all keep_ids to be used on all matrices

Author: smasongarrison

R/buildComponent.R

@@ -316,6 +316,13 @@ ped2com <- function(ped, component,
   }
 
   if (config$component == "generation") { # no need to do the rest
+    gen <- .subsetKeepIds(
+      component = gen,
+      keep_ids = config$keep_ids,
+      available_ids = rownames(r),
+      config = config,
+      verbose_message = "Subsetting generation component to %d target individuals\n"
+    )
     return(gen)
   } else {
     if (config$verbose == TRUE) {
@@ -360,20 +367,14 @@ ped2com <- function(ped, component,
   # Subset rows of r2 to target individuals if requested.
   # All columns are kept so dot products use the full ancestry paths.
   if (!is.null(config$keep_ids)) {
-    idx <- match(config$keep_ids, rownames(r2))
-    missing <- config$keep_ids[is.na(idx)]
-    if (length(missing) > 0) {
-      warning(
-        length(missing), " keep_ids not found in pedigree and will be dropped: ",
-        paste(Matrix::head(missing, 5), collapse = ", "),
-        if (length(missing) > 5) " ..." else ""
-      )
-    }
-    idx <- idx[!is.na(idx)]
-    if (config$verbose == TRUE) {
-      cat(sprintf("Subsetting r2 to %d target individuals before tcrossprod\n", length(idx)))
-    }
-    r2 <- r2[idx, , drop = FALSE]
+    r2 <- .subsetKeepIds(
+      component = r2,
+      keep_ids = config$keep_ids,
+      available_ids = rownames(r2),
+      config = config,
+      verbose_message = "Subsetting r2 to %d target individuals before tcrossprod\n",
+      drop = FALSE
+    )
   }
 
   use_tcrossprod_checkpoint <- FALSE
@@ -840,3 +841,45 @@ loadOrComputeCheckpoint <- function(file, compute_fn,
   }
   list_of_adjacencies
 }
+
+
+#' Subset output to requested IDs
+#' @inheritParams ped2com
+#' @param component A component to subset.
+#' @param keep_ids Character vector of IDs to retain.
+#' @param available_ids Character vector of IDs available in \code{x}.
+#' @param verbose_message Character. Message prefix to print when \code{config$verbose == TRUE}.
+#' @param drop logical. Passed to \code{[} when subsetting matrices.
+#' @keywords internal
+.subsetKeepIds <- function(component, keep_ids = NULL, available_ids, config,
+                           verbose_message = "Subsetting to %d target individuals\n",
+                           drop = FALSE) {
+  if (is.null(keep_ids)) {
+    return(component)
+  }
+
+  idx <- match(keep_ids, available_ids)
+  missing <- keep_ids[is.na(idx)]
+
+  if (length(missing) > 0) {
+    warning(
+      length(missing), " keep_ids not found in pedigree and will be dropped: ",
+      paste(Matrix::head(missing, 5), collapse = ", "),
+      if (length(missing) > 5) " ..." else ""
+    )
+  }
+
+  idx <- idx[!is.na(idx)]
+
+  if (config$verbose == TRUE) {
+    cat(sprintf(verbose_message, length(idx)))
+  }
+
+  if (is.matrix(component) || methods::is(component, "Matrix")) {
+    component <- component[idx, , drop = drop]
+  } else {
+    component <- component[idx]
+  }
+
+  component
+}

R/buildComponentWrappers.R

@@ -19,7 +19,7 @@ ped2add <- function(ped, max_gen = 25, sparse = TRUE, verbose = FALSE,
                     compress = TRUE,
                     mz_twins = FALSE,
                     mz_method = "addtwins",
-                    force_symmetric = FALSE,
+                    force_symmetric = TRUE,
                     ...) {
   ped2com(
     ped = ped,
@@ -59,6 +59,7 @@ ped2mit <- ped2mt <- function(ped, max_gen = 25,
                               flatten_diag = FALSE,
                               standardize_colnames = TRUE,
                               transpose_method = "tcrossprod",
+                              keep_ids = NULL,
                               adjacency_method = "direct",
                               saveable = FALSE,
                               resume = FALSE,
@@ -79,6 +80,7 @@ ped2mit <- ped2mt <- function(ped, max_gen = 25,
     flatten_diag = flatten_diag,
     standardize_colnames = standardize_colnames,
     transpose_method = transpose_method,
+    keep_ids = keep_ids,
     adjacency_method = adjacency_method,
     saveable = saveable,
     resume = resume,
@@ -100,6 +102,7 @@ ped2cn <- function(ped, max_gen = 25, sparse = TRUE, verbose = FALSE,
                    gc = FALSE, flatten_diag = FALSE,
                    standardize_colnames = TRUE,
                    transpose_method = "tcrossprod",
+                   keep_ids = NULL,
                    saveable = FALSE,
                    resume = FALSE,
                    save_rate = 5,
@@ -121,6 +124,7 @@ ped2cn <- function(ped, max_gen = 25, sparse = TRUE, verbose = FALSE,
     flatten_diag = flatten_diag,
     standardize_colnames = standardize_colnames,
     transpose_method = transpose_method,
+    keep_ids = keep_ids,
     saveable = saveable,
     resume = resume,
     save_rate_gen = save_rate_gen,
@@ -140,6 +144,7 @@ ped2gen <- function(ped, max_gen = 25, sparse = TRUE, verbose = FALSE,
                     gc = FALSE, flatten_diag = FALSE,
                     standardize_colnames = TRUE,
                     transpose_method = "tcrossprod",
+                    keep_ids = NULL,
                     saveable = FALSE,
                     resume = FALSE,
                     save_rate = 5,
@@ -161,6 +166,7 @@ ped2gen <- function(ped, max_gen = 25, sparse = TRUE, verbose = FALSE,
     flatten_diag = flatten_diag,
     standardize_colnames = standardize_colnames,
     transpose_method = transpose_method,
+    keep_ids = keep_ids,
     saveable = saveable,
     resume = resume,
     save_rate_gen = save_rate_gen,
@@ -180,6 +186,21 @@ ped2gen <- function(ped, max_gen = 25, sparse = TRUE, verbose = FALSE,
 #' @export
 #'
 ped2ce <- function(ped, personID = "ID",
+                   keep_ids = NULL,
+                   sparse = FALSE, verbose = FALSE,
                    ...) {
+  if (!is.null(keep_ids)) {
+    ped <- ped[ped[[personID]] %in% keep_ids, ]
+  }
+  if (sparse) {
+    mat <- Matrix::sparseMatrix(
+      i = seq_len(nrow(ped)),
+      j = seq_len(nrow(ped)),
+      x = 1,
+      dimnames = list(ped[[personID]], ped[[personID]])
+    )
+    return(mat)
+  } else {
   matrix(1, nrow = nrow(ped), ncol = nrow(ped), dimnames = list(ped[[personID]], ped[[personID]]))
+  }
 }