Fix bugs

NAMESPACE

@@ -79,6 +79,7 @@ export(prs_cs_weights)
 export(qr_screen)
 export(quantile_twas_weight_pipeline)
 export(raiss)
+export(raiss_single_matrix)
 export(region_to_df)
 export(rss_analysis_pipeline)
 export(rss_basic_qc)

R/RcppExports.R

@@ -2,21 +2,22 @@
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 
 dentist_iterative_impute <- function(LD_mat, nSample, zScore, pValueThreshold, propSVD, gcControl, nIter, gPvalueThreshold, ncpus, seed, correct_chen_et_al_bug, verbose = FALSE) {
-  .Call("_pecotmr_dentist_iterative_impute", PACKAGE = "pecotmr", LD_mat, nSample, zScore, pValueThreshold, propSVD, gcControl, nIter, gPvalueThreshold, ncpus, seed, correct_chen_et_al_bug, verbose)
+    .Call('_pecotmr_dentist_iterative_impute', PACKAGE = 'pecotmr', LD_mat, nSample, zScore, pValueThreshold, propSVD, gcControl, nIter, gPvalueThreshold, ncpus, seed, correct_chen_et_al_bug, verbose)
 }
 
 rcpp_mr_ash_rss <- function(bhat, shat, z, R, var_y, n, sigma2_e, s0, w0, mu1_init, tol = 1e-8, max_iter = 1e5L, update_w0 = TRUE, update_sigma = TRUE, compute_ELBO = TRUE, standardize = FALSE, ncpus = 1L) {
-  .Call("_pecotmr_rcpp_mr_ash_rss", PACKAGE = "pecotmr", bhat, shat, z, R, var_y, n, sigma2_e, s0, w0, mu1_init, tol, max_iter, update_w0, update_sigma, compute_ELBO, standardize, ncpus)
+    .Call('_pecotmr_rcpp_mr_ash_rss', PACKAGE = 'pecotmr', bhat, shat, z, R, var_y, n, sigma2_e, s0, w0, mu1_init, tol, max_iter, update_w0, update_sigma, compute_ELBO, standardize, ncpus)
 }
 
 prs_cs_rcpp <- function(a, b, phi, bhat, maf, n, ld_blk, n_iter, n_burnin, thin, verbose, seed) {
-  .Call("_pecotmr_prs_cs_rcpp", PACKAGE = "pecotmr", a, b, phi, bhat, maf, n, ld_blk, n_iter, n_burnin, thin, verbose, seed)
+    .Call('_pecotmr_prs_cs_rcpp', PACKAGE = 'pecotmr', a, b, phi, bhat, maf, n, ld_blk, n_iter, n_burnin, thin, verbose, seed)
 }
 
 qtl_enrichment_rcpp <- function(r_gwas_pip, r_qtl_susie_fit, pi_gwas = 0, pi_qtl = 0, ImpN = 25L, shrinkage_lambda = 1.0, num_threads = 1L) {
-  .Call("_pecotmr_qtl_enrichment_rcpp", PACKAGE = "pecotmr", r_gwas_pip, r_qtl_susie_fit, pi_gwas, pi_qtl, ImpN, shrinkage_lambda, num_threads)
+    .Call('_pecotmr_qtl_enrichment_rcpp', PACKAGE = 'pecotmr', r_gwas_pip, r_qtl_susie_fit, pi_gwas, pi_qtl, ImpN, shrinkage_lambda, num_threads)
 }
 
 sdpr_rcpp <- function(bhat, LD, n, per_variant_sample_size = NULL, array = NULL, a = 0.1, c = 1.0, M = 1000L, a0k = 0.5, b0k = 0.5, iter = 1000L, burn = 200L, thin = 5L, n_threads = 1L, opt_llk = 1L, verbose = TRUE) {
-  .Call("_pecotmr_sdpr_rcpp", PACKAGE = "pecotmr", bhat, LD, n, per_variant_sample_size, array, a, c, M, a0k, b0k, iter, burn, thin, n_threads, opt_llk, verbose)
+    .Call('_pecotmr_sdpr_rcpp', PACKAGE = 'pecotmr', bhat, LD, n, per_variant_sample_size, array, a, c, M, a0k, b0k, iter, burn, thin, n_threads, opt_llk, verbose)
 }
+

R/colocboost_pipeline.R

