From cce8232ee760e300e53c2ae942afd8d104f13f29 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Tue, 2 Jun 2026 13:29:29 -0400 Subject: [PATCH 01/20] Format code and add date parsing guard Apply code-style and whitespace cleanups across multiple R files: reflow long expressions, unify spacing, remove extra blank lines, and re-indent commented blocks. In readGedcom.R, improve the parse_dates branch by ensuring date columns are only parsed when present (avoids modifying non-existent columns) and clarify a message when date qualifiers are found. Minor signature and test whitespace tweaks and non-functional reformatting in data-raw/df_royal92.R and simulatePedigreeBetween.R. --- R/buildComponent.R | 3 - R/helpBuildComponent.R | 10 +- R/readGedcom.R | 56 +++---- R/simulatePedigreeBetween.R | 73 ++++---- data-raw/df_royal92.R | 250 +++++++++++++++------------- tests/testthat/test-tweakPedigree.R | 2 +- 6 files changed, 200 insertions(+), 194 deletions(-) diff --git a/R/buildComponent.R b/R/buildComponent.R index 2455d61c..e6ed8f18 100644 --- a/R/buildComponent.R +++ b/R/buildComponent.R @@ -817,6 +817,3 @@ ped2com <- function(ped, component, } list_of_adjacencies } - - - diff --git a/R/helpBuildComponent.R b/R/helpBuildComponent.R index e1db30cd..2cdf8406 100644 --- a/R/helpBuildComponent.R +++ b/R/helpBuildComponent.R @@ -3,11 +3,11 @@ #' @keywords internal initializeCheckpoint <- function(config = list( - verbose = FALSE, - saveable = FALSE, - resume = FALSE, - save_path = "checkpoint/" -)) { + verbose = FALSE, + saveable = FALSE, + resume = FALSE, + save_path = "checkpoint/" + )) { # Define checkpoint files # Ensure save path exists if (config$saveable == TRUE && !dir.exists(config$save_path)) { diff --git a/R/readGedcom.R b/R/readGedcom.R index 92614b54..a9976f76 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -512,8 +512,10 @@ processTag <- function(tag, vars, extractor = NULL, mode = "replace") { - count_name <- paste0("num_",# normalize leading underscores - tolower(gsub("^_", "", tag)), "_rows") + count_name <- paste0( + "num_", # normalize leading underscores + tolower(gsub("^_", "", tag)), "_rows" + ) matched <- FALSE if (!is.null(pattern_rows[[count_name]]) && pattern_rows[[count_name]] > 0 && @@ -564,30 +566,29 @@ postProcessGedcom <- function(df_temp, if (verbose == TRUE) message("Removing empty columns") df_temp <- df_temp[, colSums(is.na(df_temp)) < nrow(df_temp)] } - if(parse_dates == TRUE) { - - date_cols <- c("birth_date", "death_date") - if (verbose == TRUE) message("Parsing date columns: ", paste(date_cols[date_cols %in% colnames(df_temp)], collapse = ", ")) - # GEDCOM date qualifiers like "ABT", "BEF", "AFT" can be present in date strings. We can remove them before parsing. - date_qualifier_regex <- "\\b(?:[aA][bBfF][tT]|[bB][eE][tTfF])\\.?\\b\\s*" + if (parse_dates == TRUE) { + date_cols <- c("birth_date", "death_date") + if (verbose == TRUE) message("Parsing date columns: ", paste(date_cols[date_cols %in% colnames(df_temp)], collapse = ", ")) + # GEDCOM date qualifiers like "ABT", "BEF", "AFT" can be present in date strings. We can remove them before parsing. + date_qualifier_regex <- "\\b(?:[aA][bBfF][tT]|[bB][eE][tTfF])\\.?\\b\\s*" + + if (verbose == TRUE && any(sapply(df_temp[date_cols], function(col) any(grepl(date_qualifier_regex, col, perl = TRUE)))) + ) { + message("Found date qualifiers in date columns. They will be removed before parsing.") + } - if(verbose == TRUE && any(sapply(df_temp[date_cols], function(col) any(grepl(date_qualifier_regex, col, perl = TRUE)))) - ) { - message("Found date qualifiers in date columns. They will be removed before parsing.") + # only parse date columns that are present in the data frame + if (any(date_cols %in% colnames(df_temp))) { + df_temp[date_cols] <- lapply(df_temp[date_cols], function(x) { + if (is.character(x)) { + x <- stringr::str_replace_all(x, date_qualifier_regex, "") + as.Date(x, format = "%d %b %Y") + } else { + x + } + }) + } } - - # only parse date columns that are present in the data frame - if (any(date_cols %in% colnames(df_temp))) { - df_temp[date_cols] <- lapply(df_temp[date_cols], function(x) { - if (is.character(x)) { - x <- stringr::str_replace_all(x, date_qualifier_regex, "") - as.Date(x, format = "%d %b %Y") - } else { - x - } - }) -} -} if (skinny == TRUE) { if (verbose == TRUE) message("Slimming down the data frame") # Remove raw family relationship columns @@ -605,8 +606,7 @@ postProcessGedcom <- function(df_temp, #' @param datasource Character string indicating the data source ("gedcom" or "wiki"). #' @param person_id_col Character string indicating the column name for individual IDs (default "personID"). #' @return The updated data frame with parent IDs added. -processParents <- function(df_temp, datasource, person_id_col = "personID" - ) { +processParents <- function(df_temp, datasource, person_id_col = "personID") { if (datasource %in% c("gedcom", "ged")) { required_cols <- c("FAMC", "sex", "FAMS") } else if (datasource == "wiki") { @@ -638,8 +638,7 @@ processParents <- function(df_temp, datasource, person_id_col = "personID" #' @return A list mapping family IDs to parent information. mapFAMS2parents <- function(df_temp, mom_sex = "F", - dad_sex = "M" - ) { + dad_sex = "M") { if (!all(c("FAMS", "sex") %in% colnames(df_temp))) { warning("The data frame does not contain the necessary columns (FAMS, sex)") return(NULL) @@ -700,7 +699,6 @@ mapFAMC2parents <- function(df_temp, family_to_parents) { } - # --- Exported Aliases --- #' @rdname readGedcom #' @export diff --git a/R/simulatePedigreeBetween.R b/R/simulatePedigreeBetween.R index 7fdd0f29..397aa102 100644 --- a/R/simulatePedigreeBetween.R +++ b/R/simulatePedigreeBetween.R @@ -42,41 +42,41 @@ buildBtwnGenerations <- function(df_Fam, Ngen, sizeGens, verbose = FALSE, marR, stop("Invalid value for parameter 'beta'. Accepted values are TRUE, FALSE, 'optimized', 'base', 'original', or 'index'/'indexed'.") } -# if (use_optimized) { -# df_Fam <- buildBtwnGenerations_opt( -# df_Fam = df_Fam, -# Ngen = Ngen, -# sizeGens = sizeGens, -# verbose = verbose, -# marR = marR, -# sexR = sexR, -# kpc = kpc, -# rd_kpc = rd_kpc, - # personID = personID, - # momID = momID, - # dadID = dadID, -# code_male = code_male, - # code_female = code_female, - # beta = TRUE -# ) -# } else { - df_Fam <- buildBtwnGenerations_base( - df_Fam = df_Fam, - Ngen = Ngen, - sizeGens = sizeGens, - verbose = verbose, - marR = marR, - sexR = sexR, - kpc = kpc, - rd_kpc = rd_kpc, - personID = personID, - momID = momID, - dadID = dadID, - code_male = code_male, - code_female = code_female, - beta = FALSE - ) -# } + # if (use_optimized) { + # df_Fam <- buildBtwnGenerations_opt( + # df_Fam = df_Fam, + # Ngen = Ngen, + # sizeGens = sizeGens, + # verbose = verbose, + # marR = marR, + # sexR = sexR, + # kpc = kpc, + # rd_kpc = rd_kpc, + # personID = personID, + # momID = momID, + # dadID = dadID, + # code_male = code_male, + # code_female = code_female, + # beta = TRUE + # ) + # } else { + df_Fam <- buildBtwnGenerations_base( + df_Fam = df_Fam, + Ngen = Ngen, + sizeGens = sizeGens, + verbose = verbose, + marR = marR, + sexR = sexR, + kpc = kpc, + rd_kpc = rd_kpc, + personID = personID, + momID = momID, + dadID = dadID, + code_male = code_male, + code_female = code_female, + beta = FALSE + ) + # } df_Fam } @@ -459,5 +459,4 @@ buildBtwnGenerations_base <- function(df_Fam, df_Fam } -#buildBtwnGenerations_opt <- buildBtwnGenerations_base - +# buildBtwnGenerations_opt <- buildBtwnGenerations_base diff --git a/data-raw/df_royal92.R b/data-raw/df_royal92.R index 64ce6d2f..64be3000 100644 --- a/data-raw/df_royal92.R +++ b/data-raw/df_royal92.R @@ -25,12 +25,11 @@ strip_date_qualifier <- function(x) { } standardize_partial_date <- function(x, default_day = "15", - default_month = "JUN" - ) { + default_month = "JUN") { case_when( str_length(x) == 0 ~ NA_character_, - str_length(x) %in% c(3,4) ~ paste0(default_day," ",default_month," ", x), - str_length(x) %in% c(7,8) ~ paste0(default_day," ", x), + str_length(x) %in% c(3, 4) ~ paste0(default_day, " ", default_month, " ", x), + str_length(x) %in% c(7, 8) ~ paste0(default_day, " ", x), TRUE ~ x ) } @@ -94,7 +93,7 @@ royal92 <- df_raw <- readGedcom("data-raw/royal92.ged") %>% momID = 1295, dadID = 1294, overwrite = TRUE - ) %>% + ) %>% addPersonToPed( personID = 1582, name = "Sanchia of Provence", @@ -102,29 +101,29 @@ royal92 <- df_raw <- readGedcom("data-raw/royal92.ged") %>% momID = 1884, dadID = 1881, overwrite = TRUE - ) %>% + ) %>% addPersonToPed( personID = 1884, name = "Beatrice of Savoy", sex = "F", momID = NA_integer_, - dadID = NA_integer_, + dadID = NA_integer_, overwrite = TRUE - ) %>% + ) %>% addPersonToPed( personID = 2149, name = "Helen Louise Kirby", sex = "F", momID = 589, - dadID = 235, + dadID = 235, overwrite = TRUE - ) %>% + ) %>% addPersonToPed( personID = 1051, # overwriting duplicated Andreas, is already 911 name = "TODO", sex = "U", momID = NA_integer_, - dadID = NA_integer_, + dadID = NA_integer_, overwrite = TRUE ) %>% addPersonToPed( @@ -132,20 +131,19 @@ royal92 <- df_raw <- readGedcom("data-raw/royal92.ged") %>% name = "TODO", sex = "U", momID = NA_integer_, - dadID = NA_integer_, + dadID = NA_integer_, overwrite = TRUE - )%>% + ) %>% addPersonToPed( personID = 3009, # overwriting unnamed stillborn sibling of barbara cartland name = "TODO", sex = "U", momID = NA_integer_, - dadID = NA_integer_, + dadID = NA_integer_, overwrite = TRUE ) - #---- # Create overrides for dates and names based on historical records and data cleaning needs #---- @@ -163,27 +161,27 @@ date_overrides <- tribble( 34, "31 MAR 1900", "10 JUN 1974", # Henry William Frederick Windsor 38, "5 APR 1863", "24 SEP 1950", # Victoria Alberta of Hesse 40, "10 MAR 1845", "1 NOV 1894", # Alexander III Alexandrovich Romanov, - # Old Style = 26 FEB 1845, 20 OCT 1894 + # Old Style = 26 FEB 1845, 20 OCT 1894 41, "26 NOV 1847", "13 OCT 1928", # Dagmar (Marie) of Denmark 42, "6 JUL 1796", "2 MAR 1855", # Nicholas I Romanov, - # Old Style = 25 JUN 1796, 18 FEB 1855 + # Old Style = 25 JUN 1796, 18 FEB 1855 43, "13 JUL 1798", "1 NOV 1860", # Charlotte of Prussia 44, "29 APR 1818", "13 MAR 1881", # Alexander II Nicholoevich Romanov, - # Gregorian/New Style; Old Style = 17 APR 1818, 1 MAR 1881 + # Gregorian/New Style; Old Style = 17 APR 1818, 1 MAR 1881 45, "8 AUG 1824", "3 JUN 1880", # Marie of Hesse-Darmstadt 46, "15 NOV 1895", "17 JUL 1918", # Olga Nikolaevna Romanov, - # Old Style birth = 2 NOV 1895 + # Old Style birth = 2 NOV 1895 47, "10 JUN 1897", "17 JUL 1918", # Tatiana Nikolaevna Romanov, - # Old Style birth = 29 May 1897 + # Old Style birth = 29 May 1897 48, "26 JUN 1899", "17 JUL 1918", # Maria Nikolaevna Romanov, - # Old Style birth = 14 JUN 1899 + # Old Style birth = 14 JUN 1899 49, "18 JUN 1901", "17 JUL 1918", # Anastasia Nikolaevna Romanov, - # Old Style birth = 5 Jun 1901 - 51, "4 AUG 1900", "30 MAR 2002", #Elizabeth Angela Marguerite Bowes-Lyon + # Old Style birth = 5 Jun 1901 + 51, "4 AUG 1900", "30 MAR 2002", # Elizabeth Angela Marguerite Bowes-Lyon 52, "21 APR 1926", "8 SEP 2022", # Elizabeth II Alexandra Mary Windsor 53, "21 AUG 1930", "9 FEB 2002", # Margaret Rose Windsor 54, "7 APR 1930", "13 JAN 2017", # Antony Armstrong-Jones - 57, "10 JUN 1921", "9 APR 2021", #Philip Mountbatten + 57, "10 JUN 1921", "9 APR 2021", # Philip Mountbatten 65, "1 JUL 1961", "31 AUG 1997", # Diana Frances Spencer 66, "13 DEC 1906", "27 AUG 1968", # Marina of Greece, Gregorian/New Style; Old Style birth = 30 NOV 1906 68, "9 SEP 1882", "24 MAY 1947", # Henry George Charles Lascelles @@ -228,8 +226,8 @@ date_overrides <- tribble( 125, "17 MAY 1891", "26 FEB 1959", # Alexandra, 2nd Duchess of Fife 126, "29 MAY 1881", "8 OCT 1972", # Alexander Ramsay 127, "1295", "22 AUG 1358", # Isabella of France; birth year uncertain, - # sources vary ca. 1292/1295/1296; - # death date varies by one day, 22 AUG vs 23 AUG 1358 + # sources vary ca. 1292/1295/1296; + # death date varies by one day, 22 AUG vs 23 AUG 1358 128, "15 APR 1240", "1271", # Simon de Montfort the Younger 129, "19 JUL 1884", "6 MAR 1954", # Charles Edward, Duke of Saxe-Coburg and Gotha 132, "24 FEB 1774", "8 JUL 1850", # Adolphus, Duke of Cambridge @@ -246,29 +244,29 @@ date_overrides <- tribble( 147, "18 APR 1905", "24 APR 1981", # Margarita of Greece and Denmark 148, "30 MAY 1906", "16 OCT 1969", # Theodora of Greece and Denmark 149, "22 APR 1847", "17 FEB 1909", # Vladimir Alexandrovich Romanov, - # Gregorian/New Style; - # Old Style birth = 10 APR 1847 + # Gregorian/New Style; + # Old Style birth = 10 APR 1847 150, "14 JAN 1850", "27 NOV 1908", # Alexei Alexandrovich Romanov, - # Gregorian/New Style; - # Old Style = 2 JAN 1850, 14 NOV 1908 + # Gregorian/New Style; + # Old Style = 2 JAN 1850, 14 NOV 1908 151, "11 MAY 1857", "17 FEB 1905", # Serge Alexandrovich Romanov 152, "3 OCT 1860", "28 JAN 1919", # Paul Alexandrovich Romanov 153, "9 MAY 1871", "10 JUL 1899", # George Alexandrovich Romanov 154, "6 APR 1875", "20 APR 1960", # Xenia Alexandrovna Romanov, - # Gregorian/New Style; Old Style birth = 25 MAR 1875 + # Gregorian/New Style; Old Style birth = 25 MAR 1875 155, "4 DEC 1878", "13 JUN 1918", # Michael (Mischa) Alexandrovich Romanov, New Style 156, "13 JUN 1882", "24 NOV 1960", # Olga Alexandrovna Romanov, - # Gregorian/New Style; Old Style birth = 1 JUN 1882 + # Gregorian/New Style; Old Style birth = 1 JUN 1882 157, "14 MAY 1854", "6 SEP 1920", # Maria Pavlovna the Elder, - # Gregorian/New Style; Gregorian/New Style; Old Style birth = 2 MAY 1854 + # Gregorian/New Style; Gregorian/New Style; Old Style birth = 2 MAY 1854 158, "12 OCT 1876", "12 OCT 1938", # Kirill Vladimirovich Romanov, - # Gregorian/New Style; Old Style birth = 30 SEP 1876 + # Gregorian/New Style; Old Style birth = 30 SEP 1876 159, "24 NOV 1877", "9 NOV 1943", # Boris Vladimirovich Romanov, - # Gregorian/New Style + # Gregorian/New Style 160, "14 MAY 1879", "30 OCT 1956", # Andrei Vladimirovich Romanov, - # Gregorian/New Style; Old Style birth = 2 MAY 1879 + # Gregorian/New Style; Old Style birth = 2 MAY 1879 161, "31 AUG 1872", "6 DEC 1971", # Mathilde Kschessinska, - # Gregorian/New Style; Old Style birth = 19 AUG 1872 + # Gregorian/New Style; Old Style birth = 19 AUG 1872 162, "3 AUG 1770", "7 JUN 1840", # Frederick William III of Prussia 163, "30 AUG 1870", "24 SEP 1891", # Alexandra of Greece and Denmark 164, "18 SEP 1891", "5 MAR 1942", # Dmitri Pavlovich Romanov, Gregorian/New Style @@ -277,9 +275,9 @@ date_overrides <- tribble( 167, "23 MAR 1887", "27 SEP 1967", # Felix Yussoupov 169, "10 OCT 1931", "16 MAR 2003", # Ronald Ivor Ferguson 170, "9 JUN 1937", "19 SEP 1998", # Susan Mary Wright / Susan Barrantes - #Teackle Wallis Warfield + # Teackle Wallis Warfield 171, "8 FEB 1869", "15 NOV 1896", # Teackle Wallis Warfield - 172, "30 NOV 1869", "2 NOV 1929",# Alice Montague + 172, "30 NOV 1869", "2 NOV 1929", # Alice Montague 173, "17 APR 1882", "17 OCT 1893", # Violet Hyacinth Bowes-Lyon 174, "30 AUG 1883", "8 FEB 1961", # Mary Frances Bowes-Lyon / Lady Elphinstone 175, "22 SEP 1884", "25 MAY 1949", # Patrick Bowes-Lyon, 15th Earl of Strathmore and Kinghorne @@ -334,9 +332,9 @@ date_overrides <- tribble( 264, "24 AUG 1843", "2 SEP 1907", # George FitzGeorge 265, "30 JAN 1846", "17 DEC 1922", # Adolphus FitzGeorge 266, "12 JUN 1847", "30 OCT 1933", # Augustus FitzGeorge - 267, "9 MAR 1854","10 MAR 1927", # Rosa Baring - 268, "1892", "1960", #son 1 George William Frederick FitzGeorge - 269, "1886", "1976",# daught 1 Mabel Iris FitzGeorge + 267, "9 MAR 1854", "10 MAR 1927", # Rosa Baring + 268, "1892", "1960", # son 1 George William Frederick FitzGeorge + 269, "1886", "1976", # daught 1 Mabel Iris FitzGeorge 270, "1889", "1954", # daught 2 George Daphne FitzGeorge 271, "17 OCT 1819", "30 MAY 1904", # Frederick William, Grand Duke of Mecklenburg-Strelitz 272, "22 JUL 1848", "11 JUN 1914", # Adolphus Frederick V, Grand Duke of Mecklenburg-Strelitz @@ -349,7 +347,7 @@ date_overrides <- tribble( 284, "12 JUN 1897", "23 JUN 1987", # Mary Cambridge / Duchess of Beaufort 285, "23 OCT 1899", "22 DEC 1969", # Helena Cambridge 287, "24 APR 1907", "15 APR 1928", # Rupert Cambridge, Viscount Trematon; - # note conflict: RoyalFamilyTree gives 24 AUG 1907 + # note conflict: RoyalFamilyTree gives 24 AUG 1907 289, "23 JAN 1906", "29 MAY 1994", # May Cambridge 291, "21 AUG 1924", "27 FEB 1998", # Gerald David Lascelles 292, "18 OCT 1926", "6 MAR 2014", # Marion Stein / Countess of Harewood @@ -382,7 +380,7 @@ date_overrides <- tribble( 350, "21 SEP 1788", "27 JAN 1836", # Wilhelmina of Baden 351, "26 OCT 1775", "29 NOV 1830", # John Maurice von Hauke 352, "1790", "27 AUG 1831", # Sophie la Fontaine; - # approximate birth year + # approximate birth year 353, "21 SEP 1827", "25 JAN 1892", # Constantine Nikolaievitch of Russia, Gregorian/New Style; Old Style = 9 SEP 1827, 13 JAN 1892 354, "8 JUL 1830", "6 JUL 1911", # Elizabeth Alexandra of Saxe-Altenburg / Alexandra Iosifovna 355, "27 AUG 1789", "25 NOV 1868", # Joseph of Saxe-Altenburg @@ -479,9 +477,9 @@ date_overrides <- tribble( 489, "18 APR 1865", "20 JUL 1951", # Johanna Loisinger 490, "18 AUG 1874", "22 APR 1971", # Anna of Montenegro 491, "30 AUG 1842", "10 JUL 1849", # Alexandra Alexandrovna Romanov, - # Gregorian/New Style; Old Style = 18 AUG 1842, 28 JUN 1849 + # Gregorian/New Style; Old Style = 18 AUG 1842, 28 JUN 1849 492, "20 SEP 1843", "24 APR 1865", # Nicholas Alexandrovich Romanov, - # Gregorian/New Style; Old Style = 8 SEP 1843, 12 APR 1865 + # Gregorian/New Style; Old Style = 8 SEP 1843, 12 APR 1865 493, "9 JUN 1806", "13 JUN 1877", # Louis III of Hesse 494, "28 NOV 1901", "21 FEB 1960", # Edwina Ashley / Countess Mountbatten of Burma 495, "30 AUG 1813", "25 MAY 1862", # Mathilde of Bavaria @@ -545,7 +543,7 @@ date_overrides <- tribble( 584, "23 JAN 1896", "9 JUL 1985", # Charlotte of Luxembourg 586, "5 JAN 1921", "23 APR 2019", # Jean of Luxembourg 589, "6 OCT 1914", "23 MAY 2010", # Leonide Bagration-Moukhransky, - # Gregorian/New Style; Old Style birth = 23 SEP 1914 + # Gregorian/New Style; Old Style birth = 23 SEP 1914 590, "24 APR 1608", "2 FEB 1660", # Gaston, Duke of Orléans 591, "23 JUN 1908", "20 MAR 1975", # James / Jaime, Duke of Segovia 592, "30 JUL 1936", "8 JAN 2020", # Dona Maria of Bourbon / Infanta Pilar of Spain @@ -575,7 +573,7 @@ date_overrides <- tribble( 631, "13 NOV 1848", "26 JUN 1922", # Albert I of Monaco 632, "12 JUL 1870", "9 MAY 1949", # Louis II of Monaco 634, "30 SEP 1898", "16 NOV 1977", # Charlotte, Duchess of Valentinois; - # some sources give 15 NOV 1977 + # some sources give 15 NOV 1977 635, "24 OCT 1895", "10 NOV 1964", # Pierre de Polignac 636, "31 MAY 1923", "6 APR 2005", # Rainier III of Monaco 638, "27 JAN 1805", "28 MAY 1872", # Sophie of Bavaria @@ -601,7 +599,7 @@ date_overrides <- tribble( 679, "30 OCT 1797", "29 DEC 1829", # Henrietta of Nassau-Weilburg 680, "29 JUL 1818", "20 NOV 1874", # Karl Ferdinand of Austria 682, "21 JUL 1858", "6 FEB 1929", # Maria Cristina of Austria; - # some sources give 9 FEB 1929 + # some sources give 9 FEB 1929 683, "28 NOV 1857", "25 NOV 1885", # Alfonso XII 684, "9 MAR 1776", "13 JAN 1847", # Archduke Joseph of Austria, Palatine of Hungary 685, "17 JAN 1831", "14 FEB 1903", # Elisabeth Franziska of Austria @@ -613,7 +611,7 @@ date_overrides <- tribble( 729, "24 DEC 1598", "1600", # Margaret Stuart; approximate death year 735, "26 AUG 1596", "29 NOV 1632", # Frederick V of the Palatinate 736, "14 OCT 1630", "8 JUN 1714", # Sophia of Hanover; - # sources vary 13/14 OCT 1630 + # sources vary 13/14 OCT 1630 741, "26 APR 1575", "3 JUL 1642", # Marie de Medici; birth year varies in sources, selected 1575 750, "27 MAY 1626", "6 NOV 1650", # William II of Orange 751, "21 SEP 1640", "9 JUN 1701", # Philippe I, Duke of Orléans @@ -629,7 +627,7 @@ date_overrides <- tribble( 765, "22 DEC 1617", "28 AUG 1680", # Charles I Louis, Elector Palatine 766, "17 DEC 1619", "29 NOV 1682", # Rupert of the Rhine / Duke of Cumberland 767, "16 JAN 1621", "1652", # Maurice of the Palatinate; - # death year approximate, lost at sea + # death year approximate, lost at sea 768, "5 OCT 1625", "10 MAR 1663", # Edward, Count Palatine of Simmern 769, "20 NOV 1627", "16 MAR 1686", # Charlotte of Hesse-Kassel 770, "7 SEP 1674", "14 AUG 1728", # Ernest Augustus, Duke of York and Albany @@ -1041,7 +1039,7 @@ date_overrides <- tribble( 1369, "1214", "1 DEC 1241", # Isabella of England 1370, "1215", "13 APR 1275", # Eleanor of England 1372, "1122", "1 APR 1204", # Eleanor of Aquitaine - 1373, "17 AUG 1153", "1156", #William IX, count of Poitiers + 1373, "17 AUG 1153", "1156", # William IX, count of Poitiers 1375, "1156", "28 JUN 1189", # Matilda (Maud), Duchess of Saxony 1376, "8 SEP 1157", "6 APR 1199", # Richard I Coeur de Lion 1379, "OCT 1165", "4 SEP 1199", # Joan Plantagenet @@ -1446,7 +1444,7 @@ date_overrides <- tribble( 1960, "1282", "7 JUN 1337", # Gwenllian ferch Llywelyn 1961, "1223", "11 DEC 1282", # Llywelyn ap Gruffudd 1964, "849", "26 OCT 899", # Alfred the Great; - # birth year sometimes given 847-849, selected 849 + # birth year sometimes given 847-849, selected 849 1965, "852", "5 DEC 902", # Ealhswith of Mercia 1966, "795", "13 JAN 858", # Æthelwulf of Wessex 1968, "825", "852", # Æthelstan of Kent @@ -1484,7 +1482,7 @@ date_overrides <- tribble( 2050, "672", "718", # Ingild of Wessex 2051, "670", "31 AUG 725", # Cuthburh of Wimborne 2053, "630", "14 DEC 705", # Aldfrith of Northumbria - #; death year varies 704/705, selected 705 + # ; death year varies 704/705, selected 705 2054, "758", "784", # Ealhmund of Kent and death year 2057, "1307", "26 SEP 1345", # William II of Hainault 2058, "1314", "26 DEC 1360", # Thomas Holland, 1st Earl of Kent @@ -1561,7 +1559,7 @@ date_overrides <- tribble( 2146, "29 MAY 1773", "29 NOV 1844", # Sophia of Gloucester; identity inferred from Gloucester/Walpole context 2147, "23 FEB 1708", "5 JUN 1752", # Charles Louis Frederick of Mecklenburg-Strelitz 2148, "4 AUG 1713", "29 JUN 1761", # Elisabeth Albertine of Saxe-Hildburghausen - 2149, "26 JAN 1935", NA_character_, #Helen Louise Kirby. Countess Dvinskaya + 2149, "26 JAN 1935", NA_character_, # Helen Louise Kirby. Countess Dvinskaya 2150, "13 SEP 1794", "12 APR 1860", # Ernest I of Hohenlohe-Langenburg 2152, "11 OCT 1957", NA_character_, # Katharine Fraser; living 2155, "9 AUG 1914", "26 APR 1943", # Alastair Arthur of Connaught, 2nd Duke of Connaught @@ -1935,7 +1933,7 @@ date_overrides <- tribble( 2593, "850", "8 DEC 899", # Arnulf of Carinthia 2594, "873", "903", # Oda of Bavaria and death after/about 903 2595, "893", "24 SEP 911", # Louis the Child; - # death date varies 20/24 SEP 911, selected 24 SEP + # death date varies 20/24 SEP 911, selected 24 SEP 2596, "870", "13 AUG 900", # Zwentibold 2597, "850", "24 DEC 903", # Hedwiga of Babenberg 2598, "851", "30 NOV 912", # Otto of Saxony / Otto the Illustrious @@ -2096,7 +2094,7 @@ date_overrides <- tribble( 2876, "19 MAY 1797", "26 DEC 1818", # Maria Isabel of Portugal / Queen of Spain 2877, "6 DEC 1803", "18 MAY 1829", # Maria Josepha Amalia of Saxony / Queen of Spain 2878, "11 NOV 1748", "20 JAN 1819", # Charles IV of Spain; - # some sources give death as 19 JAN 1819 + # some sources give death as 19 JAN 1819 2879, "9 DEC 1751", "2 JAN 1819", # Maria Luisa of Parma / Queen of Spain 2880, "20 JAN 1716", "14 DEC 1788", # Charles III of Spain 2881, "24 NOV 1724", "27 SEP 1760", # Maria Amalia of Saxony / Queen of Spain @@ -2184,38 +2182,32 @@ date_overrides <- tribble( 2998, "4 JAN 1912", "29 MAY 1940", # Anthony Cartland 3009, NA_character_, NA_character_, # blanking the infant Cartland row for now 3010, "31 DEC 1939", NA_character_ # Glen McCorquodale - ) # notes: -# 1051 likely duplicates the Andreas of Leiningen already represented at personID == 911. -#1125 likely duplicates Jean of Luxembourg already represented at personID == 586. - -# Non-date cautions surfaced while auditing: +# 1125 likely duplicates Jean of Luxembourg already represented at personID == 586. # 1801: the row title says “King of Denmark,” but the likely identity is Sihtric Cáech/Sihtric of Northumbria or Dublin. I included the date data and noted the title/identity caution in the comment. -#1847: likely Isabel de Warenne based on the Balliol/Warenne placement, but the row’s given name alone is underspecified. I included the date data and flagged the inference. +# 1847: likely Isabel de Warenne based on the Balliol/Warenne placement, but the row’s given name alone is underspecified. I included the date data and flagged the inference. +# 1975: likely duplicates or variant-matches 1968 Æthelstan of Kent. I included the date data and flagged it. -#1975: likely duplicates or variant-matches 1968 Æthelstan of Kent. I included the date data and flagged it. +# 2065 likely duplicates the Catherine Swynford branch already represented elsewhere. -#2065 likely duplicates the Catherine Swynford branch already represented elsewhere. +# 2158 likely duplicates George Mountbatten already represented at personID == 102. -#2158 likely duplicates George Mountbatten already represented at personID == 102. +# 2215 has a current death-year pattern that may not match the most likely identification as Murchad mac Diarmata; I included the date data and flagged the identity concern. -#2215 has a current death-year pattern that may not match the most likely identification as Murchad mac Diarmata; I included the date data and flagged the identity concern. +# 2269 is listed only as “of Burgundy,” but the most likely identity in context is Philip the Bold, Duke of Burgundy. I included the date data and flagged that inference. -#2269 is listed only as “of Burgundy,” but the most likely identity in context is Philip the Bold, Duke of Burgundy. I included the date data and flagged that inference. +# 2279 likely duplicates Edmund Stafford already represented at personID == 2070. -#2279 likely duplicates Edmund Stafford already represented at personID == 2070. +# 2288 likely duplicates John Hastings already represented at personID == 1417. -#2288 likely duplicates John Hastings already represented at personID == 1417. - -#2300 likely duplicates John Neville, Lord Latimer already represented at personID == 863. # 2359 likely duplicates Thomas Howard, 4th Duke of Norfolk, already represented at personID == 2326. @@ -3063,8 +3055,10 @@ royal92_cleaned <- royal92 %>% personID == 201 ~ "Duke of Argyll", personID == 224 ~ "Princess of Battenberg; Princess of Erbach-Schönberg", personID %in% - c(230, 2839, - 2842, 2845) ~ "Princess of Greece and Denmark", + c( + 230, 2839, + 2842, 2845 + ) ~ "Princess of Greece and Denmark", personID == 240 ~ "Lady McCorquodale", personID == 241 ~ "Lady Fellowes", personID %in% @@ -3100,12 +3094,14 @@ royal92_cleaned <- royal92 %>% personID %in% c(453, 2234) ~ "Queen of Norway", personID %in% - c(474, 1828, 2416, + c( + 474, 1828, 2416, 2443, 2449, 2485, 2508, 2615, 2618, 2633, 2858, 2864, 2876, 2877, 2879, - 2881, 2883, 2887, 2888) ~ "Queen", + 2881, 2883, 2887, 2888 + ) ~ "Queen", personID == 479 ~ "Margrave of Baden", personID == 484 ~ "Duke of Württemberg", personID %in% @@ -3120,9 +3116,11 @@ royal92_cleaned <- royal92 %>% personID == 531 ~ "Grand Duke of Tuscany", personID == 578 ~ "Duke of Nassau", personID %in% - c(590, 751, + c( + 590, 751, 2501, - 2515, 2516) ~ "Duke of Orléans", + 2515, 2516 + ) ~ "Duke of Orléans", personID == 591 ~ "Duke of Segovia", personID == 593 ~ "Duchess of Soria", personID == 594 ~ "Infante of Spain", @@ -3157,18 +3155,24 @@ royal92_cleaned <- royal92 %>% c(863) ~ "Baron Latimer", personID == 864 ~ "Baron Seymour", personID %in% - c(871, 1929, + c( + 871, 1929, 2291, 2418, 2419, 2420, 2430, 2431, - 2433, 2434) ~ "Holy Roman Emperor", - personID %in% c(873, 2315, - 2953, 2954) ~ "Earl of Leicester", - personID %in% c(876, 1883, - 2217, 2288, 2332) ~ "Earl of Pembroke", + 2433, 2434 + ) ~ "Holy Roman Emperor", + personID %in% c( + 873, 2315, + 2953, 2954 + ) ~ "Earl of Leicester", + personID %in% c( + 876, 1883, + 2217, 2288, 2332 + ) ~ "Earl of Pembroke", personID == 877 ~ "Crown Prince of Yugoslavia", personID %in% - c(914) ~ "Grand Duchess of Russia", + c(914) ~ "Grand Duchess of Russia", personID == 932 ~ "Princess of Prussia", personID == 1051 ~ NA_character_, personID == 1250 ~ "Earl of Bothwell", @@ -3176,12 +3180,16 @@ royal92_cleaned <- royal92 %>% c(1373, 1867) ~ "Count of Poitiers", personID == 1385 ~ "Abbess", personID %in% - c(1473, 1476, - 1492, 1494) ~ "Earl of Arran", + c( + 1473, 1476, + 1492, 1494 + ) ~ "Earl of Arran", personID %in% - c(1588, 1834, - 1877, 1890, - 2295) ~ "Earl of Gloucester", + c( + 1588, 1834, + 1877, 1890, + 2295 + ) ~ "Earl of Gloucester", personID == 1802 ~ "wife of Edward the Elder", personID == 1804 ~ "son of Edward the Elder", personID == 1811 ~ "King of West Francia", @@ -3205,8 +3213,10 @@ royal92_cleaned <- royal92 %>% personID %in% c(1897, 2470) ~ "Count of Dreux", personID %in% - c(1904, 1906, - 2280, 2283) ~ "Earl of March", + c( + 1904, 1906, + 2280, 2283 + ) ~ "Earl of March", personID %in% c(1907, 1908) ~ "Baron Mortimer", personID == 1914 ~ "Marquess Wellesley", @@ -3248,14 +3258,18 @@ royal92_cleaned <- royal92 %>% personID == 2160 ~ "Baron Mount Temple", personID == 2180 ~ "Lord Rhys", personID %in% - c(2191, 2192, - 2193, 2194) ~ "Baron Inchiquin", + c( + 2191, 2192, + 2193, 2194 + ) ~ "Baron Inchiquin", personID %in% c(2195, 2202) ~ "King of Thomond", personID == 2218 ~ "Countess of Pembroke", personID %in% - c(2269, 2426, - 2518, 2533) ~ "Duke of Burgundy", + c( + 2269, 2426, + 2518, 2533 + ) ~ "Duke of Burgundy", personID == 2270 ~ "Count of Saint-Pol", personID == 2271 ~ "Earl Rivers", personID == 2278 ~ "Lord Cherleton", @@ -3307,7 +3321,7 @@ royal92_cleaned <- royal92 %>% personID == 2396 ~ "Lord Beauchamp", personID == 2397 ~ "Baron Seymour of Trowbridge", personID %in% - c(2403,2963) ~ "Lady", + c(2403, 2963) ~ "Lady", personID == 2407 ~ "Earl of Banbury", personID == 2414 ~ "Lord Offaly", personID == 2427 ~ "Electress", @@ -3329,7 +3343,7 @@ royal92_cleaned <- royal92 %>% personID == 2578 ~ "son of Charles the Bald", personID == 2632 ~ "Baron Geddes", personID %in% - c(2634, 2875) ~ "Princess of Asturias", + c(2634, 2875) ~ "Princess of Asturias", personID == 2637 ~ "Princess of Bourbon-Two Sicilies", personID == 2638 ~ "Viscount de la Torre", personID == 2642 ~ "Countess Marone-Cinzano", @@ -3352,7 +3366,7 @@ royal92_cleaned <- royal92 %>% personID == 2889 ~ "Prince of Asturias", personID == 2890 ~ "Prince of Portugal", personID %in% - c(2892, 2913) ~ "Duchess of Savoy", + c(2892, 2913) ~ "Duchess of Savoy", personID == 2893 ~ "Duke of Savoy", personID == 2900 ~ "Duke of Vendôme", personID == 2904 ~ "Prince Napoléon", @@ -3372,7 +3386,7 @@ royal92_cleaned <- royal92 %>% personID == 2956 ~ "Earl of Albemarle", personID == 2964 ~ "Princess of Yugoslavia", personID == 2965 ~ "Prince of Yugoslavia", - personID == 3009 ~ NA_character_, #Blanking + personID == 3009 ~ NA_character_, # Blanking TRUE ~ attribute_title ), twinID = case_when( @@ -3417,9 +3431,10 @@ royal92_cleaned <- royal92 %>% royal92 <- royal92_cleaned %>% select(personID, momID, dadID, - famID, twinID, name, sex, - birth_date, death_date, - title = attribute_title) + famID, twinID, name, sex, + birth_date, death_date, + title = attribute_title + ) checkis_acyclic <- checkPedigreeNetwork(royal92, personID = "personID", @@ -3436,24 +3451,21 @@ if (checkis_acyclic$is_acyclic) { message("The pedigree contains cyclic relationships.") } -if(FALSE){ - - library(ggpedigree) +if (FALSE) { + library(ggpedigree) royal92_famid <- royal92 %>% group_by(famID) %>% group_split() -ggped<- ggPedigreeInteractive(royal92_famid[[1]], - personID = "personID", - momID = "momID", - dadID = "dadID", - twinID = "twinID", - config = list( - code_male = "M", - code_female = "F", - add_phantoms = TRUE - ) - ) - - + ggped <- ggPedigreeInteractive(royal92_famid[[1]], + personID = "personID", + momID = "momID", + dadID = "dadID", + twinID = "twinID", + config = list( + code_male = "M", + code_female = "F", + add_phantoms = TRUE + ) + ) } diff --git a/tests/testthat/test-tweakPedigree.R b/tests/testthat/test-tweakPedigree.R index c9d9ac9b..588c78c7 100644 --- a/tests/testthat/test-tweakPedigree.R +++ b/tests/testthat/test-tweakPedigree.R @@ -97,7 +97,7 @@ test_that("makeTwins - dz Twins specified by generation", { # did it make the pair in the correct generation? expect_equal(mean(resultdz$gen[!is.na(resultdz$twinID)]), gen_twin) # how many sexes do we have? - sexes <- length(unique(resultdz$sex[!is.na(resultdz$twinID)])) + sexes <- length(unique(resultdz$sex[!is.na(resultdz$twinID)])) expect_lte(sexes, 2) expect_gte(sexes, 1) # are they from the same family? From 2e10e422941175fb2d1d70d5cc4c7d766d280373 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Fri, 5 Jun 2026 14:58:32 -0400 Subject: [PATCH 02/20] data --- data-raw/df_royal92.R | 51 ++++++++++++++++++++++++++++++------------ data-raw/royal92.csv | 10 ++++----- data/royal92.rda | Bin 47960 -> 48008 bytes 3 files changed, 42 insertions(+), 19 deletions(-) diff --git a/data-raw/df_royal92.R b/data-raw/df_royal92.R index 64be3000..f0f55a4f 100644 --- a/data-raw/df_royal92.R +++ b/data-raw/df_royal92.R @@ -126,6 +126,14 @@ royal92 <- df_raw <- readGedcom("data-raw/royal92.ged") %>% dadID = NA_integer_, overwrite = TRUE ) %>% + addPersonToPed( + personID = 1125, # overwriting duplicated Jean of Luxembourg + name = "TODO", + sex = "U", + momID = NA_integer_, + dadID = NA_integer_, + overwrite = TRUE + ) %>% addPersonToPed( personID = 2300, # overwriting duplicated John Neville name = "TODO", @@ -862,7 +870,7 @@ date_overrides <- tribble( 1122, "15 SEP 1904", "18 MAR 1983", # Umberto II of Italy 1123, "11 OCT 1927", "10 JAN 2005", # Josephine-Charlotte of Belgium 1124, "6 JUN 1934", NA_character_, # Albert II of Belgium; living - 1125, "5 JAN 1921", "23 APR 2019", # Jean of Luxembourg; duplicate/identity match to personID 586 likely + 1125, NA_character_, NA_character_, # to replace 1126, "11 JUN 1928", "5 DEC 2014", # Fabiola de Mora y Aragón 1127, "11 SEP 1937", NA_character_, # Paola Ruffo di Calabria; living 1128, "15 APR 1960", NA_character_, # Philippe of Belgium; living @@ -1567,6 +1575,8 @@ date_overrides <- tribble( 2158, "6 NOV 1892", "8 APR 1938", # George Mountbatten, 2nd Marquess of Milford Haven; likely duplicate/identity match to personID 102 2159, "9 MAR 1963", NA_character_, # Ivar Mountbatten; living 2160, "13 SEP 1867", "3 JUL 1939", # Wilfrid Ashley, 1st Baron Mount Temple + 2162, "19 OCT 1910", "31 MAR 1989", #Hamilton Joseph Keyes O'Malley (Q75382629) + 2166, "1205", "1257", # Maelgwn Fychan and death year 2168, "1210", "1265", # Maredudd ap Owain and death year 2169, "1240", "1275", # Owain ap Maredudd and death year @@ -2055,6 +2065,8 @@ date_overrides <- tribble( 2780, "10 APR 1916", "22 DEC 2019", # Dagmar Bernadotte af Wisborg 2781, "12 JUL 1921", "3 NOV 2018", # Oscar Bernadotte af Wisborg 2782, "10 JAN 1926", NA_character_, # Catharina Bernadotte af Wisborg; living or death not found in this pass + 2789, "10 AUG 1934", NA_character_, #Miles Carl Flach + 2790, "22 DEC 1960", NA_character_, # Jana Camilla Flach 2829, "25 JUN 1899", "4 JAN 1977", # Margaretha of Sweden / Princess Axel of Denmark 2830, "12 AUG 1888", "14 JUL 1964", # Axel of Denmark 2831, "7 FEB 1904", "15 APR 1991", # Elsa von Rosen @@ -2185,7 +2197,6 @@ date_overrides <- tribble( ) # notes: -# 1125 likely duplicates Jean of Luxembourg already represented at personID == 586. # 1801: the row title says “King of Denmark,” but the likely identity is Sihtric Cáech/Sihtric of Northumbria or Dublin. I included the date data and noted the title/identity caution in the comment. @@ -2208,8 +2219,6 @@ date_overrides <- tribble( # 2288 likely duplicates John Hastings already represented at personID == 1417. - - # 2359 likely duplicates Thomas Howard, 4th Duke of Norfolk, already represented at personID == 2326. # 2371 likely duplicates Margaret Audley already represented at personID == 2325. @@ -2230,15 +2239,10 @@ date_overrides <- tribble( # 2689, 2690: likely duplicate/identity matches to the Württemberg/Brandenburg-Schwedt parents already represented at personID == 1067 and 1068. # 2839 is listed as Mary, but the row clearly matches Marie Bonaparte through the father Roland Bonaparte and the marriage to Prince George of Greece. -# 2867, 2868, and 2872 required approximate mid-month values because the available date information was month-level. I used parse-compatible dates and marked them as approximate. - -# 2878 Charles IV has a one-day death-date discrepancy. I used 20 JAN 1819, while noting that some sources give 19 JAN 1819. - -# 2921 appears to be Marie Louise Élisabeth d’Orléans, Duchess of Berry. The current row’s death-year placeholder appears to be wrong, so I used 21 JUL 1719. # 2964, 2965, and 2967 resolve the Greek/Yugoslav branch: Olga of Greece and Denmark, Prince Paul of Yugoslavia, and Elizabeth of Greece and Denmark. -# 3009 is only identifiable as an infant Cartland row in this pass, so I used year-level dates only rather than fabricating precision. + name_overrides <- tribble( ~personID, ~name_override, @@ -2635,6 +2639,7 @@ name_overrides <- tribble( 2158, "George Mountbatten", 2159, "Ivar Mountbatten", 2160, "Wilfrid Ashley", + 2162, "Hamilton Joseph Keyes-O'Malley", 2169, "Owain ap Maredudd", 2170, "Llywelyn ap Owain", 2171, "Thomas ap Llywelyn", @@ -2912,6 +2917,8 @@ name_overrides <- tribble( 2780, "Dagmar Bernadotte af Wisborg", 2781, "Oscar Bernadotte af Wisborg", 2782, "Catharina Bernadotte af Wisborg", + 2789, "Miles Carl Flach", + 2790, "Jana Camilla Flach", 2829, "Margaretha of Sweden", 2832, "Madeleine Bernadotte af Wisborg", 2839, "Marie Bonaparte", @@ -3175,6 +3182,7 @@ royal92_cleaned <- royal92 %>% c(914) ~ "Grand Duchess of Russia", personID == 932 ~ "Princess of Prussia", personID == 1051 ~ NA_character_, + personID == 1125 ~ NA_character_, personID == 1250 ~ "Earl of Bothwell", personID %in% c(1373, 1867) ~ "Count of Poitiers", @@ -3190,6 +3198,8 @@ royal92_cleaned <- royal92 %>% 1877, 1890, 2295 ) ~ "Earl of Gloucester", + personID %in% + c(1706,2162,2789) ~ "Captain", personID == 1802 ~ "wife of Edward the Elder", personID == 1804 ~ "son of Edward the Elder", personID == 1811 ~ "King of West Francia", @@ -3425,7 +3435,8 @@ royal92_cleaned <- royal92 %>% ) ~ "F", TRUE ~ sex ), - name = str_replace_all(name, text_cleanup_regex) %>% + name = str_replace_all(name, + text_cleanup_regex) %>% str_squish() ) @@ -3457,7 +3468,15 @@ if (FALSE) { group_by(famID) %>% group_split() - ggped <- ggPedigreeInteractive(royal92_famid[[1]], + royal92_trimmed1 <- + royal92_famid[[1]]%>% trimPedigree( + personID = "personID", + momID = "momID", + dadID = "dadID", + max_iter = 2 + ) + + ggped <- ggPedigreeInteractive(royal92_trimmed1, personID = "personID", momID = "momID", dadID = "dadID", @@ -3465,7 +3484,11 @@ if (FALSE) { config = list( code_male = "M", code_female = "F", - add_phantoms = TRUE - ) + add_phantoms = TRUE, + ped_packed=T, + ped_align = T + ), + tooltip_columns = c("personID", "name", "title", "birth_date", "death_date") + ) } diff --git a/data-raw/royal92.csv b/data-raw/royal92.csv index de19e33f..b8e31b97 100644 --- a/data-raw/royal92.csv +++ b/data-raw/royal92.csv @@ -1123,7 +1123,7 @@ personID,momID,dadID,famID,twinID,name,sex,birth_date,death_date,title 1122,NA,NA,90,NA,Umberto II,M,1904-09-15,1983-03-18,King of Italy 1123,599,600,1,NA,Josephine Charlotte,F,1927-10-11,2005-01-10,NA 1124,599,600,1,NA,Albert,M,1934-06-06,NA,Prince of Liege -1125,NA,NA,91,NA,Jean of Luxembourg,M,1921-01-05,2019-04-23,Grand Duke +1125,NA,NA,91,NA,TODO,U,1921-06-15,NA,NA 1126,NA,NA,92,NA,Fabiola de Mora y Aragon,F,1928-06-11,2014-12-05,NA 1127,NA,NA,1,NA,Paola di Calabria Ruffo,F,1937-09-11,NA,NA 1128,1127,1124,1,NA,Philippe,M,1960-04-15,NA,NA @@ -1704,7 +1704,7 @@ personID,momID,dadID,famID,twinID,name,sex,birth_date,death_date,title 1703,1425,1424,1,NA,Marie Therese of Angouleme,F,1778-12-19,1851-10-19,Duchess 1704,514,417,27,NA,Pepin the Hunchback,M,769-06-15,811-06-15,NA 1705,NA,NA,1,NA,Marie Amelie of Bourbon,F,1782-04-26,1866-03-24,Queen of France -1706,123,126,1,NA,Alexander of Mar Ramsay,M,1919-12-21,2000-12-20,Capt. +1706,123,126,1,NA,Alexander of Mar Ramsay,M,1919-12-21,2000-12-20,Captain 1707,NA,NA,1,NA,Flora Fraser,F,1930-10-18,NA,Lady 1708,NA,NA,166,NA,Dorothy Hastings,F,1899-06-15,NA,NA 1709,NA,NA,167,NA,Henry Somerset,M,1900-04-04,1984-02-04,Duke of Beaufort @@ -2160,7 +2160,7 @@ personID,momID,dadID,famID,twinID,name,sex,birth_date,death_date,title 2159,2156,504,1,NA,Ivar Mountbatten,M,1963-03-09,NA,Lord 2160,NA,NA,1,NA,Wilfrid Ashley,M,1867-09-13,1939-07-03,Baron Mount Temple 2161,NA,NA,1,NA,of Lodesborough,M,NA,NA,Earl -2162,NA,NA,238,NA,J. Keyes-O'Malley Hamilton,M,NA,NA,Capt. +2162,NA,NA,238,NA,Hamilton Joseph Keyes-O'Malley,M,1910-10-19,1989-03-31,Captain 2163,NA,NA,1,NA,Michael Kelly Bryan,M,NA,NA,NA 2164,NA,NA,239,NA,William Kemp,M,NA,NA,NA 2165,509,2163,1,NA,Robin Alexander,M,NA,NA,NA @@ -2787,8 +2787,8 @@ personID,momID,dadID,famID,twinID,name,sex,birth_date,death_date,title 2786,2780,2783,1,NA,Catherine von Arbin,F,1946-06-15,NA,NA 2787,2780,2783,1,NA,Jeanette von Arbin,F,1951-06-15,NA,NA 2788,2780,2783,1,NA,Madeleine von Arbin,F,1955-06-15,NA,NA -2789,NA,NA,1,NA,Miles Flach,M,1934-06-15,NA,Capt. -2790,2784,2789,1,NA,Camilla Flach,F,1960-06-15,NA,NA +2789,NA,NA,1,NA,Miles Carl Flach,M,1934-08-10,NA,Captain +2790,2784,2789,1,NA,Jana Camilla Flach,F,1960-12-22,NA,NA 2791,NA,NA,1,NA,Dick Bergstrom,M,1936-06-15,NA,NA 2792,2785,2791,1,NA,Therese Bergstrom,F,1963-06-15,NA,NA 2793,2785,2791,1,NA,Michael Bergstrom,M,1965-06-15,NA,NA diff --git a/data/royal92.rda b/data/royal92.rda index 785e6ae654e3227eed8cbb6c80ba2f1bd5934806..035c546eba4a7a5e5af97b9fbcce5610d0ddcd77 100644 GIT binary patch delta 32204 zcmV(nK=QxX_5z6a0+1R5nY&4`9jiWnT>pG-60=h!jT_8=A`(L4 zN+;2A-0C|ciAQ7i$s;l)GPP!^_!(qt=b1FW--nIAqbeI>pj!4OBLn<6m-i@nS2>s` z2j&zqYpTC?#cH0UD6a4?$yT2c*96^oUjPPY>k&I=QVv&wK3lP#Ivl<#pw{r|ws7p; z5Ykb8jT1$LMx8)pUc6DfYgtTxlK!$1w6zoXQulGCHdSz<$J3`pS_wY6sV6kfV%gU{ z)>w96OVDx}Aux-#?C%_&^Bu)LmyGF!hHZg@<2+EHV7Zk>~H$aeZp+yr!g;lD)eoF`oF9< ztiS{I5UseyB%aC%!k*~G&AqEKW6D~avU4)gix$bquTZe&Mc$&;MFA%0zkiIbMB^J# zC`KTRantpLqjvZ)+tea|vQ)q0=WqfPOudNfH|VXcSH560jrlq+HcbOMlv}HIW*!%C zfXrOYZvh_o+OFsdwn7MPK!5gIZ9?!bDl_WJ2ncFF!skb2gCM^A=I^0at6XQ1-p z(Tlg8@Kf!?{j^WIMm9jpl(OApO{=50^eAe&38W~dyXv+L54+jWIu7-O)z8T4rqPw9 z@2il^bMIs6xQ*eghRF=ZGm`qKgfgZb?s(Tj*0v*o{0L0o?_OPc}`YYZ0fG?vUP?`EKbUuteSxT3;&yXWYGpWsm57a@trwZj9rQi@e^P zLNIiig^8sb>q;|JVpi`6Tb+Hyx>;Z0&NowsU)Z<5ZQw=dk4*Dqt$t^u^Vc1TD_0zm^h|)&w{%K1j>=*yFWZCyLHZajA-9wb_Ad-;i>P8hB+p<^~N*8vUF6naP96 zz5Z1GJur5!RN1sStwYd##2LFcv!#M*-OkkvV%uC!ebhLAIy&1SiPvg#mMgUjjKtv zAt$eFU`=?&D$uRta?`Bfcjzf-HS$i=8=b-)X^$GRD z(4wK1TgH5|55=gMcT&sdJWkOG-l%x*lIxj}fC6BDG8QQ5@xDUbGMc~}{jR>*K_X_l zZkN&;@Q(i8LRU`7aShD8t7lh#I*b%3!0+?0rjyB~Y;X841@7;#stw7H1(K8%Q%ff% zR01wE3To|lIQ?aS=NZcUzR)pp0p7$TCrl3|sDp)H(4m@cVp`Fi0}VqWJIaUpA_c3m zioHW$A`S87IMBp*tY%=aQL-ez82`)eC#Et(2?;1@${e%rxe9ckOc*hL{?aLw1l19p z)!96awZo_|z^~zboBhD9>LHGuB@4Rl{AD5#52N{mNl4XV;3fKZHSfQ8K9k#p3JH5N zmnO*G*GJWMt+tKb;qwmm#ec+UMF2sn)9?9EJV$-)gW_W1S_h-Rp1$!(Y`dX8`Lfc9 zR)RRbSc7Wq=}bM$2Tm1#g0z?npAMboNBlCN-k55G-qDOfKE(lVSYM`UR;{mtzs9A&t6B9D5!k43w)vMXHHMGz?e4Va;{0+VulI-K3{!1s=ojGP> zXI$2MoLgvJ8`>jm)}9APsb)ja2xVa2S-&kn!P{JqpgANz;eut>=n+e%>?-~i-8P)i65Gf5=!9vk#?U=BGDFqg(Oej)F{@Q z9t$&-v}HWYvvYkibs5JL_zZii+K#C-^EBMBhNV3B%(DGGm4quekJ$TVLc8LTAIv|a zQLlfW1U1^0F9Oo^CzmKyov7SIos2rN0s&2p}up<7~~(axY^Shy3O< zh!==|o`ZXRS%r(gca-35H)A8WD!!eLut%qvjqUX&DY zs2!uiVXowaOW7DK2}!o!gK-OXG%)p~|9pd7yf`3w{_)x>1wfBv-jyn!1epW_+Yc&# zi=6l;t|5v0h~RJaVh86hcObi#ah{lI8Ib)Y*Sq^c4jLbPx{}d6@jKfVpb>>7U{(&5aZ)qsyIcu5TkNC(^fnC(*M$NwILgP;apB%I9_l0 z%wUR4jTb_OMhldcbL+HbwZ$Q=iES!>#>>Ft4jxf#Y7kcxi@3Y=ZMbeWd*(^w@R7OH z7pF_Oa?ImLB`>{u8P0tFEgGeVI-Q)n!VTU(mcU&?d5%s3W-?ne-_>HaE}lz#@C_Mv zs@C)4@V+>fK6jUvMG2LV&@vJd0`Y9}o{$z}QwYe2A zw7w6c+%8`p+9Zt!#XKJ1rkMW(%#8GG0hEX*=$jhaWI}kfqBK$GJ&U5;IpdWtlA4v5 zS7)ig5b$U9j&LiOc*nrQM6P-j>=N8P>{_3zcYu`=&16Y7d;4biP}y7n#D6=vZQ)p9 z`BnO@v=g!;3`;U_>l-Y7|MJ>@B{2aTmN#yjD?)3D`|}0sRC;(@agtSw2aLH&?~9YW zQoL^*;eX?;3Z#%NtJ8Mq6gPHZ^F7=uL!v9d3Z!L(O6?imBQ;j$YRH~ zPb(abVQkUb?jTo`&dep5FI#}eEw152R|#|0Bvf~OVzgbP>Ukd4M&9&)xZ9Do!1`bL zG@DP>#+|lWf`KebQzWVIYp|rId8>laoHkcHb?1+uCHE788e;!b1|FWA*y{UEN^^uS zE4M8Ao1v{f1y2YL#d?$7zJw3lkICe+NS$fV66F?gT-=-V1lahCpod1hQ;%7u#BT(W zpX&O*tD?C(f6es}T{SL$_GO3!;7Sh%?_S2Cs`Uke43QyHrrpQ8>?9dLXSgnm5SzqT zkD|S#l89iWFn$l={}?C8_gZm@xfz#UoKiOL-EcfQ z0F5|G-o08w8&*5lq$b6uM)G1md3}UhGQbT5P>IXeeI>Ok7dKmbvK_yDYc4 z7ss7)|G2-f+`636|{1MecagS9S0ztS28p-*=mVvc$RY@}wnK&y171}ffV z2j^#?gt}};XcuIB$%5eFU$#^Lt`K#S%Dl%eE8Bj?ZqlgNXtC>|cH0o*U z=7(*RyaSXtJxU*Oxwr?q`Pah!ejkLpJOz2g>CI45Dd9TPFlX1c5%AO>826EB~$~7Ql z7p|!_&?q8*r!vfM0v}fGC3r`!hU43im#~Bx0?3P5NG72fP;KLrEFM2lg?}OxlFGZ~ zPW0)nIgSpTkhEpm0^T*M(?PJ_m;A1QbAJySWFaG@-e>k?%tEtfbuczQ7eKb3M=K&0}sfnluQw5PgcFhrvT1Ke(^oH zJKd;%tS5%Oi0H}rk9HGAsX+>yFITL^60xH;BYL5%-y-?tI%1>q0H%0M3HNKJEV=cg2q&SmEX{O>_ZT1+Z3lDarkrE!V4d+SKlT^|Nmuk-M`W-e zKp&Rg&zpwr?8~ydTF3#y7S0ouv$@{8K;K0tY(dED2nHZ2{7$Kk(7RO`G#GOX(=12dFQ_Yd>GS6ZlUs zi)~Dh=2+ch-SYuPBbVpyoLuL?B(^FDzX-{Pc5GmD;k;m&kv8eA(*X zz*R_#5Q$!zkr%Uh&sjn)Ws31VGW38l?&g4{pO|F41ZP)=8n=PR9Mzv3KhAxB!fYqm zvd~WV?73ksf%)8wi%wsCneWO-WHj(`E;mEHEk2LGa|EJHT*PrL0R=n?Uf<@aGBRev z={?ZMcQ_Z<#>zL*Kgc(h54%Gd+iuF!p(i&ZWpPWhXazYT18hQ=$AtXcqXV$d!@dv! zm2P}sp;gT7;gNTl4(4Pf&zX3qZT z30LERaJ%-vLTA>n2R#7+Ex+JrKr0cH!VE~@Kn+`?47EHZE}QIR@E?eOIW^d-Rda_O ziQ)NPcnwS2!D)&p>kM|357AP&TiXz&6@n_>I`L}K}3NfK?b<@3h>YnCQ`*CDQ4t|}M z1e2yQiru3}fxh$a)QkoeT;OJOh2v)mx)>SX3O<8p4tFuiUd7;Zzj02G#glsND5eItvBunruB z2c(M_P}YHy88eYeprRfwo7}uEmZK&b^b*bB!T@+_1!if{DA?wlqWIp&&!tEmMCx?t zNC@{o|8B-naCwG=QNae<3x@9&^E{a;|BKDAJOM8KuNn^Gfs}54VP?a%Okn6eoT0dd z6@6|6sXF-1_bpU^fzQcelcDX*EV@tln-z`dG@AuCDFYkui-D<-Zw~OV>2}ZG)Y(wU z#!a4y~_BFKud#(u&XUI%4q&u~g+1x)q4RPHt>MyTR zrPcU%(3Qnv%wB1FWc?TMFUBK?^XXuJgt>|JN51I8IsJ z6LT-_)T74oC7i?miiomXh{ZFUv!R%AUp3mY_0=aQy=|^})3SL&!!bQGL-NP_d3!q@ z6q+U`SuBQsEhvlx3U4sj`Q#2++~XXAZRe25Oeb71bGsuthyq7)AaZa_k6Alw3vZdv zxeWSsit1y#5FaEV$~_7TWL!2Hnkn03J(xxVp*QXXA4IMRFi}!KwML z>(pT9ARtiryjAOmyKBx)V^?j3&0;=(}#{4$weV>f%v4-rTZTr@|*#r3n%CJRxmxasfvhfp_KO{~6{K5qyv`ENlog~9j8Jbm*$d-UT z8KtLz_k#tt8}TwMgA=|ujCM}`BIcjb{{dSAHrfO)aGqgS2c54?`DHeURzTNiy8$SF zjxSmsehs&Gtj^$eqZ&lW(H}V^KF0Eq8xJ$x!*^@vqdQ%g=@eEm5WnI_|GO9}T#Ex} zCk!v}MUJ-EgoZmcCp*|U0O9fdoiOniartgQCs?h?;IVIgDV@@aWi)f3XKAH2{xUGE zUhMv4Y%Hq`a+a=$#D`YnDTkZG5X~5Wt$4Vu2M0B~s;}g;s(u|e^A7V;@8nOt2Jx zV~4id?u8LDIpwW(JC=x2X@4}1C!KWS5(S`-5lA~PH%3v%U{Zigau)hN7ka<7jtU(7g zmce&bF^G~wZpZvFd7HVFO&E)BmQ=yr!Ec};lfq$F+~05oYNe2W#HIy~W9I`z=)t_Nkjh#CmK)zFKF&T>);on0r@FbHcp({-4u} z?;tvT^hK--J?E!?zZ%r`F++2s22NR?SDja&1*g_$g`gh=`OwHzGVCL_#hvYD5qJX> ztE>cLP$Zz=-LgIfdEB)(AWYt22V~o!uPVA{Pz0c%nZ-24%1I+JCmB-7ayxNVB8q)M zcdCb;oElj$?bahoD0B5s!@f_9Sr<9vY*26-xxKRd6p0Lfa)O`RDC&_(n`X*|zjiR( z`r5Qm8uswO5ax`+PBn=ZU@KcRk&VGLLB4%z?KdsAT6U3X&9+?mUdm~{4dRa{g$_gp zgcIrquak-{IE6U)fkBJ{OZYI3(lpm+I{0B*9_5@sUg@YF=OCN8BNu$^=w#5JNFn9I z5I&$2U@-%KA11ipVN$^!M!&TJ5&f2)WfVH9`I)iw>0wB`#|D5WyYPPn8XyU8Nd+L1 zf@+lhsB1?c!_YZJ?x3ZnnLAu}US1m+#$CvPu=PX4#br-o9)bzktBiKxh7@$0ku_hR z!R7;(Ud?F~EA!hT*(CD7NDqc>UIqwj{-2qOBiX2bpRd__74uG(z1}{ylTkBSB$3;^ zsYL5X(5q`%x9Ca-?;$iJ*A}RXgrCN4tUDIU;g+~@X3@R)D;opKyxZt|m0fOmBtO?m z6e{AwYYiudMlt&K{;%=7eCqyhnuQ%xCBeCVEN-Y#SU~PhGfiT(j&B8gA9ZTx_xL=o zsoleWnf&bg$D&u(vo9XLQ*<@Gu|nk421eBLjM&vMglFJMZ?e~6%M33l9+i*Buoq>R zOv`qbw#Gu_`^E%ip!IdPJoj7OSw||Dk#k!{fwj`G<2AA`a8!qnN81L6y8?!M% zPF{jo3;C$tcGU26K9C(i1;HBk#Tthc^4VJ-FHy~xarXH3#uG^XZo+>7WjuS4+87Dy z4}DlTYAK#jrkKUZ z^xLZkQS_!BM4s#9*Gr5}87pmgEX)Pd%!k^%v{kH|$5ggK&*z&B^b$M?PYVEo!~2e~ z2ZKT4dxr+MeQiIExv7ll`IdWJ8{auuyy4}SIco-(%mX6~Se_!R$M8%129pqf=C%OB ziLx6zOzvsMsYyQcQIv4E0Ib5<=`oS7`)0$%1@71L^sl%rU+c_QfOTaH<+(EE9F!n{ zmowkEe!Q~{E6|c5yK#^qkUjvbs^DrX7q%xpE#c6Ie0g5cPvdn4&H;E0S{%P>)K=#k zR(N0UasMg3h{)B-)e(6KymU%`QSSd1H9Je^N2@$h{0z|MKzsQ!kn*bD;DWZz=QA;| zw*RH~*0wE22Zl)2i7-~Sl4o_m&_Hd^`~aG5WGttaaqFG2RRv$=1Jw0ESKCKwfX`u8httye%$TNFc_Qpiy&po z&qWYCQan;&l@CvG^zyGi#K=YS4{rFr^2C?;e%YE7RB}U9DG#>5~XA!x<=hd zQlhJ%fv70~|LeWXtGs4xNWq9wMdU_}`kHi07$Ru9u&YD!%w*zsuqt>Q??fWfaNqs5 zDY{~m?5Xw-_J-_@JtET|^LxmKQlP>feGDYiLUu}RkAU7Nm*cg6JQmxo=YkmpZ9V_j z8Hj14bv+^Ecl$HHF#}(|nxSPGP|rx3cH9A>MLeB_#O%)-zi`PYw~X<5N)NjvDUP;P zG-U0coc3VZJ6)n61#{ne#zF}bx2@u}AAMrRn%Xgb!r%}VZ?>Tyax`2n?1Qe}64u=h zPP-`DS5L+7y28ePrg?sWPWw8|2=*e(d2(0$PQavCtWg#WFBgc?CgULZZ@q51?{$RZ z^L%j4D-}$(Jv~>y{Fuxk${POmXZ;yI_zNzC?ziWJ}y=CG~j)v(LfiFXVFsnYHZ^N0VWww=LDRN)B`U+}=Z z6F3Pz8Wu2tDIJI?*I2yZ#x}p@D>fV-OeM#^7%+MtXM+99_1)pa0kBIrhQ*6k4hq?k zZgd4e8_YRMk<^AWRKW+!2ScT_P_#&4&?(1?1 z{n@t#cffo=0iGaM`~`Rc<~;VrfEbv4y>x2*%1!BQzp*xl$8vuopXSyZAWjo|Mb*ju zt3C2NMn~qEZj_;)wwBCg@*W2@2#NMAs8Y@-`5@={vrVD3IUV`{&pq6n{1T{`L?T#v z^4GP0%2CfqGa;J6_Jh10J4JmG+2?fZ(xrR$wi`&Ky9o}ODbry=b#IhdH!;#;~ z*k;KyW-(9?CpXbR-QTWQvS|t?r^p3fgxiC>gJ3U>3~Nw|oAi>>&tW@C$;6L9(CRO% zNI5dw1$7Pd(`Kix%VMtHEJoj%in?oa`+dyrMUCDXycAMW2+STxjn8zXu2>1>&w!VP68oNdmB`CWBH~ra z!WWW{ftgYuUrl_gCY1@+aOU|29F?Vi1>eclAG2MtZpBM9ku~X+Wz4D_M7)`RO}=OH za6B%h2b&We1}W*?{RRC~4=;jL!W19txldKx2jh~Jp;;95$U&c?GiGK3bV+uc0bSu` zD;-27kmp#IQQbz&T1HQ-+Chl7OiM_M9qJKzM!V2*_Q-ZyiDyGT;LUiqZ)ov<%X3V} zye>$K|5wf~3KMHHHuUb8{C8E_R}xioaUX7@9O}Y+f^|86MGZh0zwt3rB;jzpTkLay0Pek}FN?(HG8G#7^JVD+ zg^~jTpteTVjhVu&$Z>P*^FDV_FlooPZn^;fL6|?vi^{=#9A8OD)kcG9PAn31CUFhd zDyk-7lmVD^m3tWYTZtE7BS43EfeT|Hl-O-KKV%@5iiWIV4LL0%Y#&s=vqs-riWLL+jeh({nsO8^K?{i+~5 zy3%s?9hdXi6N(i7hZqlkUVoeTx+^Jeoc{l+=4gcg(Yg*X@w-|mgb4{Vw60J6Y=!o; zOsZ8`nh(3uR7SUYZYW zdidZr-QNlF2F8U=3fn0fa_+dk{6_LO_khE{Qq(~~qMYHUBBh0YJi2{}kE?W`OU6Kg zqMEV8lxjEox?7eVtSre!D>|S0O{JOXm1od!%%PM)Gi^N=Yz7iv1&`6V1-2#`=^;)F zVZrky1fDh;f7H~-F>g|4{86LQwnx;dw0qr&h{#rFrvS0-{C0!ioIY8)&w?akqagB{ zOrbZ5Qmqk3j6%MD#-oq!RY|GI}gQ!XLu&wNz?Nm5^$J4IQ zVoSvGS8aB6-q3!PT%6i(N!`~Na(Ark^GaK-kk)7KWLxt5xQ3h#F$ENN=%O_N_jIus z1^Prt_Op$Iu-By1kZrcqt(1;^@I_T%`}}6U>Eis6FJb3@{LDP}-WXw?=)DJlItPv8 zOVt_6IqXHA>bE0L!w7>kAHd`r;vrQCHL{g_|8#r})bY;@F|9U+x_|3ev>w>b9Q259 z*PUT5GBx0`E92$k(A1D3*J^7--1=|8zFij*_vCOH2k%CFX!(%aX7b@1W%7!UQ$9n$ z(n__x+Fsv({m6#ibpYf9F&aLOr0%*aS0F7r8+?A0dkK)C9XX_$@DrJ>{HI;Gu*<73vuYP`|x{8V0_9n4f?w80BpRK%u2y88^sTWaBb} z5#+IXD=*ObmF?~)%w_Qme2B6?yq(+kxe4=n^EE_Vj=lG9xf(RJPf=R!SB0yCrxFBngGIS1~DVK-UnYaxF%LlT* zol%%V1b4I>2W*fHR9|3`fEZVK#b9(T?=^~8aHU{T_Z83jXvNFu@{Gh7_?51kGe`cx z|7|8C{4fA+QSX8<#-juH`ApVei^u&|OV3q*&~7}wb$%|xu5SzXt1I!veeFw@P2=nV;?*8f7ns9u*TBj~KrobX9nZHO-HDpG2BWa=9E-7IM)pZW*SktS^;M z3j^TaLK(h(zBp$3i@@r7``tI+MW*@K)9YtQr6b0FGkS zyeDmdB9#rbrie(ZP}d|UKQWzYP59z}q1+}ra6u-Bn;DPNG+GdtYamb3K~Atjvyy(7 zgf1PakJy$!kIc~2CN6b1q%KawZRTTUVG}jhY$5rSNcpnEX-v#&mMl5bL{OM^uKzE} z`(v58T-3o3&}aC#`zRsFx@5TCBEl8C8S_2bh*fjHFQJi?*$_9Hi|-jzGty9 zXZyr(G9KdG2Yaf{n)SQKxk5`<*J@B_XJkrdWyia|8Z*v=-&ZFLhK5nryQ~I|&I@yw zG=@}E?fJ2e&BMCaqIx$zG~#+>nw*v?2zyDu7P%Be%YPNu>V!!4OcHYPpo#$i-1 z@V)_0`VWsZf$n)@ekJikl~MJ7wVrOqWVk}?SePQ1BK0wO_aZ2j`*pob5h2%4g`rE%B7OWa*~aNw{0B5m36UW+6JRQ z>AS9w&jg?Q*Wfqh_>zLTl-!a-qC1A%G$bAd_KGWX1)uk`3kroDr2;a4h)mXU1%Nd? zSPUz;IId-O4cacS?qJptgtCRxlAhlbXc~#LQr4$l3w;eRdH{ma#He*KQ}HpEgz8*o zZPq%U;Y(*c-_1s{u^yPHOO6d8OPe_{Y}2kA;7vb2d{i@eZHTENiz< zI|wU|Fza(=GC?<0S-|3d5Z>On--#}Z7{BfWlZfDL$kh@j(JmvhN|?FQmV(g$6n!Oo zMhQpRF*)+jw+8WL)Cz}@fbWdkKBCR>ZAXSbimshlgl;>;J$Y5>k_}$V`m;MY3aV`V zMo`D`Hh=nb>$xUm6%cd` z$O(8dvVmJ8{^ZfYrcp}MB@=#^?Ais*tph_?8JW@=XtM!}m%lgzixbJT(!{PNz7g_Q zev~reKfH=z;6TsLncOQFFQGLRjWFhpruEI>W;g~)bQJ$yY%*}O`G_W@H&EpX%1~i! z5KDKx61ZrWuP6e4Uv*M@it8mDlFwek<`Jz_?_0p`dr)D33zY8sL2{`wisVMoh5`y1 z4Mdtjicw{I`HZp0JPo>QQs*M0cN|z2Di8p}AeI4qE{<#D>8>9sjNFz#iU9paz$%>Q zpM8;Vx(Ml}MRbbJ2I$~D_;jm^59jrQ?ejXdiMgTH8p~^cp>^=3>@jp2Zogwrq?HA6 z6nuhj;=GF3K-ke`2dZ<3qqb?1n4NygVy)N$^k&2f#V4En<9YhZkDs2+0T4z4{LR05 zfWMa?{aBi9dgj;nVJCV?s}W$<^56+ z$;3|6uIi6FcVrH3$<^0p82dfe_+h&Nuh_LXTk|e%oy9nBaLL&i)@!LMwd4WL6?}LA zeYe;V!l&W6wR*I4Vv2WM_;4No)<&_mw8(TvDC}r|oM+Wv#5;c7pVRYFAed9s^ejq^ zx9<~t630akl?eE>byW3SpYDx>w-ke^5Jai!G8r#5p0~Szvl(Es)p$x(((~N4fnE+G z{GzdpXT8jVN!VeL=)9q`nHlCU)LcuXqBsN0fh%$h4eSVz$ni@Guxl^+STU`tg(!%t{30V{JuQ6PH?sGWCf!=6y$GYKTzrGiv2KMEX zeyVtv-~C2fzD&XOTGpz@2p5SQ1tQZUcD-nSV;vTSgV1AY*gEDpGb8n*e>jwV@0}fP zw+!Pf5qw*4mqgKTi`t0B8@5nk$CC1&l1H0`Jh^WJ3T0`|uAHAyyoDdgpCs?%m4H=8 zmAr6p>$#U&Y@0Z?So_o(PSn0`gR-~-V{Kv04OM3z`uz>WgukGRlUaPmuIO&rH_1kETnnzXLR3)vcSK(z zNU4tqg*b%WwT;2MfP2yfAaCJ4jS%7h4n1YvbA&9^j)?{UJ0q6JHYx4}B*>MlH!z_$ zw*4{U*)<4YIZN_2D?8oG{ypUoN}B0^4FSAn0|Fpe?~83QL^GZqybb_qYl5@>$jmuq z+%4dPkOb{h= z^(2&I=hA6C5Hv(zIk}ZVBEM5}WX+#Snhg+vHeYo|O}{6l^;b_Ox)hzKoLp`_U&|x> z%~>#zW}M6qE4Vgi6Hgx?d;>6ln!X9khUvexb$>6%&0L|XeX2k+kP`!Tg>@it_j{Fh z>ZO|2Wb0I#)6B^Xt$!$daquh$jWxNg!ICxEKztE5=?eG+oXzM3g72L#b72JKnjM$R zY#-sQ#5W_npC^yiS7%}7@xd|;GO4D_ns;7TA#$&^97c=DWRUcU(#k?A*$UZxX7gHKk9*f{Q)Pv0)$ zHfM7OOTbd0l@-jm6;dVc#xv#w(-fk9_fMvm)bm~{qR9l#e$eWF2NNjk`nM$n^XQ*x z+3H^dtUqFICs0Fgt{JK%UF&bYSmGB!+b-P~v&TeiG+|2Hc+ne+zlwAm=hi!!4gW=Cf)M1ZNFA>MI*Zfdpg7QKepAyP!yokNYwcOC=^<7D$JIcQBK zPBb(vSf10UOnx%m(SJV#qDeP{4)1j8&>!tHhF?TJ;HVuyhqUh2kwC}WI(de9U6HDGE zQvQmge{TFt0+P8p1@x1Vsi!u-vwBk!T`_2%Po;i@uC>4T&H}TuG^z!{oK(YZwNlAK zRW-BM1731}>*)jVI))nZBHCIml|&+WlXWsZ)y@doe2PRhy~+ylx2V{DbKNoZ4#rpb z0`HBLNY^SUHqh%>2&l1)qus!H_X0*f0n62Qu#45xq4ttT*xY9G@G*?zbgv%~s`F2# zn$U{ol?4!9$%t1(l;0?i9?YG2amAJj90wU&Z#Fj;BEsu zkc?A1l=)+jKGBF2K5M_bzH)5{k?#I}*6xiBg1h%?C{psvSTL);s`HJ}kjt`+Mk2Z) z<4OX7ujhaju+EEECxmuRl^FL6vd)gS(w8LQgiCwtV4&)U( z#EtM5dczC(XeRDogRu7F&73T3Y_p#G7LUkotJyQ}s$!?ip*OxTkVrC6wF(ERo;etd z>)qoJR&q~Y>3lPb!**Rcg9g8PWoR#s+^l?mG(nV9w3Xe69fHica{k*jxgLs#m&fA;7%0R0uNqOsW8jZL=(WnBaYrR#S>ZCsw`xG z1m~ehs45mFUtk(xQge@omOSKgL}_{U74cWP3l_3`KvCtc1IM({UoOQC*KZMm2YjTX zx{EPt*SBEkp5eN+->!zK5~CaPLavf)KTEOGcszwE*k$YMe6$K*;E=TtZ>cugU_c-w zG>A*e1GVE5+f%S=s_XdXb|r+sJkZ{MTAW2%yUfWGjgxzhnN=4w`(pS^F-SGIhWMGf z`1WVrm${z%nc@3OI)mw)HEyF)w1C@DGkt5hJru6YdUfyMj^JtR%|M!M`WrL3S3#83 ziHl@Ghs5&owLJ>&J2`}}Sk^Tn3FI@W!Hw7F&N=+bTxwz55Ll9}y|1QqEgH*zN!AA> z1G2Hk+RA>8;tt^YXDvodx~1^4xrh_^1~91rI~ucT^+$Qcr_Lp#bJGJd+VL3zDDfg@ z5YC}zcG)&6fu}pw?3c|%r@vz?DMfuO1|*%&51seWPa4481!@&Kt6E^gQ$?H)xv3gG_CxO=qc zGoY%V5ZwCc09xW;$ub%UOPW&CEw@Z}RxRdjVst7%C`(>=Mm{z$Mg%co^KFZP;*iE#-_3{aJAIF-Bz2z%;z=lf5gCs3NHfcD zePYA@b4x3JMFvGn9dmh4fK=#hX)L7eBWTiYJq-L4+6>8};F_v_gU z_*{|A_?=SA;j8mi&2f^3>?w-KA;qYt)mvDLM>DX~cP0X0C>k#p^B)Zyo&eE~UPuJa z<|~C?fyefvP3V%H7}eyr6BSwGnTa=|ebvT}*(1V?Lo-^vlxj?Sj8Rl_GIC05I>F1nR0%#{9>Uq6U*dblgfm z9~2zQTR95!*#iB^_>pG|gOhlobMQ#4WKOsB_SNFGm_a@oFVxEwTnsSWWs*?_P@uYq zc78psAya01eWd4qjgpGe;EPVmGyEP6Px}$jtI`36o?c2c@2=f-gf{%>-)BKm$|U>y zRZl2^DRxaj0b}j!RjiS0bCRSSaT`N=`gTzu;32f|@-vU2kV-2r(sHj7E*#f%>gcK% z4Z7QOJ^&631!^ArY4df|Z3_JCuQhP51Bc~m2&TyoV6;qsOWvnh*V8}$6n0x3)B%z_@xRoJhy~q11Y{q-KAjQqB1$?;Ad=Y$RY){V$k(gG-w12>T!dUeskuiW9sz~GYUB2{)i*&OY`a8M->6RB0^~90%H9ystY<;h`v5bx-e!!5y zCo%nvw(?IWC3XN)(qB(j4IHr9y8U-!{QJOWip}AFuqpa`h`)C@TzfOblKtVK@co@X z5mOz>$DNkGp%rdzJE7F!&?TT&zX7%s4N&2ZIX%gpQf`^(E=T< z3Z;H3b~4hvsatzAotXLBD90Ypv>Cpz0+h%}!p$N3QCa#;uOYde*r>WXHZY~o4X_VQy8t>T>9Vg zz=2$C6|;tJj%i1FOx8!b+TKQBe#Pn|yqUh5RB+LXX;{~{w}!bP9b?p^BsfJh&QoaF z!lo_o3s9o+#C|u3F_>$c)g&03WzjXd44DE>dMFE0ekKusub=Y*uDQD1n7-+Dyz<_C9}G z78|cI#P0yTVeN2c_?E++nU?4D5K88OnvsuJqD- zZqCI?-&1Q_MAOBv24Kg_JcnFaztnH6b-Tp$bcdgRBNb`n^akiS`3VvM4e#sb&N`Zx ze+Vg1&r6xGCgO!+Or2Ov^T0G!s2I(N3=nKD@JDPqkmG|Ic>;nB%qpP0z$Bf>Brb&M zop}fzt84SRcV)LuhM4=13lUWBfiY^J`yxCnmaM!+*1X-I`&>2+1k+_1^;`z;#FY|8 zGUN-Foc`5HC$+4KrV*5*;0yQa?fGYGe`?Avjb#b61viY|^{=;1iU$p{)HAf^pKVYT z;WT-_WALrz*_EeOLS{HWH_riD0ZPB7^*SIo{@kqv%wQ(vmRkp;V-&WstCs_d6)mmH z7$}uS%iV>8A2l<4^$x#dC_D836cvswfJt5CCTCBxm30-jfvUo38(BXmETdjIpAC{#kp*GZX^%dcrA%`&xTqwrE;-nfEQsq=9qcVo z`9Z_x!o1)`+HR+IKIerL3rbf-^GrK!7@liBmc!#j3 z$RwzR&8|s}_{^;d-bPe~Jq61uUIt)NJ(J&UwUJTWN^tG-s#lr50RQrNPF3dN{I-$U z>C&gYtgSfMGF^?y=suY0;vqOim}flurkB*VX_fi}aMc-$l3y*37GuXne<^5n%fNF# z8Y|)|+*4{a18Vd7Z+=<*Gqdt{%%-Z5L2S@74#06 zE_o043G}+7YnIEENMNIqms5^5!_3>JC2uma~ zj6yRYMhxt52BG&+ClEg1fB!Y1Y8WAIT`0PKbXZ$rPP%HI4F? zc<>UqTYU&oV(G?D6d0BJiShVCR-;lsAJE=fzY zL4Dae1~T>ivf4x6YC2^nd5u(hir`YSt+Pj@A&-lftfe^};1a_IU7)4#-#jV`p?CYl ztl01q0dulgYjap+=Wmcw`y2+f9V8L!h7tsarRP}UQn)p zljna3ma7p#&=Sz-_Ib!%Bd8G`HcPjW#1Q7Crg-z^L4S9%aG+8`I0fA+UIWz%F4XJN zUsix9>2~i48M(_);NA{3`Tv|}D9ibSwQ$!{q$5nTciwN>b!?KAvVzfPaW7aWA8qVB zu;d8tb>BuTe^Z6l1UNx!Jz>RA9L-22ofLS<7c?IeCa=Qbre6HExmO(keH7xi&yvD4 zG+w@-(e2@>9;6w|(jz~Y73@S{G|A>);i)V9Yv^>SpGq;YX0)40!A-DtCg31;sA29` zqgzbx=fUOZ+&pIf`Bt1B^6y}|jgmSa-;wIO&$FJyf8E$%L^!S)aAhI*`f$#T&T<0Jt!A1RrQ-CC2Q*cZrp9($(Y(D3!R&$9$#B{`$Epa*twTQ zwkU#n59lWQe_^T?p&nBH;4@|C5r5Nphih(`8_dP~l!Dpto8m^pW(rnU@V2>{etajO z6S1j?e*_^{QZSIA(f)NyivSB=`^JOlYpeycwTV;5G{|CptU2T10m)&D z%IEXK?QhXIR0pup^(fA`Njda#1{PX7>6p%(+7~f3_qr>) zp>HF8rC|`}%itcZD|hE-%GNXvAaJz(s65-Bw4L^B531EmbOfmxrl0Zg!@h4`Ry9fCjVrMu5h zCQ#`^i^#3L*@k|)hOPtI2;brq5ayydQErGTGFt4~g8F&21pKRCm-HUH=af~iLG1pM zI-Cb&1AM|iJH^X#ze{rF85f{wjIJ_`e+cZYRz`G*w!oQKMeZZg`*Rcw*#?#~N-joV zwZer459ya(Ot7K0Yx_z78aMYQ4+XT8Dnx%|aT(ctXlx zDI|FfjaEjXeJ?k!;esqjrTUkx@2DMASp`CNxjl`qXpp}mTo zaJ~Wc^jEx<4N}Vur`MTHffCj+FoGac8RM({krZ$X`tW4cdAt3-dy{<5e??t^wWS_U zjVO@4LxF#fZ!6s#n_IuE8s#JWbpXd>jS?}Q$;Yxg%pm7rXGdC4)JkGHBB<0iHv*xb zhPO66mkER}Ww(O7+pSwdSyAY}GE$qxWhhPZqh~yzCqXF8nI~lXn`>sMOJ;f+&^Uj& zE$tmVZha#|(`^iXewn`#e`o+9GRG!9vbv)Nh4wB=8M8ZSgfID@miu3iIj+}c~=Fp zS^stA(PrVDPe%}HB882T!3AGVIR95#@Nub4Yxj|dSCL*dBDMdhf8#Y!C)0B6&M<~7 zc~W!`ovW%`jwEcRJmK?y>?g_ET*z0KCl_00+(UJDKf%|) z889KhnO?stH-yF!B6Z4T$hDwZ`T*TUJP0aBHmF+s!Hy4GXTJB~ACxXXs}dl!zQx=!}l`Uopz1EcoR)7dmje=LOa4HM$%blBH|E@x=E zEHvNTAMpb4uUxhLqvi63y;htX>1{pK5p?zLU5x%*XNYy<5#qqy_NMAZ41kqsdwkq5CeIly5d{q(P&vTfDCBL=i1Cu_5m74P z-bC$mY1){?jp#uakQX#wj2xJdf-|w$yV}e<3%G|R=iS;3aAPB6F-YMrhKEcovv;Y# zG|h0P@TO^Cpj`-566w4DL&|ARQ`%*KH~r?lC3k7P6AyV}m~Nk>X+hz?&4alOzrIC#)R7$GsltFE&l_MPKP`Qc=7G%1Uy4UvPd=<|uA9 z4P%xY+(4x1zSbs7k7C*%Y4hT8k4*6(#G?|?J>=-t3lQuwY#(D1dNF_LUQ0^RZ2>l^Q56AeR7(}UZL4N%Bwuh3klvXtHOyO`44tnu! zlt(a1COdQHYVT7D#(IeXeOVeF>V(F1im)Ibu#C(5x$XzYsz?TZ4FhjRO& zhr!PY)^_lAOnigkSV(l;rU{S&oZ}U_Y!77j|9a{`Uth;b18=b|3kDfPO@vfe>B`uT z>%2)G*#)kR|I=!(*?{|=mrw>XHJmQ!gST)?4?8Bw?*di8cZ>$odq37=e}C9+f1VUI z>}~%2Q4W5yQW6aLREDP9Q6u?2wLZW=ncH9PMV@}i`=A*C$lzdHz<0_XBDlG`LLS;7 z!~6Kp{?VJu-i-VD=eG!CjZg7KDr=*Dtf09&9K=Z$=kGkNEPkg!DUrx-H62U}(^wxi2bL@)*^~rW?9Cz9;LbFrUPaG?+ z2Fqr(+KbGG_lnsTto%{?xdOVoqZpn}&=1MV5`0~$Ig)W)N2)E=ildMBf6HYR%~2j~ zWa%j;Z3$sWS)_iCg$olCrSw{4z!8L98S4pOQRESZyHEt$GZ-&43bl-+b_{e~jAvI# z0#F8Hr~ZFMn^8Hi^xXsN^0U^Gjghe#7{$_4U%lH#Gd}O7xfjb7_5wa8%!}tQ zCZI{D%nSk@98PlRl{@y}~wOIt& zI7%yi{-(G9A9Wp9`5=U2Q`jKZ4%~J?&}j>eBC=r9!cO>a45YZ*fAOTTB3<4uwA43z z8CBSfO<9}Z`ZAlSm+FQV5@i`X9^4UajRM~5RXdNwW<*_l3I8RGu!mTy0IBZoFC3~g zmX-HlG6mD1L_{s4bTB5^w2S&GE&Zn|I?B*kVhHnxaJbT)0vok+W7DL5tFR~*N8&!; z4(?nB+$+-HOeo7Be_}(DU|)_Ubz&&4YtL~XJ$yWvZ>t)GOKXr#pVZwwpt=CPr8XJxz6z&-g1*40W zm>QIeLXf?uCk>989kq3_S;2&U8>@_m2RG}}f6ZFxb|jdXf21Bz{p!D|%=8i7ki$Mo za8xB|TnIW{=3=qO03tgo$2e?KBHQVd=I}mth*5bF7&}78pu@BAQ1!n8nG9QlJ&xjZ zwfZJ*ROh^8e<5)Tdhom6o2QGzapOIY6~anbx@rl{{=T1+&Eq_hunK}2pmGtMnlNx) ztx8~-5uBGWp?o5Ve*&6NL$S|iGsvS^)$7g=%};hM(TRqeib6hXm$QJC&CiJ~hP7Y* z+2(b|)xK`G;6X<&ksfre6?(yDBj=<*+hh^wtDrZIe=-r;!N{H>|JZy_a67F@JAmkaV$i0U)yS?+XY0Ev{mh&W zgWECHJR%b|DTekjR*yIzB$&KA!K3PRbM|VmKQQKA9O=M+dqI%jJUeY3+lGP1DJQP(!%Uf45E^n#OUJ@WhDzy|lPID*3|WzkWPi zb(wq0Bd2~+RRe577Sg&=>UB+COs3xyi2`ivr{p28!}^=It~OqG9W;Wv1K4^clJ@0x zr#(n*08uK;d4^fW%24S0${ge^(Y&<4G1*2#$oU>BqX1w2If6`8aK-?ZU%D*Zo;Guf zf00E!8ga%!MaFdb4xh90rP(Nr>+uDe8jv1AKPrfaOO+Z;b$P02_T==B{0oY&kb@9z zu??Y2cn42uow>HFdN=AHnZKG%355^4$~o&+fh5t{y@k3~6vA1JsR4K=_mXW|FXyQfQjj<>(x`jWl|Vit06(Hs+2a_)^0|0RNut6#)B45{rw zZ8J)az`YCFqe;s3EGgX@7kA*&A`&gK74j<-mE8v_>3ET}1HkOeRKdX6*ZwOHQL;+& zAlgOpjL%FR4oZap{o-`)4NI*of3|MzdN9bIFUKhF>|x&*NhvOTCl-qQCIvOk5i@DS+HVj=eN(VfYsMKYJNNc{YxS8rOwnC z$KDA+)hWW;r@XN?I?#6Hf1K?{IzAt{$_To98i3e;Ub!;b77g6S`vhwW>AuHf9jnMC z#4$<%5hAu3wDPd_Q=M6gLO4_75N1I#n)24P-6uS_6T3>Z;4o^Klu9urT+k%UFf3WU^2p4ta=iW0{A15!n zSbRMTY~K6yYtcFOy7(rPuC+pAC=fnCS=$S2{HyUv69{4Yr~k6|$pUpt4cv|(5Y^<} z72NY}!e2&x879?mmt%F-)QRKW811%Gya(7!*mk)=jJbjP*YcmN2d4oj2?Pi_U0S;j>XSwm_FIg+bAz96$?(Da0sO3 z>eMBxbKjq;ckZ6v#ItG(sU4AeTdyp5wtn+dV7`S&g;!*g-I-}=Pb3{xF76X>h0Ri(V-3cpmiB&AY-}kW^B7t*!t8JD(2UfoNwN>n{ z7Ip_(Qpe6`7aS#&EW5wBZ?N^*@PGlB*HgvXa%(|&hF{BtDdfbE9P>weiOm1B8z)e* z#ZYs5e+O{TnSo?O7OfFAE{e?Ht{c9(9me5im$Uv_01L@SA-NJoJZ`Peo1wkSCG{PY zT%^;5k5{pG+qle4<`S;7k@%9g?n1&=8D8l~?)UzQ1<5G~&|nHx<{W6l_{#u}tiLrZ zU+f2m zrSgd-AM!U|qI0A6?xwH?lTa7Uh^LkJ1JLf`{KKH{Mh#-2$OiW=KoLZ~MWQxbXnz>$<;2J@%T&c`l7aILMX zM3jURm)h$~Ww#aix>ph@=}~SqkcsP!f12Su&(Ttx@bc#l8`7eDV2>{A#M3!CUuDiWvn&UrY=(kQwp>2@{r`!olt1;>E@f`8g+_8Q! zoPHx`7Ab0{V&3_uUGXg1e?L`lxq7=cJoKGG>ImLRzb*c3!;=QfE&SX;oUl+@cqAuT z*8MG$Daf3qBpC)p5$n1%^m1UqQE+OSLv)a`^$&0i?V{u%tHcWmcjp2V2qMwR$%4o3 zu3!RhDjfwej*qEggo$qOO0og@csdQL60Jn>kdZ(^Vb1TWV*T@2fAX%f|4X6;(hhg8 zP^qi@^0=G6?7F^B?D3-l8$%Ilzzo!KnQ6O0i|rAWqzw)ioJTSOn0Ho%eUknPhlBT` zDajubh|5SUP@Z&scImi_;IZ15P6&XTrjz78Z2Rg_l1MszeqJbZ@hNl7QEjX@Xp-c$ zGsKqEA1R1(;GzjMe_9vDcF<4klQUh~$;iyay;`CrhVjY|r!Z~-d~w(;5%*L{soG$- zA7||xM~^8I{}~gzKKR2=c^1;mCsKP88N@7WLtNIHozzUfZLUJmJ67-f%ZWNii$n{= zjAov!iXLEjsNr>PM4V`DRBDE2ZQ|qLHyj;#%8161=^Qm)e^5duybf4c7|=$X87TP+ z5_mSRRf{;@lJw0l(QUDAb9|mx3fa$teHaCLk(`_1HhVnww6{5J4nW^gM(!?lKRI)0 zsYPLMx<3ATVmcN;H$UNaf~~99ECc?xCL_u}ItWWh$9;|+2mZ66h!q+m2-_mkqB5V0 zoY&javbJBD7L_c8E2?s5tz# zLhup{V6_r-KHAk*n5nRWkGO`mo*E94-xAELzmJ(dv`ID{z z)PPoZhPwaPyU)`91QceY!8gVo((&X%Obm;Lf9nAJPb?)@mepbgcs;-dq|ID?h<(m6 z|E4nz<2Shtwgo44$;QyL5-w%U!d>EEnx05V+5KSq8Z)}Nv;dz9FeLbH;x1r41(?~HR zw6vzTmEWjpJ=H-uf@I3UJ-3W0po)DC-A~WibJ3l-4@ziV$R^Ib3BpSoQw6U@a;0$6 zhQCGi;O51ZpOr{4C!2b*h0oR+dLkH&IJdlOHP-hRr>X!Q%mhmBvvIo_w&$Qmf2te} zs|Us(Z+cZe4 zDwNmM08albyDJK=EDRV#O*8*4e;o4qzgV1BnxRB=4qFXyA^%fFN(8NFJqZWAO!t(< z_)N!Bh~9Hl0P~#HT4=>Ng+`?SiIF{~LGN(bQD~&y;FP`_l|gi-n$YDyg_8Sxc!Q15 z-Yr|`$A6()pBr8N7Z-nIdQ`P9AIWH3ac&SX9_`bw*nZ(=fknST6#)F(;ismytPcx;(v0HlM;T)@pWe%!h{(TMm`?SykqXWCrfIv|qfY zL@mrQDq&hb>(HnfbMCqSm<1<{oTnKb;{2a@C=fq6p5ne~02Q`u7LHcHSaMvKlE69F zormMjT6PzUjDA6_UvCXDf2CUAM$iW2FEA0VCwgIt`&=U7J{amg%#(#CsFC6`v&u(v ziZj{jrAW)eheJyixnUPLwvoM^CeK`%V|-U$NwWPpptoCv6KJ+F?m2`f3whUnTY}R{ zHQAi^7;sgIe*j;ShxZ>UxkU-Ltoo#wsqXb-0^O6~VM_RUva9lqe}VU=l1b5iI~_v_ zMBZI!9zqanS%u>ISWTo;W$T&POi8%Onao*N&DR#vjNM;WoujqdYl?F@3bo6)RzB}$n)8}jPuw(lk1;d1-0OPa^gQvn3r60Rs7cbhMSS?oiBsp%(#91jn8A3MM4Q;w* zlnyy5g_aaq}q*Xh??0Sb* zA}V|kQSDT`(hwqpl&oQ!oIZRpUXSp5b_V6P-^oBw?PF3a=z%ShDcX_N8IL6icb=Nz za|pwvdu5l&u8#*L3+EsF{%LVzW)C^bbE#NC$UQ$|zo|I*V*Qa^OQ&1-=;8%yV|<){ zM-G!7fBy04!RX6&l6gQM^lusd9o&AI0{0_L-{(b=H>r(E@Xjx;h=;hVuo|Om%`P6U zW1EW+0fg6!L7EUj;g(lYKxP8S^mxoG;7wO#j8q#JTB~TbvGkU53+3k;kx2kzoAxRD zk5k*l2$Kl?eYmO<>L(;21CAO=Yp>aWP$k^ge@V|hT7 zMkx_S{H#85f=MmM4 zTf4t$nL1JTZx$>ppumglq2=oH8sb>r3l&h{SX1TAfGxco&!@V;P~e8>Cjw`>mmH#51V=7qAIE_aQ@Y&92B zY81A?WX2?|O|4^kYylx698*usf7KroUZpCwID0MB!gl1l51sF{oElrM5p#)k`2VzJfrO3u96VcTu6lcNm7Y<)!Tj z8Q#H-h(fO=(EJC<-BO)?r++}Chcl?;A|D*8(Ms^w%-o<4bB@wVX`gq+f2T%mHQ{69 z#}iI!dc#`|`iG9k_Cb zBhyX2@YPm>A_@`h?o6Gxe;b+!`)$0@O737WCW?s{G2Gqv-dZ)4q0Lq0^a^@=>>!0r10_c;Cz=&?a|rE$9WzU~lQ$B1^pzOCZ!`e_rnfBluRBuD}|f z?*z7E*MAx+Bq*gqn0)iLj~iMS?^~5MT~0y2gW(3icOiF-j(u>p%;zGGOu4C`k^i<& z=ef%W;WKyj=&gKwMxqRBaV%p_J$@`|C#r6W`Q-IpM{lZ_l#!K6{v%rMs|jHXpMG{z zx;YHkh%6tj#?RJFf3D@m?Xx8X)*N9eZyyD&olF+J{PG+S>!n{J_U`KeX7R>K3rJ1S z1|$;b=Dzh!rYmya>p`|o0PHom`tNTy_}9S++$yZFQsg7V`P%K|Tj4n^E?q8Y4@Sm> z9>U6+dT62g4P^V65HKgHVm*Ukq;wI)Rgugh42K3gH0bPM zjO!F3jRSv6e|e)y!m%cIXy(?qZ~AqYZW4GzHjl#Hu1)CCamai;0RYi)_?~9QxGTpl zeu|29@(fp~D(0Cb+Q(xMnv=Fiu)(ff>AGBHXm^kPpTgQg@RN6ry;0cS>#yVSQrq90 z{;>K(wk6#+HWIlEzJqF>ipWr$c#U9wIi-k8KEK%efBMfY4y{^LRu2*H6F96uV63mk z6#xI`Zg`1!&=Z^H>B1x7c;nu17C7`^O#%4txpks-J!vjD56>3lY>?u!YOuEUz#+bW zP^@M9q|e;u$Dc{Hy=oyLy(#_&mzsZo723m{OniV4UUd8vC4(39KUO$P!V zcE$0;fBHglKy6Ro@Vhw;h=_rz7hgOh_h}esF(24T4Dy{tUeI;?Z+8otcg%R&l(9J`NSZazzo3$eSNjK3eq$KHQekLUqxpBmRex`}l~<_X9Ru@K_fCw8>=0QLOhv zWA3QBIGLFq{j5R~B>;%x6|m~B30MHpu?2gB66YMDRoMrkeP*+#gwVuq;$>i5lPTE zi%K}!WT;Ug+&9yhKa$%-Bma`J8lT}P7S*w50tZDy8YFOcENxJIXbIaw&>w6H&_Y#Q zQX$qflX{LLz?07o;&AS-C)wS;;c|?1f4f$$KAR4dqlzD)BgKRm84`}DeFWi{5-T^~ zDx_fRgs@QB+f&$R@uoGp|tyXO)FRsGH%rO4+Y(jy(uGH^w>k; zMExD`FlyY$yY@R}o6It+ZSnhJ8cf2}sFMTOczRV1Yli`W0p3{nrg?;0@ppb$4{9gJ6)D;i1 z2%b}=VXE~klEZ*~+=>s)vEd|Tf7;j=G99+X4fq8BBQEcVCf)_{dZiai8KL!xv%g~PQJ(H}Lhv+SH>aVcIqP_X=GqjRwPEUH*fo>9hcT1erqAMZf6s8Qh9TCa zT^1YL+QaYWF4J{xyiT+%7d}`$9s7N(;8UVPWqWpVCkTD3;4a^kT~bUTT8pc@r^8}k zGb`P@5knzvgE4Cv@b6M2e}_T>`wPA0-zTU0mw2R&HjQ~t_=y!l59NyJ+d})6OS(;V zA!(Pw$Z;ji7`)>fh>pXb3R9JTXPu`H4b6ev)?ZDH&sF#`a{{qge;Fs8I3o_TElY2N6}t2 z(ZBdd#(BQ2S*R5+zUD=Uui9=m9T8Ci;G-9_%S&pjI}*wr04liaAcO*v^Toj`XBw?z zKA?l`*-C*09Lz1Oe+L6O@?o-rH2Ty_i41Fp62mJMZI7SYR=7ut{XFvdq>5}2F0%rC z4Vhf@psblll&rdxFmM~Utlske?_7oF&7h?Ew!{|3Nt$tIhEQHp#y7*Y3W$G*D_{T1 zhAjI4o$IboApfjEWFKuNdPb=ULkV_S(;E=OUq9MtlaA&-e{wl(6iMXV4xXqZJ&i^Q z$Ma4A>>dS8IPTI;R6=#48-Et3mZ`g>7~-okB9l1QO81)xTz%MwrSP*PP26PyA&&MM z!d+>uWeRj5*HD?;)BY)g*8?V<3rH(Xj( zF5ZhXIhp3YfBd7CM@byH@$#oiMvjPg&j21DSS-HBXfA{Q6`;hfERHB{8@KNQNdLPu zXcI?dCyft%F3Qkrh}JBC*X&O8b%z6mepR%21& zJy5OMYgP#)h}?o)quu=|Y?W%+3|ux1yH$~CY85*!>G7LE>n!I>Q8ja5{<$<4k7H1t z{v@t{e@1U}1$~Val^z#DFrl)rk~mPS^veO6mIy^$P)gvzx9U*7X`=3OhF@k3Dyyxo zSm>M6Tyd;%T7j8%QBl5(y}Iaqr-Bn32KG}Y;jxPC*BwA6v`tfofaAj{^S{QGHL??~ z^tDhypg})h{Ff(_O$OBu@f2KW}&T zqs&zZN}ZA`N2D|AN#A=MGMV3UWgF6mc^rdpqv;saI5ZMWsKyd&0*?o3K#nEaNY&!& z);*AWn)Y+rEYjN#Pl^-lBPa9*$bFip>0|v#z2j?x4KITBmm}HfgJInoml8Aeg)9!; ze<%y$1TVR6s)iP>tZ67{H!0RO)b?R_w9hQc{3FQVHHFlMK{E(tIv9;g!X(!HiJs5) zQ64-VxAcu(0Y2cjzNpYu`rKYjLaTi$|p&#}AElztDleJF1^6EMVT{eG* z7JMLBiYt8q84m-f#g0E}V8*3vwI6QD<(KvIo36u69`hoa)Z2QB@~MlobI63=f3Ser zlLz#Bg$SF{7o)Tf-k>rI*@@s>G2;ODEE7z7O`VGVqQ=VBLPWD)wD4b}!R{99oUKKL zW_wN00-7SESr5sx*`HZ8B^{uAF2t50S$TkkvyVzSqj-$Z$vF7Zxr{iegxFI37wbSs z%mY?hKs|X0PqCF=7|&~&;G%Knf7oM5QJlVezv^ni)Z|P`>qy1@}X{Hm1@B%_lUz#(PGr?DV^P*?rbpH)gqN4VB**5Q}ZdkQzA-O zf$=h88n)N(yy0$vU8fOtsr`3k`I9)L_bPs-#velIL>X{Uxn@IHf4!PLr2$iLg2{gL z=#=N&dkF@)oh7uL_6pBv8WHk1;8J2P6kXA9&PmycYoA==ah?DrGW(Gh=opzqYtAiu z|0fP8x&EmL>qaHE`XF_W#nO_cA`QWK4AKyj+sE3Nqor(PD%X0Wo(Y-406yYiYFw(7 z$4>nS8ly-`UzJmVfA0m)MIa>oXBdpHWPA247e*;aJ{zvps*kJ)V109YzJdrk)vG>f zi1rR@!RT1)Wx_nyk;uWL&7e3{sGT@{Y@HvCaa8v34~Zv8^d$CX%900^6+K=R*;(5D zJ#vZ%T?HaGX&oW3fo8{QlpjK^b z&`YkmMC!L1JqHNg>uZ1YZ8A1cAf2fa)l;|Z1B4nI)pxX@csb>Qnm5SZTCO$BgOsZr zet0Das$7XINvZjC+nK;a*E*zNi2?ZcQqalmV<>IT=z6CX+LyK3AT?w68TP){A*l9y zBhP$Jt{u%$e}}~=H_y0fGawq7)pmcAdQ@wM?oUtr=(3K}4LQN}2ummqxyYL?@YlSP zBn@XnHzRjfn_XziLe^kZmT)9D9R$kMCf17)VTYHV~m1K7$>b^I3@V3`|)f3pVUOQ?q6QSWH(%z=FY&mdgA zh4~?-wsO6fV7)jm6jdCb`LbH?Rl%byV2|P4Dep+`8!b*XFt2Ddnc$1ADSi*Tl(d;C z?u2XXP(#fHEVqY&RW-94mU3kQd&sW}N~gz+JtaUk9)$|P;s7?RV7SAfvIm<22-F*I zm^Fine`}oYpvU&)=X+`rFWMypwG(eql&TJut`%x&P?te ze~K0j$69tm4bejElpcvt*A~&mC52V%+$=J>nn$V6HgL~Dvc=Xubh4xAr^^BeS0ZRF zZyr`*+I#y&N#Rr?fvHGJ&^(G5`faJWrwaGCHT1TYXNq*rJRK(PeR`9e!H3hg#>YIM z|Cfmq!XDf9l0q4Au%f1>2qI2EhsN$ff15%k{xwr`Xs$E1TS z$(O3HH}xFpK4Dd;`;^5R1$B2bu<$a#fhd1cxch92&XU>*c~}tL;K_(KQ$68@Y!}8a z<)LDhRsJXmx0~9r#$P^mcjn5PZ0oW3+ocUS=nM?9ux%jBpM!q#u)&KS|W7FE`gd89$4A^%nqDv8e*g&`C9DXOde;I2@ zu;g`fzibDbD~#YVNckd?pF+9SJFA~%#Y}>MKDHX{3}z~eH%i%B5RMS)$P}hc2-N)k_fsD zPW#LUgf~RZX!U|#ji6hcF3{_gj=hkB0X#l&ISzfz4nce?%k6Q}4Cc2IfK9gpn9Nn` zai32UF+`rlQvMEEniLT#Qf=t+$q~EM@UE&J^hEG{^1DigWZh;CN8A-QtTj}BA2&FX zVV|*f>y39Dy(_CN9(YQh;ru=H!FNCG#2fK^F&4C*)G;#MPVJHGL+!%qI>j@uK_98^ zfFG=@p6UK3+P<31=~d^T=5SY82CJeLXHQXSq4D`5wt@M7hzYdKi>S?Q9~O8dKW^G# zq!wmyHm--#Lj&E~jhdbKP5q*OnVF2(Rq+h|fj1k@o4|UOQ<(+t{A?$0P z`Il6$5u~OL)%oae?(@_%$cA?kq^2#aJKUY~I)M)SrhWt?30D7@UbAc(dFY{$G15Zr zqH2S)x@Sm2G9~v@LFLfnWC3Xg&Yjzw~(2goUXqv#1a$0Vjx;Z+q3ja~`s~oB|Jj{h@|yT8&$i)i9e` zadMuxRC>c8@bjTJ+=*jrP@zzRMoy1u+ft0bz3#rkaX z>I2#B8WyhF@YK7158gqApy+v_tZP65((|uRH77}C#X9Ci>p$b6(Dw@sfnri1&pLLM zas$f4ep``L72*`zXK0l(tmFd2p*zlGfDTSQo^)bjuJhS`)Vh?gung{G%YjOI22IW;kYnb~Q@31TQy##32*6uXupnWZ&mN$6uR? zqC$z_iB@=0qK6Y6_eV)wv!qrnKwk=FxVzyNb}awPynPV2Ao7{~N#kU_yZj4{q>xyw z_fVEAZc{c)qfkno`L26uJH{pV371-(v4egFpbc$AR6obPO(w&$EIw!Abhtvon*uP; z$WoW;{1*p*0RDa=0ytk*lA?6vmKt7;zSNfwf(`0QYkeN;@#_b~N#H>eqt;4%ffhl+ zY`n&#fr){UCBhJ*`ss(q)+bdxpjxK4lP!LRb$t8@P|H%Ok-`td!OE{OV8wT-GVq=~ z6+bKgx3mlbpEkHKps`L!WWr-2QiV)u79*M$V1SZ;t%80T5MYNnAgeZCM}hhB2&&NH z6=QWFd3EGA$mhrA|El~2-%=(G>0tg`r1XRCmFVTl8z*A7rIb_woK|0bh_>i1vs0A7 zV-S~|`&&-)zZ#LxBZ^te+fk5Y^n1}Jtc&Kj`)HCMF6%9_?`RU8ZhDE*RUp(XK5q6p zT!0jR7gWO2lWKN)V52UwgHDs2yXK#7nv_CdFpfGX{yh$8UkXL4aJcwHLU$!9W@Xjo z-(;bRRTL^^cjzBOQ48DRiKlubj}w+_A9TViqG)&ayuQsB)wjwA@WZLwO#a^veu74$ z!)+bGle^SQWWe2x#Z%pA3`}1Q7bFI0j%PA|jy9*K&2r&}k(b=U?xB_sOU!DXIo}|Z z?{ck&myS3Kl(qr$CffwZEniM!k%YeAzniMLk^B}fUvB6;Xg=fE0{4}@2`RVpB;xyo?0EwwVPpkzmw2In zWdu9PQ*;hR(B8Jm&ia$$6Z4Lr!DFjgnT;leM_NfF>D*VB%a~efvV&i2z(aAe`t>1E z4tgo0|A;g=V2H|&%mgo})^MZ}CbQvdKptvXUD2My^;R{icJJ$aj1}%zx_Z5H%%waN zw8HZ-xHhnL47_U0?a_F&^?v&6>r5GccTES(B_I!6PY5j?cL!U`?vGCD1GXsw3zN9m znstzv`mYMOwR&87e3+OOSw$%JDFmuO1S#^gSo+*6$GT1KLpdL&X<{kSpn+JUQ<2WO zHXTAlGsLfFKm`PU;#7%oYfF;4{y+&{ZG4L5Ah!#X( zr4?8IP?d;j930_WfQ2`Cc=fU$L1LC#_C;IzPLrVHB{N`dBTotb#6bW(la!zPg2phA4y6lLwNd3If!@9m@ zXK0>ETk;he?Utk@rYyflK+}kCRKDnrU-S6K6{%8E_jXsS{J?|Q#vp%xB6}Z%?lrd2 zTGzYXB9087Pvg!aHj9B_?2rnk(c~UAlj7M}t7C z{ES{btE=HMe7lR4E5!$eup3UXr+z}P-2Q_rv!ubg6mXIBAk&d%u6oBjuW*WzkH8SoOQa51 zM#5;~T35c$FO@nipnhGA0eVI)s0AtQd>3qm-tvOF5?xEq6s^=yUISJ4c{a|Vs zJXhgrav9a`15Jnj$wQAH2;*6}o520~B`#N9t)jV9w(KXQ%#fIWrM%2l^@`s46<)$V zq1s=3k+ovf{q;GopxiVh6*H+%ln3u_-0$d2B>$814}7By%xiNjK=1uLAM1?I=lZdF z3r6axyWY3+0F~8fnea7{lP~%^uzfe%Y1Cwe5#L+D&0U;@BBinNqpY-Jqppt})@al? z(DMf>LH!C13Y|HBxtiEWQi#4Y6tF0>zB|}55&W$Bsw7oZko-O+0`k}p=O>(|6;HuI z>(Z(v?f|$l)WR4HK&}Lq+I>|i46={&u*4@Jf@XVf>2F?F-z1edL6#Q$VR%;oAx8WUy^lWGEmJ2VrAGY#;XWQm4*DQ2rhR1mbX}0G7 zj}j!MO)?ub=Ikk$#8)f5s7f}MO4RJ!UCAtnR5Yn={xDH!v>Qeu_I3NFyvgC%&p3YM za^Z>RxuJHlVU1nd5VgRf*kS?5Y3hxcK zeCWsaO7zoz#&*!0ll{MRjIS-8&sXUBr~IbzT7Tas{^$qHaK3>p22Sj6^D{=RT`rO* zCjj`3PTI3peg)(bY#Kn{so>=DSs#JAo^JTw{5t%> zBlu97qOuM*j%yPh0*XKc>EFqB8z9$s9?$A_-+FO>FCt(OdfxKYR~Mg_pcz^?(O~W zURCNE$0S!M!2qtTZPxGjZ`K-?(mdG^iOk6c~b12W=!MS#S-va-y)x~ox zNoG)g|3?X=__lJzbG)`7>N;t`?IuVilF;WtM7AdUj6c+JPWf9{B6s!9TkUw#1ZLd& z(-!(j%*WcvZ_8w$3EaqL=|Z$<*`z%H_!^V0|p@D_1$uRZQg^n?2&Qu2VI;{N@`SsL-DUOgDgEM znewxULSsGw`$Id8`5y$@yG*JaDC*ZwFIbqt+j`2;L9EO6Yj^K!b>kl+Rhi@y-ltPseeO?nbn`eMW5n)%iqNzQ39pBYW*wvXo?7Cb^bVC7QQ!-8nGDtVC2KT(}2L+ zNJ)Cfu-3PD+3rrd;5R4=lu!iNeUWJy9Ft7L+X$^!D|)ZD zwNK|RqO?!wPAEqgp{2Y1Oh)Gjyrz*3L>M^lhBcMazM~X+%8tXq#%CIb7#f$0+Z$mC zyeho582m9!SB}*`>Mld}Z+#eR*+$0AXV90)2BB}~7GJNgtrXf*CiF);!-^z-@7%$3 zJvlYiLadV!E4qFtUpT(7aNp30FAHkpCh}gf+rTm+@+8(tNQgIhTv8Z595h}JD7emy znS_&$_x>!Uu`~c6rJ>wsAG|1!WxC)(ReQ}1d8aQL@oTjw5e)qcNyGu;rKbqfGWJ1d zxjn08l|c<%)!5?a?W4&$u@0nv-YTO$j*W|L3-Iy=HfxA2gj+%D$6TAGeVuEPYGdrr zbIsRZp#Qp`lJH7+J0oA!k20!_DM9U9izlOD|2$ubJqjk?KIYIskkLLS)!(v)g7eSyIi5{ z(KKRR1-^$PKtWOith72`$?x9ImE2n_+-oOZh*$O&Y|@wRaMe9p`v8(sj|YdhWl#u0 zC0OJZXKu{eGJa@|e@5JYT(I{KkJn;hK)6?zNQ0O5uyldg`HB%LPp0 z0;Jcloth)d?3PLhGP1%Hh_})>Z;c+=!&xx3HRb_w{*R_Sh&Mq$6$A)!vfQ>`%oqh} zkbzo}KhNwNRtXDZkKEuS#pMG}-YF;qpZhIlem&C@lB7r!Q#hV~;G!x7swzskef#>4 zNCf>a+L_Z=gc<4}mef#fkhFCDwE{iQzr8t2CQ72|dZx&}BK#!hksNO5z%iH8+(A_` zZo)szjn;2C!5B9eKabEV({ zYb-)IAE?9t@1G@qxonLJYocXixzwA^)7&E*aXPyR`5i4Eca7oZKT!|qhtx=ybTmZpDE0=LhvA?P&C z-1Xy(GQHEpxO3#!7%OvJ%b%LFc_CQWfn2}k4K1R~+gFc&+}d~y*ExeKm&U={)cPq& zph0Z`Bh3%zd62hg3Nq90*6Y0)0h>B|U%sgF2vNCSP1~g>CR^a{;AJmqY9}e8POp?L zqZVh8Hc*xU30!*`7;`$disp4PkiZNak|?mJYh`uA-30Sa*pB7&0@knwqe4X_RkD@0 zOkwOVI84)j!91$;D&xXm!g&wj!{TKQ{(=u~^1dP$>JI3|v6Klol5tT2l@0MXh`37a zKrza~NE*`pZ>yy4FmD<5hNT8%aoWuZUooM))dlh#Frp09vAw1WyUe{%S4k>~9PYhr z_?}+_z{25DI@wTCc6tv;{AVU~eV0N5Pd(LeW$ns;Q8qf&w9xzer@U(*J&28li%em{ zFXkuKxYH!+Klv9)JS8@&4m$plONr4;k zx}xawrLcYHCQ^dygF}mBL=7NqT~De;iR$Wik7MmPesZC`3Px^a!=rbY z0%YsgN~yvFQ7LZH{~$rJNIOPq@u+i^=veZ?vOZtcEgg) zpyq%N;KVsM+0!}5%wr%Oc-Oa&Z3!^AhpE$l;0Bk8VwoS!wG;kP!RxvF$R#}ND(uHo ztfqkC-@C#m{ebGhsrwKwu{m_a+MnP26s+|LO!9|06t-{8Afxb|6Gjw&X1nt{fBV&k z@#8(sp|LN3NzW*}Q!=*ibIBy?5*7Ekiz28FqQFHPOzDHmXyis0zjStD5A(S?b2zI^78_dUZI z&eRu6@t`%fLrUx=nGRE_)-kDdP{5YW5v><2p`yy_xawN>SyVbXt&3-n9nwWFM*#z|AdTxUQ=b3 zucoJ(Dd`Z`h$DIDlf721()NBEwxy1mn;5#1<1Fc!h0B>&30pu*YQ}LC!mW1Ji4hed zG?-oW$hrSdAt~rUGR;b!_e(~pI&t$;I3sXNepY-FTf}C`Ux%915uvTCXdw-dL+*=j zW%{8H*wt%_dc~qX?28ul%owD90los&rvDi@(|-aU<6evJpZX{B$&Wv?i9F7(q zyGEa*FFA#_I2=TrhhpdukF&vc+(x+Win{NU`rQtHA}3a&EU6@-6CJr# zuI#$+6j{Zez{FhJ#LHjusp@O8F40a9$H>Nsw~+4%93gE@W#bXAEHj>eh;jvR;*mQw zJspTcQ?ZbNz!C9EA&4>|;v1d=-K%4lHePlvWo25l?CXxpZnwBn-AfxYj*1hg%_q@c zY@DYB?~h`G#l$hDhefdXW(oqhYePe9VkpLvB(Xyb@WXU!GNX_%g#(Qc>`Gm$>rz(5 z($N%Pane3%>|>T^XH-akK5%iRnNJlV7dkHNm}!}eO^^;=7(T2H@~^E=S%N|S4L1%D z(tf2b0ftfUXmvm)$z$olw-kdCR+_h;vF=JpKa^iLbv&BRQD*$N+IPh0yE#5kw%^{X>RN6lcI{KN!rZ_^(Tirr2>1|PLgUTb6%r=s)_ zsLdIPwJ%f686JLrb%^J;hNu<2zRVUr4R)auEnWH&_)>aCokxEgI&OkgsK9QKMubhney}g3sD{Ugb&)5ca+z%WaeZ>5^cdMHiZN8VNqZVj zN#SE;Ik7!@H#8l`XJU_9*B#!(gY;C?=*XtwC4G!z;pRUo0r0(fsmOM+}XwRb$WD*{txgi z6B8pA>UaKVQ%0u|m&n7((5mdceG@gwu8hPytgrsEK7`o4AevcphlndH&IwHTAQn>o zcMc{GwD;-TALF+>6=O1V8UWyw{2LR-lEz%BdS91+dxupm^@iS@y4>q6VrSsrU&I=A zsSMn=B`C+O9u6T8@di+kc1`I(`qRHW_fl@T6ZcIaV*H-uMX^%E($jh5C45cn?7^Fx zY|_AGeV=wtEg>aF@AM)ya{t7Wk*j19?mq~F5YqXu;{A>eb^Wge$1kk<>%b)J{}=%Y zuBmc=WZ7`swX+XcT#Tvwf6BoSsSZoM7=J&ThoMuwlDYTV`EYT`W^K6tH4|dl zlyYy*6!?(3x8e&BdRg3k=!S2EEW}Hfn3c?b+pv9RUEvnpV>I&nI(bY4|CZG)ePG`l zJP&{c$Q?LKa*IIv-nS>G0GX!(a3Mq8@hBzSJb@{QWSD6N_ zdSRYi;QYWx&;wM@s$C4q+3P6?l@vmRSZP826zLXNVOD7e+6ssBesjj}V4R#FJz>#* z>NbNrl_%oQ%=mxnN-uU~!4VZy2CuT>L%X|`;yg&k94?3Jv8X5wi|@eSmG{xG=jN)U zbrrO2`1C4l@@ZxOJx`PNwn&OVnA;iF@^;ewokuvRlcM#n{c zr#t?Lg&a~ELzFZxi^HmRk_lD9ItiIemcw=l>^J`b5+XX#e4V-UU^>gp#G{Q7zwB48 zB6*VLbZB`gO9MUgobWs|I@BX)NS+h-gWhfSI15eEl(5>y-dO$2Xs*IKKP3x)shUm} zEF|%D?@|qIt8RwR1&1}OU>-z2s6^2Ap%wW^25KB;Pl5G9iKD4~^do#pXog71{&OQ# z+>ETfBxhy#LHWKc)2~Y=9HrhhXSEWNVfKwne{1x|$PSoK&X47K^();HcC!_tQ)2bj zi=b2j`wV3UneokFwXC8pLadX2Moh;$Gk7h_>+!qepj~0sv5o*&!@yK)Ap=@#^vsqs zmIz%a8&Al0puWj)ns7bE`*CAeCQ?Mf5H5EIyM>SkA57y>*7cPzL@cAfMqt?3821ck z73*is9d{Q$>$l3t{Gz%0b0gxhjvzVJoEalTv?0KfiwF{C$iU*^CRgHr;}=+V1aQ^I zqB0hLN~*s;o=rzX&F)ZK##1eX7M!a^{Q9JA3;+6M_%2~f@PwfT@ef>J zns6(QKnmNY&dSW8Co)QZ;3suJES}S8^aazVT30lVA*%_c?dU*nZKoa=_qk672wR|K z2#q(Q$Q(^1GvdovikNuvyZrLzV~Z6M_G=Vj(o|oEvy!ExL${imTa&f|2Sp!AF;i{o z4qx^QJB8Ar;^@_^b2FYlXwAMG>>@DFAJp+n$_ zY=1_=gt&k$9QHBm5LV>l8wZQaAD%AZSsHB;Nd!qkJ;+OPH0RbUoElcSP?74;FS;aR z3?Q_XP&ox_Ke73+x_GB-GAc9(<+5#H>8x&DUhI^o+8$U?9X-R?vw5@vJ(lb*X z?9sXNv6@X`|F0W=8sI`(F6tz{B;F;qBpaabnWJY^EF4~Bi*~+0cu|{A|Jq_&l(D2p zLuup{=r!c_M}`Wx{q5Y8N49>WKTD2}MBh(VQjqK1qjYqXxU$wP?$N4NF2gH|h;MziZull-w5^w=?#%e8?;%GLnUF@dP^V!HHrh@x_B<0z^h5B{hsCWd2e%7Xp44Bb<@1+Z%j}er3 z(v8m69$MFbC_YFb-9M8|`hB$va%$WyrijPF)_yYA%nv=a(46977ED%4GVVZKs2K!D zG<(Ze`oP-Lnkv^9xQxj53Y%(J6cY+sbP}x>eYl{bzom`3p1&Pt2{ME%TYl=VTy14z^ z*Bq!zCYY_!1VP&pV3g>_cks;puMxL6af@@+#U!4m_L>d_#^gy7 zk2XX9e^LT>iDl#U22us+zuTRM`AVy8f~&X;&xGMc+^2gqA@M=5STy+?5Mh5s*w-F^ zrqgv$TT4SV`|A?)BxDu51!7Fr?*O!&mnBYr{c4&_&*nc2yHVOF&h5IkK|D}Xq!ljMjQc+A zKaHyX!H}6qP|#rhy=Q8c(H7?_z%;73Nm0Ql+DL#MObIn@ESaWf7m(F@cR&r}H7X3TCVEO!Hy!TcL@6konH0 zVts|hvlIGbTZiaPrXIFGOFjWd%>u438~tlMqw6Q_M1g$VFGw}0C}!<0vXRcT9bA2J z^t`2U*SA7@xd;isFVa?!TU$@ev$7tWCpkSoZOFi_B?*JfR(fy4s~}ZS?*+pD`v02K zighJ=;%e^qNCT4S8X=-!l2xmJ9Rc2L(ju|Ngz902IG+RF;9z|5Vp!bJyLZ%2#cnjQD951j32&c6_z&9Op&b zqEN4D&uyJDtZwp-u6h1cr%0lK54n=ztRho^1dsQS)68HRka1PJ-sdBKQ_i^d^N2We zC2Pze!WMu?DufHBSKY66*#&%m4ntAjk5jK!+PgZCycL?EqHtAP&n(Y(OP!wy(M5&& z?UZTrKjg~c3?8c$_yZ^>h1btRMQQ3}tbTAiTunuvItr2WpdB=~Sz&ud$fM;6K8^Ex z<{ABvwu(hexv6cMAHTYPhQwWj3kk7=OfHeogl zR2e1b;CxwG`z*cIYxCFUnu}Ju5^&mE;lp1)H)@8fn$H{Z7K*c^k%Y24&%|$byiDY;c#pSS=14B$_ zjCU_(mDi74JP#~6&rub{GM6P+qdI!v9D}I*NT6thLrW0ngX(ai|0+q5dpF$P@kG7t z2tV-V9ghjz!_6XpRhy^MLF=pab^<~2LvIG$Ymv*Y=#LyU0jNK)1{0#?SWJ1oW=Tiy zNyk`+_=GFQ*&%s|&*<{&mN}hPUsH@y@mTvjyWoJfyl|?os#j{LeKm5f^(-4>E*$5J zmc{KVdN999fL%Wxi%A>!h1M|%)FwjpR@6CiX>>?i(m;WKIydftEB*`-K30A?Ka(%c zwrJ>u8Yd9coxMRJW&$%D+O|_jYW%UKz^RYS7r+u!6z)#? z&L7jyL0Q$PrK3N=SO}H?!JEiOF@p&;*~f-qIL`#zpDMh9x5omo-uk=bhNSOWvvDbv zOI{mRve_PgZVA1~tVCvV=fJ`hWct2dc?VZ4xoWnckl^_O44T4M0xb9Iv!x5fC#+j0 zDrc5r=)Km#j-5om>84VW@8VBarx5hU3WMJiyQQLOb6?kzSL9f2W>f#lGYI&AUZ|;j zNT4;rg#)Ryf)X#n2F&V=Sr0CPXyGGi==4S)9GH54*a2oR2{d|1n2*lLOuFG-`i4qW zqE)QE@K$D>jZh2rEarZKpI*ZjS+KJb{v|<*7k#9f^5L6vEDVSH#-sNR%|%?oXBL}% z4f;?MFcYEE-hO;JcluLOt|gOSn6o`Y9W8;3abSIGO(C(|Cqrh{Qy6A_HhYN={*+q&UZ{ zh8fNwYXs(vhy@a=a{o73>57JC0Z4mS5MgH~qAhi|So8V3FudJ$dlWC=JhPOf1GS>; zE>0ti-G?@^H47B+@%-BZZ+bUJws=z4v*S z7PWEOi?PZx@f2vj*v&vybUhn4wi69uJ%q6b?LFC^6rA#4lopOdO<UZZCMt{F?RBd|qmcK9xx0cfNKBwvN=QSL3Bf*W`*&t2 zk!zTzJg@#KFm$F5hnv@>ACnsLtOs0wx+knrK42c()SwbIG81Ft36c-AXn!U+sB!~J zhS8GaZfFjyncDgZO&3e*FwyAejjw3I zzd5u!5B^;TCDx@sEkx~^G2O8Gf;iEKz0=gEUFzXeu(qj$#%4&ns?=|JW@SezrPQ`W zP<`<;GoqiD{^_w^b0}*F*yb{?-IJZc@!k8H9~l@1Q``j!pRDH9f#|uewdpAhUh0Yu zw)KU_2p}oCP+>M2vP!7F7sNw;4Ii%K9#oSwP;h%HDEcSbnqeAgH=`Ny-KW_Wq<~%2a$3hG#wq8 z$-wt+%V5`Y6yP$@;ak6dw|WIq36`_oFO-2O>(^dnH#c~miTD6oe={HYa1N6GdZ|ow zRRyO5aFe9H3o?YO1J7gw0C?yv96Vkl)2POhms)Awle9)`#BH%U_XMqcdj{q;p3R&f^*YXRRr^9(i3+F_k&GoR#Z0xU=0ro zq=gMxmTsksCG<0Y;jx6sTYFJ=X5Ggpv4`g(nBWr;yo26$jWML4P577lYX5l)`ys0E zqo3hjy|e|^Roz11=QiORULN*vmTL#)!twxr68_l{&TCS-3dH#SRH!z?!`{)IexT9=-X+%uyH5-(yzx?z!M>4Z^!&DN{92=ePRg4@iV*$ulbU#&jj$7 z5YA5{8cLH;nRpkLIc0W$>`c@^R`|&@oyj7n80UKBYSF( zQ)pu!D?oXWx?A#G2H)o|csJ}j{K124vu%u%)LmOEYquOxff>L(1`mH4`!!6=j(|$8 zNj;jOs#h$%Vb*Qo!7#HPd}cX@s{%sXC&{`?LVLWm#{ ztp_ZBHmE!-O~Hqaht^x2)F)Bi9aw#w5hw?r_&2Gk(WP$}@wEbk3PTHxM)}2Ku|Iqjd&1-x7olGJqH@N3t9w(~+b&Cg!!Aqo=>zPJ{g4-M^}C$EF^NEfVg z4RvNkWau-Ulj(yDk%TsOXKZJa=WxL8C+>FBb?6C8$*So48TunFtx=PzTWM6?ME0_&k>Ic=3;hx%dc(GJ>Yy`$v>H+ZCGUUl<-k`pch z0k(ej`?7)Ak2-?4#m^O)-KJEz~RZ4zI4)toPai(C`6 z^MIc03mrafk^BfRC{aJWG*;U=Fqgt+xbU=^Xe<#)b#=KbG@(=-z~}XArI@zwgRjcv zKmYft>N4e%aU9nm%QvlAsSNFZ&OAzVeBUMG53hPTsJm`A8$U0&G16jlDarpBsz?nJ zkfxNumsKuR@=k;nXml}o#x#p0eyv-nxZ`6>2=2a24|MuAebKkcJJ$|GlVH)J9EV07 z2iqt_h9=_IG-W=`K?;|cnRo{$Y@D{${4r@L`mmXTQ3B;ow`$MA;1KeEfg%PsCj)l; z>WJz9>#dA(23UcE58UEfNZ>}>Tmh3%J}-f4Y`RF@tJU4XCves!KSWs4mxVJS4Piw<`<)%baF`O6)J zAzR6@d=O$B@*L6=F>hS>e*ossqPjnn45kx#ryN45Y``83&DM2g(GQXJ2Ww3|!D^a+ z6^^VL(dAoWc~YmSvx2J5URoe}qZJFI;ml5VUz0FBicvkoZDB@#--|oZ-vyl=Jt%dA zWBacPw5ABk|sNA)p%86pT@^Ebv=jjBpO_m@7G^AGrBKaoLk5*|ESRJDq z+xYOoD<=zEuvojrrEt;7d%nU(@uWRA^BSyBQQ`Vt$0Zc52^%B5{V196rxg+GxR zIn8ffDiOts@x;lWuJ3SSZmi|~i|=1sip*n*liLq}Jg&xpV_IQE=mWCnA&gGA+EZdJ z;AVSUF2(lu5WXZ;xZyMBqvYI)D|ImwIV-2~oS~>E&{$(-p|`Mw*QGR;tr)y^ZrH;7 zfF=KPLWAk$o4z#ixVExjxW(I(VoM?>t&ApxS%X&@vr@QBwz+Bb28 zi%wpDV}Kyr8o`X@c^s}z!LS@ssxt?89t%U;2%I0XK?~iYyAeso*m~u zicbwxse;;xMvco~0~x+H!$|;;<&YqxQRef1pCDFn@RqDt>Y8OBYqXSe#u-T*7UT)> z!C=*v-h5+~L1as%Q>2$}3rey*^`MTyBB!n3@Vz3;2gt_sw)RhJ5(UrIn!4VY^h%GW z-+>Q?k+2@upHPg85W~c>Du2|N1)F|=IW}WuXv-006)Sz7b$KoO{a6WeJF9!;Zi5^1$T1_th*sZ`BF(lO+5s%G z(5a~&n_l<_=&6Ng%GJaBXEw}J;d7ubVQOCC9)cy3_1DzC{sKNqYm z+?t%~!`+yuxVgblgVV_sU5n`vcx7SSd(Nn;Jy_#pB{Lu&2T&{m(_H?4eLu=@Fut5` z&lk$C{oJ+?hjqhp)nUMKWok#gLX_2Kds;C)^p3|Tqs9ng9#>~$iO|f)u6gAFffReE zozilqim=o7!QB%VNcEkmZ{0p!k@G1L?(gQrlOq8$s+b)6A)FYypp0Th8 z=>)jF`5m*_!#|(T5k)m0s?S?{S_FRl7?aLXgWBFX+HnM6bAxUwme*VZ5lz73aXCZ8Y0sH1R4Yt%@J+5yxiAqCNR7_h2pl)Z>8 z+1~U;qe^0`eDZ$$ENC`&#ocG|ujluL2R_azK^%(C+8_JBh@R?pl>y2K$PTTP3TmXn zEQp^Y6YINkOv9jqw@uaCZ%!LDEssmfB?nhFtgMo96Iecf#TAlUsW_)pGZGd=X%MGRS{az>yAosUkYCpL+qs&T>`bs#4h zkj8n^udvK<4$V=<3uOyUdBUwD{$QULF4OPD2*gAEtgH@qSbNqA3mjJQG@!_Q5Fxyh zntDk12={q^PCC2%e=9PK9p$xjS+@z9CXuL=eu3g3asNK8VOt4F&dtt`p#MxaViwNa zRlm}m$m}Pq?w6Gu+Mzr$akE#en9LoF+uQ?+)!-9zDys#H_Bu@m{Y-x0+lM0Qt=>^c zsm~aK1N;Ya#>%GLxtEE6Ulz(Yv=wEB&VV2u&e80D=*`>^1@=E_QC;z$a8X-Uz|vL8 zt@K{ks~6W*gGJ;`fI$OMLhNPGw+jzDbL%Z#%%$R4@V1qHCf;BS(E&ttgqH3`yeIp} zhf19MN*VGs)+S^MS!g@R#7b`)hht>th^xlA?L zN!F5nIMX~AM(+x~BrGv(aFPeQ*G3t>T9gfcvlwkwlCAhZ3(>h$n3o3!q+&T^bt0st zKV>@$f){yfEFLUeeEofR-$a0(sAS|6rHX!28bhjNb*&G zm)l4c(xFB>AkaWU(T_@29Rr6KmSLbb9kX^ zTcqii-ojlEI9YECjpOs*!kl!%0@Yf7z|VnHHb;xGzWI-tYABh;_vDrw9y?hkVa}(Y zRac8)LG4j$!4(=YDkTgYlSZp4OFyP*BI^;4btK*uBym$raD`jae65_F{9*Vi;U}!w z6>#a(4&(AT9+%QnLdL=;o3cB+6GEMD3K#HgZSjn~NLLaCG z%2++Yd^eYX$wnyGR^K2Nb{@7naU9{h#j6nqfY>z9z4*VXCO3xUz>`yuVaXbZg@}Ua z6fx9`5&))u21RXWLc5>W$e@0Ip2>{n!kB0Y!ZSLrE)LNn(M0PE6)|2X2Txhq+!}ga za$5i4%5?_AP)cm`i?+$~W2jFMvwg_y3uEsb>-W!H2osgTYJD>S$4?&>4i)<1GjqN8 zb!=MxBINoUKV#jTZL??tTZgWNjEmi7({SiW3`rZ2B@Gh!toT6bSEs&zNVi1r5PmOc zg@49JQEMKh>AHU-vW6@wYRDU!?a*`fC`r3=uNO>Ae;noAjcJ z>+ff+^AaPj4Rlqomfg&MD=Meq`f$hvHWF?pdq{D~6id<{>on!zho~uz_E7a{?kGcE zrz4uK&q7XfJ~#fbkB3dOAB-$oP9?jajlB5w;m`0GkKFy;Ba27#K;<_V7Cs-Dofa|#CWSzX zzo@z#-u(Wc$E7TNg;qvZRB@}$0!;HShxAR0md}QyW<;{a(vWBf6Fz@E3ggJXQElF3 z-6Wn)L11$mhX08w_K^+4Ec^rBTlKSygX7{^;qsDwiIM!S+V-jwVWCo-N&bRp!_?I8 z|4SryYDo;2T?TxAvp?(A>U8Ru=}kc5!s$(dh#TGbgjvABalvhWUja_k_F8=E*}|3d zCbAxf&)-iNU#^nLFzyl5RrzO0%Y8k*&kgjuQY$q#K%hHWu8Uk1Lqk3H=mdF`#9zVy zS7Xnua?2s-$XjH`OA5=0grf5o3oBCOfR2KjblQUeKci}YPZa5w&$W)>r5D}TxKYXH zK$Swlw9Y7dHEX3lYbQxvUu zud(FRSiMAls&dX8;O+$bZx!*Us;!+WgZdE&<86)LCv~~c-^mBp%X!n82D;t7JTlcm z)(3@_4*I~Wu+CCH+ex+0-8%Z(@c0-(y@$>6WN6%AeuYWhrbO~;0i3xHV(=t|>d-`zkdz!x2tAF!4s zMM4&H?#Dhqis1UNI1u7?pZs=5C?V>|Z#7=7{=B>@RQSJbYhp6oj)lZ6jme1+zgC{n zgBLFfFl9bd_oJ2+G&UfQ+O2G*9r1LyUt{16`Z8o$x5Laey$sa`7_igf7`xe9`G!=)fT^k?-cx`AVyr zAfvr7e}VjXxc?}~TKK*Q=8AS}xP0#b+xWYt?;wmtbuoCkuV#UC;+U6cZ1k%2S8a8B zIFTxt+2?w1|JWnza(|o{X4&TY3u|w@f0LuK#}VV=6AK8Y!A7MP8Kgs<9IO@YwgAI} zK*+F0IG6pJVu2md+Jh#7oq{Tgf@?yWQNS;1e*vnyc&I^^&B!+{5mccM7yxI1^uE44 z!N^BOrIB^BVNnx$^s>?D_zq1IZqIHr8G(>|w}4WL&T-4A`!q0H!t!Kcncz$1xLthq zp$o!@CAI*R9`KoI&JZt)6PQo(M@gy>MM2xYOH3+2*&zg&yyi|vQp^VSV#qi!aJg`d ze=v|oZpt%z?%d2J?v9-IU<6n9pio-Ukweg$5-3`Xa0dhWPmVLMJZ966%st>1rX(gd zyNw5XW3RH+j9t>$;Wm+B#>7o*L#;d(z!@Kw90>I~sg7Op>5Z4ZGV9&jVW-De(`4LF zz_ToxKyWkkCmo~Wj@huRglSdbJ5f(_0Sm<~)NL(cm(QPMPy@rWmKa41V*=`YxYe|cXB zM_r39(1`dM_Knaln|6WbPgEB+dO#PiqV)Y3Z^=lW%I>MpVS&jjQmyAqeR_NTrW!;- zAc+*h!4EXu{XVKT=0Mh6^M9qDrAXxOwFp|AiG>jy1T!zb;j-WjMHW-y znd_}od_UFWG}8wY`Jdq%q#M z)$1N1?w&t|m7ydOY}VwD)e9^fe7!3zjD$>k693nS{&W5ZoSDI>M-WV+YUq&>6gv&q zE>w3i!i5U%=a}s|XF2u#>WKEj^*~e#=DXPkD>1zasRO#;ILxxW!aW9je=pET9%y|a zF?9S*$p>H%}oT5zsxmf_PvqE;#r{DPhxxPdtg5i0$+niLC{rw zwq8@$98K6gW_BH!!E#M<^P{<20;eHSVJ=)Z!9bedBLDR@^6*+E==X%MbLkc@?7Vv*H~GU^l6e8`-<}D(A)Y4~Vt?m2zT~ zP>8cX8ctzR08*-)vXd~siCwSgBr8bPct4D#x{VNd+&nYs$XxZZ7*sxXs~BT|cx3$d zJcL4^2SSz5i$_?de<9M#ZhLmXGuQDV_RhyeBpnZt5-mys9*-D`dGF7hpjaN}GcI+$ zrTfvi7L2aTeojLkshd9ZD;PFU6Alp~U)~2J6pCLidc4QeWF9XvurK@^zP9{=egnLt!lc^9=aY@gMuZhxO0+=e^skG7H2Gtw~K~I+GG|{ zmShC!DHXPd)etd-9Jueep1}of2uODEx|g%}W3A==nXD zKr7#z#ihSNf40C?w+HDP0e{;IX#-u{nm^=c(|Du#ICqlOIN{@P#;>)Dd3mJ=4N9F1 z6*mpA3#X=r!+{UP-KvV|tq&fkKH4n*OPM$C5HyWsI$QG_?z&4cX^uLL90mC(%ImCg z=?;3@RW(LgR-xX;RnDNSke~i%^&rca&9xXdknmL;f4m-b*@Nq5lGU2Ca8$d8D!H{| zYa?x*z7JOpiOv|$qHF>tq>4^}85%X~*&Q_evhJ@TsK;xyEMCTrr3v7C!|s+BojSt>9;4 zu*c&^IgP5#k$;TZ#lV~j5KX`}6`oo4;0{IDrFEd(u4**e@=YhOccJN{QH849DR%tS zU>`q;A&2`Qf2Awp%w%ZmNI$sKT7FrKY0))Ae`2@McJ!_5R#(vT2$BEo;1D3C2)wN)~SU}m9;F0H<=o;^`j8Ss@56I^kLQj|1$8sDQDpB5lI}{ zgSkw6MZ`%fGhy{ND3iKue#T##$wphiDgrtWFv?5m*)A zf7AX>uI5HGBmO~dj|J4?J1_7jPMP)LVxZ{1b})b5wc51^#Mcj142#R5f=;znG88x6 zkIpgs&$&ZzaoT$(pNA?~mGf$k)lJ6tZ%%&c&~%<%c#UzeMl7Bbmg4gVe1u3HCVDAp z>f)J2s{<`GrcnU_Vt&ih9IfDfe_b{=f7nrx8w4$vgtLny^_X$muV3P`7}7p@@gqeZ zXR=hqnT16LEz#9cPh!P&iQf#C&TAj1{})NPI-^jnUus-ej8RbD7E;*c0CjggvVOx6 z#D4{HH_d54Kjf8RFizuuP-oJrqofw-iKZ=)Og`m=D_PjXqB{8pP#l9Zg;~<%e^%Nz z_^sT5*qrvj9urtufUDt*k(EDkdz-;)Xy@EW?pw8rt%>#kxqIQqj0 z>;t?wjHE%&?Gwzgqnt;YRx)V#*+5q z#lXVFd0Hg)fSlbNdoQe!^=p2XErT9P{s%8Z0Y^BD+|b+0Wb+sDi@qCHqcm*L-2bAm z$t?l%sd_*!I?3NojL$lr2Xn8~egpo>uJQcKeGjz~4nlZTy>!W!$3xmje+H%3gLhX2 zA6TE!k3Ds`1*8yl;b+Lt$}CrrvmW@r%( za`zQ&)y>a^bGq5o4W(0!Oo1Tf&I=-~X_2ptn7hao>u>;jgM}X*e>MBF|1r@><$%sd ziB>>0^}0MB(;KPDKh%tJe};M{*t*k<9Z;zY7L&IwunevK$>?|N&?7yH#kVMfhiPrzw*2T&r+EdZ2^kgp_01--t}JXR zS{}+y**-$Z^CK}s#63kH_|#;cavKg%?I}3{HOIT!@8mIs8Gog1e;aU9Gr<3hfr5=e z!>B494H>9#S^dG}CS0bE6g`6~zu@;Nqh6k)6R#of3FuW0oC2wQl6v7L0PBfrz6J6a z-c}%90L9Kg)?s9H^$XxgWvfYH775u9bm4LMyoj+sj$&9)JjOwh?HvL`T8BEmRR|Jc z2P%7o6&Pl1X`KMue~yx3F5)Bv7vn4Oz0gXJ0zHdcEt-6f1C*fTVc6J&D}w^fHKCMu z9D;*F5J_vb2JpqJ5`urNX6p9vQv!410Dc6amd=43nSu~|0i>J}ZcWQ1$o0P)RBQQU z@ri_Ef-5b7k-T^%vFXW^zx)8CrXIjEVR><$$EBza#7jq=e`Xy7Uk*kkJy>l5f~yMW z5ar=0e38ULy1zR6vv>5$?7gtEyjhms^JDjMz0;)>N~_b;!Q8)vHr>7)<0NERJ0hGx z`QEtbKI`rxs?!d0<`+a69(Q5rc_r9KbYwRtVHwj4m$3#33w|@nXW+d+#1n+;uZ^YE z#QA#*F1rhJe~nP{=e`-ww)A@beol0u5T@MNC#$enr`wNXD2eMe$zp`9i=0bIp;z(tjjOi~XvbsNrT`kG#MN8|IAE+GziTiRK4@L5?`127?*f1 zc(U{DG@3S}&@v}_6)$trY(}sEM`)z{ z^?2Ab6k%kRdp)`$&>y-x#q*PUig_&K;^gwJ<>-}Kmxh|blX$0*S&b@}r7@dlo}<^<3YowYWr}j?xdsQt^Wl%qIX2je9Cn3*VeX_W!jcO+0r#Hj zTr+}F?Sy_kj>F54j-+e$`8GrgLMeHkOK9jCbh3io*WT(?`)9?rbB@6IfP{>5aHV%$ zfB&w_(=PgaR7{}DLe0Gr5LzBk!m1|%*Ae!6>CN~E~Qrf^{^_PnRaxnLZ`M7t! zD<_*vKH#N(sSClwg6#?@uRY152~MQa+zRS!#wKU$d|ivvp>*#*^kb^U*0O0`7;HiX z9gN90PsET8!{V;&*MlX?8l#)L%jhZZf9pRv^f`6B>3Fd7>DhM+)qUa@p$HNDqRP*| zcq`Mdx{zC;o(R9F+>j=pf*~;VIDQNyH!ZK)4eWp-^-NK`EObMAt~lRt%*z(5C+&@V z>T0ep5K}71z;N}%V<?$WXY{_UI(em^}E2v8T7Z^%2X6g5E^Wf9hez zP;yz+COgvg8YOtiAz3}%%M%OJw>;HWbhfftWa-)t*Z|g@9{tiMgDwBbC7N1MXFL-=zbM9NcJ^bY!-T%7dy2P99vRHsN5rY`UR@{v=qR zuF@J5&2jX)W9kJ8E_O}ndA}^ve@{tTG`-9T`kcXC=vR_}UbT_vL!l6PlumGRmUPGH zo&tAvIg~gKoS9R@AKN!Gt5h^?yZ(}?&w9bjWl~AVj?8m}4|J%PD;qiTH$_Ty!JqL} z7z;_TQr&mAAzb?oZ{?rTZcB5hJ!QIE`O$)SJw+g%LGIe_ zf<}yu=iB?wnM9DG`7Yr2+*R12%&FZj-Wt}-&w<9TAi53q`0?H`AwIFFB3$N)11^c= z#VSv)EITyr8kf)8c9C_-60f9Bzq5GcRj2eDb|?21Vo)C!C`ziQ8eI0^F-mw0k#6Ib z0_}d#?rVd;t8BGOVBXiIe}_MFR`3sE#^Esrv{wh#Ki@j94_f9x7@+0R3(oExc3Esn z#w$=1CiEE#QC;>9B$U{-mgBTf!U(*rrd92T(3n-)C82br(29p6+m&jyP=+aSlO_a5 z%-+9{@Lh7xq);I}AR;D-c7m)^<2muojz06;0IcV^1Li&@J9D?Te`9}>xC#-G7{X%O zY+WaBL&^Cp`^pYX-H~JX7mKAcrgW?}tUdv{#`qt2*T^Ww`>McJa!mT}Axp080l*VB z;P^zJw4zS7qJLK_)6vwGYq72su(qb;Zi^`=yLUhwyz$U>{2%!do)4Gz9~2mkG{71U zjIXN^R+YRWVXy4Le~c%dR!7Rq54}5&rj&HP1;9W$XD!emzyPP-JgqRof)V-9c2`d- zf9fHIS8`h&r6k6UymEQg2Rs8s=dYRIKY2i-2?@|)vuz=Ce~G*Dpp6}yTh|CF-9lxT zJP_92R2lk5>h@!ct93C-aJVK8pe-wh}uz%iqU&t?LuB(<~ z%>$K?>KGebqNk$&sT&e=OQW@729Q_&4~btd&mf-z#ABv3Et<6Cif%DVl}JY-J+zRY8y21^@L~8x1~Hp6+3B zD%|hxtc?M~f198?br~@*ogi`&)jt_OY?}61Me>NzpAytaei`3o)dYTT@-oo3c$H>} zxrdaO+&7~xTBPO9izwX&hD{|+#bU@{H376Dij+LP4+SW+=;AJ~`*`a>N@^Owl$LNb8l77^$zpP!>K6^-3XfbE2Y;aT*E%d)IOO6xH&0xU{o=fWeR#vBXJAb@jL_rC zOgqpGEA9Zj$o{V7#7VxU7E#J5*>$rZ>RBIre?&dTqz@w~J2v?}kVr_w`PE%+w;2O| zrzuLa0Pf3|RbK`~4mv!^4ol+_&yEU44NN5ISzZedN_60;LG{IlV&>{YSt0%RECTvr z!>e&f&XFX#lM-q4apd%rizF)3hM1UEOsvm%Om&TXYyFMZEiKYS2HE>mMklGMH>mkn)td#vN-`mTx=LnD%Yi{&PcqNlHPgVGrc4Q*1q=^(E3bj z?YIwj?%3Pt>)EXL7#8m?ka2VF%-I8*u^ez+-@*tuKu`UAP6ka5MUmi9DodDY++-Sy zB*rUxuY7BugP(e`^7_|o>g;Czo^Xrje-&oSlB=9y>U@sHhXkFEx9z~g$Qse)Wm-In zAw(-7_tz*JdvbmNyPM0I{BOHK;da=uG?LJk!gkv+?8>=uQU+6Gx|9$c2DBnUo**lS zVE{X0F6WV z5y>a!Ty4!jlH|!f!T#V%6~{syT*hS?coMKNgXPnkX?hh2>9G-|3!uk@M937tGg7M% zfwuxk__Ij@K#TY1|F+SYt2G#Ru*VD|pK%0M#7%i+4SR^0L13&&%LKZO?WTqOt+ z)hM_Nu;bqT)5|;+BU&$qy7dfgJ+*9G_Hz;+3`LjeOf*0J5#Nj0~u8+)? zcVh{V-}N?)#>wh0TPSfm_jIvd|58tDXqEd;HR|%k|NkY?q_S;J$Szbc zBlh)c8XJr5eerdn`HsGM0ClWYxd}h%;9W~Bagq1`65(SKd%6vd56*2cOdGHA6&uBl zZO^Gm7}Df9JAZs3<<05ie?ELjX$=PxW=p!X_T~;abR!pj{?bhA(vW)?pzddunj}Bj z-et)663usK6*soCp~01@_b9EiF`PAz685OH(CkPS7#lhih>lyTDH%U(Gy?Aj@L% zpLbgRkTeNlOG053rowFSCMLlGE5M5*B;`HFF<3KaIAG*#GhD6M$LA{i?E)G9EaX znk8A=hV_*wpUJ!w?V--bU{s9Gg>2BG3YC%nfzhQRKPT|y8V!v?niHQ|Rs_c=?#AQ zpC5K0bXsY?K!kwX=Phnkz#6v)UO0r*WI%~V8ntWnJw{`-n43E)*=yFyM1hf_nYL}? zvR@J?I%POa3}%)_m_f&Brc(%O;AWCes-G1`dNvkJS z7K5u2mSN^=q8d|pJNotA${39@Wia+bzkAEj?9XUC5?M}34f*}6iwFmbt_~Es9Jz=N zuSP~%XeuZe7vxW1YK>e|ZJkyR)8*wF27&U;co zAfAP5D=Q$u%Y1*Uc+{`hU|{vHJxVxv`_*eJ&a1u=5HDT;9?Z_TY{4i%7ahz5b4AxcqkirCQP-vr^aBVtzd(xrPZcRzT(YQVnb;yObak(uHM$(Ia*M$7RM6_tTQO{WPdMHHAed!{59i;=Fb^dek(v1T{{-v}2sI2mRyKVlQ? zDS;o4woPTrIeUwf(L;>Ui7ckDt&R-;FvSiJ_e6nA>BA`6s*)dlSc zA88TyT?MNp`<)a!CCEzyee+pwQbc8TLO)A5S3jE|_H#?bnD$VO{XNc9`+k#knRU>B zLT&F-#(eE=;}O2YFNa)kO;A1sbAm`=jr|lStc_f|Z2EHT0U&pONNN;PD~vU&w7maT z@p$eHYZat#k9Vs&nY-C!f4?kl-dZvTN{>K6c@X6RwS#;@Z_b9n_#)V(l^(5r)A=(4 zwoQ`)$z1EqYn6O}$7AygHBc)fsw|zboi(gmj$KH$|MAW4m|&!xIr1v7{(@O|Zv48y z{3e#mD>9HWv>Mmho~^TW2c{{O6HtbIL9F}h4z#C2`-0?bYPrfnf6V|WL6u#9_UPPR z7{Ep6eux_*9gv3%+Hb6ZRS1eDEfv#mu6Kf*1snFPzjGX+ZAQVKuI4GQMeD&Q=3DxX zvMU+9x@NJ~MNn~oU8GPSdj0eaR?Q_C%3L(3=}LL;rB9-721WKoRp1x3QM>TBkxe`0 z#>nozgP=B@Gc8X#f2VTfN%|(2Gd87ErJm}R3T^m#w#xljH0H-j;dN$T#(*^@KPiu*hf7Um6!Heo4zX{t>6{CWl z_jj40Ru1mU-K_Brhr%KqxbS!2IAWGrAc9%Mxaw9jh?sWX&=c-c!IYYhx*p%Hq$G6i)0f$6jQki5U2!G`sLQ(4;x2wVejEG*rXbfNJoJ+~Oq9VaYN< z6=~j3(7QBBSF@7!9o+4Vc-~aaXpUG#x8>cFSz<@uSP*!(*_aDNirI>pGyp9(x`a85Uvq&%Ta*XKTLs`muqycZQsPGvr>))h2rRRG%?kZKa@@B4>9^OVfyt+&z!hp8H9Z9sKWVs0-MFF(+XyC+S}I>) zf6jkyAT}K=+Yj#BdibtWR~5veOCUmQZyIkEHeU1oOVT-tF>ryZ^;;$IhwWZ zU^|WH=JHXQ&|*!a;gh&bju3|WLCmtJ`vrXma@WdjZ$3WGv}EuHD#o0 zSkL_AoU#>$Wm!I*ym+ws>M1$p8{+MUbCM{yE^M`d>?79b7mg#iq;IZSPTS*r&0JS8 zO~5oWCQ-J@i1>lvP8o`)Y?83Be?QL*V-X;V)9%&TPMTTPuq#7I&xDj~Y3e<9`4)*7 zCTjl#ip*jebZ})3ibQg&MqeaaHjkzSKF_#38x0Mn+k(3AONn(`LgZOyY6pf30da39 zj-#ipKS>>Y@HPk6c0&C1axYBeLWEjE+s0K4UT0iqkVt&!>sM^=HfI%2e{<{hTUxmd z`v@lS+!pxK$_)Y{O^t_xLc>z^R*qRVI&hLiPWEGc0the=-1S4@YmJ3nzPp zr9>>xdcZF4msq2py+49S%(r2BkBPqE>Mn0q?|qf(8qdr?&z8hsvv`d;F*F7vgfo%| zbJ_!om#KxOdBSV;Vb&E5e>>}Oi=sOl5k+ypML(2zl|d}YO?xOdmqMXlri*kB zFj&?-2Or_yXb4`LZh*FTuu?jn2xj<*_x+Z8>4OxA?S7=lNt4>d^6!-)IT?OcG4#x# z5nb4zw&@#W3w3<;AE8PtnaGK~u$5SO*Lz!(EgpZMV}B>Wf9UfOaOtA@kKNh&HBf?f z^0f%BS|qZm+rb=e8t~!>YHO=9V^gUiV6uZk@PMFEZa}F`d39sER;+?mMy^M7LP#T- z*JGr3KKjR%CS=(m39UX-pH~-zk+EAIPD^x0My0?A`5NTqw1GSdyg}5yY*!C&ICqN7 z!|{Wavwz3Be_t>E3*Liiw9-M^08r`BSExoo92~9a`D=99wWJDh*xsyKCiLe_T<#pH z=;m45U3U0@!t2HQKq>4Pj&aSwT*3)-2Nhmu;A$gW773TC%%%PHdyl;G2|v_t%VAGu zh9U&5v{T8sTaOz^jIJImPRJZ>xAzJK;s;vUj0cu}94(zlCwe0n>0JdC9Y;bc&_cVnOV=!fhXE*qGlhJyvSau& zhhoi(f49|axke}p_eNwM?{5rpFkr?rgIPoHiOjx*_=14UT49-gUy8x0w8U&Ck{ZtNuB8@-N5gPjFIqlte~qpfXG#gfL;on}Ir2q{)?_OCS{IV?hu&eC zCac~CWSeLxSi)I`dBq9U5)qoa*993xsA}iA90XmF&BJTE1*%9YSj56k)}aCJ60Cs9 zvDGze0=07ZB-*xf59zUKUqsf7*64>+B!>i>@Q{!gG-|C5!N!1-TDW7v=)7V6e+2%O zn@`}CfPR`?;&XthR&*)~ojF4bXqg*R?;ugY1?xI^rAL2^OnD(|zFpe!nav}KQOH46 zIV|`f34%Pxu+*KtF(Fo`Eo>Up^D!91?xEmP{o&P3Zdj;<2wtq3uxHJlh{qL=f3`2! z;$pkwb7M!_|JY;{%igV8X5km=f2UI;nIsoL*0{cr_}XuFvn$fI*AWHkx*nOo(reKz zQx2l_;~(jc15Ks?B!0*NdL$MZURcQ;;Lp3iGaU;Xn^v_+Yf2DCKf*?dp^guMySlK88vH_FCN~%D)(^ zhYbDXe`U_F)im$ozF)Kbf9s0m-e$`bHeSrJ0&DB5sIlz{}6yuYxou1Z3$sP-lDb!Q_r7 zsV;jh(Ko$0Qw1KRm&5{toj$K`ucI3cp^+{qluLXadV`|?FkO_mf4LMpu$c2H#{^tp zyG1{x;~elG?5^{&F%*Bn7MEaQFfmg3H_A*HknacC^>C3vDL3!;hj+bR{R@|&Os@9W6435L0j z>Rl0PNf}wq(R-4YJWRQ9W^%Df-rI4brwQTbn!z2|ZH;McUjpelM60T_J*nMfVj(}i z*OCw0NAK$(xyueU5s7j-k6vj_%6z$5CyV<0eJLQjh+PSye{@l;PgaJ@=Q!`D(_pn= z%`Vt`G!=lUWP@&rhx8Imn>BZoEhIc;R&Mu-?r>kS;wke0h67T*U8x<yE7gNue))yY$B! zgPc$qamMvtQ)dl^>$_hi*{u(qu2@#!i(*S&lmOkEe~y+)fz2b*E3gE+&e#+`l)S&(4A>0F?PogCX zECh&3ls6jdU-e!o8uO{If4vW6T47(K+RQUYxEy+=3t$V1l9~?`_gS(6E~KX`Q%5*C zR|h*YIUqFfSAmI>d185N;}*(l@^riyA(vLR`PwqN`s6ju%^oG7b;M-O`}Au(J8=Eg zf2Npi`*$HqKvTjcgqh+-Kt-Z#f9n5vKLImEkL%KS8+DiQnW2uB&4`T-6jM!`lTmLp+952m3*a<=Kr1lkM15VS}y8TBkD$9t*&$l5HoMpa=?Q? zOjxwZ{O3I1tu;!v&epGx)i!Nz#POEBS zF%|c|{~m-_v|y)jmGu(te@=@dU2k@Fb7DyE+32BMM-o&bM$TIlHs`IU(&x00e{RGk zR82vz6bMu~QRIsFz*SqTo!=(C3t4N+U@un;2{Np4No_MQADeP8GGQb%F>97EB{N2W8f4EdCa#&ZBZ?pwJa6XAG0Y!dDKk6`0E~G=nhR~H^ z{N+C=n^66AV8xC6|7K0}^MXg<<;^H$$A!;R9V;}T#H8+}l}65;7|>z& zkL7^N>+qR?16DAq2-Qu zH-!=%%fx=mMfl6n?Y|KV0Otd&;|oyu<>Ny;o2nYscc#im-U+C)It_-TErnFCJp&83 z3LvN~G5XfbaQ+s4jc0T|f8{5vx@i>e*&Lg*O8zB%;DK-e;*qi_r~LN8U#^XTY=V?a zchjI`LfrhuG)@>9e_f|0cuGpGpo1NF{}BY$cdE$5J54yu#z~<>-|Zyo+ZH=1t5ot= z#MKpVVD=klu?y(%4@dLn!`}HXZ8&dc{xqfOi>r+}0@Lt`n|$u(e8==VG|}=Hbx$M- z|NOU=`>lxq{s~GL8_Xv;)IWfI?Ix7UqW)TuqtSvu5Ll{(f5MGk{tk}mmBAD4S8@NU zO9kt8bSO5;Nxb~;wP7f#I82=8;1P??_N~CcE`xV=m z>*U*tF%j0Q*DL7SFGTk{^0ihoipq&)OguGCwX2ZzB1KBHh5zo^EO>o@Sqs@1Iin`f z-EF9g0q4fSf4dHDRmPd#oT6%l0-6jBsQ`#uS>$BlrK9dpbxsZmTnrm6kilx z*jqq1Dlz*00WXm1@$h;RKAcev(Grd$HR&I|I{Qf`SYT`oppMRigq$xZfs*%2IwF=Y za5kwvf5O8hN~{#bQIByn@mltO*ZySVOcUWf{C05V{f98QfVBt&`yt%5ZNbS|#Y+o> z9@jd>1MC{3+;?{YYrl+8zvR-}JEg;G+>Og)wz~oCb9K8aqBDP)ZYnbMZRGEPuMv#p z?d4T}09BC|hcu>o6C$(b2JX}5oO)Z8oKxE6e|uIu%HmW{%%$mMeT@~y*uAbMIi)@g zWUquCzcUD@ZZik8*&Nmi4t~b!?tnGz4cMfyy6esk8?b@J*#3&I;l~`-8-Qu!W~>)` zXjSW#*Y@R+fy!%VqH{fO3fZiNNC44aExltEl25p->O zf31!)NTxe`X$be$j@tRZlvCKT#TZ;?E#3M!KsD9p!Ut*#K+du2pVR+eSL#6oxCBcW z*aG}K1ZQhjEA(0B_yp;O{SnBf3_Y&vDuEpX3(?y(e$-zubwgaO_3V{W~W=- zz0jB+xTbVlcSW#m!0`$KTy$`Sc3KW0*Yc4Z;frvs_m804Xry$jLHcU^@^|>xVU$R9 zjs3d8P|R5|g{y0vi+_22t3rzw?fHDdoD(eQgXy|v+u#s1+wiUA0lF+DC)*Z7e>TAa zK5YIUnlt;jTvrld@F)sUld^bE4IDgzl4qOr(3W-jok#eMK13T}&=RtDWo8c}x;k((O zbQTS_ClWa5yD||y<0)#N!U`)7e;Vgm)X0&vUJ_5cyObEB3v)*7MGQmb1eGhL^5E6@ zthM6o@hy}kN=1SpXiw&Kz*3pr$D!{)s#qSLy!{UAoN)KuL0sk68ob~ls}G9em+hwr z_GX~a2h(~+V=+a)KemszT+D`c@PjvZW#`uvZ15fTOstszO_28AwP;zBe~fA3&g%as zGTshN9^dij?{NTj)favC%1DDifwobg346Ayx_^8m`iekH1VAZ-h}dq52&>-9mIkPl zssJv&mj%#SnEVsoD6xHbY;@p_6=+I^BCMj7sgwPU1)3SV^RhvWk9P)bnPh8Y)<&J; zWLswrv1rFv(GA7b;{u}4f3_S?4T);fw{jyQiFD8BvIy$T5vZl7z-ISts8G|6_1nV~ zJ!!P-!mOId(fRgN!`BUgFPy%Ar9n1xh2}lkw~oJu87-|5Rx4=Fa8q>MX_y|dT_oIz zY&CaJ$(8mnd+qG`c4FXz7KLt3gcy*tTEGs}UfIuN=I4wUkzZg|f1vAbw*}zw%f(IY z%ztmKFCvoNMl=|Sak!Ej6CP*nQw+!^{w)bMfe3>h{mYXntZlz6!GrF0t4)@|+dom| ztjn}I_pIEACEAIh9wu5t)A=*iKN;6oHQI;803s2&ZPxM3BhQI2M`URTNDnEh+2=ZW zua=f36e4n`?#xdpe+<26gwqlGstISFGM{NFBvU-@Mk*v4v?Nf3mOw@*K_oqGsUTc3 z-l%KFyl>uWl0{do(^Ah^!IHfovc86xI#W;DwYrHoo25_93L z4Ojg!545gajf7!1wkV3RjyGEozf^!9XK6#Mk-QgyCuWY?e}}|V^&Xy67dujvzb+8j zj(q6dHoWg!t0ubIA9LK|z0oGl?9%r6SiyK0?y>K98Z;DJ97l|@Ihn+gK1+hO`h{k& z)Nb{>t=u>+CVcFjdM)-_`XdVWd?*>W1by#L%C?F9ER`!^0|roUtaO&^qwkr>`8HEn?0bv+8zdI_)DKpG0 z_IV^+$D$C&ZGdjG&5PZxL<2AwQ;$a491(=No1O{}~%#pRJcG5=vjZIR*q-fVe4n8Sok* z8TyI#GUkUm=3sVWr!U@OFpO?7A@N@I{oD}Qe=l^7SoQ&Bg>wRLw@p=pfNVn zHPV)=xwS`1(vD$2FmRNnE~h3UvDD_F)+ocwn{A#F-eEJ$w703KZXM@Y^B*1k5m`Lk ze_Xv~xZ}MR0!IW%iq%Zs0_zH_8+rJ_gypM)n+5;BJ?p9CTub9C&j%1-x1cC(^N@rh z5w@{%Ys9Jsm}v*shk0i2Q&DXO?8itdtYK=lPt^|ngagC5ZEwd#3-5}hSmYhm-JavN z%jGL#XRZteW-@@6g{W#Q8n90|yL1t$f0C~=$DyiS4;g#=#p&r_=m}p3&OjjH-F-Bl z_-J)lm*-@KWwqsaF9-=yPc1e3I+Y*MYQU+x8=kxzGS58l55t+yqc=YhQWK7+9zk3Tg?an{7*?2jjP>Io$A|8IC79G5Le-eYA zc#&5V9Wc3sedb5$VsF{MX&%>i69G1(^z7l$!OzW0pvW?$<$#mX;nW^FVhG)RzcjT;OgKZuF6FuKe5-S*!s!4hAIWUD1-yU&JV2H)^ZFb*`_7Ae30 j0000ZQ$nf$0kZZ2o|h9W!x^+b3os3f0ssI200CKAu28&G From 117b8b1625c644c531ef87bc10515674f93e83b5 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Fri, 5 Jun 2026 15:17:09 -0400 Subject: [PATCH 03/20] fix: replace fixed-offset event parsing with level-aware sub-block parser Add extractGedcomLevel, extractEventSubBlock, extractInfoFromLines, and extractCoordFromSubBlock helpers so processEventLine looks up fields by tag name rather than fixed line offsets, correctly handling missing or reordered GEDCOM event sub-fields. Co-Authored-By: Claude Sonnet 4.6 --- R/readGedcom.R | 68 +++++++++++++++++++++++++------- tests/testthat/test-readGedcom.R | 60 ++++++++++++++++++++++++++++ 2 files changed, 114 insertions(+), 14 deletions(-) diff --git a/R/readGedcom.R b/R/readGedcom.R index a9976f76..2e108d6a 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -363,31 +363,71 @@ parseNameLine <- function(line, record) { record } +extractGedcomLevel <- function(line) { + as.integer(stringr::str_extract(line, "^\\d+")) +} + +extractEventSubBlock <- function(block, start_idx) { + event_level <- extractGedcomLevel(block[start_idx]) + n <- length(block) + if (start_idx >= n) return(character(0)) + end_idx <- start_idx + for (j in (start_idx + 1L):n) { + if (extractGedcomLevel(block[j]) <= event_level) break + end_idx <- j + } + if (end_idx == start_idx) return(character(0)) + block[(start_idx + 1L):end_idx] +} + +extractInfoFromLines <- function(lines, tag) { + pattern <- paste0("\\b", tag, "\\b") + matches <- lines[grepl(pattern, lines)] + if (length(matches) == 0L) return(NA_character_) + extractInfo(matches[1L], tag) +} + +extractCoordFromSubBlock <- function(sub_block, tag) { + # Searches all levels of the sub-block so it handles: + # GEDCOM 5.5.x: LATI/LONG as direct children of the event + # GEDCOM 5.5.x standard: LATI/LONG under PLAC (level+2) + # GEDCOM 7.x: LATI/LONG under MAP under PLAC (level+3) + pattern <- paste0("\\b", tag, "\\b") + matches <- sub_block[grepl(pattern, sub_block)] + if (length(matches) == 0L) return(NA_character_) + extractInfo(matches[1L], tag) +} + #' Process Event Lines (Birth or Death) #' #' @description Extracts event details (e.g., date, place, cause, latitude, longitude) from a block of GEDCOM lines. -#' For "birth": expect DATE on line i+1, PLAC on i+2, LATI on i+4, LONG on i+5. -#' For "death": expect DATE on line i+1, PLAC on i+2, CAUS on i+3, LATI on i+4, LONG on i+5. +#' Uses level-aware sub-block parsing so fields are looked up by tag name rather than fixed offsets. #' @param event A character string indicating the event type ("birth" or "death"). #' @param block A character vector of GEDCOM lines. #' @param i The current line index where the event tag is found. #' @param record A named list representing the individual's record. #' @param pattern_rows A list with counts of GEDCOM tag occurrences. -#' @return The updated record with parsed event information.# -# For "death": expect DATE on line i+1, PLAC on i+2, CAUS on i+3, LATI on i+4, LONG on i+5. +#' @return The updated record with parsed event information. processEventLine <- function(event, block, i, record, pattern_rows) { - n_lines <- length(block) + sub_block <- extractEventSubBlock(block, i) + if (length(sub_block) == 0L) return(record) + + event_level <- extractGedcomLevel(block[i]) + direct_children <- sub_block[ + vapply(sub_block, extractGedcomLevel, integer(1L)) == event_level + 1L + ] + if (event == "birth") { - if (i + 1 <= n_lines) record$birth_date <- extractInfo(block[i + 1], "DATE") - if (i + 2 <= n_lines) record$birth_place <- extractInfo(block[i + 2], "PLAC") - if (i + 4 <= n_lines) record$birth_lat <- extractInfo(block[i + 4], "LATI") - if (i + 5 <= n_lines) record$birth_long <- extractInfo(block[i + 5], "LONG") + record$birth_date <- extractInfoFromLines(direct_children, "DATE") + record$birth_place <- extractInfoFromLines(direct_children, "PLAC") + record$birth_lat <- extractCoordFromSubBlock(sub_block, "LATI") + record$birth_long <- extractCoordFromSubBlock(sub_block, "LONG") } else if (event == "death") { - if (i + 1 <= n_lines) record$death_date <- extractInfo(block[i + 1], "DATE") - if (i + 2 <= n_lines) record$death_place <- extractInfo(block[i + 2], "PLAC") - if (i + 3 <= n_lines) record$death_caus <- extractInfo(block[i + 3], "CAUS") - if (i + 4 <= n_lines) record$death_lat <- extractInfo(block[i + 4], "LATI") - if (i + 5 <= n_lines) record$death_long <- extractInfo(block[i + 5], "LONG") + record$death_date <- extractInfoFromLines(direct_children, "DATE") + record$death_place <- extractInfoFromLines(direct_children, "PLAC") + record$death_caus <- extractInfoFromLines(direct_children, "CAUS") + record$death_lat <- extractCoordFromSubBlock(sub_block, "LATI") + record$death_long <- extractCoordFromSubBlock(sub_block, "LONG") } record } diff --git a/tests/testthat/test-readGedcom.R b/tests/testthat/test-readGedcom.R index ab11e915..f909321f 100644 --- a/tests/testthat/test-readGedcom.R +++ b/tests/testthat/test-readGedcom.R @@ -575,6 +575,66 @@ test_that("mapFAMS2parents warns and returns NULL when required columns are miss expect_null(out) }) +birt_no_date_content <- c( + "0 @I1@ INDI", + "1 NAME Alice /Jones/", + "1 SEX F", + "1 BIRT", + "2 PLAC Springfield", + "2 LATI N39.7817", + "2 LONG W89.6501" +) + +birt_no_plac_content <- c( + "0 @I1@ INDI", + "1 NAME Bob /Smith/", + "1 SEX M", + "1 BIRT", + "2 DATE 15 MAR 1955" +) + +birt_reordered_content <- c( + "0 @I1@ INDI", + "1 NAME Carol /Lee/", + "1 SEX F", + "1 BIRT", + "2 LATI N40.7128", + "2 LONG W74.0060", + "2 PLAC New York", + "2 DATE 4 JUL 1976" +) + +test_that("processEventLine handles missing DATE gracefully", { + temp_file <- tempfile(fileext = ".ged") + writeLines(birt_no_date_content, temp_file) + df <- readGedcom(temp_file, remove_empty_cols = FALSE) + expect_true(is.na(df$birth_date[1])) + expect_equal(df$birth_place[1], "Springfield") + expect_equal(df$birth_lat[1], "N39.7817") + expect_equal(df$birth_long[1], "W89.6501") + unlink(temp_file) +}) + +test_that("processEventLine handles missing PLAC gracefully", { + temp_file <- tempfile(fileext = ".ged") + writeLines(birt_no_plac_content, temp_file) + df <- readGedcom(temp_file, remove_empty_cols = FALSE) + expect_equal(df$birth_date[1], "15 MAR 1955") + expect_true(is.na(df$birth_place[1])) + unlink(temp_file) +}) + +test_that("processEventLine handles reordered subfields correctly", { + temp_file <- tempfile(fileext = ".ged") + writeLines(birt_reordered_content, temp_file) + df <- readGedcom(temp_file) + expect_equal(df$birth_date[1], "4 JUL 1976") + expect_equal(df$birth_place[1], "New York") + expect_equal(df$birth_lat[1], "N40.7128") + expect_equal(df$birth_long[1], "W74.0060") + unlink(temp_file) +}) + test_that("readGed and readgedcom aliases return the same output as readGedcom", { gedcom_content <- c( "0 @I1@ INDI", From 1763ec8c4944ab6c0bcbb9088fa2e1d4a1b481f6 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Fri, 5 Jun 2026 15:24:05 -0400 Subject: [PATCH 04/20] docs: update stale fixed-offset description in readGedcom roxygen; clarify extractEventSubBlock guard assumption --- R/readGedcom.R | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/R/readGedcom.R b/R/readGedcom.R index 2e108d6a..433eb64c 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -20,12 +20,14 @@ #' including name prefix, name suffix, nickname, and married surname. #' #' Birth and death events are recognized from `BIRT` and `DEAT` tags. Event -#' details are currently parsed using fixed offsets within the individual block. -#' For birth events, the parser expects `DATE` at `i + 1`, `PLAC` at `i + 2`, -#' `LATI` at `i + 4`, and `LONG` at `i + 5`. For death events, the parser -#' expects `DATE` at `i + 1`, `PLAC` at `i + 2`, `CAUS` at `i + 3`, `LATI` at -#' `i + 4`, and `LONG` at `i + 5`. Missing elements leave the corresponding -#' output fields as `NA`. +#' details are parsed by collecting all child lines whose GEDCOM level equals +#' the event level plus one (direct children), then looking up sub-fields by +#' tag name. `DATE`, `PLAC`, and `CAUS` are matched as direct children of the +#' event. Coordinates (`LATI` and `LONG`) are searched across all descendant +#' lines, which allows them to be located whether they appear as direct children +#' (common in some GEDCOM 5.5.x exporters), under `PLAC` (standard GEDCOM +#' 5.5.1), or under a `MAP` substructure under `PLAC` (GEDCOM 7.x). Missing +#' sub-fields leave the corresponding output columns as `NA`. #' #' Attribute tags such as `OCCU`, `EDUC`, `RELI`, `CAST`, `NCHI`, `NMR`, `NATI`, #' `RESI`, `PROP`, `SSN`, `TITL`, `DSCR`, and `IDNO` are parsed directly into @@ -370,6 +372,8 @@ extractGedcomLevel <- function(line) { extractEventSubBlock <- function(block, start_idx) { event_level <- extractGedcomLevel(block[start_idx]) n <- length(block) + # start_idx is always within bounds because it comes from a bounded loop in the caller, + # but guard defensively to avoid the descending-sequence pitfall of R's : operator. if (start_idx >= n) return(character(0)) end_idx <- start_idx for (j in (start_idx + 1L):n) { From db59b9875f4e7d7f88d6db24c05d85e793518ce3 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Fri, 5 Jun 2026 15:32:32 -0400 Subject: [PATCH 05/20] feat: bundle FamilySearch spec TSVs and add GEDCOM version detection Co-Authored-By: Claude Sonnet 4.6 --- R/helpReadGedcom.R | 25 +++++++++++++++++ R/readGedcom.R | 3 ++ R/sysdata.rda | Bin 0 -> 3326 bytes data-raw/gedcom_spec.R | 25 +++++++++++++++++ tests/testthat/test-readGedcom.R | 37 +++++++++++++++++++++++++ tests/testthat/test-readGedcomlegacy.R | 2 ++ 6 files changed, 92 insertions(+) create mode 100644 R/sysdata.rda create mode 100644 data-raw/gedcom_spec.R diff --git a/R/helpReadGedcom.R b/R/helpReadGedcom.R index ace867a1..094e35f1 100644 --- a/R/helpReadGedcom.R +++ b/R/helpReadGedcom.R @@ -34,6 +34,31 @@ collapseNames <- function(verbose, df_temp) { df_temp } +#' Detect GEDCOM Version from File Lines +#' +#' @param lines Character vector of lines from a GEDCOM file. +#' @return A string such as `"5.5.1"`, `"7.0"`, or `"unknown"`. +#' @keywords internal +detectGedcomVersion <- function(lines) { + head_idx <- which(grepl("^0 HEAD\\b", lines))[1L] + if (is.na(head_idx)) return("unknown") + + # End of HEAD is the next level-0 record + next_l0 <- which(grepl("^0 ", lines[(head_idx + 1L):length(lines)]))[1L] + head_end <- if (is.na(next_l0)) length(lines) else head_idx + next_l0 - 1L + head_block <- lines[head_idx:head_end] + + gedc_idx <- which(grepl("^1 GEDC\\b", head_block))[1L] + if (is.na(gedc_idx)) return("unknown") + + # Look ahead within HEAD block for the VERS line under GEDC + lookahead <- head_block[seq(gedc_idx + 1L, min(gedc_idx + 5L, length(head_block)))] + vers_line <- lookahead[grepl("^2 VERS\\b", lookahead)][1L] + if (is.na(vers_line)) return("unknown") + + stringr::str_trim(stringr::str_extract(vers_line, "(?<=VERS ).*")) +} + #' Combine Columns #' #' This function combines two columns, handling conflicts and merging non-conflicting data. diff --git a/R/readGedcom.R b/R/readGedcom.R index 433eb64c..57ef2bfa 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -123,6 +123,8 @@ readGedcom <- function(file_path, } if (verbose == TRUE) message("Reading file: ", file_path) lines <- readLines(file_path) + gedcom_version <- detectGedcomVersion(lines) + if (verbose) message("Detected GEDCOM version: ", gedcom_version) total_lines <- length(lines) if (verbose == TRUE) message("File is ", total_lines, " lines long") @@ -190,6 +192,7 @@ readGedcom <- function(file_path, ) } + attr(df_temp, "gedcom_version") <- gedcom_version df_temp } diff --git a/R/sysdata.rda b/R/sysdata.rda new file mode 100644 index 0000000000000000000000000000000000000000..3101c76d87cb486ce7bbf2ce3f8198703440f2ee GIT binary patch literal 3326 zcmV^|KPvp-{e351ONyC1QFm9 ze_vbc5gQHz($PUw0AeJbAP7^`^#e@O00000$Y>0K zkO8KL28|j9gFs}&21bTJ0BNQ`00RU7I5cR`G#UdYATl&E00T`j000;u0EJ42s$fL@ zP-d9{4I4=H7)AgA0gz~Bh+_~6QbY+oBT1m1k?I;WZA~;9XwcI@(?9?X4Kf-4i4h5) znKWrM6od6gr~^P~00001rho%GC>4jB8W1m`g6!tw9Iyh2nTRFE-tcx{6uhgyV)H~0 zNB{#NyZxhkbl3?7kd9v4N=s*NU*XN{Z~K2g2RTJt*eZA|AOMhd_dAM4F3ElnXm_0E zt6#_%f(FNmy?{=zL~BAoWB~pi2HZU&p}v^0epkS_p(I%569m*zulmLyH1fuGlE7+U z!xd4XVqv8^m3P1He(ei{L-{oAd-YIx>-_cA?bmIzP%uyxM%j!Oy`G(!#@UIH8+NdD zT!Nu6bX-i34DNlbC66`tSRlgS^FuI!su--H)NREDXjlSqWmi!tC`vC*6wlZpW))X} z5LI7gH|<>=oNqD+7XoLFi(W__W3fEucdf_*^PHh^5!FF}de=KRb*B#%2CIaKj40Zv z84({l?{)?z3=RXls^K%kHLfW^u7?cv0DumAl=9UPV{5zE;N-=UfCx0R3wnaVOc^0t zUb3jF@o^5B98|#of0zg4PC32}i25}w^Z-Rpj)H@s~ z>yMW}NKMo+Rpy}y;X|!e3@4Bz%qTj^!pLrO+Hz3$s?W5op44roYi(3D(t(@jfWKb~ z8dY@=l5+yK;e6{}RpsB82`h*shd@Y8!67>WLUmA*a;|fR=JE3D(87d1N)*p6F#P=S zvLV!5`RApFXd2I6_ntW~jd5cO;1*VAaH0VR3NjLN z#ob;=7_?|WXj-T~eMfPo#*xx#D6==D!C!Y4Okx&CNa+b3z#bmIGSaH2bViSSUHJB( zM+08>@3kJ;zhj1KLycdG_nS^S@sRf737$2$B%7#aRBz+V5@LZOgc`te)rO0puChur zs9V~IWQ41txdx!%ngfQrYuQ3@u8I<1LwQiynXUp)rEH-hhL8t+DhNW?6;9>U;k9d7 zxn<5BC0~``_I3)9v5M&_2?lsquKyKf%=5BZs|23#~(; zQj@Zw#iIUc6;0Yfb4aRSH%O{)5$p)}gm~-`muB@1Un{Cd#Hgx&PKgyyHY5In)DNZ( zo=-P1vVbl7pFDH?9DWtXfQhIwDq@DppWk5Y1FwF`;ykfdV9G+h##X zpuk6UN;x8tZB125r;vJ5rNK-!M}+cJyA+WR6;O?tBIVSCmydGQQ%(v5UPGmT1fDu~i+bfW#@Kt>@nm72k5+*D;1 zP*KcOY>?9zj8+jORn%Q;8fQtIZKWFFP`z}JGc&1XGEA_Ej8JU=SQ^y=Fbk`^-U|Q= zn?kIH#i%-wkOjdZwl4$>qY||SoWwCO#*mR9;&A}@2pyF;j)u^I89R0q)B|^Bkw@lI z-lfA7?3cF#ZKE=$p;XaR1G1+pApuZ~RM0%tA85(hEDiwfxKqaPQYv0dBA(Fz(FJhY zW|?Cq4Aza5vZbt3&_h%QumuKekcGZx@Q@)1X6~_kK%$u%WL^qtiPNOvX{%_Kw5I9a zUC7^fKL$3bccm<`;ED~RUZ|K* zk*t;pl^KoEnQo<8JEzZlbeOO)i88>(WbN%!+L75)&Ad>$JE2QP14`10XN>o{#djC7kSY=!IwWY`Q&Eay|3 zi8kMcwMM|@P<4*A+apwcHH>2k8?%C^gildb^bHj}fC>$DIzC__#0}5job$?Z=f=$m z4FM@aER-T_g)&6JWrHfJzyS*Ygh&iU95B#D9xkYBN|dQek}624l^-OGWJth*$Sszf z`YLLvfWmwLLsd*8=&7>vgJgascbHIpVeTGeo_kV*WV_PTF7v5EWRB2Iys4#>zCJ_Qa2x_R2lEH^XRMS^0puO;SoTR)rp36yD7N#|-wP%8-NUoHw zGS-yXdNn-xOC>w89+*BfDL}MPmYV7*=na9p!~heL0-n!V#vN=WG>Kypi)d1^Gi@E6 zk7*UH9o-!)vAUM^FC;KSaV38okrl_=~-k^Nx>#A`OdtgZr(NfQZ1Y(2;$u4w_(m7Kz zaIQ2PQ*26%2q^+YlvA`6)d6+uDH2gx!J$hPfki?K2+>b~5XST4(~bA4uNPzXiCSx_ zrJ`09Drjb`gQ9Awa8ki(>A6Ce&5}YP1Oh-nk|;5h87L}9mJkZ00FfA!8ES$g2yIc% zSd%tti{Qwh7>SU|K!;fg6g@?Ev((CD5?RUF2Uh})atOjf(@2R0C;BI|&{wTa@>e=n zm@B~wc)s&{*$J}%PobnH}BG0)qVrn|V?ql+{;xB?&HxPRTu3MLqR2qdXfDrHj9_-#tQ6^UR* zETyX}7^4RkEItOsTS`o+xsV!`RWzr-J{xMId5I?kVhv0YbBg0?jZ!irXv<|WV4M;p zN{ph$aS9kzeP*WaC_mQSW3~@;+zgmmm1hcOp_v5d>7Z_~@S{TekGEh{6;G3FevEx? zzWMFjQ|m%iK5&mt;f?Y0l@(1(uTD=*?9-yUDk`5#tR+*ywxmuzTpA~0M_&R*(e4J7 z6;FQa-=MlhPVFRYsH%UyI`y;5>+9D(p}P_)nn3)Oe2Mil&ay zK)8D1fp$6Z2L5jsek|y4NUC^$l19lGk()$yU3i1^gY{qg;C|*GiS9Tzo8SCh$rRy2 IK^}n|z(LmPssI20 literal 0 HcmV?d00001 diff --git a/data-raw/gedcom_spec.R b/data-raw/gedcom_spec.R new file mode 100644 index 00000000..1276903f --- /dev/null +++ b/data-raw/gedcom_spec.R @@ -0,0 +1,25 @@ +# Downloads the FamilySearch GEDCOM 7 spec TSVs and saves them as sysdata. +# Run once with: source("data-raw/gedcom_spec.R") + +base_url <- "https://raw.githubusercontent.com/FamilySearch/GEDCOM/main/extracted-files/" + +gedcom_substructures <- utils::read.table( + paste0(base_url, "substructures.tsv"), + sep = "\t", header = TRUE, stringsAsFactors = FALSE, quote = "" +) +gedcom_payloads <- utils::read.table( + paste0(base_url, "payloads.tsv"), + sep = "\t", header = TRUE, stringsAsFactors = FALSE, quote = "" +) +gedcom_enumerations <- utils::read.table( + paste0(base_url, "enumerations.tsv"), + sep = "\t", header = TRUE, stringsAsFactors = FALSE, quote = "" +) + +usethis::use_data( + gedcom_substructures, + gedcom_payloads, + gedcom_enumerations, + internal = TRUE, + overwrite = TRUE +) diff --git a/tests/testthat/test-readGedcom.R b/tests/testthat/test-readGedcom.R index f909321f..644749ee 100644 --- a/tests/testthat/test-readGedcom.R +++ b/tests/testthat/test-readGedcom.R @@ -243,6 +243,8 @@ test_that("readGedcom parses death event correctly", { row.names(df) <- NULL row.names(df_leg) <- NULL df_leg <- dplyr::rename(df_leg, personID = id) + # Strip the gedcom_version attribute added by readGedcom before comparing + attr(df, "gedcom_version") <- NULL expect_equal(df_leg, df) unlink(temp_file) @@ -635,6 +637,41 @@ test_that("processEventLine handles reordered subfields correctly", { unlink(temp_file) }) +gedcom55_header <- c( + "0 HEAD", + "1 GEDC", + "2 VERS 5.5.1", + "2 FORM LINEAGE-LINKED", + "1 CHAR UTF-8", + "0 @I1@ INDI", + "1 NAME Test /Person/", + "1 SEX M" +) + +gedcom7_header <- c( + "0 HEAD", + "1 GEDC", + "2 VERS 7.0", + "1 CHAR UTF-8", + "0 @I1@ INDI", + "1 NAME Test /Person/", + "1 SEX M" +) + +test_that("detectGedcomVersion returns correct version string", { + expect_equal(detectGedcomVersion(gedcom55_header), "5.5.1") + expect_equal(detectGedcomVersion(gedcom7_header), "7.0") + expect_equal(detectGedcomVersion(c("0 @I1@ INDI", "1 NAME No /Head/")), "unknown") +}) + +test_that("readGedcom attaches gedcom_version attribute", { + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom55_header, temp_file) + df <- readGedcom(temp_file) + expect_equal(attr(df, "gedcom_version"), "5.5.1") + unlink(temp_file) +}) + test_that("readGed and readgedcom aliases return the same output as readGedcom", { gedcom_content <- c( "0 @I1@ INDI", diff --git a/tests/testthat/test-readGedcomlegacy.R b/tests/testthat/test-readGedcomlegacy.R index ea7a505c..70fe4251 100644 --- a/tests/testthat/test-readGedcomlegacy.R +++ b/tests/testthat/test-readGedcomlegacy.R @@ -32,6 +32,8 @@ test_that("readGedcom parses death event correctly for legacy", { row.names(df) <- NULL row.names(df_leg) <- NULL df_leg <- dplyr::rename(df_leg, personID = id) + # Strip the gedcom_version attribute added by readGedcom before comparing + attr(df, "gedcom_version") <- NULL expect_equal(df_leg, df) unlink(temp_file) From 475827f706d3a4f6e9c926dff1c37bc2167a1402 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Fri, 5 Jun 2026 15:45:34 -0400 Subject: [PATCH 06/20] fix: guard detectGedcomVersion against NA return and descending seq edge case; add tests Co-Authored-By: Claude Sonnet 4.6 --- R/helpReadGedcom.R | 7 ++++++- R/readGedcom.R | 1 + tests/testthat/test-readGedcom.R | 20 ++++++++++++++++++++ 3 files changed, 27 insertions(+), 1 deletion(-) diff --git a/R/helpReadGedcom.R b/R/helpReadGedcom.R index 094e35f1..8d6fb3ab 100644 --- a/R/helpReadGedcom.R +++ b/R/helpReadGedcom.R @@ -51,12 +51,17 @@ detectGedcomVersion <- function(lines) { gedc_idx <- which(grepl("^1 GEDC\\b", head_block))[1L] if (is.na(gedc_idx)) return("unknown") + # Guard: if GEDC is the last line of HEAD, there is no VERS to look ahead to + if (gedc_idx >= length(head_block)) return("unknown") + # Look ahead within HEAD block for the VERS line under GEDC lookahead <- head_block[seq(gedc_idx + 1L, min(gedc_idx + 5L, length(head_block)))] vers_line <- lookahead[grepl("^2 VERS\\b", lookahead)][1L] if (is.na(vers_line)) return("unknown") - stringr::str_trim(stringr::str_extract(vers_line, "(?<=VERS ).*")) + val <- extractInfo(vers_line, "VERS") + if (is.na(val) || !nzchar(val)) return("unknown") + val } #' Combine Columns diff --git a/R/readGedcom.R b/R/readGedcom.R index 57ef2bfa..e3896410 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -167,6 +167,7 @@ readGedcom <- function(file_path, records <- Filter(Negate(is.null), records) if (length(records) == 0) { + # Returns NULL without a gedcom_version attribute; callers should check is.null() first. warning("No people found in file") return(NULL) } diff --git a/tests/testthat/test-readGedcom.R b/tests/testthat/test-readGedcom.R index 644749ee..a25a1848 100644 --- a/tests/testthat/test-readGedcom.R +++ b/tests/testthat/test-readGedcom.R @@ -672,6 +672,26 @@ test_that("readGedcom attaches gedcom_version attribute", { unlink(temp_file) }) +test_that("detectGedcomVersion returns unknown when GEDC is present but VERS is missing", { + lines <- c( + "0 HEAD", + "1 GEDC", + "1 CHAR UTF-8", + "0 @I1@ INDI", + "1 NAME Test /Person/", + "1 SEX M" + ) + expect_equal(detectGedcomVersion(lines), "unknown") +}) + +test_that("readGedcom attaches gedcom_version attribute with post_process = FALSE", { + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom55_header, temp_file) + df <- readGedcom(temp_file, post_process = FALSE) + expect_equal(attr(df, "gedcom_version"), "5.5.1") + unlink(temp_file) +}) + test_that("readGed and readgedcom aliases return the same output as readGedcom", { gedcom_content <- c( "0 @I1@ INDI", From 9b729db8b33582cd3bb07b35db395aef62ed3d99 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Fri, 5 Jun 2026 15:54:45 -0400 Subject: [PATCH 07/20] feat: add GEDCOM 7.x MAP coordinate support and calendar-escape date stripping --- NAMESPACE | 2 + R/helpReadGedcom.R | 30 +++++++++++++++ R/readGedcom.R | 24 ++++++++---- _pkgdown.yml | 9 +++++ man/detectGedcomVersion.Rd | 18 +++++++++ man/gedcomLatToNumeric.Rd | 18 +++++++++ man/gedcomLonToNumeric.Rd | 18 +++++++++ man/processEventLine.Rd | 5 +-- man/readGedcom.Rd | 14 ++++--- tests/testthat/test-readGedcom.R | 65 ++++++++++++++++++++++++++++++++ 10 files changed, 186 insertions(+), 17 deletions(-) create mode 100644 man/detectGedcomVersion.Rd create mode 100644 man/gedcomLatToNumeric.Rd create mode 100644 man/gedcomLonToNumeric.Rd diff --git a/NAMESPACE b/NAMESPACE index 86ddec85..b543f584 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,6 +25,8 @@ export(dropLink) export(findLeaves) export(fitComponentModel) export(fitPedigreeModel) +export(gedcomLatToNumeric) +export(gedcomLonToNumeric) export(getGenDist) export(getWikiTreeSummary) export(identifyComponentModel) diff --git a/R/helpReadGedcom.R b/R/helpReadGedcom.R index 8d6fb3ab..2017921e 100644 --- a/R/helpReadGedcom.R +++ b/R/helpReadGedcom.R @@ -64,6 +64,36 @@ detectGedcomVersion <- function(lines) { val } +#' Convert GEDCOM Latitude String to Numeric +#' +#' Converts GEDCOM-style latitude strings like `"N51.5074"` or `"S33.8688"` to +#' signed decimal degrees. Returns `NA` for `NA` input. +#' +#' @param x Character vector of GEDCOM latitude values. +#' @return Numeric vector of decimal degrees (positive = N, negative = S). +#' @export +gedcomLatToNumeric <- function(x) { + ifelse(is.na(x), NA_real_, { + sign <- ifelse(startsWith(x, "N"), 1, -1) + sign * as.numeric(substring(x, 2)) + }) +} + +#' Convert GEDCOM Longitude String to Numeric +#' +#' Converts GEDCOM-style longitude strings like `"E151.2093"` or `"W0.1278"` to +#' signed decimal degrees. Returns `NA` for `NA` input. +#' +#' @param x Character vector of GEDCOM longitude values. +#' @return Numeric vector of decimal degrees (positive = E, negative = W). +#' @export +gedcomLonToNumeric <- function(x) { + ifelse(is.na(x), NA_real_, { + sign <- ifelse(startsWith(x, "E"), 1, -1) + sign * as.numeric(substring(x, 2)) + }) +} + #' Combine Columns #' #' This function combines two columns, handling conflicts and merging non-conflicting data. diff --git a/R/readGedcom.R b/R/readGedcom.R index e3896410..7eccfe8c 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -616,21 +616,29 @@ postProcessGedcom <- function(df_temp, } if (parse_dates == TRUE) { date_cols <- c("birth_date", "death_date") - if (verbose == TRUE) message("Parsing date columns: ", paste(date_cols[date_cols %in% colnames(df_temp)], collapse = ", ")) - # GEDCOM date qualifiers like "ABT", "BEF", "AFT" can be present in date strings. We can remove them before parsing. + calendar_escape_regex <- "@#D[A-Z]+@\\s*" date_qualifier_regex <- "\\b(?:[aA][bBfF][tT]|[bB][eE][tTfF])\\.?\\b\\s*" - if (verbose == TRUE && any(sapply(df_temp[date_cols], function(col) any(grepl(date_qualifier_regex, col, perl = TRUE)))) - ) { - message("Found date qualifiers in date columns. They will be removed before parsing.") + if (verbose == TRUE) message("Parsing date columns: ", paste(date_cols[date_cols %in% colnames(df_temp)], collapse = ", ")) + + if (verbose == TRUE && any(date_cols %in% colnames(df_temp))) { + has_qualifiers <- any(sapply( + df_temp[date_cols[date_cols %in% colnames(df_temp)]], + function(col) any(grepl(date_qualifier_regex, col, perl = TRUE)) + )) + if (has_qualifiers) { + message("Found date qualifiers in date columns. They will be removed before parsing.") + } } # only parse date columns that are present in the data frame - if (any(date_cols %in% colnames(df_temp))) { - df_temp[date_cols] <- lapply(df_temp[date_cols], function(x) { + present_date_cols <- date_cols[date_cols %in% colnames(df_temp)] + if (length(present_date_cols) > 0) { + df_temp[present_date_cols] <- lapply(df_temp[present_date_cols], function(x) { if (is.character(x)) { + x <- stringr::str_replace_all(x, calendar_escape_regex, "") x <- stringr::str_replace_all(x, date_qualifier_regex, "") - as.Date(x, format = "%d %b %Y") + as.Date(stringr::str_trim(x), format = "%d %b %Y") } else { x } diff --git a/_pkgdown.yml b/_pkgdown.yml index fbd085d6..7f59e059 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -1,3 +1,12 @@ url: https://r-computing-lab.github.io/BGmisc template: bootstrap: 5 + +reference: + - title: GEDCOM I/O + contents: + - readGedcom + - readGed + - readgedcom + - gedcomLatToNumeric + - gedcomLonToNumeric diff --git a/man/detectGedcomVersion.Rd b/man/detectGedcomVersion.Rd new file mode 100644 index 00000000..d218f287 --- /dev/null +++ b/man/detectGedcomVersion.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helpReadGedcom.R +\name{detectGedcomVersion} +\alias{detectGedcomVersion} +\title{Detect GEDCOM Version from File Lines} +\usage{ +detectGedcomVersion(lines) +} +\arguments{ +\item{lines}{Character vector of lines from a GEDCOM file.} +} +\value{ +A string such as `"5.5.1"`, `"7.0"`, or `"unknown"`. +} +\description{ +Detect GEDCOM Version from File Lines +} +\keyword{internal} diff --git a/man/gedcomLatToNumeric.Rd b/man/gedcomLatToNumeric.Rd new file mode 100644 index 00000000..a95df188 --- /dev/null +++ b/man/gedcomLatToNumeric.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helpReadGedcom.R +\name{gedcomLatToNumeric} +\alias{gedcomLatToNumeric} +\title{Convert GEDCOM Latitude String to Numeric} +\usage{ +gedcomLatToNumeric(x) +} +\arguments{ +\item{x}{Character vector of GEDCOM latitude values.} +} +\value{ +Numeric vector of decimal degrees (positive = N, negative = S). +} +\description{ +Converts GEDCOM-style latitude strings like `"N51.5074"` or `"S33.8688"` to +signed decimal degrees. Returns `NA` for `NA` input. +} diff --git a/man/gedcomLonToNumeric.Rd b/man/gedcomLonToNumeric.Rd new file mode 100644 index 00000000..4bad72f7 --- /dev/null +++ b/man/gedcomLonToNumeric.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helpReadGedcom.R +\name{gedcomLonToNumeric} +\alias{gedcomLonToNumeric} +\title{Convert GEDCOM Longitude String to Numeric} +\usage{ +gedcomLonToNumeric(x) +} +\arguments{ +\item{x}{Character vector of GEDCOM longitude values.} +} +\value{ +Numeric vector of decimal degrees (positive = E, negative = W). +} +\description{ +Converts GEDCOM-style longitude strings like `"E151.2093"` or `"W0.1278"` to +signed decimal degrees. Returns `NA` for `NA` input. +} diff --git a/man/processEventLine.Rd b/man/processEventLine.Rd index d4cff3d3..40bb9417 100644 --- a/man/processEventLine.Rd +++ b/man/processEventLine.Rd @@ -18,10 +18,9 @@ processEventLine(event, block, i, record, pattern_rows) \item{pattern_rows}{A list with counts of GEDCOM tag occurrences.} } \value{ -The updated record with parsed event information.# +The updated record with parsed event information. } \description{ Extracts event details (e.g., date, place, cause, latitude, longitude) from a block of GEDCOM lines. -For "birth": expect DATE on line i+1, PLAC on i+2, LATI on i+4, LONG on i+5. -For "death": expect DATE on line i+1, PLAC on i+2, CAUS on i+3, LATI on i+4, LONG on i+5. +Uses level-aware sub-block parsing so fields are looked up by tag name rather than fixed offsets. } diff --git a/man/readGedcom.Rd b/man/readGedcom.Rd index 2350716b..8005f773 100644 --- a/man/readGedcom.Rd +++ b/man/readGedcom.Rd @@ -139,12 +139,14 @@ cleaned full name. Additional name components are parsed when present, including name prefix, name suffix, nickname, and married surname. Birth and death events are recognized from `BIRT` and `DEAT` tags. Event -details are currently parsed using fixed offsets within the individual block. -For birth events, the parser expects `DATE` at `i + 1`, `PLAC` at `i + 2`, -`LATI` at `i + 4`, and `LONG` at `i + 5`. For death events, the parser -expects `DATE` at `i + 1`, `PLAC` at `i + 2`, `CAUS` at `i + 3`, `LATI` at -`i + 4`, and `LONG` at `i + 5`. Missing elements leave the corresponding -output fields as `NA`. +details are parsed by collecting all child lines whose GEDCOM level equals +the event level plus one (direct children), then looking up sub-fields by +tag name. `DATE`, `PLAC`, and `CAUS` are matched as direct children of the +event. Coordinates (`LATI` and `LONG`) are searched across all descendant +lines, which allows them to be located whether they appear as direct children +(common in some GEDCOM 5.5.x exporters), under `PLAC` (standard GEDCOM +5.5.1), or under a `MAP` substructure under `PLAC` (GEDCOM 7.x). Missing +sub-fields leave the corresponding output columns as `NA`. Attribute tags such as `OCCU`, `EDUC`, `RELI`, `CAST`, `NCHI`, `NMR`, `NATI`, `RESI`, `PROP`, `SSN`, `TITL`, `DSCR`, and `IDNO` are parsed directly into diff --git a/tests/testthat/test-readGedcom.R b/tests/testthat/test-readGedcom.R index a25a1848..5f7aa269 100644 --- a/tests/testthat/test-readGedcom.R +++ b/tests/testthat/test-readGedcom.R @@ -715,3 +715,68 @@ test_that("readGed and readgedcom aliases return the same output as readGedcom", unlink(temp_file) }) + +gedcom7_map_content <- c( + "0 HEAD", + "1 GEDC", + "2 VERS 7.0", + "0 @I1@ INDI", + "1 NAME Test /Person/", + "1 SEX F", + "1 BIRT", + "2 DATE 1 JAN 2000", + "2 PLAC London, England", + "3 MAP", + "4 LATI N51.5074", + "4 LONG W0.1278", + "1 DEAT", + "2 DATE 31 DEC 2080", + "2 PLAC Edinburgh, Scotland", + "3 MAP", + "4 LATI N55.9533", + "4 LONG W3.1883" +) + +gedcom_calendar_escape_content <- c( + "0 HEAD", + "1 GEDC", + "2 VERS 5.5", + "0 @I1@ INDI", + "1 NAME Old /Style/", + "1 SEX M", + "1 BIRT", + "2 DATE @#DGREGORIAN@ 15 JUL 1823" +) + +test_that("readGedcom parses GEDCOM 7.x MAP coordinate structure", { + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom7_map_content, temp_file) + df <- readGedcom(temp_file) + expect_equal(attr(df, "gedcom_version"), "7.0") + expect_equal(df$birth_lat[1], "N51.5074") + expect_equal(df$birth_long[1], "W0.1278") + expect_equal(df$death_lat[1], "N55.9533") + expect_equal(df$death_long[1], "W3.1883") + unlink(temp_file) +}) + +test_that("parse_dates strips GEDCOM 5.5 calendar escape before parsing", { + temp_file <- tempfile(fileext = ".ged") + writeLines(gedcom_calendar_escape_content, temp_file) + df <- readGedcom(temp_file, parse_dates = TRUE) + expect_false(is.na(df$birth_date[1])) + expect_equal(format(df$birth_date[1], "%d %b %Y"), "15 Jul 1823") + unlink(temp_file) +}) + +test_that("gedcomLatToNumeric converts N/S notation correctly", { + expect_equal(gedcomLatToNumeric("N51.5074"), 51.5074) + expect_equal(gedcomLatToNumeric("S33.8688"), -33.8688) + expect_true(is.na(gedcomLatToNumeric(NA_character_))) +}) + +test_that("gedcomLonToNumeric converts E/W notation correctly", { + expect_equal(gedcomLonToNumeric("E151.2093"), 151.2093) + expect_equal(gedcomLonToNumeric("W0.1278"), -0.1278) + expect_true(is.na(gedcomLonToNumeric(NA_character_))) +}) From 1f994f9688185e6de225f0296cd2ab2c20cb95a8 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Fri, 5 Jun 2026 16:02:38 -0400 Subject: [PATCH 08/20] fix: guard coordinate helpers against invalid prefix; fix French Republican calendar escape; fix pkgdown catch-all --- R/helpReadGedcom.R | 24 ++++++++++++++---------- R/readGedcom.R | 2 +- _pkgdown.yml | 4 ++++ data-raw/df_royal92.R | 4 ++-- man/gedcomLatToNumeric.Rd | 5 ++++- man/gedcomLonToNumeric.Rd | 5 ++++- tests/testthat/test-readGedcom.R | 10 ++++++++++ 7 files changed, 39 insertions(+), 15 deletions(-) diff --git a/R/helpReadGedcom.R b/R/helpReadGedcom.R index 2017921e..470183cf 100644 --- a/R/helpReadGedcom.R +++ b/R/helpReadGedcom.R @@ -67,31 +67,35 @@ detectGedcomVersion <- function(lines) { #' Convert GEDCOM Latitude String to Numeric #' #' Converts GEDCOM-style latitude strings like `"N51.5074"` or `"S33.8688"` to -#' signed decimal degrees. Returns `NA` for `NA` input. +#' signed decimal degrees. Returns `NA` for `NA` or unrecognised-prefix input. #' #' @param x Character vector of GEDCOM latitude values. #' @return Numeric vector of decimal degrees (positive = N, negative = S). +#' @examples +#' gedcomLatToNumeric(c("N51.5074", "S33.8688", NA)) #' @export gedcomLatToNumeric <- function(x) { - ifelse(is.na(x), NA_real_, { - sign <- ifelse(startsWith(x, "N"), 1, -1) - sign * as.numeric(substring(x, 2)) - }) + is_north <- startsWith(x, "N") + is_valid <- is_north | startsWith(x, "S") + result <- as.numeric(substring(x, 2)) * ifelse(is_north, 1, -1) + ifelse(is.na(x) | !is_valid, NA_real_, result) } #' Convert GEDCOM Longitude String to Numeric #' #' Converts GEDCOM-style longitude strings like `"E151.2093"` or `"W0.1278"` to -#' signed decimal degrees. Returns `NA` for `NA` input. +#' signed decimal degrees. Returns `NA` for `NA` or unrecognised-prefix input. #' #' @param x Character vector of GEDCOM longitude values. #' @return Numeric vector of decimal degrees (positive = E, negative = W). +#' @examples +#' gedcomLonToNumeric(c("E151.2093", "W0.1278", NA)) #' @export gedcomLonToNumeric <- function(x) { - ifelse(is.na(x), NA_real_, { - sign <- ifelse(startsWith(x, "E"), 1, -1) - sign * as.numeric(substring(x, 2)) - }) + is_east <- startsWith(x, "E") + is_valid <- is_east | startsWith(x, "W") + result <- as.numeric(substring(x, 2)) * ifelse(is_east, 1, -1) + ifelse(is.na(x) | !is_valid, NA_real_, result) } #' Combine Columns diff --git a/R/readGedcom.R b/R/readGedcom.R index 7eccfe8c..7a61fc51 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -616,7 +616,7 @@ postProcessGedcom <- function(df_temp, } if (parse_dates == TRUE) { date_cols <- c("birth_date", "death_date") - calendar_escape_regex <- "@#D[A-Z]+@\\s*" + calendar_escape_regex <- "@#D[A-Z ]+@\\s*" date_qualifier_regex <- "\\b(?:[aA][bBfF][tT]|[bB][eE][tTfF])\\.?\\b\\s*" if (verbose == TRUE) message("Parsing date columns: ", paste(date_cols[date_cols %in% colnames(df_temp)], collapse = ", ")) diff --git a/_pkgdown.yml b/_pkgdown.yml index 7f59e059..2ba475c0 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -10,3 +10,7 @@ reference: - readgedcom - gedcomLatToNumeric - gedcomLonToNumeric + +- title: Other functions + contents: + - matches(".*") diff --git a/data-raw/df_royal92.R b/data-raw/df_royal92.R index f0f55a4f..008f65a5 100644 --- a/data-raw/df_royal92.R +++ b/data-raw/df_royal92.R @@ -3485,8 +3485,8 @@ if (FALSE) { code_male = "M", code_female = "F", add_phantoms = TRUE, - ped_packed=T, - ped_align = T + ped_packed=TRUE, + ped_align = TRUE ), tooltip_columns = c("personID", "name", "title", "birth_date", "death_date") diff --git a/man/gedcomLatToNumeric.Rd b/man/gedcomLatToNumeric.Rd index a95df188..a677b133 100644 --- a/man/gedcomLatToNumeric.Rd +++ b/man/gedcomLatToNumeric.Rd @@ -14,5 +14,8 @@ Numeric vector of decimal degrees (positive = N, negative = S). } \description{ Converts GEDCOM-style latitude strings like `"N51.5074"` or `"S33.8688"` to -signed decimal degrees. Returns `NA` for `NA` input. +signed decimal degrees. Returns `NA` for `NA` or unrecognised-prefix input. +} +\examples{ +gedcomLatToNumeric(c("N51.5074", "S33.8688", NA)) } diff --git a/man/gedcomLonToNumeric.Rd b/man/gedcomLonToNumeric.Rd index 4bad72f7..d524d083 100644 --- a/man/gedcomLonToNumeric.Rd +++ b/man/gedcomLonToNumeric.Rd @@ -14,5 +14,8 @@ Numeric vector of decimal degrees (positive = E, negative = W). } \description{ Converts GEDCOM-style longitude strings like `"E151.2093"` or `"W0.1278"` to -signed decimal degrees. Returns `NA` for `NA` input. +signed decimal degrees. Returns `NA` for `NA` or unrecognised-prefix input. +} +\examples{ +gedcomLonToNumeric(c("E151.2093", "W0.1278", NA)) } diff --git a/tests/testthat/test-readGedcom.R b/tests/testthat/test-readGedcom.R index 5f7aa269..4d8124ed 100644 --- a/tests/testthat/test-readGedcom.R +++ b/tests/testthat/test-readGedcom.R @@ -780,3 +780,13 @@ test_that("gedcomLonToNumeric converts E/W notation correctly", { expect_equal(gedcomLonToNumeric("W0.1278"), -0.1278) expect_true(is.na(gedcomLonToNumeric(NA_character_))) }) + +test_that("gedcomLatToNumeric returns NA for unrecognised prefix", { + expect_true(is.na(gedcomLatToNumeric("12.34"))) + expect_true(is.na(gedcomLatToNumeric(""))) +}) + +test_that("gedcomLonToNumeric returns NA for unrecognised prefix", { + expect_true(is.na(gedcomLonToNumeric("12.34"))) + expect_true(is.na(gedcomLonToNumeric(""))) +}) From 002c78dbbe0cd7cf0930cd9028df28fd753a7480 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Fri, 5 Jun 2026 16:14:07 -0400 Subject: [PATCH 09/20] Update NEWS.md --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index d86e48ff..d1b910c5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ * Optimized gedcom reader, com2links for speed and memory usage, with a focus on large pedigrees * Fixed bug in gedcom reader that resulted in document records being added to the final person in the pedigree * Added more unit tests for gedcom reader and data parser +* several improvements to the GEDCOM parsing functionality, focusing on more robust and flexible event parsing, better support for different GEDCOM versions, and enhanced usability. * Optimized sliceFamilies to be more abstract, and no longer require mtdna * Created `.require_openmx()` to make it easier to use OpenMx functions without making OpenMx a dependency * Smarter string ID handling for ped2id From 7da356d7ef9cdc5771634bc73f5d0ec57cc55729 Mon Sep 17 00:00:00 2001 From: Mason Garrison Date: Sat, 6 Jun 2026 15:21:27 -0400 Subject: [PATCH 10/20] Potential fix for pull request finding Potential fix for pull request finding Potential fix for pull request finding Potential fix for pull request finding Potential fix for pull request finding Potential fix for pull request finding Potential fix for pull request finding Co-Authored-By: Copilot Autofix powered by AI <175728472+Copilot@users.noreply.github.com> --- R/helpReadGedcom.R | 17 +++++++++-------- R/readGedcom.R | 4 +++- _pkgdown.yml | 6 +++--- tests/testthat/test-readGedcom.R | 8 ++++---- 4 files changed, 19 insertions(+), 16 deletions(-) diff --git a/R/helpReadGedcom.R b/R/helpReadGedcom.R index 470183cf..2207ae22 100644 --- a/R/helpReadGedcom.R +++ b/R/helpReadGedcom.R @@ -44,6 +44,7 @@ detectGedcomVersion <- function(lines) { if (is.na(head_idx)) return("unknown") # End of HEAD is the next level-0 record + if (head_idx >= length(lines)) return("unknown") next_l0 <- which(grepl("^0 ", lines[(head_idx + 1L):length(lines)]))[1L] head_end <- if (is.na(next_l0)) length(lines) else head_idx + next_l0 - 1L head_block <- lines[head_idx:head_end] @@ -75,10 +76,10 @@ detectGedcomVersion <- function(lines) { #' gedcomLatToNumeric(c("N51.5074", "S33.8688", NA)) #' @export gedcomLatToNumeric <- function(x) { - is_north <- startsWith(x, "N") - is_valid <- is_north | startsWith(x, "S") - result <- as.numeric(substring(x, 2)) * ifelse(is_north, 1, -1) - ifelse(is.na(x) | !is_valid, NA_real_, result) + out <- rep(NA_real_, length(x)) + ok <- !is.na(x) & (startsWith(x, "N") | startsWith(x, "S")) + out[ok] <- as.numeric(substring(x[ok], 2)) * ifelse(startsWith(x[ok], "N"), 1, -1) + out } #' Convert GEDCOM Longitude String to Numeric @@ -92,10 +93,10 @@ gedcomLatToNumeric <- function(x) { #' gedcomLonToNumeric(c("E151.2093", "W0.1278", NA)) #' @export gedcomLonToNumeric <- function(x) { - is_east <- startsWith(x, "E") - is_valid <- is_east | startsWith(x, "W") - result <- as.numeric(substring(x, 2)) * ifelse(is_east, 1, -1) - ifelse(is.na(x) | !is_valid, NA_real_, result) + out <- rep(NA_real_, length(x)) + ok <- !is.na(x) & (startsWith(x, "E") | startsWith(x, "W")) + out[ok] <- as.numeric(substring(x[ok], 2)) * ifelse(startsWith(x[ok], "E"), 1, -1) + out } #' Combine Columns diff --git a/R/readGedcom.R b/R/readGedcom.R index 7a61fc51..5359cfa6 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -381,7 +381,9 @@ extractEventSubBlock <- function(block, start_idx) { if (start_idx >= n) return(character(0)) end_idx <- start_idx for (j in (start_idx + 1L):n) { - if (extractGedcomLevel(block[j]) <= event_level) break + lvl <- extractGedcomLevel(block[j]) + if (is.na(lvl)) next + if (lvl <= event_level) break end_idx <- j } if (end_idx == start_idx) return(character(0)) diff --git a/_pkgdown.yml b/_pkgdown.yml index 2ba475c0..5c962523 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -11,6 +11,6 @@ reference: - gedcomLatToNumeric - gedcomLonToNumeric -- title: Other functions - contents: - - matches(".*") + - title: Other functions + contents: + - matches(".*") diff --git a/tests/testthat/test-readGedcom.R b/tests/testthat/test-readGedcom.R index 4d8124ed..1eb3cf48 100644 --- a/tests/testthat/test-readGedcom.R +++ b/tests/testthat/test-readGedcom.R @@ -659,9 +659,9 @@ gedcom7_header <- c( ) test_that("detectGedcomVersion returns correct version string", { - expect_equal(detectGedcomVersion(gedcom55_header), "5.5.1") - expect_equal(detectGedcomVersion(gedcom7_header), "7.0") - expect_equal(detectGedcomVersion(c("0 @I1@ INDI", "1 NAME No /Head/")), "unknown") + expect_equal(BGmisc:::detectGedcomVersion(gedcom55_header), "5.5.1") + expect_equal(BGmisc:::detectGedcomVersion(gedcom7_header), "7.0") + expect_equal(BGmisc:::detectGedcomVersion(c("0 @I1@ INDI", "1 NAME No /Head/")), "unknown") }) test_that("readGedcom attaches gedcom_version attribute", { @@ -681,7 +681,7 @@ test_that("detectGedcomVersion returns unknown when GEDC is present but VERS is "1 NAME Test /Person/", "1 SEX M" ) - expect_equal(detectGedcomVersion(lines), "unknown") + expect_equal(BGmisc:::detectGedcomVersion(lines), "unknown") }) test_that("readGedcom attaches gedcom_version attribute with post_process = FALSE", { From 872530982edcc7ff809113f76dfc12d9dccef0ae Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Sat, 6 Jun 2026 16:17:38 -0400 Subject: [PATCH 11/20] cleanup --- NAMESPACE | 2 - R/helpReadGedcom.R | 6 +-- R/readGedcom.R | 57 ++++++++++++++++++-------- man/gedcomLatToNumeric.Rd | 1 + man/gedcomLonToNumeric.Rd | 1 + man/postProcessGedcom.Rd | 17 +++++--- man/readGedcom.Rd | 20 +++++---- tests/testthat/test-readGedcom.R | 8 ++-- tests/testthat/test-readGedcomlegacy.R | 4 +- 9 files changed, 75 insertions(+), 41 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index b543f584..86ddec85 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,8 +25,6 @@ export(dropLink) export(findLeaves) export(fitComponentModel) export(fitPedigreeModel) -export(gedcomLatToNumeric) -export(gedcomLonToNumeric) export(getGenDist) export(getWikiTreeSummary) export(identifyComponentModel) diff --git a/R/helpReadGedcom.R b/R/helpReadGedcom.R index 2207ae22..0a128f33 100644 --- a/R/helpReadGedcom.R +++ b/R/helpReadGedcom.R @@ -18,7 +18,7 @@ initializeRecord <- function(all_var_names) { #' @param df_temp A data frame containing the columns to be combined. #' @return A data frame with the combined columns. collapseNames <- function(verbose, df_temp) { - if (verbose == TRUE) message("Combining Duplicate Columns") + if (verbose == TRUE) message("Combining Duplicate Name Columns...") if (!all(is.na(df_temp$name_given_pieces)) || !all(is.na(df_temp$name_given))) { result <- combineColumns(df_temp$name_given, df_temp$name_given_pieces) @@ -74,7 +74,7 @@ detectGedcomVersion <- function(lines) { #' @return Numeric vector of decimal degrees (positive = N, negative = S). #' @examples #' gedcomLatToNumeric(c("N51.5074", "S33.8688", NA)) -#' @export +#' @keywords internal gedcomLatToNumeric <- function(x) { out <- rep(NA_real_, length(x)) ok <- !is.na(x) & (startsWith(x, "N") | startsWith(x, "S")) @@ -91,7 +91,7 @@ gedcomLatToNumeric <- function(x) { #' @return Numeric vector of decimal degrees (positive = E, negative = W). #' @examples #' gedcomLonToNumeric(c("E151.2093", "W0.1278", NA)) -#' @export +#' @keywords internal gedcomLonToNumeric <- function(x) { out <- rep(NA_real_, length(x)) ok <- !is.na(x) & (startsWith(x, "E") | startsWith(x, "W")) diff --git a/R/readGedcom.R b/R/readGedcom.R index 5359cfa6..6f4a8c0f 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -47,20 +47,22 @@ #' #' @param file_path Character string. Path to the GEDCOM file. #' @param verbose Logical. If `TRUE`, print progress messages. -#' @param add_parents Logical. If `TRUE`, infer `momID` and `dadID` from `FAMC` -#' and `FAMS` mappings during post-processing. #' @param remove_empty_cols Logical. If `TRUE`, drop columns that are entirely #' `NA` during post-processing. -#' @param combine_cols Logical. If `TRUE`, combine redundant name columns, such -#' as `name_given` with `name_given_pieces` and `name_surn` with -#' `name_surn_pieces`, when their values do not conflict. -#' @param parse_dates Logical. If `TRUE`, attempt to parse date columns (e.g., `birth_date`, `death_date`) into Date objects, after removing common GEDCOM date qualifiers like "ABT", "BEF", and "AFT". #' @param skinny Logical. If `TRUE`, return a slimmer data frame by dropping #' `FAMC`, `FAMS`, and columns that are entirely `NA` during post-processing. #' @param update_rate Numeric. Intended rate at which progress messages should #' be printed. Currently unused. #' @param post_process Logical. If `TRUE`, apply post-processing steps controlled #' by `add_parents`, `combine_cols`, `remove_empty_cols`, `skinny`, and `parse_dates`. +#' @param remove_empty_cols Logical indicating whether to remove columns that are entirely missing. +#' @param combine_cols Logical. If `TRUE`, combine redundant name columns, such +#' as `name_given` with `name_given_pieces` and `name_surn` with +#' `name_surn_pieces`, when their values do not conflict. +#' @param add_parents Logical. If `TRUE`, infer `momID` and `dadID` from `FAMC` +#' and `FAMS` mappings during post-processing. +#' @param parse_dates Logical. If `TRUE`, attempt to parse date columns (e.g., `birth_date`, `death_date`) into Date objects, after removing common GEDCOM date qualifiers like "ABT", "BEF", and "AFT". +#' @param clean_names Logical indicating whether to clean name columns by removing trailing slashes and squishing whitespace. #' @param ... Additional arguments. Currently unused. #' @return A data frame containing information about individuals, with the following potential columns: #' \describe{ @@ -109,13 +111,15 @@ #' readGedcom <- function(file_path, verbose = FALSE, + post_process = TRUE, add_parents = TRUE, remove_empty_cols = TRUE, combine_cols = TRUE, skinny = FALSE, parse_dates = FALSE, + clean_names = TRUE, update_rate = 1000, - post_process = TRUE, + ...) { # Ensure the file exists and read all lines. if (!file.exists(file_path)) { @@ -188,6 +192,7 @@ readGedcom <- function(file_path, combine_cols = combine_cols, parse_dates = parse_dates, add_parents = add_parents, + clean_names = clean_names, skinny = skinny, verbose = verbose ) @@ -460,8 +465,11 @@ processEventLine <- function(event, block, i, record, pattern_rows) { applyTagMappings <- function(line, record, pattern_rows, tag_mappings) { for (mapping in tag_mappings) { extractor <- if (is.null(mapping$extractor)) NULL else mapping$extractor - result <- processTag(mapping$tag, mapping$field, pattern_rows, line, record, - extractor = extractor, mode = mapping$mode + result <- processTag(mapping$tag, + mapping$field, + pattern_rows, line, record, + extractor = extractor, + mode = mapping$mode ) record <- result$vars if (result$matched) { @@ -589,20 +597,16 @@ processTag <- function(tag, #' #' @description This function optionally adds parent information, combines duplicate columns, #' and removes empty columns from the GEDCOM data frame. It is called by \code{readGedcom()} if \code{post_process = TRUE}. -#' +#' @inheritParams readGedcom #' @param df_temp A data frame produced by \code{readGedcom()}. -#' @param remove_empty_cols Logical indicating whether to remove columns that are entirely missing. -#' @param combine_cols Logical indicating whether to combine columns with duplicate values. -#' @param add_parents Logical indicating whether to add parent information. -#' @param parse_dates Logical indicating whether to parse date columns into Date objects. -#' @param skinny Logical indicating whether to slim down the data frame. #' @param verbose Logical indicating whether to print progress messages. #' @return The post-processed data frame. postProcessGedcom <- function(df_temp, remove_empty_cols = TRUE, combine_cols = TRUE, - parse_dates = FALSE, add_parents = TRUE, + parse_dates = FALSE, + clean_names = TRUE, skinny = TRUE, verbose = FALSE) { if (add_parents == TRUE) { @@ -621,14 +625,16 @@ postProcessGedcom <- function(df_temp, calendar_escape_regex <- "@#D[A-Z ]+@\\s*" date_qualifier_regex <- "\\b(?:[aA][bBfF][tT]|[bB][eE][tTfF])\\.?\\b\\s*" - if (verbose == TRUE) message("Parsing date columns: ", paste(date_cols[date_cols %in% colnames(df_temp)], collapse = ", ")) + if (verbose == TRUE) { + message("Parsing date columns: ", paste(date_cols[date_cols %in% colnames(df_temp)], collapse = ", ")) + } if (verbose == TRUE && any(date_cols %in% colnames(df_temp))) { has_qualifiers <- any(sapply( df_temp[date_cols[date_cols %in% colnames(df_temp)]], function(col) any(grepl(date_qualifier_regex, col, perl = TRUE)) )) - if (has_qualifiers) { + if (has_qualifiers==TRUE) { message("Found date qualifiers in date columns. They will be removed before parsing.") } } @@ -647,6 +653,21 @@ postProcessGedcom <- function(df_temp, }) } } + if (clean_names == TRUE) { + if (verbose == TRUE) message("Cleaning column names") + name_cols <- grep("^name", colnames(df_temp), value = TRUE) + if (verbose == TRUE && any(name_cols %in% colnames(df_temp))) { + message("Cleaning name columns: ", paste(name_cols, collapse = ", ")) + } + df_temp[name_cols] <- lapply(df_temp[name_cols], function(x) { + if (is.character(x)) { # remove / at end of names if present, and squish whitespace + stringr::str_squish(stringr::str_replace(x,"/+$", "")) + } else { + x + } + } + ) + } if (skinny == TRUE) { if (verbose == TRUE) message("Slimming down the data frame") # Remove raw family relationship columns diff --git a/man/gedcomLatToNumeric.Rd b/man/gedcomLatToNumeric.Rd index a677b133..07252bf2 100644 --- a/man/gedcomLatToNumeric.Rd +++ b/man/gedcomLatToNumeric.Rd @@ -19,3 +19,4 @@ signed decimal degrees. Returns `NA` for `NA` or unrecognised-prefix input. \examples{ gedcomLatToNumeric(c("N51.5074", "S33.8688", NA)) } +\keyword{internal} diff --git a/man/gedcomLonToNumeric.Rd b/man/gedcomLonToNumeric.Rd index d524d083..37a92d4a 100644 --- a/man/gedcomLonToNumeric.Rd +++ b/man/gedcomLonToNumeric.Rd @@ -19,3 +19,4 @@ signed decimal degrees. Returns `NA` for `NA` or unrecognised-prefix input. \examples{ gedcomLonToNumeric(c("E151.2093", "W0.1278", NA)) } +\keyword{internal} diff --git a/man/postProcessGedcom.Rd b/man/postProcessGedcom.Rd index f1449735..c91179e8 100644 --- a/man/postProcessGedcom.Rd +++ b/man/postProcessGedcom.Rd @@ -8,8 +8,9 @@ postProcessGedcom( df_temp, remove_empty_cols = TRUE, combine_cols = TRUE, - parse_dates = FALSE, add_parents = TRUE, + parse_dates = FALSE, + clean_names = TRUE, skinny = TRUE, verbose = FALSE ) @@ -19,13 +20,19 @@ postProcessGedcom( \item{remove_empty_cols}{Logical indicating whether to remove columns that are entirely missing.} -\item{combine_cols}{Logical indicating whether to combine columns with duplicate values.} +\item{combine_cols}{Logical. If `TRUE`, combine redundant name columns, such +as `name_given` with `name_given_pieces` and `name_surn` with +`name_surn_pieces`, when their values do not conflict.} + +\item{add_parents}{Logical. If `TRUE`, infer `momID` and `dadID` from `FAMC` +and `FAMS` mappings during post-processing.} -\item{parse_dates}{Logical indicating whether to parse date columns into Date objects.} +\item{parse_dates}{Logical. If `TRUE`, attempt to parse date columns (e.g., `birth_date`, `death_date`) into Date objects, after removing common GEDCOM date qualifiers like "ABT", "BEF", and "AFT".} -\item{add_parents}{Logical indicating whether to add parent information.} +\item{clean_names}{Logical indicating whether to clean name columns by removing trailing slashes and squishing whitespace.} -\item{skinny}{Logical indicating whether to slim down the data frame.} +\item{skinny}{Logical. If `TRUE`, return a slimmer data frame by dropping +`FAMC`, `FAMS`, and columns that are entirely `NA` during post-processing.} \item{verbose}{Logical indicating whether to print progress messages.} } diff --git a/man/readGedcom.Rd b/man/readGedcom.Rd index 8005f773..63cd9079 100644 --- a/man/readGedcom.Rd +++ b/man/readGedcom.Rd @@ -9,39 +9,42 @@ readGedcom( file_path, verbose = FALSE, + post_process = TRUE, add_parents = TRUE, remove_empty_cols = TRUE, combine_cols = TRUE, skinny = FALSE, parse_dates = FALSE, + clean_names = TRUE, update_rate = 1000, - post_process = TRUE, ... ) readGed( file_path, verbose = FALSE, + post_process = TRUE, add_parents = TRUE, remove_empty_cols = TRUE, combine_cols = TRUE, skinny = FALSE, parse_dates = FALSE, + clean_names = TRUE, update_rate = 1000, - post_process = TRUE, ... ) readgedcom( file_path, verbose = FALSE, + post_process = TRUE, add_parents = TRUE, remove_empty_cols = TRUE, combine_cols = TRUE, skinny = FALSE, parse_dates = FALSE, + clean_names = TRUE, update_rate = 1000, - post_process = TRUE, ... ) } @@ -50,11 +53,13 @@ readgedcom( \item{verbose}{Logical. If `TRUE`, print progress messages.} +\item{post_process}{Logical. If `TRUE`, apply post-processing steps controlled +by `add_parents`, `combine_cols`, `remove_empty_cols`, `skinny`, and `parse_dates`.} + \item{add_parents}{Logical. If `TRUE`, infer `momID` and `dadID` from `FAMC` and `FAMS` mappings during post-processing.} -\item{remove_empty_cols}{Logical. If `TRUE`, drop columns that are entirely -`NA` during post-processing.} +\item{remove_empty_cols}{Logical indicating whether to remove columns that are entirely missing.} \item{combine_cols}{Logical. If `TRUE`, combine redundant name columns, such as `name_given` with `name_given_pieces` and `name_surn` with @@ -65,12 +70,11 @@ as `name_given` with `name_given_pieces` and `name_surn` with \item{parse_dates}{Logical. If `TRUE`, attempt to parse date columns (e.g., `birth_date`, `death_date`) into Date objects, after removing common GEDCOM date qualifiers like "ABT", "BEF", and "AFT".} +\item{clean_names}{Logical indicating whether to clean name columns by removing trailing slashes and squishing whitespace.} + \item{update_rate}{Numeric. Intended rate at which progress messages should be printed. Currently unused.} -\item{post_process}{Logical. If `TRUE`, apply post-processing steps controlled -by `add_parents`, `combine_cols`, `remove_empty_cols`, `skinny`, and `parse_dates`.} - \item{...}{Additional arguments. Currently unused.} } \value{ diff --git a/tests/testthat/test-readGedcom.R b/tests/testthat/test-readGedcom.R index 1eb3cf48..a8102611 100644 --- a/tests/testthat/test-readGedcom.R +++ b/tests/testthat/test-readGedcom.R @@ -80,14 +80,14 @@ test_that("readGedcom reads and parses a GEDCOM file correctly", { expect_equal(nrow(df), 2) expect_equal(df$name_given[1], "John") expect_equal(df$name_surn[1], "Doe") - expect_equal(df$name[1], "John Doe/") + expect_equal(df$name[1], "John Doe") expect_equal(df$sex[1], "M") expect_equal(df$birth_date[1], "1 JAN 1900") expect_equal(df$birth_place[1], "Someplace") expect_equal(df$attribute_children[1], NA_character_) expect_equal(df$name_given[2], "Jane") expect_equal(df$name_surn[2], "Smith") - expect_equal(df$name[2], "Jane Smith/") + expect_equal(df$name[2], "Jane Smith") expect_equal(df$sex[2], "F") expect_equal(df$birth_date[2], "2 FEB 1910") expect_equal(df$birth_place[2], "Anotherplace") @@ -213,7 +213,7 @@ test_that("readGedcom parses death event correctly", { temp_file <- tempfile(fileext = ".ged") writeLines(gedcom_content, temp_file) - df <- readGedcom(temp_file, verbose = TRUE) + df <- readGedcom(temp_file, verbose = TRUE, clean_names = FALSE) expect_true("death_date" %in% colnames(df)) expect_true("death_place" %in% colnames(df)) @@ -354,7 +354,7 @@ test_that("readGedcom parses all supported name component tags", { expect_equal(df$name_nick[1], "Jack") expect_equal(df$name_surn_pieces[1], "Doe") expect_equal(df$name_nsfx[1], "Jr.") - expect_equal(df$name_marriedsurn[1], "John Quincy /MarriedDoe/") + expect_equal(df$name_marriedsurn[1], "John Quincy /MarriedDoe") unlink(temp_file) }) diff --git a/tests/testthat/test-readGedcomlegacy.R b/tests/testthat/test-readGedcomlegacy.R index 70fe4251..24ee0fe1 100644 --- a/tests/testthat/test-readGedcomlegacy.R +++ b/tests/testthat/test-readGedcomlegacy.R @@ -14,7 +14,9 @@ test_that("readGedcom parses death event correctly for legacy", { temp_file <- tempfile(fileext = ".ged") writeLines(gedcom_content, temp_file) - df <- readGedcom(temp_file, verbose = TRUE) + df <- readGedcom(temp_file, verbose = TRUE, + clean_names = FALSE + ) df_leg <- .readGedcom.legacy(temp_file, verbose = TRUE) expect_true("death_date" %in% colnames(df_leg)) From 704417a492b2681739594e995bdae37bbe62a7c3 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Sat, 6 Jun 2026 16:54:55 -0400 Subject: [PATCH 12/20] Update helpReadGedcom.R --- R/helpReadGedcom.R | 4 ++-- man/gedcomLatToNumeric.Rd | 2 +- man/gedcomLonToNumeric.Rd | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/helpReadGedcom.R b/R/helpReadGedcom.R index 0a128f33..ac6efd49 100644 --- a/R/helpReadGedcom.R +++ b/R/helpReadGedcom.R @@ -73,7 +73,7 @@ detectGedcomVersion <- function(lines) { #' @param x Character vector of GEDCOM latitude values. #' @return Numeric vector of decimal degrees (positive = N, negative = S). #' @examples -#' gedcomLatToNumeric(c("N51.5074", "S33.8688", NA)) +#' BGmisc:::gedcomLatToNumeric(c("N51.5074", "S33.8688", NA)) #' @keywords internal gedcomLatToNumeric <- function(x) { out <- rep(NA_real_, length(x)) @@ -90,7 +90,7 @@ gedcomLatToNumeric <- function(x) { #' @param x Character vector of GEDCOM longitude values. #' @return Numeric vector of decimal degrees (positive = E, negative = W). #' @examples -#' gedcomLonToNumeric(c("E151.2093", "W0.1278", NA)) +#' BGmisc:::gedcomLonToNumeric(c("E151.2093", "W0.1278", NA)) #' @keywords internal gedcomLonToNumeric <- function(x) { out <- rep(NA_real_, length(x)) diff --git a/man/gedcomLatToNumeric.Rd b/man/gedcomLatToNumeric.Rd index 07252bf2..b81ebced 100644 --- a/man/gedcomLatToNumeric.Rd +++ b/man/gedcomLatToNumeric.Rd @@ -17,6 +17,6 @@ Converts GEDCOM-style latitude strings like `"N51.5074"` or `"S33.8688"` to signed decimal degrees. Returns `NA` for `NA` or unrecognised-prefix input. } \examples{ -gedcomLatToNumeric(c("N51.5074", "S33.8688", NA)) +BGmisc:::gedcomLatToNumeric(c("N51.5074", "S33.8688", NA)) } \keyword{internal} diff --git a/man/gedcomLonToNumeric.Rd b/man/gedcomLonToNumeric.Rd index 37a92d4a..7914d7c0 100644 --- a/man/gedcomLonToNumeric.Rd +++ b/man/gedcomLonToNumeric.Rd @@ -17,6 +17,6 @@ Converts GEDCOM-style longitude strings like `"E151.2093"` or `"W0.1278"` to signed decimal degrees. Returns `NA` for `NA` or unrecognised-prefix input. } \examples{ -gedcomLonToNumeric(c("E151.2093", "W0.1278", NA)) +BGmisc:::gedcomLonToNumeric(c("E151.2093", "W0.1278", NA)) } \keyword{internal} From 6f1a3f47e5ecdf050e34cf378cc1275577a5b14f Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Sun, 7 Jun 2026 09:54:55 -0400 Subject: [PATCH 13/20] styler --- R/helpReadGedcom.R | 24 ++++++++++++---- R/readGedcom.R | 40 +++++++++++++++----------- data-raw/df_royal92.R | 34 +++++++++++----------- tests/testthat/test-readGedcomlegacy.R | 7 +++-- 4 files changed, 63 insertions(+), 42 deletions(-) diff --git a/R/helpReadGedcom.R b/R/helpReadGedcom.R index ac6efd49..eec51cdc 100644 --- a/R/helpReadGedcom.R +++ b/R/helpReadGedcom.R @@ -41,27 +41,39 @@ collapseNames <- function(verbose, df_temp) { #' @keywords internal detectGedcomVersion <- function(lines) { head_idx <- which(grepl("^0 HEAD\\b", lines))[1L] - if (is.na(head_idx)) return("unknown") + if (is.na(head_idx)) { + return("unknown") + } # End of HEAD is the next level-0 record - if (head_idx >= length(lines)) return("unknown") + if (head_idx >= length(lines)) { + return("unknown") + } next_l0 <- which(grepl("^0 ", lines[(head_idx + 1L):length(lines)]))[1L] head_end <- if (is.na(next_l0)) length(lines) else head_idx + next_l0 - 1L head_block <- lines[head_idx:head_end] gedc_idx <- which(grepl("^1 GEDC\\b", head_block))[1L] - if (is.na(gedc_idx)) return("unknown") + if (is.na(gedc_idx)) { + return("unknown") + } # Guard: if GEDC is the last line of HEAD, there is no VERS to look ahead to - if (gedc_idx >= length(head_block)) return("unknown") + if (gedc_idx >= length(head_block)) { + return("unknown") + } # Look ahead within HEAD block for the VERS line under GEDC lookahead <- head_block[seq(gedc_idx + 1L, min(gedc_idx + 5L, length(head_block)))] vers_line <- lookahead[grepl("^2 VERS\\b", lookahead)][1L] - if (is.na(vers_line)) return("unknown") + if (is.na(vers_line)) { + return("unknown") + } val <- extractInfo(vers_line, "VERS") - if (is.na(val) || !nzchar(val)) return("unknown") + if (is.na(val) || !nzchar(val)) { + return("unknown") + } val } diff --git a/R/readGedcom.R b/R/readGedcom.R index 6f4a8c0f..45c32d06 100644 --- a/R/readGedcom.R +++ b/R/readGedcom.R @@ -119,7 +119,6 @@ readGedcom <- function(file_path, parse_dates = FALSE, clean_names = TRUE, update_rate = 1000, - ...) { # Ensure the file exists and read all lines. if (!file.exists(file_path)) { @@ -383,7 +382,9 @@ extractEventSubBlock <- function(block, start_idx) { n <- length(block) # start_idx is always within bounds because it comes from a bounded loop in the caller, # but guard defensively to avoid the descending-sequence pitfall of R's : operator. - if (start_idx >= n) return(character(0)) + if (start_idx >= n) { + return(character(0)) + } end_idx <- start_idx for (j in (start_idx + 1L):n) { lvl <- extractGedcomLevel(block[j]) @@ -391,14 +392,18 @@ extractEventSubBlock <- function(block, start_idx) { if (lvl <= event_level) break end_idx <- j } - if (end_idx == start_idx) return(character(0)) + if (end_idx == start_idx) { + return(character(0)) + } block[(start_idx + 1L):end_idx] } extractInfoFromLines <- function(lines, tag) { pattern <- paste0("\\b", tag, "\\b") matches <- lines[grepl(pattern, lines)] - if (length(matches) == 0L) return(NA_character_) + if (length(matches) == 0L) { + return(NA_character_) + } extractInfo(matches[1L], tag) } @@ -409,7 +414,9 @@ extractCoordFromSubBlock <- function(sub_block, tag) { # GEDCOM 7.x: LATI/LONG under MAP under PLAC (level+3) pattern <- paste0("\\b", tag, "\\b") matches <- sub_block[grepl(pattern, sub_block)] - if (length(matches) == 0L) return(NA_character_) + if (length(matches) == 0L) { + return(NA_character_) + } extractInfo(matches[1L], tag) } @@ -425,7 +432,9 @@ extractCoordFromSubBlock <- function(sub_block, tag) { #' @return The updated record with parsed event information. processEventLine <- function(event, block, i, record, pattern_rows) { sub_block <- extractEventSubBlock(block, i) - if (length(sub_block) == 0L) return(record) + if (length(sub_block) == 0L) { + return(record) + } event_level <- extractGedcomLevel(block[i]) direct_children <- sub_block[ @@ -466,10 +475,10 @@ applyTagMappings <- function(line, record, pattern_rows, tag_mappings) { for (mapping in tag_mappings) { extractor <- if (is.null(mapping$extractor)) NULL else mapping$extractor result <- processTag(mapping$tag, - mapping$field, - pattern_rows, line, record, - extractor = extractor, - mode = mapping$mode + mapping$field, + pattern_rows, line, record, + extractor = extractor, + mode = mapping$mode ) record <- result$vars if (result$matched) { @@ -634,7 +643,7 @@ postProcessGedcom <- function(df_temp, df_temp[date_cols[date_cols %in% colnames(df_temp)]], function(col) any(grepl(date_qualifier_regex, col, perl = TRUE)) )) - if (has_qualifiers==TRUE) { + if (has_qualifiers == TRUE) { message("Found date qualifiers in date columns. They will be removed before parsing.") } } @@ -656,17 +665,16 @@ postProcessGedcom <- function(df_temp, if (clean_names == TRUE) { if (verbose == TRUE) message("Cleaning column names") name_cols <- grep("^name", colnames(df_temp), value = TRUE) - if (verbose == TRUE && any(name_cols %in% colnames(df_temp))) { + if (verbose == TRUE && any(name_cols %in% colnames(df_temp))) { message("Cleaning name columns: ", paste(name_cols, collapse = ", ")) - } + } df_temp[name_cols] <- lapply(df_temp[name_cols], function(x) { if (is.character(x)) { # remove / at end of names if present, and squish whitespace - stringr::str_squish(stringr::str_replace(x,"/+$", "")) + stringr::str_squish(stringr::str_replace(x, "/+$", "")) } else { x } - } - ) + }) } if (skinny == TRUE) { if (verbose == TRUE) message("Slimming down the data frame") diff --git a/data-raw/df_royal92.R b/data-raw/df_royal92.R index 008f65a5..864f5a8c 100644 --- a/data-raw/df_royal92.R +++ b/data-raw/df_royal92.R @@ -1575,7 +1575,7 @@ date_overrides <- tribble( 2158, "6 NOV 1892", "8 APR 1938", # George Mountbatten, 2nd Marquess of Milford Haven; likely duplicate/identity match to personID 102 2159, "9 MAR 1963", NA_character_, # Ivar Mountbatten; living 2160, "13 SEP 1867", "3 JUL 1939", # Wilfrid Ashley, 1st Baron Mount Temple - 2162, "19 OCT 1910", "31 MAR 1989", #Hamilton Joseph Keyes O'Malley (Q75382629) + 2162, "19 OCT 1910", "31 MAR 1989", # Hamilton Joseph Keyes O'Malley (Q75382629) 2166, "1205", "1257", # Maelgwn Fychan and death year 2168, "1210", "1265", # Maredudd ap Owain and death year @@ -2065,7 +2065,7 @@ date_overrides <- tribble( 2780, "10 APR 1916", "22 DEC 2019", # Dagmar Bernadotte af Wisborg 2781, "12 JUL 1921", "3 NOV 2018", # Oscar Bernadotte af Wisborg 2782, "10 JAN 1926", NA_character_, # Catharina Bernadotte af Wisborg; living or death not found in this pass - 2789, "10 AUG 1934", NA_character_, #Miles Carl Flach + 2789, "10 AUG 1934", NA_character_, # Miles Carl Flach 2790, "22 DEC 1960", NA_character_, # Jana Camilla Flach 2829, "25 JUN 1899", "4 JAN 1977", # Margaretha of Sweden / Princess Axel of Denmark 2830, "12 AUG 1888", "14 JUL 1964", # Axel of Denmark @@ -2243,7 +2243,6 @@ date_overrides <- tribble( # 2964, 2965, and 2967 resolve the Greek/Yugoslav branch: Olga of Greece and Denmark, Prince Paul of Yugoslavia, and Elizabeth of Greece and Denmark. - name_overrides <- tribble( ~personID, ~name_override, 12, "Alexandra of Denmark (Alix)", @@ -3182,7 +3181,7 @@ royal92_cleaned <- royal92 %>% c(914) ~ "Grand Duchess of Russia", personID == 932 ~ "Princess of Prussia", personID == 1051 ~ NA_character_, - personID == 1125 ~ NA_character_, + personID == 1125 ~ NA_character_, personID == 1250 ~ "Earl of Bothwell", personID %in% c(1373, 1867) ~ "Count of Poitiers", @@ -3198,8 +3197,8 @@ royal92_cleaned <- royal92 %>% 1877, 1890, 2295 ) ~ "Earl of Gloucester", - personID %in% - c(1706,2162,2789) ~ "Captain", + personID %in% + c(1706, 2162, 2789) ~ "Captain", personID == 1802 ~ "wife of Edward the Elder", personID == 1804 ~ "son of Edward the Elder", personID == 1811 ~ "King of West Francia", @@ -3435,8 +3434,10 @@ royal92_cleaned <- royal92 %>% ) ~ "F", TRUE ~ sex ), - name = str_replace_all(name, - text_cleanup_regex) %>% + name = str_replace_all( + name, + text_cleanup_regex + ) %>% str_squish() ) @@ -3469,12 +3470,12 @@ if (FALSE) { group_split() royal92_trimmed1 <- - royal92_famid[[1]]%>% trimPedigree( - personID = "personID", - momID = "momID", - dadID = "dadID", - max_iter = 2 - ) + royal92_famid[[1]] %>% trimPedigree( + personID = "personID", + momID = "momID", + dadID = "dadID", + max_iter = 2 + ) ggped <- ggPedigreeInteractive(royal92_trimmed1, personID = "personID", @@ -3485,10 +3486,9 @@ if (FALSE) { code_male = "M", code_female = "F", add_phantoms = TRUE, - ped_packed=TRUE, + ped_packed = TRUE, ped_align = TRUE ), - tooltip_columns = c("personID", "name", "title", "birth_date", "death_date") - + tooltip_columns = c("personID", "name", "title", "birth_date", "death_date") ) } diff --git a/tests/testthat/test-readGedcomlegacy.R b/tests/testthat/test-readGedcomlegacy.R index 24ee0fe1..181794d7 100644 --- a/tests/testthat/test-readGedcomlegacy.R +++ b/tests/testthat/test-readGedcomlegacy.R @@ -14,9 +14,10 @@ test_that("readGedcom parses death event correctly for legacy", { temp_file <- tempfile(fileext = ".ged") writeLines(gedcom_content, temp_file) - df <- readGedcom(temp_file, verbose = TRUE, - clean_names = FALSE - ) + df <- readGedcom(temp_file, + verbose = TRUE, + clean_names = FALSE + ) df_leg <- .readGedcom.legacy(temp_file, verbose = TRUE) expect_true("death_date" %in% colnames(df_leg)) From 445ddbc8583b93e6e36333cc87ef1145cd1bdf1a Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Sat, 13 Jun 2026 22:17:23 -0400 Subject: [PATCH 14/20] chains --- R/addParentalChain.R | 401 +++++++++++++++++++++++++ tests/testthat/test-addParentalChain.R | 345 +++++++++++++++++++++ 2 files changed, 746 insertions(+) create mode 100644 R/addParentalChain.R create mode 100644 tests/testthat/test-addParentalChain.R diff --git a/R/addParentalChain.R b/R/addParentalChain.R new file mode 100644 index 00000000..0070d9ef --- /dev/null +++ b/R/addParentalChain.R @@ -0,0 +1,401 @@ +#' This is a convenience wrapper around [addParentalChain()] with +#' `component = "dadID"`. +#' +#' @param ped A pedigree data frame. +#' @param personID Character string giving the name of the column containing +#' individual IDs. +#' @param dadID Character string giving the name of the column containing +#' paternal IDs. +#' @param momID Character string giving the name of the column containing +#' maternal IDs. +#' @param chain_col Character string giving the name of the output list-column +#' that will contain the ordered paternal ancestor chain for each individual. +#' @param chain_string_col Character string giving the name of the output +#' character column that will contain the collapsed paternal ancestor chain. +#' @param collapse Character string used to collapse ancestor IDs into +#' `chain_string_col`. +#' +#' @return A data frame with two added columns: +#' \describe{ +#' \item{`chain_col`}{A list-column containing the ordered paternal ancestor +#' chain for each individual.} +#' \item{`chain_string_col`}{A character column containing the collapsed +#' paternal ancestor chain, or `NA_character_` when no paternal ancestors are +#' found.} +#' } +#' +#' @export +addPaternalChain <- function( + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "dadID_chain", + chain_string_col = "dadID_chain_string", + collapse = "|" +) { +addParentalChain( + ped = ped, + personID = personID, + dadID = dadID, + momID = momID, + chain_col = chain_col, + chain_string_col = chain_string_col, + collapse = collapse, + component = "dadID" +) +} + +#' Add maternal ancestor chains to a pedigree +#' +#' Adds an ordered maternal ancestor chain for each individual in a pedigree. +#' The chain follows only mother-to-mother links, so the resulting chain is: +#' mother, maternal grandmother, maternal great-grandmother, and so on. +#' +#' This is a convenience wrapper around [addParentalChain()] with +#' `component = "momID"`. +#' +#' @param ped A pedigree data frame. +#' @param personID Character string giving the name of the column containing +#' individual IDs. +#' @param dadID Character string giving the name of the column containing +#' paternal IDs. +#' @param momID Character string giving the name of the column containing +#' maternal IDs. +#' @param chain_col Character string giving the name of the output list-column +#' that will contain the ordered maternal ancestor chain for each individual. +#' @param chain_string_col Character string giving the name of the output +#' character column that will contain the collapsed maternal ancestor chain. +#' @param collapse Character string used to collapse ancestor IDs into +#' `chain_string_col`. +#' +#' @return A data frame with two added columns: +#' \describe{ +#' \item{`chain_col`}{A list-column containing the ordered maternal ancestor +#' chain for each individual.} +#' \item{`chain_string_col`}{A character column containing the collapsed +#' maternal ancestor chain, or `NA_character_` when no maternal ancestors are +#' found.} +#' } +#' +#' @export + +addMaternalChain <- function( + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "momID_chain", + chain_string_col = "momID_chain_string", + collapse = "|" +) { +addParentalChain( + ped = ped, + personID = personID, + dadID = dadID, + momID = momID, + chain_col = chain_col, + chain_string_col = chain_string_col, + collapse = collapse, + component = "momID" +) +} +#' Add unilineal parental ancestor chains to a pedigree +#' +#' Adds an ordered unilineal parental ancestor chain for each individual in a +#' pedigree. The chain can follow either paternal links only or maternal links +#' only. +#' +#' For `component = "dadID"`, the chain follows: +#' father, paternal grandfather, paternal great-grandfather, and so on. +#' +#' For `component = "momID"`, the chain follows: +#' mother, maternal grandmother, maternal great-grandmother, and so on. +#' +#' The function constructs a parent-specific version of the pedigree, converts it +#' to a graph using [ped2graph()], identifies reachable ancestors for each +#' individual, orders those ancestors by graph distance from the focal +#' individual, and adds both a list-column representation and a collapsed string +#' representation to the original pedigree. +#' +#' @param ped A pedigree data frame. +#' @param personID Character string giving the name of the column containing +#' individual IDs. +#' @param dadID Character string giving the name of the column containing +#' paternal IDs. +#' @param momID Character string giving the name of the column containing +#' maternal IDs. +#' @param chain_col Character string giving the name of the output list-column +#' that will contain the ordered parental ancestor chain for each individual. +#' @param chain_string_col Character string giving the name of the output +#' character column that will contain the collapsed parental ancestor chain. +#' @param collapse Character string used to collapse ancestor IDs into +#' `chain_string_col`. +#' @param component Character string specifying which parental component to +#' follow. Must be either `"dadID"` for paternal chains or `"momID"` for +#' maternal chains. +#' +#' @return A data frame with two added columns: +#' \describe{ +#' \item{`chain_col`}{A list-column containing the ordered unilineal parental +#' ancestor chain for each individual.} +#' \item{`chain_string_col`}{A character column containing the collapsed +#' ancestor chain, or `NA_character_` when no ancestors are found in the +#' selected component.} +#' } +#' +#' @details +#' All pedigree IDs used to construct the parent-specific graph are coerced to +#' character. Individuals that are not represented as graph vertices receive an +#' empty chain in `chain_col` and `NA_character_` in `chain_string_col`. +#' +#' The ordering of each chain is based on graph distance from the focal +#' individual, where distance 1 is the selected parent, distance 2 is the +#' selected parent's same-component parent, and so forth. +#' +#' @importFrom igraph V subcomponent distances +#' +#' @export + +addParentalChain <- function( + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "chain", + chain_string_col = "chain_string", + collapse = "|", + component = c("dadID", "momID") +) { + + # Build a paternal-only version of the pedigree. + # This removes maternal edges so the resulting graph only represents: + # person -> father -> father's father -> father's father's father. + + component <- match.arg(component) + + if (component == "momID") { + ############## + # Maternal-only pedigree. + ############## + parental_ped <- + data.frame( + personID = as.character(ped[[personID]]), + momID = as.character(ped[[momID]]), + dadID = NA_character_, + stringsAsFactors = FALSE + ) + } else if (component == "dadID") { + ############## + # Paternal-only pedigree. + ############## + parental_ped <- data.frame( + personID = as.character(ped[[personID]]), + momID = NA_character_, + dadID = as.character(ped[[dadID]]), + stringsAsFactors = FALSE + ) +} else { + stop("unknown id supplied") +} + # Use BGmisc infrastructure to convert the paternal-only pedigree into a graph. + parental_graph <- ped2graph( + parental_ped, + personID = "personID", + momID = "momID", + dadID = "dadID" + ) + + # For one person, recover the ordered paternal chain from the network. + get_ordered_parental_chain <- function(id) { + + id_chr <- as.character(id) + + # If the person is not represented as a graph vertex, return no chain. + if (!id_chr %in% igraph::V(parental_graph)$name) { + return(character(0)) + } + + # Find all nodes reachable from this person by following paternal edges. + reachable_ids <- igraph::subcomponent( + graph = parental_graph, + v = id_chr, + mode = "out" + ) %>% + names() + + # Remove the person themselves from their paternal ancestor list. + reachable_ids <- setdiff(reachable_ids, id_chr) + + # If no paternal ancestors are reachable, return no chain. + if (length(reachable_ids) == 0) { + return(character(0)) + } + + # Order ancestors by graph distance. + # Distance 1 = father. + # Distance 2 = paternal grandfather. + # Distance 3 = paternal great-grandfather. + ancestor_distances <- igraph::distances( + graph = parental_graph, + v = id_chr, + to = reachable_ids, + mode = "out" + )[1, ] + + reachable_ids[order(ancestor_distances)] + } + + # Add the ordered paternal chain as a list-column. + ped[[chain_col]] <- lapply( + ped[[personID]], + get_ordered_parental_chain + ) + + # Add a readable string version for inspection. + ped[[chain_string_col]] <- vapply( + ped[[chain_col]], + function(chain) { + if (length(chain) == 0) { + return(NA_character_) + } + + paste(chain, collapse = collapse) + }, + character(1) + ) + + ped +} + +#' Add a paternal-line descendant flag to a pedigree +#' +#' Adds a logical flag indicating whether a specified anchor individual appears +#' anywhere in each person's ordered paternal ancestor chain. +#' +#' This is a convenience wrapper around [addParentalLineFlag()] with +#' `component = "dadID"`. +#' +#' @param ped A pedigree data frame containing a paternal chain list-column. +#' @param anchor_id ID of the anchor individual to search for within each +#' person's paternal chain. +#' @param flag_col Character string giving the name of the logical output column +#' to add to `ped`. +#' @param chain_col Character string giving the name of the list-column +#' containing ordered paternal ancestor chains. +#' +#' @return A data frame with `flag_col` added. The flag is `TRUE` when +#' `anchor_id` appears in the individual's paternal chain and `FALSE` +#' otherwise. +#' +#' @export +addPaternalLineFlag <- function( + ped, + anchor_id, + flag_col, + chain_col = "dadID_chain" +) { + addParentalLineFlag( + ped = ped, + anchor_id = anchor_id, + flag_col = flag_col, + chain_col = chain_col, + component = "dadID" + ) +} + +#' Add a maternal-line descendant flag to a pedigree +#' +#' Adds a logical flag indicating whether a specified anchor individual appears +#' anywhere in each person's ordered maternal ancestor chain. +#' +#' This is a convenience wrapper around [addParentalLineFlag()] with +#' `component = "momID"`. +#' +#' @param ped A pedigree data frame containing a maternal chain list-column. +#' @param anchor_id ID of the anchor individual to search for within each +#' person's maternal chain. +#' @param flag_col Character string giving the name of the logical output column +#' to add to `ped`. +#' @param chain_col Character string giving the name of the list-column +#' containing ordered maternal ancestor chains. +#' +#' @return A data frame with `flag_col` added. The flag is `TRUE` when +#' `anchor_id` appears in the individual's maternal chain and `FALSE` +#' otherwise. +#' +#' @export +addMaternalLineFlag <- function( + ped, + anchor_id, + flag_col, + chain_col = "momID_chain" +) { + addParentalLineFlag( + ped = ped, + anchor_id = anchor_id, + flag_col = flag_col, + chain_col = chain_col, + component = "momID" + ) +} + +#' Add a unilineal parental-line descendant flag to a pedigree +#' +#' Adds a logical flag indicating whether a specified anchor individual appears +#' anywhere in each person's ordered unilineal parental ancestor chain. +#' +#' For `component = "dadID"`, the function searches the paternal chain. +#' For `component = "momID"`, the function searches the maternal chain. +#' +#' @param ped A pedigree data frame containing a parental chain list-column. +#' @param anchor_id ID of the anchor individual to search for within each +#' person's parental chain. +#' @param flag_col Character string giving the name of the logical output column +#' to add to `ped`. +#' @param chain_col Character string giving the name of the list-column +#' containing ordered parental ancestor chains. +#' @param component Character string specifying which parental component the +#' chain represents. Must be either `"dadID"` for paternal chains or `"momID"` +#' for maternal chains. +#' +#' @return A data frame with `flag_col` added. The flag is `TRUE` when +#' `anchor_id` appears in the individual's selected parental chain and `FALSE` +#' otherwise. +#' +#' @details +#' The anchor ID is coerced to character before comparison because the chain +#' columns produced by [addParentalChain()] store graph vertex names as character +#' values. +#' +#' This function assumes that `chain_col` is a list-column in which each element +#' is a character vector of ancestor IDs. Empty chains should be represented as +#' `character(0)`. +#' +#' @export +addParentalLineFlag <- function( + ped, + anchor_id, + flag_col, + chain_col, + component = c("dadID", "momID") +) { + + component <- match.arg(component) + + # Convert the anchor ID to character because the parental chain stores graph + # vertex names as character values. + anchor_id_chr <- as.character(anchor_id) + + # Create a named logical flag indicating whether the anchor appears anywhere + # in each person's ordered parental chain. + ped[[flag_col]] <- vapply( + ped[[chain_col]], + function(chain) { + anchor_id_chr %in% chain + }, + logical(1) + ) + + ped +} diff --git a/tests/testthat/test-addParentalChain.R b/tests/testthat/test-addParentalChain.R new file mode 100644 index 00000000..20cca4e7 --- /dev/null +++ b/tests/testthat/test-addParentalChain.R @@ -0,0 +1,345 @@ +get_one <- function(x, id_col, id) { + idx <- which(x[[id_col]] == id) + testthat::expect_length(idx, 1) + idx +} + +get_chain <- function(x, id_col, id, chain_col) { + x[[chain_col]][[get_one(x, id_col, id)]] +} + +get_value <- function(x, id_col, id, value_col) { + x[[value_col]][get_one(x, id_col, id)] +} + + +test_that("addPaternalChain adds ordered paternal chains", { + + ped <- data.frame( + personID = c("ego", "dad", "pat_gf", "pat_ggf", "mom", "mat_gm"), + dadID = c("dad", "pat_gf", "pat_ggf", NA, NA, NA), + momID = c("mom", NA, NA, NA, "mat_gm", NA), + stringsAsFactors = FALSE + ) + + result <- addPaternalChain(ped) + + expect_true("dadID_chain" %in% names(result)) + expect_true("dadID_chain_string" %in% names(result)) + + expect_identical( + get_chain(result, "personID", "ego", "dadID_chain"), + c("dad", "pat_gf", "pat_ggf") + ) + + expect_identical( + get_value(result, "personID", "ego", "dadID_chain_string"), + "dad|pat_gf|pat_ggf" + ) + + expect_identical( + get_chain(result, "personID", "pat_ggf", "dadID_chain"), + character(0) + ) + + expect_true( + is.na(get_value(result, "personID", "pat_ggf", "dadID_chain_string")) + ) +}) + + + +test_that("addMaternalChain adds ordered maternal chains", { + + ped <- data.frame( + personID = c("ego", "dad", "pat_gf", "mom", "mat_gm", "mat_ggm"), + dadID = c("dad", "pat_gf", NA, NA, NA, NA), + momID = c("mom", NA, NA, "mat_gm", "mat_ggm", NA), + stringsAsFactors = FALSE + ) + + result <- addMaternalChain(ped) + + expect_true("momID_chain" %in% names(result)) + expect_true("momID_chain_string" %in% names(result)) + + expect_identical( + result$momID_chain[[result$personID == "ego"]], + c("mom", "mat_gm", "mat_ggm") + ) + + expect_identical( + result$momID_chain_string[result$personID == "ego"], + "mom|mat_gm|mat_ggm" + ) + + expect_identical( + result$momID_chain[[result$personID == "mat_ggm"]], + character(0) + ) + + expect_true( + is.na(result$momID_chain_string[result$personID == "mat_ggm"]) + ) +}) + + +test_that("addParentalChain can add paternal and maternal chains with custom output columns", { + + ped <- data.frame( + personID = c("ego", "dad", "pat_gf", "mom", "mat_gm"), + dadID = c("dad", "pat_gf", NA, NA, NA), + momID = c("mom", NA, NA, "mat_gm", NA), + stringsAsFactors = FALSE + ) + + paternal_result <- addParentalChain( + ped = ped, + chain_col = "custom_pat_chain", + chain_string_col = "custom_pat_chain_string", + collapse = " > ", + component = "dadID" + ) + + maternal_result <- addParentalChain( + ped = ped, + chain_col = "custom_mat_chain", + chain_string_col = "custom_mat_chain_string", + collapse = " > ", + component = "momID" + ) + + expect_identical( + paternal_result$custom_pat_chain[[paternal_result$personID == "ego"]], + c("dad", "pat_gf") + ) + + expect_identical( + paternal_result$custom_pat_chain_string[paternal_result$personID == "ego"], + "dad > pat_gf" + ) + + expect_identical( + maternal_result$custom_mat_chain[[maternal_result$personID == "ego"]], + c("mom", "mat_gm") + ) + + expect_identical( + maternal_result$custom_mat_chain_string[maternal_result$personID == "ego"], + "mom > mat_gm" + ) +}) + + +test_that("addParentalChain works with custom input column names", { + + ped <- data.frame( + id = c("ego", "dad", "pat_gf", "mom", "mat_gm"), + father = c("dad", "pat_gf", NA, NA, NA), + mother = c("mom", NA, NA, "mat_gm", NA), + stringsAsFactors = FALSE + ) + + result <- addParentalChain( + ped = ped, + personID = "id", + dadID = "father", + momID = "mother", + chain_col = "chain", + chain_string_col = "chain_string", + component = "dadID" + ) + + expect_identical( + result$chain[[result$id == "ego"]], + c("dad", "pat_gf") + ) + + expect_identical( + result$chain_string[result$id == "ego"], + "dad|pat_gf" + ) +}) + + +test_that("addParentalChain coerces numeric IDs to character chains", { + + ped <- data.frame( + personID = c(1, 2, 3, 4, 5), + dadID = c(2, 3, NA, NA, NA), + momID = c(4, NA, NA, 5, NA) + ) + + result <- addPaternalChain(ped) + + expect_identical( + result$dadID_chain[[result$personID == 1]], + c("2", "3") + ) + + expect_identical( + result$dadID_chain_string[result$personID == 1], + "2|3" + ) +}) + + +test_that("addPaternalLineFlag flags whether anchor appears in paternal chain", { + + ped <- data.frame( + personID = c("ego", "sibling", "dad", "pat_gf", "unrelated"), + stringsAsFactors = FALSE + ) + + ped$dadID_chain <- list( + c("dad", "pat_gf"), + c("dad", "pat_gf"), + c("pat_gf"), + character(0), + character(0) + ) + + result <- addPaternalLineFlag( + ped = ped, + anchor_id = "pat_gf", + flag_col = "descends_from_pat_gf" + ) + + expect_true("descends_from_pat_gf" %in% names(result)) + + expect_identical( + result$descends_from_pat_gf, + c(TRUE, TRUE, TRUE, FALSE, FALSE) + ) +}) + + +test_that("addMaternalLineFlag flags whether anchor appears in maternal chain", { + + ped <- data.frame( + personID = c("ego", "sibling", "mom", "mat_gm", "unrelated"), + stringsAsFactors = FALSE + ) + + ped$momID_chain <- list( + c("mom", "mat_gm"), + c("mom", "mat_gm"), + c("mat_gm"), + character(0), + character(0) + ) + + result <- addMaternalLineFlag( + ped = ped, + anchor_id = "mat_gm", + flag_col = "descends_from_mat_gm" + ) + + expect_true("descends_from_mat_gm" %in% names(result)) + + expect_identical( + result$descends_from_mat_gm, + c(TRUE, TRUE, TRUE, FALSE, FALSE) + ) +}) + + +test_that("addParentalLineFlag works with explicit paternal and maternal chain columns", { + + ped <- data.frame( + personID = c("ego", "dad", "mom", "pat_gf", "mat_gm", "unrelated"), + stringsAsFactors = FALSE + ) + + ped$dadID_chain <- list( + c("dad", "pat_gf"), + c("pat_gf"), + character(0), + character(0), + character(0), + character(0) + ) + + ped$momID_chain <- list( + c("mom", "mat_gm"), + character(0), + c("mat_gm"), + character(0), + character(0), + character(0) + ) + + paternal_result <- addParentalLineFlag( + ped = ped, + anchor_id = "pat_gf", + flag_col = "paternal_flag", + chain_col = "dadID_chain", + component = "dadID" + ) + + maternal_result <- addParentalLineFlag( + ped = ped, + anchor_id = "mat_gm", + flag_col = "maternal_flag", + chain_col = "momID_chain", + component = "momID" + ) + + expect_identical( + paternal_result$paternal_flag, + c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE) + ) + + expect_identical( + maternal_result$maternal_flag, + c(TRUE, FALSE, TRUE, FALSE, FALSE, FALSE) + ) +}) + + +test_that("addParentalLineFlag coerces numeric anchor IDs to character", { + + ped <- data.frame( + personID = c(1, 2, 3, 4), + stringsAsFactors = FALSE + ) + + ped$dadID_chain <- list( + c("2", "3"), + c("3"), + character(0), + character(0) + ) + + result <- addPaternalLineFlag( + ped = ped, + anchor_id = 3, + flag_col = "has_ancestor_3" + ) + + expect_identical( + result$has_ancestor_3, + c(TRUE, TRUE, FALSE, FALSE) + ) +}) + + +test_that("addParentalLineFlag errors for invalid component", { + + ped <- data.frame( + personID = c("ego"), + stringsAsFactors = FALSE + ) + + ped$dadID_chain <- list(character(0)) + + expect_error( + addParentalLineFlag( + ped = ped, + anchor_id = "x", + flag_col = "flag", + chain_col = "dadID_chain", + component = "invalid" + ) + ) +}) From 54a18cf97ad9c6cb05b3669face0d1fe41404047 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Sat, 13 Jun 2026 22:33:12 -0400 Subject: [PATCH 15/20] addparentchains --- NAMESPACE | 9 +++ NEWS.md | 5 ++ R/addParentalChain.R | 22 ++++--- man/addMaternalChain.Rd | 57 ++++++++++++++++++ man/addMaternalLineFlag.Rd | 33 +++++++++++ man/addParentalChain.Rd | 80 ++++++++++++++++++++++++++ man/addParentalLineFlag.Rd | 52 +++++++++++++++++ man/addPaternalChain.Rd | 54 +++++++++++++++++ man/addPaternalLineFlag.Rd | 33 +++++++++++ tests/testthat/test-addParentalChain.R | 35 ++++++----- 10 files changed, 359 insertions(+), 21 deletions(-) create mode 100644 man/addMaternalChain.Rd create mode 100644 man/addMaternalLineFlag.Rd create mode 100644 man/addParentalChain.Rd create mode 100644 man/addParentalLineFlag.Rd create mode 100644 man/addPaternalChain.Rd create mode 100644 man/addPaternalLineFlag.Rd diff --git a/NAMESPACE b/NAMESPACE index 86ddec85..de1c947c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,12 @@ # Generated by roxygen2: do not edit by hand export(SimPed) +export(addMaternalChain) +export(addMaternalLineFlag) +export(addParentalChain) +export(addParentalLineFlag) +export(addPaternalChain) +export(addPaternalLineFlag) export(addPersonToPed) export(alignPhenToMatrix) export(buildFamilyGroups) @@ -73,6 +79,9 @@ export(vech) importFrom(Matrix,Diagonal) importFrom(Matrix,sparseMatrix) importFrom(data.table,as.data.table) +importFrom(igraph,V) +importFrom(igraph,distances) +importFrom(igraph,subcomponent) importFrom(stats,na.omit) importFrom(stats,pnorm) importFrom(stats,qnorm) diff --git a/NEWS.md b/NEWS.md index d1b910c5..c4574d5f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,9 @@ # BGmisc NEWS + +## Development version + +* Add building of parental chains with `addParentalChain()` and `addParentalFlag()`, so that you can easily trace maternity and paternity. This is implemented as a general function that can be used to build any type of parental chain, and a specific wrapper for maternal and paternal chains. The parental flag is a binary variable that indicates whether the individual is in the specified parental chain, which can be useful for filtering or grouping individuals based on their lineage. + ## BGmisc 1.8.0 * Optimized gedcom reader, com2links for speed and memory usage, with a focus on large pedigrees * Fixed bug in gedcom reader that resulted in document records being added to the final person in the pedigree diff --git a/R/addParentalChain.R b/R/addParentalChain.R index 0070d9ef..60a051ac 100644 --- a/R/addParentalChain.R +++ b/R/addParentalChain.R @@ -14,6 +14,7 @@ #' character column that will contain the collapsed paternal ancestor chain. #' @param collapse Character string used to collapse ancestor IDs into #' `chain_string_col`. +#' @param traversal_direction Character giving the mode of transversion: defaults to "in" #' #' @return A data frame with two added columns: #' \describe{ @@ -32,7 +33,8 @@ addPaternalChain <- function( momID = "momID", chain_col = "dadID_chain", chain_string_col = "dadID_chain_string", - collapse = "|" + collapse = "|", + traversal_direction = "in" ) { addParentalChain( ped = ped, @@ -42,7 +44,8 @@ addParentalChain( chain_col = chain_col, chain_string_col = chain_string_col, collapse = collapse, - component = "dadID" + component = "dadID", + traversal_direction = traversal_direction ) } @@ -87,7 +90,8 @@ addMaternalChain <- function( momID = "momID", chain_col = "momID_chain", chain_string_col = "momID_chain_string", - collapse = "|" + collapse = "|", + traversal_direction = "in" ) { addParentalChain( ped = ped, @@ -97,7 +101,8 @@ addParentalChain( chain_col = chain_col, chain_string_col = chain_string_col, collapse = collapse, - component = "momID" + component = "momID", + traversal_direction = traversal_direction ) } #' Add unilineal parental ancestor chains to a pedigree @@ -165,7 +170,8 @@ addParentalChain <- function( chain_col = "chain", chain_string_col = "chain_string", collapse = "|", - component = c("dadID", "momID") + component = c("dadID", "momID"), + traversal_direction = "in" ) { # Build a paternal-only version of the pedigree. @@ -220,8 +226,8 @@ addParentalChain <- function( reachable_ids <- igraph::subcomponent( graph = parental_graph, v = id_chr, - mode = "out" - ) %>% + mode = traversal_direction + ) |> names() # Remove the person themselves from their paternal ancestor list. @@ -240,7 +246,7 @@ addParentalChain <- function( graph = parental_graph, v = id_chr, to = reachable_ids, - mode = "out" + mode = traversal_direction )[1, ] reachable_ids[order(ancestor_distances)] diff --git a/man/addMaternalChain.Rd b/man/addMaternalChain.Rd new file mode 100644 index 00000000..403cc9b8 --- /dev/null +++ b/man/addMaternalChain.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addParentalChain.R +\name{addMaternalChain} +\alias{addMaternalChain} +\title{Add maternal ancestor chains to a pedigree} +\usage{ +addMaternalChain( + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "momID_chain", + chain_string_col = "momID_chain_string", + collapse = "|", + traversal_direction = "in" +) +} +\arguments{ +\item{ped}{A pedigree data frame.} + +\item{personID}{Character string giving the name of the column containing +individual IDs.} + +\item{dadID}{Character string giving the name of the column containing +paternal IDs.} + +\item{momID}{Character string giving the name of the column containing +maternal IDs.} + +\item{chain_col}{Character string giving the name of the output list-column +that will contain the ordered maternal ancestor chain for each individual.} + +\item{chain_string_col}{Character string giving the name of the output +character column that will contain the collapsed maternal ancestor chain.} + +\item{collapse}{Character string used to collapse ancestor IDs into +`chain_string_col`.} +} +\value{ +A data frame with two added columns: + \describe{ + \item{`chain_col`}{A list-column containing the ordered maternal ancestor + chain for each individual.} + \item{`chain_string_col`}{A character column containing the collapsed + maternal ancestor chain, or `NA_character_` when no maternal ancestors are + found.} + } +} +\description{ +Adds an ordered maternal ancestor chain for each individual in a pedigree. +The chain follows only mother-to-mother links, so the resulting chain is: +mother, maternal grandmother, maternal great-grandmother, and so on. +} +\details{ +This is a convenience wrapper around [addParentalChain()] with +`component = "momID"`. +} diff --git a/man/addMaternalLineFlag.Rd b/man/addMaternalLineFlag.Rd new file mode 100644 index 00000000..b99ecc1e --- /dev/null +++ b/man/addMaternalLineFlag.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addParentalChain.R +\name{addMaternalLineFlag} +\alias{addMaternalLineFlag} +\title{Add a maternal-line descendant flag to a pedigree} +\usage{ +addMaternalLineFlag(ped, anchor_id, flag_col, chain_col = "momID_chain") +} +\arguments{ +\item{ped}{A pedigree data frame containing a maternal chain list-column.} + +\item{anchor_id}{ID of the anchor individual to search for within each +person's maternal chain.} + +\item{flag_col}{Character string giving the name of the logical output column +to add to `ped`.} + +\item{chain_col}{Character string giving the name of the list-column +containing ordered maternal ancestor chains.} +} +\value{ +A data frame with `flag_col` added. The flag is `TRUE` when + `anchor_id` appears in the individual's maternal chain and `FALSE` + otherwise. +} +\description{ +Adds a logical flag indicating whether a specified anchor individual appears +anywhere in each person's ordered maternal ancestor chain. +} +\details{ +This is a convenience wrapper around [addParentalLineFlag()] with +`component = "momID"`. +} diff --git a/man/addParentalChain.Rd b/man/addParentalChain.Rd new file mode 100644 index 00000000..2e6b9138 --- /dev/null +++ b/man/addParentalChain.Rd @@ -0,0 +1,80 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addParentalChain.R +\name{addParentalChain} +\alias{addParentalChain} +\title{Add unilineal parental ancestor chains to a pedigree} +\usage{ +addParentalChain( + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "chain", + chain_string_col = "chain_string", + collapse = "|", + component = c("dadID", "momID"), + traversal_direction = "in" +) +} +\arguments{ +\item{ped}{A pedigree data frame.} + +\item{personID}{Character string giving the name of the column containing +individual IDs.} + +\item{dadID}{Character string giving the name of the column containing +paternal IDs.} + +\item{momID}{Character string giving the name of the column containing +maternal IDs.} + +\item{chain_col}{Character string giving the name of the output list-column +that will contain the ordered parental ancestor chain for each individual.} + +\item{chain_string_col}{Character string giving the name of the output +character column that will contain the collapsed parental ancestor chain.} + +\item{collapse}{Character string used to collapse ancestor IDs into +`chain_string_col`.} + +\item{component}{Character string specifying which parental component to +follow. Must be either `"dadID"` for paternal chains or `"momID"` for +maternal chains.} +} +\value{ +A data frame with two added columns: + \describe{ + \item{`chain_col`}{A list-column containing the ordered unilineal parental + ancestor chain for each individual.} + \item{`chain_string_col`}{A character column containing the collapsed + ancestor chain, or `NA_character_` when no ancestors are found in the + selected component.} + } +} +\description{ +Adds an ordered unilineal parental ancestor chain for each individual in a +pedigree. The chain can follow either paternal links only or maternal links +only. +} +\details{ +For `component = "dadID"`, the chain follows: +father, paternal grandfather, paternal great-grandfather, and so on. + +For `component = "momID"`, the chain follows: +mother, maternal grandmother, maternal great-grandmother, and so on. + +The function constructs a parent-specific version of the pedigree, converts it +to a graph using [ped2graph()], identifies reachable ancestors for each +individual, orders those ancestors by graph distance from the focal +individual, and adds both a list-column representation and a collapsed string +representation to the original pedigree. + + +All pedigree IDs used to construct the parent-specific graph are coerced to +character. Individuals that are not represented as graph vertices receive an +empty chain in `chain_col` and `NA_character_` in `chain_string_col`. + +The ordering of each chain is based on graph distance from the focal +individual, where distance 1 is the selected parent, distance 2 is the +selected parent's same-component parent, and so forth. +} diff --git a/man/addParentalLineFlag.Rd b/man/addParentalLineFlag.Rd new file mode 100644 index 00000000..c0c0cce5 --- /dev/null +++ b/man/addParentalLineFlag.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addParentalChain.R +\name{addParentalLineFlag} +\alias{addParentalLineFlag} +\title{Add a unilineal parental-line descendant flag to a pedigree} +\usage{ +addParentalLineFlag( + ped, + anchor_id, + flag_col, + chain_col, + component = c("dadID", "momID") +) +} +\arguments{ +\item{ped}{A pedigree data frame containing a parental chain list-column.} + +\item{anchor_id}{ID of the anchor individual to search for within each +person's parental chain.} + +\item{flag_col}{Character string giving the name of the logical output column +to add to `ped`.} + +\item{chain_col}{Character string giving the name of the list-column +containing ordered parental ancestor chains.} + +\item{component}{Character string specifying which parental component the +chain represents. Must be either `"dadID"` for paternal chains or `"momID"` +for maternal chains.} +} +\value{ +A data frame with `flag_col` added. The flag is `TRUE` when + `anchor_id` appears in the individual's selected parental chain and `FALSE` + otherwise. +} +\description{ +Adds a logical flag indicating whether a specified anchor individual appears +anywhere in each person's ordered unilineal parental ancestor chain. +} +\details{ +For `component = "dadID"`, the function searches the paternal chain. +For `component = "momID"`, the function searches the maternal chain. + + +The anchor ID is coerced to character before comparison because the chain +columns produced by [addParentalChain()] store graph vertex names as character +values. + +This function assumes that `chain_col` is a list-column in which each element +is a character vector of ancestor IDs. Empty chains should be represented as +`character(0)`. +} diff --git a/man/addPaternalChain.Rd b/man/addPaternalChain.Rd new file mode 100644 index 00000000..1a436565 --- /dev/null +++ b/man/addPaternalChain.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addParentalChain.R +\name{addPaternalChain} +\alias{addPaternalChain} +\title{This is a convenience wrapper around [addParentalChain()] with +`component = "dadID"`.} +\usage{ +addPaternalChain( + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "dadID_chain", + chain_string_col = "dadID_chain_string", + collapse = "|", + traversal_direction = "in" +) +} +\arguments{ +\item{ped}{A pedigree data frame.} + +\item{personID}{Character string giving the name of the column containing +individual IDs.} + +\item{dadID}{Character string giving the name of the column containing +paternal IDs.} + +\item{momID}{Character string giving the name of the column containing +maternal IDs.} + +\item{chain_col}{Character string giving the name of the output list-column +that will contain the ordered paternal ancestor chain for each individual.} + +\item{chain_string_col}{Character string giving the name of the output +character column that will contain the collapsed paternal ancestor chain.} + +\item{collapse}{Character string used to collapse ancestor IDs into + `chain_string_col`. +@param traversal_direction Character giving the mode of transversion: defaults to "in"} +} +\value{ +A data frame with two added columns: + \describe{ + \item{`chain_col`}{A list-column containing the ordered paternal ancestor + chain for each individual.} + \item{`chain_string_col`}{A character column containing the collapsed + paternal ancestor chain, or `NA_character_` when no paternal ancestors are + found.} + } +} +\description{ +This is a convenience wrapper around [addParentalChain()] with +`component = "dadID"`. +} diff --git a/man/addPaternalLineFlag.Rd b/man/addPaternalLineFlag.Rd new file mode 100644 index 00000000..58956e6c --- /dev/null +++ b/man/addPaternalLineFlag.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/addParentalChain.R +\name{addPaternalLineFlag} +\alias{addPaternalLineFlag} +\title{Add a paternal-line descendant flag to a pedigree} +\usage{ +addPaternalLineFlag(ped, anchor_id, flag_col, chain_col = "dadID_chain") +} +\arguments{ +\item{ped}{A pedigree data frame containing a paternal chain list-column.} + +\item{anchor_id}{ID of the anchor individual to search for within each +person's paternal chain.} + +\item{flag_col}{Character string giving the name of the logical output column +to add to `ped`.} + +\item{chain_col}{Character string giving the name of the list-column +containing ordered paternal ancestor chains.} +} +\value{ +A data frame with `flag_col` added. The flag is `TRUE` when + `anchor_id` appears in the individual's paternal chain and `FALSE` + otherwise. +} +\description{ +Adds a logical flag indicating whether a specified anchor individual appears +anywhere in each person's ordered paternal ancestor chain. +} +\details{ +This is a convenience wrapper around [addParentalLineFlag()] with +`component = "dadID"`. +} diff --git a/tests/testthat/test-addParentalChain.R b/tests/testthat/test-addParentalChain.R index 20cca4e7..e5d72af0 100644 --- a/tests/testthat/test-addParentalChain.R +++ b/tests/testthat/test-addParentalChain.R @@ -48,7 +48,6 @@ test_that("addPaternalChain adds ordered paternal chains", { }) - test_that("addMaternalChain adds ordered maternal chains", { ped <- data.frame( @@ -64,22 +63,22 @@ test_that("addMaternalChain adds ordered maternal chains", { expect_true("momID_chain_string" %in% names(result)) expect_identical( - result$momID_chain[[result$personID == "ego"]], + get_chain(result, "personID", "ego", "momID_chain"), c("mom", "mat_gm", "mat_ggm") ) expect_identical( - result$momID_chain_string[result$personID == "ego"], + get_value(result, "personID", "ego", "momID_chain_string"), "mom|mat_gm|mat_ggm" ) expect_identical( - result$momID_chain[[result$personID == "mat_ggm"]], + get_chain(result, "personID", "mat_ggm", "momID_chain"), character(0) ) expect_true( - is.na(result$momID_chain_string[result$personID == "mat_ggm"]) + is.na(get_value(result, "personID", "mat_ggm", "momID_chain_string")) ) }) @@ -110,22 +109,32 @@ test_that("addParentalChain can add paternal and maternal chains with custom out ) expect_identical( - paternal_result$custom_pat_chain[[paternal_result$personID == "ego"]], + get_chain(paternal_result, "personID", "ego", "custom_pat_chain"), c("dad", "pat_gf") ) expect_identical( - paternal_result$custom_pat_chain_string[paternal_result$personID == "ego"], + get_value( + paternal_result, + "personID", + "ego", + "custom_pat_chain_string" + ), "dad > pat_gf" ) expect_identical( - maternal_result$custom_mat_chain[[maternal_result$personID == "ego"]], + get_chain(maternal_result, "personID", "ego", "custom_mat_chain"), c("mom", "mat_gm") ) expect_identical( - maternal_result$custom_mat_chain_string[maternal_result$personID == "ego"], + get_value( + maternal_result, + "personID", + "ego", + "custom_mat_chain_string" + ), "mom > mat_gm" ) }) @@ -151,12 +160,12 @@ test_that("addParentalChain works with custom input column names", { ) expect_identical( - result$chain[[result$id == "ego"]], + get_chain(result, "id", "ego", "chain"), c("dad", "pat_gf") ) expect_identical( - result$chain_string[result$id == "ego"], + get_value(result, "id", "ego", "chain_string"), "dad|pat_gf" ) }) @@ -173,12 +182,12 @@ test_that("addParentalChain coerces numeric IDs to character chains", { result <- addPaternalChain(ped) expect_identical( - result$dadID_chain[[result$personID == 1]], + get_chain(result, "personID", 1, "dadID_chain"), c("2", "3") ) expect_identical( - result$dadID_chain_string[result$personID == 1], + get_value(result, "personID", 1, "dadID_chain_string"), "2|3" ) }) From c7c4685262629f695c35bd1086b0a6e12af3d7f2 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Sat, 13 Jun 2026 22:44:28 -0400 Subject: [PATCH 16/20] docs --- R/addParentalChain.R | 61 ++++++++------------------------------ man/addMaternalChain.Rd | 6 ++-- man/addMaternalLineFlag.Rd | 8 ++--- man/addParentalChain.Rd | 2 ++ man/addPaternalChain.Rd | 9 +++--- man/addPaternalLineFlag.Rd | 6 ++-- 6 files changed, 30 insertions(+), 62 deletions(-) diff --git a/R/addParentalChain.R b/R/addParentalChain.R index 60a051ac..4454fbc4 100644 --- a/R/addParentalChain.R +++ b/R/addParentalChain.R @@ -9,12 +9,12 @@ #' @param momID Character string giving the name of the column containing #' maternal IDs. #' @param chain_col Character string giving the name of the output list-column -#' that will contain the ordered paternal ancestor chain for each individual. +#' that will contain the ordered parental ancestor chain for each individual. #' @param chain_string_col Character string giving the name of the output -#' character column that will contain the collapsed paternal ancestor chain. +#' character column that will contain the collapsed parental ancestor chain. #' @param collapse Character string used to collapse ancestor IDs into #' `chain_string_col`. -#' @param traversal_direction Character giving the mode of transversion: defaults to "in" +#' @param traversal_direction Character giving the mode of transversion: defaults to "in". If set to out, will procedure a list of descendants. #' #' @return A data frame with two added columns: #' \describe{ @@ -58,19 +58,7 @@ addParentalChain( #' This is a convenience wrapper around [addParentalChain()] with #' `component = "momID"`. #' -#' @param ped A pedigree data frame. -#' @param personID Character string giving the name of the column containing -#' individual IDs. -#' @param dadID Character string giving the name of the column containing -#' paternal IDs. -#' @param momID Character string giving the name of the column containing -#' maternal IDs. -#' @param chain_col Character string giving the name of the output list-column -#' that will contain the ordered maternal ancestor chain for each individual. -#' @param chain_string_col Character string giving the name of the output -#' character column that will contain the collapsed maternal ancestor chain. -#' @param collapse Character string used to collapse ancestor IDs into -#' `chain_string_col`. +#' @inheritParams addPaternalChain #' #' @return A data frame with two added columns: #' \describe{ @@ -123,19 +111,7 @@ addParentalChain( #' individual, and adds both a list-column representation and a collapsed string #' representation to the original pedigree. #' -#' @param ped A pedigree data frame. -#' @param personID Character string giving the name of the column containing -#' individual IDs. -#' @param dadID Character string giving the name of the column containing -#' paternal IDs. -#' @param momID Character string giving the name of the column containing -#' maternal IDs. -#' @param chain_col Character string giving the name of the output list-column -#' that will contain the ordered parental ancestor chain for each individual. -#' @param chain_string_col Character string giving the name of the output -#' character column that will contain the collapsed parental ancestor chain. -#' @param collapse Character string used to collapse ancestor IDs into -#' `chain_string_col`. +#' @inheritParams addPaternalChain #' @param component Character string specifying which parental component to #' follow. Must be either `"dadID"` for paternal chains or `"momID"` for #' maternal chains. @@ -282,13 +258,13 @@ addParentalChain <- function( #' This is a convenience wrapper around [addParentalLineFlag()] with #' `component = "dadID"`. #' -#' @param ped A pedigree data frame containing a paternal chain list-column. +#' @param ped A pedigree data frame containing a parental chain list-column. #' @param anchor_id ID of the anchor individual to search for within each -#' person's paternal chain. +#' person's parental chain. #' @param flag_col Character string giving the name of the logical output column #' to add to `ped`. #' @param chain_col Character string giving the name of the list-column -#' containing ordered paternal ancestor chains. +#' containing ordered parental ancestor chains. #' #' @return A data frame with `flag_col` added. The flag is `TRUE` when #' `anchor_id` appears in the individual's paternal chain and `FALSE` @@ -318,19 +294,12 @@ addPaternalLineFlag <- function( #' This is a convenience wrapper around [addParentalLineFlag()] with #' `component = "momID"`. #' -#' @param ped A pedigree data frame containing a maternal chain list-column. -#' @param anchor_id ID of the anchor individual to search for within each -#' person's maternal chain. -#' @param flag_col Character string giving the name of the logical output column -#' to add to `ped`. -#' @param chain_col Character string giving the name of the list-column -#' containing ordered maternal ancestor chains. -#' +#' @inheritParams addPaternalLineFlag #' @return A data frame with `flag_col` added. The flag is `TRUE` when -#' `anchor_id` appears in the individual's maternal chain and `FALSE` +#' `anchor_id` appears in the individual's selected parental chain and `FALSE` #' otherwise. -#' #' @export + addMaternalLineFlag <- function( ped, anchor_id, @@ -354,13 +323,7 @@ addMaternalLineFlag <- function( #' For `component = "dadID"`, the function searches the paternal chain. #' For `component = "momID"`, the function searches the maternal chain. #' -#' @param ped A pedigree data frame containing a parental chain list-column. -#' @param anchor_id ID of the anchor individual to search for within each -#' person's parental chain. -#' @param flag_col Character string giving the name of the logical output column -#' to add to `ped`. -#' @param chain_col Character string giving the name of the list-column -#' containing ordered parental ancestor chains. +#' @inheritParams addPaternalLineFlag #' @param component Character string specifying which parental component the #' chain represents. Must be either `"dadID"` for paternal chains or `"momID"` #' for maternal chains. diff --git a/man/addMaternalChain.Rd b/man/addMaternalChain.Rd index 403cc9b8..458ec8f5 100644 --- a/man/addMaternalChain.Rd +++ b/man/addMaternalChain.Rd @@ -28,13 +28,15 @@ paternal IDs.} maternal IDs.} \item{chain_col}{Character string giving the name of the output list-column -that will contain the ordered maternal ancestor chain for each individual.} +that will contain the ordered parental ancestor chain for each individual.} \item{chain_string_col}{Character string giving the name of the output -character column that will contain the collapsed maternal ancestor chain.} +character column that will contain the collapsed parental ancestor chain.} \item{collapse}{Character string used to collapse ancestor IDs into `chain_string_col`.} + +\item{traversal_direction}{Character giving the mode of transversion: defaults to "in". If set to out, will procedure a list of descendants.} } \value{ A data frame with two added columns: diff --git a/man/addMaternalLineFlag.Rd b/man/addMaternalLineFlag.Rd index b99ecc1e..d49e9b92 100644 --- a/man/addMaternalLineFlag.Rd +++ b/man/addMaternalLineFlag.Rd @@ -7,20 +7,20 @@ addMaternalLineFlag(ped, anchor_id, flag_col, chain_col = "momID_chain") } \arguments{ -\item{ped}{A pedigree data frame containing a maternal chain list-column.} +\item{ped}{A pedigree data frame containing a parental chain list-column.} \item{anchor_id}{ID of the anchor individual to search for within each -person's maternal chain.} +person's parental chain.} \item{flag_col}{Character string giving the name of the logical output column to add to `ped`.} \item{chain_col}{Character string giving the name of the list-column -containing ordered maternal ancestor chains.} +containing ordered parental ancestor chains.} } \value{ A data frame with `flag_col` added. The flag is `TRUE` when - `anchor_id` appears in the individual's maternal chain and `FALSE` + `anchor_id` appears in the individual's selected parental chain and `FALSE` otherwise. } \description{ diff --git a/man/addParentalChain.Rd b/man/addParentalChain.Rd index 2e6b9138..c119d272 100644 --- a/man/addParentalChain.Rd +++ b/man/addParentalChain.Rd @@ -40,6 +40,8 @@ character column that will contain the collapsed parental ancestor chain.} \item{component}{Character string specifying which parental component to follow. Must be either `"dadID"` for paternal chains or `"momID"` for maternal chains.} + +\item{traversal_direction}{Character giving the mode of transversion: defaults to "in". If set to out, will procedure a list of descendants.} } \value{ A data frame with two added columns: diff --git a/man/addPaternalChain.Rd b/man/addPaternalChain.Rd index 1a436565..28b723fb 100644 --- a/man/addPaternalChain.Rd +++ b/man/addPaternalChain.Rd @@ -29,14 +29,15 @@ paternal IDs.} maternal IDs.} \item{chain_col}{Character string giving the name of the output list-column -that will contain the ordered paternal ancestor chain for each individual.} +that will contain the ordered parental ancestor chain for each individual.} \item{chain_string_col}{Character string giving the name of the output -character column that will contain the collapsed paternal ancestor chain.} +character column that will contain the collapsed parental ancestor chain.} \item{collapse}{Character string used to collapse ancestor IDs into - `chain_string_col`. -@param traversal_direction Character giving the mode of transversion: defaults to "in"} +`chain_string_col`.} + +\item{traversal_direction}{Character giving the mode of transversion: defaults to "in". If set to out, will procedure a list of descendants.} } \value{ A data frame with two added columns: diff --git a/man/addPaternalLineFlag.Rd b/man/addPaternalLineFlag.Rd index 58956e6c..45e16c88 100644 --- a/man/addPaternalLineFlag.Rd +++ b/man/addPaternalLineFlag.Rd @@ -7,16 +7,16 @@ addPaternalLineFlag(ped, anchor_id, flag_col, chain_col = "dadID_chain") } \arguments{ -\item{ped}{A pedigree data frame containing a paternal chain list-column.} +\item{ped}{A pedigree data frame containing a parental chain list-column.} \item{anchor_id}{ID of the anchor individual to search for within each -person's paternal chain.} +person's parental chain.} \item{flag_col}{Character string giving the name of the logical output column to add to `ped`.} \item{chain_col}{Character string giving the name of the list-column -containing ordered paternal ancestor chains.} +containing ordered parental ancestor chains.} } \value{ A data frame with `flag_col` added. The flag is `TRUE` when From f37a0276d4bbd3dc983e977e3d06ec7449d02af4 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Sat, 13 Jun 2026 23:46:46 -0400 Subject: [PATCH 17/20] Update DESCRIPTION --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index c434d854..3f043155 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: BGmisc Title: An R Package for Extended Behavior Genetics Analysis -Version: 1.8.0 +Version: 1.8.0.9 Authors@R: c( person("S. Mason", "Garrison", , "garrissm@wfu.edu", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-4804-6003")), From 8eb1bdbab505f4f046510aecacb58b116f8e5ff4 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Sat, 20 Jun 2026 19:18:37 -0400 Subject: [PATCH 18/20] no need to keep making warning --- R/checkParents.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/checkParents.R b/R/checkParents.R index d354954e..c5986d23 100644 --- a/R/checkParents.R +++ b/R/checkParents.R @@ -135,7 +135,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, cat("Step 3: Attempting to repair missing parents...\n") } - cat("REPAIR IN EARLY ALPHA\n") + # cat("REPAIR IN EARLY ALPHA\n") # Initialize a list to track changes made during repair changes <- list( corrected_mom_sex = character(0), From b45aa4099b4cb7ab2f774ef400e30a9f067f5b4b Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Sun, 5 Jul 2026 15:42:49 -0400 Subject: [PATCH 19/20] Add runmodel toggle and isPar input warning Adds a `runmodel` argument to `fitPedigreeModel()` so callers can optionally return the assembled OpenMx model without fitting it. The new parameter is wired into the function logic and documented in the Rd file. Also adds a warning in `ped2com()` when `iss`/`jss` are NULL or empty before building the `isPar` sparse matrix, improving visibility into invalid matrix-construction inputs. --- R/buildComponent.R | 6 +++++- R/buildmxPedigrees.R | 9 ++++++++- man/fitPedigreeModel.Rd | 5 ++++- 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/R/buildComponent.R b/R/buildComponent.R index e6ed8f18..e98d6e4a 100644 --- a/R/buildComponent.R +++ b/R/buildComponent.R @@ -672,6 +672,10 @@ ped2com <- function(ped, component, isPar <- loadOrComputeCheckpoint( file = checkpoint_files$isPar, compute_fn = function() { + if(is.null(iss) || is.null(jss) || length(iss) == 0 || length(jss) == 0) { + warning("Cannot construct isPar matrix: iss or jss is NULL or empty.") + } + Matrix::sparseMatrix( i = iss, j = jss, x = parVal, dims = c(config$nr, config$nr), @@ -791,7 +795,7 @@ ped2com <- function(ped, component, save_rate_parlist = config$save_rate_parlist, checkpoint_files = checkpoint_files, component = config$component, - adjacency_method = config$adjacency_method, # adjacency_method, + adjacency_method = config$adjacency_method, saveable = config$saveable, resume = config$resume, save_path = config$save_path, diff --git a/R/buildmxPedigrees.R b/R/buildmxPedigrees.R index d4050308..f2518d7a 100644 --- a/R/buildmxPedigrees.R +++ b/R/buildmxPedigrees.R @@ -345,6 +345,7 @@ buildPedigreeMx <- function(model_name, vars, group_models, #' if FALSE, use \code{mxRun}. #' @param intervals Logical. If TRUE (default), compute confidence intervals for the parameters using \code{mxSE} and \code{mxCI}. #' @param extraTries Numeric. The number of extra optimization attempts to make when \code{tryhard} is TRUE. Default is 10. +#' @param runmodel Logical. If TRUE (default), the model is fitted; if FALSE, the model is returned without fitting. #' @return A fitted OpenMx model. #' @export @@ -370,7 +371,8 @@ fitPedigreeModel <- function( tryhard = TRUE, intervals = TRUE, extraTries = 10, - condenseMatrixSlots = TRUE + condenseMatrixSlots = TRUE, + runmodel = TRUE ) { .require_openmx("fitPedigreeModel") @@ -402,11 +404,16 @@ fitPedigreeModel <- function( ci = intervals, condenseMatrixSlots = FALSE # only need to condense once ) + if(runmodel == TRUE){ if (tryhard == TRUE) { fitted_model <- OpenMx::mxTryHard(pedigree_model, silent = TRUE, extraTries = extraTries, intervals = intervals) } else { fitted_model <- OpenMx::mxRun(pedigree_model, intervals = intervals) } + } else { + fitted_model <- pedigree_model + } + fitted_model } diff --git a/man/fitPedigreeModel.Rd b/man/fitPedigreeModel.Rd index 628b1bde..152a1c5d 100644 --- a/man/fitPedigreeModel.Rd +++ b/man/fitPedigreeModel.Rd @@ -19,7 +19,8 @@ fitPedigreeModel( tryhard = TRUE, intervals = TRUE, extraTries = 10, - condenseMatrixSlots = TRUE + condenseMatrixSlots = TRUE, + runmodel = TRUE ) } \arguments{ @@ -57,6 +58,8 @@ if FALSE, use \code{mxRun}.} \item{extraTries}{Numeric. The number of extra optimization attempts to make when \code{tryhard} is TRUE. Default is 10.} \item{condenseMatrixSlots}{Logical. If TRUE, use the mxCondenseMatrixSlots wrapper to optimize memory usage for large matrices. Default is TRUE.} + +\item{runmodel}{Logical. If TRUE (default), the model is fitted; if FALSE, the model is returned without fitting.} } \value{ A fitted OpenMx model. From 48b1d1578a11799c9ce5b07db025ccc4474b57d8 Mon Sep 17 00:00:00 2001 From: Mason Garrison <6001608+smasongarrison@users.noreply.github.com> Date: Sun, 5 Jul 2026 16:27:10 -0400 Subject: [PATCH 20/20] rowless parents add rowless parent fix --- NEWS.md | 5 +- R/addParentalChain.R | 99 ++++++++++--------- R/buildComponent.R | 111 +++++++++++++++++++++- R/buildmxPedigrees.R | 12 +-- R/checkParents.R | 16 +++- data-raw/benchmark_rowlessParents.R | 126 +++++++++++++++++++++++++ man/dot-findRowlessParents.Rd | 20 ++++ man/ped2com.Rd | 6 ++ tests/testthat/test-addParentalChain.R | 10 -- tests/testthat/test-rowlessParents.R | 110 +++++++++++++++++++++ 10 files changed, 445 insertions(+), 70 deletions(-) create mode 100644 data-raw/benchmark_rowlessParents.R create mode 100644 man/dot-findRowlessParents.Rd create mode 100644 tests/testthat/test-rowlessParents.R diff --git a/NEWS.md b/NEWS.md index c4574d5f..3388d9fd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,7 +2,10 @@ ## Development version -* Add building of parental chains with `addParentalChain()` and `addParentalFlag()`, so that you can easily trace maternity and paternity. This is implemented as a general function that can be used to build any type of parental chain, and a specific wrapper for maternal and paternal chains. The parental flag is a binary variable that indicates whether the individual is in the specified parental chain, which can be useful for filtering or grouping individuals based on their lineage. +* Add building of parental chains with `addParentalChain()` and `addParentalFlag()`, so that you can easily trace maternity and paternity. This is implemented as a general function that can be used to build any parental chain, and a specific wrapper for maternal and paternal chains. The parental flag is a binary variable that indicates whether the individual is in the specified parental chain, which can be useful for filtering or grouping individuals based on their lineage. +* Fixed silent mis-scoring in `ped2com()`/`ped2add()` (and other component wrappers) when `momID`/`dadID` reference a parent ID that has no row of its own in `ped` (e.g., unrecorded founder stock, or a pedigree subset that excludes the parent's own row). Previously, `isChild_method = "partialparent"` treated such a parent as "known" (based on `momID`/`dadID` not being `NA`) while the adjacency builders correctly treated the link as absent, so the diagonal was silently understated (e.g., 0.5/0.75 instead of 1) and covariance between siblings who shared the missing parent was lost entirely. `ped2com()` now warns when this is detected. Two solutions are available in the new `repair_rowless_parents = TRUE` argument. + * \code{"rows"} (default) adds one placeholder founder row per unique missing parent ID (not one per affected child) to a working copy of \code{ped}, then restricts the returned matrix back to the original individuals via \code{keep_ids} unless \code{keep_ids} is already supplied. + * \code{"schur"} applies a Schur complement on the block-triangular RAM system -- for each missing parent, its already-known children define a rank-1 update (\code{v \%*\% t(v)}, where \code{v} is that parent's traced genetic contribution to every individual, computed from the existing RAM matrix) which is added to the relatedness matrix at the tcrossprod step. \code{"schur"} currently only supports \code{component = "additive"}. ## BGmisc 1.8.0 * Optimized gedcom reader, com2links for speed and memory usage, with a focus on large pedigrees diff --git a/R/addParentalChain.R b/R/addParentalChain.R index 4454fbc4..c0cad13b 100644 --- a/R/addParentalChain.R +++ b/R/addParentalChain.R @@ -27,16 +27,16 @@ #' #' @export addPaternalChain <- function( - ped, - personID = "personID", - dadID = "dadID", - momID = "momID", - chain_col = "dadID_chain", - chain_string_col = "dadID_chain_string", - collapse = "|", - traversal_direction = "in" + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "dadID_chain", + chain_string_col = "dadID_chain_string", + collapse = "|", + traversal_direction = "in" ) { -addParentalChain( + addParentalChain( ped = ped, personID = personID, dadID = dadID, @@ -46,7 +46,7 @@ addParentalChain( collapse = collapse, component = "dadID", traversal_direction = traversal_direction -) + ) } #' Add maternal ancestor chains to a pedigree @@ -72,16 +72,16 @@ addParentalChain( #' @export addMaternalChain <- function( - ped, - personID = "personID", - dadID = "dadID", - momID = "momID", - chain_col = "momID_chain", - chain_string_col = "momID_chain_string", - collapse = "|", - traversal_direction = "in" + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "momID_chain", + chain_string_col = "momID_chain_string", + collapse = "|", + traversal_direction = "in" ) { -addParentalChain( + addParentalChain( ped = ped, personID = personID, dadID = dadID, @@ -91,7 +91,7 @@ addParentalChain( collapse = collapse, component = "momID", traversal_direction = traversal_direction -) + ) } #' Add unilineal parental ancestor chains to a pedigree #' @@ -139,17 +139,16 @@ addParentalChain( #' @export addParentalChain <- function( - ped, - personID = "personID", - dadID = "dadID", - momID = "momID", - chain_col = "chain", - chain_string_col = "chain_string", - collapse = "|", - component = c("dadID", "momID"), - traversal_direction = "in" + ped, + personID = "personID", + dadID = "dadID", + momID = "momID", + chain_col = "chain", + chain_string_col = "chain_string", + collapse = "|", + component = c("dadID", "momID"), + traversal_direction = "in" ) { - # Build a paternal-only version of the pedigree. # This removes maternal edges so the resulting graph only represents: # person -> father -> father's father -> father's father's father. @@ -165,21 +164,21 @@ addParentalChain <- function( personID = as.character(ped[[personID]]), momID = as.character(ped[[momID]]), dadID = NA_character_, - stringsAsFactors = FALSE + stringsAsFactors = FALSE ) } else if (component == "dadID") { ############## # Paternal-only pedigree. ############## - parental_ped <- data.frame( + parental_ped <- data.frame( personID = as.character(ped[[personID]]), momID = NA_character_, dadID = as.character(ped[[dadID]]), - stringsAsFactors = FALSE + stringsAsFactors = FALSE ) -} else { - stop("unknown id supplied") -} + } else { + stop("unknown id supplied") + } # Use BGmisc infrastructure to convert the paternal-only pedigree into a graph. parental_graph <- ped2graph( parental_ped, @@ -190,7 +189,6 @@ addParentalChain <- function( # For one person, recover the ordered paternal chain from the network. get_ordered_parental_chain <- function(id) { - id_chr <- as.character(id) # If the person is not represented as a graph vertex, return no chain. @@ -272,10 +270,10 @@ addParentalChain <- function( #' #' @export addPaternalLineFlag <- function( - ped, - anchor_id, - flag_col, - chain_col = "dadID_chain" + ped, + anchor_id, + flag_col, + chain_col = "dadID_chain" ) { addParentalLineFlag( ped = ped, @@ -301,10 +299,10 @@ addPaternalLineFlag <- function( #' @export addMaternalLineFlag <- function( - ped, - anchor_id, - flag_col, - chain_col = "momID_chain" + ped, + anchor_id, + flag_col, + chain_col = "momID_chain" ) { addParentalLineFlag( ped = ped, @@ -343,13 +341,12 @@ addMaternalLineFlag <- function( #' #' @export addParentalLineFlag <- function( - ped, - anchor_id, - flag_col, - chain_col, - component = c("dadID", "momID") + ped, + anchor_id, + flag_col, + chain_col, + component = c("dadID", "momID") ) { - component <- match.arg(component) # Convert the anchor ID to character because the parental chain stores graph diff --git a/R/buildComponent.R b/R/buildComponent.R index e98d6e4a..7a7425f7 100644 --- a/R/buildComponent.R +++ b/R/buildComponent.R @@ -19,6 +19,8 @@ #' @param keep_ids character vector of IDs to retain in the final relatedness matrix. When supplied, only the rows of \code{r2} corresponding to these IDs are used in the tcrossprod, so the result is a \code{length(keep_ids) x length(keep_ids)} matrix. All columns of \code{r2} are retained during the multiplication so relatedness values remain correct. IDs not found in the pedigree are silently dropped with a warning. #' @param adjacency_method character. The method to use for computing the adjacency matrix. Options are "loop", "indexed", direct or beta #' @param isChild_method character. The method to use for computing the isChild matrix. Options are "classic" or "partialparent" +#' @param repair_rowless_parents logical. If TRUE, automatically correct for parents referenced in momID/dadID that have no row of their own in \code{ped} (e.g., unrecorded founder stock), before computing relatedness. Without this, such parents are still treated as "known" for the purposes of \code{isChild_method = "partialparent"} even though their genetic contribution cannot be traced, which understates diagonal relatedness and drops covariance between siblings who share the missing parent. How the correction is applied is controlled by \code{rowless_parents_method}. Defaults to FALSE, in which case a warning is issued instead. +#' @param rowless_parents_method character. How to apply the \code{repair_rowless_parents} correction. \code{"rows"} (default) adds one placeholder founder row per unique missing parent ID (not one per affected child) to a working copy of \code{ped}, then restricts the returned matrix back to the original individuals via \code{keep_ids} unless \code{keep_ids} is already supplied. \code{"schur"} applies a Schur complement on the block-triangular RAM system -- for each missing parent, its already-known children define a rank-1 update (\code{v \%*\% t(v)}, where \code{v} is that parent's traced genetic contribution to every individual, computed from the existing RAM matrix) which is added to the relatedness matrix at the tcrossprod step. \code{"schur"} currently only supports \code{component = "additive"}. #' @param adjBeta_method numeric The method to use for computing the building the adjacency_method matrix when using the "beta" build #' @param compress logical. If TRUE, use compression when saving the checkpoint files. Defaults to TRUE. #' @param mz_twins logical. If TRUE, merge MZ co-twin columns in the r2 matrix before tcrossprod so that MZ twins are coded with relatedness 1 instead of 0.5. Twin pairs are identified from the \code{twinID} column. When a \code{zygosity} column is also present, only pairs where both members have \code{zygosity == "MZ"} are used; otherwise all \code{twinID} pairs are assumed to be MZ. Defaults to TRUE. @@ -41,6 +43,8 @@ ped2com <- function(ped, component, keep_ids = NULL, adjacency_method = "direct", isChild_method = "partialparent", + repair_rowless_parents = FALSE, + rowless_parents_method = "rows", saveable = FALSE, resume = FALSE, save_rate = 5, @@ -71,6 +75,8 @@ ped2com <- function(ped, component, transpose_method = transpose_method, adjacency_method = adjacency_method, isChild_method = isChild_method, + repair_rowless_parents = repair_rowless_parents, + rowless_parents_method = rowless_parents_method, save_rate = save_rate, save_rate_gen = save_rate_gen, save_rate_parlist = save_rate_parlist, @@ -133,11 +139,76 @@ ped2com <- function(ped, component, )) } + # Validate the 'rowless_parents_method' argument + rowless_parents_method_options <- c("rows", "schur") + if (!config$rowless_parents_method %in% rowless_parents_method_options) { + stop(paste0( + "Invalid rowless_parents_method specified. Choose from ", + paste(rowless_parents_method_options, collapse = ", "), "." + )) + } + # "schur" is a pure argument-compatibility constraint, checked here for the + # same reason adjacency_method/transpose_method are validated up front -- + # this is NOT the correction itself running early. Components that return + # before the tcrossprod step (generation/distance/common nuclear) would + # otherwise never reach the check below and silently skip the correction. + if (isTRUE(config$repair_rowless_parents) && config$rowless_parents_method == "schur" && + config$component != "additive") { + stop( + "repair_rowless_parents = TRUE with rowless_parents_method = \"schur\" is currently ", + "only implemented for component = \"additive\". Use rowless_parents_method = \"rows\" ", + "for other components." + ) + } + # standardize colnames if (config$standardize_colnames == TRUE) { ped <- standardizeColnames(ped, verbose = config$verbose) } + # Detect parents referenced in momID/dadID that have no row of their own + # (e.g., unrecorded founder stock). Left unrepaired, isChild_method = + # "partialparent" (based on raw NA-status of momID/dadID) and the adjacency + # builders (based on actual row matches) disagree about whether such a + # parent is "known," which understates diagonal relatedness and silently + # drops covariance between siblings who share the same missing parent. + # rowless_parents_method = "rows" is handled entirely here, since it must + # mutate `ped` before anything downstream (isPar/isChild/RAM tracing) runs. + # rowless_parents_method = "schur" touches nothing here -- it needs the RAM + # matrix `r`, so its validation and correction both live at the tcrossprod + # step below, right where the relatedness matrix is actually assembled. + rowless_parents <- .findRowlessParents(ped) + if (length(rowless_parents) > 0) { + if (isTRUE(config$repair_rowless_parents) && config$rowless_parents_method == "rows") { + if (config$verbose == TRUE) { + message( + length(rowless_parents), " parent ID(s) referenced in momID/dadID have no row in `ped`. ", + "Adding one placeholder founder row per missing parent before computing relatedness.\n" + ) + } + original_ids <- ped$ID + ped <- addRowlessParents( + ped = ped, verbose = config$verbose, + validation_results = list(female_var = NA, male_var = NA) + ) + config$nr <- nrow(ped) + if (is.null(config$keep_ids)) { + keep_ids <- original_ids + config$keep_ids <- original_ids + } + } else if (!isTRUE(config$repair_rowless_parents)) { + warning( + length(rowless_parents), " parent ID(s) referenced in momID/dadID have no matching row in `ped`. ", + "isChild_method = \"", config$isChild_method, "\" and the adjacency builders will disagree about ", + "whether these parents are \"known,\" which can understate diagonal relatedness (e.g., 0.5/0.75 ", + "instead of 1) and omit covariance between siblings who share the missing parent. Set ", + "repair_rowless_parents = TRUE (with rowless_parents_method = \"rows\" or \"schur\") to correct ", + "for them, or repair `ped` yourself first with checkParentIDs(ped, repair = TRUE, parentswithoutrow = TRUE).", + call. = FALSE + ) + } + } + mz_row_pairs <- NULL mz_id_pairs <- NULL @@ -409,6 +480,44 @@ ped2com <- function(ped, component, } } } + + # --- Step 3c: Schur-complement correction for rowless parents --- + # For each parent referenced in momID/dadID with no row of its own, its + # (known) children define a rank-1 update: v = r %*% p_f, where p_f places + # `parVal` at each of that parent's children and r is the not-yet-isChild- + # scaled RAM matrix (I-A)^-1. Appending v as an extra column of r2 makes + # the upcoming tcrossprod add v %*% t(v) for free -- this is exactly the + # contribution that parent would have made had it been a real row, derived + # via a Schur complement on the block-triangular (rowless-parents-first) + # system. No row is ever added to `ped`, and the matrix's row dimension + # (and therefore dimnames) never changes. + if (length(rowless_parents) > 0 && isTRUE(config$repair_rowless_parents) && + config$rowless_parents_method == "schur") { + # component compatibility already validated up front + if (config$verbose == TRUE) { + message( + length(rowless_parents), " parent ID(s) referenced in momID/dadID have no row in `ped`. ", + "Applying an exact low-rank (Schur complement) correction for them here at the tcrossprod ", + "step; `ped` and matrix dimensions are left untouched.\n" + ) + } + p_nf <- matrix(0, + nrow = config$nr, ncol = length(rowless_parents), + dimnames = list(NULL, rowless_parents) + ) + for (j in seq_along(rowless_parents)) { + f <- rowless_parents[j] + p_nf[, j] <- parVal * ( + (!is.na(ped$momID) & ped$momID == f) + (!is.na(ped$dadID) & ped$dadID == f) + ) + } + v <- as.matrix(r %*% p_nf) + r2 <- cbind(r2, v) + if (config$verbose == TRUE) { + message("Added ", length(rowless_parents), " rank-1 rowless-parent correction column(s) to r2") + } + } + # --- Step 4: T crossproduct --- # Subset rows of r2 to target individuals if requested. @@ -672,7 +781,7 @@ ped2com <- function(ped, component, isPar <- loadOrComputeCheckpoint( file = checkpoint_files$isPar, compute_fn = function() { - if(is.null(iss) || is.null(jss) || length(iss) == 0 || length(jss) == 0) { + if (is.null(iss) || is.null(jss) || length(iss) == 0 || length(jss) == 0) { warning("Cannot construct isPar matrix: iss or jss is NULL or empty.") } diff --git a/R/buildmxPedigrees.R b/R/buildmxPedigrees.R index f2518d7a..56eeb2c1 100644 --- a/R/buildmxPedigrees.R +++ b/R/buildmxPedigrees.R @@ -404,13 +404,13 @@ fitPedigreeModel <- function( ci = intervals, condenseMatrixSlots = FALSE # only need to condense once ) - if(runmodel == TRUE){ - if (tryhard == TRUE) { - fitted_model <- OpenMx::mxTryHard(pedigree_model, silent = TRUE, extraTries = extraTries, intervals = intervals) - } else { - fitted_model <- OpenMx::mxRun(pedigree_model, intervals = intervals) - } + if (runmodel == TRUE) { + if (tryhard == TRUE) { + fitted_model <- OpenMx::mxTryHard(pedigree_model, silent = TRUE, extraTries = extraTries, intervals = intervals) } else { + fitted_model <- OpenMx::mxRun(pedigree_model, intervals = intervals) + } + } else { fitted_model <- pedigree_model } diff --git a/R/checkParents.R b/R/checkParents.R index c5986d23..44b7b46f 100644 --- a/R/checkParents.R +++ b/R/checkParents.R @@ -135,7 +135,7 @@ checkParentIDs <- function(ped, verbose = FALSE, repair = FALSE, cat("Step 3: Attempting to repair missing parents...\n") } - # cat("REPAIR IN EARLY ALPHA\n") + # cat("REPAIR IN EARLY ALPHA\n") # Initialize a list to track changes made during repair changes <- list( corrected_mom_sex = character(0), @@ -290,6 +290,20 @@ repairParentIDs <- function(ped, verbose = FALSE, ) } +#' Find Rowless Parents +#' +#' Identifies IDs referenced in momID or dadID that have no row of their own in \code{ped}. +#' Used to detect parents (e.g., unrecorded founder stock) whose genetic contribution +#' cannot be traced because their own ancestry is absent from the pedigree. +#' @param ped A dataframe representing the pedigree data with columns 'ID', 'dadID', and 'momID'. +#' @return A character/numeric vector of rowless parent IDs (empty if none). +#' @keywords internal +.findRowlessParents <- function(ped) { + all_parents <- unique(c(ped$momID, ped$dadID)) + all_parents <- all_parents[!is.na(all_parents)] + all_parents[!all_parents %in% ped$ID] +} + #' Add addRowlessParents #' #' This function adds parents who appear in momID or dadID but are missing from ID diff --git a/data-raw/benchmark_rowlessParents.R b/data-raw/benchmark_rowlessParents.R new file mode 100644 index 00000000..0cfb60cd --- /dev/null +++ b/data-raw/benchmark_rowlessParents.R @@ -0,0 +1,126 @@ +library(microbenchmark) +library(Matrix) +library(BGmisc) +library(tidyverse) + +# Build a pedigree, then strip out some founder rows so their IDs become +# "rowless parents" -- referenced in momID/dadID but with no row of their +# own -- to benchmark rowless_parents_method = "rows" vs "schur" against +# each other, the same way benchmark.R compares adjacency_method values. +makeRowlessPed <- function(kpc, Ngen, sexR = .5, marR = .7, seed = 1, drop_frac = 0.2, full = FALSE) { + set.seed(seed) + ped <- simulatePedigree(kpc = kpc, Ngen = Ngen, sexR = sexR, marR = marR) + + if (full) { + return(ped) + } + founder_ids <- ped$ID[is.na(ped$momID) & is.na(ped$dadID)] + n_drop <- floor(drop_frac * length(founder_ids)) + drop_ids <- sample(founder_ids, n_drop) + + ped[!ped$ID %in% drop_ids, ] +} +ped_small_complete <- makeRowlessPed(kpc = 3, Ngen = 5, seed = 15, full = TRUE) +ped_big_complete <- makeRowlessPed(kpc = 8, Ngen = 5, seed = 1151, full = TRUE) +ped_small <- makeRowlessPed(kpc = 3, Ngen = 5, seed = 15) +ped_big <- makeRowlessPed(kpc = 8, Ngen = 5, seed = 1151) + + +cat("small: n =", nrow(ped_small), ", rowless parents =", length(.findRowlessParents(standardizeColnames(ped_small))), "\n") +cat("big: n =", nrow(ped_big), ", rowless parents =", length(.findRowlessParents(standardizeColnames(ped_big))), "\n") + +component <- "additive" +verbose <- FALSE +saveable <- FALSE +resume <- FALSE + +benchmark_results <- microbenchmark( + rows_small = { + ped2com( + ped = ped_small, component = component, + repair_rowless_parents = TRUE, rowless_parents_method = "rows", + saveable = saveable, resume = resume, verbose = verbose, sparse = FALSE + ) + }, + base_small = { + ped2com( + ped = ped_small_complete, component = component, + repair_rowless_parents = F, + saveable = saveable, resume = resume, verbose = verbose, sparse = FALSE + ) + }, + schur_small = { + ped2com( + ped = ped_small, component = component, + repair_rowless_parents = TRUE, rowless_parents_method = "schur", + saveable = saveable, resume = resume, verbose = verbose, sparse = FALSE + ) + }, + rows_big = { + ped2com( + ped = ped_big, component = component, + repair_rowless_parents = TRUE, rowless_parents_method = "rows", + saveable = saveable, resume = resume, verbose = verbose, sparse = FALSE + ) + }, + base_big = { + ped2com( + ped = ped_big_complete, component = component, + repair_rowless_parents = F, + saveable = saveable, resume = resume, verbose = verbose, sparse = FALSE + ) + }, + schur_big = { + ped2com( + ped = ped_big, component = component, + repair_rowless_parents = TRUE, rowless_parents_method = "schur", + saveable = saveable, resume = resume, verbose = verbose, sparse = FALSE + ) + }, + times = 20 +) + +summary(benchmark_results) + +df_plot <- benchmark_results %>% mutate( + size = case_when( + expr %in% c( + "rows_small", "schur_small", + "base_small" + ) ~ "small", + expr %in% c( + "rows_big", "schur_big", + "base_big" + ) ~ "big" + ), + method = case_when( + expr %in% c("rows_small", "rows_big") ~ "rows", + expr %in% c("schur_small", "schur_big") ~ "schur", + expr %in% c("base_small", "base_big") ~ "base" + ) +) + +df_plot$method <- factor(df_plot$method, levels = c("rows", "schur", "base")) +df_plot$size <- factor(df_plot$size, levels = c("small", "big")) + +lm(time ~ method * size, data = df_plot) %>% + summary() %>% + print() + +p <- ggplot(df_plot, aes(x = method, y = time)) + + geom_boxplot(aes(fill = size), alpha = 0.5) + + labs( + title = "Rowless-Parent Correction: rows vs schur", + x = "Method", + y = "Time (nanoseconds)" + ) + + theme_minimal() + + theme(axis.text.x = element_text(angle = 45, hjust = 1)) + +p +print(benchmark_results) + +write.csv(summary(benchmark_results), + "benchmark_rowlessParents_results.csv", + row.names = FALSE +) diff --git a/man/dot-findRowlessParents.Rd b/man/dot-findRowlessParents.Rd new file mode 100644 index 00000000..2bf63fcb --- /dev/null +++ b/man/dot-findRowlessParents.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checkParents.R +\name{.findRowlessParents} +\alias{.findRowlessParents} +\title{Find Rowless Parents} +\usage{ +.findRowlessParents(ped) +} +\arguments{ +\item{ped}{A dataframe representing the pedigree data with columns 'ID', 'dadID', and 'momID'.} +} +\value{ +A character/numeric vector of rowless parent IDs (empty if none). +} +\description{ +Identifies IDs referenced in momID or dadID that have no row of their own in \code{ped}. +Used to detect parents (e.g., unrecorded founder stock) whose genetic contribution +cannot be traced because their own ancestry is absent from the pedigree. +} +\keyword{internal} diff --git a/man/ped2com.Rd b/man/ped2com.Rd index 900a1e7b..78d18b01 100644 --- a/man/ped2com.Rd +++ b/man/ped2com.Rd @@ -18,6 +18,8 @@ ped2com( keep_ids = NULL, adjacency_method = "direct", isChild_method = "partialparent", + repair_rowless_parents = FALSE, + rowless_parents_method = "rows", saveable = FALSE, resume = FALSE, save_rate = 5, @@ -61,6 +63,10 @@ ped2com( \item{isChild_method}{character. The method to use for computing the isChild matrix. Options are "classic" or "partialparent"} +\item{repair_rowless_parents}{logical. If TRUE, automatically correct for parents referenced in momID/dadID that have no row of their own in \code{ped} (e.g., unrecorded founder stock), before computing relatedness. Without this, such parents are still treated as "known" for the purposes of \code{isChild_method = "partialparent"} even though their genetic contribution cannot be traced, which understates diagonal relatedness and drops covariance between siblings who share the missing parent. How the correction is applied is controlled by \code{rowless_parents_method}. Defaults to FALSE, in which case a warning is issued instead.} + +\item{rowless_parents_method}{character. How to apply the \code{repair_rowless_parents} correction. \code{"rows"} (default) adds one placeholder founder row per unique missing parent ID (not one per affected child) to a working copy of \code{ped}, then restricts the returned matrix back to the original individuals via \code{keep_ids} unless \code{keep_ids} is already supplied. \code{"schur"} applies a Schur complement on the block-triangular RAM system -- for each missing parent, its already-known children define a rank-1 update (\code{v \%*\% t(v)}, where \code{v} is that parent's traced genetic contribution to every individual, computed from the existing RAM matrix) which is added to the relatedness matrix at the tcrossprod step. \code{"schur"} currently only supports \code{component = "additive"}.} + \item{saveable}{logical. If TRUE, save the intermediate results to disk} \item{resume}{logical. If TRUE, resume from a checkpoint} diff --git a/tests/testthat/test-addParentalChain.R b/tests/testthat/test-addParentalChain.R index e5d72af0..1ede74fb 100644 --- a/tests/testthat/test-addParentalChain.R +++ b/tests/testthat/test-addParentalChain.R @@ -14,7 +14,6 @@ get_value <- function(x, id_col, id, value_col) { test_that("addPaternalChain adds ordered paternal chains", { - ped <- data.frame( personID = c("ego", "dad", "pat_gf", "pat_ggf", "mom", "mat_gm"), dadID = c("dad", "pat_gf", "pat_ggf", NA, NA, NA), @@ -49,7 +48,6 @@ test_that("addPaternalChain adds ordered paternal chains", { test_that("addMaternalChain adds ordered maternal chains", { - ped <- data.frame( personID = c("ego", "dad", "pat_gf", "mom", "mat_gm", "mat_ggm"), dadID = c("dad", "pat_gf", NA, NA, NA, NA), @@ -84,7 +82,6 @@ test_that("addMaternalChain adds ordered maternal chains", { test_that("addParentalChain can add paternal and maternal chains with custom output columns", { - ped <- data.frame( personID = c("ego", "dad", "pat_gf", "mom", "mat_gm"), dadID = c("dad", "pat_gf", NA, NA, NA), @@ -141,7 +138,6 @@ test_that("addParentalChain can add paternal and maternal chains with custom out test_that("addParentalChain works with custom input column names", { - ped <- data.frame( id = c("ego", "dad", "pat_gf", "mom", "mat_gm"), father = c("dad", "pat_gf", NA, NA, NA), @@ -172,7 +168,6 @@ test_that("addParentalChain works with custom input column names", { test_that("addParentalChain coerces numeric IDs to character chains", { - ped <- data.frame( personID = c(1, 2, 3, 4, 5), dadID = c(2, 3, NA, NA, NA), @@ -194,7 +189,6 @@ test_that("addParentalChain coerces numeric IDs to character chains", { test_that("addPaternalLineFlag flags whether anchor appears in paternal chain", { - ped <- data.frame( personID = c("ego", "sibling", "dad", "pat_gf", "unrelated"), stringsAsFactors = FALSE @@ -224,7 +218,6 @@ test_that("addPaternalLineFlag flags whether anchor appears in paternal chain", test_that("addMaternalLineFlag flags whether anchor appears in maternal chain", { - ped <- data.frame( personID = c("ego", "sibling", "mom", "mat_gm", "unrelated"), stringsAsFactors = FALSE @@ -254,7 +247,6 @@ test_that("addMaternalLineFlag flags whether anchor appears in maternal chain", test_that("addParentalLineFlag works with explicit paternal and maternal chain columns", { - ped <- data.frame( personID = c("ego", "dad", "mom", "pat_gf", "mat_gm", "unrelated"), stringsAsFactors = FALSE @@ -307,7 +299,6 @@ test_that("addParentalLineFlag works with explicit paternal and maternal chain c test_that("addParentalLineFlag coerces numeric anchor IDs to character", { - ped <- data.frame( personID = c(1, 2, 3, 4), stringsAsFactors = FALSE @@ -334,7 +325,6 @@ test_that("addParentalLineFlag coerces numeric anchor IDs to character", { test_that("addParentalLineFlag errors for invalid component", { - ped <- data.frame( personID = c("ego"), stringsAsFactors = FALSE diff --git a/tests/testthat/test-rowlessParents.R b/tests/testthat/test-rowlessParents.R new file mode 100644 index 00000000..4a9dec5f --- /dev/null +++ b/tests/testthat/test-rowlessParents.R @@ -0,0 +1,110 @@ +ped_rowless <- data.frame( + ID = c("C1", "C2", "C3", "C4"), + momID = c("M1", "M1", "M1", NA), + dadID = c("D1", "D1", NA, NA), + sex = c(1, 0, 0, 1), + stringsAsFactors = FALSE +) +# M1 and D1 are referenced as parents but never appear as their own row +# (e.g., breeding stock imported from outside the recorded population). +# C1 & C2 are full sibs via M1+D1, C3 is a maternal half-sib via M1 only, +# C4 is an unrelated founder. + +test_that(".findRowlessParents identifies parent IDs with no row of their own", { + expect_equal(sort(.findRowlessParents(ped_rowless)), c("D1", "M1")) + expect_length(.findRowlessParents(data.frame(ID = "C1", momID = NA, dadID = NA)), 0) +}) + +test_that("ped2add warns when momID/dadID reference parents with no row", { + expect_warning( + ped2add(ped_rowless, sparse = FALSE), + "no matching row" + ) +}) + +test_that("repair_rowless_parents = TRUE fixes diagonal and sibling relatedness without warning, and does not grow the returned matrix", { + r <- expect_warning( + ped2add(ped_rowless, sparse = FALSE, repair_rowless_parents = TRUE), + NA + ) + + # Returned matrix stays at the original 4 individuals -- the placeholder + # founder rows added for M1/D1 are used internally but not returned. + expect_equal(sort(rownames(r)), c("C1", "C2", "C3", "C4")) + expect_equal(dim(r), c(4L, 4L)) + + # Diagonal should be 1 for everyone now, regardless of how many of their + # parents have their own row. + expect_equal(unname(diag(r)), rep(1, 4)) + + # Full sibs via the repaired M1+D1 founders + expect_equal(r["C1", "C2"], 0.5) + # Maternal half-sibs via the repaired M1 founder only + expect_equal(r["C1", "C3"], 0.25) + expect_equal(r["C2", "C3"], 0.25) + # Unrelated founder + expect_equal(r["C1", "C4"], 0) + expect_equal(r["C2", "C4"], 0) + expect_equal(r["C3", "C4"], 0) +}) + +test_that("repair_rowless_parents = TRUE is a no-op when there are no rowless parents", { + ped_complete <- potter + r_repaired <- ped2add(ped_complete, sparse = FALSE, repair_rowless_parents = TRUE) + r_plain <- ped2add(ped_complete, sparse = FALSE) + expect_equal(r_repaired, r_plain) +}) + +test_that("rowless_parents_method = 'schur' matches 'rows' exactly without adding any rows", { + r_rows <- ped2add(ped_rowless, sparse = FALSE, repair_rowless_parents = TRUE, rowless_parents_method = "rows") + # This toy pedigree has zero resolvable edges among the recorded individuals + # (every parent is rowless), which independently triggers a pre-existing, + # unrelated "empty isPar" warning regardless of rowless-parent handling -- + # suppress it here since it's not what this test is checking. + r_schur <- suppressWarnings( + ped2add(ped_rowless, sparse = FALSE, repair_rowless_parents = TRUE, rowless_parents_method = "schur") + ) + + expect_equal(dim(r_schur), c(4L, 4L)) + expect_equal(sort(rownames(r_schur)), c("C1", "C2", "C3", "C4")) + expect_equal( + r_schur[sort(rownames(r_schur)), sort(rownames(r_schur))], + r_rows[sort(rownames(r_rows)), sort(rownames(r_rows))] + ) + + expect_equal(unname(diag(r_schur)), rep(1, 4)) + expect_equal(r_schur["C1", "C2"], 0.5) + expect_equal(r_schur["C1", "C3"], 0.25) + expect_equal(r_schur["C2", "C3"], 0.25) + expect_equal(r_schur["C1", "C4"], 0) +}) + +test_that("rowless_parents_method = 'schur' propagates correctly to a grandchild generation", { + # F1 (rowless) -> C1 x D2 -> G1, G2 (full sibs); C1 x D3 -> G3 (paternal half-sib of G1/G2 via C1) + ped_deep <- data.frame( + ID = c("C1", "D2", "D3", "G1", "G2", "G3"), + momID = c("F1", NA, NA, "C1", "C1", "C1"), + dadID = c(NA, NA, NA, "D2", "D2", "D3"), + sex = c(0, 1, 1, 0, 1, 0), + stringsAsFactors = FALSE + ) + + r_rows <- ped2add(ped_deep, sparse = FALSE, repair_rowless_parents = TRUE, rowless_parents_method = "rows") + r_schur <- ped2add(ped_deep, sparse = FALSE, repair_rowless_parents = TRUE, rowless_parents_method = "schur") + + ids <- ped_deep$ID + expect_equal(r_schur[ids, ids], r_rows[ids, ids]) + expect_equal(unname(diag(r_schur)), rep(1, 6)) + expect_equal(r_schur["G1", "G2"], 0.5) + expect_equal(r_schur["G1", "G3"], 0.25) +}) + +test_that("rowless_parents_method = 'schur' errors for unsupported components", { + expect_error( + ped2com(ped_rowless, + component = "distance", sparse = FALSE, repair_rowless_parents = TRUE, + rowless_parents_method = "schur" + ), + "additive" + ) +})