Subset matrices to smallest in com2links

com2links now selects the smallest provided relationship matrix (by column count) as the ID guide, extracts IDs from it, and subsets any larger matrices to that ID set and ordering. Adds error checks when no matrices or IDs are available and emits verbose messages when subsetting. Includes unit tests covering mismatched-dimension scenarios and updates NEWS.md to document the fix.

Author: smasongarrison

NEWS.md

@@ -5,7 +5,7 @@
 * Optimized sliceFamilies to be more abstract
 * Created `.require_openmx()` to make it easier to use OpenMx functions without making OpenMx a dependency
 * Smarter string ID handling for ped2id
-
+* fixed how different sized matrixes are handled by build links
 
 # BGmisc 1.7.0.0
 * Fixed bug in parList

R/makeLinks.R

@@ -79,22 +79,45 @@ com2links <- function(
 
   # Extract individual IDs from the first available matrix.
   ids <- NULL
+  # Find the smallest matrix by ncol (avoids extracting IDs from large matrices).
+  mat_refs <- list()
+  if (!is.null(ad_ped_matrix)) mat_refs[["ad"]] <- ncol(ad_ped_matrix)
+  if (!is.null(mit_ped_matrix)) mat_refs[["mt"]] <- ncol(mit_ped_matrix)
+  if (!is.null(cn_ped_matrix)) mat_refs[["cn"]] <- ncol(cn_ped_matrix)
+
+  if (length(mat_refs) == 0L) {
+    stop("At least one relationship matrix must be provided.")
+  }
 
+  smallest <- names(which.min(unlist(mat_refs)))
+  guide_mat <- switch(smallest,
+    ad = ad_ped_matrix,
+    mt = mit_ped_matrix,
+    cn = cn_ped_matrix
+  )
 
-  if (!is.null(cn_ped_matrix)) {
-    ids <- as.numeric(dimnames(cn_ped_matrix)[[1]])
-    nc <- ncol(cn_ped_matrix)
-  } else if (!is.null(ad_ped_matrix)) {
-    ids <- as.numeric(dimnames(ad_ped_matrix)[[1]])
-    nc <- ncol(ad_ped_matrix)
-  } else if (!is.null(mit_ped_matrix)) {
-    ids <- as.numeric(dimnames(mit_ped_matrix)[[1]])
-    nc <- ncol(mit_ped_matrix)
+  # Extract IDs only from the smallest matrix.
+  guide_ids <- dimnames(guide_mat)[[1]]
+  if (is.null(guide_ids) || length(guide_ids) == 0L) {
+    stop("Could not extract IDs from the smallest matrix.")
   }
+  ids <- as.numeric(guide_ids)
+  nc <- length(ids)
 
-  if (is.null(ids)) {
-    stop("Could not extract IDs from the provided matrices.")
+  # Subset only the larger matrices to match the smallest matrix's IDs and ordering.
+  if (!is.null(ad_ped_matrix) && ncol(ad_ped_matrix) > nc) {
+    if (verbose) message("Subsetting ad_ped_matrix from ", ncol(ad_ped_matrix), " to ", nc, " IDs.")
+    ad_ped_matrix <- ad_ped_matrix[guide_ids, guide_ids, drop = FALSE]
   }
+  if (!is.null(mit_ped_matrix) && ncol(mit_ped_matrix) > nc) {
+    if (verbose) message("Subsetting mit_ped_matrix from ", ncol(mit_ped_matrix), " to ", nc, " IDs.")
+    mit_ped_matrix <- mit_ped_matrix[guide_ids, guide_ids, drop = FALSE]
+  }
+  if (!is.null(cn_ped_matrix) && ncol(cn_ped_matrix) > nc) {
+    if (verbose) message("Subsetting cn_ped_matrix from ", ncol(cn_ped_matrix), " to ", nc, " IDs.")
+    cn_ped_matrix <- cn_ped_matrix[guide_ids, guide_ids, drop = FALSE]
+  }
+
 
   # --- matrix_case construction and switch dispatch ---
   matrix_case <- paste(sort(c(

tests/testthat/test-makeLinks.R

@@ -324,3 +324,82 @@ test_that("com2links garbage collection does not affect output, using two compon
 
   expect_equal(result_gc, result_no_gc)
 })
+
+
+test_that("com2links handles mismatched matrix dimensions by subsetting to smallest", {
+  data(hazard)
+  subset_ids <- hazard$ID[seq_len(ceiling(nrow(hazard) / 2))]
+
+  ad_small <- ped2add(hazard, sparse = TRUE, keep_ids = subset_ids)
+  mit_ped_matrix <- ped2mit(hazard, sparse = TRUE)
+  cn_ped_matrix <- ped2cn(hazard, sparse = TRUE)
+
+  # All three matrices, ad is smaller
+  result_mismatch <- com2links(
+    ad_ped_matrix = ad_small,
+    mit_ped_matrix = mit_ped_matrix,
+    cn_ped_matrix = cn_ped_matrix,
+    writetodisk = FALSE
+  )
+
+  # Reference: all three matrices built from the same subset
+  result_ref <- com2links(
+    ad_ped_matrix = ad_small,
+    mit_ped_matrix = ped2mit(hazard, sparse = TRUE, keep_ids = subset_ids),
+    cn_ped_matrix = ped2cn(hazard, sparse = TRUE, keep_ids = subset_ids),
+    writetodisk = FALSE
+  )
+
+  expect_equal(result_mismatch, result_ref)
+
+  # Only IDs from the smaller matrix should appear
+  all_output_ids <- unique(c(result_mismatch$ID1, result_mismatch$ID2))
+  expect_true(all(all_output_ids %in% as.numeric(dimnames(ad_small)[[1]])))
+})
+
+test_that("com2links mismatched dimensions with two matrices", {
+  data(hazard)
+  subset_ids <- hazard$ID[seq_len(ceiling(nrow(hazard) / 2))]
+
+  ad_ped_matrix <- ped2add(hazard, sparse = TRUE)
+  cn_small <- ped2cn(hazard, sparse = TRUE, keep_ids = subset_ids)
+
+  # cn is smaller than ad
+  result_mismatch <- com2links(
+    ad_ped_matrix = ad_ped_matrix,
+    cn_ped_matrix = cn_small,
+    writetodisk = FALSE
+  )
+
+  result_ref <- com2links(
+    ad_ped_matrix = ped2add(hazard, sparse = TRUE, keep_ids = subset_ids),
+    cn_ped_matrix = cn_small,
+    writetodisk = FALSE
+  )
+
+  expect_equal(result_mismatch, result_ref)
+})
+
+test_that("com2links mismatched dimensions with mit smaller", {
+  data(hazard)
+  subset_ids <- hazard$ID[seq_len(ceiling(nrow(hazard) / 2))]
+
+  ad_ped_matrix <- ped2add(hazard, sparse = TRUE)
+  mit_small <- ped2mit(hazard, sparse = TRUE, keep_ids = subset_ids)
+
+  result_mismatch <- com2links(
+    ad_ped_matrix = ad_ped_matrix,
+    mit_ped_matrix = mit_small,
+    writetodisk = FALSE
+  )
+
+  result_ref <- com2links(
+    ad_ped_matrix = ped2add(hazard, sparse = TRUE, keep_ids = subset_ids),
+    mit_ped_matrix = mit_small,
+    writetodisk = FALSE
+  )
+
+  expect_equal(result_mismatch, result_ref)
+  expect_true(all(unique(c(result_mismatch$ID1, result_mismatch$ID2)) %in% as.numeric(dimnames(mit_small)[[1]])))
+  expect_true(all(unique(c(result_mismatch$ID1, result_mismatch$ID2)) %in% as.numeric(dimnames(ad_ped_matrix)[[1]])))
+})