Merge pull request #671 from remlapmot/fix-670

TwoSampleMR 0.7.0

Author: remlapmot

.github/workflows/test-coverage.yaml

@@ -67,7 +67,7 @@ jobs:
 
       - name: Upload test results
         if: failure()
-        uses: actions/upload-artifact@v5
+        uses: actions/upload-artifact@v6
         with:
           name: coverage-test-failures
           path: ${{ runner.temp }}/package

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: TwoSampleMR
 Title: Two Sample MR Functions and Interface to MRC Integrative
     Epidemiology Unit OpenGWAS Database
-Version: 0.6.30
+Version: 0.7.0
 Authors@R: c(
     person("Gibran", "Hemani", , "g.hemani@bristol.ac.uk", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0003-0920-1055")),

NEWS.md

@@ -1,3 +1,12 @@
+# TwoSampleMR v0.7.0
+
+(Release date 2026-02-24)
+
+* Fixed a bug in the calculation in one of the code paths for the inferred p-value in `format_data()` (thanks @j-brody)
+* Fixed the calculation of a p-value in `mr_rucker_internal()`
+* Fixed a replacement length warning in `get_population_allele_frequency()`
+* Reformatted code base with `air`
+
 # TwoSampleMR v0.6.30
 
 (Release date 2026-02-06)

R/add_rsq.r

@@ -351,7 +351,7 @@ get_population_allele_frequency <- function(af, prop, odds_ratio, prevalence) {
     co <- contingency(af[i], prop[i], odds_ratio[i])
     af_controls <- co[1, 2] / (co[1, 2] + co[2, 2])
     af_cases <- co[1, 1] / (co[1, 1] + co[2, 1])
-    af[i] <- af_controls * (1 - prevalence) + af_cases * prevalence
+    af[i] <- af_controls * (1 - prevalence[i]) + af_cases * prevalence[i]
   }
   return(af)
 }

R/format_mr_results2.R

@@ -163,8 +163,22 @@ combine_all_mrresults <- function(
 
   res <- merge(res, het, by = c("id.outcome", "id.exposure", "Method"), all.x = TRUE)
   res <- data.table::rbindlist(
-    list(res, sin[, c("exposure", "outcome", "id.exposure", "id.outcome", "SNP", "b", "se", "pval", "Method")]),
-    fill = TRUE, use.names = TRUE
+    list(
+      res,
+      sin[, c(
+        "exposure",
+        "outcome",
+        "id.exposure",
+        "id.outcome",
+        "SNP",
+        "b",
+        "se",
+        "pval",
+        "Method"
+      )]
+    ),
+    fill = TRUE,
+    use.names = TRUE
   )
   data.table::setDF(res)
 

R/harmonise.R

@@ -114,7 +114,11 @@ harmonise_data <- function(exposure_dat, outcome_dat, action = 2) {
   # 	return(x)
   # })
 
-  jlog <- data.table::rbindlist(lapply(fix.tab, function(x) attr(x, "log")), fill = TRUE, use.names = TRUE)
+  jlog <- data.table::rbindlist(
+    lapply(fix.tab, function(x) attr(x, "log")),
+    fill = TRUE,
+    use.names = TRUE
+  )
   data.table::setDF(jlog)
   fix.tab <- data.table::rbindlist(fix.tab, fill = TRUE, use.names = TRUE)
   data.table::setDF(fix.tab)
@@ -686,7 +690,8 @@ harmonise <- function(dat, tolerance, action) {
       as.data.frame(attr(d12, "log"), stringsAsFactors = FALSE),
       as.data.frame(attr(d11, "log"), stringsAsFactors = FALSE)
     ),
-    fill = TRUE, use.names = TRUE
+    fill = TRUE,
+    use.names = TRUE
   )
   data.table::setDF(jlog)
   jlog <- cbind(

R/instruments.R

@@ -22,9 +22,15 @@ extract_instruments <- function(
   opengwas_jwt = ieugwasr::get_opengwas_jwt(),
   force_server = FALSE
 ) {
-  if (!(clump %in% c(0, 1, FALSE, TRUE))) stop("The clump argument should be 0 or 1.")
-  if (clump) clump <- 1
-  if (!clump) clump <- 0
+  if (!(clump %in% c(0, 1, FALSE, TRUE))) {
+    stop("The clump argument should be 0 or 1.")
+  }
+  if (clump) {
+    clump <- 1
+  }
+  if (!clump) {
+    clump <- 0
+  }
   # .Deprecated("ieugwasr::tophits()")
   outcomes <- ieugwasr::legacy_ids(unique(outcomes))
 

R/knit.R

@@ -123,11 +123,14 @@ mr_report <- function(
   )
 
   dat_dt <- data.table::as.data.table(dat)
-  combinations <- dat_dt[, .(
-    n = .N,
-    exposure = exposure[1],
-    outcome = outcome[1]
-  ), by = c("id.exposure", "id.outcome")]
+  combinations <- dat_dt[,
+    .(
+      n = .N,
+      exposure = exposure[1],
+      outcome = outcome[1]
+    ),
+    by = c("id.exposure", "id.outcome")
+  ]
   data.table::setDF(combinations)
 
   output_file <- array("", nrow(combinations))

R/leaveoneout.R

@@ -20,7 +20,7 @@ mr_leaveoneout <- function(dat, parameters = default_parameters(), method = mr_i
 
   dat_dt <- data.table::as.data.table(dat)
   combos <- unique(dat_dt[, .(id.exposure, id.outcome)])
-  
+
   results <- lapply(seq_len(nrow(combos)), function(i) {
     exp_id <- combos$id.exposure[i]
     out_id <- combos$id.outcome[i]
@@ -104,7 +104,7 @@ mr_leaveoneout <- function(dat, parameters = default_parameters(), method = mr_i
 mr_leaveoneout_plot <- function(leaveoneout_results) {
   dat_dt <- data.table::as.data.table(leaveoneout_results)
   combos <- unique(dat_dt[, .(id.exposure, id.outcome)])
-  
+
   res <- lapply(seq_len(nrow(combos)), function(i) {
     exp_id <- combos$id.exposure[i]
     out_id <- combos$id.outcome[i]

R/mr.R

@@ -26,10 +26,10 @@ mr <- function(
   # Convert to data.table for efficient grouped operations
 
   dat_dt <- data.table::as.data.table(dat)
-  
+
   # Get unique combinations of id.exposure and id.outcome
   combos <- unique(dat_dt[, .(id.exposure, id.outcome)])
-  
+
   # Pre-compute method names once, outside the loop
   methl <- mr_method_list()
   method_names <- methl$name[match(method_list, methl$obj)]
@@ -40,7 +40,7 @@ mr <- function(
     out_id <- combos$id.outcome[i]
     x1 <- dat_dt[id.exposure == exp_id & id.outcome == out_id]
     x <- x1[mr_keep == TRUE]
-    
+
     if (nrow(x) == 0) {
       message(
         "No SNPs available for MR analysis of '",
@@ -71,7 +71,7 @@ mr <- function(
     mr_tab <- mr_tab[!(is.na(mr_tab$b) & is.na(mr_tab$se) & is.na(mr_tab$pval)), ]
     return(mr_tab)
   })
-  
+
   mr_tab <- data.table::rbindlist(results, fill = TRUE, use.names = TRUE)
   data.table::setDF(mr_tab)
 
@@ -662,12 +662,16 @@ mr_egger_regression_bootstrap <- function(b_exp, b_out, se_exp, se_out, paramete
 
   # Vectorized bootstrap: generate all random values at once
   # Matrix dimensions: nboot rows x nsnp columns
-  xs_mat <- matrix(stats::rnorm(nboot * nsnp, mean = rep(b_exp, each = nboot),
-                                sd = rep(se_exp, each = nboot)),
-                   nrow = nboot, ncol = nsnp)
-  ys_mat <- matrix(stats::rnorm(nboot * nsnp, mean = rep(b_out, each = nboot),
-                                sd = rep(se_out, each = nboot)),
-                   nrow = nboot, ncol = nsnp)
+  xs_mat <- matrix(
+    stats::rnorm(nboot * nsnp, mean = rep(b_exp, each = nboot), sd = rep(se_exp, each = nboot)),
+    nrow = nboot,
+    ncol = nsnp
+  )
+  ys_mat <- matrix(
+    stats::rnorm(nboot * nsnp, mean = rep(b_out, each = nboot), sd = rep(se_out, each = nboot)),
+    nrow = nboot,
+    ncol = nsnp
+  )
 
   # Apply sign correction for Egger regression (vectorized)
   ys_mat <- ys_mat * sign(xs_mat)
@@ -676,15 +680,19 @@ mr_egger_regression_bootstrap <- function(b_exp, b_out, se_exp, se_out, paramete
   # Vectorized weighted linear regression for all bootstrap iterations
   # For each bootstrap iteration, compute weighted regression coefficients
   # Using the formula: bhat = cov(x*w, y*w) / var(x*w), ahat = mean(y) - mean(x)*bhat
-  res <- t(vapply(seq_len(nboot), function(i) {
-    xs <- xs_mat[i, ]
-    ys <- ys_mat[i, ]
-    xw <- xs * weights
-    yw <- ys * weights
-    bhat <- stats::cov(xw, yw, use = "pair") / stats::var(xw, na.rm = TRUE)
-    ahat <- mean(ys, na.rm = TRUE) - mean(xs, na.rm = TRUE) * bhat
-    c(ahat, bhat)
-  }, numeric(2)))
+  res <- t(vapply(
+    seq_len(nboot),
+    function(i) {
+      xs <- xs_mat[i, ]
+      ys <- ys_mat[i, ]
+      xw <- xs * weights
+      yw <- ys * weights
+      bhat <- stats::cov(xw, yw, use = "pair") / stats::var(xw, na.rm = TRUE)
+      ahat <- mean(ys, na.rm = TRUE) - mean(xs, na.rm = TRUE) * bhat
+      c(ahat, bhat)
+    },
+    numeric(2)
+  ))
 
   return(list(
     b = mean(res[, 2], na.rm = TRUE),
@@ -808,20 +816,28 @@ weighted_median_bootstrap <- function(b_exp, b_out, se_exp, se_out, weights, nbo
 
   # Vectorized bootstrap: generate all random values at once
   # Matrix dimensions: nboot rows x nsnp columns
-  b_exp_mat <- matrix(stats::rnorm(nboot * nsnp, mean = rep(b_exp, each = nboot),
-                                   sd = rep(se_exp, each = nboot)),
-                      nrow = nboot, ncol = nsnp)
-  b_out_mat <- matrix(stats::rnorm(nboot * nsnp, mean = rep(b_out, each = nboot),
-                                   sd = rep(se_out, each = nboot)),
-                      nrow = nboot, ncol = nsnp)
+  b_exp_mat <- matrix(
+    stats::rnorm(nboot * nsnp, mean = rep(b_exp, each = nboot), sd = rep(se_exp, each = nboot)),
+    nrow = nboot,
+    ncol = nsnp
+  )
+  b_out_mat <- matrix(
+    stats::rnorm(nboot * nsnp, mean = rep(b_out, each = nboot), sd = rep(se_out, each = nboot)),
+    nrow = nboot,
+    ncol = nsnp
+  )
 
   # Compute Wald ratios for all bootstrap samples (element-wise division)
   betaIV_mat <- b_out_mat / b_exp_mat
 
   # Apply weighted_median to each bootstrap iteration
-  med <- vapply(seq_len(nboot), function(i) {
-    weighted_median(betaIV_mat[i, ], weights)
-  }, numeric(1))
+  med <- vapply(
+    seq_len(nboot),
+    function(i) {
+      weighted_median(betaIV_mat[i, ], weights)
+    },
+    numeric(1)
+  )
 
   return(stats::sd(med))
 }
@@ -1118,7 +1134,11 @@ mr_raps <- function(b_exp, b_out, se_exp, se_out, parameters = default_parameter
   }
 
   if (utils::packageVersion('mr.raps') < '0.4.3') {
-    message(paste("The version of mr.raps is", utils::packageVersion('mr.raps'), "please consider updating to version 0.4.3 or higher, e.g., install.packages('mr.raps', repos = c('https://mrcieu.r-universe.dev', 'https://cloud.r-project.org')) "))
+    message(paste(
+      "The version of mr.raps is",
+      utils::packageVersion('mr.raps'),
+      "please consider updating to version 0.4.3 or higher, e.g., install.packages('mr.raps', repos = c('https://mrcieu.r-universe.dev', 'https://cloud.r-project.org')) "
+    ))
   }
 
   data <- data.frame(