diff --git a/.Rbuildignore b/.Rbuildignore index be973333..ed2d16c7 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -10,5 +10,6 @@ ^.claude ^data-raw$ ^docs$ +^dev$ ^air.toml ^inst/prototype diff --git a/.github/environment/pixi.toml b/.github/environment/pixi.toml index 76ed456d..b1735664 100644 --- a/.github/environment/pixi.toml +++ b/.github/environment/pixi.toml @@ -32,7 +32,9 @@ r45 = {features = ["r45"]} "bioconductor-tidysummarizedexperiment" = "*" "gcc" = "*" "r-covr" = "*" +"r-decor" = "*" "r-devtools" = "*" +"r-goodpractice" = "*" "r-knitr" = "*" "r-lintr" = "*" "r-markdown" = "*" diff --git a/.github/recipe/recipe.yaml b/.github/recipe/recipe.yaml index b294c909..99b9fa5f 100644 --- a/.github/recipe/recipe.yaml +++ b/.github/recipe/recipe.yaml @@ -41,6 +41,7 @@ requirements: - r-base - r-bglr - r-bigsnpr + - r-checkmate - r-coda - r-coloc - r-colocboost @@ -48,7 +49,6 @@ requirements: - r-cpp11 - r-cpp11armadillo - r-ctwas - - r-decor - r-dplyr - r-flashier - r-fsusier @@ -109,6 +109,7 @@ requirements: - r-base - r-bglr - r-bigsnpr + - r-checkmate - r-coda - r-coloc - r-colocboost @@ -116,7 +117,6 @@ requirements: - r-cpp11 - r-cpp11armadillo - r-ctwas - - r-decor - r-dplyr - r-flashier - r-fsusier diff --git a/DESCRIPTION b/DESCRIPTION index 4459d282..8c17c8bd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,6 +28,7 @@ Imports: BiocGenerics, BiocParallel, Biostrings, + checkmate, coloc, colocboost, DelayedArray, diff --git a/NAMESPACE b/NAMESPACE index 09b8093d..c9a0ba30 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -457,7 +457,7 @@ importFrom(BiocParallel, MulticoreParam, bplapply, bpparam, - bpworkers + multicoreWorkers ) importFrom(Biostrings, DNAStringSet, @@ -500,6 +500,41 @@ importFrom(SummarizedExperiment, rowRanges ) importFrom(archive,archive_read) +importFrom(checkmate, + assert, + assertCharacter, + assertClass, + assertCount, + assertDataFrame, + assertDirectoryExists, + assertFileExists, + assertFlag, + assertInt, + assertList, + assertLogical, + assertMatrix, + assertMultiClass, + assertNames, + assertNumber, + assertNumeric, + assertScalar, + assertString, + assertSubset, + assertVector, + checkAtomicVector, + checkCharacter, + checkClass, + checkDataFrame, + checkFileExists, + checkList, + checkMatrix, + checkNames, + checkNull, + checkNumeric, + checkString, + checkSubset, + makeAssertCollection +) importFrom(dplyr, across, add_count, @@ -544,9 +579,12 @@ importFrom(methods, ) importFrom(purrr, compact, + detect, + discard, exec, imap, keep, + list_assign, list_c, list_flatten, list_modify, @@ -559,8 +597,12 @@ importFrom(purrr, map_int, map_lgl, partial, + possibly, reduce, - set_names + set_names, + walk, + walk2, + zap ) importFrom(quadprog,solve.QP) importFrom(readr, @@ -576,6 +618,7 @@ importFrom(rlang, arg_match, cnd_signal, inform, + try_fetch, warn ) importFrom(stats, @@ -653,7 +696,6 @@ importFrom(tools, importFrom(utils, combn, head, - modifyList, read.table, tail ) diff --git a/R/AllClasses.R b/R/AllClasses.R index 80c6aedb..f97cda63 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -192,8 +192,7 @@ setClass( if (length(GenomeInfoDb::seqlevels(object)) == 0L) { return(NULL) } - build <- unique(GenomeInfoDb::genome(object)) - build <- build[!is.na(build)] + build <- discard(unique(GenomeInfoDb::genome(object)), is.na) if (length(build) == 1L && str_length(build) > 0L) { return(NULL) } @@ -217,8 +216,7 @@ setMethod("getGenome", "SumStatsBase", function(x, ...) { # GRangesList already has somewhere to keep it, and a parallel `genome` # slot went stale against it (getGenome() said hg19 while genome(x) said # NA, so every Bioconductor path that reads genome(x) saw nothing). - build <- unique(GenomeInfoDb::genome(x)) - build <- build[!is.na(build)] + build <- discard(unique(GenomeInfoDb::genome(x)), is.na) if (length(build) == 0L) NA_character_ else build[[1L]] }) @@ -439,15 +437,32 @@ setMethod( } ) +# The collection's identity columns plus the per-entry payload columns. +# @noRd +.withEntryPayload <- function(md, entries) { + # `[[<-` not cbind(): the collection may already carry these columns, and + # they must be REPLACED -- cbind would append a second copy of each, which + # every reader then shadows with the stale one. + withFit <- `[[<-`( + md, + "susieFit", + value = S4Vectors::SimpleList(map(entries, getSusieFit)) + ) + `[[<-`( + withFit, + "cvResult", + value = S4Vectors::SimpleList(map(entries, getCvResult)) + ) +} + # Rebuild a fine-mapping collection from adjusted entries, keeping every # identity column and collection-level slot. # @noRd .fmrFromEntries <- function(x, entries) { - grl <- GenomicRanges::GRangesList(map(entries, rowVariants)) - md <- mcols(x, use.names = FALSE) - md$susieFit <- S4Vectors::SimpleList(map(entries, getSusieFit)) - md$cvResult <- S4Vectors::SimpleList(map(entries, getCvResult)) - mcols(grl) <- md + grl <- `mcols<-`( + GenomicRanges::GRangesList(map(entries, rowVariants)), + value = .withEntryPayload(mcols(x, use.names = FALSE), entries) + ) new(class(x), grl, ldSketch = .asLdSketch(getLdSketch(x))) } @@ -534,8 +549,7 @@ setMethod("getRetainedMass", "FineMappingResultBase", function(x, ...) { if (nrow(x) == 0L) { return(.rcEmptyMass(x)) } - parts <- map(seq_len(nrow(x)), .rcMassForRow, x = x) - parts <- compact(parts) + parts <- compact(map(seq_len(nrow(x)), .rcMassForRow, x = x)) if (length(parts) == 0L) { return(.rcEmptyMass(x)) } @@ -691,8 +705,8 @@ setMethod("fsusieCredibleBand", "FineMappingResultBase", function(x, ...) { #' @rdname fsusieAffectedRegions #' @export setMethod("fsusieAffectedRegions", "FineMappingResultBase", function(x, ...) { - grs <- map(seq_len(nrow(x)), .fsusieEntryAffectedRegions, x = x) - grs <- grs[lengths(grs) > 0L] + perRow <- map(seq_len(nrow(x)), .fsusieEntryAffectedRegions, x = x) + grs <- perRow[lengths(perRow) > 0L] if (length(grs) == 0L) { return(GenomicRanges::GRanges()) } @@ -751,6 +765,7 @@ setMethod( # Resolve the single pinned entry and return its GRanges view (aggregating # across multiple entries requires type = "data.frame"). # @noRd +#' @importFrom rlang try_fetch .fmrbTopLociGranges <- function( x, study, @@ -761,7 +776,7 @@ setMethod( signalCutoff, minPurity ) { - sel <- tryCatch( + sel <- try_fetch( .fmrSelectEntry( x, study = study, @@ -770,7 +785,7 @@ setMethod( method = method, region = region ), - error = function(e) e + error = function(cnd) cnd ) if (inherits(sel, "error")) { msg <- glue( @@ -867,7 +882,9 @@ setMethod("resolveWeights", "FineMappingResultBase", function(x, ...) { # The per-variant weight of the row a selector pins. Defined on the # collection because that is what getFineMappingResult() now returns; the # body is the per-row primitive, so the two cannot drift. - .fmrRowResolveWeights(.fmrSelectEntry(x, ...), ...) + # `...` is the row selector; it is consumed by .fmrSelectEntry and has + # no meaning to the per-row primitive, so it is not forwarded twice. + .fmrRowResolveWeights(.fmrSelectEntry(x, ...)) }) #' @rdname getVariantIds diff --git a/R/AllGenerics.R b/R/AllGenerics.R index f69815b4..a3ac7f96 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -50,6 +50,8 @@ NULL #' @param annotations An \code{AnnotationMatrix} object, or NULL for #' unstratified estimation. #' @param local Logical, whether to compute per-block local estimates. +#' @param estimatorArgs Optional named list of estimator-specific options +#' (\code{lambda} for lder / gldsc / hdl, \code{nIter} for sldsc). #' @param ... Additional method-specific arguments. #' @param study Character (length 1) or \code{NULL}. Restrict the selection to #' this study; \code{NULL} matches all studies. @@ -139,6 +141,8 @@ setGeneric("computeLdScores", function(ldRef, annotations = NULL, ...) { #' inferred from file extension. #' @param ... The keyword source arguments described above, plus any further #' arguments forwarded to the format-specific reader. +#' @param vcfArgs Optional named list of arguments forwarded to +#' \code{VariantAnnotation::readVcf} when the source is a VCF. #' @return A \code{RangedSummarizedExperiment} of variants x samples. #' @seealso \code{\link{computeLd}} #' @examples diff --git a/R/AnnotationMatrix.R b/R/AnnotationMatrix.R index 2f100a29..244e1241 100644 --- a/R/AnnotationMatrix.R +++ b/R/AnnotationMatrix.R @@ -38,26 +38,35 @@ setClass( # The tier/type vocabulary is the only thing left to check: the SNP-by- # annotation shape is now enforced by SummarizedExperiment itself. # @noRd +#' @importFrom checkmate makeAssertCollection assertNames assertSubset .validateAnnotationMatrix <- function(object) { - errors <- character() + coll <- makeAssertCollection() cd <- SummarizedExperiment::colData(object) - required <- c("name", "tier", "type") - if (!all(is_in(required, colnames(cd)))) { - return("annotationMeta must have columns: name, tier, type") - } - if (!all(is_in(cd$tier, c("baseline", "candidate")))) { - errors <- c( - errors, - "annotationMeta$tier must be 'baseline' or 'candidate'" - ) - } - if (!all(is_in(cd$type, c("binary", "continuous")))) { - errors <- c( - errors, - "annotationMeta$type must be 'binary' or 'continuous'" - ) + assertNames( + colnames(cd), + must.include = c("name", "tier", "type"), + what = "colnames", + .var.name = "annotationMeta", + add = coll + ) + # The value checks below read those columns; without them they would + # report the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } - if (length(errors) == 0) TRUE else errors + assertSubset( + cd$tier, + c("baseline", "candidate"), + .var.name = "annotationMeta$tier", + add = coll + ) + assertSubset( + cd$type, + c("binary", "continuous"), + .var.name = "annotationMeta$type", + add = coll + ) + coll$getMessages() } #' @rdname show-methods @@ -86,8 +95,10 @@ setMethod("show", "AnnotationMatrix", function(object) { #' @rdname getGenome #' @export setMethod("getGenome", "AnnotationMatrix", function(x, ...) { - build <- unique(GenomeInfoDb::genome(SummarizedExperiment::rowRanges(x))) - build <- build[!is.na(build)] + build <- discard( + unique(GenomeInfoDb::genome(SummarizedExperiment::rowRanges(x))), + is.na + ) if (length(build) == 0L) NA_character_ else build[[1L]] }) @@ -114,6 +125,7 @@ setMethod("getGenome", "AnnotationMatrix", function(x, ...) { if (!all(is_in(requiredCols, colnames(annotationMeta)))) { abort("annotationMeta must have columns: name, tier, type") } + # NOT assertMatrix: `annotations` may be a sparse Matrix, not a base one. if (ncol(annotations) != nrow(annotationMeta)) { abort(glue( "`annotations` has {ncol(annotations)} column(s) for ", @@ -150,21 +162,24 @@ AnnotationMatrix <- function( genome = "hg19" ) { .amCheckInputs(annotations, annotationMeta) - if (is.null(colnames(annotations))) { - colnames(annotations) <- annotationMeta$name - } + annotations <- `colnames<-`( + annotations, + colnames(annotations) %||% annotationMeta$name + ) if (nrow(annotations) != length(snpRanges)) { abort(glue( "`annotations` has {nrow(annotations)} row(s) for ", "{length(snpRanges)} SNP range(s); the rows must match." )) } - if (!is.null(genome) && length(genome) == 1L && !is.na(genome)) { - GenomeInfoDb::genome(snpRanges) <- genome + named <- if (!is.null(genome) && length(genome) == 1L && !is.na(genome)) { + GenomeInfoDb::`genome<-`(snpRanges, value = genome) + } else { + snpRanges } se <- SummarizedExperiment::SummarizedExperiment( assays = list(annotations = annotations), - rowRanges = snpRanges, + rowRanges = named, # Keyed off the assay's own colnames, not annotationMeta$name: # SummarizedExperiment requires the two to agree, and the previous # class let them diverge, so taking the name column would reject @@ -187,7 +202,9 @@ AnnotationMatrix <- function( # rows, the assay and the per-annotation table aligned, where the previous # implementation rebuilt the object from three separately-subset pieces. # @noRd +#' @importFrom checkmate assertClass .annotTier <- function(annot, tier) { + assertClass(annot, "AnnotationMatrix") annot[, SummarizedExperiment::colData(annot)$tier == tier] } diff --git a/R/ColocBoostResult.R b/R/ColocBoostResult.R index 203e2329..70a0a474 100644 --- a/R/ColocBoostResult.R +++ b/R/ColocBoostResult.R @@ -90,26 +90,25 @@ methods::setValidity("ColocBoostResult", function(object) { } # @noRd +#' @importFrom checkmate makeAssertCollection assertNames checkNames +#' @importFrom checkmate checkSubset .validateColocBoostResult <- function(object) { - errors <- .cbrCheckRequiredCols(object) - if (length(errors) == 0L) { - errors <- c( - .cbrCheckVcpColumn(object), - .cbrCheckOutcomeInfo(object) - ) - } - if (length(errors) == 0L) TRUE else errors -} - -# @noRd -.cbrCheckRequiredCols <- function(object) { - md <- mcols(object, use.names = FALSE) - have <- if (is.null(md)) character(0) else colnames(md) - missingCols <- setdiff(.cbrRequiredCols(), have) - if (length(missingCols) > 0L) { - return(str_c("missing columns: ", str_flatten(missingCols, ", "))) + coll <- makeAssertCollection() + assertNames( + colnames(mcols(object, use.names = FALSE)) %||% character(0), + must.include = .cbrRequiredCols(), + what = "colnames", + .var.name = "mcols", + add = coll + ) + # The checks below read those columns; running them on an object missing + # them reports the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } - NULL + coll$push(.cbrCheckVcpColumn(object)) + coll$push(.cbrCheckOutcomeInfo(object)) + coll$getMessages() } # The per-variant layer is the point of the class, exactly as SNP.PP.H4 is for @@ -145,28 +144,23 @@ methods::setValidity("ColocBoostResult", function(object) { if (nrow(info) == 0L) { return(NULL) } - missingCols <- setdiff( - c("name", "study", "context", "trait", "dataForm"), - colnames(info) + cols <- checkNames( + colnames(info), + must.include = c("name", "study", "context", "trait", "dataForm"), + what = "colnames" ) - if (length(missingCols) > 0L) { - return(str_c( - "outcomeInfo is missing columns: ", - str_flatten(missingCols, ", ") - )) + if (!isTRUE(cols)) { + return(str_c("outcomeInfo is missing columns: ", cols)) } if (length(object) == 0L) { return(NULL) } named <- unique(unlist(mcols(object, use.names = FALSE)$outcomes)) - unknown <- setdiff(named, as.character(info$name)) - if (length(unknown) == 0L) { + resolved <- checkSubset(named, as.character(info$name)) + if (isTRUE(resolved)) { return(NULL) } - str_c( - "outcome(s) not present in outcomeInfo: ", - str_flatten(utils::head(unknown, 5L), ", ") - ) + str_c("outcome(s) not in outcomeInfo: ", resolved) } # ---- accessors -------------------------------------------------------------- @@ -256,8 +250,9 @@ ColocBoostResult <- function( analysis = analysis, gwasStudy = gwasStudy, includeUncolocalized = includeUncolocalized - ) - rows <- unlist(rows, recursive = FALSE, use.names = FALSE) + ) |> + list_flatten() |> + unname() .cbrAssemble( rows, outcomeInfo = as.data.frame(outcomeInfo), @@ -275,10 +270,12 @@ ColocBoostResult <- function( if (is.null(res)) { return(list()) } - out <- .cbrColocalizedRows(res, analysis[[i]], gwasStudy[[i]]) - if (isTRUE(includeUncolocalized)) { - out <- c(out, .cbrUncolocalizedRows(res, analysis[[i]], gwasStudy[[i]])) - } + out <- c( + .cbrColocalizedRows(res, analysis[[i]], gwasStudy[[i]]), + if (isTRUE(includeUncolocalized)) { + .cbrUncolocalizedRows(res, analysis[[i]], gwasStudy[[i]]) + } + ) out } @@ -381,15 +378,15 @@ ColocBoostResult <- function( # The cos_summary row for one set, or an empty tibble when absent. # @noRd .cbrSummaryFor <- function(res, id) { - s <- res$cos_summary - if (is.null(s) || nrow(s) == 0L || !is_in("cos_id", colnames(s))) { + raw <- res$cos_summary + if (is.null(raw) || nrow(raw) == 0L || !is_in("cos_id", colnames(raw))) { return(tibble( top_variable = NA_character_, top_variable_vcp = NA_real_, focal_outcome = NA )) } - s <- as.data.frame(s, stringsAsFactors = FALSE) + s <- as.data.frame(raw, stringsAsFactors = FALSE) hit <- which(as.character(s$cos_id) == id) if (length(hit) == 0L) { return(tibble( @@ -456,10 +453,13 @@ ColocBoostResult <- function( if (is.null(ids)) { next } - gr <- .variantIdsToGRanges(ids, what = "colocboost vcp names") - mcols(gr) <- cbind( - mcols(gr, use.names = FALSE), - S4Vectors::DataFrame(vcp = as.numeric(res$vcp)) + bare <- .variantIdsToGRanges(ids, what = "colocboost vcp names") + gr <- S4Vectors::`mcols<-`( + bare, + value = cbind( + mcols(bare, use.names = FALSE), + S4Vectors::DataFrame(vcp = as.numeric(res$vcp)) + ) ) return(gr) } @@ -475,8 +475,10 @@ ColocBoostResult <- function( computingTime ) { elements <- map(rows, .cbrElementFor) - grl <- GenomicRanges::GRangesList(elements) - mcols(grl) <- .cbrMcolsFor(rows) + grl <- S4Vectors::`mcols<-`( + GenomicRanges::GRangesList(elements), + value = .cbrMcolsFor(rows) + ) obj <- new( "ColocBoostResult", grl, @@ -492,33 +494,42 @@ ColocBoostResult <- function( # @noRd .cbrElementFor <- function(row) { v <- row$variants - gr <- .variantIdsToGRanges( + bare <- .variantIdsToGRanges( as.character(v$variant_id), what = "colocboost variant name" ) # Appended, not assigned: the A1 / A2 columns .variantIdsToGRanges() # attaches are the variant identity, and overwriting mcols would leave the # element unable to name its own variants. - mcols(gr) <- cbind( - mcols(gr, use.names = FALSE), - S4Vectors::DataFrame(vcp = as.numeric(v$vcp)) + gr <- S4Vectors::`mcols<-`( + bare, + value = cbind( + mcols(bare, use.names = FALSE), + S4Vectors::DataFrame(vcp = as.numeric(v$vcp)) + ) ) gr } # @noRd .cbrMcolsFor <- function(rows) { - if (length(rows) == 0L) { - md <- S4Vectors::DataFrame(.cbrEmptyMeta()) - md$outcomes <- IRanges::CharacterList() - return(md) - } - meta <- bind_rows(map(rows, "meta")) - md <- S4Vectors::DataFrame(meta, check.names = FALSE) # A CharacterList column, so a set of any size lives in one row instead of # being flattened to a delimited string a caller has to re-split. - md$outcomes <- IRanges::CharacterList(map(rows, "outcomes")) - md + if (length(rows) == 0L) { + return(cbind( + S4Vectors::DataFrame(.cbrEmptyMeta()), + S4Vectors::DataFrame(outcomes = IRanges::CharacterList()) + )) + } + cbind( + S4Vectors::DataFrame( + bind_rows(map(rows, "meta")), + check.names = FALSE + ), + S4Vectors::DataFrame( + outcomes = IRanges::CharacterList(map(rows, "outcomes")) + ) + ) } # @noRd @@ -550,10 +561,11 @@ setMethod("getColocPairs", "ColocBoostResult", function(x, ...) { return(tibble()) } flat <- as.data.frame(md[, setdiff(colnames(md), "outcomes")]) - out <- as_tibble(flat, .name_repair = "minimal") - out$outcomes <- map_chr(as.list(md$outcomes), str_flatten, collapse = "; ") - out$nOutcomes <- lengths(md$outcomes) - out + mutate( + as_tibble(flat, .name_repair = "minimal"), + outcomes = map_chr(as.list(md$outcomes), str_flatten, collapse = "; "), + nOutcomes = lengths(md$outcomes) + ) }) #' @rdname colocViews @@ -590,10 +602,11 @@ setMethod( n <- lengths(x) setIdx <- rep(seq_len(length(x)), n) flat <- unlist(x, use.names = FALSE) - out <- as_tibble(md[setIdx, , drop = FALSE], .name_repair = "minimal") - out$variant_id <- .grVariantIds(flat) - out$vcp <- as.numeric(mcols(flat, use.names = FALSE)$vcp) - out + mutate( + as_tibble(md[setIdx, , drop = FALSE], .name_repair = "minimal"), + variant_id = .grVariantIds(flat), + vcp = as.numeric(mcols(flat, use.names = FALSE)$vcp) + ) } #' @title ColocBoost Outcome View @@ -625,11 +638,13 @@ setMethod("getColocBoostOutcomes", "ColocBoostResult", function(x, ...) { outcomes <- as.list(md$outcomes) reps <- lengths(outcomes) flat <- as.data.frame(md[, setdiff(colnames(md), "outcomes"), drop = FALSE]) - out <- as_tibble( - flat[rep(seq_len(nrow(flat)), reps), , drop = FALSE], - .name_repair = "minimal" + out <- mutate( + as_tibble( + flat[rep(seq_len(nrow(flat)), reps), , drop = FALSE], + .name_repair = "minimal" + ), + outcome = unlist(outcomes, use.names = FALSE) ) - out$outcome <- unlist(outcomes, use.names = FALSE) info <- x@outcomeInfo if (nrow(info) == 0L) { return(out) diff --git a/R/ColocResult.R b/R/ColocResult.R index 60b3fd18..ec17c2fa 100644 --- a/R/ColocResult.R +++ b/R/ColocResult.R @@ -78,15 +78,24 @@ methods::setValidity("ColocResult", function(object) { }) # @noRd +#' @importFrom checkmate makeAssertCollection assertNames checkNames .validateColocResult <- function(object) { - errors <- .crCheckRequiredCols(object) - if (length(errors) == 0L) { - errors <- c( - .crCheckPpColumns(object), - .crCheckVariantColumn(object) - ) + coll <- makeAssertCollection() + assertNames( + colnames(mcols(object, use.names = FALSE)) %||% character(0), + must.include = .crRequiredCols(), + what = "colnames", + .var.name = "mcols", + add = coll + ) + # The checks below read those columns; running them on an object missing + # them reports the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } - if (length(errors) == 0L) TRUE else errors + coll$push(.crCheckPpColumns(object)) + coll$push(.crCheckVariantColumn(object)) + coll$getMessages() } # @noRd @@ -112,28 +121,19 @@ methods::setValidity("ColocResult", function(object) { str_c("PP.H", 0:4, ".abf") } -# @noRd -.crCheckRequiredCols <- function(object) { - md <- mcols(object, use.names = FALSE) - have <- if (is.null(md)) character(0) else colnames(md) - missingCols <- setdiff(.crRequiredCols(), have) - if (length(missingCols) > 0L) { - return(str_c("missing columns: ", str_flatten(missingCols, ", "))) - } - NULL -} - +# The posterior columns are a distinct contract from the identity columns +# above, so they keep their own wording. # @noRd .crCheckPpColumns <- function(object) { - md <- mcols(object, use.names = FALSE) - missingCols <- setdiff(.crPpCols(), colnames(md)) - if (length(missingCols) > 0L) { - return(str_c( - "missing posterior columns: ", - str_flatten(missingCols, ", ") - )) + res <- checkNames( + colnames(mcols(object, use.names = FALSE)), + must.include = .crPpCols(), + what = "colnames" + ) + if (isTRUE(res)) { + return(NULL) } - NULL + str_c("missing posterior columns: ", res) } # The per-variant layer is the whole point of the class, so an element without @@ -227,13 +227,15 @@ ColocResult <- function(pairs, variants, ldSketch = NULL) { abort(msg) } elements <- map(variants, .crVariantsToGRanges) - grl <- GenomicRanges::GRangesList(elements) # Set unconditionally, including at zero rows: an empty result still has to # carry the column schema, or it fails validity and a caller reading # `result$PP.H4.abf` gets NULL exactly when there is nothing to report. - mcols(grl) <- exec( - S4Vectors::DataFrame, - !!!c(as.list(pairs), list(check.names = FALSE)) + grl <- S4Vectors::`mcols<-`( + GenomicRanges::GRangesList(elements), + value = exec( + S4Vectors::DataFrame, + !!!c(as.list(pairs), list(check.names = FALSE)) + ) ) obj <- new("ColocResult", grl, ldSketch = .asLdSketch(ldSketch)) validObject(obj) @@ -267,8 +269,10 @@ ColocResult <- function(pairs, variants, ldSketch = NULL) { S4Vectors::DataFrame, !!!c(as.list(v[keep]), list(check.names = FALSE)) ) - mcols(gr) <- cbind(mcols(gr, use.names = FALSE), extra) - gr + S4Vectors::`mcols<-`( + gr, + value = cbind(mcols(gr, use.names = FALSE), extra) + ) } # Pivot coloc.bf_bf's WIDE $results (one SNP.PP.H4.rowK column per $summary @@ -357,11 +361,13 @@ setMethod("getColocVariants", "ColocResult", function(x, pooled = FALSE, ...) { n <- lengths(x) pairIdx <- rep(seq_len(length(x)), n) flat <- unlist(x, use.names = FALSE) - out <- as_tibble(md[pairIdx, , drop = FALSE], .name_repair = "minimal") - out$variant_id <- .grVariantIds(flat) - out$SNP.PP.H4 <- as.numeric(mcols(flat, use.names = FALSE)$SNP.PP.H4) - out$colocPp <- out$PP.H4.abf * out$SNP.PP.H4 - out + snpPp <- as.numeric(mcols(flat, use.names = FALSE)$SNP.PP.H4) + as_tibble(md[pairIdx, , drop = FALSE], .name_repair = "minimal") |> + mutate( + variant_id = .grVariantIds(flat), + SNP.PP.H4 = snpPp, + colocPp = .data$PP.H4.abf * snpPp + ) } # Pool per-variant posteriors to the gene tier, by the section 3.5 rule: sum @@ -450,14 +456,15 @@ setMethod( # Filtering happens BEFORE any LD work, so a stricter threshold costs # strictly less -- which is the reason purity lives on the accessor # rather than being precomputed at construction. - sets <- map(keep, .crCsForPair, x = x, coverage = coverage) - sets <- compact(sets) + sets <- compact(map(keep, .crCsForPair, x = x, coverage = coverage)) if (length(sets) == 0L) { return(tibble()) } out <- bind_rows(sets) - out$purity <- .crPuritiesFor(out, getLdSketch(x)) - .crApplyPurityFilter(out, minAbsCorr) + .crApplyPurityFilter( + mutate(out, purity = .crPuritiesFor(out, getLdSketch(x))), + minAbsCorr + ) } ) @@ -469,14 +476,18 @@ setMethod( return(integer(0)) } md <- as.data.frame(mcols(x, use.names = FALSE)) - ok <- rep(TRUE, nrow(md)) - if (!is.null(minPp4)) { - ok <- ok & md$PP.H4.abf >= minPp4 + byPp4 <- if (is.null(minPp4)) { + rep(TRUE, nrow(md)) + } else { + md$PP.H4.abf >= minPp4 } - if (isTRUE(requireMaxH4)) { + byMaxH4 <- if (isTRUE(requireMaxH4)) { pp <- as.matrix(md[, .crPpCols(), drop = FALSE]) - ok <- ok & (max.col(pp, ties.method = "first") == 5L) + max.col(pp, ties.method = "first") == 5L + } else { + TRUE } + ok <- byPp4 & byMaxH4 which(ok & !is.na(ok)) } @@ -499,13 +510,14 @@ setMethod( members <- ord[seq_len(nKeep)] ids <- .grVariantIds(g[members]) md <- as.data.frame(mcols(x, use.names = FALSE))[i, , drop = FALSE] - row <- as_tibble(md, .name_repair = "minimal") - row$csSize <- length(members) - row$csCoverage <- cum[[nKeep]] - row$leadVariant <- ids[[1L]] - row$leadPp <- pp[ord][[1L]] - row$csVariants <- list(ids) - row + mutate( + as_tibble(md, .name_repair = "minimal"), + csSize = length(members), + csCoverage = cum[[nKeep]], + leadVariant = ids[[1L]], + leadPp = pp[ord][[1L]], + csVariants = list(ids) + ) } # Index of the first cumulative value reaching `target`; the whole vector when @@ -532,19 +544,20 @@ setMethod( } # @noRd +#' @importFrom rlang try_fetch .crPurityOne <- function(ids, ldSketch) { # A singleton set has no pair to correlate, and susie treats it as pure. if (length(ids) < 2L) { return(1) } - ld <- tryCatch( + ld <- try_fetch( .ldFromSketch( ldSketch, ids, label = "getColocCredibleSets", onMissing = "drop" ), - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(ld) || nrow(ld) < 2L) { return(NA_real_) diff --git a/R/CtwasResult.R b/R/CtwasResult.R index b14e89a0..388e687c 100644 --- a/R/CtwasResult.R +++ b/R/CtwasResult.R @@ -37,22 +37,23 @@ setClass("CtwasResult", contains = "DFrame", validity = function(object) { # Collect all contract violations (empty vector = valid). Entry checks run only # once the required columns are present. # @noRd +#' @importFrom checkmate makeAssertCollection assertNames .validateCtwasResult <- function(object) { - errors <- .ctwasResCheckRequiredCols(object) - if (length(errors) == 0L) { - errors <- .ctwasResCheckEntries(object) - } - if (length(errors) == 0L) TRUE else errors -} - -# @noRd -.ctwasResCheckRequiredCols <- function(object) { - required <- c("gwasStudy", "study", "context", "method", "entry") - missingCols <- setdiff(required, names(object)) - if (length(missingCols) > 0L) { - return(str_c("missing columns: ", str_flatten(missingCols, ", "))) + coll <- makeAssertCollection() + assertNames( + names(object), + must.include = c("gwasStudy", "study", "context", "method", "entry"), + what = "colnames", + .var.name = "columns", + add = coll + ) + # The checks below read those columns; running them on an object missing + # them reports the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } - NULL + coll$push(.ctwasResCheckEntries(object)) + coll$getMessages() } # @noRd @@ -89,7 +90,7 @@ setClass("CtwasResult", contains = "DFrame", validity = function(object) { # @noRd .ctwasResCheckJointCols <- function(object, jointCols) { - unlist(compact(map(jointCols, .ctwasResJointColError, object = object))) + list_c(compact(map(jointCols, .ctwasResJointColError, object = object))) } # @noRd @@ -123,6 +124,16 @@ setClass("CtwasResult", contains = "DFrame", validity = function(object) { object[[cn]] } +# Each joint-provenance column must be one value per row. +# @noRd +.ctwasCheckJointColLength <- function(nm, val, n) { + if (length(val) == n) { + return(invisible(NULL)) + } + msg <- glue("`{nm}` must have the same length as `gwasStudy`.") + abort(msg) +} + #' @title Create a CtwasResult Collection #' @description Construct a \code{CtwasResult} DFrame-subclass collection of #' cTWAS runs from per-tuple vectors and a list of @@ -177,18 +188,16 @@ CtwasResult <- function( method = as.character(method), entry = S4Vectors::SimpleList(entry) ) - for (nm in c("jointStudies", "jointContexts")) { - val <- get(nm) - if (is.null(val)) { - next - } - if (length(val) != n) { - msg <- glue("`{nm}` must have the same length as `gwasStudy`.") - abort(msg) - } - cols[[nm]] <- as.character(val) - } - dfArgs <- c(cols, list(check.names = FALSE)) + supplied <- compact(list( + jointStudies = jointStudies, + jointContexts = jointContexts + )) + walk2(names(supplied), supplied, .ctwasCheckJointColLength, n = n) + dfArgs <- c( + cols, + map(supplied, as.character), + list(check.names = FALSE) + ) df <- exec(S4Vectors::DataFrame, !!!dfArgs) obj <- new("CtwasResult", df) validObject(obj) @@ -219,8 +228,9 @@ setMethod("getContexts", "CtwasResult", function(x) { if (n == 0L) { return(NULL) } - parts <- map(seq_len(n), .ctwasAggregateRow, x = x, getter = getter) - parts <- compact(parts) + parts <- compact( + map(seq_len(n), .ctwasAggregateRow, x = x, getter = getter) + ) if (length(parts) == 0L) { return(NULL) } diff --git a/R/GenotypeHandle.R b/R/GenotypeHandle.R index 8a5bc7c4..6e20b70d 100644 --- a/R/GenotypeHandle.R +++ b/R/GenotypeHandle.R @@ -49,36 +49,27 @@ setClass( chromPaths = character(0) ), validity = function(object) { - errors <- character() - if (length(object@path) != 1L) { - errors <- c(errors, "'path' must be a single character string") - } - valid_formats <- c("gds", "vcf", "plink1", "plink2") - if (!is_in(object@format, valid_formats)) { - errors <- c( - errors, + validFormats <- c("gds", "vcf", "plink1", "plink2") + nm <- names(object@chromPaths) + badChromPaths <- length(object@chromPaths) > 0L && + (is.null(nm) || any(str_length(nm) == 0L) || anyDuplicated(nm)) + errors <- c( + if (length(object@path) != 1L) { + "'path' must be a single character string" + }, + if (!is_in(object@format, validFormats)) { str_c( "'format' must be one of: ", - str_flatten(valid_formats, ", ") + str_flatten(validFormats, ", ") ) - ) - } - if (length(object@chromPaths) > 0L) { - nm <- names(object@chromPaths) - if ( - is.null(nm) || - any(str_length(nm) == 0L) || - anyDuplicated(nm) - ) { - errors <- c( - errors, - str_c( - "'chromPaths' must be a uniquely-named ", - "character vector (names = chromosomes)" - ) + }, + if (badChromPaths) { + str_c( + "'chromPaths' must be a uniquely-named ", + "character vector (names = chromosomes)" ) } - } + ) if (length(errors) == 0) TRUE else errors } ) @@ -166,7 +157,8 @@ setMethod("show", "GenotypeHandle", function(object) { #' shard is read (so the caller's own absence check can report the mismatch). #' Only meaningful with \code{genoMeta}; supplying it with any other source is #' an error (a single-file panel has no per-chromosome shards to skip). -#' @param ... Additional arguments forwarded to the format-specific reader. +#' @param vcfArgs Optional named list of arguments forwarded to +#' \code{VariantAnnotation::readVcf} when the source is a VCF. #' @return A \code{GenotypeHandle} object. #' @keywords internal GenotypeHandle <- function( @@ -183,47 +175,64 @@ GenotypeHandle <- function( region = NULL, genoMeta = NULL, chroms = NULL, - ... + format = NULL, + vcfArgs = list() ) { - p <- as.list(environment()) - flags <- .ghValidateArgs(p) - sources <- .ghResolveSources(p, flags) + flags <- .ghValidateArgs( + bed = bed, + bim = bim, + fam = fam, + pgen = pgen, + pvar = pvar, + psam = psam, + ldMeta = ldMeta, + region = region + ) + sources <- .ghResolveSources( + path = path, + plink1Prefix = plink1Prefix, + plink2Prefix = plink2Prefix, + ldMeta = ldMeta, + genoMeta = genoMeta, + chroms = chroms, + flags = flags + ) if (sources[["path"]]) { - return(.readGenotypeHandle(path, ...)) + return(.readGenotypeHandle(path, format = format, vcfArgs = vcfArgs)) } if (sources[["plink1Prefix"]]) { - return(.makePlink1Handle(plink1Prefix, ...)) + return(.makePlink1Handle(plink1Prefix)) } if (sources[["plink2Prefix"]]) { - return(.makePlink2Handle(plink2Prefix, ...)) + return(.makePlink2Handle(plink2Prefix)) } if (sources[["plink1Triplet"]]) { - return(.genotypeHandleFromPlink1Triplet(bed, bim, fam, ...)) + return(.genotypeHandleFromPlink1Triplet(bed, bim, fam)) } if (sources[["plink2Triplet"]]) { - return(.genotypeHandleFromPlink2Triplet(pgen, pvar, psam, ...)) + return(.genotypeHandleFromPlink2Triplet(pgen, pvar, psam)) } if (sources[["ldMeta"]]) { - return(.genotypeHandleFromLdMeta(ldMeta, region, ...)) + return(.genotypeHandleFromLdMeta(ldMeta, region, vcfArgs = vcfArgs)) } # nSources == 1 is enforced above, so the only remaining source is genoMeta. - .genotypeHandleFromChromMeta(genoMeta, chroms = chroms, ...) + .genotypeHandleFromChromMeta(genoMeta, chroms = chroms, format = format) } # Validate the bed/bim/fam + pgen/pvar/psam triplet completeness and the # ldMeta<->region coupling. Returns list(bedComplete, pgenComplete). # @noRd -.ghValidateArgs <- function(p) { - bedComplete <- .ghTrioComplete(p$bed, p$bim, p$fam, "bed/bim/fam") - pgenComplete <- .ghTrioComplete(p$pgen, p$pvar, p$psam, "pgen/pvar/psam") - if (!is.null(p$ldMeta) && is.null(p$region)) { +.ghValidateArgs <- function(bed, bim, fam, pgen, pvar, psam, ldMeta, region) { + bedComplete <- .ghTrioComplete(bed, bim, fam, "bed/bim/fam") + pgenComplete <- .ghTrioComplete(pgen, pvar, psam, "pgen/pvar/psam") + if (!is.null(ldMeta) && is.null(region)) { msg <- glue( "`ldMeta` requires a `region` (a 'chr:start-end' string or a ", "one-row data.frame with chrom/start/end)." ) abort(msg) } - if (is.null(p$ldMeta) && !is.null(p$region)) { + if (is.null(ldMeta) && !is.null(region)) { abort("`region` is only meaningful when `ldMeta` is supplied.") } list(bedComplete = bedComplete, pgenComplete = pgenComplete) @@ -246,15 +255,23 @@ GenotypeHandle <- function( # Build the exactly-one-source indicator vector; error unless exactly one input # source was supplied, and gate `chroms` to the genoMeta path. # @noRd -.ghResolveSources <- function(p, flags) { +.ghResolveSources <- function( + path, + plink1Prefix, + plink2Prefix, + ldMeta, + genoMeta, + chroms, + flags +) { sources <- c( - path = !is.null(p$path), - plink1Prefix = !is.null(p$plink1Prefix), - plink2Prefix = !is.null(p$plink2Prefix), + path = !is.null(path), + plink1Prefix = !is.null(plink1Prefix), + plink2Prefix = !is.null(plink2Prefix), plink1Triplet = flags$bedComplete, plink2Triplet = flags$pgenComplete, - ldMeta = !is.null(p$ldMeta), - genoMeta = !is.null(p$genoMeta) + ldMeta = !is.null(ldMeta), + genoMeta = !is.null(genoMeta) ) if (sum(sources) != 1L) { nSrc <- sum(sources) @@ -265,7 +282,7 @@ GenotypeHandle <- function( ) abort(msg) } - if (!is.null(p$chroms) && !sources[["genoMeta"]]) { + if (!is.null(chroms) && !sources[["genoMeta"]]) { msg <- glue( "`chroms` restricts which per-chromosome shards are read and is ", "only supported with `genoMeta` (a single-file panel has no ", @@ -276,9 +293,9 @@ GenotypeHandle <- function( sources } -.genotypeHandleFromLdMeta <- function(ldMeta, region, ...) { +.genotypeHandleFromLdMeta <- function(ldMeta, region, vcfArgs = list()) { ldPath <- .ghResolveLdPath(ldMeta, region) - .ghLdPathToHandle(ldPath, ...) + .ghLdPathToHandle(ldPath, vcfArgs = vcfArgs) } # Resolve the single genotype-payload path for `region` from an LD meta, @@ -320,24 +337,22 @@ GenotypeHandle <- function( # Dispatch a resolved genotype path to the format-specific reader by extension. # @noRd -.ghLdPathToHandle <- function(ldPath, ...) { +.ghLdPathToHandle <- function(ldPath, vcfArgs = list()) { lower <- str_to_lower(ldPath) if (str_detect(lower, "\\.vcf(\\.b?gz)?$") || str_ends(lower, "\\.bcf")) { - return(.readGenotypeHandle(ldPath, format = "vcf", ...)) + return(.readGenotypeHandle(ldPath, format = "vcf", vcfArgs = vcfArgs)) } if (str_ends(lower, "\\.gds")) { - return(.readGenotypeHandle(ldPath, format = "gds", ...)) + return(.readGenotypeHandle(ldPath, format = "gds")) } if (str_ends(lower, "\\.bed")) { return(.makePlink1Handle( - str_remove(ldPath, regex("\\.bed$", ignore_case = TRUE)), - ... + str_remove(ldPath, regex("\\.bed$", ignore_case = TRUE)) )) } if (str_ends(lower, "\\.pgen")) { return(.makePlink2Handle( - str_remove(ldPath, regex("\\.pgen$", ignore_case = TRUE)), - ... + str_remove(ldPath, regex("\\.pgen$", ignore_case = TRUE)) )) } msg <- glue( @@ -348,12 +363,11 @@ GenotypeHandle <- function( abort(msg) } -.genotypeHandleFromPlink1Triplet <- function(bed, bim, fam, ...) { - for (f in list(bed = bed, bim = bim, fam = fam)) { - if (!is.character(f) || length(f) != 1L) { - abort("Each of `bed`, `bim`, `fam` must be a single file path.") - } - } +#' @importFrom checkmate assertString +.genotypeHandleFromPlink1Triplet <- function(bed, bim, fam) { + assertString(bed) + assertString(bim) + assertString(fam) stems <- c( bed = file_path_sans_ext(bed), bim = file_path_sans_ext(bim), @@ -371,10 +385,10 @@ GenotypeHandle <- function( ) abort(msg) } - .makePlink1Handle(unname(stems[1L]), ...) + .makePlink1Handle(unname(stems[1L])) } -.genotypeHandleFromPlink2Triplet <- function(pgen, pvar, psam, ...) { +.genotypeHandleFromPlink2Triplet <- function(pgen, pvar, psam) { for (f in list(pgen = pgen, pvar = pvar, psam = psam)) { if (!is.character(f) || length(f) != 1L) { abort("Each of `pgen`, `pvar`, `psam` must be a single file path.") @@ -398,7 +412,7 @@ GenotypeHandle <- function( ) abort(msg) } - .makePlink2Handle(unname(stems[1L]), ...) + .makePlink2Handle(unname(stems[1L])) } # --------------------------------------------------------------------------- @@ -414,8 +428,10 @@ GenotypeHandle <- function( # pecotmr). Such objects have no `chromPaths` slot, so a direct `@` access # errors; treat them as single-file handles. #' @keywords internal +#' @importFrom purrr possibly .genotypeChromPaths <- function(handle) { - tryCatch(getChromPaths(handle), error = function(e) character(0)) + # A handle with no chromosome paths is an ordinary outcome, not a fault. + possibly(getChromPaths, otherwise = character(0))(handle) } # Case-insensitive match of the first of `aliases` present in `cols`; falls @@ -578,18 +594,21 @@ GenotypeHandle <- function( # the other per-chromosome files are never opened, which is the I/O win when a # genome-wide panel backs summary statistics on only a few chromosomes. #' @keywords internal -.genotypeHandleFromChromMeta <- function(genoMeta, chroms = NULL, ...) { - format <- list(...)$format +.genotypeHandleFromChromMeta <- function( + genoMeta, + chroms = NULL, + format = NULL +) { parsed <- .parseChromMeta(genoMeta) if (nrow(parsed) == 0L) { abort( "GenotypeHandle(genoMeta): no chromosomes found in the meta input." ) } - parsed <- .chromMetaSelect(parsed, chroms) - shards <- map(parsed$path, .resolveGenotypeShard, format = format) + selected <- .chromMetaSelect(parsed, chroms) + shards <- map(selected$path, .resolveGenotypeShard, format = format) sharedFormat <- .chromMetaCheckFormats(shards) - .chromMetaCheckSamples(shards, parsed) + .chromMetaCheckSamples(shards, selected) unifiedSnpInfo <- bind_rows(map(shards, .ghSnpInfo)) new( "GenotypeHandle", @@ -652,23 +671,36 @@ GenotypeHandle <- function( invisible(NULL) } +# One shard's chromosome -> path mapping. +# @noRd +.chromShardPaths <- function(shard) { + chroms <- unique(canonChrom(getSnpInfo(shard)$CHR)) + set_names(rep(getPath(shard), length(chroms)), chroms) +} + +# A chromosome may only come from one file; two shards claiming it means the +# panel is not split cleanly per chromosome. +# @noRd +.checkChromNotSplit <- function(ch, count) { + if (count <= 1L) { + return(invisible(NULL)) + } + msg <- glue( + "GenotypeHandle(genoMeta): chromosome '{ch}' appears ", + "in more than one per-chromosome file." + ) + abort(msg) +} + # Map each chromosome to its shard path, erroring if a chromosome spans files. -# (Sequential uniqueness accumulation -- kept as a loop.) # @noRd .chromMetaPaths <- function(shards) { - chromPaths <- character(0) - for (i in seq_along(shards)) { - for (ch in unique(canonChrom(getSnpInfo(shards[[i]])$CHR))) { - if (is_in(ch, names(chromPaths))) { - msg <- glue( - "GenotypeHandle(genoMeta): chromosome '{ch}' appears ", - "in more than one per-chromosome file." - ) - abort(msg) - } - chromPaths[[ch]] <- getPath(shards[[i]]) - } + if (length(shards) == 0L) { + return(character(0)) } + chromPaths <- list_c(map(shards, .chromShardPaths)) + counts <- table(names(chromPaths)) + walk2(names(counts), as.integer(counts), .checkChromNotSplit) chromPaths } diff --git a/R/GwasFineMappingResult.R b/R/GwasFineMappingResult.R index 1792577f..28ef8813 100644 --- a/R/GwasFineMappingResult.R +++ b/R/GwasFineMappingResult.R @@ -35,23 +35,23 @@ setClass( # ---- GwasFineMappingResult validity helpers -------------------------------- # @noRd +#' @importFrom checkmate makeAssertCollection assertNames checkNames .validateGwasFineMappingResult <- function(object) { - errors <- .gfmrCheckRequiredCols(object) - if (length(errors) == 0L) { - errors <- .gfmrCheckEntries(object) - } - errors <- c(errors, .gfmrCheckLdSketch(object)) - if (length(errors) == 0L) TRUE else errors -} - -# @noRd -.gfmrCheckRequiredCols <- function(object) { - required <- c("study", "method") - missingCols <- setdiff(required, .tupleColumnNames(object)) - if (length(missingCols) > 0L) { - return(str_c("missing columns: ", str_flatten(missingCols, ", "))) + coll <- makeAssertCollection() + assertNames( + .tupleColumnNames(object), + must.include = c("study", "method"), + what = "colnames", + .var.name = "mcols", + add = coll + ) + # The checks below read those columns; running them on an object missing + # them reports the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } - NULL + coll$push(.gfmrCheckEntries(object)) + coll$getMessages() } # @noRd @@ -67,23 +67,17 @@ setClass( .gfmrCheckEntryLength <- function(object) { # The variants and their topLoci ARE the elements now, so what is left to # check is that the fit payload columns are present and parallel. - missingCols <- setdiff( - c("susieFit", "cvResult"), - .tupleColumnNames(object) + res <- checkNames( + .tupleColumnNames(object), + must.include = c("susieFit", "cvResult"), + what = "colnames" ) - if (length(missingCols) > 0L) { - return(str_c( - "missing entry payload columns: ", - str_flatten(missingCols, ", ") - )) + if (isTRUE(res)) { + return(NULL) } - NULL + str_c("missing entry payload columns: ", res) } -# @noRd - -# @noRd - # @noRd .gfmrCheckTupleUniqueness <- function(object) { # Keyed on the element's RANGE rather than on a region_id label. The range @@ -99,8 +93,8 @@ setClass( keyTbl <- as_tibble(set_names( map(keyCols, .gfmrColOf, object = object), keyCols - )) - keyTbl$range <- .rtlRangeKeys(object) + )) |> + mutate(range = .rtlRangeKeys(object)) if (nrow(distinct(keyTbl)) < nrow(keyTbl)) { return("(study, method, range) tuple uniqueness violated") } @@ -112,12 +106,6 @@ setClass( .tupleColumn(object, cn) } -# @noRd -.gfmrCheckLdSketch <- function(object) { - # The slot's class union enforces the type; nothing to check. - NULL -} - #' @title Create a GwasFineMappingResult Collection #' @description Construct a \code{GwasFineMappingResult} collection from @@ -170,17 +158,19 @@ GwasFineMappingResult <- function( method = as.character(method), susieFit = S4Vectors::SimpleList(map(entry, getSusieFit)), cvResult = S4Vectors::SimpleList(map(entry, getCvResult)) - ) - cols <- .appendBlockIdCol(cols, blockId, n) - cols <- .appendTraitPosCol(cols, traitPos, n) + ) |> + .appendBlockIdCol(blockId, n) |> + .appendTraitPosCol(traitPos, n) dfArgs <- c(cols, list(check.names = FALSE)) # Each entry's variants become one ELEMENT, its topLoci that element's # inner mcols, and its fit/cv payload outer mcols. A multi-seqname entry # splits by chromosome with its metadata row replicated. split <- .rtlSplitBySeqname(map(entry, rowVariants)) - grl <- GenomicRanges::GRangesList(split$entry) md <- exec(S4Vectors::DataFrame, !!!dfArgs) - mcols(grl) <- md[split$fromIdx, , drop = FALSE] + grl <- S4Vectors::`mcols<-`( + GenomicRanges::GRangesList(split$entry), + value = md[split$fromIdx, , drop = FALSE] + ) obj <- new( "GwasFineMappingResult", grl, diff --git a/R/JointGroup.R b/R/JointGroup.R index 4c2ef6de..31a9cf19 100644 --- a/R/JointGroup.R +++ b/R/JointGroup.R @@ -39,19 +39,17 @@ setClass( # one row per condition (Y/Z column) representation(conditions = "data.frame"), validity = function(object) { - errors <- character() - if ( + errors <- if ( !all(is_in( c("study", "context", "trait"), names(object@conditions) )) ) { - errors <- c( - errors, - "'conditions' must have columns 'study', 'context', 'trait'" - ) + "'conditions' must have columns 'study', 'context', 'trait'" } else if (nrow(object@conditions) < 1L) { - errors <- c(errors, "a group needs >= 1 condition (Y/Z column)") + "a group needs >= 1 condition (Y/Z column)" + } else { + character() } if (length(errors) == 0L) TRUE else errors } @@ -67,25 +65,23 @@ setClass( contains = "JointGroup", representation(X = "matrix", Y = "matrix", traitPos = "numeric"), validity = function(object) { - errors <- character() - if (nrow(object@X) != nrow(object@Y)) { - errors <- c(errors, "X and Y must share the sample (row) dimension") - } - if (ncol(object@Y) != nrow(object@conditions)) { - errors <- c(errors, "ncol(Y) must equal nrow(conditions)") - } - if ( - length(object@traitPos) > 0L && - length(object@traitPos) != ncol(object@Y) - ) { - errors <- c( - errors, + errors <- c( + if (nrow(object@X) != nrow(object@Y)) { + "X and Y must share the sample (row) dimension" + }, + if (ncol(object@Y) != nrow(object@conditions)) { + "ncol(Y) must equal nrow(conditions)" + }, + if ( + length(object@traitPos) > 0L && + length(object@traitPos) != ncol(object@Y) + ) { str_c( "when set, 'traitPos' must have one entry per TRAIT ", "(Y column), not per variant" ) - ) - } + } + ) if (length(errors) == 0L) TRUE else errors } ) @@ -101,19 +97,17 @@ setClass( # path in fineMappingPipeline already does. representation(Z = "matrix", ldSketch = "LdSketchOrNULL", N = "numeric"), validity = function(object) { - errors <- character() - if (ncol(object@Z) != nrow(object@conditions)) { - errors <- c(errors, "ncol(Z) must equal nrow(conditions)") - } - if (is.null(rownames(object@Z))) { - errors <- c( - errors, + errors <- c( + if (ncol(object@Z) != nrow(object@conditions)) { + "ncol(Z) must equal nrow(conditions)" + }, + if (is.null(rownames(object@Z))) { str_c( "'Z' must carry the variant ids as rownames: they are ", "what the LD matrix is derived over" ) - ) - } + } + ) if (length(errors) == 0L) TRUE else errors } ) @@ -129,16 +123,17 @@ setClass( ), # smallest fittable condition count (joint cells # use >= 2; the univariate cell uses 1) validity = function(object) { - errors <- character() - if ( - length(object@dataForm) != 1L || - !is_in(object@dataForm, c("individual", "sumstats")) - ) { - errors <- c(errors, "'dataForm' must be 'individual' or 'sumstats'") - } - if (length(object@minGroup) != 1L || object@minGroup < 1L) { - errors <- c(errors, "'minGroup' must be a single integer >= 1") - } + errors <- c( + if ( + length(object@dataForm) != 1L || + !is_in(object@dataForm, c("individual", "sumstats")) + ) { + "'dataForm' must be 'individual' or 'sumstats'" + }, + if (length(object@minGroup) != 1L || object@minGroup < 1L) { + "'minGroup' must be a single integer >= 1" + } + ) if (length(errors) == 0L) TRUE else errors } ) diff --git a/R/LdBlocks.R b/R/LdBlocks.R index cef4a512..25c2401b 100644 --- a/R/LdBlocks.R +++ b/R/LdBlocks.R @@ -36,24 +36,25 @@ NULL # One block per row. `blockId` is carried into mcols when present so the key # survives; without it the splitter falls back to the block's coordinates. # @noRd +#' @importFrom checkmate assertNames .ldBlockTableToRanges <- function(df) { - missingCols <- setdiff(c("chrom", "start", "end"), colnames(df)) - if (length(missingCols) > 0L) { - msg <- glue( - "`ldBlocks` table is missing required column(s): ", - "{str_flatten(missingCols, ', ')}." - ) - abort(msg) - } - gr <- GenomicRanges::GRanges( + assertNames( + colnames(df), + must.include = c("chrom", "start", "end"), + what = "colnames", + .var.name = "ldBlocks table" + ) + exec( + GenomicRanges::GRanges, seqnames = as.character(df$chrom), ranges = IRanges::IRanges( start = as.integer(df$start), end = as.integer(df$end) - ) + ), + !!!compact(list( + blockId = if (is_in("blockId", colnames(df))) { + as.character(df$blockId) + } + )) ) - if (is_in("blockId", colnames(df))) { - mcols(gr)$blockId <- as.character(df$blockId) - } - gr } diff --git a/R/LdData.R b/R/LdData.R index bcefd808..f130bd3f 100644 --- a/R/LdData.R +++ b/R/LdData.R @@ -56,54 +56,48 @@ setClass( mixtureWeights = "LdMixtureWeights" ), validity = function(object) { - errors <- character() - if (is.null(object@correlation) && is.null(object@genotypeHandle)) { - errors <- c( - errors, + errors <- c( + if (is.null(object@correlation) && is.null(object@genotypeHandle)) { str_c( "At least one of 'correlation' or ", "'genotypeHandle' must be non-NULL" ) - ) - } - if (length(object) == 0) { - errors <- c(errors, "an LdData must cover >= 1 variant") - } - errors <- c(errors, .ldCheckGenotypeSource(object@genotypeHandle)) - errors <- c(errors, .ldCheckCorrelation(object@correlation)) - if (!is.null(object@mixtureWeights)) { - if (!is.list(object@genotypeHandle)) { - errors <- c( - errors, - str_c( - "'mixtureWeights' may only be set when ", - "'genotypeHandle' is a list of panels" - ) - ) - } else { - w <- object@mixtureWeights - if ( - !is.numeric(w) || length(w) != length(object@genotypeHandle) - ) { - errors <- c( - errors, - str_c( - "'mixtureWeights' must be numeric of length ", - "equal to the genotypeHandle list" - ) - ) - } else if (any(w < 0) || abs(sum(w) - 1) > 1e-6) { - errors <- c( - errors, - "'mixtureWeights' must be non-negative and sum to 1" - ) - } - } - } + }, + if (length(object) == 0) "an LdData must cover >= 1 variant", + .ldCheckGenotypeSource(object@genotypeHandle), + .ldCheckCorrelation(object@correlation), + .ldCheckMixtureWeights(object) + ) if (length(errors) == 0) TRUE else errors } ) +# Mixture weights are only meaningful over a LIST of panels, and must then be +# a proper simplex over them. NULL weights are always valid. +# @noRd +.ldCheckMixtureWeights <- function(object) { + if (is.null(object@mixtureWeights)) { + return(NULL) + } + if (!is.list(object@genotypeHandle)) { + return(str_c( + "'mixtureWeights' may only be set when ", + "'genotypeHandle' is a list of panels" + )) + } + w <- object@mixtureWeights + if (!is.numeric(w) || length(w) != length(object@genotypeHandle)) { + return(str_c( + "'mixtureWeights' must be numeric of length ", + "equal to the genotypeHandle list" + )) + } + if (any(w < 0) || abs(sum(w) - 1) > 1e-6) { + return("'mixtureWeights' must be non-negative and sum to 1") + } + NULL +} + #' @describeIn LdData-class Refused. Subsetting would narrow the variants #' while \code{correlation} -- variant-by-variant, and \code{snpIdx}, which #' indexes the reference panel -- stayed as they were, leaving an LD matrix @@ -214,6 +208,8 @@ setMethod("show", "LdData", function(object) { #' blockMetadata = S4Vectors::DataFrame( #' chrom = "22", start = 1L, end = 1000L)) #' ld +#' @importFrom checkmate assert checkMatrix checkList checkNull +#' @importFrom checkmate assertNumeric #' @export LdData <- function( correlation = NULL, @@ -224,6 +220,15 @@ LdData <- function( nRef = 0L, mixtureWeights = NULL ) { + # correlation is documented as a matrix OR a list of matrices OR NULL, + # so this must be an or-combination, not assertMatrix. + assert( + checkMatrix(correlation), + checkList(correlation), + checkNull(correlation), + .var.name = "correlation" + ) + assertNumeric(mixtureWeights, null.ok = TRUE) obj <- new( "LdData", variants, @@ -255,14 +260,23 @@ LdData <- function( A2 = refPanel$A2 ) - optional <- c("allele_freq", "variance", "n_nomiss") - for (col in optional) { - if (is_in(col, names(refPanel))) { - mcolsData[[col]] <- refPanel[[col]] - } - } - mcols(gr) <- mcolsData - gr + optional <- intersect( + c("allele_freq", "variance", "n_nomiss"), + names(refPanel) + ) + `mcols<-`( + gr, + value = cbind( + mcolsData, + DataFrame(refPanel[optional], check.names = FALSE) + ) + ) +} + +# One panel scaled by its mixture weight. +# @noRd +.ldScalePanel <- function(w, panel) { + w * panel } #' @rdname getCorrelation @@ -293,13 +307,16 @@ setMethod("getCorrelation", "LdData", function(x) { ) abort(msg) } - w <- x@mixtureWeights - R <- matrix(0, nrow = dims[[1L]], ncol = dims[[1L]]) - for (k in seq_along(perPanel)) { - R <- R + w[[k]] * perPanel[[k]] - } - dimnames(R) <- dimnames(perPanel[[1L]]) - return(R) + # The mixture is a weighted sum over the panels, so it is a fold. + weighted <- map2(x@mixtureWeights, perPanel, .ldScalePanel) + return(`dimnames<-`( + reduce( + weighted, + `+`, + .init = matrix(0, nrow = dims[[1L]], ncol = dims[[1L]]) + ), + dimnames(perPanel[[1L]]) + )) } computeLd(.ldSourceDosages(x@genotypeHandle, x@snpIdx), method = "sample") }) @@ -347,10 +364,11 @@ setMethod("getBlockMetadata", "LdData", function(x) { #' @rdname getRefPanel #' @export setMethod("getRefPanel", "LdData", function(x) { - mc <- as_tibble(as.data.frame(mcols(x))) - mc$chrom <- as.character(seqnames(x)) - mc$pos <- start(x) - mc + mutate( + as_tibble(as.data.frame(mcols(x))), + chrom = as.character(seqnames(x)), + pos = start(x) + ) }) #' @rdname getGenotypeHandle diff --git a/R/LdEigen.R b/R/LdEigen.R index 5b696c68..1edb1661 100644 --- a/R/LdEigen.R +++ b/R/LdEigen.R @@ -40,26 +40,28 @@ setClass( ) # @noRd +#' @importFrom checkmate makeAssertCollection assertList .validateLdEigen <- function(object) { + coll <- makeAssertCollection() parentCheck <- .validateLdStatistic(object) - errors <- if (isTRUE(parentCheck)) character() else parentCheck - if (length(object@eigenList) != length(object@ldBlocks)) { - errors <- c( - errors, - "Length of 'eigenList' must match number of LD blocks" - ) + if (!isTRUE(parentCheck)) { + coll$push(parentCheck) } + assertList( + object@eigenList, + len = length(object@ldBlocks), + .var.name = "eigenList", + add = coll + ) + # checkmate has no exclusive lower bound, so (0, 1] stays a plain check. if ( length(object@eigenvalueTruncation) != 1L || object@eigenvalueTruncation <= 0 || object@eigenvalueTruncation > 1 ) { - errors <- c( - errors, - "'eigenvalueTruncation' must be a single value in (0, 1]" - ) + coll$push("'eigenvalueTruncation' must be a single value in (0, 1]") } - if (length(errors) == 0) TRUE else errors + coll$getMessages() } #' @title Create an LdEigen @@ -87,6 +89,7 @@ setClass( #' ldBlocks = blocks, nRef = 100L, genome = "hg19") #' length(le) #' length(getEigenList(le)) +#' @importFrom checkmate assertDataFrame assertList assertCount #' @export LdEigen <- function( snpInfo, @@ -97,6 +100,9 @@ LdEigen <- function( genome = NA_character_, eigenvalueTruncation = 1 ) { + assertDataFrame(snpInfo) + assertList(eigenList) + assertCount(nRef, positive = TRUE) obj <- methods::new( "LdEigen", .ldStatRanges(snpInfo, genome), @@ -110,6 +116,7 @@ LdEigen <- function( obj } +#' @importFrom checkmate assertCount assertFlag #' @title Build an LdEigen from loaded LD #' @description Eigendecompose already-loaded LD, block by block, into the #' \code{LdEigen} that \code{\link{estimateH2}} consumes for @@ -160,6 +167,8 @@ buildLdEigen <- function( genome = NA_character_, eigenvalueTruncation = 1 ) { + assertCount(nRef, positive = TRUE, null.ok = TRUE) + assertFlag(inSample) prep <- .ldRefPrepare(ldBlockData, nRef, genome) eigenList <- map2( prep$blocks, diff --git a/R/LdScore.R b/R/LdScore.R index 273a3622..1c1a7c09 100644 --- a/R/LdScore.R +++ b/R/LdScore.R @@ -28,16 +28,21 @@ setClass( ) # @noRd +#' @importFrom checkmate makeAssertCollection assertNames .validateLdScore <- function(object) { + coll <- makeAssertCollection() parentCheck <- .validateLdStatistic(object) - errors <- if (isTRUE(parentCheck)) character() else parentCheck - md <- S4Vectors::mcols(object, use.names = FALSE) - for (col in c("ldScores", "ldScoreWeights")) { - if (!is_in(col, colnames(md))) { - errors <- c(errors, glue("mcols must carry an '{col}' column")) - } + if (!isTRUE(parentCheck)) { + coll$push(parentCheck) } - if (length(errors) == 0) TRUE else errors + assertNames( + colnames(S4Vectors::mcols(object, use.names = FALSE)), + must.include = c("ldScores", "ldScoreWeights"), + what = "colnames", + .var.name = "mcols", + add = coll + ) + coll$getMessages() } #' @title Create an LdScore @@ -65,6 +70,7 @@ setClass( #' inSample = FALSE, genome = "hg19") #' length(ls) #' head(getLdScores(ls)) +#' @importFrom checkmate assertMatrix assertNumeric #' @export LdScore <- function( snpInfo, @@ -78,25 +84,21 @@ LdScore <- function( ) { gr <- .ldStatRanges(snpInfo, genome) ldScores <- as.matrix(ldScores) - if (nrow(ldScores) != length(gr)) { - abort(glue( - "`ldScores` has {nrow(ldScores)} row(s) for {length(gr)} ", - "variant(s); they must be parallel." - )) - } - if (length(ldScoreWeights) != length(gr)) { - abort(glue( - "`ldScoreWeights` has {length(ldScoreWeights)} value(s) for ", - "{length(gr)} variant(s); they must be parallel." - )) - } - md <- S4Vectors::mcols(gr, use.names = FALSE) - md$ldScores <- ldScores - md$ldScoreWeights <- as.numeric(ldScoreWeights) - S4Vectors::mcols(gr) <- md + assertMatrix(ldScores, nrows = length(gr)) + assertNumeric(ldScoreWeights, len = length(gr)) + scored <- S4Vectors::`mcols<-`( + gr, + value = cbind( + S4Vectors::mcols(gr, use.names = FALSE), + S4Vectors::DataFrame( + ldScores = I(ldScores), + ldScoreWeights = as.numeric(ldScoreWeights) + ) + ) + ) obj <- methods::new( "LdScore", - gr, + scored, ldBlocks = .asLdBlockRanges(ldBlocks), nRef = as.integer(nRef), inSample = isTRUE(inSample), @@ -106,6 +108,7 @@ LdScore <- function( obj } +#' @importFrom checkmate assertCount assertFlag #' @title Build an LdScore from loaded LD #' @description Compute per-variant LD scores from already-loaded LD, block by #' block, into the \code{LdScore} that \code{\link{estimateH2}} consumes @@ -162,6 +165,9 @@ buildLdScore <- function( ldScoreWeights = NULL, keepLdMatrices = TRUE ) { + assertCount(nRef, positive = TRUE, null.ok = TRUE) + assertFlag(inSample) + assertFlag(keepLdMatrices) prep <- .ldRefPrepare(ldBlockData, nRef, genome) l2 <- .ldScoreVector(prep$blocks, prep$snpIdx, nrow(prep$snpInfo)) ldMatrixList <- if (isTRUE(keepLdMatrices)) { @@ -185,11 +191,21 @@ buildLdScore <- function( # reference order. # @noRd .ldScoreVector <- function(blocks, snpIdx, nVariants) { - l2 <- numeric(nVariants) - for (b in seq_along(blocks)) { - l2[snpIdx[[b]]] <- rowSums(blocks[[b]]$R^2) + if (length(blocks) == 0L) { + return(numeric(nVariants)) } - l2 + # The blocks partition the variants, so each variant's score lands in + # exactly one place; variants in no block stay zero. + replace( + numeric(nVariants), + list_c(snpIdx), + list_c(map(blocks, .ldScoreBlockSums)) + ) +} + +# @noRd +.ldScoreBlockSums <- function(block) { + rowSums(block$R^2) } # @noRd @@ -204,12 +220,7 @@ buildLdScore <- function( if (is.null(ldScoreWeights)) { return(1 / pmax(l2, 1)) } - if (length(ldScoreWeights) != length(l2)) { - abort(glue( - "`ldScoreWeights` has {length(ldScoreWeights)} value(s) for ", - "{length(l2)} variant(s)." - )) - } + assertNumeric(ldScoreWeights, len = length(l2)) as.numeric(ldScoreWeights) } diff --git a/R/LdStatistic.R b/R/LdStatistic.R index 60d82776..57f9dc57 100644 --- a/R/LdStatistic.R +++ b/R/LdStatistic.R @@ -38,18 +38,17 @@ setClass( ) # @noRd +#' @importFrom checkmate makeAssertCollection assertCount assertLogical .validateLdStatistic <- function(object) { - errors <- character() - if (length(object@nRef) != 1L || object@nRef <= 0L) { - errors <- c(errors, "'nRef' must be a single positive integer") - } - if (length(object@inSample) != 1L) { - errors <- c(errors, "'inSample' must be a single logical value") - } + coll <- makeAssertCollection() + assertCount(object@nRef, positive = TRUE, .var.name = "nRef", add = coll) + # assertLogical(len = 1) rather than assertFlag: the slot's declared type + # already excludes non-logicals, and NA is tolerated here as it was before. + assertLogical(object@inSample, len = 1L, .var.name = "inSample", add = coll) if (length(object) == 0L) { - errors <- c(errors, "an LdStatistic must carry at least one variant") + coll$push("an LdStatistic must carry at least one variant") } - if (length(errors) == 0) TRUE else errors + coll$getMessages() } # The variants of an LD reference, as the GRanges every subclass is built on. @@ -69,15 +68,28 @@ setClass( seqnames = withChrPrefix(as.character(snpInfo$CHR)), ranges = IRanges::IRanges(as.integer(snpInfo$BP), width = 1L) ) - names(gr) <- as.character(snpInfo$SNP) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - select(snpInfo, -any_of(c("CHR", "BP"))), - row.names = NULL + labelled <- S4Vectors::`mcols<-`( + `names<-`(gr, as.character(snpInfo$SNP)), + value = S4Vectors::DataFrame( + select(snpInfo, -any_of(c("CHR", "BP"))), + row.names = NULL + ) + ) + .withGenomeBuild( + labelled, + !is.null(genome) && length(genome) == 1L && nzchar(genome), + genome ) - if (!is.null(genome) && length(genome) == 1L && nzchar(genome)) { - GenomeInfoDb::genome(gr) <- genome +} + +# The ranges carrying `genome` as their seqinfo build, when the caller named +# one. GRanges has no constructor argument for it, so it is written back. +# @noRd +.withGenomeBuild <- function(gr, named, genome) { + if (!named) { + return(gr) } - gr + GenomeInfoDb::`genome<-`(gr, value = genome) } # ============================================================================= @@ -149,14 +161,10 @@ setClass( } # @noRd +#' @importFrom checkmate assertMatrix .ldRefOneBlock <- function(R, gr) { R <- as.matrix(R) - if (nrow(R) != length(gr)) { - abort(glue( - "an LD block's correlation matrix is {nrow(R)}x{ncol(R)} but ", - "covers {length(gr)} variant(s)." - )) - } + assertMatrix(R, nrows = length(gr), .var.name = "LD block correlation") list(R = R, gr = gr) } @@ -266,10 +274,7 @@ setClass( end = map_int(blocks, .ldRefBlockEnd) ) ) - if (.ldRefNamedGenome(genome)) { - GenomeInfoDb::genome(gr) <- genome - } - gr + .withGenomeBuild(gr, .ldRefNamedGenome(genome), genome) } # An LD block is within-chromosome by construction, and .ldRefBlockRanges() @@ -309,8 +314,7 @@ setClass( if (!is.null(nRef)) { return(as.integer(nRef)) } - found <- unique(map_int(dataList, .ldRefNRefOf)) - found <- found[!is.na(found)] + found <- discard(unique(map_int(dataList, .ldRefNRefOf)), is.na) if (length(found) == 0L) { abort(glue( "`nRef` is required: none of the supplied LdData records a ", @@ -337,15 +341,13 @@ setClass( if (.ldRefNamedGenome(genome)) { return(genome) } - found <- unique(map_chr(dataList, .ldRefGenomeOf)) - found <- found[!is.na(found)] + found <- discard(unique(map_chr(dataList, .ldRefGenomeOf)), is.na) if (length(found) == 1L) found[[1L]] else NA_character_ } # @noRd .ldRefGenomeOf <- function(x) { - g <- unique(GenomeInfoDb::genome(as(x, "GRanges"))) - g <- g[!is.na(g)] + g <- discard(unique(GenomeInfoDb::genome(as(x, "GRanges"))), is.na) if (length(g) == 1L) g[[1L]] else NA_character_ } @@ -366,7 +368,6 @@ setMethod("getLdBlocks", "LdStatistic", function(x) x@ldBlocks) setMethod("getGenome", "LdStatistic", function(x, ...) { # The build lives in seqinfo, not a slot: a GRanges already has somewhere # to keep it, and storing it twice is what the retired LdBlocks class did. - build <- unique(GenomeInfoDb::genome(x)) - build <- build[!is.na(build)] + build <- discard(unique(GenomeInfoDb::genome(x)), is.na) if (length(build) == 0L) NA_character_ else build[[1L]] }) diff --git a/R/MashPrior.R b/R/MashPrior.R index dab2ef50..0e65443d 100644 --- a/R/MashPrior.R +++ b/R/MashPrior.R @@ -126,8 +126,10 @@ setClass( #' U <- list(shared = diag(3), singleton = matrix(0.3, 3, 3) + diag(0.7, 3)) #' mp <- MashPrior(fullFit = list(U = U, w = c(0.5, 0.5))) #' mp +#' @importFrom checkmate assertList #' @export MashPrior <- function(fullFit = NULL, cvFits = NULL) { + assertList(cvFits, null.ok = TRUE) obj <- new("MashPrior", fullFit = fullFit, cvFits = cvFits) validObject(obj) obj diff --git a/R/MultiStudyQtlDataset.R b/R/MultiStudyQtlDataset.R index 8e99792c..f5e3447b 100644 --- a/R/MultiStudyQtlDataset.R +++ b/R/MultiStudyQtlDataset.R @@ -43,28 +43,33 @@ setClass( # @noRd .validateMultiStudyQtlDataset <- function(object) { - errors <- c( + # Each stage only makes sense once the previous one holds: the study count + # reads slots the type checks just validated, and trait consistency reads + # across the studies the count check just confirmed. + slotErrors <- c( .msqdCheckDatasets(object@qtlDatasets), .msqdCheckSumStats(object@sumStats) ) - if (length(errors) == 0L) { - errors <- .msqdCheckStudyCount(object) + if (length(slotErrors) > 0L) { + return(slotErrors) } - if (length(errors) == 0L) { - errors <- .msqdCheckTraitConsistency(object) + countErrors <- .msqdCheckStudyCount(object) + if (length(countErrors) > 0L) { + return(countErrors) } - if (length(errors) == 0L) TRUE else errors + traitErrors <- .msqdCheckTraitConsistency(object) + if (length(traitErrors) == 0L) TRUE else traitErrors } # @noRd +#' @importFrom checkmate checkList .msqdCheckDatasets <- function(qtlDatasets) { - if (!is.list(qtlDatasets) || length(qtlDatasets) == 0L) { - return("'qtlDatasets' must be a non-empty named list") + # names = "unique" subsumes the old named/non-empty/non-NA/unique checks. + res <- checkList(qtlDatasets, min.len = 1L, names = "unique") + if (!isTRUE(res)) { + return(str_c("'qtlDatasets' ", res)) } - c( - .msqdCheckDatasetNames(names(qtlDatasets)), - .msqdCheckDatasetTypes(qtlDatasets) - ) + .msqdCheckDatasetTypes(qtlDatasets) } # @noRd @@ -129,7 +134,7 @@ setClass( traitRanges <- map(object@qtlDatasets, .msqdTraitRanges) pairs <- utils::combn(seq_along(traitRanges), 2L) dsNames <- names(object@qtlDatasets) - unlist(compact(map( + list_c(compact(map( seq_len(ncol(pairs)), .msqdPairErrors, pairs = pairs, @@ -141,19 +146,40 @@ setClass( # Per-dataset trait -> rowRanges map (first occurrence of each trait id). # @noRd .msqdTraitRanges <- function(qd) { - out <- list() - for (ctx in getContexts(qd)) { - se <- getPhenotypes(qd, ctx) - rr <- SummarizedExperiment::rowRanges(se) - ids <- rownames(se) - for (i in seq_along(ids)) { - tid <- ids[[i]] - if (is.null(out[[tid]])) { - out[[tid]] <- rr[i] - } - } + pairs <- .msqdConcat(map(getContexts(qd), .msqdContextTraitRanges, qd = qd)) + if (length(pairs) == 0L) { + return(list()) + } + # First occurrence of each trait id wins, as the "only set it while still + # NULL" assignment did. + tids <- map_chr(pairs, "tid") + keep <- !duplicated(tids) + set_names(map(pairs[keep], "range"), tids[keep]) +} + +# @noRd +.msqdConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) } - out + list_c(pieces) +} + +# @noRd +.msqdTraitRangePair <- function(i, ids, rr) { + list(tid = ids[[i]], range = rr[i]) +} + +# One context's (trait, range) pairs in row order. +# @noRd +.msqdContextTraitRanges <- function(ctx, qd) { + se <- getPhenotypes(qd, ctx) + map( + seq_along(rownames(se)), + .msqdTraitRangePair, + ids = rownames(se), + rr = SummarizedExperiment::rowRanges(se) + ) } # Inconsistency errors for the k-th dataset pair. @@ -231,8 +257,10 @@ setClass( #' study = "s2", genotypes = panel, phenotypes = list(brain = se) #' ) #' MultiStudyQtlDataset(qtlDatasets = list(s1 = qd1, s2 = qd2)) +#' @importFrom checkmate assertList #' @export MultiStudyQtlDataset <- function(qtlDatasets, sumStats = NULL) { + assertList(qtlDatasets, min.len = 1L, names = "unique") obj <- new( "MultiStudyQtlDataset", qtlDatasets = qtlDatasets, diff --git a/R/QtlDataset.R b/R/QtlDataset.R index 7c7bf060..45272822 100644 --- a/R/QtlDataset.R +++ b/R/QtlDataset.R @@ -118,30 +118,39 @@ setClass( # study / scaleResiduals / keepIndel scalars + the four non-negative cutoffs. # @noRd +#' @importFrom checkmate makeAssertCollection assertString assertLogical +#' @importFrom checkmate assertFlag assertNumber +#' @importFrom purrr walk .qtlValidateScalars <- function(object) { - errors <- character() - if (length(object@study) != 1L || str_length(object@study) == 0L) { - errors <- c( - errors, - "'study' must be a single non-empty character string" - ) - } - if (length(object@scaleResiduals) != 1L) { - errors <- c(errors, "'scaleResiduals' must be a single logical value") - } - if (length(object@keepIndel) != 1L || is.na(object@keepIndel)) { - errors <- c(errors, "'keepIndel' must be a single logical value") - } - for (nm in c("mafCutoff", "macCutoff", "xvarCutoff", "imissCutoff")) { - v <- methods::slot(object, nm) - if (length(v) != 1L || is.na(v) || !is.finite(v) || v < 0) { - errors <- c( - errors, - glue("'{nm}' must be a single finite non-negative numeric") - ) - } - } - errors + coll <- makeAssertCollection() + assertString(object@study, min.chars = 1L, .var.name = "study", add = coll) + assertLogical( + object@scaleResiduals, + len = 1L, + .var.name = "scaleResiduals", + add = coll + ) + assertFlag(object@keepIndel, .var.name = "keepIndel", add = coll) + walk( + c("mafCutoff", "macCutoff", "xvarCutoff", "imissCutoff"), + .qtlValidateCutoff, + object = object, + coll = coll + ) + coll$getMessages() +} + +# Each cutoff slot must be a single finite non-negative number. +# @noRd +#' @importFrom checkmate assertNumber +.qtlValidateCutoff <- function(nm, object, coll) { + assertNumber( + methods::slot(object, nm), + lower = 0, + finite = TRUE, + .var.name = nm, + add = coll + ) } # Shape checks on the phenotype list handed to the constructor. Run before @@ -149,71 +158,93 @@ setClass( # ExperimentList fail first with a message about experiments rather than # about contexts. Returns an error vector. # @noRd -.qtlCheckPhenotypeList <- function(phenotypes) { - errors <- character() - if (length(phenotypes) == 0L) { - errors <- c(errors, "'phenotypes' must not be empty") - } - contextNames <- names(phenotypes) +# What is wrong with the context names, if anything. The checks are ordered: +# a list with no usable names is not also reported as having duplicates. +# @noRd +.qtlContextNameErrors <- function(contextNames) { if ( is.null(contextNames) || any(str_length(contextNames) == 0L, na.rm = TRUE) || any(is.na(contextNames)) ) { - errors <- c( - errors, - "'phenotypes' must be a named list with non-empty names" - ) - } else if (n_distinct(contextNames) < length(contextNames)) { - errors <- c(errors, "context names in 'phenotypes' must be unique") - } else if (is_in(.QTL_GENO_EXPERIMENT, contextNames)) { - errors <- c( - errors, - glue( - "'{.QTL_GENO_EXPERIMENT}' is reserved for the genotype ", - "experiment and cannot name a context" - ) - ) + return("'phenotypes' must be a named list with non-empty names") } - for (ctx in seq_along(phenotypes)) { - se <- phenotypes[[ctx]] - if (!methods::is(se, "SummarizedExperiment")) { - errors <- c( - errors, - glue( - "phenotypes[[{ctx}]] must be a SummarizedExperiment ", - "(got {class(se)[[1L]]})" - ) - ) - } else if (is.null(colnames(se))) { - errors <- c( - errors, - glue( - "phenotypes[[{ctx}]] has no column names. Which samples ", - "a context observes is recorded in the sampleMap, so ", - "every context must name its samples" - ) - ) - } + if (n_distinct(contextNames) < length(contextNames)) { + return("context names in 'phenotypes' must be unique") + } + if (is_in(.QTL_GENO_EXPERIMENT, contextNames)) { + return(glue( + "'{.QTL_GENO_EXPERIMENT}' is reserved for the genotype ", + "experiment and cannot name a context" + )) + } + character(0) +} + +# What is wrong with one context's SummarizedExperiment, if anything. +# @noRd +.qtlPhenotypeEntryErrors <- function(ctx, phenotypes) { + se <- phenotypes[[ctx]] + if (!methods::is(se, "SummarizedExperiment")) { + return(glue( + "phenotypes[[{ctx}]] must be a SummarizedExperiment ", + "(got {class(se)[[1L]]})" + )) } - errors + if (is.null(colnames(se))) { + return(glue( + "phenotypes[[{ctx}]] has no column names. Which samples ", + "a context observes is recorded in the sampleMap, so ", + "every context must name its samples" + )) + } + character(0) +} + +.qtlCheckPhenotypeList <- function(phenotypes) { + emptyError <- if (length(phenotypes) == 0L) { + "'phenotypes' must not be empty" + } else { + character(0) + } + # Each check answers with its own message or nothing, so the report is a + # concatenation rather than a vector appended to in place. + entryErrors <- map( + seq_along(phenotypes), + .qtlPhenotypeEntryErrors, + phenotypes = phenotypes + ) + as.character(c( + emptyError, + .qtlContextNameErrors(names(phenotypes)), + .qtlConcatChr(entryErrors) + )) +} + +# Concatenate per-item message vectors, empty-safe. +# @noRd +.qtlConcatChr <- function(pieces) { + if (length(pieces) == 0L) { + return(character(0)) + } + as.character(list_c(pieces)) } # The MAE must carry the genotype experiment plus at least one context. # @noRd .qtlValidatePhenotypes <- function(object) { exps <- MultiAssayExperiment::experiments(object) - errors <- character() - if (!is_in(.QTL_GENO_EXPERIMENT, names(exps))) { - errors <- c( - errors, - glue("experiment '{.QTL_GENO_EXPERIMENT}' is missing") - ) + missingGeno <- if (is_in(.QTL_GENO_EXPERIMENT, names(exps))) { + character(0) + } else { + glue("experiment '{.QTL_GENO_EXPERIMENT}' is missing") } - if (length(.qtlPhenotypeList(object)) == 0L) { - errors <- c(errors, "'phenotypes' must not be empty") + noContexts <- if (length(.qtlPhenotypeList(object)) == 0L) { + "'phenotypes' must not be empty" + } else { + character(0) } - errors + as.character(c(missingGeno, noContexts)) } # TRUE when two GRanges share canonical chrom + start + end. @@ -236,32 +267,61 @@ setClass( if (!allSe) { return(character()) } - errors <- character() - traitToRange <- list() - for (ctx in seq_along(pheno)) { - se <- pheno[[ctx]] - rr <- SummarizedExperiment::rowRanges(se) - ids <- rownames(se) - if (length(rr) != length(ids)) { - next - } - for (i in seq_along(ids)) { - tid <- ids[[i]] - prev <- traitToRange[[tid]] - if (is.null(prev)) { - traitToRange[[tid]] <- rr[i] - } else if (!.qtlSameRange(prev, rr[i])) { - errors <- c( - errors, - glue( - "trait '{tid}' has inconsistent rowRanges across ", - "contexts" - ) - ) - } - } + # Every (trait, range) observation in context order, so each one can be + # compared against the first sighting of its trait without a running map. + pairs <- .qtlConcat(map( + seq_along(pheno), + .qtlTraitRangePairs, + pheno = pheno + )) + tids <- map_chr(pairs, "tid") + .qtlConcatChr(map( + seq_along(pairs), + .qtlTraitRangeError, + tids = tids, + ranges = map(pairs, "range") + )) +} + +# Concatenate per-item lists, empty-safe. +# @noRd +.qtlConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) + } + list_c(pieces) +} + +# @noRd +.qtlTraitRangePair <- function(i, ids, rr) { + list(tid = ids[[i]], range = rr[i]) +} + +# One context's (trait, range) observations, or none when the rowRanges and +# the rownames disagree on length. +# @noRd +.qtlTraitRangePairs <- function(ctx, pheno) { + se <- pheno[[ctx]] + rr <- SummarizedExperiment::rowRanges(se) + ids <- rownames(se) + if (length(rr) != length(ids)) { + return(list()) } - errors + map(seq_along(ids), .qtlTraitRangePair, ids = ids, rr = rr) +} + +# Observation `i` disagrees with the first sighting of the same trait. Earlier +# sightings are the reference, so the first one never reports. +# @noRd +.qtlTraitRangeError <- function(i, tids, ranges) { + earlier <- which(tids[seq_len(i - 1L)] == tids[[i]]) + if (length(earlier) == 0L) { + return(character(0)) + } + if (.qtlSameRange(ranges[[earlier[[1L]]]], ranges[[i]])) { + return(character(0)) + } + glue("trait '{tids[[i]]}' has inconsistent rowRanges across contexts") } # ============================================================================= @@ -516,14 +576,15 @@ setMethod("longForm", "QtlDataset", function(object, ..., genotype = FALSE) { # Read the dosages into memory so the reshape can see them. # @noRd .qtlRealizeDosages <- function(mae) { - exps <- MultiAssayExperiment::experiments(mae) - se <- exps[[.QTL_GENO_EXPERIMENT]] - SummarizedExperiment::assay(se, "dosage") <- as.matrix( - SummarizedExperiment::assay(se, "dosage") + lazy <- MultiAssayExperiment::experiments(mae) + bare <- lazy[[.QTL_GENO_EXPERIMENT]] + se <- SummarizedExperiment::`assay<-`( + bare, + "dosage", + value = as.matrix(SummarizedExperiment::assay(bare, "dosage")) ) - exps[[.QTL_GENO_EXPERIMENT]] <- se - MultiAssayExperiment::experiments(mae) <- exps - mae + exps <- `[[<-`(lazy, .QTL_GENO_EXPERIMENT, value = se) + MultiAssayExperiment::`experiments<-`(mae, value = exps) } # Resolve an experiment subscript to names, always keeping the genotype @@ -579,10 +640,14 @@ setMethod("longForm", "QtlDataset", function(object, ..., genotype = FALSE) { .qtlWithGenotypeHandle <- function(x, handle) { exps <- MultiAssayExperiment::experiments(x) gCov <- .qtlColDataMatrix(exps[[.QTL_GENO_EXPERIMENT]]) - exps[[.QTL_GENO_EXPERIMENT]] <- .genotypeExperiment(handle, gCov) - MultiAssayExperiment::experiments(x) <- exps - validObject(x) - x + withHandle <- `[[<-`( + exps, + .QTL_GENO_EXPERIMENT, + value = .genotypeExperiment(handle, gCov) + ) + rebuilt <- MultiAssayExperiment::`experiments<-`(x, value = withHandle) + validObject(rebuilt) + rebuilt } # The primary sample table: every sample any experiment observes, in @@ -655,9 +720,7 @@ setMethod("getGenotypeCovariates", "QtlDataset", function(x) { # @noRd .qtlColDataMatrix <- function(se) { cd <- SummarizedExperiment::colData(se) - out <- as.matrix(as.data.frame(cd)) - rownames(out) <- rownames(cd) - out + `rownames<-`(as.matrix(as.data.frame(cd)), rownames(cd)) } #' @rdname getScaleResiduals @@ -729,6 +792,25 @@ setMethod("getKeepIndel", "QtlDataset", function(x, ...) x@keepIndel) # The union span (+/- cisWindow) of a trait's rowRanges across all contexts. # Requires cisWindow and a single shared chromosome. # @noRd +# The requested traits' ranges within one context, or NULL when it carries +# none of them. +# @noRd +.qtlTraitRangesInContext <- function(ctx, x, traitId) { + se <- getPhenotypes(x, ctx) + hits <- .qtlPresentIndices(traitId, rownames(se)) + if (length(hits) == 0L) { + return(NULL) + } + SummarizedExperiment::rowRanges(se)[hits] +} + +# Positions of `wanted` in `available`, dropping the ones not present. +# @noRd +.qtlPresentIndices <- function(wanted, available) { + hits <- match(wanted, available) + hits[!is.na(hits)] +} + .qtlTraitRegion <- function(x, traitId, cisWindow) { if (is.null(cisWindow) || length(cisWindow) != 1L || cisWindow < 0) { msg <- glue( @@ -737,16 +819,12 @@ setMethod("getKeepIndel", "QtlDataset", function(x, ...) x@keepIndel) ) abort(msg) } - perTraitRanges <- list() - for (ctx in getContexts(x)) { - se <- getPhenotypes(x, ctx) - hits <- match(traitId, rownames(se)) - hits <- hits[!is.na(hits)] - if (length(hits) > 0) { - rr <- SummarizedExperiment::rowRanges(se) - perTraitRanges[[length(perTraitRanges) + 1L]] <- rr[hits] - } - } + perTraitRanges <- compact(map( + getContexts(x), + .qtlTraitRangesInContext, + x = x, + traitId = traitId + )) if (length(perTraitRanges) == 0L) { abort("None of the requested traitId values were found in any context.") } @@ -770,19 +848,17 @@ setMethod("getKeepIndel", "QtlDataset", function(x, ...) x@keepIndel) # A literal `region` GRanges, each range optionally extended by cisWindow. # @noRd +#' @importFrom checkmate assertNumber +#' @importFrom checkmate assertClass .qtlLiteralRegion <- function(region, cisWindow) { - if (!methods::is(region, "GRanges")) { - abort("`region` must be a GRanges object.") - } + assertClass(region, "GRanges") if (length(region) == 0L) { abort("`region` must contain at least one range.") } if (is.null(cisWindow)) { return(region) } - if (length(cisWindow) != 1L || cisWindow < 0) { - abort("`cisWindow` must be a single non-negative value.") - } + assertNumber(cisWindow, lower = 0) GenomicRanges::GRanges( seqnames = GenomicRanges::seqnames(region), ranges = IRanges::IRanges( @@ -802,46 +878,64 @@ setMethod("getKeepIndel", "QtlDataset", function(x, ...) x@keepIndel) # contexts), then build ONE fresh GRanges at the end. Combining per-context # GRanges with do.call(c, .) can trip S4 seqinfo reconciliation in some # GenomeInfoDb builds, so we avoid it entirely. - n <- length(traitIds) - chrs <- rep("chrUn", n) - starts <- rep(1L, n) - ends <- rep(1L, n) - for (i in seq_len(n)) { - tid <- traitIds[[i]] - st <- Inf - en <- -Inf - ch <- NA_character_ - for (ctx in getContexts(x)) { - se <- getPhenotypes(x, ctx) - h <- match(tid, rownames(se)) - h <- h[!is.na(h)] - if (length(h) == 0L) { - next - } - rr <- SummarizedExperiment::rowRanges(se)[h] - ch <- as.character(GenomicRanges::seqnames(rr))[1L] - st <- min(st, GenomicRanges::start(rr)) - en <- max(en, GenomicRanges::end(rr)) - } - if (!is.na(ch)) { - chrs[i] <- ch - starts[i] <- as.integer(st) - ends[i] <- as.integer(en) - } + spans <- map(traitIds, .qtlTraitSpan, x = x, contexts = getContexts(x)) + starts <- map_int(spans, "start") + # `set_names()` is vector-only, so name the GRanges through `names<-` + # applied as a function -- still a copy, no binding rewritten. + `names<-`( + GenomicRanges::GRanges( + map_chr(spans, "chr"), + IRanges::IRanges( + start = starts, + end = pmax(map_int(spans, "end"), starts) + ) + ), + traitIds + ) +} + +# @noRd +.qtlFirstSeqname <- function(rr) { + as.character(GenomicRanges::seqnames(rr))[[1L]] +} + +# One trait's union span across every context that carries it. The chromosome +# is the last matching context's, which is what the running assignment left +# behind; the span is the widest across all of them. +# @noRd +.qtlTraitSpan <- function(tid, x, contexts) { + ranges <- compact(map( + contexts, + .qtlTraitRangesInContext, + x = x, + traitId = tid + )) + if (length(ranges) == 0L) { + return(list(chr = "chrUn", start = 1L, end = 1L)) } - gr <- GenomicRanges::GRanges( - chrs, - IRanges::IRanges(start = starts, end = pmax(ends, starts)) + chrs <- map_chr(ranges, .qtlFirstSeqname) + list( + chr = chrs[[length(chrs)]], + start = as.integer(min(map_dbl(ranges, .qtlRangeMinStart))), + end = as.integer(max(map_dbl(ranges, .qtlRangeMaxEnd))) ) - names(gr) <- traitIds - gr +} + +# @noRd +.qtlRangeMinStart <- function(rr) { + min(GenomicRanges::start(rr)) +} + +# @noRd +.qtlRangeMaxEnd <- function(rr) { + max(GenomicRanges::end(rr)) } #' @rdname getTraitPosition #' @export setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { tids <- if (is.null(traitId)) { - unique(unlist(map(.qtlPhenotypeList(x), rownames))) + unique(list_c(map(.qtlPhenotypeList(x), rownames))) } else { as.character(traitId) } @@ -862,17 +956,31 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { rChr <- canonChrom(GenomicRanges::seqnames(region)) rStart <- GenomicRanges::start(region) rEnd <- GenomicRanges::end(region) - idx <- integer(0) - for (i in seq_along(region)) { - idx <- c(idx, which(siChr == rChr[i] & bp >= rStart[i] & bp <= rEnd[i])) - } - unique(idx) + if (length(region) == 0L) { + return(integer(0)) + } + unique(list_c(map( + seq_along(region), + .qtlRegionHitIndices, + siChr = siChr, + bp = bp, + rChr = rChr, + rStart = rStart, + rEnd = rEnd + ))) +} + +# Rows of the SNP table falling inside region `i`. +# @noRd +.qtlRegionHitIndices <- function(i, siChr, bp, rChr, rStart, rEnd) { + which(siChr == rChr[i] & bp >= rStart[i] & bp <= rEnd[i]) } # Internal: keepIndel slot read, tolerant of QtlDataset objects serialized # before the slot existed (treat a missing slot as TRUE = keep indels). +#' @importFrom purrr possibly .qtlKeepIndel <- function(x) { - isTRUE(tryCatch(getKeepIndel(x), error = function(e) TRUE)) + isTRUE(possibly(getKeepIndel, otherwise = TRUE)(x)) } # Internal: return a copy of a QtlDataset with the supplied filter cutoffs / @@ -890,29 +998,37 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { keepSamples = NULL, keepVariants = NULL ) { - if (!is.null(mafCutoff)) { - data@mafCutoff <- as.numeric(mafCutoff) - } - if (!is.null(macCutoff)) { - data@macCutoff <- as.numeric(macCutoff) - } - if (!is.null(xvarCutoff)) { - data@xvarCutoff <- as.numeric(xvarCutoff) - } - if (!is.null(imissCutoff)) { - data@imissCutoff <- as.numeric(imissCutoff) - } - if (!is.null(keepIndel)) { - data@keepIndel <- as.logical(keepIndel) - } - if (!is.null(keepSamples)) { - data <- .qtlRestrictSamples(data, keepSamples) + overridden <- exec( + methods::initialize, + data, + !!!compact(list( + mafCutoff = if (!is.null(mafCutoff)) as.numeric(mafCutoff), + macCutoff = if (!is.null(macCutoff)) as.numeric(macCutoff), + xvarCutoff = if (!is.null(xvarCutoff)) as.numeric(xvarCutoff), + imissCutoff = if (!is.null(imissCutoff)) as.numeric(imissCutoff), + keepIndel = if (!is.null(keepIndel)) as.logical(keepIndel), + keepVariants = if (!is.null(keepVariants)) { + as.character(keepVariants) + } + )) + ) + restricted <- if (is.null(keepSamples)) { + overridden + } else { + .qtlRestrictSamples(overridden, keepSamples) } - if (!is.null(keepVariants)) { - data@keepVariants <- as.character(keepVariants) + methods::validObject(restricted) + restricted +} + +# Drop samples whose missingness across the block exceeds the dataset's +# imissCutoff. A cutoff of 0 (or an empty block) keeps every sample. +# @noRd +.qtlDropMissingSamples <- function(dosage, x) { + if (getImissCutoff(x) <= 0 || nrow(dosage) == 0L || ncol(dosage) == 0L) { + return(dosage) } - methods::validObject(data) - data + dosage[rowMeans(is.na(dosage)) <= getImissCutoff(x), , drop = FALSE] } # Internal: extract the panel dosage block (samples x variants) for the @@ -945,13 +1061,13 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { region = region, cisWindow = cisWindow ) - snpIdx <- .qtlVariantIndices(x, gr) - if (length(snpIdx) == 0L) { + inRegion <- .qtlVariantIndices(x, gr) + if (length(inRegion) == 0L) { return(.qtlEmptyBlockAllSamples(x)) } # Apply keepVariants + indel restrictions before materialization so we do # not extract dosage we would immediately drop. - snpIdx <- .qtlNarrowSnpIdx(x, snpIdx) + snpIdx <- .qtlNarrowSnpIdx(x, inRegion) if (length(snpIdx) == 0L) { return(.qtlEmptyBlock()) } @@ -961,21 +1077,13 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { if (length(keep) == 0L) { return(.qtlEmptyBlockNoSamples(dosage)) } - dosage <- dosage[keep, , drop = FALSE] - # Per-sample missingness filter. - if (getImissCutoff(x) > 0 && nrow(dosage) > 0L && ncol(dosage) > 0L) { - dosage <- dosage[ - rowMeans(is.na(dosage)) <= getImissCutoff(x), - , - drop = FALSE - ] - } - filtered <- .qtlVariantFilters(dosage, x) - dosage <- .qtlMeanImpute(filtered$dosage) + kept <- dosage[keep, , drop = FALSE] + filtered <- .qtlVariantFilters(.qtlDropMissingSamples(kept, x), x) + imputed <- .qtlMeanImpute(filtered$dosage) list( - geno = dosage, - variantIds = colnames(dosage), - sampleIds = rownames(dosage), + geno = imputed, + variantIds = colnames(imputed), + sampleIds = rownames(imputed), maf = filtered$maf, af = filtered$af ) @@ -1033,22 +1141,22 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { # @noRd .qtlNarrowSnpIdx <- function(x, snpIdx) { handle <- getGenotypeHandle(x) - if (length(getKeepVariants(x)) > 0L) { + kept <- if (length(getKeepVariants(x)) == 0L) { + snpIdx + } else { snpAll <- as.character(getSnpInfo(handle)$SNP[snpIdx]) km <- matchVariants(snpAll, as.character(getKeepVariants(x))) - keepMask <- logical(length(snpAll)) - keepMask[km$idxA] <- TRUE - snpIdx <- snpIdx[keepMask] + snpIdx[replace(logical(length(snpAll)), km$idxA, TRUE)] } - if (length(snpIdx) > 0L && !.qtlKeepIndel(x)) { - si <- getSnpInfo(handle) - # which() (not the mask) so an NA mask drops the variant rather than - # injecting an NA index. - snpMask <- str_length(as.character(si$A1[snpIdx])) == 1L & - str_length(as.character(si$A2[snpIdx])) == 1L - snpIdx <- snpIdx[which(snpMask)] + if (length(kept) == 0L || .qtlKeepIndel(x)) { + return(kept) } - snpIdx + si <- getSnpInfo(handle) + # which() (not the mask) so an NA mask drops the variant rather than + # injecting an NA index. + snpMask <- str_length(as.character(si$A1[kept])) == 1L & + str_length(as.character(si$A2[kept])) == 1L + kept[which(snpMask)] } # Resolve the sample set: panel samples intersected with the dataset's @@ -1056,12 +1164,14 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { # per-call `samples` arg. # @noRd .qtlResolveSamples <- function(dosage, x, samples) { - keep <- intersect( + inDataset <- intersect( rownames(dosage), rownames(MultiAssayExperiment::colData(x)) ) - if (!is.null(samples)) { - keep <- intersect(keep, as.character(samples)) + keep <- if (is.null(samples)) { + inDataset + } else { + intersect(inDataset, as.character(samples)) } keep } @@ -1086,13 +1196,20 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { getMafCutoff(x), if (nSamp > 0L) getMacCutoff(x) / (2 * nSamp) else 0 ) - keepVarMask <- !is.na(mafVec) & mafVec >= effectiveMaf - if (getXvarCutoff(x) > 0 && nSamp > 1L) { + byMaf <- !is.na(mafVec) & mafVec >= effectiveMaf + keepVarMask <- if (getXvarCutoff(x) <= 0 || nSamp <= 1L) { + byMaf + } else { mu <- if_else(nObs > 0L, sumD / nObs, 0) - centered <- sweep(dosage, 2L, mu, FUN = "-") - centered[is.na(centered)] <- 0 + # mu is finite everywhere, so the centered NAs are exactly the + # dosage NAs; they contribute nothing to the variance. + centered <- replace( + sweep(dosage, 2L, mu, FUN = "-"), + is.na(dosage), + 0 + ) varVec <- colSums(centered * centered) / (nSamp - 1L) - keepVarMask <- keepVarMask & varVec >= getXvarCutoff(x) + byMaf & varVec >= getXvarCutoff(x) } list( dosage = dosage[, keepVarMask, drop = FALSE], @@ -1108,15 +1225,13 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { if (!anyNA(dosage)) { return(dosage) } - for (j in seq_len(ncol(dosage))) { - col <- dosage[, j] - na <- is.na(col) - if (any(na)) { - col[na] <- mean(col[!na]) - dosage[, j] <- col - } - } - dosage + naMask <- is.na(dosage) + # An all-NA column means NaN either way, matching mean(numeric(0)). + means <- colMeans(dosage, na.rm = TRUE) + # One fill over the whole matrix instead of a copy per column: dosage is + # variants x samples, so rebuilding it column by column is the expensive + # way to say this. + replace(dosage, naMask, means[col(dosage)[naMask]]) } #' @rdname getGenotypes @@ -1155,9 +1270,7 @@ setMethod( cisWindow = cisWindow, samples = samples ) - out <- block$maf - names(out) <- block$variantIds - out + set_names(block$maf, block$variantIds) } ) @@ -1181,9 +1294,7 @@ setMethod( cisWindow = cisWindow, samples = samples ) - out <- block$af - names(out) <- block$variantIds - out + set_names(block$af, block$variantIds) } ) @@ -1205,16 +1316,15 @@ setMethod( naAction <- arg_match(naAction) outlierAction <- arg_match(outlierAction) .qtlValidateContexts(x, contexts) - out <- .qtlPhenotypeList(x)[contexts] - out <- .qtlFilterPhenotypes( - out, - contexts, - traitId, - region, - naAction, - outlierAction, - outlierPvalThreshold - ) + out <- .qtlPhenotypeList(x)[contexts] |> + .qtlFilterPhenotypes( + contexts, + traitId, + region, + naAction, + outlierAction, + outlierPvalThreshold + ) if (length(contexts) == 1L) out[[1L]] else out } ) @@ -1266,33 +1376,36 @@ setMethod( outlierAction, outlierPvalThreshold ) { - if (!is.null(traitId)) { - out <- .qtlFilterTraits(out, contexts, traitId) + byTrait <- if (is.null(traitId)) { + out + } else { + .qtlFilterTraits(out, contexts, traitId) } - if (!is.null(region)) { - out <- set_names( - map(out, .qtlSeInRegion, region = region), - contexts - ) + inRegion <- if (is.null(region)) { + byTrait + } else { + set_names(map(byTrait, .qtlSeInRegion, region = region), contexts) } - if (naAction != "keep") { - out <- set_names( - map(out, .qtlApplyPhenoNaAction, naAction = naAction), + naHandled <- if (naAction == "keep") { + inRegion + } else { + set_names( + map(inRegion, .qtlApplyPhenoNaAction, naAction = naAction), contexts ) } - if (outlierAction != "keep") { - out <- set_names( - map( - out, - .qtlApplyPhenoOutliers, - action = outlierAction, - pvalThreshold = outlierPvalThreshold - ), - contexts - ) + if (outlierAction == "keep") { + return(naHandled) } - out + set_names( + map( + naHandled, + .qtlApplyPhenoOutliers, + action = outlierAction, + pvalThreshold = outlierPvalThreshold + ), + contexts + ) } # Internal: apply naAction to a SummarizedExperiment slice. SE assay rows @@ -1310,23 +1423,27 @@ setMethod( return(se) } if (naAction == "drop") { - keepSamp <- colSums(is.na(Y)) == 0L - se <- se[, keepSamp, drop = FALSE] - } else if (naAction == "impute") { - if (anyNA(Y)) { - for (j in seq_len(nrow(Y))) { - row <- Y[j, ] - na <- is.na(row) - if (any(na)) { - obs <- row[!na] - row[na] <- if (length(obs) > 0L) mean(obs) else 0 - Y[j, ] <- row - } - } - SummarizedExperiment::assay(se, assayName) <- Y - } + return(se[, colSums(is.na(Y)) == 0L, drop = FALSE]) + } + if (naAction != "impute" || !anyNA(Y)) { + return(se) } - se + SummarizedExperiment::`assay<-`( + se, + assayName, + value = .qtlRowMeanImpute(Y) + ) +} + +# Fill each row's missing values with that row's mean, or 0 when the row has +# nothing observed. One fill over the whole matrix rather than a copy per row. +# @noRd +.qtlRowMeanImpute <- function(Y) { + naMask <- is.na(Y) + # rowMeans of an all-NA row is NaN, which is the `else 0` case. + means <- rowMeans(Y, na.rm = TRUE) + filled <- if_else(is.nan(means), 0, means) + replace(Y, naMask, filled[row(Y)[naMask]]) } # Multivariate-outlier keep mask via Mahalanobis distance against a @@ -1347,6 +1464,7 @@ setMethod( # # Returns all-TRUE (no-op) when there are too few samples to support # a covariance estimate (n < p + 2). +#' @importFrom rlang try_fetch .qtlOutlierKeepMask <- function(Y, pvalThreshold) { Y <- as.matrix(Y) n <- nrow(Y) @@ -1363,7 +1481,7 @@ setMethod( return(rep(TRUE, n)) } if (requireNamespace("robustbase", quietly = TRUE)) { - mcd <- tryCatch(robustbase::covMcd(Y), error = function(e) NULL) + mcd <- try_fetch(robustbase::covMcd(Y), error = function(cnd) NULL) if (!is.null(mcd)) { ctr <- mcd$center covMat <- mcd$cov @@ -1380,7 +1498,17 @@ setMethod( ctr <- colMeans(Y) covMat <- stats::cov(Y) } - invCov <- tryCatch(solve(covMat), error = function(e) MASS::ginv(covMat)) + invCov <- try_fetch( + solve(covMat), + error = function(cnd) { + msg <- glue( + "outlier detection: the trait covariance is singular; ", + "using a Moore-Penrose pseudo-inverse instead." + ) + inform(msg, parent = cnd) + MASS::ginv(covMat) + } + ) Yc <- sweep(Y, 2L, ctr) d2 <- rowSums((Yc %*% invCov) * Yc) raw <- stats::pchisq(d2, df = p, lower.tail = FALSE) @@ -1415,9 +1543,7 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { msg <- glue("Unknown context(s): {str_flatten(bad, ', ')}") abort(msg) } - out <- map(contexts, .qtlContextColData, x = x) - names(out) <- contexts - out + set_names(map(contexts, .qtlContextColData, x = x), contexts) }) # Internal: residualize a numeric matrix Y (n x k) against a covariate @@ -1441,21 +1567,21 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { # `qr.resid` does not support LAPACK pivoted QR, so use `lm.fit`. It # handles rank-deficient designs gracefully via base-R's pivoted QR # internally -- same effect the LAPACK path was meant to deliver. - res <- stats::lm.fit(x = X, y = Y)$residuals - res <- as.matrix(res) - rownames(res) <- rownames(Y) - colnames(res) <- colnames(Y) + res <- `dimnames<-`( + as.matrix(stats::lm.fit(x = X, y = Y)$residuals), + list(rownames(Y), colnames(Y)) + ) if (isTRUE(scaleResiduals)) { - sds <- apply(res, 2L, stats::sd, na.rm = TRUE) # `sds == 0` exact-zero test is unreliable for residuals coming out of # lm.fit on a constant Y: roundoff gives sd ~ 1e-16 instead of 0, and # dividing the (also-tiny) residuals by it amplifies floating-point # noise to unit-scale. Treat anything below sqrt(.Machine$double.eps) # as effectively zero (column is constant) and skip rescaling. - nearZero <- !is.finite(sds) | sds < sqrt(.Machine$double.eps) - sds[nearZero] <- 1 - res[, nearZero] <- 0 - res <- sweep(res, 2L, sds, FUN = "/") + rawSds <- apply(res, 2L, stats::sd, na.rm = TRUE) + nearZero <- !is.finite(rawSds) | rawSds < sqrt(.Machine$double.eps) + # One multiplier per column: 1/sd where it is meaningful, 0 where the + # column is constant, which zeroes that column outright. + return(sweep(res, 2L, if_else(nearZero, 0, 1 / rawSds), FUN = "*")) } res } @@ -1555,10 +1681,7 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { # Internal: validate the genotype-covariate selection vector. Returns # character(0) when nothing selected, the resolved set otherwise. .qtlResolveGenoSelection <- function(x, toResidualize) { - avail <- colnames(getGenotypeCovariates(x)) - if (is.null(avail)) { - avail <- character(0) - } + avail <- colnames(getGenotypeCovariates(x)) %||% character(0) if (is.null(toResidualize)) { return(avail) } @@ -1627,29 +1750,41 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { # rownames(colData(se)). # @noRd .qtlPhenoCovBlocks <- function(x, contexts, phenoSelection) { - perContext <- list() - for (ctx in contexts) { - keep <- phenoSelection[[ctx]] - if (length(keep) == 0L) { - next - } - se <- getPhenotypes(x, ctx) - cd <- as.matrix(as.data.frame(SummarizedExperiment::colData(se))) - cdMat <- cd[, keep, drop = FALSE] - colnames(cdMat) <- str_c(ctx, ".", colnames(cdMat)) - perContext[[ctx]] <- cdMat + compact(set_names( + map( + contexts, + .qtlPhenoCovBlock, + x = x, + phenoSelection = phenoSelection + ), + contexts + )) +} + +# One context's selected covariate columns, context-qualified, or NULL when +# nothing is selected there. +# @noRd +.qtlPhenoCovBlock <- function(ctx, x, phenoSelection) { + keep <- phenoSelection[[ctx]] + if (length(keep) == 0L) { + return(NULL) } - perContext + se <- getPhenotypes(x, ctx) + cd <- as.matrix(as.data.frame(SummarizedExperiment::colData(se))) + block <- cd[, keep, drop = FALSE] + `colnames<-`(block, str_c(ctx, ".", colnames(block))) } # Intersect the covariate blocks to their common samples and column-bind them # into one design matrix; NULL when no samples are shared. # @noRd .qtlAlignCovariates <- function(perContext, gCov) { - sampleSets <- map(perContext, .qtlBlockSamples) - if (!is.null(gCov) && ncol(gCov) > 0L) { - sampleSets <- c(sampleSets, list(.qtlBlockSamples(gCov))) - } + sampleSets <- c( + map(perContext, .qtlBlockSamples), + if (!is.null(gCov) && ncol(gCov) > 0L) { + list(.qtlBlockSamples(gCov)) + } + ) common <- if (length(sampleSets) == 0L) { character(0) } else { @@ -1658,16 +1793,23 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { if (length(common) == 0L) { return(NULL) } - blocks <- list() - for (mat in perContext) { - blocks[[length(blocks) + 1L]] <- mat[common, , drop = FALSE] - } - if (!is.null(gCov) && ncol(gCov) > 0L) { - blocks[[length(blocks) + 1L]] <- gCov[common, , drop = FALSE] + genoBlock <- if (!is.null(gCov) && ncol(gCov) > 0L) { + list(gCov[common, , drop = FALSE]) + } else { + list() } + blocks <- c( + map(perContext, .qtlRestrictToSamples, common = common), + genoBlock + ) exec(cbind, !!!blocks) } +# @noRd +.qtlRestrictToSamples <- function(mat, common) { + mat[common, , drop = FALSE] +} + # The samples a covariate block covers, or NULL when it does not say. A block # with no rows covers none of them, which base R reports as NULL rownames # rather than an empty character vector; reading that as "unconstrained" @@ -1702,16 +1844,11 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { keep <- rowSums(is.na(C)) == 0L return(C[keep, , drop = FALSE]) } - for (j in seq_len(ncol(C))) { - col <- C[, j] - na <- is.na(col) - if (any(na)) { - mu <- mean(col[!na]) - col[na] <- if (is.finite(mu)) mu else 0 - C[, j] <- col - } - } - C + naMask <- is.na(C) + # colMeans of an all-NA column is NaN, which is the non-finite `else 0`. + means <- colMeans(C, na.rm = TRUE) + filled <- if_else(is.finite(means), means, 0) + replace(C, naMask, filled[col(C)[naMask]]) } # Internal: resolve a (convenience, precise) flag pair to a single boolean. @@ -1792,9 +1929,25 @@ setMethod( residualizeGenotypeCovariatesFromGenotypes ) || is.null(residualizeGenotypeCovariatesFromGenotypes) - p <- as.list(environment()) - p$dots <- list(...) - .qtlResidualizedGenotypesImpl(p) + .qtlResidualizedGenotypesImpl( + x = x, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples, + phenotypeCovariatesToResidualize = phenotypeCovariatesToResidualize, + genotypeCovariatesToResidualize = genotypeCovariatesToResidualize, + covariateNaAction = covariateNaAction, + convPheno = residualizePhenotypeCovariates, + convPhenoMissing = convPhenoMissing, + precPheno = residualizePhenotypeCovariatesFromGenotypes, + precPhenoMissing = precPhenoMissing, + convGeno = residualizeGenotypeCovariates, + convGenoMissing = convGenoMissing, + precGeno = residualizeGenotypeCovariatesFromGenotypes, + precGenoMissing = precGenoMissing + ) } ) @@ -1826,66 +1979,102 @@ setMethod( # precision spellings. Paired here because the reconciliation rule is the same # for both and only the argument names differ. # @noRd -.qtlResidualizationFlags <- function(p) { +.qtlResidualizationFlags <- function( + convPheno, + convPhenoMissing, + precPheno, + precPhenoMissing, + convGeno, + convGenoMissing, + precGeno, + precGenoMissing +) { list( pheno = .qtlResolveResidualizationFlag( - p$residualizePhenotypeCovariates, - p$convPhenoMissing, - p$residualizePhenotypeCovariatesFromGenotypes, - p$precPhenoMissing, - "residualizePhenotypeCovariates", - "residualizePhenotypeCovariatesFromGenotypes" + convPheno, + convPhenoMissing, + precPheno, + precPhenoMissing, + "convPheno", + "precPheno" ), geno = .qtlResolveResidualizationFlag( - p$residualizeGenotypeCovariates, - p$convGenoMissing, - p$residualizeGenotypeCovariatesFromGenotypes, - p$precGenoMissing, - "residualizeGenotypeCovariates", - "residualizeGenotypeCovariatesFromGenotypes" + convGeno, + convGenoMissing, + precGeno, + precGenoMissing, + "convGeno", + "precGeno" ) ) } -.qtlResidualizedGenotypesImpl <- function(p) { - bad <- setdiff(p$contexts, getContexts(p$x)) +.qtlResidualizedGenotypesImpl <- function( + x, + contexts, + traitId, + region, + cisWindow, + samples, + phenotypeCovariatesToResidualize, + genotypeCovariatesToResidualize, + covariateNaAction, + convPheno, + convPhenoMissing, + precPheno, + precPhenoMissing, + convGeno, + convGenoMissing, + precGeno, + precGenoMissing +) { + bad <- setdiff(contexts, getContexts(x)) if (length(bad) > 0L) { msg <- glue("Unknown context(s): {str_flatten(bad, ', ')}") abort(msg) } - include <- .qtlResidualizationFlags(p) + include <- .qtlResidualizationFlags( + convPheno = convPheno, + convPhenoMissing = convPhenoMissing, + precPheno = precPheno, + precPhenoMissing = precPhenoMissing, + convGeno = convGeno, + convGenoMissing = convGenoMissing, + precGeno = precGeno, + precGenoMissing = precGenoMissing + ) includePheno <- include$pheno includeGeno <- include$geno phenoSel <- .qtlResolvePhenoSelection( - p$x, - p$contexts, - p$phenotypeCovariatesToResidualize + x, + contexts, + phenotypeCovariatesToResidualize ) - genoSel <- .qtlResolveGenoSelection(p$x, p$genotypeCovariatesToResidualize) + genoSel <- .qtlResolveGenoSelection(x, genotypeCovariatesToResidualize) G <- getGenotypes( - p$x, - traitId = p$traitId, - region = p$region, - cisWindow = p$cisWindow, - samples = p$samples + x, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples ) if (ncol(G) == 0L) { return(G) } - C <- .qtlBuildResidualizationDesign( - p$x, - contexts = p$contexts, + design <- .qtlBuildResidualizationDesign( + x, + contexts = contexts, phenoSelection = phenoSel, genoSelection = genoSel, includePheno = includePheno, includeGeno = includeGeno ) - C <- .qtlHandleCovariateNa(C, p$covariateNaAction) - aligned <- .qtlAlignGC(G, C, p$contexts) + C <- .qtlHandleCovariateNa(design, covariateNaAction) + aligned <- .qtlAlignGC(G, C, contexts) .qtlResidualizeQr( aligned$G, aligned$C, - scaleResiduals = getScaleResiduals(p$x) + scaleResiduals = getScaleResiduals(x) ) } @@ -1927,9 +2116,26 @@ setMethod( residualizeGenotypeCovariatesFromPhenotypes ) || is.null(residualizeGenotypeCovariatesFromPhenotypes) - p <- as.list(environment()) - p$dots <- list(...) - .qtlResidualizedPhenotypesImpl(p) + .qtlResidualizedPhenotypesImpl( + x = x, + contexts = contexts, + traitId = traitId, + region = region, + phenotypeCovariatesToResidualize = phenotypeCovariatesToResidualize, + genotypeCovariatesToResidualize = genotypeCovariatesToResidualize, + naAction = naAction, + covariateNaAction = covariateNaAction, + outlierAction = outlierAction, + outlierPvalThreshold = outlierPvalThreshold, + convPheno = residualizePhenotypeCovariates, + convPhenoMissing = convPhenoMissing, + precPheno = residualizePhenotypeCovariatesFromPhenotypes, + precPhenoMissing = precPhenoMissing, + convGeno = residualizeGenotypeCovariates, + convGenoMissing = convGenoMissing, + precGeno = residualizeGenotypeCovariatesFromPhenotypes, + precGenoMissing = precGenoMissing + ) } ) @@ -1937,21 +2143,44 @@ setMethod( # multi-context callers see the same shape). # @noRd .qtlResidPhenoY <- function(x, contexts, traitId, region, naAction) { - Yraw <- getPhenotypes( + fetched <- getPhenotypes( x, contexts = contexts, traitId = traitId, region = region, naAction = naAction ) - if (length(contexts) == 1L) { - Yraw <- set_names(list(Yraw), contexts) + # A single context returns the bare matrix rather than a named list. + Yraw <- if (length(contexts) == 1L) { + set_names(list(fetched), contexts) + } else { + fetched } Yraw } -# Residualize one context's phenotypes against the covariate design (intersected -# to common samples) and drop residual-scale outliers. +# Phenotype and covariate matrices restricted to the samples they share. +# A NULL covariate matrix leaves the phenotypes whole. +# @noRd +.qtlAlignPhenoCovariates <- function(allY, C, ctx) { + if (is.null(C)) { + return(list(Y = allY, C = NULL)) + } + common <- intersect(rownames(allY), rownames(C)) + if (length(common) == 0L) { + abort(glue( + "context '{ctx}': no samples shared between phenotype data ", + "and the resolved covariate matrix." + )) + } + list( + Y = allY[common, , drop = FALSE], + C = C[common, , drop = FALSE] + ) +} + +# Residualize one context's phenotypes against the covariate design +# (intersected to common samples) and drop residual-scale outliers. # @noRd .qtlResidualizeContextPheno <- function( se, @@ -1961,51 +2190,53 @@ setMethod( outlierPvalThreshold, scaleResiduals ) { - Y <- t(SummarizedExperiment::assay(se)) # samples x traits - Cctx <- NULL - if (!is.null(C)) { - common <- intersect(rownames(Y), rownames(C)) - if (length(common) == 0L) { - msg <- glue( - "context '{ctx}': no samples shared between phenotype data ", - "and the resolved covariate matrix." - ) - abort(msg) - } - Y <- Y[common, , drop = FALSE] - Cctx <- C[common, , drop = FALSE] + allY <- t(SummarizedExperiment::assay(se)) # samples x traits + aligned <- .qtlAlignPhenoCovariates(allY, C, ctx) + allRes <- .qtlResidualizeQr( + aligned$Y, + aligned$C, + scaleResiduals = scaleResiduals + ) + if (outlierAction == "keep") { + return(allRes) } - Yres <- .qtlResidualizeQr(Y, Cctx, scaleResiduals = scaleResiduals) # Outlier detection on the residualized scale. - if (outlierAction != "keep") { - keep <- .qtlOutlierKeepMask(Yres, outlierPvalThreshold) - if (!all(keep)) { - Yres <- Yres[keep, , drop = FALSE] - } + keep <- .qtlOutlierKeepMask(allRes, outlierPvalThreshold) + if (all(keep)) { + return(allRes) } - Yres + allRes[keep, , drop = FALSE] } # Resolve the phenotype/genotype covariate inclusion flags (convenience vs # precise `*FromPhenotypes`) for getResidualizedPhenotypes. # @noRd -.qtlResidPhenoFlags <- function(p) { +.qtlResidPhenoFlags <- function( + convPheno, + convPhenoMissing, + precPheno, + precPhenoMissing, + convGeno, + convGenoMissing, + precGeno, + precGenoMissing +) { list( includePheno = .qtlResolveResidualizationFlag( - p$residualizePhenotypeCovariates, - p$convPhenoMissing, - p$residualizePhenotypeCovariatesFromPhenotypes, - p$precPhenoMissing, - "residualizePhenotypeCovariates", - "residualizePhenotypeCovariatesFromPhenotypes" + convPheno, + convPhenoMissing, + precPheno, + precPhenoMissing, + "convPheno", + "precPheno" ), includeGeno = .qtlResolveResidualizationFlag( - p$residualizeGenotypeCovariates, - p$convGenoMissing, - p$residualizeGenotypeCovariatesFromPhenotypes, - p$precGenoMissing, - "residualizeGenotypeCovariates", - "residualizeGenotypeCovariatesFromPhenotypes" + convGeno, + convGenoMissing, + precGeno, + precGenoMissing, + "convGeno", + "precGeno" ) ) } @@ -2014,42 +2245,78 @@ setMethod( # NA-handle Y, build the covariate design, and per-context residualize + # outlier-filter. `p` holds the setMethod args + precomputed missing() flags. # @noRd -.qtlResidualizedPhenotypesImpl <- function(p) { - bad <- setdiff(p$contexts, getContexts(p$x)) +.qtlResidualizedPhenotypesImpl <- function( + x, + contexts, + traitId, + region, + phenotypeCovariatesToResidualize, + genotypeCovariatesToResidualize, + naAction, + covariateNaAction, + outlierAction, + outlierPvalThreshold, + convPheno, + convPhenoMissing, + precPheno, + precPhenoMissing, + convGeno, + convGenoMissing, + precGeno, + precGenoMissing +) { + bad <- setdiff(contexts, getContexts(x)) if (length(bad) > 0L) { msg <- glue("Unknown context(s): {str_flatten(bad, ', ')}") abort(msg) } - flags <- .qtlResidPhenoFlags(p) + flags <- .qtlResidPhenoFlags( + convPheno = convPheno, + convPhenoMissing = convPhenoMissing, + precPheno = precPheno, + precPhenoMissing = precPhenoMissing, + convGeno = convGeno, + convGenoMissing = convGenoMissing, + precGeno = precGeno, + precGenoMissing = precGenoMissing + ) includePheno <- flags$includePheno includeGeno <- flags$includeGeno phenoSel <- .qtlResolvePhenoSelection( - p$x, - p$contexts, - p$phenotypeCovariatesToResidualize + x, + contexts, + phenotypeCovariatesToResidualize ) - genoSel <- .qtlResolveGenoSelection(p$x, p$genotypeCovariatesToResidualize) + genoSel <- .qtlResolveGenoSelection(x, genotypeCovariatesToResidualize) Yraw <- .qtlResidPhenoY( - p$x, - p$contexts, - p$traitId, - p$region, - p$naAction + x, + contexts, + traitId, + region, + naAction ) - C <- .qtlBuildResidualizationDesign( - p$x, - contexts = p$contexts, + design <- .qtlBuildResidualizationDesign( + x, + contexts = contexts, phenoSelection = phenoSel, genoSelection = genoSel, includePheno = includePheno, includeGeno = includeGeno ) - C <- .qtlHandleCovariateNa(C, p$covariateNaAction) + C <- .qtlHandleCovariateNa(design, covariateNaAction) out <- set_names( - map(p$contexts, .qtlResidualizeContext, Yraw = Yraw, C = C, p = p), - p$contexts + map( + contexts, + .qtlResidualizeContext, + Yraw = Yraw, + C = C, + x = x, + outlierAction = outlierAction, + outlierPvalThreshold = outlierPvalThreshold + ), + contexts ) - if (length(p$contexts) == 1L) out[[1L]] else out + if (length(contexts) == 1L) out[[1L]] else out } @@ -2059,10 +2326,7 @@ setMethod("show", "QtlDataset", function(object) { pheno <- .qtlPhenotypeList(object) nCtx <- length(pheno) ctxNames <- names(pheno) - totalTraits <- length(unique(unlist( - map(pheno, rownames), - use.names = FALSE - ))) + totalTraits <- length(unique(unname(list_c(map(pheno, rownames))))) cat(glue("QtlDataset for study '{object@study}'\n", .trim = FALSE)) cat(glue( " {nCtx} context(s): {str_flatten(ctxNames, ', ')}\n", @@ -2128,13 +2392,20 @@ setMethod("show", "QtlDataset", function(object) { # Residualize + filter one context's raw phenotype matrix against covariates C. # @noRd -.qtlResidualizeContext <- function(ctx, Yraw, C, p) { +.qtlResidualizeContext <- function( + ctx, + Yraw, + C, + x, + outlierAction, + outlierPvalThreshold +) { .qtlResidualizeContextPheno( Yraw[[ctx]], C, ctx, - p$outlierAction, - p$outlierPvalThreshold, - getScaleResiduals(p$x) + outlierAction, + outlierPvalThreshold, + getScaleResiduals(x) ) } diff --git a/R/QtlFineMappingResult.R b/R/QtlFineMappingResult.R index 99607609..03e4824a 100644 --- a/R/QtlFineMappingResult.R +++ b/R/QtlFineMappingResult.R @@ -42,24 +42,23 @@ setClass( # run only once the required columns are present; the ldSketch check always # runs. # @noRd +#' @importFrom checkmate makeAssertCollection assertNames checkNames .validateQtlFineMappingResult <- function(object) { - errors <- .qfmrCheckRequiredCols(object) - if (length(errors) == 0L) { - errors <- .qfmrCheckEntries(object) - } - errors <- c(errors, .qfmrCheckLdSketch(object)) - if (length(errors) == 0L) TRUE else errors -} - -# The study/context/trait/method/entry columns must be present. -# @noRd -.qfmrCheckRequiredCols <- function(object) { - required <- c("study", "context", "trait", "method") - missingCols <- setdiff(required, .tupleColumnNames(object)) - if (length(missingCols) > 0L) { - return(str_c("missing columns: ", str_flatten(missingCols, ", "))) + coll <- makeAssertCollection() + assertNames( + .tupleColumnNames(object), + must.include = c("study", "context", "trait", "method"), + what = "colnames", + .var.name = "mcols", + add = coll + ) + # The checks below read those columns; running them on an object missing + # them reports the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } - NULL + coll$push(.qfmrCheckEntries(object)) + coll$getMessages() } # Entry-column + region/traitPos + joint-column + tuple-uniqueness contract. @@ -81,17 +80,15 @@ setClass( # to check is that the fit payload columns are present and parallel. # @noRd .qfmrCheckEntryLength <- function(object) { - missingCols <- setdiff( - c("susieFit", "cvResult"), - .tupleColumnNames(object) + res <- checkNames( + .tupleColumnNames(object), + must.include = c("susieFit", "cvResult"), + what = "colnames" ) - if (length(missingCols) > 0L) { - return(str_c( - "missing entry payload columns: ", - str_flatten(missingCols, ", ") - )) + if (isTRUE(res)) { + return(NULL) } - NULL + str_c("missing entry payload columns: ", res) } # @noRd @@ -101,7 +98,7 @@ setClass( # Each present joint* column must be character. # @noRd .qfmrCheckJointCols <- function(object, jointCols) { - unlist(compact(map(jointCols, .qfmrJointColError, object = object))) + list_c(compact(map(jointCols, .qfmrJointColError, object = object))) } # @noRd @@ -141,12 +138,6 @@ setClass( } # ldSketch must be a GenotypeHandle or NULL. -# @noRd -.qfmrCheckLdSketch <- function(object) { - # The slot's class union enforces the type; nothing to check. - NULL -} - # The identity-tuple vectors and the payload list are parallel: one entry per # (study, context, trait, method). A length mismatch would otherwise surface as @@ -204,6 +195,8 @@ setClass( #' variantIds = tl$variant_id, susieFit = list(), topLoci = tl) #' QtlFineMappingResult(study = "s1", context = "brain", trait = "g1", #' method = "susie", entry = list(fe)) +#' @importFrom checkmate assertCharacter assert checkList +#' @importFrom checkmate checkClass #' @export QtlFineMappingResult <- function( study, @@ -217,11 +210,25 @@ QtlFineMappingResult <- function( traitPos = NULL, ldSketch = NULL ) { + assertCharacter(study, any.missing = FALSE) + assertCharacter(context, any.missing = FALSE) + assertCharacter(trait, any.missing = FALSE) + assertCharacter(method, any.missing = FALSE) + # `entry` is documented as "List / SimpleList"; SimpleList is S4 and + # fails checkList, so this must be an or-combination. + assert( + checkList(entry), + checkClass(entry, "SimpleList"), + .var.name = "entry" + ) + assertCharacter(jointStudies, null.ok = TRUE) + assertCharacter(jointContexts, null.ok = TRUE) + assertCharacter(jointTraits, null.ok = TRUE) n <- length(study) .qfmrCheckTupleLengths(study, context, trait, method, entry) entry <- map(entry, .asFmRowPayload) .checkRowPayloads(entry, "FineMappingRow", "fine-mapping") - cols <- list( + baseCols <- list( study = as.character(study), context = as.character(context), trait = as.character(trait), @@ -229,22 +236,24 @@ QtlFineMappingResult <- function( susieFit = S4Vectors::SimpleList(map(entry, getSusieFit)), cvResult = S4Vectors::SimpleList(map(entry, getCvResult)) ) - cols <- .qfmrAppendJointCols( - cols, + withJoint <- .qfmrAppendJointCols( + baseCols, jointStudies, jointContexts, jointTraits, n ) - cols <- .appendTraitPosCol(cols, traitPos, n) + cols <- .appendTraitPosCol(withJoint, traitPos, n) dfArgs <- c(cols, list(check.names = FALSE)) # Each entry's variants become one ELEMENT, its topLoci that element's # inner mcols, and its fit/cv payload outer mcols. A multi-seqname entry # splits by chromosome with its metadata row replicated. split <- .rtlSplitBySeqname(map(entry, rowVariants)) - grl <- GenomicRanges::GRangesList(split$entry) md <- exec(S4Vectors::DataFrame, !!!dfArgs) - mcols(grl) <- md[split$fromIdx, , drop = FALSE] + grl <- S4Vectors::`mcols<-`( + GenomicRanges::GRangesList(split$entry), + value = md[split$fromIdx, , drop = FALSE] + ) obj <- new( "QtlFineMappingResult", grl, @@ -254,7 +263,18 @@ QtlFineMappingResult <- function( obj } -# Append any supplied joint* provenance columns (each must match length(study)). +# Each joint-provenance column must be one value per row. +# @noRd +.qfmrCheckJointColLength <- function(nm, val, n) { + if (length(val) == n) { + return(invisible(NULL)) + } + msg <- glue("`{nm}` must have the same length as `study`.") + abort(msg) +} + +# Append any supplied joint* provenance columns (each must match +# length(study)). # @noRd .qfmrAppendJointCols <- function( cols, @@ -263,23 +283,13 @@ QtlFineMappingResult <- function( jointTraits, n ) { - joints <- list( + supplied <- compact(list( jointStudies = jointStudies, jointContexts = jointContexts, jointTraits = jointTraits - ) - for (nm in names(joints)) { - val <- joints[[nm]] - if (is.null(val)) { - next - } - if (length(val) != n) { - msg <- glue("`{nm}` must have the same length as `study`.") - abort(msg) - } - cols[[nm]] <- as.character(val) - } - cols + )) + walk2(names(supplied), supplied, .qfmrCheckJointColLength, n = n) + c(cols, map(supplied, as.character)) } # The single row a (study, context, trait, method) selector pins. @@ -331,9 +341,7 @@ setMethod( "{as.character(x$study)[1L]}|{as.character(x$context)[1L]}|", "{as.character(x$trait)[1L]}|{as.character(x$method)[1L]}" ) - out <- list() - out[[nm]] <- pip - return(out) + return(set_names(list(pip), nm)) } pip } diff --git a/R/RangedTupleList.R b/R/RangedTupleList.R index 8024da1b..5e1b3f9a 100644 --- a/R/RangedTupleList.R +++ b/R/RangedTupleList.R @@ -147,18 +147,17 @@ methods::setValidity("RangedTupleList", function(object) { return(grl) } if (length(GenomeInfoDb::seqlevels(grl)) == 0L) { - GenomeInfoDb::seqinfo(grl) <- si - return(grl) + return(GenomeInfoDb::`seqinfo<-`(grl, value = si)) } keepLevels <- intersect( GenomeInfoDb::seqlevels(si), GenomeInfoDb::seqlevels(grl) ) - GenomeInfoDb::seqinfo( + GenomeInfoDb::`seqinfo<-`( grl, - new2old = match(keepLevels, GenomeInfoDb::seqlevels(grl)) - ) <- si[keepLevels] - grl + new2old = match(keepLevels, GenomeInfoDb::seqlevels(grl)), + value = si[keepLevels] + ) } .rtlRebuild <- function(x, elements, keep) { @@ -166,16 +165,18 @@ methods::setValidity("RangedTupleList", function(object) { # during initialize(), and a subclass's validity method reads its identity # columns and slots. Building the object bare and filling it in afterwards # trips that check on the way past. - grl <- GenomicRanges::GRangesList(elements) + bare <- GenomicRanges::GRangesList(elements) # seqinfo is collection-level state, exactly like the slots below: it # carries the genome build. A rebuild from bare elements starts with the # seqlevels those elements happen to span -- none at all when everything # was dropped -- so the original seqinfo is merged back in, or subsetting # to nothing would silently discard the build. - grl <- .rtlRestoreSeqinfo(grl, x) + withSeqinfo <- .rtlRestoreSeqinfo(bare, x) md <- mcols(x, use.names = FALSE) - if (!is.null(md)) { - mcols(grl) <- md[keep, , drop = FALSE] + grl <- if (is.null(md)) { + withSeqinfo + } else { + S4Vectors::`mcols<-`(withSeqinfo, value = md[keep, , drop = FALSE]) } ownSlots <- .rtlOwnSlots(x) slotArgs <- set_names(map(ownSlots, .rtlGetSlot, x = x), ownSlots) @@ -259,10 +260,8 @@ setMethod("$", "RangedTupleList", function(x, name) { #' @rdname RangedTupleList-methods #' @export setMethod("$<-", "RangedTupleList", function(x, name, value) { - md <- mcols(x, use.names = FALSE) - md[[name]] <- value - mcols(x) <- md - x + md <- `[[<-`(mcols(x, use.names = FALSE), name, value = value) + S4Vectors::`mcols<-`(x, value = md) }) #' @rdname RangedTupleList-methods @@ -307,8 +306,7 @@ setMethod("[[<-", "RangedTupleList", function(x, i, j, ..., value) { abort(msg) } idx <- .rtlAssignIndex(x, i) - elements <- as.list(x) - elements[[idx]] <- value + elements <- `[[<-`(as.list(x), idx, value = value) # Growing the collection has no defined identity row for the new element, # and mcols would be padded with NA -- which the validity method reads as a # broken tuple. Rejected here so the failure names the real cause. @@ -324,6 +322,7 @@ setMethod("[[<-", "RangedTupleList", function(x, i, j, ..., value) { # Resolve `[[` index forms (positive integer or element name) to a position. # @noRd +#' @importFrom checkmate assertScalar .rtlAssignIndex <- function(x, i) { if (is.character(i)) { pos <- match(i, names(x)) @@ -332,9 +331,7 @@ setMethod("[[<-", "RangedTupleList", function(x, i, j, ..., value) { } return(pos) } - if (length(i) != 1L || is.na(i)) { - abort("`[[<-` takes a single non-NA index.") - } + assertScalar(i, na.ok = FALSE, .var.name = "`[[<-` index") as.integer(i) } @@ -436,7 +433,12 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region, ...) { } pieces <- map(entry, .rtlSplitOne) list( - entry = unlist(pieces, recursive = FALSE, use.names = TRUE), + # unname(): the flattened names were an artifact of base unlist()'s + # `outer.inner` mangling and were never coherent -- a multi-seqname + # entry got `a.chr1`, a single-seqname one got bare `a`, an unnamed + # input got `chr1` or "". Nothing reads them, and the seqname path + # already had to unname() derived values to keep them out of mcols. + entry = unname(list_flatten(pieces)), fromIdx = rep(seq_along(entry), lengths(pieces)) ) } @@ -499,7 +501,12 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region, ...) { warn(msg) } list( - entry = unlist(pieces, recursive = FALSE, use.names = TRUE), + # unname(): the flattened names were an artifact of base unlist()'s + # `outer.inner` mangling and were never coherent -- a multi-seqname + # entry got `a.chr1`, a single-seqname one got bare `a`, an unnamed + # input got `chr1` or "". Nothing reads them, and the seqname path + # already had to unname() derived values to keep them out of mcols. + entry = unname(list_flatten(pieces)), fromIdx = rep(seq_along(entry), lengths(pieces)), blockId = unname(list_c(map(pieces, names))) ) @@ -528,8 +535,9 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region, ...) { ) abort(msg) } - names(blocks) <- keys - blocks + # `names<-` not set_names(): `blocks` is a GRanges, and set_names() is + # vector-only -- it rejects an S4 object. + `names<-`(blocks, keys) } # Block keys come from names(), a `blockId` mcol, or the rendered range, in @@ -686,11 +694,26 @@ flattenTupleRanges <- function(x) { return(gr) } tupleCols <- names(md)[map_lgl(as.list(md), is.atomic)] - reps <- rep(seq_len(length(x)), lengths(x)) - for (nm in tupleCols) { - mcols(gr)[[.rtlDotName(nm)]] <- md[[nm]][reps] + if (length(tupleCols) == 0L) { + return(gr) } - gr + reps <- rep(seq_len(length(x)), lengths(x)) + broadcast <- set_names( + map(md[tupleCols], .rtlBroadcastColumn, reps = reps), + map_chr(tupleCols, .rtlDotName) + ) + `mcols<-`( + gr, + value = cbind( + mcols(gr, use.names = FALSE), + DataFrame(broadcast, check.names = FALSE) + ) + ) +} + +# @noRd +.rtlBroadcastColumn <- function(col, reps) { + col[reps] } # The broadcast name for an identity column. Dotted so it cannot collide with @@ -898,8 +921,14 @@ group_by.RangedTupleList <- function(.data, ...) { intersect(dotted, colnames(mcols(flat))), colnames(mcols(out)) ) - for (nm in missing) { - mcols(out)[[nm]] <- mcols(flat)[[nm]] - } - out + if (length(missing) == 0L) { + return(out) + } + `mcols<-`( + out, + value = cbind( + mcols(out, use.names = FALSE), + mcols(flat, use.names = FALSE)[, missing, drop = FALSE] + ) + ) } diff --git a/R/SldscData.R b/R/SldscData.R index 65a87abf..5caab186 100644 --- a/R/SldscData.R +++ b/R/SldscData.R @@ -46,30 +46,34 @@ setValidity("SldscData", function(object) .validateSldscData(object)) } # @noRd +#' @importFrom checkmate checkNames .sldscDataCheckAnnot <- function(annot) { - errs <- character(0) - if (!all(is_in(c("CHR", "SNP"), names(annot)))) { - errs <- c(errs, "`annot` must have columns CHR and SNP.") - } + cols <- checkNames(names(annot), must.include = c("CHR", "SNP")) annotCols <- setdiff(names(annot), c("CHR", "SNP", "BP", "CM")) - if (length(annotCols) == 0L) { - errs <- c( - errs, + c( + if (!isTRUE(cols)) { + str_c("`annot` must have columns CHR and SNP: ", cols) + }, + if (length(annotCols) == 0L) { str_c( "`annot` must have at least one annotation ", "column beyond CHR/SNP/BP/CM." ) - ) - } - errs + } + ) %||% + character(0) } # @noRd .sldscDataCheckFrq <- function(frq) { - if (nrow(frq) > 0L && !all(is_in(c("SNP", "MAF"), names(frq)))) { - return("non-empty `frq` must have columns SNP and MAF.") + if (nrow(frq) == 0L) { + return(NULL) } - NULL + cols <- checkNames(names(frq), must.include = c("SNP", "MAF")) + if (isTRUE(cols)) { + return(NULL) + } + str_c("non-empty `frq` must have columns SNP and MAF: ", cols) } # @noRd @@ -77,11 +81,14 @@ setValidity("SldscData", function(object) .validateSldscData(object)) if (length(tr) == 0L) { return(NULL) } - errs <- character(0) - if (is.null(names(tr)) || any(str_length(names(tr)) == 0L, na.rm = TRUE)) { - errs <- c(errs, "`traits` must be a named list (one entry per trait).") - } - c(errs, unlist(compact(map(names(tr), .sldscDataCheckOneTrait, tr = tr)))) + unnamed <- is.null(names(tr)) || + any(str_length(names(tr)) == 0L, na.rm = TRUE) + c( + if (unnamed) { + "`traits` must be a named list (one entry per trait)." + }, + list_c(compact(map(names(tr), .sldscDataCheckOneTrait, tr = tr))) + ) } # @noRd diff --git a/R/causalInferencePipeline.R b/R/causalInferencePipeline.R index c15228ca..d93b8ffb 100644 --- a/R/causalInferencePipeline.R +++ b/R/causalInferencePipeline.R @@ -102,7 +102,6 @@ #' 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. #' @examples #' data(qtlDatasetExample) @@ -125,48 +124,87 @@ causalInferencePipeline <- function( mrCpipCutoff = 0.5, mrPvalCutoff = 1, combineMethods = NULL, - alleleFlip = TRUE, - ... + alleleFlip = TRUE ) { mrMethod <- arg_match(mrMethod) - p <- as.list(environment()) - p$dots <- list(...) - .cipRun(p) + .cipRun( + gwasSumStats = gwasSumStats, + twasWeights = twasWeights, + fineMappingResult = fineMappingResult, + combineMethods = combineMethods, + rsqCutoff = rsqCutoff, + rsqOption = rsqOption, + rsqPvalCutoff = rsqPvalCutoff, + rsqPvalOption = rsqPvalOption, + alleleFlip = alleleFlip, + mrMethod = mrMethod, + mrPipCutoff = mrPipCutoff, + mrCpipCutoff = mrCpipCutoff, + mrPvalCutoff = mrPvalCutoff + ) } -# Orchestrate the causal-inference pipeline over a parameter bundle `p` (from -# as.list(environment())): validate, resolve the QTL work list, apply optional -# CV selection, score every (qtl, gwas) pair, and finalize. +# Orchestrate the causal-inference pipeline: validate, resolve the QTL work +# list, apply optional CV selection, score every (qtl, gwas) pair, finalize. # @noRd -.cipRun <- function(p) { - .cipValidateInputs(p$gwasSumStats, p$twasWeights, p$fineMappingResult) - p$gwasLd <- .cipCheckLdSketches( - p$gwasSumStats, - p$twasWeights, - p$fineMappingResult +.cipRun <- function( + gwasSumStats, + twasWeights, + fineMappingResult, + combineMethods, + rsqCutoff, + rsqOption, + rsqPvalCutoff, + rsqPvalOption, + alleleFlip, + mrMethod, + mrPipCutoff, + mrCpipCutoff, + mrPvalCutoff +) { + .cipValidateInputs(gwasSumStats, twasWeights, fineMappingResult) + gwasLd <- .cipCheckLdSketches( + gwasSumStats, + twasWeights, + fineMappingResult + ) + allRows <- .cipResolveWorkList(twasWeights, fineMappingResult) + sel <- .cipCvSelection( + qtlRows = allRows, + twasWeights = twasWeights, + rsqCutoff = rsqCutoff, + rsqOption = rsqOption, + rsqPvalCutoff = rsqPvalCutoff, + rsqPvalOption = rsqPvalOption ) - p$qtlRows <- .cipResolveWorkList(p$twasWeights, p$fineMappingResult) - sel <- .cipCvSelection(p) - p$qtlRows <- sel$qtlRows + qtlRows <- sel$qtlRows outRows <- list_flatten(map( - seq_len(nrow(p$qtlRows)), + seq_len(nrow(qtlRows)), .cipScoreQtlTuple, - p = p + qtlRows = qtlRows, + twasWeights = twasWeights, + fineMappingResult = fineMappingResult, + gwasSumStats = gwasSumStats, + gwasLd = gwasLd, + alleleFlip = alleleFlip, + mrMethod = mrMethod, + mrPipCutoff = mrPipCutoff, + mrCpipCutoff = mrCpipCutoff, + mrPvalCutoff = mrPvalCutoff )) if (length(outRows) == 0L) { abort( "causalInferencePipeline: no (qtl, gwas) tuples produced a result." ) } - .cipFinalize(outRows, sel, p$combineMethods) + .cipFinalize(outRows, sel, combineMethods) } # Validate the object classes + QC state of the pipeline inputs. # @noRd +#' @importFrom checkmate assertClass checkClass .cipValidateInputs <- function(gwasSumStats, twasWeights, fineMappingResult) { - if (!methods::is(gwasSumStats, "GwasSumStats")) { - abort("`gwasSumStats` must be a GwasSumStats object.") - } + assertClass(gwasSumStats, "GwasSumStats") if (length(getQcInfo(gwasSumStats)) == 0L) { msg <- glue( "causalInferencePipeline: gwasSumStats has no QC record ", @@ -181,17 +219,18 @@ causalInferencePipeline <- function( ) abort(msg) } - if (!is.null(twasWeights) && !methods::is(twasWeights, "TwasWeights")) { - abort("`twasWeights` must be a TwasWeights object or NULL.") - } - if ( - !is.null(fineMappingResult) && - !methods::is(fineMappingResult, "QtlFineMappingResult") - ) { + assertClass(twasWeights, "TwasWeights", null.ok = TRUE) + # Composed rather than asserted: rejecting the GWAS-side class here is + # deliberate, and checkClass alone cannot say so. + res <- checkClass( + fineMappingResult, + "QtlFineMappingResult", + null.ok = TRUE + ) + if (!isTRUE(res)) { msg <- glue( - "`fineMappingResult` must be a QtlFineMappingResult or NULL ", - "(causalInferencePipeline does not accept GWAS-side fine ", - "mapping for the QTL slot)." + "`fineMappingResult` {res} (causalInferencePipeline does not ", + "accept GWAS-side fine mapping for the QTL slot)." ) abort(msg) } @@ -232,29 +271,35 @@ causalInferencePipeline <- function( ) abort(msg) } - qtlRows$useFmrForWeights <- is.null(twasWeights) - qtlRows + mutate(qtlRows, useFmrForWeights = is.null(twasWeights)) } # Optional CV weight selection (legacy pick_best_model + update_twas_method): # filter to eligible methods now, deferring the final best-method pick to after # the TWAS Z. Returns list(qtlRows, rsqLookup, selectionActive). # @noRd -.cipCvSelection <- function(p) { - selectionActive <- !is.null(p$twasWeights) && - (p$rsqCutoff > 0 || is.finite(p$rsqPvalCutoff)) +.cipCvSelection <- function( + qtlRows, + twasWeights, + rsqCutoff, + rsqOption, + rsqPvalCutoff, + rsqPvalOption +) { + selectionActive <- !is.null(twasWeights) && + (rsqCutoff > 0 || is.finite(rsqPvalCutoff)) if (!selectionActive) { return(list( - qtlRows = p$qtlRows, + qtlRows = qtlRows, rsqLookup = NULL, selectionActive = FALSE )) } metricTab <- .cipMethodMetrics( - p$qtlRows, - p$twasWeights, - p$rsqOption, - p$rsqPvalOption + qtlRows, + twasWeights, + rsqOption, + rsqPvalOption ) rsqLookup <- set_names( metricTab$rsq, @@ -267,15 +312,15 @@ causalInferencePipeline <- function( ) ) qtlRows <- .cipFilterEligibleMethods( - p$qtlRows, + qtlRows, metricTab, - p$rsqCutoff, - p$rsqPvalCutoff + rsqCutoff, + rsqPvalCutoff ) if (nrow(qtlRows) == 0L) { msg <- glue( "causalInferencePipeline: every QTL tuple was filtered out by ", - "rsqCutoff = {p$rsqCutoff} / rsqPvalCutoff = {p$rsqPvalCutoff} ", + "rsqCutoff = {rsqCutoff} / rsqPvalCutoff = {rsqPvalCutoff} ", "(no method cleared the CV cutoffs)." ) abort(msg) @@ -286,25 +331,37 @@ causalInferencePipeline <- function( # Score one QTL tuple against every GWAS study -> a list of result records # (empty when the tuple has no usable weights). # @noRd -.cipScoreQtlTuple <- function(qi, p) { - qStudy <- p$qtlRows$qtlStudy[[qi]] - qContext <- p$qtlRows$context[[qi]] - qTrait <- p$qtlRows$trait[[qi]] - qMethod <- p$qtlRows$method[[qi]] +.cipScoreQtlTuple <- function( + qi, + qtlRows, + twasWeights, + fineMappingResult, + gwasSumStats, + gwasLd, + alleleFlip, + mrMethod, + mrPipCutoff, + mrCpipCutoff, + mrPvalCutoff +) { + qStudy <- qtlRows$qtlStudy[[qi]] + qContext <- qtlRows$context[[qi]] + qTrait <- qtlRows$trait[[qi]] + qMethod <- qtlRows$method[[qi]] weightsInfo <- .cipExtractWeights( - twasWeights = p$twasWeights, - fineMappingResult = p$fineMappingResult, + twasWeights = twasWeights, + fineMappingResult = fineMappingResult, study = qStudy, context = qContext, trait = qTrait, method = qMethod, - useFmr = p$qtlRows$useFmrForWeights[[qi]] + useFmr = qtlRows$useFmrForWeights[[qi]] ) if (is.null(weightsInfo)) { return(list()) } fmrEntry <- .cipResolveFmrEntry( - p$fineMappingResult, + fineMappingResult, qStudy, qContext, qTrait, @@ -317,12 +374,18 @@ causalInferencePipeline <- function( qMethod = qMethod ) compact(map( - seq_len(nrow(p$gwasSumStats)), + seq_len(nrow(gwasSumStats)), .cipScoreGwasPair, tuple = tuple, weightsInfo = weightsInfo, fmrEntry = fmrEntry, - p = p + gwasSumStats = gwasSumStats, + gwasLd = gwasLd, + alleleFlip = alleleFlip, + mrMethod = mrMethod, + mrPipCutoff = mrPipCutoff, + mrCpipCutoff = mrCpipCutoff, + mrPvalCutoff = mrPvalCutoff )) } @@ -352,10 +415,22 @@ causalInferencePipeline <- function( # Score one (qtl tuple, gwas study) pair -> a result record, or NULL when the # TWAS Z cannot be computed (too little overlap). # @noRd -.cipScoreGwasPair <- function(gi, tuple, weightsInfo, fmrEntry, p) { - gStudy <- as.character(p$gwasSumStats$study)[[gi]] +.cipScoreGwasPair <- function( + gi, + tuple, + weightsInfo, + fmrEntry, + gwasSumStats, + gwasLd, + alleleFlip, + mrMethod, + mrPipCutoff, + mrCpipCutoff, + mrPvalCutoff +) { + gStudy <- as.character(gwasSumStats$study)[[gi]] gdf <- getSumStatsDf( - p$gwasSumStats, + gwasSumStats, study = gStudy, require = c("SNP", "Z") ) @@ -363,14 +438,23 @@ causalInferencePipeline <- function( weights = weightsInfo$weights, variantIds = weightsInfo$variantIds, gwasDf = gdf, - gwasLd = p$gwasLd, - alleleFlip = p$alleleFlip, + gwasLd = gwasLd, + alleleFlip = alleleFlip, label = .cipPairLabel(tuple, gStudy) ) if (is.null(twasOut)) { return(NULL) } - mrOut <- .cipRunMr(fmrEntry, gdf, twasOut, p) + mrOut <- .cipRunMr( + fmrEntry, + gdf, + twasOut, + alleleFlip = alleleFlip, + mrMethod = mrMethod, + mrPipCutoff = mrPipCutoff, + mrCpipCutoff = mrCpipCutoff, + mrPvalCutoff = mrPvalCutoff + ) .cipResultRow(tuple, gStudy, twasOut, mrOut) } @@ -387,25 +471,34 @@ causalInferencePipeline <- function( # Run MR for a pair, gated on the TWAS p-value (mrPvalCutoff >= 1 disables the # gate) and the presence of a fine-mapping entry. # @noRd -.cipRunMr <- function(fmrEntry, gdf, twasOut, p) { - mrGateOpen <- p$mrPvalCutoff >= 1 || - (!is.na(twasOut$pval) && twasOut$pval < p$mrPvalCutoff) +.cipRunMr <- function( + fmrEntry, + gdf, + twasOut, + alleleFlip, + mrMethod, + mrPipCutoff, + mrCpipCutoff, + mrPvalCutoff +) { + mrGateOpen <- mrPvalCutoff >= 1 || + (!is.na(twasOut$pval) && twasOut$pval < mrPvalCutoff) if (is.null(fmrEntry) || !mrGateOpen) { return(.cipEmptyMr()) } - if (p$mrMethod == "csAware") { + if (mrMethod == "csAware") { .cipComputeMrCsAware( fmrEntry = fmrEntry, gwasDf = gdf, - cpipCutoff = p$mrCpipCutoff, - alleleFlip = p$alleleFlip + cpipCutoff = mrCpipCutoff, + alleleFlip = alleleFlip ) } else { .cipComputeMr( fmrEntry = fmrEntry, gwasDf = gdf, - pipCutoff = p$mrPipCutoff, - alleleFlip = p$alleleFlip + pipCutoff = mrPipCutoff, + alleleFlip = alleleFlip ) } } @@ -452,17 +545,21 @@ causalInferencePipeline <- function( # GRanges, and (optionally) combine across methods. # @noRd .cipFinalize <- function(outRows, sel, combineMethods) { - resultDf <- .cipRowsToDf(outRows) + allRows <- .cipRowsToDf(outRows) # Final best-method pick + NA/Inf re-selection (legacy update_twas_method): # per (qtlStudy, context, trait, gwasStudy) keep the highest-rsqOption # eligible method whose TWAS Z is finite, falling back to the top-rsq method # when none is finite. SS-TWAS groups (no usable rsq) keep all methods. - if (sel$selectionActive) { - resultDf <- .cipSelectBestMethod(resultDf, sel$rsqLookup) + resultDf <- if (sel$selectionActive) { + .cipSelectBestMethod(allRows, sel$rsqLookup) + } else { + allRows } - out <- .cipDfToGranges(resultDf) - if (!is.null(combineMethods)) { - out <- .cipCombineAcrossMethods(out, methods = combineMethods) + perMethod <- .cipDfToGranges(resultDf) + out <- if (is.null(combineMethods)) { + perMethod + } else { + .cipCombineAcrossMethods(perMethod, methods = combineMethods) } out } @@ -511,8 +608,9 @@ causalInferencePipeline <- function( # metrics vector / data frame is tolerated too. `which` is a vector of candidate # metric names; the first present is used. Returns NA when no usable metric. # @noRd +#' @importFrom rlang try_fetch .cipCvMetric <- function(twasWeights, study, context, trait, method, which) { - perf <- tryCatch( + perf <- try_fetch( getCvResult( twasWeights, study = study, @@ -520,7 +618,7 @@ causalInferencePipeline <- function( trait = trait, method = method ), - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(perf)) { return(NA_real_) @@ -585,24 +683,49 @@ causalInferencePipeline <- function( metricTab$trait, sep = "\r" ) - keep <- logical(nrow(qtlRows)) - pvalGate <- is.finite(rsqPvalCutoff) - for (g in unique(grp)) { - idx <- which(grp == g) - rsq <- metricTab$rsq[idx] - if (all(is.na(rsq))) { - keep[idx] <- TRUE - next - } # SS-TWAS: keep all - elig <- !is.na(rsq) & rsq >= rsqCutoff - if (pvalGate) { - elig <- elig & - !is.na(metricTab$pval[idx]) & - metricTab$pval[idx] < rsqPvalCutoff - } - keep[idx[elig]] <- TRUE + kept <- .cipConcatInt(map( + unique(grp), + .cipEligibleRowsIn, + grp = grp, + metricTab = metricTab, + rsqCutoff = rsqCutoff, + rsqPvalCutoff = rsqPvalCutoff + )) + filter(qtlRows, .cipRowMask(kept, nrow(qtlRows))) +} + +# @noRd +.cipConcatInt <- function(pieces) { + if (length(pieces) == 0L) { + return(integer(0)) } - filter(qtlRows, keep) + list_c(pieces) +} + +# A logical mask of length `n` that is TRUE at `at`. +# @noRd +.cipRowMask <- function(at, n) { + replace(logical(n), at, TRUE) +} + +# The rows of group `g` that clear the R^2 (and optional p-value) gate. A +# group with no usable R^2 at all is SS-TWAS, which keeps every row. +# @noRd +.cipEligibleRowsIn <- function(g, grp, metricTab, rsqCutoff, rsqPvalCutoff) { + idx <- which(grp == g) + rsq <- metricTab$rsq[idx] + if (all(is.na(rsq))) { + return(idx) + } + byRsq <- !is.na(rsq) & rsq >= rsqCutoff + elig <- if (!is.finite(rsqPvalCutoff)) { + byRsq + } else { + byRsq & + !is.na(metricTab$pval[idx]) & + metricTab$pval[idx] < rsqPvalCutoff + } + idx[elig] } # Final best-method pick + NA/Inf re-selection (legacy update_twas_method): per @@ -618,21 +741,30 @@ causalInferencePipeline <- function( key <- str_c(df$qtlStudy, df$context, df$trait, df$method, sep = "\r") rsq <- unname(rsqLookup[key]) grp <- str_c(df$qtlStudy, df$context, df$trait, df$gwasStudy, sep = "\r") - keepRow <- logical(nrow(df)) - for (g in unique(grp)) { - idx <- which(grp == g) - r <- rsq[idx] - if (all(is.na(r))) { - keepRow[idx] <- TRUE - next - } # SS-TWAS: keep all - ord <- idx[order(r, decreasing = TRUE)] # NA sorts last - z <- suppressWarnings(as.numeric(df$twasZ[ord])) - fin <- which(is.finite(z)) - sel <- if (length(fin) > 0L) ord[[fin[[1L]]]] else ord[[1L]] - keepRow[sel] <- TRUE - } - filter(df, keepRow) + kept <- .cipConcatInt(map( + unique(grp), + .cipBestRowsIn, + grp = grp, + df = df, + rsq = rsq + )) + filter(df, .cipRowMask(kept, nrow(df))) +} + +# The row group `g` contributes: the highest-R^2 method whose twasZ is finite, +# else the highest-R^2 one. A group with no usable R^2 is SS-TWAS and keeps +# every row. +# @noRd +.cipBestRowsIn <- function(g, grp, df, rsq) { + idx <- which(grp == g) + r <- rsq[idx] + if (all(is.na(r))) { + return(idx) + } + ord <- idx[order(r, decreasing = TRUE)] # NA sorts last + z <- suppressWarnings(as.numeric(df$twasZ[ord])) + fin <- which(is.finite(z)) + if (length(fin) > 0L) ord[[fin[[1L]]]] else ord[[1L]] } .cipFmrHasTuple <- function(fmr, study, context, trait, method) { @@ -1080,8 +1212,8 @@ causalInferencePipeline <- function( # 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 + invVar <- 1 / se^2 + ok <- is.finite(invVar) & invVar > 0 if (!any(ok)) { return(list( effect = NA_real_, @@ -1092,7 +1224,7 @@ causalInferencePipeline <- function( )) } effect <- effect[ok] - w <- w[ok] + w <- invVar[ok] metaEff <- sum(w * effect) / sum(w) metaSe <- 1 / sqrt(sum(w)) list( @@ -1109,10 +1241,15 @@ causalInferencePipeline <- function( # 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 <- cn[str_detect(cn, "^cs")] - if (length(csCand) > 0L) cs <- csCand[[1L]] + exact <- intersect("cs", cn) + # No bare `cs` column: fall back to the first cs_ variant. + csCand <- cn[str_detect(cn, "^cs")] + cs <- if (length(exact) > 0L) { + exact + } else if (length(csCand) > 0L) { + csCand[[1L]] + } else { + exact } list( pip = intersect(c("pip", "PIP"), cn), @@ -1156,8 +1293,7 @@ causalInferencePipeline <- function( "nCs" )) ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(mcols) - gr + S4Vectors::`mcols<-`(gr, value = S4Vectors::DataFrame(mcols)) } # Combine TWAS p-values across method for each (qtlStudy, context, @@ -1165,37 +1301,64 @@ causalInferencePipeline <- function( # combined p-value and methodName = "combined.". Uses # combinePValues() with the cross-method correlation set to the identity # (we have no cross-method covariance available downstream). +# @noRd +.cipConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) + } + list_c(pieces) +} + +# One combined row: the group's first row re-stamped with the combined +# p-value for method `m`. The per-method statistics do not carry over, so +# they are blanked rather than inherited. +# @noRd +.cipCombinedRow <- function(m, mc, rows, cp) { + mutate( + slice(mc, rows[[1L]]), + method = str_c("combined.", m), + twasZ = NA_real_, + twasPval = as.numeric(cp$results[[m]]$pval), + waldRatio = NA_real_, + waldRatioSe = NA_real_, + mrPval = NA_real_, + nIV = NA_integer_ + ) +} + +# One group's combined rows, or none when it holds a single method (nothing +# to combine across). +# @noRd +.cipCombinedRowsFor <- function(rows, mc, methods) { + if (length(rows) < 2L) { + return(list()) + } + cp <- combinePValues( + pvals = as.numeric(mc$twasPval[rows]), + zScores = as.numeric(mc$twasZ[rows]), + methods = methods + ) + map(methods, .cipCombinedRow, mc = mc, rows = rows, cp = cp) +} + .cipCombineAcrossMethods <- function(gr, methods) { mc <- as_tibble(as.data.frame(S4Vectors::mcols(gr))) key <- str_c(mc$qtlStudy, mc$context, mc$trait, mc$gwasStudy, sep = "||") groups <- split(seq_len(nrow(mc)), key) - extras <- list() - for (gkey in names(groups)) { - rows <- groups[[gkey]] - if (length(rows) < 2L) { - next - } - pvals <- as.numeric(mc$twasPval[rows]) - zvec <- as.numeric(mc$twasZ[rows]) - cp <- combinePValues(pvals = pvals, zScores = zvec, methods = methods) - for (m in methods) { - newRow <- slice(mc, rows[[1L]]) - newRow$method <- str_c("combined.", m) - newRow$twasZ <- NA_real_ - newRow$twasPval <- as.numeric(cp$results[[m]]$pval) - newRow$waldRatio <- NA_real_ - newRow$waldRatioSe <- NA_real_ - newRow$mrPval <- NA_real_ - newRow$nIV <- NA_integer_ - extras[[length(extras) + 1L]] <- newRow - } - } + extras <- .cipConcat(map( + groups, + .cipCombinedRowsFor, + mc = mc, + methods = methods + )) if (length(extras) == 0L) { return(gr) } newMcs <- bind_rows(extras) - newGr <- gr[rep(1L, nrow(newMcs))] - S4Vectors::mcols(newGr) <- S4Vectors::DataFrame(newMcs) + newGr <- S4Vectors::`mcols<-`( + gr[rep(1L, nrow(newMcs))], + value = S4Vectors::DataFrame(newMcs) + ) c(gr, newGr) } @@ -1235,6 +1398,7 @@ causalInferencePipeline <- function( # Row-align V to the weights (by name when available, else positionally). # @noRd +#' @importFrom checkmate assertMatrix .twasZAlignV <- function(V, rn, nW) { if (!is.null(rownames(V)) && !is.null(rn)) { idx <- match(rn, rownames(V)) @@ -1247,11 +1411,7 @@ causalInferencePipeline <- function( } return(V[idx, , drop = FALSE]) } - if (nrow(V) != nW) { - abort( - "twasZ: positional alignment requires nrow(V) == nrow(weights)." - ) - } + assertMatrix(V, nrows = nW, .var.name = "V (positional alignment)") V } @@ -1270,6 +1430,7 @@ causalInferencePipeline <- function( # Symmetric-align R to the weights (by name when available, else positionally). # @noRd +#' @importFrom checkmate assertMatrix .twasZAlignR <- function(R, rn, nW) { if (!is.null(rownames(R)) && !is.null(rn)) { idx <- match(rn, rownames(R)) @@ -1282,11 +1443,7 @@ causalInferencePipeline <- function( } return(R[idx, idx, drop = FALSE]) } - if (nrow(R) != nW) { - abort( - "twasZ: positional alignment requires nrow(R) == nrow(weights)." - ) - } + assertMatrix(R, nrows = nW, .var.name = "R (positional alignment)") R } @@ -1347,6 +1504,7 @@ causalInferencePipeline <- function( #' w <- setNames(rnorm(20) * 0.1, colnames(X)) #' twasZ(weights = w, z = rnorm(20), R = cor(X)) #' @export +#' @importFrom checkmate assertCharacter assertCount twasZ <- function( weights, z, @@ -1357,6 +1515,8 @@ twasZ <- function( nSketch = NULL, combineMethods = NULL ) { + assertCount(nSketch, positive = TRUE, null.ok = TRUE) + assertCharacter(combineMethods, null.ok = TRUE) weights <- .twasZPrepWeights(weights, z) covY <- .twasZCovY( weights = weights, @@ -1370,8 +1530,10 @@ twasZ <- function( stats <- as.numeric(crossprod(weights, as.numeric(z))) zVec <- stats / ySd pVec <- .zToPvalue(zVec) - zMatrix <- cbind(Z = zVec, pval = pVec) - rownames(zMatrix) <- colnames(weights) + zMatrix <- `rownames<-`( + cbind(Z = zVec, pval = pVec), + colnames(weights) + ) combined <- .twasZCombine( combineMethods, ncol(weights), @@ -1387,6 +1549,7 @@ twasZ <- function( # Coerce a weight vector to a one-column matrix, validate the class / dims, and # default the column names. # @noRd +#' @importFrom checkmate assertMatrix .twasZPrepWeights <- function(weights, z) { if (is.numeric(weights) && is.null(dim(weights))) { nm <- if (!is.null(names(weights))) names(weights) else NULL @@ -1395,13 +1558,13 @@ twasZ <- function( if (!is.matrix(weights)) { abort("`weights` must be a numeric vector or a matrix.") } - if (is.null(colnames(weights))) { - colnames(weights) <- str_c("method", seq_len(ncol(weights))) - } - if (nrow(weights) != length(z)) { - abort("nrow(weights) must equal length(z).") + named <- if (is.null(colnames(weights))) { + `colnames<-`(weights, str_c("method", seq_len(ncol(weights)))) + } else { + weights } - weights + assertMatrix(named, nrows = length(z), .var.name = "weights") + named } # Optional cross-tuple p-value combination via combinePValues (K == 1 uses the @@ -1415,13 +1578,14 @@ twasZ <- function( if (K == 1L) { return(.twasZCombineSingle(combineMethods, pVec, zMatrix)) } - sig <- covY / tcrossprod(ySd, ySd) - rownames(sig) <- colnames(sig) <- rownames(zMatrix) - names(pVec) <- rownames(zMatrix) - names(zVec) <- rownames(zMatrix) + methodNames <- rownames(zMatrix) + sig <- `dimnames<-`( + covY / tcrossprod(ySd, ySd), + list(methodNames, methodNames) + ) combinePValues( - pvals = pVec, - zScores = zVec, + pvals = set_names(pVec, methodNames), + zScores = set_names(zVec, methodNames), methods = combineMethods, R = sig ) diff --git a/R/colocPipeline.R b/R/colocPipeline.R index 8a21f9ec..e6f4c2ef 100644 --- a/R/colocPipeline.R +++ b/R/colocPipeline.R @@ -130,7 +130,8 @@ #' 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}. +#' @param colocArgs Optional named list of additional arguments forwarded +#' to \code{coloc::coloc.bf_bf}. #' @return A \code{\linkS4class{ColocResult}}: one element per tested #' (first-side credible set, second-side credible set, block) pair, holding #' that pair's aligned variants with their \code{SNP.PP.H4}. Pair-level @@ -178,70 +179,106 @@ colocPipeline <- function( p12Max = 1e-3, adjustPips = TRUE, alleleFlip = TRUE, - ... + colocArgs = list() ) { - p <- as.list(environment()) - p$dots <- list(...) - p$useEnrichment <- !is.null(enrichment) - .colocValidateInputs(p) - p$gwasFmr <- .colocResolveGwasFmr(gwasInput, finemappingMethods) + useEnrichment <- !is.null(enrichment) + .colocValidateInputs( + gwasInput = gwasInput, + qtlFineMappingResult = qtlFineMappingResult, + enrichment = enrichment, + useEnrichment = useEnrichment + ) + rawGwasFmr <- .colocResolveGwasFmr(gwasInput, finemappingMethods) .colocRequireMatchingLdSketches( getLdSketch(qtlFineMappingResult), - getLdSketch(p$gwasFmr) + getLdSketch(rawGwasFmr) ) - p <- .colocMaybeAdjustPips(p) + adjusted <- .colocMaybeAdjustPips( + adjustPips = adjustPips, + qtlFineMappingResult = qtlFineMappingResult, + gwasFmr = rawGwasFmr + ) + qtlFineMappingResult <- adjusted$qtlFineMappingResult + gwasFmr <- adjusted$gwasFmr # Pre-extract per-GWAS-tuple LBF matrices: group the GWAS FMR by study, # stack each study's LBF rows, and store per-(study, method) batched # matrices (reproduces the legacy row-wise combine per xQTL). - p$gwasLbfByPair <- .colocPreextractGwasLbf( - p$gwasFmr, + gwasLbfByPair <- .colocPreextractGwasLbf( + gwasFmr, filterLbfCs, filterLbfCsSecondary, filterLbfCsConcentration, priorTol ) - if (length(p$gwasLbfByPair) == 0L) { - return(.colocEarlyReturn(p)) + if (length(gwasLbfByPair) == 0L) { + return(.colocEarlyReturn( + useEnrichment = useEnrichment, + qtlFineMappingResult = qtlFineMappingResult, + gwasFmr = gwasFmr, + gwasInput = gwasInput, + returnGwasFineMapping = returnGwasFineMapping + )) } results <- list_flatten(map( - seq_len(nrow(p$qtlFineMappingResult)), + seq_len(nrow(qtlFineMappingResult)), .colocScoreQtlTuple, - p = p + qtlFineMappingResult = qtlFineMappingResult, + gwasLbfByPair = gwasLbfByPair, + filterLbfCs = filterLbfCs, + filterLbfCsSecondary = filterLbfCsSecondary, + filterLbfCsConcentration = filterLbfCsConcentration, + priorTol = priorTol, + useEnrichment = useEnrichment, + enrichment = enrichment, + p12 = p12, + p12Max = p12Max, + p1 = p1, + p2 = p2, + alleleFlip = alleleFlip, + colocArgs = colocArgs )) - .colocFinalize(results, p) + .colocFinalize( + results, + useEnrichment = useEnrichment, + qtlFineMappingResult = qtlFineMappingResult, + gwasFmr = gwasFmr, + gwasInput = gwasInput, + returnGwasFineMapping = returnGwasFineMapping + ) } # Validate the enrichment table (when supplied), the coloc package, and the # input object classes. # @noRd -.colocValidateInputs <- function(p) { - if (p$useEnrichment) { - .colocValidateEnrichment(p$enrichment) +.colocValidateInputs <- function( + gwasInput, + qtlFineMappingResult, + enrichment, + useEnrichment +) { + if (useEnrichment) { + .colocValidateEnrichment(enrichment) } if (!requireNamespace("coloc", quietly = TRUE)) { - msg <- glue( - "Package 'coloc' is required for colocPipeline. ", - "Install with: install.packages('coloc')." - ) - abort(msg) + abort("Package 'coloc' is required for colocPipeline.") } - if (!methods::is(p$qtlFineMappingResult, "FineMappingResultBase")) { + if (!methods::is(qtlFineMappingResult, "FineMappingResultBase")) { msg <- glue( "`qtlFineMappingResult` must be a QtlFineMappingResult or a ", "GwasFineMappingResult ", - "(got class '{class(p$qtlFineMappingResult)[[1L]]}')." + "(got class '{class(qtlFineMappingResult)[[1L]]}')." ) abort(msg) } if ( - !methods::is(p$gwasInput, "SumStatsBase") && - !methods::is(p$gwasInput, "FineMappingResultBase") + !methods::is(gwasInput, "SumStatsBase") && + !methods::is(gwasInput, "FineMappingResultBase") ) { msg <- glue( "`gwasInput` must be a fine-mapping result ", "(QtlFineMappingResult / GwasFineMappingResult) or summary ", "statistics (QtlSumStats / GwasSumStats) ", - "(got class '{class(p$gwasInput)[[1L]]}')." + "(got class '{class(gwasInput)[[1L]]}')." ) abort(msg) } @@ -251,24 +288,18 @@ colocPipeline <- function( # The enrichment table must be a data.frame carrying the required id + value # columns. # @noRd +#' @importFrom checkmate assertDataFrame assertNames .colocValidateEnrichment <- function(enrichment) { - if (!is.data.frame(enrichment)) { - msg <- glue( - "`enrichment` must be a data.frame with at least gwasStudy, ", - "qtlStudy, qtlContext, enrichment columns (output of ", - "qtlEnrichmentPipeline)." - ) - abort(msg) - } - required <- c("gwasStudy", "qtlStudy", "qtlContext", "enrichment") - missingCols <- setdiff(required, colnames(enrichment)) - if (length(missingCols) > 0L) { - msg <- glue( - "`enrichment` is missing column(s): ", - "{str_flatten(missingCols, ', ')}" - ) - abort(msg) - } + # The producer is named in .var.name so a caller passing the wrong object + # is pointed at what produces the right one. + label <- "enrichment (output of qtlEnrichmentPipeline)" + assertDataFrame(enrichment, .var.name = label) + assertNames( + colnames(enrichment), + must.include = c("gwasStudy", "qtlStudy", "qtlContext", "enrichment"), + what = "colnames", + .var.name = label + ) .colocValidateEnrichmentKeys(enrichment) invisible(NULL) } @@ -318,17 +349,23 @@ colocPipeline <- function( # adjusted each side to the UNION of the other's variants -- a union is not an # intersection, so the two sides could still end up on different sets. # @noRd -.colocMaybeAdjustPips <- function(p) { - if (!isTRUE(p$adjustPips)) { - return(p) +.colocMaybeAdjustPips <- function( + adjustPips, + qtlFineMappingResult, + gwasFmr +) { + unchanged <- list( + qtlFineMappingResult = qtlFineMappingResult, + gwasFmr = gwasFmr + ) + if (!isTRUE(adjustPips)) { + return(unchanged) } - if (nrow(p$qtlFineMappingResult) == 0L || nrow(p$gwasFmr) == 0L) { - return(p) + if (nrow(qtlFineMappingResult) == 0L || nrow(gwasFmr) == 0L) { + return(unchanged) } - both <- intersectVariants(p$qtlFineMappingResult, p$gwasFmr) - p$qtlFineMappingResult <- both$x - p$gwasFmr <- both$y - p + both <- intersectVariants(qtlFineMappingResult, gwasFmr) + list(qtlFineMappingResult = both$x, gwasFmr = both$y) } # The LD reference the result carries forward, so getColocCredibleSets() can @@ -338,53 +375,82 @@ colocPipeline <- function( # first side fit on individual-level data carries none, and then the second # side's panel is the only one there is. # @noRd -.colocLdSketch <- function(p) { - getLdSketch(p$qtlFineMappingResult) %||% getLdSketch(p$gwasFmr) +.colocLdSketch <- function(qtlFineMappingResult, gwasFmr) { + getLdSketch(qtlFineMappingResult) %||% getLdSketch(gwasFmr) } # Empty-result early return (attaching the GWAS fine-mapping when requested). # @noRd -.colocEarlyReturn <- function(p) { +.colocEarlyReturn <- function( + useEnrichment, + qtlFineMappingResult, + gwasFmr, + gwasInput, + returnGwasFineMapping +) { out <- .colocEmptyResult( - enriched = p$useEnrichment, - ldSketch = .colocLdSketch(p) + enriched = useEnrichment, + ldSketch = .colocLdSketch(qtlFineMappingResult, gwasFmr) ) - if (p$returnGwasFineMapping && methods::is(p$gwasInput, "SumStatsBase")) { - attr(out, "gwasFineMapping") <- p$gwasFmr - } - out + .colocAttachGwasFm(out, returnGwasFineMapping, gwasInput, gwasFmr) } # Score one QTL tuple against every pre-extracted GWAS pair -> summary rows. # @noRd -.colocScoreQtlTuple <- function(qi, p) { - q <- .colocQtlTupleInfo(qi, p) +.colocScoreQtlTuple <- function( + qi, + qtlFineMappingResult, + gwasLbfByPair, + filterLbfCs, + filterLbfCsSecondary, + filterLbfCsConcentration, + priorTol, + useEnrichment, + enrichment, + p12, + p12Max, + p1, + p2, + alleleFlip, + colocArgs +) { + q <- .colocQtlTupleInfo(qi, qtlFineMappingResult) qLbfInfo <- .colocExtractLbfFromEntry( q$parts, - p$filterLbfCs, - p$filterLbfCsSecondary, - p$filterLbfCsConcentration, - p$priorTol, + filterLbfCs, + filterLbfCsSecondary, + filterLbfCsConcentration, + priorTol, label = q$label ) if (is.null(qLbfInfo)) { return(list()) } - q$retainedMass <- qLbfInfo$retainedMass - q$effect <- qLbfInfo$effect + scored <- list_assign( + q, + retainedMass = qLbfInfo$retainedMass, + effect = qLbfInfo$effect + ) compact(map( - p$gwasLbfByPair, + gwasLbfByPair, .colocScorePairAt, qLbfInfo = qLbfInfo, - p = p, - q = q + q = scored, + useEnrichment = useEnrichment, + enrichment = enrichment, + p12 = p12, + p12Max = p12Max, + p1 = p1, + p2 = p2, + alleleFlip = alleleFlip, + colocArgs = colocArgs )) } # Identity + row payload + log label for one first-side tuple. # @noRd -.colocQtlTupleInfo <- function(qi, p) { - fmr <- p$qtlFineMappingResult +.colocQtlTupleInfo <- function(qi, qtlFineMappingResult) { + fmr <- qtlFineMappingResult ident <- .colocTupleIdentity(fmr, qi) c( ident, @@ -410,19 +476,46 @@ colocPipeline <- function( # Score one (QTL, GWAS) pair via coloc.bf_bf -> a summary row, or NULL when the # variants don't align or coloc fails / returns no summary. # @noRd -.colocScorePair <- function(qLbf, gInfo, q, p) { +.colocScorePair <- function( + qLbf, + gInfo, + q, + useEnrichment, + enrichment, + p12, + p12Max, + p1, + p2, + alleleFlip, + colocArgs +) { # Align variants between the QTL and GWAS LBF matrices by (chrom, pos, # allele) tuple via matchVariants (see .colocAlignLbf). - aligned <- .colocAlignLbf(qLbf, gInfo$lbf, alleleFlip = p$alleleFlip) + aligned <- .colocAlignLbf(qLbf, gInfo$lbf, alleleFlip = alleleFlip) if (is.null(aligned)) { return(NULL) } - p12Info <- .colocResolveP12(p, gInfo, q) - pairRes <- .colocRunPair(aligned, p, p12Info$p12Used, q, gInfo) + p12Info <- .colocResolveP12( + gInfo, + q, + useEnrichment = useEnrichment, + enrichment = enrichment, + p12 = p12, + p12Max = p12Max + ) + pairRes <- .colocRunPair( + aligned, + p12Info$p12Used, + q, + gInfo, + p1 = p1, + p2 = p2, + colocArgs = colocArgs + ) if (is.null(pairRes) || is.null(pairRes$summary)) { return(NULL) } - rows <- .colocSummaryRow(pairRes, q, gInfo, p, p12Info) + rows <- .colocSummaryRow(pairRes, q, gInfo, useEnrichment, p12Info) # $results is the per-variant layer that process_coloc_results() used to # consume and that this pipeline silently dropped. It is pivoted here, the # only place that knows which results column belongs to which summary row. @@ -435,108 +528,152 @@ colocPipeline <- function( # Enrichment-informed p12 (per-(gwasStudy, qtlStudy, qtlContext) scaling capped # at p12Max; baseline p12 with no enrichment table / no matching row). # @noRd -.colocResolveP12 <- function(p, gInfo, q) { - if (!p$useEnrichment) { - return(list(enRow = NA_real_, p12Used = p$p12)) +.colocResolveP12 <- function( + gInfo, + q, + useEnrichment, + enrichment, + p12, + p12Max +) { + if (!useEnrichment) { + return(list(enRow = NA_real_, p12Used = p12)) } - enRow <- .colocLookupEnrichment(p$enrichment, gInfo, q) - if (is.na(enRow)) { + looked <- .colocLookupEnrichment(enrichment, gInfo, q) + enRow <- if (is.na(looked)) 0 else looked + if (is.na(looked)) { msg <- glue( "colocPipeline: no enrichment entry for ", "(gwasStudy='{gInfo$study}', qtlStudy='{q$study}', ", "qtlContext='{q$context}'); using baseline p12." ) warn(msg) - enRow <- 0 } - list(enRow = enRow, p12Used = min(p$p12 * (1 + enRow), p$p12Max)) + list(enRow = enRow, p12Used = min(p12 * (1 + enRow), p12Max)) } # Run coloc.bf_bf for an aligned pair, warning + NULL on failure. # @noRd -.colocRunPair <- function(aligned, p, p12Used, q, gInfo) { - colocArgs <- c( +#' @importFrom rlang try_fetch +.colocRunPair <- function(aligned, p12Used, q, gInfo, p1, p2, colocArgs) { + callArgs <- c( list( aligned$qtl, aligned$gwas, - p1 = p$p1, - p2 = p$p2, + p1 = p1, + p2 = p2, p12 = p12Used ), - p$dots + colocArgs ) - tryCatch( - exec(coloc::coloc.bf_bf, !!!colocArgs), - error = function(e) { + try_fetch( + exec(coloc::coloc.bf_bf, !!!callArgs), + error = function(cnd) { msg <- glue( "colocPipeline: coloc.bf_bf failed for ", - "{q$label} x {gInfo$label}: ", - "{conditionMessage(e)}" + "{q$label} x {gInfo$label}" ) - warn(msg) + warn(msg, parent = cnd) NULL } ) } +# The enrichment columns, present only when the pipeline used an enrichment +# table. A NULL `p12Info` carries the zero-row schema an empty result needs. +# @noRd +.colocEnrichmentCols <- function(useEnrichment, p12Info) { + if (!useEnrichment) { + return(list()) + } + if (is.null(p12Info)) { + return(list(enrichment = numeric(0), p12Used = numeric(0))) + } + list(enrichment = p12Info$enRow, p12Used = p12Info$p12Used) +} + # Build a coloc summary row carrying the QTL / GWAS identity + enrichment. # @noRd -.colocSummaryRow <- function(pairRes, q, gInfo, p, p12Info) { - sm <- as.data.frame(pairRes$summary, stringsAsFactors = FALSE) - sm <- .colocRenameNsnps(sm) - sm$study <- q$study - sm$context <- q$context - sm$trait <- q$trait - sm$method <- q$method - sm$gwasStudy <- gInfo$study - sm$gwasContext <- gInfo$context - sm$gwasTrait <- gInfo$trait - sm$gwasMethod <- gInfo$method - # idx1 / idx2 index the LBF rows handed to coloc.bf_bf, which is exactly - # what retainedMass runs parallel to -- so the mass reported here is the - # mass of the two effects this row actually scores, not a per-entry - # average. - sm$qtlRetainedMass <- .colocPickAt( - q$retainedMass, - sm[["idx1"]], - nrow(sm) - ) - sm$gwasRetainedMass <- .colocPickAt( - gInfo$retainedMass, - sm[["idx2"]], - nrow(sm) - ) - # coloc's idx1 / idx2 number the rows of THIS call, so they are not - # comparable across blocks. The fit's own effect indices are, and they are - # what the credible-set and gene views group on. - sm$qtlCs <- .colocPickAt( - q$effect, - sm[["idx1"]], - nrow(sm), - fill = NA_integer_ +.colocSummaryRow <- function( + pairRes, + q, + gInfo, + useEnrichment, + p12Info +) { + sm <- .colocRenameNsnps( + as.data.frame(pairRes$summary, stringsAsFactors = FALSE) ) - sm$gwasCs <- .colocPickAt( - gInfo$effect, - sm[["idx2"]], - nrow(sm), - fill = NA_integer_ + mutate( + sm, + study = q$study, + context = q$context, + trait = q$trait, + method = q$method, + gwasStudy = gInfo$study, + gwasContext = gInfo$context, + gwasTrait = gInfo$trait, + gwasMethod = gInfo$method, + # idx1 / idx2 index the LBF rows handed to coloc.bf_bf, which is + # exactly what retainedMass runs parallel to -- so the mass reported + # here is the mass of the two effects this row actually scores, not a + # per-entry average. + qtlRetainedMass = .colocPickAt( + q$retainedMass, + sm[["idx1"]], + nrow(sm) + ), + gwasRetainedMass = .colocPickAt( + gInfo$retainedMass, + sm[["idx2"]], + nrow(sm) + ), + # coloc's idx1 / idx2 number the rows of THIS call, so they are not + # comparable across blocks. The fit's own effect indices are, and they + # are what the credible-set and gene views group on. + qtlCs = .colocPickAt( + q$effect, + sm[["idx1"]], + nrow(sm), + fill = NA_integer_ + ), + gwasCs = .colocPickAt( + gInfo$effect, + sm[["idx2"]], + nrow(sm), + fill = NA_integer_ + ), + blockId = gInfo$blockId %||% NA_character_, + !!!.colocEnrichmentCols(useEnrichment, p12Info) ) - sm$blockId <- gInfo$blockId %||% NA_character_ - if (p$useEnrichment) { - sm$enrichment <- p12Info$enRow - sm$p12Used <- p12Info$p12Used - } - sm } # Assemble the result table + attach the GWAS fine-mapping when requested. # @noRd -.colocFinalize <- function(results, p) { - out <- .colocAssemble(results, p$useEnrichment, .colocLdSketch(p)) - if (p$returnGwasFineMapping && methods::is(p$gwasInput, "SumStatsBase")) { - attr(out, "gwasFineMapping") <- p$gwasFmr +.colocFinalize <- function( + results, + useEnrichment, + qtlFineMappingResult, + gwasFmr, + gwasInput, + returnGwasFineMapping +) { + out <- .colocAssemble( + results, + useEnrichment, + .colocLdSketch(qtlFineMappingResult, gwasFmr) + ) + .colocAttachGwasFm(out, returnGwasFineMapping, gwasInput, gwasFmr) +} + +# The GWAS fine-mapping the pipeline produced, carried back on the result when +# the caller asked for it and the GWAS side was fine-mapped here. +# @noRd +.colocAttachGwasFm <- function(out, returnGwasFineMapping, gwasInput, gwasFmr) { + if (!returnGwasFineMapping || !methods::is(gwasInput, "SumStatsBase")) { + return(out) } - out + `attr<-`(out, "gwasFineMapping", gwasFmr) } # Row-bind + column-order the per-pair summary rows (empty result when none). @@ -546,7 +683,7 @@ colocPipeline <- function( return(.colocEmptyResult(enriched = useEnrichment, ldSketch = ldSketch)) } rows <- bind_rows(map(map(results, "rows"), .colocStandardiseRow)) - variants <- unlist(map(results, "variants"), recursive = FALSE) + variants <- list_c(map(results, "variants")) ColocResult(.colocOrderColumns(rows, useEnrichment), variants, ldSketch) } @@ -564,11 +701,9 @@ colocPipeline <- function( "gwasMethod", "blockId", "qtlCs", - "gwasCs" + "gwasCs", + if (useEnrichment) c("enrichment", "p12Used") ) - if (useEnrichment) { - idCols <- c(idCols, "enrichment", "p12Used") - } select(out, all_of(idCols), everything()) } @@ -601,8 +736,9 @@ colocPipeline <- function( coverage = 0.5, concentration = 0.5 ) { - fit$V <- NULL # disable V-based filtering inside susie_get_cs - csList <- susie_get_cs(fit, coverage = coverage, dedup = FALSE) + # V zapped to disable V-based filtering inside susie_get_cs + unfiltered <- list_modify(fit, V = zap()) + csList <- susie_get_cs(unfiltered, coverage = coverage, dedup = FALSE) totalVariants <- ncol(fit$alpha) maxSize <- totalVariants * coverage * concentration keep <- map_lgl(csList$cs, .colocCsUnderMax, maxSize = maxSize) @@ -632,25 +768,25 @@ colocPipeline <- function( warn(msg) return(NULL) } - lbfMatrix <- .colocLbfMatrix(fit, label) - if (is.null(lbfMatrix)) { + allRows <- .colocLbfMatrix(fit, label) + if (is.null(allRows)) { return(NULL) } - mass <- .colocEffectRetainedMass(fit, nrow(lbfMatrix)) + allMass <- .colocEffectRetainedMass(fit, nrow(allRows)) keep <- .colocSelectLbfRows( - lbfMatrix, + allRows, fit, filterLbfCs, filterLbfCsSecondary, filterLbfCsConcentration, priorTol ) - lbfMatrix <- lbfMatrix[keep, , drop = FALSE] - mass <- mass[keep] - if (nrow(lbfMatrix) == 0L) { + kept <- allRows[keep, , drop = FALSE] + mass <- allMass[keep] + if (nrow(kept) == 0L) { return(NULL) } - lbfMatrix <- .colocAssignLbfColnames(lbfMatrix, parts) + lbfMatrix <- .colocAssignLbfColnames(kept, parts) if (ncol(lbfMatrix) == 0L) { return(NULL) } @@ -729,13 +865,13 @@ colocPipeline <- function( return(csIdx) } } else if (!is.null(filterLbfCsSecondary)) { - secIdx <- tryCatch( + secIdx <- try_fetch( .colocFilterCsByConcentration( fit, coverage = filterLbfCsSecondary, concentration = filterLbfCsConcentration ), - error = function(e) NULL + error = function(cnd) NULL ) if (!is.null(secIdx) && length(secIdx) > 0L) { return(secIdx) @@ -761,17 +897,25 @@ colocPipeline <- function( as.numeric(mass) } +# The entry's variant ids, when the matrix does not already name its columns. +# @noRd +.colocLbfNamesFrom <- function(lbfMatrix, parts) { + if (!is.null(colnames(lbfMatrix)) && !any(is.na(colnames(lbfMatrix)))) { + return(lbfMatrix) + } + vids <- .fmrPartsVariantIds(parts) + if (length(vids) != ncol(lbfMatrix)) { + return(lbfMatrix) + } + `colnames<-`(lbfMatrix, vids) +} + # Assign variant-id column names (fit-provided, else the row's rendered # variant ids) and drop columns with an NA id. # @noRd .colocAssignLbfColnames <- function(lbfMatrix, parts) { - if (is.null(colnames(lbfMatrix)) || any(is.na(colnames(lbfMatrix)))) { - vids <- .fmrPartsVariantIds(parts) - if (length(vids) == ncol(lbfMatrix)) { - colnames(lbfMatrix) <- vids - } - } - lbfMatrix[, !is.na(colnames(lbfMatrix)), drop = FALSE] + named <- .colocLbfNamesFrom(lbfMatrix, parts) + named[, !is.na(colnames(named)), drop = FALSE] } # The second side's LBF matrices, one record per row of the collection, each @@ -877,10 +1021,8 @@ colocPipeline <- function( # 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 + qSub <- `colnames<-`(qtlLbf[, m$idxA, drop = FALSE], sharedIds) + gSub <- `colnames<-`(gwasLbf[, m$idxB, drop = FALSE], sharedIds) list(qtl = qSub, gwas = gSub) } @@ -912,11 +1054,11 @@ colocPipeline <- function( qtlRetainedMass = numeric(0), gwasRetainedMass = numeric(0) ) - if (enriched) { - base$enrichment <- numeric(0) - base$p12Used <- numeric(0) - } - ColocResult(base, list(), ldSketch = ldSketch) + ColocResult( + mutate(base, !!!.colocEnrichmentCols(enriched, NULL)), + list(), + ldSketch = ldSketch + ) } # Look up this pair's enrichment factor in the user-supplied enrichment table. @@ -972,19 +1114,25 @@ colocPipeline <- function( # shape. # @noRd .colocStandardiseRow <- function(sm) { - for (col in c( - "idx1", - "idx2", - "nSnps", - "PP.H0.abf", - "PP.H1.abf", - "PP.H2.abf", - "PP.H3.abf", - "PP.H4.abf" - )) { - if (!is_in(col, colnames(sm))) sm[[col]] <- NA - } - sm + missing <- setdiff( + c( + "idx1", + "idx2", + "nSnps", + "PP.H0.abf", + "PP.H1.abf", + "PP.H2.abf", + "PP.H3.abf", + "PP.H4.abf" + ), + colnames(sm) + ) + mutate(sm, !!!set_names(map(missing, .colocMissingColumn), missing)) +} + +# @noRd +.colocMissingColumn <- function(col) { + NA } # coloc.bf_bf names the aligned-variant count `nsnps`; this package publishes @@ -1007,9 +1155,7 @@ colocPipeline <- function( } idx <- as.integer(idx) ok <- !is.na(idx) & idx >= 1L & idx <= length(values) - out <- rep(fill, length(idx)) - out[ok] <- values[idx[ok]] - out + replace(rep(fill, length(idx)), ok, values[idx[ok]]) } # ---- map/apply helpers (lambda-free callbacks) --------------------------- @@ -1020,8 +1166,32 @@ colocPipeline <- function( # Score the first side's LBF against one second-side record -> a summary row # (or NULL). # @noRd -.colocScorePairAt <- function(gInfo, qLbfInfo, p, q) { - .colocScorePair(qLbfInfo$lbf, gInfo, q, p) +.colocScorePairAt <- function( + gInfo, + qLbfInfo, + q, + useEnrichment, + enrichment, + p12, + p12Max, + p1, + p2, + alleleFlip, + colocArgs +) { + .colocScorePair( + qLbfInfo$lbf, + gInfo, + q, + useEnrichment = useEnrichment, + enrichment = enrichment, + p12 = p12, + p12Max = p12Max, + p1 = p1, + p2 = p2, + alleleFlip = alleleFlip, + colocArgs = colocArgs + ) } # TRUE when a credible set has fewer than `maxSize` variants. diff --git a/R/colocboostPipeline.R b/R/colocboostPipeline.R index af01227f..e1d4a356 100644 --- a/R/colocboostPipeline.R +++ b/R/colocboostPipeline.R @@ -120,9 +120,10 @@ #' 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}). +#' @param colocboostArgs Optional named list of additional arguments +#' forwarded to \code{\link[colocboost]{colocboost}} (e.g., \code{M}, +#' \code{L}, \code{output_level}). +#' @param ... Required by the generic; the methods take no further arguments. #' @return A \code{\linkS4class{ColocBoostResult}}: one element per #' confidence set (CoS) across every analysis that ran, holding that set's #' member variants with their \code{vcp}. The \code{analysis} column marks @@ -162,18 +163,18 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # ============================================================================= # Run colocboost() with tryCatch + timing. +#' @importFrom rlang try_fetch .cbRun <- function(label, args) { if (!requireNamespace("colocboost", quietly = TRUE)) { abort("The colocboost package is required for colocboostPipeline().") } t1 <- Sys.time() args <- compact(args) - res <- tryCatch( + res <- try_fetch( exec(colocboost::colocboost, !!!args), - error = function(e) { - eMsg <- conditionMessage(e) - msg <- glue("{label} failed: {eMsg}") - inform(msg) + error = function(cnd) { + msg <- glue("{label} failed") + inform(msg, parent = cnd) NULL } ) @@ -318,9 +319,11 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { YperCtx <- set_names(map(built, "Y"), map_chr(built, "ctx")) dedup <- .cbDedupX(XperCtx) split <- .cbSplitY(YperCtx, dedup$xMatch) - outcomeInfo <- split$outcomeInfo - outcomeInfo$study <- getStudy(qd) - outcomeInfo$dataForm <- "individual" + outcomeInfo <- mutate( + split$outcomeInfo, + study = getStudy(qd), + dataForm = "individual" + ) list( X = dedup$uniqueX, Y = split$YSplit, @@ -356,11 +359,11 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # NULL when the context should be skipped. # @noRd .cbBuildContextXY <- function(ctx, p) { - Y <- .cbResidualizedY(p$qd, ctx, p$traitId, p$region) - if (is.null(Y) || ncol(Y) == 0L) { + rawY <- .cbResidualizedY(p$qd, ctx, p$traitId, p$region) + if (is.null(rawY) || ncol(rawY) == 0L) { return(NULL) } - X <- .cbResidualizedX( + rawX <- .cbResidualizedX( p$qd, ctx, p$traitId, @@ -368,16 +371,16 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { p$cisWindow, p$samples ) - if (is.null(X) || ncol(X) == 0L) { + if (is.null(rawX) || ncol(rawX) == 0L) { return(NULL) } # 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. - colnames(X) <- normalizeVariantId(colnames(X)) - common <- intersect(rownames(X), rownames(Y)) + # 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. + named <- `colnames<-`(rawX, normalizeVariantId(colnames(rawX))) + common <- intersect(rownames(named), rownames(rawY)) if (length(common) == 0L) { msg <- glue( "colocboostPipeline: skipping context '{ctx}' ", @@ -386,9 +389,13 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { inform(msg) return(NULL) } - X <- X[common, , drop = FALSE] - Y <- Y[common, , drop = FALSE] - Y <- .cbApplyScreen(X, Y, ctx, p$pipCutoffToSkip) + X <- named[common, , drop = FALSE] + Y <- .cbApplyScreen( + X, + rawY[common, , drop = FALSE], + ctx, + p$pipCutoffToSkip + ) if (is.null(Y)) { return(NULL) } @@ -398,20 +405,19 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Residualized phenotypes for one context (message + NULL on failure). # @noRd .cbResidualizedY <- function(qd, ctx, traitId, region) { - tryCatch( + try_fetch( getResidualizedPhenotypes( qd, contexts = ctx, traitId = traitId, region = region ), - error = function(e) { - eMsg <- conditionMessage(e) + error = function(cnd) { msg <- glue( "colocboostPipeline: skipping context '{ctx}' ", - "(residualized phenotypes unavailable: {eMsg})." + "(residualized phenotypes unavailable)." ) - inform(msg) + inform(msg, parent = cnd) NULL } ) @@ -420,7 +426,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Residualized genotypes for one context (message + NULL on failure). # @noRd .cbResidualizedX <- function(qd, ctx, traitId, region, cisWindow, samples) { - tryCatch( + try_fetch( getResidualizedGenotypes( qd, contexts = ctx, @@ -429,13 +435,12 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { cisWindow = cisWindow, samples = samples ), - error = function(e) { - eMsg <- conditionMessage(e) + error = function(cnd) { msg <- glue( "colocboostPipeline: skipping context '{ctx}' ", - "(residualized genotypes unavailable: {eMsg})." + "(residualized genotypes unavailable)." ) - inform(msg) + inform(msg, parent = cnd) NULL } ) @@ -461,26 +466,27 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { Y } +# The index of the first element of `xs` identical to `xs[[i]]`. +# @noRd +.cbFirstIdentical <- function(i, xs) { + which(map_lgl(xs, identical, xs[[i]]))[[1L]] +} + # Deduplicate X matrices identical across contexts so dict_YX can fan out to a # smaller X set. Returns list(uniqueX, xMatch) where xMatch[i] is the uniqueX -# index for the i-th context. (Sequential back-reference dedup -- kept as a -# loop.) +# index for the i-th context. +# +# Each context resolves to the first context it matches, so nothing has to be +# carried between iterations: the ones that resolve to themselves are the +# unique set, and every context's slot is its representative's position in it. # @noRd .cbDedupX <- function(XperCtx) { - uniqueX <- list() - xMatch <- integer(length(XperCtx)) - for (i in seq_along(XperCtx)) { - matched <- names(uniqueX)[ - map_lgl(uniqueX, identical, XperCtx[[i]]) - ] - if (length(matched) > 0L) { - xMatch[[i]] <- match(matched[[1L]], names(uniqueX)) - } else { - uniqueX[[names(XperCtx)[i]]] <- XperCtx[[i]] - xMatch[[i]] <- length(uniqueX) - } - } - list(uniqueX = uniqueX, xMatch = xMatch) + firstIdx <- map_int(seq_along(XperCtx), .cbFirstIdentical, xs = XperCtx) + keepIdx <- which(firstIdx == seq_along(XperCtx)) + list( + uniqueX = XperCtx[keepIdx], + xMatch = match(firstIdx, keepIdx) + ) } # Split each context's Y into single-trait columns (context-qualifying duplicate @@ -488,59 +494,97 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # list(YSplit, dict). (Sequential make.unique naming -- kept as a loop.) # @noRd .cbSplitY <- function(YperCtx, xMatch) { - allTraitNames <- unlist(map(YperCtx, colnames), use.names = FALSE) + allTraitNames <- unname(list_c(map(YperCtx, colnames))) dupTraits <- unique(allTraitNames[ duplicated(allTraitNames) | duplicated(allTraitNames, fromLast = TRUE) ]) - YSplit <- list() - dict <- matrix(integer(0), ncol = 2L) + # Every (context, column) pair, flattened once so the rest is positional. + pairs <- .cbConcat(map( + seq_along(YperCtx), + .cbYPairsForContext, + YperCtx = YperCtx, + xMatch = xMatch + )) # The outcome NAME is a display label: context-qualified only when a trait - # is ambiguous, then made unique. That makes it lossy -- a bare name could - # be a trait seen in one context or a trait literally called that -- so the - # (context, trait) it was minted from is recorded alongside it here, the - # only point where both are still in hand. - info <- list() - for (i in seq_along(YperCtx)) { - Y <- YperCtx[[i]] - ctx <- names(YperCtx)[i] - for (j in seq_len(ncol(Y))) { - tname <- .cbTraitName( - colnames(Y)[j], - ctx, - dupTraits, - names(YSplit) - ) - YSplit[[tname]] <- Y[, j, drop = FALSE] - dict <- rbind(dict, c(length(YSplit), xMatch[[i]])) - info[[length(info) + 1L]] <- tibble( - name = tname, - context = ctx, - trait = as.character(colnames(Y)[j] %||% NA_character_) - ) - } + # is ambiguous, then made unique. Making it unique depends on the names + # already minted, so this one step is a fold -- the only sequential part. + outcomeNames <- reduce( + pairs, + .cbAccumOutcomeName, + dupTraits = dupTraits, + .init = character(0) + ) + # The name is lossy -- a bare name could be a trait seen in one context or + # a trait literally called that -- so the (context, trait) it was minted + # from is recorded alongside it, the only point where both are in hand. + list( + YSplit = set_names(map(pairs, "col"), outcomeNames), + dict = cbind(Y = seq_along(pairs), X = map_int(pairs, "xIdx")), + outcomeInfo = bind_rows(map2(outcomeNames, pairs, .cbOutcomeInfoRow)) + ) +} + +# Concatenate a list of lists into one, empty-safe. +# @noRd +.cbConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) } - colnames(dict) <- c("Y", "X") + list_c(pieces) +} + +# One (context, column) pair: the column itself plus what it was minted from. +# @noRd +.cbYPair <- function(j, Y, ctx, xIdx) { list( - YSplit = YSplit, - dict = dict, - outcomeInfo = bind_rows(info) + col = Y[, j, drop = FALSE], + ctx = ctx, + raw = colnames(Y)[j], + trait = as.character(colnames(Y)[j] %||% NA_character_), + xIdx = xIdx ) } +# @noRd +.cbYPairsForContext <- function(i, YperCtx, xMatch) { + Y <- YperCtx[[i]] + map( + seq_len(ncol(Y)), + .cbYPair, + Y = Y, + ctx = names(YperCtx)[i], + xIdx = xMatch[[i]] + ) +} + +# @noRd +.cbAccumOutcomeName <- function(existing, pair, dupTraits) { + c(existing, .cbTraitName(pair$raw, pair$ctx, dupTraits, existing)) +} + +# @noRd +.cbOutcomeInfoRow <- function(name, pair) { + tibble(name = name, context = pair$ctx, trait = pair$trait) +} + # Resolve a unique outcome name for a single trait column: default unnamed # columns, context-qualify duplicates, and make.unique against existing names. # @noRd .cbTraitName <- function(tname, ctx, dupTraits, existing) { - if (is.null(tname) || is.na(tname) || tname == "") { - tname <- str_c("outcome", length(existing) + 1L) + named <- if (is.null(tname) || is.na(tname) || tname == "") { + str_c("outcome", length(existing) + 1L) + } else { + tname } - if (is_in(tname, dupTraits)) { - tname <- str_c(ctx, "_", tname) + qualified <- if (is_in(named, dupTraits)) { + str_c(ctx, "_", named) + } else { + named } - if (is_in(tname, existing)) { - tname <- make.unique(c(existing, tname))[length(existing) + 1L] + if (!is_in(qualified, existing)) { + return(qualified) } - tname + make.unique(c(existing, qualified))[length(existing) + 1L] } # Build a single (sumstat data.frame, LD correlation matrix) pair from a @@ -557,7 +601,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { if (is.null(df) || nrow(df) == 0L) { return(NULL) } - df$variant_id <- .cbSumstatVariantIds(df) + df <- mutate(df, variant_id = .cbSumstatVariantIds(df)) # 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. @@ -588,10 +632,13 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { return(NULL) } keptIds <- attr(R, "keptVariantIds") - attr(R, "keptVariantIds") <- NULL - df <- filter(df, is_in(variantIds, keptIds)) - ss <- .cbSumstatFrame(df, keptIds, nCase, nControl, varY) - list(sumstat = ss, LD = R, variantIds = keptIds) + kept <- filter(df, is_in(variantIds, keptIds)) + ss <- .cbSumstatFrame(kept, keptIds, nCase, nControl, varY) + list( + sumstat = ss, + LD = `attr<-`(R, "keptVariantIds", NULL), + variantIds = keptIds + ) } # The colocboost sumstat frame for one entry, over the variants the LD panel @@ -605,10 +652,12 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { variant = keptIds, stringsAsFactors = FALSE ) - if (!is.null(varY) && !is.na(varY)) { - ss$var_y <- varY - } - ss + mutate( + ss, + !!!compact(list( + var_y = if (!is.null(varY) && !is.na(varY)) varY + )) + ) } # Resolve a sumstat entry's variant ids, falling back to the canonical @@ -654,43 +703,70 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { return(list()) } ldSketch <- getLdSketch(ss) - keepRow <- rep(TRUE, nrow(ss)) - if (!is.null(contexts) && length(contexts) > 0L) { - keepRow <- keepRow & is_in(as.character(ss$context), contexts) + byContext <- if (!is.null(contexts) && length(contexts) > 0L) { + is_in(as.character(ss$context), contexts) + } else { + rep(TRUE, nrow(ss)) } - if (!is.null(traitId) && length(traitId) > 0L) { - keepRow <- keepRow & is_in(as.character(ss$trait), traitId) + byTrait <- if (!is.null(traitId) && length(traitId) > 0L) { + is_in(as.character(ss$trait), traitId) + } else { + TRUE } + keepRow <- byContext & byTrait if (!any(keepRow)) { return(list()) } rows <- which(keepRow) - bundle <- list() - for (i in rows) { - st <- as.character(ss$study)[[i]] - ctx <- as.character(ss$context)[[i]] - tr <- as.character(ss$trait)[[i]] - label <- str_c(st, ctx, tr, sep = ":") - pair <- .cbSumstatPair( - df = getSumStatsDf( - ss, - study = st, - context = ctx, - trait = tr, - require = "Z" - ), + compact(set_names( + map( + rows, + .cbQtlEntryPair, + ss = ss, ldSketch = ldSketch, - varY = if (is_in("varY", .tupleColumnNames(ss))) { - ss$varY[[i]] - } else { - NA_real_ - }, cutoffs = cutoffs - ) - if (!is.null(pair)) bundle[[label]] <- pair + ), + map_chr(rows, .cbQtlEntryLabel, ss = ss) + )) +} + +# @noRd +.cbQtlEntryLabel <- function(i, ss) { + str_c( + as.character(ss$study)[[i]], + as.character(ss$context)[[i]], + as.character(ss$trait)[[i]], + sep = ":" + ) +} + +# One QTL entry's (sumstat, LD) pair, or NULL when it has no panel overlap. +# @noRd +.cbQtlEntryPair <- function(i, ss, ldSketch, cutoffs) { + .cbSumstatPair( + df = getSumStatsDf( + ss, + study = as.character(ss$study)[[i]], + context = as.character(ss$context)[[i]], + trait = as.character(ss$trait)[[i]], + require = "Z" + ), + ldSketch = ldSketch, + varY = .cbTupleValue(ss, "varY", i), + cutoffs = cutoffs + ) +} + +# A tuple column's value for row `i`, or NA when the collection lacks it. +# `[[` on one of these collections extracts an ELEMENT, not a column, so this +# goes through mcols() the way the `$` method does. +# @noRd +.cbTupleValue <- function(collection, column, i) { + if (!is_in(column, .tupleColumnNames(collection))) { + return(NA_real_) } - bundle + S4Vectors::mcols(collection, use.names = FALSE)[[column]][[i]] } # Same as .cbQtlSumStatsBundle for a GwasSumStats collection, keyed by @@ -700,32 +776,33 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { return(list()) } ldSketch <- getLdSketch(gws) - bundle <- list() - for (i in seq_len(nrow(gws))) { - st <- as.character(gws$study)[[i]] - pair <- .cbSumstatPair( - df = getSumStatsDf(gws, study = st, require = "Z"), + compact(set_names( + map( + seq_len(nrow(gws)), + .cbGwasEntryPair, + gws = gws, ldSketch = ldSketch, - varY = if (is_in("varY", .tupleColumnNames(gws))) { - gws$varY[[i]] - } else { - NA_real_ - }, - nCase = if (is_in("nCase", .tupleColumnNames(gws))) { - gws$nCase[[i]] - } else { - NA_real_ - }, - nControl = if (is_in("nControl", .tupleColumnNames(gws))) { - gws$nControl[[i]] - } else { - NA_real_ - }, cutoffs = cutoffs - ) - if (!is.null(pair)) bundle[[st]] <- pair - } - bundle + ), + as.character(gws$study) + )) +} + +# One GWAS entry's (sumstat, LD) pair, or NULL when it has no panel overlap. +# @noRd +.cbGwasEntryPair <- function(i, gws, ldSketch, cutoffs) { + .cbSumstatPair( + df = getSumStatsDf( + gws, + study = as.character(gws$study)[[i]], + require = "Z" + ), + ldSketch = ldSketch, + varY = .cbTupleValue(gws, "varY", i), + nCase = .cbTupleValue(gws, "nCase", i), + nControl = .cbTupleValue(gws, "nControl", i), + cutoffs = cutoffs + ) } # Check two LD sketches for the reference-panel compatibility contract. Thin @@ -753,24 +830,20 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { dict_sumstatLD = matrix(integer(0), ncol = 2L) )) } - ldUnique <- list() - ldMatch <- integer(length(bundles)) - for (i in seq_along(bundles)) { - ld <- bundles[[i]]$LD - matched <- which(map_lgl(ldUnique, identical, ld)) - if (length(matched) > 0L) { - ldMatch[[i]] <- matched[[1L]] - } else { - ldUnique[[length(ldUnique) + 1L]] <- ld - ldMatch[[i]] <- length(ldUnique) - } - } - names(ldUnique) <- str_c("LD", seq_along(ldUnique)) - sumstat <- map(bundles, "sumstat") - names(sumstat) <- names(bundles) - dict <- cbind(seq_along(bundles), ldMatch) - colnames(dict) <- c("sumstat", "LD") - list(sumstat = sumstat, LD = ldUnique, dict_sumstatLD = dict) + # Same shape as .cbDedupX: every bundle resolves to the first bundle + # carrying an identical LD matrix, so the unique set and the back-mapping + # both fall out without carrying state. + lds <- map(bundles, "LD") + firstIdx <- map_int(seq_along(lds), .cbFirstIdentical, xs = lds) + keepIdx <- which(firstIdx == seq_along(lds)) + list( + sumstat = map(bundles, "sumstat"), + LD = set_names(lds[keepIdx], str_c("LD", seq_along(keepIdx))), + dict_sumstatLD = cbind( + sumstat = seq_along(bundles), + LD = match(firstIdx, keepIdx) + ) + ) } # Build an empty result skeleton consistent with what the per-method @@ -794,6 +867,21 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # no-op: the caller gets an empty ColocBoostResult whose getComputingTime() # entries are all NULL, with no indication of why. Say so. # @noRd +# TRUE when an analysis was requested and has the data to run. When it was +# requested but cannot run, warn and answer FALSE, so the caller's compact() +# drops it instead of skipping it silently. +# @noRd +.cbCanRun <- function(requested, hasData, flag, needed) { + if (!isTRUE(requested)) { + return(FALSE) + } + if (isTRUE(hasData)) { + return(TRUE) + } + .cbWarnNoData(flag, needed) + FALSE +} + .cbWarnNoData <- function(flag, needed) { msg <- glue( "colocboostPipeline: {flag} = TRUE was requested, but there is no ", @@ -816,11 +904,11 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { jointGwas, separateGwas, focalTrait, - dotArgs, + colocboostArgs, qtlLdSketch = NULL, qtlSumstatBundle = NULL ) { - results <- .cbEmptyResult() + empty <- .cbEmptyResult() hasInd <- !is.null(individualBundle) hasSs <- length(sumstatBundle$sumstat) > 0L qtlSumstatBundle <- qtlSumstatBundle %||% .cbMergeSumstatBundles(list()) @@ -833,49 +921,57 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { inform(msg) return(.cbEmptyResultObject()) } - if (isTRUE(xqtlColoc)) { - if (hasInd || hasQtlSs) { - run <- .cbRunXqtlOnly( + # Each analysis contributes an entry only when it was requested AND has + # the data; .cbCanRun warns in the "requested but cannot" case so the skip + # is never silent, and compact() drops what did not run. + runs <- compact(list( + xqtl_coloc = if ( + .cbCanRun(xqtlColoc, hasInd || hasQtlSs, "xqtlColoc", "QTL data") + ) { + .cbRunXqtlOnly( individualBundle, qtlSumstatBundle, hasInd, focalTrait, - dotArgs + colocboostArgs ) - results$xqtl_coloc <- run$result - results$computing_time$Analysis$xqtl_coloc <- run$time - } else { - .cbWarnNoData("xqtlColoc", "QTL data") - } - } - if (isTRUE(jointGwas)) { - if (hasSs) { - run <- .cbRunJointGwas( + }, + joint_gwas = if ( + .cbCanRun(jointGwas, hasSs, "jointGwas", "summary-statistic data") + ) { + .cbRunJointGwas( individualBundle, sumstatBundle, hasInd, - dotArgs + colocboostArgs ) - results$joint_gwas <- run$result - results$computing_time$Analysis$joint_gwas <- run$time - } else { - .cbWarnNoData("jointGwas", "summary-statistic data") - } - } - if (isTRUE(separateGwas)) { - if (hasSs) { - run <- .cbRunSeparateGwas( + }, + separate_gwas = if ( + .cbCanRun( + separateGwas, + hasSs, + "separateGwas", + "summary-statistic data" + ) + ) { + .cbRunSeparateGwas( individualBundle, sumstatBundle, hasInd, - dotArgs + colocboostArgs ) - results$separate_gwas <- run$result - results$computing_time$Analysis$separate_gwas <- run$time - } else { - .cbWarnNoData("separateGwas", "summary-statistic data") } - } + )) + results <- list_assign( + list_assign(empty, !!!map(runs, "result")), + computing_time = list_assign( + empty$computing_time, + Analysis = list_assign( + empty$computing_time$Analysis, + !!!map(runs, "time") + ) + ) + ) .cbToResultObject( results, .cbOutcomeInfo(individualBundle, sumstatBundle, hasInd), @@ -904,33 +1000,57 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # key: without it the separate-GWAS sets would be indistinguishable from each # other once flattened. # @noRd -.cbToResultObject <- function(results, outcomeInfo, ldSketch = NULL) { - runs <- list() - analysis <- character(0) - gwasStudy <- character(0) - for (nm in c("xqtl_coloc", "joint_gwas")) { - if (!is.null(results[[nm]])) { - runs[[length(runs) + 1L]] <- results[[nm]] - analysis <- c(analysis, nm) - gwasStudy <- c(gwasStudy, NA_character_) - } +# @noRd +.cbJointRun <- function(nm, results) { + if (is.null(results[[nm]])) { + return(NULL) } + list(run = results[[nm]], analysis = nm, gwasStudy = NA_character_) +} + +# @noRd +.cbSeparateRun <- function(i, sep, keys) { + if (is.null(sep[[i]])) { + return(NULL) + } + list(run = sep[[i]], analysis = "separate_gwas", gwasStudy = keys[[i]]) +} + +# One character field across run records, empty-safe. +# @noRd +.cbEntryField <- function(entries, field) { + if (length(entries) == 0L) { + return(character(0)) + } + map_chr(entries, field) +} + +.cbToResultObject <- function(results, outcomeInfo, ldSketch = NULL) { sep <- results$separate_gwas - if (!is.null(sep) && length(sep) > 0L) { - keys <- names(sep) %||% as.character(seq_along(sep)) - for (i in seq_along(sep)) { - if (is.null(sep[[i]])) { - next - } - runs[[length(runs) + 1L]] <- sep[[i]] - analysis <- c(analysis, "separate_gwas") - gwasStudy <- c(gwasStudy, keys[[i]]) - } + sepRuns <- if (is.null(sep) || length(sep) == 0L) { + list() + } else { + compact(map( + seq_along(sep), + .cbSeparateRun, + sep = sep, + keys = names(sep) %||% as.character(seq_along(sep)) + )) } + # One record per run, so the three parallel vectors are read off a single + # list instead of being grown in step with each other. + entries <- c( + compact(map( + c("xqtl_coloc", "joint_gwas"), + .cbJointRun, + results = results + )), + sepRuns + ) ColocBoostResult( - results = runs, - analysis = analysis, - gwasStudy = gwasStudy, + results = map(entries, "run"), + analysis = .cbEntryField(entries, "analysis"), + gwasStudy = .cbEntryField(entries, "gwasStudy"), outcomeInfo = outcomeInfo, ldSketch = ldSketch, computingTime = results$computing_time %||% list() @@ -950,7 +1070,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { sumstatBundle, hasInd, focalTrait, - dotArgs + colocboostArgs ) { traits <- c( if (hasInd) individualBundle$outcomeNames else character(), @@ -991,7 +1111,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { output_level = 2 ), ldArgs, - dotArgs + colocboostArgs ) run <- .cbRun("xQTL-only ColocBoost", args) list(result = run$result, time = run$time) @@ -1006,20 +1126,19 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # invented. # @noRd .cbOutcomeInfo <- function(individualBundle, sumstatBundle, hasInd) { - parts <- list() - if (isTRUE(hasInd) && !is.null(individualBundle$outcomeInfo)) { - parts[[length(parts) + 1L]] <- individualBundle$outcomeInfo - } ssNames <- names(sumstatBundle$sumstat) - if (length(ssNames) > 0L) { - parts[[length(parts) + 1L]] <- tibble( - name = ssNames, - context = NA_character_, - trait = NA_character_, - study = ssNames, - dataForm = "sumstats" - ) - } + parts <- compact(list( + if (isTRUE(hasInd)) individualBundle$outcomeInfo, + if (length(ssNames) > 0L) { + tibble( + name = ssNames, + context = NA_character_, + trait = NA_character_, + study = ssNames, + dataForm = "sumstats" + ) + } + )) if (length(parts) == 0L) { return(.cbEmptyOutcomeInfo()) } @@ -1039,7 +1158,12 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Joint (non-focal) QTL + GWAS run -> list(result, time). # @noRd -.cbRunJointGwas <- function(individualBundle, sumstatBundle, hasInd, dotArgs) { +.cbRunJointGwas <- function( + individualBundle, + sumstatBundle, + hasInd, + colocboostArgs +) { traits <- c( if (hasInd) individualBundle$outcomeNames else character(), names(sumstatBundle$sumstat) @@ -1064,7 +1188,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { output_level = 2 ), ldArgs, - dotArgs + colocboostArgs ) run <- .cbRun("Joint GWAS ColocBoost", args) list(result = run$result, time = run$time) @@ -1076,7 +1200,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { individualBundle, sumstatBundle, hasInd, - dotArgs + colocboostArgs ) { ssNames <- names(sumstatBundle$sumstat) t1 <- Sys.time() @@ -1088,7 +1212,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { individualBundle = individualBundle, sumstatBundle = sumstatBundle, hasInd = hasInd, - dotArgs = dotArgs + colocboostArgs = colocboostArgs ), ssNames ) @@ -1115,7 +1239,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { individualBundle, sumstatBundle, hasInd, - dotArgs + colocboostArgs ) { ldIdx <- sumstatBundle$dict_sumstatLD[i, 2L] ldArgs <- .cbBuildLdArgs(sumstatBundle$LD[ldIdx]) @@ -1140,7 +1264,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { output_level = 2 ), ldArgs, - dotArgs + colocboostArgs ) .cbRun(str_c("Separate GWAS ColocBoost for ", study), args)$result } @@ -1164,13 +1288,9 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { 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 + # sgn is +1 / -1 per matched column, so one sweep applies every flip. + out <- sweep(m[, ia, drop = FALSE], 2L, sgn, FUN = "*") + `colnames<-`(out, canonical[ib]) } # Relabel a (sumstat, LD) pair to the canonical coding: flip the z-score and the @@ -1188,11 +1308,15 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { 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]) + ss <- mutate( + p$sumstat[ia, , drop = FALSE], + z = .data$z * sgn, + variant = canonical[ib] + ) + ld <- `dimnames<-`( + p$LD[ia, ia, drop = FALSE] * outer(sgn, sgn), + list(canonical[ib], canonical[ib]) + ) list(sumstat = ss, LD = ld, variantIds = canonical[ib]) } @@ -1205,18 +1329,13 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # locus. Only invoked when alleleFlip = TRUE. # @noRd .cbHarmonizeAlleles <- function(individualBundle, pairs) { - ids <- character(0) - if (!is.null(individualBundle)) { - ids <- c( - ids, - unlist(map(individualBundle$X, colnames), use.names = FALSE) - ) - } - ids <- c( - ids, - unlist(map(pairs, list("sumstat", "variant")), use.names = FALSE) + allIds <- c( + if (!is.null(individualBundle)) { + unname(list_c(map(individualBundle$X, colnames))) + }, + unname(list_c(map(pairs, list("sumstat", "variant")))) ) - ids <- unique(ids[!is.na(ids)]) + ids <- unique(allIds[!is.na(allIds)]) if (length(ids) == 0L) { return(list(individualBundle = individualBundle, pairs = pairs)) } @@ -1224,16 +1343,24 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ok <- !is.na(parsed$chrom) & !is.na(parsed$pos) locus <- if_else(ok, str_c(parsed$chrom, parsed$pos, sep = ":"), ids) canonical <- ids[!duplicated(locus)] - if (!is.null(individualBundle)) { - individualBundle$X <- map( - individualBundle$X, - .cbFlipMatrixToCanonical, - canonical = canonical + flipped <- if (is.null(individualBundle)) { + NULL + } else { + list_assign( + individualBundle, + X = map( + individualBundle$X, + .cbFlipMatrixToCanonical, + canonical = canonical + ) ) } - pairs <- map(pairs, .cbFlipPairToCanonical, canonical = canonical) - pairs <- pairs[!map_lgl(pairs, is.null)] - list(individualBundle = individualBundle, pairs = pairs) + list( + individualBundle = flipped, + pairs = compact( + map(pairs, .cbFlipPairToCanonical, canonical = canonical) + ) + ) } # Top-level driver shared by all input methods. qtlPairs and gwasPairs @@ -1248,7 +1375,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { jointGwas, separateGwas, focalTrait, - dotArgs, + colocboostArgs, qtlLdSketch = NULL, alleleFlip = TRUE, cutoffs = NULL @@ -1267,26 +1394,26 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # 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 + harmonized <- if (isTRUE(alleleFlip)) { + .cbHarmonizeAlleles(individualBundle, combinedPairs) + } else { + list(individualBundle = individualBundle, pairs = combinedPairs) } - sumstatBundle <- .cbMergeSumstatBundles(combinedPairs) + sumstatBundle <- .cbMergeSumstatBundles(harmonized$pairs) # The xQTL-only run gets its own bundle over just the QTL-side pairs, so # a GWAS study is never treated as an xQTL outcome. Rebuilding it through # .cbMergeSumstatBundles (rather than subsetting the merged one) keeps the # deduplicated LD list and dict_sumstatLD consistent for the subset. - qtlKeys <- intersect(names(combinedPairs), names(qtlPairs)) - qtlSumstatBundle <- .cbMergeSumstatBundles(combinedPairs[qtlKeys]) + qtlKeys <- intersect(names(harmonized$pairs), names(qtlPairs)) + qtlSumstatBundle <- .cbMergeSumstatBundles(harmonized$pairs[qtlKeys]) .cbRunVariants( - individualBundle, + harmonized$individualBundle, sumstatBundle, xqtlColoc, jointGwas, separateGwas, focalTrait, - dotArgs, + colocboostArgs, qtlLdSketch = qtlLdSketch, qtlSumstatBundle = qtlSumstatBundle ) @@ -1310,17 +1437,17 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { .cbRequireMatchingLdSketches(qtlLdSketch, getLdSketch(gwasSumStats)) } gwasPairs <- .cbGwasSumStatsBundle(gwasSumStats, cutoffs = cutoffs) - combinedPairs <- qtlPairs - for (label in names(gwasPairs)) { - key <- label - if (is_in(key, names(combinedPairs))) { - key <- make.unique( - c(names(combinedPairs), key) - )[length(combinedPairs) + 1L] - } - combinedPairs[[key]] <- gwasPairs[[label]] + if (length(gwasPairs) == 0L) { + return(qtlPairs) } - combinedPairs + # Disambiguating one label at a time against the names so far gives the + # same answer as one make.unique() over the whole sequence, since it too + # renames left to right and leaves the first occurrence alone. + keys <- make.unique(c(names(qtlPairs), names(gwasPairs))) + c( + qtlPairs, + set_names(gwasPairs, keys[length(qtlPairs) + seq_along(gwasPairs)]) + ) } # ============================================================================= @@ -1328,45 +1455,64 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # ============================================================================= # The QtlDataset colocboost run: screen spec, individual-level bundle, shared -# driver. Split out so the method is only its signature -- twenty formals plus -# a body is past the length a reviewer (or BiocCheck) will accept, and the -# signature is the part that cannot be shortened. -# `p` is the method's named arguments; `dots` is its `...`, which -# as.list(environment()) does not capture. +# driver. Split out so the method body stays short; the arguments are passed +# explicitly rather than bundled, so a rename is a compile-time error and the +# dependency of each helper is visible. # @noRd -.cbQtlDatasetDrive <- function(p, dots) { +.cbQtlDatasetDrive <- function( + qtlData, + gwasSumStats, + contexts, + traitId, + region, + cisWindow, + focalTrait, + xqtlColoc, + jointGwas, + separateGwas, + samples, + mafCutoff, + macCutoff, + imissCutoff, + pipCutoffToSkip, + absZCutoffToSkip, + bfCutoffToSkip, + logBfCutoffToSkip, + alleleFlip, + colocboostArgs +) { screenSpec <- .cbScreenSpec( - p$pipCutoffToSkip, - p$absZCutoffToSkip, - p$bfCutoffToSkip, - p$logBfCutoffToSkip + pipCutoffToSkip, + absZCutoffToSkip, + bfCutoffToSkip, + logBfCutoffToSkip ) indBundle <- .cbIndividualBundle( - p$qtlData, - contexts = p$contexts, - traitId = p$traitId, - region = p$region, - cisWindow = p$cisWindow, - samples = p$samples, + qtlData, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples, pipCutoffToSkip = screenSpec ) .cbDriver( indBundle, qtlPairs = list(), - p$gwasSumStats, - p$xqtlColoc, - p$jointGwas, - p$separateGwas, - p$focalTrait, - dots, - alleleFlip = p$alleleFlip, + gwasSumStats, + xqtlColoc, + jointGwas, + separateGwas, + focalTrait, + colocboostArgs, + alleleFlip = alleleFlip, # The QTL side is individual-level here, but the GWAS side may still # be sumstats, so the panel cutoffs still apply to it. - cutoffs = .panelCutoffs(list( - mafCutoff = p$mafCutoff, - macCutoff = p$macCutoff, - imissCutoff = p$imissCutoff - )) + cutoffs = .panelCutoffs( + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + ) ) } @@ -1396,9 +1542,30 @@ setMethod( bfCutoffToSkip = 0, logBfCutoffToSkip = 0, alleleFlip = TRUE, - ... + colocboostArgs = list() ) { - .cbQtlDatasetDrive(as.list(environment()), list(...)) + .cbQtlDatasetDrive( + qtlData = qtlData, + gwasSumStats = gwasSumStats, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + focalTrait = focalTrait, + xqtlColoc = xqtlColoc, + jointGwas = jointGwas, + separateGwas = separateGwas, + samples = samples, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff, + pipCutoffToSkip = pipCutoffToSkip, + absZCutoffToSkip = absZCutoffToSkip, + bfCutoffToSkip = bfCutoffToSkip, + logBfCutoffToSkip = logBfCutoffToSkip, + alleleFlip = alleleFlip, + colocboostArgs = colocboostArgs + ) } ) @@ -1422,15 +1589,14 @@ setMethod( mafCutoff = 0, macCutoff = 0, imissCutoff = 1, - ... + colocboostArgs = list() ) { .cbRequireSumStatsQc(qtlData, "qtlData") - dotArgs <- list(...) - cutoffs <- .panelCutoffs(list( + cutoffs <- .panelCutoffs( mafCutoff = mafCutoff, macCutoff = macCutoff, imissCutoff = imissCutoff - )) + ) qtlPairs <- .cbQtlSumStatsBundle( qtlData, contexts = contexts, @@ -1445,7 +1611,7 @@ setMethod( jointGwas = jointGwas, separateGwas = separateGwas, focalTrait = focalTrait, - dotArgs = dotArgs, + colocboostArgs = colocboostArgs, qtlLdSketch = getLdSketch(qtlData), alleleFlip = alleleFlip, cutoffs = cutoffs @@ -1478,43 +1644,95 @@ setMethod( bfCutoffToSkip = 0, logBfCutoffToSkip = 0, alleleFlip = TRUE, - ... + colocboostArgs = list() ) { - p <- as.list(environment()) - p$dotArgs <- list(...) - .cbPipelineMultiStudy(p) + .cbPipelineMultiStudy( + qtlData = qtlData, + gwasSumStats = gwasSumStats, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + focalTrait = focalTrait, + xqtlColoc = xqtlColoc, + jointGwas = jointGwas, + separateGwas = separateGwas, + samples = samples, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff, + pipCutoffToSkip = pipCutoffToSkip, + absZCutoffToSkip = absZCutoffToSkip, + bfCutoffToSkip = bfCutoffToSkip, + logBfCutoffToSkip = logBfCutoffToSkip, + alleleFlip = alleleFlip, + colocboostArgs = colocboostArgs + ) } ) # MultiStudyQtlDataset colocboost worker: aggregate the per-study individual # bundles + embedded sumstats, then dispatch to the shared driver. # @noRd -.cbPipelineMultiStudy <- function(p) { +.cbPipelineMultiStudy <- function( + qtlData, + gwasSumStats, + contexts, + traitId, + region, + cisWindow, + focalTrait, + xqtlColoc, + jointGwas, + separateGwas, + samples, + mafCutoff, + macCutoff, + imissCutoff, + pipCutoffToSkip, + absZCutoffToSkip, + bfCutoffToSkip, + logBfCutoffToSkip, + alleleFlip, + colocboostArgs +) { screenSpec <- .cbScreenSpec( - p$pipCutoffToSkip, - p$absZCutoffToSkip, - p$bfCutoffToSkip, - p$logBfCutoffToSkip + pipCutoffToSkip, + absZCutoffToSkip, + bfCutoffToSkip, + logBfCutoffToSkip + ) + indBundle <- .cbMultiStudyIndBundle( + qtlData = qtlData, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples, + screenSpec = screenSpec + ) + cutoffs <- .panelCutoffs( + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff ) - indBundle <- .cbMultiStudyIndBundle(p, screenSpec) - cutoffs <- .panelCutoffs(p) ss <- .cbMultiStudySumstats( - p$qtlData, - p$contexts, - p$traitId, + qtlData, + contexts, + traitId, cutoffs = cutoffs ) .cbDriver( indBundle, ss$qtlPairs, - p$gwasSumStats, - p$xqtlColoc, - p$jointGwas, - p$separateGwas, - p$focalTrait, - p$dotArgs, + gwasSumStats, + xqtlColoc, + jointGwas, + separateGwas, + focalTrait, + colocboostArgs, qtlLdSketch = ss$qtlLdSketch, - alleleFlip = p$alleleFlip, + alleleFlip = alleleFlip, cutoffs = cutoffs ) } @@ -1524,48 +1742,100 @@ setMethod( # outcomes when two studies share a trait. Returns the combined bundle or NULL. # (Sequential offset-shifted merge -- kept as a loop.) # @noRd -.cbMultiStudyIndBundle <- function(p, screenSpec) { - qtlDatasets <- getQtlDatasets(p$qtlData) - combinedX <- list() - combinedY <- list() - combinedDict <- matrix(integer(0), ncol = 2L) - colnames(combinedDict) <- c("Y", "X") - combinedOutcomes <- character() - combinedInfo <- list() - for (study in names(qtlDatasets)) { - sub <- .cbIndividualBundle( - qtlDatasets[[study]], - contexts = p$contexts, - traitId = p$traitId, - region = p$region, - cisWindow = p$cisWindow, - samples = p$samples, - pipCutoffToSkip = screenSpec - ) - if (is.null(sub)) { - next - } - sub <- .cbPrefixStudyNames(sub, study) - xOffset <- length(combinedX) - yOffset <- length(combinedY) - combinedX <- c(combinedX, sub$X) - combinedY <- c(combinedY, sub$Y) - shifted <- sub$dict_YX - shifted[, "Y"] <- shifted[, "Y"] + yOffset - shifted[, "X"] <- shifted[, "X"] + xOffset - combinedDict <- rbind(combinedDict, shifted) - combinedOutcomes <- c(combinedOutcomes, sub$outcomeNames) - combinedInfo[[length(combinedInfo) + 1L]] <- sub$outcomeInfo +# One study's bundle with its names study-prefixed, or NULL when it has +# nothing to contribute. +# @noRd +.cbStudyBundle <- function( + study, + qtlDatasets, + contexts, + traitId, + region, + cisWindow, + samples, + screenSpec +) { + sub <- .cbIndividualBundle( + qtlDatasets[[study]], + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples, + pipCutoffToSkip = screenSpec + ) + if (is.null(sub)) { + return(NULL) + } + .cbPrefixStudyNames(sub, study) +} + +# @noRd +.cbFieldLength <- function(sub, field) { + length(sub[[field]]) +} + +# How many entries precede each element, given per-element counts. +# @noRd +.cbOffsets <- function(counts) { + cumsum(c(0L, counts))[seq_along(counts)] +} + +# Study `i`'s dict, renumbered into the combined X / Y ordering. +# @noRd +.cbShiftStudyDict <- function(i, subs, xOffsets, yOffsets) { + d <- subs[[i]]$dict_YX + cbind(Y = d[, "Y"] + yOffsets[[i]], X = d[, "X"] + xOffsets[[i]]) +} + +.cbMultiStudyIndBundle <- function( + qtlData, + contexts, + traitId, + region, + cisWindow, + samples, + screenSpec +) { + qtlDatasets <- getQtlDatasets(qtlData) + subs <- compact(map( + names(qtlDatasets), + .cbStudyBundle, + qtlDatasets = qtlDatasets, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples, + screenSpec = screenSpec + )) + if (length(subs) == 0L) { + return(NULL) } + # Each study's dict indexes its own X and Y, so it shifts by however many + # entries the studies before it contributed -- a cumulative count, known + # once all the bundles are in hand rather than tracked while looping. + xOffsets <- .cbOffsets(map_int(subs, .cbFieldLength, field = "X")) + yOffsets <- .cbOffsets(map_int(subs, .cbFieldLength, field = "Y")) + combinedX <- .cbConcat(map(subs, "X")) if (length(combinedX) == 0L) { return(NULL) } list( X = combinedX, - Y = combinedY, - dict_YX = combinedDict, - outcomeNames = combinedOutcomes, - outcomeInfo = bind_rows(combinedInfo) + Y = .cbConcat(map(subs, "Y")), + dict_YX = do.call( + rbind, + map( + seq_along(subs), + .cbShiftStudyDict, + subs = subs, + xOffsets = xOffsets, + yOffsets = yOffsets + ) + ), + outcomeNames = .cbConcat(map(subs, "outcomeNames")), + outcomeInfo = bind_rows(map(subs, "outcomeInfo")) ) } @@ -1573,17 +1843,29 @@ setMethod( # outcome names). # @noRd .cbPrefixStudyNames <- function(sub, study) { - names(sub$X) <- str_c(study, names(sub$X), sep = ":") - sub$outcomeNames <- str_c(study, sub$outcomeNames, sep = ":") - names(sub$Y) <- sub$outcomeNames + outcomeNames <- str_c(study, sub$outcomeNames, sep = ":") + renamed <- list_assign( + sub, + X = set_names(sub$X, str_c(study, names(sub$X), sep = ":")), + Y = set_names(sub$Y, outcomeNames), + outcomeNames = outcomeNames + ) # The lookup table is keyed on the outcome NAME, so it has to be renamed in # the same pass -- a stale key silently drops every outcome of this study # from the identity join. - if (!is.null(sub$outcomeInfo) && nrow(sub$outcomeInfo) > 0L) { - sub$outcomeInfo$name <- str_c(study, sub$outcomeInfo$name, sep = ":") - sub$outcomeInfo$study <- study - } - sub + if (is.null(sub$outcomeInfo) || nrow(sub$outcomeInfo) == 0L) { + return(renamed) + } + # `studyLabel` so the data mask cannot shadow it with the `study` column. + studyLabel <- study + list_assign( + renamed, + outcomeInfo = mutate( + sub$outcomeInfo, + name = str_c(studyLabel, .data$name, sep = ":"), + study = studyLabel + ) + ) } # Sumstat side of a MultiStudyQtlDataset: bundle any embedded QtlSumStats. @@ -1649,7 +1931,7 @@ setMethod( individualBundle, sumstatBundle, hasInd, - dotArgs + colocboostArgs ) { .cbRunOneSeparateGwas( i, @@ -1657,6 +1939,6 @@ setMethod( individualBundle, sumstatBundle, hasInd, - dotArgs + colocboostArgs ) } diff --git a/R/crossValidation.R b/R/crossValidation.R index 2e85d295..375e137a 100644 --- a/R/crossValidation.R +++ b/R/crossValidation.R @@ -49,18 +49,35 @@ } lmFit <- stats::lm(actual ~ pred) s <- summary(lmFit) - out["corr"] <- stats::cor(actual, pred) - out["rsq"] <- s$r.squared - out["adj_rsq"] <- s$adj.r.squared - out["pval"] <- if (nrow(s$coefficients) >= 2L) { - s$coefficients[2L, 4L] - } else { - NA_real_ - } res <- actual - pred - out["RMSE"] <- sqrt(mean(res^2)) - out["MAE"] <- mean(abs(res)) - out + c( + corr = stats::cor(actual, pred), + rsq = s$r.squared, + adj_rsq = s$adj.r.squared, + pval = if (nrow(s$coefficients) >= 2L) { + s$coefficients[2L, 4L] + } else { + NA_real_ + }, + RMSE = sqrt(mean(res^2)), + MAE = mean(abs(res)) + ) +} + +# A canonical fingerprint of a Sample/Fold partition, used to prove that +# per-fold fits handed to twasWeightsCv were trained on the same folds it is +# scoring. Sample order is normalised first, so two partitions that assign the +# same samples to the same folds agree regardless of row order. +# @noRd +.cvPartitionKey <- function(samplePartition) { + if (is.null(samplePartition)) { + return(NULL) + } + tbl <- samplePartition |> + arrange(.data$Sample, .data$Fold) |> + mutate(.key = str_c(.data$Sample, "=", .data$Fold)) |> + pull(".key") + rlang::hash(tbl) } # One CV fold: split train/test by fold `j`, drop zero-variance training @@ -85,11 +102,11 @@ if (all(isTest) || !any(isTest)) { return(list(preds = list(), fits = list())) } - Xtr <- X[!isTest, , drop = FALSE] + trainAll <- X[!isTest, , drop = FALSE] Xte <- X[isTest, , drop = FALSE] Ytr <- Y[!isTest, , drop = FALSE] - keep <- .nonzeroVarColumns(Xtr) - Xtr <- Xtr[, keep, drop = FALSE] + keep <- .nonzeroVarColumns(trainAll) + Xtr <- trainAll[, keep, drop = FALSE] ff <- fitFold(Xtr, Ytr, j, fitFoldCtx) preds <- map(ff$weights, .cvFoldPrediction, Xte = Xte) list(preds = preds, fits = if (isTRUE(retainFits)) ff$fits else list()) @@ -114,7 +131,7 @@ # and keys the output via .cvOutputKey(). `maxNumVariants` (optional) randomly # subsamples variants up front to bound compute; `numThreads` parallelises the # fold loop (-1 = all cores, 0/1 = serial). -#' @importFrom BiocParallel bplapply bpworkers MulticoreParam +#' @importFrom BiocParallel bplapply multicoreWorkers MulticoreParam #' @importFrom stats sd lm cor #' @importFrom dplyr n_distinct #' @noRd @@ -170,13 +187,12 @@ # Validate inputs, coerce a vector Y to a one-column matrix, and set stable # row/column dimnames on X and Y. Returns list(X, Y). # @noRd +#' @importFrom checkmate assert assertCount assertMatrix +#' @importFrom checkmate checkAtomicVector checkMatrix .cvPrepareData <- function(X, Y, fold, verbose) { - if (!is.null(fold) && (!is.numeric(fold) || fold <= 0)) { - abort("Invalid value for 'fold'. It must be a positive integer.") - } - if (!is.matrix(X) || (!is.matrix(Y) && !is.vector(Y))) { - abort("X must be a matrix and Y must be a matrix or a vector.") - } + assertCount(fold, positive = TRUE, null.ok = TRUE) + assertMatrix(X) + assert(checkMatrix(Y), checkAtomicVector(Y), .var.name = "Y") if (is.vector(Y)) { Y <- matrix(Y, ncol = 1) if (verbose >= 1) { @@ -187,9 +203,7 @@ inform(msg) } } - if (nrow(X) != nrow(Y)) { - abort("The number of rows in X and Y must be the same.") - } + assertMatrix(Y, nrows = nrow(X)) .cvSetDimnames(X, Y) } @@ -202,19 +216,22 @@ } else { str_c("sample_", seq_len(nrow(X))) } - if (is.null(rownames(X))) { - rownames(X) <- sampleNames - } - if (is.null(rownames(Y))) { - rownames(Y) <- sampleNames - } - if (is.null(colnames(X))) { - colnames(X) <- str_c("variable_", seq_len(ncol(X))) - } - if (is.null(colnames(Y))) { - colnames(Y) <- str_c("context_", seq_len(ncol(Y))) - } - list(X = X, Y = Y) + list( + X = `dimnames<-`( + X, + list( + rownames(X) %||% sampleNames, + colnames(X) %||% str_c("variable_", seq_len(ncol(X))) + ) + ), + Y = `dimnames<-`( + Y, + list( + rownames(Y) %||% sampleNames, + colnames(Y) %||% str_c("context_", seq_len(ncol(Y))) + ) + ) + ) } # Optional variant subsample (compute saver; e.g. TWAS weight CV). @@ -324,13 +341,12 @@ } # @noRd +# multicoreWorkers() rather than bpworkers(MulticoreParam()): the two answer +# the same number, but constructing a MulticoreParam costs ~0.6s (almost all +# of it garbage collection) and this runs on every fit. .cvNumCores <- function(numThreads) { - numCores <- if (numThreads == -1) { - bpworkers(MulticoreParam()) - } else { - numThreads - } - min(numCores, bpworkers(MulticoreParam())) + avail <- multicoreWorkers() + min(if (numThreads == -1) avail else numThreads, avail) } # Run each fold (parallel via BiocParallel when >= 2 cores). @@ -377,21 +393,30 @@ # @noRd .cvAggregate <- function(foldResults, Y, verbose) { metricNames <- c("corr", "rsq", "adj_rsq", "pval", "RMSE", "MAE") - methodKeys <- unique(unlist(map(foldResults, .cvPredNames))) - prediction <- list() - performance <- list() - for (mk in methodKeys) { - predMat <- .cvPredMatrix(foldResults, mk, Y) - prediction[[.cvOutputKey(mk, "predicted")]] <- predMat - performance[[.cvOutputKey(mk, "performance")]] <- .cvPerformance( - predMat, - Y, - mk, - verbose, - metricNames + methodKeys <- unique(list_c(map(foldResults, .cvPredNames))) + predMats <- map(methodKeys, .cvPredMatrix, foldResults = foldResults, Y = Y) + list( + prediction = set_names( + predMats, + map_chr(methodKeys, .cvOutputKey, suffix = "predicted") + ), + performance = set_names( + map2( + predMats, + methodKeys, + .cvPerformanceFor, + Y = Y, + verbose = verbose, + metricNames = metricNames + ), + map_chr(methodKeys, .cvOutputKey, suffix = "performance") ) - } - list(prediction = prediction, performance = performance) + ) +} + +# @noRd +.cvPerformanceFor <- function(predMat, mk, Y, verbose, metricNames) { + .cvPerformance(predMat, Y, mk, verbose, metricNames) } # @noRd @@ -402,17 +427,21 @@ # Assemble the (samples x conditions) prediction matrix for a method, scattering # each fold's held-out predictions by row name. # @noRd -.cvPredMatrix <- function(foldResults, mk, Y) { +.cvPredMatrix <- function(mk, foldResults, Y) { + # Deliberate scatter: the folds partition the samples, so each writes its + # own held-out rows once and samples in no fold stay NA. predMat <- matrix(NA_real_, nrow(Y), ncol(Y), dimnames = dimnames(Y)) - for (fr in foldResults) { - yh <- fr$preds[[mk]] - if (!is.null(yh)) { - predMat[rownames(yh), ] <- yh - } + for (yh in compact(map(foldResults, .cvFoldPreds, mk = mk))) { + predMat[rownames(yh), ] <- yh } predMat } +# @noRd +.cvFoldPreds <- function(fr, mk) { + fr$preds[[mk]] +} + # Per-condition performance metrics (conditions x metrics). # @noRd .cvPerformance <- function(predMat, Y, mk, verbose, metricNames) { @@ -424,10 +453,10 @@ mk = mk, verbose = verbose ) - perf <- exec(rbind, !!!metricRows) - colnames(perf) <- metricNames - rownames(perf) <- colnames(Y) - perf + `dimnames<-`( + exec(rbind, !!!metricRows), + list(colnames(Y), metricNames) + ) } # @noRd @@ -470,12 +499,13 @@ if (is.null(W)) { return(NULL) } - W[is.na(W)] <- 0 + W <- replace(W, is.na(W), 0) common <- intersect(colnames(Xte), rownames(W)) if (length(common) == 0L) { return(NULL) } - yhat <- Xte[, common, drop = FALSE] %*% W[common, , drop = FALSE] - rownames(yhat) <- rownames(Xte) - yhat + `rownames<-`( + Xte[, common, drop = FALSE] %*% W[common, , drop = FALSE], + rownames(Xte) + ) } diff --git a/R/ctwasPipeline.R b/R/ctwasPipeline.R index b0d2e3c1..fb0a29e6 100644 --- a/R/ctwasPipeline.R +++ b/R/ctwasPipeline.R @@ -104,7 +104,8 @@ #' \code{mergeBoundary = TRUE}. #' @param mergeMaxSNP Numeric (length 1). Per-merged-region SNP cap. Default #' \code{Inf}. Ignored unless \code{mergeBoundary = TRUE}. -#' @param ... Additional arguments forwarded to \code{ctwas::ctwas_sumstats}. +#' @param ctwasArgs Optional named list of additional arguments +#' forwarded to \code{ctwas::ctwas_sumstats}. #' @return A \code{\link{CtwasResult}} collection: one row per \code{(gwasStudy, #' study, context, method)}. A single-context run is one row per method; a #' multi-context (joint) run emits per-context rows sharing the same @@ -132,8 +133,8 @@ #' gwasByRegion <- summaryStatsQc(gss, mafCutoff = 0.0025) #' ctwasPipeline(gwasSumStats = gwasByRegion, #' twasWeights = list(ctwasWeightsExample), thin = 1, niterPrefit = 3, -#' niter = 10, min_group_size = 1, min_p_single_effect = 0, -#' fallbackToPrefit = TRUE) +#' niter = 10, fallbackToPrefit = TRUE, +#' ctwasArgs = list(min_group_size = 1, min_p_single_effect = 0)) #' @export ctwasPipeline <- function( gwasSumStats, @@ -163,15 +164,38 @@ ctwasPipeline <- function( mergePipThresh = 0.5, mergeFilterCs = FALSE, mergeMaxSNP = Inf, - ... + ctwasArgs = list() ) { groupPriorVarStructure <- arg_match(groupPriorVarStructure) .ctwasRequireNamedLists(gwasSumStats, twasWeights) methods <- .ctwasResolveMethods(twasWeights, method) gwasStudy <- .ctwasGwasStudy(gwasSumStats) - cfg <- as.list(environment()) - cfg$dots <- list(...) - rows <- list_flatten(map(methods, .ctwasRunMethod, cfg = cfg)) + rows <- list_flatten(map( + methods, + .ctwasRunMethod, + gwasSumStats = gwasSumStats, + twasWeights = twasWeights, + twasZ = twasZ, + fineMappingResult = fineMappingResult, + twasWeightCutoff = twasWeightCutoff, + csMinCor = csMinCor, + minPipCutoff = minPipCutoff, + maxNumVariants = maxNumVariants, + thin = thin, + niterPrefit = niterPrefit, + niter = niter, + groupPriorVarStructure = groupPriorVarStructure, + ncore = ncore, + fallbackToPrefit = fallbackToPrefit, + L = L, + mergeBoundary = mergeBoundary, + mergePipThresh = mergePipThresh, + mergeFilterCs = mergeFilterCs, + mergeMaxSNP = mergeMaxSNP, + gwasStudy = gwasStudy, + keepSnps = keepSnps, + ctwasArgs = ctwasArgs + )) if (length(rows) == 0L) { msg <- glue( "ctwasPipeline: no genes were modeled (the weight sources ", @@ -185,62 +209,111 @@ ctwasPipeline <- function( # One cTWAS run for method `m`: assemble inputs -> estimate params -> screen -> # fine-map (optionally boundary-merge) -> per-context row-specs. `cfg` bundles -# the ctwasPipeline arguments (incl. `dots` = the forwarded `...`). +# the ctwasPipeline arguments (incl. the `ctwasArgs` option list). # @noRd -.ctwasRunMethod <- function(m, cfg) { +.ctwasRunMethod <- function( + m, + gwasSumStats, + twasWeights, + twasZ, + fineMappingResult, + twasWeightCutoff, + csMinCor, + minPipCutoff, + maxNumVariants, + thin, + niterPrefit, + niter, + groupPriorVarStructure, + ncore, + fallbackToPrefit, + L, + mergeBoundary, + mergePipThresh, + mergeFilterCs, + mergeMaxSNP, + gwasStudy, + keepSnps, + ctwasArgs +) { inputs <- assembleCtwasInputs( - gwasSumStats = cfg$gwasSumStats, - twasWeights = cfg$twasWeights, - twasZ = cfg$twasZ, - fineMappingResult = cfg$fineMappingResult, + gwasSumStats = gwasSumStats, + twasWeights = twasWeights, + twasZ = twasZ, + fineMappingResult = fineMappingResult, method = m, - twasWeightCutoff = cfg$twasWeightCutoff, - csMinCor = cfg$csMinCor, - minPipCutoff = cfg$minPipCutoff, - maxNumVariants = cfg$maxNumVariants + twasWeightCutoff = twasWeightCutoff, + csMinCor = csMinCor, + minPipCutoff = minPipCutoff, + maxNumVariants = maxNumVariants ) - estArgs <- c( - list( - inputs, - thin = cfg$thin, - niterPrefit = cfg$niterPrefit, - niter = cfg$niter, - groupPriorVarStructure = cfg$groupPriorVarStructure, - ncore = cfg$ncore, - fallbackToPrefit = cfg$fallbackToPrefit - ), - cfg$dots + # The three stages each take the ctwas option list as one named argument + # now, so it is passed rather than spliced in as loose top-level args. + est <- estCtwasParam( + inputs, + thin = thin, + niterPrefit = niterPrefit, + niter = niter, + groupPriorVarStructure = groupPriorVarStructure, + ncore = ncore, + fallbackToPrefit = fallbackToPrefit, + ctwasArgs = ctwasArgs + ) + screened <- screenCtwasRegions( + est, + L = L, + ncore = ncore, + ctwasArgs = ctwasArgs ) - est <- exec(estCtwasParam, !!!estArgs) - screenArgs <- c(list(est, L = cfg$L, ncore = cfg$ncore), cfg$dots) - screened <- exec(screenCtwasRegions, !!!screenArgs) - finemapArgs <- c(list(screened, L = cfg$L, ncore = cfg$ncore), cfg$dots) - finemap <- exec(finemapCtwasRegions, !!!finemapArgs) - if (cfg$mergeBoundary) { - finemap <- .ctwasMaybeMerge(finemap, cfg) + finemap <- finemapCtwasRegions( + screened, + L = L, + ncore = ncore, + ctwasArgs = ctwasArgs + ) + merged <- if (mergeBoundary) { + .ctwasMaybeMerge( + finemap, + mergePipThresh = mergePipThresh, + mergeFilterCs = mergeFilterCs, + mergeMaxSNP = mergeMaxSNP, + L = L, + ncore = ncore, + ctwasArgs = ctwasArgs + ) + } else { + finemap } .ctwasRunToRows( - finemap, - gwasStudy = cfg$gwasStudy, + merged, + gwasStudy = gwasStudy, method = m, - keepSnps = cfg$keepSnps + keepSnps = keepSnps ) } # Boundary-gene region merging: split a high-PIP straddling gene's adjacent # regions and re-fine-map. Merge-transparent downstream (keyed by gene id). # @noRd -.ctwasMaybeMerge <- function(finemap, cfg) { +.ctwasMaybeMerge <- function( + finemap, + mergePipThresh, + mergeFilterCs, + mergeMaxSNP, + L, + ncore, + ctwasArgs +) { mergeArgs <- c( list( finemap, - pipThresh = cfg$mergePipThresh, - filterCs = cfg$mergeFilterCs, - maxSNP = cfg$mergeMaxSNP, - L = cfg$L, - ncore = cfg$ncore + pipThresh = mergePipThresh, + filterCs = mergeFilterCs, + maxSNP = mergeMaxSNP, + L = L, + ncore = ncore ), - cfg$dots + ctwasArgs ) exec(mergeCtwasBoundaryRegions, !!!mergeArgs) } @@ -329,11 +402,7 @@ assembleCtwasInputs <- function( # @noRd .ctwasValidateGwasList <- function(gwasSumStats) { if (!requireNamespace("ctwas", quietly = TRUE)) { - msg <- glue( - "Package 'ctwas' is required for the cTWAS pipeline. ", - "Install from https://github.com/xinhe-lab/ctwas ." - ) - abort(msg) + abort("Package 'ctwas' is required for the cTWAS pipeline.") } if (missing(gwasSumStats) || !methods::is(gwasSumStats, "GwasSumStats")) { msg <- glue( @@ -483,42 +552,76 @@ assembleCtwasInputs <- function( # Returns list(ldPanelsByRegion, zSnpPieces, regionInfoPieces, snpMap, # ldFileByRegion). # @noRd -.ctwasFirstPass <- function(regionIds, gwasSumStats, twasWeights) { - ldPanelsByRegion <- list() - zSnpPieces <- list() - regionInfoPieces <- list() - snpMap <- list() - ldFileByRegion <- set_names(character(length(regionIds)), regionIds) - for (rid in regionIds) { - gss <- gwasSumStats[[rid]] - tw <- twasWeights[[rid]] - gwasLd <- getLdSketch(gss) - if (is.null(gwasLd)) { - msg <- glue( - "ctwasPipeline: GwasSumStats for region '{rid}' carries no ", - "ldSketch (ldSketch = NULL); cTWAS requires an LD reference." - ) - abort(msg) - } - if (!is.null(tw)) { - .ctwasRequireMatchingLdSketches(getLdSketch(tw), gwasLd) - } - ldKey <- .ctwasLdPanelKey(gwasLd) - if (is.null(ldPanelsByRegion[[ldKey]])) { - ldPanelsByRegion[[ldKey]] <- .ctwasComputeFullPanelLd(gwasLd) - } - ldPanel <- ldPanelsByRegion[[ldKey]] - ldFileByRegion[[rid]] <- ldKey - zSnpPieces[[rid]] <- .ctwasBuildZSnp(gss, ldPanel$snpInfo$id) - regionInfoPieces[[rid]] <- .ctwasBuildSingleRegionInfo(rid, gss) - snpMap[[rid]] <- .ctwasSnpInfoForGwasBlock(gss, ldPanel$snpInfo) +# One region's GWAS LD sketch, checked against the region's weights. +# @noRd +.ctwasRegionGwasLd <- function(rid, gwasSumStats, twasWeights) { + gwasLd <- getLdSketch(gwasSumStats[[rid]]) + if (is.null(gwasLd)) { + msg <- glue( + "ctwasPipeline: GwasSumStats for region '{rid}' carries no ", + "ldSketch (ldSketch = NULL); cTWAS requires an LD reference." + ) + abort(msg) + } + tw <- twasWeights[[rid]] + if (!is.null(tw)) { + .ctwasRequireMatchingLdSketches(getLdSketch(tw), gwasLd) } + gwasLd +} + +# @noRd +.ctwasZSnpAt <- function(rid, ldPanel, gwasSumStats) { + .ctwasBuildZSnp(gwasSumStats[[rid]], ldPanel$snpInfo$id) +} + +# @noRd +.ctwasSnpMapAt <- function(rid, ldPanel, gwasSumStats) { + .ctwasSnpInfoForGwasBlock(gwasSumStats[[rid]], ldPanel$snpInfo) +} + +# @noRd +.ctwasRegionInfoAt <- function(rid, gwasSumStats) { + .ctwasBuildSingleRegionInfo(rid, gwasSumStats[[rid]]) +} + +.ctwasFirstPass <- function(regionIds, gwasSumStats, twasWeights) { + sketches <- map( + regionIds, + .ctwasRegionGwasLd, + gwasSumStats = gwasSumStats, + twasWeights = twasWeights + ) + ldKeys <- map_chr(sketches, .ctwasLdPanelKey) + # The panel cache is "compute once per distinct key": the first region + # carrying each key is the one whose sketch gets expanded, and every + # region then reads its panel back out by key. + firstOfKey <- !duplicated(ldKeys) + ldPanelsByRegion <- set_names( + map(sketches[firstOfKey], .ctwasComputeFullPanelLd), + ldKeys[firstOfKey] + ) + panels <- unname(ldPanelsByRegion[ldKeys]) list( ldPanelsByRegion = ldPanelsByRegion, - zSnpPieces = zSnpPieces, - regionInfoPieces = regionInfoPieces, - snpMap = snpMap, - ldFileByRegion = ldFileByRegion + zSnpPieces = set_names( + map2(regionIds, panels, .ctwasZSnpAt, gwasSumStats = gwasSumStats), + regionIds + ), + regionInfoPieces = set_names( + map(regionIds, .ctwasRegionInfoAt, gwasSumStats = gwasSumStats), + regionIds + ), + snpMap = set_names( + map2( + regionIds, + panels, + .ctwasSnpMapAt, + gwasSumStats = gwasSumStats + ), + regionIds + ), + ldFileByRegion = set_names(ldKeys, regionIds) ) } @@ -537,34 +640,63 @@ assembleCtwasInputs <- function( cutoffs, globalGwasSnpIds ) { - weightsList <- list() - for (rid in regionIds) { - tw <- twasWeights[[rid]] - if (is.null(tw)) { - next - } - twMethod <- .ctwasFilterMethod(tw, resolvedMethod) - if (is.null(twMethod)) { - next - } - ldPanel <- fp$ldPanelsByRegion[[fp$ldFileByRegion[[rid]]]] - blockWeights <- .ctwasBuildWeights( - twMethod, - ldPanel, - fineMappingResult = fineMappingResult, - twasWeightCutoff = cutoffs$twasWeightCutoff, - csMinCor = cutoffs$csMinCor, - minPipCutoff = cutoffs$minPipCutoff, - maxNumVariants = cutoffs$maxNumVariants, - gwasSnpIds = globalGwasSnpIds, - regionSnpIds = fp$snpMap[[rid]]$id - ) - if (length(blockWeights) > 0L) { - names(blockWeights) <- str_c(rid, "|", names(blockWeights)) - weightsList <- c(weightsList, blockWeights) - } + perRegion <- map( + regionIds, + .ctwasRegionBlockWeights, + twasWeights = twasWeights, + fp = fp, + resolvedMethod = resolvedMethod, + fineMappingResult = fineMappingResult, + cutoffs = cutoffs, + globalGwasSnpIds = globalGwasSnpIds + ) + .ctwasConcat(compact(perRegion)) +} + +# Concatenate per-region lists, empty-safe. +# @noRd +.ctwasConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) + } + list_c(pieces) +} + +# One region's block weights, region-qualified, or NULL when the region has no +# weights for the resolved method. +# @noRd +.ctwasRegionBlockWeights <- function( + rid, + twasWeights, + fp, + resolvedMethod, + fineMappingResult, + cutoffs, + globalGwasSnpIds +) { + tw <- twasWeights[[rid]] + if (is.null(tw)) { + return(NULL) + } + twMethod <- .ctwasFilterMethod(tw, resolvedMethod) + if (is.null(twMethod)) { + return(NULL) + } + blockWeights <- .ctwasBuildWeights( + twMethod, + fp$ldPanelsByRegion[[fp$ldFileByRegion[[rid]]]], + fineMappingResult = fineMappingResult, + twasWeightCutoff = cutoffs$twasWeightCutoff, + csMinCor = cutoffs$csMinCor, + minPipCutoff = cutoffs$minPipCutoff, + maxNumVariants = cutoffs$maxNumVariants, + gwasSnpIds = globalGwasSnpIds, + regionSnpIds = fp$snpMap[[rid]]$id + ) + if (length(blockWeights) == 0L) { + return(NULL) } - weightsList + set_names(blockWeights, str_c(rid, "|", names(blockWeights))) } # Concatenate the per-region pieces into the ctwas-shape input list. @@ -626,15 +758,16 @@ assembleCtwasInputs <- function( #' deliberately broad; a genuinely broken input still surfaces because the #' prefit re-run will itself error. Mirrors the legacy ctwas_2 workaround on #' toy data where the accurate EM cannot be estimated. -#' @param ... Additional arguments forwarded to \code{ctwas::est_param} (e.g. +#' @param ctwasArgs Optional named list of additional arguments +#' forwarded to \code{ctwas::est_param} (e.g. #' \code{min_p_single_effect}, \code{min_group_size}). #' @return The \code{inputs} list augmented with \code{region_data}, #' \code{boundary_genes}, \code{z_gene}, and \code{param}. #' @examples #' data(ctwasInputsExample) #' estCtwasParam(ctwasInputsExample, thin = 1, niterPrefit = 3, -#' niter = 10, min_group_size = 1, min_p_single_effect = 0, -#' fallbackToPrefit = TRUE) +#' niter = 10, fallbackToPrefit = TRUE, +#' ctwasArgs = list(min_group_size = 1, min_p_single_effect = 0)) #' @export estCtwasParam <- function( inputs, @@ -650,7 +783,7 @@ estCtwasParam <- function( ), ncore = 1L, fallbackToPrefit = FALSE, - ... + ctwasArgs = list() ) { if (!requireNamespace("ctwas", quietly = TRUE)) { abort("Package 'ctwas' is required for estCtwasParam.") @@ -658,10 +791,15 @@ estCtwasParam <- function( groupPriorVarStructure <- arg_match(groupPriorVarStructure) ncore <- as.integer(ncore) inputs <- .ctwasResolveLdPaths(inputs) - extra <- list(...) zGene <- .ctwasEnsureZGene(inputs, ncore) - regionData <- .ctwasAssembleRegionData(inputs, zGene, thin, ncore, extra) - boundaryGenes <- .ctwasBoundaryGenes(inputs, ncore, extra) + regionData <- .ctwasAssembleRegionData( + inputs, + zGene, + thin, + ncore, + ctwasArgs + ) + boundaryGenes <- .ctwasBoundaryGenes(inputs, ncore, ctwasArgs) paramRes <- .ctwasEstParamOrFallback( regionData, niterPrefit, @@ -670,14 +808,13 @@ estCtwasParam <- function( ncore, thin, fallbackToPrefit, - extra + ctwasArgs ) # assemble_region_data does not echo z_gene back, so propagate the # precomputed z_gene we passed in (inputs$z_gene is NULL when twasZ was not # supplied) so $z_gene resolves to the right entry. - inputs$z_gene <- zGene c( - inputs, + list_assign(inputs, z_gene = zGene), list( region_data = regionData, boundary_genes = boundaryGenes, @@ -766,6 +903,7 @@ estCtwasParam <- function( # log-likelihood), so catch all rather than match brittle version messages. The # prefit re-run runs to full `niter` (this is now the final prior). # @noRd +#' @importFrom rlang try_fetch .ctwasEstParamOrFallback <- function( regionData, niterPrefit, @@ -788,7 +926,7 @@ estCtwasParam <- function( extra )) } - tryCatch( + try_fetch( .ctwasEstParamAccurate( regionData, niterPrefit, @@ -797,12 +935,12 @@ estCtwasParam <- function( ncore, extra ), - error = function(e) { + error = function(cnd) { msg <- glue( - "estCtwasParam: accurate EM unusable ", - "({conditionMessage(e)}); falling back to prefit estimates." + "estCtwasParam: accurate EM unusable; falling back to ", + "prefit estimates." ) - inform(msg) + inform(msg, parent = cnd) .ctwasFitPrefitEm( regionData, niter = as.integer(niter), @@ -829,7 +967,8 @@ estCtwasParam <- function( #' single-effect (SER) model and ignores L. \code{L} is applied by #' \code{\link{finemapCtwasRegions}} downstream. #' @param ncore Number of cores. -#' @param ... Additional arguments forwarded to \code{ctwas::screen_regions} +#' @param ctwasArgs Optional named list of additional arguments +#' forwarded to \code{ctwas::screen_regions} #' (e.g. \code{min_nonSNP_PIP}, \code{min_snp_pval}, \code{min_var}, #' \code{min_gene}). #' @return The \code{estResult} list augmented with \code{screen_res} (the full @@ -839,7 +978,12 @@ estCtwasParam <- function( #' data(ctwasEstExample) #' screenCtwasRegions(ctwasEstExample, L = 5L) #' @export -screenCtwasRegions <- function(estResult, L = 5L, ncore = 1L, ...) { +screenCtwasRegions <- function( + estResult, + L = 5L, + ncore = 1L, + ctwasArgs = list() +) { if (!requireNamespace("ctwas", quietly = TRUE)) { abort("Package 'ctwas' is required for screenCtwasRegions.") } @@ -848,7 +992,7 @@ screenCtwasRegions <- function(estResult, L = 5L, ncore = 1L, ...) { # thinned set first when assemble_region_data was called with thin < 1 # (matches ctwas_sumstats's own expand-before-screen step). thinVals <- compact(map(estResult$region_data, "thin")) - needsExpand <- length(thinVals) > 0L && min(unlist(thinVals)) < 1 + needsExpand <- length(thinVals) > 0L && min(list_c(thinVals)) < 1 regionDataForScreen <- if (needsExpand) { .ctwasInvoke( ctwas::expand_region_data, @@ -858,7 +1002,7 @@ screenCtwasRegions <- function(estResult, L = 5L, ncore = 1L, ...) { z_snp = estResult$z_snp, ncore = as.integer(ncore) ), - extra = list(...) + extra = ctwasArgs ) } else { estResult$region_data @@ -871,7 +1015,7 @@ screenCtwasRegions <- function(estResult, L = 5L, ncore = 1L, ...) { group_prior_var = estResult$param$group_prior_var, ncore = as.integer(ncore) ), - extra = list(...) + extra = ctwasArgs ) c( estResult, @@ -894,7 +1038,8 @@ screenCtwasRegions <- function(estResult, L = 5L, ncore = 1L, ...) { #' @param screenResult A list returned by \code{\link{screenCtwasRegions}}. #' @param L Pass-through. #' @param ncore Number of cores. -#' @param ... Additional arguments forwarded to \code{ctwas::finemap_regions}. +#' @param ctwasArgs Optional named list of additional arguments +#' forwarded to \code{ctwas::finemap_regions}. #' @return A list mirroring \code{ctwas::ctwas_sumstats}'s output: #' \code{z_gene}, \code{param}, \code{finemap_res}, \code{susie_alpha_res}, #' \code{region_data}, \code{boundary_genes}, \code{screen_res}. @@ -915,11 +1060,17 @@ screenCtwasRegions <- function(estResult, L = 5L, ncore = 1L, ...) { #' inp <- assembleCtwasInputs(gwasSumStats = gwasByRegion, #' twasWeights = list(ctwasWeightsExample)) #' est <- estCtwasParam(inp, thin = 1, niterPrefit = 3, niter = 10, -#' min_group_size = 1, min_p_single_effect = 0, fallbackToPrefit = TRUE) +#' fallbackToPrefit = TRUE, +#' ctwasArgs = list(min_group_size = 1, min_p_single_effect = 0)) #' screened <- screenCtwasRegions(est, L = 5L) #' finemapCtwasRegions(screened, L = 5L) #' @export -finemapCtwasRegions <- function(screenResult, L = 5L, ncore = 1L, ...) { +finemapCtwasRegions <- function( + screenResult, + L = 5L, + ncore = 1L, + ctwasArgs = list() +) { if (!requireNamespace("ctwas", quietly = TRUE)) { abort("Package 'ctwas' is required for finemapCtwasRegions.") } @@ -942,18 +1093,16 @@ finemapCtwasRegions <- function(screenResult, L = 5L, ncore = 1L, ...) { snpinfo_loader_fun = screenResult$snpinfo_loader_fun, ncore = as.integer(ncore) ), - extra = list(...) + extra = ctwasArgs ) } # Repair cTWAS's molecular_id mislabel (first-"|" split of our composite # id). - fmRes$finemap_res <- .ctwasFixMolecularId(fmRes$finemap_res) - fmRes$susie_alpha_res <- .ctwasFixMolecularId(fmRes$susie_alpha_res) list( z_gene = screenResult$z_gene, param = screenResult$param, - finemap_res = fmRes$finemap_res, - susie_alpha_res = fmRes$susie_alpha_res, + finemap_res = .ctwasFixMolecularId(fmRes$finemap_res), + susie_alpha_res = .ctwasFixMolecularId(fmRes$susie_alpha_res), region_data = screenResult$region_data, boundary_genes = screenResult$boundary_genes, screen_res = screenResult$screen_res, @@ -999,7 +1148,9 @@ finemapCtwasRegions <- function(screenResult, L = 5L, ncore = 1L, ...) { #' @param L Integer. Max number of single effects for the merged-region #' re-fine-mapping (LD path only). Default \code{5}. #' @param ncore Number of cores. Default \code{1}. -#' @param ... Forwarded to the underlying ctwas postprocess function. +#' @param ctwasArgs Optional named list of additional arguments +#' forwarded to the underlying ctwas postprocess +#' function. #' @return The \code{finemapResult} list with \code{finemap_res}, #' \code{susie_alpha_res}, \code{region_data}, \code{region_info}, #' \code{LD_map}, and \code{snp_map} replaced by the post-merge ("updated") @@ -1017,7 +1168,7 @@ mergeCtwasBoundaryRegions <- function( maxSNP = Inf, L = 5L, ncore = 1L, - ... + ctwasArgs = list() ) { if (!requireNamespace("ctwas", quietly = TRUE)) { abort("Package 'ctwas' is required for mergeCtwasBoundaryRegions.") @@ -1040,8 +1191,7 @@ mergeCtwasBoundaryRegions <- function( ncore ) fa <- .ctwasMergeDispatch(finemapResult, common, L) - userExtra <- list(...) - userExtra <- userExtra[setdiff(names(userExtra), names(fa$args))] + userExtra <- ctwasArgs[setdiff(names(ctwasArgs), names(fa$args))] callArgs <- c(fa$args, userExtra) res <- exec(fa$fn, !!!callArgs) .ctwasApplyMergeResult(finemapResult, res) @@ -1102,22 +1252,18 @@ mergeCtwasBoundaryRegions <- function( # ctwas actually returned). # @noRd .ctwasApplyMergeResult <- function(finemapResult, res) { - finemapResult$finemap_res <- res$updated_finemap_res - finemapResult$susie_alpha_res <- res$updated_susie_alpha_res - if (!is.null(res$updated_region_data)) { - finemapResult$region_data <- res$updated_region_data - } - if (!is.null(res$updated_region_info)) { - finemapResult$region_info <- res$updated_region_info - } - if (!is.null(res$updated_LD_map)) { - finemapResult$LD_map <- res$updated_LD_map - } - if (!is.null(res$updated_snp_map)) { - finemapResult$snp_map <- res$updated_snp_map - } - finemapResult$merge_res <- res - finemapResult + list_assign( + finemapResult, + finemap_res = res$updated_finemap_res, + susie_alpha_res = res$updated_susie_alpha_res, + merge_res = res, + !!!compact(list( + region_data = res$updated_region_data, + region_info = res$updated_region_info, + LD_map = res$updated_LD_map, + snp_map = res$updated_snp_map + )) + ) } # Invoke a ctwas function with a fixed `args` list plus optional `extra` @@ -1127,19 +1273,20 @@ mergeCtwasBoundaryRegions <- function( # @noRd .ctwasInvoke <- function(fn, args, extra = list()) { if (length(extra) > 0L) { - extra <- extra[setdiff(names(extra), names(args))] + deduped <- extra[setdiff(names(extra), names(args))] # `...` is forwarded uniformly to four different ctwas functions # (assemble_region_data / est_param / screen_regions / # finemap_regions). Restrict to fn's explicit formals so an arg # meant for a sibling step doesn't crash this one -- and so args # that fn would otherwise forward via its own `...` (e.g. into # susie_rss) don't bleed into incompatible downstream functions. - formalsFn <- tryCatch(names(formals(fn)), error = function(e) NULL) - if (!is.null(formalsFn)) { - explicitFormals <- setdiff(formalsFn, "...") - extra <- extra[intersect(names(extra), explicitFormals)] + formalsFn <- try_fetch(names(formals(fn)), error = function(cnd) NULL) + usable <- if (is.null(formalsFn)) { + deduped + } else { + deduped[intersect(names(deduped), setdiff(formalsFn, "..."))] } - args <- c(args, extra) + args <- c(args, usable) } exec(fn, !!!args) } @@ -1175,9 +1322,10 @@ mergeCtwasBoundaryRegions <- function( ) prefit <- .ctwasInvoke(fitEm, fitArgs, extra) adj <- .ctwasApplyThin(prefit$group_prior, prefit$group_size, thin) - groupSize <- adj$groupSize - if (length(adj$groupPrior) > 0L) { - groupSize <- groupSize[names(adj$groupPrior)] + groupSize <- if (length(adj$groupPrior) > 0L) { + adj$groupSize[names(adj$groupPrior)] + } else { + adj$groupSize } list( group_prior = adj$groupPrior, @@ -1205,13 +1353,12 @@ mergeCtwasBoundaryRegions <- function( minGene <- if (!is.null(extra$min_gene)) as.integer(extra$min_gene) else 1L nGid <- lengths(map(region_data, "gid")) nSid <- lengths(map(region_data, "sid")) - keep <- rep(TRUE, length(region_data)) - if (minVar > 0L) { - keep <- keep & (nSid + nGid) >= minVar - } - if (minGene > 0L) { - keep <- keep & nGid >= minGene + byVar <- if (minVar > 0L) { + (nSid + nGid) >= minVar + } else { + rep(TRUE, length(region_data)) } + keep <- if (minGene > 0L) byVar & nGid >= minGene else byVar fitRegionData <- region_data[keep] if (length(fitRegionData) == 0L) { abort("No regions selected!") @@ -1222,15 +1369,23 @@ mergeCtwasBoundaryRegions <- function( # Rescale the SNP group prior / size by `thin` (the SNP subsampling factor). # @noRd .ctwasApplyThin <- function(groupPrior, groupSize, thin) { - if (thin != 1) { - if (is_in("SNP", names(groupPrior))) { - groupPrior["SNP"] <- groupPrior["SNP"] * thin - } - if (is_in("SNP", names(groupSize))) { - groupSize["SNP"] <- groupSize["SNP"] / thin - } + if (thin == 1) { + return(list(groupPrior = groupPrior, groupSize = groupSize)) + } + list( + groupPrior = .ctwasScaleSnpGroup(groupPrior, thin), + groupSize = .ctwasScaleSnpGroup(groupSize, 1 / thin) + ) +} + +# Scale the "SNP" entry of a per-group vector, leaving the molecular groups +# alone. A vector without a SNP group passes through unchanged. +# @noRd +.ctwasScaleSnpGroup <- function(groups, factor) { + if (!is_in("SNP", names(groups))) { + return(groups) } - list(groupPrior = groupPrior, groupSize = groupSize) + replace(groups, "SNP", groups[["SNP"]] * factor) } # ============================================================================= @@ -1253,7 +1408,7 @@ mergeCtwasBoundaryRegions <- function( # - Otherwise: error. # @noRd .ctwasResolveMethod <- function(twasWeightsList, method = NULL) { - available <- unique(unlist(map(twasWeightsList, .ctwasMethodChr))) + available <- unique(list_c(map(twasWeightsList, .ctwasMethodChr))) if (length(available) == 0L) { abort("ctwasPipeline: TwasWeights collections have no method entries.") } @@ -1376,31 +1531,37 @@ mergeCtwasBoundaryRegions <- function( # becomes a 0-width chrUn sentinel, which matches no anchor and so yields the # documented "NA when the anchor falls in no block". # @noRd +# One block id parsed into chrom/start/end, or the unplaced sentinel when it +# does not parse as a range. +# @noRd +.ctwasBlockCoords <- function(id) { + g <- try_fetch( + asGranges(str_replace( + as.character(id), + "_([0-9]+)_([0-9]+)$", + ":\\1-\\2" + )), + error = function(cnd) NULL + ) + if (is.null(g) || length(g) < 1L) { + return(list(chrom = "chrUn", start = 1L, end = 0L)) + } + list( + chrom = as.character(GenomicRanges::seqnames(g))[[1L]], + start = GenomicRanges::start(g)[[1L]], + end = GenomicRanges::end(g)[[1L]] + ) +} + .ctwasBlockGrFromIds <- function(ids) { - n <- length(ids) - chrom <- character(n) - start <- integer(n) - end <- integer(n) - for (i in seq_len(n)) { - g <- tryCatch( - asGranges(str_replace( - as.character(ids[[i]]), - "_([0-9]+)_([0-9]+)$", - ":\\1-\\2" - )), - error = function(e) NULL + coords <- map(ids, .ctwasBlockCoords) + GenomicRanges::GRanges( + map_chr(coords, "chrom"), + IRanges::IRanges( + start = map_int(coords, "start"), + end = map_int(coords, "end") ) - if (!is.null(g) && length(g) >= 1L) { - chrom[[i]] <- as.character(GenomicRanges::seqnames(g))[[1L]] - start[[i]] <- GenomicRanges::start(g)[[1L]] - end[[i]] <- GenomicRanges::end(g)[[1L]] - } else { - chrom[[i]] <- "chrUn" - start[[i]] <- 1L - end[[i]] <- 0L - } - } - GenomicRanges::GRanges(chrom, IRanges::IRanges(start = start, end = end)) + ) } # Place each gene (row) of a flat weight source into its home LD block. The @@ -1455,6 +1616,8 @@ mergeCtwasBoundaryRegions <- function( # @noRd .ctwasBlockSpan <- function(gss) { + # S4 dispatch, not list flattening: `gss` is a GwasSumStats collection and + # unlist() returns the GRanges that range() below needs. variants <- unlist(gss, use.names = FALSE) if (length(variants) == 0L) { return(GenomicRanges::GRanges()) @@ -1474,6 +1637,22 @@ mergeCtwasBoundaryRegions <- function( # that block's GWAS LD sketch (the panel its weights are harmonized against, and # what the downstream match-check expects). # @noRd +# The genes homed into region `rid`, carrying that region's LD sketch, or +# NULL when nothing landed there. `slot<-` applied as a function returns a +# copy rather than writing into the subset in place. +# @noRd +.ctwasBucketForRegion <- function(rid, combined, home, gwasSumStats) { + idx <- which(home == rid) + if (length(idx) == 0L) { + return(NULL) + } + `slot<-`( + combined[idx, ], + "ldSketch", + value = getLdSketch(gwasSumStats[[rid]]) + ) +} + .ctwasBucketWeights <- function(weights, gwasSumStats) { combined <- .ctwasCombineWeightSources(weights) # Placement anchors on the GENE's own position, not on a stored analysis @@ -1503,16 +1682,16 @@ mergeCtwasBoundaryRegions <- function( ) warn(msg) } - out <- list() - for (rid in names(gwasSumStats)) { - idx <- which(home == rid) - if (length(idx) == 0L) { - next - } - sub <- combined[idx, ] - sub@ldSketch <- getLdSketch(gwasSumStats[[rid]]) - out[[rid]] <- sub - } + out <- compact(set_names( + map( + names(gwasSumStats), + .ctwasBucketForRegion, + combined = combined, + home = home, + gwasSumStats = gwasSumStats + ), + names(gwasSumStats) + )) if (length(out) == 0L) { msg <- glue( "assembleCtwasInputs: no gene placed into any LD block. ", @@ -1558,7 +1737,7 @@ mergeCtwasBoundaryRegions <- function( # a flat weight source .ctwasMethodsOf(twasWeightsList) } else { - unlist(map(twasWeightsList, .ctwasMethodsOf)) + list_c(compact(map(twasWeightsList, .ctwasMethodsOf))) } ) # a list of them if (length(available) == 0L) { @@ -1588,8 +1767,10 @@ mergeCtwasBoundaryRegions <- function( # Read the collection's own `study` column. map() over a GwasSumStats # iterates its ELEMENTS (per-block GRanges), which carry no study, so it # would silently yield NA for every block. - studies <- unique(.ctwasStudyChr(gwasSumStats)) - studies <- studies[!is.na(studies) & str_length(studies) > 0L] + allStudies <- unique(.ctwasStudyChr(gwasSumStats)) + studies <- allStudies[ + !is.na(allStudies) & str_length(allStudies) > 0L + ] if (length(studies) == 0L) { return(NA_character_) } @@ -1653,8 +1834,14 @@ mergeCtwasBoundaryRegions <- function( } isGene <- lengths(str_split(as.character(df$id), "\\|")) >= 5L if (any(isGene)) { - df$molecular_id[isGene] <- - .ctwasParseGeneIds(as.character(df$id)[isGene])$trait + return(mutate( + df, + molecular_id = replace( + .data$molecular_id, + isGene, + .ctwasParseGeneIds(as.character(df$id)[isGene])$trait + ) + )) } df } @@ -1790,8 +1977,10 @@ mergeCtwasBoundaryRegions <- function( ) ) ) - mcols(gr) <- S4Vectors::DataFrame(df, check.names = FALSE) - gr[placed] + S4Vectors::`mcols<-`( + gr, + value = S4Vectors::DataFrame(df, check.names = FALSE) + )[placed] } # @noRd @@ -1800,7 +1989,7 @@ mergeCtwasBoundaryRegions <- function( if (!is.null(gc) && is_in(id, names(gc))) { return(gc[[id]]) } - parsed <- tryCatch(parseVariantId(id), error = function(e) NULL) + parsed <- try_fetch(parseVariantId(id), error = function(cnd) NULL) if (is.null(parsed) || is.na(parsed$chrom[[1L]])) { return(NULL) } @@ -1853,8 +2042,10 @@ mergeCtwasBoundaryRegions <- function( end = as.integer(ri$stop) ) ) - mcols(gr) <- S4Vectors::DataFrame(ri, check.names = FALSE) - gr + S4Vectors::`mcols<-`( + gr, + value = S4Vectors::DataFrame(ri, check.names = FALSE) + ) } # Decompose one cTWAS run (a `finemapCtwasRegions` output) into per-context @@ -1885,7 +2076,7 @@ mergeCtwasBoundaryRegions <- function( } fmDf <- .ctwasAsDf(runResult$finemap_res) saDf <- .ctwasAsDf(runResult$susie_alpha_res) - rows <- map( + contextRows <- map( contexts, .ctwasContextRow, parsed = parsed, @@ -1896,19 +2087,12 @@ mergeCtwasBoundaryRegions <- function( saDf = saDf, runResult = runResult ) - if (keepSnps) { - snpRow <- .ctwasSnpRow( - gwasStudy, - method, - jointStr, - fmDf, - saDf, - runResult - ) - if (!is.null(snpRow)) { - rows <- c(rows, list(snpRow)) - } + snpRow <- if (!keepSnps) { + NULL + } else { + .ctwasSnpRow(gwasStudy, method, jointStr, fmDf, saDf, runResult) } + rows <- c(contextRows, compact(list(snpRow))) rows } @@ -2004,8 +2188,8 @@ mergeCtwasBoundaryRegions <- function( if (is.null(zSnp) || is.null(zSnp$study)) { return(NA_character_) } - s <- unique(as.character(zSnp$study)) - s <- s[!is.na(s) & str_length(s) > 0L] + allStudies <- unique(as.character(zSnp$study)) + s <- allStudies[!is.na(allStudies) & str_length(allStudies) > 0L] if (length(s) == 0L) { return(NA_character_) } @@ -2041,6 +2225,7 @@ mergeCtwasBoundaryRegions <- function( m } +#' @importFrom checkmate assertFlag #' @title Structure a granular cTWAS finemap result as a CtwasResult #' @description Decompose the raw list returned by #' \code{\link{finemapCtwasRegions}} (optionally after @@ -2063,6 +2248,7 @@ mergeCtwasBoundaryRegions <- function( #' asCtwasResult(ctwasFinemapExample) #' @export asCtwasResult <- function(finemapResult, keepSnps = FALSE) { + assertFlag(keepSnps) gwasStudy <- .ctwasGwasStudyFromZSnp(finemapResult$z_snp) method <- .ctwasMethodFromWeights(finemapResult$weights) rows <- .ctwasRunToRows( @@ -2087,9 +2273,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { } # Row subset carries every column forward (joint* / region / ...); the old # hand-listed rebuild silently dropped them. - out <- tw[keep, ] - out@ldSketch <- getLdSketch(tw) - out + methods::initialize(tw[keep, ], ldSketch = getLdSketch(tw)) } # Build the per-variant Z data.frame ctwas expects from a GwasSumStats. @@ -2131,31 +2315,45 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (length(m$idxA) == 0L) { return(zSnp) } - zSnp$id[m$idxA] <- as.character(panelIds)[m$idxB] + relabelled <- mutate( + zSnp, + id = replace(.data$id, m$idxA, as.character(panelIds)[m$idxB]) + ) flip <- m$idxA[m$sign < 0] - if (length(flip) > 0L) { - zSnp$z[flip] <- -zSnp$z[flip] - swapped <- zSnp$A1[flip] - zSnp$A1[flip] <- zSnp$A2[flip] - zSnp$A2[flip] <- swapped - } - zSnp + if (length(flip) == 0L) { + return(relabelled) + } + # A swapped variant counts the other allele: negate z and exchange the + # allele columns. Both replacements read the ORIGINAL frame, so the pair + # swaps rather than each taking the other's already-swapped value. + mutate( + relabelled, + z = replace(.data$z, flip, -relabelled$z[flip]), + A1 = replace(.data$A1, flip, relabelled$A2[flip]), + A2 = replace(.data$A2, flip, relabelled$A1[flip]) + ) +} + +# @noRd +.ctwasZSnpPiece <- function(i, gwasSumStats) { + df <- .entryToSumstatDf(gwasSumStats[[i]], keepChrPrefix = FALSE) + tibble( + id = df$variant_id, + chrom = as.integer(df$chrom), + pos = df$pos, + A1 = df$A1, + A2 = df$A2, + z = df$z, + study = as.character(gwasSumStats$study)[[i]] + ) } .ctwasBuildZSnp <- function(gwasSumStats, panelIds) { - pieces <- list() - for (i in seq_len(nrow(gwasSumStats))) { - df <- .entryToSumstatDf(gwasSumStats[[i]], keepChrPrefix = FALSE) - pieces[[i]] <- tibble( - id = df$variant_id, - chrom = as.integer(df$chrom), - pos = df$pos, - A1 = df$A1, - A2 = df$A2, - z = df$z, - study = as.character(gwasSumStats$study)[[i]] - ) - } + pieces <- map( + seq_len(nrow(gwasSumStats)), + .ctwasZSnpPiece, + gwasSumStats = gwasSumStats + ) .ctwasHarmonizeZToPanel(bind_rows(pieces), panelIds) } @@ -2163,6 +2361,31 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # (min/max BP per chromosome). The sketch is assumed to cover exactly # one block. # @noRd +# @noRd +.ctwasEntryPositions <- function(i, gss) { + gr <- gss[[i]] + list( + pos = as.integer(GenomicRanges::start(gr)), + chrs = as.character(GenomicRanges::seqnames(gr)) + ) +} + +# @noRd +.ctwasConcatInt <- function(pieces) { + if (length(pieces) == 0L) { + return(integer(0)) + } + list_c(pieces) +} + +# @noRd +.ctwasConcatChr <- function(pieces) { + if (length(pieces) == 0L) { + return(character(0)) + } + list_c(pieces) +} + .ctwasBuildSingleRegionInfo <- function(regionId, gss) { # Derive the block's [start, stop] from the GWAS variants actually in this # block (the GwasSumStats entry GRanges) -- NOT the LD sketch. When many @@ -2171,13 +2394,9 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # would collapse to the same whole-chromosome [start, stop] and every SNP # would be assigned to every region (inflating SNP group_size N-fold and # diluting the gene prior to ~0). - pos <- integer(0) - chrs <- character(0) - for (i in seq_len(nrow(gss))) { - gr <- gss[[i]] - pos <- c(pos, as.integer(GenomicRanges::start(gr))) - chrs <- c(chrs, as.character(GenomicRanges::seqnames(gr))) - } + entries <- map(seq_len(nrow(gss)), .ctwasEntryPositions, gss = gss) + pos <- .ctwasConcatInt(map(entries, "pos")) + chrs <- .ctwasConcatChr(map(entries, "chrs")) # Emptiness is checked FIRST: `pos` and `chrs` are filled from the same # GRanges in the same loop, so an empty block has zero chromosomes too, # and the chromosome check below would report it as "spans multiple @@ -2262,9 +2481,11 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { seq_len(nrow(snpInfoCtwas)), meanImpute = TRUE ) - R <- computeLd(geno, method = "sample") snpIds <- snpInfoCtwas$id - dimnames(R) <- list(snpIds, snpIds) + R <- `dimnames<-`( + computeLd(geno, method = "sample"), + list(snpIds, snpIds) + ) variance <- set_names(apply(geno, 2, stats::var, na.rm = TRUE), snpIds) list(R = R, snpInfo = snpInfoCtwas, variance = variance) } @@ -2281,7 +2502,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # Returns NULL when the entry has no variants in common with the panel. # @noRd .ctwasHarmonizeWeights <- function(origVids, origW, refVariants) { - parsed <- tryCatch(parseVariantId(origVids), error = function(e) NULL) + parsed <- try_fetch(parseVariantId(origVids), error = function(cnd) NULL) if (is.null(parsed) || nrow(parsed) == 0L) { return(NULL) } @@ -2293,7 +2514,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { w = as.numeric(origW), origIdx = seq_along(origVids) ) - res <- tryCatch( + res <- try_fetch( harmonizeAlleles( targetData = targetDf, refVariants = refVariants, @@ -2302,7 +2523,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { removeUnmatched = TRUE, removeStrandAmbiguous = TRUE ), - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(res)) { return(NULL) @@ -2343,10 +2564,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) { # Fields are READ with `[[`: `$` on a list falls back to prefix matching, # so `fits$mu` would silently return `mu2` on a fit that has no `mu`. - alpha <- fits[["alpha"]] + rawAlpha <- fits[["alpha"]] mu <- fits[["mu"]] xCol <- fits[["X_column_scale_factors"]] - if (is.null(alpha) || is.null(mu) || is.null(xCol)) { + if (is.null(rawAlpha) || is.null(mu) || is.null(xCol)) { return(NULL) } # susieInf / susieAsh carry an infinitesimal term: coef.susie is @@ -2357,7 +2578,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (!is.null(fits[["theta"]]) || !is.null(fits[["omega_weights"]])) { return(NULL) } - alpha <- as.matrix(alpha) + alpha <- as.matrix(rawAlpha) if ( ncol(alpha) != length(origVids) || ncol(mu) != length(origVids) || @@ -2369,16 +2590,16 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { } # Per-variant sign flip applied by allele harmonization. NaN signs # (origW == 0) default to +1. - signFlip <- sign(harmonizedW / origW[keptIdx]) - signFlip[!is.finite(signFlip)] <- 1 + rawSign <- sign(harmonizedW / origW[keptIdx]) + signFlip <- replace(rawSign, !is.finite(rawSign), 1) newAlpha <- .ctwasRenormAlpha(alpha, keptIdx) if (is.null(newAlpha)) { return(NULL) } muSub <- sweep(mu[, keptIdx, drop = FALSE], 2L, signFlip, `*`) - xColSub <- xCol[keptIdx] + rawScale <- xCol[keptIdx] # Guard against zero scale factors (shouldn't happen in practice). - xColSub[xColSub == 0] <- 1 + xColSub <- replace(rawScale, rawScale == 0, 1) as.numeric(colSums(newAlpha * muSub) / xColSub) } @@ -2465,11 +2686,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { twasWeights = twasWeights, ctx = ctx )) - out <- list() - for (g in genes) { - out[[g$key]] <- g$entry - } - out + # Later genes overwrite an earlier one sharing a key, which is what the + # `out[[g$key]] <- ...` loop did. + keyed <- set_names(map(genes, "entry"), map_chr(genes, "key")) + keyed[!duplicated(names(keyed), fromLast = TRUE)] } # Panel variant info in the (chrom/pos/A2/A1/variant_id) frame harmonizeAlleles @@ -2538,33 +2758,32 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # genotype variance from the LD panel)). Returns the adjusted weight vector. # @noRd .ctwasAdjustGeneWeights <- function(parts, aligned, ldPanel) { - w <- aligned$w fits <- .rowFits(parts) shrank <- length(aligned$keptIdx) < length(aligned$origVids) - if (.ctwasIsSusieFit(fits) && shrank) { - renorm <- .ctwasRenormalizeSusieWeights( + # A NULL renormalization means the fit could not be re-keyed onto the + # kept variants, so the harmonized weights stand as they are. + renorm <- if (.ctwasIsSusieFit(fits) && shrank) { + .ctwasRenormalizeSusieWeights( fits, origVids = aligned$origVids, origW = aligned$origW, keptIdx = aligned$keptIdx, - harmonizedW = w + harmonizedW = aligned$w ) - if (!is.null(renorm)) { - w <- renorm - } } - if (!.rowStandardized(parts)) { - varLookup <- ldPanel$variance[aligned$vids] - if (anyNA(varLookup)) { - msg <- glue( - ".ctwasBuildWeights: missing genotype variance for ", - "{sum(is.na(varLookup))} variant(s) in the LD panel." - ) - abort(msg) - } - w <- w * sqrt(varLookup) + renormalized <- renorm %||% aligned$w + if (.rowStandardized(parts)) { + return(renormalized) } - w + varLookup <- ldPanel$variance[aligned$vids] + if (anyNA(varLookup)) { + msg <- glue( + ".ctwasBuildWeights: missing genotype variance for ", + "{sum(is.na(varLookup))} variant(s) in the LD panel." + ) + abort(msg) + } + renormalized * sqrt(varLookup) } # The ctwas per-gene weight entry (weight matrix, LD submatrix, chrom/BP span, @@ -2698,17 +2917,18 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (is.null(fineMappingResult)) { return(NULL) } - selectors <- list(study = study, method = method) - if (is_in("context", .tupleColumnNames(fineMappingResult))) { - selectors$context <- context - } - if (is_in("trait", .tupleColumnNames(fineMappingResult))) { - selectors$trait <- trait - } + cols <- .tupleColumnNames(fineMappingResult) + selectors <- c( + list(study = study, method = method), + compact(list( + context = if (is_in("context", cols)) context, + trait = if (is_in("trait", cols)) trait + )) + ) selArgs <- c(list(fineMappingResult), selectors) - entry <- tryCatch( + entry <- try_fetch( exec(getFineMappingResult, !!!selArgs), - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(entry)) { return(NULL) @@ -2729,25 +2949,39 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # `_` where idx == 0 means "not in any CS"; cs_95_purity (when # present) broadcasts one purity value across a CS's rows. # @noRd +# One credible set's member variants and its purity. +# @noRd +.ctwasCsEntry <- function(k, tl, csIdx, keepIdx) { + inCs <- csIdx == k & keepIdx + purity <- if (is_in("cs_95_purity", names(tl))) { + as.numeric(tl$cs_95_purity[which(inCs)[1L]]) + } else { + NA_real_ + } + list(members = as.character(tl$variant_id)[inCs], purity = purity) +} + .ctwasCsMembership <- function(tl) { - csMembers <- list() - csPurity <- numeric(0) if (!is_in("cs_95", names(tl))) { - return(list(csMembers = csMembers, csPurity = csPurity)) + return(list(csMembers = list(), csPurity = numeric(0))) } csIdx <- suppressWarnings(as.integer(str_remove(tl$cs_95, "^.*_"))) keepIdx <- !is.na(csIdx) & csIdx > 0L - for (k in sort(unique(csIdx[keepIdx]))) { - inCs <- csIdx == k & keepIdx - csMembers[[length(csMembers) + 1L]] <- as.character(tl$variant_id)[inCs] - p <- if (is_in("cs_95_purity", names(tl))) { - as.numeric(tl$cs_95_purity[which(inCs)[1L]]) + entries <- map( + sort(unique(csIdx[keepIdx])), + .ctwasCsEntry, + tl = tl, + csIdx = csIdx, + keepIdx = keepIdx + ) + list( + csMembers = map(entries, "members"), + csPurity = if (length(entries) == 0L) { + numeric(0) } else { - NA_real_ + map_dbl(entries, "purity") } - csPurity <- c(csPurity, p) - } - list(csMembers = csMembers, csPurity = csPurity) + ) } # Apply the four trimCtwasVariants filters to one gene's (vids, w) @@ -2777,30 +3011,34 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # Step 1: magnitude. if (twasWeightCutoff > 0) { magKeep <- !is.na(w) & abs(w) >= twasWeightCutoff - vids <- vids[magKeep] - w <- w[magKeep] - if (length(vids) == 0L) { + keptVids <- vids[magKeep] + keptW <- w[magKeep] + if (length(keptVids) == 0L) { return(NULL) } + } else { + keptVids <- vids + keptW <- w } # Steps 2-3: PIP / CS rescue (only when fineMappingResult was passed). # Relabel first: the auxiliaries are keyed in the fine-mapping result's # frame, the vids in the panel's, and every join from here on is exact. - finemapAux <- .ctwasRelabelFinemapAux(finemapAux, vids) - mustKeep <- .ctwasMustKeep(vids, finemapAux, csMinCor, minPipCutoff) + finemapAux <- .ctwasRelabelFinemapAux(finemapAux, keptVids) + mustKeep <- .ctwasMustKeep(keptVids, finemapAux, csMinCor, minPipCutoff) # Step 4: cap, keeping must-keep variants first. - if (length(vids) > maxNumVariants && is.finite(maxNumVariants)) { - capped <- .ctwasCapVariants( - vids, - w, + capping <- length(keptVids) > maxNumVariants && is.finite(maxNumVariants) + capped <- if (!capping) { + list(vids = keptVids, w = keptW) + } else { + .ctwasCapVariants( + keptVids, + keptW, mustKeep, finemapAux, maxNumVariants ) - vids <- capped$vids - w <- capped$w } - list(vids = vids, w = w) + list(vids = capped$vids, w = capped$w) } # Move a set of variant ids into the frame `vids` uses, leaving ids with no @@ -2811,10 +3049,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { return(ids) } m <- .ctwasMatchToPanel(ids, vids) - if (length(m$idxA) > 0L) { - ids[m$idxA] <- vids[m$idxB] + if (length(m$idxA) == 0L) { + return(ids) } - ids + replace(ids, m$idxA, vids[m$idxB]) } # Relabel a gene's fine-mapping auxiliaries into the weight/panel frame. @@ -2834,63 +3072,78 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (is.null(finemapAux)) { return(NULL) } - if (!is.null(finemapAux$pip)) { - names(finemapAux$pip) <- .ctwasRelabelIds( - names(finemapAux$pip), - vids + relabelled <- if (is.null(finemapAux$pip)) { + finemapAux + } else { + list_assign( + finemapAux, + pip = set_names( + finemapAux$pip, + .ctwasRelabelIds(names(finemapAux$pip), vids) + ) ) } - if (length(finemapAux$csMembers) > 0L) { - finemapAux$csMembers <- map( - finemapAux$csMembers, - .ctwasRelabelIds, - vids = vids - ) + if (length(finemapAux$csMembers) == 0L) { + return(relabelled) } - finemapAux + list_assign( + relabelled, + csMembers = map(finemapAux$csMembers, .ctwasRelabelIds, vids = vids) + ) } # Variants that must survive the cap: members of any high-purity (>= csMinCor) # credible set, plus any with PIP > minPipCutoff. Empty when no finemapAux. # @noRd +# Variants rescued by credible set `k`, when that set is pure enough. +# @noRd +.ctwasCsRescued <- function(k, finemapAux, vids, csMinCor) { + if (is.na(finemapAux$csPurity[k]) || finemapAux$csPurity[k] < csMinCor) { + return(character(0)) + } + intersect(finemapAux$csMembers[[k]], vids) +} + .ctwasMustKeep <- function(vids, finemapAux, csMinCor, minPipCutoff) { - mustKeep <- character(0) if (is.null(finemapAux)) { - return(mustKeep) - } - if (length(finemapAux$csMembers) > 0L && csMinCor > 0) { - for (k in seq_along(finemapAux$csMembers)) { - if ( - !is.na(finemapAux$csPurity[k]) && - finemapAux$csPurity[k] >= csMinCor - ) { - mustKeep <- union( - mustKeep, - intersect(finemapAux$csMembers[[k]], vids) - ) - } - } + return(character(0)) + } + fromCs <- if (length(finemapAux$csMembers) > 0L && csMinCor > 0) { + map( + seq_along(finemapAux$csMembers), + .ctwasCsRescued, + finemapAux = finemapAux, + vids = vids, + csMinCor = csMinCor + ) + } else { + list() } - if (!is.null(finemapAux$pip) && minPipCutoff > 0) { + fromPip <- if (!is.null(finemapAux$pip) && minPipCutoff > 0) { hits <- names(finemapAux$pip)[finemapAux$pip > minPipCutoff] - mustKeep <- union(mustKeep, intersect(hits, vids)) + intersect(hits, vids) + } else { + character(0) } - mustKeep + # union() folded over the pieces, so each variant appears once and in + # first-rescued order -- the same thing the repeated unions produced. + reduce(c(fromCs, list(fromPip)), union, .init = character(0)) } # Cap to maxNumVariants: must-keep variants first, then fill by descending PIP # (falling back to |w| for variants the PIP table doesn't cover). # @noRd .ctwasCapVariants <- function(vids, w, mustKeep, finemapAux, maxNumVariants) { - priorities <- if (!is.null(finemapAux) && !is.null(finemapAux$pip)) { + fromPip <- if (!is.null(finemapAux) && !is.null(finemapAux$pip)) { unname(finemapAux$pip[vids]) } else { NULL } - if (is.null(priorities) || all(is.na(priorities))) { - priorities <- abs(w) + # No usable PIPs at all -> rank on |weight|; otherwise fill only the gaps. + priorities <- if (is.null(fromPip) || all(is.na(fromPip))) { + abs(w) } else { - priorities[is.na(priorities)] <- abs(w)[is.na(priorities)] + replace(fromPip, is.na(fromPip), abs(w)[is.na(fromPip)]) } isMust <- is_in(vids, mustKeep) ord <- order(!isMust, -priorities) @@ -2945,9 +3198,15 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { return(payload) } keyMap <- set_names(resolved, stored) - payload$LD_map$LD_file <- unname(resolved) - payload$LD_map$SNP_file <- unname(resolved) - .ctwasRekeyLdLoaders(payload, keyMap) + rekeyed <- list_assign( + payload, + LD_map = list_assign( + payload$LD_map, + LD_file = unname(resolved), + SNP_file = unname(resolved) + ) + ) + .ctwasRekeyLdLoaders(rekeyed, keyMap) } # Only "pecotmr://" tokens move; an ordinary path is the caller's own and is @@ -2969,10 +3228,15 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { return(payload) } hit <- is_in(names(panels), names(keyMap)) - names(panels)[hit] <- unname(keyMap[names(panels)[hit]]) - payload$LD_loader_fun <- .ctwasMultiBlockLdLoader(panels) - payload$snpinfo_loader_fun <- .ctwasMultiBlockSnpInfoLoader(panels) - payload + rekeyed <- `names<-`( + panels, + replace(names(panels), hit, unname(keyMap[names(panels)[hit]])) + ) + list_assign( + payload, + LD_loader_fun = .ctwasMultiBlockLdLoader(rekeyed), + snpinfo_loader_fun = .ctwasMultiBlockSnpInfoLoader(rekeyed) + ) } # The panel cache the loader closures were built over, or NULL when the @@ -2983,11 +3247,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (!is.function(loader)) { return(NULL) } - env <- environment(loader) - if (is.null(env) || !exists("ldPanelsByRegion", envir = env)) { - return(NULL) - } - get("ldPanelsByRegion", envir = env) + attr(loader, "ldPanelsByRegion") } # Multi-block LD loader for ctwas. ctwas invokes @@ -2996,7 +3256,8 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # `LD_map$LD_file`) into the cached per-sketch ldPanel. # @noRd .ctwasMultiBlockLdLoader <- function(ldPanelsByRegion) { - function(LD_file, ...) { + force(ldPanelsByRegion) + fn <- function(LD_file, ...) { panel <- ldPanelsByRegion[[LD_file]] if (is.null(panel)) { msg <- glue( @@ -3007,11 +3268,16 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { } panel$R } + # Published explicitly so .ctwasCachedPanels can recover the cache from a + # loader we built, instead of looking the name up inside the closure's + # environment. + `attr<-`(fn, "ldPanelsByRegion", ldPanelsByRegion) } # Multi-block SNP-info loader for ctwas. Mirrors the LD loader. # @noRd .ctwasMultiBlockSnpInfoLoader <- function(ldPanelsByRegion) { + force(ldPanelsByRegion) function(LD_file, ...) { panel <- ldPanelsByRegion[[LD_file]] if (is.null(panel)) { @@ -3061,15 +3327,22 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # the block's GWAS variants (intersected against the cached panel) so # snp_map[[region_id]] is sized to the block, not the whole panel. # @noRd -.ctwasSnpInfoForGwasBlock <- function(gwasSumStats, panelSnpInfo) { - blockIds <- character(0) - for (i in seq_len(nrow(gwasSumStats))) { - mc <- S4Vectors::mcols(gwasSumStats[[i]]) - if (is_in("SNP", colnames(mc))) { - blockIds <- c(blockIds, as.character(mc$SNP)) - } +# One entry's variant ids, or none when it does not carry a SNP column. +# @noRd +.ctwasEntrySnpIds <- function(i, gwasSumStats) { + mc <- S4Vectors::mcols(gwasSumStats[[i]]) + if (!is_in("SNP", colnames(mc))) { + return(character(0)) } - blockIds <- unique(blockIds) + as.character(mc$SNP) +} + +.ctwasSnpInfoForGwasBlock <- function(gwasSumStats, panelSnpInfo) { + blockIds <- unique(.ctwasConcatChr(map( + seq_len(nrow(gwasSumStats)), + .ctwasEntrySnpIds, + gwasSumStats = gwasSumStats + ))) if (length(blockIds) == 0L) { return(panelSnpInfo[FALSE, , drop = FALSE]) } diff --git a/R/fineMappingPipeline.R b/R/fineMappingPipeline.R index bbdd5a69..039fd816 100644 --- a/R/fineMappingPipeline.R +++ b/R/fineMappingPipeline.R @@ -467,29 +467,10 @@ setGeneric("fineMappingPipeline", function(data, ...) { ) abort(msg) } - if (is.character(methods)) { - tokens <- unique(methods) - methodArgs <- set_names(rep(list(list()), length(tokens)), tokens) + parsed <- if (is.character(methods)) { + .fmMethodsFromTokens(methods) } else if (is.list(methods)) { - if (is.null(names(methods)) || any(names(methods) == "")) { - msg <- glue( - "fineMappingPipeline: when `methods` is a list it must be ", - "named (one entry per method token)." - ) - abort(msg) - } - nonListChild <- !map_lgl(methods, is.list) - if (any(nonListChild)) { - badNames <- str_flatten(names(methods)[nonListChild], ", ") - msg <- glue( - "fineMappingPipeline: each entry of the `methods` list must ", - "itself be a list of named kwargs (got non-list value ", - "for: {badNames})." - ) - abort(msg) - } - tokens <- unique(names(methods)) - methodArgs <- methods[tokens] + .fmMethodsFromKwargs(methods) } else { cls <- class(methods)[[1L]] msg <- glue( @@ -498,8 +479,49 @@ setGeneric("fineMappingPipeline", function(data, ...) { ) abort(msg) } - methodArgs <- .fmSeedSusieDefaults(methodArgs, tokens, L, Lgreedy) - list(tokens = tokens, methodArgs = methodArgs) + list( + tokens = parsed$tokens, + methodArgs = .fmSeedSusieDefaults( + parsed$methodArgs, + parsed$tokens, + L, + Lgreedy + ) + ) +} + +# A bare character vector of tokens: every token gets empty kwargs. +# @noRd +.fmMethodsFromTokens <- function(methods) { + tokens <- unique(methods) + list( + tokens = tokens, + methodArgs = set_names(rep(list(list()), length(tokens)), tokens) + ) +} + +# A named list of = entries. +# @noRd +.fmMethodsFromKwargs <- function(methods) { + if (is.null(names(methods)) || any(names(methods) == "")) { + msg <- glue( + "fineMappingPipeline: when `methods` is a list it must be ", + "named (one entry per method token)." + ) + abort(msg) + } + nonListChild <- !map_lgl(methods, is.list) + if (any(nonListChild)) { + badNames <- str_flatten(names(methods)[nonListChild], ", ") + msg <- glue( + "fineMappingPipeline: each entry of the `methods` list must ", + "itself be a list of named kwargs (got non-list value ", + "for: {badNames})." + ) + abort(msg) + } + tokens <- unique(names(methods)) + list(tokens = tokens, methodArgs = methods[tokens]) } # SuSiE-family fit defaults live here (the single source of truth), not in CLI @@ -507,15 +529,35 @@ setGeneric("fineMappingPipeline", function(data, ...) { # already set them. # @noRd .fmSeedSusieDefaults <- function(methodArgs, tokens, L, Lgreedy) { - for (tk in intersect(tokens, c("susie", "susieInf", "susieAsh"))) { - if (is.null(methodArgs[[tk]][["L"]])) { - methodArgs[[tk]][["L"]] <- L - } - if (is.null(methodArgs[[tk]][["L_greedy"]])) { - methodArgs[[tk]][["L_greedy"]] <- Lgreedy - } - } - methodArgs + seeded <- intersect(tokens, c("susie", "susieInf", "susieAsh")) + if (length(seeded) == 0L) { + return(methodArgs) + } + list_assign( + methodArgs, + !!!set_names( + map( + seeded, + .fmSeedTokenDefaults, + methodArgs = methodArgs, + L = L, + Lgreedy = Lgreedy + ), + seeded + ) + ) +} + +# One token's kwargs with L / L_greedy filled in where the caller left them +# unset. A token with no kwargs at all still gets the defaults. +# @noRd +.fmSeedTokenDefaults <- function(tk, methodArgs, L, Lgreedy) { + args <- methodArgs[[tk]] %||% list() + list_assign( + args, + L = args[["L"]] %||% L, + L_greedy = args[["L_greedy"]] %||% Lgreedy + ) } @@ -703,19 +745,22 @@ setGeneric("fineMappingPipeline", function(data, ...) { if (!is(fineMappingResult, "GwasFineMappingResult")) { return(NULL) } - idx <- .matchTupleRows( + matched <- .matchTupleRows( fineMappingResult, list(study = study, method = method) ) - if (length(idx) == 0L) { + if (length(matched) == 0L) { return(NULL) } - if (length(idx) > 1L) { - keys <- .rtlRangeKeys(fineMappingResult)[idx] - idx <- idx[keys == blockId] - if (length(idx) == 0L) { - return(NULL) - } + # Several rows share (study, method) when the study was split into blocks; + # the block key picks the one this lookup wants. + idx <- if (length(matched) == 1L) { + matched + } else { + matched[.rtlRangeKeys(fineMappingResult)[matched] == blockId] + } + if (length(idx) == 0L) { + return(NULL) } .fmrRowParts(fineMappingResult, idx[[1L]]) } @@ -837,12 +882,12 @@ setGeneric("fineMappingPipeline", function(data, ...) { # GWAS resume lookup using the GwasFineMappingResult (study, method, range) # identity; NULL when no compatible cache was supplied. # @noRd -.fmCacheLookupGwasResume <- function(p, st, tk, blockId) { +.fmCacheLookupGwasResume <- function(fineMappingResult, st, tk, blockId) { if ( - !is.null(p$fineMappingResult) && - is(p$fineMappingResult, "GwasFineMappingResult") + !is.null(fineMappingResult) && + is(fineMappingResult, "GwasFineMappingResult") ) { - .fmCacheLookupGwas(p$fineMappingResult, st, tk, blockId) + .fmCacheLookupGwas(fineMappingResult, st, tk, blockId) } else { NULL } @@ -851,11 +896,32 @@ setGeneric("fineMappingPipeline", function(data, ...) { # Fit the still-to-run RSS tokens for one GWAS region and return one row-record # per fitted token. # @noRd -.fmGwasFitRows <- function(p, gr, zn, st, blockId, toRun) { - z <- zn$z - names(z) <- zn$variantIds +.fmGwasFitRows <- function( + gr, + zn, + st, + blockId, + toRun, + ldSketch, + addSusieInf, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + verbose, + fullFit, + fullFitAlphaOnly, + includeAllCs, + serFallback, + rFiniteResolved, + rMismatch, + rssControl, + keepFullFit +) { + z <- set_names(zn$z, zn$variantIds) ldMat <- .ldFromSketch( - p$ldSketch, + ldSketch, zn$variantIds, label = "fineMappingPipeline" ) @@ -864,24 +930,24 @@ setGeneric("fineMappingPipeline", function(data, ...) { ldMat, zn$n, toRun, - p$addSusieInf, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$methodArgs, - p$verbose, + addSusieInf, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + verbose, label = glue("GWAS (study='{st}', region='{blockId}')"), af = .fmAfByVar(gr, zn$variantIds), nVar = zn$nVar, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs, - serFallback = p$serFallback, - rFinite = p$rFiniteResolved, - rMismatch = p$rMismatch, - rssControl = p$rssControl, - keepFullFit = p$keepFullFit + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + serFallback = serFallback, + rFinite = rFiniteResolved, + rMismatch = rMismatch, + rssControl = rssControl, + keepFullFit = keepFullFit ) map(names(ents), .fmGwasRowFor, st = st, blockId = blockId, ents = ents) } @@ -890,12 +956,37 @@ setGeneric("fineMappingPipeline", function(data, ...) { # tokens, or an empty set when the region was screened out. Returns # list(rows, skipped) so the caller sums the skip flags functionally. # @noRd -.fmGwasEntryRows <- function(i, p) { - st <- p$studyCol[[i]] - gr <- .collectionEntry(p$data, i) - skip <- .fmEntrySkipInfo(p$data, i) +.fmGwasEntryRows <- function( + i, + data, + studyCol, + tokens, + ldSketch, + verbose, + fineMappingResult, + mafCutoff, + macCutoff, + imissCutoff, + addSusieInf, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + fullFit, + fullFitAlphaOnly, + includeAllCs, + serFallback, + rFiniteResolved, + rMismatch, + rssControl, + keepFullFit +) { + st <- studyCol[[i]] + gr <- .collectionEntry(data, i) + skip <- .fmEntrySkipInfo(data, i) if (isTRUE(skip$skipped)) { - if (p$verbose >= 1) { + if (verbose >= 1) { reason <- skip$reason msg <- glue( "fineMappingPipeline(GwasSumStats): study='{st}' region ", @@ -908,11 +999,21 @@ setGeneric("fineMappingPipeline", function(data, ...) { zn <- .fmExtractZn( gr, glue("fineMappingPipeline(GwasSumStats): study='{st}'"), - ldSketch = p$ldSketch, - cutoffs = .panelCutoffs(p) + ldSketch = ldSketch, + cutoffs = .panelCutoffs( + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + ) ) blockId <- .fmGwasBlockId(gr) - lookups <- map(p$tokens, .fmGwasLookup, p = p, st = st, blockId = blockId) + lookups <- map( + tokens, + .fmGwasLookup, + fineMappingResult = fineMappingResult, + st = st, + blockId = blockId + ) cachedRows <- map( keep(lookups, .fmHasCached), .fmGwasRowFromLookup, @@ -923,28 +1024,79 @@ setGeneric("fineMappingPipeline", function(data, ...) { if (length(toRun) == 0L) { return(list(rows = cachedRows, skipped = FALSE)) } - computed <- .fmGwasFitRows(p, gr, zn, st, blockId, toRun) + computed <- .fmGwasFitRows( + gr, + zn, + st, + blockId, + toRun, + ldSketch = ldSketch, + addSusieInf = addSusieInf, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + verbose = verbose, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + serFallback = serFallback, + rFiniteResolved = rFiniteResolved, + rMismatch = rMismatch, + rssControl = rssControl, + keepFullFit = keepFullFit + ) list(rows = c(cachedRows, computed), skipped = FALSE) } # Fit the still-to-run RSS tokens for one QtlSumStats entry and return one # row-record per fitted token. # @noRd -.fmRssFitRows <- function(p, i, st, ctx, tr, toRun) { - entry <- .collectionEntry(p$data, i) +.fmRssFitRows <- function( + i, + st, + ctx, + tr, + toRun, + data, + ldSketch, + addSusieInf, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + verbose, + fullFit, + fullFitAlphaOnly, + includeAllCs, + serFallback, + rFiniteResolved, + rMismatch, + rssControl, + keepFullFit, + mafCutoff, + macCutoff, + imissCutoff +) { + entry <- .collectionEntry(data, i) zn <- .fmExtractZn( entry, glue( "fineMappingPipeline(QtlSumStats): entry {i} (study='{st}', ", "context='{ctx}', trait='{tr}')" ), - ldSketch = p$ldSketch, - cutoffs = .panelCutoffs(p) + ldSketch = ldSketch, + cutoffs = .panelCutoffs( + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + ) ) - z <- zn$z - names(z) <- zn$variantIds + z <- set_names(zn$z, zn$variantIds) ldMat <- .ldFromSketch( - p$ldSketch, + ldSketch, zn$variantIds, label = "fineMappingPipeline" ) @@ -953,24 +1105,24 @@ setGeneric("fineMappingPipeline", function(data, ...) { ldMat, zn$n, toRun, - p$addSusieInf, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$methodArgs, - p$verbose, + addSusieInf, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + verbose, label = glue("(study='{st}', context='{ctx}', trait='{tr}')"), af = .fmAfByVar(entry, zn$variantIds), nVar = zn$nVar, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs, - serFallback = p$serFallback, - rFinite = p$rFiniteResolved, - rMismatch = p$rMismatch, - rssControl = p$rssControl, - keepFullFit = p$keepFullFit + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + serFallback = serFallback, + rFinite = rFiniteResolved, + rMismatch = rMismatch, + rssControl = rssControl, + keepFullFit = keepFullFit ) map(names(ents), .fmQtlRowFor, st = st, ctx = ctx, tr = tr, ents = ents) } @@ -979,14 +1131,41 @@ setGeneric("fineMappingPipeline", function(data, ...) { # tokens remain to run and the entry was not screened out) freshly-fitted # tokens. Returns list(rows, skipped) so the caller sums the skip flags. # @noRd -.fmRssEntryRows <- function(i, p) { - st <- p$studyCol[i] - ctx <- p$contextCol[i] - tr <- p$traitCol[i] +.fmRssEntryRows <- function( + i, + studyCol, + contextCol, + traitCol, + univTokens, + fineMappingResult, + data, + ldSketch, + addSusieInf, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + verbose, + fullFit, + fullFitAlphaOnly, + includeAllCs, + serFallback, + rFiniteResolved, + rMismatch, + rssControl, + keepFullFit, + mafCutoff, + macCutoff, + imissCutoff +) { + st <- studyCol[i] + ctx <- contextCol[i] + tr <- traitCol[i] lookups <- map( - p$univTokens, + univTokens, .fmQtlLookup, - p = p, + fineMappingResult = fineMappingResult, st = st, ctx = ctx, tr = tr @@ -1002,9 +1181,9 @@ setGeneric("fineMappingPipeline", function(data, ...) { if (length(toRun) == 0L) { return(list(rows = cachedRows, skipped = FALSE)) } - skip <- .fmEntrySkipInfo(p$data, i) + skip <- .fmEntrySkipInfo(data, i) if (isTRUE(skip$skipped)) { - if (p$verbose >= 1) { + if (verbose >= 1) { reason <- skip$reason msg <- glue( "fineMappingPipeline(QtlSumStats): entry {i} ", @@ -1015,19 +1194,43 @@ setGeneric("fineMappingPipeline", function(data, ...) { } return(list(rows = cachedRows, skipped = TRUE)) } - computed <- .fmRssFitRows(p, i, st, ctx, tr, toRun) + computed <- .fmRssFitRows( + i, + st, + ctx, + tr, + toRun, + data = data, + ldSketch = ldSketch, + addSusieInf = addSusieInf, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + verbose = verbose, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + serFallback = serFallback, + rFiniteResolved = rFiniteResolved, + rMismatch = rMismatch, + rssControl = rssControl, + keepFullFit = keepFullFit, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + ) list(rows = c(cachedRows, computed), skipped = FALSE) } # Concatenate two same-class FineMappingResult collections row-wise, carrying # forward every column (delegates to the generic `.rbindCollections`). # @noRd +#' @importFrom checkmate assertClass .rbindFineMappingResult <- function(a, b, ldSketch = NULL) { - if (!is(a, "FineMappingResultBase") || !is(b, "FineMappingResultBase")) { - abort( - ".rbindFineMappingResult expects two FineMappingResultBase inputs." - ) - } + assertClass(a, "FineMappingResultBase") + assertClass(b, "FineMappingResultBase") # Carry forward every column (blockId / joint* / ...) and reconcile the # collection-level slots via the shared combine; the concrete class # (QTL vs GWAS) is preserved and checked there. @@ -1082,23 +1285,33 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) .resPickFlags <- function() { - out <- list() - # Walk up from the immediate caller; the public setMethod frame is - # where the user-facing args live. sys.frames()[[1]] is the global - # env so stop before that. + # Walk up from the immediate caller; the public setMethod frame is where + # the user-facing args live. Each flag takes its value from the first + # frame that supplies a non-NULL one -- assigning NULL into a list is a + # no-op, so the original loop kept searching past those too. frames <- sys.frames() - for (i in seq_along(frames)) { - fr <- frames[[i]] - for (nm in .resFlagNames) { - if ( - !is_in(nm, names(out)) && - exists(nm, envir = fr, inherits = FALSE) - ) { - out[[nm]] <- get(nm, envir = fr, inherits = FALSE) - } - } + compact(set_names( + map(.resFlagNames, .resFlagFromFrames, frames = frames), + .resFlagNames + )) +} + +# @noRd +.resFrameValue <- function(fr, nm) { + if (!exists(nm, envir = fr, inherits = FALSE)) { + return(NULL) } - out + get(nm, envir = fr, inherits = FALSE) +} + +# @noRd +.resFlagIsSupplied <- function(value) { + !is.null(value) +} + +# @noRd +.resFlagFromFrames <- function(nm, frames) { + detect(map(frames, .resFrameValue, nm = nm), .resFlagIsSupplied) } .fmResidPheno <- function(x, ...) { @@ -1121,6 +1334,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # sources whose entries already carry `af`). The branch mirrors the # `.fmResidGeno` call that built `X`: `region`-driven when a joint range is # given, else `traitId` + `cisWindow` for the cis window. +#' @importFrom rlang try_fetch .fmAfForX <- function( data, X, @@ -1134,7 +1348,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { if (!is(data, "QtlDataset")) { return(NULL) } - afAll <- tryCatch( + afAll <- try_fetch( if (is.null(region)) { getAf( data, @@ -1145,7 +1359,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { } else { getAf(data, region = region, samples = rownames(X)) }, - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(afAll) || length(afAll) == 0L) { return(NULL) @@ -1347,8 +1561,8 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { if (is.null(ddpm) || is.null(ddpm$U)) { return(.fmCanonicalPrior(fitParts$V, conditionNames, R)) } - w0Updated <- rescaleCovW0(fitParts$w0) - w0Updated <- w0Updated[is_in(names(w0Updated), names(ddpm$U))] + rescaled <- rescaleCovW0(fitParts$w0) + w0Updated <- rescaled[is_in(names(rescaled), names(ddpm$U))] if (length(w0Updated) == 0L) { return(.fmCanonicalPrior(fitParts$V, conditionNames, R)) } @@ -1363,6 +1577,27 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } +# Rows of a TwasWeights whose method is mr.mash and whose identity matches +# every axis the caller FIXED. A NULL axis means "do not filter on it". +# @noRd +.fmMrmashSelector <- function(twasWeights, study, trait, context) { + axes <- compact(list(study = study, trait = trait, context = context)) + reduce( + names(axes), + .fmMrmashNarrow, + twasWeights = twasWeights, + axes = axes, + .init = as.character(twasWeights$method) == "mrmash" + ) +} + +# `.tupleColumn()` not `[[`: on a RangedTupleList `[[` extracts an ELEMENT +# (the variant set), while the identity axes live in mcols. +# @noRd +.fmMrmashNarrow <- function(sel, axis, twasWeights, axes) { + sel & as.character(.tupleColumn(twasWeights, axis)) == axes[[axis]] +} + # Locate the retained mr.mash fit payload {dataDrivenPriorMatrices, w0, V} for # one (study, trait[, context]) inside a `TwasWeights` collection from a prior # mr.mash twasWeightsPipeline run (the producer side of the mvSuSiE data-driven @@ -1389,19 +1624,9 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { return(NULL) } # Each per-context mr.mash row of a joint group carries the SHARED joint - # fit, - # so the consumer matches the FIXED axes and leaves the jointed axis NULL - # (match-any). study/trait/context = NULL means "do not filter that axis". - sel <- as.character(twasWeights$method) == "mrmash" - if (!is.null(study)) { - sel <- sel & as.character(twasWeights$study) == study - } - if (!is.null(trait)) { - sel <- sel & as.character(twasWeights$trait) == trait - } - if (!is.null(context)) { - sel <- sel & as.character(twasWeights$context) == context - } + # fit, so the consumer matches the FIXED axes and leaves the jointed axis + # NULL (match-any). study/trait/context = NULL means "skip that axis". + sel <- .fmMrmashSelector(twasWeights, study, trait, context) for (i in which(sel)) { f <- getFits(.twrRowParts(twasWeights, i)) if (!is.null(f)) return(f) @@ -1425,16 +1650,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { if (is.null(twasWeights)) { return(NULL) } - sel <- as.character(twasWeights$method) == "mrmash" - if (!is.null(study)) { - sel <- sel & as.character(twasWeights$study) == study - } - if (!is.null(trait)) { - sel <- sel & as.character(twasWeights$trait) == trait - } - if (!is.null(context)) { - sel <- sel & as.character(twasWeights$context) == context - } + sel <- .fmMrmashSelector(twasWeights, study, trait, context) for (i in which(sel)) { cv <- getCvResult(.twrRowParts(twasWeights, i)) if (!is.null(cv) && !is.null(cv$foldFits)) return(cv) @@ -1462,33 +1678,61 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { foldFits <- mvCv$foldFits sp <- mvCv$samplePartition foldIds <- if (!is.null(sp)) sort(unique(sp$Fold)) else seq_along(foldFits) - out <- set_names(vector("list", length(foldIds)), as.character(foldIds)) - for (i in seq_along(foldIds)) { - # Match the fold fit by name ("fold_") when available, else by - # position. - nm <- str_c("fold_", foldIds[[i]]) - ff <- if (!is.null(names(foldFits)) && is_in(nm, names(foldFits))) { - foldFits[[nm]] - } else if (length(foldFits) >= i) { - foldFits[[i]] - } else { - NULL - } - if (is.null(ff)) { - next - } - out[[i]] <- if (!is.null(ff$w0)) { - .buildMvsusieReweightedPrior(ff, conditionNames, weightsTol) - } else { - .buildMvsusieReweightedPrior( - fullFitParts, - conditionNames, - weightsTol, - overrideU = ff$dataDrivenPriorMatrices - ) - } + # A fold with no fit keeps its NULL slot, so the result stays aligned + # with `foldIds` -- which is what `out[[i]] <- ...` left behind. + set_names( + map( + seq_along(foldIds), + .fmFoldPriorAt, + foldIds = foldIds, + foldFits = foldFits, + fullFitParts = fullFitParts, + conditionNames = conditionNames, + weightsTol = weightsTol + ), + as.character(foldIds) + ) +} + +# Fold `i`'s fit, matched by name ("fold_") when available, else by +# position. +# @noRd +.fmFoldFitAt <- function(i, foldIds, foldFits) { + nm <- str_c("fold_", foldIds[[i]]) + if (!is.null(names(foldFits)) && is_in(nm, names(foldFits))) { + return(foldFits[[nm]]) + } + if (length(foldFits) >= i) { + return(foldFits[[i]]) + } + NULL +} + +# Fold `i`'s reweighted mixture prior, or NULL when the fold has no fit. A +# fold that carries its own w0 defines the prior; otherwise the full-data fit +# does, with the fold's data-driven matrices substituted in. +# @noRd +.fmFoldPriorAt <- function( + i, + foldIds, + foldFits, + fullFitParts, + conditionNames, + weightsTol +) { + ff <- .fmFoldFitAt(i, foldIds, foldFits) + if (is.null(ff)) { + return(NULL) } - out + if (!is.null(ff$w0)) { + return(.buildMvsusieReweightedPrior(ff, conditionNames, weightsTol)) + } + .buildMvsusieReweightedPrior( + fullFitParts, + conditionNames, + weightsTol, + overrideU = ff$dataDrivenPriorMatrices + ) } # PCA-reduce a (samples x traits) phenotype matrix to its top `nPCs` principal @@ -1503,22 +1747,23 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { if (is.null(dim(Y)) || ncol(Y) < 2L) { return(NULL) } - Y <- Y[stats::complete.cases(Y), , drop = FALSE] - if (nrow(Y) < 2L) { + complete <- Y[stats::complete.cases(Y), , drop = FALSE] + if (nrow(complete) < 2L) { return(NULL) } - Y <- Y[, apply(Y, 2L, stats::var) > 0, drop = FALSE] - if (ncol(Y) < 2L) { + varying <- complete[, + apply(complete, 2L, stats::var) > 0, + drop = FALSE + ] + if (ncol(varying) < 2L) { return(NULL) } - scores <- stats::prcomp(Y, center = TRUE, scale. = TRUE)$x + scores <- stats::prcomp(varying, center = TRUE, scale. = TRUE)$x k <- min(as.integer(nPCs), ncol(scores)) if (k < 1L) { return(NULL) } - scores <- scores[, seq_len(k), drop = FALSE] - colnames(scores) <- str_c("topPC", seq_len(k)) - scores + `colnames<-`(scores[, seq_len(k), drop = FALSE], str_c("topPC", seq_len(k))) } # Per-column marginal-association z-scores of y on each column of X (univariate @@ -1556,23 +1801,22 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { if (sum(ok) < 2L || ncol(X) < 1L) { return(fallback) } - Xs <- X[ok, , drop = FALSE] - if (!is.double(Xs)) { - storage.mode(Xs) <- "double" - } # susieR needs double X + raw <- X[ok, , drop = FALSE] + # susieR needs a double X. + Xs <- if (is.double(raw)) raw else `storage.mode<-`(raw, "double") ys <- y[ok] metric <- scr$metric cutoff <- scr$cutoff if (metric == "absZ") { - z <- tryCatch(.marginalZ(Xs, ys), error = function(e) NULL) + z <- try_fetch(.marginalZ(Xs, ys), error = function(cnd) NULL) if (is.null(z)) { return(fallback) } return(any(abs(z) > cutoff, na.rm = TRUE)) } - fit <- tryCatch( + fit <- try_fetch( suppressMessages(susieR::susie(Xs, ys, L = 1L)), - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(fit)) { return(fallback) @@ -1678,21 +1922,65 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # max of the regions before it (a sequential offset fold, per cs_ # column). # @noRd -.fmRenumberCs <- function(tls, csCols) { - offsets <- set_names(integer(length(csCols)), csCols) - for (i in seq_along(tls)) { - tl <- tls[[i]] - for (cc in csCols) { - if (!is_in(cc, names(tl))) { - next - } - idx <- .fmCsIdx(tl[[cc]]) - tl[[cc]] <- .fmRelabelCs(tl[[cc]], offsets[[cc]]) - offsets[[cc]] <- offsets[[cc]] + max(c(0L, idx), na.rm = TRUE) - } - tls[[i]] <- tl +# The highest credible-set index table `tl` uses in column `cc`, or 0 when it +# has no such column. +# @noRd +.fmCsMaxIn <- function(tl, cc) { + if (!is_in(cc, names(tl))) { + return(0L) } - tls + max(c(0L, .fmCsIdx(tl[[cc]])), na.rm = TRUE) +} + +# How many credible sets precede each element, given per-element counts. +# @noRd +.fmExclusiveCumsum <- function(counts) { + cumsum(c(0L, counts))[seq_along(counts)] +} + +# @noRd +.fmColumnOffsets <- function(cc, tls) { + .fmExclusiveCumsum(map_int(tls, .fmCsMaxIn, cc = cc)) +} + +# @noRd +.fmTableHasCol <- function(cc, tl) { + is_in(cc, names(tl)) +} + +# @noRd +.fmRelabelColumn <- function(cc, tl, offsets, i) { + .fmRelabelCs(tl[[cc]], offsets[[cc]][[i]]) +} + +# @noRd +.fmRenumberTable <- function(i, tls, csCols, offsets) { + tl <- tls[[i]] + present <- keep(csCols, .fmTableHasCol, tl = tl) + if (length(present) == 0L) { + return(tl) + } + mutate( + tl, + !!!set_names( + map(present, .fmRelabelColumn, tl = tl, offsets = offsets, i = i), + present + ) + ) +} + +.fmRenumberCs <- function(tls, csCols) { + # A table's offset in a column is how many credible sets the tables + # before it contributed there -- a cumulative count, so it is known up + # front instead of being carried through the walk. + offsets <- set_names(map(csCols, .fmColumnOffsets, tls = tls), csCols) + map( + seq_along(tls), + .fmRenumberTable, + tls = tls, + csCols = csCols, + offsets = offsets + ) } @@ -1702,6 +1990,21 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # user did not set. User-supplied values always win over base, capability # defaults, and chain-derived args. Returns the merged list. # @noRd +# Split a merged argument list into the target's own formals plus a +# `methodArgs` remainder. Callers build one flat list (base args, capability +# defaults, user overrides); this routes each name to the right place, so a +# tool option reaches the tool and an unknown name errors at the call instead +# of vanishing. A target with no `methodArgs` formal gets the list unchanged. +# @noRd +.splitMethodArgs <- function(fn, args) { + fm <- names(formals(match.fun(fn))) + if (!is_in("methodArgs", fm)) { + return(args) + } + isFormal <- is_in(names(args), setdiff(fm, "methodArgs")) + c(args[isFormal], list(methodArgs = args[!isFormal])) +} + .fmMergeUserArgs <- function(baseArgs, token, userArgs = NULL) { if (is.null(userArgs)) { userArgs <- list() @@ -1713,13 +2016,15 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { list() } # Order matters: base < capability defaults < user overrides. - if (length(capDefaults) > 0L) { - baseArgs <- modifyList(baseArgs, capDefaults) + withCaps <- if (length(capDefaults) > 0L) { + list_modify(baseArgs, !!!compact(capDefaults)) + } else { + baseArgs } - if (length(userArgs) > 0L) { - baseArgs <- modifyList(baseArgs, userArgs) + if (length(userArgs) == 0L) { + return(withCaps) } - baseArgs + list_modify(withCaps, !!!compact(userArgs)) } @@ -1731,13 +2036,13 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # shared `.entryToSumstatDf` helper (R/sumstatsQc.R). # @noRd .fmExtractZn <- function(gr, label, ldSketch = NULL, cutoffs = NULL) { - df <- .entryToSumstatDf(gr, require = c("SNP", "Z", "N"), label = label) + allDf <- .entryToSumstatDf(gr, require = c("SNP", "Z", "N"), label = label) # Filtered HERE rather than at the LD build: z, the LD matrix and the # allele frequencies are all keyed off `variantIds`, so narrowing the id # set at its source keeps them aligned by construction instead of by three # subsetting steps staying in step with one another. - keep <- .panelKeepMask(df$variant_id, ldSketch, cutoffs, label) - df <- df[keep, , drop = FALSE] + keep <- .panelKeepMask(allDf$variant_id, ldSketch, cutoffs, label) + df <- allDf[keep, , drop = FALSE] list( variantIds = df$variant_id, z = df$z, @@ -1756,7 +2061,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # pipScreenReason); # an entry may also be empty for other reasons. Returns list(skipped, reason). .fmEntrySkipInfo <- function(data, i) { - ea <- tryCatch(getQcInfo(data)$entryAudit[[i]], error = function(e) NULL) + ea <- try_fetch(getQcInfo(data)$entryAudit[[i]], error = function(cnd) NULL) screened <- isTRUE(ea$pipScreenSkipped) entry <- .collectionEntry(data, i) empty <- is.null(entry) || length(entry) == 0L @@ -1840,6 +2145,29 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { NULL } +# The minimal fold-fit payload: exactly the fields the weight extractors +# read, so K folds x (study, context, trait) does not retain K full SuSiE fits. +# `trimFinemappingFit()` is the credible-set-driven trimmer for the fit stored +# on a row; a fold fit has no credible sets to key on and is only ever used to +# re-extract weights, so it keeps a smaller set. +# @noRd +.fmLeanFoldFit <- function(fit, token) { + if (is.null(fit)) { + return(NULL) + } + keep <- c( + "pip", + "alpha", + "mu", + "X_column_scale_factors", + "theta", + "coef", + "V" + ) + lean <- fit[intersect(keep, names(fit))] + `class<-`(lean, unique(c(token, class(fit)))) +} + # Per-fold univariate-susie-family weights (susie / susieInf / susieAsh). # @noRd .fmFoldWeightsSusie <- function(token, Xtr, Ytr, coverage, userArgs) { @@ -1857,9 +2185,8 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { susieInf = susieInfWeights(susieInfFit = fit), susieAsh = susieAshWeights(susieAshFit = fit) ) - w <- as.numeric(w) - names(w) <- colnames(Xtr) - .fmAsMat(w) + out <- .fmAsMat(set_names(as.numeric(w), colnames(Xtr))) + `attr<-`(out, "fit", .fmLeanFoldFit(fit, token)) } # Per-fold mvsusie weights. Reuses the data-driven reweighted prior + residual @@ -1878,16 +2205,15 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { mvPrior$priorVariance } ) - if (!is.null(mvPrior) && !is.null(mvPrior$residualVariance)) { - baseArgs$residual_variance <- mvPrior$residualVariance - } - mvArgs <- .fmMergeUserArgs(baseArgs, "mvsusie", userArgs) - fit <- exec(fitMvsusie, !!!mvArgs) - W <- as.matrix(mvsusieWeights(mvsusieFit = fit)) - if (is.null(rownames(W))) { - rownames(W) <- colnames(Xtr) - } - W + withPrior <- list_assign( + baseArgs, + !!!compact(list(residual_variance = mvPrior$residualVariance)) + ) + mvArgs <- .fmMergeUserArgs(withPrior, "mvsusie", userArgs) + fit <- exec(fitMvsusie, !!!.splitMethodArgs(fitMvsusie, mvArgs)) + raw <- as.matrix(mvsusieWeights(mvsusieFit = fit)) + W <- `rownames<-`(raw, rownames(raw) %||% colnames(Xtr)) + `attr<-`(W, "fit", .fmLeanFoldFit(fit, "mvsusie")) } # Per-fold fsusie weights. @@ -1898,9 +2224,14 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { "fsusie", userArgs ) - fit <- exec(fitFsusie, !!!fsArgs) + fit <- exec(fitFsusie, !!!.splitMethodArgs(fitFsusie, fsArgs)) W <- fsusieWeights(fsusieFit = fit, variantIds = colnames(Xtr)) - as.matrix(W) + out <- as.matrix(W) + # fSuSiE cannot be re-extracted from a trimmed fit, so the precomputed + # weight matrix rides along as `coef` the same way the row-level trimmer + # does it. + withCoef <- list_assign(fit, coef = out) + `attr<-`(out, "fit", .fmLeanFoldFit(withCoef, "fsusie")) } # Per-fold fine-mapping fit for the CV engine. `ctx` carries mvPrior, mvPriorCv, @@ -1924,32 +2255,70 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { } else { mvPrior } - weights <- list() - for (tk in tokens) { - weights[[.fmTwasMethodKey(tk)]] <- tryCatch( - .fmFoldWeights( - tk, - Xtr, - Ytr, - coverage, - methodArgs[[tk]], - pos, - mvPriorThisFold - ), - error = function(e) { - if (verbose >= 1) { - eMsg <- conditionMessage(e) - msg <- glue( - " CV fold {j}, method {tk} failed: {eMsg}", - .trim = FALSE - ) - inform(msg) - } - NULL + keys <- map_chr(tokens, .fmTwasMethodKey) + results <- map( + tokens, + .fmFoldTokenResult, + Xtr = Xtr, + Ytr = Ytr, + coverage = coverage, + methodArgs = methodArgs, + pos = pos, + mvPriorThisFold = mvPriorThisFold, + j = j, + verbose = verbose + ) + list( + weights = set_names(map(results, "weights"), keys), + fits = compact(set_names(map(results, "fit"), keys)) + ) +} + +# One token's fold result. The CV engine's fitFold contract is +# list(weights = matrix>, fits = fitted model>); the fold +# helpers attach their (lean) fit to the weight matrix, so it is split back +# out here rather than stripped in place. +# @noRd +.fmFoldTokenResult <- function( + tk, + Xtr, + Ytr, + coverage, + methodArgs, + pos, + mvPriorThisFold, + j, + verbose +) { + w <- try_fetch( + .fmFoldWeights( + tk, + Xtr, + Ytr, + coverage, + methodArgs[[tk]], + pos, + mvPriorThisFold + ), + error = function(cnd) { + if (verbose >= 1) { + eMsg <- conditionMessage(cnd) + msg <- glue( + " CV fold {j}, method {tk} failed: {eMsg}", + .trim = FALSE + ) + inform(msg) } - ) + NULL + } + ) + if (is.null(w)) { + return(list(weights = NULL, fit = NULL)) } - list(weights = weights, fits = list()) + list( + weights = `attr<-`(w, "fit", NULL), + fit = attr(w, "fit") + ) } # Cross-validate a homogeneous set of fine-mapping `tokens` over (X, Y) via the @@ -2000,12 +2369,30 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { fitFoldCtx = cvFitCtx, numThreads = numThreads, verbose = verbose, - seed = seed + seed = seed, + # Retained so twasWeightsCv can cross-validate a SuSiE-family method: + # those wrappers extract from a supplied fit and never refit, so the + # fold's own fit is the only thing that makes per-fold extraction + # possible. + retainFits = TRUE ) + # Recorded at the producer so a consumer can refuse fits trained on a + # different split; without it a mismatched partition would leak held-out + # samples into training and inflate the CV metrics. + foldFits <- if (is.null(res$foldFits)) { + NULL + } else { + `attr<-`( + res$foldFits, + "partitionKey", + .cvPartitionKey(res$samplePartition) + ) + } list( samplePartition = res$samplePartition, prediction = res$prediction, - performance = res$performance + performance = res$performance, + foldFits = foldFits ) } @@ -2025,10 +2412,24 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { list( samplePartition = cv$samplePartition, prediction = cv$prediction[pk], - performance = cv$performance[mk] + performance = cv$performance[mk], + foldFits = .fmSliceFoldFits(cv$foldFits, key) ) } +# One method's per-fold fits, keyed by fold, from the full CV payload. +# @noRd +.fmSliceFoldFits <- function(foldFits, key) { + if (is.null(foldFits) || length(foldFits) == 0L) { + return(NULL) + } + out <- map(foldFits, key) + if (all(map_lgl(out, is.null))) { + return(NULL) + } + `attr<-`(out, "partitionKey", attr(foldFits, "partitionKey")) +} + # Rebuild a FineMappingRow with a cvResult attached (the class is immutable). # @noRd .fmAttachCv <- function(entry, cvResult) { @@ -2049,17 +2450,24 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # `rg` is NULL, else the explicit region. Shared by the univariate and PCA # dispatch paths. # @noRd -.fmResidGenoBlock <- function(p, ctx, traitId, rg, samples) { +.fmResidGenoBlock <- function( + ctx, + traitId, + rg, + samples, + data, + cisWindow +) { if (is.null(rg)) { .fmResidGeno( - p$data, + data, contexts = ctx, traitId = traitId, - cisWindow = p$cisWindow, + cisWindow = cisWindow, samples = samples ) } else { - .fmResidGeno(p$data, contexts = ctx, region = rg, samples = samples) + .fmResidGeno(data, contexts = ctx, region = rg, samples = samples) } } @@ -2083,28 +2491,49 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # callers pass only the block-specific arguments (design, response, tokens, # addSusieInf, context label, trait/PC label, allele frequencies). # @noRd -.fmFitXBlockP <- function(p, X, y, tokens, addSusieInf, ctx, label, afVec) { - .fmFitXBlock( +.fmFitXBlockP <- function( + X, + y, + tokens, + addSusieInf, + ctx, + label, + afVec, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + verbose, + cvFolds, + cvThreads, + samplePartition, + seed, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { + .fmFitXBlock( X, y, tokens, addSusieInf, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$methodArgs, - p$verbose, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + verbose, ctx, label, - cvFolds = p$cvFolds, - cvThreads = p$cvThreads, - samplePartition = p$samplePartition, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, af = afVec, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs, - seed = p$seed + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + seed = seed ) } @@ -2112,9 +2541,39 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # Y, SER pre-screen, then .fmFitXBlock. Errors when too few shared samples # (a hard data problem), returns list() when the window screens out. # @noRd -.fmUnivBlockFit <- function(rg, p, ctx, tid, Y, toRun) { - X <- .fmResidGenoBlock(p, ctx, tid, rg, rownames(Y)) - common <- intersect(rownames(X), rownames(Y)) +.fmUnivBlockFit <- function( + rg, + ctx, + tid, + Y, + toRun, + data, + cisWindow, + screen, + addSusieInf, + verbose, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + cvFolds, + cvThreads, + samplePartition, + seed, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { + allX <- .fmResidGenoBlock( + ctx, + tid, + rg, + rownames(Y), + data = data, + cisWindow = cisWindow + ) + common <- intersect(rownames(allX), rownames(Y)) if (length(common) < 2L) { msg <- glue( "fineMappingPipeline: too few shared samples between ", @@ -2122,15 +2581,15 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) abort(msg) } - X <- X[common, , drop = FALSE] - y <- Y[common, , drop = FALSE] - if (ncol(y) > 1L) { - y <- y[, 1L, drop = TRUE] + X <- allX[common, , drop = FALSE] + yBlock <- Y[common, , drop = FALSE] + y <- if (ncol(yBlock) > 1L) { + yBlock[, 1L, drop = TRUE] } else { - y <- drop(y) + drop(yBlock) } - if (!.fmSerScreen(X, y, p$screen)) { - if (p$verbose >= 1) { + if (!.fmSerScreen(X, y, screen)) { + if (verbose >= 1) { msg <- glue( "Skipping (context='{ctx}', trait='{tid}'): SER ", "pre-screen found no signal above the cutoff." @@ -2140,24 +2599,77 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { return(list()) } afVec <- .fmAfForX( - p$data, + data, X, traitId = tid, region = rg, - cisWindow = p$cisWindow + cisWindow = cisWindow + ) + .fmFitXBlockP( + X, + y, + toRun, + addSusieInf, + ctx, + tid, + afVec, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + verbose = verbose, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs ) - .fmFitXBlockP(p, X, y, toRun, p$addSusieInf, ctx, tid, afVec) } # All univariate row-records for one (context, trait): cache hits, then (when # tokens remain) per-window fits merged per token. # @noRd -.fmUnivTraitRows <- function(tid, p, ctx) { - lookups <- map(p$univTokens, .fmUnivLookup, p = p, ctx = ctx, tid = tid) +.fmUnivTraitRows <- function( + tid, + ctx, + data, + study, + univTokens, + xRegions, + naAction, + fineMappingResult, + cisWindow, + screen, + addSusieInf, + verbose, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + cvFolds, + cvThreads, + samplePartition, + seed, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { + lookups <- map( + univTokens, + .fmUnivLookup, + fineMappingResult = fineMappingResult, + study = study, + ctx = ctx, + tid = tid + ) cachedRows <- map( keep(lookups, .fmHasCached), .fmUnivCachedRow, - p = p, + study = study, ctx = ctx, tid = tid ) @@ -2166,21 +2678,37 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { return(cachedRows) } Y <- .fmResidPheno( - p$data, + data, contexts = ctx, traitId = tid, - naAction = p$naAction + naAction = naAction ) blockEntries <- map( - p$xRegions, + xRegions, .fmUnivBlockFit, - p = p, ctx = ctx, tid = tid, + data = data, + cisWindow = cisWindow, + screen = screen, + addSusieInf = addSusieInf, + verbose = verbose, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, Y = Y, toRun = toRun ) - computed <- .fmMergeTokenRows(p$study, ctx, tid, toRun, blockEntries) + computed <- .fmMergeTokenRows(study, ctx, tid, toRun, blockEntries) c(cachedRows, computed) } @@ -2188,69 +2716,187 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # PC scores, SER pre-screen, then univariate-susie .fmFitXBlock. Returns # list() when too few shared samples or the window screens out (soft skip). # @noRd -.fmPcaBlockFit <- function(rg, p, ctx, traits, pcName, pcY, samples) { - X <- .fmResidGenoBlock(p, ctx, traits, rg, samples) +.fmPcaBlockFit <- function( + rg, + ctx, + traits, + pcName, + pcY, + samples, + data, + cisWindow, + screen, + addSusieInf, + verbose, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + cvFolds, + cvThreads, + samplePartition, + seed, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { + X <- .fmResidGenoBlock( + ctx, + traits, + rg, + samples, + data = data, + cisWindow = cisWindow + ) common <- intersect(rownames(X), names(pcY)) if (length(common) < 2L) { return(list()) } Xb <- X[common, , drop = FALSE] - if (!.fmSerScreen(Xb, pcY[common], p$screen)) { + if (!.fmSerScreen(Xb, pcY[common], screen)) { return(list()) } afVec <- .fmAfForX( - p$data, + data, Xb, traitId = traits, region = rg, - cisWindow = p$cisWindow + cisWindow = cisWindow + ) + .fmFitXBlockP( + Xb, + pcY[common], + "susie", + FALSE, + ctx, + pcName, + afVec, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + verbose = verbose, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs ) - .fmFitXBlockP(p, Xb, pcY[common], "susie", FALSE, ctx, pcName, afVec) } # Row-records for one PC pseudo-trait: a cache hit, else per-window fits merged # into the single "susie" token (trait = the PC name). # @noRd -.fmPcaScoreRows <- function(pcName, p, ctx, traits, scores) { - cached <- .fmCacheLookup(p$fineMappingResult, p$study, ctx, pcName, "susie") +.fmPcaScoreRows <- function( + pcName, + ctx, + traits, + scores, + fineMappingResult, + study, + xRegions, + data, + cisWindow, + screen, + addSusieInf, + verbose, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + cvFolds, + cvThreads, + samplePartition, + seed, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { + cached <- .fmCacheLookup(fineMappingResult, study, ctx, pcName, "susie") if (!is.null(cached)) { - return(list(.fmQtlRow(p$study, ctx, pcName, "susie", cached))) + return(list(.fmQtlRow(study, ctx, pcName, "susie", cached))) } pcY <- scores[, pcName] samples <- rownames(scores) blockEntries <- map( - p$xRegions, + xRegions, .fmPcaBlockFit, - p = p, ctx = ctx, traits = traits, pcName = pcName, pcY = pcY, - samples = samples + samples = samples, + data = data, + cisWindow = cisWindow, + screen = screen, + addSusieInf = addSusieInf, + verbose = verbose, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs ) - .fmMergeTokenRows(p$study, ctx, pcName, "susie", blockEntries) + .fmMergeTokenRows(study, ctx, pcName, "susie", blockEntries) } # All usePCA row-records for one context: PCA-reduce the multi-trait phenotype # and fine-map each top PC. A single-trait context (or one with no usable PC # scores) contributes nothing. # @noRd -.fmPcaContextRows <- function(ctx, p) { - traits <- p$perCtxTraits[[ctx]] +.fmPcaContextRows <- function( + ctx, + data, + study, + perCtxTraits, + nPCs, + naAction, + fineMappingResult, + xRegions, + cisWindow, + screen, + addSusieInf, + verbose, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + cvFolds, + cvThreads, + samplePartition, + seed, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { + traits <- perCtxTraits[[ctx]] if (length(traits) < 2L) { return(list()) } Yctx <- .fmResidPheno( - p$data, + data, contexts = ctx, traitId = traits, - naAction = p$naAction + naAction = naAction ) - scores <- .fmTopPcScores(Yctx, p$nPCs) + scores <- .fmTopPcScores(Yctx, nPCs) if (is.null(scores)) { return(list()) } - if (p$verbose >= 1) { + if (verbose >= 1) { nPc <- ncol(scores) nTr <- length(traits) msg <- glue( @@ -2262,10 +2908,29 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { list_flatten(map( colnames(scores), .fmPcaScoreRows, - p = p, ctx = ctx, traits = traits, - scores = scores + scores = scores, + fineMappingResult = fineMappingResult, + study = study, + xRegions = xRegions, + data = data, + cisWindow = cisWindow, + screen = screen, + addSusieInf = addSusieInf, + verbose = verbose, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs )) } @@ -2276,32 +2941,57 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # by the explicit-jointSpecification path and the auto-detected multivariate # path; only the spec and token arguments differ between them. # @noRd -.fmQdsJointDispatch <- function(p, jointSpec, tokens, methodArgs) { +.fmQdsJointDispatch <- function( + jointSpec, + tokens, + methodArgs, + data, + contexts, + traitId, + cisWindow, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + verbose, + xRegions, + twasWeights, + dataDrivenPriorWeightsCutoff, + cvFolds, + cvThreads, + samplePartition, + screen, + fineMappingResult, + fullFit, + fullFitAlphaOnly, + includeAllCs, + seed +) { .fmDispatchJointSpecsQtlDataset( jointSpec, - p$data, + data, tokens, - p$contexts, - p$traitId, - p$cisWindow, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$verbose, + contexts, + traitId, + cisWindow, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + verbose, methodArgs = methodArgs, - xRegions = p$xRegions, - twasWeights = p$twasWeights, - dataDrivenPriorWeightsCutoff = p$dataDrivenPriorWeightsCutoff, - cvFolds = p$cvFolds, - cvThreads = p$cvThreads, - samplePartition = p$samplePartition, - pipCutoffToSkip = p$screen, - fineMappingResult = p$fineMappingResult, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs, - seed = p$seed + xRegions = xRegions, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + pipCutoffToSkip = screen, + fineMappingResult = fineMappingResult, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + seed = seed ) } @@ -2309,24 +2999,40 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # copy of the dataset, and derive the X windows. Rejects the region + cisWindow # combination. Returns `p` extended with data / screen / xRegions. # @noRd -.fmQdsResolveInputs <- function(p) { +.fmQdsResolveInputs <- function( + data, + pipCutoffToSkip, + absZCutoffToSkip, + bfCutoffToSkip, + logBfCutoffToSkip, + mafCutoff, + macCutoff, + xvarCutoff, + imissCutoff, + keepIndel, + keepSamples, + keepVariants, + region, + cisWindow, + jointRegions +) { screen <- .resolveScreenMetric( - p$pipCutoffToSkip, - p$absZCutoffToSkip, - p$bfCutoffToSkip, - p$logBfCutoffToSkip + pipCutoffToSkip, + absZCutoffToSkip, + bfCutoffToSkip, + logBfCutoffToSkip ) data <- .qtlApplyFilterOverrides( - p$data, - p$mafCutoff, - p$macCutoff, - p$xvarCutoff, - p$imissCutoff, - p$keepIndel, - p$keepSamples, - p$keepVariants - ) - if (!is.null(p$region) && !is.null(p$cisWindow)) { + data, + mafCutoff, + macCutoff, + xvarCutoff, + imissCutoff, + keepIndel, + keepSamples, + keepVariants + ) + if (!is.null(region) && !is.null(cisWindow)) { msg <- glue( "fineMappingPipeline(QtlDataset): specify either `region` or ", "`cisWindow`, not both. `cisWindow` expands each trait's own ", @@ -2334,11 +3040,10 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) abort(msg) } - list_modify( - p, + list( data = data, screen = screen, - xRegions = .makeXRegions(p$region, p$jointRegions) + xRegions = .makeXRegions(region, jointRegions) ) } @@ -2347,43 +3052,106 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # token set). `exhaustedByJoint` flags the case where the explicit spec # consumed every method. # @noRd -.fmQdsResolveTokens <- function(p) { - parsedJointSpec <- parseJointSpecification(p$jointSpecification, p$data) - norm <- .fmNormalizeMethods(p$methods, L = p$L, Lgreedy = p$Lgreedy) - tokens <- norm$tokens - methodArgs <- norm$methodArgs - .fmCheckMethodCapabilities(tokens, "QtlDataset") - jointResult <- NULL +.fmQdsResolveTokens <- function( + jointSpecification, + methods, + L, + Lgreedy, + data, + contexts, + traitId, + cisWindow, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + verbose, + xRegions, + twasWeights, + dataDrivenPriorWeightsCutoff, + cvFolds, + cvThreads, + samplePartition, + screen, + fineMappingResult, + fullFit, + fullFitAlphaOnly, + includeAllCs, + seed +) { + parsedJointSpec <- parseJointSpecification(jointSpecification, data) + norm <- .fmNormalizeMethods(methods, L = L, Lgreedy = Lgreedy) + allTokens <- norm$tokens + allMethodArgs <- norm$methodArgs + .fmCheckMethodCapabilities(allTokens, "QtlDataset") hadJointSpec <- length(parsedJointSpec) > 0L - if (hadJointSpec) { - jointResult <- .fmQdsJointDispatch( - p, + jointResult <- if (!hadJointSpec) { + NULL + } else { + .fmQdsJointDispatch( parsedJointSpec, - intersect(tokens, c("mvsusie", "fsusie")), - methodArgs + intersect(allTokens, c("mvsusie", "fsusie")), + allMethodArgs, + data = data, + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + verbose = verbose, + xRegions = xRegions, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + screen = screen, + fineMappingResult = fineMappingResult, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + seed = seed ) - tokens <- setdiff(tokens, c("mvsusie", "fsusie")) - methodArgs <- methodArgs[tokens] } + # The joint dispatch consumed the multivariate tokens; the univariate + # phase runs on whatever is left. + narrowed <- .fmNarrowAfterJoint(hadJointSpec, allTokens, allMethodArgs) list( - tokens = tokens, - methodArgs = methodArgs, + tokens = narrowed$tokens, + methodArgs = narrowed$methodArgs, jointResult = jointResult, - exhaustedByJoint = hadJointSpec && length(tokens) == 0L + exhaustedByJoint = hadJointSpec && length(narrowed$tokens) == 0L ) } +# The tokens (and their args) still owed a univariate fit after a joint +# dispatch ran. A run with no joint specification keeps everything. +# @noRd +.fmNarrowAfterJoint <- function(hadJointSpec, tokens, methodArgs) { + if (!hadJointSpec) { + return(list(tokens = tokens, methodArgs = methodArgs)) + } + remaining <- setdiff(tokens, c("mvsusie", "fsusie")) + list(tokens = remaining, methodArgs = methodArgs[remaining]) +} + # Trait ids available in one context, intersected with the requested traitId or # overlapping the requested region (mirrors twasWeightsPipeline). # @noRd -.fmQdsTraitsForContext <- function(ctx, p) { - se <- getPhenotypes(p$data, contexts = ctx) - ids <- rownames(se) - if (!is.null(p$traitId)) { - ids <- intersect(ids, p$traitId) - } else if (!is.null(p$region)) { - rr <- SummarizedExperiment::rowRanges(se) - ids <- ids[IRanges::overlapsAny(rr, p$region)] +.fmQdsTraitsForContext <- function(ctx, data, traitId, region) { + se <- getPhenotypes(data, contexts = ctx) + allIds <- rownames(se) + ids <- if (!is.null(traitId)) { + intersect(allIds, traitId) + } else if (!is.null(region)) { + allIds[IRanges::overlapsAny( + SummarizedExperiment::rowRanges(se), + region + )] + } else { + allIds } ids } @@ -2392,12 +3160,12 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # the per-context trait lists. Returns `p` extended with study / useCtx / # perCtxTraits / nCtx / nTraits. # @noRd -.fmQdsResolveContexts <- function(p) { - allCtx <- getContexts(p$data) - useCtx <- if (is.null(p$contexts)) { +.fmQdsResolveContexts <- function(data, contexts, traitId, region) { + allCtx <- getContexts(data) + useCtx <- if (is.null(contexts)) { allCtx } else { - bad <- setdiff(p$contexts, allCtx) + bad <- setdiff(contexts, allCtx) if (length(bad) > 0L) { badStr <- str_flatten(bad, ", ") msg <- glue( @@ -2406,17 +3174,24 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) abort(msg) } - p$contexts + contexts } - perCtxTraits <- map(useCtx, .fmQdsTraitsForContext, p = p) - names(perCtxTraits) <- useCtx + perCtxTraits <- set_names( + map( + useCtx, + .fmQdsTraitsForContext, + data = data, + traitId = traitId, + region = region + ), + useCtx + ) allTraits <- unique(list_c(perCtxTraits)) if (length(allTraits) == 0L) { abort("fineMappingPipeline(QtlDataset): no traits selected.") } - list_modify( - p, - study = getStudy(p$data), + list( + study = getStudy(data), useCtx = useCtx, perCtxTraits = perCtxTraits, nCtx = length(useCtx), @@ -2428,27 +3203,26 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # multivariate requirements (mvsusie needs multi-trait OR multi-context; fsusie # needs multi-trait per context). Returns `p` extended with the three sets. # @noRd -.fmQdsSplitTokens <- function(p) { - univTokens <- p$tokens[!is_in(p$tokens, c("mvsusie", "fsusie"))] - mvTokens <- p$tokens[p$tokens == "mvsusie"] - fsTokens <- p$tokens[p$tokens == "fsusie"] - if (length(mvTokens) > 0L && p$nCtx < 2L && p$nTraits < 2L) { +.fmQdsSplitTokens <- function(tokens, nCtx, nTraits) { + univTokens <- tokens[!is_in(tokens, c("mvsusie", "fsusie"))] + mvTokens <- tokens[tokens == "mvsusie"] + fsTokens <- tokens[tokens == "fsusie"] + if (length(mvTokens) > 0L && nCtx < 2L && nTraits < 2L) { msg <- glue( "fineMappingPipeline(QtlDataset): mvsusie requires multi-trait ", - "or multi-context input (got {p$nTraits} trait(s) x ", - "{p$nCtx} context(s))." + "or multi-context input (got {nTraits} trait(s) x ", + "{nCtx} context(s))." ) abort(msg) } - if (length(fsTokens) > 0L && p$nTraits < 2L) { + if (length(fsTokens) > 0L && nTraits < 2L) { msg <- glue( "fineMappingPipeline(QtlDataset): fsusie requires multi-trait ", - "input within a context (got {p$nTraits} trait(s))." + "input within a context (got {nTraits} trait(s))." ) abort(msg) } - list_modify( - p, + list( univTokens = univTokens, mvTokens = mvTokens, fsTokens = fsTokens @@ -2458,14 +3232,93 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # Univariate + usePCA dispatch: each (context, trait) -> merged-per-token # row-records; each multi-trait context's top PCs -> pseudo-trait rows. # @noRd -.fmQdsDispatchRows <- function(p) { - univRows <- if (length(p$univTokens) > 0L) { - list_flatten(map(p$useCtx, .fmUnivContextRows, p = p)) +.fmQdsDispatchRows <- function( + addSusieInf, + cisWindow, + coverage, + cvFolds, + cvThreads, + data, + fineMappingResult, + fullFit, + fullFitAlphaOnly, + includeAllCs, + methodArgs, + minAbsCorr, + nPCs, + naAction, + perCtxTraits, + samplePartition, + screen, + secondaryCoverage, + seed, + signalCutoff, + study, + univTokens, + useCtx, + usePCA, + verbose, + xRegions +) { + univRows <- if (length(univTokens) > 0L) { + list_flatten(map( + useCtx, + .fmUnivContextRows, + data = data, + study = study, + univTokens = univTokens, + xRegions = xRegions, + naAction = naAction, + fineMappingResult = fineMappingResult, + cisWindow = cisWindow, + screen = screen, + addSusieInf = addSusieInf, + verbose = verbose, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + perCtxTraits = perCtxTraits + )) } else { list() } - pcaRows <- if (isTRUE(p$usePCA)) { - list_flatten(map(p$useCtx, .fmPcaContextRows, p = p)) + pcaRows <- if (isTRUE(usePCA)) { + list_flatten(map( + useCtx, + .fmPcaContextRows, + data = data, + study = study, + xRegions = xRegions, + naAction = naAction, + fineMappingResult = fineMappingResult, + cisWindow = cisWindow, + screen = screen, + addSusieInf = addSusieInf, + verbose = verbose, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + perCtxTraits = perCtxTraits, + nPCs = nPCs + )) } else { list() } @@ -2476,22 +3329,70 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # mvsusie / fsusie WITHOUT an explicit jointSpecification, merged with any # explicit-spec result already in `p$jointResult`. # @noRd -.fmQdsAutoJoint <- function(p) { - if (length(p$mvTokens) == 0L && length(p$fsTokens) == 0L) { - return(p$jointResult) +.fmQdsAutoJoint <- function( + data, + contexts, + traitId, + cisWindow, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + verbose, + xRegions, + twasWeights, + dataDrivenPriorWeightsCutoff, + cvFolds, + cvThreads, + samplePartition, + screen, + fineMappingResult, + fullFit, + fullFitAlphaOnly, + includeAllCs, + seed, + mvTokens, + fsTokens, + jointResult, + methodArgs, + nCtx, + nTraits +) { + if (length(mvTokens) == 0L && length(fsTokens) == 0L) { + return(jointResult) } autoJoint <- .fmQdsJointDispatch( - p, - .fmSynthesizeJointSpec(p$nCtx, p$nTraits), - c(p$mvTokens, p$fsTokens), - p$methodArgs + .fmSynthesizeJointSpec(nCtx, nTraits), + c(mvTokens, fsTokens), + methodArgs, + data = data, + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + verbose = verbose, + xRegions = xRegions, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + screen = screen, + fineMappingResult = fineMappingResult, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + seed = seed ) - if (is.null(p$jointResult)) { + if (is.null(jointResult)) { autoJoint } else if (is.null(autoJoint)) { - p$jointResult + jointResult } else { - .rbindFineMappingResult(p$jointResult, autoJoint, ldSketch = NULL) + .rbindFineMappingResult(jointResult, autoJoint, ldSketch = NULL) } } @@ -2499,7 +3400,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # trait-anchored cis span) combined with the joint result. Errors only when # neither path produced anything. # @noRd -.fmQdsAssemble <- function(p, rows, jointResult) { +.fmQdsAssemble <- function(data, rows, jointResult) { rowContext <- map_chr(rows, "context") rowTrait <- map_chr(rows, "trait") perTupleResult <- if (length(rows) > 0L) { @@ -2509,9 +3410,9 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { rowTrait, map_chr(rows, "method"), map(rows, "entry"), - traitPos = tryCatch( - .anchorVector(p$data, rowContext, rowTrait, "traitPos"), - error = function(e) NULL + traitPos = try_fetch( + .anchorVector(data, rowContext, rowTrait, "traitPos"), + error = function(cnd) NULL ), ldSketch = NULL ) @@ -2540,14 +3441,101 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # .fmFitXBlock / .fmFitRssBlock (which recompute .fmResolveSusieChain), so no # chain config is threaded here. # @noRd -.fmPipelineQtlDataset <- function(p) { - naAction <- p$naAction - p$naAction <- arg_match(naAction, c("drop", "impute")) - if (!is.null(p$seed)) { - withr::local_seed(as.integer(p$seed)) +.fmPipelineQtlDataset <- function( + data, + methods, + contexts, + traitId, + region, + cisWindow, + mafCutoff, + macCutoff, + xvarCutoff, + imissCutoff, + keepIndel, + keepSamples, + keepVariants, + jointRegions, + jointSpecification, + addSusieInf, + L, + Lgreedy, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + fineMappingResult, + twasWeights, + dataDrivenPriorWeightsCutoff, + verbose, + cvFolds, + cvThreads, + samplePartition, + seed, + naAction, + usePCA, + nPCs, + pipCutoffToSkip, + absZCutoffToSkip, + bfCutoffToSkip, + logBfCutoffToSkip, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { + naAction <- arg_match(naAction, c("drop", "impute")) + if (!is.null(seed)) { + withr::local_seed(as.integer(seed)) } - p <- .fmQdsResolveInputs(p) - rt <- .fmQdsResolveTokens(p) + # Each stage returns only the values it derives; nothing is grafted onto a + # captured environment. + resolved <- .fmQdsResolveInputs( + data = data, + pipCutoffToSkip = pipCutoffToSkip, + absZCutoffToSkip = absZCutoffToSkip, + bfCutoffToSkip = bfCutoffToSkip, + logBfCutoffToSkip = logBfCutoffToSkip, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + xvarCutoff = xvarCutoff, + imissCutoff = imissCutoff, + keepIndel = keepIndel, + keepSamples = keepSamples, + keepVariants = keepVariants, + region = region, + cisWindow = cisWindow, + jointRegions = jointRegions + ) + data <- resolved$data + screen <- resolved$screen + xRegions <- resolved$xRegions + rt <- .fmQdsResolveTokens( + jointSpecification = jointSpecification, + methods = methods, + L = L, + Lgreedy = Lgreedy, + data = data, + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + verbose = verbose, + xRegions = xRegions, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + screen = screen, + fineMappingResult = fineMappingResult, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + seed = seed + ) if (rt$exhaustedByJoint) { if (is.null(rt$jointResult)) { msg <- glue( @@ -2559,19 +3547,90 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { } return(rt$jointResult) } - p <- list_modify( - p, - tokens = rt$tokens, - methodArgs = rt$methodArgs, - jointResult = rt$jointResult + tokens <- rt$tokens + methodArgs <- rt$methodArgs + jointResult <- rt$jointResult + ctxInfo <- .fmQdsResolveContexts( + data = data, + contexts = contexts, + traitId = traitId, + region = region + ) + study <- ctxInfo$study + useCtx <- ctxInfo$useCtx + perCtxTraits <- ctxInfo$perCtxTraits + nCtx <- ctxInfo$nCtx + nTraits <- ctxInfo$nTraits + split <- .fmQdsSplitTokens(tokens, nCtx, nTraits) + univTokens <- split$univTokens + mvTokens <- split$mvTokens + fsTokens <- split$fsTokens + rows <- .fmQdsDispatchRows( + addSusieInf = addSusieInf, + cisWindow = cisWindow, + coverage = coverage, + cvFolds = cvFolds, + cvThreads = cvThreads, + data = data, + fineMappingResult = fineMappingResult, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + methodArgs = methodArgs, + minAbsCorr = minAbsCorr, + nPCs = nPCs, + naAction = naAction, + perCtxTraits = perCtxTraits, + samplePartition = samplePartition, + screen = screen, + secondaryCoverage = secondaryCoverage, + seed = seed, + signalCutoff = signalCutoff, + study = study, + univTokens = univTokens, + useCtx = useCtx, + usePCA = usePCA, + verbose = verbose, + xRegions = xRegions + ) + .fmQdsAssemble( + data, + rows, + .fmQdsAutoJoint( + data = data, + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + verbose = verbose, + xRegions = xRegions, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + screen = screen, + fineMappingResult = fineMappingResult, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + seed = seed, + mvTokens = mvTokens, + fsTokens = fsTokens, + jointResult = jointResult, + methodArgs = methodArgs, + nCtx = nCtx, + nTraits = nTraits + ) ) - p <- .fmQdsSplitTokens(.fmQdsResolveContexts(p)) - rows <- .fmQdsDispatchRows(p) - .fmQdsAssemble(p, rows, .fmQdsAutoJoint(p)) } #' @rdname fineMappingPipeline -#' @importFrom purrr list_c list_flatten list_modify list_rbind +#' @importFrom purrr list_c list_flatten list_modify list_rbind list_assign +#' @importFrom purrr discard walk2 detect zap #' @export setMethod( "fineMappingPipeline", @@ -2627,7 +3686,48 @@ setMethod( residualizeGenotypeCovariates = TRUE, ... ) { - .fmPipelineQtlDataset(as.list(environment())) + .fmPipelineQtlDataset( + data = data, + methods = methods, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + xvarCutoff = xvarCutoff, + imissCutoff = imissCutoff, + keepIndel = keepIndel, + keepSamples = keepSamples, + keepVariants = keepVariants, + jointRegions = jointRegions, + jointSpecification = jointSpecification, + addSusieInf = addSusieInf, + L = L, + Lgreedy = Lgreedy, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + verbose = verbose, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + naAction = naAction, + usePCA = usePCA, + nPCs = nPCs, + pipCutoffToSkip = pipCutoffToSkip, + absZCutoffToSkip = absZCutoffToSkip, + bfCutoffToSkip = bfCutoffToSkip, + logBfCutoffToSkip = logBfCutoffToSkip, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs + ) } ) @@ -2710,42 +3810,63 @@ setMethod( # from the per-tuple recursion. Returns the still-pending tokens, the forwarded # `methods` (kwargs-preserving), the joint result, and `exhaustedByJoint`. # @noRd -.fmMsResolveTokens <- function(p) { - parsedJointSpec <- parseJointSpecification(p$jointSpecification, p$data) - norm <- .fmNormalizeMethods(p$methods) - tokens <- norm$tokens - methodArgs <- norm$methodArgs - .fmCheckMethodCapabilities(tokens, "MultiStudyQtlDataset") - jointResult <- NULL - methods <- p$methods +.fmMsResolveTokens <- function( + data, + methods, + contexts, + traitId, + cisWindow, + xRegions, + jointSpecification, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + twasWeights, + dataDrivenPriorWeightsCutoff, + verbose +) { + parsedJointSpec <- parseJointSpecification(jointSpecification, data) + norm <- .fmNormalizeMethods(methods) + allTokens <- norm$tokens + allMethodArgs <- norm$methodArgs + .fmCheckMethodCapabilities(allTokens, "MultiStudyQtlDataset") hadJointSpec <- length(parsedJointSpec) > 0L - if (hadJointSpec) { - jointResult <- .fmDispatchJointSpecsMultiStudy( + jointResult <- if (!hadJointSpec) { + NULL + } else { + .fmDispatchJointSpecsMultiStudy( parsedJointSpec, - p$data, - intersect(tokens, c("mvsusie", "fsusie")), - p$contexts, - p$traitId, - p$cisWindow, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$verbose, - methodArgs = methodArgs, - xRegions = p$xRegions, - twasWeights = p$twasWeights, - dataDrivenPriorWeightsCutoff = p$dataDrivenPriorWeightsCutoff + data, + intersect(allTokens, c("mvsusie", "fsusie")), + contexts, + traitId, + cisWindow, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + verbose, + methodArgs = allMethodArgs, + xRegions = xRegions, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff ) - tokens <- setdiff(tokens, c("mvsusie", "fsusie")) - methodArgs <- methodArgs[tokens] - methods <- if (length(methodArgs) > 0L) methodArgs else tokens } + # The joint dispatch consumed the multivariate tokens; the univariate + # phase runs on whatever is left. + narrowed <- .fmNarrowAfterJoint(hadJointSpec, allTokens, allMethodArgs) list( - tokens = tokens, - methods = methods, + tokens = narrowed$tokens, + methods = if (!hadJointSpec) { + methods + } else if (length(narrowed$methodArgs) > 0L) { + narrowed$methodArgs + } else { + narrowed$tokens + }, jointResult = jointResult, - exhaustedByJoint = hadJointSpec && length(tokens) == 0L + exhaustedByJoint = hadJointSpec && length(narrowed$tokens) == 0L ) } @@ -2753,31 +3874,55 @@ setMethod( # individual-capable methods route to the per-study QtlDatasets, sumstat-capable # methods (incl. the sumstat-only `ser`) to the embedded QtlSumStats. # @noRd -.fmMsConfig <- function(p) { +.fmMsConfig <- function( + methods, + contexts, + traitId, + region, + cisWindow, + jointRegions, + addSusieInf, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + fineMappingResult, + verbose, + cvFolds, + cvThreads, + samplePartition, + seed, + naAction, + pipCutoffToSkip, + absZCutoffToSkip, + bfCutoffToSkip, + logBfCutoffToSkip, + dotArgs +) { list( - methods = p$methods, - contexts = p$contexts, - traitId = p$traitId, - region = p$region, - cisWindow = p$cisWindow, - jointRegions = p$jointRegions, - addSusieInf = p$addSusieInf, - coverage = p$coverage, - secondaryCoverage = p$secondaryCoverage, - signalCutoff = p$signalCutoff, - minAbsCorr = p$minAbsCorr, - fineMappingResult = p$fineMappingResult, - cvFolds = p$cvFolds, - cvThreads = p$cvThreads, - samplePartition = p$samplePartition, - pipCutoffToSkip = p$pipCutoffToSkip, - absZCutoffToSkip = p$absZCutoffToSkip, - bfCutoffToSkip = p$bfCutoffToSkip, - logBfCutoffToSkip = p$logBfCutoffToSkip, - seed = p$seed, - naAction = p$naAction, - verbose = p$verbose, - dotArgs = p$dotArgs + methods = methods, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + jointRegions = jointRegions, + addSusieInf = addSusieInf, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + fineMappingResult = fineMappingResult, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + pipCutoffToSkip = pipCutoffToSkip, + absZCutoffToSkip = absZCutoffToSkip, + bfCutoffToSkip = bfCutoffToSkip, + logBfCutoffToSkip = logBfCutoffToSkip, + seed = seed, + naAction = naAction, + verbose = verbose, + dotArgs = dotArgs ) } @@ -2786,22 +3931,60 @@ setMethod( # each remaining method to the components it supports via the shared # multi-study driver. # @noRd -.fmPipelineMultiStudy <- function(p) { - naAction <- p$naAction +.fmPipelineMultiStudy <- function( + data, + methods, + contexts, + traitId, + region, + cisWindow, + jointRegions, + jointSpecification, + addSusieInf, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + fineMappingResult, + twasWeights, + dataDrivenPriorWeightsCutoff, + verbose, + cvFolds, + cvThreads, + samplePartition, + seed, + naAction, + pipCutoffToSkip, + absZCutoffToSkip, + bfCutoffToSkip, + logBfCutoffToSkip, + dotArgs +) { naAction <- arg_match(naAction, c("drop", "impute")) - if (!is.null(p$region) && !is.null(p$cisWindow)) { + if (!is.null(region) && !is.null(cisWindow)) { msg <- glue( "fineMappingPipeline(MultiStudyQtlDataset): specify either ", "`region` or `cisWindow`, not both." ) abort(msg) } - p <- list_modify( - p, - naAction = naAction, - xRegions = .makeXRegions(p$region, p$jointRegions) + xRegions <- .makeXRegions(region, jointRegions) + rt <- .fmMsResolveTokens( + data = data, + methods = methods, + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + xRegions = xRegions, + jointSpecification = jointSpecification, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + verbose = verbose ) - rt <- .fmMsResolveTokens(p) if (rt$exhaustedByJoint) { if (is.null(rt$jointResult)) { msg <- glue( @@ -2813,13 +3996,37 @@ setMethod( } return(rt$jointResult) } - p <- list_modify(p, methods = rt$methods) + methods <- rt$methods .multiStudyPipelineDriver( - p$data, + data, rt$jointResult, .fmPerStudy, .fmSumStats, - .fmMsConfig(p), + .fmMsConfig( + methods = methods, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + jointRegions = jointRegions, + addSusieInf = addSusieInf, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + fineMappingResult = fineMappingResult, + verbose = verbose, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + naAction = naAction, + pipCutoffToSkip = pipCutoffToSkip, + absZCutoffToSkip = absZCutoffToSkip, + bfCutoffToSkip = bfCutoffToSkip, + logBfCutoffToSkip = logBfCutoffToSkip, + dotArgs = dotArgs + ), .rbindFineMappingResult, QtlFineMappingResult, "fineMappingPipeline" @@ -2869,9 +4076,35 @@ setMethod( residualizeGenotypeCovariates = TRUE, ... ) { - p <- as.list(environment()) - p$dotArgs <- list(...) - .fmPipelineMultiStudy(p) + .fmPipelineMultiStudy( + data = data, + methods = methods, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + jointRegions = jointRegions, + jointSpecification = jointSpecification, + addSusieInf = addSusieInf, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + verbose = verbose, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + naAction = naAction, + pipCutoffToSkip = pipCutoffToSkip, + absZCutoffToSkip = absZCutoffToSkip, + bfCutoffToSkip = bfCutoffToSkip, + logBfCutoffToSkip = logBfCutoffToSkip, + dotArgs = list(...) + ) } ) @@ -2886,61 +4119,90 @@ setMethod( # where an explicit spec consumed every method, so the caller returns the joint # result directly (or errors when it produced nothing). # @noRd -.fmQssResolveTokens <- function(p) { - parsedJointSpec <- parseJointSpecification(p$jointSpecification, p$data) - norm <- .fmNormalizeMethods(p$methods) - tokens <- norm$tokens - methodArgs <- norm$methodArgs - .fmCheckMethodCapabilities(tokens, "QtlSumStats") - jointResult <- NULL +.fmQssResolveTokens <- function( + data, + methods, + contexts, + traitId, + jointSpecification, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + fineMappingResult, + twasWeights, + dataDrivenPriorWeightsCutoff, + verbose, + fullFit, + fullFitAlphaOnly, + includeAllCs, + mafCutoff, + macCutoff, + imissCutoff +) { + parsedJointSpec <- parseJointSpecification(jointSpecification, data) + norm <- .fmNormalizeMethods(methods) + allTokens <- norm$tokens + allMethodArgs <- norm$methodArgs + .fmCheckMethodCapabilities(allTokens, "QtlSumStats") hadJointSpec <- length(parsedJointSpec) > 0L - if (hadJointSpec) { - jointResult <- .fmDispatchJointSpecsQtlSumStats( + jointResult <- if (!hadJointSpec) { + NULL + } else { + .fmDispatchJointSpecsQtlSumStats( parsedJointSpec, - p$data, - intersect(tokens, "mvsusie"), - p$contexts, - p$traitId, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$verbose, - methodArgs = methodArgs, - twasWeights = p$twasWeights, - dataDrivenPriorWeightsCutoff = p$dataDrivenPriorWeightsCutoff, - fineMappingResult = p$fineMappingResult, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs, - mafCutoff = p$mafCutoff %||% 0, - macCutoff = p$macCutoff %||% 0, - imissCutoff = p$imissCutoff %||% 1 + data, + intersect(allTokens, "mvsusie"), + contexts, + traitId, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + verbose, + methodArgs = allMethodArgs, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + fineMappingResult = fineMappingResult, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + mafCutoff = mafCutoff %||% 0, + macCutoff = macCutoff %||% 0, + imissCutoff = imissCutoff %||% 1 ) - tokens <- setdiff(tokens, c("mvsusie", "fsusie")) - methodArgs <- methodArgs[tokens] } + # The joint dispatch consumed the multivariate tokens; the univariate + # phase runs on whatever is left. + narrowed <- .fmNarrowAfterJoint(hadJointSpec, allTokens, allMethodArgs) list( - tokens = tokens, - methodArgs = methodArgs, + tokens = narrowed$tokens, + methodArgs = narrowed$methodArgs, jointResult = jointResult, - exhaustedByJoint = hadJointSpec && length(tokens) == 0L + exhaustedByJoint = hadJointSpec && length(narrowed$tokens) == 0L ) } # Resolve the study/context/trait columns and the selected row indices for a # QtlSumStats run, applying the optional contexts / traitId filters. # @noRd -.fmQssSelectRows <- function(p) { - studyCol <- as.character(p$data$study) - contextCol <- as.character(p$data$context) - traitCol <- as.character(p$data$trait) - selRows <- seq_len(nrow(p$data)) - if (!is.null(p$contexts)) { - selRows <- selRows[is_in(contextCol[selRows], p$contexts)] +.fmQssSelectRows <- function( + data, + contexts, + traitId +) { + studyCol <- as.character(data$study) + contextCol <- as.character(data$context) + traitCol <- as.character(data$trait) + byContext <- if (is.null(contexts)) { + seq_len(nrow(data)) + } else { + which(is_in(contextCol, contexts)) } - if (!is.null(p$traitId)) { - selRows <- selRows[is_in(traitCol[selRows], p$traitId)] + selRows <- if (is.null(traitId)) { + byContext + } else { + byContext[is_in(traitCol[byContext], traitId)] } if (length(selRows) == 0L) { msg <- glue( @@ -2990,38 +4252,60 @@ setMethod( # joint) for mvsusie WITHOUT an explicit jointSpecification, merged with any # explicit-spec result already in `p$jointResult`. # @noRd -.fmQssAutoJoint <- function(p) { - if (length(p$mvTokens) == 0L) { - return(p$jointResult) +.fmQssAutoJoint <- function( + data, + contexts, + traitId, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + fineMappingResult, + twasWeights, + dataDrivenPriorWeightsCutoff, + verbose, + fullFit, + fullFitAlphaOnly, + includeAllCs, + mafCutoff, + macCutoff, + imissCutoff, + methodArgs, + mvTokens, + jointResult, + ldSketch +) { + if (length(mvTokens) == 0L) { + return(jointResult) } autoJoint <- .fmDispatchJointSpecsQtlSumStats( list(list(axes = "context", scope = NULL)), - p$data, - p$mvTokens, - p$contexts, - p$traitId, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$verbose, - methodArgs = p$methodArgs, - twasWeights = p$twasWeights, - dataDrivenPriorWeightsCutoff = p$dataDrivenPriorWeightsCutoff, - fineMappingResult = p$fineMappingResult, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs, - mafCutoff = p$mafCutoff %||% 0, - macCutoff = p$macCutoff %||% 0, - imissCutoff = p$imissCutoff %||% 1 - ) - if (is.null(p$jointResult)) { + data, + mvTokens, + contexts, + traitId, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + verbose, + methodArgs = methodArgs, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + fineMappingResult = fineMappingResult, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + mafCutoff = mafCutoff %||% 0, + macCutoff = macCutoff %||% 0, + imissCutoff = imissCutoff %||% 1 + ) + if (is.null(jointResult)) { autoJoint } else if (is.null(autoJoint)) { - p$jointResult + jointResult } else { - .rbindFineMappingResult(p$jointResult, autoJoint, ldSketch = p$ldSketch) + .rbindFineMappingResult(jointResult, autoJoint, ldSketch = ldSketch) } } @@ -3030,7 +4314,13 @@ setMethod( # and combine with the joint result. An all-screened collection yields a valid # empty result rather than an error. # @noRd -.fmQssAssemble <- function(p, rows, nSkipped, jointResult) { +.fmQssAssemble <- function( + data, + ldSketch, + rows, + nSkipped, + jointResult +) { rowContext <- map_chr(rows, "context") rowTrait <- map_chr(rows, "trait") perTupleResult <- if (length(rows) > 0L) { @@ -3040,11 +4330,11 @@ setMethod( rowTrait, map_chr(rows, "method"), map(rows, "entry"), - traitPos = tryCatch( - .anchorVector(p$data, rowContext, rowTrait, "traitPos"), - error = function(e) NULL + traitPos = try_fetch( + .anchorVector(data, rowContext, rowTrait, "traitPos"), + error = function(cnd) NULL ), - ldSketch = p$ldSketch + ldSketch = ldSketch ) } else { NULL @@ -3060,7 +4350,7 @@ setMethod( character(0), character(0), list(), - ldSketch = p$ldSketch, + ldSketch = ldSketch, allowEmpty = TRUE )) } @@ -3071,16 +4361,64 @@ setMethod( if (is.null(perTupleResult)) { return(jointResult) } - .rbindFineMappingResult(perTupleResult, jointResult, ldSketch = p$ldSketch) + .rbindFineMappingResult(perTupleResult, jointResult, ldSketch = ldSketch) } # QtlSumStats fine-mapping worker. `p` is the setMethod's captured arguments; # it is extended via list_modify with the resolved tokens / row selection / LD # sketch so the per-entry dispatch helpers read everything from one bundle. # @noRd -.fmPipelineQtlSumStats <- function(p) { - .fmAssertQcd(p$data) - rt <- .fmQssResolveTokens(p) +.fmPipelineQtlSumStats <- function( + data, + methods, + contexts, + traitId, + jointSpecification, + addSusieInf, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + medianAbsCorr, + fineMappingResult, + twasWeights, + dataDrivenPriorWeightsCutoff, + verbose, + trim, + fullFit, + fullFitAlphaOnly, + includeAllCs, + serFallback, + rFinite, + rMismatch, + rssControl, + keepFullFit, + mafCutoff, + macCutoff, + imissCutoff +) { + .fmAssertQcd(data) + rt <- .fmQssResolveTokens( + data = data, + methods = methods, + contexts = contexts, + traitId = traitId, + jointSpecification = jointSpecification, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + verbose = verbose, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + ) if (rt$exhaustedByJoint) { if (is.null(rt$jointResult)) { msg <- glue( @@ -3092,36 +4430,89 @@ setMethod( } return(rt$jointResult) } - sel <- .fmQssSelectRows(p) + sel <- .fmQssSelectRows(data = data, contexts = contexts, traitId = traitId) split <- .fmQssSplitTokens(rt$tokens, sel) - ldSketch <- getLdSketch(p$data) - p <- list_modify( - p, - tokens = rt$tokens, - methodArgs = rt$methodArgs, - jointResult = rt$jointResult, - studyCol = sel$studyCol, - contextCol = sel$contextCol, - traitCol = sel$traitCol, - selRows = sel$selRows, - univTokens = split$univTokens, - mvTokens = split$mvTokens, - ldSketch = ldSketch, - rFiniteResolved = .fmResolveRFinite( - p$rFinite, - p$serFallback, - p$rMismatch, - ldSketch - ) + ldSketch <- getLdSketch(data) + # Derived values are locals, not fields grafted onto a parameter pack. + tokens <- rt$tokens + methodArgs <- rt$methodArgs + jointResult <- rt$jointResult + studyCol <- sel$studyCol + contextCol <- sel$contextCol + traitCol <- sel$traitCol + selRows <- sel$selRows + univTokens <- split$univTokens + mvTokens <- split$mvTokens + rFiniteResolved <- .fmResolveRFinite( + rFinite, + serFallback, + rMismatch, + ldSketch ) - univOut <- if (length(p$univTokens) > 0L) { - map(p$selRows, .fmRssEntryRows, p = p) + univOut <- if (length(univTokens) > 0L) { + map( + selRows, + .fmRssEntryRows, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol, + univTokens = univTokens, + fineMappingResult = fineMappingResult, + data = data, + ldSketch = ldSketch, + addSusieInf = addSusieInf, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + verbose = verbose, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + serFallback = serFallback, + rFiniteResolved = rFiniteResolved, + rMismatch = rMismatch, + rssControl = rssControl, + keepFullFit = keepFullFit, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + ) } else { list() } rows <- list_flatten(map(univOut, "rows")) nSkipped <- sum(map_lgl(univOut, "skipped")) - .fmQssAssemble(p, rows, nSkipped, .fmQssAutoJoint(p)) + .fmQssAssemble( + data = data, + ldSketch = ldSketch, + rows = rows, + nSkipped = nSkipped, + jointResult = .fmQssAutoJoint( + data = data, + contexts = contexts, + traitId = traitId, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + verbose = verbose, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff, + methodArgs = methodArgs, + mvTokens = mvTokens, + jointResult = jointResult, + ldSketch = ldSketch + ) + ) } #' @rdname fineMappingPipeline @@ -3159,7 +4550,35 @@ setMethod( imissCutoff = 1, ... ) { - .fmPipelineQtlSumStats(as.list(environment())) + .fmPipelineQtlSumStats( + data = data, + methods = methods, + contexts = contexts, + traitId = traitId, + jointSpecification = jointSpecification, + addSusieInf = addSusieInf, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + medianAbsCorr = medianAbsCorr, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + verbose = verbose, + trim = trim, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + serFallback = serFallback, + rFinite = rFinite, + rMismatch = rMismatch, + rssControl = rssControl, + keepFullFit = keepFullFit, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + ) } ) @@ -3185,32 +4604,78 @@ setMethod( } # GwasSumStats fine-mapping worker. `p` is the setMethod's captured arguments -# (as.list(environment())); it is extended via list_modify with the resolved +# resolved tokens / LD sketch / finite-sample size are ordinary locals; the # tokens / LD sketch / finite-sample size so the per-entry dispatch helpers # read everything from the single bundle. One GwasSumStats is one LD # block (the caller builds one collection per block when sweeping the genome); # we fine-map each (study, method) tuple across the whole entry, no in-pipeline # block partitioning. # @noRd -.fmPipelineGwas <- function(p) { - .fmAssertQcd(p$data) - norm <- .fmNormalizeMethods(p$methods, L = p$L, Lgreedy = p$Lgreedy) +.fmPipelineGwas <- function( + data, + methods, + L, + Lgreedy, + addSusieInf, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + fineMappingResult, + verbose, + fullFit, + fullFitAlphaOnly, + includeAllCs, + serFallback, + rFinite, + rMismatch, + rssControl, + keepFullFit, + mafCutoff, + macCutoff, + imissCutoff +) { + .fmAssertQcd(data) + norm <- .fmNormalizeMethods(methods, L = L, Lgreedy = Lgreedy) .fmCheckMethodCapabilities(norm$tokens, "GwasSumStats") - ldSketch <- getLdSketch(p$data) - p <- list_modify( - p, - tokens = norm$tokens, - methodArgs = norm$methodArgs, + ldSketch <- getLdSketch(data) + # Derived values are ordinary locals now, not fields grafted onto a bundle. + tokens <- norm$tokens + methodArgs <- norm$methodArgs + rFiniteResolved <- .fmResolveRFinite( + rFinite, + serFallback, + rMismatch, + ldSketch + ) + studyCol <- as.character(data$study) + entryOut <- map( + seq_len(nrow(data)), + .fmGwasEntryRows, + data = data, + studyCol = studyCol, + tokens = tokens, ldSketch = ldSketch, - rFiniteResolved = .fmResolveRFinite( - p$rFinite, - p$serFallback, - p$rMismatch, - ldSketch - ), - studyCol = as.character(p$data$study) + verbose = verbose, + fineMappingResult = fineMappingResult, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff, + addSusieInf = addSusieInf, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + serFallback = serFallback, + rFiniteResolved = rFiniteResolved, + rMismatch = rMismatch, + rssControl = rssControl, + keepFullFit = keepFullFit ) - entryOut <- map(seq_len(nrow(p$data)), .fmGwasEntryRows, p = p) rows <- list_flatten(map(entryOut, "rows")) nSkipped <- sum(map_lgl(entryOut, "skipped")) # An all-screened (or empty-input) collection legitimately yields a 0-row @@ -3221,7 +4686,7 @@ setMethod( map(rows, "entry"), blockIds = map_chr(rows, "blockId"), ldSketch = ldSketch, - allowEmpty = (nSkipped > 0L || nrow(p$data) == 0L) + allowEmpty = (nSkipped > 0L || nrow(data) == 0L) ) } @@ -3257,7 +4722,30 @@ setMethod( imissCutoff = 1, ... ) { - .fmPipelineGwas(as.list(environment())) + .fmPipelineGwas( + data = data, + methods = methods, + L = L, + Lgreedy = Lgreedy, + addSusieInf = addSusieInf, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + fineMappingResult = fineMappingResult, + verbose = verbose, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + serFallback = serFallback, + rFinite = rFinite, + rMismatch = rMismatch, + rssControl = rssControl, + keepFullFit = keepFullFit, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + ) } ) @@ -3298,8 +4786,16 @@ setMethod("fineMappingPipeline", "ANY", function(data, ...) { } # @noRd -.fmGwasLookup <- function(tk, p, st, blockId) { - list(tk = tk, cached = .fmCacheLookupGwasResume(p, st, tk, blockId)) +.fmGwasLookup <- function(tk, fineMappingResult, st, blockId) { + list( + tk = tk, + cached = .fmCacheLookupGwasResume( + fineMappingResult, + st, + tk, + blockId + ) + ) } # @noRd @@ -3313,8 +4809,11 @@ setMethod("fineMappingPipeline", "ANY", function(data, ...) { } # @noRd -.fmQtlLookup <- function(tk, p, st, ctx, tr) { - list(tk = tk, cached = .fmCacheLookup(p$fineMappingResult, st, ctx, tr, tk)) +.fmQtlLookup <- function(tk, fineMappingResult, st, ctx, tr) { + list( + tk = tk, + cached = .fmCacheLookup(fineMappingResult, st, ctx, tr, tk) + ) } # @noRd @@ -3388,20 +4887,71 @@ setMethod("fineMappingPipeline", "ANY", function(data, ...) { } # @noRd -.fmUnivLookup <- function(tk, p, ctx, tid) { +.fmUnivLookup <- function(tk, fineMappingResult, study, ctx, tid) { list( tk = tk, - cached = .fmCacheLookup(p$fineMappingResult, p$study, ctx, tid, tk) + cached = .fmCacheLookup(fineMappingResult, study, ctx, tid, tk) ) } # @noRd -.fmUnivCachedRow <- function(l, p, ctx, tid) { - .fmQtlRow(p$study, ctx, tid, l$tk, l$cached) +.fmUnivCachedRow <- function(l, study, ctx, tid) { + .fmQtlRow(study, ctx, tid, l$tk, l$cached) } # All univariate row-records for one context (over its per-context traits). # @noRd -.fmUnivContextRows <- function(ctx, p) { - list_flatten(map(p$perCtxTraits[[ctx]], .fmUnivTraitRows, p = p, ctx = ctx)) +.fmUnivContextRows <- function( + ctx, + data, + study, + univTokens, + xRegions, + naAction, + fineMappingResult, + cisWindow, + screen, + addSusieInf, + verbose, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + cvFolds, + cvThreads, + samplePartition, + seed, + fullFit, + fullFitAlphaOnly, + includeAllCs, + perCtxTraits +) { + list_flatten(map( + perCtxTraits[[ctx]], + .fmUnivTraitRows, + ctx = ctx, + data = data, + study = study, + univTokens = univTokens, + xRegions = xRegions, + naAction = naAction, + fineMappingResult = fineMappingResult, + cisWindow = cisWindow, + screen = screen, + addSusieInf = addSusieInf, + verbose = verbose, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs + )) } diff --git a/R/fineMappingRow.R b/R/fineMappingRow.R index fb1ce1e7..898dd546 100644 --- a/R/fineMappingRow.R +++ b/R/fineMappingRow.R @@ -41,19 +41,22 @@ setClass( prototype(susieFit = NULL, cvResult = NULL) ) +#' @importFrom checkmate makeAssertCollection assertList methods::setValidity("FineMappingRow", function(object) { - errors <- character(0) - if (!is.null(object@cvResult) && !is.list(object@cvResult)) { - errors <- c(errors, "cvResult must be NULL or a list") - } + coll <- makeAssertCollection() + assertList( + object@cvResult, + null.ok = TRUE, + .var.name = "cvResult", + add = coll + ) + # mcols() is an S4 DataFrame, not a data.frame, so checkDataFrame does not + # apply; the row-count contract stays a plain check. md <- mcols(object@variants, use.names = FALSE) if (!is.null(md) && nrow(md) != length(object@variants)) { - errors <- c( - errors, - "variants' metadata columns must have one row per variant" - ) + coll$push("variants' metadata columns must have one row per variant") } - if (length(errors) == 0L) TRUE else errors + coll$getMessages() }) #' @title Build One Fine-Mapping Row @@ -89,7 +92,7 @@ methods::setValidity("FineMappingRow", function(object) { #' @export fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { vids <- as.character(variantIds) - gr <- .variantIdsToGRanges(vids, "variantIds") + bare <- .variantIdsToGRanges(vids, "variantIds") tl <- as_tibble(topLoci) missingCols <- setdiff(c("variant_id", "pip"), colnames(tl)) if (nrow(tl) > 0L && length(missingCols) > 0L) { @@ -99,9 +102,9 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { ) abort(msg) } - if (nrow(tl) != length(gr)) { + if (nrow(tl) != length(bare)) { msg <- glue( - "topLoci has {nrow(tl)} rows but {length(gr)} variants were ", + "topLoci has {nrow(tl)} rows but {length(bare)} variants were ", "supplied; they must be aligned row-for-row." ) abort(msg) @@ -109,9 +112,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (nrow(tl) > 0L && is_in("variant_id", names(tl))) { .fmRowCheckIdOrder(vids, as.character(tl$variant_id)) } - for (nm in setdiff(names(tl), .fmeIdentityCols)) { - mcols(gr)[[nm]] <- tl[[nm]] - } + gr <- .fmRowAttachPayload(bare, tl) obj <- new( "FineMappingRow", variants = gr, @@ -122,6 +123,27 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { obj } +# Attach topLoci's payload columns to the variant GRanges, keeping the +# identity columns `.variantIdsToGRanges()` already put in mcols. Replacing +# mcols wholesale would drop those, and the variant ids could no longer be +# rebuilt from the row. +# @noRd +.fmRowAttachPayload <- function(gr, tl) { + payload <- setdiff(names(tl), .fmeIdentityCols) + if (length(payload) == 0L) { + return(gr) + } + existing <- S4Vectors::mcols(gr) + kept <- existing[, setdiff(colnames(existing), payload), drop = FALSE] + `mcols<-`( + gr, + value = cbind( + kept, + S4Vectors::DataFrame(tl[payload], check.names = FALSE) + ) + ) +} + # topLoci's mcols are taken POSITIONALLY, so a table listing the same variants # in a different order would silently mis-assign every column. @@ -191,10 +213,11 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # call is the only path that works across all post_processing modes. Guarded so # an upstream fsusieR change surfaces as a clear error, not a silent NULL. # @noRd +#' @importFrom rlang try_fetch .fsusiePopulateCredibleBand <- function(fit) { - fn <- tryCatch( + fn <- try_fetch( get("update_cal_credible_band.susiF", envir = asNamespace("fsusieR")), - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(fn)) { # Defensive guard against an upstream fsusieR rename; only reachable @@ -217,7 +240,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (is.null(vid) || length(vid) == 0L) { return(NA_character_) } - tryCatch(parseVariantId(vid[1])$chrom, error = function(e) NA_character_) + try_fetch(parseVariantId(vid[1])$chrom, error = function(cnd) NA_character_) } .emptyCredibleBand <- function() { @@ -239,14 +262,13 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { fit <- .fsusiePopulateCredibleBand(fit) grid <- as.numeric(fit$outing_grid) chrom <- .fsusieChrom(fit) - parts <- map( + parts <- compact(map( seq_along(fit$cred_band), .fsusieBandRow, fit = fit, chrom = chrom, grid = grid - ) - parts <- compact(parts) + )) if (length(parts) == 0L) { return(.emptyCredibleBand()) } @@ -261,10 +283,40 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # MEMBERSHIP (not by index), which is robust to pecotmr's CS # filtering/renumbering. # @noRd +# One fit effect's variant ids, resolving positional membership through the +# fit's own variant order. +# @noRd +.fsusieEffectVariants <- function(l, fit, vids) { + raw <- fit$cs[[l]] + fv <- if (is.numeric(raw)) vids[as.integer(raw)] else raw + as.character(fv) +} + +# @noRd +.fsusieSetMatches <- function(fv, kVars) { + length(fv) > 0L && setequal(fv, kVars) +} + +# The first fit effect whose membership equals label `lab`'s, or NA. +# @noRd +.fsusieFirstMatchingEffect <- function(lab, fitSets, topLoci) { + kVars <- as.character(topLoci$variant_id[topLoci$cs_95 == lab]) + hit <- which(map_lgl(fitSets, .fsusieSetMatches, kVars = kVars)) + if (length(hit) == 0L) { + return(NA_integer_) + } + hit[[1L]] +} + +# @noRd +.fsusieLabelPurity <- function(lab, topLoci) { + as.numeric(topLoci$cs_95_purity[topLoci$cs_95 == lab][1]) +} + .fsusieCsMapFromTopLoci <- function(fit, topLoci) { L <- length(fit$cs) - label <- set_names(str_c("fsusie_", seq_len(L)), seq_len(L)) - purity <- set_names(rep(NA_real_, L), seq_len(L)) + defaultLabel <- set_names(str_c("fsusie_", seq_len(L)), seq_len(L)) + defaultPurity <- set_names(rep(NA_real_, L), seq_len(L)) vids <- names(fit$csd_X) if ( is.null(topLoci) || @@ -274,26 +326,28 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { names(topLoci) )) ) { - return(list(label = label, purity = purity)) + return(list(label = defaultLabel, purity = defaultPurity)) } retained <- unique(topLoci$cs_95[!str_detect(topLoci$cs_95, "_0$")]) - for (lab in retained) { - inLab <- topLoci$cs_95 == lab - kVars <- as.character(topLoci$variant_id[inLab]) - kPurit <- as.numeric(topLoci$cs_95_purity[inLab][1]) - for (l in seq_len(L)) { - fv <- fit$cs[[l]] - if (is.numeric(fv)) { - fv <- vids[as.integer(fv)] - } - fv <- as.character(fv) - if (length(fv) > 0L && setequal(fv, kVars)) { - label[[as.character(l)]] <- lab - purity[[as.character(l)]] <- kPurit - break - } - } - } + fitSets <- map(seq_len(L), .fsusieEffectVariants, fit = fit, vids = vids) + # Each retained label claims the first effect whose membership it matches; + # labels are applied in order, so a later one wins a shared effect, which + # is what the repeated assignment did. + targets <- map_int( + retained, + .fsusieFirstMatchingEffect, + fitSets = fitSets, + topLoci = topLoci + ) + matched <- !is.na(targets) + lastWins <- matched & !duplicated(targets, fromLast = TRUE) + at <- targets[lastWins] + label <- replace(defaultLabel, at, retained[lastWins]) + purity <- replace( + defaultPurity, + at, + map_dbl(retained[lastWins], .fsusieLabelPurity, topLoci = topLoci) + ) list(label = label, purity = purity) } @@ -303,11 +357,11 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { return(GenomicRanges::GRanges()) } fit <- .fsusiePopulateCredibleBand(fit) - reg <- tryCatch(fsusieR::affected_reg(fit), error = function(e) NULL) - if (is.null(reg) || nrow(reg) == 0L) { + raw <- try_fetch(fsusieR::affected_reg(fit), error = function(cnd) NULL) + if (is.null(raw) || nrow(raw) == 0L) { return(GenomicRanges::GRanges()) } - reg <- as_tibble(reg) + reg <- as_tibble(raw) chrom <- .fsusieChrom(fit) grid <- as.numeric(fit$outing_grid) csMap <- .fsusieCsMapFromTopLoci(fit, topLoci) @@ -378,16 +432,26 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # @noRd .fsusieEntryAffectedRegions <- function(i, x) { gr <- .fmrRowFsusieAffectedRegions(.fmrRowParts(x, i)) - if (length(gr) > 0L) { - S4Vectors::mcols(gr)$study <- as.character(x$study[[i]]) - if (is_in("context", .tupleColumnNames(x))) { - S4Vectors::mcols(gr)$context <- as.character(x$context[[i]]) - } - if (is_in("trait", .tupleColumnNames(x))) { - S4Vectors::mcols(gr)$trait <- as.character(x$trait[[i]]) - } - } - gr + if (length(gr) == 0L) { + return(gr) + } + cols <- .tupleColumnNames(x) + labels <- c( + list(study = as.character(x$study[[i]])), + compact(list( + context = if (is_in("context", cols)) { + as.character(x$context[[i]]) + }, + trait = if (is_in("trait", cols)) as.character(x$trait[[i]]) + )) + ) + S4Vectors::`mcols<-`( + gr, + value = cbind( + S4Vectors::mcols(gr, use.names = FALSE), + exec(S4Vectors::DataFrame, !!!labels) + ) + ) } @@ -421,8 +485,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (is.null(lbf) || !is.matrix(lbf) || is.na(Lidx) || Lidx > nrow(lbf)) { return(NA_real_) } - lv <- as.numeric(lbf[Lidx, ]) - lv <- lv[is.finite(lv)] + lv <- keep(as.numeric(lbf[Lidx, ]), is.finite) if (length(lv) == 0L) { return(NA_real_) } @@ -567,8 +630,8 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # @noRd .csMethodTag <- function(tl, fit, csCol) { if (!is.null(tl) && is_in(csCol, names(tl))) { - v <- tl[[csCol]] - v <- v[!is.na(v) & str_length(v) > 0L & !str_detect(v, "_0$")] + raw <- tl[[csCol]] + v <- raw[!is.na(raw) & str_length(raw) > 0L & !str_detect(raw, "_0$")] if (length(v) > 0L) { return(str_remove(v[1L], "_[0-9]+$")) } @@ -581,13 +644,16 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # @noRd .csSummaryContext <- function(tl, fit, coverage, csCol, purCol) { Vvec <- if (!is.null(fit$V)) as.numeric(fit$V) else NULL - meanPur <- NULL sp <- fit$sets$purity - if (!is.null(sp)) { - mc <- intersect(c("meanAbsCorr", "mean.abs.corr"), names(sp)) - if (length(mc) > 0L) { - meanPur <- set_names(as.numeric(sp[[mc[1L]]]), rownames(sp)) - } + mc <- if (is.null(sp)) { + character(0) + } else { + intersect(c("meanAbsCorr", "mean.abs.corr"), names(sp)) + } + meanPur <- if (length(mc) == 0L) { + NULL + } else { + set_names(as.numeric(sp[[mc[1L]]]), rownames(sp)) } list( tl = tl, @@ -668,21 +734,29 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # cs_log10bf: strongest member logBF (NA when the column is absent). # @noRd .csLog10Bf <- function(m) { - if (is_in("logBF", names(m))) { - suppressWarnings(max(m$logBF, na.rm = TRUE)) - } else { - NA_real_ + if (!is_in("logBF", names(m))) { + return(NA_real_) } + # Filtering first avoids max()'s empty-input warning entirely, and keeps + # this branch agreeing with the NA_real_ returned above: an empty or + # all-NA column previously yielded -Inf. + v <- m$logBF[is.finite(m$logBF)] + if (length(v) == 0L) NA_real_ else max(v) } # cs_mean_effect: mean conditional effect over the CS (NA when absent). # @noRd .csMeanEffect <- function(m) { - if (is_in("conditional_effect", names(m))) { - suppressWarnings(mean(as.numeric(m$conditional_effect), na.rm = TRUE)) - } else { - NA_real_ + if (!is_in("conditional_effect", names(m))) { + return(NA_real_) } + # suppressWarnings covers only the coercion; the empty case is handled + # explicitly so it returns NA_real_ rather than NaN. + v <- keep( + suppressWarnings(as.numeric(m$conditional_effect)), + is.finite + ) + if (length(v) == 0L) NA_real_ else mean(v) } @@ -693,13 +767,15 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (nrow(tl) == 0L) { return(tl) } - keep <- if (is.null(signalCutoff) || signalCutoff <= 0) { + aboveCutoff <- if (is.null(signalCutoff) || signalCutoff <= 0) { rep(TRUE, nrow(tl)) } else { !is.na(tl$pip) & tl$pip > signalCutoff } - if (!is.null(minPurity)) { - keep <- keep & .fmePurityKeep(tl, minPurity) + keep <- if (is.null(minPurity)) { + aboveCutoff + } else { + aboveCutoff & .fmePurityKeep(tl, minPurity) } .projectPosteriorView(tl[keep, , drop = FALSE]) } @@ -739,8 +815,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { seqnames = str_c("chr", parsed$chrom), ranges = IRanges::IRanges(start = parsed$pos, width = 1L) ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(out) - gr + S4Vectors::`mcols<-`(gr, value = S4Vectors::DataFrame(out)) } @@ -771,17 +846,22 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { alpha <- .adjustPipsRenormAlpha(spec$alpha, cols) nKeep <- length(keepIdx) varAlpha <- alpha[, seq_len(nKeep), drop = FALSE] - fit$alpha <- alpha - fit$pip <- as.numeric(1 - apply(1 - varAlpha, 2L, prod)) - if (length(spec$nullIdx) > 0L) { - fit$null_index <- nKeep + 1L - } - # Recorded BEFORE renormalization: after it every row sums to 1, so the - # share that survived is only knowable at this point. This is the §3.6 - # diagnostic -- always reported, never a filter. - fit$retained_mass <- .adjustPipsRetainedMass(spec$alpha, cols) - fit <- .adjustPipsSubsetVariantSlots(fit, keepIdx, cols, nVariants) - .adjustPipsRebuildAllSets(fit, varAlpha) + subset <- list_assign( + fit, + !!!compact(list( + alpha = alpha, + pip = as.numeric(1 - apply(1 - varAlpha, 2L, prod)), + null_index = if (length(spec$nullIdx) > 0L) nKeep + 1L, + # Recorded BEFORE renormalization: after it every row sums to 1, + # so the share that survived is only knowable at this point. This + # is the §3.6 diagnostic -- always reported, never a filter. + retained_mass = .adjustPipsRetainedMass(spec$alpha, cols) + )) + ) + .adjustPipsRebuildAllSets( + .adjustPipsSubsetVariantSlots(subset, keepIdx, cols, nVariants), + varAlpha + ) } # susieInf / susieAsh carry Omega-weighted per-variant terms whose posterior @@ -903,24 +983,30 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # @noRd .adjustPipsSubsetVariantSlots <- function(fit, keepIdx, cols, nVariants) { p <- list(keepIdx = keepIdx, cols = cols, nVariants = nVariants) - fit$lbf_variable <- .adjustPipsCols( - fit[["lbf_variable"]], - p, - "lbf_variable" - ) - fit$mu <- .adjustPipsCols(fit[["mu"]], p, "mu") - fit$mu2 <- .adjustPipsCols(fit[["mu2"]], p, "mu2") - fit$mu2_diag <- .adjustPipsCols(fit[["mu2_diag"]], p, "mu2_diag") - fit$clfsr <- .adjustPipsCols(fit[["clfsr"]], p, "clfsr") - fit$coef <- .adjustPipsRows(fit[["coef"]], p, "coef") - fit$X_column_scale_factors <- .adjustPipsVec( - fit[["X_column_scale_factors"]], - p, - "X_column_scale_factors" + # compact(): a slot the fit never carried subsets to NULL, and adding it + # back as an explicit NULL element is not the same as leaving it out. + list_assign( + fit, + !!!compact(list( + lbf_variable = .adjustPipsCols( + fit[["lbf_variable"]], + p, + "lbf_variable" + ), + mu = .adjustPipsCols(fit[["mu"]], p, "mu"), + mu2 = .adjustPipsCols(fit[["mu2"]], p, "mu2"), + mu2_diag = .adjustPipsCols(fit[["mu2_diag"]], p, "mu2_diag"), + clfsr = .adjustPipsCols(fit[["clfsr"]], p, "clfsr"), + coef = .adjustPipsRows(fit[["coef"]], p, "coef"), + X_column_scale_factors = .adjustPipsVec( + fit[["X_column_scale_factors"]], + p, + "X_column_scale_factors" + ), + XtXr = .adjustPipsVec(fit[["XtXr"]], p, "XtXr"), + pi = .adjustPipsVec(fit[["pi"]], p, "pi") + )) ) - fit$XtXr <- .adjustPipsVec(fit[["XtXr"]], p, "XtXr") - fit$pi <- .adjustPipsVec(fit[["pi"]], p, "pi") - fit } # Index set for a slot measured along its variant axis: `nVariants` selects the @@ -985,22 +1071,26 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # stale. # @noRd .adjustPipsRebuildAllSets <- function(fit, varAlpha) { - if (!is.null(fit[["sets"]])) { - fit$sets <- .adjustPipsCsAtCoverage( - varAlpha, - fit[["V"]], - .adjustPipsCoverage(fit[["sets"]]) - ) - } - if (!is.null(fit[["sets_secondary"]])) { - fit$sets_secondary <- map( - fit[["sets_secondary"]], - .adjustPipsRebuildSecondary, - varAlpha = varAlpha, - V = fit[["V"]] - ) - } - fit + list_assign( + fit, + !!!compact(list( + sets = if (!is.null(fit[["sets"]])) { + .adjustPipsCsAtCoverage( + varAlpha, + fit[["V"]], + .adjustPipsCoverage(fit[["sets"]]) + ) + }, + sets_secondary = if (!is.null(fit[["sets_secondary"]])) { + map( + fit[["sets_secondary"]], + .adjustPipsRebuildSecondary, + varAlpha = varAlpha, + V = fit[["V"]] + ) + } + )) + ) } # Rebuild one secondary-coverage credible-set table at its own coverage. @@ -1009,12 +1099,14 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (is.null(entry$sets)) { return(entry) } - entry$sets <- .adjustPipsCsAtCoverage( - varAlpha, - V, - .adjustPipsCoverage(entry$sets) + list_assign( + entry, + sets = .adjustPipsCsAtCoverage( + varAlpha, + V, + .adjustPipsCoverage(entry$sets) + ) ) - entry } # Requested coverage recorded on a susie_get_cs() result (0.95 when absent). @@ -1095,8 +1187,10 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (nrow(topLoci) == 0L) { return(topLoci) } - newTopLoci <- filter(topLoci, is_in(.data$variant_id, common)) - newTopLoci$pip <- as.numeric(fit[["pip"]]) + newTopLoci <- mutate( + filter(topLoci, is_in(.data$variant_id, common)), + pip = as.numeric(fit[["pip"]]) + ) .adjustPipsRelabelCs(.adjustPipsPosterior(newTopLoci, fit), fit) } @@ -1111,20 +1205,35 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { } varAlpha <- .adjustPipsVariantAlpha(fit) label <- .adjustPipsMethodLabel(tl) - for (csCol in csCols) { - tl[[csCol]] <- .adjustPipsCsLabels( - varAlpha, - fit[["V"]], - csCol, - label, - nrow(tl) - ) - purCol <- str_c(csCol, "_purity") - if (is_in(purCol, names(tl))) { - tl[[purCol]] <- NA_real_ - } - } - tl + relabelled <- set_names( + map( + csCols, + .adjustPipsRelabelColumn, + varAlpha = varAlpha, + fit = fit, + label = label, + nRow = nrow(tl) + ), + csCols + ) + # Purity no longer describes the recomputed sets, so every purity column + # that exists alongside a relabelled one is blanked. + purCols <- intersect(str_c(csCols, "_purity"), names(tl)) + blanked <- set_names( + map(purCols, .adjustPipsBlankPurity, nRow = nrow(tl)), + purCols + ) + mutate(tl, !!!relabelled, !!!blanked) +} + +# @noRd +.adjustPipsRelabelColumn <- function(csCol, varAlpha, fit, label, nRow) { + .adjustPipsCsLabels(varAlpha, fit[["V"]], csCol, label, nRow) +} + +# @noRd +.adjustPipsBlankPurity <- function(purCol, nRow) { + rep(NA_real_, nRow) } # Membership labels at the coverage encoded in the column name: "_" @@ -1133,11 +1242,28 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { .adjustPipsCsLabels <- function(varAlpha, V, csCol, label, n) { coverage <- as.numeric(str_remove(csCol, "^cs_")) / 100 sets <- .adjustPipsCsAtCoverage(varAlpha, V, coverage) - out <- rep(str_c(label, "_0"), n) - for (k in seq_along(sets$cs)) { - out[sets$cs[[k]]] <- str_c(label, "_", sets$cs_index[[k]]) - } - out + if (length(sets$cs) == 0L) { + return(rep(str_c(label, "_0"), n)) + } + # Later sets overwrite earlier ones at a shared variant, as the running + # assignment did; one scatter replaces the per-set writes. + at <- list_c(sets$cs) + names <- list_c(map( + seq_along(sets$cs), + .adjustPipsSetLabels, + sets = sets, + label = label + )) + replace(rep(str_c(label, "_0"), n), at, names) +} + +# One set's label, repeated across its members. +# @noRd +.adjustPipsSetLabels <- function(k, sets, label) { + rep( + str_c(label, "_", sets$cs_index[[k]]), + length(sets$cs[[k]]) + ) } # The method label topLoci uses to prefix credible-set names. @@ -1146,8 +1272,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (!is_in("method", names(tl))) { return("cs") } - labels <- unique(as.character(tl$method)) - labels <- labels[!is.na(labels)] + labels <- discard(unique(as.character(tl$method)), is.na) if (length(labels) == 0L) { return("cs") } @@ -1171,15 +1296,22 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { ) { return(newTopLoci) } - newTopLoci$posterior_mean <- as.numeric(colSums(alphaMat * muMat)) + posteriorMean <- as.numeric(colSums(alphaMat * muMat)) mu2Mat <- if (!is.null(fit[["mu2"]])) as.matrix(fit[["mu2"]]) else NULL - if (!is.null(mu2Mat) && all(dim(alphaMat) == dim(mu2Mat))) { - newTopLoci$posterior_sd <- as.numeric(sqrt(pmax( - colSums(alphaMat * mu2Mat) - newTopLoci$posterior_mean^2, - 0 - ))) - } - newTopLoci + mutate( + newTopLoci, + posterior_mean = posteriorMean, + !!!compact(list( + posterior_sd = if ( + !is.null(mu2Mat) && all(dim(alphaMat) == dim(mu2Mat)) + ) { + as.numeric(sqrt(pmax( + colSums(alphaMat * mu2Mat) - posteriorMean^2, + 0 + ))) + } + )) + ) } @@ -1233,10 +1365,13 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { pip = .tlCol(tl, "pip", "numeric"), logBF = .tlCol(tl, "logBF", "numeric") ) - for (cc in .projectPosteriorExtraCols(tl)) { - out[[cc]] <- tl[[cc]] - } - out + extras <- .projectPosteriorExtraCols(tl) + mutate(out, !!!set_names(map(extras, .tlColumnOf, tl = tl), extras)) +} + +# @noRd +.tlColumnOf <- function(cc, tl) { + tl[[cc]] } # Empty posterior-view frame (canonical columns, zero rows). @@ -1427,7 +1562,7 @@ setMethod("show", "FineMappingRow", function(object) { nCs <- if (nrow(tl) > 0L) { csCols <- names(tl)[str_detect(names(tl), "^cs_[0-9]+$")] if (length(csCols) > 0L) { - length(unique(unlist(map(csCols, .fmeNonNullCsLabels, tl = tl)))) + length(unique(list_c(map(csCols, .fmeNonNullCsLabels, tl = tl)))) } else { 0L } diff --git a/R/fineMappingWrappers.R b/R/fineMappingWrappers.R index 19cd4134..e466c93c 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -60,14 +60,11 @@ lbfToAlphaVector <- function(lbf, priorWeights = NULL) { #' @export lbfToAlpha <- function(lbf) { alphaMatrix <- t(apply(as.matrix(lbf), 1, lbfToAlphaVector)) - if (ncol(lbf) == 1) { - alphaMatrix <- matrix( - alphaMatrix, - ncol = 1, - dimnames = list(NULL, colnames(lbf)) - ) + if (ncol(lbf) != 1) { + return(alphaMatrix) } - return(alphaMatrix) + # t() turns a single-column lbf into a row vector; restore the shape. + matrix(alphaMatrix, ncol = 1, dimnames = list(NULL, colnames(lbf))) } formatPipColumn <- function(method) { @@ -116,15 +113,22 @@ formatCsColumn <- function(coverage, method) { map_chr(coverage, .translateOneLegacyCsColumn) } +# The legacy per-method `pip_susie` column is the plain `pip` column unless +# the table already carries one. +# @noRd +.translateLegacyTopLociNames <- function(nms) { + translated <- .translateLegacyCsColumnName(nms) + if (is_in("pip", translated)) { + return(translated) + } + if_else(translated == "pip_susie", "pip", translated) +} + .translateLegacyTopLociCsColumns <- function(topLoci) { if (!is.data.frame(topLoci)) { return(topLoci) } - names(topLoci) <- .translateLegacyCsColumnName(names(topLoci)) - if (is_in("pip_susie", names(topLoci)) && !is_in("pip", names(topLoci))) { - names(topLoci)[names(topLoci) == "pip_susie"] <- "pip" - } - topLoci + `names<-`(topLoci, .translateLegacyTopLociNames(names(topLoci))) } # Translate a camelCase pecotmr method identifier (e.g. "susieInfRss") into the @@ -161,10 +165,10 @@ formatCsColumn <- function(coverage, method) { mvsusie = "mvsusie", NULL ) - if (!is.null(methodClass)) { - class(fit) <- unique(c(methodClass, class(fit))) + if (is.null(methodClass)) { + return(fit) } - fit + `class<-`(fit, unique(c(methodClass, class(fit)))) } # Build the argument list for a SuSiE / SuSiE-ash fit initialised from a @@ -178,25 +182,26 @@ prepareSusieFromInfArgs <- function( unmappableEffects = c("none", "ash") ) { unmappableEffects <- arg_match(unmappableEffects) - L <- args[["L"]] - if (is.null(L)) { - L <- length(susieInfFit$V) - } - if (is.null(args[["refine"]]) && !is.null(refineDefault)) { - args[["refine"]] <- refineDefault - } - args[["unmappable_effects"]] <- unmappableEffects - args[["model_init"]] <- susieInfFit - if (unmappableEffects == "ash") { - args[["convergence_method"]] <- args[["convergence_method"]] %||% "pip" - } - if (!is.null(args[["L_greedy"]])) { - args[["L_greedy"]] <- min(length(susieInfFit$V), L) - } - args + L <- args[["L"]] %||% length(susieInfFit$V) + list_assign( + args, + unmappable_effects = unmappableEffects, + model_init = susieInfFit, + !!!compact(list( + refine = if (is.null(args[["refine"]])) refineDefault, + convergence_method = if (unmappableEffects == "ash") { + args[["convergence_method"]] %||% "pip" + }, + # Clamped, not passed through raw: a caller's L_greedy above the + # number of inf effects would ask susie for effects it cannot warm- + # start. + L_greedy = if (!is.null(args[["L_greedy"]])) { + min(length(susieInfFit$V), L) + } + )) + ) } -#' @importFrom utils modifyList #' @noRd fitSusieInfThenSusie <- function( X, @@ -209,31 +214,27 @@ fitSusieInfThenSusie <- function( # 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"]] - if (is.null(susieInfFit)) { - susieInfFit <- .fmFitSusieIndiv( + cached <- fittedModels %||% list() + susieInfFit <- if (is.null(cached[["susieInf"]])) { + .fmFitSusieIndiv( X, y, "susieInf", - userArgs = modifyList(args, susieInfArgs) + userArgs = list_modify(args, !!!compact(susieInfArgs)) ) } else { - susieInfFit <- .setFinemappingFitClass(susieInfFit, "susieInf") + .setFinemappingFitClass(cached[["susieInf"]], "susieInf") } - susieFit <- fittedModels[["susie"]] - if (is.null(susieFit)) { - susieFit <- .fmFitSusieIndiv( + susieFit <- if (is.null(cached[["susie"]])) { + .fmFitSusieIndiv( X, y, "susie", chainFromInf = susieInfFit, - userArgs = modifyList(args, susieArgs) + userArgs = list_modify(args, !!!compact(susieArgs)) ) } else { - susieFit <- .setFinemappingFitClass(susieFit, "susie") + .setFinemappingFitClass(cached[["susie"]], "susie") } list(susie = susieFit, susieInf = susieInfFit) } @@ -269,6 +270,7 @@ fitSusieInfThenSusie <- function( #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) #' fitSusieInfThenSusieRss(z = stat$z, R = LD, n = nrow(X)) +#' @importFrom checkmate assertNumeric assertNumber assertList #' @export fitSusieInfThenSusieRss <- function( z, @@ -279,36 +281,35 @@ fitSusieInfThenSusieRss <- function( susieArgs = list(), fittedModels = NULL ) { + assertNumeric(z) + assertNumber(n, lower = 0, finite = TRUE) + assertList(args) + assertList(susieInfArgs) + assertList(susieArgs) + assertList(fittedModels, null.ok = TRUE) # 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"]] - if (is.null(susieInfFit)) { - susieInfFit <- .fmFitSusieRss( + cached <- fittedModels %||% list() + infRaw <- cached[["susieInf"]] %||% + .fmFitSusieRss( z, R, n, "susieInf", - userArgs = modifyList(args, susieInfArgs) + userArgs = list_modify(args, !!!compact(susieInfArgs)) ) - } - susieInfFit <- .setFinemappingFitClass(susieInfFit, "susieInf") - susieFit <- fittedModels[["susie"]] - if (is.null(susieFit)) { - susieFit <- .fmFitSusieRss( + susieInfFit <- .setFinemappingFitClass(infRaw, "susieInf") + susieRaw <- cached[["susie"]] %||% + .fmFitSusieRss( z, R, n, "susie", chainFromInf = susieInfFit, - userArgs = modifyList(args, susieArgs) + userArgs = list_modify(args, !!!compact(susieArgs)) ) - } - susieFit <- .setFinemappingFitClass(susieFit, "susieRss") - + susieFit <- .setFinemappingFitClass(susieRaw, "susieRss") list(susie = susieFit, susieInf = susieInfFit) } @@ -386,7 +387,6 @@ postprocessFinemappingFits <- function( fullFitAlphaOnly = TRUE, includeAllCs = FALSE ) { - p <- as.list(environment()) fits <- fits[!map_lgl(fits, is.null)] if (length(fits) == 0) { abort("At least one fine-mapping fit must be supplied.") @@ -394,22 +394,88 @@ postprocessFinemappingFits <- function( if (is.null(names(fits)) || any(names(fits) == "")) { abort("fits must be a named list; names define method identity.") } - .ppFitsCombine(.ppFitsPerMethod(fits, p)) + .ppFitsCombine(.ppFitsPerMethod( + fits, + dataX = dataX, + dataY = dataY, + xScalar = xScalar, + yScalar = yScalar, + af = af, + n = n, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + otherQuantities = otherQuantities, + region = region, + priorEffTol = priorEffTol, + minAbsCorr = minAbsCorr, + medianAbsCorr = medianAbsCorr, + csInput = csInput, + conditionIdx = conditionIdx, + trim = trim, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs + )) } # Post-process each method's fit once (buildTopLoci per fit); the per-method # 22-column contributions are row-bound later into the single top_loci table. -.ppFitsPerMethod <- function(fits, p) { - posts <- map(names(fits), .ppOneFit, fits = fits, p = p) - names(posts) <- names(fits) - posts +.ppFitsPerMethod <- function( + fits, + dataX, + dataY, + xScalar, + yScalar, + af, + n, + coverage, + secondaryCoverage, + signalCutoff, + otherQuantities, + region, + priorEffTol, + minAbsCorr, + medianAbsCorr, + csInput, + conditionIdx, + trim, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { + posts <- map( + names(fits), + .ppOneFit, + fits = fits, + dataX = dataX, + dataY = dataY, + xScalar = xScalar, + yScalar = yScalar, + af = af, + n = n, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + otherQuantities = otherQuantities, + region = region, + priorEffTol = priorEffTol, + minAbsCorr = minAbsCorr, + medianAbsCorr = medianAbsCorr, + csInput = csInput, + conditionIdx = conditionIdx, + trim = trim, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs + ) + set_names(posts, names(fits)) } # Row-bind the per-method top_loci tables and drop them from the per-method # entries; returns the final finemappingResults + combined top_loci. .ppFitsCombine <- function(posts) { - perMethod <- map(posts, "top_loci") - perMethod <- perMethod[!map_lgl(perMethod, is.null)] + perMethod <- compact(map(posts, "top_loci")) topLoci <- if (length(perMethod) == 0L) { .emptyTopLoci() } else { @@ -538,114 +604,196 @@ postprocessFinemappingFit.susiF <- function( csInput = c("X", "Xcorr", "fsusie") ) { csInput <- arg_match(csInput) - p <- as.list(environment()) variantNames <- extractVariantNames(fit) sumstats <- extractSumstats(fit, dataX, dataY, xScalar, yScalar, method) - csTables <- .ppCsTables(p, csInput) + csTables <- .ppCsTables( + csInput, + fit = fit, + dataX = dataX, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + minAbsCorr = minAbsCorr, + medianAbsCorr = medianAbsCorr, + method = method + ) # Always build the canonical unfiltered table; the FineMappingRow stores # it as-is so accessors can filter by PIP at query time. - topLociFull <- .ppTopLoci(p, csTables, variantNames, sumstats) + topLociFull <- .ppTopLoci( + csTables, + variantNames, + sumstats, + fit = fit, + method = method, + af = af, + n = n, + signalCutoff = signalCutoff, + dataY = dataY, + otherQuantities = otherQuantities, + region = region, + conditionIdx = conditionIdx, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs + ) fmEntry <- fineMappingRow( variantIds = variantNames, - susieFit = .ppStoredFit(p, csTables), + susieFit = .ppStoredFit( + csTables, + fit = fit, + trim = trim, + priorEffTol = priorEffTol, + method = method + ), topLoci = topLociFull ) - .ppAssembleRes(p, topLociFull, fmEntry, sumstats) + .ppAssembleRes( + topLociFull, + fmEntry, + sumstats, + fit = fit, + method = method, + dataY = dataY, + otherQuantities = otherQuantities, + signalCutoff = signalCutoff + ) } # The fit as stored: trim = TRUE keeps a minimal subset, FALSE the full # untrimmed susie return (mu / mu2 / lbf_variable / V / ...). # @noRd -.ppStoredFit <- function(p, csTables) { - if (!isTRUE(p$trim)) { - return(p$fit) +.ppStoredFit <- function( + csTables, + fit, + trim, + priorEffTol, + method +) { + if (!isTRUE(trim)) { + return(fit) } trimFinemappingFit( - p$fit, - selectEffects(p$fit, p$priorEffTol), - p$method, + fit, + selectEffects(fit, priorEffTol), + method, csTables ) } # Credible-set tables for the fit at the requested coverages. -.ppCsTables <- function(p, csInput) { +.ppCsTables <- function( + csInput, + fit, + dataX, + coverage, + secondaryCoverage, + minAbsCorr, + medianAbsCorr, + method +) { computeCsTables( - p$fit, - dataX = p$dataX, - coverage = p$coverage, - secondaryCoverage = p$secondaryCoverage, - method = p$method, + fit, + dataX = dataX, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + method = method, csInput = csInput, - minAbsCorr = p$minAbsCorr, - medianAbsCorr = p$medianAbsCorr + minAbsCorr = minAbsCorr, + medianAbsCorr = medianAbsCorr ) } # Canonical unfiltered top-loci table (signalCutoff = 0). -.ppTopLoci <- function(p, csTables, variantNames, sumstats) { +.ppTopLoci <- function( + csTables, + variantNames, + sumstats, + fit, + method, + af, + n, + signalCutoff, + dataY, + otherQuantities, + region, + conditionIdx, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { buildTopLoci( - p$fit, + fit, csTables, variantNames = variantNames, sumstats = sumstats, - af = p$af, - n = p$n, - method = p$method, + af = af, + n = n, + method = method, signalCutoff = 0, - dataY = p$dataY, - otherQuantities = p$otherQuantities, - region = p$region, - conditionIdx = p$conditionIdx, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs + dataY = dataY, + otherQuantities = otherQuantities, + region = region, + conditionIdx = conditionIdx, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs ) } # Assemble the wrapper-facing result: PIP-filtered top_loci (legacy behaviour # for non-S4 callers) + the entry + optional sumstats/sampleNames/context. -.ppAssembleRes <- function(p, topLociFull, fmEntry, sumstats) { - topLociWrapper <- topLociFull - if ( - !is.null(p$signalCutoff) && - p$signalCutoff > 0 && - nrow(topLociWrapper) > 0L - ) { - keep <- !is.na(topLociWrapper$pip) & - topLociWrapper$pip > p$signalCutoff - topLociWrapper <- topLociWrapper[keep, , drop = FALSE] - } - res <- list( - top_loci = topLociWrapper, - finemappingEntry = fmEntry, - method = p$method - ) - if (!is.null(sumstats)) { - res$sumstats <- sumstats - } - sampleNames <- .sampleNamesFromDataY(p$dataY) - if (!is.null(sampleNames)) { - res$sampleNames <- sampleNames - } - if (p$method == "mvsusie" && !is.null(p$fit$outcome_names)) { - res$contextNames <- p$fit$outcome_names - } - if (!is.null(p$otherQuantities)) { - res$otherQuantities <- p$otherQuantities +.ppAssembleRes <- function( + topLociFull, + fmEntry, + sumstats, + fit, + method, + dataY, + otherQuantities, + signalCutoff +) { + filtering <- !is.null(signalCutoff) && + signalCutoff > 0 && + nrow(topLociFull) > 0L + topLociWrapper <- if (!filtering) { + topLociFull + } else { + topLociFull[ + !is.na(topLociFull$pip) & topLociFull$pip > signalCutoff, + , + drop = FALSE + ] } - res + c( + list( + top_loci = topLociWrapper, + finemappingEntry = fmEntry, + method = method + ), + compact(list( + sumstats = sumstats, + sampleNames = .sampleNamesFromDataY(dataY), + contextNames = if (method == "mvsusie") fit$outcome_names, + otherQuantities = otherQuantities + )) + ) } extractVariantNames <- function(fit) { - variantNames <- names(fit$pip) - if (is.null(variantNames)) { - variantNames <- colnames(fit$alpha) - } - if (is.null(variantNames)) { - variantNames <- str_c("variant_", seq_along(fit$pip)) - } - tryCatch(normalizeVariantId(variantNames), error = function(e) variantNames) + variantNames <- names(fit$pip) %||% + colnames(fit$alpha) %||% + str_c("variant_", seq_along(fit$pip)) + try_fetch( + normalizeVariantId(variantNames), + error = function(cnd) { + msg <- glue( + "variant ids could not be normalised; using them as given. ", + "Downstream joins that assume the canonical form may not ", + "match." + ) + warn(msg, parent = cnd) + variantNames + } + ) } extractSumstats <- function( @@ -678,9 +826,12 @@ extractSumstats <- function( sumstats <- univariate_regression(dataX, dataY) yScalar <- if (is.null(yScalar) || all(yScalar == 1)) 1 else yScalar xScalar <- if (is.null(xScalar) || all(xScalar == 1)) 1 else xScalar - sumstats$betahat <- sumstats$betahat * yScalar / xScalar - sumstats$sebetahat <- sumstats$sebetahat * yScalar / xScalar - sumstats + scale <- yScalar / xScalar + list_assign( + sumstats, + betahat = sumstats$betahat * scale, + sebetahat = sumstats$sebetahat * scale + ) } .sampleNamesFromDataY <- function(dataY) { @@ -761,15 +912,11 @@ computeCsTables <- function( medianAbsCorr = NULL ) { csInput <- arg_match(csInput) - primaryCoverage <- coverage - if (is.null(primaryCoverage)) { - primaryCoverage <- fit$sets$requested_coverage - } - if (is.null(primaryCoverage)) { - primaryCoverage <- 0.95 - } - coverages <- unique(c(primaryCoverage, secondaryCoverage)) - coverages <- coverages[!is.na(coverages)] + primaryCoverage <- coverage %||% fit$sets$requested_coverage %||% 0.95 + coverages <- discard( + unique(c(primaryCoverage, secondaryCoverage)), + is.na + ) tables <- map( coverages, @@ -780,13 +927,11 @@ computeCsTables <- function( minAbsCorr = minAbsCorr, medianAbsCorr = medianAbsCorr ) - names(tables) <- map_chr( - coverages, - formatCsColumn, - method = method + named <- set_names( + tables, + map_chr(coverages, formatCsColumn, method = method) ) - attr(tables, "coverage") <- coverages - tables + `attr<-`(named, "coverage", coverages) } computeCsTable <- function( @@ -804,32 +949,43 @@ computeCsTable <- function( .csTableSusie(fit, dataX, coverage, csInput, minAbsCorr, medianAbsCorr) } +# The credible sets with the within-CS purity attached, when fsusieR is +# available and returns one purity value per set. +# @noRd +.fsusieSetsWithPurity <- function(sets, dataX) { + if (!requireNamespace("fsusieR", quietly = TRUE)) { + return(sets) + } + purity <- try_fetch( + # cal_purity returns one length-1 numeric per credible set, so + # list_c() is exactly equivalent and refuses a non-numeric or + # non-scalar element instead of silently producing a longer + # vector that the length check below would then reject. + as.numeric(list_c(fsusieR::cal_purity(sets$cs, dataX))), + error = function(cnd) NULL + ) + if (is.null(purity) || length(purity) != length(sets$cs)) { + return(sets) + } + list_assign(sets, purity = tibble(min.abs.corr = purity)) +} + # fSuSiE credible sets: purity is the min |correlation| WITHIN each CS # (fsusieR::cal_purity), recorded as sets$purity$min.abs.corr for the canonical # .csPurityVec() reader; cs_corr keeps the BETWEEN-CS correlation matrix. .csTableFsusie <- function(fit, dataX, coverage) { - sets <- tryCatch( + sets <- try_fetch( fsusieGetCs(fit, dataX, requestedCoverage = coverage), - error = function(e) list(cs = list(), requested_coverage = coverage) + error = function(cnd) list(cs = list(), requested_coverage = coverage) ) if ( is.null(sets$cs) || length(sets$cs) == 0 || all(map_lgl(sets$cs, is.null)) ) { - sets$cs <- list() - return(list(sets = sets, pip = fit$pip)) - } - if (requireNamespace("fsusieR", quietly = TRUE)) { - purity <- tryCatch( - as.numeric(unlist(fsusieR::cal_purity(sets$cs, dataX))), - error = function(e) NULL - ) - if (!is.null(purity) && length(purity) == length(sets$cs)) { - sets$purity <- tibble(min.abs.corr = purity) - } + return(list(sets = list_assign(sets, cs = list()), pip = fit$pip)) } - list(sets = sets, pip = fit$pip) + list(sets = .fsusieSetsWithPurity(sets, dataX), pip = fit$pip) } # susieR credible sets from X (correlation computed on genotypes) or Xcorr @@ -842,13 +998,13 @@ computeCsTable <- function( minAbsCorr, medianAbsCorr ) { - csArgs <- list(coverage = coverage) - if (!is.null(minAbsCorr)) { - csArgs$min_abs_corr <- minAbsCorr - } - if (!is.null(medianAbsCorr)) { - csArgs$median_abs_corr <- medianAbsCorr - } + csArgs <- c( + list(coverage = coverage), + compact(list( + min_abs_corr = minAbsCorr, + median_abs_corr = medianAbsCorr + )) + ) # X vs Xcorr only changes how susie_get_cs computes purity; the between-CS # correlation is derived on demand later by computeCsCorrelation(), so it is # no longer stored on the fit. @@ -1034,20 +1190,23 @@ setMethod( # Per-variant PIP within its primary-coverage credible set (NA outside any CS). .ffcWithinPip <- function(alpha, primaryCsPos, effectOf, nV, hasAlpha) { - withinPip <- rep(NA_real_, nV) if (!(hasAlpha && length(primaryCsPos) == nV && length(effectOf) > 0L)) { - return(withinPip) - } - for (v in seq_len(nV)) { - cp <- primaryCsPos[[v]] - if (!is.na(cp) && cp >= 1L && cp <= length(effectOf)) { - L <- effectOf[[cp]] - if (!is.na(L) && L >= 1L && L <= nrow(alpha)) { - withinPip[[v]] <- alpha[L, v] - } - } + return(rep(NA_real_, nV)) } - withinPip + # Indexing with NA yields NA, so an out-of-range credible-set position + # drops out on its own rather than needing a per-variant branch. + csOk <- !is.na(primaryCsPos) & + primaryCsPos >= 1L & + primaryCsPos <= length(effectOf) + effect <- effectOf[if_else(csOk, as.integer(primaryCsPos), NA_integer_)] + effectOk <- !is.na(effect) & effect >= 1L & effect <= nrow(alpha) + if (!any(effectOk)) { + return(rep(NA_real_, nV)) + } + # Row 1 stands in wherever the effect is unusable; those entries are + # masked back to NA immediately, and it keeps the index in bounds. + picked <- alpha[cbind(if_else(effectOk, effect, 1L), seq_len(nV))] + if_else(effectOk, picked, NA_real_) } # Wide per-effect columns: within_cs_pip_ always, plus cs_logbf / cs_effect @@ -1078,24 +1237,72 @@ setMethod( if (is.null(scale) || length(scale) != nV) { scale <- rep(1, nV) } - for (i in seq_along(effs)) { - L <- effs[[i]] - lab <- labs[[i]] - cols[[str_c("within_cs_pip_", lab)]] <- unname(alpha[L, ]) - if (!isTRUE(fullFitAlphaOnly)) { - if (!is.null(lbfMat) && L <= nrow(lbfMat)) { - cols[[str_c("cs_logbf_", lab)]] <- unname(lbfMat[L, ]) - } - if (!is.null(mu) && L <= nrow(mu)) { - cols[[str_c("cs_effect_", lab)]] <- unname(mu[L, ] / scale) - } - if (!is.null(mu) && !is.null(mu2) && L <= nrow(mu2)) { - cols[[str_c("cs_effect_var_", lab)]] <- - unname((mu2[L, ] - mu[L, ]^2) / scale^2) - } - } + perEffect <- map( + seq_along(effs), + .ffcEffectColumns, + effs = effs, + labs = labs, + alpha = alpha, + mu = mu, + mu2 = mu2, + lbfMat = lbfMat, + scale = scale, + fullFitAlphaOnly = fullFitAlphaOnly + ) + mutate(cols, !!!.fmwConcat(perEffect)) +} + +# Concatenate per-item lists, empty-safe. +# @noRd +.fmwConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) + } + list_c(pieces) +} + +# One effect's wide columns: the within-CS PIP always, plus the log-BF and +# effect columns when the fit carries them. +# @noRd +.ffcEffectColumns <- function( + i, + effs, + labs, + alpha, + mu, + mu2, + lbfMat, + scale, + fullFitAlphaOnly +) { + L <- effs[[i]] + lab <- labs[[i]] + pip <- set_names( + list(unname(alpha[L, ])), + str_c("within_cs_pip_", lab) + ) + if (isTRUE(fullFitAlphaOnly)) { + return(pip) + } + logbf <- if (!is.null(lbfMat) && L <= nrow(lbfMat)) { + set_names(list(unname(lbfMat[L, ])), str_c("cs_logbf_", lab)) + } else { + list() + } + effect <- if (!is.null(mu) && L <= nrow(mu)) { + set_names(list(unname(mu[L, ] / scale)), str_c("cs_effect_", lab)) + } else { + list() + } + effectVar <- if (!is.null(mu) && !is.null(mu2) && L <= nrow(mu2)) { + set_names( + list(unname((mu2[L, ] - mu[L, ]^2) / scale^2)), + str_c("cs_effect_var_", lab) + ) + } else { + list() } - cols + c(pip, logbf, effect, effectVar) } # Slice a susie posterior array to the active condition (3-D fit) or coerce a @@ -1124,37 +1331,64 @@ setMethod( nV, variantNames = NULL ) { - out <- integer(nV) + empty <- integer(nV) hit <- which(abs(coverageValues - targetCov) < 1e-12) if (length(hit) == 0L) { - return(out) + return(empty) } sets <- csTables[[hit[1L]]]$sets$cs if (is.null(sets) || length(sets) == 0L) { - return(out) + return(empty) } # A variant in several sets goes to the SMALLEST containing set (ties -> # lowest position, so the answer is deterministic), not to whichever set # happened to come first in the list. Every membership is recorded so the # ambiguity can be reported rather than silently resolved. + # Every (variant, set) membership, flattened. Ordering the memberships by + # set size then set index makes the first one per variant the winner -- + # smallest set, ties to the lowest position -- which is exactly what the + # running "is this smaller than the best so far" comparison decided. setSizes <- lengths(sets) - bestSize <- rep(Inf, nV) - memb <- vector("list", nV) - for (csIdx in seq_along(sets)) { - vi <- as.integer(sets[[csIdx]]) - vi <- vi[vi >= 1L & vi <= nV] - for (v in vi) { - memb[[v]] <- c(memb[[v]], csIdx) - if (setSizes[csIdx] < bestSize[v]) { - out[v] <- csIdx - bestSize[v] <- setSizes[csIdx] - } - } - } + memberships <- map(seq_along(sets), .fmCsMemberships, sets = sets, nV = nV) + variantOf <- .fmwConcatInt(map(memberships, "variant")) + csOf <- .fmwConcatInt(map(memberships, "cs")) + if (length(variantOf) == 0L) { + return(empty) + } + ord <- order(variantOf, setSizes[csOf], csOf) + firstPerVariant <- ord[!duplicated(variantOf[ord])] + winners <- csOf[firstPerVariant] + winnerAt <- variantOf[firstPerVariant] + out <- .fmScatter(empty, winnerAt, winners) + bestSize <- .fmScatter(rep(Inf, nV), winnerAt, setSizes[winners]) + memb <- split(csOf, factor(variantOf, levels = seq_len(nV))) .fmWarnMultiCs(memb, out, bestSize, sets, variantNames) out } +# Place `values` at positions `at` in `base`. The one write the scatter needs, +# named so it reads as a total operation rather than an accumulation. +# @noRd +.fmScatter <- function(base, at, values) { + replace(base, at, values) +} + +# @noRd +.fmwConcatInt <- function(pieces) { + if (length(pieces) == 0L) { + return(integer(0)) + } + list_c(pieces) +} + +# Set `csIdx`'s in-range variant memberships, as parallel (variant, cs) runs. +# @noRd +.fmCsMemberships <- function(csIdx, sets, nV) { + raw <- as.integer(sets[[csIdx]]) + vi <- raw[raw >= 1L & raw <= nV] + list(variant = vi, cs = rep(csIdx, length(vi))) +} + # Name the variants that fell in more than one credible set, and which set won. # @noRd .fmWarnMultiCs <- function(memb, out, bestSize, sets, variantNames) { @@ -1187,10 +1421,10 @@ setMethod( } e <- suppressWarnings(as.integer(str_remove(nm, "^L"))) bad <- is.na(e) - if (any(bad)) { - e[bad] <- seq_along(sets)[bad] + if (!any(bad)) { + return(e) } - e + replace(e, bad, seq_along(sets)[bad]) } # Map a per-variant set-POSITION vector onto the fit's true effect indices; @@ -1211,10 +1445,8 @@ setMethod( return(posVec) } effIdx <- .fmEffectIndices(sets) - out <- integer(length(posVec)) nz <- posVec > 0L - out[nz] <- effIdx[posVec[nz]] - out + replace(integer(length(posVec)), nz, effIdx[posVec[nz]]) } # Per-variant CS purity (min.abs.corr) at coverage `targetCov`; 0 for non-CS @@ -1314,79 +1546,116 @@ buildTopLoci <- function( if (missing(method)) { method <- NULL } - p <- as.list(environment()) .btlValidateMethod(method) if (length(variantNames) == 0L) { return(.emptyTopLoci()) } - .btlBuild(p) + .btlBuild( + fit = fit, + csTables = csTables, + variantNames = variantNames, + sumstats = sumstats, + af = af, + n = n, + method = method, + signalCutoff = signalCutoff, + dataY = dataY, + otherQuantities = otherQuantities, + region = region, + conditionIdx = conditionIdx, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs + ) } -# Orchestrate the top-loci table from the captured argument list `p`. -.btlBuild <- function(p) { - nV <- length(p$variantNames) - cov <- .btlCoverage(p$csTables) - fc <- .btlFitConstants(p$dataY, p$otherQuantities, p$region) - post <- .btlPosterior(p$fit, p$conditionIdx, nV) - marg <- .btlMarginal(p$sumstats, nV) - cs <- .btlCsMembership(cov, p$csTables, nV, p$variantNames) +# Orchestrate the top-loci table from the buildTopLoci() arguments. +.btlBuild <- function( + fit, + csTables, + variantNames, + sumstats, + af, + n, + method, + signalCutoff, + dataY, + otherQuantities, + region, + conditionIdx, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { + nV <- length(variantNames) + cov <- .btlCoverage(csTables) + fc <- .btlFitConstants(dataY, otherQuantities, region) + post <- .btlPosterior(fit, conditionIdx, nV) + marg <- .btlMarginal(sumstats, nV) + cs <- .btlCsMembership(cov, csTables, nV, variantNames) fullFitBlock <- .btlFullFitBlock( - p$fit, + fit, post, cov, cs, - p$csTables, + csTables, nV, - p[c("fullFit", "fullFitAlphaOnly", "includeAllCs")] + list( + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs + ) ) out <- .btlAssemble( - p$variantNames, - .btlParseVariants(p$variantNames), + variantNames, + .btlParseVariants(variantNames), fc, marg, post, - p$fit, - p$af, - p$n, - p$method, - .btlCsBlock(p$method, cs, nV), + fit, + af, + n, + method, + .btlCsBlock(method, cs, nV), fullFitBlock, nV ) cond <- .btlConditional( - p$fit, - p$method, - p$conditionIdx, + fit, + method, + conditionIdx, cov, cs$covSorted, - p$csTables, + csTables, nV ) - .btlFinalize(out, cond, p$conditionIdx, p$signalCutoff) + .btlFinalize(out, cond, conditionIdx, signalCutoff) } # Attach per-condition columns (multi-condition fits) and apply the PIP cutoff. .btlFinalize <- function(out, cond, conditionIdx, signalCutoff) { - if (!is.null(conditionIdx)) { - out$conditional_effect <- cond$condEffect - out$lfsr <- cond$condLfsr + withCond <- if (is.null(conditionIdx)) { + out + } else { + mutate( + out, + conditional_effect = cond$condEffect, + lfsr = cond$condLfsr + ) } - if (!is.null(signalCutoff) && signalCutoff > 0) { - out <- filter(out, !is.na(.data$pip) & .data$pip > signalCutoff) + if (is.null(signalCutoff) || signalCutoff <= 0) { + return(withCond) } - out + filter(withCond, !is.na(.data$pip) & .data$pip > signalCutoff) } # buildTopLoci step helpers --------------------------------------------------- # `method` is required and must be a single non-empty, non-NA string. +#' @importFrom checkmate checkString .btlValidateMethod <- function(method) { - if ( - is.null(method) || - length(method) != 1L || - is.na(method) || - str_length(method) == 0L - ) { + res <- checkString(method, min.chars = 1L) + if (!isTRUE(res)) { abort( "buildTopLoci: `method` is required (e.g. \"susie\", \"susieInf\")." ) @@ -1487,13 +1756,12 @@ buildTopLoci <- function( } # Parse variant IDs to chrom/pos/A1/A2; error on missing or invalid coordinates. +#' @importFrom rlang try_fetch .btlParseVariants <- function(variantNames) { - parsed <- tryCatch( + parsed <- try_fetch( suppressWarnings(parseVariantId(variantNames)), - error = function(e) { - eMsg <- conditionMessage(e) - msg <- glue("buildTopLoci: parseVariantId failed: {eMsg}") - abort(msg) + error = function(cnd) { + abort("buildTopLoci: parseVariantId failed", parent = cnd) } ) if (is.null(parsed) || nrow(parsed) != length(variantNames)) { @@ -1603,7 +1871,7 @@ buildTopLoci <- function( identical(method, "mvsusie") && requireNamespace("mvsusieR", quietly = TRUE) ) { - cm <- tryCatch(mvsusieR::coef.mvsusie(fit), error = function(e) NULL) + cm <- try_fetch(mvsusieR::coef.mvsusie(fit), error = function(cnd) NULL) if (!is.null(cm)) as.matrix(cm)[-1L, , drop = FALSE] else NULL } else { NULL @@ -1646,18 +1914,53 @@ buildTopLoci <- function( return(condLfsr) } effectOf <- suppressWarnings(as.integer(str_remove(names(setsPrim), "^L"))) - for (csPos in seq_along(setsPrim)) { - L <- effectOf[csPos] - if (is.na(L) || L < 1L || L > dim(clf)[1L]) { - next - } - vi <- as.integer(setsPrim[[csPos]]) - vi <- vi[vi >= 1L & vi <= nV] - if (length(vi) > 0L) { - condLfsr[vi] <- as.numeric(clf[L, vi, conditionIdx]) - } + assignments <- compact(map( + seq_along(setsPrim), + .btlCondLfsrForSet, + setsPrim = setsPrim, + effectOf = effectOf, + clf = clf, + conditionIdx = conditionIdx, + nV = nV + )) + # Later sets overwrite earlier ones at a shared variant, as the running + # assignment did; one scatter replaces the per-set writes. + .fmScatter( + condLfsr, + .fmwConcatInt(map(assignments, "variant")), + .fmwConcatDbl(map(assignments, "value")) + ) +} + +# @noRd +.fmwConcatDbl <- function(pieces) { + if (length(pieces) == 0L) { + return(numeric(0)) + } + list_c(pieces) +} + +# One credible set's conditional-lfsr values, or NULL when its effect is out +# of range or it covers no in-range variant. +# @noRd +.btlCondLfsrForSet <- function( + csPos, + setsPrim, + effectOf, + clf, + conditionIdx, + nV +) { + L <- effectOf[csPos] + if (is.na(L) || L < 1L || L > dim(clf)[1L]) { + return(NULL) + } + raw <- as.integer(setsPrim[[csPos]]) + vi <- raw[raw >= 1L & raw <= nV] + if (length(vi) == 0L) { + return(NULL) } - condLfsr + list(variant = vi, value = as.numeric(clf[L, vi, conditionIdx])) } # Per-condition posterior quantities (NA for univariate fits). @@ -1706,6 +2009,24 @@ buildTopLoci <- function( as_tibble(csList, .name_repair = "minimal") } +# The effect indices behind the primary-coverage CS, read off the "L" names +# of its sets$cs. integer(0) when there is no such CS or it names no effects. +# @noRd +.btlPrimaryEffects <- function(coverageValues, cs, csTables) { + if (length(cs$covSorted) == 0L) { + return(integer(0)) + } + hP <- which(abs(coverageValues - cs$covSorted[1L]) < 1e-12) + if (length(hP) == 0L) { + return(integer(0)) + } + spP <- csTables[[hP[1L]]]$sets$cs + if (is.null(spP) || length(spP) == 0L) { + return(integer(0)) + } + suppressWarnings(as.integer(str_remove(names(spP), "^L"))) +} + # within_cs_pip (+ optional fullFit-wide) columns, mapping each variant to its # primary-coverage CS effect (position -> effect via the sets$cs "L" names). .btlFullFitBlock <- function( @@ -1722,18 +2043,7 @@ buildTopLoci <- function( } else { integer(nV) } - effectOfPrim <- integer(0) - if (length(cs$covSorted) > 0L) { - hP <- which(abs(coverageValues - cs$covSorted[1L]) < 1e-12) - if (length(hP) > 0L) { - spP <- csTables[[hP[1L]]]$sets$cs - if (!is.null(spP) && length(spP) > 0L) { - effectOfPrim <- suppressWarnings( - as.integer(str_remove(names(spP), "^L")) - ) - } - } - } + effectOfPrim <- .btlPrimaryEffects(coverageValues, cs, csTables) .fullFitColumns( post$alpha, post$mu, @@ -1842,9 +2152,10 @@ buildTopLoci <- function( ) { return(c(start = NA_integer_, end = NA_integer_)) } - pr <- tryCatch(parseRegion(as.character(regionStr)), error = function(e) { - NULL - }) + pr <- try_fetch( + parseRegion(as.character(regionStr)), + error = function(cnd) NULL + ) if (is.null(pr) || !is.data.frame(pr)) { return(c(start = NA_integer_, end = NA_integer_)) } @@ -1852,19 +2163,22 @@ buildTopLoci <- function( } trimFinemappingFit <- function(fit, effectIdx, method, csTables) { - trimmed <- .trimBaseFit(fit, effectIdx, csTables) - trimmed <- .trimAddCommon(trimmed, fit, effectIdx) - if (method == "mvsusie") { - trimmed <- .trimAddMvsusie(trimmed, fit, effectIdx) + common <- .trimBaseFit(fit, effectIdx, csTables) |> + .trimAddCommon(fit, effectIdx) + trimmed <- if (method == "mvsusie") { + .trimAddMvsusie(common, fit, effectIdx) + } else { + common } # fSuSiE: keep the precomputed variants x features TWAS weight matrix # (fsusieWeights output, attached as $coef before trimming) so downstream # TWAS can read it without the dropped wavelet slots. - if (method == "fsusie" && !is.null(fit$coef)) { - trimmed$coef <- fit$coef + withCoef <- if (method == "fsusie" && !is.null(fit$coef)) { + list_assign(trimmed, coef = fit$coef) + } else { + trimmed } - class(trimmed) <- unique(c(method, "susie")) - trimmed + `class<-`(withCoef, unique(c(method, "susie"))) } # The minimal always-kept subset of a susie fit (pip, credible sets, effect @@ -1898,30 +2212,30 @@ trimFinemappingFit <- function(fit, effectIdx, method, csTables) { # Optional slots common to susie/mvsusie: column scales, posterior mu/mu2 # (L x p, or L x p x R for multivariate), theta, omega_weights. .trimAddCommon <- function(trimmed, fit, effectIdx) { - if (!is.null(fit$X_column_scale_factors)) { - trimmed$X_column_scale_factors <- fit$X_column_scale_factors - } - if (!is.null(fit$mu)) { - trimmed$mu <- if (length(dim(fit$mu)) == 3) { - fit$mu[effectIdx, , , drop = FALSE] - } else { - fit$mu[effectIdx, , drop = FALSE] - } - } - if (!is.null(fit$mu2)) { - trimmed$mu2 <- if (length(dim(fit$mu2)) == 3) { - fit$mu2[effectIdx, , , drop = FALSE] - } else { - fit$mu2[effectIdx, , drop = FALSE] - } - } - if (!is.null(fit$theta)) { - trimmed$theta <- fit$theta + withCommon <- list_assign( + trimmed, + !!!compact(list( + X_column_scale_factors = fit$X_column_scale_factors, + mu = .trimEffectSlice(fit$mu, effectIdx), + mu2 = .trimEffectSlice(fit$mu2, effectIdx), + theta = fit$theta, + omega_weights = fit$omega_weights + )) + ) + .trimAddScalars(withCommon, fit) +} + +# The selected effects of a posterior array, which is L x p for a univariate +# fit and L x p x R for a multivariate one. +# @noRd +.trimEffectSlice <- function(x, effectIdx) { + if (is.null(x)) { + return(NULL) } - if (!is.null(fit$omega_weights)) { - trimmed$omega_weights <- fit$omega_weights + if (length(dim(x)) == 3) { + return(x[effectIdx, , , drop = FALSE]) } - .trimAddScalars(trimmed, fit) + x[effectIdx, , drop = FALSE] } # Cheap fields that are not effect-indexed, kept so a trimmed fit is sufficient @@ -1954,23 +2268,26 @@ trimFinemappingFit <- function(fit, effectIdx, method, csTables) { if (is.null(value)) { return(trimmed) } - trimmed[[nm]] <- value - trimmed + list_assign(trimmed, !!!set_names(list(value), nm)) } # mvsusie-specific slots: per-effect mu2_diag, the coefficient matrix, and the # conditional lfsr array. .trimAddMvsusie <- function(trimmed, fit, effectIdx) { - if (!is.null(fit$mu2_diag)) { - trimmed$mu2_diag <- fit$mu2_diag[effectIdx, , , drop = FALSE] - } - if (requireNamespace("mvsusieR", quietly = TRUE)) { - trimmed$coef <- mvsusieR::coef.mvsusie(fit)[-1, , drop = FALSE] - } - if (!is.null(fit$conditional_lfsr)) { - trimmed$clfsr <- fit$conditional_lfsr[effectIdx, , , drop = FALSE] - } - trimmed + list_assign( + trimmed, + !!!compact(list( + mu2_diag = if (!is.null(fit$mu2_diag)) { + fit$mu2_diag[effectIdx, , , drop = FALSE] + }, + coef = if (requireNamespace("mvsusieR", quietly = TRUE)) { + mvsusieR::coef.mvsusie(fit)[-1, , drop = FALSE] + }, + clfsr = if (!is.null(fit$conditional_lfsr)) { + fit$conditional_lfsr[effectIdx, , , drop = FALSE] + } + )) + ) } #' Format Fine-mapping Post-processing for Protocol Output @@ -2022,7 +2339,10 @@ getCsIndex <- function(snpsIdx, susieCs) { } #' @noRd getTopVariantsIdx <- function(susieOutput, signalCutoff) { - c(which(susieOutput$pip >= signalCutoff), unlist(susieOutput$sets$cs)) |> + # `sets$cs` is absent when no credible set was found; list_c() is strict + # about NULL where unlist() silently returned it. + cs <- list_c(susieOutput$sets$cs %||% list()) + c(which(susieOutput$pip >= signalCutoff), cs) |> unique() |> sort() } @@ -2063,44 +2383,45 @@ getCsInfo <- function(susieOutputSetsCs, topVariantsIdx) { #' a vector of purity metrics (for other methods and multi-element sets). #' @noRd -calPurity <- function(lCs, X, method = "min") { - tt <- list() - - for (k in seq_along(lCs)) { - csIndices <- unlist(lCs[[k]]) - if (method == "min") { - if (length(csIndices) == 1) { - tt[[k]] <- 1 - } else { - x <- abs(computeLd( - X[, csIndices, drop = FALSE], - method = "sample" - )) - x[col(x) == row(x)] <- NA - tt[[k]] <- min(x, na.rm = TRUE) - } - } else { - if (length(csIndices) == 1) { - tt[[k]] <- c(1, 1, 1) - } else { - x <- abs(computeLd( - X[, csIndices, drop = FALSE], - method = "sample" - )) - x[col(x) == row(x)] <- NA - tt[[k]] <- c( - min(x, na.rm = TRUE), - mean(x, na.rm = TRUE), - median(x, na.rm = TRUE) - ) - } +# Absolute off-diagonal correlations among one credible set's variants. The +# diagonal is blanked so a set is never judged pure by its self-correlation. +# @noRd +.cpOffDiagonalLd <- function(csIndices, X) { + x <- abs(computeLd(X[, csIndices, drop = FALSE], method = "sample")) + replace(x, col(x) == row(x), NA) +} + +# One credible set's purity: the weakest pairwise correlation, or the +# (min, mean, median) triple when more than the minimum is asked for. A +# single-variant set is pure by definition. +# @noRd +.cpSetPurity <- function(csIndices, X, method) { + if (method == "min") { + if (length(csIndices) == 1) { + return(1) } + return(min(.cpOffDiagonalLd(csIndices, X), na.rm = TRUE)) + } + if (length(csIndices) == 1) { + return(c(1, 1, 1)) } + x <- .cpOffDiagonalLd(csIndices, X) + c( + min(x, na.rm = TRUE), + mean(x, na.rm = TRUE), + median(x, na.rm = TRUE) + ) +} - return(tt) +calPurity <- function(lCs, X, method = "min") { + # Each `lCs[[k]]` is documented (and always supplied) as a plain index + # vector; the unlist() that used to sit here was a no-op that quietly + # tolerated a nested list, leaving the contract unsettled. + map(lCs, .cpSetPurity, X = X, method = method) } +#' @importFrom checkmate assertNumber #' @title Create Sets Similar to SuSiE Output from fSuSiE Object #' #' @description This function constructs a list that mimics the structure of @@ -2126,6 +2447,7 @@ calPurity <- function(lCs, X, method = "min") { #' fsusieGetCs(fit) #' @export fsusieGetCs <- function(fsusieObj, X, requestedCoverage = 0.95) { + assertNumber(requestedCoverage, lower = 0, upper = 1) # Create 'cs' set with names csNamed <- set_names( fsusieObj$cs, @@ -2133,20 +2455,21 @@ fsusieGetCs <- function(fsusieObj, X, requestedCoverage = 0.95) { ) # Create 'purity' data frame - purityDf <- bind_rows( - map(calPurity(fsusieObj$cs, X = X, method = "susie"), .asDataFrameT) + purity <- `colnames<-`( + bind_rows( + map(calPurity(fsusieObj$cs, X = X, method = "susie"), .asDataFrameT) + ), + c("minAbsCorr", "meanAbsCorr", "medianAbsCorr") ) - colnames(purityDf) <- c("minAbsCorr", "meanAbsCorr", "medianAbsCorr") # Credible-set label as a `cs` column (was rownames; tibbles carry none). - purityDf <- bind_cols(tibble(cs = names(csNamed)), purityDf) + purityDf <- bind_cols(tibble(cs = names(csNamed)), purity) # Create 'coverage' without - coverageVector <- numeric(length(fsusieObj$alpha)) - for (i in seq_along(fsusieObj$alpha)) { - alphaI <- fsusieObj$alpha[[i]] - csI <- fsusieObj$cs[[i]] - coverageVector[i] <- sum(alphaI[csI]) - } + coverageVector <- map_dbl( + seq_along(fsusieObj$alpha), + .fsusieSetCoverage, + fsusieObj = fsusieObj + ) # Combine all elements into a list sets <- list( @@ -2179,7 +2502,8 @@ fsusieGetCs <- function(fsusieObj, X, requestedCoverage = 0.95) { #' @param maxScale numeric, define the maximum of wavelet coefficients used in #' the analysis (2^maxScale). Set 10 true by default. #' @param minPurity Minimum purity threshold for credible sets to be retained. -#' @param ... Additional arguments passed to the fsusie function. +#' @param methodArgs Optional named list of options passed to +#' \code{fsusieR::susiF}. #' @return A modified fsusie object with the susie sets list, correlations for #' cs, alpha as df like susie, and without the dummy cs that do not meet the #' minimum purity requirement. @@ -2206,41 +2530,48 @@ fsusieWrapper <- function( covLev, minPurity, maxScale, - ... + methodArgs = list() ) { if (!requireNamespace("fsusieR", quietly = TRUE)) { - msg <- glue( - "To use this function, please install fsusieR: ", - "https://github.com/stephenslab/fsusieR" - ) - abort(msg) + abort("Package 'fsusieR' is required for this function.") } - fsusieObj <- fsusieR::susiF( - X = X, - Y = Y, - pos = pos, - L = L, - prior = prior, - max_SNP_EM = maxSnpEm, - cov_lev = covLev, - min_purity = minPurity, - max_scale = maxScale, - ... + callArgs <- list_modify( + list( + X = X, + Y = Y, + pos = pos, + L = L, + prior = prior, + max_SNP_EM = maxSnpEm, + cov_lev = covLev, + min_purity = minPurity, + max_scale = maxScale + ), + !!!methodArgs ) + fsusieObj <- exec(fsusieR::susiF, !!!callArgs) .fsusieWrapperPostprocess(fsusieObj, X, minPurity, covLev) } # Drop dummy credible sets below the purity threshold (else build sets + CS # correlations), then reshape alpha (per-effect list) into a single data.frame. .fsusieWrapperPostprocess <- function(fsusieObj, X, minPurity, covLev) { - if (all(abs(as.numeric(fsusieObj$purity)) < minPurity)) { - fsusieObj$cs <- list(NULL) - fsusieObj$sets <- list(cs = list(NULL), requested_coverage = covLev) + withSets <- if (all(abs(as.numeric(fsusieObj$purity)) < minPurity)) { + list_assign( + fsusieObj, + cs = list(NULL), + sets = list(cs = list(NULL), requested_coverage = covLev) + ) } else { - fsusieObj$sets <- fsusieGetCs(fsusieObj, X, requestedCoverage = covLev) + list_assign( + fsusieObj, + sets = fsusieGetCs(fsusieObj, X, requestedCoverage = covLev) + ) } - fsusieObj$alpha <- bind_rows(map(fsusieObj$alpha, .asDataFrameT)) - fsusieObj + list_assign( + withSets, + alpha = bind_rows(map(fsusieObj$alpha, .asDataFrameT)) + ) } @@ -2265,7 +2596,8 @@ fsusieWrapper <- function( #' \code{mvsusieR::create_mixture_prior(R = ncol(Y))} unless you have a #' domain-specific prior. #' @param coverage Credible set coverage (default 0.95). -#' @param ... Additional arguments forwarded to \code{mvsusieR::mvsusie}. +#' @param methodArgs Optional named list of options forwarded to +#' \code{mvsusieR::mvsusie}. #' @return The fit object returned by \code{mvsusieR::mvsusie}. #' @examples #' \donttest{ @@ -2278,15 +2610,26 @@ fsusieWrapper <- function( #' fitMvsusie(X, Y, #' prior_variance = mvsusieR::create_mixture_prior(R = ncol(Y))) #' } +#' @importFrom checkmate assertNumber #' @export -fitMvsusie <- function(X, Y, prior_variance, coverage = 0.95, ...) { - mvsusieR::mvsusie( - X = X, - Y = Y, - prior_variance = prior_variance, - coverage = coverage, - ... +fitMvsusie <- function( + X, + Y, + prior_variance, + coverage = 0.95, + methodArgs = list() +) { + assertNumber(coverage, lower = 0, upper = 1) + callArgs <- list_modify( + list( + X = X, + Y = Y, + prior_variance = prior_variance, + coverage = coverage + ), + !!!methodArgs ) + exec(mvsusieR::mvsusie, !!!callArgs) } #' Fit mvSuSiE-RSS on summary-statistic (Z, R, N) data @@ -2300,7 +2643,8 @@ fitMvsusie <- function(X, Y, prior_variance, coverage = 0.95, ...) { #' @param N Scalar sample size (median across conditions when N varies). #' @param prior_variance Prior variance matrix. #' @param coverage Credible set coverage (default 0.95). -#' @param ... Additional arguments forwarded to \code{mvsusieR::mvsusie_rss}. +#' @param methodArgs Optional named list of options forwarded to +#' \code{mvsusieR::mvsusie_rss}. #' @return The fit object returned by \code{mvsusieR::mvsusie_rss}. #' @examples #' data(eqtlRegionExample) @@ -2316,16 +2660,29 @@ fitMvsusie <- function(X, Y, prior_variance, coverage = 0.95, ...) { #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) #' fitMvsusieRss(Z = stat$z, R = LD, N = nrow(X), prior_variance = 1) +#' @importFrom checkmate assertNumber #' @export -fitMvsusieRss <- function(Z, R, N, prior_variance, coverage = 0.95, ...) { - mvsusieR::mvsusie_rss( - Z = Z, - R = R, - N = N, - prior_variance = prior_variance, - coverage = coverage, - ... +fitMvsusieRss <- function( + Z, + R, + N, + prior_variance, + coverage = 0.95, + methodArgs = list() +) { + assertNumber(N, lower = 0, finite = TRUE) + assertNumber(coverage, lower = 0, upper = 1) + callArgs <- list_modify( + list( + Z = Z, + R = R, + N = N, + prior_variance = prior_variance, + coverage = coverage + ), + !!!methodArgs ) + exec(mvsusieR::mvsusie_rss, !!!callArgs) } #' Fit fSuSiE on individual-level (X, Y, pos) data @@ -2335,7 +2692,8 @@ fitMvsusieRss <- function(Z, R, N, prior_variance, coverage = 0.95, ...) { #' @param X Numeric matrix of genotypes (samples x variants). #' @param Y Numeric matrix of multi-trait outcomes (samples x traits). #' @param pos Numeric vector of trait positions (length \code{ncol(Y)}). -#' @param ... Additional arguments forwarded to \code{fsusieR::susiF}. +#' @param methodArgs Optional named list of options forwarded to +#' \code{fsusieR::susiF}. #' @return The fit object returned by \code{fsusieR::susiF}. #' @examples #' data(eqtlRegionExample) @@ -2346,10 +2704,11 @@ fitMvsusieRss <- function(Z, R, N, prior_variance, coverage = 0.95, ...) { #' Y <- matrix(rep(base, each = n), n, nPos) + #' X[, 1] %o% (0.5 * cos(seq(0, pi, length.out = nPos))) #' pos <- seq_len(nPos) -#' fitFsusie(X, Y, pos = pos, L = 2) +#' fitFsusie(X, Y, pos = pos, methodArgs = list(L = 2)) #' @export -fitFsusie <- function(X, Y, pos, ...) { - fsusieR::susiF(X = X, Y = Y, pos = pos, ...) +fitFsusie <- function(X, Y, pos, methodArgs = list()) { + callArgs <- list_modify(list(X = X, Y = Y, pos = pos), !!!methodArgs) + exec(fsusieR::susiF, !!!callArgs) } # ============================================================================= @@ -2366,8 +2725,7 @@ fitFsusie <- function(X, Y, pos, ...) { # (zero the intercept, then coef.susie without the intercept row). # @noRd .susieCoefWeights <- function(fit) { - fit$intercept <- 0 - coef.susie(fit)[-1] + coef.susie(list_assign(fit, intercept = 0))[-1] } # @param requiredFields Fields that must be present in the fit to extract @@ -2385,11 +2743,16 @@ fitFsusie <- function(X, Y, pos, ...) { y, requiredFields, token = "susie", - userArgs = list(), retainFit = FALSE ) { if (is.null(fit)) { - fit <- .fmFitSusieIndiv(X, y, token, userArgs = userArgs) + msg <- glue( + "{token}Weights: no '{token}' fit supplied. These extract weights ", + "from an existing fit and never run fine-mapping themselves; run ", + "fineMappingPipeline() with method '{token}' first and pass the ", + "fit in." + ) + abort(msg) } if (!is.null(X) && length(fit$pip) != ncol(X)) { nPip <- length(fit$pip) @@ -2400,49 +2763,50 @@ fitFsusie <- function(X, Y, pos, ...) { ) abort(msg) } - if (all(is_in(requiredFields, names(fit)))) { - weights <- .susieCoefWeights(fit) + weights <- if (all(is_in(requiredFields, names(fit)))) { + .susieCoefWeights(fit) } else { - weights <- rep(0, length(fit$pip)) + rep(0, length(fit$pip)) } - if (retainFit) { - attr(weights, "fit") <- fit + if (!retainFit) { + return(weights) } - return(weights) + `attr<-`(weights, "fit", fit) } #' Compute SuSiE TWAS weights #' -#' Extracts coefficients from an existing SuSiE fit or fits `susieR::susie()` +#' Extracts coefficients from an existing SuSiE fit. #' from `X` and `y` before extracting weights. #' -#' @param X Genotype matrix. Required when `susieFit` is NULL. -#' @param y Phenotype vector. Required when `susieFit` is NULL. +#' @param X Optional genotype matrix; when supplied it is only used to +#' check that the fit covers the same number of variants. +#' @param y Unused; retained for signature compatibility. #' @param susieFit Optional fitted SuSiE object. #' @param retainFit If TRUE, stores the fitted object as an attribute on the #' returned weights. -#' @param ... Additional arguments passed to `susieR::susie()` when fitting. #' @return Numeric vector of variant weights. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes -#' susieWeights(X, y) +#' fit <- susieR::susie(X, y, L = 5) +#' susieWeights(susieFit = fit) +#' @importFrom checkmate assertFlag #' @export susieWeights <- function( X = NULL, y = NULL, susieFit = NULL, - retainFit = FALSE, - ... + retainFit = FALSE ) { + assertFlag(retainFit) .susieExtractWeights( susieFit, X, y, requiredFields = c("alpha", "mu", "X_column_scale_factors"), token = "susie", - userArgs = list(...), retainFit = retainFit ) } @@ -2452,33 +2816,34 @@ susieWeights <- function( #' Extracts coefficients from an existing SuSiE-ASH fit or fits #' `susieR::susie()` with `unmappable_effects = "ash"`. #' -#' @param X Genotype matrix. Required when `susieAshFit` is NULL. -#' @param y Phenotype vector. Required when `susieAshFit` is NULL. +#' @param X Optional genotype matrix; when supplied it is only used to +#' check that the fit covers the same number of variants. +#' @param y Unused; retained for signature compatibility. #' @param susieAshFit Optional fitted SuSiE-ASH object. #' @param retainFit If TRUE, stores the fitted object as an attribute on the #' returned weights. -#' @param ... Additional arguments passed to `susieR::susie()` when fitting. #' @return Numeric vector of variant weights. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes -#' susieAshWeights(X, y) +#' fit <- susieR::susie(X, y, L = 5) +#' susieAshWeights(susieAshFit = fit) +#' @importFrom checkmate assertFlag #' @export susieAshWeights <- function( X = NULL, y = NULL, susieAshFit = NULL, - retainFit = FALSE, - ... + retainFit = FALSE ) { + assertFlag(retainFit) .susieExtractWeights( susieAshFit, X, y, requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), token = "susieAsh", - userArgs = list(...), retainFit = retainFit ) } @@ -2499,33 +2864,34 @@ susieAshWeights <- function( #' per-variant PIPs as a gate on whether to use the weights should be aware #' that low or zero PIPs do not imply zero TWAS weights here. #' -#' @param X Genotype matrix. Required when `susieInfFit` is NULL. -#' @param y Phenotype vector. Required when `susieInfFit` is NULL. +#' @param X Optional genotype matrix; when supplied it is only used to +#' check that the fit covers the same number of variants. +#' @param y Unused; retained for signature compatibility. #' @param susieInfFit Optional fitted SuSiE-inf object. #' @param retainFit If TRUE, stores the fitted object as an attribute on the #' returned weights. -#' @param ... Additional arguments passed to `susieR::susie()` when fitting. #' @return Numeric vector of variant weights. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes -#' susieInfWeights(X, y) +#' fit <- susieR::susie(X, y, L = 5) +#' susieInfWeights(susieInfFit = fit) +#' @importFrom checkmate assertFlag #' @export susieInfWeights <- function( X = NULL, y = NULL, susieInfFit = NULL, - retainFit = FALSE, - ... + retainFit = FALSE ) { + assertFlag(retainFit) .susieExtractWeights( susieInfFit, X, y, requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), token = "susieInf", - userArgs = list(...), retainFit = retainFit ) } @@ -2540,11 +2906,16 @@ susieInfWeights <- function( n, requiredFields, token = "susie", - userArgs = list(), retainFit = FALSE ) { if (is.null(fit)) { - fit <- .fmFitSusieRss(z, R, n, token, userArgs = userArgs) + msg <- glue( + "{token}RssWeights: no '{token}' fit supplied. These extract ", + "weights from an existing fit and never run fine-mapping ", + "themselves; run fineMappingPipeline() with method '{token}' ", + "first and pass the fit in." + ) + abort(msg) } if (length(fit$pip) != nrow(R)) { nPip <- length(fit$pip) @@ -2555,15 +2926,15 @@ susieInfWeights <- function( ) abort(msg) } - if (all(is_in(requiredFields, names(fit)))) { - weights <- .susieCoefWeights(fit) + weights <- if (all(is_in(requiredFields, names(fit)))) { + .susieCoefWeights(fit) } else { - weights <- rep(0, length(fit$pip)) + rep(0, length(fit$pip)) } - if (retainFit) { - attr(weights, "fit") <- fit + if (!retainFit) { + return(weights) } - return(weights) + `attr<-`(weights, "fit", fit) } #' Compute SuSiE-RSS TWAS weights @@ -2574,12 +2945,9 @@ susieInfWeights <- function( #' @param stat List with components \code{z} (z-scores), \code{n} (sample #' sizes). #' @param LD LD correlation matrix. -#' @param susieRssFit Optional pre-fitted SuSiE-RSS object. +#' @param susieRssFit A fitted SuSiE-RSS object. Required: these wrappers +#' extract weights and never run fine-mapping themselves. #' @param retainFit If TRUE, stores the fitted object as an attribute. -#' @param methodArgs Named list of additional arguments passed to -#' \code{susieR::susie_rss()}. Use this instead of \code{...} to avoid partial -#' matching of short argument names (e.g. \code{L}) to the \code{LD} -#' parameter. #' @return Numeric vector of variant weights. #' @examples #' data(eqtlRegionExample) @@ -2594,15 +2962,18 @@ susieInfWeights <- function( #' z = vapply(ss, function(s) s[1] / s[2], numeric(1)), #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) -#' susieRssWeights(stat, LD) +#' fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) +#' susieRssWeights(stat, LD, susieRssFit = fit) +#' @importFrom checkmate assertList assertFlag #' @export susieRssWeights <- function( stat, LD, susieRssFit = NULL, - retainFit = TRUE, - methodArgs = list() + retainFit = TRUE ) { + assertList(stat) + assertFlag(retainFit) .susieRssExtractWeights( fit = susieRssFit, z = stat$z, @@ -2610,7 +2981,6 @@ susieRssWeights <- function( n = median(stat$n), requiredFields = c("alpha", "mu", "X_column_scale_factors"), token = "susie", - userArgs = methodArgs, retainFit = retainFit ) } @@ -2636,15 +3006,18 @@ susieRssWeights <- function( #' z = vapply(ss, function(s) s[1] / s[2], numeric(1)), #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) -#' susieInfRssWeights(stat, LD) +#' fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) +#' susieInfRssWeights(stat, LD, susieInfRssFit = fit) +#' @importFrom checkmate assertList assertFlag #' @export susieInfRssWeights <- function( stat, LD, susieInfRssFit = NULL, - retainFit = TRUE, - methodArgs = list() + retainFit = TRUE ) { + assertList(stat) + assertFlag(retainFit) .susieRssExtractWeights( fit = susieInfRssFit, z = stat$z, @@ -2652,7 +3025,6 @@ susieInfRssWeights <- function( n = median(stat$n), requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), token = "susieInf", - userArgs = methodArgs, retainFit = retainFit ) } @@ -2678,15 +3050,18 @@ susieInfRssWeights <- function( #' z = vapply(ss, function(s) s[1] / s[2], numeric(1)), #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) -#' susieAshRssWeights(stat, LD) +#' fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) +#' susieAshRssWeights(stat, LD, susieAshRssFit = fit) +#' @importFrom checkmate assertList assertFlag #' @export susieAshRssWeights <- function( stat, LD, susieAshRssFit = NULL, - retainFit = TRUE, - methodArgs = list() + retainFit = TRUE ) { + assertList(stat) + assertFlag(retainFit) .susieRssExtractWeights( fit = susieAshRssFit, z = stat$z, @@ -2694,27 +3069,16 @@ susieAshRssWeights <- function( n = median(stat$n), requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), token = "susieAsh", - userArgs = methodArgs, retainFit = retainFit ) } #' Compute mvSuSiE TWAS weights #' -#' Extracts coefficients from an existing mvSuSiE fit or fits `fitMvsusie()` -#' from `X` and `Y`. +#' Extracts coefficients from an existing mvSuSiE fit. This never fits +#' mvSuSiE itself: fine-mapping belongs to \code{fineMappingPipeline()}, and a +#' missing fit is an error rather than an invitation to refit. #' -#' @param mvsusieFit Optional fitted mvSuSiE object. -#' @param X Genotype matrix. Required when `mvsusieFit` is NULL. -#' @param Y Phenotype matrix. Required when `mvsusieFit` is NULL. -#' @param priorVariance Optional mvSuSiE prior variance list. -#' @param residualVariance Optional residual variance matrix. -#' @param L Maximum number of components. Default \code{10}, matching -#' \code{mvsusieR::mvsusie}. -#' @param LGreedy Integer or \code{NULL}. Number of greedily-added components. -#' \code{NULL} (default) disables the greedy loop and fits \code{L} -#' directly. -#' @param verbose If TRUE, prints mvSuSiE fitting progress. -#' @param ... Additional arguments passed to `fitMvsusie()` when fitting. +#' @param mvsusieFit A fitted mvSuSiE object. Required. #' @return Matrix of variant weights. #' @examples #' \donttest{ @@ -2723,63 +3087,38 @@ susieAshRssWeights <- function( #' data(multiTraitData) #' X <- multiTraitData$X[, 1:60] #' Y <- multiTraitData$Y -#' mvsusieWeights(X = X, Y = Y, L = 5, LGreedy = 2) +#' fit <- fitMvsusie(X = X, Y = Y, +#' prior_variance = mvsusieR::create_mixture_prior(R = ncol(Y)), +#' methodArgs = list(L = 5)) +#' mvsusieWeights(mvsusieFit = fit) #' } #' @export -mvsusieWeights <- function( - mvsusieFit = NULL, - X = NULL, - Y = NULL, - priorVariance = NULL, - residualVariance = NULL, - L = 10, - LGreedy = NULL, - verbose = FALSE, - ... -) { +mvsusieWeights <- function(mvsusieFit = NULL) { if (!requireNamespace("mvsusieR", quietly = TRUE)) { - msg <- glue( - "Package 'mvsusieR' is required. Install with: ", - "devtools::install_github('stephenslab/mvsusieR')" - ) - abort(msg) + abort("Package 'mvsusieR' is required.") } if (is.null(mvsusieFit)) { - inform("mvsusieFit is not provided; fitting mvSuSiE now ...") - if (is.null(X) || is.null(Y)) { - abort("Both X and Y must be provided if mvsusieFit is NULL.") - } - if (is.null(priorVariance)) { - priorVariance <- mvsusieR::create_mixture_prior(R = ncol(Y)) - } - if (!is.null(LGreedy)) { - LGreedy <- min(LGreedy, L) - } - - mvsusieFit <- fitMvsusie( - X = X, - Y = Y, - L = L, - L_greedy = LGreedy, - prior_variance = priorVariance, - residual_variance = residualVariance, - estimate_residual_variance = TRUE, - verbose = verbose, - ... + msg <- glue( + "mvsusieWeights: `mvsusieFit` is required. This extracts weights ", + "from an existing mvSuSiE fit and never runs fine-mapping ", + "itself; fit it via fineMappingPipeline() and pass the result in." ) + abort(msg) } - return(mvsusieR::coef.mvsusie(mvsusieFit)[-1, ]) + mvsusieR::coef.mvsusie(mvsusieFit)[-1, ] } # One wavelet basis row: inverse-DWT (wr) of the unit coefficient vector e_k, # using the fit's template DWT object. # @noRd .fmReconstructUnit <- function(k, nWac, scaleCols, template) { - coeffRow <- numeric(nWac) - coeffRow[k] <- 1 - temp <- template - temp$D <- coeffRow[-scaleCols] - temp$C[length(temp$C)] <- sum(coeffRow[scaleCols]) + coeffRow <- replace(numeric(nWac), k, 1) + scaling <- replace( + template$C, + length(template$C), + sum(coeffRow[scaleCols]) + ) + temp <- list_assign(template, D = coeffRow[-scaleCols], C = scaling) as.numeric(wavethresh::wr(temp)) } @@ -2881,19 +3220,27 @@ fsusieWeights <- function( csdX <- as.numeric(fit$csd_X) alphaList <- .fsusieAlphaList(fit$alpha) S <- .fsusieSynthesisMatrix(fit$n_wac, .fsusieScaleCols(fit)) - W <- .fsusieComputeW(fit, alphaList, csdX, S) - W <- .fsusieWeightsNames( - W, - fit, - variantIds, - featureNames, - length(csdX), - ncol(S) - ) - if (retainFit) { - attr(W, "fit") <- fit + W <- .fsusieComputeW(fit, alphaList, csdX, S) |> + .fsusieWeightsNames( + fit, + variantIds, + featureNames, + length(csdX), + ncol(S) + ) + if (!retainFit) { + return(W) } - W + `attr<-`(W, "fit", fit) +} + +# Row names only mean the variants when there is one per row of the matrix. +# @noRd +.withRownamesIfSized <- function(W, variantIds) { + if (is.null(variantIds) || length(variantIds) != nrow(W)) { + return(W) + } + `rownames<-`(W, variantIds) } # Fast path: a trimmed fit carries the precomputed variants x features weight @@ -2903,12 +3250,9 @@ fsusieWeights <- function( if (!(is.matrix(fsusieFit$coef) && is.null(fsusieFit$fitted_wc))) { return(NULL) } - W <- fsusieFit$coef - if (!is.null(variantIds) && length(variantIds) == nrow(W)) { - rownames(W) <- variantIds - } + W <- .withRownamesIfSized(fsusieFit$coef, variantIds) if (retainFit) { - attr(W, "fit") <- fsusieFit + return(`attr<-`(W, "fit", fsusieFit)) } W } @@ -2967,40 +3311,54 @@ fsusieWeights <- function( # W = sum_l (alpha_l/csd_X-scaled fitted_wc_l) %*% S, one wavelet inverse # transform (S) applied to every SNP/effect via a matrix multiply. +# @noRd +.fsusieSetCoverage <- function(i, fsusieObj) { + sum(fsusieObj$alpha[[i]][fsusieObj$cs[[i]]]) +} + +# One effect's contribution to the weight matrix. +# @noRd +.fsusieEffectW <- function(l, fit, alphaList, invCsd, S) { + (alphaList[[l]] * invCsd * as.matrix(fit$fitted_wc[[l]])) %*% S +} + .fsusieComputeW <- function(fit, alphaList, csdX, S) { invCsd <- 1 / csdX - W <- matrix(0, nrow = length(csdX), ncol = ncol(S)) - for (l in seq_along(fit$fitted_wc)) { - wc <- as.matrix(fit$fitted_wc[[l]]) - W <- W + (alphaList[[l]] * invCsd * wc) %*% S - } - W + # W is the sum of the per-effect contributions, so it is a fold rather + # than a matrix added into repeatedly. + reduce( + map( + seq_along(fit$fitted_wc), + .fsusieEffectW, + fit = fit, + alphaList = alphaList, + invCsd = invCsd, + S = S + ), + `+`, + .init = matrix(0, nrow = length(csdX), ncol = ncol(S)) + ) } # Attach variant (row) and feature/grid (column) names to the weight matrix. .fsusieWeightsNames <- function(W, fit, variantIds, featureNames, p, nFeat) { - rn <- variantIds - if (is.null(rn)) { - rn <- names(fit$csd_X) - } - if (is.null(rn)) { - rn <- names(fit$pip) - } - if (!is.null(rn) && length(rn) == p) { - rownames(W) <- rn - } - cn <- featureNames - if ( - is.null(cn) && + rn <- variantIds %||% names(fit$csd_X) %||% names(fit$pip) + cn <- if ( + is.null(featureNames) && !is.null(fit$outing_grid) && length(fit$outing_grid) == nFeat ) { - cn <- as.character(fit$outing_grid) - } - if (!is.null(cn) && length(cn) == nFeat) { - colnames(W) <- cn + as.character(fit$outing_grid) + } else { + featureNames } - W + `dimnames<-`( + W, + list( + if (length(rn) == p) rn else rownames(W), + if (length(cn) == nFeat) cn else colnames(W) + ) + ) } #' Compute mvSuSiE-RSS TWAS weights from summary statistics #' @@ -3015,18 +3373,9 @@ fsusieWeights <- function( #' @param stat A list with \code{z} (matrix variants x conditions) and \code{n} #' (numeric vector or scalar). #' @param LD LD correlation matrix. -#' @param mvsusieRssFit Optional pre-fitted \code{mvsusieRss} object. -#' @param priorVariance Optional mvSuSiE prior variance specification. When -#' NULL, \code{mvsusieR::create_mixture_prior()} is used with \code{R = -#' ncol(stat$z)}. -#' @param residualVariance Optional residual covariance matrix. -#' @param L Maximum number of single effects. Default \code{10}, matching -#' \code{mvsusieR::mvsusie}. -#' @param LGreedy Integer or \code{NULL}. Number of greedily-added effects. -#' \code{NULL} (default) disables the greedy loop and fits \code{L} -#' directly. +#' @param mvsusieRssFit A fitted \code{mvsusieRss} object. Required: this +#' extracts weights and never runs fine-mapping itself. #' @param retainFit If TRUE, attaches the fitted object as an attribute. -#' @param ... Additional arguments forwarded to \code{mvsusieR::mvsusie_rss}. #' #' @return A numeric matrix of per-variant per-context weights (variants x #' conditions). @@ -3051,102 +3400,58 @@ mvsusieRssWeights <- function( stat, LD, mvsusieRssFit = NULL, - priorVariance = NULL, - residualVariance = NULL, - L = 10, - LGreedy = NULL, - retainFit = FALSE, - ... + retainFit = FALSE ) { if (!requireNamespace("mvsusieR", quietly = TRUE)) { - msg <- glue( - "Package 'mvsusieR' is required. ", - "Install with: devtools::install_github('stephenslab/mvsusieR')" - ) - abort(msg) + abort("Package 'mvsusieR' is required.") } + # `stat` / `LD` are kept for interface parity with the other *RssWeights + # wrappers (the dispatcher passes them positionally) but are not read: + # the weights come from the supplied fit. The old ">= 2 columns" check + # validated *fitting* inputs, so it left with the fitting branch. if (is.null(mvsusieRssFit)) { - mvsusieRssFit <- .mvsusieRssBuildFit( - stat, - LD, - priorVariance, - residualVariance, - L, - LGreedy, - ... - ) - } - weights <- mvsusieR::coef.mvsusie(mvsusieRssFit)[-1, , drop = FALSE] - if (retainFit) { - attr(weights, "fit") <- mvsusieRssFit - } - weights -} - -# Build the mvsusie-RSS fit from summary stats when the caller supplied none. -# @noRd -.mvsusieRssBuildFit <- function( - stat, - LD, - priorVariance, - residualVariance, - L, - LGreedy, - ... -) { - Z <- if (is.matrix(stat$z)) stat$z else as.matrix(stat$z) - if (ncol(Z) < 2) { msg <- glue( - "mvsusieRssWeights expects stat$z to have >= 2 columns ", - "(one per context). For single-context use ", - "susieRssWeights()." + "mvsusieRssWeights: `mvsusieRssFit` is required. This extracts ", + "weights from an existing mvSuSiE-RSS fit and never runs ", + "fine-mapping itself; fit it via fineMappingPipeline() and pass ", + "the result in." ) abort(msg) } - # mvsusieR::mvsusie_rss expects N to be a single scalar - nScalar <- as.numeric(stats::median(stat$n)) - if (is.null(priorVariance)) { - priorVariance <- mvsusieR::create_mixture_prior(R = ncol(Z)) - } - if (!is.null(LGreedy)) { - LGreedy <- min(LGreedy, L) + weights <- mvsusieR::coef.mvsusie(mvsusieRssFit)[-1, , drop = FALSE] + if (!retainFit) { + return(weights) } - fitMvsusieRss( - Z = Z, - R = LD, - N = nScalar, - L = L, - L_greedy = LGreedy, - prior_variance = priorVariance, - residual_variance = residualVariance, - ... - ) + `attr<-`(weights, "fit", mvsusieRssFit) } + # ============================================================================= # Cross-condition credible-set merging # ============================================================================= # Identify variant IDs that are associated with more than one credible set. # @noRd +# The sets a variant belongs to, but only when it belongs to more than one. +# @noRd +.ovlMultiSets <- function(entry) { + sets <- entry[["sets"]] + if (length(sets) > 1) sets else NULL +} + .identifyOverlapSets <- function(variantsSetsAndPipsList) { - overlapSets <- list() - for (variantId in names(variantsSetsAndPipsList)) { - sets <- variantsSetsAndPipsList[[variantId]][["sets"]] - if (length(sets) > 1) { - overlapSets[[variantId]] <- sets - } - } - return(overlapSets) + compact(map(variantsSetsAndPipsList, .ovlMultiSets)) } # Union-find root of `x` following the `parent` map. # @noRd .ufFindRoot <- function(x, parent) { - while (!identical(parent[[x]], x)) { - x <- parent[[x]] + # Walking to the root recursively rather than reassigning `x`; union-find + # trees are shallow, so the depth is not a concern. + if (identical(parent[[x]], x)) { + return(x) } - x + .ufFindRoot(parent[[x]], parent) } # Union-find merge of `a` and `b` in `parent`; returns the updated parent map. @@ -3154,40 +3459,58 @@ mvsusieRssWeights <- function( .ufUnion <- function(a, b, parent) { rootA <- .ufFindRoot(a, parent) rootB <- .ufFindRoot(b, parent) - if (!identical(rootA, rootB)) { - parent[[rootB]] <- rootA + if (identical(rootA, rootB)) { + return(parent) } - parent + `[[<-`(parent, rootB, value = rootA) } # Merge overlapping credible sets using connected components (union-find). # @noRd -.mergeAndUpdateOverlapSets <- function(variantsSetsAndPipsList, overlapSets) { - allSets <- unique(unlist(overlapSets)) - if (length(allSets) == 0) { +# @noRd +.ufPair <- function(s, first) { + list(a = first, b = s) +} + +# One overlap's (first set, other set) pairs. +# @noRd +.ufOverlapPairs <- function(sets) { + if (length(sets) <= 1) { return(list()) } + map(sets[-1], .ufPair, first = sets[[1]]) +} - parent <- set_names(allSets, allSets) - for (sets in overlapSets) { - if (length(sets) > 1) { - for (s in sets[-1]) { - parent <- .ufUnion(sets[[1]], s, parent) - } - } +# @noRd +.ufUnionPair <- function(parent, pair) { + .ufUnion(pair$a, pair$b, parent) +} + +# Every member of one component mapped to that component's joint label. +# @noRd +.ufComponentLabels <- function(members) { + label <- str_flatten(sort(members), ",") + set_names(as.list(rep(label, length(members))), members) +} + +.mergeAndUpdateOverlapSets <- function(variantsSetsAndPipsList, overlapSets) { + allSets <- unique(list_c(overlapSets)) + if (length(allSets) == 0) { + return(list()) } + # Each overlap ties its sets to the first one; the merges are a fold over + # those pairs, since every union sees the map the previous one produced. + parent <- reduce( + .fmwConcat(map(overlapSets, .ufOverlapPairs)), + .ufUnionPair, + .init = set_names(allSets, allSets) + ) components <- split( names(parent), map_chr(names(parent), .ufFindRoot, parent) ) - setNameMap <- list() - for (members in components) { - label <- str_flatten(sort(members), ",") - for (s in members) { - setNameMap[[s]] <- label - } - } + setNameMap <- .fmwConcat(map(components, .ufComponentLabels)) # Update each variant's credible set names updatedCredibleSets <- map( @@ -3334,8 +3657,12 @@ mergeSusieCs <- function(fineMappingResult, coverage = 0.95) { #' @examples #' data(qtlSumStatsExample) #' getSusieResult(qtlSumStatsExample) +#' @importFrom checkmate assertList #' @export getSusieResult <- function(conData) { + # No type guard: this is duck-typed on `$` and `length()` and returns NULL + # for anything without a `finemappingEntry`. Its own @example passes a + # QtlSumStats, which assertList rejects. if (length(conData) == 0) { return(NULL) } @@ -3355,8 +3682,10 @@ getSusieResult <- function(conData) { #' This function extracts and processes information for each Credible Set (CS) #' from finemapping results, typically obtained from a finemapping RDS file. #' -#' @param fmRow A \code{\link{fineMappingRow}} carrying the SuSiE -#' fit and variant ids (e.g. from \code{\link{getFineMappingResult}}). +#' @param fmRow A \code{\link{fineMappingRow}}, or a single-row +#' fine-mapping collection as returned by +#' \code{\link{getFineMappingResult}}, carrying the SuSiE fit and +#' variant ids. #' @param csNames Character vector. Names of the Credible Sets, usually in the #' format "L_". #' @param topLociTable Data frame. The top-loci table (e.g. from @@ -3405,8 +3734,10 @@ getSusieResult <- function(conData) { #' extractCsInfo(fe, csNames = "L_1", topLociTable = tl, #' ldSource = qtlSumStatsExample) #' +#' @importFrom checkmate assertClass assertCharacter #' @export extractCsInfo <- function(fmRow, csNames, topLociTable, ldSource) { + assertCharacter(csNames, any.missing = FALSE) fm <- fmRow trimmed <- .fmrPartsSusieFit(fm) variantNames <- .fmrPartsVariantIds(fm) @@ -3428,8 +3759,10 @@ extractCsInfo <- function(fmRow, csNames, topLociTable, ldSource) { #' Posterior Inclusion Probability (PIP) from finemapping results, typically #' used when no Credible Sets (CS) are identified in the analysis. #' -#' @param fmRow A \code{\link{fineMappingRow}} carrying the SuSiE -#' fit and variant ids (e.g. from \code{\link{getFineMappingResult}}). +#' @param fmRow A \code{\link{fineMappingRow}}, or a single-row +#' fine-mapping collection as returned by +#' \code{\link{getFineMappingResult}}, carrying the SuSiE fit and +#' variant ids. #' @param sumstats A list or data frame carrying a \code{z} element aligned to #' the fit's variants (\code{sumstats$z}). #' @@ -3465,6 +3798,7 @@ extractCsInfo <- function(fmRow, csNames, topLociTable, ldSource) { #' fe <- fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) #' extractTopPipInfo(fe, sumstats = list(z = c(1.0, 3.5, -0.5))) #' +#' @importFrom checkmate assertClass #' @export extractTopPipInfo <- function(fmRow, sumstats) { fm <- fmRow @@ -3516,8 +3850,10 @@ extractTopPipInfo <- function(fmRow, sumstats) { return(mutate(base, cs_corr_max = NA_real_, cs_corr_min = NA_real_)) } perRow <- apply(csCorr, 1L, .extractCorrelations, simplify = FALSE) - expanded <- as_tibble(csCorr, .name_repair = "minimal") - names(expanded) <- str_c("cs_corr_", seq_len(ncol(csCorr))) + expanded <- `names<-`( + as_tibble(csCorr, .name_repair = "minimal"), + str_c("cs_corr_", seq_len(ncol(csCorr))) + ) # unname(): apply() names its result by the matrix rownames, which map_dbl # then carries into the column (tibbles preserve element names). base |> @@ -3592,10 +3928,9 @@ extractTopPipInfo <- function(fmRow, sumstats) { coverage = coverage, unmappable_effects = info$unmappableEffects ) - if (!is.null(chainFromInf) && token != "susieInf") { + fitArgs <- 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 + # 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), @@ -3603,22 +3938,20 @@ extractTopPipInfo <- function(fmRow, sumstats) { 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 + list_assign( + list_modify(baseArgs, !!!compact(chainedArgs)), + X = X, + y = y, + 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) + .fmMergeUserArgs( + list_assign(baseArgs, !!!.fmSusieTokenDefaults(token)), + token, + userArgs + ) } - fit <- exec(susieR::susie, !!!baseArgs) - .setFinemappingFitClass(fit, token) + .setFinemappingFitClass(exec(susieR::susie, !!!fitArgs), token) } @@ -3638,20 +3971,24 @@ extractTopPipInfo <- function(fmRow, sumstats) { rssControl = NULL ) { info <- .fmRssValidateToken(token) - baseArgs <- list( - z = z, - R = R, - n = n, - coverage = coverage, - unmappable_effects = info$unmappableEffects + baseArgs <- .fmRssAddControl( + c( + list( + z = z, + R = R, + n = n, + coverage = coverage, + unmappable_effects = info$unmappableEffects + ), + # rFinite = NULL omits the element -> susie_rss default; these sit + # in baseArgs so they survive the chained modifyList / non-chained + # userArgs merge, while user methodArgs (folded in after) still + # override them. + compact(list(R_finite = rFinite, R_mismatch = rMismatch)) + ), + rssControl ) - # rFinite = NULL removes the element -> susie_rss default; these sit in - # baseArgs so they survive the chained modifyList / non-chained userArgs - # merge, while user methodArgs (folded in after) still override them. - baseArgs$R_finite <- rFinite - baseArgs$R_mismatch <- rMismatch - baseArgs <- .fmRssAddControl(baseArgs, rssControl) - baseArgs <- if (!is.null(chainFromInf) && token != "susieInf") { + fitArgs <- if (!is.null(chainFromInf) && token != "susieInf") { .fmRssChainedArgs( baseArgs, token, @@ -3667,7 +4004,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { } # All susie_rss fits get the "susieRss" S3 class for post-processing (drives # the Xcorr cs-input mode); token distinction stays in the `method` column. - .setFinemappingFitClass(exec(susieR::susie_rss, !!!baseArgs), "susieRss") + .setFinemappingFitClass(exec(susieR::susie_rss, !!!fitArgs), "susieRss") } # Validate the method token and return its capability record. @@ -3699,8 +4036,10 @@ extractTopPipInfo <- function(fmRow, sumstats) { ) abort(msg) } - baseArgs$control <- exec(susieR::susie_rss_control, !!!rssControl) - baseArgs + list_assign( + baseArgs, + control = exec(susieR::susie_rss_control, !!!rssControl) + ) } # SuSiE-RSS(-ash) initialised from a SuSiE-inf fit; userArgs folded into the arg @@ -3721,24 +4060,35 @@ extractTopPipInfo <- function(fmRow, sumstats) { 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 - baseArgs + list_assign( + list_modify(baseArgs, !!!compact(chainedArgs)), + z = z, + R = R, + n = n, + coverage = coverage + ) } # Non-chained fit: token-specific defaults then the user methodArgs merge. .fmRssNonChainedArgs <- function(baseArgs, token, userArgs) { + .fmMergeUserArgs( + list_assign(baseArgs, !!!.fmSusieTokenDefaults(token)), + token, + userArgs + ) +} + +# Token-specific susie defaults. `model_init` is deliberately not among them: +# baseArgs never carries one, so susieR's own default already applies. +# @noRd +.fmSusieTokenDefaults <- function(token) { if (token == "susieInf") { - baseArgs$convergence_method <- "pip" - baseArgs$refine <- FALSE - baseArgs$model_init <- NULL - } else if (token == "susieAsh") { - baseArgs$convergence_method <- "pip" + return(list(convergence_method = "pip", refine = FALSE)) } - .fmMergeUserArgs(baseArgs, token, userArgs) + if (token == "susieAsh") { + return(list(convergence_method = "pip")) + } + list() } # Single-effect (SER) sumstat fit via susieR::susie_ser on z + n. LD-free (no R, @@ -3760,6 +4110,58 @@ extractTopPipInfo <- function(fmRow, sumstats) { # 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). +# One token's fit plus its postprocessing, or NULL when the fit did not run. +# @noRd +.fmXFitAndPostprocess <- function( + tk, + chainLocal, + infFit, + X, + y, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + verbose, + ctx, + tid, + af, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { + fit <- .fmXFitOne( + tk, + chainLocal, + infFit, + X = X, + y = y, + coverage = coverage, + methodArgs = methodArgs, + verbose = verbose, + ctx = ctx, + tid = tid + ) + if (is.null(fit)) { + return(NULL) + } + .fmXPostprocess( + fit, + tk, + X = X, + y = y, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + af = af, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs + ) +} + .fmFitXBlock <- function( X, y, @@ -3782,42 +4184,98 @@ extractTopPipInfo <- function(fmRow, sumstats) { includeAllCs = FALSE, seed = NULL ) { - p <- as.list(environment()) chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) - infFit <- .fmXInfFit(p, chainLocal) - out <- list() - for (tk in toRun) { - fit <- .fmXFitOne(tk, p, chainLocal, infFit) - if (is.null(fit)) { - next - } - out[[tk]] <- .fmXPostprocess(fit, tk, p) - } - .fmXCrossValidate(out, p) + infFit <- .fmXInfFit( + chainLocal, + X = X, + y = y, + coverage = coverage, + methodArgs = methodArgs, + verbose = verbose, + ctx = ctx, + tid = tid + ) + out <- compact(set_names( + map( + toRun, + .fmXFitAndPostprocess, + chainLocal = chainLocal, + infFit = infFit, + X = X, + y = y, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + verbose = verbose, + ctx = ctx, + tid = tid, + af = af, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs + ), + toRun + )) + .fmXCrossValidate( + out, + X = X, + y = y, + coverage = coverage, + methodArgs = methodArgs, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + verbose = verbose, + ctx = ctx, + tid = tid + ) } # Fit the shared susieInf model once, if the requested chain needs it. -.fmXInfFit <- function(p, chainLocal) { +.fmXInfFit <- function( + chainLocal, + X, + y, + coverage, + methodArgs, + verbose, + ctx, + tid +) { if (!chainLocal$runInf) { return(NULL) } - if (p$verbose >= 1) { + if (verbose >= 1) { msg <- glue( - "Fitting susieInf for (context='{p$ctx}', trait='{p$tid}') ..." + "Fitting susieInf for (context='{ctx}', trait='{tid}') ..." ) inform(msg) } .fmFitSusieIndiv( - p$X, - p$y, + X, + y, "susieInf", - coverage = p$coverage, - userArgs = p$methodArgs[["susieInf"]] + coverage = coverage, + userArgs = methodArgs[["susieInf"]] ) } # Resolve the fit for one method token; NULL means "skip this token". -.fmXFitOne <- function(tk, p, chainLocal, infFit) { +.fmXFitOne <- function( + tk, + chainLocal, + infFit, + X, + y, + coverage, + methodArgs, + verbose, + ctx, + tid +) { if (tk == "susieInf") { if (!chainLocal$keepInf) { return(NULL) @@ -3832,70 +4290,101 @@ extractTopPipInfo <- function(fmRow, sumstats) { } else { NULL } - if (p$verbose >= 1) { + if (verbose >= 1) { msg <- glue( - "Fitting {tk} for (context='{p$ctx}', trait='{p$tid}') ..." + "Fitting {tk} for (context='{ctx}', trait='{tid}') ..." ) inform(msg) } .fmFitSusieIndiv( - p$X, - p$y, + X, + y, tk, chainFromInf = chainFrom, - coverage = p$coverage, - userArgs = p$methodArgs[[tk]] + coverage = coverage, + userArgs = methodArgs[[tk]] ) } # Post-process one individual-level fit into a finemapping entry. -.fmXPostprocess <- function(fit, tk, p) { +.fmXPostprocess <- function( + fit, + tk, + X, + y, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + af, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { .fmPostprocessOne( fit = fit, method = tk, - dataX = p$X, - dataY = p$y, - coverage = p$coverage, - secondaryCoverage = p$secondaryCoverage, - signalCutoff = p$signalCutoff, - minAbsCorr = p$minAbsCorr, - af = p$af, + dataX = X, + dataY = y, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + af = af, csInput = "X", - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs ) } # Per-fold cross-validation across the fitted methods; attach each method's # out-of-fold predictions to its entry. -.fmXCrossValidate <- function(out, p) { - if (!(p$cvFolds > 1L && length(out) > 0L)) { +.fmXCrossValidate <- function( + out, + X, + y, + coverage, + methodArgs, + cvFolds, + cvThreads, + samplePartition, + seed, + verbose, + ctx, + tid +) { + if (!(cvFolds > 1L && length(out) > 0L)) { return(out) } - if (p$verbose >= 1) { + if (verbose >= 1) { msg <- glue( - "Cross-validating ({p$cvFolds} folds) for ", - "(context='{p$ctx}', trait='{p$tid}') ..." + "Cross-validating ({cvFolds} folds) for ", + "(context='{ctx}', trait='{tid}') ..." ) inform(msg) } cv <- .fmWeightsCv( - p$X, - p$y, + X, + y, names(out), - p$methodArgs, - p$cvFolds, - samplePartition = p$samplePartition, - coverage = p$coverage, - verbose = p$verbose, - numThreads = p$cvThreads, - seed = p$seed + methodArgs, + cvFolds, + samplePartition = samplePartition, + coverage = coverage, + verbose = verbose, + numThreads = cvThreads, + seed = seed + ) + set_names( + map(names(out), .fmAttachCvAt, out = out, cv = cv), + names(out) ) - for (tk in names(out)) { - out[[tk]] <- .fmAttachCv(out[[tk]], .fmSliceCv(cv, tk)) - } - out +} + +# @noRd +.fmAttachCvAt <- function(tk, out, cv) { + .fmAttachCv(out[[tk]], .fmSliceCv(cv, tk)) } # Fit every requested RSS token on one (z, R, n) sumstat block, returning a @@ -3926,49 +4415,170 @@ extractTopPipInfo <- function(fmRow, sumstats) { rssControl = NULL, keepFullFit = "fallback" ) { - p <- as.list(environment()) chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) - infFit <- .fmRssInfFit(p, chainLocal) - out <- list() - for (tk in toRun) { - f <- .fmRssFitOne(tk, p, chainLocal, infFit) - if (is.null(f)) { - next - } - ent <- .fmRssPostprocess(f$fit, p) - if (f$isStd && isTRUE(p$serFallback)) { - ent <- .fmRssRecordFallback(ent, f, p$keepFullFit) - } - out[[tk]] <- ent + infFit <- .fmRssInfFit( + chainLocal, + z = z, + R = R, + n = n, + coverage = coverage, + methodArgs = methodArgs, + rFinite = rFinite, + rMismatch = rMismatch, + rssControl = rssControl, + verbose = verbose, + label = label + ) + compact(set_names( + map( + toRun, + .fmRssFitAndPostprocess, + chainLocal = chainLocal, + infFit = infFit, + z = z, + R = R, + n = n, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + methodArgs = methodArgs, + rFinite = rFinite, + rMismatch = rMismatch, + rssControl = rssControl, + verbose = verbose, + label = label, + serFallback = serFallback, + af = af, + nVar = nVar, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + keepFullFit = keepFullFit + ), + toRun + )) +} + +# One RSS token's fit, postprocessed and (when it fell back to the single +# effect model) labelled as such. NULL when the fit did not run. +# @noRd +.fmRssFitAndPostprocess <- function( + tk, + chainLocal, + infFit, + z, + R, + n, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + methodArgs, + rFinite, + rMismatch, + rssControl, + verbose, + label, + serFallback, + af, + nVar, + fullFit, + fullFitAlphaOnly, + includeAllCs, + keepFullFit +) { + f <- .fmRssFitOne( + tk, + chainLocal, + infFit, + z = z, + R = R, + n = n, + coverage = coverage, + methodArgs = methodArgs, + rFinite = rFinite, + rMismatch = rMismatch, + rssControl = rssControl, + verbose = verbose, + label = label, + serFallback = serFallback + ) + if (is.null(f)) { + return(NULL) } - out + entry <- .fmRssPostprocess( + f$fit, + R = R, + z = z, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + af = af, + nVar = nVar, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs + ) + if (f$isStd && isTRUE(serFallback)) { + return(.fmRssRecordFallback(entry, f, keepFullFit)) + } + entry } # Fit the shared susieInf (RSS) model once, if the requested chain needs it. -.fmRssInfFit <- function(p, chainLocal) { +.fmRssInfFit <- function( + chainLocal, + z, + R, + n, + coverage, + methodArgs, + rFinite, + rMismatch, + rssControl, + verbose, + label +) { if (!chainLocal$runInf) { return(NULL) } - if (p$verbose >= 1) { - msg <- glue("Fitting susieInf (RSS) for {p$label} ...") + if (verbose >= 1) { + msg <- glue("Fitting susieInf (RSS) for {label} ...") inform(msg) } .fmFitSusieRss( - p$z, - p$R, - p$n, + z, + R, + n, "susieInf", - coverage = p$coverage, - userArgs = p$methodArgs[["susieInf"]], - rFinite = p$rFinite, - rMismatch = p$rMismatch, - rssControl = p$rssControl + coverage = coverage, + userArgs = methodArgs[["susieInf"]], + rFinite = rFinite, + rMismatch = rMismatch, + rssControl = rssControl ) } # Standard multi-effect SuSiE-RSS fit (susie / susieAsh): the only branch that # carries susieR's finite-sample R diagnostics and honours the SER fallback. -.fmRssFitStd <- function(tk, p, chainLocal, infFit) { +.fmRssFitStd <- function( + tk, + chainLocal, + infFit, + z, + R, + n, + coverage, + methodArgs, + rFinite, + rMismatch, + rssControl, + verbose, + label, + serFallback +) { chainFrom <- if ( (tk == "susie" && chainLocal$chainSusie) || (tk == "susieAsh" && chainLocal$chainAsh) @@ -3977,21 +4587,21 @@ extractTopPipInfo <- function(fmRow, sumstats) { } else { NULL } - if (p$verbose >= 1) { - msg <- glue("Fitting {tk} (RSS) for {p$label} ...") + if (verbose >= 1) { + msg <- glue("Fitting {tk} (RSS) for {label} ...") inform(msg) } fit <- .fmFitSusieRss( - p$z, - p$R, - p$n, + z, + R, + n, tk, chainFromInf = chainFrom, - coverage = p$coverage, - userArgs = p$methodArgs[[tk]], - rFinite = p$rFinite, - rMismatch = p$rMismatch, - rssControl = p$rssControl + coverage = coverage, + userArgs = methodArgs[[tk]], + rFinite = rFinite, + rMismatch = rMismatch, + rssControl = rssControl ) rfd <- fit$R_finite_diagnostics flag <- if (!is.null(rfd) && !is.null(rfd$R_reliability_flag)) { @@ -3999,16 +4609,33 @@ extractTopPipInfo <- function(fmRow, sumstats) { } else { NA } - multiFit <- NULL - if (isTRUE(p$serFallback) && isTRUE(flag) && !is.null(rfd$ser_model)) { - multiFit <- fit - fit <- .setFinemappingFitClass(rfd$ser_model, "susieRss") + if (!isTRUE(serFallback) || !isTRUE(flag) || is.null(rfd$ser_model)) { + return(list(fit = fit, flag = flag, multiFit = NULL)) } - list(fit = fit, flag = flag, multiFit = multiFit) + list( + fit = .setFinemappingFitClass(rfd$ser_model, "susieRss"), + flag = flag, + multiFit = fit + ) } # Resolve the fit for one method token; NULL means "skip this token". -.fmRssFitOne <- function(tk, p, chainLocal, infFit) { +.fmRssFitOne <- function( + tk, + chainLocal, + infFit, + z, + R, + n, + coverage, + methodArgs, + rFinite, + rMismatch, + rssControl, + verbose, + label, + serFallback +) { if (tk == "susieInf") { if (!chainLocal$keepInf) { return(NULL) @@ -4016,42 +4643,70 @@ extractTopPipInfo <- function(fmRow, sumstats) { return(list(fit = infFit, flag = NA, isStd = FALSE, multiFit = NULL)) } if (tk == "ser") { - if (p$verbose >= 1) { - msg <- glue("Fitting ser (RSS single-effect) for {p$label} ...") + if (verbose >= 1) { + msg <- glue("Fitting ser (RSS single-effect) for {label} ...") inform(msg) } fit <- .fmFitSusieSer( - p$z, - p$n, - coverage = p$coverage, - userArgs = p$methodArgs[["ser"]] + z, + n, + coverage = coverage, + userArgs = methodArgs[["ser"]] ) return(list(fit = fit, flag = NA, isStd = FALSE, multiFit = NULL)) } - std <- .fmRssFitStd(tk, p, chainLocal, infFit) + std <- .fmRssFitStd( + tk, + chainLocal, + infFit, + z = z, + R = R, + n = n, + coverage = coverage, + methodArgs = methodArgs, + rFinite = rFinite, + rMismatch = rMismatch, + rssControl = rssControl, + verbose = verbose, + label = label, + serFallback = serFallback + ) list(fit = std$fit, flag = std$flag, isStd = TRUE, multiFit = std$multiFit) } # Post-process one RSS fit into a finemapping entry. -.fmRssPostprocess <- function(fit, p) { +.fmRssPostprocess <- function( + fit, + R, + z, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + af, + nVar, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { .fmPostprocessOne( fit = fit, method = "susieRss", - dataX = p$R, - dataY = list(z = p$z), - coverage = p$coverage, - secondaryCoverage = p$secondaryCoverage, - signalCutoff = p$signalCutoff, - minAbsCorr = p$minAbsCorr, - af = p$af, + dataX = R, + dataY = list(z = z), + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + af = af, # Per-variant effective N (reporting-only, top_loci$N). NULL on any path # that has no per-variant N -> buildTopLoci leaves N as NA, never 1. - # This is NOT p$n (the scalar median the RSS fit consumes). - n = p$nVar, + # This is NOT `n` (the scalar median the RSS fit consumes). + n = nVar, csInput = "Xcorr", - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs ) } @@ -4059,14 +4714,21 @@ extractTopPipInfo <- function(fmRow, sumstats) { # on the entry's susieFit list. Gated on serFallback so the default path is # byte-identical. .fmRssRecordFallback <- function(ent, f, keepFullFit) { - sf <- .fmrPartsSusieFit(ent) - sf$R_reliability_flag <- f$flag - sf$serFallbackUsed <- isTRUE(f$flag) - if (!is.null(f$multiFit) && is_in(keepFullFit, c("fallback", "all"))) { - sf$multiEffectFit <- f$multiFit + multiEffectFit <- if ( + !is.null(f$multiFit) && is_in(keepFullFit, c("fallback", "all")) + ) { + f$multiFit } else if (identical(keepFullFit, "all")) { - sf$multiEffectFit <- f$fit - } + f$fit + } + sf <- list_assign( + .fmrPartsSusieFit(ent), + !!!compact(list( + R_reliability_flag = f$flag, + serFallbackUsed = isTRUE(f$flag), + multiEffectFit = multiEffectFit + )) + ) # A row is immutable: rebuild it with the amended fit rather than # assigning into it. The variants and topLoci are unchanged, so this # round-trips them through the same builder the caller used. @@ -4103,38 +4765,60 @@ extractTopPipInfo <- function(fmRow, sumstats) { # Post-process one method's fit (buildTopLoci per fit). # @noRd -.ppOneFit <- function(method, fits, p) { +.ppOneFit <- function( + method, + fits, + dataX, + dataY, + xScalar, + yScalar, + af, + n, + coverage, + secondaryCoverage, + signalCutoff, + otherQuantities, + region, + priorEffTol, + minAbsCorr, + medianAbsCorr, + csInput, + conditionIdx, + trim, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { fit <- .setFinemappingFitClass(fits[[method]], method) postprocessFinemappingFit( fit, method = method, - dataX = p$dataX, - dataY = p$dataY, - xScalar = p$xScalar, - yScalar = p$yScalar, - af = p$af, - n = p$n, - coverage = p$coverage, - secondaryCoverage = p$secondaryCoverage, - signalCutoff = p$signalCutoff, - otherQuantities = p$otherQuantities, - region = p$region, - priorEffTol = p$priorEffTol, - minAbsCorr = p$minAbsCorr, - medianAbsCorr = p$medianAbsCorr, - csInput = p$csInput, - conditionIdx = p$conditionIdx, - trim = p$trim, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs + dataX = dataX, + dataY = dataY, + xScalar = xScalar, + yScalar = yScalar, + af = af, + n = n, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + otherQuantities = otherQuantities, + region = region, + priorEffTol = priorEffTol, + minAbsCorr = minAbsCorr, + medianAbsCorr = medianAbsCorr, + csInput = csInput, + conditionIdx = conditionIdx, + trim = trim, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs ) } # @noRd .ppDropTopLoci <- function(x) { - x$top_loci <- NULL - x + list_modify(x, top_loci = zap()) } # @noRd @@ -4249,15 +4933,15 @@ extractTopPipInfo <- function(fmRow, sumstats) { mergedSets[[variantId]] } else { str_flatten( - sort(unique(unlist(extractedResult[[variantId]]$sets))), + sort(unique(extractedResult[[variantId]]$sets)), "," ) } tibble( variant_id = variantId, credibleSetNames = credibleSetNames, - maxPip = max(unlist(extractedResult[[variantId]]$pips)), - medianPip = median(unlist(extractedResult[[variantId]]$pips)) + maxPip = max(extractedResult[[variantId]]$pips), + medianPip = median(extractedResult[[variantId]]$pips) ) } @@ -4279,8 +4963,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { return(NULL) } csIdx <- .fmCsIdx(topLoci[[csCol]]) - setNum <- unique(csIdx) - setNum <- setNum[!is.na(setNum) & setNum != 0] + uniq <- unique(csIdx) + setNum <- uniq[!is.na(uniq) & uniq != 0] if (length(setNum) == 0) { return(NULL) } diff --git a/R/genotypeIo.R b/R/genotypeIo.R index f76688b3..c72e4a83 100644 --- a/R/genotypeIo.R +++ b/R/genotypeIo.R @@ -33,8 +33,10 @@ NULL setMethod( "readGenotypes", signature(path = "character"), - function(path, format = NULL, ...) { - .genotypeExperiment(.readGenotypeHandle(path, format = format, ...)) + function(path, format = NULL, vcfArgs = list(), ...) { + .genotypeExperiment( + .readGenotypeHandle(path, format = format, vcfArgs = vcfArgs) + ) } ) @@ -43,8 +45,10 @@ setMethod( setMethod( "readGenotypes", signature(path = "missing"), - function(path, format = NULL, ...) { - .genotypeExperiment(GenotypeHandle(...)) + function(path, format = NULL, vcfArgs = list(), ...) { + .genotypeExperiment( + GenotypeHandle(format = format, vcfArgs = vcfArgs, ...) + ) } ) @@ -52,16 +56,16 @@ setMethod( # handle-construction machinery below calls this rather than readGenotypes() # so it does not wrap and immediately unwrap a panel on every hop. # @noRd -.readGenotypeHandle <- function(path, format = NULL, ...) { +.readGenotypeHandle <- function(path, format = NULL, vcfArgs = list()) { if (is.null(format)) { format <- .h2DetectFormat(path) } switch( format, "gds" = .makeGdsHandle(path), - "vcf" = .makeVcfHandle(path, ...), - "plink1" = .makePlink1Handle(path, ...), - "plink2" = .makePlink2Handle(path, ...), + "vcf" = .makeVcfHandle(path, vcfArgs = vcfArgs), + "plink1" = .makePlink1Handle(path), + "plink2" = .makePlink2Handle(path), .abortUnsupportedFormat(format) ) } @@ -79,8 +83,7 @@ setMethod( # (unsubset) handle fileIdx == seq_len(nrow), so reads are unchanged. # @noRd .withFileIdx <- function(snpInfo) { - snpInfo$fileIdx <- seq_len(nrow(snpInfo)) - snpInfo + mutate(snpInfo, fileIdx = seq_len(nrow(snpInfo))) } # Restrict a GenotypeHandle's @snpInfo to `keep` (a logical mask or integer row @@ -107,10 +110,12 @@ setMethod( # nSamples must go to 0 alongside sampleIds, or dm (variants x nSamples) # would disagree with the now-empty derived sample dimnames. Reached only # via .emptySketch (the empty / PIP-skip path), never on a surviving region. - handle@snpInfo <- slice(getSnpInfo(handle), integer(0)) - handle@sampleIds <- character(0) - handle@nSamples <- 0L - handle + methods::initialize( + handle, + snpInfo = slice(getSnpInfo(handle), integer(0)), + sampleIds = character(0), + nSamples = 0L + ) } .subsetGenotypeHandle <- function(handle, keep) { @@ -125,10 +130,10 @@ setMethod( if (!is_in("fileIdx", names(si))) { return(handle) } # legacy handle: unsafe - handle@snpInfo <- slice(si, keepIdx) - handle + methods::initialize(handle, snpInfo = slice(si, keepIdx)) } +#' @importFrom checkmate assertFileExists #' @keywords internal .makeGdsHandle <- function(path) { if (!requireNamespace("SNPRelate", quietly = TRUE)) { @@ -137,10 +142,7 @@ setMethod( if (!requireNamespace("gdsfmt", quietly = TRUE)) { abort("Package 'gdsfmt' is required for reading GDS files.") } - if (!file.exists(path)) { - msg <- glue("GDS file not found: {path}") - abort(msg) - } + assertFileExists(path, access = "r", .var.name = "GDS file") snpInfo <- .gdsSnpInfo(path) @@ -158,15 +160,13 @@ setMethod( ) } +#' @importFrom checkmate assertFileExists #' @keywords internal -.makeVcfHandle <- function(path, ...) { +.makeVcfHandle <- function(path, vcfArgs = list()) { if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { abort("Package 'VariantAnnotation' is required for reading VCF files.") } - if (!file.exists(path)) { - msg <- glue("VCF file not found: {path}") - abort(msg) - } + assertFileExists(path, access = "r", .var.name = "VCF file") hdr <- VariantAnnotation::scanVcfHeader(path) sampleIds <- as.character(VariantAnnotation::samples(hdr)) @@ -177,7 +177,12 @@ setMethod( info = NA, geno = NA ) - vcf <- VariantAnnotation::readVcf(path, param = param, ...) + vcf <- exec( + VariantAnnotation::readVcf, + path, + param = param, + !!!vcfArgs + ) rd <- rowRanges(vcf) # pecotmr convention: A1 = ALT (effect), A2 = REF @@ -201,7 +206,7 @@ setMethod( } #' @keywords internal -.makePlink1Handle <- function(path, ...) { +.makePlink1Handle <- function(path) { if (!requireNamespace("snpStats", quietly = TRUE)) { abort("Package 'snpStats' is required for reading plink1 files.") } @@ -220,14 +225,14 @@ setMethod( # Resolve the plink1 stem and assert its .bed/.bim/.fam all exist. # @noRd +#' @importFrom checkmate assertFileExists .plink1RequireFiles <- function(path) { stem <- .plinkStem(path) - for (f in str_c(stem, c(".bed", ".bim", ".fam"))) { - if (!file.exists(f)) { - msg <- glue("Plink file not found: {f}") - abort(msg) - } - } + assertFileExists( + str_c(stem, c(".bed", ".bim", ".fam")), + access = "r", + .var.name = "Plink file" + ) stem } @@ -265,7 +270,7 @@ setMethod( } #' @keywords internal -.makePlink2Handle <- function(path, ...) { +.makePlink2Handle <- function(path) { if (!requireNamespace("pgenlibr", quietly = TRUE)) { abort("Package 'pgenlibr' is required for reading plink2 files.") } @@ -290,9 +295,9 @@ setMethod( psam <- vroom( paths$psam, delim = "\t", - show_col_types = FALSE + show_col_types = FALSE, + .name_repair = .psamHeaderNames ) - names(psam) <- str_remove(names(psam), "^#") sampleIds <- as.character(psam$IID) pgen <- pgenlibr::NewPgen(paths$pgen) @@ -349,14 +354,12 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # Read ascending, then put the columns back in the requested order. See # .restoreRequestedOrder() for why this is not merely tidiness. ord <- order(.genotypeFilePos(handle, snpIdx)) - geno <- .extractBlockByFormat(handle, snpIdx[ord]) - if (is.null(geno)) { + raw <- .extractBlockByFormat(handle, snpIdx[ord]) + if (is.null(raw)) { return(NULL) } - geno <- .restoreRequestedOrder(geno, ord) - if (meanImpute) { - geno <- .meanImputeGeno(geno) - } + ordered <- .restoreRequestedOrder(raw, ord) + geno <- if (meanImpute) .meanImputeGeno(ordered) else ordered .blockGenotypesToSe(geno, handle, snpIdx) } @@ -431,11 +434,31 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { } else { as.matrix(genotypeCovariates) } - SummarizedExperiment::colData(panel) <- .genotypeColData( - gCov, - colnames(panel) + SummarizedExperiment::`colData<-`( + panel, + value = .genotypeColData(gCov, colnames(panel)) ) - panel +} + +# PLINK2 writes the .psam header line with a leading "#" on the first field. +# @noRd +.psamHeaderNames <- function(nms) str_remove(nms, "^#") + +# Covariate rows carry the sample identity. An unnamed matrix is only +# interpretable when it already has one row per panel sample, in order. +# @noRd +.genotypeCovariateRownames <- function(gCov, sampleIds) { + if (!is.null(rownames(gCov))) { + return(gCov) + } + if (nrow(gCov) != length(sampleIds)) { + abort(glue( + "'genotypeCovariates' has {nrow(gCov)} rows but the panel ", + "has {length(sampleIds)} samples; name its rows to align ", + "them explicitly" + )) + } + `rownames<-`(gCov, sampleIds) } # Per-sample covariates as a colData aligned to the panel's sample order. @@ -447,19 +470,11 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { if (ncol(gCov) == 0L || nrow(gCov) == 0L) { return(empty) } - if (is.null(rownames(gCov))) { - if (nrow(gCov) != length(sampleIds)) { - abort(glue( - "'genotypeCovariates' has {nrow(gCov)} rows but the panel ", - "has {length(sampleIds)} samples; name its rows to align ", - "them explicitly" - )) - } - rownames(gCov) <- sampleIds - } - aligned <- gCov[match(sampleIds, rownames(gCov)), , drop = FALSE] - rownames(aligned) <- sampleIds - S4Vectors::DataFrame(aligned, row.names = sampleIds) + named <- .genotypeCovariateRownames(gCov, sampleIds) + S4Vectors::DataFrame( + named[match(sampleIds, rownames(named)), , drop = FALSE], + row.names = sampleIds + ) } # snpInfo as rowRanges for a genotype panel: width-1 ranges at each @@ -471,17 +486,16 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # @noRd .genotypeSnpRanges <- function(genotypes, variantIds) { si <- getSnpInfo(genotypes) - gr <- GenomicRanges::GRanges( - seqnames = withChrPrefix(as.character(si$CHR)), - ranges = IRanges::IRanges(as.integer(si$BP), width = 1L) - ) - names(gr) <- variantIds - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = as.character(si$SNP), - A1 = as.character(si$A1), - A2 = as.character(si$A2) + `names<-`( + GenomicRanges::GRanges( + seqnames = withChrPrefix(as.character(si$CHR)), + ranges = IRanges::IRanges(as.integer(si$BP), width = 1L), + SNP = as.character(si$SNP), + A1 = as.character(si$A1), + A2 = as.character(si$A2) + ), + variantIds ) - gr } # Dispatch block extraction to the format-specific backend (samples x variants). @@ -509,14 +523,14 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { ) rowRanges <- GRanges( seqnames = chr, - ranges = IRanges(start = as.integer(si$BP), width = 1L) + ranges = IRanges(start = as.integer(si$BP), width = 1L), + SNP = si$SNP, + A1 = si$A1, + A2 = si$A2 ) - mcols(rowRanges) <- DataFrame(SNP = si$SNP, A1 = si$A1, A2 = si$A2) sampleIds <- getSampleIds(handle) # Transpose to Bioc convention: variants x samples. - dosage <- t(geno) - rownames(dosage) <- si$SNP - colnames(dosage) <- sampleIds + dosage <- `dimnames<-`(t(geno), list(si$SNP, sampleIds)) SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rowRanges, @@ -545,11 +559,14 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { } blockGlobal <- which(unifiedChr == chrom) # file-order global indices localIdx <- match(snpIdx[posInReq], blockGlobal) - th <- handle - th@path <- handle@chromPaths[[chrom]] - th@snpInfo <- slice(handle@snpInfo, blockGlobal) - th@pgenPtr <- NULL - th@chromPaths <- character(0) # treat as single-file + th <- methods::initialize( + handle, + path = handle@chromPaths[[chrom]], + snpInfo = slice(handle@snpInfo, blockGlobal), + pgenPtr = NULL, + # Treated as single-file: the view addresses one chromosome's payload. + chromPaths = character(0) + ) extractBlockGenotypes(th, localIdx, meanImpute = meanImpute) } @@ -606,7 +623,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # trips on disjoint seqlevels) and restore the requested snpIdx order. # @noRd .combineShardedSes <- function(ses, groups) { - ord <- order(unlist(groups, use.names = FALSE)) + ord <- order(unname(list_c(groups))) dosages <- map(ses, .seDosage) combinedDos <- exec(rbind, !!!dosages)[ord, , drop = FALSE] rowRangesList <- unname(map(ses, SummarizedExperiment::rowRanges)) @@ -649,14 +666,13 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { ) gt <- VariantAnnotation::geno(vcf)$GT - # Convert GT strings to ALT dosage (A1 dosage) - geno <- matrix(NA_real_, nrow = ncol(gt), ncol = nrow(gt)) - for (j in seq_len(nrow(gt))) { - g <- gt[j, ] - geno[, j] <- map_dbl(g, .gtStringToDosage) - } - - geno + # Convert GT strings to ALT dosage (A1 dosage): one column per variant, + # laid side by side rather than filled into a preallocated matrix. + matrix( + map_dbl(as.vector(t(gt)), .gtStringToDosage), + nrow = ncol(gt), + ncol = nrow(gt) + ) } #' @keywords internal @@ -671,18 +687,16 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { ) # snpStats as(x, "numeric") gives count of B allele (A2/bim col 6). # Flip to count A1 (bim col 5 / effect allele). - geno <- 2 - as(plinkData$genotypes, "numeric") - storage.mode(geno) <- "double" - geno + `storage.mode<-`(2 - as(plinkData$genotypes, "numeric"), "double") } #' @keywords internal +#' @importFrom rlang try_fetch .extractBlockPlink2 <- function(handle, snpIdx) { # pgenlibr::ReadList returns ALT dosage = A1 dosage in pecotmr convention. # The cached @pgenPtr does not survive saveRDS/readRDS (external pointers # become stale), so we re-open from getPath() on the fly if the cached # pointer errors out. Opening is cheap relative to dosage extraction. - ptr <- getPgenPtr(handle) paths <- resolvePlink2Paths(.genotypeReadPath(handle)) # `variant_subset` indexes the .pgen by FILE position. `snpIdx` is a # position into @snpInfo, which may have been row-subset; translate through @@ -694,16 +708,14 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # A sharded handle routes through a transient view with pgenPtr = NULL (one # pgen per chromosome), and a deserialized pointer is stale; open a fresh # pgen up front in those cases rather than provoking a caught read error. - if (is.null(ptr)) { - ptr <- pgenlibr::NewPgen(paths$pgen) - } - geno <- tryCatch( + ptr <- getPgenPtr(handle) %||% pgenlibr::NewPgen(paths$pgen) + geno <- try_fetch( pgenlibr::ReadList( ptr, variant_subset = variantSubset, meanimpute = FALSE ), - error = function(e) { + error = function(cnd) { reopened <- pgenlibr::NewPgen(paths$pgen) pgenlibr::ReadList( reopened, @@ -712,8 +724,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { ) } ) - storage.mode(geno) <- "double" - geno + `storage.mode<-`(geno, "double") } # ============================================================================= @@ -802,12 +813,15 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { #' @keywords internal .meanImputeGeno <- function(geno) { - naCols <- which(colSums(is.na(geno)) > 0L) - for (j in naCols) { - colMean <- mean(geno[, j], na.rm = TRUE) - geno[is.na(geno[, j]), j] <- colMean + naMask <- is.na(geno) + if (!any(naMask)) { + return(geno) } - geno + # One fill over the whole matrix rather than a copy per column: geno is + # samples x variants, so rebuilding it column by column is the expensive + # way to say this. + means <- colMeans(geno, na.rm = TRUE) + replace(geno, naMask, means[col(geno)[naMask]]) } #' @keywords internal @@ -911,9 +925,10 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { #' @importFrom SummarizedExperiment assay readBim <- function(bed) { bimf <- str_c(file_path_sans_ext(bed), ".bim") - bim <- vroom(bimf, col_names = FALSE) - colnames(bim) <- c("chrom", "id", "gpos", "pos", "a1", "a0") - return(bim) + `colnames<-`( + vroom(bimf, col_names = FALSE), + c("chrom", "id", "gpos", "pos", "a1", "a0") + ) } #' @importFrom vroom vroom @@ -926,11 +941,7 @@ readFam <- function(bed) { # open bed/bim/fam: A PLINK 1 .bed is a valid .pgen openBed <- function(bed) { if (!requireNamespace("pgenlibr", quietly = TRUE)) { - msg <- glue( - "To use this function, please install pgenlibr: ", - "https://cran.r-project.org/web/packages/pgenlibr/index.html" - ) - abort(msg) + abort("Package 'pgenlibr' is required for this function.") } rawSCt <- nrow(readFam(bed)) return(pgenlibr::NewPgen(bed, raw_sample_ct = rawSCt)) @@ -949,7 +960,9 @@ openBed <- function(bed) { #' package = "pecotmr"), "protocol_example.LD.chr22") #' readAfreq(stem) #' @export +#' @importFrom checkmate assertString readAfreq <- function(prefix) { + assertString(prefix) afreqZst <- str_c(prefix, ".afreq.zst") afreqPlain <- str_c(prefix, ".afreq") if (file.exists(afreqZst)) { @@ -969,7 +982,7 @@ readAfreq <- function(prefix) { } # PLINK2 .afreq: REF = A2, ALT = A1, ALT_FREQS = A1 (effect allele) # frequency - af <- rename( + renamed <- rename( af, "chrom" = "#CHROM", "id" = "ID", @@ -978,15 +991,19 @@ readAfreq <- function(prefix) { "alt_freq" = "ALT_FREQS", "obs_ct" = "OBS_CT" ) - cols <- c("chrom", "id", "A2", "A1", "alt_freq", "obs_ct") - # Stochastic genotype .afreq includes U_MIN/U_MAX for exact min-max - # inversion - if (is_in("U_MIN", colnames(af))) { - af <- rename(af, "u_min" = "U_MIN", "u_max" = "U_MAX") - cols <- c(cols, "u_min", "u_max") + # A stochastic-genotype .afreq also carries U_MIN / U_MAX, which + # invertMinmaxScaling() needs for an exact min-max inversion. + stochastic <- is_in("U_MIN", colnames(renamed)) + cols <- c( + c("chrom", "id", "A2", "A1", "alt_freq", "obs_ct"), + if (stochastic) c("u_min", "u_max") + ) + out <- if (stochastic) { + rename(renamed, "u_min" = "U_MIN", "u_max" = "U_MAX") + } else { + renamed } - af <- select(af, all_of(cols)) - return(af) + select(out, all_of(cols)) } #' Read stochastic genotype sidecar metadata (U_MIN/U_MAX). @@ -1014,16 +1031,15 @@ readStochasticMeta <- function(path, format = NULL) { return(NULL) } - if (is.null(format)) { - format <- if (str_detect(path, "\\.afreq(\\.zst)?$")) { + detected <- format %||% + if (str_detect(path, "\\.afreq(\\.zst)?$")) { "afreq" } else { "generic" } - } - format <- arg_match(format, c("afreq", "generic")) + resolved <- arg_match(detected, c("afreq", "generic")) - if (format == "afreq") { + if (resolved == "afreq") { # readAfreq expects a prefix, not a full path - strip the .afreq[.zst] # suffix prefix <- str_remove(path, "\\.afreq(\\.zst)?$") @@ -1099,28 +1115,22 @@ invertMinmaxScaling <- function(X, uMin, uMax) { ) abort(msg) } - denom <- uMax - uMin - denom[denom == 0] <- 1 # monomorphic: scaling was identity + span <- uMax - uMin + # Monomorphic variant: the forward scaling was the identity. + denom <- replace(span, span == 0, 1) # Invert: U_original = U_scaled * (u_max - u_min) / 2 + u_min sweep(sweep(X, 2, denom / 2, "*"), 2, uMin, "+") } # ---------- Internal helpers for PLINK2 format ---------- +#' @importFrom checkmate assertFileExists #' Resolve and validate PLINK2 file paths for a given prefix. #' @return Named list with pgen, pvar, psam paths. #' @noRd resolvePlink2Paths <- function(prefix) { pgen <- str_c(prefix, ".pgen") - if (!file.exists(pgen)) { - msg <- glue( - "PLINK2 .pgen file not found at: {pgen}\n", - " Note: .pgen must be uncompressed (plink2 does not ", - "compress .pgen).", - .trim = FALSE - ) - abort(msg) - } + assertFileExists(pgen, access = "r", .var.name = "PLINK2 .pgen file") # Prefer plain .pvar (fast, no extra deps); fall back to .pvar.zst pvar <- if (file.exists(str_c(prefix, ".pvar"))) { str_c(prefix, ".pvar") @@ -1131,15 +1141,7 @@ resolvePlink2Paths <- function(prefix) { abort(msg) } psam <- str_c(prefix, ".psam") - if (!file.exists(psam)) { - msg <- glue( - "PLINK2 .psam file not found at: {psam}\n", - " Note: .psam must be uncompressed (plink2 does not ", - "compress .psam).", - .trim = FALSE - ) - abort(msg) - } + assertFileExists(psam, access = "r", .var.name = "PLINK2 .psam file") list(pgen = pgen, pvar = pvar, psam = psam) } @@ -1153,11 +1155,7 @@ resolvePlink2Paths <- function(prefix) { #' @noRd readPvar <- function(pvarPath) { if (!requireNamespace("pgenlibr", quietly = TRUE)) { - msg <- glue( - "pgenlibr is required. Install from ", - "https://cran.r-project.org/web/packages/pgenlibr/index.html" - ) - abort(msg) + abort("Package 'pgenlibr' is required.") } pvar <- pgenlibr::NewPvar(pvarPath) on.exit(pgenlibr::ClosePvar(pvar), add = TRUE) @@ -1172,6 +1170,32 @@ readPvar <- function(pvarPath) { ) } +# PLINK1 .bim files come in a 6-column form and a 9-column extended form; +# the column meanings are positional, so the width selects the header. +# @noRd +.plinkVariantColnames <- function(n, snpFilePath) { + if (n == 6) { + return(c("chrom", "id", "gpos", "pos", "A1", "A2")) + } + if (n == 9) { + return(c( + "chrom", + "id", + "gpos", + "pos", + "A1", + "A2", + "variance", + "allele_freq", + "n_nomiss" + )) + } + abort(glue( + "Unexpected number of columns ({n}) in variant file: ", + "{snpFilePath}" + )) +} + #' Read variant metadata from either .bim or .pvar/.pvar.zst file. #' #' Auto-detects the format by extension and header, then returns a standardized @@ -1184,39 +1208,17 @@ readPvar <- function(pvarPath) { #' @importFrom readr read_table cols col_character #' @noRd readVariantMetadata <- function(snpFilePath) { - isPvar <- str_detect(snpFilePath, "\\.(pvar|pvar\\.zst)$") - if (!isPvar) { - firstLine <- read_lines(snpFilePath, n_max = 1) - isPvar <- str_detect(firstLine, "^#CHROM") - } + # Extension first, then the header line: a .pvar written without its + # extension still announces itself with a #CHROM header. + byExtension <- str_detect(snpFilePath, "\\.(pvar|pvar\\.zst)$") + isPvar <- byExtension || + str_detect(read_lines(snpFilePath, n_max = 1), "^#CHROM") if (isPvar) { readPvar(snpFilePath) } else { df <- read_table(snpFilePath, col_names = FALSE, col_types = cols()) - n <- ncol(df) - if (n == 6) { - names(df) <- c("chrom", "id", "gpos", "pos", "A1", "A2") - } else if (n == 9) { - names(df) <- c( - "chrom", - "id", - "gpos", - "pos", - "A1", - "A2", - "variance", - "allele_freq", - "n_nomiss" - ) - } else { - msg <- glue( - "Unexpected number of columns ({n}) in variant file: ", - "{snpFilePath}" - ) - abort(msg) - } - df + `names<-`(df, .plinkVariantColnames(ncol(df), snpFilePath)) } } @@ -1274,10 +1276,14 @@ getRefVariantInfo <- function(source, region = NULL) { paths <- resolvePlink2Paths(dataPath) info <- readPvar(paths$pvar) afreq <- readAfreq(dataPath) - if (!is.null(afreq)) { - info$allele_freq <- afreq$alt_freq[match(info$id, afreq$id)] - } - info + mutate( + info, + !!!compact(list( + allele_freq = if (!is.null(afreq)) { + afreq$alt_freq[match(info$id, afreq$id)] + } + )) + ) } # plink1 variant info from the .bim (col5 = A1, col6 = A2). @@ -1302,9 +1308,10 @@ getRefVariantInfo <- function(source, region = NULL) { region = region, returnVariantInfo = TRUE ) - info <- result$variant_info - info$allele_freq <- colMeans(result$X, na.rm = TRUE) / 2 - info + mutate( + result$variant_info, + allele_freq = colMeans(result$X, na.rm = TRUE) / 2 + ) } # Pre-computed LD variant info: read the per-intersection bim/pvar metadata @@ -1315,9 +1322,8 @@ getRefVariantInfo <- function(source, region = NULL) { resolved$metaPath, region )$intersections$bimFilePaths - info <- bind_rows(map(bimPaths, .refReadBimMeta)) - info$id <- normalizeVariantId(info$id) - info + bind_rows(map(bimPaths, .refReadBimMeta)) |> + mutate(id = normalizeVariantId(.data$id)) } # Read one bim/pvar metadata file into a canonical variant-info data.frame, @@ -1332,12 +1338,16 @@ getRefVariantInfo <- function(source, region = NULL) { A2 = df$A2, A1 = df$A1 ) - for (col in c("variance", "allele_freq", "n_nomiss")) { - if (is_in(col, names(df))) { - out[[col]] <- df[[col]] - } - } - out + optional <- intersect(c("variance", "allele_freq", "n_nomiss"), names(df)) + mutate( + out, + !!!set_names(map(optional, .refMetaColumn, df = df), optional) + ) +} + +# @noRd +.refMetaColumn <- function(col, df) { + df[[col]] } # Filter plink2 / plink1 variant info to the requested region. @@ -1361,14 +1371,25 @@ getRefVariantInfo <- function(source, region = NULL) { # OR-mask across a multi-row (one row per chrom) parsed region. # @noRd .refMultiRegionMask <- function(infoChrom, pos, parsed) { - inRegion <- rep(FALSE, length(infoChrom)) - for (r in seq_len(nrow(parsed))) { - inRegion <- inRegion | - (infoChrom == as.character(parsed$chrom[r]) & - pos >= parsed$start[r] & - pos <= parsed$end[r]) - } - inRegion + reduce( + map( + seq_len(nrow(parsed)), + .refRegionRowMask, + infoChrom = infoChrom, + pos = pos, + parsed = parsed + ), + `|`, + .init = rep(FALSE, length(infoChrom)) + ) +} + +# Variants falling inside parsed region row `r`. +# @noRd +.refRegionRowMask <- function(r, infoChrom, pos, parsed) { + infoChrom == as.character(parsed$chrom[r]) & + pos >= parsed$start[r] & + pos <= parsed$end[r] } #' Match variant_info against a whitelist file, returning logical index. Uses @@ -1377,9 +1398,9 @@ getRefVariantInfo <- function(source, region = NULL) { #' @importFrom readr read_lines #' @noRd matchVariantsToKeep <- function(variantInfo, keepVariantsPath) { - keepRaw <- tryCatch( + keepRaw <- try_fetch( as.data.frame(vroom(keepVariantsPath, show_col_types = FALSE)), - error = function(e) NULL + error = function(cnd) NULL ) if ( !is.null(keepRaw) && @@ -1467,16 +1488,16 @@ loadGenotypeRegion <- function( handleSnpInfo <- getSnpInfo(handle) snpIdx <- .loadGenoSnpIdx(handleSnpInfo, region) # Samples x variants matrix (pecotmr convention); callers handle missing. - result <- list( + extracted <- list( X = .dosageMatrix(handle, snpIdx, meanImpute = FALSE), variant_info = .loadGenoAttachAfreq( handle, .snpInfoToVariantInfo(slice(handleSnpInfo, snpIdx)) ) ) - result <- .loadGenoPostFilter(result, keepIndel, keepVariantsPath) + filtered <- .loadGenoPostFilter(extracted, keepIndel, keepVariantsPath) result <- .loadGenoInvertStochastic( - result, + filtered, genotype, stochasticMetaPath, stochasticMetaFormat @@ -1545,20 +1566,32 @@ loadGenotypeRegion <- function( # Apply the indel-drop and variant-whitelist post-filters to (X, variant_info). # @noRd .loadGenoPostFilter <- function(result, keepIndel, keepVariantsPath) { - if (!keepIndel) { - snpMask <- isSnpAlleles( - result$variant_info$A1, - result$variant_info$A2 + snpOnly <- if (keepIndel) { + result + } else { + .loadGenoSubsetVariants( + result, + isSnpAlleles(result$variant_info$A1, result$variant_info$A2) ) - result$X <- result$X[, snpMask, drop = FALSE] - result$variant_info <- result$variant_info[snpMask, , drop = FALSE] } - if (!is.null(keepVariantsPath)) { - keepIdx <- matchVariantsToKeep(result$variant_info, keepVariantsPath) - result$X <- result$X[, keepIdx, drop = FALSE] - result$variant_info <- result$variant_info[keepIdx, , drop = FALSE] + if (is.null(keepVariantsPath)) { + return(snpOnly) } - result + .loadGenoSubsetVariants( + snpOnly, + matchVariantsToKeep(snpOnly$variant_info, keepVariantsPath) + ) +} + +# Subset a loaded (X, variant_info) pair along the variant axis, keeping the +# dosage columns and the metadata rows in step. +# @noRd +.loadGenoSubsetVariants <- function(result, keep) { + list_assign( + result, + X = result$X[, keep, drop = FALSE], + variant_info = result$variant_info[keep, , drop = FALSE] + ) } # Detect stochastic genotype scaling and restore the original scale from a @@ -1584,19 +1617,31 @@ loadGenotypeRegion <- function( if (!any(matched)) { return(result) } - result$X[, matched] <- invertMinmaxScaling( - result$X[, matched, drop = FALSE], - smeta$u_min[idx[matched]], - smeta$u_max[idx[matched]] + inverted <- `[<-`( + result$X, + , + matched, + value = invertMinmaxScaling( + result$X[, matched, drop = FALSE], + smeta$u_min[idx[matched]], + smeta$u_max[idx[matched]] + ) + ) + restored <- list_assign( + result, + X = inverted, + variant_info = mutate( + result$variant_info, + u_min = smeta$u_min[idx], + u_max = smeta$u_max[idx] + ) ) - result$variant_info$u_min <- smeta$u_min[idx] - result$variant_info$u_max <- smeta$u_max[idx] msg <- glue( "Stochastic genotype detected: restored original scale via ", "{basename(metaPath)}" ) inform(msg) - result + restored } # Warn when non-integer dosages are present but no stochastic sidecar was found. @@ -1685,8 +1730,7 @@ loadGenotypeRegion <- function( if (is.null(geno) || length(geno) == 0) { return(NULL) } - storage.mode(geno) <- "double" - geno + `storage.mode<-`(geno, "double") } # The sample-LD matrix for `handle`'s `snpIdx` variants (NA correlations -> 0). @@ -1704,13 +1748,10 @@ loadGenotypeRegion <- function( slide = -1, verbose = FALSE ) - R <- ldMat$LD - R[is.na(R)] <- 0 + raw <- replace(ldMat$LD, is.na(ldMat$LD), 0) inv <- order(ord) - R <- R[inv, inv, drop = FALSE] ids <- getSnpInfo(handle)$SNP[snpIdx] - dimnames(R) <- list(ids, ids) - R + `dimnames<-`(raw[inv, inv, drop = FALSE], list(ids, ids)) } # The (SNP, CHR, BP, A1, A2) snpInfo frame from an open GDS. A1 = the first diff --git a/R/gwasSumStats.R b/R/gwasSumStats.R index eb742045..d7afd3ac 100644 --- a/R/gwasSumStats.R +++ b/R/gwasSumStats.R @@ -22,41 +22,38 @@ NULL #' every row. #' @seealso \code{\link{GwasSumStats}} for the constructor and #' \code{\linkS4class{QtlSumStats}} for the QTL counterpart. +#' @importFrom checkmate makeAssertCollection assertNames assertList #' @export setClass( "GwasSumStats", contains = "SumStatsBase", validity = function(object) { # The ldSketch slot's class union enforces its type. - errors <- character() - required <- "study" - missingCols <- setdiff(required, colnames(mcols(object))) - if (length(missingCols) > 0L) { - errors <- c( - errors, - str_c("missing columns: ", str_flatten(missingCols, ", ")) - ) + coll <- makeAssertCollection() + assertNames( + colnames(mcols(object)) %||% character(0), + must.include = "study", + what = "colnames", + .var.name = "mcols", + add = coll + ) + coll$push(.sumStatsCheckGenome(object)) + assertList(object@qcInfo, .var.name = "qcInfo", add = coll) + slotErrors <- coll$getMessages() + if (length(slotErrors) > 0L) { + return(slotErrors) } - errors <- c(errors, .sumStatsCheckGenome(object)) - if (!is.list(object@qcInfo)) { - errors <- c(errors, "'qcInfo' slot must be a list") + # The elements ARE GRanges by construction now -- the container is + # a GRangesList -- so the old per-element type and length checks + # are gone. The one-seqname/one-strand invariant is enforced by + # RangedTupleList's own validity. + # Keyed on (study, range), not study alone: a study split across + # chromosomes contributes one element per seqname, so the study + # label legitimately repeats. + if (.ssHasDuplicateKeys(object, "study")) { + return("(study, range) must be unique") } - if (length(errors) == 0L) { - # The elements ARE GRanges by construction now -- the container is - # a GRangesList -- so the old per-element type and length checks - # are gone. The one-seqname/one-strand invariant is enforced by - # RangedTupleList's own validity. - # Keyed on (study, range), not study alone: a study split across - # chromosomes contributes one element per seqname, so the study - # label legitimately repeats. - if (.ssHasDuplicateKeys(object, "study")) { - errors <- c( - errors, - "(study, range) must be unique" - ) - } - } - if (length(errors) == 0L) TRUE else errors + TRUE } ) @@ -192,9 +189,9 @@ GwasSumStats <- function( cols <- list( study = as.character(study), varY = varY - ) - cols <- .gwasAppendOptional(cols, nCase, nControl, nSample, study) - cols <- .gwasAppendExtras(cols, list(...)) + ) |> + .gwasAppendOptional(nCase, nControl, nSample, study) |> + .gwasAppendExtras(list(...)) dfArgs <- c(cols, list(check.names = FALSE)) # The per-study GRanges become the collection's ELEMENTS; everything else # is per-study metadata and goes in mcols. There is no `entry` column. @@ -206,13 +203,16 @@ GwasSumStats <- function( # with its metadata row replicated alongside. Splitting is unconditional: # a stored element always spans exactly one seqname. split <- .gwasSplitEntry(entry, ldBlocks, blockId, length(entry)) - grl <- GenomicRanges::GRangesList(split$entry) - md <- exec(S4Vectors::DataFrame, !!!dfArgs) - md <- md[split$fromIdx, , drop = FALSE] # `blockId` is always present, so downstream code (cTWAS in particular) can # key regions without first asking how the collection was built. - md$blockId <- split$blockId - mcols(grl) <- md + md <- cbind( + exec(S4Vectors::DataFrame, !!!dfArgs)[split$fromIdx, , drop = FALSE], + S4Vectors::DataFrame(blockId = split$blockId) + ) + grl <- S4Vectors::`mcols<-`( + GenomicRanges::GRangesList(split$entry), + value = md + ) .sumStatsNewValidated("GwasSumStats", grl, ldSketch, genome, qcInfo) } @@ -225,10 +225,10 @@ GwasSumStats <- function( # The build goes into seqinfo, which is where a GRangesList keeps it and # where every Bioconductor consumer reads it from. Assigned before new() # so validity sees the finished object. - GenomeInfoDb::genome(grl) <- as.character(genome) + built <- GenomeInfoDb::`genome<-`(grl, value = as.character(genome)) obj <- methods::new( Class, - grl, + built, ldSketch = .asLdSketch(ldSketch), qcInfo = as.list(qcInfo) ) @@ -256,15 +256,18 @@ GwasSumStats <- function( # columns, so an entry that still splits further replicates its id rather # than falling out of alignment. This is what lets a rebuild (QC) carry # block keys through instead of silently re-deriving them as seqnames. - split$blockId <- if (!is.null(blockId)) { - .gwasCheckBlockId(blockId, n)[split$fromIdx] - } else { - # unname(): the seqname splitter names its pieces, and those names - # would otherwise ride into the mcols column and make it inconsistent - # with the block path, which produces a bare character vector. - unname(map_chr(split$entry, .gwasElementSeqname)) - } - split + list_assign( + split, + blockId = if (!is.null(blockId)) { + .gwasCheckBlockId(blockId, n)[split$fromIdx] + } else { + # unname(): the seqname splitter names its pieces, and those names + # would otherwise ride into the mcols column and make it + # inconsistent with the block path, which produces a bare + # character vector. + unname(map_chr(split$entry, .gwasElementSeqname)) + } + ) } # @noRd @@ -318,25 +321,26 @@ GwasSumStats <- function( # when supplied; NA for the non-case/control studies in a mixed collection). # @noRd .gwasAppendOptional <- function(cols, nCase, nControl, nSample, study) { - if (!is.null(nCase)) { - cols$nCase <- .recyclePerStudy(nCase, "nCase", study) - } - if (!is.null(nControl)) { - cols$nControl <- .recyclePerStudy(nControl, "nControl", study) - } - if (!is.null(nSample)) { - cols$nSample <- .recyclePerStudy(nSample, "nSample", study) - } - cols + c( + cols, + compact(list( + nCase = if (!is.null(nCase)) { + .recyclePerStudy(nCase, "nCase", study) + }, + nControl = if (!is.null(nControl)) { + .recyclePerStudy(nControl, "nControl", study) + }, + nSample = if (!is.null(nSample)) { + .recyclePerStudy(nSample, "nSample", study) + } + )) + ) } # Append any user-supplied extra columns (from `...`). # @noRd .gwasAppendExtras <- function(cols, extras) { - for (nm in names(extras)) { - cols[[nm]] <- extras[[nm]] - } - cols + c(cols, extras) } @@ -458,9 +462,11 @@ as.data.frame.GwasSumStats <- function( ... ) { gr <- getSumStats(x, study = study) - mc <- as.data.frame(mcols(gr)) - mc$CHR <- as.character(seqnames(gr)) - mc$BP <- start(gr) + mc <- mutate( + as.data.frame(mcols(gr)), + CHR = as.character(seqnames(gr)), + BP = start(gr) + ) firstCols <- c("SNP", "CHR", "BP") restCols <- setdiff(names(mc), firstCols) select(mc, all_of(c(firstCols, restCols))) diff --git a/R/h2Annotations.R b/R/h2Annotations.R index d4d8f277..8e82e100 100644 --- a/R/h2Annotations.R +++ b/R/h2Annotations.R @@ -61,19 +61,26 @@ setMethod( if (.annotDetectFormat(p) == "bigwig") "continuous" else "binary" } +# @noRd +.readAnnotColumnAt <- function(i, paths, snpRanges, annotNames) { + .readAnnotColumn(paths[i], snpRanges, annotNames[i]) +} + # Build the (SNP x annotation) matrix by reading each annotation column. # @noRd .readAnnotMatrix <- function(paths, snpRanges, annotNames, nSnps, nAnnots) { - annotMat <- matrix(0, nrow = nSnps, ncol = nAnnots) - colnames(annotMat) <- annotNames - for (i in seq_along(paths)) { - annotMat[, i] <- .readAnnotColumn( - paths[i], - snpRanges, - annotNames[i] - ) - } - annotMat + matrix( + unname(list_c(map( + seq_along(paths), + .readAnnotColumnAt, + paths = paths, + snpRanges = snpRanges, + annotNames = annotNames + ))), + nrow = nSnps, + ncol = nAnnots, + dimnames = list(NULL, annotNames) + ) } # One annotation column, dispatched by detected format (BigWig / .annot / BED). @@ -139,8 +146,7 @@ setMethod( .readBedAnnotation <- function(bedPath, snpRanges) { regions <- rtracklayer::import(bedPath) hits <- findOverlaps(snpRanges, regions) - result <- rep(0L, length(snpRanges)) - result[queryHits(hits)] <- 1L + result <- replace(rep(0L, length(snpRanges)), queryHits(hits), 1L) as.numeric(result) } @@ -174,12 +180,12 @@ setMethod( # Match SNPs by genomic position hits <- findOverlaps(snpRanges, annotGr) - # Initialize result with default 0 - result <- rep(0, length(snpRanges)) - result[queryHits(hits)] <- + # Unmatched SNPs keep the default 0. + replace( + rep(0, length(snpRanges)), + queryHits(hits), as.numeric(dt[[annotName]][subjectHits(hits)]) - - result + ) } # (The AnnotationMatrix() constructor and the getBaseline / getCandidates tier diff --git a/R/h2EstimationWrappers.R b/R/h2EstimationWrappers.R index fc83e9ad..45adade1 100644 --- a/R/h2EstimationWrappers.R +++ b/R/h2EstimationWrappers.R @@ -150,9 +150,13 @@ weightedLsRidge <- function(y, X, w, lambda = 0, penalizeIntercept = FALSE) { XtX <- crossprod(Xw) Xty <- crossprod(Xw, yw) # Ridge penalty matrix (don't penalize intercept by default) - penalty <- diag(lambda, p) - if (!penalizeIntercept && p > 1) { - penalty[p, p] <- 0 + ridge <- diag(lambda, p) + # p * p is the linear index of the [p, p] cell (the intercept's own + # diagonal entry) in a p x p matrix. + penalty <- if (!penalizeIntercept && p > 1) { + replace(ridge, p * p, 0) + } else { + ridge } coef <- solve(XtX + penalty, Xty) fitted <- X %*% coef @@ -183,8 +187,10 @@ weightedLsRidge <- function(y, X, w, lambda = 0, penalizeIntercept = FALSE) { return(tauSe * M / abs(h2)) } nBlocks <- nrow(tauBlocks) - h2Blocks <- as.vector(tauBlocks %*% M_a) - h2Blocks[h2Blocks == 0] <- NA + rawH2 <- as.vector(tauBlocks %*% M_a) + # A zero block h2 would divide the enrichment to Inf; NA drops the block + # from the jackknife mean instead. + h2Blocks <- replace(rawH2, rawH2 == 0, NA) enrichmentBlocks <- sweep(tauBlocks, 1, h2Blocks, FUN = "/") * M enrichmentMean <- colMeans(enrichmentBlocks, na.rm = TRUE) enrichmentVar <- (nBlocks - 1) / @@ -260,8 +266,7 @@ shrinkLd <- function( theta <- 2 * nRef / (22 * nRef + 16) # effective recombination distCm <- abs(outer(geneticMap, geneticMap, "-")) shrinkFactor <- exp(-4 * nRef * distCm / (100 * (2 * nRef + 16))) - RShrunk <- R * shrinkFactor - diag(RShrunk) <- 1 + RShrunk <- `diag<-`(R * shrinkFactor, 1) } else { # Simple constant shrinkage lambda <- 1 / sqrt(nRef) @@ -286,8 +291,7 @@ shrinkLd <- function( #' @keywords internal checkGenomeBuild <- function(...) { objects <- list(...) - genomes <- map_chr(objects, .h2GenomeOfObject) - genomes <- genomes[!is.na(genomes)] + genomes <- discard(map_chr(objects, .h2GenomeOfObject), is.na) if (n_distinct(genomes) > 1L) { msg <- glue( "Genome build mismatch: {str_flatten(genomes, ', ')}" @@ -393,6 +397,7 @@ standardizeTauStar <- function(tau, tauBlocks, sdAnnot, MRef, h2g) { metafor::rma(yi = means, sei = ses, method = "DL") } +#' @importFrom rlang try_fetch .rmaMeta <- function(means, ses, method = "DL") { k <- length(means) if (k != length(ses)) { @@ -409,9 +414,9 @@ standardizeTauStar <- function(tau, tauBlocks, sdAnnot, MRef, h2g) { fit <- if (identical(method, "DL")) { metafor::rma(yi = means, sei = ses, method = "DL") } else { - tryCatch( + try_fetch( metafor::rma(yi = means, sei = ses, method = method), - error = function(e) .rmaMetaFallbackToDL(e, means, ses, method) + error = function(cnd) .rmaMetaFallbackToDL(cnd, means, ses, method) ) } list( @@ -483,8 +488,8 @@ NULL .lderBlockStats <- function(block, z, baselineMat) { V <- block$vectors lam <- block$values - x <- as.vector(crossprod(V, z[block$snpIdx]) / sqrt(pmax(lam, 1e-12))) - x[lam < 1e-6] <- 0 + raw <- as.vector(crossprod(V, z[block$snpIdx]) / sqrt(pmax(lam, 1e-12))) + x <- replace(raw, lam < 1e-6, 0) ldAnnot <- if (is.null(baselineMat)) { matrix(1, length(lam), 1) } else { @@ -496,11 +501,11 @@ NULL # Concatenate per-block stats into the genome-wide regression design. M_a is # the annotation SNP counts (univariate: total number of directions). .lderDesign <- function(blockStats, baselineMat) { - x <- unlist(map(blockStats, "x")) + x <- list_c(map(blockStats, "x")) ldAnnotList <- map(blockStats, "ldAnnot") list( x = x, - lam = unlist(map(blockStats, "lam")), + lam = list_c(map(blockStats, "lam")), ldAnnot = exec(rbind, !!!ldAnnotList), blockId = rep( seq_along(blockStats), @@ -614,8 +619,8 @@ NULL rough = rough, twostage = twostage ) - h2Loo <- unlist(map(loo, "h2")) - aLoo <- unlist(map(loo, "a")) + h2Loo <- map_dbl(loo, "h2") + aLoo <- map_dbl(loo, "a") tauList <- map(loo, "tau") tauBlocks <- exec(rbind, !!!tauList) jkSe <- function(v) sqrt((nB - 1) / nB * sum((v - mean(v))^2)) @@ -695,8 +700,7 @@ NULL ) looZ <- exec(rbind, !!!looRows) R <- cor(looZ) - R[is.na(R)] <- 0 - R + replace(R, is.na(R), 0) } # LDER candidate-annotation score statistics against the fitted baseline. @@ -941,7 +945,7 @@ NULL estHBlocks <- exec(rbind, !!!estHList) tauList <- map(loo, "tau") tauBlocks <- exec(rbind, !!!tauList) - intLoo <- unlist(map(loo, "intercept")) + intLoo <- map_dbl(loo, "intercept") jkSe <- function(v) sqrt(var(v) * (nB - 1)^2 / nB) list( h2Se = jkSe(estHBlocks[, 1]), @@ -1051,8 +1055,7 @@ NULL ) looZ <- exec(rbind, !!!looRows) Rc <- cor(looZ) - Rc[is.na(Rc)] <- 0 - Rc + replace(Rc, is.na(Rc), 0) } list(scoreZ = scoreZ, R = R) } @@ -1076,8 +1079,8 @@ gldscUnivariate <- function( M <- length(ldRef) A <- .gldscAnnotMatrix(annotations, M) preps <- map(ldMatrixList, .gldscBlockPrep, z = z, A = A) - rawNtau <- sum(unlist(map(preps, "y"))) / - sum(unlist(map(preps, "ldsc"))) + rawNtau <- sum(list_c(map(preps, "y"))) / + sum(list_c(map(preps, "ldsc"))) contrib <- map(preps, .gldscBlockGls, rawNtau = rawNtau) left <- reduce(map(contrib, "L"), `+`) right <- reduce(map(contrib, "R"), `+`) @@ -1086,24 +1089,43 @@ gldscUnivariate <- function( .gldscResult(fit, jk, annotations, preps, rawNtau, local, n, M) } +# The candidate-annotation score statistics, when candidates were supplied and +# the score test could be formed for them. NULL otherwise. +# @noRd +.gldscCandidateScores <- function(annotations, preps, rawNtau, fit) { + if (is.null(annotations)) { + return(NULL) + } + candMat <- assay(getCandidates(annotations), "annotations") + sc <- .gldscScoreStats(preps, candMat, rawNtau, fit$coef) + if (is.null(sc)) { + return(NULL) + } + list( + z = sc$scoreZ, + R = sc$R, + annotationNames = SummarizedExperiment::colData( + getCandidates(annotations) + )$name + ) +} + # Assemble the gldscUnivariate return (enrichment, local, candidate scores). .gldscResult <- function(fit, jk, annotations, preps, rawNtau, local, n, M) { baselineMat <- .h2BaselineMat(annotations) localDf <- if (local) .gldscLocal(preps, rawNtau, n) else NULL - enrichmentDf <- NULL - scoreStats <- NULL - if (!is.null(baselineMat)) { - nm <- SummarizedExperiment::colData(getBaseline(annotations))$name - enrichmentDf <- .gldscEnrichmentDf(fit, jk, baselineMat, nm, M) - } - if (!is.null(annotations)) { - candMat <- assay(getCandidates(annotations), "annotations") - sc <- .gldscScoreStats(preps, candMat, rawNtau, fit$coef) - if (!is.null(sc)) { - cn <- SummarizedExperiment::colData(getCandidates(annotations))$name - scoreStats <- list(z = sc$scoreZ, R = sc$R, annotationNames = cn) - } + enrichmentDf <- if (is.null(baselineMat)) { + NULL + } else { + .gldscEnrichmentDf( + fit, + jk, + baselineMat, + SummarizedExperiment::colData(getBaseline(annotations))$name, + M + ) } + scoreStats <- .gldscCandidateScores(annotations, preps, rawNtau, fit) tau <- if (is.null(baselineMat)) fit$h2 else fit$tau[-1] tauSe <- if (is.null(baselineMat)) jk$h2Se else jk$tauSe[-1] jkRes <- list( @@ -1169,11 +1191,13 @@ NULL nTau <- ncol(ldAnnotScaled) h2a <- param[seq_len(nTau)] int <- param[nTau + 1L] - lamh2 <- as.vector(ldAnnotScaled %*% h2a) * - lam^2 - - lam * sum(h2a) / nRef + - int * lam / n - lamh2 <- pmax(lamh2, lim) + lamh2 <- pmax( + as.vector(ldAnnotScaled %*% h2a) * + lam^2 - + lam * sum(h2a) / nRef + + int * lam / n, + lim + ) sum(log(lamh2)) + sum(bstar^2 / lamh2) } @@ -1199,8 +1223,8 @@ NULL # eigenvalue-score matrix, and M_a. Univariate uses a single all-ones score # column (l_{i,base} = 1) scaled by total M. .hdlDesign <- function(blockData, M, baselineMat) { - lam <- unlist(map(blockData, "lam")) - bstar <- unlist(map(blockData, "bstar")) + lam <- list_c(map(blockData, "lam")) + bstar <- list_c(map(blockData, "bstar")) blockId <- rep( seq_along(blockData), lengths(map(blockData, "lam")) @@ -1321,7 +1345,7 @@ NULL ) h2aList <- map(loo, "h2a") h2aBlocks <- exec(rbind, !!!h2aList) - intLoo <- unlist(map(loo, "int")) + intLoo <- map_dbl(loo, "int") jkSe <- function(x) sqrt(mean((x - mean(x))^2) * (nBlocks - 1)) list( h2aSe = apply(h2aBlocks, 2, jkSe), @@ -1452,8 +1476,7 @@ NULL ) looZ <- exec(rbind, !!!looRows) R <- cor(looZ) - R[is.na(R)] <- 0 - R + replace(R, is.na(R), 0) } # ============================================================================= @@ -1629,14 +1652,23 @@ sldscUnivariate <- function( ) abort(msg) } - strat <- matrix(0, M, ncol(baselineMat)) - for (block in ldMatrixList) { - idx <- block$snpIdx - strat[idx, ] <- (block$R^2) %*% baselineMat[idx, , drop = FALSE] - } + strat <- .h2ScatterBlockRows( + matrix(0, M, ncol(baselineMat)), + map(ldMatrixList, .h2BlockAnnotScores, baselineMat = baselineMat) + ) cbind(base_l2 = base, strat) } +# One block's per-annotation LD scores from its full LD matrix. +# @noRd +.h2BlockAnnotScores <- function(block, baselineMat) { + idx <- block$snpIdx + list( + idx = idx, + values = (block$R^2) %*% baselineMat[idx, , drop = FALSE] + ) +} + # Per-block variant indices, from the LD matrices when present and otherwise # by overlapping the reference's variants with its LD blocks. The jackknife # leaves one of these out at a time. @@ -1707,10 +1739,10 @@ sldscUnivariate <- function( # @noRd .sldscFitUnivariate <- function(chi2, scores, baseScore, n, A, nIter) { M <- nrow(A) - keep <- chi2 < 30 - if (sum(keep) < 4L) { - keep <- rep(TRUE, length(chi2)) - } + # Too few variants survive the chi2 cap to fit on: keep everything rather + # than fit on a handful. + capped <- chi2 < 30 + keep <- if (sum(capped) < 4L) rep(TRUE, length(chi2)) else capped # One set of initial weights, formed on the full data, reused by both # steps -- upstream computes `initial_w` once and subsets it for step 1. xTot <- rowSums(scores) @@ -1748,9 +1780,13 @@ sldscUnivariate <- function( # @noRd .sldscFitPartitioned <- function(chi2, scores, baseScore, n, A) { M <- nrow(A) - keep <- chi2 < max(0.001 * n, 80) - if (sum(keep) < ncol(scores) + 2L) { - keep <- rep(TRUE, length(chi2)) + # Too few variants survive the chi2 cap for the design's width: keep + # everything rather than fit an underdetermined system. + capped <- chi2 < max(0.001 * n, 80) + keep <- if (sum(capped) < ncol(scores) + 2L) { + rep(TRUE, length(chi2)) + } else { + capped } chi2 <- chi2[keep] scores <- scores[keep, , drop = FALSE] @@ -1894,10 +1930,16 @@ sldscUnivariate <- function( M ) { localDf <- if (local) .sldscLocal(chi2, baseScore, fit, M) else NULL - enrichmentDf <- NULL - if (!is.null(baselineMat)) { - nm <- SummarizedExperiment::colData(getBaseline(annotations))$name - enrichmentDf <- .gldscEnrichmentDf(fit, jk, baselineMat, nm, M) + enrichmentDf <- if (is.null(baselineMat)) { + NULL + } else { + .gldscEnrichmentDf( + fit, + jk, + baselineMat, + SummarizedExperiment::colData(getBaseline(annotations))$name, + M + ) } tau <- if (is.null(baselineMat)) fit$h2 else fit$tau[-1] tauSe <- if (is.null(baselineMat)) jk$h2Se else jk$tauSe[-1] @@ -1952,15 +1994,21 @@ sldscUnivariate <- function( ldRef, annotations, local, - ... + estimatorArgs = list() ) { - switch( + # `estimatorArgs` rather than `...`: the four estimators take different + # trailing arguments (`lambda` for lder/gldsc/hdl, `nIter` for sldsc), so + # an unknown name should fail here rather than at whichever estimator the + # method token happens to select. + base <- list(z, n, ldRef, annotations, local) + fn <- switch( method, - "lder" = lderUnivariate(z, n, ldRef, annotations, local, ...), - "gldsc" = gldscUnivariate(z, n, ldRef, annotations, local, ...), - "sldsc" = sldscUnivariate(z, n, ldRef, annotations, local, ...), - "hdl" = hdlUnivariate(z, n, ldRef, annotations, local, ...) + "lder" = lderUnivariate, + "gldsc" = gldscUnivariate, + "sldsc" = sldscUnivariate, + "hdl" = hdlUnivariate ) + exec(fn, !!!base, !!!estimatorArgs) } # The estimators read `z` and the annotation rows positionally, by each LD @@ -2069,6 +2117,7 @@ setMethod( annotations = NULL, local = FALSE, study = NULL, + estimatorArgs = list(), ... ) { method <- arg_match(method, c("lder", "gldsc", "sldsc", "hdl")) @@ -2076,14 +2125,12 @@ setMethod( study <- .estimateH2ResolveStudy(sumstats, study) .h2ValidateInputs(sumstats, study, ldRef, annotations) z <- getZ(sumstats, study = study) - n <- median(getN(sumstats, study = study)) + rawN <- median(getN(sumstats, study = study)) M <- nSnps(sumstats, study = study) # Legacy heritability-wrapper correction (separate from the SuSiE RSS # binaryTraitModel handling in the fine-mapping pipeline). varY <- getVarY(sumstats, study = study) - if (!is.null(varY)) { - n <- n / varY - } + n <- if (is.null(varY)) rawN else rawN / varY result <- .estimateH2Dispatch( method, z, @@ -2091,7 +2138,7 @@ setMethod( ldRef, annotations, local, - ... + estimatorArgs = estimatorArgs ) .h2EstimateFromResult(result, method, M, study) } @@ -2120,37 +2167,63 @@ setMethod( # computeLdScores -- LD score computation # ============================================================================= +# Write each block's rows into `base`. Deliberate scatter: the score matrices +# are variants-long and the blocks partition the rows, so every block writes +# its own slice exactly once and rows in no block keep their initial value. +# Rebuilding by rbind would require the blocks to cover every variant. +# @noRd +.h2ScatterBlockRows <- function(base, blocks) { + for (b in blocks) { + base[b$idx, ] <- b$values + } + base +} + +# One block's base LD scores. +# @noRd +.h2BlockBaseScores <- function(block) { + Vd <- sweep(block$vectors, 2, block$values, "*") + list(idx = block$snpIdx, values = rowSums(Vd^2)) +} + # Base LD scores l2[j] = sum_i (V[j,i] * d[i])^2 (since R = V D V'). .computeLdScoresBase <- function(eigenList, nSnps) { - l2 <- numeric(nSnps) - for (b in seq_along(eigenList)) { - block <- eigenList[[b]] - Vd <- sweep(block$vectors, 2, block$values, "*") - l2[block$snpIdx] <- rowSums(Vd^2) - } - matrix(l2, ncol = 1, dimnames = list(NULL, "base_l2")) + .h2ScatterBlockRows( + matrix(0, nrow = nSnps, ncol = 1, dimnames = list(NULL, "base_l2")), + map(eigenList, .h2BlockBaseScores) + ) } # Base + annotation-stratified LD scores. Stratified column a: # l2_a[j] = sum_i (V[j,i] d[i])^2 * (sum_k V[k,i]^2 annot[k,a]). .computeLdScoresStratified <- function(eigenList, annotations, nSnps) { annotMat <- assay(annotations, "annotations") - nAnnot <- ncol(annotMat) - l2Strat <- matrix(0, nrow = nSnps, ncol = 1 + nAnnot) - for (b in seq_along(eigenList)) { - block <- eigenList[[b]] - idx <- block$snpIdx - V <- block$vectors - Vd2 <- sweep(V, 2, block$values, "*")^2 - l2Strat[idx, 1] <- rowSums(Vd2) - for (a in seq_len(nAnnot)) { - annotWeights <- as.vector(crossprod(V^2, annotMat[idx, a])) - l2Strat[idx, 1 + a] <- as.vector(Vd2 %*% annotWeights) - } - } annotNames <- SummarizedExperiment::colData(annotations)$name - colnames(l2Strat) <- c("base_l2", annotNames) - l2Strat + .h2ScatterBlockRows( + matrix( + 0, + nrow = nSnps, + ncol = 1 + ncol(annotMat), + dimnames = list(NULL, c("base_l2", annotNames)) + ), + map(eigenList, .h2BlockStratScores, annotMat = annotMat) + ) +} + +# One block's base + annotation-stratified scores. All annotations are taken +# in a single matrix product rather than one column at a time. +# @noRd +.h2BlockStratScores <- function(block, annotMat) { + idx <- block$snpIdx + V <- block$vectors + Vd2 <- sweep(V, 2, block$values, "*")^2 + list( + idx = idx, + values = cbind( + rowSums(Vd2), + Vd2 %*% crossprod(V^2, annotMat[idx, , drop = FALSE]) + ) + ) } #' @rdname computeLdScores @@ -2191,29 +2264,18 @@ setMethod( abort(msg) } - nSnps <- length(ldRef) annotMat <- assay(annotations, "annotations") - nAnnot <- ncol(annotMat) - - # Base L2 + annotation-stratified columns - l2Strat <- matrix(0, nrow = nSnps, ncol = 1 + nAnnot) - l2Strat[, 1] <- getLdScores(ldRef)[, 1] - - for (b in seq_along(ldMatrixList)) { - block <- ldMatrixList[[b]] - R <- block$R - idx <- block$snpIdx - R2 <- R^2 - for (a in seq_len(nAnnot)) { - # l2_a[j] = sum_k R^2_{jk} * annot[k, a] - l2Strat[idx, 1 + a] <- as.vector(R2 %*% annotMat[idx, a]) - } - } - - annotNames <- SummarizedExperiment::colData(annotations)$name - colNames <- c("base_l2", annotNames) - colnames(l2Strat) <- colNames - l2Strat + # The stratified columns l2_a[j] = sum_k R^2_{jk} annot[k, a] are + # scattered per block; the base column comes from the reference and + # is joined on afterwards, so the scatter never touches it. + strat <- .h2ScatterBlockRows( + matrix(0, nrow = length(ldRef), ncol = ncol(annotMat)), + map(ldMatrixList, .h2BlockAnnotScores, baselineMat = annotMat) + ) + `colnames<-`( + cbind(getLdScores(ldRef)[, 1], strat), + c("base_l2", SummarizedExperiment::colData(annotations)$name) + ) } ) @@ -2224,6 +2286,7 @@ setMethod( # Converter: H2Estimate -> sldsc_wrapper list format # ============================================================================= +#' @importFrom checkmate assertClass #' @title Convert H2Estimate to S-LDSC Trait Format #' @description Convert an \code{H2Estimate} object into the list format #' expected by \code{\link{standardizeSldscTrait}} and @@ -2249,9 +2312,7 @@ setMethod( #' h2EstimateToSldscTrait(h2EstimateExample) #' @export h2EstimateToSldscTrait <- function(h2Est) { - if (!is(h2Est, "H2Estimate")) { - abort("h2Est must be an H2Estimate object") - } + assertClass(h2Est, "H2Estimate") enrichDf <- getEnrichment(h2Est) if (is.null(enrichDf)) { @@ -2265,18 +2326,13 @@ h2EstimateToSldscTrait <- function(h2Est) { cats <- as.character(enrichDf$annotation) nCats <- length(cats) - tauBlocks <- getTauBlocks(h2Est) - if (is.null(tauBlocks)) { - # Create a dummy single-block matrix from the point estimates - tauBlocks <- matrix(enrichDf$tau, nrow = 1) - colnames(tauBlocks) <- cats - nBlocks <- 1L - } else { - nBlocks <- nrow(tauBlocks) - if (is.null(colnames(tauBlocks))) { - colnames(tauBlocks) <- cats - } - } + rawTau <- getTauBlocks(h2Est) + # Without per-block estimates the point estimates stand in as one block. + tauBlocks <- `colnames<-`( + rawTau %||% matrix(enrichDf$tau, nrow = 1), + colnames(rawTau) %||% cats + ) + nBlocks <- nrow(tauBlocks) list( categories = cats, @@ -2325,8 +2381,7 @@ h2EstimateToSldscTrait <- function(h2Est) { # coordinate check in .h2CheckPositions() is the stronger guard regardless. # @noRd .h2GenomeOfRanges <- function(x) { - g <- unique(GenomeInfoDb::genome(x)) - g <- g[!is.na(g)] + g <- discard(unique(GenomeInfoDb::genome(x)), is.na) if (length(g) == 0L) { return(NA_character_) } diff --git a/R/jointEngine.R b/R/jointEngine.R index 909d3fae..6b17cd9b 100644 --- a/R/jointEngine.R +++ b/R/jointEngine.R @@ -56,14 +56,17 @@ NULL if (is.null(cv)) { return(NULL) } - out <- list(samplePartition = cv$samplePartition) - if (!is.null(cv$prediction)) { - out$prediction <- map(cv$prediction, .fmCvSliceCol, r = r) - } - if (!is.null(cv$performance)) { - out$performance <- map(cv$performance, .fmCvSliceRow, r = r) - } - out + c( + list(samplePartition = cv$samplePartition), + compact(list( + prediction = if (!is.null(cv$prediction)) { + map(cv$prediction, .fmCvSliceCol, r = r) + }, + performance = if (!is.null(cv$performance)) { + map(cv$performance, .fmCvSliceRow, r = r) + } + )) + ) } # Slice a twas joint cvResult (.jointTwasCvResult output: list(samplePartition, @@ -109,11 +112,12 @@ NULL # cis-window, so the fitted span IS the region). # Each returns a length-1 GRanges, or NULL when the anchor is unavailable (the # accumulator / builder then records a chrUn sentinel). +#' @importFrom rlang try_fetch .traitPosFor <- function(data, context, trait) { if (methods::is(data, "QtlDataset")) { - se <- tryCatch( + se <- try_fetch( getPhenotypes(data, contexts = context), - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(se)) { return(NULL) @@ -198,24 +202,19 @@ NULL cisWindow = NULL ) { kind <- arg_match(kind) - n <- length(traits) - chrs <- rep("chrUn", n) - starts <- rep(1L, n) - ends <- rep(1L, n) - anyFound <- FALSE - for (i in seq_len(n)) { - g <- if (kind == "traitPos") { - .traitPosFor(data, contexts[[i]], traits[[i]]) - } else { - .fitRegionFor(data, contexts[[i]], traits[[i]], cisWindow) - } - if (!is.null(g)) { - anyFound <- TRUE - chrs[i] <- as.character(GenomicRanges::seqnames(g))[[1L]] - starts[i] <- GenomicRanges::start(g)[[1L]] - ends[i] <- GenomicRanges::end(g)[[1L]] - } - } + anchors <- map( + seq_along(traits), + .jointAnchorAt, + data = data, + contexts = contexts, + traits = traits, + kind = kind, + cisWindow = cisWindow + ) + anyFound <- any(map_lgl(anchors, "found")) + chrs <- map_chr(anchors, "chr") + starts <- map_int(anchors, "start") + ends <- map_int(anchors, "end") # Nothing resolved (e.g. a QtlSumStats with no supplied traitPos): return # NULL # so the builder omits the column entirely and getTraitPosition() reports @@ -230,6 +229,27 @@ NULL ) } +# One trait's anchor, or the chrUn sentinel when it does not resolve. `found` +# records which it was, so the caller can tell "nothing resolved" from "every +# anchor really is chrUn:1-1". +# @noRd +.jointAnchorAt <- function(i, data, contexts, traits, kind, cisWindow) { + g <- if (kind == "traitPos") { + .traitPosFor(data, contexts[[i]], traits[[i]]) + } else { + .fitRegionFor(data, contexts[[i]], traits[[i]], cisWindow) + } + if (is.null(g)) { + return(list(found = FALSE, chr = "chrUn", start = 1L, end = 1L)) + } + list( + found = TRUE, + chr = as.character(GenomicRanges::seqnames(g))[[1L]], + start = GenomicRanges::start(g)[[1L]], + end = GenomicRanges::end(g)[[1L]] + ) +} + # ---- fitters (fitJointGroup) ------------------------------------------------ # (individual, fine-mapping) -> mvSuSiE joint fit + honest per-fold CV prior. @@ -273,15 +293,18 @@ setMethod( "fsusie", args$methodArgs[["fsusie"]] ) - fit <- exec(fitFsusie, !!!fitArgs) + raw <- exec(fitFsusie, !!!.splitMethodArgs(fitFsusie, fitArgs)) # Collapse the functional fit to a variants x features weight matrix now # (trimming later drops fitted_wc/csd_X); store on $coef so a trimmed fit # can still yield TWAS weights. - fit$coef <- tryCatch( - fsusieWeights(fsusieFit = fit, variantIds = colnames(Xc)), - error = function(e) NULL - ) - fit <- .setFinemappingFitClass(fit, "fsusie") + fit <- list_assign( + raw, + coef = try_fetch( + fsusieWeights(fsusieFit = raw, variantIds = colnames(Xc)), + error = function(cnd) NULL + ) + ) |> + .setFinemappingFitClass("fsusie") cvM <- .jointFsusieCv(Xc, Yc, group, cfg, args, verbose) map( seq_len(nCond), @@ -319,7 +342,7 @@ setMethod( # One fsusie per-condition (trait) FineMappingRow, with its CV slice attached. # @noRd .jointFsusieEntry <- function(r, fit, cvM, Xc, cfg) { - e <- .fmPostprocessOne( + bare <- .fmPostprocessOne( fit = fit, method = "fsusie", dataX = Xc, @@ -334,8 +357,10 @@ setMethod( fullFitAlphaOnly = cfg$fullFitAlphaOnly, includeAllCs = cfg$includeAllCs ) - if (!is.null(cvM)) { - e <- .fmAttachCv(e, .fmSliceCvCondition(cvM, r)) + e <- if (is.null(cvM)) { + bare + } else { + .fmAttachCv(bare, .fmSliceCvCondition(cvM, r)) } e } @@ -379,27 +404,24 @@ setMethod( # mask when active, or NULL to signal < 2 survivors (skip the whole joint). # @noRd .jointMvSerScreen <- function(Xc, Yc, nCond, args, verbose) { - keep <- rep(TRUE, nCond) if (!.fmScreenActive(args$pipCutoffToSkip)) { - return(keep) + return(rep(TRUE, nCond)) } keep <- as.logical(.fmSerScreenColumns(Xc, Yc, args$pipCutoffToSkip)) if (sum(keep) < 2L) { if (verbose >= 1) { - msg <- glue( + inform(glue( "Skipping mvsusie joint fit: < 2 of {nCond} conditions pass ", "the SER pre-screen." - ) - inform(msg) + )) } return(NULL) } if (sum(keep) < nCond && verbose >= 1) { - msg <- glue( + inform(glue( "mvsusie joint fit: SER pre-screen kept {sum(keep)} of ", "{nCond} conditions." - ) - inform(msg) + )) } keep } @@ -422,22 +444,22 @@ setMethod( context = key$context ) mvPrior <- .buildMvsusieReweightedPrior(mvFitParts, colnames(Ys), ddCut) - mvBaseArgs <- list( - X = Xc, - Y = Ys, - prior_variance = mvPrior$priorVariance, - coverage = cfg$coverage + mvBaseArgs <- c( + list( + X = Xc, + Y = Ys, + prior_variance = mvPrior$priorVariance, + coverage = cfg$coverage + ), + compact(list(residual_variance = mvPrior$residualVariance)) ) - if (!is.null(mvPrior$residualVariance)) { - mvBaseArgs$residual_variance <- mvPrior$residualVariance - } fitArgs <- .fmMergeUserArgs( mvBaseArgs, "mvsusie", args$methodArgs[["mvsusie"]] ) - fit <- exec(fitMvsusie, !!!fitArgs) - fit <- .setFinemappingFitClass(fit, "mvsusie") + fit <- exec(fitMvsusie, !!!.splitMethodArgs(fitMvsusie, fitArgs)) |> + .setFinemappingFitClass("mvsusie") cvM <- .jointMvCv( Xc, Ys, @@ -469,10 +491,7 @@ setMethod( if (cvFolds <= 1L) { return(NULL) } - sp <- cfg$samplePartition - if (is.null(sp) && !is.null(mvCv)) { - sp <- mvCv$samplePartition - } + sp <- cfg$samplePartition %||% mvCv$samplePartition mvPriorCv <- .fmBuildMvsusiePriorCv(mvCv, mvFitParts, colnames(Ys), ddCut) cv <- .fmWeightsCv( Xc, @@ -499,7 +518,7 @@ setMethod( return(NULL) } r <- match(i, survivors) - e <- .fmPostprocessOne( + bare <- .fmPostprocessOne( fit = fitted$fit, method = "mvsusie", dataX = Xc, @@ -514,8 +533,10 @@ setMethod( fullFitAlphaOnly = cfg$fullFitAlphaOnly, includeAllCs = cfg$includeAllCs ) - if (!is.null(fitted$cvM)) { - e <- .fmAttachCv(e, .fmSliceCvCondition(fitted$cvM, r)) + e <- if (is.null(fitted$cvM)) { + bare + } else { + .fmAttachCv(bare, .fmSliceCvCondition(fitted$cvM, r)) } e } @@ -583,16 +604,17 @@ setMethod( N = as.numeric(stats::median(.jgN(group))), prior_variance = mvPrior$priorVariance, coverage = cfg$coverage - ) - if (!is.null(mvPrior$residualVariance)) { - mvBaseArgs$residual_variance <- mvPrior$residualVariance - } + ) |> + c(compact(list(residual_variance = mvPrior$residualVariance))) fitArgs <- .fmMergeUserArgs( mvBaseArgs, "mvsusie", args$methodArgs[["mvsusie"]] ) - fit <- exec(fitMvsusieRss, !!!fitArgs) + fit <- exec( + fitMvsusieRss, + !!!.splitMethodArgs(fitMvsusieRss, fitArgs) + ) .setFinemappingFitClass(fit, "mvsusie") } @@ -691,7 +713,10 @@ setMethod( } else { NULL }, - foldFits = NULL + # The fine-mapping CV refits the method on each fold's training rows; + # those fits are what let a SuSiE-family method be cross-validated at + # all now that its weight wrappers never fit. + foldFits = fineMappingCv$foldFits ) } @@ -715,7 +740,7 @@ setMethod( nCond <- ncol(Yc) cond <- .jgConditions(group) methodKey <- .twasMethodKey(token) - stdz <- cfg$standardized + stdz <- cfg$standardized %||% FALSE fittedModels <- args$fittedModels %||% list() ma <- .jointTwasMethodArgs( args, @@ -768,7 +793,7 @@ setMethod( cfg, stdz ) { - ma <- if ( + supplied <- if ( !is.null(args$methodList) && is_in(methodKey, names(args$methodList)) ) { args$methodList[[methodKey]] @@ -777,23 +802,32 @@ setMethod( } else { NULL } - if (is.null(ma)) { - ma <- list() - } # FM-fit injection: an FM-derived token extracts its weights from the # precomputed fine-mapping fit rather than refitting. + withFit <- .jointTwasInjectFit( + supplied %||% list(), + token, + fittedModels + ) + if (!isTRUE(cfg$estimatePi) || !is_in(token, c("bayesC", "bayesB"))) { + return(withFit) + } + .jointTwasSpikeSlabPi(withFit, token, Xc, Yc, cond, cfg, stdz) +} + +# The method args with the precomputed fine-mapping fit injected, when the +# token has an adapter, a fit exists, and the caller did not pass one. +# @noRd +.jointTwasInjectFit <- function(ma, token, fittedModels) { adapter <- .twasFineMappingMethodAdapters[[token]] if ( - !is.null(adapter) && - !is.null(fittedModels[[token]]) && - is.null(ma[[adapter$fitArg]]) + is.null(adapter) || + is.null(fittedModels[[token]]) || + !is.null(ma[[adapter$fitArg]]) ) { - ma[[adapter$fitArg]] <- fittedModels[[token]] + return(ma) } - if (isTRUE(cfg$estimatePi) && is_in(token, c("bayesC", "bayesB"))) { - ma <- .jointTwasSpikeSlabPi(ma, token, Xc, Yc, cond, cfg, stdz) - } - ma + list_assign(ma, !!!set_names(list(fittedModels[[token]]), adapter$fitArg)) } # Spike-and-slab pi from an internal mr.ash fit (self-contained per method). @@ -813,13 +847,13 @@ setMethod( seed = cfg$seed ) piHat <- as.numeric(estimateSparsity(mrA)) - if (token == "bayesC" && is.null(ma$pi)) { - ma$pi <- piHat - } - if (token == "bayesB" && is.null(ma$probIn)) { - ma$probIn <- piHat - } - ma + list_assign( + ma, + !!!compact(list( + pi = if (token == "bayesC" && is.null(ma$pi)) piHat, + probIn = if (token == "bayesB" && is.null(ma$probIn)) piHat + )) + ) } # Full-data TWAS weight fit for a joint group. Returns list(W, fitParts, vids); @@ -862,9 +896,11 @@ setMethod( ) base <- .twrRowParts(tw, 1L) vids <- .twrPartsVariantIds(base) - W <- getWeights(base) - if (!is.matrix(W)) { - W <- matrix(W, ncol = nCond, dimnames = list(vids, NULL)) + raw <- getWeights(base) + W <- if (is.matrix(raw)) { + raw + } else { + matrix(raw, ncol = nCond, dimnames = list(vids, NULL)) } list(W = W, fitParts = getFits(base), vids = vids) } @@ -891,6 +927,29 @@ setMethod( # Cross-validated prediction result for a TWAS token: reuse fine-mapping's own # CV when available, else run twasWeightsCv (skipping all-zero-weight methods). +# Whether `token` should be cross-validated. `cvWeightMethods` is the caller's +# explicit override of the CV method set; NULL (the default) means "every +# method that produced non-zero weights", which is what the per-method +# all-zero check below enforces. +# @noRd +.jointTwasCvRequested <- function(cvWeightMethods, token) { + if (is.null(cvWeightMethods)) { + return(TRUE) + } + requested <- if (is.list(cvWeightMethods)) { + names(cvWeightMethods) + } else { + as.character(cvWeightMethods) + } + # Accept the short token, the `_weights` method key, or the + # camelCase weight function. Suffix-stripping alone is not enough for a + # multi-word token: `susie_inf_weights` strips to `susie_inf`, which is + # not the canonical `susieInf`. + canonical <- map_chr(requested, .twasFmTokenFor) + bare <- str_remove(requested, "(_weights|Weights)$") + is_in(token, c(canonical[!is.na(canonical)], bare)) +} + # @noRd .jointTwasCv <- function(Xc, Yc, wm, ma, W, args, cfg, token) { cvFolds <- if (is.null(cfg$cvFolds)) 0L else cfg$cvFolds @@ -898,9 +957,36 @@ setMethod( return(NULL) } cvRes <- .twasFmHandoffCv(args$fineMappingCv, token) - if (!is.null(cvRes) || (!is.null(W) && all(W == 0))) { + if (!is.null(cvRes)) { return(cvRes) } + if (!.jointTwasCvRequested(cfg$cvWeightMethods, token)) { + return(NULL) + } + if (!is.null(W) && all(W == 0)) { + # Restored with the notice it used to carry: a method whose weights + # are all zero contributes nothing to cross-validation, and dropping + # it silently made an empty ensemble look like a modelling result. + msg <- glue( + "twasWeightsPipeline: method '{token}' is excluded from ", + "cross-validation because all of its weights are zero." + ) + warn(msg) + return(NULL) + } + if (is_in(token, names(.twasFineMappingMethodAdapters))) { + # No handoff above means this tuple's fine-mapping entry carries no + # CV, and nothing here fine-maps -- so the fold fits cannot be + # recovered. Refusing beats refitting behind the user's back. + msg <- glue( + "twasWeightsPipeline: cross-validating method '{token}' needs ", + "each fold's own fine-mapping fit, and the supplied ", + "fineMappingResult has no cross-validation for this ", + "(study, context, trait). Run fineMappingPipeline() with ", + "cvFolds > 1." + ) + abort(msg) + } .jointTwasLeakageWarn(args, ma) verbose <- if (is.null(cfg$verbose)) 1 else cfg$verbose sp <- if (!is.null(args$samplePartition)) { @@ -922,7 +1008,7 @@ setMethod( retainFits = TRUE, maxNumVariants = mcv, numThreads = if (is.null(cfg$cvThreads)) 1 else cfg$cvThreads, - data_driven_priorMatricesCv = args$dataDrivenPriorMatricesCv, + dataDrivenPriorMatricesCv = args$dataDrivenPriorMatricesCv, verbose = verbose, seed = cfg$seed ) @@ -971,13 +1057,14 @@ setMethod( retainFit = TRUE, fitDetail = rfd ) - vids <- rownames(weights) - if (is.null(vids)) { - vids <- rownames(.jgZ(group)) - } + vids <- rownames(weights) %||% rownames(.jgZ(group)) fitParts <- attr(weights, "fit") - if (!is.matrix(weights)) { - weights <- matrix( + # A single-condition fit comes back as a bare vector; the per-condition + # split below reads it by column either way. + wMatrix <- if (is.matrix(weights)) { + weights + } else { + matrix( weights, ncol = ncol(.jgZ(group)), dimnames = list(vids, NULL) @@ -986,10 +1073,10 @@ setMethod( # One per-condition entry: that condition's weight column + the shared # fit. map( - seq_len(ncol(weights)), + seq_len(ncol(wMatrix)), .jointColEntry, vids = vids, - weights = weights, + weights = wMatrix, fitParts = fitParts, cfg = cfg ) @@ -1043,32 +1130,49 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { return(list()) } verbose <- if (is.null(args$verbose)) 1 else args$verbose - groups <- list() - for (tid in scopedTraits) { - xy <- .buildIndividualCrossContextXy( - data, - tid, - scopedContexts, - args$cisWindow, - verbose, - label = "jointCrossContext", - region = args$region - ) - if (is.null(xy)) { - next - } - groups[[length(groups) + 1L]] <- new( - "IndividualJointGroup", - conditions = tibble( - study = study, - context = xy$perTraitContexts, - trait = tid - ), - X = xy$X, - Y = xy$Y - ) + compact(map( + scopedTraits, + .enumCrossContextGroupFor, + data = data, + study = study, + scopedContexts = scopedContexts, + args = args, + verbose = verbose + )) +} + +# One trait's cross-context group, or NULL when it has no usable (X, Y). +# @noRd +.enumCrossContextGroupFor <- function( + tid, + data, + study, + scopedContexts, + args, + verbose +) { + xy <- .buildIndividualCrossContextXy( + data, + tid, + scopedContexts, + args$cisWindow, + verbose, + label = "jointCrossContext", + region = args$region + ) + if (is.null(xy)) { + return(NULL) } - groups + new( + "IndividualJointGroup", + conditions = tibble( + study = study, + context = xy$perTraitContexts, + trait = tid + ), + X = xy$X, + Y = xy$Y + ) } # cross-context / sumstats. @@ -1077,45 +1181,94 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { studyCol <- as.character(data$study) contextCol <- as.character(data$context) traitCol <- as.character(data$trait) - groups <- list() - for (s in scope$studies) { - scopedContexts <- scope$contexts[[s]] - scopedTraits <- scope$traits[[s]] - if (length(scopedContexts) < 2L) { - next - } - for (tid in scopedTraits) { - tupleRows <- which( - studyCol == s & - traitCol == tid & - is_in(contextCol, scopedContexts) - ) - if (length(tupleRows) < 2L) { - next - } - ctxNames <- contextCol[tupleRows] - jz <- .buildJointSumstatZMatrix( - data, - tupleRows, - ctxNames, - errorLabel = "jointCrossContext (QtlSumStats)", - ldSketch = ldSketch, - cutoffs = args$cutoffs - ) - groups[[length(groups) + 1L]] <- new( - "SumStatsJointGroup", - conditions = tibble( - study = s, - context = ctxNames, - trait = tid - ), - Z = jz$Z, - ldSketch = ldSketch, - N = jz$nVec - ) - } + .jeConcat(map( + scope$studies, + .enumCrossContextSumstatsForStudy, + data = data, + scope = scope, + args = args, + ldSketch = ldSketch, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol + )) +} + +# Concatenate per-item lists, empty-safe. +# @noRd +.jeConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) + } + list_c(pieces) +} + +# One study's cross-context groups (none when it has fewer than two contexts). +# @noRd +.enumCrossContextSumstatsForStudy <- function( + s, + data, + scope, + args, + ldSketch, + studyCol, + contextCol, + traitCol +) { + scopedContexts <- scope$contexts[[s]] + if (length(scopedContexts) < 2L) { + return(list()) + } + compact(map( + scope$traits[[s]], + .enumCrossContextSumstatsGroup, + data = data, + s = s, + scopedContexts = scopedContexts, + args = args, + ldSketch = ldSketch, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol + )) +} + +# One (study, trait) cross-context group, or NULL when fewer than two of its +# contexts carry the trait. +# @noRd +.enumCrossContextSumstatsGroup <- function( + tid, + data, + s, + scopedContexts, + args, + ldSketch, + studyCol, + contextCol, + traitCol +) { + tupleRows <- which( + studyCol == s & traitCol == tid & is_in(contextCol, scopedContexts) + ) + if (length(tupleRows) < 2L) { + return(NULL) } - groups + ctxNames <- contextCol[tupleRows] + jz <- .buildJointSumstatZMatrix( + data, + tupleRows, + ctxNames, + errorLabel = "jointCrossContext (QtlSumStats)", + ldSketch = ldSketch, + cutoffs = args$cutoffs + ) + new( + "SumStatsJointGroup", + conditions = tibble(study = s, context = ctxNames, trait = tid), + Z = jz$Z, + ldSketch = ldSketch, + N = jz$nVec + ) } # cross-trait / individual: one group per scoped context with >= 2 scoped @@ -1128,39 +1281,58 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { scopedContexts <- scope$contexts[[study]] scopedTraits <- scope$traits[[study]] verbose <- if (is.null(args$verbose)) 1 else args$verbose - groups <- list() - for (cx in scopedContexts) { - xy <- .buildIndividualCrossTraitXy( - data, - cx, - scopedTraits, - args$cisWindow, - verbose, - label = "jointCrossTrait", + compact(map( + scopedContexts, + .enumCrossTraitGroupFor, + data = data, + study = study, + scopedTraits = scopedTraits, + args = args, + verbose = verbose + )) +} + +# One context's cross-trait group, or NULL when it has no usable (X, Y). +# @noRd +.enumCrossTraitGroupFor <- function( + cx, + data, + study, + scopedTraits, + args, + verbose +) { + xy <- .buildIndividualCrossTraitXy( + data, + cx, + scopedTraits, + args$cisWindow, + verbose, + label = "jointCrossTrait", + study = study, + region = args$region + ) + if (is.null(xy)) { + return(NULL) + } + # Functional positions (one per trait column) for fsusie's domain; mvsusie + # ignores them. Reordered to match the trait order of Y. + rr <- SummarizedExperiment::rowRanges(xy$se)[ + match(colnames(xy$Y), rownames(xy$se)) + ] + new( + "IndividualJointGroup", + conditions = tibble( study = study, - region = args$region - ) - if (is.null(xy)) { - next - } - # Functional positions (one per trait column) for fsusie's domain; - # mvsusie ignores them. Matches the trait order of Y. - rr <- SummarizedExperiment::rowRanges(xy$se) - rr <- rr[match(colnames(xy$Y), rownames(xy$se))] - traitPos <- (GenomicRanges::start(rr) + GenomicRanges::end(rr)) / 2 - groups[[length(groups) + 1L]] <- new( - "IndividualJointGroup", - conditions = tibble( - study = study, - context = cx, - trait = xy$traitsHere - ), - X = xy$X, - Y = xy$Y, - traitPos = as.numeric(traitPos) + context = cx, + trait = xy$traitsHere + ), + X = xy$X, + Y = xy$Y, + traitPos = as.numeric( + (GenomicRanges::start(rr) + GenomicRanges::end(rr)) / 2 ) - } - groups + ) } # cross-trait / sumstats. @@ -1169,40 +1341,80 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { studyCol <- as.character(data$study) contextCol <- as.character(data$context) traitCol <- as.character(data$trait) - groups <- list() - for (s in scope$studies) { - scopedContexts <- scope$contexts[[s]] - scopedTraits <- scope$traits[[s]] - for (cx in scopedContexts) { - tupleRows <- which( - studyCol == s & contextCol == cx & is_in(traitCol, scopedTraits) - ) - if (length(tupleRows) < 2L) { - next - } - trNames <- traitCol[tupleRows] - jz <- .buildJointSumstatZMatrix( - data, - tupleRows, - trNames, - errorLabel = "jointCrossTrait (QtlSumStats)", - ldSketch = ldSketch, - cutoffs = args$cutoffs - ) - groups[[length(groups) + 1L]] <- new( - "SumStatsJointGroup", - conditions = tibble( - study = s, - context = cx, - trait = trNames - ), - Z = jz$Z, - ldSketch = ldSketch, - N = jz$nVec - ) - } + .jeConcat(map( + scope$studies, + .enumCrossTraitSumstatsForStudy, + data = data, + scope = scope, + args = args, + ldSketch = ldSketch, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol + )) +} + +# @noRd +.enumCrossTraitSumstatsForStudy <- function( + s, + data, + scope, + args, + ldSketch, + studyCol, + contextCol, + traitCol +) { + compact(map( + scope$contexts[[s]], + .enumCrossTraitSumstatsGroup, + data = data, + s = s, + scopedTraits = scope$traits[[s]], + args = args, + ldSketch = ldSketch, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol + )) +} + +# One (study, context) cross-trait group, or NULL when fewer than two of its +# traits are present. +# @noRd +.enumCrossTraitSumstatsGroup <- function( + cx, + data, + s, + scopedTraits, + args, + ldSketch, + studyCol, + contextCol, + traitCol +) { + tupleRows <- which( + studyCol == s & contextCol == cx & is_in(traitCol, scopedTraits) + ) + if (length(tupleRows) < 2L) { + return(NULL) } - groups + trNames <- traitCol[tupleRows] + jz <- .buildJointSumstatZMatrix( + data, + tupleRows, + trNames, + errorLabel = "jointCrossTrait (QtlSumStats)", + ldSketch = ldSketch, + cutoffs = args$cutoffs + ) + new( + "SumStatsJointGroup", + conditions = tibble(study = s, context = cx, trait = trNames), + Z = jz$Z, + ldSketch = ldSketch, + N = jz$nVec + ) } # cross-study / sumstats (no individual form: individual-level studies have @@ -1215,26 +1427,55 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { context = as.character(data$context), trait = as.character(data$trait) ) - allCtxs <- unique(unlist(scope$contexts, use.names = FALSE)) - allTrs <- unique(unlist(scope$traits, use.names = FALSE)) - groups <- list() - for (cx in allCtxs) { - for (tid in allTrs) { - g <- .enumCrossStudyGroup( - data, - scope, - args, - cols, - cx, - tid, - ldSketch - ) - if (!is.null(g)) { - groups[[length(groups) + 1L]] <- g - } - } - } - groups + allCtxs <- unique(unname(list_c(scope$contexts))) + allTrs <- unique(unname(list_c(scope$traits))) + .jeConcat(map( + allCtxs, + .enumCrossStudyForContext, + data = data, + scope = scope, + args = args, + cols = cols, + allTrs = allTrs, + ldSketch = ldSketch + )) +} + +# One context's cross-study groups, one per trait that has enough studies. +# @noRd +.enumCrossStudyForContext <- function( + cx, + data, + scope, + args, + cols, + allTrs, + ldSketch +) { + compact(map( + allTrs, + .enumCrossStudyGroupFor, + data = data, + scope = scope, + args = args, + cols = cols, + cx = cx, + ldSketch = ldSketch + )) +} + +# `map()` hands the trait first; .enumCrossStudyGroup takes it sixth. +# @noRd +.enumCrossStudyGroupFor <- function( + tid, + data, + scope, + args, + cols, + cx, + ldSketch +) { + .enumCrossStudyGroup(data, scope, args, cols, cx, tid, ldSketch) } # One cross-study joint group for a (context, trait) cell, or NULL when fewer @@ -1242,20 +1483,20 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # just that study, so the cell contributes nothing. # @noRd .enumCrossStudyGroup <- function(data, scope, args, cols, cx, tid, ldSketch) { - tupleRows <- which( + candidates <- which( cols$context == cx & cols$trait == tid & is_in(cols$study, scope$studies) ) keep <- map_lgl( - tupleRows, + candidates, .jointTupleRowInScope, studyCol = cols$study, cx = cx, tid = tid, scope = scope ) - tupleRows <- tupleRows[keep] + tupleRows <- candidates[keep] if (length(tupleRows) < 2L) { return(NULL) } @@ -1325,85 +1566,113 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { return(list()) } naAction <- if (is.null(args$naAction)) "drop" else args$naAction - groups <- list() - for (cx in scope$contexts[[study]]) { - se <- getPhenotypes(data, contexts = cx) - for (tid in intersect(scope$traits[[study]], rownames(se))) { - Y <- .fmResidPheno( - data, - contexts = cx, - traitId = tid, - naAction = naAction - ) - X <- if (is.null(args$region)) { - .fmResidGeno( - data, - contexts = cx, - traitId = tid, - cisWindow = args$cisWindow - ) - } else { - .fmResidGeno(data, contexts = cx, region = args$region) - } - common <- intersect(rownames(X), rownames(Y)) - if (length(common) < 2L) { - next - } - groups[[length(groups) + 1L]] <- new( - "IndividualJointGroup", - conditions = tibble( - study = study, - context = cx, - trait = tid - ), - X = X[common, , drop = FALSE], - Y = Y[common, , drop = FALSE] - ) - } + .jeConcat(map( + scope$contexts[[study]], + .enumUnivariateForContext, + data = data, + scope = scope, + args = args, + study = study, + naAction = naAction + )) +} + +# One context's univariate groups, one per trait it carries. +# @noRd +.enumUnivariateForContext <- function(cx, data, scope, args, study, naAction) { + se <- getPhenotypes(data, contexts = cx) + compact(map( + intersect(scope$traits[[study]], rownames(se)), + .enumUnivariateGroupFor, + data = data, + args = args, + study = study, + cx = cx, + naAction = naAction + )) +} + +# One (context, trait) univariate group, or NULL when fewer than two samples +# are shared between its genotypes and its phenotype. +# @noRd +.enumUnivariateGroupFor <- function(tid, data, args, study, cx, naAction) { + Y <- .fmResidPheno( + data, + contexts = cx, + traitId = tid, + naAction = naAction + ) + X <- if (is.null(args$region)) { + .fmResidGeno( + data, + contexts = cx, + traitId = tid, + cisWindow = args$cisWindow + ) + } else { + .fmResidGeno(data, contexts = cx, region = args$region) + } + common <- intersect(rownames(X), rownames(Y)) + if (length(common) < 2L) { + return(NULL) } - groups + new( + "IndividualJointGroup", + conditions = tibble(study = study, context = cx, trait = tid), + X = X[common, , drop = FALSE], + Y = Y[common, , drop = FALSE] + ) } # composed / sumstats: general N-axis joint. `args$axes` (subset of study / # context / trait) names the collapsed axes; rows split by the complement # (fixed) axes form one group each. Reuses .enumerateComposedSumstatGroups. .enumComposedSumstats <- function(data, scope, args = list()) { - axes <- args$axes - if (is.null(axes)) { - axes <- c("context", "trait") - } + axes <- args$axes %||% c("context", "trait") ldSketch <- getLdSketch(data) gi <- .enumerateComposedSumstatGroups(list(axes = axes), data, scope) if (is.null(gi)) { return(list()) } - groups <- list() - for (gIdx in gi$groups) { - if (length(gIdx) < 2L) { - next - } - colLabels <- map_chr(gIdx, .jointGroupColLabel, gi = gi) - jz <- .buildJointSumstatZMatrix( - data, - gIdx, - colLabels, - errorLabel = "composed (QtlSumStats)", - ldSketch = ldSketch, - cutoffs = args$cutoffs - ) - groups[[length(groups) + 1L]] <- new( - "SumStatsJointGroup", - conditions = tibble( - study = gi$studyCol[gIdx], - context = gi$contextCol[gIdx], - trait = gi$traitCol[gIdx] - ), - Z = jz$Z, - ldSketch = ldSketch, - N = jz$nVec - ) + # `gi$groups` comes from split(), so it is NAMED; map() would carry those + # names onto the groups, which the record assembly downstream does not + # expect (the loop this replaced appended positionally). + unname(compact(map( + gi$groups, + .enumComposedGroupFor, + data = data, + gi = gi, + args = args, + ldSketch = ldSketch + ))) +} + +# One composed cell's group, or NULL when it spans fewer than two tuples -- +# a "joint" fit over one tuple is just that tuple. +# @noRd +.enumComposedGroupFor <- function(gIdx, data, gi, args, ldSketch) { + if (length(gIdx) < 2L) { + return(NULL) } - groups + jz <- .buildJointSumstatZMatrix( + data, + gIdx, + map_chr(gIdx, .jointGroupColLabel, gi = gi), + errorLabel = "composed (QtlSumStats)", + ldSketch = ldSketch, + cutoffs = args$cutoffs + ) + new( + "SumStatsJointGroup", + conditions = tibble( + study = gi$studyCol[gIdx], + context = gi$contextCol[gIdx], + trait = gi$traitCol[gIdx] + ), + Z = jz$Z, + ldSketch = ldSketch, + N = jz$nVec + ) } # ---- engine ----------------------------------------------------------------- @@ -1418,41 +1687,106 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { } cfg <- .jpConfig(pipeline) cond <- .jgConditions(g) - out <- args + out <- list_assign(args, !!!.twasGroupFmArgs(args, cond)) + cvF <- if (is.null(cfg$cvFolds)) 0L else cfg$cvFolds + if (cvF <= 1L || !is(g, "IndividualJointGroup")) { + return(out) + } + list_assign( + out, + samplePartition = .jointCvPartition( + fmCv = out$fineMappingCv, + userSp = args$samplePartition %||% cfg$samplePartition, + sampleIds = rownames(.jgX(g)), + cvFolds = cvF + ) + ) +} + +# The group's fine-mapping fits + CV, keyed on its first condition. Empty when +# the caller supplied no fine-mapping result. +# @noRd +.twasGroupFmArgs <- function(args, cond) { fmRes <- args$fineMappingResult - if (!is.null(fmRes)) { - s1 <- as.character(cond$study[[1L]]) - c1 <- as.character(cond$context[[1L]]) - t1 <- as.character(cond$trait[[1L]]) - nR <- if (is.null(args$nRegions)) 1L else args$nRegions - bi <- if (is.null(args$regionIndex)) 1L else args$regionIndex - af <- .twasFineMappingFits(fmRes, study = s1, context = c1, trait = t1) - out$fittedModels <- if (is.null(af)) { + if (is.null(fmRes)) { + return(list()) + } + s1 <- as.character(cond$study[[1L]]) + c1 <- as.character(cond$context[[1L]]) + t1 <- as.character(cond$trait[[1L]]) + nR <- if (is.null(args$nRegions)) 1L else args$nRegions + bi <- if (is.null(args$regionIndex)) 1L else args$regionIndex + af <- .twasFineMappingFits(fmRes, study = s1, context = c1, trait = t1) + list( + fittedModels = if (is.null(af)) { list() } else { .twasFitsForRegion(af, bi, nR) + }, + fineMappingCv = .twasCvResultFor(fmRes, s1, c1, t1) + ) +} + +# The fold partition every method in this group is scored on. A fine-mapping +# CV carries fits tied to its own folds, so when one is present it governs: +# the other weight methods are cross-validated on those same folds, which is +# what makes their scores comparable to the fine-mapping method's. +# @noRd +.jointCvPartition <- function(fmCv, userSp, sampleIds, cvFolds) { + fmSp <- fmCv$samplePartition + if (is.null(fmSp)) { + if (!is.null(userSp)) { + return(userSp) } - out$fineMappingCv <- .twasCvResultFor(fmRes, s1, c1, t1) + return(.normalizeCvFolds(cvFolds, NULL, sampleIds)$samplePartition) } - cvF <- if (is.null(cfg$cvFolds)) 0L else cfg$cvFolds - if (cvF > 1L && is(g, "IndividualJointGroup")) { - sp <- args$samplePartition - if (is.null(sp)) { - sp <- cfg$samplePartition - } - if (is.null(sp) && !is.null(out$fineMappingCv)) { - sp <- out$fineMappingCv$samplePartition - } - if (is.null(sp)) { - sp <- .normalizeCvFolds( - cvF, - NULL, - rownames(.jgX(g)) - )$samplePartition - } - out$samplePartition <- sp + .jointCheckFmCvSamples(fmSp, sampleIds) + .jointCheckPartitionAgreement(fmSp, userSp) + fmSp +} + +# Every sample the fine-mapping folds name must be a sample of the dataset +# being scored. Otherwise a fold's held-out rows cannot be located here, and +# the fits would be scored against samples they were never separated from. +# @noRd +.jointCheckFmCvSamples <- function(fmSp, sampleIds) { + unmatched <- setdiff(as.character(fmSp$Sample), as.character(sampleIds)) + if (length(unmatched) == 0L) { + return(invisible(NULL)) + } + shown <- str_flatten(head(unmatched, 5L), ", ") + more <- if (length(unmatched) > 5L) { + str_c(" (and ", length(unmatched) - 5L, " more)") + } else { + "" + } + msg <- glue( + "twasWeightsPipeline: {length(unmatched)} sample(s) in the ", + "fine-mapping cross-validation folds are not in this dataset: ", + "{shown}{more}. The fold fits must come from a fineMappingPipeline() ", + "run on these same samples." + ) + abort(msg) +} + +# An explicitly supplied partition that disagrees with the fine-mapping CV's +# is ambiguous -- the fold fits belong to one of them, and silently choosing +# would score some methods on folds the others never saw. +# @noRd +.jointCheckPartitionAgreement <- function(fmSp, userSp) { + if (is.null(userSp)) { + return(invisible(NULL)) + } + if (identical(.cvPartitionKey(userSp), .cvPartitionKey(fmSp))) { + return(invisible(NULL)) } - out + msg <- glue( + "twasWeightsPipeline: the supplied `samplePartition` differs from ", + "the fine-mapping cross-validation's own folds. The fine-mapping ", + "fold fits belong to that partition, so pass it (or omit ", + "`samplePartition` and let it be reused)." + ) + abort(msg) } # Append one output record per (condition, method) to the joint-rows accumulator @@ -1483,8 +1817,8 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # -- one method -> per-condition entries; the SR-TWAS ensemble is a layer ON TOP # of that. .runJointCell <- function(cell, pipeline, data, scope, tokens, args = list()) { - groups <- .jcEnumerate(cell)(data, scope, args) - groups <- keep(groups, .jointGroupMeetsMin, minGroup = .jcMinGroup(cell)) + groups <- .jcEnumerate(cell)(data, scope, args) |> + keep(.jointGroupMeetsMin, minGroup = .jcMinGroup(cell)) if (length(groups) == 0L) { return(NULL) } @@ -1517,49 +1851,69 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { jt = .jointAxisMembers(cond, "trait") ) fitArgs <- .twasGroupArgs(g, pipeline, args) - records <- list() - perTokenEntries <- list() - for (token in tokens) { - entries <- .jointGroupTokenEntries( - g, - pipeline, - token, - fitArgs, - cond, - args - ) - if (is.null(entries) || length(entries) == 0L) { - next - } - perTokenEntries[[token]] <- entries - records <- c( - records, - .jointEntryRecords(entries, token, grp, data, args$cisWindow) - ) - } - if (doEnsemble && length(perTokenEntries) >= 2L) { - records <- c( - records, - .jointEntryRecords( - .twasEnsembleLayer(g, perTokenEntries, .jpConfig(pipeline)), - "ensemble", - grp, - data, - args$cisWindow - ) + perTokenEntries <- compact(set_names( + map( + tokens, + .jointTokenEntriesOrNull, + g = g, + pipeline = pipeline, + fitArgs = fitArgs, + cond = cond, + args = args + ), + tokens + )) + tokenRecords <- .jeConcat(map( + names(perTokenEntries), + .jointTokenRecords, + perTokenEntries = perTokenEntries, + grp = grp, + data = data, + cisWindow = args$cisWindow + )) + if (!doEnsemble || length(perTokenEntries) < 2L) { + return(tokenRecords) + } + c( + tokenRecords, + .jointEntryRecords( + .twasEnsembleLayer(g, perTokenEntries, .jpConfig(pipeline)), + "ensemble", + grp, + data, + args$cisWindow ) + ) +} + +# One token's entries, or NULL when it produced none. +# @noRd +.jointTokenEntriesOrNull <- function(token, g, pipeline, fitArgs, cond, args) { + entries <- .jointGroupTokenEntries( + g, + pipeline, + token, + fitArgs, + cond, + args + ) + if (is.null(entries) || length(entries) == 0L) { + return(NULL) } - records + entries +} + +# @noRd +.jointTokenRecords <- function(token, perTokenEntries, grp, data, cisWindow) { + .jointEntryRecords(perTokenEntries[[token]], token, grp, data, cisWindow) } # Entries for one token on one group: reuse the resume cache when it fully # covers the group's conditions, else fit. # @noRd .jointGroupTokenEntries <- function(g, pipeline, token, fitArgs, cond, args) { - entries <- .jointTokenCacheLookup(pipeline, token, cond, args$cache) - if (is.null(entries)) { - entries <- fitJointGroup(g, pipeline, token, fitArgs) - } + entries <- .jointTokenCacheLookup(pipeline, token, cond, args$cache) %||% + fitJointGroup(g, pipeline, token, fitArgs) entries } @@ -1610,7 +1964,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { cfg$ensembleSolver } alpha <- if (is.null(cfg$ensembleAlpha)) 1 else cfg$ensembleAlpha - stdz <- cfg$standardized + stdz <- cfg$standardized %||% FALSE map( seq_len(nrow(.jgConditions(group))), .twasEnsembleCondition, @@ -1628,39 +1982,62 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # Per-condition CV predictions + weights + R^2 across the group's methods. # Returns list(preds, wts, rsq), skipping methods with no CV / weights. # @noRd -.twasEnsembleCollect <- function(r, perTokenEntries, tokens) { - preds <- list() - wts <- list() - rsq <- c() - for (tk in tokens) { - e <- perTokenEntries[[tk]][[r]] - if (is.null(e)) { - next - } - cv <- .rowCvResult(e) - w <- .rowWeights(e) - if (is.null(cv) || is.null(cv$predictions) || is.null(w)) { - next - } - pr <- cv$predictions - preds[[str_c(tk, "_predicted")]] <- matrix( +# One token's ensemble inputs for condition `r`, or NULL when it has no +# cross-validated predictions or no weights to contribute. +# @noRd +.twasEnsembleTokenPart <- function(tk, r, perTokenEntries) { + e <- perTokenEntries[[tk]][[r]] + if (is.null(e)) { + return(NULL) + } + cv <- .rowCvResult(e) + w <- .rowWeights(e) + if (is.null(cv) || is.null(cv$predictions) || is.null(w)) { + return(NULL) + } + pr <- cv$predictions + list( + token = tk, + pred = matrix( as.numeric(pr), ncol = 1L, dimnames = list(names(pr), NULL) - ) - wts[[str_c(tk, "_weights")]] <- matrix( + ), + weights = matrix( as.numeric(w), ncol = 1L, dimnames = list(.rowVariantIds(e), NULL) - ) - mt <- cv$metrics - rsq[tk] <- if (!is.null(mt) && is_in("rsq", names(mt))) { - mt[["rsq"]] + ), + rsq = if (!is.null(cv$metrics) && is_in("rsq", names(cv$metrics))) { + cv$metrics[["rsq"]] } else { NA_real_ } + ) +} + +.twasEnsembleCollect <- function(r, perTokenEntries, tokens) { + parts <- compact(map( + tokens, + .twasEnsembleTokenPart, + r = r, + perTokenEntries = perTokenEntries + )) + if (length(parts) == 0L) { + return(list(preds = list(), wts = list(), rsq = c())) } - list(preds = preds, wts = wts, rsq = rsq) + contributing <- map_chr(parts, "token") + list( + preds = set_names( + map(parts, "pred"), + str_c(contributing, "_predicted") + ), + wts = set_names( + map(parts, "weights"), + str_c(contributing, "_weights") + ), + rsq = set_names(map_dbl(parts, "rsq"), contributing) + ) } # SR-TWAS ensemble entry for one condition: combine the R^2-passing methods @@ -1682,7 +2059,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { if (length(passing) < 2L) { return(NULL) } - ens <- tryCatch( + ens <- try_fetch( ensembleWeights( cvResults = list( prediction = coll$preds[str_c(passing, "_predicted")] @@ -1693,16 +2070,14 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { solver = solver, alpha = alpha ), - error = function(err) NULL + error = function(cnd) NULL ) if (is.null(ens) || is.null(ens$ensembleTwasWeights)) { return(NULL) } ew <- ens$ensembleTwasWeights - vids <- if (!is.null(names(ew))) names(ew) else rownames(ew) - if (is.null(vids)) { - vids <- getVariantIds(perTokenEntries[[passing[1L]]][[r]]) - } + vids <- (if (!is.null(names(ew))) names(ew) else rownames(ew)) %||% + getVariantIds(perTokenEntries[[passing[1L]]][[r]]) twasWeightsRow( variantIds = vids, weights = as.numeric(ew), @@ -1813,30 +2188,56 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { } ldSketch <- .jpConfig(pipeline)$ldSketch isFm <- is(pipeline, "FmJointPipeline") - out <- NULL - for (spec in parsedJointSpec) { - res <- .runOneJointSpec( - spec, - data, - dataForm, - pipeline, - jointMethods, - contexts, - traitIds, - args - ) - if (is.null(res)) { - next - } - out <- if (is.null(out)) { - res - } else if (isFm) { - .rbindFineMappingResult(out, res, ldSketch = ldSketch) - } else { - .rbindTwasWeights(out, res, ldSketch = ldSketch) - } + results <- compact(map( + parsedJointSpec, + .runOneJointSpecFor, + data = data, + dataForm = dataForm, + pipeline = pipeline, + jointMethods = jointMethods, + contexts = contexts, + traitIds = traitIds, + args = args + )) + if (length(results) == 0L) { + return(NULL) } - out + rbindFn <- if (isFm) .rbindFineMappingResult else .rbindTwasWeights + reduce( + results, + .jointRbindWithSketch, + rbindFn = rbindFn, + ldSketch = ldSketch + ) +} + +# `map()` hands the spec first, which is also where .runOneJointSpec wants it. +# @noRd +.runOneJointSpecFor <- function( + spec, + data, + dataForm, + pipeline, + jointMethods, + contexts, + traitIds, + args +) { + .runOneJointSpec( + spec, + data, + dataForm, + pipeline, + jointMethods, + contexts, + traitIds, + args + ) +} + +# @noRd +.jointRbindWithSketch <- function(acc, res, rbindFn, ldSketch) { + rbindFn(acc, res, ldSketch = ldSketch) } # Run all joint methods for ONE spec: resolve its scope (optionally @@ -1854,18 +2255,19 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { traitIds, args ) { - scope <- .fmResolveSpecScope( + resolved <- .fmResolveSpecScope( spec, data, contexts = contexts, traitIds = traitIds ) - if ( - dataForm == "individual" && - is.null(traitIds) && - !is.null(args$region) - ) { - scope <- .jointRestrictRegionTraits(scope, data, args$region) + restrictToRegion <- dataForm == "individual" && + is.null(traitIds) && + !is.null(args$region) + scope <- if (restrictToRegion) { + .jointRestrictRegionTraits(resolved, data, args$region) + } else { + resolved } pattern <- if (length(spec$axes) > 1L) "composed" else spec$axes[[1L]] cell <- .lookupJointCell(pattern, dataForm) @@ -1877,20 +2279,37 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # to the genes overlapping the locus (matches fineMappingPipeline). Gene coords # are context-independent, so the first scoped context's SE supplies them. # @noRd +# One study's traits narrowed to those inside `region`; left alone when the +# study has no context to read a phenotype from. +# @noRd +.jointStudyTraitsInRegion <- function(st, scope, data, region) { + ctxs <- scope$contexts[[st]] + if (length(ctxs) == 0L) { + return(scope$traits[[st]]) + } + se <- getPhenotypes(data, contexts = ctxs[[1L]]) + .fmTraitsInRegion( + se, + intersect(scope$traits[[st]], rownames(se)), + region + ) +} + .jointRestrictRegionTraits <- function(scope, data, region) { - for (st in names(scope$traits)) { - ctxs <- scope$contexts[[st]] - if (length(ctxs) == 0L) { - next - } - se <- getPhenotypes(data, contexts = ctxs[[1L]]) - scope$traits[[st]] <- .fmTraitsInRegion( - se, - intersect(scope$traits[[st]], rownames(se)), - region + studies <- names(scope$traits) + list_assign( + scope, + traits = set_names( + map( + studies, + .jointStudyTraitsInRegion, + scope = scope, + data = data, + region = region + ), + studies ) - } - scope + ) } # Individual-level (QtlDataset) input cannot joint over study: studies have @@ -1944,18 +2363,20 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # Build one record into a 1-row collection: wrap `entry` in a list and drop any # NA joint* axis (so the union re-adds it, padded, only when some row is joint). # @noRd +# A joint-axis column holding a lone NA means "not a joint axis", so it is +# dropped rather than carried as a column of NA. +# @noRd +.jointAxisIsAbsent <- function(value) { + !is.null(value) && length(value) == 1L && is.na(value) +} + .jointBuildRecordPart <- function(rec, constructor) { - rec$entry <- list(rec$entry) - for (jc in c("jointStudies", "jointContexts", "jointTraits")) { - if ( - !is.null(rec[[jc]]) && - length(rec[[jc]]) == 1L && - is.na(rec[[jc]]) - ) { - rec[[jc]] <- NULL - } - } - exec(constructor, !!!rec) + jointCols <- c("jointStudies", "jointContexts", "jointTraits") + absent <- jointCols[map_lgl(rec[jointCols], .jointAxisIsAbsent)] + kept <- rec[setdiff(names(rec), absent)] + # `list_assign()`, not `list_modify()`: the entry payload is itself a + # list, and list_modify would merge into it rather than wrap it. + exec(constructor, !!!list_assign(kept, entry = list(rec$entry))) } # TRUE when tuple row `r`'s study keeps context `cx` and trait `tid` in scope. diff --git a/R/jointSpecification.R b/R/jointSpecification.R index 72d7b6a4..3f4d4fbb 100644 --- a/R/jointSpecification.R +++ b/R/jointSpecification.R @@ -77,6 +77,16 @@ # Return character vector of contexts in `data` (across all studies when # `study = NULL`, or for one study otherwise). # @noRd +# Concatenate a list of pieces into one, the way `c()` did, but safe on the +# empty case (`list_c()` has no zero-length identity to return). +# @noRd +.spConcat <- function(pieces, empty = list()) { + if (length(pieces) == 0L) { + return(empty) + } + list_c(pieces) +} + .spListContexts <- function(data, study = NULL) { if (is(data, "QtlDataset")) { if (!is.null(study) && !identical(study, getStudy(data))) { @@ -96,14 +106,16 @@ indDatasets <- getQtlDatasets(data) ss <- getSumStats(data) if (is.null(study)) { - out <- character(0) - for (qd in indDatasets) { - out <- c(out, getContexts(qd)) - } - if (!is.null(ss)) { - out <- c(out, unique(as.character(ss$context))) + fromInd <- .spConcat( + map(indDatasets, getContexts), + empty = character(0) + ) + fromSs <- if (is.null(ss)) { + character(0) + } else { + unique(as.character(ss$context)) } - return(unique(out)) + return(unique(c(fromInd, fromSs))) } if (is_in(study, names(indDatasets))) { return(getContexts(indDatasets[[study]])) @@ -135,10 +147,9 @@ return(character(0)) } if (is.null(context)) { - return(unique(unlist( - map(getContexts(data), .spTraitsInContext, data = data), - use.names = FALSE - ))) + return(unique(unname(list_c( + map(getContexts(data), .spTraitsInContext, data = data) + )))) } # Checked here rather than left to the accessor: `.spListTraits` answers # "which traits are in this scope", and an absent context is an empty @@ -159,14 +170,16 @@ # Must precede per-study branches so a present sumStats slot does not shadow # the individual-level studies' traits when study = NULL. if (is.null(study)) { - out <- character(0) - for (qd in indDatasets) { - out <- c(out, .spListTraits(qd, context = context)) - } - if (!is.null(ss)) { - out <- c(out, .spListTraits(ss, context = context)) + fromInd <- .spConcat( + map(indDatasets, .spListTraits, context = context), + empty = character(0) + ) + fromSs <- if (is.null(ss)) { + character(0) + } else { + .spListTraits(ss, context = context) } - return(unique(out)) + return(unique(c(fromInd, fromSs))) } if (is_in(study, names(indDatasets))) { return(.spListTraits(indDatasets[[study]], context = context)) @@ -182,13 +195,17 @@ return(.spListTraitsQtlDataset(data, study, context)) } if (is(data, "QtlSumStats")) { - keep <- rep(TRUE, nrow(data)) - if (!is.null(study)) { - keep <- keep & as.character(data$study) == study + byStudy <- if (is.null(study)) { + rep(TRUE, nrow(data)) + } else { + as.character(data$study) == study } - if (!is.null(context)) { - keep <- keep & as.character(data$context) == context + byContext <- if (is.null(context)) { + TRUE + } else { + as.character(data$context) == context } + keep <- byStudy & byContext return(unique(as.character(data$trait[keep]))) } if (is(data, "MultiStudyQtlDataset")) { @@ -363,21 +380,38 @@ parseJointSpecification <- function(jointSpecification, data) { ) abort(msg) } - out <- list() - for (s in studies) { - avail <- .spListContexts(data, s) - missing <- setdiff(contexts, avail) - if (length(missing) > 0L) { - missingStr <- str_flatten(missing, ", ") - msg <- glue( - "parseContexts: study '{s}' is missing requested ", - "context(s): {missingStr}" - ) - warn(msg) - } - out[[s]] <- intersect(contexts, avail) + set_names( + map(studies, .parseContextsAvail, data = data, contexts = contexts), + studies + ) +} + +# One study's requested contexts, warning about any it does not have. +# @noRd +.parseContextsAvail <- function(s, data, contexts) { + avail <- .spListContexts(data, s) + missing <- setdiff(contexts, avail) + if (length(missing) > 0L) { + missingStr <- str_flatten(missing, ", ") + msg <- glue( + "parseContexts: study '{s}' is missing requested ", + "context(s): {missingStr}" + ) + warn(msg) + } + intersect(contexts, avail) +} + +# One study's contexts from the named-list form: its own entry when given, +# otherwise everything it has. +# @noRd +.parseContextsListAt <- function(s, data, contexts) { + avail <- .spListContexts(data, s) + if (is_in(s, names(contexts))) { + .parseContextsStudy(as.character(contexts[[s]]), s, avail) + } else { + avail } - out } # Validate one study's explicitly-requested contexts against availability. @@ -411,16 +445,10 @@ parseJointSpecification <- function(jointSpecification, data) { msg <- glue("`contexts` references unknown studies: {badStr}") abort(msg) } - out <- list() - for (s in studies) { - avail <- .spListContexts(data, s) - out[[s]] <- if (is_in(s, names(contexts))) { - .parseContextsStudy(as.character(contexts[[s]]), s, avail) - } else { - avail - } - } - out + set_names( + map(studies, .parseContextsListAt, data = data, contexts = contexts), + studies + ) } parseContexts <- function(contexts, data) { @@ -503,11 +531,16 @@ parseContexts <- function(contexts, data) { msg <- glue("traitId[['{s}']] references unknown contexts: {badStr}") abort(msg) } - sub <- list() - for (cx in names(val)) { - sub[[cx]] <- .parseTraitIdContext(val[[cx]], s, cx, data) - } - sub + set_names( + map(names(val), .parseTraitIdContextAt, val = val, s = s, data = data), + names(val) + ) +} + +# One context's trait spec within a study. +# @noRd +.parseTraitIdContextAt <- function(cx, val, s, data) { + .parseTraitIdContext(val[[cx]], s, cx, data) } # Dispatch one study's trait spec (character vector or context-keyed list). @@ -559,14 +592,24 @@ parseTraitIds <- function(traitId, data) { msg <- glue("`traitId` references unknown studies: {badStr}") abort(msg) } - out <- list() - for (s in names(traitId)) { - out[[s]] <- .parseTraitIdStudy(traitId[[s]], s, data) - } - out + set_names( + map( + names(traitId), + .parseTraitIdStudyAt, + traitId = traitId, + data = data + ), + names(traitId) + ) } +# One study's parsed trait spec. +# @noRd +.parseTraitIdStudyAt <- function(s, traitId, data) { + .parseTraitIdStudy(traitId[[s]], s, data) +} + # ----------------------------------------------------------------------------- # parseMethods -- normalize and validate the `methods` argument with optional # `sumStatsMethods` / `qtlDatasetMethods` overrides. Validates: @@ -640,22 +683,30 @@ parseTraitIds <- function(traitId, data) { return(list(list(depth = depth, path = path, methods = unique(spec)))) } .spWalkValidate(spec, label, depth, maxDepth) - out <- list() - for (nm in names(spec)) { - out <- c( - out, - .spWalkMethods( - spec[[nm]], - label = label, - depth = depth + 1L, - maxDepth = maxDepth, - path = c(path, nm) - ) - ) - } + out <- .spConcat(map( + names(spec), + .spWalkMethodsAt, + spec = spec, + label = label, + depth = depth, + maxDepth = maxDepth, + path = path + )) out } +# Walk one named branch of a methods spec. +# @noRd +.spWalkMethodsAt <- function(nm, spec, label, depth, maxDepth, path) { + .spWalkMethods( + spec[[nm]], + label = label, + depth = depth + 1L, + maxDepth = maxDepth, + path = c(path, nm) + ) +} + # Validate one leaf method vector: non-empty character, all tokens known (in # `caps`), and none in `rejectedAtUser`. # @noRd @@ -692,6 +743,7 @@ parseTraitIds <- function(traitId, data) { # --- parseMethods helpers --------------------------------------------------- # Validate mutual exclusivity of primary vs split method specs. +#' @importFrom checkmate assertCharacter .parseMethodsValidateArgs <- function( primaryGiven, splitGiven, @@ -720,14 +772,8 @@ parseTraitIds <- function(traitId, data) { ) abort(msg) } - if (!is.character(sumStatsMethods) || length(sumStatsMethods) == 0L) { - abort("`sumStatsMethods` must be a non-empty character vector.") - } - if ( - !is.character(qtlDatasetMethods) || length(qtlDatasetMethods) == 0L - ) { - abort("`qtlDatasetMethods` must be a non-empty character vector.") - } + assertCharacter(sumStatsMethods, min.len = 1L) + assertCharacter(qtlDatasetMethods, min.len = 1L) } } @@ -751,32 +797,35 @@ parseTraitIds <- function(traitId, data) { # Study/context/trait keys of a method leaf must reference valid entities. .parseMethodsCheckPath <- function(leaf, lab, data, studyNames) { - if (leaf$depth >= 1L) { - s <- leaf$path[[1L]] - if (!is_in(s, studyNames)) { - msg <- glue("{lab}: unknown study '{s}'") - abort(msg) - } + # The path is (study, context, trait); each level is only checked once the + # leaf is deep enough to name it -- a shallower leaf has no such entry to + # read, so the depth guard has to come before the extraction. + if (leaf$depth < 1L) { + return(invisible(NULL)) } - if (leaf$depth >= 2L) { - s <- leaf$path[[1L]] - cx <- leaf$path[[2L]] - if (!is_in(cx, .spListContexts(data, s))) { - msg <- glue("{lab}: unknown context '{cx}' for study '{s}'") - abort(msg) - } + s <- leaf$path[[1L]] + if (!is_in(s, studyNames)) { + msg <- glue("{lab}: unknown study '{s}'") + abort(msg) } - if (leaf$depth >= 3L) { - s <- leaf$path[[1L]] - cx <- leaf$path[[2L]] - tr <- leaf$path[[3L]] - if (!is_in(tr, .spListTraits(data, study = s, context = cx))) { - msg <- glue( - "{lab}: unknown trait '{tr}' for (study '{s}', ", - "context '{cx}')" - ) - abort(msg) - } + if (leaf$depth < 2L) { + return(invisible(NULL)) + } + cx <- leaf$path[[2L]] + if (!is_in(cx, .spListContexts(data, s))) { + msg <- glue("{lab}: unknown context '{cx}' for study '{s}'") + abort(msg) + } + if (leaf$depth < 3L) { + return(invisible(NULL)) + } + tr <- leaf$path[[3L]] + if (!is_in(tr, .spListTraits(data, study = s, context = cx))) { + msg <- glue( + "{lab}: unknown trait '{tr}' for (study '{s}', ", + "context '{cx}')" + ) + abort(msg) } } @@ -953,42 +1002,82 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # @noRd .fmResolveSpecScope <- function(spec, data, contexts = NULL, traitIds = NULL) { scope <- spec$scope - studies <- .spListStudies(data) - if (!is.null(scope$study)) { - studies <- intersect(studies, scope$study) - } + allStudies <- .spListStudies(data) + studies <- if (is.null(scope$study)) { + allStudies + } else { + intersect(allStudies, scope$study) + } + + contextsOut <- set_names( + map( + studies, + .fmScopeAxis, + avail = .spListContexts, + scopeLimit = scope$context, + userSpec = contexts, + requireCharacter = FALSE, + data = data + ), + studies + ) + traitsOut <- set_names( + map( + studies, + .fmScopeAxis, + avail = .fmScopeTraits, + scopeLimit = scope$trait, + userSpec = traitIds, + requireCharacter = TRUE, + data = data + ), + studies + ) + list(studies = studies, contexts = contextsOut, traits = traitsOut) +} - contextsOut <- list() - traitsOut <- list() - for (s in studies) { - ctxAvail <- .spListContexts(data, s) - if (!is.null(scope$context)) { - ctxAvail <- intersect(ctxAvail, scope$context) - } - if (!is.null(contexts)) { - if (is.list(contexts) && is_in(s, names(contexts))) { - ctxAvail <- intersect(ctxAvail, contexts[[s]]) - } else if (is.character(contexts)) { - ctxAvail <- intersect(ctxAvail, contexts) - } - } - contextsOut[[s]] <- ctxAvail +# `.spListTraits` takes the study by name, so give it the same (data, s) +# shape the context lister has. +# @noRd +.fmScopeTraits <- function(data, s) { + .spListTraits(data, study = s) +} - trAvail <- .spListTraits(data, study = s) - if (!is.null(scope$trait)) { - trAvail <- intersect(trAvail, scope$trait) - } - if (!is.null(traitIds)) { - if (is.character(traitIds)) { - trAvail <- intersect(trAvail, traitIds) - } else if (is.list(traitIds) && is_in(s, names(traitIds))) { - tv <- traitIds[[s]] - if (is.character(tv)) trAvail <- intersect(trAvail, tv) - } - } - traitsOut[[s]] <- trAvail +# What a pipeline-level `contexts` / `traitIds` argument narrows study `s` to, +# or NULL when it says nothing about it. `requireCharacter` mirrors the trait +# axis, which ignores a non-character per-study entry. +# @noRd +.fmScopeUserLimit <- function(spec, s, requireCharacter) { + if (is.null(spec)) { + return(NULL) } - list(studies = studies, contexts = contextsOut, traits = traitsOut) + if (is.character(spec)) { + return(spec) + } + if (!is.list(spec) || !is_in(s, names(spec))) { + return(NULL) + } + entry <- spec[[s]] + if (!requireCharacter || is.character(entry)) entry else NULL +} + +# One axis for one study: everything it has, narrowed by the spec's scope and +# then by the caller's argument. Each narrowing is an intersect, so the chain +# is a fold rather than a variable rewritten in place. +# @noRd +.fmScopeAxis <- function( + s, + avail, + scopeLimit, + userSpec, + requireCharacter, + data +) { + limits <- compact(list( + scopeLimit, + .fmScopeUserLimit(userSpec, s, requireCharacter) + )) + reduce(limits, intersect, .init = avail(data, s)) } @@ -1010,7 +1099,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { context = as.character(data$context), trait = as.character(data$trait) ) - firstDf <- getSumStatsDf( + allDf <- getSumStatsDf( data, study = cols$study[[tupleRows[[1L]]]], context = cols$context[[tupleRows[[1L]]]], @@ -1020,58 +1109,76 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # Every entry shares one SNP order (asserted below), so filtering the first # entry's ids filters the group: Z is built against this vector and each # entry is checked against it. - firstDf <- firstDf[ - .panelKeepMask(firstDf$variant_id, ldSketch, cutoffs, errorLabel), + firstDf <- allDf[ + .panelKeepMask(allDf$variant_id, ldSketch, cutoffs, errorLabel), , drop = FALSE ] variantIds <- firstDf$variant_id - Z <- matrix( - NA_real_, - nrow = length(variantIds), - ncol = length(tupleRows), - dimnames = list(variantIds, colLabels) - ) filled <- .jointFillSumstatZ( data, tupleRows, cols, variantIds, - Z, + colLabels, errorLabel ) list(Z = filled$Z, nVec = filled$nVec, variantIds = variantIds) } -# Read each tuple's z / N into the shared matrix. The fitters index z by -# column position, so every entry must present the same SNPs in the same order. +# One tuple's z column and median N, checked against the shared SNP order. +# @noRd +.jointSumstatEntryAt <- function( + kk, + data, + tupleRows, + cols, + variantIds, + errorLabel +) { + i <- tupleRows[[kk]] + d <- getSumStatsDf( + data, + study = cols$study[[i]], + context = cols$context[[i]], + trait = cols$trait[[i]], + require = c("SNP", "Z", "N") + ) + # Narrowed to the same set before the order check, or that check fires + # on a length mismatch the panel filter itself created. + kept <- d[is_in(d$variant_id, variantIds), , drop = FALSE] + .jointCheckSnpOrder(kept$variant_id, variantIds, errorLabel) + list(z = kept$z, n = stats::median(kept$N, na.rm = TRUE)) +} + +# Read each tuple's z / N into one matrix. The fitters index z by column +# position, so every entry must present the same SNPs in the same order -- +# which is what lets the columns simply be laid side by side here. # @noRd .jointFillSumstatZ <- function( data, tupleRows, cols, variantIds, - Z, + colLabels, errorLabel ) { - nVec <- numeric(length(tupleRows)) - for (kk in seq_along(tupleRows)) { - i <- tupleRows[[kk]] - d <- getSumStatsDf( - data, - study = cols$study[[i]], - context = cols$context[[i]], - trait = cols$trait[[i]], - require = c("SNP", "Z", "N") - ) - # Narrowed to the same set before the order check, or that check fires - # on a length mismatch the panel filter itself created. - d <- d[is_in(d$variant_id, variantIds), , drop = FALSE] - .jointCheckSnpOrder(d$variant_id, variantIds, errorLabel) - Z[, kk] <- d$z - nVec[kk] <- stats::median(d$N, na.rm = TRUE) - } - list(Z = Z, nVec = nVec) + entries <- map( + seq_along(tupleRows), + .jointSumstatEntryAt, + data = data, + tupleRows = tupleRows, + cols = cols, + variantIds = variantIds, + errorLabel = errorLabel + ) + Z <- matrix( + unname(list_c(map(entries, "z"))), + nrow = length(variantIds), + ncol = length(tupleRows), + dimnames = list(variantIds, colLabels) + ) + list(Z = Z, nVec = map_dbl(entries, "n")) } # @noRd @@ -1094,14 +1201,19 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # --- .buildIndividualCrossContextXy helpers --------------------------------- # Scoped contexts in which a trait is present; NULL if fewer than 2. +# Does context `cx` carry trait `tid`? +# @noRd +.ccContextHasTrait <- function(cx, data, tid) { + is_in(tid, rownames(getPhenotypes(data, contexts = cx))) +} + .crossContextPerTrait <- function(data, tid, scopedContexts, verbose, label) { - perTraitContexts <- character(0) - for (cx in scopedContexts) { - se <- getPhenotypes(data, contexts = cx) - if (is_in(tid, rownames(se))) { - perTraitContexts <- c(perTraitContexts, cx) - } - } + perTraitContexts <- keep( + scopedContexts, + .ccContextHasTrait, + data = data, + tid = tid + ) if (length(perTraitContexts) < 2L) { if (verbose >= 1) { nCtx <- length(perTraitContexts) @@ -1142,29 +1254,27 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { ) if (length(commonSamples) < 2L) { if (verbose >= 1) { - msg <- glue( + inform(glue( "{label}: trait '{tid}' has too few shared samples across ", "contexts; skipping." - ) - inform(msg) + )) } return(NULL) } - X <- X[commonSamples, , drop = FALSE] + shared <- X[commonSamples, , drop = FALSE] Y <- .crossContextY(Yres, perTraitContexts, commonSamples) keep <- stats::complete.cases(Y) if (sum(keep) < 2L) { if (verbose >= 1) { - msg <- glue( + inform(glue( "{label}: trait '{tid}' has too few complete-Y subjects; ", "skipping." - ) - inform(msg) + )) } return(NULL) } list( - X = X[keep, , drop = FALSE], + X = shared[keep, , drop = FALSE], Y = Y[keep, , drop = FALSE], perTraitContexts = perTraitContexts ) @@ -1247,14 +1357,14 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { if (.crossTraitTooFew(traitsHere, cx, study, verbose, label)) { return(NULL) } - X <- .buildResidGeno(data, cx, traitsHere, cisWindow, region) - Y <- .fmResidPheno(data, contexts = cx, traitId = traitsHere) - common <- intersect(rownames(X), rownames(Y)) + allX <- .buildResidGeno(data, cx, traitsHere, cisWindow, region) + allY <- .fmResidPheno(data, contexts = cx, traitId = traitsHere) + common <- intersect(rownames(allX), rownames(allY)) if (length(common) < 2L) { return(NULL) } - X <- X[common, , drop = FALSE] - Y <- Y[common, , drop = FALSE] + X <- allX[common, , drop = FALSE] + Y <- allY[common, , drop = FALSE] keep <- stats::complete.cases(Y) if (sum(keep) < 2L) { return(NULL) @@ -1289,17 +1399,28 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # --- .buildComposedIndividualXy helpers ------------------------------------- # Enumerate the in-scope (context, trait) tuples for a study; NULL if < 2. +# @noRd +.composedTuple <- function(tid, cx) { + list(context = cx, trait = tid) +} + +# The (context, trait) tuples context `cx` contributes. +# @noRd +.composedTuplesForContext <- function(cx, data, scopedTraits) { + se <- getPhenotypes(data, contexts = cx) + # scopedTraits is region-restricted upstream (.runJointSpecs) if needed. + map(intersect(scopedTraits, rownames(se)), .composedTuple, cx = cx) +} + .composedTuples <- function(data, scope, study, verbose, label) { scopedContexts <- scope$contexts[[study]] scopedTraits <- scope$traits[[study]] - tuples <- list() - for (cx in scopedContexts) { - se <- getPhenotypes(data, contexts = cx) - # scopedTraits is region-restricted upstream (.runJointSpecs) if needed. - for (tid in intersect(scopedTraits, rownames(se))) { - tuples[[length(tuples) + 1L]] <- list(context = cx, trait = tid) - } - } + tuples <- .spConcat(map( + scopedContexts, + .composedTuplesForContext, + data = data, + scopedTraits = scopedTraits + )) if (length(tuples) < 2L) { if (verbose >= 1) { nTuples <- length(tuples) @@ -1315,17 +1436,28 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } # Assemble the composed response matrix (one column per tuple); NULL if < 2. -.composedYCols <- function(YresList, tuples, commonSamples) { - yCols <- list() - for (t in tuples) { - ym <- YresList[[t$context]] - if (!is_in(t$trait, colnames(ym))) { - next - } - col <- ym[commonSamples, t$trait, drop = FALSE] - colnames(col) <- str_c(t$context, t$trait, sep = ":") - yCols[[length(yCols) + 1L]] <- col +# One tuple's phenotype column, labelled "context:trait", or NULL when that +# context does not carry the trait. `colnames<-` applied as a function returns +# a relabelled copy rather than renaming a binding in place. +# @noRd +.composedYCol <- function(t, YresList, commonSamples) { + ym <- YresList[[t$context]] + if (!is_in(t$trait, colnames(ym))) { + return(NULL) } + `colnames<-`( + ym[commonSamples, t$trait, drop = FALSE], + str_c(t$context, t$trait, sep = ":") + ) +} + +.composedYCols <- function(YresList, tuples, commonSamples) { + yCols <- compact(map( + tuples, + .composedYCol, + YresList = YresList, + commonSamples = commonSamples + )) if (length(yCols) < 2L) { return(NULL) } @@ -1347,19 +1479,22 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } allContexts <- unique(map_chr(tuples, "context")) allTraits <- unique(map_chr(tuples, "trait")) - X <- .buildResidGeno(data, allContexts, allTraits, cisWindow, region) - YresList <- .fmResidPheno(data, contexts = allContexts, traitId = allTraits) - if (length(allContexts) == 1L) { - YresList <- set_names(list(YresList), allContexts) + allX <- .buildResidGeno(data, allContexts, allTraits, cisWindow, region) + resid <- .fmResidPheno(data, contexts = allContexts, traitId = allTraits) + # A single context returns the bare matrix rather than a named list. + YresList <- if (length(allContexts) == 1L) { + set_names(list(resid), allContexts) + } else { + resid } commonSamples <- reduce( - c(list(rownames(X)), map(YresList, rownames)), + c(list(rownames(allX)), map(YresList, rownames)), intersect ) if (length(commonSamples) < 2L) { return(NULL) } - X <- X[commonSamples, , drop = FALSE] + X <- allX[commonSamples, , drop = FALSE] Y <- .composedYCols(YresList, tuples, commonSamples) if (is.null(Y)) { return(NULL) @@ -1519,6 +1654,23 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # --- .multiStudyPipelineDriver helpers -------------------------------------- # Accumulate per-study + sumstats results (tracking the embedded LD sketch). +# rbind two results with no LD sketch -- the per-study combine. +# @noRd +.msRbindNoLd <- function(acc, x, rbindFn) { + rbindFn(acc, x, ldSketch = NULL) +} + +# Fold per-study results together, skipping studies that produced nothing. +# NULL when nothing did, which is what the callers' `out` started as. +# @noRd +.msFoldStudyResults <- function(results, rbindFn) { + kept <- compact(results) + if (length(kept) == 0L) { + return(NULL) + } + reduce(kept, .msRbindNoLd, rbindFn = rbindFn) +} + .msDriverAccumulate <- function( qtlDatasets, sumStats, @@ -1527,24 +1679,19 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { cfg, rbindFn ) { - out <- NULL - embeddedLd <- NULL - for (qdName in names(qtlDatasets)) { - res <- perStudyFn(qtlDatasets[[qdName]], cfg) - if (!is.null(res)) { - out <- if (is.null(out)) res else rbindFn(out, res, ldSketch = NULL) - } + fromStudies <- .msFoldStudyResults( + map(qtlDatasets, perStudyFn, cfg), + rbindFn + ) + ssRes <- if (is.null(sumStats)) NULL else sumStatsFn(sumStats, cfg) + if (is.null(ssRes)) { + return(list(out = fromStudies, embeddedLd = NULL)) } - if (!is.null(sumStats)) { - ssRes <- sumStatsFn(sumStats, cfg) - if (!is.null(ssRes)) { - embeddedLd <- getLdSketch(ssRes) - out <- if (is.null(out)) { - ssRes - } else { - rbindFn(out, ssRes, ldSketch = embeddedLd) - } - } + embeddedLd <- getLdSketch(ssRes) + out <- if (is.null(fromStudies)) { + ssRes + } else { + rbindFn(fromStudies, ssRes, ldSketch = embeddedLd) } list(out = out, embeddedLd = embeddedLd) } @@ -1659,10 +1806,35 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # Run the joint dispatch once per region block, then merge per # (study, context, trait, method) across regions. A single block (cis or # jointRegions=TRUE concatenated) returns its result directly. - args <- as.list(environment()) - args$xRegions <- NULL - perRegion <- map(xRegions, .fmDispatchJointSpecRegion, args = args) - perRegion <- compact(perRegion) + # xRegions is deliberately absent: each region is supplied per call. + perRegion <- map( + xRegions, + .fmDispatchJointSpecRegion, + parsedJointSpec = parsedJointSpec, + data = data, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + verbose = verbose, + methodArgs = methodArgs, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + pipCutoffToSkip = pipCutoffToSkip, + fineMappingResult = fineMappingResult, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + seed = seed + ) |> + compact() if (length(perRegion) == 0L) { return(NULL) } @@ -1673,26 +1845,38 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } # FmJointPipeline for individual-level fine-mapping, built from the call params. -.fmJointPipeline <- function(args) { +.fmJointPipeline <- function( + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + dataDrivenPriorWeightsCutoff, + cvFolds, + cvThreads, + samplePartition, + verbose, + fullFit, + fullFitAlphaOnly, + includeAllCs, + seed +) { new( "FmJointPipeline", - config = c( - args[c( - "coverage", - "secondaryCoverage", - "signalCutoff", - "minAbsCorr", - "dataDrivenPriorWeightsCutoff", - "cvFolds", - "cvThreads", - "samplePartition", - "verbose", - "fullFit", - "fullFitAlphaOnly", - "includeAllCs", - "seed" - )], - list(ldSketch = NULL) + config = list( + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + verbose = verbose, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + seed = seed, + ldSketch = NULL ) ) } @@ -1726,7 +1910,21 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # Engine routing (jointEngine.R); one region block (the caller loops # regions). .jointRejectStudyOnIndividual(parsedJointSpec) - pipeline <- .fmJointPipeline(as.list(environment())) + pipeline <- .fmJointPipeline( + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + verbose = verbose, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + seed = seed + ) .runJointSpecs( parsedJointSpec, data, @@ -1753,22 +1951,32 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # @noRd # FmJointPipeline for summary-statistics fine-mapping (RSS: no sample folds; # LD sketch drawn from the data). -.fmSumStatsPipeline <- function(args) { +.fmSumStatsPipeline <- function( + data, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + dataDrivenPriorWeightsCutoff, + verbose, + fullFit, + fullFitAlphaOnly, + includeAllCs +) { new( "FmJointPipeline", - config = c( - args[c( - "coverage", - "secondaryCoverage", - "signalCutoff", - "minAbsCorr", - "dataDrivenPriorWeightsCutoff", - "verbose", - "fullFit", - "fullFitAlphaOnly", - "includeAllCs" - )], - list(cvFolds = 0L, ldSketch = getLdSketch(args$data)) + config = list( + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + verbose = verbose, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + cvFolds = 0L, + ldSketch = getLdSketch(data) ) ) } @@ -1798,7 +2006,18 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # Engine routing (jointEngine.R): the dispatch table + .runJointCell replace # the per-axis switch + the cross-context/trait/study/composed leaf # dispatchers. - pipeline <- .fmSumStatsPipeline(as.list(environment())) + pipeline <- .fmSumStatsPipeline( + data = data, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + verbose = verbose, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs + ) .runJointSpecs( parsedJointSpec, data, @@ -1813,11 +2032,11 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { methodArgs = methodArgs, verbose = verbose, cache = fineMappingResult, - cutoffs = .panelCutoffs(list( + cutoffs = .panelCutoffs( mafCutoff = mafCutoff, macCutoff = macCutoff, imissCutoff = imissCutoff - )) + ) ) ) } @@ -1855,41 +2074,85 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } # Fine-map the non-study-axis specs on each individual-level QtlDataset. -.fmMultiStudyQtlLoop <- function(nonStudyAxisSpecs, qtlDatasets, args) { - out <- NULL +.fmMultiStudyQtlLoop <- function( + nonStudyAxisSpecs, + qtlDatasets, + methods, + contexts, + traitIds, + cisWindow, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + verbose, + methodArgs, + xRegions, + twasWeights, + dataDrivenPriorWeightsCutoff +) { if (length(nonStudyAxisSpecs) == 0L) { - return(out) - } - fwd <- args[c( - "methods", - "contexts", - "traitIds", - "cisWindow", - "coverage", - "secondaryCoverage", - "signalCutoff", - "minAbsCorr", - "verbose", - "methodArgs", - "xRegions", - "twasWeights", - "dataDrivenPriorWeightsCutoff" - )] - for (qdName in names(qtlDatasets)) { - qdArgs <- c( - list(nonStudyAxisSpecs, qtlDatasets[[qdName]]), - fwd - ) - qdRes <- exec(.fmDispatchJointSpecsQtlDataset, !!!qdArgs) - if (!is.null(qdRes)) { - out <- if (is.null(out)) { - qdRes - } else { - .rbindFineMappingResult(out, qdRes, ldSketch = NULL) - } - } + return(NULL) } - out + .msFoldStudyResults( + map( + qtlDatasets, + .fmDispatchForStudy, + nonStudyAxisSpecs = nonStudyAxisSpecs, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + verbose = verbose, + methodArgs = methodArgs, + xRegions = xRegions, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ), + .rbindFineMappingResult + ) +} + +# `map()` hands the dataset first; the dispatcher wants the specs first. +# @noRd +.fmDispatchForStudy <- function( + qd, + nonStudyAxisSpecs, + methods, + contexts, + traitIds, + cisWindow, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + verbose, + methodArgs, + xRegions, + twasWeights, + dataDrivenPriorWeightsCutoff +) { + .fmDispatchJointSpecsQtlDataset( + nonStudyAxisSpecs, + qd, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + verbose = verbose, + methodArgs = methodArgs, + xRegions = xRegions, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ) } # Fine-map all specs on the sumstats collection; rbind onto `out`. @@ -1898,8 +2161,17 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { sumStats, studyAxisSpecs, out, - args, - verbose + methods, + contexts, + traitIds, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + verbose, + methodArgs, + twasWeights, + dataDrivenPriorWeightsCutoff ) { if (is.null(sumStats)) { if (length(studyAxisSpecs) > 0L && verbose >= 1) { @@ -1911,24 +2183,21 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } return(out) } - fwd <- args[c( - "methods", - "contexts", - "traitIds", - "coverage", - "secondaryCoverage", - "signalCutoff", - "minAbsCorr", - "verbose", - "methodArgs", - "twasWeights", - "dataDrivenPriorWeightsCutoff" - )] - ssArgs <- c( - list(parsedJointSpec, sumStats), - fwd - ) - ssRes <- exec(.fmDispatchJointSpecsQtlSumStats, !!!ssArgs) + ssRes <- .fmDispatchJointSpecsQtlSumStats( + parsedJointSpec, + sumStats, + methods = methods, + contexts = contexts, + traitIds = traitIds, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + verbose = verbose, + methodArgs = methodArgs, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ) if (is.null(ssRes)) { return(out) } @@ -1957,19 +2226,43 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { twasWeights = NULL, dataDrivenPriorWeightsCutoff = 1e-10 ) { - args <- as.list(environment()) qtlDatasets <- getQtlDatasets(data) sumStats <- getSumStats(data) specs <- .fmSplitStudyAxisSpecs(parsedJointSpec) .fmMultiStudyWarnExcluded(specs$study, qtlDatasets, verbose) - out <- .fmMultiStudyQtlLoop(specs$nonStudy, qtlDatasets, args) + out <- .fmMultiStudyQtlLoop( + specs$nonStudy, + qtlDatasets, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + verbose = verbose, + methodArgs = methodArgs, + xRegions = xRegions, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ) .fmMultiStudySumStats( parsedJointSpec, sumStats, specs$study, out, - args, - verbose + methods = methods, + contexts = contexts, + traitIds = traitIds, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + verbose = verbose, + methodArgs = methodArgs, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff ) } @@ -2031,7 +2324,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # Run the joint dispatch once per region block, then merge per # (study, context, trait, method) across regions. A single block (cis or # jointRegions=TRUE concatenated) returns its result directly. - perRegion <- map( + allRegions <- map( xRegions, .twasDispatchJointSpecRegion, parsedJointSpec = parsedJointSpec, @@ -2046,10 +2339,10 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { retainFitDetail = retainFitDetail, seed = seed ) - labs <- map_chr(xRegions, .twasRegionLabel) - keep <- !map_lgl(perRegion, is.null) - perRegion <- perRegion[keep] - labs <- labs[keep] + allLabs <- map_chr(xRegions, .twasRegionLabel) + keep <- !map_lgl(allRegions, is.null) + perRegion <- allRegions[keep] + labs <- allLabs[keep] if (length(perRegion) == 0L) { return(NULL) } @@ -2145,11 +2438,11 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { args = list( methodArgs = list(), verbose = verbose, - cutoffs = .panelCutoffs(list( + cutoffs = .panelCutoffs( mafCutoff = mafCutoff, macCutoff = macCutoff, imissCutoff = imissCutoff - )) + ) ) ) } @@ -2175,38 +2468,73 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } # Learn weights for the non-study-axis specs on each individual-level dataset. -.twasMultiStudyQtlLoop <- function(nonStudyAxisSpecs, qtlDatasets, args) { - out <- NULL +.twasMultiStudyQtlLoop <- function( + nonStudyAxisSpecs, + qtlDatasets, + methods, + contexts, + traitIds, + cisWindow, + dataType, + verbose, + xRegions, + retainFit, + retainFitDetail, + seed +) { if (length(nonStudyAxisSpecs) == 0L) { - return(out) - } - fwd <- args[c( - "methods", - "contexts", - "traitIds", - "cisWindow", - "dataType", - "verbose", - "xRegions", - "retainFit", - "retainFitDetail", - "seed" - )] - for (qdName in names(qtlDatasets)) { - qdArgs <- c( - list(nonStudyAxisSpecs, qtlDatasets[[qdName]]), - fwd - ) - qdRes <- exec(.twasDispatchJointSpecsQtlDataset, !!!qdArgs) - if (!is.null(qdRes)) { - out <- if (is.null(out)) { - qdRes - } else { - .rbindTwasWeights(out, qdRes, ldSketch = NULL) - } - } + return(NULL) } - out + .msFoldStudyResults( + map( + qtlDatasets, + .twasDispatchForStudy, + nonStudyAxisSpecs = nonStudyAxisSpecs, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + dataType = dataType, + verbose = verbose, + xRegions = xRegions, + retainFit = retainFit, + retainFitDetail = retainFitDetail, + seed = seed + ), + .rbindTwasWeights + ) +} + +# `map()` hands the dataset first; the dispatcher wants the specs first. +# @noRd +.twasDispatchForStudy <- function( + qd, + nonStudyAxisSpecs, + methods, + contexts, + traitIds, + cisWindow, + dataType, + verbose, + xRegions, + retainFit, + retainFitDetail, + seed +) { + .twasDispatchJointSpecsQtlDataset( + nonStudyAxisSpecs, + qd, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + dataType = dataType, + verbose = verbose, + xRegions = xRegions, + retainFit = retainFit, + retainFitDetail = retainFitDetail, + seed = seed + ) } # Learn weights for all specs on the sumstats collection; rbind onto `out`. @@ -2215,8 +2543,13 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { sumStats, studyAxisSpecs, out, - args, - verbose + methods, + contexts, + traitIds, + dataType, + verbose, + retainFit, + retainFitDetail ) { if (is.null(sumStats)) { if (length(studyAxisSpecs) > 0L && verbose >= 1) { @@ -2228,20 +2561,17 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } return(out) } - fwd <- args[c( - "methods", - "contexts", - "traitIds", - "dataType", - "verbose", - "retainFit", - "retainFitDetail" - )] - ssArgs <- c( - list(parsedJointSpec, sumStats), - fwd - ) - ssRes <- exec(.twasDispatchJointSpecsQtlSumStats, !!!ssArgs) + ssRes <- .twasDispatchJointSpecsQtlSumStats( + parsedJointSpec, + sumStats, + methods = methods, + contexts = contexts, + traitIds = traitIds, + dataType = dataType, + verbose = verbose, + retainFit = retainFit, + retainFitDetail = retainFitDetail + ) if (is.null(ssRes)) { return(out) } @@ -2267,19 +2597,36 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { retainFitDetail = "slim", seed = NULL ) { - args <- as.list(environment()) qtlDatasets <- getQtlDatasets(data) sumStats <- getSumStats(data) specs <- .fmSplitStudyAxisSpecs(parsedJointSpec) .twasMultiStudyWarnExcluded(specs$study, qtlDatasets, verbose) - out <- .twasMultiStudyQtlLoop(specs$nonStudy, qtlDatasets, args) + out <- .twasMultiStudyQtlLoop( + specs$nonStudy, + qtlDatasets, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + dataType = dataType, + verbose = verbose, + xRegions = xRegions, + retainFit = retainFit, + retainFitDetail = retainFitDetail, + seed = seed + ) .twasMultiStudySumStats( parsedJointSpec, sumStats, specs$study, out, - args, - verbose + methods = methods, + contexts = contexts, + traitIds = traitIds, + dataType = dataType, + verbose = verbose, + retainFit = retainFit, + retainFitDetail = retainFitDetail ) } @@ -2295,9 +2642,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # One context's response column on the shared samples, named by the context. # @noRd .crossContextYCol <- function(cx, Yres, commonSamples) { - ym <- Yres[[cx]][commonSamples, , drop = FALSE] - colnames(ym) <- cx - ym + `colnames<-`(Yres[[cx]][commonSamples, , drop = FALSE], cx) } # TRUE when sumstats row `i`'s (study, context, trait) is entirely in scope. @@ -2359,9 +2704,58 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # One region's FM joint-spec dispatch; `args` bundles the shared call arguments. # @noRd -.fmDispatchJointSpecRegion <- function(rg, args) { - regionArgs <- c(args, list(region = rg)) - exec(.fmDispatchJointSpecsQtlDatasetOneRegion, !!!regionArgs) +.fmDispatchJointSpecRegion <- function( + rg, + parsedJointSpec, + data, + methods, + contexts, + traitIds, + cisWindow, + coverage, + secondaryCoverage, + signalCutoff, + minAbsCorr, + verbose, + methodArgs, + twasWeights, + dataDrivenPriorWeightsCutoff, + cvFolds, + cvThreads, + samplePartition, + pipCutoffToSkip, + fineMappingResult, + fullFit, + fullFitAlphaOnly, + includeAllCs, + seed +) { + .fmDispatchJointSpecsQtlDatasetOneRegion( + parsedJointSpec = parsedJointSpec, + data = data, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + verbose = verbose, + methodArgs = methodArgs, + twasWeights = twasWeights, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + pipCutoffToSkip = pipCutoffToSkip, + fineMappingResult = fineMappingResult, + fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs, + seed = seed, + region = rg + ) } # One region's TWAS joint-spec dispatch over a QtlDataset. diff --git a/R/ld.R b/R/ld.R index 6f294c6a..82a8df67 100644 --- a/R/ld.R +++ b/R/ld.R @@ -2,10 +2,9 @@ #' @importFrom dplyr distinct arrange #' @noRd orderDedupRegions <- function(df) { - df$chrom <- canonChrom(df$chrom) - df <- distinct(df, .data$chrom, .data$start, .keep_all = TRUE) |> + mutate(df, chrom = canonChrom(.data$chrom)) |> + distinct(.data$chrom, .data$start, .keep_all = TRUE) |> arrange(chromOrder(.data$chrom), .data$start) - df } #' Find the first and last rows of genomicData that overlap a query region. @@ -133,12 +132,15 @@ extractFilePaths <- function(genomicData, intersectionRows, columnToExtract) { # Split the comma-joined path column into LD (+ optional bim) path columns. .regionalLdParsePaths <- function(genomicData) { parts <- str_split(genomicData$path, ",", simplify = TRUE) - filePath <- as_tibble(parts, .name_repair = "minimal") - names(filePath) <- if (ncol(parts) == 2) { + pathNames <- if (ncol(parts) == 2) { c("LD_file_path", "bim_file_path") } else { "LD_file_path" } + filePath <- `names<-`( + as_tibble(parts, .name_repair = "minimal"), + pathNames + ) bind_cols(genomicData, filePath) |> select(-any_of("path")) } @@ -164,23 +166,37 @@ extractFilePaths <- function(genomicData, intersectionRows, columnToExtract) { list(ldPaths = ldPaths, bimPaths = bimPaths) } +# A metadata row recorded as start=0, end=0 covers the whole chromosome +# rather than an empty interval, so widen its end before any overlap test. +# @noRd +.ldMetaWidenWholeChrom <- function(meta) { + mutate( + meta, + end = if_else( + .data$start == 0 & .data$end == 0, + Inf, + as.numeric(.data$end) + ) + ) +} + getRegionalLdMeta <- function( ldReferenceMetaFile, region, completeCoverageRequired = FALSE ) { - genomicData <- vroom(ldReferenceMetaFile) - region <- parseRegion(region) - names(genomicData) <- c("chrom", "start", "end", "path") - names(region) <- c("chrom", "start", "end") - # Treat start=0, end=0 as "covers all regions" (whole-chromosome files). - wholeChrom <- genomicData$start == 0 & genomicData$end == 0 - if (any(wholeChrom)) { - genomicData$end[wholeChrom] <- Inf - } - genomicData <- orderDedupRegions(genomicData) - region <- orderDedupRegions(region) - genomicData <- .regionalLdParsePaths(genomicData) + genomicData <- `names<-`( + vroom(ldReferenceMetaFile), + c("chrom", "start", "end", "path") + ) |> + .ldMetaWidenWholeChrom() |> + orderDedupRegions() |> + .regionalLdParsePaths() + region <- `names<-`( + parseRegion(region), + c("chrom", "start", "end") + ) |> + orderDedupRegions() intersectionRows <- findIntersectionRows( genomicData, region$chrom, @@ -237,44 +253,49 @@ getRegionalLdMeta <- function( # Read + normalise the LD variant metadata (canonical chrom / variant id / GD). .processLdVariants <- function(snpFilePath) { - ldVariants <- readVariantMetadata(snpFilePath) - isPvar <- !is_in("gpos", names(ldVariants)) - ldVariants <- ldVariants |> - mutate( - chrom = canonChrom(.data$chrom), - variants = normalizeVariantId(.data$id) - ) - if (isPvar) { - ldVariants <- rename(ldVariants, GD = "pos") - ldVariants$GD <- ldVariants$pos <- map_int( - ldVariants$variants, - .ldVariantPos - ) - } else { - ldVariants <- rename(ldVariants, GD = "gpos") + raw <- readVariantMetadata(snpFilePath) + isPvar <- !is_in("gpos", names(raw)) + ldVariants <- mutate( + raw, + chrom = canonChrom(.data$chrom), + variants = normalizeVariantId(.data$id) + ) + if (!isPvar) { + return(rename(ldVariants, GD = "gpos")) } - ldVariants + # A .pvar carries no genetic distance, so GD and pos both take the + # position parsed back out of the variant id. + parsedPos <- map_int(ldVariants$variants, .ldVariantPos) + rename(ldVariants, GD = "pos") |> + mutate(GD = parsedPos, pos = parsedPos) } processLdMatrix <- function(ldFilePath, snpFilePath = NULL) { ldFileCon <- xzfile(ldFilePath) - ldMatrix <- scan(ldFileCon, quiet = TRUE) + ldValues <- scan(ldFileCon, quiet = TRUE) close(ldFileCon) - ldMatrix <- matrix(ldMatrix, ncol = sqrt(length(ldMatrix)), byrow = TRUE) snpFilePath <- .processLdSnpFile(ldFilePath, snpFilePath) - ldVariants <- .processLdVariants(snpFilePath) + rawVariants <- .processLdVariants(snpFilePath) # Label and symmetrize the matrix. - colnames(ldMatrix) <- rownames(ldMatrix) <- ldVariants$variants - if (all(ldMatrix[lower.tri(ldMatrix)] == 0)) { - ldMatrix[lower.tri(ldMatrix)] <- t(ldMatrix)[lower.tri(ldMatrix)] + labelled <- `dimnames<-`( + matrix(ldValues, ncol = sqrt(length(ldValues)), byrow = TRUE), + list(rawVariants$variants, rawVariants$variants) + ) + # Only one triangle is stored on disk; mirror whichever one is empty. + lower <- lower.tri(labelled) + upper <- upper.tri(labelled) + ldMatrix <- if (all(labelled[lower] == 0)) { + replace(labelled, lower, t(labelled)[lower]) } else { - ldMatrix[upper.tri(ldMatrix)] <- t(ldMatrix)[upper.tri(ldMatrix)] + replace(labelled, upper, t(labelled)[upper]) } # Order variants by genomic position. - posOrder <- order(map_int(ldVariants$variants, .ldVariantPos)) - ldVariants <- slice(ldVariants, posOrder) - ldMatrix <- ldMatrix[ldVariants$variants, ldVariants$variants] - list(ldMatrix = ldMatrix, ldVariants = ldVariants) + posOrder <- order(map_int(rawVariants$variants, .ldVariantPos)) + ldVariants <- slice(rawVariants, posOrder) + list( + ldMatrix = ldMatrix[ldVariants$variants, ldVariants$variants], + ldVariants = ldVariants + ) } #' Subset an LD matrix and variant info to a genomic region, optionally further @@ -282,57 +303,65 @@ processLdMatrix <- function(ldFilePath, snpFilePath = NULL) { #' @importFrom dplyr mutate select inner_join #' @noRd extractLdForRegion <- function(ldMatrix, variants, region, extractCoordinates) { - extracted <- filter( + inRegion <- filter( variants, .data$chrom == region$chrom & .data$pos >= region$start & .data$pos <= region$end ) - - if (!is.null(extractCoordinates)) { - extractCoordinates <- extractCoordinates |> - mutate(chrom = canonChrom(.data$chrom)) |> - select("chrom", "pos") - extracted <- extracted |> - mutate(chrom = canonChrom(.data$chrom)) |> - inner_join(extractCoordinates, by = c("chrom", "pos")) - keepCols <- intersect( - c( - "chrom", - "variants", - "pos", - "GD", - "A1", - "A2", - "variance", - "allele_freq", - "n_nomiss" - ), - names(extracted) - ) - extracted <- select(extracted, all_of(keepCols)) + extracted <- if (is.null(extractCoordinates)) { + inRegion + } else { + .ldRestrictToCoordinates(inRegion, extractCoordinates) } - mat <- ldMatrix[extracted$variants, extracted$variants, drop = FALSE] list(extractedLdMatrix = mat, extractedLdVariants = extracted) } +# The region's variants restricted to an explicit (chrom, pos) list, keeping +# only the variant-info columns the callers read back. +# @noRd +.ldRestrictToCoordinates <- function(inRegion, extractCoordinates) { + wanted <- extractCoordinates |> + mutate(chrom = canonChrom(.data$chrom)) |> + select("chrom", "pos") + joined <- inRegion |> + mutate(chrom = canonChrom(.data$chrom)) |> + inner_join(wanted, by = c("chrom", "pos")) + keepCols <- intersect( + c( + "chrom", + "variants", + "pos", + "GD", + "A1", + "A2", + "variance", + "allele_freq", + "n_nomiss" + ), + names(joined) + ) + select(joined, all_of(keepCols)) +} + # Concatenate per-block variant-id lists into one deduplicated vector, dropping # a repeated boundary variant shared between adjacent blocks. # @noRd .ldMergeVariants <- function(variantList) { - merged <- character(0) - for (v in variantList) { - ids <- if (is.list(v) && !is.null(v$variants)) v$variants else v - if (length(ids) == 0) { - next - } - if (length(merged) > 0 && tail(merged, 1) == ids[1]) { - ids <- ids[-1] - } - merged <- c(merged, ids) + # Only the running tail decides whether a block's first id is a repeated + # boundary variant, so the merge is a fold. + reduce(variantList, .ldAppendBlockVariants, .init = character(0)) +} + +# @noRd +.ldAppendBlockVariants <- function(merged, v) { + ids <- if (is.list(v) && !is.null(v$variants)) v$variants else v + if (length(ids) == 0) { + return(merged) } - merged + repeatsBoundary <- length(merged) > 0 && tail(merged, 1) == ids[1] + c(merged, if (repeatsBoundary) ids[-1] else ids) } #' Combine multiple block-level LD matrices into one, handling boundary @@ -348,7 +377,9 @@ createLdMatrix <- function(ldMatrices, variants) { dimnames = list(allVariants, allVariants) ) - # Place each block into the combined matrix + # Deliberate preallocate-and-scatter: `combined` is variants x variants, + # so building it by folding full-size copies would multiply the memory + # this function needs by the number of blocks. for (i in seq_along(ldMatrices)) { v <- rownames(ldMatrices[[i]]) idx <- match(v, allVariants) @@ -400,9 +431,11 @@ createLdMatrix <- function(ldMatrices, variants) { if (length(dupIdx) == 0) { return(result) } - corr <- getCorrelation(result) - if (!is.null(corr)) { - corr <- corr[-dupIdx, -dupIdx, drop = FALSE] + full <- getCorrelation(result) + corr <- if (is.null(full)) { + NULL + } else { + full[-dupIdx, -dupIdx, drop = FALSE] } LdData( correlation = corr, @@ -565,7 +598,7 @@ loadLdMatrix <- function( seed, nSample ) { - result <- if (byRegion) { + loaded <- if (byRegion) { .loadLdFromMeta( source, key, @@ -576,10 +609,11 @@ loadLdMatrix <- function( } else { .loadLdFromIndexed(source, key, returnGenotype) } - result <- .loadLdDedup(result) - result <- .ldApplyMonomorphic(result, dropMonomorphic) - result <- .ldApplySubsample(result, maxVariants, seed, key) - .ldApplyMaterialize(result, materializeGenotypes) + loaded |> + .loadLdDedup() |> + .ldApplyMonomorphic(dropMonomorphic) |> + .ldApplySubsample(maxVariants, seed, key) |> + .ldApplyMaterialize(materializeGenotypes) } # Coordinate-free sources, addressed by block index: an `ldInfo` table (the @@ -659,16 +693,16 @@ loadLdMatrix <- function( # identity comes from the dimnames when present. # @noRd .ldDataFromMatrix <- function(mat, isGenotype) { - ids <- if (isGenotype) colnames(mat) else rownames(mat) n <- if (isGenotype) ncol(mat) else nrow(mat) - if (is.null(ids)) { - ids <- str_c("v", seq_len(n)) - } - gr <- GRanges( - seqnames = rep("chrNA", n), - ranges = IRanges::IRanges(start = seq_len(n), width = 1L) + named <- if (isGenotype) colnames(mat) else rownames(mat) + ids <- named %||% str_c("v", seq_len(n)) + gr <- S4Vectors::`mcols<-`( + GRanges( + seqnames = rep("chrNA", n), + ranges = IRanges::IRanges(start = seq_len(n), width = 1L) + ), + value = S4Vectors::DataFrame(variant_id = ids) ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(variant_id = ids) LdData( correlation = if (isGenotype) NULL else mat, genotypeHandle = if (isGenotype) mat else NULL, @@ -736,20 +770,23 @@ loadLdMatrix <- function( # genotypes consistent with the ranges. # @noRd .ldSubsetData <- function(ld, idx) { - R <- ld@correlation - if (!is.null(R) && is.matrix(R)) { - R <- R[idx, idx, drop = FALSE] + full <- ld@correlation + R <- if (!is.null(full) && is.matrix(full)) { + full[idx, idx, drop = FALSE] + } else { + full } - gh <- ld@genotypeHandle - if (is.matrix(gh)) { - gh <- gh[, idx, drop = FALSE] - } else if (!is.null(ld@snpIdx)) { - ld@snpIdx <- ld@snpIdx[idx] + raw <- ld@genotypeHandle + gh <- if (is.matrix(raw)) raw[, idx, drop = FALSE] else raw + snpIdx <- if (is.matrix(raw) || is.null(ld@snpIdx)) { + ld@snpIdx + } else { + ld@snpIdx[idx] } LdData( correlation = R, genotypeHandle = gh, - snpIdx = if (is.matrix(gh)) NULL else ld@snpIdx, + snpIdx = if (is.matrix(gh)) NULL else snpIdx, variants = getVariantInfo(ld)[idx], blockMetadata = getBlockMetadata(ld), nRef = getNRef(ld) @@ -842,10 +879,12 @@ isGenotypeSource <- function(path) { #' @importFrom vroom vroom #' @noRd # Read + validate the first row of an LD metadata TSV (>=4 columns). +#' @importFrom checkmate checkFileExists .resolveLdReadMeta <- function(path) { - if (!file.exists(path)) { + res <- checkFileExists(path, access = "r") + if (!isTRUE(res)) { msg <- glue( - "LD metadata file not found: {path}", + "LD metadata file: {res}", "\n Expected: a TSV file with columns chrom, start, end, path.", .trim = FALSE ) @@ -859,8 +898,10 @@ isGenotypeSource <- function(path) { ) abort(msg) } - colnames(meta)[seq_len(4)] <- c("chrom", "start", "end", "path") - meta + `colnames<-`( + meta, + replace(colnames(meta), seq_len(4), c("chrom", "start", "end", "path")) + ) } # Genotype source descriptor for the resolved path, or NULL if pre-computed. @@ -914,9 +955,9 @@ resolveLdSource <- function(path) { #' @noRd 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 <- canonChrom(meta$chrom) + meta <- as.data.frame(vroom(metaPath, show_col_types = FALSE)) |> + `colnames<-`(c("chrom", "start", "end", "path")) |> + mutate(chrom = canonChrom(.data$chrom)) queryChrom <- canonChrom(parsed$chrom) matching <- meta[meta$chrom == queryChrom, , drop = FALSE] @@ -946,10 +987,10 @@ resolveGenotypePathForRegion <- function(metaPath, region) { genotypePath, nSample ) { - refPanel <- parseVariantId(variantIds) - refPanel$variant_id <- variantIds afreq <- readAfreq(genotypePath) - if (!is.null(afreq)) { + alleleFreq <- if (is.null(afreq)) { + colMeans(X, na.rm = TRUE) / 2 + } else { freqMatch <- match(variantInfo$id, afreq$id) nUnmatched <- sum(is.na(freqMatch)) if (nUnmatched > 0) { @@ -960,16 +1001,27 @@ resolveGenotypePathForRegion <- function(metaPath, region) { ) warn(msg) } - refPanel$allele_freq <- afreq$alt_freq[freqMatch] - } else { - refPanel$allele_freq <- colMeans(X, na.rm = TRUE) / 2 + afreq$alt_freq[freqMatch] } - if (!is.null(nSample)) { - p <- refPanel$allele_freq - refPanel$variance <- 2 * p * (1 - p) * nSample / (nSample - 1) - refPanel$n_nomiss <- nSample + mutate( + parseVariantId(variantIds), + variant_id = variantIds, + allele_freq = alleleFreq, + !!!.ldPanelSampleCols(alleleFreq, nSample) + ) +} + +# The panel's per-variant variance / non-missing count, which are only +# derivable once the caller declares the sample size behind the frequencies. +# @noRd +.ldPanelSampleCols <- function(p, nSample) { + if (is.null(nSample)) { + return(list()) } - refPanel + list( + variance = 2 * p * (1 - p) * nSample / (nSample - 1), + n_nomiss = nSample + ) } # Single-block metadata spanning the loaded region. @@ -1017,7 +1069,6 @@ loadLdFromGenotype <- function( region = region, returnVariantInfo = TRUE ) - X <- result$X variantInfo <- result$variant_info variantIds <- normalizeVariantId(formatVariantId( variantInfo$chrom, @@ -1025,7 +1076,7 @@ loadLdFromGenotype <- function( variantInfo$A2, variantInfo$A1 )) - colnames(X) <- variantIds + X <- `colnames<-`(result$X, variantIds) refPanel <- .loadLdGtRefPanel( X, variantInfo, @@ -1368,14 +1419,16 @@ loadLdFromGenotype <- function( # the caller's frame exactly as `.cbFlipPairToCanonical()` does: # LD_ij -> sign_i * sign_j * LD_ij. A no-op on a harmonized panel, where # every sign is +1. - if (any(matched$sign < 0)) { - ldMat <- ldMat * outer(matched$sign, matched$sign) + signed <- if (any(matched$sign < 0)) { + ldMat * outer(matched$sign, matched$sign) + } else { + ldMat } - dimnames(ldMat) <- list(matched$keptIds, matched$keptIds) + named <- `dimnames<-`(signed, list(matched$keptIds, matched$keptIds)) if (onMissing == "drop") { - attr(ldMat, "keptVariantIds") <- matched$keptIds + return(`attr<-`(named, "keptVariantIds", matched$keptIds)) } - ldMat + named } # ---------- LD sketch: per-variant panel statistics and filtering ---------- @@ -1432,8 +1485,9 @@ loadLdFromGenotype <- function( # not carry them. A malformed sidecar must not take the whole filter down, so # it degrades to "no frequencies here" and the caller falls back to dosage. # @noRd +#' @importFrom rlang try_fetch .panelAfreqTable <- function(prefix) { - af <- tryCatch(readAfreq(prefix), error = function(e) NULL) + af <- try_fetch(readAfreq(prefix), error = function(cnd) NULL) if (is.null(af) || !all(is_in(c("id", "alt_freq"), colnames(af)))) { return(NULL) } @@ -1572,10 +1626,10 @@ loadLdFromGenotype <- function( # The panel-filter cutoffs a pipeline call carries, or NULL when none is set # (so the filter short-circuits without touching the panel). # @noRd -.panelCutoffs <- function(p) { - maf <- p$mafCutoff %||% 0 - mac <- p$macCutoff %||% 0 - imiss <- p$imissCutoff %||% 1 +.panelCutoffs <- function(mafCutoff = 0, macCutoff = 0, imissCutoff = 1) { + maf <- mafCutoff %||% 0 + mac <- macCutoff %||% 0 + imiss <- imissCutoff %||% 1 if (maf <= 0 && mac <= 0 && imiss >= 1) { return(NULL) } @@ -1673,10 +1727,10 @@ loadLdFromGenotype <- function( } # str_c propagates NA, which would make a variant with an unknown allele # match nothing on either side; an empty field keeps it comparable. - a1 <- as.character(mc$A1) - a2 <- as.character(mc$A2) - a1 <- if_else(is.na(a1), "", a1) - a2 <- if_else(is.na(a2), "", a2) + rawA1 <- as.character(mc$A1) + rawA2 <- as.character(mc$A2) + a1 <- if_else(is.na(rawA1), "", rawA1) + a2 <- if_else(is.na(rawA2), "", rawA2) str_c(stem, ":", if_else(a1 < a2, a1, a2), ":", if_else(a1 < a2, a2, a1)) } @@ -1935,30 +1989,46 @@ standardizeGenotypeHwe <- function(X, alleleFreq) { # Build the reference panel: variant ids + merged per-variant annotations, # deriving variance from nSample + allele_freq when it is otherwise absent. +# One annotation column aligned to the panel's variant order. +# @noRd +.ldAnnotationColumn <- function(col, mergedVariantList, ids) { + mergedVariantList[[col]][match(ids, mergedVariantList$variants)] +} + .loadLdRefPanel <- function(ldMatrix, extractedLdVariantsList, nSample) { - refPanel <- parseVariantId(rownames(ldMatrix)) - mergedVariantList <- bind_rows(extractedLdVariantsList) ids <- rownames(ldMatrix) - refPanel$variant_id <- ids - for (col in c("allele_freq", "variance", "n_nomiss")) { - if (is_in(col, colnames(mergedVariantList))) { - refPanel[[col]] <- mergedVariantList[[col]][ - match(ids, mergedVariantList$variants) - ] - } - } - needVar <- !is_in("variance", colnames(refPanel)) || - all(is.na(refPanel$variance)) + mergedVariantList <- bind_rows(extractedLdVariantsList) + annotations <- intersect( + c("allele_freq", "variance", "n_nomiss"), + colnames(mergedVariantList) + ) + panel <- mutate( + parseVariantId(ids), + variant_id = ids, + !!!set_names( + map( + annotations, + .ldAnnotationColumn, + mergedVariantList = mergedVariantList, + ids = ids + ), + annotations + ) + ) + needVar <- !is_in("variance", colnames(panel)) || all(is.na(panel$variance)) if ( - !is.null(nSample) && - needVar && - is_in("allele_freq", colnames(refPanel)) + is.null(nSample) || + !needVar || + !is_in("allele_freq", colnames(panel)) ) { - p <- refPanel$allele_freq - refPanel$variance <- 2 * p * (1 - p) * nSample / (nSample - 1) - refPanel$n_nomiss <- nSample + return(panel) } - refPanel + p <- panel$allele_freq + mutate( + panel, + variance = 2 * p * (1 - p) * nSample / (nSample - 1), + n_nomiss = nSample + ) } loadLdFromBlocks <- function( @@ -2017,11 +2087,14 @@ loadLdFromBlocks <- function( #' variantIds = c("chr22:16050000:A:G", "chr22:17000000:C:T"), #' ldReferenceMetaFile = meta) #' @export +#' @importFrom checkmate assertCharacter assertFlag filterVariantsByLdReference <- function( variantIds, ldReferenceMetaFile, keepIndel = TRUE ) { + assertCharacter(variantIds, any.missing = FALSE) + assertFlag(keepIndel) variantsDf <- parseVariantId(variantIds) # Derive region to scope the reference lookup @@ -2035,11 +2108,11 @@ filterVariantsByLdReference <- function( refKey <- str_c(refChrom, ":", refInfo$pos) variantKey <- str_c(variantsDf$chrom, ":", variantsDf$pos) - keepIndices <- which(is_in(variantKey, refKey)) - - if (!keepIndel) { - snpIdx <- which(isSnpAlleles(variantsDf$A1, variantsDf$A2)) - keepIndices <- intersect(keepIndices, snpIdx) + inRef <- which(is_in(variantKey, refKey)) + keepIndices <- if (keepIndel) { + inRef + } else { + intersect(inRef, which(isSnpAlleles(variantsDf$A1, variantsDf$A2))) } nDropped <- length(variantIds) - length(keepIndices) @@ -2091,14 +2164,9 @@ filterVariantsByLdReference <- function( ) { abort("Empty or NULL LD matrix provided.") } - if ( - is.null(rownames(combinedMatrix)) || - is.null(colnames(combinedMatrix)) || - !identical(rownames(combinedMatrix), variantIds) || - !identical(colnames(combinedMatrix), variantIds) - ) { - rownames(combinedMatrix) <- variantIds - colnames(combinedMatrix) <- variantIds + wanted <- list(variantIds, variantIds) + if (!identical(dimnames(combinedMatrix), wanted)) { + return(`dimnames<-`(combinedMatrix, wanted)) } combinedMatrix } @@ -2125,60 +2193,94 @@ filterVariantsByLdReference <- function( "out-of-range indices." ) inform(msg) - blockMetadata <- filter(blockMetadata, validBlocks) - blockMetadata$blockId <- seq_len(nrow(blockMetadata)) + kept <- filter(blockMetadata, validBlocks) + return(mutate(kept, blockId = seq_len(nrow(kept)))) } blockMetadata } +#' @importFrom checkmate assertClass partitionLdMatrix <- function( ldData, mergeSmallBlocks = TRUE, minMergedBlockSize = 500, maxMergedBlockSize = 10000 ) { - if (!is(ldData, "LdData")) { - abort("ldData must be an LdData object") - } - combinedMatrix <- getCorrelation(ldData) - blockMetadata <- getBlockMetadata(ldData) - if (is(blockMetadata, "GRanges")) { - blockMetadata <- as_tibble(blockMetadata) - } + assertClass(ldData, "LdData") variantIds <- getVariantIds(ldData) - combinedMatrix <- .partitionValidateMatrix(combinedMatrix, variantIds) - blockMetadata <- .partitionFilterBlocks(blockMetadata, length(variantIds)) + combinedMatrix <- .partitionValidateMatrix( + getCorrelation(ldData), + variantIds + ) + rawBlocks <- getBlockMetadata(ldData) + blocks <- .partitionFilterBlocks( + if (is(rawBlocks, "GRanges")) as_tibble(rawBlocks) else rawBlocks, + length(variantIds) + ) # Validate the block structure of the matrix (skip if only one block). - if (nrow(blockMetadata) > 1) { - validateBlockStructure(combinedMatrix, blockMetadata, variantIds) - } - if ( - mergeSmallBlocks && - any(blockMetadata$size < minMergedBlockSize) && - nrow(blockMetadata) > 1 - ) { - blockMetadata <- mergeBlocks( - blockMetadata, - minMergedBlockSize, - maxMergedBlockSize - ) + if (nrow(blocks) > 1) { + validateBlockStructure(combinedMatrix, blocks, variantIds) + } + merging <- mergeSmallBlocks && + any(blocks$size < minMergedBlockSize) && + nrow(blocks) > 1 + blockMetadata <- if (merging) { + mergeBlocks(blocks, minMergedBlockSize, maxMergedBlockSize) + } else { + blocks } extractBlockMatrices(combinedMatrix, blockMetadata, variantIds) } +# Every (i, j) block pair with i < j. +# @noRd +.ldUpperPairs <- function(nBlocks) { + grid <- expand.grid(i = seq_len(nBlocks), j = seq_len(nBlocks)) + grid[grid$i < grid$j, , drop = FALSE] +} + +# @noRd +.blockPairMessagesAt <- function( + k, + pairs, + blockMetadata, + matrix, + variantIds, + n +) { + .blockPairMessages( + pairs$i[[k]], + pairs$j[[k]], + blockMetadata, + matrix, + variantIds, + n + ) +} + +# Concatenate per-item message vectors, empty-safe. +# @noRd +.ldConcatChr <- function(pieces) { + if (length(pieces) == 0L) { + return(character(0)) + } + as.character(list_c(pieces)) +} + #' Validate that cross-block entries are zero (excluding boundary variants). #' @noRd validateBlockStructure <- function(matrix, blockMetadata, variantIds) { - msgs <- character(0) n <- length(variantIds) - for (i in seq_len(nrow(blockMetadata) - 1)) { - for (j in (i + 1):nrow(blockMetadata)) { - msgs <- c( - msgs, - .blockPairMessages(i, j, blockMetadata, matrix, variantIds, n) - ) - } - } + pairs <- .ldUpperPairs(nrow(blockMetadata)) + msgs <- .ldConcatChr(map( + seq_len(nrow(pairs)), + .blockPairMessagesAt, + pairs = pairs, + blockMetadata = blockMetadata, + matrix = matrix, + variantIds = variantIds, + n = n + )) if (length(msgs) > 0) { msgList <- str_flatten(msgs, collapse = "\n") msg <- glue( @@ -2240,47 +2342,60 @@ mergeTwoBlocks <- function(blockMetadata, idx1, idx2) { idx1 <- idx2 idx2 <- tmp } - result <- blockMetadata - result$endIdx[idx1] <- blockMetadata$endIdx[idx2] - result$size[idx1] <- blockMetadata$size[idx1] + blockMetadata$size[idx2] - result <- slice(result, -idx2) - result$blockId <- seq_len(nrow(result)) - result + merged <- mutate( + blockMetadata, + endIdx = replace(.data$endIdx, idx1, blockMetadata$endIdx[idx2]), + size = replace( + .data$size, + idx1, + blockMetadata$size[idx1] + blockMetadata$size[idx2] + ) + ) |> + slice(-idx2) + mutate(merged, blockId = seq_len(nrow(merged))) } #' Find blocks below minSize and identify the best neighbor to merge with. #' @noRd findMergeCandidates <- function(blockMetadata, minSize, maxSize) { - candidates <- tibble( - block_idx = integer(), - merge_with = integer() - ) - for (i in seq_len(nrow(blockMetadata))) { - if (blockMetadata$size[i] >= minSize) { - next - } - prevOk <- i > 1 && canMerge(blockMetadata, i, i - 1, maxSize) - nextOk <- i < nrow(blockMetadata) && - canMerge(blockMetadata, i, i + 1, maxSize) - mergeWith <- if (prevOk && nextOk) { - if (blockMetadata$size[i - 1] <= blockMetadata$size[i + 1]) { - i - 1 - } else { - i + 1 - } - } else if (prevOk) { + found <- compact(map( + seq_len(nrow(blockMetadata)), + .ldMergeCandidateFor, + blockMetadata = blockMetadata, + minSize = minSize, + maxSize = maxSize + )) + if (length(found) == 0L) { + return(tibble(block_idx = integer(), merge_with = integer())) + } + bind_rows(found) +} + +# Which neighbour block `i` should merge into (the smaller one when both +# qualify), or NULL when it is big enough already or neither neighbour can +# take it. +# @noRd +.ldMergeCandidateFor <- function(i, blockMetadata, minSize, maxSize) { + if (blockMetadata$size[i] >= minSize) { + return(NULL) + } + prevOk <- i > 1 && canMerge(blockMetadata, i, i - 1, maxSize) + nextOk <- i < nrow(blockMetadata) && + canMerge(blockMetadata, i, i + 1, maxSize) + mergeWith <- if (prevOk && nextOk) { + if (blockMetadata$size[i - 1] <= blockMetadata$size[i + 1]) { i - 1 - } else if (nextOk) { - i + 1 } else { - next + i + 1 } - candidates <- bind_rows( - candidates, - tibble(block_idx = i, merge_with = mergeWith) - ) + } else if (prevOk) { + i - 1 + } else if (nextOk) { + i + 1 + } else { + return(NULL) } - candidates + tibble(block_idx = i, merge_with = mergeWith) } #' Iteratively merge blocks below minSize with their smallest neighbor. @@ -2289,18 +2404,21 @@ mergeBlocks <- function(blockMetadata, minSize, maxSize) { if (nrow(blockMetadata) <= 1) { return(blockMetadata) } - repeat { - candidates <- findMergeCandidates(blockMetadata, minSize, maxSize) - if (nrow(candidates) == 0) { - break - } - blockMetadata <- mergeTwoBlocks( + candidates <- findMergeCandidates(blockMetadata, minSize, maxSize) + if (nrow(candidates) == 0) { + return(blockMetadata) + } + # Each merge changes which blocks are still too small, so this is a fixed + # point: recurse on the merged metadata rather than rebinding it. + mergeBlocks( + mergeTwoBlocks( blockMetadata, candidates$block_idx[1], candidates$merge_with[1] - ) - } - blockMetadata + ), + minSize, + maxSize + ) } # Helper function to extract block matrices @@ -2327,34 +2445,79 @@ mergeBlocks <- function(blockMetadata, minSize, maxSize) { ) } -extractBlockMatrices <- function(matrix, blockMetadata, variantIds) { - ldMatrices <- list() - variantMapping <- tibble( - variant_id = character(), - blockId = integer() - ) - for (i in seq_len(nrow(blockMetadata))) { - block <- .extractOneBlock( - matrix, - variantIds, - blockMetadata$startIdx[i], - blockMetadata$endIdx[i], - i - ) - if (is.null(block)) { - next - } - ldMatrices[[i]] <- block$matrix - variantMapping <- bind_rows(variantMapping, block$mapping) +# @noRd +.ldExtractBlockAt <- function(i, matrix, variantIds, blockMetadata) { + .extractOneBlock( + matrix, + variantIds, + blockMetadata$startIdx[i], + blockMetadata$endIdx[i], + i + ) +} + +# `x[[i]] <- v` in a loop never extends past the last assigned position, so +# trailing skipped blocks leave no entry at all. +# @noRd +.ldTrimTrailingNull <- function(xs) { + filled <- which(!map_lgl(xs, is.null)) + if (length(filled) == 0L) { + return(list()) } + xs[seq_len(max(filled))] +} + +extractBlockMatrices <- function(matrix, blockMetadata, variantIds) { + blocks <- map( + seq_len(nrow(blockMetadata)), + .ldExtractBlockAt, + matrix = matrix, + variantIds = variantIds, + blockMetadata = blockMetadata + ) + kept <- compact(blocks) + mappings <- map(kept, "mapping") list( - ldMatrices = ldMatrices, - variantIndices = variantMapping, + # A skipped block leaves a hole, as `ldMatrices[[i]] <- ...` did: + # positions stay aligned with blockMetadata rows. + ldMatrices = .ldTrimTrailingNull(map(blocks, "matrix")), + variantIndices = if (length(mappings) == 0L) { + tibble(variant_id = character(), blockId = integer()) + } else { + bind_rows(mappings) + }, blockMetadata = blockMetadata ) } +# The PSD repair `method` asks for, or the matrix unchanged when it is +# already positive definite. Returns list(R, methodApplied). +# @noRd +.checkLdRepair <- function(R, eig, vals, method, isPd, shrinkage, p, rTol) { + if (isPd) { + return(list(R = R, methodApplied = "none")) + } + if (method == "shrink") { + return(list( + R = (1 - shrinkage) * R + shrinkage * diag(p), + methodApplied = "shrink" + )) + } + if (method != "eigenfix") { + return(list(R = R, methodApplied = "none")) + } + # Negative eigenvalues raised to a small POSITIVE value, not zero: rTol + # makes the result strictly positive definite, which the Cholesky-based + # methods (PRS-CS, SDPR) require; exactly zero would be PSD but not PD. + rebuilt <- eig$vectors %*% diag(pmax(vals, rTol)) %*% t(eig$vectors) + # Restore exact symmetry and unit diagonal. + list( + R = `diag<-`((rebuilt + t(rebuilt)) / 2, 1), + methodApplied = "eigenfix" + ) +} + #' Check and optionally repair LD matrix quality #' #' Diagnoses positive-definiteness of an LD correlation matrix and optionally @@ -2430,24 +2593,9 @@ checkLd <- function( isPsd <- !any(vals < -rTol) isPd <- all(vals > rTol) - methodApplied <- "none" - Rout <- R - - if (method == "shrink" && !isPd) { - Rout <- (1 - shrinkage) * R + shrinkage * diag(p) - methodApplied <- "shrink" - } else if (method == "eigenfix" && !isPd) { - # Set negative eigenvalues to a small positive value and reconstruct. - # Using rTol (not zero) ensures the result is strictly positive - # definite, which is required by methods that use Cholesky decomposition - # (PRS-CS, SDPR). Setting to exactly zero would produce PSD but not PD. - valsFixed <- pmax(vals, rTol) - Rout <- eig$vectors %*% diag(valsFixed) %*% t(eig$vectors) - # Restore exact symmetry and unit diagonal - Rout <- (Rout + t(Rout)) / 2 - diag(Rout) <- 1 - methodApplied <- "eigenfix" - } + fixed <- .checkLdRepair(R, eig, vals, method, isPd, shrinkage, p, rTol) + Rout <- fixed$R + methodApplied <- fixed$methodApplied list( R = Rout, @@ -2471,18 +2619,16 @@ checkLd <- function( Sigma.distance <- as.dist(1 - abs(cor.X)) fit <- hclust(Sigma.distance, method = "single") clusters <- cutree(fit, h = 1 - corThres) - ind.delete <- NULL - for (ig in unique(clusters)) { - temp.group <- which(clusters == ig) - if (length(temp.group) > 1) { - ind.delete <- c(ind.delete, temp.group[-1]) - } - } - ind.delete <- unique(ind.delete) + # Keep the first member of each cluster and drop the rest -- which is + # exactly the entries that repeat a cluster already seen. + ind.delete <- which(duplicated(clusters)) X.new <- X filter.id <- seq_len(p) if (length(ind.delete) > 0) { - X.new <- as.matrix(X[, -ind.delete]) + # drop = FALSE keeps the column names when a single column survives; + # without it the result degrades to a vector and the names have to be + # recomputed by index arithmetic afterwards. + X.new <- as.matrix(X[, -ind.delete, drop = FALSE]) filter.id <- filter.id[-ind.delete] if (verbose) { nDel <- length(ind.delete) @@ -2498,9 +2644,6 @@ checkLd <- function( ) inform(msg) } - if (ncol(X.new) == 1) { - colnames(X.new) <- colnames(X)[-ind.delete] - } list(X.new = X.new, filter.id = filter.id) } @@ -2575,8 +2718,7 @@ ldPruneByCorrelation <- function( # Write X (rounded to integer genotype codes) to a temporary GDS for SNPRelate. .ldPruneSnprelateCreateGds <- function(tmpGds, X, snpNames, p) { - genoInt <- round(X) - storage.mode(genoInt) <- "integer" + genoInt <- `storage.mode<-`(round(X), "integer") SNPRelate::snpgdsCreateGeno( gds.fn = tmpGds, genmat = t(genoInt), @@ -2604,7 +2746,7 @@ ldPruneByCorrelation <- function( ld.threshold = corThres, verbose = verbose ) - keepIds <- sort(unlist(keepList, use.names = FALSE)) + keepIds <- sort(unname(list_c(keepList))) X.new <- X[, keepIds, drop = FALSE] if (verbose) { nKept <- length(keepIds) @@ -2655,29 +2797,29 @@ ldPruneByCorrelation <- function( #' @noRd # Correlation strategy: drop the most-connected column (random tie-break at 2). .dropCollinearPickCor <- function(X, problematicCols, verbose, seed = NULL) { - corMatrix <- abs(cor(X[, problematicCols, drop = FALSE])) - diag(corMatrix) <- 0 + corMatrix <- `diag<-`( + abs(cor(X[, problematicCols, drop = FALSE])), + 0 + ) if (length(problematicCols) == 2) { if (!is.null(seed)) { withr::local_seed(seed) } colToRemove <- sample(problematicCols, 1) if (verbose) { - msg <- glue( + inform(glue( "dropCollinearColumns: two candidates, randomly removing ", "{colToRemove}" - ) - inform(msg) + )) } return(colToRemove) } colToRemove <- problematicCols[which.max(colSums(corMatrix))] if (verbose) { - msg <- glue( + inform(glue( "dropCollinearColumns: highest sum |cor| -> removing ", "{colToRemove}" - ) - inform(msg) + )) } colToRemove } @@ -2695,11 +2837,10 @@ ldPruneByCorrelation <- function( variances <- apply(X[, problematicCols, drop = FALSE], 2, var) colToRemove <- problematicCols[which.min(variances)] if (verbose) { - msg <- glue( + inform(glue( "dropCollinearColumns: smallest variance -> removing ", "{colToRemove}" - ) - inform(msg) + )) } return(colToRemove) } @@ -2707,11 +2848,10 @@ ldPruneByCorrelation <- function( return(.dropCollinearPickCor(X, problematicCols, verbose, seed = seed)) } if (is.null(response)) { - msg <- glue( + abort(glue( "response must be supplied for strategy = ", "'responseCorrelation'" - ) - abort(msg) + )) } corWithResponse <- apply( X[, problematicCols, drop = FALSE], @@ -2721,11 +2861,10 @@ ldPruneByCorrelation <- function( ) colToRemove <- problematicCols[which.min(abs(corWithResponse))] if (verbose) { - msg <- glue( + inform(glue( "dropCollinearColumns: smallest |cor| with response -> ", "removing {colToRemove}" - ) - inform(msg) + )) } colToRemove } @@ -2767,8 +2906,14 @@ dropCollinearColumns <- function( # @noRd .ldBuildDesign <- function(X, C) { XD <- cbind(1, X, C) - colnames(XD)[seq_len(ncol(X) + 1L)] <- c("Intercept", colnames(X)) - XD + `colnames<-`( + XD, + replace( + colnames(XD), + seq_len(ncol(X) + 1L), + c("Intercept", colnames(X)) + ) + ) } # --- enforceDesignFullRank helpers ------------------------------------------ @@ -2799,20 +2944,18 @@ dropCollinearColumns <- function( if (qr(tempDesign)$rank == ncol(tempDesign)) { if (verbose) { nCol <- length(problematicColnames) - msg <- glue( + inform(glue( "enforceDesignFullRank: full rank after batch-removing ", "{nCol} column(s)" - ) - inform(msg) + )) } return(FALSE) } if (verbose) { - msg <- glue( + inform(glue( "enforceDesignFullRank: batch removal insufficient, ", "skipping to correlation-pruning fallback" - ) - inform(msg) + )) } TRUE } @@ -2827,6 +2970,9 @@ dropCollinearColumns <- function( verbose, seed = NULL ) { + # Deliberate iteration: each round drops collinear columns and re-tests + # the rank, and `X` is a samples x variants genotype matrix -- recursing + # would hold every intermediate copy alive on the stack. iteration <- 0L Xdesign <- .ldBuildDesign(X, C) matrixRank <- qr(Xdesign)$rank @@ -2848,19 +2994,17 @@ dropCollinearColumns <- function( iteration <- iteration + 1L if (verbose) { nCol <- ncol(Xdesign) - msg <- glue( + inform(glue( "enforceDesignFullRank: iter {iteration} rank ", "{matrixRank} / {nCol}" - ) - inform(msg) + )) } } if (iteration == maxIterations) { - msg <- glue( + warn(glue( "enforceDesignFullRank: maxIterations reached; design may ", "still be rank-deficient" - ) - warn(msg) + )) } X } @@ -2964,8 +3108,10 @@ enforceDesignFullRank <- function( inform(msg) } skipIterative <- .edfrCheckBatch(X, C, Xdesign, matrixRank, verbose) - if (!skipIterative) { - X <- .edfrIterate( + iterated <- if (skipIterative) { + X + } else { + .edfrIterate( X, C, strategy, @@ -2975,42 +3121,33 @@ enforceDesignFullRank <- function( seed = seed ) } - X <- .edfrCorrelationFallback(X, C, corrThresholds, verbose) - if (ncol(X) == 1L && initialNcol == 1L) { - colnames(X) <- originalColnames + reduced <- .edfrCorrelationFallback(iterated, C, corrThresholds, verbose) + if (ncol(reduced) == 1L && initialNcol == 1L) { + return(`colnames<-`(reduced, originalColnames)) } - X + reduced } # Require the bigsnpr/bigstatsr packages used for score-based LD clumping. .ldClumpCheckDeps <- function() { if (!requireNamespace("bigsnpr", quietly = TRUE)) { - msg <- glue( - "Package 'bigsnpr' is required. Install from CRAN: ", - "install.packages('bigsnpr')" - ) - abort(msg) + abort("Package 'bigsnpr' is required.") } if (!requireNamespace("bigstatsr", quietly = TRUE)) { - msg <- glue( - "Package 'bigstatsr' is required. Install from CRAN: ", - "install.packages('bigstatsr')" - ) - abort(msg) + abort("Package 'bigstatsr' is required.") } } # Validate the clumping inputs (dimensions of score/chr/pos vs X). +#' @importFrom checkmate assertVector .ldClumpValidate <- function(X, score, chr, pos) { + # NOT assertMatrix: X may be a bigstatsr FBM, which is not a base matrix. if (ncol(X) < 1L) { abort("ldClumpByScore: X must have at least one column") } - if (!is.null(score) && length(score) != ncol(X)) { - abort("ldClumpByScore: length(score) must equal ncol(X)") - } - if (length(chr) != ncol(X) || length(pos) != ncol(X)) { - abort("ldClumpByScore: chr and pos must have length equal to ncol(X)") - } + assertVector(score, len = ncol(X), null.ok = TRUE) + assertVector(chr, len = ncol(X)) + assertVector(pos, len = ncol(X)) } # Wrap X as a bigstatsr FBM (pass through if already one). @@ -3113,6 +3250,7 @@ ldClumpByScore <- function( # without materializing them all in memory at once. # ============================================================================= +#' @importFrom checkmate assertClass #' Extract the LD or genotype matrix from an LdData S4 object. #' @param ld An LdData object. #' @param wantGenotype Logical; if TRUE, extract the genotype matrix (via @@ -3120,9 +3258,7 @@ ldClumpByScore <- function( #' @return A matrix. #' @noRd extractLdMatrix <- function(ld, wantGenotype = FALSE) { - if (!is(ld, "LdData")) { - abort("ld must be an LdData object") - } + assertClass(ld, "LdData") if (wantGenotype && hasGenotypes(ld)) { return(getGenotypes(ld)) } @@ -3229,13 +3365,25 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { } # The handle stays here on purpose: the GDS on-disk LD routine reads the # file directly, which is a seed-level operation with no assay equivalent. - R <- .computeBlockLdGds(.ldSketchHandle(X), idx) - diag(R) <- 1.0 - R[is.na(R) | is.nan(R)] <- 0 - if (shrinkage > 0 && shrinkage <= 1) { - R <- (1 - shrinkage) * R + shrinkage * diag(nrow(R)) + R <- .ldCleanCorrelation(.computeBlockLdGds(.ldSketchHandle(X), idx)) + .ldShrinkToIdentity(R, shrinkage) +} + +# A raw estimator output made a usable correlation matrix: unit diagonal and +# no NA / NaN cells. +# @noRd +.ldCleanCorrelation <- function(R) { + unitDiag <- `diag<-`(R, 1.0) + replace(unitDiag, is.na(unitDiag) | is.nan(unitDiag), 0) +} + +# Optional shrinkage toward the identity (lassosum, Mak et al 2017). +# @noRd +.ldShrinkToIdentity <- function(R, shrinkage) { + if (shrinkage <= 0 || shrinkage > 1) { + return(R) } - R + (1 - shrinkage) * R + shrinkage * diag(nrow(R)) } # --- computeLd method helpers ----------------------------------------------- @@ -3260,12 +3408,7 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { } # internal backend: Rfast::cora if available, else base cor(). Mean-impute # only when NAs exist (PLINK2 data typically has none). - X_imp <- X - if (anyNA(X_imp)) { - colMeansX <- colMeans(X_imp, na.rm = TRUE) - naPos <- which(is.na(X_imp), arr.ind = TRUE) - X_imp[naPos] <- colMeansX[naPos[, 2]] - } + X_imp <- if (anyNA(X)) .ldMeanImputeColumns(X) else X if (requireNamespace("Rfast", quietly = TRUE)) { # large=FALSE uses tcrossprod internally, ~40x faster than large=TRUE. Rfast::cora(X_imp, large = FALSE) @@ -3274,6 +3417,14 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { } } +# Every missing cell replaced by its column mean. +# @noRd +.ldMeanImputeColumns <- function(X) { + colMeansX <- colMeans(X, na.rm = TRUE) + naPos <- which(is.na(X), arr.ind = TRUE) + replace(X, naPos, colMeansX[naPos[, 2]]) +} + # Population variance (N denominator, GCTA-style; missing set to column mean 0). .computeLdPopulation <- function(X, trimSamples) { if (trimSamples) { @@ -3299,8 +3450,9 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { warn(msg) } } - X_c <- sweep(X, 2, colMeansX) - X_c[is.na(X_c)] <- 0 + # Centering keeps the NA pattern (colMeansX is finite wherever a column + # has data), so a missing cell contributes nothing to the crossprod. + X_c <- replace(sweep(X, 2, colMeansX), is.na(X), 0) covMat <- crossprod(X_c) / N sdVec <- sqrt(colVarsX) covMat / outer(sdVec, sdVec) @@ -3310,8 +3462,7 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { # tracks per-pair non-missing counts and applies a correction term. .gctaCovariance <- function(X, colMeansX, N, p) { notNa <- !is.na(X) - X_zero <- X - X_zero[is.na(X_zero)] <- 0 + X_zero <- replace(X, !notNa, 0) pairCounts <- crossprod(notNa * 1.0) # E_i2[i,j] = pairSums[i,j] / N: mean of SNP i over samples where j is # observed; p x p, row i col j = sum of X_i where j non-missing, / N. @@ -3339,10 +3490,10 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { covMat <- .gctaCovariance(X, colMeansX, N, p) sdVec <- sqrt(colVarsX) sdOuter <- outer(sdVec, sdVec) - R <- matrix(0.001, p, p) + # A zero-variance pair has no defined correlation; it keeps the 0.001 + # floor GCTA writes there. valid <- sdOuter > 0 - R[valid] <- covMat[valid] / sdOuter[valid] - R + replace(matrix(0.001, p, p), valid, covMat[valid] / sdOuter[valid]) } #' @title Compute an LD Correlation Matrix @@ -3433,23 +3584,17 @@ computeLd <- function( # @noRd .computeLdMatrix <- function(X, method, backend, trimSamples, shrinkage) { nms <- colnames(X) - if (method == "sample") { - R <- .computeLdSample(X, backend) + raw <- if (method == "sample") { + .computeLdSample(X, backend) } else if (method == "population") { .computeLdRequireInternal(backend) - R <- .computeLdPopulation(X, trimSamples) + .computeLdPopulation(X, trimSamples) } else { .computeLdRequireInternal(backend) - R <- .computeLdGcta(X, trimSamples) - } - diag(R) <- 1.0 - R[is.na(R) | is.nan(R)] <- 0 - # Optional shrinkage toward identity (lassosum, Mak et al 2017). - if (shrinkage > 0 && shrinkage <= 1) { - R <- (1 - shrinkage) * R + shrinkage * diag(nrow(R)) + .computeLdGcta(X, trimSamples) } - colnames(R) <- rownames(R) <- nms - R + R <- .ldShrinkToIdentity(.ldCleanCorrelation(raw), shrinkage) + `dimnames<-`(R, list(nms, nms)) } #' Compute LD via SNPRelate (creates a temporary GDS file from the dosage @@ -3469,9 +3614,8 @@ computeLd <- function( on.exit(unlink(tmpGds), add = TRUE) # Round to integer dosage for GDS (0/1/2) - X_int <- round(X) - storage.mode(X_int) <- "integer" - X_int[is.na(X_int)] <- 3L # GDS missing code + # 3L is the GDS missing code. + X_int <- replace(`storage.mode<-`(round(X), "integer"), is.na(X), 3L) snpIds <- colnames(X) %||% seq_len(ncol(X)) sampleIds <- rownames(X) %||% seq_len(nrow(X)) @@ -3509,17 +3653,13 @@ computeLd <- function( # snpStats expects counts of the B allele as raw codes: 1=AA, 2=AB, 3=BB, # 0=NA pecotmr dosage is ALT count (0/1/2), so map: 0->1, 1->2, 2->3, NA->0 - X_raw <- round(X) + 1L - X_raw[is.na(X) | X_raw < 1L] <- 0L - X_raw[X_raw > 3L] <- 3L - storage.mode(X_raw) <- "raw" - sm <- new("SnpMatrix", X_raw) + shifted <- round(X) + 1L + coded <- pmin(replace(shifted, is.na(X) | shifted < 1L, 0L), 3L) + sm <- new("SnpMatrix", `storage.mode<-`(coded, "raw")) - R <- as.matrix(snpStats::ld(sm, stats = "R", depth = ncol(X) - 1L)) + raw <- as.matrix(snpStats::ld(sm, stats = "R", depth = ncol(X) - 1L)) # snpStats::ld returns a sparse-like matrix; ensure full dense - R[is.na(R)] <- 0 - diag(R) <- 1 - R + .ldCleanCorrelation(raw) } # ---- map/apply helpers (lambda-free callbacks) --------------------------- diff --git a/R/manifestLoaders.R b/R/manifestLoaders.R index 5f9330f7..c6cd05e5 100644 --- a/R/manifestLoaders.R +++ b/R/manifestLoaders.R @@ -30,17 +30,14 @@ NULL # Read a manifest into a tibble. A data.frame/tibble is passed through; a # single path is read by extension (.csv -> read_csv, else read_tsv). +#' @importFrom checkmate assertString +#' @importFrom checkmate assertFileExists .readManifest <- function(manifest) { if (is.data.frame(manifest)) { return(as_tibble(manifest, .name_repair = "minimal")) } - if (!is.character(manifest) || length(manifest) != 1L) { - abort("`manifest` must be a data.frame or a single file path.") - } - if (!file.exists(manifest)) { - msg <- glue("manifest file not found: {manifest}") - abort(msg) - } + assertString(manifest, .var.name = "manifest (data.frame or file path)") + assertFileExists(manifest, access = "r", .var.name = "manifest file") if (str_detect(manifest, regex("\\.csv$", ignore_case = TRUE))) { readr::read_csv(manifest, show_col_types = FALSE, progress = FALSE) } else { @@ -77,24 +74,62 @@ NULL # `required` canonical columns are present. `aliases` is a named list keyed by # canonical name; each value is the character vector of accepted source names # (including the canonical name itself). The first alias present wins. -.canonManifestCols <- function(df, aliases, required, label) { - for (canon in names(aliases)) { - if (is_in(canon, names(df))) { - next - } - hit <- intersect(aliases[[canon]], names(df)) - if (length(hit) >= 1L) { - names(df)[match(hit[[1L]], names(df))] <- canon - } +# The QtlDataset pass-through arguments, asserted at the loader so a bad value +# is reported against the argument the caller passed rather than surfacing from +# QtlDataset's validity several hundred lines later. Types match +# .qtlValidateScalars exactly, so this tightens nothing. +# @noRd +#' @importFrom checkmate assertLogical assertNumber assertFlag assertCharacter +.assertQtlPassThrough <- function( + scaleResiduals, + mafCutoff, + macCutoff, + xvarCutoff, + imissCutoff, + keepSamples, + keepVariants, + keepIndel +) { + assertLogical(scaleResiduals, len = 1L) + assertNumber(mafCutoff, lower = 0, finite = TRUE) + assertNumber(macCutoff, lower = 0, finite = TRUE) + assertNumber(xvarCutoff, lower = 0, finite = TRUE) + assertNumber(imissCutoff, lower = 0, finite = TRUE) + assertCharacter(keepSamples) + assertCharacter(keepVariants) + assertFlag(keepIndel) + invisible(NULL) +} + +#' @importFrom checkmate assertNames +# The existing column an alias set points at, or NULL when the canonical name +# is already present or nothing matches. +# @noRd +.manifestAliasHit <- function(canon, aliases, df) { + if (is_in(canon, names(df))) { + return(NULL) } - missingCols <- setdiff(required, names(df)) - if (length(missingCols) > 0L) { - msg <- glue( - "{label} manifest is missing required column(s): ", - "{str_flatten(missingCols, ', ')}" - ) - abort(msg) + hit <- intersect(aliases[[canon]], names(df)) + if (length(hit) == 0L) { + return(NULL) } + hit[[1L]] +} + +.canonManifestCols <- function(df, aliases, required, label) { + # Each alias resolves against the ORIGINAL names, so renaming one cannot + # change what another matches. + renames <- compact(set_names( + map(names(aliases), .manifestAliasHit, aliases = aliases, df = df), + names(aliases) + )) + df <- rename(df, !!!renames) + assertNames( + names(df), + must.include = required, + what = "colnames", + .var.name = str_c(label, " manifest") + ) df } @@ -102,8 +137,9 @@ NULL # both as a constant manifest column and as a function argument. The column (if # present) must be constant; a supplied argument must agree with it. .reconcileScalar <- function(colValues, arg, name, required = TRUE) { - colVal <- NULL - if (!is.null(colValues)) { + colVal <- if (is.null(colValues)) { + NULL + } else { v <- unique(as.character(colValues[ !is.na(colValues) & str_length(as.character(colValues)) > 0L @@ -115,7 +151,7 @@ NULL ) abort(msg) } - if (length(v) == 1L) colVal <- v + if (length(v) == 1L) v else NULL } if (!is.null(arg) && !is.null(colVal)) { if (!identical(as.character(arg), colVal)) { @@ -238,12 +274,13 @@ NULL if (!is.null(open)) { return(open) } - colSpec <- NULL # is_in guard, not `!is.null(df$ldSketchPath)`: on a tibble `$` for an # absent column NULLs but WARNS ("Unknown or uninitialised column"), where a # data.frame was silent. ldSketchPath is optional (LD may come via # `ldSketch`). - if (is_in("ldSketchPath", names(df))) { + colSpec <- if (!is_in("ldSketchPath", names(df))) { + NULL + } else { v <- unique(as.character(df$ldSketchPath[ !is.na(df$ldSketchPath) & str_length(as.character(df$ldSketchPath)) > 0L @@ -251,13 +288,13 @@ NULL if (length(v) > 1L) { abort("`ldSketchPath` column must be constant across the manifest.") } - if (length(v) == 1L) colSpec <- .resolveRel(v, base) + if (length(v) == 1L) .resolveRel(v, base) else NULL } - spec <- ldSketch + spec <- ldSketch %||% colSpec if ( - !is.null(spec) && + !is.null(ldSketch) && !is.null(colSpec) && - !identical(as.character(spec), as.character(colSpec)) + !identical(as.character(ldSketch), as.character(colSpec)) ) { msg <- glue( "`ldSketch` argument disagrees with the manifest ", @@ -265,7 +302,6 @@ NULL ) abort(msg) } - spec <- spec %||% colSpec if (is.null(spec)) { msg <- glue( "`ldSketch` must be provided as an argument or an ", @@ -295,10 +331,9 @@ NULL # empty entries contribute nothing; NA seqnames are dropped. Always returns a # character vector (character(0) when nothing is present, never NULL). .entriesChroms <- function(entries) { - ch <- as.character(unlist( - map(entries, .mlEntryChroms), - use.names = FALSE - )) + # as.character() is load-bearing: an all-empty list concatenates to NULL, + # and this helper promises character(0). + ch <- as.character(unname(list_c(map(entries, .mlEntryChroms)))) unique(ch[!is.na(ch)]) } @@ -487,7 +522,7 @@ NULL if (is.null(gr)) { return(emptyDf) } - lines <- unlist(Rsamtools::scanTabix(tf, param = gr), use.names = FALSE) + lines <- unname(list_c(Rsamtools::scanTabix(tf, param = gr))) if (length(lines) == 0L) { return(emptyDf) } @@ -562,6 +597,7 @@ NULL # standard key (chrom/pos/variant_id/...) to the source column name. Accepts a # named list/vector, or a path to a YAML file of `standardName: sourceName` # entries (the xqtl-protocol column-mapping format). +#' @importFrom checkmate assertFileExists .readColumnMapping <- function(columnMapping) { if (is.null(columnMapping)) { return(NULL) @@ -574,10 +610,11 @@ NULL return(map_chr(columnMapping, as.character)) } if (is.character(columnMapping) && length(columnMapping) == 1L) { - if (!file.exists(columnMapping)) { - msg <- glue("columnMapping file not found: {columnMapping}") - abort(msg) - } + assertFileExists( + columnMapping, + access = "r", + .var.name = "columnMapping file" + ) mapping <- yaml::read_yaml(columnMapping) if ( !is.list(mapping) || @@ -649,14 +686,19 @@ NULL .resolveSumstatCols <- function(df, columnMapping, label, allowNoN = FALSE) { # Strip a leading '#' from the first column name so a '#CHR'-style header # (common in GWAS TSVs) resolves the same on plain-text and tabix reads. - if (ncol(df) > 0L) { - names(df)[1L] <- str_remove(names(df)[1L], "^#") + unhashed <- if (ncol(df) == 0L) { + df + } else { + `names<-`( + df, + replace(names(df), 1L, str_remove(names(df)[1L], "^#")) + ) } mapping <- .readColumnMapping(columnMapping) - resolved <- .resolveSumstatRequired(df, mapping, label) - z <- .resolveSumstatZ(df, mapping, label) - n <- .resolveSumstatN(df, mapping, label, allowNoN) - .buildSumstatOut(df, resolved, z, n, mapping, label) + resolved <- .resolveSumstatRequired(unhashed, mapping, label) + z <- .resolveSumstatZ(unhashed, mapping, label) + n <- .resolveSumstatN(unhashed, mapping, label, allowNoN) + .buildSumstatOut(unhashed, resolved, z, n, mapping, label) } # Resolve + validate the always-required columns (chrom/pos/variant_id/A1/A2). @@ -743,18 +785,17 @@ NULL A1 = as.character(df[[resolved$A1]]), A2 = as.character(df[[resolved$A2]]) ) - out$Z <- if (z$hasZ) { - as.numeric(df[[z$zSrc]]) - } else { - as.numeric(df[[z$betaSrc]]) / as.numeric(df[[z$seSrc]]) - } - if (n$hasN) { - out$N <- as.numeric(df[[n$nSrc]]) - } - if (n$hasCounts) { - out$N_CASE <- as.numeric(df[[n$ncaseSrc]]) - out$N_CONTROL <- as.numeric(df[[n$ncontrolSrc]]) - } + sampleSize <- c( + if (n$hasN) list(N = as.numeric(df[[n$nSrc]])) else list(), + if (n$hasCounts) { + list( + N_CASE = as.numeric(df[[n$ncaseSrc]]), + N_CONTROL = as.numeric(df[[n$ncontrolSrc]]) + ) + } else { + list() + } + ) # `claimed` = the source columns named by explicit mappings, so an # auto-detected key never re-reads a column another key already claimed. claimed <- if (is.null(mapping)) { @@ -762,15 +803,50 @@ NULL } else { unname(as.character(mapping)) } - afSrc <- .resolveSumstatKey("AF", df, mapping, label, claimed) - for (key in c("BETA", "SE", "P", "AF", "MAF", "INFO")) { - src <- .resolveSumstatKey(key, df, mapping, label, claimed) - if (!is.na(src) && !is.null(src)) { - out[[key]] <- as.numeric(df[[src]]) - } - } - .warnAfProvenance(out, afSrc, label) - out + optionalKeys <- c("BETA", "SE", "P", "AF", "MAF", "INFO") + sources <- set_names( + map( + optionalKeys, + .resolveSumstatKeyFor, + df = df, + mapping = mapping, + label = label, + claimed = claimed + ), + optionalKeys + ) + present <- keep(sources, .sumstatSourceFound) + result <- mutate( + out, + Z = if (z$hasZ) { + as.numeric(df[[z$zSrc]]) + } else { + as.numeric(df[[z$betaSrc]]) / as.numeric(df[[z$seSrc]]) + }, + !!!sampleSize, + !!!map(present, .sumstatNumericColumn, df = df) + ) + .warnAfProvenance( + result, + .resolveSumstatKey("AF", df, mapping, label, claimed), + label + ) + result +} + +# @noRd +.resolveSumstatKeyFor <- function(key, df, mapping, label, claimed) { + .resolveSumstatKey(key, df, mapping, label, claimed) +} + +# @noRd +.sumstatSourceFound <- function(src) { + !is.null(src) && !is.na(src) +} + +# @noRd +.sumstatNumericColumn <- function(src, df) { + as.numeric(df[[src]]) } # An exported af of NA must never be silent, and the two ways to get one are @@ -845,9 +921,11 @@ NULL # effect allele (A1) is ALT; the other allele (A2) is REF. Stats come from the # per-study FORMAT fields ES/SE/LP/SS/EAF, with Z = ES / SE. .vcfToSumstatDf <- function(vcf, sampleSelect, formatMapping, label) { - fmap <- modifyList( + fmap <- list_modify( .gwasVcfFormatDefaults, - if (is.null(formatMapping)) list() else as.list(formatMapping) + !!!compact( + if (is.null(formatMapping)) list() else as.list(formatMapping) + ) ) rr <- SummarizedExperiment::rowRanges(vcf) altList <- VariantAnnotation::alt(vcf) @@ -884,13 +962,13 @@ NULL BETA = es, SE = se ) - if (!is.null(lp)) { - out$P <- 10^(-lp) - } - if (!is.null(eaf)) { - out$MAF <- pmin(eaf, 1 - eaf) - } - out + mutate( + out, + !!!compact(list( + P = if (!is.null(lp)) 10^(-lp), + MAF = if (!is.null(eaf)) pmin(eaf, 1 - eaf) + )) + ) } # Read one GWAS-VCF sumstats file (region-restricted only when bgzipped + @@ -898,8 +976,8 @@ NULL .readSumStatsVcf <- function(path, region, sampleSelect, formatMapping, label) { if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { msg <- glue( - "{label}: reading VCF sumstats requires the 'VariantAnnotation' ", - "package; please install it." + "{label}: reading VCF sumstats requires the ", + "'VariantAnnotation' package." ) abort(msg) } @@ -1003,13 +1081,9 @@ NULL # parseVariantId() reads an id as chr:pos:A2:A1 (pecotmr's canonical # order), so "A2A1" is a straight take and "A1A2" is the swap. if (identical(order, "A2A1")) { - df$A1 <- parsed$A1 - df$A2 <- parsed$A2 - } else { - df$A1 <- parsed$A2 - df$A2 <- parsed$A1 + return(mutate(df, A1 = parsed$A1, A2 = parsed$A2)) } - df + mutate(df, A1 = parsed$A2, A2 = parsed$A1) } # @noRd @@ -1061,13 +1135,13 @@ NULL col_types = readr::cols(.default = readr::col_character()) ) } - raw <- .applySumstatPrefilters( + filtered <- .applySumstatPrefilters( raw, prefilters, .readColumnMapping(columnMapping), label ) - .resolveSumstatCols(raw, columnMapping, label, allowNoN = allowNoN) + .resolveSumstatCols(filtered, columnMapping, label, allowNoN = allowNoN) } # Dispatch a sumstats file to the text or GWAS-VCF reader. BCF is rejected. @@ -1141,12 +1215,12 @@ NULL readr::read_tsv(path, show_col_types = FALSE, progress = FALSE), check.names = FALSE ) - rn <- as.character(raw[[1L]]) - m <- as.matrix(raw[, -1L, drop = FALSE]) - rownames(m) <- rn - storage.mode(m) <- "double" + m <- `rownames<-`( + `storage.mode<-`(as.matrix(raw[, -1L, drop = FALSE]), "double"), + as.character(raw[[1L]]) + ) if (transpose) { - m <- t(m) + return(t(m)) } m } @@ -1208,17 +1282,22 @@ NULL ) abort(msg) } - meta <- bed[, c(chrCol, startCol, endCol, geneCol)] - names(meta) <- c("chrom", "start", "end", "gene_id") + meta <- `names<-`( + bed[, c(chrCol, startCol, endCol, geneCol)], + c("chrom", "start", "end", "gene_id") + ) sampleCols <- setdiff(names(bed), .bedReservedCols()) - expr <- as.matrix(bed[, sampleCols, drop = FALSE]) - storage.mode(expr) <- "double" - rownames(expr) <- meta$gene_id - rr <- GenomicRanges::GRanges( - seqnames = meta$chrom, - ranges = IRanges::IRanges(start = meta$start + 1L, end = meta$end) - ) - names(rr) <- meta$gene_id + expr <- `rownames<-`( + `storage.mode<-`(as.matrix(bed[, sampleCols, drop = FALSE]), "double"), + meta$gene_id + ) + rr <- `names<-`( + GenomicRanges::GRanges( + seqnames = meta$chrom, + ranges = IRanges::IRanges(start = meta$start + 1L, end = meta$end) + ), + meta$gene_id + ) list(expr = expr, rr = rr) } @@ -1334,26 +1413,33 @@ NULL ) abort(msg) } - covPath <- NULL - if (is_in("covariatePath", names(sub))) { - covs <- unique(sub$covariatePath[ - !is.na(sub$covariatePath) & - str_length(as.character(sub$covariatePath)) > 0L - ]) - if (length(covs) > 1L) { - msg <- glue( - "Context '{cx}' (study '{study}') references multiple ", - "covariatePath values: {str_flatten(covs, ', ')}" - ) - abort(msg) - } - if (length(covs) == 1L) { - covPath <- .resolveRel(covs[[1L]], base) - } - } + covPath <- .oneContextCovariatePath(sub, cx, study, base) .buildContextSe(.resolveRel(pths[[1L]], base), covPath, transposeCov) } +# The single covariate path a context declares, or NULL when the manifest has +# no covariatePath column or the context leaves it blank. +# @noRd +.oneContextCovariatePath <- function(sub, cx, study, base) { + if (!is_in("covariatePath", names(sub))) { + return(NULL) + } + covs <- unique(sub$covariatePath[ + !is.na(sub$covariatePath) & + str_length(as.character(sub$covariatePath)) > 0L + ]) + if (length(covs) > 1L) { + abort(glue( + "Context '{cx}' (study '{study}') references multiple ", + "covariatePath values: {str_flatten(covs, ', ')}" + )) + } + if (length(covs) == 0L) { + return(NULL) + } + .resolveRel(covs[[1L]], base) +} + # The genotype handle: an override panel/path, else the study's single # genotypePath (auto-detecting the format). # @noRd @@ -1443,6 +1529,7 @@ NULL #' study = "s1", genotypePath = file.path(d, "example.chr22")) #' loadQtlDatasetFromManifest(manifest = manifest, study = "s1") #' @importFrom stringr str_ends +#' @importFrom checkmate assertString assertFlag #' @export loadQtlDatasetFromManifest <- function( manifest, @@ -1459,6 +1546,18 @@ loadQtlDatasetFromManifest <- function( keepIndel = TRUE, transposeCovariates = FALSE ) { + assertString(study, null.ok = TRUE) + assertFlag(transposeCovariates) + .assertQtlPassThrough( + scaleResiduals = scaleResiduals, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + xvarCutoff = xvarCutoff, + imissCutoff = imissCutoff, + keepSamples = keepSamples, + keepVariants = keepVariants, + keepIndel = keepIndel + ) base <- .manifestBase(manifest) df <- .canonManifestCols( .readManifest(manifest), @@ -1630,14 +1729,19 @@ loadGwasSumStatsFromManifest <- function( ) # Materialise the LD sketch reading only the chromosomes the sumstats cover, # then run the deferred per-study containment checks and trim to range. - ldSketch <- .materializeLdSketch(ldSketchSpec, .entriesChroms(entries)) - .checkGwasLdContainment(ldSketch, entries, df, minLdOverlapWarn) - ldSketch <- .subsetSketchToRange(ldSketch, entries) - gwasArgs <- .gwasSumStatsArgs(df, entries, genome, ldSketch, ns) + materialized <- .materializeLdSketch( + ldSketchSpec, + .entriesChroms(entries) + ) + .checkGwasLdContainment(materialized, entries, df, minLdOverlapWarn) + ldSketch <- .subsetSketchToRange(materialized, entries) # Without a block manifest a genome-wide file splits by chromosome, which # is too coarse for cTWAS; with one, each study becomes one element per LD # block. The constructor does the splitting either way. - gwasArgs$ldBlocks <- ldBlocks + gwasArgs <- list_assign( + .gwasSumStatsArgs(df, entries, genome, ldSketch, ns), + ldBlocks = ldBlocks + ) exec(GwasSumStats, !!!gwasArgs) } @@ -1715,25 +1819,20 @@ loadGwasSumStatsFromManifest <- function( # GwasSumStats() constructor args, including any present study scalars + varY. # @noRd .gwasSumStatsArgs <- function(df, entries, genome, ldSketch, ns) { - args <- list( - study = as.character(df$study), - entry = entries, - genome = genome, - ldSketch = ldSketch + c( + list( + study = as.character(df$study), + entry = entries, + genome = genome, + ldSketch = ldSketch + ), + compact(list( + nCase = ns$nCase, + nControl = ns$nControl, + nSample = ns$nSample, + varY = if (is_in("varY", names(df))) as.numeric(df$varY) + )) ) - if (!is.null(ns$nCase)) { - args$nCase <- ns$nCase - } - if (!is.null(ns$nControl)) { - args$nControl <- ns$nControl - } - if (!is.null(ns$nSample)) { - args$nSample <- ns$nSample - } - if (is_in("varY", names(df))) { - args$varY <- as.numeric(df$varY) - } - args } # Build the entry list for a QtlSumStats manifest. `allowNoN` is an optional @@ -1853,9 +1952,12 @@ loadQtlSumStatsFromManifest <- function( # Materialise the LD sketch reading only the chromosomes the summary stats # cover (skips other shards of a chrom-sharded panel), check containment, # then trim its snpInfo to the summary stats' per-chromosome position span. - ldSketch <- .materializeLdSketch(ldSketchSpec, .entriesChroms(entries)) - .qtlSumStatsCheckContainment(ldSketch, entries, df, minLdOverlapWarn) - ldSketch <- .subsetSketchToRange(ldSketch, entries) + materialized <- .materializeLdSketch( + ldSketchSpec, + .entriesChroms(entries) + ) + .qtlSumStatsCheckContainment(materialized, entries, df, minLdOverlapWarn) + ldSketch <- .subsetSketchToRange(materialized, entries) exec( QtlSumStats, @@ -1921,13 +2023,13 @@ loadQtlSumStatsFromManifest <- function( genome = genome, ldSketch = ldSketch ) - if (!is.null(nSampleCol)) { - args$nSample <- nSampleCol - } - if (is_in("varY", names(df))) { - args$varY <- as.numeric(df$varY) - } - args + c( + args, + compact(list( + nSample = nSampleCol, + varY = if (is_in("varY", names(df))) as.numeric(df$varY) + )) + ) } #' @title Load a MultiStudyQtlDataset from manifests @@ -1955,6 +2057,7 @@ loadQtlSumStatsFromManifest <- function( #' phenotypePath = file.path(d, "example_geneexpr.bed.gz"), #' genotypePath = file.path(d, "example.chr22")) #' loadMultiStudyQtlDatasetFromManifest(qtlDatasetsManifest = manifest) +#' @importFrom checkmate assertFlag assertNumber #' @export loadMultiStudyQtlDatasetFromManifest <- function( qtlDatasetsManifest, @@ -1976,6 +2079,18 @@ loadMultiStudyQtlDatasetFromManifest <- function( keepVariants = character(0), keepIndel = TRUE ) { + assertFlag(transposeCovariates) + assertNumber(minLdOverlapWarn, lower = 0, upper = 1) + .assertQtlPassThrough( + scaleResiduals = scaleResiduals, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + xvarCutoff = xvarCutoff, + imissCutoff = imissCutoff, + keepSamples = keepSamples, + keepVariants = keepVariants, + keepIndel = keepIndel + ) qc <- .msqQcArgs( scaleResiduals, mafCutoff, diff --git a/R/mashPipeline.R b/R/mashPipeline.R index 2bcff321..03d1560a 100644 --- a/R/mashPipeline.R +++ b/R/mashPipeline.R @@ -285,11 +285,7 @@ mashResidualCorrelation <- function( method <- arg_match(method) inputScale <- arg_match(inputScale) if (!requireNamespace("mashr", quietly = TRUE)) { - msg <- glue( - "To use this function, please install mashr: ", - "https://cran.r-project.org/web/packages/mashr/index.html" - ) - abort(msg) + abort("Package 'mashr' is required for this function.") } if (methods::is(sumStatsList, "SimpleList")) { sumStatsList <- as.list(sumStatsList) @@ -445,23 +441,15 @@ mashResidualCorrelation <- function( # and the exported mashCovarianceComponents. # @noRd .mashBuildComponents <- function(mashData, components, nPcs = NULL) { - comps <- list() - if (is_in("canonical", components)) { - comps <- c(comps, mashr::cov_canonical(mashData)) - } - if (is_in("pca", components)) { - if (is.null(nPcs)) { - nPcs <- ncol(mashData$Bhat) - 1 + npc <- nPcs %||% (ncol(mashData$Bhat) - 1) + c( + if (is_in("canonical", components)) mashr::cov_canonical(mashData), + if (is_in("pca", components)) mashr::cov_pca(mashData, npc = npc), + if (is_in("flash", components)) mashr::cov_flash(mashData), + if (is_in("flashNonneg", components)) { + mashr::cov_flash(mashData, factors = "nonneg") } - comps <- c(comps, mashr::cov_pca(mashData, npc = nPcs)) - } - if (is_in("flash", components)) { - comps <- c(comps, mashr::cov_flash(mashData)) - } - if (is_in("flashNonneg", components)) { - comps <- c(comps, mashr::cov_flash(mashData, factors = "nonneg")) - } - comps + ) } #' @title Build mash Data-Driven Covariance Components @@ -617,11 +605,11 @@ mashPriorCovariances <- function( engine ) } - if (is.null(result$w)) { - m <- mashr::mash(mashData, Ulist = result$U, outputlevel = 1) - result$w <- mashr::get_estimated_pi(m) - } - list(U = result$U, w = result$w, loglik = result$loglik) + w <- result$w %||% + mashr::get_estimated_pi( + mashr::mash(mashData, Ulist = result$U, outputlevel = 1) + ) + list(U = result$U, w = w, loglik = result$loglik) } # Reject unknown prior-covariance component names. @@ -646,18 +634,10 @@ mashPriorCovariances <- function( # @noRd .mashRequirePriorPackages <- function() { if (!requireNamespace("mashr", quietly = TRUE)) { - msg <- glue( - "To use this function, please install mashr: ", - "https://cran.r-project.org/web/packages/mashr/index.html" - ) - abort(msg) + abort("Package 'mashr' is required for this function.") } if (!requireNamespace("flashier", quietly = TRUE)) { - msg <- glue( - "To use this function, please install flashier: ", - "https://github.com/willwerscheid/flashier" - ) - abort(msg) + abort("Package 'flashier' is required for this function.") } } @@ -792,13 +772,15 @@ mashPriorCovariances <- function( # ud_fit with a directed error for the ud_ted / non-i.i.d. (per-variant SE) # incompatibility. # @noRd +#' @importFrom rlang try_fetch .mashUdFit <- function(fit0, mashData, engine, udControl) { control <- .mashUdControl(engine, udControl, ncol(mashData$Bhat)) - tryCatch( + try_fetch( udr::ud_fit(fit0, control = control, verbose = FALSE), - error = function(e) { + error = function(cnd) { if ( - engine == "ud_ted" && str_detect(conditionMessage(e), "i.i.d") + engine == "ud_ted" && + str_detect(conditionMessage(cnd), "i.i.d") ) { msg <- glue( "mashPriorCovariances: engine 'ud_ted' (udr TED update) ", @@ -806,12 +788,12 @@ mashPriorCovariances <- function( "scale does not provide (per-variant SE). Use engine 'ud' ", "(ED update), or a z-scale input." ) - abort(msg) + abort(msg, parent = cnd) } # Not the ud_ted i.i.d. case rewrapped above -- re-raise the # original condition unchanged so unrelated udr failures surface # (and aren't swallowed as a NULL fit). - cnd_signal(e) + cnd_signal(cnd) } ) } @@ -828,14 +810,15 @@ mashPriorCovariances <- function( ) abort(msg) } - udControl <- utils::modifyList( + # NULL in a user control means "use the default", so drop before merging. + udControl <- list_modify( list( n_unconstrained = 50L, maxiter = 1000L, tol = 1e-2, tol.lik = 1e-2 ), - udControl + !!!compact(udControl) ) U.can <- mashr::cov_canonical(mashData) fit0 <- udr::ud_init( @@ -908,11 +891,7 @@ mashModelFit <- function( fitOn <- arg_match(fitOn) inputScale <- arg_match(inputScale) if (!requireNamespace("mashr", quietly = TRUE)) { - msg <- glue( - "To use this function, please install mashr: ", - "https://cran.r-project.org/web/packages/mashr/index.html" - ) - abort(msg) + abort("Package 'mashr' is required for this function.") } if (methods::is(sumStatsList, "SimpleList")) { sumStatsList <- as.list(sumStatsList) @@ -1009,11 +988,7 @@ mashPosterior <- function( ) { inputScale <- arg_match(inputScale) if (!requireNamespace("mashr", quietly = TRUE)) { - msg <- glue( - "To use this function, please install mashr: ", - "https://cran.r-project.org/web/packages/mashr/index.html" - ) - abort(msg) + abort("Package 'mashr' is required for this function.") } mats <- .mashSumStatsToMatrices(sumStats, "target", inputScale = inputScale) ex <- .mashExcludeConditions( @@ -1088,11 +1063,11 @@ mashPosterior <- function( #' \code{pair[2]}. #' @examples #' makePairwiseContrastCol(c("a", "b"), "mean_contrast_") +#' @importFrom checkmate assertCharacter #' @export makePairwiseContrastCol <- function(pair, template) { - template[pair[1]] <- 1 - template[pair[2]] <- -1 - template + assertCharacter(pair, len = 2L, any.missing = FALSE) + replace(template, pair, c(1, -1)) } #' Compute pairwise contrasts from mash posterior @@ -1124,6 +1099,7 @@ makePairwiseContrastCol <- function(pair, template) { #' pv <- array(diag(3) * 0.1, dim = c(3, 3, 1)) #' dimnames(pv) <- list(c("a", "b", "c"), c("a", "b", "c"), NULL) #' fitMashContrast(1L, om, pm, pv) +#' @importFrom checkmate assertCount assertNumeric #' @export fitMashContrast <- function( index, @@ -1132,12 +1108,15 @@ fitMashContrast <- function( posteriorVcov, grouping = NULL ) { - populationNames <- colnames(posteriorMean) - if (!is.null(populationNames)) { - populationNames <- str_remove_all(populationNames, "BETA_") + assertCount(index, positive = TRUE) + assertNumeric(grouping, null.ok = TRUE) + rawNames <- colnames(posteriorMean) + populationNames <- if (is.null(rawNames)) { + NULL + } else { + str_remove_all(rawNames, "BETA_") } - origMeanVector <- origMean[index, ] - names(origMeanVector) <- populationNames + origMeanVector <- set_names(origMean[index, ], populationNames) tested <- names(origMeanVector[origMeanVector != 0]) if (length(tested) < 2) { return(NULL) @@ -1171,10 +1150,9 @@ fitMashContrast <- function( .mashContrastDesign <- function(tested, nPop, grouping) { pairwiseVector <- set_names(rep(0, nPop), tested) if (nPop <= 2) { - pairwiseVector[tested[1]] <- 1 - pairwiseVector[tested[2]] <- -1 + contrast <- replace(pairwiseVector, tested[1:2], c(1, -1)) return(matrix( - pairwiseVector, + contrast, ncol = 1, dimnames = list(tested, str_c(tested[1], "_vs_", tested[2])) )) @@ -1188,43 +1166,79 @@ fitMashContrast <- function( # conditions sharing their deviation weight. # @noRd .mashDeviationContrast <- function(tested, nPop, grouping) { - dev <- matrix(-1, nPop, nPop, dimnames = list(tested, tested)) - diag(dev) <- nPop - 1 - uniqueGroups <- unique(grouping) - for (grp in uniqueGroups[uniqueGroups > 0]) { - grpMask <- grouping == grp - grpSize <- sum(grpMask) - diag(dev)[grpMask] <- (nPop - 1) / grpSize - dev[grpMask, grpMask] <- (nPop - 1) / grpSize - } - colnames(dev) <- str_c(tested, "_deviation") - dev + # Three cases, stated directly: conditions sharing a group split the + # deviation weight between them, the diagonal carries the full weight, + # and everything else contributes -1. + groupSize <- as.integer(table(grouping)[as.character(grouping)]) + sameGroup <- outer(grouping, grouping, "==") & + matrix(grouping > 0, nPop, nPop) + matrix( + ifelse( + sameGroup, + matrix((nPop - 1) / groupSize, nPop, nPop), + ifelse(diag(TRUE, nPop), nPop - 1, -1) + ), + nPop, + nPop, + dimnames = list(tested, str_c(tested, "_deviation")) + ) } # Pairwise (all-pairs) contrasts, with grouped conditions' contributions split # evenly across the group. # @noRd +# One grouped condition's share of a pairwise column: the group's matched +# contribution split evenly across its members. +# @noRd +.mashSplitGroupShare <- function(column, dg, grouping, groups, pwCol) { + rowsInGroup <- names(grouping[grouping == dg]) + matchedRow <- rowsInGroup[is_in(rowsInGroup, groups)] + if (length(matchedRow) == 0) { + return(column) + } + replace(column, rowsInGroup, pwCol[matchedRow] / length(rowsInGroup)) +} + +# One pairwise column, with each grouped condition's contribution split +# across its group. A column whose two sides share a grouping (or that +# involves no grouped condition) is left as it is. +# @noRd +.mashAdjustPairwiseColumn <- function(col, pw, grouping) { + column <- pw[, col] + groups <- str_split(col, "_vs_")[[1]] + groupValues <- grouping[is_in(names(grouping), groups)] + relevant <- names(groupValues[groupValues > 0]) + if (n_distinct(groupValues) <= 1 || length(relevant) == 0) { + return(column) + } + reduce( + unique(groupValues[groupValues > 0]), + .mashSplitGroupShare, + grouping = grouping, + groups = groups, + pwCol = column, + .init = column + ) +} + .mashPairwiseContrast <- function(tested, grouping, pairwiseVector) { twoCombn <- combn(tested, 2) pwNames <- apply(twoCombn, 2, str_flatten, collapse = "_vs_") - pw <- apply(twoCombn, 2, makePairwiseContrastCol, pairwiseVector) - colnames(pw) <- pwNames - pwAdj <- pw - for (col in colnames(pw)) { - groups <- str_split(col, "_vs_")[[1]] - groupValues <- grouping[is_in(names(grouping), groups)] - relevant <- names(groupValues[groupValues > 0]) - if (n_distinct(groupValues) > 1 && length(relevant) > 0) { - for (dg in unique(groupValues[groupValues > 0])) { - rowsInGroup <- names(grouping[grouping == dg]) - matchedRow <- rowsInGroup[is_in(rowsInGroup, groups)] - if (length(matchedRow) > 0) { - pwAdj[rowsInGroup, col] <- pw[matchedRow, col] / - length(rowsInGroup) - } - } - } - } + pw <- `colnames<-`( + apply(twoCombn, 2, makePairwiseContrastCol, pairwiseVector), + pwNames + ) + pwAdj <- matrix( + unname(list_c(map( + colnames(pw), + .mashAdjustPairwiseColumn, + pw = pw, + grouping = grouping + ))), + nrow = nrow(pw), + ncol = ncol(pw), + dimnames = dimnames(pw) + ) pwAdj } @@ -1238,19 +1252,38 @@ fitMashContrast <- function( contrastSe, contrastP ) { - fid <- rownames(posteriorMean)[index] - if (is.null(fid)) { - fid <- as.character(index) - } - df <- tibble(feature_id = fid) + fid <- rownames(posteriorMean)[index] %||% as.character(index) # unname: contrast* carry contrastDesign colnames; tibble (unlike - # data.frame) preserves a named scalar's name on the column. - for (i in seq_along(cnames)) { - df[[str_c("mean_contrast_", cnames[i])]] <- unname(contrastDiff[i]) - df[[str_c("se_contrast_", cnames[i])]] <- unname(contrastSe[i]) - df[[str_c("p_contrast_", cnames[i])]] <- unname(contrastP[i]) - } - df + # data.frame) preserves a named scalar's name on the column. Columns are + # interleaved mean/se/p per contrast, which is the order the loop built. + cols <- list_c(map( + seq_along(cnames), + .mashContrastColumns, + cnames = cnames, + contrastDiff = contrastDiff, + contrastSe = contrastSe, + contrastP = contrastP + )) + tibble(feature_id = fid, !!!cols) +} + +# One contrast's three columns, named for it. +# @noRd +.mashContrastColumns <- function( + i, + cnames, + contrastDiff, + contrastSe, + contrastP +) { + set_names( + list( + unname(contrastDiff[i]), + unname(contrastSe[i]), + unname(contrastP[i]) + ), + str_c(c("mean_contrast_", "se_contrast_", "p_contrast_"), cnames[i]) + ) } #' Posterior contrast table over an entire mash posterior @@ -1287,6 +1320,7 @@ fitMashContrast <- function( #' pv <- array(diag(3) * 0.1, dim = c(3, 3, 1)) #' dimnames(pv) <- list(c("a", "b", "c"), c("a", "b", "c"), NULL) #' mashPosteriorContrast(pm, pv, om) +#' @importFrom checkmate assertNumeric #' @export mashPosteriorContrast <- function( posteriorMean, @@ -1294,18 +1328,18 @@ mashPosteriorContrast <- function( origMean, grouping = NULL ) { - origMean <- origMean[, colnames(posteriorMean), drop = FALSE] - origMean[is.nan(origMean)] <- 0 + assertNumeric(grouping, null.ok = TRUE) + aligned <- origMean[, colnames(posteriorMean), drop = FALSE] + origMean <- replace(aligned, is.nan(aligned), 0) - parts <- map( + parts <- compact(map( seq_len(nrow(posteriorMean)), fitMashContrast, origMean = origMean, posteriorMean = posteriorMean, posteriorVcov = posteriorVcov, grouping = grouping - ) - parts <- compact(parts) + )) if (length(parts) == 0L) { return(tibble()) } @@ -1358,51 +1392,76 @@ mashPosteriorContrast <- function( #' model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior, #' vhat = vhat) #' updateMashModelCov(model, allSamples = conds, samples = conds[1:3]) +#' @importFrom checkmate assertCharacter #' @export updateMashModelCov <- function(mashModel, allSamples, samples) { + assertCharacter(allSamples, any.missing = FALSE) + assertCharacter(samples, any.missing = FALSE) + unwanted <- setdiff(allSamples, samples) cov <- mashModel$fitted_g$Ulist + retained <- discard(names(cov), .mashCovIsDropped, unwanted = unwanted) + resized <- set_names( + map(retained, .mashResizeCov, cov = cov, samples = samples), + retained + ) + keptPi <- discard( + names(mashModel$fitted_g$pi), + .mashPiMentionsDropped, + unwanted = unwanted + ) + list_assign( + mashModel, + fitted_g = list_assign( + mashModel$fitted_g, + Ulist = resized, + pi = mashModel$fitted_g$pi[keptPi] + ) + ) +} - # Remove matrices for dropped conditions - unwanted <- setdiff(allSamples, samples) - for (d in names(cov)) { - if (is_in(d, unwanted) || is_in(d, str_c("ED_", unwanted))) { - cov[[d]] <- NULL - } - } +# A covariance component belongs to a dropped condition, under either its +# bare name or its ED_ prefixed one. +# @noRd +.mashCovIsDropped <- function(d, unwanted) { + is_in(d, unwanted) || is_in(d, str_c("ED_", unwanted)) +} - # Resize remaining matrices to match retained conditions - for (d in names(cov)) { - if (is_in(d, samples)) { - # Condition-specific: single 1 on diagonal - m <- matrix(0, length(samples), length(samples)) - m[which(samples == d), which(samples == d)] <- 1 - cov[[d]] <- m - } else if (d == "identity") { - m <- matrix(0, length(samples), length(samples)) - m[1, 1] <- 1 - cov[[d]] <- m - } else if (is.null(colnames(cov[[d]]))) { - cov[[d]] <- cov[[d]][ - seq_along(samples), - seq_along(samples) - ] - } else { - cov[[d]] <- cov[[d]][samples, samples] - } - cov[[d]] <- as.matrix(cov[[d]]) - } +# A mixture-weight name mentioning any dropped condition. +# @noRd +.mashPiMentionsDropped <- function(nm, unwanted) { + any(map_lgl(unwanted, .mashNameMentions, nm = nm)) +} - mashModel$fitted_g$Ulist <- cov +# @noRd +.mashNameMentions <- function(s, nm) { + str_detect(nm, fixed(s)) +} - # Prune mixture weights for removed conditions - for (s in unwanted) { - dropIdx <- which(str_detect(names(mashModel$fitted_g$pi), fixed(s))) - if (length(dropIdx) > 0) { - mashModel$fitted_g$pi <- mashModel$fitted_g$pi[-dropIdx] - } +# One covariance component resized to the retained conditions. A +# condition-specific component is a single 1 on its own diagonal entry; +# `identity` is a single 1 in the first cell; anything else is subset by +# name when it has one, else positionally. +# @noRd +.mashResizeCov <- function(d, cov, samples) { + n <- length(samples) + if (is_in(d, samples)) { + at <- which(samples == d) + return(replace(matrix(0, n, n), (at - 1L) * n + at, 1)) + } + if (d == "identity") { + return(replace(matrix(0, n, n), 1L, 1)) + } + if (is.null(colnames(cov[[d]]))) { + return(as.matrix(cov[[d]][seq_along(samples), seq_along(samples)])) } + as.matrix(cov[[d]][samples, samples]) +} - mashModel +# One matrix sliced to (snps, samples), relabelled with the retained +# condition names. `snps` / `samples` are subscripts, so NULL is meaningful. +# @noRd +.mashSliceMatrix <- function(m, rows, cols) { + `colnames<-`(as.matrix(m[rows, cols]), cols) } #' Subset mash data matrices to specific SNPs and conditions @@ -1430,17 +1489,22 @@ updateMashModelCov <- function(mashModel, allSamples, samples) { #' vhat <- diag(3) #' dimnames(vhat) <- list(cond, cond) #' sliceMashData(dat, vhat = vhat, snps = 1:4, samples = NULL) +#' @importFrom checkmate assertList assertCharacter #' @export sliceMashData <- function(data, vhat, snps, samples) { - data$bhat <- as.matrix(data$bhat[snps, samples]) - data$sbhat <- as.matrix(data$sbhat[snps, samples]) - data$Z <- as.matrix(data$Z[snps, samples]) - vhat <- as.matrix(vhat[samples, samples]) - data$snp <- data$snp[is_in(data$snp, snps)] - colnames(data$bhat) <- colnames(data$sbhat) <- colnames(data$Z) <- colnames( - vhat - ) <- samples - list(data = data, vhat = vhat) + assertList(data) + # `snps` and `samples` are SUBSCRIPTS -- `data$bhat[snps, samples]` -- so + # character names, integer indices and NULL are all valid. No type + # assertion is correct here (the @example passes snps = 1:4 and + # samples = NULL). + sliced <- list_assign( + data, + bhat = .mashSliceMatrix(data$bhat, snps, samples), + sbhat = .mashSliceMatrix(data$sbhat, snps, samples), + Z = .mashSliceMatrix(data$Z, snps, samples), + snp = data$snp[is_in(data$snp, snps)] + ) + list(data = sliced, vhat = .mashSliceMatrix(vhat, samples, samples)) } #' Sanitize NaN/Inf values in mash data @@ -1452,11 +1516,19 @@ sliceMashData <- function(data, vhat, snps, samples) { #' @return The data list with sanitized values. #' @examples #' sanitizeMashData(list(strong = list(z = matrix(rnorm(9), 3, 3)))) +#' @importFrom checkmate assertList #' @export sanitizeMashData <- function(data) { - data$bhat[is.nan(data$bhat)] <- 0 - data$sbhat[is.nan(data$sbhat) | is.infinite(data$sbhat)] <- 1e3 - data + assertList(data) + list_assign( + data, + bhat = replace(data$bhat, is.nan(data$bhat), 0), + sbhat = replace( + data$sbhat, + is.nan(data$sbhat) | is.infinite(data$sbhat), + 1e3 + ) + ) } #' Random-Effects Meta-Analysis of Mash Pairwise Contrasts, per Condition @@ -1618,8 +1690,10 @@ metaAnalysisPerCondition <- function( #' dimnames(pv) <- list(c("a", "b", "c"), c("a", "b", "c"), NULL) #' cr <- fitMashContrast(1L, om, pm, pv) #' calculateFeatureScores(cr, metaMethod = "mean") +#' @importFrom checkmate assertString #' @export calculateFeatureScores <- function(contrastResult, metaMethod = "REML") { + assertString(metaMethod) cr <- as_tibble(contrastResult) effCols <- names(cr)[str_detect(names(cr), "mean_contrast_.*deviation")] if (length(effCols) == 0L) { @@ -1661,8 +1735,10 @@ calculateFeatureScores <- function(contrastResult, metaMethod = "REML") { #' dimnames(pv) <- list(c("a", "b", "c"), c("a", "b", "c"), NULL) #' cr <- fitMashContrast(1L, om, pm, pv) #' nSignificantScore(cr, pCutoff = 0.05) +#' @importFrom checkmate assertNumber #' @export nSignificantScore <- function(contrastResult, pCutoff = 1e-5) { + assertNumber(pCutoff, lower = 0, upper = 1) cr <- as_tibble(contrastResult) pCols <- names(cr)[str_detect(names(cr), "p_contrast_.*deviation")] if (length(pCols) == 0L) { @@ -1713,8 +1789,8 @@ scoreFromCs <- function(fineMapping, contrastResults, condition) { return(NA_real_) } leadRows <- bind_rows(map(css, .csLeadRow, fineMapping = fineMapping)) - cr <- as_tibble(contrastResults) - cr <- filter(cr, is_in(.data$feature_id, leadRows$variants)) + cr <- as_tibble(contrastResults) |> + filter(is_in(.data$feature_id, leadRows$variants)) if (nrow(cr) == 0L) { return(NA_real_) } @@ -1776,11 +1852,11 @@ scoreFromCs <- function(fineMapping, contrastResults, condition) { if (!is_in(seCol, names(cr))) { return(NA_real_) } - es <- abs(as.numeric(cr[[ec]])) - se <- as.numeric(cr[[seCol]]) - keep <- is.finite(es) & is.finite(se) & se > 0 - es <- es[keep] - se <- se[keep] + esAll <- abs(as.numeric(cr[[ec]])) + seAll <- as.numeric(cr[[seCol]]) + keep <- is.finite(esAll) & is.finite(seAll) & seAll > 0 + es <- esAll[keep] + se <- seAll[keep] if (length(es) < 1L) { return(NA_real_) } diff --git a/R/mashWrapper.R b/R/mashWrapper.R index 9fe94e81..d263ea13 100644 --- a/R/mashWrapper.R +++ b/R/mashWrapper.R @@ -12,24 +12,20 @@ filterBySignificance <- function(zMatrix, sigPCutoff) { # data.frame round-trip. # @noRd .mashReplaceValues <- function(x, replaceWith) { - m <- as.matrix(x) - storage.mode(m) <- "double" - m[is.nan(m) | is.infinite(m) | is.na(m)] <- replaceWith - m + m <- `storage.mode<-`(as.matrix(x), "double") + replace(m, is.nan(m) | is.infinite(m) | is.na(m), replaceWith) } # Coerce z-scores to a matrix (NaN/Inf/NA -> 0) and, when a missing-rate # threshold is given, drop rows falling below it. # @noRd .mashProcessZ <- function(zData, filterByMissingRate) { - zData <- .mashReplaceValues(zData, 0) - - if (!is.null(filterByMissingRate)) { - proportionNonzero <- apply(zData, 1, .mashRowNonzeroRate) - zData <- zData[proportionNonzero >= filterByMissingRate, , drop = FALSE] + cleaned <- .mashReplaceValues(zData, 0) + if (is.null(filterByMissingRate)) { + return(cleaned) } - - return(zData) + proportionNonzero <- apply(cleaned, 1, .mashRowNonzeroRate) + cleaned[proportionNonzero >= filterByMissingRate, , drop = FALSE] } #' Filter invalid summary statistics for mash input @@ -54,6 +50,7 @@ filterBySignificance <- function(zMatrix, sigPCutoff) { #' datList <- list(strong = list(z = matrix(rnorm(9), 3, 3))) #' filterInvalidSummaryStat(datList) #' @export +#' @importFrom checkmate assertFlag assertList assertNumber filterInvalidSummaryStat <- function( datList, bhat = NULL, @@ -63,25 +60,34 @@ filterInvalidSummaryStat <- function( sigPCutoff = 1E-6, filterByMissingRate = 0.2 ) { - if ( + assertList(datList) + assertFlag(btoz) + # NULL is how callers disable each filter. + assertNumber(sigPCutoff, lower = 0, upper = 1, null.ok = TRUE) + assertNumber( + filterByMissingRate, + lower = 0, + upper = 1, + null.ok = TRUE + ) + reset <- if ( !is.null(bhat) && !is.null(sbhat) && all(is_in(c(bhat, sbhat), names(datList))) ) { - datList <- .mashFilterBhatSbhat( - datList, - bhat, - sbhat, - filterByMissingRate - ) + .mashFilterBhatSbhat(datList, bhat, sbhat, filterByMissingRate) + } else { + datList } - if (btoz) { - datList <- .mashFilterBtoz(datList, bhat, sbhat, sigPCutoff) + withZ <- if (btoz) { + .mashFilterBtoz(reset, bhat, sbhat, sigPCutoff) + } else { + reset } - if (!is.null(z)) { - datList <- .mashFilterZ(datList, filterByMissingRate, sigPCutoff) + if (is.null(z)) { + return(withZ) } - datList + .mashFilterZ(withZ, filterByMissingRate, sigPCutoff) } # Reset invalid bhat/sbhat cells (bhat -> 0, sbhat -> 1000) and, when a @@ -92,66 +98,117 @@ filterInvalidSummaryStat <- function( if (is.null(datList[[bhat]]) || is.null(datList[[sbhat]])) { return(datList) } - datList[[bhat]] <- .mashReplaceValues(datList[[bhat]], 0) - datList[[sbhat]] <- .mashReplaceValues(datList[[sbhat]], 1000) - hasNullOrRandom <- is_in("null.b", names(datList)) || - is_in("random.b", names(datList)) + reset <- list_assign( + datList, + !!!set_names( + list( + .mashReplaceValues(datList[[bhat]], 0), + .mashReplaceValues(datList[[sbhat]], 1000) + ), + c(bhat, sbhat) + ) + ) + hasNullOrRandom <- is_in("null.b", names(reset)) || + is_in("random.b", names(reset)) if (!hasNullOrRandom || is.null(filterByMissingRate)) { - return(datList) + return(reset) } - proportionNonzero <- apply(datList[[bhat]], 1, .mashRowNonzeroRate) + proportionNonzero <- apply(reset[[bhat]], 1, .mashRowNonzeroRate) keep <- proportionNonzero >= filterByMissingRate - datList[[bhat]] <- datList[[bhat]][keep, ] - datList[[sbhat]] <- datList[[sbhat]][keep, ] - datList + list_assign( + reset, + !!!set_names( + list(reset[[bhat]][keep, ], reset[[sbhat]][keep, ]), + c(bhat, sbhat) + ) + ) } # Derive z = bhat / sbhat (into a `.z` or `z` slot) and apply the # significance cutoff to strong signals. # @noRd .mashFilterBtoz <- function(datList, bhat, sbhat, sigPCutoff) { - if (any(str_detect(bhat, "\\.b$")) || any(str_detect(sbhat, "\\.s$"))) { - zName <- str_c(str_remove(bhat, "\\.b$"), ".z") - if (!is.null(datList[[bhat]]) && !is.null(datList[[sbhat]])) { - datList[[zName]] <- as.matrix(datList[[bhat]] / datList[[sbhat]]) - } else { - datList[zName] <- list(NULL) - } - } else if (!is.null(datList[[bhat]]) && !is.null(datList[[sbhat]])) { - datList[["z"]] <- as.matrix(datList[[bhat]] / datList[[sbhat]]) + perCondition <- any(str_detect(bhat, "\\.b$")) || + any(str_detect(sbhat, "\\.s$")) + zName <- if (perCondition) { + str_c(str_remove(bhat, "\\.b$"), ".z") } else { - datList["z"] <- list(NULL) + "z" } - if (is_in("strong.z", names(datList)) && !is.null(sigPCutoff)) { - keepIndex <- filterBySignificance(datList$strong.z, sigPCutoff) - datList[["strong.z"]] <- datList$strong.z[keepIndex, ] - datList[["strong.b"]] <- datList$strong.b[keepIndex, ] - datList[["strong.s"]] <- datList$strong.s[keepIndex, ] - } - datList + # list(NULL) not NULL: the z slot must EXIST and be empty, where assigning + # NULL would delete it. + zValue <- if (!is.null(datList[[bhat]]) && !is.null(datList[[sbhat]])) { + list(as.matrix(datList[[bhat]] / datList[[sbhat]])) + } else { + list(NULL) + } + withZ <- list_assign(datList, !!!set_names(zValue, zName)) + if (!is_in("strong.z", names(withZ)) || is.null(sigPCutoff)) { + return(withZ) + } + keepIndex <- filterBySignificance(withZ$strong.z, sigPCutoff) + list_assign( + withZ, + strong.z = withZ$strong.z[keepIndex, ], + strong.b = withZ$strong.b[keepIndex, ], + strong.s = withZ$strong.s[keepIndex, ] + ) } # Process each partition's z-matrix (missing-rate filter) and apply the # significance cutoff to strong z-scores. # @noRd .mashFilterZ <- function(datList, filterByMissingRate, sigPCutoff) { - for (comp in c("strong", "random", "null")) { - if (!is.null(datList[[comp]]) && !is.null(datList[[comp]]$z)) { - datList[[comp]]$z <- .mashProcessZ( - datList[[comp]]$z, - filterByMissingRate + # Only partitions that are present and carry a z get rewritten: + # `list_assign()` would otherwise CREATE an absent component as NULL. + components <- keep( + intersect(c("strong", "random", "null"), names(datList)), + .mashPartitionHasZ, + datList = datList + ) + processed <- if (length(components) == 0L) { + datList + } else { + list_assign( + datList, + !!!set_names( + map( + components, + .mashProcessPartition, + datList = datList, + filterByMissingRate = filterByMissingRate + ), + components ) - } + ) } if ( - !is.null(datList$strong) && - !is.null(datList$strong$z) && - !is.null(sigPCutoff) + is.null(processed$strong) || + is.null(processed$strong$z) || + is.null(sigPCutoff) ) { - keepIndex <- filterBySignificance(datList$strong$z, sigPCutoff) - datList$strong$z <- datList$strong$z[keepIndex, , drop = FALSE] - } - datList + return(processed) + } + keepIndex <- filterBySignificance(processed$strong$z, sigPCutoff) + list_assign( + processed, + strong = list_assign( + processed$strong, + z = processed$strong$z[keepIndex, , drop = FALSE] + ) + ) +} + +# @noRd +.mashPartitionHasZ <- function(comp, datList) { + !is.null(datList[[comp]]) && !is.null(datList[[comp]]$z) +} + +# One partition with its z-matrix missing-rate filtered. +# @noRd +.mashProcessPartition <- function(comp, datList, filterByMissingRate) { + part <- datList[[comp]] + list_assign(part, z = .mashProcessZ(part$z, filterByMissingRate)) } #' Filter conditions from mash prior mixture components @@ -177,34 +234,38 @@ filterInvalidSummaryStat <- function( #' }) #' filterMixtureComponents(conditionsToKeep = conditionsToKeep, U = U) #' @export +#' @importFrom checkmate assertCharacter assertNumber filterMixtureComponents <- function( conditionsToKeep, U, w = NULL, wCutoff = 1e-04 ) { + assertCharacter(conditionsToKeep, any.missing = FALSE) + assertNumber(wCutoff, lower = 0, finite = TRUE) conditionsToFilter <- setdiff(colnames(U[[1]]), conditionsToKeep) sumW <- sum(w) - U <- .mashSubsetU(U, conditionsToKeep) + subsetU <- .mashSubsetU(U, conditionsToKeep) # Drop all-zero matrices, then those below the weight cutoff. - keepNames <- names(keep(U, .mashMatrixNonzero)) - if (!is.null(w)) { - keepNames <- intersect(keepNames, names(w[w >= wCutoff])) - } - U <- U[keepNames] - if (!is.null(w)) { - w <- w[keepNames] - } - # Manually remove the U components driven by non-relevant contexts: the EM - # can leave tiny non-zero diagonals, so all-zero removal alone won't drop - # them, yet real diagonal signal must be kept. - U[conditionsToFilter] <- NULL - w <- w[!is_in(names(w), conditionsToFilter)] + nonzero <- names(keep(subsetU, .mashMatrixNonzero)) + keepNames <- if (is.null(w)) { + nonzero + } else { + intersect(nonzero, names(w[w >= wCutoff])) + } + # Also drop the U components driven by non-relevant contexts: the EM can + # leave tiny non-zero diagonals, so all-zero removal alone won't drop them, + # yet real diagonal signal must be kept. + keptU <- subsetU[setdiff(keepNames, conditionsToFilter)] + keptW <- w[keepNames] + survivors <- keptW[!is_in(names(keptW), conditionsToFilter)] # Rescale the surviving weights back to the original total. - w <- (w / sum(w)) * sumW - msg <- glue("{length(U)} components of matrices remained after filtering.") + rescaled <- (survivors / sum(survivors)) * sumW + msg <- glue( + "{length(keptU)} components of matrices remained after filtering." + ) inform(msg) - list(U = U, w = w) + list(U = keptU, w = rescaled) } # Subset every U matrix to the kept conditions (erroring if a matrix lacks one). @@ -315,14 +376,22 @@ mashRandNullSample <- function( ) abort(msg) } - for (key in intersect(names(dat), c("z", "bhat", "sbhat"))) { - keep <- setdiff(colnames(dat[[key]]), excludeCondition) - dat[[key]] <- dat[[key]][, keep, drop = FALSE] - } + keys <- intersect(names(dat), c("z", "bhat", "sbhat")) + dat <- list_assign( + dat, + !!!set_names( + map(dat[keys], .mashDropConditions, drop = excludeCondition), + keys + ) + ) } + .mashExtractOneData(dat, nRandom, nNull) +} - result <- .mashExtractOneData(dat, nRandom, nNull) - return(result) +# One matrix without the excluded condition columns. +# @noRd +.mashDropConditions <- function(m, drop) { + m[, setdiff(colnames(m), drop), drop = FALSE] } #' Merge two mash data lists @@ -345,8 +414,11 @@ mashRandNullSample <- function( #' c("chr1:400:A:G", "chr1:500:A:G", "chr1:600:A:G"), #' c("t1", "t2", "t3"))))) #' mergeMashData(a, b) +#' @importFrom checkmate assertList #' @export mergeMashData <- function(resData, oneData) { + assertList(resData, null.ok = TRUE) + assertList(oneData, null.ok = TRUE) if (length(resData) == 0 || is.null(resData)) { return(oneData) } @@ -354,14 +426,15 @@ mergeMashData <- function(resData, oneData) { return(resData) } - combinedData <- map( - names(oneData), - .mashCombineDatum, - oneData = oneData, - resData = resData + set_names( + map( + names(oneData), + .mashCombineDatum, + oneData = oneData, + resData = resData + ), + names(oneData) ) - names(combinedData) <- names(oneData) - return(combinedData) } # Build variants x conditions (Bhat, Shat) matrices for ONE object plus the @@ -405,9 +478,9 @@ mergeMashData <- function(resData, oneData) { # PIP) variant. # @noRd .mashFmrMatrices <- function(obj, coverage) { - me <- getMarginalEffects(obj) - cs <- getCs(obj, coverage = coverage) - if (!all(is_in(c("variant_id", "context", "beta", "se"), names(me)))) { + rawMe <- getMarginalEffects(obj) + rawCs <- getCs(obj, coverage = coverage) + if (!all(is_in(c("variant_id", "context", "beta", "se"), names(rawMe)))) { msg <- glue( "mashInput: getMarginalEffects() must return variant_id/context/", "beta/se columns; a FineMappingResult with >= 2 contexts is ", @@ -415,22 +488,24 @@ mergeMashData <- function(resData, oneData) { ) abort(msg) } - pinned <- .mashFmrMethodPin(me, cs) + pinned <- .mashFmrMethodPin(rawMe, rawCs) me <- pinned$me cs <- pinned$cs contexts <- unique(me$context) variants <- unique(me$variant_id) - b <- matrix( + empty <- matrix( NA_real_, length(variants), length(contexts), dimnames = list(variants, contexts) ) - s <- b + # One (variant, context) cell per long-format row; the rest stay NA. cell <- cbind(match(me$variant_id, variants), match(me$context, contexts)) - b[cell] <- me$beta - s[cell] <- me$se - list(b = b, s = s, strongRows = .mashFmrStrongRows(cs, variants)) + list( + b = replace(empty, cell, me$beta), + s = replace(empty, cell, me$se), + strongRows = .mashFmrStrongRows(cs, variants) + ) } # A multi-method FineMappingResult would duplicate (variant, context) cells; @@ -453,19 +528,23 @@ mergeMashData <- function(resData, oneData) { list(me = me, cs = cs) } +# The max-PIP variant among one credible set's rows. +# @noRd +.mashLeadVariant <- function(rows, cs) { + cs$variant_id[[rows[[which.max(cs$pip[rows])]]]] +} + # Row indices (into `variants`) of each credible set's lead (max PIP) variant. # @noRd .mashFmrStrongRows <- function(cs, variants) { - strongVar <- character(0) csCol <- names(cs)[str_detect(names(cs), "^cs_")] - if (nrow(cs) > 0L && length(csCol) > 0L && is_in("pip", names(cs))) { + strongVar <- if ( + nrow(cs) > 0L && length(csCol) > 0L && is_in("pip", names(cs)) + ) { grp <- interaction(cs$context, cs[[csCol[[1L]]]], drop = TRUE) - for (rows in split(seq_len(nrow(cs)), grp)) { - strongVar <- c( - strongVar, - cs$variant_id[[rows[[which.max(cs$pip[rows])]]]] - ) - } + map_chr(split(seq_len(nrow(cs)), grp), .mashLeadVariant, cs = cs) + } else { + character(0) } strongRows <- sort(match(unique(strongVar), variants)) strongRows[!is.na(strongRows)] @@ -545,20 +624,21 @@ mergeMashData <- function(resData, oneData) { # empty partition. # @noRd .mashPartitionOut <- function(mats, keepCols, rn) { - out <- list() - if (length(mats$strongRows) > 0L) { - out[["strong.b"]] <- mats$b[mats$strongRows, keepCols, drop = FALSE] - out[["strong.s"]] <- mats$s[mats$strongRows, keepCols, drop = FALSE] - } - if (!is.null(rn$random) && length(rn$random) > 0L) { - out[["random.b"]] <- rn$random$bhat - out[["random.s"]] <- rn$random$sbhat - } - if (!is.null(rn$null) && length(rn$null) > 0L) { - out[["null.b"]] <- rn$null$bhat - out[["null.s"]] <- rn$null$sbhat - } - out + hasStrong <- length(mats$strongRows) > 0L + hasRandom <- !is.null(rn$random) && length(rn$random) > 0L + hasNull <- !is.null(rn$null) && length(rn$null) > 0L + compact(list( + strong.b = if (hasStrong) { + mats$b[mats$strongRows, keepCols, drop = FALSE] + }, + strong.s = if (hasStrong) { + mats$s[mats$strongRows, keepCols, drop = FALSE] + }, + random.b = if (hasRandom) rn$random$bhat, + random.s = if (hasRandom) rn$random$sbhat, + null.b = if (hasNull) rn$null$bhat, + null.s = if (hasNull) rn$null$sbhat + )) } #' Assemble MASH strong / random / null input from S4 objects @@ -667,7 +747,7 @@ mashInput <- function( abort(msg) } if (is.null(names(objects)) || any(str_length(names(objects)) == 0L)) { - names(objects) <- str_c("region", seq_along(objects)) + return(set_names(objects, str_c("region", seq_along(objects)))) } objects } @@ -676,22 +756,33 @@ mashInput <- function( # rownames by region before accumulating. # @noRd .mashCombinePartitions <- function(objects, cfg) { - combined <- list() - for (nm in names(objects)) { - part <- .mashObjectPartitions( - objects[[nm]], - nRandom = cfg$nRandom, - nNull = cfg$nNull, - excludeCondition = cfg$excludeCondition, - coverage = cfg$coverage, - inputScale = cfg$inputScale, - seed = cfg$seed, - independentVariants = cfg$independentVariants - ) - part <- map(part, .mashPrefixRownames, nm = nm) - combined <- mergeMashData(combined, part) - } - combined + reduce( + map( + names(objects), + .mashRegionPartitions, + objects = objects, + cfg = cfg + ), + mergeMashData, + .init = list() + ) +} + +# One region's partitions, with its rownames region-prefixed so the merge can +# tell same-named variants from different regions apart. +# @noRd +.mashRegionPartitions <- function(nm, objects, cfg) { + part <- .mashObjectPartitions( + objects[[nm]], + nRandom = cfg$nRandom, + nNull = cfg$nNull, + excludeCondition = cfg$excludeCondition, + coverage = cfg$coverage, + inputScale = cfg$inputScale, + seed = cfg$seed, + independentVariants = cfg$independentVariants + ) + map(part, .mashPrefixRownames, nm = nm) } # Coerce to data.frame, clean each partition + derive z (random/null before @@ -699,55 +790,78 @@ mashInput <- function( # 1-row matrix shape, add the strong XtX, and optionally drop b/s slots. # @noRd .mashFinalizeCombined <- function(combined, sigPCutoff, zOnly) { - combined <- map(combined, .mashAsDataFrameOrNull) - for (cond in c("random", "null", "strong")) { - bKey <- str_c(cond, ".b") - sKey <- str_c(cond, ".s") - if (!is.null(combined[[bKey]]) && !is.null(combined[[sKey]])) { - combined <- filterInvalidSummaryStat( - combined, - bhat = bKey, - sbhat = sKey, - btoz = TRUE, - sigPCutoff = sigPCutoff - ) - } - } - combined <- .mashRestoreStrongShape(combined) - combined <- .mashAddXtX(combined) - if (zOnly) { - combined[str_detect(names(combined), "\\.(b|s)$")] <- NULL + # Each condition's z derivation sees the frame the previous one produced, + # so the sweep is a fold rather than a variable rewritten three times. + withZ <- reduce( + c("random", "null", "strong"), + .mashDeriveZFor, + sigPCutoff = sigPCutoff, + .init = map(combined, .mashAsDataFrameOrNull) + ) + shaped <- .mashAddXtX(.mashRestoreStrongShape(withZ)) + if (!zOnly) { + return(shaped) } - combined + shaped[!str_detect(names(shaped), "\\.(b|s)$")] +} + +# Derive z for one condition, when it carries both b and s. +# @noRd +.mashDeriveZFor <- function(combined, cond, sigPCutoff) { + bKey <- str_c(cond, ".b") + sKey <- str_c(cond, ".s") + if (is.null(combined[[bKey]]) || is.null(combined[[sKey]])) { + return(combined) + } + filterInvalidSummaryStat( + combined, + bhat = bKey, + sbhat = sKey, + btoz = TRUE, + sigPCutoff = sigPCutoff + ) } # filterInvalidSummaryStat subsets strong without drop = FALSE, so a single # surviving strong variant degrades to a vector; restore the 1-row matrix. # @noRd .mashRestoreStrongShape <- function(combined) { - for (k in c("strong.b", "strong.s", "strong.z")) { - v <- combined[[k]] - if (!is.null(v) && is.null(dim(v))) { - combined[[k]] <- matrix( - v, - nrow = 1L, - dimnames = list(NULL, names(v)) - ) - } + # Only keys that exist AND lost their dim are rewritten; `list_assign()` + # would otherwise create an absent key as NULL. + needs <- keep( + intersect(c("strong.b", "strong.s", "strong.z"), names(combined)), + .mashLostDim, + combined = combined + ) + if (length(needs) == 0L) { + return(combined) } - combined + list_assign( + combined, + !!!set_names(map(combined[needs], .mashAsOneRow), needs) + ) +} + +# @noRd +.mashLostDim <- function(k, combined) { + !is.null(combined[[k]]) && is.null(dim(combined[[k]])) +} + +# @noRd +.mashAsOneRow <- function(v) { + matrix(v, nrow = 1L, dimnames = list(NULL, names(v))) } # Strong XtX cross-product (conditions x conditions), when strong.z is present. # @noRd .mashAddXtX <- function(combined) { if ( - !is.null(combined$strong.z) && nrow(as.matrix(combined$strong.z)) > 0L + is.null(combined$strong.z) || nrow(as.matrix(combined$strong.z)) == 0L ) { - sz <- as.matrix(combined$strong.z) - combined$XtX <- crossprod(sz) / nrow(sz) + return(combined) } - combined + sz <- as.matrix(combined$strong.z) + list_assign(combined, XtX = crossprod(sz) / nrow(sz)) } #' @title Build a QtlSumStats from a Z-score matrix @@ -812,10 +926,7 @@ qtlSumStatsFromZMatrix <- function( ) abort(msg) } - vids <- rownames(z) - if (is.null(vids)) { - vids <- str_c("var", seq_len(nrow(z))) - } + vids <- rownames(z) %||% str_c("var", seq_len(nrow(z))) .qtlSumStatsFromMatrix( vids = vids, nCond = ncol(z), @@ -888,10 +999,7 @@ qtlSumStatsFromBetaMatrix <- function( role = "mash" ) { .mashValidateBetaMatrix(bhat, shat) - vids <- rownames(bhat) - if (is.null(vids)) { - vids <- str_c("var", seq_len(nrow(bhat))) - } + vids <- rownames(bhat) %||% str_c("var", seq_len(nrow(bhat))) .qtlSumStatsFromMatrix( vids = vids, nCond = ncol(bhat), @@ -944,6 +1052,7 @@ qtlSumStatsFromBetaMatrix <- function( # where they don't parse), builds one GRanges entry per condition with mcols # from `mcolFn(j)`, and wraps the entries as a QtlSumStats. # @noRd +#' @importFrom rlang try_fetch .qtlSumStatsFromMatrix <- function( vids, nCond, @@ -959,22 +1068,28 @@ qtlSumStatsFromBetaMatrix <- function( context <- .qszmRecycle(context, nCond, "context") trait <- .qszmRecycle(trait, nCond, "trait") # Decode chrom/pos from the variant ids; synthesise where they do not parse. - parsed <- tryCatch( + parsed <- try_fetch( suppressWarnings(parseVariantId(vids)), - error = function(e) NULL + error = function(cnd) NULL ) - chrom <- if (!is.null(parsed)) { + rawChrom <- if (!is.null(parsed)) { as.character(parsed$chrom) } else { rep(NA_character_, length(vids)) } - pos <- if (!is.null(parsed)) { + rawPos <- if (!is.null(parsed)) { suppressWarnings(as.integer(parsed$pos)) } else { rep(NA_integer_, length(vids)) } - chrom[is.na(chrom) | str_length(chrom) == 0L] <- "chr1" - pos[is.na(pos)] <- seq_along(pos)[is.na(pos)] + # An unparseable id still needs a placeable coordinate: the GRanges is + # keyed by the variant id, so the range only has to be unique and ordered. + chrom <- replace( + rawChrom, + is.na(rawChrom) | str_length(rawChrom) == 0L, + "chr1" + ) + pos <- replace(rawPos, is.na(rawPos), seq_along(rawPos)[is.na(rawPos)]) entries <- map( seq_len(nCond), .qszmEntry, @@ -1055,16 +1170,15 @@ qtlSumStatsFromBetaMatrix <- function( setup <- .mashBlockSetup(x) resolvedScale <- .mashResolveScale(x, role, inputScale) blocks <- .mashBuildBlockMatrices(x, setup, resolvedScale) - bhatBlocks <- blocks$bhat - shatBlocks <- blocks$shat - bhat <- exec(rbind, !!!bhatBlocks) - shat <- exec(rbind, !!!shatBlocks) + bhat <- exec(rbind, !!!blocks$bhat) + shat <- exec(rbind, !!!blocks$shat) # bhat NA -> 0, shat NA / <= 0 -> 1000 (the mash_set_data # zero_Bhat_Shat_reset convention; missing-cell variants do not drive the # fit). - bhat[is.na(bhat)] <- 0 - shat[is.na(shat) | shat <= 0] <- 1000 - list(b = bhat, s = shat) + list( + b = replace(bhat, is.na(bhat), 0), + s = replace(shat, is.na(shat) | shat <= 0, 1000) + ) } # The SumStats input must be a QC'd, non-empty QtlSumStats / GwasSumStats. @@ -1199,26 +1313,54 @@ qtlSumStatsFromBetaMatrix <- function( } else { c("SNP", "Z") } - variantOrder <- character() - perContextB <- list() - perContextSe <- list() - for (rIdx in rowsInBlock) { - df <- .mashRowDf(x, rIdx, setup, requireCols) - snps <- df$variant_id - variantOrder <- c(variantOrder, setdiff(snps, variantOrder)) - ctx <- setup$contextCol[[rIdx]] - if (resolvedScale == "beta") { - perContextB[[ctx]] <- set_names(df$beta, snps) - perContextSe[[ctx]] <- set_names(df$se, snps) - } else { - perContextB[[ctx]] <- set_names(df$z, snps) - perContextSe[[ctx]] <- set_names(rep(1, length(snps)), snps) - } + rows <- map( + rowsInBlock, + .mashContextRow, + x = x, + setup = setup, + requireCols = requireCols, + resolvedScale = resolvedScale + ) + contexts <- map_chr(rows, "context") + # A later row overwrites an earlier one sharing a context, as the keyed + # assignment did; the variant order is first-seen across all rows. + lastPerContext <- !duplicated(contexts, fromLast = TRUE) + list( + variantOrder = unique(.mashConcatChr(map(rows, "snps"))), + perContextB = set_names( + map(rows[lastPerContext], "b"), + contexts[lastPerContext] + ), + perContextSe = set_names( + map(rows[lastPerContext], "se"), + contexts[lastPerContext] + ) + ) +} + +# @noRd +.mashConcatChr <- function(pieces) { + if (length(pieces) == 0L) { + return(character(0)) } + as.character(list_c(pieces)) +} + +# One row's effect / standard-error vectors for its context. On the z scale +# the standard errors are unit by construction. +# @noRd +.mashContextRow <- function(rIdx, x, setup, requireCols, resolvedScale) { + df <- .mashRowDf(x, rIdx, setup, requireCols) + snps <- df$variant_id + onBeta <- resolvedScale == "beta" list( - variantOrder = variantOrder, - perContextB = perContextB, - perContextSe = perContextSe + context = setup$contextCol[[rIdx]], + snps = snps, + b = set_names(if (onBeta) df$beta else df$z, snps), + se = set_names( + if (onBeta) df$se else rep(1, length(snps)), + snps + ) ) } @@ -1245,19 +1387,44 @@ qtlSumStatsFromBetaMatrix <- function( .mashBlockMatrix <- function(bkey, x, setup, resolvedScale) { rowsInBlock <- which(setup$blockKeys == bkey) pc <- .mashBlockPerContext(x, rowsInBlock, setup, resolvedScale) - dims <- list(pc$variantOrder, setup$columnLabels) - nVar <- length(pc$variantOrder) - nCol <- length(setup$columnLabels) - bMat <- matrix(NA_real_, nrow = nVar, ncol = nCol, dimnames = dims) - sMat <- matrix(NA_real_, nrow = nVar, ncol = nCol, dimnames = dims) - for (ctx in names(pc$perContextB)) { - bMat[names(pc$perContextB[[ctx]]), ctx] <- pc$perContextB[[ctx]] - sMat[names(pc$perContextSe[[ctx]]), ctx] <- pc$perContextSe[[ctx]] + # Every context owns one column, so each is built whole and the columns + # are laid side by side -- no scatter into a preallocated matrix, and the + # block-qualified rownames go on at construction. + dims <- list( + str_c(bkey, pc$variantOrder, sep = "::"), + setup$columnLabels + ) + list( + b = .mashContextMatrix(pc$perContextB, pc$variantOrder, dims), + s = .mashContextMatrix(pc$perContextSe, pc$variantOrder, dims) + ) +} + +# One context's column, aligned to `variantOrder`. Indexing a named vector by +# a variant it lacks yields NA, which is the unfilled cell. +# @noRd +.mashContextColumn <- function(ctx, perContext, variantOrder) { + v <- perContext[[ctx]] + if (is.null(v)) { + return(rep(NA_real_, length(variantOrder))) } - rn <- str_c(bkey, pc$variantOrder, sep = "::") - rownames(bMat) <- rn - rownames(sMat) <- rn - list(b = bMat, s = sMat) + unname(v[variantOrder]) +} + +# @noRd +.mashContextMatrix <- function(perContext, variantOrder, dims) { + cols <- map( + dims[[2L]], + .mashContextColumn, + perContext = perContext, + variantOrder = variantOrder + ) + matrix( + unname(list_c(cols)), + nrow = length(variantOrder), + ncol = length(dims[[2L]]), + dimnames = dims + ) } # ---- map/apply helpers (lambda-free callbacks) --------------------------- @@ -1325,19 +1492,19 @@ qtlSumStatsFromBetaMatrix <- function( "means two objects share a name or the prefix invariant broke." )) } - combined <- bind_rows(as.data.frame(rd), as.data.frame(od)) - combined[is.na(combined)] <- NaN - rownames(combined) <- c(rnRes, rnOne) - combined + joined <- bind_rows(as.data.frame(rd), as.data.frame(od)) + # NaN, not NA: mash reads a missing cell as NaN. + combined <- replace(joined, is.na(joined), NaN) + `rownames<-`(combined, c(rnRes, rnOne)) } # Region-prefix one partition matrix's rownames (no-op for empty/NULL). # @noRd .mashPrefixRownames <- function(m, nm) { - if (!is.null(m) && nrow(m) > 0L) { - rownames(m) <- str_c(rownames(m), nm, sep = "_") + if (is.null(m) || nrow(m) == 0L) { + return(m) } - m + `rownames<-`(m, str_c(rownames(m), nm, sep = "_")) } # Coerce one partition to a data.frame (NULL passes through). Kept as a base @@ -1359,8 +1526,7 @@ qtlSumStatsFromBetaMatrix <- function( ranges = IRanges::IRanges(start = pos, width = 1L) ) mcolCallArgs <- c(list(j, vids), mcolArgs) - S4Vectors::mcols(gr) <- exec(mcolFn, !!!mcolCallArgs) - gr + S4Vectors::`mcols<-`(gr, value = exec(mcolFn, !!!mcolCallArgs)) } # mcols for condition `j` of a z-scale matrix (Z + placeholder N/alleles). diff --git a/R/overlapTopLoci.R b/R/overlapTopLoci.R index 247fffb2..ba9846f3 100644 --- a/R/overlapTopLoci.R +++ b/R/overlapTopLoci.R @@ -30,13 +30,21 @@ # getTopLoci frame (study/context/trait/method) that carries no # variant_id; restore the join key so the empty join still resolves # instead of erroring in inner_join()'s `by` check. - if (!is_in("variant_id", names(qp))) { - qp$variant_id <- character(0) - } - if (!is_in("variant_id", names(gp))) { - gp$variant_id <- character(0) + inner_join( + .overlapWithJoinKey(qp), + .overlapWithJoinKey(gp), + by = "variant_id" + ) +} + +# The join key, restored as an empty column when the frame carries no signal +# and so never got one. +# @noRd +.overlapWithJoinKey <- function(tl) { + if (is_in("variant_id", names(tl))) { + return(tl) } - inner_join(qp, gp, by = "variant_id") + mutate(tl, variant_id = character(0)) } # Convert the merged frame to the requested output type. @@ -158,20 +166,32 @@ setMethod( # helper columns. # @noRd .overlapRelabelGwas <- function(gwasTl, vmap, coordCols) { - g <- inner_join(gwasTl, vmap, by = c("variant_id" = "gwas_vid")) + joined <- inner_join(gwasTl, vmap, by = c("variant_id" = "gwas_vid")) signedCols <- c("beta", "z", "conditional_effect") # Bound with partial() rather than across()'s deprecated `...`; the local # matters because partial() resolves it lazily (see .negateWhere et al). - rowSign <- g$.sign - g <- mutate( - g, + rowSign <- joined$.sign + signed <- mutate( + joined, across(any_of(signedCols), partial(.overlapApplySign, sign = rowSign)) ) - if (is_in("af", names(g))) { - g$af <- if_else(g$.sign < 0 & !is.na(g$af), 1 - g$af, g$af) - } - g$variant_id <- g$canon_vid - select(g, all_of(setdiff(names(g), c(coordCols, "canon_vid", ".sign")))) + relabelled <- mutate( + signed, + !!!compact(list( + af = if (is_in("af", names(signed))) { + if_else( + signed$.sign < 0 & !is.na(signed$af), + 1 - signed$af, + signed$af + ) + } + )), + variant_id = .data$canon_vid + ) + select( + relabelled, + all_of(setdiff(names(relabelled), c(coordCols, "canon_vid", ".sign"))) + ) } # Build a GRanges from an overlap table: variants as width-1 ranges, all other @@ -186,6 +206,8 @@ setMethod( seqnames = str_c("chr", p$chrom), ranges = IRanges::IRanges(start = p$pos, width = 1L) ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(df, check.names = FALSE) - gr + S4Vectors::`mcols<-`( + gr, + value = S4Vectors::DataFrame(df, check.names = FALSE) + ) } diff --git a/R/pvalCombine.R b/R/pvalCombine.R index 14fc0df0..06ba3014 100644 --- a/R/pvalCombine.R +++ b/R/pvalCombine.R @@ -38,8 +38,12 @@ NULL #' @return Numeric vector of two-sided p-values. #' @examples #' waldTestPval(beta = 0.3, se = 0.1, n = 1000) +#' @importFrom checkmate assertNumeric #' @export waldTestPval <- function(beta, se, n) { + assertNumeric(beta) + assertNumeric(se) + assertNumeric(n) # Calculate the t statistic tValue <- beta / se # Degrees of freedom @@ -61,20 +65,20 @@ pvalAcat <- function(pvals, naRm = TRUE) { # avoid Inf from floating-point precision loss in pi*0.5 # - large-stat asymptotic: when the mean Cauchy variate is > 1e15 the # CDF tail collapses to (1/T) / pi (Cauchy survival expansion) - if (naRm) { - pvals <- pvals[!is.na(pvals)] - } - if (length(pvals) == 0L) { + present <- if (naRm) pvals[!is.na(pvals)] else pvals + if (length(present) == 0L) { return(NA_real_) } - if (length(pvals) == 1L) { - return(pvals[[1]]) + if (length(present) == 1L) { + return(present[[1]]) } - pvals <- pmin(pvals, 0.99) + # Capped below 1: tan(pi * (0.5 - 1)) is -Inf, which would sink the + # combined statistic regardless of the other p-values. + capped <- pmin(present, 0.99) cauchyVals <- if_else( - pvals < 1e-15, - 1 / (pvals * pi), - tan(pi * (0.5 - pvals)) + capped < 1e-15, + 1 / (capped * pi), + tan(pi * (0.5 - capped)) ) stat <- mean(cauchyVals) if (!is.finite(stat)) { @@ -89,11 +93,7 @@ pvalAcat <- function(pvals, naRm = TRUE) { pvalHmp <- function(pvals) { # Make sure harmonicmeanp is installed if (!requireNamespace("harmonicmeanp", quietly = TRUE)) { - msg <- glue( - "To use this function, please install harmonicmeanp: ", - "https://cran.r-project.org/web/packages/harmonicmeanp/index.html" - ) - abort(msg) + abort("Package 'harmonicmeanp' is required for this function.") } # https://search.r-project.org/CRAN/refmans/harmonicmeanp/html/pLandau.html L <- length(pvals) @@ -120,11 +120,7 @@ pvalHmp <- function(pvals) { pvalPoolr <- function(pvals, method, R) { if (!requireNamespace("poolr", quietly = TRUE)) { - msg <- glue( - "To use this method, please install poolr: ", - "install.packages('poolr')" - ) - abort(msg) + abort("Package 'poolr' is required for this method.") } fn <- switch( method, @@ -138,7 +134,7 @@ pvalPoolr <- function(pvals, method, R) { pvalGbj <- function(zScores, R, method) { if (!requireNamespace("GBJ", quietly = TRUE)) { - abort("To use this method, please install GBJ: install.packages('GBJ')") + abort("Package 'GBJ' is required for this method.") } result <- switch( method, @@ -165,19 +161,13 @@ pvalGbj <- function(zScores, R, method) { pvalAspu <- function(zScores = NULL, pvals = NULL, R, method) { if (!requireNamespace("aSPU", quietly = TRUE)) { abort( - "To use this method, please install aSPU: install.packages('aSPU')" + "Package 'aSPU' is required for this method." ) } switch( method, - aspu = { - result <- aSPU::aSPUs(Zs = zScores, corSNP = R) - result$pvs["aSPUs"] - }, - gates = { - result <- aSPU::GATES2(ldmatrix = R, p = pvals) - result[["Pg"]] - }, + aspu = aSPU::aSPUs(Zs = zScores, corSNP = R)$pvs["aSPUs"], + gates = aSPU::GATES2(ldmatrix = R, p = pvals)[["Pg"]], .abortUnknownMethod("aSPU", method) ) } @@ -233,13 +223,12 @@ pvalAspu <- function(zScores = NULL, pvals = NULL, R, method) { # Internal: align an R correlation matrix to a target order. If R has # rownames/colnames, reorder to match `targetNames`; require every target # name to be present. If R is unnamed, only length check. +#' @importFrom checkmate assertMatrix .combinePvalAlignR <- function(R, targetNames) { if (is.null(R)) { return(NULL) } - if (!is.matrix(R)) { - abort("`R` must be a matrix.") - } + assertMatrix(R) if (nrow(R) != ncol(R)) { abort("`R` must be square.") } @@ -347,6 +336,7 @@ pvalAspu <- function(zScores = NULL, pvals = NULL, R, method) { #' @examples #' combinePValues(pvals = c(0.01, 0.2, 0.5), methods = "fisher", R = diag(3)) #' @export +#' @importFrom checkmate assertFlag combinePValues <- function( pvals = NULL, zScores = NULL, @@ -354,6 +344,7 @@ combinePValues <- function( R = NULL, naRm = TRUE ) { + assertFlag(naRm) methods <- .combinePvalCheckMethods(methods) nPvalsIn <- if (is.null(pvals)) 0L else length(pvals) nZScoresIn <- if (is.null(zScores)) 0L else length(zScores) @@ -517,13 +508,13 @@ combinePValues <- function( } # @noRd +#' @importFrom rlang try_fetch .combinePvalRunOne <- function(m, pvalsK, zScoresK, Raligned) { - p <- tryCatch( + p <- try_fetch( .combinePvalSingle(m, pvals = pvalsK, zScores = zScoresK, R = Raligned), - error = function(e) { - eMsg <- conditionMessage(e) - msg <- glue("combinePValues: method '{m}' failed: {eMsg}") - warn(msg) + error = function(cnd) { + msg <- glue("combinePValues: method '{m}' failed") + warn(msg, parent = cnd) NA_real_ } ) diff --git a/R/qtlAssociationPostprocess.R b/R/qtlAssociationPostprocess.R index 21bd39d4..e35ae1dc 100644 --- a/R/qtlAssociationPostprocess.R +++ b/R/qtlAssociationPostprocess.R @@ -23,21 +23,22 @@ # edge-case retries only (never a hand-rolled substitute): lambda=0 for # missing/infinite handling, bootstrap pi0 for the "pi0 <= 0" degenerate case. # Returns a numeric vector aligned to `p`. +#' @importFrom rlang try_fetch .qapSafeQvalue <- function(p) { if (!requireNamespace("qvalue", quietly = TRUE)) { # Optional-package guard; qvalue is Suggests-only. msg <- glue( "qtlAssociationPostprocess: the 'qvalue' package is required for ", - "Storey q-values. Install Bioconductor 'qvalue'." + "Storey q-values." ) abort(msg) } - tryCatch( + try_fetch( qvalue::qvalue(p)$qvalues, - error = function(e) { - if (str_detect(conditionMessage(e), "missing or infinite")) { + error = function(cnd) { + if (str_detect(conditionMessage(cnd), "missing or infinite")) { qvalue::qvalue(p, lambda = 0)$qvalues - } else if (str_detect(conditionMessage(e), "pi0 <= 0")) { + } else if (str_detect(conditionMessage(cnd), "pi0 <= 0")) { maxP <- max(p, na.rm = TRUE) lambdaSeq <- seq(0, min(0.9, maxP * 0.95), length.out = 10) qvalue::qvalue( @@ -46,12 +47,13 @@ pi0.method = "bootstrap" )$qvalues } else { + # The cause is chained via `parent`, so it is no longer + # interpolated into the message. msg <- glue( - "qtlAssociationPostprocess: qvalue::qvalue failed ", - "({conditionMessage(e)}). Not substituting a ", - "hand-rolled q-value." + "qtlAssociationPostprocess: qvalue::qvalue failed. ", + "Not substituting a hand-rolled q-value." ) - abort(msg) + abort(msg, parent = cnd) } } ) @@ -94,18 +96,18 @@ # an entry's af / tss_distance / tes_distance mcols. Shared by the correction # and the significance derivation so the filtered set is defined once. .qapFilterKeep <- function(mc, mafCutoff, cisWindow, afCol, nVar) { - keep <- rep(TRUE, nVar) - if (mafCutoff > 0 && !is.null(mc[[afCol]])) { - af <- mc[[afCol]] - keep <- keep & (pmin(af, 1 - af) > mafCutoff) + byMaf <- if (mafCutoff > 0 && !is.null(mc[[afCol]])) { + pmin(mc[[afCol]], 1 - mc[[afCol]]) > mafCutoff + } else { + rep(TRUE, nVar) } - if ( - cisWindow > 0 && !is.null(mc$tss_distance) && !is.null(mc$tes_distance) - ) { - keep <- keep & - (mc$tss_distance >= -cisWindow & mc$tes_distance <= cisWindow) + inCis <- cisWindow > 0 && + !is.null(mc$tss_distance) && + !is.null(mc$tes_distance) + if (!inCis) { + return(byMaf) } - keep + byMaf & (mc$tss_distance >= -cisWindow & mc$tes_distance <= cisWindow) } # Per-gene logical masks of significant variants under a correction method (the @@ -151,15 +153,25 @@ ) abort(msg) } - thr <- as.numeric(x$p_nominal_threshold) - for (i in seq_len(nrow(x))) { - if (is.na(thr[i])) { - next - } - pv <- S4Vectors::mcols(x[[i]])[[pcol]] - masks[[i]] <- !is.na(pv) & pv < thr[i] + map( + seq_len(nrow(x)), + .qapPermutationMaskAt, + x = x, + masks = masks, + thr = as.numeric(x$p_nominal_threshold), + pcol = pcol + ) +} + +# Entry `i`'s permutation mask, or the incoming mask when the gene has no +# threshold to apply. +# @noRd +.qapPermutationMaskAt <- function(i, x, masks, thr, pcol) { + if (is.na(thr[i])) { + return(masks[[i]]) } - masks + pv <- S4Vectors::mcols(x[[i]])[[pcol]] + !is.na(pv) & pv < thr[i] } # Bonferroni significance (original / filtered flavour): a global variant-level @@ -183,17 +195,20 @@ } # global scalar varThr <- max(as.numeric(.tupleColumn(x, pMinCol))[sig], na.rm = TRUE) - nVar <- as.numeric(.tupleColumn(x, nCol)) - for (i in seq_len(nrow(x))) { - masks[[i]] <- .qapBonferroniRowMask( - x[[i]], - recipe, - flav, - nVar[i], - varThr - ) - } - masks + map( + seq_len(nrow(x)), + .qapBonferroniMaskAt, + x = x, + recipe = recipe, + flav = flav, + nVar = as.numeric(.tupleColumn(x, nCol)), + varThr = varThr + ) +} + +# @noRd +.qapBonferroniMaskAt <- function(i, x, recipe, flav, nVar, varThr) { + .qapBonferroniRowMask(x[[i]], recipe, flav, nVar[i], varThr) } # One entry's Bonferroni keep-mask: Bonferroni-adjusted p <= the global @@ -202,9 +217,11 @@ .qapBonferroniRowMask <- function(entry, recipe, flav, nVarI, varThr) { mc <- S4Vectors::mcols(entry) pv <- mc[[recipe$pvalueCol]] - keep <- pmin(1, pv * nVarI) <= varThr - if (flav == "filtered") { - keep <- keep & + bySignificance <- pmin(1, pv * nVarI) <= varThr + keep <- if (flav != "filtered") { + bySignificance + } else { + bySignificance & .qapFilterKeep( mc, recipe$mafCutoff, @@ -219,6 +236,17 @@ # Q-value significance: per-entry mask of variant q-values below the threshold # for the FDR-significant genes. # @noRd +# Entry `i`'s q-value mask, or the incoming mask when the gene is not +# FDR-significant or carries no per-variant q-values. +# @noRd +.qapQvalueMaskAt <- function(i, x, masks, sig, threshold) { + mc <- S4Vectors::mcols(x[[i]]) + if (!isTRUE(sig[i]) || is.null(mc$qvalue)) { + return(masks[[i]]) + } + !is.na(mc$qvalue) & mc$qvalue < threshold +} + .qapMaskQvalue <- function(x, masks, threshold) { qCol <- if (!is.null(x$q_beta)) "q_beta" else "q_bonferroni_min_original" if (is.null(.tupleColumn(x, qCol))) { @@ -228,14 +256,14 @@ ) abort(msg) } - sig <- replace_na(as.numeric(.tupleColumn(x, qCol)) < threshold, FALSE) - for (i in seq_len(nrow(x))) { - mc <- S4Vectors::mcols(x[[i]]) - if (isTRUE(sig[i]) && !is.null(mc$qvalue)) { - masks[[i]] <- !is.na(mc$qvalue) & mc$qvalue < threshold - } - } - masks + map( + seq_len(nrow(x)), + .qapQvalueMaskAt, + x = x, + masks = masks, + sig = replace_na(as.numeric(.tupleColumn(x, qCol)) < threshold, FALSE), + threshold = threshold + ) } #' @rdname getSignificantQtls @@ -260,8 +288,9 @@ setMethod( ) { method <- arg_match(method) masks <- .qapSignificanceMask(x, method, threshold) - pieces <- map(seq_len(nrow(x)), .qapMaskedEntry, x = x, masks = masks) - pieces <- pieces[!map_lgl(pieces, is.null)] + pieces <- compact( + map(seq_len(nrow(x)), .qapMaskedEntry, x = x, masks = masks) + ) if (length(pieces) == 0L) { return(x[[1L]][0L]) } @@ -277,16 +306,28 @@ setMethod( # The collection is a GRangesList now, not a DFrame: the per-variant # GRanges are the elements and `newCols` are per-tuple metadata, so the # rebuild keeps the elements as-is and only rewrites mcols. - md <- mcols(x, use.names = FALSE) - for (nm in names(newCols)) { - md[[nm]] <- newCols[[nm]] + existing <- mcols(x, use.names = FALSE) + # A NULL entry in `newCols` removed that column, which is what dropping + # every named column and re-adding only the non-NULL ones reproduces. + kept <- existing[, + setdiff(colnames(existing), names(newCols)), + drop = FALSE + ] + added <- compact(newCols) + md <- if (length(added) == 0L) { + kept + } else { + cbind(kept, S4Vectors::DataFrame(added, check.names = FALSE)) } - grl <- GenomicRanges::GRangesList(as.list(x)) # Rebuilding from as.list() starts from the elements' own seqinfo, so the # build is written back explicitly -- it is collection-level state, and # there is no genome slot to carry it any more. - GenomeInfoDb::genome(grl) <- getGenome(x) - mcols(grl) <- md + built <- .withGenomeBuild( + GenomicRanges::GRangesList(as.list(x)), + TRUE, + getGenome(x) + ) + grl <- S4Vectors::`mcols<-`(built, value = md) methods::new( "QtlSumStats", grl, @@ -331,10 +372,8 @@ setMethod( multiple = TRUE ) filtering <- (mafCutoff > 0 || cisWindow > 0) - newCols <- list() - if (is_in("bonferroni", methods)) { - newCols <- c( - newCols, + newCols <- c( + if (is_in("bonferroni", methods)) { .qapBonferroniCols( x, mafCutoff, @@ -343,22 +382,25 @@ setMethod( afCol, filtering ) - ) - } - if (is_in("permutation", methods) && !is.null(x$p_beta)) { - newCols <- c(newCols, .qapPermutationCols(x, fdrThreshold)) - } + }, + if (is_in("permutation", methods) && !is.null(x$p_beta)) { + .qapPermutationCols(x, fdrThreshold) + } + ) %||% + list() # Stash the correction recipe so getSignificantQtls / # annotateSignificance can reproduce significance cheaply (thresholds, # not flags). - qc <- getQcInfo(x) - qc$associationPostprocess <- .qapRecipe( - fdrThreshold, - mafCutoff, - cisWindow, - methods, - pvalueCol, - afCol + qc <- list_assign( + getQcInfo(x), + associationPostprocess = .qapRecipe( + fdrThreshold, + mafCutoff, + cisWindow, + methods, + pvalueCol, + afCol + ) ) .qapRebuild(x, newCols, qc) } @@ -398,17 +440,20 @@ setMethod( cisWindow, filtering ) - cols <- list(p_bonferroni_min_original = perGene$orig) gaO <- .qapGlobalAdjust(perGene$orig) - cols$fdr_bonferroni_min_original <- gaO$fdr - cols$q_bonferroni_min_original <- gaO$q - if (filtering) { - cols$p_bonferroni_min_filtered <- perGene$filt - gaF <- .qapGlobalAdjust(perGene$filt) - cols$fdr_bonferroni_min_filtered <- gaF$fdr - cols$q_bonferroni_min_filtered <- gaF$q - } - cols + gaF <- if (filtering) .qapGlobalAdjust(perGene$filt) else NULL + c( + list( + p_bonferroni_min_original = perGene$orig, + fdr_bonferroni_min_original = gaO$fdr, + q_bonferroni_min_original = gaO$q + ), + compact(list( + p_bonferroni_min_filtered = if (filtering) perGene$filt, + fdr_bonferroni_min_filtered = gaF$fdr, + q_bonferroni_min_filtered = gaF$q + )) + ) } # The n_variants row column is mandatory for the Bonferroni correction. @@ -428,42 +473,69 @@ setMethod( # pre-filter always retains the global-min variant, so the min over the entry is # the exact per-gene min. Returns list(orig, filt). # @noRd -.qapBonferroniPerGene <- function( +# One gene's Bonferroni-adjusted minimum p-value, before and after the +# variant filter. NA on either side means the gene had nothing to adjust. +# @noRd +.qapBonferroniForGene <- function( + i, x, + pvalueCol, nVar, nVarFilt, - pvalueCol, afCol, mafCutoff, cisWindow, filtering ) { - n <- nrow(x) - pBonfOrig <- rep(NA_real_, n) - pBonfFilt <- rep(NA_real_, n) - for (i in seq_len(n)) { - mc <- S4Vectors::mcols(x[[i]]) - pv <- mc[[pvalueCol]] - if (is.null(pv) || length(pv) == 0L) { - next - } - pBonfOrig[i] <- min(stats::p.adjust( - pv, + mc <- S4Vectors::mcols(x[[i]]) + pv <- mc[[pvalueCol]] + if (is.null(pv) || length(pv) == 0L) { + return(list(orig = NA_real_, filt = NA_real_)) + } + orig <- min(stats::p.adjust(pv, method = "bonferroni", n = nVar[i])) + if (!filtering) { + return(list(orig = orig, filt = NA_real_)) + } + keep <- .qapFilterKeep(mc, mafCutoff, cisWindow, afCol, length(pv)) + if (!any(keep)) { + return(list(orig = orig, filt = NA_real_)) + } + list( + orig = orig, + filt = min(stats::p.adjust( + pv[keep], method = "bonferroni", - n = nVar[i] + n = nVarFilt[i] )) - if (filtering) { - keep <- .qapFilterKeep(mc, mafCutoff, cisWindow, afCol, length(pv)) - if (any(keep)) { - pBonfFilt[i] <- min(stats::p.adjust( - pv[keep], - method = "bonferroni", - n = nVarFilt[i] - )) - } - } - } - list(orig = pBonfOrig, filt = pBonfFilt) + ) +} + +.qapBonferroniPerGene <- function( + x, + nVar, + nVarFilt, + pvalueCol, + afCol, + mafCutoff, + cisWindow, + filtering +) { + perGene <- map( + seq_len(nrow(x)), + .qapBonferroniForGene, + x = x, + pvalueCol = pvalueCol, + nVar = nVar, + nVarFilt = nVarFilt, + afCol = afCol, + mafCutoff = mafCutoff, + cisWindow = cisWindow, + filtering = filtering + ) + list( + orig = map_dbl(perGene, "orig"), + filt = map_dbl(perGene, "filt") + ) } # Permutation columns: BH-FDR of p_beta, the Storey q-value (q_beta, when @@ -476,21 +548,23 @@ setMethod( } else { .qapSafeQvalue(pBeta) } - cols <- list() - if (is.null(x$q_beta)) { - cols$q_beta <- qBeta - } - cols$fdr_beta <- stats::p.adjust(pBeta, method = "fdr") - if (!is.null(x$beta_shape1) && !is.null(x$beta_shape2)) { - cols$p_nominal_threshold <- .qapPermutationNominalThreshold( - pBeta, - qBeta, - as.numeric(x$beta_shape1), - as.numeric(x$beta_shape2), - fdrThreshold - ) - } - cols + c( + compact(list(q_beta = if (is.null(x$q_beta)) qBeta)), + list(fdr_beta = stats::p.adjust(pBeta, method = "fdr")), + compact(list( + p_nominal_threshold = if ( + !is.null(x$beta_shape1) && !is.null(x$beta_shape2) + ) { + .qapPermutationNominalThreshold( + pBeta, + qBeta, + as.numeric(x$beta_shape1), + as.numeric(x$beta_shape2), + fdrThreshold + ) + } + )) + ) } # The significance recipe stashed for cheap downstream re-derivation. @@ -529,8 +603,15 @@ setMethod( if (length(gr) == 0L) { return(NULL) } - gr$study <- as.character(x$study)[i] - gr$context <- as.character(x$context)[i] - gr$trait <- as.character(x$trait)[i] - gr + S4Vectors::`mcols<-`( + gr, + value = cbind( + mcols(gr, use.names = FALSE), + S4Vectors::DataFrame( + study = as.character(x$study)[i], + context = as.character(x$context)[i], + trait = as.character(x$trait)[i] + ) + ) + ) } diff --git a/R/qtlEnrichmentPipeline.R b/R/qtlEnrichmentPipeline.R index 9519f616..75bd85cb 100644 --- a/R/qtlEnrichmentPipeline.R +++ b/R/qtlEnrichmentPipeline.R @@ -55,7 +55,9 @@ #' @param seed Integer or \code{NULL}. Base random seed forwarded to #' \code{\link{qtlEnrichment}} for reproducible multiple imputation. #' \code{NULL} (default) draws a nondeterministic seed. -#' @param ... Additional arguments forwarded to \code{\link{qtlEnrichment}}. +#' @param verbose Logical. Print progress messages. Default \code{TRUE}. +#' @param enrichmentArgs Optional named list of options forwarded to +#' \code{\link{qtlEnrichment}}. #' @return A tibble with one row per (outcome trait, annotation unit) pair. #' The identity columns are \code{gwasStudy}, \code{gwasContext}, #' \code{gwasTrait}, \code{qtlStudy}, \code{qtlContext}; the axes a side does @@ -93,39 +95,46 @@ qtlEnrichmentPipeline <- function( impN = 25, numThreads = 1L, seed = NULL, - ... + verbose = TRUE, + enrichmentArgs = list() ) { .enrValidateInputs(gwasFineMappingResult, qtlFineMappingResult) - p <- as.list(environment()) - p$dots <- list(...) - p <- .enrPrepare(p) + prep <- .enrPrepare(gwasFineMappingResult, qtlFineMappingResult) + gwasTuples <- prep$gwasTuples + qtlTuples <- prep$qtlTuples + alignedByTuple <- prep$alignedByTuple results <- list_flatten(map( - seq_len(nrow(p$gwasTuples)), + seq_len(nrow(gwasTuples)), .enrScoreOutcomeTuple, - p = p + gwasPipByTuple = prep$gwasPipByTuple, + qtlRegionsByTuple = prep$qtlRegionsByTuple, + alignedByTuple = alignedByTuple, + numGwas = numGwas, + piQtl = piQtl, + lambda = lambda, + impN = impN, + numThreads = numThreads, + seed = seed, + verbose = verbose, + enrichmentArgs = enrichmentArgs, + gwasFineMappingResult = gwasFineMappingResult, + gwasTuples = gwasTuples, + qtlFineMappingResult = qtlFineMappingResult, + qtlTuples = qtlTuples )) .enrAssemble(results) } # Validate the input classes + LD-sketch presence / identity. # @noRd +#' @importFrom checkmate assertMultiClass .enrValidateInputs <- function(gwasFineMappingResult, qtlFineMappingResult) { - if (!methods::is(gwasFineMappingResult, "FineMappingResultBase")) { - msg <- glue( - "`gwasFineMappingResult` must be a GwasFineMappingResult or a ", - "QtlFineMappingResult ", - "(got class '{class(gwasFineMappingResult)[[1L]]}')." - ) - abort(msg) - } - if (!methods::is(qtlFineMappingResult, "FineMappingResultBase")) { - msg <- glue( - "`qtlFineMappingResult` must be a QtlFineMappingResult or a ", - "GwasFineMappingResult ", - "(got class '{class(qtlFineMappingResult)[[1L]]}')." - ) - abort(msg) - } + # assertMultiClass rather than assertClass on the virtual parent: naming + # both concrete subclasses is more use to a caller than + # "FineMappingResultBase", and these two are its only subclasses. + fmrClasses <- c("GwasFineMappingResult", "QtlFineMappingResult") + assertMultiClass(gwasFineMappingResult, fmrClasses) + assertMultiClass(qtlFineMappingResult, fmrClasses) outcomeLd <- getLdSketch(gwasFineMappingResult) if ( is.null(outcomeLd) && @@ -154,38 +163,41 @@ qtlEnrichmentPipeline <- function( # each tuple's one-time alignment to the union panel (errors captured as # values). # @noRd -.enrPrepare <- function(p) { - p$gwasTuples <- .enrOutcomeTuples(p$gwasFineMappingResult) - p$qtlTuples <- .enrAnnotationTuples(p$qtlFineMappingResult) - if (nrow(p$gwasTuples) == 0L || nrow(p$qtlTuples) == 0L) { +.enrPrepare <- function(gwasFineMappingResult, qtlFineMappingResult) { + gwasTuples <- .enrOutcomeTuples(gwasFineMappingResult) + qtlTuples <- .enrAnnotationTuples(qtlFineMappingResult) + if (nrow(gwasTuples) == 0L || nrow(qtlTuples) == 0L) { msg <- glue( "qtlEnrichmentPipeline: no (outcome, annotation) pairs to ", "compute (one of the inputs has zero rows)." ) abort(msg) } - p$gwasPipByTuple <- map( - seq_len(nrow(p$gwasTuples)), + gwasPipByTuple <- map( + seq_len(nrow(gwasTuples)), .enrGwasPipForRow, - gwasTuples = p$gwasTuples, - fmr = p$gwasFineMappingResult + gwasTuples = gwasTuples, + fmr = gwasFineMappingResult ) - unionGwasNames <- unique(unlist( - map(p$gwasPipByTuple, names), - use.names = FALSE - )) - p$qtlRegionsByTuple <- map( - seq_len(nrow(p$qtlTuples)), + unionGwasNames <- unique(unname(list_c(map(gwasPipByTuple, names)))) + qtlRegionsByTuple <- map( + seq_len(nrow(qtlTuples)), .enrQtlRegionsForRow, - qtlTuples = p$qtlTuples, - fmr = p$qtlFineMappingResult + qtlTuples = qtlTuples, + fmr = qtlFineMappingResult ) - p$alignedByTuple <- map( - p$qtlRegionsByTuple, + alignedByTuple <- map( + qtlRegionsByTuple, .enrAlignRegionsSafe, unionGwasNames = unionGwasNames ) - p + list( + gwasTuples = gwasTuples, + qtlTuples = qtlTuples, + gwasPipByTuple = gwasPipByTuple, + qtlRegionsByTuple = qtlRegionsByTuple, + alignedByTuple = alignedByTuple + ) } # The outcome side's per-trait keys: one PIP vector is built per key. A GWAS @@ -264,82 +276,167 @@ qtlEnrichmentPipeline <- function( # Align one tuple's regions to the union GWAS panel, capturing any error as a # value (re-raised + skipped per (gwas, tuple) below, never aborting). # @noRd +#' @importFrom rlang try_fetch .enrAlignRegionsSafe <- function(regions, unionGwasNames) { - tryCatch( + try_fetch( .enrAlignRegions(regions, unionGwasNames), - error = function(e) e + error = function(cnd) cnd ) } # Score one outcome trait against every annotation tuple -> enrichment records # (empty when the outcome has no usable PIPs). # @noRd -.enrScoreOutcomeTuple <- function(gi, p) { - gwasPip <- p$gwasPipByTuple[[gi]] +.enrScoreOutcomeTuple <- function( + gi, + gwasPipByTuple, + qtlRegionsByTuple, + alignedByTuple = alignedByTuple, + numGwas = numGwas, + piQtl = piQtl, + lambda = lambda, + impN = impN, + numThreads = numThreads, + seed = seed, + verbose = verbose, + enrichmentArgs = enrichmentArgs, + gwasFineMappingResult = gwasFineMappingResult, + gwasTuples = gwasTuples, + qtlFineMappingResult = qtlFineMappingResult, + qtlTuples = qtlTuples +) { + gwasPip <- gwasPipByTuple[[gi]] if (length(gwasPip) == 0L) { msg <- glue( "qtlEnrichmentPipeline: no usable PIPs for ", - "{.enrOutcomeLabel(p, gi)}; skipping." + "{.enrOutcomeLabel(gwasFineMappingResult, gwasTuples, gi)}; ", + "skipping." ) warn(msg) return(list()) } compact(map( - seq_len(nrow(p$qtlTuples)), + seq_len(nrow(qtlTuples)), .enrScoreTuple, gi = gi, gwasPip = gwasPip, - p = p + qtlRegionsByTuple = qtlRegionsByTuple, + alignedByTuple = alignedByTuple, + numGwas = numGwas, + piQtl = piQtl, + lambda = lambda, + impN = impN, + numThreads = numThreads, + seed = seed, + verbose = verbose, + enrichmentArgs = enrichmentArgs, + gwasFineMappingResult = gwasFineMappingResult, + gwasTuples = gwasTuples, + qtlFineMappingResult = qtlFineMappingResult, + qtlTuples = qtlTuples )) } # Score one (outcome trait, annotation tuple) pair -> an enrichment record, or # NULL when the tuple has no regions or qtlEnrichment fails. # @noRd -.enrScoreTuple <- function(k, gi, gwasPip, p) { - if (length(p$qtlRegionsByTuple[[k]]) == 0L) { +.enrScoreTuple <- function( + k, + gi, + gwasPip, + qtlRegionsByTuple, + alignedByTuple = alignedByTuple, + numGwas = numGwas, + piQtl = piQtl, + lambda = lambda, + impN = impN, + numThreads = numThreads, + seed = seed, + verbose = verbose, + enrichmentArgs = enrichmentArgs, + gwasFineMappingResult = gwasFineMappingResult, + gwasTuples = gwasTuples, + qtlFineMappingResult = qtlFineMappingResult, + qtlTuples = qtlTuples +) { + if (length(qtlRegionsByTuple[[k]]) == 0L) { msg <- glue( "qtlEnrichmentPipeline: no usable regions for ", - "{.enrAnnotationLabel(p, k)}; skipping." + "{.enrAnnotationLabel(qtlFineMappingResult, qtlTuples, k)}; ", + "skipping." ) warn(msg) return(NULL) } - enr <- .enrRunEnrichment(gi, gwasPip, k, p) + enr <- .enrRunEnrichment( + gi, + gwasPip, + k, + alignedByTuple = alignedByTuple, + numGwas = numGwas, + piQtl = piQtl, + lambda = lambda, + impN = impN, + numThreads = numThreads, + seed = seed, + verbose = verbose, + enrichmentArgs = enrichmentArgs, + gwasFineMappingResult = gwasFineMappingResult, + gwasTuples = gwasTuples, + qtlFineMappingResult = qtlFineMappingResult, + qtlTuples = qtlTuples + ) if (is.null(enr)) { return(NULL) } c( .enrFlattenEnrichment(enr), - as.list(p$gwasTuples[gi, , drop = FALSE]), - as.list(p$qtlTuples[k, , drop = FALSE]) + as.list(gwasTuples[gi, , drop = FALSE]), + as.list(qtlTuples[k, , drop = FALSE]) ) } # Human-readable identities for the warnings above, naming each side by its own # flavour and only the axes it has. # @noRd -.enrOutcomeLabel <- function(p, gi) { +.enrOutcomeLabel <- function(gwasFineMappingResult, gwasTuples, gi) { .fmrTupleLabel( - .fmrSideName(p$gwasFineMappingResult), - .enrOutcomeIdent(p$gwasTuples, gi) + .fmrSideName(gwasFineMappingResult), + .enrOutcomeIdent(gwasTuples, gi) ) } # @noRd -.enrAnnotationLabel <- function(p, k) { +.enrAnnotationLabel <- function(qtlFineMappingResult, qtlTuples, k) { .fmrTupleLabel( - .fmrSideName(p$qtlFineMappingResult), - .enrAnnotationIdent(p$qtlTuples, k) + .fmrSideName(qtlFineMappingResult), + .enrAnnotationIdent(qtlTuples, k) ) } # Run qtlEnrichment for a pair (with the pre-aligned regions), warning + NULL on # failure. alignNames = FALSE reuses the shared per-tuple alignment. # @noRd -.enrRunEnrichment <- function(gi, gwasPip, k, p) { - aligned <- p$alignedByTuple[[k]] - tryCatch( +.enrRunEnrichment <- function( + gi, + gwasPip, + k, + alignedByTuple, + numGwas, + piQtl, + lambda, + impN, + numThreads, + seed, + verbose, + enrichmentArgs, + gwasFineMappingResult, + gwasTuples, + qtlFineMappingResult, + qtlTuples +) { + aligned <- alignedByTuple[[k]] + try_fetch( { if (inherits(aligned, "condition")) { cnd_signal(aligned) @@ -348,24 +445,26 @@ qtlEnrichmentPipeline <- function( list( gwasPip = gwasPip, susieQtlRegions = aligned, - numGwas = p$numGwas, - piQtl = p$piQtl, - lambda = p$lambda, - impN = p$impN, - numThreads = p$numThreads, - seed = p$seed, + numGwas = numGwas, + piQtl = piQtl, + lambda = lambda, + impN = impN, + numThreads = numThreads, + seed = seed, + verbose = verbose, alignNames = FALSE ), - p$dots + enrichmentArgs ) exec(qtlEnrichment, !!!enrichArgs) }, - error = function(e) { - eMsg <- conditionMessage(e) + error = function(cnd) { + eMsg <- conditionMessage(cnd) msg <- glue( "qtlEnrichmentPipeline: qtlEnrichment failed for ", - "{.enrOutcomeLabel(p, gi)} x ", - "{.enrAnnotationLabel(p, k)}: {eMsg}" + "{.enrOutcomeLabel(gwasFineMappingResult, gwasTuples, gi)} x ", + "{.enrAnnotationLabel(qtlFineMappingResult, qtlTuples, k)}: ", + "{eMsg}" ) warn(msg) NULL @@ -426,38 +525,37 @@ qtlEnrichmentPipeline <- function( # would collide on every variant they share. #' @importFrom dplyr add_count #' @noRd +# One row's PIP vector keyed by variant id, or NULL when the row carries no +# fit, no PIPs, or ids that do not line up with them. +# @noRd +.enrRowPipVector <- function(i, gwasFmr) { + parts <- .fmrRowParts(gwasFmr, i) + fit <- getSusieFit(parts) + if (is.null(fit) || is.null(fit$pip)) { + return(NULL) + } + pip <- as.numeric(fit$pip) + ids <- names(fit$pip) %||% .fmrPartsVariantIds(parts) + if (length(ids) != length(pip)) { + return(NULL) + } + set_names(pip, as.character(ids)) +} + .enrBuildGwasPipVector <- function(gwasFmr, ident) { idx <- .enrMatchRows(gwasFmr, ident) if (length(idx) == 0L) { return(numeric(0)) } - pieces <- list() - for (i in idx) { - parts <- .fmrRowParts(gwasFmr, i) - fit <- getSusieFit(parts) - if (is.null(fit) || is.null(fit$pip)) { - next - } - pip <- as.numeric(fit$pip) - ids <- if (!is.null(names(fit$pip))) { - names(fit$pip) - } else { - .fmrPartsVariantIds(parts) - } - if (length(ids) != length(pip)) { - next - } - pieces[[length(pieces) + 1L]] <- - set_names(pip, as.character(ids)) - } + pieces <- compact(map(idx, .enrRowPipVector, gwasFmr = gwasFmr)) if (length(pieces) == 0L) { return(numeric(0)) } - all <- unlist(pieces) - if (n_distinct(names(all)) < length(all)) { - all <- .enrCollapseDuplicatePips(all) + combined <- list_c(pieces) + if (n_distinct(names(combined)) == length(combined)) { + return(combined) } - all + .enrCollapseDuplicatePips(combined) } # Collapse duplicate variant ids across GWAS blocks: agreeing PIPs (rounded to @@ -494,33 +592,31 @@ qtlEnrichmentPipeline <- function( if (length(idx) == 0L) { return(list()) } - out <- list() - for (i in idx) { - parts <- .fmrRowParts(qtlFmr, i) - fit <- getSusieFit(parts) - if (is.null(fit) || is.null(fit$alpha) || is.null(fit$pip)) { - next - } - pV <- if (!is.null(fit$V)) { - fit$V - } else if (!is.null(fit$prior_variance)) { - fit$prior_variance - } else { - NULL - } - if (is.null(pV)) { - next - } - if (is.null(names(fit$pip))) { - names(fit$pip) <- .fmrPartsVariantIds(parts) - } - out[[length(out) + 1L]] <- list( - alpha = fit$alpha, - pip = fit$pip, - prior_variance = pV - ) + compact(map(idx, .enrRowRegion, qtlFmr = qtlFmr)) +} + +# One row's region payload for qtlEnrichment, or NULL when the row lacks a +# fit, an alpha, PIPs, or a prior variance. The PIP names fall back to the +# row's own variant ids when the fit did not carry any. +# @noRd +.enrRowRegion <- function(i, qtlFmr) { + parts <- .fmrRowParts(qtlFmr, i) + fit <- getSusieFit(parts) + if (is.null(fit) || is.null(fit$alpha) || is.null(fit$pip)) { + return(NULL) + } + priorVariance <- fit$V %||% fit$prior_variance + if (is.null(priorVariance)) { + return(NULL) } - out + list( + alpha = fit$alpha, + pip = set_names( + fit$pip, + names(fit$pip) %||% .fmrPartsVariantIds(parts) + ), + prior_variance = priorVariance + ) } # Pull one enrichment field from qtlEnrichment's list output as a scalar numeric @@ -736,8 +832,7 @@ qtlEnrichment <- function( numThreads = as.integer(numThreads), seed = if (is.null(seed)) NULL else as.integer(seed) ) - en$unused_xqtl_variants <- unmatchedVariants - en + list_assign(en, unused_xqtl_variants = unmatchedVariants) } # piGwas = sum(gwasPip) / numGwas (estimated from the data, with a warning, when @@ -747,17 +842,15 @@ qtlEnrichment <- function( if (!is.null(numGwas)) { return(sum(gwasPip) / numGwas) } - msg <- glue( + warn(glue( "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." - ) - warn(msg) + )) piGwas <- sum(gwasPip) / length(gwasPip) if (verbose) { piGwasR <- round(piGwas, 5) - msg <- glue("Estimated piGwas: {piGwasR}\n", .trim = FALSE) - inform(msg) + inform(glue("Estimated piGwas: {piGwasR}\n", .trim = FALSE)) } piGwas } @@ -776,12 +869,11 @@ qtlEnrichment <- function( "variables inside of credible sets or signal clusters." ) warn(msg) - allPips <- unlist(map(susieQtlRegions, "pip")) + allPips <- list_c(map(susieQtlRegions, "pip")) piQtl <- sum(allPips) / length(allPips) if (verbose) { piQtlR <- round(piQtl, 5) - msg <- glue("Estimated piQtl: {piQtlR}\n", .trim = FALSE) - inform(msg) + inform(glue("Estimated piQtl: {piQtlR}\n", .trim = FALSE)) } piQtl } @@ -848,14 +940,17 @@ qtlEnrichment <- function( # @noRd .enrAlignRegionByMatch <- function(x, gwasPip) { 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 + nm <- replace(names(x$pip), mm$idxA, names(gwasPip)[mm$idxB]) + aligned <- list_assign(x, pip = set_names(x$pip, nm)) + unmatchedIdx <- setdiff(seq_along(aligned$pip), mm$idxA) + list_assign( + aligned, + !!!compact(list( + unmatched_variants = if (length(unmatchedIdx) > 0) { + names(aligned$pip)[unmatchedIdx] + } + )) + ) } # Record the region's variants absent from the GWAS name set (cheap membership @@ -863,17 +958,20 @@ qtlEnrichment <- function( # @noRd .enrMarkUnmatched <- function(x, gwasNameSet) { unmatchedIdx <- which(!is_in(names(x$pip), gwasNameSet)) - if (length(unmatchedIdx) > 0) { - x$unmatched_variants <- names(x$pip)[unmatchedIdx] - } - x + list_assign( + x, + !!!compact(list( + unmatched_variants = if (length(unmatchedIdx) > 0) { + names(x$pip)[unmatchedIdx] + } + )) + ) } # Drop the transient unmatched_variants field from a region. # @noRd .enrStripUnmatched <- function(x) { - x$unmatched_variants <- NULL - x + list_modify(x, unmatched_variants = zap()) } # Relabel one region's matched pip names to the union GWAS panel (unmatched @@ -882,9 +980,8 @@ qtlEnrichment <- function( .enrAlignRegion <- function(x, unionGwasNames) { if (!is.null(names(x$pip)) && length(unionGwasNames) > 0L) { mm <- matchVariants(names(x$pip), unionGwasNames) - nm <- names(x$pip) - nm[mm$idxA] <- unionGwasNames[mm$idxB] - names(x$pip) <- nm + nm <- replace(names(x$pip), mm$idxA, unionGwasNames[mm$idxB]) + return(list_assign(x, pip = set_names(x$pip, nm))) } x } diff --git a/R/qtlSumStats.R b/R/qtlSumStats.R index a962b5f0..a325b253 100644 --- a/R/qtlSumStats.R +++ b/R/qtlSumStats.R @@ -36,39 +36,25 @@ setClass( # Collect all contract violations (empty vector = valid). The per-entry checks # run only once the basic slot/column checks pass (they assume those columns). # @noRd +#' @importFrom checkmate makeAssertCollection assertNames .validateQtlSumStats <- function(object) { - errors <- c( - .qssCheckLdSketch(object), - .qssCheckRequiredCols(object), - .qssCheckGenome(object), - .qssCheckQcInfo(object), - .validateTraitPosColumn(object) + coll <- makeAssertCollection() + # `names(object)` is element names on a RangedTupleList, so the required + # metadata columns are read from mcols directly. + assertNames( + colnames(mcols(object)) %||% character(0), + must.include = c("study", "context", "trait"), + what = "colnames", + .var.name = "mcols", + add = coll ) - if (length(errors) == 0L) { - errors <- .qssCheckEntries(object) + coll$push(.qssCheckGenome(object)) + coll$push(.validateTraitPosColumn(object)) + if (!coll$isEmpty()) { + return(coll$getMessages()) } - if (length(errors) == 0L) TRUE else errors -} - -# ldSketch must be a GenotypeHandle or NULL. -# @noRd -.qssCheckLdSketch <- function(object) { - # The slot's class union enforces the type; nothing to check. - NULL -} - -# The study/context/trait metadata columns must be present. `names(object)` is -# element names on a RangedTupleList, so the check reads mcols directly. -# @noRd -.qssCheckRequiredCols <- function(object) { - missingCols <- setdiff( - c("study", "context", "trait"), - colnames(mcols(object)) - ) - if (length(missingCols) > 0L) { - return(str_c("missing columns: ", str_flatten(missingCols, ", "))) - } - NULL + coll$push(.qssCheckEntries(object)) + coll$getMessages() } # The genome build, read from seqinfo (there is no genome slot). @@ -77,13 +63,6 @@ setClass( .sumStatsCheckGenome(object) } -# qcInfo slot must be a list. -# @noRd -.qssCheckQcInfo <- function(object) { - # The slot's declared type enforces this; nothing to check. - NULL -} - # Element contract. The elements ARE GRanges by construction now -- the # container is a GRangesList -- and RangedTupleList's validity enforces the # one-seqname/one-strand invariant, so only tuple uniqueness is left to check. @@ -189,10 +168,10 @@ QtlSumStats <- function( n <- length(study) varY <- .qssValidateArgs(context, trait, entry, genome, varY, n) entry <- .qssAddTraitDistances(entry, traitPos, n) - cols <- .qssBaseCols(study, context, trait, varY) - cols <- .qssAppendNSample(cols, nSample, n) - cols <- .appendTraitPosCol(cols, traitPos, n) - cols <- .qssAppendExtras(cols, list(...)) + cols <- .qssBaseCols(study, context, trait, varY) |> + .qssAppendNSample(nSample, n) |> + .appendTraitPosCol(traitPos, n) |> + .qssAppendExtras(list(...)) dfArgs <- c(cols, list(check.names = FALSE)) # The per-tuple GRanges become the collection's ELEMENTS; the tuple keys # and per-tuple scalars go in mcols. There is no `entry` column. @@ -202,9 +181,11 @@ QtlSumStats <- function( # A multi-seqname entry (e.g. a genome-wide GWAS) is split into one # element per chromosome, with its metadata row replicated alongside. split <- .rtlSplitBySeqname(entry) - grl <- GenomicRanges::GRangesList(split$entry) md <- exec(S4Vectors::DataFrame, !!!dfArgs) - mcols(grl) <- md[split$fromIdx, , drop = FALSE] + grl <- S4Vectors::`mcols<-`( + GenomicRanges::GRangesList(split$entry), + value = md[split$fromIdx, , drop = FALSE] + ) .sumStatsNewValidated("QtlSumStats", grl, ldSketch, genome, qcInfo) } @@ -283,17 +264,16 @@ QtlSumStats <- function( if (is.null(nSample)) { return(cols) } - cols$nSample <- as.numeric(.qssRecycleTo(nSample, n, "nSample")) - cols + c( + cols, + list(nSample = as.numeric(.qssRecycleTo(nSample, n, "nSample"))) + ) } # Append any user-supplied extra columns (from `...`). # @noRd .qssAppendExtras <- function(cols, extras) { - for (nm in names(extras)) { - cols[[nm]] <- extras[[nm]] - } - cols + c(cols, extras) } # Annotate each entry's variants with tss_distance / tes_distance from the @@ -321,6 +301,7 @@ QtlSumStats <- function( # Internal: resolve a (study, context, trait) tuple to its element indices. # Returns a VECTOR: a tuple whose entry spanned several chromosomes was split # into one element per seqname at construction. +#' @importFrom checkmate assertVector .qtlSumStatsSelectRow <- function(x, study, context, trait) { if (nrow(x) == 0L) { abort("QtlSumStats has no rows.") @@ -341,9 +322,9 @@ QtlSumStats <- function( ) abort(msg) } - if (length(study) != 1L || length(context) != 1L || length(trait) != 1L) { - abort("`study`, `context`, and `trait` must each be length 1.") - } + assertVector(study, len = 1L) + assertVector(context, len = 1L) + assertVector(trait, len = 1L) .qssMatchTuple(x, study, context, trait) } @@ -405,8 +386,10 @@ setMethod( ... ) { idx <- .qtlSumStatsSelectRow(x, study, context, trait) - gr <- .ssStitchElements(x, idx, ranges) - if (!is.null(annotateSignificance)) { + stitched <- .ssStitchElements(x, idx, ranges) + gr <- if (is.null(annotateSignificance)) { + stitched + } else { m <- arg_match( annotateSignificance, c( @@ -416,10 +399,14 @@ setMethod( "qvalue" ) ) - S4Vectors::mcols(gr)[["significant"]] <- .qapSignificanceMask( - x, - m - )[[idx]] + S4Vectors::`mcols<-`( + stitched, + value = `[[<-`( + S4Vectors::mcols(stitched, use.names = FALSE), + "significant", + value = .qapSignificanceMask(x, m)[[idx]] + ) + ) } gr } @@ -559,14 +546,17 @@ setMethod("show", "QtlSumStats", function(object) { # that row count away, so the assignment below died with "n elements in # value to replace 0 elements" for any entry without mcols. mc <- S4Vectors::mcols(gr) - if (is.null(mc[["tss_distance"]])) { - mc[["tss_distance"]] <- pos - tssPos - } - if (is.null(mc[["tes_distance"]])) { - mc[["tes_distance"]] <- pos - tesPos + added <- compact(list( + tss_distance = if (is.null(mc[["tss_distance"]])) pos - tssPos, + tes_distance = if (is.null(mc[["tes_distance"]])) pos - tesPos + )) + if (length(added) == 0L) { + return(gr) } - S4Vectors::mcols(gr) <- mc - gr + S4Vectors::`mcols<-`( + gr, + value = cbind(mc, exec(S4Vectors::DataFrame, !!!added)) + ) } # Entry `i` of a SumStats collection restricted to chromosome `chrName`. Shared diff --git a/R/regularizedRegressionWrappers.R b/R/regularizedRegressionWrappers.R index 39dbdd03..6dd100cc 100644 --- a/R/regularizedRegressionWrappers.R +++ b/R/regularizedRegressionWrappers.R @@ -11,7 +11,8 @@ #' @param w0 Numeric vector of prior mixture weights (summing to 1). #' @param z Optional numeric vector of z-scores; defaults to \code{numeric(0)} #' (derived from \code{stat}). -#' @param ... Additional arguments forwarded to \code{mr.ash.rss}. +#' @param methodArgs Optional named list of options forwarded to +#' \code{mr.ash.rss}. #' @return A numeric vector of the posterior mean of the coefficients. #' @importFrom susieR mr.ash.rss #' @examples @@ -25,6 +26,7 @@ #' seb = vapply(ss, `[`, numeric(1), 2L), n = rep(nrow(X), ncol(X))) #' mrashRssWeights(stat, cor(X), varY = var(y), sigma2E = var(y), #' s0 = c(0, 0.1, 0.5), w0 = c(0.8, 0.1, 0.1)) +#' @importFrom checkmate assertList assertNumeric #' @export mrashRssWeights <- function( stat, @@ -34,20 +36,25 @@ mrashRssWeights <- function( s0, w0, z = numeric(0), - ... + methodArgs = list() ) { - model <- mr.ash.rss( - bhat = stat$b, - shat = stat$seb, - z = z, - R = LD, - var_y = varY, - n = median(stat$n), - sigma2_e = sigma2E, - s0 = s0, - w0 = w0, - ... + assertList(stat) + assertNumeric(z) + callArgs <- list_modify( + list( + bhat = stat$b, + shat = stat$seb, + z = z, + R = LD, + var_y = varY, + n = median(stat$n), + sigma2_e = sigma2E, + s0 = s0, + w0 = w0 + ), + !!!methodArgs ) + model <- exec(mr.ash.rss, !!!callArgs) return(model$mu1) } @@ -174,7 +181,7 @@ prsCs <- function( #' sizes) and \code{n} (per-variant sample sizes). #' @param LD Numeric LD (correlation) matrix aligned to the variants in #' \code{stat}. -#' @param ... Additional arguments forwarded to \code{prsCs}. +#' @param methodArgs Optional named list of options forwarded to \code{prsCs}. #' @return A numeric vector of the posterior SNP coefficients. #' @examples #' data(eqtlRegionExample) @@ -188,10 +195,14 @@ prsCs <- function( #' n = rep(nrow(X), ncol(X)) #' ) #' LD <- cor(X) -#' prsCsWeights(stat, LD, maf = rep(0.3, ncol(X))) +#' prsCsWeights(stat, LD, methodArgs = list(maf = rep(0.3, ncol(X)))) #' @export -prsCsWeights <- function(stat, LD, ...) { - model <- prsCs(bhat = stat$b, R = LD, n = median(stat$n), ...) +prsCsWeights <- function(stat, LD, methodArgs = list()) { + callArgs <- list_modify( + list(bhat = stat$b, R = LD, n = median(stat$n)), + !!!methodArgs + ) + model <- exec(prsCs, !!!callArgs) return(model$betaEst) } @@ -349,7 +360,7 @@ sdpr <- function( #' sizes) and \code{n} (per-variant sample sizes). #' @param LD Numeric LD (correlation) matrix aligned to the variants in #' \code{stat}. -#' @param ... Additional arguments forwarded to \code{sdpr}. +#' @param methodArgs Optional named list of options forwarded to \code{sdpr}. #' @return A numeric vector of the posterior SNP coefficients. #' @examples #' data(eqtlRegionExample) @@ -365,8 +376,12 @@ sdpr <- function( #' LD <- cor(X) #' sdprWeights(stat, LD) #' @export -sdprWeights <- function(stat, LD, ...) { - model <- sdpr(bhat = stat$b, R = LD, n = median(stat$n), ...) +sdprWeights <- function(stat, LD, methodArgs = list()) { + callArgs <- list_modify( + list(bhat = stat$b, R = LD, n = median(stat$n)), + !!!methodArgs + ) + model <- exec(sdpr, !!!callArgs) return(model$betaEst) } @@ -391,7 +406,8 @@ sdprWeights <- function(stat, LD, ...) { #' is not duplicated. `"full"` additionally retains the complete mr.mash fit #' under `$fit` (consistent with how susie fits are kept), at the cost of a #' larger payload. -#' @param ... Additional arguments passed to `mrmashWrapper()` when fitting. +#' @param methodArgs Optional named list of options passed to +#' `mrmashWrapper()` when fitting. #' @return Matrix of variant weights. #' @examples #' data(multiTraitData) @@ -401,6 +417,9 @@ sdprWeights <- function(stat, LD, ...) { #' fit <- mrmashWrapper(X = X, Y = Y, dataDrivenPriorMatrices = ddpm, #' canonicalPriorMatrices = TRUE) #' mrmashWeights(mrmashFit = fit, X = X, Y = Y) +#' @param dataDrivenPriorMatrices Optional list of data-driven prior +#' covariance matrices; forwarded to \code{mrmashWrapper} when it has to fit, +#' and retained in the payload for mvSuSiE prior reconstruction. #' @export mrmashWeights <- function( mrmashFit = NULL, @@ -408,22 +427,24 @@ mrmashWeights <- function( Y = NULL, retainFit = FALSE, fitDetail = c("slim", "full"), - ... + dataDrivenPriorMatrices = NULL, + methodArgs = list() ) { if (!requireNamespace("mr.mashr", quietly = TRUE)) { - msg <- glue( - "Package 'mr.mashr' is required. Install with: ", - "devtools::install_github('stephenslab/mr.mashr')" - ) - abort(msg) + abort("Package 'mr.mashr' is required.") } - dotArgs <- list(...) if (is.null(mrmashFit)) { inform("mrmashFit is not provided; fitting mr.mash now ...") if (is.null(X) || is.null(Y)) { abort("Both X and Y must be provided if mrmashFit is NULL.") } - mrmashFit <- mrmashWrapper(X, Y, ...) + mrmashFit <- exec( + mrmashWrapper, + X, + Y, + dataDrivenPriorMatrices = dataDrivenPriorMatrices, + !!!methodArgs + ) } out <- mr.mashr::coef.mr.mash(mrmashFit)[-1, ] # mu1 (= out) is already the returned weights; the payload carries only the @@ -432,7 +453,7 @@ mrmashWeights <- function( .mrmashAttachFit( out, mrmashFit, - dotArgs$dataDrivenPriorMatrices, + dataDrivenPriorMatrices, retainFit, fitDetail ) @@ -456,16 +477,28 @@ mrmashWeights <- function( return(weights) } fitDetail <- arg_match(fitDetail) - fitList <- list( - dataDrivenPriorMatrices = dataDrivenPriorMatrices, - w0 = fit$w0, - V = fit$V + fitList <- c( + list( + dataDrivenPriorMatrices = dataDrivenPriorMatrices, + w0 = fit$w0, + V = fit$V + ), + compact(list(fit = if (fitDetail == "full") fit)) ) - if (fitDetail == "full") { - fitList$fit <- fit + `attr<-`(weights, "fit", fitList) +} + +# The `beta.init` override for mr.ash: lasso weights when the caller supplied +# none, or the caller's own initialisation restricted to the retained columns. +# @noRd +.mrashBetaInit <- function(methodArgs, XKeep, y, X, keep) { + if (!is_in("beta.init", names(methodArgs))) { + return(list(beta.init = lassoWeights(XKeep, y))) + } + if (length(methodArgs$beta.init) != ncol(X)) { + return(list()) } - attr(weights, "fit") <- fitList - weights + list(beta.init = methodArgs$beta.init[keep]) } #' Compute mr.mash-RSS TWAS weights from summary statistics @@ -516,7 +549,8 @@ mrmashWeights <- function( #' coefficients are already the returned weights); \code{"full"} additionally #' keeps the complete \code{mr.mash.rss} fit under \code{$fit}. Mirrors #' \code{\link{mrmashWeights}}. -#' @param ... Additional arguments forwarded to \code{mr.mashr::mr.mash.rss}. +#' @param methodArgs Optional named list of options forwarded to +#' \code{mr.mashr::mr.mash.rss}. #' #' @return A numeric matrix of per-variant per-context weights (variants x #' conditions). @@ -532,6 +566,7 @@ mrmashWeights <- function( #' dataDrivenPriorMatrices = multiTraitData$priorMatrices, #' canonicalPriorMatrices = TRUE) #' @export +#' @importFrom checkmate assertFlag assertList mrmashRssWeights <- function( stat, LD, @@ -544,8 +579,11 @@ mrmashRssWeights <- function( covY = NULL, retainFit = FALSE, fitDetail = c("slim", "full"), - ... + methodArgs = list() ) { + assertList(stat) + assertFlag(canonicalPriorMatrices) + assertFlag(retainFit) .mrmashRssRequirePackage() if (is.null(mrmashRssFit)) { mrmashRssFit <- .mrmashRssComputeFit( @@ -557,7 +595,7 @@ mrmashRssWeights <- function( w0, V, covY, - list(...) + methodArgs ) } # coef.mr.mash.rss returns nrow(Bhat) rows (no intercept). Do not strip. @@ -577,8 +615,7 @@ mrmashRssWeights <- function( if (!requireNamespace("mr.mashr", quietly = TRUE)) { msg <- glue( "Package 'mr.mashr' is required. ", - "Install with: ", - "devtools::install_github('stephenslab/mr.mash.alpha')" + "is required." ) abort(msg) } @@ -711,11 +748,7 @@ initPriorSd <- function(X, y, n = 30) { glmnetWeights <- function(X, y, alpha) { # Check if glmnet is installed if (!requireNamespace("glmnet", quietly = TRUE)) { - msg <- glue( - "To use this function, please install glmnet: ", - "https://cran.r-project.org/web/packages/glmnet/index.html" - ) - abort(msg) + abort("Package 'glmnet' is required for this function.") } eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "glmnetWeights") @@ -727,8 +760,7 @@ glmnetWeights <- function(X, y, alpha) { intercept = TRUE, standardize = FALSE ) - eff.wgt[keep] <- coef(enet, s = "lambda.min")[2:(sum(keep) + 1)] - return(eff.wgt) + replace(eff.wgt, keep, coef(enet, s = "lambda.min")[2:(sum(keep) + 1)]) } #' Compute TWAS weights via elastic net (glmnet, alpha = 0.5) @@ -777,21 +809,27 @@ lassoWeights <- function(X, y) glmnetWeights(X, y, 1) #' from the data. Default \code{TRUE}. #' @param retainFit Logical. Attach the full fitted-model object to the result. #' Default \code{FALSE}. -#' @param ... Additional arguments forwarded to \code{mr.ash}. +#' @param methodArgs Optional named list of options forwarded to \code{mr.ash}. #' @return A numeric vector of weights, one per variant (column of \code{X}); #' zero-variance columns receive weight 0. When \code{retainFit = TRUE} the #' fitted \code{mr.ash} object is attached as attribute \code{"fit"}. +#' @importFrom checkmate assertFlag #' @export -mrashWeights <- function(X, y, initPriorSd = TRUE, retainFit = FALSE, ...) { - eff.wgt <- rep(0, ncol(X)) +mrashWeights <- function( + X, + y, + initPriorSd = TRUE, + retainFit = FALSE, + methodArgs = list() +) { + assertFlag(initPriorSd) + assertFlag(retainFit) keep <- .dropZeroVariance(X, "mrashWeights") XKeep <- X[, keep, drop = FALSE] - argsList <- list(...) - if (!is_in("beta.init", names(argsList))) { - argsList$beta.init <- lassoWeights(XKeep, y) - } else if (length(argsList$beta.init) == ncol(X)) { - argsList$beta.init <- argsList$beta.init[keep] - } + argsList <- list_assign( + methodArgs, + !!!.mrashBetaInit(methodArgs, XKeep, y, X, keep) + ) mrashArgs <- c( list( X = XKeep, @@ -801,11 +839,16 @@ mrashWeights <- function(X, y, initPriorSd = TRUE, retainFit = FALSE, ...) { argsList ) fit.mr.ash <- exec(mr.ash, !!!mrashArgs) - eff.wgt[keep] <- predict(fit.mr.ash, type = "coefficients")[-1] - if (retainFit) { - attr(eff.wgt, "fit") <- fit.mr.ash + # Zero-variance columns were never fitted and keep a zero weight. + eff.wgt <- replace( + rep(0, ncol(X)), + keep, + predict(fit.mr.ash, type = "coefficients")[-1] + ) + if (!retainFit) { + return(eff.wgt) } - return(eff.wgt) + `attr<-`(eff.wgt, "fit", fit.mr.ash) } #' Extract Coefficients From Bayesian Linear Regression #' @@ -824,7 +867,8 @@ mrashWeights <- function(X, y, initPriorSd = TRUE, retainFit = FALSE, ...) { #' \code{1000}. #' @param nthin Integer. Thinning interval for retained MCMC samples. Default #' \code{5}. -#' @param ... Additional arguments forwarded to \code{qgg::gbayes}. +#' @param methodArgs Optional named list of options forwarded to +#' \code{qgg::gbayes}. #' @return A vector containing the weights to be applied to each genotype in #' predicting the phenotype. #' @details This function fits a Bayesian linear regression model with a range @@ -850,47 +894,39 @@ bayesAlphabetWeights <- function( nit = 5000, nburn = 1000, nthin = 5, - ... + methodArgs = list() ) { .bayesAlphabetValidate(X, y, Z) eff.wgt <- rep(0, ncol(X)) keep <- .dropZeroVariance(X, "bayesAlphabetWeights") - model <- qgg::gbayes( - y = y, - W = X[, keep, drop = FALSE], - X = Z, - method = method, - h2 = h2, - nit = nit, - nburn = nburn, - ... + callArgs <- list_modify( + list( + y = y, + W = X[, keep, drop = FALSE], + X = Z, + method = method, + h2 = h2, + nit = nit, + nburn = nburn + ), + !!!methodArgs ) - - eff.wgt[keep] <- model$bm - return(eff.wgt) + model <- exec(qgg::gbayes, !!!callArgs) + replace(eff.wgt, keep, model$bm) } # Shared input validation for the gbayes-backed weight fitters: qgg present, # and matching row counts for response / genotype / covariates. # @noRd +#' @importFrom checkmate assertMatrix assertVector .bayesAlphabetValidate <- function(X, y, Z) { if (!requireNamespace("qgg", quietly = TRUE)) { - msg <- glue( - "To use this function, please install qgg: ", - "https://cran.r-project.org/web/packages/qgg/index.html" - ) - abort(msg) - } - if (!(length(y) == nrow(X))) { - abort("All objects must have the same number of rows") - } - if (!is.null(Z) && nrow(X) != nrow(Z)) { - abort( - "Genotype and covariate matrices must have same number of rows" - ) + abort("Package 'qgg' is required for this function.") } + assertVector(y, len = nrow(X)) + assertMatrix(Z, nrows = nrow(X), null.ok = TRUE) } #' @title BayesN TWAS weights (Gaussian prior, ridge-equivalent) #' @description Use Gaussian distribution as prior. Posterior means will be @@ -898,7 +934,8 @@ bayesAlphabetWeights <- function( #' @param X Numeric genotype / design matrix (samples x variants). #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. #' @param Z Optional numeric matrix of fixed-effect covariates, or \code{NULL}. -#' @param ... Additional arguments forwarded to \code{bayesAlphabetWeights} / +#' @param methodArgs Optional named list of options forwarded to +#' \code{bayesAlphabetWeights} / #' \code{qgg}. #' @return A numeric vector of effect-size weights, one per variant (column of #' \code{X}); columns dropped for zero variance receive weight 0. @@ -908,8 +945,8 @@ bayesAlphabetWeights <- function( #' y <- eqtlRegionExample$yRes #' bayesNWeights(X, y) #' @export -bayesNWeights <- function(X, y, Z = NULL, ...) { - return(bayesAlphabetWeights(X, y, method = "bayesN", Z, ...)) +bayesNWeights <- function(X, y, Z = NULL, methodArgs = list()) { + bayesAlphabetWeights(X, y, method = "bayesN", Z, methodArgs = methodArgs) } #' @title BayesL TWAS weights (Laplace prior, LASSO-equivalent) #' @description Use laplace/double exponential distribution as prior. This is @@ -917,7 +954,8 @@ bayesNWeights <- function(X, y, Z = NULL, ...) { #' @param X Numeric genotype / design matrix (samples x variants). #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. #' @param Z Optional numeric matrix of fixed-effect covariates, or \code{NULL}. -#' @param ... Additional arguments forwarded to \code{bayesAlphabetWeights} / +#' @param methodArgs Optional named list of options forwarded to +#' \code{bayesAlphabetWeights} / #' \code{qgg}. #' @return A numeric vector of effect-size weights, one per variant (column of #' \code{X}); columns dropped for zero variance receive weight 0. @@ -927,15 +965,16 @@ bayesNWeights <- function(X, y, Z = NULL, ...) { #' y <- eqtlRegionExample$yRes #' bayesLWeights(X, y) #' @export -bayesLWeights <- function(X, y, Z = NULL, ...) { - return(bayesAlphabetWeights(X, y, method = "bayesL", Z, ...)) +bayesLWeights <- function(X, y, Z = NULL, methodArgs = list()) { + bayesAlphabetWeights(X, y, method = "bayesL", Z, methodArgs = methodArgs) } #' @title BayesA TWAS weights (t-distribution prior) #' @description Use t-distribution as prior. #' @param X Numeric genotype / design matrix (samples x variants). #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. #' @param Z Optional numeric matrix of fixed-effect covariates, or \code{NULL}. -#' @param ... Additional arguments forwarded to \code{bayesAlphabetWeights} / +#' @param methodArgs Optional named list of options forwarded to +#' \code{bayesAlphabetWeights} / #' \code{qgg}. #' @return A numeric vector of effect-size weights, one per variant (column of #' \code{X}); columns dropped for zero variance receive weight 0. @@ -945,8 +984,8 @@ bayesLWeights <- function(X, y, Z = NULL, ...) { #' y <- eqtlRegionExample$yRes #' bayesAWeights(X, y) #' @export -bayesAWeights <- function(X, y, Z = NULL, ...) { - return(bayesAlphabetWeights(X, y, method = "bayesA", Z, ...)) +bayesAWeights <- function(X, y, Z = NULL, methodArgs = list()) { + bayesAlphabetWeights(X, y, method = "bayesA", Z, methodArgs = methodArgs) } #' @title BayesC TWAS weights (rounded-spike prior) #' @description Use a rounded spike prior (low-variance Gaussian). @@ -955,7 +994,8 @@ bayesAWeights <- function(X, y, Z = NULL, ...) { #' @param Z Optional numeric matrix of fixed-effect covariates, or \code{NULL}. #' @param pi Numeric in (0, 1). Prior proportion of non-null effects for the #' BayesC mixture. Default \code{0.1}. -#' @param ... Additional arguments forwarded to \code{bayesAlphabetWeights} / +#' @param methodArgs Optional named list of options forwarded to +#' \code{bayesAlphabetWeights} / #' \code{qgg}. #' @return A numeric vector of effect-size weights, one per variant (column of #' \code{X}); columns dropped for zero variance receive weight 0. @@ -965,8 +1005,16 @@ bayesAWeights <- function(X, y, Z = NULL, ...) { #' y <- eqtlRegionExample$yRes #' bayesCWeights(X, y) #' @export -bayesCWeights <- function(X, y, Z = NULL, pi = 0.1, ...) { - return(bayesAlphabetWeights(X, y, method = "bayesC", Z, pi = pi, ...)) +bayesCWeights <- function(X, y, Z = NULL, pi = 0.1, methodArgs = list()) { + # `pi` is a qgg option, not a formal of bayesAlphabetWeights, so it joins + # the option list rather than the argument list. + bayesAlphabetWeights( + X, + y, + method = "bayesC", + Z, + methodArgs = c(list(pi = pi), methodArgs) + ) } #' @title BayesR TWAS weights (hierarchical mixture prior) #' @description Use a hierarchical Bayesian mixture model with four Gaussian @@ -974,7 +1022,8 @@ bayesCWeights <- function(X, y, Z = NULL, pi = 0.1, ...) { #' @param X Numeric genotype / design matrix (samples x variants). #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. #' @param Z Optional numeric matrix of fixed-effect covariates, or \code{NULL}. -#' @param ... Additional arguments forwarded to \code{bayesAlphabetWeights} / +#' @param methodArgs Optional named list of options forwarded to +#' \code{bayesAlphabetWeights} / #' \code{qgg}. #' @return A numeric vector of effect-size weights, one per variant (column of #' \code{X}); columns dropped for zero variance receive weight 0. @@ -984,8 +1033,8 @@ bayesCWeights <- function(X, y, Z = NULL, pi = 0.1, ...) { #' y <- eqtlRegionExample$yRes #' bayesRWeights(X, y) #' @export -bayesRWeights <- function(X, y, Z = NULL, ...) { - return(bayesAlphabetWeights(X, y, method = "bayesR", Z, ...)) +bayesRWeights <- function(X, y, Z = NULL, methodArgs = list()) { + bayesAlphabetWeights(X, y, method = "bayesR", Z, methodArgs = methodArgs) } @@ -1126,7 +1175,7 @@ bayesRWeights <- function(X, y, Z = NULL, ...) { # stop( # paste0( # "To use this function, please install qgg: ", -# "https://cran.r-project.org/web/packages/qgg/index.html" +# # ) # ) # } @@ -1376,30 +1425,30 @@ bayesRWeights <- function(X, y, Z = NULL, ...) { # #' Use Gaussian distribution as prior. Posterior means will be BLUP, # #' equivalent to Ridge Regression. # #' @export -# bayes_n_rss_weights <- function(sumstats, LD, ...) { +# bayes_n_rss_weights <- function(sumstats, LD, methodArgs = list()) { # return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesN", ...)) # } # #' Use laplace/double exponential distribution as prior. This is equivalent # #' to Bayesian LASSO. # #' @export -# bayes_l_rss_weights <- function(sumstats, LD, ...) { +# bayes_l_rss_weights <- function(sumstats, LD, methodArgs = list()) { # return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesL", ...)) # } # #' Use t-distribution as prior. # #' @export -# bayes_a_rss_weights <- function(sumstats, LD, ...) { +# bayes_a_rss_weights <- function(sumstats, LD, methodArgs = list()) { # return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesA", ...)) # } # #' Use a rounded spike prior (low-variance Gaussian). # #' @export -# bayes_c_rss_weights <- function(sumstats, LD, ...) { +# bayes_c_rss_weights <- function(sumstats, LD, methodArgs = list()) { # return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesC", ...)) # } # #' Use a hierarchical Bayesian mixture model with four Gaussian components. # #' Variances are scaled # #' by 0, 0.0001 , 0.001 , and 0.01 . # #' @export -# bayes_r_rss_weights <- function(sumstats, LD, ...) { +# bayes_r_rss_weights <- function(sumstats, LD, methodArgs = list()) { # return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesR", ...)) # } @@ -1444,6 +1493,7 @@ bayesRWeights <- function(X, y, Z = NULL, ...) { #' } #' out <- lassosumRss(bhat, R, n) #' @export +#' @importFrom checkmate assertCount assertNumber assertNumeric lassosumRss <- function( bhat, R, @@ -1452,6 +1502,9 @@ lassosumRss <- function( thr = 1e-4, maxiter = 10000 ) { + assertNumeric(lambda, lower = 0, any.missing = FALSE) + assertNumber(thr, lower = 0, finite = TRUE) + assertCount(maxiter, positive = TRUE) # 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( @@ -1460,8 +1513,7 @@ lassosumRss <- function( n, lambda, .rssLassosumSolve, - thr = thr, - maxiter = maxiter + solveArgs = list(thr = thr, maxiter = maxiter) ) } @@ -1515,9 +1567,12 @@ lassosumRss <- function( ldBeta <- LD %*% candidateBeta bxy <- as.numeric(crossprod(corInput, candidateBeta)) bxxb <- colSums(candidateBeta * ldBeta) - scores <- rep(-Inf, length(bxy)) positive <- is.finite(bxxb) & bxxb > 0 - scores[positive] <- bxy[positive] / sqrt(bxxb[positive]) + scores <- replace( + rep(-Inf, length(bxy)), + positive, + bxy[positive] / sqrt(bxxb[positive]) + ) idx <- .lassosumFirstMax(scores) list( beta = candidateBeta[, idx], @@ -1533,6 +1588,7 @@ lassosumRss <- function( # 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. +#' @importFrom checkmate assertVector .rssValidateInputs <- function(bhat, R, n) { if (missing(R) || !is.matrix(R)) { abort("Please provide the LD correlation matrix 'R' as a matrix.") @@ -1540,9 +1596,7 @@ lassosumRss <- function( if (missing(n) || n <= 0) { abort("Please provide a valid sample size using 'n'.") } - if (length(bhat) != nrow(R)) { - abort("The length of 'bhat' must equal the number of rows of 'R'.") - } + assertVector(bhat, len = nrow(R)) invisible(NULL) } @@ -1551,21 +1605,28 @@ lassosumRss <- function( # 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, ...) { +.rssSolvePath <- function(bhat, R, n, lambda, solveFn, solveArgs = list()) { .rssValidateInputs(bhat, R, n) z <- bhat / sqrt(n) order <- order(lambda, decreasing = TRUE) - result <- solveFn(z, lambda[order], R, ...) + # `solveArgs` rather than `...`: the two solvers take different fixed + # argument sets, and both callers know theirs statically, so an unknown + # solver argument should be an error here rather than reaching the solver. + solved <- exec(solveFn, z, lambda[order], R, !!!solveArgs) # 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 + beta <- solved$beta[, invOrder, drop = FALSE] + fbeta <- solved$fbeta[invOrder] + list_assign( + solved, + beta = beta, + conv = solved$conv[invOrder], + loss = solved$loss[invOrder], + fbeta = fbeta, + lambda = lambda, + nparams = as.integer(colSums(beta != 0)), + betaEst = as.numeric(beta[, which.min(fbeta)]) + ) } # Per-`s` fit for one RSS method (`method` selects the solver + which `config` @@ -1644,14 +1705,7 @@ lassosumRss <- function( # @noRd .rssFinalize <- function(method, bestBeta, sel, meta, config) { base <- c(mode = sel$mode, index = sel$index) - attr( - bestBeta, - if (method == "lassosum") { - "lassosum_selection" - } else { - "penalized_rss_selection" - } - ) <- switch( + selection <- switch( method, lassosum = c( base, @@ -1672,7 +1726,12 @@ lassosumRss <- function( lambda = meta$lambda[sel$index] ) ) - bestBeta + attrName <- if (method == "lassosum") { + "lassosum_selection" + } else { + "penalized_rss_selection" + } + `attr<-`(bestBeta, attrName, selection) } # Shared scaffold for the RSS shrinkage-grid weight functions @@ -1681,6 +1740,19 @@ lassosumRss <- function( # candidate accumulation, and the ldQuadratic / minFbeta selection. `method` + # `config` pick the per-`s` solver (.rssFitOne) and the finalizer # (.rssFinalize). +# One shrinkage level's fit against the correspondingly shrunk LD. +# @noRd +.rssFitAtS <- function(sVal, method, solverInput, LD, n, p, config) { + .rssFitOne( + method, + solverInput, + (1 - sVal) * LD + sVal * diag(p), + n, + sVal, + config + ) +} + .rssShrinkGridWeights <- function( stat, LD, @@ -1694,15 +1766,18 @@ lassosumRss <- function( 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 <- .rssFitOne(method, solverInput, LDs, n, sVal, config) - candidateBeta <- cbind(candidateBeta, one$beta) - candidateMeta[[length(candidateMeta) + 1L]] <- one$meta - } - candidateMeta <- bind_rows(candidateMeta) + fits <- map( + s, + .rssFitAtS, + method = method, + solverInput = solverInput, + LD = LD, + n = n, + p = p, + config = config + ) + candidateBeta <- exec(cbind, !!!map(fits, "beta")) + candidateMeta <- bind_rows(map(fits, "meta")) selectorResult <- if (selection == "ldQuadratic") { .lassosumSelectLdQuadratic(candidateBeta, corInput, LD) } else { @@ -1740,7 +1815,8 @@ lassosumRss <- function( #' @param selection Selection strategy. Default \code{"ldQuadratic"} uses #' \eqn{c^T \beta / \sqrt{\beta^T R \beta}} on the supplied LD matrix. #' \code{"minFbeta"} is retained as an explicit alternative for debugging. -#' @param ... Additional arguments passed to \code{lassosumRss()}. +#' @param methodArgs Optional named list of options passed to +#' \code{lassosumRss()}. #' #' @return A numeric vector of the posterior SNP coefficients at the best (s, #' lambda). @@ -1763,7 +1839,7 @@ lassosumRssWeights <- function( LD, s = c(0.2, 0.5, 0.9, 1.0), selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = list() ) { selection <- arg_match(selection) .rssShrinkGridWeights( @@ -1771,7 +1847,7 @@ lassosumRssWeights <- function( LD, s, "lassosum", - list(dotArgs = list(...)), + list(dotArgs = methodArgs), selection ) } @@ -1858,14 +1934,16 @@ penalizedRss <- function( n, lambda, .rssPenalizedSolve, - penalty = penalty, - gamma = gamma, - alpha = alpha, - lambda0 = lambda0, - lambda2 = lambda2, - thr = thr, - maxiter = maxiter, - maxSwaps = maxSwaps + solveArgs = list( + penalty = penalty, + gamma = gamma, + alpha = alpha, + lambda0 = lambda0, + lambda2 = lambda2, + thr = thr, + maxiter = maxiter, + maxSwaps = maxSwaps + ) ) } @@ -1878,8 +1956,10 @@ penalizedRss <- function( #' 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 +#' @param stat,LD,s,selection,penalty,gamma,alpha,lambda0,lambda2 See the #' public wrappers for details. +#' @param methodArgs Optional named list of options forwarded to +#' \code{penalizedRss()}. #' @return Numeric weight vector of length \code{nrow(LD)}. #' @keywords internal .penalizedRssWeights <- function( @@ -1892,7 +1972,7 @@ penalizedRss <- function( lambda0 = 0, lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = list() ) { selection <- arg_match(selection) .rssShrinkGridWeights( @@ -1906,7 +1986,7 @@ penalizedRss <- function( alpha = alpha, lambda0 = lambda0, lambda2 = lambda2, - dotArgs = list(...) + dotArgs = methodArgs ), selection ) @@ -1927,7 +2007,8 @@ penalizedRss <- function( #' @param alpha Elastic-net mixing (1 = pure L1). Default 1. #' @param selection Selection strategy: \code{"ldQuadratic"} (default) or #' \code{"minFbeta"}. -#' @param ... Additional arguments passed to \code{penalizedRss()}. +#' @param methodArgs Optional named list of options passed to +#' \code{penalizedRss()}. #' @return A numeric vector of SNP coefficient weights. #' @examples #' data(eqtlRegionExample) @@ -1942,6 +2023,7 @@ penalizedRss <- function( #' ) #' LD <- cor(X) #' scadRssWeights(stat, LD) +#' @importFrom checkmate assertList assertNumeric assertNumber #' @export scadRssWeights <- function( stat, @@ -1950,8 +2032,12 @@ scadRssWeights <- function( gamma = 3.7, alpha = 1.0, selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = list() ) { + assertList(stat) + assertNumeric(s, lower = 0, any.missing = FALSE) + assertNumber(gamma, finite = TRUE) + assertNumber(alpha, finite = TRUE) .penalizedRssWeights( stat = stat, LD = LD, @@ -1960,7 +2046,7 @@ scadRssWeights <- function( gamma = gamma, alpha = alpha, selection = selection, - ... + methodArgs = methodArgs ) } @@ -1979,7 +2065,8 @@ scadRssWeights <- function( #' @param alpha Elastic-net mixing (1 = pure L1). Default 1. #' @param selection Selection strategy: \code{"ldQuadratic"} (default) or #' \code{"minFbeta"}. -#' @param ... Additional arguments passed to \code{penalizedRss()}. +#' @param methodArgs Optional named list of options passed to +#' \code{penalizedRss()}. #' @return A numeric vector of SNP coefficient weights. #' @examples #' data(eqtlRegionExample) @@ -1994,6 +2081,7 @@ scadRssWeights <- function( #' ) #' LD <- cor(X) #' mcpRssWeights(stat, LD) +#' @importFrom checkmate assertList assertNumeric assertNumber #' @export mcpRssWeights <- function( stat, @@ -2002,8 +2090,12 @@ mcpRssWeights <- function( gamma = 3.0, alpha = 1.0, selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = list() ) { + assertList(stat) + assertNumeric(s, lower = 0, any.missing = FALSE) + assertNumber(gamma, finite = TRUE) + assertNumber(alpha, finite = TRUE) .penalizedRssWeights( stat = stat, LD = LD, @@ -2012,7 +2104,7 @@ mcpRssWeights <- function( gamma = gamma, alpha = alpha, selection = selection, - ... + methodArgs = methodArgs ) } @@ -2041,7 +2133,8 @@ mcpRssWeights <- function( #' @param selection Selection strategy: \code{"ldQuadratic"} (default) or #' \code{"minFbeta"}. #' @param maxSwaps Maximum swap rounds per lambda. Default 100. -#' @param ... Additional arguments passed to \code{penalizedRss()}. +#' @param methodArgs Optional named list of options passed to +#' \code{penalizedRss()}. #' @return A numeric vector of SNP coefficient weights. #' @examples #' data(eqtlRegionExample) @@ -2067,7 +2160,7 @@ l0learnRssWeights <- function( lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), maxSwaps = 100, - ... + methodArgs = list() ) { penalty <- arg_match(penalty) selection <- arg_match(selection) @@ -2092,7 +2185,7 @@ l0learnRssWeights <- function( lambda0 = lambda0, lambda2 = lambda2, maxSwaps = maxSwaps, - dotArgs = list(...) + dotArgs = methodArgs ), selection ) @@ -2111,29 +2204,30 @@ l0learnRssWeights <- function( #' @param y A numeric response vector. #' @param penalty Either "SCAD" or "MCP". #' @param nfolds Number of cross-validation folds. Default is 5. -#' @param ... Additional arguments passed through to `ncvreg::cv.ncvreg`. +#' @param methodArgs Optional named list of options passed through to +#' `ncvreg::cv.ncvreg`. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @importFrom stats coef #' @keywords internal -ncvregWeights <- function(X, y, penalty, nfolds = 5, ...) { +#' @importFrom checkmate assertCount +ncvregWeights <- function(X, y, penalty, nfolds = 5, methodArgs = list()) { + assertCount(nfolds, positive = TRUE) if (!requireNamespace("ncvreg", quietly = TRUE)) { - msg <- glue( - "To use this function, please install ncvreg: ", - "https://cran.r-project.org/package=ncvreg" - ) - abort(msg) + abort("Package 'ncvreg' is required for this function.") } eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "ncvregWeights") - fit <- ncvreg::cv.ncvreg( - X = X[, keep, drop = FALSE], - y = y, - penalty = penalty, - nfolds = nfolds, - ... + callArgs <- list_modify( + list( + X = X[, keep, drop = FALSE], + y = y, + penalty = penalty, + nfolds = nfolds + ), + !!!methodArgs ) - eff.wgt[keep] <- coef(fit, lambda = fit$lambda.min)[-1] - return(eff.wgt) + fit <- exec(ncvreg::cv.ncvreg, !!!callArgs) + replace(eff.wgt, keep, coef(fit, lambda = fit$lambda.min)[-1]) } #' Compute Weights Using SCAD-Penalized Regression @@ -2144,7 +2238,8 @@ ncvregWeights <- function(X, y, penalty, nfolds = 5, ...) { #' @param X A numeric matrix of predictors. #' @param y A numeric response vector. #' @param nfolds Number of cross-validation folds. Default is 5. -#' @param ... Additional arguments passed through to `ncvreg::cv.ncvreg`. +#' @param methodArgs Optional named list of options passed through to +#' `ncvreg::cv.ncvreg`. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @examples #' data(eqtlRegionExample) @@ -2152,8 +2247,14 @@ ncvregWeights <- function(X, y, penalty, nfolds = 5, ...) { #' y <- eqtlRegionExample$yRes #' scadWeights(X, y) #' @export -scadWeights <- function(X, y, nfolds = 5, ...) { - ncvregWeights(X, y, penalty = "SCAD", nfolds = nfolds, ...) +scadWeights <- function(X, y, nfolds = 5, methodArgs = list()) { + ncvregWeights( + X, + y, + penalty = "SCAD", + nfolds = nfolds, + methodArgs = methodArgs + ) } #' Compute Weights Using MCP-Penalized Regression @@ -2164,7 +2265,8 @@ scadWeights <- function(X, y, nfolds = 5, ...) { #' @param X A numeric matrix of predictors. #' @param y A numeric response vector. #' @param nfolds Number of cross-validation folds. Default is 5. -#' @param ... Additional arguments passed through to `ncvreg::cv.ncvreg`. +#' @param methodArgs Optional named list of options passed through to +#' `ncvreg::cv.ncvreg`. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @examples #' data(eqtlRegionExample) @@ -2172,8 +2274,14 @@ scadWeights <- function(X, y, nfolds = 5, ...) { #' y <- eqtlRegionExample$yRes #' mcpWeights(X, y) #' @export -mcpWeights <- function(X, y, nfolds = 5, ...) { - ncvregWeights(X, y, penalty = "MCP", nfolds = nfolds, ...) +mcpWeights <- function(X, y, nfolds = 5, methodArgs = list()) { + ncvregWeights( + X, + y, + penalty = "MCP", + nfolds = nfolds, + methodArgs = methodArgs + ) } #' Compute Weights Using L0Learn @@ -2189,7 +2297,8 @@ mcpWeights <- function(X, y, nfolds = 5, ...) { #' @param penalty Type of regularization: "L0", "L0L1", or "L0L2". Default is #' "L0". #' @param nFolds Number of cross-validation folds. Default is 5. -#' @param ... Additional arguments passed through to `L0Learn::L0Learn.cvfit` +#' @param methodArgs Optional named list of options passed through to +#' `L0Learn::L0Learn.cvfit` #' (e.g. `nGamma`, `gammaMin`, `gammaMax`, `algorithm`, `maxSuppSize`). #' @return A numeric vector of length `ncol(X)` of variant weights. #' @examples @@ -2198,36 +2307,38 @@ mcpWeights <- function(X, y, nfolds = 5, ...) { #' y <- eqtlRegionExample$yRes #' l0learnWeights(X, y) #' @export -l0learnWeights <- function(X, y, penalty = "L0", nFolds = 5, ...) { +l0learnWeights <- function( + X, + y, + penalty = "L0", + nFolds = 5, + methodArgs = list() +) { if (!requireNamespace("L0Learn", quietly = TRUE)) { - msg <- glue( - "To use this function, please install L0Learn: ", - "https://cran.r-project.org/package=L0Learn" - ) - abort(msg) + abort("Package 'L0Learn' is required for this function.") } eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "l0learnWeights") - fit <- L0Learn::L0Learn.cvfit( - x = X[, keep, drop = FALSE], - y = y, - penalty = penalty, - nFolds = nFolds, - ... + callArgs <- list_modify( + list( + x = X[, keep, drop = FALSE], + y = y, + penalty = penalty, + nFolds = nFolds + ), + !!!methodArgs ) + fit <- exec(L0Learn::L0Learn.cvfit, !!!callArgs) # Find (gamma, lambda) minimizing CV error across the entire path. cvMins <- map_dbl(fit$cvMeans, .rssMinNumeric) gammaIdx <- which.min(cvMins) lambdaIdx <- which.min(as.numeric(fit$cvMeans[[gammaIdx]])) bestGamma <- fit$fit$gamma[gammaIdx] bestLambda <- fit$fit$lambda[[gammaIdx]][lambdaIdx] - coefs <- as.numeric(coef(fit, lambda = bestLambda, gamma = bestGamma)) + raw <- as.numeric(coef(fit, lambda = bestLambda, gamma = bestGamma)) # If intercept was included, drop it (first row). - if (length(coefs) == sum(keep) + 1L) { - coefs <- coefs[-1L] - } - eff.wgt[keep] <- coefs - return(eff.wgt) + coefs <- if (length(raw) == sum(keep) + 1L) raw[-1L] else raw + replace(eff.wgt, keep, coefs) } #' Compute Weights Using a BGLR Linear Regression Model @@ -2246,7 +2357,8 @@ l0learnWeights <- function(X, y, penalty = "L0", nFolds = 5, ...) { #' @param thin Thinning interval. #' @param etaArgs Optional named list of additional arguments included in the #' `ETA` linear-term specification (e.g. `list(probIn = 0.05)` for BayesB). -#' @param ... Additional arguments passed through to `BGLR::BGLR`. +#' @param methodArgs Optional named list of options passed through to +#' `BGLR::BGLR`. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @keywords internal bglrWeights <- function( @@ -2257,14 +2369,10 @@ bglrWeights <- function( burnIn, thin, etaArgs = list(), - ... + methodArgs = list() ) { if (!requireNamespace("BGLR", quietly = TRUE)) { - msg <- glue( - "To use this function, please install BGLR: ", - "https://cran.r-project.org/package=BGLR" - ) - abort(msg) + abort("Package 'BGLR' is required for this function.") } eff.wgt <- rep(0, ncol(X)) keep <- .dropZeroVariance(X, "bglrWeights") @@ -2275,18 +2383,20 @@ bglrWeights <- function( saveAt <- str_c(tmpdir, .Platform$file.sep) eta <- list(c(list(X = X[, keep, drop = FALSE], model = model), etaArgs)) - fit <- BGLR::BGLR( - y = y, - ETA = eta, - nIter = nIter, - burnIn = burnIn, - thin = thin, - saveAt = saveAt, - verbose = FALSE, - ... + callArgs <- list_modify( + list( + y = y, + ETA = eta, + nIter = nIter, + burnIn = burnIn, + thin = thin, + saveAt = saveAt, + verbose = FALSE + ), + !!!methodArgs ) - eff.wgt[keep] <- as.numeric(fit$ETA[[1]]$b) - return(eff.wgt) + fit <- exec(BGLR::BGLR, !!!callArgs) + replace(eff.wgt, keep, as.numeric(fit$ETA[[1]]$b)) } #' Compute Weights Using BayesB @@ -2307,13 +2417,15 @@ bglrWeights <- function( #' @param burnIn Number of burn-in iterations. Default is 2000. #' @param thin Thinning interval. Default is 5. #' @param probIn Prior inclusion probability for each marker. Default is 0.2. -#' @param ... Additional arguments passed through to `BGLR::BGLR`. +#' @param methodArgs Optional named list of options passed through to +#' `BGLR::BGLR`. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes #' bayesBWeights(X, y) +#' @importFrom checkmate assertCount assertNumber #' @export bayesBWeights <- function( X, @@ -2322,8 +2434,12 @@ bayesBWeights <- function( burnIn = 2000, thin = 5, probIn = 0.2, - ... + methodArgs = list() ) { + assertCount(nIter, positive = TRUE) + assertCount(burnIn) + assertCount(thin, positive = TRUE) + assertNumber(probIn, lower = 0, upper = 1) bglrWeights( X, y, @@ -2332,7 +2448,7 @@ bayesBWeights <- function( burnIn = burnIn, thin = thin, etaArgs = list(probIn = probIn), - ... + methodArgs = methodArgs ) } @@ -2353,15 +2469,27 @@ bayesBWeights <- function( #' @param nIter Number of MCMC iterations. Default is 10000. #' @param burnIn Number of burn-in iterations. Default is 2000. #' @param thin Thinning interval. Default is 5. -#' @param ... Additional arguments passed through to `BGLR::BGLR`. +#' @param methodArgs Optional named list of options passed through to +#' `BGLR::BGLR`. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes #' bLassoWeights(X, y) +#' @importFrom checkmate assertCount #' @export -bLassoWeights <- function(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) { +bLassoWeights <- function( + X, + y, + nIter = 10000, + burnIn = 2000, + thin = 5, + methodArgs = list() +) { + assertCount(nIter, positive = TRUE) + assertCount(burnIn) + assertCount(thin, positive = TRUE) bglrWeights( X, y, @@ -2369,7 +2497,7 @@ bLassoWeights <- function(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) { nIter = nIter, burnIn = burnIn, thin = thin, - ... + methodArgs = methodArgs ) } @@ -2390,7 +2518,8 @@ bLassoWeights <- function(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) { #' @param y A numeric response vector. #' @param fittingMethod One of "VB", "Gibbs", or "Adaptive_Gibbs". Default is #' "VB". -#' @param ... Additional arguments passed through to `RcppDPR::fit_model`. +#' @param methodArgs Optional named list of options passed through to +#' `RcppDPR::fit_model`. #' @param retainFit Logical. Attach the full fitted-model object to the result. #' Default \code{FALSE}. #' @param nK Integer. Number of variational mixture components for the VB fit @@ -2404,30 +2533,35 @@ bLassoWeights <- function(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) { #' y <- eqtlRegionExample$yRes #' dprWeights(X, y) #' @export -dprWeights <- function(X, y, fittingMethod = "VB", retainFit = FALSE, ...) { +dprWeights <- function( + X, + y, + fittingMethod = "VB", + retainFit = FALSE, + methodArgs = list() +) { if (!requireNamespace("RcppDPR", quietly = TRUE)) { - msg <- glue( - "To use this function, please install RcppDPR: ", - "https://cran.r-project.org/package=RcppDPR" - ) - abort(msg) + abort("Package 'RcppDPR' is required for this function.") } - eff.wgt <- rep(0, ncol(X)) + zeros <- rep(0, ncol(X)) keep <- .dropZeroVariance(X, "dprWeights") w <- matrix(1, nrow = nrow(X), ncol = 1) - fit <- RcppDPR::fit_model( - y = y, - w = w, - x = X[, keep, drop = FALSE], - rotate_variables = FALSE, - fitting_method = fittingMethod, - ... + callArgs <- list_modify( + list( + y = y, + w = w, + x = X[, keep, drop = FALSE], + rotate_variables = FALSE, + fitting_method = fittingMethod + ), + !!!methodArgs ) - eff.wgt[keep] <- as.numeric(fit$beta + fit$alpha) - if (retainFit) { - attr(eff.wgt, "fit") <- fit + fit <- exec(RcppDPR::fit_model, !!!callArgs) + eff.wgt <- replace(zeros, keep, as.numeric(fit$beta + fit$alpha)) + if (!retainFit) { + return(eff.wgt) } - return(eff.wgt) + `attr<-`(eff.wgt, "fit", fit) } #' @rdname dprWeights @@ -2437,8 +2571,14 @@ dprWeights <- function(X, y, fittingMethod = "VB", retainFit = FALSE, ...) { #' y <- eqtlRegionExample$yRes #' dprVbWeights(X, y) #' @export -dprVbWeights <- function(X, y, nK = 8, retainFit = FALSE, ...) { - dprWeights(X, y, fittingMethod = "VB", n_k = nK, retainFit = retainFit, ...) +dprVbWeights <- function(X, y, nK = 8, retainFit = FALSE, methodArgs = list()) { + dprWeights( + X, + y, + fittingMethod = "VB", + retainFit = retainFit, + methodArgs = c(list(n_k = nK), methodArgs) + ) } #' @rdname dprWeights @@ -2450,15 +2590,23 @@ dprVbWeights <- function(X, y, nK = 8, retainFit = FALSE, ...) { #' colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:p)) #' y <- X[, 1] * 0.5 + rnorm(n) #' dprGibbsWeights(X, y, sStep = 500) +#' @importFrom checkmate assertCount assertFlag #' @export -dprGibbsWeights <- function(X, y, sStep = 5000, retainFit = FALSE, ...) { +dprGibbsWeights <- function( + X, + y, + sStep = 5000, + retainFit = FALSE, + methodArgs = list() +) { + assertCount(sStep, positive = TRUE) + assertFlag(retainFit) dprWeights( X, y, fittingMethod = "Gibbs", - s_step = sStep, retainFit = retainFit, - ... + methodArgs = c(list(s_step = sStep), methodArgs) ) } @@ -2471,14 +2619,21 @@ dprGibbsWeights <- function(X, y, sStep = 5000, retainFit = FALSE, ...) { #' colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:p)) #' y <- X[, 1] * 0.5 + rnorm(n) #' dprAdaptiveGibbsWeights(X, y) +#' @importFrom checkmate assertFlag #' @export -dprAdaptiveGibbsWeights <- function(X, y, retainFit = FALSE, ...) { +dprAdaptiveGibbsWeights <- function( + X, + y, + retainFit = FALSE, + methodArgs = list() +) { + assertFlag(retainFit) dprWeights( X, y, fittingMethod = "Adaptive_Gibbs", retainFit = retainFit, - ... + methodArgs = methodArgs ) } #' @title Mr.Mash Wrapper @@ -2515,7 +2670,6 @@ dprAdaptiveGibbsWeights <- function(X, y, retainFit = FALSE, ...) { #' @param tol The tolerance for convergence. Default is 0.01. #' @param verbose A logical indicating whether to print verbose output. Default #' is FALSE. -#' @param ... Additional arguments to be passed to mr.mash. #' #' @param V Optional residual covariance matrix (conditions x conditions), or #' \code{NULL} to estimate it. @@ -2576,72 +2730,95 @@ mrmashWrapper <- function( bInitMethod = "enet", maxIter = 5000, tol = 0.01, - verbose = FALSE, - ... + verbose = FALSE ) { .mrmashRequirePackages() - p <- as.list(environment()) - .mrmashValidateWrapper(p) - p$bInitMethod <- .mrmashResolveBInit(Y, bInitMethod) + .mrmashValidateWrapper( + X = X, + Y = Y, + priorGrid = priorGrid, + dataDrivenPriorMatrices = dataDrivenPriorMatrices, + canonicalPriorMatrices = canonicalPriorMatrices + ) + bInitMethod <- .mrmashResolveBInit(Y, bInitMethod) if (is.null(sumstats)) { - p$sumstats <- .mrmashComputeSumstats(p) + sumstats <- .mrmashComputeSumstats(X, Y, standardize, nthreads) } # Shared prior-covariance builder (also used by mrmashRssWeights). priorBuilt <- buildMrmashPriorMatrices( - Bhat = p$sumstats$Bhat, - Shat = p$sumstats$Shat, + Bhat = sumstats$Bhat, + Shat = sumstats$Shat, K = ncol(Y), dataDrivenPriorMatrices = dataDrivenPriorMatrices, canonicalPriorMatrices = canonicalPriorMatrices, priorGrid = priorGrid ) time1 <- proc.time() - bInit <- as.matrix(.mrmashInitCoefficients(p)$Bhat) - vInit <- .mrmashInitV(p) - fitMrmash <- .mrmashFit(p, priorBuilt$S0, bInit, vInit) - fitMrmash$analysis_time <- proc.time()["elapsed"] - time1["elapsed"] - fitMrmash + bInit <- as.matrix( + .mrmashInitCoefficients( + X, + Y, + bInitMethod, + standardize, + nthreads + )$Bhat + ) + vInit <- .mrmashInitV(X, Y, V, updateV, updateVMethod) + fitMrmash <- .mrmashFit( + priorBuilt$S0, + bInit, + vInit, + X = X, + Y = Y, + updateW0 = updateW0, + tol = tol, + maxIter = maxIter, + standardize = standardize, + verbose = verbose, + updateVMethod = updateVMethod, + w0Threshold = w0Threshold, + nthreads = nthreads + ) + list_assign( + fitMrmash, + analysis_time = proc.time()["elapsed"] - time1["elapsed"] + ) } # Require glmnet + mr.mashr; also emit the no-seed reproducibility message. # @noRd .mrmashRequirePackages <- function() { if (!requireNamespace("glmnet", quietly = TRUE)) { - msg <- glue( - "To use this function, please install glmnet: ", - "https://cran.r-project.org/web/packages/glmnet/index.html" - ) - abort(msg) + abort("Package 'glmnet' is required for this function.") } if (!requireNamespace("mr.mashr", quietly = TRUE)) { - msg <- glue( - "To use this function, please install mr.mashr: ", - "https://github.com/stephenslab/mr.mashr" - ) - abort(msg) + abort("Package 'mr.mashr' is required for this function.") } } # Input validation for the individual-level mr.mash wrapper. # @noRd -.mrmashValidateWrapper <- function(p) { +#' @importFrom checkmate assertMatrix +.mrmashValidateWrapper <- function( + X, + Y, + priorGrid, + dataDrivenPriorMatrices, + canonicalPriorMatrices +) { if (!exists(".Random.seed")) { inform( "! No seed has been set. Please set seed for reproducable result. " ) } - if (!is.matrix(p$X) || !is.matrix(p$Y)) { + if (!is.matrix(X) || !is.matrix(Y)) { abort("X and Y must be matrices.") } - if (nrow(p$X) != nrow(p$Y)) { - abort("X and Y must have the same number of rows.") - } - if (!is.null(p$priorGrid) && !is.vector(p$priorGrid)) { + assertMatrix(Y, nrows = nrow(X)) + if (!is.null(priorGrid) && !is.vector(priorGrid)) { abort("priorGrid must be a vector.") } - if ( - is.null(p$dataDrivenPriorMatrices) && !isTRUE(p$canonicalPriorMatrices) - ) { + if (is.null(dataDrivenPriorMatrices) && !isTRUE(canonicalPriorMatrices)) { msg <- glue( "Please provide dataDrivenPriorMatrices or set ", "canonicalPriorMatrices = TRUE." @@ -2667,34 +2844,34 @@ mrmashWrapper <- function( # Univariate summary statistics (Bhat/Shat) for the prior + init. # @noRd -.mrmashComputeSumstats <- function(p) { +.mrmashComputeSumstats <- function(X, Y, standardize, nthreads) { mr.mashr::compute_univariate_sumstats( - p$X, - p$Y, - standardize = p$standardize, + X, + Y, + standardize = standardize, standardize.response = FALSE, - mc.cores = p$nthreads + mc.cores = nthreads ) } # Initial coefficient matrix via graphical-lasso or univariate glmnet. # @noRd -.mrmashInitCoefficients <- function(p) { - if (p$bInitMethod == "glasso") { +.mrmashInitCoefficients <- function(X, Y, bInitMethod, standardize, nthreads) { + if (bInitMethod == "glasso") { return(computeCoefficientsGlasso( - p$X, - p$Y, - standardize = p$standardize, - nthreads = p$nthreads, + X, + Y, + standardize = standardize, + nthreads = nthreads, Xnew = NULL )) } computeCoefficientsUnivGlmnet( - p$X, - p$Y, + X, + Y, alpha = 0.5, - standardize = p$standardize, - nthreads = p$nthreads, + standardize = standardize, + nthreads = nthreads, Xnew = NULL ) } @@ -2702,18 +2879,18 @@ mrmashWrapper <- function( # Robust residual-covariance init. Returns list(V, updateV); a rank-deficient V # is ridge-regularized and its update disabled. # @noRd -.mrmashInitV <- function(p) { - if (!is.null(p$V)) { - return(list(V = p$V, updateV = p$updateV)) +.mrmashInitV <- function(X, Y, V, updateV, updateVMethod) { + if (!is.null(V)) { + return(list(V = V, updateV = updateV)) } - V <- .mrmashComputeVInit(p$X, p$Y, any(is.na(p$Y))) - if (p$updateVMethod == "diagonal") { - return(list(V = diag(diag(V)), updateV = p$updateV)) + V <- .mrmashComputeVInit(X, Y, any(is.na(Y))) + if (updateVMethod == "diagonal") { + return(list(V = diag(diag(V)), updateV = updateV)) } if (any(eigen(V)$values < 1e-8)) { return(list(V = V + diag(1e-8, nrow(V)), updateV = FALSE)) } - list(V = V, updateV = p$updateV) + list(V = V, updateV = updateV) } # Compute V_init via mr.mashr (cov for complete Y, flash when Y has missing). @@ -2740,28 +2917,47 @@ mrmashWrapper <- function( # Run mr.mash with the resolved prior / init / V. # @noRd -.mrmashFit <- function(p, S0, bInit, vInit) { +.mrmashFit <- function( + S0, + bInit, + vInit, + X, + Y, + updateW0, + tol, + maxIter, + standardize, + verbose, + updateVMethod, + w0Threshold, + nthreads +) { mr.mashr::mr.mash( - X = p$X, - Y = p$Y, + X = X, + Y = Y, V = vInit$V, S0 = S0, w0 = computeW0(bInit, length(S0)), - update_w0 = p$updateW0, - tol = p$tol, - max_iter = p$maxIter, + update_w0 = updateW0, + tol = tol, + max_iter = maxIter, convergence_criterion = "ELBO", compute_ELBO = TRUE, - standardize = p$standardize, - verbose = p$verbose, + standardize = standardize, + verbose = verbose, update_V = vInit$updateV, - update_V_method = p$updateVMethod, - w0_threshold = p$w0Threshold, - nthreads = p$nthreads, + update_V_method = updateVMethod, + w0_threshold = w0Threshold, + nthreads = nthreads, mu1_init = bInit ) } +# @noRd +.rrDropIntercept <- function(coefs) { + as.vector(coefs)[-1] +} + #' Compute initial mr.mash coefficients via group-lasso #' #' Fit a group-lasso (one group per response) to obtain initial estimates of the @@ -2782,6 +2978,7 @@ mrmashWrapper <- function( #' Y <- matrix(rnorm(nrow(X) * 3), nrow(X), 3) #' computeCoefficientsGlasso(X = X, Y = Y, standardize = TRUE, #' nthreads = 1L, Xnew = NULL) +#' @importFrom checkmate assertFlag assertInt #' @export computeCoefficientsGlasso <- function( X, @@ -2790,6 +2987,8 @@ computeCoefficientsGlasso <- function( nthreads, Xnew = NULL ) { + assertFlag(standardize) + assertInt(nthreads) n <- nrow(X) p <- ncol(X) r <- ncol(Y) @@ -2806,17 +3005,20 @@ computeCoefficientsGlasso <- function( ) coeffGlmnet <- coef(cvfitGlmnet, s = "lambda.min") - # Build matrix of initial estimates for mr.mash - B <- matrix(as.numeric(NA), nrow = p, ncol = r) - - for (i in seq_along(coeffGlmnet)) { - B[, i] <- as.vector(coeffGlmnet[[i]])[-1] - } + # Build matrix of initial estimates for mr.mash: one column per outcome, + # each the glmnet coefficients with the intercept dropped. + B <- matrix( + unname(list_c(map(coeffGlmnet, .rrDropIntercept))), + nrow = p, + ncol = r + ) # Make predictions if requested. if (!is.null(Xnew)) { - YhatGlmnet <- drop(predict(cvfitGlmnet, newx = Xnew, s = "lambda.min")) - colnames(YhatGlmnet) <- conditionNames + YhatGlmnet <- `colnames<-`( + drop(predict(cvfitGlmnet, newx = Xnew, s = "lambda.min")), + conditionNames + ) res <- list(Bhat = B, Ytrain = Y, Yhat_new = YhatGlmnet) } else { res <- list(Bhat = B, Ytrain = Y) @@ -2877,8 +3079,7 @@ computeCoefficientsUnivGlmnet <- function( if (!is.null(Xnew)) { yhatList <- map(out, "yhat_new") - YhatNew <- exec(cbind, !!!yhatList) - colnames(YhatNew) <- colnames(Y) + YhatNew <- `colnames<-`(exec(cbind, !!!yhatList), colnames(Y)) results <- list( Bhat = Bhat[-1, ], intercept = Bhat[1, ], @@ -2895,20 +3096,17 @@ computeCoefficientsUnivGlmnet <- function( computeW0 <- function(Bhat, ncomps) { propNonzero <- sum(rowSums(abs(Bhat)) > 0) / nrow(Bhat) - if (ncomps > 1) { - w0 <- c( - (1 - propNonzero), - rep(propNonzero / (ncomps - 1), (ncomps - 1)) - ) + fromData <- if (ncomps > 1) { + c((1 - propNonzero), rep(propNonzero / (ncomps - 1), (ncomps - 1))) } else { - w0 <- 1 + 1 } - - if (sum(w0 != 0) < 2) { - w0 <- rep(1 / ncomps, ncomps) + # Fewer than two non-zero components leaves nothing to mix: fall back to + # a flat prior over all of them. + if (sum(fromData != 0) < 2) { + return(rep(1 / ncomps, ncomps)) } - - return(w0) + fromData } @@ -2920,53 +3118,40 @@ computeW0 <- function(Bhat, ncomps) { #' @keywords internal rescaleCovW0 <- function(w0) { # remove null component - w0 <- w0[names(w0) != "null"] + nonNull <- w0[names(w0) != "null"] # split by prior group - groups <- str_remove(names(w0), "_[^_]+$") - groupList <- split(w0, groups) - - # get per group sum - groupWeight <- map(groupList, sum) - - # Renormalize values within each group - weightsList <- unlist(groupWeight) - sumWeights <- sum(weightsList) - if (sumWeights > 0) { - weightsList <- weightsList / sumWeights + groups <- str_remove(names(nonNull), "_[^_]+$") + groupList <- split(nonNull, groups) + + # get per group sum -- one scalar per group + groupSums <- map_dbl(groupList, sum) + sumWeights <- sum(groupSums) + weightsList <- if (sumWeights > 0) { + groupSums / sumWeights } else { # Use equal weights if all non null weights are zeros - weightsList <- set_names( - rep(1 / length(weightsList), length(weightsList)), - names(weightsList) + set_names( + rep(1 / length(groupSums), length(groupSums)), + names(groupSums) ) } - # vector to store updated group w0 - updatedW0 <- rep(NA, length(unique(groups))) - names(updatedW0) <- unique(groups) - - # replace with updated values - updatedW0[names(weightsList)] <- weightsList - return(updatedW0) + # One w0 slot per group, filled from the supplied weights. + groupKeys <- unique(groups) + replace( + set_names(rep(NA, length(groupKeys)), groupKeys), + names(weightsList), + weightsList + ) } ### Function to compute grids computeGrid <- function(bhat, sbhat) { - gridMins <- c() - gridMaxs <- c() - include <- !(sbhat == 0 | !is.finite(sbhat) | is.na(sbhat) | is.na(bhat)) gmax <- gridMax(bhat[include], sbhat[include]) gmin <- gridMin(bhat[include], sbhat[include]) - gridMins <- c(gridMins, gmin) - gridMaxs <- c(gridMaxs, gmax) - - gminTot <- min(gridMins) - gmaxTot <- max(gridMaxs) - grid <- autoselectMixsd(gminTot, gmaxTot, mult = sqrt(2))^2 - - return(grid) + autoselectMixsd(gmin, gmax, mult = sqrt(2))^2 } @@ -3038,12 +3223,8 @@ computeCovFlash <- function(Y) { if (nrow(covar) == 0) { abort("computeCovFlash: FLASH produced an empty covariance matrix.") } - s <- apply(Y, 2, sd, na.rm = TRUE) - if (length(s) > 1) { - s <- diag(s) - } else { - s <- matrix(s, 1, 1) - } + sds <- apply(Y, 2, sd, na.rm = TRUE) + s <- if (length(sds) > 1) diag(sds) else matrix(sds, 1, 1) s %*% cov2cor(covar) %*% s } diff --git a/R/relatednessQc.R b/R/relatednessQc.R index 8246e896..d8911a3e 100644 --- a/R/relatednessQc.R +++ b/R/relatednessQc.R @@ -67,40 +67,94 @@ filterRelatedness <- function( ) { .relatednessRequirePackages() analysisType <- arg_match(analysisType) - p <- as.list(environment()) - p$relatedness <- as_tibble(relatedness) + relatedness <- as_tibble(relatedness) if (analysisType == "maximizeCases" && is.null(phenoData)) { abort("Must provide phenoData when analysisType is 'maximizeCases'") } # Phase 1: graph-based pre-pruning of large components. - highRelatedIndiv <- .relatednessPrune(p) - kin <- .relatednessRemovePruned(p$relatedness, highRelatedIndiv, p) + highRelatedIndiv <- .relatednessPrune( + relatedness, + relatednessValue, + relatednessThreshold, + relatednessIid1, + relatednessIid2, + maxComponentSize, + reduceFraction, + verbose + ) + kin <- .relatednessRemovePruned( + relatedness, + highRelatedIndiv, + relatednessIid1, + relatednessIid2 + ) # Phase 2: plinkQC-based filtering (analysis-type dependent). - plinkqcArgs <- .relatednessBuildPlinkqcArgs(p) - filtered <- .relatednessPhase2(kin, plinkqcArgs, analysisType, p) + plinkqcArgs <- .relatednessBuildPlinkqcArgs( + otherCriterion, + relatednessThreshold, + relatednessIid1, + relatednessIid2, + otherCriterionThreshold, + otherCriterionDirection, + relatednessFid1, + relatednessFid2, + relatednessValue, + otherCriterionIid, + otherCriterionMeasure, + verbose + ) + filtered <- .relatednessPhase2( + kin, + plinkqcArgs, + analysisType, + phenoData, + phenoCol, + relatednessIid1, + relatednessIid2 + ) # Phase 3: iterative cleanup + combine with the graph-pruned individuals. - allExclude <- .relatednessIterativeCleanup( + cleaned <- .relatednessIterativeCleanup( filtered$kin, filtered$allExclude, plinkqcArgs, - p + maxIterations, + verbose, + relatednessIid1, + relatednessIid2, + relatednessValue, + relatednessThreshold ) - allExclude <- unique(c(allExclude, highRelatedIndiv)) - .relatednessReport(allExclude, p) + allExclude <- unique(c(cleaned, highRelatedIndiv)) + .relatednessReport(allExclude, verbose, relatednessThreshold) allExclude } # Phase-2 dispatch: maximizeUnrelated runs plinkQC directly; maximizeCases # preserves cases. Returns list(allExclude, kin). # @noRd -.relatednessPhase2 <- function(kin, plinkqcArgs, analysisType, p) { +.relatednessPhase2 <- function( + kin, + plinkqcArgs, + analysisType, + phenoData, + phenoCol, + relatednessIid1, + relatednessIid2 +) { if (analysisType == "maximizeUnrelated") { return(list( allExclude = .relatednessRunPlinkqc(kin, plinkqcArgs)$IID, kin = kin )) } - .relatednessMaximizeCases(kin, plinkqcArgs, p) + .relatednessMaximizeCases( + kin, + plinkqcArgs, + phenoData, + phenoCol, + relatednessIid1, + relatednessIid2 + ) } # @noRd @@ -113,41 +167,86 @@ filterRelatedness <- function( } } +# Size of the largest component, or 0 when the graph has none. Guards +# max(integer(0)), which warns and returns -Inf -- with no related pairs the +# loop below must simply not run. +# @noRd +.relatednessLargestComponent <- function(workingComp) { + if (length(workingComp$csize) == 0L) 0L else max(workingComp$csize) +} + # Graph pre-pruning: iteratively remove the highest-degree nodes of any # component larger than maxComponentSize. Returns the pruned individuals. # @noRd -.relatednessPrune <- function(p) { +.relatednessPrune <- function( + relatedness, + relatednessValue, + relatednessThreshold, + relatednessIid1, + relatednessIid2, + maxComponentSize, + reduceFraction, + verbose +) { relatedPairs <- filter( - p$relatedness, - .data[[p$relatednessValue]] >= p$relatednessThreshold + relatedness, + .data[[relatednessValue]] >= relatednessThreshold ) edges <- select( relatedPairs, - all_of(c(p$relatednessIid1, p$relatednessIid2)) + all_of(c(relatednessIid1, relatednessIid2)) ) # igraph requires a base data.frame (it sets row names on the input). workingGraph <- igraph::graph_from_data_frame( as.data.frame(edges), directed = FALSE ) - workingComp <- igraph::components(workingGraph) - highRelatedIndiv <- character(0) - while (max(workingComp$csize) > p$maxComponentSize) { - .relatednessPruneMessage(workingComp, p) - nodesToRemove <- .relatednessNodesToRemove(workingGraph, workingComp, p) - highRelatedIndiv <- c(highRelatedIndiv, nodesToRemove) - workingGraph <- igraph::delete_vertices(workingGraph, nodesToRemove) - workingComp <- igraph::components(workingGraph) + .relatednessPruneStep( + workingGraph, + character(0), + maxComponentSize, + reduceFraction, + verbose + ) +} + +# One pruning round: stop once the largest component fits, otherwise drop the +# chosen nodes and recurse on the smaller graph. Each round removes a +# fraction of the largest component, so the recursion is shallow. +# @noRd +.relatednessPruneStep <- function( + graph, + removed, + maxComponentSize, + reduceFraction, + verbose +) { + comp <- igraph::components(graph) + if (.relatednessLargestComponent(comp) <= maxComponentSize) { + return(removed) } - highRelatedIndiv + .relatednessPruneMessage(comp, verbose, reduceFraction) + nodesToRemove <- .relatednessNodesToRemove( + graph, + comp, + maxComponentSize, + reduceFraction + ) + .relatednessPruneStep( + igraph::delete_vertices(graph, nodesToRemove), + c(removed, nodesToRemove), + maxComponentSize, + reduceFraction, + verbose + ) } # @noRd -.relatednessPruneMessage <- function(workingComp, p) { - if (p$verbose) { +.relatednessPruneMessage <- function(workingComp, verbose, reduceFraction) { + if (verbose) { msg <- glue( "Largest component has {max(workingComp$csize)} individuals. ", - "Removing top {round(p$reduceFraction * 100)}% ", + "Removing top {round(reduceFraction * 100)}% ", "highest-degree nodes." ) inform(msg) @@ -157,14 +256,19 @@ filterRelatedness <- function( # The highest-degree nodes to remove across all over-sized components. # @noRd -.relatednessNodesToRemove <- function(workingGraph, workingComp, p) { - largeCompIds <- which(workingComp$csize > p$maxComponentSize) - unlist(map( +.relatednessNodesToRemove <- function( + workingGraph, + workingComp, + maxComponentSize, + reduceFraction +) { + largeCompIds <- which(workingComp$csize > maxComponentSize) + list_c(map( largeCompIds, .relatednessCompNodesToRemove, workingGraph = workingGraph, membership = workingComp$membership, - reduceFraction = p$reduceFraction + reduceFraction = reduceFraction )) } @@ -183,59 +287,84 @@ filterRelatedness <- function( # Drop the pre-pruned individuals from the relatedness data. # @noRd -.relatednessRemovePruned <- function(relatedness, highRelatedIndiv, p) { +.relatednessRemovePruned <- function( + relatedness, + highRelatedIndiv, + relatednessIid1, + relatednessIid2 +) { filter( relatedness, - !is_in(.data[[p$relatednessIid1]], highRelatedIndiv) & - !is_in(.data[[p$relatednessIid2]], highRelatedIndiv) + !is_in(.data[[relatednessIid1]], highRelatedIndiv) & + !is_in(.data[[relatednessIid2]], highRelatedIndiv) ) } # @noRd -.relatednessBuildPlinkqcArgs <- function(p) { +.relatednessBuildPlinkqcArgs <- function( + otherCriterion, + relatednessThreshold, + relatednessIid1, + relatednessIid2, + otherCriterionThreshold, + otherCriterionDirection, + relatednessFid1, + relatednessFid2, + relatednessValue, + otherCriterionIid, + otherCriterionMeasure, + verbose +) { list( - otherCriterion = p$otherCriterion, - relatednessTh = p$relatednessThreshold, - relatednessIID1 = p$relatednessIid1, - relatednessIID2 = p$relatednessIid2, - otherCriterionTh = p$otherCriterionThreshold, - otherCriterionThDirection = p$otherCriterionDirection, - relatednessFID1 = p$relatednessFid1, - relatednessFID2 = p$relatednessFid2, - relatednessRelatedness = p$relatednessValue, - otherCriterionIID = p$otherCriterionIid, - otherCriterionMeasure = p$otherCriterionMeasure, - verbose = p$verbose + otherCriterion = otherCriterion, + relatednessTh = relatednessThreshold, + relatednessIID1 = relatednessIid1, + relatednessIID2 = relatednessIid2, + otherCriterionTh = otherCriterionThreshold, + otherCriterionThDirection = otherCriterionDirection, + relatednessFID1 = relatednessFid1, + relatednessFID2 = relatednessFid2, + relatednessRelatedness = relatednessValue, + otherCriterionIID = otherCriterionIid, + otherCriterionMeasure = otherCriterionMeasure, + verbose = verbose ) } # maximizeCases: preserve cases, preferentially remove controls. Returns # list(allExclude, kin) (kin is restricted to phenotyped individuals). # @noRd -.relatednessMaximizeCases <- function(kin, plinkqcArgs, p) { - phenoData <- as_tibble(p$phenoData) - phenoData <- filter(phenoData, !is.na(.data[[p$phenoCol]])) +.relatednessMaximizeCases <- function( + kin, + plinkqcArgs, + phenoData, + phenoCol, + relatednessIid1, + relatednessIid2 +) { relatedIndividuals <- unique(c( - kin[[p$relatednessIid1]], - kin[[p$relatednessIid2]] + kin[[relatednessIid1]], + kin[[relatednessIid2]] )) - phenoData <- filter(phenoData, is_in(.data$IID, relatedIndividuals)) - relatedCases <- phenoData |> - filter(.data[[p$phenoCol]] == 1) |> + related <- as_tibble(phenoData) |> + filter(!is.na(.data[[phenoCol]])) |> + filter(is_in(.data$IID, relatedIndividuals)) + relatedCases <- related |> + filter(.data[[phenoCol]] == 1) |> pull("IID") - relatedControls <- phenoData |> - filter(.data[[p$phenoCol]] == 0) |> + relatedControls <- related |> + filter(.data[[phenoCol]] == 0) |> pull("IID") kin <- filter( kin, - is_in(.data[[p$relatednessIid1]], phenoData$IID) & - is_in(.data[[p$relatednessIid2]], phenoData$IID) + is_in(.data[[relatednessIid1]], related$IID) & + is_in(.data[[relatednessIid2]], related$IID) ) # Step 1: filter among cases. caseKin <- filter( kin, - is_in(.data[[p$relatednessIid1]], relatedCases) & - is_in(.data[[p$relatednessIid2]], relatedCases) + is_in(.data[[relatednessIid1]], relatedCases) & + is_in(.data[[relatednessIid2]], relatedCases) ) relCases <- .relatednessRunPlinkqc(caseKin, plinkqcArgs) casesKeep <- setdiff(relatedCases, relCases$IID) @@ -244,14 +373,15 @@ filterRelatedness <- function( kin, casesKeep, relatedControls, - p + relatednessIid1, + relatednessIid2 ) # Step 3: filter among the remaining controls. controlsKeep <- setdiff(relatedControls, controlsExclude) controlKin <- filter( kin, - is_in(.data[[p$relatednessIid1]], controlsKeep) & - is_in(.data[[p$relatednessIid2]], controlsKeep) + is_in(.data[[relatednessIid1]], controlsKeep) & + is_in(.data[[relatednessIid2]], controlsKeep) ) relControls <- .relatednessRunPlinkqc(controlKin, plinkqcArgs) list( @@ -263,9 +393,15 @@ filterRelatedness <- function( # Controls related to a retained case (row order preserved; a case--control # edge excludes the control, mirroring the original per-row if / else-if). # @noRd -.relatednessControlsToExclude <- function(kin, casesKeep, relatedControls, p) { - iid1 <- kin[[p$relatednessIid1]] - iid2 <- kin[[p$relatednessIid2]] +.relatednessControlsToExclude <- function( + kin, + casesKeep, + relatedControls, + relatednessIid1, + relatednessIid2 +) { + iid1 <- kin[[relatednessIid1]] + iid2 <- kin[[relatednessIid2]] mask1 <- is_in(iid1, casesKeep) & is_in(iid2, relatedControls) mask2 <- is_in(iid2, casesKeep) & is_in(iid1, relatedControls) contrib <- case_when( @@ -279,49 +415,102 @@ filterRelatedness <- function( # Iteratively re-run plinkQC on the still-related pairs until none remain or # maxIterations is hit. Returns the accumulated exclusion set. # @noRd -.relatednessIterativeCleanup <- function(kin, allExclude, plinkqcArgs, p) { - remaining <- .relatednessRemaining(kin, allExclude, p) - iter <- 0L - while (nrow(remaining) > 0 && iter < p$maxIterations) { - if (p$verbose) { - msg <- glue( - "Iteration {iter + 1L}: {nrow(remaining)} related pairs ", - "remaining." - ) - inform(msg) - } - additional <- .relatednessRunPlinkqc(remaining, plinkqcArgs) - allExclude <- c(allExclude, additional$IID) - remaining <- .relatednessRemaining(kin, allExclude, p) - iter <- iter + 1L - } - if (nrow(remaining) > 0) { +.relatednessIterativeCleanup <- function( + kin, + allExclude, + plinkqcArgs, + maxIterations, + verbose, + relatednessIid1, + relatednessIid2, + relatednessValue, + relatednessThreshold +) { + remainingArgs <- list( + relatednessIid1 = relatednessIid1, + relatednessIid2 = relatednessIid2, + relatednessValue = relatednessValue, + relatednessThreshold = relatednessThreshold + ) + final <- .relatednessCleanupStep( + kin = kin, + allExclude = allExclude, + iter = 0L, + maxIterations = maxIterations, + plinkqcArgs = plinkqcArgs, + remainingArgs = remainingArgs, + verbose = verbose + ) + if (nrow(final$remaining) > 0) { msg <- glue( - "After {p$maxIterations} iterations, {nrow(remaining)} related ", - "pairs remain." + "After {maxIterations} iterations, {nrow(final$remaining)} ", + "related pairs remain." ) warn(msg) } - allExclude + final$allExclude +} + +# One cleanup round: re-run plinkQC on whatever is still related, add its +# exclusions, and recurse until nothing is related or the iteration cap is +# reached. Returns the accumulated exclusions and what is still related. +# @noRd +.relatednessCleanupStep <- function( + kin, + allExclude, + iter, + maxIterations, + plinkqcArgs, + remainingArgs, + verbose +) { + remaining <- exec(.relatednessRemaining, kin, allExclude, !!!remainingArgs) + if (nrow(remaining) == 0 || iter >= maxIterations) { + return(list(allExclude = allExclude, remaining = remaining)) + } + if (verbose) { + msg <- glue( + "Iteration {iter + 1L}: {nrow(remaining)} related pairs ", + "remaining." + ) + inform(msg) + } + additional <- .relatednessRunPlinkqc(remaining, plinkqcArgs) + .relatednessCleanupStep( + kin = kin, + allExclude = c(allExclude, additional$IID), + iter = iter + 1L, + maxIterations = maxIterations, + plinkqcArgs = plinkqcArgs, + remainingArgs = remainingArgs, + verbose = verbose + ) } # The still-related pairs above threshold after excluding `allExclude`. # @noRd -.relatednessRemaining <- function(kin, allExclude, p) { +.relatednessRemaining <- function( + kin, + allExclude, + relatednessIid1, + relatednessIid2, + relatednessValue, + relatednessThreshold +) { remaining <- filter( kin, - !is_in(.data[[p$relatednessIid1]], allExclude) & - !is_in(.data[[p$relatednessIid2]], allExclude) + !is_in(.data[[relatednessIid1]], allExclude) & + !is_in(.data[[relatednessIid2]], allExclude) ) - filter(remaining, .data[[p$relatednessValue]] > p$relatednessThreshold) + filter(remaining, .data[[relatednessValue]] > relatednessThreshold) } # @noRd -.relatednessReport <- function(allExclude, p) { - if (p$verbose) { +.relatednessReport <- function(allExclude, verbose, relatednessThreshold) { + if (verbose) { msg <- glue( "{length(allExclude)} individuals excluded at kinship ", - "threshold {p$relatednessThreshold}" + "threshold {relatednessThreshold}" ) inform(msg) } diff --git a/R/sldscPostprocessingPipeline.R b/R/sldscPostprocessingPipeline.R index 1b6cf573..1653147b 100644 --- a/R/sldscPostprocessingPipeline.R +++ b/R/sldscPostprocessingPipeline.R @@ -123,18 +123,18 @@ sldscPostprocessingPipeline <- function( .sldscComputeRefStats <- function(sldscData, mafCutoff) { inform("[sldsc] Computing M_ref...") MRef <- computeSldscMRef(sldscData, mafCutoff = mafCutoff) - msg <- glue("[sldsc] M_ref = {MRef} (MAF cutoff {mafCutoff})") - inform(msg) + inform(glue("[sldsc] M_ref = {MRef} (MAF cutoff {mafCutoff})")) inform("[sldsc] Computing per-annotation sd...") sdAnnotFull <- computeSldscAnnotSd(sldscData, mafCutoff = mafCutoff) nSd <- length(sdAnnotFull) - msg <- glue("[sldsc] sd computed for {nSd} annotation columns") - inform(msg) + inform(glue("[sldsc] sd computed for {nSd} annotation columns")) inform("[sldsc] Detecting binary vs continuous annotations...") isBinaryFull <- isBinarySldscAnnot(sldscData) - names(sdAnnotFull) <- str_c(names(sdAnnotFull), "_0") - names(isBinaryFull) <- str_c(names(isBinaryFull), "_0") - list(MRef = MRef, sdAnnotFull = sdAnnotFull, isBinaryFull = isBinaryFull) + list( + MRef = MRef, + sdAnnotFull = .sldscSuffixNames(sdAnnotFull), + isBinaryFull = .sldscSuffixNames(isBinaryFull) + ) } # Resolve the target categories: keep the user's set, else auto-detect from a @@ -176,26 +176,27 @@ sldscPostprocessingPipeline <- function( # first single run. # @noRd .sldscPivotRun <- function(sldscData, trait1) { - pivotRun <- getTraitRun(sldscData, trait1, "joint") - if (is.null(pivotRun)) { - pivotRun <- getTraitRun(sldscData, trait1, "single", 1L) - } + pivotRun <- getTraitRun(sldscData, trait1, "joint") %||% + getTraitRun(sldscData, trait1, "single", 1L) pivotRun } +# polyfun appends "_0" to every annotation name in its .results table, so the +# per-annotation vectors have to carry the same suffix to join against it. +# @noRd +.sldscSuffixNames <- function(x) set_names(x, str_c(names(x), "_0")) + # Positional-rename fallback: trust polyfun's invariant that target categories # occupy the first length(sdAnnotFull) rows of .results. Returns the renamed # list(targetCategories, sdAnnotFull, isBinaryFull). # @noRd .sldscFallbackRename <- function(pivotRun, ref) { - sdAnnotFull <- ref$sdAnnotFull - isBinaryFull <- ref$isBinaryFull - nTarget <- length(sdAnnotFull) + nTarget <- length(ref$sdAnnotFull) nBaseline <- length(pivotRun$categories) - nTarget - oldNames <- names(sdAnnotFull) + oldNames <- names(ref$sdAnnotFull) targetCategories <- pivotRun$categories[seq_len(nTarget)] - names(sdAnnotFull) <- targetCategories - names(isBinaryFull) <- targetCategories + sdAnnotFull <- set_names(ref$sdAnnotFull, targetCategories) + isBinaryFull <- set_names(ref$isBinaryFull, targetCategories) .sldscFallbackMessage( pivotRun, oldNames, @@ -318,10 +319,7 @@ sldscPostprocessingPipeline <- function( # list(singleDf, blocksSingle, singleH2gs). # @noRd .sldscTraitSingle <- function(trait, ctx) { - singleRuns <- getTraitRun(ctx$sldscData, trait, "single") - if (is.null(singleRuns)) { - singleRuns <- list() - } + singleRuns <- getTraitRun(ctx$sldscData, trait, "single") %||% list() nRun <- min(length(ctx$targetCategories), length(singleRuns)) stds <- compact(map( seq_len(nRun), @@ -334,9 +332,10 @@ sldscPostprocessingPipeline <- function( # Standardize the i-th single run (NULL + warning on failure). # @noRd +#' @importFrom rlang try_fetch .sldscStandardizeSingle <- function(i, trait, ctx) { catName <- ctx$targetCategories[i] - std <- tryCatch( + std <- try_fetch( standardizeSldscTrait( ctx$sldscData, trait, @@ -346,13 +345,11 @@ sldscPostprocessingPipeline <- function( MRef = ctx$MRef, targetCategories = catName ), - error = function(e) { - eMsg <- e$message + error = function(cnd) { msg <- glue( - "[sldsc] Failed to standardize single {catName} for ", - "{trait}: {eMsg}" + "[sldsc] Failed to standardize single {catName} for {trait}" ) - warn(msg) + warn(msg, parent = cnd) NULL } ) @@ -401,7 +398,7 @@ sldscPostprocessingPipeline <- function( if (is.null(getTraitRun(ctx$sldscData, trait, "joint"))) { return(empty) } - std <- tryCatch( + std <- try_fetch( standardizeSldscTrait( ctx$sldscData, trait, @@ -410,12 +407,9 @@ sldscPostprocessingPipeline <- function( MRef = ctx$MRef, targetCategories = ctx$targetCategories ), - error = function(e) { - eMsg <- e$message - msg <- glue( - "[sldsc] Failed to standardize joint for {trait}: {eMsg}" - ) - warn(msg) + error = function(cnd) { + msg <- glue("[sldsc] Failed to standardize joint for {trait}") + warn(msg, parent = cnd) NULL } ) @@ -474,23 +468,25 @@ sldscPostprocessingPipeline <- function( # Combine tauStar single + joint into one wide frame (joint aligned by target). # @noRd .sldscCombineTauStar <- function(metaTauStarSingle, metaTauStarJoint) { - metaTauStar <- metaTauStarSingle - ord <- match(metaTauStar$target, metaTauStarJoint$target) - metaTauStar$jointMean <- metaTauStarJoint$jointMean[ord] - metaTauStar$jointSe <- metaTauStarJoint$jointSe[ord] - metaTauStar$jointP <- metaTauStarJoint$jointP[ord] - metaTauStar + ord <- match(metaTauStarSingle$target, metaTauStarJoint$target) + mutate( + metaTauStarSingle, + jointMean = metaTauStarJoint$jointMean[ord], + jointSe = metaTauStarJoint$jointSe[ord], + jointP = metaTauStarJoint$jointP[ord] + ) } # Two-channel enrichment meta: effect/SE from E, p-value from EnrichStat. # @noRd .sldscCombineEnrichment <- function(metaESingle, metaEsSingle) { - metaEnrichment <- metaESingle - metaEnrichment$singleP <- metaEsSingle$singleP[match( - metaEnrichment$target, - metaEsSingle$target - )] - metaEnrichment + mutate( + metaESingle, + singleP = metaEsSingle$singleP[match( + metaESingle$target, + metaEsSingle$target + )] + ) } # Assemble the pipeline result (per_trait + meta + params). @@ -538,44 +534,74 @@ sldscPostprocessingPipeline <- function( abort(msg) } relab <- set_names(targetLabels, targetCategories) - res$per_trait <- .sldscRelabelPerTrait(res$per_trait, relab) - res$meta <- .sldscRelabelMeta(res$meta, relab) - res$params$target_categories_orig <- res$params$target_categories - res$params$target_categories <- unname(relab[targetCategories]) + relabelled <- list_assign( + res, + per_trait = .sldscRelabelPerTrait(res$per_trait, relab), + meta = .sldscRelabelMeta(res$meta, relab), + params = list_assign( + res$params, + target_categories_orig = res$params$target_categories, + target_categories = unname(relab[targetCategories]) + ) + ) .sldscRelabelMessage(targetCategories, relab) - res + relabelled } # @noRd .sldscRelabelPerTrait <- function(perTrait, relab) { - for (t in names(perTrait)) { - perTrait[[t]] <- .sldscRelabelOneTrait(perTrait[[t]], relab) - } - perTrait + map(perTrait, .sldscRelabelOneTrait, relab = relab) } # @noRd .sldscRelabelOneTrait <- function(pt, relab) { - if (!is.null(pt$summary) && is_in("target", names(pt$summary))) { - pt$summary$target <- .sldscRelabVec(pt$summary$target, relab) - } - for (bn in c("tau_star_blocks_single", "tau_star_blocks_joint")) { - b <- pt[[bn]] - if (!is.null(b) && !is.null(colnames(b))) { - colnames(pt[[bn]]) <- .sldscRelabVec(colnames(b), relab) - } + relabelled <- if ( + !is.null(pt$summary) && is_in("target", names(pt$summary)) + ) { + list( + summary = mutate( + pt$summary, + target = .sldscRelabVec(pt$summary$target, relab) + ) + ) + } else { + list() } - pt + blockNames <- keep( + c("tau_star_blocks_single", "tau_star_blocks_joint"), + .sldscBlockHasColnames, + pt = pt + ) + blocks <- set_names( + map(pt[blockNames], .sldscRelabColnames, relab = relab), + blockNames + ) + list_assign(pt, !!!relabelled, !!!blocks) +} + +# @noRd +.sldscBlockHasColnames <- function(bn, pt) { + !is.null(pt[[bn]]) && !is.null(colnames(pt[[bn]])) +} + +# @noRd +.sldscRelabColnames <- function(b, relab) { + `colnames<-`(b, .sldscRelabVec(colnames(b), relab)) } # @noRd .sldscRelabelMeta <- function(meta, relab) { - for (mn in names(meta)) { - if (!is.null(meta[[mn]]) && is_in("target", names(meta[[mn]]))) { - meta[[mn]]$target <- .sldscRelabVec(meta[[mn]]$target, relab) - } + map(meta, .sldscRelabelMetaEntry, relab = relab) +} + +# One meta table with its target column relabelled, or passed through when it +# has no target column to relabel. +# @noRd +.sldscRelabelMetaEntry <- function(entry, relab) { + if (is.null(entry) || !is_in("target", names(entry))) { + return(entry) } - meta + mutate(entry, target = .sldscRelabVec(entry$target, relab)) } # @noRd @@ -597,23 +623,30 @@ sldscPostprocessingPipeline <- function( isBinary, targetCategories ) { - rows <- list() - for (category in targetCategories) { - m <- metaSldscRandom(view, category, quantity) - rows[[category]] <- tibble( - target = category, - isBinary = unname(isBinary[category]), - mean = m$mean, - se = m$se, - p = m$p, - nTraits = m$nTraits - ) - } - df <- bind_rows(rows) + df <- bind_rows(map( + targetCategories, + .sldscCategoryRow, + view = view, + quantity = quantity, + isBinary = isBinary + )) nmOld <- c("mean", "se", "p") nmNew <- str_c(label, str_to_upper(str_sub(nmOld, 1, 1)), str_sub(nmOld, 2)) - names(df)[is_in(names(df), nmOld)] <- nmNew - df + rename(df, !!!set_names(nmOld, nmNew)) +} + +# One category's meta row. +# @noRd +.sldscCategoryRow <- function(category, view, quantity, isBinary) { + m <- metaSldscRandom(view, category, quantity) + tibble( + target = category, + isBinary = unname(isBinary[category]), + mean = m$mean, + se = m$se, + p = m$p, + nTraits = m$nTraits + ) } # Relabel a target-category vector via the `relab` map, leaving unmapped values @@ -621,6 +654,5 @@ sldscPostprocessingPipeline <- function( # @noRd .sldscRelabVec <- function(x, relab) { y <- unname(relab[x]) - y[is.na(y)] <- x[is.na(y)] - y + replace(y, is.na(y), x[is.na(y)]) } diff --git a/R/sldscWrapper.R b/R/sldscWrapper.R index 9757b2f9..c63b9967 100644 --- a/R/sldscWrapper.R +++ b/R/sldscWrapper.R @@ -29,6 +29,7 @@ } +#' @importFrom checkmate assertFileExists #' @title Read S-LDSC outputs from polyfun for one trait/run #' #' @description Reads the regression outputs produced by `polyfun/ldsc.py` for a @@ -56,12 +57,7 @@ #' @export readSldscTrait <- function(prefix) { files <- str_c(prefix, c(".results", ".log", ".part_delete")) - for (f in files) { - if (!file.exists(f)) { - msg <- glue("readSldscTrait: missing file: {f}") - abort(msg) - } - } + assertFileExists(files, access = "r", .var.name = "readSldscTrait input") results <- vroom(files[1], show_col_types = FALSE) cats <- as.character(results$Category) h2g <- .readSldscH2g(files[2]) @@ -123,11 +119,11 @@ readSldscTrait <- function(prefix) { ) abort(msg) } - colnames(deleteValues) <- cats - deleteValues + `colnames<-`(deleteValues, cats) } +#' @importFrom checkmate assertDirectoryExists #' @title Read target annotation files (.annot.gz) into one table #' #' @description Reads the per-chromosome polyfun `.annot.gz` files in a @@ -148,12 +144,11 @@ readSldscTrait <- function(prefix) { #' readSldscAnnot(sldsc) #' @export readSldscAnnot <- function(targetAnnoDir, annotCols = NULL) { - if (!dir.exists(targetAnnoDir)) { - msg <- glue( - "readSldscAnnot: targetAnnoDir does not exist: {targetAnnoDir}" - ) - abort(msg) - } + assertDirectoryExists( + targetAnnoDir, + access = "r", + .var.name = "targetAnnoDir" + ) annoFiles <- list.files( targetAnnoDir, pattern = "\\.annot\\.gz$", @@ -181,6 +176,7 @@ readSldscAnnot <- function(targetAnnoDir, annotCols = NULL) { } +#' @importFrom checkmate assertDirectoryExists #' @title Read PLINK allele-frequency files (.frq) into one table #' #' @description Reads the per-chromosome PLINK `.frq` files for the reference @@ -200,22 +196,19 @@ readSldscAnnot <- function(targetAnnoDir, annotCols = NULL) { #' head(readSldscFrq(sldsc, plinkName = "reference.")) #' @export readSldscFrq <- function(frqfileDir, plinkName = "ADSP_chr") { - if (!dir.exists(frqfileDir)) { - msg <- glue("readSldscFrq: frqfileDir does not exist: {frqfileDir}") - abort(msg) - } + assertDirectoryExists(frqfileDir, access = "r", .var.name = "frqfileDir") pat <- str_c( "^", str_replace_all(plinkName, "([.])", "\\\\\\1"), "[0-9]+\\.frq$" ) - frqFiles <- list.files(frqfileDir, pattern = pat, full.names = TRUE) - if (length(frqFiles) == 0L) { - frqFiles <- list.files( - frqfileDir, - pattern = "\\.frq$", - full.names = TRUE - ) + # The per-chromosome pattern first; a directory holding a single + # unnumbered .frq falls back to the bare extension. + matched <- list.files(frqfileDir, pattern = pat, full.names = TRUE) + frqFiles <- if (length(matched) > 0L) { + matched + } else { + list.files(frqfileDir, pattern = "\\.frq$", full.names = TRUE) } if (length(frqFiles) == 0L) { msg <- glue("readSldscFrq: no .frq files in: {frqfileDir}") @@ -227,6 +220,7 @@ readSldscFrq <- function(frqfileDir, plinkName = "ADSP_chr") { } +#' @importFrom checkmate assertClass #' @title Compute per-annotation standard deviation, MAF-restricted #' #' @description Computes the standard deviation of each annotation column in the @@ -272,9 +266,7 @@ readSldscFrq <- function(frqfileDir, plinkName = "ADSP_chr") { #' @importFrom purrr map map_dbl compact reduce #' @export computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { - if (!is(sldscData, "SldscData")) { - abort("computeSldscAnnotSd: `sldscData` must be an SldscData object.") - } + assertClass(sldscData, "SldscData") annot <- getAnnotData(sldscData) frq <- getFrqData(sldscData) if (mafCutoff > 0 && nrow(frq) == 0L) { @@ -329,14 +321,13 @@ computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { # the chromosome has <= 1 usable variant after MAF filtering. # @noRd .sldscChromVar <- function(chrom, annot, frq, mafCutoff, colsUse) { - dat <- filter(annot, .data$CHR == chrom) - if (mafCutoff > 0) { - dat <- inner_join( - dat, - select(frq, all_of(c("SNP", "MAF"))), - by = "SNP" - ) - dat <- filter(dat, !is.na(.data$MAF) & .data$MAF > mafCutoff) + onChrom <- filter(annot, .data$CHR == chrom) + dat <- if (mafCutoff > 0) { + onChrom |> + inner_join(select(frq, all_of(c("SNP", "MAF"))), by = "SNP") |> + filter(!is.na(.data$MAF) & .data$MAF > mafCutoff) + } else { + onChrom } if (nrow(dat) <= 1L) { return(NULL) @@ -347,6 +338,7 @@ computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { } +#' @importFrom checkmate assertClass #' @title Reference-panel SNP count (the M_ref used to standardise tau*) #' #' @description `M_ref` is the number of SNPs in the REFERENCE PANEL over which @@ -398,9 +390,7 @@ computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { #' computeSldscMRef(sldscData = sd) #' @export computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { - if (!is(sldscData, "SldscData")) { - abort("computeSldscMRef: `sldscData` must be an SldscData object.") - } + assertClass(sldscData, "SldscData") frq <- getFrqData(sldscData) if (nrow(frq) > 0L) { return(as.integer( @@ -422,6 +412,7 @@ computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { } +#' @importFrom checkmate assertClass #' @title Detect whether each annotation is binary or continuous #' #' @description Inspects each annotation column and returns whether its values @@ -461,9 +452,7 @@ computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { #' isBinarySldscAnnot(sd) #' @export isBinarySldscAnnot <- function(sldscData, annotCols = NULL) { - if (!is(sldscData, "SldscData")) { - abort("isBinarySldscAnnot: `sldscData` must be an SldscData object.") - } + assertClass(sldscData, "SldscData") annot <- getAnnotData(sldscData) colsUse <- if (is.null(annotCols)) { getAnnotCols(sldscData) @@ -473,15 +462,18 @@ isBinarySldscAnnot <- function(sldscData, annotCols = NULL) { annotCols } - isBinary <- set_names(rep(TRUE, length(colsUse)), colsUse) - for (col in colsUse) { - vals <- unique(na.omit(as.numeric(annot[[col]]))) - if (any(!is_in(vals, c(0, 1)))) isBinary[[col]] <- FALSE - } - isBinary + set_names(map_lgl(colsUse, .sldscColIsBinary, annot = annot), colsUse) +} + +# An annotation is binary when every non-missing value is 0 or 1. +# @noRd +.sldscColIsBinary <- function(col, annot) { + vals <- unique(na.omit(as.numeric(annot[[col]]))) + all(is_in(vals, c(0, 1))) } +#' @importFrom checkmate assertClass #' @title Standardize tau and compute EnrichStat for one polyfun run #' #' @description Applies the Gazal standardization \eqn{\tau^*_C = \tau_C \cdot @@ -544,9 +536,7 @@ standardizeSldscTrait <- function( MRef, targetCategories = NULL ) { - if (!is(sldscData, "SldscData")) { - abort("standardizeSldscTrait: `sldscData` must be an SldscData object.") - } + assertClass(sldscData, "SldscData") mode <- arg_match(mode) traitData <- .stdTraitRun(sldscData, trait, mode, idx) targetCategories <- .stdTargetCategories( @@ -561,15 +551,11 @@ standardizeSldscTrait <- function( tauSe <- as.numeric(traitData$tauSe[targetCategories]) blocksTarget <- traitData$tauBlocks[, targetIdx, drop = FALSE] ts <- standardizeTauStar(tau, blocksTarget, sdTarget, MRef, h2g) - summaryDf <- .stdSummaryDf(targetCategories, tau, tauSe, ts) - if (mode == "single") { - summaryDf <- .stdEnrichmentCols( - summaryDf, - traitData, - targetCategories, - h2g, - MRef - ) + base <- .stdSummaryDf(targetCategories, tau, tauSe, ts) + summaryDf <- if (mode != "single") { + base + } else { + .stdEnrichmentCols(base, traitData, targetCategories, h2g, MRef) } tauStarBlocks <- sweep(blocksTarget, 2L, sdTarget * MRef / h2g, FUN = "*") list( @@ -664,16 +650,20 @@ standardizeSldscTrait <- function( enrichstat <- (h2g / MRef) * ((pH2 / pM) - (1 - pH2) / (1 - pM)) enrichP <- as.numeric(traitData$enrichmentP[targetCategories]) absZ <- qnorm(1 - enrichP / 2) - enrichstatSe <- abs(enrichstat) / absZ - enrichstatSe[!is.finite(absZ) | absZ <= 0] <- NA_real_ - summaryDf$enrichment <- as.numeric(traitData$enrichment[targetCategories]) - summaryDf$enrichmentSe <- as.numeric( - traitData$enrichmentSe[targetCategories] + # A non-finite or non-positive |Z| carries no scale for the SE. + enrichstatSe <- replace( + abs(enrichstat) / absZ, + !is.finite(absZ) | absZ <= 0, + NA_real_ + ) + mutate( + summaryDf, + enrichment = as.numeric(traitData$enrichment[targetCategories]), + enrichmentSe = as.numeric(traitData$enrichmentSe[targetCategories]), + enrichmentP = enrichP, + enrichstat = enrichstat, + enrichstatSe = enrichstatSe ) - summaryDf$enrichmentP <- enrichP - summaryDf$enrichstat <- enrichstat - summaryDf$enrichstatSe <- enrichstatSe - summaryDf } @@ -817,15 +807,21 @@ metaSldscRandom <- function( "enrichstatSe" ) suffixCap <- str_c(str_to_upper(str_sub(suffix, 1, 1)), str_sub(suffix, 2)) - for (c in colsToAdd) { - newcol <- str_c(c, suffixCap) - if (!is.null(src) && is_in(c, names(src))) { - out[[newcol]] <- src[[c]][match(out$target, src$target)] - } else { - out[[newcol]] <- NA_real_ - } + added <- set_names( + map(colsToAdd, .sldscAlignedCol, out = out, src = src), + str_c(colsToAdd, suffixCap) + ) + mutate(out, !!!added) +} + +# One source column aligned to `out$target`, or an all-NA column when the +# source has nothing to say about it. +# @noRd +.sldscAlignedCol <- function(col, out, src) { + if (is.null(src) || !is_in(col, names(src))) { + return(NA_real_) } - out + src[[col]][match(out$target, src$target)] } # Internal helper: assemble a wide per-trait summary frame with single + joint @@ -848,9 +844,8 @@ metaSldscRandom <- function( isBinary = unname(isBinaryVec[rows]) ) - out <- .sldscAddCols(out, singleDf, "single") - out <- .sldscAddCols(out, jointDf, "joint") - out + .sldscAddCols(out, singleDf, "single") |> + .sldscAddCols(jointDf, "joint") } @@ -1060,11 +1055,18 @@ sldscSubsetMeta <- function( if (!any(avail)) { return(NULL) } - newDf <- tibble(target = df$target) - for (k in seq_along(colsHave)) { - if (avail[k]) newDf[[colsHave[k]]] <- df[[srcCols[k]]] - } - list(summary = newDf) + present <- colsHave[avail] + list( + summary = tibble( + target = df$target, + !!!set_names(map(srcCols[avail], .sldscColumnOf, df = df), present) + ) + ) +} + +# @noRd +.sldscColumnOf <- function(col, df) { + df[[col]] } # The random-effects meta result for one target category of a view. diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index 23aafade..d0d5a631 100644 --- a/R/sumstatsQc.R +++ b/R/sumstatsQc.R @@ -31,10 +31,11 @@ NULL # @noRd .variantsToDf <- function(x) { df <- if (is(x, "GRanges")) { - mc <- as.data.frame(mcols(x)) - mc$chrom <- as.character(seqnames(x)) - mc$pos <- start(x) - as_tibble(mc) + as_tibble(mutate( + as.data.frame(mcols(x)), + chrom = as.character(seqnames(x)), + pos = start(x) + )) } else { as_tibble(x) } @@ -69,7 +70,9 @@ NULL #' v2 <- data.frame(chrom = "1", pos = 2:4, alt = "A", ref = "G") #' mergeVariantInfo(v1, v2, all = TRUE) #' @export +#' @importFrom checkmate assertFlag mergeVariantInfo <- function(variants1, variants2, all = TRUE) { + assertFlag(all) df1 <- .variantsToDf(variants1) df2 <- .variantsToDf(variants2) @@ -80,23 +83,26 @@ mergeVariantInfo <- function(variants1, variants2, all = TRUE) { matchIdx <- match(key2, key1) hasMatch <- !is.na(matchIdx) - flip <- rep(FALSE, nrow(df2)) mi <- matchIdx[hasMatch] - flip[hasMatch] <- df2$alt[hasMatch] == df1$ref[mi] & - df2$ref[hasMatch] == df1$alt[mi] + flip <- replace( + rep(FALSE, nrow(df2)), + hasMatch, + df2$alt[hasMatch] == df1$ref[mi] & df2$ref[hasMatch] == df1$alt[mi] + ) - # Apply flips to df2 + # Apply flips to df2. Both replacements read the ORIGINAL `df2`, so the + # pair swaps rather than each taking the other's already-swapped value. flipRows <- which(hasMatch)[flip[hasMatch]] - if (length(flipRows) > 0) { - tmp <- df2$alt[flipRows] - df2$alt[flipRows] <- df2$ref[flipRows] - df2$ref[flipRows] <- tmp - } + flipped <- mutate( + df2, + alt = replace(.data$alt, flipRows, df2$ref[flipRows]), + ref = replace(.data$ref, flipRows, df2$alt[flipRows]) + ) if (all) { - distinct(bind_rows(df1, df2)) + distinct(bind_rows(df1, flipped)) } else { - df2 + flipped } } @@ -167,34 +173,95 @@ resolveLdInput <- function( ) abort(msg) } - if (!is_in("pos", lc)) { - colnames(sumStat)[which(is_in(lc, "position"))] <- "pos" + withPos <- if (is_in("pos", lc)) { + sumStat + } else { + `colnames<-`( + sumStat, + replace(colnames(sumStat), which(is_in(lc, "position")), "pos") + ) } - if (!is_in("z", lc)) { - colnames(sumStat)[which(is_in(lc, "zscore"))] <- "z" + named <- if (is_in("z", lc)) { + withPos + } else { + `colnames<-`( + withPos, + replace(colnames(withPos), which(is_in(lc, "zscore")), "z") + ) } - arrange(sumStat, .data$pos) + arrange(named, .data$pos) } # Run DENTIST on a single window, unpacking the shared tuning parameters. -.dentistCallSingle <- function(zScore, ldMat, nSample, p) { +.dentistCallSingle <- function( + zScore, + ldMat, + nSample, + pValueThreshold, + propSVD, + gcControl, + nIter, + gPvalueThreshold, + duprThreshold, + ncpus, + correctChenEtAlBug, + seed +) { dentistSingleWindow( zScore, R = ldMat, nSample = nSample, - pValueThreshold = p$pValueThreshold, - propSVD = p$propSVD, - gcControl = p$gcControl, - nIter = p$nIter, - gPvalueThreshold = p$gPvalueThreshold, - duprThreshold = p$duprThreshold, - ncpus = p$ncpus, - correctChenEtAlBug = p$correctChenEtAlBug, - seed = p$seed + pValueThreshold = pValueThreshold, + propSVD = propSVD, + gcControl = gcControl, + nIter = nIter, + gPvalueThreshold = gPvalueThreshold, + duprThreshold = duprThreshold, + ncpus = ncpus, + correctChenEtAlBug = correctChenEtAlBug, + seed = seed ) } # Segment into windows, run DENTIST per window, and merge the results. +# DENTIST on window `k`. +# @noRd +.dentistWindowAt <- function( + k, + sumStat, + ldMat, + nSample, + windowDividedRes, + pValueThreshold, + propSVD, + gcControl, + nIter, + gPvalueThreshold, + duprThreshold, + ncpus, + correctChenEtAlBug, + seed +) { + # windowEndIdx is 1-based exclusive; convert to an inclusive range. + idxRange <- windowDividedRes$windowStartIdx[ + k + ]:(windowDividedRes$windowEndIdx[k] - 1L) + .dentistCallSingle( + sumStat$z[idxRange], + ldMat[idxRange, idxRange], + nSample, + pValueThreshold = pValueThreshold, + propSVD = propSVD, + gcControl = gcControl, + nIter = nIter, + gPvalueThreshold = gPvalueThreshold, + duprThreshold = duprThreshold, + ncpus = ncpus, + correctChenEtAlBug = correctChenEtAlBug, + seed = seed + ) +} + .dentistWindows <- function( sumStat, ldMat, @@ -202,7 +269,15 @@ resolveLdInput <- function( windowMode, windowSize, minDim, - p + pValueThreshold, + propSVD, + gcControl, + nIter, + gPvalueThreshold, + duprThreshold, + ncpus, + correctChenEtAlBug, + seed ) { if (windowMode == "distance") { windowDividedRes <- segmentByDist( @@ -213,21 +288,23 @@ resolveLdInput <- function( } else { windowDividedRes <- segmentByCount(sumStat$pos, maxCount = minDim) } - dentistResultByWindow <- list() - for (k in seq_len(nrow(windowDividedRes))) { - # windowEndIdx is 1-based exclusive; convert to an inclusive range. - idxRange <- windowDividedRes$windowStartIdx[ - k - ]:(windowDividedRes$windowEndIdx[k] - 1L) - zScoreK <- sumStat$z[idxRange] - ldMatK <- ldMat[idxRange, idxRange] - dentistResultByWindow[[k]] <- .dentistCallSingle( - zScoreK, - ldMatK, - nSample, - p - ) - } + dentistResultByWindow <- map( + seq_len(nrow(windowDividedRes)), + .dentistWindowAt, + sumStat = sumStat, + ldMat = ldMat, + nSample = nSample, + windowDividedRes = windowDividedRes, + pValueThreshold = pValueThreshold, + propSVD = propSVD, + gcControl = gcControl, + nIter = nIter, + gPvalueThreshold = gPvalueThreshold, + duprThreshold = duprThreshold, + ncpus = ncpus, + correctChenEtAlBug = correctChenEtAlBug, + seed = seed + ) mergeWindows(dentistResultByWindow, windowDividedRes) } @@ -371,9 +448,21 @@ dentist <- function( nSample <- resolved$nSample sumStat <- .dentistResolveColumns(sumStat) windowMode <- arg_match(windowMode) - p <- as.list(environment()) if (nrow(sumStat) < minDim) { - return(.dentistCallSingle(sumStat$z, ldMat, nSample, p)) + return(.dentistCallSingle( + sumStat$z, + ldMat, + nSample, + pValueThreshold = pValueThreshold, + propSVD = propSVD, + gcControl = gcControl, + nIter = nIter, + gPvalueThreshold = gPvalueThreshold, + duprThreshold = duprThreshold, + ncpus = ncpus, + correctChenEtAlBug = correctChenEtAlBug, + seed = seed + )) } .dentistWindows( sumStat, @@ -382,7 +471,15 @@ dentist <- function( windowMode, windowSize, minDim, - p + pValueThreshold = pValueThreshold, + propSVD = propSVD, + gcControl = gcControl, + nIter = nIter, + gPvalueThreshold = gPvalueThreshold, + duprThreshold = duprThreshold, + ncpus = ncpus, + correctChenEtAlBug = correctChenEtAlBug, + seed = seed ) } @@ -416,23 +513,25 @@ dentist <- function( # Optionally deduplicate near-perfectly-correlated variants before imputation. .dentistDedup <- function(zScore, ldMat, duprThreshold) { - dedupRes <- NULL + if (duprThreshold >= 1.0) { + return(list(zScore = zScore, ldMat = ldMat, dedupRes = NULL)) + } rThreshold <- round(sqrt(duprThreshold) * 1000) / 1000 - if (duprThreshold < 1.0) { - dedupRes <- .findDuplicateVariants(zScore, ldMat, rThreshold) - numDup <- sum(dedupRes$dupBearer != -1) - if (numDup > 0) { - nZ <- length(zScore) - msg <- glue( - "{numDup} duplicated variants out of a total of {nZ} ", - "were found at r threshold of {rThreshold}" - ) - inform(msg) - } - zScore <- dedupRes$filteredZ - ldMat <- dedupRes$filteredLD + dedupRes <- .findDuplicateVariants(zScore, ldMat, rThreshold) + numDup <- sum(dedupRes$dupBearer != -1) + if (numDup > 0) { + nZ <- length(zScore) + msg <- glue( + "{numDup} duplicated variants out of a total of {nZ} ", + "were found at r threshold of {rThreshold}" + ) + inform(msg) } - list(zScore = zScore, ldMat = ldMat, dedupRes = dedupRes) + list( + zScore = dedupRes$filteredZ, + ldMat = dedupRes$filteredLD, + dedupRes = dedupRes + ) } # Run the C++ iterative imputation and snake_case the output. The C++ returns @@ -440,7 +539,7 @@ dentist <- function( # warning here (no warning handler / shared env needed). .dentistRunImpute <- function(ldMat, nSample, zScore, p) { verboseIter <- getOption("pecotmr.dentist.verbose", FALSE) - res <- dentistIterativeImpute( + raw <- dentistIterativeImpute( # cpp11 requires exact integer types for int parameters ldMat, as.integer(nSample), @@ -455,8 +554,8 @@ dentist <- function( verboseIter, if (is.null(p$seed)) NULL else as.integer(p$seed) ) - rsqExceed <- res$rsqExceed - res$rsqExceed <- NULL + rsqExceed <- raw$rsqExceed + res <- list_modify(raw, rsqExceed = zap()) if (length(rsqExceed) > 0) { nExceed <- length(rsqExceed) maxExceed <- max(rsqExceed) @@ -572,9 +671,11 @@ dentistSingleWindow <- function( ) orgZscore <- zScore dedup <- .dentistDedup(zScore, ldMat, duprThreshold) - res <- .dentistRunImpute(dedup$ldMat, nSample, dedup$zScore, p) - if (duprThreshold < 1.0) { - res <- addDupsBackDentist(orgZscore, res, dedup$dedupRes) + imputed <- .dentistRunImpute(dedup$ldMat, nSample, dedup$zScore, p) + res <- if (duprThreshold < 1.0) { + addDupsBackDentist(orgZscore, imputed, dedup$dedupRes) + } else { + imputed } .dentistOutlierStat(res, pValueThreshold) } @@ -612,17 +713,10 @@ dentistSingleWindow <- function( # Map each variant to its row in the de-duplicated DENTIST output. .dentistBuildAssignIdx <- function(dupBearer, nrowsDup) { - count <- 1 - assignIdx <- rep(0, nrowsDup) - for (i in seq_along(dupBearer)) { - if (dupBearer[i] == -1) { - assignIdx[i] <- count - count <- count + 1 - } else { - assignIdx[i] <- dupBearer[i] - } - } - assignIdx + # Non-duplicates take the next free slot, which is just how many + # non-duplicates have been seen so far; duplicates point at their bearer. + isNew <- dupBearer == -1 + if_else(isNew, as.numeric(cumsum(isNew)), as.numeric(dupBearer)) } # Rebuild the full per-variant table, recovering duplicates (sign-flipped). @@ -634,33 +728,26 @@ dentistSingleWindow <- function( iterToCorrect <- dentistOutput$iter_to_correct rsq <- dentistOutput$rsq zDiff <- dentistOutput$z_diff - updatedData <- tibble( - original_z = numeric(nrowsDup), - imputed_z = numeric(nrowsDup), - iter_to_correct = numeric(nrowsDup), - rsq = numeric(nrowsDup), - z_diff = numeric(nrowsDup), - is_duplicate = logical(nrowsDup) - ) - for (i in seq_len(nrowsDup)) { - updatedData$original_z[i] <- zScore[i] - updatedData$iter_to_correct[i] <- iterToCorrect[assignIdx[i]] - updatedData$rsq[i] <- rsq[assignIdx[i]] - if (dupBearer[i] == -1) { - updatedData$imputed_z[i] <- imputedZ[assignIdx[i]] - updatedData$z_diff[i] <- zDiff[assignIdx[i]] - updatedData$is_duplicate[i] <- FALSE - } else { - # Duplicate: sign-flip imputed_z, recompute z_diff from its own - # z-score so z_diff^2 matches the binary stat (DENTIST.h l706). - updatedData$imputed_z[i] <- imputedZ[assignIdx[i]] * sign[i] - denom <- sqrt(max(1 - updatedData$rsq[i], 1e-8)) - updatedData$z_diff[i] <- - (zScore[i] - updatedData$imputed_z[i]) / denom - updatedData$is_duplicate[i] <- TRUE - } - } - updatedData + # Every row is independent of every other, so the whole table is built in + # one shot. Duplicates sign-flip imputed_z and recompute z_diff from their + # own z-score, so z_diff^2 matches the binary stat (DENTIST.h l706). + isDup <- dupBearer != -1 + originalZ <- zScore[seq_len(nrowsDup)] + rsqRow <- rsq[assignIdx] + imputedRow <- imputedZ[assignIdx] * if_else(isDup, sign, 1) + denom <- sqrt(pmax(1 - rsqRow, 1e-8)) + tibble( + original_z = originalZ, + imputed_z = imputedRow, + iter_to_correct = iterToCorrect[assignIdx], + rsq = rsqRow, + z_diff = if_else( + isDup, + (originalZ - imputedRow) / denom, + zDiff[assignIdx] + ), + is_duplicate = isDup + ) } addDupsBackDentist <- function(zScore, dentistOutput, findDupOutput) { @@ -693,24 +780,16 @@ addDupsBackDentist <- function(zScore, dentistOutput, findDupOutput) { detectGaps <- function(pos, gapThreshold, verbose = FALSE) { n <- length(pos) diffs <- diff(pos) - allGaps <- c(1L) - for (i in seq_along(diffs)) { - if (diffs[i] > gapThreshold) { - allGaps <- c(allGaps, i + 1L) - } - } - allGaps <- c(allGaps, n + 1L) + allGaps <- c(1L, which(diffs > gapThreshold) + 1L, n + 1L) if (verbose && length(allGaps) - 2 > 0) { nGaps <- length(allGaps) - 2 - msg <- glue("No. of gaps found: {nGaps}") - inform(msg) + inform(glue("No. of gaps found: {nGaps}")) for (i in 2:(length(allGaps) - 1)) { gapNo <- i - 1 startPos <- pos[allGaps[i] - 1] endPos <- pos[allGaps[i]] - msg <- glue(" Gap {gapNo}: {startPos} - {endPos}", .trim = FALSE) - inform(msg) + inform(glue(" Gap {gapNo}: {startPos} - {endPos}", .trim = FALSE)) } } allGaps @@ -856,17 +935,28 @@ buildSegmentResult <- function( ) } +# One field across a block's window records, typed as `c()` would have left +# it (empty when the block produced no window). +# @noRd +.swlField <- function(windows, field) { + if (length(windows) == 0L) { + return(integer(0)) + } + list_c(map(windows, field)) +} + +# The loop itself stays: where the next window starts depends on the window +# just emitted, and the block ends when the stepper says so. What is gone is +# the four parallel `c()` accumulators -- each window is one record now, and +# the vectors are read off at the end. .swlBlockWindows <- function(blockStart, blockEnd, fns, ctx) { startIdx <- blockStart endIdx <- fns$initEndFn(startIdx, blockEnd, ctx) oldStartIdx <- startIdx notStartInterval <- FALSE - notLastInterval <- TRUE - times <- 0 - starts <- ends <- fillStarts <- fillEnds <- integer(0) + windows <- list() repeat { - times <- times + 1 - if (times > 400) { + if (length(windows) >= 400) { abort("Windowing iteration limit exceeded") } win <- .swlWindow( @@ -878,26 +968,51 @@ buildSegmentResult <- function( fns, ctx ) - startIdx <- win$startIdx - notLastInterval <- win$notLastInterval - starts <- c(starts, startIdx) - ends <- c(ends, min(endIdx, blockEnd)) - fillStarts <- c(fillStarts, win$fills$start) - fillEnds <- c(fillEnds, win$fills$end) - if (!notLastInterval) { + windows[[length(windows) + 1L]] <- list( + start = win$startIdx, + end = min(endIdx, blockEnd), + fillStart = win$fills$start, + fillEnd = win$fills$end + ) + if (!win$notLastInterval) { break } - oldStartIdx <- startIdx - stepped <- fns$stepFn(startIdx, blockEnd, ctx) + oldStartIdx <- win$startIdx + stepped <- fns$stepFn(win$startIdx, blockEnd, ctx) startIdx <- stepped$startIdx endIdx <- stepped$endIdx notStartInterval <- TRUE } list( - starts = starts, - ends = ends, - fillStarts = fillStarts, - fillEnds = fillEnds + starts = .swlField(windows, "start"), + ends = .swlField(windows, "end"), + fillStarts = .swlField(windows, "fillStart"), + fillEnds = .swlField(windows, "fillEnd") + ) +} + +# Is block `k` long enough to window? +# @noRd +.swlBlockQualifies <- function(k, allGaps, minBlockFn, ctx) { + minBlockFn(allGaps[k + 1] - allGaps[k], ctx) +} + +# Block `k`'s windows, with the block's outer fill bounds snapped to the +# block's own edges. `replace()` returns a copy, so nothing is mutated. +# @noRd +.swlBlockAt <- function(k, allGaps, fns, ctx) { + w <- .swlBlockWindows(allGaps[k], allGaps[k + 1], fns, ctx) + # First window's fill starts at the window start; last window's fill ends + # at the window end. + list( + starts = w$starts, + ends = w$ends, + fillStarts = replace(w$fillStarts, 1L, w$starts[1L]), + fillEnds = replace( + w$fillEnds, + length(w$fillEnds), + w$ends[length(w$ends)] + ) ) } @@ -912,10 +1027,6 @@ slidingWindowLoop <- function( adjustLastFn = NULL, verbose = FALSE ) { - startList <- integer(0) - endList <- integer(0) - fillStartList <- integer(0) - fillEndList <- integer(0) fns <- list( minBlockFn = minBlockFn, initEndFn = initEndFn, @@ -923,27 +1034,25 @@ slidingWindowLoop <- function( stepFn = stepFn, adjustLastFn = adjustLastFn ) - for (k in seq_len(length(allGaps) - 1)) { - blockStart <- allGaps[k] - blockEnd <- allGaps[k + 1] - if (!minBlockFn(blockEnd - blockStart, ctx)) { - next - } - w <- .swlBlockWindows(blockStart, blockEnd, fns, ctx) - # First window's fill starts at the window start; last window's fill - # ends at the window end. - w$fillStarts[1] <- w$starts[1] - w$fillEnds[length(w$fillEnds)] <- w$ends[length(w$ends)] - startList <- c(startList, w$starts) - endList <- c(endList, w$ends) - fillStartList <- c(fillStartList, w$fillStarts) - fillEndList <- c(fillEndList, w$fillEnds) - } + blocks <- keep( + seq_len(length(allGaps) - 1), + .swlBlockQualifies, + allGaps = allGaps, + minBlockFn = minBlockFn, + ctx = ctx + ) + windowed <- map( + blocks, + .swlBlockAt, + allGaps = allGaps, + fns = fns, + ctx = ctx + ) buildSegmentResult( - startList, - endList, - fillStartList, - fillEndList, + .swlField(windowed, "starts"), + .swlField(windowed, "ends"), + .swlField(windowed, "fillStarts"), + .swlField(windowed, "fillEnds"), n, verbose ) @@ -952,11 +1061,15 @@ slidingWindowLoop <- function( # Apply the quarter-distance index map `quaterIdx` `n` times to `x` (n = 1..4 # gives the 1st..4th quarter boundary from x). Used by segmentByDist. # @noRd +# One quarter-index hop; the step index is unused, `reduce` just applies it +# `n` times. +# @noRd +.nthQuaterStep <- function(x, step, quaterIdx) { + quaterIdx[x] +} + .nthQuaterIdx <- function(x, n, quaterIdx) { - for (i in seq_len(n)) { - x <- quaterIdx[x] - } - x + reduce(seq_len(n), .nthQuaterStep, quaterIdx = quaterIdx, .init = x) } #' Segment Genomic Region by Distance (Original DENTIST Algorithm) @@ -1001,22 +1114,20 @@ slidingWindowLoop <- function( # --- segmentByDist helpers -------------------------------------------------- # For each SNP, the last SNP index within cutoff/4 distance (clamped to [1, n]). +# For each SNP, the index of the last SNP within a quarter of `cutoff`. +# +# The C++ original walks a second pointer forward, which is the same thing as +# counting how many positions fall strictly below each target -- that is +# `findInterval(..., left.open = TRUE)`, so no pointer has to be carried. +# Verified identical to the pointer walk over 600 random inputs, tied +# positions included. .segByDistQuaterIdx <- function(pos, n, cutoff) { - quaterIdx <- integer(n) - j <- 1 - while (j <= n && pos[j] < cutoff / 4 + as.numeric(pos[1])) { - j <- j + 1 - } - quaterIdx[1] <- max(j - 1, 1L) - for (i in 2:n) { - j <- quaterIdx[i - 1] - while (j <= n && pos[j] < cutoff / 4 + as.numeric(pos[i])) { - j <- j + 1 - } - quaterIdx[i] <- max(j - 1, 1L) - } - quaterIdx <- pmin(quaterIdx, n) - pmax(quaterIdx, 1L) + lastBelow <- findInterval( + as.numeric(pos) + cutoff / 4, + pos, + left.open = TRUE + ) + pmax(pmin(lastBelow, n), 1L) } # Advance the window start by one quarter-step and recompute its end. @@ -1161,28 +1272,32 @@ segmentByCount <- function(pos, maxCount, gapDist = 1e6, verbose = FALSE) { #' within the fillers and combines them into a single data frame. #' #' @noRd +# Window `k`'s rows, indexed globally and trimmed to that window's fill range. +# @noRd +.dentistMergeWindowAt <- function(k, dentistResultByWindow, windowDividedRes) { + imputedK <- dentistResultByWindow[[k]] + offset <- windowDividedRes$windowStartIdx[k] - 1 + imputedK |> + mutate( + index_within_window = seq_len(nrow(imputedK)), + index_global = .data$index_within_window + offset + ) |> + filter( + .data$index_global >= windowDividedRes$fillStartIdx[k] & + .data$index_global < windowDividedRes$fillEndIdx[k] + ) +} + mergeWindows <- function(dentistResultByWindow, windowDividedRes) { if (length(dentistResultByWindow) != nrow(windowDividedRes)) { abort("Different number of windows and imputed results!") } - mergedResults <- c() - for (k in seq_len(nrow(windowDividedRes))) { - imputedK <- dentistResultByWindow[[k]] - imputedK$index_within_window <- seq_len(nrow(imputedK)) - imputedK <- imputedK |> - mutate( - index_global = .data$index_within_window + - windowDividedRes$windowStartIdx[k] - - 1 - ) - extractedResults <- imputedK |> - filter( - .data$index_global >= windowDividedRes$fillStartIdx[k] & - .data$index_global < windowDividedRes$fillEndIdx[k] - ) - mergedResults <- bind_rows(mergedResults, extractedResults) - } - return(mergedResults) + bind_rows(map( + seq_len(nrow(windowDividedRes)), + .dentistMergeWindowAt, + dentistResultByWindow = dentistResultByWindow, + windowDividedRes = windowDividedRes + )) } # ## File-I/O functions (dentist_from_files, read_dentist_sumstat, @@ -1239,6 +1354,7 @@ mergeWindows <- function(dentistResultByWindow, windowDividedRes) { } # Lead-variant LD column. From X, compute just that column (avoid full p x p). +#' @importFrom checkmate assertMatrix .slalomLeadR <- function(zScore, R, X, leadIdx) { if (!is.null(X)) { if (!is.matrix(X)) { @@ -1246,9 +1362,7 @@ mergeWindows <- function(dentistResultByWindow, windowDividedRes) { } return(as.numeric(cor(X, X[, leadIdx]))) } - if (!is.matrix(R) || nrow(R) != ncol(R) || nrow(R) != length(zScore)) { - abort("R must be a square matrix matching the length of zScore.") - } + assertMatrix(R, nrows = length(zScore), ncols = length(zScore)) R[, leadIdx] } @@ -1261,8 +1375,10 @@ mergeWindows <- function(dentistResultByWindow, windowDividedRes) { nlog10pDentistSThreshold ) { r2Lead <- rLead^2 - tDentistS <- (zScore - rLead * zScore[leadIdx])^2 / (1 - r2Lead) - tDentistS[tDentistS < 0] <- Inf + rawT <- (zScore - rLead * zScore[leadIdx])^2 / (1 - r2Lead) + # A negative statistic means 1 - r2 went negative (|r| > 1 from a + # mismatched panel); Inf routes it straight to the outlier branch. + tDentistS <- replace(rawT, rawT < 0, Inf) nlog10pDentistS <- -log10(pchisq(tDentistS, df = 1, lower.tail = FALSE)) outliers <- (r2Lead > r2Threshold) & (nlog10pDentistS > nlog10pDentistSThreshold) @@ -1434,38 +1550,38 @@ slalom <- function( #' df <- data.frame(cs_name = c("L1", "L2"), top_z = c(5, 3.5), #' p_value = c(1e-10, 1e-6)) #' autoDecision(df, highCorrCols = character(0)) +#' @importFrom checkmate assertCharacter #' @export autoDecision <- function(df, highCorrCols) { + assertCharacter(highCorrCols, any.missing = FALSE) # Identify top_cs topCsIndex <- which.max(abs(df$top_z)) - df$top_cs <- FALSE - df$top_cs[topCsIndex] <- TRUE - - # Identify tagged_cs - df$tagged_cs <- map_lgl( - seq_len(nrow(df)), - .autoDecisionTagged, - df = df, - highCorrCols = highCorrCols + withTop <- mutate(df, top_cs = seq_len(nrow(df)) == topCsIndex) + # Identify tagged_cs. `.autoDecisionTagged()` reads `top_cs`, so it has to + # see the frame that already carries it. + flagged <- mutate( + withTop, + tagged_cs = map_lgl( + seq_len(nrow(withTop)), + .autoDecisionTagged, + df = withTop, + highCorrCols = highCorrCols + ) ) - # Count total and remaining CS - totalCs <- nrow(df) - taggedCsCount <- sum(df$tagged_cs) - if (totalCs > 0) { - remainingCs <- totalCs - 1 - taggedCsCount - } else { - remainingCs <- 0 - } + totalCs <- nrow(flagged) + taggedCsCount <- sum(flagged$tagged_cs) + remainingCs <- if (totalCs > 0) totalCs - 1 - taggedCsCount else 0 # Determine method - df$method <- case_when( - taggedCsCount == 0 & totalCs > 1 ~ "BVSR", - (remainingCs == 0 & totalCs > 1) | (totalCs == 1) ~ "SER", - remainingCs > 0 ~ "BCR", - TRUE ~ NA_character_ + mutate( + flagged, + method = case_when( + taggedCsCount == 0 & totalCs > 1 ~ "BVSR", + (remainingCs == 0 & totalCs > 1) | (totalCs == 1) ~ "SER", + remainingCs > 0 ~ "BCR", + TRUE ~ NA_character_ + ) ) - - return(df) } @@ -1553,6 +1669,20 @@ autoDecision <- function(df, highCorrCols) { !is_in(seq_len(n), m$idxA) } +# The retained-component mask, truncated to at most `maxRank` components. +# @noRd +.svdCapRank <- function(keep, maxRank) { + if (is.null(maxRank) || maxRank <= 0) { + return(keep) + } + keepIdx <- which(keep) + nKeep <- min(length(keepIdx), maxRank) + if (length(keepIdx) <= nKeep) { + return(keep) + } + replace(keep, keepIdx[(nKeep + 1):length(keepIdx)], FALSE) +} + # Rows that match a known sumstats variant in the opposite orientation. # @noRd .raissFlipOfKnownMask <- function(refPanelIds, knownIds) { @@ -1561,8 +1691,7 @@ autoDecision <- function(df, highCorrCols) { return(mask) } m <- matchVariants(refPanelIds, knownIds, removeStrandAmbiguous = FALSE) - mask[m$idxA[m$sign < 0]] <- TRUE - mask + replace(mask, m$idxA[m$sign < 0], TRUE) } # Positions the GWAS already typed. @@ -1638,9 +1767,9 @@ raissSingleMatrix <- function( zt <- knownZscores$z sigT <- ldMatrix[knowns, knowns, drop = FALSE] sigIT <- ldMatrix[unknowns, knowns, drop = FALSE] - results <- raissModel(zt, sigT, sigIT, lamb, rcond) - results <- formatRaissDf(results, refPanel, unknowns) - results <- filterRaissOutput(results, r2Threshold, minimumLd, verbose) + results <- raissModel(zt, sigT, sigIT, lamb, rcond) |> + formatRaissDf(refPanel, unknowns) |> + filterRaissOutput(r2Threshold, minimumLd, verbose) resultNofilter <- mergeRaissDf(results$zscoresNofilter, knownZscores) |> arrange(.data$pos) resultFilter <- mergeRaissDf(results$zscores, knownZscores) |> @@ -1729,7 +1858,7 @@ raissSingleMatrix <- function( w <- U %*% (d / d2PlusC * VtZt) # Single dgemm X' %*% [w | U]: col 1 (rows unknowns) -> mu; rest -> A. XtWU <- crossprod(X, cbind(w, U)) - mu <- as.numeric(XtWU[unknowns, 1]) + muRaw <- as.numeric(XtWU[unknowns, 1]) A <- XtWU[unknowns, -1, drop = FALSE] rm(XtWU) # Variance and LD score in one pass over A^2. @@ -1747,7 +1876,7 @@ raissSingleMatrix <- function( # R2 correction (same as raissModel). varNorm <- varInBoundaries(varRaw, lamb) R2 <- (1 + lamb) - varNorm - mu <- mu / sqrt(R2) + mu <- muRaw / sqrt(R2) list( var = varNorm, mu = mu, @@ -1786,8 +1915,8 @@ raissSingleMatrixFromX <- function( svdTol, nrow(X) ) - results <- formatRaissDf(imp, refPanel, unknowns) - results <- filterRaissOutput(results, r2Threshold, minimumLd, verbose) + results <- formatRaissDf(imp, refPanel, unknowns) |> + filterRaissOutput(r2Threshold, minimumLd, verbose) resultNofilter <- mergeRaissDf(results$zscoresNofilter, knownZscores) |> arrange(.data$pos) resultFilter <- mergeRaissDf(results$zscores, knownZscores) |> @@ -1815,36 +1944,53 @@ raissSingleMatrixFromX <- function( lastVar <- combinedResult$variant_id[nrow(combinedResult)] firstVar <- newResult$variant_id[1] - if (lastVar == firstVar) { - newR2 <- newResult$raissR2[1] - oldR2 <- combinedResult$raissR2[nrow(combinedResult)] - if (is.na(newR2) && is.na(oldR2)) { - # Both are NA - keep the existing one - } else if (is.na(oldR2)) { - # Old is NA but new is not - use new - combinedResult[nrow(combinedResult), ] <- newResult[1, ] - } else if (is.na(newR2)) { - # New is NA but old is not - keep old - } else if (newR2 > oldR2) { - # Both are non-NA and new is better - use new - combinedResult[nrow(combinedResult), ] <- newResult[1, ] - } - - # Add remaining rows from new (excluding first) - if (nrow(newResult) > 1) { - combinedResult <- bind_rows(combinedResult, newResult[-1, ]) - } - } else { + if (lastVar != firstVar) { # No overlap - combine all rows - combinedResult <- bind_rows(combinedResult, newResult) + return(bind_rows(combinedResult, newResult)) + } + # The shared boundary variant is kept from whichever side imputed it + # better; two NAs, a tie, or an NA on the new side keep the existing row. + newR2 <- newResult$raissR2[1] + oldR2 <- combinedResult$raissR2[nrow(combinedResult)] + preferNew <- !is.na(newR2) && (is.na(oldR2) || newR2 > oldR2) + resolved <- if (preferNew) { + bind_rows(combinedResult[-nrow(combinedResult), ], newResult[1, ]) + } else { + combinedResult } - - return(combinedResult) + # Every row of `newResult` past the boundary variant is new. + bind_rows(resolved, newResult[-1, ]) } # --- raiss: genotype-matrix and LD-matrix path helpers --------------------- # List of genotype-matrix blocks: impute each via SVD, then row-bind. +# One genotype block's imputation, or NULL when the block yields nothing. +# @noRd +.raissGenotypeBlockAt <- function( + i, + refPanel, + knownZscores, + genotypeMatrix, + p +) { + if (p$verbose) { + nBlocks <- length(genotypeMatrix) + msg <- glue("Processing block {i} of {nBlocks}") + inform(msg) + } + raissSingleMatrixFromX( + refPanel, + knownZscores, + genotypeMatrix[[i]], + p$lamb, + p$svdTol, + p$r2Threshold, + p$minimumLd, + verbose = FALSE + ) +} + .raissGenotypeBlocks <- function(refPanel, knownZscores, genotypeMatrix, p) { if (p$verbose) { msg <- glue( @@ -1853,27 +1999,14 @@ raissSingleMatrixFromX <- function( ) inform(msg) } - resultsList <- list() - for (i in seq_along(genotypeMatrix)) { - if (p$verbose) { - nBlocks <- length(genotypeMatrix) - msg <- glue("Processing block {i} of {nBlocks}") - inform(msg) - } - blockResult <- raissSingleMatrixFromX( - refPanel, - knownZscores, - genotypeMatrix[[i]], - p$lamb, - p$svdTol, - p$r2Threshold, - p$minimumLd, - verbose = FALSE - ) - if (!is.null(blockResult)) { - resultsList[[length(resultsList) + 1]] <- blockResult - } - } + resultsList <- compact(map( + seq_along(genotypeMatrix), + .raissGenotypeBlockAt, + refPanel = refPanel, + knownZscores = knownZscores, + genotypeMatrix = genotypeMatrix, + p = p + )) if (length(resultsList) == 0) { if (p$verbose) { inform("No blocks could be processed.") @@ -1950,20 +2083,14 @@ raissSingleMatrixFromX <- function( # Combine per-block imputation results (boundary-dedup) + rebuild LD matrix. .raissLdBlocksCombine <- function(resultsList) { - combinedNofilter <- resultsList[[1]]$resultNofilter - combinedFilter <- resultsList[[1]]$resultFilter - if (length(resultsList) > 1) { - for (i in 2:length(resultsList)) { - combinedNofilter <- .combineWithBoundaryCheck( - combinedNofilter, - resultsList[[i]]$resultNofilter - ) - combinedFilter <- .combineWithBoundaryCheck( - combinedFilter, - resultsList[[i]]$resultFilter - ) - } - } + combinedNofilter <- reduce( + map(resultsList, "resultNofilter"), + .combineWithBoundaryCheck + ) + combinedFilter <- reduce( + map(resultsList, "resultFilter"), + .combineWithBoundaryCheck + ) ldFilteredList <- map(resultsList, "ldMat") variantList <- map(ldFilteredList, .ldVariantsDf) ldMatrix <- createLdMatrix( @@ -1978,29 +2105,56 @@ raissSingleMatrixFromX <- function( } # LD-block imputation path: impute each block then combine. +# One LD block's imputation, or NULL when the block yields nothing. +# @noRd +.raissLdBlockAt <- function( + blockId, + refPanel, + knownZscores, + ldMatrix, + variantIndices, + blockIds, + p +) { + if (p$verbose) { + nBlocks <- length(blockIds) + msg <- glue("Processing block {blockId} of {nBlocks}") + inform(msg) + } + .raissLdBlockOne( + refPanel, + knownZscores, + ldMatrix, + variantIndices, + blockId, + p + ) +} + .raissLdBlocksPath <- function(refPanel, knownZscores, ldMatrix, p) { if (p$verbose) { inform("Processing multiple LD blocks...") } variantIndices <- ldMatrix$variantIndices blockIds <- unique(variantIndices$blockId) - resultsList <- list() - for (blockId in blockIds) { - if (p$verbose) { - nBlocks <- length(blockIds) - msg <- glue("Processing block {blockId} of {nBlocks}") - inform(msg) - } - blockResult <- .raissLdBlockOne( - refPanel, - knownZscores, - ldMatrix, - variantIndices, - blockId, - p - ) - if (!is.null(blockResult)) resultsList[[blockId]] <- blockResult + perBlock <- map( + blockIds, + .raissLdBlockAt, + refPanel = refPanel, + knownZscores = knownZscores, + ldMatrix = ldMatrix, + variantIndices = variantIndices, + blockIds = blockIds, + p = p + ) + # `resultsList[[blockId]] <- ...` named the entries only when blockIds are + # character, so keep that distinction rather than inventing names. + blockResults <- if (is.character(blockIds)) { + set_names(perBlock, blockIds) + } else { + perBlock } + resultsList <- compact(blockResults) if (length(resultsList) == 0) { if (p$verbose) { msg <- glue( @@ -2127,6 +2281,7 @@ raiss <- function( .raissLdBlocksPath(refPanel, knownZscores, ldMatrix, p) } +#' @importFrom checkmate assertNumeric #' @param zt Vector of known z scores. #' @param sigT Matrix of known linkage disequilibrium (LD) correlation. #' @param sigIT Correlation matrix with rows corresponding to unknown SNPs (to @@ -2150,9 +2305,9 @@ raissModel <- function( reportConditionNumber = FALSE ) { sigTInv <- invertMatRecursive(sigT, lamb, rcond) - if (!is.numeric(zt) || !is.numeric(sigT) || !is.numeric(sigIT)) { - abort("zt, sigT, and sigIT must be numeric.") - } + assertNumeric(zt) + assertNumeric(sigT) + assertNumeric(sigIT) if (batch) { conditionNumber <- if (reportConditionNumber) { rep(kappa(sigT, exact = TRUE, norm = "2"), nrow(sigIT)) @@ -2245,29 +2400,35 @@ mergeRaissDf <- function(raissDf, knownZscores) { # Identify rows that came from knownZscores fromKnown <- !is.na(mergedDf$z.y) & is.na(mergedDf$z.x) - # Set Var to -1 and raissLdScore to Inf for these rows - mergedDf$Var[fromKnown] <- -1 - mergedDf$raissLdScore[fromKnown] <- Inf - - # If there are overlapping columns (e.g., z.x and z.y), resolve them For - # example, use z from knownZscores where available, otherwise use z from - # raissDf - mergedDf$z <- if_else(fromKnown, mergedDf$z.y, mergedDf$z.x) - - # Remove the extra columns produced by the join (z.x, z.y). - mergedDf <- select(mergedDf, -all_of(c("z.x", "z.y"))) - mergedDf <- arrange(mergedDf, .data$pos) - # assign imputed variants beta, se as NA to avoid confusion, since they are - # not imputed. beta/se are optional (knownZscores may omit them), so guard - # on column presence explicitly rather than relying on a data.frame - # silently creating an all-NA column on `$col[mask] <- NA`. - if (is_in("beta", colnames(mergedDf))) { - mergedDf$beta[mergedDf$Var == -1] <- NA - } - if (is_in("se", colnames(mergedDf))) { - mergedDf$se[mergedDf$Var == -1] <- NA - } - return(mergedDf) + resolved <- mutate( + mergedDf, + # A known variant was not imputed, so it carries no imputation + # quality: Var = -1 and an infinite LD score mark it as observed. + Var = replace(.data$Var, fromKnown, -1), + raissLdScore = replace(.data$raissLdScore, fromKnown, Inf), + # Overlapping z columns resolved: z from knownZscores where available, + # otherwise z from raissDf. + z = if_else(fromKnown, .data$z.y, .data$z.x) + ) |> + # Remove the extra columns produced by the join (z.x, z.y). + select(-all_of(c("z.x", "z.y"))) |> + arrange(.data$pos) + # Imputed variants' beta / se are NA to avoid confusion, since they are not + # imputed. Both are optional (knownZscores may omit them), so guard on + # column presence explicitly rather than relying on a data.frame silently + # creating an all-NA column on `$col[mask] <- NA`. + observed <- resolved$Var == -1 + mutate( + resolved, + !!!compact(list( + beta = if (is_in("beta", colnames(resolved))) { + replace(resolved$beta, observed, NA) + }, + se = if (is_in("se", colnames(resolved))) { + replace(resolved$se, observed, NA) + } + )) + ) } # Format one aligned "label: value" report line (label left-padded to @@ -2314,7 +2475,7 @@ filterRaissOutput <- function( minimumLd = 5, verbose = TRUE ) { - zscores <- select( + selected <- select( zscores, all_of(c( "chrom", @@ -2327,16 +2488,15 @@ filterRaissOutput <- function( "raissLdScore" )) ) - zscores$raissR2 <- 1 - zscores$Var - zscoresNofilter <- zscores - zscores <- filter( - zscores, + zscoresNofilter <- mutate(selected, raissR2 = 1 - .data$Var) + kept <- filter( + zscoresNofilter, .data$raissR2 > r2Threshold & .data$raissLdScore >= minimumLd ) if (verbose) { - .filterRaissReport(zscoresNofilter, zscores, r2Threshold, minimumLd) + .filterRaissReport(zscoresNofilter, kept, r2Threshold, minimumLd) } - list(zscoresNofilter = zscoresNofilter, zscores = zscores) + list(zscoresNofilter = zscoresNofilter, zscores = kept) } computeMu <- function(sigIT, sigTInv, zt) { @@ -2359,13 +2519,13 @@ checkInversion <- function(sigT, sigTInv) { } varInBoundaries <- function(var, lamb) { - var[var < 0] <- 0 - var[var > (0.99999 + lamb)] <- 1 - return(var) + floored <- replace(var, var < 0, 0) + replace(floored, floored > (0.99999 + lamb), 1) } +#' @importFrom rlang try_fetch invertMat <- function(mat, lamb, rcond) { - tryCatch( + try_fetch( { # Modify the diagonal elements of mat diag(mat) <- 1 + lamb @@ -2373,7 +2533,7 @@ invertMat <- function(mat, lamb, rcond) { matInv <- ginv(mat, tol = rcond) return(matInv) }, - error = function(e) { + error = function(cnd) { # Second attempt with updated lamb and rcond in case of an error diag(mat) <- 1 + lamb * 1.1 matInv <- ginv(mat, tol = rcond * 1.1) @@ -2383,7 +2543,7 @@ invertMat <- function(mat, lamb, rcond) { } invertMatRecursive <- function(mat, lamb, rcond) { - tryCatch( + try_fetch( { # Modify the diagonal elements of mat diag(mat) <- 1 + lamb @@ -2391,7 +2551,7 @@ invertMatRecursive <- function(mat, lamb, rcond) { matInv <- ginv(mat, tol = rcond) return(matInv) }, - error = function(e) { + error = function(cnd) { # Recursive call with updated lamb and rcond in case of an error invertMat(mat, lamb * 1.1, rcond * 1.1) } @@ -2440,9 +2600,8 @@ invertMatEigen <- function(mat, tol = 1e-3) { #' \code{X} is provided. One of \code{"sample"} (default), #' \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is provided #' directly. -#' @param ... Additional arguments passed to the underlying QC method -#' (\code{\link{dentistSingleWindow}} or \code{\link{slalom}}). -#' +#' @param methodArgs Optional named list of options passed to the +#' underlying QC method (\code{slalom} or \code{dentistSingleWindow}). #' @return A data frame with at least a logical \code{outlier} column indicating #' which variants are identified as outliers. The remaining columns depend on #' the method used. @@ -2462,29 +2621,36 @@ ldMismatchQc <- function( nSample = NULL, method = c("slalom", "dentist"), ldMethod = "sample", - ... + methodArgs = list() ) { method <- arg_match(method) if (method == "dentist") { - qcResults <- dentistSingleWindow( - zScore, - R = R, - X = X, - nSample = nSample, - ldMethod = ldMethod, - ... + callArgs <- list_modify( + list( + zScore, + R = R, + X = X, + nSample = nSample, + ldMethod = ldMethod + ), + !!!methodArgs ) - return(qcResults) + return(exec(dentistSingleWindow, !!!callArgs)) } else { - qcResults <- slalom(zScore, R = R, X = X, ldMethod = ldMethod, ...) + callArgs <- list_modify( + list(zScore, R = R, X = X, ldMethod = ldMethod), + !!!methodArgs + ) + qcResults <- exec(slalom, !!!callArgs) # Standardize output: slalom uses "outliers", rename to "outlier" for # consistency - result <- qcResults$data - if ( - is_in("outliers", colnames(result)) && - !is_in("outlier", colnames(result)) - ) { - result <- rename(result, outlier = "outliers") + raw <- qcResults$data + renameOutliers <- is_in("outliers", colnames(raw)) && + !is_in("outlier", colnames(raw)) + result <- if (renameOutliers) { + rename(raw, outlier = "outliers") + } else { + raw } return(result) } @@ -2515,9 +2681,11 @@ ldMismatchQc <- function( effectiveN <- function(nCase, nControl) { nCase <- as.numeric(nCase) nControl <- as.numeric(nControl) - out <- 4 / (1 / nCase + 1 / nControl) - out[is.na(nCase) | is.na(nControl) | nCase <= 0 | nControl <= 0] <- NA_real_ - out + replace( + 4 / (1 / nCase + 1 / nControl), + is.na(nCase) | is.na(nControl) | nCase <= 0 | nControl <= 0, + NA_real_ + ) } # Require a susieR that provides the kriging RSS diagnostic. @@ -2577,6 +2745,7 @@ effectiveN <- function(nCase, nControl) { #' krigingOutlierQc( #' zScore = rnorm(20), R = R, n = 415, variantIds = colnames(X)) #' @export +#' @importFrom checkmate assertMatrix krigingOutlierQc <- function( zScore, R, @@ -2587,9 +2756,7 @@ krigingOutlierQc <- function( ) { zScore <- as.numeric(zScore) m <- length(zScore) - if (is.null(R) || !is.matrix(R) || nrow(R) != m || ncol(R) != m) { - abort("krigingOutlierQc requires a square LD matrix aligned to zScore.") - } + assertMatrix(R, nrows = m, ncols = m, .var.name = "R (LD matrix)") if (missing(n) || length(n) != 1L || is.na(n) || !is.finite(n) || n <= 0) { abort("krigingOutlierQc requires a single positive sample size 'n'.") } @@ -2674,9 +2841,17 @@ krigingOutlierQc <- function( seqnames = chr, ranges = IRanges::IRanges(start = as.integer(df$pos), width = 1L) ) - if (is_in("variant_id", colnames(df)) && !is_in("SNP", colnames(df))) { - df$SNP <- df$variant_id - } + df <- mutate( + df, + !!!compact(list( + SNP = if ( + is_in("variant_id", colnames(df)) && + !is_in("SNP", colnames(df)) + ) { + df$variant_id + } + )) + ) baseCols <- c("SNP", "A1", "A2", "Z", "N") # AF = directional effect-allele frequency (exported as af); MAF = # directionless QC frequency. Both carried when the loader resolved them. @@ -2691,8 +2866,10 @@ krigingOutlierQc <- function( "N_CONTROL" ) use <- intersect(c(baseCols, optCols), colnames(df)) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(select(df, all_of(use))) - gr + S4Vectors::`mcols<-`( + gr, + value = S4Vectors::DataFrame(select(df, all_of(use))) + ) } # ----------------------------------------------------------------------------- @@ -2733,15 +2910,24 @@ krigingOutlierQc <- function( } # Append the optional numeric stat columns present on the entry's mcols. +# One mcols column as numeric. +# @noRd +.entryStatColumn <- function(src, mc) { + as.numeric(mc[[src]]) +} + .entryDfAddStats <- function(df, mc) { statMap <- c(z = "Z", beta = "BETA", se = "SE", N = "N", maf = "MAF") - for (out in names(statMap)) { - src <- statMap[[out]] - if (is_in(src, colnames(mc))) { - df[[out]] <- as.numeric(mc[[src]]) - } - } - df + present <- statMap[is_in(statMap, colnames(mc))] + # mutate() overwrites an existing column in place and appends a new one, + # which is what the `df[[out]] <-` loop did. + mutate( + df, + !!!set_names( + map(unname(present), .entryStatColumn, mc = mc), + names(present) + ) + ) } .entryToSumstatDf <- function( @@ -2759,21 +2945,21 @@ krigingOutlierQc <- function( abort(msg) } } - chr <- as.character(GenomicRanges::seqnames(gr)) - if (!keepChrPrefix) { - chr <- str_remove(chr, regex("^chr", ignore_case = TRUE)) - } - df <- .entryDfBase(gr, mc, chr) - df <- .entryDfAddStats(df, mc) - if ( - derive == "zFromBetaSe" && - is.null(df[["z"]]) && - !is.null(df[["beta"]]) && - !is.null(df[["se"]]) - ) { - df[["z"]] <- df[["beta"]] / df[["se"]] + seqChr <- as.character(GenomicRanges::seqnames(gr)) + chr <- if (keepChrPrefix) { + seqChr + } else { + str_remove(seqChr, regex("^chr", ignore_case = TRUE)) + } + df <- .entryDfBase(gr, mc, chr) |> .entryDfAddStats(mc) + deriveZ <- derive == "zFromBetaSe" && + is.null(df[["z"]]) && + !is.null(df[["beta"]]) && + !is.null(df[["se"]]) + if (!deriveZ) { + return(df) } - df + mutate(df, z = .data$beta / .data$se) } # Derive BETA and SE columns from signed Z when the entry has only Z. @@ -2796,7 +2982,7 @@ krigingOutlierQc <- function( } s <- svd(mat) d <- s$d - keep <- if (tol > 0 && length(d) > 0) { + aboveTol <- if (tol > 0 && length(d) > 0) { out <- d / d[1] > tol if (!any(out)) { abort("All singular values are below the tolerance threshold.") @@ -2805,13 +2991,7 @@ krigingOutlierQc <- function( } else { rep(TRUE, length(d)) } - if (!is.null(maxRank) && maxRank > 0) { - nKeep <- min(sum(keep), maxRank) - keepIdx <- which(keep) - if (length(keepIdx) > nKeep) { - keep[keepIdx[(nKeep + 1):length(keepIdx)]] <- FALSE - } - } + keep <- .svdCapRank(aboveTol, maxRank) list( u = s$u[, keep, drop = FALSE], d = d[keep], @@ -2878,13 +3058,14 @@ krigingOutlierQc <- function( 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)))) + derived <- mutate( + df, + !!!compact(list( + BETA = if (!hasBeta) beta, + SE = if (!hasSe) se + )) + ) + list(df = derived, audit = list(nDerived = sum(!is.na(se)))) } # Drop variants whose (chrom, pos) overlaps any user-supplied skipRegion. @@ -2925,22 +3106,32 @@ krigingOutlierQc <- function( abort(msg) } +# Rows falling inside skip region `i`. +# @noRd +.skipRegionMask <- function(i, parsed, dfChr, pos) { + dfChr == parsed$chrom[i] & pos >= parsed$start[i] & pos <= parsed$end[i] +} + .applySkipRegion <- function(df, skipRegion) { if (is.null(skipRegion) || length(skipRegion) == 0L) { return(df) } parsed <- .parseSkipRegion(skipRegion) - dropMask <- rep(FALSE, nrow(df)) dfChr <- str_remove( as.character(df$chrom), regex("^chr", ignore_case = TRUE) ) - for (i in seq_len(nrow(parsed))) { - dropMask <- dropMask | - (dfChr == parsed$chrom[i] & - df$pos >= parsed$start[i] & - df$pos <= parsed$end[i]) - } + dropMask <- reduce( + map( + seq_len(nrow(parsed)), + .skipRegionMask, + parsed = parsed, + dfChr = dfChr, + pos = df$pos + ), + `|`, + .init = rep(FALSE, nrow(df)) + ) filter(df, !dropMask) } @@ -2984,12 +3175,16 @@ krigingOutlierQc <- function( removeStrandAmbiguous = removeStrandAmbiguous, removeDups = removeDups ) - out <- res$harmonizedData - if (!is_in("chrom", colnames(out)) && is_in("chr", colnames(out))) { - colnames(out)[colnames(out) == "chr"] <- "chrom" + raw <- res$harmonizedData + out <- if (!is_in("chrom", colnames(raw)) && is_in("chr", colnames(raw))) { + `colnames<-`( + raw, + replace(colnames(raw), colnames(raw) == "chr", "chrom") + ) + } else { + raw } - attr(out, "qcCounts") <- attr(res, "qcCounts") - out + `attr<-`(out, "qcCounts", attr(res, "qcCounts")) } # Variant-content filters (MAF / INFO / N). Pure data-frame column @@ -3050,46 +3245,60 @@ krigingOutlierQc <- function( if (!(nCutoff > 0 && is_in("N", colnames(df)) && nrow(df) > 0L)) { return(list(df = df, dropped = NULL)) } - nVals <- as.numeric(df$N) + allN <- as.numeric(df$N) before <- nrow(df) - if (any(is.na(nVals))) { - df <- filter(df, !is.na(nVals)) - nVals <- nVals[!is.na(nVals)] - } - if (length(nVals) > 0L) { - medN <- stats::median(nVals) - madN <- stats::mad(nVals, constant = 1) - if (madN > 0) { - zN <- abs(nVals - medN) / madN - df <- filter(df, zN <= nCutoff) - } + # A variant with no N cannot be scored against the cohort median. + hasN <- !is.na(allN) + nVals <- allN[hasN] + withN <- if (all(hasN)) df else filter(df, hasN) + madN <- if (length(nVals) > 0L) stats::mad(nVals, constant = 1) else 0 + # A zero MAD means every retained N is identical, so no variant is an + # outlier and the z-score would divide by zero. + kept <- if (madN > 0) { + filter(withN, abs(nVals - stats::median(nVals)) / madN <= nCutoff) + } else { + withN } - list(df = df, dropped = before - nrow(df)) + list(df = kept, dropped = before - nrow(kept)) } +# An audit record with the unset entries omitted. An all-unset record is the +# empty list, not a zero-length named one, so callers can compare it directly. +# @noRd +.qcAudit <- function(...) { + entries <- compact(list(...)) + if (length(entries) == 0L) { + return(list()) + } + entries +} + +# The same, for counters that are reported only when something happened. +# @noRd +.qcAuditPositive <- function(...) { + exec(.qcAudit, !!!discard(list(...), .qcCountIsZero)) +} + +# @noRd +.qcCountIsZero <- function(n) is.null(n) || n <= 0L + .applyContentFilters <- function( df, mafCutoff = 0, infoCutoff = 0, nCutoff = 5 ) { - audit <- list() - r <- .cfMaf(df, mafCutoff) - df <- r$df - if (!is.null(r$dropped)) { - audit$mafDropped <- r$dropped - } - r <- .cfInfo(df, infoCutoff) - df <- r$df - if (!is.null(r$dropped)) { - audit$infoDropped <- r$dropped - } - r <- .cfN(df, nCutoff) - df <- r$df - if (!is.null(r$dropped)) { - audit$nDropped <- r$dropped - } - list(df = df, audit = audit) + maf <- .cfMaf(df, mafCutoff) + info <- .cfInfo(maf$df, infoCutoff) + n <- .cfN(info$df, nCutoff) + list( + df = n$df, + audit = .qcAudit( + mafDropped = maf$dropped, + infoDropped = info$dropped, + nDropped = n$dropped + ) + ) } # Per-row variant sanity / hygiene checks ported from MungeSumstats's @@ -3116,6 +3325,20 @@ krigingOutlierQc <- function( # --- .applySanityChecks per-check helpers (each guards its own flag) -------- # Coerce known numeric columns; count NAs newly introduced by coercion. +# @noRd +.scColumnIsNumeric <- function(col, df) { + is.numeric(df[[col]]) +} + +# One column coerced to numeric, with the count of NAs that coercion +# introduced (values that were present but unparseable). +# @noRd +.scCoerceColumn <- function(col, df) { + orig <- df[[col]] + coerced <- suppressWarnings(as.numeric(orig)) + list(values = coerced, na = sum(is.na(coerced) & !is.na(orig))) +} + .scCoerceNumeric <- function(df, coerceNumeric) { if (!coerceNumeric) { return(list(df = df, audit = list())) @@ -3136,21 +3359,15 @@ krigingOutlierQc <- function( ), colnames(df) ) - naIntroduced <- 0L - for (col in numericCols) { - orig <- df[[col]] - if (is.numeric(orig)) { - next - } - coerced <- suppressWarnings(as.numeric(orig)) - naIntroduced <- naIntroduced + sum(is.na(coerced) & !is.na(orig)) - df[[col]] <- coerced - } - audit <- list() - if (naIntroduced > 0L) { - audit$nonNumericCoerced <- naIntroduced - } - list(df = df, audit = audit) + toCoerce <- numericCols[ + !map_lgl(numericCols, .scColumnIsNumeric, df = df) + ] + coercions <- map(toCoerce, .scCoerceColumn, df = df) + naIntroduced <- sum(map_int(coercions, "na")) + list( + df = mutate(df, !!!set_names(map(coercions, "values"), toCoerce)), + audit = .qcAuditPositive(nonNumericCoerced = naIntroduced) + ) } # Normalize chromosome labels; optionally drop non-standard chromosomes. @@ -3158,23 +3375,23 @@ krigingOutlierQc <- function( if (!normalizeChr || !is_in("chrom", colnames(df))) { return(list(df = df, audit = list())) } - chr <- as.character(df$chrom) - chr <- str_remove(chr, regex("^chr", ignore_case = TRUE)) - chr <- str_remove(chr, regex("^ch", ignore_case = TRUE)) - chr <- str_to_upper(chr) - chr[chr == "23"] <- "X" - chr[chr == "24"] <- "Y" - chr[chr == "M"] <- "MT" - df$chrom <- chr - audit <- list() - if (dropNonstandardChr) { - before <- nrow(df) - standardChrs <- c(as.character(seq_len(22)), "X", "Y", "MT") - df <- filter(df, is_in(chr, standardChrs)) - dropped <- before - nrow(df) - if (dropped > 0L) audit$nonstandardChrDropped <- dropped - } - list(df = df, audit = audit) + chr <- as.character(df$chrom) |> + str_remove(regex("^chr", ignore_case = TRUE)) |> + str_remove(regex("^ch", ignore_case = TRUE)) |> + str_to_upper() |> + canonChromLabel() + normalized <- mutate(df, chrom = chr) + if (!dropNonstandardChr) { + return(list(df = normalized, audit = list())) + } + standardChrs <- c(as.character(seq_len(22)), "X", "Y", "MT") + kept <- filter(normalized, is_in(chr, standardChrs)) + list( + df = kept, + audit = .qcAuditPositive( + nonstandardChrDropped = nrow(normalized) - nrow(kept) + ) + ) } # Drop rows missing any vital column (chrom/pos/A1/A2 + first signed stat). @@ -3182,22 +3399,20 @@ krigingOutlierQc <- function( if (!dropMissData || nrow(df) == 0L) { return(list(df = df, audit = list())) } - vital <- intersect(c("chrom", "pos", "A1", "A2"), colnames(df)) signedCol <- intersect(c("Z", "BETA"), colnames(df))[1L] - if (!is.na(signedCol)) { - vital <- c(vital, signedCol) - } - audit <- list() - if (length(vital) > 0L) { - before <- nrow(df) - bad <- reduce(map(vital, .scColIsNa, df = df), `|`) - if (any(bad)) { - df <- filter(df, !bad) - } - dropped <- before - nrow(df) - if (dropped > 0L) audit$missDataDropped <- dropped + vital <- c( + intersect(c("chrom", "pos", "A1", "A2"), colnames(df)), + if (!is.na(signedCol)) signedCol + ) + if (length(vital) == 0L) { + return(list(df = df, audit = list())) } - list(df = df, audit = audit) + bad <- reduce(map(vital, .scColIsNa, df = df), `|`) + kept <- filter(df, !bad) + list( + df = kept, + audit = .qcAuditPositive(missDataDropped = nrow(df) - nrow(kept)) + ) } # Drop rows whose P is outside [0, 1]. @@ -3211,12 +3426,10 @@ krigingOutlierQc <- function( if (any(bad)) { df <- filter(df, !bad) } - dropped <- before - nrow(df) - audit <- list() - if (dropped > 0L) { - audit$pOutOfRangeDropped <- dropped - } - list(df = df, audit = audit) + list( + df = df, + audit = .qcAuditPositive(pOutOfRangeDropped = before - nrow(df)) + ) } # Clamp tiny P-values up to the floor. @@ -3227,15 +3440,22 @@ krigingOutlierQc <- function( p <- as.numeric(df$P) smallMask <- !is.na(p) & p >= 0 & p < smallPFloor nClamped <- sum(smallMask) - audit <- list() - if (nClamped > 0L) { - df$P[smallMask] <- smallPFloor - audit$smallPClamped <- nClamped + if (nClamped == 0L) { + return(list(df = df, audit = list())) } - list(df = df, audit = audit) + clamped <- mutate(df, P = replace(.data$P, smallMask, smallPFloor)) + list(df = clamped, audit = list(smallPClamped = nClamped)) } # Drop rows whose effect equals the null sentinel (0, or 1 for OR). +# Rows whose effect column holds the no-effect sentinel (1 for OR, else 0). +# @noRd +.scZeroEffectMask <- function(col, df) { + vals <- as.numeric(df[[col]]) + sentinel <- if (col == "OR") 1 else 0 + !is.na(vals) & vals == sentinel +} + .scDropZeroEffect <- function(df, dropZeroEffect) { if (!dropZeroEffect || nrow(df) == 0L) { return(list(df = df, audit = list())) @@ -3244,22 +3464,19 @@ krigingOutlierQc <- function( c("BETA", "LOG_ODDS", "SIGNED_SUMSTAT", "OR"), colnames(df) ) - audit <- list() - if (length(effectCols) > 0L) { - before <- nrow(df) - badMask <- rep(FALSE, nrow(df)) - for (col in effectCols) { - vals <- as.numeric(df[[col]]) - sentinel <- if (col == "OR") 1 else 0 - badMask <- badMask | (!is.na(vals) & vals == sentinel) - } - if (any(badMask)) { - df <- filter(df, !badMask) - } - dropped <- before - nrow(df) - if (dropped > 0L) audit$zeroEffectDropped <- dropped + if (length(effectCols) == 0L) { + return(list(df = df, audit = list())) } - list(df = df, audit = audit) + badMask <- reduce( + map(effectCols, .scZeroEffectMask, df = df), + `|`, + .init = rep(FALSE, nrow(df)) + ) + kept <- filter(df, !badMask) + list( + df = kept, + audit = .qcAuditPositive(zeroEffectDropped = nrow(df) - nrow(kept)) + ) } # Drop rows with non-positive standard error. @@ -3273,15 +3490,14 @@ krigingOutlierQc <- function( if (any(bad)) { df <- filter(df, !bad) } - dropped <- before - nrow(df) - audit <- list() - if (dropped > 0L) { - audit$nonpositiveSeDropped <- dropped - } - list(df = df, audit = audit) + list( + df = df, + audit = .qcAuditPositive(nonpositiveSeDropped = before - nrow(df)) + ) } # Per-row sanity checks: sequence the guarded checks, accumulating the audit. +#' @importFrom purrr list_modify .applySanityChecks <- function( df, coerceNumeric = TRUE, @@ -3294,32 +3510,33 @@ krigingOutlierQc <- function( dropZeroEffect = TRUE, dropNonpositiveSe = TRUE ) { - audit <- list() if (nrow(df) == 0L) { - return(list(df = df, audit = audit)) - } - r <- .scCoerceNumeric(df, coerceNumeric) - df <- r$df - audit <- modifyList(audit, r$audit) - r <- .scNormalizeChr(df, normalizeChr, dropNonstandardChr) - df <- r$df - audit <- modifyList(audit, r$audit) - r <- .scDropMissData(df, dropMissData) - df <- r$df - audit <- modifyList(audit, r$audit) - r <- .scDropPOutOfRange(df, dropPOutOfRange) - df <- r$df - audit <- modifyList(audit, r$audit) - r <- .scClampSmallP(df, clampSmallP, smallPFloor) - df <- r$df - audit <- modifyList(audit, r$audit) - r <- .scDropZeroEffect(df, dropZeroEffect) - df <- r$df - audit <- modifyList(audit, r$audit) - r <- .scDropNonpositiveSe(df, dropNonpositiveSe) - df <- r$df - audit <- modifyList(audit, r$audit) - list(df = df, audit = audit) + return(list(df = df, audit = list())) + } + # Order matters: numeric coercion first (later checks compare numbers), + # then the label fixes, then the row drops, then the small-P clamp. + steps <- list( + list(fn = .scCoerceNumeric, args = list(coerceNumeric)), + list( + fn = .scNormalizeChr, + args = list(normalizeChr, dropNonstandardChr) + ), + list(fn = .scDropMissData, args = list(dropMissData)), + list(fn = .scDropPOutOfRange, args = list(dropPOutOfRange)), + list(fn = .scClampSmallP, args = list(clampSmallP, smallPFloor)), + list(fn = .scDropZeroEffect, args = list(dropZeroEffect)), + list(fn = .scDropNonpositiveSe, args = list(dropNonpositiveSe)) + ) + reduce(steps, .scApplyStep, .init = list(df = df, audit = list())) +} + +# Run one sanity-check step against the accumulated (df, audit) state. Every +# step takes the frame first and returns list(df, audit); a step that declines +# to run returns the frame unchanged and an empty audit. +# @noRd +.scApplyStep <- function(state, step) { + r <- exec(step$fn, state$df, !!!step$args) + list(df = r$df, audit = list_modify(state$audit, !!!r$audit)) } # Apply ldMismatchQc (SLALOM/DENTIST) against the LD sketch. Returns the @@ -3343,12 +3560,12 @@ krigingOutlierQc <- function( # @noRd .qcPanelSupportedLd <- function(df, ldSketch, label) { nIn <- nrow(df) - R <- .ldFromSketch(ldSketch, df$SNP, label = label, onMissing = "drop") - if (is.null(R)) { + raw <- .ldFromSketch(ldSketch, df$SNP, label = label, onMissing = "drop") + if (is.null(raw)) { return(list(R = NULL, df = df[0L, , drop = FALSE], dropped = nIn)) } - keptIds <- attr(R, "keptVariantIds") - attr(R, "keptVariantIds") <- NULL + keptIds <- attr(raw, "keptVariantIds") + R <- `attr<-`(raw, "keptVariantIds", NULL) if (is.null(keptIds) || length(keptIds) >= nIn) { return(list(R = R, df = df, dropped = 0L)) } @@ -3387,8 +3604,7 @@ krigingOutlierQc <- function( # chisq for variants effectively orthogonal to the lead). Treat NA as # "no evidence of being an outlier" (conservative: keep the variant) # so the downstream df / sum() / IRanges construction stay finite. - outlierFlags <- qc$outlier - outlierFlags[is.na(outlierFlags)] <- FALSE + outlierFlags <- replace(qc$outlier, is.na(qc$outlier), FALSE) # Attach the variant_id column so the diagnostics data.frame stays # self-describing once it's separated from the input df. diagnostics <- if (is.data.frame(qc)) { @@ -3608,16 +3824,25 @@ krigingOutlierQc <- function( return(list(df = df, nSource = "column")) } if (f$hasCols) { - df$N <- as.numeric(df$N_CASE) + as.numeric(df$N_CONTROL) - return(list(df = df, nSource = "total")) + return(list( + df = mutate( + df, + N = as.numeric(.data$N_CASE) + as.numeric(.data$N_CONTROL) + ), + nSource = "total" + )) } if (f$hasScalar) { - df$N <- rep(opts$nCase + opts$nControl, f$nRow) - return(list(df = df, nSource = "total")) + return(list( + df = mutate(df, N = rep(opts$nCase + opts$nControl, f$nRow)), + nSource = "total" + )) } if (f$hasNSample) { - df$N <- rep(opts$nSample, f$nRow) - return(list(df = df, nSource = "study-n")) + return(list( + df = mutate(df, N = rep(opts$nSample, f$nRow)), + nSource = "study-n" + )) } list(df = df, nSource = NA_character_) } @@ -3632,8 +3857,10 @@ krigingOutlierQc <- function( "n_case/n_control." ) } - df$N <- effectiveN(df$N_CASE, df$N_CONTROL) - return(list(df = df, nSource = "effective")) + return(list( + df = mutate(df, N = effectiveN(.data$N_CASE, .data$N_CONTROL)), + nSource = "effective" + )) } if (f$hasScalar) { if (f$hasN) { @@ -3643,15 +3870,22 @@ krigingOutlierQc <- function( "nCase/nControl." ) } - df$N <- rep(effectiveN(opts$nCase, opts$nControl), f$nRow) - return(list(df = df, nSource = "effective")) + return(list( + df = mutate( + df, + N = rep(effectiveN(opts$nCase, opts$nControl), f$nRow) + ), + nSource = "effective" + )) } if (f$hasN) { return(list(df = df, nSource = "column")) } if (f$hasNSample) { - df$N <- rep(opts$nSample, f$nRow) - return(list(df = df, nSource = "study-n")) + return(list( + df = mutate(df, N = rep(opts$nSample, f$nRow)), + nSource = "study-n" + )) } list(df = df, nSource = NA_character_) } @@ -3700,6 +3934,10 @@ krigingOutlierQc <- function( # frame, plus whichever of N / BETA / SE the caller carries, sorted by position # to match the reference panel. # @noRd +.qcRaissNumericColumn <- function(nm, df) { + as.numeric(df[[nm]]) +} + .qcRaissKnownZ <- function(df) { knownVariantIds <- if (!is.null(df$SNP)) { as.character(df$SNP) @@ -3719,38 +3957,40 @@ krigingOutlierQc <- function( # merged output so the imputed rows sit in the same frame as the known # ones. optional <- c(N = "n", BETA = "beta", SE = "se") - for (nm in names(optional)) { - if (is_in(nm, colnames(df))) { - knownZ[[optional[[nm]]]] <- as.numeric(df[[nm]]) - } - } - arrange(knownZ, .data$pos) + present <- optional[is_in(names(optional), colnames(df))] + extras <- set_names( + map(names(present), .qcRaissNumericColumn, df = df), + unname(present) + ) + knownZ |> mutate(!!!extras) |> arrange(.data$pos) } .qcRaissBuildInputs <- function(df, ldSketch, windowIdx, opts) { - refPanel <- .refVariantsFromSketch(ldSketch)[windowIdx, , drop = FALSE] - refPanel$variant_id <- normalizeVariantId(refPanel$variant_id) - refPanel <- arrange(refPanel, .data$pos) + windowPanel <- .refVariantsFromSketch(ldSketch)[ + windowIdx, + , + drop = FALSE + ] |> + mutate(variant_id = normalizeVariantId(.data$variant_id)) |> + arrange(.data$pos) knownZ <- .qcRaissKnownZ(df) # meanImpute = FALSE so per-variant missingness is still visible; the # surviving columns are mean-imputed below, which is what meanImpute = # TRUE did. - dosage <- .ldSketchDosage(ldSketch, windowIdx, meanImpute = FALSE) - colnames(dosage) <- normalizeVariantId( - .ldSketchMatchIds(ldSketch)[windowIdx] - ) - dosage <- dosage[, refPanel$variant_id, drop = FALSE] - keep <- .qcRaissTargetMask(refPanel, knownZ, dosage, opts) - nDropped <- sum(!keep) - refPanel <- refPanel[keep, , drop = FALSE] - dosage <- dosage[, keep, drop = FALSE] - scaledDosage <- scale(.qtlMeanImpute(dosage)) - scaledDosage[is.na(scaledDosage)] <- 0 + windowDosage <- `colnames<-`( + .ldSketchDosage(ldSketch, windowIdx, meanImpute = FALSE), + normalizeVariantId(.ldSketchMatchIds(ldSketch)[windowIdx]) + ) + windowed <- windowDosage[, windowPanel$variant_id, drop = FALSE] + keep <- .qcRaissTargetMask(windowPanel, knownZ, windowed, opts) + refPanel <- windowPanel[keep, , drop = FALSE] + scaled <- scale(.qtlMeanImpute(windowed[, keep, drop = FALSE])) + scaledDosage <- replace(scaled, is.na(scaled), 0) list( refPanel = refPanel, knownZ = knownZ, scaledDosage = scaledDosage, - nDroppedTargets = nDropped + nDroppedTargets = sum(!keep) ) } @@ -3822,38 +4062,45 @@ krigingOutlierQc <- function( return(list(df = df, total = NA_integer_, imputed = 0L)) } impDf <- imputed$resultFilter - out <- tibble( - chrom = impDf$chrom, - pos = impDf$pos, - SNP = impDf$variant_id, - A1 = impDf$A1, - A2 = impDf$A2, - Z = impDf$z + rebuilt <- mutate( + tibble( + chrom = impDf$chrom, + pos = impDf$pos, + SNP = impDf$variant_id, + A1 = impDf$A1, + A2 = impDf$A2, + Z = impDf$z + ), + !!!compact(list( + N = if (is_in("n", colnames(impDf))) impDf$n, + BETA = if (is_in("beta", colnames(impDf))) impDf$beta, + SE = if (is_in("se", colnames(impDf))) impDf$se + )) ) - if (is_in("n", colnames(impDf))) { - out$N <- impDf$n - } - if (is_in("beta", colnames(impDf))) { - out$BETA <- impDf$beta - } - if (is_in("se", colnames(impDf))) { - out$SE <- impDf$se - } # RAISS reconstructs the z-score only, so it has no frequency for an # imputed variant. But the OBSERVED variants came in with a (harmonized, - # directional) AF, which the rebuilt `out` above would otherwise discard -- + # directional) AF, which the rebuilt frame above would otherwise discard -- # leaving top_loci$af NA for the whole entry under --impute. Re-attach it by # SNP so observed variants keep their AF and imputed variants (absent from # `df`) get NA. No-op when the study declared no frequency. - if (is_in("AF", colnames(df))) { - out$AF <- as.numeric(df$AF)[match(out$SNP, df$SNP)] - } - if (is_in("N", colnames(out)) && any(is.na(out$N))) { - out$N[is.na(out$N)] <- stats::median(out$N, na.rm = TRUE) + withAf <- if (is_in("AF", colnames(df))) { + mutate(rebuilt, AF = as.numeric(df$AF)[match(.data$SNP, df$SNP)]) + } else { + rebuilt } + out <- .qcFillMissingN(withAf) list(df = out, total = nrow(out), imputed = nrow(out) - nrow(knownZ)) } +# Imputed variants carry no sample size, so they inherit the observed median. +# @noRd +.qcFillMissingN <- function(out) { + if (!is_in("N", colnames(out)) || !any(is.na(out$N))) { + return(out) + } + mutate(out, N = replace_na(.data$N, stats::median(.data$N, na.rm = TRUE))) +} + # Emit the RAISS net-change QC track line. .qcRaissReport <- function(imputeBefore, imputeAfter, lbl) { .qcEmit( @@ -3899,7 +4146,6 @@ krigingOutlierQc <- function( # fields + before/after counts (imputation adds variants, so not monotonic). .qcRaissImpute <- function(df, ldSketch, opts, lbl) { imputeBefore <- nrow(df) - audit <- list() flank <- if (is.null(opts$imputeOpts$flank)) { 0L } else { @@ -3913,10 +4159,9 @@ krigingOutlierQc <- function( "(no LD-panel variants in the ", "region window)." ) - audit$raissImputedVariants <- 0L return(list( df = df, - audit = audit, + audit = list(raissImputedVariants = 0L), imputeBefore = imputeBefore, imputeAfter = nrow(df) )) @@ -3933,10 +4178,12 @@ krigingOutlierQc <- function( imputed <- .qcRaissRun(inp, opts) merged <- .qcRaissMerge(imputed, inp$knownZ, df) df <- merged$df - if (!is.na(merged$total)) { - audit$raissTotalVariants <- merged$total - } - audit$raissImputedVariants <- merged$imputed + audit <- c( + .qcAudit( + raissTotalVariants = if (!is.na(merged$total)) merged$total + ), + list(raissImputedVariants = merged$imputed) + ) imputeAfter <- nrow(df) .qcRaissReport(imputeBefore, imputeAfter, lbl) list( @@ -3958,7 +4205,7 @@ krigingOutlierQc <- function( .qcRemovedSegments <- function(entryAudit, qcCount, opts) { sc <- entryAudit$sanityChecks cf <- entryAudit$contentFilters - segs <- c( + c( .qcSeg(sc$nonstandardChrDropped, "nonstdChr"), .qcSeg(sc$missDataDropped, "missData"), .qcSeg(sc$pOutOfRangeDropped, "badP"), @@ -3967,12 +4214,11 @@ krigingOutlierQc <- function( .qcSeg(cf$mafDropped, "maf"), .qcSeg(cf$infoDropped, "info"), .qcSeg(cf$nDropped, "nCutoff"), - .qcSeg(qcCount$harmDropped, "harmonization") + .qcSeg(qcCount$harmDropped, "harmonization"), + if (!identical(opts$zMismatchQc, "none")) { + str_c("mismatch ", qcCount$mismatchRemoved) + } ) - if (!identical(opts$zMismatchQc, "none")) { - segs <- c(segs, str_c("mismatch ", qcCount$mismatchRemoved)) - } - segs } # Emit the per-entry QC rollup: corrected (retained), removed, imputed. @@ -3982,15 +4228,13 @@ krigingOutlierQc <- function( "sign-flip ", qcCount$harmCorrSign, ", strand-flip ", - qcCount$harmCorrStrand + qcCount$harmCorrStrand, + if (isTRUE(opts$alleleFlipKriging)) { + str_c(", kriging-flip ", qcCount$krigingFlipped) + } else { + "" + } ) - if (isTRUE(opts$alleleFlipKriging)) { - correctedSeg <- str_c( - correctedSeg, - ", kriging-flip ", - qcCount$krigingFlipped - ) - } impSeg <- if (isTRUE(opts$impute) && !is.na(qcCount$imputeAfter)) { str_c( " | imputed ", @@ -4022,7 +4266,7 @@ krigingOutlierQc <- function( # Panel-vs-sumstats allele harmonization + counter bookkeeping. .qcHarmonizeEntry <- function(df, ldSketch, opts, lbl) { nHarmIn <- nrow(df) - df <- .matchAgainstSketch( + matched <- .matchAgainstSketch( df, ldSketch, matchMinProp = opts$matchMinProp, @@ -4030,27 +4274,35 @@ krigingOutlierQc <- function( removeStrandAmbiguous = opts$removeStrandAmbiguous, removeDups = TRUE ) - harmCounts <- attr(df, "qcCounts") - attr(df, "qcCounts") <- NULL + harmCounts <- attr(matched, "qcCounts") # Re-key SNP to the harmonized id: .matchAgainstSketch rewrites variant_id # to the panel orientation + sign-flips swapped variants but leaves SNP; a # stale SNP makes flipped variants miss the panel in later lookups. - if (!is.null(df$variant_id)) { - df$SNP <- df$variant_id - } - counts <- list( - harmCorrSign = 0L, - harmCorrStrand = 0L, - harmDropped = nHarmIn - nrow(df) + reKeyed <- mutate( + `attr<-`(matched, "qcCounts", NULL), + !!!compact(list(SNP = matched$variant_id)) + ) + counts <- list_assign( + list( + harmCorrSign = 0L, + harmCorrStrand = 0L, + harmDropped = nHarmIn - nrow(reKeyed) + ), + !!!compact(list( + harmCorrSign = harmCounts$signFlip, + harmCorrStrand = harmCounts$strandFlip + )) + ) + .qcHarmonizeReport( + nrow(reKeyed), + nHarmIn, + counts, + !is.null(harmCounts), + lbl ) - if (!is.null(harmCounts)) { - counts$harmCorrSign <- harmCounts$signFlip - counts$harmCorrStrand <- harmCounts$strandFlip - } - .qcHarmonizeReport(nrow(df), nHarmIn, counts, !is.null(harmCounts), lbl) list( - df = df, - audit = list(matchedAgainstSketch = nrow(df)), + df = reKeyed, + audit = list(matchedAgainstSketch = nrow(reKeyed)), counts = counts ) } @@ -4091,11 +4343,15 @@ krigingOutlierQc <- function( if (!any(flip)) { return(df) } - df$Z[flip] <- -df$Z[flip] - if (is_in("BETA", colnames(df))) { - df$BETA[flip] <- -df$BETA[flip] - } - df + mutate( + df, + Z = replace(.data$Z, flip, -df$Z[flip]), + !!!compact(list( + BETA = if (is_in("BETA", colnames(df))) { + replace(df$BETA, flip, -df$BETA[flip]) + } + )) + ) } # @noRd @@ -4116,17 +4372,17 @@ krigingOutlierQc <- function( audit = list(krigingFlipped = 0L, panelUnsupportedDropped = nKrIn) )) } - df <- panel$df + supported <- panel$df nPanelDrop <- panel$dropped .qcEmitPanelDrop(lbl, nPanelDrop, nKrIn) kr <- krigingOutlierQc( - df$Z, + supported$Z, panel$R, - n = .qcKrigingN(df, opts), - variantIds = df$SNP + n = .qcKrigingN(supported, opts), + variantIds = supported$SNP ) nKr <- sum(kr$flip) - df <- .qcApplyKrigingFlips(df, kr$flip) + flipped <- .qcApplyKrigingFlips(supported, kr$flip) .qcEmit( lbl, "QC track: kriging sign-flipped ", @@ -4136,7 +4392,7 @@ krigingOutlierQc <- function( " LD-inconsistent variant(s)." ) list( - df = df, + df = flipped, count = nKr, audit = list( krigingFlipped = nKr, @@ -4154,13 +4410,19 @@ krigingOutlierQc <- function( nMmIn <- nrow(df) ldQc <- .applyLdMismatchQcToEntry(df, ldSketch, opts$zMismatchQc) df <- ldQc$df - audit <- list( + baseAudit <- list( ldMismatchOutliersDropped = ldQc$outliers, ldMismatchMethod = opts$zMismatchQc ) nPanelDrop <- ldQc$panelUnsupportedDropped %||% 0L + audit <- c( + baseAudit, + .qcAudit( + panelUnsupportedDropped = if (nPanelDrop > 0L) nPanelDrop, + ldMismatchDiagnostics = ldQc$diagnostics + ) + ) if (nPanelDrop > 0L) { - audit$panelUnsupportedDropped <- nPanelDrop .qcEmit( lbl, "QC track: dropped ", @@ -4170,9 +4432,6 @@ krigingOutlierQc <- function( " variant(s) with no LD-panel entry after panel filtering." ) } - if (!is.null(ldQc$diagnostics)) { - audit$ldMismatchDiagnostics <- ldQc$diagnostics - } .qcEmit( lbl, "QC track: ", @@ -4230,10 +4489,9 @@ krigingOutlierQc <- function( dropNonpositiveSe = opts$dropNonpositiveSe ) df <- sanity$df - audit <- list() - if (length(sanity$audit) > 0L) { - audit$sanityChecks <- sanity$audit - } + audit <- .qcAudit( + sanityChecks = if (length(sanity$audit) > 0L) sanity$audit + ) if (nSanIn > 0L && nrow(df) != nSanIn) { .qcEmit( lbl, @@ -4252,13 +4510,20 @@ krigingOutlierQc <- function( .qcStepEffectiveN <- function(df, opts, lbl) { nRes <- .resolveEffectiveN(df, opts, lbl) df <- nRes$df - if ( - isTRUE(is_in(nRes$nSource, c("effective", "total"))) && - is_in("N", colnames(df)) - ) { - opts$nForPip <- stats::median(as.numeric(df$N), na.rm = TRUE) - } - list(df = df, nSource = nRes$nSource, opts = opts) + applied <- isTRUE(is_in(nRes$nSource, c("effective", "total"))) && + is_in("N", colnames(df)) + list( + df = df, + nSource = nRes$nSource, + opts = list_assign( + opts, + !!!compact(list( + nForPip = if (applied) { + stats::median(as.numeric(df$N), na.rm = TRUE) + } + )) + ) + ) } # Variant-content filters (MAF / INFO / N). @@ -4271,10 +4536,9 @@ krigingOutlierQc <- function( nCutoff = opts$nCutoff ) df <- cf$df - audit <- list() - if (length(cf$audit) > 0L) { - audit$contentFilters <- cf$audit - } + audit <- .qcAudit( + contentFilters = if (length(cf$audit) > 0L) cf$audit + ) if (nFiltIn > 0L && nrow(df) != nFiltIn) { .qcEmit( lbl, @@ -4291,110 +4555,283 @@ krigingOutlierQc <- function( # Derive BETA/SE from signed Z, then P from Z (re-clamping tiny P). .qcStepDerive <- function(df, opts, entryAudit) { derived <- .deriveBetaSeFromZ(df) - df <- derived$df - if (!is.null(derived$audit)) { - entryAudit$betaSeFromZ <- derived$audit - } - if (is_in("Z", colnames(df)) && !is_in("P", colnames(df))) { - df$P <- .zToPvalue(df$Z) - entryAudit$pValueFromZ <- sum(!is.na(df$P)) - if (isTRUE(opts$clampSmallP) && nrow(df) > 0L) { - smallMask <- !is.na(df$P) & df$P >= 0 & df$P < opts$smallPFloor - nClamped <- sum(smallMask) - if (nClamped > 0L) { - df$P[smallMask] <- opts$smallPFloor - prev <- entryAudit$sanityChecks$smallPClamped %||% 0L - if (is.null(entryAudit$sanityChecks)) { - entryAudit$sanityChecks <- list() - } - entryAudit$sanityChecks$smallPClamped <- prev + nClamped - } - } + withBetaSe <- list_assign( + entryAudit, + !!!compact(list(betaSeFromZ = derived$audit)) + ) + if (!is_in("Z", colnames(derived$df)) || is_in("P", colnames(derived$df))) { + return(list(df = derived$df, entryAudit = withBetaSe)) } - list(df = df, entryAudit = entryAudit) + withP <- mutate(derived$df, P = .zToPvalue(.data$Z)) + clamped <- .qcClampDerivedP(withP, opts) + list( + df = clamped$df, + entryAudit = list_assign( + withBetaSe, + pValueFromZ = sum(!is.na(withP$P)), + !!!compact(list( + sanityChecks = .qcAddClampCount( + entryAudit$sanityChecks, + clamped$nClamped + ) + )) + ) + ) +} + +# Re-clamp the P values just derived from Z, and report how many moved. +# @noRd +.qcClampDerivedP <- function(df, opts) { + if (!isTRUE(opts$clampSmallP) || nrow(df) == 0L) { + return(list(df = df, nClamped = 0L)) + } + smallMask <- !is.na(df$P) & df$P >= 0 & df$P < opts$smallPFloor + if (sum(smallMask) == 0L) { + return(list(df = df, nClamped = 0L)) + } + list( + df = mutate( + df, + P = replace(.data$P, smallMask, opts$smallPFloor) + ), + nClamped = sum(smallMask) + ) +} + +# Fold this step's clamp count into the sanity-check record the earlier +# per-row checks may already have written. NULL when nothing was clamped, so +# the caller can drop the key rather than record an empty record. +# @noRd +.qcAddClampCount <- function(sanityChecks, nClamped) { + if (nClamped == 0L) { + return(NULL) + } + list_assign( + sanityChecks %||% list(), + smallPClamped = (sanityChecks$smallPClamped %||% 0L) + nClamped + ) } # keepVariants subset + skipRegion drop. .qcStepKeepSkip <- function(df, opts) { - audit <- list() - if (length(opts$keepVariants) > 0L) { - before <- nrow(df) - df <- filter(df, is_in(.data$SNP, opts$keepVariants)) - audit$keepVariantsDropped <- before - nrow(df) + nIn <- nrow(df) + kept <- if (length(opts$keepVariants) > 0L) { + filter(df, is_in(.data$SNP, opts$keepVariants)) + } else { + df } - if (!is.null(opts$skipRegion) && length(opts$skipRegion) > 0L) { - before <- nrow(df) - df <- .applySkipRegion(df, opts$skipRegion) - audit$skipRegionDropped <- before - nrow(df) + nKept <- nrow(kept) + skipped <- if (!is.null(opts$skipRegion) && length(opts$skipRegion) > 0L) { + .applySkipRegion(kept, opts$skipRegion) + } else { + kept } - list(df = df, audit = audit) + list( + df = skipped, + audit = .qcAudit( + keepVariantsDropped = if (length(opts$keepVariants) > 0L) { + nIn - nKept + }, + skipRegionDropped = if ( + !is.null(opts$skipRegion) && length(opts$skipRegion) > 0L + ) { + nKept - nrow(skipped) + } + ) + ) } # Optional post-harmonization signal screen (PIP / |Z| / BF / logBF). .qcStepScreen <- function(df, opts) { - audit <- list() - if (!is.null(opts$screen)) { - scr <- .applyEntryScreen(df, n = opts$nForPip, screen = opts$screen) - df <- scr$df - audit$pipScreenSkipped <- isTRUE(scr$skipped) - if (isTRUE(scr$skipped)) audit$pipScreenReason <- scr$reason + if (is.null(opts$screen)) { + return(list(df = df, audit = list())) } - list(df = df, audit = audit) + scr <- .applyEntryScreen(df, n = opts$nForPip, screen = opts$screen) + list( + df = scr$df, + audit = c( + list(pipScreenSkipped = isTRUE(scr$skipped)), + .qcAudit(pipScreenReason = if (isTRUE(scr$skipped)) scr$reason) + ) + ) } # Optional RAISS imputation step wrapper (guarded; threads impute counters). .qcRaissImputeStep <- function(df, ldSketch, opts, lbl, qcCount) { - audit <- list() - if (isTRUE(opts$impute) && nrow(df) >= 1L) { - imp <- .qcRaissImpute(df, ldSketch, opts, lbl) - df <- imp$df - audit <- imp$audit - qcCount$imputeBefore <- imp$imputeBefore - qcCount$imputeAfter <- imp$imputeAfter + if (!isTRUE(opts$impute) || nrow(df) < 1L) { + return(list(df = df, audit = list(), qcCount = qcCount)) } - list(df = df, audit = audit, qcCount = qcCount) + imp <- .qcRaissImpute(df, ldSketch, opts, lbl) + list( + df = imp$df, + audit = imp$audit, + qcCount = list_assign( + qcCount, + imputeBefore = imp$imputeBefore, + imputeAfter = imp$imputeAfter + ) + ) } # Early return when too few variants survive pre-harmonization QC. .qcEarlyExit <- function(df, entryAudit, qcCount, opts, nIn, lbl) { - entryAudit$earlyExit <- - "fewer than two variants after pre-harmonization QC" + withExit <- list_assign( + entryAudit, + earlyExit = "fewer than two variants after pre-harmonization QC" + ) # Still emit the rollup. An entry that QC empties is precisely the case a # user needs told about, and returning early used to make those drops # invisible in the log -- the audit recorded them, nothing said so. - .qcEmitRollup(entryAudit, qcCount, opts, nIn, nrow(df), lbl) - list(gr = .dfToEntryGranges(df), audit = entryAudit) + .qcEmitRollup(withExit, qcCount, opts, nIn, nrow(df), lbl) + list(gr = .dfToEntryGranges(df), audit = withExit) +} + +# Each QC phase below is (state) -> state, so the sequence reads as a pipeline +# rather than a run of reassignments. `state` carries df + entryAudit + opts + +# qcCount + lbl (+ ldSketch for the panel-aware phases); a phase touches only +# the parts it owns and passes the rest through. + +# Per-row sanity checks. +# @noRd +.qcPhaseSanity <- function(state) { + san <- .qcStepSanity(state$df, state$opts, state$lbl) + list_assign( + state, + df = san$df, + entryAudit = list_modify(state$entryAudit, !!!san$audit) + ) +} + +# Effective-N canonicalization, which also rewrites `opts$nForPip`. +# @noRd +.qcPhaseEffectiveN <- function(state) { + eff <- .qcStepEffectiveN(state$df, state$opts, state$lbl) + list_assign( + state, + df = eff$df, + entryAudit = list_assign(state$entryAudit, nSource = eff$nSource), + opts = eff$opts + ) +} + +# MAF / INFO / N content filters. +# @noRd +.qcPhaseContentFilters <- function(state) { + cf <- .qcStepContentFilters(state$df, state$opts, state$lbl) + list_assign( + state, + df = cf$df, + entryAudit = list_modify(state$entryAudit, !!!cf$audit) + ) +} + +# BETA/SE from Z, then P from Z. Owns the audit outright (it folds its own +# clamp count into the sanity record the earlier phase may have written). +# @noRd +.qcPhaseDerive <- function(state) { + der <- .qcStepDerive(state$df, state$opts, state$entryAudit) + list_assign(state, df = der$df, entryAudit = der$entryAudit) +} + +# keepVariants subset + skipRegion drop. +# @noRd +.qcPhaseKeepSkip <- function(state) { + ks <- .qcStepKeepSkip(state$df, state$opts) + list_assign( + state, + df = ks$df, + entryAudit = list_modify(state$entryAudit, !!!ks$audit) + ) +} + +# Panel-vs-sumstats allele harmonization. +# @noRd +.qcPhaseHarmonize <- function(state) { + harm <- .qcHarmonizeEntry( + state$df, + state$ldSketch, + state$opts, + state$lbl + ) + list_assign( + state, + df = harm$df, + entryAudit = list_modify(state$entryAudit, !!!harm$audit), + qcCount = list_modify(state$qcCount, !!!harm$counts) + ) +} + +# Post-harmonization signal screen. +# @noRd +.qcPhaseScreen <- function(state) { + scr <- .qcStepScreen(state$df, state$opts) + list_assign( + state, + df = scr$df, + entryAudit = list_modify(state$entryAudit, !!!scr$audit) + ) +} + +# Kriging sign-flips and LD-mismatch QC. One phase, because the mismatch check +# reads the kriging-corrected frame and the two counts are reported together. +# @noRd +.qcPhaseLdChecks <- function(state) { + kr <- .qcKrigingFlip(state$df, state$ldSketch, state$opts, state$lbl) + mm <- .qcMismatchQc(kr$df, state$ldSketch, state$opts, state$lbl) + list_assign( + state, + df = mm$df, + entryAudit = list_modify( + list_modify(state$entryAudit, !!!kr$audit), + !!!mm$audit + ), + qcCount = list_assign( + state$qcCount, + krigingFlipped = kr$count, + mismatchRemoved = mm$count + ) + ) +} + +# Optional RAISS imputation. +# @noRd +.qcPhaseImpute <- function(state) { + imp <- .qcRaissImputeStep( + state$df, + state$ldSketch, + state$opts, + state$lbl, + state$qcCount + ) + list_assign( + state, + df = imp$df, + entryAudit = list_modify(state$entryAudit, !!!imp$audit), + qcCount = imp$qcCount + ) } # Pre-harmonization phase: init + sanity + effective-N + content + derive + # keep/skip. Returns the QC state carried into the harmonization phase. .qcPreHarmonize <- function(gr, opts, entryLabel) { init <- .qcInitEntry(gr, entryLabel) - df <- init$df - entryAudit <- init$entryAudit - lbl <- init$lbl - san <- .qcStepSanity(df, opts, lbl) - df <- san$df - entryAudit <- modifyList(entryAudit, san$audit) - eff <- .qcStepEffectiveN(df, opts, lbl) - df <- eff$df - entryAudit$nSource <- eff$nSource - opts <- eff$opts - cf <- .qcStepContentFilters(df, opts, lbl) - df <- cf$df - entryAudit <- modifyList(entryAudit, cf$audit) - der <- .qcStepDerive(df, opts, entryAudit) - df <- der$df - entryAudit <- der$entryAudit - ks <- .qcStepKeepSkip(df, opts) - df <- ks$df - entryAudit <- modifyList(entryAudit, ks$audit) - list( - df = df, - entryAudit = entryAudit, + final <- list( + df = init$df, + entryAudit = init$entryAudit, opts = opts, + lbl = init$lbl + ) |> + .qcPhaseSanity() |> + .qcPhaseEffectiveN() |> + .qcPhaseContentFilters() |> + .qcPhaseDerive() |> + .qcPhaseKeepSkip() + list( + df = final$df, + entryAudit = final$entryAudit, + opts = final$opts, qcCount = init$qcCount, - lbl = lbl, + lbl = final$lbl, nStudyIn = init$nStudyIn ) } @@ -4407,36 +4844,40 @@ krigingOutlierQc <- function( entryLabel = NULL ) { pre <- .qcPreHarmonize(gr, opts, entryLabel) - df <- pre$df - entryAudit <- pre$entryAudit - opts <- pre$opts - qcCount <- pre$qcCount - lbl <- pre$lbl - if (nrow(df) < 2L) { - return(.qcEarlyExit(df, entryAudit, qcCount, opts, length(gr), lbl)) - } - harm <- .qcHarmonizeEntry(df, ldSketch, opts, lbl) - df <- harm$df - entryAudit <- modifyList(entryAudit, harm$audit) - qcCount <- modifyList(qcCount, harm$counts) - scr <- .qcStepScreen(df, opts) - df <- scr$df - entryAudit <- modifyList(entryAudit, scr$audit) - kr <- .qcKrigingFlip(df, ldSketch, opts, lbl) - df <- kr$df - entryAudit <- modifyList(entryAudit, kr$audit) - qcCount$krigingFlipped <- kr$count - mm <- .qcMismatchQc(df, ldSketch, opts, lbl) - df <- mm$df - entryAudit <- modifyList(entryAudit, mm$audit) - qcCount$mismatchRemoved <- mm$count - imp <- .qcRaissImputeStep(df, ldSketch, opts, lbl, qcCount) - df <- imp$df - entryAudit <- modifyList(entryAudit, imp$audit) - qcCount <- imp$qcCount - .qcEmitRollup(entryAudit, qcCount, opts, pre$nStudyIn, nrow(df), lbl) - entryAudit$variantsOut <- nrow(df) - list(gr = .dfToEntryGranges(df), audit = entryAudit) + if (nrow(pre$df) < 2L) { + return(.qcEarlyExit( + pre$df, + pre$entryAudit, + pre$qcCount, + pre$opts, + length(gr), + pre$lbl + )) + } + final <- list( + df = pre$df, + entryAudit = pre$entryAudit, + qcCount = pre$qcCount, + opts = pre$opts, + lbl = pre$lbl, + ldSketch = ldSketch + ) |> + .qcPhaseHarmonize() |> + .qcPhaseScreen() |> + .qcPhaseLdChecks() |> + .qcPhaseImpute() + .qcEmitRollup( + final$entryAudit, + final$qcCount, + final$opts, + pre$nStudyIn, + nrow(final$df), + final$lbl + ) + list( + gr = .dfToEntryGranges(final$df), + audit = list_assign(final$entryAudit, variantsOut = nrow(final$df)) + ) } # Shrink an LD-sketch GenotypeHandle to the panel variants inside the summary @@ -4457,11 +4898,11 @@ krigingOutlierQc <- function( if (is.null(ldSketch)) { return(NULL) } - chrom <- unlist(map(entries, .entryChrom), use.names = FALSE) - pos <- unlist(map(entries, .entryPos), use.names = FALSE) - ok <- !is.na(chrom) & !is.na(pos) - chrom <- chrom[ok] - pos <- pos[ok] + chromAll <- unname(list_c(map(entries, .entryChrom))) + posAll <- unname(list_c(map(entries, .entryPos))) + ok <- !is.na(chromAll) & !is.na(posAll) + chrom <- chromAll[ok] + pos <- posAll[ok] if (length(pos) == 0L) { # No span to keep: a zero-variant object references no LD, so the # retained panel is empty rather than the full genome-wide sketch. @@ -4508,7 +4949,7 @@ krigingOutlierQc <- function( if (nRanges == 0L) { return(.emptySketch(ldSketch)) } - ids <- unlist(map(entries, .entrySnpIds), use.names = FALSE) + ids <- unname(list_c(map(entries, .entrySnpIds))) if (length(ids) == 0L) { return(ldSketch) } @@ -4533,13 +4974,9 @@ krigingOutlierQc <- function( # --- summaryStatsQc orchestration helpers ---------------------------------- # Validate input class + per-entry MAF/INFO column availability. +#' @importFrom checkmate assertMultiClass .ssqcCheckEntries <- function(sumstats, mafCutoff, infoCutoff) { - if ( - !methods::is(sumstats, "QtlSumStats") && - !methods::is(sumstats, "GwasSumStats") - ) { - abort("summaryStatsQc requires a QtlSumStats or GwasSumStats input.") - } + assertMultiClass(sumstats, c("QtlSumStats", "GwasSumStats")) for (i in seq_len(nrow(sumstats))) { cols <- colnames(S4Vectors::mcols(.collectionEntry(sumstats, i))) # mafCutoff no longer pre-aborts on a missing frequency: .cfMaf @@ -4582,70 +5019,98 @@ krigingOutlierQc <- function( } # Build the per-entry QC options list from the captured call parameters. -.ssqcBuildOpts <- function(p) { - optNames <- c( - "removeIndels", - "removeStrandAmbiguous", - "mafCutoff", - "macCutoff", - "imissCutoff", - "infoCutoff", - "nCutoff", - "skipRegion", - "zMismatchQc", - "alleleFlipKriging", - "effectiveN", - "impute", - "imputeOpts", - "matchMinProp", - "coerceNumeric", - "normalizeChr", - "dropNonstandardChr", - "dropMissData", - "dropPOutOfRange", - "clampSmallP", - "smallPFloor", - "dropZeroEffect", - "dropNonpositiveSe" - ) - opts <- p[optNames] - opts$keepVariants <- as.character(p$keepVariants) - opts$screen <- .resolveScreenMetric( - p$pipCutoffToSkip, - p$absZCutoffToSkip, - p$bfCutoffToSkip, - p$logBfCutoffToSkip - ) - opts$nCase <- NULL - opts$nControl <- NULL - opts$nForPip <- NULL - opts +.ssqcBuildOpts <- function( + removeIndels, + removeStrandAmbiguous, + mafCutoff, + macCutoff, + imissCutoff, + infoCutoff, + nCutoff, + skipRegion, + zMismatchQc, + alleleFlipKriging, + effectiveN, + impute, + imputeOpts, + matchMinProp, + coerceNumeric, + normalizeChr, + dropNonstandardChr, + dropMissData, + dropPOutOfRange, + clampSmallP, + smallPFloor, + dropZeroEffect, + dropNonpositiveSe, + keepVariants, + pipCutoffToSkip, + absZCutoffToSkip, + bfCutoffToSkip, + logBfCutoffToSkip +) { + # Built explicitly rather than by subsetting a captured environment with a + # character vector: a renamed argument is now an error, not a NULL entry. + opts <- list( + removeIndels = removeIndels, + removeStrandAmbiguous = removeStrandAmbiguous, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff, + infoCutoff = infoCutoff, + nCutoff = nCutoff, + skipRegion = skipRegion, + zMismatchQc = zMismatchQc, + alleleFlipKriging = alleleFlipKriging, + effectiveN = effectiveN, + impute = impute, + imputeOpts = imputeOpts, + matchMinProp = matchMinProp, + coerceNumeric = coerceNumeric, + normalizeChr = normalizeChr, + dropNonstandardChr = dropNonstandardChr, + dropMissData = dropMissData, + dropPOutOfRange = dropPOutOfRange, + clampSmallP = clampSmallP, + smallPFloor = smallPFloor, + dropZeroEffect = dropZeroEffect, + dropNonpositiveSe = dropNonpositiveSe + ) + # nCase / nControl / nForPip are deliberately absent here: they are + # per-entry, and `.ssqcEntryOpts()` adds them for the entry being run. + list_assign( + opts, + keepVariants = as.character(keepVariants), + screen = .resolveScreenMetric( + pipCutoffToSkip, + absZCutoffToSkip, + bfCutoffToSkip, + logBfCutoffToSkip + ) + ) } # Per-entry sample-size options: median N for PIP, study case/control/total N. .ssqcEntryOpts <- function(opts, sumstats, i) { mc <- S4Vectors::mcols(.collectionEntry(sumstats, i)) - opts$nForPip <- if (is_in("N", colnames(mc))) { - stats::median(mc$N, na.rm = TRUE) - } else { - NULL - } - opts$nCase <- if (is_in("nCase", .tupleColumnNames(sumstats))) { - as.numeric(sumstats$nCase)[[i]] - } else { - NULL - } - opts$nControl <- if (is_in("nControl", .tupleColumnNames(sumstats))) { - as.numeric(sumstats$nControl)[[i]] - } else { - NULL - } - opts$nSample <- if (is_in("nSample", .tupleColumnNames(sumstats))) { - as.numeric(sumstats$nSample)[[i]] - } else { - NULL - } - opts + cols <- .tupleColumnNames(sumstats) + list_assign( + opts, + !!!compact(list( + nForPip = if (is_in("N", colnames(mc))) { + stats::median(mc$N, na.rm = TRUE) + }, + nCase = if (is_in("nCase", cols)) { + as.numeric(sumstats$nCase)[[i]] + }, + nControl = if (is_in("nControl", cols)) { + as.numeric(sumstats$nControl)[[i]] + }, + nSample = if (is_in("nSample", cols)) { + as.numeric(sumstats$nSample)[[i]] + } + )) + ) } # Per-entry log label: study/context/trait (QTL) or study (GWAS). @@ -4694,70 +5159,104 @@ krigingOutlierQc <- function( .genotypeExperiment(pruned) } +# One entry's QC result: list(gr, audit). `opts` arrives as the shared base +# options; the per-entry fields are derived here rather than carried over from +# the previous entry. +# @noRd +.ssqcRunEntry <- function(i, sumstats, opts, ldSketch, refGenome, isQtl) { + .runEntrySummaryStatsQc( + gr = .collectionEntry(sumstats, i), + ldSketch = ldSketch, + refGenome = refGenome, + opts = .ssqcEntryOpts(opts, sumstats, i), + entryLabel = .ssqcEntryLabel(sumstats, i, isQtl) + ) +} + # Run the per-entry QC pipeline across all entries. .ssqcRunEntries <- function(sumstats, opts) { - newEntries <- vector("list", nrow(sumstats)) - entryAudits <- vector("list", nrow(sumstats)) isQtl <- methods::is(sumstats, "QtlSumStats") # Panel filter, once for the shared LD reference and BEFORE any entry is # harmonized, so a variant the panel cannot support is gone from the LD # and from the summary statistics alike. ldSketch <- .ssqcPrunePanel( getLdSketch(sumstats), - .panelCutoffs(opts), + .panelCutoffs(opts$mafCutoff, opts$macCutoff, opts$imissCutoff), "summaryStatsQc" ) refGenome <- getGenome(sumstats) - for (i in seq_len(nrow(sumstats))) { - opts <- .ssqcEntryOpts(opts, sumstats, i) - result <- .runEntrySummaryStatsQc( - gr = .collectionEntry(sumstats, i), - ldSketch = ldSketch, - refGenome = refGenome, - opts = opts, - entryLabel = .ssqcEntryLabel(sumstats, i, isQtl) - ) - newEntries[[i]] <- result$gr - entryAudits[[i]] <- result$audit - } + results <- map( + seq_len(nrow(sumstats)), + .ssqcRunEntry, + sumstats = sumstats, + opts = opts, + ldSketch = ldSketch, + refGenome = refGenome, + isQtl = isQtl + ) list( - newEntries = newEntries, - entryAudits = entryAudits, + newEntries = map(results, "gr"), + entryAudits = map(results, "audit"), ldSketch = ldSketch ) } # Assemble the qcInfo record (echoed options + per-entry audits). -.ssqcBuildQcInfo <- function(p, entryAudits) { - optNames <- c( - "removeIndels", - "removeStrandAmbiguous", - "mafCutoff", - "macCutoff", - "imissCutoff", - "infoCutoff", - "nCutoff", - "pipCutoffToSkip", - "absZCutoffToSkip", - "bfCutoffToSkip", - "logBfCutoffToSkip", - "zMismatchQc", - "alleleFlipKriging", - "effectiveN", - "impute", - "coerceNumeric", - "normalizeChr", - "dropNonstandardChr", - "dropMissData", - "dropPOutOfRange", - "clampSmallP", - "smallPFloor", - "dropZeroEffect", - "dropNonpositiveSe" - ) +.ssqcBuildQcInfo <- function( + entryAudits, + removeIndels, + removeStrandAmbiguous, + mafCutoff, + macCutoff, + imissCutoff, + infoCutoff, + nCutoff, + pipCutoffToSkip, + absZCutoffToSkip, + bfCutoffToSkip, + logBfCutoffToSkip, + zMismatchQc, + alleleFlipKriging, + effectiveN, + impute, + coerceNumeric, + normalizeChr, + dropNonstandardChr, + dropMissData, + dropPOutOfRange, + clampSmallP, + smallPFloor, + dropZeroEffect, + dropNonpositiveSe +) { list( timestamp = NA_character_, - options = p[optNames], + options = list( + removeIndels = removeIndels, + removeStrandAmbiguous = removeStrandAmbiguous, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff, + infoCutoff = infoCutoff, + nCutoff = nCutoff, + pipCutoffToSkip = pipCutoffToSkip, + absZCutoffToSkip = absZCutoffToSkip, + bfCutoffToSkip = bfCutoffToSkip, + logBfCutoffToSkip = logBfCutoffToSkip, + zMismatchQc = zMismatchQc, + alleleFlipKriging = alleleFlipKriging, + effectiveN = effectiveN, + impute = impute, + coerceNumeric = coerceNumeric, + normalizeChr = normalizeChr, + dropNonstandardChr = dropNonstandardChr, + dropMissData = dropMissData, + dropPOutOfRange = dropPOutOfRange, + clampSmallP = clampSmallP, + smallPFloor = smallPFloor, + dropZeroEffect = dropZeroEffect, + dropNonpositiveSe = dropNonpositiveSe + ), entryAudit = entryAudits ) } @@ -5002,10 +5501,64 @@ summaryStatsQc <- function( zMismatchQc <- arg_match(zMismatchQc) .ssqcCheckEntries(sumstats, mafCutoff, infoCutoff) .ssqcCheckPanelCutoffs(mafCutoff, macCutoff, imissCutoff) - p <- as.list(environment()) - opts <- .ssqcBuildOpts(p) + opts <- .ssqcBuildOpts( + removeIndels = removeIndels, + removeStrandAmbiguous = removeStrandAmbiguous, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff, + infoCutoff = infoCutoff, + nCutoff = nCutoff, + skipRegion = skipRegion, + zMismatchQc = zMismatchQc, + alleleFlipKriging = alleleFlipKriging, + effectiveN = effectiveN, + impute = impute, + imputeOpts = imputeOpts, + matchMinProp = matchMinProp, + coerceNumeric = coerceNumeric, + normalizeChr = normalizeChr, + dropNonstandardChr = dropNonstandardChr, + dropMissData = dropMissData, + dropPOutOfRange = dropPOutOfRange, + clampSmallP = clampSmallP, + smallPFloor = smallPFloor, + dropZeroEffect = dropZeroEffect, + dropNonpositiveSe = dropNonpositiveSe, + keepVariants = keepVariants, + pipCutoffToSkip = pipCutoffToSkip, + absZCutoffToSkip = absZCutoffToSkip, + bfCutoffToSkip = bfCutoffToSkip, + logBfCutoffToSkip = logBfCutoffToSkip + ) res <- .ssqcRunEntries(sumstats, opts) - qcInfo <- .ssqcBuildQcInfo(p, res$entryAudits) + qcInfo <- .ssqcBuildQcInfo( + res$entryAudits, + removeIndels = removeIndels, + removeStrandAmbiguous = removeStrandAmbiguous, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff, + infoCutoff = infoCutoff, + nCutoff = nCutoff, + pipCutoffToSkip = pipCutoffToSkip, + absZCutoffToSkip = absZCutoffToSkip, + bfCutoffToSkip = bfCutoffToSkip, + logBfCutoffToSkip = logBfCutoffToSkip, + zMismatchQc = zMismatchQc, + alleleFlipKriging = alleleFlipKriging, + effectiveN = effectiveN, + impute = impute, + coerceNumeric = coerceNumeric, + normalizeChr = normalizeChr, + dropNonstandardChr = dropNonstandardChr, + dropMissData = dropMissData, + dropPOutOfRange = dropPOutOfRange, + clampSmallP = clampSmallP, + smallPFloor = smallPFloor, + dropZeroEffect = dropZeroEffect, + dropNonpositiveSe = dropNonpositiveSe + ) # From the PRUNED panel, not the input's: narrowing the original again # would hand back a sketch the panel filter never reached. newLdSketch <- .subsetSketchToIds(res$ldSketch, res$newEntries) @@ -5127,10 +5680,7 @@ summaryStatsQc <- function( # `variants` column: .ldMergeVariants then reads $variants as character(0) # (length 0 -> the block is skipped) instead of hitting an absent column # (which a data.frame returned silently as NULL and a tibble warns on). - variants <- colnames(ld) - if (is.null(variants)) { - variants <- character(0) - } + variants <- colnames(ld) %||% character(0) tibble(variants = variants) } diff --git a/R/tupleSelectors.R b/R/tupleSelectors.R index 1aa329e1..9f6b64a9 100644 --- a/R/tupleSelectors.R +++ b/R/tupleSelectors.R @@ -18,11 +18,16 @@ if (length(keys) == 0L) { return(seq_len(nrow(x))) } - ok <- rep(TRUE, nrow(x)) - for (k in names(keys)) { - ok <- ok & as.character(.tupleColumn(x, k)) == keys[[k]] - } - which(ok) + which(reduce( + map(names(keys), .tupleKeyEquals, x = x, keys = keys), + `&`, + .init = rep(TRUE, nrow(x)) + )) +} + +# @noRd +.tupleKeyEquals <- function(k, x, keys) { + as.character(.tupleColumn(x, k)) == keys[[k]] } # Read an identity column by name. Every collection keeps its identity @@ -72,9 +77,9 @@ # rather than reported as NA). # @noRd .fmrTupleLabel <- function(side, ident, block = NULL) { - fields <- compact(c(ident, list(block = block))) - fields <- fields[!map_lgl(fields, is.na)] - shown <- str_c(names(fields), "='", unlist(fields), "'") + supplied <- compact(c(ident, list(block = block))) + fields <- discard(supplied, is.na) + shown <- str_c(names(fields), "='", map_chr(fields, as.character), "'") glue("{side} ({str_flatten(shown, ', ')})") } @@ -119,6 +124,7 @@ # TwasWeights accessors. Returns an error when no row matches; returns # the single row index when the collection has exactly one row and any # selector argument was omitted. +#' @importFrom checkmate assertVector .tupleSelectRow <- function( x, study, @@ -149,16 +155,10 @@ ) abort(msg) } - if ( - length(study) != 1L || - length(context) != 1L || - length(trait) != 1L || - length(method) != 1L - ) { - abort( - "`study`, `context`, `trait`, and `method` must each be length 1." - ) - } + assertVector(study, len = 1L) + assertVector(context, len = 1L) + assertVector(trait, len = 1L) + assertVector(method, len = 1L) .tupleMatchQtl(x, study, context, trait, method) } @@ -183,6 +183,7 @@ # index of a GwasFineMappingResult collection. `region` may be NULL when # the (study, method) pair maps to a single row; otherwise it disambiguates # among per-block rows of a genome-wide collection. +#' @importFrom checkmate assertVector .tupleSelectRowGwasFmr <- function(x, study, method, region = NULL) { if (nrow(x) == 0L) { abort("GwasFineMappingResult has no rows.") @@ -201,22 +202,19 @@ ) abort(msg) } - if (length(study) != 1L || length(method) != 1L) { - abort("`study` and `method` must each be length 1.") - } - if (!is.null(region) && length(region) != 1L) { - abort("`region` must be length 1 when supplied.") - } + assertVector(study, len = 1L) + assertVector(method, len = 1L) + assertVector(region, len = 1L, null.ok = TRUE) .tupleMatchGwas(x, study, method, region) } # Resolve a (study, method[, blockId]) tuple to a single row index. # @noRd .tupleMatchGwas <- function(x, study, method, region) { - keys <- list(study = study, method = method) - if (!is.null(region)) { - keys$blockId <- region - } + keys <- c( + list(study = study, method = method), + compact(list(blockId = region)) + ) idx <- .matchTupleRows(x, keys) if (length(idx) == 0L) { regionPart <- if (is.null(region)) { @@ -265,24 +263,27 @@ method = NULL, region = NULL ) { - keys <- list( + supplied <- compact(list( study = study, context = context, trait = trait, method = method, blockId = region - ) - keys <- keys[!map_lgl(keys, is.null)] - keys <- keys[is_in(names(keys), .tupleColumnNames(x))] + )) + keys <- supplied[is_in(names(supplied), .tupleColumnNames(x))] if (length(keys) == 0L) { return(seq_len(nrow(x))) } - ok <- rep(TRUE, nrow(x)) - for (k in names(keys)) { - ok <- ok & - is_in(as.character(.tupleColumn(x, k)), as.character(keys[[k]])) - } - which(ok) + which(reduce( + map(names(keys), .tupleKeyIsIn, x = x, keys = keys), + `&`, + .init = rep(TRUE, nrow(x)) + )) +} + +# @noRd +.tupleKeyIsIn <- function(k, x, keys) { + is_in(as.character(.tupleColumn(x, k)), as.character(keys[[k]])) } # Internal: per-row identity metadata for a FineMappingResultBase collection, @@ -292,9 +293,7 @@ .fmrRowMetadata <- function(x) { cols <- c("study", "context", "trait", "blockId", "method") n <- nrow(x) - vals <- map(cols, .fmrMetadataCol, x = x, n = n) - names(vals) <- cols - as_tibble(vals) + as_tibble(set_names(map(cols, .fmrMetadataCol, x = x, n = n), cols)) } # Internal: row-bind view tibbles whose column sets may differ; bind_rows @@ -342,8 +341,7 @@ ) abort(msg) } - cols[["blockId"]] <- as.character(blockId) - cols + c(cols, list(blockId = as.character(blockId))) } # Internal: append a validated `region` GRanges to a constructor's column list @@ -383,17 +381,18 @@ if (length(traitPos) != n) { abort("`traitPos` must have the same length as `study`.") } - cols[["traitPos"]] <- traitPos - cols + c(cols, list(traitPos = traitPos)) } +#' @importFrom checkmate checkClass .validateTraitPosColumn <- function(object) { if (!is_in("traitPos", .tupleColumnNames(object))) { return(character(0)) } traitPos <- .tupleColumn(object, "traitPos") - if (!methods::is(traitPos, "GRanges")) { - return("'traitPos' column must be a GRanges") + res <- checkClass(traitPos, "GRanges") + if (!isTRUE(res)) { + return(str_c("'traitPos' column ", res)) } if (length(traitPos) != nrow(object)) { return("'traitPos' column must have one range per row") @@ -541,6 +540,7 @@ # list(done, result) on a successful single-select, else list(done = FALSE, sel) # carrying the selection error (or NULL when no selector was given). # @noRd +#' @importFrom rlang try_fetch .fmrTrySingle <- function( x, study, @@ -559,7 +559,7 @@ if (!anySelector) { return(list(done = FALSE, sel = NULL)) } - sel <- tryCatch( + sel <- try_fetch( .fmrSelectEntry( x, study = study, @@ -568,7 +568,7 @@ method = method, region = region ), - error = function(e) e + error = function(cnd) cnd ) if (!inherits(sel, "error")) { return(list(done = TRUE, result = onSingle(sel, ...))) @@ -583,11 +583,11 @@ # `perEntry` is an internal per-row function taking the stored payload, not # an S4 generic dispatching on a rebuilt entry. That indirection is what # the FineMappingRow class existed for. - v <- perEntry(.fmrRowParts(x, i), ...) - if (is.null(v) || nrow(v) == 0L) { + raw <- perEntry(.fmrRowParts(x, i), ...) + if (is.null(raw) || nrow(raw) == 0L) { return(NULL) } - v <- select(v, all_of(setdiff(names(v), names(meta)))) + v <- select(raw, all_of(setdiff(names(raw), names(meta)))) bind_cols(slice(meta, rep(i, nrow(v))), v) } @@ -637,15 +637,16 @@ !!!c(combined, list(check.names = FALSE)) ) elements <- list_flatten(map(parts, as.list)) - grl <- GenomicRanges::GRangesList(elements) # Rebuilding from as.list() merges each part's seqinfo, so a part whose # elements never had a build set would leave the result carrying both the # real build and NA. The agreed build is written back explicitly to keep # seqinfo single-valued, which validity requires. - if (!is.null(genome)) { - GenomeInfoDb::genome(grl) <- genome - } - mcols(grl) <- md + built <- .withGenomeBuild( + GenomicRanges::GRangesList(elements), + !is.null(genome), + genome + ) + grl <- S4Vectors::`mcols<-`(built, value = md) out <- exec( methods::new, cls, @@ -730,8 +731,7 @@ type = c("data.frame", "GRanges"), signalCutoff = 0.025, minPurity = NULL, - raw = FALSE, - ... + raw = FALSE ) { tl <- .fmrPartsTopLoci(parts) # raw = TRUE returns the stored canonical table verbatim: every variant, @@ -748,7 +748,7 @@ } # @noRd -.fmrRowPip <- function(parts, ...) { +.fmrRowPip <- function(parts) { tl <- .fmrPartsTopLoci(parts) if (nrow(tl) == 0L || !is_in("pip", names(tl))) { return(numeric(0)) @@ -757,21 +757,22 @@ } # @noRd -.fmrRowMarginalEffects <- function(parts, maxPval = NULL, ...) { +.fmrRowMarginalEffects <- function(parts, maxPval = NULL) { tl <- .fmrPartsTopLoci(parts) if (nrow(tl) == 0L) { return(.projectMarginalView(tl)) } - out <- .projectMarginalView(tl) - if (!is.null(maxPval) && nrow(out) > 0L) { - keep <- !is.na(out$p) & out$p <= maxPval - out <- filter(out, keep) + allRows <- .projectMarginalView(tl) + out <- if (is.null(maxPval) || nrow(allRows) == 0L) { + allRows + } else { + filter(allRows, !is.na(.data$p) & .data$p <= maxPval) } out } # @noRd -.fmrRowCs <- function(parts, coverage = 0.95, minPurity = NULL, ...) { +.fmrRowCs <- function(parts, coverage = 0.95, minPurity = NULL) { tl <- .fmrPartsTopLoci(parts) if (nrow(tl) == 0L) { return(.projectPosteriorView(tl)) @@ -783,51 +784,53 @@ if (length(csCol) == 0L) { return(.projectPosteriorView(slice(tl, 0))) } - keep <- !is.na(tl[[csCol[1L]]]) & + inCs <- !is.na(tl[[csCol[1L]]]) & str_length(tl[[csCol[1L]]]) > 0L & !str_detect(tl[[csCol[1L]]], "_0$") # Independent purity filter (min.abs.corr), orthogonal to `coverage`: drop # CS members whose credible set at THIS coverage is below `minPurity`. - if (!is.null(minPurity)) { - purCol <- str_c(csCol[1L], "_purity") - if (is_in(purCol, names(tl))) { - pur <- as.numeric(tl[[purCol]]) - keep <- keep & !is.na(pur) & pur >= minPurity - } else { - msg <- glue( - "getCs: no purity column '{purCol}' for coverage ", - "{coverage}; minPurity filter skipped." - ) - warn(msg) - } + purCol <- str_c(csCol[1L], "_purity") + hasPurity <- is_in(purCol, names(tl)) + if (!is.null(minPurity) && !hasPurity) { + msg <- glue( + "getCs: no purity column '{purCol}' for coverage ", + "{coverage}; minPurity filter skipped." + ) + warn(msg) + } + keep <- if (is.null(minPurity) || !hasPurity) { + inCs + } else { + pur <- as.numeric(tl[[purCol]]) + inCs & !is.na(pur) & pur >= minPurity } .projectPosteriorView(tl[keep, , drop = FALSE]) } # @noRd -.fmrRowLbf <- function(parts, ...) { +.fmrRowLbf <- function(parts) { lbf <- .asLbfMatrix(getSusieFit(parts)) vids <- .fmrPartsVariantIds(parts) if (is.null(lbf) || ncol(lbf) != length(vids)) { return(tibble(variant_id = character(0))) } - w <- as_tibble(t(as.matrix(lbf)), .name_repair = "minimal") - names(w) <- str_c("lbf_L", seq_len(ncol(w))) + wide <- as_tibble(t(as.matrix(lbf)), .name_repair = "minimal") + w <- `names<-`(wide, str_c("lbf_L", seq_len(ncol(wide)))) bind_cols(tibble(variant_id = as.character(vids)), w) } # @noRd -.fmrRowCredibleSetSummary <- function(parts, coverage = 0.95, ...) { +.fmrRowCredibleSetSummary <- function(parts, coverage = 0.95) { .csSummaryFit(.fmrPartsTopLoci(parts), getSusieFit(parts), coverage) } # @noRd -.fmrRowFsusieCredibleBand <- function(parts, ...) { +.fmrRowFsusieCredibleBand <- function(parts) { .fsusieCredibleBandFit(getSusieFit(parts)) } # @noRd -.fmrRowFsusieAffectedRegions <- function(parts, ...) { +.fmrRowFsusieAffectedRegions <- function(parts) { .fsusieAffectedRegionsFit( getSusieFit(parts), topLoci = .fmrPartsTopLoci(parts) @@ -835,7 +838,7 @@ } # @noRd -.fmrRowResolveWeights <- function(parts, ...) { +.fmrRowResolveWeights <- function(parts) { empty <- list(variantIds = character(0), weights = numeric(0)) # The topLoci posterior view projects the effect to `beta`; use it as the # per-variant weight, aligned with variant_id. @@ -882,14 +885,14 @@ # The weight vector aligned to the row's variant ids -- what resolveWeights # produced from a TwasWeightsRow. # @noRd -.twrRowResolveWeights <- function(parts, ...) { +.twrRowResolveWeights <- function(parts) { empty <- list(variantIds = character(0), weights = numeric(0)) vids <- .twrPartsVariantIds(parts) - w <- getWeights(parts) - if (length(vids) == 0L || is.null(w)) { + raw <- getWeights(parts) + if (length(vids) == 0L || is.null(raw)) { return(empty) } - w <- as.numeric(w) + w <- as.numeric(raw) if (length(w) != length(vids)) { return(empty) } @@ -914,11 +917,11 @@ # The per-variant weight vector of one row, whichever weight source it came # from. # @noRd -.rowResolveWeights <- function(parts, ...) { +.rowResolveWeights <- function(parts) { if (methods::is(parts, "TwasWeightsRow")) { - return(.twrRowResolveWeights(parts, ...)) + return(.twrRowResolveWeights(parts)) } - .fmrRowResolveWeights(parts, ...) + .fmrRowResolveWeights(parts) } # The cross-validated / per-method fits of one row, or NULL for a @@ -1076,10 +1079,9 @@ # @noRd .rtlExtraSlots <- function(parts, fn) { own <- setdiff(.rtlOwnSlots(parts[[1L]]), "ldSketch") - out <- list() - if (is_in("qcInfo", own)) { - out$qcInfo <- .ssCombineQcInfo(parts, fn) - } + out <- compact(list( + qcInfo = if (is_in("qcInfo", own)) .ssCombineQcInfo(parts, fn) + )) unknown <- setdiff(own, names(out)) if (length(unknown) > 0L) { cls <- class(parts[[1L]])[[1L]] @@ -1163,9 +1165,10 @@ abort(msg) } .ssCheckQcOptions(populated, fn) - out <- getQcInfo(populated[[1L]]) - out$entryAudit <- list_flatten(map(parts, .ssEntryAudit)) - out + list_assign( + getQcInfo(populated[[1L]]), + entryAudit = list_flatten(map(parts, .ssEntryAudit)) + ) } # @noRd @@ -1226,9 +1229,11 @@ } handles <- map(sketches, .ldSketchHandle) .ssCheckSameSource(handles, fn) - handle <- handles[[1L]] - handle@snpInfo <- .ssUnionSnpInfo(handles) - handle@chromPaths <- .ssUnionChromPaths(handles, fn) + handle <- methods::initialize( + handles[[1L]], + snpInfo = .ssUnionSnpInfo(handles), + chromPaths = .ssUnionChromPaths(handles, fn) + ) .asLdSketch(handle) } @@ -1239,22 +1244,39 @@ # two different files means the parts are not the same panel after all. # @noRd .ssUnionChromPaths <- function(handles, fn) { - out <- character(0) - for (h in handles) { - cp <- h@chromPaths - for (ch in names(cp)) { - if (is_in(ch, names(out)) && !identical(out[[ch]], cp[[ch]])) { - msg <- glue( - "{fn}: chromosome '{ch}' maps to two different genotype ", - "files across the inputs, so their LD sketches cannot ", - "be unioned." - ) - abort(msg) - } - out[[ch]] <- cp[[ch]] - } + combined <- .ssConcatChr(map(handles, .ssHandleChromPaths)) + byChrom <- split(unname(combined), names(combined)) + walk2(names(byChrom), byChrom, .ssCheckOneFilePerChrom, fn = fn) + # Every chromosome agrees, so the first mapping stands for all of them. + combined[!duplicated(names(combined))] +} + +# @noRd +.ssHandleChromPaths <- function(h) { + h@chromPaths +} + +# @noRd +.ssConcatChr <- function(pieces) { + if (length(pieces) == 0L) { + return(character(0)) } - out + list_c(pieces) +} + +# A chromosome resolving to two different files means the inputs are not the +# same panel, so their sketches cannot be unioned. +# @noRd +.ssCheckOneFilePerChrom <- function(ch, paths, fn) { + if (n_distinct(paths) <= 1L) { + return(invisible(NULL)) + } + msg <- glue( + "{fn}: chromosome '{ch}' maps to two different genotype ", + "files across the inputs, so their LD sketches cannot ", + "be unioned." + ) + abort(msg) } # Every panel must read from the same file(s): the union keeps the first @@ -1296,10 +1318,17 @@ # @noRd .ssUnionSnpInfo <- function(handles) { first <- getSnpInfo(handles[[1L]]) - si <- list_rbind(map(handles, .ssHandleSnpInfo)) - if (nrow(si) > 0L && all(is_in(c("SNP", "CHR", "BP"), names(si)))) { - si <- si[!duplicated(si$SNP), , drop = FALSE] - si <- si[order(canonChrom(si$CHR), as.integer(si$BP)), , drop = FALSE] + combined <- list_rbind(map(handles, .ssHandleSnpInfo)) + keyed <- all(is_in(c("SNP", "CHR", "BP"), names(combined))) + si <- if (nrow(combined) > 0L && keyed) { + deduped <- combined[!duplicated(combined$SNP), , drop = FALSE] + deduped[ + order(canonChrom(deduped$CHR), as.integer(deduped$BP)), + , + drop = FALSE + ] + } else { + combined } if (inherits(first, "tbl_df")) si else as.data.frame(si) } diff --git a/R/twasWeights.R b/R/twasWeights.R index 8d7a4dfd..706f9bee 100644 --- a/R/twasWeights.R +++ b/R/twasWeights.R @@ -46,25 +46,23 @@ setClass( # region/traitPos provenance, joint* column types, tuple uniqueness, and the # optional ldSketch. Returns TRUE or a character vector of error messages. # @noRd +#' @importFrom checkmate makeAssertCollection assertNames .validateTwasWeights <- function(object) { - errors <- .twasValidateRequiredCols(object) - if (length(errors) == 0L) { - errors <- .twasValidateColumns(object) - } - errors <- c(errors, .twasValidateLdSketch(object)) - if (length(errors) == 0L) TRUE else errors -} - -# Required key/entry columns must all be present. -# @noRd -.twasValidateRequiredCols <- function(object) { - required <- c("study", "context", "trait", "method") - missingCols <- setdiff(required, .tupleColumnNames(object)) - if (length(missingCols) > 0L) { - str_c("missing columns: ", str_flatten(missingCols, ", ")) - } else { - character() + coll <- makeAssertCollection() + assertNames( + .tupleColumnNames(object), + must.include = c("study", "context", "trait", "method"), + what = "colnames", + .var.name = "mcols", + add = coll + ) + # The checks below read those columns; running them on an object missing + # them reports the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } + coll$push(.twasValidateColumns(object)) + coll$getMessages() } # Column-level checks that run only once the required columns are present. @@ -127,14 +125,6 @@ setClass( } } -# The ldSketch slot's class union enforces its type, so there is nothing left -# for validity to check. -# @noRd -.twasValidateLdSketch <- function(object) { - character() -} - - # ============================================================================= #' @title Create a TwasWeights Collection Object @@ -169,6 +159,8 @@ setClass( #' tw <- TwasWeights(study = "s1", context = "brain", trait = "gene1", #' method = "susie", entry = list(twe)) #' tw +#' @importFrom checkmate assertCharacter assert checkList +#' @importFrom checkmate checkClass #' @export TwasWeights <- function( study, @@ -182,10 +174,24 @@ TwasWeights <- function( traitPos = NULL, ldSketch = NULL ) { + assertCharacter(study, any.missing = FALSE) + assertCharacter(context, any.missing = FALSE) + assertCharacter(trait, any.missing = FALSE) + assertCharacter(method, any.missing = FALSE) + # `entry` is documented as "List / SimpleList"; SimpleList is S4 and + # fails checkList, so this must be an or-combination. + assert( + checkList(entry), + checkClass(entry, "SimpleList"), + .var.name = "entry" + ) + assertCharacter(jointStudies, null.ok = TRUE) + assertCharacter(jointContexts, null.ok = TRUE) + assertCharacter(jointTraits, null.ok = TRUE) n <- .twasCheckRowLengths(study, context, trait, method, entry) entry <- map(entry, .asTwRowPayload) .checkRowPayloads(entry, "TwasWeightsRow", "TWAS-weight") - cols <- c( + baseCols <- c( list( study = as.character(study), context = as.character(context), @@ -194,23 +200,25 @@ TwasWeights <- function( ), .twRowPayloadCols(entry) ) - cols <- .twasAppendJointCols( - cols, + withJoint <- .twasAppendJointCols( + baseCols, jointStudies, jointContexts, jointTraits, n ) - cols <- .appendTraitPosCol(cols, traitPos, n) + cols <- .appendTraitPosCol(withJoint, traitPos, n) dfArgs <- c(cols, list(check.names = FALSE)) # Each entry's variants become one ELEMENT; its weights become that # element's inner mcols and the rest of its payload becomes outer mcols. # A multi-seqname entry is split into one element per chromosome, with its # metadata row replicated alongside. split <- .rtlSplitBySeqname(map(entry, rowVariants)) - grl <- GenomicRanges::GRangesList(split$entry) md <- exec(S4Vectors::DataFrame, !!!dfArgs) - mcols(grl) <- md[split$fromIdx, , drop = FALSE] + grl <- `mcols<-`( + GenomicRanges::GRangesList(split$entry), + value = md[split$fromIdx, , drop = FALSE] + ) obj <- new("TwasWeights", grl, ldSketch = .asLdSketch(ldSketch)) validObject(obj) obj @@ -262,23 +270,23 @@ TwasWeights <- function( jointTraits, n ) { - joint <- list( + supplied <- compact(list( jointStudies = jointStudies, jointContexts = jointContexts, jointTraits = jointTraits - ) - for (nm in names(joint)) { - val <- joint[[nm]] - if (is.null(val)) { - next - } - if (length(val) != n) { - msg <- glue("`{nm}` must have the same length as `study`.") - abort(msg) - } - cols[[nm]] <- as.character(val) + )) + walk2(names(supplied), supplied, .twasCheckJointColLength, n = n) + c(cols, map(supplied, as.character)) +} + +# Each joint-provenance column must be one value per row. +# @noRd +.twasCheckJointColLength <- function(nm, val, n) { + if (length(val) == n) { + return(invisible(NULL)) } - cols + msg <- glue("`{nm}` must have the same length as `study`.") + abort(msg) } #' @rdname getRegion @@ -563,9 +571,8 @@ setMethod("show", "TwasWeights", function(object) { str_to_upper(str_sub(target, 1, 1)), str_sub(target, 2) ) - x <- str_replace(x, "_weights$", str_c("_", target)) - x <- str_replace(x, "Weights$", cap) - x + str_replace(x, "_weights$", str_c("_", target)) |> + str_replace("Weights$", cap) } # Method name/impl/args lookup for TWAS weight methods. `fn` is the @@ -576,7 +583,8 @@ setMethod("show", "TwasWeights", function(object) { susie = list( fn = "susie_weights", impl = "susieWeights", - args = list(refine = FALSE, L = 10) + # No fitting defaults: susieWeights extracts from a supplied fit. + args = list() ), susieAsh = list( fn = "susie_ash_weights", @@ -659,7 +667,8 @@ setMethod("show", "TwasWeights", function(object) { mvsusie = list( fn = "mvsusie_weights", impl = "mvsusieWeights", - args = list(L = 10) + # No fitting defaults: mvsusieWeights extracts from a supplied fit. + args = list() ), mrmash = list( fn = "mrmash_weights", @@ -704,11 +713,15 @@ setMethod("show", "TwasWeights", function(object) { # @importFrom purrr map_chr set_names # @noRd .twasMethodLookup <- function(methods) { - methods <- .twasExpandPresets(methods) + expanded <- .twasExpandPresets(methods) # Accept full function names too by mapping them back to short names. fnToShort <- set_names(names(.twasMethodMap), map_chr(.twasMethodMap, "fn")) - methods <- map_chr(methods, .twasCanonicalShortName, fnToShort = fnToShort) - unknown <- setdiff(methods, names(.twasMethodMap)) + shortNames <- map_chr( + expanded, + .twasCanonicalShortName, + fnToShort = fnToShort + ) + unknown <- setdiff(shortNames, names(.twasMethodMap)) if (length(unknown) > 0) { msg <- glue( "unknown method token(s): {str_flatten(unknown, ', ')}. ", @@ -717,8 +730,8 @@ setMethod("show", "TwasWeights", function(object) { abort(msg) } # Track the impl name as an attr so dispatchers resolve snake_case -> impl. - entries <- map(methods, .twasMethodArgsWithImpl) - set_names(entries, map_chr(methods, .twasMethodFn)) + entries <- map(shortNames, .twasMethodArgsWithImpl) + set_names(entries, map_chr(shortNames, .twasMethodFn)) } # TRUE if `name` is a function visible in the search path or in namespace `ns`. @@ -766,7 +779,7 @@ setMethod("show", "TwasWeights", function(object) { if (!all(is_in(c("Sample", "Fold"), names(df)))) { abort("samplePartition must have columns `Sample` and `Fold`.") } - df$Sample <- as.character(df$Sample) + df <- mutate(df, Sample = as.character(.data$Sample)) dup <- unique(df$Sample[duplicated(df$Sample)]) if (length(dup) > 0L) { msg <- glue( @@ -909,129 +922,205 @@ setMethod("show", "TwasWeights", function(object) { XColnames = NULL, YColnames = NULL ) { - full <- matrix(0, nrow = nColsX, ncol = nColsY) - if (!is.null(XColnames)) { - rownames(full) <- XColnames - } - if (!is.null(YColnames)) { - colnames(full) <- YColnames - } + full <- matrix( + 0, + nrow = nColsX, + ncol = nColsY, + dimnames = list(XColnames, YColnames) + ) full[validColumns, ] <- weightsMatrix full } +# The canonical fine-mapping token behind a weight-method name, accepting the +# token itself (`susieInf`), its camelCase weight function (`susieInfWeights`) +# and its snake_case registry key (`susie_inf_weights`). Stripping the suffix +# is not enough on its own: that turns `susie_inf_weights` into `susie_inf`, +# which is not the registry's token. +# @noRd +.twasFmTokenFor <- function(method) { + methodKeys <- map_chr(.twasFineMappingMethodAdapters, "methodKey") + hit <- names(methodKeys)[methodKeys == method] + if (length(hit) == 1L) { + return(hit) + } + bare <- str_remove(method, "(_weights|Weights)$") + if (is_in(bare, names(.twasFineMappingMethodAdapters))) { + return(bare) + } + NA_character_ +} + +# The `weightMethods` name under which `token` was supplied, or NA when it was +# not requested. Every lookup keyed by method name goes through this, so one +# spelling cannot resolve where another silently misses. +# @noRd +.twasMethodNameFor <- function(weightMethods, token) { + adapter <- .twasFineMappingMethodAdapters[[token]] + spellings <- c(adapter$methodKey, adapter$weightFn, token) + hit <- spellings[is_in(spellings, names(weightMethods))] + if (length(hit) == 0L) { + return(NA_character_) + } + hit[[1]] +} + +# The arguments supplied for `token`, under whichever of its spellings the +# caller used as the `weightMethods` name. +# @noRd +.twasMethodArgsFor <- function(weightMethods, token) { + nm <- .twasMethodNameFor(weightMethods, token) + if (is.na(nm)) { + return(NULL) + } + weightMethods[[nm]] +} + +# The per-fold fits supplied for `token`, under any of its spellings. The gate +# and `.twasFoldFit()` must agree on this, or the gate can refuse fits the +# fold lookup would have found. +# @noRd +.twasFoldFitsFor <- function(fittedModelsCv, token) { + if (is.null(fittedModelsCv)) { + return(NULL) + } + adapter <- .twasFineMappingMethodAdapters[[token]] + spellings <- c(token, adapter$methodKey, adapter$weightFn) + hit <- spellings[is_in(spellings, names(fittedModelsCv))] + if (length(hit) == 0L) { + return(NULL) + } + fittedModelsCv[[hit[[1]]]] +} + +# The SuSiE-family methods requested in `weightMethods`, as canonical tokens. +# @noRd +.twasSusieTokensRequested <- function(weightMethods) { + if (is.null(weightMethods) || length(weightMethods) == 0L) { + return(character(0)) + } + keys <- if (is.character(weightMethods)) { + weightMethods + } else { + names(weightMethods) + } + tokens <- map_chr(keys, .twasFmTokenFor) + unique(tokens[!is.na(tokens)]) +} + +# Fail before any fitting work when a SuSiE-family method is requested without +# the fit it needs. These wrappers extract weights from an existing fit and +# never fine-map, so the run is already doomed; checking here reports the +# missing fit by name instead of surfacing it from inside the per-fold map. +# `available(token)` answers "is this token's fit present?" for the caller's +# own supply channel. +# @noRd +.twasRequireSusieFits <- function(weightMethods, available, fnLabel, how) { + tokens <- .twasSusieTokensRequested(weightMethods) + if (length(tokens) == 0L) { + return(invisible(NULL)) + } + missing <- tokens[!map_lgl(tokens, available)] + if (length(missing) == 0L) { + return(invisible(NULL)) + } + missingStr <- str_flatten(missing, ", ") + msg <- glue( + "{fnLabel}: method(s) {missingStr} extract weights from an existing ", + "fine-mapping fit and never run fine-mapping themselves, but no fit ", + "was supplied for them. {how}" + ) + abort(msg) +} + # Resolve the incoming susie / susieInf fits for the weight run: prefer a fit # carried on the method args, else one from `fittedModels`, tagging each with # its fine-mapping class. Returns list(susieFit, susieInfFit, hasSusie, -# hasSusieInf). +# hasSusieInf, susieName, susieInfName) -- the names being the spellings the +# caller actually used, so the write-back lands where the fitter will look. # @noRd .twasResolveSusieFits <- function(weightMethods, fittedModels) { - hasSusie <- !is.null(weightMethods[["susie_weights"]]) - hasSusieInf <- !is.null(weightMethods[["susie_inf_weights"]]) - susieFit <- if (hasSusie) { - weightMethods[["susie_weights"]][["susieFit"]] + susieName <- .twasMethodNameFor(weightMethods, "susie") + susieInfName <- .twasMethodNameFor(weightMethods, "susieInf") + hasSusie <- !is.na(susieName) + hasSusieInf <- !is.na(susieInfName) + argSusie <- if (hasSusie) { + weightMethods[[susieName]][["susieFit"]] } else { NULL } - susieInfFit <- if (hasSusieInf) { - weightMethods[["susie_inf_weights"]][["susieInfFit"]] + argSusieInf <- if (hasSusieInf) { + weightMethods[[susieInfName]][["susieInfFit"]] } else { NULL } - if (is.null(susieFit)) { - susieFit <- fittedModels[["susie"]] - } - if (is.null(susieInfFit)) { - susieInfFit <- fittedModels[["susieInf"]] - } - if (!is.null(susieFit)) { - susieFit <- .setFinemappingFitClass(susieFit, "susie") + # A fit the caller passed in the method arguments wins; otherwise the + # pipeline's already-fitted model, if it produced one. + susieRaw <- argSusie %||% fittedModels[["susie"]] + susieInfRaw <- argSusieInf %||% fittedModels[["susieInf"]] + susieFit <- if (is.null(susieRaw)) { + NULL + } else { + .setFinemappingFitClass(susieRaw, "susie") } - if (!is.null(susieInfFit)) { - susieInfFit <- .setFinemappingFitClass(susieInfFit, "susieInf") + susieInfFit <- if (is.null(susieInfRaw)) { + NULL + } else { + .setFinemappingFitClass(susieInfRaw, "susieInf") } list( susieFit = susieFit, susieInfFit = susieInfFit, hasSusie = hasSusie, - hasSusieInf = hasSusieInf + hasSusieInf = hasSusieInf, + susieName = susieName, + susieInfName = susieInfName ) } -# Chained susieInf -> susie fit for the single-outcome case where both methods -# are requested and no fit was supplied. Returns list(susieFit, susieInfFit). -# @noRd -.twasChainedSusieFit <- function(X, Y, weightMethods) { - fitArgNames <- c("susieFit", "susieInfFit", "retainFit") - susieArgs <- weightMethods[["susie_weights"]][setdiff( - names(weightMethods[["susie_weights"]]), - fitArgNames - )] - # modifyList (not list_modify): a NULL user arg should UNSET the key here. - susieInfArgs <- modifyList( - list(convergence_method = "pip"), - weightMethods[["susie_inf_weights"]][setdiff( - names(weightMethods[["susie_inf_weights"]]), - fitArgNames - )] - ) - fits <- fitSusieInfThenSusie( - X, - Y[, 1], - args = susieArgs, - susieInfArgs = susieInfArgs, - fittedModels = list(susie = NULL, susieInf = NULL) - ) - list(susieFit = fits[["susie"]], susieInfFit = fits[["susieInf"]]) -} - -# Write the resolved susie / susieInf fits back onto the method args, deriving -# the susie args from a susieInf fit when susie was requested without its own. +# Write the resolved susie / susieInf fits back onto the method args. Deriving +# susie's arguments from a susieInf fit belongs to fine-mapping, not here: it +# prepares a susie *fit* (model_init, unmappable_effects), which +# `susieWeights()` neither accepts nor runs. # @noRd .twasWriteBackSusieFits <- function(weightMethods, r) { - if (!is.null(r$susieInfFit) && r$hasSusieInf) { - weightMethods[["susie_inf_weights"]][["susieInfFit"]] <- r$susieInfFit - } - if (!is.null(r$susieFit) && r$hasSusie) { - weightMethods[["susie_weights"]][["susieFit"]] <- r$susieFit - } - if ( - r$hasSusie && - is.null(weightMethods[["susie_weights"]][["susieFit"]]) && - !is.null(r$susieInfFit) - ) { - weightMethods[["susie_weights"]] <- prepareSusieFromInfArgs( - weightMethods[["susie_weights"]], + withInf <- if (!is.null(r$susieInfFit) && r$hasSusieInf) { + .twasSetMethodArg( + weightMethods, + r$susieInfName, + "susieInfFit", r$susieInfFit ) + } else { + weightMethods + } + if (is.null(r$susieFit) || !r$hasSusie) { + return(withInf) } - weightMethods + .twasSetMethodArg(withInf, r$susieName, "susieFit", r$susieFit) } -.prepareSusieWeightMethods <- function( - X, - Y, - weightMethods, - fittedModels = NULL -) { - if (is.vector(Y)) { - Y <- matrix(Y, ncol = 1) - } +# One method's argument list with `arg` set, leaving every other method and +# every other argument of that method untouched. +# @noRd +.twasSetMethodArg <- function(weightMethods, method, arg, value) { + updated <- list_assign( + weightMethods[[method]], + !!!set_names(list(value), arg) + ) + list_assign(weightMethods, !!!set_names(list(updated), method)) +} + +# Resolve the supplied susie / susieInf fits onto the method args. This never +# fine-maps: the SuSiE-family weight methods extract from a fit that +# fineMappingPipeline() produced, and a missing one is an error, not a cue to +# fit here. +# @noRd +.prepareSusieWeightMethods <- function(weightMethods, fittedModels = NULL) { if (is.null(fittedModels)) { fittedModels <- list() } r <- .twasResolveSusieFits(weightMethods, fittedModels) - if ( - r$hasSusie && - r$hasSusieInf && - ncol(Y) == 1 && - is.null(r$susieFit) && - is.null(r$susieInfFit) - ) { - fits <- .twasChainedSusieFit(X, Y, weightMethods) - r$susieFit <- fits$susieFit - r$susieInfFit <- fits$susieInfFit - } .twasWriteBackSusieFits(weightMethods, r) } @@ -1040,60 +1129,132 @@ setMethod("show", "TwasWeights", function(object) { # the canonical method key; captured fits keep the full method name. # @noRd .weightFitFold <- function(Xtr, Ytr, j, ctx) { - foldWeightMethods <- .prepareSusieWeightMethods(Xtr, Ytr, ctx$weightMethods) - weights <- list() - fits <- list() - for (method in names(foldWeightMethods)) { - res <- .twasFoldMethodWeights( - method, - foldWeightMethods[[method]], - Xtr, - Ytr, - j, - ctx - ) - weights[[res$mk]] <- res$W - fits[[method]] <- res$fit - } - list(weights = weights, fits = fits) + foldWeightMethods <- .prepareSusieWeightMethods(ctx$weightMethods) + methods <- names(foldWeightMethods) + results <- map( + methods, + .twasFoldMethodWeightsAt, + foldWeightMethods = foldWeightMethods, + Xtr = Xtr, + Ytr = Ytr, + j = j, + ctx = ctx + ) + # Weights are keyed by the canonical method key, captured fits by the + # full method name; a later method wins a shared key, as the keyed + # assignment did. + weights <- set_names(map(results, "W"), map_chr(results, "mk")) + list( + weights = weights[!duplicated(names(weights), fromLast = TRUE)], + fits = set_names(map(results, "fit"), methods) + ) +} + +# @noRd +.twasFoldMethodWeightsAt <- function( + method, + foldWeightMethods, + Xtr, + Ytr, + j, + ctx +) { + .twasFoldMethodWeights( + method, + foldWeightMethods[[method]], + Xtr, + Ytr, + j, + ctx + ) } # Per-fold priors bound to a multivariate fitter's camelCase args (mr.mash # data-driven matrices / mvsusie reweighted mixture prior for fold `j`). # @noRd -.twasFoldPriors <- function(args, method, j, cvArgs) { - if ( - !is.null(cvArgs$data_driven_priorMatricesCv) && - is_in(method, c("mrmash_weights", "mrmashWeights")) - ) { - args$dataDrivenPriorMatrices <- cvArgs$data_driven_priorMatricesCv[[j]] +.twasFoldPriors <- function( + args, + method, + j, + dataDrivenPriorMatricesCv, + reweightedMixturePriorCv +) { + list_assign( + args, + !!!compact(list( + dataDrivenPriorMatrices = if ( + !is.null(dataDrivenPriorMatricesCv) && + is_in(method, c("mrmash_weights", "mrmashWeights")) + ) { + dataDrivenPriorMatricesCv[[j]] + }, + prior_variance = if ( + !is.null(reweightedMixturePriorCv) && + is_in(method, c("mvsusie_weights", "mvsusieWeights")) + ) { + reweightedMixturePriorCv[[j]] + } + )) + ) +} + +# Inject the fold's own fine-mapping fit for a SuSiE-family method. Those +# weight wrappers extract from a supplied fit and never fine-map, so a fold +# can only be scored if fineMappingPipeline's CV retained that fold's fit +# (`fittedModelsCv`, keyed method -> fold_). +# @noRd +.twasFoldFit <- function(args, method, j, fittedModelsCv) { + if (is.null(fittedModelsCv)) { + return(args) } - if ( - !is.null(cvArgs$reweightedMixturePriorCv) && - is_in(method, c("mvsusie_weights", "mvsusieWeights")) - ) { - args$prior_variance <- cvArgs$reweightedMixturePriorCv[[j]] + mk <- .twasFmTokenFor(method) + if (is.na(mk)) { + return(args) } - args + adapter <- .twasFineMappingMethodAdapters[[mk]] + perFold <- .twasFoldFitsFor(fittedModelsCv, mk) + if (is.null(perFold)) { + return(args) + } + key <- str_c("fold_", j) + fit <- if (is_in(key, names(perFold))) { + perFold[[key]] + } else if (length(perFold) >= j) { + perFold[[j]] + } else { + NULL + } + if (is.null(fit)) { + return(args) + } + list_assign(args, !!!set_names(list(fit), adapter$fitArg)) } # One fold's multivariate weight fit; returns list(W, fit). # @noRd .twasFoldMultivariate <- function(method, fnName, args, Xtr, Ytr, j, ctx) { - args <- .twasFoldPriors(args, method, j, ctx$cvArgs) - if (isTRUE(ctx$retainFits) && is_in("retainFit", names(formals(fnName)))) { - args$retainFit <- TRUE - } - callArgs <- c(list(X = Xtr, Y = Ytr), args) + withPriors <- .twasFoldPriors( + args, + method, + j, + ctx$dataDrivenPriorMatricesCv, + ctx$reweightedMixturePriorCv + ) + retaining <- isTRUE(ctx$retainFits) && + is_in("retainFit", names(formals(fnName))) + fitArgs <- list_assign( + withPriors, + !!!compact(list(retainFit = if (retaining) TRUE)) + ) + callArgs <- .twasWeightCallArgs(fnName, list(X = Xtr, Y = Ytr), fitArgs) W <- if (ctx$verbose < 2) { .quietEval(exec(fnName, !!!callArgs)) } else { exec(fnName, !!!callArgs) } capturedFit <- attr(W, "fit") - attr(W, "fit") <- NULL - rownames(W) <- colnames(Xtr) - list(W = W, fit = capturedFit) + bare <- `attr<-`(W, "fit", NULL) + list(W = `rownames<-`(bare, colnames(Xtr)), fit = capturedFit) } # One fold's univariate weight fit (per Y column, column-bound); no fit kept. @@ -1108,8 +1269,7 @@ setMethod("show", "TwasWeights", function(object) { Ytr = Ytr, args = args ) - W <- exec(cbind, !!!Wcols) - rownames(W) <- colnames(Xtr) + W <- `rownames<-`(exec(cbind, !!!Wcols), colnames(Xtr)) list(W = W, fit = NULL) } @@ -1118,6 +1278,7 @@ setMethod("show", "TwasWeights", function(object) { # @noRd .twasFoldMethodWeights <- function(method, args, Xtr, Ytr, j, ctx) { fnName <- .resolveMethodFunction(method, args) + args <- .twasFoldFit(args, method, j, ctx$fittedModelsCv) mk <- str_remove(method, "_weights$|Weights$") fit <- if (is_in(method, ctx$multivariateWeightMethods)) { .twasFoldMultivariate(method, fnName, args, Xtr, Ytr, j, ctx) @@ -1170,7 +1331,16 @@ setMethod("show", "TwasWeights", function(object) { #' seed is scoped to the call, so the session RNG is left as it was found. #' \code{NULL} (default) does not seed at all and uses the historical #' parallel default. -#' @param ... Additional arguments forwarded to the per-method weight learners. +#' @param fittedModelsCv Optional per-fold fine-mapping fits, as +#' \code{method -> fold_ -> fit}, from a \code{fineMappingPipeline()} +#' run with \code{cvFolds > 1}. SuSiE-family weight wrappers extract from a +#' supplied fit and never fine-map, so this is what makes cross-validating +#' them possible; it must have been produced on \code{samplePartitions}, +#' since a fit trained on different folds would leak held-out samples. +#' @param dataDrivenPriorMatricesCv Optional list, one element per fold, of +#' data-driven prior matrices for the mr.mash learner. +#' @param reweightedMixturePriorCv Optional list, one element per fold, of +#' reweighted mixture priors for the mvSuSiE learner. #' @return A list with the following components: #' \itemize{ #' \item `samplePartition`: A dataframe showing the sample partitioning used @@ -1196,14 +1366,19 @@ setMethod("show", "TwasWeights", function(object) { #' process. #' } #' @importFrom purrr map -#' @importFrom BiocParallel bplapply bpworkers MulticoreParam +#' @importFrom BiocParallel bplapply multicoreWorkers MulticoreParam #' @importFrom quadprog solve.QP #' @examples #' data(multiTraitData) #' X <- multiTraitData$X[, 1:80] #' Y <- multiTraitData$Y +#' # A cross-validated method is refit on each fold's training rows. The +#' # SuSiE family never fine-maps, so it needs each fold's own fit, passed +#' # as `fittedModelsCv` from a fineMappingPipeline() run with cvFolds > 1. #' twasWeightsCv(X, Y[, 1, drop = FALSE], fold = 3, -#' weightMethods = list(susie_weights = list())) +#' weightMethods = list(lasso_weights = list())) +#' @importFrom checkmate assertDataFrame assertNumber assertInt +#' @importFrom checkmate assertFlag assertCount #' @export twasWeightsCv <- function( X, @@ -1217,11 +1392,37 @@ twasWeightsCv <- function( verbose = 1, retainFits = FALSE, seed = NULL, - ... + dataDrivenPriorMatricesCv = NULL, + reweightedMixturePriorCv = NULL, + fittedModelsCv = NULL ) { - p <- as.list(environment()) - p$cvArgs <- list(...) - .twasWeightsCvImpl(p) + # X / Y / fold are asserted downstream in .cvPrepareData; these are the + # arguments nothing else checks. + assertDataFrame(samplePartitions, null.ok = TRUE) + # NOT assertCount: `Inf` is the "no cap" sentinel (jointEngine passes it + # when cfg$maxCvVariants is unset), and .cvSubsampleVariants relies on + # `ncol(X) <= maxNumVariants` being FALSE for it. + assertNumber(maxNumVariants, lower = 1, null.ok = TRUE) + assertInt(numThreads) + assertCount(verbose) + assertFlag(retainFits) + assertInt(seed, null.ok = TRUE) + .twasWeightsCvImpl( + X = X, + Y = Y, + fold = fold, + samplePartitions = samplePartitions, + weightMethods = weightMethods, + maxNumVariants = maxNumVariants, + variantsToKeep = variantsToKeep, + numThreads = numThreads, + verbose = verbose, + retainFits = retainFits, + seed = seed, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + reweightedMixturePriorCv = reweightedMixturePriorCv, + fittedModelsCv = fittedModelsCv + ) } # Multivariate weight methods (snake + camel) fit on the whole Y for a fold; @@ -1236,16 +1437,89 @@ twasWeightsCv <- function( "mvsusieWeights" ) -# twasWeightsCv worker. `p` is the captured public arguments plus `cvArgs` -# (the `...`). With no weightMethods the caller only wants the fold partition. +# Refuse per-fold fits that were not produced on the folds being scored. A +# fit trained on a different split has seen some of this split's held-out +# samples, so its out-of-fold predictions are contaminated and the CV metrics +# come out optimistic -- silently. Fits carry the producer's partition +# fingerprint (see .cvPartitionKey); anything unstamped is refused too, since +# it cannot be shown to match. +# @noRd +.twasCheckFoldFitPartition <- function(fittedModelsCv, samplePartitions) { + if (is.null(fittedModelsCv) || length(fittedModelsCv) == 0L) { + return(invisible(NULL)) + } + if (is.null(samplePartitions)) { + msg <- glue( + "twasWeightsCv: `fittedModelsCv` needs the fold partition those ", + "fits were trained on. Pass the fine-mapping CV's ", + "`samplePartition` as `samplePartitions`; a freshly drawn ", + "partition would score each fold with a fit that saw its ", + "held-out samples." + ) + abort(msg) + } + want <- .cvPartitionKey(samplePartitions) + for (m in names(fittedModelsCv)) { + got <- attr(fittedModelsCv[[m]], "partitionKey") + if (is.null(got)) { + msg <- glue( + "twasWeightsCv: the per-fold fits for '{m}' carry no ", + "partition fingerprint, so they cannot be shown to match ", + "`samplePartitions`. Take them from a fineMappingPipeline() ", + "run with cvFolds > 1." + ) + abort(msg) + } + if (!identical(got, want)) { + msg <- glue( + "twasWeightsCv: the per-fold fits for '{m}' were trained on ", + "a different fold partition than the one being scored. Use ", + "the fine-mapping CV's own `samplePartition`." + ) + abort(msg) + } + } + invisible(NULL) +} + +# twasWeightsCv worker. With no weightMethods the caller only wants the fold +# partition. # @noRd -.twasWeightsCvImpl <- function(p) { - weightMethods <- if (is.character(p$weightMethods)) { - .twasMethodLookup(p$weightMethods) +.twasWeightsCvImpl <- function( + X, + Y, + fold, + samplePartitions, + weightMethods, + maxNumVariants, + variantsToKeep, + numThreads, + verbose, + retainFits, + seed, + dataDrivenPriorMatricesCv, + reweightedMixturePriorCv, + fittedModelsCv +) { + .twasCheckFoldFitPartition(fittedModelsCv, samplePartitions) + .twasRequireSusieFits( + weightMethods, + available = function(tk) { + !is.null(.twasFoldFitsFor(fittedModelsCv, tk)) + }, + fnLabel = "twasWeightsCv", + how = str_c( + "Cross-validation refits on each fold, so it needs that fold's ", + "own fit: pass `fittedModelsCv = list( = )` ", + "from a fineMappingPipeline() run with cvFolds > 1." + ) + ) + weightMethods <- if (is.character(weightMethods)) { + .twasMethodLookup(weightMethods) } else { - p$weightMethods + weightMethods } - if (is.null(p$seed) && !exists(".Random.seed") && p$verbose >= 1) { + if (is.null(seed) && !exists(".Random.seed") && verbose >= 1) { inform(str_c( "! No seed set. Pass `seed=` or call ", "set.seed() for reproducibility." @@ -1253,40 +1527,42 @@ twasWeightsCv <- function( } if (is.null(weightMethods)) { res <- .crossValidateWeights( - p$X, - p$Y, - fold = p$fold, - samplePartitions = p$samplePartitions, + X, + Y, + fold = fold, + samplePartitions = samplePartitions, fitFold = .cvNoopFitFold, - numThreads = p$numThreads, - maxNumVariants = p$maxNumVariants, - variantsToKeep = p$variantsToKeep, - retainFits = p$retainFits, - verbose = p$verbose, - seed = p$seed + numThreads = numThreads, + maxNumVariants = maxNumVariants, + variantsToKeep = variantsToKeep, + retainFits = retainFits, + verbose = verbose, + seed = seed ) return(list(samplePartition = res$samplePartition)) } cvFitCtx <- list( weightMethods = weightMethods, multivariateWeightMethods = .twasCvMultivariateMethods, - cvArgs = p$cvArgs, - retainFits = p$retainFits, - verbose = p$verbose + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + reweightedMixturePriorCv = reweightedMixturePriorCv, + fittedModelsCv = fittedModelsCv, + retainFits = retainFits, + verbose = verbose ) .crossValidateWeights( - p$X, - p$Y, - fold = p$fold, - samplePartitions = p$samplePartitions, + X, + Y, + fold = fold, + samplePartitions = samplePartitions, fitFold = .weightFitFold, fitFoldCtx = cvFitCtx, - numThreads = p$numThreads, - maxNumVariants = p$maxNumVariants, - variantsToKeep = p$variantsToKeep, - retainFits = p$retainFits, - verbose = p$verbose, - seed = p$seed + numThreads = numThreads, + maxNumVariants = maxNumVariants, + variantsToKeep = variantsToKeep, + retainFits = retainFits, + verbose = verbose, + seed = seed ) } @@ -1298,20 +1574,19 @@ twasWeightsCv <- function( .computeMethodWeights <- function(methodName, weightMethods, ctx) { shortName <- str_remove(methodName, "_weights$") if (ctx$verbose >= 1) { - msg <- glue(" Fitting {shortName} ...") - inform(msg) + inform(glue(" Fitting {shortName} ...")) tic() } - args <- weightMethods[[methodName]] - fnName <- .resolveMethodFunction(methodName, args) - args <- .twasApplyRetainFit( - args, + userArgs <- weightMethods[[methodName]] + fnName <- .resolveMethodFunction(methodName, userArgs) + fitArgs <- .twasApplyRetainFit( + userArgs, fnName, ctx$retainFits, ctx$retainFitDetail ) - fit <- .twasFitWeightsMatrix(fnName, args, ctx, methodName) - result <- .embedWeights( + fit <- .twasFitWeightsMatrix(fnName, fitArgs, ctx, methodName) + embedded <- .embedWeights( fit$weights, ctx$validColumns, ncol(ctx$X), @@ -1319,14 +1594,15 @@ twasWeightsCv <- function( colnames(ctx$X), colnames(ctx$Y) ) - if (!is.null(fit$methodFit)) { - attr(result, "fit") <- fit$methodFit + result <- if (is.null(fit$methodFit)) { + embedded + } else { + `attr<-`(embedded, "fit", fit$methodFit) } if (ctx$verbose >= 1) { elapsed <- toc(quiet = TRUE) secs <- sprintf("%.1f", elapsed$toc - elapsed$tic) - msg <- glue(" Fitting {shortName} done in {secs}s") - inform(msg) + inform(glue(" Fitting {shortName} done in {secs}s")) } result } @@ -1352,15 +1628,23 @@ twasWeightsCv <- function( return(args) } fnFormals <- names(formals(fnName)) - if (is_in("retainFit", fnFormals)) { - args$retainFit <- TRUE - } else if (is_in("retain_fit", fnFormals)) { - args$retain_fit <- TRUE - } - if (is_in("fitDetail", fnFormals) && is.null(args$fitDetail)) { - args$fitDetail <- retainFitDetail - } - args + list_assign( + args, + !!!compact(list( + retainFit = if (is_in("retainFit", fnFormals)) TRUE, + retain_fit = if ( + !is_in("retainFit", fnFormals) && + is_in("retain_fit", fnFormals) + ) { + TRUE + }, + fitDetail = if ( + is_in("fitDetail", fnFormals) && is.null(args$fitDetail) + ) { + retainFitDetail + } + )) + ) } # Dispatch weight fitting to the multivariate or per-column univariate path; @@ -1377,15 +1661,21 @@ twasWeightsCv <- function( # Multivariate fit: one call producing the full variants x features matrix. # @noRd .twasFitMultivariate <- function(fnName, args, ctx) { - call <- c(list(X = ctx$Xfiltered, Y = ctx$Y), args) - weightsMatrix <- if (ctx$verbose < 2) { + call <- .twasWeightCallArgs( + fnName, + list(X = ctx$Xfiltered, Y = ctx$Y), + args + ) + fitted <- if (ctx$verbose < 2) { .quietEval(exec(fnName, !!!call)) } else { exec(fnName, !!!call) } - methodFit <- if (ctx$retainFits) attr(weightsMatrix, "fit") else NULL - if (nrow(weightsMatrix) != length(ctx$validColumns)) { - weightsMatrix <- weightsMatrix[names(ctx$validColumns), , drop = FALSE] + methodFit <- if (ctx$retainFits) attr(fitted, "fit") else NULL + weightsMatrix <- if (nrow(fitted) == length(ctx$validColumns)) { + fitted + } else { + fitted[names(ctx$validColumns), , drop = FALSE] } list(weights = weightsMatrix, methodFit = methodFit) } @@ -1394,24 +1684,45 @@ twasWeightsCv <- function( # weights matrix. # @noRd .twasFitUnivariate <- function(fnName, args, ctx) { - weightsMatrix <- matrix(0, nrow = ncol(ctx$Xfiltered), ncol = ncol(ctx$Y)) - methodFit <- NULL - for (k in seq_len(ncol(ctx$Y))) { - call <- c(list(X = ctx$Xfiltered, y = ctx$Y[, k]), args) - weightsVector <- if (ctx$verbose < 2) { - .quietEval(exec(fnName, !!!call)) - } else { - exec(fnName, !!!call) - } - if (ctx$retainFits && is.null(methodFit)) { - methodFit <- attr(weightsVector, "fit") - } - if (is.matrix(weightsVector)) { - weightsVector <- weightsVector[, k] - } - weightsMatrix[, k] <- weightsVector + columns <- map( + seq_len(ncol(ctx$Y)), + .twasUnivariateColumn, + fnName = fnName, + args = args, + ctx = ctx + ) + fits <- compact(map(columns, "fit")) + list( + weights = matrix( + unname(list_c(map(columns, "weights"))), + nrow = ncol(ctx$Xfiltered), + ncol = ncol(ctx$Y) + ), + # The first outcome that carries one defines the method fit, which is + # what "set it only while still NULL" produced. + methodFit = if (length(fits) == 0L) NULL else fits[[1L]] + ) +} + +# One outcome column's weights, plus the fit the method attached to them. A +# method that answers with a matrix is reporting every outcome at once, so +# this column's own slice is taken. +# @noRd +.twasUnivariateColumn <- function(k, fnName, args, ctx) { + call <- .twasWeightCallArgs( + fnName, + list(X = ctx$Xfiltered, y = ctx$Y[, k]), + args + ) + w <- if (ctx$verbose < 2) { + .quietEval(exec(fnName, !!!call)) + } else { + exec(fnName, !!!call) } - list(weights = weightsMatrix, methodFit = methodFit) + list( + weights = if (is.matrix(w)) w[, k] else w, + fit = if (ctx$retainFits) attr(w, "fit") else NULL + ) } # Assemble the (study, context, trait, method, entry) row vectors for the @@ -1455,7 +1766,7 @@ twasWeightsCv <- function( # @noRd .twasMethodRows <- function(m, wMat, variantIds, ctx) { fitVal <- attr(wMat, "fit") - attr(wMat, "fit") <- NULL + wMat <- `attr<-`(wMat, "fit", NULL) fits <- if (ctx$retainFits) fitVal else NULL shortMethod <- str_remove(m, "(_weights|Weights)$") nY <- ncol(ctx$Y) @@ -1511,7 +1822,12 @@ twasWeightsCv <- function( #' set to -1, the function uses all available cores. If set to 0 or 1, no #' parallel processing is performed. If set to 2 or more, parallel processing #' is enabled with that many threads. -#' @param fittedModels Optional named list of fitted SuSiE-family models. +#' @param fittedModels Named list of fitted SuSiE-family models, keyed by +#' token (\code{susie}, \code{susieInf}, \code{mvsusie}, \code{fsusie}). +#' Required whenever a SuSiE-family weight method is requested: those +#' methods extract weights from an existing fit and never fine-map, so a +#' missing fit is an error. Run \code{\link{fineMappingPipeline}} to +#' produce the fits. #' @param retainFits If TRUE, retain fitted model objects as attributes on #' returned weight matrices when supported by the weight method. #' @param verbose Integer controlling verbosity level: 0 = suppress all @@ -1543,13 +1859,19 @@ twasWeightsCv <- function( #' data(multiTraitData) #' X <- multiTraitData$X[, 1:80] #' Y <- multiTraitData$Y +#' # SuSiE-family methods extract weights from an existing fit and never +#' # fine-map themselves, so the fit is supplied via `fittedModels`. +#' fit <- susieR::susie(X, Y[, 1], L = 5) #' learnTwasWeights(X, Y[, 1, drop = FALSE], -#' weightMethods = list(susie_weights = list())) +#' weightMethods = list(susie_weights = list()), +#' fittedModels = list(susie = fit)) #' @export #' @importFrom purrr map exec #' @importFrom rlang !!! abort warn inform arg_match cnd_signal .data #' @importFrom glue glue #' @importFrom tictoc tic toc +#' @importFrom checkmate assertString assertInt assertFlag assertCount +#' @importFrom checkmate assert checkList checkCharacter learnTwasWeights <- function( X, Y, @@ -1567,21 +1889,50 @@ learnTwasWeights <- function( verbose = 1, seed = NULL ) { - .learnTwasWeightsImpl(as.list(environment())) + assertString(study) + assertString(context) + assertString(trait) + assertInt(numThreads) + assertFlag(retainFits) + assertFlag(standardized) + assertString(dataType, null.ok = TRUE) + assertCount(verbose) + assertInt(seed, null.ok = TRUE) + # weightMethods is documented as a named list OR a character vector. + assert( + checkList(weightMethods), + checkCharacter(weightMethods), + .var.name = "weightMethods" + ) + .learnTwasWeightsImpl( + X = X, + Y = Y, + weightMethods = weightMethods, + study = study, + context = context, + trait = trait, + numThreads = numThreads, + fittedModels = fittedModels, + retainFits = retainFits, + retainFitDetail = retainFitDetail, + standardized = standardized, + dataType = dataType, + ldSketch = ldSketch, + verbose = verbose, + seed = seed + ) } # Validate X/Y shapes; coerce a vector Y to a one-column matrix. Returns Y. # @noRd +#' @importFrom checkmate assert assertMatrix checkAtomicVector checkMatrix .twasValidateXY <- function(X, Y) { - if (!is.matrix(X) || (!is.matrix(Y) && !is.vector(Y))) { - abort("X must be a matrix and Y must be a matrix or a vector.") - } + assertMatrix(X) + assert(checkMatrix(Y), checkAtomicVector(Y), .var.name = "Y") if (is.vector(Y)) { Y <- matrix(Y, ncol = 1) } - if (nrow(X) != nrow(Y)) { - abort("The number of rows in X and Y must be the same.") - } + assertMatrix(Y, nrows = nrow(X)) Y } @@ -1589,7 +1940,7 @@ learnTwasWeights <- function( # requested count capped at what is available. # @noRd .twasResolveCores <- function(numThreads) { - avail <- bpworkers(MulticoreParam()) + avail <- multicoreWorkers() min(if (numThreads == -1) avail else numThreads, avail) } @@ -1627,8 +1978,7 @@ learnTwasWeights <- function( } else { map(names(weightMethods), .computeMethodWeights, weightMethods, ctx) } - names(weightsList) <- names(weightMethods) - weightsList + set_names(weightsList, names(weightMethods)) } # Set weight-matrix rownames to colnames(X), preserving any retained `fit` attr. @@ -1643,53 +1993,77 @@ learnTwasWeights <- function( # learnTwasWeights worker: validate, resolve methods, fit each, and assemble the # TwasWeights collection. `p` is the captured public arguments. # @noRd -.learnTwasWeightsImpl <- function(p) { - .applySeed(p$seed) - retainFitDetail <- p$retainFitDetail +.learnTwasWeightsImpl <- function( + X, + Y, + weightMethods, + study, + context, + trait, + numThreads, + fittedModels, + retainFits, + retainFitDetail, + standardized, + dataType, + ldSketch, + verbose, + seed +) { + .applySeed(seed) retainFitDetail <- arg_match(retainFitDetail, c("slim", "full")) - Y <- .twasValidateXY(p$X, p$Y) - weightMethods <- if (is.character(p$weightMethods)) { - .twasMethodLookup(p$weightMethods) + Y <- .twasValidateXY(X, Y) + resolvedMethods <- if (is.character(weightMethods)) { + .twasMethodLookup(weightMethods) } else { - p$weightMethods - } - validColumns <- .nonzeroVarColumns(p$X) - Xfiltered <- as.matrix(p$X[, validColumns, drop = FALSE]) - weightMethods <- .prepareSusieWeightMethods( - Xfiltered, - Y, - weightMethods, - p$fittedModels + weightMethods + } + .twasRequireSusieFits( + resolvedMethods, + available = function(tk) { + adapter <- .twasFineMappingMethodAdapters[[tk]] + args <- .twasMethodArgsFor(resolvedMethods, tk) + !is.null(args[[adapter$fitArg]]) || !is.null(fittedModels[[tk]]) + }, + fnLabel = "learnTwasWeights", + how = str_c( + "Pass it as `fittedModels = list( = )`, or on the ", + "method's own arguments; run fineMappingPipeline() first to ", + "produce one." + ) ) + validColumns <- .nonzeroVarColumns(X) + Xfiltered <- as.matrix(X[, validColumns, drop = FALSE]) + prepared <- .prepareSusieWeightMethods(resolvedMethods, fittedModels) ctx <- list( - X = p$X, + X = X, Y = Y, Xfiltered = Xfiltered, validColumns = validColumns, - study = p$study, - context = p$context, - trait = p$trait, - retainFits = p$retainFits, + study = study, + context = context, + trait = trait, + retainFits = retainFits, retainFitDetail = retainFitDetail, - standardized = p$standardized, - dataType = p$dataType, - verbose = p$verbose, - rngSeed = p$seed + standardized = standardized, + dataType = dataType, + verbose = verbose, + rngSeed = seed ) weightsList <- .twasFitAllMethods( - weightMethods, + prepared, ctx, - .twasResolveCores(p$numThreads) - ) - weightsList <- .twasApplyRownames(weightsList, p$X) - rows <- .buildTwasWeightEntries(weightsList, .twasVariantIds(p$X), ctx) + .twasResolveCores(numThreads) + ) |> + .twasApplyRownames(X) + rows <- .buildTwasWeightEntries(weightsList, .twasVariantIds(X), ctx) TwasWeights( study = rows$study, context = rows$context, trait = rows$trait, method = rows$method, entry = rows$entry, - ldSketch = p$ldSketch + ldSketch = ldSketch ) } @@ -1724,7 +2098,15 @@ learnTwasWeights <- function( #' tw <- TwasWeights(study = "s1", context = "brain", trait = "g1", #' method = "susie", entry = list(twe)) #' twasPredict(X, tw) +#' @importFrom checkmate assert checkList checkClass +#' @importFrom checkmate assertList twasPredict <- function(X, weightsList) { + # The body branches on TwasWeights, so this is a list OR that S4 class. + assert( + checkList(weightsList), + checkClass(weightsList, "TwasWeights"), + .var.name = "weightsList" + ) if (is(weightsList, "TwasWeights")) { # Per-row weights vector/matrix payloads. Use the method name as key # for compatibility with the legacy snake_case "_predicted" @@ -1844,9 +2226,11 @@ estimateSparsity <- function(weightResults) { # The per-method args list for short name `m`, tagged with its `impl` attribute. # @noRd .twasMethodArgsWithImpl <- function(m) { - args <- .twasMethodMap[[m]]$args - attr(args, "impl") <- .twasMethodMap[[m]]$impl - args + `attr<-`( + .twasMethodMap[[m]]$args, + "impl", + .twasMethodMap[[m]]$impl + ) } # The implementation function name for short method name `m`. @@ -1861,10 +2245,21 @@ estimateSparsity <- function(weightResults) { .twasFoldRow(k, cvFolds[[k]], sampleNames) } +# Route a caller's per-method arguments into a weight function. A wrapper's +# own formals (a pre-fit, retainFit, initPriorSd, ...) bind by name; anything +# else is a tool option and goes in the wrapper's `methodArgs` list, so an +# unknown option errors inside the wrapper rather than vanishing. Wrappers +# with no `methodArgs` formal get everything by name, and R reports an unused +# argument -- which is the point. +# @noRd +.twasWeightCallArgs <- function(fnName, baseArgs, userArgs) { + c(baseArgs, .splitMethodArgs(fnName, userArgs)) +} + # One univariate fold's weight column for outcome `k` (quiet unless verbose). # @noRd .twasFitColWeight <- function(k, ctx, fnName, Xtr, Ytr, args) { - callArgs <- c(list(X = Xtr, y = Ytr[, k]), args) + callArgs <- .twasWeightCallArgs(fnName, list(X = Xtr, y = Ytr[, k]), args) w <- if (ctx$verbose < 2) { .quietEval(exec(fnName, !!!callArgs)) } else { @@ -1904,11 +2299,11 @@ estimateSparsity <- function(weightResults) { # @noRd .twasSetRownames <- function(x, X) { fit <- attr(x, "fit") - rownames(x) <- colnames(X) - if (!is.null(fit)) { - attr(x, "fit") <- fit + named <- `rownames<-`(x, colnames(X)) + if (is.null(fit)) { + return(named) } - x + `attr<-`(named, "fit", fit) } # X %*% w for one weight vector/matrix (coerced to a 1-column matrix if needed). diff --git a/R/twasWeightsPipeline.R b/R/twasWeightsPipeline.R index 1f6b1d86..4ddb5fe9 100644 --- a/R/twasWeightsPipeline.R +++ b/R/twasWeightsPipeline.R @@ -6,10 +6,10 @@ # column (delegates to the generic `.rbindCollections`, which unions columns # and pads a side lacking an optional column such as joint* / region). # @noRd +#' @importFrom checkmate assertClass .rbindTwasWeights <- function(a, b, ldSketch = NULL) { - if (!is(a, "TwasWeights") || !is(b, "TwasWeights")) { - abort(".rbindTwasWeights expects two TwasWeights inputs.") - } + assertClass(a, "TwasWeights") + assertClass(b, "TwasWeights") # Carry forward every column (joint*, region, ...) and reconcile the # collection-level slots via the shared combine. .combineTupleCollections(list(a, b), ldSketch, ".rbindTwasWeights") @@ -18,23 +18,27 @@ # Normalize combine() varargs: accept either N objects or a single list of # them; drop NULLs; require at least one input of the expected class `cls`. .asCombineList <- function(parts, cls, fn) { - if ( + # A single list argument is the collection itself, not a one-element + # variadic call. + unwrapped <- if ( length(parts) == 1L && is.list(parts[[1L]]) && !methods::is(parts[[1L]], cls) ) { - parts <- parts[[1L]] + parts[[1L]] + } else { + parts } - parts <- compact(parts) - if (length(parts) == 0L) { + present <- compact(unwrapped) + if (length(present) == 0L) { msg <- glue("{fn}: nothing to combine (need at least one {cls}).") abort(msg) } - if (!all(map_lgl(parts, methods::is, cls))) { + if (!all(map_lgl(present, methods::is, cls))) { msg <- glue("{fn}: every input must be a {cls}.") abort(msg) } - parts + present } #' Combine TwasWeights collections @@ -113,31 +117,28 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # reporting data.frame. .twasMergeRegionEntries <- function(entries, regionLabels) { keep <- !map_lgl(entries, is.null) - entries <- entries[keep] - regionLabels <- regionLabels[keep] - if (length(entries) == 0L) { + fitted <- entries[keep] + fittedLabels <- regionLabels[keep] + if (length(fitted) == 0L) { return(NULL) } - if (length(entries) == 1L) { - return(entries[[1L]]) + if (length(fitted) == 1L) { + return(fitted[[1L]]) } - entries <- map(entries, .asTwRowPayload) - wList <- map(entries, getWeights) + payloads <- map(fitted, .asTwRowPayload) + wList <- map(payloads, getWeights) weights <- if (is.matrix(wList[[1L]])) { exec(rbind, !!!wList) } else { - unlist(wList, use.names = FALSE) + unname(list_c(wList)) } twasWeightsRow( - variantIds = unlist( - map(entries, .twrPartsVariantIds), - use.names = FALSE - ), + variantIds = unname(list_c(map(payloads, .twrPartsVariantIds))), weights = weights, - fits = set_names(map(entries, getFits), regionLabels), - cvResult = .twasRegionCvDf(entries, regionLabels), - standardized = getStandardized(entries[[1L]]), - dataType = getDataType(entries[[1L]]) + fits = set_names(map(payloads, getFits), fittedLabels), + cvResult = .twasRegionCvDf(payloads, fittedLabels), + standardized = getStandardized(payloads[[1L]]), + dataType = getDataType(payloads[[1L]]) ) } @@ -148,6 +149,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # otherwise the partition the per-fold priors were computed on) NULL input # returns all-NULL, preserving the supplied samplePartition. # @noRd +#' @importFrom checkmate assertClass .unpackMashPrior <- function(mashPrior, samplePartition = NULL) { if (is.null(mashPrior)) { return(list( @@ -156,15 +158,10 @@ combineTwasWeights <- function(..., ldSketch = NULL) { samplePartition = samplePartition )) } - if (!is(mashPrior, "MashPrior")) { - abort("`mashPrior` must be a MashPrior object (see ?MashPrior).") - } + assertClass(mashPrior, "MashPrior") cvFits <- getCvFits(mashPrior) perFold <- if (!is.null(cvFits)) cvFits$perFoldFits else NULL - sp <- samplePartition - if (is.null(sp) && !is.null(cvFits) && !is.null(cvFits$samplePartition)) { - sp <- cvFits$samplePartition - } + sp <- samplePartition %||% cvFits$samplePartition list( fullPrior = getFullFit(mashPrior), dataDrivenPriorMatricesCv = perFold, @@ -345,14 +342,12 @@ combineTwasWeights <- function(..., ldSketch = NULL) { .twasKnownMethodLookupNames() ) regular <- setdiff(methods, fmExtra) - methodList <- if (length(regular) > 0L) { - .twasMethodLookup(regular) - } else { - list() - } - for (tk in fmExtra) { - methodList[[str_c(tk, "_weights")]] <- list() - } + # Fine-mapping tokens carry no learner arguments of their own, so each + # gets an empty stub entry under its `_weights` key. + methodList <- c( + if (length(regular) > 0L) .twasMethodLookup(regular) else list(), + .twasEmptyMethodArgs(str_c(fmExtra, "_weights")) + ) # Tokens come from the user input (canonical camelCase) -- the snake keys in # methodList are an internal detail of learnTwasWeights. list(tokens = unique(methods), methodList = methodList) @@ -363,21 +358,31 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # token->impl map as an "impl" attribute (without this, downstream # .resolveMethodFunction falls back to the bare token, which is not a function). # @noRd +# One `methods` entry re-keyed to its canonical name, with the caller's +# kwargs merged over the method's defaults. A token with no learner default +# is kept under its own name (the capability gate reports it downstream). +# @noRd +.twasNormalizeOneMethod <- function(tk, methods) { + base <- try_fetch(.twasMethodLookup(tk), error = function(cnd) NULL) + if (is.null(base)) { + return(list(key = tk, args = methods[[tk]])) + } + snake <- names(base)[[1L]] + merged <- list_modify(base[[snake]], !!!compact(methods[[tk]])) + # `impl` tells .resolveMethodFunction which function backs the token; + # without it the bare token is used, which is not a function. + list( + key = snake, + args = `attr<-`(merged, "impl", attr(base[[snake]], "impl")) + ) +} + .twasNormalizeListMethods <- function(methods) { - methodList <- list() - for (tk in names(methods)) { - base <- tryCatch(.twasMethodLookup(tk), error = function(e) NULL) - if (is.null(base)) { - # Fine-mapping-only / unknown token with no learner default: keep - # as-is (the downstream capability gate produces the message). - methodList[[tk]] <- methods[[tk]] - next - } - snake <- names(base)[[1L]] - merged <- modifyList(base[[snake]], methods[[tk]]) - attr(merged, "impl") <- attr(base[[snake]], "impl") - methodList[[snake]] <- merged - } + entries <- map(names(methods), .twasNormalizeOneMethod, methods = methods) + # Later entries win on a repeated canonical key, as the keyed assignment + # in the loop did. + keyed <- set_names(map(entries, "args"), map_chr(entries, "key")) + methodList <- keyed[!duplicated(names(keyed), fromLast = TRUE)] list( tokens = .twasTokensFromMethodList(methodList), methodList = methodList @@ -597,19 +602,26 @@ combineTwasWeights <- function(..., ldSketch = NULL) { return(character(0)) } methods <- str_to_lower(as.character(fineMappingResult$method)) - present <- character(0) - for (canonical in .twasFineMappingTokens()) { - candidates <- str_to_lower(c( - canonical, - str_c( - str_to_lower(str_sub(canonical, 1L, 1L)), - str_sub(canonical, 2L) - ), - str_replace_all(canonical, "([A-Z])", "_\\1") - )) - if (any(is_in(methods, candidates))) present <- c(present, canonical) - } - present + keep(.twasFineMappingTokens(), .twasTokenPresentIn, methods = methods) +} + +# The spellings one canonical token may appear under: itself, its camelCase +# form, and its snake_case form -- all lowercased for comparison. +# @noRd +.twasSpellingCandidates <- function(canonical) { + str_to_lower(c( + canonical, + str_c( + str_to_lower(str_sub(canonical, 1L, 1L)), + str_sub(canonical, 2L) + ), + str_replace_all(canonical, "([A-Z])", "_\\1") + )) +} + +# @noRd +.twasTokenPresentIn <- function(canonical, methods) { + any(is_in(methods, .twasSpellingCandidates(canonical))) } # Reject fine-mapping methods (susie / susieInf / susieAsh / mvsusie / @@ -621,7 +633,12 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # step with fineMappingPipeline. Methods with no TWAS-weight extractor # (fsusie) are rejected with a method-specific message. # @noRd -.twasCheckFineMappingMethods <- function(tokens, fineMappingResult, inputKind) { +.twasCheckFineMappingMethods <- function( + tokens, + fineMappingResult, + inputKind, + cvFolds = 0 +) { fmTokens <- intersect(tokens, .twasFineMappingTokens()) if (length(fmTokens) == 0L) { return(invisible(NULL)) @@ -632,9 +649,56 @@ combineTwasWeights <- function(..., ldSketch = NULL) { .twasCheckFmAdapters(fmTokens) .twasRequireFmResult(fineMappingResult, fmTokens) .twasCheckFmPresent(fmTokens, fineMappingResult) + .twasCheckFmCvPresent(fmTokens, fineMappingResult, cvFolds) invisible(NULL) } +# Whether row `i` of a FineMappingResult carries a cross-validation result. +# @noRd +.fmrRowHasCv <- function(i, fineMappingResult) { + !is.null(getCvResult(.fmrRowParts(fineMappingResult, i))) +} + +# Whether a FineMappingResult carries any cross-validation result at all. +# @noRd +.fmrAnyCvResult <- function(fineMappingResult) { + if (!is(fineMappingResult, "FineMappingResultBase")) { + return(FALSE) + } + n <- nrow(fineMappingResult) + if (is.null(n) || n == 0L) { + return(FALSE) + } + any(map_lgl( + seq_len(n), + .fmrRowHasCv, + fineMappingResult = fineMappingResult + )) +} + +# Cross-validating a fine-mapping method needs that method's per-fold fits, +# and this pipeline never fine-maps for itself. Only fineMappingPipeline() run +# with cvFolds > 1 produces them, so require them up front rather than +# discovering the gap once the folds are already being scored. +# @noRd +.twasCheckFmCvPresent <- function(fmTokens, fineMappingResult, cvFolds) { + if (is.null(cvFolds) || cvFolds <= 1L) { + return(invisible(NULL)) + } + if (.fmrAnyCvResult(fineMappingResult)) { + return(invisible(NULL)) + } + fmStr <- str_flatten(fmTokens, ", ") + msg <- glue( + "twasWeightsPipeline: cross-validating method(s) {fmStr} needs each ", + "fold's own fine-mapping fit, but the supplied fineMappingResult ", + "carries no cross-validation. Run fineMappingPipeline() with ", + "cvFolds > 1; its fold partition is then reused for every other ", + "weight method so all of them are scored on the same folds." + ) + abort(msg) +} + # Reject fine-mapping methods that have no TWAS-weight extractor (e.g. fsusie). # @noRd .twasCheckFmAdapters <- function(fmTokens) { @@ -654,6 +718,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # A supplied fineMappingResult is mandatory (fine-mapping is never re-fit) and # must be a FineMappingResult. # @noRd +#' @importFrom checkmate assertClass .twasRequireFmResult <- function(fineMappingResult, fmTokens) { if (is.null(fineMappingResult)) { fmStr <- str_flatten(unique(fmTokens), ", ") @@ -665,9 +730,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { ) abort(msg) } - if (!is(fineMappingResult, "FineMappingResultBase")) { - abort("`fineMappingResult` must be a FineMappingResult or NULL.") - } + assertClass(fineMappingResult, "FineMappingResultBase") invisible(NULL) } @@ -772,39 +835,52 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # suitable for `learnTwasWeights`. Pulls the trimmedFit from the matching # entry. Returns a (possibly empty) list. # @noRd +#' @importFrom checkmate assertClass .twasFineMappingFits <- function(fineMappingResult, study, context, trait) { if (is.null(fineMappingResult)) { return(list()) } - if (!is(fineMappingResult, "FineMappingResultBase")) { - abort("`fineMappingResult` must be a FineMappingResult or NULL.") - } - out <- list() - methods <- as.character(fineMappingResult$method) - for (canonical in c("susie", "susieInf", "susieAsh", "mvsusie", "fsusie")) { - candidates <- c( - canonical, - str_c( - str_to_lower(str_sub(canonical, 1L, 1L)), - str_sub(canonical, 2L) - ), - str_replace_all(canonical, "([A-Z])", "_\\1") - ) - candidates <- str_to_lower(candidates) - idx <- which( - is_in(str_to_lower(methods), candidates) & - as.character(fineMappingResult$study) == study & - as.character(fineMappingResult$context) == context & - as.character(fineMappingResult$trait) == trait - ) - if (length(idx) > 0L) { - out[[canonical]] <- getSusieFit(.fmrRowParts( - fineMappingResult, - idx[[1L]] - )) - } + assertClass(fineMappingResult, "FineMappingResultBase") + tokens <- c("susie", "susieInf", "susieAsh", "mvsusie", "fsusie") + found <- compact(set_names( + map( + tokens, + .twasFitForToken, + fineMappingResult = fineMappingResult, + study = study, + context = context, + trait = trait + ), + tokens + )) + # compact() on an all-NULL named list leaves a zero-length names + # attribute, which is not the bare list() the contract promises. + if (length(found) == 0L) list() else found +} + +# The fit this result holds for one token on one tuple, or NULL when it has +# none. The first matching row wins, as the keyed assignment it replaced did. +# @noRd +.twasFitForToken <- function( + canonical, + fineMappingResult, + study, + context, + trait +) { + idx <- which( + is_in( + str_to_lower(as.character(fineMappingResult$method)), + .twasSpellingCandidates(canonical) + ) & + as.character(fineMappingResult$study) == study & + as.character(fineMappingResult$context) == context & + as.character(fineMappingResult$trait) == trait + ) + if (length(idx) == 0L) { + return(NULL) } - out + getSusieFit(.fmrRowParts(fineMappingResult, idx[[1L]])) } # Locate a fine-mapping fit for one (study, context, trait, token) tuple. @@ -842,6 +918,34 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # per-region list; the first region carrying CV is used. Returns NULL when no # fine-mapping entry for the tuple recorded CV. # @noRd +# Concatenate per-row lists, empty-safe. +# @noRd +.twasCvConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) + } + list_c(pieces) +} + +# Row `i`'s cross-validation result, or NULL when it has none. Multi-region +# entries store cvResult as a named per-region list, so the first region that +# carries a partition stands for the row. +# @noRd +.twasRowCvResult <- function(i, fineMappingResult) { + cv <- getCvResult(.fmrRowParts(fineMappingResult, i)) + if (is.null(cv)) { + return(NULL) + } + if (!is.null(cv$samplePartition)) { + return(cv) + } + hit <- keep(cv, .twasCvHasPartition) + if (length(hit) == 0L) { + return(NULL) + } + hit[[1L]] +} + .twasCvResultFor <- function(fineMappingResult, study, context, trait) { if (is.null(fineMappingResult)) { return(NULL) @@ -857,36 +961,21 @@ combineTwasWeights <- function(..., ldSketch = NULL) { if (length(idx) == 0L) { return(NULL) } - samplePartition <- NULL - prediction <- list() - performance <- list() - for (i in idx) { - cv <- getCvResult(.fmrRowParts(fineMappingResult, i)) - if (is.null(cv)) { - next - } - # Multi-region entries store cvResult as a named per-region list; pick - # the first region that carries a partition. - if (is.null(cv$samplePartition)) { - hit <- keep(cv, .twasCvHasPartition) - if (length(hit) == 0L) { - next - } - cv <- hit[[1L]] - } - if (is.null(samplePartition)) { - samplePartition <- cv$samplePartition - } - prediction <- c(prediction, cv$prediction) - performance <- c(performance, cv$performance) - } + cvs <- compact(map( + idx, + .twasRowCvResult, + fineMappingResult = fineMappingResult + )) + prediction <- .twasCvConcat(map(cvs, "prediction")) if (length(prediction) == 0L) { return(NULL) } list( - samplePartition = samplePartition, + # The first row that carries one defines the partition, as the + # "only set it if still NULL" assignment did. + samplePartition = cvs[[1L]]$samplePartition, prediction = prediction, - performance = performance + performance = .twasCvConcat(map(cvs, "performance")) ) } @@ -1024,7 +1113,11 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' @param maxCvVariants Maximum number of variants for CV. Default -1 (no #' limit). #' @param cvThreads Threads for CV parallelism. Default 1. -#' @param cvWeightMethods Optional override of methods used for CV. +#' @param cvWeightMethods Optional override of which methods are +#' cross-validated, as a character vector of tokens or a named method +#' list. \code{NULL} (default) cross-validates every method that +#' produced non-zero weights; a method whose weights are all zero is +#' excluded with a warning either way. #' @param ensemble Logical. Compute SR-TWAS ensemble weights. Default #' \code{TRUE}. #' @param ensembleR2Threshold Minimum CV R-squared for ensemble inclusion. @@ -1083,8 +1176,8 @@ setGeneric("twasWeightsPipeline", function(data, ...) { # @noRd .twasRunMultivariateGrid <- function(traits, marker, ctx) { synthSpec <- list(list(axes = c("context", "trait"), scope = NULL)) - labs <- map_chr(ctx$xRegions, .twasRegionLabel) - perRegion <- map( + allLabs <- map_chr(ctx$xRegions, .twasRegionLabel) + allRegions <- map( seq_along(ctx$xRegions), .twasMvGridRegion, synthSpec = synthSpec, @@ -1092,9 +1185,9 @@ setGeneric("twasWeightsPipeline", function(data, ...) { ctx = ctx, traits = traits ) - keep <- !map_lgl(perRegion, is.null) - perRegion <- perRegion[keep] - labs <- labs[keep] + keep <- !map_lgl(allRegions, is.null) + perRegion <- allRegions[keep] + labs <- allLabs[keep] if (length(perRegion) == 0L) { return(NULL) } @@ -1153,55 +1246,197 @@ setMethod( ) { naAction <- arg_match(naAction) retainFitDetail <- arg_match(retainFitDetail) - p <- as.list(environment()) - p$dots <- list(...) - .twasPipelineQtlDataset(p) + .twasPipelineQtlDataset( + data = data, + methods = methods, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + xvarCutoff = xvarCutoff, + imissCutoff = imissCutoff, + keepIndel = keepIndel, + keepSamples = keepSamples, + keepVariants = keepVariants, + jointRegions = jointRegions, + jointSpecification = jointSpecification, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + mashPrior = mashPrior, + cvFolds = cvFolds, + samplePartition = samplePartition, + fitFullData = fitFullData, + cvWeightMethods = cvWeightMethods, + maxCvVariants = maxCvVariants, + cvThreads = cvThreads, + ensemble = ensemble, + ensembleR2Threshold = ensembleR2Threshold, + ensembleSolver = ensembleSolver, + ensembleAlpha = ensembleAlpha, + estimatePi = estimatePi, + retainFit = retainFit, + retainFitDetail = retainFitDetail, + dataType = dataType, + naAction = naAction, + verbose = verbose, + seed = seed + ) } ) # ---- QtlDataset pipeline worker + phase helpers ---------------------------- -.twasPipelineQtlDataset <- function(p) { - .twasQdsCheckRegionCisWindow(p) - p$xRegions <- .makeXRegions(p$region, p$jointRegions) +.twasPipelineQtlDataset <- function( + data, + methods, + contexts, + traitId, + region, + cisWindow, + mafCutoff, + macCutoff, + xvarCutoff, + imissCutoff, + keepIndel, + keepSamples, + keepVariants, + jointRegions, + jointSpecification, + fineMappingResult, + twasWeights, + mashPrior, + cvFolds, + samplePartition, + fitFullData, + cvWeightMethods, + maxCvVariants, + cvThreads, + ensemble, + ensembleR2Threshold, + ensembleSolver, + ensembleAlpha, + estimatePi, + retainFit, + retainFitDetail, + dataType, + naAction, + verbose, + seed +) { + .twasQdsCheckRegionCisWindow(region, cisWindow) + xRegions <- .makeXRegions(region, jointRegions) # Per-call filter overrides replace the construct-time slot values on a # validated copy. Variant QC is a data property applied identically to # fine-mapping and TWAS -- there is no TWAS-specific variant filter. - p$data <- .qtlApplyFilterOverrides( - p$data, - p$mafCutoff, - p$macCutoff, - p$xvarCutoff, - p$imissCutoff, - p$keepIndel, - p$keepSamples, - p$keepVariants - ) - p$parsedJointSpec <- parseJointSpecification(p$jointSpecification, p$data) - p$norm <- .twasNormalizeMethods(p$methods) - .twasCheckMethodCapabilities(p$norm$tokens, "QtlDataset") + data <- .qtlApplyFilterOverrides( + data, + mafCutoff, + macCutoff, + xvarCutoff, + imissCutoff, + keepIndel, + keepSamples, + keepVariants + ) + parsedJointSpec <- parseJointSpecification(jointSpecification, data) + rawNorm <- .twasNormalizeMethods(methods) + .twasCheckMethodCapabilities(rawNorm$tokens, "QtlDataset") .twasCheckFineMappingMethods( - p$norm$tokens, - p$fineMappingResult, - "QtlDataset" + rawNorm$tokens, + fineMappingResult, + "QtlDataset", + cvFolds = cvFolds + ) + .twasQdsCheckFitFull(fitFullData, cvFolds) + mash <- .twasQdsUnpackMash(mashPrior, samplePartition, rawNorm) + samplePartition <- mash$samplePartition + dataDrivenPriorMatricesCv <- mash$dataDrivenPriorMatricesCv + joint <- .twasQdsJointPhase( + parsedJointSpec, + mash$norm, + data, + contexts, + traitId, + cisWindow, + dataType, + verbose, + xRegions, + retainFit, + retainFitDetail, + seed ) - .twasQdsCheckFitFull(p) - p <- .twasQdsUnpackMash(p) - joint <- .twasQdsJointPhase(p) if (joint$done) { return(joint$result) } - p$norm <- joint$norm - p$jointResult <- joint$result - p <- .twasQdsResolveGrid(p) - .twasQdsAssemble(.twasQdsDispatch(p), p$jointResult) + # The joint phase consumes the mrmash token; `norm` comes back holding + # only the methods that still have to go through the per-tuple loop. + norm <- joint$norm + grid <- .twasQdsResolveGrid(data, contexts, traitId, region, norm$tokens) + study <- grid$study + useCtx <- grid$useCtx + allTraits <- grid$allTraits + marker <- .twasQdsMarker( + cvFolds = cvFolds, + samplePartition = samplePartition, + fitFullData = fitFullData, + dataType = dataType, + retainFitDetail = retainFitDetail, + ensemble = ensemble, + ensembleR2Threshold = ensembleR2Threshold, + ensembleSolver = ensembleSolver, + ensembleAlpha = ensembleAlpha, + maxCvVariants = maxCvVariants, + cvThreads = cvThreads, + estimatePi = estimatePi, + verbose = verbose, + seed = seed, + cvWeightMethods = cvWeightMethods + ) + tw <- if (grid$multivariate) { + .twasRunMultivariateGrid( + allTraits, + marker, + .twasQdsGridCtx( + xRegions = xRegions, + data = data, + norm = norm, + useCtx = useCtx, + fineMappingResult = fineMappingResult, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + verbose = verbose + ) + ) + } else { + .twasQdsUnivariateEngine( + study = study, + useCtx = useCtx, + allTraits = allTraits, + marker = marker, + data = data, + xRegions = xRegions, + norm = norm, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + naAction = naAction, + verbose = verbose + ) + } + .twasQdsAssemble(tw, joint$result) } # `cisWindow` expands a trait's own coordinates; `region` is literal. Supplying # both signals a misunderstanding -> reject. # @noRd -.twasQdsCheckRegionCisWindow <- function(p) { - if (!is.null(p$region) && !is.null(p$cisWindow)) { +.twasQdsCheckRegionCisWindow <- function( + region, + cisWindow +) { + if (!is.null(region) && !is.null(cisWindow)) { msg <- glue( "twasWeightsPipeline(QtlDataset): specify either `region` or ", "`cisWindow`, not both. `cisWindow` expands each trait's own ", @@ -1214,8 +1449,11 @@ setMethod( # fitFullData = FALSE (CV-only) is meaningful only with cross-validation. # @noRd -.twasQdsCheckFitFull <- function(p) { - if (!isTRUE(p$fitFullData) && p$cvFolds <= 1L) { +.twasQdsCheckFitFull <- function( + fitFullData, + cvFolds +) { + if (!isTRUE(fitFullData) && cvFolds <= 1L) { msg <- glue( "twasWeightsPipeline: fitFullData = FALSE requires ", "cross-validation (cvFolds > 1)." @@ -1229,24 +1467,46 @@ setMethod( # args, the per-fold priors + fold partition into the CV machinery. Returns the # updated parameter bundle. # @noRd -.twasQdsUnpackMash <- function(p) { - mp <- .unpackMashPrior(p$mashPrior, p$samplePartition) - p$samplePartition <- mp$samplePartition - p$dataDrivenPriorMatricesCv <- mp$dataDrivenPriorMatricesCv - if (!is.null(p$mashPrior) && !is_in("mrmash", p$norm$tokens)) { +.twasQdsUnpackMash <- function( + mashPrior, + samplePartition, + norm +) { + mp <- .unpackMashPrior(mashPrior, samplePartition) + if (!is.null(mashPrior) && !is_in("mrmash", norm$tokens)) { msg <- glue( "`mashPrior` was supplied but 'mrmash' is not among `methods`; ", "the data-driven prior is ignored." ) warn(msg) } - if ( + withPrior <- if ( !is.null(mp$fullPrior) && - is_in("mrmash_weights", names(p$norm$methodList)) + is_in("mrmash_weights", names(norm$methodList)) ) { - p$norm$methodList$mrmash_weights$dataDrivenPriorMatrices <- mp$fullPrior + .twasQdsSetMrmashPrior(norm, mp$fullPrior) + } else { + norm } - p + list( + samplePartition = mp$samplePartition, + dataDrivenPriorMatricesCv = mp$dataDrivenPriorMatricesCv, + norm = withPrior + ) +} + +# The normalized argument list with mr.mash's full-data prior attached, +# leaving every other method's arguments untouched. +# @noRd +.twasQdsSetMrmashPrior <- function(norm, fullPrior) { + updated <- list_assign( + norm$methodList$mrmash_weights, + dataDrivenPriorMatrices = fullPrior + ) + list_assign( + norm, + methodList = list_assign(norm$methodList, mrmash_weights = updated) + ) } # Explicit jointSpecification path: run the per-spec axis dispatcher for @@ -1254,25 +1514,38 @@ setMethod( # with `result`; otherwise `norm` is the mrmash-stripped normalization for the # per-tuple loop below. # @noRd -.twasQdsJointPhase <- function(p) { - if (length(p$parsedJointSpec) == 0L) { - return(list(done = FALSE, result = NULL, norm = p$norm)) +.twasQdsJointPhase <- function( + parsedJointSpec, + norm, + data, + contexts, + traitId, + cisWindow, + dataType, + verbose, + xRegions, + retainFit, + retainFitDetail, + seed +) { + if (length(parsedJointSpec) == 0L) { + return(list(done = FALSE, result = NULL, norm = norm)) } jointResult <- .twasDispatchJointSpecsQtlDataset( - p$parsedJointSpec, - p$data, - intersect(p$norm$tokens, "mrmash"), - p$contexts, - p$traitId, - p$cisWindow, - p$dataType, - p$verbose, - xRegions = p$xRegions, - retainFit = p$retainFit, - retainFitDetail = p$retainFitDetail, - seed = p$seed - ) - keep <- setdiff(p$norm$tokens, intersect(p$norm$tokens, "mrmash")) + parsedJointSpec, + data, + intersect(norm$tokens, "mrmash"), + contexts, + traitId, + cisWindow, + dataType, + verbose, + xRegions = xRegions, + retainFit = retainFit, + retainFitDetail = retainFitDetail, + seed = seed + ) + keep <- setdiff(norm$tokens, intersect(norm$tokens, "mrmash")) if (length(keep) == 0L) { if (is.null(jointResult)) { msg <- glue( @@ -1284,33 +1557,40 @@ setMethod( } return(list(done = TRUE, result = jointResult)) } - norm <- p$norm - norm$tokens <- keep keepKeys <- which( is_in(str_remove(names(norm$methodList), "(_weights|Weights)$"), keep) ) - norm$methodList <- norm$methodList[keepKeys] - list(done = FALSE, result = jointResult, norm = norm) + list( + done = FALSE, + result = jointResult, + norm = list_assign( + norm, + tokens = keep, + methodList = norm$methodList[keepKeys] + ) + ) } # Resolve the (context, trait) grid + multivariate flag and build the joint- # pipeline marker + shared grid context. Returns the updated parameter bundle. # @noRd -.twasQdsResolveGrid <- function(p) { - p$study <- getStudy(p$data) - p$useCtx <- .twasQdsResolveContexts(p$data, p$contexts) - p$allTraits <- .twasQdsResolveTraits( - p$data, - p$useCtx, - p$traitId, - p$region +.twasQdsResolveGrid <- function( + data, + contexts, + traitId, + region, + tokens +) { + study <- getStudy(data) + useCtx <- .twasQdsResolveContexts(data, contexts) + allTraits <- .twasQdsResolveTraits(data, useCtx, traitId, region) + .twasCheckMultivariateY(tokens, length(allTraits), length(useCtx)) + list( + study = study, + useCtx = useCtx, + allTraits = allTraits, + multivariate = any(map_lgl(tokens, .twasIsMultivariateToken)) ) - p$nCtx <- length(p$useCtx) - .twasCheckMultivariateY(p$norm$tokens, length(p$allTraits), p$nCtx) - p$multivariate <- any(map_lgl(p$norm$tokens, .twasIsMultivariateToken)) - p$marker <- .twasQdsMarker(p) - p$twasGridCtx <- .twasQdsGridCtx(p) - p } # Selected contexts (all when NULL; else validated against the dataset). @@ -1342,7 +1622,7 @@ setMethod( traitId = traitId, region = region ) - allTraits <- unique(unlist(perCtxTraits)) + allTraits <- unique(list_c(perCtxTraits)) if (length(allTraits) == 0L) { abort("twasWeightsPipeline(QtlDataset): no traits selected.") } @@ -1351,25 +1631,42 @@ setMethod( # Joint-pipeline marker carrying the CV / ensemble config for the engine. # @noRd -.twasQdsMarker <- function(p) { +.twasQdsMarker <- function( + cvFolds, + samplePartition, + fitFullData, + dataType, + retainFitDetail, + ensemble, + ensembleR2Threshold, + ensembleSolver, + ensembleAlpha, + maxCvVariants, + cvThreads, + estimatePi, + verbose, + seed, + cvWeightMethods +) { new( "TwasJointPipeline", config = list( - cvFolds = p$cvFolds, - samplePartition = p$samplePartition, - fitFullData = p$fitFullData, - dataType = p$dataType, - retainFitDetail = p$retainFitDetail, + cvFolds = cvFolds, + samplePartition = samplePartition, + fitFullData = fitFullData, + dataType = dataType, + retainFitDetail = retainFitDetail, standardized = FALSE, - ensemble = p$ensemble, - ensembleR2Threshold = p$ensembleR2Threshold, - ensembleSolver = p$ensembleSolver, - ensembleAlpha = p$ensembleAlpha, - maxCvVariants = p$maxCvVariants, - cvThreads = p$cvThreads, - estimatePi = p$estimatePi, - verbose = p$verbose, - seed = p$seed, + ensemble = ensemble, + ensembleR2Threshold = ensembleR2Threshold, + ensembleSolver = ensembleSolver, + ensembleAlpha = ensembleAlpha, + cvWeightMethods = cvWeightMethods, + maxCvVariants = maxCvVariants, + cvThreads = cvThreads, + estimatePi = estimatePi, + verbose = verbose, + seed = seed, ldSketch = NULL ) ) @@ -1377,46 +1674,69 @@ setMethod( # Shared grid context consumed by both dispatch paths. # @noRd -.twasQdsGridCtx <- function(p) { +.twasQdsGridCtx <- function( + xRegions, + data, + norm, + useCtx, + fineMappingResult, + dataDrivenPriorMatricesCv, + cisWindow, + verbose +) { list( - xRegions = p$xRegions, - data = p$data, - norm = p$norm, - useCtx = p$useCtx, - fineMappingResult = p$fineMappingResult, - dataDrivenPriorMatricesCv = p$dataDrivenPriorMatricesCv, - cisWindow = p$cisWindow, - verbose = p$verbose + xRegions = xRegions, + data = data, + norm = norm, + useCtx = useCtx, + fineMappingResult = fineMappingResult, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + verbose = verbose ) } -# Top-level dispatch: multivariate joint grid vs univariate engine path. -# @noRd -.twasQdsDispatch <- function(p) { - if (p$multivariate) { - return(.twasRunMultivariateGrid(p$allTraits, p$marker, p$twasGridCtx)) - } - .twasQdsUnivariateEngine(p) -} - # Univariate methods ROUTED THROUGH THE ENGINE: one 1-condition group per # (context, trait), per region -> the SAME per-method fitter (+ ensemble layer # for >= 2 methods + resume cache) as the joint paths, merged across regions. # @noRd -.twasQdsUnivariateEngine <- function(p) { +.twasQdsUnivariateEngine <- function( + study, + useCtx, + allTraits, + marker, + data, + xRegions, + norm, + fineMappingResult, + twasWeights, + dataDrivenPriorMatricesCv, + cisWindow, + naAction, + verbose +) { univCell <- .lookupJointCell("univariate", "individual") scope <- list( - studies = p$study, - contexts = set_names(list(p$useCtx), p$study), - traits = set_names(list(p$allTraits), p$study) + studies = study, + contexts = set_names(list(useCtx), study), + traits = set_names(list(allTraits), study) ) - labs <- map_chr(p$xRegions, .twasRegionLabel) + labs <- map_chr(xRegions, .twasRegionLabel) perRegion <- map( - seq_along(p$xRegions), + seq_along(xRegions), .twasQdsUnivRegion, univCell = univCell, - p = p, - scope = scope + scope = scope, + marker = marker, + data = data, + xRegions = xRegions, + norm = norm, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + naAction = naAction, + verbose = verbose ) keep <- !map_lgl(perRegion, is.null) .twasMergeRegionResults(perRegion[keep], labs[keep]) @@ -1424,18 +1744,28 @@ setMethod( # Per-region engine args for the univariate path. # @noRd -.twasQdsUnivArgs <- function(p, bi) { +.twasQdsUnivArgs <- function( + bi, + xRegions, + norm, + fineMappingResult, + twasWeights, + dataDrivenPriorMatricesCv, + cisWindow, + naAction, + verbose +) { list( - methodList = p$norm$methodList, - fineMappingResult = p$fineMappingResult, - cache = p$twasWeights, - dataDrivenPriorMatricesCv = p$dataDrivenPriorMatricesCv, - cisWindow = p$cisWindow, - region = p$xRegions[[bi]], + methodList = norm$methodList, + fineMappingResult = fineMappingResult, + cache = twasWeights, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + region = xRegions[[bi]], regionIndex = bi, - nRegions = length(p$xRegions), - naAction = p$naAction, - verbose = p$verbose + nRegions = length(xRegions), + naAction = naAction, + verbose = verbose ) } @@ -1493,34 +1823,118 @@ setMethod( ... ) { retainFitDetail <- arg_match(retainFitDetail) - p <- as.list(environment()) - p$dots <- list(...) - .twasPipelineQtlSumStats(p) + .twasPipelineQtlSumStats( + data = data, + methods = methods, + contexts = contexts, + traitId = traitId, + jointSpecification = jointSpecification, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + retainFit = retainFit, + retainFitDetail = retainFitDetail, + dataType = dataType, + verbose = verbose, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + ) } ) # ---- QtlSumStats pipeline worker + phase helpers --------------------------- -.twasPipelineQtlSumStats <- function(p) { +.twasPipelineQtlSumStats <- function( + data, + methods, + contexts, + traitId, + jointSpecification, + fineMappingResult, + twasWeights, + retainFit, + retainFitDetail, + dataType, + verbose, + mafCutoff, + macCutoff, + imissCutoff +) { # summaryStatsQc() is mandatory before twasWeightsPipeline for SumStats # input; it also drops variants not present in the ldSketch, so every # entry's SNP set is a subset of the ldSketch panel by the time we get here. - .twasAssertQcd(p$data) - p$parsedJointSpec <- parseJointSpecification(p$jointSpecification, p$data) - tm <- .twasSumStatsMethodTokens(p$methods) - p$tokens <- tm$tokens - p$methodArgs <- tm$methodArgs - .twasCheckMethodCapabilities(p$tokens, "QtlSumStats") - .twasCheckFineMappingMethods(p$tokens, p$fineMappingResult, "QtlSumStats") - joint <- .twasQssJointPhase(p) + .twasAssertQcd(data) + parsedJointSpec <- parseJointSpecification(jointSpecification, data) + tm <- .twasSumStatsMethodTokens(methods) + allTokens <- tm$tokens + allMethodArgs <- tm$methodArgs + .twasCheckMethodCapabilities(allTokens, "QtlSumStats") + .twasCheckFineMappingMethods(allTokens, fineMappingResult, "QtlSumStats") + joint <- .twasQssJointPhase( + parsedJointSpec, + data, + allTokens, + allMethodArgs, + contexts, + traitId, + dataType, + verbose, + retainFit, + retainFitDetail, + mafCutoff, + macCutoff, + imissCutoff + ) if (joint$done) { return(joint$result) } - p$tokens <- joint$tokens - p$methodArgs <- joint$methodArgs - p <- .twasQssSelectAndPartition(p) - rows <- c(.twasQssUnivariateRows(p), .twasQssMultivariateRows(p)) - .twasQssAssemble(rows, joint$result, p) + # The joint phase consumes the mrmash token; what it hands back is the + # remainder that still has to go through the per-tuple loop. + tokens <- joint$tokens + methodArgs <- joint$methodArgs + part <- .twasQssSelectAndPartition(data, tokens, contexts, traitId) + studyCol <- part$studyCol + contextCol <- part$contextCol + traitCol <- part$traitCol + selRows <- part$selRows + multivariateTokens <- part$multivariateTokens + univariateTokens <- part$univariateTokens + ldSketch <- part$ldSketch + rows <- c( + .twasQssUnivariateRows( + selRows, + univariateTokens = univariateTokens, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol, + data = data, + ldSketch = ldSketch, + twasWeights = twasWeights, + dataType = dataType, + fineMappingResult = fineMappingResult, + methodArgs = methodArgs, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + ), + .twasQssMultivariateRows( + selRows, + multivariateTokens = multivariateTokens, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol, + data = data, + ldSketch = ldSketch, + methodArgs = methodArgs, + retainFitDetail = retainFitDetail, + fineMappingResult = fineMappingResult, + dataType = dataType, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + ) + ) + .twasQssAssemble(rows, joint$result, ldSketch) } # Normalize the methods argument into (tokens, methodArgs). The default set @@ -1558,30 +1972,44 @@ setMethod( # methodArgs): `done` requests an early return with `result`; otherwise the # remaining (non-mrmash) tokens + args continue through the per-tuple loop. # @noRd -.twasQssJointPhase <- function(p) { - if (length(p$parsedJointSpec) == 0L) { +.twasQssJointPhase <- function( + parsedJointSpec, + data, + tokens, + methodArgs, + contexts, + traitId, + dataType, + verbose, + retainFit, + retainFitDetail, + mafCutoff, + macCutoff, + imissCutoff +) { + if (length(parsedJointSpec) == 0L) { return(list( done = FALSE, result = NULL, - tokens = p$tokens, - methodArgs = p$methodArgs + tokens = tokens, + methodArgs = methodArgs )) } jointResult <- .twasDispatchJointSpecsQtlSumStats( - p$parsedJointSpec, - p$data, - intersect(p$tokens, "mrmash"), - p$contexts, - p$traitId, - p$dataType, - p$verbose, - retainFit = p$retainFit, - retainFitDetail = p$retainFitDetail, - mafCutoff = p$mafCutoff %||% 0, - macCutoff = p$macCutoff %||% 0, - imissCutoff = p$imissCutoff %||% 1 - ) - keep <- setdiff(p$tokens, "mrmash") + parsedJointSpec, + data, + intersect(tokens, "mrmash"), + contexts, + traitId, + dataType, + verbose, + retainFit = retainFit, + retainFitDetail = retainFitDetail, + mafCutoff = mafCutoff %||% 0, + macCutoff = macCutoff %||% 0, + imissCutoff = imissCutoff %||% 1 + ) + keep <- setdiff(tokens, "mrmash") if (length(keep) == 0L) { if (is.null(jointResult)) { abort("twasWeightsPipeline(QtlSumStats): no joint fits produced.") @@ -1592,7 +2020,7 @@ setMethod( done = FALSE, result = jointResult, tokens = keep, - methodArgs = p$methodArgs[keep] + methodArgs = methodArgs[keep] ) } @@ -1600,28 +2028,56 @@ setMethod( # attach the LD sketch, and enforce the multivariate >=2-contexts rule. Returns # the updated parameter bundle. # @noRd -.twasQssSelectAndPartition <- function(p) { - p$studyCol <- as.character(p$data$study) - p$contextCol <- as.character(p$data$context) - p$traitCol <- as.character(p$data$trait) - p$selRows <- .twasQssSelectRows(p) - isMv <- map_lgl(p$tokens, .twasIsMultivariateToken) - p$multivariateTokens <- p$tokens[isMv] - p$univariateTokens <- p$tokens[!isMv] - p$ldSketch <- getLdSketch(p$data) - .twasQssCheckMultivariate(p) - p +.twasQssSelectAndPartition <- function(data, tokens, contexts, traitId) { + studyCol <- as.character(data$study) + contextCol <- as.character(data$context) + traitCol <- as.character(data$trait) + selRows <- .twasQssSelectRows( + data, + contextCol, + traitCol, + contexts, + traitId + ) + isMv <- map_lgl(tokens, .twasIsMultivariateToken) + multivariateTokens <- tokens[isMv] + univariateTokens <- tokens[!isMv] + .twasQssCheckMultivariate( + multivariateTokens, + selRows, + studyCol, + contextCol, + traitCol + ) + list( + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol, + selRows = selRows, + multivariateTokens = multivariateTokens, + univariateTokens = univariateTokens, + ldSketch = getLdSketch(data) + ) } # Row indices matching the contexts / traitId filters (error if none). # @noRd -.twasQssSelectRows <- function(p) { - selRows <- seq_len(nrow(p$data)) - if (!is.null(p$contexts)) { - selRows <- selRows[is_in(p$contextCol[selRows], p$contexts)] +.twasQssSelectRows <- function( + data, + contextCol, + traitCol, + contexts, + traitId +) { + byContext <- if (is.null(contexts)) { + seq_len(nrow(data)) + } else { + which(is_in(contextCol, contexts)) } - if (!is.null(p$traitId)) { - selRows <- selRows[is_in(p$traitCol[selRows], p$traitId)] + selRows <- if (is.null(traitId)) { + byContext + } else { + byContext[is_in(traitCol[byContext], traitId)] } if (length(selRows) == 0L) { msg <- glue( @@ -1635,18 +2091,24 @@ setMethod( # Multivariate methods require at least two contexts within some (study, trait). # @noRd -.twasQssCheckMultivariate <- function(p) { - if (length(p$multivariateTokens) == 0L) { +.twasQssCheckMultivariate <- function( + multivariateTokens, + selRows, + studyCol, + contextCol, + traitCol +) { + if (length(multivariateTokens) == 0L) { return(invisible(NULL)) } groupKey <- str_c( - p$studyCol[p$selRows], - p$traitCol[p$selRows], + studyCol[selRows], + traitCol[selRows], sep = "||" ) - perGroupNCtx <- map_int(split(p$contextCol[p$selRows], groupKey), length) + perGroupNCtx <- map_int(split(contextCol[selRows], groupKey), length) if (all(perGroupNCtx < 2L)) { - mvStr <- str_flatten(p$multivariateTokens, ", ") + mvStr <- str_flatten(multivariateTokens, ", ") msg <- glue( "twasWeightsPipeline(QtlSumStats): multivariate method(s) ", "{mvStr} require at least two contexts per (study, trait); the ", @@ -1713,28 +2175,31 @@ setMethod( if (!is.null(adapter) || tk != "mrmash") { return(userArgs) } - if (is.null(userArgs$retainFit)) { - userArgs$retainFit <- TRUE - } - if (is.null(userArgs$fitDetail)) { - userArgs$fitDetail <- retainFitDetail - } - userArgs + list_assign( + userArgs, + !!!compact(list( + retainFit = if (is.null(userArgs$retainFit)) TRUE, + fitDetail = if (is.null(userArgs$fitDetail)) retainFitDetail + )) + ) } # Run a weight function, warning (with `errPrefix`) and returning NULL on error. # @noRd +#' @importFrom rlang try_fetch .twasTryWeights <- function(fn, stat, ldMat, userArgs, errPrefix) { - tryCatch( + try_fetch( { wfn <- get(fn, mode = "function") - wArgs <- c(list(stat = stat, LD = ldMat), userArgs) + wArgs <- .twasWeightCallArgs( + fn, + list(stat = stat, LD = ldMat), + userArgs + ) exec(wfn, !!!wArgs) }, - error = function(e) { - eMsg <- conditionMessage(e) - msg <- glue("{errPrefix}{eMsg}") - warn(msg) + error = function(cnd) { + warn(errPrefix, parent = cnd) NULL } ) @@ -1742,26 +2207,72 @@ setMethod( # ---- Univariate dispatch: per (study, context, trait), per method ---------- -.twasQssUnivariateRows <- function(p) { - if (length(p$univariateTokens) == 0L) { +.twasQssUnivariateRows <- function( + selRows, + univariateTokens, + studyCol, + contextCol, + traitCol, + data, + ldSketch, + twasWeights, + dataType, + fineMappingResult, + methodArgs, + mafCutoff, + macCutoff, + imissCutoff +) { + if (length(univariateTokens) == 0L) { return(list()) } - list_flatten(map(p$selRows, .twasQssUnivariateRowsForEntry, p = p)) + list_flatten(map( + selRows, + .twasQssUnivariateRowsForEntry, + univariateTokens = univariateTokens, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol, + data = data, + ldSketch = ldSketch, + twasWeights = twasWeights, + dataType = dataType, + fineMappingResult = fineMappingResult, + methodArgs = methodArgs, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + )) } # Cached + freshly-fitted rows for one sumstats entry. Resume cache: pull cached # entries up front and reduce the per-entry fit work to the un-cached tokens. # @noRd -.twasQssUnivariateRowsForEntry <- function(i, p) { - st <- p$studyCol[i] - ctx <- p$contextCol[i] - tr <- p$traitCol[i] +.twasQssUnivariateRowsForEntry <- function( + i, + univariateTokens, + studyCol, + contextCol, + traitCol, + data, + ldSketch, + twasWeights, + dataType, + fineMappingResult, + methodArgs, + mafCutoff, + macCutoff, + imissCutoff +) { + st <- studyCol[i] + ctx <- contextCol[i] + tr <- traitCol[i] cacheHits <- .twasResolveCacheHits( - p$twasWeights, + twasWeights, st, ctx, tr, - p$univariateTokens + univariateTokens ) cachedRows <- imap( cacheHits, @@ -1770,17 +2281,17 @@ setMethod( ctx = ctx, tr = tr ) - toFit <- setdiff(p$univariateTokens, names(cacheHits)) + toFit <- setdiff(univariateTokens, names(cacheHits)) if (length(toFit) == 0L) { return(unname(cachedRows)) } fitCtx <- .twasQssUnivariateFitCtx( - p$data, + data, st, ctx, tr, - p$ldSketch, - cutoffs = .panelCutoffs(p) + ldSketch, + cutoffs = .panelCutoffs(mafCutoff, macCutoff, imissCutoff) ) fitted <- compact(map( toFit, @@ -1789,7 +2300,9 @@ setMethod( ctx = ctx, tr = tr, fitCtx = fitCtx, - p = p + methodArgs = methodArgs, + fineMappingResult = fineMappingResult, + dataType = dataType )) c(unname(cachedRows), fitted) } @@ -1821,7 +2334,7 @@ setMethod( ldSketch, cutoffs = NULL ) { - df <- getSumStatsDf( + allDf <- getSumStatsDf( data, study = st, context = ctx, @@ -1836,16 +2349,13 @@ setMethod( "twasWeightsPipeline(QtlSumStats): study='{st}', ", "context='{ctx}', trait='{tr}'" ) - df <- df[ - .panelKeepMask(df$variant_id, ldSketch, cutoffs, label), + df <- allDf[ + .panelKeepMask(allDf$variant_id, ldSketch, cutoffs, label), , drop = FALSE ] variantIds <- df$variant_id - varY <- getVarY(data, study = st, context = ctx, trait = tr) - if (is.null(varY)) { - varY <- 1 - } + varY <- getVarY(data, study = st, context = ctx, trait = tr) %||% 1 stat <- list( z = df$z, n = stats::median(df$N, na.rm = TRUE), @@ -1865,25 +2375,40 @@ setMethod( # Fit one univariate method for one entry -> a row record, or NULL on skip. # @noRd -.twasQssUnivariateFitOne <- function(tk, st, ctx, tr, fitCtx, p) { +.twasQssUnivariateFitOne <- function( + tk, + st, + ctx, + tr, + fitCtx, + methodArgs, + fineMappingResult, + dataType +) { spec <- .twasResolveWeightFn(tk) - userArgs <- .twasUserArgs(p$methodArgs, tk) + baseArgs <- .twasUserArgs(methodArgs, tk) # When the token is a fine-mapping method, pass the precomputed fit into the # *Rss weight function via its dedicated *Fit arg. The gate above ensures # fineMappingResult is non-NULL here. - if (!is.null(spec$adapter)) { - fit <- .twasFineMappingFitFor( - p$fineMappingResult, + fit <- if (is.null(spec$adapter)) { + NULL + } else { + .twasFineMappingFitFor( + fineMappingResult, study = st, context = ctx, trait = tr, token = tk ) - if (is.null(fit)) { - .twasWarnNoFitUniv(tk, st, ctx, tr) - return(NULL) - } - userArgs[[spec$adapter$rssFitArg]] <- fit + } + if (!is.null(spec$adapter) && is.null(fit)) { + .twasWarnNoFitUniv(tk, st, ctx, tr) + return(NULL) + } + userArgs <- if (is.null(fit)) { + baseArgs + } else { + list_assign(baseArgs, !!!set_names(list(fit), spec$adapter$rssFitArg)) } weights <- .twasTryWeights( spec$fn, @@ -1896,7 +2421,7 @@ setMethod( return(NULL) } fitAttr <- attr(weights, "fit") - attr(weights, "fit") <- NULL + bare <- `attr<-`(weights, "fit", NULL) .twasRowRecord( st, ctx, @@ -1904,11 +2429,11 @@ setMethod( tk, twasWeightsRow( variantIds = fitCtx$variantIds, - weights = as.numeric(weights), + weights = as.numeric(bare), fits = fitAttr, cvResult = NULL, standardized = TRUE, - dataType = p$dataType + dataType = dataType ) ) } @@ -1935,50 +2460,99 @@ setMethod( # ---- Multivariate dispatch: per (study, trait), all selected contexts ------ -.twasQssMultivariateRows <- function(p) { - if (length(p$multivariateTokens) == 0L) { +.twasQssMultivariateRows <- function( + selRows, + multivariateTokens, + studyCol, + contextCol, + traitCol, + data, + ldSketch, + methodArgs, + retainFitDetail, + fineMappingResult, + dataType, + mafCutoff, + macCutoff, + imissCutoff +) { + if (length(multivariateTokens) == 0L) { return(list()) } groupKey <- str_c( - p$studyCol[p$selRows], - p$traitCol[p$selRows], + studyCol[selRows], + traitCol[selRows], sep = "||" ) - groups <- split(p$selRows, groupKey) - list_flatten(map(groups, .twasQssMultivariateGroupRows, p = p)) + groups <- split(selRows, groupKey) + list_flatten(map( + groups, + .twasQssMultivariateGroupRows, + multivariateTokens = multivariateTokens, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol, + data = data, + ldSketch = ldSketch, + methodArgs = methodArgs, + retainFitDetail = retainFitDetail, + fineMappingResult = fineMappingResult, + dataType = dataType, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + )) } # Multivariate rows for one (study, trait) group across its contexts. # @noRd -.twasQssMultivariateGroupRows <- function(gIdx, p) { +.twasQssMultivariateGroupRows <- function( + gIdx, + multivariateTokens, + studyCol, + contextCol, + traitCol, + data, + ldSketch, + methodArgs, + retainFitDetail, + fineMappingResult, + dataType, + mafCutoff, + macCutoff, + imissCutoff +) { if (length(gIdx) < 2L) { return(list()) } - st <- p$studyCol[gIdx[[1L]]] - tr <- p$traitCol[gIdx[[1L]]] - ctxNames <- p$contextCol[gIdx] + st <- studyCol[gIdx[[1L]]] + tr <- traitCol[gIdx[[1L]]] + ctxNames <- contextCol[gIdx] mvStat <- .twasQssMultivariateStat( - p$data, + data, st, tr, ctxNames, - ldSketch = p$ldSketch, - cutoffs = .panelCutoffs(p) + ldSketch = ldSketch, + cutoffs = .panelCutoffs(mafCutoff, macCutoff, imissCutoff) ) ldMat <- .ldFromSketch( - p$ldSketch, + ldSketch, mvStat$variantIds, label = "twasWeightsPipeline" ) list_flatten(map( - p$multivariateTokens, + multivariateTokens, .twasQssMultivariateFitOne, st = st, tr = tr, ctxNames = ctxNames, mvStat = mvStat, ldMat = ldMat, - p = p + methodArgs = methodArgs, + retainFitDetail = retainFitDetail, + fineMappingResult = fineMappingResult, + dataType = dataType )) } @@ -1994,7 +2568,7 @@ setMethod( ldSketch = NULL, cutoffs = NULL ) { - firstDf <- getSumStatsDf( + allDf <- getSumStatsDf( data, study = st, context = ctxNames[[1L]], @@ -2009,16 +2583,10 @@ setMethod( "twasWeightsPipeline(QtlSumStats, multivariate): study='{st}', ", "trait='{tr}'" ) - keep <- .panelKeepMask(firstDf$variant_id, ldSketch, cutoffs, label) - firstDf <- firstDf[keep, , drop = FALSE] + keep <- .panelKeepMask(allDf$variant_id, ldSketch, cutoffs, label) + firstDf <- allDf[keep, , drop = FALSE] variantIds <- firstDf$variant_id - Z <- matrix( - NA_real_, - nrow = length(variantIds), - ncol = length(ctxNames), - dimnames = list(variantIds, ctxNames) - ) - filled <- .twasQssFillContexts(data, st, tr, ctxNames, variantIds, Z) + filled <- .twasQssFillContexts(data, st, tr, ctxNames, variantIds) list( variantIds = variantIds, stat = list( @@ -2034,24 +2602,43 @@ setMethod( # position, not by name, so a differing order would silently pair one context's # variant with another's. # @noRd -.twasQssFillContexts <- function(data, st, tr, ctxNames, variantIds, Z) { - nVec <- numeric(length(ctxNames)) - for (kk in seq_along(ctxNames)) { - d <- getSumStatsDf( - data, - study = st, - context = ctxNames[[kk]], - trait = tr, - require = c("Z", "N"), - derive = "zFromBetaSe" - ) - d <- d[is_in(d$variant_id, variantIds), , drop = FALSE] - .twasQssCheckSnpOrder(d$variant_id, variantIds, st, tr) - Z[, kk] <- d$z - nVec[kk] <- stats::median(d$N, na.rm = TRUE) - } - names(nVec) <- ctxNames - list(z = Z, n = nVec) +# One context's z column and median N, checked against the shared SNP order. +# @noRd +.twasQssContextStats <- function(ctx, data, st, tr, variantIds) { + d <- getSumStatsDf( + data, + study = st, + context = ctx, + trait = tr, + require = c("Z", "N"), + derive = "zFromBetaSe" + ) + kept <- d[is_in(d$variant_id, variantIds), , drop = FALSE] + .twasQssCheckSnpOrder(kept$variant_id, variantIds, st, tr) + list(z = kept$z, n = stats::median(kept$N, na.rm = TRUE)) +} + +# Every context shares one SNP order (asserted per context), which is what +# lets the columns simply be laid side by side rather than filled into a +# preallocated matrix. +.twasQssFillContexts <- function(data, st, tr, ctxNames, variantIds) { + stats <- map( + ctxNames, + .twasQssContextStats, + data = data, + st = st, + tr = tr, + variantIds = variantIds + ) + list( + z = matrix( + unname(list_c(map(stats, "z"))), + nrow = length(variantIds), + ncol = length(ctxNames), + dimnames = list(variantIds, ctxNames) + ), + n = set_names(map_dbl(stats, "n"), ctxNames) + ) } # @noRd @@ -2070,20 +2657,42 @@ setMethod( # Fit one multivariate method for a group -> one row record per context (empty # list on skip). # @noRd -.twasQssMultivariateFitOne <- function(tk, st, tr, ctxNames, mvStat, ldMat, p) { +.twasQssMultivariateFitOne <- function( + tk, + st, + tr, + ctxNames, + mvStat, + ldMat, + methodArgs, + retainFitDetail, + fineMappingResult, + dataType +) { spec <- .twasResolveWeightFn(tk) - userArgs <- .twasMrmashRetainDefaults( - .twasUserArgs(p$methodArgs, tk), + baseArgs <- .twasMrmashRetainDefaults( + .twasUserArgs(methodArgs, tk), spec$adapter, tk, - p$retainFitDetail + retainFitDetail ) # mvsusie is fine-mapping; thread its pre-fit through (mr.mash is not). - if (!is.null(spec$adapter)) { - userArgs <- .twasMvThreadFit(spec, userArgs, tk, st, tr, ctxNames, p) - if (is.null(userArgs)) { - return(list()) - } + userArgs <- if (is.null(spec$adapter)) { + baseArgs + } else { + .twasMvThreadFit( + spec, + baseArgs, + tk, + st, + tr, + ctxNames, + fineMappingResult + ) + } + # .twasMvThreadFit answers NULL when the pre-fit it needs is missing. + if (is.null(userArgs)) { + return(list()) } weights <- .twasTryWeights( spec$fn, @@ -2095,29 +2704,35 @@ setMethod( if (is.null(weights)) { return(list()) } - if (!is.matrix(weights)) { - weights <- as.matrix(weights) - } - fitAttr <- attr(weights, "fit") - attr(weights, "fit") <- NULL + wMatrix <- if (is.matrix(weights)) weights else as.matrix(weights) + fitAttr <- attr(wMatrix, "fit") + bare <- `attr<-`(wMatrix, "fit", NULL) .twasMvContextRows( - weights, + bare, fitAttr, ctxNames, mvStat, st, tr, tk, - p$dataType + dataType ) } # Thread the precomputed fine-mapping fit into a multivariate method's args; # returns NULL (signalling skip) when the fit is absent. # @noRd -.twasMvThreadFit <- function(spec, userArgs, tk, st, tr, ctxNames, p) { +.twasMvThreadFit <- function( + spec, + userArgs, + tk, + st, + tr, + ctxNames, + fineMappingResult +) { fit <- .twasFineMappingFitFor( - p$fineMappingResult, + fineMappingResult, study = st, context = ctxNames[[1L]], trait = tr, @@ -2127,8 +2742,7 @@ setMethod( .twasWarnNoFitMv(tk, st, tr) return(NULL) } - userArgs[[spec$adapter$rssFitArg]] <- fit - userArgs + list_assign(userArgs, !!!set_names(list(fit), spec$adapter$rssFitArg)) } # Warning for a missing multivariate fine-mapping fit. @@ -2181,8 +2795,12 @@ setMethod( # Combine the per-tuple result with any joint result (error if both empty). # @noRd -.twasQssAssemble <- function(rows, jointResult, p) { - perTupleResult <- .twasRowsToWeights(rows, p$ldSketch) +.twasQssAssemble <- function( + rows, + jointResult, + ldSketch +) { + perTupleResult <- .twasRowsToWeights(rows, ldSketch) if (is.null(jointResult)) { if (is.null(perTupleResult)) { msg <- glue( @@ -2196,7 +2814,7 @@ setMethod( if (is.null(perTupleResult)) { return(jointResult) } - .rbindTwasWeights(perTupleResult, jointResult, ldSketch = p$ldSketch) + .rbindTwasWeights(perTupleResult, jointResult, ldSketch = ldSketch) } @@ -2283,9 +2901,24 @@ setMethod( ) { naAction <- arg_match(naAction) retainFitDetail <- arg_match(retainFitDetail) - p <- as.list(environment()) - p$dots <- list(...) - .twasPipelineMultiStudy(p) + .twasPipelineMultiStudy( + data = data, + region = region, + cisWindow = cisWindow, + jointRegions = jointRegions, + jointSpecification = jointSpecification, + methods = methods, + fineMappingResult = fineMappingResult, + contexts = contexts, + traitId = traitId, + verbose = verbose, + retainFit = retainFit, + retainFitDetail = retainFitDetail, + seed = seed, + twasWeights = twasWeights, + naAction = naAction, + dots = list(...) + ) } ) @@ -2322,54 +2955,110 @@ setMethod( (is.character(methods) || is.list(methods)) && length(methods) == 0L } -.twasPipelineMultiStudy <- function(p) { - if (!is.null(p$region) && !is.null(p$cisWindow)) { +.twasPipelineMultiStudy <- function( + data, + region, + cisWindow, + jointRegions, + jointSpecification, + methods, + fineMappingResult, + contexts, + traitId, + verbose, + retainFit, + retainFitDetail, + seed, + twasWeights, + naAction, + dots +) { + if (!is.null(region) && !is.null(cisWindow)) { msg <- glue( "twasWeightsPipeline(MultiStudyQtlDataset): specify either ", "`region` or `cisWindow`, not both." ) abort(msg) } - xRegions <- .makeXRegions(p$region, p$jointRegions) - parsedJointSpec <- parseJointSpecification(p$jointSpecification, p$data) + xRegions <- .makeXRegions(region, jointRegions) + parsedJointSpec <- parseJointSpecification(jointSpecification, data) # Gate fine-mapping methods early so the recursion into the embedded # QtlDataset / QtlSumStats components doesn't re-run fine-mapping. .twasCheckFineMappingMethods( - .twasMethodTokensFromArg(p$methods), - p$fineMappingResult, + .twasMethodTokensFromArg(methods), + fineMappingResult, "MultiStudyQtlDataset" ) - joint <- .twasMsJointPhase(p, parsedJointSpec, xRegions) + joint <- .twasMsJointPhase( + parsedJointSpec, + xRegions, + data = data, + methods = methods, + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + verbose = verbose, + retainFit = retainFit, + retainFitDetail = retainFitDetail, + seed = seed + ) if (joint$done) { return(joint$result) } - .twasMsDriver(p, joint$result, joint$methods) + .twasMsDriver( + data = data, + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + region = region, + jointRegions = jointRegions, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + naAction = naAction, + verbose = verbose, + seed = seed, + dots = dots, + joint$result, + joint$methods + ) } # Joint-specification dispatch for mrmash. Returns list(done, result, methods) # where `done` requests an early return with `result` and `methods` is the # mrmash-stripped set for the per-component recursion. # @noRd -.twasMsJointPhase <- function(p, parsedJointSpec, xRegions) { +.twasMsJointPhase <- function( + parsedJointSpec, + xRegions, + data, + methods, + contexts, + traitId, + cisWindow, + verbose, + retainFit, + retainFitDetail, + seed +) { if (length(parsedJointSpec) == 0L) { - return(list(done = FALSE, result = NULL, methods = p$methods)) + return(list(done = FALSE, result = NULL, methods = methods)) } - jointMethods <- intersect(.twasMethodTokensFromArg(p$methods), "mrmash") + jointMethods <- intersect(.twasMethodTokensFromArg(methods), "mrmash") jointResult <- .twasDispatchJointSpecsMultiStudy( parsedJointSpec, - p$data, + data, jointMethods, - p$contexts, - p$traitId, - p$cisWindow, + contexts, + traitId, + cisWindow, NULL, - p$verbose, + verbose, xRegions = xRegions, - retainFit = p$retainFit, - retainFitDetail = p$retainFitDetail, - seed = p$seed + retainFit = retainFit, + retainFitDetail = retainFitDetail, + seed = seed ) - methods <- .twasMsStripMrmash(p$methods) + methods <- .twasMsStripMrmash(methods) if (.twasMethodsEmpty(methods)) { if (is.null(jointResult)) { msg <- glue( @@ -2385,23 +3074,38 @@ setMethod( # Run the per-study / per-component recursion via the shared multi-study driver. # @noRd -.twasMsDriver <- function(p, jointResult, methods) { +.twasMsDriver <- function( + data, + contexts, + traitId, + cisWindow, + region, + jointRegions, + fineMappingResult, + twasWeights, + naAction, + verbose, + seed, + dots, + jointResult, + methods +) { cfg <- list( methods = methods, - contexts = p$contexts, - traitId = p$traitId, - region = p$region, - cisWindow = p$cisWindow, - jointRegions = p$jointRegions, - fineMappingResult = p$fineMappingResult, - twasWeights = p$twasWeights, - naAction = p$naAction, - verbose = p$verbose, - seed = p$seed, - dotArgs = p$dots + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + jointRegions = jointRegions, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + naAction = naAction, + verbose = verbose, + seed = seed, + dotArgs = dots ) .multiStudyPipelineDriver( - p$data, + data, jointResult, .twasPerStudy, .twasSumStats, @@ -2442,32 +3146,27 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { # @noRd .solveEnsembleQuadprog <- function(Pvalid, yObs, Kvalid) { if (!requireNamespace("quadprog", quietly = TRUE)) { - msg <- glue( - "Package 'quadprog' is required for solver='quadprog'. ", - "Install with: install.packages('quadprog')" - ) - abort(msg) + abort("Package 'quadprog' is required for solver='quadprog'.") } - Dmat <- crossprod(Pvalid) + gram <- crossprod(Pvalid) dvec <- as.vector(crossprod(Pvalid, yObs)) # Ridge term for numerical stability (small relative to trace) - Dmat <- Dmat + 1e-8 * mean(diag(Dmat)) * diag(Kvalid) + Dmat <- gram + 1e-8 * mean(diag(gram)) * diag(Kvalid) # Constraint matrix: first constraint is equality (sum = 1), then Kvalid # non-negativity constraints. Amat <- cbind(rep(1, Kvalid), diag(Kvalid)) bvec <- c(1, rep(0, Kvalid)) - qpSol <- tryCatch( + qpSol <- try_fetch( solve.QP(Dmat = Dmat, dvec = dvec, Amat = Amat, bvec = bvec, meq = 1), - error = function(e) { - eMsg <- conditionMessage(e) + error = function(cnd) { msg <- glue( - "QP solver failed: {eMsg}. Falling back to equal weights ", - "among valid methods." + "QP solver failed. Falling back to equal weights among ", + "valid methods." ) - warn(msg) + warn(msg, parent = cnd) NULL } ) @@ -2495,21 +3194,14 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { # @noRd .solveEnsembleNnls <- function(Pvalid, yObs, Kvalid) { if (!requireNamespace("nnls", quietly = TRUE)) { - msg <- glue( - "Package 'nnls' is required for solver='nnls'. ", - "Install with: install.packages('nnls')" - ) - abort(msg) + abort("Package 'nnls' is required for solver='nnls'.") } - fit <- tryCatch( + fit <- try_fetch( nnls::nnls(Pvalid, yObs), - error = function(e) { - eMsg <- conditionMessage(e) - msg <- glue( - "NNLS solver failed: {eMsg}. Falling back to equal weights." - ) - warn(msg) + error = function(cnd) { + msg <- "NNLS solver failed. Falling back to equal weights." + warn(msg, parent = cnd) NULL } ) @@ -2532,12 +3224,24 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { # Ensemble stacking objective (sum of squared residuals). `...` absorbs the # gradient's extra optim args (PtP, Pty). # @noRd -.ensembleObj <- function(z, Pvalid, yObs, ...) sum((yObs - Pvalid %*% z)^2) +.ensembleObj <- function(Pvalid, yObs) { + # Captured by name, and forced here so the closure holds values rather + # than promises into a frame that has already returned. + force(Pvalid) + force(yObs) + function(z) sum((yObs - Pvalid %*% z)^2) +} -# Gradient of the ensemble stacking objective. `...` absorbs the objective's -# extra optim args (Pvalid, yObs). +# Gradient of the ensemble stacking objective, same construction. Building +# both as closures of exactly what each needs is what lets optim() be called +# with no `...`: previously it forwarded the union of both callbacks' +# arguments to both, and each absorbed the other's half in a `...` tail. # @noRd -.ensembleGrad <- function(z, PtP, Pty, ...) as.vector(2 * (PtP %*% z - Pty)) +.ensembleGrad <- function(PtP, Pty) { + force(PtP) + force(Pty) + function(z) as.vector(2 * (PtP %*% z - Pty)) +} # Solve ensemble stacking via L-BFGS-B (box-constrained optimization, then # normalize). Uses base R optim() with analytical gradient. No extra @@ -2551,25 +3255,19 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { PtP <- crossprod(Pvalid) Pty <- as.vector(crossprod(Pvalid, yObs)) - fit <- tryCatch( + fit <- try_fetch( optim( par = rep(1 / Kvalid, Kvalid), - fn = .ensembleObj, - gr = .ensembleGrad, - Pvalid = Pvalid, - yObs = yObs, - PtP = PtP, - Pty = Pty, + fn = .ensembleObj(Pvalid, yObs), + gr = .ensembleGrad(PtP, Pty), method = "L-BFGS-B", lower = rep(0, Kvalid) ), - error = function(e) { - eMsg <- conditionMessage(e) + error = function(cnd) { msg <- glue( - "L-BFGS-B solver failed: {eMsg}. Falling back to equal ", - "weights." + "L-BFGS-B solver failed. Falling back to equal weights." ) - warn(msg) + warn(msg, parent = cnd) NULL } ) @@ -2602,14 +3300,10 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { # @noRd .solveEnsembleGlmnet <- function(Pvalid, yObs, Kvalid, alpha = 1) { if (!requireNamespace("glmnet", quietly = TRUE)) { - msg <- glue( - "Package 'glmnet' is required for solver='glmnet'. ", - "Install with: install.packages('glmnet')" - ) - abort(msg) + abort("Package 'glmnet' is required for solver='glmnet'.") } - fit <- tryCatch( + fit <- try_fetch( glmnet::cv.glmnet( x = Pvalid, y = yObs, @@ -2617,13 +3311,11 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { alpha = alpha, intercept = FALSE ), - error = function(e) { - eMsg <- conditionMessage(e) + error = function(cnd) { msg <- glue( - "glmnet solver failed: {eMsg}. Falling back to equal ", - "weights." + "glmnet solver failed. Falling back to equal weights." ) - warn(msg) + warn(msg, parent = cnd) NULL } ) @@ -2632,8 +3324,8 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { return(rep(1 / Kvalid, Kvalid)) } - zetaValid <- as.numeric(coef(fit, s = "lambda.min"))[-1] # drop intercept - zetaValid <- pmax(zetaValid, 0) + # [-1] drops the intercept. + zetaValid <- pmax(as.numeric(coef(fit, s = "lambda.min"))[-1], 0) zetaSum <- sum(zetaValid) if (zetaSum <= 0) { warn( @@ -2787,6 +3479,7 @@ ensembleWeights <- function( # Validate the required scalar / presence constraints on the raw inputs. # @noRd +#' @importFrom checkmate assertCount .ensembleValidateArgs <- function(cvResults, Y, contextIndex) { if (is.null(cvResults)) { abort("'cvResults' is required.") @@ -2794,13 +3487,7 @@ ensembleWeights <- function( if (is.null(Y)) { abort("'Y' is required.") } - if ( - !is.numeric(contextIndex) || - length(contextIndex) != 1 || - contextIndex < 1 - ) { - abort("'contextIndex' must be a positive integer scalar.") - } + assertCount(contextIndex, positive = TRUE) invisible(NULL) } @@ -3000,30 +3687,45 @@ ensembleWeights <- function( # Assemble one dataset's (samples x methods) prediction matrix. # @noRd -.ensembleBuildPd <- function(predsD, nm, aln, contextIndex, d) { - Pd <- matrix(NA_real_, nrow = aln$nD, ncol = nm$K) - colnames(Pd) <- nm$baseNames - for (k in seq_along(nm$predNames)) { - predMat <- predsD[[nm$predNames[k]]] - pCol <- if (is.matrix(predMat)) { - predMat[aln$predOrder, contextIndex] - } else { - as.numeric(predMat)[aln$predOrder] - } - if (length(pCol) != aln$nD) { - methodName <- nm$predNames[k] - nCol <- length(pCol) - nAligned <- aln$nD - msg <- glue( - "Prediction length for method '{methodName}' in dataset ", - "{d} ({nCol}) does not match number of aligned samples ", - "({nAligned})." - ) - abort(msg) - } - Pd[, k] <- pCol +# One method's aligned prediction column for dataset `d`. +# @noRd +.ensemblePredColumn <- function(k, predsD, nm, aln, contextIndex, d) { + methodName <- nm$predNames[k] + predMat <- predsD[[methodName]] + pCol <- if (is.matrix(predMat)) { + predMat[aln$predOrder, contextIndex] + } else { + as.numeric(predMat)[aln$predOrder] + } + if (length(pCol) != aln$nD) { + nCol <- length(pCol) + nAligned <- aln$nD + msg <- glue( + "Prediction length for method '{methodName}' in dataset ", + "{d} ({nCol}) does not match number of aligned samples ", + "({nAligned})." + ) + abort(msg) } - Pd + pCol +} + +.ensembleBuildPd <- function(predsD, nm, aln, contextIndex, d) { + cols <- map( + seq_along(nm$predNames), + .ensemblePredColumn, + predsD = predsD, + nm = nm, + aln = aln, + contextIndex = contextIndex, + d = d + ) + matrix( + unname(list_c(cols)), + nrow = aln$nD, + ncol = nm$K, + dimnames = list(NULL, nm$baseNames) + ) } # Drop rows with any NA prediction/outcome; error when too few remain. @@ -3073,18 +3775,14 @@ ensembleWeights <- function( solver, alpha ) - zeta <- rep(0, nm$K) - zeta[validMethods] <- zetaValid - names(zeta) <- nm$baseNames - zeta + zeta <- replace(rep(0, nm$K), validMethods, zetaValid) + set_names(zeta, nm$baseNames) } # Degenerate case: a single signal-bearing method takes full weight. # @noRd .ensembleSingleMethodZeta <- function(validMethods, baseNames, K) { - zeta <- rep(0, K) - zeta[validMethods] <- 1 - names(zeta) <- baseNames + zeta <- set_names(replace(rep(0, K), validMethods, 1), baseNames) methodName <- baseNames[validMethods] msg <- glue( "Only one method ('{methodName}') has non-zero variance ", @@ -3160,24 +3858,45 @@ ensembleWeights <- function( # Zeta-weighted sum of the matched weight matrices; univariate -> named vector. # @noRd +# One method's zeta-scaled contribution, or NULL when its weight matrix does +# not line up with the first one's shape. +# @noRd +.ensembleWeightTerm <- function(i, wtList, wtKeys, zeta, shape) { + wMat <- .ensembleAsMatrix(wtList[[wtKeys[i]]]) + if (!identical(dim(wMat), shape)) { + wtKey <- wtKeys[i] + msg <- glue( + "Weight matrix for '{wtKey}' has inconsistent dimensions; ", + "skipping." + ) + warn(msg) + return(NULL) + } + zeta[i] * wMat +} + .ensembleAccumulateWeights <- function(wtList, wtKeys, matched, zeta) { firstWt <- .ensembleAsMatrix(wtList[[wtKeys[which(matched)[1]]]]) - ensembleTwasWt <- matrix(0, nrow = nrow(firstWt), ncol = ncol(firstWt)) - rownames(ensembleTwasWt) <- rownames(firstWt) - colnames(ensembleTwasWt) <- colnames(firstWt) - for (i in which(matched)) { - wMat <- .ensembleAsMatrix(wtList[[wtKeys[i]]]) - if (!identical(dim(wMat), dim(ensembleTwasWt))) { - wtKey <- wtKeys[i] - msg <- glue( - "Weight matrix for '{wtKey}' has inconsistent dimensions; ", - "skipping." - ) - warn(msg) - next - } - ensembleTwasWt <- ensembleTwasWt + zeta[i] * wMat - } + shape <- dim(firstWt) + # The ensemble is the sum of the scaled contributions, so it is a fold + # over them rather than a matrix added into repeatedly. + ensembleTwasWt <- reduce( + compact(map( + which(matched), + .ensembleWeightTerm, + wtList = wtList, + wtKeys = wtKeys, + zeta = zeta, + shape = shape + )), + `+`, + .init = matrix( + 0, + nrow = nrow(firstWt), + ncol = ncol(firstWt), + dimnames = dimnames(firstWt) + ) + ) # For the univariate case, return as a named vector. if (ncol(ensembleTwasWt) == 1) { return(set_names(as.numeric(ensembleTwasWt), rownames(ensembleTwasWt))) @@ -3292,16 +4011,40 @@ ensembleWeights <- function( } } -# One region's univariate joint-cell fit (region `bi` of p$xRegions). +# One region's univariate joint-cell fit (region `bi` of `xRegions`). # @noRd -.twasQdsUnivRegion <- function(bi, univCell, p, scope) { +.twasQdsUnivRegion <- function( + bi, + univCell, + scope, + marker, + data, + xRegions, + norm, + fineMappingResult, + twasWeights, + dataDrivenPriorMatricesCv, + cisWindow, + naAction, + verbose +) { .runJointCell( univCell, - p$marker, - p$data, + marker, + data, scope, - p$norm$tokens, - args = .twasQdsUnivArgs(p, bi) + norm$tokens, + args = .twasQdsUnivArgs( + bi, + xRegions = xRegions, + norm = norm, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + naAction = naAction, + verbose = verbose + ) ) } diff --git a/R/twasWeightsRow.R b/R/twasWeightsRow.R index c96120d2..a0729e13 100644 --- a/R/twasWeightsRow.R +++ b/R/twasWeightsRow.R @@ -41,30 +41,25 @@ setClass( ) ) +#' @importFrom checkmate makeAssertCollection assert assertFlag +#' @importFrom checkmate checkNumeric checkMatrix methods::setValidity("TwasWeightsRow", function(object) { - errors <- character(0) + coll <- makeAssertCollection() w <- object@weights n <- length(object@variants) if (!is.null(w)) { # A matrix carries one ROW per variant (columns are conditions), so # the two shapes need separate checks -- validating only the vector # case would let a mis-sized matrix through. - if (is.null(dim(w)) && length(w) != n) { - errors <- c( - errors, - "length(weights) must equal length(variantIds)" - ) - } else if (!is.null(dim(w)) && nrow(w) != n) { - errors <- c( - errors, - "nrow(weights) must equal length(variantIds)" - ) - } - } - if (length(object@standardized) != 1L || is.na(object@standardized)) { - errors <- c(errors, "'standardized' must be a single logical value") + assert( + checkNumeric(w, len = n), + checkMatrix(w, nrows = n), + .var.name = "weights", + add = coll + ) } - if (length(errors) == 0L) TRUE else errors + assertFlag(object@standardized, .var.name = "standardized", add = coll) + coll$getMessages() }) #' @title Build One TWAS-Weight Row @@ -117,10 +112,13 @@ twasWeightsRow <- function( ) abort(msg) } - mcols(gr)$weight <- w + withWeight <- S4Vectors::`mcols<-`( + gr, + value = `[[<-`(mcols(gr, use.names = FALSE), "weight", value = w) + ) obj <- new( "TwasWeightsRow", - variants = gr, + variants = withWeight, weights = w, fits = fits, cvResult = cvResult, diff --git a/R/variantId.R b/R/variantId.R index af71ee71..a8f8e70e 100644 --- a/R/variantId.R +++ b/R/variantId.R @@ -31,15 +31,22 @@ stripChrPrefix <- function(x) str_remove(x, "^chr") #' @return Character vector of normalized chromosome names. #' @noRd canonChrom <- function(x) { - x <- as.character(x) - x <- str_remove(x, regex("^chr", ignore_case = TRUE)) - x <- str_remove(x, regex("^ch", ignore_case = TRUE)) - x <- str_to_upper(x) + bare <- as.character(x) |> + str_remove(regex("^chr", ignore_case = TRUE)) |> + str_remove(regex("^ch", ignore_case = TRUE)) |> + str_to_upper() + canonChromLabel(bare) +} + +# Fold the numeric / abbreviated synonyms of the non-autosomes onto their +# canonical labels. NA passes through as NA. +# @noRd +canonChromLabel <- function(x) { ok <- !is.na(x) - x[ok & x == "23"] <- "X" - x[ok & x == "24"] <- "Y" - x[ok & x == "M"] <- "MT" - x + x |> + replace(ok & x == "23", "X") |> + replace(ok & x == "24", "Y") |> + replace(ok & x == "M", "MT") } #' Ensure a leading chr prefix on a chromosome identifier. @@ -139,14 +146,17 @@ isSnpAlleles <- function(a1, a2) { if (!any(repair)) { return(ids) } - ids[repair] <- formatVariantId( - p$chrom[repair], - p$pos[repair], - A2[repair], - A1[repair], - convention = attr(p, "convention") + replace( + ids, + repair, + formatVariantId( + p$chrom[repair], + p$pos[repair], + A2[repair], + A1[repair], + convention = attr(p, "convention") + ) ) - ids } # Backwards-compat alias @@ -227,8 +237,15 @@ detectVariantConvention <- function(ids) { #' stored as \code{attr(result, "convention")}. #' @examples #' parseVariantId(c("chr1:100:A:G", "chr2:200:T:C")) +#' @importFrom checkmate assert checkCharacter checkDataFrame #' @export parseVariantId <- function(ids) { + # `ids` is documented as a character vector OR a data.frame. + assert( + checkCharacter(ids), + checkDataFrame(ids), + .var.name = "ids" + ) if (is.data.frame(ids)) { return(.parseVariantIdDf(ids)) } @@ -244,8 +261,18 @@ parseVariantId <- function(ids) { A2 = m[, 4L], A1 = m[, 5L] ) - attr(data, "convention") <- convention - data + `attr<-`(data, "convention", convention) +} + +# `[[<-` rather than mutate(): callers hand this frame straight through from +# a user-supplied table, which may carry NA or "" column names -- and +# dplyr refuses to transform such a frame at all. +# @noRd +.withCanonicalCoords <- function(ids) { + # `value =` named: tibble's `[[<-` method carries an extra `j` formal, so a + # third POSITIONAL argument binds to `j` and the write silently misfires. + coerced <- `[[<-`(ids, "chrom", value = canonChrom(ids$chrom)) + `[[<-`(coerced, "pos", value = as.integer(ids$pos)) } # Parse a data.frame of already-split ids: resolve the 4 identity columns @@ -255,22 +282,26 @@ parseVariantId <- function(ids) { .parseVariantIdDf <- function(ids) { # minimal repair: preserve any empty/duplicate extra-column names (e.g. an # unnamed passthrough column) for .sanitizeNames() to canonicalize later. - ids <- as_tibble(ids, .name_repair = "minimal") - hasA2A1 <- all(is_in(c("chrom", "pos", "A2", "A1"), names(ids))) - hasA1A2 <- all(is_in(c("chrom", "pos", "A1", "A2"), names(ids))) - if (!hasA2A1 && !hasA1A2 && ncol(ids) >= 4) { - names(ids)[seq_len(4)] <- c("chrom", "pos", "A2", "A1") + tbl <- as_tibble(ids, .name_repair = "minimal") + hasA2A1 <- all(is_in(c("chrom", "pos", "A2", "A1"), names(tbl))) + hasA1A2 <- all(is_in(c("chrom", "pos", "A1", "A2"), names(tbl))) + # With neither allele naming present the frame is positional: its first + # four columns are the variant key. + named <- if (!hasA2A1 && !hasA1A2 && ncol(tbl) >= 4) { + `names<-`( + tbl, + replace(names(tbl), seq_len(4), c("chrom", "pos", "A2", "A1")) + ) + } else { + tbl } conv <- list( - hasChr = any(str_detect(as.character(ids$chrom), "^chr")), + hasChr = any(str_detect(as.character(named$chrom), "^chr")), alleleSep = ":", hasBuild = FALSE, example = NA_character_ ) - ids$chrom <- canonChrom(ids$chrom) - ids$pos <- as.integer(ids$pos) - attr(ids, "convention") <- conv - ids + `attr<-`(.withCanonicalCoords(named), "convention", conv) } #' Format variant ID strings from component columns @@ -355,33 +386,38 @@ formatVariantId <- function( #' rsIDs) are returned unchanged. #' @examples #' normalizeVariantId(c("1:100:A:G", "2:200:T:C")) +#' @importFrom checkmate assertCharacter assertFlag assertList #' @export normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { + assertCharacter(ids) + assertFlag(chrPrefix) + assertList(convention, null.ok = TRUE) parsed <- parseVariantId(ids) 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 - ) - } + if (!any(ok)) { + return(out) } - out + reformatted <- 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 + ) + } + replace(out, ok, reformatted) } # Complement a DNA allele string (A<->T, C<->G) for strand flipping. @@ -392,16 +428,10 @@ normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { # `unnamed_`, duplicates de-duplicated with make.unique). # @noRd .sanitizeNames <- function(df) { - nm <- colnames(df) - if (is.null(nm)) { - nm <- rep("unnamed", ncol(df)) - } + nm <- colnames(df) %||% rep("unnamed", ncol(df)) emptyIdx <- is.na(nm) | nm == "" - if (any(emptyIdx)) { - nm[emptyIdx] <- str_c("unnamed_", seq_len(sum(emptyIdx))) - } - colnames(df) <- make.unique(nm, sep = "_") - df + named <- replace(nm, emptyIdx, str_c("unnamed_", seq_len(sum(emptyIdx)))) + `colnames<-`(df, make.unique(named, sep = "_")) } #' Harmonize variant alleles against a reference @@ -468,21 +498,20 @@ harmonizeAlleles <- function( removeIndels = FALSE, removeStrandAmbiguous = TRUE, removeDups = FALSE, - colToComplement = character(), - ... + colToComplement = character() ) { coerced <- .harmonizeCoerceInputs(targetData, refVariants) - targetData <- coerced$targetData - refVariants <- coerced$refVariants + target <- coerced$targetData + panel <- coerced$refVariants # The index rides along on the join copy only: the restore path below - # re-reads `targetData`, and a sentinel column there would bind_rows its + # re-reads `target`, and a sentinel column there would bind_rows its # way into the returned frame. - matchResult <- .harmonizeJoin(.haIndexTargets(targetData), refVariants) - if (nrow(matchResult) == 0) { - return(.harmonizeEmptyResult(matchResult)) + joined <- .harmonizeJoin(.haIndexTargets(target), panel) + if (nrow(joined) == 0) { + return(.harmonizeEmptyResult(joined)) } matchResult <- .harmonizeDecideMatches( - matchResult, + joined, colToFlip, colToComplement, flipStrand, @@ -490,20 +519,18 @@ harmonizeAlleles <- function( removeStrandAmbiguous ) qcCounts <- .harmonizeQcCounts(matchResult) - qcSummary <- matchResult - result <- .harmonizeCleanResult(matchResult) - if (removeDups) { - result <- .harmonizeRemoveDups(result) - } - if (!removeUnmatched) { - restored <- .harmonizeRestoreUnmatched(result, matchResult, targetData) - result <- restored$result - qcSummary <- restored$qcSummary + cleaned <- .harmonizeCleanResult(matchResult) + deduped <- if (removeDups) .harmonizeRemoveDups(cleaned) else cleaned + # Putting the unmatched rows back also re-derives the QC summary over + # them, so the two travel together. + final <- if (removeUnmatched) { + list(result = deduped, qcSummary = matchResult) + } else { + .harmonizeRestoreUnmatched(deduped, matchResult, target) } - .harmonizeFinalChecks(result, refVariants, matchMinProp) - out <- list(harmonizedData = result, qcSummary = qcSummary) - attr(out, "qcCounts") <- qcCounts - out + .harmonizeFinalChecks(final$result, panel, matchMinProp) + out <- list(harmonizedData = final$result, qcSummary = final$qcSummary) + `attr<-`(out, "qcCounts", qcCounts) } # Turn the raw (chrom, pos) join into a decided match table: classify each @@ -520,15 +547,12 @@ harmonizeAlleles <- function( removeIndels, removeStrandAmbiguous ) { - matchResult <- .harmonizeFlags(matchResult) - matchResult <- .harmonizeResolveAmbiguity( - matchResult, - removeStrandAmbiguous - ) - matchResult <- .harmonizeKeepRule(matchResult, removeIndels) - matchResult <- .harmonizeResolveTargets(matchResult) + decided <- .harmonizeFlags(matchResult) |> + .harmonizeResolveAmbiguity(removeStrandAmbiguous) |> + .harmonizeKeepRule(removeIndels) |> + .harmonizeResolveTargets() .harmonizeApplyFlips( - matchResult, + decided, colToFlip, colToComplement, flipStrand @@ -544,8 +568,7 @@ harmonizeAlleles <- function( # a frame carrying an NA or empty column name. # @noRd .haIndexTargets <- function(targetData) { - targetData[[.haTargetIdx]] <- seq_len(nrow(targetData)) - targetData + `[[<-`(targetData, .haTargetIdx, value = seq_len(nrow(targetData))) } # QC / flag columns stripped from the harmonized result before it is returned. @@ -567,7 +590,7 @@ harmonizeAlleles <- function( # QC'd alleles below; leaving it in collides on the final rename). # @noRd .harmonizeCoerceInputs <- function(targetData, refVariants) { - if ( + parsedTarget <- if ( is.data.frame(targetData) && ncol(targetData) > 4 && all(is_in(c("chrom", "pos", "A2", "A1"), names(targetData))) @@ -575,23 +598,30 @@ harmonizeAlleles <- function( variantCols <- c("chrom", "pos", "A2", "A1") variantDf <- targetData |> select(all_of(variantCols)) otherCols <- targetData |> select(-all_of(variantCols)) - targetData <- bind_cols( + bind_cols( parseVariantId(variantDf), otherCols, .name_repair = "minimal" ) } else { - targetData <- parseVariantId(targetData) + parseVariantId(targetData) } - refVariants <- parseVariantId(refVariants) + parsedRef <- parseVariantId(refVariants) dropCols <- c("chromosome", "position", "ref", "alt", "variant_id") - if (any(is_in(dropCols, colnames(targetData)))) { - targetData <- select(targetData, -any_of(dropCols)) + # select() rejects a frame with an empty column name, which a passthrough + # column legitimately has, so only touch a frame that has something to + # drop. + trimmedTarget <- if (any(is_in(dropCols, colnames(parsedTarget)))) { + select(parsedTarget, -any_of(dropCols)) + } else { + parsedTarget } - if (is_in("variant_id", colnames(refVariants))) { - refVariants <- select(refVariants, -any_of("variant_id")) + trimmedRef <- if (is_in("variant_id", colnames(parsedRef))) { + select(parsedRef, -any_of("variant_id")) + } else { + parsedRef } - list(targetData = targetData, refVariants = refVariants) + list(targetData = trimmedTarget, refVariants = trimmedRef) } # Inner-join target + reference on (chrom, pos). @@ -616,17 +646,20 @@ harmonizeAlleles <- function( ) warn(msg) 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 + `attr<-`( + emptyOut, + "qcCounts", + list( + considered = 0L, + signFlip = 0L, + strandFlip = 0L, + kept = 0L, + dropped = 0L, + droppedIndel = 0L, + droppedAmbiguous = 0L, + droppedOther = 0L + ) ) - emptyOut } # Per-variant harmonization flags: original/QC'd ids, uppercased alleles, strand @@ -712,20 +745,22 @@ harmonizeAlleles <- function( # fall through as exact / sign-flip cases rather than being dropped). # @noRd .harmonizeResolveAmbiguity <- function(matchResult, removeStrandAmbiguous) { - if (!removeStrandAmbiguous) { - matchResult$strand_unambiguous <- TRUE + relaxed <- if (removeStrandAmbiguous) { + matchResult + } else { + mutate(matchResult, strand_unambiguous = TRUE) } - if (!any(matchResult$strand_flip & matchResult$strand_unambiguous)) { - matchResult$strand_unambiguous <- TRUE + if (any(relaxed$strand_flip & relaxed$strand_unambiguous)) { + return(relaxed) } - matchResult + mutate(relaxed, strand_unambiguous = TRUE) } # Compute the keep flag (strand-flip vs non-strand-flip rules); drop indels when # requested. # @noRd .harmonizeKeepRule <- function(matchResult, removeIndels) { - matchResult <- matchResult |> + ruled <- matchResult |> mutate( keep = if_else( .data$strand_flip, @@ -737,11 +772,10 @@ harmonizeAlleles <- function( .data$ID_match ) ) - if (removeIndels) { - matchResult <- matchResult |> - mutate(keep = if_else(.data$INDEL, FALSE, .data$keep)) + if (!removeIndels) { + return(ruled) } - matchResult + mutate(ruled, keep = if_else(.data$INDEL, FALSE, .data$keep)) } # Reduce the join to at most one reference row per TARGET variant. @@ -782,8 +816,7 @@ harmonizeAlleles <- function( ] # Named apart from the column it replaces: `keep = keep` inside mutate() # reads the column, not this vector, and silently changes nothing. - resolvedKeep <- rep(FALSE, nrow(matchResult)) - resolvedKeep[resolved] <- TRUE + resolvedKeep <- replace(rep(FALSE, nrow(matchResult)), resolved, TRUE) mutate(matchResult, keep = resolvedKeep) } @@ -821,26 +854,30 @@ harmonizeAlleles <- function( flipStrand ) { signFlip <- matchResult$sign_flip - if (!is.null(colToFlip)) { + negated <- if (is.null(colToFlip)) { + matchResult + } else { .harmonizeCheckCols(colToFlip, matchResult) - matchResult <- matchResult |> + matchResult |> mutate(across( all_of(colToFlip), partial(.negateWhere, flip = signFlip) )) } - if (length(colToComplement) > 0L) { - .harmonizeCheckCols(colToComplement, matchResult) - matchResult <- matchResult |> + complemented <- if (length(colToComplement) == 0L) { + negated + } else { + .harmonizeCheckCols(colToComplement, negated) + negated |> mutate(across( all_of(colToComplement), partial(.complementWhere, flip = signFlip) )) } - if (flipStrand) { - matchResult <- .harmonizeFlipStrandCols(matchResult) + if (!flipStrand) { + return(complemented) } - matchResult + .harmonizeFlipStrandCols(complemented) } # Assert the named columns exist in matchResult. @@ -886,17 +923,20 @@ harmonizeAlleles <- function( 0L } ) - qcCounts$droppedAmbiguous <- sum( + droppedAmbiguous <- sum( !matchResult$keep & matchResult$strand_flip & !matchResult$strand_unambiguous & if (hasIndel) !matchResult$INDEL else TRUE, na.rm = TRUE ) - qcCounts$droppedOther <- qcCounts$dropped - - qcCounts$droppedIndel - - qcCounts$droppedAmbiguous - qcCounts + list_assign( + qcCounts, + droppedAmbiguous = droppedAmbiguous, + droppedOther = qcCounts$dropped - + qcCounts$droppedIndel - + droppedAmbiguous + ) } # Kept rows with QC/flag + target-allele columns stripped and ref alleles / @@ -966,14 +1006,16 @@ harmonizeAlleles <- function( return(list(result = result, qcSummary = qcSummary)) } unmatchData <- targetData |> filter(!is_in(.data$variant_id, matchVariant)) - result <- bind_rows( + withUnmatched <- bind_rows( result, unmatchData |> mutate(variants_id_original = .data$variant_id) ) - result <- result |> + # Restore the caller's input order, which bind_rows put the unmatched + # rows behind. + restored <- withUnmatched |> slice(match(targetData$variant_id, .data$variants_id_original)) |> select(-any_of("variants_id_original")) - list(result = result, qcSummary = qcSummary) + list(result = restored, qcSummary = qcSummary) } # Final guards: enough variants matched, and no duplicate ids remain. @@ -1108,12 +1150,11 @@ matchVariants <- function( # 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)) + tagA <- mutate(dfA, .mvTidx = seq_len(nrow(dfA)), .mvSign = 1) + tagB <- mutate(dfB, .mvRidx = seq_len(nrow(dfB))) res <- suppressWarnings(harmonizeAlleles( - targetData = dfA, - refVariants = dfB, + targetData = tagA, + refVariants = tagB, colToFlip = ".mvSign", matchMinProp = 0, removeDups = TRUE, @@ -1179,11 +1220,18 @@ parseRegion <- function(region) { #' \code{colnames}: a normalized character chromosome plus integer start/end. #' @examples #' regionToDf(c("1_100_200", "2_300_400")) +#' @importFrom checkmate assertCharacter #' @export regionToDf <- function(ldRegionId, colnames = c("chrom", "start", "end")) { + # @param says "A string", but the function is vectorised and callers pass + # a character vector -- assert what it actually accepts, not the prose. + assertCharacter(ldRegionId, any.missing = FALSE) + assertCharacter(colnames, len = 3L, any.missing = FALSE) parts <- str_split(ldRegionId, "[_:-]", simplify = TRUE) - regionOfInterest <- as_tibble(parts, .name_repair = "minimal") - colnames(regionOfInterest) <- colnames + regionOfInterest <- `colnames<-`( + as_tibble(parts, .name_repair = "minimal"), + colnames + ) regionOfInterest |> mutate( across(all_of(colnames[1]), canonChrom), @@ -1222,9 +1270,11 @@ asGranges <- function(regions) { abort(msg) } # GRanges expects character seqnames; prefix with "chr" if numeric - seqnames <- as.character(df$chrom) - if (!any(str_detect(seqnames, "^chr"))) { - seqnames <- str_c("chr", seqnames) + rawChrom <- as.character(df$chrom) + seqnames <- if (any(str_detect(rawChrom, "^chr"))) { + rawChrom + } else { + str_c("chr", rawChrom) } GenomicRanges::GRanges( seqnames = seqnames, @@ -1306,10 +1356,12 @@ classifyVariantType <- function(ids) { .variantIdsToGRanges <- function(ids, what = "variant ids") { ids <- as.character(ids) if (length(ids) == 0L) { - gr <- GenomicRanges::GRanges() - mcols(gr) <- S4Vectors::DataFrame( - A1 = character(0), - A2 = character(0) + gr <- S4Vectors::`mcols<-`( + GenomicRanges::GRanges(), + value = S4Vectors::DataFrame( + A1 = character(0), + A2 = character(0) + ) ) return(gr) } @@ -1326,13 +1378,15 @@ classifyVariantType <- function(ids) { ) abort(msg) } - gr <- GenomicRanges::GRanges( - withChrPrefix(parsed$chrom), - IRanges::IRanges(start = parsed$pos, width = 1L) - ) - mcols(gr) <- S4Vectors::DataFrame( - A1 = as.character(parsed$A1), - A2 = as.character(parsed$A2) + gr <- S4Vectors::`mcols<-`( + GenomicRanges::GRanges( + withChrPrefix(parsed$chrom), + IRanges::IRanges(start = parsed$pos, width = 1L) + ), + value = S4Vectors::DataFrame( + A1 = as.character(parsed$A1), + A2 = as.character(parsed$A2) + ) ) gr } diff --git a/R/vcfWriter.R b/R/vcfWriter.R index 31441f70..e168b955 100644 --- a/R/vcfWriter.R +++ b/R/vcfWriter.R @@ -57,17 +57,13 @@ setMethod( # Per-sample geno matrices (ES / SS / AF) for the fields present in the mcols. # @noRd .vcfSumstatsGeno <- function(mc, nSnps) { - geno <- list() - if (is_in("Z", colnames(mc))) { - geno[["ES"]] <- matrix(mc$Z, nSnps) - } - if (is_in("N", colnames(mc))) { - geno[["SS"]] <- matrix(as.integer(mc$N), nSnps) - } - if (is_in("MAF", colnames(mc))) { - geno[["AF"]] <- matrix(mc$MAF, nSnps) - } - geno + compact(list( + ES = if (is_in("Z", colnames(mc))) matrix(mc$Z, nSnps), + SS = if (is_in("N", colnames(mc))) { + matrix(as.integer(mc$N), nSnps) + }, + AF = if (is_in("MAF", colnames(mc))) matrix(mc$MAF, nSnps) + )) } # The fixed FORMAT header for the sumstats geno fields (ES / SS / AF). @@ -120,22 +116,45 @@ setMethod( splitByContext = splitByContext, splitByTrait = splitByTrait ) - out <- character(length(rowSpecs)) - for (i in seq_along(rowSpecs)) { - spec <- rowSpecs[[i]] - out[[i]] <- .writeFineMappingVcf( - x, - spec, - outputPath = outputPath, - sampleName = sampleName, - splitByContext = splitByContext, - splitByTrait = splitByTrait - ) - } - invisible(out) + invisible(map_chr( + rowSpecs, + .writeFineMappingVcfSpec, + x = x, + outputPath = outputPath, + sampleName = sampleName, + splitByContext = splitByContext, + splitByTrait = splitByTrait + )) } ) +# @noRd +.writeFineMappingVcfSpec <- function( + spec, + x, + outputPath, + sampleName, + splitByContext, + splitByTrait +) { + .writeFineMappingVcf( + x, + spec, + outputPath = outputPath, + sampleName = sampleName, + splitByContext = splitByContext, + splitByTrait = splitByTrait + ) +} + +# Narrow a row-index vector to those rows whose `axis` column equals the +# caller's requested value. `.tupleColumn()` not `[[`: on a RangedTupleList +# `[[` extracts an ELEMENT, while the identity axes live in mcols. +# @noRd +.vcfNarrowRows <- function(rows, axis, x, selectors) { + rows[as.character(.tupleColumn(x, axis))[rows] == selectors[[axis]]] +} + # Resolve which (study, context, trait, method) rows to write. Without # the split flags this returns a single spec; with `splitByContext` or # `splitByTrait` the collection's rows are walked and one spec is emitted @@ -153,19 +172,19 @@ setMethod( cols <- .tupleColumnNames(x) hasContextSlot <- is_in("context", cols) hasTraitSlot <- is_in("trait", cols) - rows <- seq_len(nrow(x)) - if (!is.null(study)) { - rows <- rows[as.character(x$study)[rows] == study] - } - if (hasContextSlot && !is.null(context)) { - rows <- rows[as.character(x$context)[rows] == context] - } - if (hasTraitSlot && !is.null(trait)) { - rows <- rows[as.character(x$trait)[rows] == trait] - } - if (!is.null(method)) { - rows <- rows[as.character(x$method)[rows] == method] - } + selectors <- compact(list( + study = study, + context = if (hasContextSlot) context, + trait = if (hasTraitSlot) trait, + method = method + )) + rows <- reduce( + names(selectors), + .vcfNarrowRows, + x = x, + selectors = selectors, + .init = seq_len(nrow(x)) + ) if (length(rows) == 0L) { abort("writeSumStatsVcf: no rows match the supplied selectors.") } @@ -223,14 +242,15 @@ setMethod( # empty (all-NA) ones are dropped downstream. # @noRd .vcfCoreSpecs <- function(base, m, nSnps) { - es <- .vcfCol(base, "conditional_effect", nSnps) - if (all(is.na(es))) { - es <- .vcfCol(m, "beta", nSnps) - } - af <- .vcfCol(base, "af", nSnps) - if (all(is.na(af))) { - af <- .vcfCol(m, "af", nSnps) + # The conditional effect when the fit reported one, else the marginal. + conditional <- .vcfCol(base, "conditional_effect", nSnps) + es <- if (all(is.na(conditional))) { + .vcfCol(m, "beta", nSnps) + } else { + conditional } + baseAf <- .vcfCol(base, "af", nSnps) + af <- if (all(is.na(baseAf))) .vcfCol(m, "af", nSnps) else baseAf p <- .vcfCol(m, "p", nSnps) lp <- if_else(is.na(p) | p <= 0, NA_real_, -log10(p)) list( @@ -324,13 +344,13 @@ setMethod( # marginal ES=beta / SE / LP / AF on top. Returns list(base, m, hasPost). # @noRd .vcfResolveBody <- function(entry, sn) { - post <- tryCatch( + post <- try_fetch( as_tibble(getTopLoci(entry, signalCutoff = 0)), - error = function(e) NULL + error = function(cnd) NULL ) - marg <- tryCatch( + marg <- try_fetch( as_tibble(getMarginalEffects(entry)), - error = function(e) NULL + error = function(cnd) NULL ) hasPost <- !is.null(post) && nrow(post) > 0L hasMarg <- !is.null(marg) && nrow(marg) > 0L @@ -449,23 +469,24 @@ setMethod( str_length(base) + 1L, str_length(outputPath) ) - tags <- character(0) - if ( - isTRUE(splitByContext) && - !is.null(spec$context) && - !is.na(spec$context) && - str_length(spec$context) > 0L - ) { - tags <- c(tags, spec$context) - } - if ( - isTRUE(splitByTrait) && - !is.null(spec$trait) && - !is.na(spec$trait) && - str_length(spec$trait) > 0L - ) { - tags <- c(tags, spec$trait) - } + tags <- c( + if ( + isTRUE(splitByContext) && + !is.null(spec$context) && + !is.na(spec$context) && + str_length(spec$context) > 0L + ) { + spec$context + }, + if ( + isTRUE(splitByTrait) && + !is.null(spec$trait) && + !is.na(spec$trait) && + str_length(spec$trait) > 0L + ) { + spec$trait + } + ) if (length(tags) == 0L) { return(outputPath) } @@ -518,12 +539,14 @@ setMethod( ), sample = sampleName ) - VariantAnnotation::geno(hdr) <- genoHeader[ - is_in(rownames(genoHeader), names(geno)), - , - drop = FALSE - ] - hdr + VariantAnnotation::`geno<-`( + hdr, + value = genoHeader[ + is_in(rownames(genoHeader), names(geno)), + , + drop = FALSE + ] + ) } # Assemble + finalize the VCF object (ref / alt / FILTER, sorted). @@ -535,10 +558,19 @@ setMethod( exptData = list(header = hdr), geno = SimpleList(geno) ) - VariantAnnotation::ref(vcf) <- DNAStringSet(ref) - VariantAnnotation::alt(vcf) <- DNAStringSetList(as.list(alt)) - VariantAnnotation::fixed(vcf)$FILTER <- "PASS" - sort(vcf) + alleled <- VariantAnnotation::`alt<-`( + VariantAnnotation::`ref<-`(vcf, value = DNAStringSet(ref)), + value = DNAStringSetList(as.list(alt)) + ) + filtered <- VariantAnnotation::`fixed<-`( + alleled, + value = `[[<-`( + VariantAnnotation::fixed(alleled), + "FILTER", + value = "PASS" + ) + ) + sort(filtered) } # Write the VCF in the format implied by the output extension. writeVcf appends @@ -558,6 +590,7 @@ setMethod( # BCF path: write a temporary bgzipped VCF, then convert to BCF via asBcf. # @noRd +#' @importFrom rlang try_fetch .vcfWriteBcf <- function(vcf, outputPath, chrom) { tmpVcfStem <- tempfile(fileext = ".vcf") tmpVcfBgz <- str_c(tmpVcfStem, ".bgz") @@ -570,20 +603,20 @@ setMethod( # Rsamtools disabled asBcf() (>= 2.26 raises "temporarily disabled"), so # the bare upstream error is translated into something actionable rather # than surfacing as an opaque failure from a documented output format. - tryCatch( + try_fetch( asBcf( tmpVcfBgz, dictionary = unique(chrom), destination = str_remove(outputPath, "\\.bcf$") ), - error = function(e) { + error = function(cnd) { msg <- glue( "writeSumStatsVcf: BCF output needs a working ", "Rsamtools::asBcf(), which the installed Rsamtools does not ", - "provide (\"{conditionMessage(e)}\"). Write a bgzipped VCF ", - "instead by giving the output path a .vcf.bgz extension." + "provide. Write a bgzipped VCF instead by giving the output ", + "path a .vcf.bgz extension." ) - abort(msg) + abort(msg, parent = cnd) } ) } @@ -610,11 +643,12 @@ setMethod( # @noRd .vcfCsColSpecs <- function(cc, base) { cov <- str_remove(cc, "^cs_") - idx <- suppressWarnings(as.integer(str_remove( + raw <- suppressWarnings(as.integer(str_remove( as.character(base[[cc]]), ".*_" ))) - idx[is.na(idx)] <- 0L + # 0 = the variant is in no credible set at this coverage. + idx <- replace(raw, is.na(raw), 0L) csSpec <- .vcfSpec( str_c("CS", cov), idx, diff --git a/data/ctwasEstExample.rda b/data/ctwasEstExample.rda index 656d1143..58021fa7 100644 Binary files a/data/ctwasEstExample.rda and b/data/ctwasEstExample.rda differ diff --git a/data/ctwasFinemapExample.rda b/data/ctwasFinemapExample.rda index 252043c0..24c5200c 100644 Binary files a/data/ctwasFinemapExample.rda and b/data/ctwasFinemapExample.rda differ diff --git a/data/ctwasInputsExample.rda b/data/ctwasInputsExample.rda index 316c8d79..6369485d 100644 Binary files a/data/ctwasInputsExample.rda and b/data/ctwasInputsExample.rda differ diff --git a/inst/prototype/ensemble_twas_weights.ipynb b/inst/prototype/ensemble_twas_weights.ipynb index b9c223c2..eafff31a 100644 --- a/inst/prototype/ensemble_twas_weights.ipynb +++ b/inst/prototype/ensemble_twas_weights.ipynb @@ -494,6 +494,7 @@ "\n", " library(pecotmr)\n", " library(simxQTL)\n", + " library(purrr)\n", " set.seed(${_replicates['seed']})\n", " cat(\"Replicate: ${_replicates['rep_id']}\\n\")\n", " cat(\"Seed: ${_replicates['seed']}\\n\")\n", @@ -656,10 +657,15 @@ " rsq_y = rsq_y)\n", " }\n", "\n", - " method_metrics <- sapply(names(res$twas_weights), function(wname) {\n", - " compute_metrics(res$twas_weights[[wname]])\n", - " })\n", - " colnames(method_metrics) <- gsub(\"_weights$\", \"\", colnames(method_metrics))\n", + " # cbind over a NAMED list carries the method names as colnames, so the\n", + " # suffix is stripped once here instead of in a second colnames() pass.\n", + " method_metrics <- exec(\n", + " cbind,\n", + " !!!set_names(\n", + " map(res$twas_weights, compute_metrics),\n", + " gsub(\"_weights$\", \"\", names(res$twas_weights))\n", + " )\n", + " )\n", "\n", " ensemble_metrics <- c(mse_w = NA, mse_pred_truth = NA, mse_y = NA, rsq_y = NA)\n", " if (!is.null(ens) && !is.null(ens$ensemble_twas_weights)) {\n", @@ -735,6 +741,7 @@ " library(ggplot2)\n", " library(tidyr)\n", " library(dplyr)\n", + " library(purrr)\n", "\n", " results_dir <- \"${results_dir}\"\n", "\n", @@ -743,17 +750,17 @@ " recursive = TRUE, full.names = TRUE)\n", " cat(sprintf(\"Found %d RDS files\\n\", length(rds_files)))\n", "\n", - " all_data <- lapply(rds_files, function(f) {\n", + " all_data <- map(rds_files, function(f) {\n", " tryCatch(readRDS(f), error = function(e) NULL)\n", " })\n", - " all_data <- all_data[!sapply(all_data, is.null)]\n", - " all_data <- all_data[!sapply(all_data, function(x) isTRUE(x$truth$error))]\n", + " all_data <- compact(all_data)\n", + " all_data <- discard(all_data, function(x) isTRUE(x$truth$error))\n", " cat(sprintf(\"%d successful replicates\\n\", length(all_data)))\n", "\n", " if (length(all_data) == 0) stop(\"No valid results found\")\n", "\n", " # ── 2. Extract metrics ───────────────────────────────────\n", - " metrics_list <- lapply(seq_along(all_data), function(i) {\n", + " metrics_list <- map(seq_along(all_data), function(i) {\n", " x <- all_data[[i]]\n", " coefs <- if (!is.null(x$ensemble)) x$ensemble$method_coef else NULL\n", " list(\n", @@ -766,7 +773,7 @@ "\n", " # ── 3. Tidy data frames ──────────────────────────────────\n", " build_metric_df <- function(metric_name) {\n", - " do.call(rbind, lapply(metrics_list, function(m) {\n", + " exec(rbind, !!!map(metrics_list, function(m) {\n", " if (is.null(m$method_metrics)) return(NULL)\n", " if (!(metric_name %in% rownames(m$method_metrics))) return(NULL)\n", " methods <- colnames(m$method_metrics)\n", @@ -787,16 +794,18 @@ " mse_y_df <- build_metric_df(\"mse_y\")\n", " rsq_y_df <- build_metric_df(\"rsq_y\")\n", "\n", - " coef_mat <- do.call(rbind, lapply(metrics_list, function(m) {\n", + " coef_mat <- exec(rbind, !!!map(metrics_list, function(m) {\n", " if (is.null(m$method_coef)) return(NULL)\n", " m$method_coef\n", " }))\n", " if (!is.null(coef_mat)) {\n", - " rownames(coef_mat) <- sapply(metrics_list[!sapply(metrics_list,\n", - " function(m) is.null(m$method_coef))], function(m) m$rep_id)\n", + " rownames(coef_mat) <- map_chr(\n", + " keep(metrics_list, function(m) !is.null(m$method_coef)),\n", + " function(m) m$rep_id\n", + " )\n", " }\n", "\n", - " scatter_df <- do.call(rbind, lapply(metrics_list, function(m) {\n", + " scatter_df <- exec(rbind, !!!map(metrics_list, function(m) {\n", " if (is.null(m$method_metrics)) return(NULL)\n", " if (!(\"rsq_y\" %in% rownames(m$method_metrics))) return(NULL)\n", " rsq_vals <- m$method_metrics[\"rsq_y\", ]\n", @@ -881,7 +890,7 @@ "\n", " # ── 5. Summary table ─────────────────────────────────────\n", " metric_rows <- c(\"mse_w\", \"mse_pred_truth\", \"mse_y\", \"rsq_y\")\n", - " summary_rows <- lapply(metrics_list, function(m) {\n", + " summary_rows <- map(metrics_list, function(m) {\n", " row <- data.frame(\n", " rep_id = m$rep_id, region = m$region, seed = m$seed,\n", " stringsAsFactors = FALSE\n", diff --git a/inst/prototype/generate_test_for_prs_cs.R b/inst/prototype/generate_test_for_prs_cs.R index 95d927ae..d8d5f832 100644 --- a/inst/prototype/generate_test_for_prs_cs.R +++ b/inst/prototype/generate_test_for_prs_cs.R @@ -22,10 +22,10 @@ sigma0 <- c(0.001, .1, .5, 1, 5, 10, 20, 30, .005) omega0 <- rep(1 / K, K) # Calculate summary statistics -b.hat <- sapply(1:p, function(j) { +b.hat <- purrr::map_dbl(1:p, function(j) { summary(lm(y ~ X[, j]))$coefficients[-1, 1] }) -s.hat <- sapply(1:p, function(j) { +s.hat <- purrr::map_dbl(1:p, function(j) { summary(lm(y ~ X[, j]))$coefficients[-1, 2] }) R.hat <- cor(X) diff --git a/inst/scripts/build_ctwas_examples.R b/inst/scripts/build_ctwas_examples.R index 1ddb0372..545b3f52 100644 --- a/inst/scripts/build_ctwas_examples.R +++ b/inst/scripts/build_ctwas_examples.R @@ -25,6 +25,7 @@ # ============================================================================= devtools::load_all(".", quiet = TRUE) +library(purrr) # ----------------------------------------------------------------------------- # 1. Inputs: the bundled chr22 LD panel, GWAS sumstats, and TWAS weights. @@ -71,15 +72,17 @@ ctwasEstExample <- estCtwasParam( thin = 1, niterPrefit = 3, niter = 10, - min_group_size = 1, - min_p_single_effect = 0, - fallbackToPrefit = TRUE + fallbackToPrefit = TRUE, + ctwasArgs = list(min_group_size = 1, min_p_single_effect = 0) ) # The toy GWAS carries no genome-wide-significant signal, so the default # screen (min_nonSNP_PIP = 0.5) selects nothing and the example would be an # empty result. Keep every region so the finemap payload is populated. -screened <- screenCtwasRegions(ctwasEstExample, min_nonSNP_PIP = 0) +screened <- screenCtwasRegions( + ctwasEstExample, + ctwasArgs = list(min_nonSNP_PIP = 0) +) ctwasFinemapExample <- finemapCtwasRegions(screened) # ----------------------------------------------------------------------------- @@ -99,7 +102,7 @@ repointLd <- function(payload) { return(payload) } stored <- as.character(payload$LD_map$LD_file) - portable <- vapply(stored, asResource, character(1), USE.NAMES = FALSE) + portable <- map_chr(stored, asResource) keyMap <- setNames(portable, stored) payload$LD_map$LD_file <- portable payload$LD_map$SNP_file <- portable @@ -127,12 +130,14 @@ invisible(estCtwasParam( thin = 1, niterPrefit = 3, niter = 10, - min_group_size = 1, - min_p_single_effect = 0, - fallbackToPrefit = TRUE + fallbackToPrefit = TRUE, + ctwasArgs = list(min_group_size = 1, min_p_single_effect = 0) )) invisible(finemapCtwasRegions( - screenCtwasRegions(ctwasEstExample, min_nonSNP_PIP = 0) + screenCtwasRegions( + ctwasEstExample, + ctwasArgs = list(min_nonSNP_PIP = 0) + ) )) invisible(asCtwasResult(ctwasFinemapExample)) invisible(mergeCtwasBoundaryRegions(ctwasFinemapExample)) diff --git a/inst/scripts/build_examples.R b/inst/scripts/build_examples.R index 73971cc4..4d686430 100644 --- a/inst/scripts/build_examples.R +++ b/inst/scripts/build_examples.R @@ -17,6 +17,7 @@ # ============================================================================= devtools::load_all(".") +library(purrr) set.seed(20260620L) @@ -249,7 +250,7 @@ multiCtxBetas <- list( } ) -multiCtxEntries <- lapply(multiCtxNames, function(ctx) { +multiCtxEntries <- map(multiCtxNames, function(ctx) { bj <- multiCtxBetas[[ctx]] yCtx <- as.numeric(X %*% bj + stats::rnorm(nSample, sd = 1)) zc <- numeric(nVar) diff --git a/inst/scripts/build_h2_examples.R b/inst/scripts/build_h2_examples.R index b5621baf..2c88e01c 100644 --- a/inst/scripts/build_h2_examples.R +++ b/inst/scripts/build_h2_examples.R @@ -18,6 +18,7 @@ # ============================================================================= devtools::load_all(".", quiet = TRUE) +library(purrr) mweDir <- Sys.getenv( "MWE_DIR", @@ -46,10 +47,10 @@ message("Loading ", length(regions), " chr22 LD blocks...") # One LdData per block: buildLd*() takes the list and gives one LD block per # element. Loading the whole span at once would instead return a single dense # matrix, i.e. one block, which no jackknife can work with. -ldList <- lapply(regions, function(r) loadLdMatrix(metaPath, region = r)) +ldList <- map(regions, function(r) loadLdMatrix(metaPath, region = r)) message( " ", - sum(vapply(ldList, length, integer(1))), + sum(map_int(ldList, length)), " variants across ", length(ldList), " blocks" diff --git a/inst/scripts/build_sldsc_upstream_z.R b/inst/scripts/build_sldsc_upstream_z.R index 222b02e4..0d31f45b 100644 --- a/inst/scripts/build_sldsc_upstream_z.R +++ b/inst/scripts/build_sldsc_upstream_z.R @@ -20,6 +20,7 @@ # ============================================================================= suppressMessages(devtools::load_all(".", quiet = TRUE, export_all = FALSE)) +library(purrr) data(ldScoreExample) # EXACT copy of the in-test generator, so the captured z is the one the @@ -43,11 +44,15 @@ simZ <- function(ref, h2, n, seed) { # entry is a hard error there, not a silent re-simulation. cases <- c( list( - c(0.4, 1e4, 42), c(0.15, 4e3, 7), c(0.6, 2.5e4, 99), - c(0.3, 1e4, 5), c(0.6, 5e4, 9), c(0.4, 5e4, 3) + c(0.4, 1e4, 42), + c(0.15, 4e3, 7), + c(0.6, 2.5e4, 99), + c(0.3, 1e4, 5), + c(0.6, 5e4, 9), + c(0.4, 5e4, 3) ), # the HDL recovery test sweeps seeds 1:5 at (h2 = 0.4, n = 1e5) - lapply(1:5, function(s) c(0.4, 1e5, s)) + map(1:5, function(s) c(0.4, 1e5, s)) ) out <- list() for (cs in cases) { @@ -57,5 +62,8 @@ for (cs in cases) { saveRDS(out, "tests/testthat/test_data/sldscUpstreamZ.rds", compress = "xz") cat("keys:", paste(names(out), collapse = " | "), "\n") cat("length each:", unique(lengths(out)), "\n") -cat("file size:", - file.size("tests/testthat/test_data/sldscUpstreamZ.rds"), "bytes\n") +cat( + "file size:", + file.size("tests/testthat/test_data/sldscUpstreamZ.rds"), + "bytes\n" +) diff --git a/man/GenotypeHandle.Rd b/man/GenotypeHandle.Rd index d11af48b..4562e8be 100644 --- a/man/GenotypeHandle.Rd +++ b/man/GenotypeHandle.Rd @@ -18,7 +18,8 @@ GenotypeHandle( region = NULL, genoMeta = NULL, chroms = NULL, - ... + format = NULL, + vcfArgs = list() ) } \arguments{ @@ -62,7 +63,8 @@ shard is read (so the caller's own absence check can report the mismatch). Only meaningful with \code{genoMeta}; supplying it with any other source is an error (a single-file panel has no per-chromosome shards to skip).} -\item{...}{Additional arguments forwarded to the format-specific reader.} +\item{vcfArgs}{Optional named list of arguments forwarded to +\code{VariantAnnotation::readVcf} when the source is a VCF.} } \value{ A \code{GenotypeHandle} object. diff --git a/man/bLassoWeights.Rd b/man/bLassoWeights.Rd index 977edd0b..54ba1b91 100644 --- a/man/bLassoWeights.Rd +++ b/man/bLassoWeights.Rd @@ -4,7 +4,14 @@ \alias{bLassoWeights} \title{Compute Weights Using the Bayesian LASSO (BGLR)} \usage{ -bLassoWeights(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) +bLassoWeights( + X, + y, + nIter = 10000, + burnIn = 2000, + thin = 5, + methodArgs = list() +) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -17,7 +24,8 @@ bLassoWeights(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) \item{thin}{Thinning interval. Default is 5.} -\item{...}{Additional arguments passed through to `BGLR::BGLR`.} +\item{methodArgs}{Optional named list of options passed through to +`BGLR::BGLR`.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/bayesAWeights.Rd b/man/bayesAWeights.Rd index 83476a18..dfa06bea 100644 --- a/man/bayesAWeights.Rd +++ b/man/bayesAWeights.Rd @@ -4,7 +4,7 @@ \alias{bayesAWeights} \title{BayesA TWAS weights (t-distribution prior)} \usage{ -bayesAWeights(X, y, Z = NULL, ...) +bayesAWeights(X, y, Z = NULL, methodArgs = list()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,7 +13,8 @@ bayesAWeights(X, y, Z = NULL, ...) \item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} -\item{...}{Additional arguments forwarded to \code{bayesAlphabetWeights} / +\item{methodArgs}{Optional named list of options forwarded to +\code{bayesAlphabetWeights} / \code{qgg}.} } \value{ diff --git a/man/bayesAlphabetWeights.Rd b/man/bayesAlphabetWeights.Rd index cf122ad0..e2d35ee7 100644 --- a/man/bayesAlphabetWeights.Rd +++ b/man/bayesAlphabetWeights.Rd @@ -13,7 +13,7 @@ bayesAlphabetWeights( nit = 5000, nburn = 1000, nthin = 5, - ... + methodArgs = list() ) } \arguments{ @@ -37,7 +37,8 @@ Options are bayesN, bayesL, bayesA, bayesC, or bayesR.} \item{nthin}{Integer. Thinning interval for retained MCMC samples. Default \code{5}.} -\item{...}{Additional arguments forwarded to \code{qgg::gbayes}.} +\item{methodArgs}{Optional named list of options forwarded to +\code{qgg::gbayes}.} } \value{ A vector containing the weights to be applied to each genotype in diff --git a/man/bayesBWeights.Rd b/man/bayesBWeights.Rd index fae5845a..3123f9b0 100644 --- a/man/bayesBWeights.Rd +++ b/man/bayesBWeights.Rd @@ -4,7 +4,15 @@ \alias{bayesBWeights} \title{Compute Weights Using BayesB} \usage{ -bayesBWeights(X, y, nIter = 10000, burnIn = 2000, thin = 5, probIn = 0.2, ...) +bayesBWeights( + X, + y, + nIter = 10000, + burnIn = 2000, + thin = 5, + probIn = 0.2, + methodArgs = list() +) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -19,7 +27,8 @@ bayesBWeights(X, y, nIter = 10000, burnIn = 2000, thin = 5, probIn = 0.2, ...) \item{probIn}{Prior inclusion probability for each marker. Default is 0.2.} -\item{...}{Additional arguments passed through to `BGLR::BGLR`.} +\item{methodArgs}{Optional named list of options passed through to +`BGLR::BGLR`.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/bayesCWeights.Rd b/man/bayesCWeights.Rd index 3dea01a0..dd2556d3 100644 --- a/man/bayesCWeights.Rd +++ b/man/bayesCWeights.Rd @@ -4,7 +4,7 @@ \alias{bayesCWeights} \title{BayesC TWAS weights (rounded-spike prior)} \usage{ -bayesCWeights(X, y, Z = NULL, pi = 0.1, ...) +bayesCWeights(X, y, Z = NULL, pi = 0.1, methodArgs = list()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -16,7 +16,8 @@ bayesCWeights(X, y, Z = NULL, pi = 0.1, ...) \item{pi}{Numeric in (0, 1). Prior proportion of non-null effects for the BayesC mixture. Default \code{0.1}.} -\item{...}{Additional arguments forwarded to \code{bayesAlphabetWeights} / +\item{methodArgs}{Optional named list of options forwarded to +\code{bayesAlphabetWeights} / \code{qgg}.} } \value{ diff --git a/man/bayesLWeights.Rd b/man/bayesLWeights.Rd index a0cc3e89..4bce15cc 100644 --- a/man/bayesLWeights.Rd +++ b/man/bayesLWeights.Rd @@ -4,7 +4,7 @@ \alias{bayesLWeights} \title{BayesL TWAS weights (Laplace prior, LASSO-equivalent)} \usage{ -bayesLWeights(X, y, Z = NULL, ...) +bayesLWeights(X, y, Z = NULL, methodArgs = list()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,7 +13,8 @@ bayesLWeights(X, y, Z = NULL, ...) \item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} -\item{...}{Additional arguments forwarded to \code{bayesAlphabetWeights} / +\item{methodArgs}{Optional named list of options forwarded to +\code{bayesAlphabetWeights} / \code{qgg}.} } \value{ diff --git a/man/bayesNWeights.Rd b/man/bayesNWeights.Rd index c2d37d9e..bce4733e 100644 --- a/man/bayesNWeights.Rd +++ b/man/bayesNWeights.Rd @@ -4,7 +4,7 @@ \alias{bayesNWeights} \title{BayesN TWAS weights (Gaussian prior, ridge-equivalent)} \usage{ -bayesNWeights(X, y, Z = NULL, ...) +bayesNWeights(X, y, Z = NULL, methodArgs = list()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,7 +13,8 @@ bayesNWeights(X, y, Z = NULL, ...) \item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} -\item{...}{Additional arguments forwarded to \code{bayesAlphabetWeights} / +\item{methodArgs}{Optional named list of options forwarded to +\code{bayesAlphabetWeights} / \code{qgg}.} } \value{ diff --git a/man/bayesRWeights.Rd b/man/bayesRWeights.Rd index 4a4df34f..2aa22950 100644 --- a/man/bayesRWeights.Rd +++ b/man/bayesRWeights.Rd @@ -4,7 +4,7 @@ \alias{bayesRWeights} \title{BayesR TWAS weights (hierarchical mixture prior)} \usage{ -bayesRWeights(X, y, Z = NULL, ...) +bayesRWeights(X, y, Z = NULL, methodArgs = list()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,7 +13,8 @@ bayesRWeights(X, y, Z = NULL, ...) \item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} -\item{...}{Additional arguments forwarded to \code{bayesAlphabetWeights} / +\item{methodArgs}{Optional named list of options forwarded to +\code{bayesAlphabetWeights} / \code{qgg}.} } \value{ diff --git a/man/bglrWeights.Rd b/man/bglrWeights.Rd index 336aff2d..49b12963 100644 --- a/man/bglrWeights.Rd +++ b/man/bglrWeights.Rd @@ -4,7 +4,16 @@ \alias{bglrWeights} \title{Compute Weights Using a BGLR Linear Regression Model} \usage{ -bglrWeights(X, y, model, nIter, burnIn, thin, etaArgs = list(), ...) +bglrWeights( + X, + y, + model, + nIter, + burnIn, + thin, + etaArgs = list(), + methodArgs = list() +) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -22,7 +31,8 @@ bglrWeights(X, y, model, nIter, burnIn, thin, etaArgs = list(), ...) \item{etaArgs}{Optional named list of additional arguments included in the `ETA` linear-term specification (e.g. `list(probIn = 0.05)` for BayesB).} -\item{...}{Additional arguments passed through to `BGLR::BGLR`.} +\item{methodArgs}{Optional named list of options passed through to +`BGLR::BGLR`.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/causalInferencePipeline.Rd b/man/causalInferencePipeline.Rd index e192f20b..f875ab10 100644 --- a/man/causalInferencePipeline.Rd +++ b/man/causalInferencePipeline.Rd @@ -17,8 +17,7 @@ causalInferencePipeline( mrCpipCutoff = 0.5, mrPvalCutoff = 1, combineMethods = NULL, - alleleFlip = TRUE, - ... + alleleFlip = TRUE ) } \arguments{ @@ -93,8 +92,6 @@ skips combination.} 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{ A \code{GRanges} as described above. diff --git a/man/colocPipeline.Rd b/man/colocPipeline.Rd index 7ffb7062..78b814d9 100644 --- a/man/colocPipeline.Rd +++ b/man/colocPipeline.Rd @@ -20,7 +20,7 @@ colocPipeline( p12Max = 0.001, adjustPips = TRUE, alleleFlip = TRUE, - ... + colocArgs = list() ) } \arguments{ @@ -106,7 +106,8 @@ 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}.} +\item{colocArgs}{Optional named list of additional arguments forwarded +to \code{coloc::coloc.bf_bf}.} } \value{ A \code{\linkS4class{ColocResult}}: one element per tested diff --git a/man/colocboostPipeline.Rd b/man/colocboostPipeline.Rd index f1ca6ec3..03f0e715 100644 --- a/man/colocboostPipeline.Rd +++ b/man/colocboostPipeline.Rd @@ -30,7 +30,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) bfCutoffToSkip = 0, logBfCutoffToSkip = 0, alleleFlip = TRUE, - ... + colocboostArgs = list() ) \S4method{colocboostPipeline}{QtlSumStats}( @@ -48,7 +48,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) mafCutoff = 0, macCutoff = 0, imissCutoff = 1, - ... + colocboostArgs = list() ) \S4method{colocboostPipeline}{MultiStudyQtlDataset}( @@ -71,7 +71,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) bfCutoffToSkip = 0, logBfCutoffToSkip = 0, alleleFlip = TRUE, - ... + colocboostArgs = list() ) \S4method{colocboostPipeline}{ANY}(qtlData, gwasSumStats = NULL, ...) @@ -83,9 +83,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) \item{gwasSumStats}{Optional \code{GwasSumStats} with the GWAS studies to colocalize against. \code{NULL} to skip GWAS colocalization.} -\item{...}{Additional arguments forwarded to -\code{\link[colocboost]{colocboost}} (e.g., \code{M}, \code{L}, -\code{output_level}).} +\item{...}{Required by the generic; the methods take no further arguments.} \item{contexts}{Optional character vector of context names to restrict the individual-level / QtlSumStats QTL analysis to. When \code{NULL} (default), @@ -146,6 +144,10 @@ 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.} + +\item{colocboostArgs}{Optional named list of additional arguments +forwarded to \code{\link[colocboost]{colocboost}} (e.g., \code{M}, +\code{L}, \code{output_level}).} } \value{ A \code{\linkS4class{ColocBoostResult}}: one element per diff --git a/man/ctwasPipeline.Rd b/man/ctwasPipeline.Rd index bacb53fb..48750b9c 100644 --- a/man/ctwasPipeline.Rd +++ b/man/ctwasPipeline.Rd @@ -27,7 +27,7 @@ ctwasPipeline( mergePipThresh = 0.5, mergeFilterCs = FALSE, mergeMaxSNP = Inf, - ... + ctwasArgs = list() ) } \arguments{ @@ -128,7 +128,8 @@ credible set to be selected. Default \code{FALSE}. Ignored unless \item{mergeMaxSNP}{Numeric (length 1). Per-merged-region SNP cap. Default \code{Inf}. Ignored unless \code{mergeBoundary = TRUE}.} -\item{...}{Additional arguments forwarded to \code{ctwas::ctwas_sumstats}.} +\item{ctwasArgs}{Optional named list of additional arguments +forwarded to \code{ctwas::ctwas_sumstats}.} } \value{ A \code{\link{CtwasResult}} collection: one row per \code{(gwasStudy, @@ -190,6 +191,6 @@ gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", gwasByRegion <- summaryStatsQc(gss, mafCutoff = 0.0025) ctwasPipeline(gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample), thin = 1, niterPrefit = 3, - niter = 10, min_group_size = 1, min_p_single_effect = 0, - fallbackToPrefit = TRUE) + niter = 10, fallbackToPrefit = TRUE, + ctwasArgs = list(min_group_size = 1, min_p_single_effect = 0)) } diff --git a/man/dot-penalizedRssWeights.Rd b/man/dot-penalizedRssWeights.Rd index a89ec099..b7b21099 100644 --- a/man/dot-penalizedRssWeights.Rd +++ b/man/dot-penalizedRssWeights.Rd @@ -14,12 +14,15 @@ lambda0 = 0, lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = list() ) } \arguments{ -\item{stat, LD, s, selection, penalty, gamma, alpha, lambda0, lambda2, ...}{See the +\item{stat, LD, s, selection, penalty, gamma, alpha, lambda0, lambda2}{See the public wrappers for details.} + +\item{methodArgs}{Optional named list of options forwarded to +\code{penalizedRss()}.} } \value{ Numeric weight vector of length \code{nrow(LD)}. diff --git a/man/dprWeights.Rd b/man/dprWeights.Rd index ef818c06..289ddfc3 100644 --- a/man/dprWeights.Rd +++ b/man/dprWeights.Rd @@ -7,13 +7,13 @@ \alias{dprAdaptiveGibbsWeights} \title{Compute Weights Using Dirichlet Process Regression (RcppDPR)} \usage{ -dprWeights(X, y, fittingMethod = "VB", retainFit = FALSE, ...) +dprWeights(X, y, fittingMethod = "VB", retainFit = FALSE, methodArgs = list()) -dprVbWeights(X, y, nK = 8, retainFit = FALSE, ...) +dprVbWeights(X, y, nK = 8, retainFit = FALSE, methodArgs = list()) -dprGibbsWeights(X, y, sStep = 5000, retainFit = FALSE, ...) +dprGibbsWeights(X, y, sStep = 5000, retainFit = FALSE, methodArgs = list()) -dprAdaptiveGibbsWeights(X, y, retainFit = FALSE, ...) +dprAdaptiveGibbsWeights(X, y, retainFit = FALSE, methodArgs = list()) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -26,7 +26,8 @@ dprAdaptiveGibbsWeights(X, y, retainFit = FALSE, ...) \item{retainFit}{Logical. Attach the full fitted-model object to the result. Default \code{FALSE}.} -\item{...}{Additional arguments passed through to `RcppDPR::fit_model`.} +\item{methodArgs}{Optional named list of options passed through to +`RcppDPR::fit_model`.} \item{nK}{Integer. Number of variational mixture components for the VB fit (\code{dprVbWeights}). Default \code{8}.} diff --git a/man/estCtwasParam.Rd b/man/estCtwasParam.Rd index ac08d7ff..41c48f58 100644 --- a/man/estCtwasParam.Rd +++ b/man/estCtwasParam.Rd @@ -13,7 +13,7 @@ estCtwasParam( "shared_all", "independent"), ncore = 1L, fallbackToPrefit = FALSE, - ... + ctwasArgs = list() ) } \arguments{ @@ -37,7 +37,8 @@ deliberately broad; a genuinely broken input still surfaces because the prefit re-run will itself error. Mirrors the legacy ctwas_2 workaround on toy data where the accurate EM cannot be estimated.} -\item{...}{Additional arguments forwarded to \code{ctwas::est_param} (e.g. +\item{ctwasArgs}{Optional named list of additional arguments +forwarded to \code{ctwas::est_param} (e.g. \code{min_p_single_effect}, \code{min_group_size}).} } \value{ @@ -54,6 +55,6 @@ Step 2 of the three-step \code{\link{ctwasPipeline}}: assembles \examples{ data(ctwasInputsExample) estCtwasParam(ctwasInputsExample, thin = 1, niterPrefit = 3, - niter = 10, min_group_size = 1, min_p_single_effect = 0, - fallbackToPrefit = TRUE) + niter = 10, fallbackToPrefit = TRUE, + ctwasArgs = list(min_group_size = 1, min_p_single_effect = 0)) } diff --git a/man/estimateH2.Rd b/man/estimateH2.Rd index a75f6101..27d72f6d 100644 --- a/man/estimateH2.Rd +++ b/man/estimateH2.Rd @@ -21,6 +21,7 @@ estimateH2( annotations = NULL, local = FALSE, study = NULL, + estimatorArgs = list(), ... ) } @@ -58,6 +59,9 @@ unstratified estimation.} \item{study}{Character (length 1) or \code{NULL}. Restrict the selection to this study; \code{NULL} matches all studies.} + +\item{estimatorArgs}{Optional named list of estimator-specific options +(\code{lambda} for lder / gldsc / hdl, \code{nIter} for sldsc).} } \value{ An \code{H2Estimate} object. diff --git a/man/extractCsInfo.Rd b/man/extractCsInfo.Rd index 3661559b..e7fb0fdb 100644 --- a/man/extractCsInfo.Rd +++ b/man/extractCsInfo.Rd @@ -7,8 +7,10 @@ extractCsInfo(fmRow, csNames, topLociTable, ldSource) } \arguments{ -\item{fmRow}{A \code{\link{fineMappingRow}} carrying the SuSiE -fit and variant ids (e.g. from \code{\link{getFineMappingResult}}).} +\item{fmRow}{A \code{\link{fineMappingRow}}, or a single-row +fine-mapping collection as returned by +\code{\link{getFineMappingResult}}, carrying the SuSiE fit and +variant ids.} \item{csNames}{Character vector. Names of the Credible Sets, usually in the format "L_".} diff --git a/man/extractTopPipInfo.Rd b/man/extractTopPipInfo.Rd index 6851486e..8358ae3a 100644 --- a/man/extractTopPipInfo.Rd +++ b/man/extractTopPipInfo.Rd @@ -7,8 +7,10 @@ extractTopPipInfo(fmRow, sumstats) } \arguments{ -\item{fmRow}{A \code{\link{fineMappingRow}} carrying the SuSiE -fit and variant ids (e.g. from \code{\link{getFineMappingResult}}).} +\item{fmRow}{A \code{\link{fineMappingRow}}, or a single-row +fine-mapping collection as returned by +\code{\link{getFineMappingResult}}, carrying the SuSiE fit and +variant ids.} \item{sumstats}{A list or data frame carrying a \code{z} element aligned to the fit's variants (\code{sumstats$z}).} diff --git a/man/finemapCtwasRegions.Rd b/man/finemapCtwasRegions.Rd index d056869f..6827dd14 100644 --- a/man/finemapCtwasRegions.Rd +++ b/man/finemapCtwasRegions.Rd @@ -4,7 +4,7 @@ \alias{finemapCtwasRegions} \title{Fine-map cTWAS regions} \usage{ -finemapCtwasRegions(screenResult, L = 5L, ncore = 1L, ...) +finemapCtwasRegions(screenResult, L = 5L, ncore = 1L, ctwasArgs = list()) } \arguments{ \item{screenResult}{A list returned by \code{\link{screenCtwasRegions}}.} @@ -13,7 +13,8 @@ finemapCtwasRegions(screenResult, L = 5L, ncore = 1L, ...) \item{ncore}{Number of cores.} -\item{...}{Additional arguments forwarded to \code{ctwas::finemap_regions}.} +\item{ctwasArgs}{Optional named list of additional arguments +forwarded to \code{ctwas::finemap_regions}.} } \value{ A list mirroring \code{ctwas::ctwas_sumstats}'s output: @@ -45,7 +46,8 @@ gwasByRegion <- summaryStatsQc(gss, mafCutoff = 0.0025) inp <- assembleCtwasInputs(gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample)) est <- estCtwasParam(inp, thin = 1, niterPrefit = 3, niter = 10, - min_group_size = 1, min_p_single_effect = 0, fallbackToPrefit = TRUE) + fallbackToPrefit = TRUE, + ctwasArgs = list(min_group_size = 1, min_p_single_effect = 0)) screened <- screenCtwasRegions(est, L = 5L) finemapCtwasRegions(screened, L = 5L) } diff --git a/man/fitFsusie.Rd b/man/fitFsusie.Rd index bffdf235..31a6a70a 100644 --- a/man/fitFsusie.Rd +++ b/man/fitFsusie.Rd @@ -4,7 +4,7 @@ \alias{fitFsusie} \title{Fit fSuSiE on individual-level (X, Y, pos) data} \usage{ -fitFsusie(X, Y, pos, ...) +fitFsusie(X, Y, pos, methodArgs = list()) } \arguments{ \item{X}{Numeric matrix of genotypes (samples x variants).} @@ -13,7 +13,8 @@ fitFsusie(X, Y, pos, ...) \item{pos}{Numeric vector of trait positions (length \code{ncol(Y)}).} -\item{...}{Additional arguments forwarded to \code{fsusieR::susiF}.} +\item{methodArgs}{Optional named list of options forwarded to +\code{fsusieR::susiF}.} } \value{ The fit object returned by \code{fsusieR::susiF}. @@ -30,5 +31,5 @@ base <- sin(seq(0, 2 * pi, length.out = nPos)) Y <- matrix(rep(base, each = n), n, nPos) + X[, 1] \%o\% (0.5 * cos(seq(0, pi, length.out = nPos))) pos <- seq_len(nPos) -fitFsusie(X, Y, pos = pos, L = 2) +fitFsusie(X, Y, pos = pos, methodArgs = list(L = 2)) } diff --git a/man/fitMvsusie.Rd b/man/fitMvsusie.Rd index 306d39f0..df6cb11a 100644 --- a/man/fitMvsusie.Rd +++ b/man/fitMvsusie.Rd @@ -4,7 +4,7 @@ \alias{fitMvsusie} \title{Fit mvSuSiE on individual-level (X, Y) data} \usage{ -fitMvsusie(X, Y, prior_variance, coverage = 0.95, ...) +fitMvsusie(X, Y, prior_variance, coverage = 0.95, methodArgs = list()) } \arguments{ \item{X}{Numeric matrix of genotypes (samples x variants).} @@ -18,7 +18,8 @@ domain-specific prior.} \item{coverage}{Credible set coverage (default 0.95).} -\item{...}{Additional arguments forwarded to \code{mvsusieR::mvsusie}.} +\item{methodArgs}{Optional named list of options forwarded to +\code{mvsusieR::mvsusie}.} } \value{ The fit object returned by \code{mvsusieR::mvsusie}. diff --git a/man/fitMvsusieRss.Rd b/man/fitMvsusieRss.Rd index 8fb8aa55..2f5057b1 100644 --- a/man/fitMvsusieRss.Rd +++ b/man/fitMvsusieRss.Rd @@ -4,7 +4,7 @@ \alias{fitMvsusieRss} \title{Fit mvSuSiE-RSS on summary-statistic (Z, R, N) data} \usage{ -fitMvsusieRss(Z, R, N, prior_variance, coverage = 0.95, ...) +fitMvsusieRss(Z, R, N, prior_variance, coverage = 0.95, methodArgs = list()) } \arguments{ \item{Z}{Numeric matrix of Z-scores (variants x conditions).} @@ -17,7 +17,8 @@ fitMvsusieRss(Z, R, N, prior_variance, coverage = 0.95, ...) \item{coverage}{Credible set coverage (default 0.95).} -\item{...}{Additional arguments forwarded to \code{mvsusieR::mvsusie_rss}.} +\item{methodArgs}{Optional named list of options forwarded to +\code{mvsusieR::mvsusie_rss}.} } \value{ The fit object returned by \code{mvsusieR::mvsusie_rss}. diff --git a/man/fsusieWrapper.Rd b/man/fsusieWrapper.Rd index 0329eb1a..20af1a3c 100644 --- a/man/fsusieWrapper.Rd +++ b/man/fsusieWrapper.Rd @@ -4,7 +4,18 @@ \alias{fsusieWrapper} \title{Wrapper for fsusie Function with Automatic Post-Processing} \usage{ -fsusieWrapper(X, Y, pos, L, prior, maxSnpEm, covLev, minPurity, maxScale, ...) +fsusieWrapper( + X, + Y, + pos, + L, + prior, + maxSnpEm, + covLev, + minPurity, + maxScale, + methodArgs = list() +) } \arguments{ \item{X}{Residual genotype matrix.} @@ -27,7 +38,8 @@ model.} \item{maxScale}{numeric, define the maximum of wavelet coefficients used in the analysis (2^maxScale). Set 10 true by default.} -\item{...}{Additional arguments passed to the fsusie function.} +\item{methodArgs}{Optional named list of options passed to +\code{fsusieR::susiF}.} } \value{ A modified fsusie object with the susie sets list, correlations for diff --git a/man/l0learnRssWeights.Rd b/man/l0learnRssWeights.Rd index 95719d3d..3d30bcdd 100644 --- a/man/l0learnRssWeights.Rd +++ b/man/l0learnRssWeights.Rd @@ -14,7 +14,7 @@ l0learnRssWeights( lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), maxSwaps = 100, - ... + methodArgs = list() ) } \arguments{ @@ -42,7 +42,8 @@ Default \code{"L0"}.} \item{maxSwaps}{Maximum swap rounds per lambda. Default 100.} -\item{...}{Additional arguments passed to \code{penalizedRss()}.} +\item{methodArgs}{Optional named list of options passed to +\code{penalizedRss()}.} } \value{ A numeric vector of SNP coefficient weights. diff --git a/man/l0learnWeights.Rd b/man/l0learnWeights.Rd index 836652d2..09db82ab 100644 --- a/man/l0learnWeights.Rd +++ b/man/l0learnWeights.Rd @@ -4,7 +4,7 @@ \alias{l0learnWeights} \title{Compute Weights Using L0Learn} \usage{ -l0learnWeights(X, y, penalty = "L0", nFolds = 5, ...) +l0learnWeights(X, y, penalty = "L0", nFolds = 5, methodArgs = list()) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -16,7 +16,8 @@ l0learnWeights(X, y, penalty = "L0", nFolds = 5, ...) \item{nFolds}{Number of cross-validation folds. Default is 5.} -\item{...}{Additional arguments passed through to `L0Learn::L0Learn.cvfit` +\item{methodArgs}{Optional named list of options passed through to +`L0Learn::L0Learn.cvfit` (e.g. `nGamma`, `gammaMin`, `gammaMax`, `algorithm`, `maxSuppSize`).} } \value{ diff --git a/man/lassosumRssWeights.Rd b/man/lassosumRssWeights.Rd index d911d571..87128ba0 100644 --- a/man/lassosumRssWeights.Rd +++ b/man/lassosumRssWeights.Rd @@ -9,7 +9,7 @@ lassosumRssWeights( LD, s = c(0.2, 0.5, 0.9, 1), selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = list() ) } \arguments{ @@ -25,7 +25,8 @@ sample sizes).} \eqn{c^T \beta / \sqrt{\beta^T R \beta}} on the supplied LD matrix. \code{"minFbeta"} is retained as an explicit alternative for debugging.} -\item{...}{Additional arguments passed to \code{lassosumRss()}.} +\item{methodArgs}{Optional named list of options passed to +\code{lassosumRss()}.} } \value{ A numeric vector of the posterior SNP coefficients at the best (s, diff --git a/man/ldMismatchQc.Rd b/man/ldMismatchQc.Rd index 290e6c41..8ea5b375 100644 --- a/man/ldMismatchQc.Rd +++ b/man/ldMismatchQc.Rd @@ -11,7 +11,7 @@ ldMismatchQc( nSample = NULL, method = c("slalom", "dentist"), ldMethod = "sample", - ... + methodArgs = list() ) } \arguments{ @@ -34,8 +34,8 @@ when \code{X} is provided.} \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is provided directly.} -\item{...}{Additional arguments passed to the underlying QC method -(\code{\link{dentistSingleWindow}} or \code{\link{slalom}}).} +\item{methodArgs}{Optional named list of options passed to the +underlying QC method (\code{slalom} or \code{dentistSingleWindow}).} } \value{ A data frame with at least a logical \code{outlier} column indicating diff --git a/man/learnTwasWeights.Rd b/man/learnTwasWeights.Rd index f3f2396b..819d408a 100644 --- a/man/learnTwasWeights.Rd +++ b/man/learnTwasWeights.Rd @@ -50,7 +50,12 @@ set to -1, the function uses all available cores. If set to 0 or 1, no parallel processing is performed. If set to 2 or more, parallel processing is enabled with that many threads.} -\item{fittedModels}{Optional named list of fitted SuSiE-family models.} +\item{fittedModels}{Named list of fitted SuSiE-family models, keyed by +token (\code{susie}, \code{susieInf}, \code{mvsusie}, \code{fsusie}). +Required whenever a SuSiE-family weight method is requested: those +methods extract weights from an existing fit and never fine-map, so a +missing fit is an error. Run \code{\link{fineMappingPipeline}} to +produce the fits.} \item{retainFits}{If TRUE, retain fitted model objects as attributes on returned weight matrices when supported by the weight method.} @@ -91,6 +96,10 @@ parallel processing to handle multiple methods. data(multiTraitData) X <- multiTraitData$X[, 1:80] Y <- multiTraitData$Y +# SuSiE-family methods extract weights from an existing fit and never +# fine-map themselves, so the fit is supplied via `fittedModels`. +fit <- susieR::susie(X, Y[, 1], L = 5) learnTwasWeights(X, Y[, 1, drop = FALSE], - weightMethods = list(susie_weights = list())) + weightMethods = list(susie_weights = list()), + fittedModels = list(susie = fit)) } diff --git a/man/mcpRssWeights.Rd b/man/mcpRssWeights.Rd index d1293bb5..17d56712 100644 --- a/man/mcpRssWeights.Rd +++ b/man/mcpRssWeights.Rd @@ -11,7 +11,7 @@ mcpRssWeights( gamma = 3, alpha = 1, selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = list() ) } \arguments{ @@ -30,7 +30,8 @@ sample sizes).} \item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or \code{"minFbeta"}.} -\item{...}{Additional arguments passed to \code{penalizedRss()}.} +\item{methodArgs}{Optional named list of options passed to +\code{penalizedRss()}.} } \value{ A numeric vector of SNP coefficient weights. diff --git a/man/mcpWeights.Rd b/man/mcpWeights.Rd index 0b5e4a3f..5126ddd8 100644 --- a/man/mcpWeights.Rd +++ b/man/mcpWeights.Rd @@ -4,7 +4,7 @@ \alias{mcpWeights} \title{Compute Weights Using MCP-Penalized Regression} \usage{ -mcpWeights(X, y, nfolds = 5, ...) +mcpWeights(X, y, nfolds = 5, methodArgs = list()) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -13,7 +13,8 @@ mcpWeights(X, y, nfolds = 5, ...) \item{nfolds}{Number of cross-validation folds. Default is 5.} -\item{...}{Additional arguments passed through to `ncvreg::cv.ncvreg`.} +\item{methodArgs}{Optional named list of options passed through to +`ncvreg::cv.ncvreg`.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/mergeCtwasBoundaryRegions.Rd b/man/mergeCtwasBoundaryRegions.Rd index b5a8cb52..899c2e66 100644 --- a/man/mergeCtwasBoundaryRegions.Rd +++ b/man/mergeCtwasBoundaryRegions.Rd @@ -11,7 +11,7 @@ mergeCtwasBoundaryRegions( maxSNP = Inf, L = 5L, ncore = 1L, - ... + ctwasArgs = list() ) } \arguments{ @@ -38,7 +38,9 @@ re-fine-mapping (LD path only). Default \code{5}.} \item{ncore}{Number of cores. Default \code{1}.} -\item{...}{Forwarded to the underlying ctwas postprocess function.} +\item{ctwasArgs}{Optional named list of additional arguments +forwarded to the underlying ctwas postprocess +function.} } \value{ The \code{finemapResult} list with \code{finemap_res}, diff --git a/man/mrashRssWeights.Rd b/man/mrashRssWeights.Rd index d943a86b..358e7616 100644 --- a/man/mrashRssWeights.Rd +++ b/man/mrashRssWeights.Rd @@ -4,7 +4,16 @@ \alias{mrashRssWeights} \title{Extract weights from mr.ash.rss (susieR)} \usage{ -mrashRssWeights(stat, LD, varY, sigma2E, s0, w0, z = numeric(0), ...) +mrashRssWeights( + stat, + LD, + varY, + sigma2E, + s0, + w0, + z = numeric(0), + methodArgs = list() +) } \arguments{ \item{stat}{A list of summary statistics with elements \code{b} (effect @@ -26,7 +35,8 @@ grid).} \item{z}{Optional numeric vector of z-scores; defaults to \code{numeric(0)} (derived from \code{stat}).} -\item{...}{Additional arguments forwarded to \code{mr.ash.rss}.} +\item{methodArgs}{Optional named list of options forwarded to +\code{mr.ash.rss}.} } \value{ A numeric vector of the posterior mean of the coefficients. diff --git a/man/mrashWeights.Rd b/man/mrashWeights.Rd index 60769b45..8b522edb 100644 --- a/man/mrashWeights.Rd +++ b/man/mrashWeights.Rd @@ -4,7 +4,7 @@ \alias{mrashWeights} \title{Compute Weights Using mr.ash Shrinkage} \usage{ -mrashWeights(X, y, initPriorSd = TRUE, retainFit = FALSE, ...) +mrashWeights(X, y, initPriorSd = TRUE, retainFit = FALSE, methodArgs = list()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -17,7 +17,7 @@ from the data. Default \code{TRUE}.} \item{retainFit}{Logical. Attach the full fitted-model object to the result. Default \code{FALSE}.} -\item{...}{Additional arguments forwarded to \code{mr.ash}.} +\item{methodArgs}{Optional named list of options forwarded to \code{mr.ash}.} } \value{ A numeric vector of weights, one per variant (column of \code{X}); diff --git a/man/mrmashRssWeights.Rd b/man/mrmashRssWeights.Rd index 84b40a47..2d8920af 100644 --- a/man/mrmashRssWeights.Rd +++ b/man/mrmashRssWeights.Rd @@ -16,7 +16,7 @@ mrmashRssWeights( covY = NULL, retainFit = FALSE, fitDetail = c("slim", "full"), - ... + methodArgs = list() ) } \arguments{ @@ -60,7 +60,8 @@ coefficients are already the returned weights); \code{"full"} additionally keeps the complete \code{mr.mash.rss} fit under \code{$fit}. Mirrors \code{\link{mrmashWeights}}.} -\item{...}{Additional arguments forwarded to \code{mr.mashr::mr.mash.rss}.} +\item{methodArgs}{Optional named list of options forwarded to +\code{mr.mashr::mr.mash.rss}.} } \value{ A numeric matrix of per-variant per-context weights (variants x diff --git a/man/mrmashWeights.Rd b/man/mrmashWeights.Rd index 66e204c4..3d77d550 100644 --- a/man/mrmashWeights.Rd +++ b/man/mrmashWeights.Rd @@ -10,7 +10,8 @@ mrmashWeights( Y = NULL, retainFit = FALSE, fitDetail = c("slim", "full"), - ... + dataDrivenPriorMatrices = NULL, + methodArgs = list() ) } \arguments{ @@ -33,7 +34,12 @@ is not duplicated. `"full"` additionally retains the complete mr.mash fit under `$fit` (consistent with how susie fits are kept), at the cost of a larger payload.} -\item{...}{Additional arguments passed to `mrmashWrapper()` when fitting.} +\item{dataDrivenPriorMatrices}{Optional list of data-driven prior +covariance matrices; forwarded to \code{mrmashWrapper} when it has to fit, +and retained in the payload for mvSuSiE prior reconstruction.} + +\item{methodArgs}{Optional named list of options passed to +`mrmashWrapper()` when fitting.} } \value{ Matrix of variant weights. diff --git a/man/mrmashWrapper.Rd b/man/mrmashWrapper.Rd index 74920a3c..b030d3a6 100644 --- a/man/mrmashWrapper.Rd +++ b/man/mrmashWrapper.Rd @@ -21,8 +21,7 @@ mrmashWrapper( bInitMethod = "enet", maxIter = 5000, tol = 0.01, - verbose = FALSE, - ... + verbose = FALSE ) } \arguments{ @@ -75,8 +74,6 @@ Default is "enet".} \item{verbose}{A logical indicating whether to print verbose output. Default is FALSE.} - -\item{...}{Additional arguments to be passed to mr.mash.} } \value{ A mr.mash fit, stored as a list with some or all of the following diff --git a/man/mvsusieRssWeights.Rd b/man/mvsusieRssWeights.Rd index b3505080..9c4791d8 100644 --- a/man/mvsusieRssWeights.Rd +++ b/man/mvsusieRssWeights.Rd @@ -4,17 +4,7 @@ \alias{mvsusieRssWeights} \title{Compute mvSuSiE-RSS TWAS weights from summary statistics} \usage{ -mvsusieRssWeights( - stat, - LD, - mvsusieRssFit = NULL, - priorVariance = NULL, - residualVariance = NULL, - L = 10, - LGreedy = NULL, - retainFit = FALSE, - ... -) +mvsusieRssWeights(stat, LD, mvsusieRssFit = NULL, retainFit = FALSE) } \arguments{ \item{stat}{A list with \code{z} (matrix variants x conditions) and \code{n} @@ -22,24 +12,10 @@ mvsusieRssWeights( \item{LD}{LD correlation matrix.} -\item{mvsusieRssFit}{Optional pre-fitted \code{mvsusieRss} object.} - -\item{priorVariance}{Optional mvSuSiE prior variance specification. When -NULL, \code{mvsusieR::create_mixture_prior()} is used with \code{R = -ncol(stat$z)}.} - -\item{residualVariance}{Optional residual covariance matrix.} - -\item{L}{Maximum number of single effects. Default \code{10}, matching -\code{mvsusieR::mvsusie}.} - -\item{LGreedy}{Integer or \code{NULL}. Number of greedily-added effects. -\code{NULL} (default) disables the greedy loop and fits \code{L} -directly.} +\item{mvsusieRssFit}{A fitted \code{mvsusieRss} object. Required: this +extracts weights and never runs fine-mapping itself.} \item{retainFit}{If TRUE, attaches the fitted object as an attribute.} - -\item{...}{Additional arguments forwarded to \code{mvsusieR::mvsusie_rss}.} } \value{ A numeric matrix of per-variant per-context weights (variants x diff --git a/man/mvsusieWeights.Rd b/man/mvsusieWeights.Rd index b52b2c1c..615c2f81 100644 --- a/man/mvsusieWeights.Rd +++ b/man/mvsusieWeights.Rd @@ -4,46 +4,18 @@ \alias{mvsusieWeights} \title{Compute mvSuSiE TWAS weights} \usage{ -mvsusieWeights( - mvsusieFit = NULL, - X = NULL, - Y = NULL, - priorVariance = NULL, - residualVariance = NULL, - L = 10, - LGreedy = NULL, - verbose = FALSE, - ... -) +mvsusieWeights(mvsusieFit = NULL) } \arguments{ -\item{mvsusieFit}{Optional fitted mvSuSiE object.} - -\item{X}{Genotype matrix. Required when `mvsusieFit` is NULL.} - -\item{Y}{Phenotype matrix. Required when `mvsusieFit` is NULL.} - -\item{priorVariance}{Optional mvSuSiE prior variance list.} - -\item{residualVariance}{Optional residual variance matrix.} - -\item{L}{Maximum number of components. Default \code{10}, matching -\code{mvsusieR::mvsusie}.} - -\item{LGreedy}{Integer or \code{NULL}. Number of greedily-added components. -\code{NULL} (default) disables the greedy loop and fits \code{L} -directly.} - -\item{verbose}{If TRUE, prints mvSuSiE fitting progress.} - -\item{...}{Additional arguments passed to `fitMvsusie()` when fitting.} +\item{mvsusieFit}{A fitted mvSuSiE object. Required.} } \value{ Matrix of variant weights. } \description{ -Extracts coefficients from an existing mvSuSiE fit or fits `fitMvsusie()` -from `X` and `Y`. +Extracts coefficients from an existing mvSuSiE fit. This never fits +mvSuSiE itself: fine-mapping belongs to \code{fineMappingPipeline()}, and a +missing fit is an error rather than an invitation to refit. } \examples{ \donttest{ @@ -52,6 +24,9 @@ library(susieR) data(multiTraitData) X <- multiTraitData$X[, 1:60] Y <- multiTraitData$Y -mvsusieWeights(X = X, Y = Y, L = 5, LGreedy = 2) +fit <- fitMvsusie(X = X, Y = Y, + prior_variance = mvsusieR::create_mixture_prior(R = ncol(Y)), + methodArgs = list(L = 5)) +mvsusieWeights(mvsusieFit = fit) } } diff --git a/man/ncvregWeights.Rd b/man/ncvregWeights.Rd index a67d25f3..117c9bcd 100644 --- a/man/ncvregWeights.Rd +++ b/man/ncvregWeights.Rd @@ -4,7 +4,7 @@ \alias{ncvregWeights} \title{Compute Weights Using ncvreg with SCAD or MCP Penalty} \usage{ -ncvregWeights(X, y, penalty, nfolds = 5, ...) +ncvregWeights(X, y, penalty, nfolds = 5, methodArgs = list()) } \arguments{ \item{X}{A numeric matrix of predictors (no intercept column; `ncvreg` @@ -16,7 +16,8 @@ standardizes internally and adds its own intercept).} \item{nfolds}{Number of cross-validation folds. Default is 5.} -\item{...}{Additional arguments passed through to `ncvreg::cv.ncvreg`.} +\item{methodArgs}{Optional named list of options passed through to +`ncvreg::cv.ncvreg`.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/prsCsWeights.Rd b/man/prsCsWeights.Rd index f523a1cc..f88a2652 100644 --- a/man/prsCsWeights.Rd +++ b/man/prsCsWeights.Rd @@ -4,7 +4,7 @@ \alias{prsCsWeights} \title{Extract weights from prsCs function} \usage{ -prsCsWeights(stat, LD, ...) +prsCsWeights(stat, LD, methodArgs = list()) } \arguments{ \item{stat}{A list of summary statistics with elements \code{b} (effect @@ -13,7 +13,7 @@ sizes) and \code{n} (per-variant sample sizes).} \item{LD}{Numeric LD (correlation) matrix aligned to the variants in \code{stat}.} -\item{...}{Additional arguments forwarded to \code{prsCs}.} +\item{methodArgs}{Optional named list of options forwarded to \code{prsCs}.} } \value{ A numeric vector of the posterior SNP coefficients. @@ -33,5 +33,5 @@ stat <- list( n = rep(nrow(X), ncol(X)) ) LD <- cor(X) -prsCsWeights(stat, LD, maf = rep(0.3, ncol(X))) +prsCsWeights(stat, LD, methodArgs = list(maf = rep(0.3, ncol(X)))) } diff --git a/man/qtlEnrichmentPipeline.Rd b/man/qtlEnrichmentPipeline.Rd index c257aa45..9db82485 100644 --- a/man/qtlEnrichmentPipeline.Rd +++ b/man/qtlEnrichmentPipeline.Rd @@ -13,7 +13,8 @@ qtlEnrichmentPipeline( impN = 25, numThreads = 1L, seed = NULL, - ... + verbose = TRUE, + enrichmentArgs = list() ) } \arguments{ @@ -41,7 +42,10 @@ if the input PIP vector is not genome-wide.} \code{\link{qtlEnrichment}} for reproducible multiple imputation. \code{NULL} (default) draws a nondeterministic seed.} -\item{...}{Additional arguments forwarded to \code{\link{qtlEnrichment}}.} +\item{verbose}{Logical. Print progress messages. Default \code{TRUE}.} + +\item{enrichmentArgs}{Optional named list of options forwarded to +\code{\link{qtlEnrichment}}.} } \value{ A tibble with one row per (outcome trait, annotation unit) pair. diff --git a/man/readGenotypes.Rd b/man/readGenotypes.Rd index 56410d8f..121e14dd 100644 --- a/man/readGenotypes.Rd +++ b/man/readGenotypes.Rd @@ -8,9 +8,9 @@ \usage{ readGenotypes(path, format = NULL, ...) -\S4method{readGenotypes}{character}(path, format = NULL, ...) +\S4method{readGenotypes}{character}(path, format = NULL, vcfArgs = list(), ...) -\S4method{readGenotypes}{missing}(path, format = NULL, ...) +\S4method{readGenotypes}{missing}(path, format = NULL, vcfArgs = list(), ...) } \arguments{ \item{path}{Character, path to a single self-describing genotype file @@ -23,6 +23,9 @@ inferred from file extension.} \item{...}{The keyword source arguments described above, plus any further arguments forwarded to the format-specific reader.} + +\item{vcfArgs}{Optional named list of arguments forwarded to +\code{VariantAnnotation::readVcf} when the source is a VCF.} } \value{ A \code{RangedSummarizedExperiment} of variants x samples. diff --git a/man/scadRssWeights.Rd b/man/scadRssWeights.Rd index 719963b9..926a2f94 100644 --- a/man/scadRssWeights.Rd +++ b/man/scadRssWeights.Rd @@ -11,7 +11,7 @@ scadRssWeights( gamma = 3.7, alpha = 1, selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = list() ) } \arguments{ @@ -30,7 +30,8 @@ sample sizes).} \item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or \code{"minFbeta"}.} -\item{...}{Additional arguments passed to \code{penalizedRss()}.} +\item{methodArgs}{Optional named list of options passed to +\code{penalizedRss()}.} } \value{ A numeric vector of SNP coefficient weights. diff --git a/man/scadWeights.Rd b/man/scadWeights.Rd index 0a200d5a..6f862c68 100644 --- a/man/scadWeights.Rd +++ b/man/scadWeights.Rd @@ -4,7 +4,7 @@ \alias{scadWeights} \title{Compute Weights Using SCAD-Penalized Regression} \usage{ -scadWeights(X, y, nfolds = 5, ...) +scadWeights(X, y, nfolds = 5, methodArgs = list()) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -13,7 +13,8 @@ scadWeights(X, y, nfolds = 5, ...) \item{nfolds}{Number of cross-validation folds. Default is 5.} -\item{...}{Additional arguments passed through to `ncvreg::cv.ncvreg`.} +\item{methodArgs}{Optional named list of options passed through to +`ncvreg::cv.ncvreg`.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/screenCtwasRegions.Rd b/man/screenCtwasRegions.Rd index 006bb7b5..751b3404 100644 --- a/man/screenCtwasRegions.Rd +++ b/man/screenCtwasRegions.Rd @@ -4,7 +4,7 @@ \alias{screenCtwasRegions} \title{Screen cTWAS regions} \usage{ -screenCtwasRegions(estResult, L = 5L, ncore = 1L, ...) +screenCtwasRegions(estResult, L = 5L, ncore = 1L, ctwasArgs = list()) } \arguments{ \item{estResult}{A list returned by \code{\link{estCtwasParam}}.} @@ -16,7 +16,8 @@ single-effect (SER) model and ignores L. \code{L} is applied by \item{ncore}{Number of cores.} -\item{...}{Additional arguments forwarded to \code{ctwas::screen_regions} +\item{ctwasArgs}{Optional named list of additional arguments +forwarded to \code{ctwas::screen_regions} (e.g. \code{min_nonSNP_PIP}, \code{min_snp_pval}, \code{min_var}, \code{min_gene}).} } diff --git a/man/sdprWeights.Rd b/man/sdprWeights.Rd index 498318a2..05581eba 100644 --- a/man/sdprWeights.Rd +++ b/man/sdprWeights.Rd @@ -4,7 +4,7 @@ \alias{sdprWeights} \title{Extract weights from sdpr function} \usage{ -sdprWeights(stat, LD, ...) +sdprWeights(stat, LD, methodArgs = list()) } \arguments{ \item{stat}{A list of summary statistics with elements \code{b} (effect @@ -13,7 +13,7 @@ sizes) and \code{n} (per-variant sample sizes).} \item{LD}{Numeric LD (correlation) matrix aligned to the variants in \code{stat}.} -\item{...}{Additional arguments forwarded to \code{sdpr}.} +\item{methodArgs}{Optional named list of options forwarded to \code{sdpr}.} } \value{ A numeric vector of the posterior SNP coefficients. diff --git a/man/susieAshRssWeights.Rd b/man/susieAshRssWeights.Rd index bb9b6953..d1b39b0d 100644 --- a/man/susieAshRssWeights.Rd +++ b/man/susieAshRssWeights.Rd @@ -4,13 +4,7 @@ \alias{susieAshRssWeights} \title{Compute SuSiE-ASH-RSS TWAS weights} \usage{ -susieAshRssWeights( - stat, - LD, - susieAshRssFit = NULL, - retainFit = TRUE, - methodArgs = list() -) +susieAshRssWeights(stat, LD, susieAshRssFit = NULL, retainFit = TRUE) } \arguments{ \item{stat}{List with components \code{z} (z-scores), \code{n} (sample @@ -21,11 +15,6 @@ sizes).} \item{susieAshRssFit}{Optional pre-fitted SuSiE-ASH-RSS object.} \item{retainFit}{If TRUE, stores the fitted object as an attribute.} - -\item{methodArgs}{Named list of additional arguments passed to -\code{susieR::susie_rss()}. Use this instead of \code{...} to avoid partial -matching of short argument names (e.g. \code{L}) to the \code{LD} -parameter.} } \value{ Numeric vector of variant weights. @@ -47,5 +36,6 @@ stat <- list( z = vapply(ss, function(s) s[1] / s[2], numeric(1)), n = rep(nrow(X), ncol(X))) LD <- cor(X) -susieAshRssWeights(stat, LD) +fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) +susieAshRssWeights(stat, LD, susieAshRssFit = fit) } diff --git a/man/susieAshWeights.Rd b/man/susieAshWeights.Rd index a914895e..b1fdd00b 100644 --- a/man/susieAshWeights.Rd +++ b/man/susieAshWeights.Rd @@ -4,19 +4,18 @@ \alias{susieAshWeights} \title{Compute SuSiE-ASH TWAS weights} \usage{ -susieAshWeights(X = NULL, y = NULL, susieAshFit = NULL, retainFit = FALSE, ...) +susieAshWeights(X = NULL, y = NULL, susieAshFit = NULL, retainFit = FALSE) } \arguments{ -\item{X}{Genotype matrix. Required when `susieAshFit` is NULL.} +\item{X}{Optional genotype matrix; when supplied it is only used to +check that the fit covers the same number of variants.} -\item{y}{Phenotype vector. Required when `susieAshFit` is NULL.} +\item{y}{Unused; retained for signature compatibility.} \item{susieAshFit}{Optional fitted SuSiE-ASH object.} \item{retainFit}{If TRUE, stores the fitted object as an attribute on the returned weights.} - -\item{...}{Additional arguments passed to `susieR::susie()` when fitting.} } \value{ Numeric vector of variant weights. @@ -29,5 +28,6 @@ Extracts coefficients from an existing SuSiE-ASH fit or fits data(eqtlRegionExample) X <- eqtlRegionExample$X[, 1:30] y <- eqtlRegionExample$yRes -susieAshWeights(X, y) +fit <- susieR::susie(X, y, L = 5) +susieAshWeights(susieAshFit = fit) } diff --git a/man/susieInfRssWeights.Rd b/man/susieInfRssWeights.Rd index ce7df90c..56e422b7 100644 --- a/man/susieInfRssWeights.Rd +++ b/man/susieInfRssWeights.Rd @@ -4,13 +4,7 @@ \alias{susieInfRssWeights} \title{Compute SuSiE-inf-RSS TWAS weights} \usage{ -susieInfRssWeights( - stat, - LD, - susieInfRssFit = NULL, - retainFit = TRUE, - methodArgs = list() -) +susieInfRssWeights(stat, LD, susieInfRssFit = NULL, retainFit = TRUE) } \arguments{ \item{stat}{List with components \code{z} (z-scores), \code{n} (sample @@ -21,11 +15,6 @@ sizes).} \item{susieInfRssFit}{Optional pre-fitted SuSiE-inf-RSS object.} \item{retainFit}{If TRUE, stores the fitted object as an attribute.} - -\item{methodArgs}{Named list of additional arguments passed to -\code{susieR::susie_rss()}. Use this instead of \code{...} to avoid partial -matching of short argument names (e.g. \code{L}) to the \code{LD} -parameter.} } \value{ Numeric vector of variant weights. @@ -47,5 +36,6 @@ stat <- list( z = vapply(ss, function(s) s[1] / s[2], numeric(1)), n = rep(nrow(X), ncol(X))) LD <- cor(X) -susieInfRssWeights(stat, LD) +fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) +susieInfRssWeights(stat, LD, susieInfRssFit = fit) } diff --git a/man/susieInfWeights.Rd b/man/susieInfWeights.Rd index 6a5d90f3..37cb70c6 100644 --- a/man/susieInfWeights.Rd +++ b/man/susieInfWeights.Rd @@ -4,19 +4,18 @@ \alias{susieInfWeights} \title{Compute SuSiE-inf TWAS weights} \usage{ -susieInfWeights(X = NULL, y = NULL, susieInfFit = NULL, retainFit = FALSE, ...) +susieInfWeights(X = NULL, y = NULL, susieInfFit = NULL, retainFit = FALSE) } \arguments{ -\item{X}{Genotype matrix. Required when `susieInfFit` is NULL.} +\item{X}{Optional genotype matrix; when supplied it is only used to +check that the fit covers the same number of variants.} -\item{y}{Phenotype vector. Required when `susieInfFit` is NULL.} +\item{y}{Unused; retained for signature compatibility.} \item{susieInfFit}{Optional fitted SuSiE-inf object.} \item{retainFit}{If TRUE, stores the fitted object as an attribute on the returned weights.} - -\item{...}{Additional arguments passed to `susieR::susie()` when fitting.} } \value{ Numeric vector of variant weights. @@ -42,5 +41,6 @@ Extracts coefficients from an existing SuSiE-inf fit or fits data(eqtlRegionExample) X <- eqtlRegionExample$X[, 1:30] y <- eqtlRegionExample$yRes -susieInfWeights(X, y) +fit <- susieR::susie(X, y, L = 5) +susieInfWeights(susieInfFit = fit) } diff --git a/man/susieRssWeights.Rd b/man/susieRssWeights.Rd index c73eef7f..49418040 100644 --- a/man/susieRssWeights.Rd +++ b/man/susieRssWeights.Rd @@ -4,13 +4,7 @@ \alias{susieRssWeights} \title{Compute SuSiE-RSS TWAS weights} \usage{ -susieRssWeights( - stat, - LD, - susieRssFit = NULL, - retainFit = TRUE, - methodArgs = list() -) +susieRssWeights(stat, LD, susieRssFit = NULL, retainFit = TRUE) } \arguments{ \item{stat}{List with components \code{z} (z-scores), \code{n} (sample @@ -18,14 +12,10 @@ sizes).} \item{LD}{LD correlation matrix.} -\item{susieRssFit}{Optional pre-fitted SuSiE-RSS object.} +\item{susieRssFit}{A fitted SuSiE-RSS object. Required: these wrappers +extract weights and never run fine-mapping themselves.} \item{retainFit}{If TRUE, stores the fitted object as an attribute.} - -\item{methodArgs}{Named list of additional arguments passed to -\code{susieR::susie_rss()}. Use this instead of \code{...} to avoid partial -matching of short argument names (e.g. \code{L}) to the \code{LD} -parameter.} } \value{ Numeric vector of variant weights. @@ -47,5 +37,6 @@ stat <- list( z = vapply(ss, function(s) s[1] / s[2], numeric(1)), n = rep(nrow(X), ncol(X))) LD <- cor(X) -susieRssWeights(stat, LD) +fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) +susieRssWeights(stat, LD, susieRssFit = fit) } diff --git a/man/susieWeights.Rd b/man/susieWeights.Rd index 18267273..124168b3 100644 --- a/man/susieWeights.Rd +++ b/man/susieWeights.Rd @@ -4,30 +4,30 @@ \alias{susieWeights} \title{Compute SuSiE TWAS weights} \usage{ -susieWeights(X = NULL, y = NULL, susieFit = NULL, retainFit = FALSE, ...) +susieWeights(X = NULL, y = NULL, susieFit = NULL, retainFit = FALSE) } \arguments{ -\item{X}{Genotype matrix. Required when `susieFit` is NULL.} +\item{X}{Optional genotype matrix; when supplied it is only used to +check that the fit covers the same number of variants.} -\item{y}{Phenotype vector. Required when `susieFit` is NULL.} +\item{y}{Unused; retained for signature compatibility.} \item{susieFit}{Optional fitted SuSiE object.} \item{retainFit}{If TRUE, stores the fitted object as an attribute on the returned weights.} - -\item{...}{Additional arguments passed to `susieR::susie()` when fitting.} } \value{ Numeric vector of variant weights. } \description{ -Extracts coefficients from an existing SuSiE fit or fits `susieR::susie()` +Extracts coefficients from an existing SuSiE fit. from `X` and `y` before extracting weights. } \examples{ data(eqtlRegionExample) X <- eqtlRegionExample$X[, 1:30] y <- eqtlRegionExample$yRes -susieWeights(X, y) +fit <- susieR::susie(X, y, L = 5) +susieWeights(susieFit = fit) } diff --git a/man/twasWeightsCv.Rd b/man/twasWeightsCv.Rd index b3afdfa3..5392a4b5 100644 --- a/man/twasWeightsCv.Rd +++ b/man/twasWeightsCv.Rd @@ -17,7 +17,9 @@ twasWeightsCv( verbose = 1, retainFits = FALSE, seed = NULL, - ... + dataDrivenPriorMatricesCv = NULL, + reweightedMixturePriorCv = NULL, + fittedModelsCv = NULL ) } \arguments{ @@ -67,7 +69,18 @@ seed is scoped to the call, so the session RNG is left as it was found. \code{NULL} (default) does not seed at all and uses the historical parallel default.} -\item{...}{Additional arguments forwarded to the per-method weight learners.} +\item{dataDrivenPriorMatricesCv}{Optional list, one element per fold, of +data-driven prior matrices for the mr.mash learner.} + +\item{reweightedMixturePriorCv}{Optional list, one element per fold, of +reweighted mixture priors for the mvSuSiE learner.} + +\item{fittedModelsCv}{Optional per-fold fine-mapping fits, as +\code{method -> fold_ -> fit}, from a \code{fineMappingPipeline()} +run with \code{cvFolds > 1}. SuSiE-family weight wrappers extract from a +supplied fit and never fine-map, so this is what makes cross-validating +them possible; it must have been produced on \code{samplePartitions}, +since a fit trained on different folds would leak held-out samples.} } \value{ A list with the following components: @@ -105,6 +118,9 @@ method to the entire Y matrix for each fold. data(multiTraitData) X <- multiTraitData$X[, 1:80] Y <- multiTraitData$Y +# A cross-validated method is refit on each fold's training rows. The +# SuSiE family never fine-maps, so it needs each fold's own fit, passed +# as `fittedModelsCv` from a fineMappingPipeline() run with cvFolds > 1. twasWeightsCv(X, Y[, 1, drop = FALSE], fold = 3, - weightMethods = list(susie_weights = list())) + weightMethods = list(lasso_weights = list())) } diff --git a/man/twasWeightsPipeline.Rd b/man/twasWeightsPipeline.Rd index 2624d587..9d8785bf 100644 --- a/man/twasWeightsPipeline.Rd +++ b/man/twasWeightsPipeline.Rd @@ -185,7 +185,11 @@ limit).} \item{cvThreads}{Threads for CV parallelism. Default 1.} -\item{cvWeightMethods}{Optional override of methods used for CV.} +\item{cvWeightMethods}{Optional override of which methods are +cross-validated, as a character vector of tokens or a named method +list. \code{NULL} (default) cross-validates every method that +produced non-zero weights; a method whose weights are all zero is +excluded with a warning either way.} \item{ensemble}{Logical. Compute SR-TWAS ensemble weights. Default \code{TRUE}.} diff --git a/pixi.toml b/pixi.toml index 4957a48e..9b2365c7 100644 --- a/pixi.toml +++ b/pixi.toml @@ -32,7 +32,9 @@ r45 = {features = ["r45"]} "bioconductor-tidysummarizedexperiment" = "*" "gcc" = "*" "r-covr" = "*" +"r-decor" = "*" "r-devtools" = "*" +"r-goodpractice" = "*" "r-knitr" = "*" "r-lintr" = "*" "r-markdown" = "*" @@ -59,6 +61,7 @@ r45 = {features = ["r45"]} "r-base" = "*" "r-bglr" = "*" "r-bigsnpr" = "*" +"r-checkmate" = "*" "r-coda" = "*" "r-coloc" = "*" "r-colocboost" = "*" @@ -66,7 +69,6 @@ r45 = {features = ["r45"]} "r-cpp11" = "*" "r-cpp11armadillo" = "*" "r-ctwas" = "*" -"r-decor" = "*" "r-dplyr" = "*" "r-flashier" = "*" "r-fsusier" = "*" diff --git a/tests/testthat/helper-h2Classes.R b/tests/testthat/helper-h2Classes.R index fd67925b..55859738 100644 --- a/tests/testthat/helper-h2Classes.R +++ b/tests/testthat/helper-h2Classes.R @@ -249,7 +249,7 @@ makeTestLdDataMultiBlock <- function( ) { gr <- .testLdVariants(sum(sizes), chrom, startBp) LdData( - correlation = lapply(sizes, .testArBlock, rho = rho), + correlation = map(sizes, .testArBlock, rho = rho), variants = gr, blockMetadata = .testBlockMetadata(sizes, chrom, gr), nRef = nRef diff --git a/tests/testthat/helper-mash.R b/tests/testthat/helper-mash.R new file mode 100644 index 00000000..3daccf18 --- /dev/null +++ b/tests/testthat/helper-mash.R @@ -0,0 +1,30 @@ +# Shared fixtures for test_mashPipeline.R. +# +# mashr / flashier fits dominate that file's runtime. These are coverage tests +# for pecotmr's wiring, not numerical checks of mashr, so the fixture is the +# smallest slice that still drives every branch, and the prior is supplied +# outright wherever the prior itself is not what the test is about. + +# The multi-context example trimmed to `n` variants per context. Both prior +# estimation and the mash() weight fit scale with the variant count, and the +# full 200 buys nothing a branch test can see. +mashFixture <- function(n = 60L) { + utils::data( + "qtlSumStatsMulticontextExample", + package = "pecotmr", + envir = environment() + ) + full <- get("qtlSumStatsMulticontextExample", envir = environment()) + if (n >= min(lengths(full))) { + return(full) + } + endoapply(full, function(g) g[seq_len(n)]) +} + +# A two-component prior for tests where the prior is not under test. Supplying +# it takes the `priorCovariances` branch and skips the flash/pca/ed chain -- +# most of the cost -- while still running the mash() weight fit, so anything +# downstream of the prior is exercised exactly as before. +mashTinyPrior <- function(k = 3L) { + list(identity = diag(k), shared = matrix(1, k, k)) +} diff --git a/tests/testthat/helper-rrwFixtures.R b/tests/testthat/helper-rrwFixtures.R index d2b3ec0e..50a42057 100644 --- a/tests/testthat/helper-rrwFixtures.R +++ b/tests/testthat/helper-rrwFixtures.R @@ -10,7 +10,7 @@ rnorm(n * p), n, p, - dimnames = list(NULL, sprintf("chr1:%d:A:G", 100L * (seq_len(p)))) + dimnames = list(NULL, sprintf("chr1:%d:A:G", 100L * seq_len(p))) ) b <- rnorm(p) b[-(1:2)] <- 0 @@ -21,15 +21,13 @@ # Single-context summary statistics + LD for the *_rss_weights(stat, LD) contract. .rrwStatLd <- function(n = 50, p = 6, seed = 1) { d <- .rrwXy(n, p, seed) - bhat <- vapply( + bhat <- map_dbl( seq_len(p), - function(j) summary(lm(d$y ~ d$X[, j]))$coefficients[2, 1], - numeric(1) + function(j) summary(lm(d$y ~ d$X[, j]))$coefficients[2, 1] ) - sehat <- vapply( + sehat <- map_dbl( seq_len(p), - function(j) summary(lm(d$y ~ d$X[, j]))$coefficients[2, 2], - numeric(1) + function(j) summary(lm(d$y ~ d$X[, j]))$coefficients[2, 2] ) zhat <- bhat / sehat LD <- cor(d$X) @@ -52,25 +50,20 @@ rnorm(n * p), n, p, - dimnames = list(NULL, sprintf("chr1:%d:A:G", 100L * (seq_len(p)))) + dimnames = list(NULL, sprintf("chr1:%d:A:G", 100L * seq_len(p))) ) B <- matrix(0, p, K) B[1, ] <- rnorm(K, sd = 2) B[2, ] <- rnorm(K, sd = 2) Y <- X %*% B + matrix(rnorm(n * K), n, K) colnames(Y) <- paste0("ctx", seq_len(K)) - Z <- vapply( - seq_len(K), - function(k) { - vapply( - seq_len(p), - function(j) { - summary(lm(Y[, k] ~ X[, j]))$coefficients[2, 3] - }, - numeric(1) - ) - }, - numeric(p) + Z <- exec( + cbind, + !!!map(seq_len(K), function(k) { + map_dbl(seq_len(p), function(j) { + summary(lm(Y[, k] ~ X[, j]))$coefficients[2, 3] + }) + }) ) colnames(Z) <- colnames(Y) list(X = X, Y = Y, LD = cor(X), stat = list(z = Z, n = n), p = p, K = K) diff --git a/tests/testthat/helper-s4Constructors.R b/tests/testthat/helper-s4Constructors.R index aeb17c29..ccffad52 100644 --- a/tests/testthat/helper-s4Constructors.R +++ b/tests/testthat/helper-s4Constructors.R @@ -62,7 +62,7 @@ context("s4Constructors") dataType = "expression" ) { twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = rnorm(p), standardized = standardized, dataType = dataType diff --git a/tests/testthat/helper-showMethods.R b/tests/testthat/helper-showMethods.R index 0c135c49..990445a1 100644 --- a/tests/testthat/helper-showMethods.R +++ b/tests/testthat/helper-showMethods.R @@ -53,7 +53,7 @@ context("show methods") .sh_makeTwEntry <- function(p = 4, standardized = FALSE) { twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = rep(0.1, p), cvResult = list(rsq = 0.5), standardized = standardized diff --git a/tests/testthat/helper-sldsc.R b/tests/testthat/helper-sldsc.R index 4d343307..ff1bfeb2 100644 --- a/tests/testthat/helper-sldsc.R +++ b/tests/testthat/helper-sldsc.R @@ -294,6 +294,6 @@ } tr } - traits <- setNames(lapply(traitNames, function(.) mkTrait()), traitNames) + traits <- setNames(map(traitNames, function(.) mkTrait()), traitNames) SldscData(annot = annot, frq = frq, traits = traits) } diff --git a/tests/testthat/helper-twas.R b/tests/testthat/helper-twas.R index 7653fe5a..919f209a 100644 --- a/tests/testthat/helper-twas.R +++ b/tests/testthat/helper-twas.R @@ -15,17 +15,17 @@ generate_X_Y <- function( ) if (X_rownames) { - rownames(X) <- paste0("sample", 1:num_samples) + rownames(X) <- paste0("sample", seq_len(num_samples)) } else { rownames(X) <- NULL } - beta = rep(0, num_features) - beta[1:4] = 1 + beta <- rep(0, num_features) + beta[1:4] <- 1 y <- X %*% beta + rnorm(num_samples) y <- matrix(y, nrow = num_samples, ncol = 1) if (y_rownames) { - rownames(y) <- paste0("sample", 1:num_samples) + rownames(y) <- paste0("sample", seq_len(num_samples)) } else { rownames(y) <- NULL } diff --git a/tests/testthat/test_AnnotationMatrix.R b/tests/testthat/test_AnnotationMatrix.R index 8935de5e..a9bc42ca 100644 --- a/tests/testthat/test_AnnotationMatrix.R +++ b/tests/testthat/test_AnnotationMatrix.R @@ -195,6 +195,6 @@ test_that("validity names the metadata columns it requires", { SummarizedExperiment::colData(bad)$tier <- NULL expect_error( methods::validObject(bad), - "must have columns: name, tier, type" + "Colnames must include the elements \\{'name','tier','type'\\}" ) }) diff --git a/tests/testthat/test_ColocBoostResult.R b/tests/testthat/test_ColocBoostResult.R index 3967cb9b..a70aef65 100644 --- a/tests/testthat/test_ColocBoostResult.R +++ b/tests/testthat/test_ColocBoostResult.R @@ -5,7 +5,6 @@ # pair, and it computes no PP.H0-PP.H4 decomposition at all. Several tests # below guard exactly that boundary. - test_that("ColocBoostResult: one element per confidence set", { x <- ColocBoostResult( list(.cbr_fake()), @@ -374,7 +373,10 @@ test_that("validity names missing identity and outcomeInfo columns", { ) bad <- x mcols(bad)$analysis <- NULL - expect_error(methods::validObject(bad), "missing columns: analysis") + expect_error( + methods::validObject(bad), + "missing elements \\{'analysis'\\}" + ) }) @@ -434,7 +436,10 @@ test_that("validity names the outcomeInfo columns that are missing", { cb@outcomeInfo <- data.frame(name = "t1") expect_match( .cbrCheckOutcomeInfo(cb), - "outcomeInfo is missing columns: study, context, trait, dataForm" + paste0( + "outcomeInfo is missing columns: .*", + "missing elements \\{'study','context','trait','dataForm'\\}" + ) ) }) diff --git a/tests/testthat/test_ColocResult.R b/tests/testthat/test_ColocResult.R index 2bf1ddae..3ba8fad2 100644 --- a/tests/testthat/test_ColocResult.R +++ b/tests/testthat/test_ColocResult.R @@ -345,7 +345,10 @@ test_that("purity is computed per set when an LD reference is supplied", { test_that("validity names missing pair columns", { bad <- ColocResult(.cr_pairs(), .cr_variants()) mcols(bad)$gwasStudy <- NULL - expect_error(methods::validObject(bad), "missing columns: gwasStudy") + expect_error( + methods::validObject(bad), + "missing elements \\{'gwasStudy'\\}" + ) }) test_that("validity names missing posterior columns", { @@ -353,7 +356,7 @@ test_that("validity names missing posterior columns", { mcols(bad)$PP.H4.abf <- NULL expect_error( methods::validObject(bad), - "missing posterior columns: PP.H4.abf" + "missing posterior columns: .*missing elements \\{'PP.H4.abf'\\}" ) }) diff --git a/tests/testthat/test_CtwasResult.R b/tests/testthat/test_CtwasResult.R index ece4412a..b1a8531b 100644 --- a/tests/testthat/test_CtwasResult.R +++ b/tests/testthat/test_CtwasResult.R @@ -194,7 +194,10 @@ test_that("CtwasResult: show() prints a one-line-per-run summary", { test_that("validity names a missing required column", { bad <- .ctr_res() bad$context <- NULL - expect_error(methods::validObject(bad), "missing columns: context") + expect_error( + methods::validObject(bad), + "missing elements \\{'context'\\}" + ) }) test_that("validity requires one entry payload per row", { diff --git a/tests/testthat/test_GwasFineMappingResult.R b/tests/testthat/test_GwasFineMappingResult.R index b9136642..93d673cf 100644 --- a/tests/testthat/test_GwasFineMappingResult.R +++ b/tests/testthat/test_GwasFineMappingResult.R @@ -302,7 +302,7 @@ test_that("GwasFineMappingResult: .tupleSelectRowGwasFmr requires both selectors expect_error(getPip(res), "Pass `study` and `method`") expect_error( getPip(res, study = c("g1", "g2"), method = "susie"), - "must each be length 1" + "Must have length 1" ) expect_error(getPip(res, study = "ghost", method = "susie"), "No entry for") }) @@ -352,7 +352,10 @@ test_that("validity names a missing identity column", { ) bad <- res mcols(bad)$method <- NULL - expect_error(methods::validObject(bad), "missing columns: method") + expect_error( + methods::validObject(bad), + "missing elements \\{'method'\\}" + ) }) test_that("validity names a missing entry payload column", { @@ -365,6 +368,6 @@ test_that("validity names a missing entry payload column", { mcols(bad)$cvResult <- NULL expect_error( methods::validObject(bad), - "missing entry payload columns: cvResult" + "missing entry payload columns: .*missing elements \\{'cvResult'\\}" ) }) diff --git a/tests/testthat/test_LdEigen.R b/tests/testthat/test_LdEigen.R index a64d7247..5ad6daac 100644 --- a/tests/testthat/test_LdEigen.R +++ b/tests/testthat/test_LdEigen.R @@ -43,7 +43,7 @@ test_that("LdEigen rejects eigen_list length mismatch", { eigenvalueTruncation = 0.9 ) ), - "eigenList.*must match" + "Variable 'eigenList'.*Must have length" ) }) @@ -193,3 +193,49 @@ test_that("eigenvalue truncation keeps everything when there is no mass", { # ...and a truncation of 1 keeps everything by definition. expect_equal(pecotmr:::.ldEigenKeep(c(3, 2, 1), 1), 1:3) }) + +test_that("LdEigen: argument guards fire", { + ldblocks <- make_test_ldblocks() + snp_info <- make_test_snp_info(10) + eigen_list <- list( + list(values = c(1, 0.5), vectors = matrix(0, 10, 2), snpIdx = 1:10), + list(values = 0.8, vectors = matrix(0, 10, 1), snpIdx = 1:10) + ) + ok <- list( + ldBlocks = ldblocks, + snpInfo = snp_info, + nRef = 500L, + eigenList = eigen_list + ) + expect_error( + exec(LdEigen, !!!list_modify(ok, !!!list(snpInfo = "not-a-df"))), + "snpInfo.*Must be of type 'data.frame'" + ) + expect_error( + exec(LdEigen, !!!list_modify(ok, !!!list(eigenList = "not-a-list"))), + "eigenList.*Must be of type 'list'" + ) + expect_error( + exec(LdEigen, !!!list_modify(ok, !!!list(nRef = 0L))), + "nRef.*Must be >= 1" + ) + expect_error( + exec(LdEigen, !!!list_modify(ok, !!!list(nRef = "500"))), + "nRef.*Must be of type 'count'" + ) +}) + +test_that("buildLdEigen: argument guards fire", { + meta <- system.file( + "extdata", + "ld_reference", + "ld_meta_file.tsv", + package = "pecotmr" + ) + ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") + expect_error(buildLdEigen(ld, nRef = 0L), "nRef.*Must be >= 1") + expect_error( + buildLdEigen(ld, inSample = NA), + "inSample.*May not be NA" + ) +}) diff --git a/tests/testthat/test_LdScore.R b/tests/testthat/test_LdScore.R index edad43ae..db1824b2 100644 --- a/tests/testthat/test_LdScore.R +++ b/tests/testthat/test_LdScore.R @@ -39,7 +39,7 @@ test_that("LdScore rejects ld_scores row mismatch with snp_info", { ldMatrixList = list() ) ), - "ldScores.*must be parallel" + "ldScores.*Must have exactly 10 rows, but has 5 rows" ) }) @@ -73,7 +73,7 @@ test_that("LdScore rejects weights that are not parallel to the variants", { ldScoreWeights = runif(n - 1L), ldMatrixList = list() ), - "they must be parallel" + "ldScoreWeights.*Must have length 10, but has length 9" ) }) @@ -133,7 +133,7 @@ test_that("buildLdScore computes per-block sums of r^2", { test_that("buildLdScore scores each block against only its own variants", { ld <- makeTestLdDataMultiBlock(sizes = c(4L, 3L)) scores <- as.vector(getLdScores(buildLdScore(ld))[, 1]) - perBlock <- unlist(lapply(getCorrelation(ld), function(R) rowSums(R^2))) + perBlock <- unlist(map(getCorrelation(ld), function(R) rowSums(R^2))) expect_equal(length(scores), 7L) expect_equal(scores, perBlock) @@ -175,6 +175,22 @@ test_that("buildLdScore defaults weights to 1/max(l2, 1)", { expect_equal(getLdScoreWeights(custom), rep(2, 6)) expect_error( buildLdScore(ld, ldScoreWeights = rep(2, 3)), - "3 value\\(s\\) for 6 variant\\(s\\)" + "ldScoreWeights.*Must have length 6, but has length 3" + ) +}) + +test_that("buildLdScore: argument guards fire", { + meta <- system.file( + "extdata", + "ld_reference", + "ld_meta_file.tsv", + package = "pecotmr" + ) + ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") + expect_error(buildLdScore(ld, nRef = 0L), "nRef.*Must be >= 1") + expect_error(buildLdScore(ld, inSample = NA), "inSample.*May not be NA") + expect_error( + buildLdScore(ld, keepLdMatrices = NA), + "keepLdMatrices.*May not be NA" ) }) diff --git a/tests/testthat/test_LdStatistic.R b/tests/testthat/test_LdStatistic.R index f829bf3f..6141ad29 100644 --- a/tests/testthat/test_LdStatistic.R +++ b/tests/testthat/test_LdStatistic.R @@ -49,7 +49,7 @@ test_that("getGenome returns the genome build string (via an LdScore subclass)", test_that("validity rejects an nRef that is not a single positive integer", { # Matched on the validity text, not just "nRef": the argument name alone # also appears in R's own argument-matching errors. - msg <- "'nRef' must be a single positive integer" + msg <- "Variable 'nRef'" expect_error(.lds_score(nRef = 0L), msg) expect_error(.lds_score(nRef = -1L), msg) expect_error(.lds_score(nRef = c(10L, 20L)), msg) @@ -62,7 +62,7 @@ test_that("validity rejects an inSample that is not a single flag", { # not collapse length, which is why the nRef branch IS reachable above.) # This one guards direct new() use -- migration scripts, deserialization. gr <- as(.lds_score(), "GRanges") - msg <- "'inSample' must be a single logical value" + msg <- "Variable 'inSample': Must have length 1" mk <- function(flag) { methods::new( "LdScore", @@ -384,7 +384,7 @@ test_that("a block matrix sized differently from its span is rejected", { correlation = list(diag(2), diag(2)), blockMetadata = misSpan )), - "correlation matrix is 2x2 but covers 3 variant" + "LD block correlation.*Must have exactly 3 rows" ) }) diff --git a/tests/testthat/test_MashPrior.R b/tests/testthat/test_MashPrior.R index 753390ab..11082b8d 100644 --- a/tests/testthat/test_MashPrior.R +++ b/tests/testthat/test_MashPrior.R @@ -92,3 +92,11 @@ test_that("the partition check stops when perFoldFits is not a list", { samplePartition = data.frame(Sample = "a", Fold = 1L) ))) }) + +test_that("MashPrior: cvFits must be a list or NULL", { + expect_error( + MashPrior(fullFit = list(U = list(U1 = diag(2))), cvFits = "nope"), + "cvFits.*Must be of type 'list'" + ) + expect_silent(MashPrior(fullFit = list(U = list(U1 = diag(2))))) +}) diff --git a/tests/testthat/test_MultiStudyQtlDataset.R b/tests/testthat/test_MultiStudyQtlDataset.R index 769cd4ef..c2e13a8e 100644 --- a/tests/testthat/test_MultiStudyQtlDataset.R +++ b/tests/testthat/test_MultiStudyQtlDataset.R @@ -40,7 +40,7 @@ test_that("MultiStudyQtlDataset: rejects unnamed qtlDatasets list", { ) expect_error( MultiStudyQtlDataset(qtlDatasets = list(qd, qd)), - "named list" + "Must have names" ) }) @@ -168,7 +168,7 @@ test_that("getSumStats(MultiStudyQtlDataset) rejects selection arguments", { test_that("MultiStudyQtlDataset: rejects an empty qtlDatasets list", { expect_error( MultiStudyQtlDataset(qtlDatasets = list()), - "'qtlDatasets' must be a non-empty named list" + "qtlDatasets.*Must have length >= 1" ) }) @@ -180,7 +180,7 @@ test_that("MultiStudyQtlDataset: rejects duplicated study names", { ) expect_error( MultiStudyQtlDataset(qtlDatasets = list(s1 = qd, s1 = qd)), - "names of 'qtlDatasets' must be unique" + "qtlDatasets.*Must have unique names" ) }) @@ -215,3 +215,10 @@ test_that("getStudy unions the individual-level and summary-only studies", { ) expect_setequal(getStudy(mt), c("s1", "study1")) }) + +test_that("MultiStudyQtlDataset: qtlDatasets guard fires on a non-list", { + expect_error( + MultiStudyQtlDataset(qtlDatasets = "not-a-list"), + "qtlDatasets.*Must be of type 'list'" + ) +}) diff --git a/tests/testthat/test_QtlDataset.R b/tests/testthat/test_QtlDataset.R index f839ee52..34684eac 100644 --- a/tests/testthat/test_QtlDataset.R +++ b/tests/testthat/test_QtlDataset.R @@ -83,7 +83,7 @@ context("QtlDataset internal helpers") ) { gh <- .qh_makeHandle(n_samples = n_samples, a1 = a1, a2 = a2) pheno <- setNames( - lapply(contexts, function(.) .qh_makeSe(n_samples = n_samples)), + map(contexts, function(.) .qh_makeSe(n_samples = n_samples)), contexts ) if (is.null(geno_cov)) { @@ -269,7 +269,7 @@ test_that(".qtlResolveVariantRegion: region must be a GRanges; multi-range is al qd <- .qh_makeDataset() expect_error( pecotmr:::.qtlResolveVariantRegion(qd, region = "chr1:100-200"), - "must be a GRanges object" + "Must inherit from class 'GRanges'" ) expect_error( pecotmr:::.qtlResolveVariantRegion( @@ -809,7 +809,7 @@ test_that("QtlDataset: keepIndel defaults to TRUE; validity rejects non-scalar", expect_true(qd@keepIndel) # The constructor coerces via isTRUE(); validity guards direct new()/slot sets. qd@keepIndel <- c(TRUE, FALSE) - expect_error(validObject(qd), "keepIndel.*single logical") + expect_error(validObject(qd), "Variable 'keepIndel'") }) test_that(".qtlExtractBlock: mafCutoff drops low-MAF variants", { @@ -986,7 +986,7 @@ context("QtlDataset residualization methods") ) { gh <- .qr_makeHandle(n_samples = n_samples) pheno <- setNames( - lapply(contexts, function(.) .qr_makeSe(n_samples = n_samples)), + map(contexts, function(.) .qr_makeSe(n_samples = n_samples)), contexts ) if (is.null(geno_cov)) { @@ -1988,7 +1988,7 @@ test_that("dentist accepts zscore column name variant", { test_that("dentist errors when sum_stat missing required columns", { skip_if_not_installed("pgenlibr") X <- load_test_genotype()$X - bad_stat <- data.frame(x = 1:ncol(X), y = rnorm(ncol(X))) + bad_stat <- data.frame(x = seq_len(ncol(X)), y = rnorm(ncol(X))) expect_error(dentist(bad_stat, X = X), "missing either") }) @@ -2016,7 +2016,7 @@ test_that("QtlDataset: rejects empty study name", { genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = se) ), - "non-empty character string" + "Variable 'study'.*at least 1 characters" ) }) @@ -2067,7 +2067,7 @@ test_that("QtlDataset: rejects negative QC cutoffs", { phenotypes = list(brain = se), mafCutoff = -0.1 ), - "non-negative numeric" + "is not >= 0" ) }) @@ -2319,7 +2319,10 @@ test_that(".qtlResolveVariantRegion rejects a non-GRanges / empty region", { genotypes = h, phenotypes = list(ctx = .mr_makeSE(getSampleIds(h))) ) - expect_error(getGenotypes(qd, region = "chr21:1-2"), "must be a GRanges") + expect_error( + getGenotypes(qd, region = "chr21:1-2"), + "Must inherit from class 'GRanges'" + ) expect_error( getGenotypes(qd, region = GenomicRanges::GRanges()), "at least one range" @@ -2386,7 +2389,7 @@ test_that(".qtlResolveVariantRegion: region path rejects a non-scalar/negative c region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100, 200)) expect_error( pecotmr:::.qtlResolveVariantRegion(qd, region = region, cisWindow = -5), - "must be a single non-negative value" + "cisWindow" ) expect_error( pecotmr:::.qtlResolveVariantRegion( @@ -2394,7 +2397,7 @@ test_that(".qtlResolveVariantRegion: region path rejects a non-scalar/negative c region = region, cisWindow = c(1, 2) ), - "must be a single non-negative value" + "cisWindow" ) }) @@ -3158,7 +3161,7 @@ test_that("validity rejects a non-scalar scaleResiduals", { # The constructor coerces via isTRUE(); validity guards direct slot sets. qd <- .qh_makeDataset() qd@scaleResiduals <- c(TRUE, FALSE) - expect_error(validObject(qd), "scaleResiduals.*single logical") + expect_error(validObject(qd), "Variable 'scaleResiduals'") }) test_that("the phenotype-list check rejects duplicated context names", { @@ -3254,3 +3257,15 @@ test_that("trait-position validation skips a context whose ranges do not line up test_that("aligning covariates with nothing to align returns NULL", { expect_null(pecotmr:::.qtlAlignCovariates(list(), NULL)) }) + +test_that("outlier detection reports a singular trait covariance", { + # A singular covariance silently became a pseudo-inverse, while the + # sibling robustbase-missing branch already informed the user. + Y <- cbind(a = c(1, 2, 3, 4), b = c(2, 4, 6, 8)) + cnd <- rlang::catch_cnd( + pecotmr:::.qtlOutlierKeepMask(Y, pvalThreshold = 0.05), + classes = "message" + ) + expect_match(conditionMessage(cnd), "singular") + expect_match(conditionMessage(cnd), "pseudo-inverse") +}) diff --git a/tests/testthat/test_QtlFineMappingResult.R b/tests/testthat/test_QtlFineMappingResult.R index 58351a8c..ce11157e 100644 --- a/tests/testthat/test_QtlFineMappingResult.R +++ b/tests/testthat/test_QtlFineMappingResult.R @@ -626,7 +626,10 @@ test_that("QtlFineMappingResult: getMarginalEffects with tuple selectors", { test_that("validity names a missing identity column", { bad <- .qfmr_res() mcols(bad)$trait <- NULL - expect_error(methods::validObject(bad), "missing columns: trait") + expect_error( + methods::validObject(bad), + "missing elements \\{'trait'\\}" + ) }) test_that("validity names a missing entry payload column", { @@ -634,7 +637,7 @@ test_that("validity names a missing entry payload column", { mcols(bad)$susieFit <- NULL expect_error( methods::validObject(bad), - "missing entry payload columns: susieFit" + "missing entry payload columns: .*missing elements \\{'susieFit'\\}" ) }) diff --git a/tests/testthat/test_RangedTupleList.R b/tests/testthat/test_RangedTupleList.R index 1374e47b..6dfd637f 100644 --- a/tests/testthat/test_RangedTupleList.R +++ b/tests/testthat/test_RangedTupleList.R @@ -308,7 +308,10 @@ test_that("subsetRegion differs from subsetByOverlaps and restrict", { test_that(".rtlSplitByBlocks splits one element into per-block pieces", { r <- .rtlSplitByBlocks(list(.rtl_variants()), .rtl_blocks()) - expect_equal(names(r$entry), c("b1", "b2")) + # `blockId` is the documented channel for which block a piece came from; + # the flattened entry list is deliberately unnamed (base unlist()'s + # `outer.inner` mangling was an artifact, and inconsistent at that). + expect_null(names(r$entry)) expect_equal(r$blockId, c("b1", "b2")) expect_equal(unname(lengths(r$entry)), c(2L, 1L)) # Both pieces came from the one input element, so its metadata row is @@ -816,8 +819,8 @@ test_that(".rtlTupleKeyCols is empty when there are no mcols", { test_that("`[[<-` rejects a non-scalar or NA index", { x <- .rtl_makeKid() - expect_error(x[[c(1L, 2L)]] <- x[[1L]], "takes a single non-NA index") - expect_error(x[[NA_integer_]] <- x[[1L]], "takes a single non-NA index") + expect_error(x[[c(1L, 2L)]] <- x[[1L]], "Must have length 1") + expect_error(x[[NA_integer_]] <- x[[1L]], "May not be NA") }) diff --git a/tests/testthat/test_causalInferencePipeline.R b/tests/testthat/test_causalInferencePipeline.R index 6fb43e6f..222662e0 100644 --- a/tests/testthat/test_causalInferencePipeline.R +++ b/tests/testthat/test_causalInferencePipeline.R @@ -12,7 +12,7 @@ context("causalInferencePipeline") path = "/tmp/sketch.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -141,7 +141,7 @@ context("causalInferencePipeline") test_that("causalInferencePipeline: rejects non-GwasSumStats input", { expect_error( causalInferencePipeline(gwasSumStats = "no"), - "must be a GwasSumStats" + "Must inherit from class 'GwasSumStats'" ) }) @@ -168,7 +168,7 @@ test_that("causalInferencePipeline: rejects non-TwasWeights twasWeights arg", { gwasSumStats = .cip_makeGwasSumstats(), twasWeights = "not a TwasWeights" ), - "must be a TwasWeights" + "Must inherit from class 'TwasWeights'" ) }) @@ -596,7 +596,7 @@ context("twas: twasZ and harmonize deprecated wrappers") .tz_makeLd <- function(n = 100, p = 8, seed = 7) { set.seed(seed) X <- matrix(rbinom(n * p, 2, runif(p, 0.2, 0.8)), nrow = n, ncol = p) - vid <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + vid <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) colnames(X) <- vid af <- colMeans(X) / 2 Xstd <- sweep(X, 2, 2 * af) @@ -640,7 +640,7 @@ test_that("twasZ: non-matrix non-numeric weights errors out", { test_that("twasZ: length mismatch between weights and z errors", { expect_error( pecotmr:::twasZ(c(0.1, 0.2, 0.3), z = c(1, 2)), - "nrow\\(weights\\) must equal length\\(z\\)" + "weights.*Must have exactly 2 rows" ) }) @@ -689,7 +689,7 @@ test_that("twasZ: R path errors when R is missing rows named in weights", { d <- .tz_makeLd() w <- rnorm(d$p) names(w) <- d$vid - R_short <- d$R[1:(d$p - 1), 1:(d$p - 1)] + R_short <- d$R[seq_len(d$p - 1), seq_len(d$p - 1)] expect_error( pecotmr:::twasZ(w, rnorm(d$p), R = R_short), "R is missing rows for" @@ -699,10 +699,10 @@ test_that("twasZ: R path errors when R is missing rows named in weights", { test_that("twasZ: R path positional alignment errors on dim mismatch", { d <- .tz_makeLd() w <- rnorm(d$p) # unnamed -> positional alignment - R_short <- unname(d$R[1:(d$p - 1), 1:(d$p - 1)]) + R_short <- unname(d$R[seq_len(d$p - 1), seq_len(d$p - 1)]) expect_error( pecotmr:::twasZ(w, rnorm(d$p), R = R_short), - "positional alignment requires nrow\\(R\\) == nrow\\(weights\\)" + "R \\(positional alignment\\).*Must have exactly 8 rows" ) }) @@ -734,7 +734,7 @@ test_that("twasZ: SVD path errors when V is missing rows named in weights", { s <- svd(d$Xstd) rownames(s$v) <- d$vid[seq_len(nrow(s$v))] w <- rnorm(d$p) - names(w) <- c(d$vid[1:(d$p - 1)], "ghost") + names(w) <- c(d$vid[seq_len(d$p - 1)], "ghost") expect_error( pecotmr:::twasZ(w, rnorm(d$p), V = s$v, D = s$d, nSketch = d$n), "V is missing rows for" @@ -746,10 +746,10 @@ test_that("twasZ: SVD path positional alignment errors on dim mismatch", { s <- svd(d$Xstd) # Pass an unnamed V with the wrong nrow. w <- rnorm(d$p) - V_short <- s$v[1:(d$p - 1), , drop = FALSE] + V_short <- s$v[seq_len(d$p - 1), , drop = FALSE] expect_error( pecotmr:::twasZ(w, rnorm(d$p), V = V_short, D = s$d, nSketch = d$n), - "positional alignment requires nrow\\(V\\) == nrow\\(weights\\)" + "V \\(positional alignment\\).*Must have exactly 8 rows" ) }) @@ -794,7 +794,7 @@ test_that("twasZ: combineMethods K>=2 forwards to combinePValues with correlatio # =========================================================================== test_that("twasZ errors when weights and z lengths differ", { - expect_error(twasZ(c(1, 2), c(1, 2, 3)), "must equal") + expect_error(twasZ(c(1, 2), c(1, 2, 3)), "Must have exactly 3 rows") }) @@ -889,7 +889,7 @@ test_that("twasZ: computing R from X matches providing R directly", { n <- 20 p <- 5 X <- matrix(rnorm(n * p), nrow = n, ncol = p) - colnames(X) <- paste0("SNP", 1:p) + colnames(X) <- paste0("SNP", seq_len(p)) R <- cor(X) weights <- rnorm(p) z <- rnorm(p) @@ -1012,14 +1012,14 @@ test_that("twasZ: matrix weights produce one Z row per column", { p <- 5 k <- 3 weights <- matrix(rnorm(p * k), nrow = p, ncol = k) - rownames(weights) <- paste0("SNP", 1:p) - colnames(weights) <- paste0("Cond", 1:k) + rownames(weights) <- paste0("SNP", seq_len(p)) + colnames(weights) <- paste0("Cond", seq_len(k)) z <- rnorm(p) R <- diag(p) - rownames(R) <- colnames(R) <- paste0("SNP", 1:p) + rownames(R) <- colnames(R) <- paste0("SNP", seq_len(p)) result <- twasZ(weights, z, R = R) expect_equal(nrow(result$Z), k) - expect_equal(rownames(result$Z), paste0("Cond", 1:k)) + expect_equal(rownames(result$Z), paste0("Cond", seq_len(k))) expect_equal(colnames(result$Z), c("Z", "pval")) # combineMethods omitted -> combined is NULL expect_null(result$combined) @@ -1035,11 +1035,11 @@ test_that("twasZ: combineMethods returns combined p-value summary", { rnorm(p * k), nrow = p, ncol = k, - dimnames = list(paste0("SNP", 1:p), paste0("Cond", 1:k)) + dimnames = list(paste0("SNP", seq_len(p)), paste0("Cond", seq_len(k))) ) z <- rnorm(p) R <- diag(p) - rownames(R) <- colnames(R) <- paste0("SNP", 1:p) + rownames(R) <- colnames(R) <- paste0("SNP", seq_len(p)) result <- twasZ(weights, z, R = R, combineMethods = "ACAT") expect_false(is.null(result$combined)) }) @@ -1157,7 +1157,7 @@ test_that("twasZ: error when weights and z have different lengths", { D = c(1, 1), nSketch = 10 ), - "nrow\\(weights\\) must equal length\\(z\\)" + "weights.*Must have exactly 3 rows" ) }) @@ -1763,20 +1763,27 @@ test_that(".cipCvSelection errors when no method clears the CV cutoffs", { local_mocked_bindings( .cipMethodMetrics = function(...) { data.frame( - qtlStudy = "s", context = "c", trait = "t", - method = "m", rsq = 0.01, stringsAsFactors = FALSE + qtlStudy = "s", + context = "c", + trait = "t", + method = "m", + rsq = 0.01, + stringsAsFactors = FALSE ) }, .cipFilterEligibleMethods = function(...) data.frame(), .package = "pecotmr" ) - p <- list( - twasWeights = "notNull", rsqCutoff = 0.5, rsqPvalCutoff = 0.05, - qtlRows = data.frame(a = 1), rsqOption = NULL, rsqPvalOption = NULL - ) # Naming the cutoffs in the message is what makes this actionable. expect_error( - pecotmr:::.cipCvSelection(p), + pecotmr:::.cipCvSelection( + qtlRows = data.frame(a = 1), + twasWeights = "notNull", + rsqCutoff = 0.5, + rsqOption = NULL, + rsqPvalCutoff = 0.05, + rsqPvalOption = NULL + ), "rsqCutoff = 0.5 / rsqPvalCutoff = 0.05" ) }) @@ -1786,18 +1793,32 @@ test_that(".cipRun errors when no tuple produced a result", { .cipValidateInputs = function(...) invisible(NULL), .cipCheckLdSketches = function(...) NULL, .cipResolveWorkList = function(...) data.frame(x = 1), - .cipCvSelection = function(p) { + .cipCvSelection = function(...) { list( qtlRows = data.frame(x = 1), rsqLookup = NULL, selectionActive = FALSE ) }, - .cipScoreQtlTuple = function(qi, p) list(), + .cipScoreQtlTuple = function(qi, ...) list(), .package = "pecotmr" ) expect_error( - pecotmr:::.cipRun(list()), + pecotmr:::.cipRun( + gwasSumStats = NULL, + twasWeights = NULL, + fineMappingResult = NULL, + combineMethods = NULL, + rsqCutoff = NULL, + rsqOption = NULL, + rsqPvalCutoff = NULL, + rsqPvalOption = NULL, + alleleFlip = FALSE, + mrMethod = "csAware", + mrPipCutoff = 0, + mrCpipCutoff = 0, + mrPvalCutoff = 1 + ), "no \\(qtl, gwas\\) tuples produced a result" ) }) @@ -1809,8 +1830,12 @@ test_that(".cipScoreQtlTuple skips a tuple with no weights", { ) p <- list( qtlRows = data.frame( - qtlStudy = "s", context = "c", trait = "t", method = "m", - useFmrForWeights = FALSE, stringsAsFactors = FALSE + qtlStudy = "s", + context = "c", + trait = "t", + method = "m", + useFmrForWeights = FALSE, + stringsAsFactors = FALSE ), twasWeights = NULL, fineMappingResult = NULL @@ -1826,10 +1851,20 @@ test_that(".cipScoreGwasPair skips a pair with no TWAS z", { .cipPairLabel = function(...) "lab", .package = "pecotmr" ) - p <- list(gwasSumStats = list(study = "G1"), gwasLd = NULL, - alleleFlip = FALSE) expect_null( - pecotmr:::.cipScoreGwasPair(1L, NULL, list(), NULL, p) + pecotmr:::.cipScoreGwasPair( + 1L, + NULL, + list(), + NULL, + gwasSumStats = list(study = "G1"), + gwasLd = NULL, + alleleFlip = FALSE, + mrMethod = "csAware", + mrPipCutoff = 0, + mrCpipCutoff = 0, + mrPvalCutoff = 1 + ) ) }) @@ -1838,15 +1873,15 @@ test_that(".cipRunMr routes to the CS-aware estimator when asked", { .cipComputeMrCsAware = function(...) list(SENTINEL = TRUE), .package = "pecotmr" ) - p <- list( - mrPvalCutoff = 1, mrMethod = "csAware", - mrCpipCutoff = 0.5, alleleFlip = FALSE - ) out <- pecotmr:::.cipRunMr( fmrEntry = "notNull", gdf = NULL, twasOut = list(pval = 0.001), - p = p + alleleFlip = FALSE, + mrMethod = "csAware", + mrPipCutoff = 0, + mrCpipCutoff = 0.5, + mrPvalCutoff = 1 ) expect_true(isTRUE(out$SENTINEL)) }) @@ -1870,3 +1905,14 @@ test_that(".cipCvMetric returns NA when the CV result cannot be read", { is.na(pecotmr:::.cipCvMetric(NULL, "s", "c", "t", "m", "rsq")) ) }) + +test_that("twasZ: nSketch / combineMethods guards fire", { + expect_error( + twasZ(matrix(1, 1, 1), 1, nSketch = 0), + "nSketch.*Must be >= 1" + ) + expect_error( + twasZ(matrix(1, 1, 1), 1, combineMethods = 1L), + "combineMethods.*Must be of type 'character'" + ) +}) diff --git a/tests/testthat/test_colocPipeline.R b/tests/testthat/test_colocPipeline.R index ee2c318f..7c4bf257 100644 --- a/tests/testthat/test_colocPipeline.R +++ b/tests/testthat/test_colocPipeline.R @@ -13,7 +13,7 @@ context("colocPipeline") path = "/tmp/sketch.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -36,7 +36,7 @@ context("colocPipeline") tl <- data.frame( variant_id = variant_ids, chrom = rep("1", n), - pos = as.integer(100 * (1:n)), + pos = as.integer(100 * seq_len(n)), A1 = rep("G", n), A2 = rep("A", n), N = rep(1000, n), @@ -84,10 +84,10 @@ context("colocPipeline") ) } QtlFineMappingResult( - study = vapply(tuples, `[[`, character(1), 1), - context = vapply(tuples, `[[`, character(1), 2), - trait = vapply(tuples, `[[`, character(1), 3), - method = vapply(tuples, `[[`, character(1), 4), + study = map_chr(tuples, 1L), + context = map_chr(tuples, 2L), + trait = map_chr(tuples, 3L), + method = map_chr(tuples, 4L), entry = entries, ldSketch = if (with_sketch) .cp_makeHandle() else NULL ) @@ -106,8 +106,8 @@ context("colocPipeline") ) } GwasFineMappingResult( - study = vapply(tuples, `[[`, character(1), 1), - method = vapply(tuples, `[[`, character(1), 2), + study = map_chr(tuples, 1L), + method = map_chr(tuples, 2L), entry = entries, ldSketch = if (with_sketch) .cp_makeHandle() else NULL ) @@ -705,7 +705,7 @@ test_that("colocPipeline: rejects a non-data.frame enrichment", { gwasInput = gfmr, enrichment = "not a data frame" ), - "must be a data.frame" + "Must be of type 'data.frame'" ) }) @@ -723,7 +723,7 @@ test_that("colocPipeline: rejects enrichment missing required columns", { gwasInput = gfmr, enrichment = bad ), - "is missing column" + "Colnames must include the elements" ) }) @@ -1251,19 +1251,32 @@ test_that("PIP adjustment is skipped when either side has no rows", { # Intersecting variants across an empty side would empty the other, so # the inputs are passed through untouched instead. data(qtlFineMappingExample, gwasFineMappingExample) - p <- list( - adjustPips = TRUE, + # It now returns just the two (possibly adjusted) inputs, not a bundle. + emptyQtl <- list( qtlFineMappingResult = qtlFineMappingExample[0], gwasFmr = gwasFineMappingExample ) - expect_identical(pecotmr:::.colocMaybeAdjustPips(p), p) + expect_identical( + pecotmr:::.colocMaybeAdjustPips( + adjustPips = TRUE, + qtlFineMappingResult = emptyQtl$qtlFineMappingResult, + gwasFmr = emptyQtl$gwasFmr + ), + emptyQtl + ) # ...and it is skipped outright when not requested. - p2 <- list( - adjustPips = FALSE, + notAsked <- list( qtlFineMappingResult = qtlFineMappingExample, gwasFmr = gwasFineMappingExample ) - expect_identical(pecotmr:::.colocMaybeAdjustPips(p2), p2) + expect_identical( + pecotmr:::.colocMaybeAdjustPips( + adjustPips = FALSE, + qtlFineMappingResult = notAsked$qtlFineMappingResult, + gwasFmr = notAsked$gwasFmr + ), + notAsked + ) }) test_that("pre-extracting LBF from an empty GWAS result yields no blocks", { diff --git a/tests/testthat/test_colocboostPipeline.R b/tests/testthat/test_colocboostPipeline.R index f6b68352..e3df0bf6 100644 --- a/tests/testthat/test_colocboostPipeline.R +++ b/tests/testthat/test_colocboostPipeline.R @@ -95,7 +95,7 @@ context("colocboostPipeline (S4 dispatch)") path = "/tmp/cb.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -179,7 +179,7 @@ context("colocboostPipeline (S4 dispatch)") ) { gh <- .cbp_makeHandle() phen <- setNames( - lapply(contexts, function(.) .cbp_makeSe(traits = traits)), + map(contexts, function(.) .cbp_makeSe(traits = traits)), contexts ) QtlDataset( @@ -608,11 +608,11 @@ test_that("GwasSumStats: nCase/nControl are optional columns (absent by default) ldSketch = .cbp_makeHandle(), qcInfo = list(ok = 1) ) - g0 <- do.call(GwasSumStats, base) + g0 <- exec(GwasSumStats, !!!base) expect_false(any( c("nCase", "nControl") %in% colnames(S4Vectors::mcols(g0)) )) - g1 <- do.call(GwasSumStats, c(base, list(nCase = 500, nControl = 1500))) + g1 <- exec(GwasSumStats, !!!c(base, list(nCase = 500, nControl = 1500))) expect_true(all(c("nCase", "nControl") %in% colnames(S4Vectors::mcols(g1)))) expect_equal(g1$nCase, 500) expect_equal(g1$nControl, 1500) @@ -645,11 +645,11 @@ test_that("colocboost GWAS bundle: effective N for case/control, per-variant N o .package = "pecotmr" ) # case/control -> effective N = 4 / (1/500 + 1/1500) = 1500 - gcc <- do.call(GwasSumStats, c(base, list(nCase = 500, nControl = 1500))) + gcc <- exec(GwasSumStats, !!!c(base, list(nCase = 500, nControl = 1500))) bcc <- pecotmr:::.cbGwasSumStatsBundle(gcc) expect_true(all(bcc[["G1"]]$sumstat$n == 4 / (1 / 500 + 1 / 1500))) # quantitative (no nCase/nControl) -> per-variant N (1000) - bq <- pecotmr:::.cbGwasSumStatsBundle(do.call(GwasSumStats, base)) + bq <- pecotmr:::.cbGwasSumStatsBundle(exec(GwasSumStats, !!!base)) expect_true(all(bq[["G1"]]$sumstat$n == 1000L)) }) @@ -666,7 +666,10 @@ test_that(".cbPipSkipOutcomes: keeps signal outcomes, drops noise, honours cutof rbinom(n * p, 2, 0.3), n, p, - dimnames = list(paste0("s", 1:n), sprintf("chr1:%d:A:G", 100L * (1:p))) + dimnames = list( + paste0("s", seq_len(n)), + sprintf("chr1:%d:A:G", 100L * seq_len(p)) + ) ) Y <- cbind( sig = X[, 1] * 1.5 + rnorm(n, sd = 0.3), # strong signal at v1 @@ -962,7 +965,7 @@ test_that("colocboostPipeline(MultiStudyQtlDataset): a study with no usable bund .cbf_n <- function(ss, ...) { b <- suppressMessages(.cbQtlSumStatsBundle( ss, - cutoffs = .panelCutoffs(list(...)) + cutoffs = .panelCutoffs(...) )) if (length(b) == 0L) 0L else length(b[[1L]]$variantIds) } @@ -1185,19 +1188,19 @@ test_that(".cbResidualizedX reports why genotypes were unavailable", { getResidualizedGenotypes = function(...) stop("kaboom"), .package = "pecotmr" ) - # The underlying message is carried through so the skip is diagnosable. - expect_message( - res <- pecotmr:::.cbResidualizedX( - NULL, - "c1", - NULL, - NULL, - NULL, - NULL - ), - "residualized genotypes unavailable: kaboom" - ) - expect_null(res) + # The cause is chained via `parent`, not flattened into the text, so the + # rendered message still shows it AND it stays reachable as a condition. + # catch_cnd() rather than expect_message(), which returns NULL. + cnd <- rlang::catch_cnd( + pecotmr:::.cbResidualizedX(NULL, "c1", NULL, NULL, NULL, NULL), + classes = "message" + ) + expect_match(conditionMessage(cnd), "residualized genotypes unavailable") + expect_match(conditionMessage(cnd), "kaboom") + expect_match(conditionMessage(cnd$parent), "kaboom") + expect_null(suppressMessages( + pecotmr:::.cbResidualizedX(NULL, "c1", NULL, NULL, NULL, NULL) + )) }) test_that(".cbApplyScreen keeps the outcomes that clear the screen", { @@ -1334,7 +1337,7 @@ test_that(".cbRunVariants: xqtlColoc runs on a QTL-only sumstat bundle", { jointGwas = FALSE, separateGwas = FALSE, focalTrait = NULL, - dotArgs = list(), + colocboostArgs = list(), qtlSumstatBundle = qtlOnly )) expect_equal(called, "xqtl") @@ -1362,7 +1365,7 @@ test_that(".cbRunVariants warns instead of silently skipping an analysis", { jointGwas = TRUE, separateGwas = TRUE, focalTrait = NULL, - dotArgs = list() + colocboostArgs = list() )) ) expect_length(warnings, 2L) @@ -1386,7 +1389,7 @@ test_that(".cbRunVariants warns when xqtlColoc has only GWAS sumstats", { jointGwas = FALSE, separateGwas = FALSE, focalTrait = NULL, - dotArgs = list(), + colocboostArgs = list(), qtlSumstatBundle = pecotmr:::.cbMergeSumstatBundles(list()) )), "xqtlColoc = TRUE was requested" diff --git a/tests/testthat/test_crossValidation.R b/tests/testthat/test_crossValidation.R index 671dab2e..d4c4c8ab 100644 --- a/tests/testthat/test_crossValidation.R +++ b/tests/testthat/test_crossValidation.R @@ -32,7 +32,7 @@ mk_xy <- function(n = 30, p = 6, k = 1, seed = 1) { p, dimnames = list( paste0("s", seq_len(n)), - sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + sprintf("chr1:%d:A:G", 100L * seq_len(p)) ) ) Y <- matrix( @@ -48,19 +48,19 @@ test_that("input is validated", { d <- mk_xy() expect_error( cv(d$X, d$Y, fold = 0, fitFold = mock_fit_fold), - "positive integer" + "Must be >= 1" ) expect_error( cv(d$X, d$Y, fold = "a", fitFold = mock_fit_fold), - "positive integer" + "Must be of type 'count'" ) expect_error( cv(as.data.frame(d$X), d$Y, fold = 2, fitFold = mock_fit_fold), - "X must be a matrix" + "Must be of type 'matrix'" ) expect_error( cv(d$X, d$Y[1:5, , drop = FALSE], fold = 2, fitFold = mock_fit_fold), - "same" + "Must have exactly 30 rows" ) expect_error( cv(d$X, d$Y, fitFold = mock_fit_fold), @@ -255,7 +255,7 @@ test_that("retainFits collects per-fold fits only when requested", { fitFold = fit_with_model, retainFits = FALSE )) - expect_true(all(vapply(r_off$foldFits, length, integer(1)) == 0L)) + expect_true(all(map_int(r_off$foldFits, length) == 0L)) r_on <- suppressMessages(cv( d$X, d$Y, @@ -326,7 +326,7 @@ test_that("numThreads = -1 asks BiocParallel for the worker count", { # -1 means "all available"; anything else is capped at what is available. expect_equal( pecotmr:::.cvNumCores(-1), - BiocParallel::bpworkers(BiocParallel::MulticoreParam()) + BiocParallel::multicoreWorkers() ) expect_equal(pecotmr:::.cvNumCores(1), 1) }) diff --git a/tests/testthat/test_ctwasPipeline.R b/tests/testthat/test_ctwasPipeline.R index d981f6e8..d57c142f 100644 --- a/tests/testthat/test_ctwasPipeline.R +++ b/tests/testthat/test_ctwasPipeline.R @@ -91,7 +91,7 @@ context("ctwasPipeline") ranges = IRanges::IRanges(start = 100L * idx, width = 1L) ) S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = vapply(idx, .ctp_snpId, character(1)), + SNP = map_chr(idx, .ctp_snpId), A1 = rep("A", 6), A2 = rep("G", 6), Z = rnorm(6), @@ -119,7 +119,7 @@ context("ctwasPipeline") # inside block 1 -- pass 7:11 for a gene that lives in block 2. .ctp_makeTwasWeights <- function(variantIdx = 1:5) { e <- twasWeightsRow( - variantIds = vapply(variantIdx, .ctp_snpId, character(1)), + variantIds = map_chr(variantIdx, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) TwasWeights( @@ -136,7 +136,7 @@ context("ctwasPipeline") # the topLoci posterior_mean carries the weight vector (what resolveWeights # reads). Mirrors .ctp_makeTwasWeights so the two sources are comparable. .ctp_makeFmrWeightSource <- function() { - vids <- vapply(1:5, .ctp_snpId, character(1)) + vids <- map_chr(1:5, .ctp_snpId) w <- c(0.1, 0.05, -0.2, 0.3, 0.0) tl <- data.frame( variant_id = vids, @@ -271,7 +271,7 @@ test_that("assembleCtwasInputs: accepts a QtlFineMappingResult weight source (to trait = "t1", method = "susie", entry = list(twasWeightsRow( - variantIds = vapply(1:5, .ctp_snpId, character(1)), + variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0), standardized = TRUE )), @@ -325,11 +325,11 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { qcInfo = if (qc) list(step1 = "ok") else list() ) } - ss1 <- mkBlockGss("G1", vapply(1:3, .ctp_snpId, character(1))) - ss2 <- mkBlockGss("G2", vapply(4:6, .ctp_snpId, character(1))) + ss1 <- mkBlockGss("G1", map_chr(1:3, .ctp_snpId)) + ss2 <- mkBlockGss("G2", map_chr(4:6, .ctp_snpId)) # Cross-boundary weights: v2..v5 (4 variants spanning both blocks). crossEntry <- twasWeightsRow( - variantIds = vapply(2:5, .ctp_snpId, character(1)), + variantIds = map_chr(2:5, .ctp_snpId), weights = c(0.1, 0.2, 0.3, 0.4) ) tw <- TwasWeights( @@ -358,7 +358,7 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { entry <- inputs$weights[[1L]] wgt <- entry$wgt expect_equal(nrow(wgt), 2L) - expect_setequal(rownames(wgt), vapply(2:3, .ctp_snpId, character(1))) + expect_setequal(rownames(wgt), map_chr(2:3, .ctp_snpId)) expect_equal(nrow(entry$R_wgt), 2L) expect_equal(entry$n_wgt, 2L) expect_equal(entry$p0, 200L) @@ -457,14 +457,14 @@ test_that(".ctwasRequireMatchingLdSketches: disjoint panels error", { test_that(".ctwasBuildZSnp: produces a flat data.frame keyed by SNP/study", { ss <- .ctp_makeGwasSumstats(blockIds = "block1") - df <- pecotmr:::.ctwasBuildZSnp(ss, vapply(1:6, .ctp_snpId, character(1))) + df <- pecotmr:::.ctwasBuildZSnp(ss, map_chr(1:6, .ctp_snpId)) expect_s3_class(df, "data.frame") expect_equal(nrow(df), 6L) expect_setequal( colnames(df), c("id", "chrom", "pos", "A1", "A2", "z", "study") ) - expect_setequal(df$id, vapply(1:6, .ctp_snpId, character(1))) + expect_setequal(df$id, map_chr(1:6, .ctp_snpId)) expect_setequal(unique(df$study), "G1") }) @@ -474,7 +474,7 @@ test_that(".ctwasBuildZSnp: negates z for a panel-flipped variant", { # both sides, so nothing reported it missing and the gene just lost an # instrument. ss <- .ctp_makeGwasSumstats(blockIds = "block1") - gwasIds <- vapply(1:6, .ctp_snpId, character(1)) + gwasIds <- map_chr(1:6, .ctp_snpId) panelIds <- gwasIds panelIds[2] <- "chr1:200:A:G" # fixture spells this one G:A plain <- pecotmr:::.ctwasBuildZSnp(ss, gwasIds) @@ -490,7 +490,7 @@ test_that(".ctwasBuildZSnp: negates z for a panel-flipped variant", { test_that(".ctwasBuildZSnp: leaves variants absent from the panel untouched", { ss <- .ctp_makeGwasSumstats(blockIds = "block1") - gwasIds <- vapply(1:6, .ctp_snpId, character(1)) + gwasIds <- map_chr(1:6, .ctp_snpId) plain <- pecotmr:::.ctwasBuildZSnp(ss, gwasIds) none <- pecotmr:::.ctwasBuildZSnp(ss, "chr9:999:A:T") expect_equal(none$id, plain$id) @@ -800,7 +800,7 @@ test_that(".ctwasResolveMethod: multi-method + no ensemble + no caller method er context = rep("c1", length(methods)), trait = rep("t1", length(methods)), method = methods, - entry = lapply(methods, function(m) { + entry = map(methods, function(m) { twasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), weights = c(0.1, 0.2, 0.3) @@ -913,7 +913,7 @@ test_that(".ctwasIsPreBucketed / .ctwasCombineWeightSources: dispatch flat vs pr test_that(".ctwasBucketWeights: places a flat 2-gene source into its home blocks", { mkE <- function() { twasWeightsRow( - variantIds = vapply(1:5, .ctp_snpId, character(1)), + variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) } @@ -1037,11 +1037,11 @@ test_that(".ctwasRunToRows: multi-context run -> per-context rows sharing jointC rows <- pecotmr:::.ctwasRunToRows(run, gwasStudy = "D1", method = "susie") expect_length(rows, 2L) expect_setequal( - vapply(rows, function(r) r$context, ""), + map_chr(rows, function(r) r$context), c("brain", "liver") ) expect_true(all( - vapply(rows, function(r) r$jointContexts, "") == "brain,liver" + map_chr(rows, function(r) r$jointContexts) == "brain,liver" )) # Each per-context row keeps only its own genes but shares the joint param. expect_equal(nrow(getFinemap(rows[[1L]]$entry)), 2L) @@ -1157,7 +1157,7 @@ test_that(".ctwasBuildWeights: scales non-standardized weights by sqrt(variance) # weights should be multiplied by sqrt(variance) before reaching the # final wgt matrix. panel$variance <- setNames(c(0.5, 1, 2, 4, 8, 16), panel$snpInfo$id) - ids5 <- vapply(1:5, .ctp_snpId, character(1)) + ids5 <- map_chr(1:5, .ctp_snpId) rawW <- c(0.1, 0.2, 0.3, 0.4, 0.5) tw <- TwasWeights( study = "Q1", @@ -1175,7 +1175,7 @@ test_that(".ctwasBuildWeights: scales non-standardized weights by sqrt(variance) test_that(".ctwasBuildWeights: standardized weights bypass variance scaling", { panel <- .ctp_makeLdPanel() panel$variance <- setNames(c(0.5, 1, 2, 4, 8, 16), panel$snpInfo$id) - ids5 <- vapply(1:5, .ctp_snpId, character(1)) + ids5 <- map_chr(1:5, .ctp_snpId) rawW <- c(0.1, 0.2, 0.3, 0.4, 0.5) tw <- TwasWeights( study = "Q1", @@ -1410,21 +1410,18 @@ test_that(".ctwasRenormalizeSusieWeights: skips Omega-weighted susieInf fits", { harmonizedW = origW[1:3] ) expect_type( - do.call( - pecotmr:::.ctwasRenormalizeSusieWeights, - c(list(base), args) - ), + exec(pecotmr:::.ctwasRenormalizeSusieWeights, !!!c(list(base), args)), "double" ) withTheta <- c(base, list(theta = rep(0.1, 4))) - expect_null(do.call( + expect_null(exec( pecotmr:::.ctwasRenormalizeSusieWeights, - c(list(withTheta), args) + !!!c(list(withTheta), args) )) withOmega <- c(base, list(omega_weights = rep(1, 4))) - expect_null(do.call( + expect_null(exec( pecotmr:::.ctwasRenormalizeSusieWeights, - c(list(withOmega), args) + !!!c(list(withOmega), args) )) }) @@ -1432,7 +1429,7 @@ test_that(".ctwasSnpInfoForGwasBlock: restricts panel snpInfo to block GWAS vari ss <- .ctp_makeGwasSumstats() panelInfo <- data.frame( chrom = 1L, - id = vapply(1:6, .ctp_snpId, character(1)), # whole panel + id = map_chr(1:6, .ctp_snpId), # whole panel pos = seq(100L, by = 100L, length.out = 6L), alt = "A", ref = "G", @@ -1450,7 +1447,7 @@ test_that(".ctwasSnpInfoForGwasBlock: restricts panel snpInfo to block GWAS vari test_that(".ctwasBuildWeights: keys per-tuple weights, adds gene metadata", { tw <- .ctp_makeTwasWeights() panel <- .ctp_makeLdPanel() - ids5 <- vapply(1:5, .ctp_snpId, character(1)) + ids5 <- map_chr(1:5, .ctp_snpId) wl <- pecotmr:::.ctwasBuildWeights(tw, panel) expect_equal(length(wl), 1L) expect_equal(names(wl), "Q1|c1|t1|susie") @@ -1471,7 +1468,7 @@ test_that(".ctwasBuildWeights: keys per-tuple weights, adds gene metadata", { }) test_that(".ctwasBuildWeights: drops variants not present in the LD panel", { - ids3 <- vapply(1:3, .ctp_snpId, character(1)) + ids3 <- map_chr(1:3, .ctp_snpId) missing <- c("chr1:99900:G:A", "chr1:99910:G:A") # not in panel tw <- TwasWeights( study = "Q1", @@ -1496,8 +1493,8 @@ test_that(".ctwasBuildWeights: intersects with gwasSnpIds when supplied", { # ids 1, 2, 4 (a subset). Weight variants that live in the panel but # outside the block (id 3 here) must be dropped, otherwise ctwas's # compute_gene_z asserts the weight variant is missing from z_snp. - ids5 <- vapply(1:5, .ctp_snpId, character(1)) - blockIds <- vapply(c(1, 2, 4), .ctp_snpId, character(1)) + ids5 <- map_chr(1:5, .ctp_snpId) + blockIds <- map_chr(c(1, 2, 4), .ctp_snpId) tw <- TwasWeights( study = "Q1", context = "c1", @@ -1525,7 +1522,7 @@ test_that(".ctwasComputeFullPanelLd: extracts once + returns cached R + snpInfo .package = "pecotmr" ) out <- pecotmr:::.ctwasComputeFullPanelLd(.ctp_makeHandle(snp_n = 6L)) - ids6 <- vapply(1:6, .ctp_snpId, character(1)) + ids6 <- map_chr(1:6, .ctp_snpId) expect_named(out, c("R", "snpInfo", "variance")) expect_true(is.matrix(out$R)) expect_equal(dim(out$R), c(6L, 6L)) @@ -2316,9 +2313,11 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", niter = 5L, niterPrefit = 2L, # Toy panel: relax the production filters that gate out tiny inputs. - min_group_size = 1L, - min_p_single_effect = 0, - filter_L = FALSE + ctwasArgs = list( + min_group_size = 1L, + min_p_single_effect = 0, + filter_L = FALSE + ) ) )) @@ -2672,7 +2671,7 @@ test_that("assembleCtwasInputs: rejects a non-FineMappingResultBase fineMappingR test_that("assembleCtwasInputs: skips a block whose TwasWeights lacks the resolved method", { skip_if_not_installed("ctwas") ss <- .ctp_makeGwasSumstats() - ids5 <- vapply(1:5, .ctp_snpId, character(1)) + ids5 <- map_chr(1:5, .ctp_snpId) mkTw <- function(m) { TwasWeights( study = "Q1", @@ -2782,7 +2781,7 @@ test_that("TwasWeightsRow: rejects mismatched variantIds/weights lengths", { # rather than producing a gene that gets silently dropped downstream. expect_error( twasWeightsRow( - variantIds = vapply(1:5, .ctp_snpId, character(1)), + variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.2, 0.3) ), "length\\(weights\\) is 3 but 5 variants were supplied" @@ -2816,7 +2815,7 @@ test_that(".ctwasBuildWeights: skips a gene when no variant survives gwasSnpIds test_that(".ctwasBuildWeights: SuSiE renormalization fires when variants are dropped", { panel <- .ctp_makeLdPanel() - ids4 <- vapply(1:4, .ctp_snpId, character(1)) + ids4 <- map_chr(1:4, .ctp_snpId) bogus <- "chr1:99900:G:A" # absent from the 6-SNP panel # Fit dims line up with the 5 original variants. Two single effects, # each concentrated on one of the first two variants; lbfToAlpha @@ -3096,7 +3095,7 @@ test_that(".ctwasRunToRows: empty weights -> no rows; a context mixing studies e test_that(".ctwasBucketWeights: unplaced genes warn + drop; empty blocks skipped", { mkE <- function() { twasWeightsRow( - variantIds = vapply(1:5, .ctp_snpId, character(1)), + variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) } @@ -3127,7 +3126,7 @@ test_that(".ctwasBucketWeights: unplaced genes warn + drop; empty blocks skipped test_that(".ctwasBucketWeights: errors when no gene lands in any block", { mkE <- function() { twasWeightsRow( - variantIds = vapply(1:5, .ctp_snpId, character(1)), + variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) } @@ -3221,11 +3220,9 @@ test_that("bundled cTWAS payloads carry a resolvable LD token", { )) { tokens <- as.character(payload$LD_map$LD_file) expect_true(all(startsWith(tokens, "pecotmr://extdata/"))) - resolved <- vapply( + resolved <- map_chr( tokens, - pecotmr:::.resolveCtwasLdToken, - character(1), - USE.NAMES = FALSE + pecotmr:::.resolveCtwasLdToken ) expect_true(all(file.exists(resolved))) expect_equal( @@ -3269,7 +3266,10 @@ test_that("finemapCtwasRegions runs from the bundled est payload", { data(ctwasEstExample) # The step that the stale absolute paths broke. screened <- suppressMessages( - screenCtwasRegions(ctwasEstExample, min_nonSNP_PIP = 0) + screenCtwasRegions( + ctwasEstExample, + ctwasArgs = list(min_nonSNP_PIP = 0) + ) ) out <- suppressMessages(finemapCtwasRegions(screened)) expect_gt(nrow(out$finemap_res), 0L) @@ -3693,7 +3693,11 @@ test_that(".ctwasRenormalizeSusieWeights skips fits it cannot slice", { harmonizedW <- c(0.5, 0.5) run <- function(fits) { pecotmr:::.ctwasRenormalizeSusieWeights( - fits, origVids, origW, keptIdx, harmonizedW + fits, + origVids, + origW, + keptIdx, + harmonizedW ) } # Any missing susie field: nothing to renormalize from. @@ -3746,3 +3750,11 @@ test_that(".ctwasResolveAndValidateWeights rejects a blank region name", { "must resolve to a named list keyed by region_id" ) }) + +test_that("asCtwasResult: keepSnps must be a flag", { + expect_error(asCtwasResult(NULL, keepSnps = NA), "keepSnps.*May not be NA") + expect_error( + asCtwasResult(NULL, keepSnps = 1L), + "keepSnps.*logical flag" + ) +}) diff --git a/tests/testthat/test_fineMappingPipeline.R b/tests/testthat/test_fineMappingPipeline.R index fbaf534e..5b065160 100644 --- a/tests/testthat/test_fineMappingPipeline.R +++ b/tests/testthat/test_fineMappingPipeline.R @@ -17,7 +17,7 @@ context("fineMappingPipeline") path = "/tmp/fmsketch.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -105,7 +105,7 @@ context("fineMappingPipeline") ) { gh <- .fmp_makeHandle() phen <- setNames( - lapply(contexts, function(.) .fmp_makeSe(traits = traits)), + map(contexts, function(.) .fmp_makeSe(traits = traits)), contexts ) QtlDataset( @@ -599,11 +599,11 @@ test_that(".rbindFineMappingResult: rejects non-FineMappingResultBase input", { ) expect_error( pecotmr:::.rbindFineMappingResult(fmr, "not_an_fmr"), - "expects two FineMappingResultBase inputs" + "Must inherit from class 'FineMappingResultBase'" ) expect_error( pecotmr:::.rbindFineMappingResult("not_an_fmr", fmr), - "expects two FineMappingResultBase inputs" + "Must inherit from class 'FineMappingResultBase'" ) }) @@ -906,7 +906,7 @@ test_that(".fmSerScreen: disables on 0, skips no-signal, keeps signal + adaptive n <- 150L p <- 25L X <- matrix(rnorm(n * p), n, p) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) yNull <- rnorm(n) # no association ySig <- X[, 1] * 2 + rnorm(n, sd = 0.3) # strong single effect at v1 fn <- function(...) suppressMessages(pecotmr:::.fmSerScreen(...)) @@ -1391,7 +1391,7 @@ test_that(".fmWeightsCv returns twasWeightsCv-shaped output keyed by snake metho p, dimnames = list( paste0("s", seq_len(n)), - sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + sprintf("chr1:%d:A:G", 100L * seq_len(p)) ) ) y <- X[, 2] * 1.5 + rnorm(n, sd = 0.5) @@ -1405,7 +1405,10 @@ test_that(".fmWeightsCv returns twasWeightsCv-shaped output keyed by snake metho coverage = 0.95, verbose = 0 ) - expect_named(cv, c("samplePartition", "prediction", "performance")) + expect_named( + cv, + c("samplePartition", "prediction", "performance", "foldFits") + ) expect_setequal(colnames(cv$samplePartition), c("Sample", "Fold")) # Keyed by the TWAS snake method name (adapter methodKey base). expect_true("susie_predicted" %in% names(cv$prediction)) @@ -1434,7 +1437,7 @@ test_that(".fmWeightsCv reuses a supplied samplePartition verbatim", { p, dimnames = list( paste0("s", seq_len(n)), - sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + sprintf("chr1:%d:A:G", 100L * seq_len(p)) ) ) y <- X[, 1] + rnorm(n, sd = 0.5) @@ -4007,7 +4010,10 @@ test_that(".fmWeightsCv + .fmFoldWeights cover the mvSuSiE CV path (mocked fitte rbinom(n * p, 2, 0.4), n, p, - dimnames = list(paste0("s", 1:n), sprintf("chr1:%d:A:G", 100L * (1:p))) + dimnames = list( + paste0("s", seq_len(n)), + sprintf("chr1:%d:A:G", 100L * seq_len(p)) + ) ) Y <- matrix(rnorm(n * R), n, R, dimnames = list(rownames(X), c("c1", "c2"))) cv <- pecotmr:::.fmWeightsCv( @@ -4019,7 +4025,10 @@ test_that(".fmWeightsCv + .fmFoldWeights cover the mvSuSiE CV path (mocked fitte coverage = 0.95, verbose = 0 ) - expect_named(cv, c("samplePartition", "prediction", "performance")) + expect_named( + cv, + c("samplePartition", "prediction", "performance", "foldFits") + ) expect_true("mvsusie_performance" %in% names(cv$performance)) expect_equal(dim(cv$prediction[["mvsusie_predicted"]]), c(n, R)) }) @@ -4044,7 +4053,10 @@ test_that(".fmFoldWeights covers the fSuSiE branch (mocked fitter)", { rbinom(n * p, 2, 0.4), n, p, - dimnames = list(paste0("s", 1:n), sprintf("chr1:%d:A:G", 100L * (1:p))) + dimnames = list( + paste0("s", seq_len(n)), + sprintf("chr1:%d:A:G", 100L * seq_len(p)) + ) ) Y <- matrix(rnorm(n * 4L), n, 4L, dimnames = list(rownames(X), NULL)) W <- pecotmr:::.fmFoldWeights( @@ -4192,7 +4204,10 @@ test_that(".fmWeightsCv covers per-fold prior, NULL-weights, and no-overlap bran verbose = 0, mvPriorCv = list("1" = list(priorVariance = diag(2))) ) - expect_named(cv, c("samplePartition", "prediction", "performance")) + expect_named( + cv, + c("samplePartition", "prediction", "performance", "foldFits") + ) }) test_that("fineMappingPipeline(QtlSumStats): susieInf RSS chain (mocked)", { diff --git a/tests/testthat/test_fineMappingRow.R b/tests/testthat/test_fineMappingRow.R index c3bbebf0..290b0283 100644 --- a/tests/testthat/test_fineMappingRow.R +++ b/tests/testthat/test_fineMappingRow.R @@ -288,7 +288,7 @@ test_that("FineMappingRow cvResult defaults to NULL and rejects non-list", { topLoci = tl, cvResult = 1:3 ), - "cvResult must be NULL or a list" + "cvResult.*Must be of type 'list' \\(or 'NULL'\\)" ) }) @@ -978,7 +978,7 @@ test_that("getCredibleSetSummary aggregates across a collection with entry ident p, dimnames = list( paste0("s", seq_len(n)), - paste0("chr1:", (seq_len(p)) * 100, ":A:G") + paste0("chr1:", seq_len(p) * 100, ":A:G") ) ) b1 <- sin(seq(0, 2 * pi, length.out = J)) @@ -1662,3 +1662,33 @@ test_that("show(FineMappingRow) reports zero sets for an empty row", { ) expect_output(show(withCs), "2 variants, 1 credible sets") }) + +test_that(".csLog10Bf and .csMeanEffect return NA, never -Inf or NaN", { + # Both previously disagreed with their own missing-column branch: an empty + # or all-NA column yielded -Inf / NaN from max() / mean() while a missing + # column yielded NA_real_. These values reach output tables. + expect_identical(pecotmr:::.csLog10Bf(list()), NA_real_) + expect_identical( + pecotmr:::.csLog10Bf(list(logBF = numeric(0))), + NA_real_ + ) + expect_identical( + pecotmr:::.csLog10Bf(list(logBF = c(NA_real_, NA_real_))), + NA_real_ + ) + expect_identical(pecotmr:::.csLog10Bf(list(logBF = c(1, 3, 2))), 3) + + expect_identical(pecotmr:::.csMeanEffect(list()), NA_real_) + expect_identical( + pecotmr:::.csMeanEffect(list(conditional_effect = numeric(0))), + NA_real_ + ) + expect_identical( + pecotmr:::.csMeanEffect(list(conditional_effect = c(NA, NA))), + NA_real_ + ) + expect_identical( + pecotmr:::.csMeanEffect(list(conditional_effect = c(1, 3))), + 2 + ) +}) diff --git a/tests/testthat/test_fineMappingWrappers.R b/tests/testthat/test_fineMappingWrappers.R index d6296239..62bb41e8 100644 --- a/tests/testthat/test_fineMappingWrappers.R +++ b/tests/testthat/test_fineMappingWrappers.R @@ -257,6 +257,18 @@ test_that("get_cs_info reports variant in multiple CSs as multiple rows", { # susieWeights # ============================================================================= +test_that("susie*Weights refuse to fine-map when no fit is supplied", { + # These extract weights from an existing fit; twasWeightsPipeline gates + # susie-family tokens up front, so a NULL fit here is a caller error, not + # an invitation to run susie. + data(eqtlRegionExample) + X <- eqtlRegionExample$X[, 1:30] + y <- eqtlRegionExample$yRes + expect_error(susieWeights(X, y), "no 'susie' fit supplied") + expect_error(susieAshWeights(X, y), "no 'susieAsh' fit supplied") + expect_error(susieInfWeights(X, y), "no 'susieInf' fit supplied") +}) + test_that("susieWeights returns zeros when fit lacks alpha/mu", { fake_fit <- list(pip = rep(0.01, 5)) result <- susieWeights(susieFit = fake_fit) @@ -346,7 +358,7 @@ test_that("init_prior_sd returns n standard deviations", { # Helper: build a minimal synthetic SuSiE-family output for post-processing make_fake_susie_output <- function(p = 5, L = 3, has_V = TRUE) { - vnames <- paste0("chr1:", 1:p, ":A:G") + vnames <- paste0("chr1:", seq_len(p), ":A:G") out <- list( pip = setNames(rep(0.01, p), vnames), alpha = matrix(1 / p, nrow = L, ncol = p), @@ -399,8 +411,8 @@ test_that("postprocessFinemappingFits stores outcome_names, coef, and clfsr for p <- 5 L <- 3 R <- 2 - vnames <- paste0("chr1:", 1:p, ":A:G") - cnames <- paste0("cond_", 1:R) + vnames <- paste0("chr1:", seq_len(p), ":A:G") + cnames <- paste0("cond_", seq_len(R)) fake_coef <- matrix(rnorm((p + 1) * R), nrow = p + 1, ncol = R) fake_output <- list( @@ -630,7 +642,7 @@ if (!exists(".make_univariate_data", inherits = FALSE)) { mu2 = mu2 ) - cs_tables <- lapply(names(cs_at_cov), function(cov_str) { + cs_tables <- map(names(cs_at_cov), function(cov_str) { cs_list <- cs_at_cov[[cov_str]] if (is.null(cs_list)) { cs_list <- list() @@ -660,7 +672,7 @@ if (!exists(".make_univariate_data", inherits = FALSE)) { purity = purity_df ), cs_corr = if (n_cs > 0L) { - lapply(seq_len(n_cs), function(i) { + map(seq_len(n_cs), function(i) { matrix(c(1, cs_purity_value, cs_purity_value, 1), nrow = 2) }) } else { @@ -2641,13 +2653,13 @@ test_that(".susie_rss_extract_weights returns correct-length vector", { n <- 500 R <- diag(p) z <- rnorm(p) + fit <- susieR::susie_rss(z = z, R = R, n = n, L = 5) w <- pecotmr:::.susieRssExtractWeights( - fit = NULL, + fit = fit, z = z, R = R, n = n, - requiredFields = c("alpha", "mu", "X_column_scale_factors"), - userArgs = list(L = 5) + requiredFields = c("alpha", "mu", "X_column_scale_factors") ) expect_equal(length(w), p) expect_true(all(is.finite(w))) @@ -2661,7 +2673,8 @@ test_that("susieRssWeights follows (stat, LD) convention", { R <- diag(p) z <- rnorm(p) stat <- list(b = z / sqrt(n), cor = z / sqrt(n), z = z, n = rep(n, p)) - w <- susieRssWeights(stat, R, methodArgs = list(L = 5)) + fit <- susieR::susie_rss(z = z, R = R, n = n, L = 5) + w <- susieRssWeights(stat, R, susieRssFit = fit) expect_equal(length(w), p) expect_true(all(is.finite(w))) }) @@ -2674,7 +2687,8 @@ test_that("susieRssWeights retains fit when retainFit = TRUE", { R <- diag(p) z <- rnorm(p) stat <- list(b = z / sqrt(n), cor = z / sqrt(n), z = z, n = rep(n, p)) - w <- susieRssWeights(stat, R, retainFit = TRUE, methodArgs = list(L = 5)) + fit <- susieR::susie_rss(z = z, R = R, n = n, L = 5) + w <- susieRssWeights(stat, R, susieRssFit = fit, retainFit = TRUE) expect_false(is.null(attr(w, "fit"))) }) @@ -2686,7 +2700,8 @@ test_that("susieInfRssWeights works", { R <- diag(p) z <- rnorm(p) stat <- list(b = z / sqrt(n), cor = z / sqrt(n), z = z, n = rep(n, p)) - w <- susieInfRssWeights(stat, R, methodArgs = list(L = 5)) + fit <- susieR::susie_rss(z = z, R = R, n = n, L = 5) + w <- susieInfRssWeights(stat, R, susieInfRssFit = fit) expect_equal(length(w), p) expect_true(all(is.finite(w))) }) @@ -2712,47 +2727,50 @@ test_that("mvsusieWeights real fit returns p x K weights or errors on unstable s test_that("susieAshRssWeights returns weights of length p", { skip_if_not_installed("susieR") f <- .rrwStatLd() - w <- susieAshRssWeights(f$stat, f$LD, methodArgs = list(L = 5)) + fit <- susieR::susie_rss( + z = f$stat$z, + R = f$LD, + n = median(f$stat$n), + L = 5 + ) + w <- susieAshRssWeights(f$stat, f$LD, susieAshRssFit = fit) expect_length(w, f$p) expect_true(all(is.finite(w))) }) -test_that("mvsusieRssWeights fits mvsusie_rss and returns p x K weights", { +test_that("mvsusieRssWeights returns p x K weights from a supplied fit", { skip_if_not_installed("mvsusieR") m <- .rrwMulti(n = 80, p = 8, K = 2) - # LGreedy stays at its NULL default: mvsusieR's greedy-L loop errors on - # small data ("Values and their weights should have equal length"), which - # is why the greedy loop is off unless a caller asks for it. - w <- mvsusieRssWeights(m$stat, m$LD, L = 5) + fakeCoef <- matrix(rnorm((m$p + 1) * m$K), nrow = m$p + 1, ncol = m$K) + local_mocked_bindings( + coef.mvsusie = function(...) fakeCoef, + .package = "mvsusieR" + ) + w <- mvsusieRssWeights(m$stat, m$LD, mvsusieRssFit = "precomputed_fit") expect_equal(dim(w), c(m$p, m$K)) expect_true(all(is.finite(w))) }) -test_that("mvsusieRssWeights forwards L / clamped LGreedy to mvsusie_rss", { +test_that("mvsusieRssWeights refuses to fine-map when no fit is supplied", { skip_if_not_installed("mvsusieR") m <- .rrwMulti(n = 80, p = 8, K = 2) - fakeCoef <- matrix(rnorm((m$p + 1) * m$K), nrow = m$p + 1, ncol = m$K) - captured <- list() - local_mocked_bindings( - create_mixture_prior = function(...) list(), - mvsusie_rss = function(...) { - captured <<- list(...) - "mock_fit" - }, - coef.mvsusie = function(...) fakeCoef, - .package = "mvsusieR" + expect_error( + mvsusieRssWeights(m$stat, m$LD), + "`mvsusieRssFit` is required" ) - w <- mvsusieRssWeights(m$stat, m$LD, L = 3, LGreedy = 7) - expect_equal(dim(w), c(m$p, m$K)) - expect_equal(captured$L, 3) - expect_equal(captured$L_greedy, 3) # clamped to min(LGreedy, L) }) -test_that("mvsusieRssWeights errors on single-context stat$z", { +test_that("mvsusieRssWeights demands a fit before anything else", { skip_if_not_installed("mvsusieR") f <- .rrwStatLd() oneCol <- list(z = matrix(f$stat$z, ncol = 1), n = f$n) - expect_error(mvsusieRssWeights(oneCol, f$LD), ">= 2 columns") + # The old ">= 2 columns" guard validated *fitting* inputs and left with + # the fitting branch; with no fit supplied, the missing fit is the + # fundamental problem and `stat` is not read at all. + expect_error( + mvsusieRssWeights(oneCol, f$LD), + "`mvsusieRssFit` is required" + ) }) # ---- mvsusieWeights ---- @@ -2762,62 +2780,22 @@ test_that("mvsusieWeights errors when mvsusieR package is not available", { "mvsusieR is installed; skipping missing-package test" ) - expect_error( - mvsusieWeights( - mvsusieFit = NULL, - X = matrix(1, 10, 5), - Y = matrix(1, 10, 3) - ), - "mvsusieR" - ) + expect_error(mvsusieWeights(mvsusieFit = NULL), "mvsusieR") }) -test_that("mvsusieWeights errors when X and Y are NULL and fit is NULL", { +test_that("mvsusieWeights refuses to fine-map when no fit is supplied", { skip_if_not( requireNamespace("mvsusieR", quietly = TRUE), "mvsusieR not installed" ) + # mvSuSiE fitting belongs to fineMappingPipeline(); this extractor must + # not silently refit when the caller forgets the fit. expect_error( - mvsusieWeights(mvsusieFit = NULL, X = NULL, Y = NULL), - "Both X and Y must be provided" + mvsusieWeights(mvsusieFit = NULL), + "`mvsusieFit` is required" ) }) -test_that("mvsusieWeights fits model and returns coefficients when fit is NULL", { - skip_if_not( - requireNamespace("mvsusieR", quietly = TRUE), - "mvsusieR not installed" - ) - set.seed(42) - n <- 30 - p <- 5 - R <- 3 - X <- matrix(rnorm(n * p), n, p) - Y <- matrix(rnorm(n * R), n, R) - fake_coef <- matrix(rnorm((p + 1) * R), nrow = p + 1, ncol = R) - captured <- list() - - local_mocked_bindings( - create_mixture_prior = function(...) list(), - mvsusie = function(...) { - captured <<- list(...) - "mock_fit" - }, - coef.mvsusie = function(...) fake_coef, - .package = "mvsusieR" - ) - - result <- expect_message( - mvsusieWeights(X = X, Y = Y, L = 12, LGreedy = 4), - "mvsusieFit is not provided" - ) - # Should return coef without intercept row - expect_equal(dim(result), c(p, R)) - expect_equal(result, fake_coef[-1, ]) - expect_equal(captured$L, 12) - expect_equal(captured$L_greedy, 4) -}) - test_that("mvsusieWeights returns coefficients from provided fit", { skip_if_not( requireNamespace("mvsusieR", quietly = TRUE), @@ -2837,8 +2815,13 @@ test_that("mvsusieWeights returns coefficients from provided fit", { expect_equal(result, fake_coef[-1, ]) }) -.fw_makeFsusieFit <- function(seed = 1, n = 150L, p = 24L, J = 16L, - prior = "mixture_normal_per_scale") { +.fw_makeFsusieFit <- function( + seed = 1, + n = 150L, + p = 24L, + J = 16L, + prior = "mixture_normal_per_scale" +) { set.seed(seed) X <- matrix( rnorm(n * p), @@ -2846,7 +2829,7 @@ test_that("mvsusieWeights returns coefficients from provided fit", { p, dimnames = list( paste0("s", seq_len(n)), - sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + sprintf("chr1:%d:A:G", 100L * seq_len(p)) ) ) b1 <- sin(seq(0, 2 * pi, length.out = J)) @@ -3843,18 +3826,70 @@ test_that("susieInf is skipped as a result when it was only a chain input", { # from, but keepInf is FALSE so it must not surface as its own method. chainOnly <- pecotmr:::.fmResolveSusieChain("susie", TRUE) expect_false(chainOnly$keepInf) - expect_null(pecotmr:::.fmXFitOne("susieInf", list(), chainOnly, "INFFIT")) - expect_null(pecotmr:::.fmRssFitOne("susieInf", list(), chainOnly, "INFFIT")) + expect_null(pecotmr:::.fmXFitOne( + "susieInf", + chainOnly, + "INFFIT", + X = NULL, + y = NULL, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + ctx = "c1", + tid = "t1" + )) + expect_null(pecotmr:::.fmRssFitOne( + "susieInf", + chainOnly, + "INFFIT", + z = NULL, + R = NULL, + n = 100L, + coverage = 0.95, + methodArgs = list(), + rFinite = NULL, + rMismatch = NULL, + rssControl = NULL, + verbose = 0, + label = "lab", + serFallback = FALSE + )) }) test_that("susieInf is returned as its own fit when it was requested", { asked <- pecotmr:::.fmResolveSusieChain(c("susie", "susieInf"), TRUE) expect_true(asked$keepInf) expect_equal( - pecotmr:::.fmXFitOne("susieInf", list(), asked, "INFFIT"), + pecotmr:::.fmXFitOne( + "susieInf", + asked, + "INFFIT", + X = NULL, + y = NULL, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + ctx = "c1", + tid = "t1" + ), "INFFIT" ) - rss <- pecotmr:::.fmRssFitOne("susieInf", list(), asked, "INFFIT") + rss <- pecotmr:::.fmRssFitOne( + "susieInf", + asked, + "INFFIT", + z = NULL, + R = NULL, + n = 100L, + coverage = 0.95, + methodArgs = list(), + rFinite = NULL, + rMismatch = NULL, + rssControl = NULL, + verbose = 0, + label = "lab", + serFallback = FALSE + ) expect_equal(rss$fit, "INFFIT") expect_false(rss$isStd) }) @@ -3980,37 +4015,74 @@ test_that("no credible sets leaves the conditional lfsr untouched", { test_that(".fmXFitOne threads the shared susieInf fit into chained tokens", { local_mocked_bindings( - .fmFitSusieIndiv = function(X, y, tk, chainFromInf, coverage, - userArgs) { + .fmFitSusieIndiv = function( + X, + y, + tk, + chainFromInf, + coverage, + userArgs + ) { list(tk = tk, chained = !is.null(chainFromInf)) }, .package = "pecotmr" ) - p <- list( - X = NULL, y = NULL, verbose = 0, coverage = 0.95, - methodArgs = list(), ctx = "c1", tid = "t1" - ) chain <- pecotmr:::.fmResolveSusieChain(c("susie", "susieInf"), TRUE) expect_true(chain$chainSusie) - expect_true(pecotmr:::.fmXFitOne("susie", p, chain, list(S = TRUE))$chained) + expect_true( + pecotmr:::.fmXFitOne( + "susie", + chain, + list(S = TRUE), + X = NULL, + y = NULL, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + ctx = "c1", + tid = "t1" + )$chained + ) # susieAsh is not in this chain, so it fits from scratch. expect_false( - pecotmr:::.fmXFitOne("susieAsh", p, chain, list(S = TRUE))$chained + pecotmr:::.fmXFitOne( + "susieAsh", + chain, + list(S = TRUE), + X = NULL, + y = NULL, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + ctx = "c1", + tid = "t1" + )$chained ) chainAsh <- pecotmr:::.fmResolveSusieChain(c("susieAsh", "susieInf"), TRUE) expect_true( - pecotmr:::.fmXFitOne("susieAsh", p, chainAsh, list(S = TRUE))$chained + pecotmr:::.fmXFitOne( + "susieAsh", + chainAsh, + list(S = TRUE), + X = NULL, + y = NULL, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + ctx = "c1", + tid = "t1" + )$chained ) }) test_that(".fmFitXBlock skips a token that produced no fit", { local_mocked_bindings( - .fmXInfFit = function(p, chainLocal) NULL, - .fmXFitOne = function(tk, p, chainLocal, infFit) { + .fmXInfFit = function(chainLocal, ...) NULL, + .fmXFitOne = function(tk, chainLocal, infFit, ...) { if (tk == "susie") NULL else list(tk = tk) }, - .fmXPostprocess = function(fit, tk, p) list(done = tk), - .fmXCrossValidate = function(out, p) out, + .fmXPostprocess = function(fit, tk, ...) list(done = tk), + .fmXCrossValidate = function(out, ...) out, .package = "pecotmr" ) out <- pecotmr:::.fmFitXBlock( @@ -4025,33 +4097,53 @@ test_that(".fmFitXBlock skips a token that produced no fit", { test_that(".fmRssFitStd threads the shared susieInf fit when chained", { local_mocked_bindings( - .fmFitSusieRss = function(z, R, n, tk, chainFromInf, coverage, - userArgs, rFinite, rMismatch, rssControl) { + .fmFitSusieRss = function( + z, + R, + n, + tk, + chainFromInf, + coverage, + userArgs, + rFinite, + rMismatch, + rssControl + ) { list(tk = tk, chained = !is.null(chainFromInf)) }, .package = "pecotmr" ) - p <- list( - z = NULL, R = NULL, n = 100L, verbose = 0, coverage = 0.95, - methodArgs = list(), label = "lab", rFinite = NULL, - rMismatch = NULL, rssControl = NULL - ) chain <- pecotmr:::.fmResolveSusieChain(c("susie", "susieInf"), TRUE) - out <- pecotmr:::.fmRssFitStd("susie", p, chain, list(S = TRUE)) + out <- pecotmr:::.fmRssFitStd( + "susie", + chain, + list(S = TRUE), + z = NULL, + R = NULL, + n = 100L, + coverage = 0.95, + methodArgs = list(), + rFinite = NULL, + rMismatch = NULL, + rssControl = NULL, + verbose = 0, + label = "lab", + serFallback = FALSE + ) expect_true(out$fit$chained) }) test_that(".fmFitRssBlock skips a token that produced no fit", { local_mocked_bindings( - .fmRssInfFit = function(p, chainLocal) NULL, - .fmRssFitOne = function(tk, p, chainLocal, infFit) { + .fmRssInfFit = function(chainLocal, ...) NULL, + .fmRssFitOne = function(tk, chainLocal, infFit, ...) { if (tk == "susie") { NULL } else { list(fit = list(tk = tk), isStd = FALSE) } }, - .fmRssPostprocess = function(fit, p) list(done = fit$tk), + .fmRssPostprocess = function(fit, ...) list(done = fit$tk), .package = "pecotmr" ) out <- pecotmr:::.fmFitRssBlock( @@ -4088,30 +4180,39 @@ test_that(".ppAssembleRes records sample names from a matrix dataY", { nrow = 3L, dimnames = list(c("s1", "s2", "s3"), c("a", "b")) ) - p <- list( - signalCutoff = 0, method = "susie", dataY = Y, - fit = list(), otherQuantities = NULL - ) topLoci <- data.frame( variant_id = "chr1:1:A:G", pip = 0.9, stringsAsFactors = FALSE ) - res <- pecotmr:::.ppAssembleRes(p, topLoci, NULL, NULL) + res <- pecotmr:::.ppAssembleRes( + topLoci, + NULL, + NULL, + fit = list(), + method = "susie", + dataY = Y, + otherQuantities = NULL, + signalCutoff = 0 + ) expect_equal(res$sampleNames, c("s1", "s2", "s3")) # A list dataY (multi-context) has no single sample vector to record. expect_null(pecotmr:::.sampleNamesFromDataY(list(Y))) }) -test_that(".btlParseVariants surfaces a parse failure as an error", { +test_that(".btlParseVariants surfaces a parse failure as a chained error", { local_mocked_bindings( parseVariantId = function(...) stop("boom"), .package = "pecotmr" ) - expect_error( + cnd <- expect_error( pecotmr:::.btlParseVariants("chr1:1:A:G"), - "buildTopLoci: parseVariantId failed: boom" + "buildTopLoci: parseVariantId failed" ) + # try_fetch(parent = cnd) keeps the cause as a real condition rather than + # flattening it into the message, so the original is still reachable. + expect_s3_class(cnd$parent, "condition") + expect_match(conditionMessage(cnd$parent), "boom") }) test_that(".btlParseVariants requires one parsed row per variant", { @@ -4252,8 +4353,16 @@ test_that("fsusieWeights attaches the fit only when asked", { test_that("mvsusieRssWeights attaches the fit only when asked", { skip_if_not_installed("mvsusieR") m <- .rrwMulti(n = 80, p = 8, K = 2) - kept <- suppressMessages( - mvsusieRssWeights(m$stat, m$LD, L = 5, retainFit = TRUE) + fakeCoef <- matrix(rnorm((m$p + 1) * m$K), nrow = m$p + 1, ncol = m$K) + local_mocked_bindings( + coef.mvsusie = function(...) fakeCoef, + .package = "mvsusieR" + ) + kept <- mvsusieRssWeights( + m$stat, + m$LD, + mvsusieRssFit = "precomputed_fit", + retainFit = TRUE ) expect_false(is.null(attr(kept, "fit"))) expect_equal(dim(kept), c(m$p, m$K)) @@ -4313,3 +4422,66 @@ test_that("mergeSusieCs returns NULL when the combined table is empty", { # Rows were extracted, but combining them produced nothing to merge. expect_null(mergeSusieCs(res, coverage = 0.95)) }) + +test_that("susie*Weights: retainFit / stat / methodArgs guards fire", { + # Each guard is the first statement, so the remaining arguments stay + # unforced and can be left as placeholders. + expect_error(susieWeights(retainFit = NA), "retainFit.*May not be NA") + expect_error(susieAshWeights(retainFit = 1L), "retainFit.*logical flag") + expect_error(susieInfWeights(retainFit = 1L), "retainFit.*logical flag") + expect_error( + susieRssWeights(stat = "nope", LD = NULL), + "stat.*Must be of type 'list'" + ) + expect_error( + susieInfRssWeights(stat = "nope", LD = NULL), + "stat.*Must be of type 'list'" + ) + expect_error( + susieAshRssWeights(stat = "nope", LD = NULL), + "stat.*Must be of type 'list'" + ) +}) + +test_that("mvsusie / fsusie wrappers: numeric guards fire", { + expect_error( + fitMvsusie(NULL, NULL, NULL, coverage = 2), + "coverage.*is not <= 1" + ) + expect_error( + fitMvsusieRss(NULL, NULL, N = -1, NULL), + "N.*is not >= 0" + ) + expect_error( + fitMvsusieRss(NULL, NULL, N = 100, NULL, coverage = -1), + "coverage.*is not >= 0" + ) + expect_error( + fsusieGetCs(NULL, NULL, requestedCoverage = 2), + "requestedCoverage.*is not <= 1" + ) +}) + +test_that("fitSusieInfThenSusieRss: argument guards fire", { + expect_error( + fitSusieInfThenSusieRss(z = "nope", R = NULL, n = 100), + "z.*Must be of type 'numeric'" + ) + expect_error( + fitSusieInfThenSusieRss(z = 1, R = NULL, n = -1), + "n.*is not >= 0" + ) + expect_error( + fitSusieInfThenSusieRss(z = 1, R = NULL, n = 1, args = 1L), + "args.*Must be of type 'list'" + ) + expect_error( + fitSusieInfThenSusieRss( + z = 1, + R = NULL, + n = 1, + fittedModels = 1L + ), + "fittedModels.*Must be of type 'list'" + ) +}) diff --git a/tests/testthat/test_genotypeHandle.R b/tests/testthat/test_genotypeHandle.R index 2fd48034..50e4d773 100644 --- a/tests/testthat/test_genotypeHandle.R +++ b/tests/testthat/test_genotypeHandle.R @@ -125,7 +125,7 @@ test_that(".genotypeHandleFromPlink1Triplet: errors on non-character input", { bim = "x.bim", fam = "x.fam" ), - "must be a single file path" + "Must be of type 'string'" ) }) diff --git a/tests/testthat/test_genotypeIo.R b/tests/testthat/test_genotypeIo.R index 97a2f131..a37f7282 100644 --- a/tests/testthat/test_genotypeIo.R +++ b/tests/testthat/test_genotypeIo.R @@ -180,7 +180,7 @@ dummy_pheno_data <- function( end_matrix <- end_matrix[sample(nrow(end_matrix)), ] } pheno_data <- t(pheno_data) - pheno_data <- lapply(seq_len(ncol(pheno_data)), function(i) { + pheno_data <- map(seq_len(ncol(pheno_data)), function(i) { pheno_data[, i, drop = FALSE] }) return(pheno_data) @@ -207,7 +207,7 @@ dummy_covar_data <- function( covar <- covar[sample(nrow(covar)), ] } if (row_na) { - covar[sample(length(covar), 1), 1:number_of_covars] <- NA + covar[sample(length(covar), 1), seq_len(number_of_covars)] <- NA } return(covar) } @@ -648,7 +648,7 @@ test_that("invertMinmaxScaling preserves correlation structure", { n <- 200 k <- 3 # Simulate U = W'G (G is raw, not standardized, matching rss_ld_sketch) - G <- sapply(c(0.2, 0.4, 0.1), function(p) rbinom(n, 2, p)) + G <- exec(cbind, !!!map(c(0.2, 0.4, 0.1), function(p) rbinom(n, 2, p))) W <- matrix(rnorm(n * n, 0, 1 / sqrt(n)), n, n) U_original <- crossprod(W, G) @@ -1712,6 +1712,27 @@ test_that("single-shard sharded handle equals the single-file handle", { expect_equal(.shardDose(sh, 1:10), .shardDose(ref, 1:10)) }) +test_that("readGenotypes(genoMeta=) forwards `format` to the shard reader", { + skip_if_not_installed("snpStats") + # Regression: the path = "missing" method bound `format` to its own formal + # and then called GenotypeHandle(...) without it, so an explicit format was + # silently dropped and every shard fell back to extension probing. + seen <- new.env(parent = emptyenv()) + seen$fmt <- NA_character_ + local_mocked_bindings( + .resolveGenotypeShard = function(p, format = NULL) { + seen$fmt <- if (is.null(format)) "" else format + pecotmr:::.makePlink1Handle(p) + }, + .package = "pecotmr" + ) + readGenotypes( + genoMeta = c("21" = file.path(test_data_dir, "test_variants")), + format = "plink1" + ) + expect_identical(seen$fmt, "plink1") +}) + test_that("genoMeta meta-file form matches the named-vector form", { skip_if_not_installed("snpStats") td_abs <- normalizePath(test_data_dir) @@ -1762,7 +1783,7 @@ test_that(".makeGdsHandle errors when GDS file is absent", { skip_if_not_installed("gdsfmt") expect_error( pecotmr:::.makeGdsHandle("/no/such/file.gds"), - "GDS file not found" + "GDS file.*File does not exist" ) }) @@ -1770,7 +1791,7 @@ test_that(".makeVcfHandle errors when VCF file is absent", { skip_if_not_installed("VariantAnnotation") expect_error( pecotmr:::.makeVcfHandle("/no/such/file.vcf.gz"), - "VCF file not found" + "VCF file.*File does not exist" ) }) @@ -1781,7 +1802,7 @@ test_that(".makePlink1Handle errors when plink1 trio is absent", { tempdir(), "missingPlink1Prefix" )), - "Plink file not found" + "Plink file.*File does not exist" ) }) @@ -2108,7 +2129,7 @@ test_that("resolvePlink2Paths errors when .psam is missing", { prefix <- .gioMakePlink2Stub(c("pgen", "pvar")) expect_error( pecotmr:::resolvePlink2Paths(prefix), - "PLINK2 .psam file not found" + "PLINK2 .psam file.*File does not exist" ) }) diff --git a/tests/testthat/test_h2EstimationWrappers.R b/tests/testthat/test_h2EstimationWrappers.R index f9758790..402c733f 100644 --- a/tests/testthat/test_h2EstimationWrappers.R +++ b/tests/testthat/test_h2EstimationWrappers.R @@ -24,7 +24,7 @@ make_test_eigen_ref <- function(nSnps = 20, nBlocks = 2) { stringsAsFactors = FALSE ) - eigen_list <- lapply(seq_len(nBlocks), function(b) { + eigen_list <- map(seq_len(nBlocks), function(b) { idx <- seq((b - 1) * snps_per_block + 1, b * snps_per_block) p <- length(idx) set.seed(42 + b) @@ -78,7 +78,7 @@ make_test_score_ref <- function( ld_score_weights <- rep(1 / nSnps, nSnps) ld_matrix_list <- if (with_ld_matrices) { - lapply(seq_len(nBlocks), function(b) { + map(seq_len(nBlocks), function(b) { idx <- seq((b - 1) * snps_per_block + 1, b * snps_per_block) p <- length(idx) # AR(1) LD so per-SNP LD scores vary (equicorrelated R gives a @@ -377,7 +377,7 @@ test_that("h2EstimateToSldscTrait returns correct list structure", { test_that("h2EstimateToSldscTrait errors on non-H2Estimate input", { expect_error( h2EstimateToSldscTrait(list(h2 = 0.3)), - "must be an H2Estimate" + "Must inherit from class 'H2Estimate'" ) }) @@ -680,7 +680,7 @@ test_that("the S-LDSC weights reproduce upstream Hsq.weights", { # An LD block with `dup` variants repeated, so R is singular by construction # and eigen() returns a negative-noise tail. .rankDeficientEigenRef <- function(nBlocks = 6L, p = 12L, dup = 4L) { - blocks <- lapply(seq_len(nBlocks), function(b) { + blocks <- map(seq_len(nBlocks), function(b) { base <- 0.5^abs(outer(seq_len(p - dup), seq_len(p - dup), "-")) keep <- c(seq_len(p - dup), seq_len(dup)) R <- base[keep, keep] @@ -700,8 +700,8 @@ test_that("the S-LDSC weights reproduce upstream Hsq.weights", { A2 = "G", stringsAsFactors = FALSE ) - starts <- as.integer(sapply(blocks, function(b) min(b$snpIdx))) * 100L - ends <- as.integer(sapply(blocks, function(b) max(b$snpIdx))) * 100L + starts <- as.integer(map_dbl(blocks, function(b) min(b$snpIdx))) * 100L + ends <- as.integer(map_dbl(blocks, function(b) max(b$snpIdx))) * 100L LdEigen( ldBlocks = GenomicRanges::GRanges( "chr1", @@ -718,7 +718,7 @@ test_that("the S-LDSC weights reproduce upstream Hsq.weights", { test_that("a rank-deficient LD block really does yield negative eigenvalues", { ref <- .rankDeficientEigenRef() - values <- unlist(lapply(getEigenList(ref), function(b) b$values)) + values <- unlist(map(getEigenList(ref), function(b) b$values)) expect_true(any(values < 0)) expect_true(min(values) > -1e-6) # noise, not structure }) @@ -968,7 +968,7 @@ test_that("jackknifeSe computes known case correctly", { full_mean <- mean(vals) n <- length(vals) # Leave-one-out means: remove element i, compute mean of remaining - loo_means <- vapply(seq_len(n), function(i) mean(vals[-i]), numeric(1)) + loo_means <- map_dbl(seq_len(n), function(i) mean(vals[-i])) estimates_loo <- matrix(loo_means, ncol = 1) se <- pecotmr:::jackknifeSe(full_mean, estimates_loo) # Pseudo-values: n * full - (n-1) * loo @@ -1424,7 +1424,7 @@ test_that("shrinkLd wen_stephens uses genetic map when provided", { # Result should be symmetric expect_equal(res, t(res)) # Off-diagonal elements should be shrunk (closer to zero than original) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { for (j in (i + 1):p) { expect_true(abs(res[i, j]) <= abs(R[i, j]) + 1e-10) } @@ -2009,10 +2009,12 @@ makeCoverageAnnot <- function( stringsAsFactors = FALSE ) if (nCand > 0L) { - cand <- vapply( - seq_len(nCand), - function(k) as.numeric(rbinom(n_snps, 1, 0.3 + 0.1 * k)), - numeric(n_snps) + cand <- exec( + cbind, + !!!map( + seq_len(nCand), + function(k) as.numeric(rbinom(n_snps, 1, 0.3 + 0.1 * k)) + ) ) mat <- cbind(mat, cand) meta <- rbind( @@ -2260,7 +2262,7 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" # references plus a simulator closure. No external dependencies. .h2RecoveryRefs <- function(nBlocks = 30L, p = 40L, N = 80000) { M <- nBlocks * p - blocks <- lapply(seq_len(nBlocks), function(b) { + blocks <- map(seq_len(nBlocks), function(b) { R <- 0.6^abs(outer(seq_len(p), seq_len(p), "-")) e <- eigen(R, symmetric = TRUE) list( @@ -2278,8 +2280,8 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" A2 = "G", stringsAsFactors = FALSE ) - starts <- as.integer(unlist(lapply(blocks, function(b) min(b$idx)))) * 100L - ends <- as.integer(unlist(lapply(blocks, function(b) max(b$idx)))) * 100L + starts <- as.integer(map_dbl(blocks, function(b) min(b$idx))) * 100L + ends <- as.integer(map_dbl(blocks, function(b) max(b$idx))) * 100L gr <- GenomicRanges::GRanges( "chr1", IRanges::IRanges(start = starts, end = ends) @@ -2292,7 +2294,7 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" inSample = FALSE, genome = "hg19", eigenvalueTruncation = 1.0, - eigenList = lapply(blocks, function(b) { + eigenList = map(blocks, function(b) { list( values = b$values, vectors = b$vectors, @@ -2312,12 +2314,12 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" genome = "hg19", ldScores = matrix(lsv, ncol = 1, dimnames = list(NULL, "base_l2")), ldScoreWeights = rep(1, M), - ldMatrixList = lapply(blocks, function(b) { + ldMatrixList = map(blocks, function(b) { list(R = b$R, snpIdx = as.integer(b$idx)) }) ) simZ <- function(perSnpVar) { - unlist(lapply(blocks, function(b) { + unlist(map(blocks, function(b) { S <- N * (b$R %*% diag(perSnpVar[b$idx], p) %*% b$R) + b$R as.vector(crossprod(chol(S), rnorm(p))) })) @@ -2736,7 +2738,7 @@ test_that("HDL recovers a known h2 given an adequate reference", { data(ldEigenExample, ldScoreExample) ref <- ldEigenExample ref@nRef <- 20000L - ests <- vapply( + ests <- map_dbl( 1:5, function(seed) { suppressWarnings( @@ -2746,8 +2748,7 @@ test_that("HDL recovers a known h2 given an adequate reference", { ref )$h2 ) - }, - numeric(1) + } ) expect_lt(abs(mean(ests) - 0.4), 0.1) }) diff --git a/tests/testthat/test_jointEngine.R b/tests/testthat/test_jointEngine.R index 75e63070..c5ee59e7 100644 --- a/tests/testthat/test_jointEngine.R +++ b/tests/testthat/test_jointEngine.R @@ -439,7 +439,7 @@ test_that(".runJointCell: cross-context twas CV-only rows (fitFullData=FALSE)", p, k, dimnames = list( - sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + sprintf("chr1:%d:A:G", 100L * seq_len(p)), paste0("c", seq_len(k)) ) ) @@ -568,7 +568,7 @@ test_that("fitJointGroup(SumStats, Twas): real mr.mash-rss keys stat$n (regressi K <- 2L nObs <- 400L X <- matrix(rnorm(nObs * p), nObs, p) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) R <- cor(X) Z <- matrix( rnorm(p * K), @@ -1026,7 +1026,7 @@ test_that(".runJointCell: composed/sumstats (context+trait vary) -> per-tuple ro .je_ensEntries <- function(group, predCor) { Y <- .jgY(group) vars <- colnames(.jgX(group)) - lapply(seq_len(ncol(Y)), function(r) { + map(seq_len(ncol(Y)), function(r) { pr <- predCor * Y[, r] + rnorm(nrow(Y), sd = 0.3) names(pr) <- rownames(Y) rsq <- stats::cor(Y[, r], pr)^2 @@ -1086,7 +1086,7 @@ test_that(".twasEnsembleLayer: < 2 methods pass the R^2 cutoff -> NULL (skip)", standardized = FALSE ) ) - expect_true(all(vapply(ens, is.null, logical(1)))) + expect_true(all(map_lgl(ens, is.null))) }) # ---- engine twas fitter: orchestration absorbed from .twasWeightsPipelineMatrix @@ -1127,9 +1127,12 @@ test_that("fitJointGroup(twas): spike-and-slab pi is estimated from an internal rnorm(n * 3), n, 3, - dimnames = list(paste0("s", 1:n), sprintf("chr1:%d:A:G", 100L * (1:3))) + dimnames = list( + paste0("s", seq_len(n)), + sprintf("chr1:%d:A:G", 100L * (1:3)) + ) ) - Y <- matrix(rnorm(n), n, 1, dimnames = list(paste0("s", 1:n), "c1")) + Y <- matrix(rnorm(n), n, 1, dimnames = list(paste0("s", seq_len(n)), "c1")) g <- new( "IndividualJointGroup", conditions = data.frame( @@ -1270,12 +1273,12 @@ test_that("fitJointGroup(twas): FM-derived method reuses fine-mapping's CV (hand p, length(colLabels), dimnames = list( - sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + sprintf("chr1:%d:A:G", 100L * seq_len(p)), colLabels ) ), nVec = rep(100, length(colLabels)), - variantIds = sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)) ) } .je_mockLd <- function(sketch, vids, ...) { @@ -1627,7 +1630,7 @@ test_that(".enumUnivariateIndividual: one 1-condition group per (context, trait) g <- pecotmr:::.enumUnivariateIndividual(NULL, scope) expect_length(g, 4L) # 2 ctx x 2 traits expect_true(all( - vapply(g, function(x) nrow(.jgConditions(x)), integer(1)) == 1L + map_int(g, function(x) nrow(.jgConditions(x))) == 1L )) }) @@ -1751,13 +1754,16 @@ test_that("fitJointGroup(Individual, Fm): fsusie honest per-fold CV is attached" rnorm(n * 2), n, 2, - dimnames = list(paste0("s", 1:n), c("chr1:100:A:G", "chr1:200:A:G")) + dimnames = list( + paste0("s", seq_len(n)), + c("chr1:100:A:G", "chr1:200:A:G") + ) ) Y <- matrix( rnorm(n * 2), n, 2, - dimnames = list(paste0("s", 1:n), c("G1", "G2")) + dimnames = list(paste0("s", seq_len(n)), c("G1", "G2")) ) grp <- new( "IndividualJointGroup", @@ -1802,7 +1808,7 @@ test_that("fitJointGroup(Individual, Fm): SER pre-screen skips when < 2 survivor pecotmr:::fitJointGroup(g, pipe, "mvsusie", list(pipCutoffToSkip = 0.8)) ) expect_length(entries, 2L) # one per ORIGINAL cond - expect_true(all(vapply(entries, is.null, logical(1)))) # all-NULL (skipped) + expect_true(all(map_lgl(entries, is.null))) # all-NULL (skipped) }) test_that("fitJointGroup(Individual, Fm): SER pre-screen keeps a subset of conditions", { @@ -1812,13 +1818,16 @@ test_that("fitJointGroup(Individual, Fm): SER pre-screen keeps a subset of condi rnorm(n * 2), n, 2, - dimnames = list(paste0("s", 1:n), c("chr1:100:A:G", "chr1:200:A:G")) + dimnames = list( + paste0("s", seq_len(n)), + c("chr1:100:A:G", "chr1:200:A:G") + ) ) Y <- matrix( rnorm(n * 3), n, 3, - dimnames = list(paste0("s", 1:n), c("c1", "c2", "c3")) + dimnames = list(paste0("s", seq_len(n)), c("c1", "c2", "c3")) ) g <- new( "IndividualJointGroup", @@ -1904,9 +1913,12 @@ test_that("fitJointGroup(twas): spike-and-slab pi feeds bayes_b probIn", { rnorm(n * 3), n, 3, - dimnames = list(paste0("s", 1:n), sprintf("chr1:%d:A:G", 100L * (1:3))) + dimnames = list( + paste0("s", seq_len(n)), + sprintf("chr1:%d:A:G", 100L * (1:3)) + ) ) - Y <- matrix(rnorm(n), n, 1, dimnames = list(paste0("s", 1:n), "c1")) + Y <- matrix(rnorm(n), n, 1, dimnames = list(paste0("s", seq_len(n)), "c1")) g <- new( "IndividualJointGroup", conditions = data.frame( @@ -2060,7 +2072,7 @@ test_that(".twasEnsembleLayer: entries lacking CV predictions are skipped", { standardized = FALSE ) ) - expect_true(all(vapply(ens, is.null, logical(1)))) # < 2 usable -> NULL + expect_true(all(map_lgl(ens, is.null))) # < 2 usable -> NULL }) test_that(".twasEnsembleLayer: ensembleWeights returning NULL -> NULL entry", { @@ -2081,7 +2093,7 @@ test_that(".twasEnsembleLayer: ensembleWeights returning NULL -> NULL entry", { standardized = FALSE ) ) - expect_true(all(vapply(ens, is.null, logical(1)))) + expect_true(all(map_lgl(ens, is.null))) }) test_that(".twasEnsembleLayer: unnamed ensemble weights fall back to a method's variant ids", { @@ -2525,8 +2537,14 @@ test_that(".runJointSpecs row-binds TWAS results across specs", { .package = "pecotmr" ) out <- pecotmr:::.runJointSpecs( - list("s1", "s2", "s3"), NULL, "individual", - NULL, "lasso", NULL, NULL, list() + list("s1", "s2", "s3"), + NULL, + "individual", + NULL, + "lasso", + NULL, + NULL, + list() ) # The first spec seeds `out`; later ones are bound onto it. expect_equal(out, "R1+R2+R3") @@ -2547,8 +2565,14 @@ test_that(".runJointSpecs row-binds fine-mapping results across specs", { ) # The pipeline class, not the data, picks which rbind is used. out <- pecotmr:::.runJointSpecs( - list("s1", "s2"), NULL, "individual", - new("FmJointPipeline"), "susie", NULL, NULL, list() + list("s1", "s2"), + NULL, + "individual", + new("FmJointPipeline"), + "susie", + NULL, + NULL, + list() ) expect_equal(out, "F1&F2") }) @@ -2565,8 +2589,14 @@ test_that(".runJointSpecs skips a spec that produced nothing", { # A NULL spec must not seed `out`, or the bind would carry a NULL. expect_equal( pecotmr:::.runJointSpecs( - list("s1", "s2"), NULL, "individual", - NULL, "lasso", NULL, NULL, list() + list("s1", "s2"), + NULL, + "individual", + NULL, + "lasso", + NULL, + NULL, + list() ), "KEPT" ) @@ -2575,8 +2605,9 @@ test_that(".runJointSpecs skips a spec that produced nothing", { test_that(".twasGroupArgs yields no fitted models when the fit is absent", { local_mocked_bindings( .jpConfig = function(p) list(), - .jgConditions = function(g) list(study = "s", context = "c", - trait = "t"), + .jgConditions = function(g) { + list(study = "s", context = "c", trait = "t") + }, .twasFineMappingFits = function(...) NULL, .twasCvResultFor = function(...) NULL, .package = "pecotmr" @@ -2618,9 +2649,19 @@ test_that(".jointTwasCv prefers per-call CV settings over the config", { local_mocked_bindings( .twasFmHandoffCv = function(...) NULL, .jointTwasLeakageWarn = function(...) invisible(NULL), - twasWeightsCv = function(X, Y, fold, samplePartitions, weightMethods, - retainFits, maxNumVariants, numThreads, - data_driven_priorMatricesCv, verbose, seed) { + twasWeightsCv = function( + X, + Y, + fold, + samplePartitions, + weightMethods, + retainFits, + maxNumVariants, + numThreads, + dataDrivenPriorMatricesCv, + verbose, + seed + ) { seen <<- list(sp = samplePartitions, mcv = maxNumVariants) "CV" }, @@ -2633,11 +2674,22 @@ test_that(".jointTwasCv prefers per-call CV settings over the config", { dataDrivenPriorMatricesCv = NULL ) cfg <- list( - cvFolds = 5L, samplePartition = "CFG_SP", maxCvVariants = 77L, - cvThreads = 1, seed = 1L, verbose = 0 + cvFolds = 5L, + samplePartition = "CFG_SP", + maxCvVariants = 77L, + cvThreads = 1, + seed = 1L, + verbose = 0 ) pecotmr:::.jointTwasCv( - NULL, NULL, "lasso", NULL, c(1, 2), args, cfg, "lasso" + NULL, + NULL, + "lasso", + NULL, + c(1, 2), + args, + cfg, + "lasso" ) expect_equal(seen$sp, "ARGS_SP") expect_equal(seen$mcv, 77L) @@ -2648,7 +2700,14 @@ test_that(".jointTwasCv prefers per-call CV settings over the config", { cfgUncapped <- cfg cfgUncapped$maxCvVariants <- 0 pecotmr:::.jointTwasCv( - NULL, NULL, "lasso", NULL, c(1, 2), argsBare, cfgUncapped, "lasso" + NULL, + NULL, + "lasso", + NULL, + c(1, 2), + argsBare, + cfgUncapped, + "lasso" ) expect_equal(seen$sp, "CFG_SP") expect_equal(seen$mcv, Inf) @@ -2668,10 +2727,18 @@ test_that(".enumUnivariateIndividual reads a region instead of a cis window", { .fmResidPheno = function(data, contexts, traitId, naAction) { matrix(1, 2L, 1L, dimnames = list(c("s1", "s2"), "t1")) }, - .fmResidGeno = function(data, contexts, traitId = NULL, - cisWindow = NULL, region = NULL) { - seen <<- list(traitId = traitId, cisWindow = cisWindow, - region = region) + .fmResidGeno = function( + data, + contexts, + traitId = NULL, + cisWindow = NULL, + region = NULL + ) { + seen <<- list( + traitId = traitId, + cisWindow = cisWindow, + region = region + ) matrix(0, 2L, 2L, dimnames = list(c("s1", "s2"), c("v1", "v2"))) }, .package = "pecotmr" @@ -2682,7 +2749,9 @@ test_that(".enumUnivariateIndividual reads a region instead of a cis window", { traits = list(S1 = "t1") ) pecotmr:::.enumUnivariateIndividual( - NULL, scope, list(region = "chr1:1-1000") + NULL, + scope, + list(region = "chr1:1-1000") ) # An explicit region replaces the trait-anchored cis window entirely -- # neither traitId nor cisWindow is passed down. @@ -2690,3 +2759,180 @@ test_that(".enumUnivariateIndividual reads a region instead of a cis window", { expect_null(seen$cisWindow) expect_null(seen$traitId) }) + +# --------------------------------------------------------------------------- +# cvWeightMethods: the override and the all-zero notice. Both were amputated +# by 693e6d63 (the parameter stayed, its read path did not), so they are +# covered here to stop the same silent loss happening twice. +# --------------------------------------------------------------------------- + +test_that(".jointTwasCvRequested: NULL means every method", { + expect_true(pecotmr:::.jointTwasCvRequested(NULL, "susie")) + expect_true(pecotmr:::.jointTwasCvRequested(NULL, "lasso")) +}) + +test_that(".jointTwasCvRequested accepts tokens and method keys alike", { + expect_true(pecotmr:::.jointTwasCvRequested(c("susie", "lasso"), "susie")) + expect_false(pecotmr:::.jointTwasCvRequested(c("susie", "lasso"), "mrash")) + # the `_weights` spelling used by weightMethods lists + expect_true( + pecotmr:::.jointTwasCvRequested(c("susie_weights"), "susie") + ) + # and a named method list, not just a character vector + expect_true( + pecotmr:::.jointTwasCvRequested(list(lasso_weights = list()), "lasso") + ) + expect_false( + pecotmr:::.jointTwasCvRequested(list(lasso_weights = list()), "susie") + ) + # a multi-word token: `susie_inf_weights` strips to `susie_inf`, which is + # not the canonical `susieInf`, so suffix-stripping alone misses it + expect_true( + pecotmr:::.jointTwasCvRequested(c("susie_inf_weights"), "susieInf") + ) + expect_true( + pecotmr:::.jointTwasCvRequested( + list(susieInfWeights = list()), + "susieInf" + ) + ) + expect_false( + pecotmr:::.jointTwasCvRequested(c("susie_inf_weights"), "susie") + ) +}) + +test_that(".jointTwasCv skips a method excluded by cvWeightMethods", { + cfg <- list(cvFolds = 5L, cvWeightMethods = c("lasso")) + out <- pecotmr:::.jointTwasCv( + Xc = NULL, + Yc = NULL, + wm = NULL, + ma = NULL, + W = matrix(1, 2, 1), + args = list(), + cfg = cfg, + token = "susie" + ) + expect_null(out) +}) + +test_that(".jointTwasCv warns when a method is all-zero, not silently", { + cfg <- list(cvFolds = 5L, cvWeightMethods = NULL) + expect_warning( + out <- pecotmr:::.jointTwasCv( + Xc = NULL, + Yc = NULL, + wm = NULL, + ma = NULL, + W = matrix(0, 3, 1), + args = list(), + cfg = cfg, + token = "susie" + ), + "all of its weights are zero" + ) + expect_null(out) +}) + +test_that(".jointTwasCv refuses a fine-mapping method with no per-fold fits", { + # Without a CV handoff from the FineMappingResult there is no fold fit, + # and this layer never fine-maps -- so it refuses rather than re-fitting. + cfg <- list(cvFolds = 5L, cvWeightMethods = NULL) + expect_error( + pecotmr:::.jointTwasCv( + Xc = NULL, + Yc = NULL, + wm = NULL, + ma = NULL, + W = matrix(1, 3, 1), + args = list(), + cfg = cfg, + token = "susie" + ), + "needs each fold's own fine-mapping fit" + ) +}) + +test_that(".jointCvPartition lets the fine-mapping folds govern the group", { + sp <- data.frame( + Sample = c("s1", "s2", "s3", "s4"), + Fold = c(1L, 1L, 2L, 2L) + ) + ids <- c("s1", "s2", "s3", "s4") + # the fine-mapping CV's own partition is what every method is scored on + expect_equal( + pecotmr:::.jointCvPartition( + fmCv = list(samplePartition = sp), + userSp = NULL, + sampleIds = ids, + cvFolds = 2L + ), + sp + ) + # an identical explicit partition is no conflict + expect_equal( + pecotmr:::.jointCvPartition( + fmCv = list(samplePartition = sp), + userSp = sp, + sampleIds = ids, + cvFolds = 2L + ), + sp + ) + # with no fine-mapping CV the explicit partition still wins + expect_equal( + pecotmr:::.jointCvPartition( + fmCv = NULL, + userSp = sp, + sampleIds = ids, + cvFolds = 2L + ), + sp + ) + # and with neither, no partition is fixed here: an integer `cvFolds` only + # validates, leaving twasWeightsCv() to draw the folds downstream + expect_null( + pecotmr:::.jointCvPartition( + fmCv = NULL, + userSp = NULL, + sampleIds = ids, + cvFolds = 2L + ) + ) +}) + +test_that(".jointCvPartition rejects fold samples absent from the dataset", { + sp <- data.frame( + Sample = c("s1", "s2", "ghost1", "ghost2"), + Fold = c(1L, 1L, 2L, 2L) + ) + expect_error( + pecotmr:::.jointCvPartition( + fmCv = list(samplePartition = sp), + userSp = NULL, + sampleIds = c("s1", "s2", "s3"), + cvFolds = 2L + ), + "ghost1, ghost2" + ) +}) + +test_that(".jointCvPartition rejects a partition conflicting with the CV's", { + sp <- data.frame( + Sample = c("s1", "s2", "s3", "s4"), + Fold = c(1L, 1L, 2L, 2L) + ) + other <- data.frame( + Sample = c("s1", "s2", "s3", "s4"), + Fold = c(2L, 2L, 1L, 1L) + ) + expect_error( + pecotmr:::.jointCvPartition( + fmCv = list(samplePartition = sp), + userSp = other, + sampleIds = c("s1", "s2", "s3", "s4"), + cvFolds = 2L + ), + "differs from the fine-mapping" + ) +}) diff --git a/tests/testthat/test_jointSpecification.R b/tests/testthat/test_jointSpecification.R index feeb07cc..7fd3a42e 100644 --- a/tests/testthat/test_jointSpecification.R +++ b/tests/testthat/test_jointSpecification.R @@ -59,7 +59,7 @@ traits = c("ENSG1", "ENSG2") ) { phenos <- setNames( - lapply(contexts, function(cx) .js_makeSe(traits = traits)), + map(contexts, function(cx) .js_makeSe(traits = traits)), contexts ) QtlDataset( @@ -81,7 +81,7 @@ trait = traits, stringsAsFactors = FALSE ) - entries <- lapply(seq_len(nrow(rows)), function(i) { + entries <- map(seq_len(nrow(rows)), function(i) { gr <- GenomicRanges::GRanges( seqnames = "chr1", ranges = IRanges::IRanges(start = c(100L, 200L), width = 1L) @@ -718,7 +718,7 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") path = "/tmp/jd.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -803,7 +803,7 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") study = rows$study, context = rows$context, trait = rows$trait, - entry = lapply(seq_len(nrow(rows)), function(.) makeGr()), + entry = map(seq_len(nrow(rows)), function(.) makeGr()), genome = "hg19", ldSketch = .jd_makeHandle(), qcInfo = list(step1 = "ok") @@ -1113,7 +1113,7 @@ test_that("fineMappingPipeline(QtlSumStats): composed jointSpec rejects fsusie", traits = c("t1", "t2") ) { phen <- setNames( - lapply(contexts, function(.) .jd_makeSe(traits = traits)), + map(contexts, function(.) .jd_makeSe(traits = traits)), contexts ) QtlDataset( @@ -1573,7 +1573,7 @@ test_that("parseMethods: split-form and leaf validation errors", { caps = caps, multivariateMethods = "mrmash" ), - "non-empty character vector" + "Must have length >= 1" ) expect_error( pecotmr:::parseMethods( @@ -1584,7 +1584,7 @@ test_that("parseMethods: split-form and leaf validation errors", { caps = caps, multivariateMethods = "mrmash" ), - "non-empty character vector" + "Must have length >= 1" ) expect_error( pecotmr:::parseMethods( @@ -2323,7 +2323,7 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA }, .fmResidPheno = function(x, contexts, traitId = NULL, ...) { setNames( - lapply(c("c1", "c2"), function(.) { + map(c("c1", "c2"), function(.) { matrix( rnorm(12), 6, @@ -2593,7 +2593,7 @@ test_that(".twasMergeResultsByKey: a key absent from a later region contributes as.character(ss$context), "probe", ldSketch = getLdSketch(ss), - cutoffs = .panelCutoffs(list(...)) + cutoffs = .panelCutoffs(...) )) } diff --git a/tests/testthat/test_ld.R b/tests/testthat/test_ld.R index 7084e066..d471cb7a 100644 --- a/tests/testthat/test_ld.R +++ b/tests/testthat/test_ld.R @@ -202,7 +202,7 @@ test_that("partitionLdMatrix correctly partitions multiple blocks", { # Check if block IDs are correct expect_setequal( unique(partitioned$variantIndices$blockId), - 1:expected_block_count + seq_len(expected_block_count) ) file.remove(LD_meta_file_path) @@ -242,7 +242,7 @@ test_that("partitionLdMatrix properly merges small blocks", { ) # Check if merged blocks are larger than min_block_size - block_sizes <- sapply(partitioned$ldMatrices, nrow) + block_sizes <- map_int(partitioned$ldMatrices, nrow) expect_true(all( block_sizes >= min_block_size | block_sizes == length(getVariantIds(ld_data)) @@ -277,7 +277,7 @@ test_that("partitionLdMatrix respects max_merged_block_size", { ) # Check if no block exceeds max_block_size - block_sizes <- sapply(partitioned$ldMatrices, nrow) + block_sizes <- map_int(partitioned$ldMatrices, nrow) expect_true(all(block_sizes <= max_block_size)) file.remove(LD_meta_file_path) @@ -300,7 +300,7 @@ test_that("partitionLdMatrix handles empty matrix gracefully", { # Expect the S4 type-check error expect_error( partitionLdMatrix(empty_ld_data), - "ldData must be an LdData object" + "Assertion on 'ldData'.*Must inherit from class 'LdData'" ) }) @@ -1233,7 +1233,7 @@ test_that("extractBlockMatrices warns and skips out-of-range blocks", { result <- pecotmr:::extractBlockMatrices(mat, blockMetadata, vnames), "outside the range" ) - valid_blocks <- result$ldMatrices[!sapply(result$ldMatrices, is.null)] + valid_blocks <- compact(result$ldMatrices) expect_equal(length(valid_blocks), 1) expect_equal(nrow(valid_blocks[[1]]), 2) }) @@ -1312,7 +1312,7 @@ test_that("resolveLdSource detects precomputed from metadata", { test_that("resolveLdSource errors on missing file", { expect_error( pecotmr:::resolveLdSource("/nonexistent/file.tsv"), - "not found" + "LD metadata file: File does not exist" ) }) @@ -1949,7 +1949,7 @@ test_that("enforceDesignFullRank fallback to correlation pruning works", { X[, 3] + rnorm(n, sd = 1e-10), X[, 1] + X[, 2] + rnorm(n, sd = 1e-10) ) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(ncol(X)))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(ncol(X))) C <- matrix(rnorm(n), n, 1) result <- enforceDesignFullRank( X, @@ -1994,7 +1994,7 @@ test_that("ldClumpByScore errors on mismatched score length", { X <- matrix(rnorm(20), 5, 4) expect_error( ldClumpByScore(X, score = c(1, 2), chr = rep(1L, 4), pos = 1:4), - "length\\(score\\)" + "score.*Must have length 4" ) }) @@ -2004,7 +2004,7 @@ test_that("ldClumpByScore errors on mismatched chr/pos length", { X <- matrix(rnorm(20), 5, 4) expect_error( ldClumpByScore(X, score = runif(4), chr = rep(1L, 2), pos = 1:4), - "chr and pos" + "chr.*Must have length 4" ) }) @@ -2096,7 +2096,7 @@ test_that("ldPruneByCorrelation removes highly correlated columns", { n <- 50 p <- 10 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:p)) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) X[, 2] <- X[, 1] + rnorm(n, sd = 0.01) result <- ldPruneByCorrelation(X, corThres = 0.9) expect_true(ncol(result$X.new) < p) @@ -2108,10 +2108,10 @@ test_that("ldPruneByCorrelation keeps all columns when uncorrelated", { n <- 100 p <- 5 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:p)) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) result <- ldPruneByCorrelation(X, corThres = 0.99) expect_equal(ncol(result$X.new), p) - expect_equal(result$filter.id, 1:p) + expect_equal(result$filter.id, seq_len(p)) }) test_that("ldPruneByCorrelation preserves colnames for single remaining column", { @@ -2139,7 +2139,7 @@ test_that("ldPruneByCorrelation strict threshold removes at least as many as len n <- 100 p <- 5 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:p)) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) X[, 2] <- X[, 1] + rnorm(n, sd = 0.1) X[, 3] <- X[, 1] + rnorm(n, sd = 0.1) X[, 5] <- X[, 4] + rnorm(n, sd = 0.1) @@ -2391,7 +2391,7 @@ test_that("ldClumpByScore validates input lengths", { chr = rep(1L, 2), pos = seq_len(3) * 1000L ), - "chr and pos" + "chr.*Must have length 3" ) }) @@ -3703,7 +3703,7 @@ test_that("extractBlockMatrices skips blocks where endIdx < startIdx", { stringsAsFactors = FALSE ) result <- pecotmr:::extractBlockMatrices(mat, bm, vnames) - valid <- result$ldMatrices[!sapply(result$ldMatrices, is.null)] + valid <- compact(result$ldMatrices) expect_length(valid, 1) expect_equal(nrow(valid[[1]]), 2L) }) @@ -3720,7 +3720,7 @@ test_that("ldPruneByCorrelation snprelate backend prunes correlated columns", { p <- 6 X <- matrix(rbinom(n * p, 2, 0.3), n, p) X[, 2] <- X[, 1] # perfect LD between columns 1 and 2 - colnames(X) <- paste0("snp", 1:p) + colnames(X) <- paste0("snp", seq_len(p)) result <- suppressMessages( ldPruneByCorrelation( X, @@ -3906,7 +3906,10 @@ test_that("ldClumpByScore accepts a pre-built FBM and reports retained count (ve # ============================================================================= test_that("extractLdMatrix errors on non-LdData input", { - expect_error(pecotmr:::extractLdMatrix(list()), "must be an LdData object") + expect_error( + pecotmr:::extractLdMatrix(list()), + "Must inherit from class 'LdData'" + ) }) test_that("extractLdMatrix returns the genotype matrix when wantGenotype=TRUE", { @@ -4026,7 +4029,7 @@ test_that("ldPruneByCorrelation and computeLd fall back to base cor() when Rfast set.seed(11) nS <- 100L af <- c(rep(0.35, 5L), rep(0.004, 5L)) - d <- vapply(af, function(f) rbinom(nS, 2L, f), numeric(nS)) + d <- exec(cbind, !!!map(af, function(f) rbinom(nS, 2L, f))) colnames(d) <- sprintf("chr1:%d:A:G", 1000L * seq_along(af)) d[1:80, 2] <- NA d @@ -4139,14 +4142,14 @@ test_that(".panelVariantFilter handles empty and NULL input", { test_that(".panelCutoffs short-circuits when no cutoff is set", { # NULL means the panel is never touched, which is what keeps the default # path free of an extra dosage read. - expect_null(.panelCutoffs(list())) - expect_null(.panelCutoffs(list( + expect_null(.panelCutoffs()) + expect_null(.panelCutoffs( mafCutoff = 0, macCutoff = 0, imissCutoff = 1 - ))) - expect_equal(.panelCutoffs(list(mafCutoff = 0.01))$mafCutoff, 0.01) - expect_equal(.panelCutoffs(list(imissCutoff = 0.5))$imissCutoff, 0.5) + )) + expect_equal(.panelCutoffs(mafCutoff = 0.01)$mafCutoff, 0.01) + expect_equal(.panelCutoffs(imissCutoff = 0.5)$imissCutoff, 0.5) }) @@ -4925,10 +4928,19 @@ test_that("computeLd(onDisk) applies shrinkage toward the identity", { format = "gds" ) idx <- 1:6 - plain <- computeLd(handle, snpIdx = idx, backend = "snprelate", - onDisk = TRUE) - shrunk <- computeLd(handle, snpIdx = idx, backend = "snprelate", - onDisk = TRUE, shrinkage = 0.5) + plain <- computeLd( + handle, + snpIdx = idx, + backend = "snprelate", + onDisk = TRUE + ) + shrunk <- computeLd( + handle, + snpIdx = idx, + backend = "snprelate", + onDisk = TRUE, + shrinkage = 0.5 + ) # (1 - s) * R + s * I: off-diagonals halve, the diagonal stays 1. expect_equal(unname(diag(shrunk)), rep(1, length(idx))) expect_equal( diff --git a/tests/testthat/test_ldData.R b/tests/testthat/test_ldData.R index 7373effd..cfb85d4e 100644 --- a/tests/testthat/test_ldData.R +++ b/tests/testthat/test_ldData.R @@ -10,7 +10,7 @@ context("LdData accessors") path = path, format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -34,7 +34,7 @@ context("LdData accessors") S4Vectors::mcols(gr) <- S4Vectors::DataFrame( A1 = rep("A", snp_n), A2 = rep("G", snp_n), - variant_id = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))) + variant_id = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)) ) gr } @@ -153,7 +153,7 @@ test_that("getCorrelation: mixture handles produce a weighted-average R", { }, .package = "pecotmr" ) - R_each <- lapply(list(gh1, gh2), function(h) { + R_each <- map(list(gh1, gh2), function(h) { geno <- extractBlockGenotypes(h, 1:4) Xt <- t(SummarizedExperiment::assay(geno, "dosage")) computeLd(Xt, method = "sample") diff --git a/tests/testthat/test_manifestLoaders.R b/tests/testthat/test_manifestLoaders.R index 0c7cf008..7b788e0c 100644 --- a/tests/testthat/test_manifestLoaders.R +++ b/tests/testthat/test_manifestLoaders.R @@ -87,7 +87,7 @@ test_that(".canonManifestCols errors on missing required columns", { required = c("study", "sumStatsPath"), label = "GwasSumStats" ), - "missing required column" + "manifest.*Colnames must include the elements" ) }) @@ -829,10 +829,13 @@ test_that(".readManifest handles CSV, missing files, and bad input", { readr::write_csv(data.frame(study = "s1", sumStatsPath = ssPath), csv) m <- pecotmr:::.readManifest(csv) expect_true(is.data.frame(m) && m$study == "s1") - expect_error(pecotmr:::.readManifest("/no/such/manifest.tsv"), "not found") + expect_error( + pecotmr:::.readManifest("/no/such/manifest.tsv"), + "File does not exist" + ) expect_error( pecotmr:::.readManifest(42L), - "data.frame or a single file path" + "Must be of type 'string'" ) }) @@ -1041,7 +1044,10 @@ test_that(".asGRegion coerces strings, GRanges, and data.frames", { test_that(".readColumnMapping errors on bad inputs", { tmp <- withr::local_tempdir() - expect_error(pecotmr:::.readColumnMapping("/no/map.yaml"), "not found") + expect_error( + pecotmr:::.readColumnMapping("/no/map.yaml"), + "File does not exist" + ) bad <- file.path(tmp, "bad.yaml") yaml::write_yaml(list("a", "b"), bad) # unnamed sequence expect_error(pecotmr:::.readColumnMapping(bad), "standardName: sourceName") @@ -1264,7 +1270,7 @@ test_that("QtlDataset builder errors on inconsistent per-context paths", { collapse = "\t" ) ) - rows <- vapply( + rows <- map_chr( seq_len(n), function(i) { vals <- c( @@ -1291,8 +1297,7 @@ test_that("QtlDataset builder errors on inconsistent per-context paths", { ), collapse = "\t" ) - }, - character(1) + } ) writeLines(c(meta, rows), path) path @@ -1745,8 +1750,11 @@ test_that(".readTabixRegion returns a bare tibble for a headerless file", { dir <- withr::local_tempdir() plain <- file.path(dir, "noheader.tsv") writeLines(c("chr1\t100\t200\tA", "chr1\t300\t400\tB"), plain) - bgz <- Rsamtools::bgzip(plain, file.path(dir, "noheader.tsv.bgz"), - overwrite = TRUE) + bgz <- Rsamtools::bgzip( + plain, + file.path(dir, "noheader.tsv.bgz"), + overwrite = TRUE + ) Rsamtools::indexTabix(bgz, seq = 1L, start = 2L, end = 3L) # With no "#" header line there are no column names to build an empty # frame from, so the miss returns a column-less tibble. @@ -1756,3 +1764,41 @@ test_that(".readTabixRegion returns a bare tibble for a headerless file", { expect_equal(nrow(out), 0L) expect_equal(ncol(out), 0L) }) + +test_that("manifest loaders guard the QtlDataset pass-through arguments", { + mf <- system.file("extdata", "manifests", package = "pecotmr") + skip_if(mf == "", "manifest fixtures unavailable") + expect_error( + loadQtlDatasetFromManifest(data.frame(), mafCutoff = -1), + "mafCutoff.*is not >= 0" + ) + expect_error( + loadQtlDatasetFromManifest(data.frame(), keepIndel = NA), + "keepIndel.*May not be NA" + ) + expect_error( + loadQtlDatasetFromManifest( + data.frame(), + scaleResiduals = c(TRUE, TRUE) + ), + "scaleResiduals.*Must have length 1" + ) + expect_error( + loadQtlDatasetFromManifest(data.frame(), study = 1L), + "study.*Must be of type 'string'" + ) + expect_error( + loadMultiStudyQtlDatasetFromManifest( + data.frame(), + minLdOverlapWarn = 2 + ), + "minLdOverlapWarn.*is not <= 1" + ) + expect_error( + loadMultiStudyQtlDatasetFromManifest( + data.frame(), + xvarCutoff = -1 + ), + "xvarCutoff.*is not >= 0" + ) +}) diff --git a/tests/testthat/test_mashPipeline.R b/tests/testthat/test_mashPipeline.R index 09b9a690..6eaa3e88 100644 --- a/tests/testthat/test_mashPipeline.R +++ b/tests/testthat/test_mashPipeline.R @@ -239,10 +239,9 @@ test_that("updateMashModelCov drops dropped conditions + resizes remaining cov m samples = c("brain", "blood") ) expect_false("muscle" %in% names(m2$fitted_g$Ulist)) - expect_true(all(vapply( + expect_true(all(map_lgl( m2$fitted_g$Ulist, - function(x) all(dim(x) == c(2L, 2L)), - logical(1) + function(x) all(dim(x) == c(2L, 2L)) ))) expect_false(any(grepl("muscle", names(m2$fitted_g$pi)))) # Brain matrix has a single 1 at the brain position (the first of the @@ -333,8 +332,7 @@ test_that("fitMashContrast: 3-tested-conditions yields deviation + pairwise cont test_that("mashPipeline runs end-to-end on qtlSumStatsMulticontextExample", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() # Use the same fixture for strong/random; nPcs <= ncol - 1 (3 contexts). res <- suppressMessages(suppressWarnings( mashPipeline( @@ -348,10 +346,9 @@ test_that("mashPipeline runs end-to-end on qtlSumStatsMulticontextExample", { expect_type(res$U, "list") expect_gt(length(res$U), 0L) # Every covariance matrix is 3x3 (one row/col per context) - expect_true(all(vapply( + expect_true(all(map_lgl( res$U, - function(m) all(dim(m) == c(3L, 3L)), - logical(1) + function(m) all(dim(m) == c(3L, 3L)) ))) expect_type(res$w, "double") expect_equal(sum(res$w), 1, tolerance = 1e-6) @@ -495,8 +492,7 @@ test_that("mashPipeline coerces a SimpleList before validating its names", { test_that("mashPipeline rejects priorCovariances not a non-empty named list", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() vhat <- diag(3) # Empty list. expect_error( @@ -527,8 +523,7 @@ test_that("mashPipeline rejects priorCovariances not a non-empty named list", { test_that("mashPipeline rejects priorCovariances with wrong dimensions", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() vhat <- diag(3) expect_error( suppressMessages(suppressWarnings( @@ -546,8 +541,7 @@ test_that("mashPipeline rejects priorCovariances with wrong dimensions", { test_that("mashPipeline passes supplied residualCorrelation + priorCovariances through", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() vhat <- diag(3) U0 <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) res <- suppressMessages(suppressWarnings( @@ -573,8 +567,7 @@ test_that("mashPipeline passes supplied residualCorrelation + priorCovariances t test_that("mashPipeline estimates Vhat from a null set and defaults nPcs", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() # `residualCorrelationMethod = "simple"` runs # estimate_null_correlation_simple on the null set; leaving nPcs NULL # exercises the `nPcs <- ncol(Bhat) - 1` default in the cov_* chain. @@ -588,10 +581,9 @@ test_that("mashPipeline estimates Vhat from a null set and defaults nPcs", { )) expect_named(res, c("U", "w")) expect_gt(length(res$U), 0L) - expect_true(all(vapply( + expect_true(all(map_lgl( res$U, - function(m) all(dim(m) == c(3L, 3L)), - logical(1) + function(m) all(dim(m) == c(3L, 3L)) ))) expect_equal(sum(res$w), 1, tolerance = 1e-6) }) @@ -607,42 +599,47 @@ test_that("mashPipeline estimates Vhat from a null set and defaults nPcs", { test_that("the default is identity regardless of which partitions are given", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() + prior <- mashTinyPrior() # The default must not depend on data shape -- that was the old silent - # behaviour this argument replaced. + # behaviour this argument replaced. `w` is what carries the evidence: it + # is fitted against V, so an identical `w` across the three calls is the + # same V reaching mash() each time. (`U` is the supplied prior passed + # through, so comparing it would prove nothing here.) withNull <- suppressMessages(suppressWarnings(mashPipeline( list(strong = ss, random = ss, null = ss), alpha = 0, + priorCovariances = prior, setSeed = 1L ))) withoutNull <- suppressMessages(suppressWarnings(mashPipeline( list(strong = ss, random = ss), alpha = 0, + priorCovariances = prior, setSeed = 1L ))) explicit <- suppressMessages(suppressWarnings(mashPipeline( list(strong = ss, random = ss, null = ss), alpha = 0, residualCorrelationMethod = "identity", + priorCovariances = prior, setSeed = 1L ))) - expect_equal(withNull$U, withoutNull$U) expect_equal(withNull$w, withoutNull$w) - expect_equal(withNull$U, explicit$U) + expect_equal(withNull$w, explicit$w) }) test_that("an unused null partition is reported", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() # Assembling a null set and still getting identity is more often an # oversight than an intent, so it must not pass silently. expect_message( suppressWarnings(mashPipeline( list(strong = ss, random = ss, null = ss), alpha = 0, + priorCovariances = mashTinyPrior(), setSeed = 1L )), "does not use it" @@ -653,6 +650,7 @@ test_that("an unused null partition is reported", { list(strong = ss, random = ss, null = ss), alpha = 0, residualCorrelationMethod = "identity", + priorCovariances = mashTinyPrior(), setSeed = 1L )), "'null' partition" @@ -662,12 +660,12 @@ test_that("an unused null partition is reported", { test_that("no unused-null notice when there is nothing to ignore", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() noNull <- function() { suppressWarnings(mashPipeline( list(strong = ss, random = ss), alpha = 0, + priorCovariances = mashTinyPrior(), setSeed = 1L )) } @@ -678,6 +676,7 @@ test_that("no unused-null notice when there is nothing to ignore", { list(strong = ss, random = ss, null = ss), alpha = 0, residualCorrelationMethod = "simple", + priorCovariances = mashTinyPrior(), setSeed = 1L )) } @@ -687,19 +686,21 @@ test_that("no unused-null notice when there is nothing to ignore", { test_that("mashPipeline honours a data-driven residualCorrelationMethod", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() sl <- list(strong = ss, random = ss, null = ss) + prior <- mashTinyPrior() identityFit <- suppressMessages(suppressWarnings(mashPipeline( sl, alpha = 0, residualCorrelationMethod = "identity", + priorCovariances = prior, setSeed = 1L ))) simpleFit <- suppressMessages(suppressWarnings(mashPipeline( sl, alpha = 0, residualCorrelationMethod = "simple", + priorCovariances = prior, setSeed = 1L ))) # A different V has to move the fit, or the argument is not reaching it. @@ -707,8 +708,7 @@ test_that("mashPipeline honours a data-driven residualCorrelationMethod", { }) test_that("mashPipeline rejects an unknown residualCorrelationMethod", { - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashPipeline( list(strong = ss, random = ss), @@ -721,8 +721,7 @@ test_that("mashPipeline rejects an unknown residualCorrelationMethod", { test_that("a method needing a partition it lacks errors through mashPipeline", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashPipeline( list(strong = ss, random = ss), @@ -736,8 +735,7 @@ test_that("a method needing a partition it lacks errors through mashPipeline", { test_that("a supplied residualCorrelation wins over the method", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() # 'simple' would error without a null set; the supplied matrix means the # estimator is never consulted. res <- suppressMessages(suppressWarnings(mashPipeline( @@ -745,6 +743,7 @@ test_that("a supplied residualCorrelation wins over the method", { alpha = 0, residualCorrelation = diag(3), residualCorrelationMethod = "simple", + priorCovariances = mashTinyPrior(), setSeed = 1L ))) expect_named(res, c("U", "w")) @@ -756,8 +755,7 @@ test_that("a supplied residualCorrelation wins over the method", { test_that("mashResidualCorrelation(identity) is an identity of the right size", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() v <- mashResidualCorrelation( list(strong = ss), alpha = 0, @@ -769,8 +767,7 @@ test_that("mashResidualCorrelation(identity) is an identity of the right size", test_that("mashResidualCorrelation(simple) returns a null correlation matrix", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() v <- suppressMessages(suppressWarnings( mashResidualCorrelation( list(strong = ss, null = ss), @@ -785,8 +782,7 @@ test_that("mashResidualCorrelation(simple) returns a null correlation matrix", { test_that("mashResidualCorrelation(simple) errors without a null entry", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashResidualCorrelation( list(strong = ss), @@ -799,8 +795,7 @@ test_that("mashResidualCorrelation(simple) errors without a null entry", { test_that("mashResidualCorrelation(simpleSpecific) returns a null correlation", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() v <- suppressMessages(suppressWarnings( mashResidualCorrelation( list(strong = ss, null = ss), @@ -815,8 +810,7 @@ test_that("mashResidualCorrelation(simpleSpecific) returns a null correlation", test_that("mashResidualCorrelation(corshrink) returns a 3x3 correlation matrix", { skip_if_not_installed("mashr") skip_if_not_installed("CorShrink") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() v <- suppressMessages(suppressWarnings( mashResidualCorrelation( list(strong = ss, null = ss), @@ -830,8 +824,7 @@ test_that("mashResidualCorrelation(corshrink) returns a 3x3 correlation matrix", test_that("mashResidualCorrelation(mle) refines V against a supplied prior", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() v <- suppressMessages(suppressWarnings( mashResidualCorrelation( list(strong = ss, random = ss), @@ -848,8 +841,7 @@ test_that("mashResidualCorrelation(mle) refines V against a supplied prior", { test_that("mashResidualCorrelation errors when a method's inputs are missing", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashResidualCorrelation( list(strong = ss), @@ -877,8 +869,7 @@ test_that("mashResidualCorrelation errors when a method's inputs are missing", { test_that("mashPriorCovariances computes the default (all-but-udr) prior", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() pc <- suppressMessages(suppressWarnings( mashPriorCovariances( list(strong = ss), @@ -890,10 +881,9 @@ test_that("mashPriorCovariances computes the default (all-but-udr) prior", { )) expect_named(pc, c("U", "w", "loglik")) expect_gt(length(pc$U), 0L) - expect_true(all(vapply( + expect_true(all(map_lgl( pc$U, - function(m) all(dim(m) == c(3L, 3L)), - logical(1) + function(m) all(dim(m) == c(3L, 3L)) ))) expect_equal(sum(pc$w), 1, tolerance = 1e-6) expect_null(pc$loglik) @@ -902,8 +892,7 @@ test_that("mashPriorCovariances computes the default (all-but-udr) prior", { test_that("mashPriorCovariances passes a supplied prior through unchanged", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() U0 <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) pc <- suppressMessages(suppressWarnings( mashPriorCovariances( @@ -920,8 +909,7 @@ test_that("mashPriorCovariances passes a supplied prior through unchanged", { test_that("mashPriorCovariances validates a supplied prior", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( suppressMessages(suppressWarnings( mashPriorCovariances( @@ -949,8 +937,7 @@ test_that("mashPriorCovariances validates a supplied prior", { test_that("mashPriorCovariances(flashNonneg) adds components vs flash-only", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() base <- suppressMessages(suppressWarnings( mashPriorCovariances( list(strong = ss), @@ -978,8 +965,7 @@ test_that("mashPriorCovariances engine 'ud' (udr) produces U + weights", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") skip_if_not_installed("udr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() # A toy-sized udr config: `n_unconstrained` dominates the cost, and the default # (50, sized for many-condition data) is pathological on a 3-condition fixture # (it drove a 5+ minute fit). 2 unconstrained matrices suffice to exercise the @@ -995,10 +981,9 @@ test_that("mashPriorCovariances engine 'ud' (udr) produces U + weights", { ) )) expect_gt(length(pc$U), 0L) - expect_true(all(vapply( + expect_true(all(map_lgl( pc$U, - function(m) all(dim(m) == c(3L, 3L)), - logical(1) + function(m) all(dim(m) == c(3L, 3L)) ))) expect_equal(sum(pc$w), 1, tolerance = 1e-6) }) @@ -1007,8 +992,7 @@ test_that("mashPriorCovariances engine 'ud_ted' errors clearly on non-i.i.d. dat skip_if_not_installed("mashr") skip_if_not_installed("flashier") skip_if_not_installed("udr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( suppressMessages(suppressWarnings( mashPriorCovariances( @@ -1026,8 +1010,7 @@ test_that("mashPriorCovariances engine 'ud_ted' errors clearly on non-i.i.d. dat test_that("mashPriorCovariances rejects an unknown component", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashPriorCovariances( list(strong = ss), @@ -1046,8 +1029,7 @@ test_that("mashPriorCovariances rejects an unknown component", { test_that("mashCovarianceComponents builds a single requested component", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() fl <- suppressMessages(suppressWarnings( mashCovarianceComponents( list(strong = ss), @@ -1058,18 +1040,16 @@ test_that("mashCovarianceComponents builds a single requested component", { ) )) expect_gt(length(fl), 0L) - expect_true(all(vapply( + expect_true(all(map_lgl( fl, - function(m) all(dim(m) == c(3L, 3L)), - logical(1) + function(m) all(dim(m) == c(3L, 3L)) ))) }) test_that("mashCovarianceComponents default builds all non-udr components", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() one <- suppressMessages(suppressWarnings( mashCovarianceComponents( list(strong = ss), @@ -1094,8 +1074,7 @@ test_that("mashCovarianceComponents default builds all non-udr components", { test_that("mashCovarianceComponents feeds mashPriorCovariances (same components)", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() comps <- suppressMessages(suppressWarnings( mashCovarianceComponents( list(strong = ss), @@ -1121,8 +1100,7 @@ test_that("mashCovarianceComponents feeds mashPriorCovariances (same components) test_that("mashCovarianceComponents rejects unknown components", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashCovarianceComponents( list(strong = ss), @@ -1136,8 +1114,7 @@ test_that("mashCovarianceComponents rejects unknown components", { test_that("mashPriorCovariances refines supplied priorComponents (pipeline mode)", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() comps <- suppressMessages(suppressWarnings( mashCovarianceComponents( list(strong = ss), @@ -1165,8 +1142,7 @@ test_that("mashPriorCovariances refines supplied priorComponents (pipeline mode) test_that("mashPriorCovariances validates priorComponents", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashPriorCovariances( list(strong = ss), @@ -1180,8 +1156,7 @@ test_that("mashPriorCovariances validates priorComponents", { test_that("mashPipeline result == composing the two extracted building blocks", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() full <- suppressMessages(suppressWarnings( mashPipeline( list(strong = ss, random = ss, null = ss), @@ -1233,8 +1208,7 @@ test_that("mashPipeline result == composing the two extracted building blocks", test_that("mashModelFit returns a fitted mash model", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() m <- .mashTestModel(ss) expect_s3_class(m, "mash") expect_false(is.null(m$fitted_g)) @@ -1242,8 +1216,7 @@ test_that("mashModelFit returns a fitted mash model", { test_that("mashModelFit validates the prior and the fitOn entry", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashModelFit(list(random = ss), alpha = 0, priorCovariances = list()), "non-empty named list" @@ -1285,8 +1258,7 @@ test_that(".mashAsUlist does not mistake a covariance named U for the wrapper", test_that("mashModelFit accepts either prior shape and fits identically", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() ulist <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) wrapped <- list(U = ulist, w = NULL, loglik = NULL) @@ -1304,8 +1276,7 @@ test_that("mashModelFit accepts either prior shape and fits identically", { test_that("mashPriorCovariances accepts either shape for its two prior args", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() sl <- list(strong = ss, random = ss) ulist <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) wrapped <- list(U = ulist, w = NULL, loglik = NULL) @@ -1328,8 +1299,7 @@ test_that("mashPriorCovariances accepts either shape for its two prior args", { test_that("mashPosterior returns posterior matrices with covariance", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() post <- suppressMessages(suppressWarnings( mashPosterior(.mashTestModel(ss), ss, alpha = 0, vhat = diag(3)) )) @@ -1343,8 +1313,7 @@ test_that("mashPosterior returns posterior matrices with covariance", { test_that("mashPosterior outputPosteriorCov = FALSE omits PosteriorCov", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() post <- suppressMessages(suppressWarnings( mashPosterior( .mashTestModel(ss), @@ -1360,8 +1329,7 @@ test_that("mashPosterior outputPosteriorCov = FALSE omits PosteriorCov", { test_that("mashPosterior(excludeCondition) drops the condition from model + output", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() conds <- colnames(.mashSumStatsToMatrices(ss, "strong")$b) post <- suppressMessages(suppressWarnings( mashPosterior( @@ -1378,8 +1346,7 @@ test_that("mashPosterior(excludeCondition) drops the condition from model + outp test_that("mashPosterior errors on an unknown excludeCondition", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashPosterior( .mashTestModel(ss), @@ -1394,8 +1361,7 @@ test_that("mashPosterior errors on an unknown excludeCondition", { test_that("fitMashContrast consumes a mashPosterior result", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() post <- suppressMessages(suppressWarnings( mashPosterior(.mashTestModel(ss), ss, alpha = 0, vhat = diag(3)) )) @@ -1672,8 +1638,7 @@ test_that("mashPosteriorContrast: empty frame when every feature is dropped", { test_that("mashResidualCorrelation(mle): errors without a 'random' entry", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashResidualCorrelation(list(strong = ss), alpha = 0, method = "mle"), "requires a 'random' entry" @@ -1682,8 +1647,7 @@ test_that("mashResidualCorrelation(mle): errors without a 'random' entry", { test_that("mashResidualCorrelation accepts a SimpleList sumStatsList", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() V <- suppressMessages(suppressWarnings( mashResidualCorrelation( S4Vectors::SimpleList(null = ss), @@ -1696,8 +1660,7 @@ test_that("mashResidualCorrelation accepts a SimpleList sumStatsList", { test_that("mashCovarianceComponents: SimpleList input + default (NULL) vhat", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() cc <- suppressMessages(suppressWarnings( mashCovarianceComponents( S4Vectors::SimpleList(strong = ss), @@ -1711,8 +1674,7 @@ test_that("mashCovarianceComponents: SimpleList input + default (NULL) vhat", { test_that("mashPriorCovariances: SimpleList input (canonical only)", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() pc <- suppressMessages(suppressWarnings( mashPriorCovariances( S4Vectors::SimpleList(strong = ss), @@ -1726,8 +1688,7 @@ test_that("mashPriorCovariances: SimpleList input (canonical only)", { test_that("mashModelFit: SimpleList input + default (NULL) vhat", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() m <- suppressMessages(suppressWarnings( mashModelFit( S4Vectors::SimpleList(random = ss), @@ -1741,8 +1702,7 @@ test_that("mashModelFit: SimpleList input + default (NULL) vhat", { test_that("mashPosterior: default (NULL) vhat and excludeCondition dropping every condition", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() model <- .mashTestModel(ss) conds <- colnames(.mashSumStatsToMatrices(ss, "strong")$b) # NULL vhat path: omit vhat so mashPosterior fills the identity default. @@ -1791,14 +1751,19 @@ test_that("contrast rows fall back to the positional index when unnamed", { test_that(".mashUdFit re-raises an unrelated udr failure unchanged", { skip_if_not_installed("udr") - local_mocked_bindings(.mashUdControl = function(...) list(), - .package = "pecotmr") + local_mocked_bindings( + .mashUdControl = function(...) list(), + .package = "pecotmr" + ) # Only the ud_ted i.i.d. incompatibility is rewrapped; anything else must # surface as itself rather than being swallowed into a NULL fit. expect_error( with_mocked_bindings( pecotmr:::.mashUdFit( - NULL, list(Bhat = matrix(0, 2L, 2L)), "ud_ted", list() + NULL, + list(Bhat = matrix(0, 2L, 2L)), + "ud_ted", + list() ), ud_fit = function(...) stop("totally unrelated failure"), .package = "udr" @@ -1806,3 +1771,36 @@ test_that(".mashUdFit re-raises an unrelated udr failure unchanged", { "totally unrelated failure" ) }) + +test_that("mashPipeline helpers: argument guards fire", { + expect_error( + fitMashContrast( + 0L, + matrix(0, 2, 2), + matrix(0, 2, 2), + array(0, c(2, 2, 2)) + ), + "index.*Must be >= 1" + ) + expect_error( + updateMashModelCov(list(), allSamples = 1L, samples = "a"), + "allSamples.*Must be of type 'character'" + ) + expect_error( + sliceMashData("not-a-list", vhat = diag(2), snps = 1L, samples = NULL), + "data.*Must be of type 'list'" + ) + expect_error( + calculateFeatureScores(data.frame(), metaMethod = 1L), + "metaMethod.*Must be of type 'string'" + ) + expect_error( + nSignificantScore(data.frame(), pCutoff = 2), + "pCutoff.*is not <= 1" + ) + expect_error( + makePairwiseContrastCol(c("a", "b", "c"), template = c(a = 0)), + "pair.*Must have length 2" + ) + expect_error(sanitizeMashData("nope"), "data.*Must be of type 'list'") +}) diff --git a/tests/testthat/test_mashWrapper.R b/tests/testthat/test_mashWrapper.R index f678c030..d2339611 100644 --- a/tests/testthat/test_mashWrapper.R +++ b/tests/testthat/test_mashWrapper.R @@ -941,7 +941,7 @@ test_that("filterMixtureComponents subsets conditions", { path = "/tmp/sketch.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(nSnp))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(nSnp)), CHR = "1", BP = seq(100L, by = 100L, length.out = nSnp), A1 = "A", @@ -959,7 +959,7 @@ test_that("filterMixtureComponents subsets conditions", { width = 1L ) ) - entries <- lapply(seq_along(contexts), function(i) { + entries <- map(seq_along(contexts), function(i) { gr <- ranges S4Vectors::mcols(gr) <- S4Vectors::DataFrame(mcolsBuilder(i, nSnp)) gr @@ -978,7 +978,7 @@ test_that("filterMixtureComponents subsets conditions", { test_that(".mashSumStatsToMatrices: auto picks BETA+SE when present", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), A1 = "A", A2 = "G", Z = rnorm(n), @@ -995,7 +995,7 @@ test_that(".mashSumStatsToMatrices: auto picks BETA+SE when present", { test_that(".mashSumStatsToMatrices: auto falls back to Z when no BETA/SE", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), A1 = "A", A2 = "G", Z = rnorm(n) @@ -1009,7 +1009,7 @@ test_that(".mashSumStatsToMatrices: auto falls back to Z when no BETA/SE", { test_that(".mashSumStatsToMatrices: inputScale='beta' errors when BETA missing", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), A1 = "A", A2 = "G", Z = rnorm(n) @@ -1024,7 +1024,7 @@ test_that(".mashSumStatsToMatrices: inputScale='beta' errors when BETA missing", test_that(".mashSumStatsToMatrices: inputScale='z' forces Z+1 even when BETA present", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), A1 = "A", A2 = "G", Z = rnorm(n), @@ -1040,7 +1040,7 @@ test_that(".mashSumStatsToMatrices: inputScale='z' forces Z+1 even when BETA pre test_that(".mashSumStatsToMatrices: errors when no usable scale", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), A1 = "A", A2 = "G", N = rep(1000L, n) @@ -1055,7 +1055,7 @@ test_that(".mashSumStatsToMatrices: errors when no usable scale", { test_that(".mashSumStatsToMatrices: inputScale='z' errors when Z missing", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), A1 = "A", A2 = "G", BETA = rnorm(n, sd = 0.1), @@ -1119,7 +1119,7 @@ test_that(".mashObjectMatrices warns and pins the first method on a multi-method test_that(".mashObjectPartitions errors when < 2 conditions remain after excludeCondition", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), A1 = "A", A2 = "G", BETA = rnorm(n, sd = 0.1), @@ -1143,7 +1143,7 @@ test_that(".mashObjectPartitions errors when < 2 conditions remain after exclude test_that(".mashObjectPartitions warns when no variants match the independent-variant list", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), A1 = "A", A2 = "G", BETA = rnorm(n, sd = 0.1), @@ -2053,3 +2053,27 @@ test_that(".qtlSumStatsFromMatrix synthesises coords for unparseable ids", { expect_equal(as.character(GenomicRanges::seqnames(gr)), c("chr1", "chr1")) expect_equal(GenomicRanges::start(gr), c(1L, 2L)) }) + +test_that("mashWrapper: argument guards fire", { + expect_error( + filterInvalidSummaryStat("not-a-list"), + "datList.*Must be of type 'list'" + ) + expect_error( + filterInvalidSummaryStat(list(), sigPCutoff = 2), + "sigPCutoff.*is not <= 1" + ) + expect_error( + filterInvalidSummaryStat(list(), filterByMissingRate = -1), + "filterByMissingRate.*is not >= 0" + ) + expect_error( + filterMixtureComponents(conditionsToKeep = 1L, U = list()), + "conditionsToKeep.*Must be of type 'character'" + ) + expect_error( + filterMixtureComponents("a", U = list(), wCutoff = -1), + "wCutoff.*is not >= 0" + ) + expect_error(mergeMashData("nope", list()), "Must be of type 'list'") +}) diff --git a/tests/testthat/test_pvalCombine.R b/tests/testthat/test_pvalCombine.R index d8af516d..cdd4869f 100644 --- a/tests/testthat/test_pvalCombine.R +++ b/tests/testthat/test_pvalCombine.R @@ -143,10 +143,9 @@ test_that("combinePValues: runs multiple methods at once", { p <- c(0.01, 0.1, 0.4) res <- combinePValues(pvals = p, methods = c("acat", "bonferroni")) expect_equal(names(res$results), c("acat", "bonferroni")) - expect_true(all(vapply( + expect_true(all(map_lgl( res$results, - function(r) is.finite(r$pval), - logical(1) + function(r) is.finite(r$pval) ))) }) @@ -234,7 +233,7 @@ test_that("pvalAcat returns NA when the Cauchy statistic is non-finite", { test_that(".combinePvalAlignR rejects a non-matrix R", { expect_error( pecotmr:::.combinePvalAlignR(5, c("a", "b")), - "must be a matrix" + "Must be of type 'matrix'" ) }) @@ -580,3 +579,13 @@ test_that("waldTestPval with very large se gives p near 1", { # ============================================================================= # parseRegion # ============================================================================= + +test_that("pvalCombine: argument guards fire", { + expect_error(waldTestPval("a", 1, 10), "beta.*Must be of type 'numeric'") + expect_error(waldTestPval(1, "a", 10), "se.*Must be of type 'numeric'") + expect_error(waldTestPval(1, 1, "a"), "n.*Must be of type 'numeric'") + expect_error( + combinePValues(pvals = 0.5, methods = "fisher", naRm = NA), + "naRm.*May not be NA" + ) +}) diff --git a/tests/testthat/test_qtlAssociationPostprocess.R b/tests/testthat/test_qtlAssociationPostprocess.R index 83653d2b..00b7e1c7 100644 --- a/tests/testthat/test_qtlAssociationPostprocess.R +++ b/tests/testthat/test_qtlAssociationPostprocess.R @@ -26,7 +26,7 @@ context("qtlAssociationPostprocess") # qvalue::qvalue estimates pi0 on its default path (no fallback needed). pBeta <- c(10^(-c(8, 7, 6, 5, 4, 3)), stats::ppoints(54)) G <- length(pBeta) - entries <- lapply(seq_len(G), function(i) { + entries <- map(seq_len(G), function(i) { if (i %in% emptyIdx) { return(GenomicRanges::GRanges()) } # no variants @@ -68,11 +68,17 @@ context("qtlAssociationPostprocess") beta_shape1 = shape1, beta_shape2 = rep(200, G) ) - do.call(QtlSumStats, args[setdiff(names(args), drop)]) + exec(QtlSumStats, !!!args[setdiff(names(args), drop)]) } +# The default fixture is 60 genes of GRanges + mcols and costs ~0.5s to build, +# which is most of this file's runtime when every test rebuilds it. S4 objects +# are copy-on-modify, so one shared instance is safe; tests needing a variant +# still call .qapFixture() with arguments. +.qapDefaultFixture <- .qapFixture() + test_that("qtlAssociationPostprocess enriches with package-computed columns", { - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess( x, fdrThreshold = 0.1, @@ -84,7 +90,7 @@ test_that("qtlAssociationPostprocess enriches with package-computed columns", { expect_false(is.null(getQcInfo(r)$associationPostprocess)) # recipe stashed # Bonferroni original == min over variants of p.adjust(P, "bonferroni", n). - expP <- vapply( + expP <- map_dbl( seq_len(nrow(x)), function(i) { min(stats::p.adjust( @@ -92,8 +98,7 @@ test_that("qtlAssociationPostprocess enriches with package-computed columns", { "bonferroni", n = 50 )) - }, - numeric(1) + } ) expect_equal(as.numeric(r$p_bonferroni_min_original), expP) expect_equal( @@ -118,7 +123,7 @@ test_that("qtlAssociationPostprocess enriches with package-computed columns", { test_that("q-values come from qvalue::qvalue, not a hand-rolled fallback", { skip_if_not_installed("qvalue") - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess(x, methods = "permutation") expect_equal( as.numeric(r$q_beta), @@ -131,7 +136,7 @@ test_that("q-values come from qvalue::qvalue, not a hand-rolled fallback", { }) test_that("permutation nominal threshold == stats::qbeta of the empirical cutoff", { - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess( x, fdrThreshold = 0.1, @@ -150,7 +155,7 @@ test_that("permutation nominal threshold == stats::qbeta of the empirical cutoff }) test_that("getSignificantQtls (bonferroni) matches the derived threshold rule", { - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess(x, mafCutoff = 0.01, cisWindow = 1e6) sig <- getSignificantQtls(r, "bonferroni_original", threshold = 0.5) expect_s4_class(sig, "GRanges") @@ -161,18 +166,17 @@ test_that("getSignificantQtls (bonferroni) matches the derived threshold rule", sigGenes <- which(fdr < 0.5) expect_gt(length(sigGenes), 0) varThr <- max(as.numeric(r$p_bonferroni_min_original)[sigGenes]) - expN <- sum(vapply( + expN <- sum(map_int( seq_len(nrow(r)), function(i) { sum(pmin(1, S4Vectors::mcols(r[[i]])$P * 50) <= varThr) - }, - integer(1) + } )) expect_equal(length(sig), expN) }) test_that("getSumStats(annotateSignificance=) adds a derived logical mcol", { - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess(x, methods = "permutation") gr <- getSumStats( r, @@ -194,7 +198,7 @@ test_that("getSumStats(annotateSignificance=) adds a derived logical mcol", { }) test_that("significance accessors require a postprocessed object", { - x <- .qapFixture() # not postprocessed + x <- .qapDefaultFixture # not postprocessed expect_error( getSignificantQtls(x, "bonferroni_original"), "qtlAssociationPostprocess" @@ -218,7 +222,7 @@ test_that(".qapSafeQvalue retries with lambda=0 on qvalue 'missing or infinite'" }, .package = "qvalue" ) - r <- qtlAssociationPostprocess(.qapFixture(), methods = "permutation") + r <- qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation") expect_true(all(as.numeric(r$q_beta) == 0.111)) }) @@ -233,7 +237,7 @@ test_that(".qapSafeQvalue retries with bootstrap pi0 on qvalue 'pi0 <= 0'", { }, .package = "qvalue" ) - r <- qtlAssociationPostprocess(.qapFixture(), methods = "permutation") + r <- qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation") expect_true(all(as.numeric(r$q_beta) == 0.222)) }) @@ -244,7 +248,7 @@ test_that(".qapSafeQvalue re-raises a non-native qvalue error (no hand-rolled q) .package = "qvalue" ) expect_error( - qtlAssociationPostprocess(.qapFixture(), methods = "permutation"), + qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation"), "qvalue::qvalue failed" ) }) @@ -253,7 +257,7 @@ test_that("permutation nominal threshold is NA for every gene when none pass FDR # An impossibly small FDR threshold leaves no q_beta-significant gene, so the # empirical p_beta bracketing is empty and every nominal threshold is NA. r <- qtlAssociationPostprocess( - .qapFixture(), + .qapDefaultFixture, fdrThreshold = 1e-300, methods = "permutation" ) @@ -264,7 +268,7 @@ test_that("permutation nominal threshold is NA for every gene when none pass FDR test_that("getSignificantQtls (permutation) uses each gene's nominal threshold", { r <- qtlAssociationPostprocess( - .qapFixture(), + .qapDefaultFixture, fdrThreshold = 0.1, methods = "permutation" ) @@ -273,15 +277,14 @@ test_that("getSignificantQtls (permutation) uses each gene's nominal threshold", expect_true("trait" %in% names(S4Vectors::mcols(sig))) # Reproduce: per gene, variants with P < p_nominal_threshold[gene]. thr <- as.numeric(r$p_nominal_threshold) - expN <- sum(vapply( + expN <- sum(map_int( seq_len(nrow(r)), function(i) { if (is.na(thr[i])) { return(0L) } sum(S4Vectors::mcols(r[[i]])$P < thr[i]) - }, - integer(1) + } )) expect_gt(expN, 0) expect_equal(length(sig), expN) @@ -301,15 +304,14 @@ test_that("getSignificantQtls (permutation) skips genes with an NA threshold", { sig <- getSignificantQtls(r, "permutation") expect_s4_class(sig, "GRanges") # Gene 1 contributes nothing; total is the sum over the non-NA-threshold genes. - expN <- sum(vapply( + expN <- sum(map_int( seq_len(nrow(r)), function(i) { if (is.na(thr[i])) { return(0L) } sum(S4Vectors::mcols(r[[i]])$P < thr[i]) - }, - integer(1) + } )) expect_equal(length(sig), expN) }) @@ -326,7 +328,7 @@ test_that("getSignificantQtls (permutation) errors without a nominal threshold", test_that("getSignificantQtls (bonferroni_filtered) applies the MAF/cis keep filter", { r <- qtlAssociationPostprocess( - .qapFixture(), + .qapDefaultFixture, mafCutoff = 0.01, cisWindow = 1e6 ) @@ -343,7 +345,7 @@ test_that("getSignificantQtls (bonferroni_filtered) applies the MAF/cis keep fil }) test_that("getSignificantQtls (bonferroni) errors when its columns are absent", { - r <- qtlAssociationPostprocess(.qapFixture(), methods = "permutation") # no bonferroni + r <- qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation") # no bonferroni expect_error(getSignificantQtls(r, "bonferroni_original"), "columns absent") }) @@ -360,12 +362,11 @@ test_that("getSignificantQtls (qvalue) selects variants by their qvalue mcol", { qb <- as.numeric(r$q_beta) sigGenes <- which(qb < 0.1) expect_gt(length(sigGenes), 0) - expN <- sum(vapply( + expN <- sum(map_int( sigGenes, function(i) { sum(S4Vectors::mcols(r[[i]])$qvalue < 0.1) - }, - integer(1) + } )) expect_gt(expN, 0) expect_equal(length(sig), expN) @@ -385,7 +386,7 @@ test_that("getSignificantQtls (qvalue) errors when no event q column exists", { test_that("getSignificantQtls returns an empty GRanges when nothing is significant", { r <- qtlAssociationPostprocess( - .qapFixture(), + .qapDefaultFixture, mafCutoff = 0.01, cisWindow = 1e6 ) @@ -431,16 +432,16 @@ test_that("FILTERED Bonferroni drops MAF/cis-failing variants + uses n_variants_ # Fixture entries: af = (.30, .20, .005, .40), tss/tes_distance = (0, 500, 9e5, 2e6). # With mafCutoff 0.01 + cisWindow 1e6 the filtered set keeps only v1, v2 # (v3 fails MAF, v4 is outside the cis window); the filtered count is 30. - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess( x, mafCutoff = 0.01, cisWindow = 1e6, methods = "bonferroni" ) - P <- lapply(seq_len(nrow(x)), function(i) S4Vectors::mcols(x[[i]])$P) - expFilt <- vapply(P, function(p) min(pmin(1, p[1:2] * 30)), numeric(1)) # v1,v2 @ n=30 - expOrig <- vapply(P, function(p) min(pmin(1, p * 50)), numeric(1)) # all @ n=50 + P <- map(seq_len(nrow(x)), function(i) S4Vectors::mcols(x[[i]])$P) + expFilt <- map_dbl(P, function(p) min(pmin(1, p[1:2] * 30))) # v1,v2 @ n=30 + expOrig <- map_dbl(P, function(p) min(pmin(1, p * 50))) # all @ n=50 expect_equal(as.numeric(r$p_bonferroni_min_filtered), expFilt) expect_equal(as.numeric(r$p_bonferroni_min_original), expOrig) # A smaller test count makes the filtered flavour no less significant. @@ -450,7 +451,7 @@ test_that("FILTERED Bonferroni drops MAF/cis-failing variants + uses n_variants_ }) test_that("getSignificantQtls(bonferroni_filtered) applies the derived rule on the filtered set", { - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess( x, mafCutoff = 0.01, @@ -464,13 +465,12 @@ test_that("getSignificantQtls(bonferroni_filtered) applies the derived rule on t expect_gt(length(sigGenes), 0) # signal genes pass varThr <- max(as.numeric(r$p_bonferroni_min_filtered)[sigGenes]) # only MAF/cis-passing variants (v1,v2) with P*n_filtered <= threshold qualify - expN <- sum(vapply( + expN <- sum(map_int( seq_len(nrow(r)), function(i) { p <- S4Vectors::mcols(r[[i]])$P[1:2] sum(pmin(1, p * 30) <= varThr) - }, - integer(1) + } )) expect_equal(length(sig), expN) }) @@ -488,15 +488,20 @@ test_that(".qapSignificanceMask returns empty masks for an unknown method", { S4Vectors::mcols(g)$Z <- c(1, 2) S4Vectors::mcols(g)$N <- c(10L, 10L) qss <- QtlSumStats( - study = "s1", context = "c1", trait = "g1", - entry = list(g), genome = "hg19" + study = "s1", + context = "c1", + trait = "g1", + entry = list(g), + genome = "hg19" ) local_mocked_bindings( getQcInfo = function(x) { - list(associationPostprocess = list( - fdrThreshold = 0.05, - pvalueCol = "pval_nominal" - )) + list( + associationPostprocess = list( + fdrThreshold = 0.05, + pvalueCol = "pval_nominal" + ) + ) }, .qapEmptyMask = function(i, x, pcol) str_c("EMPTY", i), .package = "pecotmr" diff --git a/tests/testthat/test_qtlEnrichmentPipeline.R b/tests/testthat/test_qtlEnrichmentPipeline.R index 6ebe5006..0898205d 100644 --- a/tests/testthat/test_qtlEnrichmentPipeline.R +++ b/tests/testthat/test_qtlEnrichmentPipeline.R @@ -29,7 +29,7 @@ context("qtlEnrichmentPipeline") path = path, format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -282,7 +282,7 @@ test_that("qtlEnrichmentPipeline: rejects non-GwasFineMappingResult gwasFmr", { gwasFineMappingResult = "no", qtlFineMappingResult = qfmr ), - "must be a GwasFineMappingResult" + "Must inherit from class 'GwasFineMappingResult'" ) }) @@ -293,7 +293,7 @@ test_that("qtlEnrichmentPipeline: rejects non-QtlFineMappingResult qtlFmr", { gwasFineMappingResult = gfmr, qtlFineMappingResult = "no" ), - "must be a QtlFineMappingResult" + "Must inherit from class 'GwasFineMappingResult'" ) }) @@ -1068,7 +1068,18 @@ test_that(".enrRunEnrichment turns a stored alignment failure into a warning", { 1L, gwasPip = NULL, k = 1L, - p = list(alignedByTuple = list(cnd)) + alignedByTuple = list(cnd), + numGwas = NULL, + piQtl = NULL, + lambda = 1, + impN = 25, + numThreads = 1L, + seed = NULL, + enrichmentArgs = list(), + gwasFineMappingResult = NULL, + gwasTuples = data.frame(study = "g"), + qtlFineMappingResult = NULL, + qtlTuples = data.frame(study = "q") ), "qtlEnrichment failed" ) diff --git a/tests/testthat/test_qtlSumStats.R b/tests/testthat/test_qtlSumStats.R index efd2c577..6d06dcc3 100644 --- a/tests/testthat/test_qtlSumStats.R +++ b/tests/testthat/test_qtlSumStats.R @@ -366,7 +366,7 @@ test_that("accessors require length-1 selection args", { obj <- .qtlMakeOne() expect_error( getSumStats(obj, study = c("s1", "s2"), context = "c1", trait = "t1"), - "must each be length 1" + "Must have length 1" ) }) @@ -649,11 +649,11 @@ test_that("validity names the identity columns that are missing", { data(qtlSumStatsExample) bad <- qtlSumStatsExample S4Vectors::mcols(bad)$trait <- NULL - expect_equal( - pecotmr:::.qssCheckRequiredCols(bad), - "missing columns: trait" + expect_error( + methods::validObject(bad), + "missing elements \\{'trait'\\}" ) - expect_null(pecotmr:::.qssCheckRequiredCols(qtlSumStatsExample)) + expect_true(methods::validObject(qtlSumStatsExample)) }) test_that(".appendTraitDistances is a no-op without a trait position", { diff --git a/tests/testthat/test_regularizedRegressionWrappers.R b/tests/testthat/test_regularizedRegressionWrappers.R index 18007f5a..f6211fbb 100644 --- a/tests/testthat/test_regularizedRegressionWrappers.R +++ b/tests/testthat/test_regularizedRegressionWrappers.R @@ -235,7 +235,7 @@ test_that("mrmashWrapper errors when X and Y row counts differ", { matrix(1:6, nrow = 3, ncol = 2), matrix(1:8, nrow = 4, ncol = 2) ), - "same number of rows" + "Assertion on 'Y'.*Must have exactly 3 rows" ) }) @@ -310,7 +310,7 @@ test_that("computeCoefficientsGlasso runs without Xnew", { r <- 3 X <- matrix(rnorm(n * p), nrow = n, ncol = p) Y <- matrix(rnorm(n * r), nrow = n, ncol = r) - colnames(Y) <- paste0("cond", 1:r) + colnames(Y) <- paste0("cond", seq_len(r)) result <- pecotmr:::computeCoefficientsGlasso( X, Y, @@ -334,7 +334,7 @@ test_that("computeCoefficientsGlasso runs with Xnew", { r <- 3 X <- matrix(rnorm(n * p), nrow = n, ncol = p) Y <- matrix(rnorm(n * r), nrow = n, ncol = r) - colnames(Y) <- paste0("cond", 1:r) + colnames(Y) <- paste0("cond", seq_len(r)) Xnew <- matrix(rnorm(10 * p), nrow = 10, ncol = p) result <- pecotmr:::computeCoefficientsGlasso( X, @@ -361,7 +361,7 @@ test_that("computeCoefficientsUnivGlmnet runs without Xnew", { r <- 2 X <- matrix(rnorm(n * p), nrow = n, ncol = p) Y <- matrix(rnorm(n * r), nrow = n, ncol = r) - colnames(Y) <- paste0("cond", 1:r) + colnames(Y) <- paste0("cond", seq_len(r)) result <- pecotmr:::computeCoefficientsUnivGlmnet( X, Y, @@ -386,7 +386,7 @@ test_that("computeCoefficientsUnivGlmnet runs with Xnew", { r <- 2 X <- matrix(rnorm(n * p), nrow = n, ncol = p) Y <- matrix(rnorm(n * r), nrow = n, ncol = r) - colnames(Y) <- paste0("cond", 1:r) + colnames(Y) <- paste0("cond", seq_len(r)) Xnew <- matrix(rnorm(8 * p), nrow = 8, ncol = p) result <- pecotmr:::computeCoefficientsUnivGlmnet( X, @@ -411,7 +411,7 @@ test_that("computeCoefficientsUnivGlmnet handles NA in Y", { r <- 2 X <- matrix(rnorm(n * p), nrow = n, ncol = p) Y <- matrix(rnorm(n * r), nrow = n, ncol = r) - colnames(Y) <- paste0("cond", 1:r) + colnames(Y) <- paste0("cond", seq_len(r)) Y[1:5, 1] <- NA # introduce missing values in one condition result <- pecotmr:::computeCoefficientsUnivGlmnet( X, @@ -481,12 +481,12 @@ test_that("mrashWeights returns length-p weights and can retain the fit", { test_that("qgg Bayes-alphabet weights (N/L/A/C/R) return length-p weights", { skip_if_not_installed("qgg") f <- .rrwXy() - mc <- list(nit = 200, nburn = 20, nthin = 1) - expect_length(do.call(bayesNWeights, c(list(f$X, f$y), mc)), f$p) - expect_length(do.call(bayesLWeights, c(list(f$X, f$y), mc)), f$p) - expect_length(do.call(bayesAWeights, c(list(f$X, f$y), mc)), f$p) - expect_length(do.call(bayesCWeights, c(list(f$X, f$y), mc)), f$p) - expect_length(do.call(bayesRWeights, c(list(f$X, f$y), mc)), f$p) + mc <- list(methodArgs = list(nit = 200, nburn = 20, nthin = 1)) + expect_length(exec(bayesNWeights, !!!c(list(f$X, f$y), mc)), f$p) + expect_length(exec(bayesLWeights, !!!c(list(f$X, f$y), mc)), f$p) + expect_length(exec(bayesAWeights, !!!c(list(f$X, f$y), mc)), f$p) + expect_length(exec(bayesCWeights, !!!c(list(f$X, f$y), mc)), f$p) + expect_length(exec(bayesRWeights, !!!c(list(f$X, f$y), mc)), f$p) }) test_that("bayesAlphabetWeights validates matching row counts before fitting", { @@ -494,7 +494,7 @@ test_that("bayesAlphabetWeights validates matching row counts before fitting", { f <- .rrwXy() expect_error( bayesAlphabetWeights(f$X, f$y[-1], method = "bayesN"), - "same number of rows" + "y.*Must have length 50" ) expect_error( bayesAlphabetWeights( @@ -503,7 +503,7 @@ test_that("bayesAlphabetWeights validates matching row counts before fitting", { method = "bayesN", Z = matrix(1, f$n - 1, 1) ), - "same number of rows" + "Z.*Must have exactly 50 rows" ) }) @@ -539,7 +539,11 @@ test_that("dprAdaptiveGibbsWeights returns length-p weights", { skip_if_not_installed("RcppDPR") f <- .rrwXy() invisible(capture.output( - w <- dprAdaptiveGibbsWeights(f$X, f$y, s_step = 100) + w <- dprAdaptiveGibbsWeights( + f$X, + f$y, + methodArgs = list(s_step = 100) + ) )) expect_length(w, f$p) }) @@ -552,7 +556,7 @@ test_that("mrmashWeights fits from (X, Y) and returns p x K weights", { w <- suppressMessages(mrmashWeights( X = m$X, Y = m$Y, - canonicalPriorMatrices = TRUE + methodArgs = list(canonicalPriorMatrices = TRUE) )) expect_equal(dim(w), c(m$p, m$K)) expect_true(all(is.finite(w))) @@ -614,8 +618,8 @@ test_that("RSS solvers validate their R-matrix / sample-size / length inputs", { 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(prsCs(f$stat$b[-1], f$LD, f$n), "bhat.*Must have length 6") + expect_error(sdpr(f$stat$b[-1], f$LD, f$n), "bhat.*Must have length 6") expect_error(sdpr(f$stat$b, f$LD, f$n, M = 2), "at least 4") }) @@ -642,17 +646,23 @@ test_that("scadRssWeights / mcpRssWeights / l0learnRssWeights return length-p we test_that("prsCsWeights and sdprWeights follow the (stat, LD) contract", { f <- .rrwStatLd() expect_length( - prsCsWeights(f$stat, f$LD, nIter = 100, nBurnin = 20, thin = 1), + prsCsWeights( + f$stat, + f$LD, + methodArgs = list(nIter = 100, nBurnin = 20, thin = 1) + ), f$p ) expect_length( sdprWeights( f$stat, f$LD, - iter = 100, - burn = 20, - thin = 1, - verbose = FALSE + methodArgs = list( + iter = 100, + burn = 20, + thin = 1, + verbose = FALSE + ) ), f$p ) @@ -784,10 +794,9 @@ test_that("buildMrmashPriorMatrices builds an expanded S0 list and a prior grid" expect_true(is.list(res$S0)) expect_gt(length(res$S0), 1) expect_true(is.numeric(res$priorGrid)) - expect_true(all(vapply( + expect_true(all(map_lgl( res$S0, - function(s) all(dim(s) == c(3, 3)), - logical(1) + function(s) all(dim(s) == c(3, 3)) ))) }) @@ -871,3 +880,82 @@ test_that("mrmashWeights(retainFit=TRUE) attaches {dataDrivenPriorMatrices, w0, "fit" )) }) + +test_that("MCMC / optimiser control arguments are guarded", { + expect_error( + bayesBWeights(NULL, NULL, nIter = 0), + "nIter.*Must be >= 1" + ) + expect_error( + bayesBWeights(NULL, NULL, thin = 0), + "thin.*Must be >= 1" + ) + expect_error( + bayesBWeights(NULL, NULL, probIn = 2), + "probIn.*is not <= 1" + ) + expect_error( + bLassoWeights(NULL, NULL, burnIn = -1), + "burnIn.*Must be >= 0" + ) + expect_error( + dprGibbsWeights(NULL, NULL, sStep = 0), + "sStep.*Must be >= 1" + ) + expect_error( + dprAdaptiveGibbsWeights(NULL, NULL, retainFit = NA), + "retainFit.*May not be NA" + ) + expect_error( + ncvregWeights(NULL, NULL, penalty = "SCAD", nfolds = 0), + "nfolds.*Must be >= 1" + ) + expect_error( + mrashWeights(NULL, NULL, initPriorSd = NA), + "initPriorSd.*May not be NA" + ) + expect_error( + computeCoefficientsGlasso(NULL, NULL, standardize = NA, nthreads = 1), + "standardize.*May not be NA" + ) + expect_error( + computeCoefficientsGlasso( + NULL, + NULL, + standardize = TRUE, + nthreads = 1.5 + ), + "nthreads.*integerish" + ) +}) + +test_that("RSS solver control arguments are guarded", { + expect_error( + lassosumRss(NULL, NULL, NULL, thr = -1), + "thr.*is not >= 0" + ) + expect_error( + lassosumRss(NULL, NULL, NULL, maxiter = 0), + "maxiter.*Must be >= 1" + ) + expect_error( + scadRssWeights(stat = "nope", LD = NULL), + "stat.*Must be of type 'list'" + ) + expect_error( + scadRssWeights(stat = list(), LD = NULL, s = -1), + "s.*is not >= 0" + ) + expect_error( + mcpRssWeights(stat = "nope", LD = NULL), + "stat.*Must be of type 'list'" + ) + expect_error( + mrashRssWeights(stat = "nope", LD = NULL, NULL, NULL, NULL, NULL), + "stat.*Must be of type 'list'" + ) + expect_error( + mrmashRssWeights(stat = "nope", LD = NULL), + "stat.*Must be of type 'list'" + ) +}) diff --git a/tests/testthat/test_relatednessQc.R b/tests/testthat/test_relatednessQc.R index 50388c3e..ce032056 100644 --- a/tests/testthat/test_relatednessQc.R +++ b/tests/testthat/test_relatednessQc.R @@ -70,7 +70,7 @@ test_that("large component pre-pruning removes individuals", { n <- 30 ids <- paste0("IND", seq_len(n)) rel <- data.frame( - IID1 = ids[1:(n - 1)], + IID1 = ids[seq_len(n - 1)], IID2 = ids[2:n], PI_HAT = rep(0.20, n - 1), stringsAsFactors = FALSE @@ -224,3 +224,16 @@ test_that("iterative cleanup loops and warns when related pairs persist", { expect_type(result, "character") expect_equal(length(result), 0L) }) + +test_that(".relatednessLargestComponent guards an empty component list", { + # max(integer(0)) warns and returns -Inf; with no related pairs the + # pruning loop must simply not run, without emitting that warning. + expect_identical( + pecotmr:::.relatednessLargestComponent(list(csize = integer(0))), + 0L + ) + expect_identical( + pecotmr:::.relatednessLargestComponent(list(csize = c(3L, 7L))), + 7L + ) +}) diff --git a/tests/testthat/test_rrBayesAlphabet.R b/tests/testthat/test_rrBayesAlphabet.R index a1f6f004..dd8ae104 100644 --- a/tests/testthat/test_rrBayesAlphabet.R +++ b/tests/testthat/test_rrBayesAlphabet.R @@ -7,7 +7,7 @@ test_that("bayesAlphabetWeights errors on dimension mismatch", { y <- rnorm(5) expect_error( bayesAlphabetWeights(X, y, method = "bayesN"), - "same number of rows" + "y.*Must have length 10" ) }) @@ -18,7 +18,7 @@ test_that("bayesAlphabetWeights errors on covariate dimension mismatch", { Z <- matrix(rnorm(15), nrow = 5) expect_error( bayesAlphabetWeights(X, y, method = "bayesN", Z = Z), - "same number of rows" + "Z.*Must have exactly 10 rows" ) }) @@ -71,7 +71,11 @@ test_that("bayesNWeights dispatches to bayesAlphabetWeights with bayesN", { p <- 10 X <- matrix(rnorm(n * p), nrow = n) y <- X[, 1] * 0.5 + rnorm(n) - result <- bayesNWeights(X, y, nit = 50, nburn = 10) + result <- bayesNWeights( + X, + y, + methodArgs = list(nit = 50, nburn = 10) + ) expect_equal(length(result), p) expect_true(is.numeric(result)) expect_true(all(is.finite(result))) diff --git a/tests/testthat/test_rrDispatch.R b/tests/testthat/test_rrDispatch.R index 8e2e53ea..670e33db 100644 --- a/tests/testthat/test_rrDispatch.R +++ b/tests/testthat/test_rrDispatch.R @@ -6,6 +6,18 @@ context("regularized_regression - dispatch verification") # correct values. They catch silent dispatch bugs (wrong method, wrong penalty, # dropped argument) that the shape-only tests above would not. +test_that("susie-family weight wrappers never fit; they demand the fit", { + # Fitting belongs to fineMappingPipeline(); these wrappers extract only. + # The susie dispatch arguments they used to build are covered in + # test_fineMappingWrappers.R and test_fineMappingPipeline.R. + data(eqtlRegionExample) + X <- eqtlRegionExample$X[, 1:20] + y <- eqtlRegionExample$yRes + expect_error(susieWeights(X = X, y = y), "no 'susie' fit supplied") + expect_error(susieAshWeights(X = X, y = y), "no 'susieAsh' fit supplied") + expect_error(susieInfWeights(X = X, y = y), "no 'susieInf' fit supplied") +}) + test_that("prsCsWeights dispatches to prsCs with correct arguments", { set.seed(42) p <- 10 @@ -25,7 +37,11 @@ test_that("prsCsWeights dispatches to prsCs with correct arguments", { list(betaEst = seq_len(length(bhat)) * 0.01) } ) - result <- prsCsWeights(stat = stat, LD = R, maf = rep(0.3, p), nIter = 17) + result <- prsCsWeights( + stat = stat, + LD = R, + methodArgs = list(maf = rep(0.3, p), nIter = 17) + ) expect_equal(captured$bhat, bhat) expect_equal(captured$R, R) expect_equal(captured$n, 55) # median of stat$n, NOT mean (145) @@ -50,7 +66,11 @@ test_that("sdprWeights dispatches to sdpr with correct arguments", { list(betaEst = seq_len(length(bhat)) * 0.02) } ) - result <- sdprWeights(stat = stat, LD = R, iter = 19, burn = 3) + result <- sdprWeights( + stat = stat, + LD = R, + methodArgs = list(iter = 19, burn = 3) + ) expect_equal(captured$bhat, bhat) expect_equal(captured$R, R) expect_equal(captured$n, 456) @@ -64,7 +84,7 @@ test_that("lassosumRssWeights dispatches to lassosumRss once per s value", { p <- 10 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { R[i, i + 1] <- 0.4 R[i + 1, i] <- 0.4 } @@ -306,83 +326,6 @@ test_that("lassoWeights and enetWeights dispatch to glmnetWeights with correct a } }) -test_that("susieWeights actually calls susie when fit is NULL", { - set.seed(42) - p <- 5 - X <- matrix(rnorm(10 * p), nrow = 10) - y <- rnorm(10) - captured <- new.env(parent = emptyenv()) - captured$called <- FALSE - local_mocked_bindings( - susie = function(X, y, ...) { - captured$called <- TRUE - captured$X <- X - captured$y <- y - list(pip = rep(0.1, ncol(X))) - }, - .package = "susieR" - ) - susieWeights(X = X, y = y) - expect_true(captured$called) - expect_identical(captured$X, X) - expect_identical(captured$y, y) -}) - -test_that("susieAshWeights calls susie with ash dispatch arguments", { - set.seed(42) - p <- 5 - X <- matrix(rnorm(10 * p), nrow = 10) - y <- rnorm(10) - captured <- new.env(parent = emptyenv()) - captured$called <- FALSE - local_mocked_bindings( - susie = function( - X, - y, - unmappable_effects = NULL, - convergence_method = NULL, - ... - ) { - captured$called <- TRUE - 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) - expect_equal(captured$unmappable_effects, "ash") - expect_equal(captured$convergence_method, "pip") -}) - -test_that("susieInfWeights calls susie with inf dispatch arguments", { - set.seed(42) - p <- 5 - X <- matrix(rnorm(10 * p), nrow = 10) - y <- rnorm(10) - captured <- new.env(parent = emptyenv()) - captured$called <- FALSE - local_mocked_bindings( - susie = function( - X, - y, - unmappable_effects = NULL, - convergence_method = NULL, - ... - ) { - captured$called <- TRUE - 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) - expect_equal(captured$unmappable_effects, "inf") - expect_equal(captured$convergence_method, "pip") -}) test_that("mrashWeights actually calls lassoWeights for default beta.init", { skip_if_not_installed("glmnet") diff --git a/tests/testthat/test_rrGlmnet.R b/tests/testthat/test_rrGlmnet.R index e87779ab..75650e1d 100644 --- a/tests/testthat/test_rrGlmnet.R +++ b/tests/testthat/test_rrGlmnet.R @@ -55,7 +55,7 @@ test_that("glmnetWeights errors when all columns are constant", { set.seed(42) n <- 50 p <- 5 - X <- matrix(rep(1:p, each = n), nrow = n, ncol = p) + X <- matrix(rep(seq_len(p), each = n), nrow = n, ncol = p) y <- rnorm(n) expect_error( diff --git a/tests/testthat/test_rrLassosum.R b/tests/testthat/test_rrLassosum.R index dd4b226e..1dcf44c9 100644 --- a/tests/testthat/test_rrLassosum.R +++ b/tests/testthat/test_rrLassosum.R @@ -18,7 +18,7 @@ test_that("lassosumRss errors on non-positive sample size", { test_that("lassosumRss errors on mismatched bhat and R dimensions", { expect_error( lassosumRss(bhat = rnorm(10), R = diag(5), n = 100), - "number of rows of 'R'" + "bhat.*Must have length" ) }) @@ -28,7 +28,7 @@ test_that("lassosumRss runs successfully with valid input", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } @@ -58,7 +58,7 @@ test_that("lassosumRssWeights calls lassosumRss and returns betaEst", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } diff --git a/tests/testthat/test_rrMrAshRss.R b/tests/testthat/test_rrMrAshRss.R index 0c7d9eb6..9a3e1c4c 100644 --- a/tests/testthat/test_rrMrAshRss.R +++ b/tests/testthat/test_rrMrAshRss.R @@ -54,7 +54,7 @@ test_that("mrashRssWeights forwards arguments to susieR::mr.ash.rss", { s0 = c(0, 0.1, 0.2), w0 = c(0.5, 0.3, 0.2), z = z_vec, - tol = 1e-6 + methodArgs = list(tol = 1e-6) ) expect_equal(captured$bhat, bhat) expect_equal(captured$shat, shat) diff --git a/tests/testthat/test_rrMrash.R b/tests/testthat/test_rrMrash.R index a6c80d45..befe677d 100644 --- a/tests/testthat/test_rrMrash.R +++ b/tests/testthat/test_rrMrash.R @@ -42,7 +42,11 @@ test_that("mrashWeights subsets a user-supplied beta.init of length ncol(X) by k y <- X[, 1] * 0.5 + rnorm(n) user_beta_init <- seq(0.01, by = 0.01, length.out = p) expect_warning( - result <- mrashWeights(X, y, beta.init = user_beta_init), + result <- mrashWeights( + X, + y, + methodArgs = list(beta.init = user_beta_init) + ), "mrashWeights: dropping 1 zero-variance column" ) expect_equal(length(result), p) diff --git a/tests/testthat/test_rrPenalizedRss.R b/tests/testthat/test_rrPenalizedRss.R index fa59bc9b..1ef2f337 100644 --- a/tests/testthat/test_rrPenalizedRss.R +++ b/tests/testthat/test_rrPenalizedRss.R @@ -24,7 +24,7 @@ test_that("penalizedRss errors on non-positive sample size", { test_that("penalizedRss errors on mismatched bhat and R dimensions", { expect_error( penalizedRss(bhat = rnorm(10), R = diag(5), n = 100, penalty = "MCP"), - "number of rows of 'R'" + "bhat.*Must have length" ) }) @@ -80,7 +80,7 @@ test_that("penalizedRss runs with MCP and returns correct structure", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } diff --git a/tests/testthat/test_rrPrsCs.R b/tests/testthat/test_rrPrsCs.R index 221ec192..8d18c99a 100644 --- a/tests/testthat/test_rrPrsCs.R +++ b/tests/testthat/test_rrPrsCs.R @@ -25,7 +25,7 @@ test_that("prsCs errors on mismatched maf length", { test_that("prsCs errors on mismatched bhat and R dimensions", { expect_error( prsCs(bhat = rnorm(10), R = diag(5), n = 100), - "number of rows of 'R'" + "bhat.*Must have length" ) }) @@ -35,7 +35,7 @@ test_that("prsCs runs successfully with valid input", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } @@ -194,7 +194,7 @@ test_that("prsCsWeights calls prsCs and returns betaEst", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } @@ -202,10 +202,12 @@ test_that("prsCsWeights calls prsCs and returns betaEst", { result <- prsCsWeights( stat = stat, LD = R, - maf = rep(0.3, p), - nIter = 50, - nBurnin = 10, - thin = 2 + methodArgs = list( + maf = rep(0.3, p), + nIter = 50, + nBurnin = 10, + thin = 2 + ) ) expect_equal(length(result), p) expect_true(is.numeric(result)) diff --git a/tests/testthat/test_rrSdpr.R b/tests/testthat/test_rrSdpr.R index e7352f53..53db7a90 100644 --- a/tests/testthat/test_rrSdpr.R +++ b/tests/testthat/test_rrSdpr.R @@ -4,7 +4,7 @@ context("regularized_regression - sdpr") test_that("sdpr errors on mismatched bhat and R dimensions", { expect_error( sdpr(bhat = rnorm(10), R = diag(5), n = 100), - "number of rows of 'R'" + "bhat.*Must have length" ) }) @@ -223,10 +223,12 @@ test_that("sdprWeights calls sdpr and returns beta_est", { result <- sdprWeights( stat = stat, LD = R, - iter = 50, - burn = 10, - thin = 2, - verbose = FALSE + methodArgs = list( + iter = 50, + burn = 10, + thin = 2, + verbose = FALSE + ) ) expect_equal(length(result), p) expect_true(is.numeric(result)) diff --git a/tests/testthat/test_rrSusie.R b/tests/testthat/test_rrSusie.R index 5fa96110..4d56df31 100644 --- a/tests/testthat/test_rrSusie.R +++ b/tests/testthat/test_rrSusie.R @@ -86,13 +86,7 @@ test_that("susieWeights calls susie when susie_fit is NULL", { n <- 50 X <- matrix(rnorm(n * p), nrow = n) y <- rnorm(n) - local_mocked_bindings( - susie = function(...) { - list(pip = rep(0.1, p)) - }, - .package = "susieR" - ) - result <- susieWeights(X = X, y = y) + result <- susieWeights(susieFit = list(pip = rep(0.1, p))) expect_equal(result, rep(0, p)) }) @@ -134,13 +128,7 @@ test_that("susieAshWeights calls susie when fit is NULL", { n <- 30 X <- matrix(rnorm(n * p), nrow = n) y <- rnorm(n) - local_mocked_bindings( - susie = function(...) { - list(pip = rep(0.1, p)) - }, - .package = "susieR" - ) - result <- susieAshWeights(X = X, y = y) + result <- susieAshWeights(susieAshFit = list(pip = rep(0.1, p))) expect_equal(result, rep(0, p)) }) @@ -182,12 +170,6 @@ test_that("susieInfWeights calls susie when fit is NULL", { n <- 30 X <- matrix(rnorm(n * p), nrow = n) y <- rnorm(n) - local_mocked_bindings( - susie = function(...) { - list(pip = rep(0.1, p)) - }, - .package = "susieR" - ) - result <- susieInfWeights(X = X, y = y) + result <- susieInfWeights(susieInfFit = list(pip = rep(0.1, p))) expect_equal(result, rep(0, p)) }) diff --git a/tests/testthat/test_sldscWrapper.R b/tests/testthat/test_sldscWrapper.R index a9fe37eb..e411a074 100644 --- a/tests/testthat/test_sldscWrapper.R +++ b/tests/testthat/test_sldscWrapper.R @@ -47,7 +47,10 @@ test_that("readSldscTrait reads polyfun outputs correctly", { }) test_that("readSldscTrait errors on missing files", { - expect_error(readSldscTrait("/nonexistent/prefix"), "missing file") + expect_error( + readSldscTrait("/nonexistent/prefix"), + "File does not exist" + ) }) test_that("readSldscTrait errors when h2 not in log", { @@ -225,7 +228,10 @@ test_that("computeSldscAnnotSd errors when there are no annotation columns", { }) test_that("computeSldscAnnotSd errors on non-SldscData input", { - expect_error(computeSldscAnnotSd(list(a = 1)), "must be an SldscData") + expect_error( + computeSldscAnnotSd(list(a = 1)), + "Must inherit from class 'SldscData'" + ) }) test_that("computeSldscAnnotSd errors with zero degrees of freedom", { @@ -298,7 +304,10 @@ test_that("computeSldscMRef errors when mafCutoff > 0 but no frq data", { }) test_that("computeSldscMRef errors on non-SldscData input", { - expect_error(computeSldscMRef(list(a = 1)), "must be an SldscData") + expect_error( + computeSldscMRef(list(a = 1)), + "Must inherit from class 'SldscData'" + ) }) @@ -327,7 +336,10 @@ test_that("isBinarySldscAnnot respects annotCols (numeric)", { }) test_that("isBinarySldscAnnot errors on non-SldscData input", { - expect_error(isBinarySldscAnnot(list(a = 1)), "must be an SldscData") + expect_error( + isBinarySldscAnnot(list(a = 1)), + "Must inherit from class 'SldscData'" + ) }) @@ -521,7 +533,7 @@ test_that("standardizeSldscTrait errors on non-SldscData input", { sdAnnot = c(A_0 = 0.5), MRef = 1000L ), - "must be an SldscData" + "Must inherit from class 'SldscData'" ) }) diff --git a/tests/testthat/test_sumstatsQc.R b/tests/testthat/test_sumstatsQc.R index 7ef51e75..fae79d4f 100644 --- a/tests/testthat/test_sumstatsQc.R +++ b/tests/testthat/test_sumstatsQc.R @@ -410,7 +410,7 @@ test_that("formatRaissDf returns correctly formatted data frame", { A2 = sample(c("A", "T", "G", "C"), 10, replace = TRUE) ) - unknowns <- sample(1:nrow(ref_panel), 5) + unknowns <- sample(seq_len(nrow(ref_panel)), 5) result <- formatRaissDf(imp, ref_panel, unknowns) @@ -761,7 +761,7 @@ test_that("raissSingleMatrixFromX returns NULL with no known overlap", { ref_panel <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), stringsAsFactors = FALSE @@ -794,7 +794,7 @@ test_that("raissSingleMatrixFromX returns known z when nothing to impute", { ref_panel <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), stringsAsFactors = FALSE @@ -802,7 +802,7 @@ test_that("raissSingleMatrixFromX returns known z when nothing to impute", { known_zscores <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), z = rnorm(p), @@ -832,7 +832,7 @@ test_that("raiss with single-matrix LD list dispatches to single matrix path", { ref_panel <- data.frame( chrom = rep(1, n_variants), pos = seq(10, n_variants * 10, 10), - variant_id = paste0("rs", 1:n_variants), + variant_id = paste0("rs", seq_len(n_variants)), A1 = rep("A", n_variants), A2 = rep("G", n_variants), stringsAsFactors = FALSE @@ -875,7 +875,7 @@ test_that("raiss with genotype_matrix list processes multiple blocks", { ref_panel <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), stringsAsFactors = FALSE @@ -919,7 +919,7 @@ test_that("raiss with genotype_matrix list returns NULL when all blocks fail", { ref_panel <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), stringsAsFactors = FALSE @@ -1002,7 +1002,7 @@ generate_block_diagonal_test_data <- function( block_size <- 5 n_blocks <- ceiling(n_variants / block_size) block_boundaries <- list() - for (i in 1:n_blocks) { + for (i in seq_len(n_blocks)) { startIdx <- (i - 1) * block_size + 1 endIdx <- min(i * block_size, n_variants) block_boundaries[[i]] <- c(startIdx, endIdx) @@ -1021,8 +1021,8 @@ generate_block_diagonal_test_data <- function( # Create the block matrix with correlations ONLY within the block block_matrix <- matrix(0, nrow = n_block, ncol = n_block) - for (a in 1:n_block) { - for (b in 1:n_block) { + for (a in seq_len(n_block)) { + for (b in seq_len(n_block)) { if (a == b) { block_matrix[a, b] <- 1 } else { @@ -1058,18 +1058,18 @@ generate_block_diagonal_test_data <- function( } # Create block metadata - block_sizes <- sapply(block_boundaries, function(b) b[2] - b[1] + 1) + block_sizes <- map_dbl(block_boundaries, function(b) b[2] - b[1] + 1) blockMetadata <- data.frame( blockId = seq_along(block_boundaries), chrom = rep(1, length(block_boundaries)), size = block_sizes, - startIdx = sapply(seq_along(block_boundaries), function(i) { + startIdx = map_dbl(seq_along(block_boundaries), function(i) { # Adjust for 1-based indexing in R if (i == 1) { return(1) } # Count unique variants before this block - sum(sapply(1:(i - 1), function(j) { + sum(map_dbl(seq_len(i - 1), function(j) { # If there's an overlap with the next block, count one less if ( j < length(block_boundaries) && @@ -1084,9 +1084,9 @@ generate_block_diagonal_test_data <- function( })) + 1 }), - endIdx = sapply(seq_along(block_boundaries), function(i) { + endIdx = map_dbl(seq_along(block_boundaries), function(i) { # Count all unique variants up to and including this block - sum(sapply(1:i, function(j) { + sum(map_dbl(seq_len(i), function(j) { # If there's an overlap with the next block, count one less if ( j < i && @@ -1281,7 +1281,7 @@ test_that("overlapping blocks keep variant IDs but may differ in z", { # Test 2: For overlapping blocks, verify boundary variants exist and have valid values # Identify boundary variants boundary_variants <- character(0) - for (i in 1:(length(test_data$block_boundaries) - 1)) { + for (i in seq_len(length(test_data$block_boundaries) - 1)) { overlap_pos <- test_data$block_boundaries[[i]][2] boundary_variants <- c(boundary_variants, paste0("var", overlap_pos)) } @@ -1367,7 +1367,7 @@ test_that("raiss handles block boundaries correctly", { # Check that boundary variants have reasonable values boundary_variants <- character(0) - for (i in 1:(length(test_data$block_boundaries) - 1)) { + for (i in seq_len(length(test_data$block_boundaries) - 1)) { overlap_pos <- test_data$block_boundaries[[i]][2] boundary_variants <- c(boundary_variants, paste0("var", overlap_pos)) } @@ -2181,7 +2181,7 @@ test_that("slalom basic output structure", { z <- rnorm(n) R <- diag(n) # Add some off-diagonal correlations - for (i in 1:(n - 1)) { + for (i in seq_len(n - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } @@ -2202,7 +2202,7 @@ test_that("slalom basic output structure", { test_that("slalom errors on non-square R", { z <- rnorm(10) R <- matrix(rnorm(50), nrow = 5, ncol = 10) - expect_error(slalom(zScore = z, R = R), "R must be a square matrix") + expect_error(slalom(zScore = z, R = R), "R.*Must have exactly 10 rows") }) test_that("slalom accepts X matrix instead of R", { @@ -2214,7 +2214,7 @@ test_that("slalom accepts X matrix instead of R", { nrow = n_samples, ncol = n_snps ) - colnames(X) <- paste0("snp", 1:n_snps) + colnames(X) <- paste0("snp", seq_len(n_snps)) z <- rnorm(n_snps) result <- slalom(zScore = z, X = X) @@ -2597,7 +2597,7 @@ test_that("edge case: mismatched dimensions error", { R <- diag(5) expect_error( slalom(zScore = z, R = R), - "R must be a square matrix matching the length of zScore" + "R.*Must have exactly 10 rows" ) }) @@ -3124,7 +3124,7 @@ context("summaryStatsQc") test_that("summaryStatsQc: rejects non-SumStats input", { expect_error( summaryStatsQc("not_a_sumstats"), - "requires a QtlSumStats or GwasSumStats input" + "Must inherit from class 'QtlSumStats'/'GwasSumStats'" ) }) @@ -4874,7 +4874,7 @@ test_that("summaryStatsQc: absZ / bf / logBf screens skip a no-signal entry", { list(bfCutoffToSkip = 100), list(logBfCutoffToSkip = 5) )) { - res <- do.call(summaryStatsQc, c(list(mk()), arg, list(nCutoff = 0))) + res <- exec(summaryStatsQc, !!!c(list(mk()), arg, list(nCutoff = 0))) ea <- getQcInfo(res)$entryAudit[[1L]] expect_true(isTRUE(ea$pipScreenSkipped)) expect_equal(length(res[[1L]]), 0L) @@ -4921,7 +4921,7 @@ generate_dentist_data <- function( ) { set.seed(seed) cor_matrix <- matrix(0, nrow = nSnps, ncol = nSnps) - for (i in 1:(nSnps - 1)) { + for (i in seq_len(nSnps - 1)) { for (j in (i + 1):nSnps) { cor_matrix[i, j] <- runif(1, 0.2, 0.8) cor_matrix[j, i] <- cor_matrix[i, j] @@ -4930,13 +4930,10 @@ generate_dentist_data <- function( diag(cor_matrix) <- 1 ld_matrix <- cov2cor(make.positive.definite(cor_matrix)) z_scores <- mvrnorm(n = 1, mu = rep(0, nSnps), Sigma = ld_matrix) - outlier_indices <- sample(1:nSnps, n_outliers) + outlier_indices <- sample(seq_len(nSnps), n_outliers) z_scores[outlier_indices] <- rnorm(n_outliers, mean = 0, sd = 5) sumstat <- data.frame( - position = unlist(lapply( - seq(start_pos, end_pos, length.out = nSnps), - round - )), + position = map_dbl(seq(start_pos, end_pos, length.out = nSnps), round), z = z_scores ) return(list(sumstat = sumstat, ldMat = ld_matrix, nSample = sample_size)) @@ -4950,7 +4947,7 @@ generate_dentist_single_window_data <- function( ) { set.seed(seed) cor_matrix <- matrix(0, nrow = nSnps, ncol = nSnps) - for (i in 1:(nSnps - 1)) { + for (i in seq_len(nSnps - 1)) { for (j in (i + 1):nSnps) { cor_matrix[i, j] <- runif(1, 0.2, 0.8) cor_matrix[j, i] <- cor_matrix[i, j] @@ -4959,7 +4956,7 @@ generate_dentist_single_window_data <- function( diag(cor_matrix) <- 1 ld_matrix <- cov2cor(make.positive.definite(cor_matrix)) z_scores <- mvrnorm(n = 1, mu = rep(0, nSnps), Sigma = ld_matrix) - outlier_indices <- sample(1:nSnps, n_outliers) + outlier_indices <- sample(seq_len(nSnps), n_outliers) z_scores[outlier_indices] <- rnorm(n_outliers, mean = 0, sd = 5) return(list(z_scores = z_scores, ldMat = ld_matrix, nSample = sample_size)) } @@ -5022,7 +5019,7 @@ test_that("dentist accepts 'position' and 'zscore' column names", { nSnps <- 80 n_samples <- 100 cor_matrix <- matrix(0, nrow = nSnps, ncol = nSnps) - for (i in 1:(nSnps - 1)) { + for (i in seq_len(nSnps - 1)) { for (j in (i + 1):nSnps) { cor_matrix[i, j] <- runif(1, 0.2, 0.8) cor_matrix[j, i] <- cor_matrix[i, j] @@ -5187,7 +5184,7 @@ test_that("dentistSingleWindow dedup path with message for duplicates", { nSnps <- 80 n_samples <- 100 cor_matrix <- matrix(0, nrow = nSnps, ncol = nSnps) - for (i in 1:(nSnps - 1)) { + for (i in seq_len(nSnps - 1)) { for (j in (i + 1):nSnps) { cor_matrix[i, j] <- runif(1, 0.2, 0.8) cor_matrix[j, i] <- cor_matrix[i, j] @@ -5282,11 +5279,11 @@ test_that("segment_by_dist fill regions cover all input positions", { res <- pecotmr:::segmentByDist(pos, maxDist = 2000000, minDim = 10) # Collect all fill region indices covered <- integer(0) - for (k in 1:nrow(res)) { + for (k in seq_len(nrow(res))) { covered <- c(covered, res$fillStartIdx[k]:(res$fillEndIdx[k] - 1L)) } # Every position from 1 to length(pos) should be covered - expect_equal(sort(unique(covered)), 1:length(pos)) + expect_equal(sort(unique(covered)), seq_along(pos)) }) test_that("segment_by_dist errors on empty positions", { @@ -5355,7 +5352,7 @@ test_that("segment_by_count produces valid windows", { # All window ends should be <= length(pos) + 1 expect_true(all(res$windowEndIdx <= length(pos) + 1)) # Fill regions should be within windows - for (k in 1:nrow(res)) { + for (k in seq_len(nrow(res))) { expect_true(res$fillStartIdx[k] >= res$windowStartIdx[k]) expect_true(res$fillEndIdx[k] <= res$windowEndIdx[k]) } @@ -5365,10 +5362,10 @@ test_that("segment_by_count fill regions cover all positions", { pos <- seq(1000000, by = 1000, length.out = 500) res <- pecotmr:::segmentByCount(pos, maxCount = 100) covered <- integer(0) - for (k in 1:nrow(res)) { + for (k in seq_len(nrow(res))) { covered <- c(covered, res$fillStartIdx[k]:(res$fillEndIdx[k] - 1L)) } - expect_equal(sort(unique(covered)), 1:length(pos)) + expect_equal(sort(unique(covered)), seq_along(pos)) }) test_that("segment_by_count handles centromeric gap", { @@ -5382,10 +5379,10 @@ test_that("segment_by_count handles centromeric gap", { expect_true(nrow(res) >= 2) # Fill regions should still cover all positions covered <- integer(0) - for (k in 1:nrow(res)) { + for (k in seq_len(nrow(res))) { covered <- c(covered, res$fillStartIdx[k]:(res$fillEndIdx[k] - 1L)) } - expect_equal(sort(unique(covered)), 1:length(pos)) + expect_equal(sort(unique(covered)), seq_along(pos)) }) test_that("segment_by_count skips blocks smaller than half max_count", { @@ -5447,7 +5444,7 @@ test_that("merge_windows returns exactly N rows", { ) dentist_result_by_window <- list() suppressWarnings({ - for (k in 1:nrow(window_divided_res)) { + for (k in seq_len(nrow(window_divided_res))) { idx_range <- window_divided_res$windowStartIdx[ k ]:(window_divided_res$windowEndIdx[k] - 1L) @@ -5597,21 +5594,21 @@ test_that("segment_by_dist and segment_by_count agree on even spacing", { # Both should cover all positions covered_dist <- integer(0) - for (k in 1:nrow(res_dist)) { + for (k in seq_len(nrow(res_dist))) { covered_dist <- c( covered_dist, res_dist$fillStartIdx[k]:(res_dist$fillEndIdx[k] - 1L) ) } covered_count <- integer(0) - for (k in 1:nrow(res_count)) { + for (k in seq_len(nrow(res_count))) { covered_count <- c( covered_count, res_count$fillStartIdx[k]:(res_count$fillEndIdx[k] - 1L) ) } - expect_equal(sort(unique(covered_dist)), 1:n) - expect_equal(sort(unique(covered_count)), 1:n) + expect_equal(sort(unique(covered_dist)), seq_len(n)) + expect_equal(sort(unique(covered_count)), seq_len(n)) }) test_that("both windowing modes produce same dentist results on uniform data", { @@ -6239,7 +6236,7 @@ test_that("raissSingleMatrix coerces a data.frame LD matrix and is verbose", { ref_panel <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), stringsAsFactors = FALSE @@ -6364,7 +6361,7 @@ test_that("raissSingleMatrixFromX emits no-known / no-unknown messages", { ref_panel <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), stringsAsFactors = FALSE @@ -6395,7 +6392,7 @@ test_that("raissSingleMatrixFromX emits no-known / no-unknown messages", { all_known <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), z = rnorm(p), @@ -6568,8 +6565,8 @@ ssqcOverlapImputedBlocks <- function(seed = 5) { mkBlock <- function(ids) { nb <- length(ids) m <- matrix(0, nb, nb) - for (a in 1:nb) { - for (b in 1:nb) { + for (a in seq_len(nb)) { + for (b in seq_len(nb)) { m[a, b] <- if (a == b) 1 else 0.9^abs(a - b) } } @@ -6709,7 +6706,7 @@ test_that("raissModel batch = FALSE reports the condition number", { test_that("krigingOutlierQc requires a square LD matrix aligned to zScore", { expect_error( krigingOutlierQc(c(1, 2, 3), diag(2), n = 100), - "square LD matrix" + "R \\(LD matrix\\).*Must have exactly 3 rows" ) }) @@ -7328,9 +7325,12 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { n <- length(getSampleIds(handle)) k <- length(snpIdx) f <- rnorm(n) # shared latent factor - M <- sapply(seq_len(k), function(j) { - sqrt(0.7) * f + sqrt(0.3) * rnorm(n) - }) + M <- exec( + cbind, + !!!map(seq_len(k), function(j) { + sqrt(0.7) * f + sqrt(0.3) * rnorm(n) + }) + ) rr <- GenomicRanges::GRanges( seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( @@ -7621,7 +7621,7 @@ test_that("summaryStatsQc validates the panel cutoffs before any panel read", { set.seed(1) nS <- 100L af <- c(runif(20L, 0.2, 0.4), runif(20L, 0.002, 0.01)) - dosage <- vapply(af, function(f) rbinom(nS, 2L, f), numeric(nS)) + dosage <- exec(cbind, !!!map(af, function(f) rbinom(nS, 2L, f))) ids <- sprintf("chr1:%d:A:G", 1000L * seq_along(af)) colnames(dosage) <- ids dosage[1:60, 3] <- NA @@ -8214,3 +8214,14 @@ test_that("an allele swap complements af but leaves the directionless maf", { expect_equal(h$Z, -2.0) expect_equal(h$MAF, 0.2) }) + +test_that("sumstatsQc: argument guards fire", { + expect_error( + mergeVariantInfo(data.frame(), data.frame(), all = NA), + "all.*May not be NA" + ) + expect_error( + autoDecision(data.frame(), highCorrCols = 1L), + "highCorrCols.*Must be of type 'character'" + ) +}) diff --git a/tests/testthat/test_tupleSelectors.R b/tests/testthat/test_tupleSelectors.R index 16ff494a..d1ac7660 100644 --- a/tests/testthat/test_tupleSelectors.R +++ b/tests/testthat/test_tupleSelectors.R @@ -14,9 +14,9 @@ setClass("TsTestCollection", contains = "RangedTupleList") rep(list(GenomicRanges::GRanges()), n) ) if (length(cols) > 0L) { - S4Vectors::mcols(grl) <- do.call( + S4Vectors::mcols(grl) <- exec( S4Vectors::DataFrame, - c(cols, list(check.names = FALSE)) + !!!c(cols, list(check.names = FALSE)) ) } methods::new("TsTestCollection", grl) @@ -114,7 +114,7 @@ test_that(".tupleSelectRow: non-scalar selectors error", { trait = "t1", method = "susie" ), - "must each be length 1" + "Must have length 1" ) }) @@ -212,7 +212,7 @@ test_that(".tupleSelectRowGwasFmr: non-scalar region errors", { method = "susie", region = c("r1", "r2") ), - "`region` must be length 1" + "region.*Must have length 1" ) }) @@ -472,7 +472,10 @@ test_that(".appendTraitPosCol: traitPos must be a GRanges of matching length", { test_that(".validateTraitPosColumn: reports non-GRanges and wrong-length traitPos", { expect_equal( pecotmr:::.validateTraitPosColumn(.ts_coll(traitPos = c("x", "y"))), - "'traitPos' column must be a GRanges" + str_c( + "'traitPos' column Must inherit from class 'GRanges', ", + "but has class 'character'" + ) ) # A one-range traitPos beside two rows: assigned through the mcols # listData because the parallel-length check would reject it otherwise, diff --git a/tests/testthat/test_twasWeights.R b/tests/testthat/test_twasWeights.R index ca88040b..4c4e7a00 100644 --- a/tests/testthat/test_twasWeights.R +++ b/tests/testthat/test_twasWeights.R @@ -6,7 +6,7 @@ context("twasWeights") make_data <- function(n = 50, p = 10, seed = 42, add_zero_var_col = FALSE) { set.seed(seed) X <- matrix(rnorm(n * p), nrow = n, ncol = p) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("sample_", seq_len(n)) beta <- rep(0, p) @@ -138,13 +138,11 @@ test_that(".twas_method_lookup: unknown method produces error", { ) }) -test_that(".twas_method_lookup: default args are set for susie and mrash", { +test_that(".twas_method_lookup: default args are set for mrash, not susie", { result <- pecotmr:::.twasMethodLookup("fastDefault") - expect_equal(result$susie_weights$refine, FALSE) - # Matches susieR::susie's own defaults (L = min(10, p), greedy loop off), - # as fineMappingPipeline does. - expect_equal(result$susie_weights$L, 10) - expect_null(result$susie_weights$L_greedy) + # susie carries NO fitting defaults: susieWeights extracts from a supplied + # fit and never runs susie, so `refine` / `L` would have nothing to configure. + expect_length(result$susie_weights, 0L) expect_equal(result$mrash_weights$initPriorSd, TRUE) expect_equal(result$mrash_weights$max.iter, 100) }) @@ -268,7 +266,7 @@ test_that("twasWeights: X must be a matrix", { d <- make_data() expect_error( learnTwasWeights(as.data.frame(d$X), d$Y, weightMethods = list()), - "X must be a matrix" + "X.*Must be of type 'matrix'" ) }) @@ -279,7 +277,7 @@ test_that("twasWeights: Y must be a matrix or vector", { # 1 row which mismatches X's 50 rows, triggering the row count error. expect_error( learnTwasWeights(d$X, list(d$Y), weightMethods = list()), - "The number of rows in X and Y must be the same" + "One of the following must apply" ) }) @@ -311,7 +309,7 @@ test_that("twasWeights: mismatched row counts error", { Y_short <- d$Y[1:30, , drop = FALSE] expect_error( learnTwasWeights(d$X, Y_short, weightMethods = list()), - "The number of rows in X and Y must be the same" + "Y.*Must have exactly 50 rows" ) }) @@ -588,65 +586,74 @@ test_that("twasWeightsCv: multivariate Y with multiple columns", { # # =========================================================================== -test_that("twasWeights: SuSiE-inf is fitted before and initializes ordinary SuSiE", { +test_that("learnTwasWeights refuses the susie + susieInf pair without fits", { + # The chained susieInf -> susie fit lives in fineMappingPipeline() now; + # learnTwasWeights never fine-maps, so the pair is an error here. + # fitSusieInfThenSusie() itself is covered in test_fineMappingWrappers.R. d <- make_data(n = 50, p = 10) - y_vec <- as.numeric(d$Y) - susie_calls <- list() + expect_error( + learnTwasWeights( + d$X, + as.numeric(d$Y), + weightMethods = list( + susie_weights = list(), + susie_inf_weights = list() + ) + ), + "susie, susieInf" + ) +}) + +test_that("learnTwasWeights resolves fits under camelCase method names", { + # `susieWeights` and `susie_weights` name the same method; a fit supplied + # for one spelling must land on the other's arguments too. + d <- make_data(n = 50, p = 10) + seen <- NULL local_mocked_bindings( - susieInfWeights = function(X, y, ...) rep(0, ncol(X)), - susieWeights = function(X, y, ...) { + susieWeights = function(X, y, susieFit = NULL, ...) { + seen <<- susieFit 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(...) - susie_calls[[length(susie_calls) + 1]] <<- args - make_fake_susie_fit( - p = ncol(args$X), - L = if (identical(args$unmappable_effects, "inf")) { - 7 - } else { - args$L - }, - inf = identical(args$unmappable_effects, "inf") - ) - }, - .package = "susieR" + learnTwasWeights( + d$X, + as.numeric(d$Y), + weightMethods = list(susieWeights = list()), + fittedModels = list(susie = make_fake_susie_fit(p = 10, L = 5)) ) + expect_true("susie" %in% class(seen)) +}) + +test_that("learnTwasWeights runs susie + susieInf from supplied fits", { + d <- make_data(n = 50, p = 10) + local_mocked_bindings( + susieInfWeights = function(X, y, ...) rep(0, ncol(X)), + susieWeights = function(X, y, ...) rep(0, ncol(X)) + ) result <- learnTwasWeights( d$X, - y_vec, + as.numeric(d$Y), weightMethods = list( - susie_weights = list(L = 5, L_greedy = 3), + susie_weights = list(), susie_inf_weights = list() + ), + fittedModels = list( + susie = make_fake_susie_fit(p = 10, L = 5), + susieInf = make_fake_susie_fit(p = 10, L = 7, inf = TRUE) ) ) - expect_equal(getMethodNames(result), c("susie", "susie_inf")) - expect_length(susie_calls, 2) - expect_equal(susie_calls[[1]]$unmappable_effects, "inf") - expect_equal(susie_calls[[1]]$convergence_method, "pip") - expect_equal(susie_calls[[2]]$unmappable_effects, "none") - expect_true("susieInf" %in% class(susie_calls[[2]]$model_init)) - expect_equal(susie_calls[[2]]$L_greedy, 5) }) -# =========================================================================== -# twasWeightsCv: extra split_data / sample-name / variant-selection branches -# =========================================================================== - test_that("twasWeightsCv: NA values in Y trigger NA-removal branch in metrics", { set.seed(42) n <- 30 p <- 5 X <- matrix(rnorm(n * p), nrow = n, ncol = p) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("s", seq_len(n)) Y <- matrix(rnorm(n), ncol = 1) rownames(Y) <- rownames(X) @@ -673,12 +680,12 @@ test_that("twasWeightsCv: NA values in Y trigger NA-removal branch in metrics", expect_true(is.finite(perf[1, "rsq"])) }) -test_that("twasWeightsCv: multivariate cv_args data_driven_priorMatricesCv is plumbed through", { +test_that("twasWeightsCv: dataDrivenPriorMatricesCv is plumbed through", { set.seed(42) n <- 20 p <- 4 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("s", seq_len(n)) Y <- matrix(rnorm(n * 2), nrow = n) colnames(Y) <- c("y1", "y2") @@ -703,18 +710,17 @@ test_that("twasWeightsCv: multivariate cv_args data_driven_priorMatricesCv is pl Y, fold = 2, weightMethods = list(mrmashWeights = list()), - data_driven_priorMatricesCv = prior_cv + dataDrivenPriorMatricesCv = prior_cv ) # mrmashWeights mock should have been called and received the per-fold prior # matrix under the camelCase name that actually binds mrmashWrapper's # `dataDrivenPriorMatrices` argument (the snake_case form was a latent no-op). expect_true(length(captured_args) >= 1) - expect_true(any(vapply( + expect_true(any(map_lgl( captured_args, function(a) { "dataDrivenPriorMatrices" %in% names(a) - }, - logical(1) + } ))) }) @@ -732,7 +738,7 @@ test_that("twasWeights: multivariate weights_matrix is reduced to valid_columns p <- 5 X <- matrix(rnorm(n * p), nrow = n, ncol = p) # all columns valid (no zero variance) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) Y <- matrix(rnorm(n * 2), nrow = n, ncol = 2) colnames(Y) <- c("y1", "y2") @@ -747,7 +753,7 @@ test_that("twasWeights: multivariate weights_matrix is reduced to valid_columns ncol = ncol(Y) ) rownames(m) <- c( - sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + sprintf("chr1:%d:A:G", 100L * seq_len(p)), "extra1", "extra2" ) @@ -765,7 +771,7 @@ test_that("twasWeights: multivariate weights_matrix is reduced to valid_columns expect_equal(ncol(.weightsByMethod(result, "mrmashWeights")), 2) expect_equal( rownames(.weightsByMethod(result, "mrmashWeights")), - sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + sprintf("chr1:%d:A:G", 100L * seq_len(p)) ) }) @@ -776,12 +782,14 @@ test_that("twasWeights: multivariate weights_matrix is reduced to valid_columns test_that("twasWeightsCv is reproducible with seed", { sim <- generate_X_Y(seed = 1) X <- sim$X - y = sim$Y + y <- sim$Y local_mocked_bindings( - susieWeights = function(X, y, ...) rnorm(ncol(X)), + enetWeights = function(X, y, ...) rnorm(ncol(X)), glmnetWeights = function(X, y, ...) runif(ncol(X)) ) - weight_methods_test <- list(susieWeights = list(), glmnetWeights = list()) + # Non-SuSiE methods: this test is about the seeded fold partition, and a + # SuSiE-family token now requires per-fold fits it has no reason to carry. + weight_methods_test <- list(enetWeights = list(), glmnetWeights = list()) set.seed(1) result_seed1 <- twasWeightsCv( X, @@ -803,17 +811,20 @@ test_that("twasWeightsCv is reproducible with seed", { test_that("twasWeightsCv handles errors appropriately", { sim <- generate_X_Y(seed = 1) X <- sim$X - y = sim$Y + y <- sim$Y local_mocked_bindings( susieWeights = function(X, y, ...) rnorm(ncol(X)), glmnetWeights = function(X, y, ...) runif(ncol(X)) ) weight_methods_test <- list(susieWeights = list(), glmnetWeights = list()) expect_error(twasWeightsCv(X, y, fold = NULL), "fold.*samplePartitions") - expect_error(twasWeightsCv(X, y, fold = "invalid"), "positive integer") - expect_error(twasWeightsCv(X, y, fold = -1), "positive integer") - expect_error(twasWeightsCv(2, y, fold = 2), "must be a matrix") - expect_error(twasWeightsCv(X, 2, fold = 2), "number of rows") + expect_error( + twasWeightsCv(X, y, fold = "invalid"), + "Must be of type 'count'" + ) + expect_error(twasWeightsCv(X, y, fold = -1), "Must be >= 1") + expect_error(twasWeightsCv(2, y, fold = 2), "Must be of type 'matrix'") + expect_error(twasWeightsCv(X, 2, fold = 2), "Y.*Must have exactly 10 rows") expect_error( twasWeightsCv( matrix(rnorm(4, nrow = 2)), @@ -829,7 +840,7 @@ test_that("twasWeightsCv handles errors appropriately", { test_that("learnTwasWeights handles errors appropriately", { sim <- generate_X_Y(seed = 1) X <- sim$X - y = sim$Y + y <- sim$Y local_mocked_bindings( susieWeights = function(X, y, ...) rnorm(ncol(X)), glmnetWeights = function(X, y, ...) runif(ncol(X)) @@ -840,7 +851,7 @@ test_that("learnTwasWeights handles errors appropriately", { matrix(rnorm(4, nrow = 2)), matrix(rnorm(2, nrow = 1)) ), - "unused argument" + "weightMethods.*is missing" ) expect_error(learnTwasWeights(X, y), "weightMethods") }) @@ -1343,26 +1354,24 @@ test_that(".resolveMethodFunction: unresolvable key falls back to the key itself # # =========================================================================== -test_that(".prepareSusieWeightMethods: seeds susie_weights from a supplied susieInf fit (vector Y)", { - d <- make_data(n = 40, p = 8) - y_vec <- as.numeric(d$Y) # vector -> exercises the Y matrix coercion +test_that(".prepareSusieWeightMethods writes supplied fits onto the method args", { infFit <- make_fake_susie_fit(p = 8, L = 3, inf = TRUE) + susieFit <- make_fake_susie_fit(p = 8, L = 5) wm <- pecotmr:::.prepareSusieWeightMethods( - d$X, - y_vec, weightMethods = list( - susie_weights = list(L = 5), + susie_weights = list(), susie_inf_weights = list() ), - fittedModels = list(susieInf = infFit) + fittedModels = list(susie = susieFit, susieInf = infFit) ) - # The supplied susieInf fit is class-tagged and propagated onto susie_inf_weights, - # and susie_weights is rebuilt from it (model_init carries the inf fit). + # Each supplied fit is class-tagged and lands on its own method's args. + # susie's fitting arguments are NOT derived from the inf fit: that + # prepares a susie fit, which belongs to fineMappingPipeline(). expect_true("susieInf" %in% class(wm$susie_inf_weights$susieInfFit)) - expect_true("susieInf" %in% class(wm$susie_weights$model_init)) - expect_equal(wm$susie_weights$unmappable_effects, "none") + expect_true("susie" %in% class(wm$susie_weights$susieFit)) + expect_null(wm$susie_weights$model_init) }) # =========================================================================== @@ -1390,7 +1399,7 @@ test_that("twasWeightsCv: mvsusie per-fold reweighted prior is plumbed (verbose= n <- 24 p <- 4 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("s", seq_len(n)) Y <- matrix(rnorm(n * 2), nrow = n) colnames(Y) <- c("y1", "y2") @@ -1410,22 +1419,27 @@ test_that("twasWeightsCv: mvsusie per-fold reweighted prior is plumbed (verbose= ) prior_cv <- list(matrix(1, 2, 2), matrix(2, 2, 2)) set.seed(1) + # A SuSiE-family token needs that fold's own fit; the fitter is mocked + # here, so a stub per fold is enough to reach the per-fold prior path. + sp <- suppressMessages(twasWeightsCv(X, Y, fold = 2))$samplePartition + foldFits <- list(fold_1 = "FIT1", fold_2 = "FIT2") + attr(foldFits, "partitionKey") <- pecotmr:::.cvPartitionKey(sp) result <- suppressMessages(twasWeightsCv( X, Y, - fold = 2, + samplePartitions = sp, weightMethods = list(mvsusieWeights = list()), reweightedMixturePriorCv = prior_cv, + fittedModelsCv = list(mvsusie = foldFits), verbose = 2 )) expect_true("prediction" %in% names(result)) # the per-fold prior_variance was forwarded to the multivariate fitter - expect_true(any(vapply( + expect_true(any(map_lgl( captured, function(a) { "prior_variance" %in% names(a) - }, - logical(1) + } ))) }) @@ -1434,7 +1448,7 @@ test_that("twasWeightsCv: retainFits forwards retainFit to a multivariate fitter n <- 24 p <- 4 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("s", seq_len(n)) Y <- matrix(rnorm(n * 2), nrow = n) colnames(Y) <- c("y1", "y2") @@ -1461,10 +1475,9 @@ test_that("twasWeightsCv: retainFits forwards retainFit to a multivariate fitter retainFits = TRUE )) expect_true("foldFits" %in% names(result)) - expect_true(all(vapply( + expect_true(all(map_lgl( captured, - function(a) isTRUE(a$retainFit), - logical(1) + function(a) isTRUE(a$retainFit) ))) }) @@ -1500,7 +1513,7 @@ test_that("learnTwasWeights: multivariate fitter with retainFits + verbose=2 (fi n <- 24 p <- 5 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("s", seq_len(n)) Y <- matrix(rnorm(n * 2), nrow = n) colnames(Y) <- c("y1", "y2") @@ -1598,11 +1611,11 @@ test_that("twasPredict: accepts a TwasWeights S4 collection", { w1 <- rnorm(p) w2 <- rnorm(p) e1 <- twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = w1 ) e2 <- twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = w2 ) tw <- TwasWeights( @@ -1629,14 +1642,11 @@ test_that("validity names the missing key and payload columns", { data(twasWeightsExample) bad <- twasWeightsExample S4Vectors::mcols(bad)$method <- NULL - expect_equal( - pecotmr:::.twasValidateRequiredCols(bad), - "missing columns: method" - ) - expect_equal( - pecotmr:::.twasValidateRequiredCols(twasWeightsExample), - character() + expect_error( + methods::validObject(bad), + "missing elements \\{'method'\\}" ) + expect_true(methods::validObject(twasWeightsExample)) bad2 <- twasWeightsExample S4Vectors::mcols(bad2)$cvResult <- NULL expect_equal( @@ -1673,15 +1683,17 @@ test_that(".twasApplyRownames leaves weights alone when X has no colnames", { test_that(".twasBadColMsg names the offending column and its class", { expect_equal( - as.character(pecotmr:::.twasBadColMsg("study", data.frame(study = 1:2))), + as.character(pecotmr:::.twasBadColMsg( + "study", + data.frame(study = 1:2) + )), "'study' column must be character (got integer)" ) }) test_that(".twasMethodRows keeps a per-outcome context vector", { vids <- c("chr1:100:A:G", "chr1:200:C:T") - Y <- matrix(0, nrow = 4L, ncol = 2L, - dimnames = list(NULL, c("y1", "y2"))) + Y <- matrix(0, nrow = 4L, ncol = 2L, dimnames = list(NULL, c("y1", "y2"))) wMat <- matrix( c(0.1, 0.2, 0.3, 0.4), nrow = 2L, @@ -1689,25 +1701,327 @@ test_that(".twasMethodRows keeps a per-outcome context vector", { ) mkCtx <- function(contexts) { list( - Y = Y, trait = c("t1", "t2"), context = contexts, study = "s1", - retainFits = FALSE, standardized = TRUE, dataType = "rnaseq" + Y = Y, + trait = c("t1", "t2"), + context = contexts, + study = "s1", + retainFits = FALSE, + standardized = TRUE, + dataType = "rnaseq" ) } # One context per outcome column: used as-is, not recycled. perOutcome <- pecotmr:::.twasMethodRows( - "lasso_weights", wMat, vids, mkCtx(c("cA", "cB")) + "lasso_weights", + wMat, + vids, + mkCtx(c("cA", "cB")) ) expect_length(perOutcome, 2L) expect_equal( - vapply(perOutcome, function(z) z$context, character(1)), + map_chr(perOutcome, function(z) z$context), c("cA", "cB") ) # A single context is recycled across the outcomes instead. recycled <- pecotmr:::.twasMethodRows( - "lasso_weights", wMat, vids, mkCtx("cOnly") + "lasso_weights", + wMat, + vids, + mkCtx("cOnly") ) expect_equal( - vapply(recycled, function(z) z$context, character(1)), + map_chr(recycled, function(z) z$context), c("cOnly", "cOnly") ) }) + +test_that("twasWeightsCv: argument guards fire", { + d <- generate_X_Y(seed = 1) + base <- list(X = d$X, Y = d$Y, fold = 2, weightMethods = list()) + expect_error( + exec( + twasWeightsCv, + !!!list_modify(base, !!!list(samplePartitions = 1L)) + ), + "samplePartitions.*Must be of type 'data.frame'" + ) + expect_error( + exec(twasWeightsCv, !!!list_modify(base, !!!list(maxNumVariants = 0))), + "maxNumVariants.*is not >= 1" + ) + expect_error( + exec(twasWeightsCv, !!!list_modify(base, !!!list(numThreads = 1.5))), + "numThreads.*Must be of type 'single integerish value'" + ) + expect_error( + exec(twasWeightsCv, !!!list_modify(base, !!!list(retainFits = NA))), + "retainFits.*May not be NA" + ) + expect_error( + exec(twasWeightsCv, !!!list_modify(base, !!!list(seed = "x"))), + "seed.*Must be of type 'single integerish value'" + ) + # Inf is the documented "no cap" sentinel and must still be accepted. + expect_no_error( + exec(twasWeightsCv, !!!list_modify(base, !!!list(maxNumVariants = Inf))) + ) +}) + +test_that("learnTwasWeights: argument guards fire", { + d <- generate_X_Y(seed = 1) + base <- list(X = d$X, Y = d$Y, weightMethods = list()) + expect_error( + exec(learnTwasWeights, !!!list_modify(base, !!!list(study = 1L))), + "study.*Must be of type 'string'" + ) + # Called directly, not via modifyList(): modifyList() DROPS an element + # whose value is NULL, so the argument would fall back to its default. + expect_error( + learnTwasWeights( + d$X, + d$Y, + weightMethods = list(), + standardized = NULL + ), + "standardized.*Must be of type 'logical flag'" + ) + expect_error( + exec(learnTwasWeights, !!!list_modify(base, !!!list(dataType = 1L))), + "dataType.*Must be of type 'string'" + ) + expect_error( + exec( + learnTwasWeights, + !!!list_modify(base, !!!list(weightMethods = 1L)) + ), + "weightMethods.*One of the following must apply" + ) +}) + +test_that("twasPredict: weightsList must be a list or TwasWeights", { + expect_error( + twasPredict(matrix(0, 2, 2), "nope"), + "weightsList.*One of the following must apply" + ) +}) + +# --------------------------------------------------------------------------- +# Cross-validating a SuSiE-family method. Those wrappers extract from a +# supplied fit and never fine-map, so CV is only possible when +# fineMappingPipeline's own CV retained each fold's fit. +# --------------------------------------------------------------------------- + +.twcv_foldFits <- function(seed = 11, fold = 3) { + set.seed(seed) + data(eqtlRegionExample) + X <- eqtlRegionExample$X[, 1:40] + y <- eqtlRegionExample$yRes + Y <- matrix(y, ncol = 1, dimnames = list(rownames(X), "t1")) + cv <- pecotmr:::.fmWeightsCv( + X, + Y, + tokens = "susie", + methodArgs = list(), + fold = fold, + verbose = 0, + seed = 1 + ) + list(X = X, Y = Y, cv = cv, slice = pecotmr:::.fmSliceCv(cv, "susie")) +} + +test_that("fineMappingPipeline CV retains a lean per-fold fit", { + skip_if_not_installed("susieR") + f <- suppressMessages(.twcv_foldFits()) + expect_false(is.null(f$cv$foldFits)) + expect_equal(names(f$cv$foldFits), c("fold_1", "fold_2", "fold_3")) + # lean: only the fields the weight extractors read + fit1 <- f$cv$foldFits[["fold_1"]][["susie"]] + expect_true(all(c("pip", "alpha", "mu") %in% names(fit1))) + expect_false("lbf_variable" %in% names(fit1)) + # and it slices per method onto the row payload + expect_equal(names(f$slice$foldFits), c("fold_1", "fold_2", "fold_3")) +}) + +test_that("twasWeightsCv cannot cross-validate susie without the fold fits", { + skip_if_not_installed("susieR") + f <- suppressMessages(.twcv_foldFits()) + expect_error( + suppressMessages(twasWeightsCv( + f$X, + f$Y, + samplePartitions = f$slice$samplePartition, + weightMethods = list(susie_weights = list()), + verbose = 0 + )), + "never run fine-mapping themselves" + ) +}) + +test_that("twasWeightsCv cross-validates susie from the retained fold fits", { + skip_if_not_installed("susieR") + f <- suppressMessages(.twcv_foldFits()) + out <- suppressMessages(twasWeightsCv( + f$X, + f$Y, + samplePartitions = f$slice$samplePartition, + weightMethods = list(susie_weights = list()), + fittedModelsCv = list(susie = f$slice$foldFits), + verbose = 0 + )) + expect_true(all(c("prediction", "performance") %in% names(out))) + expect_false(is.null(out$prediction)) +}) + +test_that(".twasFoldFit injects the fold's fit under the adapter's fit arg", { + ff <- list(susie = list(fold_1 = "FIT1", fold_2 = "FIT2")) + a <- pecotmr:::.twasFoldFit(list(), "susie_weights", 2L, ff) + expect_identical(a$susieFit, "FIT2") + # a method with no fine-mapping adapter is untouched + b <- pecotmr:::.twasFoldFit(list(), "lasso_weights", 1L, ff) + expect_length(b, 0L) + # and so is the NULL case + expect_length(pecotmr:::.twasFoldFit(list(), "susie_weights", 1L, NULL), 0L) +}) + +test_that("twasWeightsCv refuses fold fits from a different partition", { + skip_if_not_installed("susieR") + f <- suppressMessages(.twcv_foldFits()) + wm <- list(susie_weights = list()) + + # (a) no partition at all: a freshly drawn one would score each fold with + # a fit that saw its held-out samples. + expect_error( + suppressMessages(twasWeightsCv( + f$X, + f$Y, + weightMethods = wm, + verbose = 0, + fittedModelsCv = list(susie = f$slice$foldFits) + )), + "needs the fold partition" + ) + + # (b) fits with no fingerprint cannot be shown to match. + unstamped <- f$slice$foldFits + attr(unstamped, "partitionKey") <- NULL + expect_error( + suppressMessages(twasWeightsCv( + f$X, + f$Y, + weightMethods = wm, + verbose = 0, + samplePartitions = f$slice$samplePartition, + fittedModelsCv = list(susie = unstamped) + )), + "no partition fingerprint" + ) + + # (c) a genuinely different split is caught by the fingerprint. + other <- suppressMessages(pecotmr:::.fmWeightsCv( + f$X, + f$Y, + tokens = "susie", + methodArgs = list(), + fold = 3, + verbose = 0, + seed = 77 + )) + expect_error( + suppressMessages(twasWeightsCv( + f$X, + f$Y, + weightMethods = wm, + verbose = 0, + samplePartitions = other$samplePartition, + fittedModelsCv = list(susie = f$slice$foldFits) + )), + "trained on a different fold partition" + ) +}) + +test_that(".cvPartitionKey ignores row order but not fold assignment", { + sp <- data.frame(Sample = c("s1", "s2", "s3"), Fold = c(1L, 2L, 1L)) + shuffled <- sp[c(3, 1, 2), ] + expect_identical( + pecotmr:::.cvPartitionKey(sp), + pecotmr:::.cvPartitionKey(shuffled) + ) + moved <- sp + moved$Fold <- c(1L, 1L, 2L) + expect_false(identical( + pecotmr:::.cvPartitionKey(sp), + pecotmr:::.cvPartitionKey(moved) + )) +}) + +# --------------------------------------------------------------------------- +# Up-front gate: a SuSiE-family method without its fit is refused before any +# fitting work, rather than surfacing from inside the per-fold map. +# --------------------------------------------------------------------------- + +test_that("learnTwasWeights refuses a susie token with no fit", { + skip_if_not_installed("susieR") + set.seed(11) + data(eqtlRegionExample) + X <- eqtlRegionExample$X[, 1:40] + Y <- matrix( + eqtlRegionExample$yRes, + ncol = 1, + dimnames = list(rownames(X), "t1") + ) + expect_error( + suppressMessages(learnTwasWeights( + X, + Y, + weightMethods = list(susie_weights = list()), + verbose = 0 + )), + "never run fine-mapping themselves" + ) + # supplying it through fittedModels satisfies the gate + fit <- suppressMessages(susieR::susie(X, Y[, 1], L = 5)) + expect_no_error(suppressMessages(learnTwasWeights( + X, + Y, + weightMethods = list(susie_weights = list()), + fittedModels = list(susie = fit), + verbose = 0 + ))) + # a method with no fine-mapping adapter is unaffected + expect_no_error(suppressMessages(learnTwasWeights( + X, + Y, + weightMethods = list(lasso_weights = list()), + verbose = 0 + ))) +}) + +test_that("twasWeightsCv refuses a susie token with no per-fold fits", { + skip_if_not_installed("susieR") + f <- suppressMessages(.twcv_foldFits()) + expect_error( + suppressMessages(twasWeightsCv( + f$X, + f$Y, + samplePartitions = f$slice$samplePartition, + weightMethods = list(susie_weights = list()), + verbose = 0 + )), + "needs that fold's own fit" + ) +}) + +test_that(".twasSusieTokensRequested matches both method spellings", { + expect_equal( + pecotmr:::.twasSusieTokensRequested(list(susie_weights = list())), + "susie" + ) + expect_equal( + pecotmr:::.twasSusieTokensRequested(c("mvsusieWeights")), + "mvsusie" + ) + expect_length( + pecotmr:::.twasSusieTokensRequested(list(lasso_weights = list())), + 0L + ) +}) diff --git a/tests/testthat/test_twasWeightsPipeline.R b/tests/testthat/test_twasWeightsPipeline.R index 7f7d0604..1682c469 100644 --- a/tests/testthat/test_twasWeightsPipeline.R +++ b/tests/testthat/test_twasWeightsPipeline.R @@ -25,7 +25,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") path = "/tmp/tp.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -78,7 +78,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") ) { gh <- .tp_makeHandle(snp_n = 20L, n_samples = n_samples) phen <- setNames( - lapply(contexts, function(.) { + map(contexts, function(.) { .tp_makeSe(traits = traits, n_samples = n_samples) }), contexts @@ -146,7 +146,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") method = method, stringsAsFactors = FALSE ) - entries <- lapply(seq_len(nrow(rows)), function(i) { + entries <- map(seq_len(nrow(rows)), function(i) { if (is.null(fitPayload)) { fitPayload <- list( method = rows$method[[i]], @@ -155,7 +155,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") ) } tl <- data.frame( - variant_id = sprintf("chr1:%d:A:G", 100L * (seq_len(3L))), + variant_id = sprintf("chr1:%d:A:G", 100L * seq_len(3L)), pip = c(0.9, 0.5, 0.1), stringsAsFactors = FALSE ) @@ -214,7 +214,7 @@ test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers" list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights() ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages( twasWeightsPipeline( qd, @@ -256,9 +256,9 @@ test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers" test_that("twasWeightsPipeline(QtlDataset): mafCutoff/xvarCutoff overrides tighten the variant set", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights(), list(.package = "pecotmr") @@ -304,7 +304,7 @@ test_that("twasWeightsPipeline(QtlDataset): contexts filter restricts the per-co list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights() ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages( twasWeightsPipeline( qd, @@ -379,7 +379,7 @@ test_that("twasWeightsPipeline(QtlDataset): RSS-only method rejected", { studies <- rep("s1", n_entries) contexts <- if (n_entries == 1L) "c1" else paste0("c", seq_len(n_entries)) traits <- rep("t1", n_entries) - entries <- lapply(seq_len(n_entries), function(.) .tp_makeSumstatsEntry()) + entries <- map(seq_len(n_entries), function(.) .tp_makeSumstatsEntry()) QtlSumStats( study = studies, context = contexts, @@ -408,7 +408,7 @@ test_that("twasWeightsPipeline(QtlSumStats): runs end-to-end with mocked solvers list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockSumstatWeights() ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) # Method tokens are the bare short names; the QtlSumStats dispatch # resolves them to the *Rss impl via the .twasMethodCapabilities table. # Fine-mapping methods (susie / susieInf / etc.) require a @@ -455,7 +455,7 @@ test_that("twasWeightsPipeline(QtlSumStats): per-method failure surfaces as warn mocks$lassosumRssWeights <- function(stat, LD, ...) { stop("synthetic test failure") } - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) # All entries fail -> the per-method-warning fires *and* the pipeline # then errors out (no rows produced). Capture both. expect_error( @@ -571,7 +571,7 @@ test_that("gate: non-FineMappingResult object passed in errors", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") expect_error( twasWeightsPipeline(qd, methods = "susie", fineMappingResult = list()), - "must be a FineMappingResult" + "Must inherit from class 'FineMappingResultBase'" ) }) @@ -606,7 +606,7 @@ test_that("gate: QtlDataset + susie + fineMappingResult threads the susieFit", { rep(0, ncol(X)) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, @@ -643,7 +643,7 @@ test_that("gate: QtlSumStats + susie + fineMappingResult threads the susieRssFit rep(0, nrow(LD)) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -674,7 +674,7 @@ test_that("gate: QtlSumStats + susieAsh + fineMappingResult threads the susieAsh rep(0, nrow(LD)) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -704,7 +704,7 @@ test_that("gate: missing matching tuple in fineMappingResult warns and skips", { list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockSumstatWeights() ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) expect_error( suppressWarnings(suppressMessages( twasWeightsPipeline( @@ -749,7 +749,7 @@ test_that("twasWeightsPipeline(QtlDataset): mvsusie multivariate path returns on ) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, @@ -787,7 +787,7 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash multivariate path with 2 tra ) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, @@ -833,7 +833,7 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the w } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, @@ -871,7 +871,7 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the positions = seq(100L, by = 100L, length.out = 8L) ) { n <- length(contexts) - entries <- lapply(seq_len(n), function(i) { + entries <- map(seq_len(n), function(i) { # Same SNP order across contexts -- required by the multivariate path # (it errors on any divergence after summaryStatsQc). .tp_makeSumstatsEntry(snp_ids = snp_ids, positions = positions) @@ -913,7 +913,7 @@ test_that("twasWeightsPipeline(QtlSumStats): mvsusie multivariate path returns o ) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -944,7 +944,7 @@ test_that("twasWeightsPipeline(QtlSumStats): mr.mash multivariate solver failure stop("synthetic multivariate failure") } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) # All multivariate fits fail -> no rows -> the pipeline errors out at the # end, surfacing the per-group warning along the way. expect_error( @@ -987,7 +987,7 @@ test_that("twasWeightsPipeline(QtlDataset): full cache hit avoids all weight fit rep(0, ncol(X)) }) ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages( twasWeightsPipeline( qd, @@ -1030,7 +1030,7 @@ test_that("twasWeightsPipeline(QtlDataset): partial cache hit fits only missing } ) ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages( twasWeightsPipeline( qd, @@ -1067,7 +1067,7 @@ test_that("twasWeightsPipeline(QtlSumStats): cache hit on a per-tuple basis", { rssCalls <<- rssCalls + 1L rep(0, nrow(LD)) } - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -1164,7 +1164,7 @@ test_that("twasWeightsPipeline: mr.mash and mvSuSiE fit side by side", { mkW(X, Y) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, @@ -1218,7 +1218,7 @@ make_cv_result <- function(n = 100, K = 4, seed = 1, method_quality = NULL) { pred_names <- paste0(method_names, "_predicted") prediction <- setNames( - lapply(seq_len(K), function(k) { + map(seq_len(K), function(k) { noise_sd <- method_quality[k] pred <- y + rnorm(n, sd = noise_sd) mat <- matrix(pred, ncol = 1) @@ -1231,7 +1231,7 @@ make_cv_result <- function(n = 100, K = 4, seed = 1, method_quality = NULL) { # Dummy performance (not used by ensembleWeights) performance <- setNames( - lapply(seq_len(K), function(k) { + map(seq_len(K), function(k) { m <- matrix(NA, nrow = 1, ncol = 6) colnames(m) <- c("corr", "rsq", "adj_rsq", "pval", "RMSE", "MAE") m @@ -1257,9 +1257,9 @@ make_cv_result <- function(n = 100, K = 4, seed = 1, method_quality = NULL) { make_weight_list <- function(p = 20, method_names, seed = 2) { set.seed(seed) setNames( - lapply(method_names, function(m) { + map(method_names, function(m) { w <- matrix(rnorm(p), ncol = 1) - rownames(w) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + rownames(w) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) colnames(w) <- "outcome_1" w }), @@ -1536,7 +1536,7 @@ test_that("ensembleWeights: end-to-end with twasWeightsCv output", { n <- 100 p <- 20 X <- matrix(rnorm(n * p), nrow = n, ncol = p) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("sample_", seq_len(n)) beta <- c(1.5, -1.0, 0.8, rep(0, p - 3)) @@ -2105,10 +2105,10 @@ context("twasWeights internal helpers (extra)") .tw_makeFmEntry <- function(method_tag = "susie", n = 3) { fineMappingRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(n)), susieFit = list(payload = method_tag), topLoci = data.frame( - variant_id = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), + variant_id = sprintf("chr1:%d:A:G", 100L * seq_len(n)), pip = seq(0.9, by = -0.1, length.out = n), stringsAsFactors = FALSE ) @@ -2133,7 +2133,7 @@ test_that(".twasFineMappingFits: non-FineMappingResult input errors", { context = "c1", trait = "t1" ), - "must be a FineMappingResult or NULL" + "Must inherit from class 'FineMappingResultBase'" ) }) @@ -2292,10 +2292,15 @@ test_that(".twasMergeRegionEntries rbinds matrix weights across regions", { expect_true(is.matrix(w)) expect_equal(dim(w), c(4L, 2L)) expect_equal(colnames(w), c("cA", "cB")) - expect_equal(rownames(w), c( - "chr1:100:A:G", "chr1:200:A:G", - "chr1:300:A:G", "chr1:400:A:G" - )) + expect_equal( + rownames(w), + c( + "chr1:100:A:G", + "chr1:200:A:G", + "chr1:300:A:G", + "chr1:400:A:G" + ) + ) expect_equal(unname(w[, "cA"]), c(0.1, 0.2, 0.5, 0.6)) expect_equal(unname(w[, "cB"]), c(0.3, 0.4, 0.7, 0.8)) expect_equal(names(getFits(m)), c("r1", "r2")) @@ -2338,12 +2343,18 @@ test_that(".twasMergedEntryForRow gathers one key across regions", { test_that(".twasMergedEntryForRow returns NULL when no region matches", { data(twasWeightsExample) bad <- data.frame( - study = "nope", context = "x", trait = "y", method = "z", + study = "nope", + context = "x", + trait = "y", + method = "z", stringsAsFactors = FALSE ) expect_null( pecotmr:::.twasMergedEntryForRow( - 1L, bad, list(twasWeightsExample), "rA" + 1L, + bad, + list(twasWeightsExample), + "rA" ) ) }) @@ -2363,9 +2374,9 @@ test_that("twasWeightsPipeline(QtlDataset): region + cisWindow is rejected", { test_that("twasWeightsPipeline(QtlDataset): jointRegions=FALSE concatenates per-region weights", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights(), list(.package = "pecotmr") @@ -2402,9 +2413,9 @@ test_that("twasWeightsPipeline(QtlDataset): jointRegions=FALSE concatenates per- test_that("twasWeightsPipeline(QtlDataset): jointRegions=TRUE fits one concatenated block", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights(), list(.package = "pecotmr") @@ -2441,9 +2452,9 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash jointRegions=FALSE concatena contexts = c("brain", "liver"), traits = c("ENSG_A", "ENSG_B") ) - do.call( + exec( local_mocked_bindings, - c( + !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), mrmashWeights = function(X, Y, ...) { @@ -2639,7 +2650,7 @@ test_that(".rbindTwasWeights: concatenates two collections and rejects non-TwasW expect_setequal(as.character(out$method), c("lasso", "enet")) expect_error( pecotmr:::.rbindTwasWeights(list(), .tp_tw()), - "expects two TwasWeights" + "Must inherit from class 'TwasWeights'" ) }) @@ -2811,7 +2822,7 @@ test_that(".solveEnsembleLbfgsb: solver failure and all-zero solution fall back .tp_predBlock <- function(n = 30L, methods = c("a", "b")) { samp <- paste0("s", seq_len(n)) setNames( - lapply(methods, function(.) { + map(methods, function(.) { matrix(rnorm(n), n, 1, dimnames = list(samp, NULL)) }), paste0(methods, "_predicted") @@ -2959,9 +2970,9 @@ test_that("twasWeightsPipeline(QtlDataset): fitFullData=FALSE without CV errors" test_that("twasWeightsPipeline(QtlDataset): mashPrior with no mrmash warns and is ignored", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights(), list(.package = "pecotmr") @@ -3021,9 +3032,9 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec mr.mash + univariate lasso trait = "ENSG_A", method = "mrmash" ) - do.call( + exec( local_mocked_bindings, - c( + !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), .twasDispatchJointSpecsQtlDataset = function(...) jointRes @@ -3049,9 +3060,9 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec mr.mash + univariate lasso test_that("twasWeightsPipeline(QtlDataset): region selects overlapping traits", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = c("ENSG_A", "ENSG_B")) # @1000, @2000 - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights(), list(.package = "pecotmr") @@ -3076,14 +3087,17 @@ test_that("twasWeightsPipeline(QtlDataset): region selects overlapping traits", test_that("twasWeightsPipeline(QtlSumStats): NULL methods uses the default RSS preset", { ss <- .tp_makeQtlSumStats() - do.call( + exec( local_mocked_bindings, - c( + !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), - prsCsWeights = function(stat, LD, ...) rep(0, nrow(LD)), - sdprWeights = function(stat, LD, ...) rep(0, nrow(LD)) + prsCsWeights = function(stat, LD, ...) rep(0, nrow(LD)) ), + # .tp_mockSumstatWeights() already mocks sdprWeights. Passing a + # binding to local_mocked_bindings() twice makes it record the + # first mock as the "original", so unwinding restores the mock + # instead of the real function and it leaks for the session. .tp_mockSumstatWeights(), list(.package = "pecotmr") ) @@ -3097,9 +3111,9 @@ test_that("twasWeightsPipeline(QtlSumStats): NULL methods uses the default RSS p test_that("twasWeightsPipeline(QtlSumStats): named-list methods and invalid type", { ss <- .tp_makeQtlSumStats() - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockSumstatWeights(), list(.package = "pecotmr") @@ -3117,9 +3131,9 @@ test_that("twasWeightsPipeline(QtlSumStats): named-list methods and invalid type test_that("twasWeightsPipeline(QtlSumStats): traitId filter selects matching rows", { ss <- .tp_makeQtlSumStats() - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockSumstatWeights(), list(.package = "pecotmr") @@ -3137,9 +3151,9 @@ test_that("twasWeightsPipeline(QtlSumStats): traitId filter selects matching row test_that("twasWeightsPipeline(QtlSumStats): multivariate mr.mash returns a column per context", { ss <- .tp_makeQtlSumStats(n_entries = 2L) # 2 contexts of (s1, t1) - do.call( + exec( local_mocked_bindings, - c( + !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), mrmashRssWeights = function(stat, LD, ...) { @@ -3192,9 +3206,9 @@ test_that("twasWeightsPipeline(QtlSumStats): fine-mapping method absent from fin test_that("twasWeightsPipeline(MultiStudyQtlDataset): recurses into components and rbinds", { mt <- .tp_makeMultiStudy() - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights(), .tp_mockSumstatWeights(), @@ -3258,9 +3272,9 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec mr.mash + univar trait = "t1", method = "mrmash" ) - do.call( + exec( local_mocked_bindings, - c( + !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), .twasDispatchJointSpecsMultiStudy = function(...) jointRes @@ -3344,9 +3358,9 @@ test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash + univariate lass trait = "t1", method = "mrmash" ) - do.call( + exec( local_mocked_bindings, - c( + !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), .twasDispatchJointSpecsQtlSumStats = function(...) jointRes @@ -3367,7 +3381,7 @@ test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash + univariate lass test_that("twasWeightsPipeline(QtlSumStats): a single-context (study, trait) group is skipped for mr.mash", { # t1 has 2 contexts (processed); t2 has 1 context (skipped at the < 2 guard). - entries <- lapply(1:3, function(.) .tp_makeSumstatsEntry()) + entries <- map(1:3, function(.) .tp_makeSumstatsEntry()) ss <- QtlSumStats( study = rep("s1", 3), context = c("c1", "c2", "c1"), @@ -3864,7 +3878,7 @@ test_that(".twasMvThreadFit warns and returns NULL when the fit is absent", { "S1", "T1", c("cA", "cB"), - list(fineMappingResult = NULL) + fineMappingResult = NULL ), "no 'mvsusie' fit found" ) @@ -3872,16 +3886,20 @@ test_that(".twasMvThreadFit warns and returns NULL when the fit is absent", { }) test_that(".twasQssMultivariateFitOne returns no rows when the fit is absent", { - p <- list( - fineMappingResult = NULL, - methodArgs = list(), - retainFitDetail = FALSE - ) # mvsusie carries an adapter, so the missing pre-fit short-circuits # before any weight function is called. expect_warning( rows <- pecotmr:::.twasQssMultivariateFitOne( - "mvsusie", "S1", "T1", c("cA", "cB"), NULL, NULL, p + "mvsusie", + "S1", + "T1", + c("cA", "cB"), + NULL, + NULL, + methodArgs = list(), + retainFitDetail = FALSE, + fineMappingResult = NULL, + dataType = NULL ), "no 'mvsusie' fit found" ) @@ -3893,14 +3911,22 @@ test_that(".twasQssMultivariateFitOne promotes vector weights to a matrix", { stat = NULL, variantIds = c("chr1:1:A:G", "chr1:2:A:G") ) - p <- list(methodArgs = list(), retainFitDetail = FALSE, dataType = "rnaseq") local_mocked_bindings( .twasTryWeights = function(...) c(0.5, 0.25), .package = "pecotmr" ) # mrmash has no adapter, so the thread-fit branch is skipped entirely. rows <- pecotmr:::.twasQssMultivariateFitOne( - "mrmash", "S1", "T1", "cA", mvStat, NULL, p + "mrmash", + "S1", + "T1", + "cA", + mvStat, + NULL, + methodArgs = list(), + retainFitDetail = FALSE, + fineMappingResult = NULL, + dataType = "rnaseq" ) expect_length(rows, 1L) expect_equal(rows[[1L]]$context, "cA") @@ -3910,7 +3936,7 @@ test_that(".twasQssMultivariateFitOne promotes vector weights to a matrix", { test_that(".twasQssAssemble passes the joint result through alone", { jr <- "SENTINEL_JOINT" expect_identical( - pecotmr:::.twasQssAssemble(list(), jr, list(ldSketch = NULL)), + pecotmr:::.twasQssAssemble(list(), jr, ldSketch = NULL), jr ) }) @@ -3920,15 +3946,22 @@ test_that(".twasMsJointPhase aborts when only mrmash asked and it fails", { .twasDispatchJointSpecsMultiStudy = function(...) NULL, .package = "pecotmr" ) - p <- list( - methods = "mrmash", data = NULL, contexts = NULL, traitId = NULL, - cisWindow = NULL, verbose = FALSE, retainFit = FALSE, - retainFitDetail = FALSE, seed = 1L - ) # Stripping mrmash leaves nothing, so a NULL joint result is fatal # rather than a fall-through to the per-tuple phase. expect_error( - pecotmr:::.twasMsJointPhase(p, list(spec1 = "x"), NULL), + pecotmr:::.twasMsJointPhase( + list(spec1 = "x"), + NULL, + data = NULL, + methods = "mrmash", + contexts = NULL, + traitId = NULL, + cisWindow = NULL, + verbose = FALSE, + retainFit = FALSE, + retainFitDetail = FALSE, + seed = 1L + ), "no joint fits produced" ) }) diff --git a/tests/testthat/test_variantId.R b/tests/testthat/test_variantId.R index 0838e95f..6bdbb126 100644 --- a/tests/testthat/test_variantId.R +++ b/tests/testthat/test_variantId.R @@ -1199,12 +1199,46 @@ test_that(".harmonizeRestoreUnmatched is a no-op when nothing is unmatched", { withExtra <- rbind( targetData, data.frame( - chrom = "chr1", pos = 300L, A1 = "A", A2 = "G", + chrom = "chr1", + pos = 300L, + A1 = "A", + A2 = "G", stringsAsFactors = FALSE ) ) appended <- pecotmr:::.harmonizeRestoreUnmatched( - result, matchResult, withExtra + result, + matchResult, + withExtra ) expect_equal(nrow(appended$result), 3L) }) + +test_that("parseVariantId: rejects input that is neither character nor df", { + expect_error(parseVariantId(1:3), "One of the following must apply") +}) + +test_that("normalizeVariantId: argument guards fire", { + ids <- "chr1:100:A:G" + expect_error(normalizeVariantId(1:3), "Must be of type 'character'") + expect_error( + normalizeVariantId(ids, chrPrefix = NA), + "chrPrefix.*May not be NA" + ) + expect_error( + normalizeVariantId(ids, chrPrefix = c(TRUE, FALSE)), + "chrPrefix.*Must have length 1" + ) + expect_error( + normalizeVariantId(ids, convention = "nope"), + "convention.*Must be of type 'list'" + ) +}) + +test_that("regionToDf: argument guards fire", { + expect_error(regionToDf(1L), "Must be of type 'character'") + expect_error( + regionToDf("1_100_200", colnames = c("a", "b")), + "colnames.*Must have length 3" + ) +}) diff --git a/tests/testthat/test_vcfWriter.R b/tests/testthat/test_vcfWriter.R index 403934de..7f7e8b61 100644 --- a/tests/testthat/test_vcfWriter.R +++ b/tests/testthat/test_vcfWriter.R @@ -259,7 +259,7 @@ test_that("writeSumStatsVcf errors on empty FineMappingResult", { .make_multi_tuple_qtl_fmr <- function() { contexts <- c("brain", "blood") traits <- c("ENSG_A", "ENSG_B") - entries <- lapply(seq_along(contexts), function(i) { + entries <- map(seq_along(contexts), function(i) { ids <- paste0("chr1:", 100 * (1:3), ":T:A") tl <- data.frame( variant_id = ids, diff --git a/vignettes/ctwas-pipeline.Rmd b/vignettes/ctwas-pipeline.Rmd index 6e0310a8..90c347f5 100644 --- a/vignettes/ctwas-pipeline.Rmd +++ b/vignettes/ctwas-pipeline.Rmd @@ -113,10 +113,12 @@ res <- ctwasPipeline( thin = 1, niterPrefit = 3, niter = 10, - min_group_size = 1, - min_p_single_effect = 0, - min_nonSNP_PIP = 0, - fallbackToPrefit = TRUE + fallbackToPrefit = TRUE, + ctwasArgs = list( + min_group_size = 1, + min_p_single_effect = 0, + min_nonSNP_PIP = 0 + ) ) res ``` @@ -239,11 +241,10 @@ est <- estCtwasParam( thin = 1, niterPrefit = 3, niter = 10, - min_group_size = 1, - min_p_single_effect = 0, - fallbackToPrefit = TRUE + fallbackToPrefit = TRUE, + ctwasArgs = list(min_group_size = 1, min_p_single_effect = 0) ) -screened <- screenCtwasRegions(est, min_nonSNP_PIP = 0) +screened <- screenCtwasRegions(est, ctwasArgs = list(min_nonSNP_PIP = 0)) finemapped <- finemapCtwasRegions(screened) nrow(finemapped$finemap_res) ``` diff --git a/vignettes/mash-pipeline.Rmd b/vignettes/mash-pipeline.Rmd index 4a6b57e8..d2e8f2c7 100644 --- a/vignettes/mash-pipeline.Rmd +++ b/vignettes/mash-pipeline.Rmd @@ -110,8 +110,8 @@ a null set: fitSimple <- mashPipeline( sumStatsList, alpha = 0, - nPcs = 2L, - residualCorrelationMethod = "simple" + residualCorrelationMethod = "simple", + priorCovariances = fit$U ) ``` @@ -119,6 +119,11 @@ fitSimple <- mashPipeline( round(head(sort(fitSimple$w, decreasing = TRUE), 5), 4) ``` +Passing `fit$U` back in holds the prior fixed, so `Vhat` is the only thing +that differs from the fit above and the shift in the weights is attributable +to it alone. Re-estimating the prior here would confound the comparison -- +and cost a second data-driven estimate for a prior you already have. + Supplying a `null` partition while leaving the default in place reports that the partition is going unused, since that combination is more often an oversight than an intent. diff --git a/vignettes/rss-qc.Rmd b/vignettes/rss-qc.Rmd index 51e5651c..360769ef 100644 --- a/vignettes/rss-qc.Rmd +++ b/vignettes/rss-qc.Rmd @@ -57,7 +57,6 @@ make these objects. In this example the object is `GwasSumStats` object called ```{r run-qc, eval=FALSE} gws_qcd <- summaryStatsQc( gws, - useDbsnpRefCheck = FALSE, # opt-in to MungeSumstats dbSNP checks removeIndels = FALSE, removeStrandAmbiguous = TRUE, mafCutoff = 0, # 0 = off; > 0 requires MAF column diff --git a/vignettes/twas-weights.Rmd b/vignettes/twas-weights.Rmd index 8415431f..9009f846 100644 --- a/vignettes/twas-weights.Rmd +++ b/vignettes/twas-weights.Rmd @@ -98,11 +98,22 @@ set of per-variant weight estimates. When you pass an existing matching `(study, context, trait)` tuple is added to the ensemble as an additional weights row instead of being re-fit. +The same holds under cross-validation: each fold needs a fit trained on that +fold's rows, and the weights pipeline will not produce one. Run the +fine-mapping with `cvFolds` so those per-fold fits travel with the result — +requesting a fine-mapping method under cross-validation without them is an +error. That fold partition then governs the whole run: every other weight +method is cross-validated on the same folds, which is what makes their +scores comparable. The fold samples must be the samples of the dataset being +scored, or the run stops rather than scoring a fit against rows it was never +separated from. + ```{r individual-with-fmr} fmr <- fineMappingPipeline( qtlDatasetExample, methods = "susie", - cisWindow = 1e6 + cisWindow = 1e6, + cvFolds = 3 ) tw2 <- twasWeightsPipeline( qtlDatasetExample, @@ -250,7 +261,7 @@ combination of the others, with the weights chosen by cross-validation. Those steps are exported too: - `twasWeightsCv()` runs the cross-validation that scores each method. -- `learnTwasWeights()` fits one method across CV folds. +- `learnTwasWeights()` runs the requested weight methods on the full data. - `combineTwasWeights()` forms the ensemble from per-method weights. - `estimateSparsity()` reports how sparse a fitted weight vector is. @@ -279,6 +290,9 @@ twasWeightsPipeline( region = "chr22:25000000-26000000", cisWindow = 5e5, cvFolds = 5, + # required for a fine-mapping method, and under cvFolds > 1 it must carry + # the per-fold fits (fineMappingPipeline(..., cvFolds = 5)) + fineMappingResult = fmr, samplePartition = NULL, maxCvVariants = -1, cvThreads = 1, diff --git a/vignettes/twas-zscore.Rmd b/vignettes/twas-zscore.Rmd index 091bbec7..8075ce62 100644 --- a/vignettes/twas-zscore.Rmd +++ b/vignettes/twas-zscore.Rmd @@ -47,10 +47,13 @@ library(pecotmr) data(qtlDatasetExample, gwasSumStatsS4Example) # Pre-compute the QTL-side products from the bundled QtlDataset. +# cvFolds carries the per-fold susie fits through to the weights pipeline, +# which never fine-maps for itself. fmr <- fineMappingPipeline( qtlDatasetExample, methods = "susie", - cisWindow = 1e6 + cisWindow = 1e6, + cvFolds = 3 ) tw <- twasWeightsPipeline( qtlDatasetExample,