@@ -758,7 +758,8 @@ qc_regional_data <- function(region_data,
         }
         # Perform imputation
         if (impute) {
-          impute_results <- raiss(LD_data$ref_panel, sumstat$sumstats, LD_data$combined_LD_matrix,
+          LD_matrix <- partition_LD_matrix(LD_data)
+          impute_results <- raiss(LD_data$ref_panel, sumstat$sumstats, LD_matrix, variant_indices = LD_matrix$variant_indices,
             rcond = impute_opts$rcond,
             R2_threshold = impute_opts$R2_threshold, minimum_ld = impute_opts$minimum_ld, lamb = impute_opts$lamb
           )

R/raiss.R

@@ -45,7 +45,7 @@ raiss_single_matrix <- function(ref_panel, known_zscores, LD_matrix, lamb = 0.01
   }
 
   # Extract zt, sig_t, and sig_i_t
-  zt <- known_zscores$z
+  zt <- known_zscores$z[knowns]
   sig_t <- LD_matrix[knowns, knowns, drop = FALSE]
   sig_i_t <- LD_matrix[unknowns, knowns, drop = FALSE]
 
@@ -143,7 +143,8 @@ raiss <- function(ref_panel, known_zscores, LD_matrix, variant_indices = NULL, l
     # Subset ref_panel and LD_matrix for this block
     block_indices <- match(block_variant_ids, ref_panel$variant_id)
     block_ref_panel <- ref_panel[block_indices, ]
-    block_LD_matrix <- LD_matrix[[block_id]]
+    block_LD_matrix <- LD_matrix$ld_matrices[[block_id]]
+    block_known_zscores <- known_zscores %>% filter(variant_id %in% block_variant_ids)
 
     # Check dimensions match
     if (nrow(block_LD_matrix) != nrow(block_ref_panel)) {
@@ -152,7 +153,7 @@ raiss <- function(ref_panel, known_zscores, LD_matrix, variant_indices = NULL, l
 
     # Process the block using the core function
     block_result <- raiss_single_matrix(
-      block_ref_panel, known_zscores, block_LD_matrix,
+      block_ref_panel, block_known_zscores, block_LD_matrix,
       lamb, rcond, R2_threshold, minimum_ld,
       verbose = FALSE
     )
@@ -170,9 +171,14 @@ raiss <- function(ref_panel, known_zscores, LD_matrix, variant_indices = NULL, l
   }
 
   # Combine results from all blocks
-  nofilter_results <- lapply(results_list, function(x) x$result_nofilter)
-  filter_results <- lapply(results_list, function(x) x$result_filter)
+  nofilter_results <- results_list %>% lapply(function(x) x$result_nofilter) %>% bind_rows()
+  filter_results <- results_list %>% lapply(function(x) x$result_filter) %>% bind_rows()
   ld_filtered_list <- lapply(results_list, function(x) x$LD_mat)
+  variant_list <- lapply(ld_filtered_list, function(ld) data.frame(variants = colnames(ld)) )
+  combined_LD_matrix <- create_combined_LD_matrix(
+    LD_matrices = ld_filtered_list,
+    variants = variant_list
+  )
 
   # Combine into data frames
   result_nofilter <- dplyr::bind_rows(nofilter_results) %>% arrange(pos)
@@ -182,7 +188,7 @@ raiss <- function(ref_panel, known_zscores, LD_matrix, variant_indices = NULL, l
   return(list(
     result_nofilter = result_nofilter,
     result_filter = result_filter,
-    LD_mat = ld_filtered_list
+    LD_mat = combined_LD_matrix
   ))
 }
 

R/univariate_pipeline.R

@@ -219,7 +219,8 @@ rss_analysis_pipeline <- function(
 
   # Perform imputation
   if (impute) {
-    impute_results <- raiss(LD_data$ref_panel, sumstats, partition_LD_matrix(LD_data), rcond = impute_opts$rcond, R2_threshold = impute_opts$R2_threshold, minimum_ld = impute_opts$minimum_ld, lamb = impute_opts$lamb)
+    LD_matrix <- partition_LD_matrix(LD_data)
+    impute_results <- raiss(LD_data$ref_panel, sumstats, LD_matrix, variant_indices = LD_matrix$variant_indices, rcond = impute_opts$rcond, R2_threshold = impute_opts$R2_threshold, minimum_ld = impute_opts$minimum_ld, lamb = impute_opts$lamb)
     sumstats <- impute_results$result_filter
     LD_mat <- impute_results$LD_mat
   }