From 6814661447d66ddf6d9e3c4565d6b5b0d55d2b95 Mon Sep 17 00:00:00 2001 From: Daniel Nachun Date: Wed, 1 Jul 2026 10:40:17 -0700 Subject: [PATCH 1/2] fix chr name consistency --- R/FineMappingEntry.R | 11 +- R/GenotypeHandle.R | 9 +- R/MultiStudyQtlDataset.R | 4 +- R/QtlDataset.R | 15 +- R/causalInferencePipeline.R | 69 +- R/colocPipeline.R | 43 +- R/colocboostPipeline.R | 111 ++- R/ctwasPipeline.R | 13 +- R/deprecated.R | 22 +- R/genotypeIo.R | 4 +- R/ld.R | 78 +- R/qtlEnrichmentPipeline.R | 32 +- R/sumstatsQc.R | 382 +------- R/variantId.R | 471 +++++++++- man/alignVariantNames.Rd | 33 +- man/causalInferencePipeline.Rd | 6 + man/colocPipeline.Rd | 6 + man/colocboostPipeline.Rd | 9 + man/normalizeVariantId.Rd | 21 +- man/parseVariantId.Rd | 11 +- man/qtlEnrichment.Rd | 4 +- man/regionToDf.Rd | 4 +- man/summaryStatsQc.Rd | 2 +- tests/testthat/test_FineMappingEntry.R | 11 + tests/testthat/test_MultiStudyQtlDataset.R | 24 + tests/testthat/test_QtlDataset.R | 22 + tests/testthat/test_causalInferencePipeline.R | 70 ++ tests/testthat/test_colocPipeline.R | 11 + tests/testthat/test_colocboostPipeline.R | 55 ++ tests/testthat/test_ctwasPipeline.R | 6 +- tests/testthat/test_deprecated.R | 853 ------------------ tests/testthat/test_genotypeIo.R | 2 +- tests/testthat/test_ld.R | 25 +- tests/testthat/test_sumstatsQc.R | 212 +---- tests/testthat/test_variantId.R | 192 +++- 35 files changed, 1219 insertions(+), 1624 deletions(-) delete mode 100644 tests/testthat/test_deprecated.R diff --git a/R/FineMappingEntry.R b/R/FineMappingEntry.R index 3b1bb0b2..3a3f892b 100644 --- a/R/FineMappingEntry.R +++ b/R/FineMappingEntry.R @@ -190,11 +190,16 @@ setMethod("getCs", "FineMappingEntry", setMethod("adjustPips", "FineMappingEntry", function(x, keepVariants, ...) { keepVariants <- as.character(keepVariants) - common <- intersect(x@variantIds, keepVariants) - if (!length(common)) + # Match the entry's variants to `keepVariants` by (chrom, pos, allele) so a + # chr-prefix / separator difference does not read as no-overlap. PIP / LBF + # are coding-invariant, so this is pure identity (no sign). keepIdx is kept + # in the entry's variant order so the fit-matrix subsetting is unchanged. + m <- matchVariants(x@variantIds, keepVariants) + if (!length(m$idxA)) stop("adjustPips: intersection of entry variants with `keepVariants` ", "is empty.") - keepIdx <- match(common, x@variantIds) + keepIdx <- sort(m$idxA) + common <- x@variantIds[keepIdx] fit <- x@susieFit if (is.null(fit$lbf_variable)) stop("adjustPips: entry's susieFit has no `lbf_variable` matrix; ", diff --git a/R/GenotypeHandle.R b/R/GenotypeHandle.R index 9aeb80cf..7e882e16 100644 --- a/R/GenotypeHandle.R +++ b/R/GenotypeHandle.R @@ -285,10 +285,9 @@ GenotypeHandle <- function(path = NULL, # One-file-per-chromosome (sharded) handle support # --------------------------------------------------------------------------- -# Canonicalize a chromosome label to a bare token (strip a leading "chr"). -# Used as the routing key in @chromPaths and when matching @snpInfo$CHR. -#' @keywords internal -.canonChr <- function(x) sub("^chr", "", as.character(x), ignore.case = TRUE) +# Chromosome labels are canonicalized via canonChrom() (variantId.R) -- the +# single chromosome normalizer used for @chromPaths routing keys and for +# @snpInfo$CHR lookups, so both sides stay consistent (and X/Y/MT survive). # Per-chromosome shard map, tolerant of GenotypeHandle objects deserialized # from before the `chromPaths` slot existed (e.g. an RDS saved by an older @@ -389,7 +388,7 @@ GenotypeHandle <- function(path = NULL, chromPaths <- character(0) for (i in seq_along(shards)) { - chs <- unique(.canonChr(shards[[i]]@snpInfo$CHR)) + chs <- unique(canonChrom(shards[[i]]@snpInfo$CHR)) for (ch in chs) { if (ch %in% names(chromPaths)) stop("GenotypeHandle(genoMeta): chromosome '", ch, "' appears in ", diff --git a/R/MultiStudyQtlDataset.R b/R/MultiStudyQtlDataset.R index 0f61dd86..9dfbda66 100644 --- a/R/MultiStudyQtlDataset.R +++ b/R/MultiStudyQtlDataset.R @@ -90,8 +90,8 @@ setClass("MultiStudyQtlDataset", shared <- intersect(names(a), names(b)) for (tid in shared) { if (!isTRUE(all.equal( - as.character(GenomicRanges::seqnames(a[[tid]])), - as.character(GenomicRanges::seqnames(b[[tid]])))) || + canonChrom(GenomicRanges::seqnames(a[[tid]])), + canonChrom(GenomicRanges::seqnames(b[[tid]])))) || GenomicRanges::start(a[[tid]]) != GenomicRanges::start(b[[tid]]) || GenomicRanges::end(a[[tid]]) != GenomicRanges::end(b[[tid]])) { errors <- c(errors, sprintf( diff --git a/R/QtlDataset.R b/R/QtlDataset.R index c0620680..23391c92 100644 --- a/R/QtlDataset.R +++ b/R/QtlDataset.R @@ -78,8 +78,8 @@ setClass("QtlDataset", traitToRange[[tid]] <- this } else { if (!isTRUE(all.equal( - as.character(GenomicRanges::seqnames(prev)), - as.character(GenomicRanges::seqnames(this)) + canonChrom(GenomicRanges::seqnames(prev)), + canonChrom(GenomicRanges::seqnames(this)) )) || GenomicRanges::start(prev) != GenomicRanges::start(this) || GenomicRanges::end(prev) != GenomicRanges::end(this)) { @@ -267,10 +267,9 @@ setMethod("getScaleResiduals", "QtlDataset", function(x) x@scaleResiduals) return(seq_len(nrow(handle@snpInfo))) } snpInfo <- handle@snpInfo - siChr <- sub("^chr", "", as.character(snpInfo$CHR), ignore.case = TRUE) + siChr <- canonChrom(snpInfo$CHR) bp <- as.integer(snpInfo$BP) - rChr <- sub("^chr", "", as.character(GenomicRanges::seqnames(region)), - ignore.case = TRUE) + rChr <- canonChrom(GenomicRanges::seqnames(region)) rStart <- GenomicRanges::start(region) rEnd <- GenomicRanges::end(region) idx <- integer(0) @@ -323,7 +322,11 @@ setMethod("getScaleResiduals", "QtlDataset", function(x) x@scaleResiduals) # extract dosage we will immediately drop. if (length(x@keepVariants) > 0L) { snpAll <- as.character(x@genotypes@snpInfo$SNP[snpIdx]) - keepMask <- snpAll %in% x@keepVariants + # Match by (chrom, pos, allele) so user-supplied keepVariants reconcile with + # the genotype handle's ids across chr-prefix / separator differences. + km <- matchVariants(snpAll, as.character(x@keepVariants)) + keepMask <- logical(length(snpAll)) + keepMask[km$idxA] <- TRUE snpIdx <- snpIdx[keepMask] if (length(snpIdx) == 0L) { return(list( diff --git a/R/causalInferencePipeline.R b/R/causalInferencePipeline.R index f3b4cad9..67a2d484 100644 --- a/R/causalInferencePipeline.R +++ b/R/causalInferencePipeline.R @@ -97,6 +97,10 @@ #' \code{\link{combinePValues}} for cross-method combination per #' \code{(qtlStudy, context, trait, gwasStudy)} group. \code{NULL} #' (default) skips combination. +#' @param alleleFlip Logical, default \code{TRUE}. When TRUE, match QTL variants +#' to the GWAS by (chrom, pos) with ref/alt swaps recognized and the exposure +#' effect / weight sign-flipped accordingly; when FALSE, match on exact +#' alleles only, so a ref/alt swap is treated as a distinct variant. #' @param ... Reserved. #' @return A \code{GRanges} as described above. #' @export @@ -112,6 +116,7 @@ causalInferencePipeline <- function(gwasSumStats, mrCpipCutoff = 0.5, mrPvalCutoff = 1, combineMethods = NULL, + alleleFlip = TRUE, ...) { mrMethod <- match.arg(mrMethod) # --- Input validation -------------------------------------------------- @@ -210,7 +215,7 @@ causalInferencePipeline <- function(gwasSumStats, require = c("SNP", "Z")) twasOut <- .cipComputeTwasZ( weights = wVec, variantIds = wVariantIds, - gwasDf = gdf, gwasLd = gwasLd) + gwasDf = gdf, gwasLd = gwasLd, alleleFlip = alleleFlip) if (is.null(twasOut)) next # Gate MR on the TWAS p-value (legacy mr_pval_cutoff): only run MR where @@ -220,10 +225,10 @@ causalInferencePipeline <- function(gwasSumStats, mrOut <- if (!is.null(fmrEntry) && mrGateOpen) { if (mrMethod == "csAware") { .cipComputeMrCsAware(fmrEntry = fmrEntry, gwasDf = gdf, - cpipCutoff = mrCpipCutoff) + cpipCutoff = mrCpipCutoff, alleleFlip = alleleFlip) } else { .cipComputeMr(fmrEntry = fmrEntry, gwasDf = gdf, - pipCutoff = mrPipCutoff) + pipCutoff = mrPipCutoff, alleleFlip = alleleFlip) } } else { list(waldRatio = NA_real_, waldRatioSe = NA_real_, @@ -436,23 +441,29 @@ causalInferencePipeline <- function(gwasSumStats, # Compute the per-tuple TWAS Z from a single GwasSumStats tuple's # unpacked data.frame (produced by getSumstatDf upstream). Returns # NULL when the overlap is too small. -.cipComputeTwasZ <- function(weights, variantIds, gwasDf, gwasLd) { - common <- intersect(variantIds, gwasDf$variant_id) - if (length(common) < 2L) return(NULL) - - wSub <- weights[match(common, variantIds)] - zSub <- gwasDf$z[match(common, gwasDf$variant_id)] - ldMat <- .cipLdFromSketch(gwasLd, common) +.cipComputeTwasZ <- function(weights, variantIds, gwasDf, gwasLd, + alleleFlip = TRUE) { + # Match QTL weights to the GWAS sumstats by (chrom, pos, allele) rather than + # by raw id string, so chr-prefix / separator / allele-swap differences are + # reconciled instead of silently dropped. sign = -1 marks an allele swap; + # weights[idxA] * sign brings the weight into the GWAS allele coding, which + # the GWAS z and the GWAS-panel LD already share. + m <- matchVariants(variantIds, gwasDf$variant_id, allowFlip = alleleFlip) + if (length(m$idxA) < 2L) return(NULL) + + wSub <- weights[m$idxA] * m$sign + zSub <- gwasDf$z[m$idxB] + gwasIds <- gwasDf$variant_id[m$idxB] + ldMat <- .cipLdFromSketch(gwasLd, gwasIds) res <- twasZ(weights = wSub, z = zSub, R = ldMat) zMat <- res$Z zVal <- as.numeric(zMat[1L, "Z"]) pVal <- as.numeric(zMat[1L, "pval"]) # Position the row at the variant span. - idx <- match(common, gwasDf$variant_id) - chrom <- gwasDf$chrom[[idx[[1L]]]] - startPos <- min(gwasDf$pos[idx]) - endPos <- max(gwasDf$pos[idx]) + chrom <- gwasDf$chrom[[m$idxB[[1L]]]] + startPos <- min(gwasDf$pos[m$idxB]) + endPos <- max(gwasDf$pos[m$idxB]) list(Z = zVal, pval = pVal, chrom = chrom, startPos = startPos, endPos = endPos) } @@ -469,7 +480,7 @@ causalInferencePipeline <- function(gwasSumStats, # variant with PIP > pipCutoff contributes one ratio = beta_y / beta_x. # Returns list(waldRatio, waldRatioSe, mrPval, nIV) with NA fields when # no IVs survive. -.cipComputeMr <- function(fmrEntry, gwasDf, pipCutoff) { +.cipComputeMr <- function(fmrEntry, gwasDf, pipCutoff, alleleFlip = TRUE) { tl <- getTopLoci(fmrEntry) if (is.null(tl) || nrow(tl) == 0L) return(list(waldRatio = NA_real_, waldRatioSe = NA_real_, @@ -487,12 +498,15 @@ causalInferencePipeline <- function(gwasSumStats, mrPval = NA_real_, nIV = 0L)) betaX <- as.numeric(tl[[betaCol[[1L]]]])[keep] seX <- as.numeric(tl[[seCol[[1L]]]])[keep] - gIdx <- match(ivVars, gwasDf$variant_id) - ok <- !is.na(gIdx) - if (sum(ok) == 0L) + m <- matchVariants(ivVars, gwasDf$variant_id, allowFlip = alleleFlip) + if (length(m$idxA) == 0L) return(list(waldRatio = NA_real_, waldRatioSe = NA_real_, mrPval = NA_real_, nIV = 0L)) - betaX <- betaX[ok]; seX <- seX[ok]; gIdx <- gIdx[ok] + # Align the QTL exposure effect to the GWAS allele coding (sign = -1 on an + # allele swap) so the Wald ratio betaY / betaX has the correct sign. + betaX <- betaX[m$idxA] * m$sign + seX <- seX[m$idxA] + gIdx <- m$idxB gZ <- gwasDf$z[gIdx] gN <- if (!is.null(gwasDf$N)) gwasDf$N[gIdx] else rep(NA_real_, length(gIdx)) @@ -546,7 +560,8 @@ causalInferencePipeline <- function(gwasSumStats, # Returns list(waldRatio, waldRatioSe, mrPval, nIV, Q, I2, nCs) with NA # fields when no usable CS survives. # @noRd -.cipComputeMrCsAware <- function(fmrEntry, gwasDf, cpipCutoff) { +.cipComputeMrCsAware <- function(fmrEntry, gwasDf, cpipCutoff, + alleleFlip = TRUE) { naResult <- list(waldRatio = NA_real_, waldRatioSe = NA_real_, mrPval = NA_real_, nIV = 0L, Q = NA_real_, I2 = NA_real_, nCs = 0L) @@ -578,13 +593,13 @@ causalInferencePipeline <- function(gwasSumStats, cs <- cs[ok]; pip <- pip[ok] bhatX <- bhatX[ok]; sbhatX <- sbhatX[ok]; vids <- vids[ok] - # Match GWAS-side beta/se via the existing helpers. - gIdx <- match(vids, gwasDf$variant_id) - ok <- !is.na(gIdx) - if (!any(ok)) return(naResult) - cs <- cs[ok]; pip <- pip[ok] - bhatX <- bhatX[ok]; sbhatX <- sbhatX[ok] - gIdx <- gIdx[ok]; vids <- vids[ok] + # Match the exposure variants to the GWAS sumstats by (chrom, pos, allele), + # aligning the exposure effect to the GWAS coding (sign = -1 on a swap). + m <- matchVariants(vids, gwasDf$variant_id, allowFlip = alleleFlip) + if (length(m$idxA) == 0L) return(naResult) + cs <- cs[m$idxA]; pip <- pip[m$idxA] + bhatX <- bhatX[m$idxA] * m$sign; sbhatX <- sbhatX[m$idxA] + gIdx <- m$idxB; vids <- vids[m$idxA] gZ <- gwasDf$z[gIdx] gN <- if (!is.null(gwasDf$N)) gwasDf$N[gIdx] diff --git a/R/colocPipeline.R b/R/colocPipeline.R index bf6504c9..490f4b64 100644 --- a/R/colocPipeline.R +++ b/R/colocPipeline.R @@ -102,6 +102,10 @@ #' and the QTL fine-mapping input has additional variants; (2) the GWAS #' fine-mapping result contains variants not present in the QTL #' fine-mapping result. Pass \code{FALSE} to use the FMRs as supplied. +#' @param alleleFlip Logical, default \code{TRUE}. When TRUE, align LBF columns +#' between the QTL and GWAS by (chrom, pos) with ref/alt swaps recognized +#' (LBF is coding-invariant, so no sign change is needed); when FALSE, match +#' on exact alleles only, so a ref/alt swap is treated as a distinct variant. #' @param ... Additional arguments forwarded to #' \code{coloc::coloc.bf_bf}. #' @return A data frame with one row per (QTL tuple, GWAS tuple, @@ -128,6 +132,7 @@ colocPipeline <- function(qtlFineMappingResult, enrichment = NULL, p12Max = 1e-3, adjustPips = TRUE, + alleleFlip = TRUE, ...) { useEnrichment <- !is.null(enrichment) if (useEnrichment) { @@ -227,9 +232,9 @@ colocPipeline <- function(qtlFineMappingResult, gInfo <- gwasLbfByPair[[gKey]] gLbf <- gInfo$lbf - # Align variants between QTL and GWAS LBF matrices via the legacy - # alignVariantNames + intersect-and-drop pattern. - aligned <- .colocAlignLbf(qLbf, gLbf) + # Align variants between the QTL and GWAS LBF matrices by (chrom, pos, + # allele) tuple via matchVariants (see .colocAlignLbf). + aligned <- .colocAlignLbf(qLbf, gLbf, alleleFlip = alleleFlip) if (is.null(aligned)) next qAligned <- aligned$qtl gAligned <- aligned$gwas @@ -461,24 +466,26 @@ colocPipeline <- function(qtlFineMappingResult, do.call(rbind, padded) } -# Align column names between a QTL and a (combined) GWAS LBF matrix, -# intersect to the common variants, and return both restricted to that -# common set in the same order. Mirrors alignVariantNames + -# intersect-and-drop in the legacy code. +# Align column names between a QTL and a (combined) GWAS LBF matrix by +# (chrom, pos, allele) tuple (via matchVariants), returning both restricted to +# the common variants under one shared id so coloc.bf_bf can align them. # @noRd -.colocAlignLbf <- function(qtlLbf, gwasLbf) { +.colocAlignLbf <- function(qtlLbf, gwasLbf, alleleFlip = TRUE) { qids <- colnames(qtlLbf) gids <- colnames(gwasLbf) - aligned <- tryCatch(alignVariantNames(qids, gids), - error = function(e) NULL) - if (!is.null(aligned)) { - qids <- aligned$alignedVariants - colnames(qtlLbf) <- qids - } - common <- intersect(qids, gids) - if (length(common) == 0L) return(NULL) - list(qtl = qtlLbf[, common, drop = FALSE], - gwas = gwasLbf[, common, drop = FALSE]) + # Match LBF columns by (chrom, pos, allele) tuple rather than by raw id + # string, so chr-prefix / separator / allele-order differences resolve. LBF + # is allele-coding-invariant, so this is pure identity alignment (no sign); + # with alleleFlip = FALSE, ref/alt-swapped columns are not treated as shared. + m <- matchVariants(qids, gids, allowFlip = alleleFlip) + if (length(m$idxA) == 0L) return(NULL) + # Relabel both matrices to one shared id so coloc.bf_bf sees identical names. + sharedIds <- gids[m$idxB] + qSub <- qtlLbf[, m$idxA, drop = FALSE] + gSub <- gwasLbf[, m$idxB, drop = FALSE] + colnames(qSub) <- sharedIds + colnames(gSub) <- sharedIds + list(qtl = qSub, gwas = gSub) } # A blank result data frame for the no-pair case so callers downstream diff --git a/R/colocboostPipeline.R b/R/colocboostPipeline.R index b97298d9..b52b0056 100644 --- a/R/colocboostPipeline.R +++ b/R/colocboostPipeline.R @@ -80,6 +80,11 @@ #' skipped. \code{0} (default) disables it; a negative value uses #' \code{3 / n_variants}. (Summary-statistic skipping is handled upstream by #' \code{\link{summaryStatsQc}}'s own \code{pipCutoffToSkip}.) +#' @param alleleFlip Logical, default \code{TRUE}. When TRUE, harmonize variants +#' across the individual X, sumstats, and LD by (chrom, pos) with ref/alt +#' swaps recognized (flipping z / residualized dosage / LD to a shared +#' coding); when FALSE, match on exact alleles only (names-only), so a ref/alt +#' swap is treated as a distinct variant. #' @param ... Additional arguments forwarded to #' \code{\link[colocboost]{colocboost}} (e.g., \code{M}, \code{L}, #' \code{output_level}). @@ -236,6 +241,12 @@ setGeneric("colocboostPipeline", NULL }) if (is.null(X) || ncol(X) == 0L) next + # Canonicalize variant colnames (chr-prefix + separator, allele order + # preserved; rsIDs passed through) so colocboost's name-based matching + # aligns them with the sumstat / LD ids and across studies. A genuine + # ref/alt swap stays a distinct id -- names are aligned here, allele + # *coding* is not harmonized. + colnames(X) <- normalizeVariantId(colnames(X)) common <- intersect(rownames(X), rownames(Y)) if (length(common) == 0L) { message("colocboostPipeline: skipping context '", ctx, @@ -322,6 +333,10 @@ setGeneric("colocboostPipeline", variantIds <- formatVariantId(df$chrom, df$pos, df$A2, df$A1) df$variant_id <- variantIds } + # Canonicalize ids (chr-prefix + separator, allele order preserved; rsIDs + # passed through) so the sumstat `variant` column and the LD dimnames align + # by name with the individual X colnames and across studies/sumstats. + variantIds <- normalizeVariantId(variantIds) # Use the shared `.ldFromSketch` helper in "drop" mode so missing-from- # panel variants are silently filtered (the colocboost path expects to # operate only on the overlap). @@ -555,13 +570,87 @@ setGeneric("colocboostPipeline", results } +# ============================================================================= +# Allele harmonization (the alleleFlip = TRUE path) +# ============================================================================= + +# Relabel a residualized genotype matrix's columns to the canonical coding, +# negating columns whose allele order is swapped relative to canonical. For a +# centered / residualized dosage, negation IS the allele flip (flipping the +# counted allele negates the centered genotype). Columns with no canonical +# match (e.g. a multi-allelic secondary allele) are dropped. +# @noRd +.cbFlipMatrixToCanonical <- function(m, canonical) { + mm <- matchVariants(colnames(m), canonical) + if (length(mm$idxA) == 0L) return(m[, integer(0), drop = FALSE]) + o <- order(mm$idxA) + ia <- mm$idxA[o]; ib <- mm$idxB[o]; sgn <- mm$sign[o] + out <- m[, ia, drop = FALSE] + flip <- which(sgn == -1) + if (length(flip) > 0L) out[, flip] <- -out[, flip] + colnames(out) <- canonical[ib] + out +} + +# Relabel a (sumstat, LD) pair to the canonical coding: flip the z-score and the +# LD sign-submatrix for variants swapped relative to canonical +# (LD_ij -> sign_i * sign_j * LD_ij), drop unmatched variants, and relabel to +# canonical. The sumstat and its LD share one sign vector, so they stay +# consistent. Returns NULL when no variant matches. +# @noRd +.cbFlipPairToCanonical <- function(p, canonical) { + mm <- matchVariants(p$sumstat$variant, canonical) + if (length(mm$idxA) == 0L) return(NULL) + o <- order(mm$idxA) + ia <- mm$idxA[o]; ib <- mm$idxB[o]; sgn <- mm$sign[o] + ss <- p$sumstat[ia, , drop = FALSE] + ss$z <- ss$z * sgn + ss$variant <- canonical[ib] + ld <- p$LD[ia, ia, drop = FALSE] * outer(sgn, sgn) + dimnames(ld) <- list(canonical[ib], canonical[ib]) + list(sumstat = ss, LD = ld, variantIds = canonical[ib]) +} + +# Harmonize the allele coding of every colocboost input (individual X columns, +# each sumstat's z / variant, and its LD) to a single per-locus canonical +# coding, so a variant that appears with opposite ref/alt across sources is +# combined with a consistent sign rather than dropped or silently mis-signed. +# The canonical id for a (chrom, pos) locus is the first-seen id across all +# sources (its ref/alt order becomes the shared coding); rsIDs are their own +# locus. Only invoked when alleleFlip = TRUE. +# @noRd +.cbHarmonizeAlleles <- function(individualBundle, pairs) { + ids <- character(0) + if (!is.null(individualBundle)) { + ids <- c(ids, unlist(lapply(individualBundle$X, colnames), use.names = FALSE)) + } + ids <- c(ids, unlist(lapply(pairs, function(p) p$sumstat$variant), + use.names = FALSE)) + ids <- unique(ids[!is.na(ids)]) + if (length(ids) == 0L) { + return(list(individualBundle = individualBundle, pairs = pairs)) + } + parsed <- parseVariantId(ids) + ok <- !is.na(parsed$chrom) & !is.na(parsed$pos) + locus <- ifelse(ok, paste(parsed$chrom, parsed$pos, sep = ":"), ids) + canonical <- ids[!duplicated(locus)] + if (!is.null(individualBundle)) { + individualBundle$X <- lapply(individualBundle$X, + .cbFlipMatrixToCanonical, canonical = canonical) + } + pairs <- lapply(pairs, .cbFlipPairToCanonical, canonical = canonical) + pairs <- pairs[!vapply(pairs, is.null, logical(1))] + list(individualBundle = individualBundle, pairs = pairs) +} + # Top-level driver shared by all input methods. qtlPairs and gwasPairs # are per-tuple lists of `list(sumstat, LD)` produced by the per-class # bundle helpers; they are merged here so dict_sumstatLD can dedupe # identical LD matrices across QTL and GWAS sides. .cbDriver <- function(individualBundle, qtlPairs, gwasSumStats, xqtlColoc, jointGwas, separateGwas, - focalTrait, dotArgs, qtlLdSketch = NULL) { + focalTrait, dotArgs, qtlLdSketch = NULL, + alleleFlip = TRUE) { if (!isTRUE(xqtlColoc) && !isTRUE(jointGwas) && !isTRUE(separateGwas)) { message("colocboostPipeline: no analysis flag is TRUE; nothing to do.") return(.cbEmptyResult()) @@ -583,6 +672,15 @@ setGeneric("colocboostPipeline", combinedPairs[[key]] <- gwasPairs[[label]] } } + # Harmonize allele coding across all sources to a shared per-locus canonical + # so swapped variants are combined with a consistent sign (alleleFlip = TRUE); + # alleleFlip = FALSE leaves the names-only canonicalization done at the source + # builders, which keeps swapped variants distinct. + if (isTRUE(alleleFlip)) { + harmonized <- .cbHarmonizeAlleles(individualBundle, combinedPairs) + individualBundle <- harmonized$individualBundle + combinedPairs <- harmonized$pairs + } sumstatBundle <- .cbMergeSumstatBundles(combinedPairs) .cbRunVariants(individualBundle, sumstatBundle, @@ -606,6 +704,7 @@ setMethod("colocboostPipeline", "QtlDataset", separateGwas = FALSE, samples = NULL, pipCutoffToSkip = 0, + alleleFlip = TRUE, ...) { dotArgs <- list(...) indBundle <- .cbIndividualBundle( @@ -618,7 +717,7 @@ setMethod("colocboostPipeline", "QtlDataset", pipCutoffToSkip = pipCutoffToSkip) .cbDriver(indBundle, qtlPairs = list(), gwasSumStats, xqtlColoc, jointGwas, separateGwas, - focalTrait, dotArgs) + focalTrait, dotArgs, alleleFlip = alleleFlip) }) #' @rdname colocboostPipeline @@ -631,6 +730,7 @@ setMethod("colocboostPipeline", "QtlSumStats", xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, + alleleFlip = TRUE, ...) { .cbRequireSumStatsQc(qtlData, "qtlData") dotArgs <- list(...) @@ -644,7 +744,8 @@ setMethod("colocboostPipeline", "QtlSumStats", separateGwas = separateGwas, focalTrait = focalTrait, dotArgs = dotArgs, - qtlLdSketch = getLdSketch(qtlData)) + qtlLdSketch = getLdSketch(qtlData), + alleleFlip = alleleFlip) }) #' @rdname colocboostPipeline @@ -659,6 +760,7 @@ setMethod("colocboostPipeline", "MultiStudyQtlDataset", separateGwas = FALSE, samples = NULL, pipCutoffToSkip = 0, + alleleFlip = TRUE, ...) { dotArgs <- list(...) @@ -719,7 +821,8 @@ setMethod("colocboostPipeline", "MultiStudyQtlDataset", .cbDriver(indBundle, qtlPairs, gwasSumStats, xqtlColoc, jointGwas, separateGwas, focalTrait, dotArgs, - qtlLdSketch = qtlLdSketch) + qtlLdSketch = qtlLdSketch, + alleleFlip = alleleFlip) }) #' @rdname colocboostPipeline diff --git a/R/ctwasPipeline.R b/R/ctwasPipeline.R index a1e94320..761e6653 100644 --- a/R/ctwasPipeline.R +++ b/R/ctwasPipeline.R @@ -828,7 +828,10 @@ mergeCtwasBoundaryRegions <- function(finemapResult, # Per-block SNP info table (chrom, id, pos, alt, ref). ctwas requires # these exact column names (read_snp_info_files asserts them). `alt` -# maps to A1 (effect allele) and `ref` to A2. +# maps to A1 (effect allele) and `ref` to A2. NOTE: cTWAS requires an integer +# chrom, so the as.integer() cast below is intentional (an output-boundary +# format requirement) and this path is autosomal-only -- X/Y/MT are not +# supported by the downstream cTWAS model. # @noRd .ctwasSnpInfoForBlock <- function(gwasLd) { snpInfo <- getSnpInfo(gwasLd) @@ -867,7 +870,7 @@ mergeCtwasBoundaryRegions <- function(finemapResult, } # Harmonize TWAS weight variants against the LD reference panel. Same -# allele-matching semantics as the GWAS-side `.matchRefPanel` flow: +# allele-matching semantics as the GWAS-side `harmonizeAlleles` flow: # match by (chrom, pos), accept exact A1/A2 frame, sign-flip the weight # when alleles are swapped, drop unmatched / strand-ambiguous variants. # Returns a data.frame with columns: @@ -889,7 +892,7 @@ mergeCtwasBoundaryRegions <- function(finemapResult, origIdx = seq_along(origVids), stringsAsFactors = FALSE) res <- tryCatch( - .matchRefPanel( + harmonizeAlleles( targetData = targetDf, refVariants = refVariants, colToFlip = "w", @@ -975,7 +978,7 @@ mergeCtwasBoundaryRegions <- function(finemapResult, } panelInfo <- ldPanel$snpInfo # Reference frame for allele-harmonization: panel variant info with - # the column shape `.matchRefPanel` expects (chrom/pos/A2/A1). + # the column shape `harmonizeAlleles` expects (chrom/pos/A2/A1). refVariants <- data.frame( chrom = as.integer(panelInfo$chrom), pos = as.integer(panelInfo$pos), @@ -992,7 +995,7 @@ mergeCtwasBoundaryRegions <- function(finemapResult, if (length(origVids) == 0L || length(origVids) != length(origW)) next # --- Step 1: allele-harmonize against the LD panel ------------- - # Parses chr:pos:A2:A1 IDs into the data.frame `.matchRefPanel` + # Parses chr:pos:A2:A1 IDs into the data.frame `harmonizeAlleles` # expects, then matches by (chrom, pos) with exact / sign-flip / # strand-flip detection. Returned canonical variant IDs are in the # panel's A1/A2 frame; weights are sign-flipped for variants whose diff --git a/R/deprecated.R b/R/deprecated.R index 23981d1b..148b250f 100644 --- a/R/deprecated.R +++ b/R/deprecated.R @@ -36,7 +36,7 @@ matchRefPanel <- function(targetData, refVariants, ...) { msg = paste( "matchRefPanel() is deprecated; allele harmonization now runs", "inside summaryStatsQc() as part of the SumStats QC pass.")) - .matchRefPanel(targetData = targetData, refVariants = refVariants, ...) + invisible(NULL) } #' @rdname matchRefPanel @@ -46,7 +46,25 @@ alleleQc <- function(targetData, refVariants, ...) { msg = paste( "alleleQc() is deprecated; allele harmonization now runs inside", "summaryStatsQc() as part of the SumStats QC pass.")) - .matchRefPanel(targetData = targetData, refVariants = refVariants, ...) + invisible(NULL) +} + +#' (Deprecated) Align variant names to a reference convention +#' +#' \strong{Deprecated.} Match with \code{\link{matchVariants}} and relabel +#' directly, e.g. \code{m <- matchVariants(source, reference)} then +#' \code{source[m$idxA] <- reference[m$idxB]}. +#' +#' @param source,reference Character vectors of variant ids. +#' @param ... Ignored. +#' @return \code{NULL} (invisibly). +#' @export +alignVariantNames <- function(source, reference, ...) { + .Deprecated(new = "matchVariants", package = "pecotmr", + msg = paste( + "alignVariantNames() is deprecated; match with matchVariants() and", + "relabel via source[idxA] <- reference[idxB].")) + invisible(NULL) } diff --git a/R/genotypeIo.R b/R/genotypeIo.R index c8d481c0..4a047658 100644 --- a/R/genotypeIo.R +++ b/R/genotypeIo.R @@ -288,7 +288,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { colData = DataFrame(sampleId = sampleIds, row.names = sampleIds))) } - unifiedChr <- .canonChr(handle@snpInfo$CHR) + unifiedChr <- canonChrom(handle@snpInfo$CHR) reqChr <- unifiedChr[snpIdx] groups <- split(seq_along(snpIdx), reqChr) @@ -964,7 +964,7 @@ matchVariantsToKeep <- function(variantInfo, keepVariantsPath) { ids <- read_lines(keepVariantsPath) keepVariants <- parseVariantId(ids) } - viChrom <- as.integer(stripChrPrefix(variantInfo$chrom)) + viChrom <- canonChrom(variantInfo$chrom) hasAlleles <- "A1" %in% names(keepVariants) && "A2" %in% names(keepVariants) && !any(is.na(keepVariants$A1)) && !any(is.na(keepVariants$A2)) if (hasAlleles) { diff --git a/R/ld.R b/R/ld.R index 890ae277..8bfe4c26 100644 --- a/R/ld.R +++ b/R/ld.R @@ -3,9 +3,9 @@ #' @importFrom magrittr %>% #' @noRd orderDedupRegions <- function(df) { - df$chrom <- as.integer(stripChrPrefix(df$chrom)) + df$chrom <- canonChrom(df$chrom) df <- distinct(df, chrom, start, .keep_all = TRUE) %>% - arrange(chrom, start) + arrange(chromOrder(chrom), start) df } @@ -167,7 +167,7 @@ processLdMatrix <- function(ldFilePath, snpFilePath = NULL) { ldVariants <- readVariantMetadata(snpFilePath) isPvar <- !("gpos" %in% names(ldVariants)) ldVariants <- ldVariants %>% - mutate(chrom = as.character(as.integer(stripChrPrefix(chrom))), + mutate(chrom = canonChrom(chrom), variants = normalizeVariantId(id)) if (isPvar) { ldVariants <- rename(ldVariants, GD = pos) @@ -203,10 +203,10 @@ extractLdForRegion <- function(ldMatrix, variants, region, extractCoordinates) { if (!is.null(extractCoordinates)) { extractCoordinates <- extractCoordinates %>% - mutate(chrom = as.integer(stripChrPrefix(chrom))) %>% + mutate(chrom = canonChrom(chrom)) %>% select(chrom, pos) extracted <- extracted %>% - mutate(chrom = as.integer(stripChrPrefix(chrom))) %>% + mutate(chrom = canonChrom(chrom)) %>% merge(extractCoordinates, by = c("chrom", "pos")) keepCols <- intersect(c("chrom", "variants", "pos", "GD", "A1", "A2", "variance", "allele_freq", "n_nomiss"), names(extracted)) @@ -421,8 +421,8 @@ resolveGenotypePathForRegion <- function(metaPath, region) { parsed <- parseRegion(region) meta <- as.data.frame(vroom(metaPath, show_col_types = FALSE)) colnames(meta) <- c("chrom", "start", "end", "path") - meta$chrom <- as.integer(stripChrPrefix(meta$chrom)) - queryChrom <- as.integer(stripChrPrefix(parsed$chrom)) + meta$chrom <- canonChrom(meta$chrom) + queryChrom <- canonChrom(parsed$chrom) matching <- meta[meta$chrom == queryChrom, , drop = FALSE] if (nrow(matching) == 0) { @@ -548,47 +548,41 @@ loadLdFromGenotype <- function(genotypePath, region, } onMissing <- match.arg(onMissing) snpInfo <- getSnpInfo(ldSketch) - # Reconcile a pure chr-prefix mismatch between the requested ids and the - # panel (ensureChrMatch, variantId.R) before matching, so variants that - # differ only by a leading "chr" still resolve instead of reading as absent. - # The caller's original variantIds are kept for the returned labels; only the - # match keys are normalized. Fall back to the raw ids if normalization can't - # parse them (e.g. an rsID panel), preserving prior behavior. - matchIds <- variantIds - panelIds <- as.character(snpInfo$SNP) - reconciled <- tryCatch(ensureChrMatch(variantIds, panelIds), - error = function(e) NULL) - if (!is.null(reconciled)) { - matchIds <- reconciled$idsA - panelIds <- reconciled$idsB - } - idx <- match(matchIds, panelIds) - if (anyNA(idx)) { - if (onMissing == "error") { - stop(sprintf("%s: %d variant id(s) not present in the LD sketch panel.", - label, sum(is.na(idx)))) - } - keep <- !is.na(idx) - if (!any(keep)) return(NULL) - variantIds <- variantIds[keep] - idx <- idx[keep] - } + # Match the requested ids to the panel by (chrom, pos, allele) tuple, with an + # exact id-string fallback for rsID panels (matchVariants does both). This + # resolves a pure chr-prefix / separator difference between the requested ids + # and the panel that a raw string match would read as "absent". The caller's + # original ids are kept as the returned labels, in the requested order. + m <- matchVariants(variantIds, as.character(snpInfo$SNP), + removeStrandAmbiguous = FALSE) + nMissing <- length(variantIds) - length(m$idxA) + if (nMissing > 0L && onMissing == "error") { + stop(sprintf("%s: %d variant id(s) not present in the LD sketch panel.", + label, nMissing)) + } + if (length(m$idxA) == 0L) return(NULL) + o <- order(m$idxA) # restore the caller's requested order + keptIds <- variantIds[m$idxA[o]] + idx <- m$idxB[o] block <- extractBlockGenotypes(ldSketch, idx, meanImpute = TRUE) geno <- t(SummarizedExperiment::assay(block, "dosage")) - colnames(geno) <- variantIds + colnames(geno) <- keptIds ldMat <- computeLd(geno, method = "sample") - dimnames(ldMat) <- list(variantIds, variantIds) + dimnames(ldMat) <- list(keptIds, keptIds) if (onMissing == "drop") { - attr(ldMat, "keptVariantIds") <- variantIds + attr(ldMat, "keptVariantIds") <- keptIds } ldMat } # ---------- LD sketch: cross-pipeline LD-panel equality check ---------- -# Internal: assert that two `GenotypeHandle` LD sketches describe exactly the -# same reference panel (same snpInfo: SNP, CHR, BP, A1, A2, in the same -# order; same sampleIds). Shared by causalInferencePipeline, colocPipeline, +# Internal: assert that two `GenotypeHandle` LD sketches describe the same +# reference panel: same variant identity (chr-agnostic CHR via canonChrom, +# exact BP/A1/A2, in the same order) and the same sampleIds. The SNP label is +# not compared, so a pure chr-prefix difference does not fail; an allele swap +# (different A1/A2) still does, since it means a different LD coding. Shared by +# causalInferencePipeline, colocPipeline, # qtlEnrichmentPipeline, ctwasPipeline, and # colocboostPipeline. # @@ -631,7 +625,11 @@ loadLdFromGenotype <- function(genotypePath, region, nrow(qSnp), " vs ", nrow(gSnp), " variants)", between, "; the two ldSketch GenotypeHandles must match exactly.") } - for (col in c("SNP", "CHR", "BP", "A1", "A2")) { + if (!identical(canonChrom(qSnp$CHR), canonChrom(gSnp$CHR))) { + stop(pipelineName, ": ldSketch panels differ in column CHR", between, + "; use the same ldSketch on both.") + } + for (col in c("BP", "A1", "A2")) { if (!identical(as.character(qSnp[[col]]), as.character(gSnp[[col]]))) { stop(pipelineName, ": ldSketch panels differ in column ", @@ -836,7 +834,7 @@ filterVariantsByLdReference <- function(variantIds, ldReferenceMetaFile, keepInd # Use shared helper -- no genotype loading refInfo <- getRefVariantInfo(ldReferenceMetaFile, regionDf) - refChrom <- as.integer(stripChrPrefix(refInfo$chrom)) + refChrom <- canonChrom(refInfo$chrom) refKey <- paste0(refChrom, ":", refInfo$pos) variantKey <- paste0(variantsDf$chrom, ":", variantsDf$pos) diff --git a/R/qtlEnrichmentPipeline.R b/R/qtlEnrichmentPipeline.R index d2f99034..adf2e40e 100644 --- a/R/qtlEnrichmentPipeline.R +++ b/R/qtlEnrichmentPipeline.R @@ -88,7 +88,7 @@ qtlEnrichmentPipeline <- function(gwasFineMappingResult, # Hoist the QTL-side work out of the gwasStudy loop. The variant-name # alignment is independent of the GWAS study (all studies share one naming - # convention), so the original code re-ran the costly .matchRefPanel pass for + # convention), so the original code re-ran the costly harmonizeAlleles pass for # every (gwasStudy, qtlTuple) pair. Instead: build each GWAS PIP vector once, # derive the union variant-name panel, and align each QTL tuple's regions # once against that union (memoised in `alignedByTuple`, reused across every @@ -112,15 +112,19 @@ qtlEnrichmentPipeline <- function(gwasFineMappingResult, # with a warning instead of aborting the whole pipeline -- the behaviour # before this optimization, where alignment lived inside qtlEnrichment. An # empty union means no GWAS study has usable PIPs, so every study is skipped - # before this is ever reached (and the length guard keeps alignVariantNames - # from treating an empty reference as a convention mismatch). + # before this is ever reached (and the length guard skips relabeling entirely + # when the union GWAS panel is empty). alignedByTuple <- vector("list", nrow(qtlTuples)) alignTuple <- function(k) { if (!is.null(alignedByTuple[[k]])) return(alignedByTuple[[k]]) aligned <- lapply(qtlRegionsByTuple[[k]], function(x) { if (!is.null(names(x$pip)) && length(unionGwasNames) > 0L) { - names(x$pip) <- alignVariantNames(names(x$pip), - unionGwasNames)$alignedVariants + # Relabel matched pip names to the GWAS convention via the shared + # matcher (tuple match; unmatched names kept as-is). + mm <- matchVariants(names(x$pip), unionGwasNames) + nm <- names(x$pip) + nm[mm$idxA] <- unionGwasNames[mm$idxB] + names(x$pip) <- nm } x }) @@ -335,11 +339,11 @@ qtlEnrichmentPipeline <- function(gwasFineMappingResult, #' @param impN Rounds of multiple imputation to draw QTL from, default is 25. #' @param numThreads Number of Simultaneous running CPU threads for multiple imputation, default is 1. #' @param alignNames Logical; when TRUE (default) QTL pip names are aligned to -#' the GWAS variant-naming convention via \code{alignVariantNames}. Set FALSE +#' the GWAS variant-naming convention via \code{matchVariants}. Set FALSE #' when the caller has already aligned them (e.g. \code{qtlEnrichmentPipeline} #' aligns each QTL tuple once against the union GWAS panel rather than #' re-aligning per GWAS study); only the cheap per-study unmatched set is then -#' recomputed, skipping the costly \code{.matchRefPanel} pass. +#' recomputed, skipping the costly \code{harmonizeAlleles} pass. #' @return A list of enrichment parameter estimates #' #' @examples @@ -423,14 +427,18 @@ qtlEnrichment <- function(gwasPip, susieQtlRegions, # unmatched variants. With alignNames = FALSE the caller has already aligned # the pip names to the GWAS naming convention (qtlEnrichmentPipeline aligns # each QTL tuple once against the union GWAS panel), so the costly - # .matchRefPanel pass is skipped and only the per-study unmatched set is + # harmonizeAlleles pass is skipped and only the per-study unmatched set is # recomputed via a cheap set-membership test. if (alignNames) { alignedSusieQtlRegions <- lapply(susieQtlRegions, function(x) { - alignmentResult <- alignVariantNames(names(x$pip), names(gwasPip)) - names(x$pip) <- alignmentResult$alignedVariants - if (length(alignmentResult$unmatchedIndices) > 0) { - x$unmatched_variants <- names(x$pip)[alignmentResult$unmatchedIndices] + # Relabel matched pip names to the GWAS convention via the shared matcher. + mm <- matchVariants(names(x$pip), names(gwasPip)) + nm <- names(x$pip) + nm[mm$idxA] <- names(gwasPip)[mm$idxB] + names(x$pip) <- nm + unmatchedIdx <- setdiff(seq_along(x$pip), mm$idxA) + if (length(unmatchedIdx) > 0) { + x$unmatched_variants <- names(x$pip)[unmatchedIdx] } x }) diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index 70cf9e1f..d7bc1104 100644 --- a/R/sumstatsQc.R +++ b/R/sumstatsQc.R @@ -5,7 +5,7 @@ # top-level entry point is `summaryStatsQc()` (below), which orchestrates # the individual passes: # -# * Allele harmonization (matchRefPanel / alignVariantNames) +# * Allele harmonization (harmonizeAlleles, in R/variantId.R) # * RAISS sumstats imputation (fills variants present on the LD panel # but missing from sumstats) # * SLALoM (single-causal-variant ABF outlier detection) @@ -21,343 +21,10 @@ #' @importFrom S4Vectors mcols NULL -#' Match target data alleles against a reference panel -#' -#' Match by ("chrom", "A1", "A2" and "pos"), accounting for possible -#' strand flips and major/minor allele flips (opposite effects and zscores). -#' Flips specified columns when alleles are swapped relative to the reference. -#' -#' @param targetData A data frame with columns "chrom", "pos", "A2", "A1" (and optionally other columns like "beta" or "z"), -#' or a vector of strings in the format of "chr:pos:A2:A1"/"chr:pos_A2_A1". Can be automatically converted to a data frame if a vector. -#' @param refVariants A data frame with columns "chrom", "pos", "A2", "A1" or strings in the format of "chr:pos:A2:A1"/"chr:pos_A2_A1". -#' @param colToFlip The name of the column in targetData where flips are to be applied. -#' On an allele swap these columns are sign-flipped (multiplied by -1), the -#' correct operation for signed quantities like \code{beta} and \code{z}. -#' @param colToComplement Names of columns in targetData to complement -#' (\code{1 - x}) on an allele swap, the correct operation for an -#' effect-allele frequency like \code{af}. Default \code{character()} does no -#' complementing, so non-RSS callers are unchanged. Distinct from -#' \code{colToFlip}: frequencies are complemented, signed effects are -#' sign-flipped. -#' @param matchMinProp Minimum proportion of variants in the smallest data -#' to be matched, otherwise stops with an error. Default is 20%. -#' @param removeDups Whether to remove duplicates, default is TRUE. -#' @param removeIndels Whether to remove INDELs, default is FALSE. -#' @param flip Whether the alleles must be flipped: A <--> T & C <--> G, in which case -#' corresponding `colToFlip` are multiplied by -1. Default is `TRUE`. -#' @param removeStrandAmbiguous Whether to remove strand SNPs (if any). Default is `TRUE`. -#' @param flipStrand Whether to output the variants after strand flip. Default is `FALSE`. -#' @param removeUnmatched Whether to remove unmatched variants. Default is `TRUE`. -#' @return An \code{AlleleQcResult} S4 object. Use -#' \code{$harmonizedData} to recover the post-QC variant -#' data.frame and \code{$qcSummary} to inspect the per-variant -#' merge/flip/strand diagnostics. -#' @importFrom magrittr %>% -#' @importFrom dplyr mutate inner_join filter pull select everything row_number if_else any_of all_of rename -#' @importFrom vctrs vec_duplicate_detect -#' @importFrom tidyr separate -#' @keywords internal -#' @noRd -#' @details -#' Pure panel-vs-sumstats allele harmonization: match by (chrom, pos), -#' detect A1/A2 swap, sign-flip \code{colToFlip} columns and complement -#' \code{colToComplement} columns on swap. Variant-allele filters -#' (indels, strand-ambiguous, duplicates) are applied here directly when -#' the corresponding \code{removeIndels} / \code{removeStrandAmbiguous} / -#' \code{removeDups} flags are set; MAF / INFO / N column-numeric filters -#' run in \code{.applyContentFilters()} before this function. -.matchRefPanel <- function(targetData, refVariants, colToFlip = NULL, - matchMinProp = 0.2, flipStrand = FALSE, - removeUnmatched = TRUE, - removeIndels = FALSE, - removeStrandAmbiguous = TRUE, - removeDups = FALSE, - colToComplement = character(), ...) { - strandFlip <- function(ref) chartr("ATCG", "TAGC", ref) - - sanitizeNames <- function(df) { - nm <- colnames(df) - if (is.null(nm)) nm <- rep("unnamed", ncol(df)) - emptyIdx <- is.na(nm) | nm == "" - if (any(emptyIdx)) - nm[emptyIdx] <- paste0("unnamed_", seq_len(sum(emptyIdx))) - colnames(df) <- make.unique(nm, sep = "_") - df - } - - if (is.data.frame(targetData)) { - if (ncol(targetData) > 4 && - all(c("chrom", "pos", "A2", "A1") %in% names(targetData))) { - variantCols <- c("chrom", "pos", "A2", "A1") - variantDf <- targetData %>% select(all_of(variantCols)) - otherCols <- targetData %>% select(-all_of(variantCols)) - targetData <- cbind(variantIdToDf(variantDf), otherCols) - } else { - targetData <- variantIdToDf(targetData) - } - } else { - targetData <- variantIdToDf(targetData) - } - refVariants <- variantIdToDf(refVariants) - - # Strip merge-conflicting columns; keep target A1/A2. `variant_id` is also - # stripped from `refVariants` because the post-harmonization variant_id is - # rebuilt from the QC'd alleles further down (`variants_id_qced`), and - # leaving the input variant_id on either side causes the final rename to - # collide on duplicate names. - columnsToRemove <- c("chromosome", "position", "ref", "alt", "variant_id") - if (any(columnsToRemove %in% colnames(targetData))) - targetData <- select(targetData, -any_of(columnsToRemove)) - if ("variant_id" %in% colnames(refVariants)) - refVariants <- select(refVariants, -any_of("variant_id")) - - matchResult <- inner_join(targetData, refVariants, - by = c("chrom", "pos"), - suffix = c(".target", ".ref")) %>% - as.data.frame() %>% - sanitizeNames() - - if (nrow(matchResult) == 0) { - warning("No matching variants found between target data and reference variants.") - emptyOut <- list(harmonizedData = matchResult, qcSummary = matchResult) - attr(emptyOut, "qcCounts") <- list( - considered = 0L, signFlip = 0L, strandFlip = 0L, kept = 0L, - dropped = 0L, droppedIndel = 0L, droppedAmbiguous = 0L, - droppedOther = 0L) - return(emptyOut) - } - - matchResult <- matchResult %>% - mutate(variants_id_original = formatVariantId(chrom, pos, A2.target, A1.target), - variants_id_qced = formatVariantId(chrom, pos, A2.ref, A1.ref)) %>% - mutate(across(c(A1.target, A2.target, A1.ref, A2.ref), toupper)) %>% - mutate(flip1.ref = strandFlip(A1.ref), - flip2.ref = strandFlip(A2.ref)) %>% - # AT / CG pairs cannot be distinguished from strand-flip without external - # context; the keep rule below relies on this flag as a safety guard for - # callers that may not have removed strand-ambiguous variants upstream. - mutate(strand_unambiguous = if_else( - (A1.target == "A" & A2.target == "T") | - (A1.target == "T" & A2.target == "A") | - (A1.target == "C" & A2.target == "G") | - (A1.target == "G" & A2.target == "C"), - FALSE, TRUE)) %>% - mutate(exact_match = A1.target == A1.ref & A2.target == A2.ref) %>% - mutate(sign_flip = ((A1.target == A2.ref & A2.target == A1.ref) | - (A1.target == flip2.ref & A2.target == flip1.ref)) & - (A1.target != A1.ref & A2.target != A2.ref)) %>% - mutate(strand_flip = ((A1.target == flip1.ref & A2.target == flip2.ref) | - (A1.target == flip2.ref & A2.target == flip1.ref)) & - (A1.target != A1.ref & A2.target != A2.ref)) %>% - # INDEL detection: explicit "I"/"D" notation, or any allele wider than 1bp. - mutate(INDEL = (A2.target == "I" | A2.target == "D" | - nchar(A2.target) > 1L | nchar(A1.target) > 1L)) %>% - # ID_match: an indel encoded as I/D on the target side matches an indel - # on the reference side (where the reference uses multi-base alleles). - mutate(ID_match = ((A2.target == "D" | A2.target == "I") & - (nchar(A1.ref) > 1L | nchar(A2.ref) > 1L))) - - # When removeStrandAmbiguous = FALSE, the A/T - C/G safety guard is - # disabled: ambiguous variants are treated as exact/sign-flip cases. - if (!removeStrandAmbiguous) - matchResult$strand_unambiguous <- TRUE - - # If no strand_flip survives the unambiguous test, the remaining ambiguous - # variants can be treated as exact/sign-flip cases rather than dropped. - if (!any(matchResult$strand_flip & matchResult$strand_unambiguous)) - matchResult$strand_unambiguous <- TRUE - - matchResult <- matchResult %>% - mutate(keep = if_else(strand_flip, - true = strand_unambiguous | exact_match | ID_match, - false = exact_match | sign_flip | ID_match)) - - if (removeIndels) - matchResult <- matchResult %>% - mutate(keep = if_else(INDEL, FALSE, keep)) - - if (!is.null(colToFlip)) { - missing <- setdiff(colToFlip, colnames(matchResult)) - if (length(missing) > 0L) - stop("Column(s) '", paste(missing, collapse = "', '"), - "' not found in targetData.") - matchResult[matchResult$sign_flip, colToFlip] <- - -1 * matchResult[matchResult$sign_flip, colToFlip] - } - # A frequency tracks the effect allele, so an allele swap takes af -> 1 - af - # (not a sign flip). Kept independent of colToFlip so signed columns are - # untouched here. - if (length(colToComplement) > 0L) { - missing <- setdiff(colToComplement, colnames(matchResult)) - if (length(missing) > 0L) - stop("Column(s) '", paste(missing, collapse = "', '"), - "' not found in targetData.") - matchResult[matchResult$sign_flip, colToComplement] <- - 1 - matchResult[matchResult$sign_flip, colToComplement] - } - if (flipStrand) { - sIdx <- which(matchResult$strand_flip) - matchResult[sIdx, "A1.target"] <- strandFlip(matchResult[sIdx, "A1.target"]) - matchResult[sIdx, "A2.target"] <- strandFlip(matchResult[sIdx, "A2.target"]) - } - - # Per-step QC counts (used by .runEntrySummaryStatsQc for "kept N of M - # (corrected: sign-flipped A, strand-flipped B; dropped C)" logging). - # Computed from the per-variant flags before they are stripped from the - # returned data frame so callers reading the data frame are unaffected. - qcCounts <- list( - considered = nrow(matchResult), - signFlip = sum(matchResult$sign_flip & matchResult$keep, na.rm = TRUE), - strandFlip = sum(matchResult$strand_flip & matchResult$keep, na.rm = TRUE), - kept = sum(matchResult$keep, na.rm = TRUE), - dropped = sum(!matchResult$keep, na.rm = TRUE)) - if ("INDEL" %in% colnames(matchResult)) { - qcCounts$droppedIndel <- sum(!matchResult$keep & matchResult$INDEL, - na.rm = TRUE) - } else { - qcCounts$droppedIndel <- 0L - } - qcCounts$droppedAmbiguous <- sum( - !matchResult$keep & matchResult$strand_flip & - !matchResult$strand_unambiguous & - if ("INDEL" %in% colnames(matchResult)) !matchResult$INDEL else TRUE, - na.rm = TRUE) - qcCounts$droppedOther <- qcCounts$dropped - qcCounts$droppedIndel - - qcCounts$droppedAmbiguous - - result <- matchResult[matchResult$keep, , drop = FALSE] - - qcCols <- c("flip1.ref", "flip2.ref", "strand_unambiguous", - "exact_match", "sign_flip", "strand_flip", "INDEL", - "ID_match", "keep") - result <- result %>% - select(-any_of(qcCols), -A1.target, -A2.target) %>% - rename(A1 = A1.ref, A2 = A2.ref, variant_id = variants_id_qced) - - # removeDups: drop duplicate variant rows (same chrom/pos/qced ID). - # Default FALSE keeps the existing strict behavior (error on dups). - if (removeDups) { - dups <- duplicated(result[, c("chrom", "pos", "variant_id")]) - if (any(dups)) { - warning(sprintf("Removed %d duplicate variant(s), keeping first occurrence.", - sum(dups))) - result <- result[!dups, , drop = FALSE] - } - } - - if (!removeUnmatched) { - matchVariant <- result %>% pull(variants_id_original) - matchResult <- matchResult %>% - select(-any_of(qcCols), -variants_id_original, -A1.target, -A2.target) %>% - rename(A1 = A1.ref, A2 = A2.ref, variant_id = variants_id_qced) - targetData <- targetData %>% - mutate(variant_id = formatVariantId(chrom, pos, A2, A1)) - if (length(setdiff(targetData %>% pull(variant_id), matchVariant)) > 0L) { - unmatchData <- targetData %>% filter(!variant_id %in% matchVariant) - result <- rbind(result, - unmatchData %>% mutate(variants_id_original = variant_id)) - result <- result[match(targetData$variant_id, - result$variants_id_original), ] %>% - select(-variants_id_original) - } - } - - if (nrow(result) < matchMinProp * nrow(refVariants)) - stop("Not enough variants have been matched.") - if (any(duplicated(result$variant_id))) - stop("Duplicated variant IDs remain after harmonization; pass ", - "removeDups = TRUE or deduplicate upstream before calling ", - ".matchRefPanel.") - - out <- list(harmonizedData = result, qcSummary = matchResult) - attr(out, "qcCounts") <- qcCounts - out -} - -#' Align Variant Names -#' -#' This function aligns variant names from two strings containing variant names in the format of -#' "chr:pos:A1:A2" or "chr:pos_A1_A2". The first string should be the "source" and the second -#' should be the "reference". -#' -#' @param source A character vector of variant names in the format "chr:pos:A2:A1" or "chr:pos_A2_A1". -#' @param reference A character vector of variant names in the format "chr:pos:A2:A1" or "chr:pos_A2_A1". -#' @param removeBuildSuffix Whether to strip trailing genome build suffixes like ":b38" or "_b38" before alignment. Default TRUE. -#' -#' @return A list with two elements: -#' - alignedVariants: A character vector of aligned variant names. -#' - unmatchedIndices: A vector of indices for the variants in the source that could not be matched. -#' -#' @examples -#' source <- c("1:123:A:C", "2:456:G:T", "3:789:C:A") -#' reference <- c("1:123:A:C", "2:456:T:G", "4:101:G:C") -#' alignVariantNames(source, reference) -#' -#' @export -alignVariantNames <- function(source, reference, removeIndels = FALSE, removeBuildSuffix = TRUE) { - # Optionally strip build suffix like :b38 or _b38 from both sides for robust alignment - if (removeBuildSuffix) { - source <- gsub("(:|_)b[0-9]+$", "", source) - reference <- gsub("(:|_)b[0-9]+$", "", reference) - } - # Check if source and reference follow the expected pattern - sourcePattern <- grepl("^(chr)?[0-9]+[_:][0-9]+[_:][ATCG*]+[_:][ATCG*]+$", source) - referencePattern <- grepl("^(chr)?[0-9]+[_:][0-9]+[_:][ATCG*]+[_:][ATCG*]+$", reference) - - if (!all(sourcePattern) && !all(referencePattern)) { - warning("Cannot unify variant names because they do not follow the expected variant naming convention chr:pos:A2:A1 or chr:pos_A2_A1.") - return(list(alignedVariants = source, unmatchedIndices = integer(0))) - } - - if ((!all(sourcePattern) && all(referencePattern)) || (all(sourcePattern) && !all(referencePattern))) { - stop("Source and reference have different variant naming conventions. They cannot be aligned.") - } - - # Detect reference convention to preserve in output - refConvention <- detectVariantConvention(reference) - - sourceDf <- parseVariantId(source) - referenceDf <- parseVariantId(reference) - - qcResult <- .matchRefPanel( - targetData = sourceDf, - refVariants = referenceDf, - colToFlip = NULL, - matchMinProp = 0, - removeDups = FALSE, - flipStrand = TRUE, - removeIndels = removeIndels, - removeStrandAmbiguous = FALSE, - removeUnmatched = FALSE - ) - - alignedDf <- qcResult$harmonizedData - - # When no variants harmonize against the reference, return the source - # unchanged with every position flagged as unmatched. paste0() with all - # length-0 components otherwise collapses to a single "chr:::"-style - # placeholder that callers then assign back to colnames with wrong length. - if (nrow(alignedDf) == 0L) { - return(list(alignedVariants = source, - unmatchedIndices = seq_along(source))) - } - - # Format output using reference convention (preserving user's format automatically) - alignedVariants <- formatVariantId( - alignedDf$chrom, alignedDf$pos, alignedDf$A2, alignedDf$A1, - convention = refConvention - ) - names(alignedVariants) <- NULL - - # Normalize reference to the same output format for accurate matching - refNormalized <- normalizeVariantId(reference, convention = refConvention) - unmatchedIndices <- which(match(alignedVariants, refNormalized, nomatch = 0) == 0) - - list( - alignedVariants = alignedVariants, - unmatchedIndices = unmatchedIndices - ) -} +# Allele harmonization (harmonizeAlleles) now lives in R/variantId.R, alongside +# the other variant-matching primitives (parseVariantId, matchVariants). It is +# package-internal and called from here (.matchAgainstSketch), ctwasPipeline, +# and the pipeline join sites. #' Merge variant info from two sources with allele-flip-aware matching #' @@ -2401,7 +2068,7 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, # ============================================================================= # Convert one entry's GRanges into a flat data.frame with the column shape -# .matchRefPanel expects (lower-case chrom/pos plus the CapsCase mcols). +# harmonizeAlleles expects (lower-case chrom/pos plus the CapsCase mcols). .entryGrangesToDf <- function(gr) { mc <- as.data.frame(S4Vectors::mcols(gr), stringsAsFactors = FALSE) out <- data.frame( @@ -2413,7 +2080,7 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, } # Build a refVariants data.frame (chrom, pos, A1, A2, variant_id) from the -# ldSketch GenotypeHandle's snpInfo so .matchRefPanel can join by (chrom, pos). +# ldSketch GenotypeHandle's snpInfo so harmonizeAlleles can join by (chrom, pos). .refVariantsFromSketch <- function(handle) { si <- getSnpInfo(handle) chr <- sub("^chr", "", as.character(si$CHR), ignore.case = TRUE) @@ -2633,7 +2300,7 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, } # Apply the panel-vs-sumstats allele harmonization using the slim -# .matchRefPanel against the ldSketch's variant info. Threads the +# harmonizeAlleles against the ldSketch's variant info. Threads the # variant-level filters (indels, strand-ambiguous, duplicates) through # so the LD-panel-anchored pass handles them in a single sweep. .matchAgainstSketch <- function(df, ldSketch, matchMinProp, @@ -2649,7 +2316,7 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, colToComplement <- intersect("MAF", colnames(df)) if (!"A1" %in% colnames(df) || !"A2" %in% colnames(df)) stop("summaryStatsQc: input entry must contain A1 and A2 columns.") - res <- .matchRefPanel( + res <- harmonizeAlleles( targetData = df, refVariants = refVariants, colToFlip = colToFlip, @@ -2859,12 +2526,14 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, variantIds <- df$SNP if (is.null(variantIds) || any(is.na(variantIds))) stop("summaryStatsQc: ldMismatchQc requires SNP column on the entry.") - # Extract the panel block for these variants. - snpIdx <- match(variantIds, as.character(getSnpInfo(ldSketch)$SNP)) - if (anyNA(snpIdx)) - stop("summaryStatsQc: ", sum(is.na(snpIdx)), " variant(s) in entry are ", - "absent from the ldSketch panel; harmonize / impute before ", - "calling zMismatchQc.") + # Match the entry variants to the panel by (chrom, pos, allele) tuple so a + # chr-prefix / separator difference does not read as "absent". + m <- matchVariants(variantIds, as.character(getSnpInfo(ldSketch)$SNP)) + if (length(m$idxA) < length(variantIds)) + stop("summaryStatsQc: ", length(variantIds) - length(m$idxA), + " variant(s) in entry are absent from the ldSketch panel; ", + "harmonize / impute before calling zMismatchQc.") + snpIdx <- m$idxB[order(m$idxA)] # panel rows, in entry order block <- extractBlockGenotypes(ldSketch, snpIdx, meanImpute = TRUE) dosage <- t(SummarizedExperiment::assay(block, "dosage")) colnames(dosage) <- variantIds @@ -2948,7 +2617,7 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, # 2. Variant-content filters (MAF / INFO / N). Pure column-numeric # filters; the indel / strand-ambiguous variant-allele filtering happens - # inside .matchAgainstSketch via .matchRefPanel against the LD panel. + # inside .matchAgainstSketch via harmonizeAlleles against the LD panel. nFiltIn <- nrow(df) contentFiltered <- .applyContentFilters( df, @@ -3051,7 +2720,12 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, # 6. Optional kriging prefilter. if (isTRUE(opts$alleleFlipKriging) && nrow(df) >= 2L) { nKrIn <- nrow(df) - snpIdx <- match(df$SNP, as.character(getSnpInfo(ldSketch)$SNP)) + m <- matchVariants(df$SNP, as.character(getSnpInfo(ldSketch)$SNP)) + if (length(m$idxA) < nrow(df)) + stop("summaryStatsQc: ", nrow(df) - length(m$idxA), + " variant(s) absent from the ldSketch panel; harmonize / impute ", + "before the kriging prefilter.") + snpIdx <- m$idxB[order(m$idxA)] # panel rows, in entry order block <- extractBlockGenotypes(ldSketch, snpIdx, meanImpute = TRUE) dosage <- t(SummarizedExperiment::assay(block, "dosage")) colnames(dosage) <- df$SNP @@ -3089,6 +2763,10 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, if (isTRUE(opts$impute) && nrow(df) >= 1L) { qcCount$imputeBefore <- nrow(df) refPanel <- .refVariantsFromSketch(ldSketch) + # Canonicalize the panel ids so they align with the QC'd entry ids (df$SNP + # is already canonical) across chr-prefix / separator differences -- raiss() + # matches knownZscores$variant_id against refPanel$variant_id by string. + refPanel$variant_id <- normalizeVariantId(refPanel$variant_id) refPanel <- refPanel[order(refPanel$pos), , drop = FALSE] knownVariantIds <- if (!is.null(df$SNP)) as.character(df$SNP) @@ -3111,7 +2789,7 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, block <- extractBlockGenotypes( ldSketch, seq_len(nrow(sketchSnpInfo)), meanImpute = TRUE) dosage <- t(SummarizedExperiment::assay(block, "dosage")) - colnames(dosage) <- as.character(sketchSnpInfo$SNP) + colnames(dosage) <- normalizeVariantId(as.character(sketchSnpInfo$SNP)) dosage <- dosage[, refPanel$variant_id, drop = FALSE] scaledDosage <- scale(dosage) scaledDosage[is.na(scaledDosage)] <- 0 @@ -3223,7 +2901,7 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, #' numeric), variant-content filters (MAF / INFO / N) via #' \code{.applyContentFilters}, optional \code{skipRegion} drop, optional #' PIP screen, panel-vs-sumstats allele harmonization against the -#' \code{ldSketch} via \code{.matchRefPanel} (which handles indels, +#' \code{ldSketch} via \code{harmonizeAlleles} (which handles indels, #' strand-ambiguous variants, sign / strand flips, and duplicate drops in #' a single sweep), optional SLALOM/DENTIST LD-mismatch QC, and optional #' RAISS imputation. No Bioconductor genome / dbSNP packages required. diff --git a/R/variantId.R b/R/variantId.R index 5021f487..e7ef5ce6 100644 --- a/R/variantId.R +++ b/R/variantId.R @@ -13,6 +13,48 @@ NULL #' @noRd stripChrPrefix <- function(x) sub("^chr", "", x) +#' Canonicalize chromosome identifiers to a normalized string. +#' +#' Strips a leading "chr"/"ch" prefix (case-insensitive), uppercases, and maps +#' common synonyms to a single form (23 -> X, 24 -> Y, M -> MT). Returns a +#' character vector and never coerces to integer, so non-autosomal chromosomes +#' (X, Y, MT) survive instead of collapsing to NA. This is the single chromosome +#' normalizer used for variant matching and identity throughout the package; +#' it mirrors the chromosome handling previously inlined in summary-statistics +#' QC. +#' +#' @param x Character or numeric vector of chromosome identifiers. +#' @return Character vector of normalized chromosome names. +#' @noRd +canonChrom <- function(x) { + x <- as.character(x) + x <- sub("^chr", "", x, ignore.case = TRUE) + x <- sub("^ch", "", x, ignore.case = TRUE) + x <- toupper(x) + ok <- !is.na(x) + x[ok & x == "23"] <- "X" + x[ok & x == "24"] <- "Y" + x[ok & x == "M"] <- "MT" + x +} + +#' Order key for chromosome identifiers. +#' +#' Returns an ordered factor placing autosomes 1..22 first, then X, Y, XY, MT, +#' and finally any non-standard contigs (in order of appearance). Use this in +#' place of \code{as.integer(chrom)} wherever chromosomes must be sorted, so +#' that X / Y / MT sort sensibly instead of collapsing to NA. +#' +#' @param x Vector of chromosome identifiers. +#' @return An ordered factor suitable for \code{order()} / \code{arrange()}. +#' @noRd +chromOrder <- function(x) { + x <- canonChrom(x) + standard <- c(as.character(1:22), "X", "Y", "XY", "MT") + extra <- setdiff(unique(x[!is.na(x)]), standard) + factor(x, levels = c(standard, extra), ordered = TRUE) +} + # Backwards-compat alias #' Strip build suffix from variant IDs (e.g., ":b38" or "_b38"). @@ -81,15 +123,18 @@ detectVariantConvention <- function(ids) { #' Parse variant IDs into a data frame #' #' Converts variant IDs from any supported string format or data.frame into a -#' standardized data.frame with integer chrom, integer pos, and character allele -#' columns (A2, A1). Supports colon-separated ("chr1:100:A:G"), underscore-separated +#' standardized data.frame with a normalized character chrom, integer pos, and +#' character allele columns (A2, A1). The chrom is canonicalized (chr stripped, +#' uppercased, 23 -> X / 24 -> Y / M -> MT) but kept as a string so X/Y/MT +#' survive. Supports colon-separated ("chr1:100:A:G"), underscore-separated #' ("1_100_A_G"), with or without "chr" prefix, and with optional build suffix #' (":b38" or "_b38"). The detected input convention is stored as an attribute. #' #' @param ids A character vector of variant IDs, or a data.frame with columns #' "chrom", "pos", and allele columns (A2/A1 or ref/alt or any 4-column layout). -#' @return A data.frame with columns "chrom" (integer), "pos" (integer), "A2" -#' (character), "A1" (character). The detected convention is stored as +#' @return A data.frame with columns "chrom" (character, normalized), "pos" +#' (integer), "A2" (character), "A1" (character). The detected convention is +#' stored as #' \code{attr(result, "convention")}. #' @export parseVariantId <- function(ids) { @@ -109,7 +154,7 @@ parseVariantId <- function(ids) { hasChr = any(grepl("^chr", as.character(ids$chrom))), alleleSep = ":", hasBuild = FALSE, example = NA_character_ ) - ids$chrom <- as.integer(stripChrPrefix(as.character(ids$chrom))) + ids$chrom <- canonChrom(ids$chrom) ids$pos <- as.integer(ids$pos) attr(ids, "convention") <- conv return(ids) @@ -131,7 +176,7 @@ parseVariantId <- function(ids) { stringsAsFactors = FALSE) ) - data$chrom <- as.integer(stripChrPrefix(data$chrom)) + data$chrom <- canonChrom(data$chrom) data$pos <- as.integer(data$pos) attr(data, "convention") <- convention @@ -172,8 +217,9 @@ formatVariantId <- function(chrom, pos, A2, A1, chrPrefix = TRUE, alleleSep = ": chrPrefix <- convention$hasChr alleleSep <- if (!is.null(convention$alleleSep)) convention$alleleSep else ":" } - # Strip any existing chr prefix to normalize, then re-add if requested - chromClean <- stripChrPrefix(as.character(chrom)) + # Normalize the chromosome (strip prefix, uppercase, map synonyms) then re-add + # the "chr" prefix if requested. canonChrom keeps X/Y/MT as strings. + chromClean <- canonChrom(chrom) if (chrPrefix) { paste0("chr", chromClean, ":", pos, alleleSep, A2, alleleSep, A1) } else { @@ -183,12 +229,19 @@ formatVariantId <- function(chrom, pos, A2, A1, chrPrefix = TRUE, alleleSep = ": # Backwards-compat alias for external callers -#' Normalize variant IDs to canonical format +#' Re-format variant IDs to a chosen output convention +#' +#' Output-only convenience: parses variant IDs and re-emits them in a single +#' format. By default produces the canonical format +#' (\code{"chr{N}:{pos}:{A2}:{A1}"}); pass a \code{convention} to preserve the +#' input format instead. #' -#' One-step convenience function: parses variant IDs in any supported format -#' and re-formats them. By default, outputs the canonical format -#' (\code{"chr{N}:{pos}:{A2}:{A1}"}). When a \code{convention} object is -#' provided, the output preserves the user's original format automatically. +#' This normalizes only the textual \emph{format} (chr prefix and field +#' separators); it does NOT reorder alleles, so it is not a matching/identity +#' operation -- two records that differ by a ref/alt swap remain distinct +#' strings. For identity, match on the (chrom, pos, ref, alt) tuple via the +#' variant matcher; use this only for display, file output, or relabeling for +#' name-based downstream consumers. #' #' @param ids A character vector of variant IDs in any supported format. #' @param chrPrefix Logical, whether to include "chr" prefix. Default TRUE. @@ -196,15 +249,24 @@ formatVariantId <- function(chrom, pos, A2, A1, chrPrefix = TRUE, alleleSep = ": #' @param convention Optional list from \code{detectVariantConvention} or #' \code{attr(parseVariantId(ids), "convention")}. When provided, the #' output format is driven automatically by the detected convention. -#' @return A character vector of normalized variant IDs. +#' @return A character vector of re-formatted variant IDs. Unparseable ids +#' (e.g. rsIDs) are returned unchanged. #' @export normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { parsed <- parseVariantId(ids) - if (!is.null(convention)) { - formatVariantId(parsed$chrom, parsed$pos, parsed$A2, parsed$A1, convention = convention) - } else { - formatVariantId(parsed$chrom, parsed$pos, parsed$A2, parsed$A1, chrPrefix = chrPrefix) + out <- as.character(ids) + # Only re-format ids that parsed into a chrom + pos; leave unparseable ids + # (e.g. rsIDs) unchanged rather than emitting "chrNA:..." garbage. + ok <- !is.na(parsed$chrom) & !is.na(parsed$pos) + if (any(ok)) { + out[ok] <- if (!is.null(convention)) + formatVariantId(parsed$chrom[ok], parsed$pos[ok], parsed$A2[ok], + parsed$A1[ok], convention = convention) + else + formatVariantId(parsed$chrom[ok], parsed$pos[ok], parsed$A2[ok], + parsed$A1[ok], chrPrefix = chrPrefix) } + out } #' @export @@ -214,6 +276,342 @@ variantIdToDf <- function(variantId) { parseVariantId(variantId) } +#' Harmonize variant alleles against a reference +#' +#' The allele-harmonization engine for the package (used by summary-statistics +#' QC, ctwasPipeline, and -- via \code{matchVariants} -- the pipeline join +#' sites). Matches a target against a reference by ("chrom", "pos") and the +#' allele pair ("A2", "A1"), accounting for strand flips and major/minor allele +#' (ref/alt) swaps, and sign-flips the specified columns when alleles are +#' swapped relative to the reference. +#' +#' @param targetData A data frame with columns "chrom", "pos", "A2", "A1" (and optionally other columns like "beta" or "z"), +#' or a vector of strings in the format of "chr:pos:A2:A1"/"chr:pos_A2_A1". Can be automatically converted to a data frame if a vector. +#' @param refVariants A data frame with columns "chrom", "pos", "A2", "A1" or strings in the format of "chr:pos:A2:A1"/"chr:pos_A2_A1". +#' @param colToFlip The name of the column in targetData where flips are to be applied. +#' On an allele swap these columns are sign-flipped (multiplied by -1), the +#' correct operation for signed quantities like \code{beta} and \code{z}. +#' @param colToComplement Names of columns in targetData to complement +#' (\code{1 - x}) on an allele swap, the correct operation for an +#' effect-allele frequency like \code{af}. Default \code{character()} does no +#' complementing, so non-RSS callers are unchanged. Distinct from +#' \code{colToFlip}: frequencies are complemented, signed effects are +#' sign-flipped. +#' @param matchMinProp Minimum proportion of variants in the smallest data +#' to be matched, otherwise stops with an error. Default is 20%. +#' @param removeDups Whether to remove duplicates, default is TRUE. +#' @param removeIndels Whether to remove INDELs, default is FALSE. +#' @param flip Whether the alleles must be flipped: A <--> T & C <--> G, in which case +#' corresponding `colToFlip` are multiplied by -1. Default is `TRUE`. +#' @param removeStrandAmbiguous Whether to remove strand SNPs (if any). Default is `TRUE`. +#' @param flipStrand Whether to output the variants after strand flip. Default is `FALSE`. +#' @param removeUnmatched Whether to remove unmatched variants. Default is `TRUE`. +#' @return An \code{AlleleQcResult} S4 object. Use +#' \code{$harmonizedData} to recover the post-QC variant +#' data.frame and \code{$qcSummary} to inspect the per-variant +#' merge/flip/strand diagnostics. +#' @importFrom magrittr %>% +#' @importFrom dplyr mutate inner_join filter pull select everything row_number if_else any_of all_of rename +#' @importFrom vctrs vec_duplicate_detect +#' @importFrom tidyr separate +#' @keywords internal +#' @noRd +#' @details +#' Pure panel-vs-sumstats allele harmonization: match by (chrom, pos), +#' detect A1/A2 swap, sign-flip \code{colToFlip} columns and complement +#' \code{colToComplement} columns on swap. Variant-allele filters +#' (indels, strand-ambiguous, duplicates) are applied here directly when +#' the corresponding \code{removeIndels} / \code{removeStrandAmbiguous} / +#' \code{removeDups} flags are set; MAF / INFO / N column-numeric filters +#' run in \code{.applyContentFilters()} before this function. +harmonizeAlleles <- function(targetData, refVariants, colToFlip = NULL, + matchMinProp = 0.2, flipStrand = FALSE, + removeUnmatched = TRUE, + removeIndels = FALSE, + removeStrandAmbiguous = TRUE, + removeDups = FALSE, + colToComplement = character(), ...) { + strandFlip <- function(ref) chartr("ATCG", "TAGC", ref) + + sanitizeNames <- function(df) { + nm <- colnames(df) + if (is.null(nm)) nm <- rep("unnamed", ncol(df)) + emptyIdx <- is.na(nm) | nm == "" + if (any(emptyIdx)) + nm[emptyIdx] <- paste0("unnamed_", seq_len(sum(emptyIdx))) + colnames(df) <- make.unique(nm, sep = "_") + df + } + + if (is.data.frame(targetData)) { + if (ncol(targetData) > 4 && + all(c("chrom", "pos", "A2", "A1") %in% names(targetData))) { + variantCols <- c("chrom", "pos", "A2", "A1") + variantDf <- targetData %>% select(all_of(variantCols)) + otherCols <- targetData %>% select(-all_of(variantCols)) + targetData <- cbind(variantIdToDf(variantDf), otherCols) + } else { + targetData <- variantIdToDf(targetData) + } + } else { + targetData <- variantIdToDf(targetData) + } + refVariants <- variantIdToDf(refVariants) + + # Strip merge-conflicting columns; keep target A1/A2. `variant_id` is also + # stripped from `refVariants` because the post-harmonization variant_id is + # rebuilt from the QC'd alleles further down (`variants_id_qced`), and + # leaving the input variant_id on either side causes the final rename to + # collide on duplicate names. + columnsToRemove <- c("chromosome", "position", "ref", "alt", "variant_id") + if (any(columnsToRemove %in% colnames(targetData))) + targetData <- select(targetData, -any_of(columnsToRemove)) + if ("variant_id" %in% colnames(refVariants)) + refVariants <- select(refVariants, -any_of("variant_id")) + + matchResult <- inner_join(targetData, refVariants, + by = c("chrom", "pos"), + suffix = c(".target", ".ref")) %>% + as.data.frame() %>% + sanitizeNames() + + if (nrow(matchResult) == 0) { + warning("No matching variants found between target data and reference variants.") + emptyOut <- list(harmonizedData = matchResult, qcSummary = matchResult) + attr(emptyOut, "qcCounts") <- list( + considered = 0L, signFlip = 0L, strandFlip = 0L, kept = 0L, + dropped = 0L, droppedIndel = 0L, droppedAmbiguous = 0L, + droppedOther = 0L) + return(emptyOut) + } + + matchResult <- matchResult %>% + mutate(variants_id_original = formatVariantId(chrom, pos, A2.target, A1.target), + variants_id_qced = formatVariantId(chrom, pos, A2.ref, A1.ref)) %>% + mutate(across(c(A1.target, A2.target, A1.ref, A2.ref), toupper)) %>% + mutate(flip1.ref = strandFlip(A1.ref), + flip2.ref = strandFlip(A2.ref)) %>% + # AT / CG pairs cannot be distinguished from strand-flip without external + # context; the keep rule below relies on this flag as a safety guard for + # callers that may not have removed strand-ambiguous variants upstream. + mutate(strand_unambiguous = if_else( + (A1.target == "A" & A2.target == "T") | + (A1.target == "T" & A2.target == "A") | + (A1.target == "C" & A2.target == "G") | + (A1.target == "G" & A2.target == "C"), + FALSE, TRUE)) %>% + mutate(exact_match = A1.target == A1.ref & A2.target == A2.ref) %>% + mutate(sign_flip = ((A1.target == A2.ref & A2.target == A1.ref) | + (A1.target == flip2.ref & A2.target == flip1.ref)) & + (A1.target != A1.ref & A2.target != A2.ref)) %>% + mutate(strand_flip = ((A1.target == flip1.ref & A2.target == flip2.ref) | + (A1.target == flip2.ref & A2.target == flip1.ref)) & + (A1.target != A1.ref & A2.target != A2.ref)) %>% + # INDEL detection: explicit "I"/"D" notation, or any allele wider than 1bp. + mutate(INDEL = (A2.target == "I" | A2.target == "D" | + nchar(A2.target) > 1L | nchar(A1.target) > 1L)) %>% + # ID_match: an indel encoded as I/D on the target side matches an indel + # on the reference side (where the reference uses multi-base alleles). + mutate(ID_match = ((A2.target == "D" | A2.target == "I") & + (nchar(A1.ref) > 1L | nchar(A2.ref) > 1L))) + + # When removeStrandAmbiguous = FALSE, the A/T - C/G safety guard is + # disabled: ambiguous variants are treated as exact/sign-flip cases. + if (!removeStrandAmbiguous) + matchResult$strand_unambiguous <- TRUE + + # If no strand_flip survives the unambiguous test, the remaining ambiguous + # variants can be treated as exact/sign-flip cases rather than dropped. + if (!any(matchResult$strand_flip & matchResult$strand_unambiguous)) + matchResult$strand_unambiguous <- TRUE + + matchResult <- matchResult %>% + mutate(keep = if_else(strand_flip, + true = strand_unambiguous | exact_match | ID_match, + false = exact_match | sign_flip | ID_match)) + + if (removeIndels) + matchResult <- matchResult %>% + mutate(keep = if_else(INDEL, FALSE, keep)) + + if (!is.null(colToFlip)) { + missing <- setdiff(colToFlip, colnames(matchResult)) + if (length(missing) > 0L) + stop("Column(s) '", paste(missing, collapse = "', '"), + "' not found in targetData.") + matchResult[matchResult$sign_flip, colToFlip] <- + -1 * matchResult[matchResult$sign_flip, colToFlip] + } + # A frequency tracks the effect allele, so an allele swap takes af -> 1 - af + # (not a sign flip). Kept independent of colToFlip so signed columns are + # untouched here. + if (length(colToComplement) > 0L) { + missing <- setdiff(colToComplement, colnames(matchResult)) + if (length(missing) > 0L) + stop("Column(s) '", paste(missing, collapse = "', '"), + "' not found in targetData.") + matchResult[matchResult$sign_flip, colToComplement] <- + 1 - matchResult[matchResult$sign_flip, colToComplement] + } + if (flipStrand) { + sIdx <- which(matchResult$strand_flip) + matchResult[sIdx, "A1.target"] <- strandFlip(matchResult[sIdx, "A1.target"]) + matchResult[sIdx, "A2.target"] <- strandFlip(matchResult[sIdx, "A2.target"]) + } + + # Per-step QC counts (used by .runEntrySummaryStatsQc for "kept N of M + # (corrected: sign-flipped A, strand-flipped B; dropped C)" logging). + # Computed from the per-variant flags before they are stripped from the + # returned data frame so callers reading the data frame are unaffected. + qcCounts <- list( + considered = nrow(matchResult), + signFlip = sum(matchResult$sign_flip & matchResult$keep, na.rm = TRUE), + strandFlip = sum(matchResult$strand_flip & matchResult$keep, na.rm = TRUE), + kept = sum(matchResult$keep, na.rm = TRUE), + dropped = sum(!matchResult$keep, na.rm = TRUE)) + if ("INDEL" %in% colnames(matchResult)) { + qcCounts$droppedIndel <- sum(!matchResult$keep & matchResult$INDEL, + na.rm = TRUE) + } else { + qcCounts$droppedIndel <- 0L + } + qcCounts$droppedAmbiguous <- sum( + !matchResult$keep & matchResult$strand_flip & + !matchResult$strand_unambiguous & + if ("INDEL" %in% colnames(matchResult)) !matchResult$INDEL else TRUE, + na.rm = TRUE) + qcCounts$droppedOther <- qcCounts$dropped - qcCounts$droppedIndel - + qcCounts$droppedAmbiguous + + result <- matchResult[matchResult$keep, , drop = FALSE] + + qcCols <- c("flip1.ref", "flip2.ref", "strand_unambiguous", + "exact_match", "sign_flip", "strand_flip", "INDEL", + "ID_match", "keep") + result <- result %>% + select(-any_of(qcCols), -A1.target, -A2.target) %>% + rename(A1 = A1.ref, A2 = A2.ref, variant_id = variants_id_qced) + + # removeDups: drop duplicate variant rows (same chrom/pos/qced ID). + # Default FALSE keeps the existing strict behavior (error on dups). + if (removeDups) { + dups <- duplicated(result[, c("chrom", "pos", "variant_id")]) + if (any(dups)) { + warning(sprintf("Removed %d duplicate variant(s), keeping first occurrence.", + sum(dups))) + result <- result[!dups, , drop = FALSE] + } + } + + if (!removeUnmatched) { + matchVariant <- result %>% pull(variants_id_original) + matchResult <- matchResult %>% + select(-any_of(qcCols), -variants_id_original, -A1.target, -A2.target) %>% + rename(A1 = A1.ref, A2 = A2.ref, variant_id = variants_id_qced) + targetData <- targetData %>% + mutate(variant_id = formatVariantId(chrom, pos, A2, A1)) + if (length(setdiff(targetData %>% pull(variant_id), matchVariant)) > 0L) { + unmatchData <- targetData %>% filter(!variant_id %in% matchVariant) + result <- rbind(result, + unmatchData %>% mutate(variants_id_original = variant_id)) + result <- result[match(targetData$variant_id, + result$variants_id_original), ] %>% + select(-variants_id_original) + } + } + + if (nrow(result) < matchMinProp * nrow(refVariants)) + stop("Not enough variants have been matched.") + if (any(duplicated(result$variant_id))) + stop("Duplicated variant IDs remain after harmonization; pass ", + "removeDups = TRUE or deduplicate upstream before calling ", + "harmonizeAlleles.") + + out <- list(harmonizedData = result, qcSummary = matchResult) + attr(out, "qcCounts") <- qcCounts + out +} + +#' Allele-aware variant matcher (match by chrom/pos/ref/alt, not id string) +#' +#' The single matching primitive for the package: given two sets of variant +#' identifiers, match them on the (chrom, pos) position and the allele pair +#' (exact, ref/alt swap, strand flip) rather than by raw id-string equality. +#' This makes matching robust to chr-prefix, field-separator, and allele-order +#' differences -- the id string is a serialization, not an identity. +#' +#' Allele semantics mirror summary-statistics QC (it delegates the allele +#' classification to \code{harmonizeAlleles}): an allele swap is matched and +#' reported with \code{sign = -1} so callers can sign-flip a paired effect / z +#' / weight; strand flips are resolved; and strand-ambiguous (A/T, C/G) matches +#' are dropped when \code{removeStrandAmbiguous = TRUE}. +#' +#' When ids cannot be parsed into chrom/pos/ref/alt (e.g. rsIDs), the matcher +#' falls back to exact string identity with \code{sign = 1} (no allele +#' awareness is possible without alleles). +#' +#' @param idsA,idsB Character vectors of variant IDs, or data.frames with +#' chrom/pos/A2/A1 columns (A2 = ref, A1 = alt). +#' @param allowFlip When TRUE (default) match by (chrom, pos) with ref/alt swap +#' and strand handling, reporting \code{sign = -1} for a swap. When FALSE, +#' match on exact alleles only (canonicalized format; \code{sign} always +1) +#' so a ref/alt swap does not match. +#' @param removeStrandAmbiguous Drop strand-ambiguous (A/T, C/G) matches. +#' Default TRUE (mirrors summaryStatsQc). +#' @param removeIndels Drop indels. Default FALSE. +#' @return A list of three equal-length vectors describing the matched pairs: +#' \code{idxA} / \code{idxB} (indices into \code{idsA} / \code{idsB}) and +#' \code{sign} (+1 exact, -1 allele-swap). At most one pair per \code{idsA} +#' entry; unmatched entries are omitted. +#' @noRd +matchVariants <- function(idsA, idsB, allowFlip = TRUE, + removeStrandAmbiguous = TRUE, + removeIndels = FALSE) { + empty <- list(idxA = integer(0), idxB = integer(0), sign = numeric(0)) + if (!allowFlip) { + # Exact-allele matching: canonicalize the id FORMAT (chr-prefix + separator, + # rsID-safe) but keep allele order, then match by exact string identity, so + # a ref/alt swap does NOT match (sign is always +1). + keyOf <- function(x) if (is.data.frame(x)) { + p <- parseVariantId(x) + formatVariantId(p$chrom, p$pos, p$A2, p$A1) + } else normalizeVariantId(x) + idxB <- match(keyOf(idsA), keyOf(idsB)) + matched <- which(!is.na(idxB)) + return(list(idxA = matched, idxB = idxB[matched], + sign = rep(1, length(matched)))) + } + dfA <- parseVariantId(idsA) + dfB <- parseVariantId(idsB) + unparseable <- nrow(dfA) == 0L || nrow(dfB) == 0L || + anyNA(dfA$chrom) || anyNA(dfA$pos) || + anyNA(dfB$chrom) || anyNA(dfB$pos) + if (unparseable) { + # rsID / unparseable ids: exact string identity only (no allele awareness). + if (is.data.frame(idsA) || is.data.frame(idsB)) return(empty) + idxB <- match(as.character(idsA), as.character(idsB)) + matched <- which(!is.na(idxB)) + return(list(idxA = matched, idxB = idxB[matched], + sign = rep(1, length(matched)))) + } + # Inject sentinel index/sign columns so the matched pairs and the swap sign + # can be read straight back out of harmonizeAlleles without re-deriving them. + dfA$.mvTidx <- seq_len(nrow(dfA)) + dfA$.mvSign <- 1 + dfB$.mvRidx <- seq_len(nrow(dfB)) + res <- suppressWarnings(harmonizeAlleles( + targetData = dfA, refVariants = dfB, + colToFlip = ".mvSign", matchMinProp = 0, removeDups = TRUE, + flipStrand = FALSE, removeIndels = removeIndels, + removeStrandAmbiguous = removeStrandAmbiguous, removeUnmatched = TRUE)) + h <- res$harmonizedData + if (is.null(h) || nrow(h) == 0L) return(empty) + keep <- !duplicated(h$.mvTidx) # at most one ref per A id + list(idxA = as.integer(h$.mvTidx[keep]), + idxB = as.integer(h$.mvRidx[keep]), + sign = as.numeric(h$.mvSign[keep])) +} + # Backwards-compat alias for external callers #' @importFrom stringr str_split @@ -228,7 +626,7 @@ parseRegion <- function(region) { } parts <- str_split(region, "[:-]")[[1]] df <- data.frame( - chrom = stripChrPrefix(parts[1]), + chrom = canonChrom(parts[1]), start = as.integer(parts[2]), end = as.integer(parts[3]) ) @@ -237,36 +635,21 @@ parseRegion <- function(region) { } #' Utility function to convert LD region_ids to `region of interest` dataframe +#' +#' The first field is treated as the chromosome and kept as a normalized string +#' (via \code{canonChrom}) so X/Y/MT survive; the remaining fields are genomic +#' positions and are returned as integers. #' @param ldRegionId A string of region in the format of chrom_start_end. #' @export regionToDf <- function(ldRegionId, colnames = c("chrom", "start", "end")) { - regionOfInterest <- as.data.frame(do.call(rbind, lapply(strsplit(ldRegionId, "[_:-]"), function(x) as.integer(stripChrPrefix(x))))) + parts <- do.call(rbind, strsplit(ldRegionId, "[_:-]")) + regionOfInterest <- as.data.frame(parts, stringsAsFactors = FALSE) colnames(regionOfInterest) <- colnames - return(regionOfInterest) -} - -#' Ensure two sets of variant IDs use matching chr prefix convention -#' -#' Detects whether \code{idsA} and \code{idsB} have mismatched chr prefixes. -#' If mismatched, normalizes both to canonical format (with "chr" prefix) using -#' \code{\link{normalizeVariantId}}. If already matching, returns inputs -#' unchanged. -#' -#' @param idsA Character vector of variant IDs. -#' @param idsB Character vector of variant IDs. -#' @return A list with components \code{idsA} and \code{idsB}, both normalized -#' to canonical chr-prefix format if they were mismatched. -#' @noRd -ensureChrMatch <- function(idsA, idsB) { - hasChrA <- any(grepl("^chr", idsA[!is.na(idsA)][1:min(5, sum(!is.na(idsA)))])) - hasChrB <- any(grepl("^chr", idsB[!is.na(idsB)][1:min(5, sum(!is.na(idsB)))])) - if (hasChrA == hasChrB) { - return(list(idsA = idsA, idsB = idsB)) + regionOfInterest[[1]] <- canonChrom(regionOfInterest[[1]]) + for (j in seq_along(colnames)[-1]) { + regionOfInterest[[j]] <- as.integer(regionOfInterest[[j]]) } - list( - idsA = normalizeVariantId(idsA, chrPrefix = TRUE), - idsB = normalizeVariantId(idsB, chrPrefix = TRUE) - ) + regionOfInterest } # Backwards-compat alias for external callers diff --git a/man/alignVariantNames.Rd b/man/alignVariantNames.Rd index ae217e29..c123577e 100644 --- a/man/alignVariantNames.Rd +++ b/man/alignVariantNames.Rd @@ -1,36 +1,21 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sumstatsQc.R +% Please edit documentation in R/deprecated.R \name{alignVariantNames} \alias{alignVariantNames} -\title{Align Variant Names} +\title{(Deprecated) Align variant names to a reference convention} \usage{ -alignVariantNames( - source, - reference, - removeIndels = FALSE, - removeBuildSuffix = TRUE -) +alignVariantNames(source, reference, ...) } \arguments{ -\item{source}{A character vector of variant names in the format "chr:pos:A2:A1" or "chr:pos_A2_A1".} +\item{source, reference}{Character vectors of variant ids.} -\item{reference}{A character vector of variant names in the format "chr:pos:A2:A1" or "chr:pos_A2_A1".} - -\item{removeBuildSuffix}{Whether to strip trailing genome build suffixes like ":b38" or "_b38" before alignment. Default TRUE.} +\item{...}{Ignored.} } \value{ -A list with two elements: -- alignedVariants: A character vector of aligned variant names. -- unmatchedIndices: A vector of indices for the variants in the source that could not be matched. +\code{NULL} (invisibly). } \description{ -This function aligns variant names from two strings containing variant names in the format of -"chr:pos:A1:A2" or "chr:pos_A1_A2". The first string should be the "source" and the second -should be the "reference". -} -\examples{ -source <- c("1:123:A:C", "2:456:G:T", "3:789:C:A") -reference <- c("1:123:A:C", "2:456:T:G", "4:101:G:C") -alignVariantNames(source, reference) - +\strong{Deprecated.} Match with \code{\link{matchVariants}} and relabel +directly, e.g. \code{m <- matchVariants(source, reference)} then +\code{source[m$idxA] <- reference[m$idxB]}. } diff --git a/man/causalInferencePipeline.Rd b/man/causalInferencePipeline.Rd index 5438531a..75feb4fe 100644 --- a/man/causalInferencePipeline.Rd +++ b/man/causalInferencePipeline.Rd @@ -17,6 +17,7 @@ causalInferencePipeline( mrCpipCutoff = 0.5, mrPvalCutoff = 1, combineMethods = NULL, + alleleFlip = TRUE, ... ) } @@ -90,6 +91,11 @@ exists).} \code{(qtlStudy, context, trait, gwasStudy)} group. \code{NULL} (default) skips combination.} +\item{alleleFlip}{Logical, default \code{TRUE}. When TRUE, match QTL variants +to the GWAS by (chrom, pos) with ref/alt swaps recognized and the exposure +effect / weight sign-flipped accordingly; when FALSE, match on exact +alleles only, so a ref/alt swap is treated as a distinct variant.} + \item{...}{Reserved.} } \value{ diff --git a/man/colocPipeline.Rd b/man/colocPipeline.Rd index b1e3aff5..4f5f3490 100644 --- a/man/colocPipeline.Rd +++ b/man/colocPipeline.Rd @@ -19,6 +19,7 @@ colocPipeline( enrichment = NULL, p12Max = 0.001, adjustPips = TRUE, + alleleFlip = TRUE, ... ) } @@ -95,6 +96,11 @@ and the QTL fine-mapping input has additional variants; (2) the GWAS fine-mapping result contains variants not present in the QTL fine-mapping result. Pass \code{FALSE} to use the FMRs as supplied.} +\item{alleleFlip}{Logical, default \code{TRUE}. When TRUE, align LBF columns +between the QTL and GWAS by (chrom, pos) with ref/alt swaps recognized +(LBF is coding-invariant, so no sign change is needed); when FALSE, match +on exact alleles only, so a ref/alt swap is treated as a distinct variant.} + \item{...}{Additional arguments forwarded to \code{coloc::coloc.bf_bf}.} } diff --git a/man/colocboostPipeline.Rd b/man/colocboostPipeline.Rd index 03357802..b8ede09a 100644 --- a/man/colocboostPipeline.Rd +++ b/man/colocboostPipeline.Rd @@ -23,6 +23,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) separateGwas = FALSE, samples = NULL, pipCutoffToSkip = 0, + alleleFlip = TRUE, ... ) @@ -37,6 +38,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, + alleleFlip = TRUE, ... ) @@ -53,6 +55,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) separateGwas = FALSE, samples = NULL, pipCutoffToSkip = 0, + alleleFlip = TRUE, ... ) @@ -102,6 +105,12 @@ variant's PIP exceeds the cutoff; a context with no surviving outcome is skipped. \code{0} (default) disables it; a negative value uses \code{3 / n_variants}. (Summary-statistic skipping is handled upstream by \code{\link{summaryStatsQc}}'s own \code{pipCutoffToSkip}.)} + +\item{alleleFlip}{Logical, default \code{TRUE}. When TRUE, harmonize variants +across the individual X, sumstats, and LD by (chrom, pos) with ref/alt +swaps recognized (flipping z / residualized dosage / LD to a shared +coding); when FALSE, match on exact alleles only (names-only), so a ref/alt +swap is treated as a distinct variant.} } \value{ A list with elements \code{xqtl_coloc}, \code{joint_gwas}, diff --git a/man/normalizeVariantId.Rd b/man/normalizeVariantId.Rd index 7a4a610e..2474afff 100644 --- a/man/normalizeVariantId.Rd +++ b/man/normalizeVariantId.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/variantId.R \name{normalizeVariantId} \alias{normalizeVariantId} -\title{Normalize variant IDs to canonical format} +\title{Re-format variant IDs to a chosen output convention} \usage{ normalizeVariantId(ids, chrPrefix = TRUE, convention = NULL) } @@ -17,11 +17,20 @@ Ignored if \code{convention} is provided.} output format is driven automatically by the detected convention.} } \value{ -A character vector of normalized variant IDs. +A character vector of re-formatted variant IDs. Unparseable ids + (e.g. rsIDs) are returned unchanged. } \description{ -One-step convenience function: parses variant IDs in any supported format -and re-formats them. By default, outputs the canonical format -(\code{"chr{N}:{pos}:{A2}:{A1}"}). When a \code{convention} object is -provided, the output preserves the user's original format automatically. +Output-only convenience: parses variant IDs and re-emits them in a single +format. By default produces the canonical format +(\code{"chr{N}:{pos}:{A2}:{A1}"}); pass a \code{convention} to preserve the +input format instead. +} +\details{ +This normalizes only the textual \emph{format} (chr prefix and field +separators); it does NOT reorder alleles, so it is not a matching/identity +operation -- two records that differ by a ref/alt swap remain distinct +strings. For identity, match on the (chrom, pos, ref, alt) tuple via the +variant matcher; use this only for display, file output, or relabeling for +name-based downstream consumers. } diff --git a/man/parseVariantId.Rd b/man/parseVariantId.Rd index ff3399a8..d5eb5dcc 100644 --- a/man/parseVariantId.Rd +++ b/man/parseVariantId.Rd @@ -11,14 +11,17 @@ parseVariantId(ids) "chrom", "pos", and allele columns (A2/A1 or ref/alt or any 4-column layout).} } \value{ -A data.frame with columns "chrom" (integer), "pos" (integer), "A2" - (character), "A1" (character). The detected convention is stored as +A data.frame with columns "chrom" (character, normalized), "pos" + (integer), "A2" (character), "A1" (character). The detected convention is + stored as \code{attr(result, "convention")}. } \description{ Converts variant IDs from any supported string format or data.frame into a -standardized data.frame with integer chrom, integer pos, and character allele -columns (A2, A1). Supports colon-separated ("chr1:100:A:G"), underscore-separated +standardized data.frame with a normalized character chrom, integer pos, and +character allele columns (A2, A1). The chrom is canonicalized (chr stripped, +uppercased, 23 -> X / 24 -> Y / M -> MT) but kept as a string so X/Y/MT +survive. Supports colon-separated ("chr1:100:A:G"), underscore-separated ("1_100_A_G"), with or without "chr" prefix, and with optional build suffix (":b38" or "_b38"). The detected input convention is stored as an attribute. } diff --git a/man/qtlEnrichment.Rd b/man/qtlEnrichment.Rd index 98365e71..2a7dc688 100644 --- a/man/qtlEnrichment.Rd +++ b/man/qtlEnrichment.Rd @@ -36,11 +36,11 @@ When it is set to 0, no shrinkage will be applied. A large value indicates stron \item{numThreads}{Number of Simultaneous running CPU threads for multiple imputation, default is 1.} \item{alignNames}{Logical; when TRUE (default) QTL pip names are aligned to -the GWAS variant-naming convention via \code{alignVariantNames}. Set FALSE +the GWAS variant-naming convention via \code{matchVariants}. Set FALSE when the caller has already aligned them (e.g. \code{qtlEnrichmentPipeline} aligns each QTL tuple once against the union GWAS panel rather than re-aligning per GWAS study); only the cheap per-study unmatched set is then -recomputed, skipping the costly \code{.matchRefPanel} pass.} +recomputed, skipping the costly \code{harmonizeAlleles} pass.} } \value{ A list of enrichment parameter estimates diff --git a/man/regionToDf.Rd b/man/regionToDf.Rd index 2c9064c2..acaec021 100644 --- a/man/regionToDf.Rd +++ b/man/regionToDf.Rd @@ -10,5 +10,7 @@ regionToDf(ldRegionId, colnames = c("chrom", "start", "end")) \item{ldRegionId}{A string of region in the format of chrom_start_end.} } \description{ -Utility function to convert LD region_ids to `region of interest` dataframe +The first field is treated as the chromosome and kept as a normalized string +(via \code{canonChrom}) so X/Y/MT survive; the remaining fields are genomic +positions and are returned as integers. } diff --git a/man/summaryStatsQc.Rd b/man/summaryStatsQc.Rd index ef11e92f..07af7c4d 100644 --- a/man/summaryStatsQc.Rd +++ b/man/summaryStatsQc.Rd @@ -124,7 +124,7 @@ columns; clamp tiny P; normalize CHR; coerce signed columns to numeric), variant-content filters (MAF / INFO / N) via \code{.applyContentFilters}, optional \code{skipRegion} drop, optional PIP screen, panel-vs-sumstats allele harmonization against the -\code{ldSketch} via \code{.matchRefPanel} (which handles indels, +\code{ldSketch} via \code{harmonizeAlleles} (which handles indels, strand-ambiguous variants, sign / strand flips, and duplicate drops in a single sweep), optional SLALOM/DENTIST LD-mismatch QC, and optional RAISS imputation. No Bioconductor genome / dbSNP packages required. diff --git a/tests/testthat/test_FineMappingEntry.R b/tests/testthat/test_FineMappingEntry.R index 328dd0c9..1daa2e9a 100644 --- a/tests/testthat/test_FineMappingEntry.R +++ b/tests/testthat/test_FineMappingEntry.R @@ -106,6 +106,17 @@ test_that("adjustPips errors when the intersection is empty", { }) +test_that("adjustPips tolerates a chr-prefix difference between entry and keepVariants", { + vids <- paste0("chr1:", 1:6, ":A:G") + entry <- .makeAdjustEntry(vids) + keep <- paste0("1:", 2:5, ":A:G") # same variants, no "chr" prefix + adj <- adjustPips(entry, keep) + expect_s4_class(adj, "FineMappingEntry") + expect_equal(adj@variantIds, vids[2:5]) # entry keeps its own labels + expect_equal(ncol(adj@susieFit$lbf_variable), 4) +}) + + test_that("adjustPips on a FineMappingResultBase collection renormalizes each entry", { vidsA <- paste0("chr1:", 1:6, ":A:G") vidsB <- paste0("chr1:", 3:8, ":A:G") diff --git a/tests/testthat/test_MultiStudyQtlDataset.R b/tests/testthat/test_MultiStudyQtlDataset.R index 7d8be277..7df43333 100644 --- a/tests/testthat/test_MultiStudyQtlDataset.R +++ b/tests/testthat/test_MultiStudyQtlDataset.R @@ -58,6 +58,30 @@ test_that("MultiStudyQtlDataset: rejects trait/position conflicts across studies }) +test_that("MultiStudyQtlDataset: tolerates chr-prefix-only seqname differences across studies", { + # se1 uses "chr1"; se2 is the SAME locus (chr1:1000-1499) but seqnames "1". + se1 <- .sc_makeSe(traits = "ENSG1") + rng2 <- GenomicRanges::GRanges( + seqnames = "1", + ranges = IRanges::IRanges(start = 1000L, width = 500L)) + names(rng2) <- "ENSG1" + expr2 <- matrix(rnorm(10), nrow = 1, ncol = 10, + dimnames = list("ENSG1", paste0("s", 1:10))) + cd2 <- S4Vectors::DataFrame(sex = rep(c("M", "F"), 5), + row.names = paste0("s", 1:10)) + se2 <- SummarizedExperiment::SummarizedExperiment( + assays = list(expression = expr2), + rowRanges = rng2, colData = cd2) + qd1 <- QtlDataset(study = "s1", genotypes = .sc_makeGenotypeHandle(), + phenotypes = list(brain = se1)) + qd2 <- QtlDataset(study = "s2", genotypes = .sc_makeGenotypeHandle(), + phenotypes = list(brain = se2)) + expect_s4_class( + MultiStudyQtlDataset(qtlDatasets = list(s1 = qd1, s2 = qd2)), + "MultiStudyQtlDataset") +}) + + test_that("getSumStats(MultiStudyQtlDataset) rejects selection arguments", { # Compose one individual-level QtlDataset with a QtlSumStats of # summary-statistic-only studies (1 + 1 = 2 studies total). diff --git a/tests/testthat/test_QtlDataset.R b/tests/testthat/test_QtlDataset.R index e5fbeade..8837f9b9 100644 --- a/tests/testthat/test_QtlDataset.R +++ b/tests/testthat/test_QtlDataset.R @@ -1546,6 +1546,28 @@ test_that("QtlDataset: rejects shared traits with inconsistent rowRanges", { ) }) + +test_that("QtlDataset: tolerates chr-prefix-only seqname differences for a shared trait", { + se1 <- .sc_makeSe(traits = c("ENSG1")) # ENSG1 at chr1:1000-1499 + # se2 is the SAME locus but with a non-prefixed seqname ("1" vs "chr1"); + # canonChrom() reconciliation should treat these as the same trait position. + rng2 <- GenomicRanges::GRanges( + seqnames = "1", + ranges = IRanges::IRanges(start = 1000L, width = 500L)) + names(rng2) <- "ENSG1" + expr2 <- matrix(rnorm(10), nrow = 1, ncol = 10, + dimnames = list("ENSG1", paste0("s", 1:10))) + cd2 <- S4Vectors::DataFrame(sex = rep(c("M", "F"), 5), + row.names = paste0("s", 1:10)) + se2 <- SummarizedExperiment::SummarizedExperiment( + assays = list(expression = expr2), + rowRanges = rng2, colData = cd2) + expect_s4_class( + QtlDataset(study = "s1", genotypes = .sc_makeGenotypeHandle(), + phenotypes = list(brain = se1, liver = se2)), + "QtlDataset") +}) + # =========================================================================== # MultiStudyQtlDataset # =========================================================================== diff --git a/tests/testthat/test_causalInferencePipeline.R b/tests/testthat/test_causalInferencePipeline.R index 51abbca3..31347176 100644 --- a/tests/testthat/test_causalInferencePipeline.R +++ b/tests/testthat/test_causalInferencePipeline.R @@ -965,6 +965,76 @@ test_that(".cipComputeMr: IVW Wald-ratio over PIP-passing instruments", { expect_equal(res$nIV, 3L) # v1, v2, v4 pass + overlap }) +# --------------------------------------------------------------------------- +# Phase 3: tuple-based (chrom/pos/allele) matching of QTL exposure to GWAS. +# Positional ids exercise matchVariants' tuple path (the v1.. fixtures above +# use the rsID string-fallback). Previously these joins used intersect()/match +# on the raw id string, so a chr-prefix or allele-swap difference silently +# dropped the variant. +# --------------------------------------------------------------------------- + +test_that(".cipComputeMr matches across a chr-prefix difference (tuple match)", { + tl <- data.frame(variant_id = c("chr1:100:A:G", "chr1:200:A:G"), + pip = c(0.9, 0.9), beta = c(0.3, 0.2), se = c(0.05, 0.05), + stringsAsFactors = FALSE) + local_mocked_bindings(getTopLoci = function(x) tl, .package = "pecotmr") + # GWAS carries the same variants without the "chr" prefix. + g <- .cip_gwasDf(c("1:100:A:G", "1:200:A:G"), z = c(2, 1.5)) + res <- pecotmr:::.cipComputeMr(NULL, g, pipCutoff = 0.5) + expect_equal(res$nIV, 2L) # matched despite chr-prefix mismatch + expect_true(is.finite(res$waldRatio)) +}) + +test_that(".cipComputeMr includes an allele-swapped GWAS variant and flips the sign", { + tl <- data.frame(variant_id = "chr1:100:A:G", + pip = 0.9, beta = 0.3, se = 0.05, stringsAsFactors = FALSE) + local_mocked_bindings(getTopLoci = function(x) tl, .package = "pecotmr") + rSame <- pecotmr:::.cipComputeMr(NULL, .cip_gwasDf("chr1:100:A:G", z = 2.0), + pipCutoff = 0.5) + # Same locus, ref/alt swapped on the GWAS side (same |z|): previously dropped + # (id-string mismatch); now matched with sign -1, negating the Wald ratio. + rSwap <- pecotmr:::.cipComputeMr(NULL, .cip_gwasDf("chr1:100:G:A", z = 2.0), + pipCutoff = 0.5) + expect_equal(rSwap$nIV, 1L) + expect_equal(rSwap$waldRatio, -rSame$waldRatio) +}) + +test_that(".cipComputeMr with alleleFlip = FALSE drops an allele-swapped GWAS variant", { + tl <- data.frame(variant_id = "chr1:100:A:G", pip = 0.9, beta = 0.3, se = 0.05, + stringsAsFactors = FALSE) + local_mocked_bindings(getTopLoci = function(x) tl, .package = "pecotmr") + # GWAS variant is the ref/alt swap; with flipping disabled it is not matched. + rSwap <- pecotmr:::.cipComputeMr(NULL, .cip_gwasDf("chr1:100:G:A", z = 2.0), + pipCutoff = 0.5, alleleFlip = FALSE) + expect_equal(rSwap$nIV, 0L) + expect_true(is.na(rSwap$waldRatio)) +}) + +test_that(".cipComputeMrCsAware matches across a chr-prefix difference", { + tl <- data.frame(variant_id = c("chr1:100:A:G", "chr1:200:A:G"), + cs = c(1L, 1L), pip = c(0.6, 0.4), + beta = c(0.3, 0.2), se = c(0.05, 0.05), stringsAsFactors = FALSE) + local_mocked_bindings(getTopLoci = function(x) tl, .package = "pecotmr") + g <- .cip_gwasDf(c("1:100:A:G", "1:200:A:G"), z = c(2, 1.5)) + res <- pecotmr:::.cipComputeMrCsAware(NULL, g, cpipCutoff = 0.5) + expect_equal(res$nCs, 1L) + expect_true(is.finite(res$waldRatio)) +}) + +test_that(".cipComputeTwasZ reconciles a chr-prefix mismatch (previously dropped)", { + idsGwas <- c("1:100:A:G", "1:200:A:G", "1:300:A:G") # GWAS / panel coding + idsWt <- c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") # QTL weight ids + h <- .cip_makeHandle(snp_n = 3L) + h@snpInfo$SNP <- idsGwas + h@snpInfo$A2 <- rep("A", 3); h@snpInfo$A1 <- rep("G", 3) + g <- .cip_gwasDf(idsGwas, z = c(2, -1.5, 0.8)) + local_mocked_bindings(extractBlockGenotypes = .cip_mockExtractor(), + .package = "pecotmr") + res <- pecotmr:::.cipComputeTwasZ(c(0.2, -0.1, 0.3), idsWt, g, h) + expect_false(is.null(res)) # intersect() would have returned NULL + expect_true(is.finite(res$Z)) +}) + test_that(".cipComputeMr: NA on empty / missing-col / no-IV / no-overlap / zero-beta", { g <- .cip_gwasDf(paste0("v", 1:4)) isNa <- function(r) { expect_true(is.na(r$waldRatio)); expect_equal(r$nIV, 0L) } diff --git a/tests/testthat/test_colocPipeline.R b/tests/testthat/test_colocPipeline.R index 6f883a18..2f42e36d 100644 --- a/tests/testthat/test_colocPipeline.R +++ b/tests/testthat/test_colocPipeline.R @@ -306,6 +306,17 @@ test_that(".colocAlignLbf: aligned matrices share the common variant set", { expect_setequal(colnames(aligned$gwas), c("chr1:20:A:G", "chr1:30:A:G")) }) +test_that(".colocAlignLbf aligns non-autosomal columns across a chr-prefix difference", { + # chrX ids: alignVariantNames' numeric-chrom regex could not parse these and + # fell back to a raw intersect (no overlap); tuple matching resolves them. + q <- matrix(0, 2, 2, dimnames = list(NULL, c("chrX:100:A:G", "chrX:200:C:T"))) + g <- matrix(0, 2, 2, dimnames = list(NULL, c("X:100:A:G", "X:200:C:T"))) + aligned <- pecotmr:::.colocAlignLbf(q, g) + expect_false(is.null(aligned)) + expect_equal(ncol(aligned$qtl), 2L) + expect_identical(colnames(aligned$qtl), colnames(aligned$gwas)) +}) + test_that(".colocRbindLbf: rbinds matrices with union of columns, NAs filled with 0", { a <- matrix(1, 2, 2, dimnames = list(NULL, c("v1", "v2"))) b <- matrix(2, 2, 2, dimnames = list(NULL, c("v2", "v3"))) diff --git a/tests/testthat/test_colocboostPipeline.R b/tests/testthat/test_colocboostPipeline.R index edabd365..40408dde 100644 --- a/tests/testthat/test_colocboostPipeline.R +++ b/tests/testthat/test_colocboostPipeline.R @@ -602,6 +602,61 @@ test_that(".cbSumstatPair: varY attaches var_y; NA variant ids fall back to chr: expect_null(pecotmr:::.cbSumstatPair(dfNA, h)) }) +test_that(".cbSumstatPair canonicalizes variant ids to chr-prefixed for name alignment", { + local_mocked_bindings(extractBlockGenotypes = .cbp_mockExtractor(), + .package = "pecotmr") + h <- .cbp_makeHandle(snp_n = 3L) + h@snpInfo$SNP <- c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") # chr-prefixed panel + # sumstat carries the same variants without the "chr" prefix; the pipeline + # should canonicalize them so the sumstat / LD ids align by name with other + # sources (previously the returned ids kept the caller's convention). + df <- data.frame(variant_id = c("1:100:A:G", "1:200:A:G", "1:300:A:G"), + z = c(1, -1, 0.5), N = rep(1000, 3), stringsAsFactors = FALSE) + pair <- pecotmr:::.cbSumstatPair(df, h) + expect_equal(pair$sumstat$variant, + c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G")) + expect_identical(colnames(pair$LD), pair$sumstat$variant) +}) + +test_that(".cbFlipPairToCanonical flips z + LD for swapped variants, relabels to canonical", { + ss <- data.frame(z = c(2, -1), n = c(1000, 1000), + variant = c("chr1:100:A:G", "chr1:200:C:T"), + stringsAsFactors = FALSE) + LD <- matrix(c(1, 0.5, 0.5, 1), 2, dimnames = list(ss$variant, ss$variant)) + p <- list(sumstat = ss, LD = LD, variantIds = ss$variant) + canonical <- c("chr1:100:G:A", "chr1:200:C:T") # variant 1 swapped, 2 identical + out <- pecotmr:::.cbFlipPairToCanonical(p, canonical) + expect_equal(out$sumstat$variant, c("chr1:100:G:A", "chr1:200:C:T")) + expect_equal(out$sumstat$z, c(-2, -1)) # v1 z flipped; v2 unchanged + expect_equal(out$LD["chr1:100:G:A", "chr1:200:C:T"], -0.5) # one endpoint flipped + expect_equal(unname(diag(out$LD)), c(1, 1)) # diagonal preserved +}) + +test_that(".cbFlipMatrixToCanonical negates residualized dosage for swapped columns", { + X <- matrix(c(1, -1, 2, 0.5, -0.5, 1), nrow = 3, + dimnames = list(paste0("s", 1:3), + c("chr1:100:A:G", "chr1:200:C:T"))) + canonical <- c("chr1:100:G:A", "chr1:200:C:T") # col 1 swapped, col 2 identical + out <- pecotmr:::.cbFlipMatrixToCanonical(X, canonical) + expect_equal(colnames(out), c("chr1:100:G:A", "chr1:200:C:T")) + expect_equal(unname(out[, "chr1:100:G:A"]), -c(1, -1, 2)) # negated + expect_equal(unname(out[, "chr1:200:C:T"]), c(0.5, -0.5, 1)) +}) + +test_that(".cbHarmonizeAlleles aligns opposite-coded sumstats to one canonical (invariance)", { + mkPair <- function(v, z) { + ss <- data.frame(z = z, n = 1000, variant = v, stringsAsFactors = FALSE) + list(sumstat = ss, LD = matrix(1, 1, 1, dimnames = list(v, v)), variantIds = v) + } + # Same locus, opposite ref/alt coding across two sumstats, same underlying z. + pairs <- list(A = mkPair("chr1:100:A:G", 3), B = mkPair("chr1:100:G:A", 3)) + h <- pecotmr:::.cbHarmonizeAlleles(NULL, pairs) + expect_equal(h$pairs$A$sumstat$variant, "chr1:100:A:G") # first-seen = canonical + expect_equal(h$pairs$B$sumstat$variant, "chr1:100:A:G") # B relabeled to it + expect_equal(h$pairs$A$sumstat$z, 3) # A already canonical + expect_equal(h$pairs$B$sumstat$z, -3) # B flipped to match +}) + test_that("colocboostPipeline(MultiStudyQtlDataset): a study with no usable bundle is skipped", { mt <- .cbp_makeMultiStudy() # qd (study1, ENSG_A) + ss (Q1, t1) local_mocked_bindings(extractBlockGenotypes = .cbp_mockExtractor(), diff --git a/tests/testthat/test_ctwasPipeline.R b/tests/testthat/test_ctwasPipeline.R index 8d6a4492..343fa3c2 100644 --- a/tests/testthat/test_ctwasPipeline.R +++ b/tests/testthat/test_ctwasPipeline.R @@ -460,7 +460,7 @@ test_that(".ctwasBuildWeights: standardized weights bypass variance scaling", { }) # Build an LD-panel fixture with realistic chr:pos:A2:A1 variant IDs so -# `.ctwasHarmonizeWeights` (which calls parseVariantId + .matchRefPanel) +# `.ctwasHarmonizeWeights` (which calls parseVariantId + harmonizeAlleles) # can do real allele matching. .ctp_makeAllelePanel <- function() { ids <- c("1:100:C:T", "1:200:G:A", "1:300:A:G", "1:400:T:C") @@ -1231,8 +1231,8 @@ test_that(".ctwasHarmonizeWeights: returns NULL when there is nothing to parse", origVids = character(0), origW = numeric(0), refVariants = refVariants)) }) -test_that(".ctwasHarmonizeWeights: returns NULL when .matchRefPanel fails", { - local_mocked_bindings(.matchRefPanel = function(...) NULL, +test_that(".ctwasHarmonizeWeights: returns NULL when harmonizeAlleles fails", { + local_mocked_bindings(harmonizeAlleles = function(...) NULL, .package = "pecotmr") panel <- .ctp_makeAllelePanel() refVariants <- data.frame( diff --git a/tests/testthat/test_deprecated.R b/tests/testthat/test_deprecated.R deleted file mode 100644 index ea41ca69..00000000 --- a/tests/testthat/test_deprecated.R +++ /dev/null @@ -1,853 +0,0 @@ -context("deprecated") - -# All tests below exercise functions in R/deprecated.R. The functions -# emit .Deprecated() warnings on every call; we wrap each call in -# suppressWarnings() (or rely on the surrounding expect_warning when -# the test already asserts a warning) so the deprecation message is -# not surfaced as test output. -# -# Every test starts with `skip_on_covr()`: R/deprecated.R is listed in -# .covrignore (its lines are not measured for coverage), so running -# these tests under `covr::package_coverage()` / `covr::codecov()` -# contributes nothing to the coverage signal — they would just exercise -# the deprecation shims whose forwarding targets are tested elsewhere. -# Skipping under covr cuts the coverage-run wallclock without changing -# what's measured. - -# =========================================================================== -# Helpers (moved from test_sumstatsQc.R / test_colocPipeline.R / -# test_qtlEnrichmentPipeline.R) -# =========================================================================== - -create_allele_data <- function(seed, n=100, match_min_prop=0.8, ambiguous=FALSE, non_actg=FALSE, edge_cases=FALSE) { - set.seed(seed) - num_pass <- n*match_min_prop - sumstat_A1 <- sample(c("A", "T", "G", "C"), num_pass, replace = TRUE) - sumstat_A2 <- unlist(lapply(sumstat_A1, function(x) { - if (x == "A") { - return(sample(c("G", "C"), 1)) - } else if (x == "T") { - return(sample(c("G", "C"), 1)) - } else if (x == "G") { - return(sample(c("A", "T"), 1)) - } else if (x == "C") { - return(sample(c("A", "T"), 1)) - } - })) - - if (ambiguous) { - # Strand Ambiguous SNPs - sumstat_A1 <- c(sumstat_A1, sample(c("A", "T", "G", "C"), n-num_pass, replace = TRUE)) - sumstat_A2 <- unlist(c(sumstat_A2, lapply(sumstat_A1[(num_pass+1):length(sumstat_A1)], function(x) { - if (x == "A") { - return("T") - } else if (x == "T") { - return("A") - } else if (x == "G") { - return("C") - } else if (x == "C") { - return("G") - } - }))) - } else if (non_actg) { - # Non-ATCG coding SNPs - sumstat_A1 <- c(sumstat_A1, sample(c("ATG", "TAC", "GACA", "CTAA"), n-num_pass, replace = TRUE)) - sumstat_A2 <- unlist(c(sumstat_A2, lapply(sumstat_A1[(num_pass+1):length(sumstat_A1)], function(x) { - if (x == "ATG") { - return("TAC") - } else if (x == "TAC") { - return("ATG") - } else if (x == "GACA") { - return("CTGT") - } else if (x == "CTAA") { - return("GATT") - } - }))) - } - - # Info SNPs - info_A1 <- lapply(sumstat_A1[1:num_pass], function(x) { - if(runif(1) < 0.2) { - # flip a small proportion of the alleles - if (x == "A") { - return("T") - } else if (x == "T") { - return("A") - } else if (x == "G") { - return("C") - } else if (x == "C") { - return("G") - } - } else { - return(x) - } - }) - info_A2 <- sumstat_A2[1:num_pass] - # Handle random flips - info_A2[info_A1 != sumstat_A1[1:num_pass]] <- unlist(lapply(info_A2[info_A1 != sumstat_A1[1:num_pass]], function(x) { - if (x == "A") { - return("T") - } else if (x == "T") { - return("A") - } else if (x == "G") { - return("C") - } else if (x == "C") { - return("G") - } - })) - - # Create the rest of the alleles - info_A1 <- unlist(c(info_A1, sample(c("A", "T", "G", "C"), n-num_pass, replace = TRUE))) - info_A2 <- unlist(c(info_A2, lapply(info_A1[(num_pass+1):length(info_A1)], function(x) { - if (x == "A") { - return(sample(c("G", "C"), 1)) - } else if (x == "T") { - return(sample(c("G", "C"), 1)) - } else if (x == "G") { - return(sample(c("A", "T"), 1)) - } else if (x == "C") { - return(sample(c("A", "T"), 1)) - } - }))) - - chromosome <- unlist(rep(sample(1:20, 1), n)) - snp_positions <- sample(1:1000000, n) - ref_variants <- data.frame( - chrom = chromosome, - pos = snp_positions, - A1 = info_A1, - A2 = info_A2 - ) - target_data <- data.frame( - chrom = chromosome, - pos = snp_positions, - A1 = sumstat_A1, - A2 = sumstat_A2, - beta = rnorm(n), - z = rnorm(n) - ) - - return(list(target_data = target_data, ref_variants = ref_variants)) -} - -.ep_makeHandle <- function(snp_n = 6L, n_samples = 30L) { - new("GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", - snpInfo = data.frame( - SNP = paste0("v", seq_len(snp_n)), - CHR = rep("1", snp_n), - BP = seq(100L, by = 100L, length.out = snp_n), - A1 = rep("A", snp_n), - A2 = rep("G", snp_n), - stringsAsFactors = FALSE), - nSamples = n_samples, - sampleIds = paste0("s", seq_len(n_samples)), - pgenPtr = NULL) -} - -.ep_makeFmEntry <- function(variant_ids = paste0("chr1:", 100*(1:5), ":A:G"), - n_eff = 2L) { - pip <- seq(0.9, by = -0.15, length.out = length(variant_ids)) - n <- length(variant_ids) - tl <- data.frame( - variant_id = variant_ids, - chrom = rep("1", n), - pos = as.integer(100 * (1:n)), - A1 = rep("G", n), - A2 = rep("A", n), - N = rep(1000, n), - MAF = rep(0.1, n), - marginal_beta = rep(0.1, n), - marginal_se = rep(0.05, n), - marginal_z = rep(2.0, n), - marginal_p = rep(0.05, n), - pip = pip, - posterior_mean = rep(0.05, n), - posterior_sd = rep(0.02, n), - stringsAsFactors = FALSE) - set.seed(1) - fit <- list( - alpha = matrix(1/length(variant_ids), - nrow = n_eff, ncol = length(variant_ids), - dimnames = list(NULL, variant_ids)), - pip = setNames(pip, variant_ids), - V = rep(0.05, n_eff), - lbf_variable = matrix(rnorm(n_eff * length(variant_ids)), - nrow = n_eff, ncol = length(variant_ids), - dimnames = list(NULL, variant_ids))) - FineMappingEntry(variantIds = variant_ids, - susieFit = fit, - topLoci = tl) -} - -.ep_mockColocBfBf <- function() { - function(qLbf, gLbf, p1, p2, p12, ...) { - list(summary = data.frame( - idx1 = 1L, idx2 = 1L, nSnps = ncol(qLbf), - PP.H0.abf = 0.1, PP.H1.abf = 0.2, PP.H2.abf = 0.2, - PP.H3.abf = 0.2, PP.H4.abf = 0.3, - p12_actual = p12, - stringsAsFactors = FALSE)) - } -} - -.ep_makeQtlFmr <- function(with_sketch = TRUE) { - QtlFineMappingResult( - study = "Q1", context = "c1", trait = "t1", method = "susie", - entry = list(.ep_makeFmEntry()), - ldSketch = if (with_sketch) .ep_makeHandle() else NULL) -} - -.ep_makeGwasFmr <- function(with_sketch = TRUE) { - GwasFineMappingResult( - study = "G1", method = "susie", - entry = list(.ep_makeFmEntry()), - ldSketch = if (with_sketch) .ep_makeHandle() else NULL) -} - -.ep_makeGwasSumstats <- function(qc = TRUE) { - gr <- GenomicRanges::GRanges( - seqnames = "chr1", - ranges = IRanges::IRanges(start = seq(100L, by = 100L, length.out = 5L), - width = 1L)) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = paste0("v", 1:5), - A1 = rep("A", 5), A2 = rep("G", 5), - Z = rnorm(5), N = rep(1000L, 5)) - GwasSumStats( - study = "G1", - entry = list(gr), - genome = "hg19", - ldSketch = .ep_makeHandle(), - qcInfo = if (qc) list(step1 = "ok") else list()) -} - -generate_mock_data <- function(seed=1, num_pips = 1000, num_susie_fits = 2) { - # Simulate fake data for gwas_pip - n_gwas_pip <- num_pips - gwas_pip <- runif(n_gwas_pip) - names(gwas_pip) <- paste0("snp", 1:n_gwas_pip) - gwas_fit <- list(pip=gwas_pip) - - # Simulate fake data for a single SuSiEFit object - simulate_susiefit <- function(n, p) { - pip <- runif(n) - names(pip) <- paste0("snp", 1:n) - alpha <- t(matrix(runif(n * p), nrow = n)) - alpha <- t(apply(alpha, 1, function(row) row / sum(row))) - list( - pip = pip, - alpha = alpha, - prior_variance = runif(p) - ) - } - - # Simulate multiple SuSiEFit objects - n_susie_fits <- num_susie_fits - susie_fits <- replicate(n_susie_fits, simulate_susiefit(n_gwas_pip, 10), simplify = FALSE) - # Add these fits to a list, providing names to each element - names(susie_fits) <- paste0("fit", 1:length(susie_fits)) - return(list(gwas_fit=gwas_fit, susie_fits=susie_fits)) -} - -# =========================================================================== -# alleleQc (deprecated; replaced by summaryStatsQc()) -# =========================================================================== - -test_that("Check that we correctly remove stand ambiguous SNPs",{ - skip_on_covr() - res <- create_allele_data(1, n=100, match_min_prop=0.8, ambiguous=TRUE) - output <- suppressWarnings(alleleQc( - res$target_data, res$ref_variants, colToFlip = "beta", - matchMinProp = 0.2)) - expect_equal(nrow(output$harmonizedData), 80) -}) - -test_that("Check that we correctly remove non-ACTG coding SNPs",{ - skip_on_covr() - res <- create_allele_data(1, n=100, match_min_prop=0.4, non_actg=TRUE) - output <- suppressWarnings(alleleQc( - res$target_data, res$ref_variants, colToFlip = "beta", - matchMinProp = 0.2)) - expect_equal(nrow(output$harmonizedData), 40) -}) - -test_that("Check that execution stops if not enough variants are matched",{ - skip_on_covr() - res <- create_allele_data(1, n=100, match_min_prop=0.1, ambiguous=TRUE) - expect_error(suppressWarnings(alleleQc( - res$target_data, res$ref_variants, colToFlip = "beta", - matchMinProp = 0.2)), "Not enough variants have been matched.") -}) - -test_that("alleleQc matches exact alleles", { - skip_on_covr() - target <- data.frame( - chrom = c(1, 1), pos = c(100, 200), - A2 = c("A", "C"), A1 = c("G", "T") - ) - ref <- data.frame( - chrom = c(1, 1), pos = c(100, 200), - A2 = c("A", "C"), A1 = c("G", "T") - ) - result <- suppressWarnings(alleleQc(target, ref, matchMinProp = 0)) - expect_equal(nrow(result$harmonizedData), 2) -}) - -test_that("alleleQc detects sign flips", { - skip_on_covr() - target <- data.frame( - chrom = 1, pos = 100, - A2 = "A", A1 = "G", - z = 2.5 - ) - ref <- data.frame( - chrom = 1, pos = 100, - A2 = "G", A1 = "A" - ) - result <- suppressWarnings(alleleQc(target, ref, colToFlip = "z", matchMinProp = 0)) - expect_equal(nrow(result$harmonizedData), 1) - # z should be flipped - expect_equal(result$harmonizedData$z, -2.5) -}) - -test_that("alleleQc handles string input format", { - skip_on_covr() - target <- c("1:100:A:G", "1:200:C:T") - ref <- c("1:100:A:G", "1:200:C:T") - result <- suppressWarnings(alleleQc(target, ref, matchMinProp = 0)) - expect_equal(nrow(result$harmonizedData), 2) -}) - -test_that("alleleQc with chr prefix", { - skip_on_covr() - target <- c("chr1:100:A:G", "chr1:200:C:T") - ref <- c("chr1:100:A:G", "chr1:200:C:T") - result <- suppressWarnings(alleleQc(target, ref, matchMinProp = 0)) - expect_equal(nrow(result$harmonizedData), 2) -}) - -test_that("alleleQc warns when too few matches", { - skip_on_covr() - target <- c("1:100:A:G") - ref <- c("2:200:C:T", "2:300:A:G", "2:400:C:T", "2:500:A:G", "2:600:C:T") - expect_warning(alleleQc(target, ref, matchMinProp = 0.5)) -}) - -test_that("alleleQc with no matching positions returns empty", { - skip_on_covr() - target <- data.frame( - chrom = 1, pos = 100, - A2 = "A", A1 = "G" - ) - ref <- data.frame( - chrom = 1, pos = 999, - A2 = "C", A1 = "T" - ) - expect_warning( - result <- alleleQc(target, ref, matchMinProp = 0), - "No matching variants" - ) - expect_equal(nrow(result$harmonizedData), 0) -}) - -test_that("alleleQc preserves extra columns", { - skip_on_covr() - target <- data.frame( - chrom = 1, pos = 100, - A2 = "A", A1 = "G", - beta = 0.5, se = 0.1 - ) - ref <- data.frame( - chrom = 1, pos = 100, - A2 = "A", A1 = "G" - ) - result <- suppressWarnings(alleleQc(target, ref, matchMinProp = 0)) - expect_true("beta" %in% colnames(result$harmonizedData)) - expect_true("se" %in% colnames(result$harmonizedData)) -}) - -test_that("alleleQc with lowercase alleles", { - skip_on_covr() - target <- data.frame( - chrom = 1, pos = 100, - A2 = "a", A1 = "g" - ) - ref <- data.frame( - chrom = 1, pos = 100, - A2 = "A", A1 = "G" - ) - result <- suppressWarnings(alleleQc(target, ref, matchMinProp = 0)) - expect_equal(nrow(result$harmonizedData), 1) -}) - -# ---- sanitize_names edge cases (alleleQc.R lines 37, 42) ---- -test_that("alleleQc handles data frame with NULL colnames after merge", { - skip_on_covr() - # Create a data frame where merge might produce empty names - # by giving target_data a column with NA name - target <- data.frame(chrom = 1, pos = 100, A2 = "A", A1 = "G") - ref <- data.frame(chrom = 1, pos = 100, A2 = "A", A1 = "G") - colnames(target)[1] <- "" - colnames(target) <- make.unique(colnames(target), sep = "_") - # Restore chrom for the join - colnames(target)[1] <- "chrom" - result <- suppressWarnings(alleleQc(target, ref, matchMinProp = 0)) - expect_equal(nrow(result$harmonizedData), 1) -}) - -# ---- target_data with redundant columns (alleleQc.R line 75) ---- -test_that("alleleQc removes redundant columns from target_data before join", { - skip_on_covr() - target <- data.frame( - chrom = 1, pos = 100, A2 = "A", A1 = "G", - variant_id = "1:100:A:G", chromosome = "chr1", position = 100 - ) - ref <- data.frame(chrom = 1, pos = 100, A2 = "A", A1 = "G") - result <- suppressWarnings(alleleQc(target, ref, matchMinProp = 0)) - expect_equal(nrow(result$harmonizedData), 1) - # The redundant columns should have been removed before the join - expect_true("variant_id" %in% colnames(result$harmonizedData)) -}) - -# ---- col_to_flip with nonexistent column (alleleQc.R line 130) ---- -test_that("alleleQc errors when col_to_flip column does not exist", { - skip_on_covr() - target <- data.frame(chrom = 1, pos = 100, A2 = "G", A1 = "A") - ref <- data.frame(chrom = 1, pos = 100, A2 = "A", A1 = "G") - expect_error( - suppressWarnings( - alleleQc(target, ref, colToFlip = "nonexistent_col", matchMinProp = 0)), - "not found in targetData" - ) -}) - -# Duplicate-handling is no longer the responsibility of alleleQc / -# matchRefPanel: callers are expected to deduplicate (via MungeSumstats / -# summaryStatsQc) before harmonization. The new behavior is to error. -test_that("alleleQc errors on duplicate variants in target input", { - skip_on_covr() - target <- data.frame( - chrom = c(1, 1), pos = c(100, 100), - A2 = c("A", "A"), A1 = c("G", "G"), - beta = c(0.5, 0.6) - ) - ref <- data.frame(chrom = 1, pos = 100, A2 = "A", A1 = "G") - expect_error( - suppressWarnings(alleleQc(target, ref, matchMinProp = 0)), - "Duplicated variant IDs" - ) -}) - -# =========================================================================== -# matchRefPanel (deprecated; replaced by summaryStatsQc()) -# colToComplement hook (rss-qc-parity): af complemented on allele swap -# =========================================================================== - -test_that("af is complemented (1 - af) when harmonization swaps the effect allele", { - skip_on_covr() - ref <- data.frame(chrom = c("chr1", "chr1"), pos = c(100, 200), - A2 = c("A", "C"), A1 = c("G", "T"), stringsAsFactors = FALSE) - # chr1:100 alleles swapped vs ref (=> sign flip); chr1:200 exact match. - target <- data.frame(chrom = c("chr1", "chr1"), pos = c(100, 200), - A2 = c("G", "C"), A1 = c("A", "T"), - z = c(2.0, 1.5), af = c(0.30, 0.40), stringsAsFactors = FALSE) - - res <- suppressWarnings( - matchRefPanel(target, ref, colToFlip = "z", colToComplement = "af")) - h <- res$harmonizedData - swapped <- h[h$pos == 100, ] - control <- h[h$pos == 200, ] - - expect_equal(swapped$af, 0.70) # 1 - input af - expect_equal(swapped$z, -2.0) # signed columns still sign-flip - expect_equal(control$af, 0.40) # untouched (no swap) - expect_equal(control$z, 1.5) -}) - -test_that("colToComplement default leaves af unchanged (non-RSS callers unaffected)", { - skip_on_covr() - ref <- data.frame(chrom = c("chr1", "chr1"), pos = c(100, 200), - A2 = c("A", "C"), A1 = c("G", "T"), stringsAsFactors = FALSE) - target <- data.frame(chrom = c("chr1", "chr1"), pos = c(100, 200), - A2 = c("G", "C"), A1 = c("A", "T"), - z = c(2.0, 1.5), af = c(0.30, 0.40), stringsAsFactors = FALSE) - - res <- suppressWarnings( - matchRefPanel(target, ref, colToFlip = "z")) # default: no complement - h <- res$harmonizedData - swapped <- h[h$pos == 100, ] - expect_equal(swapped$af, 0.30) # unchanged - expect_equal(swapped$z, -2.0) # z still sign-flips (independent path) -}) - -test_that("colToComplement errors on a missing column name", { - skip_on_covr() - ref <- data.frame(chrom = "chr1", pos = 100, A2 = "A", A1 = "G", stringsAsFactors = FALSE) - target <- data.frame(chrom = "chr1", pos = 100, A2 = "A", A1 = "G", - z = 1.0, stringsAsFactors = FALSE) - expect_error( - suppressWarnings(matchRefPanel(target, ref, colToComplement = "af")), - "not found in targetData" - ) -}) - -# =========================================================================== -# enlocPipeline (deprecated; integrated into colocPipeline) -# Input-type validation -# =========================================================================== - -test_that("enlocPipeline: rejects non-QtlFineMappingResult qtlFmr", { - skip_on_covr() - expect_error( - suppressWarnings(enlocPipeline(qtlFineMappingResult = "no", - gwasInput = .ep_makeGwasFmr(), - enrichment = data.frame(gwasStudy = "G1", qtlStudy = "Q1", qtlContext = "c1", - enrichment = 2.0, - stringsAsFactors = FALSE))), - "must be a QtlFineMappingResult" - ) -}) - -test_that("enlocPipeline: rejects gwasInput that is neither GwasSumStats nor GwasFineMappingResult", { - skip_on_covr() - expect_error( - suppressWarnings(enlocPipeline(qtlFineMappingResult = .ep_makeQtlFmr(), - gwasInput = 42L, - enrichment = data.frame(gwasStudy = "G1", qtlStudy = "Q1", qtlContext = "c1", - enrichment = 2.0, - stringsAsFactors = FALSE))), - "must be a GwasSumStats or a GwasFineMappingResult" - ) -}) - -test_that("enlocPipeline: enrichment must be a data.frame", { - skip_on_covr() - expect_error( - suppressWarnings(enlocPipeline(qtlFineMappingResult = .ep_makeQtlFmr(), - gwasInput = .ep_makeGwasFmr(), - enrichment = "not a df")), - "must be a data.frame" - ) -}) - -test_that("enlocPipeline: enrichment missing required columns errors", { - skip_on_covr() - expect_error( - suppressWarnings(enlocPipeline(qtlFineMappingResult = .ep_makeQtlFmr(), - gwasInput = .ep_makeGwasFmr(), - enrichment = data.frame(gwasStudy = "G1"))), - "missing column" - ) -}) - -test_that("enlocPipeline: un-QCd GwasSumStats input is rejected", { - skip_on_covr() - expect_error( - suppressWarnings(enlocPipeline(qtlFineMappingResult = .ep_makeQtlFmr(), - gwasInput = .ep_makeGwasSumstats(qc = FALSE), - enrichment = data.frame(gwasStudy = "G1", qtlStudy = "Q1", qtlContext = "c1", - enrichment = 2.0, - stringsAsFactors = FALSE))), - "has no QC record" - ) -}) - -# =========================================================================== -# enlocPipeline — Pair loop (runs end-to-end via the LBF + coloc.bf_bf path) -# =========================================================================== - -test_that("enlocPipeline: pair loop produces one row per (QTL tuple, GWAS tuple) with adjusted p12", { - skip_on_covr() - enr <- data.frame(gwasStudy = "G1", qtlStudy = "Q1", qtlContext = "c1", enrichment = 2.0, - stringsAsFactors = FALSE) - local_mocked_bindings(coloc.bf_bf = .ep_mockColocBfBf(), .package = "coloc") - out <- suppressWarnings( - enlocPipeline(qtlFineMappingResult = .ep_makeQtlFmr(), - gwasInput = .ep_makeGwasFmr(), - enrichment = enr, - p12 = 5e-6, - p12Max = 1e-3)) - expect_s3_class(out, "data.frame") - expect_equal(nrow(out), 1L) - expect_equal(out$enrichment, 2.0) - # 5e-6 * (1 + 2.0) = 1.5e-5 < 1e-3, so capped value is the raw product. - expect_equal(out$p12Used, 1.5e-5) - expect_equal(out$p12_actual, 1.5e-5) -}) - -test_that("enlocPipeline: missing-enrichment pair falls back to baseline p12 with a warning", { - skip_on_covr() - # An enrichment frame that has no row for (G1, c1). - enr <- data.frame(gwasStudy = "G_other", qtlStudy = "Q_other", qtlContext = "c_other", - enrichment = 10.0, stringsAsFactors = FALSE) - local_mocked_bindings(coloc.bf_bf = .ep_mockColocBfBf(), .package = "coloc") - expect_warning( - out <- enlocPipeline(qtlFineMappingResult = .ep_makeQtlFmr(), - gwasInput = .ep_makeGwasFmr(), - enrichment = enr, - p12 = 5e-6, - p12Max = 1e-3), - "no enrichment entry" - ) - # Baseline p12 unchanged because the pair fell back (enRow = 0). - expect_equal(out$p12Used, 5e-6) -}) - -test_that("enlocPipeline: p12Max caps the adjusted prior", { - skip_on_covr() - enr <- data.frame(gwasStudy = "G1", qtlStudy = "Q1", qtlContext = "c1", enrichment = 1e6, - stringsAsFactors = FALSE) - local_mocked_bindings(coloc.bf_bf = .ep_mockColocBfBf(), .package = "coloc") - out <- suppressWarnings( - enlocPipeline(qtlFineMappingResult = .ep_makeQtlFmr(), - gwasInput = .ep_makeGwasFmr(), - enrichment = enr, - p12 = 5e-6, - p12Max = 1e-4)) - expect_equal(out$p12Used, 1e-4) -}) - -test_that("enlocPipeline: coloc.bf_bf failures are caught and warned, pair skipped", { - skip_on_covr() - enr <- data.frame(gwasStudy = "G1", qtlStudy = "Q1", qtlContext = "c1", enrichment = 2.0, - stringsAsFactors = FALSE) - local_mocked_bindings( - coloc.bf_bf = function(q, g, ...) stop("boom"), - .package = "coloc") - expect_warning( - out <- enlocPipeline(qtlFineMappingResult = .ep_makeQtlFmr(), - gwasInput = .ep_makeGwasFmr(), - enrichment = enr), - "coloc.bf_bf failed" - ) - expect_equal(nrow(out), 0L) -}) - -test_that("enlocPipeline: returnGwasFineMapping=TRUE attaches gwasFineMapping attr (non-empty result)", { - skip_on_covr() - enr <- data.frame(gwasStudy = "G1", qtlStudy = "Q1", qtlContext = "c1", enrichment = 2.0, - stringsAsFactors = FALSE) - local_mocked_bindings(coloc.bf_bf = .ep_mockColocBfBf(), .package = "coloc") - # Use GwasFineMappingResult input: returnGwasFineMapping has no effect - # for this branch (only GwasSumStats triggers attachment). To trigger - # attachment we mock fineMappingPipeline so the GwasSumStats path - # produces a usable FMR. - fakeFmr <- .ep_makeGwasFmr() - local_mocked_bindings( - fineMappingPipeline = function(data, ...) fakeFmr, - .package = "pecotmr") - out <- suppressWarnings( - enlocPipeline(qtlFineMappingResult = .ep_makeQtlFmr(), - gwasInput = .ep_makeGwasSumstats(), - enrichment = enr, - returnGwasFineMapping = TRUE)) - expect_true("gwasFineMapping" %in% names(attributes(out))) - expect_s4_class(attr(out, "gwasFineMapping"), "GwasFineMappingResult") -}) - -test_that("enlocPipeline: qLbf NULL (QTL entry's LBF rows drop after priorTol) skips that QTL row", { - skip_on_covr() - # Build a QTL FMR whose lbf_variable is empty after the V > priorTol filter - # (V = 0 < default priorTol 1e-9 -> drop all rows -> return NULL). - emptyFit <- list( - lbf_variable = matrix(0, nrow = 1, ncol = 1, dimnames = list(NULL, "v1")), - V = 0.0) - e <- FineMappingEntry(variantIds = "v1", - susieFit = emptyFit, - topLoci = data.frame( - variant_id = "v1", chrom = "1", pos = 100L, - A1 = "G", A2 = "A", N = 1000, MAF = 0.1, - marginal_beta = 0.1, marginal_se = 0.05, - marginal_z = 2, marginal_p = 0.05, - pip = 0, posterior_mean = 0, posterior_sd = 0, - stringsAsFactors = FALSE)) - qfmr <- QtlFineMappingResult( - study = "Q1", context = "c1", trait = "t1", method = "susie", - entry = list(e), - ldSketch = .ep_makeHandle()) - local_mocked_bindings(coloc.bf_bf = .ep_mockColocBfBf(), .package = "coloc") - out <- suppressWarnings( - enlocPipeline(qtlFineMappingResult = qfmr, - gwasInput = .ep_makeGwasFmr(), - enrichment = data.frame( - gwasStudy = "G1", qtlStudy = "Q1", qtlContext = "c1", - enrichment = 1.0, stringsAsFactors = FALSE))) - expect_equal(nrow(out), 0L) -}) - -test_that("enlocPipeline: aligned NULL (disjoint variant sets) skips that pair", { - skip_on_covr() - # QTL fmr with variant ids that don't overlap the GWAS variant ids. - qVids <- paste0("chr1:", 100*(1:5), ":A:G") - gVids <- paste0("chr2:", 200*(1:5), ":A:G") - qfmr <- QtlFineMappingResult( - study = "Q1", context = "c1", trait = "t1", method = "susie", - entry = list(.ep_makeFmEntry(variant_ids = qVids)), - ldSketch = .ep_makeHandle()) - gfmr <- GwasFineMappingResult( - study = "G1", method = "susie", - entry = list(.ep_makeFmEntry(variant_ids = gVids)), - ldSketch = .ep_makeHandle()) - local_mocked_bindings(coloc.bf_bf = .ep_mockColocBfBf(), .package = "coloc") - out <- suppressWarnings( - enlocPipeline(qtlFineMappingResult = qfmr, - gwasInput = gfmr, - enrichment = data.frame( - gwasStudy = "G1", qtlStudy = "Q1", qtlContext = "c1", - enrichment = 1.0, stringsAsFactors = FALSE))) - expect_equal(nrow(out), 0L) -}) - -test_that("enlocPipeline: empty result schema includes enrichment + p12Used", { - skip_on_covr() - # Build a GWAS FMR whose entry has no usable LBF -> pre-extract returns empty. - emptyFit <- list(alpha = matrix(0, 1, 1), pip = c(v1 = 0), - V = 0, lbf_variable = matrix(NA_real_, 1, 1)) - e <- FineMappingEntry(variantIds = "v1", - susieFit = emptyFit, - topLoci = data.frame( - variant_id = "v1", chrom = "1", pos = 100L, - A1 = "G", A2 = "A", N = 1000, MAF = 0.1, - marginal_beta = 0.1, marginal_se = 0.05, - marginal_z = 2, marginal_p = 0.05, - pip = 0, posterior_mean = 0, posterior_sd = 0, - stringsAsFactors = FALSE)) - gfmr <- GwasFineMappingResult( - study = "G1", method = "susie", - entry = list(e), - ldSketch = .ep_makeHandle()) - out <- suppressWarnings( - enlocPipeline(qtlFineMappingResult = .ep_makeQtlFmr(), - gwasInput = gfmr, - enrichment = data.frame( - gwasStudy = "G1", qtlStudy = "Q1", qtlContext = "c1", - enrichment = 1.0, stringsAsFactors = FALSE))) - expect_equal(nrow(out), 0L) - expect_true(all(c("enrichment", "p12Used") %in% colnames(out))) -}) - -# =========================================================================== -# computeQtlEnrichment (deprecated; renamed to qtlEnrichment()) -# =========================================================================== - -test_that("computeQtlEnrichment dummy data single-threaded works",{ - skip_on_covr() - local_mocked_bindings( - qtlEnrichmentRcpp = function(...) TRUE) - input_data <- generate_mock_data(seed=1, num_pips=10) - expect_warning( - computeQtlEnrichment(input_data$gwas_fit$pip, input_data$susie_fits, lambda = 1, impN = 10, numThreads = 1), - "numGwas is not provided. Estimating piGwas from the data. Note that this estimate may be biased if the input gwasPip does not contain genome-wide variants.") - expect_warning( - computeQtlEnrichment(input_data$gwas_fit$pip, input_data$susie_fits, lambda = 1, impN = 10, numThreads = 1), - "piQtl is not provided. Estimating piQtl from the data. Note that this estimate may be biased if either 1) the input susieQtlRegions does not have enough data, or 2) the single effects only include variables inside of credible sets or signal clusters.") - res <- suppressWarnings(computeQtlEnrichment(input_data$gwas_fit$pip, input_data$susie_fits, numGwas=5000, piQtl=0.49819, lambda = 1, impN = 10, numThreads = 1)) - expect_true(length(res) > 0) -}) - -test_that("computeQtlEnrichment dummy data single thread and multi-threaded are equivalent",{ - skip_on_covr() - local_mocked_bindings( - qtlEnrichmentRcpp = function(...) TRUE) - input_data <- generate_mock_data(seed=1, num_pips=10) - res_single <- suppressWarnings(computeQtlEnrichment(input_data$gwas_fit$pip, input_data$susie_fits, numGwas=5000, piQtl=0.49819, lambda = 1, impN = 10, numThreads = 1)) - res_multi <- suppressWarnings(computeQtlEnrichment(input_data$gwas_fit$pip, input_data$susie_fits, numGwas=5000, piQtl=0.49819, lambda = 1, impN = 10, numThreads = 2)) - expect_equal(res_single, res_multi) -}) - -# ---- error paths (computeQtlEnrichment.R lines 86, 87, 91) ---- -test_that("computeQtlEnrichment errors when pi_gwas is zero", { - skip_on_covr() - gwas_pip <- rep(0, 10) - names(gwas_pip) <- paste0("snp", 1:10) - susie_fits <- list(fit1 = list(pip = setNames(runif(10), paste0("snp", 1:10)), - alpha = matrix(1, 1, 10), - prior_variance = 1)) - expect_error( - suppressWarnings(computeQtlEnrichment(gwas_pip, susie_fits, piQtl = 0.5)), - "No association signal found in GWAS data" - ) -}) - -test_that("computeQtlEnrichment errors when pi_qtl is zero", { - skip_on_covr() - gwas_pip <- runif(10) - names(gwas_pip) <- paste0("snp", 1:10) - susie_fits <- list(fit1 = list(pip = setNames(rep(0, 10), paste0("snp", 1:10)), - alpha = matrix(1, 1, 10), - prior_variance = 1)) - expect_error( - suppressWarnings(computeQtlEnrichment(gwas_pip, susie_fits, numGwas = 1000, piQtl = 0)), - "No QTL associated" - ) -}) - -test_that("computeQtlEnrichment errors when gwas_pip has no names", { - skip_on_covr() - gwas_pip <- runif(10) # no names - susie_fits <- list(fit1 = list(pip = setNames(runif(10), paste0("snp", 1:10)), - alpha = matrix(1, 1, 10), - prior_variance = 1)) - expect_error( - suppressWarnings(computeQtlEnrichment(gwas_pip, susie_fits, numGwas = 1000, piQtl = 0.5)), - "Variant names are missing in gwasPip" - ) -}) - -# Real C++ kernel integration is now covered in test_qtlEnrichmentPipeline.R -# via qtlEnrichment() (no skip_on_covr there). Don't duplicate here — this -# file would just skip those tests anyway. - -# ---- unmatched variants tracking (computeQtlEnrichment.R line 102) ---- -test_that("computeQtlEnrichment tracks unmatched QTL variants", { - skip_on_covr() - local_mocked_bindings( - qtlEnrichmentRcpp = function(...) TRUE - ) - gwas_pip <- runif(10) - names(gwas_pip) <- paste0("1:", 1:10, ":A:G") - # QTL has some variants not in GWAS - qtl_pip <- runif(5) - names(qtl_pip) <- c(paste0("1:", 1:3, ":A:G"), "1:999:A:G", "1:998:A:G") - susie_fits <- list(fit1 = list(pip = qtl_pip, - alpha = matrix(runif(5), 1, 5), - prior_variance = 1)) - res <- suppressWarnings( - computeQtlEnrichment(gwas_pip, susie_fits, numGwas = 1000, piQtl = 0.5) - ) - expect_true("unused_xqtl_variants" %in% names(res)) -}) - -# =========================================================================== -# coloc/xqtl pre-S4 entry points (deprecated; superseded by the S4 pipelines) -# These are pure no-op shims: each fires .Deprecated() and returns NULL. -# =========================================================================== - -test_that("xqtlEnrichmentWrapper is a deprecated no-op", { - skip_on_covr() - expect_warning( - res <- xqtlEnrichmentWrapper(), - "has been removed", - ignore.case = TRUE) - expect_null(res) -}) - -test_that("colocWrapper is a deprecated no-op", { - skip_on_covr() - expect_warning( - res <- colocWrapper(), - "has been removed", - ignore.case = TRUE) - expect_null(res) -}) - -test_that("colocPostProcessor is a deprecated no-op", { - skip_on_covr() - expect_warning( - res <- colocPostProcessor(), - "has been removed", - ignore.case = TRUE) - expect_null(res) -}) diff --git a/tests/testthat/test_genotypeIo.R b/tests/testthat/test_genotypeIo.R index d87dcf13..97d36294 100644 --- a/tests/testthat/test_genotypeIo.R +++ b/tests/testthat/test_genotypeIo.R @@ -1481,7 +1481,7 @@ test_that("sharded extraction errors for a chromosome with no payload", { # Drop the chr22 payload but keep its variants in @snpInfo, so routing a # chr22 request finds no per-chromosome file. shard@chromPaths <- shard@chromPaths["21"] - idx22 <- which(pecotmr:::.canonChr(shard@snpInfo$CHR) == "22")[1] + idx22 <- which(pecotmr:::canonChrom(shard@snpInfo$CHR) == "22")[1] expect_error( extractBlockGenotypes(shard, idx22), "no per-chromosome file for chromosome") diff --git a/tests/testthat/test_ld.R b/tests/testthat/test_ld.R index 696ec4e2..f4883698 100644 --- a/tests/testthat/test_ld.R +++ b/tests/testthat/test_ld.R @@ -425,7 +425,15 @@ test_that("orderDedupRegions orders and deduplicates across chromosomes", { test_that("orderDedupRegions strips chr prefix", { df <- data.frame(chrom = c("chr1", "chr2"), start = c(100, 200), end = c(200, 300)) result <- pecotmr:::orderDedupRegions(df) - expect_true(all(result$chrom %in% c(1L, 2L))) + expect_equal(result$chrom, c("1", "2")) # normalized to a bare string, not integer +}) + +test_that("orderDedupRegions sorts X/Y/MT after autosomes and keeps chrom a string", { + df <- data.frame(chrom = c("chrX", "chr2", "chr1", "chrMT"), + start = c(1L, 1L, 1L, 1L), end = c(2L, 2L, 2L, 2L)) + result <- pecotmr:::orderDedupRegions(df) + expect_equal(result$chrom, c("1", "2", "X", "MT")) # genomic order, not NA-collapsed + expect_type(result$chrom, "character") }) # ---- findIntersectionRows ---- @@ -2910,6 +2918,21 @@ test_that(".requireMatchingLdSketches errors when panels differ in a column", { ) }) +test_that(".requireMatchingLdSketches tolerates a chr-prefix-only difference", { + si1 <- data.frame(SNP = c("1:100:A:G", "1:200:C:T"), CHR = c("1", "1"), + BP = c(100L, 200L), A1 = c("A", "C"), A2 = c("G", "T"), + stringsAsFactors = FALSE) + si2 <- si1 + si2$CHR <- c("chr1", "chr1") + si2$SNP <- c("chr1:100:A:G", "chr1:200:C:T") # same panel, chr-prefixed + mk <- function(si) new("GenotypeHandle", path = "/tmp/x", format = "gds", + snpInfo = si, nSamples = 3L, + sampleIds = paste0("s", 1:3), pgenPtr = NULL, + chromPaths = character(0)) + expect_null( + pecotmr:::.requireMatchingLdSketches(mk(si1), mk(si2), "testPipeline")) +}) + # ============================================================================= # Additional coverage: loadLdSketch non-LdData guard # ============================================================================= diff --git a/tests/testthat/test_sumstatsQc.R b/tests/testthat/test_sumstatsQc.R index 0c29c5c9..2710e960 100644 --- a/tests/testthat/test_sumstatsQc.R +++ b/tests/testthat/test_sumstatsQc.R @@ -104,151 +104,6 @@ test_that("krigingOutlierQc requires a positive sample size n", { }) -test_that("alignVariantNames correctly aligns variant names", { - # Test case 1: Matching variant names - source1 <- c("1:123:A:C", "2:456:G:T", "3:789:C:A") - reference1 <- c("1:123:A:C", "2:456:T:G", "3:789:C:A") - expected_aligned1 <- c("1:123:A:C", "2:456:T:G", "3:789:C:A") - expected_unmatched1 <- integer(0) - - result1 <- alignVariantNames(source1, reference1) - expect_equal(result1$alignedVariants, expected_aligned1) - expect_equal(result1$unmatchedIndices, expected_unmatched1) - - # Test case 2: Unmatched variant names - source2 <- c("1:123:A:C", "2:456:G:T", "3:789:C:A", "4:101:G:C") - reference2 <- c("1:123:A:C", "2:456:T:G", "3:789:C:A") - expected_aligned2 <- c("1:123:A:C", "2:456:T:G", "3:789:C:A", "4:101:G:C") - expected_unmatched2 <- 4 - - result2 <- alignVariantNames(source2, reference2) - expect_equal(result2$alignedVariants, expected_aligned2) - expect_equal(result2$unmatchedIndices, expected_unmatched2) - - # Test case 3: Different variant name formats - source3 <- c("1:123:A:C", "2:456_G_T", "3:789:C:A") - reference3 <- c("1:123:A:C", "2:456:T:G", "3:789:C:A") - expected_aligned3 <- c("1:123:A:C", "2:456:T:G", "3:789:C:A") - expected_unmatched3 <- integer(0) - - result3 <- alignVariantNames(source3, reference3) - expect_equal(result3$alignedVariants, expected_aligned3) - expect_equal(result3$unmatchedIndices, expected_unmatched3) -}) - -test_that("alignVariantNames correctly aligns variant names with different flip patterns", { - # Test case 4: Strand flip - source4 <- c("1:123:A:C", "2:456:G:T", "3:789:C:A") - reference4 <- c("1:123:T:G", "2:456:A:C", "3:789:C:A") - expected_aligned4 <- c("1:123:T:G", "2:456:A:C", "3:789:C:A") - expected_unmatched4 <- integer(0) - - result4 <- alignVariantNames(source4, reference4) - expect_equal(result4$alignedVariants, expected_aligned4) - expect_equal(result4$unmatchedIndices, expected_unmatched4) - - # Test case 5: Strand ambiguous variants - source5 <- c("1:123:A:T", "2:456:G:C", "3:789:C:A") - reference5 <- c("1:123:A:T", "2:456:G:C", "3:789:C:A") - expected_aligned5 <- c("1:123:A:T", "2:456:G:C", "3:789:C:A") - expected_unmatched5 <- integer(0) - - result5 <- alignVariantNames(source5, reference5) - expect_equal(result5$alignedVariants, expected_aligned5) - expect_equal(result5$unmatchedIndices, expected_unmatched5) - - # Test case 6: Sign flip - source6 <- c("1:123:A:C", "2:456:G:T", "3:789:C:A") - reference6 <- c("1:123:C:A", "2:456:T:G", "3:789:C:A") - expected_aligned6 <- c("1:123:C:A", "2:456:T:G", "3:789:C:A") - expected_unmatched6 <- integer(0) - - result6 <- alignVariantNames(source6, reference6) - expect_equal(result6$alignedVariants, expected_aligned6) - expect_equal(result6$unmatchedIndices, expected_unmatched6) - - # Test case 7: Strand and sign flip - source7 <- c("1:123:A:C", "2:456:G:T", "3:789:C:A") - reference7 <- c("1:123:G:T", "2:456:A:C", "3:789:C:A") - expected_aligned7 <- c("1:123:G:T", "2:456:A:C", "3:789:C:A") - expected_unmatched7 <- integer(0) - - result7 <- alignVariantNames(source7, reference7) - expect_equal(result7$alignedVariants, expected_aligned7) - expect_equal(result7$unmatchedIndices, expected_unmatched7) - - # Test case 8: Indels - source8 <- c("1:123:A:C", "2:456:G:T", "3:789:C:A", "4:101:G:GATC") - reference8 <- c("1:123:A:C", "2:456:T:G", "3:789:C:A", "4:101:GATC:G") - expected_aligned8 <- c("1:123:A:C", "2:456:T:G", "3:789:C:A", "4:101:GATC:G") - expected_unmatched8 <- integer(0) - - result8 <- alignVariantNames(source8, reference8) - expect_equal(result8$alignedVariants, expected_aligned8) - expect_equal(result8$unmatchedIndices, expected_unmatched8) -}) - -test_that("alignVariantNames correctly aligns variant names with different chr prefix conventions", { - # Test case 9: Original without chr prefix, reference with chr prefix - source9 <- c("1:123:A:C", "2:456:G:T", "3:789:C:A") - reference9 <- c("chr1:123:A:C", "chr2:456:T:G", "chr3:789:C:A") - expected_aligned9 <- c("chr1:123:A:C", "chr2:456:T:G", "chr3:789:C:A") - expected_unmatched9 <- integer(0) - - result9 <- alignVariantNames(source9, reference9) - expect_equal(result9$alignedVariants, expected_aligned9) - expect_equal(result9$unmatchedIndices, expected_unmatched9) - - # Test case 10: Original with chr prefix, reference without chr prefix - source10 <- c("chr1:123:A:C", "chr2:456:G:T", "chr3:789:C:A") - reference10 <- c("1:123:A:C", "2:456:T:G", "3:789:C:A") - expected_aligned10 <- c("1:123:A:C", "2:456:T:G", "3:789:C:A") - expected_unmatched10 <- integer(0) - - result10 <- alignVariantNames(source10, reference10) - expect_equal(result10$alignedVariants, expected_aligned10) - expect_equal(result10$unmatchedIndices, expected_unmatched10) -}) - -test_that("alignVariantNames warns on non-standard format", { - source <- c("rs12345") - reference <- c("rs67890") - expect_warning( - alignVariantNames(source, reference), - "do not follow the expected" - ) -}) - -test_that("alignVariantNames errors on mixed formats", { - source <- c("1:100:A:G") - reference <- c("rs12345") - expect_error( - alignVariantNames(source, reference), - "different variant naming conventions" - ) -}) - -test_that("alignVariantNames strips build suffix", { - source <- c("1:100:A:G:b38") - reference <- c("1:100:A:G") - result <- alignVariantNames(source, reference, removeBuildSuffix = TRUE) - expect_length(result$alignedVariants, 1) -}) - -test_that("alignVariantNames: disjoint source/reference returns source unchanged", { - # Bug fix: when no variants harmonize, paste0() over length-0 components - # used to collapse to a single "chr:::" placeholder. Verify the output - # now preserves source length and flags every position as unmatched. - src <- c("chr1:10:A:G", "chr1:20:A:G", "chr1:30:A:G") - ref <- c("chr2:40:A:G", "chr2:50:A:G", "chr2:60:A:G") - out <- suppressWarnings(alignVariantNames(src, ref)) - expect_equal(length(out$alignedVariants), length(src)) - expect_equal(out$alignedVariants, src) - expect_equal(out$unmatchedIndices, seq_along(src)) -}) - - - context("raiss") library(tidyverse) library(MASS) @@ -2769,6 +2624,29 @@ test_that("summaryStatsQc: slalom z-mismatch resolves sign-flipped variants agai expect_equal(length(out$entry[[1L]]), 3L) }) +test_that("summaryStatsQc: zMismatchQc reconciles a chr-prefix difference vs the panel", { + # Panel SNP ids are non-chr-prefixed positional; QC re-keys the entry to the + # canonical chr-prefixed form, so the opt-in z-mismatch panel match must + # reconcile the prefix (previously errored "absent from the ldSketch panel"). + h <- .ssQ_makeHandle() + h@snpInfo$SNP <- paste0("1:", h@snpInfo$BP, ":G:A") # non-chr-prefixed + ss <- GwasSumStats(study = "g1", entry = list(.ssQ_makeEntryGr()), + genome = "hg19", ldSketch = h) + local_mocked_bindings( + extractBlockGenotypes = .ssQ_mockExtractor(), + ldMismatchQc = function(zScore, R = NULL, X = NULL, nSample = NULL, + method = c("slalom", "dentist"), + ldMethod = "sample", ...) { + data.frame(original_z = zScore, outlier = rep(FALSE, length(zScore)), + stringsAsFactors = FALSE) + }, + .package = "pecotmr") + expect_no_error( + out <- summaryStatsQc(ss, zMismatchQc = "slalom", + pipCutoffToSkip = 0, nCutoff = 0)) + expect_gte(length(out$entry[[1L]]), 1L) +}) + test_that(".deriveBetaSeFromZ: derives BETA+SE when entry has Z+MAF+N only", { df <- data.frame( SNP = paste0("rs", 1:3), @@ -2961,7 +2839,7 @@ test_that("summaryStatsQc: impute = TRUE with raiss returning NULL records 0 imp # summaryStatsQc: per-step QC counter logging (concept salvaged from PR #520) # =========================================================================== -test_that(".matchRefPanel surfaces sign/strand/dropped counts via qcCounts attribute", { +test_that("harmonizeAlleles surfaces sign/strand/dropped counts via qcCounts attribute", { # 4 shared positions: 100 exact, 200 sign-flip, 300 strand-flip (A/G # unambiguous), 400 allele mismatch (dropped). target <- data.frame( @@ -2972,7 +2850,7 @@ test_that(".matchRefPanel surfaces sign/strand/dropped counts via qcCounts attri chrom = c(1, 1, 1, 1), pos = c(100, 200, 300, 400), A2 = c("A", "G", "T", "C"), A1 = c("G", "A", "C", "A"), stringsAsFactors = FALSE) - res <- pecotmr:::.matchRefPanel(target, ref, colToFlip = "z", + res <- pecotmr:::harmonizeAlleles(target, ref, colToFlip = "z", matchMinProp = 0) # Default return shape unchanged. expect_named(res, c("harmonizedData", "qcSummary")) @@ -4553,18 +4431,18 @@ test_that("mergeVariantInfo does not warn on length-mismatch recycling", { }) # =========================================================================== -# .matchRefPanel uncovered branches +# harmonizeAlleles uncovered branches # =========================================================================== -test_that(".matchRefPanel: accepts a bare variant-id character vector (targetData)", { - res <- pecotmr:::.matchRefPanel( +test_that("harmonizeAlleles: accepts a bare variant-id character vector (targetData)", { + res <- pecotmr:::harmonizeAlleles( c("chr1:100:A:G", "chr1:200:C:T"), c("chr1:100:A:G", "chr1:200:C:T"), matchMinProp = 0) expect_equal(nrow(res$harmonizedData), 2L) }) -test_that(".matchRefPanel: strips merge-conflicting columns (variant_id) from targetData", { +test_that("harmonizeAlleles: strips merge-conflicting columns (variant_id) from targetData", { target <- data.frame(chrom = c(1, 1), pos = c(100, 200), A2 = c("A", "C"), A1 = c("G", "T"), variant_id = c("old1", "old2"), z = c(1, 2), @@ -4572,34 +4450,34 @@ test_that(".matchRefPanel: strips merge-conflicting columns (variant_id) from ta ref <- data.frame(chrom = c(1, 1), pos = c(100, 200), A2 = c("A", "C"), A1 = c("G", "T"), stringsAsFactors = FALSE) - res <- pecotmr:::.matchRefPanel(target, ref, colToFlip = "z", matchMinProp = 0) + res <- pecotmr:::harmonizeAlleles(target, ref, colToFlip = "z", matchMinProp = 0) expect_equal(nrow(res$harmonizedData), 2L) # The input variant_id was stripped; the returned id is rebuilt from QC'd alleles. expect_false(any(c("old1", "old2") %in% res$harmonizedData$variant_id)) }) -test_that(".matchRefPanel: errors when colToFlip column is absent", { +test_that("harmonizeAlleles: errors when colToFlip column is absent", { target <- data.frame(chrom = 1, pos = 100, A2 = "A", A1 = "G", z = 1, stringsAsFactors = FALSE) ref <- data.frame(chrom = 1, pos = 100, A2 = "A", A1 = "G", stringsAsFactors = FALSE) expect_error( - pecotmr:::.matchRefPanel(target, ref, colToFlip = "missingCol", matchMinProp = 0), + pecotmr:::harmonizeAlleles(target, ref, colToFlip = "missingCol", matchMinProp = 0), "not found in targetData") }) -test_that(".matchRefPanel: errors when colToComplement column is absent", { +test_that("harmonizeAlleles: errors when colToComplement column is absent", { target <- data.frame(chrom = 1, pos = 100, A2 = "A", A1 = "G", z = 1, stringsAsFactors = FALSE) ref <- data.frame(chrom = 1, pos = 100, A2 = "A", A1 = "G", stringsAsFactors = FALSE) expect_error( - pecotmr:::.matchRefPanel(target, ref, colToComplement = "missingAf", + pecotmr:::harmonizeAlleles(target, ref, colToComplement = "missingAf", matchMinProp = 0), "not found in targetData") }) -test_that(".matchRefPanel: complements colToComplement (1 - af) on an allele swap", { +test_that("harmonizeAlleles: complements colToComplement (1 - af) on an allele swap", { # pos 100 exact; pos 200 allele-swapped -> sign_flip => z negated, af -> 1-af. target <- data.frame(chrom = c(1, 1), pos = c(100, 200), A2 = c("A", "A"), A1 = c("G", "G"), @@ -4608,7 +4486,7 @@ test_that(".matchRefPanel: complements colToComplement (1 - af) on an allele swa ref <- data.frame(chrom = c(1, 1), pos = c(100, 200), A2 = c("A", "G"), A1 = c("G", "A"), stringsAsFactors = FALSE) - res <- pecotmr:::.matchRefPanel(target, ref, colToFlip = "z", + res <- pecotmr:::harmonizeAlleles(target, ref, colToFlip = "z", colToComplement = "af", matchMinProp = 0) hd <- res$harmonizedData row200 <- hd[hd$pos == 200, ] @@ -4616,38 +4494,38 @@ test_that(".matchRefPanel: complements colToComplement (1 - af) on an allele swa expect_equal(row200$z, -2) # sign-flipped }) -test_that(".matchRefPanel: removeDups = TRUE warns and drops duplicate variants", { +test_that("harmonizeAlleles: removeDups = TRUE warns and drops duplicate variants", { target <- data.frame(chrom = c(1, 1), pos = c(100, 100), A2 = c("A", "A"), A1 = c("G", "G"), stringsAsFactors = FALSE) ref <- data.frame(chrom = 1, pos = 100, A2 = "A", A1 = "G", stringsAsFactors = FALSE) expect_warning( - res <- pecotmr:::.matchRefPanel(target, ref, removeDups = TRUE, + res <- pecotmr:::harmonizeAlleles(target, ref, removeDups = TRUE, matchMinProp = 0), "Removed 1 duplicate") expect_equal(nrow(res$harmonizedData), 1L) }) -test_that(".matchRefPanel: errors when duplicated variant IDs remain (removeDups = FALSE)", { +test_that("harmonizeAlleles: errors when duplicated variant IDs remain (removeDups = FALSE)", { target <- data.frame(chrom = c(1, 1), pos = c(100, 100), A2 = c("A", "A"), A1 = c("G", "G"), stringsAsFactors = FALSE) ref <- data.frame(chrom = 1, pos = 100, A2 = "A", A1 = "G", stringsAsFactors = FALSE) expect_error( - pecotmr:::.matchRefPanel(target, ref, removeDups = FALSE, matchMinProp = 0), + pecotmr:::harmonizeAlleles(target, ref, removeDups = FALSE, matchMinProp = 0), "Duplicated variant IDs remain") }) -test_that(".matchRefPanel: errors when too few variants match (matchMinProp)", { +test_that("harmonizeAlleles: errors when too few variants match (matchMinProp)", { target <- data.frame(chrom = 1, pos = 100, A2 = "A", A1 = "G", stringsAsFactors = FALSE) ref <- data.frame(chrom = rep(1, 10), pos = seq(100, 1000, 100), A2 = rep("A", 10), A1 = rep("G", 10), stringsAsFactors = FALSE) expect_error( - pecotmr:::.matchRefPanel(target, ref, matchMinProp = 0.9), + pecotmr:::harmonizeAlleles(target, ref, matchMinProp = 0.9), "Not enough variants") }) @@ -5239,9 +5117,9 @@ test_that("dentistSingleWindow: rsq-warning capture path on a near-singular LD b # existing suite leaves untouched. # =========================================================================== -test_that(".matchRefPanel sanitizes an empty-named target column to 'unnamed_N'", { +test_that("harmonizeAlleles sanitizes an empty-named target column to 'unnamed_N'", { # 5 columns whose first four are positional (NOT literally named - # chrom/pos/A2/A1), so .matchRefPanel routes through variantIdToDf -- which + # chrom/pos/A2/A1), so harmonizeAlleles routes through variantIdToDf -- which # preserves the extra column -- rather than the select()-based path. The 5th # column has an empty name, so the joined matchResult carries an empty-named # column and sanitizeNames() rewrites it to "unnamed_1" (sumstatsQc.R:83). @@ -5252,7 +5130,7 @@ test_that(".matchRefPanel sanitizes an empty-named target column to 'unnamed_N'" ref <- data.frame(chrom = c(1, 1, 1), pos = c(100, 200, 300), A2 = c("A", "C", "G"), A1 = c("G", "T", "A"), stringsAsFactors = FALSE) - res <- pecotmr:::.matchRefPanel(target, ref, matchMinProp = 0) + res <- pecotmr:::harmonizeAlleles(target, ref, matchMinProp = 0) expect_equal(nrow(res$harmonizedData), 3L) nm <- colnames(res$harmonizedData) expect_false(any(nm == "" | is.na(nm))) # the empty name was repaired diff --git a/tests/testthat/test_variantId.R b/tests/testthat/test_variantId.R index ad49cb14..14382969 100644 --- a/tests/testthat/test_variantId.R +++ b/tests/testthat/test_variantId.R @@ -7,7 +7,7 @@ context("variantId") test_that("parseVariantId: canonical colon format with chr prefix", { res <- parseVariantId(c("chr1:100:A:G", "chr2:200:T:C")) expect_s3_class(res, "data.frame") - expect_equal(res$chrom, c(1L, 2L)) + expect_equal(res$chrom, c("1", "2")) expect_equal(res$pos, c(100L, 200L)) expect_equal(res$A2, c("A", "T")) expect_equal(res$A1, c("G", "C")) @@ -15,14 +15,14 @@ test_that("parseVariantId: canonical colon format with chr prefix", { test_that("parseVariantId: canonical colon format without chr prefix", { res <- parseVariantId(c("1:100:A:G", "2:200:T:C")) - expect_equal(res$chrom, c(1L, 2L)) + expect_equal(res$chrom, c("1", "2")) expect_equal(res$pos, c(100L, 200L)) expect_equal(attr(res, "convention")$hasChr, FALSE) }) test_that("parseVariantId: underscore separator format", { res <- parseVariantId(c("chr1_100_A_G", "1_200_T_C")) - expect_equal(res$chrom, c(1L, 1L)) + expect_equal(res$chrom, c("1", "1")) expect_equal(res$pos, c(100L, 200L)) expect_equal(res$A2, c("A", "T")) expect_equal(res$A1, c("G", "C")) @@ -30,7 +30,7 @@ test_that("parseVariantId: underscore separator format", { test_that("parseVariantId: mixed colon-underscore format", { res <- parseVariantId("chr1:100_A_G") - expect_equal(res$chrom, 1L) + expect_equal(res$chrom, "1") expect_equal(res$pos, 100L) expect_equal(res$A2, "A") expect_equal(res$A1, "G") @@ -55,7 +55,7 @@ test_that("parseVariantId: data.frame input with chrom/pos/A2/A1 returns as-is", df <- data.frame(chrom = "chr1", pos = 100L, A2 = "A", A1 = "G", stringsAsFactors = FALSE) res <- parseVariantId(df) - expect_equal(res$chrom, 1L) + expect_equal(res$chrom, "1") expect_equal(res$pos, 100L) expect_equal(attr(res, "convention")$hasChr, TRUE) }) @@ -64,7 +64,7 @@ test_that("parseVariantId: data.frame input with >=4 columns assigns positional df <- data.frame(c1 = "1", c2 = "100", c3 = "A", c4 = "G", extra = "x", stringsAsFactors = FALSE) res <- parseVariantId(df) - expect_equal(res$chrom, 1L) + expect_equal(res$chrom, "1") expect_equal(res$pos, 100L) expect_equal(res$A2, "A") expect_equal(res$A1, "G") @@ -141,19 +141,19 @@ test_that("parseRegion: returns non-character input unchanged", { test_that("regionToDf: parses chrom_start_end LD region IDs", { res <- regionToDf(c("1_100_200", "2_300_400")) - expect_equal(res$chrom, c(1L, 2L)) + expect_equal(res$chrom, c("1", "2")) expect_equal(res$start, c(100L, 300L)) expect_equal(res$end, c(200L, 400L)) }) test_that("regionToDf: strips chr prefix from chromosome", { res <- regionToDf("chr5_1000_2000") - expect_equal(res$chrom, 5L) + expect_equal(res$chrom, "5") }) test_that("regionToDf: accepts colon/dash separators", { res <- regionToDf("chr1:100-200") - expect_equal(res$chrom, 1L) + expect_equal(res$chrom, "1") expect_equal(res$start, 100L) expect_equal(res$end, 200L) }) @@ -323,7 +323,7 @@ test_that("parseRegion returns non-single-string input unchanged", { test_that("parseVariantId parses single variant with chr prefix", { result <- parseVariantId("chr1:12345:A:G") - expect_equal(result$chrom, 1L) + expect_equal(result$chrom, "1") expect_equal(result$pos, 12345L) expect_equal(result$A2, "A") expect_equal(result$A1, "G") @@ -335,7 +335,7 @@ test_that("parseVariantId parses single variant with chr prefix", { test_that("parseVariantId parses single variant without chr prefix", { result <- parseVariantId("5:12345:A:G") - expect_equal(result$chrom, 5L) + expect_equal(result$chrom, "5") expect_equal(result$pos, 12345L) expect_equal(result$A2, "A") expect_equal(result$A1, "G") @@ -348,7 +348,7 @@ test_that("parseVariantId parses multiple variants", { ids <- c("chr1:100:A:G", "chr2:200:C:T", "chr3:300:G:A") result <- parseVariantId(ids) expect_equal(nrow(result), 3) - expect_equal(result$chrom, c(1L, 2L, 3L)) + expect_equal(result$chrom, c("1", "2", "3")) expect_equal(result$pos, c(100L, 200L, 300L)) expect_equal(result$A2, c("A", "C", "G")) expect_equal(result$A1, c("G", "T", "A")) @@ -397,6 +397,14 @@ test_that("normalizeVariantId normalizes various formats", { expect_equal(normalizeVariantId("1:200:C:T", convention = conv), "chr1:200_C_T") }) + +test_that("normalizeVariantId leaves unparseable ids (rsIDs) unchanged", { + expect_equal( + normalizeVariantId(c("rs123", "1:100:A:G", "chr2:200_C_T")), + c("rs123", "chr1:100:A:G", "chr2:200:C:T")) # rsID passes through + expect_equal(normalizeVariantId("rs1"), "rs1") # all-unparseable input +}) + # ============================================================================= # variantIdToDf # ============================================================================= @@ -406,7 +414,7 @@ test_that("variantIdToDf handles colon-separated format", { ids <- c("1:100:A:G", "2:200:C:T") result <- pecotmr:::variantIdToDf(ids) expect_equal(nrow(result), 2) - expect_equal(result$chrom, c(1L, 2L)) + expect_equal(result$chrom, c("1", "2")) expect_equal(result$pos, c(100L, 200L)) expect_equal(result$A2, c("A", "C")) expect_equal(result$A1, c("G", "T")) @@ -424,7 +432,7 @@ test_that("variantIdToDf handles underscore-separated format", { test_that("variantIdToDf strips chr prefix", { ids <- c("chr1:100:A:G", "chr2:200:C:T") result <- pecotmr:::variantIdToDf(ids) - expect_equal(result$chrom, c(1L, 2L)) + expect_equal(result$chrom, c("1", "2")) }) @@ -432,7 +440,7 @@ test_that("variantIdToDf handles data.frame input with named columns", { df <- data.frame(chrom = c("chr1", "2"), pos = c(100, 200), A2 = c("A", "C"), A1 = c("G", "T")) suppressWarnings(result <- pecotmr:::variantIdToDf(df)) - expect_equal(result$chrom, c(1L, 2L)) + expect_equal(result$chrom, c("1", "2")) expect_equal(result$pos, c(100L, 200L)) }) @@ -442,7 +450,7 @@ test_that("variantIdToDf handles 5-part IDs with build suffix", { result <- pecotmr:::variantIdToDf(ids) expect_equal(ncol(result), 4) expect_equal(colnames(result), c("chrom", "pos", "A2", "A1")) - expect_equal(result$chrom, c(1L, 2L)) + expect_equal(result$chrom, c("1", "2")) expect_equal(result$A2, c("A", "T")) expect_equal(result$A1, c("G", "C")) }) @@ -486,7 +494,7 @@ test_that("parseVariantId handles data.frame with generic column names", { ) result <- parseVariantId(df) expect_equal(names(result)[1:4], c("chrom", "pos", "A2", "A1")) - expect_equal(result$chrom, c(1L, 2L)) + expect_equal(result$chrom, c("1", "2")) expect_equal(result$pos, c(100L, 200L)) expect_equal(result$A2, c("A", "T")) expect_equal(result$A1, c("G", "C")) @@ -601,35 +609,141 @@ test_that("classifyVariantType accepts data.frame input", { expect_equal(result, c("SNP", "deletion")) }) -# ============================================================================= -# ensureChrMatch -# ============================================================================= +# =========================================================================== +# canonChrom / chromOrder / non-autosomal chromosomes (string chrom contract) +# =========================================================================== +test_that("canonChrom normalizes prefixes, case, and synonyms to strings", { + expect_equal( + pecotmr:::canonChrom(c("chr1", "CHR2", "chrX", "x", "23", "24", "M", "chrMT", "MT")), + c("1", "2", "X", "X", "X", "Y", "MT", "MT", "MT")) + # never coerces to integer -- non-autosomes survive + expect_type(pecotmr:::canonChrom("chrX"), "character") +}) + +test_that("parseVariantId keeps non-autosomal chromosomes as strings", { + res <- parseVariantId(c("chrX:100:A:G", "chr23:200:T:C", "chrM:5:G:A", "chrY:9:C:T")) + expect_equal(res$chrom, c("X", "X", "MT", "Y")) + expect_equal(res$pos, c(100L, 200L, 5L, 9L)) +}) + +test_that("formatVariantId emits non-autosomal ids without 'chrNA'", { + expect_equal(pecotmr:::formatVariantId("X", 100, "A", "G"), "chrX:100:A:G") + expect_equal(pecotmr:::formatVariantId("23", 100, "A", "G"), "chrX:100:A:G") + expect_false(grepl("NA", pecotmr:::formatVariantId("chrMT", 5, "G", "A"))) +}) -test_that("ensureChrMatch returns unchanged when both have chr prefix", { - idsA <- c("chr1:100:A:G", "chr1:200:C:T") - idsB <- c("chr1:150:A:G", "chr1:250:C:T") - result <- pecotmr:::ensureChrMatch(idsA, idsB) - expect_equal(result$idsA, idsA) - expect_equal(result$idsB, idsB) +test_that("normalizeVariantId round-trips non-autosomal chromosomes", { + expect_equal(normalizeVariantId("23:100:A:G"), "chrX:100:A:G") + expect_equal(normalizeVariantId("chrX:100:A:G"), "chrX:100:A:G") + expect_equal(normalizeVariantId("chrM:5:G:A"), "chrMT:5:G:A") }) +test_that("chromOrder sorts autosomes then X/Y/MT", { + ord <- pecotmr:::chromOrder(c("MT", "X", "2", "1", "22", "Y")) + expect_equal(as.character(sort(ord)), c("1", "2", "22", "X", "Y", "MT")) +}) -test_that("ensureChrMatch normalizes when prefixes mismatch", { - idsA <- c("chr1:100:A:G", "chr1:200:C:T") - idsB <- c("1:150:A:G", "1:250:C:T") - result <- pecotmr:::ensureChrMatch(idsA, idsB) - expect_true(all(grepl("^chr", result$idsA))) - expect_true(all(grepl("^chr", result$idsB))) +test_that("regionToDf keeps chrom as a string and positions as integers", { + res <- regionToDf("chrX_1000_2000") + expect_equal(res$chrom, "X") + expect_type(res$start, "integer") + expect_equal(res$start, 1000L) }) +# =========================================================================== +# matchVariants -- allele-aware matcher (match on chrom/pos/ref/alt) +# =========================================================================== -test_that("ensureChrMatch returns unchanged when both lack chr prefix", { - idsA <- c("1:100:A:G", "1:200:C:T") - idsB <- c("1:150:A:G", "1:250:C:T") - result <- pecotmr:::ensureChrMatch(idsA, idsB) - # Both already match (no prefix), so returned unchanged - expect_equal(result$idsA, idsA) - expect_equal(result$idsB, idsB) +test_that("matchVariants matches exact pairs and reports sign +1", { + a <- c("chr1:100:A:G", "chr2:200:C:T") + b <- c("chr2:200:C:T", "chr1:100:A:G") + m <- pecotmr:::matchVariants(a, b) + ord <- order(m$idxA) + expect_equal(m$idxA[ord], c(1L, 2L)) + expect_equal(m$idxB[ord], c(2L, 1L)) # a[1]->b[2], a[2]->b[1] + expect_equal(m$sign[ord], c(1, 1)) +}) + +test_that("matchVariants is robust to chr-prefix and separator differences", { + m <- pecotmr:::matchVariants("chr1:100:A:G", "1_100_A_G") + expect_equal(m$idxA, 1L) + expect_equal(m$idxB, 1L) + expect_equal(m$sign, 1) +}) + +test_that("matchVariants reports sign -1 for an allele swap", { + m <- pecotmr:::matchVariants("chr1:100:A:G", "chr1:100:G:A") + expect_equal(m$idxA, 1L) + expect_equal(m$idxB, 1L) + expect_equal(m$sign, -1) +}) + +test_that("matchVariants handles strand-ambiguous (A/T) swaps with the QC heuristic", { + # A lone A/T swap has no unambiguous strand flip to corroborate a strand + # interpretation, so (mirroring summaryStatsQc) it is treated as a plain + # allele swap and kept with sign -1, not dropped. + m <- pecotmr:::matchVariants("chr1:100:A:T", "chr1:100:T:A") + expect_equal(m$idxA, 1L) + expect_equal(m$sign, -1) + + # When the batch contains a genuine unambiguous strand flip ([1]), the + # ambiguous A/T swap ([2]) is dropped as untrustworthy by default ... + a <- c("chr1:100:A:C", "chr2:200:A:T") + b <- c("chr1:100:T:G", "chr2:200:T:A") + expect_equal(pecotmr:::matchVariants(a, b)$idxA, 1L) + # ... but is kept when ambiguity checking is disabled. + expect_equal(sort(pecotmr:::matchVariants(a, b, removeStrandAmbiguous = FALSE)$idxA), + c(1L, 2L)) +}) + +test_that("matchVariants matches non-autosomal variants (chrX, chr23 synonym)", { + m <- pecotmr:::matchVariants(c("chrX:100:A:G", "chr23:200:C:T"), + c("X:100:A:G", "X:200:C:T")) + ord <- order(m$idxA) + expect_equal(m$idxA[ord], c(1L, 2L)) + expect_equal(m$idxB[ord], c(1L, 2L)) +}) + +test_that("matchVariants falls back to exact string match for rsIDs", { + m <- pecotmr:::matchVariants(c("rs1", "rs2", "rs3"), c("rs3", "rs1")) + ord <- order(m$idxA) + expect_equal(m$idxA[ord], c(1L, 3L)) + expect_equal(m$idxB[ord], c(2L, 1L)) + expect_equal(m$sign[ord], c(1, 1)) +}) + +test_that("matchVariants disambiguates a multi-allelic site by allele", { + m <- pecotmr:::matchVariants("chr1:100:A:G", + c("chr1:100:A:T", "chr1:100:A:G")) + expect_equal(m$idxA, 1L) + expect_equal(m$idxB, 2L) # the A:G ref, not A:T + expect_equal(m$sign, 1) +}) + +test_that("matchVariants returns empty on no overlap", { + m <- pecotmr:::matchVariants("chr1:100:A:G", "chr2:200:C:T") + expect_length(m$idxA, 0) + expect_length(m$idxB, 0) + expect_length(m$sign, 0) +}) + +test_that("matchVariants accepts data.frame (chrom/pos/A2/A1) input", { + a <- data.frame(chrom = "1", pos = 100L, A2 = "A", A1 = "G", + stringsAsFactors = FALSE) + m <- pecotmr:::matchVariants(a, "chr1:100:A:G") + expect_equal(m$idxA, 1L) + expect_equal(m$idxB, 1L) + expect_equal(m$sign, 1) +}) + +test_that("matchVariants allowFlip = FALSE matches exact alleles only (no swap)", { + # chr-prefix / separator still reconcile ... + m1 <- pecotmr:::matchVariants("chr1:100:A:G", "1_100_A_G", allowFlip = FALSE) + expect_equal(m1$idxA, 1L) + expect_equal(m1$sign, 1) + # ... but a ref/alt swap is NOT matched when flipping is disabled. + m2 <- pecotmr:::matchVariants("chr1:100:A:G", "chr1:100:G:A", allowFlip = FALSE) + expect_length(m2$idxA, 0) }) From 4dc3ad412aa8643dcda5a65a597400179a058638 Mon Sep 17 00:00:00 2001 From: Daniel Nachun Date: Thu, 2 Jul 2026 19:59:44 -0700 Subject: [PATCH 2/2] deduplicate fine-mapping logic --- R/AllClasses.R | 87 +++- R/GwasFineMappingResult.R | 53 +-- R/LdData.R | 16 +- R/QtlDataset.R | 6 +- R/QtlFineMappingResult.R | 53 +-- R/causalInferencePipeline.R | 98 ++-- R/colocboostPipeline.R | 18 +- R/ctwasPipeline.R | 15 +- R/fineMappingPipeline.R | 397 +++++----------- R/fineMappingWrappers.R | 294 ++++++++++-- R/genotypeIo.R | 116 ++--- R/gwasSumStats.R | 31 +- R/h2Annotations.R | 2 +- R/h2EstimationWrappers.R | 55 +-- R/jointSpecification.R | 74 ++- R/mashPipeline.R | 6 +- R/pvalCombine.R | 19 + R/qtlSumStats.R | 40 +- R/regularizedRegressionWrappers.R | 444 ++++++++---------- R/sldscWrapper.R | 2 +- R/sumstatsQc.R | 50 +- R/twasWeightsPipeline.R | 80 +--- R/variantId.R | 12 + man/dot-penalizedRssWeights.Rd | 10 +- man/fineMappingPipeline.Rd | 7 + man/getCs.Rd | 22 +- man/getMaf.Rd | 12 +- man/getMarginalEffects.Rd | 21 +- man/getN.Rd | 10 +- man/getSusieFit.Rd | 13 +- man/getTopLoci.Rd | 22 +- man/getVariantIds.Rd | 23 +- man/getZ.Rd | 10 +- man/lassosumRss.Rd | 7 +- man/nSnps.Rd | 10 +- man/penalizedRss.Rd | 12 +- man/prsCs.Rd | 7 +- man/sdpr.Rd | 7 +- tests/testthat/test_fineMappingPipeline.R | 62 +++ tests/testthat/test_fineMappingWrappers.R | 2 +- .../test_regularizedRegressionWrappers.R | 27 +- tests/testthat/test_rrDispatch.R | 35 +- tests/testthat/test_rrLassosum.R | 38 +- tests/testthat/test_rrPenalizedRss.R | 41 +- tests/testthat/test_rrPrsCs.R | 55 +-- tests/testthat/test_rrSdpr.R | 55 +-- tests/testthat/test_rrSusie.R | 9 +- tests/testthat/test_sumstatsQc.R | 2 +- tests/testthat/test_twasWeights.R | 13 +- tests/testthat/test_variantId.R | 109 +++++ 50 files changed, 1291 insertions(+), 1318 deletions(-) diff --git a/R/AllClasses.R b/R/AllClasses.R index da35193c..d756316d 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -20,10 +20,10 @@ NULL # ----------------------------------------------------------------------------- # Shared parent of the QTL and GWAS summary statistics collections. # Concrete subclasses (QtlSumStats, GwasSumStats) inherit from DFrame and -# share the ldSketch / genome / qcInfo slots. Class-specific accessors -# (getZ / getN / getMaf / nSnps / subsetChr / getVarY / getSumStats) -# stay on the concrete subclass because they rely on the tuple shape -# (3-tuple for QtlSumStats, 1-tuple for GwasSumStats). +# share the ldSketch / genome / qcInfo slots. getZ / getN / getMaf / nSnps are +# defined once on SumStatsBase (they only delegate to getSumStats); subsetChr / +# getVarY / getSumStats / getSumstatDf stay on the concrete subclass because +# they rely on the tuple shape (3-tuple QtlSumStats, 1-tuple GwasSumStats). # ============================================================================= #' @title Summary Statistics Base Class @@ -88,6 +88,28 @@ setMethod("getLdSketch", "SumStatsBase", function(x, ...) x@ldSketch) setMethod("getStudy", "SumStatsBase", function(x) unique(as.character(x$study))) +# getZ / getN / getMaf / nSnps delegate purely to getSumStats (which the +# concrete subclass dispatches with its own tuple shape), so they live once on +# the base and forward `...` through. +#' @rdname getZ +#' @export +setMethod("getZ", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$Z) + +#' @rdname getN +#' @export +setMethod("getN", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$N) + +#' @rdname getMaf +#' @export +setMethod("getMaf", "SumStatsBase", function(x, ...) { + mc <- mcols(getSumStats(x, ...)) + if ("MAF" %in% colnames(mc)) mc$MAF else NULL +}) + +#' @rdname nSnps +#' @export +setMethod("nSnps", "SumStatsBase", function(x, ...) length(getSumStats(x, ...))) + # ============================================================================= # FineMappingResultBase # ----------------------------------------------------------------------------- @@ -145,3 +167,60 @@ setMethod("adjustPips", "FineMappingResultBase", x@listData$entry <- entries x }) + +# Select the single FineMappingEntry addressed by a (tuple / region) key. Each +# concrete subclass implements this with its own row selector; the delegating +# accessors below then live once on the base and route through it. +setGeneric(".fmrSelectEntry", function(x, ...) standardGeneric(".fmrSelectEntry")) + +#' @rdname getCs +#' @export +setMethod("getCs", "FineMappingResultBase", + function(x, study = NULL, context = NULL, trait = NULL, method = NULL, + region = NULL, coverage = 0.95, ...) { + getCs(.fmrSelectEntry(x, study = study, context = context, trait = trait, + method = method, region = region), + coverage = coverage) + }) + +#' @rdname getTopLoci +#' @export +setMethod("getTopLoci", "FineMappingResultBase", + function(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, + study = NULL, context = NULL, trait = NULL, method = NULL, + region = NULL, ...) { + getTopLoci(.fmrSelectEntry(x, study = study, context = context, + trait = trait, method = method, region = region), + type = match.arg(type), signalCutoff = signalCutoff) + }) + +#' @rdname getMarginalEffects +#' @export +setMethod("getMarginalEffects", "FineMappingResultBase", + function(x, maxPval = NULL, + study = NULL, context = NULL, trait = NULL, method = NULL, + region = NULL, ...) { + getMarginalEffects(.fmrSelectEntry(x, study = study, context = context, + trait = trait, method = method, + region = region), maxPval = maxPval) + }) + +#' @rdname getSusieFit +#' @export +setMethod("getSusieFit", "FineMappingResultBase", + function(x, study = NULL, context = NULL, trait = NULL, method = NULL, + region = NULL, ...) { + getSusieFit(.fmrSelectEntry(x, study = study, context = context, + trait = trait, method = method, + region = region)) + }) + +#' @rdname getVariantIds +#' @export +setMethod("getVariantIds", "FineMappingResultBase", + function(x, study = NULL, context = NULL, trait = NULL, method = NULL, + region = NULL, ...) { + getVariantIds(.fmrSelectEntry(x, study = study, context = context, + trait = trait, method = method, + region = region)) + }) diff --git a/R/GwasFineMappingResult.R b/R/GwasFineMappingResult.R index e2c3e950..f2a9914a 100644 --- a/R/GwasFineMappingResult.R +++ b/R/GwasFineMappingResult.R @@ -161,54 +161,13 @@ setMethod("getPip", "GwasFineMappingResult", getPip(x$entry[[idx]]) }) -#' @rdname getCs -#' @export -setMethod("getCs", "GwasFineMappingResult", +# Row selector for the base delegating accessors (getCs / getTopLoci / +# getMarginalEffects / getSusieFit / getVariantIds live on +# FineMappingResultBase, AllClasses.R). The Gwas selector threads `region`. +setMethod(".fmrSelectEntry", "GwasFineMappingResult", function(x, study = NULL, context = NULL, trait = NULL, method = NULL, - region = NULL, ...) { - idx <- .tupleSelectRowGwasFmr(x, study, method, region) - getCs(x$entry[[idx]]) - }) - -#' @rdname getTopLoci -#' @export -setMethod("getTopLoci", "GwasFineMappingResult", - function(x, type = c("data.frame", "GRanges"), - signalCutoff = 0.025, - study = NULL, context = NULL, trait = NULL, method = NULL, - region = NULL, ...) { - idx <- .tupleSelectRowGwasFmr(x, study, method, region) - getTopLoci(x$entry[[idx]], type = match.arg(type), - signalCutoff = signalCutoff) - }) - -#' @rdname getMarginalEffects -#' @export -setMethod("getMarginalEffects", "GwasFineMappingResult", - function(x, maxPval = NULL, - study = NULL, context = NULL, trait = NULL, method = NULL, - region = NULL, ...) { - idx <- .tupleSelectRowGwasFmr(x, study, method, region) - getMarginalEffects(x$entry[[idx]], maxPval = maxPval) - }) - -#' @rdname getSusieFit -#' @export -setMethod("getSusieFit", "GwasFineMappingResult", - function(x, study = NULL, context = NULL, trait = NULL, method = NULL, - region = NULL, ...) { - idx <- .tupleSelectRowGwasFmr(x, study, method, region) - getSusieFit(x$entry[[idx]]) - }) - -#' @rdname getVariantIds -#' @export -setMethod("getVariantIds", "GwasFineMappingResult", - function(x, study = NULL, context = NULL, trait = NULL, method = NULL, - region = NULL, ...) { - idx <- .tupleSelectRowGwasFmr(x, study, method, region) - getVariantIds(x$entry[[idx]]) - }) + region = NULL, ...) + x$entry[[.tupleSelectRowGwasFmr(x, study, method, region)]]) #' @export diff --git a/R/LdData.R b/R/LdData.R index e8ee6b75..bb0b8176 100644 --- a/R/LdData.R +++ b/R/LdData.R @@ -160,9 +160,7 @@ setMethod("getCorrelation", "LdData", function(x) { "Construct LdData with mixtureWeights = ", "when supplying a list of GenotypeHandles.") perPanel <- lapply(x@genotypeHandle, function(h) { - geno <- extractBlockGenotypes(h, x@snpIdx) - X <- t(assay(geno, "dosage")) - computeLd(X, method = "sample") + computeLd(.dosageMatrix(h, x@snpIdx), method = "sample") }) dims <- vapply(perPanel, function(R) nrow(R), integer(1)) if (length(unique(dims)) != 1L) @@ -175,9 +173,7 @@ setMethod("getCorrelation", "LdData", function(x) { dimnames(R) <- dimnames(perPanel[[1L]]) return(R) } - geno <- extractBlockGenotypes(x@genotypeHandle, x@snpIdx) - X <- t(assay(geno, "dosage")) - computeLd(X, method = "sample") + computeLd(.dosageMatrix(x@genotypeHandle, x@snpIdx), method = "sample") }) #' @rdname getGenotypes @@ -186,13 +182,9 @@ setMethod("getGenotypes", "LdData", function(x, ...) { if (is.null(x@genotypeHandle)) return(NULL) if (is.matrix(x@genotypeHandle)) return(x@genotypeHandle) if (is.list(x@genotypeHandle)) { - lapply(x@genotypeHandle, function(h) { - geno <- extractBlockGenotypes(h, x@snpIdx) - t(assay(geno, "dosage")) - }) + lapply(x@genotypeHandle, function(h) .dosageMatrix(h, x@snpIdx)) } else { - geno <- extractBlockGenotypes(x@genotypeHandle, x@snpIdx) - t(assay(geno, "dosage")) + .dosageMatrix(x@genotypeHandle, x@snpIdx) } }) diff --git a/R/QtlDataset.R b/R/QtlDataset.R index 23391c92..497174e6 100644 --- a/R/QtlDataset.R +++ b/R/QtlDataset.R @@ -361,10 +361,8 @@ setMethod("getScaleResiduals", "QtlDataset", function(x) x@scaleResiduals) } } - block <- extractBlockGenotypes(x@genotypes, snpIdx, meanImpute = FALSE) - # `block` is variants x samples (Bioc convention); transpose to - # samples x variants for analysis-style operations. - dosage <- t(SummarizedExperiment::assay(block, "dosage")) + # samples x variants dosage for analysis-style operations. + dosage <- .dosageMatrix(x@genotypes, snpIdx, meanImpute = FALSE) # Resolve the requested sample set: keepSamples (panel-level) intersected # with the per-call samples arg, then intersected with the panel sample IDs. diff --git a/R/QtlFineMappingResult.R b/R/QtlFineMappingResult.R index 90291c5c..f4f9eff5 100644 --- a/R/QtlFineMappingResult.R +++ b/R/QtlFineMappingResult.R @@ -156,14 +156,12 @@ setMethod("getPip", "QtlFineMappingResult", pip }) -#' @rdname getCs -#' @export -setMethod("getCs", "QtlFineMappingResult", - function(x, study = NULL, context = NULL, trait = NULL, method = NULL, - coverage = 0.95, ...) { - entry <- getFineMappingResult(x, study, context, trait, method) - getCs(entry, coverage = coverage) - }) +# Row selector for the base delegating accessors (getCs / getTopLoci / +# getMarginalEffects / getSusieFit / getVariantIds now live on +# FineMappingResultBase, AllClasses.R). +setMethod(".fmrSelectEntry", "QtlFineMappingResult", + function(x, study = NULL, context = NULL, trait = NULL, method = NULL, ...) + getFineMappingResult(x, study, context, trait, method)) #' @rdname getCvResult #' @export @@ -173,43 +171,8 @@ setMethod("getCvResult", "QtlFineMappingResult", getCvResult(entry) }) -#' @rdname getTopLoci -#' @export -setMethod("getTopLoci", "QtlFineMappingResult", - function(x, type = c("data.frame", "GRanges"), - signalCutoff = 0.025, - study = NULL, context = NULL, trait = NULL, method = NULL, - ...) { - entry <- getFineMappingResult(x, study, context, trait, method) - getTopLoci(entry, type = match.arg(type), signalCutoff = signalCutoff) - }) - -#' @rdname getMarginalEffects -#' @export -setMethod("getMarginalEffects", "QtlFineMappingResult", - function(x, maxPval = NULL, - study = NULL, context = NULL, trait = NULL, method = NULL, ...) { - entry <- getFineMappingResult(x, study, context, trait, method) - getMarginalEffects(entry, maxPval = maxPval) - }) - -#' @rdname getSusieFit -#' @export -setMethod("getSusieFit", "QtlFineMappingResult", - function(x, study = NULL, context = NULL, trait = NULL, method = NULL, - ...) { - entry <- getFineMappingResult(x, study, context, trait, method) - getSusieFit(entry) - }) - -#' @rdname getVariantIds -#' @export -setMethod("getVariantIds", "QtlFineMappingResult", - function(x, study = NULL, context = NULL, trait = NULL, method = NULL, - ...) { - entry <- getFineMappingResult(x, study, context, trait, method) - getVariantIds(entry) - }) +# getTopLoci / getMarginalEffects / getSusieFit / getVariantIds are defined once +# on FineMappingResultBase (AllClasses.R), routing through .fmrSelectEntry. #' @rdname getContexts #' @export diff --git a/R/causalInferencePipeline.R b/R/causalInferencePipeline.R index 67a2d484..cf008851 100644 --- a/R/causalInferencePipeline.R +++ b/R/causalInferencePipeline.R @@ -429,7 +429,7 @@ causalInferencePipeline <- function(gwasSumStats, method = method) tl <- getTopLoci(ent) if (is.null(tl) || nrow(tl) == 0L) return(NULL) - betaCol <- intersect(c("betahat", "beta", "bhat_x"), colnames(tl)) + betaCol <- .cipTlCols(tl)$beta if (length(betaCol) == 0L) return(NULL) vids <- as.character(tl$variant_id) w <- as.numeric(tl[[betaCol[[1L]]]]) @@ -485,9 +485,10 @@ causalInferencePipeline <- function(gwasSumStats, if (is.null(tl) || nrow(tl) == 0L) return(list(waldRatio = NA_real_, waldRatioSe = NA_real_, mrPval = NA_real_, nIV = 0L)) - pipCol <- intersect(c("pip", "PIP"), colnames(tl)) - betaCol <- intersect(c("betahat", "beta", "bhat_x"), colnames(tl)) - seCol <- intersect(c("sebetahat", "se", "sbhat_x"), colnames(tl)) + cols <- .cipTlCols(tl) + pipCol <- cols$pip + betaCol <- cols$beta + seCol <- cols$se if (length(pipCol) == 0L || length(betaCol) == 0L || length(seCol) == 0L) return(list(waldRatio = NA_real_, waldRatioSe = NA_real_, mrPval = NA_real_, nIV = 0L)) @@ -517,18 +518,13 @@ causalInferencePipeline <- function(gwasSumStats, ratio <- betaY / betaX # Standard Wald-ratio SE via delta method. rSe <- sqrt((seY / betaX)^2 + (betaY * seX / betaX^2)^2) - # IVW pooling: weight by 1/rSe^2; pooled SE = 1/sqrt(sum(w)). - w <- 1 / rSe^2 - validW <- is.finite(w) & w > 0 - if (sum(validW) == 0L) + # IVW pooling of the per-instrument Wald ratios. + pooled <- .ivwPool(ratio, rSe) + if (pooled$n == 0L) return(list(waldRatio = NA_real_, waldRatioSe = NA_real_, mrPval = NA_real_, nIV = 0L)) - ratio <- ratio[validW]; rSe <- rSe[validW]; w <- w[validW] - meta <- sum(w * ratio) / sum(w) - metaSe <- 1 / sqrt(sum(w)) - pval <- 2 * stats::pnorm(-abs(meta / metaSe)) - list(waldRatio = meta, waldRatioSe = metaSe, - mrPval = pval, nIV = length(ratio)) + list(waldRatio = pooled$effect, waldRatioSe = pooled$se, + mrPval = pooled$pval, nIV = pooled$n) } # Cochran's Q-based I-squared heterogeneity statistic. Ported from @@ -569,15 +565,11 @@ causalInferencePipeline <- function(gwasSumStats, tl <- getTopLoci(fmrEntry) if (is.null(tl) || nrow(tl) == 0L) return(naResult) - pipCol <- intersect(c("pip", "PIP"), colnames(tl)) - betaCol <- intersect(c("betahat", "beta", "bhat_x"), colnames(tl)) - seCol <- intersect(c("sebetahat", "se", "sbhat_x"), colnames(tl)) - csCol <- intersect(c("cs"), colnames(tl)) - if (length(csCol) == 0L) { - # Look for any column starting with "cs" (e.g. cs_0.95, cs_susie). - csCandidates <- grep("^cs", colnames(tl), value = TRUE) - if (length(csCandidates) > 0L) csCol <- csCandidates[[1L]] - } + cols <- .cipTlCols(tl) + pipCol <- cols$pip + betaCol <- cols$beta + seCol <- cols$se + csCol <- cols$cs if (length(pipCol) == 0L || length(betaCol) == 0L || length(seCol) == 0L || length(csCol) == 0L) return(naResult) @@ -638,12 +630,12 @@ causalInferencePipeline <- function(gwasSumStats, if (length(composite_bhat) == 0L) return(naResult) # IVW meta across CSs. - wv <- 1 / composite_sbhat^2 - metaEff <- sum(wv * composite_bhat) / sum(wv) - metaSe <- sqrt(1 / sum(wv)) - Q <- sum(wv * (composite_bhat - metaEff)^2) - I2 <- .cipCalcI2(Q, length(composite_bhat)) - metaPval <- 2 * stats::pnorm(-abs(metaEff / metaSe)) + pooled <- .ivwPool(composite_bhat, composite_sbhat) + metaEff <- pooled$effect + metaSe <- pooled$se + Q <- pooled$Q + I2 <- .cipCalcI2(Q, pooled$n) + metaPval <- pooled$pval list(waldRatio = metaEff, waldRatioSe = metaSe, @@ -654,17 +646,52 @@ causalInferencePipeline <- function(gwasSumStats, } -# Derive beta from z using maf + n. beta = z * se. With se = 1/sqrt(2*n*p*q), -# beta = z / sqrt(2*n*p*q). +# Derive beta / se from z using maf + n via the shared zToBetaSe() (model-exact +# se = 1/sqrt(2*p*q*(N + z^2)), beta = z*se). Fall back to z as a beta surrogate +# / se = 1 when maf or n is unavailable. .cipZToBeta <- function(z, maf, n) { if (any(is.na(maf)) || any(is.na(n))) return(z) # fall back to z as a beta surrogate when no maf/n - z / sqrt(2 * n * maf * (1 - maf)) + .zToBetaSe(z, maf, n)$beta } .cipZToSe <- function(z, maf, n) { if (any(is.na(maf)) || any(is.na(n))) return(rep(1, length(z))) - 1 / sqrt(2 * n * maf * (1 - maf)) + .zToBetaSe(z, maf, n)$se +} + +# Fixed-effect inverse-variance-weighted (IVW) pooling of per-instrument +# effects. Weights 1/se^2, drops non-finite / non-positive weights, and +# returns the pooled effect, its SE (1/sqrt(sum w)), two-tailed p-value, +# Cochran's Q, and the number pooled (n = 0 when nothing is poolable). +.ivwPool <- function(effect, se) { + w <- 1 / se^2 + ok <- is.finite(w) & w > 0 + if (!any(ok)) + return(list(effect = NA_real_, se = NA_real_, pval = NA_real_, + Q = NA_real_, n = 0L)) + effect <- effect[ok]; w <- w[ok] + metaEff <- sum(w * effect) / sum(w) + metaSe <- 1 / sqrt(sum(w)) + list(effect = metaEff, se = metaSe, + pval = .zToPvalue(metaEff / metaSe), + Q = sum(w * (effect - metaEff)^2), n = length(effect)) +} + +# Resolve the topLoci column aliases used across the CIP MR helpers. Returns the +# first matching column name for each role (character(0) if absent); `cs` also +# falls back to any column whose name starts with "cs" (e.g. cs_0.95). +.cipTlCols <- function(tl) { + cn <- colnames(tl) + cs <- intersect("cs", cn) + if (length(cs) == 0L) { + csCand <- grep("^cs", cn, value = TRUE) + if (length(csCand) > 0L) cs <- csCand[[1L]] + } + list(pip = intersect(c("pip", "PIP"), cn), + beta = intersect(c("betahat", "beta", "bhat_x"), cn), + se = intersect(c("sebetahat", "se", "sbhat_x"), cn), + cs = cs) } # Convert the accumulated list of row records to a flat data.frame. @@ -675,8 +702,7 @@ causalInferencePipeline <- function(gwasSumStats, # Convert the assembled result data.frame to a GRanges with mcols. .cipDfToGranges <- function(df) { - chr <- paste0("chr", sub("^chr", "", as.character(df$chrom), - ignore.case = TRUE)) + chr <- withChrPrefix(df$chrom) gr <- GenomicRanges::GRanges( seqnames = chr, ranges = IRanges::IRanges(start = as.integer(df$startPos), @@ -853,7 +879,7 @@ twasZ <- function(weights, z, R = NULL, X = NULL, ySd <- sqrt(diag(covY)) stats <- as.numeric(crossprod(weights, as.numeric(z))) zVec <- stats / ySd - pVec <- 2 * pnorm(-abs(zVec)) + pVec <- .zToPvalue(zVec) zMatrix <- cbind(Z = zVec, pval = pVec) rownames(zMatrix) <- colnames(weights) diff --git a/R/colocboostPipeline.R b/R/colocboostPipeline.R index b52b0056..24835073 100644 --- a/R/colocboostPipeline.R +++ b/R/colocboostPipeline.R @@ -177,18 +177,12 @@ setGeneric("colocboostPipeline", # Returns the retained Y (NULL when no outcome clears the threshold). .cbPipSkipOutcomes <- function(X, Y, cutoff) { if (is.null(cutoff) || is.na(cutoff) || cutoff == 0) return(Y) - if (!is.double(X)) storage.mode(X) <- "double" # susieR needs double X - thr <- if (cutoff < 0) 3 / ncol(X) else cutoff - keep <- logical(ncol(Y)) - for (j in seq_len(ncol(Y))) { - obs <- !is.na(Y[, j]) - if (sum(obs) < 2L) next - pip <- tryCatch( - susieR::susie(X[obs, , drop = FALSE], Y[obs, j], - L = 1, max_iter = 100)$pip, - error = function(e) NULL) - if (!is.null(pip) && any(pip > thr, na.rm = TRUE)) keep[[j]] <- TRUE - } + # Single-effect screen per outcome, sharing the L = 1 SuSiE pre-screen + # (.fmSerScreen) with the fine-mapping pipeline. fallback = FALSE: an outcome + # that cannot be screened (too few samples / fit failure) is dropped. + keep <- vapply(seq_len(ncol(Y)), + function(j) .fmSerScreen(X, Y[, j], cutoff, fallback = FALSE), + logical(1L)) if (!any(keep)) return(NULL) Y[, keep, drop = FALSE] } diff --git a/R/ctwasPipeline.R b/R/ctwasPipeline.R index 761e6653..2dab23ba 100644 --- a/R/ctwasPipeline.R +++ b/R/ctwasPipeline.R @@ -681,16 +681,7 @@ mergeCtwasBoundaryRegions <- function(finemapResult, niter = as.integer(niterPrefit), group_prior_var_structure = groupPriorVarStructure, ncore = as.integer(ncore)) - if (length(extra) > 0L) { - formalsFn <- tryCatch(names(formals(fitEm)), error = function(e) NULL) - if (!is.null(formalsFn)) { - explicitFormals <- setdiff(formalsFn, "...") - extra <- extra[setdiff(names(extra), names(fitArgs))] - extra <- extra[intersect(names(extra), explicitFormals)] - } - fitArgs <- c(fitArgs, extra) - } - prefit <- do.call(fitEm, fitArgs) + prefit <- .ctwasInvoke(fitEm, fitArgs, extra) groupPrior <- prefit$group_prior groupSize <- prefit$group_size if (thin != 1) { @@ -859,9 +850,7 @@ mergeCtwasBoundaryRegions <- function(finemapResult, # @noRd .ctwasComputeFullPanelLd <- function(gwasLd) { snpInfoCtwas <- .ctwasSnpInfoForBlock(gwasLd) - block <- extractBlockGenotypes(gwasLd, seq_len(nrow(snpInfoCtwas)), - meanImpute = TRUE) - geno <- t(SummarizedExperiment::assay(block, "dosage")) + geno <- .dosageMatrix(gwasLd, seq_len(nrow(snpInfoCtwas)), meanImpute = TRUE) R <- computeLd(geno, method = "sample") snpIds <- snpInfoCtwas$id dimnames(R) <- list(snpIds, snpIds) diff --git a/R/fineMappingPipeline.R b/R/fineMappingPipeline.R index 2a756e02..d2af774b 100644 --- a/R/fineMappingPipeline.R +++ b/R/fineMappingPipeline.R @@ -30,6 +30,13 @@ #' variant of the same.} #' \item{\code{susieAsh}}{\code{unmappable_effects = "ash"} #' variant of the same.} +#' \item{\code{ser}}{Single-effect regression via +#' \code{susieR::susie_ser} on summary statistics +#' (\code{z}, \code{n}); LD-free (no \code{R}, no \code{L}), +#' so distinct from \code{susie} with \code{L = 1}. Sumstat +#' input only (\code{QtlSumStats} / \code{GwasSumStats}, or the +#' sumstat side of a \code{MultiStudyQtlDataset}); rejected on +#' individual-level \code{QtlDataset}.} #' \item{\code{mvsusie}}{\code{mvsusieR::mvsusie} on individual- #' level input (requires multi-trait OR multi-context Y), #' \code{mvsusieR::mvsusie_rss} on sumstat input (requires @@ -290,6 +297,17 @@ setGeneric("fineMappingPipeline", gwasAllowed = TRUE, unmappableEffects = "ash", args = list()), + # Single-effect regression (SER) on summary statistics via susieR::susie_ser. + # LD-free (z + n; no R, no L), so distinct from susie with L = 1. Sumstat-only + # (individualImpl = NULL): runs on QtlSumStats / GwasSumStats (and the sumstat + # side of a MultiStudyQtlDataset); rejected on individual-level QtlDataset. + ser = list( + individualImpl = NULL, + sumstatImpl = "susieR::susie_ser", + multivariate = FALSE, + gwasAllowed = TRUE, + unmappableEffects = NA_character_, + args = list()), mvsusie = list( individualImpl = "mvsusieR::mvsusie", sumstatImpl = "mvsusieR::mvsusie_rss", @@ -380,7 +398,6 @@ setGeneric("fineMappingPipeline", paste(unknown, collapse = ", "), paste(names(caps), collapse = ", "))) } - individualKinds <- c("QtlDataset", "MultiStudyQtlDataset") bad <- character(0); reason <- character(0) for (tk in tokens) { if (tk %in% .fmTwasOnlyTokens) { @@ -390,10 +407,18 @@ setGeneric("fineMappingPipeline", next } info <- caps[[tk]] - if (inputKind %in% individualKinds) { + if (inputKind == "QtlDataset") { if (is.null(info$individualImpl)) { bad <- c(bad, tk) - reason <- c(reason, "is sumstat-only on this pipeline") + reason <- c(reason, "is sumstat-only (use a QtlSumStats input)") + } + } else if (inputKind == "MultiStudyQtlDataset") { + # Can hold individual QtlDatasets and/or an embedded QtlSumStats, so a + # method is available if it has EITHER path; it is routed to the + # component(s) it applies to. + if (is.null(info$individualImpl) && is.null(info$sumstatImpl)) { + bad <- c(bad, tk) + reason <- c(reason, "has no individual or sumstat implementation") } } else if (inputKind == "QtlSumStats") { if (is.null(info$sumstatImpl)) { @@ -417,6 +442,19 @@ setGeneric("fineMappingPipeline", } } +# Keep only the tokens in `methods` whose capability has a non-NULL `capField` +# (individualImpl / sumstatImpl), so a sumstat-only method (e.g. ser) is dropped +# from the individual-level recursion and an individual-only method from the +# sumstat recursion. `methods` is a character vector of tokens or a named list +# of per-token args; unknown tokens pass through (handled elsewhere). +.fmFilterMethodsForKind <- function(methods, capField) { + caps <- .fineMappingMethodCapabilities + ok <- function(tk) { info <- caps[[tk]]; is.null(info) || !is.null(info[[capField]]) } + if (is.character(methods)) methods[vapply(methods, ok, logical(1))] + else if (is.list(methods)) methods[vapply(names(methods), ok, logical(1))] + else methods +} + # Reject SumStats inputs that have not been QC'd via summaryStatsQc. # @noRd @@ -870,21 +908,24 @@ setGeneric("fineMappingPipeline", # * `cutoff == 0` (or NULL/non-scalar) disables the screen -> always keep. # * `cutoff < 0` uses the adaptive 3 / nVariants threshold. # * NA entries of `y` are dropped before fitting. -# The screen is advisory: too few samples/variants or a fit failure keeps the -# block (returns TRUE) rather than discarding a potentially real signal. +# The screen is advisory: too few samples/variants or a fit failure returns +# `fallback` -- TRUE (default) keeps the block rather than discard a potentially +# real signal (fineMapping / joint paths); colocboost passes FALSE to drop an +# outcome it cannot screen. This is the single L = 1 SuSiE pre-screen shared by +# .fmSerScreenColumns (joint) and .cbPipSkipOutcomes (colocboost). # @noRd -.fmSerScreen <- function(X, y, cutoff) { +.fmSerScreen <- function(X, y, cutoff, fallback = TRUE) { if (is.null(cutoff) || length(cutoff) != 1L || is.na(cutoff) || cutoff == 0) return(TRUE) ok <- !is.na(y) - if (sum(ok) < 2L || ncol(X) < 1L) return(TRUE) + if (sum(ok) < 2L || ncol(X) < 1L) return(fallback) Xs <- X[ok, , drop = FALSE] - ys <- y[ok] + if (!is.double(Xs)) storage.mode(Xs) <- "double" # susieR needs double X thr <- if (cutoff < 0) 3 / ncol(Xs) else cutoff - pip <- tryCatch(suppressMessages(susieR::susie(Xs, ys, L = 1L))$pip, + pip <- tryCatch(suppressMessages(susieR::susie(Xs, y[ok], L = 1L))$pip, error = function(e) NULL) - if (is.null(pip)) return(TRUE) - any(pip > thr) + if (is.null(pip)) return(fallback) + any(pip > thr, na.rm = TRUE) } # Is the SER pre-screen enabled? Only a finite, non-zero scalar activates it; @@ -907,59 +948,8 @@ setGeneric("fineMappingPipeline", logical(1L)) } -# Fit every requested univariate token on one residualized (X, y) block, -# returning a named list (token -> FineMappingEntry). Extracted from the -# univariate dispatch so the same logic serves the cis path (one block), the -# jointRegions=TRUE path (one concatenated block) and the jointRegions=FALSE -# path (one block per region, merged afterwards via .fmMergeEntries). -.fmFitXBlock <- function(X, y, toRun, addSusieInf, coverage, - secondaryCoverage, signalCutoff, minAbsCorr, - methodArgs, verbose, ctx, tid, - cvFolds = 0, samplePartition = NULL, af = NULL) { - chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) - infFit <- NULL - if (chainLocal$runInf) { - if (verbose >= 1) - message(sprintf("Fitting susieInf for (context='%s', trait='%s') ...", - ctx, tid)) - infFit <- .fmFitSusieIndiv(X, y, "susieInf", coverage = coverage, - userArgs = methodArgs[["susieInf"]]) - } - out <- list() - for (tk in toRun) { - if (tk == "susieInf") { - if (!chainLocal$keepInf) next - fit <- infFit - } else { - chainFrom <- if ((tk == "susie" && chainLocal$chainSusie) || - (tk == "susieAsh" && chainLocal$chainAsh)) - infFit else NULL - if (verbose >= 1) - message(sprintf("Fitting %s for (context='%s', trait='%s') ...", - tk, ctx, tid)) - fit <- .fmFitSusieIndiv(X, y, tk, chainFromInf = chainFrom, - coverage = coverage, userArgs = methodArgs[[tk]]) - } - out[[tk]] <- .fmPostprocessOne( - fit = fit, method = tk, dataX = X, dataY = y, coverage = coverage, - secondaryCoverage = secondaryCoverage, signalCutoff = signalCutoff, - minAbsCorr = minAbsCorr, af = af, csInput = "X") - } - # Per-fold cross-validation across the fitted univariate methods; attach - # each method's out-of-fold predictions to its entry. - if (cvFolds > 1L && length(out) > 0L) { - if (verbose >= 1) - message(sprintf("Cross-validating (%d folds) for (context='%s', trait='%s') ...", - cvFolds, ctx, tid)) - cv <- .fmCrossValidate(X, y, names(out), methodArgs, cvFolds, - samplePartition = samplePartition, - coverage = coverage, verbose = verbose) - for (tk in names(out)) { - out[[tk]] <- .fmAttachCv(out[[tk]], .fmSliceCv(cv, tk)) - } - } - out -} +# .fmFitXBlock / .fmFitRssBlock (per-block SuSiE dispatch) now live in +# fineMappingWrappers.R with the other method-fitting wrappers. # Extract integer credible-set indices from a "_" vector. .fmCsIdx <- function(csVec) { @@ -1048,79 +1038,8 @@ setGeneric("fineMappingPipeline", } -# Fit one of the SuSiE-family individual-level methods on (X, y). When -# `chainFromInf` is non-NULL, the susieInf fit it points at is used as -# initialisation (with prepareSusieFromInfArgs); otherwise a plain fit -# with the requested `unmappable_effects` is performed. `userArgs` are -# spliced via .fmMergeUserArgs (user wins over chain/base/capability -# defaults), so the caller can override things like L, max_iter, -# estimate_residual_method, refine, etc. -# @noRd -.fmFitSusieIndiv <- function(X, y, token, chainFromInf = NULL, - coverage = 0.95, userArgs = NULL) { - info <- .fineMappingMethodCapabilities[[token]] - if (is.null(info) || identical(info$unmappableEffects, NA_character_)) { - stop(".fmFitSusieIndiv: token '", token, "' is not a SuSiE-family method.") - } - baseArgs <- list(X = X, y = y, coverage = coverage, - unmappable_effects = info$unmappableEffects) - if (token == "susieInf") { - baseArgs$convergence_method <- "pip" - baseArgs$refine <- FALSE - baseArgs$model_init <- NULL - } else if (!is.null(chainFromInf)) { - chainedArgs <- prepareSusieFromInfArgs( - list(), - chainFromInf, - refineDefault = if (token == "susie") TRUE else NULL, - unmappableEffects = if (token == "susieAsh") "ash" else "none") - baseArgs <- modifyList(baseArgs, chainedArgs) - # chainedArgs already supplies unmappable_effects + model_init; X / y - # / coverage stay in baseArgs. - baseArgs$X <- X; baseArgs$y <- y; baseArgs$coverage <- coverage - } else if (token == "susieAsh") { - baseArgs$convergence_method <- "pip" - } - baseArgs <- .fmMergeUserArgs(baseArgs, token, userArgs) - fit <- do.call(susieR::susie, baseArgs) - .setFinemappingFitClass(fit, token) -} - - -# Sumstat counterpart of .fmFitSusieIndiv. Calls susieR::susie_rss with -# the same unmappable_effects switch, chained init, and userArgs merge. -# @noRd -.fmFitSusieRss <- function(z, R, n, token, chainFromInf = NULL, - coverage = 0.95, userArgs = NULL) { - info <- .fineMappingMethodCapabilities[[token]] - if (is.null(info) || identical(info$unmappableEffects, NA_character_)) { - stop(".fmFitSusieRss: token '", token, "' is not a SuSiE-family method.") - } - baseArgs <- list(z = z, R = R, n = n, coverage = coverage, - unmappable_effects = info$unmappableEffects) - if (token == "susieInf") { - baseArgs$convergence_method <- "pip" - baseArgs$refine <- FALSE - baseArgs$model_init <- NULL - } else if (!is.null(chainFromInf)) { - chainedArgs <- prepareSusieFromInfArgs( - list(), - chainFromInf, - refineDefault = if (token == "susie") TRUE else NULL, - unmappableEffects = if (token == "susieAsh") "ash" else "none") - baseArgs <- modifyList(baseArgs, chainedArgs) - baseArgs$z <- z; baseArgs$R <- R; baseArgs$n <- n - baseArgs$coverage <- coverage - } else if (token == "susieAsh") { - baseArgs$convergence_method <- "pip" - } - baseArgs <- .fmMergeUserArgs(baseArgs, token, userArgs) - fit <- do.call(susieR::susie_rss, baseArgs) - # All susie_rss fits get the "susieRss" S3 class for post-processing - # (this drives the Xcorr cs-input mode). Token-level distinction stays - # in the `method` column of the FineMappingResult. - .setFinemappingFitClass(fit, "susieRss") -} +# .fmFitSusieIndiv / .fmFitSusieRss / .fmFitSusieSer (single SuSiE fits) now +# live in fineMappingWrappers.R with the other method-fitting wrappers. # Extract variant ids + Z + (median) N from a single QtlSumStats / @@ -1459,8 +1378,11 @@ setMethod("fineMappingPipeline", "QtlDataset", nCtx <- length(useCtx) nTraits <- length(allTraits) - # Partition tokens by univariate / multivariate / fsusie. - isUniv <- tokens %in% c("susie", "susieInf", "susieAsh") + # Partition tokens by univariate / multivariate / fsusie. Univariate = + # everything that isn't multivariate (mvsusie / fsusie); ser can't reach the + # individual path (capability check rejects it), so this set is unchanged + # here but stays consistent with the sumstat method. + isUniv <- !(tokens %in% c("mvsusie", "fsusie")) univTokens <- tokens[isUniv] isMv <- tokens == "mvsusie" mvTokens <- tokens[isMv] @@ -1727,83 +1649,36 @@ setMethod("fineMappingPipeline", "MultiStudyQtlDataset", } } - qtlDatasets <- getQtlDatasets(data) - sumStats <- getSumStats(data) - - out <- NULL - embeddedLd <- NULL - for (qdName in names(qtlDatasets)) { - qd <- qtlDatasets[[qdName]] - res <- fineMappingPipeline( - data = qd, - methods = methods, - contexts = contexts, - traitId = traitId, - region = region, - cisWindow = cisWindow, - jointRegions = jointRegions, - jointSpecification = NULL, - addSusieInf = addSusieInf, - coverage = coverage, - secondaryCoverage = secondaryCoverage, - signalCutoff = signalCutoff, - minAbsCorr = minAbsCorr, - fineMappingResult = fineMappingResult, - cvFolds = cvFolds, - samplePartition = samplePartition, - pipCutoffToSkip = pipCutoffToSkip, - seed = seed, - naAction = naAction, - verbose = verbose, - ...) - out <- if (is.null(out)) res else .rbindFineMappingResult(out, res, ldSketch = NULL) - } - - if (!is.null(sumStats)) { - ssRes <- fineMappingPipeline( - data = sumStats, - methods = methods, - contexts = contexts, - traitId = traitId, - jointSpecification = NULL, - addSusieInf = addSusieInf, - coverage = coverage, - secondaryCoverage = secondaryCoverage, - signalCutoff = signalCutoff, - minAbsCorr = minAbsCorr, - fineMappingResult = fineMappingResult, - verbose = verbose, - ...) - embeddedLd <- getLdSketch(ssRes) - out <- if (is.null(out)) ssRes else .rbindFineMappingResult(out, ssRes, - ldSketch = embeddedLd) + dotArgs <- list(...) + # Route each method to the components it supports: individual-capable + # methods to the per-study QtlDatasets, sumstat-capable methods (incl. the + # sumstat-only `ser`) to the embedded QtlSumStats. + perStudyFn <- function(qd) { + m <- .fmFilterMethodsForKind(methods, "individualImpl") + if (length(m) == 0L) return(NULL) + do.call(fineMappingPipeline, c(list( + data = qd, methods = m, contexts = contexts, traitId = traitId, + region = region, cisWindow = cisWindow, jointRegions = jointRegions, + jointSpecification = NULL, addSusieInf = addSusieInf, coverage = coverage, + secondaryCoverage = secondaryCoverage, signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, fineMappingResult = fineMappingResult, + cvFolds = cvFolds, samplePartition = samplePartition, + pipCutoffToSkip = pipCutoffToSkip, seed = seed, naAction = naAction, + verbose = verbose), dotArgs)) } - - perTupleResult <- if (!is.null(out)) { - # ldSketch: NULL if all studies were individual-level; the embedded - # sumStats's ldSketch otherwise. - QtlFineMappingResult( - study = as.character(out$study), - context = as.character(out$context), - trait = as.character(out$trait), - method = as.character(out$method), - entry = as.list(out$entry), - jointStudies = if ("jointStudies" %in% names(out)) - as.character(out$jointStudies) else NULL, - jointContexts = if ("jointContexts" %in% names(out)) - as.character(out$jointContexts) else NULL, - jointTraits = if ("jointTraits" %in% names(out)) - as.character(out$jointTraits) else NULL, - ldSketch = embeddedLd) - } else NULL - - if (is.null(jointResult)) { - if (is.null(perTupleResult)) - stop("fineMappingPipeline(MultiStudyQtlDataset): no entries produced a result.") - return(perTupleResult) + sumStatsFn <- function(ss) { + m <- .fmFilterMethodsForKind(methods, "sumstatImpl") + if (length(m) == 0L) return(NULL) + do.call(fineMappingPipeline, c(list( + data = ss, methods = m, contexts = contexts, traitId = traitId, + jointSpecification = NULL, addSusieInf = addSusieInf, coverage = coverage, + secondaryCoverage = secondaryCoverage, signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, fineMappingResult = fineMappingResult, + verbose = verbose), dotArgs)) } - if (is.null(perTupleResult)) return(jointResult) - .rbindFineMappingResult(perTupleResult, jointResult, ldSketch = embeddedLd) + .multiStudyPipelineDriver( + data, jointResult, perStudyFn, sumStatsFn, + .rbindFineMappingResult, QtlFineMappingResult, "fineMappingPipeline") }) @@ -1870,7 +1745,9 @@ setMethod("fineMappingPipeline", "QtlSumStats", "contexts / traitId filters.") } - isUniv <- tokens %in% c("susie", "susieInf", "susieAsh") + # Univariate RSS family = everything that isn't multivariate (mvsusie / + # fsusie): susie / susieInf / susieAsh / ser (and any future variant). + isUniv <- !(tokens %in% c("mvsusie", "fsusie")) univTokens <- tokens[isUniv] mvTokens <- tokens[tokens == "mvsusie"] @@ -1931,45 +1808,14 @@ setMethod("fineMappingPipeline", "QtlSumStats", ldMat <- .fmLdFromSketch(ldSketch, variantIds) names(z) <- variantIds - chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) - infFit <- NULL - if (chainLocal$runInf) { - if (verbose >= 1) - message(sprintf("Fitting susieInf (RSS) for (study='%s', context='%s', trait='%s') ...", st, ctx, tr)) - infFit <- .fmFitSusieRss(z, ldMat, n, "susieInf", - coverage = coverage, - userArgs = methodArgs[["susieInf"]]) - } - for (tk in toRun) { - if (tk == "susieInf") { - if (!chainLocal$keepInf) next - fit <- infFit - } else { - chainFrom <- if ((tk == "susie" && chainLocal$chainSusie) || - (tk == "susieAsh" && chainLocal$chainAsh)) - infFit else NULL - if (verbose >= 1) - message(sprintf("Fitting %s (RSS) for (study='%s', context='%s', trait='%s') ...", - tk, st, ctx, tr)) - fit <- .fmFitSusieRss(z, ldMat, n, tk, - chainFromInf = chainFrom, - coverage = coverage, - userArgs = methodArgs[[tk]]) - } - ent <- .fmPostprocessOne( - fit = fit, method = "susieRss", - dataX = ldMat, dataY = list(z = z), - coverage = coverage, - secondaryCoverage = secondaryCoverage, - signalCutoff = signalCutoff, - minAbsCorr = minAbsCorr, - af = afByVar, - csInput = "Xcorr") - # The method column on the FineMappingResult carries the bare - # token (susie / susieInf / susieAsh), independent of which - # postprocess class was used. - pushRow(st, ctx, tr, tk, ent) - } + ents <- .fmFitRssBlock( + z, ldMat, n, toRun, addSusieInf, coverage, secondaryCoverage, + signalCutoff, minAbsCorr, methodArgs, verbose, + label = sprintf("(study='%s', context='%s', trait='%s')", st, ctx, tr), + af = afByVar) + # The method column carries the bare token, independent of the + # postprocess class. + for (tk in names(ents)) pushRow(st, ctx, tr, tk, ents[[tk]]) } } @@ -2098,43 +1944,12 @@ setMethod("fineMappingPipeline", "GwasSumStats", ldMat <- .fmLdFromSketch(ldSketch, variantIds) names(z) <- variantIds - chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) - infFit <- NULL - if (chainLocal$runInf) { - if (verbose >= 1) - message(sprintf("Fitting susieInf (RSS) for GWAS (study='%s', region='%s') ...", - st, region_id)) - infFit <- .fmFitSusieRss(z, ldMat, n, "susieInf", - coverage = coverage, - userArgs = methodArgs[["susieInf"]]) - } - for (tk in toRun) { - if (tk == "susieInf") { - if (!chainLocal$keepInf) next - fit <- infFit - } else { - chainFrom <- if ((tk == "susie" && chainLocal$chainSusie) || - (tk == "susieAsh" && chainLocal$chainAsh)) - infFit else NULL - if (verbose >= 1) - message(sprintf("Fitting %s (RSS) for GWAS (study='%s', region='%s') ...", - tk, st, region_id)) - fit <- .fmFitSusieRss(z, ldMat, n, tk, - chainFromInf = chainFrom, - coverage = coverage, - userArgs = methodArgs[[tk]]) - } - ent <- .fmPostprocessOne( - fit = fit, method = "susieRss", - dataX = ldMat, dataY = list(z = z), - coverage = coverage, - secondaryCoverage = secondaryCoverage, - signalCutoff = signalCutoff, - minAbsCorr = minAbsCorr, - af = afByVar, - csInput = "Xcorr") - pushRow(st, tk, region_id, ent) - } + ents <- .fmFitRssBlock( + z, ldMat, n, toRun, addSusieInf, coverage, secondaryCoverage, + signalCutoff, minAbsCorr, methodArgs, verbose, + label = sprintf("GWAS (study='%s', region='%s')", st, region_id), + af = afByVar) + for (tk in names(ents)) pushRow(st, tk, region_id, ents[[tk]]) } .fmBuildGwasResult(rowStudy, rowMethod, rowEntries, diff --git a/R/fineMappingWrappers.R b/R/fineMappingWrappers.R index 814e2608..28bf8fb7 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -153,26 +153,24 @@ fitSusieInfThenSusie <- function(X, y, args = list(), susieInfArgs = list(), susieArgs = list(), fittedModels = NULL) { + # Two-stage chain built from the shared per-token fitter (.fmFitSusieIndiv), + # so the susieInf fit arguments and the susieInf -> susie initialisation live + # in one place rather than being duplicated here and in the pipeline. if (is.null(fittedModels)) fittedModels <- list() susieInfFit <- fittedModels[["susieInf"]] - susieFit <- fittedModels[["susie"]] - if (is.null(susieInfFit)) { - fitArgs <- modifyList(args, susieInfArgs) - fitArgs <- modifyList(fitArgs, list( - X = X, y = y, unmappable_effects = "inf", - convergence_method = "pip", refine = FALSE, model_init = NULL - )) - susieInfFit <- do.call(susie, fitArgs) + susieInfFit <- .fmFitSusieIndiv(X, y, "susieInf", + userArgs = modifyList(args, susieInfArgs)) + } else { + susieInfFit <- .setFinemappingFitClass(susieInfFit, "susieInf") } - susieInfFit <- .setFinemappingFitClass(susieInfFit, "susieInf") - + susieFit <- fittedModels[["susie"]] if (is.null(susieFit)) { - fitArgs <- prepareSusieFromInfArgs(modifyList(args, susieArgs), susieInfFit, refineDefault = TRUE) - susieFit <- do.call(susie, c(list(X = X, y = y), fitArgs)) + susieFit <- .fmFitSusieIndiv(X, y, "susie", chainFromInf = susieInfFit, + userArgs = modifyList(args, susieArgs)) + } else { + susieFit <- .setFinemappingFitClass(susieFit, "susie") } - susieFit <- .setFinemappingFitClass(susieFit, "susie") - list(susie = susieFit, susieInf = susieInfFit) } @@ -198,23 +196,20 @@ fitSusieInfThenSusieRss <- function(z, R, n, args = list(), susieInfArgs = list(), susieArgs = list(), fittedModels = NULL) { + # RSS analog of fitSusieInfThenSusie, built from the shared per-token RSS + # fitter (.fmFitSusieRss). .fmFitSusieRss tags every fit "susieRss", so the + # inf fit is re-tagged "susieInf" to preserve this wrapper's contract. if (is.null(fittedModels)) fittedModels <- list() susieInfFit <- fittedModels[["susieInf"]] - susieFit <- fittedModels[["susie"]] - if (is.null(susieInfFit)) { - fitArgs <- modifyList(args, susieInfArgs) - fitArgs <- modifyList(fitArgs, list( - z = z, R = R, n = n, unmappable_effects = "inf", - convergence_method = "pip", refine = FALSE, model_init = NULL - )) - susieInfFit <- do.call(susie_rss, fitArgs) + susieInfFit <- .fmFitSusieRss(z, R, n, "susieInf", + userArgs = modifyList(args, susieInfArgs)) } susieInfFit <- .setFinemappingFitClass(susieInfFit, "susieInf") - + susieFit <- fittedModels[["susie"]] if (is.null(susieFit)) { - fitArgs <- prepareSusieFromInfArgs(modifyList(args, susieArgs), susieInfFit, refineDefault = TRUE) - susieFit <- do.call(susie_rss, c(list(z = z, R = R, n = n), fitArgs)) + susieFit <- .fmFitSusieRss(z, R, n, "susie", chainFromInf = susieInfFit, + userArgs = modifyList(args, susieArgs)) } susieFit <- .setFinemappingFitClass(susieFit, "susieRss") @@ -1157,14 +1152,25 @@ fitFsusie <- function(X, Y, pos, ...) { # @param fit A susie fit object (or NULL to fit from X, y). # @param X Genotype matrix (optional). # @param y Phenotype vector (optional). +# Drop-intercept TWAS coefficient weights from a fitted SuSiE(-RSS) model +# (zero the intercept, then coef.susie without the intercept row). +# @noRd +.susieCoefWeights <- function(fit) { + fit$intercept <- 0 + coef.susie(fit)[-1] +} + # @param requiredFields Fields that must be present in the fit to extract weights. -# @param fitArgs Extra arguments passed to susieR::susie when fit is NULL. -# @param ... Additional arguments forwarded to susieR::susie. +# @param token SuSiE-family token ("susie" / "susieInf" / "susieAsh") selecting +# the unmappable_effects mode. The fit is delegated to .fmFitSusieIndiv so the +# package keeps a single susie-invocation point. +# @param userArgs Extra arguments forwarded to susieR::susie via .fmFitSusieIndiv. #' @importFrom susieR coef.susie susie #' @noRd -.susieExtractWeights <- function(fit, X, y, requiredFields, fitArgs = list(), retainFit = FALSE, ...) { +.susieExtractWeights <- function(fit, X, y, requiredFields, token = "susie", + userArgs = list(), retainFit = FALSE) { if (is.null(fit)) { - fit <- do.call(susie, c(list(X = X, y = y), fitArgs, list(...))) + fit <- .fmFitSusieIndiv(X, y, token, userArgs = userArgs) } if (!is.null(X) && length(fit$pip) != ncol(X)) { stop(paste0( @@ -1173,8 +1179,7 @@ fitFsusie <- function(X, Y, pos, ...) { )) } if (all(requiredFields %in% names(fit))) { - fit$intercept <- 0 - weights <- coef.susie(fit)[-1] + weights <- .susieCoefWeights(fit) } else { weights <- rep(0, length(fit$pip)) } @@ -1197,7 +1202,7 @@ fitFsusie <- function(X, Y, pos, ...) { susieWeights <- function(X = NULL, y = NULL, susieFit = NULL, retainFit = FALSE, ...) { .susieExtractWeights(susieFit, X, y, requiredFields = c("alpha", "mu", "X_column_scale_factors"), - retainFit = retainFit, ...) + token = "susie", userArgs = list(...), retainFit = retainFit) } #' Compute SuSiE-ASH TWAS weights @@ -1215,8 +1220,7 @@ susieWeights <- function(X = NULL, y = NULL, susieFit = NULL, retainFit = FALSE, susieAshWeights <- function(X = NULL, y = NULL, susieAshFit = NULL, retainFit = FALSE, ...) { .susieExtractWeights(susieAshFit, X, y, requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), - fitArgs = list(unmappable_effects = "ash", convergence_method = "pip"), - retainFit = retainFit, ...) + token = "susieAsh", userArgs = list(...), retainFit = retainFit) } #' Compute SuSiE-inf TWAS weights @@ -1245,18 +1249,17 @@ susieAshWeights <- function(X = NULL, y = NULL, susieAshFit = NULL, retainFit = susieInfWeights <- function(X = NULL, y = NULL, susieInfFit = NULL, retainFit = FALSE, ...) { .susieExtractWeights(susieInfFit, X, y, requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), - fitArgs = list(unmappable_effects = "inf", convergence_method = "pip"), - retainFit = retainFit, ...) + token = "susieInf", userArgs = list(...), retainFit = retainFit) } # Internal helper: extract weights from a susieRss fit. # Mirrors .susie_extract_weights but uses the RSS interface. #' @importFrom susieR coef.susie susie_rss #' @noRd .susieRssExtractWeights <- function(fit, z, R, n, - requiredFields, fitArgs = list(), - retainFit = FALSE) { + requiredFields, token = "susie", + userArgs = list(), retainFit = FALSE) { if (is.null(fit)) { - fit <- do.call(susie_rss, c(list(z = z, R = R, n = n), fitArgs)) + fit <- .fmFitSusieRss(z, R, n, token, userArgs = userArgs) } if (length(fit$pip) != nrow(R)) { stop(paste0( @@ -1264,8 +1267,7 @@ susieInfWeights <- function(X = NULL, y = NULL, susieInfFit = NULL, retainFit = " variants but R has ", nrow(R), " rows.")) } if (all(requiredFields %in% names(fit))) { - fit$intercept <- 0 - weights <- coef.susie(fit)[-1] + weights <- .susieCoefWeights(fit) } else { weights <- rep(0, length(fit$pip)) } @@ -1292,7 +1294,7 @@ susieRssWeights <- function(stat, LD, susieRssFit = NULL, retainFit = TRUE, methodArgs = list()) { .susieRssExtractWeights(fit = susieRssFit, z = stat$z, R = LD, n = median(stat$n), requiredFields = c("alpha", "mu", "X_column_scale_factors"), - fitArgs = methodArgs, + token = "susie", userArgs = methodArgs, retainFit = retainFit) } @@ -1309,7 +1311,7 @@ susieInfRssWeights <- function(stat, LD, susieInfRssFit = NULL, retainFit = TRUE methodArgs = list()) { .susieRssExtractWeights(fit = susieInfRssFit, z = stat$z, R = LD, n = median(stat$n), requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), - fitArgs = c(list(unmappable_effects = "inf", convergence_method = "pip"), methodArgs), + token = "susieInf", userArgs = methodArgs, retainFit = retainFit) } @@ -1326,7 +1328,7 @@ susieAshRssWeights <- function(stat, LD, susieAshRssFit = NULL, retainFit = TRUE methodArgs = list()) { .susieRssExtractWeights(fit = susieAshRssFit, z = stat$z, R = LD, n = median(stat$n), requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), - fitArgs = c(list(unmappable_effects = "ash", convergence_method = "pip"), methodArgs), + token = "susieAsh", userArgs = methodArgs, retainFit = retainFit) } #' Compute mvSuSiE TWAS weights @@ -1746,3 +1748,207 @@ mergeSusieCs <- function(fineMappingResult, coverage = 0.95) { rownames(combinedTopLociDf) <- NULL return(combinedTopLociDf) } + + +# ============================================================================= +# SuSiE-family fitters (single-fit wrappers + per-block dispatch) +# ----------------------------------------------------------------------------- +# Relocated here from fineMappingPipeline.R so all method-fitting wrappers live +# in one file, alongside fitMvsusie / fitFsusie / fitSusieInfThenSusie. +# `.fmFitSusie{Indiv,Rss,Ser}` each invoke a single susieR entry point; +# `.fmFit{X,Rss}Block` fit every requested token on one (X, y) / (z, R, n) +# block. They call orchestration helpers that remain in fineMappingPipeline.R +# (.fmResolveSusieChain / .fmPostprocessOne / .fmMergeUserArgs / +# .fineMappingMethodCapabilities); all resolve within the package namespace. +# ============================================================================= + +# Fit one of the SuSiE-family individual-level methods on (X, y). When +# `chainFromInf` is non-NULL, the susieInf fit it points at is used as +# initialisation (with prepareSusieFromInfArgs); otherwise a plain fit +# with the requested `unmappable_effects` is performed. `userArgs` are +# spliced via .fmMergeUserArgs (user wins over chain/base/capability +# defaults), so the caller can override things like L, max_iter, +# estimate_residual_method, refine, etc. +# @noRd +.fmFitSusieIndiv <- function(X, y, token, chainFromInf = NULL, + coverage = 0.95, userArgs = NULL) { + info <- .fineMappingMethodCapabilities[[token]] + if (is.null(info) || identical(info$unmappableEffects, NA_character_)) { + stop(".fmFitSusieIndiv: token '", token, "' is not a SuSiE-family method.") + } + baseArgs <- list(X = X, y = y, coverage = coverage, + unmappable_effects = info$unmappableEffects) + if (!is.null(chainFromInf) && token != "susieInf") { + # SuSiE(-ash) initialised from a SuSiE-inf fit. userArgs are folded into the + # arg prep (not merged afterwards) so L_greedy is clamped to + # min(#inf effects, L) rather than passed through raw. + chainedArgs <- prepareSusieFromInfArgs( + .fmMergeUserArgs(list(), token, userArgs), + chainFromInf, + refineDefault = if (token == "susie") TRUE else NULL, + unmappableEffects = if (token == "susieAsh") "ash" else "none") + baseArgs <- modifyList(baseArgs, chainedArgs) + baseArgs$X <- X; baseArgs$y <- y; baseArgs$coverage <- coverage + } else { + if (token == "susieInf") { + baseArgs$convergence_method <- "pip" + baseArgs$refine <- FALSE + baseArgs$model_init <- NULL + } else if (token == "susieAsh") { + baseArgs$convergence_method <- "pip" + } + baseArgs <- .fmMergeUserArgs(baseArgs, token, userArgs) + } + fit <- do.call(susieR::susie, baseArgs) + .setFinemappingFitClass(fit, token) +} + + +# Sumstat counterpart of .fmFitSusieIndiv. Calls susieR::susie_rss with +# the same unmappable_effects switch, chained init, and userArgs merge. +# @noRd +.fmFitSusieRss <- function(z, R, n, token, chainFromInf = NULL, + coverage = 0.95, userArgs = NULL) { + info <- .fineMappingMethodCapabilities[[token]] + if (is.null(info) || identical(info$unmappableEffects, NA_character_)) { + stop(".fmFitSusieRss: token '", token, "' is not a SuSiE-family method.") + } + baseArgs <- list(z = z, R = R, n = n, coverage = coverage, + unmappable_effects = info$unmappableEffects) + if (!is.null(chainFromInf) && token != "susieInf") { + # SuSiE-RSS(-ash) initialised from a SuSiE-inf fit; userArgs folded into the + # arg prep so L_greedy is clamped rather than passed through raw. + chainedArgs <- prepareSusieFromInfArgs( + .fmMergeUserArgs(list(), token, userArgs), + chainFromInf, + refineDefault = if (token == "susie") TRUE else NULL, + unmappableEffects = if (token == "susieAsh") "ash" else "none") + baseArgs <- modifyList(baseArgs, chainedArgs) + baseArgs$z <- z; baseArgs$R <- R; baseArgs$n <- n + baseArgs$coverage <- coverage + } else { + if (token == "susieInf") { + baseArgs$convergence_method <- "pip" + baseArgs$refine <- FALSE + baseArgs$model_init <- NULL + } else if (token == "susieAsh") { + baseArgs$convergence_method <- "pip" + } + baseArgs <- .fmMergeUserArgs(baseArgs, token, userArgs) + } + fit <- do.call(susieR::susie_rss, baseArgs) + # All susie_rss fits get the "susieRss" S3 class for post-processing + # (this drives the Xcorr cs-input mode). Token-level distinction stays + # in the `method` column of the FineMappingResult. + .setFinemappingFitClass(fit, "susieRss") +} + +# Single-effect (SER) sumstat fit via susieR::susie_ser on z + n. LD-free (no R, +# no L, no unmappable_effects), so it cannot reuse .fmFitSusieRss. Tagged +# "susieRss" so the shared post-processing (credible sets + purity against the +# LD sketch) applies unchanged. +# @noRd +.fmFitSusieSer <- function(z, n, coverage = 0.95, userArgs = NULL) { + baseArgs <- .fmMergeUserArgs(list(z = z, n = n, coverage = coverage), + "ser", userArgs) + .setFinemappingFitClass(do.call(susieR::susie_ser, baseArgs), "susieRss") +} + +# Fit every requested univariate token on one residualized (X, y) block, +# returning a named list (token -> FineMappingEntry). Extracted from the +# univariate dispatch so the same logic serves the cis path (one block), the +# jointRegions=TRUE path (one concatenated block) and the jointRegions=FALSE +# path (one block per region, merged afterwards via .fmMergeEntries). +.fmFitXBlock <- function(X, y, toRun, addSusieInf, coverage, + secondaryCoverage, signalCutoff, minAbsCorr, + methodArgs, verbose, ctx, tid, + cvFolds = 0, samplePartition = NULL, af = NULL) { + chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) + infFit <- NULL + if (chainLocal$runInf) { + if (verbose >= 1) + message(sprintf("Fitting susieInf for (context='%s', trait='%s') ...", + ctx, tid)) + infFit <- .fmFitSusieIndiv(X, y, "susieInf", coverage = coverage, + userArgs = methodArgs[["susieInf"]]) + } + out <- list() + for (tk in toRun) { + if (tk == "susieInf") { + if (!chainLocal$keepInf) next + fit <- infFit + } else { + chainFrom <- if ((tk == "susie" && chainLocal$chainSusie) || + (tk == "susieAsh" && chainLocal$chainAsh)) + infFit else NULL + if (verbose >= 1) + message(sprintf("Fitting %s for (context='%s', trait='%s') ...", + tk, ctx, tid)) + fit <- .fmFitSusieIndiv(X, y, tk, chainFromInf = chainFrom, + coverage = coverage, userArgs = methodArgs[[tk]]) + } + out[[tk]] <- .fmPostprocessOne( + fit = fit, method = tk, dataX = X, dataY = y, coverage = coverage, + secondaryCoverage = secondaryCoverage, signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, af = af, csInput = "X") + } + # Per-fold cross-validation across the fitted univariate methods; attach + # each method's out-of-fold predictions to its entry. + if (cvFolds > 1L && length(out) > 0L) { + if (verbose >= 1) + message(sprintf("Cross-validating (%d folds) for (context='%s', trait='%s') ...", + cvFolds, ctx, tid)) + cv <- .fmCrossValidate(X, y, names(out), methodArgs, cvFolds, + samplePartition = samplePartition, + coverage = coverage, verbose = verbose) + for (tk in names(out)) { + out[[tk]] <- .fmAttachCv(out[[tk]], .fmSliceCv(cv, tk)) + } + } + out +} + +# Fit every requested RSS token on one (z, R, n) sumstat block, returning a +# named list (token -> FineMappingEntry). The sumstat analog of .fmFitXBlock: +# the QtlSumStats and GwasSumStats methods both call it and differ only in how +# they push the returned entries (tuple shape) and the progress `label`. +.fmFitRssBlock <- function(z, R, n, toRun, addSusieInf, coverage, + secondaryCoverage, signalCutoff, minAbsCorr, + methodArgs, verbose, label, af = NULL) { + chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) + infFit <- NULL + if (chainLocal$runInf) { + if (verbose >= 1) + message(sprintf("Fitting susieInf (RSS) for %s ...", label)) + infFit <- .fmFitSusieRss(z, R, n, "susieInf", coverage = coverage, + userArgs = methodArgs[["susieInf"]]) + } + out <- list() + for (tk in toRun) { + if (tk == "susieInf") { + if (!chainLocal$keepInf) next + fit <- infFit + } else if (tk == "ser") { + # LD-free single-effect regression (susieR::susie_ser): z + n only, no R, + # no L, no chaining. + if (verbose >= 1) + message(sprintf("Fitting ser (RSS single-effect) for %s ...", label)) + fit <- .fmFitSusieSer(z, n, coverage = coverage, + userArgs = methodArgs[["ser"]]) + } else { + chainFrom <- if ((tk == "susie" && chainLocal$chainSusie) || + (tk == "susieAsh" && chainLocal$chainAsh)) + infFit else NULL + if (verbose >= 1) + message(sprintf("Fitting %s (RSS) for %s ...", tk, label)) + fit <- .fmFitSusieRss(z, R, n, tk, chainFromInf = chainFrom, + coverage = coverage, userArgs = methodArgs[[tk]]) + } + out[[tk]] <- .fmPostprocessOne( + fit = fit, method = "susieRss", dataX = R, dataY = list(z = z), + coverage = coverage, secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, minAbsCorr = minAbsCorr, af = af, + csInput = "Xcorr") + } + out +} diff --git a/R/genotypeIo.R b/R/genotypeIo.R index 4a047658..8ca39f63 100644 --- a/R/genotypeIo.R +++ b/R/genotypeIo.R @@ -51,10 +51,8 @@ setMethod("readGenotypes", snpInfo <- .gdsSnpInfo(path) - gds <- SNPRelate::snpgdsOpen(path, readonly = TRUE) - on.exit(SNPRelate::snpgdsClose(gds)) - sampleIds <- as.character(gdsfmt::read.gdsn( - gdsfmt::index.gdsn(gds, "sample.id"))) + sampleIds <- .withGds(path, function(gds) as.character(gdsfmt::read.gdsn( + gdsfmt::index.gdsn(gds, "sample.id")))) nSamples <- length(sampleIds) new("GenotypeHandle", @@ -325,20 +323,17 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { #' @keywords internal .extractBlockGds <- function(handle, snpIdx) { - gds <- SNPRelate::snpgdsOpen(getPath(handle), readonly = TRUE, - allow.fork = TRUE) - on.exit(SNPRelate::snpgdsClose(gds)) - - snpIds <- getSnpInfo(handle)$SNP[snpIdx] - # Use snpgdsGetGeno for proper non-contiguous SNP selection - geno <- SNPRelate::snpgdsGetGeno(gds, snp.id = snpIds, - with.id = FALSE, verbose = FALSE) - if (is.null(geno) || length(geno) == 0) return(NULL) - - # snpgdsGetGeno returns count of the first allele in snp.allele, - # which we label A1 in .gdsSnpInfo. No flip needed. - storage.mode(geno) <- "double" - geno + .withGds(getPath(handle), allow.fork = TRUE, fn = function(gds) { + snpIds <- getSnpInfo(handle)$SNP[snpIdx] + # Use snpgdsGetGeno for proper non-contiguous SNP selection + geno <- SNPRelate::snpgdsGetGeno(gds, snp.id = snpIds, + with.id = FALSE, verbose = FALSE) + if (is.null(geno) || length(geno) == 0) return(NULL) + # snpgdsGetGeno returns count of the first allele in snp.allele, + # which we label A1 in .gdsSnpInfo. No flip needed. + storage.mode(geno) <- "double" + geno + }) } #' @keywords internal @@ -445,20 +440,36 @@ computeBlockLdCor <- function(handle, snpIdx, backend = "internal", computeLd(geno, method = method, backend = backend, ...) } -#' @keywords internal -.computeBlockLdGds <- function(handle, snpIdx) { - gds <- SNPRelate::snpgdsOpen(getPath(handle), readonly = TRUE, - allow.fork = TRUE) +# Samples x variants dosage matrix for a genotype block: extract via the +# GenotypeHandle pipeline and transpose out of the Bioc variants x samples +# layout. The shared form of the t(assay(extractBlockGenotypes(...))) idiom. +# @noRd +.dosageMatrix <- function(handle, snpIdx, meanImpute = TRUE) { + t(SummarizedExperiment::assay( + extractBlockGenotypes(handle, snpIdx, meanImpute = meanImpute), "dosage")) +} + +# Open a GDS read-only, guarantee it is closed on exit, and return fn(gds). +# The shared form of the snpgdsOpen(...) + on.exit(snpgdsClose(gds)) idiom +# used across the GDS readers. +# @noRd +.withGds <- function(path, fn, readonly = TRUE, allow.fork = FALSE) { + gds <- SNPRelate::snpgdsOpen(path, readonly = readonly, allow.fork = allow.fork) on.exit(SNPRelate::snpgdsClose(gds)) + fn(gds) +} - snpIds <- getSnpInfo(handle)$SNP[snpIdx] - ldMat <- SNPRelate::snpgdsLDMat( - gds, snp.id = snpIds, method = "corr", - slide = -1, verbose = FALSE - ) - R <- ldMat$LD - R[is.na(R)] <- 0 - R +#' @keywords internal +.computeBlockLdGds <- function(handle, snpIdx) { + .withGds(getPath(handle), allow.fork = TRUE, fn = function(gds) { + snpIds <- getSnpInfo(handle)$SNP[snpIdx] + ldMat <- SNPRelate::snpgdsLDMat( + gds, snp.id = snpIds, method = "corr", + slide = -1, verbose = FALSE) + R <- ldMat$LD + R[is.na(R)] <- 0 + R + }) } # ============================================================================= @@ -512,28 +523,24 @@ computeBlockLdCor <- function(handle, snpIdx, backend = "internal", #' @keywords internal .gdsSnpInfo <- function(gdsPath) { - gds <- SNPRelate::snpgdsOpen(gdsPath, readonly = TRUE) - on.exit(SNPRelate::snpgdsClose(gds)) - - snpId <- gdsfmt::read.gdsn(gdsfmt::index.gdsn(gds, "snp.id")) - chr <- gdsfmt::read.gdsn(gdsfmt::index.gdsn(gds, "snp.chromosome")) - pos <- gdsfmt::read.gdsn(gdsfmt::index.gdsn(gds, "snp.position")) - allele <- gdsfmt::read.gdsn(gdsfmt::index.gdsn(gds, "snp.allele")) - - allelesSplit <- strsplit(allele, "/") - # snpgdsGetGeno counts copies of the first allele in snp.allele. - # Label the first allele as A1 so dosage = count of A1. - a1 <- vapply(allelesSplit, `[`, character(1), 1L) - a2 <- vapply(allelesSplit, `[`, character(1), 2L) - - data.frame( - SNP = snpId, - CHR = as.character(chr), - BP = as.integer(pos), - A1 = a1, - A2 = a2, - stringsAsFactors = FALSE - ) + .withGds(gdsPath, function(gds) { + snpId <- gdsfmt::read.gdsn(gdsfmt::index.gdsn(gds, "snp.id")) + chr <- gdsfmt::read.gdsn(gdsfmt::index.gdsn(gds, "snp.chromosome")) + pos <- gdsfmt::read.gdsn(gdsfmt::index.gdsn(gds, "snp.position")) + allele <- gdsfmt::read.gdsn(gdsfmt::index.gdsn(gds, "snp.allele")) + allelesSplit <- strsplit(allele, "/") + # snpgdsGetGeno counts copies of the first allele in snp.allele. + # Label the first allele as A1 so dosage = count of A1. + a1 <- vapply(allelesSplit, `[`, character(1), 1L) + a2 <- vapply(allelesSplit, `[`, character(1), 2L) + data.frame( + SNP = snpId, + CHR = as.character(chr), + BP = as.integer(pos), + A1 = a1, + A2 = a2, + stringsAsFactors = FALSE) + }) } #' @title Detect File Format from Extension @@ -1038,9 +1045,8 @@ loadGenotypeRegion <- function(genotype, region = NULL, keepIndel = TRUE, } # --- Extract genotypes (no mean imputation — callers handle missing) --- - rse <- extractBlockGenotypes(handle, snpIdx, meanImpute = FALSE) - # Convert RSE to samples x variants matrix for pecotmr convention - X <- t(assay(rse, "dosage")) + # Samples x variants matrix (pecotmr convention); callers handle missing. + X <- .dosageMatrix(handle, snpIdx, meanImpute = FALSE) variantInfo <- .snpInfoToVariantInfo( handleSnpInfo[snpIdx, , drop = FALSE]) diff --git a/R/gwasSumStats.R b/R/gwasSumStats.R index 73088d41..747cafe8 100644 --- a/R/gwasSumStats.R +++ b/R/gwasSumStats.R @@ -185,27 +185,7 @@ setMethod("getSumStats", signature(x = "GwasSumStats"), } ) -#' @rdname getZ -#' @export -setMethod("getZ", "GwasSumStats", function(x, study = NULL) { - gr <- getSumStats(x, study = study) - mcols(gr)$Z -}) - -#' @rdname getN -#' @export -setMethod("getN", "GwasSumStats", function(x, study = NULL) { - gr <- getSumStats(x, study = study) - mcols(gr)$N -}) - -#' @rdname getMaf -#' @export -setMethod("getMaf", "GwasSumStats", function(x, study = NULL, ...) { - gr <- getSumStats(x, study = study) - mc <- mcols(gr) - if ("MAF" %in% colnames(mc)) mc$MAF else NULL -}) +# getZ / getN / getMaf / nSnps are provided once by SumStatsBase (AllClasses.R). #' @rdname getSumstatDf #' @export @@ -225,17 +205,10 @@ setMethod("getSumstatDf", "GwasSumStats", else study)) }) -#' @rdname nSnps -#' @export -setMethod("nSnps", "GwasSumStats", function(x, study = NULL) { - gr <- getSumStats(x, study = study) - length(gr) -}) - #' @rdname subsetChr #' @export setMethod("subsetChr", "GwasSumStats", function(x, chr) { - chrName <- paste0("chr", sub("^chr", "", as.character(chr))) + chrName <- withChrPrefix(chr) newEntries <- lapply(seq_len(nrow(x)), function(i) { gr <- x$entry[[i]] idx <- as.character(seqnames(gr)) == chrName diff --git a/R/h2Annotations.R b/R/h2Annotations.R index 4d40456f..c3d7c4df 100644 --- a/R/h2Annotations.R +++ b/R/h2Annotations.R @@ -175,7 +175,7 @@ setMethod("readAnnotations", # Build GRanges from the annot file positions annotGr <- GRanges( - seqnames = paste0("chr", sub("^chr", "", dt$CHR)), + seqnames = withChrPrefix(dt$CHR), ranges = IRanges(start = dt$BP, width = 1L) ) diff --git a/R/h2EstimationWrappers.R b/R/h2EstimationWrappers.R index 46d96492..60eeadbe 100644 --- a/R/h2EstimationWrappers.R +++ b/R/h2EstimationWrappers.R @@ -202,7 +202,7 @@ computeBaselineEnrichment <- function(tau, tauSe, tauBlocks, # P-value from z-score enrichmentZ <- enrichment / enrichmentSe - enrichmentP <- 2 * pnorm(-abs(enrichmentZ)) + enrichmentP <- .zToPvalue(enrichmentZ) data.frame( annotation = annotNames, @@ -679,21 +679,20 @@ lderUnivariate <- function(z, n, eigenRef, annotations = NULL, R <- matrix(1, 1, 1) } - candMeta <- getAnnotationMeta(candidateAnnot) - enrichmentDf <- data.frame( - annotation = candMeta$name, - scoreZ = scoreZ, - scoreP = 2 * pnorm(-abs(scoreZ)), - stringsAsFactors = FALSE - ) - - scoreStatsList <- list( - z = scoreZ, - R = R, - annotationNames = candMeta$name - ) + .buildEnrichmentResult(getAnnotationMeta(candidateAnnot), scoreZ, R) +} - list(enrichment = enrichmentDf, scoreStats = scoreStatsList) +# Assemble the enrichment result shared by the h2 enrichment helpers: a +# per-annotation table (z + two-tailed p) plus the scoreStats bundle +# (z, R, annotation names) consumed downstream. +.buildEnrichmentResult <- function(candMeta, scoreZ, R) { + list( + enrichment = data.frame( + annotation = candMeta$name, + scoreZ = scoreZ, + scoreP = .zToPvalue(scoreZ), + stringsAsFactors = FALSE), + scoreStats = list(z = scoreZ, R = R, annotationNames = candMeta$name)) } @@ -1115,19 +1114,7 @@ gldscUnivariate <- function(z, n, ldRef, annotations = NULL, R <- matrix(1, 1, 1) } - candMeta <- getAnnotationMeta(candidate) - list( - enrichment = data.frame( - annotation = candMeta$name, - scoreZ = scoreZ, - scoreP = 2 * pnorm(-abs(scoreZ)), - stringsAsFactors = FALSE - ), - scoreStats = list( - z = scoreZ, R = R, - annotationNames = candMeta$name - ) - ) + .buildEnrichmentResult(getAnnotationMeta(candidate), scoreZ, R) } @@ -1536,17 +1523,7 @@ hdlUnivariate <- function(z, n, eigenRef, annotations = NULL, R <- diag(nCand) } - candMeta <- getAnnotationMeta(candidate) - list( - enrichment = data.frame( - annotation = candMeta$name, - scoreZ = scoreZ, - scoreP = 2 * pnorm(-abs(scoreZ)), - stringsAsFactors = FALSE - ), - scoreStats = list(z = scoreZ, R = R, - annotationNames = candMeta$name) - ) + .buildEnrichmentResult(getAnnotationMeta(candidate), scoreZ, R) } diff --git a/R/jointSpecification.R b/R/jointSpecification.R index f0a73f71..b46d5575 100644 --- a/R/jointSpecification.R +++ b/R/jointSpecification.R @@ -853,14 +853,72 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { }) .fmMergeEntries(Filter(Negate(is.null), perRegion)) }) - QtlFineMappingResult( - study = as.character(base$study), context = as.character(base$context), - trait = as.character(base$trait), method = as.character(base$method), - entry = mergedEntries, - jointStudies = if ("jointStudies" %in% names(base)) base$jointStudies else NULL, - jointContexts = if ("jointContexts" %in% names(base)) base$jointContexts else NULL, - jointTraits = if ("jointTraits" %in% names(base)) base$jointTraits else NULL, - ldSketch = NULL) + do.call(QtlFineMappingResult, c( + list(study = as.character(base$study), context = as.character(base$context), + trait = as.character(base$trait), method = as.character(base$method), + entry = mergedEntries), + .jointCols(base), + list(ldSketch = NULL))) +} + +# The three optional joint-key columns (jointStudies / jointContexts / +# jointTraits) of a per-tuple result row, as a named list (NULL for any absent +# column). Spliced into the QtlFineMappingResult / TwasWeights constructors. +.jointCols <- function(df) { + pick <- function(nm) if (nm %in% names(df)) as.character(df[[nm]]) else NULL + list(jointStudies = pick("jointStudies"), + jointContexts = pick("jointContexts"), + jointTraits = pick("jointTraits")) +} + +# Shared tail of the MultiStudyQtlDataset fineMapping / twasWeights pipeline +# methods: recurse into each embedded QtlDataset then the embedded QtlSumStats, +# row-bind the per-study results, build the per-tuple result object, and combine +# it with any joint-specification result. `perStudyFn` / `sumStatsFn` are the +# (method-specific) single-study recursions; `rbindFn` / `resultCtor` / +# `pipelineName` supply the per-pipeline pieces. Each method keeps its own +# (divergent) method-gating / joint-dispatch preamble and passes the computed +# `jointResult` in. +# @noRd +.multiStudyPipelineDriver <- function(data, jointResult, perStudyFn, sumStatsFn, + rbindFn, resultCtor, pipelineName, + noun = "a result") { + qtlDatasets <- getQtlDatasets(data) + sumStats <- getSumStats(data) + out <- NULL + embeddedLd <- NULL + for (qdName in names(qtlDatasets)) { + res <- perStudyFn(qtlDatasets[[qdName]]) + if (!is.null(res)) + out <- if (is.null(out)) res else rbindFn(out, res, ldSketch = NULL) + } + if (!is.null(sumStats)) { + ssRes <- sumStatsFn(sumStats) + if (!is.null(ssRes)) { + embeddedLd <- getLdSketch(ssRes) + out <- if (is.null(out)) ssRes else rbindFn(out, ssRes, ldSketch = embeddedLd) + } + } + perTupleResult <- if (!is.null(out)) { + # ldSketch: NULL if all studies were individual-level; the embedded + # sumStats's ldSketch otherwise. + do.call(resultCtor, c( + list(study = as.character(out$study), + context = as.character(out$context), + trait = as.character(out$trait), + method = as.character(out$method), + entry = as.list(out$entry)), + .jointCols(out), + list(ldSketch = embeddedLd))) + } else NULL + if (is.null(jointResult)) { + if (is.null(perTupleResult)) + stop(sprintf("%s(MultiStudyQtlDataset): no entries produced %s.", + pipelineName, noun)) + return(perTupleResult) + } + if (is.null(perTupleResult)) return(jointResult) + rbindFn(perTupleResult, jointResult, ldSketch = embeddedLd) } # Synthesize a jointSpecification for the AUTO-DETECTION path (no explicit diff --git a/R/mashPipeline.R b/R/mashPipeline.R index 0cf339a7..a0646459 100644 --- a/R/mashPipeline.R +++ b/R/mashPipeline.R @@ -304,7 +304,7 @@ fitMashContrast <- function(index, origMean, posteriorMean, posteriorVcov, contrastDiff <- drop(t(contrastDesign) %*% pm) contrastVcov <- t(contrastDesign) %*% pv %*% contrastDesign contrastSe <- sqrt(diag(contrastVcov)) - contrastP <- 2 * (1 - pnorm(abs(contrastDiff) / contrastSe)) + contrastP <- .zToPvalue(contrastDiff / contrastSe) # Build output data.frame cnames <- colnames(contrastDesign) @@ -477,7 +477,7 @@ metaAnalysisPerCell <- function(effectSizes, seValues, cell = cell, condition = cellConditions[i], meta_pvalue = if (length(es) == 1) { - 2 * pnorm(abs(es / se), lower.tail = FALSE) + .zToPvalue(es / se) } else NA_real_, meta_effect = if (length(es) == 1) es else NA_real_, meta_se = if (length(es) == 1) se else NA_real_, @@ -492,7 +492,7 @@ metaAnalysisPerCell <- function(effectSizes, seValues, results[[length(results) + 1]] <- tibble( cell = cell, condition = cellConditions[i], - meta_pvalue = 2 * pnorm(abs(z), lower.tail = FALSE), + meta_pvalue = .zToPvalue(z), meta_effect = ma$mean, meta_se = ma$se, tau2 = ma$tau2, diff --git a/R/pvalCombine.R b/R/pvalCombine.R index 7445b12d..f12131d1 100644 --- a/R/pvalCombine.R +++ b/R/pvalCombine.R @@ -8,6 +8,25 @@ #' @importFrom magrittr %>% NULL +# Internal: two-tailed normal p-value from a signed Z. The single shared helper +# across the sumstats-QC, TWAS, h2, mash and S-LDSC paths. Uses the numerically +# stable 2 * pnorm(-|z|) form (1 - pnorm(|z|) underflows earlier at large |z|). +# Returns NA where z is NA; |z| > ~37 underflows to 0 (R's pnorm limit). +# @noRd +.zToPvalue <- function(z) 2 * pnorm(-abs(z)) + +# Derive effect size + standard error from a signed Z, allele frequency (maf), +# and sample size (n) for a standardized phenotype, using the model-exact +# relationship se = 1 / sqrt(2*maf*(1-maf)*(n + z^2)), beta = z * se. The +# (n + z^2) term accounts for the residual-variance reduction from the SNP's own +# effect (residual = n/(n + z^2)); dropping z^2 is the weak-effect limit. Shared +# by the RAISS imputation (summaryStatsQc) and the CIP MR helpers. +# @noRd +.zToBetaSe <- function(z, maf, n) { + se <- 1 / sqrt(2 * maf * (1 - maf) * (n + z * z)) + list(beta = z * se, se = se) +} + #' @export waldTestPval <- function(beta, se, n) { # Calculate the t statistic diff --git a/R/qtlSumStats.R b/R/qtlSumStats.R index 2e844bca..6cbb1d93 100644 --- a/R/qtlSumStats.R +++ b/R/qtlSumStats.R @@ -168,33 +168,8 @@ setMethod("getSumStats", signature(x = "QtlSumStats"), } ) -#' @rdname getZ -#' @export -setMethod("getZ", "QtlSumStats", - function(x, study = NULL, context = NULL, trait = NULL) { - gr <- getSumStats(x, study = study, context = context, trait = trait) - mcols(gr)$Z - } -) - -#' @rdname getN -#' @export -setMethod("getN", "QtlSumStats", - function(x, study = NULL, context = NULL, trait = NULL) { - gr <- getSumStats(x, study = study, context = context, trait = trait) - mcols(gr)$N - } -) - -#' @rdname getMaf -#' @export -setMethod("getMaf", "QtlSumStats", - function(x, study = NULL, context = NULL, trait = NULL, ...) { - gr <- getSumStats(x, study = study, context = context, trait = trait) - mc <- mcols(gr) - if ("MAF" %in% colnames(mc)) mc$MAF else NULL - } -) +# getZ / getN / getMaf / nSnps are provided once by SumStatsBase (AllClasses.R); +# they only delegate to getSumStats(). #' @rdname getSumstatDf #' @export @@ -217,19 +192,10 @@ setMethod("getSumstatDf", "QtlSumStats", } ) -#' @rdname nSnps -#' @export -setMethod("nSnps", "QtlSumStats", - function(x, study = NULL, context = NULL, trait = NULL) { - gr <- getSumStats(x, study = study, context = context, trait = trait) - length(gr) - } -) - #' @rdname subsetChr #' @export setMethod("subsetChr", "QtlSumStats", function(x, chr) { - chrName <- paste0("chr", sub("^chr", "", as.character(chr))) + chrName <- withChrPrefix(chr) newEntries <- lapply(seq_len(nrow(x)), function(i) { gr <- x$entry[[i]] idx <- as.character(seqnames(gr)) == chrName diff --git a/R/regularizedRegressionWrappers.R b/R/regularizedRegressionWrappers.R index bcc51b1c..0aa7a598 100644 --- a/R/regularizedRegressionWrappers.R +++ b/R/regularizedRegressionWrappers.R @@ -18,7 +18,7 @@ mrAshRssWeights <- function(stat, LD, varY, sigma2E, s0, w0, z = numeric(0), ... #' and infers posterior SNP effect sizes using Bayesian regression with continuous shrinkage priors. #' #' @param bhat A vector of marginal effect sizes. -#' @param LD A list of LD blocks, where each element is a matrix representing an LD block. +#' @param R The LD correlation matrix (a single matrix over the analysed window), as in \code{susieR::susie_rss()}. #' @param n Sample size of the GWAS. #' @param a Shape parameter for the prior distribution of psi. Default is 1. #' @param b Scale parameter for the prior distribution of psi. Default is 0.5. @@ -73,39 +73,25 @@ mrAshRssWeights <- function(stat, LD, varY, sigma2E, s0, w0, z = numeric(0), ... #' #' # Run PRS CS #' maf <- rep(0.5, length(b.hat)) # fake MAF -#' LD <- list(blk1 = R.hat) -#' out <- prsCs(b.hat, LD, n, maf = maf) +#' out <- prsCs(b.hat, R.hat, n, maf = maf) #' # In sample prediction correlations #' cor(X %*% out$betaEst, y) # 0.9944553 #' @export -prsCs <- function(bhat, LD, n, +prsCs <- function(bhat, R, n, a = 1, b = 0.5, phi = NULL, maf = NULL, nIter = 1000, nBurnin = 500, thin = 5, verbose = FALSE, seed = NULL) { - # Check input parameters - if (missing(LD) || !is.list(LD)) { - stop("Please provide a valid list of LD blocks using 'LD'.") - } - if (missing(n) || n <= 0) { - stop("Please provide a valid sample size using 'n'.") - } - - # Check if maf is provided and its length matches that of bhat + # Shared LD-matrix validation, then the prsCs-specific maf length check. + .rssValidateInputs(bhat, R, n) if (!is.null(maf) && length(bhat) != length(maf)) { stop("The length of 'bhat' must be the same as 'maf'.") } - # Check if the length of bhat matches the sum of the nrow of all elements in the LD list - totalRowsInLd <- sum(sapply(LD, nrow)) - if (length(bhat) != totalRowsInLd) { - stop("The length of 'bhat' must be the same as the sum of the number of rows of all elements in the 'LD' list.") - } - # Run PRS-CS # cpp11 requires exact integer types for int parameters result <- prsCsRcpp( a = a, b = b, phi = phi, bhat = bhat, maf = maf, - n = as.integer(n), ldBlk = LD, + n = as.integer(n), ldBlk = list(blk1 = R), nIter = as.integer(nIter), nBurnin = as.integer(nBurnin), thin = as.integer(thin), verbose = verbose, seed = seed ) @@ -123,7 +109,7 @@ prsCs <- function(bhat, LD, n, #' @return A numeric vector of the posterior SNP coefficients. #' @export prsCsWeights <- function(stat, LD, ...) { - model <- prsCs(bhat = stat$b, LD = list(blk1 = LD), n = median(stat$n), ...) + model <- prsCs(bhat = stat$b, R = LD, n = median(stat$n), ...) return(model$betaEst) } @@ -134,7 +120,7 @@ prsCsWeights <- function(stat, LD, ...) { #' for estimating effect sizes and heritability based on summary statistics and reference LD matrices. #' #' @param bhat A vector of marginal beta values for each SNP. -#' @param LD A list of LD matrices, where each matrix corresponds to a subset of SNPs. +#' @param R The LD correlation matrix (a single matrix over the analysed window). #' @param n The total sample size of the GWAS. #' @param perVariantSampleSize (Optional) A vector of sample sizes for each SNP. If NULL (default), it will be initialized #' to a vector of length equal to `bhat`, with all values set to `n`. @@ -192,8 +178,7 @@ prsCsWeights <- function(stat, LD, ...) { #' sigmasq_init <- 1.5 #' #' # Run SDPR -#' LD <- list(blk1 = R.hat) -#' out <- sdpr(b.hat, LD, n) +#' out <- sdpr(b.hat, R.hat, n) #' # In sample prediction correlations #' cor(X %*% out$betaEst, y) # #' @@ -202,18 +187,10 @@ prsCsWeights <- function(stat, LD, ...) { #' https://htmlpreview.github.io/?https://github.com/eldronzhou/SDPR/blob/main/doc/Manual.html #' #' @export -sdpr <- function(bhat, LD, n, perVariantSampleSize = NULL, array = NULL, a = 0.1, c = 1.0, M = 1000, +sdpr <- function(bhat, R, n, perVariantSampleSize = NULL, array = NULL, a = 0.1, c = 1.0, M = 1000, a0k = 0.5, b0k = 0.5, iter = 1000, burn = 200, thin = 5, nThreads = 1, optLlk = 1, verbose = TRUE, seed = NULL) { - # Check if the sum of the rows in LD list is the same as length of bhat - if (sum(sapply(LD, nrow)) != length(bhat)) { - stop("The sum of the rows in LD list must be the same as the length of bhat.") - } - - # Check if total sample size n is a positive integer - if (missing(n) || n <= 0) { - stop("The total sample size 'n' must be a positive integer.") - } + .rssValidateInputs(bhat, R, n) # M must be >= 4 (SDPR uses M-2 indexing in sample_V; M < 4 causes buffer overflow) if (M < 4) { @@ -233,8 +210,9 @@ sdpr <- function(bhat, LD, n, perVariantSampleSize = NULL, array = NULL, a = 0.1 # cpp11 requires exact integer types for int parameters and sexp-wrapped vectors if (!is.null(array)) array <- as.integer(array) # Call the sdprRcpp function + # C++ backend takes a block list; wrap the single-window matrix R as one block. result <- sdprRcpp( - bhatR = bhat, LD = LD, n = as.integer(n), + bhatR = bhat, LD = list(blk1 = R), n = as.integer(n), perVariantSampleSize = perVariantSampleSize, array = array, a = a, c = c, M = as.integer(M), a0k = a0k, b0k = b0k, @@ -250,7 +228,7 @@ sdpr <- function(bhat, LD, n, perVariantSampleSize = NULL, array = NULL, a = 0.1 #' @return A numeric vector of the posterior SNP coefficients. #' @export sdprWeights <- function(stat, LD, ...) { - model <- sdpr(bhat = stat$b, LD = list(blk1 = LD), n = median(stat$n), ...) + model <- sdpr(bhat = stat$b, R = LD, n = median(stat$n), ...) return(model$betaEst) } @@ -294,24 +272,30 @@ mrmashWeights <- function(mrmashFit = NULL, X = NULL, Y = NULL, mrmashFit <- mrmashWrapper(X, Y, ...) } out <- mr.mashr::coef.mr.mash(mrmashFit)[-1, ] - if (isTRUE(retainFit)) { - fitDetail <- match.arg(fitDetail) - # Reconstruction inputs for the mvSuSiE data-driven prior (see the - # mvSuSiE-prior-from-mr.mash note): the original matrices (required for - # bit-identical results -- rescaleCovW0(w0) collapses the expanded weights - # back onto them), w0, and V. mu1 is already returned as `out`, so "slim" - # does not duplicate it; "full" additionally keeps the whole fit. - fitList <- list( - dataDrivenPriorMatrices = dotArgs$dataDrivenPriorMatrices, - w0 = mrmashFit$w0, - V = mrmashFit$V) - if (fitDetail == "full") fitList$fit <- mrmashFit - attr(out, "fit") <- fitList - } - out + # mu1 (= out) is already the returned weights; the payload carries only the + # mvSuSiE data-driven-prior reconstruction inputs (w0, V, and the raw prior + # matrices), plus the whole fit when fitDetail = "full". + .mrmashAttachFit(out, mrmashFit, dotArgs$dataDrivenPriorMatrices, + retainFit, fitDetail) } +# Attach the mvSuSiE-prior reconstruction payload as the "fit" attribute, +# shared by mrmashWeights (individual) and mrmashRssWeights (summary stats): +# the data-driven prior matrices + fitted w0 + V, and -- when fitDetail = +# "full" -- the whole fit. The coefficients are already the returned `weights`, +# so mu1 is not duplicated. Returns `weights` unchanged unless retainFit is TRUE. +.mrmashAttachFit <- function(weights, fit, dataDrivenPriorMatrices, + retainFit, fitDetail = c("slim", "full")) { + if (!isTRUE(retainFit)) return(weights) + fitDetail <- match.arg(fitDetail) + fitList <- list(dataDrivenPriorMatrices = dataDrivenPriorMatrices, + w0 = fit$w0, V = fit$V) + if (fitDetail == "full") fitList$fit <- fit + attr(weights, "fit") <- fitList + weights +} + #' Compute mr.mash-RSS TWAS weights from summary statistics #' #' Multi-context summary-statistics analog of \code{\link{mrmashWeights}}: @@ -416,19 +400,8 @@ mrmashRssWeights <- function(stat, LD, mrmashRssFit = NULL, } # coef.mr.mash.rss returns nrow(Bhat) rows (no intercept). Do not strip. weights <- mr.mashr::coef.mr.mash.rss(mrmashRssFit) - if (retainFit) { - fitDetail <- match.arg(fitDetail) - # Mirror mrmashWeights(): the slim payload carries only the mvSuSiE-prior - # reconstruction inputs (the coefficients are already `weights`, so mu1 is - # not duplicated); "full" additionally keeps the whole mr.mash.rss fit. - fitList <- list( - dataDrivenPriorMatrices = dataDrivenPriorMatrices, - w0 = mrmashRssFit$w0, - V = mrmashRssFit$V) - if (fitDetail == "full") fitList$fit <- mrmashRssFit - attr(weights, "fit") <- fitList - } - weights + .mrmashAttachFit(weights, mrmashRssFit, dataDrivenPriorMatrices, + retainFit, fitDetail) } @@ -900,7 +873,7 @@ bayesRWeights <- function(X, y, Z = NULL, ...) { #' Genetic Epidemiology 41(6):469-480. #' #' @param bhat A vector of marginal effect sizes. -#' @param LD A list of LD blocks, where each element is a matrix representing an LD block. +#' @param R The LD correlation matrix (a single matrix over the analysed window), as in \code{susieR::susie_rss()}. #' If shrinkage is desired, apply it before passing (e.g., \code{(1-s)*R + s*I}). #' @param n Sample size of the GWAS. #' @param lambda A vector of L1 penalty values. Default: 20 values from 0.001 to 0.1 on log scale. @@ -926,41 +899,16 @@ bayesRWeights <- function(X, y, Z = NULL, ...) { #' R[i, i + 1] <- 0.3 #' R[i + 1, i] <- 0.3 #' } -#' LD <- list(blk1 = R) -#' out <- lassosumRss(bhat, LD, n) +#' out <- lassosumRss(bhat, R, n) #' @export -lassosumRss <- function(bhat, LD, n, +lassosumRss <- function(bhat, R, n, lambda = exp(seq(log(0.0001), log(0.1), length.out = 20)), thr = 1e-4, maxiter = 10000) { - if (!is.list(LD)) { - stop("Please provide a valid list of LD blocks using 'LD'.") - } - if (missing(n) || n <= 0) { - stop("Please provide a valid sample size using 'n'.") - } - totalRowsInLd <- sum(sapply(LD, nrow)) - if (length(bhat) != totalRowsInLd) { - stop("The length of 'bhat' must be the same as the sum of the number of rows of all elements in the 'LD' list.") - } - - z <- bhat / sqrt(n) - order <- order(lambda, decreasing = TRUE) - # cpp11 requires exact integer types for int parameters - result <- lassosumRssRcpp(zR = z, LD = LD, lambdaR = lambda[order], - thr = thr, maxiter = as.integer(maxiter)) - - # Reorder back to original lambda order. - # Must use inverse permutation to unsort: if order[i]=j, then - # the result at position j in the sorted output goes to position i. - invOrder <- order(order) - result$beta <- result$beta[, invOrder, drop = FALSE] - result$conv <- result$conv[invOrder] - result$loss <- result$loss[invOrder] - result$fbeta <- result$fbeta[invOrder] - result$lambda <- lambda - result$nparams <- as.integer(colSums(result$beta != 0)) - result$betaEst <- as.numeric(result$beta[, which.min(result$fbeta)]) - result + # cpp11 requires exact integer types; the C++ backend takes a block list, so + # the single-window matrix R is wrapped as one block here. + .rssSolvePath(bhat, R, n, lambda, function(z, lam) + lassosumRssRcpp(zR = z, LD = list(blk1 = R), lambdaR = lam, + thr = thr, maxiter = as.integer(maxiter))) } .lassosumCorFromStat <- function(stat, n, p) { @@ -1016,6 +964,80 @@ lassosumRss <- function(bhat, LD, n, ) } +# Validate the (bhat, R, n) inputs shared by the RSS solvers (lassosumRss / +# penalizedRss via .rssSolvePath, prsCs, and sdpr). R is a single LD correlation +# matrix over one cis-window, matching susieR::susie_rss; bhat must match +# nrow(R). missing() guards turn an omitted R / n into a clear message instead +# of an "argument is missing" error, and propagate through the public wrappers +# (verified two levels deep). Method-specific checks -- prsCs's maf length, +# sdpr's M / perVariantSampleSize / array -- stay in the caller. +.rssValidateInputs <- function(bhat, R, n) { + if (missing(R) || !is.matrix(R)) { + stop("Please provide the LD correlation matrix 'R' as a matrix.") + } + if (missing(n) || n <= 0) { + stop("Please provide a valid sample size using 'n'.") + } + if (length(bhat) != nrow(R)) { + stop("The length of 'bhat' must equal the number of rows of 'R'.") + } + invisible(NULL) +} + +# Validate (bhat, LD, n), run a decreasing-lambda coordinate-descent sweep via +# `solveFn` (the penalty-specific Rcpp backend), then reorder back to the input +# lambda order via the inverse permutation and assemble the standard result +# list. Shared by lassosumRss and penalizedRss, which differ only in which Rcpp +# solver they pass as `solveFn` (and penalizedRss's per-penalty gamma default). +.rssSolvePath <- function(bhat, R, n, lambda, solveFn) { + .rssValidateInputs(bhat, R, n) + z <- bhat / sqrt(n) + order <- order(lambda, decreasing = TRUE) + result <- solveFn(z, lambda[order]) + # Reorder back to original lambda order via the inverse permutation. + invOrder <- order(order) + result$beta <- result$beta[, invOrder, drop = FALSE] + result$conv <- result$conv[invOrder] + result$loss <- result$loss[invOrder] + result$fbeta <- result$fbeta[invOrder] + result$lambda <- lambda + result$nparams <- as.integer(colSums(result$beta != 0)) + result$betaEst <- as.numeric(result$beta[, which.min(result$fbeta)]) + result +} + +# Shared scaffold for the RSS shrinkage-grid weight functions +# (lassosumRssWeights / .penalizedRssWeights / l0learnRssWeights). Standardizes +# the stat -> solverInput conversion, the outer LD-shrinkage grid over `s`, the +# candidate accumulation, and the ld_quadratic / min_fbeta selection. `fitOne` +# supplies the per-`s` fit as list(beta, meta); any inner grid (e.g. l0learn's +# lambda0 sweep) lives inside it. `finalize` stamps the function-specific +# selection attribute onto the returned coefficient vector. +.rssShrinkGridWeights <- function(stat, LD, s, fitOne, finalize, + selection = c("ld_quadratic", "min_fbeta")) { + selection <- match.arg(selection) + n <- median(stat$n) + p <- nrow(LD) + corInput <- .lassosumClampCor(.lassosumCorFromStat(stat, n = n, p = p)) + solverInput <- corInput * sqrt(n) + candidateBeta <- NULL + candidateMeta <- list() + for (sVal in s) { + LDs <- (1 - sVal) * LD + sVal * diag(p) + one <- fitOne(solverInput, LDs, n, sVal) + candidateBeta <- cbind(candidateBeta, one$beta) + candidateMeta[[length(candidateMeta) + 1L]] <- one$meta + } + candidateMeta <- do.call(rbind, candidateMeta) + selectorResult <- if (selection == "ld_quadratic") { + .lassosumSelectLdQuadratic(candidateBeta, corInput, LD) + } else { + .lassosumSelectMinFbeta(candidateBeta, candidateMeta) + } + bestBeta <- as.numeric(selectorResult$beta) + finalize(bestBeta, selectorResult, candidateMeta) +} + #' Extract weights from lassosumRss with shrinkage grid search #' #' Searches over a grid of shrinkage parameters \code{s} (default: @@ -1051,40 +1073,23 @@ lassosumRssWeights <- function(stat, LD, s = c(0.2, 0.5, 0.9, 1.0), selection = c("ld_quadratic", "min_fbeta"), ...) { selection <- match.arg(selection) - n <- median(stat$n) - p <- nrow(LD) - corInput <- .lassosumClampCor(.lassosumCorFromStat(stat, n = n, p = p)) - solverInput <- corInput * sqrt(n) - candidateBeta <- NULL - candidateMeta <- list() - - for (sVal in s) { - LDs <- (1 - sVal) * LD + sVal * diag(p) - model <- lassosumRss(bhat = solverInput, LD = list(blk1 = LDs), n = n, ...) - candidateBeta <- cbind(candidateBeta, model$beta) - candidateMeta[[length(candidateMeta) + 1L]] <- data.frame( - s = rep(sVal, length(model$lambda)), - lambda = model$lambda, - fbeta = model$fbeta, - stringsAsFactors = FALSE - ) - } - candidateMeta <- do.call(rbind, candidateMeta) - - selectorResult <- if (selection == "ld_quadratic") { - .lassosumSelectLdQuadratic(candidateBeta, corInput, LD) - } else { - .lassosumSelectMinFbeta(candidateBeta, candidateMeta) - } - - bestBeta <- as.numeric(selectorResult$beta) - attr(bestBeta, "lassosum_selection") <- c( - mode = selectorResult$mode, - index = selectorResult$index, - s = candidateMeta$s[selectorResult$index], - lambda = candidateMeta$lambda[selectorResult$index] - ) - bestBeta + dotArgs <- list(...) + fitOne <- function(solverInput, LDs, n, sVal) { + model <- do.call(lassosumRss, + c(list(bhat = solverInput, R = LDs, n = n), + dotArgs)) + list(beta = model$beta, + meta = data.frame(s = rep(sVal, length(model$lambda)), + lambda = model$lambda, fbeta = model$fbeta, + stringsAsFactors = FALSE)) + } + finalize <- function(bestBeta, sel, meta) { + attr(bestBeta, "lassosum_selection") <- c( + mode = sel$mode, index = sel$index, + s = meta$s[sel$index], lambda = meta$lambda[sel$index]) + bestBeta + } + .rssShrinkGridWeights(stat, LD, s, fitOne, finalize, selection) } #' Penalized Regression on RSS (Summary Statistics) Objective @@ -1095,8 +1100,8 @@ lassosumRssWeights <- function(stat, LD, s = c(0.2, 0.5, 0.9, 1.0), #' where \eqn{R} is a (possibly pre-shrunk) LD matrix and \eqn{z = \hat\beta / \sqrt{n}}. #' #' @param bhat Numeric vector of marginal effect estimates (length p). -#' @param LD A list of LD correlation matrices (one per block), as in -#' \code{lassosumRss()}. +#' @param R The LD correlation matrix (a single matrix over the analysed +#' window), as in \code{lassosumRss()}. #' @param n GWAS sample size (positive scalar). #' @param penalty Penalty type: \code{"lasso"}, \code{"MCP"}, \code{"SCAD"}, #' \code{"L0"}, \code{"L0L1"}, or \code{"L0L2"}. @@ -1134,32 +1139,21 @@ lassosumRssWeights <- function(stat, LD, s = c(0.2, 0.5, 0.9, 1.0), #' bhat <- rnorm(p, sd = 0.1) #' R <- diag(p) #' # MCP -#' penalizedRss(bhat, list(blk1 = R), n, penalty = "MCP") +#' penalizedRss(bhat, R, n, penalty = "MCP") #' # SCAD -#' penalizedRss(bhat, list(blk1 = R), n, penalty = "SCAD") +#' penalizedRss(bhat, R, n, penalty = "SCAD") #' # L0 -#' penalizedRss(bhat, list(blk1 = R), n, penalty = "L0", lambda0 = 0.01, +#' penalizedRss(bhat, R, n, penalty = "L0", lambda0 = 0.01, #' lambda = c(0)) #' } #' @export -penalizedRss <- function(bhat, LD, n, +penalizedRss <- function(bhat, R, n, penalty = c("lasso", "MCP", "SCAD", "L0", "L0L1", "L0L2"), lambda = exp(seq(log(0.0001), log(0.1), length.out = 20)), gamma = NULL, alpha = 1.0, lambda0 = 0, lambda2 = 0, thr = 1e-4, maxiter = 10000, maxSwaps = 100) { penalty <- match.arg(penalty) - if (!is.list(LD)) { - stop("Please provide a valid list of LD blocks using 'LD'.") - } - if (missing(n) || n <= 0) { - stop("Please provide a valid sample size using 'n'.") - } - totalRowsInLd <- sum(sapply(LD, nrow)) - if (length(bhat) != totalRowsInLd) { - stop("The length of 'bhat' must be the same as the sum of the number of rows of all elements in the 'LD' list.") - } - # Default gamma per penalty if (is.null(gamma)) { gamma <- switch(penalty, @@ -1167,35 +1161,24 @@ penalizedRss <- function(bhat, LD, n, MCP = 3.0, 0.0) } - - z <- bhat / sqrt(n) - order <- order(lambda, decreasing = TRUE) - - result <- penalizedRssRcpp(zR = z, LD = LD, lambdaR = lambda[order], - penaltyStr = penalty, - gamma = gamma, alpha = alpha, - lambda0 = lambda0, lambda2 = lambda2, - thr = thr, maxiter = as.integer(maxiter), - maxSwaps = as.integer(maxSwaps)) - - # Reorder back to original lambda order - invOrder <- order(order) - result$beta <- result$beta[, invOrder, drop = FALSE] - result$conv <- result$conv[invOrder] - result$loss <- result$loss[invOrder] - result$fbeta <- result$fbeta[invOrder] - result$lambda <- lambda - result$nparams <- as.integer(colSums(result$beta != 0)) - result$betaEst <- as.numeric(result$beta[, which.min(result$fbeta)]) - result + # C++ backend takes a block list; wrap the single-window matrix R as one block. + .rssSolvePath(bhat, R, n, lambda, function(z, lam) + penalizedRssRcpp(zR = z, LD = list(blk1 = R), lambdaR = lam, + penaltyStr = penalty, + gamma = gamma, alpha = alpha, + lambda0 = lambda0, lambda2 = lambda2, + thr = thr, maxiter = as.integer(maxiter), + maxSwaps = as.integer(maxSwaps))) } #' RSS Weights Helper for Penalized Methods #' -#' Shared implementation for \code{scadRssWeights()}, \code{mcpRssWeights()}, -#' and \code{l0learnRssWeights()}. Searches over a shrinkage grid \code{s} -#' (LD matrix shrinkage \code{(1-s)R + sI}) and selects the best candidate via -#' LD-quadratic pseudovalidation or minimum penalized objective. +#' Shared implementation for \code{scadRssWeights()} and \code{mcpRssWeights()}. +#' (\code{l0learnRssWeights()} uses the lower-level \code{.rssShrinkGridWeights} +#' scaffold directly, since it sweeps an additional \code{lambda0} path.) +#' Searches over a shrinkage grid \code{s} (LD matrix shrinkage +#' \code{(1-s)R + sI}) and selects the best candidate via LD-quadratic +#' pseudovalidation or minimum penalized objective. #' #' @param stat,LD,s,selection,penalty,gamma,alpha,lambda0,lambda2,... #' See the public wrappers for details. @@ -1208,43 +1191,24 @@ penalizedRss <- function(bhat, LD, n, selection = c("ld_quadratic", "min_fbeta"), ...) { selection <- match.arg(selection) - n <- median(stat$n) - p <- nrow(LD) - corInput <- .lassosumClampCor(.lassosumCorFromStat(stat, n = n, p = p)) - solverInput <- corInput * sqrt(n) - candidateBeta <- NULL - candidateMeta <- list() - - for (sVal in s) { - LDs <- (1 - sVal) * LD + sVal * diag(p) - model <- penalizedRss(bhat = solverInput, LD = list(blk1 = LDs), n = n, - penalty = penalty, gamma = gamma, alpha = alpha, - lambda0 = lambda0, lambda2 = lambda2, ...) - candidateBeta <- cbind(candidateBeta, model$beta) - candidateMeta[[length(candidateMeta) + 1L]] <- data.frame( - s = rep(sVal, length(model$lambda)), - lambda = model$lambda, - fbeta = model$fbeta, - stringsAsFactors = FALSE - ) - } - candidateMeta <- do.call(rbind, candidateMeta) - - selectorResult <- if (selection == "ld_quadratic") { - .lassosumSelectLdQuadratic(candidateBeta, corInput, LD) - } else { - .lassosumSelectMinFbeta(candidateBeta, candidateMeta) - } - - bestBeta <- as.numeric(selectorResult$beta) - attr(bestBeta, "penalized_rss_selection") <- c( - mode = selectorResult$mode, - index = selectorResult$index, - penalty = penalty, - s = candidateMeta$s[selectorResult$index], - lambda = candidateMeta$lambda[selectorResult$index] - ) - bestBeta + dotArgs <- list(...) + fitOne <- function(solverInput, LDs, n, sVal) { + model <- do.call(penalizedRss, + c(list(bhat = solverInput, R = LDs, n = n, + penalty = penalty, gamma = gamma, alpha = alpha, + lambda0 = lambda0, lambda2 = lambda2), dotArgs)) + list(beta = model$beta, + meta = data.frame(s = rep(sVal, length(model$lambda)), + lambda = model$lambda, fbeta = model$fbeta, + stringsAsFactors = FALSE)) + } + finalize <- function(bestBeta, sel, meta) { + attr(bestBeta, "penalized_rss_selection") <- c( + mode = sel$mode, index = sel$index, penalty = penalty, + s = meta$s[sel$index], lambda = meta$lambda[sel$index]) + bestBeta + } + .rssShrinkGridWeights(stat, LD, s, fitOne, finalize, selection) } #' Compute SCAD-Penalized Weights from Summary Statistics @@ -1343,49 +1307,35 @@ l0learnRssWeights <- function(stat, LD, } } - n <- median(stat$n) - p <- nrow(LD) - corInput <- .lassosumClampCor(.lassosumCorFromStat(stat, n = n, p = p)) - solverInput <- corInput * sqrt(n) - candidateBeta <- NULL - candidateMeta <- list() - - # Grid search over s and lambda0 - for (sVal in s) { - LDs <- (1 - sVal) * LD + sVal * diag(p) + dotArgs <- list(...) + # Inner sweep over the lambda0 (L0) path for each shrinkage level; the outer + # `s` grid, selection, and bestBeta live in .rssShrinkGridWeights. + fitOne <- function(solverInput, LDs, n, sVal) { + beta <- NULL + meta <- list() for (l0Val in lambda0) { - model <- penalizedRss(bhat = solverInput, LD = list(blk1 = LDs), n = n, - penalty = penalty, lambda = lambda, - lambda0 = l0Val, lambda2 = lambda2, - maxSwaps = maxSwaps, ...) - candidateBeta <- cbind(candidateBeta, model$beta) - candidateMeta[[length(candidateMeta) + 1L]] <- data.frame( + model <- do.call(penalizedRss, + c(list(bhat = solverInput, R = LDs, n = n, + penalty = penalty, lambda = lambda, + lambda0 = l0Val, lambda2 = lambda2, + maxSwaps = maxSwaps), dotArgs)) + beta <- cbind(beta, model$beta) + meta[[length(meta) + 1L]] <- data.frame( s = rep(sVal, length(model$lambda)), lambda0 = rep(l0Val, length(model$lambda)), - lambda = model$lambda, - fbeta = model$fbeta, - stringsAsFactors = FALSE - ) + lambda = model$lambda, fbeta = model$fbeta, + stringsAsFactors = FALSE) } + list(beta = beta, meta = do.call(rbind, meta)) } - candidateMeta <- do.call(rbind, candidateMeta) - - selectorResult <- if (selection == "ld_quadratic") { - .lassosumSelectLdQuadratic(candidateBeta, corInput, LD) - } else { - .lassosumSelectMinFbeta(candidateBeta, candidateMeta) + finalize <- function(bestBeta, sel, meta) { + attr(bestBeta, "penalized_rss_selection") <- c( + mode = sel$mode, index = sel$index, penalty = penalty, + s = meta$s[sel$index], lambda0 = meta$lambda0[sel$index], + lambda = meta$lambda[sel$index]) + bestBeta } - - bestBeta <- as.numeric(selectorResult$beta) - attr(bestBeta, "penalized_rss_selection") <- c( - mode = selectorResult$mode, - index = selectorResult$index, - penalty = penalty, - s = candidateMeta$s[selectorResult$index], - lambda0 = candidateMeta$lambda0[selectorResult$index], - lambda = candidateMeta$lambda[selectorResult$index] - ) - bestBeta + .rssShrinkGridWeights(stat, LD, s, fitOne, finalize, selection) } #' Compute Weights Using ncvreg with SCAD or MCP Penalty diff --git a/R/sldscWrapper.R b/R/sldscWrapper.R index 4efe251f..c8e7812e 100644 --- a/R/sldscWrapper.R +++ b/R/sldscWrapper.R @@ -451,7 +451,7 @@ metaSldscRandom <- function(perTraitEstimates, category, } meta <- metaRandomEffects(means, ses) z <- meta$mean / meta$se - p <- 2 * pnorm(-abs(z)) + p <- .zToPvalue(z) list( mean = meta$mean, se = meta$se, diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index d7bc1104..cd6d3160 100644 --- a/R/sumstatsQc.R +++ b/R/sumstatsQc.R @@ -2049,7 +2049,7 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, condMean <- as.numeric(cd$condmean) statistic <- as.numeric(cd$z_std_diff) residual <- zScore - condMean - pValue <- 2 * stats::pnorm(-abs(statistic)) + pValue <- .zToPvalue(statistic) outlier <- !is.na(pValue) & pValue < pThreshold list( outlier = outlier, @@ -2104,7 +2104,7 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, gr <- GenomicRanges::GRanges() return(gr) } - chr <- paste0("chr", sub("^chr", "", chrRaw, ignore.case = TRUE)) + chr <- withChrPrefix(chrRaw) gr <- GenomicRanges::GRanges( seqnames = chr, ranges = IRanges::IRanges(start = as.integer(df$pos), width = 1L)) @@ -2178,11 +2178,8 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, # Requires Z, MAF, and N to all be present in `df`. No-op if BETA and SE # are already there, or if any required column is missing. Returns: # list(df = , audit = NULL | list(nDerived = )) -# Internal: two-tailed normal p-value from a signed Z. -# Returns NA where z is NA. Values |z| > ~37 underflow to 0 (R's pnorm -# limit); that's expected behaviour for the regime where p-values are -# meaningless anyway. -.zToPvalue <- function(z) 2 * pnorm(-abs(z)) +# .zToPvalue (two-tailed normal p-value from a signed Z) is defined once in +# pvalCombine.R and shared package-wide. # Internal: thin SVD with numerical-stability filtering. Drops singular # values below `tol * max(d)` and caps the retained rank at `maxRank`. @@ -2255,9 +2252,9 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, z <- as.numeric(df$Z) maf <- as.numeric(df$MAF) n <- as.numeric(df$N) - varTerm <- 2 * maf * (1 - maf) * (n + z * z) - se <- 1 / sqrt(varTerm) - beta <- z * se + bs <- .zToBetaSe(z, maf, n) + se <- bs$se + beta <- bs$beta if (!hasBeta) df$BETA <- beta if (!hasSe) df$SE <- se list(df = df, audit = list(nDerived = sum(!is.na(se)))) @@ -2526,18 +2523,10 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, variantIds <- df$SNP if (is.null(variantIds) || any(is.na(variantIds))) stop("summaryStatsQc: ldMismatchQc requires SNP column on the entry.") - # Match the entry variants to the panel by (chrom, pos, allele) tuple so a - # chr-prefix / separator difference does not read as "absent". - m <- matchVariants(variantIds, as.character(getSnpInfo(ldSketch)$SNP)) - if (length(m$idxA) < length(variantIds)) - stop("summaryStatsQc: ", length(variantIds) - length(m$idxA), - " variant(s) in entry are absent from the ldSketch panel; ", - "harmonize / impute before calling zMismatchQc.") - snpIdx <- m$idxB[order(m$idxA)] # panel rows, in entry order - block <- extractBlockGenotypes(ldSketch, snpIdx, meanImpute = TRUE) - dosage <- t(SummarizedExperiment::assay(block, "dosage")) - colnames(dosage) <- variantIds - R <- computeLd(dosage, method = "sample") + # Panel LD for the entry variants via the shared LD-from-sketch helper (tuple + # match with chr-prefix tolerance, strand-ambiguous variants kept; errors if + # any variant is absent from the panel). + R <- .ldFromSketch(ldSketch, variantIds, label = "summaryStatsQc: zMismatchQc") qc <- ldMismatchQc(zScore = df$Z, R = R, nSample = getNSamples(ldSketch), method = method) # slalom / dentist can leave NA in the outlier column when their @@ -2720,16 +2709,8 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, # 6. Optional kriging prefilter. if (isTRUE(opts$alleleFlipKriging) && nrow(df) >= 2L) { nKrIn <- nrow(df) - m <- matchVariants(df$SNP, as.character(getSnpInfo(ldSketch)$SNP)) - if (length(m$idxA) < nrow(df)) - stop("summaryStatsQc: ", nrow(df) - length(m$idxA), - " variant(s) absent from the ldSketch panel; harmonize / impute ", - "before the kriging prefilter.") - snpIdx <- m$idxB[order(m$idxA)] # panel rows, in entry order - block <- extractBlockGenotypes(ldSketch, snpIdx, meanImpute = TRUE) - dosage <- t(SummarizedExperiment::assay(block, "dosage")) - colnames(dosage) <- df$SNP - R <- computeLd(dosage, method = "sample") + R <- .ldFromSketch(ldSketch, df$SNP, + label = "summaryStatsQc: kriging prefilter") nKrig <- if (!is.null(opts$nForPip) && is.finite(opts$nForPip)) opts$nForPip else stats::median(as.numeric(df$N), na.rm = TRUE) kr <- krigingOutlierQc(df$Z, R, n = nKrig, variantIds = df$SNP) @@ -2786,9 +2767,8 @@ krigingOutlierQc <- function(zScore, R, n, variantIds = NULL, # Materialize the full panel dosage in panel-order matching refPanel. sketchSnpInfo <- getSnpInfo(ldSketch) - block <- extractBlockGenotypes( - ldSketch, seq_len(nrow(sketchSnpInfo)), meanImpute = TRUE) - dosage <- t(SummarizedExperiment::assay(block, "dosage")) + dosage <- .dosageMatrix(ldSketch, seq_len(nrow(sketchSnpInfo)), + meanImpute = TRUE) colnames(dosage) <- normalizeVariantId(as.character(sketchSnpInfo$SNP)) dosage <- dosage[, refPanel$variant_id, drop = FALSE] scaledDosage <- scale(dosage) diff --git a/R/twasWeightsPipeline.R b/R/twasWeightsPipeline.R index f34c8ba1..dc057bb8 100644 --- a/R/twasWeightsPipeline.R +++ b/R/twasWeightsPipeline.R @@ -1378,72 +1378,20 @@ setMethod("twasWeightsPipeline", "MultiStudyQtlDataset", } } - qtlDatasets <- getQtlDatasets(data) - sumStats <- getSumStats(data) - - out <- NULL - embeddedLd <- NULL - for (qdName in names(qtlDatasets)) { - qd <- qtlDatasets[[qdName]] - res <- twasWeightsPipeline( - data = qd, - methods = methods, - contexts = contexts, - traitId = traitId, - region = region, - cisWindow = cisWindow, - jointRegions = jointRegions, - jointSpecification = NULL, - fineMappingResult = fineMappingResult, - twasWeights = twasWeights, - naAction = naAction, - verbose = verbose, - ...) - out <- if (is.null(out)) res - else .rbindTwasWeights(out, res, ldSketch = NULL) - } - - if (!is.null(sumStats)) { - ssRes <- twasWeightsPipeline( - data = sumStats, - methods = methods, - contexts = contexts, - traitId = traitId, - jointSpecification = NULL, - fineMappingResult = fineMappingResult, - twasWeights = twasWeights, - verbose = verbose, - ...) - embeddedLd <- getLdSketch(ssRes) - out <- if (is.null(out)) ssRes - else .rbindTwasWeights(out, ssRes, ldSketch = embeddedLd) - } - - perTupleResult <- if (!is.null(out)) { - # ldSketch: NULL when all studies are individual-level; the embedded - # sumStats's ldSketch otherwise. - TwasWeights( - study = as.character(out$study), - context = as.character(out$context), - trait = as.character(out$trait), - method = as.character(out$method), - entry = as.list(out$entry), - jointStudies = if ("jointStudies" %in% names(out)) - as.character(out$jointStudies) else NULL, - jointContexts = if ("jointContexts" %in% names(out)) - as.character(out$jointContexts) else NULL, - jointTraits = if ("jointTraits" %in% names(out)) - as.character(out$jointTraits) else NULL, - ldSketch = embeddedLd) - } else NULL - - if (is.null(jointResult)) { - if (is.null(perTupleResult)) - stop("twasWeightsPipeline(MultiStudyQtlDataset): no entries produced weights.") - return(perTupleResult) - } - if (is.null(perTupleResult)) return(jointResult) - .rbindTwasWeights(perTupleResult, jointResult, ldSketch = embeddedLd) + dotArgs <- list(...) + perStudyFn <- function(qd) do.call(twasWeightsPipeline, c(list( + data = qd, methods = methods, contexts = contexts, traitId = traitId, + region = region, cisWindow = cisWindow, jointRegions = jointRegions, + jointSpecification = NULL, fineMappingResult = fineMappingResult, + twasWeights = twasWeights, naAction = naAction, verbose = verbose), + dotArgs)) + sumStatsFn <- function(ss) do.call(twasWeightsPipeline, c(list( + data = ss, methods = methods, contexts = contexts, traitId = traitId, + jointSpecification = NULL, fineMappingResult = fineMappingResult, + twasWeights = twasWeights, verbose = verbose), dotArgs)) + .multiStudyPipelineDriver( + data, jointResult, perStudyFn, sumStatsFn, + .rbindTwasWeights, TwasWeights, "twasWeightsPipeline", noun = "weights") }) diff --git a/R/variantId.R b/R/variantId.R index e7ef5ce6..de220d75 100644 --- a/R/variantId.R +++ b/R/variantId.R @@ -38,6 +38,18 @@ canonChrom <- function(x) { x } +#' Ensure a leading chr prefix on a chromosome identifier. +#' +#' Case-insensitive additive companion to \code{canonChrom} (which strips the +#' prefix): \code{"1"}, \code{"chr1"}, \code{"CHR1"} all become \code{"chr1"}. +#' Does not remap 23/24/M. +#' @param x Character or numeric vector of chromosome identifiers. +#' @return Character vector with a lowercase \code{"chr"} prefix. +#' @noRd +withChrPrefix <- function(x) { + paste0("chr", sub("^chr", "", as.character(x), ignore.case = TRUE)) +} + #' Order key for chromosome identifiers. #' #' Returns an ordered factor placing autosomes 1..22 first, then X, Y, XY, MT, diff --git a/man/dot-penalizedRssWeights.Rd b/man/dot-penalizedRssWeights.Rd index a6ff4a67..7eab9516 100644 --- a/man/dot-penalizedRssWeights.Rd +++ b/man/dot-penalizedRssWeights.Rd @@ -24,9 +24,11 @@ Numeric weight vector of length \code{nrow(LD)}. } \description{ -Shared implementation for \code{scadRssWeights()}, \code{mcpRssWeights()}, -and \code{l0learnRssWeights()}. Searches over a shrinkage grid \code{s} -(LD matrix shrinkage \code{(1-s)R + sI}) and selects the best candidate via -LD-quadratic pseudovalidation or minimum penalized objective. +Shared implementation for \code{scadRssWeights()} and \code{mcpRssWeights()}. +(\code{l0learnRssWeights()} uses the lower-level \code{.rssShrinkGridWeights} +scaffold directly, since it sweeps an additional \code{lambda0} path.) +Searches over a shrinkage grid \code{s} (LD matrix shrinkage +\code{(1-s)R + sI}) and selects the best candidate via LD-quadratic +pseudovalidation or minimum penalized objective. } \keyword{internal} diff --git a/man/fineMappingPipeline.Rd b/man/fineMappingPipeline.Rd index 70a0906b..a08bfea8 100644 --- a/man/fineMappingPipeline.Rd +++ b/man/fineMappingPipeline.Rd @@ -321,6 +321,13 @@ S4-dispatched per-region fine-mapping entry point that variant of the same.} \item{\code{susieAsh}}{\code{unmappable_effects = "ash"} variant of the same.} + \item{\code{ser}}{Single-effect regression via + \code{susieR::susie_ser} on summary statistics + (\code{z}, \code{n}); LD-free (no \code{R}, no \code{L}), + so distinct from \code{susie} with \code{L = 1}. Sumstat + input only (\code{QtlSumStats} / \code{GwasSumStats}, or the + sumstat side of a \code{MultiStudyQtlDataset}); rejected on + individual-level \code{QtlDataset}.} \item{\code{mvsusie}}{\code{mvsusieR::mvsusie} on individual- level input (requires multi-trait OR multi-context Y), \code{mvsusieR::mvsusie_rss} on sumstat input (requires diff --git a/man/getCs.Rd b/man/getCs.Rd index 1ee1fef0..37b4d2a7 100644 --- a/man/getCs.Rd +++ b/man/getCs.Rd @@ -1,36 +1,26 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/FineMappingEntry.R, -% R/GwasFineMappingResult.R, R/QtlFineMappingResult.R +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, +% R/FineMappingEntry.R \name{getCs} \alias{getCs} +\alias{getCs,FineMappingResultBase-method} \alias{getCs,FineMappingEntry-method} -\alias{getCs,GwasFineMappingResult-method} -\alias{getCs,QtlFineMappingResult-method} \title{Get Credible Sets} \usage{ getCs(x, ...) -\S4method{getCs}{FineMappingEntry}(x, coverage = 0.95, ...) - -\S4method{getCs}{GwasFineMappingResult}( +\S4method{getCs}{FineMappingResultBase}( x, study = NULL, context = NULL, trait = NULL, method = NULL, region = NULL, - ... -) - -\S4method{getCs}{QtlFineMappingResult}( - x, - study = NULL, - context = NULL, - trait = NULL, - method = NULL, coverage = 0.95, ... ) + +\S4method{getCs}{FineMappingEntry}(x, coverage = 0.95, ...) } \arguments{ \item{x}{A \code{FineMappingEntry} or \code{FineMappingResult}.} diff --git a/man/getMaf.Rd b/man/getMaf.Rd index 63033d1b..71b4a73e 100644 --- a/man/getMaf.Rd +++ b/man/getMaf.Rd @@ -1,20 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/QtlDataset.R, -% R/gwasSumStats.R, R/qtlSumStats.R +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, R/QtlDataset.R \name{getMaf} \alias{getMaf} +\alias{getMaf,SumStatsBase-method} \alias{getMaf,QtlDataset-method} -\alias{getMaf,GwasSumStats-method} -\alias{getMaf,QtlSumStats-method} \title{Get Minor Allele Frequencies} \usage{ getMaf(x, ...) -\S4method{getMaf}{QtlDataset}(x, region = NULL, cisWindow = NULL, samples = NULL, ...) - -\S4method{getMaf}{GwasSumStats}(x, study = NULL, ...) +\S4method{getMaf}{SumStatsBase}(x, ...) -\S4method{getMaf}{QtlSumStats}(x, study = NULL, context = NULL, trait = NULL, ...) +\S4method{getMaf}{QtlDataset}(x, region = NULL, cisWindow = NULL, samples = NULL, ...) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlDataset} object.} diff --git a/man/getMarginalEffects.Rd b/man/getMarginalEffects.Rd index 98263d16..2ee80caf 100644 --- a/man/getMarginalEffects.Rd +++ b/man/getMarginalEffects.Rd @@ -1,18 +1,15 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/FineMappingEntry.R, -% R/GwasFineMappingResult.R, R/QtlFineMappingResult.R +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, +% R/FineMappingEntry.R \name{getMarginalEffects} \alias{getMarginalEffects} +\alias{getMarginalEffects,FineMappingResultBase-method} \alias{getMarginalEffects,FineMappingEntry-method} -\alias{getMarginalEffects,GwasFineMappingResult-method} -\alias{getMarginalEffects,QtlFineMappingResult-method} \title{Get Marginal Effects} \usage{ getMarginalEffects(x, maxPval = NULL, ...) -\S4method{getMarginalEffects}{FineMappingEntry}(x, maxPval = NULL, ...) - -\S4method{getMarginalEffects}{GwasFineMappingResult}( +\S4method{getMarginalEffects}{FineMappingResultBase}( x, maxPval = NULL, study = NULL, @@ -23,15 +20,7 @@ getMarginalEffects(x, maxPval = NULL, ...) ... ) -\S4method{getMarginalEffects}{QtlFineMappingResult}( - x, - maxPval = NULL, - study = NULL, - context = NULL, - trait = NULL, - method = NULL, - ... -) +\S4method{getMarginalEffects}{FineMappingEntry}(x, maxPval = NULL, ...) } \arguments{ \item{x}{A \code{FineMappingEntry} or \code{FineMappingResult}.} diff --git a/man/getN.Rd b/man/getN.Rd index bdc73e9b..511ec8b3 100644 --- a/man/getN.Rd +++ b/man/getN.Rd @@ -1,17 +1,13 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/gwasSumStats.R, -% R/qtlSumStats.R +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R \name{getN} \alias{getN} -\alias{getN,GwasSumStats-method} -\alias{getN,QtlSumStats-method} +\alias{getN,SumStatsBase-method} \title{Get Sample Sizes} \usage{ getN(x, ...) -\S4method{getN}{GwasSumStats}(x, study = NULL) - -\S4method{getN}{QtlSumStats}(x, study = NULL, context = NULL, trait = NULL) +\S4method{getN}{SumStatsBase}(x, ...) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} diff --git a/man/getSusieFit.Rd b/man/getSusieFit.Rd index 4a037888..3e421e0f 100644 --- a/man/getSusieFit.Rd +++ b/man/getSusieFit.Rd @@ -1,18 +1,15 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/FineMappingEntry.R, -% R/GwasFineMappingResult.R, R/QtlFineMappingResult.R +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, +% R/FineMappingEntry.R \name{getSusieFit} \alias{getSusieFit} +\alias{getSusieFit,FineMappingResultBase-method} \alias{getSusieFit,FineMappingEntry-method} -\alias{getSusieFit,GwasFineMappingResult-method} -\alias{getSusieFit,QtlFineMappingResult-method} \title{Get SuSiE Fit} \usage{ getSusieFit(x, ...) -\S4method{getSusieFit}{FineMappingEntry}(x, ...) - -\S4method{getSusieFit}{GwasFineMappingResult}( +\S4method{getSusieFit}{FineMappingResultBase}( x, study = NULL, context = NULL, @@ -22,7 +19,7 @@ getSusieFit(x, ...) ... ) -\S4method{getSusieFit}{QtlFineMappingResult}(x, study = NULL, context = NULL, trait = NULL, method = NULL, ...) +\S4method{getSusieFit}{FineMappingEntry}(x, ...) } \arguments{ \item{x}{A \code{FineMappingEntry} or \code{FineMappingResult}.} diff --git a/man/getTopLoci.Rd b/man/getTopLoci.Rd index 3212fa2b..e20ab28a 100644 --- a/man/getTopLoci.Rd +++ b/man/getTopLoci.Rd @@ -1,18 +1,15 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/FineMappingEntry.R, -% R/GwasFineMappingResult.R, R/QtlFineMappingResult.R +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, +% R/FineMappingEntry.R \name{getTopLoci} \alias{getTopLoci} +\alias{getTopLoci,FineMappingResultBase-method} \alias{getTopLoci,FineMappingEntry-method} -\alias{getTopLoci,GwasFineMappingResult-method} -\alias{getTopLoci,QtlFineMappingResult-method} \title{Get Top Loci (posterior view)} \usage{ getTopLoci(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, ...) -\S4method{getTopLoci}{FineMappingEntry}(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, ...) - -\S4method{getTopLoci}{GwasFineMappingResult}( +\S4method{getTopLoci}{FineMappingResultBase}( x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, @@ -24,16 +21,7 @@ getTopLoci(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, ...) ... ) -\S4method{getTopLoci}{QtlFineMappingResult}( - x, - type = c("data.frame", "GRanges"), - signalCutoff = 0.025, - study = NULL, - context = NULL, - trait = NULL, - method = NULL, - ... -) +\S4method{getTopLoci}{FineMappingEntry}(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, ...) } \arguments{ \item{x}{A \code{FineMappingEntry} or \code{FineMappingResult}.} diff --git a/man/getVariantIds.Rd b/man/getVariantIds.Rd index 860a0f83..0c9f7772 100644 --- a/man/getVariantIds.Rd +++ b/man/getVariantIds.Rd @@ -1,22 +1,18 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/FineMappingEntry.R, -% R/GwasFineMappingResult.R, R/LdData.R, R/QtlFineMappingResult.R, -% R/TwasWeightsEntry.R, R/twasWeights.R +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, +% R/FineMappingEntry.R, R/LdData.R, R/TwasWeightsEntry.R, R/twasWeights.R \name{getVariantIds} \alias{getVariantIds} +\alias{getVariantIds,FineMappingResultBase-method} \alias{getVariantIds,FineMappingEntry-method} -\alias{getVariantIds,GwasFineMappingResult-method} \alias{getVariantIds,LdData-method} -\alias{getVariantIds,QtlFineMappingResult-method} \alias{getVariantIds,TwasWeightsEntry-method} \alias{getVariantIds,TwasWeights-method} \title{Get Variant IDs} \usage{ getVariantIds(x, ...) -\S4method{getVariantIds}{FineMappingEntry}(x, ...) - -\S4method{getVariantIds}{GwasFineMappingResult}( +\S4method{getVariantIds}{FineMappingResultBase}( x, study = NULL, context = NULL, @@ -26,16 +22,9 @@ getVariantIds(x, ...) ... ) -\S4method{getVariantIds}{LdData}(x, ...) +\S4method{getVariantIds}{FineMappingEntry}(x, ...) -\S4method{getVariantIds}{QtlFineMappingResult}( - x, - study = NULL, - context = NULL, - trait = NULL, - method = NULL, - ... -) +\S4method{getVariantIds}{LdData}(x, ...) \S4method{getVariantIds}{TwasWeightsEntry}(x, ...) diff --git a/man/getZ.Rd b/man/getZ.Rd index 11fb59d0..9093eade 100644 --- a/man/getZ.Rd +++ b/man/getZ.Rd @@ -1,17 +1,13 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/gwasSumStats.R, -% R/qtlSumStats.R +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R \name{getZ} \alias{getZ} -\alias{getZ,GwasSumStats-method} -\alias{getZ,QtlSumStats-method} +\alias{getZ,SumStatsBase-method} \title{Get Z-scores} \usage{ getZ(x, ...) -\S4method{getZ}{GwasSumStats}(x, study = NULL) - -\S4method{getZ}{QtlSumStats}(x, study = NULL, context = NULL, trait = NULL) +\S4method{getZ}{SumStatsBase}(x, ...) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} diff --git a/man/lassosumRss.Rd b/man/lassosumRss.Rd index 1d833ae2..18ffdfc8 100644 --- a/man/lassosumRss.Rd +++ b/man/lassosumRss.Rd @@ -6,7 +6,7 @@ \usage{ lassosumRss( bhat, - LD, + R, n, lambda = exp(seq(log(1e-04), log(0.1), length.out = 20)), thr = 1e-04, @@ -16,7 +16,7 @@ lassosumRss( \arguments{ \item{bhat}{A vector of marginal effect sizes.} -\item{LD}{A list of LD blocks, where each element is a matrix representing an LD block. +\item{R}{The LD correlation matrix (a single matrix over the analysed window), as in \code{susieR::susie_rss()}. If shrinkage is desired, apply it before passing (e.g., \code{(1-s)*R + s*I}).} \item{n}{Sample size of the GWAS.} @@ -56,6 +56,5 @@ for (i in 1:(p - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } -LD <- list(blk1 = R) -out <- lassosumRss(bhat, LD, n) +out <- lassosumRss(bhat, R, n) } diff --git a/man/nSnps.Rd b/man/nSnps.Rd index 01ba3c50..0732b41a 100644 --- a/man/nSnps.Rd +++ b/man/nSnps.Rd @@ -1,17 +1,13 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/gwasSumStats.R, -% R/qtlSumStats.R +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R \name{nSnps} \alias{nSnps} -\alias{nSnps,GwasSumStats-method} -\alias{nSnps,QtlSumStats-method} +\alias{nSnps,SumStatsBase-method} \title{Get Number of SNPs} \usage{ nSnps(x, ...) -\S4method{nSnps}{GwasSumStats}(x, study = NULL) - -\S4method{nSnps}{QtlSumStats}(x, study = NULL, context = NULL, trait = NULL) +\S4method{nSnps}{SumStatsBase}(x, ...) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} diff --git a/man/penalizedRss.Rd b/man/penalizedRss.Rd index 81444418..387034ef 100644 --- a/man/penalizedRss.Rd +++ b/man/penalizedRss.Rd @@ -6,7 +6,7 @@ \usage{ penalizedRss( bhat, - LD, + R, n, penalty = c("lasso", "MCP", "SCAD", "L0", "L0L1", "L0L2"), lambda = exp(seq(log(1e-04), log(0.1), length.out = 20)), @@ -22,8 +22,8 @@ penalizedRss( \arguments{ \item{bhat}{Numeric vector of marginal effect estimates (length p).} -\item{LD}{A list of LD correlation matrices (one per block), as in -\code{lassosumRss()}.} +\item{R}{The LD correlation matrix (a single matrix over the analysed +window), as in \code{lassosumRss()}.} \item{n}{GWAS sample size (positive scalar).} @@ -78,11 +78,11 @@ p <- 10; n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) # MCP -penalizedRss(bhat, list(blk1 = R), n, penalty = "MCP") +penalizedRss(bhat, R, n, penalty = "MCP") # SCAD -penalizedRss(bhat, list(blk1 = R), n, penalty = "SCAD") +penalizedRss(bhat, R, n, penalty = "SCAD") # L0 -penalizedRss(bhat, list(blk1 = R), n, penalty = "L0", lambda0 = 0.01, +penalizedRss(bhat, R, n, penalty = "L0", lambda0 = 0.01, lambda = c(0)) } } diff --git a/man/prsCs.Rd b/man/prsCs.Rd index 98e062be..0f0e47a4 100644 --- a/man/prsCs.Rd +++ b/man/prsCs.Rd @@ -6,7 +6,7 @@ \usage{ prsCs( bhat, - LD, + R, n, a = 1, b = 0.5, @@ -22,7 +22,7 @@ prsCs( \arguments{ \item{bhat}{A vector of marginal effect sizes.} -\item{LD}{A list of LD blocks, where each element is a matrix representing an LD block.} +\item{R}{The LD correlation matrix (a single matrix over the analysed window), as in \code{susieR::susie_rss()}.} \item{n}{Sample size of the GWAS.} @@ -93,8 +93,7 @@ sigmasq_init <- 1.5 # Run PRS CS maf <- rep(0.5, length(b.hat)) # fake MAF -LD <- list(blk1 = R.hat) -out <- prsCs(b.hat, LD, n, maf = maf) +out <- prsCs(b.hat, R.hat, n, maf = maf) # In sample prediction correlations cor(X \%*\% out$betaEst, y) # 0.9944553 } diff --git a/man/sdpr.Rd b/man/sdpr.Rd index 7c7f1117..27a76f99 100644 --- a/man/sdpr.Rd +++ b/man/sdpr.Rd @@ -6,7 +6,7 @@ \usage{ sdpr( bhat, - LD, + R, n, perVariantSampleSize = NULL, array = NULL, @@ -27,7 +27,7 @@ sdpr( \arguments{ \item{bhat}{A vector of marginal beta values for each SNP.} -\item{LD}{A list of LD matrices, where each matrix corresponds to a subset of SNPs.} +\item{R}{The LD correlation matrix (a single matrix over the analysed window).} \item{n}{The total sample size of the GWAS.} @@ -110,8 +110,7 @@ var_y <- var(y) sigmasq_init <- 1.5 # Run SDPR -LD <- list(blk1 = R.hat) -out <- sdpr(b.hat, LD, n) +out <- sdpr(b.hat, R.hat, n) # In sample prediction correlations cor(X \%*\% out$betaEst, y) # diff --git a/tests/testthat/test_fineMappingPipeline.R b/tests/testthat/test_fineMappingPipeline.R index 8772114e..bb341f0b 100644 --- a/tests/testthat/test_fineMappingPipeline.R +++ b/tests/testthat/test_fineMappingPipeline.R @@ -135,6 +135,12 @@ context("fineMappingPipeline") } } +.fmp_mockFitSer <- function() { + function(z, n, coverage = 0.95, userArgs = NULL) { + list(token = "ser", n_variants = length(z)) + } +} + .fmp_mockPostprocess <- function() { function(fit, method, dataX, dataY, coverage, secondaryCoverage, signalCutoff, minAbsCorr, csInput = NULL, af = NULL, @@ -1438,6 +1444,62 @@ test_that("fineMappingPipeline(GwasSumStats): non-RSS family rejected by capabil ) }) +# ---- ser (LD-free single-effect regression); sumstat-only, not GWAS-only ---- + +test_that("fineMappingPipeline(QtlSumStats): ser dispatches via .fmFitSusieSer", { + ss <- .fmp_makeQtlSumStats() + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieSer = .fmp_mockFitSer(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr") + res <- suppressMessages(fineMappingPipeline(ss, methods = "ser")) + expect_s4_class(res, "QtlFineMappingResult") + expect_setequal(getMethodNames(res), "ser") +}) + +test_that("fineMappingPipeline(GwasSumStats): ser dispatches via .fmFitSusieSer", { + gss <- .fmp_makeGwasSumStats() + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieSer = .fmp_mockFitSer(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr") + res <- suppressMessages(fineMappingPipeline(gss, methods = "ser")) + expect_s4_class(res, "GwasFineMappingResult") + expect_setequal(getMethodNames(res), "ser") +}) + +test_that("ser is sumstat-only: rejected on QtlDataset, allowed on all sumstat kinds", { + expect_error(pecotmr:::.fmCheckMethodCapabilities("ser", "QtlDataset"), + "sumstat-only") + expect_silent(pecotmr:::.fmCheckMethodCapabilities("ser", "QtlSumStats")) + expect_silent(pecotmr:::.fmCheckMethodCapabilities("ser", "GwasSumStats")) + expect_silent(pecotmr:::.fmCheckMethodCapabilities("ser", "MultiStudyQtlDataset")) +}) + +test_that(".fmFitSusieSer calls susieR::susie_ser with z + n and no R / L", { + captured <- new.env(parent = emptyenv()) + local_mocked_bindings( + susie_ser = function(z, n, coverage = 0.95, ...) { + captured$args <- list(z = z, n = n, coverage = coverage, dots = list(...)) + list(pip = rep(0.1, length(z))) + }, + .package = "susieR") + fit <- pecotmr:::.fmFitSusieSer(z = rnorm(5), n = 1000) + expect_equal(captured$args$n, 1000) + expect_length(captured$args$z, 5) + expect_null(captured$args$dots$R) + expect_null(captured$args$dots$L) + expect_true("susieRss" %in% class(fit)) +}) + +test_that(".fmNormalizeMethods does not inject L / L_greedy for ser", { + norm <- pecotmr:::.fmNormalizeMethods("ser", L = 20L, Lgreedy = 5L) + expect_null(norm$methodArgs[["ser"]][["L"]]) + expect_null(norm$methodArgs[["ser"]][["L_greedy"]]) +}) + # =========================================================================== # fineMappingPipeline(ANY) # =========================================================================== diff --git a/tests/testthat/test_fineMappingWrappers.R b/tests/testthat/test_fineMappingWrappers.R index 08e1f84e..99343d5c 100644 --- a/tests/testthat/test_fineMappingWrappers.R +++ b/tests/testthat/test_fineMappingWrappers.R @@ -1626,7 +1626,7 @@ test_that(".susie_rss_extract_weights returns correct-length vector", { w <- pecotmr:::.susieRssExtractWeights( fit = NULL, z = z, R = R, n = n, requiredFields = c("alpha", "mu", "X_column_scale_factors"), - fitArgs = list(L = 5) + userArgs = list(L = 5) ) expect_equal(length(w), p) expect_true(all(is.finite(w))) diff --git a/tests/testthat/test_regularizedRegressionWrappers.R b/tests/testthat/test_regularizedRegressionWrappers.R index aa6e0b21..2b7cda9f 100644 --- a/tests/testthat/test_regularizedRegressionWrappers.R +++ b/tests/testthat/test_regularizedRegressionWrappers.R @@ -470,7 +470,7 @@ test_that("mrmashWeights fits from (X, Y) and returns p x K weights", { test_that("lassosumRss returns a p x nlambda beta matrix", { f <- .rrwStatLd() - out <- lassosumRss(f$stat$b, list(blk1 = f$LD), f$n) + out <- lassosumRss(f$stat$b, f$LD, f$n) expect_equal(nrow(out$beta), f$p) expect_equal(ncol(out$beta), length(out$lambda)) expect_length(out$conv, length(out$lambda)) @@ -479,37 +479,38 @@ test_that("lassosumRss returns a p x nlambda beta matrix", { test_that("penalizedRss traces a solution path for MCP / SCAD / L0", { f <- .rrwStatLd() for (pen in c("MCP", "SCAD")) { - out <- penalizedRss(f$stat$b, list(blk1 = f$LD), f$n, penalty = pen) + out <- penalizedRss(f$stat$b, f$LD, f$n, penalty = pen) expect_equal(nrow(out$beta), f$p) } - outL0 <- penalizedRss(f$stat$b, list(blk1 = f$LD), f$n, + outL0 <- penalizedRss(f$stat$b, f$LD, f$n, penalty = "L0", lambda0 = 0.01, lambda = c(0)) expect_equal(nrow(outL0$beta), f$p) }) test_that("prsCs returns posterior betaEst of length p", { f <- .rrwStatLd() - out <- prsCs(f$stat$b, list(blk1 = f$LD), f$n, nIter = 100, nBurnin = 20, thin = 1) + out <- prsCs(f$stat$b, f$LD, f$n, nIter = 100, nBurnin = 20, thin = 1) expect_length(out$betaEst, f$p) expect_true(all(is.finite(out$betaEst))) }) test_that("sdpr returns betaEst of length p", { f <- .rrwStatLd() - out <- sdpr(f$stat$b, list(blk1 = f$LD), f$n, + out <- sdpr(f$stat$b, f$LD, f$n, iter = 100, burn = 20, thin = 1, verbose = FALSE) expect_length(out$betaEst, f$p) }) -test_that("RSS solvers validate their LD-list / sample-size / length inputs", { +test_that("RSS solvers validate their R-matrix / sample-size / length inputs", { f <- .rrwStatLd() - expect_error(prsCs(f$stat$b, f$LD, f$n), "list of LD blocks") - expect_error(prsCs(f$stat$b, list(blk1 = f$LD), -1), "sample size") - expect_error(prsCs(f$stat$b[-1], list(blk1 = f$LD), f$n), "same as the sum") - expect_error(sdpr(f$stat$b[-1], list(blk1 = f$LD), f$n), "same as the length") - expect_error(sdpr(f$stat$b, list(blk1 = f$LD), f$n, M = 2), "at least 4") - expect_error(lassosumRss(f$stat$b, f$LD, f$n), "list of LD blocks") - expect_error(penalizedRss(f$stat$b, f$LD, f$n), "list of LD blocks") + # A list (the old block-list contract) is now rejected: R must be a matrix. + expect_error(prsCs(f$stat$b, list(blk1 = f$LD), f$n), "as a matrix") + expect_error(lassosumRss(f$stat$b, list(blk1 = f$LD), f$n), "as a matrix") + expect_error(penalizedRss(f$stat$b, list(blk1 = f$LD), f$n), "as a matrix") + expect_error(prsCs(f$stat$b, f$LD, -1), "sample size") + expect_error(prsCs(f$stat$b[-1], f$LD, f$n), "number of rows of 'R'") + expect_error(sdpr(f$stat$b[-1], f$LD, f$n), "number of rows of 'R'") + expect_error(sdpr(f$stat$b, f$LD, f$n, M = 2), "at least 4") }) # --------------------------- RSS weight wrappers ---------------------------- diff --git a/tests/testthat/test_rrDispatch.R b/tests/testthat/test_rrDispatch.R index 4319655a..f7b9200d 100644 --- a/tests/testthat/test_rrDispatch.R +++ b/tests/testthat/test_rrDispatch.R @@ -17,9 +17,9 @@ test_that("prsCsWeights dispatches to prsCs with correct arguments", { stat <- list(b = bhat, n = c(10, 20, 30, 40, 50, 60, 70, 80, 90, 1000)) captured <- new.env(parent = emptyenv()) local_mocked_bindings( - prsCs = function(bhat, LD, n, ...) { + prsCs = function(bhat, R, n, ...) { captured$bhat <- bhat - captured$LD <- LD + captured$R <- R captured$n <- n captured$dots <- list(...) list(betaEst = seq_len(length(bhat)) * 0.01) @@ -27,7 +27,7 @@ test_that("prsCsWeights dispatches to prsCs with correct arguments", { ) result <- prsCsWeights(stat = stat, LD = R, maf = rep(0.3, p), nIter = 17) expect_equal(captured$bhat, bhat) - expect_equal(captured$LD, list(blk1 = R)) + expect_equal(captured$R, R) expect_equal(captured$n, 55) # median of stat$n, NOT mean (145) expect_equal(captured$dots$maf, rep(0.3, p)) expect_equal(captured$dots$nIter, 17) @@ -42,9 +42,9 @@ test_that("sdprWeights dispatches to sdpr with correct arguments", { stat <- list(b = bhat, n = rep(456, p)) captured <- new.env(parent = emptyenv()) local_mocked_bindings( - sdpr = function(bhat, LD, n, ...) { + sdpr = function(bhat, R, n, ...) { captured$bhat <- bhat - captured$LD <- LD + captured$R <- R captured$n <- n captured$dots <- list(...) list(betaEst = seq_len(length(bhat)) * 0.02) @@ -52,7 +52,7 @@ test_that("sdprWeights dispatches to sdpr with correct arguments", { ) result <- sdprWeights(stat = stat, LD = R, iter = 19, burn = 3) expect_equal(captured$bhat, bhat) - expect_equal(captured$LD, list(blk1 = R)) + expect_equal(captured$R, R) expect_equal(captured$n, 456) expect_equal(captured$dots$iter, 19) expect_equal(captured$dots$burn, 3) @@ -72,9 +72,9 @@ test_that("lassosumRssWeights dispatches to lassosumRss once per s value", { call_log <- new.env(parent = emptyenv()) call_log$calls <- list() local_mocked_bindings( - lassosumRss = function(bhat, LD, n, ...) { + lassosumRss = function(bhat, R, n, ...) { call_log$calls <- c(call_log$calls, - list(list(bhat = bhat, LD = LD, n = n))) + list(list(bhat = bhat, R = R, n = n))) list( beta = cbind(rep(0, length(bhat)), rep(0.05, length(bhat))), lambda = c(0.05, 0.01), @@ -86,8 +86,8 @@ test_that("lassosumRssWeights dispatches to lassosumRss once per s value", { expect_equal(length(call_log$calls), 2L) expect_equal(call_log$calls[[1]]$n, 100) expect_equal(length(call_log$calls[[1]]$bhat), p) - # LD should differ between calls because s is different - expect_false(identical(call_log$calls[[1]]$LD, call_log$calls[[2]]$LD)) + # R should differ between calls because s is different + expect_false(identical(call_log$calls[[1]]$R, call_log$calls[[2]]$R)) }) test_that("lassosumRssWeights defaults to LD-quadratic selection", { @@ -99,7 +99,7 @@ test_that("lassosumRssWeights defaults to LD-quadratic selection", { expected <- c(1, 0, 0, 0) local_mocked_bindings( - lassosumRss = function(bhat, LD, n, ...) { + lassosumRss = function(bhat, R, n, ...) { list( beta = cbind(expected, c(1, 1, 0, 0)), lambda = c(0.05, 0.01), @@ -119,7 +119,7 @@ test_that("lassosumRssWeights uses first-max tie behavior for LD-quadratic selec R <- diag(p) local_mocked_bindings( - lassosumRss = function(bhat, LD, n, ...) { + lassosumRss = function(bhat, R, n, ...) { list( beta = cbind(c(1, 0, 0), c(0, 1, 0)), lambda = c(0.05, 0.01), @@ -140,7 +140,7 @@ test_that("lassosumRssWeights still supports explicit min(fbeta)", { expected <- c(1, 1, 0, 0) local_mocked_bindings( - lassosumRss = function(bhat, LD, n, ...) { + lassosumRss = function(bhat, R, n, ...) { list( beta = cbind(c(1, 0, 0, 0), expected), lambda = c(0.05, 0.01), @@ -277,7 +277,8 @@ test_that("susieWeights actually calls susie when fit is NULL", { captured$X <- X captured$y <- y list(pip = rep(0.1, ncol(X))) - } + }, + .package = "susieR" ) susieWeights(X = X, y = y) expect_true(captured$called) @@ -298,7 +299,8 @@ test_that("susieAshWeights calls susie with ash dispatch arguments", { captured$unmappable_effects <- unmappable_effects captured$convergence_method <- convergence_method list(pip = rep(0.1, ncol(X))) - } + }, + .package = "susieR" ) susieAshWeights(X = X, y = y) expect_true(captured$called) @@ -319,7 +321,8 @@ test_that("susieInfWeights calls susie with inf dispatch arguments", { captured$unmappable_effects <- unmappable_effects captured$convergence_method <- convergence_method list(pip = rep(0.1, ncol(X))) - } + }, + .package = "susieR" ) susieInfWeights(X = X, y = y) expect_true(captured$called) diff --git a/tests/testthat/test_rrLassosum.R b/tests/testthat/test_rrLassosum.R index 5b720df0..0d5f6a0c 100644 --- a/tests/testthat/test_rrLassosum.R +++ b/tests/testthat/test_rrLassosum.R @@ -1,20 +1,20 @@ context("regularized_regression - lassosumRss") # ---- lassosumRss ---- -test_that("lassosumRss errors on invalid LD input", { - expect_error(lassosumRss(bhat = rnorm(5), LD = "not_a_list", n = 100), - "valid list of LD blocks") +test_that("lassosumRss errors on non-matrix R input", { + expect_error(lassosumRss(bhat = rnorm(5), R = "not_a_matrix", n = 100), + "as a matrix") }) test_that("lassosumRss errors on non-positive sample size", { - expect_error(lassosumRss(bhat = rnorm(5), LD = list(blk1 = diag(5)), n = -1), + expect_error(lassosumRss(bhat = rnorm(5), R = diag(5), n = -1), "valid sample size") }) -test_that("lassosumRss errors on mismatched bhat and LD dimensions", { +test_that("lassosumRss errors on mismatched bhat and R dimensions", { expect_error( - lassosumRss(bhat = rnorm(10), LD = list(blk1 = diag(5)), n = 100), - "same as the sum" + lassosumRss(bhat = rnorm(10), R = diag(5), n = 100), + "number of rows of 'R'" ) }) @@ -28,7 +28,7 @@ test_that("lassosumRss runs successfully with valid input", { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } - result <- lassosumRss(bhat = bhat, LD = list(blk1 = R), n = n) + result <- lassosumRss(bhat = bhat, R = R, n = n) expect_type(result, "list") expect_true("betaEst" %in% names(result)) expect_equal(length(result$betaEst), p) @@ -37,29 +37,13 @@ test_that("lassosumRss runs successfully with valid input", { expect_equal(ncol(result$beta), 20) }) -test_that("lassosumRss accepts multiple LD blocks", { - set.seed(42) - p1 <- 5 - p2 <- 5 - p <- p1 + p2 - n <- 100 - bhat <- rnorm(p, sd = 0.1) - R1 <- diag(p1) - R2 <- diag(p2) - result <- lassosumRss(bhat = bhat, LD = list(blk1 = R1, blk2 = R2), n = n) - expect_type(result, "list") - expect_true("betaEst" %in% names(result)) - expect_equal(length(result$betaEst), p) - expect_true(all(is.finite(result$betaEst))) -}) - test_that("lassosumRss with large lambda gives all-zero betas", { set.seed(42) p <- 10 n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - result <- lassosumRss(bhat = bhat, LD = list(blk1 = R), n = n, + result <- lassosumRss(bhat = bhat, R = R, n = n, lambda = c(100)) expect_true(all(result$betaEst == 0)) }) @@ -78,7 +62,7 @@ test_that("lassosumRssWeights calls lassosumRss and returns betaEst", { stat <- list(b = bhat, n = rep(n, p)) expected <- seq_len(p) * 0.02 local_mocked_bindings( - lassosumRss = function(bhat, LD, n, ...) { + lassosumRss = function(bhat, R, n, ...) { list( beta = cbind(rep(0, length(bhat)), expected), lambda = c(0.05, 0.01), @@ -103,7 +87,7 @@ test_that("lassosumRssWeights clamps correlation input before scaling", { stat <- list(b = bhat, n = rep(n, p)) captured <- NULL local_mocked_bindings( - lassosumRss = function(bhat, LD, n, ...) { + lassosumRss = function(bhat, R, n, ...) { captured <<- bhat list( beta = matrix(0, nrow = length(bhat), ncol = 2), diff --git a/tests/testthat/test_rrPenalizedRss.R b/tests/testthat/test_rrPenalizedRss.R index 7d105725..e3e8bda4 100644 --- a/tests/testthat/test_rrPenalizedRss.R +++ b/tests/testthat/test_rrPenalizedRss.R @@ -2,23 +2,23 @@ context("regularized_regression — penalizedRss") # ---- penalizedRss (low-level solver) ---- -test_that("penalizedRss errors on invalid LD input", { - expect_error(penalizedRss(bhat = rnorm(5), LD = "not_a_list", n = 100, +test_that("penalizedRss errors on non-matrix R input", { + expect_error(penalizedRss(bhat = rnorm(5), R = "not_a_matrix", n = 100, penalty = "MCP"), - "valid list of LD blocks") + "as a matrix") }) test_that("penalizedRss errors on non-positive sample size", { - expect_error(penalizedRss(bhat = rnorm(5), LD = list(blk1 = diag(5)), + expect_error(penalizedRss(bhat = rnorm(5), R = diag(5), n = -1, penalty = "SCAD"), "valid sample size") }) -test_that("penalizedRss errors on mismatched bhat and LD dimensions", { +test_that("penalizedRss errors on mismatched bhat and R dimensions", { expect_error( - penalizedRss(bhat = rnorm(10), LD = list(blk1 = diag(5)), n = 100, + penalizedRss(bhat = rnorm(10), R = diag(5), n = 100, penalty = "MCP"), - "same as the sum" + "number of rows of 'R'" ) }) @@ -26,7 +26,7 @@ test_that("penalizedRss with large lambda gives all-zero betas (MCP)", { set.seed(42) p <- 10; n <- 100 bhat <- rnorm(p, sd = 0.1) - result <- penalizedRss(bhat = bhat, LD = list(blk1 = diag(p)), n = n, + result <- penalizedRss(bhat = bhat, R = diag(p), n = n, penalty = "MCP", lambda = c(100)) expect_true(all(result$betaEst == 0)) }) @@ -35,7 +35,7 @@ test_that("penalizedRss with large lambda gives all-zero betas (SCAD)", { set.seed(42) p <- 10; n <- 100 bhat <- rnorm(p, sd = 0.1) - result <- penalizedRss(bhat = bhat, LD = list(blk1 = diag(p)), n = n, + result <- penalizedRss(bhat = bhat, R = diag(p), n = n, penalty = "SCAD", lambda = c(100)) expect_true(all(result$betaEst == 0)) }) @@ -44,7 +44,7 @@ test_that("penalizedRss with large lambda0 gives all-zero betas (L0)", { set.seed(42) p <- 10; n <- 100 bhat <- rnorm(p, sd = 0.1) - result <- penalizedRss(bhat = bhat, LD = list(blk1 = diag(p)), n = n, + result <- penalizedRss(bhat = bhat, R = diag(p), n = n, penalty = "L0", lambda = c(0), lambda0 = 1e6) expect_true(all(result$betaEst == 0)) }) @@ -58,7 +58,7 @@ test_that("penalizedRss runs with MCP and returns correct structure", { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } - result <- penalizedRss(bhat = bhat, LD = list(blk1 = R), n = n, + result <- penalizedRss(bhat = bhat, R = R, n = n, penalty = "MCP") expect_type(result, "list") expect_true("betaEst" %in% names(result)) @@ -74,7 +74,7 @@ test_that("penalizedRss runs with SCAD and returns correct structure", { p <- 10; n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - result <- penalizedRss(bhat = bhat, LD = list(blk1 = R), n = n, + result <- penalizedRss(bhat = bhat, R = R, n = n, penalty = "SCAD") expect_type(result, "list") expect_equal(length(result$betaEst), p) @@ -86,33 +86,22 @@ test_that("penalizedRss runs with L0 and returns correct structure", { p <- 10; n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - result <- penalizedRss(bhat = bhat, LD = list(blk1 = R), n = n, + result <- penalizedRss(bhat = bhat, R = R, n = n, penalty = "L0", lambda = c(0), lambda0 = 0.01) expect_type(result, "list") expect_equal(length(result$betaEst), p) expect_true(all(is.finite(result$betaEst))) }) -test_that("penalizedRss accepts multiple LD blocks", { - set.seed(42) - p1 <- 5; p2 <- 5; p <- p1 + p2; n <- 100 - bhat <- rnorm(p, sd = 0.1) - result <- penalizedRss(bhat = bhat, - LD = list(blk1 = diag(p1), blk2 = diag(p2)), - n = n, penalty = "MCP") - expect_equal(length(result$betaEst), p) - expect_true(all(is.finite(result$betaEst))) -}) - test_that("penalizedRss LASSO matches lassosumRss on identity LD", { set.seed(42) p <- 10; n <- 200 bhat <- rnorm(p, sd = 0.2) R <- diag(p) lam <- exp(seq(log(0.001), log(0.1), length.out = 5)) - res_lasso <- penalizedRss(bhat = bhat, LD = list(blk1 = R), n = n, + res_lasso <- penalizedRss(bhat = bhat, R = R, n = n, penalty = "lasso", lambda = lam) - res_lassosum <- lassosumRss(bhat = bhat, LD = list(blk1 = R), n = n, + res_lassosum <- lassosumRss(bhat = bhat, R = R, n = n, lambda = lam) expect_equal(res_lasso$beta, res_lassosum$beta, tolerance = 1e-4) }) diff --git a/tests/testthat/test_rrPrsCs.R b/tests/testthat/test_rrPrsCs.R index f52801d3..f0951da5 100644 --- a/tests/testthat/test_rrPrsCs.R +++ b/tests/testthat/test_rrPrsCs.R @@ -1,27 +1,27 @@ context("regularized_regression - prsCs") # ---- prsCs ---- -test_that("prsCs errors on invalid LD input", { - expect_error(prsCs(bhat = rnorm(5), LD = "not_a_list", n = 100), - "valid list of LD blocks") +test_that("prsCs errors on non-matrix R input", { + expect_error(prsCs(bhat = rnorm(5), R = "not_a_matrix", n = 100), + "as a matrix") }) test_that("prsCs errors on non-positive sample size", { - expect_error(prsCs(bhat = rnorm(5), LD = list(blk1 = diag(5)), n = -1), + expect_error(prsCs(bhat = rnorm(5), R = diag(5), n = -1), "valid sample size") }) test_that("prsCs errors on mismatched maf length", { expect_error( - prsCs(bhat = rnorm(5), LD = list(blk1 = diag(5)), n = 100, maf = rep(0.3, 3)), + prsCs(bhat = rnorm(5), R = diag(5), n = 100, maf = rep(0.3, 3)), "same as 'maf'" ) }) -test_that("prsCs errors on mismatched bhat and LD dimensions", { +test_that("prsCs errors on mismatched bhat and R dimensions", { expect_error( - prsCs(bhat = rnorm(10), LD = list(blk1 = diag(5)), n = 100), - "same as the sum" + prsCs(bhat = rnorm(10), R = diag(5), n = 100), + "number of rows of 'R'" ) }) @@ -35,7 +35,7 @@ test_that("prsCs runs successfully with valid input", { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } - result <- prsCs(bhat = bhat, LD = list(blk1 = R), n = n, + result <- prsCs(bhat = bhat, R = R, n = n, maf = rep(0.3, p), nIter = 50, nBurnin = 10, thin = 2) expect_type(result, "list") expect_true("betaEst" %in% names(result)) @@ -43,37 +43,12 @@ test_that("prsCs runs successfully with valid input", { expect_true(all(is.finite(result$betaEst))) }) -test_that("prsCs accepts multiple LD blocks whose dimensions sum to length of bhat", { - set.seed(42) - p1 <- 5 - p2 <- 5 - p <- p1 + p2 - n <- 100 - - bhat <- rnorm(p, sd = 0.1) - R1 <- diag(p1) - R2 <- diag(p2) - - result <- prsCs( - bhat = bhat, - LD = list(blk1 = R1, blk2 = R2), - n = n, - maf = rep(0.3, p), - nIter = 50, nBurnin = 10, thin = 2 - ) - - expect_type(result, "list") - expect_true("betaEst" %in% names(result)) - expect_equal(length(result$betaEst), p) - expect_true(all(is.finite(result$betaEst))) -}) - test_that("prsCs with phi = NULL estimates phi automatically", { set.seed(42) p <- 10; n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - result <- prsCs(bhat = bhat, LD = list(blk1 = R), n = n, + result <- prsCs(bhat = bhat, R = R, n = n, phi = NULL, maf = rep(0.3, p), nIter = 50, nBurnin = 10, thin = 2) expect_true("phiEst" %in% names(result)) @@ -84,7 +59,7 @@ test_that("prsCs with explicit phi value", { p <- 10; n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - result <- prsCs(bhat = bhat, LD = list(blk1 = R), n = n, + result <- prsCs(bhat = bhat, R = R, n = n, phi = 0.01, maf = rep(0.3, p), nIter = 50, nBurnin = 10, thin = 2) expect_true("phiEst" %in% names(result)) @@ -97,7 +72,7 @@ test_that("prsCs works without maf (maf = NULL)", { p <- 10; n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - result <- prsCs(bhat = bhat, LD = list(blk1 = R), n = n, + result <- prsCs(bhat = bhat, R = R, n = n, maf = NULL, nIter = 50, nBurnin = 10, thin = 2) expect_equal(length(result$betaEst), p) }) @@ -109,7 +84,7 @@ test_that("prsCs with verbose = TRUE produces output", { bhat <- rnorm(p, sd = 0.1) R <- diag(p) # n_iter >= 100 triggers the verbose print inside the MCMC loop - result <- prsCs(bhat = bhat, LD = list(blk1 = R), n = n, + result <- prsCs(bhat = bhat, R = R, n = n, maf = rep(0.3, p), nIter = 110, nBurnin = 10, thin = 2, verbose = TRUE, seed = 42L) expect_type(result, "list") @@ -122,7 +97,7 @@ test_that("prsCs verbose with phi = NULL shows estimated phi", { p <- 10; n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - result <- prsCs(bhat = bhat, LD = list(blk1 = R), n = n, + result <- prsCs(bhat = bhat, R = R, n = n, phi = NULL, maf = rep(0.3, p), nIter = 110, nBurnin = 10, thin = 2, verbose = TRUE, seed = 42L) @@ -141,7 +116,7 @@ test_that("prsCs recovers signal direction on simulated genotype data", { y <- X %*% beta_true + rnorm(n) bhat <- as.vector(cor(y, X)) R <- cor(X) - result <- prsCs(bhat = bhat, LD = list(blk1 = R), n = n, + result <- prsCs(bhat = bhat, R = R, n = n, nIter = 1000, nBurnin = 500, thin = 5, seed = 42) expect_true("betaEst" %in% names(result)) expect_equal(length(result$betaEst), p) diff --git a/tests/testthat/test_rrSdpr.R b/tests/testthat/test_rrSdpr.R index c851a4b6..487f1117 100644 --- a/tests/testthat/test_rrSdpr.R +++ b/tests/testthat/test_rrSdpr.R @@ -1,30 +1,37 @@ context("regularized_regression - sdpr") # ---- sdpr ---- -test_that("sdpr errors on mismatched bhat and LD dimensions", { +test_that("sdpr errors on mismatched bhat and R dimensions", { expect_error( - sdpr(bhat = rnorm(10), LD = list(blk1 = diag(5)), n = 100), - "same as the length of bhat" + sdpr(bhat = rnorm(10), R = diag(5), n = 100), + "number of rows of 'R'" + ) +}) + +test_that("sdpr errors on non-matrix R input", { + expect_error( + sdpr(bhat = rnorm(5), R = "not_a_matrix", n = 100), + "as a matrix" ) }) test_that("sdpr errors on non-positive sample size", { expect_error( - sdpr(bhat = rnorm(5), LD = list(blk1 = diag(5)), n = -1), - "positive integer" + sdpr(bhat = rnorm(5), R = diag(5), n = -1), + "valid sample size" ) }) test_that("sdpr errors when M is less than 4", { expect_error( - sdpr(bhat = rnorm(5), LD = list(blk1 = diag(5)), n = 100, M = 3), + sdpr(bhat = rnorm(5), R = diag(5), n = 100, M = 3), "'M' must be at least 4" ) }) test_that("sdpr errors on invalid per_variant_sample_size", { expect_error( - sdpr(bhat = rnorm(5), LD = list(blk1 = diag(5)), n = 100, + sdpr(bhat = rnorm(5), R = diag(5), n = 100, perVariantSampleSize = c(100, -1, 100, 100, 100)), "positive values" ) @@ -32,7 +39,7 @@ test_that("sdpr errors on invalid per_variant_sample_size", { test_that("sdpr errors on invalid array values", { expect_error( - sdpr(bhat = rnorm(5), LD = list(blk1 = diag(5)), n = 100, + sdpr(bhat = rnorm(5), R = diag(5), n = 100, array = c(0, 1, 3, 1, 0)), "0, 1, or 2" ) @@ -43,7 +50,7 @@ test_that("sdpr runs successfully", { p <- 10 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - result <- sdpr(bhat = bhat, LD = list(blk1 = R), n = 100, + result <- sdpr(bhat = bhat, R = R, n = 100, iter = 50, burn = 10, thin = 2, verbose = FALSE) expect_type(result, "list") expect_true("betaEst" %in% names(result)) @@ -56,7 +63,7 @@ test_that("sdpr with per_variant_sample_size", { p <- 10 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - result <- sdpr(bhat = bhat, LD = list(blk1 = R), n = 100, + result <- sdpr(bhat = bhat, R = R, n = 100, perVariantSampleSize = rep(100, p), iter = 50, burn = 10, thin = 2, verbose = FALSE) expect_equal(length(result$betaEst), p) @@ -68,7 +75,7 @@ test_that("sdpr with valid array parameter", { p <- 10 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - result <- sdpr(bhat = bhat, LD = list(blk1 = R), n = 100, + result <- sdpr(bhat = bhat, R = R, n = 100, array = rep(1, p), iter = 50, burn = 10, thin = 2, verbose = FALSE) expect_equal(length(result$betaEst), p) @@ -87,7 +94,7 @@ test_that("sdpr recovers signal direction on simulated genotype data", { y <- X %*% beta_true + rnorm(n) bhat <- as.vector(cor(y, X)) R <- cor(X) - result <- sdpr(bhat = bhat, LD = list(blk1 = R), n = n, + result <- sdpr(bhat = bhat, R = R, n = n, iter = 500, burn = 200, thin = 5, verbose = FALSE, seed = 42L) expect_true("betaEst" %in% names(result)) expect_equal(length(result$betaEst), p) @@ -96,24 +103,6 @@ test_that("sdpr recovers signal direction on simulated genotype data", { expect_gt(cor(result$betaEst, beta_true), 0.3) }) -test_that("sdpr accepts multiple LD blocks with realistic genotype data", { - set.seed(2024) - n <- 500 - p <- 20 - X <- matrix(rbinom(n * p, 2, 0.3), nrow = n) - beta_true <- rep(0, p) - beta_true[c(3, 15)] <- c(0.4, 0.2) - y <- X %*% beta_true + rnorm(n) - bhat <- as.vector(cor(y, X)) - R <- cor(X) - R1 <- R[1:10, 1:10] - R2 <- R[11:20, 11:20] - result <- sdpr(bhat = bhat, LD = list(blk1 = R1, blk2 = R2), n = n, - iter = 500, burn = 200, thin = 5, verbose = FALSE, seed = 42L) - expect_equal(length(result$betaEst), p) - expect_true(all(is.finite(result$betaEst))) -}) - # ---- sdpr verbose output ---- test_that("sdpr with verbose = TRUE produces output", { set.seed(42) @@ -121,7 +110,7 @@ test_that("sdpr with verbose = TRUE produces output", { bhat <- rnorm(p, sd = 0.1) R <- diag(p) # iter >= 100 triggers the verbose print inside the MCMC loop - result <- sdpr(bhat = bhat, LD = list(blk1 = R), n = 100, + result <- sdpr(bhat = bhat, R = R, n = 100, iter = 110, burn = 10, thin = 2, verbose = TRUE, seed = 42L) expect_type(result, "list") expect_equal(length(result$betaEst), p) @@ -136,7 +125,7 @@ test_that("sdpr runs with optLlk = 2 and mixed array values", { R <- diag(p) # Mixed array: some variants from array 1, some from array 2 arr <- c(rep(1, 5), rep(2, 5)) - result <- sdpr(bhat = bhat, LD = list(blk1 = R), n = 100, + result <- sdpr(bhat = bhat, R = R, n = 100, perVariantSampleSize = rep(100, p), array = arr, optLlk = 2, iter = 50, burn = 10, thin = 2, verbose = FALSE, seed = 42L) @@ -158,7 +147,7 @@ test_that("sdpr optLlk = 2 with realistic genotype data", { # Mixed arrays with varying sample sizes arr <- rep(c(1, 2), length.out = p) per_n <- rep(c(400, 500), length.out = p) - result <- sdpr(bhat = bhat, LD = list(blk1 = R), n = n, + result <- sdpr(bhat = bhat, R = R, n = n, perVariantSampleSize = per_n, array = arr, optLlk = 2, iter = 100, burn = 30, thin = 5, verbose = FALSE, seed = 42L) expect_equal(length(result$betaEst), p) diff --git a/tests/testthat/test_rrSusie.R b/tests/testthat/test_rrSusie.R index 066dbb8f..9a213456 100644 --- a/tests/testthat/test_rrSusie.R +++ b/tests/testthat/test_rrSusie.R @@ -63,7 +63,8 @@ test_that("susieWeights calls susie when susie_fit is NULL", { local_mocked_bindings( susie = function(...) { list(pip = rep(0.1, p)) - } + }, + .package = "susieR" ) result <- susieWeights(X = X, y = y) expect_equal(result, rep(0, p)) @@ -107,7 +108,8 @@ test_that("susieAshWeights calls susie when fit is NULL", { local_mocked_bindings( susie = function(...) { list(pip = rep(0.1, p)) - } + }, + .package = "susieR" ) result <- susieAshWeights(X = X, y = y) expect_equal(result, rep(0, p)) @@ -151,7 +153,8 @@ test_that("susieInfWeights calls susie when fit is NULL", { local_mocked_bindings( susie = function(...) { list(pip = rep(0.1, p)) - } + }, + .package = "susieR" ) result <- susieInfWeights(X = X, y = y) expect_equal(result, rep(0, p)) diff --git a/tests/testthat/test_sumstatsQc.R b/tests/testthat/test_sumstatsQc.R index 2710e960..3f226e46 100644 --- a/tests/testthat/test_sumstatsQc.R +++ b/tests/testthat/test_sumstatsQc.R @@ -3299,7 +3299,7 @@ test_that(".applyLdMismatchQcToEntry: errors on variants absent from the sketch" stringsAsFactors = FALSE) expect_error( pecotmr:::.applyLdMismatchQcToEntry(df, .ssh_makeHandle(), method = "dentist"), - "are absent from the ldSketch panel" + "not present in the LD sketch panel" ) }) diff --git a/tests/testthat/test_twasWeights.R b/tests/testthat/test_twasWeights.R index 94ce8ab7..50e0feff 100644 --- a/tests/testthat/test_twasWeights.R +++ b/tests/testthat/test_twasWeights.R @@ -780,6 +780,14 @@ test_that("twasWeights: SuSiE-inf is fitted before and initializes ordinary SuSi y_vec <- as.numeric(d$Y) susie_calls <- list() + local_mocked_bindings( + susieInfWeights = function(X, y, ...) rep(0, ncol(X)), + susieWeights = function(X, y, ...) { + rep(0, ncol(X)) + } + ) + # The two chained SuSiE fits now run through .fmFitSusieIndiv, which calls + # susieR::susie, so capture at the susieR namespace. local_mocked_bindings( susie = function(...) { args <- list(...) @@ -790,10 +798,7 @@ test_that("twasWeights: SuSiE-inf is fitted before and initializes ordinary SuSi inf = identical(args$unmappable_effects, "inf") ) }, - susieInfWeights = function(X, y, ...) rep(0, ncol(X)), - susieWeights = function(X, y, ...) { - rep(0, ncol(X)) - } + .package = "susieR" ) result <- learnTwasWeights( diff --git a/tests/testthat/test_variantId.R b/tests/testthat/test_variantId.R index 14382969..5551aaf7 100644 --- a/tests/testthat/test_variantId.R +++ b/tests/testthat/test_variantId.R @@ -747,3 +747,112 @@ test_that("matchVariants allowFlip = FALSE matches exact alleles only (no swap)" expect_length(m2$idxA, 0) }) +# =========================================================================== +# harmonizeAlleles -- direct tests for branches no caller exercises (every +# caller uses flipStrand = FALSE, removeUnmatched = TRUE, a valid colToFlip, +# and matchMinProp = 0, so these paths are otherwise unreached). +# =========================================================================== + +.vid_df <- function(chrom, pos, A2, A1, ...) + data.frame(chrom = as.character(chrom), pos = as.integer(pos), + A2 = A2, A1 = A1, ..., stringsAsFactors = FALSE) + +test_that("harmonizeAlleles warns and returns empty when nothing overlaps", { + res <- suppressWarnings(pecotmr:::harmonizeAlleles( + .vid_df("1", 100, "A", "G"), .vid_df("1", 999, "A", "G"))) + expect_equal(nrow(res$harmonizedData), 0L) + expect_equal(attr(res, "qcCounts")$considered, 0L) +}) + +test_that("harmonizeAlleles removeUnmatched = FALSE retains unmatched target variants", { + tgt <- .vid_df(c("1", "1"), c(100, 200), c("A", "A"), c("G", "G")) + res <- pecotmr:::harmonizeAlleles(tgt, .vid_df("1", 100, "A", "G"), + removeUnmatched = FALSE, matchMinProp = 0) + expect_equal(nrow(res$harmonizedData), 2L) +}) + +test_that("harmonizeAlleles flipStrand = TRUE runs the strand-flip branch", { + # target T/C is the unambiguous strand flip of ref A/G. + res <- pecotmr:::harmonizeAlleles( + .vid_df("1", 100, "T", "C"), .vid_df("1", 100, "A", "G"), + flipStrand = TRUE, matchMinProp = 0) + expect_equal(nrow(res$harmonizedData), 1L) +}) + +test_that("harmonizeAlleles complements colToComplement on an allele swap", { + # target G/A is the ref/alt swap of ref A/G, so an effect-allele freq + # complements to 1 - af. + tgt <- .vid_df("1", 100, "G", "A", af = 0.3) + res <- pecotmr:::harmonizeAlleles(tgt, .vid_df("1", 100, "A", "G"), + colToComplement = "af", matchMinProp = 0) + expect_equal(res$harmonizedData$af, 0.7) +}) + +test_that("harmonizeAlleles errors when colToFlip / colToComplement are absent", { + tgt <- .vid_df("1", 100, "A", "G") + expect_error(pecotmr:::harmonizeAlleles(tgt, tgt, colToFlip = "nope", + matchMinProp = 0), "not found in targetData") + expect_error(pecotmr:::harmonizeAlleles(tgt, tgt, colToComplement = "nope", + matchMinProp = 0), "not found in targetData") +}) + +test_that("harmonizeAlleles errors when too few variants clear matchMinProp", { + ref <- .vid_df("1", c(100, 200, 300, 400, 500), "A", "G") + expect_error( + pecotmr:::harmonizeAlleles(.vid_df("1", 100, "A", "G"), ref, matchMinProp = 0.5), + "Not enough variants") +}) + +test_that("harmonizeAlleles errors on duplicate variant IDs when removeDups = FALSE", { + tgt <- .vid_df(c("1", "1"), c(100, 100), c("A", "A"), c("G", "G")) + expect_error( + pecotmr:::harmonizeAlleles(tgt, .vid_df("1", 100, "A", "G"), matchMinProp = 0), + "Duplicated variant IDs") +}) + +test_that("harmonizeAlleles removeDups = TRUE drops duplicates with a warning", { + tgt <- .vid_df(c("1", "1"), c(100, 100), c("A", "A"), c("G", "G")) + expect_warning( + res <- pecotmr:::harmonizeAlleles(tgt, .vid_df("1", 100, "A", "G"), + removeDups = TRUE, matchMinProp = 0), + "duplicate") + expect_equal(nrow(res$harmonizedData), 1L) +}) + +test_that("harmonizeAlleles removeIndels = TRUE drops indels", { + tgt <- .vid_df(c("1", "1"), c(100, 200), c("A", "AT"), c("G", "A")) + res <- pecotmr:::harmonizeAlleles(tgt, tgt, removeIndels = TRUE, matchMinProp = 0) + expect_equal(nrow(res$harmonizedData), 1L) +}) + +# =========================================================================== +# withChrPrefix + asGranges error paths +# =========================================================================== + +test_that("withChrPrefix adds a lowercase chr prefix case-insensitively", { + expect_equal(pecotmr:::withChrPrefix(c("1", "chr2", "CHR3", "X")), + c("chr1", "chr2", "chr3", "chrX")) +}) + +test_that("asGranges errors on malformed input", { + expect_error(pecotmr:::asGranges(data.frame(foo = 1)), "must have columns") + expect_error(pecotmr:::asGranges(list(1)), "character vector or data.frame") +}) + +test_that("matchVariants allowFlip = FALSE accepts data.frame input", { + a <- .vid_df("1", 100, "A", "G") + b <- .vid_df("1", 100, "A", "G") + m <- pecotmr:::matchVariants(a, b, allowFlip = FALSE) + expect_equal(m$idxA, 1L) + expect_equal(m$idxB, 1L) + expect_equal(m$sign, 1) +}) + +test_that("matchVariants returns empty for unparseable data.frame input", { + # NA chrom / pos -> unparseable; with a data.frame there is no id string to + # fall back to, so the matcher returns empty. + a <- .vid_df(NA_character_, NA_integer_, "A", "G") + m <- pecotmr:::matchVariants(a, .vid_df("1", 100, "A", "G")) + expect_length(m$idxA, 0) +}) +