add option to remove alternative isChild

Author: smasongarrison

R/convertPedigree.R

@@ -31,6 +31,7 @@ ped2com <- function(ped, component,
                     standardize.colnames = TRUE,
                     transpose_method = "tcrossprod",
                     adjacency_method = "indexed",
+                    isChild_method = "classic",
                     saveable = FALSE,
                     resume = FALSE,
                     save_rate = 5,
@@ -222,14 +223,22 @@ ped2com <- function(ped, component,
     isChild <- readRDS(checkpoint_files$isChild)
   } else {
     # isChild is the 'S' matrix from RAM
+
+    if(isChild_method == "partialparent"){
     isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) {
       .5 + .25*sum(is.na(x)) # 2 parents -> .5, 1 parent -> .75, 0 parents -> 1
     })
+    }else{
+      isChild <- apply(ped[, c("momID", "dadID")], 1, function(x) {
+        2^(-!all(is.na(x)))
+      })
+
+    }
     if (saveable) {
       saveRDS(isChild, file = checkpoint_files$isChild)
     }
-  }
 
+}
   # --- Step 2: Compute Relatedness Matrix ---
   if (resume && file.exists(checkpoint_files$r_checkpoint) && file.exists(checkpoint_files$gen_checkpoint) && file.exists(checkpoint_files$mtSum_checkpoint) && file.exists(checkpoint_files$newIsPar_checkpoint) &&
     file.exists(checkpoint_files$count_checkpoint)
@@ -659,9 +668,10 @@ compute_parent_adjacency <- function(ped, component,
                                           update_rate = update_rate,
                                           parList = parList,
                                           lens=lens,
-                                          save_rate_parlist=save_rate_parlist,
+                                          save_rate_parlist =save_rate_parlist,
                                           ...)
         }
+
     } else if (adjacency_method == "indexed") { # Garrison version
         if (lastComputed < nr) {
             list_of_adjacency <- .adjIndexed(ped=ped,
@@ -702,7 +712,7 @@ compute_parent_adjacency <- function(ped, component,
     if (saveable) {
         saveRDS(parList, file = checkpoint_files$parList)
         saveRDS(lens, file = checkpoint_files$lens)
-        if (verbose) cat("Final checkpoint saved for adjacency matrix.\n")
+        if (verbose) {cat("Final checkpoint saved for adjacency matrix.\n")}
     }
     return(list_of_adjacency)
 }

tests/testthat/test-convertPedigree.R

@@ -320,3 +320,46 @@ test_that("adjacency_method  'indexed', 'loop', and direct produce the same resu
   expect_equal(ped_gen_loop, ped_gen_direct, tolerance = tolerance)
   expect_equal(ped_gen_indexed, ped_gen_direct, tolerance = tolerance)
 })
+
+test_that("isChild_method product the same results for add matrix", {
+  data(inbreeding)
+  df <- inbreeding
+  df$momID[df$ID == 6] <- NA
+  tolerance <- 1e-10
+  # add
+  ped_add_partial <- ped2com(df, isChild_method= "partialparent",
+                             component = "additive",
+                             adjacency_method = "direct")
+  ped_add_classic <- ped2com(df, isChild_method= "classic",
+                             component = "additive", adjacency_method = "direct")
+
+  expect_equal(ped_add_partial[6,6], 1, tolerance = tolerance)
+  expect_equal(ped_add_classic[6,6], .75, tolerance = tolerance)
+  difference <- ped_add_partial - ped_add_classic
+#  expect_equal(ped_add_partial, ped_add_classic, tolerance = tolerance)
+
+  difference <- ped_add_partial - ped_add_classic
+
+  expect_gt(sum(abs(difference)),0)
+})
+
+
+
+test_that("isChild_method product the same results for mtdna matrix", {
+  data(hazard)
+  df <- hazard
+  df$momID[df$ID == 4] <- NA
+  tolerance <- 1e-10
+  # maternal
+  ped_mit_partial <- ped2com(df, isChild_method= "partialparent",
+                             component = "mitochondrial",
+                             adjacency_method = "indexed")
+  ped_mit_classic <- ped2com(df, isChild_method= "classic",
+                             component = "mitochondrial", adjacency_method = "indexed")
+  # should be the same
+  expect_equal(ped_mit_partial, ped_mit_classic, tolerance = tolerance)
+
+})
+
+
+