From 3865859d8d3886deb19c33aa284875f39f677ebf Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 7 Apr 2025 16:52:27 -0400 Subject: [PATCH 01/69] asoiaf --- .gitignore | 1 + data-raw/HouseofHabsburg.ged | 4 +- data-raw/Targaryen tree Dance.txt | 17 +++++++ data-raw/df_ASOIAF.R | 2 +- vignettes/ASOIAF.Rmd | 73 ++++++++++++++++++++++++------- vignettes/ASOIAF.html | 46 ++++++++++--------- 6 files changed, 103 insertions(+), 40 deletions(-) create mode 100644 data-raw/Targaryen tree Dance.txt diff --git a/.gitignore b/.gitignore index c2b69572..8faabc57 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,4 @@ ASOIAF.ged .vscode/launch.json dataRelatedPairs_new2.csv +data-raw/ASOIAF_040725.ged diff --git a/data-raw/HouseofHabsburg.ged b/data-raw/HouseofHabsburg.ged index 98b7100c..fd358bf8 100644 --- a/data-raw/HouseofHabsburg.ged +++ b/data-raw/HouseofHabsburg.ged @@ -1,4 +1,4 @@ -0 HEAD +0 HEAD 1 SOUR PAF 2 NAME Personal Ancestral File 2 VERS 5.2.18.0 @@ -260,7 +260,7 @@ 0 @I17@ INDI 1 NAME /Frederick I/ 2 SURN Frederick I -2 _AKA Frederick the Handsome or the Fair +2 _AKA Frederick the Handsome or the Fair 1 SEX M 1 BIRT 2 DATE 1289 diff --git a/data-raw/Targaryen tree Dance.txt b/data-raw/Targaryen tree Dance.txt new file mode 100644 index 00000000..082c263c --- /dev/null +++ b/data-raw/Targaryen tree Dance.txt @@ -0,0 +1,17 @@ +{{familytree/start|style=font: 90% sans-serif;|state={{{state|}}}|title={{{title|}}}}} +{{familytree | | | | | | | | | | | | | JAE |v| ALY | |JAE=[[Jaehaerys I Targaryen|Jaehaerys I]]|ALY=[[Alysanne Targaryen|Alysanne]]|}} +{{familytree | | | | | | | |,|-|-|-|v|-|-|-|^|-|-|-|v|-|-|-|.| | | | | | | | | | | | | | | | | | | | | }} +{{familytree | | |JOC|v|AEM| |DAE|v|ROD| |BAE|v|ALY| |JOC=[[Jocelyn Baratheon|Jocelyn
Baratheon]]|AEM=[[Aemon Targaryen (son of Jaehaerys I)|Aemon]]|DAE=[[Daella Targaryen (daughter of Jaehaerys I)|Daella]]|ROD=[[Rodrik Arryn|Rodrik
Arryn]]|BAE=[[Baelon Targaryen (son of Jaehaerys I)|Baelon]]|ALY=[[Alyssa Targaryen|Alyssa]]}} +{{familytree | | | | | |!| | | | | | | |!| | | |,|-|-|-|^|-|-|-|-|-|-|-|-|-|-|-|-|-|v|-|-|-|-|-|-|-|.| }} +{{familytree |COV|v|RHA| | | | | |AEM|v|VIS|-|-|-|-|-|-|-|-|-|-|v|ALI| |DAE|-|RHR| |AEG| |COV=[[Corlys Velaryon|Corlys
Velaryon]]|RHA=[[Rhaenys Targaryen (daughter of Aemon)|Rhaenys]]|AEM=[[Aemma Arryn|Aemma
Arryn]]|VIS=[[Viserys I Targaryen|Viserys I]]|ALI=[[Alicent Hightower|Alicent
Hightower]]|DAE=[[Daemon Targaryen|Daemon]]
Prince Daemon Targaryen was married to Lady Rhea Royce from {{Date|97}} to {{Date|115}}, to Lady Laena Velaryon from {{Date|115}} to {{Date|120}}, and to Princess Rhaenyra Targaryen from {{Date|120}} to {{Date|130}}.|RHR=[[Rhea Royce|Rhea
Royce]]|AEG=[[Aegon Targaryen (son of Baelon)|Aegon]]}} +{{familytree | |,|-|^|-|-|-|-|-|.| | | |,|-|^|-|-|-|-|-|v|-|-|-|.| | | |)|-|-|-|v|-|-|-|v|-|-|-|.| | | }} +{{familytree |LAE|v|DAE| |LEO|v|RHA|v|DAE| |SON| |BAE| |AEG|v|HEL| |AEM| |DAR| |LAE=[[Laena Velaryon|Laena
Velaryon]]|DAE=[[Daemon Targaryen|Daemon]]
|LEO=[[Laenor Velaryon|Laenor
Velaryon]]|RHA=[[Rhaenyra Targaryen|Rhaenyra]]|SON=Son|BAE=[[Baelon Targaryen (son of Viserys I)|Baelon]]|AEG=[[Aegon II Targaryen|Aegon II]]|HEL=[[Helaena Targaryen|Helaena]]|AEM=[[Aemond Targaryen|Aemond]]|DAR=[[Daeron Targaryen (son of Viserys I)|Daeron]]}} +{{familytree | | | |!| | | | | | | |!| | | |`|-|-|-|-|-|-|-|-|-|-|-|.| | | |`|-|-|-|-|-|-|-|.| | | | | | | | | }} +{{familytree | |,|-|^|-|v|-|-|-|.| |`|-|v|-|-|-|v|-|-|-|.| | | |,|-|^|-|v|-|-|-|.| | | |,|-|^|-|v|-|-|-|.| | | }} +{{familytree |BAE| |RHA| |STI| |JAC| |LUC| |JOF| |VIS| |VSN| |AEG|-|JAE| |JAY| |MAE| |BAE=[[Baela Targaryen|Baela]]|RHA=[[Rhaena Targaryen (daughter of Daemon)|Rhaena]]|STI=Stillborn
son|JAC=[[Jacaerys Velaryon|Jacaerys
Velaryon]]|LUC=[[Lucerys Velaryon|Lucerys
Velaryon]]|JOF=[[Joffrey Velaryon|Joffrey
Velaryon]]|VIS=[[Viserys II Targaryen|Viserys II]]|VSN=[[Visenya Targaryen (daughter of Daemon)|Visenya]]|AEG=[[Aegon III Targaryen|Aegon III]]|JAE=[[Jaehaera Targaryen|Jaehaera]]|JAY=[[Jaehaerys Targaryen (son of Aegon II)|Jaehaerys]]|MAE=[[Maelor Targaryen|Maelor]]}} +{{familytree | | | | | | | | |}} +{| style="border-spacing: 2px; - +|style="text-align: left; vertical-align: top"|'''Notes:''' +|{{References|group="Note"}} +|} +{{familytree/end|state={{{state|}}}}} diff --git a/data-raw/df_ASOIAF.R b/data-raw/df_ASOIAF.R index 4a840d57..e5cdc112 100644 --- a/data-raw/df_ASOIAF.R +++ b/data-raw/df_ASOIAF.R @@ -10,7 +10,7 @@ library(BGmisc) ## Create dataframe ASOIAF <- readGedcom("data-raw/ASOIAF.ged") - +#ASOIAF <- readGedcom("data-raw/ASOIAF_040725.ged") df <- ped2fam(ASOIAF, personID = "id") %>% select( diff --git a/vignettes/ASOIAF.Rmd b/vignettes/ASOIAF.Rmd index 0491b015..69d72a76 100644 --- a/vignettes/ASOIAF.Rmd +++ b/vignettes/ASOIAF.Rmd @@ -7,12 +7,15 @@ vignette: > %\VignetteEncoding{UTF-8} --- +## Introduction -Just how related are Jon Snow and Daenerys Targaryen? This vignette walks through how to quantify their genetic relatedness using functions from the BGmisc package. While the Game of Thrones canon gives us some clues, we can use a formal pedigree-based approach to quantify their genetic relatedness. This vignette demonstrates how to compute coefficients of relatedness using the `BGmisc` package, along with basic data manipulation from tidyverse. We will also handle incomplete parental information programmatically and generate a plot of the reconstructed pedigree. +Just how closely related are Jon Snow and Daenerys Targaryen? According to the lore of *A Song of Ice and Fire*, Daenerys is Jon's paternal aunt. This would suggest a theoretical genetic relatedness of 0.25, assuming a simple pedigree and no inbreeding. But with tangled ancestries and potentially missing information, how confident can we be in that estimate? + +In this vignette, we use the `BGmisc` package to reconstruct the *ASOIAF* pedigree, handle incomplete parentage data, and compute additive genetic and common nuclear relatedness. We'll focus on Jon and Daenerys as a case study, but the methods generalize to any characters in the provided dataset. ## Load Packages and Data -We begin by loading the necessary packages and accessing the built-in `ASOIAF` pedigree dataset included with `BGmisc`. +We begin by loading the required libraries and examining the structure of the built-in `ASOIAF` pedigree. ```{r} @@ -20,7 +23,9 @@ library(BGmisc) library(tidyverse) data(ASOIAF) ``` -The ASOIAF data contains character IDs, family identifiers, and parent-child links extracted from A Song of Ice and Fire lore. + + +The ASOIAF dataset includes character IDs, names, sex codes, and parent identifiers for a subset of characters drawn from the *A Song of Ice and Fire* canon. ```{r} head(ASOIAF) @@ -28,7 +33,8 @@ head(ASOIAF) ## Prepare and Validate Sex Codes -We use `checkSex()` to ensure that all individuals have valid sex codes, repairing as needed. This is important for correct pedigree plotting and downstream calculations. +Many pedigree-based algorithms rely on biological sex for downstream calculationss and visualization. We use `checkSex()` to inspect the sex variable, repairing inconsistencies programmatically. + ```{r} df_got <- checkSex(ASOIAF, @@ -36,46 +42,71 @@ df_got <- checkSex(ASOIAF, code_female = 0, verbose = FALSE, repair = TRUE ) + ``` + ## Compute Relatedness Matrices -We now compute the additive genetic relatedness matrix (add) and the common nuclear relatedness matrix (cn) from the pedigree using ped2com() and ped2cn(), respectively. -The `isChild_method` argument specifies how to identify child-parent relationships. We use "partialparent" to account for missing parent information. -The `adjacency_method` argument specifies how to construct the adjacency matrix. We use "direct" for the additive matrix and "indexed" for the common nuclear matrix. The direct method is much faster. The `sparse` argument is set to FALSE to return dense matrices. +With validated pedigree data, we can now compute two distinct relationship matrices: + +- Additive genetic relatedness (add): Proportion of shared additive genetic variance between individuals. + +- Common nuclear relatedness (cn): Indicates shared full-sibling (nuclear family) environments. + +These are derived using ped2add() and ped2cn(), respectively. Both functions rely on internal graph traversal and adjacency structures. In this case: + +- We specify isChild_method = "partialparent" to allow inclusion of dyads where one parent is unknown. + +- We choose adjacency_method = "direct" for the additive matrix to optimize for computational speed. + +- For the common nuclear matrix, we use adjacency_method = "indexed", which is slower but necessary for resolving sibling-group structures. + +- We set `sparse = FALSE` to return full (dense) matrices rather than compressed sparse formats. + ```{r} add <- ped2com(df_got, isChild_method = "partialparent", component = "additive", adjacency_method = "direct", - sparse = FALSE + sparse = TRUE +) + +mt <- ped2com(df_got, + isChild_method = "partialparent", + component = "mitochondrial", + adjacency_method = "direct", + sparse = TRUE ) cn <- ped2cn(df_got, isChild_method = "partialparent", adjacency_method = "indexed", - sparse = FALSE + sparse = TRUE ) ``` ## Convert to Pairwise Format -We convert the component matrices into a long-format table of pairwise relationships using `com2links()`. This gives us a long dataframe where each row represents a pair of individuals and their relatedness. The function can return the entire matrix or just the lower triangular part, which is often sufficient for our purposes. We set `writetodisk = FALSE` to keep the data in memory. +For interpretability, we convert these square matrices into long-format tables using `com2links()`. This function returns a dataframe where each row represents a unique pair of individuals, including their additive and common nuclear coefficients. ```{r} df_links <- com2links( writetodisk = FALSE, - ad_ped_matrix = add, cn_ped_matrix = cn, + ad_ped_matrix = add, cn_ped_matrix = cn, mit_ped_matrix= mt, drop_upper_triangular = TRUE )# %>% # filter(ID1 != ID2) ``` +The function can return the entire matrix or just the lower triangular part, which is often sufficient for our purposes. Setting `drop_upper_triangular = TRUE` ensures we only retain one entry per dyad, since the matrices are symmetric. We also keep the data in memory by setting `writetodisk = FALSE`. + ## Locate Jon and Daenerys -Next, we extract the IDs corresponding to Jon Snow and Daenerys Targaryen. -We use the `filter()` function to find the rows in the `df_links` dataframe where either ID1 or ID2 corresponds to Jon Snow, and then filter again to find the row where the other ID corresponds to Daenerys Targaryen. +We next identify the rows in the pairwise relatedness table that correspond to Jon Snow and Daenerys Targaryen. First, we retrieve their individual IDs: + + ```{r} # Find the IDs of Jon Snow and Daenerys Targaryen @@ -89,7 +120,7 @@ dany_id <- df_got %>% pull(ID) ``` -We then filter the pairwise table to retrieve the row containing their relationship. +Then we isolate their dyad: ```{r} @@ -100,9 +131,17 @@ jon_dany_row <- df_links %>% jon_dany_row ``` -This row contains the additive relatedness coefficient between Jon and Daenerys, which allows us to assess how closely related they are genetically. We'd expect to see a value of 0.25 for an Aunt-Nephew relationship, which is what Jon and Daenerys are in the show. However, the value is `r jon_dany_row$addRel[1]`, indicating a more complex relationship. +This table contains the additive and nuclear relatedness estimates for Jon and Daenerys. If the pedigree reflects their canonical aunt-nephew relationship and is free from inbreeding, we’d expect to see an additive coefficient close to 0.25. However, the value is `r jon_dany_row$addRel[1]`, indicating a more complex relationship. + +## Plotting the Pedigree with Incomplete Parental Information + +Many real-world and fictional pedigrees contain individuals with unknown or partially known parentage. In such cases, plotting tools typically fail unless these gaps are handled. We use `checkParentIDs()` to: + +- Identify individuals with one known parent and one missing + +- Create "phantom" placeholders for the missing parent -## Plotting the Pedigree with incomplete parental information +-Optionally repair and harmonize parent fields To facilitate plotting, we check for individuals with one known parent but a missing other. For those cases, we assign a placeholder ID to the missing parent. @@ -113,7 +152,7 @@ df_repaired <- checkParentIDs(df_got,addphantoms=TRUE, parentswithoutrow=FALSE, repairsex=FALSE ) %>% mutate(fam=1, - affected = case_when(ID %in% c(jon_id,dany_id) ~ 1, + affected = case_when(ID %in% c(jon_id,dany_id, "365") ~ 1, TRUE ~ 0) ) diff --git a/vignettes/ASOIAF.html b/vignettes/ASOIAF.html index e6f72f60..9b925ee3 100644 --- a/vignettes/ASOIAF.html +++ b/vignettes/ASOIAF.html @@ -340,29 +340,33 @@

ASOIAF: How related are Jon and Danny?

-

Just how related are Jon Snow and Daenerys Targaryen? This vignette -walks through how to quantify their genetic relatedness using functions -from the BGmisc package. While the Game of Thrones canon gives us some -clues, we can use a formal pedigree-based approach to quantify their -genetic relatedness. This vignette demonstrates how to compute -coefficients of relatedness using the BGmisc package, along -with basic data manipulation from tidyverse. We will also handle -incomplete parental information programmatically and generate a plot of -the reconstructed pedigree.

+
+

Introduction

+

Just how closely related are Jon Snow and Daenerys Targaryen? +According to the lore of A Song of Ice and Fire, Daenerys is +Jon’s paternal aunt. This would suggest a theoretical genetic +relatedness of 0.25, assuming a simple pedigree and no inbreeding. But +with tangled ancestries and potentially missing information, how +confident can we be in that estimate?

+

In this vignette, we use the BGmisc package to +reconstruct the ASOIAF pedigree, handle incomplete parentage +data, and compute additive genetic and common nuclear relatedness. We’ll +focus on Jon and Daenerys as a case study, but the methods generalize to +any characters in the provided dataset.

+

Load Packages and Data

-

We begin by loading the necessary packages and accessing the built-in -ASOIAF pedigree dataset included with -BGmisc.

+

We begin by loading the required libraries and examining the +structure of the built-in ASOIAF pedigree.

library(BGmisc)
 library(tidyverse)
-
## ── Attaching core tidyverse packages ────── tidyverse 2.0.0 ──
+
## ── Attaching core tidyverse packages ───── tidyverse 2.0.0 ──
 ## ✔ dplyr     1.1.4     ✔ readr     2.1.5
 ## ✔ forcats   1.0.0     ✔ stringr   1.5.1
 ## ✔ ggplot2   3.5.1     ✔ tibble    3.2.1
 ## ✔ lubridate 1.9.4     ✔ tidyr     1.3.1
 ## ✔ purrr     1.0.4     
-## ── Conflicts ──────────────────────── tidyverse_conflicts() ──
+## ── Conflicts ─────────────────────── tidyverse_conflicts() ──
 ## ✖ dplyr::between()     masks BGmisc::between()
 ## ✖ dplyr::filter()      masks stats::filter()
 ## ✖ dplyr::first()       masks BGmisc::first()
@@ -382,8 +386,9 @@ 
Load Packages and Data

 ## ✖ lubridate::year()    masks BGmisc::year()
 ## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

 
data(ASOIAF)

-
The ASOIAF data contains character IDs, family identifiers, and
-parent-child links extracted from A Song of Ice and Fire lore.

+
The ASOIAF dataset includes character IDs, names, sex codes, and
+parent identifiers for a subset of characters drawn from the A Song
+of Ice and Fire canon.

 
head(ASOIAF)

 
##   id famID momID dadID          name sex
 ## 1  1     1    NA    NA   Walder Frey   M
@@ -395,14 +400,15 @@ 
Load Packages and Data

Prepare and Validate Sex Codes

-

We use checkSex() to ensure that all individuals have -valid sex codes, repairing as needed. This is important for correct -pedigree plotting and downstream calculations.

+

Many pedigree-based algorithms rely on valid sex codes for downstream +calculationss and visualization. We use checkSex() to +inspect the sex variable, repairing inconsistencies +programmatically.

df_got <- checkSex(ASOIAF,
   code_male = 1,
   code_female = 0,
   verbose = FALSE, repair = TRUE
-)
+)

Compute Relatedness Matrices

From 5f68290276d726e9e088e546583d877ea77e9342 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 7 Apr 2025 16:54:12 -0400 Subject: [PATCH 02/69] extendparser --- R/readPedigree.R | 26 +++++++++++++++++++++++++- tests/testthat/test-readPedigrees.R | 16 ++++++++++++++-- 2 files changed, 39 insertions(+), 3 deletions(-) diff --git a/R/readPedigree.R b/R/readPedigree.R index d79bb230..2dd48c3d 100644 --- a/R/readPedigree.R +++ b/R/readPedigree.R @@ -579,8 +579,32 @@ countPatternRows <- function(file) { #' Read Wiki Family Tree #' #' @param text A character string containing the text of a family tree in wiki format. +#' @param verbose A logical value indicating whether to print messages. +#' @param file_path The path to the file containing the family tree. +#' @param ... Additional arguments (not used). +#' +#' @return A list containing the summary, members, structure, and relationships of the family tree. #' @export -readWikifamilytree <- function(text) { +readWikifamilytree <- function(text=NULL, verbose = FALSE, file_path = NULL, ...) { + # Checks + if (is.null(text) && is.null(file_path)) { + stop("Either 'text' or 'file_path' must be provided.") + } + # read from file if provided +if (!is.null(file_path)){ + + if (!file.exists(file_path)) stop("File does not exist: ", file_path) + + if (verbose) { + print(paste("Reading file:", file_path)) + } + file <- data.frame(X1 = readLines(file_path)) + file_length <- nrow(file) + if (verbose) { + print(paste0("File is ", file_length, " lines long")) + } + text <- file$X1 +} # Extract summary text summary_text <- extractSummaryText(text) diff --git a/tests/testthat/test-readPedigrees.R b/tests/testthat/test-readPedigrees.R index 94cbcb28..5086b83c 100644 --- a/tests/testthat/test-readPedigrees.R +++ b/tests/testthat/test-readPedigrees.R @@ -181,7 +181,7 @@ test_that("if file does not exist, readGedcom throws an error", { # readWikifamilytree -test_that("readWikifamilytree reads a simple file correctly", { +test_that("readWikifamilytree reads a string correctly", { # Create a temporary WikiFamilyTree file for testing # Example usage family_tree_text <- "{{familytree/start |summary=I have a brother Joe and a little sister: my mom married my dad, and my dad's parents were Grandma and Grandpa; they had another child, Aunt Daisy.}} @@ -192,7 +192,7 @@ test_that("readWikifamilytree reads a simple file correctly", { {{familytree | JOE | | ME | | SIS | | | JOE=My brother Joe|ME='''Me!'''|SIS=My little sister}} {{familytree/end}}" - result <- readWikifamilytree(family_tree_text) + result <- readWikifamilytree(text=family_tree_text) # list( # summary = summary_text, @@ -205,3 +205,15 @@ test_that("readWikifamilytree reads a simple file correctly", { "I have a brother Joe and a little sister: my mom married my dad, and my dad's parents were Grandma and Grandpa; they had another child, Aunt Daisy." ) }) + + +# read E:/Dropbox/Lab/Research/Projects/2024/BGMiscJoss/BGmisc_main/data-raw/Targaryen tree Dance.txt + +test_that("readWikifamilytree reads a file correctly", { + # Create a temporary WikiFamilyTree file for testing + # Example usage + family_tree_file_path <- "data-raw/Targaryen tree Dance.txt" #system.file("extdata", "Targaryen tree Dance.txt", package = "BGmisc") + + result <- readWikifamilytree(file_path=family_tree_file_path) + +}) From bb9f66b86ff8c611350f12417048b4346a47f85c Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 7 Apr 2025 16:58:51 -0400 Subject: [PATCH 03/69] split Update readWikifamilytree.R --- R/readPedigree.R | 2 +- R/readWikifamilytree.R | 198 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 199 insertions(+), 1 deletion(-) create mode 100644 R/readWikifamilytree.R diff --git a/R/readPedigree.R b/R/readPedigree.R index 2dd48c3d..3faafa07 100644 --- a/R/readPedigree.R +++ b/R/readPedigree.R @@ -603,7 +603,7 @@ if (!is.null(file_path)){ if (verbose) { print(paste0("File is ", file_length, " lines long")) } - text <- file$X1 + text <- paste0(file$X1, collapse = "\n") } # Extract summary text diff --git a/R/readWikifamilytree.R b/R/readWikifamilytree.R new file mode 100644 index 00000000..6d14c41a --- /dev/null +++ b/R/readWikifamilytree.R @@ -0,0 +1,198 @@ +#' Read Wiki Family Tree +#' +#' @param text A character string containing the text of a family tree in wiki format. +#' @param verbose A logical value indicating whether to print messages. +#' @param file_path The path to the file containing the family tree. +#' @param ... Additional arguments (not used). +#' +#' @return A list containing the summary, members, structure, and relationships of the family tree. +#' @export +readWikifamilytree <- function(text=NULL, verbose = FALSE, file_path = NULL, ...) { + # Checks + if (is.null(text) && is.null(file_path)) { + stop("Either 'text' or 'file_path' must be provided.") + } + # read from file if provided +if (!is.null(file_path)){ + + if (!file.exists(file_path)) stop("File does not exist: ", file_path) + + if (verbose) { + print(paste("Reading file:", file_path)) + } + file <- data.frame(X1 = readLines(file_path)) + file_length <- nrow(file) + if (verbose) { + print(paste0("File is ", file_length, " lines long")) + } + text <- paste0(file$X1, collapse = "\n") +} + # Extract summary text + + summary_text <- extractSummaryText(text) + # Extract all lines defining the family tree + tree_lines <- unlist(stringr::str_extract_all(text, "\\{\\{familytree.*?\\}\\}")) + tree_lines <- tree_lines[!stringr::str_detect(tree_lines, "start|end")] # Remove start/end markers + tree_lines <- gsub("\\{\\{familytree(.*?)\\}\\}", "\\1", tree_lines) # Remove wrapping markup + + # Convert tree structure into a coordinate grid (preserves symbols!) + tree_df <- parseTree(tree_lines) + + # Identify columns that start with "Y" + cols_to_pivot <- grep("^Y", names(tree_df), value = TRUE) + + # Reshape from wide to long format + tree_long <- makeLongTree(tree_df, cols_to_pivot) + + # Extract member definitions + members_df <- matchMembers(text) + members_df$id <- paste0("P", seq_len(nrow(members_df))) # Assign unique person IDs + + # Merge names into the tree structure (keeping all symbols!) + tree_long <- merge(tree_long, members_df, by.x = "Value", by.y = "identifier", all.x = TRUE) + + tree_long$DisplayName <- ifelse(!is.na(tree_long$name), tree_long$name, tree_long$Value) # Use name if available + + # parse relationships and infer them + + relationships_df <- parseRelationships(tree_long) + + # relationships_df <- processParents(tree_long, datasource = "wiki") + + + + # Return structured table of the family tree (symbols included) + list( + summary = summary_text, + members = members_df, + structure = tree_long, + relationships = relationships_df + ) +} + +#' Make Long Tree +#' @param tree_df A data frame containing the tree structure. +#' @param cols_to_pivot A character vector of column names to pivot. +#' @return A long data frame containing the tree structure. +#' @keywords internal +makeLongTree <- function(tree_df, cols_to_pivot) { + tree_long <- stats::reshape(tree_df, + varying = cols_to_pivot, + v.names = "Value", + timevar = "Column", + times = cols_to_pivot, + idvar = setdiff(names(tree_df), cols_to_pivot), + direction = "long" + ) + + tree_long <- tree_long[!is.na(tree_long$Value), ] + tree_long$Value <- stringr::str_trim(tree_long$Value) + tree_long$Column <- as.numeric(gsub("^Y", "", tree_long$Column)) + return(tree_long) +} + +#' Match Members +#' @inheritParams readWikifamilytree +#' @return A data frame containing information about the members of the family tree. +#' @keywords internal + +matchMembers <- function(text) { + member_matches <- stringr::str_extract_all(text, "\\|\\s*([A-Za-z0-9]+)\\s*=\\s*([^|}]*)")[[1]] + member_matches <- gsub("\\[|\\]|'''", "", member_matches) # Remove formatting + + members_df <- data.frame( + identifier = stringr::str_trim(stringr::str_extract(member_matches, "^[^=]+")), + name = stringr::str_trim(stringr::str_extract(member_matches, "(?<=\\=).*")), + stringsAsFactors = FALSE + ) + + # Remove leading pipes (`|`) from identifiers for consistency + members_df$identifier <- gsub("^\\|\\s*", "", members_df$identifier) + + # remove summary row + members_df <- members_df[members_df$identifier != "summary", ] + + return(members_df) +} + +#' Extract Summary Text +#' @inheritParams readWikifamilytree +#' @return A character string containing the summary text. +#' @keywords internal +#' @export + +extractSummaryText <- function(text) { + summary_match <- stringr::str_match(text, "\\{\\{familytree/start \\|summary=(.*?)\\}\\}") + summary_text <- ifelse(!is.na(summary_match[, 2]), summary_match[, 2], NA) + return(summary_text) +} + +#' Parse Tree +#' @param tree_lines A character vector containing the lines of the tree structure. +#' @return A data frame containing the tree structure. +#' @keywords internal +#' @export + +parseTree <- function(tree_lines) { + tree_matrix <- base::strsplit(tree_lines, "\\|") # Split each row into columns + max_cols <- max(sapply(tree_matrix, length)) # Find the max column count + + # Convert to a data frame (ensures correct structure) + tree_df <- do.call(rbind, lapply(tree_matrix, function(row) { + length(row) <- max_cols # Ensure uniform column length + return(row) + })) + + tree_df <- as.data.frame(tree_df, stringsAsFactors = FALSE) + colnames(tree_df) <- paste0("Y", seq_len(ncol(tree_df))) # Assign column names + tree_df$Row <- seq_len(nrow(tree_df)) # Assign row numbers + return(tree_df) +} + +#' infer relationship from tree template +#' +#' @param tree_long A data frame containing the tree structure in long format. +#' @return A data frame containing the relationships between family members. +#' @keywords internal +#' +parseRelationships <- function(tree_long) { + relationships <- data.frame( + id = tree_long$id, + momID = NA_character_, + dadID = NA_character_, + spouseID = NA_character_, + stringsAsFactors = FALSE + ) + + # Loop through rows to find connections + for (i in seq_len(nrow(tree_long))) { + row <- tree_long[i, ] + + # **Parent-Child Detection** + if (row$Value == "y") { + parent <- tree_long$Value[tree_long$Row == row$Row - 1 & tree_long$Column == row$Column] + child <- tree_long$Value[tree_long$Row == row$Row + 1 & tree_long$Column == row$Column] + + if (length(parent) == 0) parent <- NA + if (length(child) == 0) child <- NA + # Assign mom/dad IDs based on tree structure + if (!is.na(parent) && !is.na(child)) { + relationships$momID[relationships$id == child] <- parent + relationships$dadID[relationships$id == child] <- parent # Assuming one parent detected for now + } + } + + # **Spouse Detection** + if (row$Value == "+") { + spouse1 <- tree_long$Value[tree_long$Row == row$Row & tree_long$Column == row$Column - 1] + spouse2 <- tree_long$Value[tree_long$Row == row$Row & tree_long$Column == row$Column + 1] + + if (!is.na(spouse1) && !is.na(spouse2)) { + relationships$spouseID[relationships$id == spouse1] <- spouse2 + relationships$spouseID[relationships$id == spouse2] <- spouse1 + } + } + } + + return(relationships) +} From 5000ed5e1d4746c6dffbd8341e1d7e29ef119786 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 7 Apr 2025 17:02:32 -0400 Subject: [PATCH 04/69] Rename readPedigree.R to readGedcom.R --- R/{readPedigree.R => readGedcom.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename R/{readPedigree.R => readGedcom.R} (100%) diff --git a/R/readPedigree.R b/R/readGedcom.R similarity index 100% rename from R/readPedigree.R rename to R/readGedcom.R From ddac2dfa7dde5647abab3d58b09edb9cc960dbb8 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 7 Apr 2025 17:13:52 -0400 Subject: [PATCH 05/69] spilting file --- R/readGedcom.R | 198 ------------------------------------------------- 1 file changed, 198 deletions(-) diff --git a/R/readGedcom.R b/R/readGedcom.R index 3faafa07..9aa8f48e 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -576,201 +576,3 @@ countPatternRows <- function(file) { return(num_rows) } -#' Read Wiki Family Tree -#' -#' @param text A character string containing the text of a family tree in wiki format. -#' @param verbose A logical value indicating whether to print messages. -#' @param file_path The path to the file containing the family tree. -#' @param ... Additional arguments (not used). -#' -#' @return A list containing the summary, members, structure, and relationships of the family tree. -#' @export -readWikifamilytree <- function(text=NULL, verbose = FALSE, file_path = NULL, ...) { - # Checks - if (is.null(text) && is.null(file_path)) { - stop("Either 'text' or 'file_path' must be provided.") - } - # read from file if provided -if (!is.null(file_path)){ - - if (!file.exists(file_path)) stop("File does not exist: ", file_path) - - if (verbose) { - print(paste("Reading file:", file_path)) - } - file <- data.frame(X1 = readLines(file_path)) - file_length <- nrow(file) - if (verbose) { - print(paste0("File is ", file_length, " lines long")) - } - text <- paste0(file$X1, collapse = "\n") -} - # Extract summary text - - summary_text <- extractSummaryText(text) - # Extract all lines defining the family tree - tree_lines <- unlist(stringr::str_extract_all(text, "\\{\\{familytree.*?\\}\\}")) - tree_lines <- tree_lines[!stringr::str_detect(tree_lines, "start|end")] # Remove start/end markers - tree_lines <- gsub("\\{\\{familytree(.*?)\\}\\}", "\\1", tree_lines) # Remove wrapping markup - - # Convert tree structure into a coordinate grid (preserves symbols!) - tree_df <- parseTree(tree_lines) - - # Identify columns that start with "Y" - cols_to_pivot <- grep("^Y", names(tree_df), value = TRUE) - - # Reshape from wide to long format - tree_long <- makeLongTree(tree_df, cols_to_pivot) - - # Extract member definitions - members_df <- matchMembers(text) - members_df$id <- paste0("P", seq_len(nrow(members_df))) # Assign unique person IDs - - # Merge names into the tree structure (keeping all symbols!) - tree_long <- merge(tree_long, members_df, by.x = "Value", by.y = "identifier", all.x = TRUE) - - tree_long$DisplayName <- ifelse(!is.na(tree_long$name), tree_long$name, tree_long$Value) # Use name if available - - # parse relationships and infer them - - relationships_df <- parseRelationships(tree_long) - - # relationships_df <- processParents(tree_long, datasource = "wiki") - - - - # Return structured table of the family tree (symbols included) - list( - summary = summary_text, - members = members_df, - structure = tree_long, - relationships = relationships_df - ) -} - -#' Make Long Tree -#' @param tree_df A data frame containing the tree structure. -#' @param cols_to_pivot A character vector of column names to pivot. -#' @return A long data frame containing the tree structure. -#' @keywords internal -makeLongTree <- function(tree_df, cols_to_pivot) { - tree_long <- stats::reshape(tree_df, - varying = cols_to_pivot, - v.names = "Value", - timevar = "Column", - times = cols_to_pivot, - idvar = setdiff(names(tree_df), cols_to_pivot), - direction = "long" - ) - - tree_long <- tree_long[!is.na(tree_long$Value), ] - tree_long$Value <- stringr::str_trim(tree_long$Value) - tree_long$Column <- as.numeric(gsub("^Y", "", tree_long$Column)) - return(tree_long) -} - -#' Match Members -#' @inheritParams readWikifamilytree -#' @return A data frame containing information about the members of the family tree. -#' @keywords internal - -matchMembers <- function(text) { - member_matches <- stringr::str_extract_all(text, "\\|\\s*([A-Za-z0-9]+)\\s*=\\s*([^|}]*)")[[1]] - member_matches <- gsub("\\[|\\]|'''", "", member_matches) # Remove formatting - - members_df <- data.frame( - identifier = stringr::str_trim(stringr::str_extract(member_matches, "^[^=]+")), - name = stringr::str_trim(stringr::str_extract(member_matches, "(?<=\\=).*")), - stringsAsFactors = FALSE - ) - - # Remove leading pipes (`|`) from identifiers for consistency - members_df$identifier <- gsub("^\\|\\s*", "", members_df$identifier) - - # remove summary row - members_df <- members_df[members_df$identifier != "summary", ] - - return(members_df) -} - -#' Extract Summary Text -#' @inheritParams readWikifamilytree -#' @return A character string containing the summary text. -#' @keywords internal -#' @export - -extractSummaryText <- function(text) { - summary_match <- stringr::str_match(text, "\\{\\{familytree/start \\|summary=(.*?)\\}\\}") - summary_text <- ifelse(!is.na(summary_match[, 2]), summary_match[, 2], NA) - return(summary_text) -} - -#' Parse Tree -#' @param tree_lines A character vector containing the lines of the tree structure. -#' @return A data frame containing the tree structure. -#' @keywords internal -#' @export - -parseTree <- function(tree_lines) { - tree_matrix <- base::strsplit(tree_lines, "\\|") # Split each row into columns - max_cols <- max(sapply(tree_matrix, length)) # Find the max column count - - # Convert to a data frame (ensures correct structure) - tree_df <- do.call(rbind, lapply(tree_matrix, function(row) { - length(row) <- max_cols # Ensure uniform column length - return(row) - })) - - tree_df <- as.data.frame(tree_df, stringsAsFactors = FALSE) - colnames(tree_df) <- paste0("Y", seq_len(ncol(tree_df))) # Assign column names - tree_df$Row <- seq_len(nrow(tree_df)) # Assign row numbers - return(tree_df) -} - -#' infer relationship from tree template -#' -#' @param tree_long A data frame containing the tree structure in long format. -#' @return A data frame containing the relationships between family members. -#' @keywords internal -#' -parseRelationships <- function(tree_long) { - relationships <- data.frame( - id = tree_long$id, - momID = NA_character_, - dadID = NA_character_, - spouseID = NA_character_, - stringsAsFactors = FALSE - ) - - # Loop through rows to find connections - for (i in seq_len(nrow(tree_long))) { - row <- tree_long[i, ] - - # **Parent-Child Detection** - if (row$Value == "y") { - parent <- tree_long$Value[tree_long$Row == row$Row - 1 & tree_long$Column == row$Column] - child <- tree_long$Value[tree_long$Row == row$Row + 1 & tree_long$Column == row$Column] - - if (length(parent) == 0) parent <- NA - if (length(child) == 0) child <- NA - # Assign mom/dad IDs based on tree structure - if (!is.na(parent) && !is.na(child)) { - relationships$momID[relationships$id == child] <- parent - relationships$dadID[relationships$id == child] <- parent # Assuming one parent detected for now - } - } - - # **Spouse Detection** - if (row$Value == "+") { - spouse1 <- tree_long$Value[tree_long$Row == row$Row & tree_long$Column == row$Column - 1] - spouse2 <- tree_long$Value[tree_long$Row == row$Row & tree_long$Column == row$Column + 1] - - if (!is.na(spouse1) && !is.na(spouse2)) { - relationships$spouseID[relationships$id == spouse1] <- spouse2 - relationships$spouseID[relationships$id == spouse2] <- spouse1 - } - } - } - - return(relationships) -} From 48db447507ee6380c7af6802c3d48813e406cf03 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 7 Apr 2025 18:38:40 -0400 Subject: [PATCH 06/69] refactoring --- R/readGedcom.R | 259 +++++++++++++--------------- data/royal92.rda | Bin 68816 -> 69068 bytes tests/testthat/test-readPedigrees.R | 21 ++- 3 files changed, 135 insertions(+), 145 deletions(-) diff --git a/R/readGedcom.R b/R/readGedcom.R index 9aa8f48e..1fd039ed 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -120,38 +120,34 @@ readGedcom <- function(file_path, next } # PERSONAL_NAME_PIECES := NAME | NPFX | GIVN | NICK | SPFX | SURN | NSFX - if (num_rows$num_givn_rows > 0 && grepl(" GIVN", tmpv)) { - vars$name_given_pieces <- extract_info(tmpv, "GIVN") - next - } + result <- process_tag("GIVN", "name_given_pieces", num_rows, tmpv, vars) + vars <- result$vars + if (result$matched) next # npfx := Name Prefix - if (num_rows$num_npfx_rows > 0 && grepl(" NPFX", tmpv)) { - vars$name_npfx <- extract_info(tmpv, "NPFX") - next - } + result <- process_tag("NPFX", "name_npfx", num_rows, tmpv, vars) + vars <- result$vars + if (result$matched) next # NICK := Nickname - if (num_rows$num_nick_rows > 0 && grepl(" NICK", tmpv)) { - vars$name_nick <- extract_info(tmpv, "NICK") - next - } + result <- process_tag("NICK", "name_nick", num_rows, tmpv, vars) + vars <- result$vars + if (result$matched) next # surn := Surname - if (num_rows$num_surn_rows > 0 && grepl(" SURN", tmpv)) { - vars$name_surn_pieces <- extract_info(tmpv, "SURN") - next - } + result <- process_tag("SURN", "name_surn_pieces", num_rows, tmpv, vars) + vars <- result$vars + if (result$matched) next # nsfx := Name suffix - if (num_rows$num_nsfx_rows > 0 && grepl(" NSFX", tmpv)) { - vars$name_nsfx <- extract_info(tmpv, "NSFX") - next - } - if (num_rows$num_marnm_rows > 0 && grepl(" _MARNM", tmpv)) { - vars$name_marriedsurn <- extract_info(tmpv, "_MARNM") - next - } + result <- process_tag("NSFX", "name_nsfx", num_rows, tmpv, vars) + vars <- result$vars + if (result$matched) next + + result <- process_tag("_MARNM", "name_marriedsurn", num_rows, tmpv, vars) + vars <- result$vars + if (result$matched) next + # Birth event related information if (num_rows$num_birt_rows > 0 && grepl(" BIRT", tmpv)) { if (num_rows$num_date_rows > 0 && i + 1 <= file_length) { @@ -190,118 +186,85 @@ readGedcom <- function(file_path, next } - if (grepl(" SEX", tmpv)) { - vars$sex <- extract_info(tmpv, "SEX") - next - } - # Individual Attributes + # Attribute tags using process_tag() + for (tag_field in list( + c("SEX", "sex"), - # CAST caste - # g7:CAST The name of an individual’s rank or status in society which is sometimes based on racial or religious differences, or differences in wealth, inherited rank, profession, or occupation. - if (num_rows$num_cast_rows > 0 && grepl(" CAST", tmpv)) { - vars$attribute_caste <- extract_info(tmpv, "CAST") - next - } - # DSCR physical description - # g7:DSCR The physical characteristics of a person. - if (num_rows$num_dscr_rows > 0 && grepl(" DSCR", tmpv)) { - vars$attribute_description <- extract_info(tmpv, "DSCR") - next - } - # EDUC education - # g7:EDUC Indicator of a level of education attained. - if (num_rows$num_educ_rows > 0 && grepl(" EDUC", tmpv)) { - vars$attribute_education <- extract_info(tmpv, "EDUC") - next - } - # IDNO identifying number - # g7:IDNO A number or other string assigned to identify a person within some significant external system. It must have a TYPE substructure to define what kind of identification number is being provided. - if (num_rows$num_idno_rows > 0 && grepl(" IDNO", tmpv)) { - vars$attribute_idnumber <- extract_info(tmpv, "IDNO") - next - } - # NATI nationality - # g7:NATI An individual’s national heritage or origin, or other folk, house, kindred, lineage, or tribal interest. - if (num_rows$num_nati_rows > 0 && grepl(" NATI", tmpv)) { - vars$attribute_nationality <- extract_info(tmpv, "NATI") - next - } - # NCHI number of children - # g7:INDI-NCHI The number of children that this person is known to be the parent of (all marriages). - if (num_rows$num_nchi_rows > 0 && grepl(" NCHI", tmpv)) { - vars$attribute_children <- extract_info(tmpv, "NCHI") - next - } + # CAST caste + # g7:CAST The name of an individual’s rank or status in society which is sometimes based on racial or religious differences, or differences in wealth, inherited rank, profession, or occupation. + c("CAST", "attribute_caste"), - # NMR number of marriages - # g7:NMR The number of times this person has participated in a family as a spouse or parent. - if (num_rows$num_nmr_rows > 0 && grepl(" NMR", tmpv)) { - vars$attribute_marriages <- extract_info(tmpv, "NMR") - next - } + # DSCR physical description + # g7:DSCR The physical characteristics of a person. + c("DSCR", "attribute_description"), - # OCCU occupation - # g7:OCCU The type of work or profession of an individual. - if (num_rows$num_occu_rows > 0 && grepl(" OCCU", tmpv)) { - vars$attribute_occupation <- extract_info(tmpv, "OCCU") - next - } - # PROP property - # g7:PROP Pertaining to possessions such as real estate or other property of interest. + # EDUC education + # g7:EDUC Indicator of a level of education attained. + c("EDUC", "attribute_education"), - if (num_rows$num_prop_rows > 0 && grepl(" PROP", tmpv)) { - vars$attribute_property <- extract_info(tmpv, "PROP") - next - } + # IDNO identifying number + # g7:IDNO A number or other string assigned to identify a person within some significant external system. It must have a TYPE substructure to define what kind of identification number is being provided. + c("IDNO", "attribute_idnumber"), - # RELI religion - # g7:INDI-RELI A religious denomination to which a person is affiliated or for which a record applies. - if (num_rows$num_reli_rows > 0 && grepl(" RELI", tmpv)) { - vars$attribute_religion <- extract_info(tmpv, "RELI") - next - } - # RESI residence - # g7:INDI-RESI An address or place of residence where an individual resided. - if (num_rows$num_resi_rows > 0 && grepl(" RESI", tmpv)) { - vars$attribute_residence <- extract_info(tmpv, "RESI") - next - } + # NATI nationality + # g7:NATI An individual’s national heritage or origin, or other folk, house, kindred, lineage, or tribal interest. + c("NATI", "attribute_nationality"), - # SSN social security number - # g7:SSN A number assigned by the United States Social Security Administration, used for tax identification purposes. It is a type of IDNO. - if (num_rows$num_ssn_rows > 0 && grepl(" SSN", tmpv)) { - vars$attribute_ssn <- extract_info(tmpv, "SSN") - next - } - # TITL title - # g7:INDI-TITL A formal designation used by an individual in connection with positions of royalty or other social status, such as Grand Duke. - if (num_rows$num_titl_rows > 0 && grepl(" TITL", tmpv)) { - vars$attribute_title <- extract_info(tmpv, "TITL") - next + # NCHI number of children + # g7:INDI-NCHI The number of children that this person is known to be the parent of (all marriages). + c("NCHI", "attribute_children"), + + # NMR number of marriages + # g7:NMR The number of times this person has participated in a family as a spouse or parent. + c("NMR", "attribute_marriages"), + + # OCCU occupation + # g7:OCCU The type of work or profession of an individual. + c("OCCU", "attribute_occupation"), + + # PROP property + # g7:PROP Pertaining to possessions such as real estate or other property of interest. + c("PROP", "attribute_property"), + + # RELI religion + # g7:INDI-RELI A religious denomination to which a person is affiliated or for which a record applies. + c("RELI", "attribute_religion"), + + # RESI residence + # g7:INDI-RESI An address or place of residence where an individual resided. + c("RESI", "attribute_residence"), + + # SSN social security number + # g7:SSN A number assigned by the United States Social Security Administration, used for tax identification purposes. It is a type of IDNO. + c("SSN", "attribute_ssn"), + + # TITL title + # g7:INDI-TITL A formal designation used by an individual in connection with positions of royalty or other social status, such as Grand Duke. + c("TITL", "attribute_title") + )) { + result <- process_tag(tag_field[1], tag_field[2], num_rows, tmpv, vars) + vars <- result$vars + if (result$matched) next } # relationship data # g7:INDI-FAMC ## The family in which an individual appears as a child. It is also used with a g7:FAMC-STAT substructure to show individuals who are not children of the family. See FAMILY_RECORD for more details. - if (num_rows$num_famc_rows > 0 && grepl(" FAMC", tmpv)) { - if (is.na(vars$FAMC)) { - vars$FAMC <- stringr::str_extract(tmpv, "(?<=@.)\\d*(?=@)") - } else { - vars$FAMC <- paste0(vars$FAMC, ", ", stringr::str_extract(tmpv, "(?<=@.)\\d*(?=@)")) - } - next - } +result <- process_tag("FAMC", "FAMC", num_rows, tmpv, vars, + extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)"), + mode = "append") + vars <- result$vars + if (result$matched) next + # FAMS (Family spouse) g7:FAMS # The family in which an individual appears as a partner. See FAMILY_RECORD for more details. - if (num_rows$num_fams_rows > 0 && grepl(" FAMS", tmpv)) { - if (is.na(vars$FAMS)) { - vars$FAMS <- stringr::str_extract(tmpv, "(?<=@.)\\d*(?=@)") - } else { - vars$FAMS <- paste0(vars$FAMS, ", ", stringr::str_extract(tmpv, "(?<=@.)\\d*(?=@)")) - } - next - } + result <- process_tag("FAMS", "FAMS", num_rows, tmpv, vars, + extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)"), + mode = "append") + vars <- result$vars + if (result$matched) next + if (verbose && i %% 1000 == 0) { cat("Processed", i, "lines\n") } @@ -383,8 +346,7 @@ readGedcom <- function(file_path, #' @param df_temp A data frame containing information about individuals. #' @return A list mapping family IDs to parent IDs. #' @keywords internal -createFamilyToParentsMapping <- function(df_temp, datasource) { - if (datasource == "gedcom") { +mapFAMS2parents <- function(df_temp) { if (!all(c("FAMS", "sex") %in% colnames(df_temp))) { warning("The data frame does not contain the necessary columns (FAMS, sex)") return(NULL) @@ -411,10 +373,6 @@ createFamilyToParentsMapping <- function(df_temp, datasource) { } } } - } else if (datasource == "wiki") { - message("The data source is not supported") - return(df_temp) - } return(family_to_parents) } @@ -425,13 +383,11 @@ createFamilyToParentsMapping <- function(df_temp, datasource) { #' #' @param df_temp A data frame containing individual information. #' @param family_to_parents A list mapping family IDs to parent IDs. -#' @param datasource A string indicating the data source. Options are "gedcom" and "wiki". #' @return A data frame with added momID and dad_ID columns. #' @keywords internal -assignParentIDs <- function(df_temp, family_to_parents, datasource) { +mapFAMC2parents <- function(df_temp, family_to_parents) { df_temp$momID <- NA_character_ df_temp$dadID <- NA_character_ - if (datasource == "gedcom") { for (i in 1:nrow(df_temp)) { if (!is.na(df_temp$FAMC[i])) { famc_ids <- unlist(strsplit(df_temp$FAMC[i], ", ")) @@ -448,10 +404,6 @@ assignParentIDs <- function(df_temp, family_to_parents, datasource) { } } return(df_temp) - } else if (datasource == "wiki") { - message("No parents information available for wiki data") - return(df_temp) - } } #' Process parents information @@ -477,11 +429,11 @@ processParents <- function(df_temp, datasource) { return(df_temp) } - family_to_parents <- createFamilyToParentsMapping(df_temp, datasource = datasource) + family_to_parents <- mapFAMS2parents(df_temp) if (is.null(family_to_parents) || length(family_to_parents) == 0) { return(df_temp) } - df_temp <- assignParentIDs(df_temp, family_to_parents, datasource = datasource) + df_temp <- mapFAMC2parents(df_temp, family_to_parents) return(df_temp) } @@ -576,3 +528,36 @@ countPatternRows <- function(file) { return(num_rows) } +#' Process a GEDCOM Tag +#' +#' Extracts and assigns a value to a specified field in `vars` if the pattern is present. +#' Returns both the updated variable list and a flag indicating whether the tag was matched. +#' +#' @param tag The GEDCOM tag (e.g., "SEX", "CAST", etc.). +#' @param field_name The name of the variable to assign to in `vars`. +#' @param pattern_rows Output from `countPatternRows()`. +#' @param line The GEDCOM line to parse. +#' @param vars The current list of variables to update. +#' @return A list with updated `vars` and a `matched` flag. +#' @keywords internal +process_tag <- function(tag, field_name, pattern_rows, line, vars, + extractor = NULL, mode = "replace") { + count_name <- paste0("num_", tolower(tag), "_rows") + matched <- FALSE + if (!is.null(pattern_rows[[count_name]]) && + pattern_rows[[count_name]] > 0 && + grepl(paste0(" ", tag), line)) { + + value <- if (is.null(extractor)) extract_info(line, tag) else extractor(line) + + if (mode == "append" && !is.na(vars[[field_name]])) { + vars[[field_name]] <- paste0(vars[[field_name]], ", ", value) + } else { + vars[[field_name]] <- value + } + + matched <- TRUE + } + return(list(vars = vars, matched = matched)) +} + diff --git a/data/royal92.rda b/data/royal92.rda index 357f1aba690c24fe19fb45b49b1111b5a999cbfd..4a10b174c582e692825f6afe8e14ff1b069d9978 100644 GIT binary patch literal 69068 zcmV(pK=8l)H+ooF0004LBHlIv03iV!0000G&sfaoDXH)OT>vQ&2UKVgRpfkl* zs)A-(1?mrGpRD!ZGl(jIKV0o498AZQJr5ThUTo6G?CiTsN^@9Pn{Z4z+$o9g9m4$3ttE zj(>y6)vM4N{K~4@i*|74svXGSp4GB&zC{#IhlXRO$5Zmvk7S+AXasVgv1SRjZ?=Ec z+B}sXrtE{$^P^cxbgdxp9SK-vn;*uOO`9c4%8?csI)XYMFsHWUHtOBM=yFqrcTZmz5cBB*d4> zKY|~x!efGdWC??VLB(5g&V-cZF08PQm&mbsJmbO8IKPh8z7;x9$%(96liM1cOhHVQ zG0$QWgWDVHgx8Q4>m^rWpr2$&_Uj8j3Q$w8%x^If1JOYl@d8EehQUBG1QN!q&xcRD= zE(bEBIn<>bS2I+qt#7;#+*?>!Agd+DkLc2YgPohuEUj@GIO-yde%3BA=K1x9(mQU7 z)It3D2dr81A2+HP-@7>0cehp>4@U;Pn=vuOzqdtH-&c2A<1xeLb4JkVw3(D7;9ILj zui>%4i?L`svXgdVxlpf(!{ut7vJNj*W3Uj&9yk7V8c%=p;-n>{|IF?52*~8cYcmV3 zz)|JO4B^*)-~3cLZA-*;h;{hn!L&gABCA+GfW@_=e$q9Lc!Vr(f|f!dQXk?c*p-byAGnY_2N71>o2IErB~Z?jI${S7X=Fd>9+c3!4&6-J@S313n8GM z)yEzaqr6o(t}YQz7Q~VWG+l0VNf3LM-%%nGWl4HzMiRGI!@Lv$ zH)X@kDj$kT$S|lyX4KG1NfxB)AI%b{JL>mRdoWGic%k^nC1BxmC3m&D$sY^n7)7@r zLZY(?0-xh8jUFW@;2QH`r`<8DMn#id#`tX|#m{BPamGhac}qs(b>B#W&mN-5#@Q5G z3W$&>0l_;+LU7ZcMamJIbnLVy_CS`&&2+}YQlx260h!bSEj>tN0C8;wr7y+`d)cuM zfso~Q4W&jHN|hgg`a|_~MVd8T41I%~ZzBy~;_7;gA*g@xi{|Q6ZHs*j{O8ac#RFz5 zx)%(dESN`7a7n{+YWFLS`K{&GL)9RH5R5%u_Bw#M zgRZjF<|oPYEx?6hb{bayFeG)^4h3X~FC{X2*Z0`lc~zu%QJ;G`_9tq3I0fuIG4V3q(bNGVa?>S*gPl;t zP>f{+A9>e86PK;(%edRsK_s1)yGA*r3nEUOR8__duIC*8N^W6+&ewBtMlZfT2w%1c zyKPj;Q1#+iD9+51jsjuA5RK znu2ePQqPjW!bI1=4!P^|Au_jh!Sk~C=@{TnAH)g*hWZQ_A5dhINM=1G> z-@%Kuu0omBLcm$2!U8zWeO`Bu3p^o zb8P~>-uiI&G6h$Fbq)F^jTE3#jpiSFcc;<1*~-eVuFu}UuaP>%-yMf&^ok0*Kaqm< z>{KB-lLai+le^#Kd9w3jXwn>j%}Es3g+mZ^Yfbc0k6I+UvGT> ziJA&NsZ1cf*uY{5fT$svT9y~my*3l!akSe#O|6}Bdidq(`9GzquK8)Q8=KVpRC^!gV&HlaxPD!02l3pFeFO8!IgO#9cH|{P?Q3wo zt)@gn58KbJCK6O2S1yJU+gApy7^VV z$}2U))d28mWSacDf-}71K?=vHLMvi!ER0U_YlaX+Q%ss#x8!3UkpC*FG@i%sjbXdl z5t3gQRA0sBz>R*l;a8AX%d-Gw0lMx;Mbt)~3y&j85Fmox4XWyD0x480iFg;VrfY_4 zKpseJ=@M6f#VZ7`A%f>2P!=%tE64TbJkd-n(+QrUN4@@t4%g&`Jgfbu%i7%HP5))) zx7sPYSyi{TNOpBj$i?NCU5__+>Jg&Opa1^ifv|5!$S)T@t;~|K_g;^23_ylt4!eQ# zKDS=DJVLNM|H*3-MsU)(on&27QOYuZNnXDZ}4%kZiv!%)rzx;Mt3~S!k=6#8wKk9xsc2RsbV$Lkj zWCKtCwqq_H8mjs!+#mP3CXV_E&6*d#YwNS`n6{OGa=|r}+MK4!ArADa)N(~Vz$aje zDd|ziC0M-EvnN?&u645dB87b1AMQH?RI^Hs*r>cwZA(|c!=q|hgv;nNZf?B@iU35O z*Zim;32W8zZaqo4y3n33mi1)P9&v=wP-(7#%!dusLc0Ah-TJ39(n5LM0kE4PM?WG? z%hqA7X-kLQLl2N3MQ!!wSN3Rn6@I@bO|WfsUo%Vqdc-!E2~U(A`YN?uI2gq-Q?hiJ z#b>gZ_F-4J;Of4-W@D|MIB+`BsZ**%Z_{|MikYr4|JjsT@biw7nk519__*eBHu#|R zm82H;bo>ieNfoN13b{U{3y>%N1b$G;z~-yjR2;eiROj2rW}{%P?I&J(7h(-^6$T;Ym{y5$qAbosA1l0ccwyOUrHL=QgFm5lmY!wJjK z9b#-N#vaEZ9USDf^?p<{5t#hH?X`|~I?8vrVT|GuyQ$01z!x_5bG`O`V7CAcu><1F zUN8zT$M=Jj3sH_<4D=*NnMpdCPOD?`@4E4P3#p|j8?_z};nv`95jr*SvdAh;iS|s- zPJ?@9hskdfLDA_phBPCp5mCsP>bOJK@p!7V11EG;i-Gs;3QM+kS2bIE+4MMcxHuV6 zj4}pfD^=(b&lVpCJsR%$jk-9~%g)ji*CwEXG*PbmDgTW6UpgZqLA~GEEE#|{{iuam zZ{g|D!FYG4)kRF;RK>)ig+X@Z(1`}WNPxdu-3Lxg?&99#+p9$h<^Uxt}DOdyS7n#Ub`|Y$t&>qWn`2>qTtxt`rU1;m@1wLv~_ZP zD&lf}3YVMg^K#>m3H*j-rdU@iLz$*9Vgx6krc2p zC*g0A5;77TPR)3*>EK_)E*XWi+TY-HIn&cp^GRNME~8sOI!b>`qmVx(g{aaEgDk$M;Z?$JN$fb02Eob3To`vU5B@3SPo*T2an*rgPiSDIZA zP9#EWyuUX*+JPrN+46pDnS0fWm5F#S(DN#>OP2)P!8Zvk-uOl##rvn2pYsjv(9)=l z5yZC6LDxsFPAx=kM$!mB9}-*peVP7q^9Ky6Zt(q#Cq=QU>eu0`R3*0rS(M3_-vIa+ zzw90GvYDh#ILA3m6s^;IH2PQ+lS8&ZGkLLC=UccfD1LBq70o6gFx@v-(k6oz=v;=d z)f9yxPu!D{V7O;hR&?ct=ETa>qxT%QlT76_Qz?7)f-rFW{Pegec~bq=X=@@=>5Kj( zokNzV=~A*^N=m!Mj+~miVFjtr6}t?w{mo4ys49wp#(nny5vhoL@`%3ZNWDwzWD+uT z^&=Wo<@L{D+|yNn%yW4!44l+R*-eW-ab~jycYAU5t#$AYqA~&$D9wJ3&<=E$s*6v z`ta`vJbO~pFTE@Q8mX<7m?W-UrgDXJMk4$P&<|%RPj)nRbnt+7hDsB)VUt`kEeJH%$C|+S zl*tnw=I2{(C5yWi+3?U`n*38-)>K2|5!#sI&Mz16CyVBIr{mrpvP{1K9F8EkS85Ra-t@Jb;u|8(&9!2P~{KhBC??8>IevLc-?{hpp&&?3OPZ`x*=ju5lx?!G z07^0y7qGlr7nP=lwE{`N>@Jj|?1N-FCHeSG@{)~y%eVinS5)!LkVc1a$#OTGf~3u; zxqRzCx1t#a2u7aOW<8F^I}f=%=+?Y8B(S?>{G$2N8A7s zFuz(VC?7~tMFcq8)AuHv@#48d-!wO*569L4uOzi_(uVYdp5@j1y0*pTxL#Zr0O1+k zc($-PjLH7$K9ckTMJ74Mn=&Gm_ZBu!1-xRp=FsDRDL%U>N`-xTz(#Oo&C82EW{WIi}^ip_U%Ya7QG;A0R zGf(qW(su2(30Dnm6UEdM3Q8A>@et2ULPa$tFyc4F!U@tVY;CKY5~OB>G?@NfZ!CWY zkILtBs)8#RlSzX#$|ZUBLd_drKhzJmtg6WVj2A`FG9%(U`RLZl+6e}sdRp*0@oyWZ zGgjbh<2Z?1VK;1~^t3%0wWu&_0*$-K@bviue;TYa^I~+HW#$99eCYDwYA=p{*9MHX zHdQEQ9RU{Id47EPtJp#aN=CP_Q#Z|?R&QncbW{v9KPx`N3Wji#ci_^jaoN2B<^dAQ zt0@Pe&Z9U8hT6aLy!Xoh4{`ev9Tq-=My9ioPrh-L@NT8*3Q>I33s&iCi2d@nQ*WuW zv?6_v1LryV*vS7%lqP#+c`oxHrATCdqvWaHkm5CZ8jINfyp26S0BAuCyPsN5UQDW! z?NqVAA--z?7Tawuo5|HW?ui_D4g^?Q6;CSk;wNX;)U_RT9PYDQMdVGLni~%pNU{fT z%Njz1qXVW<&BF{gmqcdv=yv57sIM!k!u7EU$mEG;T#;Mx0fB|#Z$Mg$q!Jja8PBC7 z*M!dRLK&zHA_0vP6tI2QLCr|16r^n;lZMrI>>107SXZ38={Nw6gd(C~q zhFG@AK8d_(7iz^wo}Uncrqe%}hyht(nwv)NbHjpWy(pS01r@e8MjE}NZg)C#4lIp# zfdmaS-hpXqjOGgcUfIq-LqK|4zjcmhWa{c`w7+_J)K7A;eA+0mJLB6MuBV;VOl@B`^r!z(FyyIQqQ|#6*Z%x_)F4Va*fzPhN&ZkbieewNI?|Y5yD4 zc@@sbkcSky03&2A@?o2Znv`88B8?+Gy3H2)T1Tpy+a4oc0splS?bn+{xnt!lq{@?U zLsV>Rg^(?rH4kDEC_b#Fgai&Mcb0mq24P}+;MA36fNJ8>(g2d~FKqP-8sFk5D$V4( zbKKU*GQ>P-wH-j}!lOy2ISgHh-=Mw~_CFx)Z#Q-gad04F8mmK|D0FGsZ~XqFha(r+ z2;pri9o4LdD>tNJe*GUk_Gz!P!Cc#O%=4%1>k&@7X}#2}Y%jhumCXv^IC+~RR)eM;+-aiWg`yd;dp}P};aNUpu>8)o({ljBSBk&73*Fc^K$+R*cjOS|s_@4N9gl(Q4?M;nK9) z1;>2zpnT*Dqv!c1g~1XF&)!jaQ7FbVL$d+^;-c4Wsuh>)|JjA20d~P64v<+$=mlux za`}1f_OFwag^I*HMt0c7waqS6;GO-z84Ar+QB2Ox^? zc~!mJarn2TN@=_z4T*BBnh`NFZCVOUAGfbG%a&oQtip?;O5aiDSdB`H6-%X6KrY~y zI#=E|+x(z0+QOwDrLC!~y&r0+1n?`e+57{b++FWLVs9ZiYXzeh5E=_wsSSe()ibVj zY_c{Wb5bK}pqSRKU6hOy6p$CLj{Nv>(4B7rF^^1rk9CIxopZ)D6c^D%vLMyF{+sS- zhuy{~L|Uaul<&^uUxi@H-W!)eO4)DB&UF=K+tCmGD?|;58BTC+XPu!Y+D`AR-yTl?K?lol?U`N$^Pc3&16R^0xr* z2d6nSy0o-`2c6%cFkUUb04rhwMH`$?8?`jdhX5>Xqp!FS^aC|5bbAlFmQY>75L3`j zO6V#?W5s+Bbz7g0#z4l z*-TSCQjIsNpJ!{UB9_3NIvA@R8MOQp2zB zO@lT*ZGHMADXp+P#kX-_dVcm9TAUNS;1Y|@VO(}s+Y4on=kmAu3`(j5fkM?w!C3nr z3Dje7j^IRZ$WNA<%wagOWiH)>wym=C{I3Zz-5H>g_AyY7q!B)hGA?tgjrtv<`X&C9 zW15}$#CdC)lYKGPC;#GyUArQN?IOyQMVLaQG75>@=>rp|{mmK8S6)jXM8s#LqzWrJ zgSj$F%+;gCG~6TI7pl9awA><{=+2!NI92xs)T=U5+vC+=%(a7wpDyArCcL{5Dd3sz zbWxV~AP?8n!)c!m|D~5<9Ld(%zK3Z6Dtn2u+5)NH zSOChKoZ6fj19L%Nlzh9KM$6W$lj~wDbg_Go(UZMPdKTpuQpvytw<(%iWQF#2`(3yS z9S;%-@gU^uTOUwvQP8_U^p2oHv~B|@NLJFLjNWOlz9p`gL`&=2zzy6e26o&#Q=?p; zLbhXS?l$bUozw#J!S4Y@#h4OOXng68Q3WT03=C1y?3QvmZ!yn_D4s1R@6nE)9u1)( z%`bi^0y$Wl>yB!`n^Af7TnlWY49yh#*>$VREF_I1f90*p8mz(j{foe=;={A~Jow40 zojs}xu-YZ9@&$^TNvEJB;BqT@nlQUmW`G7hs{(h<2or z!sYHl&rDAT70&b(okqI8=5HkT?c`AJ{%E0eF=zV!c`e~&0w?Pe0}?b8oz*D?dc>AD z_}qi=0v?odeJtP->6jS|pPoQ}OX&#qpses5M>%QA(?I#?Au8jgaH+NhPt-KS zygozTHYb%y2OsY53n#gd$X5e3mlHM%!gDj@5ImRqM1nSxHT<2ZW?vURd_@sKQ%czS zH2vIM`DXW3H+^6!0pwc}q{>Ua=5gtuD2{R1-C&O%v`^ACGy~;!J8b|dony7Ax1=xj zoJi||GR~dMWl91N$#5LJH67c+pxR(SfG5ZrkbKv(s-8EG=!aWPz*(s(U49#~@dnbI z?_wV%+#dU?Fj*R8QraOMfD3Gm|ApG{ZQ@A~6lvU>NLV>|_T|jhs2VU<%7||!!i@pS z(c)9IgWxJRb0XM^c(2CXZ~f6LQLx%8$UrIl8#&QZ-!BCi(sQ(1f2gi6=cD3iw>&!A z5@d&l&jB`Zx>2Dv=CYI*H1AiQ7-(SsWJ~SLvU+#zZ3(433eVGYM%{02w0Vx3ZTo#v z%H)8%ruD>4*BI9YLt*&?7!qdVd|}yy~I=3 zOgj&q)?`Y4s0$r04KPDh%G>zsC*Jk2qR3*(lLR()$;P`mvzTU_ZC*_911j!mscR{t z4mc#a&nwdq&G95x56}6%Ckg|cR<|`~nR_Y=Jg^&wLF!f`FTU+UgG<6VnMqVp^npB? zMWP6CeWaxOXh(}H)lCcUF!}U-Okm&}_%$h`?rsQpsYei_^j&U5@=`voWp^W}-kvfE zbvI}h()2u9?H!BT>wS;wI`&{vWqi$_-p=r;29IAB*~bb;W8g~hAz_$$<{mkD+KnW& zYKI3<+tlAbHY&v`K^gNbh!NbVwEc&@u8O=KA*M_;PW9f_YeWCHzl@)IhmB(@_eLI! z#^{bp*QiFrO!a%$xw+EZQ0Ddwr^Sjhyb$ZsD;glKWSfY}o%wugMWD72pu+o7z=Fw} z=r63gs`Pe<@ITJ9=(iB$N;W?*e?w_l zSu2LykBQmGw1}bxK9GH=WwQFPjzGR9_7HY#8yxYJ?g*2$%U&uls7tJ9w#-j@yNax2 zE5_}c+kq8yG9b+EDlhP&+J7^`+r=lP0PYOKhNfF)2y>WwiTZ8A`455h8un?n-w?i3 z>3Jx#Z`0zaZmLK|E#2q7gj_d89r4oxdnxL9t*s~#3o8@~v`h}AeotEbf{i52@NqZ4EA25ryXYS%7G8 zQnpEbnb2<5Vj9zlv_o9rTMbkOO!4Nc*C@8}ugbP}?j4e%1+8j>-2vHdhdG>WDB=Iw z?X$ja8je;Qw#@ei*={y}1bo8=C_UyJ@N-*G*-VICalyW3;yWAbvtG4!{Zqo&TSGLf zOxTri4XVDUW8tdREqB?EsNudU*X5@EoJSLl6ny8GM#Y}ycWG-GqfsV=t#1|@L|h`a zqtW+=#A()_yVY_DAX{)3PX8g?834D0wwdFm=OX#XUW~!P-=d!L;!9xOm3y0thXW$i#Fm3u zOj>KS$hcpy6mp$h5R$En8j)the*@X-tWJ|=5V-tpvd*z-CGOlJdVjff^!sGf zK{xMKPtH3A+?wz>r}rLW$Ymq~(MyZhkGeeO&dfE__#D6P_x^tuYubfSs97+yU2pNl zOMYhHK8=1UPW3pst>B{U)&pp4O}g3e8Mx(WC$$k%Ptg<~@FTX7{hT;Zz#lFXV;bN4 zOvBLG_gf8_gf@1J!L%M|o5V|uKYxJoEIOI=OwEwY$W%YG_yz=6&LNN{0>^CFdE=0aBO#BzAe%zq z9_o>#_ZAJDCy<{ld-gY%bMT|8l+)U>{t$w(G!yIDl9(s(R80ls`eR;nyB-KLYk*37 z-%2=jd8e0^Q2Q0|YH0Vh*@rMTnZr;838K{&vaO*2{&V_ukHhGw$$?~rAd zTQM)g1%Noe{#5!mOFYS=0682!X&7eq1?-bP5z#lgFT0~#L^_%lJ9BTyjzeWdh2@q z6?Qd^4z(YK+cavv{#MKxic>znKJCrKF4X&2j{2W~k+?j^k>q}7A3Ha-KYE?qGzMnr zv_r!&>QYd0(ZGDoF|n|s2FFvk9zod}nVMr1SO5Bw z-#zVGcDFZ-4~wcVNXPF99?uU!$a1809r55yjh-YZ|_+BI2@%(F?1_ zb>rYmJ|>xQBRGYoI=R0a`NG?Ci#UFB3+UDqo69US&O+BaR!xs>tDOl*);r#}nZEmC zXJcSL%Q-K@Z5{#w|1uI+Q3TW(p(n>3%~57erD0xHd>WV`b;833@PVM8u?>q6?Xwdz z^+uA(mNtF^CSY8}|8w(aJAdN*wIz}A>RPbUGlQmI@`nC5fqqD3Ekw^IafjHB>dX2e zJb;?^jtJn?9huTQ5dORT`)@b?vY~}0#Jgw~TzFN>TZ9z`I_s?^i9VINH0tP!hzX9^ z9#WZg1an_1z7P~-b@lNW?(mSNy8KtXnpU)XCG_9$GtYix-o2l!0&qP#7AUzBC)sF$ zBnlCRZAv{8uDN>B3(g=N1ZkU#6O%X!x*|-d)b0Kg$WUmZgIsHL$4D657ezAtv_+Vb z>FZ6!YG4|$2yP0EKNj0o14zh-n9ub>w%;37O%R`T9J06l2pGxNS`_2*<(8i${vJiM zBov1=VLE#-=xFTzgL;IxNtxZ0SZNPGz_#eVB}fpw9}6&FCtBBtOnExiXjhWr$`}Qs zzaMEllvw&}mz0PHcO)1y$Ddj+WC7iU6u1B(m`;hVYP~>NH}oJbT_SADR2ci~EDB0< zMp{>Lz$MT)#i>(E;hdFXNQp$>w5lga_IM;ca`jcq@4Lu@(5ir_kbgdfJvn+5pXv>Zr7;G!Yzp)uVn?S6 znL0nkI`X;X*w}S2M4y7(ZvAzF+jB2XYvObkm-|i-^_Su-9JTN@VKoGNn9@T$bm*5J znX5F&!{J{paIwr(lvBFX@%37@^^Jq{Q5*U>Ca!(H5r(BUMJUCXyrJ4A$JXvUcNfJ}TZW%?kKKIrskZ<4Y5*QtC~i50XKI$Lv4&=!Q5H?_RLXL+b?{tfY0Y9c zp>!?KQsnozM3+tIcq7m_F|B=guSbn@k@^jzIG);A5XCT^(Xqy;LvZ23{X76T$-{TL zQ*|5Kt+LTpKdWR|-X1m99$phjYC)OzChbw9p1tB^@ zU#&uKZqac>)*L*JvY$q!X1!CQP4Je;_bNA^o%0v4ebPC~fO<85y?@0q0H4dl-jRap z6W_^%0bA&qmaSoY?cx^Q^k(dY=@NAnwB4K;31yQdj1OSO4!4>C*S2QLbJ>Wg3rdrBPWUx9GTo*6+OPA#bqDIy|ds&t+s8XfRj-p?q^%#V~-a1E#zQ!__}DY*Z2 ze}4vo!*nfowe(PwIIae@Xea%X^Rzze^4dIaVMoS3N+-|wcZM&h z1`It3sQc-@2B!(>N10hY?Z)KucJVl}uWM4l5Bf*Y6IBk~rm=ZfEs5O5V6`??4`Qf? z1gdrPJ4w-XGodbnRSt7CIscM(R%VIplV3AhyCb3oCq05bNIRWbYjYOxmVo=|Ym3Lh zWW7)`l{?`>Ik#MVw1kxK4|c0$+OvzR;#V6>R-bIqp_C&do7HNnvx#V16IQhnV5Skh z0|M91HW{tmlt1#HAOCt?c+i~(!3pw1u4ij%nH7(i>@n7{_D3`my!XNoDaH`$0q zCQqk-^xjdt%3^OT&fUQ0tkHjx7;KqVq4`Wkz6T(s$QGh03rq&KA|RuK|o5Me*JGTzuEqpD@W_ z7Bwu3@$HG!8a*Mi^)@@j87sBi-HShyS6~i@v_V0@-oxDYBCRYf3kV^vIwH|f)v?_K z<`Prn+zh6QRI)PC27R6SKo*il1<{3&DY6fY<~CM!^Yu~qp*}3O&KAM0D5^8{DD-xs z8_=6bdWYD(B<$V{K>69TLcwDoCEkR^gMLdyHNT5uPPMpFvX8w5yDEwu$fk_{L`eoq zP;Dz^5Hb&~p>b|cZn*rw?1&$-zmESCDccu=q_7IAxC<&=vu*lY=GUgvqdVPqFIXvR z;a4&zem7drX4nFw;ZSJ&U^Z*6+E)hwM#`*qN(uvyi=y3UM0y{2Ni{03VaTc;b z9sVIY*8)rvtYCF$pDB5$-)+7o0o>Xme{zFs5fJRAkM?QCSr&7mj3N8hw~Ryxh@{b! z#DXhHPrCArm=-RW;dBHQU9}fP7+z)BCB~*8qQx7Rxsg8wfG3M@{KIiUXXs48G3yIm zK7c}jl^O+*8y-xzWq&yD#t`lgk`nEEg|Jo!T=DV7Pm}O9JEWKG%(fl#gDNd>iIg+n zC)k0>Jzv>Pa+awH1Up_8>;v2=1W+`4VhVcMu({KLM9{X2_3p|CAaZytA{vtI`tlg ziV+LSC8Ts+LxDA|Ti1?TYId(7+-#&2F}{_-2h{byv0p@o<G&9?ci?+#a*PI??53CNeG*DA4F zV^NLTO8f9QWt|U@>#F71F2N_p7(6cpJ^WwW?gtmjm3+IPTuXL`-^jRNRuJo%A;yN@ zYp%;d_cByt6zD%rKk|(6o=o@uB&=yn*p6TRQM6#F6Aap#StPZUa|A5UY=jTYv!!Uj zlBSTos7q;bLv0QI)~e@ez1F!c{{S$nv`&U<*M+NCNQZvMRh^pX2T6Re(ar|Ze4;X+ z`(YtNXH22FOgY$#RJ8s69MN+P7C?UTCFZSdqFD+BRov?uu0Ev2JQAl64UEnSr)RW5 z!d}lpb~X0=VZwxW0ndLTDSw{-OFD;Shb9Qy_>`U-p<*w&!G|O3Ec;TD?#qEaww(_O ziy2Z^G{_-X0x6x@H0JMwZS#M2XWl+|ovo1TClD&r<00jTI_Q$VprW9d3f$}xYmQ-d z^0qx~3+r^$Hap*J@P@&4#aHIm&7oXN=M9Z=i)%X`R$=iibuRQ zk(NI7i@HSw%ZBm)U4_|Dyo?8GAatFC82b~)@XeYB?;P|dzMwsPX3*R1jcxJL@=>19 zIkBZ`nLUPlgZ*iYLXdxo9M>O{8%|WS?1;io6yJeDK%SjVbOgsNd6UT2+Dh~`)IRgLvneyo?_i2itc&rgN(acI91D7{pPVvJLN)ll%8a{! z&DZ8)@;BZd-;}{f6V%v2pqUG0s+K|X{9`?OeYQ5qOKFn$7go~KBs!}Ubob$C<01I^ z3JPrM*hQhTf?%O?bc=c}SW(xR!i{6lkhAi~3=WVdD<{33AipzChzMiNPPL}ov1)gu zy}HCr-$Lsc+1!hnp1ve8Kh(FEy`*@j=DH02+xtR5>Z6s~%d;0{R)?LrPn$Gh(ZF?% z!vIstMl*JAUj#OR%)Jr2l&|U_WgOr_&Jfjyw5_i-M{)I!87an}`0J7ORgy+1_|#Rs*6!wg!V`Kkx+Exr4P z%8fhYb?v#0U5t%+msy!zCe?A$;L9WtU#x$g@Qf+6II~;HW7kHJ1h6&k*l$q_gkd-_ zIY8fwl67N%!tM~PDNkoTk?3tgRDEyAt(d7R^4V;VXWLDgvX@^^%IAE;A!0g6PiZ?2 zr04icODuDv9XRgc*8<)cF?v4b$~h$ijHzzgGS)N{3XN+y0A-?5oz^Ef_H|*443CXY zR`@G?tA{Ny!e9)P8tjcC#1EHC76UW}79@dswg}k#LN05Yhdp()7s_5D5~#T{y@&k3 zb){iPJU+{aZ{Ub9n!?5ZG=I}HQZ+-n^GM+h^O&H=1ctK^U}YaQxD-F=&o4zFP3w3% z`Z#~?i$04u`B635eBYZTbmbMg_efvXKufRo^{k@)U6k@TuBvSl{U<7q|M|TZO)mS| zbR&tmmV)c!PR?e%%<>-Zr=MZXzjKE?GsQ67c_zxPU5O@7$mqwBqG(%y0h_o2+J#<5 zi^B=uth4bN;3I1i-NhY2>-DhVu1l&EnJ;N4UrPsCyGrRt->GL(Mi=f@W+DXV_u<*C z6d_4)9W!d$hL+@8vdN1cxFWk5??fV^pkX}3$PUZ3*yH)CdsZcdn(j@aB{?fUr#>|ZxO6-wA zu$6}e8&4i}I8Q~6WOjCb^_UuB0lH4PYx=A9UOl?Ctvcxr%+}u_z|q&y?fTfsIDaZ_Ji z`+?+9cmAEYa!$+h(QTkYrnFqF#lFM{xgS#=K*1qB!@Dr^KNcm&sP3A!T%#+dmA9@V z^S;*@_UZ21aHSgOOdkjJ^zb0ha*+ElNT6#}XPQdWi&;bB_OCWd{ zX&WPV0+|MdKcec@#gozuwQbhnn2uO)_j&Jlbb6lnRCa zP#NlO+x@Ny*!D>|=gl6!;1)6rIsp%*#8T=|)!0p-ar6*W;~5?7twYQ@MT)`Ni#<&00d2Yw3v%AOmH{P;?&?$ zK%gp(l_dM0p!{H&6cO1b;-csiQ(Wx9sAZH{PwG!9v<1`-Q>f?7n#>WSu$F7DQ@+a2 zbVuwO_ho+@D+s4NlWi1OSMAM&#O}Z7qt;!JDna2b$HOye%ws41_#Vro@JBY@`ux-Oa*q)Y2-8_6%YioI;XfheawbG}?(F0?M zs^|5Ghw|QK8{9en%s`hYgWXNKL?hn}t3q;w{IK=$hrQ5bNxK1*!%s@N-{5zh^k;f3 zW@cv!#~99yLn37gn_B-ItW0~}LfmoaDPTM=7YAw5DDgv9OBd|MR52)lPtSWy`YgUD z$C9jKUcH;j>GK{$hfzOq=i3RU+yxjb0GlRf@QN;UIJmzGFW#as;Kr<3W78sMQ9M5A z(S)yBh8EoM1w`3oqG-fshxb8m6g2EEcE$O(9dgY; zb^5n_aNi2okEL3Q?{-jMCAaEhofhH`f^qnZGr>mqq|2hFw9D$#p;GZDML`3*`pC}Y zv=P-e6-L*Az>4v=m{*W^(-@0d)Qqr|ZBQ}uX zShI0ZJPXobeZ{XXN78*cl#cXFcg@@t8}L>NG>c0Etlb?_Sk|rHR_XUd^kL2hJo;NX zO6;s@3xm5KAn6NLvl;PJRqBrdD@N)+G3ODrd^G{8U$r^+C^Ps3)S`44MscuUeOyKk zhCv8d4LuU9bRZ1{m~w>0LJP41RjOI^Q+U?i$PSfG!6KTK;fYLZ+{9UyU%sk1N3V!A zh$^d_T5CkjlBW)f1Ax*;zoY#{K`y52nyqeKHkS#6D)vv~fuhg6?L<&;dVQ5rWp!l; z$juLM8K=uv?ys;gi_!K2sIU9ddO;CCrtKF3pIpQpX*MR96JyvlL7}t>8AM8GO&~tA zPZ!+M6D{4cRfx-DzjivSfq7nt+faxOXw#j|L%LRTi7kA1>xVQfb))|P7AqIcQ zHPXN&&UV7doe=Dl?Kv0AAjQ?vJr#n8ZR^*#*D-2uQbzNRwF)5^1~a|RO2oOy*FWge zm>0*pL-Kwj{5BG#VblwIHL~bH>UJ2=L4jQxcKt&eoow5I_#%uAa?rdM%N6KMW=(w< z6U3JeV$E!(2R>W{E+(!BumGg=+OCVk7DLr^d!R)^NT)I_f8*PvQKBp0=>G*@X4$oJ)ayP!3puyn%we{w=K@x z2%NN^bzd}&RVmKtI@`bzKkRaFnnNGKGIHT1za$OYN#tyzgouy=5eqbMe)zpT!R?Pb zG?SiT?N0XEjSlWKqhUQ?!`3w<`e|TW){J6D>h#T52)_*;rp2C{DHWc8(Yy!zN&!rj zfZVn-!$W`Gv|;Q9tuSc88(C#iix zj$tK(S=`ufA298fEQv0&bu&h0v?h0K!v21ZeNJ+>4CvTZI4#;T}ZGfUb{7KyehZ+e&WfCn`<5bLArIcE3H zZNS}r1cd^hEf%YW*X=%P=7^~Cz(X8bAGv?YX&pVN0^14k6$V>pceLuu>K6PM`^(b$ zwwA`}FsaA0dG8K@qVK@#>}DD(bW49Wiul-!Vi;&G1(C9yN>oH)K&Kx{xW zpaP$d67`Homl#!01NxSz8?0p=6ocT@#ZkED43hh~^Ir@SETI3lpMT^8_y$FX_hy-E z>!DGn2&I~XA3{N90$j<#6&7LTEvKBZF-Nl;arE-?v%^d2(PfKNfg5ZT$uiUv#}{)+ zRbi|HA>GC3`^Z0=va$XYfFWGvbx!r3x*F;h8hi`fLGb?`-%b!AAdGV=rf6B&uW{I- zxc9&uzGY4|LV|%)O!L2~hPlNL7LwbFlQr>@m;98CT|U?oY-O!2=xXghKT5xhF+&eb zj&!@PdDIY5sKpl7XU+Z$Y1I6s8U`Vh1K(NjsSgHNdnb93v5P9DI0S#oer1(eN=Jf!;{4Y$fItk5O*@x>vLoB}K|L8d}gQF79`M%R+SIb>fa~t zN{74e4AA)^vU>LbS_V#o^x>{QhCNCz9S}sCf~s>jOkR6a#1wd^i7EK%?L$9KcT`dFojq zqmz1(s!Ev7n>^6^M*-$+SNW-7O?iX_0C8o3VRm3Vc)MlTA$vY6G-nx~7^$Ej4qF{L z1+v@NupkclVKFEu*1>`80EUjhK!~9jv7Y7DjCYDtRT3hB3sxPvN_Kd~m`bwRscqe3 z#@<9wp`M)-4p!~&r@G+tWvvsw=)O1eDhn!f@sczD*B`yP#(svwG~SKE!}N#g{`F^q z7(opYY%AseG1ZUJwJKsnz~av%{Ev6xdTGnRkr)hiKDEHk^&HpbQV3kSf=@dp< zu_RHJDRTI2s7S2}?W4p9LJr+z4=oiU_B(quN_X5mbmela-HV~_PaEk!OZ#t-LUL_E zdzn#v${ZFIP=N2xEI!Z_T6pcV#!)hG+UDISY6WtdC8zYFn-Ot5RzlS-CEj^#A`x*9 zZ%u(rXqPURtPCcmlIwm#O~HO&^B3B>_G53FfF8@bd^8DM0?YkGJo78EXh;J zkO(@pE9U;HG9Ud63Le5)va!2I-NmioBiek@Y^J-y9H}Auaz><|K8hNeEzx}i>(Ke= zAhe?kLpBuZfL@kW#T4#NMMF9a~B{g z1vX1oVuJx(DWvd2FQ{Ng& zHW5U&@<72953S4frN`z;ZwgUF&sE&n(T%It(1KaIcHutw#UJ>&%%aK4Yjty~HAjn93-5l!kJlHHTeaJz*k#wAVrZm|-f(p>D`WhdK1G^VMG$~^KMl;P?_v`N>UY|znuI23{NayL8q-;MzXO2G z(vxbatf>sSk)N^`Na}q2y&lW&E-cc3abLGY66!hgZ-0)l5p+f5|LWDQLo@di-JwN9+M$ z8zRrO3iGUn?PQ7;X|E2c+n_MWqJp8dU@K$C=}ACUSeodh9Z5Qqh(rsPd1cwnm|<|n zf3uq~^3w!W7QlTMOA=k~=8kgRP!x-5wS;MO7%R%(d%6H9(Sml*=QcwrkiSK%j=A_uACtB+v!BE9R- z;t0D*JSDs5buSxG5fNTpZyWb2+Uc)m14nsQhq_j;TnR9P_Dqu$;(AyZhzili=7DB; zcq-_ZV4w%y3`e?J@?lzIuJphVL~8tnt9BAgwE`%bkPq za>}gwGO@@J5^=|vwF|@C*8B+EdQ-!RCzMq_;Snm*zD6Yi{+gIDx`4;+(V(XZ9)}%CVTkP#Ki*keI$MjoXz3j;&j;L74|~2I}_`47=QbSwAXnj?s#A~$nrVm zrix279y{&@k?V)fvUu2)8wKGQMo}uUG#^*^9ul(0vyF3eT7^ehxDA<}>|kl`oh6=; z2Xd}ji7;FcJ{`-CGmB5FM2N?06cj9H8uyvR>@7YEq;@t3MjaJ5gviOuj(vTcmp=+Ai~caLT3Ydm+9k311CO*t<-?B`jxNa zuhZ(0VhyS;)6CNsSysuREAOPa_^ZHFt=BgDeqKTk_;gOmQe3~@=oa0tcvHiOLR@Bc zNE0H2b-G=_fT%ok2br3C112l0LLl+Ur*FRS=6GVs{V03+PDSiK7s zH5HZ-zk0D5=%kVBe$kNDC?bwsdM=GsSxn@GMSP@S--6PRAgqMvyN@xtDTFjyRJFmcX+))oo=05`2-!$3KFF~I3i;x3vo0W-!)x8o@6hyAZsZ<6L^zCsyS!bI!flZM{qM=cGi%w zYlR-F0>p_KHLShMgoef1P5FQBBK7GROJ+aLgGtrS4|0JNOb*bfSc9PQ4MxBGTl}?= zMt^bD!HdQ0NXZoXs1+&eq5ma!t39e=U+^oW(W;d>5s8R^$8gt~U9&$xyQcTBg4-0X zB297ysg#;4QQAL!QJMCxy+nIu$}wRb$s(o~&47o&n)3bGkPcF*lm5fd0k^Cp+@h{U z+EA(i;C?XIa z{kW^xnuUo~u&(wTBA$Gu2Oop{=Idk?C+hB7o<}&=Q|Y4kO(dZn0ci^ggXeixaLOc4 z9AlLZ%-a&tMfwEa%x=zvTj-;kV(NEuT}|ctiY*(0soTyv>=(JFd>5B$OJgwWYxdMk z@k*F~-z?G3AR)Jpj-s>x!jfV;d272MjJ)eFzEYWVR%W!A2=$&k=MA5BS%99ely$YI z^OUes!|^KDF48P`sjj9%nIv46fcGz^Xr%K8mtIzq`?dh%aNn%AT8oaFm^QEQakVo* z%cF`{gM>Y-iBY>UD5h{^jC+ein84!i9aaQ|&#T8;&BPFaF7bo6b@8}Yy4WTSFtq9Egrm~O>#6t|e?%ZM}Ut)aTg#Uk4ZNH-KNSrAO ze$1$q@RZ&g`y9&UK1;GE(7!mc{1WH$-Qs2}J;6efXF(O7z%>u8W%XSqz3vD)ZrD$f zBFY;HNFWFL-H@ARW7$x__t7Jf-OK0r1b4S7)1f_L6?9do!AN$IWs%_=o=b67TUT;- z*NiS8#l<2EY#6Z!wb@?J*oCZx=7HtDX}$&|N5NuLck~*YU3RCbEj7e&7kH3lOWnp0 ztnl;GZ+}2N@LT$HKhO*07x-NxG4gNBTa9`#gIL;mb@61l)EC1d*rywG%wt>km7*o7 z<7t7goGcS9(i;rALJKnPFC<;0gQ~=F8`=S|ic$$99NebPd6Pas z{Ohbwytslx(OwHOlX3c+gAfzIe0SN0*XB>U;$-nIqC4PFyr@ znKhj7p(t^-&#lkAqHnXQUy^pqVCFNa>4WTPkXiXCUxGq6e;M9h$4%RJ2fr%p)HPfG zxvqUe$o78TF+RK<#KLUQ9mBULaJ0=fTNVX6##YARm{AAJ{U#2!Ya)}$Q)0;6!}hsk zkGqXZRp8b}_$n*>P%Z$MFkP5YiBN6tt+?r$6k@_FdAZRnDBh zeqn3P&fs=Z_?L97w(_c)Rm5O4O?h9?O!J!;vo!E92zR2aSaGLl$@;^oAj1ZcOR@U; z-X_&n25bTv83Jfo6r@_-zVO{TC2#D%3t8W=w3bx*EKYrJ1MU$WK_uFO<#3n>( zhTJAEz^SZb0tnQNc?Gcs-a9>78Y=y}4Q{CVu{bo=$0QObK|%iHsaF>)aom1#uMa%5 zK%F#TTcr$)4vmOpDpVY!NWP}SE^`7;Z*8EeRk~eNx$w=5_3VWKSy6!g&x}#!{Hs<# zo!(i<8nY$O4oc>4ZNwFxTshXm#C~;h9FdqoR}gZsfPk*73;{sM-3fb*M>+)Sc8|O` zdb#~j%*F-l;< zXfRDJgFq#*m?R?E<0tBBB*&aHWujDxNjH%Pm2T3QbX}#iq)q&4tq{k!ZLz-}_cr)H zWH>`7F+RjZSuZLuUbb5@r@PD|q*yKTj*J6mtxkl+KNe}7xIQ~g>x|Dm5NYq=BE8l? zj56JkeO7+D$P+tC781r!ke;2<0mkKuzT+9p+8m@I6%^fLN`Te=aE(w45G0FPBd zQ;%d~l%&l92X=3qNp|WZF)Rf3zFEEzcSDO#jfbNa8NGurpEjaL8%3Nk% z8&oE|=elFXK%X6`#b~82mmlu|%+=lj)lUyyBi&97@1X=xc+$Fd(u%I`*Czj6zE?Mk zS(2RNSxdf5>wlsJV>; z5!2E(Su8R7h|<1v9$&NdGBK?V7+54xuAH3+pfm|FO6P!98(Bsxjsq;NKJ!^l4++Wp zX-Azk;Sp@=A+nrXm|EdZ{&cgr(x=(Kb%eU6h0OWm&*#*P)xe@B8JhNIW;FednFme# z%m6|Jmo%}N5g0I=^Q3}w_Ru+$xL#SB9M#gpe$wWH$=)7xs~S;!R2vVF!DFqe?PEB# ztq%5Wp-Q5NeW1>fNibFFcAj<)$!y_>_5N}}$$!Vn6n@uTQ2$k_U+=w$FU#{^$O_ua@xxb0w9Ceq zRUc97BIF&wtX1}ECT_YQ)l#s_mFitz6JQA!`OHLUX9p?p%r9b|9rNd~ZBoJHoC6ui4N%N6N;U4y4Y0UxMLe|(kma4zRvjFxB&;E;lKI2)$jnU~A-oXg4%TW&tt7Pa z_A+60gHW3*Vd{#3I7>wsLZMHXTmu#@RMVDmGc5`p1YqX2@b}?hD&ZN!9a*V9oc}|5 zlnund&B^I)i8s}R@M>eUb7pW&OO2CiJ{eK7q{+;rOEhysCe3iUK1H2&`@tK9J6JXA zkkdh@9pU)H^Y9t%(v{cIAT2kM;bU6|Z?hX!OJA@+$$NPqB<)-DZz96=52wQvMbq#z zlHG#NDL&lfT4VCbpav*nHt)6g=uHu*X`|cD3zy>L+Q}=G%hZootpg!npm)B4@X_L~ zG<+sX(EYYe{Z*?t;2a8Ug>|JFsQWTLHO|{qw49ctP1UCAbt@bdG$v9|h$k%8Z)NzqOONeri z0+JJ!92CAFRr3uBbAsaOj|5)Te051zEfX-vUJFFpqPP9tmojD3)>*~6!d;5JzTyrM z<->17CVNrmE6RZnn7M6~sdVNYuFEQARq3Np^xG*ZV8-*3A1iX%z3jl43C+t)gILtljIP7u+HP1U?R;w|Uhsvlk%N<0~Au@yX% z>&sxdT)BdUeXt-J6pe(QWZO)m*-{OgK-=xUmq9Pw#Z0 zV9LM5#qoLYr{}I(;ks1*U4ED~_0RR&7Y;~>DRJXeWF(D;?I%T>Au%d>--K&X4zF!7 zQC;uLw1Jh*WXUG_`P`DWcY%PHCFKoCpX2t_pJxCJN@D2&f{;10g1*w4D8Otjv4BuPb*=K?D`X_=X?Ff;P>ZzkQ?kxbN?$X zqKAd!y~P$ufID+aLl@HnIU7dSR~M!O*D_xrmQqnCMi9%aLpvPJ_|%-|ZPYs4&A083 zXzmnTGC~n8Q_#3!P=Qe!j%siX=JI9YpN9axSdLp%4_k#E!geDMDYQ_GUj^pPImE8( z{kE=1kRea84M0m>aFtzj>jZ>0U)%Y3%$uPWXL1?qN8mP2ro#sc%ZJ=n?-SNkXmQ(E zXhGTb`rzf6ngCb)Kd(gpYkr6$w>1>lGu)pKwfnBFIx$2GZ>$TFv7Vla#Gsk4b>93) zb3i1KGL(`nE0-2+q>7s@;S!tn`r<=MXHQ`A4yK8(I&G~O!({A8nSh$OGl@Ak5fu%t z(pJu6k}M=UCLWgX3_6_*V?Obl`0y+lv?SuF2BtFBwM3O!@`uMwNPnevr;oh@IQq_H zeAjZjgWB0!r~K*YysQ=JJJtA@d+Eu{D64$D1xUu{uGO zNuWZVlPYt4s`F{a^00Ef0?O-Wka-rn2UXpsM|M^)xcS@3&RT8-QS=v-6IxtBsG4i$Wo~H7PsHy3>&tFfRmc zF1@U`pQ02!aI!htn~3t0!*|)u;1f(?lu^(6gE%sO*p73VT9F^8c*UaB?oAfbYPzK> zTTXo^D)OCARL87cr4V@dPU;zBbO=GJ*d-f01Z<%gkks(nbHbgMK{pkunCB@!Dc%hA zx*Fg}8tC3NQvD|$`#3C^gO;=J?Ez?{*dT(6`*ay7NrN(VRn#qI0m$G7wHBJ*psS>|DBn@OBx4ybKXSa3A}na73o zMq5xaI@x?zM-44Mhg6#4u8!akrr5~-a@`L7iS(F5reK^A(@W5G{^DJ9lZ)4ojd8-@ zq#GQF#fA8!$GZ3mI{n-$iSvpE?sxhQ&Y=|B<={Pgh07Ue%dTFQsMiK&GHb> zk(P+)G~u|QLNSl!G#@6mOOv;kCU=`JlNcR4yui7P}6_p+?t0O?|16&`7 zd{*^*0&Ru$EI~|0lQ=m6{M*+ zT~P!Ry3r!QtX$_|{>3b(YoaB7JE)gLd{*+ac?d6aBuvU)$SGQUlF1--ayUu)7rLph zwL!CHiJ|T?H6Im>3q*K^1=ZwzpZ3Fz%6t#y-wy;1dts3WBOO~vZMJ>x?F1h1djQ~V zHuFDCMMM}G9u~$Oi`yD*Zl{QsT0=z-dFiHGYP&DMp0))~Q#ISPx1o(oIon8{R3#SyKb3Gx#qIvRx)Y>+ zJ^W$=^!=lA-EwHB`@tU(J-W)ko@rk%R z8>gb|jy=Ja_H0bY&MBmZQI-aekE4c`ih3LxZ?tmn83x`1QoD3!B~^0pbvcwe#siS9 zgesHxr!Zfwj_ZH()Pr7R8UiYNa>xP5P0!kw2Gx*+@e1!XNEC=|OE6)?x?!b4;eOxm zJ)1VDUhc<`-pd-P1|lpB4$Z<@A0r*RE2gmlMB4jzqURF_&`ddvpk6T78Ebb-22T*m zv3Qp;8BRwc#yu?x2Z;E_@a~ZV^i2>Y&^6a#r<8m z)IbC4MEO900UO!dsKv>_^+l}&4K?UrNyP0d!_}ZJjG;roOH6AcR59N#&LE6~@&H63 zcU23NYQ!o1O*pZhENo;g1IBsa69J9dNY@Hr)w<5TPPw2wJYNKaS@Y(^2JH>l^z4=6 zhWICot5s<9?s2Z`KbCB;I>zUsmfrV%%FnWyJ0kHEtYZIG`@-&U$%P?z{n$YFy?5>rsoO}^e{U@Dq>YMbx0k|mmw2UT`z2@ z#6yhd-i=CYl+2f3*q{oi{>Qo_rk164bra8=&B}7#IilSia(gbPOYFM)6CV_7$SfBw zGxR+ZyGS;^;e0I|uM$$A7j=0*Aa$#Q?AHGEqdY4w-a@sgi_kb+6cODun3E)&)J!mB z>F^D9pLII_2!#(Tc#~3(bCHQ5L%V$YVBrq;;Evl!>cYZzyAj(p1=DI7g8*i_I?2_Y z;56SBO#k~#3r>13D3oQI=RljD)Pn2KgKjgC#*3BTBmxv#!~GQLY34d!shdR~44sNc zCr}~Gt5P5=9bCbj!NX*lFyI{cXcMV@2$-YpOr{;45nEu+S(+!cV#bk6LmLrGHS@|Q zL0J=gRJUuB=JN}*<3&P?2mjbfd4}T`S`s?H&{w{>dIY4aR^Z1hFKX||;<1z?m#}YP z<##Xsh{AsbP3Z20m+%2p7q0?XN&==|9xHeN0O|B-86svzze+yI9h$*|JJ%AcH~h)M z0V`Rz0;eS4(@<*TVosT_cmT8vB4()t`VJUq4&Uj7%4||d3=PNtD^RoZEiFsP#yUIa zARaPI7SoW>Dh~ho5{0FjC}Mt}ytg<&g?m<|II&elDj&ILmO=%4Ee-`T)9rJKHb8eDi4?j2Y#&;4SxjLt90arAjPs1^jBH0Ub5`2 zt8YsMJ=xTus5XA;(~IC})&jVIsItAy^lK36%&n4g45&l~Cni{?1-|fX@{RfAg8i>2 zNc1R%%BgxF%_NS4DkmqCZD@}A9tW9+3b=|tX$p4czd_YV6j=J`>A%eS0Cm=v1!hYt(#bW~f&$qXN)m}cBbb)-gWoVmjj2wc^WUU*HEqT_=lhd+c>1Oo1uo+LLN-LG>r-}I zQ@^md<+500biJYxXa#d)pHVYdN+iK3|G&P9YL|jjG?Qupa%vHX(e>`#jn|lfHHh`lS!QR9OnI zt1L?RU;b8celtMU@}(%fE$LU?g0ncZKTGNhzi8|v>*UJ|twgd=uzm;APtcaZ46^%4 z?`LXwQA8LtsPI?*Uyfi^F;6+rb{kp!i@t(�whZ)U9~#^Qth6x!)Y}^VQz(z`The z$rOJ-b=`iH{5}9z9^M##yyI_dvKc;KPztZqYDZNF$`J0U5;>f;c1i@+USgEG#@QiG zfL$YYflX|18zF$XR))ER~%lLgQ< zz#*I&?4biVfv|aei!sYbUr-qbN+xQiF3<0;JVLc-Ud9wlq}YG~)oZK)WQ*hJ{p+br zM}oYVZ_fg+32Osb&w_r}GLksiU18pR0U%U>7fh7y?*kx(p=96=gUvR?GqOLMEGLbL zY)tGCNB}bUYHyQT;q&_&^`1DL)>Ey+5r#=t=d`O&x!b7^VUfl|!VTK5EzYMLzYR1s z1W+Z6H+w*5gK{;*C-mYgG_Fn}xS!AA_>B9kfOlvn2DgR>kfv1X@VrP;W}E*+3bkXS zl=Qn)L0DTIS!$0e7AV^p5dv2m}XewYO3&RkMDD+<06J$zI*mM zki9Gg-R#v*5H)#(;dP_l{%N2;`lU_j0)$p)7lhEOV2b@K>MjOG`j+OX6Y(WmP5 z_4(PHK^P*zx&O7cy9`TRVE2T1M~wl<{H5Qc{dahjX+t-P{;1!oCwYLS#{Y&_em{Y{yml-4~|Tch14hb!o3 zkrcSQepLC~tsfk-L>ZOrKhW5CQs>w7)SWZ47ve$Jrt#(KODg4wwW-mvV=~FBtqzm_ z>OfQP+V~Za2z%MTbWNO;MKZ3DSL!YcQn{~mE2p?5j)DwE0K4rIu}8H!@!`JSbh;8$ zkr?`K3yfkMxVL2e^vqjDB1>9H?y zx75I&HWqEXeM%0zMdDcdbLr})o|Fz-(}p`T0v4h)e4WO`L;HW!a&5!@1AoTZHHEIz z5$Va_Z%PvL^~7s@gH^{4+GLq;aSsH`rIZbg{ly&VrpxuO2;YW#%AR8fL-D*HGgsu0 zZkC(Z)qmkRemY@Osxk8QrtR@$DBzUmeJFK!LWHvBTg=`=u6S&1hg*J!0=9)WCU_>_ zAs{5vQ%k9by7!XnOmLF<3SJkscsHajkLkW)*DHf*i*h?ZUt^(G5WhUU#*SNeXC-9qM6*UeG=Om zz;S%0?+7c<02cuM%NWqN!rZ>1O9Zwd+$-;LPpsGCX-85P^$V%xQ{^PYNl$uy#Xw(&dy zJ+O{h*w%7VN947Pyp=m;jXc?p-L4>EkMvW59)vhse^ymi7xn-}UO@4`;1i*Hm{ZD; zR{@fxjpdH@U)9VIf6mUUQ6^z^I$s?+=wP{uf0l3NE5wtO52z{Ad+XtBhT==sbgdc; zSsN_Z4=G_If!Iq!PXbxLP?KdaEXC`jE$S1R41F?@s^cO_;n0x2cQ>lcr2ZPztCdps z&coC5x8o3|vW2dPyi*eyA{1nx(oT&wrHNw4694M;0>&t7VNA`*sQi$0mm-x;gHJw_ zkQ&CiK*lS=>*=02{6j5$RJ=f&6LMe2x+`dW2wWPwRIgQ8xH^E+d4oqn{_NP+4`n@4 z3Dhjch{rmHQ$xYNgT52ur%wKYc~3v1MBiZT`73~~=Db%?EJRihSkfu;+S&Le$tG{L z*Mo>=^MPzuIVI_`cCQ+v#f(JLk6e*}X%bRFIx3jbbX@p2#M9AI0fiiQBdzL?yF3jv zdT=*tt+*SMt`Q)*=i`e)7ki=|9Vj}t?EI_km;{bm`de*Tnb*o%5AWcUeWe@^{ZsOE zP$BmX{S4IM+)-y5GU)o-OPo^iD9``7u$_Tih!quf%s!jbdt_VQPR`fmHr9iO*o!i} zQlV~peTBMW*n)vuF8InBY=qR`ifn!69%v}fL=Nl%^MRX%$w&~|1i;U2R!B;qbD7QcZeLK&JiOAa9ND6K3p& zM!6zwo4ftPxZkWFcX-cNPsz^M-*=$E^>Dqv7NpU#(IssnF`M`~^|hB0s;aTO;8T9( zI(0)PXYWLhmh`{n&Xhs+<#8DQc{piH9rBbFngM`Hg?h(Je>*~ZMmoREU@!AD8!G1M zI563K3>sUb*|Dy%WCeiOEvB-~?dBnc#p!3Q($TZ-V31EcQ5$~{6YrRluCw=CVb6QN zISIaJ_s?9Hlp5q;QA4?DT)G1K=@t8QNJNM=mRYOaCpW+1k)A(@7bG_Em1JqUrb}RC-eFSBB-qYjBBo z&g+^1=TD?0c`XYWYQE=EA})b`Gm@Lt`X|-L#)3eKmPz8(Vb=Hyx{@X6k%)kqcdIpD z&$Cj%Rz?rV_3HhY4I-2m@J<#(-o;`2gA-wteKumXmUbLFLN26u5ouY}iH(Jk8!vaF zh%ynPQsc=C2N)rfSql5eWw2#Cnjf_#2|3I1Iy#adk(G&>Um4f&-2PbPmY0LD1QwVy zBBX3%>UM7a(=41uw&VsQw*?epj?4_)hIi+J`OM}!p#kudzqI+PAmllRS{|| zxT$|%TNR5I%ulg0XK#4eBnRby?z-m^!{cI0V{(m&VUb~ zvZfZZhFADw9GXS7)#QYIyA-`EG2GlNc!`?jZ|5mfnL1}2S<>?%OzgNxj{vHknm&hu zT51PAd~8%SIonlS_+}p-U;jx9tKJhgNifQ*>uzs}BM8S57{08BpswB_Qc10My!y<0 z*U3unkZ<&L9H!j4izZ#Sz8MuWG~e&jS~Cquu2^R&`g za$A-oj5du=Az#|2Xs@;67qlqfl|P0gwj8_Xi?2`pa)v=O|;L+c`C ztSkZ$9-tb^c@E3f=xzk!g+qt`ur_3ME)jU2@3&5nj}dA^^>6?am2vSMYE7!$%uZiy z40M;+^>nfm$2MbYh0KBWow*B^Du;W7^*5P~oDIbpohC8!XEGjCBUD-po-cM<fc`N0v8g9lp_hsHHu>lSEU&S(q9SEJU} zH4Bq4(`ocB-=+@Ac+B>?+rmq#mgI2w;e}(cEZP4P>Vt38j2gYRA5Hh`*P}a45=qLh z$jKqY0raV}$_pE~TbGBFOw9+j9PBwuef}R`WlJqgxSX{p`< zQ&^$Y-P69mj3B^pL=nq6QGNnu9f+} zxU|MK>+V&k1Nl~0BW5~qYbKuiq2$lT|obo%V&yX>Ov2m87H z*~jJ|sgBZrlDZ}3oVnGAwX!a=Mh+nA$l#@Mn zpsrKblSdRIEXG2SlYJe};5sd6CPRk=C%iY{0KcFRLPc&Gy*|D-J0kyFA-dL-Glb|E znzE~!0KsmV=-B{LHcuOMJmcXLk1iK&W=EGTZN96FbF)MHkC4Zy+Kp`RTIg{$XF_ll z(*wbmjoznw^dJVSZ3M+Y;yuA)l`kVQ2hOdX*p+QNKo#kz-=o{ZdeHX!FbZcd3{gQY zYlpsfmD9jBe-Mb;Li6#zjg||P2nVZc(x>n{NAc=m@mB8ty7V|WA}=EZNfq;QcCDmc zEvMpWGMiGj??{3kuGQZVr)~K-=-6u+uEx^_$G;(uo@JwLN%-7b zS?vP?f}HxV;4CH0G5atXVWtvaVO5bzOL~PG(|>k$l2w69BBtR`Nq))DB`(fBW7;XP zxIKBY7OriAaO*YQ!G;{-pX6gOsV$%yD5uQ<-MI(|o?iHWzQ?f=&E|N3Tx}>IvvMRHH1~;ibbeBvZMyEAGynu&u*g^v4%M z!XaA0yC$`9p+o>eefzh<1Ft>buGPG^1!Wn{y!^qv_Lgy59KYa&xvG`25p5SUD%9D4 zi#)b0WYR1!uy!z};*^BiQB(MTet6RrHV8NPq5ou{Ip;8%-_brRk^7|NPC_hWx(?;A zf`$}9d|K)Z7M#L+J8E)#TFN;8mEDMQEiE`&iRW%I8w`c6#bHs&V@ltLA1b(jduJIz zKLuL5r6G9Q-T<#)X{L}cm)diV;2Rz!$a2cQEOs;!0X5{~Sl+c=+uW<`iee=*r1pPD z{Z<%ujDe{qbQ*|2z?$Nu8|t`jsgI%yTh95>2Bh<@1>`O=wW*jk@8RaMm?O@1nu>|V zj3*_W#Jx+kK%`Bx;W(O(yXX1x07pQ$zf?B71{jnM7SKNOKvN3Vkh?Odk5yUg1secf z!Ps8^TFtS?MteJ#4`{hW;GAntB~LAbT5jV6f$E>87gac1rJjTREgCRB@u>@{lbvfXMRUkAdonC&m7lnW z;^||iEyCzasz`i%QXwZVyT$kcFSL<-OG}P-dPJt6>pi|?6C#23fh5P=XtaV4_TrWq z92RI~E+es9O@7W%NM_;{_Rk;ArVlQSqb5spc3_gzV8hn%F;Q*_T&mb>Vn7DYB{lxz zwascFQ)uZKea1s_X$e?=R2oO*QjRr8X(6Kv&#*O3^h~}ujsJ3a;giRN=-4RUl4uc?hdzz$E~vQl^tEdY&E;!pdhC^HfjrT z2sJBxpwMgBdK6_uA*4Kau@_T?&hFp#Xjn{IloDR0Yd(dnar2CGm!;;g+j#Jk_-uI7 zWTcq1RXgIqmp&GAbSlx|upN$`DXNo$;hI~PWNWi24-~!?MJt!r*~(A^ewpx)y(m5ai20pO?FJXhE^<9jCie#KcL$CjPo41Bo7TlQuJuY0 zNdG2x)%Ih;{eIS4*6Z-SZKQC4%6}WZ^X?B>b9JfN=_3C0jSXToBYJA^7tEaO-@y2` zVVTHih8vXv|2%JL#AI10o=G1mf$5N_t=5NOmKI>BVxtOpO@D+#ZE>sk(OeN>{SYb~w;p>Jr%Dwj!q00=56~(bg(9U;)oa{oo|aVqQG#A>jIXq|+}RD#rU^rCSb`Zdb$;*ge%L&ZHeB&gzT z^$0mcXUS_BJ;&8v3(R!}Z%SJ?gK7&WoWVC( zd{CM)>aIk~tkj|n+8ZZpOVQW5f)VM1w|eSq80O1_95~uUKJ|kX3gB7sYO(cf{s;0_ z{1l8S`r&cqO)mJ~J`-uGrii*M;{I9>dH)LFK7R_XTPC=MwF7GhkDsNUJ@faMh8c86XEy|k)r_!W5c~Dy742r5wkG>TGp-YB=Fq+RFIFC zlTMT!YaOY`_Nn$-64OgrP0*M$Hs?~ol_2V-l9YJEGq-T`59^mRE3~n(dnM|#SlMWW z-&Ine5*-4n()gZ}G;O}M zW8z2$5AK@t#(N9exFg$GU9pIQ@km(68}Sfy9Ob9z27|JKm0*BudI!>DPe|vo1TIb^ zKp%YtK>L9zQO}maP=lOAs;j-{RC1BF@p zqPdbWXnc5L7Gdf=i01(FVKsYn75_lwi2ii}C%qhwZF>UYrLff|#L|U6dru%^HjD%l>Y?}WV0^cCoA9wn!%nj zdVntW#u7*6$A3O(C1Olz+tF6CkC+w7VQva#{dGN=O8I3tNNedbQ*qfthVug0bu&6d z-k>OG^4YJCjxRUk-p9}_+qS>oWITsgxC3OWK;JzVOL%egvo5p7sWz%#vl$i@+h)}i zy%c(44<>DLOq*Utk-xv^H)B7JggdlzVGD;K*6DR{cFb`&e}Lg}R?XA?X2JgPWuSzn za!RHv;qf_Sspi-F@*|!L@GAe11QZ{}60wCXyhbKwBg_xizC7BP!6yKJXz587%FYjB zsw;Q-!udc|PMY>Pjrt)x9|!I@iA8VACRrA++1Cc%P5i?SbZz0yDk%paLl~@~N04Bc zqbk4YRkvCnu(Om%6;!mcF$pa+QENDGNe-o1k(6sk3U%Z#{cbL!xH)KTG?rRBoZfAv z)$1MmunQl!l3H}!;I(?5kQHmlOwIC-CMpg-u@G#BHL>Q#1^-9yOr$dlIkY5}GIUOM zP8!CSw`x{4vfdsDU8g6>9THXW6WVR+v)FZNivVRA^tznc$>_XC$jM`~HFymgi*4`q zi?Qlu{_q)2_aLPkm{!K6duymjS3>YUhkobF8(dOslMsF)pm`juYmeW8@xfh-HG#8b z{^N2=p86rhZT`k1=1<#UzH~@GO=L%9y-1x^Iap6p8o$NJUL_|JM?fCS(xzSdE_s?%(Ok21Mmp%loD!^yxlpB#&%!<%Kwxhh}7=wm`fIf)Zq`Qooz zy};k&wKV5&<8`GgxDoIb?%S2`XH!;t<>M2y>C`R@L^|9mkifK}b}{;c(5yE&F5@OJ zs7#B>7&u*%EacmuXfdlR+@onL<+TC79po5`pZZvzs~S$JZ35H^Blj^CixWScDU)UB zYIM{C#!UK#P5DKcTgk(%Lhfg}uO5dxgU-t`QJ6ptnlmzLgRKd1+}ky+SZ>y!rE#gydH9-Hi5G4kmmOi;ZhHWe zq(OEE390Tna5ltYFw{SOz@AWrONs6%$rVH!)yXN>(VA+LD@$M@cX(L<@k5n`?pfRF z!$=V(y|WKEuFdvyW$Id1FeC%;&~=0iDYo;UT-hA}1P;K-RpKy)Pim6*st5z-Wsy39 zSKe)Y)fiqrLzI;?PpNBn>(gHmM_V?$AG$fq#%gWQs=pdB;9cG7Sy{n@R+Vx>#bVt_bGKV=d6hK`|C}sdC2_@Eq&@ORItx~}}3mP@JE|8eiPvXmk z4blfwWs7k*aa665`WOkGJ3jm@b<#+aTOsB#6a|l@bg4Uy1)Y<=U7*`-aax_f_K(s6 z&3HMC0br!%3%>zt)!(BZG(XPke)U}W@`%l<3kHuVzWmZmAHbt8gM4A+q_CW8E%vlf z4J1@`1?HHGgANj6wQ(qeq`ixqv=@zyxEGeKvmO#~Tc4B}?m#lP8Zz4AA2EoOw^25Z z=koe0Sz(@0oo$&U$W|zK$a9zLE5O3(?9({{1w@4A=e*q9kN`8Z+{Y!IwI+LJ{CMjV zMMlv;?wP1^Ejp(w0lZQMIjJ{s4QW7w`ooA03~UcPfHx$Cd|NLqo5LQKi4;y^B(TzPGB zR7Nf|lM+v7ORNz9Uk#r6@P7+3Rv_sI1*&@s+rO@%dzM5iPCKR{%EWMvlEv&R$lkw9 zIx3LLQ@79|k%Wy4K=0|zCV7h<5ZEw;5q8~uedCY|l`aNGvdu4}TTdv9C2|YtSk+10 zV|0~O{`^u~9P7+&*a`VB2x@$wVagisolW>#7T@r-oit+ppjx+DgwzQ7@0sioTshYa zl9LYLi3%r7HuozRmMRyuw@r|e5B>sL?xbnq(w5HS^hXyR2B1ZlQAl-?Aa#&&Me#jm z4UNOs<vkYCWXAu~dr0-fjmiP9e8Kv`w=n=(jQ)mfO;m0~52%$^+&x|d3OCVe ztyocrn6_RUKq0gS`I}E&$RK5vV{p`rxb)kyDPaz*dgOhF%NzGDb$gUyVXI&l^yshG zPdX1pmUgVaHFhm9tZIdkp1FVn3ci-pz9FHvc1JOkPIRcF{z{KTu|ktJDqWRUyuL-H!LUG3FR`9qL$lx{#d9X64yNufC7Cgo|yq{Azmf{ zG8p~9Gbn;c*7?*Ir0@MXJ%9QEPHV~P1Dh20Z z(~>}$PV=uV%lP67_fRJ-iI*523T`VAA z^<9No**m|LhIHvH$wLhZt#h53xrywjSfbD%yF9sv2|y%Yj}-)_z|Y|H#9(2oh9&@) zA6~8W+GJbUp5mtrO?9DRpJAn$;=)N+0Y&6P@zMJbG>s!8`I21sJrvc}VxME1Uj@cH z)F9(%pz6Aitl54~7*MG^*TttNb*tVf2#oePU%>G(1)UvE*J+<{wOB~_6q4xhJ>R(= zuLXoW^qeOpb6 z{=yAsR8%6VDjNI9)5G3*8PW*Vk76ZAh8-O=*2X-8Agq_R9TLAp18bxLnYqD=sR0%) zcWCouO*0&gmB$!HJy`m~?5kpRjS~#;ZhRkt&e(v)9PBikC+3xV^8ZbRd0ZQ`FII>& zn7uUy{M-?G1|SK!(sf(zCK_i)9am#8ma3$3bMB3-hzdzyk=wtX75U^wz1Za*GBa&% z0X!g?LClS^o**5vA33IqMlRBdMv`k#-}=-<@_Tbs16zc zaGo#ulb5|&1h)%BMD{Y8+9~R%Z&6@r4?V}#-+V@`e&lyfKfTNI%GQ^AL?*&&bctYV zWK5|X^I4AC7@&&Y*Ya-|N3a8dZKhsttkTE{9XQ@m57@!+KoG82)^>`S+^F1!<-gWW z%+qU`uoQB|{-H{X!|_RdNopD@My1LK_B@`CO+?Z0DHTWZxbuNcwb4k{uPkA6H6sf%LRtuT7kH>zh5=CsXosUXJRzy z){=6uklS_0Cc)CvY+nM1J(c7@DIbz`B@(Ppt+&S0ZveOc=;2tP5Q1o;(dSdzXv)q% zK;NaNp#t!P@_*oHcTT1D0&qE2G`#V0qOdgA<#w-YUr)Fe@8?7B+$hPBMJt(zr{iAX z02&3lBgukkGi$mE<2!1pw&@MR(zDoF^hjQ4JV^n&9zC^LoFTotkvIk4x8w%yWG&Z9 zxrOUQ75;SJx1bL1&UWnq>iEv=>G8*dKgO4PdHl#xu zRWF^gN&HkupVgsju7BZ*ZB=UpJRAO>6l6!H0Yk}okTny%V zOolx)1#_`;(`$nraH_=bm{5cD)LPCIH^yhCTO(lpaNkY7K)+;f6uGu)3vIa&z_H^x z{SdLwewLqy9Al0d^kl0A)G{8722y2lFkm#QQ%-!fxHcy6!@i+1_&l9I6UU>TSX%2# z5Zo`iqK<#5_E^N@`A*YaXxcs#bJ8m<#e+ZJDh-elRq&MYi$B9EFs>j<6zV;1mCKdn zV06#@c?{~&s2B;nI%+iCvNgrKeGoM5@`)z z^M`zfJs4<*=Y;)8jAL^1LHZ1?%#7017czz;ht&Kqch~nZ87`@nT5` zL|whV)B=6@6(o4LaBwX7KE@?cGD0q&X59tMifygYv(;&rx zuu&#L`lf2@YwZa1_F3o?N|R4{_mixQP)Q}OWq|FSh^6HMTEzOTa&hb|;fW06K(=7G z6paKDS3=ADO8=x5>f>kCkEB6szzaVN!t4yFRujmOW=EScI8avw=ELbDc*x zwR2QO4n`|PGS!LuP4AWW^I?(?tYR~(gYLbrT=jk$`l(;Rn3iuFieVq-bqw7wXVf62 z*@R|dT*Hh7o=-x08A7} zj6TZ1Y1n2n=ur1~K)vxyWhiO2Tm_%A!mlW|PrLJgzgEeTwq`KO$^DX1wWi#_*_`l`euW5wWmaUW}sqSJRPx z{Q>>bj{leDX6+0Smrm4~_s6X-a^hT;QORiH;Bh&WW1Xt90PHx^rdSAQ9vJKxjiuVl z>$VZG%yQ|^zwOA8qW<<72Q>E`WD=Ud;!O5|?(J~g>-BgBfqjeGSZIYxW$O`{BAi(lRe=DY2sm17&(jbEHD!V35)9Pgs6OGqvV z$?lMiMt_w@WF~7DX?(pe|GUfZf3E@4ow>wBYV(6BCNd`Bkk(OKnb7)JXu$UB*gFO# z-!0K^vvSe;tu?;ORV$q+?bE3aW#O6Grf-X3Jl1QGXa)?MQUEGDZck_tdg$OSf}J8^ z)LMv`&ZgM%u`9r1g6S%NKo=V-#0HIfzsn(@Etd<3hn~t%2WuMQ$E2Rmvu*-ZJ3X8E zJztN>2bGJeCf>wsT5Ua|CphGw4eV`;*K)|0a9Uns|1~otafaw!P!ZBuBTPuE)1>}n;jOMJ&KnidqpeMj&sDek>`Y(j+ zi)CszTf|-z(I=ECLH`1UxX9rgE|QJQNHyC+hWylDt}UIx6%L6!*x4H~9WqT4;*Y{5 z1Ig9>M*%qHFdIZVVisK5sVh{N|3USsdFWB1$#9(AZ)`i2sttiI4E9Fcy927nJeySy~`QCPqllXn|s7`_7t#8~o7MyUcHTv3_R*TCr9B!V}ooNe$$?h|?{F5w_pF}5+PSfl~K^)U8m+zk?cwg>zt;NYeZ@g=xvI2#7K^cHp@qR2qL?C|8Ge zF?m@G4WUFy4JA4k)0b!Vp|tHQ2;*^8dHDOGB=xV3*WI#yk29I<7};^EuNU00JNqKm zy>@|QYdp{_49FSs7D*;HS1EKr7R^#_&mB z_|bjau2I+>(mecJ%(BT;N_So-{SHxjA5Ft(`J&FpLl+NLz0umgk$yP+@#{;zj#DNz z6c3ar6RF9JgCB8AUJ%0O#tvQ;B#^wwjrQE6e(o=#?k@ zWYT|MKj$iNSf#`ViGjTu$p)1dy>}7uz4kq}tb|&d za^dv_hmiE&g(BLFMDIk%=LSe&CVko~PMrHu(v*+7&V;jx0%8`BKb9fxKxClRDhsbm z7M*brluMUQghN~K6Irh0!dn&R4OeO@4=V!&0fNqif5h+U+^_w25W75klw3a`3QY@u ziELwXYx11=<=IFXF^6RA6*q&iu3f3jTuAC9iWY>A=*y7rDXrOb1~0G{x1}UPxXhRtDOqpRQXK7xEnD!)P*UCRLdULcCP9TYTXatE26;`G1&(1z*elv z&-{&n82Gfipu?lr$oMp{d4!0gGphGIgc946bOYk?2dy-wvjkTGOw-Dn~aLQbu^Kf+#h+@}5( zImhIL*fm!&E2;OQE!KxjrJ{|8%hAfw9T?gZvt+n6oK>{VRq@NGZaR^B+$ynFT9CM< zyd9uG=b5{CQ>LE~DxRMZWt9EOs|s9F*6E#UST^E_7zZc21k6baeY<1%kBiI%6K<@r)uHXY&Ns$rMP-i~2B zX##rCXYFnz;KLF@a>l)Qs^S_T07iKMgl~|f%+UpXJotMUZ}v{>Yv8QpM*$wZUC~AM za1Fx!p5nR+c=q4J;X*kk`d1|K2tT7QANlx%I*}TpV0)lX%{zd|pWLQZO&6UPyk7X8 zd$l#*F)~a59<405E&0oTMO%5HIwxB@q;wIJ^Dj7;&Asu!@q@hgRT04FyPzQLGFplV zXV?Y1bv|~*wl1u*I0CN2htpfomYp$S`4mUqbX=;n_h!X%kfmRgdc80KgqD@&Ga&9h znCwC>X&UZ2?+qr6$|xkvO*WOT9??$)tNSlI2vLJF`~&dpmhesCE4`k^_lOQf<63L8 zf!?l+$ELQ40s7&t#f)NhWPJfplfaVt$_b={=%h4ldKD5Zh;|Bgyqlm8N^%PTum z&?2EoQX=|I4U98YcX^kGFON%SP;&IChneFA^)czlwq8@b6;vH6SXNr(w9x|lWWsRPeb2eAcu(V$J7(^}yVjYN%Qj9aw` z%qE;9yhsI%8|~u{mIdy%T-$~^bHz=bPA}9E2qX`AKkR`v3p#FZs7|m2KoW&91`HOM zNMyNX-oE5as?;~enmxw?KO@SzpnYNfxV_ykCH#s<6_q# z_zZv~PnAm0GfU%RE#H;M%bG zdoBeUFa5wOQ4IKpeU2pB&sNn!UgT`@-pVG@2uImniM6tYNsD^XHpDS&4?ER2mSvbL zC-GoJdm3HDi5UuK3I=s3LYnt`5GciYrh^s(2W8r>m6ECF*zZ6F}0>tZQ{q=dOGRzu9ko!?c^QQ>Tw zP^k00@FaDcEUj_vN{9U1c3h^2#PEPh!uvxfLrv#aJXMJu^2XMeB`yVIhS$fKcst>j znJYy2({<0_(FD3QNKNuQvj&;0n#;JA-fUTvBwz{(TnV-R&KwM1(|LO-pQSlF)Rl3EoABIWA@I zMBYB==~hVDDxYAvv8Kq6n2`mTE9ZVvV>c|lp~JsE;8~g-f-)mFicBrGXA2p=({NUH zzz;ZZ!bRwAW+8CjR|9ZPLD!W-sj8e`_kNfnvq{FVHZ_&nTiJZVHfGO3K!V9XDPE1P zUfkEh`)D+|5u#97Guik)eq09pUS5iffo9nB!l{BtP~5fU!bJ;}&%I~=Z`GoKbyi2C z^2rLQifph2|0EG#GW0KjHdr5z3pG<41IEw0c{HMm;sqlvNIDIcCeEMY*8=bpM!E&D zI@FVmjfRQL&arxC@m`^LJvAYnSAl~MH?~VURqIKYInSpsykN#-T|1Rk?`aI4%)-iP z-;Zqwu&_p8sqr(wm@AX0|Ek51A%F&)isx(nU#Y+OCMnm-1_TJM2RK91-E2x)jj}b1 zQ`88>-9Sf}K}Q(hxQQxIBbD551a2}80gp~!0=}J*$@B5R$}r^=V65u17rJkH21D^1 zFYF4=Z7gwb66||6(8@}HCl$%*jRoXz`%<&q)`y5Z_3lLft%t7qD3Z!^A{^u zi+BANhhTtKb@M0C8RY@=AmaZ@y%(1%;=SVoBV3aGqf&ftB8T{2gm$`$k$i!Af!gd| zviq3bp5_8NK0alz9;6W98d3kRSz+JrA5fy|k3yYwzer9A=ule_W((sRzaZ599SZL{ zhUcsHpTUhBBJ=>Y0B`7{D01_2*@0ShB`Npha`q&3q-C8f9ease;>G?KwI7OE3_Ip- zD$BmTj_{q%Hojs!sWIsX09deSER}@-7W?HS07>a*;D8M2P}M<*BTE`mb@1V1z)s;P zpGg>XXa=-dI{vVgs8dGzCAl+{EbdEy<>=b>iW=m&UQFRECCpsDDmx6uh)rjY@Kx4! z|DOPt?=87pH+^zK2or<-3o8$3(PEC>4q45+4sk8hTo%fmUWb!9rWf1iR040;E3lY^ zjLtf)=nA-GQ01X$xWzRzEHG1+algXuRr{3W&LobYc;Kq4csO!K4YH2EVI()#dm=`+ zNc}F7k7T?>5bVWRfX}&j1&<->BvNmof7}+vw|Y4}snx;Q7c0i?njOmUewvs!T}Afz9|FrMKfV*kUocrV(e-J7FM*kB>Nehe zUVG_G^LZRy5Kgt--cK@5Oa~EOVGWp(tL+2d=_5yZG0gaKAX~fQ6DQK?J~RN&o~l=h zoFzAH$1lCiEN!fI`x8=3CjyF+7K4bB5wXNpBO8IOplssR)g%_4G9KN1B@_!&751gY zg-0r={NJ&rGy$~NF)5f|zY+9^2G^hAjT3-&F(ZL9%z)KlA@pj%Q6}Mf`pJznBi_LtG5b9Jn7& z1sN{rV9%avWTpN#-d}^!wm^>|z3dRDPLlp>k zm|$%yAOI|ayWD#$MSv&n1txjq@q=k*PVJybW$)$3)DNylBfTt6v?fHr#*nemNh?c5 zK?PmFbMjEtWJw-sQ1B3qP$ck_@=^WluafA&tP$o;Z0c=uxMP&1)JbTLgJ4P?IFDWC zCcAb3|9H7d=lN!Zj2kN14}vt>-~g%l%YbP}#Q5dZo+q<&Pv=9xz&W3JS>VH?Rw+^VmK@^CY^8dW9bDE;(OY;pXh+0U<)F)_ddZ9Fy3sD&${rA20$OE6z zil9+*p#dqYsYN`q#PSfE{7v#pIyi`SJMn9d1HY=lx%fvdylNkNZP)QJNWcPP9L|&YLnzIy9h_r**@Hm z45ZYQd)VBPlplkyay^*54BLLcHDjRHf$(Fmw<`r+{~B zi`@gU;8SLBN^+6g;j(N1W3&WE5-k*$^~`} z_yB3yG~A#UKKE+UvG`LX_kOpE|HLJ zwD8?`Qk*_46l)l9((U{LVVhV}@z~lH$x07TE0as?EBDw4smh7&=iEFpAyHsA zi*gvbJzgGK3SS~I4PKAny48`!S7AXhVxh3&Y^qIAgp@k$Vm6>Eg506=N%{}59$@_Br`;!m+P znLBKqfA&1XhN|ZQ%d11n$QFc<)pUrqMbIYV(V*eHM{42|#(a8xWB@7o`wcVib_K1+ zZxaQgJIp1>bGSCqq^_K6%0qitnZP0vK+~GB<(F{2q=&wAT@3QEm6E^h1ZB*eMjbuo$~H1?QMSkA!W>X z7Hry|PO@hAEOKA<&PgguWwAKTIkfFppTifDr>j1IEgKll8!{!*Qn9CIwDK%lst#2D z?vO6i#s$(gOZWMSo-4fzjHsR_P1k;Bf9=2IlR8uODM;t2*tzP@9;*%Efl&VuZ#4HA z!FqW^c_?dOJFZ&KgKn3a(ZpxY#CXy?8}>*9_(>zx!q8kgm_kH4fCjkqk@O@Sp}Hfp zrU!7Tu}YKpLIy8c!<509{g;_jq@l0KRI*#*am<6wAa)kIC@T#RZk|zLrNpf0;mj2V zTp0`Q6dzIOqAOx281ZizpHb9S8=bGD31_nDO%vlJz(#+Mc=$3mK$0l`m@Bm_KtkqD zh=5HOOg?CQtk#vm+^V^E`EOzfSu3q%ba65O{*A}_ClUtlN2So=nV~Z+UcGM$8TWGD zg@qEzZ6AE3(C>qO*3ce0XXA|upJGw5-Q=e-4d_QOwlJ%7e&=!at^rR;%<9!210bA^ z3G6s__iNmMW`maIN*1SoP6-IkWV}k@=ay!i7s8J*&Qxl#=HVbIROKgVc+jo-Vh>pN zP8IWY;(Ntq1t+<^=e%B2f{({W#4#{IA>V=Kx`++}vs=45YyNxlYNWrqpppwKn}J8ROz;eZ zSuteq(s<&sdRs5^S=V2QqQj81BV#EKhf6&E!~6!>*x)t}-b{9_Rz6+ag-Pz00)bTq zpGmxYg-UGqyXk~^B^*{)sDxPtl3X{7ZlBlpUb>8zhdM~BqixC8 z0x@pq_c)__|941`MENyf`YYYpjEw>>puZWQl)k;R{kUPq+(nB+dy}0Ficg3K8UfaG zW=kVTtrqTl81J*vR97M~cbzJ+$-X$W96f{;-g`?CV*CD{g7 zM>ss?^)agfsYy!CI_sc!qw%-l3y~?5@gcfys&faFZ2N^Wf`D{3KDtUr(0V3tI2~A` z3F6MJz#OPABb0L{+2!Gk2Beo;-{)Wk~{d2pI?P%Zot^tVTP12jlKQ zs}TisPgY9uWg9;r_Z_XV0JDe|DMP(~A}g?^Q~AteU60BbtM7OAXl7Gg`lmgu*LY*> zB(}!2_v>KE_hHPn;gBXO6=!-nQ~h4bnSyzpeLKfcb?xP7M5KAk{91!kFD!$(o^kXc z0_m3lXs6sg4pjXuJr61O;ntS%OOm6kwtdKcq4~;j1rt*S$7e(Q0608vnL!h(=6qR! zj=+4c-}{r_v3YYPvfoRpUg)x3gvBrPQh|-;^>(~9(U;>^jr5~fa;Ez3pJzoA4 z*su%}mwRcL$o1g=B*O3|(z-Ga5DH7kFjjqCX|1lD2Uj>hw79luKG7_Heq~o|>&EQO zZ#vHJS|1Js%9~D55rtWo%CV7=1MUw9gyQcs-ErK)(yl?1ZYgtiyfHmpj<(z9hfycl9^qVYu8> zX^7-8t8>lHiNmB*c4E!v+DSo%@7J-F6+g{Dw~Z?0Q;HCE<_6`bvzUWQjG99X{EJcd ziF({$J5!d-_2m^C`cd0|p5i?_*q{^0;qvXZ@z(vtT(@I9!z>Wb@*IAW@u{@`Iq$$) zG1^!pIW(n{hpf-I6y0`^M6ZrFIAL9^Cwj&8^*0ZXuz0B3(Sx0^ceXb1@88==)a}%- zM{$qec-F1gkp(7TMOm zB}@9;n3xQq(85uBbs26F7+?KHrl-a?+L&V~|&UXx9a%T?RrnQ_zftl)Fw`stR))<8MOzL1n=mR|vA>^%3vpRZ}snI2mQ4l1vC$W_W~jA`JTN z#DCJi$*0fX@>?N7>vY%PDq5LoQ2U?6KtUaPO3zb-oV@pc3qf)xs})aLg6H4|bSoR| zR+m)g&{6#;pel^u&-X>+SAv4<&nI1esD;}A$X?p?cpbP=X7DBcm698h;7eG20!Uv; z!Cbj@tGL#`Lp+FecKdWYHSlu>uL;-}UFT#t;l9Y#4ak?+A3p}_1HXbH`2P;ffiMvM z<@T9RFKiX<9(l4(L?eYNPmBli0u=RX0-TRt&A0FOmi)t3gvpCXdo#BbT|526=Yy`X z#Ccm^=v#8wvS}&v7z#CY;nPAsJ<$$Mm@ku?4!3MrBea!Go*QXcoaY)Ub6ku}E{=-Z zxZBje5Oa-$X-fn4>>PVx_{gRu$@B2v^;LK$G5IHn2fY4-1dzUp-PBkwml$?kdsD8I zC9fiuKm7T3+ConYWmphz&L>z59XkmcB2TSlql-1g$OU?p>mAj4AkAV^AHA>1VM<7T zXK~Fhy}{W29yr;Jb+&VTen1r0un`saEugR)2~_R#$C2qHzGP060$bplIy0;G}sXJ_e9JR>{gO+n6907$@p2>*M5b6Qm z>a({(S|pBu3*d;mK#&?caX(y+3Ln?)DTAS~Tswk1Wr;?MpHm#NQ_Vkf*^(J`n@pC0 zwa8#mGI@NwHq5IAxKzWM1-sl;4&*4qeVZk}QvP3m_*Uy3dCT}P+8ulPqSdFY=>cuKo`_rp-T_B?mq?g@QjKxvH}5}Up)NP77dv3-+$=#_ zFm^XbOB!6o&h+KAi*cHV&QT(rq~HadZ%$WI*>!LeMV5}fOC5`bx)bN0U7pX`lYFNt z|2HX9j;Y4^+Y4YF!n810lRd6XK2yZ3QO+K|*MQm-z_K#&0lQ07kgMJAAw+{?L21Cs z!29{F#_+9E@KI%@dW_gU;IOV#?jLMe$E;0Jl+|%CNYM;Y-;+C%oQ5&8%uK*J;bXh(ci(~;UK7?#cBct(lO;@cI=ekCXHd%2geD4 z*#3w+`kQrBk_3RD_W3>)bSVG{gfF0%KU2rjUAxPM$iO>J7!cyl`on9&j8k#!D?l2FD8o-sL%r&{IqO^lg-?8OJ575ZZT@7eoY%{C_0@Q->2 z4vrhth;KQvfq!goz`kiIRCKzFp*o3-V@F%zj^QTU+#bo ztC&&aCb;yuWAnVZGl+@IatjNn)=dq=XRw_NrMoIom?Rv>*poLO=@n>Lk9S3YH7cr8 z*=Kl#&@f!8s(pR9yB#p=j^MLq7FiWK!!#5sTdpa?Z-as01LoDxwhx^mIc|PBjD(QP zaQIzLFMgbgS|JM|0ZOQhxL4V*9Ji>as&u;U;Q9a|UI^;ibH;wgp@Arna^6N<4o?REyvz35FGsVrv8yAC#?GGzt{Draip1->d3p&pZeALuibr@#xUlcus{9OhpgQ; ztC?z1y*=3brs?aYWtb0+Uqb~qxBaeae7Dd6i}UToPUSNcH*x>ZQ&W# z_$ZL;yxKqT00AlBA|wrPPdJvGir^;2AxMH2vsS7fZ{&L{!hNQyCQ{n)(XV; zV1~I^F2ALcP-`>UO~>>v7MlnCP@J5sHPN?oaASdhl$(>DKjX%KsMy_i-5q9V z0Apa>UsI5_%LOHbX+@_(sZrT4cY@i7`WJKC^2R2G?f5@@m?<`-%x8vAIS$juZ4WC) zQ=xKuK?6vS7{zFg^uQCjMnDejwv)x^J^9dz|J|r7^C@RSqq~t;W#8g`PM0GNSd`SA z8Vt(nD}csLXFt7Nec{w$BgKf3*%wEsov7m{@c2YR8;(!7^N2I70m45r(fXu5TwK7{ zVXlTDJHF2zC0#OCmRY~4YEDG0i>$3?N|*t5dmq0Rt%o3aA<|sEQ1|MnHRmQQ3Mb?* z+x>5&!Y-UB`0HI27NXYit18C@dspHJ(SjTvTao+U7pTC0&=Y$^4HwbS$_WXs&Cx?* zF)efEUL`Eh>WKN1cf({p2x$_V<4X9}qB+|ghs3~7K6c@&(pp>>V{Of0=Kuiwd0LSB z`^f?XO6IZT7b_|RL++G24k^eOCiKP=YEa0V-Y$jxLhPZ{I@;I;f#Ly&?I(?nH1W~6 z5%E2j*sk&M_P{9FMD1RUds5rSAJ|DsBWmwL(W&tesh>k_U|&EE0J_IzgJOQYa@Pc9 z3*OF_*#ndQHrBO&pDL|FVJO4KUHm%y(jvS`dJeQL%9dOuU4UhMMu0V})&f?J07O8$ zzu=_e!+-EufOssAd$%b4m5T>B$h(AvU~sgzw}e?(#tyZD%JG=b7o~Wu834%;`|K;rTfiZVwtvFrE@jqiPKbOifGM5;v9A2+9A3pKrz zM=m~h_wrWO%>4=!VaGy>vp-P%zktaovsJS@K{BQC*HJw1D#5dPPERaA(Pf!26r8m# zn{J7+P+=65^D~~Agk4kY2ran9TbP(_E#f6n&3Pq$32)t-{WTRT+U3h!#yZE8HgMS#FfgGOwzTZ_I=Ka}{jJK7i*IOy z8|?3j@f<2kwWPmB@0q>v^X5y3^HVr)m*6K--YG5(>S@jpw$Ky0arP9{$H_-k)=efT z>WOq$E1&;vJR%j`?s*mEIiX;-}>@f;=iFRhFWTM}bk8_j@273%zBjt9>7f?R4R z30Le4;NtK~l%~TjA}iOyXl{!OAXv#OSmR7|ENRX$x}`ciE)CHylPUNIZ!P$b{xqFx zQu>(g$Lpj;UZ4!|;bd(l_ft-gR^0JT0Ao<|D*2`sZ!@M*JcOq)OncVx z*6?d+i}m35E-*6cfkC(h>t{45NL(}%rYtu_4h`$cKCt#uy5ze^g04H zpCWSe>BMIer&FFLC^h4>ucYS_iM4qGT6{->FX`^GI5Q^gY2C9$TcB? z`_{SGOmPMP*;`fZ8i2&n-=Fy4A0<_z{W>MLy~V>EVXCd*88ASqwrlD~?UL#clI z|34$|12C(aw$yM54Jvsm*#7C=j@2CJ3y*BJ7keekMK8haE9v1U!{$L(IH0>R$u@6; z$86cA4nju2jdpgR8*+iFFE)Fnx?SR;R!$^J!RD(qaGte~1fjKwG#*;_@{Xp(6|EDd ztwys$!3d4XH@>$4vXPFj^mHT7)YzW3_*E3vzs5ikLF=qv!6~wD=fz%IEFlGpx`9`; z0W~XGeu-8uWHV@LSE%^Gp0kT}gtCEw+HcI)vl+hV;`l<9H6l;Ao}O~^g{S_v>hmZ4 zWhhoRA1iFr`ybT2a8gA0XoAW1!Hwj6pFov;t&K7sO9%l~O=eds=(G$h>v7=( z))E0;2suh1n83Px)-hhfM-G@ajK@s;KCF@dplYvp8j;02=j_)|zcmpFJ#)|W=&W|= z4RrnMvYE#q3J79PrCy(2UAgWJ1rSV)0*Icln?T|oXQ?lmc4DgA!T&>8`(-C z|MgZ5RsqE0+}7!g%~gNJj;q>$BQ3VQ)xDQa=Fy`(p^hD}Drp#LuH1m*zW)ne2#lh5 zjT+T?5$|3e0)sM;K#NG;u3kN}Q7ze6>rAb@9RB{=677Xh2dp&O@iwzPHONUR@YvmN zYNTdIqo@W`m`pQD{BshxJ`3y16pO`c84N8nB-8sD8}i_%=6uh0>#%#qRftwaR_hE; z-^GcQ2hmD0ugQ?-qp91JI2cvFND4*Y-*YidQq+4;jl3sYW~)QQ1wLO6E}HAvxM`*1 z8L0FlxUoyUd9lNcGxkX&F8)}CS*wuHNxAMtAGY&AY3mO~LH(&)&>OqNIZ`v71RxW( zUX@(|MkXSVeF;|FQi#F|B@_8jr37W5r%PmwI#t4Zh@XU*31M`0M%9!I%2R_#h~m^9 zMl@Af!P5P+&*-LQX|2(XW_vR=^U!xh*KA$pjEGdTg2WwCUAz)$gvPkIscN%FeJaG% zl)X1*U6J_R;5%^8a;79U~#&a-pbZhOw1XI+vz+()hEJy~0tQ zTt4Wpt~Gq#hKT_?$=rzkeX=<(ZM;&5hnhv_b4015gFL5el7Hz@2kE3$!VWR^Ia{%Y z!2i?>$O4aV2y*sayQ_>De$(DUOaY&%7gcSh9?c7rfcr zoG%uXBS7p4&^#h zE}F6?fAvBRfU!@X;#9R>da)WTW9hn7J>2m9B(Bn z+yxf7p~t!MS4Q+YTU*GI9cJe_sA9jpvTcDps;$PZDQlR+We%srQuLbuP-DSUOGO zw9bJRSi3ah!%`5ERX;Q z<4yf7UmX7|f?6nW3EsWlhl)cyP!(Gl$5fy)Bhe}`V0APskxHZhdkRpFE?%bv}zEPWF zAA^51VVE^E8K=4o=qx3=dU`(Cbth5?r%?`+v1LGUQ}%mj2l%_VIFCh~^*=G7;rP8| zQ6O?Qetc#}s(c4u6^EhlJVK#~PCo}{CS$LJlN1n8U5uRoW6Rn}n=b8Utq4M87x|L_ z_9BP*HrQRCQr8A6J-B@yd{y9)JwXJBM@UQ7Ioddx-$G!t_nj>9haa&}QMh(l>&>h6%kky&~koCnh# zHr_>YBUL869oGwu#deavM>eUWpG1gIGi#`n$B?COsg@RcKy|6li`?T1trFe{%my$f zE*J``q?;w?K>OF$Xm&*sI{jVCKws}Ui-vP+2BZ$lLWxbKTfrCyheniUqm+3!dqXr@ zK$e?BXX6s|JfDGEXl=}>nu8%UzBx8D;i;BO9l3*R>#KvRg*(vDb$yhyNjN#=i6b&< z4?J0ptaTX&J)PIt;Sxfwf`&kc<9Y8>yD*Rbz_Dc%K5SVH0@8Fv=@${PHl^qzEdw_L z2Tq%wGtPHCQB*0VZm>~mzd90E_yocxH~iMd#uz3|WTD_>7~|_{2lk9`JfQ>B%Hc-% zG5RC5uX?+JLrUt_zjnZ*kTIZpCl~oJwDU>)iB7 z40fgaMks8tQJO3#on~GDoDGho4J`Fz%I04rvojV_bLt;vc0r@GaYRi{K9XTLh*DHE`5g<#^SCaG=!h*{&riMI?{k((&)aoD(B92J5^l{9 zT&>^m=5gfwvJB)04^Lp&FA!|ycRU8@m6 zK-y86l8zzzkorJ*6lj1lc`?94b-3*-siG!43s)rI!r6{Xp7@b}>(~rV??ym@Sg(k$ zF#j;*8oEG7mzr%QP}zfIa5@zyeeD&c93-zC7hs=+CfLC8blWo!JD*05$KwZwiy0z8$?yu&lE#zO5IBc79= zEEc=7%g)!vlTU`bvFV|?jL(mHT8*YRcyh<1%OJDRwm6)Cq1_h2aK-c}xQN#=WAt#C z9&0EJxHuD4y9{Q!XpIO1Swe@cTZdODMZgSnr%QT%P9PsgweOP^qX29e^4rcTXGuD3 z?fUj1IOC03G`xYG($N1jBA1Cg2D6UVqF)m8lZ+9kxdMoDw<^0PEAY{d&F(w7(4Fs6 zKY+V&iApZB`UCz$mE=`o3RRkvCu$84V0`u0+>?YGE~el0cXTa9wMC(a4AEzUl(mAH zu|)%6VrdLnIdkaCQoW&|vh~GB8Lcp^VOfiN`ptZzIgizj^6O|as5kn^&~2S3369= z&^?1NqIX&%`n-?icerSaX>;kL*=wqD+F6L z5*%KeY-Hga$t|x+OQNfuMckW18u{#3212fV6qSjRuk_4m2~kwF!=ZzBF{2=)uW!|*1qOz zLHk$svl&hP9Zp^GcCs9{$Xn}&u1y%7oLlBl>XFZ^)%^zEaM^B${3)d#^-4bQEv5{B zZ*%iy4g(E+aZ0i!LF3|Xn1@}HjHx`M*Y!9=@C;m-K4dny0Rbtti?S1<{M$_3TG3jf zx6!7ooffIX@?#9!4Z^l9cs-P867~JFH&?-@anXIXrqv>Xie;a?6soPn!t#>0>xoYvH4*2XawlS2Bs_4V9ji+6 zn`oCIA8cY~YE-9KwAZ+|l30~b8(PXXg3K2Fvj%X1STLMwT9agbeqalv^DNzIo(l*+ zrY5;+zk@^94vju-4_y`091%$A<0nvX%p5k4CIiqPgWnKVgs36;AAnz8b!M2Q(=}=; zPHE=wNY#s1hBfNw(bU+y*S0Blu(SN*Ovg~kO)CvqxtO&A18eo9kYA=*Xieey2!&r@$)%h=K za(BVss4D|JLiaf6d4DJ0CQW2L0aglpA0eXjkI+jJE;3 zt?ANJ8*gyKFvJIcQKUwCy^v{;He@(r8OGqXakN12E+P4&L`q*xvD# zxmKpdx`!p0n-=+c4yya$!ReE+YId8_cka81lMiPvq+TP+x)kA=WW`VFDu`9P!H+eVks5^T9&lBRa7G{y!idXkvdqt&kTfR0196nlDC8+X}@4}UDcj5Z3y4lS&x{5k+@LIb1-z*R8h)Zwd- zfYRxy-!6ybpD(Y#&^x|Ff94yPzOLfa?0D9X=|Ogdcslwij{VlO3B8P8SVR1QV+nBz zog1bn6qRSI{68l4-Q(6S;k?+aT^V}Mbb9R!!uO>`vYX>Fh0bfZL~an`TGK7TDV06XRy#H+!5ju=fXBhba=i#-#%@ zX+e6S>GkQF7yyFL-Xj3f%lg?_$v8fbi7a(Hjz?!Yvl;O=V1c;lqRR60X}gBn3W1{r zv*k<{QiYqAnCDM;pC+73&n~^X408%cg%ABQW?1TLS(RDyZ!rRLd-0-PDa0edW=5if z482oJmFY6@4--jGsWvD-_SX><&)@pSnwD)OWb2b32q*a=#Wvw1mEGhaG) zM6lbOHhVap?9+}iu&x(L7J0Ds%4@^UrPVXUdV#H=)TVx!s9)Oi*M3V(5Cm)}#XHEg2p zi}$WxiTqERqDl* zrX^Pcpk^>cibYpLN22XH)U*D2kNSZLvh*HFKxLx7Q}wnQyNx8#S(d`L%wCrJl&?bg zWoyNF8+=+X$Zrgngv%0MT+)GU*ob`;S zd_SVYxbeX}%V>0Fbx@`oc*?G9YCpLgoJX1Vim%Sb#LKEDOy;ikIsIa~ zs<9}IFaAvhiNvnA_Z!WSW-Mt8tZOKQapw(UI2P?rr0!e%@#YFlV^N z+H&{D(~((ly%#RSIVCo&LnK7U&O5Q-NI$tf3lg+38WBu%#HJ7f+V@1uGOC2M zXQIBAJvqsSP(|_?E9J|}(bLwA0J?b50jAvvv8F6Izy}>7vNtMm<5Ul}sEyH=SYpHF zhwYL&9>)T~W}ng!;n=j_3EX@0N0e6}d%I2Tk*+{7f@_?-t6BI`qD;|(0dOrGaz{q4 z^l~<78edwwM`#{`4hZzl3Mx7rCoA7C=>n+`Qm$O7 zwJ7WfFP1I=u(Xf=#AzwV=F<5th*eZA^&Z*6EDwB=VSVMJ@zw^<7l=w4`<-xjBX^5AJ;LvuA|Ax%{onZp$2^#i=LJqHp-gCfcNbz+l0XS{=TX z+33KVEAu`fwIFXTj{0x&4lj~BJt>~QFOtPYo5&Y8#OQXwz95u=vt|6}rdJ(cOm-ry z!%Fq@W5$#T3}s;VY?XU$fu@R!?muhvKvhgRKOI^~R<+h*>XB%;%F@DVV-SFDEkjis z_{{ZWhhQAQP3@0G<6`WlW%iXIqYg0@56oG5JQ~0PP;PZcHS9?s!0+rHAKb-u5KTzs zg)3*$GqUr*OKlOo#OGSa(1^EB4tcBeqr0UI^vy&u#N9Li+-+k=f3^bUfpb~)P zWd11oV%ez`ew~^NG?v-UZ+#7Ck0K+~AE4|H&+RcHcr&o<;u4&TW_6QtOZK=Y# z#?&TyYjZXQ@BNolP>g-pPO&=;+d8CIPTz-05A|9rI{k1;-Ckk)xu-H>I4a-(`HuaE zl<{>L!Y06P&6?QQLJFnqVBTOt?C)7Gyh3X76$8Zx=r@4dJ~Q7y&zzRI;SsmjCNya^3ES9IBd4ziC2%L0fv*wemMo@M2=YfI zJwSkxGT(a!cfwdX3mBNo(b#4xZHx)V#mAeIhGUeBX`z(g9l=l8SrU98X+w2Bks71!6W3o=oj6_FpJ}-LG*Et zO!dekll?zbI_(hYo0M5hu_JM*SzGp2#Hkq;ctysRE0Xz;>uG9g7r{n81rV781b}_~2*kd_lE<4pK%g)9WfD<)> z$>YFq7U{9W8kW07Y8fn7uYYHteoe73Ttf5ebO^vLeqP4KVY|n6=i0{xJgq$K*}}N{ z()k3|u09djoH-zQu^+TP>7)#ISyDV6f#1R!rNyZqr=|ul3^lbmL(W$eEfR$54zn+( z98WR3)+!&x`X1--v0zQ$u<0j)Xn8PM+5+Jgc&Q5RyQmJK9A;B|YyE-YMr&~6^MWhn zah=gOfqea{fvH>?xWHMbS9h63iM=Ssn=1I2NyU;;Gza(eKa3jK$EB;tbFC>N3j5ll zLChy1j7xfUUm! zm1&hC%$HzUSIQSOx%P z1}Ea@2%Q1W1u>2a;fr|AJV1qHL!Xl+&1W$Jw!{`GFULt}>&8D!n>j^?V?^h0%Mj*n z%>^J_oNIJX<$kUr-6Oau$cDC$>5Qvdz+d@nYwyV(86BuGMDu^%b#^hYr(&*WXG!iw zAq!q_q4uV{@+Q58CO5WCH!5J>)(4q-H$D1`O7LJ6c4t}4aonXx-ScciN(|n90H}%m z-;-+#5V1`iRN;Oo7*i->C0>K03XSo%TkW5&Bey(3w6HKk@EvSlr7&I`>)gMOQA=)} zrk^&kp0cHM!Wy7szOVh7P}5b`dmMFgrB3aam}#6d(qfaUULQ_^@~@1@EZTAe$!8*h zLvGGEumD4EAc4pucAL&OK1x^$FBTIUoqnl~Jt&VxoyR2mF}Qh7Hnx%uoOL5-Y-Hrs>?1VR;zL(os4 zTE{3B%joj@j&(3^Qj&Y#%2s!BMoRzcWD>&TsTvI~9yZ_>Lv zJp81|i>Bun)7wL8>LbUUV^fHPs}1G)arKiK#+wYAlw7wvKK`5@)6ctQ0)4;HRW%vjR|_Hn>t`(&6e)@o>iuhTZ}|)+EzmAT$JbCwfdS_C z_(EXhi^lvsX0Hyoa2i3+cLFw-QUR1XORRS-3y3h?8Ek1YSC~cn&hJxt@56ldl??>}zzK@IsFnS!i`Iq3Q5d-o8 z!M04Yw^7fo!1=NMtgfCn^U3gl$z8pMgvcoCFk>)Pj2Q9hbIG}=LF#yjtGY6vH>Qh^ z)&nWn%X}ON7&pVBr={jE&?@#DlOw{~tROrn($|1)6lNfS{yRyQ9BozU7@u`@BkGg7 z1Oj)ka9x;eL$~Ql0&JZ3M^}oWc5I@#ZJz+I&XODp25CHx?>$_hp3j)WZ5W(hz86$N z#`Iyp4xsP)X;q(bOcIGKc6TPujgH9L5A8XXsk)QcWnhsbL_xS1z}Oqz+9A5g+4QIw zRV9kMpgAstB49^XIv>Jd)27l}u?GrKU%-4hp{gBUkqwyrcfbpham9)w$BL`uVC;W* z*bw$R<{-q>p=f2?q`3m#rso?3=-UCw8cTl3}!mA2)R~X5~cl?lsfq zx5boTr;)86P1fOtnX8hG&c(h?Hcei)HZ#b>yKk8KJq4Glv|nYPB8Y+WOvmcHuv!Go z?4;qf7Is0HoCE9ZK=E2x6Ap+nrrD&#Sj1`vAocL;{1#Q6nsS$x&$)emV)@XwSu=|$ zR7p$fehW7S0;Yv}3>Yi#3}Ace*J%3}dUt~MV?1G&k2+`V<<4nIS30=m?8VsqgRu(8 zf`Ot-#sl>u1|(deSp?2Y*sO3JoE#HwWRX9-|BE3N`sqpb#~P?hGR==^eSTE_t$T!% zrle@cv-4xhbXO#LEJ>;a1m(er30ukQR7ZcDHntqk&b-?OTVX=ws{c=>EWEP-9U}Ae zG@+^?M6n}^MHUgD3P*mbY(Dnt!(<5F76y0rp31<$nJYNbhu=SE4O|chP}4+~PovTM zJVX~JiUEoWD(pTYV%vCv!C{Gc9)S^7V>sc$me+qSI*LGx_1N%I7r%`Krrr z=s=Mld2DfC+~WR!Wc_oAJVx92z)rMZ{9r=0Fiq8m6oLx1`t|0R3| zqSMFLNBN|KKuB0g-nI4#0=FNq-{nb>-7OTTekc8yGX_(CuCTQcKrhp{WUfK=>gP${cz)Z%%Z zT08HfP0#M#4CZ@%ShF}Z=7dZvQ8v_qoQA>A@5m*3O&5J!v8or=PBx@6g2lTwOaKO^ zQXgh7%gD0RDB)`gMuZo9coOuAnVcRnuv2YbdA!hl5yLA$#c4~s2>&WL2zvM`f-`W6 zi7eEY=UoNh-x&2F4SnLR**4L^x^4Gm^d;~NS0)E^taOY&IM;oP*T}m-cLV1q)eTP^ zics{#adqg&lniu@Ag9bJv>f?PpgZ@?s=Or|?)zjC`01QEt37naQKG~hxV5MVqY85q z3*;cWXkVx@WfJwAlMPfK$2{@#UHo-Lm>LxS`7xi&^s*6Th-`sd%c=3s9e^P~8AGtI zJnfZ@irSffHoFJgkMPVc^yBzciC|OPUmDT^8zR`xLm_1XnmB@uKfON?qOC?57}?gO z$sNY3GF07pNu_gvDfXG_fi8M=d$7v9OwqS%ObG${Oz>x!JX`-Fx}0~kR1k{VDL(t` z8VR_j#Bpnm1A+qKmvv}_d(QoK7^Uu-j96n!{%OWQ6|d> z)-jMoNxAuPw8KOH(igB&`6lP&%$5KKNCe))%_F8CTS~92--e1Y^MkA0LMrjpslO&m z!;_STadLd)TZJdQ)Vo;%Qjvgo%Og&z7opn~0{r3Kq@@#E!K3yVJL%F&=GQ(ZA20{6 z1Y^+P4S6xhMPOnBUHFf06DRvd=LA7t5Fuz-gHmLyRf3Xunhd&HAx9vnBi!!Aq$bHe zKpQ`WvVFy5=mw>_F))wf+RozL2KAi`h2Qx_Y`YcPrUENtKNf5KB&N4)6^Qfg$jF2W zppO$%ldrDAaMcSK<@#e;5bUf&R~XxWky#}ypgCvjY{*SSI#q_7i0fw`KN|1kE_6>M z;P61_nY-actH-ua)xW3tP9`+GtODa`+&c5ucL}tdibTW;TyCa#jeMeOAN?z|S zM_;kR4nd@xm>=g?{j!Mu9Rr8*9AklVMC~=z7yU*G>Hv>* zd-go*uwI2e2My8oXhK{(tkllv6ZgV;Qt@dkCP{0xqf|uQM}srGhm7CS4Zz;I1W}9k zF4maeB91fbsi|0$l|QExfdM#fwVehcgRX|w=85zHt&V1)%C~>im8<_!Zav5+zS0^A^Hfi)2fQ;UA*|P+Ne%V-BPn6;aY=1x{yGDBB_wle>H54g z*$Fxl)CK#PZ(&K)@^wd2+8F2GJhzw;IGWD@fcFa>hyZTQb4wsQpFwdlT}Ysbu-@|u zE47|GNL6So`6|dzFuSPQGp^I2r0BQqCjCOG!N6kVtW7*XPh9`Omh5yv|2EnFc~zLH zKy}A(0BVm0S=2X|zze-6D$t0)s(pwgZLU}%$SS2YC%1)%qvj9yT!U$f@jciC?L0tF zVhcO{(-iRtPSbrsRs3xEcs6kwHhe|!ITn!96H>B!v>Vbkr3tF%S#E?2^?zH}yt*hc z*jMF?S=-73(?qv;Y~Wv?6xn0YZ3T0ssH~x%&fMWy-E7!UJKFB&lXO@ocOshf4g_WMJ4o8CLR zo*57`k0H3zO}9pOsL~Q8CZBn@fr{|3sU3?L%{^I;{x@tQBl~CGV+m+LgCC*{c+1r! zJVsxVZn*mHl{#2}Re(QrZBVC*iGFdqXe@;%?K}cK6Lz9}@|@|{n|eFi?D7QXgt_OKADayWenj~%FiVB# zn_P5BG(~Rn+X)qGVb{i(v<53-Vhrvhe^c2YhS&Lms^Nw-VA(wR%x>PBXP)B&HF(ec zC)31*JGH{CEhaMb2B1TlYnDXTI}OCwguY>VZ*P7B7f%VZ*RPyf=4fov=-N9yh_{(g z&Vhwo>Yp_iTNd++ki0c~C4JZh$GlM*+B-Lap@*%Vv?~O&KQ(pR=K8l`9UU!6wU^** zzbWl&=Pu1V2_`YTptZL+%r>;7C5R9R5{vLY%CiHf&y}gMsIs7<5y_ZAyBCk2rxgmQ z00{ELQ&x`$FrAA@H4PuDXo>HPRnfB7{}%{OT1_0T9>4Ki(FyNTxgo|Ls$Tj^yx2XS zPzAdZSGIm+n+b?r%`8U+^CvoHp?nUdQmy_EqpCGWIDu2$cr-C97v^9nW!7@(%L%kf zpT}Kg@o=TR7h~OiS)Kl%%~F(PS!;z4yzKDui45wN^wem5fS|<%=N9@R z7#>jvkkBd*`_kC%6X6TIQC}{wet7C7)y$MQ6ZNqxjr|6fY<%Md)@)-8u^R`f#8AfB8K{SI%Y9PS-VTz2xK;}M}NcZMJ}j9%!> zRj}EN`+)*DCN16hEoVeO@!yjlibQF81#09jYjwZ?5_SO=xahaVQzn&jeJk3J)5U(su%=?xE@@LlNwGZ8lo z{7l|8`vftX(2W%GbF=xhy(1$>CpsiqgC!9HF@-T1n@rzi^jp@3jd5+F3jn)_)RG9& z9+k1q^m%0V3Tt-i_eHTyFU|xg3XgmVyemY*Wu z+`TXvsrF%!4WZLNtqUjp$n9^}+com*BxS;cFl(09P!%el z7RiK}`LJD9G)=TlCz_eL|*%sglBW_$e3SF>376~_8Uun zbeT48xmh5yz>foYOsTOQTK+vu>LTp1Fi9_%i5Xssp05w>veExZ{EPeX0hAKZ=SpPz#*|AFy$~<{67J-DrkFJ9-DK}MftqUR z_A=|kWQ#ADO5|@isy^F}B<*=-AZCkR(j%nUUv>Q+Ub&G@YXK#piJx4$C5Jg?Go$I2 zUg9_cOZWE>8U$+9^T+H(?=RtcbMwD;2Cn8NV9*yY-=QQ-vJ4V#PNK*YYpPxbA2IcX)1GL?Q3B(IyMDFUBYM*kM%C!Fe93d zt`z8ogUx z;XJd}fDos($W!8VM8Cvi3!I~%cFJ@sPIe=}XB=CCAAL_Tpy_@Bh0?!*$3p7V-bvX z5>}B)QTZePV4xwyK~0pXh5t}9?ux6?x84AoVY{#vhMA_q^Wyp^x*_3XqA^adyiy+VEyw9RhJQ; zP5%fG;j*XF{#}=<7?;uwdL#Vmfyf3>)Wo;IsB;xqOyT0SQvSEB3x%2bqny>Dl!IXiGzS%T$JvA?I-Bi?$2mC`Q$iyPu{fxikIZW)OWT2bjf$ z5;1+v|KS$(T9gAGw}7RM%I$PfC1$}|UD+EXo_D@bKD0~{x`xq7TK5c{wL)c&4H_#6 z>!&G<247C6muIP8u%0gQX!|kv}AB+>;-zq!cUZ)Dy z0zWyhia>A}d0#-7Z*#@?w=Oa_HYu+bkG6pcC%1aLBh4v#>3lF-xvlf(%T;tw70UGc z=mT|>U|HpF*fAN9Peb-v(%23qPOl$;Sy6)C5Wkcb%DH5Ni$sl0^4RQxNL3G`kn?`( zBJYC>p!H|$4T``5!lYc`^RYP0-NbQoju1p~IO=JW!oK<3Ly#7C_hiw5{e*a(p@YWN zI7zlOTXtZ020DetA}y#~bUt?VQ0{v`Z09%S3Ao&iG{h|A8h9ygAn>>g;ly|5T78z= zRV%YAZ?1rv?Wtu>kbvty3znAw)@@?wZRGS7|3@+ba)(G`cE zL(Oh>5K#IkNmI)e@Hf~F`rj$L42#64!VHLbE$10U2x5&eMJ-+1}G>n}W5^v&CZ^;f|AZgPf${@R$iuYu!Ta#ZU@w`haDW&0{ zP3{Q&3?&$ZONk{kDdGbjh&okDqOI7QfmsjaUlNdQ4RMBwAqHwgiy$<0@~&wRFVKiJ zVhd640PV$=K30MZ(UM%n!iuT7mTB8B5RhrLeG83)Dwa#mJOw$ zyaz!3bRQP$r z03}BC5@8bup3=Q%33c1xDX=TxMg&b8+3O;E^}5s+50>(@DERUb;R0Y&CAvfBTMNP| zbWeUb2Y0OkKyb>>3@Z3$Cg3H@lh6)-#Va;_E;YL10z7{xAz*ZA8JX1M=zNy(q(CJaRe-BY%UCMN0dhLp{tFW+Y2LxWE$+Arm)Ann5EsxgTCXeLRt< zAQt?&mg~j#ltk=22g5`SO$IujiK&2kXidfA2%Bv1(HwRaiAP=k5Uj6gj0t#5AI5BE zk`8c@J`!*@Wh}>r`Q=01L0hlicorDsvu;T7-|;T}+KDmSV_bCLe$85R(mZnAdbvfl zEmS&&Agfkgx|etA#gYBWFOdmXKcQt;oUa0WHZ?s7$c1(#g0T%`jfO+erjti`oSWpTHDrIV>DYVQ z(*0cO3Rnjo32TVMaIRZ2M?cwBXvf^|%2#pNLhWYh_S) z@01`laAKXm$+?imfnGvtEb&#dr0JfAgD&V1{W%HiVI*1GXWjCv*W+BPBPeK@=jo1n z+lCr*W8ZkCm!p45RLemGYWklivHy-P3Y2LcJ4SAg?@>Kw{rQHSn=v!QyTqc1DUOb*8Vct&``1vGh~Iczq|sYoxz8Ki=F)KV za4xAtAe|SBjK_@5MAwd(;qxdZGzXp6l4tTWF19|_{!&}<)-o-%K-udZwClGz9Y(Ik%_#!vilMGK%R(BX zgkomWhs+F;aW^m+mpDGboRZRRjsXn~^70460$e!yC*2C5s5xXXEOrk8B)n(#zu_&O zKi`moRu#tmJ8v~3ZdaOg!vdHQlp#?oPzB!|=M285mDFVn3dzW0=T!e+^pNS2b0;eUtEqrg<=L1&5}-B554p$%ER3MqBMpR=4>Uv-h4{^Zx?Vu=le48 z-BFNjDx3=FCEWn)K#RN0EwAeqjs8&?%$xf%ZS1C8oDcF-bw!rVh2ZMDtK6$7Iduh* z#}2W2b-EBcuQ}@cU&pVBHp@uTSbCl(E-0fTc+1i8u1Od)3rcC+Vgl-Kj%K4lmn*dV zWs+uyPrHPhe^m(@;XU@{otMb@GTR5IaP|EO2a&T)bLF%QF&~+k=J(gsBgx0uT1n_7 zM{GJ%am=_Q+1q6+pmBuyI$Yv?Pon?PeuuCkdqrpd+&GU^;=hZNx1^M(5Mv3zb;UTA z#9Eu6g^9=oCD8U2sSV~UxzuJZqZoDe-)HYXvi-J`DpDf=mw68OJEQguxL7UVxyl`@rglp((=5MtSyFJ^Xj5$U0A4Knvg;!l)&k&Eh9 zf1G3E*`apIyknBva{y`9x2P>~%5&oiZ+3el>oQpof_y5m@_2A3_<)My*5|>zC2&?i zYmg%a^u+@*ZNTkr621k+N+c0hNW0oiL^Q5EjyvNbSn+2fwWwi4UaCRE*1rhl08(3T zKA6;-jhTa!@8=W&jyMyn)=BW0IZDh8ELi*M}wDU3rv;!Tkc5IadC@Ww=4Uw4Xto(obPezWAG|6z#CeS8?CUi$C1)S z^ET{0#}MCsp(S}xJI;rb;cHZHx3m4c$5IP3@9bKN!iGoN$C{fus}|DV$RUpT`U7{W z3pxrhr%GkC68K=JBMnwzL9uy%a-S z+&jzMYsbtd{PHQ~H6vKh5^fnhD8w8{UDDwjVV;WzwjU#%mHi{ymyeQcCfIhiqBFJx z@x7Q)H#sSVQ37|`5CJ*OzrgI2$2EFi(Kgwa`1Qm_X{=Ozo^=6Bu(M9H&PlM zXsN6Wh*f*tMV{<0z50u}$AAr-B545u0$RT&Fsp>tw$T_ILUdYeyuSmu;`eGE$%1k* z_mlDGGb$elG!}aGWp-e&jt{@-=%V*_J_b7cd)WRv=NDN@A@{j&+83B5q57;aN}+ZZ zcX?V5!WH$7K?;*hNE@O?XSwe_B~ne@e~YH1!v=ic_;paoFt(H&cgZoQTE)iI0L$Fs z%>BEfHHpkmk&aflt9HIX7j}~iUD-+kHac)K`HU*)?JLnncXnrmM4Y`f`$}ol2MnxJ z`T16f99>hCf*r5YQ)z??XD)HAq@MV>a)KO*-*j==O-DX2#4T^FUM@@GGAM79h46Y_ zUiI3JQrTh9`9ckD`7Nzt0X-5QizAm}_h%n3oqhZlr(@aFV|xVge)fN9(?o8RO34$g zmn=fdxqOXMs_?`5us^pQO%KP?cnBG$ZS70SR!g*XVV2Z_9Y^dSc+Hba2x|@_`Y8^UI z&C*dCv0DZ{b!=d1<}u+Nm+gSy_8CH61<^x@1BNs24Y~d&jJL-3;ER)BE;-0it%vA* zL=S|gP-{w8I;k)NDBckpDduZIMqpokw};j38dzfjAJbwOc9wPWz_-=>;ih%Pt5p!| z9u6VoQVz9eV@%BF(w5b^Be6S0a!{jLFdM`t1i`ZPb9=Y4S&4bP2`6V&Q{H~_RSIad z^hbg@q+nyI4#q$c(>^LZ$if6_9a$+<#7s3v3?qL6`A4~+d_D$+e$ql3`u$Q@>xsS2A$N>v_t zPF2`ooQWkcW@a*0fqS8q4ZtFMbQ-7k2@!*#fEU@Dpo)1xdgpwA#}LDPwIihFoUIXu zv3x#lR!fO7B~rODbD%-zhK@ucFtF?$fj&l%!??8WB!U(c0#N1ETd@W3#~w{S5qR@%zmji`sQ@8BUk-b_bIAbBi+F z`Wq)r`v9rz8u>TGrR8#O!>|P5(GG-OvJ?9SnIg;jnHG9Uwu}x91XJ_s?%0FG3T?Ih z*-t;=aCK4e7tW0639F@g@l2d+pvQAOt`XPMfLqjPFfX1+I=hU2ZHJ z1gHWN0qi*~Hg&)e{(HV3Go@RYbYZQen_l1bm-yo@KY>On9la?=Q(@2T5WOF}lg_jI z`WMnYj;@yQ9kUS^JZ++u!kTAeeBZAxs z+(}AFVM#hNL62voHoxBd8yve`lO%Q#%c=K!7uB$9Ty=FuE-D8{Lk)zO8ZG? zZwf?`>tJ8_wDNkOg}1P62y4%?PeYg#MKVvEr!ysfd=C4&$5zP^kSM_yjgLcw0(S05 z3OSqSrt{9yxs;qp)ENE=e!!JHP!89N<}z+&6_nGM#;Q_*v8h-#d@u0vFn-L4%kNzs zs3`+~c3r<<19P&#(`1C9{5Gr555{6VyIYutwjV>_W!u67`GTcv$ila^0OY(!j=6G^ zQAOzB99D%1sZ6CXHe$Zv>k!8-lxpeL1dXN9;WEO=*9S|p;(cZjq9|y2Q0NOH& z8mQ+oLA~BHK#8{XfQ4!Z*Qy`D7{v{Mdn#M%ptVnJimgLms^=M`91`}kwf3p|YW(NK z1Zr$enD6ORYA)q-^?(eVk`U;(fmg zW{zcsLKI9ct2X>)#ZLC-jLd8xHv;Xa@Z(xiiu^=UNUD`Tsj00#$}JGrq$Gdok-MBV z_JWR8#bD!aDbN^DCtVEG*zj7}m^X+@&K9m}l$_jmcjk8}|6q0AEy~(%D%6QPXo;sh zF?A6i*-ypf`P(9?2}o#e6m+AWhF1PO{-ZB!$XVz+F!QR;bVKi5?U;r)KMLMTcQ4$G qo9Q;uaEAo|00007JUTo80i~M+w!t8?k!*`TFb#_W000000a;qcozX1- literal 68816 zcmV(nK=Qx+H+ooF0004LBHlIv03iV!0000G&sfaoGPm#lT>vQ&2UKVgRpfkl( ztnn6!$!Kl^VMGIvukwO8Frd72I!zzPD&I%0*tbhUwOcVQPu?N_;t;^me&RmTslu)p z-R30K3!t1# zikjhI9sPSxdx@njfI_UtYb)whz-feKdHz_oDGjbAV1yZ0gH7VK@O>CXAcKi5K~-R- zl;iQ+1gWP<+mYM{w zGG<&ul8<)2&$a2mZz`#8beq%^q*w+$U>Ga#rM@_Z=8AcdP2{kQkdIwvl&w}lGgn+zK1r~Q4r4mxojH@z-Gd?UiU)y! z9=K;(9Ln+*Dfi)9i%H>sVPIo;mcxYbQ7V;poU=Y}>s+th6)7ZGmYkB2H)1#8M!S?E zui=Z9L=l^(JyN!aZH&vMumIM)L?2xTaWJ2W9-wb|U)HoL?}kd+cp64>lE2o!Um>t& z@|6d=mK+$f$*N+7+o+QMd0S2FBg|2Wy`j8dl6XF=w-Lf~3S>*-`1%|#+Qg(9flh^1 zX$QE~KV)DORZUJ&&zMqmRc;VXK5ovxlfEd)dBP2~xP_jF&KB%Q!}(j~yp0vMz+b@G zkMTr1{xIFSIH~1+1#Jtjd`(5RB7`c}hM{)MgNkJ*0VoqvfYfJGu+-mE>ZkddmC!s&|346cwDb}Hbt9Ax2Sk1O6O_7=0xdWC6So<~$4I2fmbbai;l(`E; zIt=<39jnJj;H}z{$oDm>lcF#(~8JWtTS_{Bq?gj8VEefY#sgcoK>K zR@iz4b%odGK2RyMKeZZejz#%z9O&NY!l~DpFC?ZzK7$$cHIQvA6r$;~V7kSqtaK3f z`2{6Ezmye<(`L}@1>8tm+_QRBCeH1n-U<&=`Q6wQN1;DWu~)pxK9N;lsqwMbmMiDp zI$O^=%B%N2zMUIbHl=k#6l_O@y_APf#~-C8ufF-Gt(IIgdY6UuhlBgN)lgqjda{ zoNuGl4)8N`%G@)H4d$tC|BxJEYhN@RwsIXzLfWaRJsUmYqH zRi=3@|JjTam6wci=RXMtUkVFw|K82MFkys4fLdrMeR{2qQI7(RW`rTyZ+%lVHCpK3 z-l0v`KBAB(1r$FXDrLGcbq*`|stELXh&29G^+$q*e_IO%K)jrGJ3;NY<6F~5zkfQh zKt&XZNjMs=V}=skuhys>zXCXTXz=j&aj(5!ll zKJJ$YF-3ce-lP7P-GhPAbfmkC1D|!9C=j;KqFCsRtz=_zmVr}Fxg52~|0)8w@ZhYbRR{K@PI zjEviTtt!JKJxiQy@K5Jp^ArVF$#MV~p~jOf48QntsJh#9Ph@4zob8Lae}|Yqmnby% zcW#Rr3_dO6==be)7hQt2bm>;w?JlmfbGH=Yr17R@{%6`bCCg8!J(s|PA+MNAsr~la zN!-L#ZF_C-x`afcpr@51sKGF7!($_y@6nWXhmJqKNQZ?Q%gm)2&v#dvr1`4yeu3M0 zF*64t^2at|{P%BVzsI-tOM!hWN3a4umxtVVI)X2hEQ0N_mJaCC^uXc;j*%Wbq^*QdzKc0yP29j<#eO(jFsMY6{ z-k*4YW`)jWaYrLDO!FonmNFxtzq^W}5~7*yBo(Uo7jFQOPOpvAx06 zh^EQnboUj=y@jWOE#0@OaOh+`uk(WXC}zqJ#4O$UD6B>Z?6 z$|^RUSU?oM2=@+6TTADcXbe$>?EPUa#R0@2K%ek+iBo`2qtwMwzU zKKR};aNN-7LlL?67*ix}QF%?_GOR!kHiVU6rr2WrFIYvE+q0-kZ!Vlt^1ch}%tH*_ zL%E>3yZJJ|MrrZgXtCk?HxDKqaBAXBeyt^_ z5R=uqGz~BOzFEAz!8J+Zp!FDFN`ddBGeWKy5qnph^*-hvTUAkr<1 zd2u&_?`gXWFwmI3b+I76TvkPt@%+;Ersq!WwNbC6cl2s8E$@YSrg+QddH9Th53{Q&lf?UjX~sFRLi0&O$l zES|N6HGZg43yb>?NQ=nzGU1C6%K>!IBEFIdxApjZ?fE`rS$H%Y|-_D`MNRrX@rd=SF$=d30>_k z37!CprJ~(-Bwdl!pAabEI(DuYRd91_<;-kGE?=pRf^6Zham^A{o$AaM9OvO`3(4{` z2{JoXd+t^cQTP{Ktq0}FCSpo_hv_mSkA%ZD0ozBt$~wqLO>Xd;4~~mj*(fo9dq4j0 z9=vO6a86-lZP|>$=W#I5g>1FBkbVlCMLqx)FFSs{7z@KE1pd++5HpLFsO4rw#gN|{_DZM=^Ch8Rsq4H1UL z@)2V!a&@G@DL*EvUwmG6La`mQn@LhYg3o@R8FbCSh$F_TNL2vz(*o&Sk;6Kk%8)(R zY*pzwZl2HDtsvv=@IeqGVgvUih`ohXo0FH-w&47ZDvPx_bN zLtm4t7~QHcK|%bOIoua^u{e&(XRd<_TeV^=$Q|NUzKdCD%nlWU$I!n0-w5mRkJE!huDe~k$qWly}J&xa@NBHyxTiGT%22fzs@oIt@r%+_&D_r|Na0Or!FhG+a!g_V$ecaCDZ1n zQAg9v_X9$*#7K`JXisoUdrHk)ERt%A7-P7H_}cCyBC(U`exZb|cLoqp4Q#=N6rV~G zQ{oWQ?Rhp1GZ@}EN=8H@zDoBadN3pVoH;eU0Iu<3X>kR3ZQZh%KbZ{`yG4Br+{A7b zw0_QU!U_t|edW5%r*Kl8B;EKM3TH9Avy?D!4Tu>=b1I5bkBAvR8;CR(n_%sBKM4hz4>RZap%g4GBH(1)E)n{R8tWb zA}S{t+O#(ys`tL*RP>ad$6pi;ul3@Y_=)>=`-K^WVQ&OzYDGEDkp8_l_-lXsfXsAO zFjJ?_MD(`E?WAKOf(zs>6FZe*&uZkB2FeA2qOq4(A7_Y>moe{eLb9g>dKYrTars71 z;k>W>_Qig0n^Hu@q(?S6_$sI-m)tdYx5zTPb^8ZTPIT%~QD%RBM&wp{T4tFZ%wVX$ z-t9*U5G+ChZzmS2@i7~Nqs95d#o+tPt`=%d+mif&`<%56S_eZ5Xs{|UNSNeHoTm` zOiI(q!NE?A)$>6P?bf^V0q(#(JSl_mVr}Ks_zRp&fD{rGH>j8}8lkEsX3pNS<+9*; z9DsQH;e{t!5k6qcx4u@O?(3*Rjsd7n7ufsesLSpSHCz8-vaV4q?XsLl-JqL4CG3;+ zyIQ{^)HkuIh-m^*H~UTx{0B7Eoj~5o|0YX+xY;_71{lVa64yHpe)btYraX}h*-Li! z8^lw4-(&f~vD<|mFUO36sKyK*?#Te$`r>Eg-xE~|Mo-Jc|LBq!LCERf&Hf?-Ec!E! z0}a>AOS|N(OiIlQ?^%@b2#T%9@Yd}a4--%?#$_>bZS%PGFWXM#)F`tM8&Rq?|MuIC zqjAK-l;9J@mK_JVp@7SNIgmN0%kZ20j^{!i$CYyqFElxlgq>HP@uCl9yfV3Ovj-_s zLh)~uzEqO=+=A+lO;=KzUWs8EFtPI~A6e$aIae(T%`pA7Mp##Hn2D3&E4H*0K{y z7<0Q{r(?`$R$Z(dqYGq^Y8j|s895byzvjhf>Ei_=UrS-spIBm>Z%A6(KpXBGYV8F% zrGKh55FoAWuqK(eL6;qBAmti*vT9;+&+t5WMR|z*)+Yxjl_(5RH`>&>|JHq{WyNdw zTf_NW7Fo}kCOC_=a1BTX{MGE~*ZgLk4FFDGTX&J|M|E9-ob+^O94Q2z8?yvV9Q)tT z!>_2WXn%tE3$i1dr8IGgv@)phTm-3-cy~SliL||>GZSrfs0p@%gSv91RM5)h&wzTZXcrzyl$u3f43{pm`_gLmB=T(|Aie7w6 z)v9GhrqPa*2-{vzI$h0WCN?$xayCP4m0#Hz()eE=NK(=cpr-$Jrqq9DLO1Ll@PW1% zm0u*^0l-cXloyn#r*W3Lvd9a%8-;VFWSweY9*4ZKq?@M?7WNw51tK)>Z@O?2&mW_+ z_RxDG*&+K|j`;dM0lGPv=P3)BG)bP#ViIv{gNHc}nFui_1h^y9$l8X>E%vHDCmRHq z_%oG|vKk95eSk@?I3*1wk#jX;7$WvG`zZiPZF_Jv2|R!={d&x(^+>axLFk%$@Y?{T zuMJM2eeO@n2vt#_J78XsH0bA6K?Oqo*YOEm$^OG6p7=+X)+hmDG7Zs4@MmU*p0XEA z!Yk_3EB|7+d*+`rgYf5fk3&8EPiHNSVRl2~S2=EVrKAUazeQ?ke-N(%*ye5^pE(;%B#D0p&^!#oZqw8U6cA$so z&pk}pN2JqMVKS+FftT@RKyRvnt(qqVNF$oY$FB&(U*T}d_!!V5ag6UrD9Fr;{%byX z@4}nzr-pNO;>Z_c6NUx?`7jIhr`|C%Hg*C~g1mc`ONTL68o%AJ63F+yPijXL%T66r z=(@_0fAUr>r5pAFtz=owdceU`v;&6r%^*ATjWbHw`R9%Z^iSDu7X?*SQ{^rx;iM!$ zBhDS>(#cGd_sjS)5s-#5ioi&Rrbh5`M|$CbI29z@rG;t1Bf8K9_B+xSy(HGrgAIAL zy1MZ0EqXvi-@korjMss69m`%A<}Diy%f47vhogb{=MlOIGmix~-!1$67_%{6_5by7 zZ^i?Xq!r*lyM1pA9t~9DI`%6VO&u;ek$~lnZoEkb+I)AK*;@1qj9h6aYw8rcCU?o&H$Pi=p!wdE1HAk^Ym`{sH)CGZOEH z84MBs(vxpG(xV_zJ6OH~yr}=lBUQ(xd*uR7g+ree(Q*0soBvyhIc^z+pk~5AoI7x| ztd<*g`sWLD&GN$lu91(~6TU4pYe{`I>N@|VM2Y}fMHboTV5iwLbfI4r3FOG`0CM)} zjfEU>+K@iLlz+h=?48|p7}ngoBAdurIK~%R$gg%^*jF%vY;6^j_nhiGGFO<}z|XCa zr$vw^rK;#Z?&R`>E92Fr$&vYFudTQ&uric07(;C|)C+;YW4_zwrECAe%_bv-KMmXB ziUj&#RNi9bdc)n{4J;igv7_94r{PE3F)8EfeDVGIKvDJ5=GVg)PD@kP1wkikO4`w$ z5)iXuz#ok6H%YS`e(awI6$3aO%-S$yF>g98`N)`y)M%wK|8<&TXBp^iI1{OH-qjZJ zrc;M+6(KRRX5EAeg9ZOf0e4-OogZKRNt#hsT?BiA1HCxo!|C5i?wBezzI0W1Pu_DN z4f-3=uBi$k9#&uMlbxbJYRyR*+qP^9<~LzO!{hKd6G;%Q9n2DfMT-fUY%I(FKVMW{ zHaK1q^l{7c9si?V5?|n8v*b#s35p??o7rM$Ps|oTJjdmBm74l@14?@C9*+LUdD(a$ z4GO{^q&c5tp0$OV#yeK`E)^rxC9SbhKLMgUHe6~aq>(|&TEF^!U|-;d7esb$0rusZ zE(5*Q-dxvEc1b)%_o=l~HINE|@!@waT!MqI zlc1XRFfqEOWh(=m>mwKFsTA9D3EC2a_0TF)BJK%~&8n|o$;$>J?_uQ7MFfwN90^71 zLyr=9?KwngElkMrs?8i+@dXWVZF=Z{lvQDK{Y;TX1|~XxUt=RnL@ zJEO^TTCI@{=(PB!`Ibs@7W~YE9cOdC5Q!DpC-V>S4wV{GWHF>Gif+)+xWf0v1tBhvdgfDyG}Kqm}8l?Qwg~( zfWy24sis7!u4GPA=I#6{;-jhbTe4ge%D_5Kv?}XedU978?PmtaPS`%oCR_y=+c*D6 z5jIoPMzZPwWjyOKMNL$K22r5I3UQZ@RQ(18fkA`*cu$%2<{LH%vEdDK%YqbwLjokH z5iYJjY9P6ZU6rQq4zG5Rq$_UBN;31mdxZ_1SC0Mke~!?ufs~=6Ykus+JbhzV6!_*> z282`a=(@4`S*Jj4BIGmHBvE1hxPO)~_!+HlK-lcIUsK#gw{pfe;WRQ+lzyRbSdU?r zvOGSBA)(VRupmRbJ(N#0Pri#7@HPyOI?U(ifJwlx&c(f>BfZK6Qdsf^d6>!RTR|2I z6GBG>keK+~A|X?R0QhK=g1w<;N8RmjM3@ley-EDx4V_!xfZt}HIn-Yt+8@u)Mx1%~ z1nwzK(nMeEd(|{f-?d_)obfDU4?lLcTUIL1UaUMEEV#vVc#03YGw6tdgO++|Rf^KCtbQ z6fj)&@{stMCh3}PB|RlkU*{1lX(M>cpnb`=R9!|Y^+uVwHfq-+{s*_`)b`zpQ_a#QbK6#@+#2A_xS?#I4b z*@N($vr*B_i~H~{s}syCkV{BgIX$(@k%Q)K)Sq>)A2=eJl-jiky0->btI6agl%-Zv zHD8)Mp)|(eQVDXxVK(~){5^;c7Ww+hhQx~8M6eN5GD!cQ$nC?bNFIWeI7hCdngSgg z->xSBC_Y7_k^()B{OODXL=F|f??><49(?y2*Hm!f!DbAc;s>5_MzBR^h&jLbf_ncm zL0#l}L=f#HiHYJ{fjU26U|JgE^N7aA=;y9XB&JI;2&0XyKeL@#AO_*&he$frJo7Sc zEvxZ}xwspWcz;pLB+vdeiMR4GW#A4a3Ml3?zyFHmN06es0_zQ3@4Q|w09`ZHtLz~2 zZ5o2$?HC0BNzVi9V*&}l5+_zL&z;kBdtaTN+k09v+uOphnmRPA3F0~Gyvs!`-jZ){HD zM`=CyqT2}3(n;x)Bg&!vsOUUgnGys_f+wc&Y8w_cuWUFGoUsM>eY+)1HzMyux#!*0 z%i9wLFNIlo_kImzGS0BwmvfGrEoYye{*^0?lV{~Ry4y-8uaEAh=&=YGFFvKAI~XL51gB0KSLVO0I6*`161SjW0#~J*T%JHpv-~p+C9%mM(*t~ z{AIMCq6J@#cVnY(l*Kd(=-tWGt%jMI<#$X%0beUrwyKOK}uRn9wQEhWCJnbkQ# zJod*q&R?fb>jhjgFrYX-&|j{@*F4=0EIhFXy6E1-dA}hMW&I+8zcI5W=5x|w+LzHK zG^>r$8ejcU#qTsSvX>K(uhSj&AeI@oi&QAY;G!ir^3%RYNb}(r8ZvV&(OFkmYdO$a z+->GE{0rAw(+m%Dvk-L-tbx%c(>>dRzSMLPgG7sul}OjhrxQMh=B@R?a>|wzzPXcf z`N2z{O21>rB-co>FUZ@)XmTdE-SUm}c#RuN-woYrs%_hlpc0>{f@6e5$4;9lu+-95 zw}n}3P`n1%*UafDC&2#LJ<>AO;OZN@FK%l;H9zARJjc84V1g5~l?1N1_qTP7EK9@E zbm?;b4apbQO6v9q`li(&v46w@LAO}R-ML$Cm#i~x+iCOR8(#+DGr@KjBmI@n7a zz^{m?^|Njf-QUjJAWM{B?}oDYs%_-!7__X-FhSI)l82AYW|UJ|1vq6SvDO<>?S(q! zTR)-%#`?3I4Kz=JHgM*qcY2D3HdS!8GkgiCsPkMIrh&iyu)ZZW5AG8hnEwa6yzdIv zI;Ua2l`tRS9RD~CVcD2wu?M#{)V&Gxs7|2eLZ8l5*g%$_bPN^N&eOdZJxSB}NVqfC4eJiqvxkf@&udJPIK-2Td)?VAsG^2VYhPAuqGH>ers zgorV99>JwN<~Iz}D8YSB$-g9Y;E3i+fL@?(2RB zpGeRy-~t5a>IS=bo&(5cgX^uyrT6_y#M4pAMk>K7%{l2hcLV+Edy;C3T~MNBNV&mg z5E#FrP7?~3_5H87PMb;McIcu0*^?ELKY9ZfChmC_3tJ|z^?G2Lt)d6Ublwbizae$( zJcu|lb@;9<>uDiF1N_NAUBoBBBR<6Yp%X17I4u^t(HZX3k?(>X2%=Y=PYWLqm05Ot zEqMQQlsuf~u5mdehybFJh&h)0>!ZF!g@~7XVDn$ueO4-nj+= zwdqq;s4eme@#9DeD@I&6H~>VaQtuH?B!g8RZTrf zl7x5+7YFN{;&(!boj_sU+h!XW*=v$d(CQdrzK-ZDN2Y6 zxBfK7j!-@oEyB+YBF=i8=$yP>@v8a%@FGLl$SQgyXOp1PsHQ-BUX;J^ZN9(W(Uu>p;i(*=Ags!`3OCPorxtfUXa9^D7e zMv)O*Y=bu7K&GeRZF7vQukL6?6AP-^ER~=PN{RmyZ7(IzpbJH2>I2)Zb@Th#6A?}V z0F~N(qZKrB0#oPuK?x$esbEv|pXOI@CCQ$?U}Q^24-}OFLKYFZk>o&sEHn2H!kVaa z+Imn}b6|=1XDP)My&r*X1SnCUC*4sj7P!}V%dVj#9}?Ru4M~}AY&HjH;}eKh!NwM} zuKG59sj)h+%vY?a1xRDmU#|F3p%}&dga{Ny-sn4b1Jb5Ppi^Q^6Q5^b19V*13H*!| zG$P>Gwn`uj>-6m8L7n`%ClDk5+lPpfAZhev%;#PtyG(U+8k%fo!}5=^)Wt3Sac?^x zYv8EeGQOzIGhqu!a`=%EO}O2VG4L(p&Q==nO7FlpP~VY^o4VMCZ1nc0gOHVb?8+eg zw3tb*b9(c)@v#%b=O~ZCcQVcBEak}AlBh_UI~h+F5|Pl**_+lWXwxKgrrV{5Uuq?y zI&as^no07BG7+4;v3L~^UeL7r_}fD|z`M5?W|4M@;C{QjL4C8+H-#?fq@{%f&DyPB zqlSk{d=V#gtX+#XPbF7s0E4A zv+51KVq9n_s34obVaB51-xI5c=JZdV0u6uYinN79KFvXZYR~h1vVi9V2Bv#)+1g)s zDUeI>t^F^-c$Is`a~Bl=E}0!V;uMH2M`Jt`Rm7bnkek7RW$D=rh)r{g_)oxQq0pn- zEM59ZN>$6yh5~6oVCp-Izt#&NKZ*7+VG8TAgvHb(TcxO05-N;Le@AvBj;Zvm32C?iq_c1P^19-GW;oLvy)7iChxZc{BJV^$ zUST(l3(r?Kch4nIKLbiJr%ewSsqeRI8!FK7|V#Fksjy9mB2iU&xcdGkoHc#G~zi*Vy_YXthR5w2qxX_cH2$nj)Ac zG7^p`rQpOoOnt5s{4p-Q#t5!ZK{O;`(k0rjZq@`=T`4ut&!Oxh(7{!(9NRD*XIdm+ z`MFa%%p+$6ab^u<&G8e|1cMMNmuPLEfT>Zc=F2JD7S$DZq-p)q50MDQhu~25fBv_u zckE&lBkkQyU>qVn>0wnxB;{KhW~+T{DUu>-9rY>XlSW8%=WmLS8_#iPN`toBMZYv# zndVT>p>mKIr@};L5PGrxc`Pt+;0!q*ciMv(^+{G*abF-b`?3 zA-fLC6B{(nedXCHnu4Kf9kr8>7SSaU&HNg#gpPfBhj{aDP@0Q^7_3m%4x(Ch6l?+{ zwon6Bi4?Vx;U}8?XJNtlx$fuLoNkdBd}#bzk#MQGGcHhkd+Xh#MS{-&*!(Twd8CUfc!b|{7B%=1RRhTU6z~FjNe$H-iGLq@DrV|#bR{BY(Q+)cKG{Y7 z@G5WfI)3D#E|yM6T-p7mRg5r2+;Fhg`HF7|l{;SX&^!iQR2M!L)VbpW_zi)Y5#zAT z4R7>F%9E4dN>;;VW@~@j>Y}&)5$_pDj2wnLDDQVNa17YGQgY-^Bvr;y$h`(C0jLaC zL%d5&C0eU_cT|iE`)=@dkwtn*LbK9}RU=-BhB@=z%`hF-at9fRZ^~Lpzo$M5fqN)TEb zcwEF?XNYYULp1B&yLBj-nQb2KBN~3lqRpLhPS5-83VUi`2YSThV*#@2n(^x?p2u)3 zN(+c7jtvdhfq*^P(l5C}i@fD9j>(?&nWfx7rF_T=Ng^=1qmdc9CbKe>!qg+66srs@ zSD)jK`)Srp1MhuLT5x!1_Ek`O&`}mmA(aKzQVXtIB~cQdh7HS6i<9rjp?;Qkuyicm z$rfL06wOoj*pvt_Nv3yO)s6ct*WnHwKCe^)n?vQxJLrCLy;caBC^Tej_-Gn1t^(8A zhj6+zQY)uRPIpTxme>2%HJjG1BkfBrke||+g^`@3`gY_qKQFm;R}=}NY_gw zgJU0TYTo<`K*ud$lqHb?B8 z3#neL_RqEa+Q4*1r0aQ#4x(|1VV`44B^`P@L~_A8M|>~8f?Ew7pOP3q_bs8U$^6|30xKtQ<6oS@;6D&L^4<&DnObjVP+KBeRhP7yTLxUS(mhUM#I^}^h->o3I}`O zv2@2TCMw)F)pRV^fY{(?j?bx@R9}vGw&b$OZ_j*TughO=IUIwb`1zukCZ&P9%2+{n zp#E9_aENyN6S70Qu1 zQH1%1iSfL!Ia;Z2Ia(gRm2=|c8WD72`#iZp&f_KFQK*qK|DM@qjyYRYZ#XYkgqUAy zydZw2Q}8W3M}%DE#_b6ee5=HJrO=3V0jOs`WwLLYU{vagOp#H zG?7*r(7I>X5!A4sfos|jWD2NHkJ`aff*B{r;{nqtw#a$EHs~$G~(qS(KGp z>Jl|<%Zv#?2K+$Und!{@-b-Ub)cU=MnkI34e(Ob5s#xMXAfpgMAFz0TfL~&*DF$1b zMb?&`rYQAOa6u)r#G+2($+cJ{x3zqy2Hr{P)nx~aDSqnHB!+Jpp>y(@!c5XAJ}9c%jo`bWiiD_*^LFxz6im78YLDzz)L1jO3{jr(+X z`{)7JA~?_3hzWb6#wDbEc=fSRpgtqiOv5VEHn5EQ0<>O}EPj9Ut&-u{0_!oRM~3?H z@0}8f||A^}jtWoZV9#3tNve3m@DVShJ;zKz=f(S6Iav>ZKs8xb-36jhy&Z zhl38jh9B(JZ)8)@t?h)`bHhvU=7ac+s+#i+F5soVnvXhvS`=133nCxRPn#wNJebd& zSW@$FiQ*o0tNRtsm%aR2)dRURyjJa_SLpjLBbBk+tbHaZAWP`o@pw$SAqgz_DftuQ zGSYjOj z=wVx&9wp%cgeZZ|koUJGYoopJ+*yokmM$0sD#G&hb$|Uy99vUhReU)}j{4r-77t zU2x)?q!Nx4tqaq(?PlJ%G!|f?k!6*1o}QCAk+T!p7>8Z#X^9jd(nZ__{Jpx$i~x2$?`FMz8MHH_-m=VqBo&%oZee6+Nr0^Xlr^nXT<~R!`+{ zy2!l4eb-p(EZBfa0!SNh(m1Y?loJ+QH^X@YdelKGbG`O>+#w~u<8?zce85BwqbPcW zYFf#^pkt(DqxU}BkM{$v#Wki&$mPm;nC{6CEp#A{DRsmQ)0v_fWogEQ_hi`v88e@B zVD#^pRsG20JkJEDJAQ4&cK{1XyU{DbDs!zf!ThxcxKzX`F^_DBIWDam?UA0Fw<&h%Qed!^z34mZwxI=B)yClZAJg z{ZXewjTh#XfiaguMA7^?zs98%PY{bU+)WJco5_j#(fL`CA$Uu-#TXs zqC~CY_#1x#x@;pO-l#UL8ON6VoaexY&vr3mG*=!La75$JPHk{^9cKPmdg>F4e2V-Hw)(rp9NH1xXVoIWPQ}9_vi;9^B&^u4qvet{v>6)<0tHAJVI^nbfP@n9};|-Tf&~uj0 zmKkZoW>+^kSuEZ7?Z0JLg&25AaM!>3!Dj6e4j9zOCC+n) z&7Ai6P>V8>*?SZ=Y_IQYr?$#=8hu?`oG=HwaMSA&vZ>cf9i%%SNHqTH-HDL!^yk?bNV&mwZ*`1?cCAWq1a zdJ<`uGL8e+Oda}XXH$q#XU`uT6Ws^xk^C`GC(0CdmVjJ*@1~!k z1TAk8HgOK}A^23H39?BUxK4X;7%g!8a7hMAT7p5BHN{v2tQ6lJE=QF7R0pXAwc4Z{T z3WNAZsW1Ju`vUGDk?*ly=d-(l{BiGk5r{#PZ+K`*(8Xlnr?OXL{~(5aVoQ&~Qf{k+ ztcL=hh0YSWn;r{?u&uNkW0VgKzOcjty#K;1R(&$VS3ht_s&FIAlVA>OC)%iY5Y8v! z_Nvbw#12cWz_{(LKjwXhzCr1e{}?ODuhs~wuK@dSudLVHQ(8B&8~c+P@FEkdy>;fR zE!Dl+Rq*LmG&fOU?cmNvule;NnwJdr$r06QJ{+X+BEc%MDbmT*J9{AaSgTiA4z$gb z|D^XSu1U%&8PPm40Da`o%9+Gx0=uGNZZOsz&JYd3ESO~)!otS+@#6>>8Mg!$s4&R0 z%Bw;c^8q>C5qk)L`&M{m-FN!iO)QH;Wv-;xWk2P-(yqyU~t!O?DfaAO*J?=GF66%}qnF-z0Yk!*?B>b^Cr7AB1 zt49%^{Kbt+6{ho2rRb8|pzsROAAz(1Qe&Z4&mn+x+i;P+FTU5ac38b9rP%Wzz(x@S__INrId;ZDf-g*1h7 z_xt0{Tt>_^7!L*Px-<~?X{zobvyxk)zZXYtG?T6NU0+MpQFnx8sAt744m&H!tuh10 zv43EH@TYd0Q1f^ysx+j_q-}amO6cFjnFy7gB#b7FD6+hjw`>1);aweuUbX@KJalFxmr76<%E1dSy zjG%y(zG!D9m6Q}QnB2JMTi5A~2N|B7u?)tBcUaJV>`Elx;we&vfJ8TYPv4LK!N798 z?W+M7CCex=X9_KEx=iXk%V3+HcTBQCE-SV4;D79jc#81np4fUY9<|Tygna5KR(y{X zncXYCqn*eg%?lref03oil0bW+@hB9p&Oh}DTl4~qtJ@zB#~tq(0g8#H(wKJ|k8%GB zGd7wv@-ww_OS_E@fS5WhSA`&$+D}P02)=ImO5F#YL}d&vLp2Sw$juR( z;UbsaP+Oo!ZFS^?e(|H*h=tbK?fJrMN(!8vL4iGzy_5&s%}+xZ<1DSdQcB{TyMa@l zjxj{6re74J$Y<4J)_XoPYK${=dqmb3C+yfDlKe)aZZr=+V1s1Z zwa~+zQ_dFR{4o;|3keySC-)$36U`!qL{7Lk>6woTIfmqbRH5Oh{z(UlZhy~O7b))f zJ}|(OWA)EIg=RtAom+T=ZT-zR#o(W;TZWiO1A`DSC5{Q5H zb(6Z;N;oICUzAyhOeB(pl&^xh_fdJ62U#Ok)g=%gECHJ-PltVtI`w|1ozD_bgV6ZIieW+TP&6YA%?PYuW4m- z6?y+C4J=kbd~_1K>z{x{vKK8Z=INzmkhbTSdy`o2!cH8Z?oOo@V%@m03yyYg@yKlk z%ZdX1+74jS_HhhxD};4cp|W6A*s10ms;m53s~PnFPP-%AyRW2cmJ$%zd}sXthmO_F zI+)Y;-8*ajmJa3~Qtf{iR-meQ31?roDKX%A1McfG0j;Jd~Ot+SO zEeuPbpKDym1k-=_Ua845@>_=jj+&{w6bdyJA#o_X4)eDp;MEX-@i8kR#fr99;AGx< zjw4~=4Wyl-FQ3XNZn9RM{7XBnpn9aN=xy)=$&yp<6PK59=47safUOlCISjSRS)6G} z?t`M;HGC()WA)DDS^oby@DoLU@?`_rlccw+weGmv#af>E^?}r$^!H8dfHFuq`*%{@H!L?@&u!9{M5LAdu#PIy;j>1DS%8Wq=ETh=rgyW_N zGeGvDaU5prt)vug2Y`j{y{mqd78X%zF}>-BmxyhZP#clrb>XxRtpCA30t2_-KsWv@@^B! z`55t~h>u5}YExl*JKkYy>>XOa(f=+2Z!#Bn@=y@zWMyvXBZMSC1uR#0K}@!&J`_m7 zA=Ip$#=*sx(2BV8+o1Xq$+zlQM=GX703$%$zcWof7JhH{D(^*V(}Wu`52TsfJePuD z_4rCVV`v_aS|*V5n!SkKlKfERG=z-D5+0XKrnXbfOow-n9a74bf(;HYl0D<4bB^u- zjAML^^}!WOqL&52AdB(lDSAANium`8y;+_ zzos#-6wLtWV2~>RBLn?2rhh30YucZIfg7nqt-e-#k%^A3E_Xq7l~6N050G;x@Qyyg zNvS|zuqZ9#=#ifA8@6E>E;~8h=f^CS-|-od8=-Y6y#9I7f^LsFgs%pfd`x-|Ws`Np zDGff@N<$>4PK9E0!#iEht{5m^URj@Ry(bNh%bUG^zcyP)iiD23)%4_1S`cjIuEc4H*q;Q+h9 zF1%J)BgTl_M1>##m!Vt(l!zI-^&Z;bY8o4?`MKx$%nA7E$j81LputD`BNUV!%^+9f+3kTwU>4dmj*AX=ds>+CnJD)OsLo5U``Gb9SJC_ZXh8ht z6qv}Zz0_|KmFi?UlrE#Y;f=~x5UCp%B;}%ZGQ0aYgV90H9=!%>f1=FA*4mbfdt*6) z{rXM6q2pofua|rZ$z(aX0)T(|!E0={w7h9J96c9#xS@dygG5@`D{2;-VrQeyP?*Aa%T`t&jwQqs1VnaSkk%IRpTgF3B=5*SW-;dFNuLd7Xc zr>%>l;QpMSDiHnZxHQh)NK z3_2VfCv>+!;{UK(cf5io{^UK+uS88S44&|F!vu81%UWZ?lpo;1ns?44yi#B{9^0ZK zqksJmsWs&t%}kt15?1k#`5{(+z*MN!f#zo(8g8nri!+Y>O5tjaYd3&Eq)anLlT#k> z&B?3GnW{nB@aSzY7f1BH{-qZtZp_x2lX>MfSHT`|GN&5u)~EQ&ePr6iKTG>@Xa~?3 z8Kj_Cd^(xnUbtYieVs9yl!EGPmuOd#J<8~EkYVo17O;KCXUc|yK5v!DWqidf-1ba9 zlQU>|kt|0T!!ZZe(W5K%kM>@%47Y!fzHTJ1S)6X&Kl~C!1x5AMlCPc>Wbf+;%)&?? zr2mK4_BPOfcmX5Lr>7Xp52hhO#sP4}6{Pqn398H;cv%2JibV{@m)3*P$+`V|s4Ja) zA+yMTS}XR{hYM2xT}{OW`bn4J5$>Qj?HbW+NcnrL(dMOmWS=V^UfSfif!~8PL`VX4 zX3L(k!0NYiP&=Mt%)MBM+H5VafJ20%*JRx#_ij_%s2}H!WL#gDcV=8$JxR~d{{9)0 z58M@@5-?vG>0!3`h{I;XMVZzh$qG^SrdS30jSue4P`+l!HWi;Iz%4o!8){o z1X7K@%R66-#kCTIpd+IWurFgvT1~c)w}qLy)<%Nos`_{Megg*yuDpOjDYmg1IRv}U zr1D8Zu|1xU(bkCP{@osfztE{l1Ym|gw^=s~hxa6p2GLR7x#7FDW&if%&)1$GkVwkx zJM6vQo5Fp(r9zq`3@C@P>V*%N7F8g0u%BUxu^k8ecM}p;RSc6E{}Lr0hsAtx2+|ra zH=aocI4ON5C;CYz9p%vPqrhYEx{RynTt#$+Aq}?&B^~YrPbXT@cU~BlIhT2W!ZKC5 zJQu(>5gxG3D)u{MXZEdMxRqZ>HPhfInBpw00B_@~D`4bNDO|o=whPu2}W~AR6 zrA)FLaiJu_S)wuikq|AibAbcqPikbTp93hG65yFlWTVF~`; zp=TGczI(`Fa^=s8m)?5|^{&9N6a{%R0#i_EpqfT%7ANoE-x683IAIdqrQYIU-scHu z$BGVxP+R1)o7tS)x`~%o=M`eN&v%&`AW`*ai$+*Y|3IdBq=EjWgb90UiXm=qw(8`5 zn+!nxGOi6)i#9@z!#Ol_0D0nSsMtd~*V;leJ}M%18dc=9oI~F^m(2N;NXzvbYQsp7 zWXYxGDXGGdCt9H03W||lOMXb3lw~Y|SH*+Hs9JR>>ptf7emhrh%!~<-ebT2Tf(lgb zizXm)JeGLnN%yq&)j#EbIJJH~@TTQMZum+1gliac&xeX@2usImL<+3S3D)eXx{Npe zxnHg+Rm>3g`WXIazC!N_hp98d6kbgreh41S64C7z2IGP$SOsj@mv};pc9IH8LqgB4 zQIK{BeVL*0#%Oji22b#j-?!<4zUF;^W&CF-4KRR~Wl)Fe?oGA@11-|`7T$alHPS_E z82)YPsq-x(fY8i1$(qZo5gLj^ZJgvl%{}<2(jtl{l8PpW&Ay$xFGke3!BTd9jW zzDoR~x{A270F@iIi4TNlX_BvfKIJNjzc&rTNvir^WvaWm&KeoKv1FN;UCixTjX+V7I&> z(f_$UZ8892out4Np?$GoGR_*8aSPD`!fM5g`(%mI$v7@$=wU-~BS;OU0t<}%l^u#x zIaPSl!%DHO8YI3w5fi}8sJ{*Q<;)`nv)d5}!=n>U3}Aw7vKfXlb((7yh?e@zWz0Dh zgbd2(PL|J3E1Fkv{-~>@zk`#c1z)=epLNZG z=?`gP-Wdk+pJwLGEwUWi({XlCpTQhW* zb8yjZRx3^u`_>2to_0!u)*P5sJr3`Z1g+T)-QmuXMcQ!;b9jF@~W;#*tA>kXN zTxxN@MMlDFWEEfpFP#5s{anB$w#53Pl31MtsS`J%e z*w2A$npZs>SDe*tl8yaNDY{b#xm_n5LUAv-mYFqXt+Yot>|(&IjDkj4Lj8(Oo&aG> zc9~isgNbslNH8Bj%;h8r6~bUB-T7j?`oWlBGBe-uF` zKD&Z!9B%r)nvoF%XP5ow}tj_Y^G{Pa=PvdFWFJlyD>A5qZCB$ zrVJXL0v&n4rD`1GF%w~trgG@8Ngk7W{;RP*j%}6;e1GP+J^2v{{uIeXnLbpj+Hdul zLC#;_s9-n@Po~72`|~y^QbwAC#dv#%!%+V3L)G{(7ZA z45A)a%`~;JK(zNy--B}sm}{zXD@1pkS_K^v+HdKiw^HJZjH&Y`fW{=73VL%B-2E~6 znG;3sH<vPF+Yl=1dwhUfLonAF-8Xc2@vO@?JaJJJlQ1%G@=!qRo21#S z1E0?Qe=>uh(lnmnBOQrIsz7noLbN)Ja3VOb+A6sBMP*(*={mP#wb=rXJ>jPV^-EJ{cTdddKsP%q=y-uxbFZN~ptp^Xted`c6Mj0&Yi;_di79FZ-)Nca~NBbAM=?=H}K3QWIkgf z84Pr;il|moThZCx-Dm1?c@!*VWkw9JHKC;{HHYkK%QV`YG z{%C8RpSl%oG9krq(O4JKmZ7(`MFsL8LSN~l`sr*@u;x_iG*FNN#Figp|X$vG2^fV;-SIJ(?`zd)+7^$Nm zL8KLz&S_G~KL`qr*g^1ij#Xh8YZIbfY?&>=<@u6>7q5L7<6Nmd7ffp-?63>ch&SOs zOzn5$kM~E`_+AA#9W=Cf$tUlqVaJc3^?m_(fhBsHO4kDvz-fbAtd^qpEZ5_z%$Zvv zj&M>Y+Vijw&fkDu`4nh8c`uVVu5K5}Nz`vD{L5TekebZ5fujWU+h3z~kRF*&sQ%Y! zrQrz#6qPoG&&o0o^Sd49_6yy{yh|ssvaKm^2tS?cW7;JU@QAm9M}s6JU?>URiQsbi za6u9p8uZ+&Q>-CjoYm3KQ%QevaBH`t1_uudsvtkVOjp}8@{x7B`b`2*)#$-~vJyj> zy`oLXpk^=IQX)EIxz`G4zU=W<+{famU|O$Kl)p>1F0V)9P@(Ue)3i4yq7lSpv}Xap zmw+H|4b&st8HIE;j}>s1guKNrKzvu?znhr^9G*eN5b;`WD#|o2qK}@{Rx!d6L~gu& zIS_?9xtr;%2MZFMEm0awfttjdKn7g>+tqA~<)1^36IXG%PI4QRAwHgHM#8C0@}_K2 zOkVt3zSdpi|K9U2O|vA$51rOvV07A=DWxnaleJ*&Ao~lb`G!qu^&T|s6JEwT+)K7Q zQRJ&c!o3rFa3$Pm`Zt7{t(D$EbSZ+zt&tgvwc2meV+ecGVh<-oO?Hl$VgN3@JCS!y zx9}`CRp0-IFX0Dt_A~azqg@1p0&n=xmH^?-U<22|$OT<-!VOWkd2p9rq3=q9a&8y0 zFw`H5`R9E@mwt=>1V|4EVefbrX~YRMFYuP6m~!EfkqV zXG_a}a&$lm4jm^WMyMzm(kN)E5Ry%GUk@jnyPfbmO^8PqEfSAjgp=ZY0jKQ}g~9FB zb2t5IL=jtHfe!U~>+fP&`79HH;xSrB5LP@rxUtA^CDH}${7L;JK&>Vt_;0d_sM#GO z$!TaO7;XOfYvz$RirPbDA=D0>Wr#!8hn2lc#Bq-!Y!)GkHs+V(O{^cWz~$U(p9_8`^R!dEFFTN&bH zGup}^eo*^lH+6g%!d|_!JCqEoAXX1m7;2qwF!_c8#gwyV0Gs(gE4W3tXm+_LPzQE zzDp)QOE6Jx{2kii=`Nw6XMv@QARhNJgmA$-gwiP7zRzyh7c=Sy9@lUF*YAz#M;vmuKsq0Tp}$PAKx;`QuFjC zo2;(_KNAoc#QoLKY6rgdSh1J-(9g$g2yMg2#m5k0t)0QQvYqA8;fIgOfg@8bIo;A% zN*7qwch_#B*25@%eh#=4y?Q21A|78AOaB6p{zRsxICKwFHBE@)bZQ1ZG)`c{jqN_= z`?1838vMir+GfzIKO+I=xffw$w2xquaxccfP~W&jb7zR5gql(7PNZ*Sc;jzcANyP$ z5^fGc^+DV+1O>TtBj*~?WYob^9k8x7wuux61sUVqGKMsIubiS16;|(MhjGQE&kn<) z5`gIX6C%ABalh8YG0rh-^?-;tKM+(yS{J3q5LVsE#jr%sXxT#R2WnY*!$Y3i$Xc=~ zALYIwi1()721i|fcoXqFpy;56vPFG<469y~2$R8!;`sQt#k8J-Ae@C+($dRRIcq*_ z8_*5C-rXacS#mo&)lb9H5Ypz*X@9VbA}x3jXphI0wBS3HOkbCj;U&b|TK(Zc|Kj^j zI74m(cm0Zw7)lyCT$6$h*85{Np=;vlsV7uXsKBQjHe3CgMK6O10j(VSQEu+o2NIS- z0UO2pjhbc32Re~W`F?2FeewBin`x9!6(V=v>u`z`P>4T`N(cfGkIK>Q7VRDphS+IM zjaFJ4MZgPcV#^O+fcw%;ycdeji@foo#%MC*v)T;eqd8pD1-1gf6D;l|n(K)KUzgVV zDOm{fIbdssP?q}6aWfP3Uc9(%2=Wh*=nL{1Hv*>a`qYT)&)6il>s4?Mz&HDLRhHtm zP$P}GW2^>liC3=1Rw(cHP%pWshIAc1&pG~w{$!=x(=Y2*qGX*Q@CnaPfyV09oN0rl zgMs}-q5!S3rc?PL9x(Zi^OoY@TUf56^BT}hiDPS$7O1aH3)(O7fOkQT*?68HfaKFU zek`9Rz?6)TutC*d^gWKn%MxWrbx1&0SSnPnHfMF1QVku!jcsze=)%TBAZ|UERsb0F zO@!Jz{8Ey@HNPORRA)k5R3SD%Xtp{mo?9$`8kWY;)JEG*u#LU0XI<$-JAk21BrHJK@ryt_$WCpc% zK43)-$usAiOUl?=f6neT=;_j{z7A0v+AR;TBborDls=jRFyT%j&18?xj}BJew5!g! z!{nAEW<#6xn$8Hlq$G|&IRuy6CP3@DFUR3!0p?*xW;tJ0>oDMC-ngS`J+Do>?uKj<=Vj;Q`RBkk?88irCB zF;X>py>s#e9L&5h^2XA$9uW*OvygwhNUHj+=RE5r~TFbMdZDfgZsQlxlfSvcM&)k;} zah?V_#{*kZ8(p68ZWM=m9#g}WLuh|bZ-d(7YsaJZnft*})* zwp>ZUm4S3e6bJabos?~&W_D}8I!AU0IMfEK`#BN8+<+<5JtYMigs*-tyf9EhZN@kx z9Jt2|?rM@v8BZkpX7ZGwR%eST?-ts49zKoOJ3CA9<{t@TcFRppTA`LC_8%S#S=4U; zE+h(Qg(0nGfpMK1A$APC)3ZOWWNk7c;u>24#nrA1Tyxeh-?1$(2`<~65mzLPJ6Au} zH_V4F<{5C3+5vF~^WP)bfxkBO^4;#BaBI>}h_Y-+i!kdg&kS^PN-DQccLUcMSxGa2 zH82XJ;4!B#Bkl66vg3N=dpK=$ggv> z>{6`ugJE=GaS5aDTQLK&Eof(?8SQLn8rYtV5-G3o@!zan*<_6$>o-EjV5 z2gL@`oRVBkFZD${z1)3`973Qv>Xx)>iH*3|8&F71O~RsVB;g)BhBK_1^V(%zo`88q zB*H84yTdDyWf=);Z99oiO2c>nT@8uFF2HPZ`8%rJ;40gP554d=m!2iTe~Zmd%Btf% z;WBA>hv!|wDETS1U7?{n?O#w7Uay+HAdA7%tKO4sR`xac0464p$?NPlPDC43EJ! z2-%H%-+Yu?cV$6vUVzuiIi(MfC zWO)4vb>+7zo|ydVg^i3$+kC~mI1C``3qvdf7^7KnoEb`mF&~v{L~OpYaj)4|zkjfY z34(gvQw?hsfOSBNF4N~eDDAN6vC!3gV-|l+I+v3eXTWSf*$mpPO8x@@+M=;_NQ%OZ zbY*DU)r|s^hAoMQ`2hnZ1Xr?_mW6CLG|XON(u3}3#+&&q#?W4~n^w?gKzSlmQKAS@ zdX4~L}*u#L-36-;m0NwNpQqF0Shn{8fCPvXjRuEv) z7aAHZ9uSdNeiL0JQo%Dv#QP8pGQRl}%|(kR1>%n6AAD(0g0LZEzsG1WLLfy#%W2Uka)cFCD# zrucS+;Ju3DC4^l>V4Q79pUpRDmrxwBuG9~31n~m&M{hQ#oJJkeW>)zH+XnbNW&37y zXX=ClDyn_>f8DzxM@xmKHk5lsaUOp1R#`7_c{s8?5!V=?Ri9Ly?_zGF;a7~i>V$~D z#AUNFO*5HuW2@GisE3UWUFvxuldpqHHnO|3cNC?zk7SX(!*R^^rESNGEPI_T=UDVK zl0s?}$5i}mXks2a%;B6sf5g^!Q4W}@rQuQRZ^8R6(LjfC0119~J-8mnl9U+&Gn~+0 zPsPgqobvh#;2zuMn9Qwwp`B_ozjG|sT&{>^fGKBc2zXV~1tTym;W>}f!W9YKvD3fC zc8Kkxzh5`RDz*vFUC>74Cf+ggRVYTGP6L5B<%Q-bVl+VTx56}ESaewT&~DYyNu5ot zc{3Bw89Z((b<*lohIFwj4_~`|Kt!i1P$)ji^4db?&s8 z$v!`+7vm^#Ky$5^ifEeyXEza3Ve&VNB@TFWMMlCZCZsC+uwyz->R~LCxiyhKk1Gzu zH&*{*p;C`}K5%wN*lL_5S3uMF(|#Pto|F?AJuc}fUppt}1x-%QtxvmYEw9(c%+4yeXeLDF-;W36SPHXE-c^tMwvRm9fg#nv`Qx$cT=GvUr6}BPfJhoj^ z=>x2^0~Y{QBMW~weA^<>1NS;>=7YG-tZ9s#xw7T+%UtTe6lLz^EGO6+9Bh19Da{>s zR_!|uf#oL@(+E~lOT_Or8>mJpx&8d$hdO6ijhb9QyqC(CBvKP4R-qbw>+rqsj6bHgjC(Nq7UkLciZOLPRX#gd zltHiVZZ3YAg#~47wxV(gV2v3X^9R}j6)xwo0}T3biX~Ud%C%T(^o+-d6O5WU?T3W{ zxw;S|x#Y6C5TR8q8*L^SxTvMF&A=z>H(iQJJmY8;cUr*76EvSIztyB_iAefpOVVjN z0p_mf3#-OHAO`^fz*N-NG|$Cg%uU_pj4fcawmBrESVs>_2q)cW$5kP629oGojJ{9;nifVjjAy>Lm&YNw-Nhp=yMmT%LaBSa8XXA|e#b~Bs$v=bxhV}lVS_lVjIto`ydrD> zAkVjI6iT!{Wi7|3b2ZpJQW_HI{AS@FFkjmN*gvq?r%95s!txcoA2=%VE>Bl+_I3pL z^6+!8;~79SudG+|OPFjuDT~(BJ)B-$|4apbh&lo*Z@24{TgV$mci_Exp@YCJp)fi! z_=A(cIRu6g@7~}Cp>VJWiUyZlhJI3VvhM^g-^A2v3amkQ8Qz+r9G?1yu*HL+6;xaJ z`u?KFIO8lh-++nU%V5jSdE51&%_}vYbY+PF#T}@cEh9Lv3k8hjDurD=G?|uRYbW=Y z+Y?b#U(TaZBYxfy*6k1lefc%rMlahne`w?Vxa#yaPsoV8SMC@^=G=+A2=KU_1Z8V= zx~5akD&LRx_^Fb6*7OuzDw3vT1e?PDoEYICyL=A{vE=cG7-fER&?r8VwFY8K{Z%>0 zZ|4*ysA4!m`WQ=qIA*pt>TKBpWio)}li4dTNd z*uM}tEj1UT@rwy{P05T%%Toi|0EE2XUVp~eOg-vL^A=FFTRWklOY!|e(SaC)<*abL z)!TVl-}@v(zbjq!l1xj9sSNrjvk?EaNlT7_EKC3&ny&vwbs2T`SB(g1!g@#5^%T)Z zd~hqeJt|)an*@?ZR;|S83(yyarT&pzKl{qf^!4fFnv_r%;x{bJ5g3xT*6gzIJ`HX0 z$rx2as#T!k08^XvK(VuM;Zd?YUV+;Egd!Q6@1vvA2^2*fk}R*eaM=j-t*G>#xLMqJ zrH}8MLa-y|?SyoD!-8=v1iW0#3ukbfJa;?_ou!i56SdGaU#o!V}o{0Ew!e;_o}X9Wg5GKzOxP*dSho|8t6e%d{GyU zA=cy!%g{@E^9_^PSMpS0p)CyQ?OmJWe5Yiz0dOiF`qw}jGv}G1_y1PeU(DZ|gV3r9 zw0#E~FW0xMMf{i}SVK|kli(3b?`jlIB7KN2(QQ62+B#^ITgT(p@T6VGq%ECT&P_24 zBnMkQp)d7k4ewVdgcKNpzbVWzwZrq-6&n?MDKq#56}W_l1yw7B-(Y4e``73fTR}eL z1hK4ZkYAjkwMK=hB?Manvuh_O~)T?M95^3&(b?r3mR-#I+pTVp@Rv)c1=T435eE-_dP??$Fko(Ud26ZxHf0ss{u1 z`4jy5`9tL6Ci1+9d(xYYWVu38ze4WdMosbxolB{VbmvBcAXH#UD36fvM!ExIg};OZ zWC8O}Xa=rb^v?2H^Ryi=v1%TST=a8d*S476Bb9N~$}sM)BogKNeh1WQfwudBpO4&f zw$XO$*B6d8z5*YOlMOXATB9n$*BpeN$`KVjkFRv^pxCVA@XT%<(q zg>6ani=nrFgUqajgoo-_)2op55)pCtf~F2#eZW;xYG8sJvPe|DT0IE=`mcPi;Tf-I zN^6ZReTpQItllNpAj&B+*u?G)@aZ)^aS>56f*j-Rxm9rGsv{@=?c=F{%#p;hTZ)ag z0fMo2`{u{5|1G@;0a-?h8wZJ4a>YELsFmbU=t?p@^q)!uofM=L@#=ED(cVzv0VBXFp!D<;go6Y8e zAeAm~X$%$dj;i9x7pOF=U?x5(b-vKKo49QlX1&`Mh{We;R7O?nzciY0TLg*{vCO9+)p1Qh%I4vsq z@>scFK^nP9+W#WL#`?7Im*i06z;4*@?cJo_Nn7T%kFS00`z_fcYFQR!BQES>?Q!QC zbucB0uxpw6yNlKdTnBWSZNDu))7&&Ce);YKpsO?g7-V);c8Uv!Rl{}zGCewj3iVX7 zyblEROoX>jsv&@eXZdlWtLKRawt}lDX`fxV3XVjAC+WS#VyUJx4CaPB?ZekVXN(RK z#KVX&%a9G+fj?lBVWdfa=RUBEf-pmqXOnfv91P1oLLZeVy${RH5rMBlz5eP9F=ak~ z)qDh(4vWEA zri;hzw_O$KSCVvb1Ii64Ru6p3Kp=q^6>n{&kmvxK-2W<0?|l*NX4EOW;Xdx)u(kP| zh;XN!(Y10F^&W;92TJkzc}4`TSuuQk4{pmaY5Gtk3zzMa$j&+ZQM+sTq+eeOF7Ztw zL;XDLi7yLcuXtr6#{Y(Wr7>b))n#Y#9}?mh-__3AkS1Y#{-JtYU5BrvOwADbYVEIu z{ohiwKTW1P!aRDW=B(?46%pmP3;tU;i{>;v0dPejVJLfj*V8SBUJikEH1ev{IKLK~ ztM=(^F`-y@x4n~AJmn6{GVD!!mfBS0n59ag=vsf-2TA{Zq9|a9Bp#TN=9B{IsBVZC zyXw|6KbtD=VU6ETQN$7e1c_=A= zv4ZDmqcfzWCV_yOR(G0hm!u207E2}29_zhS#;^8~9I3uom%g)aT?WDJ-dhxy?&(6$ zbLv^D*@;gU_ymsUn@MHmKBngF6-TS@o)w+rI2w>JSh?>hF&Iu^79y&T`%HRe zseK*L-5aDjTNsf2uY@1e-vV!Uh^ z&_+(TxA&GO!^&N(du|+S3vL zb4Chw8njLbUdw~MO(ApaVuK-{aQV=CKu3-6b~leVBw>@FkmQev=xLqfs?w_m=L>bW zuCv$~x`k?sP+;CL%fIrR>grIn(P8M9jr5V(X<532H%+dvH~kDp7TO0b$RDnJapE1} z(L*C+2zkagX1)^KrI`#GZH9y@G2h~*?8g!-_AVP z%C5np>LPFTWTC#{UDI-)GZk%he79#l5}*edm=0KzFZdE5YD==)oM1|%8p8+a&7L0Q zet~XqreMZ0#fE!yOPsi z&>Z$1caf!H3-%A78{%u97sl>2nZwzw6D-tWDt5gZZL$=dBO-pUS$5PnB&&vSm!v;gdtKp%XoWX*tMXMouPB{hTn&(EXh0clE`8+6MQ2h8xZ?HvCkg zQPF#&Xq0u6g#X2BhP{X_6{!sX3(g9aNW=ytdhXX9l~y}hfZJ268ge~Pp2(r)35f2G z{6oe^*A1!5#Pxxn$?GUV?>xLl84|>EsYyeuozyv9kYnM_?UgJBsiwL*=l0jXg(}{x z01CnEJfwR(B66|_Zo-oBJi8%gnJML)&G)1j5&yBfp5n$&^y_0&WEj$X*LSM8h2x!)cY z;74Z%&uT?a0v1(SC(+&v4uuv`L&-$}W6^Kx(UgaQt5mDxvZ0pWBB`ByE%=N$#G0|7 zls|_FUJIFm#J&tm7fRDAZ1^O0Yh%d)@|14m^Hy}8eJRl#quv#hnz_r+n3WlSiX1B4 zE$id&7T9H>W>Lq3IRfiU3V!pDM0@=3B?V!9qVqD=DOF#NRcy{yFGGQRpi?$SeUc5} zk@7UXvuwExL%Iu&9j9eFS;a~r|ZpH&PR1Z^7=3+ zJjJE7NJ2fg>KvHVZ+Q|`Kc2N)>E3cu1FyKETk+Be9qK3iHToX<_mKf*78$}8;{0gr zPx2|R{0>Cal*&!9n&{k5km)hLI)i^dz^X}j9~(HE_&&Y$;Fm{eJ~_B=?PTn;nb)m< z?Wk7`&WxKrxNw@?VC~+#qQb%6C`=6`gKLsOL2#fXgo^$;5-oGf!wYHW30^*uB#NF- zXO1jwXdm5)&yxTZ;+Qtq3_1dAz#-4sTpQ+!MvTMR72sx2&Zv7gunRXLL(?>0+A*=g zv~qQn>i$HoCivB5ujQ~v%oR43s!v37NHg!l-1H8#+ON0Q$>_a6Vq7=yc_MHM%Yp%6 zvL3i#@9|?C&Vt?^yFZsCz*ow7v{0l~I|GpEZ09$t=9uuw)5NL+$(zhj_Jd1XSf9j0~hm%=h|zD+>% zUX_l6*sp`Wz7=k3mKUZwCM@Z%o?UtPeF1GITB7c;z$_>Lfj5Owz$i=Ket#;75SMi@ zw6*}A5_bF8ytOOf`X#!|&Ve+9ji}zI&sUd2b{8qn+MCt~h$}Nw)~*`(;|kA}D7aNe z7NV&jaEed8fJTwlBq(66l3eROqVUI#WT+^F^Rm{O`R@8x}qQ<;7( zA(xN`7w3Y1_%HyC3w?^qm58lnE647=fq{EvLtq^@h&FhK~_H zKgEMa;IodKfG41;4PL|g>ZpDVG|&!`upGK$yne{33Hn3H-Y510 zEZbfrgCO~0v>1676da@y!09T0&?n7gP^|8oMcgr1oj5Rd&KdklicRvsji4EIX#O1y z;r?w>ST_0!J!z3ju4ZAi!int8q$}Nd6V^ zTfPY>{RMYOExm^(ByHBR$`HZLUFjHa9K!>&mEtPrd;u>nV?Kfb$$K<*%r&(`>w;!> z$0`?Wq4-nDRS8RWSdmQ2b*&xRRIx_WNKBCRLQQ7`8OnIF+(*G2wr5`Jk;C*e>ZQcT zNivAe&o{rp(abi=Ajwirlg^5gLYoIy8uKs~46V9muI7b&<^$y=7B#=vAZ*M^v*r82e00?Lb+oU&gKUdu)+0TpIlLJE;EfLS5ssU_S{@((I zwq*Ds@koeNj6JLmru~Hc`ME0)?@P|>;P_WskIKHN-1azFi0=C5yQ876*k8og70oQ6lMRnGjnu z0OET(FU6l9U)fS#1ZiMjE8?fQ;&V$t(LPXtQgJHv@VIJhFTn5jGN! zPmu0EOL5YoC6+s!-WqzIUMKv^)8ue7&O3O&{<6Y5|6l~>3!hsh_>0cK@J7{e&z zxPtbY>23rDTLb14=HFHJLQ0XpJ5Md78xdl=zo;f9Vk}?hG@D3i!~NIya%z zAD9Hc&um$q`RV2dGwxxL5+-m3W*TNqT2nDa9NJai*J|Y2PKMN*rwXKLN1ubFC&3W2 zQ*oOfG*9G~e`RL2JAhVh;?mrrO--qF#s1p1+vlVc+(HQXf3TM&wn!E zLg~Pm8tQL*>}ATw5UkS=!W8J*s*T(aLCh?)m?6;Hz#dsKdym9%j&Tb-W5^O>Vw;1G zmpbce%DV7O&R2Lm`-usBoI`$bQ|Eaq*|_;8n6k-`O1wJoM{H;nJARg8#iG4GShE0n zJqAS#lU3=z1p$%$uJ)+|CEF<}RvpkaV}n4vpQP{Fiqb$WsiuBQ1h7Gq&7iShuttQhlCuFw5Z zQNCAI!B{RPPgqB}R?^!q^ioc1)@+!Vb2*q+!ate(&taUcZ}Q2uQK$5M zgG0HP@3YPC1*)^aEk8x_6~~ozE1#N+D`HF;YQ>V^%Bk~iz80!^U=nVLkVi=*;NX=` zfMiZWzW4T2p#*E<^W2r`G@PvrhOzsDux&Whoy0hdm0u!zR|vKR98k2;f2J|AsOYdE zds8sroU(BAK;hdk^Pz;Y6lc#IZs%Mss5_IoHRu3 z)a(utpIRwz^6OAr>rFWffg`QCfaf8!ubFnZS-B|)Ett5Ajp7CV+?9=2X((LXxShlw zgpe8#aHu_xBuD!ZohC~)2b}<@stMsg*4U1Q-IN-1j<~+NW+7~&4wz`9iaG@DeJ*l{ z6azm2NXwiWt!*F#@I%!4887SA+rL5#xR^2i$F#Rg&mP++7+l@ec7HSj1RK93 zpt34aInD}%$EIGaig20~eowDTXo)KsYook4?4-smb~gfykrAN`@JL3GGUiv(K_+0p z?9Hn>BUM*V&8{ErSf6h%x^EYNU1Ne#g~dhBi@A3Li)8N7#@z)9&9i;`CgsT92R(qY z*MDRQV=hS8_hc_&X$@#gWBp6xqzh&Yq=a6p>XFy{Ay1FgjJ8kd z(vVputtIE;e3{AtHv4IIi`BVlc$V)}_3{*9io~?t9Em+agV>{Bq$;HH`t*Y)Ule>@Rd~i`vg1l$ivHcYwgE6 zYJ^TZKEFf4a71oBrPF+;+u0I9jjurZH4|kW{??PAP+d%WVoj2N_gnEYgh;Nl3mx4K zDEJK~`8cVsxtM{Axy`U=06Rd$zZ~rguoUfYWzi@xPejhn_0tM-5i($CFhf4`kXKp` zc2QUrdQkDk->rJBT*1prLj)`N*n^zszL23+t3S*` zss*JGX@PfD(Ed6QuJyjp_6z$K0WFW0d$(}%BR=;iUZGBr5QDG6s2w^OCekTW6eA&sRk`O2`E0)b9rJ_3GvgP0x7H}K?{^7KVF(%alF8pCnA^cdmu{a`l?Bry zmXIB@5cu3V;R^iJD2pH-2E$od03NBikz_3`s3!gwr+1|gwjbH4?mGP)su=0+5~c5j zcmiB4sjR2&2!W~fJRON(p_3Bf3ms%461tV>cGiW$q;}T0)}6Q~MOkDG$;3=zpW|q0DiJC*!|Z4u6a8{3V(J@!e}d{aAna z8k&U}WTJ*>R);z`>Vwi@@yEpD04nW{3TF^3Xac3+W*7%UW;60 zf(=sQSFaA0bJ5@2BT)cjC(MwP89A>0uc~f!#$1@n;9C$J2-{#Eu2xY-k2dP${Ym z`pMqgIPdmf7K1R#sg|6p@3UfJoCvv>!IMF`VPv}n5Pp4qxH)PTQ%XnN(rZyEJHN~Z z?3`*9$JCzhF?NoI#ingB`{&GB;PmmX5-kqy8wnU+#LnEeypZQa=?pI;qS;RF;S%gF z_fiHp!Z7b&YM^H^#BwQ{s@W$Tg3}id`F);i(S38L9Hn56iZsOq15+X-lk9e8^V%Ms zt42h-&Yzn})fTDe7n}KXIWQe$-Tz%tId=7oZC*0m8YGbuvmgV{;yc~N{aSOgr)aM$ zu9tR5@HJmJGoIvSzAZNB{vSkeD2T%F{!b|&&aWxm8wf`s%P!BqjX8dgB=w8y>`ZRG z`K&GtBQHtYwUorA$T>fnHCb@-^;K3AomF*2w=*4~ZmrakP&9oBQgEZeRP#y<#n5)u z6bfeBQs%etbFu)pZ@(`7gfG;QWU)KOYG>-;e`(aM|B~+!UBKW_n>OgOhc6opC)C zJH)A8Oq5|RSjXxJYWuNlm9`CUp{A=wRKpcaY1P9~j*kQ5>9YiV^C$q%!W zvhKl8tDGlOM20MHXB6eas_nJIzW&5~;f1FGN!|kac&NJ(mf0M3PnSkd`GGX@g`H#J zhnD5n!d4K%saOGcQJV)cw2Z$=6M9;^PYl*p`@0zhaD9}E3#@ackT~)~wnvhhQ|F4S zxNf>QYS`<-KnB$C#O!y}kGCT_kWw*!@e}CD&}U1GJyd2q!<15(Per_v`rYAJ!sPNZA z4_fhBGwiHks*Enx-}{%p7kkV#-o$)OJfPO80ffHu@?!qA>7idg>Fa^4wos8H>Z@G+p#^Q;8mYFt=uYyRu@w6vP4V5^b#Fgm4& z`Tii+2OIHxAFUI>$v|ShP`iS%z1)f>sfz$?hs-d~OF&{A|JHPY6Jn z(=1{6&l*QtRMCPgSqAc~eRw53Bc3Uw8Y1r8Qber0ii6FMQ6#y?@~ZOVs|;ZgUy+}6 z^AlWOk5bx(&+WHnOgTy9c9e`NRZFKkp<(L3*nhK)$*m9=@1>(@GjGHa76! zx3*73a|po!_YTQeh*B#sSh)7F6QVTtHd6*zBn zMrlQdD?lgX)fk?mpdC=2su<*0?FD7|CP2lNjCPAt{kQsaOW#9d&U?`23^1|GUZ5b) z!JrtQyC?uRg>x172i2oqZ{Z6Eb2&Cwk6LBwC+(u%J;{rrROTsJc=Mmme-Fx!rc1FG zVs68@W+8603g{@7j3t8|e$5CC!$_6VyfiEgxe`s3iKHFA8i-5zX|Og79L$EJ51z`R z0D*fI@W_w)O#+=6+pV=?{>e;;moc4)be}7Ks}2kvWb(C)<;UVTIv=5g!4Qslu7G@ifV*7iK@#&}Xi%`+qW1km^soIaTc zfsL;;e_bE3H5RxPhK8$S z^kR30vj~v1`hPJQF>~}|3BBp*=1xqs+PgFTRicr-unZOaAfMT{K=u%iW-bm?!}1adpT#udi1-p*J7NxA{JnXZIN$ox`h zYk%?Q^e%K$L{pRGe1CdsftXj!dehh5N>8pJqwLF3AcCMZ+QQ z$^AXX#x2~?qH0(XGAg#RAiuU7yQkiT)M4lXY<|Zw`oG}!gh;Z7(1(%|G;|1b(INBU z5eDYiRJ9qjr5GN!D=T9p;Nr%)qiECv!hx6w`r|RioJ-AH#;F&`XkuaeF()x>{Q(I( zX~V5`KkbrI(UtB5dCjV9q(&hw+KKURTc`j&Rm;{p1h775=a8gM&@k2ImOQrvUL-EP z`!sheiHnr`^2w?7Gq=s|&YH^sYz_teBV`Z^*mvWjEt-Xd}AIlsFCS< z6JZS$H%kkZNBh9rxv5q*)@5sMi@r1H=9<(GS78R-psH%1stVhUR?g+HaqGuX*}U@K zsapeTz;ox*b=J)jT4JNdoAfvCq<(Qc?a_KG!xA?E0}GBR_DM)qRQ%Ut4N-~!m3_0oevPBy7O5}^yTs~0N_44vsb zE!T|X^U)WD;LMsOq@E-iTG-Pusxu9w#M9<$#V}{@^S`yMf%SD(z_1gJDUK=AP!|ZV zE!+~vd4@8T*dvFBi(q`Md?ZKaQG5ZJS04`hZ3+`+2ta=+*nKs>1kBd~LpavYzNzA^ zFWS2`HymuFl^S^~vgLlXsAk^Dr3xF&l!{-YGeK`+2U$=oIe4S1hZaZQ^Z&$PuI0M) zuhRGlIpZ}WNklT*w}V|0!Y!bh6eQlsjWL1ZPyyXOE^_K^n8g7=^V9A2K(l_w-ik(*7=b-3X&fJsf`CzQ?n~+r~)n#{bBaAH$<;ZMc%I(Uvw*UGD1RBmM8yRa-AX*T z&}X3MUo>evYHNn*Um-t?8bkpbcc7KO6ErOVcL~pg9#1;lU7S;j0ojwC^{q2m1|PZn zDH$i2x)iBGOX}bOPpP%#>3e6cw(fI+_Z;&O^z}Kk+NU|VGHq?ZxJ&YhJzp^sVcrD+ z(o)Rn87s)2%TwvJSDt|J;XYh2c8SlxjX{&1ukMGQy3;3gaiHM`C&Db>VzTdNc$wBx z9kVo^5x)#vJ2BW;1%NZwZ?uENotaCY*WS z^RddqrlsiIbgTv89{6R)dWsmAf~%Wq0cmIpW_y$l&rlUDQx5YbvQ>f|6u;I?*-C`f z+AE`Zya(VPYIDVIRm-w8nUjwTm-1g2)gC02DJ&bO)MF!@d{IjV>7^|%j`wtl=}TzY zu*Cim6FL=7BxV5g!9j%eX^TK%KwXe-c8k$P?Ndu9!f7^G`Hg`H8E7iKi<>_%aRx46 z4l3nvVQzNFFgfY1 z#%C~YXs2f;_Br!8Kw&SauY1K+zvPb-y2NVGloFUBs}Gw-w5^@49IFcX@u@r5#UMGm z?r9mBJ@_R#tqHr>RatPrayj|I--Y+%M&=Qsh-(JT(jF^id|7O^VE|(+OmEst>~bld zQoA0VJ|AdVHAtBhtaM$L@7lw!hcfkW1^@a-s8g}yBVJUGGe;dJL|FkxI*VCi1YsV& z^%>iO_mz~u1g=!yu=vtLM&RAgJESr=fh8WCPwcA)_`FkmdrBR94=ECbnO4 z5J6EtkpV(8i)%&ZH;F(-2ZX6aV34=c?JQ{@J07FJwy&d|+S?W`-(Q=}ak_7VmUdR0 zPF#`1drB9%7P3q3oI4a;bx%hvlu%JJ0D^p1k^@>BolTH9rz@r1uU$NFVsYY>yzubG z9l*lywSmw4>9j__t;59jHUQjdP6h{}Ox<+nBs%oN{mIFBN4X`M(pjumT z3L^SBx9#N?hQo~Cw~UpctrX0Sp4YnS)1-QGMXBFAg02`GrbsngrMDx24^ra?%m@v~ z$PI#4AuZ!bi^hYnJjFSv&w7&YPt*s;K^cfthZbRDmZJOzJm>n@sv;7Gf!({8Z631YbL>GM$CD?R$AId6@Pn5Q0A{@0ILn4&6 z<<9#w?68TO=}qE}QtxD0d%K6-@dh6PB=^nBzGcX4rg53QV6I^aOFn4fo9{kvxS8tW z<&Khk8+YNej1OrGGgVdIB3ChK>y+J~_URQGbBHFxo5(Z@udws)q%?(e&!%MiFa+FQ zTw`8bXn4u0Vs?&ZzE&BK81grfnowJ67X5;$xM$(Q(Rb;NuC|`&|0^oh^&xC80UF_F zlmA3y$BE8TxT1=M4%v;{Pz>Hv2|Ax<(npFWE=ZljOtmj4Lr>AI{7;%JX&dTTeWX21 zcSnwAsf(?D@b~|(uUemZl>BDg{ydH7?Obr>n(Mz)I)=W}xZW`3xnETc=U=;##d>Z7 zOv#q68xD{ZJWbHw_a2Lmmu(S-1b0q{r4fB*GFZC@#^}t(Dp8bjXV-U#)_-i}a(x)g7eFymK>}@8CPn4GBzDRXe6Lcdh91&SfZQiBRoJC%y{6nSz47ZN! zGp37du?Ml$u-#w^)@b#gNc|nQ{{{nCcRdSnHLS__c1Yte(5YJ~dbhH&SQ@x;zg|z8 zs01R=@CY28P2FVMG7g%n|G)MG(ZLgzuC3!PX@r8b z{vPD$T8i=v6UTqLM50A|b#|;}C~buHz@1&J`z-ooX0;^Tjzx>7#kY0qJb`&|W`-xP zu*K8keL*#RF?25BwlIKPXB0R<=Du+6QGs^~$%~!#SLPo5YfI=ybI|e2;XY30*WC$h z=k?+oFM)&QvB4FWH?exy6l)zw!HqQO=Z6MBn7>uyrVu@-2{>^p)h4altWwlKQ=<0! zMN^%IAM*3@GG?EV#rMdm*{1v zGh@6)fHE#m#&j3n_cu~*cyWBqb!he9nNMD->_^C2^x4>=75&ea9nwGT9m{sPpw{uS zqAFK^S?0i{D1f%YkIhTWQIf3(-vl<#fZ_(@4mr?63Cc=;8K}`V0BDhLgiw6MuoXp? z>j*;XuXq$Tn+HXXz(6jd)J``XO4^45ar0X>99v>|@%y9jR7vhAn%@zjweS&G-~S$6 zMJ;dAnsbuntY5Z)~|>G82QnuqS5tZh8I*H8&)Np!AkG0 zq3dDICH1W}X{p$!Cm`D;xNQnsICDAKcTM)$DbgoC_gcMf6yo2O#H1N}j!M0^SJhlO zPv7c6Mae-Z@xNT*h!J|fl7Un#3eZALwmkL$x!KsyTBLbJd*dKeB}U@eVOo@d{&qZ9 zd6pR{Yd0$L+26 zT+R>&?e;xmS7|{(yXf@i$#Woo^N@9}oN% zTU{)AQm4qWmq-eD>GplvOKovUKGfjcX1PcDL$7m3?Eb8f{&Zip zY4_9xR8KtntdS?f$Z2EWUzA~WfPmTONXjeiJf|Y;EaixgCcuj8sW&)RT>t1P?8gbR zz4UPP`~etg&YTsEu~wfJWe2XU;)mh!i`(`?epmZ*z*G0(Od&}B;&}5pOLQ&_aw|E_ zcWKC$I{&xDwemZMfyAA7figT10w?}K@LsCC$FHj@6{%2sLq-1+9*Vz*N_@r_Ahafg z$_(t&HDd4PDZ=c{0`n*qXk3MaCzP=*Knm`0TLkuX=$YJ!e93rPNnb9_LO+>XUmXw@u|8n^d9vtuYZzwG>adLQsg{`0 zOCS8skCJF$VX_q;?JT#Tb-ruGus*&<9 zVrA3QO9!{!jao9cN>q||)Q)iZCbB5nP125V+DV6V9^hhP2M*YAP^&RWpV@$zTa+~fU_HW?rF{G0@Y3P#pc->z1W+(q zYxTXX`;5?u6dBUvk!&zj|H*$x83`zH^8C}e^0r9iMiVm{rI6t=zuS04EKrkOt&%a!io(D1P21xwl?@`_wu@O z&Ht}XiD`2>NjB|7xTXT?i$_asPD7Ci!y)nqQGDZMXtgV6>Cltq1+BGBrBS*5=SOIn zyvkUFJnEa^ALd+}+iNY|AhhBXD^r9C{GGfS+?sJ9793u=e^NEZki48CdxupDKVnsj zqN-eo2|L%DVd*^5{TJid9%+jYwT>f$ z4rrv$qKr2c?arufGpV|A?v@QABETv&OTF<}EjGHlrk!Db9isP?^!d5Gea#^$O5!l` z`+T2BUcmC%Xgh!M)2aV#UuLEDm==wK4*SX*i`xi4I$ZY&y9iy~IP5$@O~IE>0XrTfTFF&zxDyWhclZ zlP#FDclmCJ=ko50?i5Tc9O`*MCY>kg46Mocy7&U^QQ1s-m1Lnt$S&7)TU_S%Be5lyAoH}SWXe>PQb|79Q|a1eaBI0X2ZRA1)6 zldx&JmD}9D2HemmW#n*kLx!;73SKZhIWwI^;tvju?)XLI&o*^+x%7wNSvV6?_oYe) z$lv|elPBDDmF=b{BfLql)ZEz0x)rzU-S$Sl8o5aEG~9Zach|caX%$nNsY7s;dTvR+ zAIYON%Jh*woTel_NCbUkP*Nc>I-Oqa<&r5QCs`(`BS*UUms2vYINVPj*`CPtfQ;k?*juLPFBnyc^TOY41Ur;nS(V z4hoJVY@mLXS51^iu?kHPZW8XGgSPyvLfX0lJyWlml(QB-&yU2aLIPxj?-NvX z4C0B-Bkz9GdCRjuT3wb(CVo~?{$?g9dEsn|0oNJj(gQ#Y8UX2Bl$dGO{-npJODB!! zJtu#4NTQuvZ;cY;N2szZYU}?Ht|t*`Fo-#%7=I`q1EC&kf1n{y5LxiaMbpVAfIxmY zKdg@udeB{lj{Y!~Zw1vCKCg+k&soGTGo+*C!l|r}clEe~a}N^v+=K}42H>Y4cqVOd zLvDv?qJ$+k7M-ptk$QqUhPXva+<(W7UYPen>P3Vb(8q@)YEW@~bb#|sG z00e)h-potM9D>v*M(XcO^YLqs#sc(QiOTM$HLR9~iQ5ZoL~QL>N=aeQ%d2FnAPQW< zU(!f0tz0}F=`W7eDM-P?%df{DC=%JV^WL(t3sUj!Ss5Xk_g|VH44MyZ<;S+dnn5z@ zmwq6mLSv=Ckm2#?qGYl_i``#f)X}n>gumr`aqlUAExPt(B+^=h`dOQoSM60zZ-6=* zR%F)u*yO;ofp)nCVNMYKGe^6*4sp#lbs1SVsKOl|Y)#+-2X2Ynr59Ycg0sY{2{T2G=G!qEO9j4SFM_Iqb0T zliDlJs4(uX)+PZ2EX(W}hsP@h{~gSASPQJYqhf2nnyV?k0*4%tfHXF4K7+g%$jOHf zC{ril6HAM$S@U*7hWnAjd%|^-&W|<#V6iYbEI9%maf{?twQIWRjTUWsn#eZA`A~}f z56SCe-L{!g`{K*}P<{hLQ#<4%Max_h25)+xTd#V_$L~N?k`M+3&2V4%4m&a^xcNt! z_Sut6VR4DkvJ%S|BW}O3buv@Hlc#u6(-Cywo!)Z01S9%O3O~*NO>=yIHYG{%4?w`8 z4}Ym61X!s5k!IpHBA6s{Z5;%WA4%<`p;7l~t?36FgW@exoS#8r zyuPsGfB*+tk{ZhI2dLL9{aamx68eoI1yH$jW+&jIwiYhkXAuVyMJ>%o)CP~|zL+*? zh_W{oKF)=;w_`?ezsHT^=`hs!Ji5=@$0UwDx8#TMYq#<&4gVX6h{_i^& zXE@>!9a7wjpdHRUdrZJl%~lugmM@rVctM~ZVSfQm13{RUufN1xoa}NMWs#fV2NO~S z_R6yG7>=aza{rXJJ!jG|Vf*U;VaB7|98qM5B9R07b@K1YioMuNnLv+Nc0jHO$9%&4 zAFMvj7WS9p$+!eawNRCrxrefph@LrA70ua;l>Y`fB)oOE#-|<`Z#5FwDjqu zKgJj%#YLcqRsq)mYpq_!g*Ei-DaUjsb6`*Bek0CQllM%0(b8%|#hKzhJe_tKSz&p4 zP0xEC$eg1T@ZrRRMPN5#+LGOnnG^kj0u9t&J=N6U-Q?|9gVc*!My!39c7HIRoIwq; zp2U{)(D+zCP3z^#AFi;LlR|gG zQ}KL+{6NI7FWvk1KwvIekL~T~X7!!>KL=LZXo}jK49mSo2f5OJGbI{-w5|6QuB$qK z(rcqTnn=Ay#^IedJ}j-c5b2n#VRmDEwI)zl3!Pe(fN~E3p!Fc0Dnq_P&@pr231%1_g^qYqRH&CNn&##eB){7hwXT*YrjB$E7oY*Q*>xK%j0wG_ zZ!dScI>wl&(N@7ZCSc;|%$bWv7;7~HHeN^SoPn)XtosQ?FLS#aj<*7a%VQZ|YmiQ@ zcX8MG3&ft$w}cZ};BA%wV*NsSLe(CtYV`hj(ZyO5a&La6arR4!V!@ysD!(}AO}=-# z$aB+qYe5R57QdbyICezYo|SjB-P|fZ5qegh@P`DK5}rpTeMbm85H?XB!;MbDdLwHj zlF8kDb4xFYREryY26hxXfjyAbz!3DDe-f(_>B{KDLF$W3Z=md*)i~B=b9h}3HR<{s z3R9;CTc)+{BTEb%Om+MDYEIn!$DQ6V9wzv;5=c;sU!88+j$aOsknPlGqw`or^j7N5 z9iIDw*Y$@-#{laIDT-fvXM4D_wG)v)OgpEqB(P2pdDd$ah|L+dCOi+z8*)Sne$C=r z&lLq&vYd(Xt$Edr(_A;?BqfrkFeFGmH*au6-uHH{UYYzyTouo?`l%YVC>fueIN+F$ zM$!lAxGl`_%+-dr4pS+4-6Sl(R8s)c_CkbEi&0+_#4-i zNv(ppo$U)hfl%#i0@G(D2ChRoW3h8BG7#Uk6`!a;lsA8kzq&M8@v_O}P%?q)6hTa&RW`a?va za8)|;?Cu!u*7K3>6&QWxnf9pZ09(h#vw?1FFJDwvNh1MKU>3eEaXX3e56vqS{Zdek z;%`Dd%jpq4csGbMBnSWrGCkV)r_BslegWVKc%yaD-!$|5Cck8UK0$D``&`g%&-} zIA>J!N$>g;RLcKg1tLvMI4y4y)%AE!pFyGVUC{Ufrrmqj&bE9$fy#(2{*bb`Kx&Z( zJ9nC_45QgMYg~}8sc)7l+*#5^pee5*AS*09-SH=%*U1*odizR;Y81TA?wIU2w4 zbD|WEGOZ9z>e>35OT*-Nu}Fq1;hIjrK;4f?e*ll4^H{*X;V5bJ0IwZ{Ok9lTg&p_Q zqPVJH__iD$O)x92UrBEB(Se>HwW{v}y~o{#`_iZu!D}cY_H}DxcYJndlHVWY0DLm- zo&+hkt470)Fr?VWTQ(K?&v!Kjz;O50g1O;Vpam^K3&ZCwBWeO)Uq-)aH=iZS#UKTA z7O44zdoHF|WsC*Kt*_la-HFDw78uoYyPRzbe4oe!&Jq?en{K7u5K@7yDtZ87HslDt zBNQ+Mc6g6cIu}j4@nWfj)5YV|nbigMNR+{cG@jbA9QmyRas>DMR2Z}bK;O|Wf*e%A@iYI)qS`|EORR^Hys~x1aYimHrRAkn# zKkyC)H-?xfxLQW=tXhHl)(~~`n${T3W!9nCW33b6H`XufoeP!x9PS+Ajb-40mR)n1 zaE1{b%rw_$D@j{ZE+~VgckJi^Gqmco-8z(5b?E6jdO_M!7}fHt@~8%IMS)>(*|0lR z_we$?c_Dy8T*MVni{c2ph)&;?P0?|mu&$;|oIP#DT3~KfnN?l=_x{>PVj}Od6V>@& zBo=@8O^)WCsd_D0f6g~i(+?C0P_*QG#4H`n3##$thNfSjD!nahFAR-=r}=G<$8q)} z>5_Qzq}`juOFJoKLqUlugk8PF$0Ii(=X(4<+GFtTs`dqv5^R^sBJffWu$kSn%WX5j zx^Ij|5-=ne(1@5N?xKHVQyqRqwezmPw6|>J$7{My7c521EY&DhQS4Fz`CrzYc(No- z>+XU8wssS?x^K-rw|ljczPHh!$p)U!Uq8%TUT7dcV&YI#cTbQ+IF4X6iODD5n+XH7 z>kO_Zk(~ZG3`W@fyQb=eM$G+;IiuyTe(-6y3k=+;L41ay&J&>MT$W@B+m*U95ES3I zD-~3js1Rus&p@AV*1@o*4oh_p8cKR#Zdx~p)Bq{1yRKe|d7{MO#4d2;9wn`pm=$+n zcw^z=IffF}A*2%6HNx94%a%XQI|`Fz&iy(-D;p4 zc9r$m2Q$_Sp_?Gdr3f7R30mwnu_6n2HHahWu5R%ld3_-$ zz@fBs8Vcu!?P28dRD*mtTP^WwCHD|bqL8Hk=a~&Rk!3;#u@rpW&DyrV$-q4xZf^`g z1bl2$i~96>8!1qMO|={$c2m#zA}?N4T6-4&pW7f{N5v*s=2<47rlB7}6-vYJjB&IJ z#s`cy=(|J8XJC2*wFaWwdOgFqSa|6`eGS#?h{+>u;MyVMkkca!d3W$RTiP^V>TGcY zBV5R4O83bn!W}N*L8)DZc|kNc-Bl^dwO-|_S0X^;{U3geeU;=USJX#*H2A>g&j>mn zbC;?8N6sZJruU_3Rc4p;>d}&X_g9*0>uUbt2*T>B*dQljdE_uVfH5Yu_hfpj0g;Ww zTm%SBPnfdXz90v5ET=k%@_#+_XM|l8nd-hRlf>X&ee@{uNocYrZT2o@4lrq~v7qVlh zwJOU3{XC2Y?sZ*-gwb##Z1kkKXv;02Xnmbi+ort#6pS}3NhLbI<&xUw z#xlFOYIY5vY0T+QY11mTRQ0LXS9T(M`J+4-;Rn=_Uvr|a$3Kvvdpus-)Ud?2+J<8J zed6?l3Q!FVyCj9_4k&1W;hTnnO6{!rnrzYL2U^n!H4X=|X}uVa3g#9A_!nfNb%md> zA}GY306yl#^Nyah&w9AF!7fjI@y>QQ;Z9Q>%?{peWcQwV{X%``88_|@E$dF-G{fJF zT1pMMlC`f>OGkMQ`PiMF5?vH`bDi^h#3v0_bax@}JAu6Z3T88xqqtFpI!YVnIg7Cr z{h!g|gzke0#tk$I9B~+Stegvo$XLhlgSjWeX>pt_+vt-{cJhbU`X}SbMSR5fjl*T4 z#_k}7obj9(>?f}Xk5^&tput9WTE1Xw>Qm~v6A9|6Q3i6-#{S27`(1r{6cQV|mWyn0 zGfUdwaZwCp??51{`X!06A8GBO$HcrZ)(%|;wgd?}arQeO=RF-aL!59E0(4~lQ9(8| znw8eMheOV^tt_6twFplLYddI!I@Q&RrP}WvNDpo7_%Bj>)Csz;goUNYuRU_w>9=@l z-QM`agxZ*;+VWE9KB~g#Zk{M}k8UXdKaG|0pu)uO*obpr-kDsE!0iE_`VsrcyVfUF zFiLU8?<=iP4t3uup8N+4S5#zt`yjQCmy8rq9GCxLf@n}c3`_1a`s zSO}~v1|r^eg_mN$2hf9356O^w4=FttFRfPFQq!BtfkLDp|Ey!51z~rR%OpT1XZOKc=b{ zI9+Kemy^vJgSXz}g4;Y_MH+`Dbg8>#a0FgzVnE%0Rarm_yqrN#&MEEda7Slb?uBBhVM12zR zD5I8R=nSA=rZ!C3nFk}s@fG$}+9=B<1`}`n5B=$W9RaP*Xb*zQD^MFg5(_ji{9TI- z^+m>(+4OA<`f&(-QTm4>L8cOiyfd}s+R*@A4O@a!Q8Fu(;hTkl1bLneS-BF_;uj;_oA3>kIc$b=C5sWU@~3ADKEKgwmQnRT0Sjk_m~&({eX5XR~|X5k3m?7gfA%q}Zh)ZTfT4VUIgDlFCPQx*0= zN0iu!il5V@r>Fj}8qt)Ko!wl(g&VApgnMVSw`0L`SJp!Elm! zMKXT*lUysVc-WGNP8*FrP&vN}>I8p(`Gh(c!^U%p-yMIo7T$v9U6yHjM^iEQg7eI| zRi6`q{qJ>9GMO#OBGp*%(`gFBjqE{amvZUv-gp-xK8=&>HY(G*LyR{+V6-%^X@!^7 zZB>o^9*ziaX2*A(|Az*g7B2gm;rU$4dAJ7shgwSph<{-*uEu%rv?8OX^xxp~a zM}}Lg&x?w50r`9hw?yoG9zwuxeR;QKCMD5klnTBiJ9jaETJGk}LZ(;?W(X1|BVlR* zDS1}7MiS9+FbnCxHspRLWnHD*PtpHxxnvxW!I&x=E@<5Tsf9C#+pPVsl@dDfX}fZ? z%R}d$L<9$wNadbooi~?eI~utbu9JHLI%@CMCJ;6Dq7%A9H(>3SxzJlRGhWOKE|U;Q z#~aOBOYUn-HIK>1_?8~&-)y(-1c0mUjK)n6<6qm@T{PxOz;qob14t0gPv|1%NG-4l zIcpN66rUUEb2qYRpVqNHlo?XpXlZ!wP(zO7ay_KVsz4!RW>R>HL(BQ~ZWHB7ZkrjD znAM?f5V;n+GbUdRq~k{MOU#~wiTtY%#f1*>+cVng`o_X6e9pp~eCw?XSE^QCP?3Lj zTzSFda)?S>>(1IPCP@TNo|o!g)x)Yj(;m9HeFe&9zY1*xOsjMp^+q%Xv5cO#(_o&L z^YoOG+0jhKu5%MV3O@l1P&m6)aj`UmVJl!ese=J86Xv>-PE2Kv|Dil5HGm~|91?Rp zWf0HPaVSAAs%e0Q=$0wUElVT<0^cKJrZqHuVrQ%he>m(fm-<=Y6QmkUFuK4CS`mQ& z-DULF_#!U^kU9shI&H_qN9=6VR=jdC|HZgmKgqdJiBLkN0d%yJ_%p`1yu$fYy(=@b zWJv9#|E`BA8zx1Bkkv-nDaRcL*3PT%M(>kLClg2xx&~@|?F0aZb{&W=@Wu)l6pFGU zTDEfZ0z^%5vVznz!xAu1ebYTD`c&a8mQXVy)cstK6S114w>K0Gy~R>@a-+!yZIh)p z7X}UWcC~8JRIs_{xc8UsgaqpkFzBcroj?0j(Y+08*-26V{Fd@ANFo1tGAco%b!w}6 z)D9!H(cc3J?_IDGV8;{RjS}fpyJHeaX~YW{hxg3KbiBC6-L8TQ4jtL_beN+0R2z_O zfPo2+1jFtpN8bgIU+V|?J`GtlVi1q^NFZCD{o|@=8*KmX+AFv^>rIdRiFB@>LYk181b54?lienO5Q0Uc69!lP~%~_bYIY?YO{? z$%xwfRmx-F+s@q>6hyYa6+%*d31-iV%jshSP3)xP=jV z(8;nz|07PYd@hC9)yXt#!HU%;ju4!W!4`#3gg9Rp(6QYvf8VlFfheXEgA&(G`Q7)Q z5nQ=DISe!AwcNui6!~pk1B~@Et1U?$mvV*OIyqnk=91~dgI^dX(47hht_btQJChBD z6So{z?^+uFwM=br9;Zzr`U|Z_K@u;o;HoM*1MfqL5$UCkCCxa9#N{fT;)@x3)Rc~U z)j$7V+r=k&G%V4_P^A^nvVZY%if>BAlC0#C&KCf)3N1>bpesWormB-_sUhofRtFIK zlgDAd3N!-Hx6{kuv#;gSt|yqj zL+-b%KlOdyj-OTT$K3+^QrRQ?JLS{n<7e2jKq3-9fZ*kLS^G7F!r@fd%bAn+^r-Os zSVS^_Rl_MUM;f+4W`38}>%V-E%&i&r^LDkG3vze2wYC0t=G#%`$xLNHjh z`OLtJ;f^st9-XEi9(D0C2#FTQMYmY;AZ!wJO&`@8fA0W3mz&p@f;bsxYGVQ@xw?B2 z|LW*=AGDR*ip&>r`RT@(_J#(Os>GKEf4j?48wl&gTj3}+Nf8Th(($kZK7ab_JxSj}c&d%@q>d#4U0_@@o zPmZ<$;LS--)s<*$2G-J|R0Hd6XEw$e+%RCg~64OO#c0*J2I zGV!H^yD4epntU)5ZsUCIe!nV*TVbLpaMEK9?yuk1L@{BLGnr=$O~!Boj^}|ya_fs7 zo$QNY*+Mg_N9JnPrRGWMTf#-|04M_=x9Smu6L49s*UIffrT6AcB7WrY+HJ7iV(Z{c z1`b583Y6$~cq}=iQw^`=eX??MqtE5!*wd*KJfUhLa}_=v`)7QkEl2~=kMRFu{-&mz z$-5PGkg)&XSV8PuHGciZHyYnhBKtGplkJiRDXFE3S$(|AaVv|rxhkPwCbfn zA6t|BTzFySTD@q7toXCcuKv@Y_P-JXx==gcO4`j6c|)N$KcGAz_pn_q!79Qw=j-3| zE+t-*COF>MX5aeLqu{pES(Fl9;)blEr9v57Tw#Kq{DqMtkX^ z&o?uNT$A>OeI1w`Wh5Yi4E(YM0FcoGxm8D|lI*HM=n}^wtXy>Yiihi6c=JSb($tg$ z@uxT)Pl+3;>wf<{!i^zA(?Suiv_8LXQvpTlU8ckmfO25KeX7q zItRc3sn7Jt8Ma7BOri5Id&}Q*Ne6l#TamB9brl^bF9Lx{4;k1r9`**eP;S~bdElb& zSlY!V1>6_>CdOOgM9_||sXYu5Dk89m+b1r;w_ohst41WfDYi>hR|)Nekn(3 zHDf4U82Ff{nKAFw)8fd=f6GdkqK2L4R~&WimRkgAxRaZg&7gd11?fbpB@szj6rPqV z#4$ti;i>7K_=iSgbW~fh(=>sg`ZQIytEq~-tUqQioTk=K4GwBv0UAj=*>1iDLVzz* zG=`XNqnA?Z6cJApI+{oYma*p6=~$A8XiiZJC^D8``kLQqUYj@D*h1oUPVqdjA!a(8 z+<+c}umNKWq5mjLX06?h*9_Hb=q@1R)cqX-Z|zaY#K^=*yhRC40OTcd%f}QGo)Tk@ z;YlgkKgGy4Mr~QE0NE*$OCp)ibsNorglB>`gu}-b)g1Z#sab@nF+c%~h8POa_7VEC zrH*ETWol=^JEhU4D9T0-U)2k1=v)2BBmYXz~FlUzy#T5cE}cPwIicyAR`q(#|$sjGXae? zP+_|ldjGZMoHNy*h(yv=$9NaPktb6T*E5VviIT2QZpv)Kno;{gg4LQqBHF?T?eYI! zG#&qvVNL}-u$D8qfoqmq!8OBWs`ZT4rh4s2r3yL5uMKgJ%KQ2^ z!XGF0`#^Nh6)aTu)7SKljG0Hecx*^s8hHW4RH0GIAqoW0v^FJ2I@&KNdN790RK8*y zbfzrsDYbzSZNlXYgg*TfA3!MDgr*SanE-$lC8LrJ`K?Xp_W6``91z$vM4BijUSMC= zl?zeQ^80d6!Vm?EafA0)ty2E2BU)ZAw->N}JBvIafgYAbMnK~GsX;h<-P83mI ziCt~VKC3+r!%KeciO)k;?o(5|$iypsW)s&j?26*Pq(?E%DFrlx0I$Y6KbQ}>4+Fj% zmt4MAe>9FR0IC<^1>%nr2^whPC#+;-5cIx@%MhOk96!Y5Q7Vg9oIfCVjkP(estu2b ze?||5SGl}mdlW;W8|f~sRW64oL$+GNplo9-h|ii0QztU@CVt2RA|y`(WfuQ72@e=} zJzKbh2ZMLtaGw0v@+2{xB|g+hCohHTN0Vu~S%+y&?1Q8@uC8>;$_z@&1m4s>EYRuV zpoiuG{uBnAX4ng{$EcN)CXZ;Zfvqso2cphM08rk#yIr;fa{E$Akt2i%oOS`7OU$n% z??>M`e9*PB*X#inzKo<#KZXDjj4FQz|CeigBz;rRFM`mAIng_?C zVCfH~OgY8=#)kXwxQ%osx9m>j@evL&E2u`5no&*sLLW1sOuFzq<|^<2)ZCE27G=+-3jkIqw{z)~M_suLBMOMvVE;PnD_Q0f5BxDW)BpN& zlv&wPi2eiiIHb*zm+#o25)vb`E3mJ7d;M)KNDiDA#&Vinf#~IkHXV4`Y{aNnCdW|g zUK-5*G<5@s&h+=!;F7<%XhaqCI~RG1p!l=lCh6N~OGR*#GX(15`@t&yyR;WIA6Y4C zw)+fQMX6ft&ig*5PV=`^CfX!G15lsw#=rCJ*j%OLjmT1z8X2S^6|o(4J_v*>QqZ0q zcCL$&uN>kIqZE14AHjG}p%6GHz~RxQK<_5%LiW=>RA4Qnt8GbWZc#~`_Goi~STGHi zE}~KJkBDm~q8uvdt?f4*e5I7QS6aPHyYZ@SN9eS!%e-R3@|c4aAD@VR>~1Z)-I!Li zi`x?vdkL1KsWzrwm6QVc9-z=0<|gcw zv<;>5zu2!u99OJou`x-J_y1^H6%QoUo&&;ujwB+n*Ouv(0l>Tw_SNFWTrrO)CANV-`eJDa&7iFUvqr0Ac z!*NIZ%4ic1K9tOy++>1XFMuGWrc~>P-a!1>2zq3vq8>)MR6}4F0ZoGp#LBYRmGlHh zA~nllPi!Uh7~YjzO8;(kHB7;!&|pN_40d$qICZ%Ii-JD=Wp+I62lxG}@nA3k z$eR|~5x#G6&~R1nTc$biVkM3LMOGDI+?U@VT4^|3BFe)`mMRvneSw0%KGXfi9uz}&#MSAFldw&+qHs>ta=w_ z?T4l4`0&!EuqX{4ka7r_Nqe$4PfXOMHB+_b0equPB@QB4?qm$9m4a zu9FP}=j7%?{;|NGrG-&=k}|yz!{Q6fb+FRYz;2F??kBZ>H=LQvD$c}3CO{`n7^(-N z)a7ye}V>+pHrZScoyU$B1~ z<9eXoH|?`!XH+3feMV3VYsy!{D!Ot7zTRaL%t{WJ2!?ORQv-a-aUZO4a(W4axG$;V z{=QsFSe_Wc8tpV+LjG?)$$2#JXh*G6QA148WF=vVa20O$FtZhwq%VDmg=!S`9jOe> zhZPc5nvLK}#uL2l)cQQZ0kpT)wB-AmX|^aT^_A36vO8=C5>Dk^#4Rzn{k|NSeU$vJ zBDCc|0^3qE`AphgUI+g82#vtT>SdjhBFFA+UQPr?8NpN?)Q;sD4yi+VZiGYnNtcp{ zm=91r>mXMUSPx+zGYb(wA;-aJmyHtbS2@2mh$Se)O7x zjol+WVB$BcG#Bf!Q5V=(kh6zgie8^EVjBkqRW4`g2KTL<0+k>mG3T0;W`(Nblt^6Y zpsCU0lF2({OtK>&zh{`wg|!0jkPdXMdwBfe=_}(Q%+L4i zjKnLrkBH%uqW6`S#A^t{Mjb_b=QQ=an?kHv;VH>tA#b zuQ~PpxAWd8et0H20!thn%VaN0m-p&hvq*P6kF>p!q+R_JjYq^z%{7I1g%~Bum$WTI2WQJlbA<{A|uTMACP|SxoAh0 z?|)jR%;+Ulg|D*@|4Bng(V0aUl4#RI9rsw~N5o=y5ev_)Qbi7=fbCK=hem+?1c_M_ zXJ|{1rwrqq-}GQq+lI3Z(JQqiL*qX+@u1?*3wLDHEvAHr1i*$YZ|02 zTAE11l5HqjB_a&b1M!u0`@ZAeR_E*(7BZCN71{e$gUX7)!YBjH7K+BpFKt>Xz*4u= zZ#)#A{IB1zy0(Vu%TuAEQke%S>a=Bte^=hJva}>S?3hoWpalC+%ME(uR2>ydMI@Us zf+~e-;^>w|B}Q~6L%UlE8vhl+56QL0a+k6vi(jk|baE=)FmZ{h$7m=eRu5e?T8@H0 z(h;&B?YAUTg41D4S5Jo#>x7=%`YQG&Sb_0J<1) zL5z!aI&iD$J=APuASh^c^D1VMyzrMW&4K%G zFH?5LzFG`%rkz9(!VL24Y5S7}@8`BuVi!u$B4trk@vU_9^Ki*c@0#vC=hU7xu6TK? zj*HCJoFEjcxRU)^8zz z=eJ<@W2fgnQjeFK0n+e)q15d{zkF5f$n#Y>QMscbwQW(4tc^6ARX*~l1m>8H~HLCV}>AT0vfA^rQc{gsBh7rjyR7ssLG9x_VhTs&8NgJF^gGu!3{Z8 z#;YANqjB`|KF~h5YJ|r&4u~X-b%ho1QPz1i=z-WXh?0H{1Ya9yE4Qcmb0oUtV-h&c zdr#G_L25mLGA~`rVne{CAuKxKO6zeb9zF}HUJHw-9Fj1c>t0yKAqtYsOb{8`A)VXy`N^L_4c_bQhXqf??Z zHzs02!toxuzrg~S1Yf=t_|#Qm=x-iNPltKm!ejYG*C(0GzZD@IW7_naj^I4xmmrg6 z5TJrOC2uOHA|R!5WH^dTNh8p(|JxDk&g{G&T<}oU*Go$(?7SG0IM(#A@vS%sWr5?E ze0y-^NiE(aumCaL1F^x1Vow@g6u+41KU@B(SGY~?+F8m;X#gl1xt4B z+P#l8l7*9DBrKm>Q>G?H3$7_}Y4dIaH)%W*QdA4LK}tCiUFrJe_gJJL2&<|!na}%i zvA>sp-;x2Hm;|V9F9+>!u!zm3p{sMTU-yiK3c<}{h=jzLVFvC3m!r~rm{Pf?SNCT; zim+xvZ~m|v7|uLZ7DxKZE_ERH(mKDNl-bk;Nn>q$6XHZ7uvrR3`9;Wc?!bI7ca_s3 zRCL2PVk(D_SB{S-+K8X*z?$!?8YRnHrGsTfuRKX-O}M{7z&KlCbw}k)TQO2u-8XU(OoJ}>`b;XlzdW+DwcMZjTFX@p?603!8-3Z>K=dU#FXq3BX`229c>E|t% zJ}p*-zR}lTengs46^uwbH()wph?b4D#ZQR-uV>c@4>!FT*Taw7?6AnQe9%zN1hc*= z6CG7qJuA@gU2^I5FGbQ7?>8_we^=Y>|2Auyj(LqK=Nx51hX|nPxRq5XH1#(zf7K5l z@b0WhFmY}jH?UI@`!y_A+L1)p+B0A(xkyp#8Pw{a=QC%@gSXxMEsZW@rdLd)4+#Rqzx86HF-)mSQlSR-EGDuiw zx%=s3_ZT)&R=k6Z_;28E7^4(CUlfr=2C-Z)1ho`Hu8IZB;2>LKEz>)TMCFmhtyMO= zt#dnp!oHP0sZT+9PPu9B$Z*~tc*!WQEJIq%*|*W!nSUrbL|08^`0GWYyq`(& z&!gIb^QmDq_X1K?(=y>RzE{%x+*{hjz#;|(k?L)ejE|Nxda#2|Y3138r1>o2@rh)^ z>TT$-AF*a`#Hafb*P$Md4A=1x$z{ZB^)eq!xVP2uLwu4CkRDxEm+e^@-a@&?#Jm^} z2J#lXRtSv+m4GM1MsROw*R$**0h1@?bf4CjMV_`b3XZbzysy6Y+gheF;lQBq0) zYHmB1v81p?_jLYNoU#;zpI=qp5DWMMMAp2uR|lunp0KnYm*7Yf?b&WrHRK@GkBPcf zWpVzGK6YE`p1no|r8ssav&TrR7ucs~THoX{UL=P3QbsQg$b89}CM?WCD-@duUOcp% zJ!T8nGE~aIqpc?FqpYP5^TFiEg>``5M3@&Omr!U`%KNErV2{TR)X8$CfhZkh_mUhM z`XVkPtu;A&(BQq*+h5~1uoweCs5Q;CchilZ?@XZ+7DmbpS%x_wscc+nOTWg>n^(b}89e zn(fiNhfVpM2dcujeeatEW~WM=3$#-Hy-p!b2U~eM{CL-jP>Hc1qOUz0m*wmIN3i#8 zFSWEU$vO^1)>{t$$ATV%i5AlUVXYCg4XRQ1JK1USl{w}~vKfDi&PR0R7`+dl`5%hS zOi4GdBLLl7&}kpGo4m9ED;gW@cRx-;c(4Dbvn>oi7f4^i#5} zNoD}(pylhwh5o`Lnm(`4NS06A2LvJ)BG2)U>ByL2P<)=&NDqoELWe|bz_^U#*&N+J zh-&*)xURPGmzLL)GfyVVRDbWtg&1|$%`Q}RhjROgaVB%eH&zHaZC@`Hqxf4jtM@itQDbmG>uQ6`SQJ3^=02^l?$eu!!NW(eL{&9S!$G`Ve0d{F4MRfEe=roT3+Z0g~yNW0x zSOxf|b*kg{dh`|ZJTo3(<#IJ~uuxhb zvjzEzV-T()YKop<9qsm`sgZH2YMr{+Jc{}f9?TYx-uu!Ufebh+$JIj2PW)uv_Z>-; z6UTO$6|A^*)HvWNrkFhty9hXZK)MC7Xc(j2Fh<1N%=xGRNUe-C2QgUlwoWv#?_=%^vVHV`cz}{Z zOSr|5DeT`Mw2{rV@P4X3ECUa&kL=6n2uKX6GwNQ+A5jk2e>RZ zR&r#~wz=B*Y8OH(obQeA9ux$tz1a>ght<`n+fFYXXIA}H^+(Fb^7e;kW#5phFU((u z9n)cQ)B4$P(-1>jZF7Im1(Egab-cBnCE~VK?L`-RZ$z|&(~BmS&nONO@8Vuw%PdaC z{#mD8d&6$mqFeMwRdm5{fZ{D=3!ZtZ#LE@Pb3Wtf1WrkLM`Nda7D&2@e+W^)cgZ*CQn|D|3fB zlc}(juA$T4_NBXT=|3QTO07DBgDft*(4YrHlF&Rpb>_YHu^WQ1ZrsL6#v+3PGdO@4 zPUfF%)V(9 z5h@<){%EpG+su^~O(K1!;0Uvr>mRjrCM>#eQ&H+vkaBdRkJV1FQ|)}T|& zV7zJqOy&84QxAGS`q*KwKsREBuk$2Vf91mwsO&f`uF1v*z*y84C!1n8qqxBGXfySqqs7*3&j zgWjr~qx5ABl?#M?0E^XN8>|C)gEa&l#I59Z&kBGNhtp%$@r%FC{V<6exmB0VB4;`o z7m!e~@ytwz9Q&+kU*bFnkYt}`3-$60gogT?SYSGufE<$e#A{shnre3pS|bB%ijfQ) zN{w_hf>EwoPhBwsjnlMa8vkVPi}@*0CS8qvm1{Gm=0BjA3Uq(5h!qtEHJr%rmCB{S zqMj%0%0A>JgHp@%w!EP+s@!NSKDeWb6#YFpMgzyCZJC7Nc%k$C0(+3YQd1?L0+|8( z_jd~6TAZFwDK6I#bix0 zITYn{U6W^H)yHw4n@R1)x7Unz7=nh7Xd6Gl%wic}Qku}lw<$dJAk#z2K>U6-Fgztj zIOW?kXxNa9DcKMp6u&FEqE66+T~tuj8KZ}}=}cfzzHC$SkjC31AI<@O^T&KZW7KGt z>M3YKPI9(Bs01{R*=j!jL|zSKJUD_^28VJ%jAYm`)?S87buo~;p& zj}J^|^x$sUOmW4YW`vtU^jlTWs!3Aci<}VnYN-Cp#GfWG@7uynt!SR8d2>0xZVBm? z#SuK83pF0G8(y7rj3Ukibm4qKC9*yGQPS;&D6efvuN-g>2tKNokE|AgpdsbG#-n&P z#81p+-Hkysc+2oQPvPWVHUEQ>FNj{A_l|yjRa7ktd-;>8wN zv3kG_s@VS;iK?#}pN#d=Eh{l)8H5?d3asDR&`=)mT8hGG#Y0tyH>!PgvFl+r3U5|+ z`F{Qri7T=P&jGGEry4G?@}p&K-vDDPxU@9&Z4liXiL452;&!KPT)UMj33Mb;ZqJE) zWi`c|;B=kU;M}2O@o{ZKLNjl4DamYgUR_)iubQEzNB@0l2&ps5$FA0K^S_vU!8aW;= z%Nn3TXkkzv{u6t++wEYxv#%e|++cAvpiNGq85;M7edn(9_gNIgvLo;e8XW+~Z=3J4 z?dO8u1aZkb2D9791pDQxw9N^6@J%dop4#cX>nM{z*95l7Z<0oza3LrfF2qlgqbDhL zph-H)cCtxys<#LYQWfmorb7sfBNq;QJ!c=4B6vbl}Pt5u-cQyMehow zT=O($#~~TE&1cFCUsET9)=8&J4gFE~E)}d&Y`#ACKJSE;uAK+G&nd4*nJYPE%28$B zdLdhQwT2tQTQ0rU`6LnT9~b1#tyssX_{6S(H4q25PUAf4cFJa<&PRxy^mCNT7PlA- zW6HJqgid-M#m457^b0e0-Rel(8d`pBxIpaa^kwp&4^4awj|UKtqRD=P@%qIQ}UWY$a z4A;(F?zgW`1v9~b%LJ$RT7>5nXSBk?9l*OuWr#DUgnIh;Cz%!)!o}mjvLp;hdd;g} z!`;Wq{jPzG|M~$i0mo|0^t5=3Mv(v+o*d`+PW)*8LeT!tEk*R17rQ&>%9vO*^ktBB zpBJ*i+GFI6zbTP<{g@S;5dqnV@Z5L`&G=j-D z(HMKR9iui*8Q!QR=qn;LV{uCsWlYb4tgX*|cJ|9*iOA*A%aD_Qm9+B;=!aXD+G4RA zlI8)#j@N&#Mk|s#Mp1_(idITAsj+~s9q{rvOStvctHS0msM4g0c04^%;wS{JqL?9i z=^G)9Y~6+c=V8Hr{$Ro&k}({<6DPO>Y*HsNhFg|N6e%W+?h#sgWA+vwx(&h%65Owc z=_ZKB7*7N%XD3Lx3A4`QRK~k11uu0!&t9zOx%77=DH@`Gs z#JvTGx*@prfZ^hrXW7u2g(pW(qt(m!@7aF2w13mqaBrMZD&8U6YsT*o&H~X5sXJ zfri3dCdq2~!Ol`h1!rU!9fEC9bY-tJl{)?tstMZy5IIvDe4ob6qlB=C17Y61OkoEq zc;^`Y#7@Pxr>|lpLR^0zKWCA3QocLwP2Y&(u*)7rX2}PRkZ(Ap6JtiVgjS8r)l6;S z7lmOslG$d76lm6RV%k_P96?oGk;d*2N+b3a_s;Tnd9%5lr)Kdemv&yl6F`Zr100}B zDLFY`noQq2tPE2$kTdnf8(u&c+(?Esh4^}lp9;0~-fi&VE67L69C_tumr8M8PLfdd z6@;E73d7GO$GU)x>5REO{5!#%trAJZ1B_riu>n*QYrGy z81aiqZd^|JFogO1cnvm4nf`Z8nB?Y7&1g?O3V*s2>_y0~4A;YF-1q*dEJ~9uLsdIi zDUTjz={jeV0G?nZ;@&t~LSmUpUjVCPO*UX{z2AlARboZ7T8Y*I7j(XCkkz4q*WKU7 zJpzQk;jYDsP>gJBzi@Vpor`#4o#RCDK4dqUr~-JQ;y z0gEXR>p%ZtOGMMVt1bGpvi0Xl#wj_bXRu&7Hs1Y4G{3~-Mq6=ZR7N5$q@aR{Rgn^+ zZDJR^ssYvXUxFsnaSG5l7|4!%n7f@%U<(Jocic$;8*}GYG$97aOSW7H9bPeAE;pTO z`uNT6jgSHQNQSYo9ZkM4o4X;`i$O1}Xg=G-)i#v-73CRwiqFH!5H4>12uXyhZcC;^ z9iAO0V@wwWSpAW45bScy6z02g3nV|b5x`f26n|i|RxS5LQ9k>AW3ef%-y`SRVyNYXpYumUwyL5Tv|}eWg)Qfxf5`mmOlR&}+fn21Y9Um9oXh=FA7* z@-ICug?_VW^F?Us0z=5v8-PD7);vUFzH<5-mpc%vnC0i|+IF(dU$h+lSEV0jN*Tty zVV_Ma$&7#jic(-X^NtXZ^rJ_XYkoDI@7hKNez+Z>No1rzkb4YCd51~2sV7JFKR`qg z5kTq7;K%qO%RB?+I#*d8{()X5tS8$5GhY5GS_@_Yx^tsp>eLzQUFTauNIk{D_+FUsThRm(xzJ z^rRo&->4;h-rKo;;M#Q^eLYxScpu*;)CA2Qd@fdd;sI8I$l}snMr_8gVbOTF z++dka*>PI$;nT>wBN3_z)PS(n?RKw0u`j#7hApneR!b-ISigK8;Cus1u^!!~V--)K z@>gaZBJ82nt??jM&pW`u?TjTS`)9=x&%X+GeTxI%4JXJjeoB;v+WMsEbuYI(c0=<~M zNNM2!nXRg_qShGBDeL1Mz7A-##PoKFztggT$% zUR8y6BCUT;PSd?z*~RYTaBLZ1XwR(dWKf88VegiRm!fTZMm}MSQ3W=!wGbj_zvOF& z+j5Y59t>jPwr&}sy8CxWHMg*DQ1nIujoF9goEVKf0F#bgh$_5T_n@y(Zm&ouZ;su9 zM=UIHa-1KovG8^1nvU1N4Q(047U_o{BQ7wtDCMKM{Jn5xeeD^?#A|^;Oc#GmTp8C< zkG+n>ESLf0;i+Y$bL_(gjvE=>|t>ec$8u@+=sr)m>K4SX0Jxirh1 zr9*im#3t264YTc;9XI~sdK?f)+rA}?I8`B0=afl}K;YZDQjTb&2$ErpSU0$lT=}Cfhb9mQDwq)2uy($u*D~f~tjVyZW#cz~p&I3&&M>yuy~gu1#}wMMd`^ zLAubWiYoxDuS$3E1;q_?lr5c1?DFtrN)UL#KG z)awMbbg@-x+AfV8b}M>ZjrekD9L`1f@X%*33KX69k?9lhnB~DPwpUx`?g$>EcPGEp zXO21`V4SNDhYf|ekB}kvxK!f3TgBIrA#7`R{h$n@sieLaNdq%728(EqYwsLd)M+$f z5a3gGUmf#_VT5yRDs06dAYB!OnY#ztvaK8SLhy~7aSE`8kN+V!l_yl+;1z{{lc3F= zFZVD5hbHF9ZSf=^hTFGpJBiM>_pIjND*C*zbMr>8uUg6X<~b^M{6K*w=s*vvxpll= z&+;ulidhnY6lH82yyjl1kD&1 zqVsoQu+G5Y=@^1^l8WY2AeJ`anPX0?4sVWxgDXDTnl6T!#RNoE^I>@wAg(az;ff>f zse8X|bXZZ`QkH8Tt!Z2SGX zllS^l#Q}m}ofcEv$Q~%=Alk{XL5jMBigfxH*60UhTX-d@9UlwU$#z^BgHf)gsxtPL zFt+qS&Qxbsy$4E;)a^8|@P`9y7rPW=%PAP4cn2D#Chv}R93w8=`?>R;qt|7^DVrEt0)n|duM26)fIlmntFu+_y^edKEhBb@$@jnNiA(;ivH_N9SjTQzf`^`8YFB&Xf(T__L z&|K0U@unLirlihA)ZiSYK(PniBxHn&^c6fkNj|2F1JIRT(m8C7UzY0F$UWb-KxN&O z*$BK+Qh{IUWx1S+&pN5<&*FU%WRYo+G;wXpCW5G_b~jc#h`cLIy=*zi}{ zM_yD)ory9N>L+NRW`b&qocA)EawO_>)Wn!UI~I0RYJY(eX5Q7(q$|T0R6R{Kv~ct7 zqz?);SFi%P?HI?#s6!Lsr_Sz^g$!cPG_e*=E41U$(5dV%jp6;~RFM}j7y=gTPEmjh z`*Vcq7z=$K%=^0Pjfu5BN<;QT(}P1KCd-O@*)o-A0NtQkpwZqOQ>|i5MfbIPpjR1RM$ij*IQBeV7n1hx@8J|ga zha}RO)GOznmg>k`<5g_SovwaQf-0iC;Q6ZXG?12}Fp*)mS~X9C7P{5GAZxvkkb?Wo zvp78Bj_1O8zdU!WiYk|=WCBw)!YfTNY!Z>YG|1M8({HI&0yL^#k`G7+HCa_8=`YjA z+6I<8J{}sg>MH5@3d50F*W|g-+{c0&&zRVhZofSqej4FZliDyi4~3wGNhR5x65?Sa zLu}8mtYE`M4AzMeg;rET;`{(z7zZFP|I>h9W6_-Ob|q4{B5C6$5=RCtBISU~h}v-q z9a-`|>ZldXvSRelN(;8Ln)}6Y{Q|Or@|-n{^#4quLHH%Z!!4!_WfC1^K%ITnqwq!w zUGeNYt0csa?%x{lD#g;^^P2cpg?!cgGTAWZ>`a zhiLm*EYEWRt|V#@l4sasWbtTp!q}1JY9o9fOyKV}&;@=-r6tzz#Jug9i#LvE1HRTv z)?E^rsVxF|LUCK&%i}kgRA{E9B{)157X)uG74p=tbmYp?pF;MJJcU+x6ux)fQD4Ee zc0AEHd{}K8Qm2B0N0j8t*nU72>>bX5>F)0I%aDB%D zM`DhaO?oRUMmB^|K3emv@92tWr%%6dyTuKdj>$GB9ZST>>^KdGQavT^4 z>RB&^Kr94AbFpY#I&4+pkjM2w9TuQW2lQW_YbBO#6OK>yZV^!B?d!xM88HB-oQzs& z>)6x1Cn#?xJ%D2E)e5WZYJ$N7nhvf2INC%Evj z>o(O3P@45L&mMd6gzTi7vEoFw(e0BTEZhpYa;e!5klQ&+MBZpC09_M)$!VNc5nq_^ z0;n^J6tb%+87Q=kc98P!V7er6xw+ZTb-23=dM69-?X8AMW+dhMzq!d?0r_fF{er2% zROihzl?g9%s>jhM(EVE@SxubDTM#2)@LA$Pn{B3zb-{y_J1J(xTs=;4*=S*jfG+M6 zs84%&lLB#_GwboT=q0E#RyGI2PR z4pexgb?VmOtG%ab<($6pWW-V=C<5B;iHo0D{?A^ZR#{@*%#94iK|q0{xWl7CzowY_ z*W$6A)vnKrc#R2{n5w=y*e|xx#Mua&V`UM-;6PG%+|hK@WoGZ~z;t6d)fJp0#Mzlm z#X#!V3GuCctJ#_OoUAc9#RlJzV)uG26yOcM21#1Sk}kO_zP31_}78f6NR-Z^tp4-+ydwR5>7+nC0j)s(Z2klXbI0^MrXq*l)a(oJ~fu zQHbXHYljDr8h(fO(cPtaXxQ+HA`w8IS*^fF-0dOXMJ*kI93c35WH3bpy z21J2@))uBI+_41AtluA)Nl+}W4T7|)5C6$ZzCq<)=wuU?j&qoeUth^u>X0i5H$a5{ z(uEh1iy=^14|u`5b3D7s5CO<)VRQxSq%*@AIdK-BVh~kAS0B0%8qGUXi*%kHwd5|6 z!4HPt^bW#}Z;w+Va(vBAX;B3Qv9wK#X0PXv<%JDPdLl7~c7}4hrQSv_`B7;yNC&$E zo+1o|FU+Pp!ghD1oCUXPkTUu#Lm_E8<7gYyW^x!nF6=GCDAt^4Hu)7+->=9*Q#NQl zPK|GK=4zKMht%M{{Zn()_Ffuwx+;i{^rCXuV4pyOB*sh?p3zH92@f(2NcV7K&gX@P zp3(M@Q!nvY2M8GLtZExpF%lRir$aP7sa+FUjWT;av=RP5*R41)q!``YRth8>Nlz_9 zy8EXbF^z81^+zX!Yq?>BZAPU`L$ZkMc_SE3p(Q!R@GY}yQ4lIfMHM;VXH8}z?Ji;f z359!z=M^3%b`+9#W=A@bS-r^1D0A~10MWRaIihWN`C7;MR+1bMI#nS}ZzYTiU{OLT zQ?}BDm5c(P8xG)A9DnICNLW0o-fe2^gLFr5d7`p-i3hfGFy3FESR*a_d0^-vOe2R6 z1vmXi3Ms~{0GrMx{w!Bg($po&>F3M6Jks}hrJ67i-|W8>N*)Ndc0iQc%eT%BVUL2@ zLSD%iwVgc6W&_EZctK&-Ow71j1SW=96Ll?7Mwn`Z=u?S!?_zJFV)^`$o5{MX)_r`? zm|LTUV9u$kqw}c{Fnf%=gb&x_zT(M;CwIX99?~pNkNWov6r?C!#+_6Pek)zUs`s=Y zqyOz;;6*?=hJAW-%M~Sb=h`QwHzTPBikzrMmJtFEGwN|_3CnfWRJ-~CIrlGaj=q&G z)~kDH$iXvyWuW_L1kSV9fp;i;U7!fBZ?FSlfd9Gl4;|pwi9*R_sY^BeT_UfS0Cp0s zgO0{z>$3D>%ju#f^UQ|Z8z+3FHeh10XEWs6>lN`{zf)uhPg62W{*(Ou;7^i}8d)wD z(vQblNHlU_iOG>d=^y=La>P_wif2h%s*^fHMbB_ku2`(^cTyRu=JWQcng@Sh>Sam~ zQ_VqH`O%qI9_n@Um|}WVt47O$aVDot-A;zZXFCB~Q()h1ogGqP&4@+MZg9&?_*2d;BfGe+S$Ww}H;D@HZs)AFn z)Nd#jXu>^m>rKME7?H~=DB?L#BuBD<5KzcoGuf*!%&D@Ldhu*lrIre7Uu-$RcamKH zgYQql{$_Mg1@Ctqai?AgGdAuG^{A&=L@e#7Gl1>g;P!`L?|B$L_0%!CYCpl;Kueib zw}0tp`mNnZh)3F#oIkAnsG+KmIwimjW&IV}(H%KTZNky|jhXNSa`uFx=tWIc2Vbec zx|k_tC7LEPh^c&^Z7EsdFBx%uJdmCqQtr?h-3rmdX@Zl?z&r|tF&--|(bn;w>D_0rO*MsTR7){=fuY7!R8~5d&J5<^;cSovTz{IC=8?pAPavY;^aJjmd~V! z(u5tWx0;1w&N#I+{|%=f?AB>gdna9L8-N?~?zWJ#U9k=3ce>-StqN_w4DA>z^VRXz z%WA3LAGF8X z>k?{tDR8V3y8)-!lXsbIokn1#G>qZ-;I%1Gmf`h3Q!E{-uqdFwe^cxn9gCMDa#+Wn z=(uR|jRbD0i~ZYYk<30A_G~FryK09&xb`$ylcl0;U`X7;DVdc`)?9fmIMVQBQJ9v4 zeoJl9)N;|`e-Sdwn}JoCD@0}%?@4D0s)l&HHQHGoN|0(Ay7SzBV}jF5Qs>R>c_&4T zi7u5ax@0BVQq!g#NdV(*5g~=>3bf}j%4nB|YJC-FnZ^u;LGwl!Bq74v(oohMX6hC7 zKVh^W7!*Hn5K>w;!OBM5)R;ACO=yne45{GEqh@7a8}e%JI)WP^SXt@{kzV7@|NT}W*Ca*ND90z#?XL0IQh zVbI+*Jdt@9{n6Pny1cXO;?G1hgsF5wP>`MYg#hZYEcYU0S%dpptmgwWJ8g_@TL~XmfJ@5W}BWjr9?Jt#T-a`)i0$R9yh#i8R-QHj8 zvffd0QmNBkdY&MtJwiGKOmhNiN%W*(r}#C=^HNGkWFCRRopjX5+KE%SSVR9Igi7C4 z)?IxRo0VNmyL7Q^L_(wE5(Hv<%Ih1JX-NQ+M&Aj*N9?{DZdxt|c2Qc+i0@D}6DBd< zT$KWn4^j4(Yo~|JgSjzLRsoP)ksOh2Jmjj?C3D<=p+l(MdcN|$T;+H3e9rkVq}Syt zs%1Zs68^>-ilDU&Tx_?PJEqyR9*jmgEe+uUF58Y%Mt~`-()l+?__bUE(Zt+xRICK^ z31d9EJ;rf*G}K|C@oY$kh6&slpGkVC0+7i~{p3eW+j zj1@(T-ou*?RYgIol=0zjWEXAk}pGPnfA$n5&gAb4o75-jb$rohThRqbtCd_<( z4P|CoIJQ0Q2UY*ceJvu48u$`zuwrG|&t2hS+KjjTYrR&-S$YPspAS$^(|GM{msj9g zF++F4O^aurEuS7hTV>?0ur90a+r~!+&fYKRvHdn0JG~Y*l&Z_`IOD4Za{Qsk!b9zb zYO>viuIKjoyqfy^MNnIgyi2yM%221zgH+8()WYItI7QrT9 zJ%Q|fy1tQRsthv;N3pJrFV7$42SV;Qiyrsl=jv$vMY^kDjSs_YHPVCi?-6QvHeWTY zH87LEj>f4J1n7^wU@&m5{jkTHY51jq76mg;ohs(%p8+q%vr8b10Wu8D^GFNW!Bwh} zObnCvC#zm(#_rO_zIBK24Y^mFo1PXfPFLGZ#{2>02k(4EbcpdQbJ#fow7`&gA86m=M+^05kH@G^Ggz{$mU}MLRZq#9AD;t z+$ZUBm!((_a}Pl^c(Hl-2id;wnEBW`k?sw6jl#Y`J!e<%oX`?;FI)fx*Ut{nuyPnE zMlF+Ul(S{;kxFL+y1(*e6Ib|+))w}uP2n}H=^>XiKZWUOBOlclE#p-@q5zSG@_;;m zcO`(NF11JZPFUJKIrByPr&H{~bg2SbP$b!VZxioYZ%bUyeOhGk4g37@sb6j}Ezg}M7^RMV;@Au2UCOO~h}y*^!}E`N^u148BnPBk^c zOXwLRz+kJ^lJdV*Btd;dl-W$8$>94zhF-kK+1t#@sEqVT{&M=&KmP=lCuO;7U;{X` z_&4BNb#{csde{LW63JuLPl7gRw4@_JIW4DWNB3xbA5(}2c&qdEdN+b?FS{vrjq2Dz zcE=AGYKpklSGMG_^B`n;wJKwGS~8(;9s&IP&Z1u0QhD)uZ{5?tKW*ZSucYwQTLWv_ z*BLGJqOvcb%~o_B%;t&-r(xXZJsFhMA7+EBwuu8~*VD61_xgzhj!Jb-oYFI`EHNEs z^~hV?6fWxLKMAb|@bD-ef?cQLX-_jHiBDU!IU*|QcbRnfGu4s>#UqtAD!4#X0~6sil7v> z?5`SiApt0=%75f;Fr84%_&`!USv!(2c##>WFL$kMH>WI-Em6aL;0Iyac|vxHT`v5O zf}g{#&<7FC!w5qOzab1htwG1Ik&$obu$r~Xin1ESpirHQ_Gfi6(}LCvBmkQcBo+b0 z%QN_yNJ+o7~c2J z%q{ueEn*f(!j;3$DrQvMz=N$!VKVY!Wu8yGB7gyfrBjqK4Y@)u&;sx=LMxi$X-g!( zM~7CM?b?ZK%Al3?u;@t=B#?2XBC%lvYQSo`V-#MydeDm-80R=Zm_dşna2eB>} zMe!Y};Nv>7__cQ2^F@Wc4SzmYCRcvS<+Q)%w0EpESo1g&=B>9LS!#5gM|>S94H#C0$X{2}>*?qJbJc?mz3 zV`f-pFkFr*Z>H}=J!lJ|SP_`loe%=us-3KV*99;I{)pSsuogdK`!qo!Ft#j-OT3X+ z3rBH#l;ec2-Z>esWU#2p{u|7oJYCD42oQV;DEOL(5))bewf?uBeZPz2OEl~_fD*>5hhc0~2|%Ouesv_f@y39-_vb;cny2WItl*%9I}oHRKJ=8#@<}VWjmE)G zDVy&e4;D#Ov`7|W(KJ_WsLi_h9V!oo^v(UvzCXeV1XL>wOjnB&O5NY0^QDO0RNAz= z+;)miEW#M(wsFA36zwm=7fGa^WJ>pI)cm`N)yS;n31H>bJ+NG6F;>t44b)Dq8ye5I zey11zb*@zh*P79{NQJ@%Pp&&{bj@`=5&-)n+s?YNsi=hSv(7~x{I;-K>HD0j)~Hpn zvj4o)liUD`hIre!JkKSRq!{zVt$qknRho-cU{FcE*blve6fE}%pcQW~?Av*SdFois z%dAwUxTFsobB6Fma;+wYi%U;VZGBWqDAfKH+CS36(s`tX31-$MO~CywG1dYGNwKSC zgN9Bs8vLUBg1Dpp$eM9AanFZ(1s_bh(oFNlfZ(&p3*|WC3j##|+b^vLs z3-IeT9a$3Vs=)ilK5eb-v9+RZ$yBc_h=Wi!yhWO>{~cuiH)@(z8%Zb>`AfqeAlk89 z*^y(OeW^Xl0GwFt(r;8y4luuY!Yf|=%Bk~ILv9fdrR@%9r9*-78mU{Kd zCg&gBhV}k&PMJdc+XRYKPzLYRRt6YwfZ>oV}l3+~&nQ|cJ#aH3kqy9M=4b>&+ z`bfH{$pw^Ly*w?)WQLh{r z^0R!bw~`}1fASupWCcjJVF*v@SL_f+13!U_!8L+U$qET#fC$@_C!)0U`60d8YL3W3 zBbP+)Qi3q*%uSmz&aC{#_o+c6%nwqSIZOo=ks~ahPKI23jH1H5fN8g20TlIyk+3rI zL!e-V{p3CCotSPi{T(&O<`tAmKJvAN&HG)(vXc`9JJ{I8*m*w6P08<3p}+D%6>tOs zHg5i^GoG9tA^T6PFm3*v&&2J*2GQe!i%l|*U26~o_4g;=$R*R?rRcIeJ*2O~lWa{3 zCYe!FKAZJ4Ov~A&K%|=;iS~>D40psQ-T{m9w|yLH6D&hhz(~kW@E4~Z_zuD^ zX;op62Fo-T6g}xE)v-fsiYfWsyUS=7-sli>WL3T zeT#(qE(`p`)YZk0d_qj@rBi^PKt?ecJupS{4)^u`L~pk3FqDR9>^vI=WH@U#q@xvm z7tb>rOt5IA8EzjARoXW13V6&fG$+tEbvE#Mx|yK$kP%4NVl~2JXkxqwDI|xErrt~j z=k+#4>=Yvsr5_pTG|+8|Y2B5GDvQ2=tv}8sx}@Ns$j~1(S8P3iil^L0)BCwiBCe?> z-T@txz1vSF0;_xnrHM5B3mAM9Lco9)`Vv)b#gb$`F&Q_&joDrilAU{w%?D-8XYg3( ziuk@7kd$(Gp_Hs~(lTr^!`{*GqJmjeUVGJ$<+i^8=$nRtUDL5>yLgJ*c0=4VqdGwc zIhiB4l^9?iT1RU*6^I9;zk~KemFk3sPS_(c8Ft=N%b!U41N^TOM4RnuEEulDOR{M) z-gmnP$pxOYZXnrnm_H)0&&&QDdh}s-P*FHWK)+fDPS-YHA70%b!Wd;Yfs&MDNs?FO z&%%%bi2u{g60{J3>>OzJGzPQ=&OrVhX!fuIE-X^o`8WH~uZ?3N#W30I~^ZkKwv0Xh(5+ zOG!G4CV*Txmwsv7rQjtBeLAcAJYWscc;MM>8%Vnq4pu z`u%GCxbr2)lq;rtKx|jl+1N@PMuNuz)D>fm`a+O4)MjYj?*cY0LGCr7wdvLi40l8x y>hQ=aD%~i}M|^ViR$$li00009kr;>o0jik Date: Mon, 7 Apr 2025 18:39:13 -0400 Subject: [PATCH 07/69] docs --- man/combine_columns.Rd | 2 +- man/countPatternRows.Rd | 2 +- man/extractSummaryText.Rd | 2 +- man/extract_info.Rd | 2 +- man/makeLongTree.Rd | 2 +- ...{assignParentIDs.Rd => mapFAMC2parents.Rd} | 10 +- ...ToParentsMapping.Rd => mapFAMS2parents.Rd} | 8 +- man/matchMembers.Rd | 2 +- man/parseRelationships.Rd | 2 +- man/parseTree.Rd | 2 +- man/processParents.Rd | 2 +- man/process_tag.Rd | 35 ++++ man/readGedcom.Rd | 2 +- man/readWikifamilytree.Rd | 13 +- vignettes/ASOIAF.html | 170 +++++++++++------- 15 files changed, 165 insertions(+), 91 deletions(-) rename man/{assignParentIDs.Rd => mapFAMC2parents.Rd} (66%) rename man/{createFamilyToParentsMapping.Rd => mapFAMS2parents.Rd} (67%) create mode 100644 man/process_tag.Rd diff --git a/man/combine_columns.Rd b/man/combine_columns.Rd index 86e6d4f9..43554b0b 100644 --- a/man/combine_columns.Rd +++ b/man/combine_columns.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R +% Please edit documentation in R/readGedcom.R \name{combine_columns} \alias{combine_columns} \title{Combine Columns} diff --git a/man/countPatternRows.Rd b/man/countPatternRows.Rd index edcdda52..f9100912 100644 --- a/man/countPatternRows.Rd +++ b/man/countPatternRows.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R +% Please edit documentation in R/readGedcom.R \name{countPatternRows} \alias{countPatternRows} \title{Check for Pattern Rows} diff --git a/man/extractSummaryText.Rd b/man/extractSummaryText.Rd index ad1e90a9..9b12be26 100644 --- a/man/extractSummaryText.Rd +++ b/man/extractSummaryText.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R +% Please edit documentation in R/readWikifamilytree.R \name{extractSummaryText} \alias{extractSummaryText} \title{Extract Summary Text} diff --git a/man/extract_info.Rd b/man/extract_info.Rd index 0001eb99..3f5bbc1d 100644 --- a/man/extract_info.Rd +++ b/man/extract_info.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R +% Please edit documentation in R/readGedcom.R \name{extract_info} \alias{extract_info} \title{Extract Information from Line} diff --git a/man/makeLongTree.Rd b/man/makeLongTree.Rd index e03db2f9..96d4a514 100644 --- a/man/makeLongTree.Rd +++ b/man/makeLongTree.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R +% Please edit documentation in R/readWikifamilytree.R \name{makeLongTree} \alias{makeLongTree} \title{Make Long Tree} diff --git a/man/assignParentIDs.Rd b/man/mapFAMC2parents.Rd similarity index 66% rename from man/assignParentIDs.Rd rename to man/mapFAMC2parents.Rd index 8bd15170..3ebd6dd7 100644 --- a/man/assignParentIDs.Rd +++ b/man/mapFAMC2parents.Rd @@ -1,17 +1,15 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R -\name{assignParentIDs} -\alias{assignParentIDs} +% Please edit documentation in R/readGedcom.R +\name{mapFAMC2parents} +\alias{mapFAMC2parents} \title{Assign momID and dadID based on family mapping} \usage{ -assignParentIDs(df_temp, family_to_parents, datasource) +mapFAMC2parents(df_temp, family_to_parents) } \arguments{ \item{df_temp}{A data frame containing individual information.} \item{family_to_parents}{A list mapping family IDs to parent IDs.} - -\item{datasource}{A string indicating the data source. Options are "gedcom" and "wiki".} } \value{ A data frame with added momID and dad_ID columns. diff --git a/man/createFamilyToParentsMapping.Rd b/man/mapFAMS2parents.Rd similarity index 67% rename from man/createFamilyToParentsMapping.Rd rename to man/mapFAMS2parents.Rd index 20d8216d..25d5a9f3 100644 --- a/man/createFamilyToParentsMapping.Rd +++ b/man/mapFAMS2parents.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R -\name{createFamilyToParentsMapping} -\alias{createFamilyToParentsMapping} +% Please edit documentation in R/readGedcom.R +\name{mapFAMS2parents} +\alias{mapFAMS2parents} \title{Create a mapping of family IDs to parent IDs} \usage{ -createFamilyToParentsMapping(df_temp, datasource) +mapFAMS2parents(df_temp) } \arguments{ \item{df_temp}{A data frame containing information about individuals.} diff --git a/man/matchMembers.Rd b/man/matchMembers.Rd index e02311af..382c05ec 100644 --- a/man/matchMembers.Rd +++ b/man/matchMembers.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R +% Please edit documentation in R/readWikifamilytree.R \name{matchMembers} \alias{matchMembers} \title{Match Members} diff --git a/man/parseRelationships.Rd b/man/parseRelationships.Rd index a02a5983..24e864b5 100644 --- a/man/parseRelationships.Rd +++ b/man/parseRelationships.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R +% Please edit documentation in R/readWikifamilytree.R \name{parseRelationships} \alias{parseRelationships} \title{infer relationship from tree template} diff --git a/man/parseTree.Rd b/man/parseTree.Rd index e429662c..6982013e 100644 --- a/man/parseTree.Rd +++ b/man/parseTree.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R +% Please edit documentation in R/readWikifamilytree.R \name{parseTree} \alias{parseTree} \title{Parse Tree} diff --git a/man/processParents.Rd b/man/processParents.Rd index e8077472..9aa205a7 100644 --- a/man/processParents.Rd +++ b/man/processParents.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R +% Please edit documentation in R/readGedcom.R \name{processParents} \alias{processParents} \title{Process parents information} diff --git a/man/process_tag.Rd b/man/process_tag.Rd new file mode 100644 index 00000000..14dfa65e --- /dev/null +++ b/man/process_tag.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcom.R +\name{process_tag} +\alias{process_tag} +\title{Process a GEDCOM Tag} +\usage{ +process_tag( + tag, + field_name, + pattern_rows, + line, + vars, + extractor = NULL, + mode = "replace" +) +} +\arguments{ +\item{tag}{The GEDCOM tag (e.g., "SEX", "CAST", etc.).} + +\item{field_name}{The name of the variable to assign to in `vars`.} + +\item{pattern_rows}{Output from `countPatternRows()`.} + +\item{line}{The GEDCOM line to parse.} + +\item{vars}{The current list of variables to update.} +} +\value{ +A list with updated `vars` and a `matched` flag. +} +\description{ +Extracts and assigns a value to a specified field in `vars` if the pattern is present. +Returns both the updated variable list and a flag indicating whether the tag was matched. +} +\keyword{internal} diff --git a/man/readGedcom.Rd b/man/readGedcom.Rd index a5136bc5..09d19040 100644 --- a/man/readGedcom.Rd +++ b/man/readGedcom.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R +% Please edit documentation in R/readGedcom.R \name{readGedcom} \alias{readGedcom} \title{Read a GEDCOM File} diff --git a/man/readWikifamilytree.Rd b/man/readWikifamilytree.Rd index b06acf7b..58a64efd 100644 --- a/man/readWikifamilytree.Rd +++ b/man/readWikifamilytree.Rd @@ -1,13 +1,22 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPedigree.R +% Please edit documentation in R/readWikifamilytree.R \name{readWikifamilytree} \alias{readWikifamilytree} \title{Read Wiki Family Tree} \usage{ -readWikifamilytree(text) +readWikifamilytree(text = NULL, verbose = FALSE, file_path = NULL, ...) } \arguments{ \item{text}{A character string containing the text of a family tree in wiki format.} + +\item{verbose}{A logical value indicating whether to print messages.} + +\item{file_path}{The path to the file containing the family tree.} + +\item{...}{Additional arguments (not used).} +} +\value{ +A list containing the summary, members, structure, and relationships of the family tree. } \description{ Read Wiki Family Tree diff --git a/vignettes/ASOIAF.html b/vignettes/ASOIAF.html index 9b925ee3..7e1f9f05 100644 --- a/vignettes/ASOIAF.html +++ b/vignettes/ASOIAF.html @@ -360,13 +360,13 @@

Load Packages and Data

structure of the built-in ASOIAF pedigree.

 -
## ── Attaching core tidyverse packages ───── tidyverse 2.0.0 ──
+
## ── Attaching core tidyverse packages ─────────────────
 ## ✔ dplyr     1.1.4     ✔ readr     2.1.5
 ## ✔ forcats   1.0.0     ✔ stringr   1.5.1
 ## ✔ ggplot2   3.5.1     ✔ tibble    3.2.1
 ## ✔ lubridate 1.9.4     ✔ tidyr     1.3.1
 ## ✔ purrr     1.0.4     
-## ── Conflicts ─────────────────────── tidyverse_conflicts() ──
+## ── Conflicts ──────────────── tidyverse_conflicts() ──
 ## ✖ dplyr::between()     masks BGmisc::between()
 ## ✖ dplyr::filter()      masks stats::filter()
 ## ✖ dplyr::first()       masks BGmisc::first()
@@ -400,7 +400,7 @@ 
Load Packages and Data

 
library(BGmisc)
 library(tidyverse)

Prepare and Validate Sex Codes

-

Many pedigree-based algorithms rely on valid sex codes for downstream +

Many pedigree-based algorithms rely on biological sex for downstream calculationss and visualization. We use checkSex() to inspect the sex variable, repairing inconsistencies programmatically.

@@ -408,93 +408,125 @@

Prepare and Validate Sex Codes

code_male = 1, code_female = 0, verbose = FALSE, repair = TRUE -)
+)

Compute Relatedness Matrices

-

We now compute the additive genetic relatedness matrix (add) and the -common nuclear relatedness matrix (cn) from the pedigree using ped2com() -and ped2cn(), respectively. The isChild_method argument -specifies how to identify child-parent relationships. We use -“partialparent” to account for missing parent information. The -adjacency_method argument specifies how to construct the -adjacency matrix. We use “direct” for the additive matrix and “indexed” -for the common nuclear matrix. The direct method is much faster. The -sparse argument is set to FALSE to return dense -matrices.

+

With validated pedigree data, we can now compute two distinct +relationship matrices:

+
    +

  • Additive genetic relatedness (add): Proportion of shared additive +genetic variance between individuals.

    • +

  • Common nuclear relatedness (cn): Indicates shared full-sibling +(nuclear family) environments.

    • +
+

These are derived using ped2add() and ped2cn(), respectively. Both +functions rely on internal graph traversal and adjacency structures. In +this case:

+
    +

  • We specify isChild_method = “partialparent” to allow inclusion of +dyads where one parent is unknown.

    • +

  • We choose adjacency_method = “direct” for the additive matrix to +optimize for computational speed.

    • +

  • For the common nuclear matrix, we use adjacency_method = +“indexed”, which is slower but necessary for resolving sibling-group +structures.

    • +

  • We set sparse = FALSE to return full (dense) +matrices rather than compressed sparse formats.

    • +
add <- ped2com(df_got,
   isChild_method = "partialparent",
   component = "additive",
   adjacency_method = "direct",
-  sparse = FALSE
+  sparse = TRUE
 )
 
-cn <- ped2cn(df_got,
+mt <- ped2com(df_got,
   isChild_method = "partialparent",
-  adjacency_method = "indexed",
-  sparse = FALSE
-)
+ component = "mitochondrial", + adjacency_method = "direct", + sparse = TRUE +) + +cn <- ped2cn(df_got, + isChild_method = "partialparent", + adjacency_method = "indexed", + sparse = TRUE +)

Convert to Pairwise Format

-

We convert the component matrices into a long-format table of -pairwise relationships using com2links(). This gives us a -long dataframe where each row represents a pair of individuals and their -relatedness. The function can return the entire matrix or just the lower -triangular part, which is often sufficient for our purposes. We set -writetodisk = FALSE to keep the data in memory.

+

For interpretability, we convert these square matrices into +long-format tables using com2links(). This function returns +a dataframe where each row represents a unique pair of individuals, +including their additive and common nuclear coefficients.

df_links <- com2links(
   writetodisk = FALSE,
-  ad_ped_matrix = add, cn_ped_matrix = cn,
+  ad_ped_matrix = add, cn_ped_matrix = cn, mit_ped_matrix= mt,
   drop_upper_triangular = TRUE
-)# %>%
-#  filter(ID1 != ID2)
+)# %>%
+
## 'as(<dsCMatrix>, "dgCMatrix")' is deprecated.
+## Use 'as(., "generalMatrix")' instead.
+## See help("Deprecated") and help("Matrix-deprecated").
+
#  filter(ID1 != ID2)
+

The function can return the entire matrix or just the lower +triangular part, which is often sufficient for our purposes. Setting +drop_upper_triangular = TRUE ensures we only retain one +entry per dyad, since the matrices are symmetric. We also keep the data +in memory by setting writetodisk = FALSE.

Locate Jon and Daenerys

-

Next, we extract the IDs corresponding to Jon Snow and Daenerys -Targaryen. We use the filter() function to find the rows in -the df_links dataframe where either ID1 or ID2 corresponds -to Jon Snow, and then filter again to find the row where the other ID -corresponds to Daenerys Targaryen.

-
# Find the IDs of Jon Snow and Daenerys Targaryen
-
-jon_id <- df_got %>%
-  filter(name == "Jon Snow") %>%
-  pull(ID)
-
-dany_id <- df_got %>%
-  filter(name == "Daenerys Targaryen") %>%
-  pull(ID)
-

We then filter the pairwise table to retrieve the row containing -their relationship.

-
jon_dany_row <- df_links %>%
-  filter(ID1 == jon_id | ID2 == jon_id) %>%
-  filter(ID1 %in% dany_id| ID2 %in% dany_id)
-
-jon_dany_row
-
##   ID1 ID2     addRel cnuRel
-## 1 206 211 0.31274414      0
-## 2 211 304 0.01953125      0
-

This row contains the additive relatedness coefficient between Jon -and Daenerys, which allows us to assess how closely related they are -genetically. We’d expect to see a value of 0.25 for an Aunt-Nephew -relationship, which is what Jon and Daenerys are in the show. However, -the value is 0.3127441, indicating a more complex relationship.

+

We next identify the rows in the pairwise relatedness table that +correspond to Jon Snow and Daenerys Targaryen. First, we retrieve their +individual IDs:

+
# Find the IDs of Jon Snow and Daenerys Targaryen
+
+jon_id <- df_got %>%
+  filter(name == "Jon Snow") %>%
+  pull(ID)
+
+dany_id <- df_got %>%
+  filter(name == "Daenerys Targaryen") %>%
+  pull(ID)
+

Then we isolate their dyad:

+
jon_dany_row <- df_links %>%
+  filter(ID1 == jon_id | ID2 == jon_id) %>%
+  filter(ID1 %in% dany_id| ID2 %in% dany_id)
+
+jon_dany_row
+
##   ID1 ID2     addRel mitRel cnuRel
+## 1 206 211 0.31274414      0      0
+## 2 211 304 0.01953125      0      0
+

This table contains the additive and nuclear relatedness estimates +for Jon and Daenerys. If the pedigree reflects their canonical +aunt-nephew relationship and is free from inbreeding, we’d expect to see +an additive coefficient close to 0.25. However, the value is 0.3127441, +indicating a more complex relationship.

-

Plotting the Pedigree with incomplete parental information

+

Plotting the Pedigree with Incomplete Parental Information

+

Many real-world and fictional pedigrees contain individuals with +unknown or partially known parentage. In such cases, plotting tools +typically fail unless these gaps are handled. We use +checkParentIDs() to:

+
    +

  • Identify individuals with one known parent and one +missing

    • +

  • Create “phantom” placeholders for the missing parent

    • +
+

-Optionally repair and harmonize parent fields

To facilitate plotting, we check for individuals with one known parent but a missing other. For those cases, we assign a placeholder ID to the missing parent.

-
df_repaired <- checkParentIDs(df_got,addphantoms=TRUE,
-                              repair=TRUE,
-                              parentswithoutrow=FALSE,
-                              repairsex=FALSE
-                              ) %>% mutate(fam=1,
-                                           affected = case_when(ID %in% c(jon_id,dany_id) ~ 1,
-                                                               TRUE ~ 0)
-                              )
+
df_repaired <- checkParentIDs(df_got,addphantoms=TRUE,
+                              repair=TRUE,
+                              parentswithoutrow=FALSE,
+                              repairsex=FALSE
+                              ) %>% mutate(fam=1,
+                                           affected = case_when(ID %in% c(jon_id,dany_id, "365") ~ 1,
+                                                               TRUE ~ 0)
+                              )
## REPAIR IN EARLY ALPHA

This code creates new IDs for individuals with one known parent and a missing other. It checks if either momID or @@ -504,9 +536,9 @@

Plotting the Pedigree with incomplete parental information

Visualize the Pedigree

-
#fixParents(id=df_got$ID, dadid=df_got$dadID, momid=df_got$momID, sex=df_got$sex, missid = NA)
-
-plotPedigree(df_repaired,affected=df_repaired$affected,verbose=FALSE)
+
#fixParents(id=df_got$ID, dadid=df_got$dadID, momid=df_got$momID, sex=df_got$sex, missid = NA)
+
+plotPedigree(df_repaired,affected=df_repaired$affected,verbose=FALSE)

## Did not plot the following people: 85 88 125 142 228 229 258 259 274 275 305 336 357 381 388 405 409 418 420 424 428 451 487
## named list()
From 1d3a2dcb82981d508cf6907cb7bc9444d71aad79 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 7 Apr 2025 19:35:40 -0400 Subject: [PATCH 08/69] styling --- R/checkParents.R | 135 ++++----- R/checkPedigree.R | 6 +- R/convertPedigree.R | 4 +- R/readGedcom.R | 96 +++---- R/readWikifamilytree.R | 27 +- data-raw/df_ASOIAF.R | 2 +- data-raw/df_potter.R | 328 +++++++++++----------- man/checkPedigreeNetwork.Rd | 6 +- man/readGedcom.Rd | 5 +- tests/testthat/test-calculateFamilySize.R | 9 +- tests/testthat/test-checkParents.R | 26 +- tests/testthat/test-convertPedigree.R | 22 +- tests/testthat/test-readPedigrees.R | 11 +- tests/testthat/test-tweakPedigree.R | 2 +- vignettes/ASOIAF.Rmd | 41 ++- vignettes/ASOIAF.html | 36 +-- 16 files changed, 384 insertions(+), 372 deletions(-) diff --git a/R/checkParents.R b/R/checkParents.R index b03a5926..eab8e0ca 100644 --- a/R/checkParents.R +++ b/R/checkParents.R @@ -23,8 +23,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, repairsex = repair, addphantoms = repair, - parentswithoutrow = repair - ) { + parentswithoutrow = repair) { # Standardize column names in the input dataframe ped_og <- ped ped <- standardizeColnames(ped) @@ -74,7 +73,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, cat("All parents are listed in the pedigree.\n") } } - validation_results$missing_parents <- validation_results$single_parents&length(rowless_parents) > 0 + validation_results$missing_parents <- validation_results$single_parents & length(rowless_parents) > 0 if (verbose) { cat("Step 2: Determining the if moms are the same sex and dads are same sex\n") @@ -146,11 +145,13 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, # Are any parents in both momID and dadID? momdad <- intersect(ped$dadID, ped$momID) - if (!is.na(momdad)&&length(momdad) > 0) { + if (!is.na(momdad) && length(momdad) > 0) { validation_results$parents_in_both <- momdad if (verbose) { - cat(paste("Some individuals appear in both momID and dadID roles.\n", - "These individuals are:\n")) + cat(paste( + "Some individuals appear in both momID and dadID roles.\n", + "These individuals are:\n" + )) print(momdad) } } @@ -162,12 +163,12 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, print(validation_results) } return(validation_results) - } else{ - if (verbose) { - cat("Validation Results:\n") - print(validation_results) - cat("Step 3: Attempting to repair missing parents...\n") - } + } else { + if (verbose) { + cat("Validation Results:\n") + print(validation_results) + cat("Step 3: Attempting to repair missing parents...\n") + } cat("REPAIR IN EARLY ALPHA\n") # Initialize a list to track changes made during repair @@ -177,32 +178,32 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, phantom_dads_added = c(), phantom_moms_added = c() ) - if(repairsex){ - # Fix sex of existing parents if wrong - mom_indices <- match(ped$momID, ped$ID) - dad_indices <- match(ped$dadID, ped$ID) + if (repairsex) { + # Fix sex of existing parents if wrong + mom_indices <- match(ped$momID, ped$ID) + dad_indices <- match(ped$dadID, ped$ID) - if (!is.na(validation_results$female_var)) { - corrected_moms <- ped$ID[mom_indices[!is.na(mom_indices)]] - ped$sex[mom_indices[!is.na(mom_indices)]] <- validation_results$female_var - changes$corrected_mom_sex <- corrected_moms - if (verbose && length(corrected_moms) > 0) { - cat("Corrected sex of moms for:", paste(corrected_moms, collapse = ", "), "\n") + if (!is.na(validation_results$female_var)) { + corrected_moms <- ped$ID[mom_indices[!is.na(mom_indices)]] + ped$sex[mom_indices[!is.na(mom_indices)]] <- validation_results$female_var + changes$corrected_mom_sex <- corrected_moms + if (verbose && length(corrected_moms) > 0) { + cat("Corrected sex of moms for:", paste(corrected_moms, collapse = ", "), "\n") + } } - } - if (!is.na(validation_results$male_var)) { - corrected_dads <- ped$ID[dad_indices[!is.na(dad_indices)]] - ped$sex[dad_indices[!is.na(dad_indices)]] <- validation_results$male_var - changes$corrected_dad_sex <- corrected_dads - if (verbose && length(corrected_dads) > 0) { - cat("Corrected sex of dads for:", paste(corrected_dads, collapse = ", "), "\n") + if (!is.na(validation_results$male_var)) { + corrected_dads <- ped$ID[dad_indices[!is.na(dad_indices)]] + ped$sex[dad_indices[!is.na(dad_indices)]] <- validation_results$male_var + changes$corrected_dad_sex <- corrected_dads + if (verbose && length(corrected_dads) > 0) { + cat("Corrected sex of dads for:", paste(corrected_dads, collapse = ", "), "\n") + } } } - } -} -if (addphantoms){ + } + if (addphantoms) { # Generate new IDs newIDbase <- if (is.numeric(ped$ID)) max(ped$ID, na.rm = TRUE) + 1 else paste0("phantom-", seq_len(nrow(ped))) new_entries <- data.frame() @@ -248,47 +249,47 @@ if (addphantoms){ if (verbose && length(changes$phantom_moms_added) > 0) { cat("Added phantom moms for:", paste(changes$phantom_moms_added, collapse = ", "), "\n") } -} + } # add phantom parents - if(parentswithoutrow){ - # Add parents who appear in momID or dadID but are missing from ID - listed_parents <- unique(c(ped$momID, ped$dadID)) - listed_parents <- listed_parents[!is.na(listed_parents)] - - existing_ids <- ped$ID - missing_parents <- setdiff(listed_parents, existing_ids) - - if (length(missing_parents) > 0) { - if (verbose) { - cat("Adding parents who were listed in momID/dadID but missing from ID:\n") - print(missing_parents) - } + if (parentswithoutrow) { + # Add parents who appear in momID or dadID but are missing from ID + listed_parents <- unique(c(ped$momID, ped$dadID)) + listed_parents <- listed_parents[!is.na(listed_parents)] + + existing_ids <- ped$ID + missing_parents <- setdiff(listed_parents, existing_ids) + + if (length(missing_parents) > 0) { + if (verbose) { + cat("Adding parents who were listed in momID/dadID but missing from ID:\n") + print(missing_parents) + } - for (pid in missing_parents) { - role <- unique( - c( - if (pid %in% ped$momID) "mom" else NULL, - if (pid %in% ped$dadID) "dad" else NULL + for (pid in missing_parents) { + role <- unique( + c( + if (pid %in% ped$momID) "mom" else NULL, + if (pid %in% ped$dadID) "dad" else NULL + ) ) - ) - inferred_sex <- if ("mom" %in% role) validation_results$female_var else validation_results$male_var - - new_row <- ped[1, ] - new_row$ID <- pid - new_row$dadID <- NA - new_row$momID <- NA - new_row$sex <- inferred_sex - new_entries <- rbind(new_entries, new_row) + inferred_sex <- if ("mom" %in% role) validation_results$female_var else validation_results$male_var + + new_row <- ped[1, ] + new_row$ID <- pid + new_row$dadID <- NA + new_row$momID <- NA + new_row$sex <- inferred_sex + new_entries <- rbind(new_entries, new_row) + } } - } - ped <- merge(ped, new_entries, all = TRUE) + ped <- merge(ped, new_entries, all = TRUE) } - if (verbose) { - cat("Changes Made:\n") - print(changes) - } - return(ped) + if (verbose) { + cat("Changes Made:\n") + print(changes) + } + return(ped) } #' Repair Parent IDs #' diff --git a/R/checkPedigree.R b/R/checkPedigree.R index 1ebe6afa..3c0af179 100644 --- a/R/checkPedigree.R +++ b/R/checkPedigree.R @@ -13,8 +13,10 @@ #' @return List containing detailed validation results. #' @examples #' \dontrun{ -#' results <- checkPedigreeNetwork(ped, personID = "ID", -#' momID = "momID", dadID = "dadID", verbose = TRUE) +#' results <- checkPedigreeNetwork(ped, +#' personID = "ID", +#' momID = "momID", dadID = "dadID", verbose = TRUE +#' ) #' } #' @export checkPedigreeNetwork <- function(ped, personID = "ID", momID = "momID", dadID = "dadID", verbose = FALSE) { diff --git a/R/convertPedigree.R b/R/convertPedigree.R index 257bc02f..a26f5f3b 100644 --- a/R/convertPedigree.R +++ b/R/convertPedigree.R @@ -212,7 +212,7 @@ ped2com <- function(ped, component, # isPar is the adjacency matrix. 'A' matrix from RAM if (component %in% c("common nuclear")) { Matrix::diag(isPar) <- 1 - if (sparse==FALSE) { + if (sparse == FALSE) { isPar <- as.matrix(isPar) } return(isPar) @@ -330,7 +330,7 @@ ped2com <- function(ped, component, # Assign 1 to all nonzero elements for mitochondrial component } - if (sparse==FALSE) { + if (sparse == FALSE) { r <- as.matrix(r) } if (flatten.diag) { # flattens diagonal if you don't want to deal with inbreeding diff --git a/R/readGedcom.R b/R/readGedcom.R index 1fd039ed..16251cef 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -9,6 +9,7 @@ #' @param combine_cols A logical value indicating whether to combine columns with duplicate values. #' @param verbose A logical value indicating whether to print messages. #' @param skinny A logical value indicating whether to return a skinny data frame. +#' @param ... Additional arguments to be passed to the function. #' @return A data frame containing information about individuals, with the following potential columns: #' - `id`: ID of the individual #' - `momID`: ID of the individual's mother @@ -51,7 +52,8 @@ readGedcom <- function(file_path, add_parents = TRUE, remove_empty_cols = TRUE, combine_cols = TRUE, - skinny = FALSE) { + skinny = FALSE, + ...) { # Checks if (!file.exists(file_path)) stop("File does not exist: ", file_path) if (verbose) { @@ -189,7 +191,7 @@ readGedcom <- function(file_path, # Attribute tags using process_tag() for (tag_field in list( - c("SEX", "sex"), + c("SEX", "sex"), # CAST caste # g7:CAST The name of an individual’s rank or status in society which is sometimes based on racial or religious differences, or differences in wealth, inherited rank, profession, or occupation. @@ -217,7 +219,7 @@ readGedcom <- function(file_path, # NMR number of marriages # g7:NMR The number of times this person has participated in a family as a spouse or parent. - c("NMR", "attribute_marriages"), + c("NMR", "attribute_marriages"), # OCCU occupation # g7:OCCU The type of work or profession of an individual. @@ -237,7 +239,7 @@ readGedcom <- function(file_path, # SSN social security number # g7:SSN A number assigned by the United States Social Security Administration, used for tax identification purposes. It is a type of IDNO. - c("SSN", "attribute_ssn"), + c("SSN", "attribute_ssn"), # TITL title # g7:INDI-TITL A formal designation used by an individual in connection with positions of royalty or other social status, such as Grand Duke. @@ -251,17 +253,19 @@ readGedcom <- function(file_path, # relationship data # g7:INDI-FAMC ## The family in which an individual appears as a child. It is also used with a g7:FAMC-STAT substructure to show individuals who are not children of the family. See FAMILY_RECORD for more details. -result <- process_tag("FAMC", "FAMC", num_rows, tmpv, vars, - extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)"), - mode = "append") + result <- process_tag("FAMC", "FAMC", num_rows, tmpv, vars, + extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)"), + mode = "append" + ) vars <- result$vars if (result$matched) next # FAMS (Family spouse) g7:FAMS # The family in which an individual appears as a partner. See FAMILY_RECORD for more details. result <- process_tag("FAMS", "FAMS", num_rows, tmpv, vars, - extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)"), - mode = "append") + extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)"), + mode = "append" + ) vars <- result$vars if (result$matched) next @@ -347,32 +351,32 @@ result <- process_tag("FAMC", "FAMC", num_rows, tmpv, vars, #' @return A list mapping family IDs to parent IDs. #' @keywords internal mapFAMS2parents <- function(df_temp) { - if (!all(c("FAMS", "sex") %in% colnames(df_temp))) { - warning("The data frame does not contain the necessary columns (FAMS, sex)") - return(NULL) - } - family_to_parents <- list() - for (i in 1:nrow(df_temp)) { - if (!is.na(df_temp$FAMS[i])) { - fams_ids <- unlist(strsplit(df_temp$FAMS[i], ", ")) - for (fams_id in fams_ids) { - if (!is.null(family_to_parents[[fams_id]])) { - if (df_temp$sex[i] == "M") { - family_to_parents[[fams_id]]$father <- df_temp$id[i] - } else if (df_temp$sex[i] == "F") { - family_to_parents[[fams_id]]$mother <- df_temp$id[i] - } - } else { - family_to_parents[[fams_id]] <- list() - if (df_temp$sex[i] == "M") { - family_to_parents[[fams_id]]$father <- df_temp$id[i] - } else if (df_temp$sex[i] == "F") { - family_to_parents[[fams_id]]$mother <- df_temp$id[i] - } + if (!all(c("FAMS", "sex") %in% colnames(df_temp))) { + warning("The data frame does not contain the necessary columns (FAMS, sex)") + return(NULL) + } + family_to_parents <- list() + for (i in 1:nrow(df_temp)) { + if (!is.na(df_temp$FAMS[i])) { + fams_ids <- unlist(strsplit(df_temp$FAMS[i], ", ")) + for (fams_id in fams_ids) { + if (!is.null(family_to_parents[[fams_id]])) { + if (df_temp$sex[i] == "M") { + family_to_parents[[fams_id]]$father <- df_temp$id[i] + } else if (df_temp$sex[i] == "F") { + family_to_parents[[fams_id]]$mother <- df_temp$id[i] + } + } else { + family_to_parents[[fams_id]] <- list() + if (df_temp$sex[i] == "M") { + family_to_parents[[fams_id]]$father <- df_temp$id[i] + } else if (df_temp$sex[i] == "F") { + family_to_parents[[fams_id]]$mother <- df_temp$id[i] } } } } + } return(family_to_parents) } @@ -388,22 +392,22 @@ mapFAMS2parents <- function(df_temp) { mapFAMC2parents <- function(df_temp, family_to_parents) { df_temp$momID <- NA_character_ df_temp$dadID <- NA_character_ - for (i in 1:nrow(df_temp)) { - if (!is.na(df_temp$FAMC[i])) { - famc_ids <- unlist(strsplit(df_temp$FAMC[i], ", ")) - for (famc_id in famc_ids) { - if (!is.null(family_to_parents[[famc_id]])) { - if (!is.null(family_to_parents[[famc_id]]$father)) { - df_temp$dadID[i] <- family_to_parents[[famc_id]]$father - } - if (!is.null(family_to_parents[[famc_id]]$mother)) { - df_temp$momID[i] <- family_to_parents[[famc_id]]$mother - } + for (i in 1:nrow(df_temp)) { + if (!is.na(df_temp$FAMC[i])) { + famc_ids <- unlist(strsplit(df_temp$FAMC[i], ", ")) + for (famc_id in famc_ids) { + if (!is.null(family_to_parents[[famc_id]])) { + if (!is.null(family_to_parents[[famc_id]]$father)) { + df_temp$dadID[i] <- family_to_parents[[famc_id]]$father + } + if (!is.null(family_to_parents[[famc_id]]$mother)) { + df_temp$momID[i] <- family_to_parents[[famc_id]]$mother } } } } - return(df_temp) + } + return(df_temp) } #' Process parents information @@ -545,9 +549,8 @@ process_tag <- function(tag, field_name, pattern_rows, line, vars, count_name <- paste0("num_", tolower(tag), "_rows") matched <- FALSE if (!is.null(pattern_rows[[count_name]]) && - pattern_rows[[count_name]] > 0 && - grepl(paste0(" ", tag), line)) { - + pattern_rows[[count_name]] > 0 && + grepl(paste0(" ", tag), line)) { value <- if (is.null(extractor)) extract_info(line, tag) else extractor(line) if (mode == "append" && !is.na(vars[[field_name]])) { @@ -560,4 +563,3 @@ process_tag <- function(tag, field_name, pattern_rows, line, vars, } return(list(vars = vars, matched = matched)) } - diff --git a/R/readWikifamilytree.R b/R/readWikifamilytree.R index 6d14c41a..fc0a7521 100644 --- a/R/readWikifamilytree.R +++ b/R/readWikifamilytree.R @@ -7,26 +7,25 @@ #' #' @return A list containing the summary, members, structure, and relationships of the family tree. #' @export -readWikifamilytree <- function(text=NULL, verbose = FALSE, file_path = NULL, ...) { +readWikifamilytree <- function(text = NULL, verbose = FALSE, file_path = NULL, ...) { # Checks if (is.null(text) && is.null(file_path)) { stop("Either 'text' or 'file_path' must be provided.") } - # read from file if provided -if (!is.null(file_path)){ + # read from file if provided + if (!is.null(file_path)) { + if (!file.exists(file_path)) stop("File does not exist: ", file_path) - if (!file.exists(file_path)) stop("File does not exist: ", file_path) - - if (verbose) { - print(paste("Reading file:", file_path)) - } - file <- data.frame(X1 = readLines(file_path)) - file_length <- nrow(file) - if (verbose) { - print(paste0("File is ", file_length, " lines long")) + if (verbose) { + print(paste("Reading file:", file_path)) + } + file <- data.frame(X1 = readLines(file_path)) + file_length <- nrow(file) + if (verbose) { + print(paste0("File is ", file_length, " lines long")) + } + text <- paste0(file$X1, collapse = "\n") } - text <- paste0(file$X1, collapse = "\n") -} # Extract summary text summary_text <- extractSummaryText(text) diff --git a/data-raw/df_ASOIAF.R b/data-raw/df_ASOIAF.R index e5cdc112..2874d8a8 100644 --- a/data-raw/df_ASOIAF.R +++ b/data-raw/df_ASOIAF.R @@ -10,7 +10,7 @@ library(BGmisc) ## Create dataframe ASOIAF <- readGedcom("data-raw/ASOIAF.ged") -#ASOIAF <- readGedcom("data-raw/ASOIAF_040725.ged") +# ASOIAF <- readGedcom("data-raw/ASOIAF_040725.ged") df <- ped2fam(ASOIAF, personID = "id") %>% select( diff --git a/data-raw/df_potter.R b/data-raw/df_potter.R index 77c147aa..153df4e4 100644 --- a/data-raw/df_potter.R +++ b/data-raw/df_potter.R @@ -156,18 +156,24 @@ df <- ped2fam(potter_big, personID = "id") %>% -birth_date, -FAMC, -FAMS - ) %>% rename(personID=id) %>% + ) %>% + rename(personID = id) %>% mutate( personID = as.numeric(personID), momID = as.numeric(momID), dadID = as.numeric(dadID), name = str_remove(name, "/") - ) %>% arrange(name) + ) %>% + arrange(name) -potter_clean <- potter %>% arrange(name) %>% mutate(personID = as.numeric(personID)*1000, - momID = as.numeric(momID)*1000, - dadID = as.numeric(dadID)*1000) +potter_clean <- potter %>% + arrange(name) %>% + mutate( + personID = as.numeric(personID) * 1000, + momID = as.numeric(momID) * 1000, + dadID = as.numeric(dadID) * 1000 + ) # merge so that I have all of A and all the Bs that match A @@ -177,166 +183,168 @@ df_clean <- df %>% potter_clean <- potter_clean %>% - mutate(personID = case_match( - personID, - 22000 ~ 15, - 9000 ~ 18, - 6000 ~ 10, - 18000 ~ 29, - 7000 ~ 1, - 17000 ~ 25, - 25000 ~ 27, - 13000 ~ 20, - 19000 ~ 34, - 23000 ~ 16, - 10000 ~ 17, - 14000 ~ 22, - 3000 ~ 8, - 24000 ~ 26, - 1000 ~ 9, - 26000 ~ 30, - 21000 ~ 14, - 11000 ~ 19, - 8000 ~ 13, - 5000 ~ 2, - 15000 ~ 23, - 16000 ~ 24, - 4000 ~ 3, - 2000 ~ -2000, - 101000 ~12, - 102000 ~ 11, - 20000 ~ -20000, - 27000 ~ -27000, - 106000 ~ 32, - 105000 ~ 33, - 29000 ~ 17, - 103000 ~ 7, - 104000 ~ 6, - 12000 ~ 21, - 30000 ~ -30000, - 28000 ~ -28000, - .default = personID - ), dadID = - case_match( - dadID, - 22000 ~ 15, - 9000 ~ 18, - 6000 ~ 10, - 18000 ~ 29, - 7000 ~ 1, - 17000 ~ 25, - 25000 ~ 27, - 13000 ~ 20, - 19000 ~ 34, - 23000 ~ 16, - 10000 ~ 17, - 14000 ~ 22, - 3000 ~ 8, - 24000 ~ 26, - 1000 ~ 9, - 26000 ~ 30, - 21000 ~ 14, - 11000 ~ 19, - 8000 ~ 13, - 5000 ~ 2, - 15000 ~ 23, - 16000 ~ 24, - 4000 ~ 3, - 2000 ~ 2000, - 101000 ~12, - 102000 ~ 11, - 20000 ~ 20000, - 27000 ~ 27000, - 106000 ~ 32, - 105000 ~ 33, - 29000 ~ 17, - 103000 ~ 7, - 104000 ~ 6, - 12000 ~ 21, - 30000 ~ 30000, - 28000 ~ 28000, - .default = dadID - ), momID = - case_match( - momID, - 22000 ~ 15, - 9000 ~ 18, - 6000 ~ 10, - 18000 ~ 29, - 7000 ~ 1, - 17000 ~ 25, - 25000 ~ 27, - 13000 ~ 20, - 19000 ~ 34, - 23000 ~ 16, - 10000 ~ 17, - 14000 ~ 22, - 3000 ~ 8, - 24000 ~ 26, - 1000 ~ 9, - 26000 ~ 30, - 21000 ~ 14, - 11000 ~ 19, - 8000 ~ 13, - 5000 ~ 2, - 15000 ~ 23, - 16000 ~ 24, - 4000 ~ 3, - 2000 ~ 2000, - 101000 ~12, - 102000 ~ 11, - 20000 ~ 20000, - 27000 ~ 27000, - 106000 ~ 32, - 105000 ~ 33, - 29000 ~ 17, - 103000 ~ 7, - 104000 ~ 6, - 12000 ~ 21, - 30000 ~ 30000, - 28000 ~ 28000, - .default = momID - ), spouseID = - case_match( - spouseID, - 22000 ~ 15, - 9000 ~ 18, - 6000 ~ 10, - 18000 ~ 29, - 7000 ~ 1, - 17000 ~ 25, - 25000 ~ 27, - 13000 ~ 20, - 19000 ~ 34, - 23000 ~ 16, - 10000 ~ 17, - 14000 ~ 22, - 3000 ~ 8, + mutate( + personID = case_match( + personID, + 22000 ~ 15, + 9000 ~ 18, + 6000 ~ 10, + 18000 ~ 29, + 7000 ~ 1, + 17000 ~ 25, + 25000 ~ 27, + 13000 ~ 20, + 19000 ~ 34, + 23000 ~ 16, + 10000 ~ 17, + 14000 ~ 22, + 3000 ~ 8, 24000 ~ 26, - 1000 ~ 9, - 26000 ~ 30, + 1000 ~ 9, + 26000 ~ 30, 21000 ~ 14, - 11000 ~ 19, - 8000 ~ 13, + 11000 ~ 19, + 8000 ~ 13, 5000 ~ 2, - 15000 ~ 23, - 16000 ~ 24, + 15000 ~ 23, + 16000 ~ 24, 4000 ~ 3, - 2000 ~ 2000, - 101000 ~12, - 102000 ~ 11, - 20000 ~ 20000, - 27000 ~ 27000, + 2000 ~ -2000, + 101000 ~ 12, + 102000 ~ 11, + 20000 ~ -20000, + 27000 ~ -27000, 106000 ~ 32, - 105000 ~ 33, - 29000 ~ 17, - 103000 ~ 7, - 104000 ~ 6, - 12000 ~ 21, - 30000 ~ 30000, - 28000 ~ 28000, - .default = spouseID - )) + 105000 ~ 33, + 29000 ~ 17, + 103000 ~ 7, + 104000 ~ 6, + 12000 ~ 21, + 30000 ~ -30000, + 28000 ~ -28000, + .default = personID + ), dadID = + case_match( + dadID, + 22000 ~ 15, + 9000 ~ 18, + 6000 ~ 10, + 18000 ~ 29, + 7000 ~ 1, + 17000 ~ 25, + 25000 ~ 27, + 13000 ~ 20, + 19000 ~ 34, + 23000 ~ 16, + 10000 ~ 17, + 14000 ~ 22, + 3000 ~ 8, + 24000 ~ 26, + 1000 ~ 9, + 26000 ~ 30, + 21000 ~ 14, + 11000 ~ 19, + 8000 ~ 13, + 5000 ~ 2, + 15000 ~ 23, + 16000 ~ 24, + 4000 ~ 3, + 2000 ~ 2000, + 101000 ~ 12, + 102000 ~ 11, + 20000 ~ 20000, + 27000 ~ 27000, + 106000 ~ 32, + 105000 ~ 33, + 29000 ~ 17, + 103000 ~ 7, + 104000 ~ 6, + 12000 ~ 21, + 30000 ~ 30000, + 28000 ~ 28000, + .default = dadID + ), momID = + case_match( + momID, + 22000 ~ 15, + 9000 ~ 18, + 6000 ~ 10, + 18000 ~ 29, + 7000 ~ 1, + 17000 ~ 25, + 25000 ~ 27, + 13000 ~ 20, + 19000 ~ 34, + 23000 ~ 16, + 10000 ~ 17, + 14000 ~ 22, + 3000 ~ 8, + 24000 ~ 26, + 1000 ~ 9, + 26000 ~ 30, + 21000 ~ 14, + 11000 ~ 19, + 8000 ~ 13, + 5000 ~ 2, + 15000 ~ 23, + 16000 ~ 24, + 4000 ~ 3, + 2000 ~ 2000, + 101000 ~ 12, + 102000 ~ 11, + 20000 ~ 20000, + 27000 ~ 27000, + 106000 ~ 32, + 105000 ~ 33, + 29000 ~ 17, + 103000 ~ 7, + 104000 ~ 6, + 12000 ~ 21, + 30000 ~ 30000, + 28000 ~ 28000, + .default = momID + ), spouseID = + case_match( + spouseID, + 22000 ~ 15, + 9000 ~ 18, + 6000 ~ 10, + 18000 ~ 29, + 7000 ~ 1, + 17000 ~ 25, + 25000 ~ 27, + 13000 ~ 20, + 19000 ~ 34, + 23000 ~ 16, + 10000 ~ 17, + 14000 ~ 22, + 3000 ~ 8, + 24000 ~ 26, + 1000 ~ 9, + 26000 ~ 30, + 21000 ~ 14, + 11000 ~ 19, + 8000 ~ 13, + 5000 ~ 2, + 15000 ~ 23, + 16000 ~ 24, + 4000 ~ 3, + 2000 ~ 2000, + 101000 ~ 12, + 102000 ~ 11, + 20000 ~ 20000, + 27000 ~ 27000, + 106000 ~ 32, + 105000 ~ 33, + 29000 ~ 17, + 103000 ~ 7, + 104000 ~ 6, + 12000 ~ 21, + 30000 ~ 30000, + 28000 ~ 28000, + .default = spouseID + ) + ) # Left join by name diff --git a/man/checkPedigreeNetwork.Rd b/man/checkPedigreeNetwork.Rd index d6e92749..9b8c8d24 100644 --- a/man/checkPedigreeNetwork.Rd +++ b/man/checkPedigreeNetwork.Rd @@ -33,7 +33,9 @@ Checks for structural issues in pedigree networks, including: } \examples{ \dontrun{ -results <- checkPedigreeNetwork(ped, personID = "ID", -momID = "momID", dadID = "dadID", verbose = TRUE) +results <- checkPedigreeNetwork(ped, + personID = "ID", + momID = "momID", dadID = "dadID", verbose = TRUE +) } } diff --git a/man/readGedcom.Rd b/man/readGedcom.Rd index 09d19040..78d45773 100644 --- a/man/readGedcom.Rd +++ b/man/readGedcom.Rd @@ -10,7 +10,8 @@ readGedcom( add_parents = TRUE, remove_empty_cols = TRUE, combine_cols = TRUE, - skinny = FALSE + skinny = FALSE, + ... ) } \arguments{ @@ -25,6 +26,8 @@ readGedcom( \item{combine_cols}{A logical value indicating whether to combine columns with duplicate values.} \item{skinny}{A logical value indicating whether to return a skinny data frame.} + +\item{...}{Additional arguments to be passed to the function.} } \value{ A data frame containing information about individuals, with the following potential columns: diff --git a/tests/testthat/test-calculateFamilySize.R b/tests/testthat/test-calculateFamilySize.R index b6e32c7d..f648c8fd 100644 --- a/tests/testthat/test-calculateFamilySize.R +++ b/tests/testthat/test-calculateFamilySize.R @@ -65,13 +65,12 @@ test_that("allGens behaves with Ngens", { result <- allGens(kpc = kpc, Ngen = Ngen, marR = marR) - expect_equal(result, 2) + expect_equal(result, 2) Ngen <- 0 - expect_error( allGens(kpc = kpc, Ngen = Ngen, marR = marR)) + expect_error(allGens(kpc = kpc, Ngen = Ngen, marR = marR)) - expect_error(allGens(kpc = kpc, Ngen= NULL, marR = marR)) - expect_error(allGens(kpc = kpc, Ngen= -1, marR = marR)) + expect_error(allGens(kpc = kpc, Ngen = NULL, marR = marR)) + expect_error(allGens(kpc = kpc, Ngen = -1, marR = marR)) }) - diff --git a/tests/testthat/test-checkParents.R b/tests/testthat/test-checkParents.R index 86776577..21660c4b 100644 --- a/tests/testthat/test-checkParents.R +++ b/tests/testthat/test-checkParents.R @@ -1,29 +1,27 @@ # Test Case 1: Validate sex coding without repair test_that("checkParentIDs identifies parent coding correctly in potter dataset", { - results <- checkParentIDs(potter,verbose = TRUE, repair = FALSE) + results <- checkParentIDs(potter, verbose = TRUE, repair = FALSE) expect_false("parents_in_both" %in% names(results)) expect_false(results$single_parents) expect_false(results$missing_parents) expect_true(results$female_moms) expect_true(results$male_dads) - expect_equal(results$female_var,0) - expect_equal(results$male_var,1) - expect_equal(results$mom_sex,0) - expect_equal(results$dad_sex,1) + expect_equal(results$female_var, 0) + expect_equal(results$male_var, 1) + expect_equal(results$mom_sex, 0) + expect_equal(results$dad_sex, 1) }) # Test Case 2: Validate sex coding without repair test_that("checksif single parents found correctly in ASOIAF dataset", { data(ASOIAF) df_asoiaf <- ASOIAF - results <- checkParentIDs(df_asoiaf,verbose = FALSE, repair = FALSE) + results <- checkParentIDs(df_asoiaf, verbose = FALSE, repair = FALSE) expect_true(results$single_parents) - single_dads <- length(df_asoiaf$id[!is.na(df_asoiaf$dadID)&is.na(df_asoiaf$momID)]) - single_moms <- length(df_asoiaf$id[is.na(df_asoiaf$dadID)&!is.na(df_asoiaf$momID)]) - expect_equal(single_moms, length(results$missing_fathers)) - expect_equal(single_dads, length(results$missing_mothers)) - repaired_df <- checkParentIDs(df_asoiaf,verbose = FALSE, repair = TRUE) - expect_equal(nrow(repaired_df), nrow(df_asoiaf)+single_moms+single_dads) - + single_dads <- length(df_asoiaf$id[!is.na(df_asoiaf$dadID) & is.na(df_asoiaf$momID)]) + single_moms <- length(df_asoiaf$id[is.na(df_asoiaf$dadID) & !is.na(df_asoiaf$momID)]) + expect_equal(single_moms, length(results$missing_fathers)) + expect_equal(single_dads, length(results$missing_mothers)) + repaired_df <- checkParentIDs(df_asoiaf, verbose = FALSE, repair = TRUE) + expect_equal(nrow(repaired_df), nrow(df_asoiaf) + single_moms + single_dads) }) - diff --git a/tests/testthat/test-convertPedigree.R b/tests/testthat/test-convertPedigree.R index fb6e06fe..11dfbeca 100644 --- a/tests/testthat/test-convertPedigree.R +++ b/tests/testthat/test-convertPedigree.R @@ -1,7 +1,7 @@ test_that("ped2add produces correct matrix dims, values, and dimnames for hazard", { tolerance <- 1e-10 data(hazard) - add <- ped2add(hazard,sparse = FALSE) + add <- ped2add(hazard, sparse = FALSE) # Check dimension expect_equal(dim(add), c(nrow(hazard), nrow(hazard))) # Check several values @@ -21,7 +21,7 @@ test_that("ped2add produces correct matrix dims, values, and dimnames for hazard test_that("ped2add produces correct matrix dims, values, and dimnames for alternative transpose", { tolerance <- 1e-10 data(hazard) - add <- ped2add(hazard, tcross.alt.crossprod = TRUE,sparse = FALSE) + add <- ped2add(hazard, tcross.alt.crossprod = TRUE, sparse = FALSE) # Check dimension expect_equal(dim(add), c(nrow(hazard), nrow(hazard)), tolerance = tolerance) # Check several values @@ -42,7 +42,7 @@ test_that("ped2add produces correct matrix dims, values, and dimnames for altern test_that("ped2add produces correct matrix dims, values, and dimnames for inbreeding data", { tolerance <- 1e-10 data(inbreeding) - add <- ped2add(inbreeding,sparse = FALSE) + add <- ped2add(inbreeding, sparse = FALSE) # Check dimension expect_equal(dim(add), c(nrow(inbreeding), nrow(inbreeding)), tolerance = tolerance) # Check several values @@ -62,7 +62,7 @@ test_that("ped2add produces correct matrix dims, values, and dimnames for inbree test_that("ped2add produces correct matrix dims, values, and dimnames for inbreeding data with alternative transpose", { tolerance <- 1e-10 data(inbreeding) - add <- ped2add(inbreeding, transpose_method = "star",sparse = FALSE) + add <- ped2add(inbreeding, transpose_method = "star", sparse = FALSE) # Check dimension expect_equal(dim(add), c(nrow(inbreeding), nrow(inbreeding))) # Check several values @@ -81,7 +81,7 @@ test_that("ped2add produces correct matrix dims, values, and dimnames for inbree test_that("ped2add produces correct matrix dims, values, and dimnames for inbreeding data with 2nd alternative transpose", { tolerance <- 1e-10 data(inbreeding) - add <- ped2add(inbreeding, transpose_method = "crossprod",sparse = FALSE) + add <- ped2add(inbreeding, transpose_method = "crossprod", sparse = FALSE) # Check dimension expect_equal(dim(add), c(nrow(inbreeding), nrow(inbreeding))) # Check several values @@ -101,7 +101,7 @@ test_that("ped2add produces correct matrix dims, values, and dimnames for inbree test_that("ped2add flattens diagonal for inbreeding data", { tolerance <- 1e-10 data(inbreeding) - add <- ped2add(inbreeding, flatten.diag = TRUE,sparse = FALSE) + add <- ped2add(inbreeding, flatten.diag = TRUE, sparse = FALSE) # Check dimension expect_equal(dim(add), c(nrow(inbreeding), nrow(inbreeding)), tolerance = tolerance) # Check several values @@ -121,7 +121,7 @@ test_that("ped2mit produces correct matrix dims, values, and dimnames for inbree tolerance <- 1e-10 # Check dimension data(inbreeding) - mit <- ped2mit(inbreeding,sparse = FALSE) + mit <- ped2mit(inbreeding, sparse = FALSE) # Check dimension expect_equal(dim(mit), c(nrow(inbreeding), nrow(inbreeding))) # Check several values @@ -142,7 +142,7 @@ test_that("ped2mit produces correct matrix dims, values, and dimnames for inbree tolerance <- 1e-10 # Check dimension data(inbreeding) - mit <- ped2mit(inbreeding,sparse = FALSE) + mit <- ped2mit(inbreeding, sparse = FALSE) # Check dimension expect_equal(dim(mit), c(nrow(inbreeding), nrow(inbreeding)), tolerance = tolerance) # Check several values @@ -164,7 +164,7 @@ test_that("ped2cn produces correct matrix dims, values, and dimnames", { # Check dimension data(inbreeding) - cn <- ped2cn(inbreeding,sparse = FALSE) + cn <- ped2cn(inbreeding, sparse = FALSE) expect_equal(dim(cn), c( nrow(inbreeding), nrow(inbreeding) @@ -189,7 +189,7 @@ test_that("ped2cn produces correct matrix dims, values, and dimnames", { test_that("ped2ce produces correct matrix dims, values, and dimnames", { tolerance <- 1e-10 data(inbreeding) - ce <- ped2ce(inbreeding,sparse = FALSE) + ce <- ped2ce(inbreeding, sparse = FALSE) expect_equal(dim(ce), c(nrow(inbreeding), nrow(inbreeding)), tolerance = tolerance) # Check several values # expect_true(all(diag(ce) == 1)) @@ -207,7 +207,7 @@ test_that("ped2ce produces correct matrix dims, values, and dimnames", { test_that("ped2add verbose prints updates", { data(hazard) - expect_output(ped2add(hazard, verbose = TRUE,sparse = FALSE), regexp = "Family Size =") + expect_output(ped2add(hazard, verbose = TRUE, sparse = FALSE), regexp = "Family Size =") }) diff --git a/tests/testthat/test-readPedigrees.R b/tests/testthat/test-readPedigrees.R index da87fc25..349b4f30 100644 --- a/tests/testthat/test-readPedigrees.R +++ b/tests/testthat/test-readPedigrees.R @@ -193,12 +193,12 @@ test_that("readWikifamilytree reads a string correctly", { {{familytree | JOE | | ME | | SIS | | | JOE=My brother Joe|ME='''Me!'''|SIS=My little sister}} {{familytree/end}}" - temp_file <- tempfile(fileext = ".txt") + temp_file <- tempfile(fileext = ".txt") writeLines(family_tree_text, temp_file) - result <- readWikifamilytree(text=family_tree_text) - result2 <- readWikifamilytree(file_path=temp_file) + result <- readWikifamilytree(text = family_tree_text) + result2 <- readWikifamilytree(file_path = temp_file) expect_equal( result$summary, @@ -217,8 +217,7 @@ test_that("readWikifamilytree reads a string correctly", { test_that("readWikifamilytree reads a file correctly", { # Create a temporary WikiFamilyTree file for testing # Example usage - family_tree_file_path <- "data-raw/Targaryen tree Dance.txt" #system.file("extdata", "Targaryen tree Dance.txt", package = "BGmisc") - -# result <- readWikifamilytree(file_path=family_tree_file_path) + family_tree_file_path <- "data-raw/Targaryen tree Dance.txt" # system.file("extdata", "Targaryen tree Dance.txt", package = "BGmisc") + # result <- readWikifamilytree(file_path=family_tree_file_path) }) diff --git a/tests/testthat/test-tweakPedigree.R b/tests/testthat/test-tweakPedigree.R index 24f81ff9..0b542e2e 100644 --- a/tests/testthat/test-tweakPedigree.R +++ b/tests/testthat/test-tweakPedigree.R @@ -115,7 +115,7 @@ test_that("makeInbreeding - Inbred mates specified by generation and cousin", { expect_error(makeInbreeding(ped, gen_inbred = gen_inbred, - type_inbred = type_inbred,verbose = TRUE + type_inbred = type_inbred, verbose = TRUE ), regexp = "Cousin inbreedin") }) diff --git a/vignettes/ASOIAF.Rmd b/vignettes/ASOIAF.Rmd index 69d72a76..f9dceaa0 100644 --- a/vignettes/ASOIAF.Rmd +++ b/vignettes/ASOIAF.Rmd @@ -42,7 +42,6 @@ df_got <- checkSex(ASOIAF, code_female = 0, verbose = FALSE, repair = TRUE ) - ``` @@ -94,9 +93,9 @@ For interpretability, we convert these square matrices into long-format tables u ```{r} df_links <- com2links( writetodisk = FALSE, - ad_ped_matrix = add, cn_ped_matrix = cn, mit_ped_matrix= mt, + ad_ped_matrix = add, cn_ped_matrix = cn, mit_ped_matrix = mt, drop_upper_triangular = TRUE -)# %>% +) # %>% # filter(ID1 != ID2) ``` @@ -108,7 +107,6 @@ We next identify the rows in the pairwise relatedness table that correspond to J ```{r} - # Find the IDs of Jon Snow and Daenerys Targaryen jon_id <- df_got %>% @@ -123,12 +121,11 @@ dany_id <- df_got %>% Then we isolate their dyad: ```{r} - jon_dany_row <- df_links %>% filter(ID1 == jon_id | ID2 == jon_id) %>% - filter(ID1 %in% dany_id| ID2 %in% dany_id) + filter(ID1 %in% dany_id | ID2 %in% dany_id) -jon_dany_row +jon_dany_row ``` This table contains the additive and nuclear relatedness estimates for Jon and Daenerys. If the pedigree reflects their canonical aunt-nephew relationship and is free from inbreeding, we’d expect to see an additive coefficient close to 0.25. However, the value is `r jon_dany_row$addRel[1]`, indicating a more complex relationship. @@ -146,18 +143,18 @@ Many real-world and fictional pedigrees contain individuals with unknown or part To facilitate plotting, we check for individuals with one known parent but a missing other. For those cases, we assign a placeholder ID to the missing parent. ```{r} - -df_repaired <- checkParentIDs(df_got,addphantoms=TRUE, - repair=TRUE, - parentswithoutrow=FALSE, - repairsex=FALSE - ) %>% mutate(fam=1, - affected = case_when(ID %in% c(jon_id,dany_id, "365") ~ 1, - TRUE ~ 0) - ) - - - +df_repaired <- checkParentIDs(df_got, + addphantoms = TRUE, + repair = TRUE, + parentswithoutrow = FALSE, + repairsex = FALSE +) %>% mutate( + fam = 1, + affected = case_when( + ID %in% c(jon_id, dany_id, "365") ~ 1, + TRUE ~ 0 + ) +) ``` This code creates new IDs for individuals with one known parent and a missing other. It checks if either `momID` or `dadID` is missing, and if so, it assigns a new ID based on the row number. This allows us to visualize the pedigree even when some parental information is incomplete. @@ -167,9 +164,7 @@ This code creates new IDs for individuals with one known parent and a missing ot ## Visualize the Pedigree ```{r} +# fixParents(id=df_got$ID, dadid=df_got$dadID, momid=df_got$momID, sex=df_got$sex, missid = NA) -#fixParents(id=df_got$ID, dadid=df_got$dadID, momid=df_got$momID, sex=df_got$sex, missid = NA) - -plotPedigree(df_repaired,affected=df_repaired$affected,verbose=FALSE) - +plotPedigree(df_repaired, affected = df_repaired$affected, verbose = FALSE) ``` diff --git a/vignettes/ASOIAF.html b/vignettes/ASOIAF.html index 7e1f9f05..6762cd1f 100644 --- a/vignettes/ASOIAF.html +++ b/vignettes/ASOIAF.html @@ -360,13 +360,13 @@

Load Packages and Data

structure of the built-in ASOIAF pedigree.

library(BGmisc)
 library(tidyverse)
-
## ── Attaching core tidyverse packages ─────────────────
+
## ── Attaching core tidyverse packages ────── tidyverse 2.0.0 ──
 ## ✔ dplyr     1.1.4     ✔ readr     2.1.5
 ## ✔ forcats   1.0.0     ✔ stringr   1.5.1
 ## ✔ ggplot2   3.5.1     ✔ tibble    3.2.1
 ## ✔ lubridate 1.9.4     ✔ tidyr     1.3.1
 ## ✔ purrr     1.0.4     
-## ── Conflicts ──────────────── tidyverse_conflicts() ──
+## ── Conflicts ──────────────────────── tidyverse_conflicts() ──
 ## ✖ dplyr::between()     masks BGmisc::between()
 ## ✖ dplyr::filter()      masks stats::filter()
 ## ✖ dplyr::first()       masks BGmisc::first()
@@ -462,9 +462,9 @@ 
Convert to Pairwise Format

 including their additive and common nuclear coefficients.

 
df_links <- com2links(
   writetodisk = FALSE,
-  ad_ped_matrix = add, cn_ped_matrix = cn, mit_ped_matrix= mt,
+  ad_ped_matrix = add, cn_ped_matrix = cn, mit_ped_matrix = mt,
   drop_upper_triangular = TRUE
-)# %>%

+) # %>%
## 'as(<dsCMatrix>, "dgCMatrix")' is deprecated.
 ## Use 'as(., "generalMatrix")' instead.
 ## See help("Deprecated") and help("Matrix-deprecated").
@@ -492,9 +492,9 @@

Locate Jon and Daenerys

Then we isolate their dyad:

jon_dany_row <- df_links %>%
   filter(ID1 == jon_id | ID2 == jon_id) %>%
-  filter(ID1 %in% dany_id| ID2 %in% dany_id)
+  filter(ID1 %in% dany_id | ID2 %in% dany_id)
 
-jon_dany_row
+jon_dany_row 
##   ID1 ID2     addRel mitRel cnuRel
 ## 1 206 211 0.31274414      0      0
 ## 2 211 304 0.01953125      0      0
@@ -519,14 +519,18 @@

Plotting the Pedigree with Incomplete Parental Information

To facilitate plotting, we check for individuals with one known parent but a missing other. For those cases, we assign a placeholder ID to the missing parent.

-
df_repaired <- checkParentIDs(df_got,addphantoms=TRUE,
-                              repair=TRUE,
-                              parentswithoutrow=FALSE,
-                              repairsex=FALSE
-                              ) %>% mutate(fam=1,
-                                           affected = case_when(ID %in% c(jon_id,dany_id, "365") ~ 1,
-                                                               TRUE ~ 0)
-                              )
+
df_repaired <- checkParentIDs(df_got,
+  addphantoms = TRUE,
+  repair = TRUE,
+  parentswithoutrow = FALSE,
+  repairsex = FALSE
+) %>% mutate(
+  fam = 1,
+  affected = case_when(
+    ID %in% c(jon_id, dany_id, "365") ~ 1,
+    TRUE ~ 0
+  )
+)
## REPAIR IN EARLY ALPHA

This code creates new IDs for individuals with one known parent and a missing other. It checks if either momID or @@ -536,9 +540,9 @@

Plotting the Pedigree with Incomplete Parental Information

Visualize the Pedigree

-
#fixParents(id=df_got$ID, dadid=df_got$dadID, momid=df_got$momID, sex=df_got$sex, missid = NA)
+
# fixParents(id=df_got$ID, dadid=df_got$dadID, momid=df_got$momID, sex=df_got$sex, missid = NA)
 
-plotPedigree(df_repaired,affected=df_repaired$affected,verbose=FALSE)

+plotPedigree(df_repaired, affected = df_repaired$affected, verbose = FALSE)

## Did not plot the following people: 85 88 125 142 228 229 258 259 274 275 305 336 357 381 388 405 409 418 420 424 428 451 487
## named list()
From c3c9c3ba67982528f255d81b92baf3fea4050b20 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 7 Apr 2025 20:50:35 -0400 Subject: [PATCH 09/69] refactor summary subfunctions --- R/buildPedigree.R | 17 +++-- R/computeRelatedness.R | 3 - R/convertPedigree.R | 32 ++++++--- R/makeLinks.R | 63 +++++++++++++---- R/readGedcom.R | 2 + R/summarizePedigree.R | 86 +++++++++++++++++------- data-raw/benchmark.R | 3 +- data-raw/df_ASOIAF.R | 3 +- data-raw/df_inbreeding.R | 2 +- data-raw/df_potter.R | 7 +- man/findBiggest.Rd | 18 +++++ man/findOldest.Rd | 20 ++++++ man/isChild.Rd | 19 ++++++ man/ped2fam.Rd | 3 +- man/ped2maternal.Rd | 2 +- man/summarizeFamilies.Rd | 2 +- man/summarizeMatrilines.Rd | 2 +- man/summarizePatrilines.Rd | 2 +- man/summarizePedigrees.Rd | 2 +- tests/testthat/test-computeRelatedness.R | 10 +++ tests/testthat/test-summarizePedigrees.R | 31 ++++++--- 21 files changed, 250 insertions(+), 79 deletions(-) create mode 100644 man/findBiggest.Rd create mode 100644 man/findOldest.Rd create mode 100644 man/isChild.Rd diff --git a/R/buildPedigree.R b/R/buildPedigree.R index 6a89f94e..3d94ecad 100644 --- a/R/buildPedigree.R +++ b/R/buildPedigree.R @@ -1,6 +1,7 @@ #' Segment Pedigree into Extended Families #' -#' This function adds an extended family ID variable to a pedigree by segmenting that dataset into independent extended families +#' This function adds an extended family ID variable to a pedigree by segmenting +#' that dataset into independent extended families #' using the weakly connected components algorithm. #' #' @@ -86,7 +87,8 @@ ped2graph <- function(ped, adjacent = c("parents", "mothers", "fathers"), ...) { # Check ped/data.fram - if (!inherits(ped, "data.frame")) stop("ped should be a data.frame or inherit to a data.frame") + if (!inherits(ped, "data.frame")) { + stop("ped should be a data.frame or inherit to a data.frame")} # Handle adjacent argument adjacent <- match.arg(tolower(adjacent)[1], choices = c( @@ -165,7 +167,7 @@ ped2graph <- function(ped, #' Add a maternal line ID variable to a pedigree #' @inheritParams ped2fam -#' @param matID Character. Maternal line ID variable to be created and added to the pedigree +#' @param matID Character. Maternal line ID variable to be created and added to the pedigree #' @details #' Under various scenarios it is useful to know which people in a pedigree #' belong to the same maternal lines. This function first turns a pedigree @@ -177,9 +179,11 @@ ped2graph <- function(ped, #' @export #' ped2maternal <- function(ped, personID = "ID", - momID = "momID", dadID = "dadID", matID = "matID", ...) { + momID = "momID", dadID = "dadID", + matID = "matID", ...) { # Call to wrapper function - .ped2id(ped = ped, personID = personID, momID = momID, dadID = dadID, famID = matID, type = "mothers") + .ped2id(ped = ped, personID = personID, momID = momID, + dadID = dadID, famID = matID, type = "mothers") } #' Add a paternal line ID variable to a pedigree @@ -199,5 +203,6 @@ ped2paternal <- function(ped, personID = "ID", momID = "momID", dadID = "dadID", patID = "patID", ...) { # Call to wrapper function - .ped2id(ped = ped, personID = personID, momID = momID, dadID = dadID, famID = patID, type = "fathers") + .ped2id(ped = ped, personID = personID, momID = momID, + dadID = dadID, famID = patID, type = "fathers") } diff --git a/R/computeRelatedness.R b/R/computeRelatedness.R index 2533c16f..e3f53b8b 100644 --- a/R/computeRelatedness.R +++ b/R/computeRelatedness.R @@ -133,7 +133,6 @@ calculateH <- function(r1, r2, obsR1, obsR2) { message("Your scale might be reverse coded because you have negative correlations. Please check your data. ") } - # Calculate heritability estimates (H^2) for all pairs heritability_estimates <- (obsR1 - obsR2) / (r1 - r2) @@ -145,7 +144,5 @@ calculateH <- function(r1, r2, obsR1, obsR2) { if (any(heritability_estimates > 1)) { warning("Some calculated heritability values are greater than 1, which may suggest overestimation or errors in the observed correlations or relatedness coefficients.") } - - return(heritability_estimates) } diff --git a/R/convertPedigree.R b/R/convertPedigree.R index a26f5f3b..0f454acc 100644 --- a/R/convertPedigree.R +++ b/R/convertPedigree.R @@ -95,7 +95,7 @@ ped2com <- function(ped, component, # standardize colnames if (standardize.colnames) { - ped <- standardizeColnames(ped) + ped <- standardizeColnames(ped, verbose = verbose) } # Load final result if computation was completed @@ -224,15 +224,8 @@ ped2com <- function(ped, component, } else { # isChild is the 'S' matrix from RAM - if (isChild_method == "partialparent") { - isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) { - .5 + .25 * sum(is.na(x)) # 2 parents -> .5, 1 parent -> .75, 0 parents -> 1 - }) - } else { - isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) { - 2^(-!all(is.na(x))) - }) - } + isChild <- isChild(isChild_method=isChild_method, ped=ped) + if (saveable) { saveRDS(isChild, file = checkpoint_files$isChild) } @@ -723,3 +716,22 @@ compute_parent_adjacency <- function(ped, component, } return(list_of_adjacency) } + + +#' Determine isChild Status, isChild is the 'S' matrix from RAM +#' @param isChild_method method to determine isChild status +#' @param ped pedigree data frame +#' @return isChild 'S' matrix +#' + +isChild <- function(isChild_method, ped) { + if (isChild_method == "partialparent") { + isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) { + .5 + .25 * sum(is.na(x)) # 2 parents -> .5, 1 parent -> .75, 0 parents -> 1 + }) + } else { + isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) { + 2^(-!all(is.na(x))) + }) + } +} diff --git a/R/makeLinks.R b/R/makeLinks.R index 9517b533..fe40bc59 100644 --- a/R/makeLinks.R +++ b/R/makeLinks.R @@ -508,6 +508,44 @@ com2links <- function( # return(NULL) } } else if (legacy) { + # --- Legacy Mode --- + # In legacy mode, convert matrices to the expected symmetric formats. + + com2links.legacy( + rel_pairs_file = rel_pairs_file, + ad_ped_matrix = ad_ped_matrix, + mit_ped_matrix = mit_ped_matrix, + cn_ped_matrix = cn_ped_matrix, + update_rate = update_rate, + verbose = verbose, + outcome_name = outcome_name + ) + return(NULL) + } + + # --- End of Legacy Mode --- + + # Merge and write the parentage matrices + # df <- full_join(mat_ped_matrix %>% arrange(ID), pat_ped_matrix %>% arrange(ID)) + + # write.table(df, file = mapa_id_file, sep = ",", append = FALSE, row.names = FALSE) +} + +#' @title com2links +#' @description +#' This legacy function converts pedigree matrices into a related pairs file. + + +com2links.legacy <- function( + rel_pairs_file = "dataRelatedPairs.csv", + ad_ped_matrix = NULL, + mit_ped_matrix = mt_ped_matrix, + mt_ped_matrix = NULL, + cn_ped_matrix = NULL, + update_rate = 500, + verbose = FALSE, + outcome_name = "data", + ...) { # --- Legacy Mode --- if (verbose) { message("Using legacy mode") @@ -536,8 +574,12 @@ com2links <- function( fname <- paste0(outcome_name, "_dataBiggestRelatedPairsTake2.csv") } # Initialize the output file with headers. - ds <- data.frame(ID1 = numeric(0), ID2 = numeric(0), addRel = numeric(0), mitRel = numeric(0), cnuRel = numeric(0)) - utils::write.table(ds, file = fname, sep = ",", append = FALSE, row.names = FALSE) + ds <- data.frame(ID1 = numeric(0), ID2 = numeric(0), + addRel = numeric(0), + mitRel = numeric(0), cnuRel = numeric(0)) + + utils::write.table(ds, file = fname, sep = ",", + append = FALSE, row.names = FALSE) # Extract IDs from the common nuclear matrix. ids <- as.numeric(dimnames(biggestCnPed)[[1]]) @@ -587,7 +629,8 @@ com2links <- function( # browser() if (cond1 || cond2 || cond3) { ID1 <- ids[u] - tds <- data.frame(ID1 = ID1, ID2 = ID2, addRel = 0, mitRel = 0, cnuRel = 0) + tds <- data.frame(ID1 = ID1, ID2 = ID2, + addRel = 0, mitRel = 0, cnuRel = 0) if (cond1) { tds$addRel[u %in% iss1vv] <- biggestPed@x[vv1] } @@ -597,18 +640,12 @@ com2links <- function( if (cond3) { tds$cnuRel[u %in% iss3vv] <- biggestCnPed@x[vv3] } - utils::write.table(tds, file = fname, row.names = FALSE, col.names = FALSE, append = TRUE, sep = ",") + utils::write.table(tds, file = fname, row.names = FALSE, + col.names = FALSE, append = TRUE, sep = ",") } - if (!(j %% 500)) { + if (!(j %% update_rate)) { cat(paste0("Done with ", j, " of ", nc, "\n")) } } + return(NULL) } - - - - # Merge and write the parentage matrices - # df <- full_join(mat_ped_matrix %>% arrange(ID), pat_ped_matrix %>% arrange(ID)) - - # write.table(df, file = mapa_id_file, sep = ",", append = FALSE, row.names = FALSE) -} diff --git a/R/readGedcom.R b/R/readGedcom.R index 16251cef..d6858e58 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -350,6 +350,7 @@ readGedcom <- function(file_path, #' @param df_temp A data frame containing information about individuals. #' @return A list mapping family IDs to parent IDs. #' @keywords internal +#' mapFAMS2parents <- function(df_temp) { if (!all(c("FAMS", "sex") %in% colnames(df_temp))) { warning("The data frame does not contain the necessary columns (FAMS, sex)") @@ -544,6 +545,7 @@ countPatternRows <- function(file) { #' @param vars The current list of variables to update. #' @return A list with updated `vars` and a `matched` flag. #' @keywords internal +#' process_tag <- function(tag, field_name, pattern_rows, line, vars, extractor = NULL, mode = "replace") { count_name <- paste0("num_", tolower(tag), "_rows") diff --git a/R/summarizePedigree.R b/R/summarizePedigree.R index 1fbd06ac..11a3e7e4 100644 --- a/R/summarizePedigree.R +++ b/R/summarizePedigree.R @@ -104,14 +104,13 @@ summarizePedigrees <- function(ped, famID = "famID", personID = "ID", if (network_checks) { if (verbose) message("Performing network validation checks...") - network_validation_results <- checkPedigreeNetwork( + output$network_validation <- checkPedigreeNetwork( ped, personID = personID, momID = momID, dadID = dadID, verbose = verbose ) - output$network_validation <- network_validation_results } # Calculate summary statistics for families, maternal lines, and paternal lines @@ -191,50 +190,59 @@ summarizePedigrees <- function(ped, famID = "famID", personID = "ID", # repair = FALSE, verbose = verbose) # } - - # Optionally find the superlative lines - # & noldest <= unique(ped_dt[[famID]]) - # determin number of lines - - ## oldest if (!is.null(byr) && noldest > 0) { if (!is.null(n_families) && "families" %in% type) { if (verbose) message("Finding oldest families...") - output$oldest_families <- try_na(family_summary_dt[order(get(byr))][1:min(c(noldest, n_families), - na.rm = TRUE - )]) + output$oldest_families <- findOldest( + foo_summary_dt = family_summary_dt, + byr = byr, + noldest = noldest, + n_foo = n_families + ) } if (!is.null(n_mothers) && "mothers" %in% type) { if (verbose) message("Finding oldest maternal lines...") - output$oldest_maternal <- try_na(maternal_summary_dt[order(get(byr))][1:min(c(noldest, n_mothers), - na.rm = TRUE - )]) + output$oldest_maternal <- findOldest( + foo_summary_dt = maternal_summary_dt, + byr = byr, + noldest = noldest, + n_foo = n_mothers + ) } if (!is.null(n_fathers) && "fathers" %in% type) { if (verbose) message("Finding oldest paternal lines...") - output$oldest_paternal <- try_na(paternal_summary_dt[order(get(byr))][1:min(c(noldest, n_fathers), - na.rm = TRUE - )]) + output$oldest_paternal <- findOldest( + foo_summary_dt = paternal_summary_dt, + byr = byr, + noldest = noldest, + n_foo = n_fathers + ) } } # biggest lines if (!is.null(nbiggest) && nbiggest > 0) { if (!is.null(n_families) && "families" %in% type) { - output$biggest_families <- try_na(family_summary_dt[order(-get("count"))][1:min(c(nbiggest, n_families), - na.rm = TRUE - )]) + output$biggest_families <- findBiggest( + foo_summary_dt = family_summary_dt, + nbiggest = nbiggest, + n_foo = n_families + ) } if (!is.null(n_mothers) && "mothers" %in% type) { - output$biggest_maternal <- try_na(maternal_summary_dt[order(-get("count"))][1:min(c(nbiggest, n_mothers), - na.rm = TRUE - )]) + output$biggest_maternal <- findBiggest( + foo_summary_dt = maternal_summary_dt, + nbiggest = nbiggest, + n_foo = n_mothers + ) } if (!is.null(n_fathers) && "fathers" %in% type) { - output$biggest_paternal <- try_na(paternal_summary_dt[order(-get("count"))][1:min(c(nbiggest, n_fathers), - na.rm = TRUE - )]) + output$biggest_paternal <- findBiggest( + foo_summary_dt = paternal_summary_dt, + nbiggest = nbiggest, + n_foo = n_fathers + ) } } @@ -385,3 +393,29 @@ summarizeFamilies <- function(ped, famID = "famID", personID = "ID", founder_sort_var = founder_sort_var ) } +# Function to find the oldest individuals in a pedigree +#' This function finds the oldest families in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function. +#' @inheritParams summarizePedigrees +#' @param foo_summary_dt A data.table containing the summary statistics. +#' @param n_foo An integer specifying the number of individuals in the summary. +#' @returns a data.table containing the oldest families in the pedigree. + +findOldest <- function(foo_summary_dt, byr, noldest, n_foo) { + oldest_foo <- try_na(foo_summary_dt[order(get(byr))][1:min(c(noldest, n_foo), + na.rm = TRUE + )]) + return(oldest_foo) +} + +# Function to find the biggest families in a pedigree +#' This function finds the biggest families in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function. +#' @inheritParams findOldest +#' @returns a data.table containing the biggest families in the pedigree. + + +findBiggest <- function(foo_summary_dt, nbiggest, n_foo) { + biggest_foo <- try_na(foo_summary_dt[order(-get("count"))][1:min(c(nbiggest, n_foo), + na.rm = TRUE + )]) + return(biggest_foo) +} diff --git a/data-raw/benchmark.R b/data-raw/benchmark.R index 80d6db40..8c4c90b5 100644 --- a/data-raw/benchmark.R +++ b/data-raw/benchmark.R @@ -59,4 +59,5 @@ benchmark_results <- microbenchmark( print(benchmark_results) # Optional: Save results to CSV for later analysis -write.csv(summary(benchmark_results), "benchmark_results.csv", row.names = FALSE) +write.csv(summary(benchmark_results), + "benchmark_results.csv", row.names = FALSE) diff --git a/data-raw/df_ASOIAF.R b/data-raw/df_ASOIAF.R index 2874d8a8..9741d04f 100644 --- a/data-raw/df_ASOIAF.R +++ b/data-raw/df_ASOIAF.R @@ -29,7 +29,8 @@ df <- ped2fam(ASOIAF, personID = "id") %>% name = str_remove(name, "/") ) -# pedADD <- ped2com(df , personID = "id", momID = "momID", dadID = "dadID", component = "additive", isChild_method = "partial_parent") +# pedADD <- ped2com(df , personID = "id", momID = "momID", +# dadID = "dadID", component = "additive", isChild_method = "partial_parent") # com2links(ad_ped_matrix=pedADD) # if missing momID or dadID, assign the next available ID diff --git a/data-raw/df_inbreeding.R b/data-raw/df_inbreeding.R index 4419baef..9af10ff0 100644 --- a/data-raw/df_inbreeding.R +++ b/data-raw/df_inbreeding.R @@ -8,5 +8,5 @@ inbreeding <- raw ## # data processing -write.csv(inbreeding, "data-raw/inbreeding.csv", row.names = FALSE) +#write.csv(inbreeding, "data-raw/inbreeding.csv", row.names = FALSE) usethis::use_data(inbreeding, overwrite = TRUE, compress = "xz") diff --git a/data-raw/df_potter.R b/data-raw/df_potter.R index 153df4e4..aa039c81 100644 --- a/data-raw/df_potter.R +++ b/data-raw/df_potter.R @@ -45,7 +45,9 @@ potter <- data.frame( "Molly Weasley", "Lucy Weasley" ), - gen = c(1, 1, 1, 1, 1, 2, 2, 2, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3), + gen = c(1, 1, 1, 1, 1, 2, 2, 2, 1, 1, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3), momID = c( 101, 101, 103, 103, NA, 3, 4, 10, NA, NA, 10, 10, 10, 10, 10, 10, NA, 105, 105, NA, @@ -137,7 +139,8 @@ potter[nrow(potter) + 1, ] <- list( 0 ) -# potter[nrow(potter) + 1,] <- list(personID,fam,name,gen,momID,dadID,spouseID,sex) +# potter[nrow(potter) + 1,] <- list(personID,fam,name,gen, +# momID,dadID,spouseID,sex) write_csv(potter, here("data-raw", "potter.csv")) usethis::use_data(potter, overwrite = TRUE, compress = "xz") diff --git a/man/findBiggest.Rd b/man/findBiggest.Rd new file mode 100644 index 00000000..82d58e70 --- /dev/null +++ b/man/findBiggest.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summarizePedigree.R +\name{findBiggest} +\alias{findBiggest} +\title{This function finds the biggest families in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function.} +\usage{ +findBiggest(foo_summary_dt, nbiggest, n_foo) +} +\arguments{ +\item{foo_summary_dt}{A data.table containing the summary statistics.} + +\item{nbiggest}{An integer specifying the number of biggest families to find.} + +\item{n_foo}{An integer specifying the number of individuals in the summary.} +} +\description{ +This function finds the biggest families in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function. +} diff --git a/man/findOldest.Rd b/man/findOldest.Rd new file mode 100644 index 00000000..8b5caf27 --- /dev/null +++ b/man/findOldest.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summarizePedigree.R +\name{findOldest} +\alias{findOldest} +\title{This function finds the oldest families in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function.} +\usage{ +findOldest(foo_summary_dt, byr, noldest, n_foo) +} +\arguments{ +\item{foo_summary_dt}{A data.table containing the summary statistics.} + +\item{byr}{Character. Optional column name for birth year. Used to determine the oldest lineages.} + +\item{noldest}{Integer. Number of oldest lineages to return (sorted by birth year).} + +\item{n_foo}{An integer specifying the number of individuals in the summary.} +} +\description{ +This function finds the oldest families in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function. +} diff --git a/man/isChild.Rd b/man/isChild.Rd new file mode 100644 index 00000000..1bd6f1e9 --- /dev/null +++ b/man/isChild.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/convertPedigree.R +\name{isChild} +\alias{isChild} +\title{Determine isChild Status, isChild is the 'S' matrix from RAM} +\usage{ +isChild(isChild_method, ped) +} +\arguments{ +\item{isChild_method}{method to determine isChild status} + +\item{ped}{pedigree data frame} +} +\value{ +isChild 'S' matrix +} +\description{ +Determine isChild Status, isChild is the 'S' matrix from RAM +} diff --git a/man/ped2fam.Rd b/man/ped2fam.Rd index 4dbc9aa5..2ff7eb0d 100644 --- a/man/ped2fam.Rd +++ b/man/ped2fam.Rd @@ -30,7 +30,8 @@ ped2fam( A pedigree dataset with one additional column for the newly created extended family ID } \description{ -This function adds an extended family ID variable to a pedigree by segmenting that dataset into independent extended families +This function adds an extended family ID variable to a pedigree by segmenting +that dataset into independent extended families using the weakly connected components algorithm. } \details{ diff --git a/man/ped2maternal.Rd b/man/ped2maternal.Rd index 88106fb6..e54c3e76 100755 --- a/man/ped2maternal.Rd +++ b/man/ped2maternal.Rd @@ -22,7 +22,7 @@ ped2maternal( \item{dadID}{character. Name of the column in ped for the father ID variable} -\item{matID}{Character. Maternal line ID variable to be created and added to the pedigree} +\item{matID}{Character. Maternal line ID variable to be created and added to the pedigree} \item{...}{additional arguments to be passed to \code{\link{ped2com}}} } diff --git a/man/summarizeFamilies.Rd b/man/summarizeFamilies.Rd index 54fc978d..8903eb93 100644 --- a/man/summarizeFamilies.Rd +++ b/man/summarizeFamilies.Rd @@ -33,7 +33,7 @@ summarizeFamilies( \item{dadID}{character. Name of the column in ped for the father ID variable} -\item{matID}{Character. Maternal line ID variable to be created and added to the pedigree} +\item{matID}{Character. Maternal line ID variable to be created and added to the pedigree} \item{patID}{Character. Paternal line ID variable to be created and added to the pedigree} diff --git a/man/summarizeMatrilines.Rd b/man/summarizeMatrilines.Rd index 1930858a..2890b622 100644 --- a/man/summarizeMatrilines.Rd +++ b/man/summarizeMatrilines.Rd @@ -33,7 +33,7 @@ summarizeMatrilines( \item{dadID}{character. Name of the column in ped for the father ID variable} -\item{matID}{Character. Maternal line ID variable to be created and added to the pedigree} +\item{matID}{Character. Maternal line ID variable to be created and added to the pedigree} \item{patID}{Character. Paternal line ID variable to be created and added to the pedigree} diff --git a/man/summarizePatrilines.Rd b/man/summarizePatrilines.Rd index 846b0e4b..aed89bcd 100644 --- a/man/summarizePatrilines.Rd +++ b/man/summarizePatrilines.Rd @@ -33,7 +33,7 @@ summarizePatrilines( \item{dadID}{character. Name of the column in ped for the father ID variable} -\item{matID}{Character. Maternal line ID variable to be created and added to the pedigree} +\item{matID}{Character. Maternal line ID variable to be created and added to the pedigree} \item{patID}{Character. Paternal line ID variable to be created and added to the pedigree} diff --git a/man/summarizePedigrees.Rd b/man/summarizePedigrees.Rd index 1a076fdc..b298d326 100644 --- a/man/summarizePedigrees.Rd +++ b/man/summarizePedigrees.Rd @@ -35,7 +35,7 @@ summarizePedigrees( \item{dadID}{character. Name of the column in ped for the father ID variable} -\item{matID}{Character. Maternal line ID variable to be created and added to the pedigree} +\item{matID}{Character. Maternal line ID variable to be created and added to the pedigree} \item{patID}{Character. Paternal line ID variable to be created and added to the pedigree} diff --git a/tests/testthat/test-computeRelatedness.R b/tests/testthat/test-computeRelatedness.R index 10b0de29..05fb7e62 100644 --- a/tests/testthat/test-computeRelatedness.R +++ b/tests/testthat/test-computeRelatedness.R @@ -25,6 +25,15 @@ test_that("calculateRelatedness function with empirical", { }) +# Test 7: empirical divide by zero + +test_that("calculateH handles divide by zero for empirical", { +expect_error( + calculateRelatedness(generations = 2, + empirical = TRUE, total_a = 0, + total_m = 0)) + +}) test_that("inferRelatedness performs as expected", { result <- inferRelatedness(0, aceA = .9, aceC = 0, sharedC = 0) expect_equal(result, 0) @@ -96,3 +105,4 @@ test_that("calculateH stops for illegal coefficients", { "The observed correlations should be between -1 and 1" ) }) + diff --git a/tests/testthat/test-summarizePedigrees.R b/tests/testthat/test-summarizePedigrees.R index 13cb46e0..61dae665 100644 --- a/tests/testthat/test-summarizePedigrees.R +++ b/tests/testthat/test-summarizePedigrees.R @@ -51,17 +51,22 @@ test_that("summarizeFamilies() works with additional summary stats", { # Test Case 4: Does this function work for summarizeMatrilines test_that("summarizeMatrilines() works", { nbiggest <- 2 - df <- ped2fam(potter, famID = "newFamID", personID = "personID") %>% ped2maternal(personID = "personID") - df_summarized <- summarizeMatrilines(df, famID = "newFamID", personID = "personID", nbiggest = nbiggest) + df <- ped2fam(potter, famID = "newFamID", personID = "personID") %>% + ped2maternal(personID = "personID") + df_summarized <- summarizeMatrilines(df, famID = "newFamID", + personID = "personID", + nbiggest = nbiggest) # is the total count from the family summary the same as the raw data? result_observed <- sum(df_summarized$maternal_summary$count) result_expected <- nrow(potter) expect_equal(result_observed, result_expected) - # is the count of the summarized data frame equal to the number of unique families in the input data frame? + # is the count of the summarized data frame equal to the number of + # unique families in the input data frame? result_observed <- length(df_summarized$maternal_summary$count) result_expected <- length(unique(df$matID)) expect_equal(result_observed, result_expected) - # is the count of the biggest families equal to the number of unique families in the input data frame? + # is the count of the biggest families equal to the number of + # unique families in the input data frame? result_observed <- nrow(df_summarized$biggest_maternal) expect_equal(result_observed, nbiggest) }) @@ -69,17 +74,22 @@ test_that("summarizeMatrilines() works", { # Test Case 5: Does this function work for summarizePatrilines test_that("summarizePatrilines() works", { nbiggest <- 4 - df <- ped2fam(potter, famID = "newFamID", personID = "personID") %>% ped2paternal(personID = "personID") - df_summarized <- summarizePatrilines(df, famID = "newFamID", personID = "personID", nbiggest = nbiggest) + df <- ped2fam(potter, famID = "newFamID", personID = "personID") %>% + ped2paternal(personID = "personID") + df_summarized <- summarizePatrilines(df, famID = "newFamID", + personID = "personID", + nbiggest = nbiggest) # is the total count from the family summary the same as the raw data? result_observed <- sum(df_summarized$paternal_summary$count) result_expected <- nrow(potter) expect_equal(result_observed, result_expected) - # is the count of the summarized data frame equal to the number of unique families in the input data frame? + # is the count of the summarized data frame equal to the number of + # unique families in the input data frame? result_observed <- length(df_summarized$paternal_summary$count) result_expected <- length(unique(df$patID)) expect_equal(result_observed, result_expected) - # is the count of the biggest families equal to the number of unique families in the input data frame? + # is the count of the biggest families equal to the number of + # unique families in the input data frame? result_observed <- nrow(df_summarized$biggest_paternal) expect_equal(result_observed, nbiggest) }) @@ -101,7 +111,7 @@ test_that("summarizePedigrees() handles missing values correctly", { }) # Test Case 7: When all variables are skipped -test_that("summarizePedigrees() works when all numeric variables are skipped", { +test_that("summarizePedigrees works when all numeric variables are skipped",{ df <- data.frame( ID = 1:5, momID = c(NA, 1, 1, NA, 4), @@ -116,7 +126,8 @@ test_that("summarizePedigrees() works when all numeric variables are skipped", { # Test Case 8: Handling invalid column names test_that("summarizePedigrees() throws error on invalid column names", { - df <- data.frame(ID = 1:5, momID = c(NA, 1, 1, NA, 4), dadID = c(NA, 2, 2, NA, 5), famID = c(1, 1, 1, 2, 2)) + df <- data.frame(ID = 1:5, momID = c(NA, 1, 1, NA, 4), + dadID = c(NA, 2, 2, NA, 5), famID = c(1, 1, 1, 2, 2)) expect_error(summarizePedigrees(df, byr = "unknown_column")) }) From 9d9ac4fe313814880b950ea9e5f88c403b6b9339 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 7 Apr 2025 22:17:18 -0400 Subject: [PATCH 10/69] * reduced complexity of com2links and summarizePedigree with the use of subfunctions --- NEWS.md | 1 + R/makeLinks.R | 103 +++++++++++++++-------------- man/com2links.legacy.Rd | 21 ++++++ man/findBiggest.Rd | 5 +- man/findOldest.Rd | 3 + man/validate_and_convert_matrix.Rd | 28 ++++++++ tests/testthat/test-makeLinks.R | 5 +- 7 files changed, 110 insertions(+), 56 deletions(-) create mode 100644 man/com2links.legacy.Rd create mode 100644 man/validate_and_convert_matrix.Rd diff --git a/NEWS.md b/NEWS.md index f0fd33f4..d8bd3dd0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,7 @@ * revived checkParents function to check for handling phantom parents and missing parents * added tests for checkParents function * added GoT analysis +* reduced complexity of com2links and summarizePedigree with the use of subfunctions # BGmisc 1.3.5.1 * Setting the default for the `sparse` argument in `ped2com()` to TRUE diff --git a/R/makeLinks.R b/R/makeLinks.R index fe40bc59..91b6ea1e 100644 --- a/R/makeLinks.R +++ b/R/makeLinks.R @@ -46,42 +46,27 @@ com2links <- function( # Ensure that at least one relationship matrix is provided. if (is.null(ad_ped_matrix) && is.null(mit_ped_matrix) && is.null(cn_ped_matrix)) { - stop("At least one of 'ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided.") + stop("At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided.") } # Validate and convert ad_ped_matrix to a sparse dgCMatrix if provided. if (!is.null(ad_ped_matrix)) { - if (!inherits(ad_ped_matrix, c("matrix", "dgCMatrix", "dsCMatrix"))) { - stop("The 'ad_ped_matrix' must be a matrix or dgCMatrix.") - } - # convert to sparse - if (!inherits(ad_ped_matrix, "dgCMatrix")) { - ad_ped_matrix <- methods::as(ad_ped_matrix, "dgCMatrix") - } + ad_ped_matrix <- validate_and_convert_matrix(mat=ad_ped_matrix, + name = "ad_ped_matrix") } # Validate and convert cn_ped_matrix to a sparse dgCMatrix if provided. if (!is.null(cn_ped_matrix)) { - if (!inherits(cn_ped_matrix, c("matrix", "dgCMatrix", "dsCMatrix"))) { - stop("The 'cn_ped_matrix' must be a matrix or dgCMatrix.") - } - # convert to sparse - if (!inherits(cn_ped_matrix, "dgCMatrix")) { - cn_ped_matrix <- methods::as(cn_ped_matrix, "dgCMatrix") - } - # Ensure CN matrix is symmetric. - cn_ped_matrix <- methods::as(cn_ped_matrix, "symmetricMatrix") + cn_ped_matrix <- validate_and_convert_matrix(mat=cn_ped_matrix, + name="cn_ped_matrix", + ensure_symmetric = TRUE) } # Validate and process mit_ped_matrix: convert and ensure binary values. if (!is.null(mit_ped_matrix)) { - if (!inherits(mit_ped_matrix, c("matrix", "dgCMatrix", "dsCMatrix"))) { - stop("The 'mit_ped_matrix' must be a matrix or dgCMatrix.") - } - if (!inherits(mit_ped_matrix, "dgCMatrix")) { - mit_ped_matrix <- methods::as(mit_ped_matrix, "symmetricMatrix") - } - # Ensure mitochondrial matrix values are binary (0/1) - mit_ped_matrix@x[mit_ped_matrix@x > 0] <- 1 + + mit_ped_matrix <- validate_and_convert_matrix(mat=mit_ped_matrix, + name="mit_ped_matrix",force_binary = TRUE, + ensure_symmetric = TRUE) } # --- Build IDs and Prepare Matrix Pointers --- @@ -162,12 +147,7 @@ com2links <- function( # mapa_id_file <- paste0(outcome_name, "_data_mapaID.csv") # Initialize the related pairs file with headers. - df_relpairs <- data.frame( - ID1 = numeric(0), ID2 = numeric(0) - ) - df_relpairs[[relNames[1]]] <- numeric(0) - df_relpairs[[relNames[2]]] <- numeric(0) - df_relpairs[[relNames[3]]] <- numeric(0) + df_relpairs <- initialize_empty_df(relNames = relNames) # Write the headers to the related pairs file. if (writetodisk == TRUE) { @@ -261,10 +241,8 @@ com2links <- function( } } } - if (verbose) { - if (!(j %% update_rate)) { - cat(paste0("Done with ", j, " of ", nc, "\n")) - } + if (verbose && (j %% update_rate == 0L)) { + cat("Done with", j, "of", nc, "\n") } } } else if (sum_nulls == 2) { @@ -309,11 +287,8 @@ com2links <- function( } # Initialize the related pairs file with the appropriate headers. - df_relpairs <- data.frame( - ID1 = numeric(0), ID2 = numeric(0) - ) - df_relpairs[[relNames[1]]] <- numeric(0) - df_relpairs[[relNames[2]]] <- numeric(0) + df_relpairs <- initialize_empty_df(relNames = relNames) + if (writetodisk == TRUE) { utils::write.table( df_relpairs, @@ -386,10 +361,8 @@ com2links <- function( } } } - if (verbose) { - if (!(j %% update_rate)) { - cat(paste0("Done with ", j, " of ", nc, "\n")) - } + if (verbose && (j %% update_rate == 0L)) { + cat("Done with", j, "of", nc, "\n") } } } else if (sum_nulls == 1) { @@ -426,10 +399,8 @@ com2links <- function( } # Initialize the related pairs file. - df_relpairs <- data.frame( - ID1 = numeric(0), ID2 = numeric(0) - ) - df_relpairs[[relNames[1]]] <- numeric(0) + df_relpairs <- initialize_empty_df(relNames = relNames) + if (writetodisk == TRUE) { utils::write.table( df_relpairs, @@ -486,8 +457,8 @@ com2links <- function( } } } - if (verbose && !(j %% update_rate)) { - cat(paste0("Done with ", j, " of ", nc, "\n")) + if (verbose && (j %% update_rate == 0L)) { + cat("Done with", j, "of", nc, "\n") } } } else { @@ -510,7 +481,6 @@ com2links <- function( } else if (legacy) { # --- Legacy Mode --- # In legacy mode, convert matrices to the expected symmetric formats. - com2links.legacy( rel_pairs_file = rel_pairs_file, ad_ped_matrix = ad_ped_matrix, @@ -649,3 +619,34 @@ com2links.legacy <- function( } return(NULL) } + +#' @title validate_and_convert_matrix +#' @description +#' This function validates and converts a matrix to a specific format. +#' +#' @param mat The matrix to be validated and converted. +#' @param name The name of the matrix for error messages. +#' @param ensure_symmetric Logical indicating whether to ensure the matrix is symmetric. +#' @param force_binary Logical indicating whether to force the matrix to be binary. +#' +#' @return The validated and converted matrix. +validate_and_convert_matrix <- function(mat, name, ensure_symmetric = FALSE, force_binary = FALSE) { + if (!inherits(mat, c("matrix", "dgCMatrix", "dsCMatrix"))) { + stop(paste0("The '", name, "' must be a matrix or dgCMatrix.")) + } + if (!inherits(mat, "dgCMatrix")) { + mat <- methods::as(mat, if (ensure_symmetric) "symmetricMatrix" else "dgCMatrix") + } + if (force_binary) { + mat@x[mat@x > 0] <- 1 + } + return(mat) +} + +initialize_empty_df <- function(relNames) { + df <- data.frame(ID1 = numeric(0), ID2 = numeric(0)) + for (r in relNames) { + df[[r]] <- numeric(0) + } + return(df) +} diff --git a/man/com2links.legacy.Rd b/man/com2links.legacy.Rd new file mode 100644 index 00000000..d409e8ef --- /dev/null +++ b/man/com2links.legacy.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/makeLinks.R +\name{com2links.legacy} +\alias{com2links.legacy} +\title{com2links} +\usage{ +com2links.legacy( + rel_pairs_file = "dataRelatedPairs.csv", + ad_ped_matrix = NULL, + mit_ped_matrix = mt_ped_matrix, + mt_ped_matrix = NULL, + cn_ped_matrix = NULL, + update_rate = 500, + verbose = FALSE, + outcome_name = "data", + ... +) +} +\description{ +This legacy function converts pedigree matrices into a related pairs file. +} diff --git a/man/findBiggest.Rd b/man/findBiggest.Rd index 82d58e70..22c13d96 100644 --- a/man/findBiggest.Rd +++ b/man/findBiggest.Rd @@ -9,10 +9,11 @@ findBiggest(foo_summary_dt, nbiggest, n_foo) \arguments{ \item{foo_summary_dt}{A data.table containing the summary statistics.} -\item{nbiggest}{An integer specifying the number of biggest families to find.} - \item{n_foo}{An integer specifying the number of individuals in the summary.} } +\value{ +a data.table containing the biggest families in the pedigree. +} \description{ This function finds the biggest families in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function. } diff --git a/man/findOldest.Rd b/man/findOldest.Rd index 8b5caf27..f97fa65c 100644 --- a/man/findOldest.Rd +++ b/man/findOldest.Rd @@ -15,6 +15,9 @@ findOldest(foo_summary_dt, byr, noldest, n_foo) \item{n_foo}{An integer specifying the number of individuals in the summary.} } +\value{ +a data.table containing the oldest families in the pedigree. +} \description{ This function finds the oldest families in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function. } diff --git a/man/validate_and_convert_matrix.Rd b/man/validate_and_convert_matrix.Rd new file mode 100644 index 00000000..f6bf5c2a --- /dev/null +++ b/man/validate_and_convert_matrix.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/makeLinks.R +\name{validate_and_convert_matrix} +\alias{validate_and_convert_matrix} +\title{validate_and_convert_matrix} +\usage{ +validate_and_convert_matrix( + mat, + name, + ensure_symmetric = FALSE, + force_binary = FALSE +) +} +\arguments{ +\item{mat}{The matrix to be validated and converted.} + +\item{name}{The name of the matrix for error messages.} + +\item{ensure_symmetric}{Logical indicating whether to ensure the matrix is symmetric.} + +\item{force_binary}{Logical indicating whether to force the matrix to be binary.} +} +\value{ +The validated and converted matrix. +} +\description{ +This function validates and converts a matrix to a specific format. +} diff --git a/tests/testthat/test-makeLinks.R b/tests/testthat/test-makeLinks.R index 2edb8377..e8dfe99e 100644 --- a/tests/testthat/test-makeLinks.R +++ b/tests/testthat/test-makeLinks.R @@ -1,7 +1,7 @@ test_that("com2links handles missing matrices properly", { expect_error( com2links(ad_ped_matrix = NULL, mit_ped_matrix = NULL, cn_ped_matrix = NULL), - "At least one of 'ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided." + "At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided." ) }) @@ -131,8 +131,7 @@ test_that("com2links correctly handles missing matrices", { expect_error( com2links(ad_ped_matrix = NULL, mit_ped_matrix = NULL, cn_ped_matrix = NULL), - "At least one of 'ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided." - ) + "At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided." ) expect_error(com2links(ad_ped_matrix = hazard), "The 'ad_ped_matrix' must be a matrix or dgCMatrix.") }) From 837b97b9d476c192a437c6d853dcb27841c96e6f Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 7 Apr 2025 22:52:18 -0400 Subject: [PATCH 11/69] missed documentation --- DESCRIPTION | 2 +- R/makeLinks.R | 13 +++++++++++-- R/summarizePedigree.R | 1 + man/com2links.legacy.Rd | 21 ++++++++++++++++++++- man/findBiggest.Rd | 2 ++ man/initialize_empty_df.Rd | 18 ++++++++++++++++++ 6 files changed, 53 insertions(+), 4 deletions(-) create mode 100644 man/initialize_empty_df.Rd diff --git a/DESCRIPTION b/DESCRIPTION index b35bfadd..bcdab09f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: BGmisc Title: An R Package for Extended Behavior Genetics Analysis -Version: 1.3.5.1 +Version: 1.3.6 Authors@R: c( person("S. Mason", "Garrison", , "garrissm@wfu.edu", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-4804-6003")), diff --git a/R/makeLinks.R b/R/makeLinks.R index 91b6ea1e..96768fd5 100644 --- a/R/makeLinks.R +++ b/R/makeLinks.R @@ -501,10 +501,10 @@ com2links <- function( # write.table(df, file = mapa_id_file, sep = ",", append = FALSE, row.names = FALSE) } -#' @title com2links +#' Convert Pedigree Matrices to Related Pairs File (Legacy) #' @description #' This legacy function converts pedigree matrices into a related pairs file. - +#' @inheritParams com2links com2links.legacy <- function( rel_pairs_file = "dataRelatedPairs.csv", @@ -643,6 +643,15 @@ validate_and_convert_matrix <- function(mat, name, ensure_symmetric = FALSE, for return(mat) } +#' @title initialize_empty_df +#' @description +#' This function initializes an empty data frame with specified column names. +#' +#' @param relNames A vector of column names to be included in the data frame. +#' +#' @return An empty data frame with specified column names. +#' @keywords internal + initialize_empty_df <- function(relNames) { df <- data.frame(ID1 = numeric(0), ID2 = numeric(0)) for (r in relNames) { diff --git a/R/summarizePedigree.R b/R/summarizePedigree.R index 11a3e7e4..6c6564f3 100644 --- a/R/summarizePedigree.R +++ b/R/summarizePedigree.R @@ -410,6 +410,7 @@ findOldest <- function(foo_summary_dt, byr, noldest, n_foo) { # Function to find the biggest families in a pedigree #' This function finds the biggest families in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function. #' @inheritParams findOldest +#' @inheritParams summarizePedigrees #' @returns a data.table containing the biggest families in the pedigree. diff --git a/man/com2links.legacy.Rd b/man/com2links.legacy.Rd index d409e8ef..757117a1 100644 --- a/man/com2links.legacy.Rd +++ b/man/com2links.legacy.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/makeLinks.R \name{com2links.legacy} \alias{com2links.legacy} -\title{com2links} +\title{Convert Pedigree Matrices to Related Pairs File (Legacy)} \usage{ com2links.legacy( rel_pairs_file = "dataRelatedPairs.csv", @@ -16,6 +16,25 @@ com2links.legacy( ... ) } +\arguments{ +\item{rel_pairs_file}{File path to write related pairs to (CSV format).} + +\item{ad_ped_matrix}{Matrix of additive genetic relatedness coefficients.} + +\item{mit_ped_matrix}{Matrix of mitochondrial relatedness coefficients. Alias: \code{mt_ped_matrix}.} + +\item{mt_ped_matrix}{Matrix of mitochondrial relatedness coefficients.} + +\item{cn_ped_matrix}{Matrix of common nuclear relatedness coefficients.} + +\item{update_rate}{Numeric. Frequency (in iterations) at which progress messages are printed.} + +\item{verbose}{Logical. If TRUE, prints progress messages.} + +\item{outcome_name}{Character string representing the outcome name (used in file naming).} + +\item{...}{Additional arguments to be passed to \code{\link{com2links}}} +} \description{ This legacy function converts pedigree matrices into a related pairs file. } diff --git a/man/findBiggest.Rd b/man/findBiggest.Rd index 22c13d96..c3b3d23e 100644 --- a/man/findBiggest.Rd +++ b/man/findBiggest.Rd @@ -9,6 +9,8 @@ findBiggest(foo_summary_dt, nbiggest, n_foo) \arguments{ \item{foo_summary_dt}{A data.table containing the summary statistics.} +\item{nbiggest}{Integer. Number of largest lineages to return (sorted by count).} + \item{n_foo}{An integer specifying the number of individuals in the summary.} } \value{ diff --git a/man/initialize_empty_df.Rd b/man/initialize_empty_df.Rd new file mode 100644 index 00000000..637d83cb --- /dev/null +++ b/man/initialize_empty_df.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/makeLinks.R +\name{initialize_empty_df} +\alias{initialize_empty_df} +\title{initialize_empty_df} +\usage{ +initialize_empty_df(relNames) +} +\arguments{ +\item{relNames}{A vector of column names to be included in the data frame.} +} +\value{ +An empty data frame with specified column names. +} +\description{ +This function initializes an empty data frame with specified column names. +} +\keyword{internal} From 26c0eb0aa2d3b2c0d4af606f11fe37b362f06318 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 7 Apr 2025 22:55:28 -0400 Subject: [PATCH 12/69] comment out skipped test --- tests/testthat/test-readPedigrees.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-readPedigrees.R b/tests/testthat/test-readPedigrees.R index 349b4f30..1f098697 100644 --- a/tests/testthat/test-readPedigrees.R +++ b/tests/testthat/test-readPedigrees.R @@ -214,10 +214,10 @@ test_that("readWikifamilytree reads a string correctly", { # read E:/Dropbox/Lab/Research/Projects/2024/BGMiscJoss/BGmisc_main/data-raw/Targaryen tree Dance.txt -test_that("readWikifamilytree reads a file correctly", { +#test_that("readWikifamilytree reads a file correctly", { # Create a temporary WikiFamilyTree file for testing # Example usage - family_tree_file_path <- "data-raw/Targaryen tree Dance.txt" # system.file("extdata", "Targaryen tree Dance.txt", package = "BGmisc") +# family_tree_file_path <- "data-raw/Targaryen tree Dance.txt" # system.file("extdata", "Targaryen tree Dance.txt", package = "BGmisc") # result <- readWikifamilytree(file_path=family_tree_file_path) -}) +#}) From 502993751ee1e059953fbc6494fca1fd7647e9dd Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Tue, 8 Apr 2025 11:47:05 -0400 Subject: [PATCH 13/69] add update rate --- R/buildPedigree.R | 15 +- R/convertPedigree.R | 2 +- R/makeLinks.R | 217 ++++++++++++----------- R/readGedcom.R | 82 +++++---- data-raw/benchmark.R | 4 +- data-raw/df_inbreeding.R | 2 +- data-raw/df_potter.R | 8 +- man/collapseNames.Rd | 16 ++ man/readGedcom.Rd | 3 + tests/testthat/test-computeRelatedness.R | 13 +- tests/testthat/test-makeLinks.R | 3 +- tests/testthat/test-readPedigrees.R | 10 +- tests/testthat/test-summarizePedigrees.R | 24 ++- 13 files changed, 235 insertions(+), 164 deletions(-) create mode 100644 man/collapseNames.Rd diff --git a/R/buildPedigree.R b/R/buildPedigree.R index 3d94ecad..98dfbaa3 100644 --- a/R/buildPedigree.R +++ b/R/buildPedigree.R @@ -88,7 +88,8 @@ ped2graph <- function(ped, ...) { # Check ped/data.fram if (!inherits(ped, "data.frame")) { - stop("ped should be a data.frame or inherit to a data.frame")} + stop("ped should be a data.frame or inherit to a data.frame") + } # Handle adjacent argument adjacent <- match.arg(tolower(adjacent)[1], choices = c( @@ -182,8 +183,10 @@ ped2maternal <- function(ped, personID = "ID", momID = "momID", dadID = "dadID", matID = "matID", ...) { # Call to wrapper function - .ped2id(ped = ped, personID = personID, momID = momID, - dadID = dadID, famID = matID, type = "mothers") + .ped2id( + ped = ped, personID = personID, momID = momID, + dadID = dadID, famID = matID, type = "mothers" + ) } #' Add a paternal line ID variable to a pedigree @@ -203,6 +206,8 @@ ped2paternal <- function(ped, personID = "ID", momID = "momID", dadID = "dadID", patID = "patID", ...) { # Call to wrapper function - .ped2id(ped = ped, personID = personID, momID = momID, - dadID = dadID, famID = patID, type = "fathers") + .ped2id( + ped = ped, personID = personID, momID = momID, + dadID = dadID, famID = patID, type = "fathers" + ) } diff --git a/R/convertPedigree.R b/R/convertPedigree.R index 0f454acc..9cab93f0 100644 --- a/R/convertPedigree.R +++ b/R/convertPedigree.R @@ -224,7 +224,7 @@ ped2com <- function(ped, component, } else { # isChild is the 'S' matrix from RAM - isChild <- isChild(isChild_method=isChild_method, ped=ped) + isChild <- isChild(isChild_method = isChild_method, ped = ped) if (saveable) { saveRDS(isChild, file = checkpoint_files$isChild) diff --git a/R/makeLinks.R b/R/makeLinks.R index 96768fd5..d2dc6a65 100644 --- a/R/makeLinks.R +++ b/R/makeLinks.R @@ -50,23 +50,28 @@ com2links <- function( } # Validate and convert ad_ped_matrix to a sparse dgCMatrix if provided. if (!is.null(ad_ped_matrix)) { - ad_ped_matrix <- validate_and_convert_matrix(mat=ad_ped_matrix, - name = "ad_ped_matrix") + ad_ped_matrix <- validate_and_convert_matrix( + mat = ad_ped_matrix, + name = "ad_ped_matrix" + ) } # Validate and convert cn_ped_matrix to a sparse dgCMatrix if provided. if (!is.null(cn_ped_matrix)) { - cn_ped_matrix <- validate_and_convert_matrix(mat=cn_ped_matrix, - name="cn_ped_matrix", - ensure_symmetric = TRUE) + cn_ped_matrix <- validate_and_convert_matrix( + mat = cn_ped_matrix, + name = "cn_ped_matrix", + ensure_symmetric = TRUE + ) } # Validate and process mit_ped_matrix: convert and ensure binary values. if (!is.null(mit_ped_matrix)) { - - mit_ped_matrix <- validate_and_convert_matrix(mat=mit_ped_matrix, - name="mit_ped_matrix",force_binary = TRUE, - ensure_symmetric = TRUE) + mit_ped_matrix <- validate_and_convert_matrix( + mat = mit_ped_matrix, + name = "mit_ped_matrix", force_binary = TRUE, + ensure_symmetric = TRUE + ) } # --- Build IDs and Prepare Matrix Pointers --- @@ -516,109 +521,117 @@ com2links.legacy <- function( verbose = FALSE, outcome_name = "data", ...) { - # --- Legacy Mode --- - if (verbose) { - message("Using legacy mode") + # --- Legacy Mode --- + if (verbose) { + message("Using legacy mode") + } + # In legacy mode, convert matrices to the expected symmetric formats. + + # load(paste0(outcome_name,'_dataBiggestCnPedigree.Rdata')) + # biggestCnPed <- methods::as(biggestCnPed, "symmetricMatrix") + # load(paste0(outcome_name,'_dataBiggestPedigree.Rdata')) + # load(paste0(outcome_name,'_dataBiggestMtPedigree.Rdata')) + + # rel_pairs_file <- paste0(outcome_name,'_datacnmitBiggestRelatedPairsTake3.csv') + + biggestMtPed <- mit_ped_matrix + remove(mit_ped_matrix) + biggestCnPed <- methods::as(cn_ped_matrix, "symmetricMatrix") + remove(cn_ped_matrix) + biggestPed <- ad_ped_matrix + remove(ad_ped_matrix) + biggestMtPed@x[biggestMtPed@x > 0] <- 1 + + # Set the output file name. + if (exists("rel_pairs_file")) { + fname <- rel_pairs_file + } else { + fname <- paste0(outcome_name, "_dataBiggestRelatedPairsTake2.csv") + } + # Initialize the output file with headers. + ds <- data.frame( + ID1 = numeric(0), ID2 = numeric(0), + addRel = numeric(0), + mitRel = numeric(0), cnuRel = numeric(0) + ) + + utils::write.table(ds, + file = fname, sep = ",", + append = FALSE, row.names = FALSE + ) + + # Extract IDs from the common nuclear matrix. + ids <- as.numeric(dimnames(biggestCnPed)[[1]]) + + # Extract pointers from the legacy matrices. + newColPos1 <- biggestPed@p + 1L + iss1 <- biggestPed@i + 1L + newColPos2 <- biggestMtPed@p + 1L + iss2 <- biggestMtPed@i + 1L + newColPos3 <- biggestCnPed@p + 1L + iss3 <- biggestCnPed@i + 1L + nc <- ncol(biggestPed) + + # Process each individual. + for (j in 1L:nc) { + ID2 <- ids[j] + ncp1 <- newColPos1[j] + ncp1p <- newColPos1[j + 1L] + cond1 <- ncp1 < ncp1p + if (cond1) { + vv1 <- ncp1:(ncp1p - 1L) + iss1vv <- iss1[vv1] } - # In legacy mode, convert matrices to the expected symmetric formats. - - # load(paste0(outcome_name,'_dataBiggestCnPedigree.Rdata')) - # biggestCnPed <- methods::as(biggestCnPed, "symmetricMatrix") - # load(paste0(outcome_name,'_dataBiggestPedigree.Rdata')) - # load(paste0(outcome_name,'_dataBiggestMtPedigree.Rdata')) - - # rel_pairs_file <- paste0(outcome_name,'_datacnmitBiggestRelatedPairsTake3.csv') - - biggestMtPed <- mit_ped_matrix - remove(mit_ped_matrix) - biggestCnPed <- methods::as(cn_ped_matrix, "symmetricMatrix") - remove(cn_ped_matrix) - biggestPed <- ad_ped_matrix - remove(ad_ped_matrix) - biggestMtPed@x[biggestMtPed@x > 0] <- 1 - - # Set the output file name. - if (exists("rel_pairs_file")) { - fname <- rel_pairs_file - } else { - fname <- paste0(outcome_name, "_dataBiggestRelatedPairsTake2.csv") + ncp2 <- newColPos2[j] + ncp2p <- newColPos2[j + 1L] + cond2 <- ncp2 < ncp2p + if (cond2) { + vv2 <- ncp2:(ncp2p - 1L) + iss2vv <- iss2[vv2] + } + ncp3 <- newColPos3[j] + ncp3p <- newColPos3[j + 1L] + cond3 <- ncp3 < ncp3p + if (cond3) { + vv3 <- ncp3:(ncp3p - 1L) + iss3vv <- iss3[vv3] } - # Initialize the output file with headers. - ds <- data.frame(ID1 = numeric(0), ID2 = numeric(0), - addRel = numeric(0), - mitRel = numeric(0), cnuRel = numeric(0)) - - utils::write.table(ds, file = fname, sep = ",", - append = FALSE, row.names = FALSE) - - # Extract IDs from the common nuclear matrix. - ids <- as.numeric(dimnames(biggestCnPed)[[1]]) - - # Extract pointers from the legacy matrices. - newColPos1 <- biggestPed@p + 1L - iss1 <- biggestPed@i + 1L - newColPos2 <- biggestMtPed@p + 1L - iss2 <- biggestMtPed@i + 1L - newColPos3 <- biggestCnPed@p + 1L - iss3 <- biggestCnPed@i + 1L - nc <- ncol(biggestPed) - - # Process each individual. - for (j in 1L:nc) { - ID2 <- ids[j] - ncp1 <- newColPos1[j] - ncp1p <- newColPos1[j + 1L] - cond1 <- ncp1 < ncp1p + + # Merge indices from all three matrices. + u <- sort(igraph::union(igraph::union(if (cond1) { + iss1vv + }, if (cond2) { + iss2vv + }), if (cond3) { + iss3vv + })) + # browser() + if (cond1 || cond2 || cond3) { + ID1 <- ids[u] + tds <- data.frame( + ID1 = ID1, ID2 = ID2, + addRel = 0, mitRel = 0, cnuRel = 0 + ) if (cond1) { - vv1 <- ncp1:(ncp1p - 1L) - iss1vv <- iss1[vv1] + tds$addRel[u %in% iss1vv] <- biggestPed@x[vv1] } - ncp2 <- newColPos2[j] - ncp2p <- newColPos2[j + 1L] - cond2 <- ncp2 < ncp2p if (cond2) { - vv2 <- ncp2:(ncp2p - 1L) - iss2vv <- iss2[vv2] + tds$mitRel[u %in% iss2vv] <- biggestMtPed@x[vv2] } - ncp3 <- newColPos3[j] - ncp3p <- newColPos3[j + 1L] - cond3 <- ncp3 < ncp3p if (cond3) { - vv3 <- ncp3:(ncp3p - 1L) - iss3vv <- iss3[vv3] - } - - # Merge indices from all three matrices. - u <- sort(igraph::union(igraph::union(if (cond1) { - iss1vv - }, if (cond2) { - iss2vv - }), if (cond3) { - iss3vv - })) - # browser() - if (cond1 || cond2 || cond3) { - ID1 <- ids[u] - tds <- data.frame(ID1 = ID1, ID2 = ID2, - addRel = 0, mitRel = 0, cnuRel = 0) - if (cond1) { - tds$addRel[u %in% iss1vv] <- biggestPed@x[vv1] - } - if (cond2) { - tds$mitRel[u %in% iss2vv] <- biggestMtPed@x[vv2] - } - if (cond3) { - tds$cnuRel[u %in% iss3vv] <- biggestCnPed@x[vv3] - } - utils::write.table(tds, file = fname, row.names = FALSE, - col.names = FALSE, append = TRUE, sep = ",") - } - if (!(j %% update_rate)) { - cat(paste0("Done with ", j, " of ", nc, "\n")) + tds$cnuRel[u %in% iss3vv] <- biggestCnPed@x[vv3] } + utils::write.table(tds, + file = fname, row.names = FALSE, + col.names = FALSE, append = TRUE, sep = "," + ) + } + if (!(j %% update_rate)) { + cat(paste0("Done with ", j, " of ", nc, "\n")) } - return(NULL) } + return(NULL) +} #' @title validate_and_convert_matrix #' @description diff --git a/R/readGedcom.R b/R/readGedcom.R index d6858e58..f9066c91 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -9,6 +9,7 @@ #' @param combine_cols A logical value indicating whether to combine columns with duplicate values. #' @param verbose A logical value indicating whether to print messages. #' @param skinny A logical value indicating whether to return a skinny data frame. +#' @param update_rate numeric. The rate at which to print progress #' @param ... Additional arguments to be passed to the function. #' @return A data frame containing information about individuals, with the following potential columns: #' - `id`: ID of the individual @@ -53,6 +54,7 @@ readGedcom <- function(file_path, remove_empty_cols = TRUE, combine_cols = TRUE, skinny = FALSE, + update_rate = 1000, ...) { # Checks if (!file.exists(file_path)) stop("File does not exist: ", file_path) @@ -73,11 +75,15 @@ readGedcom <- function(file_path, identifiers = c("id", "momID", "dadID"), names = c( "name", "name_given", "name_given_pieces", - "name_surn", "name_surn_pieces", "name_marriedsurn", "name_nick", "name_npfx", "name_nsfx" + "name_surn", "name_surn_pieces", "name_marriedsurn", + "name_nick", "name_npfx", "name_nsfx" ), sex = c("sex"), birth = c("birth_date", "birth_lat", "birth_long", "birth_place"), - death = c("death_caus", "death_date", "death_lat", "death_long", "death_place"), + death = c( + "death_caus", "death_date", + "death_lat", "death_long", "death_place" + ), attributes = c( "attribute_caste", "attribute_children", "attribute_description", "attribute_education", "attribute_idnumber", "attribute_marriages", @@ -91,7 +97,10 @@ readGedcom <- function(file_path, all_var_names <- unlist(var_names, use.names = FALSE) # Initialize all variables to NA - vars <- stats::setNames(as.list(rep(NA_character_, length(all_var_names))), all_var_names) + vars <- stats::setNames( + as.list(rep(NA_character_, length(all_var_names))), + all_var_names + ) df_temp <- as.data.frame(matrix(nrow = 1, ncol = length(all_var_names))) names(df_temp) <- all_var_names @@ -107,7 +116,10 @@ readGedcom <- function(file_path, df_temp <- rbind(df_temp, line_to_write) # Reset all variables to NA - vars <- stats::setNames(as.list(rep(NA_character_, length(all_var_names))), all_var_names) + vars <- stats::setNames(as.list(rep( + NA_character_, + length(all_var_names) + )), all_var_names) vars$id <- stringr::str_extract(tmpv, "(?<=@.)\\d*(?=@)") next @@ -269,7 +281,7 @@ readGedcom <- function(file_path, vars <- result$vars if (result$matched) next - if (verbose && i %% 1000 == 0) { + if (verbose && i %% update_rate == 0) { cat("Processed", i, "lines\n") } } @@ -296,32 +308,8 @@ readGedcom <- function(file_path, df_temp <- processParents(df_temp, datasource = "gedcom") } - - if (combine_cols) { - if (verbose) { - print("Combining Duplicate Columns") - } - # need to check if any values aren't NA in name_given_pieces and name_surn_pieces - # Combine `name_given` and `name_given_pieces` - - # Combine `name_given` and `name_given_pieces` - if (!all(is.na(df_temp$name_given_pieces)) | !all(is.na(df_temp$name_given))) { - result <- combine_columns(df_temp$name_given, df_temp$name_given_pieces) - df_temp$name_given <- result$combined - if (!result$retain_col2) { - df_temp$name_given_pieces <- NULL - } - } - - # Combine `name_surn` and `name_surn_pieces` - if (!all(is.na(df_temp$name_surn_pieces)) | !all(is.na(df_temp$name_surn))) { - result <- combine_columns(df_temp$name_surn, df_temp$name_surn_pieces) - df_temp$name_surn <- result$combined - if (!result$retain_col2) { - df_temp$name_surn_pieces <- NULL - } - } + df_temp <- collapseNames(verbose = verbose, df_temp = df_temp) } if (remove_empty_cols) { @@ -565,3 +553,37 @@ process_tag <- function(tag, field_name, pattern_rows, line, vars, } return(list(vars = vars, matched = matched)) } + +#' collapse Names +#' +#' This function combines the `name_given` and `name_given_pieces` columns in a data frame. +#' +#' @inheritParams readGedcom +#' @param df_temp A data frame containing the columns to be combined. + +collapseNames <- function(verbose, df_temp) { + if (verbose) { + print("Combining Duplicate Columns") + } + # need to check if any values aren't NA in name_given_pieces and name_surn_pieces + # Combine `name_given` and `name_given_pieces` + + # Combine `name_given` and `name_given_pieces` + if (!all(is.na(df_temp$name_given_pieces)) | !all(is.na(df_temp$name_given))) { + result <- combine_columns(df_temp$name_given, df_temp$name_given_pieces) + df_temp$name_given <- result$combined + if (!result$retain_col2) { + df_temp$name_given_pieces <- NULL + } + } + + # Combine `name_surn` and `name_surn_pieces` + if (!all(is.na(df_temp$name_surn_pieces)) | !all(is.na(df_temp$name_surn))) { + result <- combine_columns(df_temp$name_surn, df_temp$name_surn_pieces) + df_temp$name_surn <- result$combined + if (!result$retain_col2) { + df_temp$name_surn_pieces <- NULL + } + } + return(df_temp) +} diff --git a/data-raw/benchmark.R b/data-raw/benchmark.R index 8c4c90b5..fe480cdf 100644 --- a/data-raw/benchmark.R +++ b/data-raw/benchmark.R @@ -60,4 +60,6 @@ print(benchmark_results) # Optional: Save results to CSV for later analysis write.csv(summary(benchmark_results), - "benchmark_results.csv", row.names = FALSE) + "benchmark_results.csv", + row.names = FALSE +) diff --git a/data-raw/df_inbreeding.R b/data-raw/df_inbreeding.R index 9af10ff0..430830ff 100644 --- a/data-raw/df_inbreeding.R +++ b/data-raw/df_inbreeding.R @@ -8,5 +8,5 @@ inbreeding <- raw ## # data processing -#write.csv(inbreeding, "data-raw/inbreeding.csv", row.names = FALSE) +# write.csv(inbreeding, "data-raw/inbreeding.csv", row.names = FALSE) usethis::use_data(inbreeding, overwrite = TRUE, compress = "xz") diff --git a/data-raw/df_potter.R b/data-raw/df_potter.R index aa039c81..d1f5faf3 100644 --- a/data-raw/df_potter.R +++ b/data-raw/df_potter.R @@ -45,9 +45,11 @@ potter <- data.frame( "Molly Weasley", "Lucy Weasley" ), - gen = c(1, 1, 1, 1, 1, 2, 2, 2, 1, 1, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 3), + gen = c( + 1, 1, 1, 1, 1, 2, 2, 2, 1, 1, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3 + ), momID = c( 101, 101, 103, 103, NA, 3, 4, 10, NA, NA, 10, 10, 10, 10, 10, 10, NA, 105, 105, NA, diff --git a/man/collapseNames.Rd b/man/collapseNames.Rd new file mode 100644 index 00000000..01a38a6c --- /dev/null +++ b/man/collapseNames.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcom.R +\name{collapseNames} +\alias{collapseNames} +\title{collapse Names} +\usage{ +collapseNames(verbose, df_temp) +} +\arguments{ +\item{verbose}{A logical value indicating whether to print messages.} + +\item{df_temp}{A data frame containing the columns to be combined.} +} +\description{ +This function combines the `name_given` and `name_given_pieces` columns in a data frame. +} diff --git a/man/readGedcom.Rd b/man/readGedcom.Rd index 78d45773..fdb158e1 100644 --- a/man/readGedcom.Rd +++ b/man/readGedcom.Rd @@ -11,6 +11,7 @@ readGedcom( remove_empty_cols = TRUE, combine_cols = TRUE, skinny = FALSE, + update_rate = 1000, ... ) } @@ -27,6 +28,8 @@ readGedcom( \item{skinny}{A logical value indicating whether to return a skinny data frame.} +\item{update_rate}{numeric. The rate at which to print progress} + \item{...}{Additional arguments to be passed to the function.} } \value{ diff --git a/tests/testthat/test-computeRelatedness.R b/tests/testthat/test-computeRelatedness.R index 05fb7e62..192df30b 100644 --- a/tests/testthat/test-computeRelatedness.R +++ b/tests/testthat/test-computeRelatedness.R @@ -28,11 +28,13 @@ test_that("calculateRelatedness function with empirical", { # Test 7: empirical divide by zero test_that("calculateH handles divide by zero for empirical", { -expect_error( - calculateRelatedness(generations = 2, - empirical = TRUE, total_a = 0, - total_m = 0)) - + expect_error( + calculateRelatedness( + generations = 2, + empirical = TRUE, total_a = 0, + total_m = 0 + ) + ) }) test_that("inferRelatedness performs as expected", { result <- inferRelatedness(0, aceA = .9, aceC = 0, sharedC = 0) @@ -105,4 +107,3 @@ test_that("calculateH stops for illegal coefficients", { "The observed correlations should be between -1 and 1" ) }) - diff --git a/tests/testthat/test-makeLinks.R b/tests/testthat/test-makeLinks.R index e8dfe99e..475f7b6b 100644 --- a/tests/testthat/test-makeLinks.R +++ b/tests/testthat/test-makeLinks.R @@ -131,7 +131,8 @@ test_that("com2links correctly handles missing matrices", { expect_error( com2links(ad_ped_matrix = NULL, mit_ped_matrix = NULL, cn_ped_matrix = NULL), - "At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided." ) + "At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided." + ) expect_error(com2links(ad_ped_matrix = hazard), "The 'ad_ped_matrix' must be a matrix or dgCMatrix.") }) diff --git a/tests/testthat/test-readPedigrees.R b/tests/testthat/test-readPedigrees.R index 1f098697..a6d6bdd0 100644 --- a/tests/testthat/test-readPedigrees.R +++ b/tests/testthat/test-readPedigrees.R @@ -214,10 +214,10 @@ test_that("readWikifamilytree reads a string correctly", { # read E:/Dropbox/Lab/Research/Projects/2024/BGMiscJoss/BGmisc_main/data-raw/Targaryen tree Dance.txt -#test_that("readWikifamilytree reads a file correctly", { - # Create a temporary WikiFamilyTree file for testing - # Example usage +# test_that("readWikifamilytree reads a file correctly", { +# Create a temporary WikiFamilyTree file for testing +# Example usage # family_tree_file_path <- "data-raw/Targaryen tree Dance.txt" # system.file("extdata", "Targaryen tree Dance.txt", package = "BGmisc") - # result <- readWikifamilytree(file_path=family_tree_file_path) -#}) +# result <- readWikifamilytree(file_path=family_tree_file_path) +# }) diff --git a/tests/testthat/test-summarizePedigrees.R b/tests/testthat/test-summarizePedigrees.R index 61dae665..5bc1d6ea 100644 --- a/tests/testthat/test-summarizePedigrees.R +++ b/tests/testthat/test-summarizePedigrees.R @@ -53,9 +53,11 @@ test_that("summarizeMatrilines() works", { nbiggest <- 2 df <- ped2fam(potter, famID = "newFamID", personID = "personID") %>% ped2maternal(personID = "personID") - df_summarized <- summarizeMatrilines(df, famID = "newFamID", - personID = "personID", - nbiggest = nbiggest) + df_summarized <- summarizeMatrilines(df, + famID = "newFamID", + personID = "personID", + nbiggest = nbiggest + ) # is the total count from the family summary the same as the raw data? result_observed <- sum(df_summarized$maternal_summary$count) result_expected <- nrow(potter) @@ -76,9 +78,11 @@ test_that("summarizePatrilines() works", { nbiggest <- 4 df <- ped2fam(potter, famID = "newFamID", personID = "personID") %>% ped2paternal(personID = "personID") - df_summarized <- summarizePatrilines(df, famID = "newFamID", - personID = "personID", - nbiggest = nbiggest) + df_summarized <- summarizePatrilines(df, + famID = "newFamID", + personID = "personID", + nbiggest = nbiggest + ) # is the total count from the family summary the same as the raw data? result_observed <- sum(df_summarized$paternal_summary$count) result_expected <- nrow(potter) @@ -111,7 +115,7 @@ test_that("summarizePedigrees() handles missing values correctly", { }) # Test Case 7: When all variables are skipped -test_that("summarizePedigrees works when all numeric variables are skipped",{ +test_that("summarizePedigrees works when all numeric variables are skipped", { df <- data.frame( ID = 1:5, momID = c(NA, 1, 1, NA, 4), @@ -126,8 +130,10 @@ test_that("summarizePedigrees works when all numeric variables are skipped",{ # Test Case 8: Handling invalid column names test_that("summarizePedigrees() throws error on invalid column names", { - df <- data.frame(ID = 1:5, momID = c(NA, 1, 1, NA, 4), - dadID = c(NA, 2, 2, NA, 5), famID = c(1, 1, 1, 2, 2)) + df <- data.frame( + ID = 1:5, momID = c(NA, 1, 1, NA, 4), + dadID = c(NA, 2, 2, NA, 5), famID = c(1, 1, 1, 2, 2) + ) expect_error(summarizePedigrees(df, byr = "unknown_column")) }) From e22c933ea0dcfb8053e4c434d03f9cf4f12163c8 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Tue, 8 Apr 2025 13:53:02 -0400 Subject: [PATCH 14/69] allow verbose argument to be passed to standardizeColnames --- NEWS.md | 1 + R/checkIDs.R | 2 +- R/checkParents.R | 47 ++++++++++++++++++++++++++++++++++++++++++++++- R/checkSex.R | 2 +- R/cleanPedigree.R | 2 +- R/plotPedigree.R | 2 +- R/tweakPedigree.R | 4 ++-- 7 files changed, 53 insertions(+), 7 deletions(-) diff --git a/NEWS.md b/NEWS.md index d8bd3dd0..c5392a9d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ * added tests for checkParents function * added GoT analysis * reduced complexity of com2links and summarizePedigree with the use of subfunctions +* allow verbose argument to be passed to standardizeColnames # BGmisc 1.3.5.1 * Setting the default for the `sparse` argument in `ped2com()` to TRUE diff --git a/R/checkIDs.R b/R/checkIDs.R index b9da9a6d..d528d56a 100644 --- a/R/checkIDs.R +++ b/R/checkIDs.R @@ -17,7 +17,7 @@ #' @export checkIDs <- function(ped, verbose = FALSE, repair = FALSE) { # Standardize column names in the input dataframe - ped <- standardizeColnames(ped) + ped <- standardizeColnames(ped, verbose = verbose) # Initialize a list to store validation results validation_results <- list() diff --git a/R/checkParents.R b/R/checkParents.R index eab8e0ca..c37a08e9 100644 --- a/R/checkParents.R +++ b/R/checkParents.R @@ -26,7 +26,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, parentswithoutrow = repair) { # Standardize column names in the input dataframe ped_og <- ped - ped <- standardizeColnames(ped) + ped <- standardizeColnames(ped, verbose = verbose) # Initialize a list to store validation results @@ -300,3 +300,48 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, repairParentIDs <- function(ped, verbose = FALSE) { checkParentIDs(ped = ped, verbose = verbose, repair = TRUE) } + +#' Add Phantom Parents +#' +#' This function adds phantom parents to a pedigree. +#' @inheritParams checkParentIDs + +addPhantoms <- function(ped, verbose, pid, validation_results) { + # Add parents who appear in momID or dadID but are missing from ID + new_entries <- data.frame() + + listed_parents <- unique(c(ped$momID, ped$dadID)) + listed_parents <- listed_parents[!is.na(listed_parents)] + + existing_ids <- ped$ID + missing_parents <- setdiff(listed_parents, existing_ids) + + if (length(missing_parents) > 0) { + if (verbose) { + cat("Adding parents who were listed in momID/dadID but missing from ID:\n") + print(missing_parents) + } + + for (pid in missing_parents) { + role <- unique( + c( + if (pid %in% ped$momID) "mom" else NULL, + if (pid %in% ped$dadID) "dad" else NULL + ) + ) + inferred_sex <- if ("mom" %in% role) validation_results$female_var else validation_results$male_var + + new_row <- ped[1, ] + new_row$ID <- pid + new_row$dadID <- NA + new_row$momID <- NA + new_row$sex <- inferred_sex + new_entries <- rbind(new_entries, new_row) + } + } + ped <- merge(ped, new_entries, all = TRUE) + if (verbose) { + cat("Added phantom parents for:", paste(new_entries$ID, collapse = ", "), "\n") + } + return(ped) +} diff --git a/R/checkSex.R b/R/checkSex.R index d220dec6..8fbabf6a 100644 --- a/R/checkSex.R +++ b/R/checkSex.R @@ -37,7 +37,7 @@ #' checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE, repair = FALSE) { # Standardize column names in the input dataframe - ped <- standardizeColnames(ped) + ped <- standardizeColnames(ped, verbose = verbose) # TO DO: bypass the rest of the function if recode_only is TRUE diff --git a/R/cleanPedigree.R b/R/cleanPedigree.R index ffd8054e..b03ca270 100644 --- a/R/cleanPedigree.R +++ b/R/cleanPedigree.R @@ -60,7 +60,7 @@ standardizeColnames <- function(df, verbose = FALSE) { # check_sex = TRUE, # check_parents = TRUE, # verbose = FALSE) { -# corrected_ped <- ped <- standardizeColnames(ped) +# corrected_ped <- ped <- standardizeColnames(ped, verbose = verbose) # if (verbose) { # print("Repairing pedigree...") # } diff --git a/R/plotPedigree.R b/R/plotPedigree.R index 051610e6..5b2229cd 100644 --- a/R/plotPedigree.R +++ b/R/plotPedigree.R @@ -25,7 +25,7 @@ plotPedigree <- function(ped, pconnect = .5, ...) { # Standardize column names in the input dataframe - ped <- standardizeColnames(ped) + ped <- standardizeColnames(ped, verbose = verbose) # Define required columns simulated_vars <- c("fam", "ID", "dadID", "momID", "sex") diff --git a/R/tweakPedigree.R b/R/tweakPedigree.R index 2367fe21..edefaf99 100644 --- a/R/tweakPedigree.R +++ b/R/tweakPedigree.R @@ -18,7 +18,7 @@ makeTwins <- function(ped, ID_twin1 = NA_integer_, ID_twin2 = NA_integer_, gen_t "fam", "ID", "gen", "dadID", "momID", "spID", "sex" ), collapse = "")) { - ped <- standardizeColnames(ped) + ped <- standardizeColnames(ped, verbose = verbose) if (verbose) { cat("The input pedigree is not in the same format as the output of simulatePedigree\n") } @@ -131,7 +131,7 @@ makeInbreeding <- function(ped, c("fam", "ID", "gen", "dadID", "momID", "spID", "sex"), collapse = "" )) { - ped <- standardizeColnames(ped) + ped <- standardizeColnames(ped, verbose = verbose) if (verbose) { cat("The input pedigree is not in the same format as the output of simulatePedigree\n") } From a8c2b6c8781bcf4a37858c12660247dd221a1233 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Tue, 8 Apr 2025 14:54:40 -0400 Subject: [PATCH 15/69] refactor checkids --- R/checkIDs.R | 151 ++++++++++++++++++++---------------------- R/summarizePedigree.R | 62 ++++++++++------- 2 files changed, 109 insertions(+), 104 deletions(-) diff --git a/R/checkIDs.R b/R/checkIDs.R index d528d56a..c92653ed 100644 --- a/R/checkIDs.R +++ b/R/checkIDs.R @@ -28,91 +28,15 @@ checkIDs <- function(ped, verbose = FALSE, repair = FALSE) { } # Identify non-unique IDs - duplicated_ids <- ped$ID[duplicated(ped$ID) | duplicated(ped$ID, fromLast = TRUE)] - + id_check <- checkIDuniqueness(ped=ped, verbose=verbose) - # Update the validation_results list - if (length(duplicated_ids) > 0) { - if (verbose) { - cat(paste0(length(duplicated_ids), " non-unique IDs found.\n")) - } - validation_results$all_unique_ids <- FALSE - validation_results$total_non_unique_ids <- length(duplicated_ids) - validation_results$non_unique_ids <- unique(duplicated_ids) - } else { - if (verbose) { - cat("All IDs are unique.\n") - } - validation_results$all_unique_ids <- TRUE - validation_results$total_non_unique_ids <- 0 - validation_results$non_unique_ids <- NULL - } if (verbose) { cat("Step 2: Checking for within row duplicats...\n") - cat("Is own father?\n") - } - is_own_father <- ped$ID[ped$ID == ped$dadID & !is.na(ped$dadID)] - if (verbose) { - cat("Is own mother?\n") - } - is_own_mother <- ped$ID[ped$ID == ped$momID & !is.na(ped$momID)] - if (verbose) { - cat("Is mother father?\n") } - duplicated_parents <- ped$ID[ped$dadID == ped$momID & !is.na(ped$dadID) & !is.na(ped$momID)] + row_check <- checkWithinRowDuplicates(ped=ped, verbose = verbose) - # get the total number of within row duplicates - validation_results$total_own_father <- length(is_own_father) - validation_results$total_own_mother <- length(is_own_mother) - validation_results$total_duplicated_parents <- length(duplicated_parents) - validation_results$total_within_row_duplicates <- sum(length(is_own_father), length(is_own_mother), length(duplicated_parents)) - # Update the validation_results list + validation_results <- c(id_check, row_check) - if (validation_results$total_within_row_duplicates > 0) { - if (verbose) { - cat(paste0( - validation_results$total_within_row_duplicates, - " within row duplicates found.\n" - )) - } - validation_results$within_row_duplicates <- TRUE - if (validation_results$total_own_father > 0) { - validation_results$is_own_father_ids <- unique(is_own_father) - if (verbose) { - cat(paste0( - validation_results$total_own_father, - " individuals are their own fathers.\n" - )) - } - } - if (validation_results$total_own_mother > 0) { - validation_results$is_own_mother_ids <- unique(is_own_mother) - if (verbose) { - cat(paste0( - validation_results$total_own_mother, - " individuals are their own mothers.\n" - )) - } - } - if (validation_results$total_duplicated_parents > 0) { - validation_results$duplicated_parents_ids <- unique(duplicated_parents) - if (verbose) { - cat(paste0( - validation_results$total_duplicated_parents, - " individuals have the same mother and father.\n" - )) - } - } - } else { - if (verbose) { - cat("No within row duplicates found.\n") - } - validation_results$within_row_duplicates <- FALSE - validation_results$total_within_row_duplicates <- 0 - validation_results$is_own_father_ids <- NULL - validation_results$is_own_mother_ids <- NULL - validation_results$duplicated_parents_ids <- NULL - } if (verbose) { cat("Validation Results:\n") print(validation_results) @@ -169,3 +93,72 @@ checkIDs <- function(ped, verbose = FALSE, repair = FALSE) { repairIDs <- function(ped, verbose = FALSE) { checkIDs(ped = ped, verbose = verbose, repair = TRUE) } + +#' Check for duplicated individual IDs +#' +#' This function checks for duplicated individual IDs in a pedigree. +#' +#' @param ped A pedigree object +#' @param verbose A logical indicating whether to print progress messages +#' @return A list containing the results of the check +#' +checkIDuniqueness <- function(ped, verbose = FALSE) { + # Identify non-unique IDs + + duplicated_ids <- ped$ID[duplicated(ped$ID) | duplicated(ped$ID, fromLast = TRUE)] + + if (verbose) { + if (length(duplicated_ids) > 0) { + cat(length(duplicated_ids), " non-unique IDs found.\n") + } else { + cat("All IDs are unique.\n") + } + } + + # Update the validation_results list + list( + all_unique_ids = length(duplicated_ids) == 0, + total_non_unique_ids = length(duplicated_ids), + non_unique_ids = if (length(duplicated_ids) > 0) unique(duplicated_ids) else NULL + ) +} + + +#' Check for within-row duplicates (self-parents, same mom/dad) +checkWithinRowDuplicates <- function(ped, verbose = FALSE) { + # is the individual their own father or mother? + is_own_father <- ped$ID[ped$ID == ped$dadID & !is.na(ped$dadID)] + is_own_mother <- ped$ID[ped$ID == ped$momID & !is.na(ped$momID)] + + # is mother and father the same? + duplicated_parents <- ped$ID[ + ped$dadID == ped$momID & + !is.na(ped$dadID) & !is.na(ped$momID) + ] + + # get the total number of within row duplicates + total <- length(is_own_father) + length(is_own_mother) + length(duplicated_parents) + + if (verbose) { + if (total > 0) { + cat(total, " within row duplicates found.\n") + if (length(is_own_father) > 0) cat(length(is_own_father), " individuals are their own fathers.\n") + if (length(is_own_mother) > 0) cat(length(is_own_mother), " individuals are their own mothers.\n") + if (length(duplicated_parents) > 0) cat(length(duplicated_parents), " individuals have the same mother and father.\n") + } else { + cat("No within row duplicates found.\n") + } + } + # Update the validation_results list + list( + total_own_father = length(is_own_father), + total_own_mother = length(is_own_mother), + total_duplicated_parents = length(duplicated_parents), + total_within_row_duplicates = total, + within_row_duplicates = total > 0, + is_own_father_ids = if (length(is_own_father) > 0) unique(is_own_father) else NULL, + is_own_mother_ids = if (length(is_own_mother) > 0) unique(is_own_mother) else NULL, + duplicated_parents_ids = if (length(duplicated_parents) > 0) unique(duplicated_parents) else NULL + ) +} + diff --git a/R/summarizePedigree.R b/R/summarizePedigree.R index 6c6564f3..ea8f81e8 100644 --- a/R/summarizePedigree.R +++ b/R/summarizePedigree.R @@ -39,7 +39,7 @@ summarizePedigrees <- function(ped, famID = "famID", personID = "ID", matID = "matID", patID = "patID", type = c("fathers", "mothers", "families"), byr = NULL, include_founder = FALSE, founder_sort_var = NULL, - nbiggest = 5, noldest = 5, skip_var = NULL, + nbiggest = 5, noldest = nbiggest, skip_var = NULL, five_num_summary = FALSE, network_checks = FALSE, verbose = FALSE) { # Fast Fails @@ -123,15 +123,11 @@ summarizePedigrees <- function(ped, famID = "famID", personID = "ID", ) # Find the originating member for each line if (include_founder) { - if (verbose) message("Finding originating members for families...") - originating_member_family <- findFounder(ped_dt, + family_summary_dt <- summarizeFounder( + verbose = verbose, ped_dt = ped_dt, group_var = famID, - sort_var = founder_sort_var - ) - # Merge summary statistics with originating members for additional information - family_summary_dt <- merge(family_summary_dt, - originating_member_family, - by = famID, suffixes = c("", "_founder") + sort_var = founder_sort_var, + foo_summary_dt = family_summary_dt ) } output$family_summary <- family_summary_dt @@ -146,14 +142,11 @@ summarizePedigrees <- function(ped, famID = "famID", personID = "ID", five_num_summary = five_num_summary ) if (include_founder) { - if (verbose) message("Finding originating members for matrilineal lines...") - originating_member_maternal <- findFounder(ped_dt, + maternal_summary_dt <- summarizeFounder( + verbose = verbose, ped_dt = ped_dt, group_var = matID, - sort_var = founder_sort_var - ) - maternal_summary_dt <- merge(maternal_summary_dt, - originating_member_maternal, - by = matID, suffixes = c("", "_founder") + sort_var = founder_sort_var, + foo_summary_dt = maternal_summary_dt ) } output$maternal_summary <- maternal_summary_dt @@ -167,14 +160,11 @@ summarizePedigrees <- function(ped, famID = "famID", personID = "ID", five_num_summary = five_num_summary ) if (include_founder) { - if (verbose) message("Finding originating members for patrilineal lines...") - originating_member_paternal <- findFounder(ped_dt, + paternal_summary_dt <- summarizeFounder( + verbose = verbose, ped_dt = ped_dt, group_var = patID, - sort_var = founder_sort_var - ) - paternal_summary_dt <- merge(paternal_summary_dt, - originating_member_paternal, - by = patID, suffixes = c("", "_founder") + sort_var = founder_sort_var, + foo_summary_dt = paternal_summary_dt ) } @@ -298,8 +288,8 @@ calculateSummaryDT <- function(data, group_var, skip_var, return(summary_stats) } -# Function to find the originating member for each line - +#' Function to find the originating member for each line +#' #' This function finds the originating member for each line in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function. #' @inheritParams summarizePedigrees #' @param sort_var A character string specifying the column name to sort by. @@ -312,7 +302,29 @@ findFounder <- function(data, group_var, sort_var) { data[order(get(sort_var)), .SD[1], by = group_var] } +#' Function to summarize the originating members for each line +#' +#' This function summarizes the originating members for each line in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function. +#' +#' @inheritParams summarizePedigrees +#' @inheritParams findFounder +#' +#' @keywords internal +summarizeFounder <- function(ped_dt, group_var, sort_var, foo_summary_dt, verbose) { + if (verbose) message(paste0("Finding originating members for ", "group_var")) + originating_member_foo <- findFounder( + data = ped_dt, + group_var = group_var, + sort_var = sort_var + ) + # Merge summary statistics with originating members for additional information + foo_summary_dt <- merge(foo_summary_dt, + originating_member_foo, + by = group_var, suffixes = c("", "_founder") + ) + return(foo_summary_dt) +} #' Summarize the maternal lines in a pedigree #' @inheritParams summarizePedigrees #' @seealso [summarizePedigrees ()] From 3326f757fbe4fa9e5731fa74972096a1e842842c Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Tue, 8 Apr 2025 14:57:25 -0400 Subject: [PATCH 16/69] docs --- NEWS.md | 3 ++- man/addPhantoms.Rd | 16 ++++++++++++++++ man/checkIDuniqueness.Rd | 19 +++++++++++++++++++ man/checkWithinRowDuplicates.Rd | 11 +++++++++++ man/findFounder.Rd | 2 +- man/summarizeFounder.Rd | 17 +++++++++++++++++ man/summarizePedigrees.Rd | 2 +- 7 files changed, 67 insertions(+), 3 deletions(-) create mode 100644 man/addPhantoms.Rd create mode 100644 man/checkIDuniqueness.Rd create mode 100644 man/checkWithinRowDuplicates.Rd create mode 100644 man/summarizeFounder.Rd diff --git a/NEWS.md b/NEWS.md index c5392a9d..31ad40c0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,9 +2,10 @@ * revived checkParents function to check for handling phantom parents and missing parents * added tests for checkParents function * added GoT analysis -* reduced complexity of com2links and summarizePedigree with the use of subfunctions +* reduced complexity of com2links, summarizePedigree, and checkIDs with the use of subfunctions * allow verbose argument to be passed to standardizeColnames + # BGmisc 1.3.5.1 * Setting the default for the `sparse` argument in `ped2com()` to TRUE diff --git a/man/addPhantoms.Rd b/man/addPhantoms.Rd new file mode 100644 index 00000000..2981b01e --- /dev/null +++ b/man/addPhantoms.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checkParents.R +\name{addPhantoms} +\alias{addPhantoms} +\title{Add Phantom Parents} +\usage{ +addPhantoms(ped, verbose, pid, validation_results) +} +\arguments{ +\item{ped}{A dataframe representing the pedigree data with columns 'ID', 'dadID', and 'momID'.} + +\item{verbose}{A logical flag indicating whether to print progress and validation messages to the console.} +} +\description{ +This function adds phantom parents to a pedigree. +} diff --git a/man/checkIDuniqueness.Rd b/man/checkIDuniqueness.Rd new file mode 100644 index 00000000..88b4dba3 --- /dev/null +++ b/man/checkIDuniqueness.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checkIDs.R +\name{checkIDuniqueness} +\alias{checkIDuniqueness} +\title{Check for duplicated individual IDs} +\usage{ +checkIDuniqueness(ped, verbose = FALSE) +} +\arguments{ +\item{ped}{A pedigree object} + +\item{verbose}{A logical indicating whether to print progress messages} +} +\value{ +A list containing the results of the check +} +\description{ +This function checks for duplicated individual IDs in a pedigree. +} diff --git a/man/checkWithinRowDuplicates.Rd b/man/checkWithinRowDuplicates.Rd new file mode 100644 index 00000000..e0ddb318 --- /dev/null +++ b/man/checkWithinRowDuplicates.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checkIDs.R +\name{checkWithinRowDuplicates} +\alias{checkWithinRowDuplicates} +\title{Check for within-row duplicates (self-parents, same mom/dad)} +\usage{ +checkWithinRowDuplicates(ped, verbose = FALSE) +} +\description{ +Check for within-row duplicates (self-parents, same mom/dad) +} diff --git a/man/findFounder.Rd b/man/findFounder.Rd index a4cf70bb..19bfcb1f 100644 --- a/man/findFounder.Rd +++ b/man/findFounder.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/summarizePedigree.R \name{findFounder} \alias{findFounder} -\title{This function finds the originating member for each line in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function.} +\title{Function to find the originating member for each line} \usage{ findFounder(data, group_var, sort_var) } diff --git a/man/summarizeFounder.Rd b/man/summarizeFounder.Rd new file mode 100644 index 00000000..703834e3 --- /dev/null +++ b/man/summarizeFounder.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summarizePedigree.R +\name{summarizeFounder} +\alias{summarizeFounder} +\title{Function to summarize the originating members for each line} +\usage{ +summarizeFounder(ped_dt, group_var, sort_var, foo_summary_dt, verbose) +} +\arguments{ +\item{sort_var}{A character string specifying the column name to sort by.} + +\item{verbose}{Logical, if TRUE, print progress messages.} +} +\description{ +This function summarizes the originating members for each line in a pedigree. It is supposed to be used internally by the \code{summarize_pedigree} function. +} +\keyword{internal} diff --git a/man/summarizePedigrees.Rd b/man/summarizePedigrees.Rd index b298d326..3ed2f0a5 100644 --- a/man/summarizePedigrees.Rd +++ b/man/summarizePedigrees.Rd @@ -17,7 +17,7 @@ summarizePedigrees( include_founder = FALSE, founder_sort_var = NULL, nbiggest = 5, - noldest = 5, + noldest = nbiggest, skip_var = NULL, five_num_summary = FALSE, network_checks = FALSE, From 6019916322c00d8227bfbdffada562fe09cadea7 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Wed, 9 Apr 2025 14:37:32 -0400 Subject: [PATCH 17/69] documentation --- NEWS.md | 2 +- R/checkIDs.R | 13 +++++-- R/checkParents.R | 3 +- R/computeRelatedness.R | 16 ++++++++ R/helpGeneric.R | 68 +-------------------------------- R/simulatePedigree.R | 8 ++++ man/SimPed.Rd | 33 ---------------- man/addPhantoms.Rd | 4 +- man/calculateRelatedness.Rd | 3 ++ man/checkIDuniqueness.Rd | 4 +- man/checkWithinRowDuplicates.Rd | 10 ++++- man/inferRelatedness.Rd | 5 +++ man/related_coef.Rd | 33 ---------------- man/relatedness.Rd | 33 ---------------- man/repairIDs.Rd | 4 +- man/simulatePedigree.Rd | 5 +++ 16 files changed, 67 insertions(+), 177 deletions(-) delete mode 100644 man/SimPed.Rd delete mode 100644 man/related_coef.Rd delete mode 100644 man/relatedness.Rd diff --git a/NEWS.md b/NEWS.md index 31ad40c0..94602bd7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,7 +4,7 @@ * added GoT analysis * reduced complexity of com2links, summarizePedigree, and checkIDs with the use of subfunctions * allow verbose argument to be passed to standardizeColnames - +* list SimPed and related_coef as aliases for functions # BGmisc 1.3.5.1 * Setting the default for the `sparse` argument in `ped2com()` to TRUE diff --git a/R/checkIDs.R b/R/checkIDs.R index c92653ed..4c1100fd 100644 --- a/R/checkIDs.R +++ b/R/checkIDs.R @@ -87,8 +87,7 @@ checkIDs <- function(ped, verbose = FALSE, repair = FALSE) { #' Repair Missing IDs #' #' This function repairs missing IDs in a pedigree. -#' @param ped A pedigree object -#' @param verbose A logical indicating whether to print progress messages +#' @inheritParams checkIDs #' @return A corrected pedigree repairIDs <- function(ped, verbose = FALSE) { checkIDs(ped = ped, verbose = verbose, repair = TRUE) @@ -98,8 +97,7 @@ repairIDs <- function(ped, verbose = FALSE) { #' #' This function checks for duplicated individual IDs in a pedigree. #' -#' @param ped A pedigree object -#' @param verbose A logical indicating whether to print progress messages +#' @inheritParams checkIDs #' @return A list containing the results of the check #' checkIDuniqueness <- function(ped, verbose = FALSE) { @@ -124,7 +122,14 @@ checkIDuniqueness <- function(ped, verbose = FALSE) { } + #' Check for within-row duplicates (self-parents, same mom/dad) +#' +#' This function checks for within-row duplicates in a pedigree. +#' +#' @inheritParams checkIDs +#' @return A list containing the results of the check +#' checkWithinRowDuplicates <- function(ped, verbose = FALSE) { # is the individual their own father or mother? is_own_father <- ped$ID[ped$ID == ped$dadID & !is.na(ped$dadID)] diff --git a/R/checkParents.R b/R/checkParents.R index c37a08e9..3c680e77 100644 --- a/R/checkParents.R +++ b/R/checkParents.R @@ -305,8 +305,9 @@ repairParentIDs <- function(ped, verbose = FALSE) { #' #' This function adds phantom parents to a pedigree. #' @inheritParams checkParentIDs +#' @param validation_results validation results -addPhantoms <- function(ped, verbose, pid, validation_results) { +addPhantoms <- function(ped, verbose, validation_results) { # Add parents who appear in momID or dadID but are missing from ID new_entries <- data.frame() diff --git a/R/computeRelatedness.R b/R/computeRelatedness.R index e3f53b8b..3fa91ffd 100644 --- a/R/computeRelatedness.R +++ b/R/computeRelatedness.R @@ -64,6 +64,14 @@ calculateRelatedness <- function( return(coef) } + +#' @rdname calculateRelatedness +#' @export +related_coef <- function(...) { + warning("The 'related_coef' function is deprecated. Please use 'calculateRelatedness' instead.") + calculateRelatedness(...) +} + #' Infer Relatedness Coefficient #' #' @description @@ -79,6 +87,7 @@ calculateRelatedness <- function( #' @param aceA Numeric. Proportion of variance attributable to additive genetic variance. Must be between 0 and 1. Default is 0.9. #' @param aceC Numeric. Proportion of variance attributable to shared environmental variance. Must be between 0 and 1. Default is 0. #' @param sharedC Numeric. Proportion of shared environment shared between the two individuals. Must be between 0 (no shared environment) and 1 (completely shared environment). Default is 0. +#' @param ... Further named arguments that may be passed to another function. #' #' @return #' Numeric. The calculated relatedness coefficient (`est_r`). @@ -97,6 +106,13 @@ inferRelatedness <- function(obsR, aceA = .9, aceC = 0, sharedC = 0) { return(calc_r) } +#' @rdname inferRelatedness +#' @export +relatedness <- function(...) { + warning("The 'relatedness' function is deprecated. Please use 'inferRelatedness' instead.") + inferRelatedness(...) +} + #' Falconer's Formula #' #' @description diff --git a/R/helpGeneric.R b/R/helpGeneric.R index e8ef381c..8b376bfb 100644 --- a/R/helpGeneric.R +++ b/R/helpGeneric.R @@ -99,71 +99,7 @@ resample <- function(x, ...) { } -#' SimPed (Deprecated) -#' -#' This function is a wrapper around the new `simulatePedigree` function. -#' `SimPed` has been deprecated, and it's advised to use `simulatePedigree` directly. -#' -#' @param ... Arguments to be passed to `simulatePedigree`. -#' @return The same result as calling `simulatePedigree`. -#' @seealso \code{\link{simulatePedigree}} for the updated function. -#' @description When calling this function, a warning will be issued about its deprecation. -#' @keywords deprecated -#' @examples -#' \dontrun{ -#' # This is an example of the deprecated function: -#' SimPed(...) -#' # It is recommended to use: -#' simulatePedigree(...) -#' } -#' @export -SimPed <- function(...) { # nolint: object_name_linter. - warning("The 'SimPed' function is deprecated. Please use 'simulatePedigree' instead.") - simulatePedigree(...) -} -#' related_coef (Deprecated) -#' -#' This function is a wrapper around the new `calculateRelatedness` function. -#' `related_coef` has been deprecated, and it's advised to use `calculateRelatedness` directly. -#' -#' @param ... Arguments to be passed to `calculateRelatedness`. -#' @return The same result as calling `calculateRelatedness`. -#' @seealso \code{\link{calculateRelatedness}} for the updated function. -#' @description When calling this function, a warning will be issued about its deprecation. -#' @keywords deprecated -#' @examples -#' \dontrun{ -#' # This is an example of the deprecated function: -#' related_coef(...) -#' # It is recommended to use: -#' calculateRelatedness(...) -#' } -#' @export -related_coef <- function(...) { - warning("The 'related_coef' function is deprecated. Please use 'calculateRelatedness' instead.") - calculateRelatedness(...) -} -#' relatedness (Deprecated) -#' -#' This function is a wrapper around the new `inferRelatedness` function. -#' `relatedness` has been deprecated, and it's advised to use `inferRelatedness` directly. -#' -#' @param ... Arguments to be passed to `inferRelatedness`. -#' @return The same result as calling `inferRelatedness`. -#' @seealso \code{\link{inferRelatedness}} for the updated function. -#' @description When calling this function, a warning will be issued about its deprecation. -#' @keywords deprecated -#' @examples -#' \dontrun{ -#' # This is an example of the deprecated function: -#' relatedness(...) -#' # It is recommended to use: -#' inferRelatedness(...) -#' } -#' @export -relatedness <- function(...) { - warning("The 'relatedness' function is deprecated. Please use 'inferRelatedness' instead.") - inferRelatedness(...) -} + + diff --git a/R/simulatePedigree.R b/R/simulatePedigree.R index d50b7732..29407af8 100644 --- a/R/simulatePedigree.R +++ b/R/simulatePedigree.R @@ -343,6 +343,7 @@ buildBetweenGenerations <- function(df_Fam, Ngen, sizeGens, verbose, marR, sexR, #' @param balancedSex Not fully developed yet. Always \code{TRUE} in the current version. #' @param balancedMar Not fully developed yet. Always \code{TRUE} in the current version. #' @param verbose logical If TRUE, print progress through stages of algorithm +#' @param ... Additional arguments to be passed to other functions. #' @return A \code{data.frame} with each row representing a simulated individual. The columns are as follows: #' \itemize{ @@ -408,3 +409,10 @@ simulatePedigree <- function(kpc = 3, # print(df_Fam) return(df_Fam) } + +#' @rdname simulatePedigree +#' @export +SimPed <- function(...) { # nolint: object_name_linter. + warning("The 'SimPed' function is deprecated. Please use 'simulatePedigree' instead.") + simulatePedigree(...) +} diff --git a/man/SimPed.Rd b/man/SimPed.Rd deleted file mode 100644 index 79dd1f96..00000000 --- a/man/SimPed.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/helpGeneric.R -\name{SimPed} -\alias{SimPed} -\title{SimPed (Deprecated)} -\usage{ -SimPed(...) -} -\arguments{ -\item{...}{Arguments to be passed to `simulatePedigree`.} -} -\value{ -The same result as calling `simulatePedigree`. -} -\description{ -When calling this function, a warning will be issued about its deprecation. -} -\details{ -This function is a wrapper around the new `simulatePedigree` function. -`SimPed` has been deprecated, and it's advised to use `simulatePedigree` directly. -} -\examples{ -\dontrun{ -# This is an example of the deprecated function: -SimPed(...) -# It is recommended to use: -simulatePedigree(...) -} -} -\seealso{ -\code{\link{simulatePedigree}} for the updated function. -} -\keyword{deprecated} diff --git a/man/addPhantoms.Rd b/man/addPhantoms.Rd index 2981b01e..bafe5b75 100644 --- a/man/addPhantoms.Rd +++ b/man/addPhantoms.Rd @@ -4,12 +4,14 @@ \alias{addPhantoms} \title{Add Phantom Parents} \usage{ -addPhantoms(ped, verbose, pid, validation_results) +addPhantoms(ped, verbose, validation_results) } \arguments{ \item{ped}{A dataframe representing the pedigree data with columns 'ID', 'dadID', and 'momID'.} \item{verbose}{A logical flag indicating whether to print progress and validation messages to the console.} + +\item{validation_results}{validation results} } \description{ This function adds phantom parents to a pedigree. diff --git a/man/calculateRelatedness.Rd b/man/calculateRelatedness.Rd index b9a8f067..6d932e63 100644 --- a/man/calculateRelatedness.Rd +++ b/man/calculateRelatedness.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/computeRelatedness.R \name{calculateRelatedness} \alias{calculateRelatedness} +\alias{related_coef} \title{Calculate Relatedness Coefficient} \usage{ calculateRelatedness( @@ -18,6 +19,8 @@ calculateRelatedness( denom_m = FALSE, ... ) + +related_coef(...) } \arguments{ \item{generations}{Number of generations back of common ancestors the pair share.} diff --git a/man/checkIDuniqueness.Rd b/man/checkIDuniqueness.Rd index 88b4dba3..6c1aebf6 100644 --- a/man/checkIDuniqueness.Rd +++ b/man/checkIDuniqueness.Rd @@ -7,9 +7,9 @@ checkIDuniqueness(ped, verbose = FALSE) } \arguments{ -\item{ped}{A pedigree object} +\item{ped}{A dataframe representing the pedigree data with columns `ID`, `dadID`, and `momID`.} -\item{verbose}{A logical indicating whether to print progress messages} +\item{verbose}{A logical flag indicating whether to print progress and validation messages to the console.} } \value{ A list containing the results of the check diff --git a/man/checkWithinRowDuplicates.Rd b/man/checkWithinRowDuplicates.Rd index e0ddb318..4797306c 100644 --- a/man/checkWithinRowDuplicates.Rd +++ b/man/checkWithinRowDuplicates.Rd @@ -6,6 +6,14 @@ \usage{ checkWithinRowDuplicates(ped, verbose = FALSE) } +\arguments{ +\item{ped}{A dataframe representing the pedigree data with columns `ID`, `dadID`, and `momID`.} + +\item{verbose}{A logical flag indicating whether to print progress and validation messages to the console.} +} +\value{ +A list containing the results of the check +} \description{ -Check for within-row duplicates (self-parents, same mom/dad) +This function checks for within-row duplicates in a pedigree. } diff --git a/man/inferRelatedness.Rd b/man/inferRelatedness.Rd index dba7a0ed..1dd8b17c 100644 --- a/man/inferRelatedness.Rd +++ b/man/inferRelatedness.Rd @@ -2,9 +2,12 @@ % Please edit documentation in R/computeRelatedness.R \name{inferRelatedness} \alias{inferRelatedness} +\alias{relatedness} \title{Infer Relatedness Coefficient} \usage{ inferRelatedness(obsR, aceA = 0.9, aceC = 0, sharedC = 0) + +relatedness(...) } \arguments{ \item{obsR}{Numeric. Observed correlation between the two groups. Must be between -1 and 1.} @@ -14,6 +17,8 @@ inferRelatedness(obsR, aceA = 0.9, aceC = 0, sharedC = 0) \item{aceC}{Numeric. Proportion of variance attributable to shared environmental variance. Must be between 0 and 1. Default is 0.} \item{sharedC}{Numeric. Proportion of shared environment shared between the two individuals. Must be between 0 (no shared environment) and 1 (completely shared environment). Default is 0.} + +\item{...}{Further named arguments that may be passed to another function.} } \value{ Numeric. The calculated relatedness coefficient (`est_r`). diff --git a/man/related_coef.Rd b/man/related_coef.Rd deleted file mode 100644 index 11112982..00000000 --- a/man/related_coef.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/helpGeneric.R -\name{related_coef} -\alias{related_coef} -\title{related_coef (Deprecated)} -\usage{ -related_coef(...) -} -\arguments{ -\item{...}{Arguments to be passed to `calculateRelatedness`.} -} -\value{ -The same result as calling `calculateRelatedness`. -} -\description{ -When calling this function, a warning will be issued about its deprecation. -} -\details{ -This function is a wrapper around the new `calculateRelatedness` function. -`related_coef` has been deprecated, and it's advised to use `calculateRelatedness` directly. -} -\examples{ -\dontrun{ -# This is an example of the deprecated function: -related_coef(...) -# It is recommended to use: -calculateRelatedness(...) -} -} -\seealso{ -\code{\link{calculateRelatedness}} for the updated function. -} -\keyword{deprecated} diff --git a/man/relatedness.Rd b/man/relatedness.Rd deleted file mode 100644 index f84740df..00000000 --- a/man/relatedness.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/helpGeneric.R -\name{relatedness} -\alias{relatedness} -\title{relatedness (Deprecated)} -\usage{ -relatedness(...) -} -\arguments{ -\item{...}{Arguments to be passed to `inferRelatedness`.} -} -\value{ -The same result as calling `inferRelatedness`. -} -\description{ -When calling this function, a warning will be issued about its deprecation. -} -\details{ -This function is a wrapper around the new `inferRelatedness` function. -`relatedness` has been deprecated, and it's advised to use `inferRelatedness` directly. -} -\examples{ -\dontrun{ -# This is an example of the deprecated function: -relatedness(...) -# It is recommended to use: -inferRelatedness(...) -} -} -\seealso{ -\code{\link{inferRelatedness}} for the updated function. -} -\keyword{deprecated} diff --git a/man/repairIDs.Rd b/man/repairIDs.Rd index 2ce49f7a..cc37d78f 100644 --- a/man/repairIDs.Rd +++ b/man/repairIDs.Rd @@ -7,9 +7,9 @@ repairIDs(ped, verbose = FALSE) } \arguments{ -\item{ped}{A pedigree object} +\item{ped}{A dataframe representing the pedigree data with columns `ID`, `dadID`, and `momID`.} -\item{verbose}{A logical indicating whether to print progress messages} +\item{verbose}{A logical flag indicating whether to print progress and validation messages to the console.} } \value{ A corrected pedigree diff --git a/man/simulatePedigree.Rd b/man/simulatePedigree.Rd index a2e07b23..b7c28650 100644 --- a/man/simulatePedigree.Rd +++ b/man/simulatePedigree.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/simulatePedigree.R \name{simulatePedigree} \alias{simulatePedigree} +\alias{SimPed} \title{Simulate Pedigrees This function simulates "balanced" pedigrees based on a group of parameters: 1) k - Kids per couple; @@ -19,6 +20,8 @@ simulatePedigree( balancedMar = TRUE, verbose = FALSE ) + +SimPed(...) } \arguments{ \item{kpc}{Number of kids per couple. An integer >= 2 that determines how many kids each fertilized mated couple will have in the pedigree. Default value is 3. Returns an error when kpc equals 1.} @@ -36,6 +39,8 @@ simulatePedigree( \item{balancedMar}{Not fully developed yet. Always \code{TRUE} in the current version.} \item{verbose}{logical If TRUE, print progress through stages of algorithm} + +\item{...}{Additional arguments to be passed to other functions.} } \value{ A \code{data.frame} with each row representing a simulated individual. The columns are as follows: From 7f249101de4e10259cf8bd28abbc1ede8e2def2c Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Wed, 9 Apr 2025 23:04:00 -0400 Subject: [PATCH 18/69] Updatedocs --- .gitignore | 1 + R/checkIDs.R | 5 +- R/checkParents.R | 48 +- R/helpGeneric.R | 6 - R/makeLinks.R | 499 ++++++++++++++++++- benchmark_results.csv | 4 + data-raw/benchmark.R | 81 ++- man/{addPhantoms.Rd => addRowlessParents.Rd} | 8 +- tests/testthat/test-checkParents.R | 2 +- tests/testthat/test-makeLinks.R | 90 ++++ 10 files changed, 688 insertions(+), 56 deletions(-) create mode 100644 benchmark_results.csv rename man/{addPhantoms.Rd => addRowlessParents.Rd} (75%) diff --git a/.gitignore b/.gitignore index 8faabc57..dc07da73 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,4 @@ ASOIAF.ged .vscode/launch.json dataRelatedPairs_new2.csv data-raw/ASOIAF_040725.ged +dataRelatedPairs.csv diff --git a/R/checkIDs.R b/R/checkIDs.R index 4c1100fd..b687f4c7 100644 --- a/R/checkIDs.R +++ b/R/checkIDs.R @@ -28,12 +28,12 @@ checkIDs <- function(ped, verbose = FALSE, repair = FALSE) { } # Identify non-unique IDs - id_check <- checkIDuniqueness(ped=ped, verbose=verbose) + id_check <- checkIDuniqueness(ped = ped, verbose = verbose) if (verbose) { cat("Step 2: Checking for within row duplicats...\n") } - row_check <- checkWithinRowDuplicates(ped=ped, verbose = verbose) + row_check <- checkWithinRowDuplicates(ped = ped, verbose = verbose) validation_results <- c(id_check, row_check) @@ -166,4 +166,3 @@ checkWithinRowDuplicates <- function(ped, verbose = FALSE) { duplicated_parents_ids = if (length(duplicated_parents) > 0) unique(duplicated_parents) else NULL ) } - diff --git a/R/checkParents.R b/R/checkParents.R index 3c680e77..b80669bf 100644 --- a/R/checkParents.R +++ b/R/checkParents.R @@ -250,39 +250,10 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, cat("Added phantom moms for:", paste(changes$phantom_moms_added, collapse = ", "), "\n") } } - # add phantom parents + # add parents who appear in momID or dadID but are missing from ID if (parentswithoutrow) { # Add parents who appear in momID or dadID but are missing from ID - listed_parents <- unique(c(ped$momID, ped$dadID)) - listed_parents <- listed_parents[!is.na(listed_parents)] - - existing_ids <- ped$ID - missing_parents <- setdiff(listed_parents, existing_ids) - - if (length(missing_parents) > 0) { - if (verbose) { - cat("Adding parents who were listed in momID/dadID but missing from ID:\n") - print(missing_parents) - } - - for (pid in missing_parents) { - role <- unique( - c( - if (pid %in% ped$momID) "mom" else NULL, - if (pid %in% ped$dadID) "dad" else NULL - ) - ) - inferred_sex <- if ("mom" %in% role) validation_results$female_var else validation_results$male_var - - new_row <- ped[1, ] - new_row$ID <- pid - new_row$dadID <- NA - new_row$momID <- NA - new_row$sex <- inferred_sex - new_entries <- rbind(new_entries, new_row) - } - } - ped <- merge(ped, new_entries, all = TRUE) + ped <- addRowlessParents(ped = ped, verbose = verbose, validation_results = validation_results) } if (verbose) { @@ -301,13 +272,13 @@ repairParentIDs <- function(ped, verbose = FALSE) { checkParentIDs(ped = ped, verbose = verbose, repair = TRUE) } -#' Add Phantom Parents +#' Add addRowlessParents #' -#' This function adds phantom parents to a pedigree. +#' This function adds parents who appear in momID or dadID but are missing from ID #' @inheritParams checkParentIDs #' @param validation_results validation results -addPhantoms <- function(ped, verbose, validation_results) { +addRowlessParents <- function(ped, verbose, validation_results) { # Add parents who appear in momID or dadID but are missing from ID new_entries <- data.frame() @@ -339,10 +310,11 @@ addPhantoms <- function(ped, verbose, validation_results) { new_row$sex <- inferred_sex new_entries <- rbind(new_entries, new_row) } - } - ped <- merge(ped, new_entries, all = TRUE) - if (verbose) { - cat("Added phantom parents for:", paste(new_entries$ID, collapse = ", "), "\n") + + ped <- merge(ped, new_entries, all = TRUE) + if (verbose) { + cat("Added phantom parents for:", paste(new_entries$ID, collapse = ", "), "\n") + } } return(ped) } diff --git a/R/helpGeneric.R b/R/helpGeneric.R index 8b376bfb..8dae2b2c 100644 --- a/R/helpGeneric.R +++ b/R/helpGeneric.R @@ -97,9 +97,3 @@ resample <- function(x, ...) { } x[sample.int(length(x), ...)] } - - - - - - diff --git a/R/makeLinks.R b/R/makeLinks.R index d2dc6a65..930d3d2b 100644 --- a/R/makeLinks.R +++ b/R/makeLinks.R @@ -78,6 +78,9 @@ com2links <- function( # Extract individual IDs from the first available matrix. ids <- NULL + + + if (!is.null(cn_ped_matrix)) { ids <- as.numeric(dimnames(cn_ped_matrix)[[1]]) nc <- ncol(cn_ped_matrix) @@ -93,6 +96,15 @@ com2links <- function( stop("Could not extract IDs from the provided matrices.") } + + # Construct case identifier + matrix_case <- paste(sort(c( + if (!is.null(ad_ped_matrix)) "ad" else NULL, + if (!is.null(mit_ped_matrix)) "mt" else NULL, + if (!is.null(cn_ped_matrix)) "cn" else NULL + )), collapse = "-") + + # Count how many matrices are provided. sum_nulls <- sum(!is.null(ad_ped_matrix), !is.null(mit_ped_matrix), @@ -100,7 +112,7 @@ com2links <- function( na.rm = TRUE ) if (verbose) { - print(sum_nulls) + print(matrix_case) } # Extract the internal pointers (p, i, and x slots) for each provided matrix. @@ -633,6 +645,491 @@ com2links.legacy <- function( return(NULL) } +com2links.beta <- function( + rel_pairs_file = "dataRelatedPairs.csv", + ad_ped_matrix = NULL, + mit_ped_matrix = mt_ped_matrix, + mt_ped_matrix = NULL, + cn_ped_matrix = NULL, + # pat_ped_matrix = NULL, + # mat_ped_matrix = NULL, + # mapa_id_file = "data_mapaID.csv", + write_buffer_size = 1000, + update_rate = 1000, + gc = TRUE, + writetodisk = TRUE, + verbose = FALSE, + legacy = FALSE, + outcome_name = "data", + drop_upper_triangular = TRUE, + ...) { + # --- Input Validations and Preprocessing --- + + # Ensure that at least one relationship matrix is provided. + if (is.null(ad_ped_matrix) && is.null(mit_ped_matrix) && is.null(cn_ped_matrix)) { + stop("At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided.") + } + # Validate and convert ad_ped_matrix to a sparse dgCMatrix if provided. + if (!is.null(ad_ped_matrix)) { + ad_ped_matrix <- validate_and_convert_matrix( + mat = ad_ped_matrix, + name = "ad_ped_matrix" + ) + } + + # Validate and convert cn_ped_matrix to a sparse dgCMatrix if provided. + if (!is.null(cn_ped_matrix)) { + cn_ped_matrix <- validate_and_convert_matrix( + mat = cn_ped_matrix, + name = "cn_ped_matrix", + ensure_symmetric = TRUE + ) + } + + # Validate and process mit_ped_matrix: convert and ensure binary values. + if (!is.null(mit_ped_matrix)) { + mit_ped_matrix <- validate_and_convert_matrix( + mat = mit_ped_matrix, + name = "mit_ped_matrix", force_binary = TRUE, + ensure_symmetric = TRUE + ) + } + + # --- Build IDs and Prepare Matrix Pointers --- + + # Extract individual IDs from the first available matrix. + ids <- NULL + + + + if (!is.null(cn_ped_matrix)) { + ids <- as.numeric(dimnames(cn_ped_matrix)[[1]]) + nc <- ncol(cn_ped_matrix) + } else if (!is.null(ad_ped_matrix)) { + ids <- as.numeric(dimnames(ad_ped_matrix)[[1]]) + nc <- ncol(ad_ped_matrix) + } else if (!is.null(mit_ped_matrix)) { + ids <- as.numeric(dimnames(mit_ped_matrix)[[1]]) + nc <- ncol(mit_ped_matrix) + } + + if (is.null(ids)) { + stop("Could not extract IDs from the provided matrices.") + } + + # --- matrix_case construction and switch dispatch --- + matrix_case <- paste(sort(c( + if (!is.null(ad_ped_matrix)) "ad" else NULL, + if (!is.null(mit_ped_matrix)) "mt" else NULL, + if (!is.null(cn_ped_matrix)) "cn" else NULL + )), collapse = "-") + + if (verbose) { + print(matrix_case) + } + + switch(matrix_case, + "ad" = process_one( + matrix = ad_ped_matrix, + rel_name = "addRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "mt" = process_one( + matrix = mit_ped_matrix, + rel_name = "mitRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "cn" = process_one( + matrix = cn_ped_matrix, + rel_name = "cnuRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "ad-mt" = process_two( + matrix1 = ad_ped_matrix, + name1 = "addRel", + matrix2 = mit_ped_matrix, + name2 = "mitRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "ad-cn" = process_two( + matrix1 = ad_ped_matrix, + name1 = "addRel", + matrix2 = cn_ped_matrix, + name2 = "cnuRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "cn-mt" = process_two( + matrix1 = cn_ped_matrix, + name1 = "cnuRel", + matrix2 = mit_ped_matrix, + name2 = "mitRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "ad-cn-mt" = process_all_three( + mat1 = ad_ped_matrix, + name1 = "addRel", + mat2 = mit_ped_matrix, + name2 = "mitRel", + mat3 = cn_ped_matrix, + name3 = "cnuRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + stop("Unsupported matrix combination") + ) +} + +process_one <- function(matrix, rel_name, ids, nc, rel_pairs_file, writetodisk, write_buffer_size, drop_upper_triangular, update_rate, verbose, gc, ...) { + # Extract pointers and indices from the matrix. + newColPos <- matrix@p + 1L + iss <- matrix@i + 1L + x <- matrix@x + + # Initialize the related pairs file with headers. + df_relpairs <- initialize_empty_df(relNames = rel_name) + + if (writetodisk == TRUE) { + utils::write.table( + df_relpairs, + file = rel_pairs_file, sep = ",", append = FALSE, row.names = FALSE + ) + + # Prepare an empty buffer for batching writes. + write_buffer <- list() + remove(df_relpairs) + } + + # Process each column in the matrix. + for (j in 1L:nc) { + ID2 <- ids[j] + + # Extract column indices + ncp <- newColPos[j] + ncpp <- newColPos[j + 1L] + cond <- ncp < ncpp + if (cond) { + vv <- ncp:(ncpp - 1L) + issvv <- iss[vv] + } + + # Create a unique set of row indices. + u <- sort(issvv) + + # If any relationships exist for this individual, build the related pairs. + if (cond) { + ID1 <- ids[u] + tds <- data.frame(ID1 = ID1, ID2 = ID2) + tds[[rel_name]] <- 0 + + if (cond) { + tds[u %in% issvv, rel_name] <- x[vv] + } + if (drop_upper_triangular == TRUE) { + tds <- tds[tds$ID1 <= tds$ID2, ] # or < if you want strictly lower triangle + } + + # Write the batch to disk or accumulate in the data frame. + if (nrow(tds) > 0) { + if (writetodisk == TRUE) { + write_buffer[[length(write_buffer) + 1]] <- tds + + if (length(write_buffer) >= write_buffer_size) { # Write in batches + utils::write.table(do.call(rbind, write_buffer), + file = rel_pairs_file, + row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," + ) + write_buffer <- list() + } + } else { + df_relpairs <- rbind(df_relpairs, tds) + } + } + } + if (verbose && (j %% update_rate == 0L)) { + cat("Done with", j, "of", nc, "\n") + } + } + # If not writing to disk, return the accumulated data frame. + if (writetodisk == FALSE) { + return(df_relpairs) + } else { + # Write any remaining buffered rows. + if (length(write_buffer) > 0) { + utils::write.table(do.call(rbind, write_buffer), + file = rel_pairs_file, + row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," + ) + } + } + if (gc == TRUE) { + remove(newColPos, iss, x) + } +} + +process_all_three <- function( + mat1, name1, + mat2, name2, + mat3, name3, + ids, nc, + rel_pairs_file, + writetodisk, + write_buffer_size, + drop_upper_triangular, + update_rate, + verbose, + gc, + ...) { + # Extract matrix slots + p1 <- mat1@p + 1L + i1 <- mat1@i + 1L + x1 <- mat1@x + p2 <- mat2@p + 1L + i2 <- mat2@i + 1L + x2 <- mat2@x + p3 <- mat3@p + 1L + i3 <- mat3@i + 1L + x3 <- mat3@x + + relNames <- c(name1, name2, name3) + df_relpairs <- initialize_empty_df(relNames) + + if (writetodisk) { + utils::write.table(df_relpairs, file = rel_pairs_file, sep = ",", append = FALSE, row.names = FALSE) + write_buffer <- list() + rm(df_relpairs) + } + + for (j in seq_len(nc)) { + ID2 <- ids[j] + + # Get index spans + v1 <- if (p1[j] < p1[j + 1L]) { + idx <- p1[j]:(p1[j + 1L] - 1L) + list(i = i1[idx], x = x1[idx]) + } else { + NULL + } + v2 <- if (p2[j] < p2[j + 1L]) { + idx <- p2[j]:(p2[j + 1L] - 1L) + list(i = i2[idx], x = x2[idx]) + } else { + NULL + } + v3 <- if (p3[j] < p3[j + 1L]) { + idx <- p3[j]:(p3[j + 1L] - 1L) + list(i = i3[idx], x = x3[idx]) + } else { + NULL + } + + # Union of index positions + u <- sort(unique(c( + if (!is.null(v1)) v1$i else NULL, + if (!is.null(v2)) v2$i else NULL, + if (!is.null(v3)) v3$i else NULL + ))) + if (length(u) > 0) { + ID1 <- ids[u] + tds <- data.frame(ID1 = ID1, ID2 = ID2) + tds[[name1]] <- if (!is.null(v1)) ifelse(u %in% v1$i, v1$x[match(u, v1$i)], 0) else 0 + tds[[name2]] <- if (!is.null(v2)) ifelse(u %in% v2$i, v2$x[match(u, v2$i)], 0) else 0 + tds[[name3]] <- if (!is.null(v3)) ifelse(u %in% v3$i, v3$x[match(u, v3$i)], 0) else 0 + + if (drop_upper_triangular) { + tds <- tds[tds$ID1 <= tds$ID2, ] + } + + if (nrow(tds) > 0) { + if (writetodisk) { + write_buffer[[length(write_buffer) + 1L]] <- tds + if (length(write_buffer) >= write_buffer_size) { + utils::write.table(do.call(rbind, write_buffer), + file = rel_pairs_file, row.names = FALSE, + col.names = FALSE, append = TRUE, sep = "," + ) + write_buffer <- list() + } + } else { + df_relpairs <- rbind(df_relpairs, tds) + } + } + } + + if (verbose && (j %% update_rate == 0L)) { + cat("Done with", j, "of", nc, "\n") + } + } + + if (!writetodisk) { + return(df_relpairs) + } else if (length(write_buffer) > 0) { + utils::write.table(do.call(rbind, write_buffer), + file = rel_pairs_file, row.names = FALSE, + col.names = FALSE, append = TRUE, sep = "," + ) + } + + invisible(NULL) +} + +process_two <- function( + matrix1, name1, + matrix2, name2, + ids, nc, + rel_pairs_file, + writetodisk, + write_buffer_size, + drop_upper_triangular, + update_rate, + verbose, + gc, + ...) { + # Extract internal slots + p1 <- matrix1@p + 1L + i1 <- matrix1@i + 1L + x1 <- matrix1@x + p2 <- matrix2@p + 1L + i2 <- matrix2@i + 1L + x2 <- matrix2@x + + relNames <- c(name1, name2) + df_relpairs <- initialize_empty_df(relNames) + + if (writetodisk) { + utils::write.table(df_relpairs, file = rel_pairs_file, sep = ",", append = FALSE, row.names = FALSE) + write_buffer <- list() + rm(df_relpairs) + } + + for (j in seq_len(nc)) { + ID2 <- ids[j] + + # Get index/value slices + v1 <- if (p1[j] < p1[j + 1L]) { + idx <- p1[j]:(p1[j + 1L] - 1L) + list(i = i1[idx], x = x1[idx]) + } else { + NULL + } + v2 <- if (p2[j] < p2[j + 1L]) { + idx <- p2[j]:(p2[j + 1L] - 1L) + list(i = i2[idx], x = x2[idx]) + } else { + NULL + } + + # Union of indices from both matrices + u <- sort(unique(c( + if (!is.null(v1)) v1$i else NULL, + if (!is.null(v2)) v2$i else NULL + ))) + + if (length(u) > 0) { + ID1 <- ids[u] + tds <- data.frame(ID1 = ID1, ID2 = ID2) + tds[[name1]] <- if (!is.null(v1)) ifelse(u %in% v1$i, v1$x[match(u, v1$i)], 0) else 0 + tds[[name2]] <- if (!is.null(v2)) ifelse(u %in% v2$i, v2$x[match(u, v2$i)], 0) else 0 + + if (drop_upper_triangular) { + tds <- tds[tds$ID1 <= tds$ID2, ] + } + + if (nrow(tds) > 0) { + if (writetodisk) { + write_buffer[[length(write_buffer) + 1L]] <- tds + if (length(write_buffer) >= write_buffer_size) { + utils::write.table(do.call(rbind, write_buffer), + file = rel_pairs_file, row.names = FALSE, + col.names = FALSE, append = TRUE, sep = "," + ) + write_buffer <- list() + } + } else { + df_relpairs <- rbind(df_relpairs, tds) + } + } + } + + if (verbose && (j %% update_rate == 0L)) { + cat("Done with", j, "of", nc, "\n") + } + } + + if (!writetodisk) { + return(df_relpairs) + } else if (length(write_buffer) > 0) { + utils::write.table(do.call(rbind, write_buffer), + file = rel_pairs_file, row.names = FALSE, + col.names = FALSE, append = TRUE, sep = "," + ) + } + + invisible(NULL) +} + + #' @title validate_and_convert_matrix #' @description #' This function validates and converts a matrix to a specific format. diff --git a/benchmark_results.csv b/benchmark_results.csv new file mode 100644 index 00000000..efe84ed8 --- /dev/null +++ b/benchmark_results.csv @@ -0,0 +1,4 @@ +"expr","min","lq","mean","median","uq","max","neval" +"beta",430.4392,516.5138,574.575919,563.7353,623.24015,956.2494,100 +"regular",424.8536,507.47875,578.514,564.8453,631.97425,997.8213,100 +"legacy",580.1082,1392.24995,2086.481802,1783.02635,2686.8328,4768.9119,100 diff --git a/data-raw/benchmark.R b/data-raw/benchmark.R index fe480cdf..536190b1 100644 --- a/data-raw/benchmark.R +++ b/data-raw/benchmark.R @@ -2,7 +2,7 @@ library(microbenchmark) library(Matrix) # library(BGmisc) # data("hazard") - +library(tidyverse) # make big data set.seed(15) @@ -10,8 +10,34 @@ Ngen <- 5 kpc <- 5 sexR <- .50 marR <- .7 -ped <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) - +ped <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) %>% + mutate( + fam = "fam 1" + ) +set.seed(151) +Ngen <- 5 +marR <- .8 +ped2 <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) %>% + mutate( + fam = "fam 2", + ID = ID + 10000, + momID = momID + 10000, + dadID = dadID + 10000, + spID = spID + 10000 + ) +set.seed(1151) +kpc <- 8 +ped3 <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) %>% + mutate( + fam = "fam 3", + ID = ID + 20000, + momID = momID + 20000, + dadID = dadID + 20000, + spID = spID + 20000 + ) +ped <- rbind(ped, ped2) +ped <- rbind(ped, ped3) +if(FALSE){ # Define parameters component <- "additive" # Change this to test different components saveable <- FALSE # Disable saving to avoid disk I/O slowing down benchmarking @@ -52,9 +78,58 @@ benchmark_results <- microbenchmark( times = 100 # Run each method 100 times ) +summary(benchmark_results) + +lm(benchmark_results$time ~ benchmark_results$expr) %>% + summary() +# Print benchmark results +print(benchmark_results) + +# Optional: Save results to CSV for later analysis +write.csv(summary(benchmark_results), + "benchmark_results.csv", + row.names = FALSE +) # Print benchmark +} +verbose=FALSE +ad_ped_matrix <- ped2com(ped, component = "additive", adjacency_method = "direct", sparse = TRUE) +mit_ped_matrix <- ped2com(ped, component = "mitochondrial", adjacency_method = "direct", sparse = TRUE) +cn_ped_matrix <- ped2com(ped, component = "common nuclear", adjacency_method = "indexed", sparse = TRUE) +benchmark_results <- microbenchmark( + beta = { + com2links.beta( + ad_ped_matrix = ad_ped_matrix, + mit_ped_matrix = mit_ped_matrix, + cn_ped_matrix = cn_ped_matrix, + writetodisk = TRUE, + verbose = verbose +); file.remove("dataRelatedPairs.csv") + }, regular = { + com2links( + ad_ped_matrix = ad_ped_matrix, + mit_ped_matrix = mit_ped_matrix, + cn_ped_matrix = cn_ped_matrix, + writetodisk = TRUE, + verbose = verbose + ); file.remove("dataRelatedPairs.csv") + }, legacy = { + com2links( + ad_ped_matrix = ad_ped_matrix, + mit_ped_matrix = mit_ped_matrix, + cn_ped_matrix = cn_ped_matrix, + verbose = verbose, + legacy = TRUE + ); file.remove("dataRelatedPairs.csv") + }, + + times = 100 # Run each method 100 times +) +summary(benchmark_results) +lm(benchmark_results$time ~ benchmark_results$expr) %>% + summary() # Print benchmark results print(benchmark_results) diff --git a/man/addPhantoms.Rd b/man/addRowlessParents.Rd similarity index 75% rename from man/addPhantoms.Rd rename to man/addRowlessParents.Rd index bafe5b75..8161ee4e 100644 --- a/man/addPhantoms.Rd +++ b/man/addRowlessParents.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/checkParents.R -\name{addPhantoms} -\alias{addPhantoms} +\name{addRowlessParents} +\alias{addRowlessParents} \title{Add Phantom Parents} \usage{ -addPhantoms(ped, verbose, validation_results) +addRowlessParents(ped, verbose, validation_results) } \arguments{ \item{ped}{A dataframe representing the pedigree data with columns 'ID', 'dadID', and 'momID'.} @@ -14,5 +14,5 @@ addPhantoms(ped, verbose, validation_results) \item{validation_results}{validation results} } \description{ -This function adds phantom parents to a pedigree. +This function adds parents w } diff --git a/tests/testthat/test-checkParents.R b/tests/testthat/test-checkParents.R index 21660c4b..50916289 100644 --- a/tests/testthat/test-checkParents.R +++ b/tests/testthat/test-checkParents.R @@ -22,6 +22,6 @@ test_that("checksif single parents found correctly in ASOIAF dataset", { single_moms <- length(df_asoiaf$id[is.na(df_asoiaf$dadID) & !is.na(df_asoiaf$momID)]) expect_equal(single_moms, length(results$missing_fathers)) expect_equal(single_dads, length(results$missing_mothers)) - repaired_df <- checkParentIDs(df_asoiaf, verbose = FALSE, repair = TRUE) + repaired_df <- checkParentIDs(df_asoiaf, verbose = FALSE, repair = TRUE, parentswithoutrow = TRUE) expect_equal(nrow(repaired_df), nrow(df_asoiaf) + single_moms + single_dads) }) diff --git a/tests/testthat/test-makeLinks.R b/tests/testthat/test-makeLinks.R index 475f7b6b..200b8934 100644 --- a/tests/testthat/test-makeLinks.R +++ b/tests/testthat/test-makeLinks.R @@ -108,6 +108,17 @@ test_that("com2links legacy works", { expect_true(all(c("ID1", "ID2", "addRel", "mitRel", "cnuRel") %in% colnames(written_data))) + + result_beta <- com2links.beta( + ad_ped_matrix = ad_ped_matrix, + mit_ped_matrix = mit_ped_matrix, cn_ped_matrix = cn_ped_matrix, + writetodisk = FALSE + ) + + expect_true(is.data.frame(result_beta)) + expect_true(all(c("ID1", "ID2", "addRel", "mitRel", "cnuRel") %in% colnames(result_beta))) + + result <- com2links( ad_ped_matrix = ad_ped_matrix, mit_ped_matrix = mit_ped_matrix, cn_ped_matrix = cn_ped_matrix, @@ -115,15 +126,94 @@ test_that("com2links legacy works", { ) expect_true(is.data.frame(result)) + expect_true(all(c("ID1", "ID2", "addRel", "mitRel", "cnuRel") %in% colnames(result))) # Drop row names to avoid mismatches in expect_equal rownames(result) <- NULL rownames(written_data) <- NULL + rownames(result_beta) <- NULL # Final comparison between written versions expect_equal(written_data, result) + expect_equal(result_beta, result) }) +test_that("com2links beta works", { + data(hazard) + ad_ped_matrix <- ped2com(hazard, component = "additive", adjacency_method = "direct", sparse = TRUE) + mit_ped_matrix <- ped2com(hazard, component = "mitochondrial", adjacency_method = "direct", sparse = TRUE) + cn_ped_matrix <- ped2com(hazard, component = "common nuclear", adjacency_method = "indexed", sparse = TRUE) + + # compare 2 + result_beta <- com2links.beta( + ad_ped_matrix = ad_ped_matrix, + mit_ped_matrix = mit_ped_matrix, + writetodisk = FALSE + ) + + expect_true(is.data.frame(result_beta)) + expect_true(all(c("ID1", "ID2", "addRel", "mitRel") %in% colnames(result_beta))) + + + result <- com2links( + ad_ped_matrix = ad_ped_matrix, + mit_ped_matrix = mit_ped_matrix, + writetodisk = FALSE + ) + + expect_true(is.data.frame(result)) + expect_true(all(c("ID1", "ID2", "addRel", "mitRel") %in% colnames(result))) + # Drop row names to avoid mismatches in expect_equal + rownames(result) <- NULL + rownames(result_beta) <- NULL + + # Final comparison between versions + expect_equal(result_beta, result) + + + # write to disk + result_disk <- com2links.beta( + ad_ped_matrix = ad_ped_matrix, + mit_ped_matrix = mit_ped_matrix, + writetodisk = TRUE + ) + expect_true(file.exists("dataRelatedPairs.csv")) + written_data <- read.csv("dataRelatedPairs.csv") + # remove the file + expect_true(file.remove("dataRelatedPairs.csv")) + + expect_true(all(c("ID1", "ID2", "addRel", "mitRel") %in% colnames(written_data))) + rownames(written_data) <- NULL + expect_equal(result_beta, written_data) + expect_equal(result, written_data) + # compare 1 + + result_beta <- com2links.beta( + mit_ped_matrix = mit_ped_matrix, + writetodisk = FALSE + ) + + expect_true(is.data.frame(result_beta)) + expect_true(all(c("ID1", "ID2", "mitRel") %in% colnames(result_beta))) + + + result <- com2links( + mit_ped_matrix = mit_ped_matrix, + writetodisk = FALSE + ) + + expect_true(is.data.frame(result)) + expect_true(all(c("ID1", "ID2", "mitRel") %in% colnames(result))) + # Drop row names to avoid mismatches in expect_equal + rownames(result) <- NULL + rownames(result_beta) <- NULL + + # Final comparison between versions + expect_equal(result_beta, result) +}) + + + test_that("com2links correctly handles missing matrices", { data(hazard) From 61fb620c45124b84a590f7fac0c8740a951106fa Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Thu, 10 Apr 2025 00:16:11 -0400 Subject: [PATCH 19/69] renaming beta --- R/makeLinks.R | 21 ++++++++++++----- benchmark_results.csv | 6 ++--- man/addRowlessParents.Rd | 4 ++-- man/com2links.Rd | 3 --- man/com2links.legacy.Rd | 27 +++++++++++++++++++--- man/com2links.og.Rd | 41 +++++++++++++++++++++++++++++++++ tests/testthat/test-makeLinks.R | 14 +++++------ 7 files changed, 92 insertions(+), 24 deletions(-) create mode 100644 man/com2links.og.Rd diff --git a/R/makeLinks.R b/R/makeLinks.R index 930d3d2b..7bbdb082 100644 --- a/R/makeLinks.R +++ b/R/makeLinks.R @@ -20,8 +20,9 @@ #' @param ... Additional arguments to be passed to \code{\link{com2links}} #' #' @return A data frame of related pairs if \code{writetodisk} is FALSE; otherwise, writes the results to disk. -#' @export -com2links <- function( +#' @keywords internal + +com2links.legacy <- function( rel_pairs_file = "dataRelatedPairs.csv", ad_ped_matrix = NULL, mit_ped_matrix = mt_ped_matrix, @@ -498,7 +499,7 @@ com2links <- function( } else if (legacy) { # --- Legacy Mode --- # In legacy mode, convert matrices to the expected symmetric formats. - com2links.legacy( + com2links.og( rel_pairs_file = rel_pairs_file, ad_ped_matrix = ad_ped_matrix, mit_ped_matrix = mit_ped_matrix, @@ -521,9 +522,11 @@ com2links <- function( #' Convert Pedigree Matrices to Related Pairs File (Legacy) #' @description #' This legacy function converts pedigree matrices into a related pairs file. -#' @inheritParams com2links +#' @inheritParams com2links.legacy +#' @keywords internal -com2links.legacy <- function( + +com2links.og <- function( rel_pairs_file = "dataRelatedPairs.csv", ad_ped_matrix = NULL, mit_ped_matrix = mt_ped_matrix, @@ -645,7 +648,13 @@ com2links.legacy <- function( return(NULL) } -com2links.beta <- function( +#' Convert Sparse Relationship Matrices to Kinship Links +#' @inheritParams com2links.legacy +#' @inherit com2links.legacy description +#' @inherit com2links.legacy details +#' @export + +com2links <- function( rel_pairs_file = "dataRelatedPairs.csv", ad_ped_matrix = NULL, mit_ped_matrix = mt_ped_matrix, diff --git a/benchmark_results.csv b/benchmark_results.csv index efe84ed8..192b22dd 100644 --- a/benchmark_results.csv +++ b/benchmark_results.csv @@ -1,4 +1,4 @@ "expr","min","lq","mean","median","uq","max","neval" -"beta",430.4392,516.5138,574.575919,563.7353,623.24015,956.2494,100 -"regular",424.8536,507.47875,578.514,564.8453,631.97425,997.8213,100 -"legacy",580.1082,1392.24995,2086.481802,1783.02635,2686.8328,4768.9119,100 +"beta",16.0127553,19.82506435,22.108722786,21.26392435,23.70929065,33.0821112,100 +"regular",16.1161818,19.80905795,22.26289046694,21.25613265,24.39315385,33.3530921,100 +"legacy",32.0135859,39.7116454,43.55598528601,42.62947545,47.32561085,65.684218301,100 diff --git a/man/addRowlessParents.Rd b/man/addRowlessParents.Rd index 8161ee4e..83132805 100644 --- a/man/addRowlessParents.Rd +++ b/man/addRowlessParents.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/checkParents.R \name{addRowlessParents} \alias{addRowlessParents} -\title{Add Phantom Parents} +\title{Add addRowlessParents} \usage{ addRowlessParents(ped, verbose, validation_results) } @@ -14,5 +14,5 @@ addRowlessParents(ped, verbose, validation_results) \item{validation_results}{validation results} } \description{ -This function adds parents w +This function adds parents who appear in momID or dadID but are missing from ID } diff --git a/man/com2links.Rd b/man/com2links.Rd index 9dae2f09..e9c7ac2b 100644 --- a/man/com2links.Rd +++ b/man/com2links.Rd @@ -50,9 +50,6 @@ com2links( \item{...}{Additional arguments to be passed to \code{\link{com2links}}} } -\value{ -A data frame of related pairs if \code{writetodisk} is FALSE; otherwise, writes the results to disk. -} \description{ This function processes one or more sparse relationship components (additive, mitochondrial, and common nuclear) and converts them into kinship link pairs. The resulting related pairs are diff --git a/man/com2links.legacy.Rd b/man/com2links.legacy.Rd index 757117a1..a523a106 100644 --- a/man/com2links.legacy.Rd +++ b/man/com2links.legacy.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/makeLinks.R \name{com2links.legacy} \alias{com2links.legacy} -\title{Convert Pedigree Matrices to Related Pairs File (Legacy)} +\title{Convert Sparse Relationship Matrices to Kinship Links} \usage{ com2links.legacy( rel_pairs_file = "dataRelatedPairs.csv", @@ -10,9 +10,14 @@ com2links.legacy( mit_ped_matrix = mt_ped_matrix, mt_ped_matrix = NULL, cn_ped_matrix = NULL, - update_rate = 500, + write_buffer_size = 1000, + update_rate = 1000, + gc = TRUE, + writetodisk = TRUE, verbose = FALSE, + legacy = FALSE, outcome_name = "data", + drop_upper_triangular = TRUE, ... ) } @@ -27,14 +32,30 @@ com2links.legacy( \item{cn_ped_matrix}{Matrix of common nuclear relatedness coefficients.} +\item{write_buffer_size}{Number of related pairs to write to disk at a time.} + \item{update_rate}{Numeric. Frequency (in iterations) at which progress messages are printed.} +\item{gc}{Logical. If TRUE, performs garbage collection via \code{\link{gc}} to free memory.} + +\item{writetodisk}{Logical. If TRUE, writes the related pairs to disk; if FALSE, returns a data frame.} + \item{verbose}{Logical. If TRUE, prints progress messages.} +\item{legacy}{Logical. If TRUE, uses the legacy branch of the function.} + \item{outcome_name}{Character string representing the outcome name (used in file naming).} +\item{drop_upper_triangular}{Logical. If TRUE, drops the upper triangular portion of the matrix.} + \item{...}{Additional arguments to be passed to \code{\link{com2links}}} } +\value{ +A data frame of related pairs if \code{writetodisk} is FALSE; otherwise, writes the results to disk. +} \description{ -This legacy function converts pedigree matrices into a related pairs file. +This function processes one or more sparse relationship components (additive, mitochondrial, +and common nuclear) and converts them into kinship link pairs. The resulting related pairs are +either returned as a data frame or written to disk in CSV format. } +\keyword{internal} diff --git a/man/com2links.og.Rd b/man/com2links.og.Rd new file mode 100644 index 00000000..b6c3d71b --- /dev/null +++ b/man/com2links.og.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/makeLinks.R +\name{com2links.og} +\alias{com2links.og} +\title{Convert Pedigree Matrices to Related Pairs File (Legacy)} +\usage{ +com2links.og( + rel_pairs_file = "dataRelatedPairs.csv", + ad_ped_matrix = NULL, + mit_ped_matrix = mt_ped_matrix, + mt_ped_matrix = NULL, + cn_ped_matrix = NULL, + update_rate = 500, + verbose = FALSE, + outcome_name = "data", + ... +) +} +\arguments{ +\item{rel_pairs_file}{File path to write related pairs to (CSV format).} + +\item{ad_ped_matrix}{Matrix of additive genetic relatedness coefficients.} + +\item{mit_ped_matrix}{Matrix of mitochondrial relatedness coefficients. Alias: \code{mt_ped_matrix}.} + +\item{mt_ped_matrix}{Matrix of mitochondrial relatedness coefficients.} + +\item{cn_ped_matrix}{Matrix of common nuclear relatedness coefficients.} + +\item{update_rate}{Numeric. Frequency (in iterations) at which progress messages are printed.} + +\item{verbose}{Logical. If TRUE, prints progress messages.} + +\item{outcome_name}{Character string representing the outcome name (used in file naming).} + +\item{...}{Additional arguments to be passed to \code{\link{com2links}}} +} +\description{ +This legacy function converts pedigree matrices into a related pairs file. +} +\keyword{internal} diff --git a/tests/testthat/test-makeLinks.R b/tests/testthat/test-makeLinks.R index 200b8934..a2666f2e 100644 --- a/tests/testthat/test-makeLinks.R +++ b/tests/testthat/test-makeLinks.R @@ -95,7 +95,7 @@ test_that("com2links legacy works", { mit_ped_matrix <- ped2com(hazard, component = "mitochondrial", adjacency_method = "direct", sparse = TRUE) cn_ped_matrix <- ped2com(hazard, component = "common nuclear", adjacency_method = "indexed", sparse = TRUE) - resultlegacy <- com2links( + resultlegacy <- com2links.legacy( ad_ped_matrix = ad_ped_matrix, mit_ped_matrix = mit_ped_matrix, cn_ped_matrix = cn_ped_matrix, legacy = TRUE @@ -109,7 +109,7 @@ test_that("com2links legacy works", { expect_true(all(c("ID1", "ID2", "addRel", "mitRel", "cnuRel") %in% colnames(written_data))) - result_beta <- com2links.beta( + result_beta <- com2links( ad_ped_matrix = ad_ped_matrix, mit_ped_matrix = mit_ped_matrix, cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE @@ -119,7 +119,7 @@ test_that("com2links legacy works", { expect_true(all(c("ID1", "ID2", "addRel", "mitRel", "cnuRel") %in% colnames(result_beta))) - result <- com2links( + result <- com2links.legacy( ad_ped_matrix = ad_ped_matrix, mit_ped_matrix = mit_ped_matrix, cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE @@ -145,7 +145,7 @@ test_that("com2links beta works", { cn_ped_matrix <- ped2com(hazard, component = "common nuclear", adjacency_method = "indexed", sparse = TRUE) # compare 2 - result_beta <- com2links.beta( + result_beta <- com2links( ad_ped_matrix = ad_ped_matrix, mit_ped_matrix = mit_ped_matrix, writetodisk = FALSE @@ -155,7 +155,7 @@ test_that("com2links beta works", { expect_true(all(c("ID1", "ID2", "addRel", "mitRel") %in% colnames(result_beta))) - result <- com2links( + result <- com2links.legacy( ad_ped_matrix = ad_ped_matrix, mit_ped_matrix = mit_ped_matrix, writetodisk = FALSE @@ -172,7 +172,7 @@ test_that("com2links beta works", { # write to disk - result_disk <- com2links.beta( + result_disk <- com2links( ad_ped_matrix = ad_ped_matrix, mit_ped_matrix = mit_ped_matrix, writetodisk = TRUE @@ -188,7 +188,7 @@ test_that("com2links beta works", { expect_equal(result, written_data) # compare 1 - result_beta <- com2links.beta( + result_beta <- com2links( mit_ped_matrix = mit_ped_matrix, writetodisk = FALSE ) From 2c0961cc070dda438c5839cdd0dc46bcf32b5f6a Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Thu, 10 Apr 2025 09:55:57 -0400 Subject: [PATCH 20/69] Update .gitignore --- .gitignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index dc07da73..f84ea082 100644 --- a/.gitignore +++ b/.gitignore @@ -12,7 +12,7 @@ tests/testthat/Rplots.pdf *.ASOIAF.ged ASOIAF.ged *.Rproj - +benchmark_results.csv .vscode/launch.json dataRelatedPairs_new2.csv data-raw/ASOIAF_040725.ged From edf27455ba0f12c93361cb0be118329e1afeeeef Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Thu, 10 Apr 2025 10:03:16 -0400 Subject: [PATCH 21/69] reorder coms --- R/makeLinks.R | 406 +++++++++++++++++++++++++------------------------- 1 file changed, 203 insertions(+), 203 deletions(-) diff --git a/R/makeLinks.R b/R/makeLinks.R index 7bbdb082..2894a3bf 100644 --- a/R/makeLinks.R +++ b/R/makeLinks.R @@ -20,7 +20,208 @@ #' @param ... Additional arguments to be passed to \code{\link{com2links}} #' #' @return A data frame of related pairs if \code{writetodisk} is FALSE; otherwise, writes the results to disk. -#' @keywords internal +#' @export com2links + +com2links <- function( + rel_pairs_file = "dataRelatedPairs.csv", + ad_ped_matrix = NULL, + mit_ped_matrix = mt_ped_matrix, + mt_ped_matrix = NULL, + cn_ped_matrix = NULL, + # pat_ped_matrix = NULL, + # mat_ped_matrix = NULL, + # mapa_id_file = "data_mapaID.csv", + write_buffer_size = 1000, + update_rate = 1000, + gc = TRUE, + writetodisk = TRUE, + verbose = FALSE, + legacy = FALSE, + outcome_name = "data", + drop_upper_triangular = TRUE, + ...) { + # --- Input Validations and Preprocessing --- + + # Ensure that at least one relationship matrix is provided. + if (is.null(ad_ped_matrix) && is.null(mit_ped_matrix) && is.null(cn_ped_matrix)) { + stop("At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided.") + } + # Validate and convert ad_ped_matrix to a sparse dgCMatrix if provided. + if (!is.null(ad_ped_matrix)) { + ad_ped_matrix <- validate_and_convert_matrix( + mat = ad_ped_matrix, + name = "ad_ped_matrix" + ) + } + + # Validate and convert cn_ped_matrix to a sparse dgCMatrix if provided. + if (!is.null(cn_ped_matrix)) { + cn_ped_matrix <- validate_and_convert_matrix( + mat = cn_ped_matrix, + name = "cn_ped_matrix", + ensure_symmetric = TRUE + ) + } + + # Validate and process mit_ped_matrix: convert and ensure binary values. + if (!is.null(mit_ped_matrix)) { + mit_ped_matrix <- validate_and_convert_matrix( + mat = mit_ped_matrix, + name = "mit_ped_matrix", force_binary = TRUE, + ensure_symmetric = TRUE + ) + } + + # --- Build IDs and Prepare Matrix Pointers --- + + # Extract individual IDs from the first available matrix. + ids <- NULL + + + + if (!is.null(cn_ped_matrix)) { + ids <- as.numeric(dimnames(cn_ped_matrix)[[1]]) + nc <- ncol(cn_ped_matrix) + } else if (!is.null(ad_ped_matrix)) { + ids <- as.numeric(dimnames(ad_ped_matrix)[[1]]) + nc <- ncol(ad_ped_matrix) + } else if (!is.null(mit_ped_matrix)) { + ids <- as.numeric(dimnames(mit_ped_matrix)[[1]]) + nc <- ncol(mit_ped_matrix) + } + + if (is.null(ids)) { + stop("Could not extract IDs from the provided matrices.") + } + + # --- matrix_case construction and switch dispatch --- + matrix_case <- paste(sort(c( + if (!is.null(ad_ped_matrix)) "ad" else NULL, + if (!is.null(mit_ped_matrix)) "mt" else NULL, + if (!is.null(cn_ped_matrix)) "cn" else NULL + )), collapse = "-") + + if (verbose) { + print(matrix_case) + } + + switch(matrix_case, + "ad" = process_one( + matrix = ad_ped_matrix, + rel_name = "addRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "mt" = process_one( + matrix = mit_ped_matrix, + rel_name = "mitRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "cn" = process_one( + matrix = cn_ped_matrix, + rel_name = "cnuRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "ad-mt" = process_two( + matrix1 = ad_ped_matrix, + name1 = "addRel", + matrix2 = mit_ped_matrix, + name2 = "mitRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "ad-cn" = process_two( + matrix1 = ad_ped_matrix, + name1 = "addRel", + matrix2 = cn_ped_matrix, + name2 = "cnuRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "cn-mt" = process_two( + matrix1 = cn_ped_matrix, + name1 = "cnuRel", + matrix2 = mit_ped_matrix, + name2 = "mitRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "ad-cn-mt" = process_all_three( + mat1 = ad_ped_matrix, + name1 = "addRel", + mat2 = mit_ped_matrix, + name2 = "mitRel", + mat3 = cn_ped_matrix, + name3 = "cnuRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + stop("Unsupported matrix combination") + ) +} +#' Convert Sparse Relationship Matrices to Kinship Links +#' @inheritParams com2links +#' @inherit com2links description +#' @inherit com2links details +#' @keyword internal com2links.legacy <- function( rel_pairs_file = "dataRelatedPairs.csv", @@ -522,7 +723,7 @@ com2links.legacy <- function( #' Convert Pedigree Matrices to Related Pairs File (Legacy) #' @description #' This legacy function converts pedigree matrices into a related pairs file. -#' @inheritParams com2links.legacy +#' @inheritParams com2links #' @keywords internal @@ -648,207 +849,6 @@ com2links.og <- function( return(NULL) } -#' Convert Sparse Relationship Matrices to Kinship Links -#' @inheritParams com2links.legacy -#' @inherit com2links.legacy description -#' @inherit com2links.legacy details -#' @export - -com2links <- function( - rel_pairs_file = "dataRelatedPairs.csv", - ad_ped_matrix = NULL, - mit_ped_matrix = mt_ped_matrix, - mt_ped_matrix = NULL, - cn_ped_matrix = NULL, - # pat_ped_matrix = NULL, - # mat_ped_matrix = NULL, - # mapa_id_file = "data_mapaID.csv", - write_buffer_size = 1000, - update_rate = 1000, - gc = TRUE, - writetodisk = TRUE, - verbose = FALSE, - legacy = FALSE, - outcome_name = "data", - drop_upper_triangular = TRUE, - ...) { - # --- Input Validations and Preprocessing --- - - # Ensure that at least one relationship matrix is provided. - if (is.null(ad_ped_matrix) && is.null(mit_ped_matrix) && is.null(cn_ped_matrix)) { - stop("At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided.") - } - # Validate and convert ad_ped_matrix to a sparse dgCMatrix if provided. - if (!is.null(ad_ped_matrix)) { - ad_ped_matrix <- validate_and_convert_matrix( - mat = ad_ped_matrix, - name = "ad_ped_matrix" - ) - } - - # Validate and convert cn_ped_matrix to a sparse dgCMatrix if provided. - if (!is.null(cn_ped_matrix)) { - cn_ped_matrix <- validate_and_convert_matrix( - mat = cn_ped_matrix, - name = "cn_ped_matrix", - ensure_symmetric = TRUE - ) - } - - # Validate and process mit_ped_matrix: convert and ensure binary values. - if (!is.null(mit_ped_matrix)) { - mit_ped_matrix <- validate_and_convert_matrix( - mat = mit_ped_matrix, - name = "mit_ped_matrix", force_binary = TRUE, - ensure_symmetric = TRUE - ) - } - - # --- Build IDs and Prepare Matrix Pointers --- - - # Extract individual IDs from the first available matrix. - ids <- NULL - - - - if (!is.null(cn_ped_matrix)) { - ids <- as.numeric(dimnames(cn_ped_matrix)[[1]]) - nc <- ncol(cn_ped_matrix) - } else if (!is.null(ad_ped_matrix)) { - ids <- as.numeric(dimnames(ad_ped_matrix)[[1]]) - nc <- ncol(ad_ped_matrix) - } else if (!is.null(mit_ped_matrix)) { - ids <- as.numeric(dimnames(mit_ped_matrix)[[1]]) - nc <- ncol(mit_ped_matrix) - } - - if (is.null(ids)) { - stop("Could not extract IDs from the provided matrices.") - } - - # --- matrix_case construction and switch dispatch --- - matrix_case <- paste(sort(c( - if (!is.null(ad_ped_matrix)) "ad" else NULL, - if (!is.null(mit_ped_matrix)) "mt" else NULL, - if (!is.null(cn_ped_matrix)) "cn" else NULL - )), collapse = "-") - - if (verbose) { - print(matrix_case) - } - - switch(matrix_case, - "ad" = process_one( - matrix = ad_ped_matrix, - rel_name = "addRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "mt" = process_one( - matrix = mit_ped_matrix, - rel_name = "mitRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "cn" = process_one( - matrix = cn_ped_matrix, - rel_name = "cnuRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "ad-mt" = process_two( - matrix1 = ad_ped_matrix, - name1 = "addRel", - matrix2 = mit_ped_matrix, - name2 = "mitRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "ad-cn" = process_two( - matrix1 = ad_ped_matrix, - name1 = "addRel", - matrix2 = cn_ped_matrix, - name2 = "cnuRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "cn-mt" = process_two( - matrix1 = cn_ped_matrix, - name1 = "cnuRel", - matrix2 = mit_ped_matrix, - name2 = "mitRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "ad-cn-mt" = process_all_three( - mat1 = ad_ped_matrix, - name1 = "addRel", - mat2 = mit_ped_matrix, - name2 = "mitRel", - mat3 = cn_ped_matrix, - name3 = "cnuRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - stop("Unsupported matrix combination") - ) -} process_one <- function(matrix, rel_name, ids, nc, rel_pairs_file, writetodisk, write_buffer_size, drop_upper_triangular, update_rate, verbose, gc, ...) { # Extract pointers and indices from the matrix. From 39fde6cb5f2c3d9309ed374b224d4e84f0a56fda Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Thu, 10 Apr 2025 10:03:51 -0400 Subject: [PATCH 22/69] Delete benchmark_results.csv --- benchmark_results.csv | 4 ---- 1 file changed, 4 deletions(-) delete mode 100644 benchmark_results.csv diff --git a/benchmark_results.csv b/benchmark_results.csv deleted file mode 100644 index 192b22dd..00000000 --- a/benchmark_results.csv +++ /dev/null @@ -1,4 +0,0 @@ -"expr","min","lq","mean","median","uq","max","neval" -"beta",16.0127553,19.82506435,22.108722786,21.26392435,23.70929065,33.0821112,100 -"regular",16.1161818,19.80905795,22.26289046694,21.25613265,24.39315385,33.3530921,100 -"legacy",32.0135859,39.7116454,43.55598528601,42.62947545,47.32561085,65.684218301,100 From 015c32abfa9461162f0b9c5ffc0f7f47ca3bc1cb Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Thu, 10 Apr 2025 10:03:16 -0400 Subject: [PATCH 23/69] reorder coms --- R/makeLinks.R | 403 ++++++++++++++++++++-------------------- man/com2links.Rd | 3 + man/com2links.legacy.Rd | 3 - 3 files changed, 204 insertions(+), 205 deletions(-) diff --git a/R/makeLinks.R b/R/makeLinks.R index 7bbdb082..f0bee11e 100644 --- a/R/makeLinks.R +++ b/R/makeLinks.R @@ -20,8 +20,208 @@ #' @param ... Additional arguments to be passed to \code{\link{com2links}} #' #' @return A data frame of related pairs if \code{writetodisk} is FALSE; otherwise, writes the results to disk. +#' @export com2links + +com2links <- function( + rel_pairs_file = "dataRelatedPairs.csv", + ad_ped_matrix = NULL, + mit_ped_matrix = mt_ped_matrix, + mt_ped_matrix = NULL, + cn_ped_matrix = NULL, + # pat_ped_matrix = NULL, + # mat_ped_matrix = NULL, + # mapa_id_file = "data_mapaID.csv", + write_buffer_size = 1000, + update_rate = 1000, + gc = TRUE, + writetodisk = TRUE, + verbose = FALSE, + legacy = FALSE, + outcome_name = "data", + drop_upper_triangular = TRUE, + ...) { + # --- Input Validations and Preprocessing --- + + # Ensure that at least one relationship matrix is provided. + if (is.null(ad_ped_matrix) && is.null(mit_ped_matrix) && is.null(cn_ped_matrix)) { + stop("At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided.") + } + # Validate and convert ad_ped_matrix to a sparse dgCMatrix if provided. + if (!is.null(ad_ped_matrix)) { + ad_ped_matrix <- validate_and_convert_matrix( + mat = ad_ped_matrix, + name = "ad_ped_matrix" + ) + } + + # Validate and convert cn_ped_matrix to a sparse dgCMatrix if provided. + if (!is.null(cn_ped_matrix)) { + cn_ped_matrix <- validate_and_convert_matrix( + mat = cn_ped_matrix, + name = "cn_ped_matrix", + ensure_symmetric = TRUE + ) + } + + # Validate and process mit_ped_matrix: convert and ensure binary values. + if (!is.null(mit_ped_matrix)) { + mit_ped_matrix <- validate_and_convert_matrix( + mat = mit_ped_matrix, + name = "mit_ped_matrix", force_binary = TRUE, + ensure_symmetric = TRUE + ) + } + + # --- Build IDs and Prepare Matrix Pointers --- + + # Extract individual IDs from the first available matrix. + ids <- NULL + + + + if (!is.null(cn_ped_matrix)) { + ids <- as.numeric(dimnames(cn_ped_matrix)[[1]]) + nc <- ncol(cn_ped_matrix) + } else if (!is.null(ad_ped_matrix)) { + ids <- as.numeric(dimnames(ad_ped_matrix)[[1]]) + nc <- ncol(ad_ped_matrix) + } else if (!is.null(mit_ped_matrix)) { + ids <- as.numeric(dimnames(mit_ped_matrix)[[1]]) + nc <- ncol(mit_ped_matrix) + } + + if (is.null(ids)) { + stop("Could not extract IDs from the provided matrices.") + } + + # --- matrix_case construction and switch dispatch --- + matrix_case <- paste(sort(c( + if (!is.null(ad_ped_matrix)) "ad" else NULL, + if (!is.null(mit_ped_matrix)) "mt" else NULL, + if (!is.null(cn_ped_matrix)) "cn" else NULL + )), collapse = "-") + + if (verbose) { + print(matrix_case) + } + + switch(matrix_case, + "ad" = process_one( + matrix = ad_ped_matrix, + rel_name = "addRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "mt" = process_one( + matrix = mit_ped_matrix, + rel_name = "mitRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "cn" = process_one( + matrix = cn_ped_matrix, + rel_name = "cnuRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "ad-mt" = process_two( + matrix1 = ad_ped_matrix, + name1 = "addRel", + matrix2 = mit_ped_matrix, + name2 = "mitRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "ad-cn" = process_two( + matrix1 = ad_ped_matrix, + name1 = "addRel", + matrix2 = cn_ped_matrix, + name2 = "cnuRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "cn-mt" = process_two( + matrix1 = cn_ped_matrix, + name1 = "cnuRel", + matrix2 = mit_ped_matrix, + name2 = "mitRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "ad-cn-mt" = process_all_three( + mat1 = ad_ped_matrix, + name1 = "addRel", + mat2 = mit_ped_matrix, + name2 = "mitRel", + mat3 = cn_ped_matrix, + name3 = "cnuRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + stop("Unsupported matrix combination") + ) +} +#' Convert Sparse Relationship Matrices to Kinship Links +#' @inheritParams com2links #' @keywords internal + com2links.legacy <- function( rel_pairs_file = "dataRelatedPairs.csv", ad_ped_matrix = NULL, @@ -522,7 +722,7 @@ com2links.legacy <- function( #' Convert Pedigree Matrices to Related Pairs File (Legacy) #' @description #' This legacy function converts pedigree matrices into a related pairs file. -#' @inheritParams com2links.legacy +#' @inheritParams com2links #' @keywords internal @@ -648,207 +848,6 @@ com2links.og <- function( return(NULL) } -#' Convert Sparse Relationship Matrices to Kinship Links -#' @inheritParams com2links.legacy -#' @inherit com2links.legacy description -#' @inherit com2links.legacy details -#' @export - -com2links <- function( - rel_pairs_file = "dataRelatedPairs.csv", - ad_ped_matrix = NULL, - mit_ped_matrix = mt_ped_matrix, - mt_ped_matrix = NULL, - cn_ped_matrix = NULL, - # pat_ped_matrix = NULL, - # mat_ped_matrix = NULL, - # mapa_id_file = "data_mapaID.csv", - write_buffer_size = 1000, - update_rate = 1000, - gc = TRUE, - writetodisk = TRUE, - verbose = FALSE, - legacy = FALSE, - outcome_name = "data", - drop_upper_triangular = TRUE, - ...) { - # --- Input Validations and Preprocessing --- - - # Ensure that at least one relationship matrix is provided. - if (is.null(ad_ped_matrix) && is.null(mit_ped_matrix) && is.null(cn_ped_matrix)) { - stop("At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided.") - } - # Validate and convert ad_ped_matrix to a sparse dgCMatrix if provided. - if (!is.null(ad_ped_matrix)) { - ad_ped_matrix <- validate_and_convert_matrix( - mat = ad_ped_matrix, - name = "ad_ped_matrix" - ) - } - - # Validate and convert cn_ped_matrix to a sparse dgCMatrix if provided. - if (!is.null(cn_ped_matrix)) { - cn_ped_matrix <- validate_and_convert_matrix( - mat = cn_ped_matrix, - name = "cn_ped_matrix", - ensure_symmetric = TRUE - ) - } - - # Validate and process mit_ped_matrix: convert and ensure binary values. - if (!is.null(mit_ped_matrix)) { - mit_ped_matrix <- validate_and_convert_matrix( - mat = mit_ped_matrix, - name = "mit_ped_matrix", force_binary = TRUE, - ensure_symmetric = TRUE - ) - } - - # --- Build IDs and Prepare Matrix Pointers --- - - # Extract individual IDs from the first available matrix. - ids <- NULL - - - - if (!is.null(cn_ped_matrix)) { - ids <- as.numeric(dimnames(cn_ped_matrix)[[1]]) - nc <- ncol(cn_ped_matrix) - } else if (!is.null(ad_ped_matrix)) { - ids <- as.numeric(dimnames(ad_ped_matrix)[[1]]) - nc <- ncol(ad_ped_matrix) - } else if (!is.null(mit_ped_matrix)) { - ids <- as.numeric(dimnames(mit_ped_matrix)[[1]]) - nc <- ncol(mit_ped_matrix) - } - - if (is.null(ids)) { - stop("Could not extract IDs from the provided matrices.") - } - - # --- matrix_case construction and switch dispatch --- - matrix_case <- paste(sort(c( - if (!is.null(ad_ped_matrix)) "ad" else NULL, - if (!is.null(mit_ped_matrix)) "mt" else NULL, - if (!is.null(cn_ped_matrix)) "cn" else NULL - )), collapse = "-") - - if (verbose) { - print(matrix_case) - } - - switch(matrix_case, - "ad" = process_one( - matrix = ad_ped_matrix, - rel_name = "addRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "mt" = process_one( - matrix = mit_ped_matrix, - rel_name = "mitRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "cn" = process_one( - matrix = cn_ped_matrix, - rel_name = "cnuRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "ad-mt" = process_two( - matrix1 = ad_ped_matrix, - name1 = "addRel", - matrix2 = mit_ped_matrix, - name2 = "mitRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "ad-cn" = process_two( - matrix1 = ad_ped_matrix, - name1 = "addRel", - matrix2 = cn_ped_matrix, - name2 = "cnuRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "cn-mt" = process_two( - matrix1 = cn_ped_matrix, - name1 = "cnuRel", - matrix2 = mit_ped_matrix, - name2 = "mitRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "ad-cn-mt" = process_all_three( - mat1 = ad_ped_matrix, - name1 = "addRel", - mat2 = mit_ped_matrix, - name2 = "mitRel", - mat3 = cn_ped_matrix, - name3 = "cnuRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - stop("Unsupported matrix combination") - ) -} process_one <- function(matrix, rel_name, ids, nc, rel_pairs_file, writetodisk, write_buffer_size, drop_upper_triangular, update_rate, verbose, gc, ...) { # Extract pointers and indices from the matrix. diff --git a/man/com2links.Rd b/man/com2links.Rd index e9c7ac2b..9dae2f09 100644 --- a/man/com2links.Rd +++ b/man/com2links.Rd @@ -50,6 +50,9 @@ com2links( \item{...}{Additional arguments to be passed to \code{\link{com2links}}} } +\value{ +A data frame of related pairs if \code{writetodisk} is FALSE; otherwise, writes the results to disk. +} \description{ This function processes one or more sparse relationship components (additive, mitochondrial, and common nuclear) and converts them into kinship link pairs. The resulting related pairs are diff --git a/man/com2links.legacy.Rd b/man/com2links.legacy.Rd index a523a106..bf4bc6e4 100644 --- a/man/com2links.legacy.Rd +++ b/man/com2links.legacy.Rd @@ -50,9 +50,6 @@ com2links.legacy( \item{...}{Additional arguments to be passed to \code{\link{com2links}}} } -\value{ -A data frame of related pairs if \code{writetodisk} is FALSE; otherwise, writes the results to disk. -} \description{ This function processes one or more sparse relationship components (additive, mitochondrial, and common nuclear) and converts them into kinship link pairs. The resulting related pairs are From 0850662838bae94e354bd4898d2ae71c8682770e Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Thu, 10 Apr 2025 10:26:25 -0400 Subject: [PATCH 24/69] Update test-makeLinks.R --- tests/testthat/test-makeLinks.R | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-makeLinks.R b/tests/testthat/test-makeLinks.R index a2666f2e..51bdcb49 100644 --- a/tests/testthat/test-makeLinks.R +++ b/tests/testthat/test-makeLinks.R @@ -25,6 +25,18 @@ test_that("com2links produces correct output with a single relationship matrix ( expect_true(all(result$addRel >= 0)) # Relatedness values should be non-negative }) +test_that("com2links produces correct output with cn_ped_matrix", { + data(ASOIAF) + cn_ped_matrix <- ped2mit(ASOIAF, sparse = TRUE) + + result <- com2links(cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE) + + expect_true(is.data.frame(result)) + expect_true(all(c("ID1", "ID2", "cnRel") %in% colnames(result))) + expect_equal(ncol(result), 3) # Expect ID1, ID2, and addRel + expect_true(all(result$cnRel >= 0)) # Relatedness values should be non-negative +}) + test_that("com2links produces correct output with mt_ped_matrix", { data(hazard) mit_ped_matrix <- ped2mit(hazard, sparse = TRUE) @@ -34,7 +46,7 @@ test_that("com2links produces correct output with mt_ped_matrix", { expect_true(is.data.frame(result)) expect_true(all(c("ID1", "ID2", "mitRel") %in% colnames(result))) expect_equal(ncol(result), 3) # Expect ID1, ID2, and addRel - expect_true(all(result$addRel >= 0)) # Relatedness values should be non-negative + expect_true(all(result$mitRel %in% c(0, 1))) # Mitochondrial should be binary }) test_that("com2links processes multiple matrices correctly (hazard dataset)", { From c5eabef3ccce44d39580740a9a6799ea8ceced08 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Thu, 10 Apr 2025 10:58:00 -0400 Subject: [PATCH 25/69] splitting links into legacy --- R/makeLinks.R | 635 +------------------------------- R/makeLinkslegacy.R | 631 +++++++++++++++++++++++++++++++ tests/testthat/test-makeLinks.R | 55 ++- 3 files changed, 684 insertions(+), 637 deletions(-) create mode 100644 R/makeLinkslegacy.R diff --git a/R/makeLinks.R b/R/makeLinks.R index f0bee11e..0156717c 100644 --- a/R/makeLinks.R +++ b/R/makeLinks.R @@ -222,632 +222,6 @@ com2links <- function( #' @keywords internal -com2links.legacy <- function( - rel_pairs_file = "dataRelatedPairs.csv", - ad_ped_matrix = NULL, - mit_ped_matrix = mt_ped_matrix, - mt_ped_matrix = NULL, - cn_ped_matrix = NULL, - # pat_ped_matrix = NULL, - # mat_ped_matrix = NULL, - # mapa_id_file = "data_mapaID.csv", - write_buffer_size = 1000, - update_rate = 1000, - gc = TRUE, - writetodisk = TRUE, - verbose = FALSE, - legacy = FALSE, - outcome_name = "data", - drop_upper_triangular = TRUE, - ...) { - # Non-legacy mode processing - - if (!legacy) { - # --- Input Validations and Preprocessing --- - - # Ensure that at least one relationship matrix is provided. - if (is.null(ad_ped_matrix) && is.null(mit_ped_matrix) && is.null(cn_ped_matrix)) { - stop("At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided.") - } - # Validate and convert ad_ped_matrix to a sparse dgCMatrix if provided. - if (!is.null(ad_ped_matrix)) { - ad_ped_matrix <- validate_and_convert_matrix( - mat = ad_ped_matrix, - name = "ad_ped_matrix" - ) - } - - # Validate and convert cn_ped_matrix to a sparse dgCMatrix if provided. - if (!is.null(cn_ped_matrix)) { - cn_ped_matrix <- validate_and_convert_matrix( - mat = cn_ped_matrix, - name = "cn_ped_matrix", - ensure_symmetric = TRUE - ) - } - - # Validate and process mit_ped_matrix: convert and ensure binary values. - if (!is.null(mit_ped_matrix)) { - mit_ped_matrix <- validate_and_convert_matrix( - mat = mit_ped_matrix, - name = "mit_ped_matrix", force_binary = TRUE, - ensure_symmetric = TRUE - ) - } - - # --- Build IDs and Prepare Matrix Pointers --- - - # Extract individual IDs from the first available matrix. - ids <- NULL - - - - if (!is.null(cn_ped_matrix)) { - ids <- as.numeric(dimnames(cn_ped_matrix)[[1]]) - nc <- ncol(cn_ped_matrix) - } else if (!is.null(ad_ped_matrix)) { - ids <- as.numeric(dimnames(ad_ped_matrix)[[1]]) - nc <- ncol(ad_ped_matrix) - } else if (!is.null(mit_ped_matrix)) { - ids <- as.numeric(dimnames(mit_ped_matrix)[[1]]) - nc <- ncol(mit_ped_matrix) - } - - if (is.null(ids)) { - stop("Could not extract IDs from the provided matrices.") - } - - - # Construct case identifier - matrix_case <- paste(sort(c( - if (!is.null(ad_ped_matrix)) "ad" else NULL, - if (!is.null(mit_ped_matrix)) "mt" else NULL, - if (!is.null(cn_ped_matrix)) "cn" else NULL - )), collapse = "-") - - - # Count how many matrices are provided. - sum_nulls <- sum(!is.null(ad_ped_matrix), - !is.null(mit_ped_matrix), - !is.null(cn_ped_matrix), - na.rm = TRUE - ) - if (verbose) { - print(matrix_case) - } - - # Extract the internal pointers (p, i, and x slots) for each provided matrix. - if (!is.null(ad_ped_matrix)) { - ad_ped_p <- ad_ped_matrix@p + 1L - ad_ped_i <- ad_ped_matrix@i + 1L - ad_ped_x <- ad_ped_matrix@x - } - if (!is.null(mit_ped_matrix)) { - mt_p <- mit_ped_matrix@p + 1L - mt_i <- mit_ped_matrix@i + 1L - mt_x <- mit_ped_matrix@x - } - if (!is.null(cn_ped_matrix)) { - cn_p <- cn_ped_matrix@p + 1L - cn_i <- cn_ped_matrix@i + 1L - cn_x <- cn_ped_matrix@x - } - - # --- Process Based on the Number of Provided Matrices --- - # --- Case: All Three Matrices Provided --- - if (sum_nulls == 3) { - # Set pointers for all three matrices. - newColPos1 <- ad_ped_p - iss1 <- ad_ped_i - x1 <- ad_ped_x - - newColPos2 <- mt_p - iss2 <- mt_i - x2 <- mt_x - - newColPos3 <- cn_p - iss3 <- cn_i - x3 <- cn_x - - # Define relationship column names. - relNames <- c("addRel", "mitRel", "cnuRel") - - # Optionally remove the original pointers to free memory. - if (gc == TRUE) { - remove(ad_ped_p, ad_ped_i, ad_ped_x, mt_p, mt_i, mt_x, cn_p, cn_i, cn_x) - } - if (verbose) { - message("All 3 matrix is present") - } - - # File names - # rel_pairs_file <- paste0(outcome_name, "_dataRelatedPairs.csv") - # mapa_id_file <- paste0(outcome_name, "_data_mapaID.csv") - - # Initialize the related pairs file with headers. - df_relpairs <- initialize_empty_df(relNames = relNames) - - # Write the headers to the related pairs file. - if (writetodisk == TRUE) { - utils::write.table( - df_relpairs, - file = rel_pairs_file, sep = ",", append = FALSE, row.names = FALSE - ) - - # Prepare an empty buffer for batching writes. - write_buffer <- list() - remove(df_relpairs) - } - - # Loop over each column (individual) in the matrix. - for (j in 1L:nc) { - ID2 <- ids[j] - - # Extract column indices for the 1st component - ncp1 <- newColPos1[j] - ncp1p <- newColPos1[j + 1L] - cond1 <- ncp1 < ncp1p - if (cond1) { - vv1 <- ncp1:(ncp1p - 1L) - iss1vv <- iss1[vv1] - } - # Extract indices for the 2nd component - ncp2 <- newColPos2[j] - ncp2p <- newColPos2[j + 1L] - cond2 <- ncp2 < ncp2p - if (cond2) { - vv2 <- ncp2:(ncp2p - 1L) - iss2vv <- iss2[vv2] - } - - # Extract indices for the 3rd component - ncp3 <- newColPos3[j] - ncp3p <- newColPos3[j + 1L] - cond3 <- ncp3 < ncp3p - if (cond3) { - vv3 <- ncp3:(ncp3p - 1L) - iss3vv <- iss3[vv3] - } - - # Create a unique, sorted set of row indices from all provided matrices. - u <- sort(igraph::union(igraph::union(if (cond1) { - iss1vv - }, if (cond2) { - iss2vv - }), if (cond3) { - iss3vv - })) - - # If any relationships exist for this individual, build the related pairs. - if (cond1 || cond2 || cond3) { - ID1 <- ids[u] - tds <- data.frame(ID1 = ID1, ID2 = ID2) - tds[[relNames[1]]] <- 0 - tds[[relNames[2]]] <- 0 - tds[[relNames[3]]] <- 0 - - # Assign the relationship coefficients from each matrix. - if (cond1) { - tds[u %in% iss1vv, relNames[1]] <- x1[vv1] - } - if (cond2) { - tds[u %in% iss2vv, relNames[2]] <- x2[vv2] - } - if (cond3) { - tds[u %in% iss3vv, relNames[3]] <- x3[vv3] - } - - # Optionally drop upper-triangular entries. - if (drop_upper_triangular == TRUE) { - tds <- tds[tds$ID1 <= tds$ID2, ] # or < if you want strictly lower triangle - } - - # Write the batch to disk or accumulate in the data frame. - if (nrow(tds) > 0) { - if (writetodisk == TRUE) { - write_buffer[[length(write_buffer) + 1]] <- tds - - if (length(write_buffer) >= write_buffer_size) { # Write in batches - utils::write.table(do.call(rbind, write_buffer), - file = rel_pairs_file, - row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," - ) - write_buffer <- list() - } - } else { - df_relpairs <- rbind(df_relpairs, tds) - } - } - } - if (verbose && (j %% update_rate == 0L)) { - cat("Done with", j, "of", nc, "\n") - } - } - } else if (sum_nulls == 2) { - # --- Case: Two Matrices Provided --- - # Set pointers and relationship names based on which matrix is missing. - - if (is.null(ad_ped_matrix)) { - newColPos1 <- mt_p - iss1 <- mt_i - x1 <- mt_x - newColPos2 <- cn_p - iss2 <- cn_i - x2 <- cn_x - relNames <- c("mitRel", "cnuRel") - if (gc == TRUE) { - remove(mt_p, mt_i, mt_x, cn_p, cn_i, cn_x) - } - } - if (is.null(mit_ped_matrix)) { - newColPos1 <- ad_ped_p - iss1 <- ad_ped_i - x1 <- ad_ped_x - newColPos2 <- cn_p - iss2 <- cn_i - x2 <- cn_x - relNames <- c("addRel", "cnuRel") - if (gc == TRUE) { - remove(ad_ped_p, ad_ped_i, ad_ped_x, cn_p, cn_i, cn_x) - } - } - if (is.null(cn_ped_matrix)) { - newColPos1 <- ad_ped_p - iss1 <- ad_ped_i - x1 <- ad_ped_x - newColPos2 <- mt_p - iss2 <- mt_i - x2 <- mt_x - relNames <- c("addRel", "mitRel") - if (gc == TRUE) { - remove(ad_ped_p, ad_ped_i, ad_ped_x, mt_p, mt_i, mt_x) - } - } - - # Initialize the related pairs file with the appropriate headers. - df_relpairs <- initialize_empty_df(relNames = relNames) - - if (writetodisk == TRUE) { - utils::write.table( - df_relpairs, - file = rel_pairs_file, sep = ",", append = FALSE, row.names = FALSE - ) - # initial buffer - write_buffer <- list() - remove(df_relpairs) - } - - # Process each column to extract relationships. - for (j in 1L:nc) { - ID2 <- ids[j] - - # Extract indices from the first matrix. - ncp1 <- newColPos1[j] - ncp1p <- newColPos1[j + 1L] - cond1 <- ncp1 < ncp1p - if (cond1) { - vv1 <- ncp1:(ncp1p - 1L) - iss1vv <- iss1[vv1] - } - # Extract indices from the second matrix. - ncp2 <- newColPos2[j] - ncp2p <- newColPos2[j + 1L] - cond2 <- ncp2 < ncp2p - if (cond2) { - vv2 <- ncp2:(ncp2p - 1L) - iss2vv <- iss2[vv2] - } - - # Merge the indices from both matrices. - u <- sort(igraph::union(if (cond1) { - iss1vv - }, if (cond2) { - iss2vv - })) - - # Create related pairs if relationships are found. - if (cond1 || cond2) { - ID1 <- ids[u] - tds <- data.frame(ID1 = ID1, ID2 = ID2) - tds[[relNames[1]]] <- 0 - tds[[relNames[2]]] <- 0 - - if (cond1) { - tds[u %in% iss1vv, relNames[1]] <- x1[vv1] - } - if (cond2) { - tds[u %in% iss2vv, relNames[2]] <- x2[vv2] - } - if (drop_upper_triangular == TRUE) { - tds <- tds[tds$ID1 <= tds$ID2, ] # or < if you want strictly lower triangle - } - - # Write the batch to disk or accumulate in the data frame. - if (nrow(tds) > 0) { - if (writetodisk == TRUE) { - write_buffer[[length(write_buffer) + 1]] <- tds - - if (length(write_buffer) >= write_buffer_size) { # Write in batches - utils::write.table(do.call(rbind, write_buffer), - file = rel_pairs_file, - row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," - ) - write_buffer <- list() - } - } else { - df_relpairs <- rbind(df_relpairs, tds) - } - } - } - if (verbose && (j %% update_rate == 0L)) { - cat("Done with", j, "of", nc, "\n") - } - } - } else if (sum_nulls == 1) { - # --- Case: Only One Matrix Provided --- - if (verbose) { - message("Only one matrix is present") - } - if (!is.null(ad_ped_matrix)) { - newColPos1 <- ad_ped_p - iss1 <- ad_ped_i - x1 <- ad_ped_x - relNames <- c("addRel") - if (gc == TRUE) { - remove(ad_ped_p, ad_ped_i, ad_ped_x) - } - } - if (!is.null(mit_ped_matrix)) { - newColPos1 <- mt_p - iss1 <- mt_i - x1 <- mt_x - relNames <- c("mitRel") - if (gc == TRUE) { - remove(mt_p, mt_i, mt_x) - } - } - if (!is.null(cn_ped_matrix)) { - newColPos1 <- cn_p - iss1 <- cn_i - x1 <- cn_x - relNames <- c("cnuRel") - if (gc == TRUE) { - remove(cn_p, cn_i, cn_x) - } - } - - # Initialize the related pairs file. - df_relpairs <- initialize_empty_df(relNames = relNames) - - if (writetodisk == TRUE) { - utils::write.table( - df_relpairs, - file = rel_pairs_file, sep = ",", append = FALSE, row.names = FALSE - ) - - # initial buffer - write_buffer <- list() - - remove(df_relpairs) - } - - # Process each column. - for (j in 1L:nc) { - ID2 <- ids[j] - # Extract column indices - ncp1 <- newColPos1[j] - ncp1p <- newColPos1[j + 1L] - cond1 <- ncp1 < ncp1p - if (cond1) { - vv1 <- ncp1:(ncp1p - 1L) - iss1vv <- iss1[vv1] - } - - # Use the indices from the single matrix. - u <- sort(iss1vv) - - if (cond1) { - ID1 <- ids[u] - tds <- data.frame(ID1 = ID1, ID2 = ID2) - tds[[relNames[1]]] <- 0 - - if (cond1) { - tds[u %in% iss1vv, relNames[1]] <- x1[vv1] - } - if (drop_upper_triangular == TRUE) { - tds <- tds[tds$ID1 <= tds$ID2, ] # or < if you want strictly lower triangle - } - - # Write the batch to disk or accumulate in the data frame. - if (nrow(tds) > 0) { - if (writetodisk == TRUE) { - write_buffer[[length(write_buffer) + 1]] <- tds - - if (length(write_buffer) >= write_buffer_size) { # Write in batches - utils::write.table(do.call(rbind, write_buffer), - file = rel_pairs_file, - row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," - ) - write_buffer <- list() - } - } else { - df_relpairs <- rbind(df_relpairs, tds) - } - } - } - if (verbose && (j %% update_rate == 0L)) { - cat("Done with", j, "of", nc, "\n") - } - } - } else { - stop("No matrices provided") - } - - # If not writing to disk, return the accumulated data frame. - if (writetodisk == FALSE) { - return(df_relpairs) - } else { - # Write any remaining buffered rows. - if (length(write_buffer) > 0) { - utils::write.table(do.call(rbind, write_buffer), - file = rel_pairs_file, - row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," - ) - } - # return(NULL) - } - } else if (legacy) { - # --- Legacy Mode --- - # In legacy mode, convert matrices to the expected symmetric formats. - com2links.og( - rel_pairs_file = rel_pairs_file, - ad_ped_matrix = ad_ped_matrix, - mit_ped_matrix = mit_ped_matrix, - cn_ped_matrix = cn_ped_matrix, - update_rate = update_rate, - verbose = verbose, - outcome_name = outcome_name - ) - return(NULL) - } - - # --- End of Legacy Mode --- - - # Merge and write the parentage matrices - # df <- full_join(mat_ped_matrix %>% arrange(ID), pat_ped_matrix %>% arrange(ID)) - - # write.table(df, file = mapa_id_file, sep = ",", append = FALSE, row.names = FALSE) -} - -#' Convert Pedigree Matrices to Related Pairs File (Legacy) -#' @description -#' This legacy function converts pedigree matrices into a related pairs file. -#' @inheritParams com2links -#' @keywords internal - - -com2links.og <- function( - rel_pairs_file = "dataRelatedPairs.csv", - ad_ped_matrix = NULL, - mit_ped_matrix = mt_ped_matrix, - mt_ped_matrix = NULL, - cn_ped_matrix = NULL, - update_rate = 500, - verbose = FALSE, - outcome_name = "data", - ...) { - # --- Legacy Mode --- - if (verbose) { - message("Using legacy mode") - } - # In legacy mode, convert matrices to the expected symmetric formats. - - # load(paste0(outcome_name,'_dataBiggestCnPedigree.Rdata')) - # biggestCnPed <- methods::as(biggestCnPed, "symmetricMatrix") - # load(paste0(outcome_name,'_dataBiggestPedigree.Rdata')) - # load(paste0(outcome_name,'_dataBiggestMtPedigree.Rdata')) - - # rel_pairs_file <- paste0(outcome_name,'_datacnmitBiggestRelatedPairsTake3.csv') - - biggestMtPed <- mit_ped_matrix - remove(mit_ped_matrix) - biggestCnPed <- methods::as(cn_ped_matrix, "symmetricMatrix") - remove(cn_ped_matrix) - biggestPed <- ad_ped_matrix - remove(ad_ped_matrix) - biggestMtPed@x[biggestMtPed@x > 0] <- 1 - - # Set the output file name. - if (exists("rel_pairs_file")) { - fname <- rel_pairs_file - } else { - fname <- paste0(outcome_name, "_dataBiggestRelatedPairsTake2.csv") - } - # Initialize the output file with headers. - ds <- data.frame( - ID1 = numeric(0), ID2 = numeric(0), - addRel = numeric(0), - mitRel = numeric(0), cnuRel = numeric(0) - ) - - utils::write.table(ds, - file = fname, sep = ",", - append = FALSE, row.names = FALSE - ) - - # Extract IDs from the common nuclear matrix. - ids <- as.numeric(dimnames(biggestCnPed)[[1]]) - - # Extract pointers from the legacy matrices. - newColPos1 <- biggestPed@p + 1L - iss1 <- biggestPed@i + 1L - newColPos2 <- biggestMtPed@p + 1L - iss2 <- biggestMtPed@i + 1L - newColPos3 <- biggestCnPed@p + 1L - iss3 <- biggestCnPed@i + 1L - nc <- ncol(biggestPed) - - # Process each individual. - for (j in 1L:nc) { - ID2 <- ids[j] - ncp1 <- newColPos1[j] - ncp1p <- newColPos1[j + 1L] - cond1 <- ncp1 < ncp1p - if (cond1) { - vv1 <- ncp1:(ncp1p - 1L) - iss1vv <- iss1[vv1] - } - ncp2 <- newColPos2[j] - ncp2p <- newColPos2[j + 1L] - cond2 <- ncp2 < ncp2p - if (cond2) { - vv2 <- ncp2:(ncp2p - 1L) - iss2vv <- iss2[vv2] - } - ncp3 <- newColPos3[j] - ncp3p <- newColPos3[j + 1L] - cond3 <- ncp3 < ncp3p - if (cond3) { - vv3 <- ncp3:(ncp3p - 1L) - iss3vv <- iss3[vv3] - } - - # Merge indices from all three matrices. - u <- sort(igraph::union(igraph::union(if (cond1) { - iss1vv - }, if (cond2) { - iss2vv - }), if (cond3) { - iss3vv - })) - # browser() - if (cond1 || cond2 || cond3) { - ID1 <- ids[u] - tds <- data.frame( - ID1 = ID1, ID2 = ID2, - addRel = 0, mitRel = 0, cnuRel = 0 - ) - if (cond1) { - tds$addRel[u %in% iss1vv] <- biggestPed@x[vv1] - } - if (cond2) { - tds$mitRel[u %in% iss2vv] <- biggestMtPed@x[vv2] - } - if (cond3) { - tds$cnuRel[u %in% iss3vv] <- biggestCnPed@x[vv3] - } - utils::write.table(tds, - file = fname, row.names = FALSE, - col.names = FALSE, append = TRUE, sep = "," - ) - } - if (!(j %% update_rate)) { - cat(paste0("Done with ", j, " of ", nc, "\n")) - } - } - return(NULL) -} - process_one <- function(matrix, rel_name, ids, nc, rel_pairs_file, writetodisk, write_buffer_size, drop_upper_triangular, update_rate, verbose, gc, ...) { # Extract pointers and indices from the matrix. @@ -1149,11 +523,12 @@ process_two <- function( #' #' @return The validated and converted matrix. validate_and_convert_matrix <- function(mat, name, ensure_symmetric = FALSE, force_binary = FALSE) { - if (!inherits(mat, c("matrix", "dgCMatrix", "dsCMatrix"))) { - stop(paste0("The '", name, "' must be a matrix or dgCMatrix.")) + if (!inherits(mat, c("matrix", "dgCMatrix", "dsCMatrix","generalMatrix", + "symmetricMatrix", "triangularMatrix", "dsyMatrix", "dspMatrix", "dsyMatrix"))) { + stop(paste0("The '", name, "' must be a matrix or generalMatrix")) } - if (!inherits(mat, "dgCMatrix")) { - mat <- methods::as(mat, if (ensure_symmetric) "symmetricMatrix" else "dgCMatrix") + if (!inherits(mat, "generalMatrix")) { + mat <- methods::as(mat, if (ensure_symmetric) "symmetricMatrix" else "generalMatrix") } if (force_binary) { mat@x[mat@x > 0] <- 1 diff --git a/R/makeLinkslegacy.R b/R/makeLinkslegacy.R new file mode 100644 index 00000000..27a6e45a --- /dev/null +++ b/R/makeLinkslegacy.R @@ -0,0 +1,631 @@ +#' Convert Sparse Relationship Matrices to Kinship Links +#' @inheritParams com2links +#' @keywords internal + + +com2links.legacy <- function( + rel_pairs_file = "dataRelatedPairs.csv", + ad_ped_matrix = NULL, + mit_ped_matrix = mt_ped_matrix, + mt_ped_matrix = NULL, + cn_ped_matrix = NULL, + # pat_ped_matrix = NULL, + # mat_ped_matrix = NULL, + # mapa_id_file = "data_mapaID.csv", + write_buffer_size = 1000, + update_rate = 1000, + gc = TRUE, + writetodisk = TRUE, + verbose = FALSE, + legacy = FALSE, + outcome_name = "data", + drop_upper_triangular = TRUE, + ...) { + # Non-legacy mode processing + + if (!legacy) { + # --- Input Validations and Preprocessing --- + + # Ensure that at least one relationship matrix is provided. + if (is.null(ad_ped_matrix) && is.null(mit_ped_matrix) && is.null(cn_ped_matrix)) { + stop("At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided.") + } + # Validate and convert ad_ped_matrix to a sparse dgCMatrix if provided. + if (!is.null(ad_ped_matrix)) { + ad_ped_matrix <- validate_and_convert_matrix( + mat = ad_ped_matrix, + name = "ad_ped_matrix" + ) + } + + # Validate and convert cn_ped_matrix to a sparse dgCMatrix if provided. + if (!is.null(cn_ped_matrix)) { + cn_ped_matrix <- validate_and_convert_matrix( + mat = cn_ped_matrix, + name = "cn_ped_matrix", + ensure_symmetric = TRUE + ) + } + + # Validate and process mit_ped_matrix: convert and ensure binary values. + if (!is.null(mit_ped_matrix)) { + mit_ped_matrix <- validate_and_convert_matrix( + mat = mit_ped_matrix, + name = "mit_ped_matrix", force_binary = TRUE, + ensure_symmetric = TRUE + ) + } + + # --- Build IDs and Prepare Matrix Pointers --- + + # Extract individual IDs from the first available matrix. + ids <- NULL + + + + if (!is.null(cn_ped_matrix)) { + ids <- as.numeric(dimnames(cn_ped_matrix)[[1]]) + nc <- ncol(cn_ped_matrix) + } else if (!is.null(ad_ped_matrix)) { + ids <- as.numeric(dimnames(ad_ped_matrix)[[1]]) + nc <- ncol(ad_ped_matrix) + } else if (!is.null(mit_ped_matrix)) { + ids <- as.numeric(dimnames(mit_ped_matrix)[[1]]) + nc <- ncol(mit_ped_matrix) + } + + if (is.null(ids)) { + stop("Could not extract IDs from the provided matrices.") + } + + + # Construct case identifier + matrix_case <- paste(sort(c( + if (!is.null(ad_ped_matrix)) "ad" else NULL, + if (!is.null(mit_ped_matrix)) "mt" else NULL, + if (!is.null(cn_ped_matrix)) "cn" else NULL + )), collapse = "-") + + + # Count how many matrices are provided. + sum_nulls <- sum(!is.null(ad_ped_matrix), + !is.null(mit_ped_matrix), + !is.null(cn_ped_matrix), + na.rm = TRUE + ) + if (verbose) { + print(matrix_case) + } + + # Extract the internal pointers (p, i, and x slots) for each provided matrix. + if (!is.null(ad_ped_matrix)) { + ad_ped_p <- ad_ped_matrix@p + 1L + ad_ped_i <- ad_ped_matrix@i + 1L + ad_ped_x <- ad_ped_matrix@x + } + if (!is.null(mit_ped_matrix)) { + mt_p <- mit_ped_matrix@p + 1L + mt_i <- mit_ped_matrix@i + 1L + mt_x <- mit_ped_matrix@x + } + if (!is.null(cn_ped_matrix)) { + cn_p <- cn_ped_matrix@p + 1L + cn_i <- cn_ped_matrix@i + 1L + cn_x <- cn_ped_matrix@x + } + + # --- Process Based on the Number of Provided Matrices --- + # --- Case: All Three Matrices Provided --- + if (sum_nulls == 3) { + # Set pointers for all three matrices. + newColPos1 <- ad_ped_p + iss1 <- ad_ped_i + x1 <- ad_ped_x + + newColPos2 <- mt_p + iss2 <- mt_i + x2 <- mt_x + + newColPos3 <- cn_p + iss3 <- cn_i + x3 <- cn_x + + # Define relationship column names. + relNames <- c("addRel", "mitRel", "cnuRel") + + # Optionally remove the original pointers to free memory. + if (gc == TRUE) { + remove(ad_ped_p, ad_ped_i, ad_ped_x, mt_p, mt_i, mt_x, cn_p, cn_i, cn_x) + } + if (verbose) { + message("All 3 matrix is present") + } + + # File names + # rel_pairs_file <- paste0(outcome_name, "_dataRelatedPairs.csv") + # mapa_id_file <- paste0(outcome_name, "_data_mapaID.csv") + + # Initialize the related pairs file with headers. + df_relpairs <- initialize_empty_df(relNames = relNames) + + # Write the headers to the related pairs file. + if (writetodisk == TRUE) { + utils::write.table( + df_relpairs, + file = rel_pairs_file, sep = ",", append = FALSE, row.names = FALSE + ) + + # Prepare an empty buffer for batching writes. + write_buffer <- list() + remove(df_relpairs) + } + + # Loop over each column (individual) in the matrix. + for (j in 1L:nc) { + ID2 <- ids[j] + + # Extract column indices for the 1st component + ncp1 <- newColPos1[j] + ncp1p <- newColPos1[j + 1L] + cond1 <- ncp1 < ncp1p + if (cond1) { + vv1 <- ncp1:(ncp1p - 1L) + iss1vv <- iss1[vv1] + } + # Extract indices for the 2nd component + ncp2 <- newColPos2[j] + ncp2p <- newColPos2[j + 1L] + cond2 <- ncp2 < ncp2p + if (cond2) { + vv2 <- ncp2:(ncp2p - 1L) + iss2vv <- iss2[vv2] + } + + # Extract indices for the 3rd component + ncp3 <- newColPos3[j] + ncp3p <- newColPos3[j + 1L] + cond3 <- ncp3 < ncp3p + if (cond3) { + vv3 <- ncp3:(ncp3p - 1L) + iss3vv <- iss3[vv3] + } + + # Create a unique, sorted set of row indices from all provided matrices. + u <- sort(igraph::union(igraph::union(if (cond1) { + iss1vv + }, if (cond2) { + iss2vv + }), if (cond3) { + iss3vv + })) + + # If any relationships exist for this individual, build the related pairs. + if (cond1 || cond2 || cond3) { + ID1 <- ids[u] + tds <- data.frame(ID1 = ID1, ID2 = ID2) + tds[[relNames[1]]] <- 0 + tds[[relNames[2]]] <- 0 + tds[[relNames[3]]] <- 0 + + # Assign the relationship coefficients from each matrix. + if (cond1) { + tds[u %in% iss1vv, relNames[1]] <- x1[vv1] + } + if (cond2) { + tds[u %in% iss2vv, relNames[2]] <- x2[vv2] + } + if (cond3) { + tds[u %in% iss3vv, relNames[3]] <- x3[vv3] + } + + # Optionally drop upper-triangular entries. + if (drop_upper_triangular == TRUE) { + tds <- tds[tds$ID1 <= tds$ID2, ] # or < if you want strictly lower triangle + } + + # Write the batch to disk or accumulate in the data frame. + if (nrow(tds) > 0) { + if (writetodisk == TRUE) { + write_buffer[[length(write_buffer) + 1]] <- tds + + if (length(write_buffer) >= write_buffer_size) { # Write in batches + utils::write.table(do.call(rbind, write_buffer), + file = rel_pairs_file, + row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," + ) + write_buffer <- list() + } + } else { + df_relpairs <- rbind(df_relpairs, tds) + } + } + } + if (verbose && (j %% update_rate == 0L)) { + cat("Done with", j, "of", nc, "\n") + } + } + } else if (sum_nulls == 2) { + # --- Case: Two Matrices Provided --- + # Set pointers and relationship names based on which matrix is missing. + + if (is.null(ad_ped_matrix)) { + newColPos1 <- mt_p + iss1 <- mt_i + x1 <- mt_x + newColPos2 <- cn_p + iss2 <- cn_i + x2 <- cn_x + relNames <- c("mitRel", "cnuRel") + if (gc == TRUE) { + remove(mt_p, mt_i, mt_x, cn_p, cn_i, cn_x) + } + } + if (is.null(mit_ped_matrix)) { + newColPos1 <- ad_ped_p + iss1 <- ad_ped_i + x1 <- ad_ped_x + newColPos2 <- cn_p + iss2 <- cn_i + x2 <- cn_x + relNames <- c("addRel", "cnuRel") + if (gc == TRUE) { + remove(ad_ped_p, ad_ped_i, ad_ped_x, cn_p, cn_i, cn_x) + } + } + if (is.null(cn_ped_matrix)) { + newColPos1 <- ad_ped_p + iss1 <- ad_ped_i + x1 <- ad_ped_x + newColPos2 <- mt_p + iss2 <- mt_i + x2 <- mt_x + relNames <- c("addRel", "mitRel") + if (gc == TRUE) { + remove(ad_ped_p, ad_ped_i, ad_ped_x, mt_p, mt_i, mt_x) + } + } + + # Initialize the related pairs file with the appropriate headers. + df_relpairs <- initialize_empty_df(relNames = relNames) + + if (writetodisk == TRUE) { + utils::write.table( + df_relpairs, + file = rel_pairs_file, sep = ",", append = FALSE, row.names = FALSE + ) + # initial buffer + write_buffer <- list() + remove(df_relpairs) + } + + # Process each column to extract relationships. + for (j in 1L:nc) { + ID2 <- ids[j] + + # Extract indices from the first matrix. + ncp1 <- newColPos1[j] + ncp1p <- newColPos1[j + 1L] + cond1 <- ncp1 < ncp1p + if (cond1) { + vv1 <- ncp1:(ncp1p - 1L) + iss1vv <- iss1[vv1] + } + # Extract indices from the second matrix. + ncp2 <- newColPos2[j] + ncp2p <- newColPos2[j + 1L] + cond2 <- ncp2 < ncp2p + if (cond2) { + vv2 <- ncp2:(ncp2p - 1L) + iss2vv <- iss2[vv2] + } + + # Merge the indices from both matrices. + u <- sort(igraph::union(if (cond1) { + iss1vv + }, if (cond2) { + iss2vv + })) + + # Create related pairs if relationships are found. + if (cond1 || cond2) { + ID1 <- ids[u] + tds <- data.frame(ID1 = ID1, ID2 = ID2) + tds[[relNames[1]]] <- 0 + tds[[relNames[2]]] <- 0 + + if (cond1) { + tds[u %in% iss1vv, relNames[1]] <- x1[vv1] + } + if (cond2) { + tds[u %in% iss2vv, relNames[2]] <- x2[vv2] + } + if (drop_upper_triangular == TRUE) { + tds <- tds[tds$ID1 <= tds$ID2, ] # or < if you want strictly lower triangle + } + + # Write the batch to disk or accumulate in the data frame. + if (nrow(tds) > 0) { + if (writetodisk == TRUE) { + write_buffer[[length(write_buffer) + 1]] <- tds + + if (length(write_buffer) >= write_buffer_size) { # Write in batches + utils::write.table(do.call(rbind, write_buffer), + file = rel_pairs_file, + row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," + ) + write_buffer <- list() + } + } else { + df_relpairs <- rbind(df_relpairs, tds) + } + } + } + if (verbose && (j %% update_rate == 0L)) { + cat("Done with", j, "of", nc, "\n") + } + } + } else if (sum_nulls == 1) { + # --- Case: Only One Matrix Provided --- + if (verbose) { + message("Only one matrix is present") + } + if (!is.null(ad_ped_matrix)) { + newColPos1 <- ad_ped_p + iss1 <- ad_ped_i + x1 <- ad_ped_x + relNames <- c("addRel") + if (gc == TRUE) { + remove(ad_ped_p, ad_ped_i, ad_ped_x) + } + } + if (!is.null(mit_ped_matrix)) { + newColPos1 <- mt_p + iss1 <- mt_i + x1 <- mt_x + relNames <- c("mitRel") + if (gc == TRUE) { + remove(mt_p, mt_i, mt_x) + } + } + if (!is.null(cn_ped_matrix)) { + newColPos1 <- cn_p + iss1 <- cn_i + x1 <- cn_x + relNames <- c("cnuRel") + if (gc == TRUE) { + remove(cn_p, cn_i, cn_x) + } + } + + # Initialize the related pairs file. + df_relpairs <- initialize_empty_df(relNames = relNames) + + if (writetodisk == TRUE) { + utils::write.table( + df_relpairs, + file = rel_pairs_file, sep = ",", append = FALSE, row.names = FALSE + ) + + # initial buffer + write_buffer <- list() + + remove(df_relpairs) + } + + # Process each column. + for (j in 1L:nc) { + ID2 <- ids[j] + # Extract column indices + ncp1 <- newColPos1[j] + ncp1p <- newColPos1[j + 1L] + cond1 <- ncp1 < ncp1p + if (cond1) { + vv1 <- ncp1:(ncp1p - 1L) + iss1vv <- iss1[vv1] + } + + # Use the indices from the single matrix. + u <- sort(iss1vv) + + if (cond1) { + ID1 <- ids[u] + tds <- data.frame(ID1 = ID1, ID2 = ID2) + tds[[relNames[1]]] <- 0 + + if (cond1) { + tds[u %in% iss1vv, relNames[1]] <- x1[vv1] + } + if (drop_upper_triangular == TRUE) { + tds <- tds[tds$ID1 <= tds$ID2, ] # or < if you want strictly lower triangle + } + + # Write the batch to disk or accumulate in the data frame. + if (nrow(tds) > 0) { + if (writetodisk == TRUE) { + write_buffer[[length(write_buffer) + 1]] <- tds + + if (length(write_buffer) >= write_buffer_size) { # Write in batches + utils::write.table(do.call(rbind, write_buffer), + file = rel_pairs_file, + row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," + ) + write_buffer <- list() + } + } else { + df_relpairs <- rbind(df_relpairs, tds) + } + } + } + if (verbose && (j %% update_rate == 0L)) { + cat("Done with", j, "of", nc, "\n") + } + } + } else { + stop("No matrices provided") + } + + # If not writing to disk, return the accumulated data frame. + if (writetodisk == FALSE) { + return(df_relpairs) + } else { + # Write any remaining buffered rows. + if (length(write_buffer) > 0) { + utils::write.table(do.call(rbind, write_buffer), + file = rel_pairs_file, + row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," + ) + } + # return(NULL) + } + } else if (legacy) { + # --- Legacy Mode --- + # In legacy mode, convert matrices to the expected symmetric formats. + com2links.og( + rel_pairs_file = rel_pairs_file, + ad_ped_matrix = ad_ped_matrix, + mit_ped_matrix = mit_ped_matrix, + cn_ped_matrix = cn_ped_matrix, + update_rate = update_rate, + verbose = verbose, + outcome_name = outcome_name + ) + return(NULL) + } + + # --- End of Legacy Mode --- + + # Merge and write the parentage matrices + # df <- full_join(mat_ped_matrix %>% arrange(ID), pat_ped_matrix %>% arrange(ID)) + + # write.table(df, file = mapa_id_file, sep = ",", append = FALSE, row.names = FALSE) +} + +#' Convert Pedigree Matrices to Related Pairs File (Legacy) +#' @description +#' This legacy function converts pedigree matrices into a related pairs file. +#' @inheritParams com2links +#' @keywords internal + + +com2links.og <- function( + rel_pairs_file = "dataRelatedPairs.csv", + ad_ped_matrix = NULL, + mit_ped_matrix = mt_ped_matrix, + mt_ped_matrix = NULL, + cn_ped_matrix = NULL, + update_rate = 500, + verbose = FALSE, + outcome_name = "data", + ...) { + # --- Legacy Mode --- + if (verbose) { + message("Using legacy mode") + } + # In legacy mode, convert matrices to the expected symmetric formats. + + # load(paste0(outcome_name,'_dataBiggestCnPedigree.Rdata')) + # biggestCnPed <- methods::as(biggestCnPed, "symmetricMatrix") + # load(paste0(outcome_name,'_dataBiggestPedigree.Rdata')) + # load(paste0(outcome_name,'_dataBiggestMtPedigree.Rdata')) + + # rel_pairs_file <- paste0(outcome_name,'_datacnmitBiggestRelatedPairsTake3.csv') + + biggestMtPed <- mit_ped_matrix + remove(mit_ped_matrix) + biggestCnPed <- methods::as(cn_ped_matrix, "symmetricMatrix") + remove(cn_ped_matrix) + biggestPed <- ad_ped_matrix + remove(ad_ped_matrix) + biggestMtPed@x[biggestMtPed@x > 0] <- 1 + + # Set the output file name. + if (exists("rel_pairs_file")) { + fname <- rel_pairs_file + } else { + fname <- paste0(outcome_name, "_dataBiggestRelatedPairsTake2.csv") + } + # Initialize the output file with headers. + ds <- data.frame( + ID1 = numeric(0), ID2 = numeric(0), + addRel = numeric(0), + mitRel = numeric(0), cnuRel = numeric(0) + ) + + utils::write.table(ds, + file = fname, sep = ",", + append = FALSE, row.names = FALSE + ) + + # Extract IDs from the common nuclear matrix. + ids <- as.numeric(dimnames(biggestCnPed)[[1]]) + + # Extract pointers from the legacy matrices. + newColPos1 <- biggestPed@p + 1L + iss1 <- biggestPed@i + 1L + newColPos2 <- biggestMtPed@p + 1L + iss2 <- biggestMtPed@i + 1L + newColPos3 <- biggestCnPed@p + 1L + iss3 <- biggestCnPed@i + 1L + nc <- ncol(biggestPed) + + # Process each individual. + for (j in 1L:nc) { + ID2 <- ids[j] + ncp1 <- newColPos1[j] + ncp1p <- newColPos1[j + 1L] + cond1 <- ncp1 < ncp1p + if (cond1) { + vv1 <- ncp1:(ncp1p - 1L) + iss1vv <- iss1[vv1] + } + ncp2 <- newColPos2[j] + ncp2p <- newColPos2[j + 1L] + cond2 <- ncp2 < ncp2p + if (cond2) { + vv2 <- ncp2:(ncp2p - 1L) + iss2vv <- iss2[vv2] + } + ncp3 <- newColPos3[j] + ncp3p <- newColPos3[j + 1L] + cond3 <- ncp3 < ncp3p + if (cond3) { + vv3 <- ncp3:(ncp3p - 1L) + iss3vv <- iss3[vv3] + } + + # Merge indices from all three matrices. + u <- sort(igraph::union(igraph::union(if (cond1) { + iss1vv + }, if (cond2) { + iss2vv + }), if (cond3) { + iss3vv + })) + # browser() + if (cond1 || cond2 || cond3) { + ID1 <- ids[u] + tds <- data.frame( + ID1 = ID1, ID2 = ID2, + addRel = 0, mitRel = 0, cnuRel = 0 + ) + if (cond1) { + tds$addRel[u %in% iss1vv] <- biggestPed@x[vv1] + } + if (cond2) { + tds$mitRel[u %in% iss2vv] <- biggestMtPed@x[vv2] + } + if (cond3) { + tds$cnuRel[u %in% iss3vv] <- biggestCnPed@x[vv3] + } + utils::write.table(tds, + file = fname, row.names = FALSE, + col.names = FALSE, append = TRUE, sep = "," + ) + } + if (!(j %% update_rate)) { + cat(paste0("Done with ", j, " of ", nc, "\n")) + } + } + return(NULL) +} + diff --git a/tests/testthat/test-makeLinks.R b/tests/testthat/test-makeLinks.R index 51bdcb49..52cc13c1 100644 --- a/tests/testthat/test-makeLinks.R +++ b/tests/testthat/test-makeLinks.R @@ -7,10 +7,9 @@ test_that("com2links handles missing matrices properly", { - test_that("com2links rejects invalid matrix types", { fake_matrix <- data.frame(A = c(1, 2), B = c(3, 4)) - expect_error(com2links(ad_ped_matrix = fake_matrix), "The 'ad_ped_matrix' must be a matrix or dgCMatrix.") + expect_error(com2links(ad_ped_matrix = fake_matrix), "The 'ad_ped_matrix' must be a matrix or generalMatrix") }) test_that("com2links produces correct output with a single relationship matrix (hazard dataset)", { @@ -27,12 +26,12 @@ test_that("com2links produces correct output with a single relationship matrix ( test_that("com2links produces correct output with cn_ped_matrix", { data(ASOIAF) - cn_ped_matrix <- ped2mit(ASOIAF, sparse = TRUE) + cn_ped_matrix <- ped2cn(ASOIAF, sparse = TRUE) result <- com2links(cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE) expect_true(is.data.frame(result)) - expect_true(all(c("ID1", "ID2", "cnRel") %in% colnames(result))) + expect_true(all(c("ID1", "ID2", "cnuRel") %in% colnames(result))) expect_equal(ncol(result), 3) # Expect ID1, ID2, and addRel expect_true(all(result$cnRel >= 0)) # Relatedness values should be non-negative }) @@ -65,7 +64,47 @@ test_that("com2links processes multiple matrices correctly (hazard dataset)", { expect_true(all(result$cnuRel >= 0)) }) +test_that("com2links processes creates same length for cn with 3, 2, and 1 matrices are used", { + data(hazard) + ad_ped_matrix <- ped2add(hazard, sparse = TRUE) + mit_ped_matrix <- ped2mit(hazard, sparse = TRUE) + cn_ped_matrix <- ped2cn(hazard, sparse = TRUE) + + result3 <- com2links(ad_ped_matrix = ad_ped_matrix, mit_ped_matrix = mit_ped_matrix, cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE) + + expect_true(is.data.frame(result3)) + expect_true(all(c("ID1", "ID2", "addRel", "mitRel", "cnuRel") %in% colnames(result3))) + expect_equal(ncol(result3), 5) # Expect ID1, ID2, addRel, mitRel, and cnuRel + expect_true(all(result3$addRel >= 0)) + expect_true(all(result3$mitRel %in% c(0, 1))) # Mitochondrial should be binary + expect_true(all(result3$cnuRel >= 0)) + + result2 <- com2links(ad_ped_matrix = ad_ped_matrix, cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE) + expect_true(is.data.frame(result2)) + expect_true(all(c("ID1", "ID2", "addRel", "cnuRel") %in% colnames(result2))) + expect_equal(ncol(result2), 4) # Expect ID1, ID2, addRel, and cnuRel + expect_true(all(result2$addRel >= 0)) + expect_true(all(result2$cnuRel >= 0)) + + expect_equal(result3$cnuRel,result2$cnuRel) + + result1 <- com2links(cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE) + result1_legacy <- com2links.legacy(cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE) + expect_true(is.data.frame(result1)) + expect_true(is.data.frame(result1_legacy)) + expect_true(all(c("ID1", "ID2", "cnuRel") %in% colnames(result1))) + expect_true(all(c("ID1", "ID2", "cnuRel") %in% colnames(result1_legacy))) + expect_equal(ncol(result1), 3) # Expect ID1, ID2, and cnuRel + expect_equal(ncol(result1_legacy), 3) # Expect ID1, ID2, and cnuRel + expect_true(all(result1$cnuRel >= 0)) + expect_true(all(result1_legacy$cnuRel >= 0)) + expect_equal(result3$cnuRel,result1$cnuRel) + expect_equal(result3$cnuRel,result1_legacy$cnuRel) + expect_equal(result2$cnuRel,result1$cnuRel) + expect_equal(result2$cnuRel,result1_legacy$cnuRel) + expect_equal(result1$cnuRel,result1_legacy$cnuRel) +}) test_that("com2links written version matchs", { data(hazard) ad_ped_matrix <- ped2com(hazard, component = "additive", adjacency_method = "direct", sparse = TRUE) @@ -236,7 +275,7 @@ test_that("com2links correctly handles missing matrices", { "At least one of 'ad_ped_matrix', 'mit_ped_matrix', or 'cn_ped_matrix' must be provided." ) - expect_error(com2links(ad_ped_matrix = hazard), "The 'ad_ped_matrix' must be a matrix or dgCMatrix.") + expect_error(com2links(ad_ped_matrix = hazard), "The 'ad_ped_matrix' must be a matrix or generalMatrix") }) test_that("com2links correctly processes inbreeding dataset", { @@ -281,14 +320,16 @@ test_that("com2links handles large batch writing correctly", { sexR <- 0.5 df_fam <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) - ad_ped_matrix <- ped2add(df_fam, sparse = TRUE) + cn_ped_matrix <- ped2cn(df_fam, sparse = TRUE) temp_file <- tempfile(fileext = ".csv") - com2links(ad_ped_matrix = ad_ped_matrix, rel_pairs_file = temp_file, writetodisk = TRUE, verbose = TRUE) + com2links(cn_ped_matrix = cn_ped_matrix, rel_pairs_file = temp_file, writetodisk = TRUE, verbose = TRUE) expect_true(file.exists(temp_file)) written_data <- read.csv(temp_file) expect_true(nrow(written_data) > 1000) # Ensuring batch writing logic works + expect_true(file.remove(temp_file)) + }) test_that("com2links garbage collection does not affect output, using two components", { From 8039f67956e256ef2dd282eba34e4b635856246c Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Thu, 10 Apr 2025 15:16:44 -0400 Subject: [PATCH 26/69] more tests and exploring option to write out all values --- R/makeLinks.R | 46 ++++++++++++++++++++++++------ man/com2links.Rd | 3 ++ man/com2links.legacy.Rd | 6 ++-- man/com2links.og.Rd | 2 +- man/process_one.Rd | 45 +++++++++++++++++++++++++++++ tests/testthat/test-makeLinks.R | 12 ++++---- tests/testthat/test-plotPedigree.R | 17 +++++++++++ 7 files changed, 112 insertions(+), 19 deletions(-) create mode 100644 man/process_one.Rd diff --git a/R/makeLinks.R b/R/makeLinks.R index 0156717c..46e7d743 100644 --- a/R/makeLinks.R +++ b/R/makeLinks.R @@ -17,6 +17,7 @@ #' @param legacy Logical. If TRUE, uses the legacy branch of the function. #' @param outcome_name Character string representing the outcome name (used in file naming). #' @param drop_upper_triangular Logical. If TRUE, drops the upper triangular portion of the matrix. +#' @param include_all_links_1ped Logical. If TRUE, includes all links in the output. (Default is true when only one ped is provided) #' @param ... Additional arguments to be passed to \code{\link{com2links}} #' #' @return A data frame of related pairs if \code{writetodisk} is FALSE; otherwise, writes the results to disk. @@ -39,6 +40,7 @@ com2links <- function( legacy = FALSE, outcome_name = "data", drop_upper_triangular = TRUE, + include_all_links_1ped=FALSE, ...) { # --- Input Validations and Preprocessing --- @@ -118,6 +120,7 @@ com2links <- function( update_rate = update_rate, verbose = verbose, gc = gc, + include_all_links = include_all_links_1ped, ... ), "mt" = process_one( @@ -132,6 +135,7 @@ com2links <- function( update_rate = update_rate, verbose = verbose, gc = gc, + include_all_links = include_all_links_1ped, ... ), "cn" = process_one( @@ -146,6 +150,7 @@ com2links <- function( update_rate = update_rate, verbose = verbose, gc = gc, + include_all_links = include_all_links_1ped, ... ), "ad-mt" = process_two( @@ -217,13 +222,17 @@ com2links <- function( stop("Unsupported matrix combination") ) } -#' Convert Sparse Relationship Matrices to Kinship Links +#' Convert Sparse Relationship Matrices to Kinship Links for one Matrix #' @inheritParams com2links +#' @param include_all_links Logical. If TRUE, all links are included in the output. #' @keywords internal -process_one <- function(matrix, rel_name, ids, nc, rel_pairs_file, writetodisk, write_buffer_size, drop_upper_triangular, update_rate, verbose, gc, ...) { +process_one <- function(matrix, rel_name, ids, nc, rel_pairs_file, writetodisk, + write_buffer_size, drop_upper_triangular, update_rate, verbose, gc, + include_all_links=TRUE, ...) { + if (include_all_links == FALSE) { # Extract pointers and indices from the matrix. newColPos <- matrix@p + 1L iss <- matrix@i + 1L @@ -245,7 +254,8 @@ process_one <- function(matrix, rel_name, ids, nc, rel_pairs_file, writetodisk, # Process each column in the matrix. for (j in 1L:nc) { - ID2 <- ids[j] + + ID2 <- ids[j] # Extract column indices ncp <- newColPos[j] @@ -261,10 +271,10 @@ process_one <- function(matrix, rel_name, ids, nc, rel_pairs_file, writetodisk, # If any relationships exist for this individual, build the related pairs. if (cond) { - ID1 <- ids[u] - tds <- data.frame(ID1 = ID1, ID2 = ID2) - tds[[rel_name]] <- 0 - + # Create a data frame with unique pairs. + ID1 <- ids[u] + tds <- data.frame(ID1 = ID1, ID2 = ID2) + tds[[rel_name]] <- 0 if (cond) { tds[u %in% issvv, rel_name] <- x[vv] } @@ -307,6 +317,26 @@ process_one <- function(matrix, rel_name, ids, nc, rel_pairs_file, writetodisk, } if (gc == TRUE) { remove(newColPos, iss, x) + } + }else{ + matrix2= matrix(rep(1,length(ids)^2), + nrow = length(ids), + dimnames = list(ids, ids)) + process_two(matrix2=matrix, name2=rel_name, + matrix1=methods::as(matrix2,"CsparseMatrix"), + name1="phantom", + ids=ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc) + + + } } @@ -524,7 +554,7 @@ process_two <- function( #' @return The validated and converted matrix. validate_and_convert_matrix <- function(mat, name, ensure_symmetric = FALSE, force_binary = FALSE) { if (!inherits(mat, c("matrix", "dgCMatrix", "dsCMatrix","generalMatrix", - "symmetricMatrix", "triangularMatrix", "dsyMatrix", "dspMatrix", "dsyMatrix"))) { + "symmetricMatrix", "triangularMatrix", "dsyMatrix", "dspMatrix", "dsyMatrix",'CsparseMatrix'))) { stop(paste0("The '", name, "' must be a matrix or generalMatrix")) } if (!inherits(mat, "generalMatrix")) { diff --git a/man/com2links.Rd b/man/com2links.Rd index 9dae2f09..dc846645 100644 --- a/man/com2links.Rd +++ b/man/com2links.Rd @@ -18,6 +18,7 @@ com2links( legacy = FALSE, outcome_name = "data", drop_upper_triangular = TRUE, + include_all_links_1ped = FALSE, ... ) } @@ -48,6 +49,8 @@ com2links( \item{drop_upper_triangular}{Logical. If TRUE, drops the upper triangular portion of the matrix.} +\item{include_all_links_1ped}{Logical. If TRUE, includes all links in the output. (Default is true when only one ped is provided)} + \item{...}{Additional arguments to be passed to \code{\link{com2links}}} } \value{ diff --git a/man/com2links.legacy.Rd b/man/com2links.legacy.Rd index bf4bc6e4..4467dc85 100644 --- a/man/com2links.legacy.Rd +++ b/man/com2links.legacy.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/makeLinks.R +% Please edit documentation in R/makeLinkslegacy.R \name{com2links.legacy} \alias{com2links.legacy} \title{Convert Sparse Relationship Matrices to Kinship Links} @@ -51,8 +51,6 @@ com2links.legacy( \item{...}{Additional arguments to be passed to \code{\link{com2links}}} } \description{ -This function processes one or more sparse relationship components (additive, mitochondrial, -and common nuclear) and converts them into kinship link pairs. The resulting related pairs are -either returned as a data frame or written to disk in CSV format. +Convert Sparse Relationship Matrices to Kinship Links } \keyword{internal} diff --git a/man/com2links.og.Rd b/man/com2links.og.Rd index b6c3d71b..e51c53cd 100644 --- a/man/com2links.og.Rd +++ b/man/com2links.og.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/makeLinks.R +% Please edit documentation in R/makeLinkslegacy.R \name{com2links.og} \alias{com2links.og} \title{Convert Pedigree Matrices to Related Pairs File (Legacy)} diff --git a/man/process_one.Rd b/man/process_one.Rd new file mode 100644 index 00000000..0d57de2b --- /dev/null +++ b/man/process_one.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/makeLinks.R +\name{process_one} +\alias{process_one} +\title{Convert Sparse Relationship Matrices to Kinship Links for one Matrix} +\usage{ +process_one( + matrix, + rel_name, + ids, + nc, + rel_pairs_file, + writetodisk, + write_buffer_size, + drop_upper_triangular, + update_rate, + verbose, + gc, + include_all_links = TRUE, + ... +) +} +\arguments{ +\item{rel_pairs_file}{File path to write related pairs to (CSV format).} + +\item{writetodisk}{Logical. If TRUE, writes the related pairs to disk; if FALSE, returns a data frame.} + +\item{write_buffer_size}{Number of related pairs to write to disk at a time.} + +\item{drop_upper_triangular}{Logical. If TRUE, drops the upper triangular portion of the matrix.} + +\item{update_rate}{Numeric. Frequency (in iterations) at which progress messages are printed.} + +\item{verbose}{Logical. If TRUE, prints progress messages.} + +\item{gc}{Logical. If TRUE, performs garbage collection via \code{\link{gc}} to free memory.} + +\item{include_all_links}{Logical. If TRUE, all links are included in the output.} + +\item{...}{Additional arguments to be passed to \code{\link{com2links}}} +} +\description{ +Convert Sparse Relationship Matrices to Kinship Links for one Matrix +} +\keyword{internal} diff --git a/tests/testthat/test-makeLinks.R b/tests/testthat/test-makeLinks.R index 52cc13c1..e23b2390 100644 --- a/tests/testthat/test-makeLinks.R +++ b/tests/testthat/test-makeLinks.R @@ -98,11 +98,11 @@ test_that("com2links processes creates same length for cn with 3, 2, and 1 matri expect_equal(ncol(result1_legacy), 3) # Expect ID1, ID2, and cnuRel expect_true(all(result1$cnuRel >= 0)) expect_true(all(result1_legacy$cnuRel >= 0)) - expect_equal(result3$cnuRel,result1$cnuRel) - expect_equal(result3$cnuRel,result1_legacy$cnuRel) - expect_equal(result2$cnuRel,result1$cnuRel) - expect_equal(result2$cnuRel,result1_legacy$cnuRel) - expect_equal(result1$cnuRel,result1_legacy$cnuRel) + expect_equal(result3$cnuRel[result3$cnuRel==1],result1$cnuRel[result1$cnuRel==1]) + expect_equal(result3$cnuRel[result3$cnuRel==1],result1_legacy$cnuRel[result1_legacy$cnuRel==1]) + expect_equal(result2$cnuRel[result2$cnuRel==1],result1$cnuRel[result1$cnuRel==1]) + expect_equal(result2$cnuRel[result2$cnuRel==1],result1_legacy$cnuRel[result1_legacy$cnuRel==1]) + expect_equal(result1$cnuRel[result1$cnuRel==1],result1_legacy$cnuRel[result1_legacy$cnuRel==1]) }) test_that("com2links written version matchs", { @@ -327,7 +327,7 @@ test_that("com2links handles large batch writing correctly", { expect_true(file.exists(temp_file)) written_data <- read.csv(temp_file) - expect_true(nrow(written_data) > 1000) # Ensuring batch writing logic works + expect_true(nrow(written_data) == 155) # Ensuring batch writing logic works expect_true(file.remove(temp_file)) }) diff --git a/tests/testthat/test-plotPedigree.R b/tests/testthat/test-plotPedigree.R index 4944bcdb..2c5199d7 100644 --- a/tests/testthat/test-plotPedigree.R +++ b/tests/testthat/test-plotPedigree.R @@ -32,3 +32,20 @@ test_that("pedigree plots correctly with affected variables", { # file.remove("Rplots.pdf") }) # file.remove("Rplots.pdf") + +test_that("pedigree errs when affected variables named", { +data(inbreeding) + + expect_error(plotPedigree(data, verbose = TRUE, affected = "affected")) + + +}) + + +test_that("pedigree plots multiple families", { + data(inbreeding) + + expect_output(plotPedigree(inbreeding, verbose = TRUE)) + + +}) From 728d56030249f8497eecb66c38a95df7d63c3261 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Fri, 11 Apr 2025 09:20:00 -0400 Subject: [PATCH 27/69] additional aliases --- NAMESPACE | 4 ++++ NEWS.md | 1 + R/calculateFamilySize.R | 23 +++++++++++++------ R/helpGeneric.R | 14 +++++++---- R/helpPedigree.R | 6 ++++- R/insertEven.R | 6 ++++- R/simulatePedigree.R | 14 ++++------- R/tweakPedigree.R | 2 +- man/assignCoupleIds.Rd | 5 +++- man/{allGens.Rd => calcAllGens.Rd} | 5 +++- man/{famSizeCal.Rd => calcFamilySize.Rd} | 5 +++- ...{sizeAllGens.Rd => calcFamilySizeByGen.Rd} | 5 +++- man/{evenInsert.Rd => insertEven.Rd} | 5 +++- man/{nullToNA.Rd => null2NA.Rd} | 5 +++- man/{try_na.Rd => tryNA.Rd} | 5 +++- 15 files changed, 75 insertions(+), 30 deletions(-) rename man/{allGens.Rd => calcAllGens.Rd} (91%) rename man/{famSizeCal.Rd => calcFamilySize.Rd} (90%) rename man/{sizeAllGens.Rd => calcFamilySizeByGen.Rd} (86%) rename man/{evenInsert.Rd => insertEven.Rd} (93%) rename man/{nullToNA.Rd => null2NA.Rd} (86%) rename man/{try_na.Rd => tryNA.Rd} (89%) diff --git a/NAMESPACE b/NAMESPACE index 47496f84..972282d4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,8 @@ export(SimPed) export(allGens) +export(calcAllGens) +export(calcFamilySize) export(calculateRelatedness) export(checkIDs) export(checkParentIDs) @@ -17,6 +19,7 @@ export(famSizeCal) export(fitComponentModel) export(identifyComponentModel) export(inferRelatedness) +export(insertEven) export(makeInbreeding) export(makeTwins) export(parseTree) @@ -38,6 +41,7 @@ export(relatedness) export(repairSex) export(resample) export(simulatePedigree) +export(sizeAllGens) export(summarizeFamilies) export(summarizeMatrilines) export(summarizePatrilines) diff --git a/NEWS.md b/NEWS.md index 94602bd7..fd941969 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,6 +5,7 @@ * reduced complexity of com2links, summarizePedigree, and checkIDs with the use of subfunctions * allow verbose argument to be passed to standardizeColnames * list SimPed and related_coef as aliases for functions +* harmonizing function names like calcFamilySize from famSizeCal # BGmisc 1.3.5.1 * Setting the default for the `sparse` argument in `ped2com()` to TRUE diff --git a/R/calculateFamilySize.R b/R/calculateFamilySize.R index 51365d85..06cc3f16 100644 --- a/R/calculateFamilySize.R +++ b/R/calculateFamilySize.R @@ -5,7 +5,7 @@ #' @param marR Mating rate (numeric value ranging from 0 to 1). #' @return Returns a vector containing the number of individuals in every generation. #' @export -allGens <- function(kpc, Ngen, marR) { +calcAllGens <- function(kpc, Ngen, marR) { # Check if the number of generations is valid if (Ngen < 1) { stop("The number of generations should be an integer greater or equal than 1") @@ -23,14 +23,16 @@ allGens <- function(kpc, Ngen, marR) { } return(allGens) } - +#' @rdname calcAllGens +#' @export +allGens <- calcAllGens #' sizeAllGens #' An internal supporting function for \code{simulatePedigree}. -#' @inheritParams allGens +#' @inheritParams calcAllGens #' @return Returns a vector including the number of individuals in every generation. -sizeAllGens <- function(kpc, Ngen, marR) { +calcFamilySizeByGen <- function(kpc, Ngen, marR) { Nmid <- Ngen - 2 midGens <- numeric(length = Nmid) @@ -46,14 +48,16 @@ sizeAllGens <- function(kpc, Ngen, marR) { # print(allGens) return(allGens) } - +#' @rdname calcFamilySizeByGen +#' @export +sizeAllGens <- calcFamilySizeByGen #' famSizeCal #' A function to calculate the total number of individuals in a pedigree given parameters. This is a supporting function for function \code{simulatePedigree} -#' @inheritParams allGens +#' @inheritParams calcAllGens #' @return Returns a numeric value indicating the total pedigree size. #' @export -famSizeCal <- function(kpc, Ngen, marR) { +calcFamilySize <- function(kpc, Ngen, marR) { if (Ngen < 1) { stop("The number of generations should be an integer greater than or equal to 1") } else if (Ngen == 1) { @@ -71,3 +75,8 @@ famSizeCal <- function(kpc, Ngen, marR) { } return(size) } + +#' @rdname calcFamilySize +#' @export +#' +famSizeCal <- calcFamilySize diff --git a/R/helpGeneric.R b/R/helpGeneric.R index 8dae2b2c..4e1d8ca9 100644 --- a/R/helpGeneric.R +++ b/R/helpGeneric.R @@ -24,10 +24,9 @@ rmvn <- function(n, sigma) { #' @param x vector of any length #' @return replaces null values in a vector to NA #' -nullToNA <- function(x) { +null2NA <- function(x) { if (length(x) == 0) { x <- NA - # Handle case when x is a list } else if (is.list(x)) { for (i in seq_along(x)) { @@ -39,6 +38,9 @@ nullToNA <- function(x) { return(x) } +#' @rdname null2NA +#' +nullToNA <- null2NA #' modified tryCatch function #' @@ -46,10 +48,14 @@ nullToNA <- function(x) { #' @keywords internal #' @return Fuses the nullToNA function with efunc #' -try_na <- function(x) { - nullToNA(tryCatch(x, error = efunc)) +tryNA <- function(x) { + null2NA(tryCatch(x, error = efunc)) } +#' @rdname tryNA +#' @keywords internal +#' +try_na <- tryNA #' Compute the null space of a matrix #' #' @param M a matrix of which the null space is desired diff --git a/R/helpPedigree.R b/R/helpPedigree.R index 7b6bb4be..3d054d4b 100644 --- a/R/helpPedigree.R +++ b/R/helpPedigree.R @@ -60,7 +60,7 @@ determineSex <- function(idGen, sexR) { #' #' @param df_Ngen The dataframe for the current generation, including columns for individual IDs and spouse IDs. #' @return The input dataframe augmented with a 'coupleId' column, where each mated pair has a unique identifier. -assignCoupleIds <- function(df_Ngen) { +assignCoupleIDs <- function(df_Ngen) { df_Ngen$coupleId <- NA_character_ # Initialize the coupleId column with NAs usedCoupleIds <- character() # Initialize an empty character vector to track used IDs @@ -86,6 +86,10 @@ assignCoupleIds <- function(df_Ngen) { return(df_Ngen) } + +#' @rdname assignCoupleIDs +assignCoupleIds <- assignCoupleIDs + #' Generate or Adjust Number of Kids per Couple Based on Mating Rate #' #' This function generates or adjusts the number of kids per couple in a generation diff --git a/R/insertEven.R b/R/insertEven.R index ba2d55e9..573bd8c9 100644 --- a/R/insertEven.R +++ b/R/insertEven.R @@ -12,7 +12,7 @@ #' @export #' @seealso \code{\link{SimPed}} for the main function that uses this supporting function. -evenInsert <- function(m, n, verbose = FALSE) { +insertEven <- function(m, n, verbose = FALSE) { if (length(m) > length(n)) { temp <- m m <- n @@ -36,3 +36,7 @@ evenInsert <- function(m, n, verbose = FALSE) { return(vec) } + +#' @rdname insertEven +#' @export +evenInsert <- insertEven diff --git a/R/simulatePedigree.R b/R/simulatePedigree.R index 29407af8..8fc88915 100644 --- a/R/simulatePedigree.R +++ b/R/simulatePedigree.R @@ -24,7 +24,6 @@ buildWithinGenerations <- function(sizeGens, marR, sexR, Ngen) { df_Ngen$sex <- determineSex(idGen = idGen, sexR = sexR) - # print(paste("tiger",i)) # The first generation if (i == 1) { @@ -181,11 +180,9 @@ buildBetweenGenerations <- function(df_Fam, Ngen, sizeGens, verbose, marR, sexR, # count the number of couples in the i th gen countCouple <- (nrow(df_Ngen) - sum(is.na(df_Ngen$spID))) * .5 - # Now, assign couple IDs for the current generation df_Ngen <- assignCoupleIds(df_Ngen) - # get the number of linked female and male children after excluding the single children # get a vector of single person id in the ith generation IdSingle <- df_Ngen$id[is.na(df_Ngen$spID)] @@ -194,9 +191,11 @@ buildBetweenGenerations <- function(df_Fam, Ngen, sizeGens, verbose, marR, sexR, SingleM <- sum(df_Ngen$sex == "M" & is.na(df_Ngen$spID)) CoupleM <- N_LinkedMale - SingleM - df_Fam[df_Fam$gen == i, ] <- markPotentialChildren(df_Ngen = df_Ngen, i = i, Ngen = Ngen, sizeGens = sizeGens, CoupleF = CoupleF) - - + df_Fam[df_Fam$gen == i, ] <- markPotentialChildren(df_Ngen = df_Ngen, + i = i, + Ngen = Ngen, + sizeGens = sizeGens, + CoupleF = CoupleF) if (verbose) { print( "Step 2.2: mark a group of potential parents in the i-1 th generation" @@ -251,7 +250,6 @@ buildBetweenGenerations <- function(df_Fam, Ngen, sizeGens, verbose, marR, sexR, # generate link kids to the couples random_numbers <- adjustKidsPerCouple(nMates = sum(df_Ngen$ifparent) / 2, kpc = kpc, rd_kpc = rd_kpc) - # cat("final random numbers",random_numbers, "\n") # cat("mean",sum(random_numbers)/length(random_numbers), "\n") # create two vectors for maId and paId; replicate the ids to match the same length as IdOfp @@ -391,8 +389,6 @@ simulatePedigree <- function(kpc = 3, sizeGens = sizeGens, verbose = verbose, marR = marR, sexR = sexR, kpc = kpc, rd_kpc = rd_kpc ) - - df_Fam <- df_Fam[, 1:7] df_Fam <- df_Fam[!(is.na(df_Fam$pat) & is.na(df_Fam$mat) & is.na(df_Fam$spID)), ] colnames(df_Fam)[c(2, 4, 5)] <- c("ID", "dadID", "momID") diff --git a/R/tweakPedigree.R b/R/tweakPedigree.R index edefaf99..d617851b 100644 --- a/R/tweakPedigree.R +++ b/R/tweakPedigree.R @@ -255,7 +255,7 @@ dropLink <- function(ped, if (!is.na(ID_drop)) { ped[ped$ID %in% ID_drop, c("dadID", "momID")] <- NA_integer_ } else { - warning("No individual is dropped from his/her parents.") + warning("No individual is dropped from their parents.") } } else { ped[ped$ID == ID_drop, c("dadID", "momID")] <- NA_integer_ diff --git a/man/assignCoupleIds.Rd b/man/assignCoupleIds.Rd index 7f379f64..95165581 100644 --- a/man/assignCoupleIds.Rd +++ b/man/assignCoupleIds.Rd @@ -1,9 +1,12 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/helpPedigree.R -\name{assignCoupleIds} +\name{assignCoupleIDs} +\alias{assignCoupleIDs} \alias{assignCoupleIds} \title{Assign Couple IDs} \usage{ +assignCoupleIDs(df_Ngen) + assignCoupleIds(df_Ngen) } \arguments{ diff --git a/man/allGens.Rd b/man/calcAllGens.Rd similarity index 91% rename from man/allGens.Rd rename to man/calcAllGens.Rd index 6bc6d9e0..66a89c25 100644 --- a/man/allGens.Rd +++ b/man/calcAllGens.Rd @@ -1,10 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/calculateFamilySize.R -\name{allGens} +\name{calcAllGens} +\alias{calcAllGens} \alias{allGens} \title{allGens A function to calculate the number of individuals in each generation. This is a supporting function for \code{simulatePedigree}.} \usage{ +calcAllGens(kpc, Ngen, marR) + allGens(kpc, Ngen, marR) } \arguments{ diff --git a/man/famSizeCal.Rd b/man/calcFamilySize.Rd similarity index 90% rename from man/famSizeCal.Rd rename to man/calcFamilySize.Rd index e51f95ee..a0128d0c 100644 --- a/man/famSizeCal.Rd +++ b/man/calcFamilySize.Rd @@ -1,10 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/calculateFamilySize.R -\name{famSizeCal} +\name{calcFamilySize} +\alias{calcFamilySize} \alias{famSizeCal} \title{famSizeCal A function to calculate the total number of individuals in a pedigree given parameters. This is a supporting function for function \code{simulatePedigree}} \usage{ +calcFamilySize(kpc, Ngen, marR) + famSizeCal(kpc, Ngen, marR) } \arguments{ diff --git a/man/sizeAllGens.Rd b/man/calcFamilySizeByGen.Rd similarity index 86% rename from man/sizeAllGens.Rd rename to man/calcFamilySizeByGen.Rd index e477c19e..ae3e5e88 100644 --- a/man/sizeAllGens.Rd +++ b/man/calcFamilySizeByGen.Rd @@ -1,10 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/calculateFamilySize.R -\name{sizeAllGens} +\name{calcFamilySizeByGen} +\alias{calcFamilySizeByGen} \alias{sizeAllGens} \title{sizeAllGens An internal supporting function for \code{simulatePedigree}.} \usage{ +calcFamilySizeByGen(kpc, Ngen, marR) + sizeAllGens(kpc, Ngen, marR) } \arguments{ diff --git a/man/evenInsert.Rd b/man/insertEven.Rd similarity index 93% rename from man/evenInsert.Rd rename to man/insertEven.Rd index 2dae39c1..7fc08138 100644 --- a/man/evenInsert.Rd +++ b/man/insertEven.Rd @@ -1,10 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/insertEven.R -\name{evenInsert} +\name{insertEven} +\alias{insertEven} \alias{evenInsert} \title{evenInsert A function to insert m elements evenly into a length n vector.} \usage{ +insertEven(m, n, verbose = FALSE) + evenInsert(m, n, verbose = FALSE) } \arguments{ diff --git a/man/nullToNA.Rd b/man/null2NA.Rd similarity index 86% rename from man/nullToNA.Rd rename to man/null2NA.Rd index 4bccb4b3..cb6d7571 100644 --- a/man/nullToNA.Rd +++ b/man/null2NA.Rd @@ -1,9 +1,12 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/helpGeneric.R -\name{nullToNA} +\name{null2NA} +\alias{null2NA} \alias{nullToNA} \title{nullToNA} \usage{ +null2NA(x) + nullToNA(x) } \arguments{ diff --git a/man/try_na.Rd b/man/tryNA.Rd similarity index 89% rename from man/try_na.Rd rename to man/tryNA.Rd index 0f8fddeb..388fa600 100644 --- a/man/try_na.Rd +++ b/man/tryNA.Rd @@ -1,9 +1,12 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/helpGeneric.R -\name{try_na} +\name{tryNA} +\alias{tryNA} \alias{try_na} \title{modified tryCatch function} \usage{ +tryNA(x) + try_na(x) } \arguments{ From 9641a042e25ae46be36446baaddf076599deec83 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Fri, 11 Apr 2025 09:28:45 -0400 Subject: [PATCH 28/69] Delete assignCoupleIds.Rd --- man/assignCoupleIds.Rd | 21 --------------------- 1 file changed, 21 deletions(-) delete mode 100644 man/assignCoupleIds.Rd diff --git a/man/assignCoupleIds.Rd b/man/assignCoupleIds.Rd deleted file mode 100644 index 95165581..00000000 --- a/man/assignCoupleIds.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/helpPedigree.R -\name{assignCoupleIDs} -\alias{assignCoupleIDs} -\alias{assignCoupleIds} -\title{Assign Couple IDs} -\usage{ -assignCoupleIDs(df_Ngen) - -assignCoupleIds(df_Ngen) -} -\arguments{ -\item{df_Ngen}{The dataframe for the current generation, including columns for individual IDs and spouse IDs.} -} -\value{ -The input dataframe augmented with a 'coupleId' column, where each mated pair has a unique identifier. -} -\description{ -This subfunction assigns a unique couple ID to each mated pair in the generation. -Unmated individuals are assigned NA for their couple ID. -} From 9525061de57fe2111b9cb6ae290bbc7d64a28ccf Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Fri, 11 Apr 2025 17:48:40 -0400 Subject: [PATCH 29/69] allow NAs to behave --- R/checkParents.R | 27 ++++++++++++++++++++++----- R/cleanPedigree.R | 4 ++-- 2 files changed, 24 insertions(+), 7 deletions(-) diff --git a/R/checkParents.R b/R/checkParents.R index b80669bf..7d142af1 100644 --- a/R/checkParents.R +++ b/R/checkParents.R @@ -145,7 +145,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, # Are any parents in both momID and dadID? momdad <- intersect(ped$dadID, ped$momID) - if (!is.na(momdad) && length(momdad) > 0) { + if (length(momdad) > 0&& !is.na(momdad)) { validation_results$parents_in_both <- momdad if (verbose) { cat(paste( @@ -185,21 +185,38 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, - if (!is.na(validation_results$female_var)) { + if (length(validation_results$female_var) > 0 && !is.na(validation_results$female_var)){ corrected_moms <- ped$ID[mom_indices[!is.na(mom_indices)]] ped$sex[mom_indices[!is.na(mom_indices)]] <- validation_results$female_var changes$corrected_mom_sex <- corrected_moms if (verbose && length(corrected_moms) > 0) { cat("Corrected sex of moms for:", paste(corrected_moms, collapse = ", "), "\n") } + } else { + corrected_moms <- ped$ID[mom_indices[!is.na(mom_indices)]] + ped$sex[mom_indices[!is.na(mom_indices)]] <- 0 + + changes$corrected_mom_sex <- corrected_moms + if (verbose && length(corrected_moms) > 0) { + cat("Corrected sex of moms for:", paste(corrected_moms, collapse = ", "), "\n") + } + } - if (!is.na(validation_results$male_var)) { + if (length(validation_results$male_var) > 0 && !is.na(validation_results$male_var)){ corrected_dads <- ped$ID[dad_indices[!is.na(dad_indices)]] ped$sex[dad_indices[!is.na(dad_indices)]] <- validation_results$male_var changes$corrected_dad_sex <- corrected_dads if (verbose && length(corrected_dads) > 0) { cat("Corrected sex of dads for:", paste(corrected_dads, collapse = ", "), "\n") } + } else { + corrected_dads <- ped$ID[dad_indices[!is.na(dad_indices)]] + ped$sex[dad_indices[!is.na(dad_indices)]] <- 1 + changes$corrected_dad_sex <- corrected_dads + if (verbose && length(corrected_dads) > 0) { + cat("Corrected sex of dads for:", paste(corrected_dads, collapse = ", "), "\n") + } + } } } @@ -218,7 +235,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, new_entry$ID <- new_id new_entry$dadID <- NA new_entry$momID <- NA - new_entry$sex <- validation_results$male_var + new_entry$sex <- if(length(validation_results$male_var) > 0 && !is.na(validation_results$male_var)) validation_results$male_var else 1 new_entries <- rbind(new_entries, new_entry) } @@ -231,7 +248,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, new_entry$ID <- new_id new_entry$dadID <- NA new_entry$momID <- NA - new_entry$sex <- validation_results$female_var + new_entry$sex <- if(length(validation_results$female_var) > 0 && !is.na(validation_results$female_var)) validation_results$female_var else 0 new_entries <- rbind(new_entries, new_entry) } diff --git a/R/cleanPedigree.R b/R/cleanPedigree.R index b03ca270..737b558c 100644 --- a/R/cleanPedigree.R +++ b/R/cleanPedigree.R @@ -16,9 +16,9 @@ standardizeColnames <- function(df, verbose = FALSE) { "fam" = "^(?:fam(?:ily)?[\\.\\-_]?(?:id)?)", "ID" = "^(?:i(?:d$|ndiv(?:idual)?)|p(?:erson)?[\\.\\-_]?id)", "gen" = "^(?:gen(?:s|eration)?)", - "dadID" = "^(?:d(?:ad)?id|paid|fatherid|pid[\\.\\-_]?fath[er]*)", + "dadID" = "^(?:d(?:ad)?id|paid|fatherid|pid[\\.\\-_]?fath[er]*|sire)", "patID" = "^(?:dat[\\.\\-_]?id|pat[\\.\\-_]?id|paternal[\\.\\-_]?(?:id)?)", - "momID" = "^(?:m(?:om|a|other)?[\\.\\-_]?id|pid[\\.\\-_]?moth[er]*)", + "momID" = "^(?:m(?:om|a|other)?[\\.\\-_]?id|pid[\\.\\-_]?moth[er]*|dame)", "matID" = "^(?:mat[\\.\\-_]?id|maternal[\\.\\-_]?(?:id)?)", "spID" = "^(?:s(?:pt)?id|spouse[\\.\\-_]?(?:id)?|partner[\\.\\-_]?(?:id)?|husb(?:and)?[\\.\\-_]?id|wife[\\.\\-_]?(?:id)?|pid[\\.\\-_]?spouse1?)", "twinID" = "^(?:twin[\\.\\-_]?(?:id)?)", From c18dbd758587b62d5a6af29422cd57795006ce95 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Fri, 11 Apr 2025 17:48:40 -0400 Subject: [PATCH 30/69] allow NAs to behave --- R/checkParents.R | 27 ++++++++++++++++++++++----- R/cleanPedigree.R | 4 ++-- 2 files changed, 24 insertions(+), 7 deletions(-) diff --git a/R/checkParents.R b/R/checkParents.R index b80669bf..7d142af1 100644 --- a/R/checkParents.R +++ b/R/checkParents.R @@ -145,7 +145,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, # Are any parents in both momID and dadID? momdad <- intersect(ped$dadID, ped$momID) - if (!is.na(momdad) && length(momdad) > 0) { + if (length(momdad) > 0&& !is.na(momdad)) { validation_results$parents_in_both <- momdad if (verbose) { cat(paste( @@ -185,21 +185,38 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, - if (!is.na(validation_results$female_var)) { + if (length(validation_results$female_var) > 0 && !is.na(validation_results$female_var)){ corrected_moms <- ped$ID[mom_indices[!is.na(mom_indices)]] ped$sex[mom_indices[!is.na(mom_indices)]] <- validation_results$female_var changes$corrected_mom_sex <- corrected_moms if (verbose && length(corrected_moms) > 0) { cat("Corrected sex of moms for:", paste(corrected_moms, collapse = ", "), "\n") } + } else { + corrected_moms <- ped$ID[mom_indices[!is.na(mom_indices)]] + ped$sex[mom_indices[!is.na(mom_indices)]] <- 0 + + changes$corrected_mom_sex <- corrected_moms + if (verbose && length(corrected_moms) > 0) { + cat("Corrected sex of moms for:", paste(corrected_moms, collapse = ", "), "\n") + } + } - if (!is.na(validation_results$male_var)) { + if (length(validation_results$male_var) > 0 && !is.na(validation_results$male_var)){ corrected_dads <- ped$ID[dad_indices[!is.na(dad_indices)]] ped$sex[dad_indices[!is.na(dad_indices)]] <- validation_results$male_var changes$corrected_dad_sex <- corrected_dads if (verbose && length(corrected_dads) > 0) { cat("Corrected sex of dads for:", paste(corrected_dads, collapse = ", "), "\n") } + } else { + corrected_dads <- ped$ID[dad_indices[!is.na(dad_indices)]] + ped$sex[dad_indices[!is.na(dad_indices)]] <- 1 + changes$corrected_dad_sex <- corrected_dads + if (verbose && length(corrected_dads) > 0) { + cat("Corrected sex of dads for:", paste(corrected_dads, collapse = ", "), "\n") + } + } } } @@ -218,7 +235,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, new_entry$ID <- new_id new_entry$dadID <- NA new_entry$momID <- NA - new_entry$sex <- validation_results$male_var + new_entry$sex <- if(length(validation_results$male_var) > 0 && !is.na(validation_results$male_var)) validation_results$male_var else 1 new_entries <- rbind(new_entries, new_entry) } @@ -231,7 +248,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, new_entry$ID <- new_id new_entry$dadID <- NA new_entry$momID <- NA - new_entry$sex <- validation_results$female_var + new_entry$sex <- if(length(validation_results$female_var) > 0 && !is.na(validation_results$female_var)) validation_results$female_var else 0 new_entries <- rbind(new_entries, new_entry) } diff --git a/R/cleanPedigree.R b/R/cleanPedigree.R index b03ca270..737b558c 100644 --- a/R/cleanPedigree.R +++ b/R/cleanPedigree.R @@ -16,9 +16,9 @@ standardizeColnames <- function(df, verbose = FALSE) { "fam" = "^(?:fam(?:ily)?[\\.\\-_]?(?:id)?)", "ID" = "^(?:i(?:d$|ndiv(?:idual)?)|p(?:erson)?[\\.\\-_]?id)", "gen" = "^(?:gen(?:s|eration)?)", - "dadID" = "^(?:d(?:ad)?id|paid|fatherid|pid[\\.\\-_]?fath[er]*)", + "dadID" = "^(?:d(?:ad)?id|paid|fatherid|pid[\\.\\-_]?fath[er]*|sire)", "patID" = "^(?:dat[\\.\\-_]?id|pat[\\.\\-_]?id|paternal[\\.\\-_]?(?:id)?)", - "momID" = "^(?:m(?:om|a|other)?[\\.\\-_]?id|pid[\\.\\-_]?moth[er]*)", + "momID" = "^(?:m(?:om|a|other)?[\\.\\-_]?id|pid[\\.\\-_]?moth[er]*|dame)", "matID" = "^(?:mat[\\.\\-_]?id|maternal[\\.\\-_]?(?:id)?)", "spID" = "^(?:s(?:pt)?id|spouse[\\.\\-_]?(?:id)?|partner[\\.\\-_]?(?:id)?|husb(?:and)?[\\.\\-_]?id|wife[\\.\\-_]?(?:id)?|pid[\\.\\-_]?spouse1?)", "twinID" = "^(?:twin[\\.\\-_]?(?:id)?)", From 31f9a42777d5f2b72f4fd0b4a9422c9f92153c2f Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Sat, 12 Apr 2025 16:21:24 -0400 Subject: [PATCH 31/69] nicer plots --- man/assignCoupleIDs.Rd | 21 +++ vignettes/partial.Rmd | 143 +++++++++++------- vignettes/partial.html | 330 ++++++++++++++++++++++++++++------------- 3 files changed, 341 insertions(+), 153 deletions(-) create mode 100644 man/assignCoupleIDs.Rd diff --git a/man/assignCoupleIDs.Rd b/man/assignCoupleIDs.Rd new file mode 100644 index 00000000..95165581 --- /dev/null +++ b/man/assignCoupleIDs.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helpPedigree.R +\name{assignCoupleIDs} +\alias{assignCoupleIDs} +\alias{assignCoupleIds} +\title{Assign Couple IDs} +\usage{ +assignCoupleIDs(df_Ngen) + +assignCoupleIds(df_Ngen) +} +\arguments{ +\item{df_Ngen}{The dataframe for the current generation, including columns for individual IDs and spouse IDs.} +} +\value{ +The input dataframe augmented with a 'coupleId' column, where each mated pair has a unique identifier. +} +\description{ +This subfunction assigns a unique couple ID to each mated pair in the generation. +Unmated individuals are assigned NA for their couple ID. +} diff --git a/vignettes/partial.Rmd b/vignettes/partial.Rmd index 45fb7ce6..52a9e45e 100644 --- a/vignettes/partial.Rmd +++ b/vignettes/partial.Rmd @@ -49,11 +49,13 @@ We compute the additive genetic relationship matrix using both the classic and p ped_add_partial_complete <- ped2com(df, isChild_method = "partialparent", component = "additive", - adjacency_method = "direct" + adjacency_method = "direct", + sparse = FALSE ) ped_add_classic_complete <- ped2com(df, isChild_method = "classic", - component = "additive", adjacency_method = "direct" + component = "additive", adjacency_method = "direct", + sparse = FALSE ) ``` @@ -67,23 +69,29 @@ library(corrplot) corrplot(as.matrix(ped_add_classic_complete), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Additive component - Classic method" -) + is.corr = FALSE, title = "Additive component - Classic method", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) + corrplot(as.matrix(ped_add_partial_complete), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Additive component - Partial parent method" -) + is.corr = FALSE, title = "Additive component - Partial parent method", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) ``` To verify this, we subtract one matrix from the other and calculate RMSE. The difference should be numerically zero. Indeed, it is `r sqrt(mean((ped_add_classic_complete-ped_add_partial_complete)^2))`. -```{r} -corrplot(as.matrix(ped_add_classic_complete - ped_add_partial_complete), +```{r,warning=FALSE} +corrplot((as.matrix(ped_add_classic_complete) - as.matrix(ped_add_partial_complete)), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE -) + is.corr = FALSE, order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) ``` @@ -101,12 +109,14 @@ df$momID[df$ID == 4] <- NA ped_add_partial_mom <- ped_add_partial <- ped2com(df, isChild_method = "partialparent", component = "additive", - adjacency_method = "direct" + adjacency_method = "direct", + sparse = FALSE ) ped_add_classic_mom <- ped_add_classic <- ped2com(df, isChild_method = "classic", - component = "additive", adjacency_method = "direct" + component = "additive", adjacency_method = "direct", + sparse = FALSE ) ``` @@ -119,30 +129,35 @@ The resulting additive matrices reflect this difference. The RMSE between the tw ```{r} corrplot(as.matrix(ped_add_classic), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Classic (mother removed)" -) - + is.corr = FALSE, title = "Classic (mother removed)", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) corrplot(as.matrix(ped_add_partial), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Partial (mother removed)" -) + is.corr = FALSE, title = "Partial (mother removed)", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) ``` We quantify the overall matrix difference: ```{r} -sqrt(mean((ped_add_classic - ped_add_partial)^2)) +sqrt(mean((as.matrix(ped_add_classic) - as.matrix(ped_add_partial))^2)) ``` Next, we compare each method to the matrix from the complete pedigree. This evaluates how much each method deviates from the correct additive structure. ```{r} -corrplot(as.matrix(ped_add_classic_complete - ped_add_classic), +corrplot(as.matrix(ped_add_classic_complete) - as.matrix(ped_add_classic), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE -) + is.corr = FALSE, + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) sqrt(mean((ped_add_classic_complete - ped_add_classic)^2)) ``` @@ -152,8 +167,10 @@ The RMSE between the true additive component and the classic method is `r sqrt(m ```{r} corrplot(as.matrix(ped_add_classic_complete - ped_add_partial), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE -) + is.corr = FALSE, + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) sqrt(mean((ped_add_classic_complete - ped_add_partial)^2)) ``` @@ -190,18 +207,22 @@ ped_add_classic_dad <- ped_add_classic <- ped2com(df, ``` -As we can see, the two matrices are different. The RMSE between the two matrices is `r sqrt(mean((ped_add_classic-ped_add_partial)^2))`. +As we can see, the two matrices are different. The RMSE between the two matrices is `r sqrt(mean((as.matrix(ped_add_classic)-as.matrix(ped_add_partial))^2))`. ```{r} corrplot(as.matrix(ped_add_classic_dad), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Classic (father removed)" -) + is.corr = FALSE, title = "Classic (father removed)", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) corrplot(as.matrix(ped_add_partial_dad), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Partial (father removed)" -) + is.corr = FALSE, title = "Partial (father removed)", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) ``` Again, we compare to the true matrix from the complete pedigree: @@ -210,8 +231,10 @@ Again, we compare to the true matrix from the complete pedigree: ```{r} corrplot(as.matrix(ped_add_classic_complete - ped_add_classic), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE -) + is.corr = FALSE, + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) sqrt(mean((ped_add_classic_complete - ped_add_classic)^2)) ``` @@ -220,8 +243,10 @@ sqrt(mean((ped_add_classic_complete - ped_add_classic)^2)) ```{r} corrplot(as.matrix(ped_add_classic_complete - ped_add_partial), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE -) + is.corr = FALSE, + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) sqrt(mean((ped_add_classic_complete - ped_add_partial)^2)) ``` @@ -362,28 +387,38 @@ fam1 <- inbreeding_list[[1]] corrplot(as.matrix(fam1$ped_add_classic_complete), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Classic - Complete" -) + is.corr = FALSE, title = "Classic - Complete", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) corrplot(as.matrix(fam1$ped_add_classic_mom), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Classic - Mom Missing" -) + is.corr = FALSE, title = "Classic - Mom Missing", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) corrplot(as.matrix(fam1$ped_add_partial_mom), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Partial - Mom Missing" -) + is.corr = FALSE, title = "Partial - Mom Missing", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) corrplot(as.matrix(fam1$ped_add_classic_dad), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Classic - Dad Missing" -) + is.corr = FALSE, title = "Classic - Dad Missing", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) corrplot(as.matrix(fam1$ped_add_partial_dad), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Partial - Dad Missing" -) + is.corr = FALSE, title = "Partial - Dad Missing", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) ``` @@ -392,23 +427,31 @@ To visualize the differences from the true matrix: ```{r} corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_classic_mom), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Classic Mom Diff from Complete" -) + is.corr = FALSE, title = "Classic Mom Diff from Complete", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_partial_mom), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Partial Mom Diff from Complete" -) + is.corr = FALSE, title = "Partial Mom Diff from Complete", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_classic_dad), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Classic Dad Diff from Complete" -) + is.corr = FALSE, title = "Classic Dad Diff from Complete", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_partial_dad), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Partial Dad Diff from Complete" -) + is.corr = FALSE, title = "Partial Dad Diff from Complete", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) ``` These plots show how each method responds to missing data, and whether it maintains consistency with the complete pedigree. We observe that the partial parent method typically introduces smaller deviations. If desired, this same diagnostic can be repeated for additional families, such as inbreeding_list[[2]]. diff --git a/vignettes/partial.html b/vignettes/partial.html index aaa1fbec..9a2e5535 100644 --- a/vignettes/partial.html +++ b/vignettes/partial.html @@ -377,12 +377,14 @@

Hazard Data Example

ped_add_partial_complete <- ped2com(df,
   isChild_method = "partialparent",
   component = "additive",
-  adjacency_method = "direct"
-)
-ped_add_classic_complete <- ped2com(df,
-  isChild_method = "classic",
-  component = "additive", adjacency_method = "direct"
-)
+ adjacency_method = "direct", + sparse = FALSE +) +ped_add_classic_complete <- ped2com(df, + isChild_method = "classic", + component = "additive", adjacency_method = "direct", + sparse = FALSE +)

The following plots display the full additive matrices. These matrices should be identical.

This can be confirmed visually and numerically.

@@ -392,25 +394,28 @@

Hazard Data Example

corrplot(as.matrix(ped_add_classic_complete), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Additive component - Classic method" -) -

+ is.corr = FALSE, title = "Additive component - Classic method", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +


-corrplot(as.matrix(ped_add_partial_complete),
-  method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Additive component - Partial parent method"
-)
-

+ +corrplot(as.matrix(ped_add_partial_complete), + method = "color", type = "lower", col.lim = c(0, 1), + is.corr = FALSE, title = "Additive component - Partial parent method", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +

To verify this, we subtract one matrix from the other and calculate RMSE. The difference should be numerically zero. Indeed, it is 0.

-
corrplot(as.matrix(ped_add_classic_complete - ped_add_partial_complete),
+
corrplot((as.matrix(ped_add_classic_complete) - as.matrix(ped_add_partial_complete)),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE
-)
-#> Warning in corrplot(as.matrix(ped_add_classic_complete -
-#> ped_add_partial_complete), : col.lim interval too wide, please set a suitable
-#> value

-

+  is.corr = FALSE,  order = "hclust",
+  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
+  col = COL1('Reds', 100), mar=c(0,0,2,0))
+

Introducing Missingness: Remove a Parent

@@ -420,13 +425,15 @@

Introducing Missingness: Remove a Parent

ped_add_partial_mom <- ped_add_partial <- ped2com(df,
   isChild_method = "partialparent",
   component = "additive",
-  adjacency_method = "direct"
-)
-
-ped_add_classic_mom <- ped_add_classic <- ped2com(df,
-  isChild_method = "classic",
-  component = "additive", adjacency_method = "direct"
-)
+ adjacency_method = "direct", + sparse = FALSE +) + +ped_add_classic_mom <- ped_add_classic <- ped2com(df, + isChild_method = "classic", + component = "additive", adjacency_method = "direct", + sparse = FALSE +)

The two methods now treat individual 4 differently in the parent adjacency matrix. The classic method applies a fixed contribution because one parent remains. The partial parent method inflates the @@ -436,26 +443,31 @@

Introducing Missingness: Remove a Parent

between the two matrices is 0.009811.

corrplot(as.matrix(ped_add_classic),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Classic (mother removed)"
-)
-

-

-corrplot(as.matrix(ped_add_partial),
-  method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Partial (mother removed)"
-)
-

+ is.corr = FALSE, title = "Classic (mother removed)", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +

+
corrplot(as.matrix(ped_add_partial),
+  method = "color", type = "lower", col.lim = c(0, 1),
+  is.corr = FALSE, title = "Partial (mother removed)",
+  order = "hclust",
+  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
+  col = COL1('Reds', 100), mar=c(0,0,2,0))
+

We quantify the overall matrix difference:

-
sqrt(mean((ped_add_classic - ped_add_partial)^2))
+
sqrt(mean((as.matrix(ped_add_classic) - as.matrix(ped_add_partial))^2))
 #> [1] 0.009811047

 
Next, we compare each method to the matrix from the complete
 pedigree. This evaluates how much each method deviates from the correct
 additive structure.

-
corrplot(as.matrix(ped_add_classic_complete - ped_add_classic),
+
corrplot(as.matrix(ped_add_classic_complete) - as.matrix(ped_add_classic),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE
-)

-

+  is.corr = FALSE,
+  order = "hclust",
+  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
+  col = COL1('Reds', 100), mar=c(0,0,2,0))

+

 

 sqrt(mean((ped_add_classic_complete - ped_add_classic)^2))
 #> [1] 0.02991371

@@ -463,9 +475,11 @@ 
Introducing Missingness: Remove a Parent

 is 0.0299137.

 
corrplot(as.matrix(ped_add_classic_complete - ped_add_partial),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE
-)

-

+  is.corr = FALSE,
+  order = "hclust",
+  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
+  col = COL1('Reds', 100), mar=c(0,0,2,0))
+


 sqrt(mean((ped_add_classic_complete - ped_add_partial)^2))
 #> [1] 0.02825904
@@ -499,32 +513,44 @@

Removing the Father Instead

two matrices is 0.009811.

corrplot(as.matrix(ped_add_classic_dad),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Classic (father removed)"
-)
-

+ is.corr = FALSE, title = "Classic (father removed)", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +


 corrplot(as.matrix(ped_add_partial_dad),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Partial (father removed)"
-)
-

+ is.corr = FALSE, title = "Partial (father removed)", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +

Again, we compare to the true matrix from the complete pedigree:

corrplot(as.matrix(ped_add_classic_complete - ped_add_classic),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE
-)
-

+ is.corr = FALSE, + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +


 sqrt(mean((ped_add_classic_complete - ped_add_classic)^2))
-#> [1] 0.02991371
+#> Warning in mean.default((ped_add_classic_complete - ped_add_classic)^2): +#> argument is not numeric or logical: returning NA +#> [1] NA 
corrplot(as.matrix(ped_add_classic_complete - ped_add_partial),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE
-)
-

+ is.corr = FALSE, + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +


 sqrt(mean((ped_add_classic_complete - ped_add_partial)^2))
-#> [1] 0.02825904
+#> Warning in mean.default((ped_add_classic_complete - ped_add_partial)^2): +#> argument is not numeric or logical: returning NA +#> [1] NA

The partial parent method again yields a matrix closer to the full-data version.

@@ -638,7 +664,85 @@

Inbreeding Dataset: Family-Level Evaluation

ped_add_partial_mom = ped_add_partial_mom, ped_add_classic_mom = ped_add_classic_mom ) -} +} +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_dad)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_partial_mom)^2): +#> argument is not numeric or logical: returning NA +#> Warning in mean.default((ped_add_classic_complete - ped_add_classic_mom)^2): +#> argument is not numeric or logical: returning NA

Example: Family 1

To understand what these matrices look like, we visualize them for @@ -651,57 +755,75 @@

Example: Family 1

corrplot(as.matrix(fam1$ped_add_classic_complete), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Classic - Complete" -)
-

+ is.corr = FALSE, title = "Classic - Complete", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +


 corrplot(as.matrix(fam1$ped_add_classic_mom),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Classic - Mom Missing"
-)
-

+ is.corr = FALSE, title = "Classic - Mom Missing", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +


 corrplot(as.matrix(fam1$ped_add_partial_mom),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Partial - Mom Missing"
-)
-

+ is.corr = FALSE, title = "Partial - Mom Missing", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +


 corrplot(as.matrix(fam1$ped_add_classic_dad),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Classic - Dad Missing"
-)
-

+ is.corr = FALSE, title = "Classic - Dad Missing", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +


 corrplot(as.matrix(fam1$ped_add_partial_dad),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Partial - Dad Missing"
-)
-

+ is.corr = FALSE, title = "Partial - Dad Missing", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +

To visualize the differences from the true matrix:

corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_classic_mom),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Classic Mom Diff from Complete"
-)
-

+ is.corr = FALSE, title = "Classic Mom Diff from Complete", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +


 corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_partial_mom),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Partial Mom Diff from Complete"
-)
-

+ is.corr = FALSE, title = "Partial Mom Diff from Complete", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +


 corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_classic_dad),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Classic Dad Diff from Complete"
-)
-

+ is.corr = FALSE, title = "Classic Dad Diff from Complete", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +


 corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_partial_dad),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Partial Dad Diff from Complete"
-)
-

+ is.corr = FALSE, title = "Partial Dad Diff from Complete", + order = "hclust", + tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1('Reds', 100), mar=c(0,0,2,0)) +

These plots show how each method responds to missing data, and whether it maintains consistency with the complete pedigree. We observe that the partial parent method typically introduces smaller deviations. @@ -728,13 +850,14 @@

Summary

results %>%
   select(RMSE_diff_mom, RMSE_diff_dad) %>%
   summary()
-#>  RMSE_diff_mom      RMSE_diff_dad     
-#>  Min.   :0.001222   Min.   :0.001222  
-#>  1st Qu.:0.001869   1st Qu.:0.002036  
-#>  Median :0.002538   Median :0.002520  
-#>  Mean   :0.005763   Mean   :0.005786  
-#>  3rd Qu.:0.005625   3rd Qu.:0.005625  
-#>  Max.   :0.024221   Max.   :0.024221
+#> RMSE_diff_mom RMSE_diff_dad +#> Min. : NA Min. : NA +#> 1st Qu.: NA 1st Qu.: NA +#> Median : NA Median : NA +#> Mean :NaN Mean :NaN +#> 3rd Qu.: NA 3rd Qu.: NA +#> Max. : NA Max. : NA +#> NA's :8 NA's :8

In all families, both RMSE_diff_mom and RMSE_diff_dad are positive—indicating that the classic method produces larger the errors relative to the partial method. This @@ -742,9 +865,9 @@

Summary

father.

To verify this directly:

mean(results$RMSE_diff_mom > 0, na.rm = TRUE)
-#> [1] 1
+#> [1] NaN
 mean(results$RMSE_diff_dad > 0, na.rm = TRUE)
-#> [1] 1
+#> [1] NaN

These proportions show how often the partial method produces a lower RMSE across the dataset. This confirms the earlier findings: when pedigree data are incomplete, the partial parent method more faithfully @@ -756,13 +879,14 @@

Summary

-max_R_partial_dad, -max_R_classic_mom, -max_R_partial_mom, -max_R_classic ) %>% summary() -#> RMSE_partial_dad RMSE_partial_mom RMSE_classic_dad RMSE_classic_mom -#> Min. :0.04773 Min. :0.04773 Min. :0.04895 Min. :0.04895 -#> 1st Qu.:0.05570 1st Qu.:0.05349 1st Qu.:0.05774 1st Qu.:0.05555 -#> Median :0.06206 Median :0.06899 Median :0.06457 Median :0.07158 -#> Mean :0.07545 Mean :0.07686 Mean :0.08124 Mean :0.08262 -#> 3rd Qu.:0.08237 3rd Qu.:0.08323 3rd Qu.:0.08866 3rd Qu.:0.08866 -#> Max. :0.15547 Max. :0.15547 Max. :0.17969 Max. :0.17969 +#> RMSE_partial_dad RMSE_partial_mom RMSE_classic_dad RMSE_classic_mom +#> Min. : NA Min. : NA Min. : NA Min. : NA +#> 1st Qu.: NA 1st Qu.: NA 1st Qu.: NA 1st Qu.: NA +#> Median : NA Median : NA Median : NA Median : NA +#> Mean :NaN Mean :NaN Mean :NaN Mean :NaN +#> 3rd Qu.: NA 3rd Qu.: NA 3rd Qu.: NA 3rd Qu.: NA +#> Max. : NA Max. : NA Max. : NA Max. : NA +#> NA's :8 NA's :8 NA's :8 NA's :8 From c7320ebcf519d0b870d3a3fbbee3013f6bb07956 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Sun, 13 Apr 2025 15:05:39 -0400 Subject: [PATCH 32/69] more tests --- R/readGedcom.R | 7 +++++ R/summarizePedigree.R | 22 +++++++++++++-- tests/testthat/test-summarizePedigrees.R | 34 ++++++++++++++++++++++-- 3 files changed, 59 insertions(+), 4 deletions(-) diff --git a/R/readGedcom.R b/R/readGedcom.R index f9066c91..c0eea803 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -587,3 +587,10 @@ collapseNames <- function(verbose, df_temp) { } return(df_temp) } +#' @rdname readGedcom +#' @export +readGed <- readGedcom + +#' @rdname readGedcom +#' @export +readgedcom <- readGedcom diff --git a/R/summarizePedigree.R b/R/summarizePedigree.R index ea8f81e8..6cee4e5e 100644 --- a/R/summarizePedigree.R +++ b/R/summarizePedigree.R @@ -235,12 +235,11 @@ summarizePedigrees <- function(ped, famID = "famID", personID = "ID", ) } } - return(output) } -# Function to calculate summary statistics for all numeric variables +#' Function to calculate summary statistics for all numeric variables #' This function calculates summary statistics for all numeric variables in a data.table. It is supposed to be used internally by the \code{summarize_pedigree} function. #' @inheritParams summarizePedigrees #' @param data A data.table containing the pedigree data. @@ -352,6 +351,9 @@ summarizeMatrilines <- function(ped, famID = "famID", personID = "ID", ) } + + + #' Summarize the paternal lines in a pedigree #' @inheritParams summarizePedigrees #' @seealso [summarizePedigrees ()] @@ -432,3 +434,19 @@ findBiggest <- function(foo_summary_dt, nbiggest, n_foo) { )]) return(biggest_foo) } + +#' @rdname summarizePedigrees +#' @export +summarisePedigrees <- summarizePedigrees + +#' @rdname summarizeFamilies +#' @export +summariseFamilies <- summarizeFamilies + +#' @rdname summarizeMatrilines +#' @export +summariseMatrilines <- summarizeMatrilines + +#' @rdname summarizePatrilines +#' @export +summarisePatrilines <- summarizePatrilines diff --git a/tests/testthat/test-summarizePedigrees.R b/tests/testthat/test-summarizePedigrees.R index 5bc1d6ea..3fd62464 100644 --- a/tests/testthat/test-summarizePedigrees.R +++ b/tests/testthat/test-summarizePedigrees.R @@ -7,7 +7,13 @@ test_that("Counts the correct number people", { expect_equal(result_observed, result_expected) }) - +# Test: SummarizeFamilies is used when SummariseFamilies +test_that("SummarizeFamilies works like SummariseFamilies", { + df <- ped2fam(potter, famID = "newFamID", personID = "personID") + df_summarized <- summarizeFamilies(df, famID = "newFamID", personID = "personID") + df_summarised <- summariseFamilies(df, famID = "newFamID", personID = "personID") + expect_equal(df_summarised, df_summarized) +}) # Test Case 2: Multiple families test_that("summarizeFamilies() works with multiple families", { df <- ped2fam(inbreeding, famID = "newFamID", personID = "ID") @@ -72,7 +78,13 @@ test_that("summarizeMatrilines() works", { result_observed <- nrow(df_summarized$biggest_maternal) expect_equal(result_observed, nbiggest) }) - +# Test: SummarizeMatrilines is used when SummariseMatrilines +test_that("SummarizeMatrilines works like SummariseMatrilines", { + df <- ped2fam(potter, famID = "newFamID", personID = "personID") + df_summarized <- summarizeMatrilines(df, famID = "newFamID", personID = "personID") + df_summarised <- summariseMatrilines(df, famID = "newFamID", personID = "personID") + expect_equal(df_summarised, df_summarized) +}) # Test Case 5: Does this function work for summarizePatrilines test_that("summarizePatrilines() works", { nbiggest <- 4 @@ -98,6 +110,13 @@ test_that("summarizePatrilines() works", { expect_equal(result_observed, nbiggest) }) +# Test: summarizePatrilines is used when SummarisePatrilines +test_that("summarizePatrilines works like SummarisePatrilines", { + df <- ped2fam(potter, famID = "newFamID", personID = "personID") + df_summarized <- summarizePatrilines(df, famID = "newFamID", personID = "personID") + df_summarised <- summarisePatrilines(df, famID = "newFamID", personID = "personID") + expect_equal(df_summarised, df_summarized) +}) # Test Case 6: Handling of missing values in critical columns test_that("summarizePedigrees() handles missing values correctly", { df <- data.frame( @@ -137,6 +156,9 @@ test_that("summarizePedigrees() throws error on invalid column names", { expect_error(summarizePedigrees(df, byr = "unknown_column")) }) + + + # Test Case 9: Handling empty dataset # test_that("summarizePedigrees() handles empty dataset gracefully", { # df <- data.frame(ID = integer(), momID = integer(), dadID = integer(), famID = integer()) @@ -155,3 +177,11 @@ test_that("summarizePedigrees() works for single-entry pedigree", { expect_equal(nrow(df_summarized$family_summary), 1) expect_equal(df_summarized$oldest_families$byr_mean, 1920) }) + +# Test: summarizePedigrees is used when SummarisePedigrees +test_that("SummarizePedigrees works like SummarisePedigrees", { + df <- ped2fam(potter, famID = "newFamID", personID = "personID") + df_summarized <- summarizePedigrees(df, famID = "newFamID", personID = "personID") + df_summarised <- summarisePedigrees(df, famID = "newFamID", personID = "personID") + expect_equal(df_summarised, df_summarized) +}) From f45712fa7d116e6e37e60290d46a375d09ba9b7f Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Sun, 13 Apr 2025 15:07:10 -0400 Subject: [PATCH 33/69] aliases --- NAMESPACE | 6 ++++++ man/calculateSummaryDT.Rd | 4 +++- man/readGedcom.Rd | 24 ++++++++++++++++++++++++ man/summarizeFamilies.Rd | 19 +++++++++++++++++++ man/summarizeMatrilines.Rd | 19 +++++++++++++++++++ man/summarizePatrilines.Rd | 19 +++++++++++++++++++ man/summarizePedigrees.Rd | 21 +++++++++++++++++++++ 7 files changed, 111 insertions(+), 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index 972282d4..1f9bacee 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -33,8 +33,10 @@ export(ped2maternal) export(ped2mit) export(ped2paternal) export(plotPedigree) +export(readGed) export(readGedcom) export(readWikifamilytree) +export(readgedcom) export(recodeSex) export(related_coef) export(relatedness) @@ -42,6 +44,10 @@ export(repairSex) export(resample) export(simulatePedigree) export(sizeAllGens) +export(summariseFamilies) +export(summariseMatrilines) +export(summarisePatrilines) +export(summarisePedigrees) export(summarizeFamilies) export(summarizeMatrilines) export(summarizePatrilines) diff --git a/man/calculateSummaryDT.Rd b/man/calculateSummaryDT.Rd index 45e67d3f..cb403b04 100644 --- a/man/calculateSummaryDT.Rd +++ b/man/calculateSummaryDT.Rd @@ -2,7 +2,8 @@ % Please edit documentation in R/summarizePedigree.R \name{calculateSummaryDT} \alias{calculateSummaryDT} -\title{This function calculates summary statistics for all numeric variables in a data.table. It is supposed to be used internally by the \code{summarize_pedigree} function.} +\title{Function to calculate summary statistics for all numeric variables +This function calculates summary statistics for all numeric variables in a data.table. It is supposed to be used internally by the \code{summarize_pedigree} function.} \usage{ calculateSummaryDT(data, group_var, skip_var, five_num_summary = FALSE) } @@ -20,6 +21,7 @@ the minimum, median, and maximum values.} A data.table containing the summary statistics for all numeric variables. } \description{ +Function to calculate summary statistics for all numeric variables This function calculates summary statistics for all numeric variables in a data.table. It is supposed to be used internally by the \code{summarize_pedigree} function. } \keyword{internal} diff --git a/man/readGedcom.Rd b/man/readGedcom.Rd index fdb158e1..7bab49b1 100644 --- a/man/readGedcom.Rd +++ b/man/readGedcom.Rd @@ -2,6 +2,8 @@ % Please edit documentation in R/readGedcom.R \name{readGedcom} \alias{readGedcom} +\alias{readGed} +\alias{readgedcom} \title{Read a GEDCOM File} \usage{ readGedcom( @@ -14,6 +16,28 @@ readGedcom( update_rate = 1000, ... ) + +readGed( + file_path, + verbose = FALSE, + add_parents = TRUE, + remove_empty_cols = TRUE, + combine_cols = TRUE, + skinny = FALSE, + update_rate = 1000, + ... +) + +readgedcom( + file_path, + verbose = FALSE, + add_parents = TRUE, + remove_empty_cols = TRUE, + combine_cols = TRUE, + skinny = FALSE, + update_rate = 1000, + ... +) } \arguments{ \item{file_path}{The path to the GEDCOM file.} diff --git a/man/summarizeFamilies.Rd b/man/summarizeFamilies.Rd index 8903eb93..2cb50761 100644 --- a/man/summarizeFamilies.Rd +++ b/man/summarizeFamilies.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/summarizePedigree.R \name{summarizeFamilies} \alias{summarizeFamilies} +\alias{summariseFamilies} \title{Summarize the families in a pedigree} \usage{ summarizeFamilies( @@ -21,6 +22,24 @@ summarizeFamilies( five_num_summary = FALSE, verbose = FALSE ) + +summariseFamilies( + ped, + famID = "famID", + personID = "ID", + momID = "momID", + dadID = "dadID", + matID = "matID", + patID = "patID", + byr = NULL, + founder_sort_var = NULL, + include_founder = FALSE, + nbiggest = 5, + noldest = 5, + skip_var = NULL, + five_num_summary = FALSE, + verbose = FALSE +) } \arguments{ \item{ped}{a pedigree dataset. Needs ID, momID, and dadID columns} diff --git a/man/summarizeMatrilines.Rd b/man/summarizeMatrilines.Rd index 2890b622..577204f6 100644 --- a/man/summarizeMatrilines.Rd +++ b/man/summarizeMatrilines.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/summarizePedigree.R \name{summarizeMatrilines} \alias{summarizeMatrilines} +\alias{summariseMatrilines} \title{Summarize the maternal lines in a pedigree} \usage{ summarizeMatrilines( @@ -21,6 +22,24 @@ summarizeMatrilines( five_num_summary = FALSE, verbose = FALSE ) + +summariseMatrilines( + ped, + famID = "famID", + personID = "ID", + momID = "momID", + dadID = "dadID", + matID = "matID", + patID = "patID", + byr = NULL, + include_founder = FALSE, + founder_sort_var = NULL, + nbiggest = 5, + noldest = 5, + skip_var = NULL, + five_num_summary = FALSE, + verbose = FALSE +) } \arguments{ \item{ped}{a pedigree dataset. Needs ID, momID, and dadID columns} diff --git a/man/summarizePatrilines.Rd b/man/summarizePatrilines.Rd index aed89bcd..27fd9494 100644 --- a/man/summarizePatrilines.Rd +++ b/man/summarizePatrilines.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/summarizePedigree.R \name{summarizePatrilines} \alias{summarizePatrilines} +\alias{summarisePatrilines} \title{Summarize the paternal lines in a pedigree} \usage{ summarizePatrilines( @@ -21,6 +22,24 @@ summarizePatrilines( five_num_summary = FALSE, verbose = FALSE ) + +summarisePatrilines( + ped, + famID = "famID", + personID = "ID", + momID = "momID", + dadID = "dadID", + matID = "matID", + patID = "patID", + byr = NULL, + founder_sort_var = NULL, + include_founder = FALSE, + nbiggest = 5, + noldest = 5, + skip_var = NULL, + five_num_summary = FALSE, + verbose = FALSE +) } \arguments{ \item{ped}{a pedigree dataset. Needs ID, momID, and dadID columns} diff --git a/man/summarizePedigrees.Rd b/man/summarizePedigrees.Rd index 3ed2f0a5..a4f6a6e9 100644 --- a/man/summarizePedigrees.Rd +++ b/man/summarizePedigrees.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/summarizePedigree.R \name{summarizePedigrees} \alias{summarizePedigrees} +\alias{summarisePedigrees} \title{Summarize Pedigree Data} \usage{ summarizePedigrees( @@ -23,6 +24,26 @@ summarizePedigrees( network_checks = FALSE, verbose = FALSE ) + +summarisePedigrees( + ped, + famID = "famID", + personID = "ID", + momID = "momID", + dadID = "dadID", + matID = "matID", + patID = "patID", + type = c("fathers", "mothers", "families"), + byr = NULL, + include_founder = FALSE, + founder_sort_var = NULL, + nbiggest = 5, + noldest = nbiggest, + skip_var = NULL, + five_num_summary = FALSE, + network_checks = FALSE, + verbose = FALSE +) } \arguments{ \item{ped}{a pedigree dataset. Needs ID, momID, and dadID columns} From d023b785d81f99e969e5e94176c6cf2403605a94 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 14 Apr 2025 14:07:33 -0400 Subject: [PATCH 34/69] default now is direct method --- R/convertPedigree.R | 16 +++++++++++++--- tests/testthat/test-convertPedigree.R | 6 +++--- 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/R/convertPedigree.R b/R/convertPedigree.R index 9cab93f0..3d5ac7ca 100644 --- a/R/convertPedigree.R +++ b/R/convertPedigree.R @@ -31,7 +31,7 @@ ped2com <- function(ped, component, flatten.diag = FALSE, standardize.colnames = TRUE, transpose_method = "tcrossprod", - adjacency_method = "indexed", + adjacency_method = "direct", isChild_method = "classic", saveable = FALSE, resume = FALSE, @@ -615,8 +615,18 @@ ped2ce <- function(ped, iss <- c(mIDs$rID, dIDs$rID) jss <- c(mIDs$cID, dIDs$cID) } else if (component %in% c("common nuclear")) { - stop("Common Nuclear component is not yet implemented for direct method. Use index method.\n") + message("Common Nuclear component is not yet implemented for direct method. Using index method.\n") # change to warning and call indexed version + list_of_adjacency <- .adjIndexed(ped = ped, component = component, + saveable = saveable, resume = resume, + save_path = save_path, verbose = verbose, + lastComputed = lastComputed, nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, parList = parList, + lens = lens, save_rate_parlist = save_rate_parlist, + ... + ) + return(list_of_adjacency) } else if (component %in% c("mitochondrial")) { mIDs <- stats::na.omit(data.frame(rID = ped$ID, cID = ped$momID)) iss <- c(mIDs$rID) @@ -641,7 +651,7 @@ ped2ce <- function(ped, #' @param checkpoint_files a list of checkpoint files compute_parent_adjacency <- function(ped, component, - adjacency_method = "indexed", + adjacency_method = "direct", saveable, resume, save_path, verbose, lastComputed, nr, checkpoint_files, update_rate, diff --git a/tests/testthat/test-convertPedigree.R b/tests/testthat/test-convertPedigree.R index 11dfbeca..ec5af8b1 100644 --- a/tests/testthat/test-convertPedigree.R +++ b/tests/testthat/test-convertPedigree.R @@ -301,10 +301,10 @@ test_that("adjacency_method 'indexed', 'loop', and direct produce the same resu # common nuclear ped_common_indexed <- ped2com(hazard, component = "common nuclear", adjacency_method = "indexed") ped_common_loop <- ped2com(hazard, component = "common nuclear", adjacency_method = "loop") - # ped_common_direct <- ped2com(hazard, component = "common nuclear", adjacency_method = "direct") + ped_common_direct <- ped2com(hazard, component = "common nuclear", adjacency_method = "direct") expect_equal(ped_common_indexed, ped_common_loop, tolerance = tolerance) - # expect_equal(ped_common_loop, ped_common_direct, tolerance = tolerance) - # expect_equal(ped_common_indexed, ped_common_direct, tolerance = tolerance) + expect_equal(ped_common_loop, ped_common_direct, tolerance = tolerance) + expect_equal(ped_common_indexed, ped_common_direct, tolerance = tolerance) }) From b55ae50c22a2272ee71b2cfaaa8d80e0b5c6c579 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 14 Apr 2025 17:13:48 -0400 Subject: [PATCH 35/69] Update readGedcom.R subfactor --- NAMESPACE | 1 + R/helpPedigree.R | 11 +- R/readGedcom.R | 69 ++- R/readGedcom_alpha.R | 616 ++++++++++++++++++++++ man/compute_parent_adjacency.Rd | 2 +- man/determineSex.Rd | 2 +- man/ped2com.Rd | 2 +- man/postProcessGedcom.Rd | 34 ++ man/readGedcom.Rd | 3 + tests/testthat/test-readPedigrees_alpha.R | 231 ++++++++ 10 files changed, 946 insertions(+), 25 deletions(-) create mode 100644 R/readGedcom_alpha.R create mode 100644 man/postProcessGedcom.Rd create mode 100644 tests/testthat/test-readPedigrees_alpha.R diff --git a/NAMESPACE b/NAMESPACE index 1f9bacee..69e23307 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,7 @@ export(SimPed) export(allGens) +export(assignCoupleIDs) export(calcAllGens) export(calcFamilySize) export(calculateRelatedness) diff --git a/R/helpPedigree.R b/R/helpPedigree.R index 3d054d4b..f9e7c855 100644 --- a/R/helpPedigree.R +++ b/R/helpPedigree.R @@ -41,13 +41,13 @@ createGenDataFrame <- function(sizeGens, genIndex, idGen) { #' @param sexR Numeric value indicating the sex ratio (proportion of males). #' @return Vector of sexes ("M" for male, "F" for female) for the offspring. #' @importFrom stats runif -determineSex <- function(idGen, sexR) { +determineSex <- function(idGen, sexR, code_male = "M", code_female = "F") { if (runif(1) > .5) { - sexVec1 <- rep("M", floor(length(idGen) * sexR)) - sexVec2 <- rep("F", length(idGen) - length(sexVec1)) + sexVec1 <- rep(code_male, floor(length(idGen) * sexR)) + sexVec2 <- rep(code_female, length(idGen) - length(sexVec1)) } else { - sexVec1 <- rep("F", floor(length(idGen) * (1 - sexR))) - sexVec2 <- rep("M", length(idGen) - length(sexVec1)) + sexVec1 <- rep(code_female, floor(length(idGen) * (1 - sexR))) + sexVec2 <- rep(code_male, length(idGen) - length(sexVec1)) } sexVec <- sample(c(sexVec1, sexVec2)) return(sexVec) @@ -60,6 +60,7 @@ determineSex <- function(idGen, sexR) { #' #' @param df_Ngen The dataframe for the current generation, including columns for individual IDs and spouse IDs. #' @return The input dataframe augmented with a 'coupleId' column, where each mated pair has a unique identifier. +#' @export assignCoupleIDs <- function(df_Ngen) { df_Ngen$coupleId <- NA_character_ # Initialize the coupleId column with NAs usedCoupleIds <- character() # Initialize an empty character vector to track used IDs diff --git a/R/readGedcom.R b/R/readGedcom.R index c0eea803..f271632c 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -55,6 +55,7 @@ readGedcom <- function(file_path, combine_cols = TRUE, skinny = FALSE, update_rate = 1000, + post_process = TRUE, ...) { # Checks if (!file.exists(file_path)) stop("File does not exist: ", file_path) @@ -300,6 +301,39 @@ readGedcom <- function(file_path, if (nrow(df_temp) != num_rows$num_indi_rows) { warning("The number of people found in the processed file does not match the number of individuals raw data") } + + if(post_process){ + if (verbose) { + print("Post-processing data frame") + } + # Remove the first row (empty) +df_temp <- postProcessGedcom( + df_temp = df_temp, + remove_empty_cols = remove_empty_cols, + combine_cols = combine_cols, + add_parents = add_parents, + skinny = skinny, + verbose = verbose + ) + + } + + return(df_temp) +} + +#' Post-process GEDCOM Data Frame +#' +#' @inheritParams readGedcom +#' @inheritParams mapFAMS2parents +#' @return A data frame with processed information. + +postProcessGedcom <- function(df_temp, + remove_empty_cols = TRUE, + combine_cols = TRUE, + add_parents = TRUE, + skinny = TRUE, + verbose = FALSE +){ # Add mom and dad ids if (add_parents) { if (verbose) { @@ -308,28 +342,29 @@ readGedcom <- function(file_path, df_temp <- processParents(df_temp, datasource = "gedcom") } - if (combine_cols) { - df_temp <- collapseNames(verbose = verbose, df_temp = df_temp) - } +if (combine_cols) { + df_temp <- collapseNames(verbose = verbose, df_temp = df_temp) +} - if (remove_empty_cols) { - # Remove empty columns - if (verbose) { - print("Removing empty columns") - } - df_temp <- df_temp[, colSums(is.na(df_temp)) < nrow(df_temp)] +if (remove_empty_cols) { + # Remove empty columns + if (verbose) { + print("Removing empty columns") } - if (skinny) { - if (verbose) { - print("Slimming down the data frame") - } - df_temp <- df_temp[, colSums(is.na(df_temp)) < nrow(df_temp)] - df_temp$FAMC <- NULL - df_temp$FAMS <- NULL + df_temp <- df_temp[, colSums(is.na(df_temp)) < nrow(df_temp)] +} +if (skinny) { + if (verbose) { + print("Slimming down the data frame") } - return(df_temp) + df_temp <- df_temp[, colSums(is.na(df_temp)) < nrow(df_temp)] + df_temp$FAMC <- NULL + df_temp$FAMS <- NULL } +return(df_temp) + +} #' Create a mapping of family IDs to parent IDs #' diff --git a/R/readGedcom_alpha.R b/R/readGedcom_alpha.R new file mode 100644 index 00000000..3cde78dc --- /dev/null +++ b/R/readGedcom_alpha.R @@ -0,0 +1,616 @@ +#' Read a GEDCOM File +#' +#' This function reads a GEDCOM file and parses it into a structured data frame of individuals. +#' +#' @param file_path The path to the GEDCOM file. +#' @param add_parents A logical value indicating whether to add parents to the data frame. +#' @param remove_empty_cols A logical value indicating whether to remove columns with all missing values. +#' @param combine_cols A logical value indicating whether to combine columns with duplicate values. +#' @param verbose A logical value indicating whether to print messages. +#' @param skinny A logical value indicating whether to return a skinny data frame. +#' @param update_rate numeric. The rate at which to print progress +#' @param ... Additional arguments to be passed to the function. +#' @return A data frame containing information about individuals, with the following potential columns: +#' - `id`: ID of the individual +#' - `momID`: ID of the individual's mother +#' - `dadID`: ID of the individual's father +#' - `sex`: Sex of the individual +#' - `name`: Full name of the individual +#' - `name_given`: First name of the individual +#' - `name_surn`: Last name of the individual +#' - `name_marriedsurn`: Married name of the individual +#' - `name_nick`: Nickname of the individual +#' - `name_npfx`: Name prefix +#' - `name_nsfx`: Name suffix +#' - `birth_date`: Birth date of the individual +#' - `birth_lat`: Latitude of the birthplace +#' - `birth_long`: Longitude of the birthplace +#' - `birth_place`: Birthplace of the individual +#' - `death_caus`: Cause of death +#' - `death_date`: Death date of the individual +#' - `death_lat`: Latitude of the place of death +#' - `death_long`: Longitude of the place of death +#' - `death_place`: Place of death of the individual +#' - `attribute_caste`: Caste of the individual +#' - `attribute_children`: Number of children of the individual +#' - `attribute_description`: Description of the individual +#' - `attribute_education`: Education of the individual +#' - `attribute_idnumber`: Identification number of the individual +#' - `attribute_marriages`: Number of marriages of the individual +#' - `attribute_nationality`: Nationality of the individual +#' - `attribute_occupation`: Occupation of the individual +#' - `attribute_property`: Property owned by the individual +#' - `attribute_religion`: Religion of the individual +#' - `attribute_residence`: Residence of the individual +#' - `attribute_ssn`: Social security number of the individual +#' - `attribute_title`: Title of the individual +#' - `FAMC`: ID(s) of the family where the individual is a child +#' - `FAMS`: ID(s) of the family where the individual is a spouse +#' @export +readGedcom.alpha <- function(file_path, + verbose = FALSE, + add_parents = TRUE, + remove_empty_cols = TRUE, + combine_cols = TRUE, + skinny = FALSE, + update_rate = 1000, + post_process = TRUE, + ...) { + + # Ensure the file exists and read all lines. + if (!file.exists(file_path)) { + stop("File does not exist: ", file_path) + } + if (verbose) message("Reading file: ", file_path) + lines <- readLines(file_path) + total_lines <- length(lines) + if (verbose) message("File is ", total_lines, " lines long") + + # Count pattern occurrences (pattern_rows remains used in subfunctions) + pattern_rows <- countPatternRows.alpha(data.frame(X1 = lines)) + + # List of variables to initialize + all_var_names <- unlist(list( + identifiers = c("id", "momID", "dadID"), + names = c("name", "name_given", "name_given_pieces", "name_surn", "name_surn_pieces", "name_marriedsurn", + "name_nick", "name_npfx", "name_nsfx"), + sex = c("sex"), + birth = c("birth_date", "birth_lat", "birth_long", "birth_place"), + death = c("death_caus", "death_date", "death_lat", "death_long", "death_place"), + attributes = c("attribute_caste", "attribute_children", "attribute_description", "attribute_education", + "attribute_idnumber", "attribute_marriages", "attribute_nationality", "attribute_occupation", + "attribute_property", "attribute_religion", "attribute_residence", "attribute_ssn", + "attribute_title"), + relationships = c("FAMC", "FAMS") + ), use.names = FALSE) + + # Split the file into blocks; each block corresponds to one individual. + blocks <- splitIndividuals.alpha(lines, verbose) + + # Parse each individual block into a record (a named list) + records <- lapply(blocks, parseIndividualBlock.alpha, + pattern_rows = pattern_rows, + all_var_names = all_var_names, verbose = verbose) + + # Remove any NULLs (if a block did not contain an individual id) + records <- Filter(Negate(is.null), records) + + if (length(records) == 0) { + warning("No people found in file") + return(NULL) + } + + # Convert the list of records to a data frame. + df_temp <- do.call(rbind, lapply(records, function(rec) { + as.data.frame(rec, stringsAsFactors = FALSE) + })) + + if (verbose) message("File has ", nrow(df_temp), " people") + + # Run post-processing if requested. + if (post_process) { + if (verbose) message("Post-processing data frame") + df_temp <- postProcessGedcom.alpha( + df_temp = df_temp, + remove_empty_cols = remove_empty_cols, + combine_cols = combine_cols, + add_parents = add_parents, + skinny = skinny, + verbose = verbose + ) + } + + return(df_temp) +} + +# --- SUBFUNCTIONS --- +#' Split GEDCOM Lines into Individual Blocks +#' +#' This function partitions the GEDCOM file (as a vector of lines) into a list of blocks, +#' where each block corresponds to a single individual starting with an "@ INDI" line. +#' +#' @param lines A character vector of lines from the GEDCOM file. +#' @param verbose Logical indicating whether to output progress messages. +#' @return A list of character vectors, each representing one individual. +splitIndividuals.alpha <- function(lines, verbose = FALSE) { + indi_idx <- grep("@ INDI", lines) + if (length(indi_idx) == 0) return(list()) + + blocks <- list() + for (i in seq_along(indi_idx)) { + start <- indi_idx[i] + end <- if (i < length(indi_idx)) indi_idx[i + 1] - 1 else length(lines) + block <- lines[start:end] + blocks[[length(blocks) + 1]] <- block + } + if (verbose) message("Found ", length(blocks), " individual blocks") + return(blocks) +} + +#' Initialize an Empty Individual Record +#' +#' Creates a named list with all GEDCOM fields set to NA. +#' +#' @param all_var_names A character vector of variable names. +#' @return A named list representing an empty individual record. +initializeRecord.alpha <- function(all_var_names) { + setNames(as.list(rep(NA_character_, length(all_var_names))), all_var_names) +} + +#' Parse a GEDCOM Individual Block +#' +#' Processes a block of GEDCOM lines corresponding to a single individual. +#' +#' @param block A character vector containing the GEDCOM lines for one individual. +#' @param pattern_rows A list with counts of lines matching specific GEDCOM tags. +#' @param all_var_names A character vector of variable names. +#' @param verbose Logical indicating whether to print progress messages. +#' @return A named list representing the parsed record for the individual, or NULL if no ID is found. +#' @keywords internal +parseIndividualBlock.alpha <- function(block, pattern_rows, all_var_names, verbose = FALSE) { + record <- initializeRecord.alpha(all_var_names) + n_lines <- length(block) + + # Loop through the block by index so that we can look ahead for event details. + i <- 1 + while (i <= n_lines) { + line <- block[i] + + # Process individual identifier (e.g., "@ INDI ...") + if (grepl("@ INDI", line)) { + record$id <- stringr::str_extract(line, "(?<=@.)\\d*(?=@)") + i <- i + 1 + next + } + + # Special processing for full name using " NAME" tag. + if (grepl(" NAME", line) && pattern_rows$num_name_rows > 0) { + record <- parseNameLine.alpha(line, record) + i <- i + 1 + next + } + + # Process birth and death events by consuming multiple lines. + if (grepl(" BIRT", line) && pattern_rows$num_birt_rows > 0) { + record <- processEventLine.alpha("birth", block, i, record, pattern_rows) + i <- i + 1 # Skip further processing of this line. + next + } + if (grepl(" DEAT", line) && pattern_rows$num_deat_rows > 0) { + record <- processEventLine.alpha("death", block, i, record, pattern_rows) + i <- i + 1 + next + } + + # Process other tags using common mappings. + # Define mappings for name pieces (if not handled by NAME tag). + name_piece_mappings <- list( + list(tag = "GIVN", field = "name_given_pieces", mode = "replace"), + list(tag = "NPFX", field = "name_npfx", mode = "replace"), + list(tag = "NICK", field = "name_nick", mode = "replace"), + list(tag = "SURN", field = "name_surn_pieces", mode = "replace"), + list(tag = "NSFX", field = "name_nsfx", mode = "replace"), + list(tag = "_MARNM", field = "name_marriedsurn", mode = "replace") + ) + out <- applyTagMappings.alpha(line, record, pattern_rows, name_piece_mappings) + if (out$matched) { record <- out$record + i <- i + 1 + next } + + # Process attribute tags. + attribute_mappings <- list( + list(tag = "SEX", field = "sex", mode = "replace"), + list(tag = "CAST", field = "attribute_caste", mode = "replace"), + list(tag = "DSCR", field = "attribute_description", mode = "replace"), + list(tag = "EDUC", field = "attribute_education", mode = "replace"), + list(tag = "IDNO", field = "attribute_idnumber", mode = "replace"), + list(tag = "NATI", field = "attribute_nationality", mode = "replace"), + list(tag = "NCHI", field = "attribute_children", mode = "replace"), + list(tag = "NMR", field = "attribute_marriages", mode = "replace"), + list(tag = "OCCU", field = "attribute_occupation", mode = "replace"), + list(tag = "PROP", field = "attribute_property", mode = "replace"), + list(tag = "RELI", field = "attribute_religion", mode = "replace"), + list(tag = "RESI", field = "attribute_residence", mode = "replace"), + list(tag = "SSN", field = "attribute_ssn", mode = "replace"), + list(tag = "TITL", field = "attribute_title", mode = "replace") + ) + out <- applyTagMappings.alpha(line, record, pattern_rows, attribute_mappings) + if (out$matched) { record <- out$record + i <- i + 1 + next } + + # Process relationship tags, using a custom extractor. + relationship_mappings <- list( + list(tag = "FAMC", field = "FAMC", mode = "append", + extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)")), + list(tag = "FAMS", field = "FAMS", mode = "append", + extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)")) + ) + out <- applyTagMappings.alpha(line, record, pattern_rows, relationship_mappings) + if (out$matched) { record <- out$record + i <- i + 1 + next } + + # Optionally print progress for long records. + i <- i + 1 + } + + # If the record has no ID, return NULL. + if (is.na(record$id)) return(NULL) + return(record) +} + +#' Parse a Full Name Line +#' +#' Extracts full name information from a GEDCOM "NAME" line and updates the record accordingly. +#' +#' @param line A character string containing the name line. +#' @param record A named list representing the individual's record. +#' @return The updated record with parsed name information. +parseNameLine.alpha <- function(line, record) { + record$name <- extract_info.alpha(line, "NAME") + record$name_given <- stringr::str_extract(record$name, ".*(?= /)") + record$name_surn <- stringr::str_extract(record$name, "(?<=/).*(?=/)") + record$name <- stringr::str_squish(stringr::str_replace(record$name, "/", " ")) + return(record) +} + +#' Process Event Lines (Birth or Death) +#' +#' 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. +#' @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. +processEventLine.alpha <- function(event, block, i, record, pattern_rows) { + n_lines <- length(block) + if (event == "birth") { + if (i + 1 <= n_lines) record$birth_date <- extract_info.alpha(block[i+1], "DATE") + if (i + 2 <= n_lines) record$birth_place <- extract_info.alpha(block[i+2], "PLAC") + if (i + 4 <= n_lines) record$birth_lat <- extract_info.alpha(block[i+4], "LATI") + if (i + 5 <= n_lines) record$birth_long <- extract_info.alpha(block[i+5], "LONG") + } else if (event == "death") { + if (i + 1 <= n_lines) record$death_date <- extract_info.alpha(block[i+1], "DATE") + if (i + 2 <= n_lines) record$death_place <- extract_info.alpha(block[i+2], "PLAC") + if (i + 3 <= n_lines) record$death_caus <- extract_info.alpha(block[i+3], "CAUS") + if (i + 4 <= n_lines) record$death_lat <- extract_info.alpha(block[i+4], "LATI") + if (i + 5 <= n_lines) record$death_long <- extract_info.alpha(block[i+5], "LONG") + } + return(record) +} + +#' Apply Tag Mappings to a Line +#' +#' Iterates over a list of tag mappings and, if a tag matches the line, updates the record. +#' +#' @param line A character string from the GEDCOM file. +#' @param record A named list representing the individual's record. +#' @param pattern_rows A list with GEDCOM tag counts. +#' @param tag_mappings A list of lists. Each sublist should define: +#' - \code{tag}: the GEDCOM tag, +#' - \code{field}: the record field to update, +#' - \code{mode}: either "replace" or "append", +#' - \code{extractor}: (optional) a custom extraction function. +#' @return A list with the updated record (\code{record}) and a logical flag (\code{matched}). +applyTagMappings.alpha <- function(line, record, pattern_rows, tag_mappings) { + for (mapping in tag_mappings) { + extractor <- if (is.null(mapping$extractor)) NULL else mapping$extractor + result <- process_tag.alpha(mapping$tag, mapping$field, pattern_rows, line, record, + extractor = extractor, mode = mapping$mode) + record <- result$vars + if (result$matched) { + return(list(record = record, matched = TRUE)) + } + } + return(list(record = record, matched = FALSE)) +} + + +#' Extract Information from Line +#' +#' This function extracts information from a line based on a specified type. +#' @param line A character string representing a line from a GEDCOM file. +#' @param type A character string representing the type of information to extract. +#' @return A character string with the extracted information. +#' @keywords internal +extract_info.alpha <- function(line, type) { + stringr::str_squish(stringr::str_extract(line, paste0("(?<=", type, " ).+"))) +} + +#' Count GEDCOM Pattern Rows +#' +#' Counts the number of lines in a file (passed as a data frame with column "X1") +#' that match various GEDCOM patterns. +#' +#' @param file A data frame with a column \code{X1} containing GEDCOM lines. +#' @return A list with counts of specific GEDCOM tag occurrences. +countPatternRows.alpha <- function(file) { + pattern_counts <- sapply( + c( + "@ INDI", " NAME", " GIVN", " NPFX", " NICK", " SURN", " NSFX", " _MARNM", + " BIRT", " DEAT", " SEX", " CAST", " DSCR", " EDUC", " IDNO", " NATI", + " NCHI", " NMR", " OCCU", " PROP", " RELI", " RESI", " SSN", " TITL", + " FAMC", " FAMS", " PLAC", " LATI", " LONG", " DATE", " CAUS" + ), + function(pat) sum(grepl(pat, file$X1)) + ) + num_rows <- list( + num_indi_rows = pattern_counts["@ INDI"], + num_name_rows = pattern_counts[" NAME"], + num_givn_rows = pattern_counts[" GIVN"], + num_npfx_rows = pattern_counts[" NPFX"], + num_nick_rows = pattern_counts[" NICK"], + num_surn_rows = pattern_counts[" SURN"], + num_nsfx_rows = pattern_counts[" NSFX"], + num_marnm_rows = pattern_counts[" _MARNM"], + num_birt_rows = pattern_counts[" BIRT"], + num_deat_rows = pattern_counts[" DEAT"], + num_sex_rows = pattern_counts[" SEX"], + num_cast_rows = pattern_counts[" CAST"], + num_dscr_rows = pattern_counts[" DSCR"], + num_educ_rows = pattern_counts[" EDUC"], + num_idno_rows = pattern_counts[" IDNO"], + num_nati_rows = pattern_counts[" NATI"], + num_nchi_rows = pattern_counts[" NCHI"], + num_nmr_rows = pattern_counts[" NMR"], + num_occu_rows = pattern_counts[" OCCU"], + num_prop_rows = pattern_counts[" PROP"], + num_reli_rows = pattern_counts[" RELI"], + num_resi_rows = pattern_counts[" RESI"], + num_ssn_rows = pattern_counts[" SSN"], + num_titl_rows = pattern_counts[" TITL"], + num_famc_rows = pattern_counts[" FAMC"], + num_fams_rows = pattern_counts[" FAMS"], + num_plac_rows = pattern_counts[" PLAC"], + num_lati_rows = pattern_counts[" LATI"], + num_long_rows = pattern_counts[" LONG"], + num_date_rows = pattern_counts[" DATE"], + num_caus_rows = pattern_counts[" CAUS"] + ) + return(num_rows) +} + +#' Process a GEDCOM Tag +#' +#' Extracts and assigns a value to a specified field in `vars` if the pattern is present. +#' Returns both the updated variable list and a flag indicating whether the tag was matched. +#' +#' @param tag The GEDCOM tag (e.g., "SEX", "CAST", etc.). +#' @param field_name The name of the variable to assign to in `vars`. +#' @param pattern_rows Output from `countPatternRows()`. +#' @param line The GEDCOM line to parse. +#' @param vars The current list of variables to update. +#' @return A list with updated `vars` and a `matched` flag. +#' @keywords internal +process_tag.alpha <- function(tag, field_name, pattern_rows, line, vars, + extractor = NULL, mode = "replace") { + count_name <- paste0("num_", tolower(tag), "_rows") + matched <- FALSE + if (!is.null(pattern_rows[[count_name]]) && + pattern_rows[[count_name]] > 0 && + grepl(paste0(" ", tag), line)) { + value <- if (is.null(extractor)) { + extract_info.alpha(line, tag) + } else { + extractor(line) + } + if (mode == "append" && !is.na(vars[[field_name]])) { + vars[[field_name]] <- paste0(vars[[field_name]], ", ", value) + } else { + vars[[field_name]] <- value + } + matched <- TRUE + } + return(list(vars = vars, matched = matched)) +} + +#' Post-process GEDCOM Data Frame +#' +#' This function optionally adds parent information, combines duplicate columns, +#' and removes empty columns from the GEDCOM data frame. +#' +#' @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 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.alpha <- function(df_temp, + remove_empty_cols = TRUE, + combine_cols = TRUE, + add_parents = TRUE, + skinny = TRUE, + verbose = FALSE) { + if (add_parents) { + if (verbose) message("Processing parents") + df_temp <- processParents.alpha(df_temp, datasource = "gedcom") + } + if (combine_cols) { + df_temp <- collapseNames.alpha(verbose = verbose, df_temp = df_temp) + } + if (remove_empty_cols) { + if (verbose) message("Removing empty columns") + df_temp <- df_temp[, colSums(is.na(df_temp)) < nrow(df_temp)] + } + if (skinny) { + if (verbose) message("Slimming down the data frame") + df_temp <- df_temp[, colSums(is.na(df_temp)) < nrow(df_temp)] + df_temp$FAMC <- NULL + df_temp$FAMS <- NULL + } + return(df_temp) +} + +#' Process Parents Information from GEDCOM Data +#' +#' Adds parent IDs to the individuals based on family relationship data. +#' +#' @param df_temp A data frame produced by \code{readGedcom()}. +#' @param datasource Character string indicating the data source ("gedcom" or "wiki"). +#' @return The updated data frame with parent IDs added. +processParents.alpha <- function(df_temp, datasource) { + if (datasource == "gedcom") { + required_cols <- c("FAMC", "sex", "FAMS") + } else if (datasource == "wiki") { + required_cols <- c("id") + } else { + stop("Invalid datasource") + } + if (!all(required_cols %in% colnames(df_temp))) { + missing_cols <- setdiff(required_cols, colnames(df_temp)) + warning("Missing necessary columns: ", paste(missing_cols, collapse = ", ")) + return(df_temp) + } + family_to_parents <- mapFAMS2parents.alpha(df_temp) + if (is.null(family_to_parents) || length(family_to_parents) == 0) { + return(df_temp) + } + df_temp <- mapFAMC2parents.alpha(df_temp, family_to_parents) + return(df_temp) +} + +#' Create a Mapping from Family IDs to Parent IDs +#' +#' This function scans the data frame and creates a mapping of family IDs +#' to the corresponding parent IDs. +#' +#' @param df_temp A data frame produced by \code{readGedcom()}. +#' @return A list mapping family IDs to parent information. +mapFAMS2parents.alpha <- function(df_temp) { + if (!all(c("FAMS", "sex") %in% colnames(df_temp))) { + warning("The data frame does not contain the necessary columns (FAMS, sex)") + return(NULL) + } + family_to_parents <- list() + for (i in 1:nrow(df_temp)) { + if (!is.na(df_temp$FAMS[i])) { + fams_ids <- unlist(strsplit(df_temp$FAMS[i], ", ")) + for (fams_id in fams_ids) { + if (!is.null(family_to_parents[[fams_id]])) { + if (df_temp$sex[i] == "M") { + family_to_parents[[fams_id]]$father <- df_temp$id[i] + } else if (df_temp$sex[i] == "F") { + family_to_parents[[fams_id]]$mother <- df_temp$id[i] + } + } else { + family_to_parents[[fams_id]] <- list() + if (df_temp$sex[i] == "M") { + family_to_parents[[fams_id]]$father <- df_temp$id[i] + } else if (df_temp$sex[i] == "F") { + family_to_parents[[fams_id]]$mother <- df_temp$id[i] + } + } + } + } + } + return(family_to_parents) +} + +#' Assign momID and dadID based on family mapping +#' +#' This function assigns mother and father IDs to individuals in the data frame +#' based on the mapping of family IDs to parent IDs. +#' +#' @param df_temp A data frame containing individual information. +#' @param family_to_parents A list mapping family IDs to parent IDs. +#' @return A data frame with added momID and dad_ID columns. +#' @keywords internal +mapFAMC2parents.alpha <- function(df_temp, family_to_parents) { + df_temp$momID <- NA_character_ + df_temp$dadID <- NA_character_ + for (i in 1:nrow(df_temp)) { + if (!is.na(df_temp$FAMC[i])) { + famc_ids <- unlist(strsplit(df_temp$FAMC[i], ", ")) + for (famc_id in famc_ids) { + if (!is.null(family_to_parents[[famc_id]])) { + if (!is.null(family_to_parents[[famc_id]]$father)) { + df_temp$dadID[i] <- family_to_parents[[famc_id]]$father + } + if (!is.null(family_to_parents[[famc_id]]$mother)) { + df_temp$momID[i] <- family_to_parents[[famc_id]]$mother + } + } + } + } + } + return(df_temp) +} + +#' collapse Names +#' +#' This function combines the `name_given` and `name_given_pieces` columns in a data frame. +#' +#' @inheritParams readGedcom +#' @param df_temp A data frame containing the columns to be combined. +#' @return A data frame with the combined columns. +collapseNames.alpha <- function(verbose, df_temp) { + if (verbose) message("Combining Duplicate Columns") + + if (!all(is.na(df_temp$name_given_pieces)) | !all(is.na(df_temp$name_given))) { + result <- combine_columns.alpha(df_temp$name_given, df_temp$name_given_pieces) + df_temp$name_given <- result$combined + if (!result$retain_col2) df_temp$name_given_pieces <- NULL + } + + if (!all(is.na(df_temp$name_surn_pieces)) | !all(is.na(df_temp$name_surn))) { + result <- combine_columns.alpha(df_temp$name_surn, df_temp$name_surn_pieces) + df_temp$name_surn <- result$combined + if (!result$retain_col2) df_temp$name_surn_pieces <- NULL + } + return(df_temp) +} + +#' Combine Columns +#' +#' This function combines two columns, handling conflicts and merging non-conflicting data. +#' @param col1 The first column to combine. +#' @param col2 The second column to combine. +#' @return A list with the combined column and a flag indicating if the second column should be retained. +#' @keywords internal +# Helper function to check for conflicts and merge columns +combine_columns.alpha <- function(col1, col2) { + col1_lower <- stringr::str_to_lower(col1) + col2_lower <- stringr::str_to_lower(col2) + conflicts <- !is.na(col1_lower) & !is.na(col2_lower) & col1_lower != col2_lower + if (any(conflicts)) { + warning("Columns have conflicting values. They were not merged.") + return(list(combined = col1, retain_col2 = TRUE)) + } else { + combined <- ifelse(is.na(col1), col2, col1) + return(list(combined = combined, retain_col2 = FALSE)) + } +} + +# --- Exported Aliases --- +#' @rdname readGedcom.alpha +#' @export +readGed.alpha <- readGedcom.alpha +#' @rdname readGedcom.alpha +#' @export +readgedcom.alpha <- readGedcom.alpha diff --git a/man/compute_parent_adjacency.Rd b/man/compute_parent_adjacency.Rd index 9cd4311c..21974673 100644 --- a/man/compute_parent_adjacency.Rd +++ b/man/compute_parent_adjacency.Rd @@ -7,7 +7,7 @@ compute_parent_adjacency( ped, component, - adjacency_method = "indexed", + adjacency_method = "direct", saveable, resume, save_path, diff --git a/man/determineSex.Rd b/man/determineSex.Rd index c98644f6..c1c096af 100644 --- a/man/determineSex.Rd +++ b/man/determineSex.Rd @@ -4,7 +4,7 @@ \alias{determineSex} \title{Determine Sex of Offspring} \usage{ -determineSex(idGen, sexR) +determineSex(idGen, sexR, code_male = "M", code_female = "F") } \arguments{ \item{idGen}{Vector of IDs for the generation.} diff --git a/man/ped2com.Rd b/man/ped2com.Rd index 27f632f5..c47d5982 100644 --- a/man/ped2com.Rd +++ b/man/ped2com.Rd @@ -14,7 +14,7 @@ ped2com( flatten.diag = FALSE, standardize.colnames = TRUE, transpose_method = "tcrossprod", - adjacency_method = "indexed", + adjacency_method = "direct", isChild_method = "classic", saveable = FALSE, resume = FALSE, diff --git a/man/postProcessGedcom.Rd b/man/postProcessGedcom.Rd new file mode 100644 index 00000000..9d0c7b2c --- /dev/null +++ b/man/postProcessGedcom.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcom.R +\name{postProcessGedcom} +\alias{postProcessGedcom} +\title{Post-process GEDCOM Data Frame} +\usage{ +postProcessGedcom( + df_temp, + remove_empty_cols = TRUE, + combine_cols = TRUE, + add_parents = TRUE, + skinny = TRUE, + verbose = FALSE +) +} +\arguments{ +\item{df_temp}{A data frame containing information about individuals.} + +\item{remove_empty_cols}{A logical value indicating whether to remove columns with all missing values.} + +\item{combine_cols}{A logical value indicating whether to combine columns with duplicate values.} + +\item{add_parents}{A logical value indicating whether to add parents to the data frame.} + +\item{skinny}{A logical value indicating whether to return a skinny data frame.} + +\item{verbose}{A logical value indicating whether to print messages.} +} +\value{ +A data frame with processed information. +} +\description{ +Post-process GEDCOM Data Frame +} diff --git a/man/readGedcom.Rd b/man/readGedcom.Rd index 7bab49b1..a54cd5aa 100644 --- a/man/readGedcom.Rd +++ b/man/readGedcom.Rd @@ -14,6 +14,7 @@ readGedcom( combine_cols = TRUE, skinny = FALSE, update_rate = 1000, + post_process = TRUE, ... ) @@ -25,6 +26,7 @@ readGed( combine_cols = TRUE, skinny = FALSE, update_rate = 1000, + post_process = TRUE, ... ) @@ -36,6 +38,7 @@ readgedcom( combine_cols = TRUE, skinny = FALSE, update_rate = 1000, + post_process = TRUE, ... ) } diff --git a/tests/testthat/test-readPedigrees_alpha.R b/tests/testthat/test-readPedigrees_alpha.R new file mode 100644 index 00000000..4a5a4e98 --- /dev/null +++ b/tests/testthat/test-readPedigrees_alpha.R @@ -0,0 +1,231 @@ +test_that("readGedcom.alpha reads and parses a GEDCOM file correctly", { + # Create a temporary GEDCOM file for testing + gedcom_content <- c( + "0 HEAD", + "1 GEDC", + "2 VERS 5.5", + "2 FORM LINEAGE-LINKED", + "1 CHAR UTF-8", + "1 LANG English", + "0 @I1@ INDI", + "1 NAME John /Doe/", + "1 SEX M", + "1 BIRT", + "2 DATE 1 JAN 1900", + "2 PLAC Someplace", + "0 @I2@ INDI", + "1 NAME Jane /Smith/", + "1 SEX F", + "1 BIRT", + "2 DATE 2 FEB 1910", + "2 PLAC Anotherplace", + "1 NCHI 2" + ) + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom_content, temp_file) + + # Call readGedcom.alpha + df <- readGedcom.alpha(temp_file, verbose = TRUE, skinny = FALSE) + # note to self, the code is not reading in the 2nd person. and is also not reading in the birth date and place + # Check that the data frame has the expected structure + expect_true("id" %in% colnames(df)) + expect_true("name_given" %in% colnames(df)) + expect_true("name_surn" %in% colnames(df)) + expect_true("sex" %in% colnames(df)) + expect_true("birth_date" %in% colnames(df)) + expect_true("birth_place" %in% colnames(df)) + + # Check the contents of the data frame + expect_equal(nrow(df), 2) + expect_equal(df$name_given[1], "John") + expect_equal(df$name_surn[1], "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$name_given[2], "Jane") + expect_equal(df$name_surn[2], "Smith") + expect_equal(df$sex[2], "F") + expect_equal(df$birth_date[2], "2 FEB 1910") + expect_equal(df$birth_place[2], "Anotherplace") + + # Clean up temporary file + unlink(temp_file) +}) + +test_that("readGedcom.alpha combines duplicate columns correctly", { + # Create a temporary GEDCOM file for testing + gedcom_content <- c( + "0 @I1@ INDI", + "1 NAME John /Doe/", + "1 GIVN John", + "1 SEX M", + "0 @I2@ INDI", + "1 NAME Jane /Smith/", + "1 GIVN Jane", + "1 SEX F" + ) + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom_content, temp_file) + + # Call readGedcom.alpha with combine_cols = TRUE + df <- readGedcom.alpha(temp_file, verbose = TRUE, combine_cols = TRUE) + + # Check that the data frame has the expected structure + expect_true("name_given" %in% colnames(df)) + expect_false("name_given_pieces" %in% colnames(df)) + + # Check the contents of the data frame + expect_equal(nrow(df), 2) + expect_equal(df$name_given[1], "John") + expect_equal(df$name_given[2], "Jane") + + # Clean up temporary file + unlink(temp_file) +}) + +test_that("readGedcom.alpha removes empty columns correctly", { + # Create a temporary GEDCOM file for testing + gedcom_content <- c( + "0 @I1@ INDI", + "1 NAME John /Doe/", + "1 SEX M" + ) + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom_content, temp_file) + + # Call readGedcom.alpha with remove_empty_cols = TRUE + df <- readGedcom.alpha(temp_file, verbose = TRUE, remove_empty_cols = TRUE) + + # Check that empty columns are removed + expect_false("birth_date" %in% colnames(df)) + expect_false("birth_place" %in% colnames(df)) + + # Clean up temporary file + unlink(temp_file) +}) + +test_that("readGedcom.alpha handles skinny option correctly", { + # Create a temporary GEDCOM file for testing + gedcom_content <- c( + "0 @I1@ INDI", + "1 NAME John /Doe/", + "1 SEX M", + "1 FAMC @F1@", + "1 FAMS @F2@" + ) + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom_content, temp_file) + + # Call readGedcom.alpha with skinny = TRUE + df <- readGedcom.alpha(temp_file, verbose = TRUE, skinny = TRUE) + + # Check that FAMC and FAMS columns are removed + expect_false("FAMC" %in% colnames(df)) + expect_false("FAMS" %in% colnames(df)) + + # Clean up temporary file + unlink(temp_file) +}) + +test_that("processParents.alpha adds momID and dadID correctly", { + # Create a data frame for testing + df_temp <- data.frame( + id = c("I1", "I2", "I3"), + sex = c("M", "F", "M"), + FAMS = c("@F1@", "@F1@", NA), + FAMC = c(NA, NA, "@F1@"), + stringsAsFactors = FALSE + ) + + # Call processParents.alpha + df_temp <- processParents.alpha(df_temp, datasource = "gedcom") + + # Check the structure of the data frame + expect_true("momID" %in% colnames(df_temp)) + expect_true("dadID" %in% colnames(df_temp)) + + # Check the contents of the data frame + expect_equal(df_temp$momID[1], NA_character_) + expect_equal(df_temp$dadID[1], NA_character_) + expect_equal(df_temp$momID[2], NA_character_) + expect_equal(df_temp$dadID[2], NA_character_) + expect_equal(df_temp$momID[3], "I2") + expect_equal(df_temp$dadID[3], "I1") + + # Create a more complex data frame for testing + df_temp <- data.frame( + id = c("I1", "I2", "I3", "I4", "I5"), + sex = c("M", "F", "M", "F", "M"), + FAMS = c("@F1@", "@F1@", "@F2@", "@F2@", "@F3@"), + FAMC = c(NA, NA, "@F1@", "@F1@", "@F2@"), + stringsAsFactors = FALSE + ) + + # Call processParents.alpha + df_temp <- processParents.alpha(df_temp, datasource = "gedcom") + + # Check the contents of the data frame + expect_equal(df_temp$momID[3], "I2") + expect_equal(df_temp$dadID[3], "I1") + expect_equal(df_temp$momID[4], "I2") + expect_equal(df_temp$dadID[4], "I1") + expect_equal(df_temp$momID[5], "I4") + expect_equal(df_temp$dadID[5], "I3") +}) + +test_that("if file does not exist, readGedcom.alpha throws an error", { + # Call readGedcom.alpha with a non-existent file + expect_error(readGedcom.alpha("nonexistent.ged")) +}) + +test_that("readGedcom.alpha parses death event correctly", { + # Test that a GEDCOM file with a death event is parsed correctly. + gedcom_content <- c( + "0 @I1@ INDI", + "1 NAME John /Doe/", + "1 SEX M", + "1 DEAT", + "2 DATE 31 DEC 2000", + "2 PLAC Lastplace", + "2 CAUS Old age", + "2 LATI 12.3456", + "2 LONG -65.4321" + ) + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom_content, temp_file) + + df <- readGedcom.alpha(temp_file, verbose = TRUE) + + expect_true("death_date" %in% colnames(df)) + expect_true("death_place" %in% colnames(df)) + expect_true("death_caus" %in% colnames(df)) + expect_true("death_lat" %in% colnames(df)) + expect_true("death_long" %in% colnames(df)) + + expect_equal(df$death_date[1], "31 DEC 2000") + expect_equal(df$death_place[1], "Lastplace") + expect_equal(df$death_caus[1], "Old age") + expect_equal(df$death_lat[1], "12.3456") + expect_equal(df$death_long[1], "-65.4321") + + unlink(temp_file) +}) + +test_that("readGedcom.alpha handles incomplete individual records gracefully", { + # Test that an individual record missing a NAME line is handled without error. + gedcom_content <- c( + "0 @I1@ INDI", + "1 SEX M" + # No NAME or BIRT information. + ) + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom_content, temp_file) + + df <- readGedcom.alpha(temp_file, verbose = TRUE) + + # Expect one record with missing name fields. + expect_equal(nrow(df), 1) + expect_true(is.null(df$name[1])) + + unlink(temp_file) +}) From 2541415bb113667cb2b7cedbd0a1e881a2077bfc Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 14 Apr 2025 19:46:46 -0400 Subject: [PATCH 36/69] Update readGedcom.R --- R/readGedcom.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/readGedcom.R b/R/readGedcom.R index f271632c..8d800a66 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -48,7 +48,7 @@ #' - `FAMC`: ID(s) of the family where the individual is a child #' - `FAMS`: ID(s) of the family where the individual is a spouse #' @export -readGedcom <- function(file_path, +readGedcom.legacy <- function(file_path, verbose = FALSE, add_parents = TRUE, remove_empty_cols = TRUE, From 65affa3dd2f09262798d3632cf5b1b591c5f5b04 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 14 Apr 2025 19:51:32 -0400 Subject: [PATCH 37/69] rename --- R/{readGedcom.R => readGedcomlegacy.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename R/{readGedcom.R => readGedcomlegacy.R} (100%) diff --git a/R/readGedcom.R b/R/readGedcomlegacy.R similarity index 100% rename from R/readGedcom.R rename to R/readGedcomlegacy.R From 1ee34bab6060cf75177645a8a75edc9e70082526 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 14 Apr 2025 19:51:58 -0400 Subject: [PATCH 38/69] rename --- R/{readGedcom_alpha.R => readGedcom.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename R/{readGedcom_alpha.R => readGedcom.R} (100%) diff --git a/R/readGedcom_alpha.R b/R/readGedcom.R similarity index 100% rename from R/readGedcom_alpha.R rename to R/readGedcom.R From 294186ba69f2a6c1d3e23e9af4792071ee48d527 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 14 Apr 2025 19:59:28 -0400 Subject: [PATCH 39/69] Update readGedcomlegacy.R --- R/readGedcomlegacy.R | 84 ++++++++++++++++++++------------------------ 1 file changed, 39 insertions(+), 45 deletions(-) diff --git a/R/readGedcomlegacy.R b/R/readGedcomlegacy.R index 8d800a66..b8697908 100644 --- a/R/readGedcomlegacy.R +++ b/R/readGedcomlegacy.R @@ -47,7 +47,7 @@ #' - `attribute_title`: Title of the individual #' - `FAMC`: ID(s) of the family where the individual is a child #' - `FAMS`: ID(s) of the family where the individual is a spouse -#' @export +#' @internal readGedcom.legacy <- function(file_path, verbose = FALSE, add_parents = TRUE, @@ -69,7 +69,7 @@ readGedcom.legacy <- function(file_path, } # Count the number of rows containing specific patterns - num_rows <- countPatternRows(file) + num_rows <- countPatternRows.legacy(file) # List of variables to initialize var_names <- list( @@ -128,51 +128,51 @@ readGedcom.legacy <- function(file_path, # names if (num_rows$num_name_rows > 0 && grepl(" NAME", tmpv)) { - vars$name <- extract_info(tmpv, "NAME") + vars$name <- extract_info.legacy(tmpv, "NAME") vars$name_given <- stringr::str_extract(vars$name, ".*(?= /)") vars$name_surn <- stringr::str_extract(vars$name, "(?<=/).*(?=/)") vars$name <- stringr::str_squish(stringr::str_replace(vars$name, "/", " ")) next } # PERSONAL_NAME_PIECES := NAME | NPFX | GIVN | NICK | SPFX | SURN | NSFX - result <- process_tag("GIVN", "name_given_pieces", num_rows, tmpv, vars) + result <- process_tag.legacy("GIVN", "name_given_pieces", num_rows, tmpv, vars) vars <- result$vars if (result$matched) next # npfx := Name Prefix - result <- process_tag("NPFX", "name_npfx", num_rows, tmpv, vars) + result <- process_tag.legacy("NPFX", "name_npfx", num_rows, tmpv, vars) vars <- result$vars if (result$matched) next # NICK := Nickname - result <- process_tag("NICK", "name_nick", num_rows, tmpv, vars) + result <- process_tag.legacy("NICK", "name_nick", num_rows, tmpv, vars) vars <- result$vars if (result$matched) next # surn := Surname - result <- process_tag("SURN", "name_surn_pieces", num_rows, tmpv, vars) + result <- process_tag.legacy("SURN", "name_surn_pieces", num_rows, tmpv, vars) vars <- result$vars if (result$matched) next # nsfx := Name suffix - result <- process_tag("NSFX", "name_nsfx", num_rows, tmpv, vars) + result <- process_tag.legacy("NSFX", "name_nsfx", num_rows, tmpv, vars) vars <- result$vars if (result$matched) next - result <- process_tag("_MARNM", "name_marriedsurn", num_rows, tmpv, vars) + result <- process_tag.legacy("_MARNM", "name_marriedsurn", num_rows, tmpv, vars) vars <- result$vars if (result$matched) next # Birth event related information if (num_rows$num_birt_rows > 0 && grepl(" BIRT", tmpv)) { if (num_rows$num_date_rows > 0 && i + 1 <= file_length) { - vars$birth_date <- extract_info(file[1][[1]][[i + 1]], "DATE") + vars$birth_date <- extract_info.legacy(file[1][[1]][[i + 1]], "DATE") if (num_rows$num_plac_rows > 0 && i + 2 <= file_length) { - vars$birth_place <- extract_info(file[1][[1]][[i + 2]], "PLAC") + vars$birth_place <- extract_info.legacy(file[1][[1]][[i + 2]], "PLAC") if (num_rows$num_lati_rows > 0 && i + 4 <= file_length) { - vars$birth_lat <- extract_info(file[1][[1]][[i + 4]], "LATI") + vars$birth_lat <- extract_info.legacy(file[1][[1]][[i + 4]], "LATI") if (num_rows$num_long_rows > 0 && i + 5 <= file_length) { - vars$birth_long <- extract_info(file[1][[1]][[i + 5]], "LONG") + vars$birth_long <- extract_info.legacy(file[1][[1]][[i + 5]], "LONG") } } } @@ -184,15 +184,15 @@ readGedcom.legacy <- function(file_path, # the ifs are nested so that there is no need to check if you've already run out of if (num_rows$num_deat_rows > 0 && grepl(" DEAT", tmpv)) { if (num_rows$num_date_rows > 0 && i + 1 <= file_length) { - vars$death_date <- extract_info(file[1][[1]][[i + 1]], "DATE") + vars$death_date <- extract_info.legacy(file[1][[1]][[i + 1]], "DATE") if (num_rows$num_plac_rows > 0 && i + 2 <= file_length) { - vars$death_place <- extract_info(file[1][[1]][[i + 2]], "PLAC") + vars$death_place <- extract_info.legacy(file[1][[1]][[i + 2]], "PLAC") if (num_rows$num_caus_rows > 0 && i + 3 <= file_length) { - vars$death_caus <- extract_info(file[1][[1]][[i + 3]], "CAUS") + vars$death_caus <- extract_info.legacy(file[1][[1]][[i + 3]], "CAUS") if (num_rows$num_lati_rows > 0 && i + 4 <= file_length) { - vars$death_lat <- extract_info(file[1][[1]][[i + 4]], "LATI") + vars$death_lat <- extract_info.legacy(file[1][[1]][[i + 4]], "LATI") if (num_rows$num_long_rows > 0 && i + 5 <= file_length) { - vars$death_long <- extract_info(file[1][[1]][[i + 5]], "LONG") + vars$death_long <- extract_info.legacy(file[1][[1]][[i + 5]], "LONG") } } } @@ -258,7 +258,7 @@ readGedcom.legacy <- function(file_path, # g7:INDI-TITL A formal designation used by an individual in connection with positions of royalty or other social status, such as Grand Duke. c("TITL", "attribute_title") )) { - result <- process_tag(tag_field[1], tag_field[2], num_rows, tmpv, vars) + result <- process_tag.legacy(tag_field[1], tag_field[2], num_rows, tmpv, vars) vars <- result$vars if (result$matched) next } @@ -266,7 +266,7 @@ readGedcom.legacy <- function(file_path, # relationship data # g7:INDI-FAMC ## The family in which an individual appears as a child. It is also used with a g7:FAMC-STAT substructure to show individuals who are not children of the family. See FAMILY_RECORD for more details. - result <- process_tag("FAMC", "FAMC", num_rows, tmpv, vars, + result <- process_tag.legacy("FAMC", "FAMC", num_rows, tmpv, vars, extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)"), mode = "append" ) @@ -275,7 +275,7 @@ readGedcom.legacy <- function(file_path, # FAMS (Family spouse) g7:FAMS # The family in which an individual appears as a partner. See FAMILY_RECORD for more details. - result <- process_tag("FAMS", "FAMS", num_rows, tmpv, vars, + result <- process_tag.legacy("FAMS", "FAMS", num_rows, tmpv, vars, extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)"), mode = "append" ) @@ -307,7 +307,7 @@ readGedcom.legacy <- function(file_path, print("Post-processing data frame") } # Remove the first row (empty) -df_temp <- postProcessGedcom( +df_temp <- postProcessGedcom.legacy( df_temp = df_temp, remove_empty_cols = remove_empty_cols, combine_cols = combine_cols, @@ -323,11 +323,11 @@ df_temp <- postProcessGedcom( #' Post-process GEDCOM Data Frame #' -#' @inheritParams readGedcom -#' @inheritParams mapFAMS2parents +#' @inheritParams readGedcom.legacy +#' @inheritParams mapFAMS2parents.legacy #' @return A data frame with processed information. -postProcessGedcom <- function(df_temp, +postProcessGedcom.legacy <- function(df_temp, remove_empty_cols = TRUE, combine_cols = TRUE, add_parents = TRUE, @@ -339,11 +339,11 @@ postProcessGedcom <- function(df_temp, if (verbose) { print("Processing parents") } - df_temp <- processParents(df_temp, datasource = "gedcom") + df_temp <- processParents.legacy(df_temp, datasource = "gedcom") } if (combine_cols) { - df_temp <- collapseNames(verbose = verbose, df_temp = df_temp) + df_temp <- collapseNames.legacy(verbose = verbose, df_temp = df_temp) } if (remove_empty_cols) { @@ -374,7 +374,7 @@ return(df_temp) #' @return A list mapping family IDs to parent IDs. #' @keywords internal #' -mapFAMS2parents <- function(df_temp) { +mapFAMS2parents.legacy <- function(df_temp) { if (!all(c("FAMS", "sex") %in% colnames(df_temp))) { warning("The data frame does not contain the necessary columns (FAMS, sex)") return(NULL) @@ -413,7 +413,7 @@ mapFAMS2parents <- function(df_temp) { #' @param family_to_parents A list mapping family IDs to parent IDs. #' @return A data frame with added momID and dad_ID columns. #' @keywords internal -mapFAMC2parents <- function(df_temp, family_to_parents) { +mapFAMC2parents.legacy <- function(df_temp, family_to_parents) { df_temp$momID <- NA_character_ df_temp$dadID <- NA_character_ for (i in 1:nrow(df_temp)) { @@ -441,7 +441,7 @@ mapFAMC2parents <- function(df_temp, family_to_parents) { #' @param df_temp A data frame containing information about individuals. #' @return A data frame with added momID and dadID columns. #' @keywords internal -processParents <- function(df_temp, datasource) { +processParents.legacy <- function(df_temp, datasource) { # Ensure required columns are present if (datasource == "gedcom") { required_cols <- c("FAMC", "sex", "FAMS") @@ -457,11 +457,11 @@ processParents <- function(df_temp, datasource) { return(df_temp) } - family_to_parents <- mapFAMS2parents(df_temp) + family_to_parents <- mapFAMS2parents.legacy(df_temp) if (is.null(family_to_parents) || length(family_to_parents) == 0) { return(df_temp) } - df_temp <- mapFAMC2parents(df_temp, family_to_parents) + df_temp <- mapFAMC2parents.legacy(df_temp, family_to_parents) return(df_temp) } @@ -474,7 +474,7 @@ processParents <- function(df_temp, datasource) { #' @param type A character string representing the type of information to extract. #' @return A character string with the extracted information. #' @keywords internal -extract_info <- function(line, type) { +extract_info.legacy <- function(line, type) { stringr::str_squish(stringr::str_extract(line, paste0("(?<=", type, " ).+"))) } @@ -509,7 +509,7 @@ combine_columns <- function(col1, col2) { #' @return A list with the number of rows containing each pattern. #' @keywords internal #' -countPatternRows <- function(file) { +countPatternRows.legacy <- function(file) { # Count the number of rows containing specific patterns pattern_counts <- sapply( c( @@ -569,14 +569,14 @@ countPatternRows <- function(file) { #' @return A list with updated `vars` and a `matched` flag. #' @keywords internal #' -process_tag <- function(tag, field_name, pattern_rows, line, vars, +process_tag.legacy <- function(tag, field_name, pattern_rows, line, vars, extractor = NULL, mode = "replace") { count_name <- paste0("num_", tolower(tag), "_rows") matched <- FALSE if (!is.null(pattern_rows[[count_name]]) && pattern_rows[[count_name]] > 0 && grepl(paste0(" ", tag), line)) { - value <- if (is.null(extractor)) extract_info(line, tag) else extractor(line) + value <- if (is.null(extractor)) extract_info.legacy(line, tag) else extractor(line) if (mode == "append" && !is.na(vars[[field_name]])) { vars[[field_name]] <- paste0(vars[[field_name]], ", ", value) @@ -593,10 +593,10 @@ process_tag <- function(tag, field_name, pattern_rows, line, vars, #' #' This function combines the `name_given` and `name_given_pieces` columns in a data frame. #' -#' @inheritParams readGedcom +#' @inheritParams readGedcom.legacy #' @param df_temp A data frame containing the columns to be combined. - -collapseNames <- function(verbose, df_temp) { +#' @keywords internal +collapseNames.legacy <- function(verbose, df_temp) { if (verbose) { print("Combining Duplicate Columns") } @@ -622,10 +622,4 @@ collapseNames <- function(verbose, df_temp) { } return(df_temp) } -#' @rdname readGedcom -#' @export -readGed <- readGedcom -#' @rdname readGedcom -#' @export -readgedcom <- readGedcom From 8244984df4aead2370965479be4bc3ea7afedf7f Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 14 Apr 2025 20:05:14 -0400 Subject: [PATCH 40/69] updating tests --- tests/testthat/test-readPedigrees.R | 73 ++++--- tests/testthat/test-readPedigrees_alpha.R | 245 +++------------------- 2 files changed, 70 insertions(+), 248 deletions(-) diff --git a/tests/testthat/test-readPedigrees.R b/tests/testthat/test-readPedigrees.R index a6d6bdd0..b48bf74a 100644 --- a/tests/testthat/test-readPedigrees.R +++ b/tests/testthat/test-readPedigrees.R @@ -180,44 +180,55 @@ test_that("if file does not exist, readGedcom throws an error", { -# readWikifamilytree - -test_that("readWikifamilytree reads a string correctly", { - # Create a temporary WikiFamilyTree file for testing - # Example usage - family_tree_text <- "{{familytree/start |summary=I have a brother Joe and a little sister: my mom married my dad, and my dad's parents were Grandma and Grandpa; they had another child, Aunt Daisy.}} -{{familytree | | | | GMa |~|y|~| GPa | | GMa=Gladys|GPa=Sydney}} -{{familytree | | | | | | | |)|-|-|-|.| }} -{{familytree | | | MOM |y| DAD | |DAISY| MOM=Mom|DAD=Dad|DAISY=[[Daisy Duke]]}} -{{familytree | |,|-|-|-|+|-|-|-|.| | | }} -{{familytree | JOE | | ME | | SIS | | | JOE=My brother Joe|ME='''Me!'''|SIS=My little sister}} -{{familytree/end}}" +test_that("readGedcom parses death event correctly", { + # Test that a GEDCOM file with a death event is parsed correctly. + gedcom_content <- c( + "0 @I1@ INDI", + "1 NAME John /Doe/", + "1 SEX M", + "1 DEAT", + "2 DATE 31 DEC 2000", + "2 PLAC Lastplace", + "2 CAUS Old age", + "2 LATI 12.3456", + "2 LONG -65.4321" + ) + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom_content, temp_file) - temp_file <- tempfile(fileext = ".txt") - writeLines(family_tree_text, temp_file) + df <- readGedcom(temp_file, verbose = TRUE) + expect_true("death_date" %in% colnames(df)) + expect_true("death_place" %in% colnames(df)) + expect_true("death_caus" %in% colnames(df)) + expect_true("death_lat" %in% colnames(df)) + expect_true("death_long" %in% colnames(df)) - result <- readWikifamilytree(text = family_tree_text) - result2 <- readWikifamilytree(file_path = temp_file) + expect_equal(df$death_date[1], "31 DEC 2000") + expect_equal(df$death_place[1], "Lastplace") + expect_equal(df$death_caus[1], "Old age") + expect_equal(df$death_lat[1], "12.3456") + expect_equal(df$death_long[1], "-65.4321") - expect_equal( - result$summary, - "I have a brother Joe and a little sister: my mom married my dad, and my dad's parents were Grandma and Grandpa; they had another child, Aunt Daisy." - ) + unlink(temp_file) +}) - expect_equal( - result2$summary, - "I have a brother Joe and a little sister: my mom married my dad, and my dad's parents were Grandma and Grandpa; they had another child, Aunt Daisy." +test_that("readGedcom handles incomplete individual records gracefully", { + # Test that an individual record missing a NAME line is handled without error. + gedcom_content <- c( + "0 @I1@ INDI", + "1 SEX M" + # No NAME or BIRT information. ) -}) + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom_content, temp_file) + df <- readGedcom(temp_file, verbose = TRUE) -# read E:/Dropbox/Lab/Research/Projects/2024/BGMiscJoss/BGmisc_main/data-raw/Targaryen tree Dance.txt + # Expect one record with missing name fields. + expect_equal(nrow(df), 1) + expect_true(is.null(df$name[1])) -# test_that("readWikifamilytree reads a file correctly", { -# Create a temporary WikiFamilyTree file for testing -# Example usage -# family_tree_file_path <- "data-raw/Targaryen tree Dance.txt" # system.file("extdata", "Targaryen tree Dance.txt", package = "BGmisc") + unlink(temp_file) +}) -# result <- readWikifamilytree(file_path=family_tree_file_path) -# }) diff --git a/tests/testthat/test-readPedigrees_alpha.R b/tests/testthat/test-readPedigrees_alpha.R index 4a5a4e98..d73e5810 100644 --- a/tests/testthat/test-readPedigrees_alpha.R +++ b/tests/testthat/test-readPedigrees_alpha.R @@ -1,231 +1,42 @@ -test_that("readGedcom.alpha reads and parses a GEDCOM file correctly", { - # Create a temporary GEDCOM file for testing - gedcom_content <- c( - "0 HEAD", - "1 GEDC", - "2 VERS 5.5", - "2 FORM LINEAGE-LINKED", - "1 CHAR UTF-8", - "1 LANG English", - "0 @I1@ INDI", - "1 NAME John /Doe/", - "1 SEX M", - "1 BIRT", - "2 DATE 1 JAN 1900", - "2 PLAC Someplace", - "0 @I2@ INDI", - "1 NAME Jane /Smith/", - "1 SEX F", - "1 BIRT", - "2 DATE 2 FEB 1910", - "2 PLAC Anotherplace", - "1 NCHI 2" - ) - temp_file <- tempfile(fileext = ".ged") - writeLines(gedcom_content, temp_file) - - # Call readGedcom.alpha - df <- readGedcom.alpha(temp_file, verbose = TRUE, skinny = FALSE) - # note to self, the code is not reading in the 2nd person. and is also not reading in the birth date and place - # Check that the data frame has the expected structure - expect_true("id" %in% colnames(df)) - expect_true("name_given" %in% colnames(df)) - expect_true("name_surn" %in% colnames(df)) - expect_true("sex" %in% colnames(df)) - expect_true("birth_date" %in% colnames(df)) - expect_true("birth_place" %in% colnames(df)) - # Check the contents of the data frame - expect_equal(nrow(df), 2) - expect_equal(df$name_given[1], "John") - expect_equal(df$name_surn[1], "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$name_given[2], "Jane") - expect_equal(df$name_surn[2], "Smith") - expect_equal(df$sex[2], "F") - expect_equal(df$birth_date[2], "2 FEB 1910") - expect_equal(df$birth_place[2], "Anotherplace") +# readWikifamilytree - # Clean up temporary file - unlink(temp_file) -}) - -test_that("readGedcom.alpha combines duplicate columns correctly", { - # Create a temporary GEDCOM file for testing - gedcom_content <- c( - "0 @I1@ INDI", - "1 NAME John /Doe/", - "1 GIVN John", - "1 SEX M", - "0 @I2@ INDI", - "1 NAME Jane /Smith/", - "1 GIVN Jane", - "1 SEX F" - ) - temp_file <- tempfile(fileext = ".ged") - writeLines(gedcom_content, temp_file) +test_that("readWikifamilytree reads a string correctly", { + # Create a temporary WikiFamilyTree file for testing + # Example usage + family_tree_text <- "{{familytree/start |summary=I have a brother Joe and a little sister: my mom married my dad, and my dad's parents were Grandma and Grandpa; they had another child, Aunt Daisy.}} +{{familytree | | | | GMa |~|y|~| GPa | | GMa=Gladys|GPa=Sydney}} +{{familytree | | | | | | | |)|-|-|-|.| }} +{{familytree | | | MOM |y| DAD | |DAISY| MOM=Mom|DAD=Dad|DAISY=[[Daisy Duke]]}} +{{familytree | |,|-|-|-|+|-|-|-|.| | | }} +{{familytree | JOE | | ME | | SIS | | | JOE=My brother Joe|ME='''Me!'''|SIS=My little sister}} +{{familytree/end}}" - # Call readGedcom.alpha with combine_cols = TRUE - df <- readGedcom.alpha(temp_file, verbose = TRUE, combine_cols = TRUE) + temp_file <- tempfile(fileext = ".txt") + writeLines(family_tree_text, temp_file) - # Check that the data frame has the expected structure - expect_true("name_given" %in% colnames(df)) - expect_false("name_given_pieces" %in% colnames(df)) - # Check the contents of the data frame - expect_equal(nrow(df), 2) - expect_equal(df$name_given[1], "John") - expect_equal(df$name_given[2], "Jane") + result <- readWikifamilytree(text = family_tree_text) + result2 <- readWikifamilytree(file_path = temp_file) - # Clean up temporary file - unlink(temp_file) -}) - -test_that("readGedcom.alpha removes empty columns correctly", { - # Create a temporary GEDCOM file for testing - gedcom_content <- c( - "0 @I1@ INDI", - "1 NAME John /Doe/", - "1 SEX M" + expect_equal( + result$summary, + "I have a brother Joe and a little sister: my mom married my dad, and my dad's parents were Grandma and Grandpa; they had another child, Aunt Daisy." ) - temp_file <- tempfile(fileext = ".ged") - writeLines(gedcom_content, temp_file) - - # Call readGedcom.alpha with remove_empty_cols = TRUE - df <- readGedcom.alpha(temp_file, verbose = TRUE, remove_empty_cols = TRUE) - - # Check that empty columns are removed - expect_false("birth_date" %in% colnames(df)) - expect_false("birth_place" %in% colnames(df)) - # Clean up temporary file - unlink(temp_file) -}) - -test_that("readGedcom.alpha handles skinny option correctly", { - # Create a temporary GEDCOM file for testing - gedcom_content <- c( - "0 @I1@ INDI", - "1 NAME John /Doe/", - "1 SEX M", - "1 FAMC @F1@", - "1 FAMS @F2@" + expect_equal( + result2$summary, + "I have a brother Joe and a little sister: my mom married my dad, and my dad's parents were Grandma and Grandpa; they had another child, Aunt Daisy." ) - temp_file <- tempfile(fileext = ".ged") - writeLines(gedcom_content, temp_file) - - # Call readGedcom.alpha with skinny = TRUE - df <- readGedcom.alpha(temp_file, verbose = TRUE, skinny = TRUE) - - # Check that FAMC and FAMS columns are removed - expect_false("FAMC" %in% colnames(df)) - expect_false("FAMS" %in% colnames(df)) - - # Clean up temporary file - unlink(temp_file) }) -test_that("processParents.alpha adds momID and dadID correctly", { - # Create a data frame for testing - df_temp <- data.frame( - id = c("I1", "I2", "I3"), - sex = c("M", "F", "M"), - FAMS = c("@F1@", "@F1@", NA), - FAMC = c(NA, NA, "@F1@"), - stringsAsFactors = FALSE - ) - - # Call processParents.alpha - df_temp <- processParents.alpha(df_temp, datasource = "gedcom") - # Check the structure of the data frame - expect_true("momID" %in% colnames(df_temp)) - expect_true("dadID" %in% colnames(df_temp)) +# read E:/Dropbox/Lab/Research/Projects/2024/BGMiscJoss/BGmisc_main/data-raw/Targaryen tree Dance.txt - # Check the contents of the data frame - expect_equal(df_temp$momID[1], NA_character_) - expect_equal(df_temp$dadID[1], NA_character_) - expect_equal(df_temp$momID[2], NA_character_) - expect_equal(df_temp$dadID[2], NA_character_) - expect_equal(df_temp$momID[3], "I2") - expect_equal(df_temp$dadID[3], "I1") - - # Create a more complex data frame for testing - df_temp <- data.frame( - id = c("I1", "I2", "I3", "I4", "I5"), - sex = c("M", "F", "M", "F", "M"), - FAMS = c("@F1@", "@F1@", "@F2@", "@F2@", "@F3@"), - FAMC = c(NA, NA, "@F1@", "@F1@", "@F2@"), - stringsAsFactors = FALSE - ) +# test_that("readWikifamilytree reads a file correctly", { +# Create a temporary WikiFamilyTree file for testing +# Example usage +# family_tree_file_path <- "data-raw/Targaryen tree Dance.txt" # system.file("extdata", "Targaryen tree Dance.txt", package = "BGmisc") - # Call processParents.alpha - df_temp <- processParents.alpha(df_temp, datasource = "gedcom") - - # Check the contents of the data frame - expect_equal(df_temp$momID[3], "I2") - expect_equal(df_temp$dadID[3], "I1") - expect_equal(df_temp$momID[4], "I2") - expect_equal(df_temp$dadID[4], "I1") - expect_equal(df_temp$momID[5], "I4") - expect_equal(df_temp$dadID[5], "I3") -}) - -test_that("if file does not exist, readGedcom.alpha throws an error", { - # Call readGedcom.alpha with a non-existent file - expect_error(readGedcom.alpha("nonexistent.ged")) -}) - -test_that("readGedcom.alpha parses death event correctly", { - # Test that a GEDCOM file with a death event is parsed correctly. - gedcom_content <- c( - "0 @I1@ INDI", - "1 NAME John /Doe/", - "1 SEX M", - "1 DEAT", - "2 DATE 31 DEC 2000", - "2 PLAC Lastplace", - "2 CAUS Old age", - "2 LATI 12.3456", - "2 LONG -65.4321" - ) - temp_file <- tempfile(fileext = ".ged") - writeLines(gedcom_content, temp_file) - - df <- readGedcom.alpha(temp_file, verbose = TRUE) - - expect_true("death_date" %in% colnames(df)) - expect_true("death_place" %in% colnames(df)) - expect_true("death_caus" %in% colnames(df)) - expect_true("death_lat" %in% colnames(df)) - expect_true("death_long" %in% colnames(df)) - - expect_equal(df$death_date[1], "31 DEC 2000") - expect_equal(df$death_place[1], "Lastplace") - expect_equal(df$death_caus[1], "Old age") - expect_equal(df$death_lat[1], "12.3456") - expect_equal(df$death_long[1], "-65.4321") - - unlink(temp_file) -}) - -test_that("readGedcom.alpha handles incomplete individual records gracefully", { - # Test that an individual record missing a NAME line is handled without error. - gedcom_content <- c( - "0 @I1@ INDI", - "1 SEX M" - # No NAME or BIRT information. - ) - temp_file <- tempfile(fileext = ".ged") - writeLines(gedcom_content, temp_file) - - df <- readGedcom.alpha(temp_file, verbose = TRUE) - - # Expect one record with missing name fields. - expect_equal(nrow(df), 1) - expect_true(is.null(df$name[1])) - - unlink(temp_file) -}) +# result <- readWikifamilytree(file_path=family_tree_file_path) +# }) From ff6947316bc14253ec2b2633904745f718058092 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 14 Apr 2025 20:07:02 -0400 Subject: [PATCH 41/69] rename --- R/readGedcom.R | 98 +++++++++--------- R/readGedcomlegacy.R | 2 +- data-raw/benchged.R | 31 ++++++ data/royal92.rda | Bin 69068 -> 67612 bytes man/applyTagMappings.Rd | 27 +++++ man/collapseNames.Rd | 3 + man/collapseNames.legacy.Rd | 17 +++ man/combine_columns.Rd | 8 +- man/countPatternRows.Rd | 10 +- man/countPatternRows.legacy.Rd | 18 ++++ man/extract_info.legacy.Rd | 20 ++++ man/initializeRecord.Rd | 17 +++ man/mapFAMC2parents.legacy.Rd | 21 ++++ man/mapFAMS2parents.Rd | 10 +- man/mapFAMS2parents.legacy.Rd | 18 ++++ man/parseIndividualBlock.Rd | 24 +++++ man/parseNameLine.Rd | 19 ++++ man/postProcessGedcom.Rd | 17 +-- man/postProcessGedcom.legacy.Rd | 34 ++++++ man/processEventLine.Rd | 27 +++++ man/processParents.Rd | 11 +- man/processParents.legacy.Rd | 18 ++++ man/process_tag.legacy.Rd | 35 +++++++ man/readGedcom.Rd | 1 - man/readGedcom.legacy.Rd | 78 ++++++++++++++ man/splitIndividuals.Rd | 20 ++++ ...dPedigrees_alpha.R => test-readWikiTree.R} | 0 27 files changed, 509 insertions(+), 75 deletions(-) create mode 100644 data-raw/benchged.R create mode 100644 man/applyTagMappings.Rd create mode 100644 man/collapseNames.legacy.Rd create mode 100644 man/countPatternRows.legacy.Rd create mode 100644 man/extract_info.legacy.Rd create mode 100644 man/initializeRecord.Rd create mode 100644 man/mapFAMC2parents.legacy.Rd create mode 100644 man/mapFAMS2parents.legacy.Rd create mode 100644 man/parseIndividualBlock.Rd create mode 100644 man/parseNameLine.Rd create mode 100644 man/postProcessGedcom.legacy.Rd create mode 100644 man/processEventLine.Rd create mode 100644 man/processParents.legacy.Rd create mode 100644 man/process_tag.legacy.Rd create mode 100644 man/readGedcom.legacy.Rd create mode 100644 man/splitIndividuals.Rd rename tests/testthat/{test-readPedigrees_alpha.R => test-readWikiTree.R} (100%) diff --git a/R/readGedcom.R b/R/readGedcom.R index 3cde78dc..109377e1 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -47,7 +47,7 @@ #' - `FAMC`: ID(s) of the family where the individual is a child #' - `FAMS`: ID(s) of the family where the individual is a spouse #' @export -readGedcom.alpha <- function(file_path, +readGedcom <- function(file_path, verbose = FALSE, add_parents = TRUE, remove_empty_cols = TRUE, @@ -67,7 +67,7 @@ readGedcom.alpha <- function(file_path, if (verbose) message("File is ", total_lines, " lines long") # Count pattern occurrences (pattern_rows remains used in subfunctions) - pattern_rows <- countPatternRows.alpha(data.frame(X1 = lines)) + pattern_rows <- countPatternRows(data.frame(X1 = lines)) # List of variables to initialize all_var_names <- unlist(list( @@ -85,10 +85,10 @@ readGedcom.alpha <- function(file_path, ), use.names = FALSE) # Split the file into blocks; each block corresponds to one individual. - blocks <- splitIndividuals.alpha(lines, verbose) + blocks <- splitIndividuals(lines, verbose) # Parse each individual block into a record (a named list) - records <- lapply(blocks, parseIndividualBlock.alpha, + records <- lapply(blocks, parseIndividualBlock, pattern_rows = pattern_rows, all_var_names = all_var_names, verbose = verbose) @@ -110,7 +110,7 @@ readGedcom.alpha <- function(file_path, # Run post-processing if requested. if (post_process) { if (verbose) message("Post-processing data frame") - df_temp <- postProcessGedcom.alpha( + df_temp <- postProcessGedcom( df_temp = df_temp, remove_empty_cols = remove_empty_cols, combine_cols = combine_cols, @@ -132,7 +132,7 @@ readGedcom.alpha <- function(file_path, #' @param lines A character vector of lines from the GEDCOM file. #' @param verbose Logical indicating whether to output progress messages. #' @return A list of character vectors, each representing one individual. -splitIndividuals.alpha <- function(lines, verbose = FALSE) { +splitIndividuals <- function(lines, verbose = FALSE) { indi_idx <- grep("@ INDI", lines) if (length(indi_idx) == 0) return(list()) @@ -153,7 +153,7 @@ splitIndividuals.alpha <- function(lines, verbose = FALSE) { #' #' @param all_var_names A character vector of variable names. #' @return A named list representing an empty individual record. -initializeRecord.alpha <- function(all_var_names) { +initializeRecord <- function(all_var_names) { setNames(as.list(rep(NA_character_, length(all_var_names))), all_var_names) } @@ -167,8 +167,8 @@ initializeRecord.alpha <- function(all_var_names) { #' @param verbose Logical indicating whether to print progress messages. #' @return A named list representing the parsed record for the individual, or NULL if no ID is found. #' @keywords internal -parseIndividualBlock.alpha <- function(block, pattern_rows, all_var_names, verbose = FALSE) { - record <- initializeRecord.alpha(all_var_names) +parseIndividualBlock <- function(block, pattern_rows, all_var_names, verbose = FALSE) { + record <- initializeRecord(all_var_names) n_lines <- length(block) # Loop through the block by index so that we can look ahead for event details. @@ -185,19 +185,19 @@ parseIndividualBlock.alpha <- function(block, pattern_rows, all_var_names, verbo # Special processing for full name using " NAME" tag. if (grepl(" NAME", line) && pattern_rows$num_name_rows > 0) { - record <- parseNameLine.alpha(line, record) + record <- parseNameLine(line, record) i <- i + 1 next } # Process birth and death events by consuming multiple lines. if (grepl(" BIRT", line) && pattern_rows$num_birt_rows > 0) { - record <- processEventLine.alpha("birth", block, i, record, pattern_rows) + record <- processEventLine("birth", block, i, record, pattern_rows) i <- i + 1 # Skip further processing of this line. next } if (grepl(" DEAT", line) && pattern_rows$num_deat_rows > 0) { - record <- processEventLine.alpha("death", block, i, record, pattern_rows) + record <- processEventLine("death", block, i, record, pattern_rows) i <- i + 1 next } @@ -212,7 +212,7 @@ parseIndividualBlock.alpha <- function(block, pattern_rows, all_var_names, verbo list(tag = "NSFX", field = "name_nsfx", mode = "replace"), list(tag = "_MARNM", field = "name_marriedsurn", mode = "replace") ) - out <- applyTagMappings.alpha(line, record, pattern_rows, name_piece_mappings) + out <- applyTagMappings(line, record, pattern_rows, name_piece_mappings) if (out$matched) { record <- out$record i <- i + 1 next } @@ -234,7 +234,7 @@ parseIndividualBlock.alpha <- function(block, pattern_rows, all_var_names, verbo list(tag = "SSN", field = "attribute_ssn", mode = "replace"), list(tag = "TITL", field = "attribute_title", mode = "replace") ) - out <- applyTagMappings.alpha(line, record, pattern_rows, attribute_mappings) + out <- applyTagMappings(line, record, pattern_rows, attribute_mappings) if (out$matched) { record <- out$record i <- i + 1 next } @@ -246,7 +246,7 @@ parseIndividualBlock.alpha <- function(block, pattern_rows, all_var_names, verbo list(tag = "FAMS", field = "FAMS", mode = "append", extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)")) ) - out <- applyTagMappings.alpha(line, record, pattern_rows, relationship_mappings) + out <- applyTagMappings(line, record, pattern_rows, relationship_mappings) if (out$matched) { record <- out$record i <- i + 1 next } @@ -267,8 +267,8 @@ parseIndividualBlock.alpha <- function(block, pattern_rows, all_var_names, verbo #' @param line A character string containing the name line. #' @param record A named list representing the individual's record. #' @return The updated record with parsed name information. -parseNameLine.alpha <- function(line, record) { - record$name <- extract_info.alpha(line, "NAME") +parseNameLine <- function(line, record) { + record$name <- extract_info(line, "NAME") record$name_given <- stringr::str_extract(record$name, ".*(?= /)") record$name_surn <- stringr::str_extract(record$name, "(?<=/).*(?=/)") record$name <- stringr::str_squish(stringr::str_replace(record$name, "/", " ")) @@ -287,19 +287,19 @@ parseNameLine.alpha <- function(line, 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. -processEventLine.alpha <- function(event, block, i, record, pattern_rows) { +processEventLine <- function(event, block, i, record, pattern_rows) { n_lines <- length(block) if (event == "birth") { - if (i + 1 <= n_lines) record$birth_date <- extract_info.alpha(block[i+1], "DATE") - if (i + 2 <= n_lines) record$birth_place <- extract_info.alpha(block[i+2], "PLAC") - if (i + 4 <= n_lines) record$birth_lat <- extract_info.alpha(block[i+4], "LATI") - if (i + 5 <= n_lines) record$birth_long <- extract_info.alpha(block[i+5], "LONG") + if (i + 1 <= n_lines) record$birth_date <- extract_info(block[i+1], "DATE") + if (i + 2 <= n_lines) record$birth_place <- extract_info(block[i+2], "PLAC") + if (i + 4 <= n_lines) record$birth_lat <- extract_info(block[i+4], "LATI") + if (i + 5 <= n_lines) record$birth_long <- extract_info(block[i+5], "LONG") } else if (event == "death") { - if (i + 1 <= n_lines) record$death_date <- extract_info.alpha(block[i+1], "DATE") - if (i + 2 <= n_lines) record$death_place <- extract_info.alpha(block[i+2], "PLAC") - if (i + 3 <= n_lines) record$death_caus <- extract_info.alpha(block[i+3], "CAUS") - if (i + 4 <= n_lines) record$death_lat <- extract_info.alpha(block[i+4], "LATI") - if (i + 5 <= n_lines) record$death_long <- extract_info.alpha(block[i+5], "LONG") + if (i + 1 <= n_lines) record$death_date <- extract_info(block[i+1], "DATE") + if (i + 2 <= n_lines) record$death_place <- extract_info(block[i+2], "PLAC") + if (i + 3 <= n_lines) record$death_caus <- extract_info(block[i+3], "CAUS") + if (i + 4 <= n_lines) record$death_lat <- extract_info(block[i+4], "LATI") + if (i + 5 <= n_lines) record$death_long <- extract_info(block[i+5], "LONG") } return(record) } @@ -317,10 +317,10 @@ processEventLine.alpha <- function(event, block, i, record, pattern_rows) { #' - \code{mode}: either "replace" or "append", #' - \code{extractor}: (optional) a custom extraction function. #' @return A list with the updated record (\code{record}) and a logical flag (\code{matched}). -applyTagMappings.alpha <- function(line, record, pattern_rows, tag_mappings) { +applyTagMappings <- function(line, record, pattern_rows, tag_mappings) { for (mapping in tag_mappings) { extractor <- if (is.null(mapping$extractor)) NULL else mapping$extractor - result <- process_tag.alpha(mapping$tag, mapping$field, pattern_rows, line, record, + result <- process_tag(mapping$tag, mapping$field, pattern_rows, line, record, extractor = extractor, mode = mapping$mode) record <- result$vars if (result$matched) { @@ -338,7 +338,7 @@ applyTagMappings.alpha <- function(line, record, pattern_rows, tag_mappings) { #' @param type A character string representing the type of information to extract. #' @return A character string with the extracted information. #' @keywords internal -extract_info.alpha <- function(line, type) { +extract_info <- function(line, type) { stringr::str_squish(stringr::str_extract(line, paste0("(?<=", type, " ).+"))) } @@ -349,7 +349,7 @@ extract_info.alpha <- function(line, type) { #' #' @param file A data frame with a column \code{X1} containing GEDCOM lines. #' @return A list with counts of specific GEDCOM tag occurrences. -countPatternRows.alpha <- function(file) { +countPatternRows <- function(file) { pattern_counts <- sapply( c( "@ INDI", " NAME", " GIVN", " NPFX", " NICK", " SURN", " NSFX", " _MARNM", @@ -407,7 +407,7 @@ countPatternRows.alpha <- function(file) { #' @param vars The current list of variables to update. #' @return A list with updated `vars` and a `matched` flag. #' @keywords internal -process_tag.alpha <- function(tag, field_name, pattern_rows, line, vars, +process_tag <- function(tag, field_name, pattern_rows, line, vars, extractor = NULL, mode = "replace") { count_name <- paste0("num_", tolower(tag), "_rows") matched <- FALSE @@ -415,7 +415,7 @@ process_tag.alpha <- function(tag, field_name, pattern_rows, line, vars, pattern_rows[[count_name]] > 0 && grepl(paste0(" ", tag), line)) { value <- if (is.null(extractor)) { - extract_info.alpha(line, tag) + extract_info(line, tag) } else { extractor(line) } @@ -441,7 +441,7 @@ process_tag.alpha <- function(tag, field_name, pattern_rows, line, vars, #' @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.alpha <- function(df_temp, +postProcessGedcom <- function(df_temp, remove_empty_cols = TRUE, combine_cols = TRUE, add_parents = TRUE, @@ -449,10 +449,10 @@ postProcessGedcom.alpha <- function(df_temp, verbose = FALSE) { if (add_parents) { if (verbose) message("Processing parents") - df_temp <- processParents.alpha(df_temp, datasource = "gedcom") + df_temp <- processParents(df_temp, datasource = "gedcom") } if (combine_cols) { - df_temp <- collapseNames.alpha(verbose = verbose, df_temp = df_temp) + df_temp <- collapseNames(verbose = verbose, df_temp = df_temp) } if (remove_empty_cols) { if (verbose) message("Removing empty columns") @@ -474,7 +474,7 @@ postProcessGedcom.alpha <- function(df_temp, #' @param df_temp A data frame produced by \code{readGedcom()}. #' @param datasource Character string indicating the data source ("gedcom" or "wiki"). #' @return The updated data frame with parent IDs added. -processParents.alpha <- function(df_temp, datasource) { +processParents <- function(df_temp, datasource) { if (datasource == "gedcom") { required_cols <- c("FAMC", "sex", "FAMS") } else if (datasource == "wiki") { @@ -487,11 +487,11 @@ processParents.alpha <- function(df_temp, datasource) { warning("Missing necessary columns: ", paste(missing_cols, collapse = ", ")) return(df_temp) } - family_to_parents <- mapFAMS2parents.alpha(df_temp) + family_to_parents <- mapFAMS2parents(df_temp) if (is.null(family_to_parents) || length(family_to_parents) == 0) { return(df_temp) } - df_temp <- mapFAMC2parents.alpha(df_temp, family_to_parents) + df_temp <- mapFAMC2parents(df_temp, family_to_parents) return(df_temp) } @@ -502,7 +502,7 @@ processParents.alpha <- function(df_temp, datasource) { #' #' @param df_temp A data frame produced by \code{readGedcom()}. #' @return A list mapping family IDs to parent information. -mapFAMS2parents.alpha <- function(df_temp) { +mapFAMS2parents <- function(df_temp) { if (!all(c("FAMS", "sex") %in% colnames(df_temp))) { warning("The data frame does not contain the necessary columns (FAMS, sex)") return(NULL) @@ -541,7 +541,7 @@ mapFAMS2parents.alpha <- function(df_temp) { #' @param family_to_parents A list mapping family IDs to parent IDs. #' @return A data frame with added momID and dad_ID columns. #' @keywords internal -mapFAMC2parents.alpha <- function(df_temp, family_to_parents) { +mapFAMC2parents <- function(df_temp, family_to_parents) { df_temp$momID <- NA_character_ df_temp$dadID <- NA_character_ for (i in 1:nrow(df_temp)) { @@ -569,17 +569,17 @@ mapFAMC2parents.alpha <- function(df_temp, family_to_parents) { #' @inheritParams readGedcom #' @param df_temp A data frame containing the columns to be combined. #' @return A data frame with the combined columns. -collapseNames.alpha <- function(verbose, df_temp) { +collapseNames <- function(verbose, df_temp) { if (verbose) message("Combining Duplicate Columns") if (!all(is.na(df_temp$name_given_pieces)) | !all(is.na(df_temp$name_given))) { - result <- combine_columns.alpha(df_temp$name_given, df_temp$name_given_pieces) + result <- combine_columns(df_temp$name_given, df_temp$name_given_pieces) df_temp$name_given <- result$combined if (!result$retain_col2) df_temp$name_given_pieces <- NULL } if (!all(is.na(df_temp$name_surn_pieces)) | !all(is.na(df_temp$name_surn))) { - result <- combine_columns.alpha(df_temp$name_surn, df_temp$name_surn_pieces) + result <- combine_columns(df_temp$name_surn, df_temp$name_surn_pieces) df_temp$name_surn <- result$combined if (!result$retain_col2) df_temp$name_surn_pieces <- NULL } @@ -594,7 +594,7 @@ collapseNames.alpha <- function(verbose, df_temp) { #' @return A list with the combined column and a flag indicating if the second column should be retained. #' @keywords internal # Helper function to check for conflicts and merge columns -combine_columns.alpha <- function(col1, col2) { +combine_columns <- function(col1, col2) { col1_lower <- stringr::str_to_lower(col1) col2_lower <- stringr::str_to_lower(col2) conflicts <- !is.na(col1_lower) & !is.na(col2_lower) & col1_lower != col2_lower @@ -608,9 +608,9 @@ combine_columns.alpha <- function(col1, col2) { } # --- Exported Aliases --- -#' @rdname readGedcom.alpha +#' @rdname readGedcom #' @export -readGed.alpha <- readGedcom.alpha -#' @rdname readGedcom.alpha +readGed <- readGedcom +#' @rdname readGedcom #' @export -readgedcom.alpha <- readGedcom.alpha +readgedcom <- readGedcom diff --git a/R/readGedcomlegacy.R b/R/readGedcomlegacy.R index b8697908..e7e04a82 100644 --- a/R/readGedcomlegacy.R +++ b/R/readGedcomlegacy.R @@ -47,7 +47,7 @@ #' - `attribute_title`: Title of the individual #' - `FAMC`: ID(s) of the family where the individual is a child #' - `FAMS`: ID(s) of the family where the individual is a spouse -#' @internal +#' @keywords internal readGedcom.legacy <- function(file_path, verbose = FALSE, add_parents = TRUE, diff --git a/data-raw/benchged.R b/data-raw/benchged.R new file mode 100644 index 00000000..c0d0eef9 --- /dev/null +++ b/data-raw/benchged.R @@ -0,0 +1,31 @@ +library(microbenchmark) +library(Matrix) +# library(BGmisc) +# data("hazard") +library(tidyverse) + + + +# Run benchmarking for "loop" and "indexed" methods in ped2com() +benchmark_results <- microbenchmark( + reg = { + readGedcom("data-raw/royal92.ged") + }, + alpha = { + readGedcom.alpha("data-raw/royal92.ged") + }, + times = 5 # Run each method 100 times +) + +summary(benchmark_results) + +lm(benchmark_results$time ~ benchmark_results$expr) %>% + summary() +# Print benchmark results +print(benchmark_results) + +# Optional: Save results to CSV for later analysis +write.csv(summary(benchmark_results), + "benchmark_results.csv", + row.names = FALSE +) diff --git a/data/royal92.rda b/data/royal92.rda index 4a10b174c582e692825f6afe8e14ff1b069d9978..678261bd01b418c34dea9b0a8f61ed568ac576f1 100644 GIT binary patch literal 67612 zcmV(tKvQ&2UKVgRpfkl* zs)A-(1?mtq`wK1=P|2Vhnvh!g`SsYX4|fbsicZp6kJg_Fs9KxM*|3n!St4?ABQ zGOXX2>_XHrw%M=CH`Ek{MrR(DqDw%&()~Q3JW3eYe?D=Xr2$bJxqRaiBfPdsiJf%>0sk++1HQ@nuK%m-~Bwj%ohQqqA9!X8kacjQf z&RWSBfEO57e;WR6jpP96L*C&LMF3ME#u%vAz2#(l<(333V7N-)lH`y?t(J%9@yo4z z4NQFcs)K+pPp)3Q7t(y+p6a)Ht8DiMN@B!THRwQyD9vK}KnE4avDkZWabxU#8<`uI zgm$$x1Fzgq2@nu4ueSR6j$y%QUB&mQp{NRS*iRP!1ex@$m+vFHTRb$oH1N~~_(W9B1e~St5sZtJ zGSFM`2f0Mu4{wuJIr@qZ-EZDxfYmML!lJoTXw3`>ISJMma2n0~=`p#8mM)xUPby(- zao1Y%N44IvPZZL(A#7Th$!>%iVsD$=hWjT(8RM?f?*aouu;5oJX{5W24-ky+tLQx- z9ZPKNUjRx+xLAUrbI4NYCWl$mMji6dkGI8RCp@8|^FmZJg3egn|D-O62BMXW>+v$C zk1xnnnLwqX7SpQ_jQ|>12npb9?-YFfI zRK17DV%gE!{S4m8Gh&tpJDHj{fV@$`uycOSX;{9Y>x%uL2}^n^%82`4X-JvNrHaB! zSAa`+MqUi#mxpCyC5|wrpLR{)cp(c_2d{bayeKh}O*;j4{&CeRpKuE}C~rmA1e%~E z5(6uJwQ>AiOyhY7>VHYNLi!N{j#v^Qe5->QV39+~FbSdzdV+GT#-ljR-35yw->FbA zg<+b-{9<26Ybh{EbU0_0DEluFMhR7z9&%-=SFc?t`4c41Nf0+7mVaLjfX^_$Ic3S2 z8hGtilTF3*bf-r{v~N^L)j0zub74)*K=B0gk`QssSijzb< zo*?lGIHj?Sm0{kqW&VzB&Rf6Z7Y;{9dy06pCh=MtII>PXtk-evj1?y}Gg#cEe~6o# z!LLMG{IU1*OIzOHUelEZ3wWKTPe&?>$Q~%Ba{ca0AI5ej0c}1R*7{ZdCivy@th%aP55Yez`qWfB;=Sn@0^dMB z>^((wik=eQRxXu(&LA_6gwcOm>29Qks>U*oEK^`)@Z6HlORJ8Mfq~Za_-ub<5h_Uq z`k$HHUw2UCPSwxKb>Os|x$c_98OOBjDHxS&qM|14wUDaU3Y9_Z_^ijF3S!B>?ZqO%j6w z!ow8&Jf*K`wKq@0K#9Ntz90N>_&voBd#-ROes2Hjf2sFf7{=AGhy{MCkDQ zUZ;Jr%AV-ZB>*lsXzigabF!t;p+#!@^5*IQ%IF}=k2#uwbswxzGXNo!q_`Lp==;{) z2Py%!Hsov#xsd{?7Xruq{wY0m-_IaGpQxszfEHiboO z;146%Fo|)lt%fzuk=J+*_D34*@)ea}_rPF<`+EYW!ZsJL!vX7GSC6dMH}}?;&3_EE zI3K0G*n5nt&tCs-f-uVP7=E&=aq6S54WG2@w$!9jp+7-)gWIq>5^F>pmmilX-P!{#8zzj`#E!2!tAIbVN;w9V+) zhMGfIuO(%?2#>u8l~>SPC>vwGz$*Rq_VVNTF~sroo6w|!)xJm~9(YEixJ-QF^$7w# z%8FjS?hvy4o%c*-H0y8jLu{+5U+Y&(GlBkbecR5wJ`qWt7e{*ez~T%ae{>wf7&x|Z zPSQa}w?`2_?)wBs%B~4?&{{}%4-Jcm!nCem>B-==#Y5u@=XCKg)$JGk@WjvV)?(Gf z49yoDMI%Ey+^wU05qaIiJ6*oG2EkUOK0xFEH)SBhh3EwWTys-V3Nnr&Y(V%CRk2PO zVl%jmP%#eMlyPf9ojE+SAYq=fMB@l1**bkExUp&Tq_n%xQ>O!ajTtT^h(bsoOc@5!g;oDFe@LeIz@V9N?xT$BN(!B4Fr zJg%1;4+;zOPYiT zPi|q|r1nr<5Dw=1&y@(dJ)BrznkuX|3LxrkO%?w2G$e8|S9Rt86}{>xMg9wrse3YuD;a0jryH9i-i=@-v4S z8P__;t-62_*oDMhIHVIi!hxMRH_&tToXiIAFz+U7e7MWDTpN z;<(Jn*#pS=7S+f=BW_Pgc*RhGUYU)6i;G`Gs`NShkREM?l8Egq@0CXbD$3Eh82`;& z!(o#5^2B8x`A4(Ar5zd&bM2_f<&py_0YMW@WNIr4%z%L*Q+8@x)xOW^F4`!GGPbX} zhXHDEPL@=wWVKYG_mq*!&J+TPXG;1VD921)Xugb}q$qQ%u-cN|=HBRz*-fCKMJ*R=O%n&OY;WGb1wI99W&rvFLT{4c3dgipPxTbVw zC&fV0UpOyD@AQIx4gcix+I5WWoZ>4B3!ePgzVx%Q%5K@LxdoM;WB8t~k9cobzwTY| zP}e=t2-BKZFGdJ8kZs=a(T>|v&O}NFEXvG<{0>Q6AI~Q_VKhJg-uugG3&_!f>Dx#{%0I5qrQlqR7{wo*J$sfO=*ywylsT23_eX}9hxY);9!##Wqw_yl~sqgv#hUV#zaigQK ztE^oMpL&R2e(x|ZMDVf+jxjV*2=|)+H1OU9bFJ*gBBulIKX^3$g1eJBMQnI>HQVNg z0{oA*Nb!|3Ne>`vN$H-S`s!TX@8gq#8SomxvkvA*CBORQ=)j7u{V|8ICU(tdv4E@! z+gD?a`#tcpd=35zl!1gvFX^7Q_~0*)U8a?>=5&nE`liY%J6mOp&jjN&a9IU8qvU#$ zZlCLpc$^vMfGeW)%7;L4TCqtQDrh>5onrlwp)?c!+OvCFHOL*35FVg9*kF1FtY{{x zVw0;`MCjNo!G$hUK3Wk>F-w)Ng@cJov~4oMOgg?yXIb)<-*4-a&K%4%HEQ!7QaE^-H$Cy0%U?v3php7zG7IC8U z)Ha0bB%>|!1Nw0c>q!e5g5L*6!7V#^Fckx3uIN&fLM1;^yj-?Ni)PzXA5B2Rp}adq z&|#mcS@ol=5Q{W5ANB_0I${QOdOgx~MVG%*AQ6E12)Gn32or#nVtzwgFfsnh6}<2F zSU{JuooRT&oa-q`e2_-)+j|oK0@;_Wo8};+1F;)MpDDSUCM*T@F0qrE8*RC->U4h% zari(o+-Ob8(Hl$GS*Fv64-c`TNWn!m5$3_$z=fK&dz<@>$EQ?Tk}D~dts9+GycdBF z67~b+*0}k7z2R(kStQc0OrZLTy;ResStq5w@kzgRAxAr(HZ?+J)!6AcT2`KHmP{Oo zbfGXrq^%nBohqv(w0@Q$*Uye&6UqmKiPcYYm+XaUy~zEoQUvcC#&}%FhFRw=DUI}H z49)zLV*d8}@=ZZYsU(nq;v zm71Q5_TO@l0qwVZc;LgfsbJ`L9!TT+$VtVHx4mkiCo#IMImYlA7BREorP%h){S|T@ zgsR%$Dh6W#SLXCUXE9k%KN#Z`!gXAvuFY6sE z9BH!b3eonY4FmIfMOckmE=|9%bdA@)7!DQKEl%t5RH@9z)V*2ZO+#N?TL7hT&{6fA zbeg;k;-*Xi4PU%b6SJT^A}mHa%DJog6~73U-_8KvfkL@z7_#ie-YQnhw}5yytyV0c z+kjk{@-SZk{cPBG)mGM{VX4!ht7{ny;$Jgh7LNCkF6gq+ibi0CfKL`Y&nS8pad5)w zuXil0{YW#}{RNbS9OQ`vE%j{0SF5Xppv`{E0sCt*jA?xV!7w_)yrNVn$~x>P<$c=E zJwNJDC!-{nGaH9R#T*zX<&fRn7)eeSlitdZV*5=BF^zUx6i09Ne5cbHC+9A!*t%VZ zH1F-r!7#pD_w>skFyrD4`CLT*o!?^B9ZCx-tF8date7W6EiSOc%*yX$FN-(ObJVFD zYYo5~8BNL8=(ngFALTrU&6t>&yCLU5hTaTv@@iNrx_|g7ggQ3E=#EkUz)Q?`9`u7&geL&PgWFdqCEWI-SLo&dzd+L>fApN2CJXwd~*6WYi)qaVRU z4ZyvFv6VEs%OYE%It$ac+Y?YSiH{M)s=)^?J7L{@*g0Wmx$3EBV`O!}f+=t_w@R^_ z>bBMW+~9n8?~fkst{OCq=nl3hd&V!{7QYa7whD*_CEuM3VS#euzL~=9#6rFH6sy3q|F5THHl8Bgu)Ks4@5uza+4Pa-5wR z&A>Pi<4`tmP8f0~bCNE4s$t3|8u-X8XNNf-NHw1MD%lKShw%xkL!FXJ!@ZAy@H*>3 zHi%J1R=Xc}maC-EEflISU}x!^f^IXmcwwHkuO%J8RwQ#K&(V`(AvljIR-o^gU&?tu zZBvumb3xCaYT->#J34{5kylLCy(Q1;PQz*TUzR$*HE}GoKO|tn>Xjb!6R1yCt1r}) zs|z;r|7Bw0^~Udka2E>d9zdBYr!qCf^$_OF3SfvE$*hnaG_98vo*_i)@0nHENgn5- zPCjmnXK`|2bxDt>HT5Bb#BkzhN{GBOa`6mJJKBe>h(ajVJrkG11`Eva1k)%Nvbn-< zG)hD1!H=VdcM1MrCrptXu>=4-DeC>~MVBz7WnZW4vEfAUqn3hcZ+qh_8GSj)@o;d> z42HsyOh{W5P7k(PLAXetK`RX1*psnw`TN%|mMDSuX@a?!gz zf3dgMb^=AL`TR)4pScd4{V21@Q?)IVl*-eF3vO}~Zbiz{zBGJx3$f4i+HbWI`*E{b zRY>G7ROWxeyqjS8on<}KR#iz|2alKRPhkscRI<){2fotsd|9{SQ(51pyP$INNJXX8 z<8iC^HF-&gF+Y%R85#Rlp4#icpYzZ(Bhux*6>C>O(_r8pEQ26fPg3t|HOfD}MwWf_ zSE&Oyc)NlSA1Q^~%IQcdF=$HBX^teo-@$Db93avsFmR9^S|F6%GxE#Y3^c4^Jy|YNQFkDF0 zDY->^;587m=x#3ywJ-N!b(eSO=qo4@=OewT`Y04QwNC(AUg^KA`=5_y-D5FhHOnm3 zVBnoJq{zf%>A6v^#-dOoBjcY@eo|Yg;AD-68xLordB<1A8#0R);X3(ndq6y6$I7;-8TyS!%c&kpZ<6@7Ijy%^25;uT=S`+&G;^lNy@T)C;%MjI7 zr@yUfUZx$Sr_Z=wg76>CO%vaf&o;9M_h23biYifqx8}CziY|$xR>NA?u5bhg8n|Nk zL&b28T1-wD7z zML5{xiz8-;44YZnX^jQ{kB(8))&ou!K*4DqW|0Dwd-gT=EnRtVZ|w%9%j3xd4`ML+ zJiJM@rWY?Op&uC9W@99%=p*FT5yD{xNsH^C|IAy?OK(%v$|sa?ure!M1u1JZ)hIyE z8i~|$i!KSf^FMoz5kD<#3kxd^e<`~XF~J~5-;(kfazYv);6_=UEKXdNV1Y7}L>Glb z`0w7#)$Op6-UaJvT~M+M8{0xevNB*3x2yhhTV_70h5tu~2>1sg840^v=J#aK7gz4E zNxl`5?#CkRe@~`c6G8)WpKdVNIxbcYwB|p>2B1yX#be^pp*zyzmQ2DY^{8xKEorbn z>N~Q@q4oQ4)WFgQ6$T;0t3+NV2Yd?7WECMWT#4V~Em8?oTp3A7409f6$< zQt%6yWT^`B+PU$W5&A7{Pu(|!VshtA~7m|6Vs&D*bhG|X5N5k*YFNpK3WihZ%i;JazOz@-e=JXu-i+} zL>`;084GJC*L6aOn0-3|e&FVXmu_Z2(o=H5Ni%1AR^Xy<>>zo^rs#f|QBlKW{sDn! zIL;7T=Sp)cQ)xzSy?h)08f++#CR827tmg1kd~2llOMS_>hWpb{Kl5d{GMFt0wUTqQ z^Jy!tmUtj-oq-d^zm+vEwut#<^%YdLsf%79P~AJQX*%;HA7*GH%zmErV{aO69rj&d zE||$WXf~R=_lT)9<+19b9|JilrqI%aQ2$qwm2`ZKK`r+zZ;lHTXVOD zx{||aJPF@7J~t}#V%=lEqpDDWf(L-|bc4P1srUsa6H$8;-#hUGLD?wsI#a7n)~3kv zjPXyrkCQL`!}Fe>k45gkc&gX?Xdj(}=go;Bm~N#mtGX+Jy7&ISpx*>QuT%C0i}zpZ z!mzK~WN1NlE-LHvlK))J?_=rG=2keLY}+SGHt!YB_qr>jj~#?kgXGNmz8s>38j<7C zl(hh!vB)B*{787P1B#E%;U_t|D5x=L!ha6M(UIFy0+-sXz4tCoY!fB|HA{RF{Ao*v z|HXLjbjut&v_}&!W&Yh9v)+g-7^UJCnjqYtW>w+usUC{00Qma(g#rjqR}XpKHcPaU8AHTa{HlK4 zdAYucqiB2*U%ia59jdE$ByC*6uqv~W6vS|8252)}=hG_3xhV4beI;W=>TS={^ieu>o^(xZxt<4I(z_BcIm%vZcSa zfC9!by@|+~s>7NUa@`qu@gJPyK%M*_J;^JhVVL5Mkb&R}qE0}sPj-ZXZW3Xpf#atr z{$UmtG}f$DpOn>WR#AXGcBZdb2YaHp6Nfg~M!-d3(2;x>p&`EPZEn6Cxw*sMi~35e zIY-=gdtIQ-ZcI&*EY2`y1qd?yhO6Db&aquH>Yp|zFA0rnLw&YzH6Z~0@ni=NcI8(w z!0Fz5G>=^|Vq%wpuMjH83>M=JO6;U57ZI@JMv@WL*C$*E#WS@Zfg=EvW}a6)h=+%o zrtbb2ACm&?G%-=hnfi>vN7v<&WIpbXDb0KpSaQFYv198=0LA~tsQyFDCqNv_`UFQN zF7RXz^U4k$_UcIVhx;?SBG<@IfbWXCUX{k@$ze#<YpD%N^4Ea@P&=$YY zMhohC>dm;awlB2b8qoXpSEVHG4d8yj9C?xR^QTN_nct*R`NZY=6JW|jBGlZCGFv2Au zVI_34?PL?-!hG?)=OwHV)DwT~1p}g40rkk{+`6P+DV8ZzDo^JM8`gP=WjZLPf{Ugt z7jim88eIR5`~Ji`?6PV<70n2loLGbGo0g5jgP0>ydo}YhfuMc)2 z?PRfZ%uMF21&`Y)F%ykJb{ad-hNu$<5_qpsA9Me*8?PsUe)HO5w)o+?t!+_@jVtzI zNjjqiBjz01(-}SYXjLRGvn`&RgnYxH+%&J!{U__zu?*x7gBp*gZ#0!pVD&9&^x$4u z%und;@=6v@T~XEBVQH%hsR4$#e)%HmzrJee z3st7PNy%Rc{YkOOGcA3^wkL;u!AY-atCwNANBOg1p^Y=iLZbQAeWfc22R)c0=@?F@ zTklgJ)E~MPmg>a`DWL|8R3!%nGOcNoBJN6JIL{IUeIPc1-}#W|BQwfvPReLZF>|n= zv4E^RmB_mSSvux2@x)-4pN4LfSE97bpU14=fn$4pfWA24;b6z}ndqNoXOPbAaj6`U zybH1FI3)g~kH^2I(dXme>?)(ke8VFCf;NK27M#XW9j3(oDW#u-3BJ4q_Qmm!4OTVEWjW zdS)&8>hwjQwRM@EWI&w4fRwLCah};d9ryXP9n~nh7 zu@YvvqWsz4OnS?}%1gBMbNo;eAv>gL?rGl=exQoH=XtUY4qt->DxF|UVeUXt`zYQC z^HtnBvPYePt_T&8n<%N3#^A*#0I~tVkfR_d8^0_exlNkS9SA0hngl-M53*r{h!i|i z?BV!&+>^x!?mTUiiT|F->Jt&!N!5nZT^9nd`?Z8YArwI`C^70|sQQDbtiPjlwyy&1 z(|~qThBndyXKZSN-q01E#&Wyg*aG(P^~M{>68}*)5m|Mkau!G7MKwBl=t?Xg;l08^ zGluY}2U*7y#Ewr*SW9@t{~w`LlKK+z_8!Q#RS*-sStFZ^DI76Dh=8Iy$Lgx8&=ukg zq*VZ9krIXi=#i%dQ-bFp?&ODBIQE7Rg*SL8p6X-*`ot007f}?d!mStx)zEKWPX~lXj@d#LIJ|60!uMn>;4a zHM4g|z9IT1`Q$1GF%K@2q%J!Z$@!=h@dqrXdfn*hzMm+~ujisIrJC-V;bmN7yRrCo z|Ng&-IU0E<84v^;Gs36m+F=!&;${E{lZCc(iR)1DEy{_p)lIx#t1p0k(su+U14Ep1 zO<(tK-xWe4TO7MTtOYa30&w_86ug@|i)|3$9-iVa~ct{O@qzf2H; z@YxmRl~wIXuy5deg3TI(Tq0MV*n(j+99*a@;5Fq!kO(U7#qW|RXVtXfdxuIPcVoQcw5YDSZW7g(Q^70L~Iw5RHa$qXmXP{?{a$S zC=cj;*gDR@B&rpn0SfGv0;~#qvLTj9)U00>FoHeMKtDBRBy0|GgfZ5Es9EVp&i*7M zRGf38DT2^h%07x$yOk#Y0F0X(uQ7#v}{+V@^M}$;cSRw~E#+!p6-a*kL>F6(FSjtD25IU6Fn}L!5M5 zieB`luAxs7p6f%}e6F%heDV@beB`_-CKB_Qy6kfuQb7*DeBt1B4>)IChGpk)x4p?q zrbpZvS+79A62Ep3>JzKqrfy;;EuM#A^_W-k*PuoS4kjIxj0YxzHWMY3h+`*2%Asf>e0RLv$>o2k1th*j<40%e>h8yr9htn3Y#{`l^A^JXP z`}%AG2BS^&nd@xe0MG0l&Hv14oM)Lwh0hE$8yq>DQ^%%K2HSu=@xMWa*4b>r1Gxrd ziyZ~K0O3#FOv2K z(&KZ-IY2+QVTuCjFyGeBu*TZ72m;wet-j<^v(6`6<`gBgLaBCe=E@bM^#wcn^joJB zD`DZqueJ#^Y`UW`0sM*F=oKJ1=5>WSQ$OJU=QvbF$VUz~ZS9!#t!QRwHbbK;aI&!3 z%24DsTkF)$NJiY3h^YF*8%RJcaOK!`)YW--w!L8vhKGSn{@6$bA}n%-xam)&bB2jKmG$cW47XCu zJ@ym>F8x0HC*WM92(uZ$pnBjS*?~H7dNNLGJhl))pAqhdMloikDzLlO#X=hotQS{j zFnxNVBzzxS5m(L=FBQIvAy-P9{y{(#N_STWeG#&E_5hqa1p)Wv$<#^k$bR~%&a{AT zAJ->Y(Z2{jPi=8MfwS!=n|rsG_MK!of1O4{IJu$lizQgCvN=xQKn7&MVx=Jm=Eq8x z3Pq-Bp$u0K+2sh-sVDETOXLx4ROiT*&dfB{`a5_2gn9GF=MxYKIU$y{T!LUL4AQaG zoyyjk=n51v7hPm2MrSxyOhJ2xw+t#|Ft8bj>?EM-7dRdHs)H!2iD?*4HHNdE!tkbi z^!Uc5O-+07-;sDMa$gi5^iUQi>IfGMzEoH2RW z$NkmXFqZBcUarYYOe^M@VJiJ3H-IWrHwds+u(%zud8JHB4hBPLY!yTR6^_|6=p?&~ z`G(e*1Lv`JEruLJVxt^u6o}fqMbupLew;}K#5&e}_4bDDmA*+)kMK)07*#fS`?iy^ zVRq#DOTl5=hoX|!8!mKPK|3IS0UHyXkL^AyuE*kfh7)wc4iv0aWAa&5fQn(6b_=JL z#dYxUxM8H;AiwZ-DmHUKU&CP*x&>VO1eD7C63yieR{V1jNv4JDD_h6*ZT?u=p!47Q zja-jja(yv=wI&<+f8C{ON71`-3_x=x_7t}E^|)rX3JNVrj&pli-{}3$XQSl(a9sFc z+Ow}*FgjFp=?CZ5`_A*+y@7JOp2@sk7nLR<-^jkT)m#9W&zzv%varm@04$0IIdxg59 zId^9Sf?iue73($_1^k7{4F-CEVT!T^Ozx`gr`W6xQv=rFbe@lZ)h{ZkueSnb#lE$=FxYO z+g)mYuhXY(li8(8@T*B$Gz`eIlg1+2DIvv1f!%ph%UXZNlf-@YXmuV0-}%|;!WjfB zdz%+vdfiMg?))hU?}SS*yx9nBEw-H5B|Aokxbx;N2iSYn!O6Li&94kR`GoeGG}AeJ zqofka<|x7d%|kjmxlp{If3(QPvQjpOS3NizXZ;4P^U9)CaACPQ_jYLFTpa{fs zk>wFt#%C-b=c9>CCb0HOiBE}4O3nmZMZvT{H;YezV}!BLuH0aap(tYl3ns#~BQj;Z zZwrOL>U42~A|oQ55H<}?rQ0g4wliBV&IN>$ZU%N2hQnj>LT`9N$EDCnwR&gY!HgzB zKxAW&*Cxjvt3HumTLci9H8N+YaOaAL%BDIa0PNvW1Tbil1)?=#_7fgP77*tHmwr^EzsbWLwjUrg z1x=Uvs{UWGd^;`!WOimY30^9gfsNL5EiLlv|HUKpMNQ_x4CE$fSgvbb z-XI8CJ$KAjcSPUJr_1Ro6Fi;kX6ygp3(G4B(8&=sDe&3NUm({mso7A-*xEwy-Vb{3 zIk1U{Emozf|G9rgDl68lJ4N?TQ#YTZbjKx12&clCIQ*0d3oFB^?9YJXY985t=~r6& z%^Gp-iCWLXN1*i54S`+CQTl#spS3HI;U*BE1PT(QT&DyQzs=tqjrI2D?&Z1X<-#YC zmOi{SL{$_r18IhDc(|~9pgh0g?Nvo2V-Tr%i{}H$sV{ZYXylQMc3 z^cH2eo6T_gK6C6Il}j~+J=MR*9M>CV99LofXi$bwLHE!yfq4$h1sMbF7h`vX^4kdbo$<* zlrTC2rxg_SAR%_~(~d<{6i@*kMR&3J$k{S^9(%(IV1jdbjx*7VqaI*-8tkvqBm*4I zI-l|HWCnHHcULk&dmRUeO*{T1(z5MKGz>a|FvV9AM9c`}nDPg5*9?sreTqwPy=)kL z$bFY*B!uId@b9nP_4C4;7Z7;euo$YezP?L0kjBBwizCDRB3DdRL`ZcB+(kmh*)}TDP}`Et|a<2qE7vF zAwfdoXv?x#+7{G7L*YIV%+x=9VIqa16W|d*9Npo#CUNLNoze1;l8Gme#lpKb zEf}BGp54BjMA4JLx%{B1^1oLUB}8UaCN=nHr7x{c1hco0#e@<^BY$FaW&km%OlG$T z3+-WfF1{v*B~Ufhe3X9}8)>0-JY}U1-NBeM!;j2&dGR+_w1k2$y+MvNu;%8ryj4tb zztQH3*yXap5wifovUc%Q;JUZ6NK}quhj<=S!mGsVX!MKLjX2)DPo? zT3xV&r%&iqwo5fENljqF6o!Enwb|Uk^!(|MI6q>Eieh)-YE@=A>|Ldd zI22cwUAUK>NYc#n^pdXW9A=@#2x@*BJXGX;G; z@s!PHbqzIiT07Ck>b2mBoH6MWmtq7NAKG2Hn`^fg1t{N)p)Ax&4<&xO0SzoFA_zJnKv0q1-+n5W-NXIbn;kt~rB zkbHjQDhKeNQlqP=>=foD7#cw2TFZ2&cT07LuT_(p6?CTBbeDsfb2vnJf}og1r(a&C zM^$q=15?-@mZd748<01;`HK~V4UpZK`gK2{Uw&Wtzt;IfEWLxOc`#|VL5M~U7nTW@ zOXC@Ob>?C+b(c~@BSIheAxfwXm)n|c{A8fPm0E3}DpOqeBakAD@+-;Tx*7v=ElGTW z+=K?sM!S_DPM>e4K@N7HN+$9Nu5seJ@UiC;tnF#$L?y?PF9xvzo3Oh3$$mjH%Bb&e zFcONfCVQ|B8##0p(yUMZn(%G9ca>fBKmI(7{6t~ok)jvt!RV^9j3FeWB~9kzY`;=Q z?%0Nz=W|o-7YQ68*(Nybt)&1$!n{ww3kQv!snI>XPl|bp&aT9k70Pj6>%#=OXCiC) z&CDiYctOwT=z4_UoKTICSN&g|0*PU1;xjzi?Iix zwH4EnkYSZ&=a5k`O$G)9cFg)pBpy*AKDK>Zs{lA7oDN0oEby zg+)?UBxX`yP3|BjzqINb{1S2n{^Tb&=i3Pb2G%FBcsu-Hdo*F1TA1_hKPtw%25d124t;1yE#S1@aQeK1?P_}r&0Qlsc6qMTOgL^N?cxj-#j{$6ooJX>(7 zVIet7WJp5-#^$pS3HKiuv)6N90-S~Xxyy<}I@JlrdW&N%ED(h8aXO@f>;qDnztGPq zzsd8Nt}>&K=^opmyc6Pq7nDeD_9A1-QhSSq?X6~ICV+;}U(r?_D+vuXxL3TmjojDD zf|AW(aUv3Z7|a;6s^1nHKdK(#f^mxCxw%zaQrVSmB`~#imaPB3J}}us*NwvkW*-l| z1C5U(_80<9<$DBn$(16rsw4vef?6>GwGr&N1<721^xz9-n9Ukgcm4u@5bY-X=hU3gOhK+!DJqu?9L%z_bh}d zyu`UYl{ctC7xOrF#&79Oj2Al%Z?+X(r!MG+iAg;s2xATQFb+nD;N~b50d&GIUhs5I zd)sv?aWCkJ-*0K^0L5B1WoaL+PveaX6HcF+)@b+uJVd3+%5;^`M~G_8!=C?s`?<3e zC_`pk&RiqGRoA@ltw#xwm6+8r1qgWQ*gd*7d%;yz^C|RNFuSU|W2>~pV+`--#Bq_) z0AIAO_MlE0GwEO~0rgH)#=`@vexNuRYcR^@w<}KaqKb9`P2B=jPr1tb+fQx=xjZLFooV|6|Vm7 zjKc9EAe31tZ)meYKujw*+68&s(@aMYgN^Cp8|5G@v z(V1FCDs)m6mQi~TRJGvDmwCHF5sn9n^a&ZfG%T?GrT=vB?g8tSQ`EN27P>aa(`cB- z-7jPJf$cgna-kEjJew^$=T)dxK4tLNCYwG19=q^Uw?7vDdu(AD(|sx!CzxLMwPV!= z@M#-}$~Cnc)3z7=e-7QBaE|o?$N0J0RHq3K#P5270o5zNBh%@WWr1sM!5z@S+n+a+ zqUjmXl+*#5>yPRW@BDsCq8S%T3&XeY%x%#Vyp88v;u*zt93>bN=8@PywAtqEk7@lF z0jF|~$<7CPQA<%qFSRL!=mXEe4&JB~2vNY3#k=L-vzaZLY}%ZMfzr4yc6Ig;8`9q$ zwDP}p`a0D*2u!cN#wGV*hx0tL8%>)Tik}U@KjoL*_Bb(|=iuu4*YZjRrWMB9Hbr=X zvdvs4Jp3aQfz2QcC&~No8Sh`S8&A=|ij0R{P!;SXQ2zs9dA>giY%n(@ZFm&OCOxx( zFPb=qn;Q=-dCh?#kiXN0)-=ob?SErWEErV#OEJw}lLO2E49;UaAl-}nAR_0JLS0=; z)-Gx+LH=;^#**Auz<5ooOBnP)CzCnT^NdpQo14Nfk50K!NPH9a+`Nsi7bM?2pW7d; zc{x)g>oj{zByA6XQ^P8pVRB{BMRw=8fq{RHEq57XrD85~dj#AmgdZx?zK?7m#Wx_B zY-u*uSc%lnhZwvBB8`aoA^aORF_<^+?N^7F<|{!BeVheTA92ItsjMJoq^KlJw+oXP z{E_%sQ6@qog7c%5Q^ye7?r>c`wosXNt4wz9e;j5f;jSl4LL(cf!VM@r(2&Y<<#Lt! z*3fe+NY;3_O$YaG4={NFNH7IJXx_a}?d?oa1)IyidmGj>7UHtEFO4$|_%+8dWnP>| z1iuLP7s>p@T1GzXt;*O}`7P_%Vfxz17v!wHnSH`8YljBFnRWkL522uN)*p=mlpFgv zTVB)FBex5uYOzyACNR86IjWlTo=WvsIKqIY67b2dF;87IIP-l*Sw1i^+yLO>9tqzg z@ZR44LW@W4NBh`5|17dlJWDm8((Wy|cwP6rjzy?w?DkQZ)Z+Szc|l_pn+S}N{b;!F z+dLm1-p3Kkc+Cpb0E#oDW;1;vfr_efBwAuBmnKRpQrH^1L_WwfE*%A!G$GUO-Y3)p zc42OJj2}q?@ryIBs6861`_s5%r_9u^ptS`qkPy%Q5<}l~v=papX5o=3s|R>q%)F4s zY*R(}I2lR~4|*(>DE1{u(Tht4QS!F+L3QAKOmXCoeD%u{W^jf4z22Y_a@2* zS!%(SP6a%GEN1`cvXWvTEHV~N-ss3ufiKYsldaq=7I*K-W!Pg0Y#w_}T@=jy@L5?} zpV=+HV~}UgWxgxDU+Vkb6zdti?&RbZc}M3vCo?}buR-$mNK#4F=5l|+)~X1d0EsNf-xSEr zs@m+%w#j|YE8pmmQdDTa%M55jW?1C|(&9f^*J>?`^}2tILo?v}ZLMCN^1WD@*b2V* zt5&1Ll~~8RO8dN4+RuIMd}uH@suW;X6gsJo*4{KGbVAOLC;O?-4sFx6F3HH)72tU_ z&sgRFe3D`{T*NrBpmUH(F@>iG3Orx|B+C3@YisNgX$YIFGoF>SnmAe#k5D^53G)92 zawk3Oi?*WnJ#>lvt~(8MG0?}>I*WCO+RTv(FORs`tjm@@)<(j(? z*>&hJ2g1l4N)7*x7k6voxxB6BYgn!=mdK4i+MsRqpz#u*o;$`<7lCRzzaJTgU zRd#NO7za;uX66WYv2*58c+FfM((c}7&euzMu@EUBnM$5zOnCVGHEKu?9rJ{q#<@;$ z&=h@Piw^HF7O{4Br3wbs6Qo^nDDiM+!4!}~Q#1!=k4_7-`%DXjHLecFpEBeQ)-1R9 zF)zqN1ihoinD;zqN<7=jW6|t$g`cf=z ze~D)o6bFJh3LzW_W(W^tXDOvi6kS#@G~Nl_7Al$*7a)82LHpa!jR zwB-O+D6Q&;P9rTyPJ?#ag;-Wgh?&^_c;N{pzYMy@7dk34*-)Q!lkFia zxp`tTh$6=r@f*{T3j5LlTSZX|Ox>8gTnbq1nan)j%dsdZ5#+i*8gbhzPXtWB_FQ@1 zE#(6#m>Ape5Z8vzjWoG?9FO}Pt`(dc~blER`Fjaf^)2EqpKONmhb(7Sa6b$S#||K zVKv!vnpp2ucA^etyW3k1$Y=m3l)RRqULOR9!l^f?WGx-Mh2F^Mb1c~EP|<<7T`aHx zVf+qb=d{7xHAwwDA)I>4$>ElAy$_Zme+{XSC0MrNkZO_VElTT`C~{Xk<|8ci)d}Vy z{F^{E(qw_tGmvqGsFi$G*dR=jL~GCwdsiYlQrk_mIdO)y5qRurmk(VCz|FxJm;luU@ z{IYscoaAEiNuLOvdUK90kS< zKD5j2)o3duGt!w{_frtw-bssObqn$Hzl$5j{w7rflhV;InA0wlUmE z&!0_hgzvUAjCEedl~Eeb|O+4GXu}%Nw!;UvVS%Q;mv%P zvq{l+A98#)`)M?Ch!p}WGS?P@?Vdk+dH}$vglt!k_W79-ShI0NvaP1G6@C6<4a=(OLy+E((q%d6h$%{~55X;G`Q z^~~0^JSs67h1F_HWVejp^oXXW?^I{_bEc7eFOCT$3oB0$YEEVN7P9`OB#k~Eg+_-) z=qI!#S=L20Ema=j3um?3KseYp{QBT`>*A1D-iF|Kz^ME{?$~_HyFPR=9JR-1-u;8; zT`ItUB#h{_xVYQpwvZdKO-*0ezDl%hPm|EBN^vsA91gf|kzyV(BW(Jeotz-Dv4N$3 z7ml*8Pja|n?_{mHZmtT9K=V&9nd84c)(waBb6 zOO3BeOOC(2U2NU0QH^%`oTXR6D&a#uzoty#$yZHSv*;tmS}Y^xHfpHFz*cEp>&4wR z1Ui|9qnQRBZ^r7joE$SDO0&0ZB?yuvg>lRUZ;rYR{uVZpfEGKkr=_NRMEIFNtMqu4 z#oAyOt*(M=ucd165sds&XQ4hfhNSP4s2x|Lt~x86POe1=t~sW;fY|pfQRAk}^KHJh zQ(Q|m<$J8J0V5WExPVuW-@L;_Dv|tzk~>BuE1aeoI&=LMgA3WH;g(;1XrhuWEke*% zb;f$-oskP!VWlqM`ps_2`V!CeDsHDveszkQ_EVGlwnL?LKLe-nxi#t|Qx#KS<$%-N zx46qZcSc{K&A%2JORIysz~UpoyYqE5A5UR6NM%nr2#xdQ8b+N0{~jt=bq>Uj_Jx&k zSCm1AcvId5QbkME(&SSXFw6M?*beb*GQ|)$kky;q2it5h3Q#{M4R0$`fEq`s2={?b z(o{(5lCqg$C8$2guove^)NemnYc=bF2{KrdMIM$M4Kv~jLIb^L36tagX-Ag1s2B=; zx8BtfrODZCzW==?zBS+_NUYiAvM-1Qeh8~X&25`HC1PHoIPZz75@)7H*oZD(Edo4u z77-1{f{(<-SOC(1AvUvNp!yr#ekiCxgqp_t@l(sZ0%JN5m~5-BG~!0%9!~{s-{t|Y zU-Edqfs%)d0j|sM9_fnI%UI!uT?)( zQVOoMfG{N^C7=d;Pgr6RbqRJHyeGwcus71nMH8^K@2wSSd{A67QSJ)i7ni zHK10sE@85Q`n1@v5;uVq8z*B1)C?Bj4FH|HvM__z*oq zVs$VY4Nqrn-wyEGZS;CI6`Kvkf96OMecB4Pal6TbzFgn2MRMhlgKCn;JK5flU9izA z)X1R%7>~-xw&HZj_?A`})kCX6U3`zhW4R?y-z_xXuX84MFUMoJa5(h8M7o6bXanO| z&}q(MB+W)lK3jo_DHL6RI*t$6o(pDU13&V50Qe^R7yGoMQTYIH9(V*N1KnV>Lf0mG zRJ`vkI{`M&wgXUDgfGt4fuftebjTm>sM^g;R9Abj=yG+JkpLLRbpqMx*)OBnl;`!7 zVre}|$o^yvhTZZ>c6(jWoOMb87NcN!kd2GTnF;2ci!_p3{Bs=KR-1c9R-7DrdF_tM zE^k$)ku~L>b(~c<%AxZHtC%ObW_3yETsFiv&6tf89-4ZEvW}RmueY~{s{{#}2eWJe zw+Ii+!;VP;HR3v+!RTsT81>00Q>O+yXw|UyH1?60zvCRU=3l^R$he6JoXEt{q?YKg zp^=qmZ3e=$dTv~G^TCsL@PKlU8PH0zKq)huXNl~8k@g%2Ue=TDFny<~;2^dJPXLii zJt~m|J1bspjUn#cBH=_w1?D~VFnGUc6TLq{dPjxgz#LVSW-&_%?G6prI*BVZLW1vo z*=g4bkeuiS+Pw?~%m}bl1FOus)i^UbnL_P}n6l9!5QGz~L4uD&W_Z9qG=pP(yu4sp zI(!;S{LeJ=wqvWID2v-I1^Tu2iQ}DtPa_pk z;@}Q*djP{2UTJFWV)>ehWgT%Xr_*{rfm>_~WU#<|jn)o^SRqIehuLCh;TmDDN)v_C zx$)+sbN{1&cpDoSMH|y*X*AG)lZBh1_7F?0lf<-;H)}jT7t3N9PrVq|OoV33a#vPSujQbEVMww%4P2EGY)4ve>;9y+AVi9$?__DKoC~>(F$#gj78RZx-P(?D)*3u=g>0w5Dohq^?#$*CziZas}05V)kkznq#$DFk%V8noF zGeYRD;hkwz#UTHP8NzurF>XY-KG}%5hGYwv+>eOo5DUj4=>6Qq*ZP*sx?&K`_B>x& z%fhsfSTWr0A^c`NKnh3KNy5QizGk$LmuNNfOrDkw8f-RwV(Is5U^jsEO86kW_>x(f z{*?SoKJbK{D+thSj8jV+s=!7}Mt_LZ_S)JCfTzPH z3|zjX0$b{rYyo%9LaHV41rlS7>!2XPRB0AfeX26dhx7sCBt;}wQcgdrwDl!D0Pqkk zm&E*PM%Zn&BBF$WYPPP~DoZ?}6jIOZ!;Z4%z7|d15`&|}8R%m^=ssC^t)=8_EtMrE z-3mg(xAQ`zi70-&F~wUvKhLFw3}m5lsLzZ;>8`8!=9k)wHC}bPxH!y5+kv1s0-t)x zGk$?lug0~7<7$ZMRyeB%C~A~|Olih$xyqN(PR|7?%AqDIB4B(_LGzC;lFVDtvAOp} zGHOLnmJ|_&c}LF~WGO1r83D!daPKIt2FXL23L>x~3V;>Xs(Uqj-=4l6 z)-%o`us4($z1;7cGW~KcI_I9m+=?1YLPDquW2_qaKEeiS5OX|Y@xB+jL3|S z3x%HKn#d((gi|~I69$Rs4uv(6UChlgkL{1Ybh}f^gp;4R6*=k_!_-eR8oAnbX3xDq z$`;NJcbocZ>Q>&Lid3B{`E-{Ev)K3Belv%_Q&*wH7<&_?gB+~aq`(U*F-)Fz+J8<= zT5@O7gc*I_j-Fy6Gp$>x+~jL2?liJ%`)4J`zH;D=Rw)ZwTftMLTFjp?WAJGq|3ctBwUdb%FZ;F=W1KpwkRZ|-fd69f1y-~6IR8Td07K`u>QUeY}A z=W1G+s1v5Llp!vO)E>b=bKa5etUgkYH)*OZk@{?i-gxF-RZ8jLC=a{gB?#-Wo>r&D zPf_tiR%*pS2!gkU0C=Cs&+!OBVQlRIiGnPn}KJc9thd))!;mjCm|h`Yz!iJwQCbc zb_y0DvhF*x<&wSmlRVDV_4qq%&^CcFbwK}BofaCGk1GK)?KPgO&_^MMojRLS5!85fe^GbHl^-MznUn`|vKbmJN(}}Aw?#(42!=kHha8H4i z)})Y&M@-4i{EBe_s{2KrP6Y&(ihE)y#YwId1D++!!UKt_ak)t9)V23KMFyVTys4QHcHpijWg%Y zZeA+HeoE7cQz-Xn!T;V8S@y|yi5YdvS}-=6Xo{O58pl5n&*^iMHzuIl4?PcPq8i4- z+z3+e;ZVczV}20@w4QboCXc9#hgyV(bOApc_*<`dQ zc1SFe{VMsOLZq;{i2QVnvJFA1uyM%%*`B%&P{3VVdhI*wxn}0@x7s4nEg959+h(;q z3)su{84bqC;Fg8x9IT$uEQb~UiTa^*s1GxJXYD6;X7`o3lcPP?cmA*|mJWSV$tMSK z=vZ=InbZ?KT6vdfYvs;)t1^emN%F>!ZP-1wDSyEKc&-BZcr-G7Et(Yg0&Z!Fzm&-y z+5`m-1|I_yMnW}8X=#(S%w;neCQ*3WYg$BIIEngo(GXLg6%~oL?9CBCaghg~(=#Ww zS!FJhzuIEGQA$jXH&&=xy|!K;z*{9_QPjDA`rllqMNdkj*aC^CU4H~3vAOmrTwu|9 znn7fC)%O|;o@#b0L4bV|96l2p&cAL}CK>q7ko=dR`sT%mHM2(GM3_9VgDBHd%UdQC z-*r_Ju2cB53YSi7W!OBo#1183q75$9H_83h0=0?bc}tdARX8JUVWin6C@|4b7y)!< zX^32V=Km2L?Ne8%o`6wW>^66wZsw3vjH|5StldxF$Xb~Bhwc2GI`V+7u5R461#6s{ zyELI#A91#S3;5+CRw{2u#eQ~e`2)cKS}>4Dl?l*_^WlvRfi;#g@|G}EMY z{#fTrIMU^X#3Aj3v-v}IeaL7;=1u+_c%}MxnNqhk$dnqcK_BjAd}Od;uwvCl{}V^< zcr#D5WmSxbG^A9a0#q)7RI1N^wnoI%cgA60#H3>3S_zQY3J1gvJ=B~~{9>p}af(L! zK65{0JPcp9K($HHA_`8)^C*PT-SjWNmK(f8N~?yPE2Wg_kD2|W-(z_XDTCFy z8{LgpHn}GB2@Ezuhz5Zc8@j(f@9(QqxG{|nTYlzoP$z*3!Udw+RPi>Uo6iLBb_EE- z#>n^juP$DO8#f>1$$EhtaU6jCswJ_Fr-5YR6q$prDOx*dilDzU6-~g{kg7ycg5gWl z}$(YWA8JOt}b#8RHJb;O8?~qa(8fAAt^JVxx8r9W^@=@LW>QwNCq#hV zCPKp!Xvrqb6y?RAfWG4XFn^lJ1%J#56Q8<_P5_(8UcIj|!jT}>>m3Y2HY;4GS%L?N zYBVb{>5_Mjhwt6>ez)J}+b*&p91I)G?>yo5_9Y>rl-Uh*JDhSRab`MG6gIg4_7jIC zcr$JF&PiWn2FpVeXc24|N+Y;Q2ORM&!uvaDtjv0_P$k#ux<9vOka`0Ud(3gXe!RY3lg;L$~dgPcKs|5E%0#E2bBmG`QvrDqVRwm$NCqMV+CDxH{R>eKZ{lO_%lqn)Y6u?gAWHd zYSQY-hsEcMN}kT`$;F;3R`OXY5dt?IN;q-9)a#|NV}xgkx;`LXy71a|?)SNo)=8M2 ze!5lRP~Ae?a7vus!SqZiqy1&MsXMRB>F-R>{h{{LUWnmz>f7Y0F+#7$n8?taJN%^- z0{Uf=^4_0J7*{K!l@L20lgi4nva>?%HvK-rNN?5Pd=Yg7sQEG~6S*1zu>8SU320VS zo|l*3bp&qPM+7Pcl(L>&KMYz_=!czTyAYfjC$x0k4NtPmPi)=eE%t~70a9Cv0w%K& z(&MhD+Ka7+EZkt@4I8j!9v)gcwOa5j?|_{ROT6{8;f1gA-W}sBI_cw}E)6as!w$gY zL>1?Nr>m9`m$E9YX?p>1Hki zA_#IDdZ%K#3LT#&ohC3A5gt|5s4vZm?snlNJe z7(6m%EA(}ONg+-*Pq4(^E00{0Ocrfyf1kfv2xIny{F$>w))6Qqb!vVTz-xkUfDF<3 z;{K{jfbDgORC!NG%2g`YWG_ml{gN$)p^KDy3>lU9go#w7V?2irx?5egk?Xgqc$ekm z*_lp`^cUu69{S)Po^y8&WZXs0ORcWQkbGyzL40uvEZ~6jFgO*vbs9#?VDu@kwm z<$OocsN#+Q$)1pB87L4vYVr3rt~&x&ab(PCMC7B?6%~g8LAz<&>eO&Fl^>jDN7qx| zR%Gkq{!jfYvbfdKTHUf(HsYM;ZP*TXr@sA7fi{R8(&#`2YP1G>Du&-j({ltb=JF(U z6NDyS-NU6kfXs|C)8(*QFUA*4$3Rgqlu4Jxda+PYY$n+A(I1mcO0=Pitg?{8u+gby zc=MHFHRJwr*NdQ+=hO~@h&}*AY=J}_xf>rA-TRs}bu~^;RJi%cD)2l=PB~A+PC@*J ztiSJK0rWtGN%c@Jab-4x{<3f0eWYpq0|nbRoM@M)^QAAVsIDQNl7J5<@fb4 zKyWJ9&950dkq>y%4O0)}TI~Q_aR$kSmBC+;4&%QW2hGp)PXl9FBSyxO%CvE~d>)ue zXp4~N!AHvhUcN`9YHhYP13FX584VF`090j4Cu5E3LbeMLzs|*={7@+WEB1#LGt~tk zq;_8%EN^FO2deJU2`pR0d;6YzZ|;_B!~T?=*_h&D`)O1deXmAl_iiMqg}ZjR|6{+J z(e@!$6dcSnkU{xDfbx?i=J!em+qvOcAho=P`xOKtJ{E#}fUA8HJ18a%npQfQcv~$+N~5bvTY5RZJ=*OK-WgHl9v(h5Hf|iuuVxQx9uh3NdNP3IR@@AR zwFxD2QC&xTBVpEz^Tk{?`=E3Ms2i2(2Mw`zn=st=tH}OgLVxHbFGlcf!`_=-GntlE z=GPb#Eilv&jhP5)6YzW%)nCdYLRQ>(;C6~ixeK2$ZT0JY&svBOW4P{DP0R zK!CVvDjJw5no;Aw-V0>)9-Z5i2+AR!qwGdY$hnSfz_4n_h-0&_o@$r12|*k2 zt4g0)I`Puk+~-9e(lkc#_JYV4YTHq$`{sipid!)3jTN@4(19NHe|W;E3_0n+exk%F zDrd$7`P>hg zu=@oRvnXPG;kU^r1b^bz_70I&r-(3iFJ)d6=a(3Q7w$LClde_%s`h^>Z5w{oi%4P2 zkk7o<-I(y*uASm52fy|3rs@9bxlc7zLDLYCbmdggMAxFg&;Gkg#2o!AvE#w&M}HkOi=g1OYgcn0CgwN?XD&AvW2OP_ zM1-{JwqMT|YPpiTda-2*j881=?T6`|Zg1(Qg6!77*_sT^ShkKf6_$_w*gu_oh1h)#Kk3LC`0}k&TQL%5UIkTp$ ztgJrS)h+o08SBT#WHA*rRjguM-<(UXV@E?N%L@-R^V@3|nEX^TnPSiM=9d@9jvImDBtt5t9r0?~!xuQBI(ngoyFk7)ZLa3rE?oLRnt1#e z%Z3$Q(+j~e3fLj(xrBfXXqFTM0H~sMGr|nuaq2ijS3lYybVR=!_8@}q;R5A)WtM;w za8`0n*vHV**v^wuaUU`_8--g!>IR1L%#(Sc7U0=UHR#)j@Pl@2PO_)V9MUJ1O15Qv zaE}vke^stQx?fo{*B)(?H6^B+i7?mK+3*L~zbcw?P-Q+u|Gql^C5&{QOrBfc@lOA;!62zk?Hw zt@K0!*)AQGj(@QpY#=EiOC|5Ih(c1T((a;rf9pjr`tJB=f-q4%s-UyuS4bLH3|iBT zyZGrE z{0xV)Og_)eFq6!%CuJ`%xDJ4$Xj4-ZCEWC!kPY4IE&^YW+v2zHG1U@=6PdKGPP7J% zg|;|jg_GI;4o7#lN}OGRl#m6$yqr`o^z{tQ_SG5tcqJ0ACQhT&X&UwFmckub?q|m* z%U*w>T}&!!ECIzfD;VIfOZQvY{DjE1X?XnB$NO;pAbuy;RQHiMZoea zU3~>)dUSU)UfPywo~OB{5(*&{tIk#6ZhZ=Z%J&}@g%$(sdONaVH_l&AzhFf@zLL0i z@yTUjfiWm@>luRx4tF5Pc41o{Ep0T?w@vLm%L(ze(SQiLS*AV64NXN^9&0|^!y4hQ zi=kDhyi`WacK@r_Zg+d-Qt)a+GTvqS<7N%E}FrW9BNo)@Jo9C+TPx-ZBA)DKO^1lg?}=pM7S zU%2(rJftw7RB8O)1;W=%Pto4B3%fN{R(GJp0W^e3%faVjtO>;*z&tPV3HRV>Vm&Jo z3ZCb7M$7RV6?fxVdOEI&K#HI;kLz23?-@g?v}uYo^?+s`*U)(g>UzCTc-OGn{g4oS z>mko}`|VG>8ip5)If|P|Xm*TNuOQPV&BSTLiJ>5iX4)w;9};3Nb}-uWml4})K0g0k z9`ah^??f4;iQv141?#Redf*3tb*%0t>^@`R^C{g3EUbT~Q1u($7leRYAzI&fEG@Fm zuz2{mP(G?MzxvK8wljgnJ6L|U5|UZGTzBdhv*;f#7y=ALcA}Vr-tRW z+miYuWx?D?b4i??UW>VkqpMyze()S$>COX-2U^BzcUmkHmc(lG;J?qyx=bXGo?Zh& zpi*^Zjw&POSlIz~CX*8bfBRJ8@^(Kc{s3(M5{Fuy=zuZ{Okq_2aIxXD=7~N%4(cR0 zAiH3tPQWSv*TAr0`|DvVzO=)e4yeD`jNc*TAi_M)NaMWORRy7l8@)vqUQg2@i7QM@L z5FhD~sk2+)<^MlF2}a6d$Ju}0hWjRN6L*wy+O5?&*h=R?POfaPE<|d?W-8ufw-|qJ z=e_YmrBNZ|nlIb>Ck3`VjCA-k-w9p z&-;6hm*bD3c1yVh`inbNd%B|P{X{+h4C4aenRYcWy4=n)iM?#k1GQ4i*&AnN&~{86^btcmzdS4PJ6B{JyZl*-eAzoIe-@)M9BS45TYm z>jY~{joTB(h@0GjfbublkZl9B4RBvLn3|+!W>UU}xmXEOnZp3$;|W_M4vC-mim8A) z&4*7+lKoXCxdd0-Zt#A!oGf6f49Hs6^C0#`WZYTYI7l)(IY3und>hIXL-}ZVEx7dG z(bNb&qo;qyOBI<9^i}rc?d+}AY5C6|9hIc;spDqkKa^}z1V4RQ)WPo(Wo!yMmxUHo$352Rm64yotr4xAlDo)Xtc1?-AS_In-n zo)t#B$`qP&CF>^8Jjl^pe%8Pn%ApA$*$7gFgT$xnI&HBc1Zk6zs$@&DxCK)v`TxDW z@?-&6545$VZ+(ZCodUyL7ej}hJ^meL1!c-h7UxK$K|fCOymE|emX}N-Z_$Lig#}$v zvD0rP$|-U$X=Vx+09z?G&I(Z}A_Ek-d8Id7U2tfP9xATR_lA`HDQM1?S7F|ky4T-i z*tbwJ!y!B)XdM>qw+7WZ605{C%MWfgymfDJa)r3!gxwV_Fv0uzNLVGQW~9%Na{OBb zfbB2a-g1sv2)9;o)O{nlx|8mHK!6XlFLmc3%Uz4s{EB~_{36wW-7Fq=(~TtaN?4EM zED+yfuOe8l&D0BB5as7kgYsQEt$U>9?x;fsy+O)Rg6^;ArtL%_15q%3qiJxj@+FpC zk%yg&s$p@wzY&RJD>_5d$m>ZH^XpZ1&&Z~st^SYaY{{4Hevy8EP>@aI40)+s9%Ur^ z&yC;~c8+NtAttv?Y1OZI&z)ja&mj^C-Rq4$`2KwZrwhoTx$uztF6`QhVq$*(FT=L> ze}IF9z@2ejF{z*ggMmZ4wzX}=l7Y2*S6Gi9dm)}2C*BqGx42J?hT0PDx^r10U)a_Q zZid$bJq%`%vJzm`T6HC<%<^-SOh=JCag}X{Zm*@+;GjwEExNh255(6Q+gs1V@G>0# z2dlE?V`?3AtD8oVA0P@ya64WR&WH)^R3Z1fp6cWD_aq z_AiI{@G#ouH%UIVT7c6u2M-K@MV{wWTc z_75dP+q1Roj^(1c_AqaivavHmSYKf#(8mnkuqyA%goqmpe>9OUd~PGiqO#44Di6v^ z2byTpB_cHs5^`UrNIF#!Qm#*lY?sRcdI-M=&)4!=y$oju=CIeY0O*{6C17MQO>{m= za+r}%Hw5MB!iNyuq$1vUkec{Yt#ZbP^$)`(_tA|sCZ6hgFuiog=#qWx=r}1Z^7tvc z<)w-IWgD^iOBw_5J#OS#B1&i)1PhW_7euZ!!3Ah05H~iyoSZj)`2tr2WDwsrg&isF z{c>~M)y!svwzv`b(zYC=ANByPu-oSiqGaGl?~q3Vr#3GVrG#mDK3B*@?;7O&O?Diz zxWxj_LjnBN?h}ini!t|H&p=MO#X$TlZBx4Mv6F9)qC~lvyO0TDfLO)1h+225luYM z70;j-M4U}9nhZT%--Q)p1ND(a*#kFNfH?YE_o7zV-sXhi^ps{0a=4d7y6au*kETlA zX?k}_|K+)$P{sEnOEKviONk!MD99%Zz(@lkRYu&Iy`m5fh4c&BJNYUE+OGk6!&^5I z)Se)w%=$i|QS`3$cWg_BIn?Ee@P_d+rij|7erIv#;|0F=VsuI@QH@{fMM=5q2ChFy zRbJ%OS_>GlR)f5x*=HjorZ-$xy zKxDTPGziziMHTGL-|(KQMoye`3FtNj-IF;V>puR$DRLGcp(z@@bnS#X@QX~|MCDQA zV6V$h2*;mrn<#Jbx^Bx54D3o^PsR>^zjE3|B=htBRHQqNZ0Iq~NVMjbw1?2I#gl1Wc-Zp$}xZzKE@^VzY9C=sCW}Mm*2P)^3mw1}Q}yTpa^B4YKEvV0#|u_^-uz z!wwsa4yBjeJ8H;~1@6Q3dmpf&AuznI{oP7=PLb{-W zD_mX*f>?M*K=Mm%MF1-lDFz}*Uf%LpYH#fR5W^q*%Udb|k@t6IkYhdABosMR2x67- z^`GP%Wr#c~feOGWNfc~|0gYg#^B`i)M-N|>Va?<}bTS^du~2G7ir=_;f(QbzEL9LE zHfAQ_s)CN5xi>nB?=0u-;FW7w%mQ?)%AR-E{HErb zyd#jE@xXv2S&Ah#Lq=QWhSJPJh)}eO2l3QbPS`5ghvoSa&BjzDhsaoi0;=dceD;4a zL!8iw%NX8#em6X0Lc6T76`8_kbgzrEA$9&eh~MQlj|5XqSqU>)?+N{6800 zH@l+FK5R@$6-wHw%2(NDJ_Z`&&-G151JWI58tdmEHnR=B?9ds=TVT66+0<`#x`A?8 zo*cTB4l&X?(e`M|<;?jDO=rG-Ng!As-8Gen?`#MgYxU}z=HsL@GV(T~ZxrtxiJQ|q z#ay>jM%{7@xUMeTCpb&>%CiVhT#~$=U@fs^Y1yBHE`0AwZZuX0OuU|VHBxN6W_=6Rs|p{hD}nsKF#SLr{Ulb;l8| zvYus_CU+YCv_}GHN_4-WhF9-CTBg%J%#z*R0b%-xLv1`&t2o+=5Iu#X`)=D#*fx5) z`wpA{s?d#aH#@I>>nkkUG{4?i%Slv2DAl`U3k(TSSGo8f(-}kE?iCHI)Bu_0e3Q6; zlD~Myvi|M7wbO==z5S__V|BWYv4FgbYm03fMA;n$laAjhN+96$1c{&3AhtgJhSS07 zN53Gg4e8wNT_TZxW>5&KzYQZZ3MJg&#=ajZAayaAMCtOUNpBQKCAr!An zF>Q5+>$L?@bH54H3(p2bLX{Re_pmc3kGOSjMdHeciH`8GRNzNODG0I<# zbdkp~wQjPPNMdNl+2eN?#5m;>m?$+^qHYbqx|y6Kg&r|Fe-p~5LnOOz^f4!9UnoEe zATUpig5XZv<5$dUWd<~KOx3TAqH-HIy|q<`SvWC((;_g#wAcHa3i3I|CNFYx>=A#{ zx}%BNE&0*@=!^o9x)=nTFiD?8lhU&%XPjqr!+hODfgK$@$dlqqb>&dk7n z>2?pVvLH%$1|OeX#!|Q+Ul)QdU<8Oq4r|fDs)6??8aybxooH~}=e8s}I$S!POea*o zAeTIz0x+l?;_$)VJffj7L3A;BlwKG_@z!dC&KojWMG_y zAdOp z8#$f9Ye{=uHQKNgXgd4h@O#sy0RuNL@1|Z3UumsYEf~hTmN9-hIRB->1=|*#8BFW>dA9ELrsHumG&*!0Gj91I7@pk8ZtRB|EZrPtqu2if zGQ_t;??^3~O;$MLg27)#6%&g7t>|<$PmBCq)9zLDx24_hQpr}Uas2={%$-Fw@gKVo z;jBmD{$RbT63vr@Bb^$Lmz^~!QUc%AT(q+KGD>>z>4^pIlR-Iecp4>%i&GG7{EsPe zu#-yP$N8_uL8;(R93~E2Cs?9k%Z#9rrZkc9vrn;B^wJoGKZ?o2 z#Gt8RVLl|W9oNI0kkjuwS0ns9;st9az(K|r~KWDK$LWDw43BS{HpYA&ba z;gdrbS*#D**GNMwB5*D|>UhPb<)P4QWag;02#CCJX?$0|D>4(t*PhZEa0nc1(4mK` z@2gU1=Rai6;97cSu<_>36joKo@fB zFQSjoaQ7*U?JqOVOP2TdUav7v=xBh?Qk{^fE&w~9_nj_OaD`uhTekr_Y$hA7)K79| zhJsjXMU?&!qIqBo)&Rw$QWZ<*y-gWQpOZhgat9xCc~zB6B_)}1WiHRC3qg(Lkz zHP15&$JFohoQni(-VI6bp{5Wyi(=RA!N|ewdp?X$e2VaCJ;*%WF+%J^tfhkQ;sCFu zrFJN1UM#tQl}2arhKx7cqxoTUBf+E|!4bAZkxYl_3Lly+|Uie2?5<5y1nsLn5v4XCDJTL1J-a>o`o` z?s-EnJjc2TW!DiNBCWwMfSiW{oeLz-GXz&Kyiy&wnrE<6NRuxB@!~Et$mU12w%aoj z?#Cj3V=inGx24ms3trxlZc`t1xaAI=z98IQvAYT6MB^w;6TC-Np4}#i+YOCZvpV;N ze|Uzwq?`x<_b5DY4;i#Vi*+g<@^@Q8rL3yWGPJKZ9eHD5W+G0)xtArLL-zxw7?(g@ zw8Dts))JHt@hqYo$2z$aVnf5!PxWxZAg#AjK^OK8gdX+dX;GgVQdR6pn9AyTaZ;uY zC5pMaJHE8itT5vW<1^`_)98E6F;L@Hqom>ev{ZT&7 zd5Xu*)LeI{!*a#ZV4OPfHlptRprk~QR@s|-+ znB9MlA~+!f2e_59AX~K9Pl#PD76S$hS-ge*=$#7^4dqPG<2HOwdTG$eb6g%S-oKKu zNU7aDO9;1ftt>2Pl>CTQ;&e1-JRvht3)(Z4vW!G@V#?qNcyM7t)E|huw*m%y#}u^b zTq`Z`&}Rf8vFQU~F)OvGtTgr>3ZCl|hqI?5mI}}(dC-7LEM#&*DRbk)m8{r``aIUl zID(!H_0TP}Aqp)bwbDGCW5^dse+Ej`?ie-Nxq8iDcjdU=A3YKAF8vQ^qwwd0a&DuX zGO-d{seIyTN_ZZSxM4Qd|A#Zp$xnyykr;}D+mpZ4YhWpI4+@F;B3Roir)OumnC(BH z4uds}UK5L~&&1Y8oh6PiYx7_e>CbWu*dwj2}}hcwuorA(f2PiSZ73~ zs74d2Mmf(La?WGaPWx+Xm`z7*&kFg%)rnZPJz?gZ^0ITy03`v)5tYdiB0w8R;lrG- z#pA}MBgAqbm(*k`B@^d^&iQ2ug)>>}HZ$@N9@?dyqB9|2)dSAQzgafYJ63IojHq(J zj8EF8rp98GQDI3kcWFC>SI}419d_8#Be;olD6wz^hWck+FsHUgLb`@{$@E+z(7fbL zTm80K1qk{g?-6**?G(&l4E{&wCy?7NptCxzT-5KNI8X?1s}QFzbVoEzr8+b)+*O4xTM ztT|Bi2`v!;r8gR{Tx1>3k#Ikx*KCoY;Xk@}P+%x*pyU21F^beI(G7LjaJ$e(!;sbZ z`8s8QsH1Oyjfa%Xs;C#wwyG27uZCYSl7|Y!K`c$BD6{m8g%kgHvnb zrcIVLcb}%fqG3}^bVX!QJMrq>A&d!5ji3IV!g)+|{xvOj6ix^!kt&1&zUTU^BzH~* z?bwGqMr_-xCfbH%{JG&){B-OmIk=GWlpAqC8gg?6|EGg?V1v{EBQR5~lyc2zKY_4w z$TyeZSWb5bA2pJeB3GH_pOrMo*>f3l8hV;3Eo@zs`akN!I;38ebn`Clv+5A6ye$xf zFDhsLri(Lh0!LnK<$u-LA>ql_6Yywv>|)hP_W4!?b*-y87b_XvQ7jE|f{A2|2Uf~@ z+L(nJ{l1iF_e}#N;e%0LcE*0F#nqZAw3ug6?%oUj;7TIq@65^9wnZGA(vl5M$^MdP zxc24lmX)yCv6=tshz0TE5E^cPXJC0G=W7kIczJI)8HFS@<;muTf$#q>BnTZHWV|y1 zI1Rf)YYA3<$P+LstH1dYvcevcG?gBieRy0~RsYi@GhT836SmL0cZ>=Dc}`4Bw!wevRQrZH4GgxC7*c?q5m$1LV|Tk2tEQZ%N{)%ITq21 zjg&!IWk3FF7`_=DZiCwvr`)>f8N7%3AyfyHry*B8hkcTk|I^whe=#**n}jWxv2SKyA!y@N!|4$2kXQ%+H4gwkLnxR9B?}@!K2*3Tc+VNaqK2EEydhoc5>;z8G zh~SHEZKP;%8hqR>O4YgIr|wIzmFIZq?U3dhe=k$1ZB)5F8k8NDa%nsC|BV4$mvLi0 z3}-c|Hq&HHrle1C^hhVcQ5G-kJ;;+Z35&7nr&)%laa`N&5~jS6AipT)Y|9lTmyM&SMN z(Wn#kSR|^usV{Kma22@4t5wvKjVJh$O$lBj`5{Gg=$pN%lo^t>l#&%DlE6aBZ$Z9a zA)VbU3iz{8+2v&o0K>%+dhw#K-+E_^iHt4ziN(PZ>OslRysc6ZCmd2dOv{c7$qo@Sz{^uHdXjs zVG{>bZ|VD^%7{45%Vr??B#HI>7P{f^61o4gpCp{go1Jj8Qc|on3ev`Lk<*X%gb=%? z_JvF@_1ytstUeGa)_gmdo1i5j#96K851(AJS0mwbyulBO>$>no-ORui08v1$zk~Ny zOr9uy=B6G;|Not&Xdn*`nftY~6OPh9y64z2w95=r=Jk5%5-T?zSPNt#+2Hz!W%f5Sf|X^4godM9aTRbjAS}FJXbkz~!8q)< zT?3-j@-EEYM*T`;**`QMI)f0YhyK0Dlqx8JTRez%NwHS}b*LAo6 zq2i|}5oKQx5fMRc(k^vMC*$|dL0^Lh$;Wz_YSQ`{Jci8`q7|dkeLf7n&`nL&Fy<(5 zW&cB(GPryj`Tv`J3?y-|KOOYHQn|TNcDW&GiSm&o@s9Bu_)Wc!-I0w6UppEqF3;R z(wF#iCh!@ULR?Zs_BeC6q=1Mmky-#0%MA7-At<{rR2bhl#rWR4urN)~(l$bafMdna zKx2cGji>+u$FQ+vh6DvEDthg0tY@|Z-r{=Du(kG7J&hwSFE(4NIb)QQ`rKD zm7*9ToG=k+{+Ai2Mz}8_Iuqs}ZHIjVv1v|@|46GC)WGI9^`#>8t2I0SW%zAzDcq_a zIb84C5nW$4H?>?mnX#wZMn}gC@yyvjogQPRR}k}aVPp3tUj?rKV%en?VQxm%SEQD#dY%s@w8*a8v|ud(<^g9G8h(+Dm~Yok$wRc!{;=MPO~ua5xTDb1 z8%Pq`28$nn?i*wff3(^X2Bg0RFYT>A;1z4TO1dfOKDc2=QF0 z7lDRAe#i;lH^d1*kHUOy9j^5Sr1$xf;!rX1vTQtpNJWE|SsLJ(^tNK(xlk zbi}{2{-1bdA6ufL=2|DoadPJbt+zI|m!sN7s?RKBvAFt$-#h73!91-Rb<><4p?)9( zi~yMezF&=a7|1Iz+|zZ2YL5|EHuQ8k|MFLll>r+}k1;pfcX{!(V zh$~O^8mt=VK8U<$EUQkikKCj8O7)@siqy!?>~}2q@7`bm3ruF3F0A>eql_1oY#mj{ z6DS|==yFze3drY$cld9{*S!&Ea@0+J&C+)pzY5(Zc+wXt=6fq*(;2UNZNnG9@w&$K zDN+vPaFS47_CjRSH=Wf6Px$)(SP<0Kh*7iT?>#UkcJ9w;l2aih!Gb{xPVGlIujusn z&vD`yka7-Sh!X9(3_oOEt%Kfk*x48AQOmog4ge#q2kyjJxYV>&T<@ESYGF*{gup^K z68!B;aDfk7giPx;U^Tbaou6~SF_Dkn_gm-rfI7UFu+SXjS}c=maa1Bz} zt0m^LD7G&KFMwg;H!y0_MX*eq|3qZa1v@Fh zHl+P!87mUp-2?7&5vG<^K3>M2 zL9d4Ab7%**IM*i91Yvz7SMGj{Fq9Pb`0Z$QEB-- zbNq+YWlsj%WP-*CUV;IJ8n&pbIYQdKfWH-R;gA5Zi5MHfw-N>8kr_cw4r6Mpvxn&U zpsX40rz>QRvNK(?P+mqTS64o|)1ZNu3@X78bH3E?5lOGPE;bkSFab$M1?NO$`;t=;FyN5CB12i!W zlzr&Uh3k-$l5*}mq(b~8!#L+V;QFf8ID{TT&!vh%zD!fL5=u*Ru&UD<5qg$ZACGxv zHe>cO`geD4{tJ!Z0hvPt-<=R;;^I!Av$b3iqgog3CmxTPS2qlx<@0m|fW<^Cj~|jo z3z`Kh1wt~8wh-Z!B}jwol8IE*u{^Zgk@LN$xv!Xr$H$i`_CB8f4gs=JZssqwPne(a zGk|7f`Q0PB0sBEk1WxYDgqV<7oD3>c7<0(?AVu+v5jDYI*aVo|*TutmTthOU`6N{f ztZ;+sDHovt3to#haUv?r=7sEm%OleiS1Wh^XLs@FP_E=Sz9I%^PE#7-LEmn*#xkR) z-)S4e~0ylHIw9rj6t zz7Jq=_PXgDAFuvNO^NFV4r#RsVAEUqom@tl#jxA&e-$5Q z3o3w~Kx}hfuCaSvgulV%E#-N44DPH*INj6BkXmG*uiTnlBIr%R&;`Qr!j& zE10+PN8fIWy8YNLpwg`ZP9v_0;WI0<%PCyDTD)`l-E$R~--!z%m)dw;j^2Ekq*WNd z;GnJczjW+PKQFrHfclkrdah`QZF-OXv#l;TmgkTU?qAf9gkRInAYxX=#y@teA&YDG zV>H&Rb==tSFhSziwjFQBfPv}$4X}~}ue4U((mftfIz7NJS&!gJmwCLc;AKi^7o&cXTGq+DOvYayp@k_09N0rx2cvZX5)FK%R zGSCGbJBKly{lOHxy|h0ARR^Fc`0_TN%-o#VW*lWxwn1Y$fw|Kr{<(Z0GGGhrYXY!; zLR&D1H`yYpeVz7Zrs_9bY7lpfQK}_6f4Z8<+Z;Wwiq(LKy2o1hN#}p&z{~-!a@jC? zC@vGyZJMOlQAcWOekjvIh9ldiP^&|P(MIi0soxL4uP@YV+eFO9??Z-9kYoGnkbXVB zNhuaYW}c-H*2Fq{hmNKz%OaAS^~1Q!k)#Tc+q{mO;LFKS5;W;oj#9dY2iKFu!6-nX z$SGyp3H>c~;>e70X$e)dM~$~OAv3w6!^9&*V+Q4bBq3Qrvz0WEB2fbLiOqxPf;&OD zFy)C7B#^unYkZyT{H2~^j72oneR?ydLMcQd9%NOLkl<0)@@0^ zTO8A%c+0nl>>FCM^?A9y$0h1(YiRt@T^0N^kw3#$q>&*a;PmT|TgtcZ0?#mkceUYq zy0457#-gpgiT^S~LU3EhpKt}Z`S6CuZ&XrEX^O{rt&P<;HuI#QCsAsMWq?G~Od5gB zb&#KVbTJw6vN-|NJ^U%$OK2}7Pv0(=>za|XglA-|D%}51`d-(#sx%Ksjxr$+btC4~ z!b-oaS9cRL(Vm7uXO3R;h-R2L@W6M3^ZH(AIS$BlxyG{oM->0~PJrDGkZ?txdB%{2 z#1B*C?T;-5TMY;%ajZW@ngnIf0M*5h;u;%n+T0!%O7r=eKDSaGK_!xgO|DGVl?l8j zXA%lQFHBWwo_WMR`1RCH$&6G10H&EmjG5_bZuw+>rv_L{otATsGQAS zZlE1igRMOZ2>Mzr#^lPliy=P?Vd-haRW0YCA9e>t$iMcZR5$%Z6ZF;qUq4h_&|jN? zoU$Es8`H|aO;3a(OOg&eQ9F~BeBfRmpF9S4K$kj228WjXX!CK=1m?Wb5Y1>T+3vtR z3~uj|on^hA7-^W&MQ@*&rp8M(K6U*Aw-)!qzr~&$3asibHm&-W8!!;~2hcX65eq7# zz=t}DH+HXQVawTmng^>S{z{zQNawtllCbQIvZ485St==77&X%T`Mikm$h0sz99j{1 zGMXtnGXFj!5b0veK!#^;op zWEvz#Pwc0Knf;|xIFpUV{Mn0Rv_;-yPA<^cvcWb99QS}|%XqtTf zN!)KhfzOb=W%}?cg3*7yyoEELhQ&}u-9rlPwPY8LVE!yRvMvM$n(K6<;YHyj(NJOz2uF= z+SC?4CP0F%Go9HYl|-aWRUyy^9%h1Y76|9|h(Do79XCN;kUPF{TXdgR$y-5DLi|pi z35L=?5zv4hK@9=?G{_zm!He|tfI1~VW+o?|n$ciUAI*-(1HD{!K`QX`LT4P&?8LF4 za=K6J8)Ek`CW;OOMg}T^#-5mHwpPlWX-a$NzAs`h-mr@0cB6f+e8(~v6{Wa_s1o3N z*a2-h@NpQ|p8$i|20_3qs!u;BzlVzy6~AMnxocRO$V?M^?NM!V?X(v+bO!?xr9U{J zELF*{;-V@)$`cJ{O;>do3np@Q97eJEj2v8=%_H=U_6xq3PW~97+gspjxS+7P0%_4f{*r^FwKQy2g>@1UXQUv1k; zso$)Fp%_}3^3RaoY?*>3@u(FTo_L}ACczRZnv?yobg1T2H(;}sm7c!c#6=84iO%XF zJ(v*idIfZY41}hFq5)?=-yLW@3Nj{FI4M+WFQ0e}CH>o@$xs7ua9Gp&Mxm{9*NPay z`?kF5y2G1LRNkdB%_2hB94*LXU$MWGie|rp78x$n>0s}WLrZ?5n3e9 zjHA4JZ$Lj>ofn^wAc}xKP$)VNYHgd6ib&!wN6t_Qp9hGsl8W2xwIrYItr*=}N7z|D z4Gv9J@x(x_BYTleDIR=eS^dF|afqHckKHhDRNWYrn2)RLYjuAslze`qbTKskMVmT_ z0Uk}g4I4Y~0Id-Xn#vHfO1CoY|8r%^c8#5tGRunB6z>VHnF9KLa_w%E0t-{q*8PI) zJY6S<%Y(%2=8ugrY?Cii&vhiRC1zP5apT0_j4(#Z!*^v8&dmQ_IW#kS^?g`7#VCah zw3cWh84`K^lwH)1&huaag6#u-i@C45VC}utt6XFYFtC+_d8O}Y6Qd~Sv{?;lBNlOg zm!+QXXQvGVql(uI)>dc5{ZbBouG9COWS*~@T!UOxmI~SEOK43k2hx>St{VT}EOR?p z`9#u3RmbbpUA?EfUa$at74r6hfRc!zWRL_6+m5i1JfRO_M$t(pDF@!V$;%Jv^2j)? zSOrzP)VV^A5T?9jybm`&EL;%Pec|d2sC=au0o42`myag~J$#0DbxPmkG{tUA&7Z>B zs>D1L6+1|#wCpi18yd0~dVhj8eLFgXcLe%5eyYs?^pcsXG#m!vUdf|ClJ`~Wj;v*| zKQQkv%c@QO%YwRDm$k(I_gpzCGkthVlWWlC!&K2tfkLd<$eRfC*qXWk*C5?dgk)oG zdkHXzkTeybEui)VBCMhbYG<3PihR-vi@_~j>lYiTVH=7`k_%jp^+uGMrV@ejdt8s_ z(o#dIe4o)7<58=yJD(+lFT)9ukGy2irZQ+B4%URJP)dDwZ_0_jPBJ?!2`7US3c&{h zzM+Egl-{j-nx(?AoL65=8rN}D(kjHBZ4g?SS*t;;)B{P$0*|o@N-8td@v?ESFEk5^ z$;srnZ*MnX(bT#GAkMFlLV_dZR|INQ@ikv}&|~!hb(Na7!QAw9u^fLH0_2@$fz&rY zJsOtEb<>1)NT(?wO>&Faep{BGLe!a?k(w=EM6G@*5|}_eREPd&eW~?fzi2zOMf>M@ zS7@^_-50zpYFDys+J!*iRaFUnH?Ap7Eu#N-ME>Ev#zH-Zf_^?NKzME-R zwAW`+QWXRz!(y58Tg?}D-pauz%n8FV!v1cqEPK}tdVDSp1AsL$cLu-*DpU55Lhv9Y zqyaGzIB%Ol;f^X{nB+m^3@GFMQ?0P8*M%^^{!0-S19Cx?@cr|ZaiqXhiG|J25Amzt znKSX-zj4I1OoXTv5l3Rf^-di+WbdAuqX^37r?f>-Z&Mr+{IP~tN{dp)F7`pqI)I$A zgOwx6uPUY$501{?6sr!Jt37FuMOE}0Qw4q+N>uhpx{zTep5DdK6k(ALGKhX+FKp6L zx!lwZaVzm_Kv7X}pV_dmtrt*U+Ol@zeZW8@MC z6NJ0n|*aPO0-R?EUtcldJc0}8*L35QI70GOp@|W z8L#9p?wnK$6Xrj#LYN&BeRadgXy0M=*L`G@S7E|oF>!^kpEdW=8wP7KPsM$=q<)K( zEZWKIe4}wvF9MSmF-iJnzX}i-LNxeR3Q5+Qd#DY2GYB!`&0ODk#8VD9HJ5D;tmG*OrIiEdoeB*yLiXFY-gW7-B^1t1+mq z@gEa@1<+n7`}VxD3whU$fr?2MOO7e{bWi?uCRrKE+yNBWlPkWspD@Kfo_GH5eTiyN zbt|*f=G^N}5SbF|jc+Z95yR$}fQdoamk(2EST6_85A=G5<%4N#o21-GYAvKb7|IrS z9Dg?@J_CbUIkNN0!b+X@j>WmIp`2;mzcKDZ-JltFZR4u^ox&5`O0ddWq+LE z@0T=&sq%1KoKLj@EO)(^dL(4t%2>CqM-Al9jG4qI>DJ)BL)A=2|Q+ zpr8{p5G;@~eW4+~h^{_ur`>nYy_N%fknotFsot|jMNP2EU3KdUU~m9|7`&e2B?)bK z>RY*g#gw=P>27`h7Ak#r^5tfZLe3Vhl&I&!*4lwesAXZET6@I8nMiheb0 z`4Wotk>VPzZNcMg%51BLN}A3F)Ec~gu^EWtpctK1RSC@P9T@6(N~?%C3owL?D6Q_O z)q*$G#D5si)1-Li2trqjJ|VCx#^kinj>h{AvBh5GTyKGQ`7+1`V;;@x!H$~pgQ?zjj7b3&iIsu%P&aS!gJUj_ybhr+h_(t0W95I@ z4@NkYt8)B7l)}U!fCX)$wb8mmxA(>O7Y2-2(6c-r4EXx52}$pld?-D*SwVa&an!&< zN6*g~_(R_X8UfdRsWHHI@Iz`=<=%vv>Hu{~DtRQ-eu4o(t!%=Xz=FQqdqCobb8wKf zaGuuKOp#4?rKQuO+ct}Vd(3jgE>0QH3glV)eio~ik_i|o`nlzm1zjys%jDsP+@aZD zki>j{4us0-U+ed}?iJb(x!;5cW8iN)~9^fJE5(~iwVbAbZY)Kh!awv-rSNtUC zDro82%o?u3F-Bx0Vqco(<6`Q3?4vX(H1Q;Y!2hAn&uZmdh@=&5MPp&4 zYysPVU|{y@7S*)p-%VLLizO2b*D#`gO&Q72^+B9ctS1H0TA;n=9|is?(sR|V(InWh=3xxCtwNY zOWI({dy^I@mIm8EM>KSGO~tq zPGI<(Rzw&=fw8us8GsgK?y|7_ZOkYIg%0sPm($rGVjgnj$|iuxE(VIV_X zK!#HfQ~dR5a@l-GoXhUXkn`0{Md_Yyx~Od16G^m`!OBC?pw#^Ss~*t7k>^@C>YWYK z)niu<9JUQag#}q7*6{6|C1op`zmL4co&R&p{8Ww@tAb(*^@sSgkcf|jr!%gSiy;Dc zo5EaMBO>(F5#)%<1u0-&(|3-QG6hTY@J@{vkZTr&l%8t)#dknAb^m!gYav*1B(eTY zDC;P@^2`X0C!@K*M~(%@6D%(*FT!=XvUGx@8LoHSe_%4+5^`-@w{oaypbfE*f99P#27>-9yW+ z0LIkpv{XuVI|+SibkjZ6r{xLlzE!z{AXw_&CJoYlV&o=(59EqVRfSq~dTTF&RS}f- z=!BsJ16^ftKgBof)=S!Scp^o7Fc(+LZb>p{gd&O8YCIr<)P9 zhnBtI`!*%mTn8;-P}S&a4r_@)MFj8`JF|=v^N0*Uu@^(pYht`jy`*fWET0fnc=dX9x6LwdpeJOtvWF(#zk9Lts{;OUQx1Q1*Vm2@NSl4E<1+)Z`q7qLThB14fag(<@T$eB6QtWz z%rv3nF1^2NQ!i4S1l)fm2Lihir8!m9cQp-jwg~N)=l3}~7&(%egL4r(Kb0`_#7QKg z{_!TZI#xk@hbU699|Q3aUGilUXD=5gwQ_VRTJOtB2t6`V`DO|dcKD;Tjs)N{0*i@j zuRAq5zRH9OjTcL_+s;JrE>5?tWFuf#lQ_wG`d^|H*-1gk!*37+d{GzK&q@`3$JVM9 z%8}PZZi(5{KZCJ+yE>#Z;@3Ahp5Vd{MhAVh(%ToTT2RC8FXUT{XvAVG0sz7}=G;<~ zw)vZZEG8@c&~HGd-sd@xkms4T@ML{B4LQCQusBG#Kk>1!u;h_ z-8AC5Q$l@)l?o?L3=%6gHB`g8c9(t1*I}%gU_J{7$OQU?IO)dlP?XmKB+8=vg6Xerij;eBw+tO2*?k#MUh-Ja;1AJZ*mJ0Tog+#9L{52Mz8KM>fUT} z#yc2@0o!!OpL5UgHxMuStZb}P$a;dBV@G!KlYpvxz!_Oi$0E551@czGb|KQ(za3y48F(-GHgFSkZx;9s)=yy~BJT1cukcw9JX4 z%|Ksf{vLB9Jw;TJSA0Q+YZ8$Xtx5%>t`|282xr-?zq=0^f_S`0Oec+-gSlpc4_`S zbQ@C*6Sgs@X31%!xOL81BQ&-&z0cW3co6Pn9D{!MF7CvOV?HHi%ZZ{WG;6Md;a&Jx)Gc_p9WZt+{4jnvt?;(VysMhAl!psZ$5|A~}GQifK!PdWm_j&@=t;08r z6T9lZ(H;u=31P#b1w8oWUJc$0K=~l4TDVh`PrQc*tY|=)Wt7do-N{whl&e+40`f?+ zBS|`ytHWCC8Ot1ShcfGCu#Gqph&+W1%UkX=jSiSpwse`f9M7H120MR1t=P>L12X(WlvRCk-A z!4&$?4$v(PO{f=k0}C{KuHstV>hEz8iy|%&v_Nh zf!FX4tFbqRx=k}wex%(JL-Z62aMJBFxh5u76jyU*K*m}^*GgRJ?iUhQ5?uS!TQ)U* z-W6(_`)K7T)E4AiylhjE@wDX~8wh=i;veh9C6sZ%fx9Tw?zIh_Guk({18CH`Z5kA& z26-Hrt=+1D{^B=)V(@1=0qws7r4x2GUsv*mkbN@9%msjfugE{GSLtZpRe0y^uP2l< zX%7)KCJnzgb>|&dFYMd!rZz_Wr(h$owtM}*>OF+(L*y*>jB>rCFBL|GXJSf$5?dY5 zURw%-%(1Eq(yEV6;7Vz71-oPw-mWFMjTdJYPLerzn@<3KM1B2sAq4||0t+k7zGQ(8 z0qEK?#zLz2iZ4&+3G3#k#wDzM69?Do!#S0uTNDf5(MCLJKZbJICq4Ap@CFMij-Y3- z_xG{Lo*U$`Ub2H26H~vg8upIr-qz8O`j{+`mgHmsK|C!ZqEz8^r$C@UWYpP!`Y%Ax zlYz)bjS_U$>u7)lSis9#+KWHC7|L zCedAdt9az@o#01`gR2CwMEvv?)8F4)11<96AdMdkNv@paYtgoC58p33ruCs&y$=HF@Cp>AFj3L=W zq~XWe{&L8uC)3Vo^rkT&$b0*)Y4>Q}IjNt?XipL2-b04=lya_wC27@-dVP#4M^+iA zSKWKRW#<0LwQ^mzj|nQRl^K<`!PILw*Eb6mAfTIk!RpLa8!z+yV_uJKy(3yr`zU1 zDUaC~t6jxd1W}B`59E-PcweLgKD{5L8&`^9=bpcfBtxM4SGgo6-OF-n2 z4bMJyXxJgHF+Y$p`3bTP(;4{neTEYufHbh*`Qb!j2_yJ&+Hy2bc!he0CLJoAGV9{q zqBNnA1b@c+&N!HOQdEu<2mVykdA8y1UORuD!5D2@aP_p7kgrOjxb73*qF&SEob&&Y z^zWvyggX3QZdsM4ecbY zHdqAv#l2U=WT*j$;zCMrJ15dngAMvKO^T(Hi=y8=JBCuD(Vd6cp5v^m6`sowBVD4W zl6#I%v<2G}Sd~7m$*O3Ff#jTI6+?!sXVZzuC=C8YEps_P3o1GZ`VsQseYTpVt=oHk z$7{arMDD)ub$ZJrK~<8z91$Q%+4o2khy38Aa%#f!p}yG*D`n=OlO(#JKa%-9=YVJ^ zS81c9(qn4MCV$r4!xU0Q5$pp5ZVJj1pQSA9ALHme(~s^}Hu6orN0FWgTUc-((epvPeT zu;i=K+rvdj3}u0ymh1Hfqq=X;D!S#QQ$MK07n=ny@s-m4wGQ<#?lC@Y%y-LqA=AjXHDzHZ46**9z9i{M_&Y+Rws@~;BfHzc(Q-lXq@ZC%S}Dyt0CO=5_HUhc|O z*0u8KTp9tahClV^T%l43Akj20gX!w3Di#+_YXIKhM?;JnJ#G0`^l^CL5s6y&00Ai( z6wJ@B;d}pHa}jC%o1+kpU4W01``rC#u<-DiFh=_xBI_6^{bBM&)$d!27TryUO=LnT zQm2m^cZ3P2lMo{ihrP1cKW}}LfH9MQfFk3%|5A|kQh6$N4Le72ybxRAOVLZ!*bqie zS~1BQy0!+_B?ARjh@65Wv$FA)2-yAfKmM6cKUU_yOW^;7;JF*~8oU@-vaM?!iG}!6 zeyAz<88g{o)Z=gHHO0A7GzSyFH0&y*k#h-ICOdn)@IbwBpWPN?N2%oz^<{E2!qWF` zUE_j^aGUYF)GxV?UGSs?MNKZxPyHUHIKsN=9(^~j`pFuin!6fed!wX;`gi@~ROB7Y zy1E;ByD!#T^gRE*S@)7d1efRaW|199fzP`HNP4k%`nW$8Z-#{}M6nOoJ@;m-y4HHN zrl^c@o@Sh)D{do}9UzCm3{rnzb7;Z{r9Kmh^iEmv>nHLZ#n{rLHS=>jUHyZ5Lrf&` z;$AT%OJYQ>(|Vn#1SkJi#{}98C&*ZSNt^mkXOrq=bSjH6eoJNLV}GF3bEKTWkde64zM&*vb=DvlLt2Smcz-IumEI}} z(5yFGhsXvRsZ(_pbUSoe|JV~atP_$03%sF?A+Fn?>QQm4s@bM!bv*9-aSr5@>ypW% z-jw05RTK@S@y+CtVm7^;_W_}5<&V3!dUD+>$tSfEa?ewbdTKr-@G#F?Fp(H0oqbWI zReDN*G%SumS|v9AS+^|~n-QOl8kx-<*NA1r#PO_rSw)g%1FY$^$D3zq9Q|OO^fSRP79nh+>qc{9rfSkHADeet84)0sj-%-Zo1?+0sP@SQkB+0-sSz zw`>l89plu3l==6C?)EjAO2HBFgV2{_aK0f zs$3aw1p|icefN8t-nhJU8qEh4^adEjlXW)KqaJ7p*x`AC$)#HV2S=B~RXZrguDv=6 zpx#+$#e@aFh z23N6{i*qqIcy_6rvMgwD>vQErtO6!#=WfoMLJRa;KE`WUxvEk}3LMkj`;OzZ9q2@5Uc|Cj?NiRN!x}5l) zq;;%L*l1LoXc4xRiSBFI9?GHY7%8J6H2AlHOs6M(Bq@ zyn$D`Z$Vpa3p?yQl!Ss}eGaTxn6c4fsjcXAK)@ZHSJMo8l7AzevHb*?{o8e=UCjJQ z8qcAkszRhul;fY!4{arp)|{FDLH!w`Eo&14_PRjOp5J)xJRE)8Vd>E7q;=C01s_fe zMRF)<5 zC_Uw9ASkWx{D#jpjR93c?{%?(=qtfOb@*t z)|Lrx0;R2n+g+nF1n>Iz$H>(!=>bzb`GG(2Dq7BITOFQ(pA-3BA`cR$Mk&Zc5 z-lSWnMKxzO(wz0d^oiBD3n0_jn3iu+ul%yEnq|o$jZH-ywQYnqRSOf|n1j@x5>?(Q ze0K=o_*JwE@eP4$Z+D&Z?%Kj3&w%7BYL zCX229dqlln>YwXYdxkNfRRjI0RlurT26+4cRTE&(40-_L4hxA|nY4UAq}^V+20$Rb zVeSu?5_RA6m+>ip{<|E&TW(;z$Y*iy>j0~(5?URV0(~LnKaRQqB%%!?tE(U?Ae*A7 z`GMWg4*pk-eGzdKS6V7|Qt-{K`l`f4%xcA*iOv-fIF*|ia*H5dG}wK$5&+0F40fq& zjW!D1J~Z!2p{ZBoYN z&cOyVgtfF@mU&gO4Zk4fuql@>3V0h!nk%g+d$md4V<%G%^pyD|vO)t#;Rz`&iIDYf z^O2PuD#gSjxoUuKjb$JH@3IYHQu_C^oBefIf4t_}SAwGa_fAS1%pK&lvo{~D(x7Df zO4WuZc1UBSZ|JssyUBuYU%;T0sB5uJ`}HiZan{#0mAzkGR11sOTPM@zM1vEJb?=we z@GZqn+7W3n8I&NMPdldqT~qW8fjdv_i3GzQYJ|gjnC#o>6jv@TF~{+T;pve(*+rXG zICa$p_qWyn>l(OZqlMqbLl-9gD0x8r#7S_-$C5AmErGxF8xK|%f*A-q@m!R~lsrn( z3F$WSA?z9V#FV&&zI7XP9VrPEv^kwAg8hG~M5Tk)UWuiaK0Q=fe69w|B^-#e0-uX6 zD;pR@A6Zvwp9J7Q8_LHS*BjWfC?`lX##s5cLTgrmtB0d-`N>cd8OiH>GnKN*&%rd4 zC=_S{2+8oaH&Es>V6!K8y3uFweCG!Czf75^+$|pjha!4kQvJ3kw$zGZCZ^Q#XSM&* z-|%pI{OV+5Wz_?jVEdU2xxt|~u;V1%+eop|k+x-J;)Lz;RY{UE)?pK!qPmIamCv3la&3A0kU3{5n?_`ODyN0WG|aV8uOdSq^iHD` zU*%RJYV4^YQ>}N`bxwUbPI#Z%GDPX`=2a?CKGcdAah0&Ns8Oey;OhNH_P|JfW)^G z2Y|1|`KO|_7DOe~;xj1~+*h7p&R1;33&qEs-6 z)zkz+5#77L7-~9DBiAH|oCT%}b$v34hnJTYqFHt>rtngp8zK6ZZOZ6Y(9CBbx4Re) z0$F7*14>4cg_I5v_@Cf{-2;7Dh!ZgTr7 zZuw8yHAz+2wZcyr-4AfsIgL3{gTI}Wza9Ua7cjbg4s+RHd=Kio{<{z_=x%DwIB?*S zX+M^AI;_fwVAYr)H&@|9vdE1a-GZL(F&H|Wi^r-{m2IzPq~AO&-%3U+SvMJ>J7syp z?|%#yYhJQae#{DH`-Z-XzJGIo1NN_r%dAFSv+rgOV1yUW?K5++ANn4ML5O3Lfvbtq zFSxk21=D$&qrIStNP-S7`=y`Fh*+IpR&(D8?^3dnW$L-=tsqU*XqnEFp7k0@1@#@b z@^E`Mc^yxwGMG&>PKK~XI_Bc?Ib!?>*|q-o@Zu`_8dR-6$0I!nmEBMAWo(~Tp2N7K zX1o?4vW#8j-(sd&h`cKr5a%FyQp!nfq2t5bsC&c*#*?R@98A>Z7>hII#R?MFcQPR@ z?!_pNEZvzK1%v|W`W(z$z4Vj&N=6PbFD{kJVQcX8hc%iInbHV!e}?7Ws@+W;nFH=S z$$sg|9jP&B1k>K6hr}4SaeiBt$V9<)FPYVoC@CBjTqv|@EHiI_;bPQ64VK!VpMPO; z5dF(Oq1Z%+uBe(~sN=z(C1yEyG0-!!+&84Bm|q}`7WH&?%Sys`hjz{<`o;_*p}J?M~hd&l@=wsmMQ=tejwo{6YHD+f!aBD3;Mh?5`F z|D2Li0P3zP4OeE*C5D*TT7X4OdU4l@tS2~@cy)Dd0BxX9#MI&EH5#HpSy;`IOUy7(3KfF5VMKpqy>r0 z>6Tpg)yCE~2gwc+;XWkX;v$uP`R+pZ{sAN}qnHK)XdAp`kgi>u<~T6d7;zIhd`7$%f-l2E)K zFlq}$ITA2zOk&$iLG#EGPzl~81K5gfzGk7VsCC^WTn{cUxxLIJz1I;>eN@k(Z40@x zDdN^kGvwPDxmX}CgdXntQ?i_j5U<5}6DCbijD+?wd8>qC|Fb6gpO%vjzc83uP8+(J zjeZ}nQE+6BYM5GKZJq>tB~{i#8)8zt`;UZ~Odn4_dg%a_d|cw#*=ff?W!sq(A(t(+ zwQr7SUj~Y>VPzD&tH?wGSlNuQHSz!;Y@c|7d4W1E3cHhQQF!16edWRYdF~bqlf(|u z9qcnZD-T2Y*9NhqyDYWdcS+N-bkPbDdpJ}5KR-XWyB~1P(`TY#rH^oNExh9Qrm`- zcO^XnvQUz5V+p-U?3*r$SSVX=lqV4j*?g+QUh$SOC4lrCCpwd&Tyr_VTz$s~_nw_n zsx8?&@-1n8i*q@ZcRFqo-OM%GUfI3z4{=%smoIYfR3>vmiLfvIyYGxL#9Rf2MQwKd zfoE}fF#fcu9z_tL0)~Pwk<+it-5T-GfD(w+StT^Bk%YF7^6Z245yV5WIqD}YP8`qO zjR;IfDTF8*HgRwG1L#Fng|ycBSptQsXxFg5pEpQ&Z$P6)@j0A4GDO<-faNbQ&0P+R zHzd!4Is-=p%SNaxE!>b9K5o(?2%)LiLhk|A%1IWtYZ!h@MvIbb@)#!?k45I{7MSo< zxUpG6?|_ura}uaGU!AhR%Z$I_PlEe?L_a-Qyjl2p)aeOhNXyD~v0FHUq6th&@(5z>FI-^l)J$s`bzM(2cP^7CrCE{u^~-*D(As?l8-rBc>n?ugW% zGUsd+%YMtc00v>poaY)-iFM6LjMzj$%Ouerkk1hXIC1qA-+e(D3CGH+PIBRNUx}@{ zBo{xPCMt~Xvl;)1biiffUniQ8)W$F>(|7`|0XvvoVpq4EYukEXLA@mQO_Mv|tJi2L z+P4Oyw*kn?rMImmSAlq;u_ z#`nULNs$p<#tzMzT?Lyg`-&#^^DmvlACm))NCkP0%HMaGCv?j6N$(yAM(5JSwzpG* z$x`dM3|nC28_5*BzGFs~E#N&wWK{_q=2Z9((w64n*GVei@1bFCqUPc`M(J?3R8@J9Fy)N;j&YLTBbd+0QxaXncYjLwrNcGkyI zB}3fZmAup+!Z8wr8pL8L*LS46<_k0Y-=uGCeUbUbwbU0oQ$9|MEl1bg5{PgqrHUq6 zR^sVGdM(s^8VLYOs0nIrVAmlPqx|UZP=+nez9kBf^7HT2ABBpR=o8f}66k*V`#CQv zed{Q=khZ~5xy*d0tJ#7CZ^NuA_em9J&Gg`qGGZWgD^$USwyN5gro>2@{k&{ysRtEcmkk@wiE~{BF0#5%Mnha6LBc(>cwwN`Gvp{eADL*pPG1XybaWg|=q~W9o2?M( z%4$rEHbBZJV|EoLx5}o}3yxKOV>+n4!Y(KxX@Rqa757WBxQpo`RI_JybsN@k2&quHQLPLTJ%E6-+*a&FSF8E$}XvHr5+$uZFj?!t$i z%HCiFO>GeSpJx)rlpp9gSrLa0gF6W-H(c_8E~PcoJt(I@$U%ciewQj@jpk~37;-`41Uv+@`k0QrE{5KnkeKU%i#A#s4W-MMUz_jx zaa}oMu$qm|l6#Axd1rbkeJ!-fVwt6OL2}?$O;0)zP z9_@>SFcnq4z5XmqFcry5GpGpq4B=? zsF~xh%!bgGhPvdXELO$+KhiO@b0MewTRlRKT3_$I)sSAg$s~wc2PE=b)Dwg*52D9G zG02Bp^zJEkkMhG$Y|po{G0dP!pp{_+Y0mFmn@cL9d!zmMlMq=$W6ZiWON{Wjw%&*F z64bP)pd>D=U$AqA*{z`Cu-u~cHLDfA9qa?a2z~n34ZCPNEJyW(Yl9;r-CSMAF&+Hw zp3an_1D>2|w`h6;#WLYvRBSdB^>Z78N3omMID=7XBQY15yB5i85%Wg@psbs+$Ln7s z7@JKtd!#DmNC3Sy=TXorAY9s74y&O(=gq#9-&r8Afvgp~ebCl%U?=Vym5`~N*)SXz zYE_^HdHdYw{6^9F54%dUHR|HRuoCB)$mcz;O`p=DgbD8`yTX87b1ea(bFTDtYktEJ zAGu+!UQ4Qy#FXg}ZK4>e+eN=z4Qka>jumd%z`4UP0FC&gX-hnV~g;A8&TDD4JOpv6_+D+4MGT8}yyXs(pWX zJZZqQexI$?Y@ltSM7<@VZI(SCK;>FvnaFOQ^bSa~(#q&~D;Fme|Ei2Aqca~nbN%|D zTr-YFHk9E=RGy##lZBHqrIlb;_QJ4NjjM>@$T)5h;AidV(*iQajyNm*W;m_d%TX%0(%arJfI^>g9QI?y!9a9^og)vI4@Nok)+d`mH)Mj?9 zp}V#|#4-acft(R(2T-OB{LEx#g{0aT9m{J#DtY@9=acsvz&Bad?7~A|CizUQFtm$Q zd%{j|6v9wM$cT@6@L!sFA+iY`NkKiy{k=Of%0_58P|epAod0sLWwG?JMSNK1jx)w~_(yJX zitNNdseId+vovOd0?qYii}jq!=_=1e>^7%TU5)#n!gSlx7^;d-Pmy)}=NtXKD3Ow& zmS>-nE=b3CSl{r8PBB`AIQ;cjRtwXNKw2WSVg=&?goM1c9?T2E8$`W%zB0R*T|n|h zwPv+g0R}$+jN$$F#8${K0gK-|B^;c?PbSl8kf=678Mw2xkGtn?;X*OGfjOkwL zb$rlO_&BfYS-c?+XhB5yvZ9HW>(ULB0;n9G`HSF zO!1r^1dS8mt6)mP%+YHz-@K}u(wvw-k~hK1{&FDPa1qF?K=(VkztiI zbb-l~M#!Gb8RDLEkw_p-EA}<~5A-VYoE4T2`3|bVXtgnSe{y$wMbH2LG?``ahRO0O zDup=&76-lDU8-SGht4ZWQDw;ceO7TzTu7a9XL)8!>C(-EfXQWMBz_h-tys&M7b>+= zRIEXp8XP-*Gvw}c+?_xwTmtK^LVuM7tGMp#Pz;YYN`SB-~9ZY|QdaXn~ZYPx_wKT~{ICu31;`+O}QG z=)wuvy$75Xsh2xP^u8VbAkwf=g<{HZ*~zWTaH^TfnJ^wgm+2nwr91 zQg`dLq`Q>mfCgkA_0LOfycDdHB`wJbZN+~UGy(3|DN$mbmD25Ubi#+k`@>_AUHvS? zE4K+6u8I-~9HZ6#eN2uHz;cb>_q!|U?B(8JiRQRTJ7b9f{->hsyOC z=`fm8?@}J4T6WpDgZNVrPKMAOc3KqqIzm?Uu+Y|t$^Gj!VHy~b5k8iSN>4DYYG#K? z`4s1kfhC(8BNp*ucr3scL$%X;EvROnt5bVrIGay4$JywYmk~*AIe#ixe{*f}+V)Y} zML@oOjK41=1RRo1+ZP@>bM?{zH##)!^>~OJsGu{D?fy*;k}aIR@-e9?;6|w}AJ^z) z;6o6zkZ$7o;Yeh=lynj!J*hXRUTUSH`sU&yI> zDELSsbsAEDQkoslp*s#r<$YuIzWpVV$pkdY?Ui#j?>6MiBV*tT#%zxL=N2B*tD97Q zW9t!|&b8nEkjm(cLhR$cnX|01fwP--rPwG-5nZ-)kZ&c`Ih8FwC=wya3NSvL(6px{ zja#jQ8ckaH_2@3)9+O-&vTe~s=ABB5=I~c2D&85x#qBxIg8)u)i^K8a&LwYX)s}f} zet_jvi%Dz{v4%&*|kM1 zC8MWmA6IHuSn2QBFGMUS7jfG=F1=T7z_J|bIqk1I5nZ+C2}D3?_7&Cw>nQz*=8&R7 z1I3dP_@}N6s&b6=X*I|rs^oUr)w^ekSlp{QvJITDswdY~d6k{UYi*F9Ugj=9z9q-j zCpicKk4j01B0xr_TgJT-^H8i2gI+8zEJY@|r%uWRznz-wS(h-Q(=T#~^I62wM{s7U zdHWb(X`Gt~0#lXoX$7~m^ZAnxo%~$e5K#$7v*lPSv zd`?E<1OAH9<*wxxE3VCe+yjNDLXWzPn6}2O)H%C+H!GIDFH82=`JFjA^}$d=H(FkY zZQr>4qzCd~>PC3WN?qxqMxBb%1aaFdt^n&dr5lxp)=-(0^L<|PRCe%wco)q*VJayu zjj+K)uC}&s_PFQ^gPJY#-`Vm)JcVh=90HWS*SrB&jt~3sI@?k$oRdJ%*?LXKt(l=v zJoEbxj=1JsN^^6&>$Oyavf{s{evspUlZLAQgr-}n9%FeK-AUFx0-GDyyRM|`dFmKM z@LUG>*prPx$K4Jq3WTaak~UC9yBnQ?+5ub6YQbqM(2mh7q&mdFpb0K?%xx#;m?$Nc zFT)N&V}@#~6sf0KlEun87b1bAWTzv>=fT|QKj3TsOv{@IM}0fre~xhyey^V8tR79X ze1kS%1F@sP5hi-Lk0szn=>0*^bk~saoMK7eX*wmSkII^nENl%xcXZS z97dm$(~vt@EOUIGjmLrp(HI{VK^rTm(C`DN-Bj6X#CGLS z%4}C(83Jha{chw$WU-G_rfvWV4A+ahw;<2>dZ{B!Rj1wSRib#g6yoAwZ1cI=fh29+ zol^j2I!rPFeW&*lW1~^kPLzJ==#mY(&_bjW+*N6=EAf@_bHnBI(}WB%o9yx#<8)%J zrAeFM^rMlZ?4LHH8bbbMLp0Q*H}yj*7)K6+;d7XOoL6tE<$WJppny`A z4+ucQwcr0QXv)lOFtj(0KNZN9OT5(OJcdH5`R zO*p?K*Wz1#dMgxx z$ug7yut`VBH92y!;+h@D3FT)1(};jrAk6K%rOl33v((0_kVw6k#wO~m+*{>m!lUZyO2fh%6^q2R8bANo88jzr-bCOxc+D-g$AVbtqqZUDviLL12$#S#Ph z$YAV3us66zs;zXZ5$&=7(NeDAqH@tX76%7bj*Fv7?x9diG|sQzHsoQW1}I{XA^;8R z$ir~YMs`{~1Syo2aUvzdQr{!=In@#%W+FkG`s%Q>8dv{Qt)Hc^Yj|wi%~_F5!9RmY zEzFvrS#aZ()RH>H3(+cN*1Mh!PEi_$Z%}c)hQqJ%Mo%>y zG#><%V*MLKvbUlL02%wOY-wmGE59%kIf1lrCDDeHuag8e!xT07Ed{wsVWCc> zP>U)a^OQ`xGoj#$xzic>%dXWL(F^`v+;>q5la`yHF%XvKeyIsO{`BY|Z9{};f&3DN zF1U8TZTU9yn8pl^#ug<^&a@0DPpsj=u=a+eAG}FN3qg#bebZC%m*yd{P_SMIYl@*V z4vYWUSak<%mQ-qs>*%x|%CZchsBz$mAtuAT@*CX`v4P$*lpRfAfm~G%IPOe@FcWf7 zSUEDODM11L@hG2A?64PLJ*vfm;mlU6;gQK+ON5l}oN8>6r2!XAsy4Jl=zSs_o;|rO z;rS4|G9E_jZ}Ayw>&z@RiZtlgT+r1#^1&CI$wiMjmusqNK(P;tVe}M%X}~2Fnj9!_ zVE!oRe@PMP|F6`JgN#6ITqBc!L>F|CII5qqdq*Ze?;*V&nL*LGMG!7U?8A$@aAHQK zmi_pA=^7yeFMji-L5c<7Fh0bW8!jVf(8Tb&dmWw5yT?rx8FMszk+LnPR9gr7qk1L$ zqS`JuJnTm+&={dr-(@a?{4Dgn_zNk}xm-|c!Z3U9d6yCNZ~_j&lW&u4Yg4?1R~WE1 zXtr{yH?qsef=3O$ob%04%?K#T;0t&_$`#DG{4fGdx+m@BN;=P%S=oo&{F<$lrgd0J z4-$zZFGCp7)pCv@6$l{V=P#F6`ao%-Pw?!6%=*H&g5yM`NWmOc#zT*QaSU70 zOO>StLG>PFq`&R?Uw{cAZj`)kc$C-vr-uhRYb4TsG>>hz0#SCAuOpv@FdFWLEAZ|R zbb26#72u&iq6n);IVeyNLfhmYhj)#p6JXLYd_qV$=%{#w(RS^x0 zQDyBMp)eR`BwkN120f->qLC5VB$JXURsuykJSa-njml`8*HZNqGDS0xJ^zdIoKg1- z;iAz8f&BA29zwvaU(hy)*P#YFbxCIq(9RXL*CS4gbcu3(s-qi#G{y}Y*NZ~3HwylC z6Gcb%+qRipEMUyKw|+s#D9`}RQ#JtD z@hR_VxW~mZrI%MX!y|xBKc2SN)2GH;Q0ZwJh+|CH5 znGeg$d_f3A^|$Ye)#tj@l(qukSayT4w3K*DtOnuBKx=xT!h>xmST$kWTAXcOP*BLH zn=i!fvNS&0`5^e4KEyjnD{zo39&sQ>Zt!B^o0PA6g`p#`u_1*r<3{yu+W$U?3gpDBvY8e3( z`&}B(>93{Fj-zMuv}WI|w1v&di%2yNjo8s162I#Cs_&GPLJq3!qAh7olQh2$RJk%^^+dr|-+kRYCm7b`+8&|) z4C%q_<6Ysy%&j~y`6dH}{4{>c(g#*KHOBSP$GJ0)39CNZ*ce8BbzFAvjfBO^JmX!8 z<#BtH;jJlC@n!N#Yl~83&_;25jF#aIyV$hnw|ptt3?^;e2+WzQKQ_!VqS6WBZ`a@g zfeH}Cxj7pQwE*0rMvelq5!uAjy4T3TLS5hEJ{VKdaWwex&f|1UlKUVeYdgByvRRJv zieIOvgi)LG$S|7_OyQgdQRb41@SW&(800f!=EUz8ow_x_{r_o*uO7wx7I{C%BhE%B zPZ`4D@5_XZZQ7omQg&d`_aDUERp+!le~i886wa8Hh8BeRVYD=2>tC%T#h1hC{K2ue zoci=s6q0rW-TML0?_f}pJrv~P33}}xACae-_=_kr*@?a_d2$Q%YRHndhT)O$X$viP ze%z!o$5@R1vP=hzC}2ZTt-5#1 zzRT>K%DN2`rbNZiTn;&S(>C?Xk=ZcWqaUT3iXL#dTKl-@eDpI*2J}e8Isa-lE~my@ za7%sT;&c|`^g>u0{K{RSQQx>Ef&*>a6SwXXjBntFSNebZ^-C1jK>6FbSM2oE0Pt1H z;x4u`#;7iY22>5?@OjBJDw^a$x&Dk>f(O1s_bpTw_GZQ$C`}&-2l^{M-6C_TnQAP> z(mkF`K&6@@JhfmtEc*@BCc*as7)ENFC`K#lsRCWj9}5L}#`HB5zgtGpDUyPf4bgIw z*6f*%pRXc16=jF=A>BNWgoOZ58iUdWx{m3;PFfdBN+3F_LMuq@zbN5Mg?dSDm zFxR(OM0nH*e^!Uw}{EAa5?^;k~c|v_u=9c`qi0 zk@A$#e6sgSpUWw31vCDTnsiogDi1?dTi0XS<(rY|53w;*4}@3Uj>SL4!d)|BT5$DY z)!a`P$<~q~Y;AB^773~uz-x7Z{cK2|W3?p?jkX|#_{&k4%V?+#u}DuQR$7eKsIQa- z?2fr{v7aU3QgZd^T067|pk=)m0ftRMrFBB^h+0COVoZRd(agw2mRc{yN;`$TTqQq)=lpn~R&f zAwIX1u%O$-jRH{q`y@t3t;#en_bU|koVsbaH`FtTWm6Qfn+jxMN=4J zL^~na4s!)}x5KTJR;ke@i*WL~T1hZPz%`*BF(M>DoLTo2(4KNTe-tIw{l6C*pk%F* z2P`&4+WvXn6Z-=3FsJrYmk7v0i(sW)PG9&zhVa1IdI_p0zdT;_gozRlke2!&%kz~s zFLNn>j4#VeWL8T- zHM39&Lckqvl|!*<0WBoznUS|j3iB0OP|Q$Lo`|NH?=FIRSw(f|7WT}hV!tB(tRzZk ziBWiFb9AIC3kG?ATk&bj2EG^{qc-fkN{BXv1FwQq?e|m5mi^=gpE~Cm{A!{+GRz;CRQj4mxDDP#&BTZ9NPp1_igSeRQxmL1?O=Ur7iJ0)Lne@1e?AW%L~oMJL1uWb;*Y`EwI1ugxvj#zQ8PA2Vjc- z6aw*^=Uy`h2h7@h1Wg6@7u?5AXd5xGx5~PX$MXt`oiMZbf+Ei%j2v`jm%adOZc5Va zLk#9qjRC_l%$>62>U7}|B{*9VnXL~Z zf-=w1qqv0;n=iEF1uZI)>A&>i+|7VUjRe|KL=v;z`qu{iR!4Mw|9zmiwt|S*q>?z? zwx;8n50^~IVo~S9UncZ9A2(23l_1>^)aT3I=rWX1fgTiiF_k4KfEf?I>E@Ze=20omF7XM5tmU0k`rX5aL@ODQZoATl&~r zb-ra-^$;LS*@1J}4eg%##kuR9Lo$;d6G<&6j&%#;MbCzu9WfZ(t)M0S^Z~!XDX-Kb zcvX=$J#hFk9I4w)%+7onu^xOJUC&cIlK0Jew_(4+e%_xH&kR^-;3i8l8* zm$wqTCm&+=Ml;mFHu>h0OpTQhzar_PeW-=YX^i@IO9-i%*{IGr6_C#ykS$|wAQG;T z*e3PD2>e57o@f|LDI^%coa|2CdhMNCgxXz5MlkPXmA%0<)grc{%*nLM&5SLMfGT1_ zUIahIiigE1ZbJiQ$xPd6$NWw+*n}1NIkt3RtJHj5Z>AA;5K;B7o9XjXE8oLDTKQ-} z1@C+zkH9Ke`tn25d2(2oFM07#h(Y;0%+TWp&|*?reGgciP%_>%x`(f=R`TBW>%X`f zjKxo}V>o*j{_j)xs<@IIg27B7^)oVp-?;2yB&k+WoTx%-IJf?oz4QF>gZAeb=$V>^ zeZC<|HRB*)*}6j>q;ha8H@Co5ou;z}UXp}_EYdfdo@i-Fv&8G$Mf;KGI9h=^BFCs- zM7*V{GqMOf+NqlyY&dMTkdqF34R?{ZkCDmK3mu)kr!!5HJ%Z#*98hedC`B|$_HFN| ztIOI71*)JR@^?7yIBfTNjNx_HvAgbR(+hjQBKIL5gVu{iXR$$0V(oH3R>8Z@S_5Mn4Z5FVA=Kx zXL8Q~Ux^(Ob9do_`-EZA98jq!q5iQt(y(Zr+u5umm<8BjS$+H~ABCl4*+ChEjfA9# z1Y5!Xb#OAXuUZB+TC4uHn?PhV%U2hU=i=~NyE;k5MJ`D#vI0+w)9CJBGsOJ&~Xt-?6f(EDWij_)Q ze&koxjc7F4F774KAaR*>)@X4ZEc%Ko7fd!?q?-6Er7+>GI1n%)T?G{<+D<#w;!rTl~RAD^0RqI5aTac81yZP4^sxg;{#Dqa+V8@=(|3TXuX}_I`!68AF-_h z^kidOH+_!w?KUb)eU5oexg!YsXidO5#0-_Lk{EhZX~!STS1N3MDSt>1)M(XS))uz* zKC9UhSR3>U#hKp-WZE$bU;tWcA(S+r;0mF(#dWyjManRA{rRm;~&y^cpoO;&y zBYWZ7@qp#ubw{|8%P_<;-pNr-z?AwOfT$|s9Z~XH97Jj zScTfjAnZ9AsQ{ECUmZ*Sp2Sx%T_^NXy}&&$6ZV>}5&#Z12;t8xrrfsu!fp^5#J&t$ zC@yUe%kw^<70%ff3AEgW0vmU94V5%yGtczbr!gqkL`z#`uyG)|09U8?pjI-m#O-z; zJt5fk8k{H#tShf=|Ej7SOmo?PmVIzCpHZz-uHhT6C05$-QWn+C9~KF(nHfLL0UF(l z=Vh&6umm(Qtcr)hH@yJj9FKl}#d>1;4-35B7u%&qwtT=|9l@6C!(U0bsU?=zd-+o$ z#NK>`rOOIW-hAzfy@Yg>g^4Vy1m8r#!AG1w#mW8nB}T<;&N z=qiQ#S(;ra4TPo2!5K&J=-MqNYxN$-|0Yr_qri42&k|_~1(>!qeKDa0Ixc(m^|HSL z?+q-V^8(NeYBPoqSbe-#luPprKequw{h(06m_dbe|M*&NbE&vo<#XQ7auR6L6#35& zsaBJ(<=c3EKKmg>V%iYb_^Oo{F&PDSYg?2WtqLMtJLCMvQw^Ff7qaO-%c@|z>fVDk zufk>MkOJjZlj-L^)H)et?QPg}zA{LF2ZVJgkgk{xQ{(X8HV#D)Lcrxp7#yN(c3aiU zSg+NyOmkS&ndhj@bG>F^vWI>^Yuoa6Z9@U*&E>TRfX8BW+$namZ6?!ucXgyj6o|^v zN>eA3QeGTo&}WkK1j1csxYajKpeonxxj42~!Xh5|@N9vjfWmCq%2u%QB&<~mx)jQ4 zMPsKa^ZCrj5#GKn8RuDCD?cs)SUw?_nxGG6C|mta&>E?F(ao&H_dlza*Xd|du@}x^ z3^4YQ(e5lbWTe^y!^jp5D(XRD^Xl*;A%sOPtsUtu<#DdXeBh<3DKO&r>I@_(Gl{8HfGo{6>aHUdfnDX~ZMAn( zF=zO%pvTVEJgsl>Dw30+gaqiEcOzE^IjSL%Bv!wTO%MZEb0I4QgY6Nf;>IJlKB6J) zEyvby<<;$v)0h~jq1eCWAwWexM)Tv6E=nKi4eS<>g+;UwvR$A`G6*3^6SPNE<kN) z()oG`T`UeVDSvbVb4boK%Zy+H(9UFN`AwWL0Ppaf{_q%{;YSK%dWLuY@a8DT!utv; zQPSS1a~S89?CcYtG0HE)wet$cbBZRD2Sx8{70Y+{NW0BZRC$-`cQJy81ltoYPsr>Ov^}sjuf?T>I`Qb;fa8`M%Cs`a%iA!i zgjvVdosrw^rw&~TMii*Cy5!ArW44HH29@)D8x(w1?s%C0Bjo~EnF3DI6$x^UWxOB4 zf7Dfa?0N6GgQO{96cNFQC>D4|tI|+zD8raAf3k*kPG_2DH6QY zU}ctJ?3TA1+`x23qt3@LafqT$;I+e$G`ii9b3v7)&_5Xy83gb~vLRM)>(F7jl(~cg z6U7dM<+ zlwNIx%jFGq^}@%!#iwz_=#O85xcPxpB3bRr`o5wAHUV-&nJ19(Aln)BhPdgz{a1K7 zKoQF_FdI-4*=F9XEMha^M?W{1yJS^H^cD@6rr#aI8tkO#zY!fUufu8xDB=9pHZS-k zxJTx}xE;{6fz8WZ<6MG?_#C>pdQSfTBhkb~I+S;CZN{|RO;;J9F{k--wBTq*p;Mm~jpil1X{0~#$`MD~kOOK(P9`9L$qX0T0MSTchSx-Qcn`gz)@t^y1KbtIeNv>Q)kMMkUPnNRM|B`0}x6O24q` zqUT(0`jK*bz6m#u!o;ufCMXQbZ%$uH4Ps^E|K<7)#DjQawM%qv<8Kudt^m z0{-F$WHmur3bQk?L`3W z^-$hQC{M(L6&czlXcZ=kQp{NPe zF$vr48~^k~L;v}LnQ2qt)8xhfa-{e{aoSCuY4mDiU_=R8Vr#_N#Y1HP>A_k28t|Le z7DA@SrBzGS%Mp(O?ZpBD;F>r?M~Tn{k@8ja2~e8iBaXKe_=|#sOGn2XNMjZU5uyM^ zC^G)0u3A}giZFpr**+7xd+z^CsP|Wst2^9bob*sK=mL|yOZ>4uVEGe$0*vNgRx$XjQ3 zUNDo+2tv*_d>HAzjeX9xtOxZAc+_(|+f$Q@)2Z~vnn9Sb=Y%jf=;;3R^3LaE4rc8e^|#c znVHxYm`Q9Nr>=3X8&9~7)8Nt6`7VPQ9e2~=cvw9nL**EW7>v$ucFT1V$dj3_>W^Kq z23*t&)pp~E$4T5t4NCoSOCr27b-KRvEKsu=zIRr(?VaCZEUuhqM^@2?zCro}De(aK zu4X-|YXp;QV9l$hn_^WNu4i}CadqPmZ#rO-w{F+JSTk-KSh5b08!t(rok#cyuL>25 z!0UHe6xbjSI;{}P>S$~)rTemU*Gt27XC8(1hRxmYHpf_Xyw4VD6Azu?I%RpZUhj(tlKZk)qw?OLL2Hr;o!$ zgb+v5Hy(a8zm`T`cO|wHjL>73#mIH^|6G;)pZ$=Xe*x z4m(~+R;NW9M`lx3$=&%b&dZaQJA`;H6*VU2#A`=P|K<&720OF>*v#S0B1hxXi{GQr zCLzEO$CPvklL4k#G@!sttc_ThzTA}QM*hq2_Q*a1xT#Mzs76};0>Ggvr|iq72y*Enw~{qOU}ulIv$rCXFp37+ z@PDbzy2dkQxYrRi3;vLo9Cij;>s-6!+I$$tHX@ajutMIc!*6JkTLoHI9cn5u@UBQz zZNf}eLx~#VJ2F`$HQwfz6P2%yJpZCss41i9ML{e|#oqHjwqG@w!;$ z)w6ZW-jnbhtAu3o#E49Mi)ehyiOdYI=qtE;8dE%#@X`n&>g?}3>#57llrjoLo4zIo z`6==us!wsUze+NCL~v2o+XU4(3-NF}JU_$tKdmx#7q{a^I3aj$aTsM=o;{a2t`S`7#0A()T>`}K zt6P`4=sHaHG@cU+?7Xu~nG#K9Kjz;hCWCOt;3A{ck_Mywz(yZ*pmp-$RJmUpP57RV zg@&&r(l?M0I{u)c%MXM6tmj1DLI=a<&pXXR%SpHVcGQEY1;)U9QJmhpu)4 z1cGxuet}-Gf@Py-KS$^+U!oE&BImmI4EU7&bUQ6~%2&F-a-lnfmMYJUgB-h--ylHf+4a?brhb`TTJkC_Au z`rc9#(^S@pZDLR!?-56R=27P@XF)|)<2AC7#|No{~5MDK(KYf@QuQ(Imj=AW3kx7ZY z4J=4Yg0Wqs8!3`UXppc1G z9j4-LB#wWQqf~t;2DAiUwENJ__}iP$eDy(5)PrpWIT?x|9@cHo5l4mcoS+J>I4hpn z4E=6+&1jlsE%>uGAMI4j7fofF93uNiUC(QBXpHQ1j67^)}T~HR>4|Pc; z1*0b}?T_|)g#j&I3q!WZM3!kDqI;q9KjByZIxhnBj;h>NtnEAxdtWj|w15ZeN-&8% zu1IZR!wd8mmt-b5Hn1y+@!z@GUADOad9r@gLsnh#n>_2RqEL)jH!FQWWmQ;pmWCpC z6Y8x88m>rI1OT!HxM|q3ixnhS`zX%E8jxvMwq1=pLDt*?B>NSs?>n!p8L!aqV z9Njen;Tq?r;M`4BBoEqCm+&@K)rfD9U&4M#4q9HShV;Mo<8Vm?IR|R?r>PtaB4ac= zzrLkWZ`2dA2>l%wx-dTyj_wAK*t%#udKb)*%+N;OWQJABr=o{e3-ePyFcbIGcN#0o zn9wxahA>HhuffiiL+7{ZoE`e%n3W(uEqZ`14VR#~WoE6cDugOf%G@^42k7cbdmF6_ zHwYnMv@J)4Fs~D#P>vQHIylEI$EcekbigBT3M>o6!jIRo*CqMVc8zg0(ys+yysPF& zU4Osy;jV9xdLO?%{r4E!RFojHc-5aG=fOa!-!juVJ+e`N#!Q;amD4U{V|R;czZOPj zsiBPN_H8CnTJ{TrY_OXwHayvI4udLVFNO?@m@o(^LhDSm+NE+K5kRrb;kGR+6yXhS z?)f#?gL)*8#FTYb_3K61^zBe$n!urA7ajN#b1>&HBJaz+mP|2@)3nu zIHKp*>zHCtgLTDttMTKd^$KcE1O9F~5|pE-+q!DOj;VIsEE@dU(Om$^e zX7OUJLiueB!wn$DO4#Rjwt(~N#ejs5=I6uNOcLR+YPjNDQJeq5q#BZR0vsT0p}=Rr zBqw=#TKzRn-MJ#V#>%2>v!E=;I7CW>+Chq_@KLF2{6;HF^j&pK9uh-BcJpNP^L#<# zc0K`w+_d%ZzqB;~aZ1GXS0#YoUS(*rjiK1DRLI@|KICMF{GG~}QO>h(I4I4CRhcER z%`SVnHP(p^C)k%6Ng64y-REmu*w}=)(%TTJ8BR*4Q}PELaijmSyjTz+Opkq$32&%au|{GB{C$BWWokUf{T-D6^W1M+6s0ChRwCCkp{@#~J-lTPHSzZ4 zDC8_Hy}K{kCq+86B`#;Ae8a-*NFf^>cz0!;GhVrKjMG|}TzHEyDY?oLlyWk})aLC! zB?m@SUj-dQ~x=hp?ZtIEF$DkqDGNP$A>Ld=sOw; z7d|rl{GMqlq!Vsj3k>+lM}TnBDU?$DdrD@G6tFq%-%~_lnBV=Zr@9R>hAAF1Vsw`q zE@bVuvS{^d9m=xRBBJsUNsgqZELKiOR-$KD)I$^WwdVFyciu}gN^NSbxD(ph;{*jB zf?G(Uo#l!JOWA(*J91{*Ru3>W)Vgq5y z;99iet?x|q0`S`GGRJyX50F#-^bF9_WfSV8A|&w}$-9OY1wA6HKmEycr+Ia_}m z5xoy+q+>4NZ##1vFF+?Nyb>!-Lr%;n*vxheK1FibpbIJ^F+ZD;#1BOVTiAP>T1dVV zf_VoaJI49qYUucvf4*(|<4G?D=YT`xHbG_K`PS+ye7Z7&D-!WcL~@vC;$#%fXeT$7 zCCa%k>xFlD@yDSG+H2&B$BlaU12AO&=y>GV<}DtTcR|WiC6oYih&veJn>C}EoEU<> z1WAh_SCztkR@=&8U|W{onJR7+`B}EMAiI!-5tZNg{KZ47!) zX6Q9MS3nBBKrqD!goI3-IE}Pzdqz;nDp;?%Rp2m?_mMWpi*I#fLbbEB1`vc-U-{b~ zPRS-OrqSW*+i!CM495Hfngs{}mGgV-KN+S7RZ;b3I0`cutqvJ5G5x=#hkaBKe3N$; z_T*mSgU>u9V_jbrQs}6;DBMd?K2ZB1hc9jL>3c7bJX4d*cssE$AQi-jRq;59p2Qp1 zr4luS18l#FffDM1adBC09wq->NJ}!QhF)_s(yo9}&woNKmtXOYqwR1`D-+}vrQ$*x zcPiB>3dnM%Npk{nM6#RsJ_jujVj2j$Cg3%=-xf<&gyPtL+HWI-H9@?ul@k&p+o%H{u#Epw?0;HIPT5yzit5fJo5g zZc||(TeM?xI`%A0egxFsX`$ciT)^LWzpAO`0mk0i07q@yVsu1%1>xR4MgSnoJO#+1>-94+3qt> zKxaS89n(6V(*dqZc(xjZh{xfCx4)U@4N&dpnc71f7cIT|7I4#aq~kmNN;*Kw4hK^{ z-DuhKVcWO;*{do{7tA(JRIy-6czzC~B0MQJtY7Mx(8F(an^LR;Ht52Bw4B?PF9`bv z8v=DPGkLt2!Z{EN6EAh)fd#KL^gpCg_fKh2Cd9qHCOKCuKYY5iNnE_HCYn_?!ZGeV zvm3{!(?}o$={tVXg90(d4b^(z4a4TWDT}IRBZ+1p?Lg>IbW!xh-&LUtifXl08P9pz ztgJ;vYaE~@_d@}beZ8CgjGW2chkaeY=BnmDQe?#2j9XT+#CS2MXwr*LWrKwR?ioJ0 z;8G7Xly8?;9#k&6CNE#gI@El{^4}_RfTwWaq&FnkcDyVTi9HzN{=sW$g`>3mnfaA} zHX=Mglkw#D`*(m#$a>J%Yt!5K(z&M>?+P00gW=ty*b*oi%glI;g<}^9v`)x5xQKlh z*)&0B;EbeAPp?lnZUIp^`aQCx*W6q4oeY+bx;pX>h?=4iQ_3Urx(_ES_dk9kb2ouTVER7p>H7HgGO%CZ?vL;7O1D95!h>{J9EfW6( zf!K#S`hoE0T5H#&Pf@#-oQnZr>xA(q>gT7&;cc%OTCFTLs-`5$>tf<@?|3C`I95K~_nPj2SRvtEMLM@%h{O_i&US=OaCwWmg@tLJYjZ|M+sr!lLW4%F*+r&?p5U^?ZcQQbw zBSCw3E-X~We?`Edl9vJ#>R~G9 qrmTCG=Y-e*0001Iq$CUg0rrmsw&NeQvBHHuFb#_W000000a;oY|L{Tp literal 69068 zcmV(pK=8l)H+ooF0004LBHlIv03iV!0000G&sfaoDXH)OT>vQ&2UKVgRpfkl* zs)A-(1?mrGpRD!ZGl(jIKV0o498AZQJr5ThUTo6G?CiTsN^@9Pn{Z4z+$o9g9m4$3ttE zj(>y6)vM4N{K~4@i*|74svXGSp4GB&zC{#IhlXRO$5Zmvk7S+AXasVgv1SRjZ?=Ec z+B}sXrtE{$^P^cxbgdxp9SK-vn;*uOO`9c4%8?csI)XYMFsHWUHtOBM=yFqrcTZmz5cBB*d4> zKY|~x!efGdWC??VLB(5g&V-cZF08PQm&mbsJmbO8IKPh8z7;x9$%(96liM1cOhHVQ zG0$QWgWDVHgx8Q4>m^rWpr2$&_Uj8j3Q$w8%x^If1JOYl@d8EehQUBG1QN!q&xcRD= zE(bEBIn<>bS2I+qt#7;#+*?>!Agd+DkLc2YgPohuEUj@GIO-yde%3BA=K1x9(mQU7 z)It3D2dr81A2+HP-@7>0cehp>4@U;Pn=vuOzqdtH-&c2A<1xeLb4JkVw3(D7;9ILj zui>%4i?L`svXgdVxlpf(!{ut7vJNj*W3Uj&9yk7V8c%=p;-n>{|IF?52*~8cYcmV3 zz)|JO4B^*)-~3cLZA-*;h;{hn!L&gABCA+GfW@_=e$q9Lc!Vr(f|f!dQXk?c*p-byAGnY_2N71>o2IErB~Z?jI${S7X=Fd>9+c3!4&6-J@S313n8GM z)yEzaqr6o(t}YQz7Q~VWG+l0VNf3LM-%%nGWl4HzMiRGI!@Lv$ zH)X@kDj$kT$S|lyX4KG1NfxB)AI%b{JL>mRdoWGic%k^nC1BxmC3m&D$sY^n7)7@r zLZY(?0-xh8jUFW@;2QH`r`<8DMn#id#`tX|#m{BPamGhac}qs(b>B#W&mN-5#@Q5G z3W$&>0l_;+LU7ZcMamJIbnLVy_CS`&&2+}YQlx260h!bSEj>tN0C8;wr7y+`d)cuM zfso~Q4W&jHN|hgg`a|_~MVd8T41I%~ZzBy~;_7;gA*g@xi{|Q6ZHs*j{O8ac#RFz5 zx)%(dESN`7a7n{+YWFLS`K{&GL)9RH5R5%u_Bw#M zgRZjF<|oPYEx?6hb{bayFeG)^4h3X~FC{X2*Z0`lc~zu%QJ;G`_9tq3I0fuIG4V3q(bNGVa?>S*gPl;t zP>f{+A9>e86PK;(%edRsK_s1)yGA*r3nEUOR8__duIC*8N^W6+&ewBtMlZfT2w%1c zyKPj;Q1#+iD9+51jsjuA5RK znu2ePQqPjW!bI1=4!P^|Au_jh!Sk~C=@{TnAH)g*hWZQ_A5dhINM=1G> z-@%Kuu0omBLcm$2!U8zWeO`Bu3p^o zb8P~>-uiI&G6h$Fbq)F^jTE3#jpiSFcc;<1*~-eVuFu}UuaP>%-yMf&^ok0*Kaqm< z>{KB-lLai+le^#Kd9w3jXwn>j%}Es3g+mZ^Yfbc0k6I+UvGT> ziJA&NsZ1cf*uY{5fT$svT9y~my*3l!akSe#O|6}Bdidq(`9GzquK8)Q8=KVpRC^!gV&HlaxPD!02l3pFeFO8!IgO#9cH|{P?Q3wo zt)@gn58KbJCK6O2S1yJU+gApy7^VV z$}2U))d28mWSacDf-}71K?=vHLMvi!ER0U_YlaX+Q%ss#x8!3UkpC*FG@i%sjbXdl z5t3gQRA0sBz>R*l;a8AX%d-Gw0lMx;Mbt)~3y&j85Fmox4XWyD0x480iFg;VrfY_4 zKpseJ=@M6f#VZ7`A%f>2P!=%tE64TbJkd-n(+QrUN4@@t4%g&`Jgfbu%i7%HP5))) zx7sPYSyi{TNOpBj$i?NCU5__+>Jg&Opa1^ifv|5!$S)T@t;~|K_g;^23_ylt4!eQ# zKDS=DJVLNM|H*3-MsU)(on&27QOYuZNnXDZ}4%kZiv!%)rzx;Mt3~S!k=6#8wKk9xsc2RsbV$Lkj zWCKtCwqq_H8mjs!+#mP3CXV_E&6*d#YwNS`n6{OGa=|r}+MK4!ArADa)N(~Vz$aje zDd|ziC0M-EvnN?&u645dB87b1AMQH?RI^Hs*r>cwZA(|c!=q|hgv;nNZf?B@iU35O z*Zim;32W8zZaqo4y3n33mi1)P9&v=wP-(7#%!dusLc0Ah-TJ39(n5LM0kE4PM?WG? z%hqA7X-kLQLl2N3MQ!!wSN3Rn6@I@bO|WfsUo%Vqdc-!E2~U(A`YN?uI2gq-Q?hiJ z#b>gZ_F-4J;Of4-W@D|MIB+`BsZ**%Z_{|MikYr4|JjsT@biw7nk519__*eBHu#|R zm82H;bo>ieNfoN13b{U{3y>%N1b$G;z~-yjR2;eiROj2rW}{%P?I&J(7h(-^6$T;Ym{y5$qAbosA1l0ccwyOUrHL=QgFm5lmY!wJjK z9b#-N#vaEZ9USDf^?p<{5t#hH?X`|~I?8vrVT|GuyQ$01z!x_5bG`O`V7CAcu><1F zUN8zT$M=Jj3sH_<4D=*NnMpdCPOD?`@4E4P3#p|j8?_z};nv`95jr*SvdAh;iS|s- zPJ?@9hskdfLDA_phBPCp5mCsP>bOJK@p!7V11EG;i-Gs;3QM+kS2bIE+4MMcxHuV6 zj4}pfD^=(b&lVpCJsR%$jk-9~%g)ji*CwEXG*PbmDgTW6UpgZqLA~GEEE#|{{iuam zZ{g|D!FYG4)kRF;RK>)ig+X@Z(1`}WNPxdu-3Lxg?&99#+p9$h<^Uxt}DOdyS7n#Ub`|Y$t&>qWn`2>qTtxt`rU1;m@1wLv~_ZP zD&lf}3YVMg^K#>m3H*j-rdU@iLz$*9Vgx6krc2p zC*g0A5;77TPR)3*>EK_)E*XWi+TY-HIn&cp^GRNME~8sOI!b>`qmVx(g{aaEgDk$M;Z?$JN$fb02Eob3To`vU5B@3SPo*T2an*rgPiSDIZA zP9#EWyuUX*+JPrN+46pDnS0fWm5F#S(DN#>OP2)P!8Zvk-uOl##rvn2pYsjv(9)=l z5yZC6LDxsFPAx=kM$!mB9}-*peVP7q^9Ky6Zt(q#Cq=QU>eu0`R3*0rS(M3_-vIa+ zzw90GvYDh#ILA3m6s^;IH2PQ+lS8&ZGkLLC=UccfD1LBq70o6gFx@v-(k6oz=v;=d z)f9yxPu!D{V7O;hR&?ct=ETa>qxT%QlT76_Qz?7)f-rFW{Pegec~bq=X=@@=>5Kj( zokNzV=~A*^N=m!Mj+~miVFjtr6}t?w{mo4ys49wp#(nny5vhoL@`%3ZNWDwzWD+uT z^&=Wo<@L{D+|yNn%yW4!44l+R*-eW-ab~jycYAU5t#$AYqA~&$D9wJ3&<=E$s*6v z`ta`vJbO~pFTE@Q8mX<7m?W-UrgDXJMk4$P&<|%RPj)nRbnt+7hDsB)VUt`kEeJH%$C|+S zl*tnw=I2{(C5yWi+3?U`n*38-)>K2|5!#sI&Mz16CyVBIr{mrpvP{1K9F8EkS85Ra-t@Jb;u|8(&9!2P~{KhBC??8>IevLc-?{hpp&&?3OPZ`x*=ju5lx?!G z07^0y7qGlr7nP=lwE{`N>@Jj|?1N-FCHeSG@{)~y%eVinS5)!LkVc1a$#OTGf~3u; zxqRzCx1t#a2u7aOW<8F^I}f=%=+?Y8B(S?>{G$2N8A7s zFuz(VC?7~tMFcq8)AuHv@#48d-!wO*569L4uOzi_(uVYdp5@j1y0*pTxL#Zr0O1+k zc($-PjLH7$K9ckTMJ74Mn=&Gm_ZBu!1-xRp=FsDRDL%U>N`-xTz(#Oo&C82EW{WIi}^ip_U%Ya7QG;A0R zGf(qW(su2(30Dnm6UEdM3Q8A>@et2ULPa$tFyc4F!U@tVY;CKY5~OB>G?@NfZ!CWY zkILtBs)8#RlSzX#$|ZUBLd_drKhzJmtg6WVj2A`FG9%(U`RLZl+6e}sdRp*0@oyWZ zGgjbh<2Z?1VK;1~^t3%0wWu&_0*$-K@bviue;TYa^I~+HW#$99eCYDwYA=p{*9MHX zHdQEQ9RU{Id47EPtJp#aN=CP_Q#Z|?R&QncbW{v9KPx`N3Wji#ci_^jaoN2B<^dAQ zt0@Pe&Z9U8hT6aLy!Xoh4{`ev9Tq-=My9ioPrh-L@NT8*3Q>I33s&iCi2d@nQ*WuW zv?6_v1LryV*vS7%lqP#+c`oxHrATCdqvWaHkm5CZ8jINfyp26S0BAuCyPsN5UQDW! z?NqVAA--z?7Tawuo5|HW?ui_D4g^?Q6;CSk;wNX;)U_RT9PYDQMdVGLni~%pNU{fT z%Njz1qXVW<&BF{gmqcdv=yv57sIM!k!u7EU$mEG;T#;Mx0fB|#Z$Mg$q!Jja8PBC7 z*M!dRLK&zHA_0vP6tI2QLCr|16r^n;lZMrI>>107SXZ38={Nw6gd(C~q zhFG@AK8d_(7iz^wo}Uncrqe%}hyht(nwv)NbHjpWy(pS01r@e8MjE}NZg)C#4lIp# zfdmaS-hpXqjOGgcUfIq-LqK|4zjcmhWa{c`w7+_J)K7A;eA+0mJLB6MuBV;VOl@B`^r!z(FyyIQqQ|#6*Z%x_)F4Va*fzPhN&ZkbieewNI?|Y5yD4 zc@@sbkcSky03&2A@?o2Znv`88B8?+Gy3H2)T1Tpy+a4oc0splS?bn+{xnt!lq{@?U zLsV>Rg^(?rH4kDEC_b#Fgai&Mcb0mq24P}+;MA36fNJ8>(g2d~FKqP-8sFk5D$V4( zbKKU*GQ>P-wH-j}!lOy2ISgHh-=Mw~_CFx)Z#Q-gad04F8mmK|D0FGsZ~XqFha(r+ z2;pri9o4LdD>tNJe*GUk_Gz!P!Cc#O%=4%1>k&@7X}#2}Y%jhumCXv^IC+~RR)eM;+-aiWg`yd;dp}P};aNUpu>8)o({ljBSBk&73*Fc^K$+R*cjOS|s_@4N9gl(Q4?M;nK9) z1;>2zpnT*Dqv!c1g~1XF&)!jaQ7FbVL$d+^;-c4Wsuh>)|JjA20d~P64v<+$=mlux za`}1f_OFwag^I*HMt0c7waqS6;GO-z84Ar+QB2Ox^? zc~!mJarn2TN@=_z4T*BBnh`NFZCVOUAGfbG%a&oQtip?;O5aiDSdB`H6-%X6KrY~y zI#=E|+x(z0+QOwDrLC!~y&r0+1n?`e+57{b++FWLVs9ZiYXzeh5E=_wsSSe()ibVj zY_c{Wb5bK}pqSRKU6hOy6p$CLj{Nv>(4B7rF^^1rk9CIxopZ)D6c^D%vLMyF{+sS- zhuy{~L|Uaul<&^uUxi@H-W!)eO4)DB&UF=K+tCmGD?|;58BTC+XPu!Y+D`AR-yTl?K?lol?U`N$^Pc3&16R^0xr* z2d6nSy0o-`2c6%cFkUUb04rhwMH`$?8?`jdhX5>Xqp!FS^aC|5bbAlFmQY>75L3`j zO6V#?W5s+Bbz7g0#z4l z*-TSCQjIsNpJ!{UB9_3NIvA@R8MOQp2zB zO@lT*ZGHMADXp+P#kX-_dVcm9TAUNS;1Y|@VO(}s+Y4on=kmAu3`(j5fkM?w!C3nr z3Dje7j^IRZ$WNA<%wagOWiH)>wym=C{I3Zz-5H>g_AyY7q!B)hGA?tgjrtv<`X&C9 zW15}$#CdC)lYKGPC;#GyUArQN?IOyQMVLaQG75>@=>rp|{mmK8S6)jXM8s#LqzWrJ zgSj$F%+;gCG~6TI7pl9awA><{=+2!NI92xs)T=U5+vC+=%(a7wpDyArCcL{5Dd3sz zbWxV~AP?8n!)c!m|D~5<9Ld(%zK3Z6Dtn2u+5)NH zSOChKoZ6fj19L%Nlzh9KM$6W$lj~wDbg_Go(UZMPdKTpuQpvytw<(%iWQF#2`(3yS z9S;%-@gU^uTOUwvQP8_U^p2oHv~B|@NLJFLjNWOlz9p`gL`&=2zzy6e26o&#Q=?p; zLbhXS?l$bUozw#J!S4Y@#h4OOXng68Q3WT03=C1y?3QvmZ!yn_D4s1R@6nE)9u1)( z%`bi^0y$Wl>yB!`n^Af7TnlWY49yh#*>$VREF_I1f90*p8mz(j{foe=;={A~Jow40 zojs}xu-YZ9@&$^TNvEJB;BqT@nlQUmW`G7hs{(h<2or z!sYHl&rDAT70&b(okqI8=5HkT?c`AJ{%E0eF=zV!c`e~&0w?Pe0}?b8oz*D?dc>AD z_}qi=0v?odeJtP->6jS|pPoQ}OX&#qpses5M>%QA(?I#?Au8jgaH+NhPt-KS zygozTHYb%y2OsY53n#gd$X5e3mlHM%!gDj@5ImRqM1nSxHT<2ZW?vURd_@sKQ%czS zH2vIM`DXW3H+^6!0pwc}q{>Ua=5gtuD2{R1-C&O%v`^ACGy~;!J8b|dony7Ax1=xj zoJi||GR~dMWl91N$#5LJH67c+pxR(SfG5ZrkbKv(s-8EG=!aWPz*(s(U49#~@dnbI z?_wV%+#dU?Fj*R8QraOMfD3Gm|ApG{ZQ@A~6lvU>NLV>|_T|jhs2VU<%7||!!i@pS z(c)9IgWxJRb0XM^c(2CXZ~f6LQLx%8$UrIl8#&QZ-!BCi(sQ(1f2gi6=cD3iw>&!A z5@d&l&jB`Zx>2Dv=CYI*H1AiQ7-(SsWJ~SLvU+#zZ3(433eVGYM%{02w0Vx3ZTo#v z%H)8%ruD>4*BI9YLt*&?7!qdVd|}yy~I=3 zOgj&q)?`Y4s0$r04KPDh%G>zsC*Jk2qR3*(lLR()$;P`mvzTU_ZC*_911j!mscR{t z4mc#a&nwdq&G95x56}6%Ckg|cR<|`~nR_Y=Jg^&wLF!f`FTU+UgG<6VnMqVp^npB? zMWP6CeWaxOXh(}H)lCcUF!}U-Okm&}_%$h`?rsQpsYei_^j&U5@=`voWp^W}-kvfE zbvI}h()2u9?H!BT>wS;wI`&{vWqi$_-p=r;29IAB*~bb;W8g~hAz_$$<{mkD+KnW& zYKI3<+tlAbHY&v`K^gNbh!NbVwEc&@u8O=KA*M_;PW9f_YeWCHzl@)IhmB(@_eLI! z#^{bp*QiFrO!a%$xw+EZQ0Ddwr^Sjhyb$ZsD;glKWSfY}o%wugMWD72pu+o7z=Fw} z=r63gs`Pe<@ITJ9=(iB$N;W?*e?w_l zSu2LykBQmGw1}bxK9GH=WwQFPjzGR9_7HY#8yxYJ?g*2$%U&uls7tJ9w#-j@yNax2 zE5_}c+kq8yG9b+EDlhP&+J7^`+r=lP0PYOKhNfF)2y>WwiTZ8A`455h8un?n-w?i3 z>3Jx#Z`0zaZmLK|E#2q7gj_d89r4oxdnxL9t*s~#3o8@~v`h}AeotEbf{i52@NqZ4EA25ryXYS%7G8 zQnpEbnb2<5Vj9zlv_o9rTMbkOO!4Nc*C@8}ugbP}?j4e%1+8j>-2vHdhdG>WDB=Iw z?X$ja8je;Qw#@ei*={y}1bo8=C_UyJ@N-*G*-VICalyW3;yWAbvtG4!{Zqo&TSGLf zOxTri4XVDUW8tdREqB?EsNudU*X5@EoJSLl6ny8GM#Y}ycWG-GqfsV=t#1|@L|h`a zqtW+=#A()_yVY_DAX{)3PX8g?834D0wwdFm=OX#XUW~!P-=d!L;!9xOm3y0thXW$i#Fm3u zOj>KS$hcpy6mp$h5R$En8j)the*@X-tWJ|=5V-tpvd*z-CGOlJdVjff^!sGf zK{xMKPtH3A+?wz>r}rLW$Ymq~(MyZhkGeeO&dfE__#D6P_x^tuYubfSs97+yU2pNl zOMYhHK8=1UPW3pst>B{U)&pp4O}g3e8Mx(WC$$k%Ptg<~@FTX7{hT;Zz#lFXV;bN4 zOvBLG_gf8_gf@1J!L%M|o5V|uKYxJoEIOI=OwEwY$W%YG_yz=6&LNN{0>^CFdE=0aBO#BzAe%zq z9_o>#_ZAJDCy<{ld-gY%bMT|8l+)U>{t$w(G!yIDl9(s(R80ls`eR;nyB-KLYk*37 z-%2=jd8e0^Q2Q0|YH0Vh*@rMTnZr;838K{&vaO*2{&V_ukHhGw$$?~rAd zTQM)g1%Noe{#5!mOFYS=0682!X&7eq1?-bP5z#lgFT0~#L^_%lJ9BTyjzeWdh2@q z6?Qd^4z(YK+cavv{#MKxic>znKJCrKF4X&2j{2W~k+?j^k>q}7A3Ha-KYE?qGzMnr zv_r!&>QYd0(ZGDoF|n|s2FFvk9zod}nVMr1SO5Bw z-#zVGcDFZ-4~wcVNXPF99?uU!$a1809r55yjh-YZ|_+BI2@%(F?1_ zb>rYmJ|>xQBRGYoI=R0a`NG?Ci#UFB3+UDqo69US&O+BaR!xs>tDOl*);r#}nZEmC zXJcSL%Q-K@Z5{#w|1uI+Q3TW(p(n>3%~57erD0xHd>WV`b;833@PVM8u?>q6?Xwdz z^+uA(mNtF^CSY8}|8w(aJAdN*wIz}A>RPbUGlQmI@`nC5fqqD3Ekw^IafjHB>dX2e zJb;?^jtJn?9huTQ5dORT`)@b?vY~}0#Jgw~TzFN>TZ9z`I_s?^i9VINH0tP!hzX9^ z9#WZg1an_1z7P~-b@lNW?(mSNy8KtXnpU)XCG_9$GtYix-o2l!0&qP#7AUzBC)sF$ zBnlCRZAv{8uDN>B3(g=N1ZkU#6O%X!x*|-d)b0Kg$WUmZgIsHL$4D657ezAtv_+Vb z>FZ6!YG4|$2yP0EKNj0o14zh-n9ub>w%;37O%R`T9J06l2pGxNS`_2*<(8i${vJiM zBov1=VLE#-=xFTzgL;IxNtxZ0SZNPGz_#eVB}fpw9}6&FCtBBtOnExiXjhWr$`}Qs zzaMEllvw&}mz0PHcO)1y$Ddj+WC7iU6u1B(m`;hVYP~>NH}oJbT_SADR2ci~EDB0< zMp{>Lz$MT)#i>(E;hdFXNQp$>w5lga_IM;ca`jcq@4Lu@(5ir_kbgdfJvn+5pXv>Zr7;G!Yzp)uVn?S6 znL0nkI`X;X*w}S2M4y7(ZvAzF+jB2XYvObkm-|i-^_Su-9JTN@VKoGNn9@T$bm*5J znX5F&!{J{paIwr(lvBFX@%37@^^Jq{Q5*U>Ca!(H5r(BUMJUCXyrJ4A$JXvUcNfJ}TZW%?kKKIrskZ<4Y5*QtC~i50XKI$Lv4&=!Q5H?_RLXL+b?{tfY0Y9c zp>!?KQsnozM3+tIcq7m_F|B=guSbn@k@^jzIG);A5XCT^(Xqy;LvZ23{X76T$-{TL zQ*|5Kt+LTpKdWR|-X1m99$phjYC)OzChbw9p1tB^@ zU#&uKZqac>)*L*JvY$q!X1!CQP4Je;_bNA^o%0v4ebPC~fO<85y?@0q0H4dl-jRap z6W_^%0bA&qmaSoY?cx^Q^k(dY=@NAnwB4K;31yQdj1OSO4!4>C*S2QLbJ>Wg3rdrBPWUx9GTo*6+OPA#bqDIy|ds&t+s8XfRj-p?q^%#V~-a1E#zQ!__}DY*Z2 ze}4vo!*nfowe(PwIIae@Xea%X^Rzze^4dIaVMoS3N+-|wcZM&h z1`It3sQc-@2B!(>N10hY?Z)KucJVl}uWM4l5Bf*Y6IBk~rm=ZfEs5O5V6`??4`Qf? z1gdrPJ4w-XGodbnRSt7CIscM(R%VIplV3AhyCb3oCq05bNIRWbYjYOxmVo=|Ym3Lh zWW7)`l{?`>Ik#MVw1kxK4|c0$+OvzR;#V6>R-bIqp_C&do7HNnvx#V16IQhnV5Skh z0|M91HW{tmlt1#HAOCt?c+i~(!3pw1u4ij%nH7(i>@n7{_D3`my!XNoDaH`$0q zCQqk-^xjdt%3^OT&fUQ0tkHjx7;KqVq4`Wkz6T(s$QGh03rq&KA|RuK|o5Me*JGTzuEqpD@W_ z7Bwu3@$HG!8a*Mi^)@@j87sBi-HShyS6~i@v_V0@-oxDYBCRYf3kV^vIwH|f)v?_K z<`Prn+zh6QRI)PC27R6SKo*il1<{3&DY6fY<~CM!^Yu~qp*}3O&KAM0D5^8{DD-xs z8_=6bdWYD(B<$V{K>69TLcwDoCEkR^gMLdyHNT5uPPMpFvX8w5yDEwu$fk_{L`eoq zP;Dz^5Hb&~p>b|cZn*rw?1&$-zmESCDccu=q_7IAxC<&=vu*lY=GUgvqdVPqFIXvR z;a4&zem7drX4nFw;ZSJ&U^Z*6+E)hwM#`*qN(uvyi=y3UM0y{2Ni{03VaTc;b z9sVIY*8)rvtYCF$pDB5$-)+7o0o>Xme{zFs5fJRAkM?QCSr&7mj3N8hw~Ryxh@{b! z#DXhHPrCArm=-RW;dBHQU9}fP7+z)BCB~*8qQx7Rxsg8wfG3M@{KIiUXXs48G3yIm zK7c}jl^O+*8y-xzWq&yD#t`lgk`nEEg|Jo!T=DV7Pm}O9JEWKG%(fl#gDNd>iIg+n zC)k0>Jzv>Pa+awH1Up_8>;v2=1W+`4VhVcMu({KLM9{X2_3p|CAaZytA{vtI`tlg ziV+LSC8Ts+LxDA|Ti1?TYId(7+-#&2F}{_-2h{byv0p@o<G&9?ci?+#a*PI??53CNeG*DA4F zV^NLTO8f9QWt|U@>#F71F2N_p7(6cpJ^WwW?gtmjm3+IPTuXL`-^jRNRuJo%A;yN@ zYp%;d_cByt6zD%rKk|(6o=o@uB&=yn*p6TRQM6#F6Aap#StPZUa|A5UY=jTYv!!Uj zlBSTos7q;bLv0QI)~e@ez1F!c{{S$nv`&U<*M+NCNQZvMRh^pX2T6Re(ar|Ze4;X+ z`(YtNXH22FOgY$#RJ8s69MN+P7C?UTCFZSdqFD+BRov?uu0Ev2JQAl64UEnSr)RW5 z!d}lpb~X0=VZwxW0ndLTDSw{-OFD;Shb9Qy_>`U-p<*w&!G|O3Ec;TD?#qEaww(_O ziy2Z^G{_-X0x6x@H0JMwZS#M2XWl+|ovo1TClD&r<00jTI_Q$VprW9d3f$}xYmQ-d z^0qx~3+r^$Hap*J@P@&4#aHIm&7oXN=M9Z=i)%X`R$=iibuRQ zk(NI7i@HSw%ZBm)U4_|Dyo?8GAatFC82b~)@XeYB?;P|dzMwsPX3*R1jcxJL@=>19 zIkBZ`nLUPlgZ*iYLXdxo9M>O{8%|WS?1;io6yJeDK%SjVbOgsNd6UT2+Dh~`)IRgLvneyo?_i2itc&rgN(acI91D7{pPVvJLN)ll%8a{! z&DZ8)@;BZd-;}{f6V%v2pqUG0s+K|X{9`?OeYQ5qOKFn$7go~KBs!}Ubob$C<01I^ z3JPrM*hQhTf?%O?bc=c}SW(xR!i{6lkhAi~3=WVdD<{33AipzChzMiNPPL}ov1)gu zy}HCr-$Lsc+1!hnp1ve8Kh(FEy`*@j=DH02+xtR5>Z6s~%d;0{R)?LrPn$Gh(ZF?% z!vIstMl*JAUj#OR%)Jr2l&|U_WgOr_&Jfjyw5_i-M{)I!87an}`0J7ORgy+1_|#Rs*6!wg!V`Kkx+Exr4P z%8fhYb?v#0U5t%+msy!zCe?A$;L9WtU#x$g@Qf+6II~;HW7kHJ1h6&k*l$q_gkd-_ zIY8fwl67N%!tM~PDNkoTk?3tgRDEyAt(d7R^4V;VXWLDgvX@^^%IAE;A!0g6PiZ?2 zr04icODuDv9XRgc*8<)cF?v4b$~h$ijHzzgGS)N{3XN+y0A-?5oz^Ef_H|*443CXY zR`@G?tA{Ny!e9)P8tjcC#1EHC76UW}79@dswg}k#LN05Yhdp()7s_5D5~#T{y@&k3 zb){iPJU+{aZ{Ub9n!?5ZG=I}HQZ+-n^GM+h^O&H=1ctK^U}YaQxD-F=&o4zFP3w3% z`Z#~?i$04u`B635eBYZTbmbMg_efvXKufRo^{k@)U6k@TuBvSl{U<7q|M|TZO)mS| zbR&tmmV)c!PR?e%%<>-Zr=MZXzjKE?GsQ67c_zxPU5O@7$mqwBqG(%y0h_o2+J#<5 zi^B=uth4bN;3I1i-NhY2>-DhVu1l&EnJ;N4UrPsCyGrRt->GL(Mi=f@W+DXV_u<*C z6d_4)9W!d$hL+@8vdN1cxFWk5??fV^pkX}3$PUZ3*yH)CdsZcdn(j@aB{?fUr#>|ZxO6-wA zu$6}e8&4i}I8Q~6WOjCb^_UuB0lH4PYx=A9UOl?Ctvcxr%+}u_z|q&y?fTfsIDaZ_Ji z`+?+9cmAEYa!$+h(QTkYrnFqF#lFM{xgS#=K*1qB!@Dr^KNcm&sP3A!T%#+dmA9@V z^S;*@_UZ21aHSgOOdkjJ^zb0ha*+ElNT6#}XPQdWi&;bB_OCWd{ zX&WPV0+|MdKcec@#gozuwQbhnn2uO)_j&Jlbb6lnRCa zP#NlO+x@Ny*!D>|=gl6!;1)6rIsp%*#8T=|)!0p-ar6*W;~5?7twYQ@MT)`Ni#<&00d2Yw3v%AOmH{P;?&?$ zK%gp(l_dM0p!{H&6cO1b;-csiQ(Wx9sAZH{PwG!9v<1`-Q>f?7n#>WSu$F7DQ@+a2 zbVuwO_ho+@D+s4NlWi1OSMAM&#O}Z7qt;!JDna2b$HOye%ws41_#Vro@JBY@`ux-Oa*q)Y2-8_6%YioI;XfheawbG}?(F0?M zs^|5Ghw|QK8{9en%s`hYgWXNKL?hn}t3q;w{IK=$hrQ5bNxK1*!%s@N-{5zh^k;f3 zW@cv!#~99yLn37gn_B-ItW0~}LfmoaDPTM=7YAw5DDgv9OBd|MR52)lPtSWy`YgUD z$C9jKUcH;j>GK{$hfzOq=i3RU+yxjb0GlRf@QN;UIJmzGFW#as;Kr<3W78sMQ9M5A z(S)yBh8EoM1w`3oqG-fshxb8m6g2EEcE$O(9dgY; zb^5n_aNi2okEL3Q?{-jMCAaEhofhH`f^qnZGr>mqq|2hFw9D$#p;GZDML`3*`pC}Y zv=P-e6-L*Az>4v=m{*W^(-@0d)Qqr|ZBQ}uX zShI0ZJPXobeZ{XXN78*cl#cXFcg@@t8}L>NG>c0Etlb?_Sk|rHR_XUd^kL2hJo;NX zO6;s@3xm5KAn6NLvl;PJRqBrdD@N)+G3ODrd^G{8U$r^+C^Ps3)S`44MscuUeOyKk zhCv8d4LuU9bRZ1{m~w>0LJP41RjOI^Q+U?i$PSfG!6KTK;fYLZ+{9UyU%sk1N3V!A zh$^d_T5CkjlBW)f1Ax*;zoY#{K`y52nyqeKHkS#6D)vv~fuhg6?L<&;dVQ5rWp!l; z$juLM8K=uv?ys;gi_!K2sIU9ddO;CCrtKF3pIpQpX*MR96JyvlL7}t>8AM8GO&~tA zPZ!+M6D{4cRfx-DzjivSfq7nt+faxOXw#j|L%LRTi7kA1>xVQfb))|P7AqIcQ zHPXN&&UV7doe=Dl?Kv0AAjQ?vJr#n8ZR^*#*D-2uQbzNRwF)5^1~a|RO2oOy*FWge zm>0*pL-Kwj{5BG#VblwIHL~bH>UJ2=L4jQxcKt&eoow5I_#%uAa?rdM%N6KMW=(w< z6U3JeV$E!(2R>W{E+(!BumGg=+OCVk7DLr^d!R)^NT)I_f8*PvQKBp0=>G*@X4$oJ)ayP!3puyn%we{w=K@x z2%NN^bzd}&RVmKtI@`bzKkRaFnnNGKGIHT1za$OYN#tyzgouy=5eqbMe)zpT!R?Pb zG?SiT?N0XEjSlWKqhUQ?!`3w<`e|TW){J6D>h#T52)_*;rp2C{DHWc8(Yy!zN&!rj zfZVn-!$W`Gv|;Q9tuSc88(C#iix zj$tK(S=`ufA298fEQv0&bu&h0v?h0K!v21ZeNJ+>4CvTZI4#;T}ZGfUb{7KyehZ+e&WfCn`<5bLArIcE3H zZNS}r1cd^hEf%YW*X=%P=7^~Cz(X8bAGv?YX&pVN0^14k6$V>pceLuu>K6PM`^(b$ zwwA`}FsaA0dG8K@qVK@#>}DD(bW49Wiul-!Vi;&G1(C9yN>oH)K&Kx{xW zpaP$d67`Homl#!01NxSz8?0p=6ocT@#ZkED43hh~^Ir@SETI3lpMT^8_y$FX_hy-E z>!DGn2&I~XA3{N90$j<#6&7LTEvKBZF-Nl;arE-?v%^d2(PfKNfg5ZT$uiUv#}{)+ zRbi|HA>GC3`^Z0=va$XYfFWGvbx!r3x*F;h8hi`fLGb?`-%b!AAdGV=rf6B&uW{I- zxc9&uzGY4|LV|%)O!L2~hPlNL7LwbFlQr>@m;98CT|U?oY-O!2=xXghKT5xhF+&eb zj&!@PdDIY5sKpl7XU+Z$Y1I6s8U`Vh1K(NjsSgHNdnb93v5P9DI0S#oer1(eN=Jf!;{4Y$fItk5O*@x>vLoB}K|L8d}gQF79`M%R+SIb>fa~t zN{74e4AA)^vU>LbS_V#o^x>{QhCNCz9S}sCf~s>jOkR6a#1wd^i7EK%?L$9KcT`dFojq zqmz1(s!Ev7n>^6^M*-$+SNW-7O?iX_0C8o3VRm3Vc)MlTA$vY6G-nx~7^$Ej4qF{L z1+v@NupkclVKFEu*1>`80EUjhK!~9jv7Y7DjCYDtRT3hB3sxPvN_Kd~m`bwRscqe3 z#@<9wp`M)-4p!~&r@G+tWvvsw=)O1eDhn!f@sczD*B`yP#(svwG~SKE!}N#g{`F^q z7(opYY%AseG1ZUJwJKsnz~av%{Ev6xdTGnRkr)hiKDEHk^&HpbQV3kSf=@dp< zu_RHJDRTI2s7S2}?W4p9LJr+z4=oiU_B(quN_X5mbmela-HV~_PaEk!OZ#t-LUL_E zdzn#v${ZFIP=N2xEI!Z_T6pcV#!)hG+UDISY6WtdC8zYFn-Ot5RzlS-CEj^#A`x*9 zZ%u(rXqPURtPCcmlIwm#O~HO&^B3B>_G53FfF8@bd^8DM0?YkGJo78EXh;J zkO(@pE9U;HG9Ud63Le5)va!2I-NmioBiek@Y^J-y9H}Auaz><|K8hNeEzx}i>(Ke= zAhe?kLpBuZfL@kW#T4#NMMF9a~B{g z1vX1oVuJx(DWvd2FQ{Ng& zHW5U&@<72953S4frN`z;ZwgUF&sE&n(T%It(1KaIcHutw#UJ>&%%aK4Yjty~HAjn93-5l!kJlHHTeaJz*k#wAVrZm|-f(p>D`WhdK1G^VMG$~^KMl;P?_v`N>UY|znuI23{NayL8q-;MzXO2G z(vxbatf>sSk)N^`Na}q2y&lW&E-cc3abLGY66!hgZ-0)l5p+f5|LWDQLo@di-JwN9+M$ z8zRrO3iGUn?PQ7;X|E2c+n_MWqJp8dU@K$C=}ACUSeodh9Z5Qqh(rsPd1cwnm|<|n zf3uq~^3w!W7QlTMOA=k~=8kgRP!x-5wS;MO7%R%(d%6H9(Sml*=QcwrkiSK%j=A_uACtB+v!BE9R- z;t0D*JSDs5buSxG5fNTpZyWb2+Uc)m14nsQhq_j;TnR9P_Dqu$;(AyZhzili=7DB; zcq-_ZV4w%y3`e?J@?lzIuJphVL~8tnt9BAgwE`%bkPq za>}gwGO@@J5^=|vwF|@C*8B+EdQ-!RCzMq_;Snm*zD6Yi{+gIDx`4;+(V(XZ9)}%CVTkP#Ki*keI$MjoXz3j;&j;L74|~2I}_`47=QbSwAXnj?s#A~$nrVm zrix279y{&@k?V)fvUu2)8wKGQMo}uUG#^*^9ul(0vyF3eT7^ehxDA<}>|kl`oh6=; z2Xd}ji7;FcJ{`-CGmB5FM2N?06cj9H8uyvR>@7YEq;@t3MjaJ5gviOuj(vTcmp=+Ai~caLT3Ydm+9k311CO*t<-?B`jxNa zuhZ(0VhyS;)6CNsSysuREAOPa_^ZHFt=BgDeqKTk_;gOmQe3~@=oa0tcvHiOLR@Bc zNE0H2b-G=_fT%ok2br3C112l0LLl+Ur*FRS=6GVs{V03+PDSiK7s zH5HZ-zk0D5=%kVBe$kNDC?bwsdM=GsSxn@GMSP@S--6PRAgqMvyN@xtDTFjyRJFmcX+))oo=05`2-!$3KFF~I3i;x3vo0W-!)x8o@6hyAZsZ<6L^zCsyS!bI!flZM{qM=cGi%w zYlR-F0>p_KHLShMgoef1P5FQBBK7GROJ+aLgGtrS4|0JNOb*bfSc9PQ4MxBGTl}?= zMt^bD!HdQ0NXZoXs1+&eq5ma!t39e=U+^oW(W;d>5s8R^$8gt~U9&$xyQcTBg4-0X zB297ysg#;4QQAL!QJMCxy+nIu$}wRb$s(o~&47o&n)3bGkPcF*lm5fd0k^Cp+@h{U z+EA(i;C?XIa z{kW^xnuUo~u&(wTBA$Gu2Oop{=Idk?C+hB7o<}&=Q|Y4kO(dZn0ci^ggXeixaLOc4 z9AlLZ%-a&tMfwEa%x=zvTj-;kV(NEuT}|ctiY*(0soTyv>=(JFd>5B$OJgwWYxdMk z@k*F~-z?G3AR)Jpj-s>x!jfV;d272MjJ)eFzEYWVR%W!A2=$&k=MA5BS%99ely$YI z^OUes!|^KDF48P`sjj9%nIv46fcGz^Xr%K8mtIzq`?dh%aNn%AT8oaFm^QEQakVo* z%cF`{gM>Y-iBY>UD5h{^jC+ein84!i9aaQ|&#T8;&BPFaF7bo6b@8}Yy4WTSFtq9Egrm~O>#6t|e?%ZM}Ut)aTg#Uk4ZNH-KNSrAO ze$1$q@RZ&g`y9&UK1;GE(7!mc{1WH$-Qs2}J;6efXF(O7z%>u8W%XSqz3vD)ZrD$f zBFY;HNFWFL-H@ARW7$x__t7Jf-OK0r1b4S7)1f_L6?9do!AN$IWs%_=o=b67TUT;- z*NiS8#l<2EY#6Z!wb@?J*oCZx=7HtDX}$&|N5NuLck~*YU3RCbEj7e&7kH3lOWnp0 ztnl;GZ+}2N@LT$HKhO*07x-NxG4gNBTa9`#gIL;mb@61l)EC1d*rywG%wt>km7*o7 z<7t7goGcS9(i;rALJKnPFC<;0gQ~=F8`=S|ic$$99NebPd6Pas z{Ohbwytslx(OwHOlX3c+gAfzIe0SN0*XB>U;$-nIqC4PFyr@ znKhj7p(t^-&#lkAqHnXQUy^pqVCFNa>4WTPkXiXCUxGq6e;M9h$4%RJ2fr%p)HPfG zxvqUe$o78TF+RK<#KLUQ9mBULaJ0=fTNVX6##YARm{AAJ{U#2!Ya)}$Q)0;6!}hsk zkGqXZRp8b}_$n*>P%Z$MFkP5YiBN6tt+?r$6k@_FdAZRnDBh zeqn3P&fs=Z_?L97w(_c)Rm5O4O?h9?O!J!;vo!E92zR2aSaGLl$@;^oAj1ZcOR@U; z-X_&n25bTv83Jfo6r@_-zVO{TC2#D%3t8W=w3bx*EKYrJ1MU$WK_uFO<#3n>( zhTJAEz^SZb0tnQNc?Gcs-a9>78Y=y}4Q{CVu{bo=$0QObK|%iHsaF>)aom1#uMa%5 zK%F#TTcr$)4vmOpDpVY!NWP}SE^`7;Z*8EeRk~eNx$w=5_3VWKSy6!g&x}#!{Hs<# zo!(i<8nY$O4oc>4ZNwFxTshXm#C~;h9FdqoR}gZsfPk*73;{sM-3fb*M>+)Sc8|O` zdb#~j%*F-l;< zXfRDJgFq#*m?R?E<0tBBB*&aHWujDxNjH%Pm2T3QbX}#iq)q&4tq{k!ZLz-}_cr)H zWH>`7F+RjZSuZLuUbb5@r@PD|q*yKTj*J6mtxkl+KNe}7xIQ~g>x|Dm5NYq=BE8l? zj56JkeO7+D$P+tC781r!ke;2<0mkKuzT+9p+8m@I6%^fLN`Te=aE(w45G0FPBd zQ;%d~l%&l92X=3qNp|WZF)Rf3zFEEzcSDO#jfbNa8NGurpEjaL8%3Nk% z8&oE|=elFXK%X6`#b~82mmlu|%+=lj)lUyyBi&97@1X=xc+$Fd(u%I`*Czj6zE?Mk zS(2RNSxdf5>wlsJV>; z5!2E(Su8R7h|<1v9$&NdGBK?V7+54xuAH3+pfm|FO6P!98(Bsxjsq;NKJ!^l4++Wp zX-Azk;Sp@=A+nrXm|EdZ{&cgr(x=(Kb%eU6h0OWm&*#*P)xe@B8JhNIW;FednFme# z%m6|Jmo%}N5g0I=^Q3}w_Ru+$xL#SB9M#gpe$wWH$=)7xs~S;!R2vVF!DFqe?PEB# ztq%5Wp-Q5NeW1>fNibFFcAj<)$!y_>_5N}}$$!Vn6n@uTQ2$k_U+=w$FU#{^$O_ua@xxb0w9Ceq zRUc97BIF&wtX1}ECT_YQ)l#s_mFitz6JQA!`OHLUX9p?p%r9b|9rNd~ZBoJHoC6ui4N%N6N;U4y4Y0UxMLe|(kma4zRvjFxB&;E;lKI2)$jnU~A-oXg4%TW&tt7Pa z_A+60gHW3*Vd{#3I7>wsLZMHXTmu#@RMVDmGc5`p1YqX2@b}?hD&ZN!9a*V9oc}|5 zlnund&B^I)i8s}R@M>eUb7pW&OO2CiJ{eK7q{+;rOEhysCe3iUK1H2&`@tK9J6JXA zkkdh@9pU)H^Y9t%(v{cIAT2kM;bU6|Z?hX!OJA@+$$NPqB<)-DZz96=52wQvMbq#z zlHG#NDL&lfT4VCbpav*nHt)6g=uHu*X`|cD3zy>L+Q}=G%hZootpg!npm)B4@X_L~ zG<+sX(EYYe{Z*?t;2a8Ug>|JFsQWTLHO|{qw49ctP1UCAbt@bdG$v9|h$k%8Z)NzqOONeri z0+JJ!92CAFRr3uBbAsaOj|5)Te051zEfX-vUJFFpqPP9tmojD3)>*~6!d;5JzTyrM z<->17CVNrmE6RZnn7M6~sdVNYuFEQARq3Np^xG*ZV8-*3A1iX%z3jl43C+t)gILtljIP7u+HP1U?R;w|Uhsvlk%N<0~Au@yX% z>&sxdT)BdUeXt-J6pe(QWZO)m*-{OgK-=xUmq9Pw#Z0 zV9LM5#qoLYr{}I(;ks1*U4ED~_0RR&7Y;~>DRJXeWF(D;?I%T>Au%d>--K&X4zF!7 zQC;uLw1Jh*WXUG_`P`DWcY%PHCFKoCpX2t_pJxCJN@D2&f{;10g1*w4D8Otjv4BuPb*=K?D`X_=X?Ff;P>ZzkQ?kxbN?$X zqKAd!y~P$ufID+aLl@HnIU7dSR~M!O*D_xrmQqnCMi9%aLpvPJ_|%-|ZPYs4&A083 zXzmnTGC~n8Q_#3!P=Qe!j%siX=JI9YpN9axSdLp%4_k#E!geDMDYQ_GUj^pPImE8( z{kE=1kRea84M0m>aFtzj>jZ>0U)%Y3%$uPWXL1?qN8mP2ro#sc%ZJ=n?-SNkXmQ(E zXhGTb`rzf6ngCb)Kd(gpYkr6$w>1>lGu)pKwfnBFIx$2GZ>$TFv7Vla#Gsk4b>93) zb3i1KGL(`nE0-2+q>7s@;S!tn`r<=MXHQ`A4yK8(I&G~O!({A8nSh$OGl@Ak5fu%t z(pJu6k}M=UCLWgX3_6_*V?Obl`0y+lv?SuF2BtFBwM3O!@`uMwNPnevr;oh@IQq_H zeAjZjgWB0!r~K*YysQ=JJJtA@d+Eu{D64$D1xUu{uGO zNuWZVlPYt4s`F{a^00Ef0?O-Wka-rn2UXpsM|M^)xcS@3&RT8-QS=v-6IxtBsG4i$Wo~H7PsHy3>&tFfRmc zF1@U`pQ02!aI!htn~3t0!*|)u;1f(?lu^(6gE%sO*p73VT9F^8c*UaB?oAfbYPzK> zTTXo^D)OCARL87cr4V@dPU;zBbO=GJ*d-f01Z<%gkks(nbHbgMK{pkunCB@!Dc%hA zx*Fg}8tC3NQvD|$`#3C^gO;=J?Ez?{*dT(6`*ay7NrN(VRn#qI0m$G7wHBJ*psS>|DBn@OBx4ybKXSa3A}na73o zMq5xaI@x?zM-44Mhg6#4u8!akrr5~-a@`L7iS(F5reK^A(@W5G{^DJ9lZ)4ojd8-@ zq#GQF#fA8!$GZ3mI{n-$iSvpE?sxhQ&Y=|B<={Pgh07Ue%dTFQsMiK&GHb> zk(P+)G~u|QLNSl!G#@6mOOv;kCU=`JlNcR4yui7P}6_p+?t0O?|16&`7 zd{*^*0&Ru$EI~|0lQ=m6{M*+ zT~P!Ry3r!QtX$_|{>3b(YoaB7JE)gLd{*+ac?d6aBuvU)$SGQUlF1--ayUu)7rLph zwL!CHiJ|T?H6Im>3q*K^1=ZwzpZ3Fz%6t#y-wy;1dts3WBOO~vZMJ>x?F1h1djQ~V zHuFDCMMM}G9u~$Oi`yD*Zl{QsT0=z-dFiHGYP&DMp0))~Q#ISPx1o(oIon8{R3#SyKb3Gx#qIvRx)Y>+ zJ^W$=^!=lA-EwHB`@tU(J-W)ko@rk%R z8>gb|jy=Ja_H0bY&MBmZQI-aekE4c`ih3LxZ?tmn83x`1QoD3!B~^0pbvcwe#siS9 zgesHxr!Zfwj_ZH()Pr7R8UiYNa>xP5P0!kw2Gx*+@e1!XNEC=|OE6)?x?!b4;eOxm zJ)1VDUhc<`-pd-P1|lpB4$Z<@A0r*RE2gmlMB4jzqURF_&`ddvpk6T78Ebb-22T*m zv3Qp;8BRwc#yu?x2Z;E_@a~ZV^i2>Y&^6a#r<8m z)IbC4MEO900UO!dsKv>_^+l}&4K?UrNyP0d!_}ZJjG;roOH6AcR59N#&LE6~@&H63 zcU23NYQ!o1O*pZhENo;g1IBsa69J9dNY@Hr)w<5TPPw2wJYNKaS@Y(^2JH>l^z4=6 zhWICot5s<9?s2Z`KbCB;I>zUsmfrV%%FnWyJ0kHEtYZIG`@-&U$%P?z{n$YFy?5>rsoO}^e{U@Dq>YMbx0k|mmw2UT`z2@ z#6yhd-i=CYl+2f3*q{oi{>Qo_rk164bra8=&B}7#IilSia(gbPOYFM)6CV_7$SfBw zGxR+ZyGS;^;e0I|uM$$A7j=0*Aa$#Q?AHGEqdY4w-a@sgi_kb+6cODun3E)&)J!mB z>F^D9pLII_2!#(Tc#~3(bCHQ5L%V$YVBrq;;Evl!>cYZzyAj(p1=DI7g8*i_I?2_Y z;56SBO#k~#3r>13D3oQI=RljD)Pn2KgKjgC#*3BTBmxv#!~GQLY34d!shdR~44sNc zCr}~Gt5P5=9bCbj!NX*lFyI{cXcMV@2$-YpOr{;45nEu+S(+!cV#bk6LmLrGHS@|Q zL0J=gRJUuB=JN}*<3&P?2mjbfd4}T`S`s?H&{w{>dIY4aR^Z1hFKX||;<1z?m#}YP z<##Xsh{AsbP3Z20m+%2p7q0?XN&==|9xHeN0O|B-86svzze+yI9h$*|JJ%AcH~h)M z0V`Rz0;eS4(@<*TVosT_cmT8vB4()t`VJUq4&Uj7%4||d3=PNtD^RoZEiFsP#yUIa zARaPI7SoW>Dh~ho5{0FjC}Mt}ytg<&g?m<|II&elDj&ILmO=%4Ee-`T)9rJKHb8eDi4?j2Y#&;4SxjLt90arAjPs1^jBH0Ub5`2 zt8YsMJ=xTus5XA;(~IC})&jVIsItAy^lK36%&n4g45&l~Cni{?1-|fX@{RfAg8i>2 zNc1R%%BgxF%_NS4DkmqCZD@}A9tW9+3b=|tX$p4czd_YV6j=J`>A%eS0Cm=v1!hYt(#bW~f&$qXN)m}cBbb)-gWoVmjj2wc^WUU*HEqT_=lhd+c>1Oo1uo+LLN-LG>r-}I zQ@^md<+500biJYxXa#d)pHVYdN+iK3|G&P9YL|jjG?Qupa%vHX(e>`#jn|lfHHh`lS!QR9OnI zt1L?RU;b8celtMU@}(%fE$LU?g0ncZKTGNhzi8|v>*UJ|twgd=uzm;APtcaZ46^%4 z?`LXwQA8LtsPI?*Uyfi^F;6+rb{kp!i@t(�whZ)U9~#^Qth6x!)Y}^VQz(z`The z$rOJ-b=`iH{5}9z9^M##yyI_dvKc;KPztZqYDZNF$`J0U5;>f;c1i@+USgEG#@QiG zfL$YYflX|18zF$XR))ER~%lLgQ< zz#*I&?4biVfv|aei!sYbUr-qbN+xQiF3<0;JVLc-Ud9wlq}YG~)oZK)WQ*hJ{p+br zM}oYVZ_fg+32Osb&w_r}GLksiU18pR0U%U>7fh7y?*kx(p=96=gUvR?GqOLMEGLbL zY)tGCNB}bUYHyQT;q&_&^`1DL)>Ey+5r#=t=d`O&x!b7^VUfl|!VTK5EzYMLzYR1s z1W+Z6H+w*5gK{;*C-mYgG_Fn}xS!AA_>B9kfOlvn2DgR>kfv1X@VrP;W}E*+3bkXS zl=Qn)L0DTIS!$0e7AV^p5dv2m}XewYO3&RkMDD+<06J$zI*mM zki9Gg-R#v*5H)#(;dP_l{%N2;`lU_j0)$p)7lhEOV2b@K>MjOG`j+OX6Y(WmP5 z_4(PHK^P*zx&O7cy9`TRVE2T1M~wl<{H5Qc{dahjX+t-P{;1!oCwYLS#{Y&_em{Y{yml-4~|Tch14hb!o3 zkrcSQepLC~tsfk-L>ZOrKhW5CQs>w7)SWZ47ve$Jrt#(KODg4wwW-mvV=~FBtqzm_ z>OfQP+V~Za2z%MTbWNO;MKZ3DSL!YcQn{~mE2p?5j)DwE0K4rIu}8H!@!`JSbh;8$ zkr?`K3yfkMxVL2e^vqjDB1>9H?y zx75I&HWqEXeM%0zMdDcdbLr})o|Fz-(}p`T0v4h)e4WO`L;HW!a&5!@1AoTZHHEIz z5$Va_Z%PvL^~7s@gH^{4+GLq;aSsH`rIZbg{ly&VrpxuO2;YW#%AR8fL-D*HGgsu0 zZkC(Z)qmkRemY@Osxk8QrtR@$DBzUmeJFK!LWHvBTg=`=u6S&1hg*J!0=9)WCU_>_ zAs{5vQ%k9by7!XnOmLF<3SJkscsHajkLkW)*DHf*i*h?ZUt^(G5WhUU#*SNeXC-9qM6*UeG=Om zz;S%0?+7c<02cuM%NWqN!rZ>1O9Zwd+$-;LPpsGCX-85P^$V%xQ{^PYNl$uy#Xw(&dy zJ+O{h*w%7VN947Pyp=m;jXc?p-L4>EkMvW59)vhse^ymi7xn-}UO@4`;1i*Hm{ZD; zR{@fxjpdH@U)9VIf6mUUQ6^z^I$s?+=wP{uf0l3NE5wtO52z{Ad+XtBhT==sbgdc; zSsN_Z4=G_If!Iq!PXbxLP?KdaEXC`jE$S1R41F?@s^cO_;n0x2cQ>lcr2ZPztCdps z&coC5x8o3|vW2dPyi*eyA{1nx(oT&wrHNw4694M;0>&t7VNA`*sQi$0mm-x;gHJw_ zkQ&CiK*lS=>*=02{6j5$RJ=f&6LMe2x+`dW2wWPwRIgQ8xH^E+d4oqn{_NP+4`n@4 z3Dhjch{rmHQ$xYNgT52ur%wKYc~3v1MBiZT`73~~=Db%?EJRihSkfu;+S&Le$tG{L z*Mo>=^MPzuIVI_`cCQ+v#f(JLk6e*}X%bRFIx3jbbX@p2#M9AI0fiiQBdzL?yF3jv zdT=*tt+*SMt`Q)*=i`e)7ki=|9Vj}t?EI_km;{bm`de*Tnb*o%5AWcUeWe@^{ZsOE zP$BmX{S4IM+)-y5GU)o-OPo^iD9``7u$_Tih!quf%s!jbdt_VQPR`fmHr9iO*o!i} zQlV~peTBMW*n)vuF8InBY=qR`ifn!69%v}fL=Nl%^MRX%$w&~|1i;U2R!B;qbD7QcZeLK&JiOAa9ND6K3p& zM!6zwo4ftPxZkWFcX-cNPsz^M-*=$E^>Dqv7NpU#(IssnF`M`~^|hB0s;aTO;8T9( zI(0)PXYWLhmh`{n&Xhs+<#8DQc{piH9rBbFngM`Hg?h(Je>*~ZMmoREU@!AD8!G1M zI563K3>sUb*|Dy%WCeiOEvB-~?dBnc#p!3Q($TZ-V31EcQ5$~{6YrRluCw=CVb6QN zISIaJ_s?9Hlp5q;QA4?DT)G1K=@t8QNJNM=mRYOaCpW+1k)A(@7bG_Em1JqUrb}RC-eFSBB-qYjBBo z&g+^1=TD?0c`XYWYQE=EA})b`Gm@Lt`X|-L#)3eKmPz8(Vb=Hyx{@X6k%)kqcdIpD z&$Cj%Rz?rV_3HhY4I-2m@J<#(-o;`2gA-wteKumXmUbLFLN26u5ouY}iH(Jk8!vaF zh%ynPQsc=C2N)rfSql5eWw2#Cnjf_#2|3I1Iy#adk(G&>Um4f&-2PbPmY0LD1QwVy zBBX3%>UM7a(=41uw&VsQw*?epj?4_)hIi+J`OM}!p#kudzqI+PAmllRS{|| zxT$|%TNR5I%ulg0XK#4eBnRby?z-m^!{cI0V{(m&VUb~ zvZfZZhFADw9GXS7)#QYIyA-`EG2GlNc!`?jZ|5mfnL1}2S<>?%OzgNxj{vHknm&hu zT51PAd~8%SIonlS_+}p-U;jx9tKJhgNifQ*>uzs}BM8S57{08BpswB_Qc10My!y<0 z*U3unkZ<&L9H!j4izZ#Sz8MuWG~e&jS~Cquu2^R&`g za$A-oj5du=Az#|2Xs@;67qlqfl|P0gwj8_Xi?2`pa)v=O|;L+c`C ztSkZ$9-tb^c@E3f=xzk!g+qt`ur_3ME)jU2@3&5nj}dA^^>6?am2vSMYE7!$%uZiy z40M;+^>nfm$2MbYh0KBWow*B^Du;W7^*5P~oDIbpohC8!XEGjCBUD-po-cM<fc`N0v8g9lp_hsHHu>lSEU&S(q9SEJU} zH4Bq4(`ocB-=+@Ac+B>?+rmq#mgI2w;e}(cEZP4P>Vt38j2gYRA5Hh`*P}a45=qLh z$jKqY0raV}$_pE~TbGBFOw9+j9PBwuef}R`WlJqgxSX{p`< zQ&^$Y-P69mj3B^pL=nq6QGNnu9f+} zxU|MK>+V&k1Nl~0BW5~qYbKuiq2$lT|obo%V&yX>Ov2m87H z*~jJ|sgBZrlDZ}3oVnGAwX!a=Mh+nA$l#@Mn zpsrKblSdRIEXG2SlYJe};5sd6CPRk=C%iY{0KcFRLPc&Gy*|D-J0kyFA-dL-Glb|E znzE~!0KsmV=-B{LHcuOMJmcXLk1iK&W=EGTZN96FbF)MHkC4Zy+Kp`RTIg{$XF_ll z(*wbmjoznw^dJVSZ3M+Y;yuA)l`kVQ2hOdX*p+QNKo#kz-=o{ZdeHX!FbZcd3{gQY zYlpsfmD9jBe-Mb;Li6#zjg||P2nVZc(x>n{NAc=m@mB8ty7V|WA}=EZNfq;QcCDmc zEvMpWGMiGj??{3kuGQZVr)~K-=-6u+uEx^_$G;(uo@JwLN%-7b zS?vP?f}HxV;4CH0G5atXVWtvaVO5bzOL~PG(|>k$l2w69BBtR`Nq))DB`(fBW7;XP zxIKBY7OriAaO*YQ!G;{-pX6gOsV$%yD5uQ<-MI(|o?iHWzQ?f=&E|N3Tx}>IvvMRHH1~;ibbeBvZMyEAGynu&u*g^v4%M z!XaA0yC$`9p+o>eefzh<1Ft>buGPG^1!Wn{y!^qv_Lgy59KYa&xvG`25p5SUD%9D4 zi#)b0WYR1!uy!z};*^BiQB(MTet6RrHV8NPq5ou{Ip;8%-_brRk^7|NPC_hWx(?;A zf`$}9d|K)Z7M#L+J8E)#TFN;8mEDMQEiE`&iRW%I8w`c6#bHs&V@ltLA1b(jduJIz zKLuL5r6G9Q-T<#)X{L}cm)diV;2Rz!$a2cQEOs;!0X5{~Sl+c=+uW<`iee=*r1pPD z{Z<%ujDe{qbQ*|2z?$Nu8|t`jsgI%yTh95>2Bh<@1>`O=wW*jk@8RaMm?O@1nu>|V zj3*_W#Jx+kK%`Bx;W(O(yXX1x07pQ$zf?B71{jnM7SKNOKvN3Vkh?Odk5yUg1secf z!Ps8^TFtS?MteJ#4`{hW;GAntB~LAbT5jV6f$E>87gac1rJjTREgCRB@u>@{lbvfXMRUkAdonC&m7lnW z;^||iEyCzasz`i%QXwZVyT$kcFSL<-OG}P-dPJt6>pi|?6C#23fh5P=XtaV4_TrWq z92RI~E+es9O@7W%NM_;{_Rk;ArVlQSqb5spc3_gzV8hn%F;Q*_T&mb>Vn7DYB{lxz zwascFQ)uZKea1s_X$e?=R2oO*QjRr8X(6Kv&#*O3^h~}ujsJ3a;giRN=-4RUl4uc?hdzz$E~vQl^tEdY&E;!pdhC^HfjrT z2sJBxpwMgBdK6_uA*4Kau@_T?&hFp#Xjn{IloDR0Yd(dnar2CGm!;;g+j#Jk_-uI7 zWTcq1RXgIqmp&GAbSlx|upN$`DXNo$;hI~PWNWi24-~!?MJt!r*~(A^ewpx)y(m5ai20pO?FJXhE^<9jCie#KcL$CjPo41Bo7TlQuJuY0 zNdG2x)%Ih;{eIS4*6Z-SZKQC4%6}WZ^X?B>b9JfN=_3C0jSXToBYJA^7tEaO-@y2` zVVTHih8vXv|2%JL#AI10o=G1mf$5N_t=5NOmKI>BVxtOpO@D+#ZE>sk(OeN>{SYb~w;p>Jr%Dwj!q00=56~(bg(9U;)oa{oo|aVqQG#A>jIXq|+}RD#rU^rCSb`Zdb$;*ge%L&ZHeB&gzT z^$0mcXUS_BJ;&8v3(R!}Z%SJ?gK7&WoWVC( zd{CM)>aIk~tkj|n+8ZZpOVQW5f)VM1w|eSq80O1_95~uUKJ|kX3gB7sYO(cf{s;0_ z{1l8S`r&cqO)mJ~J`-uGrii*M;{I9>dH)LFK7R_XTPC=MwF7GhkDsNUJ@faMh8c86XEy|k)r_!W5c~Dy742r5wkG>TGp-YB=Fq+RFIFC zlTMT!YaOY`_Nn$-64OgrP0*M$Hs?~ol_2V-l9YJEGq-T`59^mRE3~n(dnM|#SlMWW z-&Ine5*-4n()gZ}G;O}M zW8z2$5AK@t#(N9exFg$GU9pIQ@km(68}Sfy9Ob9z27|JKm0*BudI!>DPe|vo1TIb^ zKp%YtK>L9zQO}maP=lOAs;j-{RC1BF@p zqPdbWXnc5L7Gdf=i01(FVKsYn75_lwi2ii}C%qhwZF>UYrLff|#L|U6dru%^HjD%l>Y?}WV0^cCoA9wn!%nj zdVntW#u7*6$A3O(C1Olz+tF6CkC+w7VQva#{dGN=O8I3tNNedbQ*qfthVug0bu&6d z-k>OG^4YJCjxRUk-p9}_+qS>oWITsgxC3OWK;JzVOL%egvo5p7sWz%#vl$i@+h)}i zy%c(44<>DLOq*Utk-xv^H)B7JggdlzVGD;K*6DR{cFb`&e}Lg}R?XA?X2JgPWuSzn za!RHv;qf_Sspi-F@*|!L@GAe11QZ{}60wCXyhbKwBg_xizC7BP!6yKJXz587%FYjB zsw;Q-!udc|PMY>Pjrt)x9|!I@iA8VACRrA++1Cc%P5i?SbZz0yDk%paLl~@~N04Bc zqbk4YRkvCnu(Om%6;!mcF$pa+QENDGNe-o1k(6sk3U%Z#{cbL!xH)KTG?rRBoZfAv z)$1MmunQl!l3H}!;I(?5kQHmlOwIC-CMpg-u@G#BHL>Q#1^-9yOr$dlIkY5}GIUOM zP8!CSw`x{4vfdsDU8g6>9THXW6WVR+v)FZNivVRA^tznc$>_XC$jM`~HFymgi*4`q zi?Qlu{_q)2_aLPkm{!K6duymjS3>YUhkobF8(dOslMsF)pm`juYmeW8@xfh-HG#8b z{^N2=p86rhZT`k1=1<#UzH~@GO=L%9y-1x^Iap6p8o$NJUL_|JM?fCS(xzSdE_s?%(Ok21Mmp%loD!^yxlpB#&%!<%Kwxhh}7=wm`fIf)Zq`Qooz zy};k&wKV5&<8`GgxDoIb?%S2`XH!;t<>M2y>C`R@L^|9mkifK}b}{;c(5yE&F5@OJ zs7#B>7&u*%EacmuXfdlR+@onL<+TC79po5`pZZvzs~S$JZ35H^Blj^CixWScDU)UB zYIM{C#!UK#P5DKcTgk(%Lhfg}uO5dxgU-t`QJ6ptnlmzLgRKd1+}ky+SZ>y!rE#gydH9-Hi5G4kmmOi;ZhHWe zq(OEE390Tna5ltYFw{SOz@AWrONs6%$rVH!)yXN>(VA+LD@$M@cX(L<@k5n`?pfRF z!$=V(y|WKEuFdvyW$Id1FeC%;&~=0iDYo;UT-hA}1P;K-RpKy)Pim6*st5z-Wsy39 zSKe)Y)fiqrLzI;?PpNBn>(gHmM_V?$AG$fq#%gWQs=pdB;9cG7Sy{n@R+Vx>#bVt_bGKV=d6hK`|C}sdC2_@Eq&@ORItx~}}3mP@JE|8eiPvXmk z4blfwWs7k*aa665`WOkGJ3jm@b<#+aTOsB#6a|l@bg4Uy1)Y<=U7*`-aax_f_K(s6 z&3HMC0br!%3%>zt)!(BZG(XPke)U}W@`%l<3kHuVzWmZmAHbt8gM4A+q_CW8E%vlf z4J1@`1?HHGgANj6wQ(qeq`ixqv=@zyxEGeKvmO#~Tc4B}?m#lP8Zz4AA2EoOw^25Z z=koe0Sz(@0oo$&U$W|zK$a9zLE5O3(?9({{1w@4A=e*q9kN`8Z+{Y!IwI+LJ{CMjV zMMlv;?wP1^Ejp(w0lZQMIjJ{s4QW7w`ooA03~UcPfHx$Cd|NLqo5LQKi4;y^B(TzPGB zR7Nf|lM+v7ORNz9Uk#r6@P7+3Rv_sI1*&@s+rO@%dzM5iPCKR{%EWMvlEv&R$lkw9 zIx3LLQ@79|k%Wy4K=0|zCV7h<5ZEw;5q8~uedCY|l`aNGvdu4}TTdv9C2|YtSk+10 zV|0~O{`^u~9P7+&*a`VB2x@$wVagisolW>#7T@r-oit+ppjx+DgwzQ7@0sioTshYa zl9LYLi3%r7HuozRmMRyuw@r|e5B>sL?xbnq(w5HS^hXyR2B1ZlQAl-?Aa#&&Me#jm z4UNOs<vkYCWXAu~dr0-fjmiP9e8Kv`w=n=(jQ)mfO;m0~52%$^+&x|d3OCVe ztyocrn6_RUKq0gS`I}E&$RK5vV{p`rxb)kyDPaz*dgOhF%NzGDb$gUyVXI&l^yshG zPdX1pmUgVaHFhm9tZIdkp1FVn3ci-pz9FHvc1JOkPIRcF{z{KTu|ktJDqWRUyuL-H!LUG3FR`9qL$lx{#d9X64yNufC7Cgo|yq{Azmf{ zG8p~9Gbn;c*7?*Ir0@MXJ%9QEPHV~P1Dh20Z z(~>}$PV=uV%lP67_fRJ-iI*523T`VAA z^<9No**m|LhIHvH$wLhZt#h53xrywjSfbD%yF9sv2|y%Yj}-)_z|Y|H#9(2oh9&@) zA6~8W+GJbUp5mtrO?9DRpJAn$;=)N+0Y&6P@zMJbG>s!8`I21sJrvc}VxME1Uj@cH z)F9(%pz6Aitl54~7*MG^*TttNb*tVf2#oePU%>G(1)UvE*J+<{wOB~_6q4xhJ>R(= zuLXoW^qeOpb6 z{=yAsR8%6VDjNI9)5G3*8PW*Vk76ZAh8-O=*2X-8Agq_R9TLAp18bxLnYqD=sR0%) zcWCouO*0&gmB$!HJy`m~?5kpRjS~#;ZhRkt&e(v)9PBikC+3xV^8ZbRd0ZQ`FII>& zn7uUy{M-?G1|SK!(sf(zCK_i)9am#8ma3$3bMB3-hzdzyk=wtX75U^wz1Za*GBa&% z0X!g?LClS^o**5vA33IqMlRBdMv`k#-}=-<@_Tbs16zc zaGo#ulb5|&1h)%BMD{Y8+9~R%Z&6@r4?V}#-+V@`e&lyfKfTNI%GQ^AL?*&&bctYV zWK5|X^I4AC7@&&Y*Ya-|N3a8dZKhsttkTE{9XQ@m57@!+KoG82)^>`S+^F1!<-gWW z%+qU`uoQB|{-H{X!|_RdNopD@My1LK_B@`CO+?Z0DHTWZxbuNcwb4k{uPkA6H6sf%LRtuT7kH>zh5=CsXosUXJRzy z){=6uklS_0Cc)CvY+nM1J(c7@DIbz`B@(Ppt+&S0ZveOc=;2tP5Q1o;(dSdzXv)q% zK;NaNp#t!P@_*oHcTT1D0&qE2G`#V0qOdgA<#w-YUr)Fe@8?7B+$hPBMJt(zr{iAX z02&3lBgukkGi$mE<2!1pw&@MR(zDoF^hjQ4JV^n&9zC^LoFTotkvIk4x8w%yWG&Z9 zxrOUQ75;SJx1bL1&UWnq>iEv=>G8*dKgO4PdHl#xu zRWF^gN&HkupVgsju7BZ*ZB=UpJRAO>6l6!H0Yk}okTny%V zOolx)1#_`;(`$nraH_=bm{5cD)LPCIH^yhCTO(lpaNkY7K)+;f6uGu)3vIa&z_H^x z{SdLwewLqy9Al0d^kl0A)G{8722y2lFkm#QQ%-!fxHcy6!@i+1_&l9I6UU>TSX%2# z5Zo`iqK<#5_E^N@`A*YaXxcs#bJ8m<#e+ZJDh-elRq&MYi$B9EFs>j<6zV;1mCKdn zV06#@c?{~&s2B;nI%+iCvNgrKeGoM5@`)z z^M`zfJs4<*=Y;)8jAL^1LHZ1?%#7017czz;ht&Kqch~nZ87`@nT5` zL|whV)B=6@6(o4LaBwX7KE@?cGD0q&X59tMifygYv(;&rx zuu&#L`lf2@YwZa1_F3o?N|R4{_mixQP)Q}OWq|FSh^6HMTEzOTa&hb|;fW06K(=7G z6paKDS3=ADO8=x5>f>kCkEB6szzaVN!t4yFRujmOW=EScI8avw=ELbDc*x zwR2QO4n`|PGS!LuP4AWW^I?(?tYR~(gYLbrT=jk$`l(;Rn3iuFieVq-bqw7wXVf62 z*@R|dT*Hh7o=-x08A7} zj6TZ1Y1n2n=ur1~K)vxyWhiO2Tm_%A!mlW|PrLJgzgEeTwq`KO$^DX1wWi#_*_`l`euW5wWmaUW}sqSJRPx z{Q>>bj{leDX6+0Smrm4~_s6X-a^hT;QORiH;Bh&WW1Xt90PHx^rdSAQ9vJKxjiuVl z>$VZG%yQ|^zwOA8qW<<72Q>E`WD=Ud;!O5|?(J~g>-BgBfqjeGSZIYxW$O`{BAi(lRe=DY2sm17&(jbEHD!V35)9Pgs6OGqvV z$?lMiMt_w@WF~7DX?(pe|GUfZf3E@4ow>wBYV(6BCNd`Bkk(OKnb7)JXu$UB*gFO# z-!0K^vvSe;tu?;ORV$q+?bE3aW#O6Grf-X3Jl1QGXa)?MQUEGDZck_tdg$OSf}J8^ z)LMv`&ZgM%u`9r1g6S%NKo=V-#0HIfzsn(@Etd<3hn~t%2WuMQ$E2Rmvu*-ZJ3X8E zJztN>2bGJeCf>wsT5Ua|CphGw4eV`;*K)|0a9Uns|1~otafaw!P!ZBuBTPuE)1>}n;jOMJ&KnidqpeMj&sDek>`Y(j+ zi)CszTf|-z(I=ECLH`1UxX9rgE|QJQNHyC+hWylDt}UIx6%L6!*x4H~9WqT4;*Y{5 z1Ig9>M*%qHFdIZVVisK5sVh{N|3USsdFWB1$#9(AZ)`i2sttiI4E9Fcy927nJeySy~`QCPqllXn|s7`_7t#8~o7MyUcHTv3_R*TCr9B!V}ooNe$$?h|?{F5w_pF}5+PSfl~K^)U8m+zk?cwg>zt;NYeZ@g=xvI2#7K^cHp@qR2qL?C|8Ge zF?m@G4WUFy4JA4k)0b!Vp|tHQ2;*^8dHDOGB=xV3*WI#yk29I<7};^EuNU00JNqKm zy>@|QYdp{_49FSs7D*;HS1EKr7R^#_&mB z_|bjau2I+>(mecJ%(BT;N_So-{SHxjA5Ft(`J&FpLl+NLz0umgk$yP+@#{;zj#DNz z6c3ar6RF9JgCB8AUJ%0O#tvQ;B#^wwjrQE6e(o=#?k@ zWYT|MKj$iNSf#`ViGjTu$p)1dy>}7uz4kq}tb|&d za^dv_hmiE&g(BLFMDIk%=LSe&CVko~PMrHu(v*+7&V;jx0%8`BKb9fxKxClRDhsbm z7M*brluMUQghN~K6Irh0!dn&R4OeO@4=V!&0fNqif5h+U+^_w25W75klw3a`3QY@u ziELwXYx11=<=IFXF^6RA6*q&iu3f3jTuAC9iWY>A=*y7rDXrOb1~0G{x1}UPxXhRtDOqpRQXK7xEnD!)P*UCRLdULcCP9TYTXatE26;`G1&(1z*elv z&-{&n82Gfipu?lr$oMp{d4!0gGphGIgc946bOYk?2dy-wvjkTGOw-Dn~aLQbu^Kf+#h+@}5( zImhIL*fm!&E2;OQE!KxjrJ{|8%hAfw9T?gZvt+n6oK>{VRq@NGZaR^B+$ynFT9CM< zyd9uG=b5{CQ>LE~DxRMZWt9EOs|s9F*6E#UST^E_7zZc21k6baeY<1%kBiI%6K<@r)uHXY&Ns$rMP-i~2B zX##rCXYFnz;KLF@a>l)Qs^S_T07iKMgl~|f%+UpXJotMUZ}v{>Yv8QpM*$wZUC~AM za1Fx!p5nR+c=q4J;X*kk`d1|K2tT7QANlx%I*}TpV0)lX%{zd|pWLQZO&6UPyk7X8 zd$l#*F)~a59<405E&0oTMO%5HIwxB@q;wIJ^Dj7;&Asu!@q@hgRT04FyPzQLGFplV zXV?Y1bv|~*wl1u*I0CN2htpfomYp$S`4mUqbX=;n_h!X%kfmRgdc80KgqD@&Ga&9h znCwC>X&UZ2?+qr6$|xkvO*WOT9??$)tNSlI2vLJF`~&dpmhesCE4`k^_lOQf<63L8 zf!?l+$ELQ40s7&t#f)NhWPJfplfaVt$_b={=%h4ldKD5Zh;|Bgyqlm8N^%PTum z&?2EoQX=|I4U98YcX^kGFON%SP;&IChneFA^)czlwq8@b6;vH6SXNr(w9x|lWWsRPeb2eAcu(V$J7(^}yVjYN%Qj9aw` z%qE;9yhsI%8|~u{mIdy%T-$~^bHz=bPA}9E2qX`AKkR`v3p#FZs7|m2KoW&91`HOM zNMyNX-oE5as?;~enmxw?KO@SzpnYNfxV_ykCH#s<6_q# z_zZv~PnAm0GfU%RE#H;M%bG zdoBeUFa5wOQ4IKpeU2pB&sNn!UgT`@-pVG@2uImniM6tYNsD^XHpDS&4?ER2mSvbL zC-GoJdm3HDi5UuK3I=s3LYnt`5GciYrh^s(2W8r>m6ECF*zZ6F}0>tZQ{q=dOGRzu9ko!?c^QQ>Tw zP^k00@FaDcEUj_vN{9U1c3h^2#PEPh!uvxfLrv#aJXMJu^2XMeB`yVIhS$fKcst>j znJYy2({<0_(FD3QNKNuQvj&;0n#;JA-fUTvBwz{(TnV-R&KwM1(|LO-pQSlF)Rl3EoABIWA@I zMBYB==~hVDDxYAvv8Kq6n2`mTE9ZVvV>c|lp~JsE;8~g-f-)mFicBrGXA2p=({NUH zzz;ZZ!bRwAW+8CjR|9ZPLD!W-sj8e`_kNfnvq{FVHZ_&nTiJZVHfGO3K!V9XDPE1P zUfkEh`)D+|5u#97Guik)eq09pUS5iffo9nB!l{BtP~5fU!bJ;}&%I~=Z`GoKbyi2C z^2rLQifph2|0EG#GW0KjHdr5z3pG<41IEw0c{HMm;sqlvNIDIcCeEMY*8=bpM!E&D zI@FVmjfRQL&arxC@m`^LJvAYnSAl~MH?~VURqIKYInSpsykN#-T|1Rk?`aI4%)-iP z-;Zqwu&_p8sqr(wm@AX0|Ek51A%F&)isx(nU#Y+OCMnm-1_TJM2RK91-E2x)jj}b1 zQ`88>-9Sf}K}Q(hxQQxIBbD551a2}80gp~!0=}J*$@B5R$}r^=V65u17rJkH21D^1 zFYF4=Z7gwb66||6(8@}HCl$%*jRoXz`%<&q)`y5Z_3lLft%t7qD3Z!^A{^u zi+BANhhTtKb@M0C8RY@=AmaZ@y%(1%;=SVoBV3aGqf&ftB8T{2gm$`$k$i!Af!gd| zviq3bp5_8NK0alz9;6W98d3kRSz+JrA5fy|k3yYwzer9A=ule_W((sRzaZ599SZL{ zhUcsHpTUhBBJ=>Y0B`7{D01_2*@0ShB`Npha`q&3q-C8f9ease;>G?KwI7OE3_Ip- zD$BmTj_{q%Hojs!sWIsX09deSER}@-7W?HS07>a*;D8M2P}M<*BTE`mb@1V1z)s;P zpGg>XXa=-dI{vVgs8dGzCAl+{EbdEy<>=b>iW=m&UQFRECCpsDDmx6uh)rjY@Kx4! z|DOPt?=87pH+^zK2or<-3o8$3(PEC>4q45+4sk8hTo%fmUWb!9rWf1iR040;E3lY^ zjLtf)=nA-GQ01X$xWzRzEHG1+algXuRr{3W&LobYc;Kq4csO!K4YH2EVI()#dm=`+ zNc}F7k7T?>5bVWRfX}&j1&<->BvNmof7}+vw|Y4}snx;Q7c0i?njOmUewvs!T}Afz9|FrMKfV*kUocrV(e-J7FM*kB>Nehe zUVG_G^LZRy5Kgt--cK@5Oa~EOVGWp(tL+2d=_5yZG0gaKAX~fQ6DQK?J~RN&o~l=h zoFzAH$1lCiEN!fI`x8=3CjyF+7K4bB5wXNpBO8IOplssR)g%_4G9KN1B@_!&751gY zg-0r={NJ&rGy$~NF)5f|zY+9^2G^hAjT3-&F(ZL9%z)KlA@pj%Q6}Mf`pJznBi_LtG5b9Jn7& z1sN{rV9%avWTpN#-d}^!wm^>|z3dRDPLlp>k zm|$%yAOI|ayWD#$MSv&n1txjq@q=k*PVJybW$)$3)DNylBfTt6v?fHr#*nemNh?c5 zK?PmFbMjEtWJw-sQ1B3qP$ck_@=^WluafA&tP$o;Z0c=uxMP&1)JbTLgJ4P?IFDWC zCcAb3|9H7d=lN!Zj2kN14}vt>-~g%l%YbP}#Q5dZo+q<&Pv=9xz&W3JS>VH?Rw+^VmK@^CY^8dW9bDE;(OY;pXh+0U<)F)_ddZ9Fy3sD&${rA20$OE6z zil9+*p#dqYsYN`q#PSfE{7v#pIyi`SJMn9d1HY=lx%fvdylNkNZP)QJNWcPP9L|&YLnzIy9h_r**@Hm z45ZYQd)VBPlplkyay^*54BLLcHDjRHf$(Fmw<`r+{~B zi`@gU;8SLBN^+6g;j(N1W3&WE5-k*$^~`} z_yB3yG~A#UKKE+UvG`LX_kOpE|HLJ zwD8?`Qk*_46l)l9((U{LVVhV}@z~lH$x07TE0as?EBDw4smh7&=iEFpAyHsA zi*gvbJzgGK3SS~I4PKAny48`!S7AXhVxh3&Y^qIAgp@k$Vm6>Eg506=N%{}59$@_Br`;!m+P znLBKqfA&1XhN|ZQ%d11n$QFc<)pUrqMbIYV(V*eHM{42|#(a8xWB@7o`wcVib_K1+ zZxaQgJIp1>bGSCqq^_K6%0qitnZP0vK+~GB<(F{2q=&wAT@3QEm6E^h1ZB*eMjbuo$~H1?QMSkA!W>X z7Hry|PO@hAEOKA<&PgguWwAKTIkfFppTifDr>j1IEgKll8!{!*Qn9CIwDK%lst#2D z?vO6i#s$(gOZWMSo-4fzjHsR_P1k;Bf9=2IlR8uODM;t2*tzP@9;*%Efl&VuZ#4HA z!FqW^c_?dOJFZ&KgKn3a(ZpxY#CXy?8}>*9_(>zx!q8kgm_kH4fCjkqk@O@Sp}Hfp zrU!7Tu}YKpLIy8c!<509{g;_jq@l0KRI*#*am<6wAa)kIC@T#RZk|zLrNpf0;mj2V zTp0`Q6dzIOqAOx281ZizpHb9S8=bGD31_nDO%vlJz(#+Mc=$3mK$0l`m@Bm_KtkqD zh=5HOOg?CQtk#vm+^V^E`EOzfSu3q%ba65O{*A}_ClUtlN2So=nV~Z+UcGM$8TWGD zg@qEzZ6AE3(C>qO*3ce0XXA|upJGw5-Q=e-4d_QOwlJ%7e&=!at^rR;%<9!210bA^ z3G6s__iNmMW`maIN*1SoP6-IkWV}k@=ay!i7s8J*&Qxl#=HVbIROKgVc+jo-Vh>pN zP8IWY;(Ntq1t+<^=e%B2f{({W#4#{IA>V=Kx`++}vs=45YyNxlYNWrqpppwKn}J8ROz;eZ zSuteq(s<&sdRs5^S=V2QqQj81BV#EKhf6&E!~6!>*x)t}-b{9_Rz6+ag-Pz00)bTq zpGmxYg-UGqyXk~^B^*{)sDxPtl3X{7ZlBlpUb>8zhdM~BqixC8 z0x@pq_c)__|941`MENyf`YYYpjEw>>puZWQl)k;R{kUPq+(nB+dy}0Ficg3K8UfaG zW=kVTtrqTl81J*vR97M~cbzJ+$-X$W96f{;-g`?CV*CD{g7 zM>ss?^)agfsYy!CI_sc!qw%-l3y~?5@gcfys&faFZ2N^Wf`D{3KDtUr(0V3tI2~A` z3F6MJz#OPABb0L{+2!Gk2Beo;-{)Wk~{d2pI?P%Zot^tVTP12jlKQ zs}TisPgY9uWg9;r_Z_XV0JDe|DMP(~A}g?^Q~AteU60BbtM7OAXl7Gg`lmgu*LY*> zB(}!2_v>KE_hHPn;gBXO6=!-nQ~h4bnSyzpeLKfcb?xP7M5KAk{91!kFD!$(o^kXc z0_m3lXs6sg4pjXuJr61O;ntS%OOm6kwtdKcq4~;j1rt*S$7e(Q0608vnL!h(=6qR! zj=+4c-}{r_v3YYPvfoRpUg)x3gvBrPQh|-;^>(~9(U;>^jr5~fa;Ez3pJzoA4 z*su%}mwRcL$o1g=B*O3|(z-Ga5DH7kFjjqCX|1lD2Uj>hw79luKG7_Heq~o|>&EQO zZ#vHJS|1Js%9~D55rtWo%CV7=1MUw9gyQcs-ErK)(yl?1ZYgtiyfHmpj<(z9hfycl9^qVYu8> zX^7-8t8>lHiNmB*c4E!v+DSo%@7J-F6+g{Dw~Z?0Q;HCE<_6`bvzUWQjG99X{EJcd ziF({$J5!d-_2m^C`cd0|p5i?_*q{^0;qvXZ@z(vtT(@I9!z>Wb@*IAW@u{@`Iq$$) zG1^!pIW(n{hpf-I6y0`^M6ZrFIAL9^Cwj&8^*0ZXuz0B3(Sx0^ceXb1@88==)a}%- zM{$qec-F1gkp(7TMOm zB}@9;n3xQq(85uBbs26F7+?KHrl-a?+L&V~|&UXx9a%T?RrnQ_zftl)Fw`stR))<8MOzL1n=mR|vA>^%3vpRZ}snI2mQ4l1vC$W_W~jA`JTN z#DCJi$*0fX@>?N7>vY%PDq5LoQ2U?6KtUaPO3zb-oV@pc3qf)xs})aLg6H4|bSoR| zR+m)g&{6#;pel^u&-X>+SAv4<&nI1esD;}A$X?p?cpbP=X7DBcm698h;7eG20!Uv; z!Cbj@tGL#`Lp+FecKdWYHSlu>uL;-}UFT#t;l9Y#4ak?+A3p}_1HXbH`2P;ffiMvM z<@T9RFKiX<9(l4(L?eYNPmBli0u=RX0-TRt&A0FOmi)t3gvpCXdo#BbT|526=Yy`X z#Ccm^=v#8wvS}&v7z#CY;nPAsJ<$$Mm@ku?4!3MrBea!Go*QXcoaY)Ub6ku}E{=-Z zxZBje5Oa-$X-fn4>>PVx_{gRu$@B2v^;LK$G5IHn2fY4-1dzUp-PBkwml$?kdsD8I zC9fiuKm7T3+ConYWmphz&L>z59XkmcB2TSlql-1g$OU?p>mAj4AkAV^AHA>1VM<7T zXK~Fhy}{W29yr;Jb+&VTen1r0un`saEugR)2~_R#$C2qHzGP060$bplIy0;G}sXJ_e9JR>{gO+n6907$@p2>*M5b6Qm z>a({(S|pBu3*d;mK#&?caX(y+3Ln?)DTAS~Tswk1Wr;?MpHm#NQ_Vkf*^(J`n@pC0 zwa8#mGI@NwHq5IAxKzWM1-sl;4&*4qeVZk}QvP3m_*Uy3dCT}P+8ulPqSdFY=>cuKo`_rp-T_B?mq?g@QjKxvH}5}Up)NP77dv3-+$=#_ zFm^XbOB!6o&h+KAi*cHV&QT(rq~HadZ%$WI*>!LeMV5}fOC5`bx)bN0U7pX`lYFNt z|2HX9j;Y4^+Y4YF!n810lRd6XK2yZ3QO+K|*MQm-z_K#&0lQ07kgMJAAw+{?L21Cs z!29{F#_+9E@KI%@dW_gU;IOV#?jLMe$E;0Jl+|%CNYM;Y-;+C%oQ5&8%uK*J;bXh(ci(~;UK7?#cBct(lO;@cI=ekCXHd%2geD4 z*#3w+`kQrBk_3RD_W3>)bSVG{gfF0%KU2rjUAxPM$iO>J7!cyl`on9&j8k#!D?l2FD8o-sL%r&{IqO^lg-?8OJ575ZZT@7eoY%{C_0@Q->2 z4vrhth;KQvfq!goz`kiIRCKzFp*o3-V@F%zj^QTU+#bo ztC&&aCb;yuWAnVZGl+@IatjNn)=dq=XRw_NrMoIom?Rv>*poLO=@n>Lk9S3YH7cr8 z*=Kl#&@f!8s(pR9yB#p=j^MLq7FiWK!!#5sTdpa?Z-as01LoDxwhx^mIc|PBjD(QP zaQIzLFMgbgS|JM|0ZOQhxL4V*9Ji>as&u;U;Q9a|UI^;ibH;wgp@Arna^6N<4o?REyvz35FGsVrv8yAC#?GGzt{Draip1->d3p&pZeALuibr@#xUlcus{9OhpgQ; ztC?z1y*=3brs?aYWtb0+Uqb~qxBaeae7Dd6i}UToPUSNcH*x>ZQ&W# z_$ZL;yxKqT00AlBA|wrPPdJvGir^;2AxMH2vsS7fZ{&L{!hNQyCQ{n)(XV; zV1~I^F2ALcP-`>UO~>>v7MlnCP@J5sHPN?oaASdhl$(>DKjX%KsMy_i-5q9V z0Apa>UsI5_%LOHbX+@_(sZrT4cY@i7`WJKC^2R2G?f5@@m?<`-%x8vAIS$juZ4WC) zQ=xKuK?6vS7{zFg^uQCjMnDejwv)x^J^9dz|J|r7^C@RSqq~t;W#8g`PM0GNSd`SA z8Vt(nD}csLXFt7Nec{w$BgKf3*%wEsov7m{@c2YR8;(!7^N2I70m45r(fXu5TwK7{ zVXlTDJHF2zC0#OCmRY~4YEDG0i>$3?N|*t5dmq0Rt%o3aA<|sEQ1|MnHRmQQ3Mb?* z+x>5&!Y-UB`0HI27NXYit18C@dspHJ(SjTvTao+U7pTC0&=Y$^4HwbS$_WXs&Cx?* zF)efEUL`Eh>WKN1cf({p2x$_V<4X9}qB+|ghs3~7K6c@&(pp>>V{Of0=Kuiwd0LSB z`^f?XO6IZT7b_|RL++G24k^eOCiKP=YEa0V-Y$jxLhPZ{I@;I;f#Ly&?I(?nH1W~6 z5%E2j*sk&M_P{9FMD1RUds5rSAJ|DsBWmwL(W&tesh>k_U|&EE0J_IzgJOQYa@Pc9 z3*OF_*#ndQHrBO&pDL|FVJO4KUHm%y(jvS`dJeQL%9dOuU4UhMMu0V})&f?J07O8$ zzu=_e!+-EufOssAd$%b4m5T>B$h(AvU~sgzw}e?(#tyZD%JG=b7o~Wu834%;`|K;rTfiZVwtvFrE@jqiPKbOifGM5;v9A2+9A3pKrz zM=m~h_wrWO%>4=!VaGy>vp-P%zktaovsJS@K{BQC*HJw1D#5dPPERaA(Pf!26r8m# zn{J7+P+=65^D~~Agk4kY2ran9TbP(_E#f6n&3Pq$32)t-{WTRT+U3h!#yZE8HgMS#FfgGOwzTZ_I=Ka}{jJK7i*IOy z8|?3j@f<2kwWPmB@0q>v^X5y3^HVr)m*6K--YG5(>S@jpw$Ky0arP9{$H_-k)=efT z>WOq$E1&;vJR%j`?s*mEIiX;-}>@f;=iFRhFWTM}bk8_j@273%zBjt9>7f?R4R z30Le4;NtK~l%~TjA}iOyXl{!OAXv#OSmR7|ENRX$x}`ciE)CHylPUNIZ!P$b{xqFx zQu>(g$Lpj;UZ4!|;bd(l_ft-gR^0JT0Ao<|D*2`sZ!@M*JcOq)OncVx z*6?d+i}m35E-*6cfkC(h>t{45NL(}%rYtu_4h`$cKCt#uy5ze^g04H zpCWSe>BMIer&FFLC^h4>ucYS_iM4qGT6{->FX`^GI5Q^gY2C9$TcB? z`_{SGOmPMP*;`fZ8i2&n-=Fy4A0<_z{W>MLy~V>EVXCd*88ASqwrlD~?UL#clI z|34$|12C(aw$yM54Jvsm*#7C=j@2CJ3y*BJ7keekMK8haE9v1U!{$L(IH0>R$u@6; z$86cA4nju2jdpgR8*+iFFE)Fnx?SR;R!$^J!RD(qaGte~1fjKwG#*;_@{Xp(6|EDd ztwys$!3d4XH@>$4vXPFj^mHT7)YzW3_*E3vzs5ikLF=qv!6~wD=fz%IEFlGpx`9`; z0W~XGeu-8uWHV@LSE%^Gp0kT}gtCEw+HcI)vl+hV;`l<9H6l;Ao}O~^g{S_v>hmZ4 zWhhoRA1iFr`ybT2a8gA0XoAW1!Hwj6pFov;t&K7sO9%l~O=eds=(G$h>v7=( z))E0;2suh1n83Px)-hhfM-G@ajK@s;KCF@dplYvp8j;02=j_)|zcmpFJ#)|W=&W|= z4RrnMvYE#q3J79PrCy(2UAgWJ1rSV)0*Icln?T|oXQ?lmc4DgA!T&>8`(-C z|MgZ5RsqE0+}7!g%~gNJj;q>$BQ3VQ)xDQa=Fy`(p^hD}Drp#LuH1m*zW)ne2#lh5 zjT+T?5$|3e0)sM;K#NG;u3kN}Q7ze6>rAb@9RB{=677Xh2dp&O@iwzPHONUR@YvmN zYNTdIqo@W`m`pQD{BshxJ`3y16pO`c84N8nB-8sD8}i_%=6uh0>#%#qRftwaR_hE; z-^GcQ2hmD0ugQ?-qp91JI2cvFND4*Y-*YidQq+4;jl3sYW~)QQ1wLO6E}HAvxM`*1 z8L0FlxUoyUd9lNcGxkX&F8)}CS*wuHNxAMtAGY&AY3mO~LH(&)&>OqNIZ`v71RxW( zUX@(|MkXSVeF;|FQi#F|B@_8jr37W5r%PmwI#t4Zh@XU*31M`0M%9!I%2R_#h~m^9 zMl@Af!P5P+&*-LQX|2(XW_vR=^U!xh*KA$pjEGdTg2WwCUAz)$gvPkIscN%FeJaG% zl)X1*U6J_R;5%^8a;79U~#&a-pbZhOw1XI+vz+()hEJy~0tQ zTt4Wpt~Gq#hKT_?$=rzkeX=<(ZM;&5hnhv_b4015gFL5el7Hz@2kE3$!VWR^Ia{%Y z!2i?>$O4aV2y*sayQ_>De$(DUOaY&%7gcSh9?c7rfcr zoG%uXBS7p4&^#h zE}F6?fAvBRfU!@X;#9R>da)WTW9hn7J>2m9B(Bn z+yxf7p~t!MS4Q+YTU*GI9cJe_sA9jpvTcDps;$PZDQlR+We%srQuLbuP-DSUOGO zw9bJRSi3ah!%`5ERX;Q z<4yf7UmX7|f?6nW3EsWlhl)cyP!(Gl$5fy)Bhe}`V0APskxHZhdkRpFE?%bv}zEPWF zAA^51VVE^E8K=4o=qx3=dU`(Cbth5?r%?`+v1LGUQ}%mj2l%_VIFCh~^*=G7;rP8| zQ6O?Qetc#}s(c4u6^EhlJVK#~PCo}{CS$LJlN1n8U5uRoW6Rn}n=b8Utq4M87x|L_ z_9BP*HrQRCQr8A6J-B@yd{y9)JwXJBM@UQ7Ioddx-$G!t_nj>9haa&}QMh(l>&>h6%kky&~koCnh# zHr_>YBUL869oGwu#deavM>eUWpG1gIGi#`n$B?COsg@RcKy|6li`?T1trFe{%my$f zE*J``q?;w?K>OF$Xm&*sI{jVCKws}Ui-vP+2BZ$lLWxbKTfrCyheniUqm+3!dqXr@ zK$e?BXX6s|JfDGEXl=}>nu8%UzBx8D;i;BO9l3*R>#KvRg*(vDb$yhyNjN#=i6b&< z4?J0ptaTX&J)PIt;Sxfwf`&kc<9Y8>yD*Rbz_Dc%K5SVH0@8Fv=@${PHl^qzEdw_L z2Tq%wGtPHCQB*0VZm>~mzd90E_yocxH~iMd#uz3|WTD_>7~|_{2lk9`JfQ>B%Hc-% zG5RC5uX?+JLrUt_zjnZ*kTIZpCl~oJwDU>)iB7 z40fgaMks8tQJO3#on~GDoDGho4J`Fz%I04rvojV_bLt;vc0r@GaYRi{K9XTLh*DHE`5g<#^SCaG=!h*{&riMI?{k((&)aoD(B92J5^l{9 zT&>^m=5gfwvJB)04^Lp&FA!|ycRU8@m6 zK-y86l8zzzkorJ*6lj1lc`?94b-3*-siG!43s)rI!r6{Xp7@b}>(~rV??ym@Sg(k$ zF#j;*8oEG7mzr%QP}zfIa5@zyeeD&c93-zC7hs=+CfLC8blWo!JD*05$KwZwiy0z8$?yu&lE#zO5IBc79= zEEc=7%g)!vlTU`bvFV|?jL(mHT8*YRcyh<1%OJDRwm6)Cq1_h2aK-c}xQN#=WAt#C z9&0EJxHuD4y9{Q!XpIO1Swe@cTZdODMZgSnr%QT%P9PsgweOP^qX29e^4rcTXGuD3 z?fUj1IOC03G`xYG($N1jBA1Cg2D6UVqF)m8lZ+9kxdMoDw<^0PEAY{d&F(w7(4Fs6 zKY+V&iApZB`UCz$mE=`o3RRkvCu$84V0`u0+>?YGE~el0cXTa9wMC(a4AEzUl(mAH zu|)%6VrdLnIdkaCQoW&|vh~GB8Lcp^VOfiN`ptZzIgizj^6O|as5kn^&~2S3369= z&^?1NqIX&%`n-?icerSaX>;kL*=wqD+F6L z5*%KeY-Hga$t|x+OQNfuMckW18u{#3212fV6qSjRuk_4m2~kwF!=ZzBF{2=)uW!|*1qOz zLHk$svl&hP9Zp^GcCs9{$Xn}&u1y%7oLlBl>XFZ^)%^zEaM^B${3)d#^-4bQEv5{B zZ*%iy4g(E+aZ0i!LF3|Xn1@}HjHx`M*Y!9=@C;m-K4dny0Rbtti?S1<{M$_3TG3jf zx6!7ooffIX@?#9!4Z^l9cs-P867~JFH&?-@anXIXrqv>Xie;a?6soPn!t#>0>xoYvH4*2XawlS2Bs_4V9ji+6 zn`oCIA8cY~YE-9KwAZ+|l30~b8(PXXg3K2Fvj%X1STLMwT9agbeqalv^DNzIo(l*+ zrY5;+zk@^94vju-4_y`091%$A<0nvX%p5k4CIiqPgWnKVgs36;AAnz8b!M2Q(=}=; zPHE=wNY#s1hBfNw(bU+y*S0Blu(SN*Ovg~kO)CvqxtO&A18eo9kYA=*Xieey2!&r@$)%h=K za(BVss4D|JLiaf6d4DJ0CQW2L0aglpA0eXjkI+jJE;3 zt?ANJ8*gyKFvJIcQKUwCy^v{;He@(r8OGqXakN12E+P4&L`q*xvD# zxmKpdx`!p0n-=+c4yya$!ReE+YId8_cka81lMiPvq+TP+x)kA=WW`VFDu`9P!H+eVks5^T9&lBRa7G{y!idXkvdqt&kTfR0196nlDC8+X}@4}UDcj5Z3y4lS&x{5k+@LIb1-z*R8h)Zwd- zfYRxy-!6ybpD(Y#&^x|Ff94yPzOLfa?0D9X=|Ogdcslwij{VlO3B8P8SVR1QV+nBz zog1bn6qRSI{68l4-Q(6S;k?+aT^V}Mbb9R!!uO>`vYX>Fh0bfZL~an`TGK7TDV06XRy#H+!5ju=fXBhba=i#-#%@ zX+e6S>GkQF7yyFL-Xj3f%lg?_$v8fbi7a(Hjz?!Yvl;O=V1c;lqRR60X}gBn3W1{r zv*k<{QiYqAnCDM;pC+73&n~^X408%cg%ABQW?1TLS(RDyZ!rRLd-0-PDa0edW=5if z482oJmFY6@4--jGsWvD-_SX><&)@pSnwD)OWb2b32q*a=#Wvw1mEGhaG) zM6lbOHhVap?9+}iu&x(L7J0Ds%4@^UrPVXUdV#H=)TVx!s9)Oi*M3V(5Cm)}#XHEg2p zi}$WxiTqERqDl* zrX^Pcpk^>cibYpLN22XH)U*D2kNSZLvh*HFKxLx7Q}wnQyNx8#S(d`L%wCrJl&?bg zWoyNF8+=+X$Zrgngv%0MT+)GU*ob`;S zd_SVYxbeX}%V>0Fbx@`oc*?G9YCpLgoJX1Vim%Sb#LKEDOy;ikIsIa~ zs<9}IFaAvhiNvnA_Z!WSW-Mt8tZOKQapw(UI2P?rr0!e%@#YFlV^N z+H&{D(~((ly%#RSIVCo&LnK7U&O5Q-NI$tf3lg+38WBu%#HJ7f+V@1uGOC2M zXQIBAJvqsSP(|_?E9J|}(bLwA0J?b50jAvvv8F6Izy}>7vNtMm<5Ul}sEyH=SYpHF zhwYL&9>)T~W}ng!;n=j_3EX@0N0e6}d%I2Tk*+{7f@_?-t6BI`qD;|(0dOrGaz{q4 z^l~<78edwwM`#{`4hZzl3Mx7rCoA7C=>n+`Qm$O7 zwJ7WfFP1I=u(Xf=#AzwV=F<5th*eZA^&Z*6EDwB=VSVMJ@zw^<7l=w4`<-xjBX^5AJ;LvuA|Ax%{onZp$2^#i=LJqHp-gCfcNbz+l0XS{=TX z+33KVEAu`fwIFXTj{0x&4lj~BJt>~QFOtPYo5&Y8#OQXwz95u=vt|6}rdJ(cOm-ry z!%Fq@W5$#T3}s;VY?XU$fu@R!?muhvKvhgRKOI^~R<+h*>XB%;%F@DVV-SFDEkjis z_{{ZWhhQAQP3@0G<6`WlW%iXIqYg0@56oG5JQ~0PP;PZcHS9?s!0+rHAKb-u5KTzs zg)3*$GqUr*OKlOo#OGSa(1^EB4tcBeqr0UI^vy&u#N9Li+-+k=f3^bUfpb~)P zWd11oV%ez`ew~^NG?v-UZ+#7Ck0K+~AE4|H&+RcHcr&o<;u4&TW_6QtOZK=Y# z#?&TyYjZXQ@BNolP>g-pPO&=;+d8CIPTz-05A|9rI{k1;-Ckk)xu-H>I4a-(`HuaE zl<{>L!Y06P&6?QQLJFnqVBTOt?C)7Gyh3X76$8Zx=r@4dJ~Q7y&zzRI;SsmjCNya^3ES9IBd4ziC2%L0fv*wemMo@M2=YfI zJwSkxGT(a!cfwdX3mBNo(b#4xZHx)V#mAeIhGUeBX`z(g9l=l8SrU98X+w2Bks71!6W3o=oj6_FpJ}-LG*Et zO!dekll?zbI_(hYo0M5hu_JM*SzGp2#Hkq;ctysRE0Xz;>uG9g7r{n81rV781b}_~2*kd_lE<4pK%g)9WfD<)> z$>YFq7U{9W8kW07Y8fn7uYYHteoe73Ttf5ebO^vLeqP4KVY|n6=i0{xJgq$K*}}N{ z()k3|u09djoH-zQu^+TP>7)#ISyDV6f#1R!rNyZqr=|ul3^lbmL(W$eEfR$54zn+( z98WR3)+!&x`X1--v0zQ$u<0j)Xn8PM+5+Jgc&Q5RyQmJK9A;B|YyE-YMr&~6^MWhn zah=gOfqea{fvH>?xWHMbS9h63iM=Ssn=1I2NyU;;Gza(eKa3jK$EB;tbFC>N3j5ll zLChy1j7xfUUm! zm1&hC%$HzUSIQSOx%P z1}Ea@2%Q1W1u>2a;fr|AJV1qHL!Xl+&1W$Jw!{`GFULt}>&8D!n>j^?V?^h0%Mj*n z%>^J_oNIJX<$kUr-6Oau$cDC$>5Qvdz+d@nYwyV(86BuGMDu^%b#^hYr(&*WXG!iw zAq!q_q4uV{@+Q58CO5WCH!5J>)(4q-H$D1`O7LJ6c4t}4aonXx-ScciN(|n90H}%m z-;-+#5V1`iRN;Oo7*i->C0>K03XSo%TkW5&Bey(3w6HKk@EvSlr7&I`>)gMOQA=)} zrk^&kp0cHM!Wy7szOVh7P}5b`dmMFgrB3aam}#6d(qfaUULQ_^@~@1@EZTAe$!8*h zLvGGEumD4EAc4pucAL&OK1x^$FBTIUoqnl~Jt&VxoyR2mF}Qh7Hnx%uoOL5-Y-Hrs>?1VR;zL(os4 zTE{3B%joj@j&(3^Qj&Y#%2s!BMoRzcWD>&TsTvI~9yZ_>Lv zJp81|i>Bun)7wL8>LbUUV^fHPs}1G)arKiK#+wYAlw7wvKK`5@)6ctQ0)4;HRW%vjR|_Hn>t`(&6e)@o>iuhTZ}|)+EzmAT$JbCwfdS_C z_(EXhi^lvsX0Hyoa2i3+cLFw-QUR1XORRS-3y3h?8Ek1YSC~cn&hJxt@56ldl??>}zzK@IsFnS!i`Iq3Q5d-o8 z!M04Yw^7fo!1=NMtgfCn^U3gl$z8pMgvcoCFk>)Pj2Q9hbIG}=LF#yjtGY6vH>Qh^ z)&nWn%X}ON7&pVBr={jE&?@#DlOw{~tROrn($|1)6lNfS{yRyQ9BozU7@u`@BkGg7 z1Oj)ka9x;eL$~Ql0&JZ3M^}oWc5I@#ZJz+I&XODp25CHx?>$_hp3j)WZ5W(hz86$N z#`Iyp4xsP)X;q(bOcIGKc6TPujgH9L5A8XXsk)QcWnhsbL_xS1z}Oqz+9A5g+4QIw zRV9kMpgAstB49^XIv>Jd)27l}u?GrKU%-4hp{gBUkqwyrcfbpham9)w$BL`uVC;W* z*bw$R<{-q>p=f2?q`3m#rso?3=-UCw8cTl3}!mA2)R~X5~cl?lsfq zx5boTr;)86P1fOtnX8hG&c(h?Hcei)HZ#b>yKk8KJq4Glv|nYPB8Y+WOvmcHuv!Go z?4;qf7Is0HoCE9ZK=E2x6Ap+nrrD&#Sj1`vAocL;{1#Q6nsS$x&$)emV)@XwSu=|$ zR7p$fehW7S0;Yv}3>Yi#3}Ace*J%3}dUt~MV?1G&k2+`V<<4nIS30=m?8VsqgRu(8 zf`Ot-#sl>u1|(deSp?2Y*sO3JoE#HwWRX9-|BE3N`sqpb#~P?hGR==^eSTE_t$T!% zrle@cv-4xhbXO#LEJ>;a1m(er30ukQR7ZcDHntqk&b-?OTVX=ws{c=>EWEP-9U}Ae zG@+^?M6n}^MHUgD3P*mbY(Dnt!(<5F76y0rp31<$nJYNbhu=SE4O|chP}4+~PovTM zJVX~JiUEoWD(pTYV%vCv!C{Gc9)S^7V>sc$me+qSI*LGx_1N%I7r%`Krrr z=s=Mld2DfC+~WR!Wc_oAJVx92z)rMZ{9r=0Fiq8m6oLx1`t|0R3| zqSMFLNBN|KKuB0g-nI4#0=FNq-{nb>-7OTTekc8yGX_(CuCTQcKrhp{WUfK=>gP${cz)Z%%Z zT08HfP0#M#4CZ@%ShF}Z=7dZvQ8v_qoQA>A@5m*3O&5J!v8or=PBx@6g2lTwOaKO^ zQXgh7%gD0RDB)`gMuZo9coOuAnVcRnuv2YbdA!hl5yLA$#c4~s2>&WL2zvM`f-`W6 zi7eEY=UoNh-x&2F4SnLR**4L^x^4Gm^d;~NS0)E^taOY&IM;oP*T}m-cLV1q)eTP^ zics{#adqg&lniu@Ag9bJv>f?PpgZ@?s=Or|?)zjC`01QEt37naQKG~hxV5MVqY85q z3*;cWXkVx@WfJwAlMPfK$2{@#UHo-Lm>LxS`7xi&^s*6Th-`sd%c=3s9e^P~8AGtI zJnfZ@irSffHoFJgkMPVc^yBzciC|OPUmDT^8zR`xLm_1XnmB@uKfON?qOC?57}?gO z$sNY3GF07pNu_gvDfXG_fi8M=d$7v9OwqS%ObG${Oz>x!JX`-Fx}0~kR1k{VDL(t` z8VR_j#Bpnm1A+qKmvv}_d(QoK7^Uu-j96n!{%OWQ6|d> z)-jMoNxAuPw8KOH(igB&`6lP&%$5KKNCe))%_F8CTS~92--e1Y^MkA0LMrjpslO&m z!;_STadLd)TZJdQ)Vo;%Qjvgo%Og&z7opn~0{r3Kq@@#E!K3yVJL%F&=GQ(ZA20{6 z1Y^+P4S6xhMPOnBUHFf06DRvd=LA7t5Fuz-gHmLyRf3Xunhd&HAx9vnBi!!Aq$bHe zKpQ`WvVFy5=mw>_F))wf+RozL2KAi`h2Qx_Y`YcPrUENtKNf5KB&N4)6^Qfg$jF2W zppO$%ldrDAaMcSK<@#e;5bUf&R~XxWky#}ypgCvjY{*SSI#q_7i0fw`KN|1kE_6>M z;P61_nY-actH-ua)xW3tP9`+GtODa`+&c5ucL}tdibTW;TyCa#jeMeOAN?z|S zM_;kR4nd@xm>=g?{j!Mu9Rr8*9AklVMC~=z7yU*G>Hv>* zd-go*uwI2e2My8oXhK{(tkllv6ZgV;Qt@dkCP{0xqf|uQM}srGhm7CS4Zz;I1W}9k zF4maeB91fbsi|0$l|QExfdM#fwVehcgRX|w=85zHt&V1)%C~>im8<_!Zav5+zS0^A^Hfi)2fQ;UA*|P+Ne%V-BPn6;aY=1x{yGDBB_wle>H54g z*$Fxl)CK#PZ(&K)@^wd2+8F2GJhzw;IGWD@fcFa>hyZTQb4wsQpFwdlT}Ysbu-@|u zE47|GNL6So`6|dzFuSPQGp^I2r0BQqCjCOG!N6kVtW7*XPh9`Omh5yv|2EnFc~zLH zKy}A(0BVm0S=2X|zze-6D$t0)s(pwgZLU}%$SS2YC%1)%qvj9yT!U$f@jciC?L0tF zVhcO{(-iRtPSbrsRs3xEcs6kwHhe|!ITn!96H>B!v>Vbkr3tF%S#E?2^?zH}yt*hc z*jMF?S=-73(?qv;Y~Wv?6xn0YZ3T0ssH~x%&fMWy-E7!UJKFB&lXO@ocOshf4g_WMJ4o8CLR zo*57`k0H3zO}9pOsL~Q8CZBn@fr{|3sU3?L%{^I;{x@tQBl~CGV+m+LgCC*{c+1r! zJVsxVZn*mHl{#2}Re(QrZBVC*iGFdqXe@;%?K}cK6Lz9}@|@|{n|eFi?D7QXgt_OKADayWenj~%FiVB# zn_P5BG(~Rn+X)qGVb{i(v<53-Vhrvhe^c2YhS&Lms^Nw-VA(wR%x>PBXP)B&HF(ec zC)31*JGH{CEhaMb2B1TlYnDXTI}OCwguY>VZ*P7B7f%VZ*RPyf=4fov=-N9yh_{(g z&Vhwo>Yp_iTNd++ki0c~C4JZh$GlM*+B-Lap@*%Vv?~O&KQ(pR=K8l`9UU!6wU^** zzbWl&=Pu1V2_`YTptZL+%r>;7C5R9R5{vLY%CiHf&y}gMsIs7<5y_ZAyBCk2rxgmQ z00{ELQ&x`$FrAA@H4PuDXo>HPRnfB7{}%{OT1_0T9>4Ki(FyNTxgo|Ls$Tj^yx2XS zPzAdZSGIm+n+b?r%`8U+^CvoHp?nUdQmy_EqpCGWIDu2$cr-C97v^9nW!7@(%L%kf zpT}Kg@o=TR7h~OiS)Kl%%~F(PS!;z4yzKDui45wN^wem5fS|<%=N9@R z7#>jvkkBd*`_kC%6X6TIQC}{wet7C7)y$MQ6ZNqxjr|6fY<%Md)@)-8u^R`f#8AfB8K{SI%Y9PS-VTz2xK;}M}NcZMJ}j9%!> zRj}EN`+)*DCN16hEoVeO@!yjlibQF81#09jYjwZ?5_SO=xahaVQzn&jeJk3J)5U(su%=?xE@@LlNwGZ8lo z{7l|8`vftX(2W%GbF=xhy(1$>CpsiqgC!9HF@-T1n@rzi^jp@3jd5+F3jn)_)RG9& z9+k1q^m%0V3Tt-i_eHTyFU|xg3XgmVyemY*Wu z+`TXvsrF%!4WZLNtqUjp$n9^}+com*BxS;cFl(09P!%el z7RiK}`LJD9G)=TlCz_eL|*%sglBW_$e3SF>376~_8Uun zbeT48xmh5yz>foYOsTOQTK+vu>LTp1Fi9_%i5Xssp05w>veExZ{EPeX0hAKZ=SpPz#*|AFy$~<{67J-DrkFJ9-DK}MftqUR z_A=|kWQ#ADO5|@isy^F}B<*=-AZCkR(j%nUUv>Q+Ub&G@YXK#piJx4$C5Jg?Go$I2 zUg9_cOZWE>8U$+9^T+H(?=RtcbMwD;2Cn8NV9*yY-=QQ-vJ4V#PNK*YYpPxbA2IcX)1GL?Q3B(IyMDFUBYM*kM%C!Fe93d zt`z8ogUx z;XJd}fDos($W!8VM8Cvi3!I~%cFJ@sPIe=}XB=CCAAL_Tpy_@Bh0?!*$3p7V-bvX z5>}B)QTZePV4xwyK~0pXh5t}9?ux6?x84AoVY{#vhMA_q^Wyp^x*_3XqA^adyiy+VEyw9RhJQ; zP5%fG;j*XF{#}=<7?;uwdL#Vmfyf3>)Wo;IsB;xqOyT0SQvSEB3x%2bqny>Dl!IXiGzS%T$JvA?I-Bi?$2mC`Q$iyPu{fxikIZW)OWT2bjf$ z5;1+v|KS$(T9gAGw}7RM%I$PfC1$}|UD+EXo_D@bKD0~{x`xq7TK5c{wL)c&4H_#6 z>!&G<247C6muIP8u%0gQX!|kv}AB+>;-zq!cUZ)Dy z0zWyhia>A}d0#-7Z*#@?w=Oa_HYu+bkG6pcC%1aLBh4v#>3lF-xvlf(%T;tw70UGc z=mT|>U|HpF*fAN9Peb-v(%23qPOl$;Sy6)C5Wkcb%DH5Ni$sl0^4RQxNL3G`kn?`( zBJYC>p!H|$4T``5!lYc`^RYP0-NbQoju1p~IO=JW!oK<3Ly#7C_hiw5{e*a(p@YWN zI7zlOTXtZ020DetA}y#~bUt?VQ0{v`Z09%S3Ao&iG{h|A8h9ygAn>>g;ly|5T78z= zRV%YAZ?1rv?Wtu>kbvty3znAw)@@?wZRGS7|3@+ba)(G`cE zL(Oh>5K#IkNmI)e@Hf~F`rj$L42#64!VHLbE$10U2x5&eMJ-+1}G>n}W5^v&CZ^;f|AZgPf${@R$iuYu!Ta#ZU@w`haDW&0{ zP3{Q&3?&$ZONk{kDdGbjh&okDqOI7QfmsjaUlNdQ4RMBwAqHwgiy$<0@~&wRFVKiJ zVhd640PV$=K30MZ(UM%n!iuT7mTB8B5RhrLeG83)Dwa#mJOw$ zyaz!3bRQP$r z03}BC5@8bup3=Q%33c1xDX=TxMg&b8+3O;E^}5s+50>(@DERUb;R0Y&CAvfBTMNP| zbWeUb2Y0OkKyb>>3@Z3$Cg3H@lh6)-#Va;_E;YL10z7{xAz*ZA8JX1M=zNy(q(CJaRe-BY%UCMN0dhLp{tFW+Y2LxWE$+Arm)Ann5EsxgTCXeLRt< zAQt?&mg~j#ltk=22g5`SO$IujiK&2kXidfA2%Bv1(HwRaiAP=k5Uj6gj0t#5AI5BE zk`8c@J`!*@Wh}>r`Q=01L0hlicorDsvu;T7-|;T}+KDmSV_bCLe$85R(mZnAdbvfl zEmS&&Agfkgx|etA#gYBWFOdmXKcQt;oUa0WHZ?s7$c1(#g0T%`jfO+erjti`oSWpTHDrIV>DYVQ z(*0cO3Rnjo32TVMaIRZ2M?cwBXvf^|%2#pNLhWYh_S) z@01`laAKXm$+?imfnGvtEb&#dr0JfAgD&V1{W%HiVI*1GXWjCv*W+BPBPeK@=jo1n z+lCr*W8ZkCm!p45RLemGYWklivHy-P3Y2LcJ4SAg?@>Kw{rQHSn=v!QyTqc1DUOb*8Vct&``1vGh~Iczq|sYoxz8Ki=F)KV za4xAtAe|SBjK_@5MAwd(;qxdZGzXp6l4tTWF19|_{!&}<)-o-%K-udZwClGz9Y(Ik%_#!vilMGK%R(BX zgkomWhs+F;aW^m+mpDGboRZRRjsXn~^70460$e!yC*2C5s5xXXEOrk8B)n(#zu_&O zKi`moRu#tmJ8v~3ZdaOg!vdHQlp#?oPzB!|=M285mDFVn3dzW0=T!e+^pNS2b0;eUtEqrg<=L1&5}-B554p$%ER3MqBMpR=4>Uv-h4{^Zx?Vu=le48 z-BFNjDx3=FCEWn)K#RN0EwAeqjs8&?%$xf%ZS1C8oDcF-bw!rVh2ZMDtK6$7Iduh* z#}2W2b-EBcuQ}@cU&pVBHp@uTSbCl(E-0fTc+1i8u1Od)3rcC+Vgl-Kj%K4lmn*dV zWs+uyPrHPhe^m(@;XU@{otMb@GTR5IaP|EO2a&T)bLF%QF&~+k=J(gsBgx0uT1n_7 zM{GJ%am=_Q+1q6+pmBuyI$Yv?Pon?PeuuCkdqrpd+&GU^;=hZNx1^M(5Mv3zb;UTA z#9Eu6g^9=oCD8U2sSV~UxzuJZqZoDe-)HYXvi-J`DpDf=mw68OJEQguxL7UVxyl`@rglp((=5MtSyFJ^Xj5$U0A4Knvg;!l)&k&Eh9 zf1G3E*`apIyknBva{y`9x2P>~%5&oiZ+3el>oQpof_y5m@_2A3_<)My*5|>zC2&?i zYmg%a^u+@*ZNTkr621k+N+c0hNW0oiL^Q5EjyvNbSn+2fwWwi4UaCRE*1rhl08(3T zKA6;-jhTa!@8=W&jyMyn)=BW0IZDh8ELi*M}wDU3rv;!Tkc5IadC@Ww=4Uw4Xto(obPezWAG|6z#CeS8?CUi$C1)S z^ET{0#}MCsp(S}xJI;rb;cHZHx3m4c$5IP3@9bKN!iGoN$C{fus}|DV$RUpT`U7{W z3pxrhr%GkC68K=JBMnwzL9uy%a-S z+&jzMYsbtd{PHQ~H6vKh5^fnhD8w8{UDDwjVV;WzwjU#%mHi{ymyeQcCfIhiqBFJx z@x7Q)H#sSVQ37|`5CJ*OzrgI2$2EFi(Kgwa`1Qm_X{=Ozo^=6Bu(M9H&PlM zXsN6Wh*f*tMV{<0z50u}$AAr-B545u0$RT&Fsp>tw$T_ILUdYeyuSmu;`eGE$%1k* z_mlDGGb$elG!}aGWp-e&jt{@-=%V*_J_b7cd)WRv=NDN@A@{j&+83B5q57;aN}+ZZ zcX?V5!WH$7K?;*hNE@O?XSwe_B~ne@e~YH1!v=ic_;paoFt(H&cgZoQTE)iI0L$Fs z%>BEfHHpkmk&aflt9HIX7j}~iUD-+kHac)K`HU*)?JLnncXnrmM4Y`f`$}ol2MnxJ z`T16f99>hCf*r5YQ)z??XD)HAq@MV>a)KO*-*j==O-DX2#4T^FUM@@GGAM79h46Y_ zUiI3JQrTh9`9ckD`7Nzt0X-5QizAm}_h%n3oqhZlr(@aFV|xVge)fN9(?o8RO34$g zmn=fdxqOXMs_?`5us^pQO%KP?cnBG$ZS70SR!g*XVV2Z_9Y^dSc+Hba2x|@_`Y8^UI z&C*dCv0DZ{b!=d1<}u+Nm+gSy_8CH61<^x@1BNs24Y~d&jJL-3;ER)BE;-0it%vA* zL=S|gP-{w8I;k)NDBckpDduZIMqpokw};j38dzfjAJbwOc9wPWz_-=>;ih%Pt5p!| z9u6VoQVz9eV@%BF(w5b^Be6S0a!{jLFdM`t1i`ZPb9=Y4S&4bP2`6V&Q{H~_RSIad z^hbg@q+nyI4#q$c(>^LZ$if6_9a$+<#7s3v3?qL6`A4~+d_D$+e$ql3`u$Q@>xsS2A$N>v_t zPF2`ooQWkcW@a*0fqS8q4ZtFMbQ-7k2@!*#fEU@Dpo)1xdgpwA#}LDPwIihFoUIXu zv3x#lR!fO7B~rODbD%-zhK@ucFtF?$fj&l%!??8WB!U(c0#N1ETd@W3#~w{S5qR@%zmji`sQ@8BUk-b_bIAbBi+F z`Wq)r`v9rz8u>TGrR8#O!>|P5(GG-OvJ?9SnIg;jnHG9Uwu}x91XJ_s?%0FG3T?Ih z*-t;=aCK4e7tW0639F@g@l2d+pvQAOt`XPMfLqjPFfX1+I=hU2ZHJ z1gHWN0qi*~Hg&)e{(HV3Go@RYbYZQen_l1bm-yo@KY>On9la?=Q(@2T5WOF}lg_jI z`WMnYj;@yQ9kUS^JZ++u!kTAeeBZAxs z+(}AFVM#hNL62voHoxBd8yve`lO%Q#%c=K!7uB$9Ty=FuE-D8{Lk)zO8ZG? zZwf?`>tJ8_wDNkOg}1P62y4%?PeYg#MKVvEr!ysfd=C4&$5zP^kSM_yjgLcw0(S05 z3OSqSrt{9yxs;qp)ENE=e!!JHP!89N<}z+&6_nGM#;Q_*v8h-#d@u0vFn-L4%kNzs zs3`+~c3r<<19P&#(`1C9{5Gr555{6VyIYutwjV>_W!u67`GTcv$ila^0OY(!j=6G^ zQAOzB99D%1sZ6CXHe$Zv>k!8-lxpeL1dXN9;WEO=*9S|p;(cZjq9|y2Q0NOH& z8mQ+oLA~BHK#8{XfQ4!Z*Qy`D7{v{Mdn#M%ptVnJimgLms^=M`91`}kwf3p|YW(NK z1Zr$enD6ORYA)q-^?(eVk`U;(fmg zW{zcsLKI9ct2X>)#ZLC-jLd8xHv;Xa@Z(xiiu^=UNUD`Tsj00#$}JGrq$Gdok-MBV z_JWR8#bD!aDbN^DCtVEG*zj7}m^X+@&K9m}l$_jmcjk8}|6q0AEy~(%D%6QPXo;sh zF?A6i*-ypf`P(9?2}o#e6m+AWhF1PO{-ZB!$XVz+F!QR;bVKi5?U;r)KMLMTcQ4$G qo9Q;uaEAo|00007JUTo80i~M+w!t8?k!*`TFb#_W000000a;qcozX1- diff --git a/man/applyTagMappings.Rd b/man/applyTagMappings.Rd new file mode 100644 index 00000000..ae08a548 --- /dev/null +++ b/man/applyTagMappings.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcom.R +\name{applyTagMappings} +\alias{applyTagMappings} +\title{Apply Tag Mappings to a Line} +\usage{ +applyTagMappings(line, record, pattern_rows, tag_mappings) +} +\arguments{ +\item{line}{A character string from the GEDCOM file.} + +\item{record}{A named list representing the individual's record.} + +\item{pattern_rows}{A list with GEDCOM tag counts.} + +\item{tag_mappings}{A list of lists. Each sublist should define: +- \code{tag}: the GEDCOM tag, +- \code{field}: the record field to update, +- \code{mode}: either "replace" or "append", +- \code{extractor}: (optional) a custom extraction function.} +} +\value{ +A list with the updated record (\code{record}) and a logical flag (\code{matched}). +} +\description{ +Iterates over a list of tag mappings and, if a tag matches the line, updates the record. +} diff --git a/man/collapseNames.Rd b/man/collapseNames.Rd index 01a38a6c..b3a0c514 100644 --- a/man/collapseNames.Rd +++ b/man/collapseNames.Rd @@ -11,6 +11,9 @@ collapseNames(verbose, df_temp) \item{df_temp}{A data frame containing the columns to be combined.} } +\value{ +A data frame with the combined columns. +} \description{ This function combines the `name_given` and `name_given_pieces` columns in a data frame. } diff --git a/man/collapseNames.legacy.Rd b/man/collapseNames.legacy.Rd new file mode 100644 index 00000000..dbf12d7c --- /dev/null +++ b/man/collapseNames.legacy.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcomlegacy.R +\name{collapseNames.legacy} +\alias{collapseNames.legacy} +\title{collapse Names} +\usage{ +collapseNames.legacy(verbose, df_temp) +} +\arguments{ +\item{verbose}{A logical value indicating whether to print messages.} + +\item{df_temp}{A data frame containing the columns to be combined.} +} +\description{ +This function combines the `name_given` and `name_given_pieces` columns in a data frame. +} +\keyword{internal} diff --git a/man/combine_columns.Rd b/man/combine_columns.Rd index 43554b0b..9ab750ef 100644 --- a/man/combine_columns.Rd +++ b/man/combine_columns.Rd @@ -1,9 +1,11 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readGedcom.R +% Please edit documentation in R/readGedcom.R, R/readGedcomlegacy.R \name{combine_columns} \alias{combine_columns} \title{Combine Columns} \usage{ +combine_columns(col1, col2) + combine_columns(col1, col2) } \arguments{ @@ -12,9 +14,13 @@ combine_columns(col1, col2) \item{col2}{The second column to combine.} } \value{ +A list with the combined column and a flag indicating if the second column should be retained. + A list with the combined column and a flag indicating if the second column should be retained. } \description{ +This function combines two columns, handling conflicts and merging non-conflicting data. + This function combines two columns, handling conflicts and merging non-conflicting data. } \keyword{internal} diff --git a/man/countPatternRows.Rd b/man/countPatternRows.Rd index f9100912..3fe3c3af 100644 --- a/man/countPatternRows.Rd +++ b/man/countPatternRows.Rd @@ -2,17 +2,17 @@ % Please edit documentation in R/readGedcom.R \name{countPatternRows} \alias{countPatternRows} -\title{Check for Pattern Rows} +\title{Count GEDCOM Pattern Rows} \usage{ countPatternRows(file) } \arguments{ -\item{file}{A data frame containing the GEDCOM file.} +\item{file}{A data frame with a column \code{X1} containing GEDCOM lines.} } \value{ -A list with the number of rows containing each pattern. +A list with counts of specific GEDCOM tag occurrences. } \description{ -This function counts the number of rows containing specific patterns. +Counts the number of lines in a file (passed as a data frame with column "X1") +that match various GEDCOM patterns. } -\keyword{internal} diff --git a/man/countPatternRows.legacy.Rd b/man/countPatternRows.legacy.Rd new file mode 100644 index 00000000..c55ccf85 --- /dev/null +++ b/man/countPatternRows.legacy.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcomlegacy.R +\name{countPatternRows.legacy} +\alias{countPatternRows.legacy} +\title{Check for Pattern Rows} +\usage{ +countPatternRows.legacy(file) +} +\arguments{ +\item{file}{A data frame containing the GEDCOM file.} +} +\value{ +A list with the number of rows containing each pattern. +} +\description{ +This function counts the number of rows containing specific patterns. +} +\keyword{internal} diff --git a/man/extract_info.legacy.Rd b/man/extract_info.legacy.Rd new file mode 100644 index 00000000..23ac5bd8 --- /dev/null +++ b/man/extract_info.legacy.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcomlegacy.R +\name{extract_info.legacy} +\alias{extract_info.legacy} +\title{Extract Information from Line} +\usage{ +extract_info.legacy(line, type) +} +\arguments{ +\item{line}{A character string representing a line from a GEDCOM file.} + +\item{type}{A character string representing the type of information to extract.} +} +\value{ +A character string with the extracted information. +} +\description{ +This function extracts information from a line based on a specified type. +} +\keyword{internal} diff --git a/man/initializeRecord.Rd b/man/initializeRecord.Rd new file mode 100644 index 00000000..3c0c08ca --- /dev/null +++ b/man/initializeRecord.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcom.R +\name{initializeRecord} +\alias{initializeRecord} +\title{Initialize an Empty Individual Record} +\usage{ +initializeRecord(all_var_names) +} +\arguments{ +\item{all_var_names}{A character vector of variable names.} +} +\value{ +A named list representing an empty individual record. +} +\description{ +Creates a named list with all GEDCOM fields set to NA. +} diff --git a/man/mapFAMC2parents.legacy.Rd b/man/mapFAMC2parents.legacy.Rd new file mode 100644 index 00000000..f3166e4f --- /dev/null +++ b/man/mapFAMC2parents.legacy.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcomlegacy.R +\name{mapFAMC2parents.legacy} +\alias{mapFAMC2parents.legacy} +\title{Assign momID and dadID based on family mapping} +\usage{ +mapFAMC2parents.legacy(df_temp, family_to_parents) +} +\arguments{ +\item{df_temp}{A data frame containing individual information.} + +\item{family_to_parents}{A list mapping family IDs to parent IDs.} +} +\value{ +A data frame with added momID and dad_ID columns. +} +\description{ +This function assigns mother and father IDs to individuals in the data frame +based on the mapping of family IDs to parent IDs. +} +\keyword{internal} diff --git a/man/mapFAMS2parents.Rd b/man/mapFAMS2parents.Rd index 25d5a9f3..10cfb4e4 100644 --- a/man/mapFAMS2parents.Rd +++ b/man/mapFAMS2parents.Rd @@ -2,17 +2,17 @@ % Please edit documentation in R/readGedcom.R \name{mapFAMS2parents} \alias{mapFAMS2parents} -\title{Create a mapping of family IDs to parent IDs} +\title{Create a Mapping from Family IDs to Parent IDs} \usage{ mapFAMS2parents(df_temp) } \arguments{ -\item{df_temp}{A data frame containing information about individuals.} +\item{df_temp}{A data frame produced by \code{readGedcom()}.} } \value{ -A list mapping family IDs to parent IDs. +A list mapping family IDs to parent information. } \description{ -This function creates a mapping from family IDs to the IDs of the parents. +This function scans the data frame and creates a mapping of family IDs +to the corresponding parent IDs. } -\keyword{internal} diff --git a/man/mapFAMS2parents.legacy.Rd b/man/mapFAMS2parents.legacy.Rd new file mode 100644 index 00000000..798af515 --- /dev/null +++ b/man/mapFAMS2parents.legacy.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcomlegacy.R +\name{mapFAMS2parents.legacy} +\alias{mapFAMS2parents.legacy} +\title{Create a mapping of family IDs to parent IDs} +\usage{ +mapFAMS2parents.legacy(df_temp) +} +\arguments{ +\item{df_temp}{A data frame containing information about individuals.} +} +\value{ +A list mapping family IDs to parent IDs. +} +\description{ +This function creates a mapping from family IDs to the IDs of the parents. +} +\keyword{internal} diff --git a/man/parseIndividualBlock.Rd b/man/parseIndividualBlock.Rd new file mode 100644 index 00000000..8f58554b --- /dev/null +++ b/man/parseIndividualBlock.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcom.R +\name{parseIndividualBlock} +\alias{parseIndividualBlock} +\title{Parse a GEDCOM Individual Block} +\usage{ +parseIndividualBlock(block, pattern_rows, all_var_names, verbose = FALSE) +} +\arguments{ +\item{block}{A character vector containing the GEDCOM lines for one individual.} + +\item{pattern_rows}{A list with counts of lines matching specific GEDCOM tags.} + +\item{all_var_names}{A character vector of variable names.} + +\item{verbose}{Logical indicating whether to print progress messages.} +} +\value{ +A named list representing the parsed record for the individual, or NULL if no ID is found. +} +\description{ +Processes a block of GEDCOM lines corresponding to a single individual. +} +\keyword{internal} diff --git a/man/parseNameLine.Rd b/man/parseNameLine.Rd new file mode 100644 index 00000000..44490d60 --- /dev/null +++ b/man/parseNameLine.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcom.R +\name{parseNameLine} +\alias{parseNameLine} +\title{Parse a Full Name Line} +\usage{ +parseNameLine(line, record) +} +\arguments{ +\item{line}{A character string containing the name line.} + +\item{record}{A named list representing the individual's record.} +} +\value{ +The updated record with parsed name information. +} +\description{ +Extracts full name information from a GEDCOM "NAME" line and updates the record accordingly. +} diff --git a/man/postProcessGedcom.Rd b/man/postProcessGedcom.Rd index 9d0c7b2c..62bbc50e 100644 --- a/man/postProcessGedcom.Rd +++ b/man/postProcessGedcom.Rd @@ -14,21 +14,22 @@ postProcessGedcom( ) } \arguments{ -\item{df_temp}{A data frame containing information about individuals.} +\item{df_temp}{A data frame produced by \code{readGedcom()}.} -\item{remove_empty_cols}{A logical value indicating whether to remove columns with all missing values.} +\item{remove_empty_cols}{Logical indicating whether to remove columns that are entirely missing.} -\item{combine_cols}{A logical value indicating whether to combine columns with duplicate values.} +\item{combine_cols}{Logical indicating whether to combine columns with duplicate values.} -\item{add_parents}{A logical value indicating whether to add parents to the data frame.} +\item{add_parents}{Logical indicating whether to add parent information.} -\item{skinny}{A logical value indicating whether to return a skinny data frame.} +\item{skinny}{Logical indicating whether to slim down the data frame.} -\item{verbose}{A logical value indicating whether to print messages.} +\item{verbose}{Logical indicating whether to print progress messages.} } \value{ -A data frame with processed information. +The post-processed data frame. } \description{ -Post-process GEDCOM Data Frame +This function optionally adds parent information, combines duplicate columns, +and removes empty columns from the GEDCOM data frame. } diff --git a/man/postProcessGedcom.legacy.Rd b/man/postProcessGedcom.legacy.Rd new file mode 100644 index 00000000..060b9367 --- /dev/null +++ b/man/postProcessGedcom.legacy.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcomlegacy.R +\name{postProcessGedcom.legacy} +\alias{postProcessGedcom.legacy} +\title{Post-process GEDCOM Data Frame} +\usage{ +postProcessGedcom.legacy( + df_temp, + remove_empty_cols = TRUE, + combine_cols = TRUE, + add_parents = TRUE, + skinny = TRUE, + verbose = FALSE +) +} +\arguments{ +\item{df_temp}{A data frame containing information about individuals.} + +\item{remove_empty_cols}{A logical value indicating whether to remove columns with all missing values.} + +\item{combine_cols}{A logical value indicating whether to combine columns with duplicate values.} + +\item{add_parents}{A logical value indicating whether to add parents to the data frame.} + +\item{skinny}{A logical value indicating whether to return a skinny data frame.} + +\item{verbose}{A logical value indicating whether to print messages.} +} +\value{ +A data frame with processed information. +} +\description{ +Post-process GEDCOM Data Frame +} diff --git a/man/processEventLine.Rd b/man/processEventLine.Rd new file mode 100644 index 00000000..d4cff3d3 --- /dev/null +++ b/man/processEventLine.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcom.R +\name{processEventLine} +\alias{processEventLine} +\title{Process Event Lines (Birth or Death)} +\usage{ +processEventLine(event, block, i, record, pattern_rows) +} +\arguments{ +\item{event}{A character string indicating the event type ("birth" or "death").} + +\item{block}{A character vector of GEDCOM lines.} + +\item{i}{The current line index where the event tag is found.} + +\item{record}{A named list representing the individual's record.} + +\item{pattern_rows}{A list with counts of GEDCOM tag occurrences.} +} +\value{ +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. +} diff --git a/man/processParents.Rd b/man/processParents.Rd index 9aa205a7..aec5deb3 100644 --- a/man/processParents.Rd +++ b/man/processParents.Rd @@ -2,17 +2,18 @@ % Please edit documentation in R/readGedcom.R \name{processParents} \alias{processParents} -\title{Process parents information} +\title{Process Parents Information from GEDCOM Data} \usage{ processParents(df_temp, datasource) } \arguments{ -\item{df_temp}{A data frame containing information about individuals.} +\item{df_temp}{A data frame produced by \code{readGedcom()}.} + +\item{datasource}{Character string indicating the data source ("gedcom" or "wiki").} } \value{ -A data frame with added momID and dadID columns. +The updated data frame with parent IDs added. } \description{ -This function processes the dataframe to add momID and dadID columns. +Adds parent IDs to the individuals based on family relationship data. } -\keyword{internal} diff --git a/man/processParents.legacy.Rd b/man/processParents.legacy.Rd new file mode 100644 index 00000000..774663aa --- /dev/null +++ b/man/processParents.legacy.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcomlegacy.R +\name{processParents.legacy} +\alias{processParents.legacy} +\title{Process parents information} +\usage{ +processParents.legacy(df_temp, datasource) +} +\arguments{ +\item{df_temp}{A data frame containing information about individuals.} +} +\value{ +A data frame with added momID and dadID columns. +} +\description{ +This function processes the dataframe to add momID and dadID columns. +} +\keyword{internal} diff --git a/man/process_tag.legacy.Rd b/man/process_tag.legacy.Rd new file mode 100644 index 00000000..f31cbad6 --- /dev/null +++ b/man/process_tag.legacy.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcomlegacy.R +\name{process_tag.legacy} +\alias{process_tag.legacy} +\title{Process a GEDCOM Tag} +\usage{ +process_tag.legacy( + tag, + field_name, + pattern_rows, + line, + vars, + extractor = NULL, + mode = "replace" +) +} +\arguments{ +\item{tag}{The GEDCOM tag (e.g., "SEX", "CAST", etc.).} + +\item{field_name}{The name of the variable to assign to in `vars`.} + +\item{pattern_rows}{Output from `countPatternRows()`.} + +\item{line}{The GEDCOM line to parse.} + +\item{vars}{The current list of variables to update.} +} +\value{ +A list with updated `vars` and a `matched` flag. +} +\description{ +Extracts and assigns a value to a specified field in `vars` if the pattern is present. +Returns both the updated variable list and a flag indicating whether the tag was matched. +} +\keyword{internal} diff --git a/man/readGedcom.Rd b/man/readGedcom.Rd index a54cd5aa..e345d587 100644 --- a/man/readGedcom.Rd +++ b/man/readGedcom.Rd @@ -99,5 +99,4 @@ A data frame containing information about individuals, with the following potent } \description{ This function reads a GEDCOM file and parses it into a structured data frame of individuals. -Inspired by https://raw.githubusercontent.com/jjfitz/readgedcom/master/R/read_gedcom.R } diff --git a/man/readGedcom.legacy.Rd b/man/readGedcom.legacy.Rd new file mode 100644 index 00000000..e4cf2957 --- /dev/null +++ b/man/readGedcom.legacy.Rd @@ -0,0 +1,78 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcomlegacy.R +\name{readGedcom.legacy} +\alias{readGedcom.legacy} +\title{Read a GEDCOM File} +\usage{ +readGedcom.legacy( + file_path, + verbose = FALSE, + add_parents = TRUE, + remove_empty_cols = TRUE, + combine_cols = TRUE, + skinny = FALSE, + update_rate = 1000, + post_process = TRUE, + ... +) +} +\arguments{ +\item{file_path}{The path to the GEDCOM file.} + +\item{verbose}{A logical value indicating whether to print messages.} + +\item{add_parents}{A logical value indicating whether to add parents to the data frame.} + +\item{remove_empty_cols}{A logical value indicating whether to remove columns with all missing values.} + +\item{combine_cols}{A logical value indicating whether to combine columns with duplicate values.} + +\item{skinny}{A logical value indicating whether to return a skinny data frame.} + +\item{update_rate}{numeric. The rate at which to print progress} + +\item{...}{Additional arguments to be passed to the function.} +} +\value{ +A data frame containing information about individuals, with the following potential columns: +- `id`: ID of the individual +- `momID`: ID of the individual's mother +- `dadID`: ID of the individual's father +- `sex`: Sex of the individual +- `name`: Full name of the individual +- `name_given`: First name of the individual +- `name_surn`: Last name of the individual +- `name_marriedsurn`: Married name of the individual +- `name_nick`: Nickname of the individual +- `name_npfx`: Name prefix +- `name_nsfx`: Name suffix +- `birth_date`: Birth date of the individual +- `birth_lat`: Latitude of the birthplace +- `birth_long`: Longitude of the birthplace +- `birth_place`: Birthplace of the individual +- `death_caus`: Cause of death +- `death_date`: Death date of the individual +- `death_lat`: Latitude of the place of death +- `death_long`: Longitude of the place of death +- `death_place`: Place of death of the individual +- `attribute_caste`: Caste of the individual +- `attribute_children`: Number of children of the individual +- `attribute_description`: Description of the individual +- `attribute_education`: Education of the individual +- `attribute_idnumber`: Identification number of the individual +- `attribute_marriages`: Number of marriages of the individual +- `attribute_nationality`: Nationality of the individual +- `attribute_occupation`: Occupation of the individual +- `attribute_property`: Property owned by the individual +- `attribute_religion`: Religion of the individual +- `attribute_residence`: Residence of the individual +- `attribute_ssn`: Social security number of the individual +- `attribute_title`: Title of the individual +- `FAMC`: ID(s) of the family where the individual is a child +- `FAMS`: ID(s) of the family where the individual is a spouse +} +\description{ +This function reads a GEDCOM file and parses it into a structured data frame of individuals. +Inspired by https://raw.githubusercontent.com/jjfitz/readgedcom/master/R/read_gedcom.R +} +\keyword{internal} diff --git a/man/splitIndividuals.Rd b/man/splitIndividuals.Rd new file mode 100644 index 00000000..dcb9a7e8 --- /dev/null +++ b/man/splitIndividuals.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readGedcom.R +\name{splitIndividuals} +\alias{splitIndividuals} +\title{Split GEDCOM Lines into Individual Blocks} +\usage{ +splitIndividuals(lines, verbose = FALSE) +} +\arguments{ +\item{lines}{A character vector of lines from the GEDCOM file.} + +\item{verbose}{Logical indicating whether to output progress messages.} +} +\value{ +A list of character vectors, each representing one individual. +} +\description{ +This function partitions the GEDCOM file (as a vector of lines) into a list of blocks, +where each block corresponds to a single individual starting with an "@ INDI" line. +} diff --git a/tests/testthat/test-readPedigrees_alpha.R b/tests/testthat/test-readWikiTree.R similarity index 100% rename from tests/testthat/test-readPedigrees_alpha.R rename to tests/testthat/test-readWikiTree.R From 8039214165967e06744a21285739ed0a1e74c2b7 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Wed, 16 Apr 2025 15:53:47 -0400 Subject: [PATCH 42/69] potential more direct methods --- R/convertPedigree.R | 257 ++++++++++++++++++++++++-- data-raw/benchmark.R | 180 +++++++++++++++++- tests/testthat/test-convertPedigree.R | 20 +- 3 files changed, 425 insertions(+), 32 deletions(-) diff --git a/R/convertPedigree.R b/R/convertPedigree.R index 3d5ac7ca..4b033c82 100644 --- a/R/convertPedigree.R +++ b/R/convertPedigree.R @@ -40,6 +40,7 @@ ped2com <- function(ped, component, save_rate_parlist = 100000 * save_rate, update_rate = 100, save_path = "checkpoint/", + method_approach=NULL, ...) { #------ # Checkpointing @@ -160,7 +161,8 @@ ped2com <- function(ped, component, lastComputed = lastComputed, nr = nr, parList = parList, - lens = lens + lens = lens, + method_approach = method_approach ) # Construct sparse matrix @@ -406,7 +408,8 @@ ped2mit <- ped2mt <- function(ped, max.gen = 25, resume = resume, save_rate_gen = save_rate_gen, save_rate_parlist = save_rate_parlist, - save_path = save_path + save_path = save_path, + ... ) } @@ -442,7 +445,8 @@ ped2cn <- function(ped, max.gen = 25, sparse = TRUE, verbose = FALSE, resume = resume, save_rate_gen = save_rate_gen, save_rate_parlist = save_rate_parlist, - save_path = save_path + save_path = save_path, + ... ) } #' Take a pedigree and turn it into an extended environmental relatedness matrix @@ -540,8 +544,7 @@ ped2ce <- function(ped, .adjIndexed <- function(ped, component, saveable, resume, save_path, verbose, lastComputed, nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist, - ...) { + parList, lens, save_rate_parlist) { # Loop through each individual in the pedigree # Build the adjacency matrix for parent-child relationships # Is person in column j the parent of the person in row i? .5 for yes, 0 for no. @@ -599,7 +602,7 @@ ped2ce <- function(ped, .adjDirect <- function(ped, component, saveable, resume, save_path, verbose, lastComputed, nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist, + parList, lens, save_rate_parlist,method_approach, ...) { # Loop through each individual in the pedigree # Build the adjacency matrix for parent-child relationships @@ -615,17 +618,19 @@ ped2ce <- function(ped, iss <- c(mIDs$rID, dIDs$rID) jss <- c(mIDs$cID, dIDs$cID) } else if (component %in% c("common nuclear")) { - message("Common Nuclear component is not yet implemented for direct method. Using index method.\n") - # change to warning and call indexed version - list_of_adjacency <- .adjIndexed(ped = ped, component = component, - saveable = saveable, resume = resume, - save_path = save_path, verbose = verbose, - lastComputed = lastComputed, nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, parList = parList, - lens = lens, save_rate_parlist = save_rate_parlist, - ... - ) + # message("Common Nuclear component is not yet implemented for direct method. Using index method.\n") + + list_of_adjacency <- cnmethods(ped=ped,method_approach=method_approach, + component = component, + saveable = saveable, resume = resume, + save_path = save_path, verbose = verbose, + lastComputed = lastComputed, nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, save_rate_parlist = save_rate_parlist, + ...) + return(list_of_adjacency) } else if (component %in% c("mitochondrial")) { mIDs <- stats::na.omit(data.frame(rID = ped$ID, cID = ped$momID)) @@ -653,9 +658,9 @@ ped2ce <- function(ped, compute_parent_adjacency <- function(ped, component, adjacency_method = "direct", saveable, resume, - save_path, verbose, - lastComputed, nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist, + save_path, verbose=FALSE, + lastComputed=0, nr, checkpoint_files, update_rate, + parList, lens, save_rate_parlist,method_approach=NULL, ...) { if (adjacency_method == "loop") { if (lastComputed < nr) { # Original version @@ -711,6 +716,7 @@ compute_parent_adjacency <- function(ped, component, parList = parList, lens = lens, save_rate_parlist = save_rate_parlist, + method_approach = method_approach, ... ) } @@ -745,3 +751,214 @@ isChild <- function(isChild_method, ped) { }) } } + + +cnmethods <- function(ped,component = "common nuclear", + method_approach=NULL, + parList=NULL, + lastComputed=0, + nr=NULL, + lens=NULL, + saveable=FALSE, + resume=FALSE, + save_path=NULL, + verbose=FALSE, + checkpoint_files=NULL, + ...){# 1) Pairwise compare mother IDs + if(method_approach == 1){ + + # gets slow when data are bigger. much slower than indexed + momMatch <- outer(ped$momID, ped$momID, FUN = "==") + momMatch[is.na(momMatch)] <- FALSE + + # 2) Pairwise compare father IDs + dadMatch <- outer(ped$dadID, ped$dadID, FUN = "==") + dadMatch[is.na(dadMatch)] <- FALSE + + # 3) Sibling adjacency if both mom & dad match + adj <- momMatch & dadMatch + + # 4) Extract indices where adj[i,j] is TRUE + w <- which(adj, arr.ind = TRUE) + # iss <- w[, 1] + # jss <- w[, 2] +# + list_of_adjacency <- list( + iss = w[, 1], + jss = w[, 2] + ) + } else if(method_approach == 2){ + # 1) Create a logical mask for known parents + mask <- !is.na(ped$momID) & !is.na(ped$dadID) + + # 2) Create a single string label for each known (momID, dadID) pair + pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) + + # 3) Factor that label => each row with the same (mom,dad) gets the same integer code + # This is "creating a new ID" for each unique parent pair + pairCode <- match(pairLabel, unique(pairLabel)) + + # childVec are the row indices in 'ped' that have known parents + childVec <- which(mask) # length(childVec) = sum(mask) + + # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" + groupList <- split(childVec, pairCode) + + # 5) For each group with >1 children, form pairwise adjacency i->j + iss_list <- list() + jss_list <- list() + counter <- 1 + + for (g in groupList) { + if (length(g) > 1) { + combos <- expand.grid(g, g, KEEP.OUT.ATTRS = FALSE) + combos <- combos[combos[,1] != combos[,2], , drop = FALSE] + iss_list[[counter]] <- combos[,1] + jss_list[[counter]] <- combos[,2] + counter <- counter + 1 + } + } + # iss <- unlist(iss_list, use.names = FALSE) + # jss <- unlist(jss_list, use.names = FALSE) + + list_of_adjacency <- list( + iss = unlist(iss_list, use.names = FALSE), + jss = unlist(jss_list, use.names = FALSE) + ) + } else if(method_approach == 3){ + nr <- nrow(ped) +# terrible + # Define a scalar-checking function: + f_check <- function(i, j) { + # i, j are each single integers + # Return one boolean: do they share both parents? + !is.na(ped$momID[i]) && !is.na(ped$dadID[i]) && + !is.na(ped$momID[j]) && !is.na(ped$dadID[j]) && + (ped$momID[i] == ped$momID[j]) && + (ped$dadID[i] == ped$dadID[j]) + } + + # Vectorize it so outer() will produce an nr x nr matrix + vf_check <- Vectorize(f_check) + + # Now outer() calls vf_check(...) in a way that yields scalar results + adj <- outer(seq_len(nr), seq_len(nr), FUN = vf_check) + + # Extract which cells of adj are TRUE + w <- which(adj, arr.ind = TRUE) + # iss <- w[, 1] + # jss <- w[, 2] + + list_of_adjacency <- list( + iss = iss <- w[, 1], + jss = jss <- w[, 2] + ) +}else if(method_approach == 4){ + + # 1) Create a logical mask for known parents + mask <- !is.na(ped$momID) & !is.na(ped$dadID) + + # 2) Create a single string label for each known (momID, dadID) pair + pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) + + # 3) Factor that label => each row with the same (mom,dad) gets the same integer code + pairCode <- match(pairLabel, unique(pairLabel)) + + # childVec are the row indices in 'ped' that have known parents + childVec <- which(mask) + + # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" + groupList <- split(childVec, pairCode) + + # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j + iss_list <- vector("list", length(groupList)) + jss_list <- vector("list", length(groupList)) + counter <- 1 + + for (g in groupList) { + k <- length(g) + if (k > 1) { + # We'll form all k^2 combos, then remove the diagonal i=j + # Instead of expand.grid, do rep() calls: + + # v = each child repeated k times + # w = entire group repeated once for each child + v <- rep(g, each = k) # row index + w <- rep(g, times = k) # col index + + keep <- (v != w) # remove diagonal where v == w + iss_list[[counter]] <- v[keep] + jss_list[[counter]] <- w[keep] + counter <- counter + 1 + } + } + + list_of_adjacency <- list( + iss = unlist(iss_list, use.names = FALSE), + jss = unlist(jss_list, use.names = FALSE) + ) + + } else if(method_approach == 5){ + # 1) Create a logical mask for known parents + mask <- !is.na(ped$momID) & !is.na(ped$dadID) + + # 2) Create a single string label for each known (momID, dadID) pair + #pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) + base <- max(ped$ID, na.rm = TRUE) + 1L + pairCode <- ped$momID[mask] + base * ped$dadID[mask] + + # 3) Factor that label => each row with the same (mom,dad) gets the same integer code + # pairCode <- match(pairLabel, unique(pairLabel)) + + # childVec are the row indices in 'ped' that have known parents + childVec <- which(mask) + + # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" + groupList <- split(childVec, pairCode) + + # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j + iss_list <- vector("list", length(groupList)) + jss_list <- vector("list", length(groupList)) + counter <- 1 + + for (g in groupList) { + k <- length(g) + if (k > 1) { + # We'll form all k^2 combos, then remove the diagonal i=j + # Instead of expand.grid, do rep() calls: + + # v = each child repeated k times + # w = entire group repeated once for each child + v <- rep(g, each = k) # row index + w <- rep(g, times = k) # col index + + keep <- (v != w) # remove diagonal where v == w + iss_list[[counter]] <- v[keep] + jss_list[[counter]] <- w[keep] + counter <- counter + 1 + } + } + + list_of_adjacency <- list( + iss = unlist(iss_list, use.names = FALSE), + jss = unlist(jss_list, use.names = FALSE) + ) + + }else{ + + list_of_adjacency <- .adjIndexed(ped = ped, component = component, + saveable = saveable, resume = resume, + save_path = save_path, verbose = verbose, + lastComputed = lastComputed, nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, parList = parList, + lens = lens, save_rate_parlist = save_rate_parlist + ) + + } + + + + return(list_of_adjacency) + +} diff --git a/data-raw/benchmark.R b/data-raw/benchmark.R index 536190b1..96d25d67 100644 --- a/data-raw/benchmark.R +++ b/data-raw/benchmark.R @@ -27,6 +27,7 @@ ped2 <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) %>% ) set.seed(1151) kpc <- 8 +Ngen <- 10 ped3 <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) %>% mutate( fam = "fam 3", @@ -35,25 +36,62 @@ ped3 <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) %>% dadID = dadID + 20000, spID = spID + 20000 ) +ped3 <- ped3 %>% + mutate( + fam = "fam 4", + ID = ID + 10000, + momID = momID + 10000, + dadID = dadID + 10000, + spID = spID + 10000 + ) %>% rbind(ped3) + +set.seed(1151) +kpc <- 2 +Ngen <- 10 +ped4 <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) %>% + mutate( + fam = "fam 5", + ID = ID + 40000, + momID = momID + 40000, + dadID = dadID + 40000, + spID = spID + 40000 + ) + + ped <- rbind(ped, ped2) ped <- rbind(ped, ped3) -if(FALSE){ +ped <- rbind(ped, ped4) + +if(TRUE){ # Define parameters -component <- "additive" # Change this to test different components +component <- "common nuclear"#"additive" # Change this to test different components saveable <- FALSE # Disable saving to avoid disk I/O slowing down benchmarking resume <- FALSE # Disable resume to ensure full fresh runs save_path <- "checkpoint/" verbose <- FALSE # Turn off verbose for cleaner output update_rate <- 100 save_rate_parlist <- 1000 - +#method_approach <- 1 # Run benchmarking for "loop" and "indexed" methods in ped2com() benchmark_results <- microbenchmark( - loop = { +# loop_big = { +# ped2com( +# ped = ped, +# component = component, +# adjacency_method = "loop", # Test "loop" method +# saveable = saveable, +# resume = resume, +# save_path = save_path, +# verbose = verbose, +# update_rate = update_rate, +# save_rate_parlist = save_rate_parlist +# ) +# }, + indexed_big = { ped2com( ped = ped, component = component, - adjacency_method = "loop", # Test "loop" method + adjacency_method = "indexed", # Test "indexed" method saveable = saveable, resume = resume, save_path = save_path, @@ -62,10 +100,66 @@ benchmark_results <- microbenchmark( save_rate_parlist = save_rate_parlist ) }, - indexed = { + direct4_big = { ped2com( ped = ped, component = component, + adjacency_method = "direct", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + method_approach = 4, + save_rate_parlist = save_rate_parlist + ) + }, + direct2_big = { + ped2com( + ped = ped, + component = component, + adjacency_method = "direct", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + method_approach = 2, + save_rate_parlist = save_rate_parlist + ) + }, + direct5_big = { + ped2com( + ped = ped, + component = component, + adjacency_method = "direct", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + method_approach = 5, + save_rate_parlist = save_rate_parlist + ) + }, +# loop = { +# ped2com( +# ped = ped2, +# component = component, +# adjacency_method = "loop", # Test "loop" method +# saveable = saveable, +# resume = resume, +# save_path = save_path, +# verbose = verbose, +# update_rate = update_rate, +# save_rate_parlist = save_rate_parlist +# +# ) +# }, + indexed = { + ped2com( + ped = ped2, + component = component, adjacency_method = "indexed", # Test "indexed" method saveable = saveable, resume = resume, @@ -75,14 +169,81 @@ benchmark_results <- microbenchmark( save_rate_parlist = save_rate_parlist ) }, + direct4 = { + ped2com( + ped = ped2, + component = component, + adjacency_method = "direct", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + method_approach = 4, + save_rate_parlist = save_rate_parlist + ) + }, + direct2 = { + ped2com( + ped = ped2, + component = component, + adjacency_method = "direct", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + method_approach = 2, + save_rate_parlist = save_rate_parlist + ) + }, + direct5 = { + ped2com( + ped = ped2, + component = component, + adjacency_method = "direct", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + method_approach = 5, + save_rate_parlist = save_rate_parlist + ) + }, times = 100 # Run each method 100 times ) + summary(benchmark_results) -lm(benchmark_results$time ~ benchmark_results$expr) %>% - summary() +df_plot <- benchmark_results %>% mutate(size = case_when(expr %in% c("loop", "indexed", "direct4", "direct2", "direct5") ~ "small", + expr %in% c("loop_big", "indexed_big", "direct4_big", "direct2_big", "direct5_big") ~ "big"), + method = case_when(expr %in% c("loop", "loop_big") ~ "loop", + expr %in% c("indexed", "indexed_big") ~ "indexed", + expr %in% c("direct4", "direct4_big") ~ "direct4", + expr %in% c("direct2", "direct2_big") ~ "direct2", + expr %in% c("direct5", "direct5_big") ~ "direct5"))# %>% + +# set indexed as reference level +df_plot$method <- factor(df_plot$method, levels = c("indexed", "loop","direct2", "direct4", "direct5")) +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 = "Benchmarking Results", + x = "Method", + y = "Time (seconds)") + + theme_minimal() + + theme(axis.text.x = element_text(angle = 45, hjust = 1)) # Print benchmark results + +p print(benchmark_results) # Optional: Save results to CSV for later analysis @@ -92,6 +253,8 @@ write.csv(summary(benchmark_results), ) # Print benchmark } + +if(FALSE){ verbose=FALSE ad_ped_matrix <- ped2com(ped, component = "additive", adjacency_method = "direct", sparse = TRUE) mit_ped_matrix <- ped2com(ped, component = "mitochondrial", adjacency_method = "direct", sparse = TRUE) @@ -138,3 +301,4 @@ write.csv(summary(benchmark_results), "benchmark_results.csv", row.names = FALSE ) +} diff --git a/tests/testthat/test-convertPedigree.R b/tests/testthat/test-convertPedigree.R index ec5af8b1..9e18c892 100644 --- a/tests/testthat/test-convertPedigree.R +++ b/tests/testthat/test-convertPedigree.R @@ -297,14 +297,26 @@ test_that("adjacency_method 'indexed', 'loop', and direct produce the same resu test_that("adjacency_method 'indexed', 'loop', and direct produce the same results for common nuclear matrix", { data(hazard) tolerance <- 1e-10 - + method_approach_1 <- 1 + method_approach_2 <- 4 + method_approach_3 <- 5 # common nuclear ped_common_indexed <- ped2com(hazard, component = "common nuclear", adjacency_method = "indexed") ped_common_loop <- ped2com(hazard, component = "common nuclear", adjacency_method = "loop") - ped_common_direct <- ped2com(hazard, component = "common nuclear", adjacency_method = "direct") + ped_common_direct1 <- ped2com(hazard, component = "common nuclear", adjacency_method = "direct",method_approach = method_approach_1) + ped_common_direct2 <- ped2com(hazard, component = "common nuclear", adjacency_method = "direct",method_approach = method_approach_2) + ped_common_direct3 <- ped2com(hazard, component = "common nuclear", adjacency_method = "direct",method_approach = method_approach_3) + expect_equal(ped_common_indexed, ped_common_loop, tolerance = tolerance) - expect_equal(ped_common_loop, ped_common_direct, tolerance = tolerance) - expect_equal(ped_common_indexed, ped_common_direct, tolerance = tolerance) + expect_equal(ped_common_loop, ped_common_direct1, tolerance = tolerance) + expect_equal(ped_common_indexed, ped_common_direct1, tolerance = tolerance) + expect_equal(ped_common_loop, ped_common_direct2, tolerance = tolerance) + expect_equal(ped_common_indexed, ped_common_direct2, tolerance = tolerance) + expect_equal(ped_common_loop, ped_common_direct3, tolerance = tolerance) + expect_equal(ped_common_indexed, ped_common_direct3, tolerance = tolerance) + expect_equal(ped_common_direct1, ped_common_direct2, tolerance = tolerance) + expect_equal(ped_common_direct1, ped_common_direct3, tolerance = tolerance) + expect_equal(ped_common_direct2, ped_common_direct3, tolerance = tolerance) }) From 3293ebdf49b4b995e3c1669a65e94b94ea706627 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Wed, 16 Apr 2025 16:09:41 -0400 Subject: [PATCH 43/69] BENCHMARCKING --- R/convertPedigree.R | 5 +---- data-raw/benchmark.R | 36 ++++++++++++++++++------------------ 2 files changed, 19 insertions(+), 22 deletions(-) diff --git a/R/convertPedigree.R b/R/convertPedigree.R index 4b033c82..f099df8a 100644 --- a/R/convertPedigree.R +++ b/R/convertPedigree.R @@ -902,15 +902,12 @@ cnmethods <- function(ped,component = "common nuclear", # 1) Create a logical mask for known parents mask <- !is.na(ped$momID) & !is.na(ped$dadID) - # 2) Create a single string label for each known (momID, dadID) pair + # 2) Create a single hash label for each known (momID, dadID) pair #pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) base <- max(ped$ID, na.rm = TRUE) + 1L pairCode <- ped$momID[mask] + base * ped$dadID[mask] # 3) Factor that label => each row with the same (mom,dad) gets the same integer code - # pairCode <- match(pairLabel, unique(pairLabel)) - - # childVec are the row indices in 'ped' that have known parents childVec <- which(mask) # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" diff --git a/data-raw/benchmark.R b/data-raw/benchmark.R index 96d25d67..4a615af2 100644 --- a/data-raw/benchmark.R +++ b/data-raw/benchmark.R @@ -20,29 +20,29 @@ marR <- .8 ped2 <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) %>% mutate( fam = "fam 2", - ID = ID + 10000, - momID = momID + 10000, - dadID = dadID + 10000, - spID = spID + 10000 + ID = ID + max(ped2$ID, na.rm = TRUE), + momID = momID + max(ped$ID, na.rm = TRUE), + dadID = dadID + max(ped$ID, na.rm = TRUE), + spID = spID + max(ped$ID, na.rm = TRUE) ) set.seed(1151) kpc <- 8 -Ngen <- 10 +Ngen <- 6 ped3 <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) %>% mutate( fam = "fam 3", - ID = ID + 20000, - momID = momID + 20000, - dadID = dadID + 20000, - spID = spID + 20000 + ID = ID + max(ped2$ID, na.rm = TRUE), + momID = momID + max(ped2$ID, na.rm = TRUE), + dadID = dadID + max(ped2$ID, na.rm = TRUE), + spID = spID + max(ped2$ID, na.rm = TRUE) ) ped3 <- ped3 %>% mutate( fam = "fam 4", - ID = ID + 10000, - momID = momID + 10000, - dadID = dadID + 10000, - spID = spID + 10000 + ID = ID + max(ped3$ID, na.rm = TRUE), + momID = momID + max(ped3$ID, na.rm = TRUE), + dadID = dadID + max(ped3$ID, na.rm = TRUE), + spID = spID + max(ped3$ID, na.rm = TRUE) ) %>% rbind(ped3) set.seed(1151) @@ -51,10 +51,10 @@ Ngen <- 10 ped4 <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) %>% mutate( fam = "fam 5", - ID = ID + 40000, - momID = momID + 40000, - dadID = dadID + 40000, - spID = spID + 40000 + ID = ID + max(ped3$ID, na.rm = TRUE), + momID = momID + max(ped3$ID, na.rm = TRUE), + dadID = dadID + max(ped3$ID, na.rm = TRUE), + spID = spID + max(ped3$ID, na.rm = TRUE) ) @@ -211,7 +211,7 @@ benchmark_results <- microbenchmark( save_rate_parlist = save_rate_parlist ) }, - times = 100 # Run each method 100 times + times = 10 # Run each method 100 times ) From 2ae433616e1db4752fb2f9b2c4a53bfdbabb1a86 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Wed, 16 Apr 2025 20:00:26 -0400 Subject: [PATCH 44/69] rolling out a direct(ish) method --- NEWS.md | 1 + R/convertPedigree.R | 120 +++++++++++++++++++------- R/helpPedigree.R | 2 + R/readGedcom.R | 3 +- man/compute_parent_adjacency.Rd | 9 +- man/determineSex.Rd | 4 + man/ped2add.Rd | 2 +- man/ped2cn.Rd | 4 +- man/ped2com.Rd | 5 +- man/ped2mit.Rd | 2 +- man/readGedcom.Rd | 2 + tests/testthat/test-convertPedigree.R | 30 +++---- 12 files changed, 127 insertions(+), 57 deletions(-) diff --git a/NEWS.md b/NEWS.md index fd941969..c0daa9a2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,6 +6,7 @@ * allow verbose argument to be passed to standardizeColnames * list SimPed and related_coef as aliases for functions * harmonizing function names like calcFamilySize from famSizeCal +* implemented adjBeta function to evaluation alternative build method # BGmisc 1.3.5.1 * Setting the default for the `sparse` argument in `ped2com()` to TRUE diff --git a/R/convertPedigree.R b/R/convertPedigree.R index f099df8a..ae76cab0 100644 --- a/R/convertPedigree.R +++ b/R/convertPedigree.R @@ -17,8 +17,9 @@ #' @param flatten.diag logical. If TRUE, overwrite the diagonal of the final relatedness matrix with ones #' @param standardize.colnames logical. If TRUE, standardize the column names of the pedigree dataset #' @param transpose_method character. The method to use for computing the transpose. Options are "tcrossprod", "crossprod", or "star" -#' @param adjacency_method character. The method to use for computing the adjacency matrix. Options are "loop" or "indexed" +#' @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 adjBeta_method numeric The method to use for computing the building the adjacency_method matrix when using the "beta" build #' @param ... additional arguments to be passed to \code{\link{ped2com}} #' @details The algorithms and methodologies used in this function are further discussed and exemplified in the vignette titled "examplePedigreeFunctions". For more advanced scenarios and detailed explanations, consult this vignette. #' @export @@ -40,7 +41,7 @@ ped2com <- function(ped, component, save_rate_parlist = 100000 * save_rate, update_rate = 100, save_path = "checkpoint/", - method_approach=NULL, + adjBeta_method=NULL, ...) { #------ # Checkpointing @@ -90,8 +91,8 @@ ped2com <- function(ped, component, if (!transpose_method %in% c("tcrossprod", "crossprod", "star", "tcross.alt.crossprod", "tcross.alt.star")) { stop("Invalid method specified. Choose from 'tcrossprod', 'crossprod', or 'star' or 'tcross.alt.crossprod' or 'tcross.alt.star'.") } - if (!adjacency_method %in% c("indexed", "loop", "direct")) { - stop("Invalid method specified. Choose from 'indexed', 'loop', or 'direct'.") + if (!adjacency_method %in% c("indexed", "loop", "direct", "beta")) { + stop("Invalid method specified. Choose from 'indexed', 'loop', 'direct', or 'beta'.") } # standardize colnames @@ -162,7 +163,7 @@ ped2com <- function(ped, component, nr = nr, parList = parList, lens = lens, - method_approach = method_approach + adjBeta_method = adjBeta_method ) # Construct sparse matrix @@ -425,7 +426,7 @@ ped2cn <- function(ped, max.gen = 25, sparse = TRUE, verbose = FALSE, saveable = FALSE, resume = FALSE, save_rate = 5, - adjacency_method = "indexed", + adjacency_method = "direct", save_rate_gen = save_rate, save_rate_parlist = 1000 * save_rate, save_path = "checkpoint/", @@ -602,7 +603,7 @@ ped2ce <- function(ped, .adjDirect <- function(ped, component, saveable, resume, save_path, verbose, lastComputed, nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist,method_approach, + parList, lens, save_rate_parlist,adjBeta_method, ...) { # Loop through each individual in the pedigree # Build the adjacency matrix for parent-child relationships @@ -620,18 +621,58 @@ ped2ce <- function(ped, } else if (component %in% c("common nuclear")) { # message("Common Nuclear component is not yet implemented for direct method. Using index method.\n") - list_of_adjacency <- cnmethods(ped=ped,method_approach=method_approach, - component = component, - saveable = saveable, resume = resume, - save_path = save_path, verbose = verbose, - lastComputed = lastComputed, nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, save_rate_parlist = save_rate_parlist, - ...) - - return(list_of_adjacency) + # 1) Create a logical mask for only known parents + mask <- !is.na(ped$momID) & !is.na(ped$dadID) + + # 2) Create a single hash label for each known (momID, dadID) pair + base <- max(ped$ID, na.rm = TRUE) + 1L + pairCode <- ped$momID[mask] + base * ped$dadID[mask] + + # 3) Factor that label => each row with the same (mom,dad) gets the same integer code + childVec <- which(mask) + + # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" + groupList <- split(childVec, pairCode) + + # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j + iss_list <- vector("list", length(groupList)) + jss_list <- vector("list", length(groupList)) + counter <- 1 + + for (g in groupList) { + k <- length(g) + if (k > 1) { + # We'll form all k^2 combos, then remove the diagonal i=j + # rep() calls faster than expand.grid + + # v = each child repeated k times + # w = entire group repeated once for each child + v <- rep(g, each = k) # row index + w <- rep(g, times = k) # col index + + keep <- (v != w) # remove diagonal where v == w + iss_list[[counter]] <- v[keep] + jss_list[[counter]] <- w[keep] + counter <- counter + 1 + } + } + + + iss <- unlist(iss_list, use.names = FALSE) + jss <- unlist(jss_list, use.names = FALSE) + + # list_of_adjacency <- .adjBeta(ped=ped,adjBeta_method=adjBeta_method, +# component = component, + # saveable = saveable, resume = resume, + # save_path = save_path, verbose = verbose, + # lastComputed = lastComputed, nr = nr, + # checkpoint_files = checkpoint_files, + # update_rate = update_rate, + # parList = parList, + # lens = lens, save_rate_parlist = save_rate_parlist, + # ...) + + # return(list_of_adjacency) } else if (component %in% c("mitochondrial")) { mIDs <- stats::na.omit(data.frame(rID = ped$ID, cID = ped$momID)) iss <- c(mIDs$rID) @@ -660,7 +701,7 @@ compute_parent_adjacency <- function(ped, component, saveable, resume, save_path, verbose=FALSE, lastComputed=0, nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist,method_approach=NULL, + parList, lens, save_rate_parlist,adjBeta_method=NULL, ...) { if (adjacency_method == "loop") { if (lastComputed < nr) { # Original version @@ -716,12 +757,27 @@ compute_parent_adjacency <- function(ped, component, parList = parList, lens = lens, save_rate_parlist = save_rate_parlist, - method_approach = method_approach, ... ) } + } else if (adjacency_method == "beta") { + list_of_adjacency <- .adjBeta(ped = ped, + adjBeta_method = adjBeta_method, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ...) } else { - stop("Invalid method specified. Choose from 'loop', 'direct', or 'indexed'.") + stop("Invalid method specified. Choose from 'loop', 'direct', 'indexed', or beta") } if (saveable) { saveRDS(parList, file = checkpoint_files$parList) @@ -753,8 +809,8 @@ isChild <- function(isChild_method, ped) { } -cnmethods <- function(ped,component = "common nuclear", - method_approach=NULL, +.adjBeta <- function(ped,component, + adjBeta_method=5, parList=NULL, lastComputed=0, nr=NULL, @@ -763,9 +819,11 @@ cnmethods <- function(ped,component = "common nuclear", resume=FALSE, save_path=NULL, verbose=FALSE, + save_rate_parlist=NULL, + update_rate=NULL, checkpoint_files=NULL, ...){# 1) Pairwise compare mother IDs - if(method_approach == 1){ + if(adjBeta_method == 1){ # gets slow when data are bigger. much slower than indexed momMatch <- outer(ped$momID, ped$momID, FUN = "==") @@ -787,7 +845,7 @@ cnmethods <- function(ped,component = "common nuclear", iss = w[, 1], jss = w[, 2] ) - } else if(method_approach == 2){ + } else if(adjBeta_method == 2){ # 1) Create a logical mask for known parents mask <- !is.na(ped$momID) & !is.na(ped$dadID) @@ -825,7 +883,7 @@ cnmethods <- function(ped,component = "common nuclear", iss = unlist(iss_list, use.names = FALSE), jss = unlist(jss_list, use.names = FALSE) ) - } else if(method_approach == 3){ + } else if(adjBeta_method == 3){ nr <- nrow(ped) # terrible # Define a scalar-checking function: @@ -853,7 +911,7 @@ cnmethods <- function(ped,component = "common nuclear", iss = iss <- w[, 1], jss = jss <- w[, 2] ) -}else if(method_approach == 4){ +}else if(adjBeta_method == 4){ # 1) Create a logical mask for known parents mask <- !is.na(ped$momID) & !is.na(ped$dadID) @@ -898,7 +956,7 @@ cnmethods <- function(ped,component = "common nuclear", jss = unlist(jss_list, use.names = FALSE) ) - } else if(method_approach == 5){ + } else if(adjBeta_method == 5){ # 1) Create a logical mask for known parents mask <- !is.na(ped$momID) & !is.na(ped$dadID) @@ -953,9 +1011,5 @@ cnmethods <- function(ped,component = "common nuclear", ) } - - - return(list_of_adjacency) - } diff --git a/R/helpPedigree.R b/R/helpPedigree.R index f9e7c855..e46d49cf 100644 --- a/R/helpPedigree.R +++ b/R/helpPedigree.R @@ -39,6 +39,8 @@ createGenDataFrame <- function(sizeGens, genIndex, idGen) { #' #' @param idGen Vector of IDs for the generation. #' @param sexR Numeric value indicating the sex ratio (proportion of males). +#' @param recode_male The value to use for males. Default is "M" +#' @param recode_female The value to use for females. Default is "F" #' @return Vector of sexes ("M" for male, "F" for female) for the offspring. #' @importFrom stats runif determineSex <- function(idGen, sexR, code_male = "M", code_female = "F") { diff --git a/R/readGedcom.R b/R/readGedcom.R index 109377e1..29462ad2 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -9,6 +9,7 @@ #' @param verbose A logical value indicating whether to print messages. #' @param skinny A logical value indicating whether to return a skinny data frame. #' @param update_rate numeric. The rate at which to print progress +#' @param post_process A logical value indicating whether to post-process the data frame. #' @param ... Additional arguments to be passed to the function. #' @return A data frame containing information about individuals, with the following potential columns: #' - `id`: ID of the individual @@ -154,7 +155,7 @@ splitIndividuals <- function(lines, verbose = FALSE) { #' @param all_var_names A character vector of variable names. #' @return A named list representing an empty individual record. initializeRecord <- function(all_var_names) { - setNames(as.list(rep(NA_character_, length(all_var_names))), all_var_names) + stats::setNames(as.list(rep(NA_character_, length(all_var_names))), all_var_names) } #' Parse a GEDCOM Individual Block diff --git a/man/compute_parent_adjacency.Rd b/man/compute_parent_adjacency.Rd index 21974673..f6364808 100644 --- a/man/compute_parent_adjacency.Rd +++ b/man/compute_parent_adjacency.Rd @@ -11,14 +11,15 @@ compute_parent_adjacency( saveable, resume, save_path, - verbose, - lastComputed, + verbose = FALSE, + lastComputed = 0, nr, checkpoint_files, update_rate, parList, lens, save_rate_parlist, + adjBeta_method = NULL, ... ) } @@ -27,7 +28,7 @@ compute_parent_adjacency( \item{component}{character. Which component of the pedigree to return. See Details.} -\item{adjacency_method}{character. The method to use for computing the adjacency matrix. Options are "loop" or "indexed"} +\item{adjacency_method}{character. The method to use for computing the adjacency matrix. Options are "loop", "indexed", direct or beta} \item{saveable}{logical. If TRUE, save the intermediate results to disk} @@ -51,6 +52,8 @@ compute_parent_adjacency( \item{save_rate_parlist}{numeric. The rate at which to save the intermediate results by parent list. If NULL, defaults to save_rate*1000} +\item{adjBeta_method}{numeric The method to use for computing the building the adjacency_method matrix when using the "beta" build} + \item{...}{additional arguments to be passed to \code{\link{ped2com}}} } \description{ diff --git a/man/determineSex.Rd b/man/determineSex.Rd index c1c096af..4ea9498a 100644 --- a/man/determineSex.Rd +++ b/man/determineSex.Rd @@ -10,6 +10,10 @@ determineSex(idGen, sexR, code_male = "M", code_female = "F") \item{idGen}{Vector of IDs for the generation.} \item{sexR}{Numeric value indicating the sex ratio (proportion of males).} + +\item{recode_male}{The value to use for males. Default is "M"} + +\item{recode_female}{The value to use for females. Default is "F"} } \value{ Vector of sexes ("M" for male, "F" for female) for the offspring. diff --git a/man/ped2add.Rd b/man/ped2add.Rd index 79803b21..c2179e99 100644 --- a/man/ped2add.Rd +++ b/man/ped2add.Rd @@ -42,7 +42,7 @@ ped2add( \item{transpose_method}{character. The method to use for computing the transpose. Options are "tcrossprod", "crossprod", or "star"} -\item{adjacency_method}{character. The method to use for computing the adjacency matrix. Options are "loop" or "indexed"} +\item{adjacency_method}{character. The method to use for computing the adjacency matrix. Options are "loop", "indexed", direct or beta} \item{saveable}{logical. If TRUE, save the intermediate results to disk} diff --git a/man/ped2cn.Rd b/man/ped2cn.Rd index 82d25902..c738d13b 100644 --- a/man/ped2cn.Rd +++ b/man/ped2cn.Rd @@ -16,7 +16,7 @@ ped2cn( saveable = FALSE, resume = FALSE, save_rate = 5, - adjacency_method = "indexed", + adjacency_method = "direct", save_rate_gen = save_rate, save_rate_parlist = 1000 * save_rate, save_path = "checkpoint/", @@ -48,7 +48,7 @@ ped2cn( \item{save_rate}{numeric. The rate at which to save the intermediate results} -\item{adjacency_method}{character. The method to use for computing the adjacency matrix. Options are "loop" or "indexed"} +\item{adjacency_method}{character. The method to use for computing the adjacency matrix. Options are "loop", "indexed", direct or beta} \item{save_rate_gen}{numeric. The rate at which to save the intermediate results by generation. If NULL, defaults to save_rate} diff --git a/man/ped2com.Rd b/man/ped2com.Rd index c47d5982..58c0fc47 100644 --- a/man/ped2com.Rd +++ b/man/ped2com.Rd @@ -23,6 +23,7 @@ ped2com( save_rate_parlist = 1e+05 * save_rate, update_rate = 100, save_path = "checkpoint/", + adjBeta_method = NULL, ... ) } @@ -47,7 +48,7 @@ ped2com( \item{transpose_method}{character. The method to use for computing the transpose. Options are "tcrossprod", "crossprod", or "star"} -\item{adjacency_method}{character. The method to use for computing the adjacency matrix. Options are "loop" or "indexed"} +\item{adjacency_method}{character. The method to use for computing the adjacency matrix. Options are "loop", "indexed", direct or beta} \item{isChild_method}{character. The method to use for computing the isChild matrix. Options are "classic" or "partialparent"} @@ -65,6 +66,8 @@ ped2com( \item{save_path}{character. The path to save the checkpoint files} +\item{adjBeta_method}{numeric The method to use for computing the building the adjacency_method matrix when using the "beta" build} + \item{...}{additional arguments to be passed to \code{\link{ped2com}}} } \description{ diff --git a/man/ped2mit.Rd b/man/ped2mit.Rd index d11480d1..c19e9ba7 100644 --- a/man/ped2mit.Rd +++ b/man/ped2mit.Rd @@ -43,7 +43,7 @@ ped2mit( \item{transpose_method}{character. The method to use for computing the transpose. Options are "tcrossprod", "crossprod", or "star"} -\item{adjacency_method}{character. The method to use for computing the adjacency matrix. Options are "loop" or "indexed"} +\item{adjacency_method}{character. The method to use for computing the adjacency matrix. Options are "loop", "indexed", direct or beta} \item{saveable}{logical. If TRUE, save the intermediate results to disk} diff --git a/man/readGedcom.Rd b/man/readGedcom.Rd index e345d587..d9701427 100644 --- a/man/readGedcom.Rd +++ b/man/readGedcom.Rd @@ -57,6 +57,8 @@ readgedcom( \item{update_rate}{numeric. The rate at which to print progress} +\item{post_process}{A logical value indicating whether to post-process the data frame.} + \item{...}{Additional arguments to be passed to the function.} } \value{ diff --git a/tests/testthat/test-convertPedigree.R b/tests/testthat/test-convertPedigree.R index 9e18c892..a4b747e1 100644 --- a/tests/testthat/test-convertPedigree.R +++ b/tests/testthat/test-convertPedigree.R @@ -297,26 +297,26 @@ test_that("adjacency_method 'indexed', 'loop', and direct produce the same resu test_that("adjacency_method 'indexed', 'loop', and direct produce the same results for common nuclear matrix", { data(hazard) tolerance <- 1e-10 - method_approach_1 <- 1 - method_approach_2 <- 4 - method_approach_3 <- 5 + adjBeta_method_1 <- 1 + adjBeta_method_2 <- 4 + adjBeta_method_3 <- 5 # common nuclear ped_common_indexed <- ped2com(hazard, component = "common nuclear", adjacency_method = "indexed") ped_common_loop <- ped2com(hazard, component = "common nuclear", adjacency_method = "loop") - ped_common_direct1 <- ped2com(hazard, component = "common nuclear", adjacency_method = "direct",method_approach = method_approach_1) - ped_common_direct2 <- ped2com(hazard, component = "common nuclear", adjacency_method = "direct",method_approach = method_approach_2) - ped_common_direct3 <- ped2com(hazard, component = "common nuclear", adjacency_method = "direct",method_approach = method_approach_3) + ped_common_direct <- ped2com(hazard, component = "common nuclear", adjacency_method = "direct") + ped_common_adjBeta_1 <- ped2com(hazard, component = "common nuclear", adjacency_method = "beta",adjBeta_method = adjBeta_method_2) + ped_common_adjBeta_2 <- ped2com(hazard, component = "common nuclear", adjacency_method = "beta",adjBeta_method = adjBeta_method_3) expect_equal(ped_common_indexed, ped_common_loop, tolerance = tolerance) - expect_equal(ped_common_loop, ped_common_direct1, tolerance = tolerance) - expect_equal(ped_common_indexed, ped_common_direct1, tolerance = tolerance) - expect_equal(ped_common_loop, ped_common_direct2, tolerance = tolerance) - expect_equal(ped_common_indexed, ped_common_direct2, tolerance = tolerance) - expect_equal(ped_common_loop, ped_common_direct3, tolerance = tolerance) - expect_equal(ped_common_indexed, ped_common_direct3, tolerance = tolerance) - expect_equal(ped_common_direct1, ped_common_direct2, tolerance = tolerance) - expect_equal(ped_common_direct1, ped_common_direct3, tolerance = tolerance) - expect_equal(ped_common_direct2, ped_common_direct3, tolerance = tolerance) + expect_equal(ped_common_loop, ped_common_direct, tolerance = tolerance) + expect_equal(ped_common_indexed, ped_common_direct, tolerance = tolerance) + expect_equal(ped_common_loop, ped_common_adjBeta_1, tolerance = tolerance) + expect_equal(ped_common_indexed, ped_common_adjBeta_1, tolerance = tolerance) + expect_equal(ped_common_loop, ped_common_adjBeta_2, tolerance = tolerance) + expect_equal(ped_common_indexed, ped_common_adjBeta_2, tolerance = tolerance) + expect_equal(ped_common_direct, ped_common_adjBeta_1, tolerance = tolerance) + expect_equal(ped_common_direct, ped_common_adjBeta_2, tolerance = tolerance) + expect_equal(ped_common_adjBeta_1, ped_common_adjBeta_2, tolerance = tolerance) }) From 76ebddc133ff4041b228194e8e8e8a95a5b82ed6 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Wed, 16 Apr 2025 20:06:45 -0400 Subject: [PATCH 45/69] styler --- R/checkParents.R | 12 +- R/convertPedigree.R | 293 ++++++++-------- R/makeLinks.R | 407 ++++++++++++----------- R/makeLinkslegacy.R | 1 - R/readGedcom.R | 105 +++--- R/readGedcomlegacy.R | 70 ++-- R/simulatePedigree.R | 12 +- data-raw/benchged.R | 4 +- data-raw/benchmark.R | 462 +++++++++++++------------- tests/testthat/test-convertPedigree.R | 4 +- tests/testthat/test-makeLinks.R | 16 +- tests/testthat/test-plotPedigree.R | 6 +- tests/testthat/test-readPedigrees.R | 1 - tests/testthat/test-readWikiTree.R | 1 - vignettes/ASOIAF.Rmd | 2 - vignettes/partial.Rmd | 104 +++--- vignettes/partial.html | 104 +++--- 17 files changed, 829 insertions(+), 775 deletions(-) diff --git a/R/checkParents.R b/R/checkParents.R index 7d142af1..43c8a924 100644 --- a/R/checkParents.R +++ b/R/checkParents.R @@ -145,7 +145,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, # Are any parents in both momID and dadID? momdad <- intersect(ped$dadID, ped$momID) - if (length(momdad) > 0&& !is.na(momdad)) { + if (length(momdad) > 0 && !is.na(momdad)) { validation_results$parents_in_both <- momdad if (verbose) { cat(paste( @@ -185,7 +185,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, - if (length(validation_results$female_var) > 0 && !is.na(validation_results$female_var)){ + if (length(validation_results$female_var) > 0 && !is.na(validation_results$female_var)) { corrected_moms <- ped$ID[mom_indices[!is.na(mom_indices)]] ped$sex[mom_indices[!is.na(mom_indices)]] <- validation_results$female_var changes$corrected_mom_sex <- corrected_moms @@ -200,9 +200,8 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, if (verbose && length(corrected_moms) > 0) { cat("Corrected sex of moms for:", paste(corrected_moms, collapse = ", "), "\n") } - } - if (length(validation_results$male_var) > 0 && !is.na(validation_results$male_var)){ + if (length(validation_results$male_var) > 0 && !is.na(validation_results$male_var)) { corrected_dads <- ped$ID[dad_indices[!is.na(dad_indices)]] ped$sex[dad_indices[!is.na(dad_indices)]] <- validation_results$male_var changes$corrected_dad_sex <- corrected_dads @@ -216,7 +215,6 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, if (verbose && length(corrected_dads) > 0) { cat("Corrected sex of dads for:", paste(corrected_dads, collapse = ", "), "\n") } - } } } @@ -235,7 +233,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, new_entry$ID <- new_id new_entry$dadID <- NA new_entry$momID <- NA - new_entry$sex <- if(length(validation_results$male_var) > 0 && !is.na(validation_results$male_var)) validation_results$male_var else 1 + new_entry$sex <- if (length(validation_results$male_var) > 0 && !is.na(validation_results$male_var)) validation_results$male_var else 1 new_entries <- rbind(new_entries, new_entry) } @@ -248,7 +246,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, new_entry$ID <- new_id new_entry$dadID <- NA new_entry$momID <- NA - new_entry$sex <- if(length(validation_results$female_var) > 0 && !is.na(validation_results$female_var)) validation_results$female_var else 0 + new_entry$sex <- if (length(validation_results$female_var) > 0 && !is.na(validation_results$female_var)) validation_results$female_var else 0 new_entries <- rbind(new_entries, new_entry) } diff --git a/R/convertPedigree.R b/R/convertPedigree.R index ae76cab0..86e9970a 100644 --- a/R/convertPedigree.R +++ b/R/convertPedigree.R @@ -41,7 +41,7 @@ ped2com <- function(ped, component, save_rate_parlist = 100000 * save_rate, update_rate = 100, save_path = "checkpoint/", - adjBeta_method=NULL, + adjBeta_method = NULL, ...) { #------ # Checkpointing @@ -447,7 +447,7 @@ ped2cn <- function(ped, max.gen = 25, sparse = TRUE, verbose = FALSE, save_rate_gen = save_rate_gen, save_rate_parlist = save_rate_parlist, save_path = save_path, - ... + ... ) } #' Take a pedigree and turn it into an extended environmental relatedness matrix @@ -603,7 +603,7 @@ ped2ce <- function(ped, .adjDirect <- function(ped, component, saveable, resume, save_path, verbose, lastComputed, nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist,adjBeta_method, + parList, lens, save_rate_parlist, adjBeta_method, ...) { # Loop through each individual in the pedigree # Build the adjacency matrix for parent-child relationships @@ -619,7 +619,7 @@ ped2ce <- function(ped, iss <- c(mIDs$rID, dIDs$rID) jss <- c(mIDs$cID, dIDs$cID) } else if (component %in% c("common nuclear")) { - # message("Common Nuclear component is not yet implemented for direct method. Using index method.\n") + # message("Common Nuclear component is not yet implemented for direct method. Using index method.\n") # 1) Create a logical mask for only known parents mask <- !is.na(ped$momID) & !is.na(ped$dadID) @@ -637,7 +637,7 @@ ped2ce <- function(ped, # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j iss_list <- vector("list", length(groupList)) jss_list <- vector("list", length(groupList)) - counter <- 1 + counter <- 1 for (g in groupList) { k <- length(g) @@ -647,10 +647,10 @@ ped2ce <- function(ped, # v = each child repeated k times # w = entire group repeated once for each child - v <- rep(g, each = k) # row index - w <- rep(g, times = k) # col index + v <- rep(g, each = k) # row index + w <- rep(g, times = k) # col index - keep <- (v != w) # remove diagonal where v == w + keep <- (v != w) # remove diagonal where v == w iss_list[[counter]] <- v[keep] jss_list[[counter]] <- w[keep] counter <- counter + 1 @@ -658,21 +658,21 @@ ped2ce <- function(ped, } - iss <- unlist(iss_list, use.names = FALSE) - jss <- unlist(jss_list, use.names = FALSE) + iss <- unlist(iss_list, use.names = FALSE) + jss <- unlist(jss_list, use.names = FALSE) - # list_of_adjacency <- .adjBeta(ped=ped,adjBeta_method=adjBeta_method, -# component = component, - # saveable = saveable, resume = resume, - # save_path = save_path, verbose = verbose, - # lastComputed = lastComputed, nr = nr, - # checkpoint_files = checkpoint_files, - # update_rate = update_rate, - # parList = parList, - # lens = lens, save_rate_parlist = save_rate_parlist, - # ...) + # list_of_adjacency <- .adjBeta(ped=ped,adjBeta_method=adjBeta_method, + # component = component, + # saveable = saveable, resume = resume, + # save_path = save_path, verbose = verbose, + # lastComputed = lastComputed, nr = nr, + # checkpoint_files = checkpoint_files, + # update_rate = update_rate, + # parList = parList, + # lens = lens, save_rate_parlist = save_rate_parlist, + # ...) - # return(list_of_adjacency) + # return(list_of_adjacency) } else if (component %in% c("mitochondrial")) { mIDs <- stats::na.omit(data.frame(rID = ped$ID, cID = ped$momID)) iss <- c(mIDs$rID) @@ -699,9 +699,9 @@ ped2ce <- function(ped, compute_parent_adjacency <- function(ped, component, adjacency_method = "direct", saveable, resume, - save_path, verbose=FALSE, - lastComputed=0, nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist,adjBeta_method=NULL, + save_path, verbose = FALSE, + lastComputed = 0, nr, checkpoint_files, update_rate, + parList, lens, save_rate_parlist, adjBeta_method = NULL, ...) { if (adjacency_method == "loop") { if (lastComputed < nr) { # Original version @@ -761,21 +761,23 @@ compute_parent_adjacency <- function(ped, component, ) } } else if (adjacency_method == "beta") { - list_of_adjacency <- .adjBeta(ped = ped, - adjBeta_method = adjBeta_method, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ...) + list_of_adjacency <- .adjBeta( + ped = ped, + adjBeta_method = adjBeta_method, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) } else { stop("Invalid method specified. Choose from 'loop', 'direct', 'indexed', or beta") } @@ -809,22 +811,21 @@ isChild <- function(isChild_method, ped) { } -.adjBeta <- function(ped,component, - adjBeta_method=5, - parList=NULL, - lastComputed=0, - nr=NULL, - lens=NULL, - saveable=FALSE, - resume=FALSE, - save_path=NULL, - verbose=FALSE, - save_rate_parlist=NULL, - update_rate=NULL, - checkpoint_files=NULL, - ...){# 1) Pairwise compare mother IDs - if(adjBeta_method == 1){ - +.adjBeta <- function(ped, component, + adjBeta_method = 5, + parList = NULL, + lastComputed = 0, + nr = NULL, + lens = NULL, + saveable = FALSE, + resume = FALSE, + save_path = NULL, + verbose = FALSE, + save_rate_parlist = NULL, + update_rate = NULL, + checkpoint_files = NULL, + ...) { # 1) Pairwise compare mother IDs + if (adjBeta_method == 1) { # gets slow when data are bigger. much slower than indexed momMatch <- outer(ped$momID, ped$momID, FUN = "==") momMatch[is.na(momMatch)] <- FALSE @@ -837,15 +838,15 @@ isChild <- function(isChild_method, ped) { adj <- momMatch & dadMatch # 4) Extract indices where adj[i,j] is TRUE - w <- which(adj, arr.ind = TRUE) - # iss <- w[, 1] - # jss <- w[, 2] -# + w <- which(adj, arr.ind = TRUE) + # iss <- w[, 1] + # jss <- w[, 2] + # list_of_adjacency <- list( iss = w[, 1], jss = w[, 2] ) - } else if(adjBeta_method == 2){ + } else if (adjBeta_method == 2) { # 1) Create a logical mask for known parents mask <- !is.na(ped$momID) & !is.na(ped$dadID) @@ -857,7 +858,7 @@ isChild <- function(isChild_method, ped) { pairCode <- match(pairLabel, unique(pairLabel)) # childVec are the row indices in 'ped' that have known parents - childVec <- which(mask) # length(childVec) = sum(mask) + childVec <- which(mask) # length(childVec) = sum(mask) # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" groupList <- split(childVec, pairCode) @@ -865,27 +866,27 @@ isChild <- function(isChild_method, ped) { # 5) For each group with >1 children, form pairwise adjacency i->j iss_list <- list() jss_list <- list() - counter <- 1 + counter <- 1 for (g in groupList) { if (length(g) > 1) { combos <- expand.grid(g, g, KEEP.OUT.ATTRS = FALSE) - combos <- combos[combos[,1] != combos[,2], , drop = FALSE] - iss_list[[counter]] <- combos[,1] - jss_list[[counter]] <- combos[,2] + combos <- combos[combos[, 1] != combos[, 2], , drop = FALSE] + iss_list[[counter]] <- combos[, 1] + jss_list[[counter]] <- combos[, 2] counter <- counter + 1 } } - # iss <- unlist(iss_list, use.names = FALSE) - # jss <- unlist(jss_list, use.names = FALSE) + # iss <- unlist(iss_list, use.names = FALSE) + # jss <- unlist(jss_list, use.names = FALSE) list_of_adjacency <- list( iss = unlist(iss_list, use.names = FALSE), jss = unlist(jss_list, use.names = FALSE) ) - } else if(adjBeta_method == 3){ + } else if (adjBeta_method == 3) { nr <- nrow(ped) -# terrible + # terrible # Define a scalar-checking function: f_check <- function(i, j) { # i, j are each single integers @@ -903,105 +904,102 @@ isChild <- function(isChild_method, ped) { adj <- outer(seq_len(nr), seq_len(nr), FUN = vf_check) # Extract which cells of adj are TRUE - w <- which(adj, arr.ind = TRUE) - # iss <- w[, 1] - # jss <- w[, 2] + w <- which(adj, arr.ind = TRUE) + # iss <- w[, 1] + # jss <- w[, 2] list_of_adjacency <- list( iss = iss <- w[, 1], jss = jss <- w[, 2] ) -}else if(adjBeta_method == 4){ - - # 1) Create a logical mask for known parents - mask <- !is.na(ped$momID) & !is.na(ped$dadID) + } else if (adjBeta_method == 4) { + # 1) Create a logical mask for known parents + mask <- !is.na(ped$momID) & !is.na(ped$dadID) - # 2) Create a single string label for each known (momID, dadID) pair - pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) + # 2) Create a single string label for each known (momID, dadID) pair + pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) - # 3) Factor that label => each row with the same (mom,dad) gets the same integer code - pairCode <- match(pairLabel, unique(pairLabel)) + # 3) Factor that label => each row with the same (mom,dad) gets the same integer code + pairCode <- match(pairLabel, unique(pairLabel)) - # childVec are the row indices in 'ped' that have known parents - childVec <- which(mask) + # childVec are the row indices in 'ped' that have known parents + childVec <- which(mask) - # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" - groupList <- split(childVec, pairCode) + # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" + groupList <- split(childVec, pairCode) - # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j - iss_list <- vector("list", length(groupList)) - jss_list <- vector("list", length(groupList)) - counter <- 1 + # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j + iss_list <- vector("list", length(groupList)) + jss_list <- vector("list", length(groupList)) + counter <- 1 - for (g in groupList) { - k <- length(g) - if (k > 1) { - # We'll form all k^2 combos, then remove the diagonal i=j - # Instead of expand.grid, do rep() calls: + for (g in groupList) { + k <- length(g) + if (k > 1) { + # We'll form all k^2 combos, then remove the diagonal i=j + # Instead of expand.grid, do rep() calls: - # v = each child repeated k times - # w = entire group repeated once for each child - v <- rep(g, each = k) # row index - w <- rep(g, times = k) # col index + # v = each child repeated k times + # w = entire group repeated once for each child + v <- rep(g, each = k) # row index + w <- rep(g, times = k) # col index - keep <- (v != w) # remove diagonal where v == w - iss_list[[counter]] <- v[keep] - jss_list[[counter]] <- w[keep] - counter <- counter + 1 + keep <- (v != w) # remove diagonal where v == w + iss_list[[counter]] <- v[keep] + jss_list[[counter]] <- w[keep] + counter <- counter + 1 + } } - } - list_of_adjacency <- list( - iss = unlist(iss_list, use.names = FALSE), - jss = unlist(jss_list, use.names = FALSE) - ) - - } else if(adjBeta_method == 5){ + list_of_adjacency <- list( + iss = unlist(iss_list, use.names = FALSE), + jss = unlist(jss_list, use.names = FALSE) + ) + } else if (adjBeta_method == 5) { # 1) Create a logical mask for known parents mask <- !is.na(ped$momID) & !is.na(ped$dadID) - # 2) Create a single hash label for each known (momID, dadID) pair - #pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) - base <- max(ped$ID, na.rm = TRUE) + 1L - pairCode <- ped$momID[mask] + base * ped$dadID[mask] - - # 3) Factor that label => each row with the same (mom,dad) gets the same integer code - childVec <- which(mask) - - # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" - groupList <- split(childVec, pairCode) - - # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j - iss_list <- vector("list", length(groupList)) - jss_list <- vector("list", length(groupList)) - counter <- 1 - - for (g in groupList) { - k <- length(g) - if (k > 1) { - # We'll form all k^2 combos, then remove the diagonal i=j - # Instead of expand.grid, do rep() calls: - - # v = each child repeated k times - # w = entire group repeated once for each child - v <- rep(g, each = k) # row index - w <- rep(g, times = k) # col index - - keep <- (v != w) # remove diagonal where v == w - iss_list[[counter]] <- v[keep] - jss_list[[counter]] <- w[keep] - counter <- counter + 1 - } - } + # 2) Create a single hash label for each known (momID, dadID) pair + # pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) + base <- max(ped$ID, na.rm = TRUE) + 1L + pairCode <- ped$momID[mask] + base * ped$dadID[mask] - list_of_adjacency <- list( - iss = unlist(iss_list, use.names = FALSE), - jss = unlist(jss_list, use.names = FALSE) - ) + # 3) Factor that label => each row with the same (mom,dad) gets the same integer code + childVec <- which(mask) + + # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" + groupList <- split(childVec, pairCode) + + # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j + iss_list <- vector("list", length(groupList)) + jss_list <- vector("list", length(groupList)) + counter <- 1 - }else{ + for (g in groupList) { + k <- length(g) + if (k > 1) { + # We'll form all k^2 combos, then remove the diagonal i=j + # Instead of expand.grid, do rep() calls: - list_of_adjacency <- .adjIndexed(ped = ped, component = component, + # v = each child repeated k times + # w = entire group repeated once for each child + v <- rep(g, each = k) # row index + w <- rep(g, times = k) # col index + + keep <- (v != w) # remove diagonal where v == w + iss_list[[counter]] <- v[keep] + jss_list[[counter]] <- w[keep] + counter <- counter + 1 + } + } + + list_of_adjacency <- list( + iss = unlist(iss_list, use.names = FALSE), + jss = unlist(jss_list, use.names = FALSE) + ) + } else { + list_of_adjacency <- .adjIndexed( + ped = ped, component = component, saveable = saveable, resume = resume, save_path = save_path, verbose = verbose, lastComputed = lastComputed, nr = nr, @@ -1009,7 +1007,6 @@ isChild <- function(isChild_method, ped) { update_rate = update_rate, parList = parList, lens = lens, save_rate_parlist = save_rate_parlist ) - } return(list_of_adjacency) } diff --git a/R/makeLinks.R b/R/makeLinks.R index 46e7d743..37c44274 100644 --- a/R/makeLinks.R +++ b/R/makeLinks.R @@ -40,7 +40,7 @@ com2links <- function( legacy = FALSE, outcome_name = "data", drop_upper_triangular = TRUE, - include_all_links_1ped=FALSE, + include_all_links_1ped = FALSE, ...) { # --- Input Validations and Preprocessing --- @@ -108,118 +108,118 @@ com2links <- function( } switch(matrix_case, - "ad" = process_one( - matrix = ad_ped_matrix, - rel_name = "addRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - include_all_links = include_all_links_1ped, - ... - ), - "mt" = process_one( - matrix = mit_ped_matrix, - rel_name = "mitRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - include_all_links = include_all_links_1ped, - ... - ), - "cn" = process_one( - matrix = cn_ped_matrix, - rel_name = "cnuRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - include_all_links = include_all_links_1ped, - ... - ), - "ad-mt" = process_two( - matrix1 = ad_ped_matrix, - name1 = "addRel", - matrix2 = mit_ped_matrix, - name2 = "mitRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "ad-cn" = process_two( - matrix1 = ad_ped_matrix, - name1 = "addRel", - matrix2 = cn_ped_matrix, - name2 = "cnuRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "cn-mt" = process_two( - matrix1 = cn_ped_matrix, - name1 = "cnuRel", - matrix2 = mit_ped_matrix, - name2 = "mitRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - "ad-cn-mt" = process_all_three( - mat1 = ad_ped_matrix, - name1 = "addRel", - mat2 = mit_ped_matrix, - name2 = "mitRel", - mat3 = cn_ped_matrix, - name3 = "cnuRel", - ids = ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc, - ... - ), - stop("Unsupported matrix combination") + "ad" = process_one( + matrix = ad_ped_matrix, + rel_name = "addRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + include_all_links = include_all_links_1ped, + ... + ), + "mt" = process_one( + matrix = mit_ped_matrix, + rel_name = "mitRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + include_all_links = include_all_links_1ped, + ... + ), + "cn" = process_one( + matrix = cn_ped_matrix, + rel_name = "cnuRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + include_all_links = include_all_links_1ped, + ... + ), + "ad-mt" = process_two( + matrix1 = ad_ped_matrix, + name1 = "addRel", + matrix2 = mit_ped_matrix, + name2 = "mitRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "ad-cn" = process_two( + matrix1 = ad_ped_matrix, + name1 = "addRel", + matrix2 = cn_ped_matrix, + name2 = "cnuRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "cn-mt" = process_two( + matrix1 = cn_ped_matrix, + name1 = "cnuRel", + matrix2 = mit_ped_matrix, + name2 = "mitRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + "ad-cn-mt" = process_all_three( + mat1 = ad_ped_matrix, + name1 = "addRel", + mat2 = mit_ped_matrix, + name2 = "mitRel", + mat3 = cn_ped_matrix, + name3 = "cnuRel", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc, + ... + ), + stop("Unsupported matrix combination") ) } #' Convert Sparse Relationship Matrices to Kinship Links for one Matrix @@ -231,112 +231,111 @@ com2links <- function( process_one <- function(matrix, rel_name, ids, nc, rel_pairs_file, writetodisk, write_buffer_size, drop_upper_triangular, update_rate, verbose, gc, - include_all_links=TRUE, ...) { + include_all_links = TRUE, ...) { if (include_all_links == FALSE) { - # Extract pointers and indices from the matrix. - newColPos <- matrix@p + 1L - iss <- matrix@i + 1L - x <- matrix@x - - # Initialize the related pairs file with headers. - df_relpairs <- initialize_empty_df(relNames = rel_name) - - if (writetodisk == TRUE) { - utils::write.table( - df_relpairs, - file = rel_pairs_file, sep = ",", append = FALSE, row.names = FALSE - ) - - # Prepare an empty buffer for batching writes. - write_buffer <- list() - remove(df_relpairs) - } + # Extract pointers and indices from the matrix. + newColPos <- matrix@p + 1L + iss <- matrix@i + 1L + x <- matrix@x + + # Initialize the related pairs file with headers. + df_relpairs <- initialize_empty_df(relNames = rel_name) + + if (writetodisk == TRUE) { + utils::write.table( + df_relpairs, + file = rel_pairs_file, sep = ",", append = FALSE, row.names = FALSE + ) - # Process each column in the matrix. - for (j in 1L:nc) { + # Prepare an empty buffer for batching writes. + write_buffer <- list() + remove(df_relpairs) + } + # Process each column in the matrix. + for (j in 1L:nc) { ID2 <- ids[j] - # Extract column indices - ncp <- newColPos[j] - ncpp <- newColPos[j + 1L] - cond <- ncp < ncpp - if (cond) { - vv <- ncp:(ncpp - 1L) - issvv <- iss[vv] - } + # Extract column indices + ncp <- newColPos[j] + ncpp <- newColPos[j + 1L] + cond <- ncp < ncpp + if (cond) { + vv <- ncp:(ncpp - 1L) + issvv <- iss[vv] + } - # Create a unique set of row indices. - u <- sort(issvv) + # Create a unique set of row indices. + u <- sort(issvv) - # If any relationships exist for this individual, build the related pairs. - if (cond) { + # If any relationships exist for this individual, build the related pairs. + if (cond) { # Create a data frame with unique pairs. ID1 <- ids[u] tds <- data.frame(ID1 = ID1, ID2 = ID2) tds[[rel_name]] <- 0 - if (cond) { - tds[u %in% issvv, rel_name] <- x[vv] - } - if (drop_upper_triangular == TRUE) { - tds <- tds[tds$ID1 <= tds$ID2, ] # or < if you want strictly lower triangle - } - - # Write the batch to disk or accumulate in the data frame. - if (nrow(tds) > 0) { - if (writetodisk == TRUE) { - write_buffer[[length(write_buffer) + 1]] <- tds + if (cond) { + tds[u %in% issvv, rel_name] <- x[vv] + } + if (drop_upper_triangular == TRUE) { + tds <- tds[tds$ID1 <= tds$ID2, ] # or < if you want strictly lower triangle + } - if (length(write_buffer) >= write_buffer_size) { # Write in batches - utils::write.table(do.call(rbind, write_buffer), - file = rel_pairs_file, - row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," - ) - write_buffer <- list() + # Write the batch to disk or accumulate in the data frame. + if (nrow(tds) > 0) { + if (writetodisk == TRUE) { + write_buffer[[length(write_buffer) + 1]] <- tds + + if (length(write_buffer) >= write_buffer_size) { # Write in batches + utils::write.table(do.call(rbind, write_buffer), + file = rel_pairs_file, + row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," + ) + write_buffer <- list() + } + } else { + df_relpairs <- rbind(df_relpairs, tds) } - } else { - df_relpairs <- rbind(df_relpairs, tds) } } + if (verbose && (j %% update_rate == 0L)) { + cat("Done with", j, "of", nc, "\n") + } } - if (verbose && (j %% update_rate == 0L)) { - cat("Done with", j, "of", nc, "\n") + # If not writing to disk, return the accumulated data frame. + if (writetodisk == FALSE) { + return(df_relpairs) + } else { + # Write any remaining buffered rows. + if (length(write_buffer) > 0) { + utils::write.table(do.call(rbind, write_buffer), + file = rel_pairs_file, + row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," + ) + } } - } - # If not writing to disk, return the accumulated data frame. - if (writetodisk == FALSE) { - return(df_relpairs) - } else { - # Write any remaining buffered rows. - if (length(write_buffer) > 0) { - utils::write.table(do.call(rbind, write_buffer), - file = rel_pairs_file, - row.names = FALSE, col.names = FALSE, append = TRUE, sep = "," - ) + if (gc == TRUE) { + remove(newColPos, iss, x) } - } - if (gc == TRUE) { - remove(newColPos, iss, x) - } - }else{ - matrix2= matrix(rep(1,length(ids)^2), - nrow = length(ids), - dimnames = list(ids, ids)) - process_two(matrix2=matrix, name2=rel_name, - matrix1=methods::as(matrix2,"CsparseMatrix"), - name1="phantom", - ids=ids, - nc = nc, - rel_pairs_file = rel_pairs_file, - writetodisk = writetodisk, - write_buffer_size = write_buffer_size, - drop_upper_triangular = drop_upper_triangular, - update_rate = update_rate, - verbose = verbose, - gc = gc) - - - + } else { + matrix2 <- matrix(rep(1, length(ids)^2), + nrow = length(ids), + dimnames = list(ids, ids) + ) + process_two( + matrix2 = matrix, name2 = rel_name, + matrix1 = methods::as(matrix2, "CsparseMatrix"), + name1 = "phantom", + ids = ids, + nc = nc, + rel_pairs_file = rel_pairs_file, + writetodisk = writetodisk, + write_buffer_size = write_buffer_size, + drop_upper_triangular = drop_upper_triangular, + update_rate = update_rate, + verbose = verbose, + gc = gc + ) } } @@ -553,8 +552,10 @@ process_two <- function( #' #' @return The validated and converted matrix. validate_and_convert_matrix <- function(mat, name, ensure_symmetric = FALSE, force_binary = FALSE) { - if (!inherits(mat, c("matrix", "dgCMatrix", "dsCMatrix","generalMatrix", - "symmetricMatrix", "triangularMatrix", "dsyMatrix", "dspMatrix", "dsyMatrix",'CsparseMatrix'))) { + if (!inherits(mat, c( + "matrix", "dgCMatrix", "dsCMatrix", "generalMatrix", + "symmetricMatrix", "triangularMatrix", "dsyMatrix", "dspMatrix", "dsyMatrix", "CsparseMatrix" + ))) { stop(paste0("The '", name, "' must be a matrix or generalMatrix")) } if (!inherits(mat, "generalMatrix")) { diff --git a/R/makeLinkslegacy.R b/R/makeLinkslegacy.R index 27a6e45a..23265d05 100644 --- a/R/makeLinkslegacy.R +++ b/R/makeLinkslegacy.R @@ -628,4 +628,3 @@ com2links.og <- function( } return(NULL) } - diff --git a/R/readGedcom.R b/R/readGedcom.R index 29462ad2..7181fac4 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -57,7 +57,6 @@ readGedcom <- function(file_path, update_rate = 1000, post_process = TRUE, ...) { - # Ensure the file exists and read all lines. if (!file.exists(file_path)) { stop("File does not exist: ", file_path) @@ -73,15 +72,19 @@ readGedcom <- function(file_path, # List of variables to initialize all_var_names <- unlist(list( identifiers = c("id", "momID", "dadID"), - names = c("name", "name_given", "name_given_pieces", "name_surn", "name_surn_pieces", "name_marriedsurn", - "name_nick", "name_npfx", "name_nsfx"), - sex = c("sex"), - birth = c("birth_date", "birth_lat", "birth_long", "birth_place"), - death = c("death_caus", "death_date", "death_lat", "death_long", "death_place"), - attributes = c("attribute_caste", "attribute_children", "attribute_description", "attribute_education", - "attribute_idnumber", "attribute_marriages", "attribute_nationality", "attribute_occupation", - "attribute_property", "attribute_religion", "attribute_residence", "attribute_ssn", - "attribute_title"), + names = c( + "name", "name_given", "name_given_pieces", "name_surn", "name_surn_pieces", "name_marriedsurn", + "name_nick", "name_npfx", "name_nsfx" + ), + sex = c("sex"), + birth = c("birth_date", "birth_lat", "birth_long", "birth_place"), + death = c("death_caus", "death_date", "death_lat", "death_long", "death_place"), + attributes = c( + "attribute_caste", "attribute_children", "attribute_description", "attribute_education", + "attribute_idnumber", "attribute_marriages", "attribute_nationality", "attribute_occupation", + "attribute_property", "attribute_religion", "attribute_residence", "attribute_ssn", + "attribute_title" + ), relationships = c("FAMC", "FAMS") ), use.names = FALSE) @@ -90,8 +93,9 @@ readGedcom <- function(file_path, # Parse each individual block into a record (a named list) records <- lapply(blocks, parseIndividualBlock, - pattern_rows = pattern_rows, - all_var_names = all_var_names, verbose = verbose) + pattern_rows = pattern_rows, + all_var_names = all_var_names, verbose = verbose + ) # Remove any NULLs (if a block did not contain an individual id) records <- Filter(Negate(is.null), records) @@ -135,7 +139,9 @@ readGedcom <- function(file_path, #' @return A list of character vectors, each representing one individual. splitIndividuals <- function(lines, verbose = FALSE) { indi_idx <- grep("@ INDI", lines) - if (length(indi_idx) == 0) return(list()) + if (length(indi_idx) == 0) { + return(list()) + } blocks <- list() for (i in seq_along(indi_idx)) { @@ -194,7 +200,7 @@ parseIndividualBlock <- function(block, pattern_rows, all_var_names, verbose = F # Process birth and death events by consuming multiple lines. if (grepl(" BIRT", line) && pattern_rows$num_birt_rows > 0) { record <- processEventLine("birth", block, i, record, pattern_rows) - i <- i + 1 # Skip further processing of this line. + i <- i + 1 # Skip further processing of this line. next } if (grepl(" DEAT", line) && pattern_rows$num_deat_rows > 0) { @@ -214,50 +220,62 @@ parseIndividualBlock <- function(block, pattern_rows, all_var_names, verbose = F list(tag = "_MARNM", field = "name_marriedsurn", mode = "replace") ) out <- applyTagMappings(line, record, pattern_rows, name_piece_mappings) - if (out$matched) { record <- out$record - i <- i + 1 - next } + if (out$matched) { + record <- out$record + i <- i + 1 + next + } # Process attribute tags. attribute_mappings <- list( - list(tag = "SEX", field = "sex", mode = "replace"), + list(tag = "SEX", field = "sex", mode = "replace"), list(tag = "CAST", field = "attribute_caste", mode = "replace"), list(tag = "DSCR", field = "attribute_description", mode = "replace"), list(tag = "EDUC", field = "attribute_education", mode = "replace"), list(tag = "IDNO", field = "attribute_idnumber", mode = "replace"), list(tag = "NATI", field = "attribute_nationality", mode = "replace"), list(tag = "NCHI", field = "attribute_children", mode = "replace"), - list(tag = "NMR", field = "attribute_marriages", mode = "replace"), + list(tag = "NMR", field = "attribute_marriages", mode = "replace"), list(tag = "OCCU", field = "attribute_occupation", mode = "replace"), list(tag = "PROP", field = "attribute_property", mode = "replace"), list(tag = "RELI", field = "attribute_religion", mode = "replace"), list(tag = "RESI", field = "attribute_residence", mode = "replace"), - list(tag = "SSN", field = "attribute_ssn", mode = "replace"), + list(tag = "SSN", field = "attribute_ssn", mode = "replace"), list(tag = "TITL", field = "attribute_title", mode = "replace") ) out <- applyTagMappings(line, record, pattern_rows, attribute_mappings) - if (out$matched) { record <- out$record - i <- i + 1 - next } + if (out$matched) { + record <- out$record + i <- i + 1 + next + } # Process relationship tags, using a custom extractor. relationship_mappings <- list( - list(tag = "FAMC", field = "FAMC", mode = "append", - extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)")), - list(tag = "FAMS", field = "FAMS", mode = "append", - extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)")) + list( + tag = "FAMC", field = "FAMC", mode = "append", + extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)") + ), + list( + tag = "FAMS", field = "FAMS", mode = "append", + extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)") + ) ) out <- applyTagMappings(line, record, pattern_rows, relationship_mappings) - if (out$matched) { record <- out$record - i <- i + 1 - next } + if (out$matched) { + record <- out$record + i <- i + 1 + next + } # Optionally print progress for long records. i <- i + 1 } # If the record has no ID, return NULL. - if (is.na(record$id)) return(NULL) + if (is.na(record$id)) { + return(NULL) + } return(record) } @@ -291,16 +309,16 @@ parseNameLine <- function(line, record) { processEventLine <- function(event, block, i, record, pattern_rows) { n_lines <- length(block) if (event == "birth") { - if (i + 1 <= n_lines) record$birth_date <- extract_info(block[i+1], "DATE") - if (i + 2 <= n_lines) record$birth_place <- extract_info(block[i+2], "PLAC") - if (i + 4 <= n_lines) record$birth_lat <- extract_info(block[i+4], "LATI") - if (i + 5 <= n_lines) record$birth_long <- extract_info(block[i+5], "LONG") + if (i + 1 <= n_lines) record$birth_date <- extract_info(block[i + 1], "DATE") + if (i + 2 <= n_lines) record$birth_place <- extract_info(block[i + 2], "PLAC") + if (i + 4 <= n_lines) record$birth_lat <- extract_info(block[i + 4], "LATI") + if (i + 5 <= n_lines) record$birth_long <- extract_info(block[i + 5], "LONG") } else if (event == "death") { - if (i + 1 <= n_lines) record$death_date <- extract_info(block[i+1], "DATE") - if (i + 2 <= n_lines) record$death_place <- extract_info(block[i+2], "PLAC") - if (i + 3 <= n_lines) record$death_caus <- extract_info(block[i+3], "CAUS") - if (i + 4 <= n_lines) record$death_lat <- extract_info(block[i+4], "LATI") - if (i + 5 <= n_lines) record$death_long <- extract_info(block[i+5], "LONG") + if (i + 1 <= n_lines) record$death_date <- extract_info(block[i + 1], "DATE") + if (i + 2 <= n_lines) record$death_place <- extract_info(block[i + 2], "PLAC") + if (i + 3 <= n_lines) record$death_caus <- extract_info(block[i + 3], "CAUS") + if (i + 4 <= n_lines) record$death_lat <- extract_info(block[i + 4], "LATI") + if (i + 5 <= n_lines) record$death_long <- extract_info(block[i + 5], "LONG") } return(record) } @@ -322,7 +340,8 @@ applyTagMappings <- function(line, record, pattern_rows, tag_mappings) { for (mapping in tag_mappings) { extractor <- if (is.null(mapping$extractor)) NULL else mapping$extractor result <- process_tag(mapping$tag, mapping$field, pattern_rows, line, record, - extractor = extractor, mode = mapping$mode) + extractor = extractor, mode = mapping$mode + ) record <- result$vars if (result$matched) { return(list(record = record, matched = TRUE)) @@ -413,8 +432,8 @@ process_tag <- function(tag, field_name, pattern_rows, line, vars, count_name <- paste0("num_", tolower(tag), "_rows") matched <- FALSE if (!is.null(pattern_rows[[count_name]]) && - pattern_rows[[count_name]] > 0 && - grepl(paste0(" ", tag), line)) { + pattern_rows[[count_name]] > 0 && + grepl(paste0(" ", tag), line)) { value <- if (is.null(extractor)) { extract_info(line, tag) } else { diff --git a/R/readGedcomlegacy.R b/R/readGedcomlegacy.R index e7e04a82..8221197a 100644 --- a/R/readGedcomlegacy.R +++ b/R/readGedcomlegacy.R @@ -49,14 +49,14 @@ #' - `FAMS`: ID(s) of the family where the individual is a spouse #' @keywords internal readGedcom.legacy <- function(file_path, - verbose = FALSE, - add_parents = TRUE, - remove_empty_cols = TRUE, - combine_cols = TRUE, - skinny = FALSE, - update_rate = 1000, - post_process = TRUE, - ...) { + verbose = FALSE, + add_parents = TRUE, + remove_empty_cols = TRUE, + combine_cols = TRUE, + skinny = FALSE, + update_rate = 1000, + post_process = TRUE, + ...) { # Checks if (!file.exists(file_path)) stop("File does not exist: ", file_path) if (verbose) { @@ -302,12 +302,12 @@ readGedcom.legacy <- function(file_path, warning("The number of people found in the processed file does not match the number of individuals raw data") } - if(post_process){ + if (post_process) { if (verbose) { print("Post-processing data frame") } # Remove the first row (empty) -df_temp <- postProcessGedcom.legacy( + df_temp <- postProcessGedcom.legacy( df_temp = df_temp, remove_empty_cols = remove_empty_cols, combine_cols = combine_cols, @@ -315,7 +315,6 @@ df_temp <- postProcessGedcom.legacy( skinny = skinny, verbose = verbose ) - } return(df_temp) @@ -328,12 +327,11 @@ df_temp <- postProcessGedcom.legacy( #' @return A data frame with processed information. postProcessGedcom.legacy <- function(df_temp, - remove_empty_cols = TRUE, - combine_cols = TRUE, - add_parents = TRUE, - skinny = TRUE, - verbose = FALSE -){ + remove_empty_cols = TRUE, + combine_cols = TRUE, + add_parents = TRUE, + skinny = TRUE, + verbose = FALSE) { # Add mom and dad ids if (add_parents) { if (verbose) { @@ -342,28 +340,27 @@ postProcessGedcom.legacy <- function(df_temp, df_temp <- processParents.legacy(df_temp, datasource = "gedcom") } -if (combine_cols) { - df_temp <- collapseNames.legacy(verbose = verbose, df_temp = df_temp) -} + if (combine_cols) { + df_temp <- collapseNames.legacy(verbose = verbose, df_temp = df_temp) + } -if (remove_empty_cols) { - # Remove empty columns - if (verbose) { - print("Removing empty columns") + if (remove_empty_cols) { + # Remove empty columns + if (verbose) { + print("Removing empty columns") + } + df_temp <- df_temp[, colSums(is.na(df_temp)) < nrow(df_temp)] } - df_temp <- df_temp[, colSums(is.na(df_temp)) < nrow(df_temp)] -} -if (skinny) { - if (verbose) { - print("Slimming down the data frame") + if (skinny) { + if (verbose) { + print("Slimming down the data frame") + } + df_temp <- df_temp[, colSums(is.na(df_temp)) < nrow(df_temp)] + df_temp$FAMC <- NULL + df_temp$FAMS <- NULL } - df_temp <- df_temp[, colSums(is.na(df_temp)) < nrow(df_temp)] - df_temp$FAMC <- NULL - df_temp$FAMS <- NULL -} - -return(df_temp) + return(df_temp) } #' Create a mapping of family IDs to parent IDs @@ -570,7 +567,7 @@ countPatternRows.legacy <- function(file) { #' @keywords internal #' process_tag.legacy <- function(tag, field_name, pattern_rows, line, vars, - extractor = NULL, mode = "replace") { + extractor = NULL, mode = "replace") { count_name <- paste0("num_", tolower(tag), "_rows") matched <- FALSE if (!is.null(pattern_rows[[count_name]]) && @@ -622,4 +619,3 @@ collapseNames.legacy <- function(verbose, df_temp) { } return(df_temp) } - diff --git a/R/simulatePedigree.R b/R/simulatePedigree.R index 8fc88915..65f35ff8 100644 --- a/R/simulatePedigree.R +++ b/R/simulatePedigree.R @@ -191,11 +191,13 @@ buildBetweenGenerations <- function(df_Fam, Ngen, sizeGens, verbose, marR, sexR, SingleM <- sum(df_Ngen$sex == "M" & is.na(df_Ngen$spID)) CoupleM <- N_LinkedMale - SingleM - df_Fam[df_Fam$gen == i, ] <- markPotentialChildren(df_Ngen = df_Ngen, - i = i, - Ngen = Ngen, - sizeGens = sizeGens, - CoupleF = CoupleF) + df_Fam[df_Fam$gen == i, ] <- markPotentialChildren( + df_Ngen = df_Ngen, + i = i, + Ngen = Ngen, + sizeGens = sizeGens, + CoupleF = CoupleF + ) if (verbose) { print( "Step 2.2: mark a group of potential parents in the i-1 th generation" diff --git a/data-raw/benchged.R b/data-raw/benchged.R index c0d0eef9..18a9fc47 100644 --- a/data-raw/benchged.R +++ b/data-raw/benchged.R @@ -26,6 +26,6 @@ print(benchmark_results) # Optional: Save results to CSV for later analysis write.csv(summary(benchmark_results), - "benchmark_results.csv", - row.names = FALSE + "benchmark_results.csv", + row.names = FALSE ) diff --git a/data-raw/benchmark.R b/data-raw/benchmark.R index 4a615af2..2add0e4f 100644 --- a/data-raw/benchmark.R +++ b/data-raw/benchmark.R @@ -43,7 +43,8 @@ ped3 <- ped3 %>% momID = momID + max(ped3$ID, na.rm = TRUE), dadID = dadID + max(ped3$ID, na.rm = TRUE), spID = spID + max(ped3$ID, na.rm = TRUE) - ) %>% rbind(ped3) + ) %>% + rbind(ped3) set.seed(1151) kpc <- 2 @@ -62,243 +63,254 @@ ped <- rbind(ped, ped2) ped <- rbind(ped, ped3) ped <- rbind(ped, ped4) -if(TRUE){ -# Define parameters -component <- "common nuclear"#"additive" # Change this to test different components -saveable <- FALSE # Disable saving to avoid disk I/O slowing down benchmarking -resume <- FALSE # Disable resume to ensure full fresh runs -save_path <- "checkpoint/" -verbose <- FALSE # Turn off verbose for cleaner output -update_rate <- 100 -save_rate_parlist <- 1000 -#method_approach <- 1 -# Run benchmarking for "loop" and "indexed" methods in ped2com() -benchmark_results <- microbenchmark( -# loop_big = { -# ped2com( -# ped = ped, -# component = component, -# adjacency_method = "loop", # Test "loop" method -# saveable = saveable, -# resume = resume, -# save_path = save_path, -# verbose = verbose, -# update_rate = update_rate, -# save_rate_parlist = save_rate_parlist -# ) -# }, - indexed_big = { - ped2com( - ped = ped, - component = component, - adjacency_method = "indexed", # Test "indexed" method - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - update_rate = update_rate, - save_rate_parlist = save_rate_parlist - ) - }, - direct4_big = { - ped2com( - ped = ped, - component = component, - adjacency_method = "direct", # Test "indexed" method - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - update_rate = update_rate, - method_approach = 4, - save_rate_parlist = save_rate_parlist - ) - }, - direct2_big = { - ped2com( - ped = ped, - component = component, - adjacency_method = "direct", # Test "indexed" method - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - update_rate = update_rate, - method_approach = 2, - save_rate_parlist = save_rate_parlist - ) - }, - direct5_big = { - ped2com( - ped = ped, - component = component, - adjacency_method = "direct", # Test "indexed" method - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - update_rate = update_rate, - method_approach = 5, - save_rate_parlist = save_rate_parlist - ) - }, -# loop = { -# ped2com( -# ped = ped2, -# component = component, -# adjacency_method = "loop", # Test "loop" method -# saveable = saveable, -# resume = resume, -# save_path = save_path, -# verbose = verbose, -# update_rate = update_rate, -# save_rate_parlist = save_rate_parlist -# -# ) -# }, - indexed = { - ped2com( - ped = ped2, - component = component, - adjacency_method = "indexed", # Test "indexed" method - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - update_rate = update_rate, - save_rate_parlist = save_rate_parlist - ) - }, - direct4 = { - ped2com( - ped = ped2, - component = component, - adjacency_method = "direct", # Test "indexed" method - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - update_rate = update_rate, - method_approach = 4, - save_rate_parlist = save_rate_parlist - ) - }, - direct2 = { - ped2com( - ped = ped2, - component = component, - adjacency_method = "direct", # Test "indexed" method - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - update_rate = update_rate, - method_approach = 2, - save_rate_parlist = save_rate_parlist - ) - }, - direct5 = { - ped2com( - ped = ped2, - component = component, - adjacency_method = "direct", # Test "indexed" method - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - update_rate = update_rate, - method_approach = 5, - save_rate_parlist = save_rate_parlist - ) - }, - times = 10 # Run each method 100 times -) +if (TRUE) { + # Define parameters + component <- "common nuclear" # "additive" # Change this to test different components + saveable <- FALSE # Disable saving to avoid disk I/O slowing down benchmarking + resume <- FALSE # Disable resume to ensure full fresh runs + save_path <- "checkpoint/" + verbose <- FALSE # Turn off verbose for cleaner output + update_rate <- 100 + save_rate_parlist <- 1000 + # method_approach <- 1 + # Run benchmarking for "loop" and "indexed" methods in ped2com() + benchmark_results <- microbenchmark( + # loop_big = { + # ped2com( + # ped = ped, + # component = component, + # adjacency_method = "loop", # Test "loop" method + # saveable = saveable, + # resume = resume, + # save_path = save_path, + # verbose = verbose, + # update_rate = update_rate, + # save_rate_parlist = save_rate_parlist + # ) + # }, + indexed_big = { + ped2com( + ped = ped, + component = component, + adjacency_method = "indexed", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + save_rate_parlist = save_rate_parlist + ) + }, + direct4_big = { + ped2com( + ped = ped, + component = component, + adjacency_method = "direct", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + method_approach = 4, + save_rate_parlist = save_rate_parlist + ) + }, + direct2_big = { + ped2com( + ped = ped, + component = component, + adjacency_method = "direct", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + method_approach = 2, + save_rate_parlist = save_rate_parlist + ) + }, + direct5_big = { + ped2com( + ped = ped, + component = component, + adjacency_method = "direct", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + method_approach = 5, + save_rate_parlist = save_rate_parlist + ) + }, + # loop = { + # ped2com( + # ped = ped2, + # component = component, + # adjacency_method = "loop", # Test "loop" method + # saveable = saveable, + # resume = resume, + # save_path = save_path, + # verbose = verbose, + # update_rate = update_rate, + # save_rate_parlist = save_rate_parlist + # + # ) + # }, + indexed = { + ped2com( + ped = ped2, + component = component, + adjacency_method = "indexed", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + save_rate_parlist = save_rate_parlist + ) + }, + direct4 = { + ped2com( + ped = ped2, + component = component, + adjacency_method = "direct", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + method_approach = 4, + save_rate_parlist = save_rate_parlist + ) + }, + direct2 = { + ped2com( + ped = ped2, + component = component, + adjacency_method = "direct", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + method_approach = 2, + save_rate_parlist = save_rate_parlist + ) + }, + direct5 = { + ped2com( + ped = ped2, + component = component, + adjacency_method = "direct", # Test "indexed" method + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + update_rate = update_rate, + method_approach = 5, + save_rate_parlist = save_rate_parlist + ) + }, + times = 10 # Run each method 100 times + ) -summary(benchmark_results) + summary(benchmark_results) -df_plot <- benchmark_results %>% mutate(size = case_when(expr %in% c("loop", "indexed", "direct4", "direct2", "direct5") ~ "small", - expr %in% c("loop_big", "indexed_big", "direct4_big", "direct2_big", "direct5_big") ~ "big"), - method = case_when(expr %in% c("loop", "loop_big") ~ "loop", - expr %in% c("indexed", "indexed_big") ~ "indexed", - expr %in% c("direct4", "direct4_big") ~ "direct4", - expr %in% c("direct2", "direct2_big") ~ "direct2", - expr %in% c("direct5", "direct5_big") ~ "direct5"))# %>% + df_plot <- benchmark_results %>% mutate( + size = case_when( + expr %in% c("loop", "indexed", "direct4", "direct2", "direct5") ~ "small", + expr %in% c("loop_big", "indexed_big", "direct4_big", "direct2_big", "direct5_big") ~ "big" + ), + method = case_when( + expr %in% c("loop", "loop_big") ~ "loop", + expr %in% c("indexed", "indexed_big") ~ "indexed", + expr %in% c("direct4", "direct4_big") ~ "direct4", + expr %in% c("direct2", "direct2_big") ~ "direct2", + expr %in% c("direct5", "direct5_big") ~ "direct5" + ) + ) # %>% -# set indexed as reference level -df_plot$method <- factor(df_plot$method, levels = c("indexed", "loop","direct2", "direct4", "direct5")) -df_plot$size <- factor(df_plot$size, levels = c("small", "big")) + # set indexed as reference level + df_plot$method <- factor(df_plot$method, levels = c("indexed", "loop", "direct2", "direct4", "direct5")) + df_plot$size <- factor(df_plot$size, levels = c("small", "big")) -lm(time ~ method*size,data=df_plot) %>% - summary() %>% print() + 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 = "Benchmarking Results", - x = "Method", - y = "Time (seconds)") + - theme_minimal() + - theme(axis.text.x = element_text(angle = 45, hjust = 1)) -# Print benchmark results + p <- ggplot(df_plot, aes(x = method, y = time)) + + geom_boxplot(aes(fill = size), alpha = 0.5) + + labs( + title = "Benchmarking Results", + x = "Method", + y = "Time (seconds)" + ) + + theme_minimal() + + theme(axis.text.x = element_text(angle = 45, hjust = 1)) + # Print benchmark results -p -print(benchmark_results) + p + print(benchmark_results) -# Optional: Save results to CSV for later analysis -write.csv(summary(benchmark_results), - "benchmark_results.csv", - row.names = FALSE -) -# Print benchmark + # Optional: Save results to CSV for later analysis + write.csv(summary(benchmark_results), + "benchmark_results.csv", + row.names = FALSE + ) + # Print benchmark } -if(FALSE){ -verbose=FALSE -ad_ped_matrix <- ped2com(ped, component = "additive", adjacency_method = "direct", sparse = TRUE) -mit_ped_matrix <- ped2com(ped, component = "mitochondrial", adjacency_method = "direct", sparse = TRUE) -cn_ped_matrix <- ped2com(ped, component = "common nuclear", adjacency_method = "indexed", sparse = TRUE) -benchmark_results <- microbenchmark( - beta = { - com2links.beta( - ad_ped_matrix = ad_ped_matrix, - mit_ped_matrix = mit_ped_matrix, - cn_ped_matrix = cn_ped_matrix, - writetodisk = TRUE, - verbose = verbose -); file.remove("dataRelatedPairs.csv") - }, regular = { - com2links( - ad_ped_matrix = ad_ped_matrix, - mit_ped_matrix = mit_ped_matrix, - cn_ped_matrix = cn_ped_matrix, - writetodisk = TRUE, - verbose = verbose - ); file.remove("dataRelatedPairs.csv") - }, legacy = { - com2links( - ad_ped_matrix = ad_ped_matrix, - mit_ped_matrix = mit_ped_matrix, - cn_ped_matrix = cn_ped_matrix, - verbose = verbose, - legacy = TRUE - ); file.remove("dataRelatedPairs.csv") - }, - - times = 100 # Run each method 100 times -) +if (FALSE) { + verbose <- FALSE + ad_ped_matrix <- ped2com(ped, component = "additive", adjacency_method = "direct", sparse = TRUE) + mit_ped_matrix <- ped2com(ped, component = "mitochondrial", adjacency_method = "direct", sparse = TRUE) + cn_ped_matrix <- ped2com(ped, component = "common nuclear", adjacency_method = "indexed", sparse = TRUE) + benchmark_results <- microbenchmark( + beta = { + com2links.beta( + ad_ped_matrix = ad_ped_matrix, + mit_ped_matrix = mit_ped_matrix, + cn_ped_matrix = cn_ped_matrix, + writetodisk = TRUE, + verbose = verbose + ) + file.remove("dataRelatedPairs.csv") + }, regular = { + com2links( + ad_ped_matrix = ad_ped_matrix, + mit_ped_matrix = mit_ped_matrix, + cn_ped_matrix = cn_ped_matrix, + writetodisk = TRUE, + verbose = verbose + ) + file.remove("dataRelatedPairs.csv") + }, legacy = { + com2links( + ad_ped_matrix = ad_ped_matrix, + mit_ped_matrix = mit_ped_matrix, + cn_ped_matrix = cn_ped_matrix, + verbose = verbose, + legacy = TRUE + ) + file.remove("dataRelatedPairs.csv") + }, + times = 100 # Run each method 100 times + ) -summary(benchmark_results) + summary(benchmark_results) -lm(benchmark_results$time ~ benchmark_results$expr) %>% - summary() -# Print benchmark results -print(benchmark_results) + lm(benchmark_results$time ~ benchmark_results$expr) %>% + summary() + # Print benchmark results + print(benchmark_results) -# Optional: Save results to CSV for later analysis -write.csv(summary(benchmark_results), - "benchmark_results.csv", - row.names = FALSE -) + # Optional: Save results to CSV for later analysis + write.csv(summary(benchmark_results), + "benchmark_results.csv", + row.names = FALSE + ) } diff --git a/tests/testthat/test-convertPedigree.R b/tests/testthat/test-convertPedigree.R index a4b747e1..a011c334 100644 --- a/tests/testthat/test-convertPedigree.R +++ b/tests/testthat/test-convertPedigree.R @@ -304,8 +304,8 @@ test_that("adjacency_method 'indexed', 'loop', and direct produce the same resu ped_common_indexed <- ped2com(hazard, component = "common nuclear", adjacency_method = "indexed") ped_common_loop <- ped2com(hazard, component = "common nuclear", adjacency_method = "loop") ped_common_direct <- ped2com(hazard, component = "common nuclear", adjacency_method = "direct") - ped_common_adjBeta_1 <- ped2com(hazard, component = "common nuclear", adjacency_method = "beta",adjBeta_method = adjBeta_method_2) - ped_common_adjBeta_2 <- ped2com(hazard, component = "common nuclear", adjacency_method = "beta",adjBeta_method = adjBeta_method_3) + ped_common_adjBeta_1 <- ped2com(hazard, component = "common nuclear", adjacency_method = "beta", adjBeta_method = adjBeta_method_2) + ped_common_adjBeta_2 <- ped2com(hazard, component = "common nuclear", adjacency_method = "beta", adjBeta_method = adjBeta_method_3) expect_equal(ped_common_indexed, ped_common_loop, tolerance = tolerance) expect_equal(ped_common_loop, ped_common_direct, tolerance = tolerance) diff --git a/tests/testthat/test-makeLinks.R b/tests/testthat/test-makeLinks.R index e23b2390..05fc58fd 100644 --- a/tests/testthat/test-makeLinks.R +++ b/tests/testthat/test-makeLinks.R @@ -86,7 +86,7 @@ test_that("com2links processes creates same length for cn with 3, 2, and 1 matri expect_true(all(result2$addRel >= 0)) expect_true(all(result2$cnuRel >= 0)) - expect_equal(result3$cnuRel,result2$cnuRel) + expect_equal(result3$cnuRel, result2$cnuRel) result1 <- com2links(cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE) result1_legacy <- com2links.legacy(cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE) @@ -98,12 +98,11 @@ test_that("com2links processes creates same length for cn with 3, 2, and 1 matri expect_equal(ncol(result1_legacy), 3) # Expect ID1, ID2, and cnuRel expect_true(all(result1$cnuRel >= 0)) expect_true(all(result1_legacy$cnuRel >= 0)) - expect_equal(result3$cnuRel[result3$cnuRel==1],result1$cnuRel[result1$cnuRel==1]) - expect_equal(result3$cnuRel[result3$cnuRel==1],result1_legacy$cnuRel[result1_legacy$cnuRel==1]) - expect_equal(result2$cnuRel[result2$cnuRel==1],result1$cnuRel[result1$cnuRel==1]) - expect_equal(result2$cnuRel[result2$cnuRel==1],result1_legacy$cnuRel[result1_legacy$cnuRel==1]) - expect_equal(result1$cnuRel[result1$cnuRel==1],result1_legacy$cnuRel[result1_legacy$cnuRel==1]) - + expect_equal(result3$cnuRel[result3$cnuRel == 1], result1$cnuRel[result1$cnuRel == 1]) + expect_equal(result3$cnuRel[result3$cnuRel == 1], result1_legacy$cnuRel[result1_legacy$cnuRel == 1]) + expect_equal(result2$cnuRel[result2$cnuRel == 1], result1$cnuRel[result1$cnuRel == 1]) + expect_equal(result2$cnuRel[result2$cnuRel == 1], result1_legacy$cnuRel[result1_legacy$cnuRel == 1]) + expect_equal(result1$cnuRel[result1$cnuRel == 1], result1_legacy$cnuRel[result1_legacy$cnuRel == 1]) }) test_that("com2links written version matchs", { data(hazard) @@ -327,9 +326,8 @@ test_that("com2links handles large batch writing correctly", { expect_true(file.exists(temp_file)) written_data <- read.csv(temp_file) - expect_true(nrow(written_data) == 155) # Ensuring batch writing logic works + expect_true(nrow(written_data) == 155) # Ensuring batch writing logic works expect_true(file.remove(temp_file)) - }) test_that("com2links garbage collection does not affect output, using two components", { diff --git a/tests/testthat/test-plotPedigree.R b/tests/testthat/test-plotPedigree.R index 2c5199d7..ce4697c4 100644 --- a/tests/testthat/test-plotPedigree.R +++ b/tests/testthat/test-plotPedigree.R @@ -34,11 +34,9 @@ test_that("pedigree plots correctly with affected variables", { # file.remove("Rplots.pdf") test_that("pedigree errs when affected variables named", { -data(inbreeding) + data(inbreeding) expect_error(plotPedigree(data, verbose = TRUE, affected = "affected")) - - }) @@ -46,6 +44,4 @@ test_that("pedigree plots multiple families", { data(inbreeding) expect_output(plotPedigree(inbreeding, verbose = TRUE)) - - }) diff --git a/tests/testthat/test-readPedigrees.R b/tests/testthat/test-readPedigrees.R index b48bf74a..6adb4687 100644 --- a/tests/testthat/test-readPedigrees.R +++ b/tests/testthat/test-readPedigrees.R @@ -231,4 +231,3 @@ test_that("readGedcom handles incomplete individual records gracefully", { unlink(temp_file) }) - diff --git a/tests/testthat/test-readWikiTree.R b/tests/testthat/test-readWikiTree.R index d73e5810..166539d9 100644 --- a/tests/testthat/test-readWikiTree.R +++ b/tests/testthat/test-readWikiTree.R @@ -1,4 +1,3 @@ - # readWikifamilytree test_that("readWikifamilytree reads a string correctly", { diff --git a/vignettes/ASOIAF.Rmd b/vignettes/ASOIAF.Rmd index 54ecea5f..c83d9241 100644 --- a/vignettes/ASOIAF.Rmd +++ b/vignettes/ASOIAF.Rmd @@ -165,7 +165,5 @@ This code creates new IDs for individuals with one known parent and a missing ot We can now visualize the repaired pedigree using the `plotPedigree()` function. This function generates a plot of the pedigree, with individuals colored based on their affected status. In this case, we highlight Jon and Daenerys as "affected" individuals. Otherwise they would be difficult to distinguish from the rest of the pedigree. ```{r, message=FALSE, warning=FALSE} - - plotPedigree(df_repaired, affected = df_repaired$affected, verbose = FALSE) ``` diff --git a/vignettes/partial.Rmd b/vignettes/partial.Rmd index 52a9e45e..50009cfc 100644 --- a/vignettes/partial.Rmd +++ b/vignettes/partial.Rmd @@ -71,16 +71,18 @@ corrplot(as.matrix(ped_add_classic_complete), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Additive component - Classic method", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) corrplot(as.matrix(ped_add_partial_complete), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, title = "Additive component - Partial parent method", + is.corr = FALSE, title = "Additive component - Partial parent method", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) ``` @@ -89,9 +91,10 @@ To verify this, we subtract one matrix from the other and calculate RMSE. The di ```{r,warning=FALSE} corrplot((as.matrix(ped_add_classic_complete) - as.matrix(ped_add_partial_complete)), method = "color", type = "lower", col.lim = c(0, 1), - is.corr = FALSE, order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + is.corr = FALSE, order = "hclust", + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) ``` @@ -131,14 +134,16 @@ corrplot(as.matrix(ped_add_classic), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Classic (mother removed)", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) corrplot(as.matrix(ped_add_partial), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Partial (mother removed)", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) ``` @@ -156,8 +161,9 @@ corrplot(as.matrix(ped_add_classic_complete) - as.matrix(ped_add_classic), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) sqrt(mean((ped_add_classic_complete - ped_add_classic)^2)) ``` @@ -169,8 +175,9 @@ corrplot(as.matrix(ped_add_classic_complete - ped_add_partial), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) sqrt(mean((ped_add_classic_complete - ped_add_partial)^2)) ``` @@ -214,15 +221,17 @@ corrplot(as.matrix(ped_add_classic_dad), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Classic (father removed)", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) corrplot(as.matrix(ped_add_partial_dad), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Partial (father removed)", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) ``` Again, we compare to the true matrix from the complete pedigree: @@ -233,8 +242,9 @@ corrplot(as.matrix(ped_add_classic_complete - ped_add_classic), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) sqrt(mean((ped_add_classic_complete - ped_add_classic)^2)) ``` @@ -245,8 +255,9 @@ corrplot(as.matrix(ped_add_classic_complete - ped_add_partial), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) sqrt(mean((ped_add_classic_complete - ped_add_partial)^2)) ``` @@ -389,36 +400,41 @@ corrplot(as.matrix(fam1$ped_add_classic_complete), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Classic - Complete", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) corrplot(as.matrix(fam1$ped_add_classic_mom), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Classic - Mom Missing", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) corrplot(as.matrix(fam1$ped_add_partial_mom), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Partial - Mom Missing", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) corrplot(as.matrix(fam1$ped_add_classic_dad), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Classic - Dad Missing", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) corrplot(as.matrix(fam1$ped_add_partial_dad), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Partial - Dad Missing", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) ``` @@ -429,29 +445,33 @@ corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_classic_mom), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Classic Mom Diff from Complete", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_partial_mom), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Partial Mom Diff from Complete", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_classic_dad), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Classic Dad Diff from Complete", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_partial_dad), method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Partial Dad Diff from Complete", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) ``` These plots show how each method responds to missing data, and whether it maintains consistency with the complete pedigree. We observe that the partial parent method typically introduces smaller deviations. If desired, this same diagnostic can be repeated for additional families, such as inbreeding_list[[2]]. diff --git a/vignettes/partial.html b/vignettes/partial.html index 9a2e5535..51f5d3f5 100644 --- a/vignettes/partial.html +++ b/vignettes/partial.html @@ -396,25 +396,28 @@

Hazard Data Example

 method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Additive component - Classic method", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0)) + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 
 corrplot(as.matrix(ped_add_partial_complete),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE, title = "Additive component - Partial parent method", 
+  is.corr = FALSE, title = "Additive component - Partial parent method",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +)

To verify this, we subtract one matrix from the other and calculate RMSE. The difference should be numerically zero. Indeed, it is 0.

corrplot((as.matrix(ped_add_classic_complete) - as.matrix(ped_add_partial_complete)),
   method = "color", type = "lower", col.lim = c(0, 1),
-  is.corr = FALSE,  order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ is.corr = FALSE, order = "hclust", + tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +)

@@ -445,15 +448,17 @@

Introducing Missingness: Remove a Parent

method = "color", type = "lower", col.lim = c(0, 1), is.corr = FALSE, title = "Classic (mother removed)", order = "hclust", - tl.pos ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, - col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 

corrplot(as.matrix(ped_add_partial),
   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE, title = "Partial (mother removed)",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +)

We quantify the overall matrix difference:

sqrt(mean((as.matrix(ped_add_classic) - as.matrix(ped_add_partial))^2))
@@ -465,8 +470,9 @@ 
Introducing Missingness: Remove a Parent

   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE,
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 sqrt(mean((ped_add_classic_complete - ped_add_classic)^2))
@@ -477,8 +483,9 @@ 
Introducing Missingness: Remove a Parent

   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE,
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 sqrt(mean((ped_add_classic_complete - ped_add_partial)^2))
@@ -515,24 +522,27 @@ 
Removing the Father Instead

   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE, title = "Classic (father removed)",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 corrplot(as.matrix(ped_add_partial_dad),
   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE, title = "Partial (father removed)",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +)

Again, we compare to the true matrix from the complete pedigree:

corrplot(as.matrix(ped_add_classic_complete - ped_add_classic),
   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE,
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 sqrt(mean((ped_add_classic_complete - ped_add_classic)^2))
@@ -543,8 +553,9 @@ 
Removing the Father Instead

   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE,
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 sqrt(mean((ped_add_classic_complete - ped_add_partial)^2))
@@ -757,72 +768,81 @@ 
Example: Family 1

   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE, title = "Classic - Complete",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 corrplot(as.matrix(fam1$ped_add_classic_mom),
   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE, title = "Classic - Mom Missing",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 corrplot(as.matrix(fam1$ped_add_partial_mom),
   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE, title = "Partial - Mom Missing",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 corrplot(as.matrix(fam1$ped_add_classic_dad),
   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE, title = "Classic - Dad Missing",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 corrplot(as.matrix(fam1$ped_add_partial_dad),
   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE, title = "Partial - Dad Missing",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +)

To visualize the differences from the true matrix:

corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_classic_mom),
   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE, title = "Classic Mom Diff from Complete",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_partial_mom),
   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE, title = "Partial Mom Diff from Complete",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_classic_dad),
   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE, title = "Classic Dad Diff from Complete",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +) 


 corrplot(as.matrix(fam1$ped_add_classic_complete - fam1$ped_add_partial_dad),
   method = "color", type = "lower", col.lim = c(0, 1),
   is.corr = FALSE, title = "Partial Dad Diff from Complete",
   order = "hclust",
-  tl.pos    ="l", tl.col = "black", tl.srt = 5, tl.cex = 0.2,
-  col = COL1('Reds', 100), mar=c(0,0,2,0))
+ tl.pos = "l", tl.col = "black", tl.srt = 5, tl.cex = 0.2, + col = COL1("Reds", 100), mar = c(0, 0, 2, 0) +)

These plots show how each method responds to missing data, and whether it maintains consistency with the complete pedigree. We observe From 13ac783f590b51014b39dec856f7b1a976e8ed50 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Wed, 16 Apr 2025 20:19:47 -0400 Subject: [PATCH 46/69] oops --- R/helpPedigree.R | 4 ++-- man/determineSex.Rd | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/helpPedigree.R b/R/helpPedigree.R index e46d49cf..87263fb9 100644 --- a/R/helpPedigree.R +++ b/R/helpPedigree.R @@ -39,8 +39,8 @@ createGenDataFrame <- function(sizeGens, genIndex, idGen) { #' #' @param idGen Vector of IDs for the generation. #' @param sexR Numeric value indicating the sex ratio (proportion of males). -#' @param recode_male The value to use for males. Default is "M" -#' @param recode_female The value to use for females. Default is "F" +#' @param code_male The value to use for males. Default is "M" +#' @param code_female The value to use for females. Default is "F" #' @return Vector of sexes ("M" for male, "F" for female) for the offspring. #' @importFrom stats runif determineSex <- function(idGen, sexR, code_male = "M", code_female = "F") { diff --git a/man/determineSex.Rd b/man/determineSex.Rd index 4ea9498a..39711ada 100644 --- a/man/determineSex.Rd +++ b/man/determineSex.Rd @@ -11,9 +11,9 @@ determineSex(idGen, sexR, code_male = "M", code_female = "F") \item{sexR}{Numeric value indicating the sex ratio (proportion of males).} -\item{recode_male}{The value to use for males. Default is "M"} +\item{code_male}{The value to use for males. Default is "M"} -\item{recode_female}{The value to use for females. Default is "F"} +\item{code_female}{The value to use for females. Default is "F"} } \value{ Vector of sexes ("M" for male, "F" for female) for the offspring. From 5475b12b13af3e982501dae7ec8cb3af9eb9de26 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Wed, 16 Apr 2025 20:35:37 -0400 Subject: [PATCH 47/69] Update test-readPedigrees.R --- tests/testthat/test-readPedigrees.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-readPedigrees.R b/tests/testthat/test-readPedigrees.R index 6adb4687..de7aaeb3 100644 --- a/tests/testthat/test-readPedigrees.R +++ b/tests/testthat/test-readPedigrees.R @@ -209,6 +209,7 @@ test_that("readGedcom parses death event correctly", { expect_equal(df$death_caus[1], "Old age") expect_equal(df$death_lat[1], "12.3456") expect_equal(df$death_long[1], "-65.4321") + df <- readGedcom.legacy(temp_file, verbose = TRUE) unlink(temp_file) }) From 682df518f34d3725093d1f30ac0f39280feb72f5 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Thu, 17 Apr 2025 22:32:31 -0400 Subject: [PATCH 48/69] graph tracing wip --- R/calculateFamilySize.R | 9 +- R/readWikifamilytree.R | 173 ++++++++++++++++++++++++----- tests/testthat/test-readWikiTree.R | 54 +++++++++ 3 files changed, 205 insertions(+), 31 deletions(-) diff --git a/R/calculateFamilySize.R b/R/calculateFamilySize.R index 06cc3f16..c346cb66 100644 --- a/R/calculateFamilySize.R +++ b/R/calculateFamilySize.R @@ -1,4 +1,4 @@ -#' allGens +#' calcAllGens #' A function to calculate the number of individuals in each generation. This is a supporting function for \code{simulatePedigree}. #' @param kpc Number of kids per couple (integer >= 2). #' @param Ngen Number of generations (integer >= 1). @@ -24,10 +24,9 @@ calcAllGens <- function(kpc, Ngen, marR) { return(allGens) } #' @rdname calcAllGens -#' @export allGens <- calcAllGens -#' sizeAllGens +#' calcFamilySizeByGen #' An internal supporting function for \code{simulatePedigree}. #' @inheritParams calcAllGens #' @return Returns a vector including the number of individuals in every generation. @@ -49,10 +48,9 @@ calcFamilySizeByGen <- function(kpc, Ngen, marR) { return(allGens) } #' @rdname calcFamilySizeByGen -#' @export sizeAllGens <- calcFamilySizeByGen -#' famSizeCal +#' calcFamilySize #' A function to calculate the total number of individuals in a pedigree given parameters. This is a supporting function for function \code{simulatePedigree} #' @inheritParams calcAllGens #' @return Returns a numeric value indicating the total pedigree size. @@ -77,6 +75,5 @@ calcFamilySize <- function(kpc, Ngen, marR) { } #' @rdname calcFamilySize -#' @export #' famSizeCal <- calcFamilySize diff --git a/R/readWikifamilytree.R b/R/readWikifamilytree.R index fc0a7521..a59ea7c3 100644 --- a/R/readWikifamilytree.R +++ b/R/readWikifamilytree.R @@ -148,6 +148,10 @@ parseTree <- function(tree_lines) { return(tree_df) } + + + + #' infer relationship from tree template #' #' @param tree_long A data frame containing the tree structure in long format. @@ -155,43 +159,162 @@ parseTree <- function(tree_lines) { #' @keywords internal #' parseRelationships <- function(tree_long) { + +traced <- traceTreePaths(tree_long, deduplicate = FALSE) + + # Initialize relationships data frame relationships <- data.frame( - id = tree_long$id, + id = tree_long$id[!is.na(tree_long$id)], momID = NA_character_, dadID = NA_character_, + parent_1 = NA_character_, + parent_2 = NA_character_, spouseID = NA_character_, stringsAsFactors = FALSE ) - # Loop through rows to find connections - for (i in seq_len(nrow(tree_long))) { - row <- tree_long[i, ] - - # **Parent-Child Detection** - if (row$Value == "y") { - parent <- tree_long$Value[tree_long$Row == row$Row - 1 & tree_long$Column == row$Column] - child <- tree_long$Value[tree_long$Row == row$Row + 1 & tree_long$Column == row$Column] - - if (length(parent) == 0) parent <- NA - if (length(child) == 0) child <- NA - # Assign mom/dad IDs based on tree structure - if (!is.na(parent) && !is.na(child)) { - relationships$momID[relationships$id == child] <- parent - relationships$dadID[relationships$id == child] <- parent # Assuming one parent detected for now + traced <- traced[!is.na(traced$from_id) & !is.na(traced$to_id), ] + + + # > traced +# from_id to_id path_length intermediates intermediate_values +# A B 2 1_2 + +# A C 5 1_2;2_2;3_2;4_2 +|y| +# B C 5 1_2;2_2;3_2;4_2 +|y| + # Fill in relationships based on the tree structure + traced$relationship <- NA_character_ + + + # if intermediate values is "+", the relationship is spouse + + + traced$relationship[traced$intermediate_values=="+"] <- "spouse" + + #if intermediate value contains "y", the relationship is parent-child + + traced$relationship[traced$intermediate_values=="+|y|"] <- "parent-child" + traced$relationship[traced$intermediate_values=="|y|+"] <- "child-parent" + + + + return(relationships) +} + + + +#' Trace paths between individuals in a family tree grid +#' +#' @param tree_long A data.frame with columns: Row, Column, Value, id +#' @param deduplicate Logical, if TRUE, will remove duplicate paths +#' @return A data.frame with columns: from_id, to_id, direction, path_length, intermediates +#' @export +traceTreePaths <- function(tree_long, deduplicate = TRUE) { + # Keep only relevant cells (people and path symbols) + path_symbols <- c("|", "-", "+", "v", "^", "y", ",", ".", "`", "!") + tree_long$Value <- gsub("\\s+", "", tree_long$Value) # Remove whitespace + active_cells <- tree_long[!is.na(tree_long$Value) & + (tree_long$Value %in% path_symbols | !is.na(tree_long$id)), ] + + active_cells$key <- paste(active_cells$Row, active_cells$Column, sep = "_") + + + edges <- do.call(rbind, lapply(seq_len(nrow(active_cells)), function(i) { + from_key <- active_cells$key[i] + to_keys <- findNeighbors(active_cells[i, ], + active_keys=active_cells$key) + if (length(to_keys) > 0) { + data.frame(from = from_key, to = to_keys, stringsAsFactors = FALSE) + } + })) + + # Create graph + g <- igraph::graph_from_data_frame(edges, directed = FALSE) + + # Map keys to IDs + person_nodes <- active_cells[!is.na(active_cells$id), c("key", "id")] + id_map <- setNames(person_nodes$id, person_nodes$key) + + # Find all pairs of people and trace paths + person_keys <- names(id_map) + result <- data.frame() + + for (i in seq_along(person_keys)) { + for (j in seq_along(person_keys)) { + if (i == j) next + from_key <- person_keys[i] + to_key <- person_keys[j] + + sp <- suppressWarnings(igraph::shortest_paths(g, from_key, to_key, output = "vpath")$vpath[[1]]) + if (length(sp) > 1) { + intermediate <- setdiff(names(sp), c(from_key, to_key)) + # Extract values at those intermediate keys + intermediate_values <- sapply(intermediate, function(k) { + cell <- active_cells[active_cells$key == k, ] + if (nrow(cell) > 0) cell$Value else NA + }) + result <- rbind(result, data.frame( + from_id = id_map[[from_key]], + to_id = id_map[[to_key]], + path_length = length(sp) - 1, + intermediates = paste(intermediate, collapse = ";"), + intermediate_values = paste(intermediate_values, collapse = ""), + stringsAsFactors = FALSE + ))} else { + # If no path found, add a row with NA values + result <- rbind(result, data.frame( + from_id = id_map[[from_key]], + to_id = id_map[[to_key]], + path_length = NA, + intermediates = NA, + intermediate_values = NA, + stringsAsFactors = FALSE + )) + } } } - # **Spouse Detection** - if (row$Value == "+") { - spouse1 <- tree_long$Value[tree_long$Row == row$Row & tree_long$Column == row$Column - 1] - spouse2 <- tree_long$Value[tree_long$Row == row$Row & tree_long$Column == row$Column + 1] + if(deduplicate==TRUE){ + # Deduplicate pairs + result <- deduplicatePairs(result) + } - if (!is.na(spouse1) && !is.na(spouse2)) { - relationships$spouseID[relationships$id == spouse1] <- spouse2 - relationships$spouseID[relationships$id == spouse2] <- spouse1 - } + return(result) +} + +#' Build adjacency list (4-way neighbors) +#' +#' @param cell A data frame with columns Row and Column +#' @return A character vector of neighboring cell keys +#' @keywords internal + +findNeighbors <- function(cell,active_keys) { + offsets <- list(c(1, 0), c(-1, 0), c(0, 1), c(0, -1)) # down, up, right, left + out <- character() + for (offset in offsets) { + r2 <- cell$Row + offset[1] + c2 <- cell$Column + offset[2] + key2 <- paste(r2, c2, sep = "_") + if (key2 %in% active_keys) { + out <- c(out, key2) } } + return(out) +} - return(relationships) +#' Deduplicate pairs of IDs in a data frame +#' +#' @param df A data frame with columns from_id and to_id +#' @return A data frame with unique pairs of IDs +#' @export +deduplicatePairs <- function(df) { + # Create a new column with sorted pairs + df$pair <- apply(df[, c("from_id", "to_id")], 1, function(x) paste(sort(x), collapse = "_")) + + # Remove duplicates based on the pair column + df_dedup <- df[!duplicated(df$pair), ] + + # Drop the pair column + df_dedup$pair <- NULL + + return(df_dedup) } diff --git a/tests/testthat/test-readWikiTree.R b/tests/testthat/test-readWikiTree.R index 166539d9..03067c2c 100644 --- a/tests/testthat/test-readWikiTree.R +++ b/tests/testthat/test-readWikiTree.R @@ -1,5 +1,59 @@ # readWikifamilytree + +test_that("traceTreePaths works correctly for horizontal tree", { + # Create a mock tree_horizontal data frame + # This is a simplified version of the tree_horizontal data frame + # with Row, Column, Value, and id columns + # The id column is used to identify the nodes in the tree + +tree_horizontal <- data.frame( + Row = rep(1, 3), + Column = 1:3, + Value = c("A", "+", "B"), + stringsAsFactors = FALSE +) +tree_horizontal$id <- NA +tree_horizontal$id[tree_horizontal$Value %in% c("A", "B")] <- tree_horizontal$Value[tree_horizontal$Value %in% c("A", "B")] + +result <- traceTreePaths(tree_horizontal) +# Check the result + expect_equal(result$path[1], "A") + expect_equal(result$path[2], "B") + expect_equal(result$path[3], NA) +}) + + +test_that("traceTreePaths works correctly for vertical tree", { + # Create a mock tree_vertical data frame + # This is a simplified version of the tree_vertical data frame + # with Row, Column, Value, and id columns + # The id column is used to identify the nodes in the tree +tree_spouse_child <- data.frame( + Row = c(1, 1, 1, 2, 3, 4, 5), + Column = c(1, 2, 3, 2, 2, 2, 2), + Value = c("A", "+", "B", "|", "y", "|", "C"), + stringsAsFactors = FALSE +) +tree_spouse_child$id <- NA +tree_spouse_child$id[tree_spouse_child$Value %in% c("A", "B", "C")] <- tree_spouse_child$Value[tree_spouse_child$Value %in% c("A", "B", "C")] + +result <- traceTreePaths(tree_spouse_child) + +expect_equal(result$path[1], "A") + expect_equal(result$path[2], "B") + expect_equal(result$path[3], "C") + expect_equal(result$path[4], "y") + expect_equal(result$path[5], NA) +}) + + + + + + + + test_that("readWikifamilytree reads a string correctly", { # Create a temporary WikiFamilyTree file for testing # Example usage From 4886b201dcf5335179123d79bd99f43992bc08b7 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Fri, 18 Apr 2025 23:21:32 -0400 Subject: [PATCH 49/69] docs --- NAMESPACE | 5 ++--- man/calcAllGens.Rd | 4 ++-- man/calcFamilySize.Rd | 4 ++-- man/calcFamilySizeByGen.Rd | 4 ++-- man/deduplicatePairs.Rd | 17 +++++++++++++++++ man/findNeighbors.Rd | 18 ++++++++++++++++++ man/traceTreePaths.Rd | 19 +++++++++++++++++++ 7 files changed, 62 insertions(+), 9 deletions(-) create mode 100644 man/deduplicatePairs.Rd create mode 100644 man/findNeighbors.Rd create mode 100644 man/traceTreePaths.Rd diff --git a/NAMESPACE b/NAMESPACE index 69e23307..67e8e90a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,6 @@ # Generated by roxygen2: do not edit by hand export(SimPed) -export(allGens) export(assignCoupleIDs) export(calcAllGens) export(calcFamilySize) @@ -13,10 +12,10 @@ export(checkSex) export(com2links) export(comp2vech) export(createGenDataFrame) +export(deduplicatePairs) export(dropLink) export(evenInsert) export(extractSummaryText) -export(famSizeCal) export(fitComponentModel) export(identifyComponentModel) export(inferRelatedness) @@ -44,7 +43,6 @@ export(relatedness) export(repairSex) export(resample) export(simulatePedigree) -export(sizeAllGens) export(summariseFamilies) export(summariseMatrilines) export(summarisePatrilines) @@ -53,6 +51,7 @@ export(summarizeFamilies) export(summarizeMatrilines) export(summarizePatrilines) export(summarizePedigrees) +export(traceTreePaths) export(vech) import(data.table) import(kinship2) diff --git a/man/calcAllGens.Rd b/man/calcAllGens.Rd index 66a89c25..35871be7 100644 --- a/man/calcAllGens.Rd +++ b/man/calcAllGens.Rd @@ -3,7 +3,7 @@ \name{calcAllGens} \alias{calcAllGens} \alias{allGens} -\title{allGens +\title{calcAllGens A function to calculate the number of individuals in each generation. This is a supporting function for \code{simulatePedigree}.} \usage{ calcAllGens(kpc, Ngen, marR) @@ -21,6 +21,6 @@ allGens(kpc, Ngen, marR) Returns a vector containing the number of individuals in every generation. } \description{ -allGens +calcAllGens A function to calculate the number of individuals in each generation. This is a supporting function for \code{simulatePedigree}. } diff --git a/man/calcFamilySize.Rd b/man/calcFamilySize.Rd index a0128d0c..dda31d20 100644 --- a/man/calcFamilySize.Rd +++ b/man/calcFamilySize.Rd @@ -3,7 +3,7 @@ \name{calcFamilySize} \alias{calcFamilySize} \alias{famSizeCal} -\title{famSizeCal +\title{calcFamilySize A function to calculate the total number of individuals in a pedigree given parameters. This is a supporting function for function \code{simulatePedigree}} \usage{ calcFamilySize(kpc, Ngen, marR) @@ -21,6 +21,6 @@ famSizeCal(kpc, Ngen, marR) Returns a numeric value indicating the total pedigree size. } \description{ -famSizeCal +calcFamilySize A function to calculate the total number of individuals in a pedigree given parameters. This is a supporting function for function \code{simulatePedigree} } diff --git a/man/calcFamilySizeByGen.Rd b/man/calcFamilySizeByGen.Rd index ae3e5e88..f849339c 100644 --- a/man/calcFamilySizeByGen.Rd +++ b/man/calcFamilySizeByGen.Rd @@ -3,7 +3,7 @@ \name{calcFamilySizeByGen} \alias{calcFamilySizeByGen} \alias{sizeAllGens} -\title{sizeAllGens +\title{calcFamilySizeByGen An internal supporting function for \code{simulatePedigree}.} \usage{ calcFamilySizeByGen(kpc, Ngen, marR) @@ -21,6 +21,6 @@ sizeAllGens(kpc, Ngen, marR) Returns a vector including the number of individuals in every generation. } \description{ -sizeAllGens +calcFamilySizeByGen An internal supporting function for \code{simulatePedigree}. } diff --git a/man/deduplicatePairs.Rd b/man/deduplicatePairs.Rd new file mode 100644 index 00000000..4a042665 --- /dev/null +++ b/man/deduplicatePairs.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readWikifamilytree.R +\name{deduplicatePairs} +\alias{deduplicatePairs} +\title{Deduplicate pairs of IDs in a data frame} +\usage{ +deduplicatePairs(df) +} +\arguments{ +\item{df}{A data frame with columns from_id and to_id} +} +\value{ +A data frame with unique pairs of IDs +} +\description{ +Deduplicate pairs of IDs in a data frame +} diff --git a/man/findNeighbors.Rd b/man/findNeighbors.Rd new file mode 100644 index 00000000..58de5a20 --- /dev/null +++ b/man/findNeighbors.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readWikifamilytree.R +\name{findNeighbors} +\alias{findNeighbors} +\title{Build adjacency list (4-way neighbors)} +\usage{ +findNeighbors(cell, active_keys) +} +\arguments{ +\item{cell}{A data frame with columns Row and Column} +} +\value{ +A character vector of neighboring cell keys +} +\description{ +Build adjacency list (4-way neighbors) +} +\keyword{internal} diff --git a/man/traceTreePaths.Rd b/man/traceTreePaths.Rd new file mode 100644 index 00000000..5522ed83 --- /dev/null +++ b/man/traceTreePaths.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readWikifamilytree.R +\name{traceTreePaths} +\alias{traceTreePaths} +\title{Trace paths between individuals in a family tree grid} +\usage{ +traceTreePaths(tree_long, deduplicate = TRUE) +} +\arguments{ +\item{tree_long}{A data.frame with columns: Row, Column, Value, id} + +\item{deduplicate}{Logical, if TRUE, will remove duplicate paths} +} +\value{ +A data.frame with columns: from_id, to_id, direction, path_length, intermediates +} +\description{ +Trace paths between individuals in a family tree grid +} From 66a68f515716b9a858a56adbb0ddbf3d1f568858 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Sat, 19 Apr 2025 12:16:29 -0400 Subject: [PATCH 50/69] smarter parsinh --- NAMESPACE | 1 - R/readWikifamilytree.R | 110 ++++++++++++++++++++++++++++++-------- man/assignParent.Rd | 22 ++++++++ man/deduplicatePairs.Rd | 1 + man/parseRelationships.Rd | 4 +- 5 files changed, 115 insertions(+), 23 deletions(-) create mode 100644 man/assignParent.Rd diff --git a/NAMESPACE b/NAMESPACE index 67e8e90a..fe31174b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,7 +12,6 @@ export(checkSex) export(com2links) export(comp2vech) export(createGenDataFrame) -export(deduplicatePairs) export(dropLink) export(evenInsert) export(extractSummaryText) diff --git a/R/readWikifamilytree.R b/R/readWikifamilytree.R index a59ea7c3..5a663fb4 100644 --- a/R/readWikifamilytree.R +++ b/R/readWikifamilytree.R @@ -53,8 +53,9 @@ readWikifamilytree <- function(text = NULL, verbose = FALSE, file_path = NULL, . tree_long$DisplayName <- ifelse(!is.na(tree_long$name), tree_long$name, tree_long$Value) # Use name if available # parse relationships and infer them + tree_paths <- traceTreePaths(tree_long, deduplicate = FALSE) - relationships_df <- parseRelationships(tree_long) + paresedrelationships <- parseRelationships(tree_long, tree_paths) # relationships_df <- processParents(tree_long, datasource = "wiki") @@ -65,7 +66,8 @@ readWikifamilytree <- function(text = NULL, verbose = FALSE, file_path = NULL, . summary = summary_text, members = members_df, structure = tree_long, - relationships = relationships_df + tree_paths = paresedrelationships$tree_paths, + relationships = paresedrelationships$relationships ) } @@ -155,16 +157,22 @@ parseTree <- function(tree_lines) { #' infer relationship from tree template #' #' @param tree_long A data frame containing the tree structure in long format. +#' @param tree_paths Optional. traceTreePaths output. If NULL, it will be calculated. #' @return A data frame containing the relationships between family members. #' @keywords internal #' -parseRelationships <- function(tree_long) { +parseRelationships <- function(tree_long, tree_paths=NULL) { -traced <- traceTreePaths(tree_long, deduplicate = FALSE) + # Check if tree_paths is NULL and call traceTreePaths if necessary + if (is.null(tree_paths)) { + tree_paths <- traceTreePaths(tree_long, deduplicate = FALSE) + } + # Initialize relationships dataframe: one row per unique person + person_ids <- unique(tree_long$id[!is.na(tree_long$id)]) # Initialize relationships data frame relationships <- data.frame( - id = tree_long$id[!is.na(tree_long$id)], + id = person_ids, momID = NA_character_, dadID = NA_character_, parent_1 = NA_character_, @@ -173,33 +181,88 @@ traced <- traceTreePaths(tree_long, deduplicate = FALSE) stringsAsFactors = FALSE ) - traced <- traced[!is.na(traced$from_id) & !is.na(traced$to_id), ] - + tree_paths <- tree_paths[!is.na(tree_paths$from_id) & !is.na(tree_paths$to_id), ] - # > traced -# from_id to_id path_length intermediates intermediate_values -# A B 2 1_2 + -# A C 5 1_2;2_2;3_2;4_2 +|y| -# B C 5 1_2;2_2;3_2;4_2 +|y| # Fill in relationships based on the tree structure - traced$relationship <- NA_character_ + tree_paths$relationship <- NA_character_ + + # map relationships based on the intermediate values + + tree_paths$relationship[ + grepl("\\+", tree_paths$intermediate_values) & + !grepl("y", tree_paths$intermediate_values) + ] <- "spouse" + + # Parent-child: + and y both present + tree_paths$relationship[ + grepl("\\+", tree_paths$intermediate_values) & + grepl("y", tree_paths$intermediate_values) + ] <- "offspring" +tree_paths$relationship[ + is.na(tree_paths$relationship) & grepl("y", tree_paths$intermediate_values) +] <- "offspring" - # if intermediate values is "+", the relationship is spouse - traced$relationship[traced$intermediate_values=="+"] <- "spouse" + # determine direction + tree_paths$relationship[grepl("^\\+", tree_paths$intermediate_values) & tree_paths$relationship=="offspring"] <- "parent-child" + tree_paths$relationship[grepl("[y\\|]$", tree_paths$intermediate_values) & tree_paths$relationship=="offspring"] <- "parent-child" + tree_paths$relationship[grepl("\\+$", tree_paths$intermediate_values) & tree_paths$relationship=="offspring"] <- "child-parent" + tree_paths$relationship[grepl("^[y\\|]", tree_paths$intermediate_values) & tree_paths$relationship=="offspring"] <- "child-parent" - #if intermediate value contains "y", the relationship is parent-child - traced$relationship[traced$intermediate_values=="+|y|"] <- "parent-child" - traced$relationship[traced$intermediate_values=="|y|+"] <- "child-parent" +# Fill spouse links + spouse_links <- tree_paths[tree_paths$relationship == "spouse", ] + for (i in seq_len(nrow(spouse_links))) { + a <- spouse_links$from_id[i] + b <- spouse_links$to_id[i] + relationships$spouseID[relationships$id == a] <- b + relationships$spouseID[relationships$id == b] <- a + } + + # Fill parent-child links from directional tags - return(relationships) + pc_links <- tree_paths[tree_paths$relationship == "parent-child", ] + for (i in seq_len(nrow(pc_links))) { + relationships <- assignParent(df=relationships, + child=pc_links$to_id[i], + parent=pc_links$from_id[i]) + } + + # --- Child-parent (to_id = parent) --- + cp_links <- tree_paths[tree_paths$relationship == "child-parent", ] + for (i in seq_len(nrow(cp_links))) { + parent <- cp_links$to_id[i] + child <- cp_links$from_id[i] + relationships <- assignParent(relationships, child, parent) + } + + out <- list(tree_paths = tree_paths, + relationships = relationships) + + return(out) } +#' Assign Parent +#' @param df A data frame containing the relationships. +#' @param child The ID of the child. +#' @param parent The ID of the parent. +#' @return A data frame with updated parent information. +#' @keywords internal +assignParent <- function(df, child, parent) { + idx <- which(df$id == child) + if (length(idx) != 1) return(df) + + if (is.na(df$parent_1[idx])) { + df$parent_1[idx] <- parent + } else if (is.na(df$parent_2[idx]) && df$parent_1[idx] != parent) { + df$parent_2[idx] <- parent + } + return(df) + } #' Trace paths between individuals in a family tree grid @@ -210,7 +273,7 @@ traced <- traceTreePaths(tree_long, deduplicate = FALSE) #' @export traceTreePaths <- function(tree_long, deduplicate = TRUE) { # Keep only relevant cells (people and path symbols) - path_symbols <- c("|", "-", "+", "v", "^", "y", ",", ".", "`", "!") + path_symbols <- c("|", "-", "+", "v", "^", "y", ",", ".", "`", "!", "~", "x", ")", "(") tree_long$Value <- gsub("\\s+", "", tree_long$Value) # Remove whitespace active_cells <- tree_long[!is.na(tree_long$Value) & (tree_long$Value %in% path_symbols | !is.na(tree_long$id)), ] @@ -244,6 +307,11 @@ traceTreePaths <- function(tree_long, deduplicate = TRUE) { from_key <- person_keys[i] to_key <- person_keys[j] + # skip if either endpoint is not in graph + if (!(from_key %in% igraph::V(g)$name) || !(to_key %in% igraph::V(g)$name)) { + next + } + # Find the shortest path between the two keys sp <- suppressWarnings(igraph::shortest_paths(g, from_key, to_key, output = "vpath")$vpath[[1]]) if (length(sp) > 1) { intermediate <- setdiff(names(sp), c(from_key, to_key)) @@ -305,7 +373,7 @@ findNeighbors <- function(cell,active_keys) { #' #' @param df A data frame with columns from_id and to_id #' @return A data frame with unique pairs of IDs -#' @export +#' @keywords internal deduplicatePairs <- function(df) { # Create a new column with sorted pairs df$pair <- apply(df[, c("from_id", "to_id")], 1, function(x) paste(sort(x), collapse = "_")) diff --git a/man/assignParent.Rd b/man/assignParent.Rd new file mode 100644 index 00000000..a4a58c44 --- /dev/null +++ b/man/assignParent.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/readWikifamilytree.R +\name{assignParent} +\alias{assignParent} +\title{Assign Parent} +\usage{ +assignParent(df, child, parent) +} +\arguments{ +\item{df}{A data frame containing the relationships.} + +\item{child}{The ID of the child.} + +\item{parent}{The ID of the parent.} +} +\value{ +A data frame with updated parent information. +} +\description{ +Assign Parent +} +\keyword{internal} diff --git a/man/deduplicatePairs.Rd b/man/deduplicatePairs.Rd index 4a042665..e133d803 100644 --- a/man/deduplicatePairs.Rd +++ b/man/deduplicatePairs.Rd @@ -15,3 +15,4 @@ A data frame with unique pairs of IDs \description{ Deduplicate pairs of IDs in a data frame } +\keyword{internal} diff --git a/man/parseRelationships.Rd b/man/parseRelationships.Rd index 24e864b5..5e017a3a 100644 --- a/man/parseRelationships.Rd +++ b/man/parseRelationships.Rd @@ -4,10 +4,12 @@ \alias{parseRelationships} \title{infer relationship from tree template} \usage{ -parseRelationships(tree_long) +parseRelationships(tree_long, tree_paths = NULL) } \arguments{ \item{tree_long}{A data frame containing the tree structure in long format.} + +\item{tree_paths}{Optional. traceTreePaths output. If NULL, it will be calculated.} } \value{ A data frame containing the relationships between family members. From ab1c7fd8da2d43b51f9e8e76815574a34154b00b Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Sat, 19 Apr 2025 14:16:08 -0400 Subject: [PATCH 51/69] rename functions --- .gitignore | 26 ++-- NAMESPACE | 4 +- R/readWikifamilytree.R | 141 +++++++++--------- man/{parseTree.Rd => buildTreeGrid.Rd} | 6 +- ...akeLongTree.Rd => convertGrid2LongTree.Rd} | 6 +- ...{matchMembers.Rd => extractMemberTable.Rd} | 6 +- man/{findNeighbors.Rd => getGridNeighbors.Rd} | 6 +- ...ctSummaryText.Rd => getWikiTreeSummary.Rd} | 6 +- ...tionships.Rd => parseTreeRelationships.Rd} | 6 +- man/{assignParent.Rd => populateParents.Rd} | 6 +- tests/testthat/test-readWikiTree.R | 46 +++--- 11 files changed, 128 insertions(+), 131 deletions(-) rename man/{parseTree.Rd => buildTreeGrid.Rd} (82%) rename man/{makeLongTree.Rd => convertGrid2LongTree.Rd} (78%) rename man/{matchMembers.Rd => extractMemberTable.Rd} (82%) rename man/{findNeighbors.Rd => getGridNeighbors.Rd} (80%) rename man/{extractSummaryText.Rd => getWikiTreeSummary.Rd} (81%) rename man/{parseRelationships.Rd => parseTreeRelationships.Rd} (80%) rename man/{assignParent.Rd => populateParents.Rd} (82%) diff --git a/.gitignore b/.gitignore index f84ea082..5f04620b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,19 +1,21 @@ -.Rproj.user +*.ASOIAF.ged +*.Rproj +*.knit.md .DS_Store -data-raw/ASOIAF.ged -R/.Rhistory +.Rdata .Rhistory -paper/paper.html +.Rproj.user +.httr-oauth +.quarto +.vscode/launch.json /Meta/ -*.knit.md -vignettes/articles/paper.html BGmisc.code-workspace -tests/testthat/Rplots.pdf -*.ASOIAF.ged -ASOIAF.ged -*.Rproj +R/.Rhistory benchmark_results.csv -.vscode/launch.json -dataRelatedPairs_new2.csv +data-raw/ASOIAF.ged data-raw/ASOIAF_040725.ged dataRelatedPairs.csv +dataRelatedPairs_new2.csv +paper/paper.html +tests/testthat/Rplots.pdf +vignettes/articles/paper.html diff --git a/NAMESPACE b/NAMESPACE index fe31174b..b5cff75a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,7 @@ export(SimPed) export(assignCoupleIDs) +export(buildTreeGrid) export(calcAllGens) export(calcFamilySize) export(calculateRelatedness) @@ -14,14 +15,13 @@ export(comp2vech) export(createGenDataFrame) export(dropLink) export(evenInsert) -export(extractSummaryText) export(fitComponentModel) +export(getWikiTreeSummary) export(identifyComponentModel) export(inferRelatedness) export(insertEven) export(makeInbreeding) export(makeTwins) -export(parseTree) export(ped2add) export(ped2ce) export(ped2cn) diff --git a/R/readWikifamilytree.R b/R/readWikifamilytree.R index 5a663fb4..018caaef 100644 --- a/R/readWikifamilytree.R +++ b/R/readWikifamilytree.R @@ -28,23 +28,23 @@ readWikifamilytree <- function(text = NULL, verbose = FALSE, file_path = NULL, . } # Extract summary text - summary_text <- extractSummaryText(text) + summary_text <- getWikiTreeSummary(text) # Extract all lines defining the family tree tree_lines <- unlist(stringr::str_extract_all(text, "\\{\\{familytree.*?\\}\\}")) tree_lines <- tree_lines[!stringr::str_detect(tree_lines, "start|end")] # Remove start/end markers tree_lines <- gsub("\\{\\{familytree(.*?)\\}\\}", "\\1", tree_lines) # Remove wrapping markup # Convert tree structure into a coordinate grid (preserves symbols!) - tree_df <- parseTree(tree_lines) + tree_df <- buildTreeGrid(tree_lines) # Identify columns that start with "Y" cols_to_pivot <- grep("^Y", names(tree_df), value = TRUE) # Reshape from wide to long format - tree_long <- makeLongTree(tree_df, cols_to_pivot) + tree_long <- convertGrid2LongTree(tree_df, cols_to_pivot) # Extract member definitions - members_df <- matchMembers(text) + members_df <- extractMemberTable(text) members_df$id <- paste0("P", seq_len(nrow(members_df))) # Assign unique person IDs # Merge names into the tree structure (keeping all symbols!) @@ -55,19 +55,14 @@ readWikifamilytree <- function(text = NULL, verbose = FALSE, file_path = NULL, . # parse relationships and infer them tree_paths <- traceTreePaths(tree_long, deduplicate = FALSE) - paresedrelationships <- parseRelationships(tree_long, tree_paths) - - # relationships_df <- processParents(tree_long, datasource = "wiki") - - - + parsedRelationships <- parseTreeRelationships(tree_long, tree_paths) # Return structured table of the family tree (symbols included) list( summary = summary_text, members = members_df, structure = tree_long, - tree_paths = paresedrelationships$tree_paths, - relationships = paresedrelationships$relationships + tree_paths = parsedRelationships$tree_paths, + relationships = parsedRelationships$relationships ) } @@ -76,7 +71,7 @@ readWikifamilytree <- function(text = NULL, verbose = FALSE, file_path = NULL, . #' @param cols_to_pivot A character vector of column names to pivot. #' @return A long data frame containing the tree structure. #' @keywords internal -makeLongTree <- function(tree_df, cols_to_pivot) { +convertGrid2LongTree <- function(tree_df, cols_to_pivot) { tree_long <- stats::reshape(tree_df, varying = cols_to_pivot, v.names = "Value", @@ -97,7 +92,7 @@ makeLongTree <- function(tree_df, cols_to_pivot) { #' @return A data frame containing information about the members of the family tree. #' @keywords internal -matchMembers <- function(text) { +extractMemberTable <- function(text) { member_matches <- stringr::str_extract_all(text, "\\|\\s*([A-Za-z0-9]+)\\s*=\\s*([^|}]*)")[[1]] member_matches <- gsub("\\[|\\]|'''", "", member_matches) # Remove formatting @@ -122,7 +117,7 @@ matchMembers <- function(text) { #' @keywords internal #' @export -extractSummaryText <- function(text) { +getWikiTreeSummary <- function(text) { summary_match <- stringr::str_match(text, "\\{\\{familytree/start \\|summary=(.*?)\\}\\}") summary_text <- ifelse(!is.na(summary_match[, 2]), summary_match[, 2], NA) return(summary_text) @@ -134,7 +129,7 @@ extractSummaryText <- function(text) { #' @keywords internal #' @export -parseTree <- function(tree_lines) { +buildTreeGrid <- function(tree_lines) { tree_matrix <- base::strsplit(tree_lines, "\\|") # Split each row into columns max_cols <- max(sapply(tree_matrix, length)) # Find the max column count @@ -150,10 +145,6 @@ parseTree <- function(tree_lines) { return(tree_df) } - - - - #' infer relationship from tree template #' #' @param tree_long A data frame containing the tree structure in long format. @@ -161,8 +152,7 @@ parseTree <- function(tree_lines) { #' @return A data frame containing the relationships between family members. #' @keywords internal #' -parseRelationships <- function(tree_long, tree_paths=NULL) { - +parseTreeRelationships <- function(tree_long, tree_paths = NULL) { # Check if tree_paths is NULL and call traceTreePaths if necessary if (is.null(tree_paths)) { tree_paths <- traceTreePaths(tree_long, deduplicate = FALSE) @@ -194,26 +184,22 @@ parseRelationships <- function(tree_long, tree_paths=NULL) { ] <- "spouse" # Parent-child: + and y both present - tree_paths$relationship[ + tree_paths$relationship[ grepl("\\+", tree_paths$intermediate_values) & - grepl("y", tree_paths$intermediate_values) + grepl("y", tree_paths$intermediate_values) ] <- "offspring" -tree_paths$relationship[ - is.na(tree_paths$relationship) & grepl("y", tree_paths$intermediate_values) -] <- "offspring" - - - - # determine direction - tree_paths$relationship[grepl("^\\+", tree_paths$intermediate_values) & tree_paths$relationship=="offspring"] <- "parent-child" - tree_paths$relationship[grepl("[y\\|]$", tree_paths$intermediate_values) & tree_paths$relationship=="offspring"] <- "parent-child" - tree_paths$relationship[grepl("\\+$", tree_paths$intermediate_values) & tree_paths$relationship=="offspring"] <- "child-parent" - tree_paths$relationship[grepl("^[y\\|]", tree_paths$intermediate_values) & tree_paths$relationship=="offspring"] <- "child-parent" - + tree_paths$relationship[ + is.na(tree_paths$relationship) & grepl("y", tree_paths$intermediate_values) + ] <- "offspring" + # determine direction + tree_paths$relationship[grepl("^\\+", tree_paths$intermediate_values) & tree_paths$relationship == "offspring"] <- "parent-child" + tree_paths$relationship[grepl("[y\\|]$", tree_paths$intermediate_values) & tree_paths$relationship == "offspring"] <- "parent-child" + tree_paths$relationship[grepl("\\+$", tree_paths$intermediate_values) & tree_paths$relationship == "offspring"] <- "child-parent" + tree_paths$relationship[grepl("^[y\\|]", tree_paths$intermediate_values) & tree_paths$relationship == "offspring"] <- "child-parent" -# Fill spouse links + # Fill spouse links spouse_links <- tree_paths[tree_paths$relationship == "spouse", ] for (i in seq_len(nrow(spouse_links))) { @@ -227,22 +213,27 @@ tree_paths$relationship[ pc_links <- tree_paths[tree_paths$relationship == "parent-child", ] for (i in seq_len(nrow(pc_links))) { - relationships <- assignParent(df=relationships, - child=pc_links$to_id[i], - parent=pc_links$from_id[i]) + relationships <- populateParents( + df = relationships, + child = pc_links$to_id[i], + parent = pc_links$from_id[i] + ) } # --- Child-parent (to_id = parent) --- cp_links <- tree_paths[tree_paths$relationship == "child-parent", ] for (i in seq_len(nrow(cp_links))) { - parent <- cp_links$to_id[i] - child <- cp_links$from_id[i] - relationships <- assignParent(relationships, child, parent) + relationships <- populateParents( + df = relationships, + child = cp_links$from_id[i], + parent = cp_links$to_id[i] + ) } - out <- list(tree_paths = tree_paths, - relationships = relationships) - + out <- list( + tree_paths = tree_paths, + relationships = relationships + ) return(out) } @@ -252,18 +243,20 @@ tree_paths$relationship[ #' @param parent The ID of the parent. #' @return A data frame with updated parent information. #' @keywords internal -assignParent <- function(df, child, parent) { - idx <- which(df$id == child) - if (length(idx) != 1) return(df) - - if (is.na(df$parent_1[idx])) { - df$parent_1[idx] <- parent - } else if (is.na(df$parent_2[idx]) && df$parent_1[idx] != parent) { - df$parent_2[idx] <- parent - } +populateParents <- function(df, child, parent) { + idx <- which(df$id == child) + if (length(idx) != 1) { return(df) } + if (is.na(df$parent_1[idx])) { + df$parent_1[idx] <- parent + } else if (is.na(df$parent_2[idx]) && df$parent_1[idx] != parent) { + df$parent_2[idx] <- parent + } + return(df) +} + #' Trace paths between individuals in a family tree grid #' @@ -271,20 +264,21 @@ assignParent <- function(df, child, parent) { #' @param deduplicate Logical, if TRUE, will remove duplicate paths #' @return A data.frame with columns: from_id, to_id, direction, path_length, intermediates #' @export +#' traceTreePaths <- function(tree_long, deduplicate = TRUE) { # Keep only relevant cells (people and path symbols) path_symbols <- c("|", "-", "+", "v", "^", "y", ",", ".", "`", "!", "~", "x", ")", "(") tree_long$Value <- gsub("\\s+", "", tree_long$Value) # Remove whitespace active_cells <- tree_long[!is.na(tree_long$Value) & - (tree_long$Value %in% path_symbols | !is.na(tree_long$id)), ] + (tree_long$Value %in% path_symbols | !is.na(tree_long$id)), ] active_cells$key <- paste(active_cells$Row, active_cells$Column, sep = "_") - edges <- do.call(rbind, lapply(seq_len(nrow(active_cells)), function(i) { from_key <- active_cells$key[i] - to_keys <- findNeighbors(active_cells[i, ], - active_keys=active_cells$key) + to_keys <- getGridNeighbors(active_cells[i, ], + active_keys = active_cells$key + ) if (length(to_keys) > 0) { data.frame(from = from_key, to = to_keys, stringsAsFactors = FALSE) } @@ -327,21 +321,22 @@ traceTreePaths <- function(tree_long, deduplicate = TRUE) { intermediates = paste(intermediate, collapse = ";"), intermediate_values = paste(intermediate_values, collapse = ""), stringsAsFactors = FALSE - ))} else { - # If no path found, add a row with NA values - result <- rbind(result, data.frame( - from_id = id_map[[from_key]], - to_id = id_map[[to_key]], - path_length = NA, - intermediates = NA, - intermediate_values = NA, - stringsAsFactors = FALSE - )) - } + )) + } else { + # If no path found, add a row with NA values + result <- rbind(result, data.frame( + from_id = id_map[[from_key]], + to_id = id_map[[to_key]], + path_length = NA, + intermediates = NA, + intermediate_values = NA, + stringsAsFactors = FALSE + )) } } + } - if(deduplicate==TRUE){ + if (deduplicate == TRUE) { # Deduplicate pairs result <- deduplicatePairs(result) } @@ -355,8 +350,8 @@ traceTreePaths <- function(tree_long, deduplicate = TRUE) { #' @return A character vector of neighboring cell keys #' @keywords internal -findNeighbors <- function(cell,active_keys) { - offsets <- list(c(1, 0), c(-1, 0), c(0, 1), c(0, -1)) # down, up, right, left +getGridNeighbors <- function(cell, active_keys) { + offsets <- list(c(1, 0), c(-1, 0), c(0, 1), c(0, -1)) # down, up, right, left out <- character() for (offset in offsets) { r2 <- cell$Row + offset[1] diff --git a/man/parseTree.Rd b/man/buildTreeGrid.Rd similarity index 82% rename from man/parseTree.Rd rename to man/buildTreeGrid.Rd index 6982013e..13205cee 100644 --- a/man/parseTree.Rd +++ b/man/buildTreeGrid.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/readWikifamilytree.R -\name{parseTree} -\alias{parseTree} +\name{buildTreeGrid} +\alias{buildTreeGrid} \title{Parse Tree} \usage{ -parseTree(tree_lines) +buildTreeGrid(tree_lines) } \arguments{ \item{tree_lines}{A character vector containing the lines of the tree structure.} diff --git a/man/makeLongTree.Rd b/man/convertGrid2LongTree.Rd similarity index 78% rename from man/makeLongTree.Rd rename to man/convertGrid2LongTree.Rd index 96d4a514..d3bd5b5f 100644 --- a/man/makeLongTree.Rd +++ b/man/convertGrid2LongTree.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/readWikifamilytree.R -\name{makeLongTree} -\alias{makeLongTree} +\name{convertGrid2LongTree} +\alias{convertGrid2LongTree} \title{Make Long Tree} \usage{ -makeLongTree(tree_df, cols_to_pivot) +convertGrid2LongTree(tree_df, cols_to_pivot) } \arguments{ \item{tree_df}{A data frame containing the tree structure.} diff --git a/man/matchMembers.Rd b/man/extractMemberTable.Rd similarity index 82% rename from man/matchMembers.Rd rename to man/extractMemberTable.Rd index 382c05ec..72b0945b 100644 --- a/man/matchMembers.Rd +++ b/man/extractMemberTable.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/readWikifamilytree.R -\name{matchMembers} -\alias{matchMembers} +\name{extractMemberTable} +\alias{extractMemberTable} \title{Match Members} \usage{ -matchMembers(text) +extractMemberTable(text) } \arguments{ \item{text}{A character string containing the text of a family tree in wiki format.} diff --git a/man/findNeighbors.Rd b/man/getGridNeighbors.Rd similarity index 80% rename from man/findNeighbors.Rd rename to man/getGridNeighbors.Rd index 58de5a20..cc1e20fa 100644 --- a/man/findNeighbors.Rd +++ b/man/getGridNeighbors.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/readWikifamilytree.R -\name{findNeighbors} -\alias{findNeighbors} +\name{getGridNeighbors} +\alias{getGridNeighbors} \title{Build adjacency list (4-way neighbors)} \usage{ -findNeighbors(cell, active_keys) +getGridNeighbors(cell, active_keys) } \arguments{ \item{cell}{A data frame with columns Row and Column} diff --git a/man/extractSummaryText.Rd b/man/getWikiTreeSummary.Rd similarity index 81% rename from man/extractSummaryText.Rd rename to man/getWikiTreeSummary.Rd index 9b12be26..dadc4c33 100644 --- a/man/extractSummaryText.Rd +++ b/man/getWikiTreeSummary.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/readWikifamilytree.R -\name{extractSummaryText} -\alias{extractSummaryText} +\name{getWikiTreeSummary} +\alias{getWikiTreeSummary} \title{Extract Summary Text} \usage{ -extractSummaryText(text) +getWikiTreeSummary(text) } \arguments{ \item{text}{A character string containing the text of a family tree in wiki format.} diff --git a/man/parseRelationships.Rd b/man/parseTreeRelationships.Rd similarity index 80% rename from man/parseRelationships.Rd rename to man/parseTreeRelationships.Rd index 5e017a3a..a29a56da 100644 --- a/man/parseRelationships.Rd +++ b/man/parseTreeRelationships.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/readWikifamilytree.R -\name{parseRelationships} -\alias{parseRelationships} +\name{parseTreeRelationships} +\alias{parseTreeRelationships} \title{infer relationship from tree template} \usage{ -parseRelationships(tree_long, tree_paths = NULL) +parseTreeRelationships(tree_long, tree_paths = NULL) } \arguments{ \item{tree_long}{A data frame containing the tree structure in long format.} diff --git a/man/assignParent.Rd b/man/populateParents.Rd similarity index 82% rename from man/assignParent.Rd rename to man/populateParents.Rd index a4a58c44..f0871d6a 100644 --- a/man/assignParent.Rd +++ b/man/populateParents.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/readWikifamilytree.R -\name{assignParent} -\alias{assignParent} +\name{populateParents} +\alias{populateParents} \title{Assign Parent} \usage{ -assignParent(df, child, parent) +populateParents(df, child, parent) } \arguments{ \item{df}{A data frame containing the relationships.} diff --git a/tests/testthat/test-readWikiTree.R b/tests/testthat/test-readWikiTree.R index 03067c2c..3ab920bd 100644 --- a/tests/testthat/test-readWikiTree.R +++ b/tests/testthat/test-readWikiTree.R @@ -7,17 +7,17 @@ test_that("traceTreePaths works correctly for horizontal tree", { # with Row, Column, Value, and id columns # The id column is used to identify the nodes in the tree -tree_horizontal <- data.frame( - Row = rep(1, 3), - Column = 1:3, - Value = c("A", "+", "B"), - stringsAsFactors = FALSE -) -tree_horizontal$id <- NA -tree_horizontal$id[tree_horizontal$Value %in% c("A", "B")] <- tree_horizontal$Value[tree_horizontal$Value %in% c("A", "B")] - -result <- traceTreePaths(tree_horizontal) -# Check the result + tree_horizontal <- data.frame( + Row = rep(1, 3), + Column = 1:3, + Value = c("A", "+", "B"), + stringsAsFactors = FALSE + ) + tree_horizontal$id <- NA + tree_horizontal$id[tree_horizontal$Value %in% c("A", "B")] <- tree_horizontal$Value[tree_horizontal$Value %in% c("A", "B")] + + result <- traceTreePaths(tree_horizontal) + # Check the result expect_equal(result$path[1], "A") expect_equal(result$path[2], "B") expect_equal(result$path[3], NA) @@ -29,18 +29,18 @@ test_that("traceTreePaths works correctly for vertical tree", { # This is a simplified version of the tree_vertical data frame # with Row, Column, Value, and id columns # The id column is used to identify the nodes in the tree -tree_spouse_child <- data.frame( - Row = c(1, 1, 1, 2, 3, 4, 5), - Column = c(1, 2, 3, 2, 2, 2, 2), - Value = c("A", "+", "B", "|", "y", "|", "C"), - stringsAsFactors = FALSE -) -tree_spouse_child$id <- NA -tree_spouse_child$id[tree_spouse_child$Value %in% c("A", "B", "C")] <- tree_spouse_child$Value[tree_spouse_child$Value %in% c("A", "B", "C")] - -result <- traceTreePaths(tree_spouse_child) - -expect_equal(result$path[1], "A") + tree_spouse_child <- data.frame( + Row = c(1, 1, 1, 2, 3, 4, 5), + Column = c(1, 2, 3, 2, 2, 2, 2), + Value = c("A", "+", "B", "|", "y", "|", "C"), + stringsAsFactors = FALSE + ) + tree_spouse_child$id <- NA + tree_spouse_child$id[tree_spouse_child$Value %in% c("A", "B", "C")] <- tree_spouse_child$Value[tree_spouse_child$Value %in% c("A", "B", "C")] + + result <- traceTreePaths(tree_spouse_child) + + expect_equal(result$path[1], "A") expect_equal(result$path[2], "B") expect_equal(result$path[3], "C") expect_equal(result$path[4], "y") From 3373800487629a67f7cf60ccea36be197c94dc8d Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Sat, 19 Apr 2025 14:25:52 -0400 Subject: [PATCH 52/69] Update test-readWikiTree.R tests now work --- tests/testthat/test-readWikiTree.R | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/tests/testthat/test-readWikiTree.R b/tests/testthat/test-readWikiTree.R index 3ab920bd..df894c08 100644 --- a/tests/testthat/test-readWikiTree.R +++ b/tests/testthat/test-readWikiTree.R @@ -18,9 +18,11 @@ test_that("traceTreePaths works correctly for horizontal tree", { result <- traceTreePaths(tree_horizontal) # Check the result - expect_equal(result$path[1], "A") - expect_equal(result$path[2], "B") - expect_equal(result$path[3], NA) + # Check the result + expect_equal(names(result), c("from_id", "to_id", "path_length", "intermediates","intermediate_values")) + expect_equal(c("A", "B") %in% c(result$from_id, result$to_id), rep(TRUE,2)) + expect_equal(result$path_length[result$from_id == "A" & result$to_id == "B"], 2) + expect_equal(result$intermediate_values[result$from_id == "A" & result$to_id == "B"], "+") }) @@ -39,12 +41,14 @@ test_that("traceTreePaths works correctly for vertical tree", { tree_spouse_child$id[tree_spouse_child$Value %in% c("A", "B", "C")] <- tree_spouse_child$Value[tree_spouse_child$Value %in% c("A", "B", "C")] result <- traceTreePaths(tree_spouse_child) + # Check the result + expect_equal(names(result), c("from_id", "to_id", "path_length", "intermediates","intermediate_values")) + expect_equal(c("A", "B", "C") %in% c(result$from_id, result$to_id), rep(TRUE,3)) + expect_equal(result$path_length[result$from_id == "A" & result$to_id == "B"], 2) + expect_equal(result$path_length[result$from_id == "A" & result$to_id == "C"], 5) + expect_equal(result$path_length[result$from_id == "B" & result$to_id == "C"], 5) + expect_equal(result$intermediate_values[result$from_id == "A" & result$to_id == "B"], "+") - expect_equal(result$path[1], "A") - expect_equal(result$path[2], "B") - expect_equal(result$path[3], "C") - expect_equal(result$path[4], "y") - expect_equal(result$path[5], NA) }) @@ -79,8 +83,7 @@ test_that("readWikifamilytree reads a string correctly", { expect_equal( result2$summary, - "I have a brother Joe and a little sister: my mom married my dad, and my dad's parents were Grandma and Grandpa; they had another child, Aunt Daisy." - ) + result$summary) }) From 00ac669376d293449a3e6f199120860b0f339e06 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 21 Apr 2025 13:52:26 -0400 Subject: [PATCH 53/69] rename --- .../{modelingrelatedness.Rmd => modelingvariancecomponents.Rmd} | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) rename vignettes/{modelingrelatedness.Rmd => modelingvariancecomponents.Rmd} (98%) diff --git a/vignettes/modelingrelatedness.Rmd b/vignettes/modelingvariancecomponents.Rmd similarity index 98% rename from vignettes/modelingrelatedness.Rmd rename to vignettes/modelingvariancecomponents.Rmd index 6f793690..c82441a9 100644 --- a/vignettes/modelingrelatedness.Rmd +++ b/vignettes/modelingvariancecomponents.Rmd @@ -2,7 +2,7 @@ title: "Modeling variance components" output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{modelingandrelatedness} + %\VignetteIndexEntry{modelingvariancecomponents} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- From 6c3603b1588fddac0c1a45c052ad8beca16a7309 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 21 Apr 2025 16:31:31 -0400 Subject: [PATCH 54/69] rename --- R/{convertPedigree.R => buildComponent.R} | 0 R/{buildPedigree.R => segmentPedigree.R} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename R/{convertPedigree.R => buildComponent.R} (100%) rename R/{buildPedigree.R => segmentPedigree.R} (100%) diff --git a/R/convertPedigree.R b/R/buildComponent.R similarity index 100% rename from R/convertPedigree.R rename to R/buildComponent.R diff --git a/R/buildPedigree.R b/R/segmentPedigree.R similarity index 100% rename from R/buildPedigree.R rename to R/segmentPedigree.R From 2038a66928adc115310e6f618f0d0907c5d3387a Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 21 Apr 2025 16:39:00 -0400 Subject: [PATCH 55/69] split out adjacency --- R/buildComponent.R | 528 ---------------------------------------- R/constructAdjacency.R | 529 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 529 insertions(+), 528 deletions(-) create mode 100644 R/constructAdjacency.R diff --git a/R/buildComponent.R b/R/buildComponent.R index 86e9970a..dda09f1f 100644 --- a/R/buildComponent.R +++ b/R/buildComponent.R @@ -482,531 +482,3 @@ ped2ce <- function(ped, } } -.adjLoop <- function(ped, component, saveable, resume, - save_path, verbose, lastComputed, - nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist, - ...) { - # Loop through each individual in the pedigree - # Build the adjacency matrix for parent-child relationships - # Is person in column j the parent of the person in row i? .5 for yes, 0 for no. - ped$momID <- as.numeric(ped$momID) - ped$dadID <- as.numeric(ped$dadID) - ped$ID <- as.numeric(ped$ID) - - for (i in (lastComputed + 1):nr) { - x <- ped[i, , drop = FALSE] - # Handle parentage according to the 'component' specified - if (component %in% c("generation", "additive")) { - # Code for 'generation' and 'additive' components - # Checks if is mom of ID or is dad of ID - xID <- as.numeric(x["ID"]) - sMom <- (xID == ped$momID) - sDad <- (xID == ped$dadID) - val <- sMom | sDad - val[is.na(val)] <- FALSE - } else if (component %in% c("common nuclear")) { - # Code for 'common nuclear' component - # IDs have the Same mom and Same dad - sMom <- (as.numeric(x["momID"]) == ped$momID) - sMom[is.na(sMom)] <- FALSE - sDad <- (as.numeric(x["dadID"]) == ped$dadID) - sDad[is.na(sDad)] <- FALSE - val <- sMom & sDad - } else if (component %in% c("mitochondrial")) { - # Code for 'mitochondrial' component - val <- (as.numeric(x["ID"]) == ped$momID) - val[is.na(val)] <- FALSE - } else { - stop("Unknown relatedness component requested") - } - # Storing the indices of the parent-child relationships - # Keep track of indices only, and then initialize a single sparse matrix - wv <- which(val) - parList[[i]] <- wv - lens[i] <- length(wv) - # Print progress if verbose is TRUE - if (verbose && (i %% update_rate == 0)) { - cat(paste0("Done with ", i, " of ", nr, "\n")) - } - # Checkpointing every save_rate iterations - if (saveable && (i %% save_rate_parlist == 0)) { - saveRDS(parList, file = checkpoint_files$parList) - saveRDS(lens, file = checkpoint_files$lens) - if (verbose) cat("Checkpointed parlist saved at iteration", i, "\n") - } - } - jss <- rep(1L:nr, times = lens) - iss <- unlist(parList) - list_of_adjacency <- list(iss = iss, jss = jss) - return(list_of_adjacency) -} - -.adjIndexed <- function(ped, component, saveable, resume, - save_path, verbose, lastComputed, - nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist) { - # Loop through each individual in the pedigree - # Build the adjacency matrix for parent-child relationships - # Is person in column j the parent of the person in row i? .5 for yes, 0 for no. - - # Convert IDs - ped$ID <- as.numeric(ped$ID) - ped$momID <- as.numeric(ped$momID) - ped$dadID <- as.numeric(ped$dadID) - - # parent-child lookup - mom_index <- match(ped$momID, ped$ID, nomatch = 0) - dad_index <- match(ped$dadID, ped$ID, nomatch = 0) - - for (i in (lastComputed + 1):nr) { - if (component %in% c("generation", "additive")) { - sMom <- (mom_index == i) - sDad <- (dad_index == i) - val <- sMom | sDad - } else if (component %in% c("common nuclear")) { - # Code for 'common nuclear' component - # IDs have the Same mom and Same dad - sMom <- (ped$momID[i] == ped$momID) - sMom[is.na(sMom)] <- FALSE - sDad <- (ped$dadID[i] == ped$dadID) - sDad[is.na(sDad)] <- FALSE - val <- sMom & sDad - } else if (component %in% c("mitochondrial")) { - val <- (mom_index == i) - } else { - stop("Unknown relatedness component requested") - } - - val[is.na(val)] <- FALSE - parList[[i]] <- which(val) - lens[i] <- length(parList[[i]]) - - # Print progress if verbose is TRUE - if (verbose && (i %% update_rate == 0)) { - cat(paste0("Done with ", i, " of ", nr, "\n")) - } - - # Checkpointing every save_rate iterations - if (saveable && (i %% save_rate_parlist == 0)) { - saveRDS(parList, file = checkpoint_files$parList) - saveRDS(lens, file = checkpoint_files$lens) - if (verbose) cat("Checkpointed parlist saved at iteration", i, "\n") - } - } - jss <- rep(1L:nr, times = lens) - iss <- unlist(parList) - list_of_adjacency <- list(iss = iss, jss = jss) - return(list_of_adjacency) -} - -.adjDirect <- function(ped, component, saveable, resume, - save_path, verbose, lastComputed, - nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist, adjBeta_method, - ...) { - # Loop through each individual in the pedigree - # Build the adjacency matrix for parent-child relationships - # Is person in column j the parent of the person in row i? .5 for yes, 0 for no. - uniID <- ped$ID # live dangerously without sort(unique(ped$ID)) - ped$ID <- as.numeric(factor(ped$ID, levels = uniID)) - ped$momID <- as.numeric(factor(ped$momID, levels = uniID)) - ped$dadID <- as.numeric(factor(ped$dadID, levels = uniID)) - - if (component %in% c("generation", "additive")) { - mIDs <- stats::na.omit(data.frame(rID = ped$ID, cID = ped$momID)) - dIDs <- stats::na.omit(data.frame(rID = ped$ID, cID = ped$dadID)) - iss <- c(mIDs$rID, dIDs$rID) - jss <- c(mIDs$cID, dIDs$cID) - } else if (component %in% c("common nuclear")) { - # message("Common Nuclear component is not yet implemented for direct method. Using index method.\n") - - # 1) Create a logical mask for only known parents - mask <- !is.na(ped$momID) & !is.na(ped$dadID) - - # 2) Create a single hash label for each known (momID, dadID) pair - base <- max(ped$ID, na.rm = TRUE) + 1L - pairCode <- ped$momID[mask] + base * ped$dadID[mask] - - # 3) Factor that label => each row with the same (mom,dad) gets the same integer code - childVec <- which(mask) - - # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" - groupList <- split(childVec, pairCode) - - # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j - iss_list <- vector("list", length(groupList)) - jss_list <- vector("list", length(groupList)) - counter <- 1 - - for (g in groupList) { - k <- length(g) - if (k > 1) { - # We'll form all k^2 combos, then remove the diagonal i=j - # rep() calls faster than expand.grid - - # v = each child repeated k times - # w = entire group repeated once for each child - v <- rep(g, each = k) # row index - w <- rep(g, times = k) # col index - - keep <- (v != w) # remove diagonal where v == w - iss_list[[counter]] <- v[keep] - jss_list[[counter]] <- w[keep] - counter <- counter + 1 - } - } - - - iss <- unlist(iss_list, use.names = FALSE) - jss <- unlist(jss_list, use.names = FALSE) - - # list_of_adjacency <- .adjBeta(ped=ped,adjBeta_method=adjBeta_method, - # component = component, - # saveable = saveable, resume = resume, - # save_path = save_path, verbose = verbose, - # lastComputed = lastComputed, nr = nr, - # checkpoint_files = checkpoint_files, - # update_rate = update_rate, - # parList = parList, - # lens = lens, save_rate_parlist = save_rate_parlist, - # ...) - - # return(list_of_adjacency) - } else if (component %in% c("mitochondrial")) { - mIDs <- stats::na.omit(data.frame(rID = ped$ID, cID = ped$momID)) - iss <- c(mIDs$rID) - jss <- c(mIDs$cID) - } else { - stop("Unknown relatedness component requested") - } - list_of_adjacency <- list( - iss = iss, - jss = jss - ) - return(list_of_adjacency) -} - -#' Compute Parent Adjacency Matrix with Multiple Approaches -#' @inheritParams ped2com -#' @inherit ped2com details -#' @param nr the number of rows in the pedigree dataset -#' @param lastComputed the last computed index -#' @param parList a list of parent-child relationships -#' @param lens a vector of the lengths of the parent-child relationships -#' @param checkpoint_files a list of checkpoint files - -compute_parent_adjacency <- function(ped, component, - adjacency_method = "direct", - saveable, resume, - save_path, verbose = FALSE, - lastComputed = 0, nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist, adjBeta_method = NULL, - ...) { - if (adjacency_method == "loop") { - if (lastComputed < nr) { # Original version - list_of_adjacency <- .adjLoop( - ped = ped, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ... - ) - } - } else if (adjacency_method == "indexed") { # Garrison version - if (lastComputed < nr) { - list_of_adjacency <- .adjIndexed( - ped = ped, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ... - ) - } - } else if (adjacency_method == "direct") { # Hunter version - if (lastComputed < nr) { - list_of_adjacency <- .adjDirect( - ped = ped, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ... - ) - } - } else if (adjacency_method == "beta") { - list_of_adjacency <- .adjBeta( - ped = ped, - adjBeta_method = adjBeta_method, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ... - ) - } else { - stop("Invalid method specified. Choose from 'loop', 'direct', 'indexed', or beta") - } - if (saveable) { - saveRDS(parList, file = checkpoint_files$parList) - saveRDS(lens, file = checkpoint_files$lens) - if (verbose) { - cat("Final checkpoint saved for adjacency matrix.\n") - } - } - return(list_of_adjacency) -} - - -#' Determine isChild Status, isChild is the 'S' matrix from RAM -#' @param isChild_method method to determine isChild status -#' @param ped pedigree data frame -#' @return isChild 'S' matrix -#' - -isChild <- function(isChild_method, ped) { - if (isChild_method == "partialparent") { - isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) { - .5 + .25 * sum(is.na(x)) # 2 parents -> .5, 1 parent -> .75, 0 parents -> 1 - }) - } else { - isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) { - 2^(-!all(is.na(x))) - }) - } -} - - -.adjBeta <- function(ped, component, - adjBeta_method = 5, - parList = NULL, - lastComputed = 0, - nr = NULL, - lens = NULL, - saveable = FALSE, - resume = FALSE, - save_path = NULL, - verbose = FALSE, - save_rate_parlist = NULL, - update_rate = NULL, - checkpoint_files = NULL, - ...) { # 1) Pairwise compare mother IDs - if (adjBeta_method == 1) { - # gets slow when data are bigger. much slower than indexed - momMatch <- outer(ped$momID, ped$momID, FUN = "==") - momMatch[is.na(momMatch)] <- FALSE - - # 2) Pairwise compare father IDs - dadMatch <- outer(ped$dadID, ped$dadID, FUN = "==") - dadMatch[is.na(dadMatch)] <- FALSE - - # 3) Sibling adjacency if both mom & dad match - adj <- momMatch & dadMatch - - # 4) Extract indices where adj[i,j] is TRUE - w <- which(adj, arr.ind = TRUE) - # iss <- w[, 1] - # jss <- w[, 2] - # - list_of_adjacency <- list( - iss = w[, 1], - jss = w[, 2] - ) - } else if (adjBeta_method == 2) { - # 1) Create a logical mask for known parents - mask <- !is.na(ped$momID) & !is.na(ped$dadID) - - # 2) Create a single string label for each known (momID, dadID) pair - pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) - - # 3) Factor that label => each row with the same (mom,dad) gets the same integer code - # This is "creating a new ID" for each unique parent pair - pairCode <- match(pairLabel, unique(pairLabel)) - - # childVec are the row indices in 'ped' that have known parents - childVec <- which(mask) # length(childVec) = sum(mask) - - # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" - groupList <- split(childVec, pairCode) - - # 5) For each group with >1 children, form pairwise adjacency i->j - iss_list <- list() - jss_list <- list() - counter <- 1 - - for (g in groupList) { - if (length(g) > 1) { - combos <- expand.grid(g, g, KEEP.OUT.ATTRS = FALSE) - combos <- combos[combos[, 1] != combos[, 2], , drop = FALSE] - iss_list[[counter]] <- combos[, 1] - jss_list[[counter]] <- combos[, 2] - counter <- counter + 1 - } - } - # iss <- unlist(iss_list, use.names = FALSE) - # jss <- unlist(jss_list, use.names = FALSE) - - list_of_adjacency <- list( - iss = unlist(iss_list, use.names = FALSE), - jss = unlist(jss_list, use.names = FALSE) - ) - } else if (adjBeta_method == 3) { - nr <- nrow(ped) - # terrible - # Define a scalar-checking function: - f_check <- function(i, j) { - # i, j are each single integers - # Return one boolean: do they share both parents? - !is.na(ped$momID[i]) && !is.na(ped$dadID[i]) && - !is.na(ped$momID[j]) && !is.na(ped$dadID[j]) && - (ped$momID[i] == ped$momID[j]) && - (ped$dadID[i] == ped$dadID[j]) - } - - # Vectorize it so outer() will produce an nr x nr matrix - vf_check <- Vectorize(f_check) - - # Now outer() calls vf_check(...) in a way that yields scalar results - adj <- outer(seq_len(nr), seq_len(nr), FUN = vf_check) - - # Extract which cells of adj are TRUE - w <- which(adj, arr.ind = TRUE) - # iss <- w[, 1] - # jss <- w[, 2] - - list_of_adjacency <- list( - iss = iss <- w[, 1], - jss = jss <- w[, 2] - ) - } else if (adjBeta_method == 4) { - # 1) Create a logical mask for known parents - mask <- !is.na(ped$momID) & !is.na(ped$dadID) - - # 2) Create a single string label for each known (momID, dadID) pair - pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) - - # 3) Factor that label => each row with the same (mom,dad) gets the same integer code - pairCode <- match(pairLabel, unique(pairLabel)) - - # childVec are the row indices in 'ped' that have known parents - childVec <- which(mask) - - # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" - groupList <- split(childVec, pairCode) - - # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j - iss_list <- vector("list", length(groupList)) - jss_list <- vector("list", length(groupList)) - counter <- 1 - - for (g in groupList) { - k <- length(g) - if (k > 1) { - # We'll form all k^2 combos, then remove the diagonal i=j - # Instead of expand.grid, do rep() calls: - - # v = each child repeated k times - # w = entire group repeated once for each child - v <- rep(g, each = k) # row index - w <- rep(g, times = k) # col index - - keep <- (v != w) # remove diagonal where v == w - iss_list[[counter]] <- v[keep] - jss_list[[counter]] <- w[keep] - counter <- counter + 1 - } - } - - list_of_adjacency <- list( - iss = unlist(iss_list, use.names = FALSE), - jss = unlist(jss_list, use.names = FALSE) - ) - } else if (adjBeta_method == 5) { - # 1) Create a logical mask for known parents - mask <- !is.na(ped$momID) & !is.na(ped$dadID) - - # 2) Create a single hash label for each known (momID, dadID) pair - # pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) - base <- max(ped$ID, na.rm = TRUE) + 1L - pairCode <- ped$momID[mask] + base * ped$dadID[mask] - - # 3) Factor that label => each row with the same (mom,dad) gets the same integer code - childVec <- which(mask) - - # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" - groupList <- split(childVec, pairCode) - - # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j - iss_list <- vector("list", length(groupList)) - jss_list <- vector("list", length(groupList)) - counter <- 1 - - for (g in groupList) { - k <- length(g) - if (k > 1) { - # We'll form all k^2 combos, then remove the diagonal i=j - # Instead of expand.grid, do rep() calls: - - # v = each child repeated k times - # w = entire group repeated once for each child - v <- rep(g, each = k) # row index - w <- rep(g, times = k) # col index - - keep <- (v != w) # remove diagonal where v == w - iss_list[[counter]] <- v[keep] - jss_list[[counter]] <- w[keep] - counter <- counter + 1 - } - } - - list_of_adjacency <- list( - iss = unlist(iss_list, use.names = FALSE), - jss = unlist(jss_list, use.names = FALSE) - ) - } else { - list_of_adjacency <- .adjIndexed( - ped = ped, component = component, - saveable = saveable, resume = resume, - save_path = save_path, verbose = verbose, - lastComputed = lastComputed, nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, parList = parList, - lens = lens, save_rate_parlist = save_rate_parlist - ) - } - return(list_of_adjacency) -} diff --git a/R/constructAdjacency.R b/R/constructAdjacency.R new file mode 100644 index 00000000..cc3a4e7f --- /dev/null +++ b/R/constructAdjacency.R @@ -0,0 +1,529 @@ + +.adjLoop <- function(ped, component, saveable, resume, + save_path, verbose, lastComputed, + nr, checkpoint_files, update_rate, + parList, lens, save_rate_parlist, + ...) { + # Loop through each individual in the pedigree + # Build the adjacency matrix for parent-child relationships + # Is person in column j the parent of the person in row i? .5 for yes, 0 for no. + ped$momID <- as.numeric(ped$momID) + ped$dadID <- as.numeric(ped$dadID) + ped$ID <- as.numeric(ped$ID) + + for (i in (lastComputed + 1):nr) { + x <- ped[i, , drop = FALSE] + # Handle parentage according to the 'component' specified + if (component %in% c("generation", "additive")) { + # Code for 'generation' and 'additive' components + # Checks if is mom of ID or is dad of ID + xID <- as.numeric(x["ID"]) + sMom <- (xID == ped$momID) + sDad <- (xID == ped$dadID) + val <- sMom | sDad + val[is.na(val)] <- FALSE + } else if (component %in% c("common nuclear")) { + # Code for 'common nuclear' component + # IDs have the Same mom and Same dad + sMom <- (as.numeric(x["momID"]) == ped$momID) + sMom[is.na(sMom)] <- FALSE + sDad <- (as.numeric(x["dadID"]) == ped$dadID) + sDad[is.na(sDad)] <- FALSE + val <- sMom & sDad + } else if (component %in% c("mitochondrial")) { + # Code for 'mitochondrial' component + val <- (as.numeric(x["ID"]) == ped$momID) + val[is.na(val)] <- FALSE + } else { + stop("Unknown relatedness component requested") + } + # Storing the indices of the parent-child relationships + # Keep track of indices only, and then initialize a single sparse matrix + wv <- which(val) + parList[[i]] <- wv + lens[i] <- length(wv) + # Print progress if verbose is TRUE + if (verbose && (i %% update_rate == 0)) { + cat(paste0("Done with ", i, " of ", nr, "\n")) + } + # Checkpointing every save_rate iterations + if (saveable && (i %% save_rate_parlist == 0)) { + saveRDS(parList, file = checkpoint_files$parList) + saveRDS(lens, file = checkpoint_files$lens) + if (verbose) cat("Checkpointed parlist saved at iteration", i, "\n") + } + } + jss <- rep(1L:nr, times = lens) + iss <- unlist(parList) + list_of_adjacency <- list(iss = iss, jss = jss) + return(list_of_adjacency) +} + +.adjIndexed <- function(ped, component, saveable, resume, + save_path, verbose, lastComputed, + nr, checkpoint_files, update_rate, + parList, lens, save_rate_parlist) { + # Loop through each individual in the pedigree + # Build the adjacency matrix for parent-child relationships + # Is person in column j the parent of the person in row i? .5 for yes, 0 for no. + + # Convert IDs + ped$ID <- as.numeric(ped$ID) + ped$momID <- as.numeric(ped$momID) + ped$dadID <- as.numeric(ped$dadID) + + # parent-child lookup + mom_index <- match(ped$momID, ped$ID, nomatch = 0) + dad_index <- match(ped$dadID, ped$ID, nomatch = 0) + + for (i in (lastComputed + 1):nr) { + if (component %in% c("generation", "additive")) { + sMom <- (mom_index == i) + sDad <- (dad_index == i) + val <- sMom | sDad + } else if (component %in% c("common nuclear")) { + # Code for 'common nuclear' component + # IDs have the Same mom and Same dad + sMom <- (ped$momID[i] == ped$momID) + sMom[is.na(sMom)] <- FALSE + sDad <- (ped$dadID[i] == ped$dadID) + sDad[is.na(sDad)] <- FALSE + val <- sMom & sDad + } else if (component %in% c("mitochondrial")) { + val <- (mom_index == i) + } else { + stop("Unknown relatedness component requested") + } + + val[is.na(val)] <- FALSE + parList[[i]] <- which(val) + lens[i] <- length(parList[[i]]) + + # Print progress if verbose is TRUE + if (verbose && (i %% update_rate == 0)) { + cat(paste0("Done with ", i, " of ", nr, "\n")) + } + + # Checkpointing every save_rate iterations + if (saveable && (i %% save_rate_parlist == 0)) { + saveRDS(parList, file = checkpoint_files$parList) + saveRDS(lens, file = checkpoint_files$lens) + if (verbose) cat("Checkpointed parlist saved at iteration", i, "\n") + } + } + jss <- rep(1L:nr, times = lens) + iss <- unlist(parList) + list_of_adjacency <- list(iss = iss, jss = jss) + return(list_of_adjacency) +} + +.adjDirect <- function(ped, component, saveable, resume, + save_path, verbose, lastComputed, + nr, checkpoint_files, update_rate, + parList, lens, save_rate_parlist, adjBeta_method, + ...) { + # Loop through each individual in the pedigree + # Build the adjacency matrix for parent-child relationships + # Is person in column j the parent of the person in row i? .5 for yes, 0 for no. + uniID <- ped$ID # live dangerously without sort(unique(ped$ID)) + ped$ID <- as.numeric(factor(ped$ID, levels = uniID)) + ped$momID <- as.numeric(factor(ped$momID, levels = uniID)) + ped$dadID <- as.numeric(factor(ped$dadID, levels = uniID)) + + if (component %in% c("generation", "additive")) { + mIDs <- stats::na.omit(data.frame(rID = ped$ID, cID = ped$momID)) + dIDs <- stats::na.omit(data.frame(rID = ped$ID, cID = ped$dadID)) + iss <- c(mIDs$rID, dIDs$rID) + jss <- c(mIDs$cID, dIDs$cID) + } else if (component %in% c("common nuclear")) { + # message("Common Nuclear component is not yet implemented for direct method. Using index method.\n") + + # 1) Create a logical mask for only known parents + mask <- !is.na(ped$momID) & !is.na(ped$dadID) + + # 2) Create a single hash label for each known (momID, dadID) pair + base <- max(ped$ID, na.rm = TRUE) + 1L + pairCode <- ped$momID[mask] + base * ped$dadID[mask] + + # 3) Factor that label => each row with the same (mom,dad) gets the same integer code + childVec <- which(mask) + + # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" + groupList <- split(childVec, pairCode) + + # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j + iss_list <- vector("list", length(groupList)) + jss_list <- vector("list", length(groupList)) + counter <- 1 + + for (g in groupList) { + k <- length(g) + if (k > 1) { + # We'll form all k^2 combos, then remove the diagonal i=j + # rep() calls faster than expand.grid + + # v = each child repeated k times + # w = entire group repeated once for each child + v <- rep(g, each = k) # row index + w <- rep(g, times = k) # col index + + keep <- (v != w) # remove diagonal where v == w + iss_list[[counter]] <- v[keep] + jss_list[[counter]] <- w[keep] + counter <- counter + 1 + } + } + + + iss <- unlist(iss_list, use.names = FALSE) + jss <- unlist(jss_list, use.names = FALSE) + + # list_of_adjacency <- .adjBeta(ped=ped,adjBeta_method=adjBeta_method, + # component = component, + # saveable = saveable, resume = resume, + # save_path = save_path, verbose = verbose, + # lastComputed = lastComputed, nr = nr, + # checkpoint_files = checkpoint_files, + # update_rate = update_rate, + # parList = parList, + # lens = lens, save_rate_parlist = save_rate_parlist, + # ...) + + # return(list_of_adjacency) + } else if (component %in% c("mitochondrial")) { + mIDs <- stats::na.omit(data.frame(rID = ped$ID, cID = ped$momID)) + iss <- c(mIDs$rID) + jss <- c(mIDs$cID) + } else { + stop("Unknown relatedness component requested") + } + list_of_adjacency <- list( + iss = iss, + jss = jss + ) + return(list_of_adjacency) +} + +#' Compute Parent Adjacency Matrix with Multiple Approaches +#' @inheritParams ped2com +#' @inherit ped2com details +#' @param nr the number of rows in the pedigree dataset +#' @param lastComputed the last computed index +#' @param parList a list of parent-child relationships +#' @param lens a vector of the lengths of the parent-child relationships +#' @param checkpoint_files a list of checkpoint files + +compute_parent_adjacency <- function(ped, component, + adjacency_method = "direct", + saveable, resume, + save_path, verbose = FALSE, + lastComputed = 0, nr, checkpoint_files, update_rate, + parList, lens, save_rate_parlist, adjBeta_method = NULL, + ...) { + if (adjacency_method == "loop") { + if (lastComputed < nr) { # Original version + list_of_adjacency <- .adjLoop( + ped = ped, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) + } + } else if (adjacency_method == "indexed") { # Garrison version + if (lastComputed < nr) { + list_of_adjacency <- .adjIndexed( + ped = ped, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) + } + } else if (adjacency_method == "direct") { # Hunter version + if (lastComputed < nr) { + list_of_adjacency <- .adjDirect( + ped = ped, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) + } + } else if (adjacency_method == "beta") { + list_of_adjacency <- .adjBeta( + ped = ped, + adjBeta_method = adjBeta_method, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) + } else { + stop("Invalid method specified. Choose from 'loop', 'direct', 'indexed', or beta") + } + if (saveable) { + saveRDS(parList, file = checkpoint_files$parList) + saveRDS(lens, file = checkpoint_files$lens) + if (verbose) { + cat("Final checkpoint saved for adjacency matrix.\n") + } + } + return(list_of_adjacency) +} + + +#' Determine isChild Status, isChild is the 'S' matrix from RAM +#' @param isChild_method method to determine isChild status +#' @param ped pedigree data frame +#' @return isChild 'S' matrix +#' + +isChild <- function(isChild_method, ped) { + if (isChild_method == "partialparent") { + isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) { + .5 + .25 * sum(is.na(x)) # 2 parents -> .5, 1 parent -> .75, 0 parents -> 1 + }) + } else { + isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) { + 2^(-!all(is.na(x))) + }) + } +} + + +.adjBeta <- function(ped, component, + adjBeta_method = 5, + parList = NULL, + lastComputed = 0, + nr = NULL, + lens = NULL, + saveable = FALSE, + resume = FALSE, + save_path = NULL, + verbose = FALSE, + save_rate_parlist = NULL, + update_rate = NULL, + checkpoint_files = NULL, + ...) { # 1) Pairwise compare mother IDs + if (adjBeta_method == 1) { + # gets slow when data are bigger. much slower than indexed + momMatch <- outer(ped$momID, ped$momID, FUN = "==") + momMatch[is.na(momMatch)] <- FALSE + + # 2) Pairwise compare father IDs + dadMatch <- outer(ped$dadID, ped$dadID, FUN = "==") + dadMatch[is.na(dadMatch)] <- FALSE + + # 3) Sibling adjacency if both mom & dad match + adj <- momMatch & dadMatch + + # 4) Extract indices where adj[i,j] is TRUE + w <- which(adj, arr.ind = TRUE) + # iss <- w[, 1] + # jss <- w[, 2] + # + list_of_adjacency <- list( + iss = w[, 1], + jss = w[, 2] + ) + } else if (adjBeta_method == 2) { + # 1) Create a logical mask for known parents + mask <- !is.na(ped$momID) & !is.na(ped$dadID) + + # 2) Create a single string label for each known (momID, dadID) pair + pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) + + # 3) Factor that label => each row with the same (mom,dad) gets the same integer code + # This is "creating a new ID" for each unique parent pair + pairCode <- match(pairLabel, unique(pairLabel)) + + # childVec are the row indices in 'ped' that have known parents + childVec <- which(mask) # length(childVec) = sum(mask) + + # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" + groupList <- split(childVec, pairCode) + + # 5) For each group with >1 children, form pairwise adjacency i->j + iss_list <- list() + jss_list <- list() + counter <- 1 + + for (g in groupList) { + if (length(g) > 1) { + combos <- expand.grid(g, g, KEEP.OUT.ATTRS = FALSE) + combos <- combos[combos[, 1] != combos[, 2], , drop = FALSE] + iss_list[[counter]] <- combos[, 1] + jss_list[[counter]] <- combos[, 2] + counter <- counter + 1 + } + } + # iss <- unlist(iss_list, use.names = FALSE) + # jss <- unlist(jss_list, use.names = FALSE) + + list_of_adjacency <- list( + iss = unlist(iss_list, use.names = FALSE), + jss = unlist(jss_list, use.names = FALSE) + ) + } else if (adjBeta_method == 3) { + nr <- nrow(ped) + # terrible + # Define a scalar-checking function: + f_check <- function(i, j) { + # i, j are each single integers + # Return one boolean: do they share both parents? + !is.na(ped$momID[i]) && !is.na(ped$dadID[i]) && + !is.na(ped$momID[j]) && !is.na(ped$dadID[j]) && + (ped$momID[i] == ped$momID[j]) && + (ped$dadID[i] == ped$dadID[j]) + } + + # Vectorize it so outer() will produce an nr x nr matrix + vf_check <- Vectorize(f_check) + + # Now outer() calls vf_check(...) in a way that yields scalar results + adj <- outer(seq_len(nr), seq_len(nr), FUN = vf_check) + + # Extract which cells of adj are TRUE + w <- which(adj, arr.ind = TRUE) + # iss <- w[, 1] + # jss <- w[, 2] + + list_of_adjacency <- list( + iss = iss <- w[, 1], + jss = jss <- w[, 2] + ) + } else if (adjBeta_method == 4) { + # 1) Create a logical mask for known parents + mask <- !is.na(ped$momID) & !is.na(ped$dadID) + + # 2) Create a single string label for each known (momID, dadID) pair + pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) + + # 3) Factor that label => each row with the same (mom,dad) gets the same integer code + pairCode <- match(pairLabel, unique(pairLabel)) + + # childVec are the row indices in 'ped' that have known parents + childVec <- which(mask) + + # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" + groupList <- split(childVec, pairCode) + + # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j + iss_list <- vector("list", length(groupList)) + jss_list <- vector("list", length(groupList)) + counter <- 1 + + for (g in groupList) { + k <- length(g) + if (k > 1) { + # We'll form all k^2 combos, then remove the diagonal i=j + # Instead of expand.grid, do rep() calls: + + # v = each child repeated k times + # w = entire group repeated once for each child + v <- rep(g, each = k) # row index + w <- rep(g, times = k) # col index + + keep <- (v != w) # remove diagonal where v == w + iss_list[[counter]] <- v[keep] + jss_list[[counter]] <- w[keep] + counter <- counter + 1 + } + } + + list_of_adjacency <- list( + iss = unlist(iss_list, use.names = FALSE), + jss = unlist(jss_list, use.names = FALSE) + ) + } else if (adjBeta_method == 5) { + # 1) Create a logical mask for known parents + mask <- !is.na(ped$momID) & !is.na(ped$dadID) + + # 2) Create a single hash label for each known (momID, dadID) pair + # pairLabel <- paste0(ped$momID[mask], "_", ped$dadID[mask]) + base <- max(ped$ID, na.rm = TRUE) + 1L + pairCode <- ped$momID[mask] + base * ped$dadID[mask] + + # 3) Factor that label => each row with the same (mom,dad) gets the same integer code + childVec <- which(mask) + + # 4) Group children by pairCode, so each group is "all children with that (mom,dad)" + groupList <- split(childVec, pairCode) + + # 5) For each group with >1 children, form pairwise adjacency (i->j) for i != j + iss_list <- vector("list", length(groupList)) + jss_list <- vector("list", length(groupList)) + counter <- 1 + + for (g in groupList) { + k <- length(g) + if (k > 1) { + # We'll form all k^2 combos, then remove the diagonal i=j + # Instead of expand.grid, do rep() calls: + + # v = each child repeated k times + # w = entire group repeated once for each child + v <- rep(g, each = k) # row index + w <- rep(g, times = k) # col index + + keep <- (v != w) # remove diagonal where v == w + iss_list[[counter]] <- v[keep] + jss_list[[counter]] <- w[keep] + counter <- counter + 1 + } + } + + list_of_adjacency <- list( + iss = unlist(iss_list, use.names = FALSE), + jss = unlist(jss_list, use.names = FALSE) + ) + } else { + list_of_adjacency <- .adjIndexed( + ped = ped, component = component, + saveable = saveable, resume = resume, + save_path = save_path, verbose = verbose, + lastComputed = lastComputed, nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, parList = parList, + lens = lens, save_rate_parlist = save_rate_parlist + ) + } + return(list_of_adjacency) +} From 75b9b4e2b3f09cd75d55b0cd6175e602d736715a Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 21 Apr 2025 16:45:08 -0400 Subject: [PATCH 56/69] renamed --- .gitignore | 1 + NAMESPACE | 1 + NEWS.md | 1 + R/buildComponent.R | 2 +- R/constructAdjacency.R | 255 ++++---- ...adjacency.Rd => computeParentAdjacency.Rd} | 10 +- man/dot-computeTranspose.Rd | 2 +- man/isChild.Rd | 2 +- man/ped2add.Rd | 2 +- man/ped2ce.Rd | 2 +- man/ped2cn.Rd | 2 +- man/ped2com.Rd | 2 +- man/ped2fam.Rd | 2 +- man/ped2graph.Rd | 2 +- man/ped2maternal.Rd | 2 +- man/ped2mit.Rd | 2 +- man/ped2paternal.Rd | 2 +- vignettes/modelingvariancecomponents.html | 554 ++++++++++++++++++ 18 files changed, 707 insertions(+), 139 deletions(-) rename man/{compute_parent_adjacency.Rd => computeParentAdjacency.Rd} (90%) create mode 100644 vignettes/modelingvariancecomponents.html diff --git a/.gitignore b/.gitignore index 5f04620b..22835dfa 100644 --- a/.gitignore +++ b/.gitignore @@ -19,3 +19,4 @@ dataRelatedPairs_new2.csv paper/paper.html tests/testthat/Rplots.pdf vignettes/articles/paper.html +.vscode/settings.json diff --git a/NAMESPACE b/NAMESPACE index b5cff75a..879d7895 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,7 @@ export(checkPedigreeNetwork) export(checkSex) export(com2links) export(comp2vech) +export(computeParentAdjacency) export(createGenDataFrame) export(dropLink) export(evenInsert) diff --git a/NEWS.md b/NEWS.md index c0daa9a2..7693f0eb 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,6 +7,7 @@ * list SimPed and related_coef as aliases for functions * harmonizing function names like calcFamilySize from famSizeCal * implemented adjBeta function to evaluation alternative build method +* reorganize file names to be more consistent # BGmisc 1.3.5.1 * Setting the default for the `sparse` argument in `ped2com()` to TRUE diff --git a/R/buildComponent.R b/R/buildComponent.R index dda09f1f..a920207f 100644 --- a/R/buildComponent.R +++ b/R/buildComponent.R @@ -148,7 +148,7 @@ ped2com <- function(ped, component, iss <- readRDS(checkpoint_files$iss) list_of_adjacencies <- list(iss = iss, jss = jss) } else { - list_of_adjacencies <- compute_parent_adjacency( + list_of_adjacencies <- computeParentAdjacency( ped = ped, save_rate_parlist = save_rate_parlist, checkpoint_files = checkpoint_files, diff --git a/R/constructAdjacency.R b/R/constructAdjacency.R index cc3a4e7f..d0dcdd71 100644 --- a/R/constructAdjacency.R +++ b/R/constructAdjacency.R @@ -204,128 +204,6 @@ return(list_of_adjacency) } -#' Compute Parent Adjacency Matrix with Multiple Approaches -#' @inheritParams ped2com -#' @inherit ped2com details -#' @param nr the number of rows in the pedigree dataset -#' @param lastComputed the last computed index -#' @param parList a list of parent-child relationships -#' @param lens a vector of the lengths of the parent-child relationships -#' @param checkpoint_files a list of checkpoint files - -compute_parent_adjacency <- function(ped, component, - adjacency_method = "direct", - saveable, resume, - save_path, verbose = FALSE, - lastComputed = 0, nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist, adjBeta_method = NULL, - ...) { - if (adjacency_method == "loop") { - if (lastComputed < nr) { # Original version - list_of_adjacency <- .adjLoop( - ped = ped, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ... - ) - } - } else if (adjacency_method == "indexed") { # Garrison version - if (lastComputed < nr) { - list_of_adjacency <- .adjIndexed( - ped = ped, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ... - ) - } - } else if (adjacency_method == "direct") { # Hunter version - if (lastComputed < nr) { - list_of_adjacency <- .adjDirect( - ped = ped, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ... - ) - } - } else if (adjacency_method == "beta") { - list_of_adjacency <- .adjBeta( - ped = ped, - adjBeta_method = adjBeta_method, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ... - ) - } else { - stop("Invalid method specified. Choose from 'loop', 'direct', 'indexed', or beta") - } - if (saveable) { - saveRDS(parList, file = checkpoint_files$parList) - saveRDS(lens, file = checkpoint_files$lens) - if (verbose) { - cat("Final checkpoint saved for adjacency matrix.\n") - } - } - return(list_of_adjacency) -} - - -#' Determine isChild Status, isChild is the 'S' matrix from RAM -#' @param isChild_method method to determine isChild status -#' @param ped pedigree data frame -#' @return isChild 'S' matrix -#' - -isChild <- function(isChild_method, ped) { - if (isChild_method == "partialparent") { - isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) { - .5 + .25 * sum(is.na(x)) # 2 parents -> .5, 1 parent -> .75, 0 parents -> 1 - }) - } else { - isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) { - 2^(-!all(is.na(x))) - }) - } -} .adjBeta <- function(ped, component, @@ -527,3 +405,136 @@ isChild <- function(isChild_method, ped) { } return(list_of_adjacency) } + + + + + +#' Compute Parent Adjacency Matrix with Multiple Approaches +#' @inheritParams ped2com +#' @inherit ped2com details +#' @param nr the number of rows in the pedigree dataset +#' @param lastComputed the last computed index +#' @param parList a list of parent-child relationships +#' @param lens a vector of the lengths of the parent-child relationships +#' @param checkpoint_files a list of checkpoint files +#' @param update_rate the rate at which to update the progress +#' +#' @export +computeParentAdjacency <- function(ped, component, + adjacency_method = "direct", + saveable, resume, + save_path, + verbose = FALSE, + lastComputed = 0, nr, + checkpoint_files, + update_rate, + parList, lens, save_rate_parlist, + adjBeta_method = NULL, + ...) { + if (adjacency_method == "loop") { + if (lastComputed < nr) { # Original version + list_of_adjacency <- .adjLoop( + ped = ped, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) + } + } else if (adjacency_method == "indexed") { # Garrison version + if (lastComputed < nr) { + list_of_adjacency <- .adjIndexed( + ped = ped, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) + } + } else if (adjacency_method == "direct") { # Hunter version + if (lastComputed < nr) { + list_of_adjacency <- .adjDirect( + ped = ped, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) + } + } else if (adjacency_method == "beta") { + list_of_adjacency <- .adjBeta( + ped = ped, + adjBeta_method = adjBeta_method, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) + } else { + stop("Invalid method specified. Choose from 'loop', 'direct', 'indexed', or beta") + } + if (saveable) { + saveRDS(parList, file = checkpoint_files$parList) + saveRDS(lens, file = checkpoint_files$lens) + if (verbose) { + cat("Final checkpoint saved for adjacency matrix.\n") + } + } + return(list_of_adjacency) +} + + +#' Determine isChild Status, isChild is the 'S' matrix from RAM +#' @param isChild_method method to determine isChild status +#' @param ped pedigree data frame +#' @return isChild 'S' matrix +#' + +isChild <- function(isChild_method, ped) { + if (isChild_method == "partialparent") { + isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) { + .5 + .25 * sum(is.na(x)) # 2 parents -> .5, 1 parent -> .75, 0 parents -> 1 + }) + } else { + isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) { + 2^(-!all(is.na(x))) + }) + } +} diff --git a/man/compute_parent_adjacency.Rd b/man/computeParentAdjacency.Rd similarity index 90% rename from man/compute_parent_adjacency.Rd rename to man/computeParentAdjacency.Rd index f6364808..353a655a 100644 --- a/man/compute_parent_adjacency.Rd +++ b/man/computeParentAdjacency.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/convertPedigree.R -\name{compute_parent_adjacency} -\alias{compute_parent_adjacency} +% Please edit documentation in R/constructAdjacency.R +\name{computeParentAdjacency} +\alias{computeParentAdjacency} \title{Compute Parent Adjacency Matrix with Multiple Approaches} \usage{ -compute_parent_adjacency( +computeParentAdjacency( ped, component, adjacency_method = "direct", @@ -44,7 +44,7 @@ compute_parent_adjacency( \item{checkpoint_files}{a list of checkpoint files} -\item{update_rate}{numeric. The rate at which to print progress} +\item{update_rate}{the rate at which to update the progress} \item{parList}{a list of parent-child relationships} diff --git a/man/dot-computeTranspose.Rd b/man/dot-computeTranspose.Rd index 38c8fa82..4d90dcbc 100644 --- a/man/dot-computeTranspose.Rd +++ b/man/dot-computeTranspose.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/convertPedigree.R +% Please edit documentation in R/buildComponent.R \name{.computeTranspose} \alias{.computeTranspose} \title{Compute the transpose multiplication for the relatedness matrix} diff --git a/man/isChild.Rd b/man/isChild.Rd index 1bd6f1e9..be64125d 100644 --- a/man/isChild.Rd +++ b/man/isChild.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/convertPedigree.R +% Please edit documentation in R/constructAdjacency.R \name{isChild} \alias{isChild} \title{Determine isChild Status, isChild is the 'S' matrix from RAM} diff --git a/man/ped2add.Rd b/man/ped2add.Rd index c2179e99..c3949c68 100644 --- a/man/ped2add.Rd +++ b/man/ped2add.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/convertPedigree.R +% Please edit documentation in R/buildComponent.R \name{ped2add} \alias{ped2add} \title{Take a pedigree and turn it into an additive genetics relatedness matrix} diff --git a/man/ped2ce.Rd b/man/ped2ce.Rd index b4e3db1d..ed22966a 100644 --- a/man/ped2ce.Rd +++ b/man/ped2ce.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/convertPedigree.R +% Please edit documentation in R/buildComponent.R \name{ped2ce} \alias{ped2ce} \title{Take a pedigree and turn it into an extended environmental relatedness matrix} diff --git a/man/ped2cn.Rd b/man/ped2cn.Rd index c738d13b..3178cab6 100644 --- a/man/ped2cn.Rd +++ b/man/ped2cn.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/convertPedigree.R +% Please edit documentation in R/buildComponent.R \name{ped2cn} \alias{ped2cn} \title{Take a pedigree and turn it into a common nuclear environmental relatedness matrix} diff --git a/man/ped2com.Rd b/man/ped2com.Rd index 58c0fc47..b49a6b03 100644 --- a/man/ped2com.Rd +++ b/man/ped2com.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/convertPedigree.R +% Please edit documentation in R/buildComponent.R \name{ped2com} \alias{ped2com} \title{Take a pedigree and turn it into a relatedness matrix} diff --git a/man/ped2fam.Rd b/man/ped2fam.Rd index 2ff7eb0d..3052e568 100644 --- a/man/ped2fam.Rd +++ b/man/ped2fam.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/buildPedigree.R +% Please edit documentation in R/segmentPedigree.R \name{ped2fam} \alias{ped2fam} \title{Segment Pedigree into Extended Families} diff --git a/man/ped2graph.Rd b/man/ped2graph.Rd index 13c191d7..5e7ac7b1 100755 --- a/man/ped2graph.Rd +++ b/man/ped2graph.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/buildPedigree.R +% Please edit documentation in R/segmentPedigree.R \name{ped2graph} \alias{ped2graph} \title{Turn a pedigree into a graph} diff --git a/man/ped2maternal.Rd b/man/ped2maternal.Rd index e54c3e76..03e02311 100755 --- a/man/ped2maternal.Rd +++ b/man/ped2maternal.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/buildPedigree.R +% Please edit documentation in R/segmentPedigree.R \name{ped2maternal} \alias{ped2maternal} \title{Add a maternal line ID variable to a pedigree} diff --git a/man/ped2mit.Rd b/man/ped2mit.Rd index c19e9ba7..2c7dbcb1 100644 --- a/man/ped2mit.Rd +++ b/man/ped2mit.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/convertPedigree.R +% Please edit documentation in R/buildComponent.R \name{ped2mit} \alias{ped2mit} \alias{ped2mt} diff --git a/man/ped2paternal.Rd b/man/ped2paternal.Rd index 16a9e35a..e893ec03 100755 --- a/man/ped2paternal.Rd +++ b/man/ped2paternal.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/buildPedigree.R +% Please edit documentation in R/segmentPedigree.R \name{ped2paternal} \alias{ped2paternal} \title{Add a paternal line ID variable to a pedigree} diff --git a/vignettes/modelingvariancecomponents.html b/vignettes/modelingvariancecomponents.html new file mode 100644 index 00000000..7b5df889 --- /dev/null +++ b/vignettes/modelingvariancecomponents.html @@ -0,0 +1,554 @@ + + + + + + + + + + + + + + +Modeling variance components + + + + + + + + + + + + + + + + + + + + + + + + + + +

Modeling variance components

+ + + +
+

Introduction

+

This vignette provides a detailed guide to specific functions within +the BGmisc package that aid in the identification and +fitting of variance component models common in behavior genetics. We +will explore key functions such as identifyComponentModel, +providing practical examples and theoretical background. Identification +ensures a unique set of parameters that define the model-implied +covariance matrix, preventing free parameters from trading off one +another.

+
+

Loading Required Libraries

+

Ensure that the BGmisc package is installed and +loaded.

+

Ensure that the following dependencies are installed before +proceeding as they provide us with behavior genetic data and models:

+
    +

  • EasyMx

    • +

  • OpenMx

    • +
+
library(BGmisc)
+library(EasyMx)
+library(OpenMx)
+

Note: If any of the libraries are not installed, you can install them +using install.packages(“package_name”).

+
+
+
+

Working with Variance Component Models

+

In this section, we will demonstrate core functions related to the +identification and fitting of variance component models.

+
+

Using comp2vech Function

+

The comp2vech function is used to vectorize a components +model. The function is often used in conjunction with the identification +process. In this example, we apply it to a list of matrices:

+
comp2vech(list(
+  matrix(c(1, .5, .5, 1), 2, 2),
+  matrix(1, 2, 2)
+))
+#> [1] 1.0 0.5 1.0 1.0 1.0 1.0
+

The result showcases how the matrices have been transformed, +reflecting their role in subsequent variance component analysis.

+
+
+

Using identifyComponentModel Function

+

The identifyComponentModel function helps determine if a +variance components model is identified. It accepts relatedness +component matrices and returns information about identified and +non-identified parameters.

+

Here’s an example using the classical twin model with only MZ +twins:

+
identifyComponentModel(
+  A = list(matrix(1, 2, 2)),
+  C = list(matrix(1, 2, 2)),
+  E = diag(1, 2)
+)
+#> Component model is not identified.
+#> Non-identified parameters are  A, C
+#> $identified
+#> [1] FALSE
+#> 
+#> $nidp
+#> [1] "A" "C"
+

As you can see, the model is not identified. We need to add an +additional group so that we have sufficient information. Let us add the +rest of the classical twin model, in this case DZ twins.

+
identifyComponentModel(
+  A = list(matrix(c(1, .5, .5, 1), 2, 2), matrix(1, 2, 2)),
+  C = list(matrix(1, 2, 2), matrix(1, 2, 2)),
+  E = diag(1, 4)
+)
+#> Component model is identified.
+#> $identified
+#> [1] TRUE
+#> 
+#> $nidp
+#> character(0)
+

As you can see the model is identified, now that we’ve added another +group. Let us confirm by fitting a model. First we prepare the data.

+
require(dplyr)
+#> Loading required package: dplyr
+#> 
+#> Attaching package: 'dplyr'
+#> The following objects are masked from 'package:BGmisc':
+#> 
+#>     between, first, last
+#> The following objects are masked from 'package:stats':
+#> 
+#>     filter, lag
+#> The following objects are masked from 'package:base':
+#> 
+#>     intersect, setdiff, setequal, union
+# require(purrr)
+
+data(twinData, package = "OpenMx")
+selVars <- c("ht1", "ht2")
+
+mzdzData <- subset(
+  twinData, zyg %in% c(1, 3),
+  c(selVars, "zyg")
+)
+
+mzdzData$RCoef <- c(1, NA, .5)[mzdzData$zyg]
+
+
+mzData <- mzdzData %>% filter(zyg == 1)
+

Let us fit the data with MZ twins by themselves.

+
run1 <- emxTwinModel(
+  model = "Cholesky",
+  relatedness = "RCoef",
+  data = mzData,
+  use = selVars,
+  run = TRUE, name = "TwCh"
+)
+#> Running TwCh with 4 parameters
+#> Warning: In model 'TwCh' Optimizer returned a non-zero status code 5. The
+#> Hessian at the solution does not appear to be convex. See
+#> ?mxCheckIdentification for possible diagnosis (Mx status RED).
+
+summary(run1)
+#> Summary of TwCh 
+#>  
+#> The Hessian at the solution does not appear to be convex. See ?mxCheckIdentification for possible diagnosis (Mx status RED). 
+#>  
+#> free parameters:
+#>      name matrix row col   Estimate    Std.Error A lbound ubound
+#> 1 sqrtA11  sqrtA   1   1 0.05122646           NA    1e-06       
+#> 2 sqrtC11  sqrtC   1   1 0.03518629           NA       0!       
+#> 3 sqrtE11  sqrtE   1   1 0.02325722 0.0007017955 !     0!       
+#> 4    Mht1  Means ht1   1 1.62974908 0.0027023907                
+#> 
+#> Model Statistics: 
+#>                |  Parameters  |  Degrees of Freedom  |  Fit (-2lnL units)
+#>        Model:              4                   1112             -3693.148
+#>    Saturated:              5                   1111                    NA
+#> Independence:              4                   1112                    NA
+#> Number of observations/statistics: 569/1116
+#> 
+#> 
+#> ** Information matrix is not positive definite (not at a candidate optimum).
+#>   Be suspicious of these results. At minimum, do not trust the standard errors.
+#> 
+#> Information Criteria: 
+#>       |  df Penalty  |  Parameters Penalty  |  Sample-Size Adjusted
+#> AIC:      -5917.148              -3685.148                -3685.078
+#> BIC:     -10747.543              -3667.773                -3680.471
+#> To get additional fit indices, see help(mxRefModels)
+#> timestamp: 2025-04-21 16:43:57 
+#> Wall clock time: 0.04138112 secs 
+#> optimizer:  SLSQP 
+#> OpenMx version number: 2.21.13 
+#> Need help?  See help(mxSummary)
+

As you can see the model was unsuccessful because it was not +identified. But when we add another group, so that the model is +identified, the model now fits.

+
run2 <- emxTwinModel(
+  model = "Cholesky",
+  relatedness = "RCoef",
+  data = mzdzData,
+  use = selVars,
+  run = TRUE, name = "TwCh"
+)
+#> Running TwCh with 4 parameters
+
+summary(run2)
+#> Summary of TwCh 
+#>  
+#> free parameters:
+#>      name matrix row col   Estimate    Std.Error A lbound ubound
+#> 1 sqrtA11  sqrtA   1   1 0.06339271 0.0014377690    1e-06       
+#> 2 sqrtC11  sqrtC   1   1 0.00000100 0.0250260004 !     0!       
+#> 3 sqrtE11  sqrtE   1   1 0.02330040 0.0007015267       0!       
+#> 4    Mht1  Means ht1   1 1.63295540 0.0020511844                
+#> 
+#> Model Statistics: 
+#>                |  Parameters  |  Degrees of Freedom  |  Fit (-2lnL units)
+#>        Model:              4                   1803             -5507.092
+#>    Saturated:              5                   1802                    NA
+#> Independence:              4                   1803                    NA
+#> Number of observations/statistics: 920/1807
+#> 
+#> Information Criteria: 
+#>       |  df Penalty  |  Parameters Penalty  |  Sample-Size Adjusted
+#> AIC:      -9113.092              -5499.092                -5499.048
+#> BIC:     -17811.437              -5479.794                -5492.498
+#> To get additional fit indices, see help(mxRefModels)
+#> timestamp: 2025-04-21 16:43:57 
+#> Wall clock time: 0.03366184 secs 
+#> optimizer:  SLSQP 
+#> OpenMx version number: 2.21.13 
+#> Need help?  See help(mxSummary)
+
+
+ + + + + + + + + + + From fd71877e195ab1d3b495421e51f20a454301d8c7 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 21 Apr 2025 17:06:30 -0400 Subject: [PATCH 57/69] switch --- R/buildComponent.R | 42 +++++-- R/constructAdjacency.R | 180 +++++++++++++++-------------- tests/testthat/test-readWikiTree.R | 12 +- 3 files changed, 131 insertions(+), 103 deletions(-) diff --git a/R/buildComponent.R b/R/buildComponent.R index a920207f..b57e90dc 100644 --- a/R/buildComponent.R +++ b/R/buildComponent.R @@ -467,18 +467,38 @@ ped2ce <- function(ped, #' @param r2 a relatedness matrix #' .computeTranspose <- function(r2, transpose_method = "tcrossprod", verbose = FALSE) { - if (!transpose_method %in% c("tcrossprod", "crossprod", "star", "tcross.alt.crossprod", "tcross.alt.star")) { - stop("Invalid method specified. Choose from 'tcrossprod', 'crossprod', or 'star'.") + valid_methods <- c("tcrossprod", "crossprod", "star", + "tcross.alt.crossprod", "tcross.alt.star") + if (!transpose_method %in% valid_methods) { + stop("Invalid method specified. Choose from 'tcrossprod', 'crossprod', 'star', 'tcross.alt.crossprod', or 'tcross.alt.star'.") } - if (transpose_method %in% c("crossprod", "tcross.alt.crossprod")) { - if (verbose) cat("Doing alt tcrossprod crossprod t \n") - return(crossprod(t(as.matrix(r2)))) - } else if (transpose_method %in% c("star", "tcross.alt.star")) { - if (verbose) cat("Doing alt tcrossprod %*% t \n") - return(r2 %*% t(as.matrix(r2))) + + # Map aliases to core methods + alias_map <- c( + "tcross.alt.crossprod" = "crossprod", + "tcross.alt.star" = "star" + ) + + if (transpose_method %in% names(alias_map)) { + method_normalized <- alias_map[[transpose_method]] } else { - if (verbose) cat("Doing tcrossprod\n") - return(Matrix::tcrossprod(r2)) + method_normalized <- transpose_method } -} + result <- switch(method_normalized, + "tcrossprod" = { + if (verbose) cat("Doing tcrossprod\n") + Matrix::tcrossprod(r2) + }, + "crossprod" = { + if (verbose) cat("Doing tcrossprod using crossprod(t(.))\n") + crossprod(t(as.matrix(r2))) + }, + "star" = { + if (verbose) cat("Doing tcrossprod using %*% t(.)\n") + r2 %*% t(as.matrix(r2)) + } + ) + + return(result) +} diff --git a/R/constructAdjacency.R b/R/constructAdjacency.R index d0dcdd71..6a2c337b 100644 --- a/R/constructAdjacency.R +++ b/R/constructAdjacency.R @@ -1,4 +1,3 @@ - .adjLoop <- function(ped, component, saveable, resume, save_path, verbose, lastComputed, nr, checkpoint_files, update_rate, @@ -407,9 +406,6 @@ } - - - #' Compute Parent Adjacency Matrix with Multiple Approaches #' @inheritParams ped2com #' @inherit ped2com details @@ -422,93 +418,105 @@ #' #' @export computeParentAdjacency <- function(ped, component, - adjacency_method = "direct", - saveable, resume, - save_path, + adjacency_method = "direct", + saveable, resume, + save_path, verbose = FALSE, - lastComputed = 0, nr, + lastComputed = 0, nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist, + parList, lens, save_rate_parlist, adjBeta_method = NULL, - ...) { - if (adjacency_method == "loop") { - if (lastComputed < nr) { # Original version - list_of_adjacency <- .adjLoop( - ped = ped, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ... - ) - } - } else if (adjacency_method == "indexed") { # Garrison version - if (lastComputed < nr) { - list_of_adjacency <- .adjIndexed( - ped = ped, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ... - ) - } - } else if (adjacency_method == "direct") { # Hunter version - if (lastComputed < nr) { - list_of_adjacency <- .adjDirect( - ped = ped, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ... - ) - } - } else if (adjacency_method == "beta") { - list_of_adjacency <- .adjBeta( - ped = ped, - adjBeta_method = adjBeta_method, - component = component, - saveable = saveable, - resume = resume, - save_path = save_path, - verbose = verbose, - lastComputed = lastComputed, - nr = nr, - checkpoint_files = checkpoint_files, - update_rate = update_rate, - parList = parList, - lens = lens, - save_rate_parlist = save_rate_parlist, - ... - ) + ...) { + if (!adjacency_method %in% c("loop", "indexed", "direct", "beta")) { + stop("Invalid method specified. Choose from 'loop', 'direct', 'indexed', or 'beta'.") + } + # For loop/indexed/direct: skip if already complete + if (adjacency_method != "beta" && lastComputed >= nr) { + list_of_adjacency <- NULL } else { - stop("Invalid method specified. Choose from 'loop', 'direct', 'indexed', or beta") + list_of_adjacency <- switch(adjacency_method, + + "loop" = { + # Original version + .adjLoop( + ped = ped, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) + }, + + "indexed" = { + # Garrison version + .adjIndexed( + ped = ped, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) + }, + + "direct" = { + # Hunter version + .adjDirect( + ped = ped, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) + }, + + "beta" = { + .adjBeta( + ped = ped, + adjBeta_method = adjBeta_method, + component = component, + saveable = saveable, + resume = resume, + save_path = save_path, + verbose = verbose, + lastComputed = lastComputed, + nr = nr, + checkpoint_files = checkpoint_files, + update_rate = update_rate, + parList = parList, + lens = lens, + save_rate_parlist = save_rate_parlist, + ... + ) + } + ) } if (saveable) { saveRDS(parList, file = checkpoint_files$parList) diff --git a/tests/testthat/test-readWikiTree.R b/tests/testthat/test-readWikiTree.R index df894c08..e7602e03 100644 --- a/tests/testthat/test-readWikiTree.R +++ b/tests/testthat/test-readWikiTree.R @@ -19,8 +19,8 @@ test_that("traceTreePaths works correctly for horizontal tree", { result <- traceTreePaths(tree_horizontal) # Check the result # Check the result - expect_equal(names(result), c("from_id", "to_id", "path_length", "intermediates","intermediate_values")) - expect_equal(c("A", "B") %in% c(result$from_id, result$to_id), rep(TRUE,2)) + expect_equal(names(result), c("from_id", "to_id", "path_length", "intermediates", "intermediate_values")) + expect_equal(c("A", "B") %in% c(result$from_id, result$to_id), rep(TRUE, 2)) expect_equal(result$path_length[result$from_id == "A" & result$to_id == "B"], 2) expect_equal(result$intermediate_values[result$from_id == "A" & result$to_id == "B"], "+") }) @@ -42,13 +42,12 @@ test_that("traceTreePaths works correctly for vertical tree", { result <- traceTreePaths(tree_spouse_child) # Check the result - expect_equal(names(result), c("from_id", "to_id", "path_length", "intermediates","intermediate_values")) - expect_equal(c("A", "B", "C") %in% c(result$from_id, result$to_id), rep(TRUE,3)) + expect_equal(names(result), c("from_id", "to_id", "path_length", "intermediates", "intermediate_values")) + expect_equal(c("A", "B", "C") %in% c(result$from_id, result$to_id), rep(TRUE, 3)) expect_equal(result$path_length[result$from_id == "A" & result$to_id == "B"], 2) expect_equal(result$path_length[result$from_id == "A" & result$to_id == "C"], 5) expect_equal(result$path_length[result$from_id == "B" & result$to_id == "C"], 5) expect_equal(result$intermediate_values[result$from_id == "A" & result$to_id == "B"], "+") - }) @@ -83,7 +82,8 @@ test_that("readWikifamilytree reads a string correctly", { expect_equal( result2$summary, - result$summary) + result$summary + ) }) From 05676d15e090d584ed6fa05e8e5b0ab6929620bf Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 21 Apr 2025 17:51:44 -0400 Subject: [PATCH 58/69] rename --- R/{computeRelatedness.R => calculateRelatedness.R} | 1 - 1 file changed, 1 deletion(-) rename R/{computeRelatedness.R => calculateRelatedness.R} (99%) diff --git a/R/computeRelatedness.R b/R/calculateRelatedness.R similarity index 99% rename from R/computeRelatedness.R rename to R/calculateRelatedness.R index 3fa91ffd..d1da241d 100644 --- a/R/computeRelatedness.R +++ b/R/calculateRelatedness.R @@ -107,7 +107,6 @@ inferRelatedness <- function(obsR, aceA = .9, aceC = 0, sharedC = 0) { } #' @rdname inferRelatedness -#' @export relatedness <- function(...) { warning("The 'relatedness' function is deprecated. Please use 'inferRelatedness' instead.") inferRelatedness(...) From 9311fdb676a92b8e72ce59b96107d35352d798ca Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Mon, 21 Apr 2025 17:54:40 -0400 Subject: [PATCH 59/69] docs --- NAMESPACE | 1 - man/calculateH.Rd | 2 +- man/calculateRelatedness.Rd | 2 +- man/inferRelatedness.Rd | 2 +- 4 files changed, 3 insertions(+), 4 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 879d7895..d739dd51 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -39,7 +39,6 @@ export(readWikifamilytree) export(readgedcom) export(recodeSex) export(related_coef) -export(relatedness) export(repairSex) export(resample) export(simulatePedigree) diff --git a/man/calculateH.Rd b/man/calculateH.Rd index 6717b588..5341b7e4 100644 --- a/man/calculateH.Rd +++ b/man/calculateH.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/computeRelatedness.R +% Please edit documentation in R/calculateRelatedness.R \name{calculateH} \alias{calculateH} \title{Falconer's Formula} diff --git a/man/calculateRelatedness.Rd b/man/calculateRelatedness.Rd index 6d932e63..c52ccf48 100644 --- a/man/calculateRelatedness.Rd +++ b/man/calculateRelatedness.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/computeRelatedness.R +% Please edit documentation in R/calculateRelatedness.R \name{calculateRelatedness} \alias{calculateRelatedness} \alias{related_coef} diff --git a/man/inferRelatedness.Rd b/man/inferRelatedness.Rd index 1dd8b17c..d46c3f15 100644 --- a/man/inferRelatedness.Rd +++ b/man/inferRelatedness.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/computeRelatedness.R +% Please edit documentation in R/calculateRelatedness.R \name{inferRelatedness} \alias{inferRelatedness} \alias{relatedness} From 703786e26d788865270b23336a564e321eade000 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Tue, 22 Apr 2025 10:16:55 -0400 Subject: [PATCH 60/69] renamed 1.3.6 to 1.4.0 --- DESCRIPTION | 2 +- NEWS.md | 3 +- R/buildComponent.R | 5 +- R/checkParents.R | 78 +++------------ R/checkSex.R | 137 ++++++++++++++++++++------ R/cleanPedigree.R | 2 +- R/constructAdjacency.R | 17 +--- R/tweakPedigree.R | 4 +- tests/testthat/test-convertPedigree.R | 2 +- tests/testthat/test-tweakPedigree.R | 14 +-- 10 files changed, 137 insertions(+), 127 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index bcdab09f..a81d4686 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: BGmisc Title: An R Package for Extended Behavior Genetics Analysis -Version: 1.3.6 +Version: 1.4.0 Authors@R: c( person("S. Mason", "Garrison", , "garrissm@wfu.edu", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-4804-6003")), diff --git a/NEWS.md b/NEWS.md index 7693f0eb..7d508905 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# BGmisc 1.3.6 +# BGmisc 1.4.0 * revived checkParents function to check for handling phantom parents and missing parents * added tests for checkParents function * added GoT analysis @@ -8,6 +8,7 @@ * harmonizing function names like calcFamilySize from famSizeCal * implemented adjBeta function to evaluation alternative build method * reorganize file names to be more consistent +* harmonized famID # BGmisc 1.3.5.1 * Setting the default for the `sparse` argument in `ped2com()` to TRUE diff --git a/R/buildComponent.R b/R/buildComponent.R index b57e90dc..8c1da06e 100644 --- a/R/buildComponent.R +++ b/R/buildComponent.R @@ -120,6 +120,7 @@ ped2com <- function(ped, component, } # Step 1: Construct parent-child adjacency matrix + ## A. Resume from Checkpoint if Needed if (resume && file.exists(checkpoint_files$parList) && file.exists(checkpoint_files$lens)) { if (verbose) cat("Resuming: Loading parent-child adjacency data...\n") @@ -139,7 +140,6 @@ ped2com <- function(ped, component, ## B. Resume loop from the next uncomputed index - if (verbose) cat("Computing parent-child adjacency matrix...\n") # Construct sparse matrix if (resume && file.exists(checkpoint_files$iss) && file.exists(checkpoint_files$jss)) { # fix to check actual @@ -234,6 +234,8 @@ ped2com <- function(ped, component, } } # --- Step 2: Compute Relatedness Matrix --- + + if (resume && file.exists(checkpoint_files$r_checkpoint) && file.exists(checkpoint_files$gen_checkpoint) && file.exists(checkpoint_files$mtSum_checkpoint) && file.exists(checkpoint_files$newIsPar_checkpoint) && file.exists(checkpoint_files$count_checkpoint) ) { @@ -320,7 +322,6 @@ ped2com <- function(ped, component, } } - if (component == "mitochondrial") { r@x <- rep(1, length(r@x)) # Assign 1 to all nonzero elements for mitochondrial component diff --git a/R/checkParents.R b/R/checkParents.R index 43c8a924..18f8a17a 100644 --- a/R/checkParents.R +++ b/R/checkParents.R @@ -13,6 +13,7 @@ #' @param addphantoms A logical flag indicating whether to add phantom parents for missing parent IDs. #' @param parentswithoutrow A logical flag indicating whether to add parents without a row in the pedigree. #' +#' #' @return Depending on the value of `repair`, either a list containing validation results or a repaired dataframe is returned. #' @examples #' \dontrun{ @@ -25,10 +26,8 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, addphantoms = repair, parentswithoutrow = repair) { # Standardize column names in the input dataframe - ped_og <- ped ped <- standardizeColnames(ped, verbose = verbose) - # Initialize a list to store validation results validation_results <- list() @@ -36,6 +35,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, cat("Step 1: Checking for single parents...\n") } + # Identify missing fathers and mothers missing_fathers <- ped$ID[which(is.na(ped$dadID) & !is.na(ped$momID))] missing_mothers <- ped$ID[which(!is.na(ped$dadID) & is.na(ped$momID))] @@ -79,69 +79,17 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, cat("Step 2: Determining the if moms are the same sex and dads are same sex\n") } # Determine modal sex values for moms and dads - mom_sexes <- ped$sex[ped$ID %in% ped$momID] - dad_sexes <- ped$sex[ped$ID %in% ped$dadID] - - # Determine the most frequent sex for moms and dads - most_frequent_sex_mom <- names(sort(table(mom_sexes), decreasing = TRUE))[1] - most_frequent_sex_dad <- names(sort(table(dad_sexes), decreasing = TRUE))[1] - - # are all moms/dads the same sex? - validation_results$mom_sex <- unique(mom_sexes) - validation_results$dad_sex <- unique(dad_sexes) - - # Store the most frequent sex for moms and dads - if (is.numeric(ped$sex)) { - validation_results$female_var <- as.numeric(most_frequent_sex_mom) - validation_results$male_var <- as.numeric(most_frequent_sex_dad) - } else if (is.character(ped$sex) | is.factor(ped$sex)) { - validation_results$female_var <- most_frequent_sex_mom - validation_results$male_var <- most_frequent_sex_dad - } else { - print("You should never see this. If you do, then you have a problem with the data type of the sex variable") - } - - # verbose - if (length(validation_results$mom_sex) == 1) { - if (verbose) { - cat(paste0( - "All moms are '", - validation_results$female_var, - "'.\n" - )) - } - validation_results$female_moms <- TRUE - } else { - validation_results$female_moms <- FALSE - } - - if (length(validation_results$dad_sex) == 1) { - if (verbose) { - cat(paste0( - "All dads are '", - validation_results$male_var, - "'.\n" - )) - } - validation_results$male_dads <- TRUE - } else { - validation_results$male_dads <- FALSE - } - # Check for inconsistent sex - wrong_sex_moms <- ped$ID[which(ped$sex[ped$ID %in% ped$momID] != validation_results$female_var)] - wrong_sex_dads <- ped$ID[which(ped$sex[ped$ID %in% ped$dadID] != validation_results$male_var)] - - validation_results$wrong_sex_moms <- wrong_sex_moms - validation_results$wrong_sex_dads <- wrong_sex_dads - - if (verbose) { - if (length(wrong_sex_moms) > 0) { - cat("Some individuals listed as moms are not coded as", validation_results$female_var, "\n") - } - if (length(wrong_sex_dads) > 0) { - cat("Some individuals listed as dads are not coded as", validation_results$male_var, "\n") - } - } + mom_results <- checkParentSex(ped, parent_col = "momID", verbose = verbose) + dad_results <- checkParentSex(ped, parent_col = "dadID", verbose = verbose) + + validation_results$mom_sex <- mom_results$unique_sexes + validation_results$dad_sex <- dad_results$unique_sexes + validation_results$female_var <- mom_results$modal_sex + validation_results$male_var <- dad_results$modal_sex + validation_results$wrong_sex_moms <- mom_results$inconsistent_parents + validation_results$wrong_sex_dads <- dad_results$inconsistent_parents + validation_results$female_moms <- mom_results$all_same_sex + validation_results$male_dads <- dad_results$all_same_sex # Are any parents in both momID and dadID? momdad <- intersect(ped$dadID, ped$momID) diff --git a/R/checkSex.R b/R/checkSex.R index 8fbabf6a..2c729760 100644 --- a/R/checkSex.R +++ b/R/checkSex.R @@ -35,7 +35,10 @@ #' } #' @export #' -checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE, repair = FALSE) { +checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE, repair = FALSE, + momID = "momID", + dadID = "dadID" + ) { # Standardize column names in the input dataframe ped <- standardizeColnames(ped, verbose = verbose) @@ -53,36 +56,31 @@ checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE, validation_results$sex_unique <- unique(ped$sex) validation_results$sex_length <- length(unique(ped$sex)) if (verbose) { - cat(paste0(validation_results$sex_length, " unique values found.\n")) - cat(paste0("Unique values: ", paste0(validation_results$sex_unique, collapse = ", "), "\n")) + cat(validation_results$sex_length, " unique sex codes found: ", paste(validation_results$sex_unique, collapse = ", "), "\n") } - # Are there multiple sexes/genders in the list of dads and moms? - table_sex_dad <- sort(table(ped$sex[ped$ID %in% ped$dadID]), decreasing = TRUE) - table_sex_mom <- sort(table(ped$sex[ped$ID %in% ped$momID]), decreasing = TRUE) - validation_results$all_sex_dad <- names(table_sex_dad) - validation_results$all_sex_mom <- names(table_sex_mom) - validation_results$most_frequent_sex_dad <- validation_results$all_sex_dad[1] - validation_results$most_frequent_sex_mom <- validation_results$all_sex_mom[1] + # Are there multiple sexes/genders in the list of dads and moms? - # List ids for dads that are female, moms that are male - if (length(validation_results$all_sex_dad) > 1) { - df_dads <- ped[ped$ID %in% ped$dadID, ] - validation_results$ID_female_dads <- df_dads$ID[df_dads$sex != validation_results$most_frequent_sex_dad] - validation_results$ID_child_female_dads <- ped$ID[ped$dadID %in% validation_results$ID_female_dads] - remove(df_dads) - } - if (length(validation_results$all_sex_mom) > 1) { - df_moms <- ped[ped$ID %in% ped$momID, ] - validation_results$ID_male_moms <- df_moms$ID[df_moms$sex != validation_results$most_frequent_sex_mom] - validation_results$ID_child_male_moms <- ped$ID[ped$momID %in% validation_results$ID_male_moms] - remove(df_moms) - } + dad_results <- checkParentSex(ped, parent_col = dadID, verbose = verbose) + mom_results <- checkParentSex(ped, parent_col = momID, verbose = verbose) - if (repair) { - if (verbose) { + validation_results$all_sex_dad <- dad_results$unique_sexes + validation_results$all_sex_mom <- mom_results$unique_sexes + validation_results$most_frequent_sex_dad <- dad_results$modal_sex + validation_results$most_frequent_sex_mom <- mom_results$modal_sex + validation_results$ID_female_dads <- dad_results$inconsistent_parents + validation_results$ID_child_female_dads <- dad_results$inconsistent_children + validation_results$ID_male_moms <- mom_results$inconsistent_parents + validation_results$ID_child_male_moms <- mom_results$inconsistent_children + + if (repair==FALSE) { + if (verbose) { cat("Checks Made:\n") + print(validation_results) } + return(validation_results) + } else { + if (verbose==TRUE) { cat("Step 2: Attempting to repair sex coding...\n") } # Initialize a list to track changes made during repair @@ -107,13 +105,6 @@ checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE, print(changes) } return(ped) - } else { - if (verbose) { - cat("Checks Made:\n") - print(validation_results) - } - - return(validation_results) } } @@ -193,3 +184,85 @@ recodeSex <- function( } return(ped) } + + + +#' Check Parental Role Sex Consistency +#' +#' Validates sex coding consistency for a given parental role (momID or dadID). +#' +#' @param ped Pedigree dataframe. +#' @param parent_col The column name for parent IDs ("momID" or "dadID"). +#' @param sex_col The column name for sex coding. Default is "sex". +#' @param verbose Logical, whether to print messages. +#' +#' @return A list containing role, unique sex codes, modal sex, inconsistent parents, and linked children. +checkParentSex <- function(ped, parent_col, sex_col = "sex", verbose = FALSE) { + + + parent_ids <- ped[[parent_col]] + parent_rows <- ped[ped$ID %in% parent_ids, ] + + if (nrow(parent_rows) == 0) { + if (verbose) cat(paste0("No individuals found in role: ", parent_col, "\n")) + return(list( + role = parent_col, + unique_sexes = NULL, + modal_sex = NA, + all_same_sex = NA, + inconsistent_parents = NULL, + inconsistent_children = NULL + )) + } + + + # Are there multiple sexes/genders in the list of dads and moms? + parent_sexes <- parent_rows[[sex_col]] + unique_sexes <- unique(parent_sexes) + + # are all moms/dads the same sex? + all_same_sex <- length(unique_sexes) == 1 + + # Store the most frequent sex for moms and dads + modal_sex <- names(sort(table(parent_sexes), decreasing = TRUE))[1] + + # Type coercion based on ped$sex type + if (is.numeric(ped[[sex_col]])) { + modal_sex <- as.numeric(modal_sex) + } + + # List ids for dads that are female, moms that are male + inconsistent_parents <- parent_rows$ID[parent_rows[[sex_col]] != modal_sex] + + child_col <- parent_col + inconsistent_children <- ped$ID[ped[[child_col]] %in% inconsistent_parents] + + + if (verbose) { + cat(paste0("Role: ", parent_col, "\n")) + cat(length(unique_sexes), " unique sex codes found: ", paste(unique_sexes, collapse = ", "), "\n") + cat("Modal sex code: ", modal_sex, "\n") + + if (all_same_sex) { + cat("All parents consistently coded.\n") + } else cat(length(inconsistent_parents), " parents have inconsistent sex coding.\n") + } + + return(list( + role = parent_col, + unique_sexes = unique_sexes, + modal_sex = modal_sex, + all_same_sex = all_same_sex, + inconsistent_parents = inconsistent_parents, + inconsistent_children = inconsistent_children + )) +} + +#' Get the Modal Value of a Vector + +.getModalValue <- function(x) { + if (length(na.omit(x)) == 0) return(NA) + freq_table <- sort(table(x), decreasing = TRUE) + modal <- names(freq_table)[1] + return(modal) +} diff --git a/R/cleanPedigree.R b/R/cleanPedigree.R index 737b558c..46a3a64a 100644 --- a/R/cleanPedigree.R +++ b/R/cleanPedigree.R @@ -13,7 +13,7 @@ standardizeColnames <- function(df, verbose = FALSE) { # Internal mapping of standardized names to possible variants mapping <- list( - "fam" = "^(?:fam(?:ily)?[\\.\\-_]?(?:id)?)", + "famID" = "^(?:fam(?:ily)?[\\.\\-_]?(?:id)?)", "ID" = "^(?:i(?:d$|ndiv(?:idual)?)|p(?:erson)?[\\.\\-_]?id)", "gen" = "^(?:gen(?:s|eration)?)", "dadID" = "^(?:d(?:ad)?id|paid|fatherid|pid[\\.\\-_]?fath[er]*|sire)", diff --git a/R/constructAdjacency.R b/R/constructAdjacency.R index 6a2c337b..a1d6fd66 100644 --- a/R/constructAdjacency.R +++ b/R/constructAdjacency.R @@ -119,7 +119,7 @@ .adjDirect <- function(ped, component, saveable, resume, save_path, verbose, lastComputed, nr, checkpoint_files, update_rate, - parList, lens, save_rate_parlist, adjBeta_method, + parList, lens, save_rate_parlist, ...) { # Loop through each individual in the pedigree # Build the adjacency matrix for parent-child relationships @@ -177,18 +177,6 @@ iss <- unlist(iss_list, use.names = FALSE) jss <- unlist(jss_list, use.names = FALSE) - # list_of_adjacency <- .adjBeta(ped=ped,adjBeta_method=adjBeta_method, - # component = component, - # saveable = saveable, resume = resume, - # save_path = save_path, verbose = verbose, - # lastComputed = lastComputed, nr = nr, - # checkpoint_files = checkpoint_files, - # update_rate = update_rate, - # parList = parList, - # lens = lens, save_rate_parlist = save_rate_parlist, - # ...) - - # return(list_of_adjacency) } else if (component %in% c("mitochondrial")) { mIDs <- stats::na.omit(data.frame(rID = ped$ID, cID = ped$momID)) iss <- c(mIDs$rID) @@ -459,8 +447,7 @@ computeParentAdjacency <- function(ped, component, "indexed" = { # Garrison version - .adjIndexed( - ped = ped, + .adjIndexed(ped = ped, component = component, saveable = saveable, resume = resume, diff --git a/R/tweakPedigree.R b/R/tweakPedigree.R index d617851b..52b67a30 100644 --- a/R/tweakPedigree.R +++ b/R/tweakPedigree.R @@ -15,7 +15,7 @@ makeTwins <- function(ped, ID_twin1 = NA_integer_, ID_twin2 = NA_integer_, gen_twin = 2, verbose = FALSE) { # Check if the ped is the same format as the output of simulatePedigree if (paste0(colnames(ped), collapse = "") != paste0(c( - "fam", "ID", "gen", + "famID", "ID", "gen", "dadID", "momID", "spID", "sex" ), collapse = "")) { ped <- standardizeColnames(ped, verbose = verbose) @@ -128,7 +128,7 @@ makeInbreeding <- function(ped, if (paste0(colnames(ped), collapse = "" ) != paste0( - c("fam", "ID", "gen", "dadID", "momID", "spID", "sex"), + c("famID", "ID", "gen", "dadID", "momID", "spID", "sex"), collapse = "" )) { ped <- standardizeColnames(ped, verbose = verbose) diff --git a/tests/testthat/test-convertPedigree.R b/tests/testthat/test-convertPedigree.R index a011c334..c927d2ad 100644 --- a/tests/testthat/test-convertPedigree.R +++ b/tests/testthat/test-convertPedigree.R @@ -37,7 +37,7 @@ test_that("ped2add produces correct matrix dims, values, and dimnames for altern expect_equal(dn[[1]], dn[[2]]) expect_equal(dn[[1]], as.character(hazard$ID)) }) -# to do, combine the sets that are equalivant. shouldn't need to run 1000 expect equals +# to do, combine the sets that are equivalent. shouldn't need to run 1000 expect equals test_that("ped2add produces correct matrix dims, values, and dimnames for inbreeding data", { tolerance <- 1e-10 diff --git a/tests/testthat/test-tweakPedigree.R b/tests/testthat/test-tweakPedigree.R index 0b542e2e..eb00908a 100644 --- a/tests/testthat/test-tweakPedigree.R +++ b/tests/testthat/test-tweakPedigree.R @@ -2,7 +2,7 @@ test_that("makeTwins - Twins specified by IDs", { set.seed(1234) ped <- data.frame( - fam = c(1, 1, 2, 2), + famID = c(1, 1, 2, 2), ID = c(1, 2, 3, 4), gen = c(1, 1, 2, 2), dadID = c(NA, NA, 1, 1), @@ -11,7 +11,7 @@ test_that("makeTwins - Twins specified by IDs", { sex = c("M", "F", "M", "F") ) expected_result <- data.frame( - fam = c(1, 1, 2, 2), + famID = c(1, 1, 2, 2), ID = c(1, 2, 3, 4), gen = c(1, 1, 2, 2), dadID = c(NA, NA, 1, 1), @@ -25,7 +25,7 @@ test_that("makeTwins - Twins specified by IDs", { expect_equal(result, expected_result) # does it handle weird variable names? "fam" = "famID" - names(ped)[1] <- "famID" + names(ped)[1] <- "fam" result <- makeTwins(ped, ID_twin1 = 1, ID_twin2 = 2, verbose = TRUE) expect_equal(result, expected_result) @@ -41,7 +41,7 @@ test_that("makeTwins - Twins specified by generation", { ped <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) # result <- makeTwins(ped, gen_twin = gen_twin) - expect_equal(names(result), c("fam", "ID", "gen", "dadID", "momID", "spID", "sex", "MZtwin")) + expect_equal(names(result), c("famID", "ID", "gen", "dadID", "momID", "spID", "sex", "MZtwin")) # do we have the same people? expect_equal(result$ID, ped$ID) # did it make one pair of twins? @@ -61,7 +61,7 @@ test_that("makeTwins - Twins specified by generation", { # Test for makeInbreeding function test_that("makeInbreeding - Inbred mates specified by IDs", { ped <- data.frame( - fam = c(1, 1, 2, 2), + famID = c(1, 1, 2, 2), ID = c(1, 2, 3, 4), gen = c(1, 1, 2, 2), dadID = c(NA, NA, 1, 1), @@ -70,7 +70,7 @@ test_that("makeInbreeding - Inbred mates specified by IDs", { sex = c("M", "F", "M", "F") ) expected_result <- data.frame( - fam = c(1, 1, 2, 2), + famID = c(1, 1, 2, 2), ID = c(1, 2, 3, 4), gen = c(1, 1, 2, 2), dadID = c(NA, NA, 1, 1), @@ -94,7 +94,7 @@ test_that("makeInbreeding - Inbred mates specified by generation and sibling", { ped <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) # result <- makeInbreeding(ped, gen_inbred = gen_inbred, type_inbred = type_inbred) - expect_equal(names(result), c("fam", "ID", "gen", "dadID", "momID", "spID", "sex")) + expect_equal(names(result), c("famID", "ID", "gen", "dadID", "momID", "spID", "sex")) # do we have the same people? expect_equal(result$ID, ped$ID) From 0e597c38c25ae39c441bf3fa7680861cd9ca9a6f Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Tue, 22 Apr 2025 10:32:45 -0400 Subject: [PATCH 61/69] varnames --- R/plotPedigree.R | 4 ++-- data-raw/inbreeding.csv | 2 +- data/inbreeding.rda | Bin 640 -> 640 bytes man/checkParentSex.Rd | 23 +++++++++++++++++++++++ man/checkSex.Rd | 4 +++- man/dot-getModalValue.Rd | 11 +++++++++++ tests/testthat/test-networks.R | 8 ++++---- 7 files changed, 44 insertions(+), 8 deletions(-) create mode 100644 man/checkParentSex.Rd create mode 100644 man/dot-getModalValue.Rd diff --git a/R/plotPedigree.R b/R/plotPedigree.R index 5b2229cd..f82be4bc 100644 --- a/R/plotPedigree.R +++ b/R/plotPedigree.R @@ -28,11 +28,11 @@ plotPedigree <- function(ped, ped <- standardizeColnames(ped, verbose = verbose) # Define required columns - simulated_vars <- c("fam", "ID", "dadID", "momID", "sex") + simulated_vars <- c("famID", "ID", "dadID", "momID", "sex") # Check if dataframe contains the required columns if (all(simulated_vars %in% names(ped))) { - p <- ped[, c("fam", "ID", "dadID", "momID", "sex")] + p <- ped[, c("famID", "ID", "dadID", "momID", "sex")] colnames(p) <- c("ped", "id", "father", "mother", "sex") # data conversation diff --git a/data-raw/inbreeding.csv b/data-raw/inbreeding.csv index 0c61ca8e..19b66a51 100644 --- a/data-raw/inbreeding.csv +++ b/data-raw/inbreeding.csv @@ -1,4 +1,4 @@ -ID,sex,dadID,momID,FamID,Gen,proband +ID,sex,dadID,momID,famID,gen,proband 1,1,NA,NA,1,1,FALSE 2,0,NA,NA,1,1,FALSE 3,1,NA,NA,1,1,FALSE diff --git a/data/inbreeding.rda b/data/inbreeding.rda index 44339aa8bd32ff9fdde5f5f12f140a1642fb3092..4490821bbace749dfde2532e8978147ab6fcf0b0 100755 GIT binary patch delta 625 zcmV-%0*?KF1%L&R8h`KtL|p(W5eHOg5#(-C%AhmFB=3^5RQzS%9jv_+mdv|qJ7$|u z=oK4J@)OO--z{RwLrA}qk2_hdh4IQT70TSMH8EF@E|Lj`3N>bBng}0kF#p4k>FYB4 zyn$WyVKrqf6#{-tDN|(A1HRj zmOOk5U_x9bF`V%exrl=B!QR0|m%Ppd@2Ls`en8KmuYAFi7A=J_{{vLX=Pu-p)V+DK zS;hrQqjtPurv1i1m_ftG4(~IgcbKg#|(V+bqT}OHwsLplQV9&c`CMTn}HbvTz{$6ur8KCepXO>B0qI}X(cJS zI`U_8Kh%r@-)0e|%Mw#oezcS#FMO?IZwfZ@)uDRBehj#J1f;l!#=fZ#YTjZ**szC%RQ00GVa&i!nK2LW@O8DIjdxK z_DiaR_KotN@^SVV!gJGJNj;z zt;j!O(2i&u_dpgtNzX3 z%Zsj71{-G5-N1yQ{6$Gp=wK}23|!3FmKuUlOhPd~&ib>CT8rPsux0j57_h=&JpbI{ zN}^Y7>}m?ndLVTORne@2m@G{l3wfH}Kt%&WBU|a+ZjNuL)b1(|#;d&ll&X1T3~cyb zqB>&6#Ak*MfS2@&^TkxTvOB%k Date: Tue, 22 Apr 2025 10:36:36 -0400 Subject: [PATCH 62/69] data fix --- R/checkSex.R | 14 ++++++++++++-- R/readWikifamilytree.R | 2 +- data-raw/hazard.csv | 2 +- data/hazard.rda | Bin 672 -> 572 bytes man/checkSex.Rd | 4 ++++ man/dot-getModalValue.Rd | 10 +++++++++- vignettes/ASOIAF.Rmd | 2 +- vignettes/ASOIAF.html | 2 +- vignettes/partial.Rmd | 30 +++++++++++++++--------------- vignettes/partial.html | 28 ++++++++++++++-------------- 10 files changed, 58 insertions(+), 36 deletions(-) diff --git a/R/checkSex.R b/R/checkSex.R index 2c729760..239fc22f 100644 --- a/R/checkSex.R +++ b/R/checkSex.R @@ -26,6 +26,8 @@ #' @param code_female The current code used to represent females in the 'sex' column. If both are NULL, no recoding is performed. #' @param verbose A logical flag indicating whether to print progress and validation messages to the console. #' @param repair A logical flag indicating whether to attempt repairs on the sex coding. +#' @param momID The column name for maternal IDs. Default is "momID". +#' @param dadID The column name for paternal IDs. Default is "dadID". #' #' @return Depending on the value of `repair`, either a list containing validation results or a repaired dataframe is returned. #' @examples @@ -196,6 +198,7 @@ recodeSex <- function( #' @param sex_col The column name for sex coding. Default is "sex". #' @param verbose Logical, whether to print messages. #' +#' #' @return A list containing role, unique sex codes, modal sex, inconsistent parents, and linked children. checkParentSex <- function(ped, parent_col, sex_col = "sex", verbose = FALSE) { @@ -259,9 +262,16 @@ checkParentSex <- function(ped, parent_col, sex_col = "sex", verbose = FALSE) { } #' Get the Modal Value of a Vector - +#' +#' This function calculates the modal value of a vector, which is the most frequently occurring value. +#' If the vector is empty or contains only NA values, it returns NA. +#' +#' @param x A vector of values. +#' +#' @return The modal value of the vector. If the vector is empty or contains only NA values, returns NA. +#' @keywords internal .getModalValue <- function(x) { - if (length(na.omit(x)) == 0) return(NA) + if (length(stats::na.omit(x)) == 0) return(NA) freq_table <- sort(table(x), decreasing = TRUE) modal <- names(freq_table)[1] return(modal) diff --git a/R/readWikifamilytree.R b/R/readWikifamilytree.R index 018caaef..39f609ea 100644 --- a/R/readWikifamilytree.R +++ b/R/readWikifamilytree.R @@ -289,7 +289,7 @@ traceTreePaths <- function(tree_long, deduplicate = TRUE) { # Map keys to IDs person_nodes <- active_cells[!is.na(active_cells$id), c("key", "id")] - id_map <- setNames(person_nodes$id, person_nodes$key) + id_map <- stats::setNames(person_nodes$id, person_nodes$key) # Find all pairs of people and trace paths person_keys <- names(id_map) diff --git a/data-raw/hazard.csv b/data-raw/hazard.csv index 1e5007b8..b986fd7c 100644 --- a/data-raw/hazard.csv +++ b/data-raw/hazard.csv @@ -1,4 +1,4 @@ -"FamID","ID","sex","dadID","momID","affected","DA1","DA2","birthYr","onsetYr","deathYr","available","Gen","proband" +"famID","ID","sex","dadID","momID","affected","DA1","DA2","birthYr","onsetYr","deathYr","available","gen","proband" 1,1,1,NA,NA,TRUE,0,1,1902,1940,1970,TRUE,1,FALSE 1,2,0,NA,NA,FALSE,0,0,NA,NA,NA,FALSE,1,FALSE 1,3,0,2,1,FALSE,0,1,1923,NA,1982,TRUE,2,FALSE diff --git a/data/hazard.rda b/data/hazard.rda index 665569503a13d3e017961d2005dc73e20ef82d4b..7c4f244e0383a2c106c9b38d2b9fbc3c1127f06d 100644 GIT binary patch delta 558 zcmV+}0@3}T1-t~18Gj2%0sUP7DG>)$Xc6RYQp%t+#U$^NvsC<%IYaQf}3R^1nT`t zHvd?}8Jiqd%B2<a8 zT%dyHOT9Aha5ENk=pI9u<3WTy@~d@=z5iNj$g071fPZ?%j)hw3?Mq{9EP2$E8=}w4 zL7@tvNZ-jVp?{yGD*{F}k3cL`78?a3KCQ=i2y?8TZgL7-Fw14l7m)tndMQ{x?6;<5 zS|kX63Zg=JhUo=ZQ7_dJmm*auKSZ4uyO2E+P|jqB9*|2c0M-JHt)xv)&3ji&jepW7 w`!1Mb9Vhq=IgFIvpa1{>02?#_c>n>G1j!Zv0HceLXg)9vivj=u00045S|(`$od5s; delta 659 zcmV;E0&M-f1fT_w8GjP40%BbNDG>)$S0dzYQp%r_*(8Q(QeBELAaE!~m!o`W&#}>v zq~tvkNM1RdU2cA!TC86XiMQ+cXVQX*S9eH#-(HQ{2|8Yu$eU^XXYGH{bW-`2(<9sg ziAaqqqA$KUm`cg_;ighyB_M-)&ZY_3@W^FIp(;EaJav$tIe*>u3s_Tx9G0JfEK zOu`0Fjy?Ifoqu?iq0m8Os}f*Keh|~IukdVm$jY=IrBzz6L+!vVRx=;HyFQ^*8xRIL z=$@Y{sqak(9&^xO6-=aRX^=ettfiZBtm2Bih&+N%%d?zCvC!SYax=Hjd3N?On|esv z$6Yz8JMMIvVRMS+WH-dF$R({WQgNtD2+`Z ze!f#A((gze$U_A;m?kDcEsW8C+|flSuN$VPzSc08Zi-tQAafP@U1(z(vcf(H$UL6) z0c^;%#FoT&RC7p-{xE$NDDdO8Q3&zIXhL zv$Q}uKz~{D1?8ZN% mutate( - fam = 1, + famID = 1, affected = case_when( ID %in% c(jon_id, dany_id, "365") ~ 1, TRUE ~ 0 diff --git a/vignettes/ASOIAF.html b/vignettes/ASOIAF.html index 4066c186..7848e21a 100644 --- a/vignettes/ASOIAF.html +++ b/vignettes/ASOIAF.html @@ -497,7 +497,7 @@

Plotting the Pedigree with Incomplete Parental Information

parentswithoutrow = FALSE, repairsex = FALSE ) %>% mutate( - fam = 1, + famID = 1, affected = case_when( ID %in% c(jon_id, dany_id, "365") ~ 1, TRUE ~ 0 diff --git a/vignettes/partial.Rmd b/vignettes/partial.Rmd index 50009cfc..3e4b11fb 100644 --- a/vignettes/partial.Rmd +++ b/vignettes/partial.Rmd @@ -275,7 +275,7 @@ data("inbreeding") df <- inbreeding -FamIDs <- unique(df$FamID) +famIDs <- unique(df$famID) ``` For each one, we construct the additive relationship matrix under complete information and then simulate two missingness scenarios: @@ -291,16 +291,16 @@ In each condition, we recompute the additive matrix using both the classic and p ```{r} inbreeding_list <- list() results <- data.frame( - FamIDs = FamIDs, - RMSE_partial_dad = rep(NA, length(FamIDs)), - RMSE_partial_mom = rep(NA, length(FamIDs)), - RMSE_classic_dad = rep(NA, length(FamIDs)), - RMSE_classic_mom = rep(NA, length(FamIDs)), - max_R_classic_dad = rep(NA, length(FamIDs)), - max_R_partial_dad = rep(NA, length(FamIDs)), - max_R_classic_mom = rep(NA, length(FamIDs)), - max_R_partial_mom = rep(NA, length(FamIDs)), - max_R_classic = rep(NA, length(FamIDs)) + famIDs = famIDs, + RMSE_partial_dad = rep(NA, length(famIDs)), + RMSE_partial_mom = rep(NA, length(famIDs)), + RMSE_classic_dad = rep(NA, length(famIDs)), + RMSE_classic_mom = rep(NA, length(famIDs)), + max_R_classic_dad = rep(NA, length(famIDs)), + max_R_partial_dad = rep(NA, length(famIDs)), + max_R_classic_mom = rep(NA, length(famIDs)), + max_R_partial_mom = rep(NA, length(famIDs)), + max_R_classic = rep(NA, length(famIDs)) ) ``` @@ -308,9 +308,9 @@ The loop below performs this procedure for all families in the dataset and store ```{r} -for (i in 1:length(FamIDs)) { +for (i in 1:length(famIDs)) { # make three versions to filter down - df_fam_dad <- df_fam_mom <- df_fam <- df[df$FamID == FamIDs[i], ] + df_fam_dad <- df_fam_mom <- df_fam <- df[df$famID == famIDs[i], ] results$RMSE_partial_mom[i] <- sqrt(mean((ped_add_classic_complete - ped_add_partial_mom)^2)) @@ -381,7 +381,7 @@ for (i in 1:length(FamIDs)) { } ``` -### Example: Family ``r FamIDs[1]`` +### Example: Family ``r famIDs[1]`` To understand what these matrices look like, we visualize them for one representative family. For this example, we select the first family in the dataset. @@ -519,7 +519,7 @@ These proportions show how often the partial method produces a lower RMSE across results %>% as.data.frame() %>% select( - -FamIDs, -RMSE_diff_mom, -RMSE_diff_dad, -max_R_classic_dad, + -famIDs, -RMSE_diff_mom, -RMSE_diff_dad, -max_R_classic_dad, -max_R_partial_dad, -max_R_classic_mom, -max_R_partial_mom, -max_R_classic ) %>% summary() diff --git a/vignettes/partial.html b/vignettes/partial.html index 51f5d3f5..3e0901a1 100644 --- a/vignettes/partial.html +++ b/vignettes/partial.html @@ -575,7 +575,7 @@

Inbreeding Dataset: Family-Level Evaluation

df <- inbreeding -FamIDs <- unique(df$FamID) +famIDs <- unique(df$famID)

For each one, we construct the additive relationship matrix under complete information and then simulate two missingness scenarios:

    @@ -591,23 +591,23 @@

    Inbreeding Dataset: Family-Level Evaluation

    relatedness structure when parental data are partially missing.

    inbreeding_list <- list()
 results <- data.frame(
-  FamIDs = FamIDs,
-  RMSE_partial_dad = rep(NA, length(FamIDs)),
-  RMSE_partial_mom = rep(NA, length(FamIDs)),
-  RMSE_classic_dad = rep(NA, length(FamIDs)),
-  RMSE_classic_mom = rep(NA, length(FamIDs)),
-  max_R_classic_dad = rep(NA, length(FamIDs)),
-  max_R_partial_dad = rep(NA, length(FamIDs)),
-  max_R_classic_mom = rep(NA, length(FamIDs)),
-  max_R_partial_mom = rep(NA, length(FamIDs)),
-  max_R_classic = rep(NA, length(FamIDs))
+  famIDs = famIDs,
+  RMSE_partial_dad = rep(NA, length(famIDs)),
+  RMSE_partial_mom = rep(NA, length(famIDs)),
+  RMSE_classic_dad = rep(NA, length(famIDs)),
+  RMSE_classic_mom = rep(NA, length(famIDs)),
+  max_R_classic_dad = rep(NA, length(famIDs)),
+  max_R_partial_dad = rep(NA, length(famIDs)),
+  max_R_classic_mom = rep(NA, length(famIDs)),
+  max_R_partial_mom = rep(NA, length(famIDs)),
+  max_R_classic = rep(NA, length(famIDs))
 )

    The loop below performs this procedure for all families in the dataset and stores both the RMSEs and the maximum relatedness values.

    -
    for (i in 1:length(FamIDs)) {
+
    for (i in 1:length(famIDs)) {
   # make three versions to filter down
-  df_fam_dad <- df_fam_mom <- df_fam <- df[df$FamID == FamIDs[i], ]
+  df_fam_dad <- df_fam_mom <- df_fam <- df[df$famID == famIDs[i], ]
 
   results$RMSE_partial_mom[i] <- sqrt(mean((ped_add_classic_complete - ped_add_partial_mom)^2))
 
@@ -895,7 +895,7 @@ 
    Summary
    
 
    results %>%
   as.data.frame() %>%
   select(
-    -FamIDs, -RMSE_diff_mom, -RMSE_diff_dad, -max_R_classic_dad,
+    -famIDs, -RMSE_diff_mom, -RMSE_diff_dad, -max_R_classic_dad,
     -max_R_partial_dad, -max_R_classic_mom, -max_R_partial_mom, -max_R_classic
   ) %>%
   summary()

From 49dee2d58a29e904d938626d18b0f7d75593ca05 Mon Sep 17 00:00:00 2001
From: Mason Garrison 
Date: Tue, 22 Apr 2025 12:45:24 -0400
Subject: [PATCH 63/69] assignParentValue

---
 R/buildComponent.R       | 213 ++++++++++++++++++++++++++++-----------
 R/calculateRelatedness.R |   1 +
 2 files changed, 153 insertions(+), 61 deletions(-)

diff --git a/R/buildComponent.R b/R/buildComponent.R
index 8c1da06e..58c2f27e 100644
--- a/R/buildComponent.R
+++ b/R/buildComponent.R
@@ -43,36 +43,38 @@ ped2com <- function(ped, component,
                     save_path = "checkpoint/",
                     adjBeta_method = NULL,
                     ...) {
+
+  #------
+  # Check inputs
+  #------
+
+  config <- list(verbose = verbose,
+                 saveable = saveable,
+                 resume = resume,
+                 save_path = save_path,
+                 max.gen = max.gen,
+                 sparse = sparse,
+                 flatten.diag = flatten.diag,
+                 standardize.colnames = standardize.colnames,
+                 transpose_method = transpose_method,
+                 adjacency_method = adjacency_method,
+                 isChild_method = isChild_method,
+                 save_rate = save_rate,
+                 save_rate_gen = save_rate_gen,
+                 save_rate_parlist = save_rate_parlist,
+                 update_rate = update_rate,
+                 gc = gc,
+                 component =component
+                 )
+
+
   #------
   # Checkpointing
   #------
-  if (saveable || resume) { # prepare checkpointing
-    if (verbose) cat("Preparing checkpointing...\n")
-    # Ensure save path exists
-    if (saveable && !dir.exists(save_path)) {
-      if (verbose) cat("Creating save path...\n")
-      dir.create(save_path, recursive = TRUE)
-    } else if (resume && !dir.exists(save_path)) {
-      stop("Cannot resume from checkpoint. Save path does not exist.")
-    }
+  if (config$saveable || config$resume) { # prepare checkpointing
+  if (config$verbose) cat("Preparing checkpointing...\n")
 
-    # Define checkpoint files
-    checkpoint_files <- list(
-      parList = file.path(save_path, "parList.rds"),
-      lens = file.path(save_path, "lens.rds"),
-      isPar = file.path(save_path, "isPar.rds"),
-      iss = file.path(save_path, "iss.rds"),
-      jss = file.path(save_path, "jss.rds"),
-      isChild = file.path(save_path, "isChild.rds"),
-      r_checkpoint = file.path(save_path, "r_checkpoint.rds"),
-      gen_checkpoint = file.path(save_path, "gen_checkpoint.rds"),
-      newIsPar_checkpoint = file.path(save_path, "newIsPar_checkpoint.rds"),
-      mtSum_checkpoint = file.path(save_path, "mtSum_checkpoint.rds"),
-      r2_checkpoint = file.path(save_path, "r2_checkpoint.rds"),
-      tcrossprod_checkpoint = file.path(save_path, "tcrossprod_checkpoint.rds"),
-      count_checkpoint = file.path(save_path, "count_checkpoint.rds"),
-      final_matrix = file.path(save_path, "final_matrix.rds")
-    )
+    checkpoint_files  <- initializeCheckpoint(config) # initialize checkpoint files
   }
   #------
   # Validation/Preparation
@@ -88,9 +90,14 @@ ped2com <- function(ped, component,
     )
   )
 
-  if (!transpose_method %in% c("tcrossprod", "crossprod", "star", "tcross.alt.crossprod", "tcross.alt.star")) {
-    stop("Invalid method specified. Choose from 'tcrossprod', 'crossprod', or 'star' or 'tcross.alt.crossprod' or 'tcross.alt.star'.")
+  transpose_method_options <- c("tcrossprod", "crossprod", "star",
+                                "tcross.alt.crossprod", "tcross.alt.star")
+  if (!transpose_method %in%  transpose_method_options) {
+    stop(paste0("Invalid method specified. Choose from ",
+                paste(transpose_method_options, collapse = ", "), "."))
   }
+
+
   if (!adjacency_method %in% c("indexed", "loop", "direct", "beta")) {
     stop("Invalid method specified. Choose from 'indexed', 'loop', 'direct', or 'beta'.")
   }
@@ -134,13 +141,13 @@ ped2com <- function(ped, component,
     parList <- vector("list", nr)
     lens <- integer(nr)
     lastComputed <- 0
-
     if (verbose) cat("Building parent adjacency matrix...\n")
   }
 
 
   ## B. Resume loop from the next uncomputed index
-  if (verbose) cat("Computing parent-child adjacency matrix...\n")
+
+
   # Construct sparse matrix
   if (resume && file.exists(checkpoint_files$iss) && file.exists(checkpoint_files$jss)) { # fix to check actual
     if (verbose) cat("Resuming: Constructed matrix...\n")
@@ -148,6 +155,7 @@ ped2com <- function(ped, component,
     iss <- readRDS(checkpoint_files$iss)
     list_of_adjacencies <- list(iss = iss, jss = jss)
   } else {
+    if (verbose) cat("Computing parent-child adjacency matrix...\n")
     list_of_adjacencies <- computeParentAdjacency(
       ped = ped,
       save_rate_parlist = save_rate_parlist,
@@ -183,36 +191,27 @@ ped2com <- function(ped, component,
       gc()
     }
   }
-  # Set parent values depending on the component type
-  if (component %in% c("generation", "additive")) {
-    parVal <- .5
-  } else if (component %in% c("common nuclear", "mitochondrial")) {
-    parVal <- 1
-  } else {
-    stop("Don't know how to set parental value")
-  }
+
+  # Assign parent values based on the component type
+  parVal <- assignParentValue(component = component, verbose = verbose,...)
+
   # Construct sparse matrix
-  if (resume && file.exists(checkpoint_files$isPar)) {
-    if (verbose) cat("Resuming: Loading adjacency matrix...\n")
-    isPar <- readRDS(checkpoint_files$isPar)
-  } else {
-    # Initialize adjacency matrix for parent-child relationships
-    isPar <- Matrix::sparseMatrix(
-      i = iss,
-      j = jss,
-      x = parVal,
-      dims = c(nr, nr),
-      dimnames = list(ped$ID, ped$ID)
-    )
-    if (verbose) {
-      cat("Completed first degree relatives (adjacency)\n")
-    }
-    if (saveable) {
-      saveRDS(isPar, file = checkpoint_files$isPar)
-    }
+  # Initialize adjacency matrix for parent-child relationships
+  isPar <-  loadOrComputeIsPar(
+    iss = iss,
+    jss = jss,
+    parVal = parVal,
+    nr = nr,
+    ped = ped,
+    checkpoint_files = checkpoint_files,
+    config = config
+  )
+  if (verbose) {
+    cat("Completed first degree relatives (adjacency)\n")
   }
 
-  # isPar is the adjacency matrix.  'A' matrix from RAM
+   # isPar is the adjacency matrix.  'A' matrix from RAM
+
   if (component %in% c("common nuclear")) {
     Matrix::diag(isPar) <- 1
     if (sparse == FALSE) {
@@ -353,7 +352,7 @@ ped2add <- function(ped, max.gen = 25, sparse = TRUE, verbose = FALSE,
                     resume = FALSE,
                     save_rate = 5,
                     save_rate_gen = save_rate,
-                    save_rate_parlist = 1000 * save_rate,
+                    save_rate_parlist = 100000 * save_rate,
                     save_path = "checkpoint/",
                     ...) {
   ped2com(
@@ -392,7 +391,7 @@ ped2mit <- ped2mt <- function(ped, max.gen = 25,
                               resume = FALSE,
                               save_rate = 5,
                               save_rate_gen = save_rate,
-                              save_rate_parlist = 1000 * save_rate,
+                              save_rate_parlist = 100000 * save_rate,
                               save_path = "checkpoint/",
                               ...) {
   ped2com(
@@ -456,8 +455,7 @@ ped2cn <- function(ped, max.gen = 25, sparse = TRUE, verbose = FALSE,
 #' @inherit ped2com details
 #' @export
 #'
-ped2ce <- function(ped,
-                   ...) {
+ped2ce <- function(ped,...) {
   matrix(1, nrow = nrow(ped), ncol = nrow(ped), dimnames = list(ped$ID, ped$ID))
 }
 
@@ -503,3 +501,96 @@ ped2ce <- function(ped,
 
   return(result)
 }
+
+#' Initialize checkpoint files
+#' @inheritParams ped2com
+#' @keyword internal
+
+initializeCheckpoint <- function(config= list(verbose = FALSE,
+       saveable = FALSE,
+       resume = FALSE,
+       save_path = "checkpoint/")) {
+  # Define checkpoint files
+  # Ensure save path exists
+  if (config$saveable && !dir.exists(config$save_path)) {
+    if (config$verbose) cat("Creating save path...\n")
+    dir.create(config$save_path, recursive = TRUE)
+  } else if (config$resume && !dir.exists(config$save_path)) {
+    stop("Cannot resume from checkpoint. Save path does not exist.")
+  }
+
+  checkpoint_files <- list(
+    parList = file.path(config$save_path, "parList.rds"),
+    lens = file.path(config$save_path, "lens.rds"),
+    isPar = file.path(config$save_path, "isPar.rds"),
+    iss = file.path(config$save_path, "iss.rds"),
+    jss = file.path(config$save_path, "jss.rds"),
+    isChild = file.path(config$save_path, "isChild.rds"),
+    r_checkpoint = file.path(config$save_path, "r_checkpoint.rds"),
+    gen_checkpoint = file.path(config$save_path, "gen_checkpoint.rds"),
+    newIsPar_checkpoint = file.path(config$save_path, "newIsPar_checkpoint.rds"),
+    mtSum_checkpoint = file.path(config$save_path, "mtSum_checkpoint.rds"),
+    r2_checkpoint = file.path(config$save_path, "r2_checkpoint.rds"),
+    tcrossprod_checkpoint = file.path(config$save_path, "tcrossprod_checkpoint.rds"),
+    count_checkpoint = file.path(config$save_path, "count_checkpoint.rds"),
+    final_matrix = file.path(config$save_path, "final_matrix.rds")
+  )
+
+  return(checkpoint_files)
+}
+
+
+assignParentValue<- function(component = component, verbose = verbose){
+
+# Set parent values depending on the component type
+if (component %in% c("generation", "additive")) {
+  parVal <- .5
+} else if (component %in% c("common nuclear", "mitochondrial")) {
+  parVal <- 1
+} else {
+  stop("Don't know how to set parental value")
+}
+return(parVal)
+}
+
+#' Load or compute a checkpoint
+#' @param file The file path to load the checkpoint from.
+#' @param compute_fn The function to compute the checkpoint if it doesn't exist.
+#' @param config A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.
+#' @param message_resume Optional message to display when resuming from a checkpoint.
+#' @param message_compute Optional message to display when computing the checkpoint.
+#' @return The loaded or computed checkpoint.
+#' @keyword internal
+loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = NULL, message_compute = NULL) {
+  if (config$resume && file.exists(file)) {
+    if (config$verbose && !is.null(message_resume)) cat(message_resume)
+    return(readRDS(file))
+  } else {
+    if (config$verbose && !is.null(message_compute)) cat(message_compute)
+    result <- compute_fn()
+    if (config$saveable) saveRDS(result, file = file)
+    return(result)
+  }
+}
+
+#' Load or compute the isPar matrix
+#' @inheritParams loadOrComputeCheckpoint
+#' @inheritParams ped2com
+#'
+#' @keyword internal
+loadOrComputeIsPar <- function(iss, jss, parVal, nr, ped, checkpoint_files, config) {
+  isPar <- loadOrComputeCheckpoint(
+    file = checkpoint_files$isPar,
+    compute_fn = function() Matrix::sparseMatrix(
+      i = iss, j = jss, x = parVal,
+      dims = c(nr, nr),
+      dimnames = list(ped$ID, ped$ID)
+    ),
+    config = config,
+    message_resume = "Resuming: Loading adjacency matrix...\n",
+    message_compute = "Initializing adjacency matrix...\n"
+  )
+
+  return(isPar)
+
+}
diff --git a/R/calculateRelatedness.R b/R/calculateRelatedness.R
index d1da241d..da7336e3 100644
--- a/R/calculateRelatedness.R
+++ b/R/calculateRelatedness.R
@@ -107,6 +107,7 @@ inferRelatedness <- function(obsR, aceA = .9, aceC = 0, sharedC = 0) {
 }
 
 #' @rdname inferRelatedness
+#' @keywords internal
 relatedness <- function(...) {
   warning("The 'relatedness' function is deprecated. Please use 'inferRelatedness' instead.")
   inferRelatedness(...)

From 305d186156c0ce83f3bd841f6386d0eacf992a37 Mon Sep 17 00:00:00 2001
From: Mason Garrison 
Date: Tue, 22 Apr 2025 13:15:13 -0400
Subject: [PATCH 64/69] Update buildComponent.R

---
 R/buildComponent.R | 83 ++++++++++++++++++++++++++++++++--------------
 1 file changed, 58 insertions(+), 25 deletions(-)

diff --git a/R/buildComponent.R b/R/buildComponent.R
index 58c2f27e..4d9a31ce 100644
--- a/R/buildComponent.R
+++ b/R/buildComponent.R
@@ -129,20 +129,13 @@ ped2com <- function(ped, component,
   # Step 1: Construct parent-child adjacency matrix
 
   ## A. Resume from Checkpoint if Needed
-  if (resume && file.exists(checkpoint_files$parList) && file.exists(checkpoint_files$lens)) {
-    if (verbose) cat("Resuming: Loading parent-child adjacency data...\n")
-    parList <- readRDS(checkpoint_files$parList)
-    lens <- readRDS(checkpoint_files$lens)
-    computed_indices <- which(!sapply(parList, is.null))
-    lastComputed <- if (length(computed_indices) > 0) max(computed_indices) else 0
-    if (verbose) cat("Resuming from iteration", lastComputed + 1, "\n")
-  } else {
-    ## Initialize variables
-    parList <- vector("list", nr)
-    lens <- integer(nr)
-    lastComputed <- 0
-    if (verbose) cat("Building parent adjacency matrix...\n")
-  }
+  ## Initialize variables
+  ParList_prep <-  resumeParList(checkpoint_files = checkpoint_files, config = config,nr=nr)
+  parList <- ParList_prep$parList
+  lens <- ParList_prep$lens
+  lastComputed <- ParList_prep$lastComputed
+
+  remove(ParList_prep)
 
 
   ## B. Resume loop from the next uncomputed index
@@ -220,18 +213,12 @@ ped2com <- function(ped, component,
     return(isPar)
   }
 
-  if (resume && file.exists(checkpoint_files$isChild)) {
-    if (verbose) cat("Resuming: Loading isChild matrix...\n")
-    isChild <- readRDS(checkpoint_files$isChild)
-  } else {
     # isChild is the 'S' matrix from RAM
-
-    isChild <- isChild(isChild_method = isChild_method, ped = ped)
-
-    if (saveable) {
-      saveRDS(isChild, file = checkpoint_files$isChild)
-    }
-  }
+  isChild <- loadOrComputeIsChild(
+    ped = ped,
+    checkpoint_files = checkpoint_files,
+    config = config
+  )
   # --- Step 2: Compute Relatedness Matrix ---
 
 
@@ -594,3 +581,49 @@ loadOrComputeIsPar <- function(iss, jss, parVal, nr, ped, checkpoint_files, conf
   return(isPar)
 
 }
+
+#' Load or compute the isChild matrix
+#' @inheritParams loadOrComputeCheckpoint
+#' @inheritParams ped2com
+#'
+#'  @keyword internal
+
+loadOrComputeIsChild <- function(ped, checkpoint_files, config) {
+  isChild <- loadOrComputeCheckpoint(
+    file = checkpoint_files$isChild,
+    compute_fn = function() isChild(isChild_method = config$isChild_method, ped = ped),
+    config = config,
+    message_resume = "Resuming: Loading isChild matrix...\n",
+    message_compute = "Computing isChild matrix...\n"
+  )
+
+  return(isChild)
+}
+
+
+#' parent-child adjacency data
+#' @inheritParams loadOrComputeCheckpoint
+#' @inheritParams ped2com
+#' @keyword internal
+
+#' @return A list containing the parent-child adjacency data either loaded from a checkpoint or initialized.
+#'
+
+resumeParList <- function(checkpoint_files, config, lastComputed, nr) {
+  if (config$resume && file.exists(checkpoint_files$parList) && file.exists(checkpoint_files$lens)) {
+    if (config$verbose) cat("Resuming: Loading parent-child adjacency data...\n")
+    parList <- readRDS(checkpoint_files$parList)
+    lens <- readRDS(checkpoint_files$lens)
+    computed_indices <- which(!sapply(parList, is.null))
+    lastComputed <- if (length(computed_indices) > 0) max(computed_indices) else 0
+    if (config$verbose) cat("Resuming from iteration", lastComputed + 1, "\n")
+  } else {
+    ## Initialize variables
+    parList <- vector("list", nr)
+    lens <- integer(nr)
+    lastComputed <- 0
+    if (config$verbose) cat("Building parent adjacency matrix...\n")
+  }
+  return(list(parList = parList, lens = lens, lastComputed = lastComputed))
+}
+

From bae130a4fcb1a4b525628be90aac28cb3a26f23c Mon Sep 17 00:00:00 2001
From: Mason Garrison 
Date: Tue, 22 Apr 2025 18:30:02 -0400
Subject: [PATCH 65/69] renaming

---
 R/buildComponent.R                            | 142 ++++++++++--------
 R/makeLinkslegacy.R                           |   6 +-
 R/readGedcomlegacy.R                          |  82 +++++-----
 man/combine_columns.Rd                        |   8 +-
 ....legacy.Rd => dot-collapseNames.legacy.Rd} |   6 +-
 ...inks.legacy.Rd => dot-com2links.legacy.Rd} |   6 +-
 man/{com2links.og.Rd => dot-com2links.og.Rd}  |   6 +-
 man/dot-combine_columns.legacy.Rd             |  20 +++
 ...gacy.Rd => dot-countPatternRows.legacy.Rd} |   6 +-
 ...o.legacy.Rd => dot-extract_info.legacy.Rd} |   6 +-
 man/dot-loadOrComputeIsChild.Rd               |  20 +++
 man/dot-loadOrComputeIsPar.Rd                 |  27 ++++
 ...egacy.Rd => dot-mapFAMC2parents.legacy.Rd} |   6 +-
 ...egacy.Rd => dot-mapFAMS2parents.legacy.Rd} |   6 +-
 ...acy.Rd => dot-postProcessGedcom.legacy.Rd} |   6 +-
 ...legacy.Rd => dot-processParents.legacy.Rd} |   6 +-
 ...ag.legacy.Rd => dot-process_tag.legacy.Rd} |   6 +-
 ...com.legacy.Rd => dot-readGedcom.legacy.Rd} |   6 +-
 man/inferRelatedness.Rd                       |   1 +
 man/initializeCheckpoint.Rd                   |  15 ++
 man/loadOrComputeCheckpoint.Rd                |  32 ++++
 man/loadOrComputeParList.Rd                   |  35 +++++
 man/ped2add.Rd                                |   2 +-
 man/ped2mit.Rd                                |   2 +-
 tests/testthat/test-makeLinks.R               |   8 +-
 tests/testthat/test-readPedigrees.R           |  18 ++-
 26 files changed, 328 insertions(+), 156 deletions(-)
 rename man/{collapseNames.legacy.Rd => dot-collapseNames.legacy.Rd} (80%)
 rename man/{com2links.legacy.Rd => dot-com2links.legacy.Rd} (96%)
 rename man/{com2links.og.Rd => dot-com2links.og.Rd} (95%)
 create mode 100644 man/dot-combine_columns.legacy.Rd
 rename man/{countPatternRows.legacy.Rd => dot-countPatternRows.legacy.Rd} (79%)
 rename man/{extract_info.legacy.Rd => dot-extract_info.legacy.Rd} (84%)
 create mode 100644 man/dot-loadOrComputeIsChild.Rd
 create mode 100644 man/dot-loadOrComputeIsPar.Rd
 rename man/{mapFAMC2parents.legacy.Rd => dot-mapFAMC2parents.legacy.Rd} (82%)
 rename man/{mapFAMS2parents.legacy.Rd => dot-mapFAMS2parents.legacy.Rd} (80%)
 rename man/{postProcessGedcom.legacy.Rd => dot-postProcessGedcom.legacy.Rd} (90%)
 rename man/{processParents.legacy.Rd => dot-processParents.legacy.Rd} (78%)
 rename man/{process_tag.legacy.Rd => dot-process_tag.legacy.Rd} (91%)
 rename man/{readGedcom.legacy.Rd => dot-readGedcom.legacy.Rd} (97%)
 create mode 100644 man/initializeCheckpoint.Rd
 create mode 100644 man/loadOrComputeCheckpoint.Rd
 create mode 100644 man/loadOrComputeParList.Rd

diff --git a/R/buildComponent.R b/R/buildComponent.R
index 4d9a31ce..346ce907 100644
--- a/R/buildComponent.R
+++ b/R/buildComponent.R
@@ -64,7 +64,8 @@ ped2com <- function(ped, component,
                  save_rate_parlist = save_rate_parlist,
                  update_rate = update_rate,
                  gc = gc,
-                 component =component
+                 component =component,
+                 adjBeta_method = adjBeta_method
                  )
 
 
@@ -104,7 +105,7 @@ ped2com <- function(ped, component,
 
   # standardize colnames
   if (standardize.colnames) {
-    ped <- standardizeColnames(ped, verbose = verbose)
+    ped <- standardizeColnames(ped, verbose = config$verbose)
   }
 
   # Load final result if computation was completed
@@ -130,69 +131,29 @@ ped2com <- function(ped, component,
 
   ## A. Resume from Checkpoint if Needed
   ## Initialize variables
-  ParList_prep <-  resumeParList(checkpoint_files = checkpoint_files, config = config,nr=nr)
-  parList <- ParList_prep$parList
-  lens <- ParList_prep$lens
-  lastComputed <- ParList_prep$lastComputed
-
-  remove(ParList_prep)
+  list_of_adjacencies <-   loadOrComputeParList(checkpoint_files = checkpoint_files,
+                                                 ped = ped,
+                                                 config = config,
+                                                 nr=nr)
 
 
   ## B. Resume loop from the next uncomputed index
 
 
   # Construct sparse matrix
-  if (resume && file.exists(checkpoint_files$iss) && file.exists(checkpoint_files$jss)) { # fix to check actual
-    if (verbose) cat("Resuming: Constructed matrix...\n")
-    jss <- readRDS(checkpoint_files$jss)
-    iss <- readRDS(checkpoint_files$iss)
-    list_of_adjacencies <- list(iss = iss, jss = jss)
-  } else {
-    if (verbose) cat("Computing parent-child adjacency matrix...\n")
-    list_of_adjacencies <- computeParentAdjacency(
-      ped = ped,
-      save_rate_parlist = save_rate_parlist,
-      checkpoint_files = checkpoint_files,
-      component = component,
-      adjacency_method = adjacency_method, # adjacency_method,
-      saveable = saveable,
-      resume = resume,
-      save_path = save_path,
-      update_rate = update_rate,
-      verbose = verbose,
-      lastComputed = lastComputed,
-      nr = nr,
-      parList = parList,
-      lens = lens,
-      adjBeta_method = adjBeta_method
-    )
-
-    # Construct sparse matrix
-    iss <- list_of_adjacencies$iss
-    jss <- list_of_adjacencies$jss
-
-    if (verbose) {
-      cat("Constructed sparse matrix\n")
-    }
-    if (saveable) {
-      saveRDS(jss, file = checkpoint_files$jss)
-      saveRDS(iss, file = checkpoint_files$iss)
-    }
-    # Garbage collection if gc is TRUE
-    if (gc) {
-      rm(parList, lens, list_of_adjacencies)
-      gc()
-    }
-  }
+   # Garbage collection if gc is TRUE
+   if (config$gc) {
+     gc()
+   }
 
   # Assign parent values based on the component type
-  parVal <- assignParentValue(component = component, verbose = verbose,...)
+  parVal <- assignParentValue(component = config$component)
 
   # Construct sparse matrix
   # Initialize adjacency matrix for parent-child relationships
-  isPar <-  loadOrComputeIsPar(
-    iss = iss,
-    jss = jss,
+  isPar <-  .loadOrComputeIsPar(
+    iss =  list_of_adjacencies$iss,
+    jss =  list_of_adjacencies$jss,
     parVal = parVal,
     nr = nr,
     ped = ped,
@@ -214,7 +175,7 @@ ped2com <- function(ped, component,
   }
 
     # isChild is the 'S' matrix from RAM
-  isChild <- loadOrComputeIsChild(
+  isChild <- .loadOrComputeIsChild(
     ped = ped,
     checkpoint_files = checkpoint_files,
     config = config
@@ -491,7 +452,7 @@ ped2ce <- function(ped,...) {
 
 #' Initialize checkpoint files
 #' @inheritParams ped2com
-#' @keyword internal
+#' @keywords internal
 
 initializeCheckpoint <- function(config= list(verbose = FALSE,
        saveable = FALSE,
@@ -527,7 +488,7 @@ initializeCheckpoint <- function(config= list(verbose = FALSE,
 }
 
 
-assignParentValue<- function(component = component, verbose = verbose){
+assignParentValue<- function(component){
 
 # Set parent values depending on the component type
 if (component %in% c("generation", "additive")) {
@@ -547,7 +508,7 @@ return(parVal)
 #' @param message_resume Optional message to display when resuming from a checkpoint.
 #' @param message_compute Optional message to display when computing the checkpoint.
 #' @return The loaded or computed checkpoint.
-#' @keyword internal
+#' @keywords internal
 loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = NULL, message_compute = NULL) {
   if (config$resume && file.exists(file)) {
     if (config$verbose && !is.null(message_resume)) cat(message_resume)
@@ -563,9 +524,15 @@ loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = N
 #' Load or compute the isPar matrix
 #' @inheritParams loadOrComputeCheckpoint
 #' @inheritParams ped2com
+#' @param iss The row indices of the sparse matrix.
+#' @param jss The column indices of the sparse matrix.
+#' @param parVal The value to assign to the non-zero elements of the sparse matrix.
+#' @param nr The number of rows in the sparse matrix.
+#' @param ped The pedigree dataset.
+#' @param checkpoint_files A list of checkpoint file paths.
 #'
-#' @keyword internal
-loadOrComputeIsPar <- function(iss, jss, parVal, nr, ped, checkpoint_files, config) {
+#' @keywords internal
+.loadOrComputeIsPar <- function(iss, jss, parVal, nr, ped, checkpoint_files, config) {
   isPar <- loadOrComputeCheckpoint(
     file = checkpoint_files$isPar,
     compute_fn = function() Matrix::sparseMatrix(
@@ -585,10 +552,12 @@ loadOrComputeIsPar <- function(iss, jss, parVal, nr, ped, checkpoint_files, conf
 #' Load or compute the isChild matrix
 #' @inheritParams loadOrComputeCheckpoint
 #' @inheritParams ped2com
+#' @param checkpoint_files A list of checkpoint file paths.
+#' @param config A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.
 #'
-#'  @keyword internal
+#'  @keywords internal
 
-loadOrComputeIsChild <- function(ped, checkpoint_files, config) {
+.loadOrComputeIsChild <- function(ped, checkpoint_files, config) {
   isChild <- loadOrComputeCheckpoint(
     file = checkpoint_files$isChild,
     compute_fn = function() isChild(isChild_method = config$isChild_method, ped = ped),
@@ -604,12 +573,17 @@ loadOrComputeIsChild <- function(ped, checkpoint_files, config) {
 #' parent-child adjacency data
 #' @inheritParams loadOrComputeCheckpoint
 #' @inheritParams ped2com
-#' @keyword internal
+#' @param checkpoint_files A list of checkpoint file paths.
+#' @param config A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.
+#' @param nr The number of rows in the sparse matrix.
+#' @param parList A list of parent-child adjacency data.
+#' @param lens A vector of lengths for each parent-child relationship.
+#' @keywords internal
 
 #' @return A list containing the parent-child adjacency data either loaded from a checkpoint or initialized.
 #'
 
-resumeParList <- function(checkpoint_files, config, lastComputed, nr) {
+loadOrComputeParList <- function(checkpoint_files, config, nr, ped = NULL, parList = NULL, lens = NULL) {
   if (config$resume && file.exists(checkpoint_files$parList) && file.exists(checkpoint_files$lens)) {
     if (config$verbose) cat("Resuming: Loading parent-child adjacency data...\n")
     parList <- readRDS(checkpoint_files$parList)
@@ -624,6 +598,44 @@ resumeParList <- function(checkpoint_files, config, lastComputed, nr) {
     lastComputed <- 0
     if (config$verbose) cat("Building parent adjacency matrix...\n")
   }
-  return(list(parList = parList, lens = lens, lastComputed = lastComputed))
+
+  if (config$resume && file.exists(checkpoint_files$iss) && file.exists(checkpoint_files$jss)) { # fix to check actual
+    if (config$verbose) cat("Resuming: Constructed matrix...\n")
+    jss <- readRDS(checkpoint_files$jss)
+    iss <- readRDS(checkpoint_files$iss)
+    list_of_adjacencies <- list(iss = iss, jss = jss)
+  } else {
+    if (config$verbose) cat("Computing parent-child adjacency matrix...\n")
+    list_of_adjacencies <- computeParentAdjacency(
+      ped = ped,
+      save_rate_parlist = config$save_rate_parlist,
+      checkpoint_files = checkpoint_files,
+      component = config$component,
+      adjacency_method = config$adjacency_method, # adjacency_method,
+      saveable = config$saveable,
+      resume = config$resume,
+      save_path = config$save_path,
+      update_rate = config$update_rate,
+      verbose = config$verbose,
+      lastComputed = lastComputed,
+      nr = nr,
+      parList = parList,
+      lens = lens,
+      adjBeta_method = config$adjBeta_method
+    )
+
+    # Construct sparse matrix
+
+
+    if (config$verbose) {
+      cat("Constructed sparse matrix\n")
+    }
+    if (config$saveable) {
+      saveRDS(list_of_adjacencies$jss, file = checkpoint_files$jss)
+      saveRDS(list_of_adjacencies$iss, file = checkpoint_files$iss)
+    }
+
+  }
+return(list_of_adjacencies)
 }
 
diff --git a/R/makeLinkslegacy.R b/R/makeLinkslegacy.R
index 23265d05..686c9f5a 100644
--- a/R/makeLinkslegacy.R
+++ b/R/makeLinkslegacy.R
@@ -3,7 +3,7 @@
 #' @keywords internal
 
 
-com2links.legacy <- function(
+.com2links.legacy <- function(
     rel_pairs_file = "dataRelatedPairs.csv",
     ad_ped_matrix = NULL,
     mit_ped_matrix = mt_ped_matrix,
@@ -480,7 +480,7 @@ com2links.legacy <- function(
   } else if (legacy) {
     # --- Legacy Mode ---
     # In legacy mode, convert matrices to the expected symmetric formats.
-    com2links.og(
+    .com2links.og(
       rel_pairs_file = rel_pairs_file,
       ad_ped_matrix = ad_ped_matrix,
       mit_ped_matrix = mit_ped_matrix,
@@ -507,7 +507,7 @@ com2links.legacy <- function(
 #' @keywords internal
 
 
-com2links.og <- function(
+.com2links.og <- function(
     rel_pairs_file = "dataRelatedPairs.csv",
     ad_ped_matrix = NULL,
     mit_ped_matrix = mt_ped_matrix,
diff --git a/R/readGedcomlegacy.R b/R/readGedcomlegacy.R
index 8221197a..d6b65948 100644
--- a/R/readGedcomlegacy.R
+++ b/R/readGedcomlegacy.R
@@ -48,7 +48,7 @@
 #' - `FAMC`: ID(s) of the family where the individual is a child
 #' - `FAMS`: ID(s) of the family where the individual is a spouse
 #' @keywords internal
-readGedcom.legacy <- function(file_path,
+.readGedcom.legacy <- function(file_path,
                               verbose = FALSE,
                               add_parents = TRUE,
                               remove_empty_cols = TRUE,
@@ -69,7 +69,7 @@ readGedcom.legacy <- function(file_path,
   }
 
   # Count the number of rows containing specific patterns
-  num_rows <- countPatternRows.legacy(file)
+  num_rows <- .countPatternRows.legacy(file)
 
   # List of variables to initialize
   var_names <- list(
@@ -128,51 +128,51 @@ readGedcom.legacy <- function(file_path,
 
     # names
     if (num_rows$num_name_rows > 0 && grepl(" NAME", tmpv)) {
-      vars$name <- extract_info.legacy(tmpv, "NAME")
+      vars$name <- .extract_info.legacy(tmpv, "NAME")
       vars$name_given <- stringr::str_extract(vars$name, ".*(?= /)")
       vars$name_surn <- stringr::str_extract(vars$name, "(?<=/).*(?=/)")
       vars$name <- stringr::str_squish(stringr::str_replace(vars$name, "/", " "))
       next
     }
     # PERSONAL_NAME_PIECES := NAME | NPFX | GIVN | NICK | SPFX | SURN | NSFX
-    result <- process_tag.legacy("GIVN", "name_given_pieces", num_rows, tmpv, vars)
+    result <- .process_tag.legacy("GIVN", "name_given_pieces", num_rows, tmpv, vars)
     vars <- result$vars
     if (result$matched) next
 
     # npfx := Name Prefix
-    result <- process_tag.legacy("NPFX", "name_npfx", num_rows, tmpv, vars)
+    result <- .process_tag.legacy("NPFX", "name_npfx", num_rows, tmpv, vars)
     vars <- result$vars
     if (result$matched) next
 
     # NICK := Nickname
-    result <- process_tag.legacy("NICK", "name_nick", num_rows, tmpv, vars)
+    result <- .process_tag.legacy("NICK", "name_nick", num_rows, tmpv, vars)
     vars <- result$vars
     if (result$matched) next
 
     # surn := Surname
-    result <- process_tag.legacy("SURN", "name_surn_pieces", num_rows, tmpv, vars)
+    result <- .process_tag.legacy("SURN", "name_surn_pieces", num_rows, tmpv, vars)
     vars <- result$vars
     if (result$matched) next
 
     # nsfx := Name suffix
-    result <- process_tag.legacy("NSFX", "name_nsfx", num_rows, tmpv, vars)
+    result <- .process_tag.legacy("NSFX", "name_nsfx", num_rows, tmpv, vars)
     vars <- result$vars
     if (result$matched) next
 
-    result <- process_tag.legacy("_MARNM", "name_marriedsurn", num_rows, tmpv, vars)
+    result <- .process_tag.legacy("_MARNM", "name_marriedsurn", num_rows, tmpv, vars)
     vars <- result$vars
     if (result$matched) next
 
     # Birth event related information
     if (num_rows$num_birt_rows > 0 && grepl(" BIRT", tmpv)) {
       if (num_rows$num_date_rows > 0 && i + 1 <= file_length) {
-        vars$birth_date <- extract_info.legacy(file[1][[1]][[i + 1]], "DATE")
+        vars$birth_date <- .extract_info.legacy(file[1][[1]][[i + 1]], "DATE")
         if (num_rows$num_plac_rows > 0 && i + 2 <= file_length) {
-          vars$birth_place <- extract_info.legacy(file[1][[1]][[i + 2]], "PLAC")
+          vars$birth_place <- .extract_info.legacy(file[1][[1]][[i + 2]], "PLAC")
           if (num_rows$num_lati_rows > 0 && i + 4 <= file_length) {
-            vars$birth_lat <- extract_info.legacy(file[1][[1]][[i + 4]], "LATI")
+            vars$birth_lat <- .extract_info.legacy(file[1][[1]][[i + 4]], "LATI")
             if (num_rows$num_long_rows > 0 && i + 5 <= file_length) {
-              vars$birth_long <- extract_info.legacy(file[1][[1]][[i + 5]], "LONG")
+              vars$birth_long <- .extract_info.legacy(file[1][[1]][[i + 5]], "LONG")
             }
           }
         }
@@ -184,15 +184,15 @@ readGedcom.legacy <- function(file_path,
     # the ifs are nested so that there is no need to check if you've already run out of
     if (num_rows$num_deat_rows > 0 && grepl(" DEAT", tmpv)) {
       if (num_rows$num_date_rows > 0 && i + 1 <= file_length) {
-        vars$death_date <- extract_info.legacy(file[1][[1]][[i + 1]], "DATE")
+        vars$death_date <- .extract_info.legacy(file[1][[1]][[i + 1]], "DATE")
         if (num_rows$num_plac_rows > 0 && i + 2 <= file_length) {
-          vars$death_place <- extract_info.legacy(file[1][[1]][[i + 2]], "PLAC")
+          vars$death_place <- .extract_info.legacy(file[1][[1]][[i + 2]], "PLAC")
           if (num_rows$num_caus_rows > 0 && i + 3 <= file_length) {
-            vars$death_caus <- extract_info.legacy(file[1][[1]][[i + 3]], "CAUS")
+            vars$death_caus <- .extract_info.legacy(file[1][[1]][[i + 3]], "CAUS")
             if (num_rows$num_lati_rows > 0 && i + 4 <= file_length) {
-              vars$death_lat <- extract_info.legacy(file[1][[1]][[i + 4]], "LATI")
+              vars$death_lat <- .extract_info.legacy(file[1][[1]][[i + 4]], "LATI")
               if (num_rows$num_long_rows > 0 && i + 5 <= file_length) {
-                vars$death_long <- extract_info.legacy(file[1][[1]][[i + 5]], "LONG")
+                vars$death_long <- .extract_info.legacy(file[1][[1]][[i + 5]], "LONG")
               }
             }
           }
@@ -258,7 +258,7 @@ readGedcom.legacy <- function(file_path,
       # g7:INDI-TITL	A formal designation used by an individual in connection with positions of royalty or other social status, such as Grand Duke.
       c("TITL", "attribute_title")
     )) {
-      result <- process_tag.legacy(tag_field[1], tag_field[2], num_rows, tmpv, vars)
+      result <- .process_tag.legacy(tag_field[1], tag_field[2], num_rows, tmpv, vars)
       vars <- result$vars
       if (result$matched) next
     }
@@ -266,7 +266,7 @@ readGedcom.legacy <- function(file_path,
     # relationship data
     # g7:INDI-FAMC
     ## The family in which an individual appears as a child. It is also used with a g7:FAMC-STAT substructure to show individuals who are not children of the family. See FAMILY_RECORD for more details.
-    result <- process_tag.legacy("FAMC", "FAMC", num_rows, tmpv, vars,
+    result <- .process_tag.legacy("FAMC", "FAMC", num_rows, tmpv, vars,
       extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)"),
       mode = "append"
     )
@@ -275,7 +275,7 @@ readGedcom.legacy <- function(file_path,
 
     # FAMS (Family spouse) g7:FAMS
     #  The family in which an individual appears as a partner. See FAMILY_RECORD for more details.
-    result <- process_tag.legacy("FAMS", "FAMS", num_rows, tmpv, vars,
+    result <- .process_tag.legacy("FAMS", "FAMS", num_rows, tmpv, vars,
       extractor = function(x) stringr::str_extract(x, "(?<=@.)\\d*(?=@)"),
       mode = "append"
     )
@@ -307,7 +307,7 @@ readGedcom.legacy <- function(file_path,
       print("Post-processing data frame")
     }
     # Remove the first row (empty)
-    df_temp <- postProcessGedcom.legacy(
+    df_temp <- .postProcessGedcom.legacy(
       df_temp = df_temp,
       remove_empty_cols = remove_empty_cols,
       combine_cols = combine_cols,
@@ -322,11 +322,11 @@ readGedcom.legacy <- function(file_path,
 
 #' Post-process GEDCOM Data Frame
 #'
-#' @inheritParams readGedcom.legacy
-#' @inheritParams mapFAMS2parents.legacy
+#' @inheritParams .readGedcom.legacy
+#' @inheritParams .mapFAMS2parents.legacy
 #' @return A data frame with processed information.
 
-postProcessGedcom.legacy <- function(df_temp,
+.postProcessGedcom.legacy <- function(df_temp,
                                      remove_empty_cols = TRUE,
                                      combine_cols = TRUE,
                                      add_parents = TRUE,
@@ -337,11 +337,11 @@ postProcessGedcom.legacy <- function(df_temp,
     if (verbose) {
       print("Processing parents")
     }
-    df_temp <- processParents.legacy(df_temp, datasource = "gedcom")
+    df_temp <- .processParents.legacy(df_temp, datasource = "gedcom")
   }
 
   if (combine_cols) {
-    df_temp <- collapseNames.legacy(verbose = verbose, df_temp = df_temp)
+    df_temp <- .collapseNames.legacy(verbose = verbose, df_temp = df_temp)
   }
 
   if (remove_empty_cols) {
@@ -371,7 +371,7 @@ postProcessGedcom.legacy <- function(df_temp,
 #' @return A list mapping family IDs to parent IDs.
 #' @keywords internal
 #'
-mapFAMS2parents.legacy <- function(df_temp) {
+.mapFAMS2parents.legacy <- function(df_temp) {
   if (!all(c("FAMS", "sex") %in% colnames(df_temp))) {
     warning("The data frame does not contain the necessary columns (FAMS, sex)")
     return(NULL)
@@ -410,7 +410,7 @@ mapFAMS2parents.legacy <- function(df_temp) {
 #' @param family_to_parents A list mapping family IDs to parent IDs.
 #' @return A data frame with added momID and dad_ID columns.
 #' @keywords internal
-mapFAMC2parents.legacy <- function(df_temp, family_to_parents) {
+.mapFAMC2parents.legacy <- function(df_temp, family_to_parents) {
   df_temp$momID <- NA_character_
   df_temp$dadID <- NA_character_
   for (i in 1:nrow(df_temp)) {
@@ -438,7 +438,7 @@ mapFAMC2parents.legacy <- function(df_temp, family_to_parents) {
 #' @param df_temp A data frame containing information about individuals.
 #' @return A data frame with added momID and dadID columns.
 #' @keywords internal
-processParents.legacy <- function(df_temp, datasource) {
+.processParents.legacy <- function(df_temp, datasource) {
   # Ensure required columns are present
   if (datasource == "gedcom") {
     required_cols <- c("FAMC", "sex", "FAMS")
@@ -454,11 +454,11 @@ processParents.legacy <- function(df_temp, datasource) {
     return(df_temp)
   }
 
-  family_to_parents <- mapFAMS2parents.legacy(df_temp)
+  family_to_parents <- .mapFAMS2parents.legacy(df_temp)
   if (is.null(family_to_parents) || length(family_to_parents) == 0) {
     return(df_temp)
   }
-  df_temp <- mapFAMC2parents.legacy(df_temp, family_to_parents)
+  df_temp <- .mapFAMC2parents.legacy(df_temp, family_to_parents)
   return(df_temp)
 }
 
@@ -471,7 +471,7 @@ processParents.legacy <- function(df_temp, datasource) {
 #' @param type A character string representing the type of information to extract.
 #' @return A character string with the extracted information.
 #' @keywords internal
-extract_info.legacy <- function(line, type) {
+.extract_info.legacy <- function(line, type) {
   stringr::str_squish(stringr::str_extract(line, paste0("(?<=", type, " ).+")))
 }
 
@@ -483,7 +483,7 @@ extract_info.legacy <- function(line, type) {
 #' @return A list with the combined column and a flag indicating if the second column should be retained.
 #' @keywords internal
 # Helper function to check for conflicts and merge columns
-combine_columns <- function(col1, col2) {
+.combine_columns.legacy <- function(col1, col2) {
   col1_lower <- stringr::str_to_lower(col1)
   col2_lower <- stringr::str_to_lower(col2)
 
@@ -506,7 +506,7 @@ combine_columns <- function(col1, col2) {
 #' @return A list with the number of rows containing each pattern.
 #' @keywords internal
 #'
-countPatternRows.legacy <- function(file) {
+.countPatternRows.legacy <- function(file) {
   # Count the number of rows containing specific patterns
   pattern_counts <- sapply(
     c(
@@ -566,14 +566,14 @@ countPatternRows.legacy <- function(file) {
 #' @return A list with updated `vars` and a `matched` flag.
 #' @keywords internal
 #'
-process_tag.legacy <- function(tag, field_name, pattern_rows, line, vars,
+.process_tag.legacy <- function(tag, field_name, pattern_rows, line, vars,
                                extractor = NULL, mode = "replace") {
   count_name <- paste0("num_", tolower(tag), "_rows")
   matched <- FALSE
   if (!is.null(pattern_rows[[count_name]]) &&
     pattern_rows[[count_name]] > 0 &&
     grepl(paste0(" ", tag), line)) {
-    value <- if (is.null(extractor)) extract_info.legacy(line, tag) else extractor(line)
+    value <- if (is.null(extractor)) .extract_info.legacy(line, tag) else extractor(line)
 
     if (mode == "append" && !is.na(vars[[field_name]])) {
       vars[[field_name]] <- paste0(vars[[field_name]], ", ", value)
@@ -590,10 +590,10 @@ process_tag.legacy <- function(tag, field_name, pattern_rows, line, vars,
 #'
 #' This function combines the `name_given` and `name_given_pieces` columns in a data frame.
 #'
-#' @inheritParams readGedcom.legacy
+#' @inheritParams .readGedcom.legacy
 #' @param df_temp A data frame containing the columns to be combined.
 #' @keywords internal
-collapseNames.legacy <- function(verbose, df_temp) {
+.collapseNames.legacy <- function(verbose, df_temp) {
   if (verbose) {
     print("Combining Duplicate Columns")
   }
@@ -602,7 +602,7 @@ collapseNames.legacy <- function(verbose, df_temp) {
 
   # Combine `name_given` and `name_given_pieces`
   if (!all(is.na(df_temp$name_given_pieces)) | !all(is.na(df_temp$name_given))) {
-    result <- combine_columns(df_temp$name_given, df_temp$name_given_pieces)
+    result <- .combine_columns.legacy(df_temp$name_given, df_temp$name_given_pieces)
     df_temp$name_given <- result$combined
     if (!result$retain_col2) {
       df_temp$name_given_pieces <- NULL
@@ -611,7 +611,7 @@ collapseNames.legacy <- function(verbose, df_temp) {
 
   # Combine `name_surn` and `name_surn_pieces`
   if (!all(is.na(df_temp$name_surn_pieces)) | !all(is.na(df_temp$name_surn))) {
-    result <- combine_columns(df_temp$name_surn, df_temp$name_surn_pieces)
+    result <- .combine_columns.legacy(df_temp$name_surn, df_temp$name_surn_pieces)
     df_temp$name_surn <- result$combined
     if (!result$retain_col2) {
       df_temp$name_surn_pieces <- NULL
diff --git a/man/combine_columns.Rd b/man/combine_columns.Rd
index 9ab750ef..43554b0b 100644
--- a/man/combine_columns.Rd
+++ b/man/combine_columns.Rd
@@ -1,11 +1,9 @@
 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/readGedcom.R, R/readGedcomlegacy.R
+% Please edit documentation in R/readGedcom.R
 \name{combine_columns}
 \alias{combine_columns}
 \title{Combine Columns}
 \usage{
-combine_columns(col1, col2)
-
 combine_columns(col1, col2)
 }
 \arguments{
@@ -14,13 +12,9 @@ combine_columns(col1, col2)
 \item{col2}{The second column to combine.}
 }
 \value{
-A list with the combined column and a flag indicating if the second column should be retained.
-
 A list with the combined column and a flag indicating if the second column should be retained.
 }
 \description{
-This function combines two columns, handling conflicts and merging non-conflicting data.
-
 This function combines two columns, handling conflicts and merging non-conflicting data.
 }
 \keyword{internal}
diff --git a/man/collapseNames.legacy.Rd b/man/dot-collapseNames.legacy.Rd
similarity index 80%
rename from man/collapseNames.legacy.Rd
rename to man/dot-collapseNames.legacy.Rd
index dbf12d7c..c127dfe0 100644
--- a/man/collapseNames.legacy.Rd
+++ b/man/dot-collapseNames.legacy.Rd
@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/readGedcomlegacy.R
-\name{collapseNames.legacy}
-\alias{collapseNames.legacy}
+\name{.collapseNames.legacy}
+\alias{.collapseNames.legacy}
 \title{collapse Names}
 \usage{
-collapseNames.legacy(verbose, df_temp)
+.collapseNames.legacy(verbose, df_temp)
 }
 \arguments{
 \item{verbose}{A logical value indicating whether to print messages.}
diff --git a/man/com2links.legacy.Rd b/man/dot-com2links.legacy.Rd
similarity index 96%
rename from man/com2links.legacy.Rd
rename to man/dot-com2links.legacy.Rd
index 4467dc85..b82497a9 100644
--- a/man/com2links.legacy.Rd
+++ b/man/dot-com2links.legacy.Rd
@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/makeLinkslegacy.R
-\name{com2links.legacy}
-\alias{com2links.legacy}
+\name{.com2links.legacy}
+\alias{.com2links.legacy}
 \title{Convert Sparse Relationship Matrices to Kinship Links}
 \usage{
-com2links.legacy(
+.com2links.legacy(
   rel_pairs_file = "dataRelatedPairs.csv",
   ad_ped_matrix = NULL,
   mit_ped_matrix = mt_ped_matrix,
diff --git a/man/com2links.og.Rd b/man/dot-com2links.og.Rd
similarity index 95%
rename from man/com2links.og.Rd
rename to man/dot-com2links.og.Rd
index e51c53cd..b87b70b2 100644
--- a/man/com2links.og.Rd
+++ b/man/dot-com2links.og.Rd
@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/makeLinkslegacy.R
-\name{com2links.og}
-\alias{com2links.og}
+\name{.com2links.og}
+\alias{.com2links.og}
 \title{Convert Pedigree Matrices to Related Pairs File (Legacy)}
 \usage{
-com2links.og(
+.com2links.og(
   rel_pairs_file = "dataRelatedPairs.csv",
   ad_ped_matrix = NULL,
   mit_ped_matrix = mt_ped_matrix,
diff --git a/man/dot-combine_columns.legacy.Rd b/man/dot-combine_columns.legacy.Rd
new file mode 100644
index 00000000..fffafda2
--- /dev/null
+++ b/man/dot-combine_columns.legacy.Rd
@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/readGedcomlegacy.R
+\name{.combine_columns.legacy}
+\alias{.combine_columns.legacy}
+\title{Combine Columns}
+\usage{
+.combine_columns.legacy(col1, col2)
+}
+\arguments{
+\item{col1}{The first column to combine.}
+
+\item{col2}{The second column to combine.}
+}
+\value{
+A list with the combined column and a flag indicating if the second column should be retained.
+}
+\description{
+This function combines two columns, handling conflicts and merging non-conflicting data.
+}
+\keyword{internal}
diff --git a/man/countPatternRows.legacy.Rd b/man/dot-countPatternRows.legacy.Rd
similarity index 79%
rename from man/countPatternRows.legacy.Rd
rename to man/dot-countPatternRows.legacy.Rd
index c55ccf85..8aba84fb 100644
--- a/man/countPatternRows.legacy.Rd
+++ b/man/dot-countPatternRows.legacy.Rd
@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/readGedcomlegacy.R
-\name{countPatternRows.legacy}
-\alias{countPatternRows.legacy}
+\name{.countPatternRows.legacy}
+\alias{.countPatternRows.legacy}
 \title{Check for Pattern Rows}
 \usage{
-countPatternRows.legacy(file)
+.countPatternRows.legacy(file)
 }
 \arguments{
 \item{file}{A data frame containing the GEDCOM file.}
diff --git a/man/extract_info.legacy.Rd b/man/dot-extract_info.legacy.Rd
similarity index 84%
rename from man/extract_info.legacy.Rd
rename to man/dot-extract_info.legacy.Rd
index 23ac5bd8..6ebf6180 100644
--- a/man/extract_info.legacy.Rd
+++ b/man/dot-extract_info.legacy.Rd
@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/readGedcomlegacy.R
-\name{extract_info.legacy}
-\alias{extract_info.legacy}
+\name{.extract_info.legacy}
+\alias{.extract_info.legacy}
 \title{Extract Information from Line}
 \usage{
-extract_info.legacy(line, type)
+.extract_info.legacy(line, type)
 }
 \arguments{
 \item{line}{A character string representing a line from a GEDCOM file.}
diff --git a/man/dot-loadOrComputeIsChild.Rd b/man/dot-loadOrComputeIsChild.Rd
new file mode 100644
index 00000000..58205d04
--- /dev/null
+++ b/man/dot-loadOrComputeIsChild.Rd
@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/buildComponent.R
+\name{.loadOrComputeIsChild}
+\alias{.loadOrComputeIsChild}
+\title{Load or compute the isChild matrix}
+\usage{
+.loadOrComputeIsChild(ped, checkpoint_files, config)
+}
+\arguments{
+\item{ped}{a pedigree dataset.  Needs ID, momID, and dadID columns}
+
+\item{checkpoint_files}{A list of checkpoint file paths.}
+
+\item{config}{A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.
+
+ @keywords internal}
+}
+\description{
+Load or compute the isChild matrix
+}
diff --git a/man/dot-loadOrComputeIsPar.Rd b/man/dot-loadOrComputeIsPar.Rd
new file mode 100644
index 00000000..e4222523
--- /dev/null
+++ b/man/dot-loadOrComputeIsPar.Rd
@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/buildComponent.R
+\name{.loadOrComputeIsPar}
+\alias{.loadOrComputeIsPar}
+\title{Load or compute the isPar matrix}
+\usage{
+.loadOrComputeIsPar(iss, jss, parVal, nr, ped, checkpoint_files, config)
+}
+\arguments{
+\item{iss}{The row indices of the sparse matrix.}
+
+\item{jss}{The column indices of the sparse matrix.}
+
+\item{parVal}{The value to assign to the non-zero elements of the sparse matrix.}
+
+\item{nr}{The number of rows in the sparse matrix.}
+
+\item{ped}{The pedigree dataset.}
+
+\item{checkpoint_files}{A list of checkpoint file paths.}
+
+\item{config}{A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.}
+}
+\description{
+Load or compute the isPar matrix
+}
+\keyword{internal}
diff --git a/man/mapFAMC2parents.legacy.Rd b/man/dot-mapFAMC2parents.legacy.Rd
similarity index 82%
rename from man/mapFAMC2parents.legacy.Rd
rename to man/dot-mapFAMC2parents.legacy.Rd
index f3166e4f..11109e6e 100644
--- a/man/mapFAMC2parents.legacy.Rd
+++ b/man/dot-mapFAMC2parents.legacy.Rd
@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/readGedcomlegacy.R
-\name{mapFAMC2parents.legacy}
-\alias{mapFAMC2parents.legacy}
+\name{.mapFAMC2parents.legacy}
+\alias{.mapFAMC2parents.legacy}
 \title{Assign momID and dadID based on family mapping}
 \usage{
-mapFAMC2parents.legacy(df_temp, family_to_parents)
+.mapFAMC2parents.legacy(df_temp, family_to_parents)
 }
 \arguments{
 \item{df_temp}{A data frame containing individual information.}
diff --git a/man/mapFAMS2parents.legacy.Rd b/man/dot-mapFAMS2parents.legacy.Rd
similarity index 80%
rename from man/mapFAMS2parents.legacy.Rd
rename to man/dot-mapFAMS2parents.legacy.Rd
index 798af515..7f07a076 100644
--- a/man/mapFAMS2parents.legacy.Rd
+++ b/man/dot-mapFAMS2parents.legacy.Rd
@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/readGedcomlegacy.R
-\name{mapFAMS2parents.legacy}
-\alias{mapFAMS2parents.legacy}
+\name{.mapFAMS2parents.legacy}
+\alias{.mapFAMS2parents.legacy}
 \title{Create a mapping of family IDs to parent IDs}
 \usage{
-mapFAMS2parents.legacy(df_temp)
+.mapFAMS2parents.legacy(df_temp)
 }
 \arguments{
 \item{df_temp}{A data frame containing information about individuals.}
diff --git a/man/postProcessGedcom.legacy.Rd b/man/dot-postProcessGedcom.legacy.Rd
similarity index 90%
rename from man/postProcessGedcom.legacy.Rd
rename to man/dot-postProcessGedcom.legacy.Rd
index 060b9367..8deeadd3 100644
--- a/man/postProcessGedcom.legacy.Rd
+++ b/man/dot-postProcessGedcom.legacy.Rd
@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/readGedcomlegacy.R
-\name{postProcessGedcom.legacy}
-\alias{postProcessGedcom.legacy}
+\name{.postProcessGedcom.legacy}
+\alias{.postProcessGedcom.legacy}
 \title{Post-process GEDCOM Data Frame}
 \usage{
-postProcessGedcom.legacy(
+.postProcessGedcom.legacy(
   df_temp,
   remove_empty_cols = TRUE,
   combine_cols = TRUE,
diff --git a/man/processParents.legacy.Rd b/man/dot-processParents.legacy.Rd
similarity index 78%
rename from man/processParents.legacy.Rd
rename to man/dot-processParents.legacy.Rd
index 774663aa..eca10438 100644
--- a/man/processParents.legacy.Rd
+++ b/man/dot-processParents.legacy.Rd
@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/readGedcomlegacy.R
-\name{processParents.legacy}
-\alias{processParents.legacy}
+\name{.processParents.legacy}
+\alias{.processParents.legacy}
 \title{Process parents information}
 \usage{
-processParents.legacy(df_temp, datasource)
+.processParents.legacy(df_temp, datasource)
 }
 \arguments{
 \item{df_temp}{A data frame containing information about individuals.}
diff --git a/man/process_tag.legacy.Rd b/man/dot-process_tag.legacy.Rd
similarity index 91%
rename from man/process_tag.legacy.Rd
rename to man/dot-process_tag.legacy.Rd
index f31cbad6..0fbfac81 100644
--- a/man/process_tag.legacy.Rd
+++ b/man/dot-process_tag.legacy.Rd
@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/readGedcomlegacy.R
-\name{process_tag.legacy}
-\alias{process_tag.legacy}
+\name{.process_tag.legacy}
+\alias{.process_tag.legacy}
 \title{Process a GEDCOM Tag}
 \usage{
-process_tag.legacy(
+.process_tag.legacy(
   tag,
   field_name,
   pattern_rows,
diff --git a/man/readGedcom.legacy.Rd b/man/dot-readGedcom.legacy.Rd
similarity index 97%
rename from man/readGedcom.legacy.Rd
rename to man/dot-readGedcom.legacy.Rd
index e4cf2957..515262e0 100644
--- a/man/readGedcom.legacy.Rd
+++ b/man/dot-readGedcom.legacy.Rd
@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/readGedcomlegacy.R
-\name{readGedcom.legacy}
-\alias{readGedcom.legacy}
+\name{.readGedcom.legacy}
+\alias{.readGedcom.legacy}
 \title{Read a GEDCOM File}
 \usage{
-readGedcom.legacy(
+.readGedcom.legacy(
   file_path,
   verbose = FALSE,
   add_parents = TRUE,
diff --git a/man/inferRelatedness.Rd b/man/inferRelatedness.Rd
index d46c3f15..3d25312b 100644
--- a/man/inferRelatedness.Rd
+++ b/man/inferRelatedness.Rd
@@ -37,3 +37,4 @@ By considering the observed correlation (`obsR`), the proportion of variance att
 inferRelatedness(obsR = 0.5, aceA = 0.9, aceC = 0, sharedC = 0)
 }
 }
+\keyword{internal}
diff --git a/man/initializeCheckpoint.Rd b/man/initializeCheckpoint.Rd
new file mode 100644
index 00000000..2b06a258
--- /dev/null
+++ b/man/initializeCheckpoint.Rd
@@ -0,0 +1,15 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/buildComponent.R
+\name{initializeCheckpoint}
+\alias{initializeCheckpoint}
+\title{Initialize checkpoint files}
+\usage{
+initializeCheckpoint(
+  config = list(verbose = FALSE, saveable = FALSE, resume = FALSE, save_path =
+    "checkpoint/")
+)
+}
+\description{
+Initialize checkpoint files
+}
+\keyword{internal}
diff --git a/man/loadOrComputeCheckpoint.Rd b/man/loadOrComputeCheckpoint.Rd
new file mode 100644
index 00000000..20b8f807
--- /dev/null
+++ b/man/loadOrComputeCheckpoint.Rd
@@ -0,0 +1,32 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/buildComponent.R
+\name{loadOrComputeCheckpoint}
+\alias{loadOrComputeCheckpoint}
+\title{Load or compute a checkpoint}
+\usage{
+loadOrComputeCheckpoint(
+  file,
+  compute_fn,
+  config,
+  message_resume = NULL,
+  message_compute = NULL
+)
+}
+\arguments{
+\item{file}{The file path to load the checkpoint from.}
+
+\item{compute_fn}{The function to compute the checkpoint if it doesn't exist.}
+
+\item{config}{A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.}
+
+\item{message_resume}{Optional message to display when resuming from a checkpoint.}
+
+\item{message_compute}{Optional message to display when computing the checkpoint.}
+}
+\value{
+The loaded or computed checkpoint.
+}
+\description{
+Load or compute a checkpoint
+}
+\keyword{internal}
diff --git a/man/loadOrComputeParList.Rd b/man/loadOrComputeParList.Rd
new file mode 100644
index 00000000..7c623c59
--- /dev/null
+++ b/man/loadOrComputeParList.Rd
@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/buildComponent.R
+\name{loadOrComputeParList}
+\alias{loadOrComputeParList}
+\title{parent-child adjacency data}
+\usage{
+loadOrComputeParList(
+  checkpoint_files,
+  config,
+  nr,
+  ped = NULL,
+  parList = NULL,
+  lens = NULL
+)
+}
+\arguments{
+\item{checkpoint_files}{A list of checkpoint file paths.}
+
+\item{config}{A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.}
+
+\item{nr}{The number of rows in the sparse matrix.}
+
+\item{ped}{a pedigree dataset.  Needs ID, momID, and dadID columns}
+
+\item{parList}{A list of parent-child adjacency data.}
+
+\item{lens}{A vector of lengths for each parent-child relationship.}
+}
+\value{
+A list containing the parent-child adjacency data either loaded from a checkpoint or initialized.
+}
+\description{
+parent-child adjacency data
+}
+\keyword{internal}
diff --git a/man/ped2add.Rd b/man/ped2add.Rd
index c3949c68..45eeedea 100644
--- a/man/ped2add.Rd
+++ b/man/ped2add.Rd
@@ -18,7 +18,7 @@ ped2add(
   resume = FALSE,
   save_rate = 5,
   save_rate_gen = save_rate,
-  save_rate_parlist = 1000 * save_rate,
+  save_rate_parlist = 1e+05 * save_rate,
   save_path = "checkpoint/",
   ...
 )
diff --git a/man/ped2mit.Rd b/man/ped2mit.Rd
index 2c7dbcb1..5b43fa5d 100644
--- a/man/ped2mit.Rd
+++ b/man/ped2mit.Rd
@@ -19,7 +19,7 @@ ped2mit(
   resume = FALSE,
   save_rate = 5,
   save_rate_gen = save_rate,
-  save_rate_parlist = 1000 * save_rate,
+  save_rate_parlist = 1e+05 * save_rate,
   save_path = "checkpoint/",
   ...
 )
diff --git a/tests/testthat/test-makeLinks.R b/tests/testthat/test-makeLinks.R
index 05fc58fd..7d5135f7 100644
--- a/tests/testthat/test-makeLinks.R
+++ b/tests/testthat/test-makeLinks.R
@@ -89,7 +89,7 @@ test_that("com2links processes creates same length for cn with 3, 2, and 1 matri
   expect_equal(result3$cnuRel, result2$cnuRel)
 
   result1 <- com2links(cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE)
-  result1_legacy <- com2links.legacy(cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE)
+  result1_legacy <- .com2links.legacy(cn_ped_matrix = cn_ped_matrix, writetodisk = FALSE)
   expect_true(is.data.frame(result1))
   expect_true(is.data.frame(result1_legacy))
   expect_true(all(c("ID1", "ID2", "cnuRel") %in% colnames(result1)))
@@ -145,7 +145,7 @@ test_that("com2links legacy works", {
   mit_ped_matrix <- ped2com(hazard, component = "mitochondrial", adjacency_method = "direct", sparse = TRUE)
   cn_ped_matrix <- ped2com(hazard, component = "common nuclear", adjacency_method = "indexed", sparse = TRUE)
 
-  resultlegacy <- com2links.legacy(
+  resultlegacy <- .com2links.legacy(
     ad_ped_matrix = ad_ped_matrix,
     mit_ped_matrix = mit_ped_matrix, cn_ped_matrix = cn_ped_matrix,
     legacy = TRUE
@@ -169,7 +169,7 @@ test_that("com2links legacy works", {
   expect_true(all(c("ID1", "ID2", "addRel", "mitRel", "cnuRel") %in% colnames(result_beta)))
 
 
-  result <- com2links.legacy(
+  result <- .com2links.legacy(
     ad_ped_matrix = ad_ped_matrix,
     mit_ped_matrix = mit_ped_matrix, cn_ped_matrix = cn_ped_matrix,
     writetodisk = FALSE
@@ -205,7 +205,7 @@ test_that("com2links beta works", {
   expect_true(all(c("ID1", "ID2", "addRel", "mitRel") %in% colnames(result_beta)))
 
 
-  result <- com2links.legacy(
+  result <- .com2links.legacy(
     ad_ped_matrix = ad_ped_matrix,
     mit_ped_matrix = mit_ped_matrix,
     writetodisk = FALSE
diff --git a/tests/testthat/test-readPedigrees.R b/tests/testthat/test-readPedigrees.R
index de7aaeb3..efc09ddd 100644
--- a/tests/testthat/test-readPedigrees.R
+++ b/tests/testthat/test-readPedigrees.R
@@ -209,7 +209,23 @@ test_that("readGedcom parses death event correctly", {
   expect_equal(df$death_caus[1], "Old age")
   expect_equal(df$death_lat[1], "12.3456")
   expect_equal(df$death_long[1], "-65.4321")
-  df <- readGedcom.legacy(temp_file, verbose = TRUE)
+  df_leg <- .readGedcom.legacy(temp_file, verbose = TRUE)
+
+  expect_true("death_date" %in% colnames(df_leg))
+  expect_true("death_place" %in% colnames(df_leg))
+  expect_true("death_caus" %in% colnames(df_leg))
+  expect_true("death_lat" %in% colnames(df_leg))
+  expect_true("death_long" %in% colnames(df_leg))
+
+  expect_equal(df_leg$death_date[1], "31 DEC 2000")
+  expect_equal(df_leg$death_place[1], "Lastplace")
+  expect_equal(df_leg$death_caus[1], "Old age")
+  expect_equal(df_leg$death_lat[1], "12.3456")
+  expect_equal(df_leg$death_long[1], "-65.4321")
+
+  row.names(df) <- NULL
+  row.names(df_leg) <- NULL
+  expect_equal(df_leg,df)
 
   unlink(temp_file)
 })

From 39451f86d999578e40aa9e48f96779790ad872b4 Mon Sep 17 00:00:00 2001
From: Mason Garrison 
Date: Tue, 22 Apr 2025 19:44:50 -0400
Subject: [PATCH 66/69] loadOrComputeInverseDiagonal

---
 R/buildComponent.R                            | 53 +++++++++++--------
 man/dot-assignParentValue.Rd                  | 14 +++++
 man/dot-loadOrComputeIsChild.Rd               |  6 +--
 ...ParList.Rd => dot-loadOrComputeParList.Rd} |  6 +--
 tests/testthat/test-convertPedigree.R         |  1 -
 5 files changed, 50 insertions(+), 30 deletions(-)
 create mode 100644 man/dot-assignParentValue.Rd
 rename man/{loadOrComputeParList.Rd => dot-loadOrComputeParList.Rd} (90%)

diff --git a/R/buildComponent.R b/R/buildComponent.R
index 346ce907..0de61044 100644
--- a/R/buildComponent.R
+++ b/R/buildComponent.R
@@ -64,7 +64,7 @@ ped2com <- function(ped, component,
                  save_rate_parlist = save_rate_parlist,
                  update_rate = update_rate,
                  gc = gc,
-                 component =component,
+                 component = component,
                  adjBeta_method = adjBeta_method
                  )
 
@@ -131,7 +131,7 @@ ped2com <- function(ped, component,
 
   ## A. Resume from Checkpoint if Needed
   ## Initialize variables
-  list_of_adjacencies <-   loadOrComputeParList(checkpoint_files = checkpoint_files,
+  list_of_adjacencies <-   .loadOrComputeParList(checkpoint_files = checkpoint_files,
                                                  ped = ped,
                                                  config = config,
                                                  nr=nr)
@@ -147,7 +147,7 @@ ped2com <- function(ped, component,
    }
 
   # Assign parent values based on the component type
-  parVal <- assignParentValue(component = config$component)
+  parVal <- .assignParentValue(component = config$component)
 
   # Construct sparse matrix
   # Initialize adjacency matrix for parent-child relationships
@@ -240,22 +240,12 @@ ped2com <- function(ped, component,
   }
 
   # --- Step 3: I-A inverse times diagonal multiplication ---
-  if (resume && file.exists(checkpoint_files$r2_checkpoint)) {
-    if (verbose) cat("Resuming: Loading I-A inverse...\n")
-    r2 <- readRDS(checkpoint_files$r2_checkpoint)
-  } else {
-    if (verbose) {
-      cat("Doing I-A inverse times diagonal multiplication\n")
-    }
-    r2 <- r %*% Matrix::Diagonal(x = sqrt(isChild), n = nr)
-    if (gc) {
-      rm(r, isChild)
-      gc()
-    }
-    if (saveable) {
-      saveRDS(r2, file = checkpoint_files$r2_checkpoint)
-    }
-  }
+  r2 <- .loadOrComputeInverseDiagonal(r=r,
+                                      nr=nr,
+                                      isChild=isChild,
+                                      checkpoint_files = checkpoint_files,
+                                      config = config
+                                      )
 
   # --- Step 4: T crossproduct  ---
 
@@ -487,8 +477,9 @@ initializeCheckpoint <- function(config= list(verbose = FALSE,
   return(checkpoint_files)
 }
 
-
-assignParentValue<- function(component){
+#' Assign parent values based on component type
+#' @inheritParams ped2com
+.assignParentValue <- function(component){
 
 # Set parent values depending on the component type
 if (component %in% c("generation", "additive")) {
@@ -553,7 +544,6 @@ loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = N
 #' @inheritParams loadOrComputeCheckpoint
 #' @inheritParams ped2com
 #' @param checkpoint_files A list of checkpoint file paths.
-#' @param config A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.
 #'
 #'  @keywords internal
 
@@ -569,6 +559,23 @@ loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = N
   return(isChild)
 }
 
+.loadOrComputeInverseDiagonal <- function(r,nr, isChild, checkpoint_files, config) {
+  r2 <- loadOrComputeCheckpoint(
+    file = checkpoint_files$r2_checkpoint,
+    compute_fn = function() {r %*% Matrix::Diagonal(x = sqrt(isChild),  n = nr)
+      },
+    config = config,
+    message_resume = "Resuming: Loading I-A inverse...\n",
+    message_compute = "Doing I-A inverse times diagonal multiplication\n"
+  )
+  if (config$gc) {
+    rm(r, isChild)
+    gc()
+  }
+  return(r2)
+}
+
+
 
 #' parent-child adjacency data
 #' @inheritParams loadOrComputeCheckpoint
@@ -583,7 +590,7 @@ loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = N
 #' @return A list containing the parent-child adjacency data either loaded from a checkpoint or initialized.
 #'
 
-loadOrComputeParList <- function(checkpoint_files, config, nr, ped = NULL, parList = NULL, lens = NULL) {
+.loadOrComputeParList <- function(checkpoint_files, config, nr, ped = NULL, parList = NULL, lens = NULL) {
   if (config$resume && file.exists(checkpoint_files$parList) && file.exists(checkpoint_files$lens)) {
     if (config$verbose) cat("Resuming: Loading parent-child adjacency data...\n")
     parList <- readRDS(checkpoint_files$parList)
diff --git a/man/dot-assignParentValue.Rd b/man/dot-assignParentValue.Rd
new file mode 100644
index 00000000..4ca25a10
--- /dev/null
+++ b/man/dot-assignParentValue.Rd
@@ -0,0 +1,14 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/buildComponent.R
+\name{.assignParentValue}
+\alias{.assignParentValue}
+\title{Assign parent values based on component type}
+\usage{
+.assignParentValue(component)
+}
+\arguments{
+\item{component}{character.  Which component of the pedigree to return.  See Details.}
+}
+\description{
+Assign parent values based on component type
+}
diff --git a/man/dot-loadOrComputeIsChild.Rd b/man/dot-loadOrComputeIsChild.Rd
index 58205d04..7656d261 100644
--- a/man/dot-loadOrComputeIsChild.Rd
+++ b/man/dot-loadOrComputeIsChild.Rd
@@ -9,11 +9,11 @@
 \arguments{
 \item{ped}{a pedigree dataset.  Needs ID, momID, and dadID columns}
 
-\item{checkpoint_files}{A list of checkpoint file paths.}
-
-\item{config}{A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.
+\item{checkpoint_files}{A list of checkpoint file paths.
 
  @keywords internal}
+
+\item{config}{A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.}
 }
 \description{
 Load or compute the isChild matrix
diff --git a/man/loadOrComputeParList.Rd b/man/dot-loadOrComputeParList.Rd
similarity index 90%
rename from man/loadOrComputeParList.Rd
rename to man/dot-loadOrComputeParList.Rd
index 7c623c59..22934c55 100644
--- a/man/loadOrComputeParList.Rd
+++ b/man/dot-loadOrComputeParList.Rd
@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/buildComponent.R
-\name{loadOrComputeParList}
-\alias{loadOrComputeParList}
+\name{.loadOrComputeParList}
+\alias{.loadOrComputeParList}
 \title{parent-child adjacency data}
 \usage{
-loadOrComputeParList(
+.loadOrComputeParList(
   checkpoint_files,
   config,
   nr,
diff --git a/tests/testthat/test-convertPedigree.R b/tests/testthat/test-convertPedigree.R
index c927d2ad..f1a163e6 100644
--- a/tests/testthat/test-convertPedigree.R
+++ b/tests/testthat/test-convertPedigree.R
@@ -256,7 +256,6 @@ test_that("ped2com handles checkpoint saving and resuming", {
   checkpoint_files_v1 <- list.files(save_path, pattern = "\\.rds$", full.names = TRUE)
 
   expect_equal(length(checkpoint_files_v1), length(checkpoint_files_v0))
-
   # Resume from checkpoint
   resumed_matrix <- ped2com(hazard,
     component = "additive", resume = TRUE, save_path = save_path,

From 078bbfd7e310c94df2c1bb1bca847985c38b8969 Mon Sep 17 00:00:00 2001
From: Mason Garrison 
Date: Mon, 28 Apr 2025 14:23:07 -0400
Subject: [PATCH 67/69] adding config

---
 R/buildComponent.R                    | 265 ++++++++++++++------------
 R/checkParents.R                      |   2 +-
 R/checkSex.R                          |  25 +--
 R/constructAdjacency.R                | 193 +++++++++----------
 R/readGedcomlegacy.R                  |  28 +--
 man/computeParentAdjacency.Rd         |   6 +-
 man/dot-loadOrComputeIsPar.Rd         |   4 +-
 man/dot-loadOrComputeParList.Rd       |   3 -
 tests/testthat/test-convertPedigree.R |   1 +
 tests/testthat/test-readPedigrees.R   |   2 +-
 10 files changed, 269 insertions(+), 260 deletions(-)

diff --git a/R/buildComponent.R b/R/buildComponent.R
index 0de61044..0372e5fc 100644
--- a/R/buildComponent.R
+++ b/R/buildComponent.R
@@ -43,46 +43,47 @@ ped2com <- function(ped, component,
                     save_path = "checkpoint/",
                     adjBeta_method = NULL,
                     ...) {
-
   #------
   # Check inputs
   #------
 
-  config <- list(verbose = verbose,
-                 saveable = saveable,
-                 resume = resume,
-                 save_path = save_path,
-                 max.gen = max.gen,
-                 sparse = sparse,
-                 flatten.diag = flatten.diag,
-                 standardize.colnames = standardize.colnames,
-                 transpose_method = transpose_method,
-                 adjacency_method = adjacency_method,
-                 isChild_method = isChild_method,
-                 save_rate = save_rate,
-                 save_rate_gen = save_rate_gen,
-                 save_rate_parlist = save_rate_parlist,
-                 update_rate = update_rate,
-                 gc = gc,
-                 component = component,
-                 adjBeta_method = adjBeta_method
-                 )
+  config <- list(
+    verbose = verbose,
+    saveable = saveable,
+    resume = resume,
+    save_path = save_path,
+    max.gen = max.gen,
+    sparse = sparse,
+    flatten.diag = flatten.diag,
+    standardize.colnames = standardize.colnames,
+    transpose_method = transpose_method,
+    adjacency_method = adjacency_method,
+    isChild_method = isChild_method,
+    save_rate = save_rate,
+    save_rate_gen = save_rate_gen,
+    save_rate_parlist = save_rate_parlist,
+    update_rate = update_rate,
+    gc = gc,
+    component = component,
+    adjBeta_method = adjBeta_method,
+    nr = nrow(ped)
+  )
 
 
   #------
   # Checkpointing
   #------
   if (config$saveable || config$resume) { # prepare checkpointing
-  if (config$verbose) cat("Preparing checkpointing...\n")
+    if (config$verbose) cat("Preparing checkpointing...\n")
 
-    checkpoint_files  <- initializeCheckpoint(config) # initialize checkpoint files
+    checkpoint_files <- initializeCheckpoint(config) # initialize checkpoint files
   }
   #------
   # Validation/Preparation
   #------
 
   # Validate the 'component' argument and match it against predefined choices
-  component <- match.arg(tolower(component),
+  config$component <- match.arg(tolower(config$component),
     choices = c(
       "generation",
       "additive",
@@ -91,26 +92,30 @@ ped2com <- function(ped, component,
     )
   )
 
-  transpose_method_options <- c("tcrossprod", "crossprod", "star",
-                                "tcross.alt.crossprod", "tcross.alt.star")
-  if (!transpose_method %in%  transpose_method_options) {
-    stop(paste0("Invalid method specified. Choose from ",
-                paste(transpose_method_options, collapse = ", "), "."))
+  transpose_method_options <- c(
+    "tcrossprod", "crossprod", "star",
+    "tcross.alt.crossprod", "tcross.alt.star"
+  )
+  if (!config$transpose_method %in% transpose_method_options) {
+    stop(paste0(
+      "Invalid method specified. Choose from ",
+      paste(transpose_method_options, collapse = ", "), "."
+    ))
   }
 
 
-  if (!adjacency_method %in% c("indexed", "loop", "direct", "beta")) {
+  if (!config$adjacency_method %in% c("indexed", "loop", "direct", "beta")) {
     stop("Invalid method specified. Choose from 'indexed', 'loop', 'direct', or 'beta'.")
   }
 
   # standardize colnames
-  if (standardize.colnames) {
+  if (config$standardize.colnames) {
     ped <- standardizeColnames(ped, verbose = config$verbose)
   }
 
   # Load final result if computation was completed
-  if (resume && file.exists(checkpoint_files$final_matrix)) {
-    if (verbose) cat("Loading final computed matrix...\n")
+  if (config$resume && file.exists(checkpoint_files$final_matrix)) {
+    if (config$verbose) cat("Loading final computed matrix...\n")
     return(readRDS(checkpoint_files$final_matrix))
   }
 
@@ -120,61 +125,61 @@ ped2com <- function(ped, component,
   #------
 
   # Get the number of rows in the pedigree dataset, representing the size of the family
-  nr <- nrow(ped)
+  #  nr <- nrow(ped)
 
   # Print the family size if verbose is TRUE
-  if (verbose) {
-    cat(paste0("Family Size = ", nr, "\n"))
+  if (config$verbose) {
+    cat(paste0("Family Size = ", config$nr, "\n"))
   }
 
   # Step 1: Construct parent-child adjacency matrix
 
   ## A. Resume from Checkpoint if Needed
   ## Initialize variables
-  list_of_adjacencies <-   .loadOrComputeParList(checkpoint_files = checkpoint_files,
-                                                 ped = ped,
-                                                 config = config,
-                                                 nr=nr)
+  list_of_adjacencies <- .loadOrComputeParList(
+    checkpoint_files = checkpoint_files,
+    ped = ped,
+    config = config
+  )
 
 
   ## B. Resume loop from the next uncomputed index
 
 
   # Construct sparse matrix
-   # Garbage collection if gc is TRUE
-   if (config$gc) {
-     gc()
-   }
+  # Garbage collection if gc is TRUE
+  if (config$gc) {
+    gc()
+  }
 
   # Assign parent values based on the component type
   parVal <- .assignParentValue(component = config$component)
 
   # Construct sparse matrix
   # Initialize adjacency matrix for parent-child relationships
-  isPar <-  .loadOrComputeIsPar(
-    iss =  list_of_adjacencies$iss,
-    jss =  list_of_adjacencies$jss,
+  isPar <- .loadOrComputeIsPar(
+    iss = list_of_adjacencies$iss,
+    jss = list_of_adjacencies$jss,
     parVal = parVal,
-    nr = nr,
     ped = ped,
     checkpoint_files = checkpoint_files,
     config = config
   )
-  if (verbose) {
+  if (config$verbose) {
     cat("Completed first degree relatives (adjacency)\n")
   }
 
-   # isPar is the adjacency matrix.  'A' matrix from RAM
+  # isPar is the adjacency matrix.  'A' matrix from RAM
 
-  if (component %in% c("common nuclear")) {
+  if (config$component %in% c("common nuclear")) {
     Matrix::diag(isPar) <- 1
-    if (sparse == FALSE) {
+    if (config$sparse == FALSE) {
       isPar <- as.matrix(isPar)
     }
     return(isPar)
   }
 
-    # isChild is the 'S' matrix from RAM
+  # isChild is the 'S' matrix from RAM
   isChild <- .loadOrComputeIsChild(
     ped = ped,
     checkpoint_files = checkpoint_files,
@@ -183,24 +188,24 @@ ped2com <- function(ped, component,
   # --- Step 2: Compute Relatedness Matrix ---
 
 
-  if (resume && file.exists(checkpoint_files$r_checkpoint) && file.exists(checkpoint_files$gen_checkpoint) && file.exists(checkpoint_files$mtSum_checkpoint) && file.exists(checkpoint_files$newIsPar_checkpoint) &&
+  if (config$resume && file.exists(checkpoint_files$r_checkpoint) && file.exists(checkpoint_files$gen_checkpoint) && file.exists(checkpoint_files$mtSum_checkpoint) && file.exists(checkpoint_files$newIsPar_checkpoint) &&
     file.exists(checkpoint_files$count_checkpoint)
   ) {
-    if (verbose) cat("Resuming: Loading previous computation...\n")
+    if (config$verbose) cat("Resuming: Loading previous computation...\n")
     r <- readRDS(checkpoint_files$r_checkpoint)
     gen <- readRDS(checkpoint_files$gen_checkpoint)
     mtSum <- readRDS(checkpoint_files$mtSum_checkpoint)
     newIsPar <- readRDS(checkpoint_files$newIsPar_checkpoint)
     count <- readRDS(checkpoint_files$count_checkpoint)
   } else {
-    r <- Matrix::Diagonal(x = 1, n = nr)
-    gen <- rep(1, nr)
+    r <- Matrix::Diagonal(x = 1, n = config$nr)
+    gen <- rep(1, config$nr)
     mtSum <- sum(r, na.rm = TRUE)
     newIsPar <- isPar
     count <- 0
   }
-  maxCount <- max.gen + 1
-  if (verbose) {
+  maxCount <- config$max.gen + 1
+  if (config$verbose) {
     cat("About to do RAM path tracing\n")
   }
 
@@ -212,65 +217,71 @@ ped2com <- function(ped, component,
     newIsPar <- newIsPar %*% isPar
     mtSum <- sum(newIsPar)
     count <- count + 1
-    if (verbose) {
+    if (config$verbose) {
       cat(paste0("Completed ", count - 1, " degree relatives\n"))
     }
     # Save progress every save_rate iterations
-    if (saveable && (count %% save_rate_gen == 0)) {
+    if (config$saveable && (count %% save_rate_gen == 0)) {
       saveRDS(r, file = checkpoint_files$r_checkpoint)
       saveRDS(gen, file = checkpoint_files$gen_checkpoint)
       saveRDS(newIsPar, file = checkpoint_files$newIsPar_checkpoint)
       saveRDS(mtSum, file = checkpoint_files$mtSum_checkpoint)
       saveRDS(count, file = checkpoint_files$count_checkpoint)
     }
+    if (config$gc && config$nr > 1000000) {
+      gc()
+    } # extra gc if large
   }
   # compute rsq <- r %*% sqrt(diag(isChild))
   # compute rel <- tcrossprod(rsq)
-  if (gc) {
+  if (config$gc) {
     rm(isPar, newIsPar)
     gc()
   }
+  if (config$saveable) {
+    saveRDS(r, file = checkpoint_files$ram_checkpoint)
+  }
 
-  if (component == "generation") { # no need to do the rest
+  if (config$component == "generation") { # no need to do the rest
     return(gen)
   } else {
-    if (verbose) {
+    if (config$verbose) {
       cat("Completed RAM path tracing\n")
     }
   }
 
   # --- Step 3: I-A inverse times diagonal multiplication ---
-  r2 <- .loadOrComputeInverseDiagonal(r=r,
-                                      nr=nr,
-                                      isChild=isChild,
-                                      checkpoint_files = checkpoint_files,
-                                      config = config
-                                      )
+  r2 <- .loadOrComputeInverseDiagonal(
+    r = r,
+    isChild = isChild,
+    checkpoint_files = checkpoint_files,
+    config = config
+  )
 
   # --- Step 4: T crossproduct  ---
 
-  if (resume && file.exists(checkpoint_files$tcrossprod_checkpoint) && component != "generation") {
-    if (verbose) cat("Resuming: Loading tcrossprod...\n")
+  if (config$resume && file.exists(checkpoint_files$tcrossprod_checkpoint) && config$component != "generation") {
+    if (config$verbose) cat("Resuming: Loading tcrossprod...\n")
     r <- readRDS(checkpoint_files$tcrossprod_checkpoint)
   } else {
-    r <- .computeTranspose(r2 = r2, transpose_method = transpose_method, verbose = verbose)
-    if (saveable) {
+    r <- .computeTranspose(r2 = r2, transpose_method = transpose_method, verbose = config$verbose)
+    if (config$saveable) {
       saveRDS(r, file = checkpoint_files$tcrossprod_checkpoint)
     }
   }
 
-  if (component == "mitochondrial") {
+  if (config$component == "mitochondrial") {
     r@x <- rep(1, length(r@x))
     # Assign 1 to all nonzero elements for mitochondrial component
   }
 
-  if (sparse == FALSE) {
+  if (config$sparse == FALSE) {
     r <- as.matrix(r)
   }
-  if (flatten.diag) { # flattens diagonal if you don't want to deal with inbreeding
+  if (config$flatten.diag) { # flattens diagonal if you don't want to deal with inbreeding
     diag(r) <- 1
   }
-  if (saveable) {
+  if (config$saveable) {
     saveRDS(r, file = checkpoint_files$final_matrix)
   }
   return(r)
@@ -393,7 +404,7 @@ ped2cn <- function(ped, max.gen = 25, sparse = TRUE, verbose = FALSE,
 #' @inherit ped2com details
 #' @export
 #'
-ped2ce <- function(ped,...) {
+ped2ce <- function(ped, ...) {
   matrix(1, nrow = nrow(ped), ncol = nrow(ped), dimnames = list(ped$ID, ped$ID))
 }
 
@@ -404,8 +415,10 @@ ped2ce <- function(ped,...) {
 #' @param r2 a relatedness matrix
 #'
 .computeTranspose <- function(r2, transpose_method = "tcrossprod", verbose = FALSE) {
-  valid_methods <- c("tcrossprod", "crossprod", "star",
-                     "tcross.alt.crossprod", "tcross.alt.star")
+  valid_methods <- c(
+    "tcrossprod", "crossprod", "star",
+    "tcross.alt.crossprod", "tcross.alt.star"
+  )
   if (!transpose_method %in% valid_methods) {
     stop("Invalid method specified. Choose from 'tcrossprod', 'crossprod', 'star', 'tcross.alt.crossprod', or 'tcross.alt.star'.")
   }
@@ -423,18 +436,18 @@ ped2ce <- function(ped,...) {
   }
 
   result <- switch(method_normalized,
-                   "tcrossprod" = {
-                     if (verbose) cat("Doing tcrossprod\n")
-                     Matrix::tcrossprod(r2)
-                   },
-                   "crossprod" = {
-                     if (verbose) cat("Doing tcrossprod using crossprod(t(.))\n")
-                     crossprod(t(as.matrix(r2)))
-                   },
-                   "star" = {
-                     if (verbose) cat("Doing tcrossprod using %*% t(.)\n")
-                     r2 %*% t(as.matrix(r2))
-                   }
+    "tcrossprod" = {
+      if (verbose) cat("Doing tcrossprod\n")
+      Matrix::tcrossprod(r2)
+    },
+    "crossprod" = {
+      if (verbose) cat("Doing tcrossprod using crossprod(t(.))\n")
+      crossprod(t(as.matrix(r2)))
+    },
+    "star" = {
+      if (verbose) cat("Doing tcrossprod using %*% t(.)\n")
+      r2 %*% t(as.matrix(r2))
+    }
   )
 
   return(result)
@@ -444,10 +457,12 @@ ped2ce <- function(ped,...) {
 #' @inheritParams ped2com
 #' @keywords internal
 
-initializeCheckpoint <- function(config= list(verbose = FALSE,
-       saveable = FALSE,
-       resume = FALSE,
-       save_path = "checkpoint/")) {
+initializeCheckpoint <- function(config = list(
+                                   verbose = FALSE,
+                                   saveable = FALSE,
+                                   resume = FALSE,
+                                   save_path = "checkpoint/"
+                                 )) {
   # Define checkpoint files
   # Ensure save path exists
   if (config$saveable && !dir.exists(config$save_path)) {
@@ -468,6 +483,7 @@ initializeCheckpoint <- function(config= list(verbose = FALSE,
     gen_checkpoint = file.path(config$save_path, "gen_checkpoint.rds"),
     newIsPar_checkpoint = file.path(config$save_path, "newIsPar_checkpoint.rds"),
     mtSum_checkpoint = file.path(config$save_path, "mtSum_checkpoint.rds"),
+    ram_checkpoint = file.path(config$save_path, "ram_checkpoint.rds"),
     r2_checkpoint = file.path(config$save_path, "r2_checkpoint.rds"),
     tcrossprod_checkpoint = file.path(config$save_path, "tcrossprod_checkpoint.rds"),
     count_checkpoint = file.path(config$save_path, "count_checkpoint.rds"),
@@ -479,17 +495,16 @@ initializeCheckpoint <- function(config= list(verbose = FALSE,
 
 #' Assign parent values based on component type
 #' @inheritParams ped2com
-.assignParentValue <- function(component){
-
-# Set parent values depending on the component type
-if (component %in% c("generation", "additive")) {
-  parVal <- .5
-} else if (component %in% c("common nuclear", "mitochondrial")) {
-  parVal <- 1
-} else {
-  stop("Don't know how to set parental value")
-}
-return(parVal)
+.assignParentValue <- function(component) {
+  # Set parent values depending on the component type
+  if (component %in% c("generation", "additive")) {
+    parVal <- .5
+  } else if (component %in% c("common nuclear", "mitochondrial")) {
+    parVal <- 1
+  } else {
+    stop("Don't know how to set parental value")
+  }
+  return(parVal)
 }
 
 #' Load or compute a checkpoint
@@ -518,26 +533,26 @@ loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = N
 #' @param iss The row indices of the sparse matrix.
 #' @param jss The column indices of the sparse matrix.
 #' @param parVal The value to assign to the non-zero elements of the sparse matrix.
-#' @param nr The number of rows in the sparse matrix.
 #' @param ped The pedigree dataset.
 #' @param checkpoint_files A list of checkpoint file paths.
 #'
 #' @keywords internal
-.loadOrComputeIsPar <- function(iss, jss, parVal, nr, ped, checkpoint_files, config) {
+.loadOrComputeIsPar <- function(iss, jss, parVal, ped, checkpoint_files, config) {
   isPar <- loadOrComputeCheckpoint(
     file = checkpoint_files$isPar,
-    compute_fn = function() Matrix::sparseMatrix(
-      i = iss, j = jss, x = parVal,
-      dims = c(nr, nr),
-      dimnames = list(ped$ID, ped$ID)
-    ),
+    compute_fn = function() {
+      Matrix::sparseMatrix(
+        i = iss, j = jss, x = parVal,
+        dims = c(config$nr, config$nr),
+        dimnames = list(ped$ID, ped$ID)
+      )
+    },
     config = config,
     message_resume = "Resuming: Loading adjacency matrix...\n",
     message_compute = "Initializing adjacency matrix...\n"
   )
 
   return(isPar)
-
 }
 
 #' Load or compute the isChild matrix
@@ -559,11 +574,12 @@ loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = N
   return(isChild)
 }
 
-.loadOrComputeInverseDiagonal <- function(r,nr, isChild, checkpoint_files, config) {
+.loadOrComputeInverseDiagonal <- function(r, isChild, checkpoint_files, config) {
   r2 <- loadOrComputeCheckpoint(
     file = checkpoint_files$r2_checkpoint,
-    compute_fn = function() {r %*% Matrix::Diagonal(x = sqrt(isChild),  n = nr)
-      },
+    compute_fn = function() {
+      r %*% Matrix::Diagonal(x = sqrt(isChild), n = config$nr)
+    },
     config = config,
     message_resume = "Resuming: Loading I-A inverse...\n",
     message_compute = "Doing I-A inverse times diagonal multiplication\n"
@@ -582,7 +598,6 @@ loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = N
 #' @inheritParams ped2com
 #' @param checkpoint_files A list of checkpoint file paths.
 #' @param config A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.
-#' @param nr The number of rows in the sparse matrix.
 #' @param parList A list of parent-child adjacency data.
 #' @param lens A vector of lengths for each parent-child relationship.
 #' @keywords internal
@@ -590,7 +605,7 @@ loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = N
 #' @return A list containing the parent-child adjacency data either loaded from a checkpoint or initialized.
 #'
 
-.loadOrComputeParList <- function(checkpoint_files, config, nr, ped = NULL, parList = NULL, lens = NULL) {
+.loadOrComputeParList <- function(checkpoint_files, config, ped = NULL, parList = NULL, lens = NULL) {
   if (config$resume && file.exists(checkpoint_files$parList) && file.exists(checkpoint_files$lens)) {
     if (config$verbose) cat("Resuming: Loading parent-child adjacency data...\n")
     parList <- readRDS(checkpoint_files$parList)
@@ -600,8 +615,8 @@ loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = N
     if (config$verbose) cat("Resuming from iteration", lastComputed + 1, "\n")
   } else {
     ## Initialize variables
-    parList <- vector("list", nr)
-    lens <- integer(nr)
+    parList <- vector("list", config$nr)
+    lens <- integer(config$nr)
     lastComputed <- 0
     if (config$verbose) cat("Building parent adjacency matrix...\n")
   }
@@ -625,7 +640,7 @@ loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = N
       update_rate = config$update_rate,
       verbose = config$verbose,
       lastComputed = lastComputed,
-      nr = nr,
+      config = config,
       parList = parList,
       lens = lens,
       adjBeta_method = config$adjBeta_method
@@ -641,8 +656,6 @@ loadOrComputeCheckpoint <- function(file, compute_fn, config, message_resume = N
       saveRDS(list_of_adjacencies$jss, file = checkpoint_files$jss)
       saveRDS(list_of_adjacencies$iss, file = checkpoint_files$iss)
     }
-
   }
-return(list_of_adjacencies)
+  return(list_of_adjacencies)
 }
-
diff --git a/R/checkParents.R b/R/checkParents.R
index 18f8a17a..a5635bdc 100644
--- a/R/checkParents.R
+++ b/R/checkParents.R
@@ -89,7 +89,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE,
   validation_results$wrong_sex_moms <- mom_results$inconsistent_parents
   validation_results$wrong_sex_dads <- dad_results$inconsistent_parents
   validation_results$female_moms <- mom_results$all_same_sex
-  validation_results$male_dads   <- dad_results$all_same_sex
+  validation_results$male_dads <- dad_results$all_same_sex
 
   # Are any parents in both momID and dadID?
   momdad <- intersect(ped$dadID, ped$momID)
diff --git a/R/checkSex.R b/R/checkSex.R
index 239fc22f..d2fc9fd5 100644
--- a/R/checkSex.R
+++ b/R/checkSex.R
@@ -39,8 +39,7 @@
 #'
 checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE, repair = FALSE,
                      momID = "momID",
-                     dadID = "dadID"
-                     ) {
+                     dadID = "dadID") {
   # Standardize column names in the input dataframe
   ped <- standardizeColnames(ped, verbose = verbose)
 
@@ -77,12 +76,14 @@ checkSex <- function(ped, code_male = NULL, code_female = NULL, verbose = FALSE,
   validation_results$ID_male_moms <- mom_results$inconsistent_parents
   validation_results$ID_child_male_moms <- mom_results$inconsistent_children
 
-  if (repair==FALSE) {
-    if (verbose) { cat("Checks Made:\n")
-      print(validation_results) }
+  if (repair == FALSE) {
+    if (verbose) {
+      cat("Checks Made:\n")
+      print(validation_results)
+    }
     return(validation_results)
   } else {
-    if (verbose==TRUE) {
+    if (verbose == TRUE) {
       cat("Step 2: Attempting to repair sex coding...\n")
     }
     # Initialize a list to track changes made during repair
@@ -201,8 +202,6 @@ recodeSex <- function(
 #'
 #' @return A list containing role, unique sex codes, modal sex, inconsistent parents, and linked children.
 checkParentSex <- function(ped, parent_col, sex_col = "sex", verbose = FALSE) {
-
-
   parent_ids <- ped[[parent_col]]
   parent_rows <- ped[ped$ID %in% parent_ids, ]
 
@@ -231,7 +230,7 @@ checkParentSex <- function(ped, parent_col, sex_col = "sex", verbose = FALSE) {
 
   # Type coercion based on ped$sex type
   if (is.numeric(ped[[sex_col]])) {
-  modal_sex <- as.numeric(modal_sex)
+    modal_sex <- as.numeric(modal_sex)
   }
 
   # List ids for dads that are female, moms that are male
@@ -248,7 +247,9 @@ checkParentSex <- function(ped, parent_col, sex_col = "sex", verbose = FALSE) {
 
     if (all_same_sex) {
       cat("All parents consistently coded.\n")
-  }  else cat(length(inconsistent_parents), " parents have inconsistent sex coding.\n")
+    } else {
+      cat(length(inconsistent_parents), " parents have inconsistent sex coding.\n")
+    }
   }
 
   return(list(
@@ -271,7 +272,9 @@ checkParentSex <- function(ped, parent_col, sex_col = "sex", verbose = FALSE) {
 #' @return The modal value of the vector. If the vector is empty or contains only NA values, returns NA.
 #' @keywords internal
 .getModalValue <- function(x) {
-  if (length(stats::na.omit(x)) == 0) return(NA)
+  if (length(stats::na.omit(x)) == 0) {
+    return(NA)
+  }
   freq_table <- sort(table(x), decreasing = TRUE)
   modal <- names(freq_table)[1]
   return(modal)
diff --git a/R/constructAdjacency.R b/R/constructAdjacency.R
index a1d6fd66..6c87e9c8 100644
--- a/R/constructAdjacency.R
+++ b/R/constructAdjacency.R
@@ -1,7 +1,7 @@
 .adjLoop <- function(ped, component, saveable, resume,
                      save_path, verbose, lastComputed,
-                     nr, checkpoint_files, update_rate,
-                     parList, lens, save_rate_parlist,
+                     checkpoint_files, update_rate,
+                     parList, lens, save_rate_parlist, config,
                      ...) {
   # Loop through each individual in the pedigree
   # Build the adjacency matrix for parent-child relationships
@@ -10,7 +10,7 @@
   ped$dadID <- as.numeric(ped$dadID)
   ped$ID <- as.numeric(ped$ID)
 
-  for (i in (lastComputed + 1):nr) {
+  for (i in (lastComputed + 1):config$nr) {
     x <- ped[i, , drop = FALSE]
     # Handle parentage according to the 'component' specified
     if (component %in% c("generation", "additive")) {
@@ -43,7 +43,7 @@
     lens[i] <- length(wv)
     # Print progress if verbose is TRUE
     if (verbose && (i %% update_rate == 0)) {
-      cat(paste0("Done with ", i, " of ", nr, "\n"))
+      cat(paste0("Done with ", i, " of ", config$nr, "\n"))
     }
     # Checkpointing every save_rate iterations
     if (saveable && (i %% save_rate_parlist == 0)) {
@@ -52,7 +52,7 @@
       if (verbose) cat("Checkpointed parlist saved at iteration", i, "\n")
     }
   }
-  jss <- rep(1L:nr, times = lens)
+  jss <- rep(1L:config$nr, times = lens)
   iss <- unlist(parList)
   list_of_adjacency <- list(iss = iss, jss = jss)
   return(list_of_adjacency)
@@ -60,8 +60,8 @@
 
 .adjIndexed <- function(ped, component, saveable, resume,
                         save_path, verbose, lastComputed,
-                        nr, checkpoint_files, update_rate,
-                        parList, lens, save_rate_parlist) {
+                        checkpoint_files, update_rate,
+                        parList, lens, save_rate_parlist, config) {
   # Loop through each individual in the pedigree
   # Build the adjacency matrix for parent-child relationships
   # Is person in column j the parent of the person in row i? .5 for yes, 0 for no.
@@ -75,7 +75,7 @@
   mom_index <- match(ped$momID, ped$ID, nomatch = 0)
   dad_index <- match(ped$dadID, ped$ID, nomatch = 0)
 
-  for (i in (lastComputed + 1):nr) {
+  for (i in (lastComputed + 1):config$nr) {
     if (component %in% c("generation", "additive")) {
       sMom <- (mom_index == i)
       sDad <- (dad_index == i)
@@ -100,7 +100,7 @@
 
     # Print progress if verbose is TRUE
     if (verbose && (i %% update_rate == 0)) {
-      cat(paste0("Done with ", i, " of ", nr, "\n"))
+      cat(paste0("Done with ", i, " of ", config$nr, "\n"))
     }
 
     # Checkpointing every save_rate iterations
@@ -110,7 +110,7 @@
       if (verbose) cat("Checkpointed parlist saved at iteration", i, "\n")
     }
   }
-  jss <- rep(1L:nr, times = lens)
+  jss <- rep(1L:config$nr, times = lens)
   iss <- unlist(parList)
   list_of_adjacency <- list(iss = iss, jss = jss)
   return(list_of_adjacency)
@@ -118,8 +118,8 @@
 
 .adjDirect <- function(ped, component, saveable, resume,
                        save_path, verbose, lastComputed,
-                       nr, checkpoint_files, update_rate,
-                       parList, lens, save_rate_parlist,
+                       checkpoint_files, update_rate,
+                       parList, lens, save_rate_parlist, config,
                        ...) {
   # Loop through each individual in the pedigree
   # Build the adjacency matrix for parent-child relationships
@@ -176,7 +176,6 @@
 
     iss <- unlist(iss_list, use.names = FALSE)
     jss <- unlist(jss_list, use.names = FALSE)
-
   } else if (component %in% c("mitochondrial")) {
     mIDs <- stats::na.omit(data.frame(rID = ped$ID, cID = ped$momID))
     iss <- c(mIDs$rID)
@@ -197,7 +196,6 @@
                      adjBeta_method = 5,
                      parList = NULL,
                      lastComputed = 0,
-                     nr = NULL,
                      lens = NULL,
                      saveable = FALSE,
                      resume = FALSE,
@@ -206,6 +204,7 @@
                      save_rate_parlist = NULL,
                      update_rate = NULL,
                      checkpoint_files = NULL,
+                     config,
                      ...) { # 1) Pairwise compare mother IDs
   if (adjBeta_method == 1) {
     # gets slow when data are bigger. much slower than indexed
@@ -267,7 +266,7 @@
       jss = unlist(jss_list, use.names = FALSE)
     )
   } else if (adjBeta_method == 3) {
-    nr <- nrow(ped)
+    # nr <- nrow(ped)
     # terrible
     # Define a scalar-checking function:
     f_check <- function(i, j) {
@@ -283,7 +282,7 @@
     vf_check <- Vectorize(f_check)
 
     # Now outer() calls vf_check(...) in a way that yields scalar results
-    adj <- outer(seq_len(nr), seq_len(nr), FUN = vf_check)
+    adj <- outer(seq_len(config$nr), seq_len(config$nr), FUN = vf_check)
 
     # Extract which cells of adj are TRUE
     w <- which(adj, arr.ind = TRUE)
@@ -384,7 +383,7 @@
       ped = ped, component = component,
       saveable = saveable, resume = resume,
       save_path = save_path, verbose = verbose,
-      lastComputed = lastComputed, nr = nr,
+      lastComputed = lastComputed, config = config,
       checkpoint_files = checkpoint_files,
       update_rate = update_rate, parList = parList,
       lens = lens, save_rate_parlist = save_rate_parlist
@@ -410,99 +409,97 @@ computeParentAdjacency <- function(ped, component,
                                    saveable, resume,
                                    save_path,
                                    verbose = FALSE,
-                                   lastComputed = 0, nr,
+                                   lastComputed = 0,
                                    checkpoint_files,
                                    update_rate,
                                    parList, lens, save_rate_parlist,
                                    adjBeta_method = NULL,
+                                   config,
                                    ...) {
   if (!adjacency_method %in% c("loop", "indexed", "direct", "beta")) {
     stop("Invalid method specified. Choose from 'loop', 'direct', 'indexed', or 'beta'.")
   }
   # For loop/indexed/direct: skip if already complete
-  if (adjacency_method != "beta" && lastComputed >= nr) {
+  if (adjacency_method != "beta" && lastComputed >= config$nr) {
     list_of_adjacency <- NULL
   } else {
     list_of_adjacency <- switch(adjacency_method,
-
-                                "loop" = {
-                                  # Original version
-                                  .adjLoop(
-                                    ped = ped,
-                                    component = component,
-                                    saveable = saveable,
-                                    resume = resume,
-                                    save_path = save_path,
-                                    verbose = verbose,
-                                    lastComputed = lastComputed,
-                                    nr = nr,
-                                    checkpoint_files = checkpoint_files,
-                                    update_rate = update_rate,
-                                    parList = parList,
-                                    lens = lens,
-                                    save_rate_parlist = save_rate_parlist,
-                                    ...
-                                  )
-                                },
-
-                                "indexed" = {
-                                  # Garrison version
-                                  .adjIndexed(ped = ped,
-                                    component = component,
-                                    saveable = saveable,
-                                    resume = resume,
-                                    save_path = save_path,
-                                    verbose = verbose,
-                                    lastComputed = lastComputed,
-                                    nr = nr,
-                                    checkpoint_files = checkpoint_files,
-                                    update_rate = update_rate,
-                                    parList = parList,
-                                    lens = lens,
-                                    save_rate_parlist = save_rate_parlist,
-                                    ...
-                                  )
-                                },
-
-                                "direct" = {
-                                  # Hunter version
-                                  .adjDirect(
-                                    ped = ped,
-                                    component = component,
-                                    saveable = saveable,
-                                    resume = resume,
-                                    save_path = save_path,
-                                    verbose = verbose,
-                                    lastComputed = lastComputed,
-                                    nr = nr,
-                                    checkpoint_files = checkpoint_files,
-                                    update_rate = update_rate,
-                                    parList = parList,
-                                    lens = lens,
-                                    save_rate_parlist = save_rate_parlist,
-                                    ...
-                                  )
-                                },
-
-                                "beta" = {
-                                  .adjBeta(
-                                    ped = ped,
-                                    adjBeta_method = adjBeta_method,
-                                    component = component,
-                                    saveable = saveable,
-                                    resume = resume,
-                                    save_path = save_path,
-                                    verbose = verbose,
-                                    lastComputed = lastComputed,
-                                    nr = nr,
-                                    checkpoint_files = checkpoint_files,
-                                    update_rate = update_rate,
-                                    parList = parList,
-                                    lens = lens,
-                                    save_rate_parlist = save_rate_parlist,
-                                    ...
-                                  )
-                                }
+      "loop" = {
+        # Original version
+        .adjLoop(
+          ped = ped,
+          component = component,
+          saveable = saveable,
+          resume = resume,
+          save_path = save_path,
+          verbose = verbose,
+          lastComputed = lastComputed,
+          checkpoint_files = checkpoint_files,
+          update_rate = update_rate,
+          parList = parList,
+          lens = lens,
+          save_rate_parlist = save_rate_parlist,
+          config = config,
+          ...
+        )
+      },
+      "indexed" = {
+        # Garrison version
+        .adjIndexed(
+          ped = ped,
+          component = component,
+          saveable = saveable,
+          resume = resume,
+          save_path = save_path,
+          verbose = verbose,
+          lastComputed = lastComputed,
+          checkpoint_files = checkpoint_files,
+          update_rate = update_rate,
+          parList = parList,
+          lens = lens,
+          save_rate_parlist = save_rate_parlist,
+          config = config,
+          ...
+        )
+      },
+      "direct" = {
+        # Hunter version
+        .adjDirect(
+          ped = ped,
+          component = component,
+          saveable = saveable,
+          resume = resume,
+          save_path = save_path,
+          verbose = verbose,
+          lastComputed = lastComputed,
+          checkpoint_files = checkpoint_files,
+          update_rate = update_rate,
+          parList = parList,
+          lens = lens,
+          save_rate_parlist = save_rate_parlist,
+          config = config,
+          ...
+        )
+      },
+      "beta" = {
+        .adjBeta(
+          ped = ped,
+          adjBeta_method = adjBeta_method,
+          component = component,
+          saveable = saveable,
+          resume = resume,
+          save_path = save_path,
+          verbose = verbose,
+          lastComputed = lastComputed,
+          checkpoint_files = checkpoint_files,
+          update_rate = update_rate,
+          parList = parList,
+          lens = lens,
+          save_rate_parlist = save_rate_parlist,
+          config = config,
+          ...
+        )
+      }
     )
   }
   if (saveable) {
diff --git a/R/readGedcomlegacy.R b/R/readGedcomlegacy.R
index d6b65948..7a420a9c 100644
--- a/R/readGedcomlegacy.R
+++ b/R/readGedcomlegacy.R
@@ -49,14 +49,14 @@
 #' - `FAMS`: ID(s) of the family where the individual is a spouse
 #' @keywords internal
 .readGedcom.legacy <- function(file_path,
-                              verbose = FALSE,
-                              add_parents = TRUE,
-                              remove_empty_cols = TRUE,
-                              combine_cols = TRUE,
-                              skinny = FALSE,
-                              update_rate = 1000,
-                              post_process = TRUE,
-                              ...) {
+                               verbose = FALSE,
+                               add_parents = TRUE,
+                               remove_empty_cols = TRUE,
+                               combine_cols = TRUE,
+                               skinny = FALSE,
+                               update_rate = 1000,
+                               post_process = TRUE,
+                               ...) {
   # Checks
   if (!file.exists(file_path)) stop("File does not exist: ", file_path)
   if (verbose) {
@@ -327,11 +327,11 @@
 #' @return A data frame with processed information.
 
 .postProcessGedcom.legacy <- function(df_temp,
-                                     remove_empty_cols = TRUE,
-                                     combine_cols = TRUE,
-                                     add_parents = TRUE,
-                                     skinny = TRUE,
-                                     verbose = FALSE) {
+                                      remove_empty_cols = TRUE,
+                                      combine_cols = TRUE,
+                                      add_parents = TRUE,
+                                      skinny = TRUE,
+                                      verbose = FALSE) {
   # Add mom and dad ids
   if (add_parents) {
     if (verbose) {
@@ -567,7 +567,7 @@
 #' @keywords internal
 #'
 .process_tag.legacy <- function(tag, field_name, pattern_rows, line, vars,
-                               extractor = NULL, mode = "replace") {
+                                extractor = NULL, mode = "replace") {
   count_name <- paste0("num_", tolower(tag), "_rows")
   matched <- FALSE
   if (!is.null(pattern_rows[[count_name]]) &&
diff --git a/man/computeParentAdjacency.Rd b/man/computeParentAdjacency.Rd
index 353a655a..003e8d2a 100644
--- a/man/computeParentAdjacency.Rd
+++ b/man/computeParentAdjacency.Rd
@@ -13,13 +13,13 @@ computeParentAdjacency(
   save_path,
   verbose = FALSE,
   lastComputed = 0,
-  nr,
   checkpoint_files,
   update_rate,
   parList,
   lens,
   save_rate_parlist,
   adjBeta_method = NULL,
+  config,
   ...
 )
 }
@@ -40,8 +40,6 @@ computeParentAdjacency(
 
 \item{lastComputed}{the last computed index}
 
-\item{nr}{the number of rows in the pedigree dataset}
-
 \item{checkpoint_files}{a list of checkpoint files}
 
 \item{update_rate}{the rate at which to update the progress}
@@ -55,6 +53,8 @@ computeParentAdjacency(
 \item{adjBeta_method}{numeric The method to use for computing the building the adjacency_method matrix when using the "beta" build}
 
 \item{...}{additional arguments to be passed to \code{\link{ped2com}}}
+
+\item{nr}{the number of rows in the pedigree dataset}
 }
 \description{
 Compute Parent Adjacency Matrix with Multiple Approaches
diff --git a/man/dot-loadOrComputeIsPar.Rd b/man/dot-loadOrComputeIsPar.Rd
index e4222523..7879c078 100644
--- a/man/dot-loadOrComputeIsPar.Rd
+++ b/man/dot-loadOrComputeIsPar.Rd
@@ -4,7 +4,7 @@
 \alias{.loadOrComputeIsPar}
 \title{Load or compute the isPar matrix}
 \usage{
-.loadOrComputeIsPar(iss, jss, parVal, nr, ped, checkpoint_files, config)
+.loadOrComputeIsPar(iss, jss, parVal, ped, checkpoint_files, config)
 }
 \arguments{
 \item{iss}{The row indices of the sparse matrix.}
@@ -13,8 +13,6 @@
 
 \item{parVal}{The value to assign to the non-zero elements of the sparse matrix.}
 
-\item{nr}{The number of rows in the sparse matrix.}
-
 \item{ped}{The pedigree dataset.}
 
 \item{checkpoint_files}{A list of checkpoint file paths.}
diff --git a/man/dot-loadOrComputeParList.Rd b/man/dot-loadOrComputeParList.Rd
index 22934c55..91fe33fa 100644
--- a/man/dot-loadOrComputeParList.Rd
+++ b/man/dot-loadOrComputeParList.Rd
@@ -7,7 +7,6 @@
 .loadOrComputeParList(
   checkpoint_files,
   config,
-  nr,
   ped = NULL,
   parList = NULL,
   lens = NULL
@@ -18,8 +17,6 @@
 
 \item{config}{A list containing configuration parameters such as `resume`, `verbose`, and `saveable`.}
 
-\item{nr}{The number of rows in the sparse matrix.}
-
 \item{ped}{a pedigree dataset.  Needs ID, momID, and dadID columns}
 
 \item{parList}{A list of parent-child adjacency data.}
diff --git a/tests/testthat/test-convertPedigree.R b/tests/testthat/test-convertPedigree.R
index f1a163e6..00139c58 100644
--- a/tests/testthat/test-convertPedigree.R
+++ b/tests/testthat/test-convertPedigree.R
@@ -246,6 +246,7 @@ test_that("ped2com handles checkpoint saving and resuming", {
     gen_checkpoint = file.path(save_path, "gen_checkpoint.rds"),
     newIsPar_checkpoint = file.path(save_path, "newIsPar_checkpoint.rds"),
     mtSum_checkpoint = file.path(save_path, "mtSum_checkpoint.rds"),
+    ram_checkpoint = file.path(save_path, "ram_checkpoint.rds"),
     r2_checkpoint = file.path(save_path, "r2_checkpoint.rds"),
     tcrossprod_checkpoint = file.path(save_path, "tcrossprod_checkpoint.rds"),
     count_checkpoint = file.path(save_path, "count_checkpoint.rds"),
diff --git a/tests/testthat/test-readPedigrees.R b/tests/testthat/test-readPedigrees.R
index efc09ddd..779dde29 100644
--- a/tests/testthat/test-readPedigrees.R
+++ b/tests/testthat/test-readPedigrees.R
@@ -225,7 +225,7 @@ test_that("readGedcom parses death event correctly", {
 
   row.names(df) <- NULL
   row.names(df_leg) <- NULL
-  expect_equal(df_leg,df)
+  expect_equal(df_leg, df)
 
   unlink(temp_file)
 })

From f01482d33448a08bdaf9867f271774f61971ded4 Mon Sep 17 00:00:00 2001
From: Mason Garrison 
Date: Mon, 28 Apr 2025 14:39:49 -0400
Subject: [PATCH 68/69] defined config

---
 R/constructAdjacency.R        | 2 +-
 man/computeParentAdjacency.Rd | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/R/constructAdjacency.R b/R/constructAdjacency.R
index 6c87e9c8..74145337 100644
--- a/R/constructAdjacency.R
+++ b/R/constructAdjacency.R
@@ -396,7 +396,7 @@
 #' Compute Parent Adjacency Matrix with Multiple Approaches
 #' @inheritParams ped2com
 #' @inherit ped2com details
-#' @param nr the number of rows in the pedigree dataset
+#' @param config a configuration list that passes parameters to the function
 #' @param lastComputed the last computed index
 #' @param parList a list of parent-child relationships
 #' @param lens a vector of the lengths of the parent-child relationships
diff --git a/man/computeParentAdjacency.Rd b/man/computeParentAdjacency.Rd
index 003e8d2a..6177f91f 100644
--- a/man/computeParentAdjacency.Rd
+++ b/man/computeParentAdjacency.Rd
@@ -52,9 +52,9 @@ computeParentAdjacency(
 
 \item{adjBeta_method}{numeric The method to use for computing the building the adjacency_method matrix when using the "beta" build}
 
-\item{...}{additional arguments to be passed to \code{\link{ped2com}}}
+\item{config}{a configuration list that passes parameters to the function}
 
-\item{nr}{the number of rows in the pedigree dataset}
+\item{...}{additional arguments to be passed to \code{\link{ped2com}}}
 }
 \description{
 Compute Parent Adjacency Matrix with Multiple Approaches

From 53e29c3b528c5964167f387b00934173780e2284 Mon Sep 17 00:00:00 2001
From: Mason Garrison 
Date: Tue, 29 Apr 2025 13:32:10 -0400
Subject: [PATCH 69/69] added hex

---
 .gitignore               |   1 +
 README.Rmd               |   1 +
 README.md                |  10 +++++++---
 data-raw/hex.R           |   2 ++
 data-raw/logo_archie.png | Bin 0 -> 6139 bytes
 man/figures/hex.png      | Bin 0 -> 43131 bytes
 6 files changed, 11 insertions(+), 3 deletions(-)
 create mode 100644 data-raw/hex.R
 create mode 100644 data-raw/logo_archie.png
 create mode 100644 man/figures/hex.png

diff --git a/.gitignore b/.gitignore
index 22835dfa..90e6d24a 100644
--- a/.gitignore
+++ b/.gitignore
@@ -20,3 +20,4 @@ paper/paper.html
 tests/testthat/Rplots.pdf
 vignettes/articles/paper.html
 .vscode/settings.json
+data-raw/logo_orange.png
diff --git a/README.Rmd b/README.Rmd
index ee83aced..9780c791 100644
--- a/README.Rmd
+++ b/README.Rmd
@@ -17,6 +17,7 @@ options(citation.bibtex.max = 0)
 # BGmisc
 
 
+discord website
 [![status](https://joss.theoj.org/papers/ee3a025be4f61584f977a7657d936187/status.svg)](https://joss.theoj.org/papers/10.21105/joss.06203) 
    
 [![Project Status: Active – The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active)
 [![R package version](https://www.r-pkg.org/badges/version/BGmisc)](https://cran.r-project.org/package=BGmisc)
diff --git a/README.md b/README.md
index 6b8357fe..eede5556 100644
--- a/README.md
+++ b/README.md
@@ -5,16 +5,20 @@
 
 
 
+discord website
 [![status](https://joss.theoj.org/papers/ee3a025be4f61584f977a7657d936187/status.svg)](https://joss.theoj.org/papers/10.21105/joss.06203)
 
     [![Project Status: Active – The project has reached a stable,
 usable state and is being actively
 developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active)
-[![R package version](https://www.r-pkg.org/badges/version/BGmisc)](https://cran.r-project.org/package=BGmisc)
+[![R package
+version](https://www.r-pkg.org/badges/version/BGmisc)](https://cran.r-project.org/package=BGmisc)
 [![Package
 downloads](https://cranlogs.r-pkg.org/badges/grand-total/BGmisc)](https://cran.r-project.org/package=BGmisc)
    
 [![R-CMD-check](https://github.com/R-Computing-Lab/BGmisc/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/R-Computing-Lab/BGmisc/actions/workflows/R-CMD-check.yaml)
-[![Dev Main branch](https://github.com/R-Computing-Lab/BGmisc/actions/workflows/R-CMD-dev_maincheck.yaml/badge.svg)](https://github.com/R-Computing-Lab/BGmisc/actions/workflows/R-CMD-dev_maincheck.yaml)
-[![Codecov test coverage](https://codecov.io/gh/R-Computing-Lab/BGmisc/graph/badge.svg?token=2IARK2XSA6)](https://app.codecov.io/gh/R-Computing-Lab/BGmisc)
+[![Dev Main
+branch](https://github.com/R-Computing-Lab/BGmisc/actions/workflows/R-CMD-dev_maincheck.yaml/badge.svg)](https://github.com/R-Computing-Lab/BGmisc/actions/workflows/R-CMD-dev_maincheck.yaml)
+[![Codecov test
+coverage](https://codecov.io/gh/R-Computing-Lab/BGmisc/graph/badge.svg?token=2IARK2XSA6)](https://app.codecov.io/gh/R-Computing-Lab/BGmisc)
 ![License](https://img.shields.io/badge/License-GPL_v3-blue.svg)
 
 
diff --git a/data-raw/hex.R b/data-raw/hex.R
new file mode 100644
index 00000000..8dbfe218
--- /dev/null
+++ b/data-raw/hex.R
@@ -0,0 +1,2 @@
+library(hexSticker)
+sticker("data-raw/logo_archie.png", package = "BGmisc", p_size = 20, s_x = 1, s_y = .75, s_width = .6, h_fill = "#0fa1e0", h_color = "#333333", p_color = "white", filename = "man/figures/hex.png")
diff --git a/data-raw/logo_archie.png b/data-raw/logo_archie.png
new file mode 100644
index 0000000000000000000000000000000000000000..2a947a3731029bc6e4a464b57adac8fcdc292e55
GIT binary patch
literal 6139
zcmeHr`8O19__lrMlPyJAhU`8_lHH6JO!lG@GRm5DieiiHP5VX8z
z=D@+hiTw}!eC(ZP=iZyK7lDV@oI^P{Y?l55=aZ4OYz_{IYD=@rH{toKv!>}kuZ4Ba
zuRK@0I$?Cd2YsWW=6mPeOR+NqUav1VD$c!o#7pB6WS;Vx&<#6o_<7=0>WTMnZ+d%c
z>+Gn=pVlI8adNNvN48e!SRQW2dHq6>NF*^1uQdSU0*7-Fki+l)m=A~s4
z8cjW-_h-nuW3Df@L}j3o+GV05qTM#Pc=^7tIN+8i_nN2&Sn*;-Kszytyg7K(=K0u0Hy60oMs3Ns&m5D
zEvDRAz*lYN1{nJL0JJ&4r8qkJY-7JZY0e1LckWmwP?5NYbJz!_h+qomAcS~Dd0W83
zmU9EWhP3s){}tzKUDVcVQmHh7yY=U#qrTMdt-0&W$QG$L~xpKhRv6mm}<$lA?y
z;bV~Z5PtZ`nMKQ&G#rH`eGLUXZJ);7%(^EzucPL=pBg~MTPr-rZzx~yS>kLA<6vk$
zVTFML|4>^Fe*_$TbM@4h&jcP1Ugm7Zh9B`mKp2g&o_@hIxrP}
zI&8YXI#+PW)PL%x855_^xDaMduKdabdsANX-pi)TwK6Xub`MDQ>v@O8?er($4oJXU
zrEW*e2eO@w4Wd(}3E9g6p2W}ZZFTHdN?>apR8EaXnrw{u61m0I40&^Q2md`lj9^Kn
zGshJWomX{{*aUQ{3)(Yn3j-(t%-s4*p}NRcw^RV)Uq19L4T#(;aPO8>5mtcCiGki3
z)~Ta?_ANXj#J1nD1pkS1LXoz>1n%H}BS0{t)5da5^H17`*%@$4h+k`h&D}mS#^dp~
zVvr}SG{e)w-0YdL9}&mM$l9QT1BAc=bGL0|%Z?fQFCxi}KCrq|pON}*4J!t^H&M78
z0pVo~41hu&^E_vy(KyW;g`oK2HtGg7_|&C&_DkL&amGer_V)I@F=)nI$I;x;!49=3
z<)E-BP+;zweti;f4ab}fcP$(b5XF>Uak}tuD}OQkqjcvtu_7AhY=BJL?bmIUEG9}f
zsss?fyS~_ux?R-a955JgrVV&SzjBG_%U1$eaZrF)dyoQXzs8c>`~2|iGRreRPCnWC
z*HqLEx}|=f9%8CPmPn9j+YOuf`k9ttHYxq-2>EC70bUmi8G5=-ea}t0a_K9*=s|+IBl~O6oa{({`L62(wCH?3Vf9E$uSY
z1xo-LU&05)FuOKUTgmLI!~Y0Fli(V@U$hr=*&ilO_Z}2$>u1?TDtVBWZEvzaeth&t
zJ4MqsH?)v;nF~_%1eLSFgRZ_I>n;MK6l)YsXumD3z!nw>p8~!6*AWO31zjtl)-xh`
zw2-)1U*K|nb;g}A07^x55OOrr+Y^1Yg;SpJZqhM<+5*5XE&Xl^47C4`J>
zv`Fjz0ne-VHWBM)2ITD%Ke!uAM!^EIIxa!+t|}m$I=c6SZ-Qrh}
zo@k;{sk2Yh<7H4*fky#$-|ph8U<_YadPwR+g`rf1_$Kc-<0E6G1wbWtdt6d`+G7U|
zgj4z?LGu<-VSe!<<=|RCql8Gi4b(bWohKsxT;e|q`w@0tUEByQ`M8>g)|;vN?jJAN_$D>R9of?J5F(H
z3G8iLm8kKkbSL;j2}vFv>7nBP@YB(D|I^kz>d`^RK~=bF^F@NX491~O%*cRTI$7X$
zXvCSSX3j+X1GO&>1!b%t`5047hJd?CHw5joHqkR;26$+aq4B9!2@dKX$pU!kJZ4(i
zMNlbeB5j!zPD{bPVLF5t_OhVdCdqU8i6QB)hol~&{F5M*r^00WK~N`;R?S(IzO`+H
zb-aY%XEBqUaG@XAHpAX??eis07vL4f1CYtSUw?+rSjYLcawqw|r)B4CSR5;y#h!|63exYm
zdnWw^7|~dXnZk(~#fA}|$`9SZ<$0*U&FⅇUNm`|A6S@+se#(7pY`!{?11Z_K1vN
zsG9BCfKO`;0Av}dU_In*TgRRLnF`lis8e4la|-ZtTzjW63ItiUU?Ktr*+KZarhgUG
zD0-d>9hSOd_0U&2%4@1rg0766ax9$0nal?SFtmflJe_x`Osf+n7Cw9F-JgF2u_N~M
ztMB1kh~>!0W&I8{Y10}n({E~^r}87!ADz$dQi*wDPzdsgsONA5ehNR+jzUSGDMF4b
zGpO2cY@(@wCG6kB6Md@H?AHd~Grbe()2D&a&vc5$b5<-&D{`4(A||TcAyh##VjZ@Tw!Btpy
zFXJ1hFbHByvc~n>!^w;+uipWuw!Wz_=p|IwgyO=fd1FDz4rFE^Yw=DJttC`!;elxT
zsN8x0HZTtaR~gE?Bv{=QeoV4Mq2|Uha$a$%Q;13}uG2`fJN%ePhXSnc(LRE$X)kF@
z7ka$!BKY4;ZYtekniK){%v<|n%s4W@BmA?`${tOk+Go3)Y_r1Yq2(F!dW_-DS
z-n6HWP4T%F6Khg?JT{EJ3f?7(sd#Th>o>sPY@Q0Qt3^fxMBu-na1sAN8Z{*bQ~%_mi}4>k?0AMdKUkLXb!^CHh353gq|4QJa#79~%IaRGwLQwyn^U&NY&dIWbxlo6m=oZ(=D
z%DpH2(oFT^X0%`uOG!*Yss@#;)XY
zb2If4xT&XQD-j7SRS8?pK0b4@9EC!8bV%&17@lis+XrWo?Xb3yapCSM^dRfC9>J+=
zy7Yp7Z6hm%MrwNg=nQ3=c@wKtX39v*FYILv*S&?vJBk%!As&8Qfap4m^Vg1VR{}YlqE;OfFr-S9JF2760
z=&qXcyZ2DWlU#>6lBH7B1DR}H)C9l%^mrQ~46XWF?UltN6!J)6D4RIf`A}&5L6fL#
zY;RQGlN_HF!A;v&`ILdc6_?eFg&
z9kn>gTZk(}UAJHmwP3*Y#;XBH6Kfs@^m~-Qz$?pbOU6yr<4s+ph1^`%_36J`FED-d$r1B
zl2es3w57E-lVv)=PfxFIsy8CBiVrl47*(6a!*Kww3u9>-C@am-bAqnJAJC825`=bd
zEKbf_Ag2@am{zW>mnYutTJhn%0ABimOshirCjs}b+u1_EOJUvTV1?P3ywITUEDcwF
zU@96V+=%zuUK&84
za90o2WZY4Md415`h0W$z+eE|x*6vKT=?5gj{Py$LFUw&6xUzN@%VWHXfAx|f>*_7*
zc^e!^%cFegYFqxVh46#9qN1XJL;hC|Fvn~)v~asUnt;MjOi^qjIEKoLm?I`6t}&0n
zloV+S~x;ds+l;IYGid
zs*4T2gWOgkAP%Aks5Klm__vv>Hj&2p>i>eEt6y7-RD%5x1+^-{FZq=~?u^h{dcWW_
zOCTtlh!v%%Z=(NQ#agw;9PAqXbpOQZ2)v#`6Ma*z-i%M)GI7^5b3)ohbnI`W=-0%$
zKRwXhpW~bm!5(Af-;ds7RZ}}$ZXtE2+rSYbmo0oF>d#vr+dN>7+Ls=k64o*QesXxg
z3@wM79?2p}tb5)>>W80bJ>WsRQ`ekXUMEYMuBSA6V+xz};7Gj;?Oyxs)6Zzbv}i;m
z0`Z$tIf+k@NLka48zU^M1?MuR?ha;!o6IY;UL=IBR%=yYniDbx64Rks-@WrTc(lOt
z3Loc7B!WuBFy0zLEXa1!gB&WeV$z!*`ZMp24SaE3LzZw{6q`g^wt)}jZp1oVfoLr}
z4xbXmymu@VfCW~7}0IO>v6elHouq{l>mY*Cn3&C8WqT
zf7{SF2u$8SMnoQg
z{#>b(|DdrEycC)zW+M0Tz6utJ8+yE$Oj%FDTb29HnxlKNsF&9_dW25n9%e$5DG^?j
zQXAafe|?-#OzJPIIRm{Qolz>(LNDkaaBYOiRdcQBt+8?Cu!y^d2QsudfjM~Vu7B}_
z6zQZfE>8s>VT*<&lX~75fFym0t~yHsvq3+EZpMY@sl5<=zJKBehzCYK*%mljKmq;I
zeR(8l@Mz}&yEQ1-;9=AU))^bV()UizB$w^4*lqw*d0?QS{M52MOEk;QdoVKd(Pv}l
z5tA|g>AWCcX=SXUP1s7bOucR7=p2cqQ@BQO4FPE_XQ2)dFS*4t>1TIN?8SMLwR4z!
znV`oib<0HlqVHX&&0ri?wk%eDU!cPUEkwWwwykx0dO6UKYb$rM_uf<~KpAV7JniX0
zDzxkm5OLEdq_m$+zA1G@BF`_Q^gk2W8rCDEdOs=SY+lWBqcVK6Kvq=((+)Sq@V(Au
z>WN^Cq_2h4vf0SNjIp#-KFR$%&MAGMcgaTxefg#v+cH>;Ef9Ed(-t$$K2wXTNc|nN
zvO8U6VpQEV!x9EDI(g;xnFfA{er{CWk;QT6Sily
zzKkgR5$}DW@Kbt-falM(2(M?(KNxEZ@J6ITLGwAC--kuJ7D#$4d34kfU~1W6;yC~u
z4I?h%>X&RavF&`$&vTgw#A94;iRCLj|HKayF($+q?FDdfM5bFp1_W^==dV)Nl0>!$
z%L?y;*lHrr2K3{XVq+3sLerG&WG!zevWY2lKYuKJsH`boW|7^7B9k)h=m*mcBmiOB
za{C=vR@OpozJ#<0xb7L={(-bNq+7h>rBUYqtTmS^EAY&_U3G!GB`6SV)NF&|dNJ~n0mjY7K9g@AGv5bML#q
z_x^^*7|3wI-rp5-&QHv>c8r>;9L96f=MV@4LqT3f0|J3Z0^fQl;9m$y2L}`Qfn=d1
zCj)+huN&!(An*g#RbJm60^y*8eZ%>bhteh7fbK-~%1^vvE0=ZND=b<&0lVg%m^a+1-8w|3Xnxhe++K1NnnvY5W6
zV!~m-swKw0z#AACI4?;}g3DM5;XFrZU4PRg*6DS)Bq2aSic^9O9xLVy9!sapI4cd|
zIFcF@qv`)_ZEgMZjG6%U7u2x7c=IhB_0P-f!(FLpL$?FrP}TPu90Hlj0v|tqbk=$=
zCsPqM5L|vdz2bajEfu|vK)ix+6N$a)(q6N!t*)-Vig6>8D#L~(6Cm&AcB;j^O$(Xz
z+c+eR!0thP2LIIIxj*NM)k%eO0f9X$zr5V8uGIbtp_K*I<*5yOv$Ub1p(W*HO{SPQ
z4o;o(WzeI4$K-AYYHto?=7YbW3o4B>2P^B{Ki`KWWsG|*B%mUwEz1v1H2r;$SB!UN
z-Lxzv_bz>0fgNsJgOOHL=s2F_u=m+I^!=+4O!s>N_yGMqoD3oK{3ID-|PF#z9x_kMxX@?}^AwjXQr%nOI%~D@~
zkteM{1{$D;9X(0GTMBD07V>osayr6=%4c}_S(xPsk_qVY*LzE$N`)ZlB
z%Ch8Uhp@^P#9-{;DBAbK2-yNI&gvw}GJAEz*d_TDnq`SUJRi&mR%7lFQLC6=m
zXf)$7PT{}*sUvweO4MiIE%Cz~(o4gWO)F%>^hB8&dq>x4P4I>|6PEz}aICDLUN{giPSGe|mqsc9s3VNih
z+Kk8VHP$ptOdg*Lu4TSp2IKZ!C{{?BVIv%Mf;c0X>89;dX@~AD>e75zr9dD^di@*6
z%E=$EjqIaT+>3|&C!AoiE|X(Iu+{ifAdV(+K!T+!GE+U{lF_yk^hSBJ!xkQNjj#Ql
z!sb$d+Izfl`2MeDn#c=M$Rk#7ZKsJ#LZupQYywCaWPAbw0*9-;K?CM5F{voMn=8&STZehvyV{qk}jo9o(ic715g4&q@;K_lcB+I&0@d*&UXB*xo
zwYq~Tj_!+mvHPSREb3viFJi@b>8#0zwO&9X;W0?
z5lEKBA{`DJxhg1*jc7_b3pzXfOGeZRAEUu?r|eATxj4UhbBjgO?*jKi#19#5u+V1B
z69tpJh=pg{&RqPhKxcS$f{O(4p4e|R8k1y=wVey!D^@gyJzEea!Ue^}zdZW5C=s|M
zwM%n9#$_$)eiQIgtu>UJ(*GFQH*9*r_o+ikdk_f}wsZ}#-xt0Qpp4vxJ)X`+$>X#v
zi@riRMTQVnj-)c8?X40OuAMs#AFT`uMhIOw$*heq)Xh<7k@%^hxEX?4a=vjnB7+J`
z$=+)HMxM~G8#xeXcr)#^W&dx=(6M&hX=Q5!0zY>1-@{919B=1EvDl%7JiZr1`&gYU
z(lNIzAf*=gT9yNvur~uC2-*>m=W_YJN1iAzh@)2KGvHN*ji2Bfnmdup$&T3~uwOr?
zIeNj)t}T2KQ(kM%P5nkrLE*b{AJ-#FZxM^8w^gCn;MLD;*Y-2F;edoDFRC+Lwvesh
z86iag7ssTeq=bhnZM?-i8RfNR+|;*`_OqoJF|UexkX9ZK(8-lDRp$bodkm0B^<(YX|EeGL8$D7Rk@i^09FS%t$-^#yT*}9se=!a6B_(k+5=E$C
z9kE&ukNLM}RjbZVsKKUiYF?L^_=$2CEBn|JR0S*_aOuCn{qixDRK2OfelsM}^L&G_
zcD_T&`h|L>C3pU#RO{-Idjxh8L{L)Oj*pj$-@Qiiyxji5hHOjA+F3ZZ^T#B0zz}I#
zy*VUl>G0A|x7OrPlSDbS@;W8{_8$-$AFwyoA+{AGsWxPLO5Jg{h37QmBQK@s5y_*P
zX@Umu>U55^Ner1w?q%P-yP1Wg9=6M*#)9ciW(m4kB>s5wz#se+`ps=vg=s?iaBQ@o
ztV2uogM}37@WL&ek;4<5X1;=P4K|1VT0_AtMuO
zUqdVnhG>Z5wFwkfmC>50y&vL+m+qTqPA4F_yxHR|wWd8Lu==3|ustAlXiEsOmllGj
zZT)KYt(wUG^XtKJ#MT72TC30E=<_2C^2>%bJabqZa8*BUqnaG%k-!Es;KjjRpn|$n
zRGf;Xz}y2OI%~}CMLXnzVLigUzACnaUUAtF6TG@^j!K85!&LF6@$BrZ1f(Do8EjJR
zOY?8x9#MU#Xw2K}5XZ{5hJ(s-;|EpP-?d(T3%L9tmaYzLd%q<#2?a2tzBR~@2WLv9NnvC?M?eaHWQYIcjOJtf#n{Zyum%P
zwC_7!x~x@u?BS`uHs{Va89MZOO(ewz&!w$h>O3j28h>15|LxDpU~68z&av!cEYpVI
z7Zqzqyx?`Du&+;R?Vb*L)?Dh|AUsSg&whQ6U`+WFNYkHI$x|{l#Rrm56(nJ94a-Mg
zGUoT)exheOVyNz#O(VZ3AkJsLT`nQ}Smo(v-1(^jmV@YW^tf&Mitmu|6QwV)vg5Oa
z&~Uskz%F%tijI7*c`E!?@d*_Nqhgd`lcJBynS+z_NlX8Qx&Roq7GrE&Tn}BzJwh-}
zr4-#_m^$z7n=kPvu4I~MJGP_RgL{xiCUVRt8<0#FpjK*azLr%~kd>89
z;aBlP@AcQtjQkPOUa>B{^~;@F#YVdx8nwvU(vs+1vsA&;OxSB&^eW+Yf2Kq!?WkR*
z7(NcJB(<=x(4VGXR4SSZqSlz5jBQ7{E{rL(H>QEB@DRd|uK+^p
z^!`O)HQ1*rJ@gk0KL1e0rJfB*MR)v%4nsvS^0J+zMWFDIN{C8Z_BU_1#s@-s~79>~Qn8B?hN9@M(hzFe|^@
zrfTgdk8c=6~wJRmx*pPr7llW7x
z4)KQdW3NHSYwH6Xn*Pbrk&#EtMDJ31u+WqO)+4EoDc}DpLBtXB9SQPXR>+|f?YQcR
z(xsHNfUy~hOB^i)_2U1nh+l(jl$q3ecL6+<0YROlUuPC#KVM@!k4h7WOl_*|Y}acC
zqp2a1BS$jWp3#Jkkq&(tAhOYs%$`1%Zw;ECSL_~S$8{Ev>_F#WN7Ji7E=Gr!r
zPm$GTQ?LCgct&#eku&n}H%D6i4~-EKxg^T2jIEpsI*uG}=uT0U
z1n7X{X~P;rzt>b868}0KXs2VYJ2GuX7e4f@NT7lVSfneCEx7YD{-I1l{A|4;0C@{&
zDN=&;_=*D#so*PZdiA{g2!zjDIRf1^uu@qPX?|Z_SSSUMVb2d>k}+k{t}-MEp178U
zH|t31@Sti##GG&*2YbNGUNE#%`!$V|cg4s8^}mYgSiog%1-3Vsk5;9Y%9%Xd&l(r+
z>r&5P73X_sBlH3DN*E9
zQac{BkkEtW;AF1oygc(U0+)og^NS$*%3YH2j>e)*OCdfOwICYU-(r}RQ<#MQ^p$7>rv@L%b
zP$IT+BCx68TkAp6;#n6!S?h@ZQWdtgUgI)vhe0AM0X4%fv^kQxjv}gvr7u(kfv{n4
z&c-A5p!dhemZm?CU*+y15`!#NHJ}hWU@?W&y6T*SZGrQDWm4#1%=)IFRU!WWOC^Z{
zmE`kjE9Xv(FifnvxVTti{=zQ;8?9h((!kE{pBr?jN)LWJou&dk4l^SIk5_f1!;jg@
zArTimsTDoIK)XlO6xrF30;V#!Egds6GsOv{?r|j|D_44xQ`AMT48qTWJfbgjrl*zs
zmD&?|(2!p6=Rc*8^s1=E5lHx`1~o+z@D6dH#_R$)3YYJQB1!KKd1GUm@Ns&!HGx~5
z)5^K>)moNqa(6(}$U-#sCO0U89T)ra0u|_`zcydrh!p|@q_fl>$bU`k(k~0@x@X2f
zA7O=UCCB)R-W50vo7NLI?}@TlCOxMKR0rdxhm>@1sJ{iP{Fc{dY#1Y|&l}-72o{Zh
za|EgQ8#$tKKUT4Ph}H;BM&fA>cs9SZYo;Nx)<)io0q`JgL~ZXK8&Vha{^opKEbll9
zas-!ua6rK(2*-b3BbN*wd&|duAa@j*p4@bbfg-K@k+sC%1jVgmet)%=E!7u4PLfkg
zOUok*j2TW)|37J@uiGo&jM?iHA9IW0(1+8iBNp>T)SAT-K`I)#Bo)iI%cN(-Y%dTz
zH+pD`1Y-jW()}5*GPZJW(_r68*<>ASG8$Z9(yZu)bP_0;eHJg~xeUhMYzD=RsP{0<
z4}&nw#B8owpX96A2_{4Up{{boiINwgsj*gy9+rBvdjsJGbPl5;!^T(eU)178euFAS
zHZnTe1qzK{9dYr?@k1|DhVWJ@iIB=E*EK-OIxs`Np;pqylw)xtW+itVy|W596U%q*
zYm&
z2Gkj#uC(9F$Z$15Xn!~xTd#%27!>gf592*P!GseKD@B#(4R6zl7W|0Zv4
zZn_tz0!XL=kdT=K=dst5%!+F+#v9)zuhz0xM0Bf877BJm;NI;U5mzN{^u0Q(NvMyMBH^Rt{mbZqpdi
zVBW?6J`g~Jsh)b`7tLm0;b(J2{c6%R9x)|yD_1sxxyv)X*+atyL9wLW^D-z$Y}+@L
zncHbeOY}xMsa|w^yt%#D$ErkUAVequL~>UNrecd(c=yI$9agjc6mjDiqQO(Iwf-#r
zY(5qUB;5j-Kner`=>#ZX1eUNnUP1)KQq>$`9?}Fc`ta)-;LGq775w&xrW>L6S?B^_
zNYw%s+E0Ue;<-pV7RxKR>&*H60Mr$ewoyIwcC-Is55p~JZ8yi~MrH}=(tQw8)27E!
zAHnwhyS|mv7wFk0RgDeAk%2+Gy1t!wzr~c00dR!3HAavj=sE~kAg6n5L%1py`Xd_slDR0E(iei@-BS&up0;guKz8M
z)OdGE|C2|wgU~9kozS#i#B53j9aSR?<(#Jjk6}{D5-jhLiyk%H{=C
zxuYay%0sYkD34{J-J3m-6O&sz8>pjN1rq5Mirf6~d%CA)k3Sj!BrXuykW7D``kX;l
z5H_M9&;v&LXIX=JvF#-3bR%xVGBOlQ7*_tx@PHWh9sutzsPSKmx51i4+E0WK0YaHH
z1i$eF*GeYQ3<7f_MGc0ENbwp33Nla^`}fp95yl+E&Qt#_Z!lus79Y1cp9Bi2PEOyB
zbM81UWclzB5L9&tQ{_l}X$KJfd0Z*`DACdQjWB_TMWxIBl%dh;&W~u=}qoozb913BFq2k=q1B)e=60-{@
za62&{JUZQbSdsoUv^nAK@q-(*gS+b+)kW@DKn0xSIs-j(&QPe+kLo|
zjSF93Q~bubRpI`ZnZeW%Fvbv*Ygq*N%w1Gv%NHU(Zg1a`vqVjvB1N>CgQ;eLHKg5P~qVX-uX
ztYm|d`Mbe-G?XPwQ$3FZ38>#bpnkD?ue7Wc$HNB;&((F`a-&yCYqR0tRM7r!X{4YB
z1>l(9S1ZjX0&1MwbaFm1GX22
zE^M^SuVkc$PrF0Ok6E#&>qdSHfYuf}OsUuKd||p6w4eqxk`u^Tbh9s&Q}R0!&@toa
zkM9Ro1~a0|^SA`&zcuaITREDR@VtcINP--l`gSF-g!xI;3L_Byee@oYBiE2V~uuVm|eEAvT{$yy#1eTjSN&#rvnZ-
z7f?kwI2Skug2A6=(vyu(g~JO#EXGBeujr_&*T1$df5U8u4zne|Y@eHjRw|3GMr7&3
zOzW3G7~!ZZ!(3~_8$Lk!E8{WXeYkLA{%L)8zC)PywX%3+ar)3J3GSp0dlUXYRm3?&
zW0(p9K$(YN(20QsF^J`~dStkjqYK}s5d38mA?w($U+iaj=-v#17H0QNu(vPrmxucO7WdEi2BTiDGtR5i+q?{1_B$aS3A)l$WuSax^5aXKOSk>r?~bCG&8*%
z7#>6?zE&(gWR_lwWvJuRu25bB)UgEU8-9B82gxKtgruRZRESY;*dp`~C$N_OL=FuUN`lrTzsaC*oA>U(9)33dY7?@T9!LksWsu8|w
zRj6vuGnJHy9YHHvT1Do|B9Zqk{@ef%bV&?3!>_e{eQ&q^v#lRXomr89bR{EBcol@a
zA#8n2$H$lJFT7V8MD?FS!g>EzgVyqn<=5vxB*vz#oR&9PUY5XXM`n@kQGCap!DSx$
z!@1=Nzqb}*RX&1&uPOmj5a(apIy$=CFh(9*XuFoSXLhXVBE*ayZUXn4*VarL#~l24S&VrJOCJ!q4*n%+(YMIV@0%S&&vXGxn^jNyE&|R=q^GC%#MD-cV?(%L
zB+cFZoE`X65JBy(BG8tFj)7j%5%#|WfA~-;m#ls2yYI6ruV($XLt`Wx2t;v22w+G^
za6X8=TH43h6O`dgZD`XxE8{@R0;kzMi0@i?{X|@MzHM3-6Dmps)1&2NL
z`FYx~@dNr8FvD@Xj5(0LemgDC^<$U1q0=VE#=*hyOh!RY-g+Qa
z6(!7F08VpjVla3YM7^xUZ%t>+#m5Hof8s&7**6z-U(-T6IK%l^mr>qpOxcG~y!hT?
zo-Zw3svV|+$2IUG1Q%D*n6_BynMaJ7Rv}ORRsF*&jo$n)weNNiIG9*p$u#%}5b+cnVOBaW881Kdma*B!#aal0}&NckB2WV?D
zM+EpEQRBBkKla=vhg@MIp3LMD`n$eJ{`)~~gX?Dp-Rw!1x_w5f!{HM7TSyulMO9U(
zk7pj$F$FqxIn&*G-Id7OMJ~ayp{JC^t+>M9rixc-OnbcHe93JW(tz+0mgaMw)+!Yf
z6JL6e3q4^zLrU16k<>Vzp%~bxY8H6q`c#T^@8A-J6vXT%Rf^c6Joas%Xl80csBF}r
z5Vy!wu=nkhEQT(I%hgpSyzn5q=t7vBH1y8ys}1`7?@9UP%!R{IR3I#&N<*^0VFE;i>yaic&m&>)*v=
z&_a)HpZybo$tKt@yv@HQ?bQ)r{e*D(d8yazB$4!!c0f
z7&o|3tql0l-)3;p_Qj(L=_rr4n8%JTUCOU6Bg2=YF=rR7)jBz$So${;Ot_?meJt_j)+biu#i~gu#oR;m`w7St!o
z_`-f%^IiKC(H$ROIL3iXqD6owio|}s0e?sZf}>#3RERg$*~?ItvL5Zs18M3#U0^p4
zJ@brtGSWtK({)OwxloBGUkIntM}UkEi%Y+?G()eG0Gliz<=T5GE?NLn`@SneGI
zjMJ6iaMVq|T1bf2FqUuK7}vWHeEKwdlaNN4vm^D9|FY%s>&F+W0p}>
z10u+l$6kUw6SM=DV`NrCi_(^+PUV<;ts7k|2M*3b?BERnBbQL9Z)Cny5aOL+dc0iW
zXAs#rCc|wFw8ron(le8nf#!kMr3SP=Q)(gebL=kRg8B!SxSK5TfTi$lIiI`W=yFki
zmXHtMaBW|2P8`6w9=673^qBsccY7L)#N5?*vL@`U^Wbf$Cgouxona^a7AfQ2FJZaR
z+r9HbK)+B792omRJ4tzGp>0ilNf2Rqt}G}pu@pMg{Iakl?;d;d%bSdkE`7;-yl)*z
z3nOJT`+H4H@w4~8<*fOCcg8*WwaCTN7jKk}6f=jbOT<%G#XPewK#mL9!CyE%#8Jg>
zb0p4l3K@q6#-u?on`BPyrJs>iO6zG7gtjn35BnN*xjGfk$*;>DOl!vF
zJ6j?%d4v5j?Q8{VY<^chyN#|exckm8M;Y@D@Pa`Zc;f$XBk&?EEK}e!z*UQoep?qi
z|CxvCynHaxxH+`N>$aw5JBDX%EirUPC;88#Js!&&kru20=CFh7c@hMXzx;Ax!h_ul
zH>aankQ%D=kUZt#{;4nhL2S<<(lcYkA8ZCmB0dj5snUF&)F45RUn*8tB}FX#6A{zn
z6^AOq4lh?qUVJYs_dVF+5xt$9RY{7FWi}7$T$B51Pept@Bji2p#
z)lysO^RMWB3L71wf9X)zYyJ%+wd?nCzRvpfB*Xc6&+EO(a%H6`lXY!N9(Eu9X0!p+
z`xd3}SvJ?7u1q5iQi`!(!F*c--o7lw`n__xs0=U5!5V9%bN{;-eZ|-$Y1g~S<9agU
z77H}e+z?gq2;&`tcKg^p&3znjpF-Z?_TEd@$9;`^-mIrez+t%m;A~oaVfA?UQ}rJ)
zkyx~)SOf{g=jmLz86BHnSIpHMjB+3$E4@A^JvWH=1S9_xDkW={6;Q!D4=
z7!94DB#nmiy3iEp@HMoqn+=aDYugkHTvl(AM0og>Na~53r3nA+
zS*G+=*L_X63L=E6Jb$mT`=lZ~Xgzzfl)0+;oIV)iN6u5Oh;=eW)g)DQCqAS%u@nVf
z{phd4A!zMWT24Qs%sKjY)A#AHdnZg9u5;z9+dzuDrKyFnI*E*_p&$Q({kLm!v`1kP
z&Yync^{@rV!ZXO*ljlY2^tgrK3;y`Th4zUN>{`mneorUv%xd8N_pcIBw*ZW)Si^Em
zHrmXrNKJ$T%%VoL3cp46m$q}kcO5j7Ua+kx<~uV@wbT6!7-%ETn|)-Ol4e)GpI=(S
z+|47W!-Kq>yZl^*D6#+ja{lOGi{qJNjG`7a+;yt9&m5OH-RWzL{;BxQIyVE_;jE$G
z%8);PyunN=5mEEpDMM&#?Ir0gRZgd;=fu?9vQ&%-
zJ5o{=FR~=N$BW
ztOq{5V0oZ0#U^kexS6|Mdq7z|y*D#LV)VDnl~GX}THVI*dFL|9Jvo>DYx$&1zy9_0
zJ1@LPzR@2?zee*p>I-?IAI87>4ES(>*cqISQwMZ~3B((^-a}Z2K~$$@SXHj;osrj`{#Xf3Ou`
zzLV@~XNh*uh2~eLR28GmT9{%U#qr{F-?Z+w7tt8iSGTWHFep_?U(YS4>A9^@;}5>j
z7-B{2jt;pK;J5hhweBYFG(m1RlxNev`LQQ1Qp9aJvb{A=uLw8i(L^5lC+v_r=&3#J
zFg^4VjA~mhG-pX)6Yz%#51LinyUVWt1Dy?YqbO8j(u|Ga^IpoFfZ9BHaA2IYuW{y@
z0LL)Cn}B1~(}1+wW%#26Pg3&JU4N8_8$qGKq7Kzp1}ch#j&TpC;a(@QJ(1L|9-&wv
z7xJ%p&HPP%Ql^>&{foysn|7bBUbondP@*1G(r}MVKknEiy|7Tj?vbh8eHf4cI$BEnklwI^3}s!;2efhYh+~JSDnN{blk;93bL$
zUGvjk$nF(=q6?(({y4}{UCMkx)7x
z){qYtYt$k;7!A_ty(1&kkC$y&E(gcg0s0VbssQwhjlKPz$;lxz+kKs{UX8&J>}W-3
zq=%zJ^ahiIaCaR~ZkhM>i9*1p2s$Y)tjNy~WwOFSywiSI1|d85b#}HO_MHAQbB!+}
z(I_GA7w#DpemrtrO10tZ5q6!}xyn8Zh15!wpe;
zV|YNb`~6kSvGP2Y@%EdQ%(F-ukp@k|@@KX!m(~x^Ah0RsU7V5NLp#7xkCBWlmp*`#
zUpiR2Me8|g2eUU9vYl$sy!XQEmx-PnOjcHBDppVD$P)rw#EOu;`Qrx+@$Ohgw;GL!
zKdwCxY0a{e?hy8K(8P)F7E12vccuZZ>0pX|0JJdnc`qJjRH<{)i25-NZ4ia>(2Gn)V$Z*q^DJtdKXcvL4D74
z%{8&#L$Y*B>vj%yStL|>A}Bp)bAWA)b5o%n#4aK@agXkU^x$||Oqovll&+CisFcs_
zm_Jin1UM_er;UjQU;Li8#EmB6q28ND&Pc(syhd)i_Cd^Z9L_IOemCl3yqx!R_AL+(
zX*9AGh!CE_?I0GktVaH$z<};N%NI!*dQ#D?a7_KJ)
zIKEc?`NG`jc3R!&(am%0?&)PpZ=TJ-`T-)O(z2SCDEdjz(xs`Saez7`;7p{0r-xzU
z0r@>?7epNu?Cn89;@yI=F$^|I#Ie&}l
zNUVs{vDv55c_!r=f~goT>maK$(*pH%W;8
zReJU|++YUNCD5A6WY~9N2eugXM7Am;+CeUY
zi??T`Dxyxdn$K)|G-IefSN?%Q%FyE?sp3a_+tHA>5}6lKu_WNJ&)-O^rLS}Ze+UKC
zR587G)X&nz5&zh&#wXoyxBupLEt(0viQXVDl=+hNZ?suRE5UM_Ic2}brLxoW#RPS{&0Rge+MqHXQy
zq{MrChfUON8e!}8vWVtuCjL5E8lih$IOl*bbj}%<+xvokkAn><)g#SK?7cNZ9rHwo
zTaB=h5M!70RbWiF)$m+_skpvooSPEXCX>S(y!P0WxbKV6-X=)`IJ~T~Ua`fG5$m3*
zXBMkb4>M$U58P#Zgr%8oi@&cyFb?3(Fyt;S#(&Vo8e%W9Y-G#Wj13?=P*Xav;9^W^
z=`G&{x?yH}!6Jz47Edp{sa7a932W$4^5OiuK6B$a<%RP&4uURwZKBBH*_W^NQMLh;
zwsW#>p&dcE72t@Kf&k6LkxK&V+Prb6=w)5zH$L9Lt?vrgt2xwpVf%b6!AvAg4%-x=F5US3NvB-aSQbArm{Wk)$Ic88f&X_
z%^6qEcM0O}=W{>wJ=!8h;8mws$g&w{KMCjK)+tGV7dCMTBO!v~^K6BU9@|zf7qx@e
zM|u3OHrFVxOY>?zhjC6Y34z~ze|O_!XTTxwp+L36+30}DxOr%?h76Lsx=8LmW0$)c
z&a|_0>SnkHZa_e{R^I7!2I#rv)!*T$(DX&951z@SWn*303kgHq{Ur?ph(L>lo
z$dX!2*cN-`-6<2LuY;5x=`N3h-(%A}mG@iA<$57yAIEmIWe&>FsIu)%=+{I{V_EqY
zJ2xt&A}A04dL-*$vG*GUnmERj6x2+gH-Uj;-}C$e)E&!J9p7w8XOpQ@*ftiOM+u#N
zT?|wE#zat_?RJH}m+Dv*Ib^&0(@sK8B0br(4fhQ%9A-)+TNO-KzADaE&zP%sX#$cz
zNq3%hkYKJgu%`lUQ3pd@n7Mwyuj86N0KjVb~VKpSX&azj075L&8h`)1G2EW4e7@H);j4o*sXR&UjT1xQ6X
z)OE7my}pdi)_u9rlkBTJZCq%Li@UUIxX;!C$|#
zr!Xi)a?Z^7QBcc|y3y~5raE@yN0)uq!PnR;ByC8P3!Djkgu@K}lXVAU+DIAc1qpW<
zS{4RCV$Uc_F;};O08g0oK6x|maCd*bHOF}GA!V~NpUX3xsEM>_K0K%LA@RDX9F4>-
zMsYzI-rgnzJ_=QOcHGpk^#$BYO9h&{YvOnG*zhjE)ss5Ndkr5&UD?;U0VgzUQn&oTL_
zjx=u+KSQgAxK5w&-COGNvLH}olPWwQ2PtZdTvyYCYOV{1wqTXBBAWVI=TW(@35H%_
zR!o+zSqFY%GH>5(97LITSH^Q>R(DB^d;LAj;Gc#P?wy0AnhayJxVvbs3zz$&{NgG!
zlGes*O7QBLpK^F27PXwQ#{oY0>HZ%0*?YLldKHM#0abYPrdV>b3?MqmPQS46)ai7GUQ>B2|{r*-S;Sb=5f
zZoF@5{ey=5=of=EM9-TqyuhCE*MhQBQCV2Kj8ol3K)c22G5dXFYOsk^Rk)D2i3mKF4N|(Zpvs3V+>D_tHV9
zIp&T6cY-4HL6>bWW~%^yhYJnnD!T~K3{}$X$MqaA!c{5s(gr8fOyj<{OH}+Kg8_Yp
zaquQKzmkaEqapKIWJxCXKSiFh-tDrz<}+r~!ND9j(TdkaxGFdZX@L}S@WPe%>VG$6
zu{6f)35j!^2TweBfdmsAhxbYe9;croPqRZIu|p?YSSBB^#rVk~`l?DQOW(|>84P#U$}zx=862D@aN7qoDqezHbf6aH%(>I1@@8C}-dtF4U~Tk@+5&oHJ-Xu$;|ty2D6**73S7)8q)hj&
zgQpu!|Ay=Q=VU%mpC0LeRdy;90fJ(K-g{Z0%PczB{bnW#T%KNd@T@~3?f9fy=f{s;
zAW5u#AaZlhv8#RtZXc>A;Y23tb3SM(eB_^kIOM}YlJz@~5iV0ReoB@j~D+E
zy?w?^Qyjv*J!!dd#J_q*n8nBCu`Cj;H|usCeiMwndL{+n+6;%pgSEco
z%QjCh?2lg?!%||ErO}yluqFui+f>T=BYy`R&4%wEqyy%5V!2n73L|cR!z*gnFx}}P
z>(+f6H8Q`D<&do2K_oUGZAJCm6B{<)s;?p+8SbzXx!=x?qAc@5nAJtB6dSP0
zW>pQ&1zIt6=kwT~1Hxqx;gp#+P0#Nj3O6=(*u1p_6UQ*Oxy%7Owe&B#*wT
ztbRPMFEK9_Ejr8-hsT#SeB|j7Q8vks
zy*06TFHhg|*db!bXMv
za~8mc2h
zrsF1h%^C^jwhrn!;m8xnpDsg`^jt&eh_V<@HHcp8%;jS-rHY}M%lLWFmHJda`j+T2
z2c`;P+tB2bNmxQ9EJXy6X817vlv*nF>BSi@)~mhQ)6=G>RZQmpt#sW)NR!Bnh-85F
z^}Xw}_SD12ZG6&$nQ+!mH^dHJ)Stuhf_p~rQH!;h)dtW*_zHeX$#G;AA(7Gw`?ph`
z_c)}~Y`F@CmLDwr$WWjXul&6p>iZmgVuAWhLZhH-;lT9eWP7UJ)CFci?Yv{8@trp~JyLIJi#2JMpWDX@0zrd57|B>}
z`1d{25B)jic%JhQ0ubd!8;^E;{|XvX+1~3b_9#vAOk+_tMRQo-XjIZobELuNU(CtW
zGf?aniXA+nx7`+7sjqvAl
zXIyzhXL_xa3>vT^G{C1K;FO^EOt)D~S^d_dI4fX?DGL0o!&=jMHUgyIS7a))_3nUG
zf0>~c{>>qC(fAZL)p#yX$A^&D0%lvE!^Oa74n+I1BLs){JA6G_kD0W(y{d^9e>_ck
zpR@Y-Pnb_l_wC-+<89Z~+VbU9q`8DwU#K{O#Alp=N;SNh!^PoQ+@1uyG+d*wg{yyK
zJz8>nYo9
z2{A_}B@KNNa>u5k!YY~Z7P;~irm(QI6iOg@=|~I-w$?ZDTC`qhb)y3p>iU)bQH3BG
z3J^mwo#~Mey+r!MuG(oO<8i@diG1NtUiXe-H-=RrI$7D1)0acMEo;848k(AL5Lzn7
zY9(c584HWTQGT0X8}%bn0cUb>I5O<+xQ7bjde}7YOF-q?aMY*jz(gx!(T~xv+dI;r
z=4*rz@(e){9fhW|v9fR@nT6V`F}J%z{C9#XGN*#1qT+K64Gk{8OGio@kr;F0axE5!
zgs*S=>pbC4nZ4B}U8LaiCI++k9bB(Z%mqdNS^NsGH@_T`tzG}uQhZF^LIUNd@m4Y#
zj$d`})?O5X{oAFw+0DSA!4NAO8(MB|oJO1RO=cE}qG^c=Eh%ut)KTYeSthTo#m-o!
zUfWv+0|SGTQO+K4-Y9cCUR{GAY5KjHbPOB~{YI0};c$yb;b@#NqP@L+>t1D5r?8Dr
zX@PVUJVc9yz>0^2)7^K!G}~F~^=qtR4d%ed8{4Fv7hgR4;0f_2HJ{n%WU?ql^1vn@
zy6+}z+HkI3R{&MHb$=f^B@T#4cS|W<(ukCFw}5nacM1rXZd5|LyHi@aQ$o5A{cYZF{xkQ^
z+!?RWd1CLi)-TrDTNQ9S^Op9*wx{g;P)r66ieS{T-z!m?@%UN@2a)wbmkrkeQu&>S
z^{ZGRUCsIK=ppdvA$iA)qB#k&KioGW=pm3Of;VD%dZY!XBMQW>S^^v&h|r2&5!1pM
zKJ{XIaAm>Br|W2f5o=_zy~uldde)lu%YuMo&D{pv%G{i0GzlN4#kaufhr89MJ}{Ai
zH}+S}b>85YeYe&$&riXE&rc@o;C*4&c~;Th+7UD}7#|;>!ed7UzNetR25T}kH8lcw
zb;5joyKG=#C+j*!NSl1LG2Cr>BkOQMtY^||N5<&J(*kAm!Jes>R{66yMXKbUB$|U
z&QgMBmb939A0Cb>c)Ob)9vywbfLy5=z1|%r&YCPvg_ik7)3K2xR`3k9FP41F<6uYV
zjgQ}o8Aond_Y+-z-)IOUchq^Bgk~Zkj+pmPJ`>J@JFBs|Lw)17`9UW0o6KbmU7M?C
zm!3j@CMSgym;yVU#)NiGH4`QSY`;bjp(*_Tzeg3TBi+@da$LTc;rb4%;`Gp4;T7AN
zgr_GzCnsmlm@%M)&ubE<
zYWJPY=7Wh(Q{U%gy}mu)c$wguns+O=bT}IQeR^-4QF}0Qoyfw16OEch0*k9FkDWe`
zl8?X4WHprNQBe;e_?bc(UdD#YpD5fNhK-#{gp}2E`|sB$Rn_2y1?`ocvat>Qw*iP)
zvY6qk5gAx(Qh*E_dH$!oiFjSxryOfXYlrlXLQgE%e8GMfga
zzze=1$|$8m5#2w5Hvg|9-|;!WSekWQrYYF9E
zDM-iTNAi#lV-F9Ur|o5h_`5_OJ9&kUzwN#W5eq0`VQO$%I9c!hq^8!ppV6Bv{CnTK
z=Lx(BVd}T_)Rmqn5Q;``1PLtLoj=PQ#&?Un9M1e{D)e0?mo12_r>$um8dNtYX5pDa
zfxS4y#QO=W--4!>-Bx3`tY%KQ4RkgL=MuAcN~r<@pa>gyCfsacQ)W^UcMjQQ)YZB!ViH&xaDdkfe(c}>g-Piq;pb}M9{np%2yqlb5AM)UrCr6W
z_h0fSI(UvOFRY7?(MHn
z8|M^h$s{dyi6t>helq0Q{`7FHCmba~_5J5hW6*y$*W|*SmY&WxlH7RwF>$mZb_^#1
zTU8+gJ4_QeyljM1MYy=8>CZ!}&x-2v-^A;W1vANF4)`bP$rDy?3dvZv{ZcNNu&A(K
zFPF}kvb^-ajv*5w0^O$eyg;jWE?PX7=1KA-r9KrZPz|8QD+}qF37SiTU)hXs`IKv$H_Ty~UW3_&{v=y@r3nrIB
zCFWlhyRfN0Aq@PVpcPp1dhb7o66W;yH;i+u8BSf*d!(~*bJrc;!&*GfM?DNc=Rx}m
z)8QZ-%VFg<=CtRlUY-bZ$SJsylF^N)0u=Q46YS7Hxql2DXhK45zw+GciZgC@Bcjh2J!x8AitPL5Em!#B*qw&JD1%85x#4A}oJK!T;~by!O_HukDO
zQ}zSgX>-KWJ+bSOXSvQboq=$aK6RYGRI@=BWYhWmXUhwV68-Z2Zfp_EOog!F;bC6`
z5r+*#FqQ^^ig7nuLAvu8X7?x&F7UJMoatS66-Cs{3z&=il@iTx3(jkvN8gTeJSf9%
zgealRo4eOvP-gAPl0hQZv28>GI|YG&skpqn->SSd^pCR9BC*@vpYbeqXf3rF1`!IH
zopA_>$3E#46=dG41E3=I)iuy$6D31j3>
zgo7b|!eSSicEMyX6YK)C(itpBf-`;+3lKF`=7(Sf;lzG2#@Xn5+L)i{ktXv%-0Y7f
zukc*Yj}?vtN!yD!ZT3p{68?bmWrp!JIuouK>T42OWJ+t9b*4g{SVywt`1k-cJi3eK
zmFejao)!0QwhsYXq$mZZYe!M?uT_+?eJaOHD1zhcB_c$_m0h_h|7iAm=-S${60qqn
z9eaZE`gu7XEHx&?p6C*8hUM!dY&n+N!hTc~BCqsFf(_~hHs~kZ!+u3qg)Ixvr>(?*
z|4_!JRfUKg6c9UpOVYH41);})UP|?x@bjQyFV@>hOG!x?c-e`CU+*?EA`W`W4_xJ#
zbpi+#m!7_Od`lfG82DTE=tJN8v_A!FyD%#VL_H)enePLvxTt7-$t3~D(KnGWm_kzH
zZ4bAt4;p9`udtY)O13hqeqG*nTRi(AKrJ^!oGENQvfYad8x7lQyDfZhRfy7=&}e-<
zjGTZU5$X?aT6B}Ut;=J0YcSzXZ?VpX*!6hjP>sdRhVys9Qs7Zx05ctQqx9kK8XNXK
z3TNXrD0YvUkA;V`4z)=NOG`)gk!4j#9Pjr4zJtjt%(5Tz|H%VvwPnQiD
z#6FUyf~jWCZ?K#F*Vyv6)VT9XrYRqK^`+^F3Am`rgkWb(up+PvD
zrmM+uZuN~mewLO@pwmXT?7#p1>olu&Fv!5ob)EV<_x2ho#W>WFTrvC==xaZj)-dQa
z4o5oA|B3}eEDCX=j589^2IB*mJ|4ya)U9CrQ9z|
z`iF6AQeYj&X*N+-x;Fbff$E0-kQB!sLgKt7{%t5txLifK*``u1v>z4VPbfRR;
zI7j{{{M`sw%J|UC4(&?*7cuK_+kD7b*F*$3ih;pFw4okDFl5LbJnF<`cPaY6RIsc9
zf7ERoh3V7c#Paqk%c6%HBGf-SI(s1?#>Q$iAQ4q}@K6Bx!<#24Uez8_T_yK!k%AXR%y^Y}SgvIDxVH{D7q
z;JTJ(Rd#Bj;hSUi9(nuuAmMjv
zVvsSr*Sav+wkY|H1h1Ez*a-9`bL0g_By
z)NbLq`$4hVuL`?W;re4cg|U3}FbR8wN_@%c?4Dg4JJFfR^=VzKFa+?=`SwWnc&>OQ
zh;}rzw4y(hPx0UQSz1|5fY{zo?w2v^p~Y@7kQM-b=C6xBv;_n?$Nc&>5LAL;dTy%d
zOmt6Z^GM8;$F_ezkAl1-cs4+t^41*dnFMk>($(L-R5vl9zB-r>I&Qne8W|aB88hH9
zCiwcbIqllx!%1EbMf7k6AKw4Cf!aapPa+4#S=3ZLPNb*QO2U7+qvxwgsKQW4MaPT|
z7iu92>Ifr4L)|};^?xre>9$<2cv;xkNb2Z3&*t!{>We>}&9Q~CWDm;+zIrYlgoH>f
zYZvk>OEhKs@jtvzsam-F)HLwrdXOJ1RPg#WD~*vLYas8P4f2~WHagL-_}t+;vp9HUQ9`ML_ho>scq~Fim!i3y-G(oa=mdcdWmKwJRoEmK!Cn2
z8v~TrcqNE2pwj$zcfXx(cT3Y(T}u}u-kYd{+#ZjkWc+@~Ik7kgmyK4#T0%m)bf`9E
zGoXz`$cHs
zT5G`yy^zN6V6M`A4Q>`$UgQx*-S%*$6T7_#b}V2%{K3fED^fRWOUpBU1>v5lSNW}d
z{@XPl03r&60H}&HN~2yq#0-HDwjRn$5bh&Ih6{j7yP<(M*{XikSHQOY!L@w5^`L6#
z_R)KHoRURr!>7CQ=6nYmR=fe?r^_$LqJbHV%GTL^UKw|QJ#aV~_mO}l?b0>=s}BArr$)MC+YnfZ22w6y+p;=9Co=fbasHBkKBQFGsu0_P)uJjb
z1dzw6HcEDc-;1*lh%^0nhopLL|2>NF5XnIh=nxN4rM@M`8mKyf~SadSvh{x?y;)hvC}zI_YAi|#J_0N-~~
zU4+W+e~xc%#ytb_PFo8L8Md~!uYA6ODj0UUi4@InLaSygX>ui(GX0D_;X#Sk^Cn_?
zk&y$HVw3v~l9SZl+Q1c2@>nh%=##HDA3M5ZNgl!lEX9>OpadKcIK;YMfK?r7L>MkX
zmCf~qGK+W@<=(E%+t6P?JWPh>-<^}GDGizTiRj8s^3WbGKjjf98KU34d)HyjE&fB<
z=wf%G;k1vqDE^zjX{!`NOw2=>`KyxPyk<#%@OJ1DC>a@xj;pmx`?zLxH>)p!8Gzlm
z2Q_;{QKm2#T&P5+9t$9dBIzfYNSoI2*&}hQ--zTA1h=L_QZ%Y|ZjA)<`iu3V?1_5L
z6Oydi0MY1Pp}-<#e*~)kI@DN>`(Me1*eE`E)X^aS(WmVzfI=z!vY1Oh{uOq|`50XK
z5G;D;+KSK_N<2~$L^({#^EB!X4G&*fVTy-h21rl^s4|6!<(}*>1P8;*Vg_a~a(~>#
z>B^e3?M$?L)vRm6exe_sl&@TL0qh_9YO
zk!q8*oZQEc`}?|JoCnBkUBkq7E$fa4QNIfD!p6UG;&OY?#C}5h`n@~-_Tgu?)_u(T
z3E1lVkHCjzMG88)zQ6TPFqnJtzmQ;@)%+fc;br&D7+(7|$bswK8V>?^rQMYi?HH*&
zhG5)-uJAq)R%kEShOln($MNH5+Uudt*V|i=idyf944~I!dPFc87hDGs-{1-e)_#Ne
zm7p3~yT?9-#gtP#r9HXVWQp|55VF^tIMpBhr`ha7BEP2DGUq}btXy=le+zhsaf^38
z*}cXbhbR;@5Re|>51_VB9R^M#T(IqQ1M=8{pFi`8i+>-U8tY)IX41pw)f5jH?F*cX
zm`(nQ(`rKeD#L4BNeG}l>ugnZHHXyCN$10J_LA*00DJR;ruc<+H`?Kt(TYC{gxy@M_x5H}wzkzul?rr(F~
zPyo=c)jmwFMWbw!1eHkzQ>_Kb88MCOvHiYp(&tK$?7`54_Tz;Sp4H(Z^t=HhN#noV
zqR^n-TWHS|A&%1$1eaKtHq*q!#9=+;)s>Gr(|-fM9iJL30VVvE^t>cV%-XtS$QM{)
zP?i=UO)PHcZ^KTOmu}ey8fZD$2+zBB4K4-%i$kH%+fw;-cr-L@u>4TNB(Mrp;o?hY
zOYg8rc>SO244zf*w-5?uW(~O)C%p};P_8L31QwOMWr{Fje0pyoQYXi+wOr$y*V2$08
z`S3whP7YIByMgQEb>k*!qGIEVkv$Kxavxz_QWwIu{q7t&big&=kq&yD4bngFypuK2
z_P#E5OlN*lppN8%(XUP1lr-*2#yEYL$OvY`DFIVcst|eudQ)?ACk0H1;oQ;7IBkAV
z3qbWvR8xuKTdz$D)0&qW2NV%rDeK;cOa;N9i0z!Er_v2S0>kI9@Ny-K+SOY5fidDDsU|E;R9MzQv>Op
zNe9(t2e#pB4x*}?`PbR!=jS+!Z{pGyJyK)sCJPk%=PFI^gny|Piw<2DPg`cU{vsFh
ztQj)5q`+T5M@R3dDj7G5OY4zu|35DP4gkNXl}t4ijJ3A($dHrk_9s$u5KC9R>{|6>
z!FLKiKb3^w%)cSju0dBX*61&y$(;R$d12I43$b1`b@Yj{v_SQ^6PA{g^q5vOrf_g@kdc*jyn6(RCV9-f
zJ&z(7#{ftW5J=nIk-%`KK>hLgMsL*VjESHa-I%YF{W`+di6
z=Z))Joa$qgv{fdffB-R7JSrfh8aBTQ=(hE-V?y!pTJ^h0JzL2b85tjZcM<&M==OhU
z7b+L+)rlTVwCqpM%38LH?dNAq_;VHe
z5**fm#jijE{X`D8QCU~VeQ{yWcGkK32`J3<`+sn9Z3LE+NgNK$?}n2i7f2w3#8N01L)d!hQojvo5%A5r
zhEw0hfBUxKBB#snpRCLe;|D>>4
zXR{azqEIrqE4I)D4gl*XKzTfa>d4OXe@`q85-*lmu86|bGuW7k?}=hku)Y;0`Y
zPkUeKl|7xt`UT6;bpvSP9`(t3Uv#09D`O|o^&8+wt0K3auumYrrS25fnpd8o%{QC
z*y)=L&9h#L>>Ybtl#!7ES3bEdB8JKrvG60L0SFr&@5%}aP-0@rkU|0DnkN}m0YU|c
zJmB{>HFS%o|>A%gk8SUckle1KxF`;ox|m{hDm2264_X;DpNdQ{SFSS
zO+P!ZRY;&xu15o2)ZX--tMIi8(vAZdDF!%v#%L*%_VPhf&LyBm!WLH_Ljff%+!d_L
z+Fv`XzgT{Q{YpzqYhYmDy`!UJJ7-rgVsrKNBhGWx9t_r{l!o)|8V^=ZQxg$@m}CA1
zQIU~i`ub$gH)q$if4&xk?Z`yz{qy3&SuTY=KmjW*PF+cf!WoqY6U1Y>g>QX%o?R~X
zk)JdA(?-mmsYMH0Te6dV*&onf8s&X{kLTp3rl$5s|9}i(50Z*U}R-70&(`J<_wes1`f4|D5#KhotQb4T0dHM41gr->F2%tBkz-B7nDSG`N
zK$b_@Ddms{#qCF5Zc5GqwOG@7GM4WopQ^gLF*x4A;tQXjUNCcc3)F4ZhlkAP;u8Rx
z=NZ>Us!YS_JY)GnNT;W#G9N$YfABdGmzyK`05R(-NF>%!Q?=<{oGF^S(sDbhMc}8bK8oB3durQHE
zvgu(q4_C{3f~5%<*8aC+f#8E}o!kl)ZiXxDZ_$8Ebb;BjD6
zzq~z>hK7cAaqABoIo<3Z18qg**4)IGk`%tufJn3YNEFtc@Ptagd1DZCxL9uj-p@0&
zvrP8ZVM79hjZv!~1qIX`9P#J8VuE01aWDvmoioRWhrQRUer$8MG=iX*+g`wv%H54D
zXw5QTZgSDAvB32O8jsV;;}405VUiO{I5tjJz~iZg{3z1i-%Ie!cAWO!w5()ivFlSaPP?j|pAp_Uf!RC`}&P=qMqzdUWO%ABm!V>l*eP
zJ&Bs`UwXFP-g@d=HcLxOd)3ef#2ME5+_{QoDdWJ8;~_XE)qSsIXoDH$cJG1-Gyx#1
z0rs<}{6+ND@v5Q=Mz|pmj~|?+Y4cAa+q)T)0$$$yeChxL+LoFW|A!ZEX^<(kO4W14
zDM+TLraElv@0?$NqSL4wxkRsdreGiE89>ItrA|A{-Q4})<#uJwFkbg%4>K<4`SuMe
z2wMvh3lrrn{`IRHaGjfzT+fCVfRS&UUx*vOmw%6kF9`*DU|9|h7j3Y+^8M!f(Khi^g)tz&i11k#KIS%w7iB&HWkZ-7@$dnKu
z5U&?n{)w3retH3@ULcg0306*6e3veu*=+$v0A8S**qztb*LPdIJL4v&T*>S4cQ<{a
z#oipR5l|9v{Hh@t55%CNF+ntbk%tRBw(}G@x|WBlMFu9OjnBeju=hZLP61gs-(+WF
z9LX)`qRUG#Ex)poqeP$48)TWFx?;M3*m8P3HZZpaoK)01q#Jw^0_1ltm0_G3+8D{b
z3onmMH!yCuW%LzladEM?FF_WpAEbd6BENo8w>9826O)Boa5>J
z4|QGKuH5`{cZ?Ku5{p*g_O=kT;P}ZD!23y_2qC?uT}5jWM)SU43OMQesnlJv?i%c{Q1bMh9j1?m|Z|1)J2{t6sE5Ir+9<2#$oX7IJV{ZZRL9Q70nP(ZLw47QfF
zvzvMI?3WCHVHy*8@?Onuf4sGN&T<(%bWkXRMJya{;^bcNh#6pF2%;#VA?l+GfBtNo
z@o{sj=g5S!z2o7@Z*3*LyE^QSe90V)6@~+%^?StWm6fkRQfbx&IRxm6<9p8VlD*|X
zc?EmS*M8Ba9{3I@TTn|4hGb-(*+LhW+Hs>3v%Nn*0NaL2X`2r|VTpJc78+^b?25+@
zsV3N+-Jtrd2VV+aT~RT1oYKA5wm!eC42xx`NmqjbA6^n9?;!B^aL8`}^`-=r>*L$z
z<2L5^?}BkQ$evlJV4Oc;fLroj1M@RA>uocESAb2=eLaK_pa$^Y8ye2K@irFo=49SSaKtymak
z%G2X@`~RNYhj0dMB*10-(6zn!*P<8ZR9GEFmE)_0^D@c1o<>7j&e%YjT=|J<_@Y{!
zU3NqjeSP22@`tPX_TEHBm3zV$ln)d!+2;AEp4j^YlW(}V#FUH-9?wsxBTL@;Gi$iN;BKl+9^R0Yr2)jN8iTR@2Tcs_4L
zM)REff+kjMND{*+V(`Sm0m@HUF);V^23lO-EJVl234LYYU5TB4mJKRL0I1k@?we$2
z0_CI>=OH;jTl?|i63nlDuFinCj0P5cXKdxAn8wKq=a65Wyw*Y3yeQ>gnVI%w<8Swj
zQ>4bk_G^gOmHt#_*>f59dyUUtmY==CDp6-{1A@i*3N=Ag5&jupiFPeIATneW75iWC
zEWIz_MqQ8moLe>*nnL;%8{6v7jRv7_;j44EG!ZxLb*+(qK!`SBLt*}ThPwV9*bI!k
z6t1$8uUyedV(fv&08TrgaV8Wk1vwDZ(}jhF{_4MaK}A9BEE9}~)Egn&V|@dO>_gYz
zHqp8wMeAlCt7f@#v!ln;8VR4jHL#GK$#dz0cP>!eqL!kJjLPTa5%8h)ZlfIIDlQ*DFv{U@IHsP16ZK{xm%5r`pN&Z-uepU{G#nWWcO
zWzA~vi$9U5MxhxuGv7Smb0K=Q5^$nPi%q*iSn!v-Uj9lG^5Ujb%)*S{z4vkHpG#?I}mY+^!!6Gk`t6MS5U2L8+(=DRUX|18sg>f6{*
z9c&3#3_3q@!oRwJA^9nv9{Q23)p^{D7K#R(lgD9&4ST!09i{av|E?aul7(y6pd!R1
z=EekuQ|N^$3SgF3dxYpDjvq-DzPUj5x2&|2KF>cz_HMKvEjQOYbhwOhRpjOxt;SJ`
zuhcFcV)_s6G|t)>JE6S$oK9gS^mPTs;@P?;?&u^CdZ-mp(lr)>^3s)pQ}_utMgLn1plO|
z4sR-HNZ;Q3smJU%*d~-=f5`qHnh3dT1&f!BkjT`PSak?4mv=g6KHFL9}?(V
zvDZW(W!uzM1HZi`NEqLHjSAN6=p(4h?lj-LtFd^A{}XRKlb6Ps!N+VQEd+zLp`+9b
zoHGZ1RDW=G=E!2uwsbg)0?AQg0QJ8Qp_==AyPpWKQUX?;*_k027G3<4kV8iV90N9+
z^|ltXn}wBu0Y(B0ZniH;fZU`8DH|LbO8@K3Z-BIR*$nA362Dks%YCyLoP=R3wR5ru
zITSfrD73MoYFf`3H)?p+(ZKxnr8W@|!Jr@3rn)SEt_eO}Fc?(cX(t>sZ|!=wC&mk?
z>F}>#$u8QcrN4Gqyi+!QFZQh_pR95bI5a)kvL~-9SnljXjgr9bOj#!F@sOSZlmRX9
z1GvGtlXa}Ej@bT_Ck#!BBFN(rjw)yDjvUx~f3*^e>lHoQuB!iu0Ux+aHdU{9nV8T)
zp1d?tT}lDa5OB?6VYuoWo12~N!+bo}KoeT@{kr@8dBX|`wUA-ssa^)}D~YhYll_MB
zHhwyKSI9uD`51*=@T$U4>*{T&5g895CYNr%qwkH!#qK9_aq;ez=;-KcQmioa_pB{N
z8Sataf4xi#BBtQt%H^RXE{PuXZT@IlpYcy+O{*JIc<<5^)J$RkECLgSl$qJjMU&T|
z0s7_GDNg%<<#UIvhXF+{1dF!B+0CunvKH9IMOg^0KjQrP^9MNVkFOiR)bdDx4`4oe
z2455jLlj!?Re2v1Uzd(8-OQ|4q~em3
zc^3AZS&{5h>zy+DWM5hg-3dkGl?STG9b2Fz=v7o11W@?_U2kR*faGEd02hxjg
zGU_6XQt02leXH?Y_vt+aY!!>1&qr+d8|s$xSpxz&T1?1%X7(2tX7#wP96
z=Xwp8S{{32<=3@_?1m!v>YW3DJV2pf|BmF
z)BhF-gTdOgAHf#ca`x=d0S0!W7`mKqfk7w;`w}QOYUbwjgrTAmh|?mJqJf`tgyZ_Z&lfRmNa-ws+Gt}dmN
znEr!Pg8>}|84U9k7Z(p2&&A;Zn)e290n9Zz6)Z|t1H2c}h%g}_67bU+ufqVkk9flE
z-%gB)Y>T8OxE9OAX)P++X%0xS+pk6`{hCQWnEtcoxSwrmWwajzo8CH2a6YKd<-zaN
zD;f}A4?$!5^uU@0vS-y8@vZ6S&zFmm!kXPQltLHd;uVXB&v=%dD8|Cl5?~OqTXrns
zyelv$D~pYy>QsBqn%W=b1u{Z8Y2s+V-QT~M$U(0=L_q$$STB;5<2m85>xqXi{Q9z!
zcU`tdz70zuH8S=Kg1V{K3ki}aLm+I*WeGMOUj`J=KtHrA_X3t1&MD15YGy{grnc4y
z*rqNl_)!5K2QL5}6xQ^Ml;m&T56?V_T9Q=I#}^dC2^zB#st5I(p&gxgEzhf{rPvCZ
zJatOg?U-g@NxUozy&X3LS^srrJ}cJz)#xU7>u-!Jgd4xk&u~M75oTVUtU#sHk*IwejlsT=mNE
zw|v-T562!{_)2ZI@0VM=e!2S17V=b}{>xyw#iN>nYZ{4J#z0fE;qZ39d`tjPX*MiF
zZIF)rW82F4@CJjGVAm%_i>yjW>tMcn_`8OY)VC-qKjj?u^-I+k-NXQI7qZoO>i4j3
zunW?Eu6V$t;cq=N8|c@VMkw6_&K!PACNe=ZzYWxM8w;!{Ld&(4#tJ|@)z;R+r4ynJof2zx~&44-<*UFdV*y%m8potNnf(;IhPN
zphy?`5IdoVi^;imzxHt>_u!WipS%aV?PbIZRNV_$NymQ#8D(00NDUv(W5di5X{uZuy
zIByPsU(W{qWDcAhvXUS}!&c4W^^*KtO8vmU*bvzSphiQmda1cXh`6;7(b@d8ca^+DKTA{qiwnmk
zw~US1F0V5RSNgIoAw6n=1Xj8rRN2=r{6x%*Lv*X+)4T^y(br??;UsKID}m9S8W)x!
zVSVtSp}s59_QG&#s5zCDm8ETMkCUMK_0F&!-E#3$3w06Ga>Gfh8nKtyHH=Ysv2ga=
zq5n#3e)?dhl|K^;k6uASRdveWAX)YY043Oivq&9-V&GmS-LK}&KWS<*IP;Q$qc1j3
zwsh=GyNusVAfqd;lH?Hraa;}<+5S(_nWt_BLHiD)UWarhOSRx@o7Gji~xyQ*!-=%C|o7YI5khHji_J<+B~LP)mEW%
zlm+5q<4#sLz-OEJ;Vmj6_sSBP3}HWi$nGkI3uw|$eb&iYy?LVGa6931s+6I*9RiuW
z{)DfH4e?&#ZBXYp2s%dy>~QoLLhiAjb6J{Oo%r3S(^u
znoI!>H*(2y<_L*D<@U2T_uE4#5QuBU#@6W{3ZIbI3W+cN%IICvZ1A*O4n@pS*W!PZC7_}nK{(-rlv~|KTDOiL!(gUfJFn{j+~c8X^8o!~4!tim
zGS2r+`l3%w-raMi$^jY=9?}9_BNdt~@X}kYbz2U*YX6in-x};H1*&UkyaJgq{=dI2
zv)4|tGBO=+>X!n6!#L=C?u@Zs)UO4VDv8M&nd*ZE^M!zLXp=W__T&N_iyJS=*zsb0
zId#evKa#w$J-QV;VOu7j)Akssak1fH#E^2GQm`gv?jI#nCj0U~_Z`ynFnser1Fbr_
zfYt##-CV6z^7#5m7yes(V8gOd7z+|7^6x)Hoci%Ggu|D&hW__*Q+rVn8gQhZeKB4u
z{g-hwz@!P-{w>VtWpurD%U$&6D&;acn*4RB$M>9^j@I@LIJ!9~0;HqJQi)9=?cEn7
z|5uQuzWx?~O27M_u}7Qi1bc2Ur`PNy_2QDq?%4O`jaHwTJ8yRFV;gN=@
zsyN9x7B$}g8MIQ&a|ER}6F?#nV;>&gFyIAEDyW4u34yXnzF-oZ
z>shCI@0LjJn=d6D6Nq8JN-8?395LW}JsRWY>iW#uvkcv~d`c;ZG#3gzCDw=XM_16<
z2?x%Vl8b%X@z}qGBh*TIKoF(SNp1f>xuP^NMB8)dN=n%+Q2>yJx3eQxksxHM$&~58VMe
zm#m*t{djJ0$lsx4z)qm>XDaL}$@t@@$BZA};sb!;ZWA_Kb>Ibpte&dsmVSIH1r9W#
zlhGQ$Ncw!~Sp8BZ1~QZr21vQV(r=KA_tMQLglMqeOxgv>r?2^Z_Z^>`3kN28YOZOX
zJ6hrU6Y+bPXL0G&|9JtZr~S!sy4MC8e!)RXi}-fcko>x-bAfIcZR8~kik=lsRsLsc
z+PQU=e>YU9&nT?U{YBn&N#MXj_s&#$rov7T*v*~uF^7U;jKHozBIsU$(J=}1SlD|O
zf_B6;PvPyD!WE3^N-Af$2K2*(@}RdJJW;iEb$OMQ6Z8?Cpk*)`*vQX>?bzS;Vs^%#
zwyQH7Oqrv;l0*ISJEe<{!~LjnrvjYvLoT^R`b!MK#G0EH`LUxaoLAkwiquhBDElq>
zXTt4?z`($A-1ncOZ}1%>I=>VY%Z`8(;F|{k3PNCCS>$^iM#|sKqm*nTwvXf|u`>__
z5vg
zk4NO->H)ZrL2Vc(1Am@f4|F}TMeUH?g}6J(w}t}?mblf2eoCaw8%_(hp+=9i|H&E*
zj*abHPKf8A4Ih(`9WFP!4PDL}h!hnUTf%j-vq4Uprt^B10$?x7sf)MFYlZB~G%=
zP%WcTmp?Iv?-sgv4Ln@0#)6*ep)gU8f{*E#dJk~*+<152no5!Nn%;?;tR)oIW84ZE
zysv(u*MIUGsygV$3fmk6Cyi9h$-O*_fE%A(xoHL66yCrnlZ|`=afh|*`Q||f4Fp3*
z*C!`#(?vSTimv%*-hbv!uXNf`$n9PmW{l5wg|XDoM@tk4U;KU_hESjxnZLPhbfJEY
zf#KrnYJ7dPoWl7z5}W#5cVu^!^7Mp2rgS;5k7MeDktkH3!2;9UP?P>03O5D6A8k)-
zrnf?C*ys6nd;)?{sZ)F&B<~NV!ayV}?>1x?>|!4#ge++{WQKug`$wdSe8Q^@Vp4y`
zb?A?!V9>MoNbU>EUFAyp{7Gm3(axY_u!llKBzrRDy}e!Y`QghKSlJ&$5xUvyi7-RItS8|^jFJd5fE2A{%TDOq&pvDiccPpc2`J>&
z{kPx!yhW(6kJrw5qcKca>VMnr@JkKU#y;q|E%)v{zBh_QJ7i5;&lB>cv6LPq;K$TI
zOub{v6-TvHR>6bLvWT9|`h}JJB{Z1SCJgn+t*>{}1OP@FBFHul?djs=;5}4zDXs*&
zAF*SgKLY?>n)?fMK>Z?FQha+Z$~fXv}jM-Y=T8
zF=8&kLs$dZ@|ji0R50frsyg;B!2I+{BXVktfchx8o`U=Qo6|*6%00cpHTH$fv}JAH
zFXob`qXde{6fV+be%pRK;Jcq#eskb;f6kcg*gQ^&h&_XLnL8r$1oPd!^6fR(Sb{>5
zpD9`2RY9$?iI<1x8gPbB2o&7_v(Aw9SR23{?p=-U@lj5!
z+<0FN`{0gN|6`SVaIG{jS^MK3hKQng6)kvw(ha+qRP@1#xh8?~H6gik5wi5?m5v|Z
zBc_Sp-
    Yl6DY-7Wa7|jjmKhD~Ty$BKHyC<9pL43`%iep7TJKT>oVT0WK_JwblRo
z@gtfRalHzh`M*Cu@;o{pEYpC=k`fNlQ2K1Ogm--a0CFw*vp6pJlam{@?y51Igd4p2
zkmy+QH33FVu-$osI!`EQk#^|37ds&8IyzS6<>jm3D5&~CqZB~$x0Gd}LX=IY-_h<<
zR66JL2osk`^m$;pEPhgW@!y4~P~TUV!++-7>AC8^D3h_Fvr5un`)j
z4cYJWb8{(8(@1a7X_0M#kSp=b*zrU}L|DBJeT~wwZ|;Yw$w0)M!w19AOhpF_w8G#2
z4wYX{*+^3!JJ^}z1D#R7JWT&sJNN@Qi2gr9;JMiZs+p63FysM>Q1oNyI0CM_%3fwm
zwVwj5||%isXwy}>a)d&fT=$(>`zzmOTR3hCK?;U97b{_K$tB^p_D2B_1|9CwyXj&Pht?Uzfj)iUIxFo27zbCYY~VHw)E;?*
z{VjcwvhwlPH~D3RQ3C8quXw;VK-1sPKH@mVxY|Ct8x5&oG9oF7;Nk*x@lMLjR{Gft
zuhdEkn#q&P4_nWk5F^pS3tR6}yQaKyH)?P24sqbmd2}R=4_vxSKrz
z6S-UO?)rG=%_J)QMNfw~XbYLSy}gYAc0Fde@9>0!{Vi2>+7=&Y02T(EGzQMcF%LVh
zKZL-gA2K(>ISkx1((392HQJ>^mtfL`FDW4kFf#`I`J?RY+N9yCI%5_1TN69fg(@!}
z3y2Oqb@~!KB=%N<28ntj6^!pL_$hlVbc%7Nw;m@8fZ0PrTG|A7O!P~w-Vp(@{tw&W
zHdWIjCK#diE62t
z)cUKU!rsBh$7k)Z5R)pA(7mXwt*y1K%~uUvR2{+xs@Ts16$(J9$YESW43kCpC489C
zPnF9~TyQ4*RZ6^KnX=jDRMH{$mK_kv5Ev>yP&);QcyZe#3<;KRxB4|A)h+X`1h`HU|}D(-k0y9S!AcWTol`X=QHQLyw~;75B(Xz91S!<
z4noXyz|CU$dpT6uhtAS0ABG!T6Dg|;p-Gzb`d=sNo`uiu*VNRw3xx^LsK0&pM$K1i
z-2bhJ1`da1
z4E-_cDrai5#izL2!Ju$n?E!I9AN5FyymjQD^&6n)8?EAn;CLE$U8o-CYpYnI2%d*YTr)4RSU78Kla%#Ao)sf>ey5Ho0oaFlateP
z9Yq*(pX71HRoNXmvvq1O^U~haUN8~y=k|plP4W|b{NzLHXJGr4*3Ixr_a37K`pa|M
zONsh%QxRtg-okeGZcMbKn<^&>C#@&7Np3kthJp8w8QUHbHZhex{0b^tuG43Az4L|4
z{pqR_DH~k3iW6U`5xNA`#3d3E($K&CeT4d&&vAJ@9Vj3+dxFRDRgjar|7MiJ0?I9_
zte}>^gn3vcC=gA&synh{2Ol;*&H1F8D||Brp`ONg>1BV;968Q0$4WnQynyF{|H-7;=BN@Qd!
zJCeP3b-59;g^28NL)_oX=l8vTpL5SSujhO{UysN0*`%xma*%GGGy07Vdial^ANll<
z5K!$o2gzxB@aq~c=w=n9R2dx}9{x5wysZmV+YSl>hrPeMlSJrr6
z(nztElN)a%#zx1r7W|+ARQs!|H}9U)?I%87lebBgA+~`749t6#J?QK-E8XD1i}dMe
zB!Y=F&s67Er!Bg4bIckwrDdUC__oO_$Cj2&6U^r@FD>!>WL(*4R_l&8TNT|f7q^f~
zza_-SZUTGDKW?y@a$h=aZ<8n2-28b=v+e`wt(BlaZV8#Wy%Vyy$GD@@*)#(dZb_rR
z*pT}dzbU@Kzr@D7Hu_bi2?xJh`18WtC?^ndvhQ*_$GKo{TT>aF72w~f!&Uhr248Ku}k#WC_EgQwmDy=sL1g@cl8
zj&(0X9rn>>ytSlJ+;u@LT7b$lWb0SZc|{Vi5njvtI^8aRkD8|VMo^kdvVFf*641dPe+Rrx*Soyma^Xo6*^lYz
zFIFtIO!ybz?EI%HZxzEXMm$%?@p%MkWV^ZTcrhGL3W+t%8;l@4Jg$LrUX_ipfcf^w
zp_v;10KNJBcic!ifN*#>ZPcl3ePhdO1He4rsx%+H9a$=s=D(9_4TmnbW!MQ|%&z#j
ztXGsHyD=zX2p)2LWf6>3`zcM|WeET;jF;G*;#PP
zp`a~Y@v(%yQFnH1RZWE8dhPf##JQqRer^>m-g#=a_Ml7h0XRdas8`n{-Z~Pq$5w@^
z%q*%2$qV
zq4TBW%)PhWyfe(vLI7~~fSlxo3PAlswH%mN&aDs!!9YCmhn-EtBuAc;p+H;vD**e)
zLc_<&;MW`X(#%+kA6pFEg8YL!2_*cnYRsTOTvJz97p^aI0E?LYnsrJl_l8~~jTUeo
zkXYSP0T-5llh#NR@2yG0gzn+APKT<@3P~u!_xLk=bz1TDOT#Tk(kwIwB~sQX;X*sW
zZECC#8f&M*3rHhGsJVEy{s3anex>2a7x`Ju>LE<*&mDOMMMWk|pJUCBw|Csfl5EqD
z{yI#CiqO1ZcQdyX*zggY;LZE*)*V@@r2MO43Q`AmGPKz=nE0AnQCv|^VGBO&z>dSX
zxlW09nD9wp4z(X>9J6$}Llo-gjxI01T`!u%vry!FYkZm>=IfIa`)a|Es%lvYzoL1r8as2
z0jP9I{`Gc4t6?+jspGFM9|Tuk&2xdO9%)uviup7kL17JvEk@{dVXI}B2KsxfPCj*T
zzuzKwgqwF`=|`M2=07tstUl5ta{RYPl{k4Smm0Lo@b)PvU|N;zP5WzYJ*s>Hvt~4=
ze_buC5FO7%UmcFckXlmCo7#>qGjzcDVmsjf-MN#Rosv=mZ;wVS%?}zH8v|eKG?V(5
zs5z2VQhzvL{6x8sMe6ZgC2k^(MUfc|AhsJ7
z@5LMrA_I(1t|n(K-Wy_lS3VyR`E)9q=Z|ydXaxuHSzL|&u}~(gLV1h#$!9&wqpLim
z?GpTrU0_D4U);0q^RKw+HCbCqQkJ0g<3WMOh^%~;5gKbXU;zv*IWF4AI|U`nL3V{uG#RSb%i;qXFBp`>;>oj+mzm*
z89;URflt5`ff3uWV9k#^pbifD2U3#q=3lghD}zR@pG{DoVc+l
zC!6Hpp}8yKp-sD6*Mcs~Lh{UFBGM(!mV)~EV3(Ja28r(6(vweaxpa3|LU
zePhb|Q`c|*Loj36tvc5iA(fn%6{Iz@79)RQ#fzxSnH#*sRmQRHK{X_yxmc3m`v*Cz
zOd-mx8E~-PUy7s`ADk>$t%TUt8nZ*W2D>>@I(cJ}LCY^?#Mu&VvLz^Aq=^N*hk=Zo
z^mOXtkspg^R3Sy7WZHcO_iUr#%DL&jbaPGALGiO1IMcDI4WUQ%u5t>tT|Tb=3Y$9+
z{S!Q@3$I@4c&L0yZ_YupU5?wK>R;+g6^K=%Iqw@c0}ap4hTDgPoIC=J|HN%ZWb2U<
z@|;4q;Y^%&ql_i~F+)0)kkqQ@0^5Xw4GDz%MJBx4*8j>jtVcQLta;=Hov(+2jT|&_
ziQ%oo9?kvG<}8^yuJ(M1wDku1%W_q-!SDeMuw)i?cHRKXMZEcR)fe()JZg$d(mee`
z0mGzfldJoD@Q;0dvU#n);^+cPwGo(YknxKVAjcVeVA;o_242=yz8u`u;5(Ly##(nvj=3AVXF5-ubxBEo_C
zXr0E4|Bg(*|1o#KPdP(rJnA*7mVe7j^zDx!C34>QYoGkO5#%dks^gM%SO#@E5o_5*B(b#r-Lb%(Oq8D_
zXz{W0*A|2`o`-SIay4nle66`L#ZY?})JjqDG*d74AW9!EzqpQeuKLcYe&we0!sJJ$
zqpfDhLtDmWHvo*XKR!K6%FK0gebK49|GICnfqf=rbb{gD8@B*iBN1)=fxEo4Q`y>l
zFOpBUsf4F%Ie%-f%ioJe_-}zemD%zhja9)Sa&eO5J)21Qo
z=v+TA;>&Y}CgOOyN3vWq!!KB0ZzL_Ss&|TIm;K$rXj;D$G{LyJl;~xur#$-O$I%GL
zIbkkUI)-NKFr$pAjaFTegL{xbgSx=c%G>b6Q2*rYZdQ@*h!6g?yu_Kb=XX!8u7HW%
zdG^fsFc7iJK5--5Q#w_vu1QD)Ol}-DkxWxWlz(?TsTYCaGU8nieJXVLj$c0Odv069
z9mHCxny_ssBbb-Omf(z?+p2s(%lcDZgbvXLN--Swsx7lgw{KJ!e6YkLgKuPn+DE59
zSb4@8W&10ha`&cqe9~hu7Dew}Po(NR;kj>rUJg*pFpJBf7Zl>XDlK{nhGH9
zsZ~@nh;lD~zPm=yd)M?YoTyS~!iRg#Ldow48q=_e7IK^FonEd#^A?RA`}r9!xpB2y
zX2P8T>)wwTqk4mFJD{+fynHL=F&xj|B{}4EzCgIh(hqu7Ef2*
zpp}QQS`W3}Iv$eNVtoBHpYaWTn?*;JU++9Pqr^?fM-ZPO_!&1Qs`H=9Si&U0tub6Dx46jG(M@a}6UgyFI=I-9~3I#LMN9pMj2kNRoq?pBiZA3q3G}-oJ2Ex-b=UO=h!SeR2N{-a3>+XYyL{6`O4V7H?~YKA|n&
z-a692E1V3(Vj$oF1PvKBQMPhiF%6wf-Y(}ZW#%KXwle(;XWE0r@^@G%*kB2p`u*Ws
zh7l9N)Jzd8<>u>**F;5=AI8#1nSh1X^#JXOD}3btg+U1Hp%(xRH3x
z>qtMoB#6Antsf@){t8c?gt(1n@
z>uPdT7G*jR2hZJHU``VmmM+X(ym^XXmqGtSoA*T~3#C)PPty$XZE7$>dk->w=Zli;
zm&}B*z3bQ=oGxxGl>O+9Iq#kZ2!|KiF_2REdN7qs6+9ZaSgC^4moKfRCMVBW+XbKr
zE%CT`jJD5VIgF8Kh*g9V&GuW>ZrT05MH^0mfukLD!?3Aui@*c?ol}*rBX3;6?~&pa
zO@1sD^iL6@weX(mmL_)z=K?QKp@TPON%#5Q8XJ1%+YdH(j=b=RK@L$w-g97jZiR(~
z7lDTri+Hj$SRku-sfC!xMz|pv3Q4a1BZF*9)=lD03S-t5ib@e3DiN<
z1hD8t3rB09XZ7m$th!8YdvH(o8NS@XQFl&SW1`AS=cl`lomEKZtxCTi2ZA$&^>Qjc
zW^8E2(^OL=(z9l2V~)ayCqk@Z8dq~&9mIV!OI4CTyrm$|ap{r=_JSo@k}s!p#K%74
z%cH(=G}wM1QW2N6(RVIAPSx5Z(=>HExJ%X&jhsm%-s;mG=6>iAz9q-
zj7meH1q4ye=_1tb1QnaPoASc{(z=wu2Y~0meo*4ZTyB?!YU-uG?i46*9QbBM~6FFdsz$0_9)28S4lkBJ8
zz~AEw3Jy!C5T=T(C(DUR7w|)6=Iha*6&r{RF*poc
zp@@fCKAJ^htQh{{<0sEop3sYa8%Qf1wSm|uNJ+-1_0+Fi6QPUwOP4crb5i!J5Xp4+
zOWh0#aY2h*U%gufHk1~gYrN{e&LA2&;>~Z?$v#)N?&^s%kdvma
zZ53!^)y^i`4Ht}!gexxvG$o{(8I#q&x;9cf0Y=wXVqG;)d`=
zSUMs{xbPJyAEoh~z+zUJz)GzOR*r{IFey_-Y*?vIr(@>7px%0QmZf@BW&-o0cw@ou
z*OntAM+aKeyYBbhxN&16vqPQk(YpicE95DFr{p2baxBNBOvjsco}V4TaCQ+DH4|D2
zSH#4>J^jD*Y+e3-;pnxUz<-+{AH__l$LjC_@#4=>o&%U3Cq~i2Rx;cU?&2BQr3ay0
z)rp)H{oQI;KLmKG&MIDSpTu{jBQ?(>;KUbThVMZHgi+d668NDZCcHDqM*ZI633p}F
zLMdbsy^4wqZJ4N}&)9I!>n@(k5j=^2^VtImY)9V8Fl-($i73o&aLYIxF9Y?0cu*5B
z5IArXAD(^Fjlg56LEk^Od$~RUwUC&U7c$n9-&k>;m+`+8Tq#b3Qk39b9lK2wuMYK(g%Y
zgNr-U|(^U-vuU
z9J?U^12cPIZ9T~h=|dn8c-|h0pBLPNbH(i7M7cE%567_5r>_Oc79
zpbv)u4H+M$8i-sC8AYe;?eri8wHp4vjLgl?rzgCFf;ydN4d^1X+t+yc6v733R-9v5
zWUUmNQ~UXIc^@{-qyYsb5ndilbiSYO+l#EVGojoc33RdPB4P2gi%i6P^6RZ53;eSD
zP`L@Pk;iNp)zP3Ps)|-KKi?dELd}Ij7_#$(?1m?2lpot$uxF^yab1A#iiXGk$v7}c
zTzpRQuUGc#mc`w>)j+oD``N(eufQ;UDfIL45L=XQv)@#VmFw$Av`)BxGB}e5oK{<>
z6hT|9bo%v49&V6HZtAf&FT7-lj#WML7FcH;NubB+a70cTU{JdOuk?~iD9`Skv
zSI(}>SCPfOdDS(xEj9iSnujyZc(M1Q@L{{EFf1>SF27pC%;t5G!fcB6Lowc8U$lM3
zlwx{^`SQ)pAQ18pyXPKpDIZ*Zp!cp2>ZLn$GUC@l
z+?F!jTUc9j|DWK_gn;YPeP34gWp->VfGQ${m
z^3|f;Zd6By^MeOzB>W0!LYeC+Q#;(hZ5N+v)&}xD0-(2ZuJ^6O_$XfkJ)lzqX)bPm
ze?KJE>@n%8ZE4qtiJq64p7{RB>G#YAb#ynVe8M#*0JRjC(Bot*QrJ2OCt%IiaH_o9
zm+o_ZfNQ)0e^UTej@xK~5MrPZ{Rxz