From 5744461a6d0a11f7890203c3fbf2e84a97f8cf69 Mon Sep 17 00:00:00 2001 From: Daniel Nachun Date: Tue, 1 Sep 2026 17:54:17 -0700 Subject: [PATCH] class cleanup --- DESCRIPTION | 1 - NAMESPACE | 9 +- R/AllClasses.R | 49 ++- R/CtwasResult.R | 14 + R/CtwasResultEntry.R | 17 + R/QtlDataset.R | 26 +- R/RangedTupleList.R | 341 +++++++++++++++++++ R/TupleRangesView.R | 383 ---------------------- R/fineMappingPipeline.R | 18 +- R/fineMappingWrappers.R | 239 ++++++++++++++ R/gwasSumStats.R | 26 +- R/qtlAssociationPostprocess.R | 5 +- R/qtlSumStats.R | 20 +- R/sumstatsQc.R | 231 +------------ R/tupleSelectors.R | 215 ++++++++---- R/twasWeightsPipeline.R | 7 +- _pkgdown.yml | 253 ++++++++------ data/gwasSumStatsS4Example.rda | Bin 7448 -> 7448 bytes data/multiStudyQtlDatasetExample.rda | Bin 7364 -> 7352 bytes data/qtlDatasetExample.rda | Bin 5828 -> 5760 bytes data/qtlSumStatsExample.rda | Bin 8404 -> 8404 bytes data/qtlSumStatsMulticontextExample.rda | Bin 16492 -> 16488 bytes man/CtwasResult-class.Rd | 24 ++ man/CtwasResultEntry-class.Rd | 33 ++ man/GwasSumStats-class.Rd | 22 ++ man/QtlDataset-class.Rd | 4 +- man/QtlSumStats-class.Rd | 23 ++ man/RangedTupleList-methods.Rd | 9 + man/SumStatsBase-class.Rd | 5 +- man/TupleRangesView-class.Rd | 27 -- man/extractCsInfo.Rd | 2 +- man/extractTopPipInfo.Rd | 2 +- man/flattenTupleRanges.Rd | 2 +- man/getSusieResult.Rd | 2 +- man/nestTupleRanges.Rd | 2 +- man/show-methods.Rd | 8 +- tests/testthat/test_RangedTupleList.R | 252 ++++++++++++++ tests/testthat/test_TupleRangesView.R | 314 ------------------ tests/testthat/test_ctwasPipeline.R | 8 +- tests/testthat/test_fineMappingWrappers.R | 222 +++++++++++++ tests/testthat/test_ld.R | 12 +- tests/testthat/test_sumstatsQc.R | 219 ------------- tests/testthat/test_tupleSelectors.R | 87 +++-- 43 files changed, 1686 insertions(+), 1447 deletions(-) delete mode 100644 R/TupleRangesView.R create mode 100644 man/CtwasResult-class.Rd create mode 100644 man/CtwasResultEntry-class.Rd create mode 100644 man/GwasSumStats-class.Rd create mode 100644 man/QtlSumStats-class.Rd delete mode 100644 man/TupleRangesView-class.Rd delete mode 100644 tests/testthat/test_TupleRangesView.R diff --git a/DESCRIPTION b/DESCRIPTION index e0994fc0..e5271766 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -140,7 +140,6 @@ Collate: 'MultiStudyQtlDataset.R' 'QtlFineMappingResult.R' 'SldscData.R' - 'TupleRangesView.R' 'causalInferencePipeline.R' 'colocPipeline.R' 'qtlSumStats.R' diff --git a/NAMESPACE b/NAMESPACE index 90d26e3f..95e2ca3a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,10 +4,8 @@ S3method(as.data.frame,GwasSumStats) S3method(dplyr::arrange,RangedTupleList) S3method(dplyr::filter,RangedTupleList) S3method(dplyr::group_by,RangedTupleList) -S3method(dplyr::group_by,TupleRangesView) S3method(dplyr::mutate,RangedTupleList) S3method(dplyr::select,RangedTupleList) -S3method(dplyr::select,TupleRangesView) S3method(dplyr::slice,RangedTupleList) S3method(dplyr::summarise,RangedTupleList) S3method(postprocessFinemappingFit,mvsusie) @@ -309,9 +307,12 @@ exportClasses(AnnotationMatrix) exportClasses(ColocBoostResult) exportClasses(ColocResult) exportClasses(ColocResultBase) +exportClasses(CtwasResult) +exportClasses(CtwasResultEntry) exportClasses(FineMappingResultBase) exportClasses(FineMappingRow) exportClasses(GwasFineMappingResult) +exportClasses(GwasSumStats) exportClasses(H2Estimate) exportClasses(LdData) exportClasses(LdEigen) @@ -321,10 +322,10 @@ exportClasses(MashPrior) exportClasses(MultiStudyQtlDataset) exportClasses(QtlDataset) exportClasses(QtlFineMappingResult) +exportClasses(QtlSumStats) exportClasses(RangedTupleList) exportClasses(SldscData) exportClasses(SumStatsBase) -exportClasses(TupleRangesView) exportClasses(TwasWeights) exportClasses(TwasWeightsRow) exportMethods("$") @@ -332,6 +333,7 @@ exportMethods("$<-") exportMethods("[") exportMethods("[[<-") exportMethods(as.data.frame) +exportMethods(bindROWS) exportMethods(colnames) exportMethods(colocboostPipeline) exportMethods(computeLdScores) @@ -492,6 +494,7 @@ importFrom(S4Vectors, "mcols<-", DataFrame, SimpleList, + bindROWS, endoapply, mcols, queryHits, diff --git a/R/AllClasses.R b/R/AllClasses.R index eee8b165..6b553525 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -79,7 +79,8 @@ setClassUnion("LdMixtureWeights", c("numeric", "NULL")) # ----------------------------------------------------------------------------- # Shared parent of the QTL and GWAS summary statistics collections. # Concrete subclasses (QtlSumStats, GwasSumStats) inherit from -# RangedTupleList and share the ldSketch / genome / qcInfo slots. Each element +# RangedTupleList and share the ldSketch / qcInfo slots (the genome build +# lives in seqinfo, not a slot). Each element # is one tuple's per-variant GRanges: x[[i]], formerly x$entry[[i]]. # # getZ / getN / getMaf / nSnps are @@ -92,7 +93,8 @@ setClassUnion("LdMixtureWeights", c("numeric", "NULL")) #' @description Virtual base class for QTL and GWAS summary statistics #' collections. Concrete subclasses (\code{QtlSumStats}, \code{GwasSumStats}) #' inherit from \code{\linkS4class{RangedTupleList}} and share the -#' \code{ldSketch} / \code{genome} / \code{qcInfo} slots. +#' \code{ldSketch} / \code{qcInfo} slots, and the genome build in +#' \code{seqinfo()}. #' #' Each element is the per-variant \code{GRanges} of one tuple, so #' \code{x[[i]]} is that tuple's summary statistics and the identity columns @@ -102,7 +104,6 @@ setClassUnion("LdMixtureWeights", c("numeric", "NULL")) #' or \code{NULL}. Optional: LD-free workflows (e.g. mash, which operates #' across conditions per variant) carry \code{NULL}; pipelines that need LD #' validate its presence when they consume the collection. -#' @slot genome Character, genome build label. #' @slot qcInfo A \code{list} recording which QC steps ran. Empty \code{list()} #' on construction; populated by \code{summaryStatsQc()} with a per-step audit #' record (filter names, drop counts, liftover target, RAISS settings, etc.). @@ -115,7 +116,6 @@ setClass( contains = c("VIRTUAL", "RangedTupleList"), representation( ldSketch = "LdSketchOrNULL", - genome = "character", qcInfo = "list" ) ) @@ -176,12 +176,51 @@ setClass( gr[onWindowChrom & IRanges::overlapsAny(gr, win)] } +# The build recorded in seqinfo must be exactly one non-NA value. A missing +# build is an error rather than a default: every downstream liftover / LD +# join keys on it, and silently guessing hg38 is how a mismatched panel gets +# through. Mixed builds mean the parts were never comparable. +# @noRd +.sumStatsCheckGenome <- function(object) { + # seqinfo records the build per SEQLEVEL, so a collection spanning none + # has nowhere to keep one -- whether it has no elements at all or only + # empty ones (a PIP-screened region emptied by summaryStatsQc). That is + # the one case where a missing build is not a defect: there is nothing + # for it to describe. A subset that empties an existing collection keeps + # its seqinfo (see .rtlRebuild), so this exempts only what was built with + # no ranges in the first place. + if (length(GenomeInfoDb::seqlevels(object)) == 0L) { + return(NULL) + } + build <- unique(GenomeInfoDb::genome(object)) + build <- build[!is.na(build)] + if (length(build) == 1L && str_length(build) > 0L) { + return(NULL) + } + if (length(build) == 0L) { + return("no genome build in seqinfo(); set one with genome(x) <- ...") + } + str_c( + "seqinfo() names more than one genome build (", + str_flatten(build, ", "), + ")" + ) +} + #' @rdname getGenome #' @examples #' data(qtlSumStatsExample) #' getGenome(qtlSumStatsExample) #' @export -setMethod("getGenome", "SumStatsBase", function(x, ...) x@genome) +setMethod("getGenome", "SumStatsBase", function(x, ...) { + # The build lives in seqinfo, exactly as it does on LdStatistic: a + # 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)] + if (length(build) == 0L) NA_character_ else build[[1L]] +}) #' @rdname getQcInfo #' @examples diff --git a/R/CtwasResult.R b/R/CtwasResult.R index 3743b3d2..b14e89a0 100644 --- a/R/CtwasResult.R +++ b/R/CtwasResult.R @@ -14,6 +14,20 @@ #' @include AllGenerics.R tupleSelectors.R NULL +#' @title cTWAS Result Collection +#' @description S4 collection of cTWAS runs keyed by the identity tuple +#' \code{(gwasStudy, study, context, method)}. Each row holds a +#' \code{\linkS4class{CtwasResultEntry}} payload -- fine-mapping posteriors, +#' the jointly-estimated group priors, and region metadata -- for one run. +#' @details Unlike the QTL family, \code{trait} is not part of the key: a cTWAS +#' run is multi-gene, so genes live inside the payload. The optional +#' \code{jointStudies} / \code{jointContexts} columns tag rows born from a +#' multi-study or multi-context run and participate in the uniqueness key, +#' exactly as in the \code{\linkS4class{TwasWeights}} and fine-mapping +#' families. +#' @seealso \code{\link{CtwasResult}} for the constructor and +#' \code{\link{ctwasPipeline}} for the pipeline that builds one. +#' @export setClass("CtwasResult", contains = "DFrame", validity = function(object) { .validateCtwasResult(object) }) diff --git a/R/CtwasResultEntry.R b/R/CtwasResultEntry.R index 30638f92..a296af47 100644 --- a/R/CtwasResultEntry.R +++ b/R/CtwasResultEntry.R @@ -10,6 +10,23 @@ #' @include AllGenerics.R NULL +#' @title cTWAS Per-Run Payload +#' @description Per-run cTWAS payload: the fine-mapping posterior table, the +#' full per-effect susie alpha table, the jointly-estimated group prior(s), +#' and per-region metadata. One entry sits in every row of a +#' \code{\linkS4class{CtwasResult}} collection. +#' @slot finemap The per-gene (and, when SNPs are retained, per-SNP) posterior +#' summary table (\code{ctwas::finemap_regions} \code{finemap_res} shape), +#' or \code{NULL}. +#' @slot susieAlpha The per-effect susie alpha table +#' (\code{ctwas::finemap_regions} \code{susie_alpha_res} shape) -- the +#' fuller cTWAS output retained so the raw run is reconstructable, or +#' \code{NULL}. +#' @slot param The estimated \code{group_prior} / \code{group_prior_var} for +#' this run, or \code{NULL}. +#' @slot regionInfo Per-region metadata, or \code{NULL}. +#' @seealso \code{\link{CtwasResultEntry}} for the constructor. +#' @export setClass( "CtwasResultEntry", representation( diff --git a/R/QtlDataset.R b/R/QtlDataset.R index d28f73ce..cda5972a 100644 --- a/R/QtlDataset.R +++ b/R/QtlDataset.R @@ -46,7 +46,6 @@ NULL #' @slot study Character (length 1). Study identifier; used in collection #' classes to tag downstream \code{FineMappingResult} / \code{TwasWeights} #' entries. -#' @slot genotypes The genotype source for lazy access to dosages. #' The \code{genotype} experiment's assay reads through this handle; the #' extraction accessors read it directly, so that QC can be applied per #' block. @@ -78,7 +77,6 @@ setClass( contains = "MultiAssayExperiment", representation( study = "character", - genotypes = "GenotypeHandle", scaleResiduals = "logical", mafCutoff = "numeric", macCutoff = "numeric", @@ -403,7 +401,6 @@ QtlDataset <- function( "QtlDataset", .qtlRestrictSamples(mae, keepSamples), study = as.character(study), - genotypes = handle, scaleResiduals = isTRUE(scaleResiduals), mafCutoff = as.numeric(mafCutoff), macCutoff = as.numeric(macCutoff), @@ -575,19 +572,15 @@ setMethod("longForm", "QtlDataset", function(object, ..., genotype = FALSE) { x[, which(is_in(ids, as.character(keepSamples))), ] } -# Replace the genotype handle, rebuilding the genotype experiment along with -# it. The handle is deliberately held twice -- once as a slot, once inside -# the assay's seed -- because that is what lets the assay read lazily. Moving -# one without the other would leave the dosages describing a different panel -# from the one the extraction accessors read, so nothing may set the slot -# directly. +# Replace the genotype handle by rebuilding the genotype experiment around +# it. The handle lives in exactly one place -- the assay's seed -- so there +# is no second copy to keep in step; getGenotypeHandle() reads it back. # @noRd .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 - x@genotypes <- handle validObject(x) x } @@ -673,7 +666,15 @@ setMethod("getScaleResiduals", "QtlDataset", function(x) x@scaleResiduals) #' @rdname getGenotypeHandle #' @keywords internal -setMethod("getGenotypeHandle", "QtlDataset", function(x) x@genotypes) +setMethod("getGenotypeHandle", "QtlDataset", function(x) { + # Derived, not stored. The handle already lives inside the genotype + # assay's seed -- that is what lets the dosages read lazily -- so a + # parallel slot was a second copy that had to be kept in step by hand. + # Reading it back removes the invariant instead of policing it. + .ldSketchHandle( + MultiAssayExperiment::experiments(x)[[.QTL_GENO_EXPERIMENT]] + ) +}) #' @rdname qtlDatasetFilters #' @export @@ -2069,8 +2070,9 @@ setMethod("show", "QtlDataset", function(object) { .trim = FALSE )) cat(glue(" {totalTraits} unique traits across contexts\n", .trim = FALSE)) + gh <- getGenotypeHandle(object) cat(glue( - " Genotypes: {object@genotypes@format} @ {object@genotypes@path}\n", + " Genotypes: {getFormat(gh)} @ {getPath(gh)}\n", .trim = FALSE )) cat(glue( diff --git a/R/RangedTupleList.R b/R/RangedTupleList.R index 69691c3c..f34abc45 100644 --- a/R/RangedTupleList.R +++ b/R/RangedTupleList.R @@ -132,12 +132,43 @@ methods::setValidity("RangedTupleList", function(object) { # drops the subclass's slots -- verified -- which is exactly the desync this # class exists to prevent. # @noRd +# Put `x`'s seqinfo back onto a rebuilt GRangesList. Only the seqlevels the +# rebuild actually spans can be kept, so this restores the genome (and any +# lengths) for those, and supplies the whole seqinfo when the rebuild spans +# nothing. +# @noRd +.rtlRestoreSeqinfo <- function(grl, x) { + si <- GenomeInfoDb::seqinfo(x) + if (length(GenomeInfoDb::seqlevels(si)) == 0L) { + return(grl) + } + if (length(GenomeInfoDb::seqlevels(grl)) == 0L) { + GenomeInfoDb::seqinfo(grl) <- si + return(grl) + } + keepLevels <- intersect( + GenomeInfoDb::seqlevels(si), + GenomeInfoDb::seqlevels(grl) + ) + GenomeInfoDb::seqinfo( + grl, + new2old = match(keepLevels, GenomeInfoDb::seqlevels(grl)) + ) <- si[keepLevels] + grl +} + .rtlRebuild <- function(x, elements, keep) { # mcols and slots are attached BEFORE new(), not after: new() validates # 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) + # 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) md <- mcols(x, use.names = FALSE) if (!is.null(md)) { mcols(grl) <- md[keep, , drop = FALSE] @@ -563,3 +594,313 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region, ...) { } g[onWindowChrom & IRanges::overlapsAny(g, win)] } + + +# ============================================================================= +# Combining collections +# ============================================================================= + +#' @rdname RangedTupleList-methods +#' @importFrom S4Vectors bindROWS +#' @export +setMethod( + "bindROWS", + "RangedTupleList", + function( + x, + objects = list(), + use.names = TRUE, + ignore.mcols = FALSE, + check = TRUE + ) { + # bindROWS() is the one hook `c()` and `append()` share, so defining it + # here fixes both. The inherited CompressedList version rbinds the mcols, + # which requires identical columns and so fails whenever the parts came + # from runs with different optional columns (traitPos / jointContexts / + # blockId); it also carries the FIRST part's collection-level slots + # silently, making the result depend on argument order. + .combineTupleCollections(compact(c(list(x), objects)), NULL, "c") + } +) + + +# ============================================================================= +# The plyranges / dplyr bridge for RangedTupleList collections +# +# plyranges has no GRangesList support at all: its verbs dispatch on +# GenomicRanges / Ranges, and a plain CompressedGRangesList fails exactly as +# these collections do. That is not a deficiency in the collections, and it is +# not fixable by changing them. +# +# The bridge is a round trip through a flat GRanges instead: flatten the +# collection (broadcasting its identity tuple onto every range), let plyranges +# work on the shape it already supports, and nest the result back into the +# collection's elements. Nothing about the collections has to change, and no +# wrapper class is needed -- plyranges acts on a real GRanges natively. +# ============================================================================= + +# ----------------------------------------------------------------------------- +# Conversions +# ----------------------------------------------------------------------------- + +#' Flatten a tuple collection to a plain GRanges +#' +#' Concatenates every element's ranges and broadcasts the collection's identity +#' tuple onto each range, so a plyranges predicate can mix tuple and per-range +#' columns: \code{filter(x, .context == "blood" & pip > 0.9)}. +#' +#' Broadcast columns are prefixed with a dot -- \code{.study}, +#' \code{.context}, \code{.trait}, \code{.method} -- following the +#' tidySummarizedExperiment convention for framework-injected columns +#' (\code{.sample}, \code{.feature}). The prefix is not cosmetic: a +#' collection's identity column can collide with a per-range column of the same +#' name carrying different information. On +#' \code{\link{gwasFineMappingExample}} the outer \code{method} is +#' \code{"susie"} while the per-range \code{method} is \code{"susieRss"} -- +#' the collection's label against the fitter actually used. Prefixing keeps +#' both, and keeps the name stable so a predicate does not change meaning +#' between objects. +#' +#' Non-atomic \code{mcols} columns -- the per-element \code{susieFit} / +#' \code{cvResult} payloads -- are dropped. They describe an element, not a +#' range, so there is no row to broadcast them onto. Use the accessors +#' (\code{\link{getSusieFit}}, \code{\link{getCvResult}}) for those. +#' +#' @param x A \code{RangedTupleList}. +#' @return A \code{GRanges}. +#' @examples +#' data(qtlFineMappingExample) +#' flat <- flattenTupleRanges(qtlFineMappingExample) +#' head(names(S4Vectors::mcols(flat))) +#' @export +flattenTupleRanges <- function(x) { + if (!methods::is(x, "RangedTupleList")) { + msg <- glue( + "`x` must be a RangedTupleList (got {class(x)[[1L]]})." + ) + abort(msg) + } + gr <- .rtlGatherElements(x, seq_len(length(x))) + md <- mcols(x, use.names = FALSE) + if (is.null(md) || ncol(md) == 0L || length(gr) == 0L) { + 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] + } + gr +} + +# The broadcast name for an identity column. Dotted so it cannot collide with +# a per-range column, and so the name is the same whatever the object holds. +# @noRd +.rtlDotName <- function(nm) { + str_c(".", nm) +} + +#' Re-nest a flattened GRanges into a tuple collection +#' +#' The inverse of \code{\link{flattenTupleRanges}}: ranges are grouped by the +#' identity tuple they carry and returned to \code{template}'s elements, so the +#' collection's class, its per-element payloads and its collection-level slots +#' all survive a plyranges round trip. +#' +#' A tuple with no surviving ranges becomes an empty element rather than being +#' dropped, so the collection keeps its shape and its metadata stays aligned. +#' +#' @param flat A \code{GRanges} produced by \code{flattenTupleRanges} (possibly +#' filtered or mutated). +#' @param template The collection it came from, supplying the tuple grid, the +#' payload columns and the slots. +#' @return An object of \code{template}'s class. +#' @examples +#' data(qtlFineMappingExample) +#' flat <- flattenTupleRanges(qtlFineMappingExample) +#' nestTupleRanges(flat, qtlFineMappingExample) +#' @export +nestTupleRanges <- function(flat, template) { + if (!methods::is(template, "RangedTupleList")) { + msg <- glue( + "`template` must be a RangedTupleList (got ", + "{class(template)[[1L]]})." + ) + abort(msg) + } + if (!methods::is(flat, "GRanges")) { + msg <- glue("`flat` must be a GRanges (got {class(flat)[[1L]]}).") + abort(msg) + } + keyCols <- .rtlTupleKeyCols(template) + dotted <- map_chr(keyCols, .rtlDotName) + wanted <- .rtlTupleKeys( + mcols(template, use.names = FALSE), + keyCols, + n = length(template) + ) + have <- .rtlTupleKeys( + mcols(flat, use.names = FALSE), + dotted, + n = length(flat) + ) + elements <- map(wanted, .rtlPickByKey, flat = flat, have = have) + .rtlRebuild(template, elements, seq_len(length(template))) +} + +# The identity columns to group by: the atomic mcols the flattener broadcasts. +# @noRd +.rtlTupleKeyCols <- function(x) { + md <- mcols(x, use.names = FALSE) + if (is.null(md)) { + return(character(0)) + } + names(md)[map_lgl(as.list(md), is.atomic)] +} + +# One key string per row. With no identity columns every range belongs to the +# single element, which is what a one-row collection means. +# @noRd +.rtlTupleKeys <- function(md, keyCols, n) { + present <- intersect(keyCols, colnames(md)) + if (length(present) == 0L) { + return(rep("", n)) + } + exec(str_c, !!!map(present, .rtlKeyPart, md = md), sep = "\r") +} + +# NA is mapped to a sentinel rather than left alone: str_c() propagates NA, so +# a single NA-valued identity column (varY is NA_real_ on a z-score collection) +# would turn every key into NA and the subsequent `have == key` into a logical +# subscript full of NAs. +# @noRd +.rtlKeyPart <- function(nm, md) { + v <- as.character(md[[nm]]) + if_else(is.na(v), "\u0001NA", v) +} + +# @noRd +.rtlPickByKey <- function(key, flat, have) { + flat[have == key] +} + + +# ----------------------------------------------------------------------------- +# Verbs on the collections themselves +# ----------------------------------------------------------------------------- + +# S3 dispatch reaches a method registered on an S4 VIRTUAL base, so one set of +# methods here serves every RangedTupleList subclass -- the fine-mapping, +# sumstats, TWAS-weight and coloc collections alike. +# +# Shape-preserving verbs flatten, delegate and re-nest, so the caller gets the +# collection back. Reducing verbs return what the verb produces, because a +# summary has no per-element shape to nest into. + +# These verbs delegate to plyranges' GRanges methods, which only exist once +# plyranges' namespace is loaded. Without this the failure is an opaque "no +# applicable method for 'filter' applied to an object of class GRanges" -- +# pointing at the flattened form rather than at the missing package. +# requireNamespace() both checks and loads, so the check is also the fix. +# @noRd +.rtlRequirePlyranges <- function(verb) { + if (!requireNamespace("plyranges", quietly = TRUE)) { + msg <- glue( + "`{verb}()` on a tuple collection needs the plyranges package; ", + "install it, or work on flattenTupleRanges(x) directly." + ) + abort(msg) + } + invisible(NULL) +} + +# `...` is forwarded directly rather than captured with enquos() and spliced: +# splicing hands the verb quosure OBJECTS instead of expressions to evaluate, +# and plyranges then fails with "Argument to filter condition must evaluate to +# a logical vector". + +#' @exportS3Method dplyr::filter +filter.RangedTupleList <- function(.data, ...) { + .rtlRequirePlyranges("filter") + out <- dplyr::filter(flattenTupleRanges(.data), ...) + nestTupleRanges(out, .data) +} + +#' @exportS3Method dplyr::mutate +mutate.RangedTupleList <- function(.data, ...) { + .rtlRequirePlyranges("mutate") + out <- dplyr::mutate(flattenTupleRanges(.data), ...) + nestTupleRanges(out, .data) +} + +#' @exportS3Method dplyr::select +select.RangedTupleList <- function(.data, ...) { + .rtlRequirePlyranges("select") + # The identity columns are kept whatever the selection, or the result + # could not be nested back into its elements. + out <- dplyr::select(flattenTupleRanges(.data), ...) + nestTupleRanges( + .rtlRestoreKeys(out, flattenTupleRanges(.data), .data), + .data + ) +} + +# Takes n ranges FROM EACH element, matching arrange()'s within-element rule. +# +# Unlike the other verbs this does not flatten: slicing the flat set would take +# n ranges in TOTAL, which for a many-element collection empties all but the +# first. Applying the slice per element is both the right semantics and simpler +# than reconstructing the grouping after a flatten. +#' @exportS3Method dplyr::slice +slice.RangedTupleList <- function(.data, ...) { + .rtlRequirePlyranges("slice") + elements <- map(as.list(.data), .rtlSliceOne, ...) + .rtlRebuild(.data, elements, seq_len(length(.data))) +} + +# @noRd +.rtlSliceOne <- function(g, ...) { + dplyr::slice(g, ...) +} + +# Orders WITHIN each element. A global sort of the flattened set followed by +# partitioning on the identity tuple leaves each element internally sorted -- +# the two are the same thing for the partitioned result -- so no grouping is +# needed here. Ordering ACROSS elements would permute the elements themselves, +# which the identity tuple cannot express. +#' @exportS3Method dplyr::arrange +arrange.RangedTupleList <- function(.data, ...) { + .rtlRequirePlyranges("arrange") + out <- dplyr::arrange(flattenTupleRanges(.data), ...) + nestTupleRanges(out, .data) +} + +#' @exportS3Method dplyr::summarise +summarise.RangedTupleList <- function(.data, ...) { + .rtlRequirePlyranges("summarise") + dplyr::summarise(flattenTupleRanges(.data), ...) +} + +# No count() method: plyranges defines none for GRanges either, so there is +# nothing to delegate to. Use summarise(group_by(x, ...), n = n()). + +#' @exportS3Method dplyr::group_by +group_by.RangedTupleList <- function(.data, ...) { + .rtlRequirePlyranges("group_by") + dplyr::group_by(flattenTupleRanges(.data), ...) +} + +# Put back any identity column a selection dropped. Without them the ranges +# carry no tuple and every one would fall into the first element. +# @noRd +.rtlRestoreKeys <- function(out, flat, template) { + dotted <- map_chr(.rtlTupleKeyCols(template), .rtlDotName) + missing <- setdiff( + intersect(dotted, colnames(mcols(flat))), + colnames(mcols(out)) + ) + for (nm in missing) { + mcols(out)[[nm]] <- mcols(flat)[[nm]] + } + out +} diff --git a/R/TupleRangesView.R b/R/TupleRangesView.R deleted file mode 100644 index 34f4d65f..00000000 --- a/R/TupleRangesView.R +++ /dev/null @@ -1,383 +0,0 @@ -# ============================================================================= -# TupleRangesView -- the plyranges bridge for RangedTupleList collections -# -# plyranges has no GRangesList support at all: its verbs dispatch on -# GenomicRanges / Ranges, and a plain CompressedGRangesList fails exactly as -# these collections do. That is not a deficiency in the collections, and it is -# not fixable by changing them. -# -# It IS fixable through the extension point GenomicRanges provides: -# `DelegatingGenomicRanges` is a virtual class that wraps a flat `delegate` and -# *is* a GenomicRanges, and plyranges ships methods for it. A subclass supplies -# a `[` hook and inherits the verb surface instead of reimplementing it. -# -# The conversion is the right shape rather than a workaround: plyranges' own -# `GroupedGenomicRanges` (slots group_keys / group_indices / n / delegate) -# represents grouping as flat ranges plus group metadata, which is exactly a -# RangedTupleList transposed. Same information, other representation. -# ============================================================================= - -#' Flat view of a tuple collection for plyranges verbs -#' -#' A \code{\link[GenomicRanges]{GenomicRanges}} view over a -#' \code{RangedTupleList}: every element's ranges concatenated, with the -#' collection's identity tuple broadcast onto each range. Because it is a -#' \code{GenomicRanges}, plyranges verbs act on it directly. -#' -#' Users do not normally build one. The verb methods on \code{RangedTupleList} -#' convert to a view, delegate, and convert back. -#' -#' @slot delegate The flattened \code{GRanges}. -#' @name TupleRangesView-class -#' @keywords internal -#' @export -setClass("TupleRangesView", contains = "DelegatingGenomicRanges") - -# Build a view over `flat`. -# -# DelegatingGenomicRanges carries its OWN elementMetadata alongside the -# delegate's, and validity requires it to be parallel to the object. Supplying -# only `delegate=` leaves it zero-row against a longer object and the class -# rejects itself with "'mcols(x)' is not parallel to 'x'", so it is set here. -# @noRd -.tupleRangesView <- function(flat) { - methods::new( - "TupleRangesView", - delegate = flat, - elementMetadata = S4Vectors::make_zero_col_DFrame(length(flat)) - ) -} - -# The flat GRanges a view wraps. Internal accessor: TupleRangesView is not -# exported, so this adds no public surface and keeps the `@` in the class file. -# @noRd -.trvDelegate <- function(x) x@delegate - -# The one hook a DelegatingGenomicRanges subclass has to supply. Without it, -# plyranges' subsetting verbs (slice, filter_by_overlaps, join_overlap_*) fail -# with "subscript is a NSBS object that is incompatible with the current -# subsetting operation". -#' @rdname TupleRangesView-class -#' @export -setMethod("[", "TupleRangesView", function(x, i, j, ..., drop = TRUE) { - if (!missing(j)) { - abort("two-argument `[` is not supported on a TupleRangesView.") - } - .tupleRangesView(.trvDelegate(x)[i]) -}) - -#' @rdname show-methods -#' @export -setMethod("show", "TupleRangesView", function(object) { - cat(glue( - "TupleRangesView: {length(.trvDelegate(object))} ranges, ", - "{ncol(mcols(.trvDelegate(object)))} metadata column(s)\n", - .trim = FALSE - )) - invisible(NULL) -}) - -# ----------------------------------------------------------------------------- -# Conversions -# ----------------------------------------------------------------------------- - -#' Flatten a tuple collection to a plain GRanges -#' -#' Concatenates every element's ranges and broadcasts the collection's identity -#' tuple onto each range, so a plyranges predicate can mix tuple and per-range -#' columns: \code{filter(x, .context == "blood" & pip > 0.9)}. -#' -#' Broadcast columns are prefixed with a dot -- \code{.study}, -#' \code{.context}, \code{.trait}, \code{.method} -- following the -#' tidySummarizedExperiment convention for framework-injected columns -#' (\code{.sample}, \code{.feature}). The prefix is not cosmetic: a -#' collection's identity column can collide with a per-range column of the same -#' name carrying different information. On -#' \code{\link{gwasFineMappingExample}} the outer \code{method} is -#' \code{"susie"} while the per-range \code{method} is \code{"susieRss"} -- -#' the collection's label against the fitter actually used. Prefixing keeps -#' both, and keeps the name stable so a predicate does not change meaning -#' between objects. -#' -#' Non-atomic \code{mcols} columns -- the per-element \code{susieFit} / -#' \code{cvResult} payloads -- are dropped. They describe an element, not a -#' range, so there is no row to broadcast them onto. Use the accessors -#' (\code{\link{getSusieFit}}, \code{\link{getCvResult}}) for those. -#' -#' @param x A \code{RangedTupleList}. -#' @return A \code{GRanges}. -#' @examples -#' data(qtlFineMappingExample) -#' flat <- flattenTupleRanges(qtlFineMappingExample) -#' head(names(S4Vectors::mcols(flat))) -#' @export -flattenTupleRanges <- function(x) { - if (!methods::is(x, "RangedTupleList")) { - msg <- glue( - "`x` must be a RangedTupleList (got {class(x)[[1L]]})." - ) - abort(msg) - } - gr <- .rtlGatherElements(x, seq_len(length(x))) - md <- mcols(x, use.names = FALSE) - if (is.null(md) || ncol(md) == 0L || length(gr) == 0L) { - 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] - } - gr -} - -# The broadcast name for an identity column. Dotted so it cannot collide with -# a per-range column, and so the name is the same whatever the object holds. -# @noRd -.rtlDotName <- function(nm) { - str_c(".", nm) -} - -#' Re-nest a flattened GRanges into a tuple collection -#' -#' The inverse of \code{\link{flattenTupleRanges}}: ranges are grouped by the -#' identity tuple they carry and returned to \code{template}'s elements, so the -#' collection's class, its per-element payloads and its collection-level slots -#' all survive a plyranges round trip. -#' -#' A tuple with no surviving ranges becomes an empty element rather than being -#' dropped, so the collection keeps its shape and its metadata stays aligned. -#' -#' @param flat A \code{GRanges} produced by \code{flattenTupleRanges} (possibly -#' filtered or mutated). -#' @param template The collection it came from, supplying the tuple grid, the -#' payload columns and the slots. -#' @return An object of \code{template}'s class. -#' @examples -#' data(qtlFineMappingExample) -#' flat <- flattenTupleRanges(qtlFineMappingExample) -#' nestTupleRanges(flat, qtlFineMappingExample) -#' @export -nestTupleRanges <- function(flat, template) { - if (!methods::is(template, "RangedTupleList")) { - msg <- glue( - "`template` must be a RangedTupleList (got ", - "{class(template)[[1L]]})." - ) - abort(msg) - } - if (!methods::is(flat, "GRanges")) { - msg <- glue("`flat` must be a GRanges (got {class(flat)[[1L]]}).") - abort(msg) - } - keyCols <- .rtlTupleKeyCols(template) - dotted <- map_chr(keyCols, .rtlDotName) - wanted <- .rtlTupleKeys( - mcols(template, use.names = FALSE), - keyCols, - n = length(template) - ) - have <- .rtlTupleKeys( - mcols(flat, use.names = FALSE), - dotted, - n = length(flat) - ) - elements <- map(wanted, .rtlPickByKey, flat = flat, have = have) - .rtlRebuild(template, elements, seq_len(length(template))) -} - -# The identity columns to group by: the atomic mcols the flattener broadcasts. -# @noRd -.rtlTupleKeyCols <- function(x) { - md <- mcols(x, use.names = FALSE) - if (is.null(md)) { - return(character(0)) - } - names(md)[map_lgl(as.list(md), is.atomic)] -} - -# One key string per row. With no identity columns every range belongs to the -# single element, which is what a one-row collection means. -# @noRd -.rtlTupleKeys <- function(md, keyCols, n) { - present <- intersect(keyCols, colnames(md)) - if (length(present) == 0L) { - return(rep("", n)) - } - exec(str_c, !!!map(present, .rtlKeyPart, md = md), sep = "\r") -} - -# NA is mapped to a sentinel rather than left alone: str_c() propagates NA, so -# a single NA-valued identity column (varY is NA_real_ on a z-score collection) -# would turn every key into NA and the subsequent `have == key` into a logical -# subscript full of NAs. -# @noRd -.rtlKeyPart <- function(nm, md) { - v <- as.character(md[[nm]]) - if_else(is.na(v), "\u0001NA", v) -} - -# @noRd -.rtlPickByKey <- function(key, flat, have) { - flat[have == key] -} - - -# ----------------------------------------------------------------------------- -# Patches for the two verbs plyranges' DelegatingGenomicRanges support misses -# ----------------------------------------------------------------------------- - -# Both work on a plain GRanges and fail on any DelegatingGenomicRanges: -# `select` reports "Cannot select/rename the following columns: seqnames, -# start, end, width, strand", and `group_by` -- for which plyranges defines no -# DelegatingGenomicRanges method at all -- reports "Can't select columns with -# `dots`". Both are upstream gaps, not something about this class. -# -# The fix in each case is to run the verb on the delegate, where plyranges -# works, and re-wrap. - -#' @exportS3Method dplyr::select -select.TupleRangesView <- function(.data, ..., .drop_ranges = FALSE) { - out <- dplyr::select( - .trvDelegate(.data), - ..., - .drop_ranges = .drop_ranges - ) - if (isTRUE(.drop_ranges)) { - return(out) - } - .tupleRangesView(out) -} - -# Not re-wrapped: grouping is plyranges' own representation, and the result is -# a GroupedGenomicRanges rather than a view of a collection. -#' @exportS3Method dplyr::group_by -group_by.TupleRangesView <- function(.data, ..., .add = FALSE) { - dplyr::group_by(.trvDelegate(.data), ...) -} - -# ----------------------------------------------------------------------------- -# Verbs on the collections themselves -# ----------------------------------------------------------------------------- - -# S3 dispatch reaches a method registered on an S4 VIRTUAL base, so one set of -# methods here serves every RangedTupleList subclass -- the fine-mapping, -# sumstats, TWAS-weight and coloc collections alike. -# -# Shape-preserving verbs flatten, delegate and re-nest, so the caller gets the -# collection back. Reducing verbs return what the verb produces, because a -# summary has no per-element shape to nest into. - -# These verbs delegate to plyranges' GRanges methods, which only exist once -# plyranges' namespace is loaded. Without this the failure is an opaque "no -# applicable method for 'filter' applied to an object of class GRanges" -- -# pointing at the flattened form rather than at the missing package. -# requireNamespace() both checks and loads, so the check is also the fix. -# @noRd -.rtlRequirePlyranges <- function(verb) { - if (!requireNamespace("plyranges", quietly = TRUE)) { - msg <- glue( - "`{verb}()` on a tuple collection needs the plyranges package; ", - "install it, or work on flattenTupleRanges(x) directly." - ) - abort(msg) - } - invisible(NULL) -} - -# Unwrap a view back to its delegate; pass a plain GRanges through. -# @noRd -.rtlAsRanges <- function(out) { - if (methods::is(out, "TupleRangesView")) .trvDelegate(out) else out -} - -# `...` is forwarded directly rather than captured with enquos() and spliced: -# splicing hands the verb quosure OBJECTS instead of expressions to evaluate, -# and plyranges then fails with "Argument to filter condition must evaluate to -# a logical vector". - -#' @exportS3Method dplyr::filter -filter.RangedTupleList <- function(.data, ...) { - .rtlRequirePlyranges("filter") - out <- dplyr::filter(flattenTupleRanges(.data), ...) - nestTupleRanges(.rtlAsRanges(out), .data) -} - -#' @exportS3Method dplyr::mutate -mutate.RangedTupleList <- function(.data, ...) { - .rtlRequirePlyranges("mutate") - out <- dplyr::mutate(flattenTupleRanges(.data), ...) - nestTupleRanges(.rtlAsRanges(out), .data) -} - -#' @exportS3Method dplyr::select -select.RangedTupleList <- function(.data, ...) { - .rtlRequirePlyranges("select") - # The identity columns are kept whatever the selection, or the result - # could not be nested back into its elements. - out <- dplyr::select(flattenTupleRanges(.data), ...) - nestTupleRanges( - .rtlRestoreKeys(.rtlAsRanges(out), flattenTupleRanges(.data), .data), - .data - ) -} - -# Takes n ranges FROM EACH element, matching arrange()'s within-element rule. -# -# Unlike the other verbs this does not flatten: slicing the flat set would take -# n ranges in TOTAL, which for a many-element collection empties all but the -# first. Applying the slice per element is both the right semantics and simpler -# than reconstructing the grouping after a flatten. -#' @exportS3Method dplyr::slice -slice.RangedTupleList <- function(.data, ...) { - .rtlRequirePlyranges("slice") - elements <- map(as.list(.data), .rtlSliceOne, ...) - .rtlRebuild(.data, elements, seq_len(length(.data))) -} - -# @noRd -.rtlSliceOne <- function(g, ...) { - dplyr::slice(g, ...) -} - -# Orders WITHIN each element. A global sort of the flattened set followed by -# partitioning on the identity tuple leaves each element internally sorted -- -# the two are the same thing for the partitioned result -- so no grouping is -# needed here. Ordering ACROSS elements would permute the elements themselves, -# which the identity tuple cannot express. -#' @exportS3Method dplyr::arrange -arrange.RangedTupleList <- function(.data, ...) { - .rtlRequirePlyranges("arrange") - out <- dplyr::arrange(flattenTupleRanges(.data), ...) - nestTupleRanges(.rtlAsRanges(out), .data) -} - -#' @exportS3Method dplyr::summarise -summarise.RangedTupleList <- function(.data, ...) { - .rtlRequirePlyranges("summarise") - .rtlAsRanges(dplyr::summarise(flattenTupleRanges(.data), ...)) -} - -# No count() method: plyranges defines none for GRanges either, so there is -# nothing to delegate to. Use summarise(group_by(x, ...), n = n()). - -#' @exportS3Method dplyr::group_by -group_by.RangedTupleList <- function(.data, ...) { - .rtlRequirePlyranges("group_by") - .rtlAsRanges(dplyr::group_by(flattenTupleRanges(.data), ...)) -} - -# Put back any identity column a selection dropped. Without them the ranges -# carry no tuple and every one would fall into the first element. -# @noRd -.rtlRestoreKeys <- function(out, flat, template) { - dotted <- map_chr(.rtlTupleKeyCols(template), .rtlDotName) - missing <- setdiff( - intersect(dotted, colnames(mcols(flat))), - colnames(mcols(out)) - ) - for (nm in missing) { - mcols(out)[[nm]] <- mcols(flat)[[nm]] - } - out -} diff --git a/R/fineMappingPipeline.R b/R/fineMappingPipeline.R index aa498b3f..15fc4450 100644 --- a/R/fineMappingPipeline.R +++ b/R/fineMappingPipeline.R @@ -1027,18 +1027,10 @@ setGeneric("fineMappingPipeline", function(data, ...) { ".rbindFineMappingResult expects two FineMappingResultBase inputs." ) } - if (!identical(class(a)[[1L]], class(b)[[1L]])) { - clsA <- class(a)[[1L]] - clsB <- class(b)[[1L]] - msg <- glue( - ".rbindFineMappingResult: inputs must be the same concrete ", - "class (got '{clsA}' and '{clsB}')." - ) - abort(msg) - } - # Carry forward every column (blockId / joint* / ...) via the generic - # combine; the concrete class (QTL vs GWAS) is preserved automatically. - .rbindCollections(list(a, b), ldSketch = ldSketch) + # 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. + .combineTupleCollections(list(a, b), ldSketch, ".rbindFineMappingResult") } #' Combine FineMappingResult collections @@ -1067,7 +1059,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { "FineMappingResultBase", "combineFineMappingResults" ) - reduce(parts, .rbindFineMappingResult, ldSketch = ldSketch) + .combineTupleCollections(parts, ldSketch, "combineFineMappingResults") } diff --git a/R/fineMappingWrappers.R b/R/fineMappingWrappers.R index a0ee4506..bed515f6 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -3310,6 +3310,245 @@ mergeSusieCs <- function(fineMappingResult, coverage = 0.95) { } +# ============================================================================= +# Post-fine-mapping credible-set extraction +# ----------------------------------------------------------------------------- +# Pull the trimmed SuSiE fit out of a pipeline result and reduce it to the +# per-credible-set / top-PIP diagnostic rows that summaryStatsQc() and the +# fine-mapping report consume. Relocated here from sumstatsQc.R: these read a +# fine-mapping result, they do not perform QC. +# ============================================================================= + +#' Extract the trimmed SuSiE fit from a finemapping pipeline result +#' +#' Returns the trimmed model fit underlying \code{con_data$finemappingEntry} (a +#' \code{FineMappingRow} S4 object), or NULL if no fine-mapping entry is +#' attached. +#' +#' @param conData List. The method-layer entry from a finemapping pipeline +#' result, expected to carry \code{$finemappingEntry} as a +#' \code{FineMappingRow} object. +#' @return The trimmed fit (a list with \code{pip}, \code{sets}, etc.) or NULL. +#' @examples +#' data(qtlSumStatsExample) +#' getSusieResult(qtlSumStatsExample) +#' @export +getSusieResult <- function(conData) { + if (length(conData) == 0) { + return(NULL) + } + fm <- conData$finemappingEntry + if (is.null(fm) || !is(fm, "FineMappingResultBase")) { + return(NULL) + } + trimmed <- .fmrPartsSusieFit(fm) + if (length(trimmed) == 0) { + return(NULL) + } + trimmed +} + +#' Process Credible Sets (CS) from Finemapping Results +#' +#' 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 csNames Character vector. Names of the Credible Sets, usually in the +#' format "L_". +#' @param topLociTable Data frame. The top-loci table (e.g. from +#' \code{\link{getTopLoci}}) carrying \code{variant_id}, \code{pip}, and +#' \code{z} columns. +#' @param ldSource The LD source from which the between-credible-set correlation +#' is derived on demand: a \code{QtlDataset} (individual-level) or a +#' \code{QtlSumStats} / \code{GwasSumStats} (summary statistics). See +#' \code{\link{computeCsCorrelation}}. +#' +#' @return A data frame with one row per CS, containing the following columns: +#' \item{cs_name}{Name of the Credible Set} +#' \item{variants_per_cs}{Number of variants in the CS} +#' \item{top_variant}{ID of the variant with the highest PIP in the CS} +#' \item{top_variant_index}{Global index of the top variant} +#' \item{top_pip}{Highest Posterior Inclusion Probability (PIP) in the CS} +#' \item{top_z}{Z-score of the top variant} +#' \item{p_value}{P-value calculated from the top Z-score} +#' \item{cs_corr_1, cs_corr_2, ...}{Each CS's pairwise correlation with every +#' CS (its row of the between-CS matrix, self-correlation on the diagonal), +#' computed on demand from \code{ldSource}. Absent when there are fewer than +#' two credible sets.} +#' \item{cs_corr_max}{Maximum absolute between-CS correlation (excluding the +#' self == 1); \code{NA} for a single CS.} +#' \item{cs_corr_min}{Minimum absolute between-CS correlation; \code{NA} for a +#' single CS.} +#' +#' @details This function is designed to be used only when there is at least one +#' Credible Set in the finemapping results usually for a given study and +#' block. It processes each CS, extracting key information such as the top +#' variant, its statistics, and correlation information between multiple CS if +#' available. +#' +#' @importFrom purrr map map_dbl map_int +#' @importFrom dplyr bind_rows +#' +#' @examples +#' data(qtlSumStatsExample) +#' vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") +#' fit <- list(pip = c(0.1, 0.7, 0.2), sets = list(cs = list(L_1 = c(1, 2)))) +#' tl <- data.frame(variant_id = vids, pip = c(0.1, 0.7, 0.2), +#' z = c(1.0, 3.5, -0.5)) +#' fe <- fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) +#' # A single credible set has no between-CS correlation (cs_corr_* are NA), so +#' # the ldSource is not consulted here. +#' extractCsInfo(fe, csNames = "L_1", topLociTable = tl, +#' ldSource = qtlSumStatsExample) +#' +#' @export +extractCsInfo <- function(fmRow, csNames, topLociTable, ldSource) { + fm <- fmRow + trimmed <- .fmrPartsSusieFit(fm) + variantNames <- .fmrPartsVariantIds(fm) + csCorr <- .rowCsCorrelation(fm, ldSource) + rows <- map( + seq_along(csNames), + .extractCsInfoRow, + csNames = csNames, + trimmed = trimmed, + variantNames = variantNames, + topLociTable = topLociTable + ) + .csAppendCorrelationCols(bind_rows(rows), csCorr) +} + +#' Extract Information for Top Variant from Finemapping Results +#' +#' This function extracts information about the variant with the highest +#' 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 sumstats A list or data frame carrying a \code{z} element aligned to +#' the fit's variants (\code{sumstats$z}). +#' +#' @return A data frame with one row containing the following columns: +#' \item{cs_name}{NA (as no CS is identified)} +#' \item{variants_per_cs}{NA (as no CS is identified)} +#' \item{top_variant}{ID of the variant with the highest PIP} +#' \item{top_variant_index}{Index of the top variant in the original data} +#' \item{top_pip}{Highest Posterior Inclusion Probability (PIP)} +#' \item{top_z}{Z-score of the top variant} +#' \item{p_value}{P-value calculated from the top Z-score} +#' \item{cs_corr_max}{NA (no between-CS correlation without a CS)} +#' \item{cs_corr_min}{NA (no between-CS correlation without a CS)} +#' +#' @details This function is designed to be used when no Credible Sets are +#' identified in the finemapping results, but information about the most +#' significant variant is still desired. It identifies the variant with the +#' highest PIP and extracts relevant statistical information. +#' +#' @note This function is particularly useful for capturing information about +#' potentially important variants that might be included in Credible Sets +#' under different analysis parameters or lower coverage. It maintains a +#' structure similar to the output of `extract_cs_info()` for consistency in +#' downstream analyses. +#' +#' @seealso \code{\link{extractCsInfo}} for processing when Credible Sets are +#' present. +#' +#' @examples +#' vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") +#' fit <- list(pip = c(0.1, 0.7, 0.2)) +#' tl <- data.frame(variant_id = vids, pip = c(0.1, 0.7, 0.2)) +#' fe <- fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) +#' extractTopPipInfo(fe, sumstats = list(z = c(1.0, 3.5, -0.5))) +#' +#' @export +extractTopPipInfo <- function(fmRow, sumstats) { + fm <- fmRow + trimmed <- .fmrPartsSusieFit(fm) + variantNames <- .fmrPartsVariantIds(fm) + # Find the variant with the highest PIP + topPipIndex <- which.max(trimmed$pip) + topPip <- trimmed$pip[topPipIndex] + topVariant <- variantNames[topPipIndex] + topZ <- sumstats$z[topPipIndex] + pValue <- .zToPvalue(topZ) + + list( + cs_name = NA, + variants_per_cs = NA, + top_variant = topVariant, + top_variant_index = topPipIndex, + top_pip = topPip, + top_z = topZ, + p_value = pValue, + cs_corr_max = NA_real_, + cs_corr_min = NA_real_ + ) +} + +# Reduce one credible set's correlation vector (a row of the between-CS matrix, +# the self-correlation == 1 on the diagonal) to its |corr| max/min, excluding +# every self / perfect correlation (== 1). An empty result yields NA. +# @noRd +.extractCorrelations <- function(x) { + filtered <- abs(x[x != 1]) + if (length(filtered) == 0L) { + return(list(max_corr = NA_real_, min_corr = NA_real_)) + } + list( + max_corr = max(filtered, na.rm = TRUE), + min_corr = min(filtered, na.rm = TRUE) + ) +} + +# Append the between-CS correlation columns to the per-CS summary `base` from +# the m x m matrix `csCorr` (whose rows are aligned to `base`): the expanded +# cs_corr_1..m (each CS's row, self-correlation on the diagonal) plus +# cs_corr_max / cs_corr_min (|corr| excluding the self == 1). A NULL matrix +# (fewer than two credible sets) yields NA max/min and no expanded columns. +# @noRd +.csAppendCorrelationCols <- function(base, csCorr) { + if (is.null(csCorr)) { + 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))) + # unname(): apply() names its result by the matrix rownames, which map_dbl + # then carries into the column (tibbles preserve element names). + base |> + bind_cols(expanded) |> + mutate( + cs_corr_max = unname(map_dbl(perRow, "max_corr")), + cs_corr_min = unname(map_dbl(perRow, "min_corr")) + ) +} + +# One credible set's scalar summary row (top variant / PIP / z / p). The +# between-CS correlation columns are appended once by .csAppendCorrelationCols. +# @noRd +.extractCsInfoRow <- function(i, csNames, trimmed, variantNames, topLociTable) { + csName <- csNames[i] + indices <- trimmed$sets$cs[[csName]] + csVariants <- variantNames[indices] + csData <- filter(topLociTable, is_in(.data$variant_id, csVariants)) + topRow <- which.max(csData$pip) + topVariant <- csData$variant_id[topRow] + topZ <- csData$z[topRow] + tibble( + cs_name = csName, + variants_per_cs = length(csVariants), + top_variant = topVariant, + top_variant_index = which(variantNames == topVariant), + top_pip = csData$pip[topRow], + top_z = topZ, + p_value = .zToPvalue(topZ) + ) +} + + # ============================================================================= # SuSiE-family fitters (single-fit wrappers + per-block dispatch) # ----------------------------------------------------------------------------- diff --git a/R/gwasSumStats.R b/R/gwasSumStats.R index c5f25b53..876f039b 100644 --- a/R/gwasSumStats.R +++ b/R/gwasSumStats.R @@ -11,6 +11,18 @@ #' @include AllClasses.R tupleSelectors.R NULL +#' @title GWAS Summary-Statistic Collection +#' @description S4 collection of GWAS summary statistics keyed by the identity +#' tuple \code{(study)}. Each element is that study's per-variant +#' \code{GRanges} covering a single LD block, so build one collection per +#' block when sweeping the genome. +#' @details Required column: \code{study}, unique across rows. The class-level +#' slots inherited from \code{\linkS4class{SumStatsBase}} -- +#' \code{ldSketch}, \code{genome} and \code{qcInfo} -- apply uniformly to +#' every row. +#' @seealso \code{\link{GwasSumStats}} for the constructor and +#' \code{\linkS4class{QtlSumStats}} for the QTL counterpart. +#' @export setClass( "GwasSumStats", contains = "SumStatsBase", @@ -25,12 +37,7 @@ setClass( str_c("missing columns: ", str_flatten(missingCols, ", ")) ) } - if (length(object@genome) != 1L || str_length(object@genome) == 0L) { - errors <- c( - errors, - "'genome' slot must be a single non-empty character string" - ) - } + errors <- c(errors, .sumStatsCheckGenome(object)) if (!is.list(object@qcInfo)) { errors <- c(errors, "'qcInfo' slot must be a list") } @@ -58,7 +65,7 @@ setClass( setMethod("show", "GwasSumStats", function(object) { cat(glue( "GwasSumStats: {nrow(object)} studies, ", - "genome build {object@genome}\n", + "genome build {getGenome(object)}\n", .trim = FALSE )) ld <- object@ldSketch @@ -215,11 +222,14 @@ GwasSumStats <- function( # coerce those slots. Used by qtlSumStats.R too. # @noRd .sumStatsNewValidated <- function(Class, grl, ldSketch, genome, qcInfo) { + # 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) obj <- methods::new( Class, grl, ldSketch = .asLdSketch(ldSketch), - genome = as.character(genome), qcInfo = as.list(qcInfo) ) methods::validObject(obj) diff --git a/R/qtlAssociationPostprocess.R b/R/qtlAssociationPostprocess.R index 12059f02..db9778f6 100644 --- a/R/qtlAssociationPostprocess.R +++ b/R/qtlAssociationPostprocess.R @@ -283,12 +283,15 @@ setMethod( md[[nm]] <- newCols[[nm]] } 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 methods::new( "QtlSumStats", grl, ldSketch = getLdSketch(x), - genome = getGenome(x), qcInfo = qcInfo ) } diff --git a/R/qtlSumStats.R b/R/qtlSumStats.R index 2dd4026e..488c4974 100644 --- a/R/qtlSumStats.R +++ b/R/qtlSumStats.R @@ -12,6 +12,19 @@ #' @include AllClasses.R tupleSelectors.R NULL +#' @title QTL Summary-Statistic Collection +#' @description S4 collection of QTL summary statistics keyed by the identity +#' tuple \code{(study, context, trait)}. Each element is that tuple's +#' per-variant \code{GRanges} -- \code{variant_id} plus the per-variant +#' Z / N / MAF mcols. +#' @details Required columns: \code{study}, \code{context} and \code{trait}; +#' the 3-tuple is unique. The class-level slots inherited from +#' \code{\linkS4class{SumStatsBase}} -- \code{ldSketch}, \code{genome} and +#' \code{qcInfo} -- apply uniformly to every row, and \code{qcInfo} records +#' which \code{\link{summaryStatsQc}} passes have run. +#' @seealso \code{\link{QtlSumStats}} for the constructor and +#' \code{\linkS4class{GwasSumStats}} for the GWAS counterpart. +#' @export setClass( "QtlSumStats", contains = "SumStatsBase", @@ -58,13 +71,10 @@ setClass( NULL } -# genome slot: a single non-empty string. +# The genome build, read from seqinfo (there is no genome slot). # @noRd .qssCheckGenome <- function(object) { - if (length(object@genome) != 1L || str_length(object@genome) == 0L) { - return("'genome' slot must be a single non-empty character string") - } - NULL + .sumStatsCheckGenome(object) } # qcInfo slot must be a list. diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index 5bd26c6c..1e907463 100644 --- a/R/sumstatsQc.R +++ b/R/sumstatsQc.R @@ -1390,216 +1390,9 @@ slalom <- function( # ============================================================================= -# Univariate RSS diagnostics (post-finemap) +# Post-finemap credible-set update strategy # ============================================================================= -#' Extract the trimmed SuSiE fit from a finemapping pipeline result -#' -#' Returns the trimmed model fit underlying \code{con_data$finemappingEntry} (a -#' \code{FineMappingRow} S4 object), or NULL if no fine-mapping entry is -#' attached. -#' -#' @param conData List. The method-layer entry from a finemapping pipeline -#' result, expected to carry \code{$finemappingEntry} as a -#' \code{FineMappingRow} object. -#' @return The trimmed fit (a list with \code{pip}, \code{sets}, etc.) or NULL. -#' @examples -#' data(qtlSumStatsExample) -#' getSusieResult(qtlSumStatsExample) -#' @export -getSusieResult <- function(conData) { - if (length(conData) == 0) { - return(NULL) - } - fm <- conData$finemappingEntry - if (is.null(fm) || !is(fm, "FineMappingResultBase")) { - return(NULL) - } - trimmed <- .fmrPartsSusieFit(fm) - if (length(trimmed) == 0) { - return(NULL) - } - trimmed -} - -#' Process Credible Sets (CS) from Finemapping Results -#' -#' 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 csNames Character vector. Names of the Credible Sets, usually in the -#' format "L_". -#' @param topLociTable Data frame. The top-loci table (e.g. from -#' \code{\link{getTopLoci}}) carrying \code{variant_id}, \code{pip}, and -#' \code{z} columns. -#' @param ldSource The LD source from which the between-credible-set correlation -#' is derived on demand: a \code{QtlDataset} (individual-level) or a -#' \code{QtlSumStats} / \code{GwasSumStats} (summary statistics). See -#' \code{\link{computeCsCorrelation}}. -#' -#' @return A data frame with one row per CS, containing the following columns: -#' \item{cs_name}{Name of the Credible Set} -#' \item{variants_per_cs}{Number of variants in the CS} -#' \item{top_variant}{ID of the variant with the highest PIP in the CS} -#' \item{top_variant_index}{Global index of the top variant} -#' \item{top_pip}{Highest Posterior Inclusion Probability (PIP) in the CS} -#' \item{top_z}{Z-score of the top variant} -#' \item{p_value}{P-value calculated from the top Z-score} -#' \item{cs_corr_1, cs_corr_2, ...}{Each CS's pairwise correlation with every -#' CS (its row of the between-CS matrix, self-correlation on the diagonal), -#' computed on demand from \code{ldSource}. Absent when there are fewer than -#' two credible sets.} -#' \item{cs_corr_max}{Maximum absolute between-CS correlation (excluding the -#' self == 1); \code{NA} for a single CS.} -#' \item{cs_corr_min}{Minimum absolute between-CS correlation; \code{NA} for a -#' single CS.} -#' -#' @details This function is designed to be used only when there is at least one -#' Credible Set in the finemapping results usually for a given study and -#' block. It processes each CS, extracting key information such as the top -#' variant, its statistics, and correlation information between multiple CS if -#' available. -#' -#' @importFrom purrr map map_dbl map_int -#' @importFrom dplyr bind_rows -#' -#' @examples -#' data(qtlSumStatsExample) -#' vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") -#' fit <- list(pip = c(0.1, 0.7, 0.2), sets = list(cs = list(L_1 = c(1, 2)))) -#' tl <- data.frame(variant_id = vids, pip = c(0.1, 0.7, 0.2), -#' z = c(1.0, 3.5, -0.5)) -#' fe <- fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) -#' # A single credible set has no between-CS correlation (cs_corr_* are NA), so -#' # the ldSource is not consulted here. -#' extractCsInfo(fe, csNames = "L_1", topLociTable = tl, -#' ldSource = qtlSumStatsExample) -#' -#' @export -extractCsInfo <- function(fmRow, csNames, topLociTable, ldSource) { - fm <- fmRow - trimmed <- .fmrPartsSusieFit(fm) - variantNames <- .fmrPartsVariantIds(fm) - csCorr <- .rowCsCorrelation(fm, ldSource) - rows <- map( - seq_along(csNames), - .extractCsInfoRow, - csNames = csNames, - trimmed = trimmed, - variantNames = variantNames, - topLociTable = topLociTable - ) - .csAppendCorrelationCols(bind_rows(rows), csCorr) -} - -#' Extract Information for Top Variant from Finemapping Results -#' -#' This function extracts information about the variant with the highest -#' 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 sumstats A list or data frame carrying a \code{z} element aligned to -#' the fit's variants (\code{sumstats$z}). -#' -#' @return A data frame with one row containing the following columns: -#' \item{cs_name}{NA (as no CS is identified)} -#' \item{variants_per_cs}{NA (as no CS is identified)} -#' \item{top_variant}{ID of the variant with the highest PIP} -#' \item{top_variant_index}{Index of the top variant in the original data} -#' \item{top_pip}{Highest Posterior Inclusion Probability (PIP)} -#' \item{top_z}{Z-score of the top variant} -#' \item{p_value}{P-value calculated from the top Z-score} -#' \item{cs_corr_max}{NA (no between-CS correlation without a CS)} -#' \item{cs_corr_min}{NA (no between-CS correlation without a CS)} -#' -#' @details This function is designed to be used when no Credible Sets are -#' identified in the finemapping results, but information about the most -#' significant variant is still desired. It identifies the variant with the -#' highest PIP and extracts relevant statistical information. -#' -#' @note This function is particularly useful for capturing information about -#' potentially important variants that might be included in Credible Sets -#' under different analysis parameters or lower coverage. It maintains a -#' structure similar to the output of `extract_cs_info()` for consistency in -#' downstream analyses. -#' -#' @seealso \code{\link{extractCsInfo}} for processing when Credible Sets are -#' present. -#' -#' @examples -#' vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") -#' fit <- list(pip = c(0.1, 0.7, 0.2)) -#' tl <- data.frame(variant_id = vids, pip = c(0.1, 0.7, 0.2)) -#' fe <- fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) -#' extractTopPipInfo(fe, sumstats = list(z = c(1.0, 3.5, -0.5))) -#' -#' @export -extractTopPipInfo <- function(fmRow, sumstats) { - fm <- fmRow - trimmed <- .fmrPartsSusieFit(fm) - variantNames <- .fmrPartsVariantIds(fm) - # Find the variant with the highest PIP - topPipIndex <- which.max(trimmed$pip) - topPip <- trimmed$pip[topPipIndex] - topVariant <- variantNames[topPipIndex] - topZ <- sumstats$z[topPipIndex] - pValue <- .zToPvalue(topZ) - - list( - cs_name = NA, - variants_per_cs = NA, - top_variant = topVariant, - top_variant_index = topPipIndex, - top_pip = topPip, - top_z = topZ, - p_value = pValue, - cs_corr_max = NA_real_, - cs_corr_min = NA_real_ - ) -} - -# Reduce one credible set's correlation vector (a row of the between-CS matrix, -# the self-correlation == 1 on the diagonal) to its |corr| max/min, excluding -# every self / perfect correlation (== 1). An empty result yields NA. -# @noRd -.extractCorrelations <- function(x) { - filtered <- abs(x[x != 1]) - if (length(filtered) == 0L) { - return(list(max_corr = NA_real_, min_corr = NA_real_)) - } - list( - max_corr = max(filtered, na.rm = TRUE), - min_corr = min(filtered, na.rm = TRUE) - ) -} - -# Append the between-CS correlation columns to the per-CS summary `base` from -# the m x m matrix `csCorr` (whose rows are aligned to `base`): the expanded -# cs_corr_1..m (each CS's row, self-correlation on the diagonal) plus -# cs_corr_max / cs_corr_min (|corr| excluding the self == 1). A NULL matrix -# (fewer than two credible sets) yields NA max/min and no expanded columns. -# @noRd -.csAppendCorrelationCols <- function(base, csCorr) { - if (is.null(csCorr)) { - 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))) - # unname(): apply() names its result by the matrix rownames, which map_dbl - # then carries into the column (tibbles preserve element names). - base |> - bind_cols(expanded) |> - mutate( - cs_corr_max = unname(map_dbl(perRow, "max_corr")), - cs_corr_min = unname(map_dbl(perRow, "min_corr")) - ) -} - #' Process Credible Set Information and Determine Updating Strategy #' #' This function categorizes Credible Sets (CS) within a study block into @@ -5197,28 +4990,6 @@ summaryStatsQc <- function( # ---- other map/apply helpers (lambda-free callbacks) -------------------- -# One credible set's scalar summary row (top variant / PIP / z / p). The -# between-CS correlation columns are appended once by .csAppendCorrelationCols. -# @noRd -.extractCsInfoRow <- function(i, csNames, trimmed, variantNames, topLociTable) { - csName <- csNames[i] - indices <- trimmed$sets$cs[[csName]] - csVariants <- variantNames[indices] - csData <- filter(topLociTable, is_in(.data$variant_id, csVariants)) - topRow <- which.max(csData$pip) - topVariant <- csData$variant_id[topRow] - topZ <- csData$z[topRow] - tibble( - cs_name = csName, - variants_per_cs = length(csVariants), - top_variant = topVariant, - top_variant_index = which(variantNames == topVariant), - top_pip = csData$pip[topRow], - top_z = topZ, - p_value = .zToPvalue(topZ) - ) -} - # TRUE when credible set row `i` is a tagged (redundant) set. # @noRd .autoDecisionTagged <- function(i, df, highCorrCols) { diff --git a/R/tupleSelectors.R b/R/tupleSelectors.R index 8fa0cbb1..436699cc 100644 --- a/R/tupleSelectors.R +++ b/R/tupleSelectors.R @@ -1,9 +1,11 @@ # ============================================================================= # Tuple row matchers # ----------------------------------------------------------------------------- -# Internal helpers shared by the FineMappingResult / TwasWeights / -# SumStats DFrame-subclass collections to resolve a tuple-keyed selection -# to a single row index. Pure R helpers -- no S4 dispatch, no exports. +# Internal helpers shared by the FineMappingResult / TwasWeights / SumStats +# collections to resolve a tuple-keyed selection to a single row index. Every +# collection is a RangedTupleList, so these read identity columns off mcols +# and payloads off the elements -- there is no second shape to branch on. +# Pure R helpers -- no S4 dispatch, no exports. # ============================================================================= # Internal: return integer row indices of `x` where every (column, value) @@ -23,16 +25,12 @@ which(ok) } -# Read an identity column by name, whichever collection shape `x` has. -# `x[[k]]` is a column on the DFrame-backed collections but an ELEMENT on a -# RangedTupleList, where the identity columns live in mcols. The two shapes -# coexist until every collection has migrated. +# Read an identity column by name. Every collection keeps its identity +# columns in mcols; `x[[k]]` addresses an ELEMENT, not a column, so mcols is +# the only correct read. # @noRd .tupleColumn <- function(x, k) { - if (methods::is(x, "RangedTupleList")) { - return(mcols(x)[[k]]) - } - x[[k]] + mcols(x)[[k]] } # One collection ELEMENT, whichever shape `x` has. On a RangedTupleList the @@ -47,10 +45,7 @@ if (methods::is(x, "FineMappingResultBase")) { return(.fmrRowParts(x, i)) } - if (methods::is(x, "RangedTupleList")) { - return(x[[i]]) - } - x$entry[[i]] + x[[i]] } # ALL elements as a plain list, whichever shape `x` has. @@ -64,20 +59,14 @@ ) { return(map(seq_len(nrow(x)), .collectionEntry, x = x)) } - if (methods::is(x, "RangedTupleList")) { - return(as.list(x)) - } - as.list(x$entry) + as.list(x) } -# The identity column NAMES, whichever shape `x` has. `names(x)` is element -# names on a RangedTupleList, not columns. +# The identity column NAMES. `names(x)` would be the ELEMENT names, not the +# columns, so this reads mcols. # @noRd .tupleColumnNames <- function(x) { - if (methods::is(x, "RangedTupleList")) { - return(colnames(mcols(x))) - } - names(x) + colnames(mcols(x)) } # Internal: resolve a tuple-keyed selection (study, context, trait, @@ -286,13 +275,9 @@ if (nrow(x) == 0L) { return(GenomicRanges::GRanges()) } - if (methods::is(x, "RangedTupleList")) { - return(unlist(range(x), use.names = FALSE)) - } - # No fallback to a stored column: nothing carries one any more. A DFrame - # collection (CtwasResult) has no region column either, so an empty - # GRanges is the honest answer rather than a fabricated span. - GenomicRanges::GRanges() + # No stored region column: nothing carries one any more, so the span is + # always derived from the elements' own ranges. + unlist(range(x), use.names = FALSE) } # Internal: append the optional `blockId` provenance column (no-op when NULL). @@ -406,30 +391,26 @@ # region) is padded with `.naLikeColumn` -- so adding a column to a class flows # through combines automatically rather than being hand-listed at each site. # Preserves the concrete class and sets the `ldSketch` slot explicitly (rbind -# does not reliably carry it). Returns NULL when given no inputs. +# does not reliably carry it). Returns NULL when given no inputs. Every +# collection is a RangedTupleList now, so this only drops the NULL parts and +# hands off; the old DFrame path went with the rebase onto GRangesList. # # `slots` carries the collection-level state a concrete subclass adds beyond # `ldSketch` (SumStatsBase's `genome` / `qcInfo`). It is passed in rather than # read off `parts[[1L]]` because those slots describe the WHOLE collection, so # merging them is the caller's decision -- first-wins would silently drop the # other parts' QC audit. -.rbindCollections <- function(parts, ldSketch = NULL, slots = list()) { +.rbindCollections <- function( + parts, + ldSketch = NULL, + slots = list(), + genome = NULL +) { parts <- compact(parts) if (length(parts) == 0L) { return(NULL) } - if (methods::is(parts[[1L]], "RangedTupleList")) { - return(.rbindRangedCollections(parts, ldSketch, slots)) - } - cls <- class(parts[[1L]])[[1L]] - allCols <- reduce(map(parts, names), union) - combined <- map(allCols, .rbindColumn, parts = parts) - names(combined) <- allCols - dfArgs <- c(combined, list(check.names = FALSE)) - df <- exec(S4Vectors::DataFrame, !!!dfArgs) - out <- new(cls, df, ldSketch = ldSketch) - validObject(out) - out + .rbindRangedCollections(parts, ldSketch, slots, genome) } # Internal: aggregate a per-entry accessor across every row of a @@ -588,11 +569,20 @@ # Concatenate column `cn` across all parts (NA-filling parts that lack it). # @noRd -# Row-binding a RANGED collection: the elements append and the mcols rbind. -# The DFrame path cannot be reused because there is no column holding the -# payload any more -- the payload is the container. +# Row-binding a collection: the elements append and the mcols rbind. +# +# S4Vectors::combineRows() does the union-with-NA-fill this needs, but it +# fails on a GRanges-valued mcols column (`traitPos`) with "GRanges objects +# don't support [[, as.list(), lapply(), or unlist()". .rbindColumn() binds +# each column with c() instead, which GRanges does support, so the union is +# done per column here rather than delegated. # @noRd -.rbindRangedCollections <- function(parts, ldSketch, slots = list()) { +.rbindRangedCollections <- function( + parts, + ldSketch, + slots = list(), + genome = NULL +) { cls <- class(parts[[1L]])[[1L]] allCols <- reduce(map(parts, .tupleColumnNames), union) combined <- set_names(map(allCols, .rbindColumn, parts = parts), allCols) @@ -602,6 +592,13 @@ ) 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 out <- exec( methods::new, @@ -1006,21 +1003,84 @@ # first -- and cTWAS computes its full-panel LD from exactly that slot. # ============================================================================= -# Row-bind summary-statistics parts, merging the three collection-level slots. -# `ldSketch` (when non-NULL) overrides the unioned panel. +# The concrete class of `x`, for map_chr over a list of collections. # @noRd -.rbindSumStats <- function(parts, ldSketch, fn) { - sketch <- ldSketch %||% .ssCombineSketch(parts, fn) +.firstClass <- function(x) class(x)[[1L]] + +# Every part must be the same concrete class: the combined object is built as +# `parts[[1L]]`'s class, so a mixed set would silently coerce the rest. +# @noRd +.rtlRequireSameClass <- function(parts, fn) { + classes <- unique(map_chr(parts, .firstClass)) + if (length(classes) > 1L) { + msg <- glue( + "{fn}: inputs must be the same concrete class (got ", + "{str_flatten(classes, ', ')})." + ) + abort(msg) + } + invisible(NULL) +} + +# The collection-level slots BEYOND ldSketch that a combine has to merge, for +# whatever concrete class `parts` are. A slot describes the whole collection, +# so first-wins would silently drop the other parts' state; each gets its own +# rule and an unrecognised slot is an error rather than a quiet default, so +# adding one to a class cannot slip through a combine unnoticed. +# @noRd +.rtlExtraSlots <- function(parts, fn) { + own <- setdiff(.rtlOwnSlots(parts[[1L]]), "ldSketch") + out <- list() + if (is_in("qcInfo", own)) { + out$qcInfo <- .ssCombineQcInfo(parts, fn) + } + unknown <- setdiff(own, names(out)) + if (length(unknown) > 0L) { + cls <- class(parts[[1L]])[[1L]] + msg <- glue( + "{fn}: no merge rule for the collection-level slot(s) ", + "{str_flatten(unknown, ', ')} on class '{cls}'." + ) + abort(msg) + } + out +} + +# Merge `parts` into one collection, reconciling every collection-level slot. +# The single path behind `c()` / `append()` and the four combine*() wrappers. +# A non-NULL `ldSketch` overrides the unioned panel. +# @noRd +.combineTupleCollections <- function(parts, ldSketch, fn) { + .rtlRequireSameClass(parts, fn) + # Forced before the rebuild: GRangesList() merges seqinfo and rejects + # mismatched builds itself, with a message about sequence-level genomes + # that says nothing about which inputs disagreed. + genome <- .rtlCombineGenome(parts, fn) .rbindCollections( parts, - ldSketch = sketch, - slots = list( - genome = .ssCombineGenome(parts, fn), - qcInfo = .ssCombineQcInfo(parts, fn) - ) + ldSketch = ldSketch %||% .combineLdSketch(parts, fn), + slots = .rtlExtraSlots(parts, fn), + genome = genome ) } +# The single build every part must agree on, or NULL for a family that does +# not carry one. Read through getGenome() so it works off seqinfo. +# @noRd +.rtlCombineGenome <- function(parts, fn) { + if (!methods::is(parts[[1L]], "SumStatsBase")) { + return(NULL) + } + .ssCombineGenome(parts, fn) +} + +# Row-bind summary-statistics parts, merging the three collection-level slots. +# `ldSketch` (when non-NULL) overrides the unioned panel. +# @noRd +.rbindSumStats <- function(parts, ldSketch, fn) { + .combineTupleCollections(parts, ldSketch, fn) +} + # One genome build per collection (every entry shares the LD sketch), so the # parts must agree. # @noRd @@ -1104,7 +1164,7 @@ # collection has no panel); a mix is an error, because silently keeping the # panels that exist would leave elements harmonized against nothing. # @noRd -.ssCombineSketch <- function(parts, fn) { +.combineLdSketch <- function(parts, fn) { sketches <- map(parts, getLdSketch) present <- !map_lgl(sketches, is.null) if (!any(present)) { @@ -1122,9 +1182,35 @@ .ssCheckSameSource(handles, fn) handle <- handles[[1L]] handle@snpInfo <- .ssUnionSnpInfo(handles) + handle@chromPaths <- .ssUnionChromPaths(handles, fn) .asLdSketch(handle) } +# Union the per-chromosome shard paths across handles. Two sketches trimmed +# from one genoMeta panel to different chromosomes share path/format/samples +# and differ ONLY here, so unioning is what lets their snpInfo rows keep +# routing: a row reaches its file by its own CHR. One chromosome mapping to +# 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]] + } + } + out +} + # Every panel must read from the same file(s): the union keeps the first # handle and widens its snpInfo, and each row's `fileIdx` addresses a position # in THAT file, so rows from another panel would read the wrong variants. @@ -1144,11 +1230,16 @@ # @noRd .ssSameGenotypeSource <- function(h, first) { + # chromPaths is deliberately NOT compared: two sketches trimmed from the + # same genoMeta panel to different chromosomes differ there and nowhere + # else, and .ssUnionChromPaths() merges them (erroring on a genuine + # conflict). Everything below must match for the union to mean anything -- + # snpInfo rows carry file POSITIONS, which only make sense against the + # same files and the same sample axis. identical(h@path, first@path) && identical(h@format, first@format) && identical(h@nSamples, first@nSamples) && - identical(h@sampleIds, first@sampleIds) && - identical(h@chromPaths, first@chromPaths) + identical(h@sampleIds, first@sampleIds) } # The parts' snpInfo rows, de-duplicated by variant id and returned in genomic diff --git a/R/twasWeightsPipeline.R b/R/twasWeightsPipeline.R index 3a185e53..d20819b9 100644 --- a/R/twasWeightsPipeline.R +++ b/R/twasWeightsPipeline.R @@ -10,8 +10,9 @@ if (!is(a, "TwasWeights") || !is(b, "TwasWeights")) { abort(".rbindTwasWeights expects two TwasWeights inputs.") } - # Carry forward every column (joint*, region, ...) via the generic combine. - .rbindCollections(list(a, b), ldSketch = ldSketch) + # Carry forward every column (joint*, region, ...) and reconcile the + # collection-level slots via the shared combine. + .combineTupleCollections(list(a, b), ldSketch, ".rbindTwasWeights") } # Normalize combine() varargs: accept either N objects or a single list of @@ -63,7 +64,7 @@ #' @export combineTwasWeights <- function(..., ldSketch = NULL) { parts <- .asCombineList(list(...), "TwasWeights", "combineTwasWeights") - reduce(parts, .rbindTwasWeights, ldSketch = ldSketch) + .combineTupleCollections(parts, ldSketch, "combineTwasWeights") } # --- Multi-region (jointRegions) helpers for the QtlDataset method ---------- diff --git a/_pkgdown.yml b/_pkgdown.yml index 1862f12c..907d04aa 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -92,15 +92,20 @@ reference: desc: > S4 class definitions. The `-class` topic documents the slots and validity constraints; the matching constructor topic (next - section) documents the user-facing factory function. + section) documents the user-facing factory function. Virtual + classes have no constructor, and neither does `H2Estimate` -- + `estimateH2()` builds it. contents: - AnnotationMatrix-class - ColocBoostResult-class - ColocResult-class - ColocResultBase-class + - CtwasResult-class + - CtwasResultEntry-class - FineMappingResultBase-class - FineMappingRow-class - GwasFineMappingResult-class + - GwasSumStats-class - H2Estimate-class - LdData-class - LdEigen-class @@ -110,6 +115,7 @@ reference: - MultiStudyQtlDataset-class - QtlDataset-class - QtlFineMappingResult-class + - QtlSumStats-class - RangedTupleList-class - SldscData-class - SumStatsBase-class @@ -118,15 +124,16 @@ reference: - title: "Class constructors" desc: > - User-facing constructors. For classes that have both a `-class` - topic and a constructor topic, prefer the constructor for + User-facing constructors -- one per class, plus the two + alternative `QtlSumStats` builders. Every class here also has a + `-class` topic in the section above: prefer the constructor for day-to-day use; the `-class` topic is the authoritative slot reference. contents: - AnnotationMatrix - - CtwasResult - ColocBoostResult - ColocResult + - CtwasResult - CtwasResultEntry - fineMappingRow - GwasFineMappingResult @@ -158,88 +165,160 @@ reference: - title: "Class methods" desc: > - Accessor and behaviour methods grouped by the class they're - defined on. Generics with implementations on multiple classes - appear under each. S4 pipeline dispatch methods - (`fineMappingPipeline`, `colocboostPipeline`, - `twasWeightsPipeline`) are listed under "Pipelines" further - down rather than repeated per class. + Accessor and behaviour methods, grouped by the class each method is + defined on. A generic with methods on several classes is listed under + every one of them, so each block is the complete callable surface for + that class (a subclass also inherits everything listed under its base). + S4 pipeline dispatch methods (`fineMappingPipeline`, + `colocboostPipeline`, `twasWeightsPipeline`) are listed under + "Pipelines" further down rather than repeated per class. contents: - show-methods - - subtitle: "AnnotationMatrix" - contents: - - getBaseline - - getCandidates - - getGenome - - subtitle: "RangedTupleList" contents: - # The virtual base every collection inherits: container and metadata - # methods, plus the region/variant verbs and the plyranges bridge. - - RangedTupleList-methods - - subsetRegion - - intersectVariants + # The virtual base of every tuple collection: container and metadata + # methods, the region verb, and the plyranges bridge. The families + # that inherit it -- fine-mapping results, colocalization results, + # summary statistics, TWAS weights -- follow. - flattenTupleRanges - nestTupleRanges + - RangedTupleList-methods + - subsetRegion + + - subtitle: "FineMappingResultBase" + contents: - computeCsCorrelation - fsusieAffectedRegions - fsusieCredibleBand - getCredibleSetSummary - getCs - getLbf + - getLdSketch - getMarginalEffects - - getPip + - getMethodNames + - getRegion + - getRetainedMass + - getStudy - getSusieFit - getTopLoci + - getTraitPosition - getVariantIds + - intersectVariants - resolveWeights - - - subtitle: "FineMappingResultBase" - contents: - - getLdSketch - - getMethodNames - - getRegion - - getStudy - writeSumstatsVcf - - subtitle: "CtwasResult / CtwasResultEntry" + - subtitle: "QtlFineMappingResult" contents: - - getCtwasParam - - getFinemap - - getSusieAlpha + - getContexts + - getCvResult + - getFineMappingResult + - getPip + - getTraits - subtitle: "GwasFineMappingResult" contents: - getContexts - getFineMappingResult + - getPip - getTraits - - subtitle: "GwasSumStats" + - subtitle: "FineMappingRow" + contents: + - getCvResult + - getSusieFit + - getVariantIds + + - subtitle: "ColocResultBase / ColocResult / ColocBoostResult" + contents: + - "as.data.frame,ColocBoostResult-method" + - "as.data.frame,ColocResult-method" + - colocViews + - getColocBoostOutcomes + - getComputingTime + - getLdSketch + - getRegionVcp + + - subtitle: "SumStatsBase" contents: - - "getSumStats,GwasSumStats-method" - - combineGwasSumStats - getBeta + - getGenome + - getLdSketch - getMaf - getN - getP + - getQcDiagnostics + - getQcInfo - getSe - - getSumStats - - getSumstatDf - - getVarY + - getStudy + - getVariantIds - getZ - nSnps - subsetChr - - subtitle: "ColocResult / ColocBoostResult" + - subtitle: "GwasSumStats" contents: - - colocViews - - getColocBoostOutcomes - - getComputingTime - - getRegionVcp - - getRetainedMass - - "as.data.frame,ColocResult-method" - - "as.data.frame,ColocBoostResult-method" + - combineGwasSumStats + - getSumstatDf + - "getSumStats,GwasSumStats-method" + - getVarY + - writeSumstatsVcf + + - subtitle: "QtlSumStats" + contents: + - combineQtlSumStats + - getContexts + - getSignificantQtls + - getSumstatDf + - getSumStats + - getTraitPosition + - getTraits + - getVarY + - qtlAssociationPostprocess + + - subtitle: "TwasWeights" + contents: + - getContexts + - getCvResult + - getDataType + - getFits + - getLdSketch + - getMethodNames + - getRegion + - getStandardized + - getStudy + - getTraitPosition + - getTraits + - getTwasWeights + - getVariantIds + - getWeights + - resolveWeights + + - subtitle: "TwasWeightsRow" + contents: + - getCvResult + - getDataType + - getFits + - getStandardized + - getVariantIds + - getWeights + + - subtitle: "AnnotationMatrix" + contents: + # Classes outside the RangedTupleList hierarchy follow, in + # alphabetical order. + - getBaseline + - getCandidates + - getGenome + + - subtitle: "CtwasResult / CtwasResultEntry" + contents: + - getContexts + - getCtwasParam + - getFinemap + - getMethodNames + - getStudy + - getSusieAlpha - subtitle: "H2Estimate" contents: @@ -249,6 +328,7 @@ reference: - getIntercept - getInterceptSe - getLocal + - getMethodNames - getNSnps - getScoreStats - getTauBlocks @@ -263,6 +343,7 @@ reference: - getNRef - getRefPanel - getSnpIdx + - getVariantIds - getVariantInfo - hasGenotypes @@ -273,80 +354,51 @@ reference: - subtitle: "LdScore" contents: - getLdMatrixList - - getLdScoreWeights - getLdScores + - getLdScoreWeights - subtitle: "LdStatistic" contents: + - getGenome - getInSample - getLdBlocks + - getNRef + + - subtitle: "MashPrior" + contents: + - getCvFits + - getFullFit - subtitle: "MultiStudyQtlDataset" contents: - getQtlDatasets + - getStudy + - getSumStats - subtitle: "QtlDataset" contents: - getAf + - getContexts - getGenotypeCovariates - getGenotypes + - getMaf - getPhenotypeCovariates - getPhenotypes - getResidualizedGenotypes - getResidualizedPhenotypes - getScaleResiduals + - getStudy - getTraitPosition - qtlDatasetFilters - - subtitle: "QtlFineMappingResult" - contents: - - getFineMappingResult - - - subtitle: "QtlSumStats" - contents: - - combineQtlSumStats - - getContexts - - getSignificantQtls - - getTraits - - qtlAssociationPostprocess - - - subtitle: "SumStatsBase" - contents: - - getQcInfo - - getQcDiagnostics - - subtitle: "SldscData" contents: + - getAnnotCols - getAnnotData - getFrqData - - getTraitRuns - getTraitNames - - getAnnotCols - getTraitRun - - - subtitle: "MashPrior" - contents: - - getCvFits - - getFullFit - - - subtitle: "TwasWeights" - contents: - - getCvResult - - getDataType - - getFits - - getStandardized - - getTwasWeights - - getWeights - - - subtitle: "TwasWeightsEntry" - contents: - # Same generic surface as TwasWeights — dispatches on per-row entries. - - getCvResult - - getDataType - - getFits - - getStandardized - - getVariantIds - - getWeights + - getTraitRuns - title: "Pipelines" desc: > @@ -396,21 +448,21 @@ reference: - autoDecision - raiss - mergeVariantInfo - - mergeSusieCs - filterRelatedness - title: "LD infrastructure" desc: > - Loading and manipulating LD matrices, plus design-matrix - conditioning utilities. + Computing, loading, and manipulating LD matrices, plus + design-matrix conditioning utilities. contents: - loadLdMatrix - loadLdSketch + - loadLdBlock + - computeLd - checkLd - enforceDesignFullRank - ldClumpByScore - ldLoader - - loadLdBlock - ldPruneByCorrelation - filterVariantsByLdReference @@ -421,7 +473,6 @@ reference: lazily, so the Bioconductor accessors apply to it directly. contents: - readGenotypes - - computeLd - loadGenotypeRegion - readAfreq - getRefVariantInfo @@ -467,12 +518,14 @@ reference: - fsusieWrapper - getSusieResult - computeCsTables + - buildTopLoci - extractCsInfo - extractTopPipInfo - formatFinemappingOutput - lbfToAlpha - postprocessFinemappingFits - combineFineMappingResults + - mergeSusieCs - overlapTopLoci - title: "TWAS" @@ -534,11 +587,13 @@ reference: - combineTwasWeights - twasWeightsCv - twasPredict - - twasZ - estimateSparsity - - subtitle: "Multi-method p-value combination" + - subtitle: "Association testing and p-value combination" contents: + # twasZ() turns weights plus GWAS summary statistics into a per-tuple + # Z and p-value, then delegates cross-tuple pooling to combinePValues(). + - twasZ - combinePValues - waldTestPval @@ -653,8 +708,6 @@ reference: - genotypeDelayedArray - as.data.frame.GwasSumStats - rescaleCovW0 - - buildTopLoci - - "getSumStats,GwasSumStats-method" footer: structure: diff --git a/data/gwasSumStatsS4Example.rda b/data/gwasSumStatsS4Example.rda index 18175d97bf549e9b865ea3398008513dfa79717c..447dca842bf4716ddd4d9b836416ce58aaa52383 100644 GIT binary patch delta 4446 zcmV-k5uxswI+!|;8UaAD8_o-Vx;+__bajdviyAU$P(l^_bc4>NctHb{>fXi6JYoYY zz=G=Z>uI$6-2WqaQi)1lVbti&L0WXP!D_y2#dp)~`rTNbpY{4$fi68eq~vFx&0&$` zgqhEWH>cS9frb{C5>Y%BekRA&((LT!CGBj7| zuZ2z5CgRx5JTqF6l|XMdzSeR!0mqdPkKp;rox*)8U=>)QD#d1v-MM})g1s`KaM8Qx z48}@+&x+MhctFPX%ADeVT0aoH-qdk>^p)qr^SB5C<+bmq7(IG>+IoJFs4{YZ1Yt5U zpPGcMWNsamYq6L{=bbzwSORnAn(@$%&QtgxVvI$Dcd*c16Q5 zy0WKpcx*U6Mo!p&C&pJ|IleOgIbD5xtyfGlYfwK~jC>8^NePiU;{BWC8aT2%oEgMk z$=qhyvTc2GiTMmkhiT;#?37+^?ytR-_22ZyDkbQ;c32S5-z@6L^ZpbpcH}qsFSu^3 zoozlYPXQ4eK8pLL`J#IE0uRI_2SseHsL|Ko&IBATHMMJhgQSmj#?I0KB9y$?vtZ@- z_!)$5Epnnu-3tV_rZ!aYp|RHRbswJ3)SqKc7@7Qq2?&xew;D(h{lL13osKP({h&j( zIi97w?8>D{ns?y6Znui@Hh`pYrbeJV1&-?jF^HyA$314h+}J0}Qet9c*c|eR{(lF< zfTsjxjP@yiE@Qx}bq1yV%!QoZRkR`Y+}HcZMJ=1n^5-eB!g6oA&hy4K0Aq%4 zELz$7o0;9OyL6kgIzB1cY?p6|umfOJ@v1u90rL6uxf&&wnvLgpl(w1aJ!`1Qt?Ja9 zdM-=&yewIC@Y7(j>(-BRheV`W-}fHbdeP#xAMPA~wJ1ckf1>=Rpqvo1`uo0NqLcAa zZ1K?=1`YEFx6X5CE{9@UuZ~*873PpAkf>;nfr8xhl2MuwQZ3J3>f1nf+7!VQD;Kc4 zviWiC*N2}NK`%?B5Mvb$Uyl)#=I{BI`cX|i+nWAZT-k^pOq3=gJlI6W^B3){=T}F| z<)*%W4QA^&!M>ws`&3Bz`fs=JWj-Qv-pr!EGedgPk#Z~%w%)N6M(5t%Yhxc{(;M{# zG$6M0vge$RqCHi08XSIRgUoq5|aaEX$?cRPFf zeB<2Ljy~5V%jQ*ASZw87+X2imVWwolz;Nn+7M2rni_%;5obmi@H{FUh!~j(skpVKn z(RZ~KdBsDQmKki2Gd>C0(X0l&DGebXRI2Qj_HXW$!xlkHrxJ23*x-pG*|y45{T$Dh zAE0}ie!7{EH8(1#Q@_~oYhaE&}`)oXE0|MNHQ?h}7 z9vn&`Mj3p91G+rsS$x`9-oNboEUM8M0nl8TF-}UmF(bL2_CR-O*Ylbh{V!wlj+!yF z3oXqEx3G#^Z~mRyca&VmqP4m=j($#vZLrg^APF9eO4?T?m&-q|o9xs0=GSy;_WcM~ z5a#aE9rCFNkQwz9KGcb5}=VV|he6}$z+Q}cbc_)i7b z4Rx*wf4H6P52j*;Y~Y!*8kD&uJW^l2YY2}O6(x;I7CtwmsG1#ibzg&JBjO-R8!15? znTFORj|Vco9&&W(x{^manaH$$y+M5U1^OctZP%wRd!@lxflcqmGr)SDgkUs(eX6mm zk3O}WU z%?{>RHe;{q=apj`8Hw}_r_EQA<%8SCsBL3v!?crnp4YAcFTj(lDbWpo2BO);(X>sO zn8NYxubR)36;O(*EJ~}(j3Kx);?Qs7SsY)GvE?Jm?*BxcK&kK}FzI2Cf)1uMbJ6HP zCc%UO`9_wHg4dh$W-&!YH7Ed`N5D#1ZG7ADUez<4x|*=0}oZBz4~TE+Cjyg^RBM0V}? zr}N^^KfbM$Z+g6)o{-GxE>Kzgr&Z3A9-}NjXA0vuY z(qE%tHQc`?D0FNmtBz+sasll(bs$r~9c6Gd#%!sV`8vi1Mha?wLk{}%_uT-2A36bG z7u5D{k|Z?xB=(Ek)q9K-_I{}_eyEM75q56AUPI@&$hyMzrYVTtD?`9#6P`X8T9Ae! z=|*92_H>9XhI4M77xOf2bpz>I`+XGlX%}&U0h|bv@$|Q;3Z7exgUHbgyY^NQxae() zi+s2zlk?O*)0P!~GkzqNxBMV-ExO;dXfG(Y+2sWr+D4j~KLZlDNr^`YuO&BL#|o(> zw(g@6LHy>1CO%k=KIM9U>1Yco4a?i9;(jNV`1(>PC~*Vi z>Bj|lwc4cNm^VptR*xU35}!7LICjAVA4`xNbD_zX(V)(tXrxP zm1W80FZHm!g-r#_p^-#)a7m@EeF>Rg>y(P!_ZnSR64f1VpG&x3Ef&?r+!ws5!^~5# zKO&HY6P`-Cb){56W?`h6Jxj4}>v4?^SmRJ>FM=9-!VpGma zvuWm1tpnIHwdq)Tnp33T=<7x4g8NGnYT>%w-^~AZk;7 zA=qr_eX!Ur8&X6wnq&}++%LW!VoRGDsOwt~wJMso%u#s8Gq=$L`gTAJGNEplOBsuQ z=36A8Gx4!FqA0ML2ENYPA<`IoTdz!v%>&<~EEQ&eS z_9k8|?-5Q=np_(pPQ+Mi`{4=_P`a3Zp#N1cF_D_E={Rs0$=Qy7n`c#MIYA+nt zNbuN|MCQKU*A%;u%--@YOG-E3q&Eb}`jxTd(whKTMryT^L#gjR<^SVj#?9Tb0eFV| z7M;iRoSC;t_~~tA!hq9+b1|gARM2l`YRqAj{A#^<_a=Jn@23%uh;^bk`Byi8Qv&(y zc<~+&pkZxMZnT?x!yFppyg`tGSV3uJo(kn@ga3e0hL5-~ zy;wQZiJKIV*(nzd{09AC`#;csWWvlgaFt9g;p62#3kk8<6Dg_t(2ps^*XYCx%x#jF z{oVR5U&n=C{76q`fT1mfUu)h;KL^cbWPQqL(Uy^@Rf2)%n&OBCN^v#-F@6CwooZro zvSI3)DcC{1nF}cEYTmA<(`7i5&QFs$mz1VEMHIomhvG?JE%^- zffjS{-oA#$6)c0u=oj~Y`i?rrWej)*+Qu%pro!eKSzYqu*gTtfcaX87w0MpohaYHIPNB2?+4ClJ2C*ZZczqMc7OA*k{G#iWC&pd_z*}M z+;x`uPoM7mnbM+RMK7#084^rKY;TUY=jVWEd5cpG4U?>g@*gaJi?rpkTf1w}HxzFi zd42%pfbSC&@{m;dK;+us5ySg7#TGNiIakBB3oIiQ;5-^8-vpSKZzVEQ01qfSvh{(; z!Cv%`|3EEtafykg`CWDp4r&!AB7%6ESL+W}3tm2kS9YMEUfVFG<6!%nRcz$e&#Lri z!-N4@;#t~DSjAd@wluC3aT6UCIVh<(cWB4BfkM{fgZr6Bm60RU1TP!((!X0diF_C@ zRB+N!guh5nq}rLy77pkZ&}m1fVn~1uu(9P7s(SSd-r|%nDk-lkcPaAKOSE3ebmIk* z!72FG3L+AL93{bZ2Ec?@m;2fc;biUeiP@JgyPDS^xyWLFj@M;$gJjGpqJcNNVJZxS zQKGDL4e5=_9@2a15Od(`gdw5Q&938|@UJIMKo{&+<-yq^U>u+G?5J~|wOSdTT(O;X z)#tV@Jw}bm>??>9s--T1cT49&mV-uZ9{(}era;l}dGqtB#1k7=%)@vAc`8jL;(}C0 z@|sK(eh+hhWJ@$y3J^EUaJNrOQ^g^SXJ&t3-h#5;lmo?|)9OWRnQ7_S7OnY+f52Ne z7Y@AsOVXtBI}Z+2ZX~>vx2=Xf(z@gR1Hp#W6Eu5L5wZQ4DxM|GG>RBLDYkl&$R~G} z7_D2<5;JHLk$ulc!|W~OA+S~$jUGG2xRtKlcDFcdU_^JLBHOuTib#+9ontnA_~Ll^SR8%^BiQ?#TI$FKzny4)1C|FdY0; zbGJIvp)1p$#dCc=Au4w%+UJNcn_1=aD~pouu>NR8dPN;A)QN)_evC4nix2R)IFB}< z@oA?~x{>*L+_9PBY<$jne*sY)olqcXh{QxnBt`W-1d&&|y-BqY>hf|Of#aK9Rn%_y kZ{Pp`0G8=?RsaF=Il+_!0CVcOXFf0uivj=u00045TK4?Kng9R* delta 4446 zcmV-k5uxswI+!|;8Ua|b8_o-V$@3q6eE;8g*TzbrWlbiwJa)vCkZYrn(n+;{&UUv6 z&8U$Qp7<|+2IO=a58XKeTaEez*=20{t&^-|VHkEWT~XF;m;C$fGwCNBJK!3W(Rkqn z;_+uxBw7*AlCbw><-c>i{J_YO8N^VWWGPi2+?+LOHmzf8UUx}TtqK)?2lSnrchB7G z^yw4SL@h(~{8i-*a=cbA&nYD?-K)Kpzwh#BHtPU;;xeDw`3pb~8%%i?cjc%6%}ixW z^u;UXy1nOijM@96Q+wL2 zZ?3Av`xV3gf7aM#sNpfK;85ky*%7tW5!hmuHieoaUo0Bdh#1X(N0a3kS!i7yEp(6? zjqQ^~R;)kgd4*#sy>{{pJ=Wco!CWji1zDrcsffc$;GBYyDXK}K?Vwc~z96~$F=CKW z%a^#I>*Ei^FQ54!?YOwJmga<9I|iuUZp8~9ULJ*487Kuqm*u+o$OE6T)I}+(BL<+% zD_J`HXG4aE!;Z6m*u+~w-pZnq_lFb3mc3=g^xxSXcOg^mhHnh@X8Y7#%!8~$7E}qs z_^q9|ZltBx(OCLdY?Vz=dsaZRik-rHjTXF*vvqzwY}c-slcx|p!}q?ixLbe@B&@ry zJG0YI-on0?NC$w&dls$l3kTNUcoZb_Xyvt+^mGwFrb_UCKDdb@wA7`*Co-m!tOL*C zc8}&i2py9KVmJpam1%kO0oEo$JLho5Cr^{q9suS3;t2f~^6pYd5^?)p4mSy>1g-HD zH9Z5K9yx?tet2{TUEtS_HB7QrXX*dU5z}>D;BY)0B8oL{^z?D#2Zb|6l_IzOAly6W z%;RkBAcb^=c1y&af*o!O|tR9Fx%Yo%M$140Z0@iVLCe#*&YoO-O&9yCH>7 z(goVQ`oBnP=E`V|1Kf+riPOVOv5ZO4F^-?0^Y^nBH4T8j@P#ZAlBhIDnhS$Ou?_Eo z-v(l&?Jl8*YnCo5Oz|(v4GPavXHux~KXPt{D8{LOQlh*tvvJou#x8UCA8qJSJ1ips zgY0Jb2SGl<%Rbt13@sZK$LO@;1CGD5W{<80H%%iU2&cD)W)lL%F?OkTeX_Hw)#-J7Ct*wh9mOsMbA(>LmcDj+_^N*rOr9OE>FX1=J0EB(bKp1vw;>Xh>N7ZYg4s zA(^M~pu;DG%gy!;%1d8wD))N6qF_5E*VYO=m8Rrx)hG8}`bS21e1qDK0LpruF*pa> z2t#M!(lB+aa~Tf;RS8S72~C$nbOoWyo2m}6-Iwb7iE*O4lK4j`+# zoL`HQZ%-FP)MgoD#7F%_5$MObI;WVZTPO6H8uyMJ@}g-PkHQ?jvaufii~uPw0! zKt~3TEbp;ErP4FVcTMMEXhCt21{7GHeSY{f`93veXFjFlCXIaRu?u-EVIDHlPxDLg z1IgQtuWj%m#R?BE^xnXUvo7i4k!D=ZD}omJKHdd2X5D-9>;A@ z$dU!1v&-A|84=h=V^MW~vgb;H6YMV*kBO0Qjl&BfS1Op#bOR*@Jyv2ORrv6tT?rQP zs`2Y|=~@UnLbk2iS2T7PuNGmZOBB~2{?9^_Ppek#WgzGYgRfBUP^r8IDPtW+{>!=O zsv#|C6)sy1euhN4Jb*0NAA#XRB#o)2!A2*UOE38f_pd)rbfl(#ml-N^7F3fUed7!t zwm_#y6jMnieBh<8bsCco2tBM)S@cuC#{39X(}UZ2-h}P?oytar^SCTGCOgpXwPbHe zK;MOEw8wz-;t71$j!)6eLA#Sqz@HVnJ6ab>305EwnB{dcxXltA^f5TT-~DT2a{P%dL$g%~dd)?moUe$f?M0HlRd( z&Udib%PM7>NawL~;R31W^Ncr$(>=h+y4^#^Z*Hf5Y-Gy1sl^hcxM-q9Pc#*KUW3n3 zaAs=cXS00q+yAclGI*?0xAYVZZ6qEXo-A&ugn)Q#_F!m#@MW5kZ=&645xTv#R?rV6 zXY@5-sVERRTJuYuv$(q9yfk0jG(62Swc!3H3B5se{*|ZQC>tKn*^a^h@SgBLY_nlJ zwx3{ZRJ8q+vSlhOT8kB8TMK|T4nM~5%(1wM@p+l>&m|e@=AAO<0$&OggwOHDkA530 zaW-aGJN5^EORvaZjT1LVh{gnaFh%P#3dKihF}=;cdx7Cw_b}3DcWh49VjGZRB(eP~ z)I)4;RswULUGCjlC5g@DJ{f1>&Uoa@AoaGa{>UP4>TAg(-3TV}OHu0%#615TTd8)2 z6_vS^vvIF2vAfKaoRt^E)T9^`zT6agia{o>BmIbfKiVBvMN+8`3Vo`Ds|Tfd_#Uww z61k>hP-9*ndo$4$iBjay=2ZE=$7xXB)_0Y#5xcdD$q7JEe~KqeclNC2*g?wjA4u5D&`AaUP#~(nJlq^q;j=a__#Kth{1nM<#2236u z3dKo(QNB*|+0xfO@DPst{bwH@Ctl(6EEQEZ2P*8Fh}qf}uSvVx90Kn-u!+`|+~M{b zG8?#X)NH%pdBez!mQTW>HMqO(+4;dHR#d@jC2f%ia+w9X)G5$CJEQjq%x95cL=Nhs zbfqXrXE?VW3_)-v!pyn&pDJ>6XB^qCn#9?Ev_2+>3TROT!TO3U!H&32)LI-|L^NVF zxRd02uI5SQ=>`e`?;&^mdVxcLZ^sI)U-jYs_rtLW9Dp zL!=rCSA3i*ojwLLnT-8s%64>1kP#VG11)rs{^hlz#7Ftc;{aP;nhHE=kS9K`TP-Yq z4@YhOJTeQf?FhFpNwQHtes4;iFj!te<@aUiY#Y#ZoTfiB=0AOvPTGNjmLyRF9#o}T1;(rk}j&fK8*x?>*_c$;(QSuKjodGup zZoXbif4J?27%9;;BUK}k%wHeF``tZ%ypY26m~0@_c{8Pd9wH=3mhH#mK)UN#g7T(T zR=FfLhbm%o=pXJxPY2cwp?b-Q7~2&l>(2qc?x0Kn0#FJV^kc*fwIZ+;1Z+s*9^!af z;0%tUvWqe2v}G*3ET(2#}94JVvD_OXhiNnnU8>eyFRl z6OSKkAtg(VMCPXk@|IN>Ati8ghgC7f!vr)I>wBDHxSeFl)@VI5$*AjN#g-Q;5{G>cbHuSyvB@}MtiHR z{D5xd2JU>PyR4hbenyN`H5&NFROBtVFo@9s?eGfZ%deJ)u2Q+0+j5oXhFa0e&z~nMhju0WIMH+J@V%55xm5E`)=5^S&^#ou}S7zy2ZW6I7%n1f2VU5_naL8MT)PSb#{k29Ztug>Z+ z%t-EW1ZT!?q}*-MLu+h*6-lVC>whr5b7NJSZ4d|iAM~5Ten@TVWEr`Ip~K#~N!T}r z#bN)e-Xnbn?5u-rvj(F;WB~&n$Sg^e((fKB#f8L?ntV zJljtrc+eKnNfot9paM{rValmt%&lb2rERFz7r7vT^ad(o6E3p-Qe*CjSI(p zNFObGAmueMKm%?R+=!cu=@4vO$5O)dmpYSVM9kEJwB+BS?-^JK=_3XdIcZJW4!?LM zwN=#<#QV>FUDI5D%=Y|N2XIDbP=?lR@|JN+z10a{OAZSA#fA`_0N0*9>r zhQZtOA9q#vn$1EEv@vy*bAmme(l3Kr8W;6F70$?5xgB2xNkO+~$>i4kLT|xg!tc~m zuIIrm4fyx3tEo6&n3_2!tQ*{?KW2VY)A_b(ngGow&{tM}C`ogw&hm5f}hDB5z4 zb$-jP*rltQBidKbfH{`z#BjavVU+loFcP8Xbjr732ggvuG#V6*!QVz-K&ea%zHLtZ z9(fG$15#XQxOM`l+$~tNODKOkD;+G%P$Vr4cnq39I8yjwyrmUrM#GH7a@?DA5N|Z0 zh^|^ZkVpNQ=z^|MDYR06CS4q25F4?Ko?tkM1ss19P?>_J zD$Y41HPfy|AC^w{)BVlTHOFK(HPL{pHf@=1V>xL+ibA0ZfR6RW<9hCBcjD&{p6Np7 z4;e8y7NePfuKi-iPEJp=hf~pax+~25efTQH^pe?s=vc2oO+qK;vMHp)Re*F0Qgib{ zNVFLB#?&;4J`lIUSZ%F(BauLGo8VEjR%^0VNioB4hr0feTkcm8aV)Es!~)423&o$V z>bHo((go&_Hb8(r^Yv(1M)>a8Vkgfq8MKvsfTVZ{+{JCQWrf6D?hVtqOYv3$ZBEd= z)N5%`u2_^K;4YF+*Z#AjAz3p^&D@(D^^Qr)l{8kTe$viCiAvbIeB-ts8P;woAdt(- kf4%?!0Pyd^mH+|rIoXs100Wg2@;)#Pivj=u00045S|(hrGXMYp diff --git a/data/multiStudyQtlDatasetExample.rda b/data/multiStudyQtlDatasetExample.rda index 6207969718ba46c427ee86c4b0faf38b057ea1f4..981d490a04dbf6b57b7d4258fb601c7f83733b55 100644 GIT binary patch delta 7278 zcmV-!9FgP1Ik-8H83Yh`9D0!*bboCIkRim%JSiVJPZ+?uy|5e@z_(u5keq&H`X(m4sS-HL}7MjQE7=CgO5^1j>|SD^s@vk zvRbPA90xjLP_QYjop%?=Jk@fSvMp}w@YPT`KSNPzH;iwPe=S1`KBdEC@P8)JVcWRF zv~7U_FD@EMVr2F{Yr*-5;R-0+g=I?Td~0!e^#Rc>R*Znj{aVo(1q!&1ChBFuN6Fvm zl~ad8aDLZ=daAN38-QH_(}!y%jK_S)g9sGCNyg7D#0{>8q!=Gti-Ta5pEg;}kmmp{ zT=caO7UK}MnK-YH%&p&VTz~pDP{{d{Krt+^i^4PN)9^+=L{zw%JPL=^PQsZq{;wjV z8H*)zlw>yg3j-)-=kQ@b5wX9Z(*8XQRLUrmPfX#D_!%I;%fIe&8TzjeM$#wEu+JLQ z@GN~f00{kQ6|1?Vkm39gjDpmeEH-M_cbVtU-VUcKgxZsi1dd@22!GgEd;1)JRfozc z72L98@tX?zrCEryDH+h2z=)+%f2IKu2&m>jgRD+k4t`z-f(7YoS{yY9Fax z@HrfiNsd)fE@o1TF&K}4O0(88LR%ymH4jC%(Px`{L{@ACZalDWoxp%4;|CbJG760D zmDEH=Ph|&sD?3FV4sW}= zJw63}BrTwrlV8U$$*)n!ZNGx^ZjkL5(c8F4tT5Bew|M|l%PYb&f4fU4eUYf^r*&f; zEH{#$yuq7J+kby1iTu0|VfHS)v;Q+`ABUR_Os(Jg`ox^#OitaHk<{!g#|6U`m}P9S zcId6>dCMkRZ6w+)J7Pl4zp5ip26>z)+v_5Q5lZxvl35-fO;6fZ)lHO3lys#`ZIE(m zS?gDo+jgT$@qLILy{JchNIuIc<)zf&-g5fSylAO&T-$@Z)U|rpFnh4>;BF_cP|@(tcGj{ljfX zu@%449f9kFCblsjd&bZh5$N$Pi3ISL_W*v)noe78N!4+UG}j zsQLXQwtuiRH<<05HWe*Y^_tW+jIW4cUu~Y`QfCVjcnb}7G7Fnmu!hlSo|vGC79eP$ zy~Xik-hXS7p0II_4F3s^^Es9%ca^gpUflIJ|1?BhO064~AhR~^p!Llm5w9p*UCa4j zQAOLswQsGndMSP^5afU)R0koavlZb368RIS|9>!5%l{u1Pe{HCk_(|z&; zY5T{IJFjo0+1YE)Zy#-C&*`i_Ke!yK8F%j#Qqum+9Jg3ciZM)3q!L{rRDP75-!u4@#PimzI!I!9B1e6(&Xk^8OtKt?4} zOn-mHr);d-F7xp$xh9OeG1)^y&n(?A1A|dW5^iDflV}(PY(yyyYlSBA2h9Ogx1@#0S8+3Fy}4I5MQcoH8|6RR zOz;Y~hSBQPVr{;(7juF~gf{rgmXG!)FMr=_AlgCjD-|7~ZXeKB&Mmb9W4AdU&*NDg zFv|#-UNpZp{YUIr*XiXJth5OBxvK9z$6{qx3Bf=p?H>cvUp9(qI}kwAPNd0gCKRuB;pf5kGuargL30}ui@%EDY|{2GwElr$58+EZ+bRHF5C z-~62i;CZbn_&iTJYq%oR=tSm7v#ery5ay69#h+tK6w$*K8Pk>DhMU!*?(+P#+dPV* zCv5MZfr-M})B8tlg-#$AT|mXWPk%xXf9aC9kK0L7rbXrD#bMLDFkF+HA6wiGduh0E zM6>GZ$4KPPNH(k{E}rL6h=qJ}igwKD@lrs+bglH$$15!^8j$VKPLEd?75gk~s5~xV zWp8}y+r$`cZ(>M?BnnN^Nca{vNIYYsm+7%E0{|`6-PHqkmGRLrdYHlU&41D0YE_Ye z+G)hfoy9{$zS4vEU&&84GYl` zaE?e6_V>5$;JvyuzSMi4dISpueqK-2cjuZxmQ7R;VGwH9@K%A{0-wesaZ+|2 zv&!paJ-2=!Z!?YO$hPSnYrR)$QLNlr>_^@x;~;3*dO1+EZ|`yXq^lt*0+uzry99J4 z$+k_`giHh^&CSq7P=6q_fdVWDhKE*-^kGd&uWtkS^#10^4jW>39dS~H(v3LRU_+HY z83J{_oet$xRz79zVOw}E7~X&QfI;K~_Qp*zpvNa}qNe2Xy+_Q=uhfE&Q50m`^ZWltz*^S9NPpnvqSbyGJ;i+5ElKvo&6Rc;hIX?dOQ&`@2s zWwLK5kwr7fsuX=Vf^-=0JYMT^k=&s+f$Ktn_aJwx?%nS@)3#^tZQhk1s25WArbn|q zV&zo2qTj1x-3VZd9A&s|bi8G!TXs`&+Nbh$ayZ$C2YV7s)Dx4! z3RBS3BPT8r+gzGCZI?u(ZhNjlc=OvaW6YZyN$I_Adq@PWmAT8w7xS++hpaxG!363r z*2~>Jd>3omilAG@kM2g-%u!S)gV8=KxFq|w=1JQOj(1A3&H<#x{7N5!~dW;9UPe|-L$GoQ^0 zjrpGGq?k;hwC>eAoaRJCQu{micPL0p>(zE@&t8X2xfat63Q65%wJIg)R}ma)j9V!j znt!Iw3Xn-E`U+kfG-mNOUztF{%o^UGwcKSzVH?jc>o#Wwz+C zrwZhf$<#yDVtU8KXxwJE50o&y38&&9Vt=BPs1FQUKigvief;Qia5{T?^g?B9RfrzY z)<^MmS?u`e9Y#4?F%%Gw-oG5pwfdV0>0j?@xosAup->POR%+rKi4lvgO{%1$N9dz` zJFc!Euu-~CZOgFpU1(ywHYVN>;k)Uqw^ZsPa(|9d zv0)%>P?{pseiGa?w<#eec3_qNe$+6eU#vi5O70*VXeMeLA2yqgwj5{;@m^d1o_geU zWAt5y&5|rwJj8DhV8FefyM8DBa%4<^04(0tzr1|TJn7F9-nXV|Ham5u_n37F5J6_N zp1y%xJIp`WDkm7heL6N9suL=hD1ZCzcA9Hjudr8%-83LFF~6tIfM(vIy*RfkwDSW3 z4PcW-#SMviL>E>7sbV<&B66wGr{uE4`P&pArZhb$AvA!%##PL>%O(FY$fQrXmB}H! zzsVG$b?NP~`9^==R!W4D^pxiSbrk+_CCyH8@1vny?fMR6UtqcH2I2zs|L@ z<+>-dx`3m%9OWJWXAhzPea#IM=?F*ig_sGS0%vp062ca(8sC;11hHlPhz!`;p(P)< z*5vTfPi^%r9|X2If+Io^kbioq#}tsc;%?=ao*CPlx2Nv@yPMm%g1z212mM|ye$yJ< zCxSnEgTu$j(xq+}mBUfGqa*9!N4Panw#}lP!dWa;`V$A*+DpHwn{gT!0VGjcu2j}w z4-^bQY4GcRbq~lhe?i)qHurPA$-{uOZEVQbVfC7f7kgE;TtW{Y!GCKIWHKj23cX7! z525L$L>ul!z>aiI+l09HjkqdU<){j}bIL%`WIK6i0Pn^jO=`FCy0&u$+UDx9gert& zNJWJxleIRmTKpq{Bdg|T-IAKv4Z9w1D_6Wi|1&!ijR>DF2N`LK^uu=zEKAN2zZ8J5TXZ{fzK>4VJy0kFQzDZ z531{CYpm`n(T9~qPp`7|t$vy>p}SIO6n=A4^oYO?pr`>2d7{JsqSoEhSz%L81C#O8 zZ3sfbW6LGUHi3k>;KHd)kNC3y{FMUp47>TJ)=l;VK z_bFknF`yUm%YVxQb-h7xx9gD5hgy2sMO9JAuleF2>!dXtgntzK*foJN5h zE^H8!@O&*ch3s=Rff(jRKs0mT`)@R@?5DW_F;-&UjbV2ZnU{^SY#~@{?L@qP)hsLm zK@3!AWiW*g9+=du!fY|CAq09XH}ulbuN&$lkAZ~FB!8~_x#sj)qcbHc3EG+couy2t zU%Qo(Hbuf|(oR#GHA_)fhv4kfbOOO}_4g2#wuqKiB{lZwwsS*?mzjJ& zmK2X=d{E&*!zB)Qn>b#Zbq6+SpMirDZNXdY`$n!trkEOme_0SHLSS8Q1|GV~vSsE& z;x7&8GD;wjo&Ft0yk9T=^&L}Os8l-0*x4Nmw|E;~-3e%#?)()G=I1Ik~fNR&lzseuIbox&HUnh27#BHriE-N z!rFHY>7dp#rCr=zbS4M~noJ5mMqo~l{YC+?E6D0wwWlSO_EJ|#A1wOf^FF+>IxU?V zVe()H;b=2Q{aXe~sf+(e;puFsQ<-8rrh|-9M?5yHQUQ!HcWOw)L84vjvSt}527f*h zzwm9C(x!m=6B799LFn>4PUAwm3-Z@t(tML zTQRLDHKhb$qqHna-~a1RDj{bie2Uue8}$|)%GcH*3`{S*$=0-5vZnyHHq8m@mu+@x zLo8tUiOhksp20Ct9*I%%c|uOXMSuJ2jK_V3?L3Ue|Co&a%dv`(3^75td;I3u{m~+n zW*?9$(jTd8_Q5Z@(k|tEP426?NDNg@SaLc1YbSxLG=Uyu6!ey%I`@7rn#ZuL_{9kh0Z*GJZsX%bN{Ns;e7q#O?4sViFcqVfbQAJxBgvc5d2!Tq|Y~o_%hEf0fDI!!s zPcUSOE=Z<@6h&t}L#s^LeJA@euDvZ^ub@QACQ?|GJs4wBmO+!D5ED@?t;X!Ae6p>{ zE;S58qC-ADwjFbWKl+>0L4UG)FnW+(3iJ+)7=i|E7M918q1EyX1&|ezXD@G9-D0M; zlbPHmT_gYto;e}qfXb&d5LVvnNv)nMA&!N!KSaOpjLg`?w11d#ytvEw)A!o7k~BK8oIPJj638jD4h5I?F6 zHMv_@+ASr;2D3lBIg{-#y|rESnNACkmXiQw>F3@`UupMG0;%QNyYEae;m)e-^$P+J zyWd^E%vw8hNAw%eK=RBXuXymk5&CZ2D1$!KZZ2&$bT}uoIgYOtF~C4=a1;KbEG5DG z96beM?u$0b?TP=1Lw^ULg8`eY0hVxo`5bGf&90}GzbNjbb5-AN8_iq_Y43Pk6TtG& z!Bx6?pk*b;0DTLal@0P(Z3SxVhdT}9+emHWOokxMjVmEV83t{{h1sGe;3Fd+HLV@j z>~;pAAhnOfG5W`m!EMKXjK(w$WGJ5e$9Sa`GYct`preDRX@89o;JUHIdl+Aa$%JH+ z@9yyLUB0BoF*FQmJSWxXV(doBn|^GpP@h_6OT@dC~|GIaYYq4w7B{R6n@B%{DsIG^J6$BR)FEe&*Zbgu2nO%lOJ1s*R8i2VD9st$(h9td}JPacUNVFAwC2z`syN z$^f!&4Qy7O6&FI<8uN0zFCUHQ%Ez%E`bWsw0}nd@droYTZWkm>y{#5IinfYQd}ljV zGGF}9lrlyCmNXjG3HODJx1mn0C=xWJH3Q#?bE^?-O2^3@P@B>cLcRv;0E%`Kk1R;5 zA7PW4f`2U^0bh=6I1`1j)m!+z7UHJ=-7a0M-*8UKB4tQycptpu%kY{TlO-%HaC>1u zbpqV2)y^;hoR@u-Z48|b)U|OgmG=AZQD`3Rup;6;o}12*2Yx}WYtwa_hI+)S2&AD# z-49Mw)-V3_oBb9T3+)bw$d8)6(T_Pd=*JBX^?xjT?NfhON6mm8g{}>$GPPQvV-uwq z4~qg`=Seh34eS9k6NYkFguQP)c)?=c+bl=%yu0>r1PU?McSThl_cmk?zkJ$4?x%5wKo!Q`msq9c^p3}kP zhbLtn-~GEiyf3Y@ch9@hYTrN_q_>I%eQ^AhCNrGk&DQsUqzZnSegCZ0DyX!{I-Mn@ z$dh-j+>jToXzM~sk7Yy{%{hn^5{4E3kX7@@sWJ@Nukb!on}iR+608Te1+_krIX^Jc8J}5M=cu|@_%KM zJP!4#U-6pBn|8j(uQiIinq`&>lJ@+q=}{EHtOZe$b;6lh;rYm%R

bH8r5flU191FPA``ofSFP#r%OwZxntaitjLk)5=Qc8hx&39V9WwM(soWRQ1ps(dG-_tm1fbMrwtpd@myJ`zl_?O$ z7+GeBk3ETCvxyWi+x0v9b%`ZcQeH`LqkmV5x`SXSC=_;>c5$^__`73HXV?SyB8ki? zNCBu~)7DtivEn$c&yV2sIe>yIt=5TK9oHbN>=wr(E~>H1Ei;%;{Ab?ZamTDm} zUg)}+#fAMS-naK&$<2(xUXr$DF`d700#B<1$Pl7cMa4=hep3)27446%Bv0~AfRUb< z6p^YOIVy(pov{s0`WEVP)B9e@*kj!9eB-%BP_|5IJ!YDL@;N%CeSaAOJ0e%k3Kz!C zE6_;bMQd+!U}y55Px;T5Tx4Y6-!Gh0G!|aNI_g$bf`7Kz8^?!%H+8 zJ8XZ}AEJdqdw>^H1%U9LM9!Lwl<(`~nvg?!6<6zYzh6*Oi(i^C6Ra)60XBl8Lspdvb z#_F~_=7~6@iRhYxKYD$Z@rk$+;DmooCN9{!D66e_Z7o&s_4f%)3$3+xSj{MW=2np^ zpLPC&?vK_-@4IJ4)<=#cZ34a2{4}c%b%p-mWB@j*acFXUL4TKp@#F~w4tz&xrYVKz z8nR<$svw0Huzy#c6Ex~;Y9%?7{6>pjQzwlBY1a=JQPMVCs^|8>i`o{HD#MQbDtjXX zBSHV|8Lqia!RI{bAg1k`Peh5dQevhLwxt!eY5>37xq?7`_-(omtL-$1`Dcv0?KlqW zApMf{KY>DPH2os5T?hMdERn`aRteb1@($mgd66MC9DfdS4o4eYaMe>qOxmK-w#5w6 zh0@qWSA6YzakJBTA9)2q%Kiv>V#Jgdp~Fjath#87e|F+XP!LgrD)O78(ES@U#4Wo3X2fFlpi#P$8)$!0Kf41@1_2v;1#}GB5v%xW;x}DEG z<_A9k)qkA=S!Q1tY;ku#nSw|$(Z#q4u%QY(H1RA1Qc`&RX&++Yq2gSjayV=_QdNwB z&`9@QSyO_YHmKKx#`Py80SkE&vRW|_N>n~De4Q_qXt*q3E%`jj_Y;jOy&E4|mY_X` zvGg3MySB-h?cvK~>3-t>)%x(!wvjL+K94!ZH-Bi3batk5vFC-+!oB%6ghX>k)GJW2 zV(tB-v9lS#k*8K>sooz184w@`=U-P&iM*xm{q~6tK+yv)pkuMjX@eNX5UDhz2DmB_ zj24Wg@D@c8`?1K-+9P$?32M;q_Jor(mCvs-{77CIpXl@3f#CE$k9q^p=|riocZOOl z27gEEUc9H09{H%;b=atf4WZJdVJ>iBpmz`uvDGX%*-<6Yig36r#pKa&GNWP3ZtNrF z=0ktlFWWNbg6&!Edqv~wp!A)5$=iMqK&)25t0TN4>E`Z@K=U7|L^TEQL|FsnG{O{O20jSzxyLyCNrWwDy25aE%Cqx6~Z`V#&t!(Or<*MCz5 ziQc{iOXpswE@i7sbA?Mo-$!?PLw8{+#XBJMPTCdFj-Yq+O#rC*lU@*u`ChVhoJRCa z0iRNIyQu{N_urXWkNbgKdqPurOGs+gMbF^U{E14dP9U|Ju}_?~FFS}ZeiNK>L+Pao zV{gNsvi5xn;-@qqAB+Ip^JgHKvwsWw!<1Q(c8A6LylKhmkBBX^!$(mJuLsg z;M$V-B~U*Uz@2Y4@R}cs=YOna9$}2hg&+mCeLvzdKw)rA$#FZn6pNqf??hcA@^|_Z zEte+QX3RIORJK@e5)@XitFbzB6evOV;MML=vs;nzrOC&WT@*?9BZeO~`(n(__ezn` zWsb*|9F^BX(t6BjdyE6Z3iQ}5IEOqE+$unqV6vTe4E^I<>iGkOhJT`DR!Qcfa>Bv? zu<{N|c-UMtlP@ztjb#XA*SP-_@_|21xXcZ2ipGW~Io8pK_L2I!eVKoySgYZ`EwJP4 zj@S=WQspHrTJ9=M01XBq=Nif}qDGj&3RxR(q0Mso^xMDQO7;_+n5(d$NuL$vo^&ZN zEOZQXd`Tvu!9sg1|9`@rR3&8v@h)l7HQypf@m+7=Nmu6bLR|gh-x@w5Xw91Dw1L=5 z7l}qeGO%>302E_OI9N+Dke7Xo;;S-9rnEQxb|$_$UAYq{DmIetF4M7^Aasj~jXh|< zV8yi?QjUbcHeVl})son7UWKS$7Pq!vFc@-om%iVrsb}4<4}X=nfe6M3;bR3uJ3-;M z?P&;I_Y83@_WdWQbb(uJ^BE+&x0f+rstEPJOa`Jn7&_qOb+dYdi~RtXlsHR8rO>o@ zEdp0Zzg_3{buqDlQDPmmks3tct1*OCR9_$*(Tr}JzQ$4{O@CUH<}0epLyz&fG}d^F z6+gq9-T&UhCx1cZq}C4W{_Tp2xXiETA9BbG`MpQ|t^>2K8N^s)-+6X|L_q}F%MFA> z{|FqL@ing@P2G2FHu9niHWT_Q?Z7}kbSuT%AaZaNOk~f{X#m~Kk`w`giJY=e*F-Do z7Mt5u-|Z{BUU8tkTLy)r`2N*#sZi@6Wo9DX8F}A)cz>OkLtVsd)%aNA$no{VY#jVU z>^M`AtF^*U7}yiG!tMVdX7lBPx2iXvhhr~T4?;_A#FxFcKa?>+<40qM)_$A^K*fV< z*m#b1qBbNUFK5c$Z?oh`z7~@rR55Ln*fAS5_Nngb!Eyp-Hm{}!$r%Dsq1eSKA(A7K z`IEb!6@Q>PX^zTP+)XpqQqdMc?d6Km-v&Pt7_Id4Y1B2rwcCjMS>1)_aQJVA z8_YK9c7DIwc`NU_1M7>CYB{)hY0l-xIYfGpI)CHo1NNsSNc}albc%%kcNM(hF|1_1 zoPTZ08BIXO_SHlx5$YCV!r8J$;j%AIt|#(t_`nMa_v9k^PE21wx;-$j{vnn?9@@|q z`>S@Zn1DJbzJ`zafo|HzF<{DuqWBXfIon=}X@zDfR%|;mcPj{vhmg-~d3!eP;kB9~ zl7IW)^?$y3Ow}wP6WU2e92QXat9)tYn=mPf?@-Z`54WD2RueELqT&w?`px&SZf3ij zR?+^iYsZSmHFfYeqj-c5z=djrEr3?Oh|JqOWn|~xA2V@H9Cj}%*w5p||M*m)KknXM z$ip9ZST6}l;;}GMuxE#(R5n4`FO{{sK7YAv2k0~rjd%Vo1Wi&|nzpoKeR(s(f1+(f zPjw-WbXW*d?)2dOSSBzWpH8_Xo)4~fL7Wz4a+F~$06GA)09~Ozs&PvxLul#rcuwj= zRgj_X{i5aXa_dAkJzuwF#;L`Z^FuYN#D7Co zla~=fG?5fHzv6L&TSE5=EVrCV;k5k=8z~?vuxz5abk84Ns9Zq5K zz1Z%FP9uog(4(U4i&%+}fVC9IW1E%0&bn~Xg%hp`U76k(cxdc?8D{K&RD~OP8fF`e z2~d9$sJJ>12%F5?43rP2Z^ycS#D8H4Re?{F6ekO_UFgTNMT2A zbmbzd`#Z8;R0hu2`G{y$YK{=YoPI}Z_uAng7~EHt^JpVVS@W;o^cUV|X@HHeYOP`T z&*s7)7g+$2`)%>c)<7EZ>VH8f%1@j{2zdpOZjI$1+oN6|V)lkSy@!Q;G>TjwTtFJ# z-5HAAV)s|(<+Jgy7mi5;LNOkm8VsD+Zn4z>p}y4_gYyCrWjx#PcVx|0e3#g2;gBpU zVy0`rh7Z8cf{IbenU6JMNC(vnfF4A^p25#6f}%Xb+3Wn9fA9VuLx22pH;c&t0wZ=T z2&C?E*E>=fCj%14wanQvlSw~t5_1W6HL0WM^m&l?GfLGM_KBS(>^cNZm@9yZlHdY> zc52puNiMe~iz5cHdWNIR*%3b7brWFk@oC__WE7u_-!q78UalR_c!Ln5(7a@We6V`V zbMAKkU~RdXRoVBBv42}a9?fLA=Oo-+DqZT)m_wv?>Bq}%JFSZ_Rnsp%`L8$KybEz? zykI#=E_~6?RCh7C9B07yYSs5u)@gWo#DCfM7XrVZl}Y@@Ui z%0HzdfjH8Vmi*zRUmpSs_?lw)E$SK=V2rF;XG6Ms*7U>$v1+Omc^>fk!n zpX@IiB@JmOXQ+4$K8Qt{3`=H7UM7ebVY~qK!&o7RPFo-a9fxV>OZU62Ch#(n>Bmc# z4=WBLGle+et!I9BPI<#+Bsw`Fm26{sT{vIbioxykuhHWIrn^d1Dztb!oC)AW-@Rho zU|!O6zY>QI!+*(({4(i$BNZkoM%CpJS&~fv6oHsoG%AU0YBJ)twdug~OJJ=odyiG_ zyBZ%8>!x6YyZoOuYg95u&IY41g~ z6kNQ-yb*~u1h6ZBCOM~J)flJD6fz>pflVH>w#vYmYU+7V#cwn(^l@Uua$|!ghYDOx z(Hq31KYzI;b__^}eztGDQOIEGMOp*TI-D+5mjMKga3hZ9FJrn135d|xoM+4YQU|L# zF7VQtkVtKPAh5LrNX!sG@q!-HoMtwr|hOC zP%ovu{0CjnU>DZ8G)n83fArWP#{~#JYV-iFVS-wOptLYNx}yh9_o&h?j$xx{>WKi* zet)*!8|G$@BrCm!67@gnXE+L@0AzRuJYL}TMo@v1^GNqlZ!)?{kUI7;X!_nLKB0DC zGb>!Wp#Wbn6s>fRrY~~biRkX?ruFMpGnLPl_>J__5`^KjUD>?Zj@iz zw(fcCY``-h9}}g`_q`ksam@F z=;!p|uUR1m=2Fliy;BYtqvjlogsyP1A~y2ab3ct$t zHop(OxcJ8jYdmDIJgC*Tzl%JRes;qfJ`0<+1J}+-ob)3i!1{AX$QLDF%yAvjVV}U@ z$ITPmz+9r1$p@CKz5yOgmB?`hRo)w}1=MmMKSU_vS9-K14)OMykSZI$aZ+$hBs5hy zN{zn3I7F~7#vZ<|vwg7@7y{KGw|}tR-KRAKAANi4kvToB+ok`N#A6C;n2+e>Tr-4+ zg3r;D*B0yG<*L%CI94G^2+(u3e~4|c5yzWlcx3c4vwAQSQ~^!z0`6D>JWP<7-uDq` zd?h;Q^{P7276@|H18$)y5OsJKH8uK!c$mr30V7=X&<-E$*dpx17?Qd&aeq8`tKJmh zB3TE1^)<5Cm{Z5_h{(;zUA33sI~Qbwh!~U1X4d zx(M+A>?NC|>@P_93ykqeXn*K#c8a82Puu#O-%B%+x4F6T`^18#Y(j}#ob>WYH-hJ9 z&e(DPlu4S2B-J3@VOAH|=~MKblc_c|NubG#FTv6Cj^H2Djig4HqLw62s9$LcEKm0> za_>dpgf|oiuqWdlF4$2zC#IK2h)hk%Pei};sP!lHvNxbUWDco>EPuOgwf#HbC6K5x zG9wBbYAK&I)En0*gg2fkp0~YMgcH_?a|Pj9?_gJb!0PaRhMpoX*1}=EUdP}?9WrE6b5)y8h5NNNi|ekq<}Q%mnT|O zWBDGCeJ2M}+%0A2e1FGHr2@AA@`Hnv83aHVWfa4Ua$dO*!xy;z=i`l4#aCt4>^Og8+f@W>6;A3Cg@ zKe9HXJpvfeimqB8!UF}elF!DT6bCbs)_e<{PkqehLsKaXGNH+CO}!~?b7`$@7xSsl!1E`cz`%L-FM{}k5F z$KxnbeX5>{{5@(34NHB7M%o~*BbWrtm2Qt~?0+d@)y4YiB1 zj2_7lWsxM{PD#Qa8~y_Shn)UqJZcTVA$Sm$smj2N5fnOfA?gM5Z0v99r|VYI{{yE| zQ6aZ@uL8Dy!YKBVHpyB!CFZN;uiHjX--1hI4u3W~fzKx6^|plqE&EoWChSgab-|%D zCxuSgR!7a$PV)#Fx{}*)yp~rQC@8^IgYMN8Nr2i&jDWFP7j&q`=5XP>hBq6p)YqyUMOE!F5O^`8RBHfhb7GA^I?6=N{L`1y%I7SJ&cYo`b z0!C}mB;&IYX*nzfB;ave9Qpha0R?ia$on4F?hZxy)T}=wLm93a@>Q=z7YYrr72nD> zJZLDNNLQTKl^)(WoU<)`;~2hDB20;);)- z^Xe3SP*Oc|@s}5WY3{ulSGNYKfcvl1leFpZ@D{70U?9lTCylOts_EW3yI{i>Q`xFL zbFobxj$3MINLCa92E?6O*~lLux{oIIEnlj%L>9G1IoVou015PNEZOOdZGYnr@^ibb z-)vC|r=$h(W#z%E`cf=xVdiZ5XQKV>{oCH0KAWa61@MLmpB|4bgBIB)t;GY|Z4<3r z_BmFxjAjR1CdaG5bz<8+4?{c$1}Mi|1nczobK11Qwk>e9>BYDy>=H3!e~oievEK%W zBz9SbD%~HSxOLXk3S*ffO8@a^mM#Z52uYV!z6anNBlBB

e9|4t@NjM2{$RvjbnGcMKbytD@v7N<*X0f zq0ZQm1*UqOTMjLJYl$L-y`@?A`j9U#F@q0(sQ0CKrHku<-#tCYWMua!^^)2Dd~33g z?@ltzYXjP$j*%^&L~BA+H~gvZP-(~?gy`7*=MfeIw(3F=iEYJsaM-D`gb}orMNs;S zE4d*8g52eJc_dZtTyPJ5@ED4fn|5frt&@kuNy?@iF^KpV$^ZZW04|Ay&;S9RIk<%i U0F5r+jXp39ivj=u00045T4?GZy#N3J diff --git a/data/qtlDatasetExample.rda b/data/qtlDatasetExample.rda index a284f4a4d67c81c184acbdc4b717680eb36aecd5..e8cd861a7138e051ea6a25fd3c8f8b139f77a7e7 100644 GIT binary patch delta 5697 zcmV-H7QX4kEr2bM83Yc{7DSO9U4Qw-&fXuUG}sAy!%Zx$*Q$*VW4@JzX`_qq{cKV~ zl-yi6u7alK%z|fxf9GnKTPqW;ojj|2+<5;tXv~U)P#E>DD3x+gAEKWx4`E@^e7Qbi zJbwJ=3zV4}>P`Ijc`z*^yEFS7cZ#P|jm7=h{s<;0o&cxj1V;YKYrSlZQGfe+H2O{$ zkuyl~dHIdJ1>~N0#4enZF~1euo4!L9@J$d7E!GZNfR`7$i>mOE>GK2zh^w^%`P~EK zf;q+oMgbN*X|gknv^VQkqp5+I9(!WcfHC(pPYI!pXrK{|rhJ`i9Zp9)$pKgq>C#wG zE?@iu!keD2@MiYJhCL5}s(;*;x#Gy>l|x$ymRIYN`0-V0LII$4%_c~oHXq0xvnZvu zLTY)*9cDL%qA;^IM4a}L>Ac1+pJoR(6L}a+)?1UbGKvuOP5I1AHsr5UI}j3^YDF-} zOtAG+KS23i=KgoVc{vi(F9)7nY+?G+v%r$w-c^sY4S$av0_z8@mH^d> za8)gh*1!Am+S6tX$-rsg~;AjPG zO8U(xD{_Wx{XMK0`XZ!cQxNJt`Bp->9oDC6c0*H!q}~Fv>rvaxae@u9tM4iI?+-3- z4S2-Z`c+;9mI`ZAhktx6T47*4+C(n0&G*7Bb)JHiC%2IBQ&%s&^NP3_7uz|B= zEE&r^8E-rA(SPd@O@3^EfsG~;>%zQi_IG2kC||=~sf=y^Y_fs6n}1+{J=xG`YNM>4 z>rXnM7pIZd{o<2vu_^k_V!LWPDTiWSa)|h0Ds!~&uJ~cMooit=iz2C&>&nGP9of&( zTo&wzo#i;H=oNQll`orDljf!)Z;5_|H0B8mvfik~sdys9jk>ocyCZG;VTsLjo zA)56n3+rTF=IMH^&vSbf0)(fmHS$^kf^9Ss6-tpz+wv-=1McvSBW)HY2h?8faqGSt z-ZVCEh?$pW0L0fzfy)wz!VSw}n1atK5`S{cEYnB=uGEGeB5KwwK?a4+|KN^2 zQbrPd?hP&{K3b1wjJIcMew}8q3gG4cce^#P^w}-{&|Xy!M_7frjkxp9g3;+&6hf|- zB&wblFvvQ-?q)STa!cGhAzX%f#R~qbZ@bY}KH828#y)wkLu4BCK%9J&GwmLTiI@4K zNq@62w=UxG^)YN^O<8JtF#OFdT$bKR(pgBFK&*;2h647BV<9yt#+OeSKxu}ppYPyS zPId1n3L2$%+z!Q`Dp22N?TUbfa=w9AF3%TcnsPKaKlJDRD+G~S@F(-6>u&&Cg(lTv z2sB0c97!FGSziwCia0JuYn1>v8EaPp~K z!Q97(wW@cV85C*iA!DXUtHw1XkBt9=g6Ur>@x;medSJ5MEGFV!RGw_$CIe6=z!ftg zUbS|RwVV9$<3y|0)`*69DzUv9vT@Knp8#MEC=&NW#f(5?{Ql?&`#tMKx=6_$4 zO|W0Mm;Jo{;xK@(Ynm~f{Qp1uJ7${cCG}|(=2jheDGwr|o zDQr2(a?v~AYvatTE8k*S(dY4ehfpoAG9-MaduDDDra zr(|TKIlcGaJ$jtsY|$=ghF5T|gnjA`L4>sr3i+}p^)giy^(tGno+RSWwDVaFQBC2Um*>RW=m`7J{#Zo_X z`1L4yRPT~d8FFa-7W$4(Sb-u`q-o+eAa=%r+vBkB-^KtD- z7{4WAJr{_kek!s>E9$Qax)nmhhq!j>1Tk$SUjm@`8972`EI{0^$$xll*UgJZF);90 zsgg+E>b7Z;a=SIJ>x+tn6097@ElFHWdtlQ}cAF`B-v8w5El^%Fr92Pw+zlrbs(|N+LO2k8z+($Uc*3x99 zumZF{%3KslbxUR(kbjvg#Pa%UKv3k}KS9a0#Yb@5RDKnGcC-fVl~j<|z+0lZD;3w1 zMTCPF;+))u6D(!xDj+t`I&WL-b!Ro9CE-f}d=;Pl7wv9|&Ka+W%YB&p3W-yF|37fw zSMOoo&{nhhQw+wFINC)~I^FBMz&r58t=%RMBb_*As>O#&)_5<=NjlKG78j9*Z!LvS?^6omeb4Fk%uYb0k1VI_;TpisTUQ{~XV$ zl%xNyC1%Gq>yVbLcnD>zoG7n&vg8=o%s`G4YZZ3tj?9i_X)j9Yo+V=_Sf(`@3pD+0mUj4w`w&~`vh0|^(u&c+gb z>RPDl&!NJzB3xIgBTuDW=sdzcmVJ!w@C2@reGHPn0Bs&Q`kE4-!$`@qy>ahBEP~ng zX*ZM6L1_mc$g|Zbrh$>O@Po0nd@v2Ox13?!pYA+)wtoae)n*W=r~SEk+VvC{%pgbH z-_{a1w?AkisZrO=Ti=5sJ7Ehk{a*2y^K10S+w1tiZNyZ-o9Ml(DA4#=G9Q&|DcBEZ z6y=`sfd3^09(}SV`|Cm1yj_V?_Id6{Xh-<@u>aGq%l!P31B99)8gHR!E5mHMxj+U{ znm68cX@4^yY;xoI%^}*T^RvyjtR#yV{IDt{>eX3YTmgm76i*v+j52Z3s76k7-M8m1{$?bvE^x8t!Z^8}^)hDq|3R z;JkaLsAHG`ZI`Kz|wPj7mMHS+|Hg;s|g3o+X+P*1Bw{ z-r3}~hIIa=zhf07W)y+b zXBjEz%^tZzJw8Dpeq#Gi2?vdK>4zZbK^W%aG3RC@jPDel+C*zCRM?e!&X!o8r+&sC z-koM;h}I+g$0J3*J)Zc(OP(H9yw9Yq-hZ1GT6Q(3P&@s)EfN7*|Lh>n4h!n3IKIks z>_)*sanGFCw#G{>RNc&x@vy^8hnxN&q>ZbyVMB3kaB32hON_a^+!i@L zie$W1R!l=AHZJ7;-#Oa=($O2^{8z(1EI@S8v)Mw zyTpLF9|l|9uo!Y-aC;zXfRBuVJ<}ePacx z&CeB*Q{xFU+S$L@BT@(?Xc`BhBN$s^&nb^nJlZVId3I~a3+B=R=l)tWqS&$-DULMz zSp1Dn5W5cwV<_mSZR~z)vK9U^dt@wBn{zW!?D|=?h*Pw;ej>{i%+J^!C*HWkfAZlv5EJx~!!ma_Vc3Qe)saBN5&Pr5<<*I+PQOdf z`;AH?>rE($u4&+3ntZZ1bAg$p^1AM_P|_FHUjKMq9i^}!f&{?=B&9~h&Wy9Uw`f^D zAjxBnSQV@bf6*+tqJMyN_(k@EnF?C5Sl=v7^Fc%~)`?3&^cRRE*)2gTJ_{nVlJP(6 z@dk{J$(y9Z+RjlT^b#qJh7fi$*Pbb7D`Z0UY>!z^g0rw1O6Ge+g2}fDWtiK7bz&B3 zIHjJT%{Ey>2g%$Emodk8ZDhK(c3dKsCImDoVy1wKjN>)XVQ&IhBFlJQ+IRFruZegIV3O3uB{%|E|#8^5a0av)YI6>nqrB)6JL$@iWZ&zF z)t+eR#T&#O(=OQH`v>6)NKa{~sjJyQa11xq+FU}S9w2ld1rJqcn>9lV+}j#(0^Tl^ zSN9q28PIWYEp37QUAPWW%F0y~|A;H?WR-YZ_)epp!GBEwQEM#~FtOVW@42TXt z((`zU$%EK$XlEi*--4w&P2VD5vJIx%EFd0|E0Ni6yjKw;fL1%kJp89DJzJzr10wC+ z``7OQ0Dqb@J=LV!p5iCsJkz<~qj&}!ksC%VOnN*`YE>kHXK|z`+nvELK=kLkPagBu z11bK=X&qmDbs&0jSgMB32kkoAT!LXUFYS>(&+CRrjSB?8NuYCB&qusw;M=F=npa;^ zh2^BJw)kfbY93F`o*{-YeJze&93j=AO<}#cLVxMJgLc;8cMC$A;PO@Vqd_m@v2s8E zdDMzX552r`iQe_raG}k7T_Rt-fl>qaG7`qW0HqXW$%2IUtAPNITd`dQHZ6X0!*C39 z2Xbe%5Q9c};z8$4<9$|WDcHM}(EMJp^K0xwx)Y)hyiSDdLnc>6V1`Py7lCDc6sdd5 zU4N6>VCA~hFC<;rVaI%E4@HH9MRhnm)U_m1K!C$CO~&*ZzK^}lQDh~bQvETY@7Q9* ziRE5627|CuPFqlKvz2S3_|D&jP>2xFfIb$Wzg4vXS4g+<4iD=*EX{A#8RJqU?GemkSPUC-jS+K+ z1gnP}Pcf?5aV$`Vb)Vto0QQvJk;RDS)!(X2Nr$$UCOZN&sBepYxvi5xi_n%*+JBp< zuZ;de+~%}`$yXfm(3f4|N6F8eKBeAB@j#?xl%vNQIf)yeS>ClRvT&K+4jlk~;Cet^ z*;Mb5ld#}z5_T`l&Vrg<(O1Usla8v$3HSL1{~(MDydRzJ8M?9qAu1&2-O%NH<4*YS zu>9bHcZZlRAt{ENX2hr8=NFXkwtr2**w$7sKZURlbl&}b2G=<_6RoRp&#w-m;I{~a zxN_N)DR~!{-2y;gkUyEV^YIwo;4yG-!B0cyuB8Qw9DjXR-upa{Lj_hhhmo4tT0!sw zdfQZmPf|Nf)8X-t!K6y9qX}Q_fx4(go_Es53NBQ3 z+dI2`eKReBElU^y{##lqPk)ei42*!0$+j|t+M-vv+G~MC%LW|gBoOJ56*xOpPVRgcIJ6?~2{zFhx`RgoGBp&C zOoo2U0)g#Zh!<2r?Rs>*ktGXyzIXrgro?1an-m?g9PSIKTh0ntA){$@{hTME1krx2 zK2v&yVjblX|KVP~Cx0@!4*)*%6L&@GA2j0!^x#0fDpd)rB2J^?5>hpk?PZaC_wcGZ zgFU=Wgy-JI*3+FNwYm`uzCp5JtX!advFlI5i0ER4(28)fnXtO&FgjD}0S0>}XN8(B z!~ge!k*9LCl6#?|29J>g<-n5mdh6CmUrF~;^s7N%%x=71u`;uR7WhO1gEV;HPX9Kn nv<}7M-yF&Sh)U3Y00G=A(VYYU*ZSA3J}?c70ssI200CKAWPB$w delta 5765 zcmV;07JBJ`EyOL583af87Ko7@U4Qy+3XmI0_gW+zzB*^}SwkLPQLAN+!7% zbIxi7U3sYP;+rQgGjmB)kJDqFQp{lP^b|rOSrKfP?vW&&`%JI5y&gUc@PCXjygchD z#+xw_RH&*^0~Xpl)W4Kjx2z$mr77yNd$`J1coWEque))_IjwelE{HqG71>F^fg6+R z1OSegw=O*aO;S5zDZ7_3sQV;U!A-qGqqa)?2&)q@%$Q-E=?i+?Zs;DaSHzDhO9TNSDfCZ3SdEW0P*i!78C#QJUTMdtzI zq)-Xxe=f@ff3{;m$9HMjl!ZGE!JV&o6qeUd^L)WBljfx(ggycOwP!z>Qr>5+I-p!? z5-E@-2GWkoF_wsY5F#(iDhRnnCUguhwUI&J=7j&}{~-_4AS>NsrGFwtu4YMMQ2>zs zpnKor7ufaHMG({hPlI4BeBbtg_GY%5rddho4~6%{aSq0v+Px5~$q>LfM*h-e!~U~K znIfr!3-A>h5$p5PKEcnt<^QNEu zBkM;lSjZ0SfSVXo_=og@_f@Q(H81cRuE0ORgbVK}v6P22A7*hO>diZwtxFK9SyP{% zT6ds>rkQj<{UWQ4S=5gY(Q%`v#O4~Z;i%F_iJi16ANegDEq`%iv_R1K2SE}`uXW?`;j8R`|8%?SB;FPz-27i*TU+SKtugie8(M zqg|OV%3C?s{}R$HK9IzNP62% zI8sP-xRwYiU*jZn5VddJG(8Kv3oD!SmPh=^S{M?Mt2^R+ga7iJluoUV69hQzbG z!4|~-vP3kQ0-a zh=oU3e5KKFUc-%;Pt!gT`nx1=vf|ofM_+bwuSkc8)-r!akM;QX zvw6eChG3rVNPm)2;Gt+{F{&NTq4H$^P)BE}ShW|v!%qon29G(a|HwI zb%%0GlPdKHCG%sAP3l)Xk4u$#7sGiXn$cjflcJll!8I4TQjEH+*Cbh%W9T@{gy0~ zG>Cqxke;Oe;MOY!k{f96R6zI#E+oY?1#U(J`Kt;rEHt86kD9*9!uw3h zViv-dIO~)v(_asl>1Hvq*Lsni9R3)0lX!Sj-2z|`+0&SaRLK%HSkM8QN4+~O4mWJ`6wCNsls>5=Q3B&th*HDe< zX1`?S<9Yh>ejI-AHS~rhI8MSdWPd`mrJvA9FP&Xi|6lp=j_Niu?ZOk-1zX7Yx`XsD zOO-D|QBp7bfY8voUq^qQjZH1~`!6RPtMYOg2MTb)&kVNjB({R8AV-zt^Oajep1|{1 zmQ`fk$4q(U3CL8d|3CNcYUf`fgUfSN^~tSG``i6PSYQD~KtY-vVH4w$OjGKjzER7=9ZL;GOSptcd~nX&pFD#*m=cjQU!#fAeX{b65h9Bge@;9~OY+8y7|JAb+gTz{>TBOO0z z8Lka!wZ<-JZ%a&9e1^#M1)9OUZ!!2k-!@BNNIX-Oc?QW=dC}i@Qq`D3m;H&Gyt_`v z3u;}oixThKCO#WlPf9QJLA(_`jJC?N1RCORT%Bm48BbKsEPi(#l#!l3&LB-1s}$>> zQxDOUfUNWU;0@lILx1$%t<8Kcd8&T=A%l>DzrjeXRs(|>Mo~9lJGZm7^HqrKh7udn zH9BMlK7!;X3n^!?J9&RLy-EyJ{WC1pF(sM{2+<4cXXFjmIJ;6xPl~>hF#iTPV&-z% zk34=OMOPj8$U3cU%2pfq{RTM|XOaU*#DDb~d@ zUz?mQWUI||oGltquCcpD!C=g6xi-Tl^;|*XXH8(4hc`g-OCMoC__N@f!@JIje;6Ud z|9;Q)N&46$pUW}#i4R@ME09h}K-EAxpT+|$PG~WOk@R%LwEK&B_g`b~%-v^ZO98zm z;UUgYe5j`Z8h^>QruFgMS^hN%i|pVn)468UfEV3cP394Shr|>tV><-qB37bNOBKp6 z#rVc98>azEv73YQ&!R2tD9sbN713wBar+32P_^*vx!d`crZ}w^A?X91SW;*S)FB|y zn*DnmrmF`B>(~iaGjtFnIj-(f!5@7mvLHM?&KVcc!Otbylt!JrTeybMd^jO_xMMi^Z%jEkHmX(h z>wmC#4t}TROcFCX6;ZpSglaBT#D)Mk>$vlRj6A4Wb`Qyb)I%#?Ty6ZEZ{Z&|aIY7! z_55;(DZXh>NiR_U@JGWiREX4$cGtbvjsm%v_La8p4PG=@yZN*ksrgn_ka!(7#{SmM z^ojlFEK-}=Wq(Jq(Zql2C6uz;f>iFcateL;;axpait;~iMBQUXh zR8!kZUQs477vE0_U(X~30EPafkd+HOqu7zHV*gq(k@HHe1B)6FLq~PQMSg3)+iwXb@YKa2AyyKp7j7f> zVo~h5HiY*c^;{|EOyp(>OEQ_k4lB6qR<>{p7!(-VoXeE{TjH;1_|4{5JFrN3Q2TNu zbEcz#T8l>7i0$3LvA4Pozfhkf^?w)Dq}I}|bxvz-mfS1$+%Wm5N`EMO>}NYQHr00y z1z0bKM>1R!NCPUSdiKOM{D8Bo;(v;Nz%g?6B@{;7wG)00xv5AAjXm^AH-1Kq3EfEb zpHbcq`8RyYk23WKFan}s#tx4SCy!_4%)~|kGW1^kvwNi+dW%r{_n8a35`T<|79%o? z%Iy?m5f*!iCBc-PT9P)Nk3dbN@Iz`Y9H_a|5GaL(edWS~G=IS?U;yZiu><-wgc4+q zb*xqUScKJQs?azPvMt^@|ns>oxc8r?*Ypn$Hgl3nJfQDzmI@bOWgG`i=#?SXd(sJF3d^T}bP6;7fpF6IEKW z$j{0V=OJMXiFFN+LVqSyN%w~^LaiYO&iG_bN_$uIn9j-f+sGnzeWM7Wr+*;?*#7&) z0q7OfDPL&1AoLf=SQXWR$ma5l`JI}Y=6B?1e)sx#1Px!#2mK+ zB+>sVD#)ARdk1>P1wZkO^ZB3AA7J~M8SFPQ7|PS_CmcQU>upOz)9P?VT-rEMSHSNgtQuRL$m ztC#icBKJs1$baW;hcsIyDB0q?B#dizHI7z4jcm(7b#Y7WNiCQI6Sc~~Emp)#iUT;C z_^am@RYtW!Iqx0VGf7#F#x1hF8bb*$TpxRs(!z$A+RDT)jJb)=d({!juvbZZUaicc z+puc_KM-f?i&OFC@^A+d(`*Q3du5pKY_0OYcXC-G)qkDx_d5r;`4#6S&Ff*5&`Uk#{FT*Ku zRq_b!U8V+;0FE+GoW8wWOENMKe2S!Ig-i+1TMbwUfh~lz4a}IjJOX8ntR-_SP)D`@ zL7S0?Tz~9ZkRA+=nj?m&JO&-r!y2K3N^io0Uqns|m$;Zw*T)tG9q0=hMzAcQ2!!Un zgPc6zn)(b_19g*R@Sjopb@cIfJy&~<+&UlkE`bL8%f8JdARGsVYEIwFpn~X?buM~b zzDg%R>;xq563ia001^^FS4Tgdi-e39o1hP-iGS<7ZP^`?Vx@==!vX0}^g7PCouN&p zn-}TA5Jr=78Mqv9ZZHGfEQD-9cle~uFg*glBW2e9(ANt%pW|fbhxf1YDkT`|pjb&Z zy;+1T*N=XTI0>(W!S0~5KrfRQVIC(UdIAx5WCca0KUoFj{x>Q0i+M~Ogn`yV_P#*V z6@S}_DYv(CRKEs;a8cfT%OWRqIbdK7H(T@_pK*(pq4!buGew7yQEcmh25(yE)a2dy zL%w~rhbf)&KOB!489Lrq*X1livPoc&1y|ecl|{827gVz8h?dYw$E9Z`A2NJ-ggo*niXPs=Ft-2 zNVjcwl%dqdJ4!opNmp}B(J+UrrIY>Pd3kuPfnNi#~e6}0F z0{Ejt~-YW^%9Ht*0>6%F?LZ<~2;gvtRc?Y9udC`%ZL2Nelg z90tb}kobIfF@(F@aPI(+K61x5oo9EJo7XIeuUsQkmiz0Ew`6fHy1Nq??jL=)$K|Q{ zM(BM8S(68ss#^ZRG+8$dQQ3Q^;D6p$cXrn)Z{c6&8Yw`MxMi)<7>W5?ACBDmm+V&7 zfFy||{?z{`J)2G?x4$Tc*=0{@Ch;&0bC)W+*TxfCPi{UC4cf}WuhZcaOUZDuzWkK| zTai&YU&_N3VNA6_O4xM?+R1kIrMo%t5&Vf>`;-5@6Rlomm<$M}tZEqfoqwW>&^7Ym zY4kbHBM%gwK}O(%#d(RF@F8iZ@3=BO8=q$*V<1Epz5!w&%~T zPioDY!-YgB6!gGUV&Aq#V5U#fHiqsvFgzWnTO1S9^e3IBc)|lXL1aIsEnavA9bp&4 zCPhlIBW5^uhYT9c5286*NPl)PVd3>BE@+$a7BXLlTY?l~BdGsUWW#jp2r<@?Hb{Ds z(YW0f_q_f2(#Y{_^TUA|z#@6dYRpn;5!849ma48sskjzchs|l_16Bi&7+VhiCr^^C z0ULC@i#TILQ+=eO`DSD{Ljs4OO%^;hTqE8n=X#5F8L({sUvpdbrm-esEXfvUN6zM zV5K?118NxY0|bs$f`9f#ZW`|%M390LmO(i0?Z{NkYN07znD=xh%RI7s8 zht53~7a#e(ScBq)PU|1|y9wdy4x(w7bpe0?MvCeCG;-eM!@}@_%SLf4s8LaO_%EYh ztp%WQr=V!X=3@+Ks3tY&!4#&o`J-}y--uDgA}M1WE9p@119odv?Tx`X(38v7rF^Bs z3G)n{-j3ibHx1*h=>!DocX_ulW;=n1`>EuH-pblP9=<0r6`L_yN;}5FO0dp{(DHL3t7pR`HpPb$$c6|NtpO(( z(P%Luc*wL&uXrX#`OF)kW+ho089Nqak!X=E_P5iv2RJt66`Cv`pe<^INlbRQEIR(> zg7n6Kr|TSET0KQEf9}Fr$(9JcsdPdeb+-Wkad8-o)O(0f+-xz?wd_TI<1od8D5-Rf zsUmPi_FtIpl8e;ys2w)Vo4}+9LftWxsT;QasIkiop6#!d-_4O;PqzAz`&@3ER$#i$ zM0{0ta`~$VSuV!GGo~6uY7DLtodY%a>8=W_(c~t>fPO-n<;KgGYV(_i@YAcx|1N(4 zjrRoKN?pW2gcBW8&IRuv=&;j?PsJ@)A7pqFg7C{eAfj>$gJ-r}s(0U)0hPH5b z>UCi)WU@jvO{J$+?^#?y#MFrO+`2!Ew+-=7)2n>`y;~oDM{)S?b6^3|pe}~p_rr%! zyhg4y08pn!ODL|w8c!Va<`LO~N_>7X@c|6y(g3IluA;B<#?a4yjo2^kBubpbVp&;q zbf`XdLNjdqSJetwm34G^=7snZ^;tNz;ErAJ>|U`s9`y=4@)ZA!Be1nXQLIH)U@`2k zfGYHwOuybs!Do&-P>Rd3brQ|HJJ3UajFqzs#Gcl^2`mBeb{#vfh@gGId&LdkwoKG9g{xG&wyMqa}j0Z`jBWI?N%C%TOwOniYXD=W9eti95A_lVr$NJs5|D@IQ*$+`?hm zput`Oi^R?DIh=h@rhhYR8-C5s(5ZxH!cWqM%-#CU+X6okw)QOtuDyUkp`FHuE;&`J zi~FFCZ&laIb^zX!9G4?7Va8(zj;$)x9@t%VQuH*7{RNnE<3kk61Ct$3_AK;MbYry> z&(I(GU86yNbxmb9)C=78PUgLcfgZUpev1t@+IZ>XNmVc>{y=FbSz}CqRISL8zyRA(|{lL5{a|2=|3@XKi=*E3%iVa z(0Mp=mvK31z8<8XoJ|{u5ut~a*UD(1z1R5X^~UFak7{1FUsg9Z6SZo$)|T5m#hLhn zH*6uZ9MmoP?-2Of8-fuIQ$;aL>=lY53H;;?4)`?$X@8BD`7`@-p`7SXgeGW*cddD~ zbv)Wk)Gd7@$8r|RMyk3#Hz9^DR^BAUqz(^_xdGo=J2)a!VGklpJ-jLL>4QReXkVTO zH_rTjC<4Rg&Zvg>2dEKUn^~bwV3w^>*i7tlthpQS^uXR?2-lx>imysV-Sq1J;o$v) zX{`(-pN;>s+y7ArOnyLYmw=FKbcQZYFICJHi9tZbWgzMvSRCC}|7Dxw-Ip9}Yilx=G)q*)6{*a|KDG@Skz%Td zsS%b{sVJ0I@~BKoeSHw5C!5Q5;dpMdSVI7^edD6hrX4u#h9;8I!nIW0bB0J~O?VxD z!hA%fJJ|*$ru9@tmTa=6441^bK9ghJkB;V@q4-KcF~KjxNN$Fz9utvsDhUB2lYfJ@ z;Q_2NR%eXU^IY()SWQd6|0stkZ4WVaSu{>|)<^gL?vtX;XTC$OTz3(*w8-|BwMgRv zB35!n4wv+HRf@wJ~3HMChSKuR#A_T4i23S>UFGej& zF|SZZRb;sAk&e)AZy3={L!WLFKcD$@>bS8re%~8ngY6$j#*hcQn=s+yPuOWYnA|LH z=^D)cbXve?hjomEnq(=rhsF`mO|Y0=r+%Ez*oMrUt?#O<^+`K+(e}K5M~5|9>L@2F zZT70VhovMxELAPPN;O-8W)@7GnclXzMbzpduVS){N~)P*KUz#>MB=P*AZPogP8=AD zFx;)M0+BZ^OmCUTaA{;SxG#$trx#tkZ+K^x#IH&@Vrkw)WN~N+ct&F=HU?ovmFQTX zmX`Bm)CDkKwN{Q;OV4$GRNh0&BJ%&ZF7nxb(@z~uciPpwqohG?*+J{O@ z7dubf$2-sP_j`aKX<&`AM!GKI-P{TUCrXT9N~$kt-Ae#Fyp6D2Au%Ysl#=wnVXkf1 zOa}7uh4FV(;x&&TMMXNx&*n_5RsNlF^TF~Yd{hu?Ss95ga_Ht4E622t%^)Zc%%1I3+g z9qdj)imkayvtY~%e=Ok|;FWs%u4p_;L7pB=r>({WJT~kjTC1D%J=45;a&;_o;4l8tZ88mqK2gdjKTMB9go6B zo^L;5Xy5{~%Wg_fVf)|Cma_b%93%$TQyikd|MAd&?fyhy+n$aEydsQ3``f1+FhbQ; zu?kdhsg``dQ$)k5>O=1l#Ki+E?!rzVTRxTB@-5pQ=l^zal8CG+w0sy+ChFy(hRFD{ zt-aC)t8Azg8!70L8C*+#6E3ojgA&K6p!51Sws=eiE{ugkdW3Kg#bTK-M zaJw;ou;E_bv+bl|P$PfImM2vgq!$ltV$f3ch2P@{To^i4-WjsGj&n7;ytz_P+H?Fj zLpjF_5YF9SEM69^T`_|aoyq0(nh(b7ETHa8QY(o) zGwf$zV(|V+7XN9E*%o*=VZm*zyGT9Kz*eRS9ffrMRT~~}#VOIJH3HG~wt^_mL+ojP zsO!}h%Rd$X0Y3M9NmNq;q$g3HioOu1!Zz-D{KW=O^5tx8J1@7+_KQENec^v(uL7^o z?E?q2oY3q}KdS0)3(6%FLjn@9Ga$SRLbec>tnJoqnH~i*x+s2F<(ozQnp!t&JDiij zIfgKi9)vo%T%DO`oH~9ro~S!3U^%jXLbW_^@IW0GLM#FIz&rCGl8s~v2H{fysx!y& zBZa!MQ;JvjQz(SM8MrE;fNRx3*wLgs>TJqeHIIW(Tx&`;f!uPVjgu(NQf9{zO$2fb zg!#DRC?sS(>W|HC>HWgf7^yKr-@3c%W$w^DdaC+%v4;JYhF(`RCpX@={F^6#vgqGf zQm}UooIIyHlKQ>n2%X%BI8SZ{aL&bGS!%nNK7dN*8YMrOD-;m09u(bhX3#jk+YYQ( zw~z3}u0y8HgfX#8xB5y&<@&r1-=oX7`OgWkTmC*jI4G!ed7c?@S`S*S+0}mQ-LL0` zg>U%+BKN=Ztv`tIl|<3Ux)8B{vCD`uXdAAciR#&dxK=?aPY-{1PlrKWL~>CsL~kW* zE(<}mx!U6|wU7jF01o)jTzywS_feh&2dYudtHzG5A9Q&44x#eEsPxzu%`*ILe_lFW z8#i1XB1tUVy7mgEIFUys783FmELUVS9&Tj>wve9i2Sy-3(y1FO-Y0W^Cp;T_xud-b zs!)O|(4JsRhXd_feVx4k*x>n%B;D47`BC!kWH`YdkTrFt%;dDt;lfte)e*+6jO61; z!OcgQ(AvyQ?>a1OUp!9>IWwO>?5V#pmyKXi?m0Rj(fr;`=|0-YHgV6ZfxPwmpj1=Z zKC1s*kyL1DBR(?E9>qw1TL*Yq6x2v&3U}Vr6?;?1+O7Icip`#hpctV&QJYJ$hB96F zY7r#~WyCvL3iTiiL7q9(pX2Ia6nTgUyho^$ghVokSp>+%~12( zyqu)pana#ce_lX_z=wOB9e(BW;+m0A(y!dPOJ`CMpH{7exq5T^4wJnbO) z3;$O-*$`srm?7$AAax77FXVaBTdD22C(z3G!M`z}4)y9GYw_j^%ug{>Q*HnufFMCI zn1QU_S9|NL%mSx>K1$(zcztQX0ciE1Vpht%jmd;i8)X-bZ}h`g)r-WO6iIxGgV`zW zwYu(&vJ&;(?$!7`dy!o}rb-V31(F3TDJ z(D3jarW(Q9)ioB}vkCBjA&r@-^0DyW#7^;0JNAK-c09Fz!_D^zISY0gTWY@{1b3HVxTCrdkJLAiIHO- zr>61*(MuzLki}Z5U2qMnZs&U6-&=e5AQL6_5~YUv1UC4F|97^cp*NG9Xs3&HsCL-Y z0@!vpuB0ZdEV7O79ES(=vKvU}P#@ML__VpCQ+uU%VINv9*~k~RYFS^@2+tf9Mc5`} z+Fp(Q+Sz6pgY1^3NO&%VoU#hOs_XuSwwic<&S4;MR#*;E}Sg$t3@9SQUW_Y#- zWi;(R*H67pm0**dFf^Q0x=AZtQYwCR=VFVOcp=G-`>-diTFs++`^N-xTDxt{GIspm ztHRiS{j!Gb??8ZBP}NR#t}+~wu)N91Zo#F4-_@4=dRz*jXpiDkCU{8CzRa`Hnxb4$ zIBBzluRk`UQ{`N6ey$AgJSlR}zB$v`7t+xP?D0)yJn(u}cD?t;c3b2t?rWRF(VXg| z`bRNQ7qHUuigHlmf2UcqOUd~eOp(1AY*>ZFrJfP&#E^Sm;? zeizHq>NE=&{5SghyY$Nl9lq|j@Eaa-SiXRJhljZ~v7qH6rMBt^;*JdnP?rw7jD4P) zR53<2zU}iq;!T`en?(;aMnk-NTwr{qg!*~q7{k5Fo?6+A?Wq2R&VOenE#%<1No?+a zy;@TI@~lfXS8aQ&1KC@t$VWfL@7G_HZ>5>%+U>I4IU0qlNJAChLX+rro*Y_2?yLNrk{kduL zSis-Ymp>Knhx9m_Yeb5=gW;Z-@c=3j2s^Dy28yTQ$3ooSTN;U5Ff;{5UaxI59fl zYQI|YWKPXtLsD;Y=qVt9U9e_|T>b{d>AODiz@xKIA4HF4~`AA5k23$drGXvQR} zj_l%zxMqeIx*Dd&s)LBWg7EB&Ok>T8akrtU4-1QN{?&HgPIOBuwfv=z4W-hT6keN) zH2KY%(OhF|;=2f!-2bl7TA2fwmbC@NFZ;iVRv7}-`Yn;VYYPTo*!EF>+vJ+9wOUYM zMWeZ6gLEnu(c{iFLats{e|~Ctb&r{KFfQh5+uV7_LXN^^@a7c!Mu48S*9pR>-GsIOa-&>}hpi7e*BdSGr$W#y* z@V6e;Vb|gnCasoQvd(}07xUznE(N< YL5h_G0Qx+Dm_9HKivj=u00045TCD4nbpQYW delta 5422 zcmV+}718R{LDWHz8UdlP8^Q~JcL3*@%y8Vx*8WqpX|CE;sRfE4QMLvl5H||NGb0(e za8%;KsrA%u@>XpOgTd+7oN0X&6N_=p9Xp#KDswTPyY;&|Dur7r2Uf|aKlfG$wCBSy zegb@U36di#{%`SlwbE|-XQ_s>wp?Q+!_>Ds-ZhnYEwuI|%PQs;@{4GHNaEiZQf$2P z<k82%Pmx1!Dp9VGjwsx}d>XBV-vJ*_KNFy|7f#c9#cP!u~to#!E7*0_#hLc1b zz+^27AU=K(7d*Y3X9T>CSjVj_kd4NBePRS`j5lSnJ;(j;=Q85s?q>Gh{384cMu-Qa za((RnA9_PAxdzpEbE=zvx#{8w6fMZ=I5o>bH&vSi>2~K5#RVI>-VU5e4PVrNtZn)F zk9o|f6|Q7|j@oygW`B~ik;%Wt6_yAy4Fs=6>v-FbGcmMrrk`hOQylY8qZx$PoO<`pNvobgaTYCqd=lQpI}$UFuMvf1 z2KD$ZkR#g+;rvm!p3>?)INO@PY4xL?6&_x3 zxy3~gM=upq3_@-8vTX8%nD5zZVQ6|3`;ZaYRvL*@cnO^Zv_6mW?=Uy8byCK43JhgZ zC0kJYZ~B0Q*L)0roV%20=I!|+E=Q>eHd)=i6wdqUfYw{pqED!SJnvZN4|$prrX=*- zf9qt7*`VU9wd{MQ{kB8LHBTuBel&KlG`m`(kp0);%f58~t2pCUqjUkZV`0 zZ9LBIGCH!g#M`zvEg5X7+i?J#Q=gs)4yjG& zTo$TE)^bH10@-b_kPW&tUsF}1l#!PZ`euRhwv$d+q{K3*6(^57y2zu}NUdFlLWeU) z)D1}6B2u4J?blH)YvA#Sdr|W7k`t4#Q#S}*u?mU=DgqXZOP`8tpvjX0Wbl8I;$8R=(c730r$a9aRC{-CBG@CqS-!7==Q%LD){Qql3sz zH7C`7TybA$FGKoyA<9UWq(}+1b69D-u@OZ`qPZmvnk_mjCse;~>5lqXkDi1@19I-; zK9T?#*Ep@Uf4SRr{VJhDZ2WRCV$qayQjE{nLB52^u1FSWA=Iq1v;JPT1}<_7{u#9-`0U)@r?0s^xV^-2eMs*D%wh;#hRz=(C_we5L#Wd4DQww zY$t>%LfG^I(dIr!vmnzAA5=C&BNe6=>o|2<%DtDJp2@!_FF#vCF9OY~ELM;cvvB#k zBoT#u1`&68B7%6T_bRf*xDg*~acrI7D^25|;l%VH75VfNBaHLg(?EEUM!*k$%E%%a z@+>5DZzLJA1{jJaxJTR3KpQqzq-^)oG;5M%QCc8)Zg3$`mNTNa#F(C|92+lk8IiOj z!IgHl-iEJ(q5=7wPAe)qpwMI>6BR7mvr}7J50kH98z)6IHU(1I5pzgTR0EDFUHId86QHba?MBXiM^V2^-6 ze|KY@3ajjx^f2Nv^oc!Z2Z6}-*ibBtWW)1L47<}$+K*b7IKz5!Z#m&A>ioI2<$Zt* z^*J{JbN=&eHtS1maZq_<9?OiH9BaM+)W5r^9{!~2wB-jq zi9)@=nC#X{yM9`OD~TAP^>bCIu;7_e9l=FOYXcktZmnGYbleu%MP7TLwCJhy@Bg3| zg83;kTFTJKMC?^WA@0jr0x6a04Oe_n@tCk6=9PB@{a4P4n?)LesEYB0>*|<2ek_FZ zT++fe5rxplbIMgAn_Yf?Uj%Wesw_!@Ug-!aG)@IDvgED-GJ{Xx`Ot1EKMDpEnQdvW zIqaMR7`IrNbV@#FqGI#EIjwk+dQ& zSt8Ds?S!aJ6-6btUx$lRRU~%5L}fVUvs(MskY3a1lQoA~!(qyQ_xc_a_<_iBtttdi zo~gV4gV(fuQhH%E*w4M{b|jnz8lCy_gcq(Zvm$=b7x5$g-o?R5-s(tBf-(cNQx zx*j)Wu>RNuxLY27HEk#*VjShaF!BO(!y-4YboDdGcu8|`?7WWn3D*L>UE`@99H&?V ztwV02Z2Q$BT4!1`Mf#1gn)!q|UN12+%kU~nu&{!C2$>dvt!AWI(MbB&GEq`L__?qu z6cbF@-O)B3#*9oncZ8z)q3QDp@kUVgg$>wxuhr>(OHsyuisf_*9=PV!{JZG&+e}ps zF26LRjq&+3Kh2zQ7!1mP9i#SE6)pxP<$ds5J`lZ9n&3&M0BS4~IvZ}|F`4)5THSc+ z3Mj(Sy7hY9kw=B-i399`PZ62Jw7+c)$AjI)k|ZuO`>jr7(}$l5<3Sr7E)uRdiYZ@j z>$&A|07Ptm?sL04IV-%#DDQNO-7UVF$Rp|Ny`r*G8KO{o(<8BdIXD-Yi#B@Q^z=?^ zOB-rnXMH!}*M&ilmiM)!X!A}t3QMA6O||v^@_5apTb2~b8RFU?6}(*Ys>~f<Uw<jjF1Tb{s^9sur+(z>h$ZIG+Rg#d){379 zaEBeW0!_M2a8h=&TL_QEfT7@-g|wgYC*g?(Jo&Lpnf2Mx?9$^%Wc~yUIcR#DX!PjG zxrxSq64!h^AO}fo^C|Fo9;#7!ecdfGg!`f3hKe#@TKKv=f%}0N8LRD6Vi(A$IVb$k zf>0m7!I-E`qqY!Yt~3U?-8-0aVE}}}8WS7PYEv3gO8;Z6Q1?my@DRJ8gH9J>TkmCf zD^6gyalv4*K{j9l-=KS+q1f_Y2E{rK#JSji)W-dcdqo&Z6=@y6ub95#?K)V@ftDnj z?{+G{@_me05H#ew8llVQ=owsctT0Z~%~mXH8FCxZmG^E1u8jMg)#+phH~cB+f8T$9 zHsz$Y1iu)uKrA7Dh6gW4^jv0HBEp8cN<%{OqwEjr9UqTof7xzjR=ObEY;lPr(?NKD z;TWj5)f+v7=Rg{Q{dq|cH`%A|#1pF2xqW-ThOIj6lgmqs2Qf)DnhOf`_ifJ`EueLA zvb%7%$I>@E=2$s2%A9>+kiF8t+Gg_dR@s$W+py@1Qm~VQ^&P3Ipg3-$J#8+#7%dnzo=9KXWE<(r<_oi@?0yS)BH<` zC24W*Be*_8N;oF(ygF+);iMvOjJ{NUfY-RIK}qXE)_?EWPZ{YL*ym`iq)H}#q`nZ9 z^bq(fV;R6UyS${_sSR}+&^)h1pHn76C^g1g_b}uZy|2-zx z1UUx+bse-BTSZoRFv^og)P@XyQA%c)M$NKv1bY;{5C=n=LyzOxE6oCv_rkIM+SqAm z6)2DZ{lEbGD;Ci;prBH?$WvG8gZ`4_r%AU_H6Z<@F#ELSR1$<-Vid#M4bhv-BTngu=0ZUqsCmQBtK( zuiMdH?kNrJ`SYfRDfF@2pbmfx1OH^Ci`oIQq4~^gz86wOEf;)D{w`&)gdAzNxa*11 zc%d||?Z`!~dbMHlpytPdjz$$?e>bj|!LZBr?P^tIv-N#@vU`=^T^PXnH>}EL*6;dx zn6l^EdWBwrHV20EsTb;hdSe_;^su5mL@5{VL%3U@*}Z|`L=GnZQ_TZ`Su;!#K`zU1 zD%FrOH{A~l^A1b!VFYFLNiTS2V*tM3NOc9KzR#XJugT$VinhVR4~T?j@6m4j*V4-# zD=?Y+e2;Ap+?8L*-SCMFrk@-F$y25ZdJUW9yi*5mZm8jJ);ew^r%TgdfZW zO?h!v$deo7{nrb5MQhZ*ZlAeimX=dB$Ddqnd)1OlTpUN1>s(E6$QBt%199>_WrrH~ z&+M9x&@Lz*P3b|VPz@JOnB$qkQFIz71E&IK=O9Be>6A$*pVVjPPmpB8fot>*L^`K( zPbD&(L^NWEYsff%RWdH8vcqdyG8{#SG<9tM<=e<5EtAOZ6Qknb>yYAsex5w4l?L*q z5$R_ez|RXo1d%NuvjJ>FM=*z;*-*VC@l)CA!~oBK*RlSkarzdyeDAJCz)YU5TL+Ye znxkK_OgJzb22QT_W{wk!g7-MMVN=ff!yX6|n1*l)aVQXf0+aq6|H*cCnbT?r6^;^F z?C5o!`17p=ndp<(iL((V9=BQ5ZUW_*@MRJ>D0r@iG$cYdcLXoDL)1Xd1Q)NSz@nNu z{3d=dxhb8yMTub^f)NOyPnj7cV5~l0rZ4e!!(4WQK&Ue^Y5?1pa-5tYQz#P*>!||*?Y4GV<408bSslyPY~u-6%S}-f%8H1R#I%feB{$X(VTa5C$p-S zsV(@22N}Du7%IgM8d9b%#&~NTMn^YhNxU!lA`o?dj8ydgZMrd#sJ7dMj%yG@T7WpR zeoz^!*_&Q4ma<(Y`2l1GFYn3EWPULu8+YvEx0kWG`OGI`2##G!IO;+=*kSe-b@^vu zY+l2bnFm5R-pn$*zQ*9|B=OK7Td&>T%__h2>m&rY!a+M9rF6PXs2W1qElIf6pTwqw;0pikF+iXZ3>!-m11)F`G|XP2MMfjw4f#edB) zz6hzgWg~(s!eKg0lWSBrnF(k!Ya6AOjU~#RNk%MbB;qkFj=O{T#tAy#Ysp@e@0h?ku@=?J3f#DqFR6E$t!NVQ~?F}RUy@oLHP8oiAK zu!=7pLW=E4w#rfmy>Jk$ZXF2MY%NBy`C!ctFmJR5*^T^vi4iC*IsA{LAKR}BrH6^20&I(K%yVQgT{w^=IrT0gYU^p)F9~p#fB;tD3ExU1ls~K8gjC` zs&Ay8jejdsvTc+zzThamIJ1X&E1@~ffz+!g5% zp5c#v`UN_7ZO7XHkxf8_)fATnAS^GXBHFhc@Xd!$`IT^e6DnBMr+HVBW1D|Pa}oige^BqnjUJ_+@B6#{KKuoOo;zG;MM@fvm%rC zs)6LUK$O9b9`G?&raoKIqJgoh*Ktz?z?BFTPg^ku$f*II`w-o`AwZsg%4Vr|IRue@vv(i{vqY!!>QeY5Ms1lK8;lH)O6T5~5W^%$o@ zJ;|p9|0S~xvCM_KV#Pat`?sp(cgj-b%%1gNP7w6ZWi0MG%QeENm*CgG?ep~dpxYRmD+Xq$_mXR3lx1_m)%wu;i>i6Ud%sR9+oYM^bym46zLLE z*zy(){&ENn)!_l#xsOIEAqQ-^A%i_T;P#Qtk9dAv zYnT_y3|~A7$?wpL>@NDy$I-dWitl{N?jX66ran>`kCWw@2K!{|!)wg9Rs^46g z(Hja?np*Nx(94f60@HEi>{vU0=I$90<+y=9p!W`zQX2wEj+4Q}X1wkD{wyUM8^|37 z%ncuBQj!nR#A>cvnSY<;K{;0=Iml!%B4VVIKk#x48Zr3v_@+%sqyh3>#jL z-^_frS93?4ej9Ee{Up4Uq3)uz7r`pM{iN`G7*VU@86!V*1P2MwEXre#)1cbiBTSv*YX)Tcs^Ip zR^U&jaBW=vrJxLU4I+!$O&VeOZtaPl^QXJeOk%-}S*{4P{`R)LyD}#0k7_LREd6qg zNzH`>Y-XBXyJUh{NL68&$HNLkhw>FyhZdQAzZ)Qj%YscGyV1##7r75w90_2FvC|dS z!a4yYn7O{Ps6L~AbJYvFGE}W|1k$FjwQNO_w>_xXk)Vsm<)9Lj7r}_d|!dj4jb@VispOGkAIOwwu)6;Kv zg&=q^C!yzEq1h$CBHteZbGZG;<-^{rq%V*vazqpuo%;&B`r5!jt#&-lVb8V06Xm`z7V&#J*n<`gs79$!1t6 z8r<<_t0{DUWMr~Oy^gL z>9B?pEbUJO6bTQhNiFUbcg!e>A9C{O1LPGb)NkPU{MIZC7HI?eu&dLKG2&g-e}94= zp}rk|BwxRRwUo$6Y0O9$22l<+y~*3R2~0uKhIDFF($X0V4=lBNH}Qt+S`1vSMB&p~ z2o6283USlx^z7~WE8Jy1>HAAQX1H;un5rBwvORBdb(c4J8#=z+n(2ew=bdMfS3(7& zC+xsy{d30Zl7gzg3m#5&CY2e>NRwu4aAF95{<&|?cYI03Y>Z#tl`XA8RB5-PpGyTc z2o&|-TjAboHjFEu_BCM&`qVS#!0y$OxVfWv!wb7A9i551WKzC$B8TA< zdjR)S@J?D;CbmhqX1x~^5Njfi4t51Z_Us$l0w?JeYb!0*K)EtV5IbKjGUMJ5Lsu`rC4Xzw~EjMF%?QnVnm z>rKZ3-9FFtC)d{6KAPxBU^LEFuMy%DS~rZyyi)l~DaBxQWo|k%z z{^JAodtV(reg-60?J-gogi}920w^K4$B%>>1g4z0p8>1r4G8i5l8oUnbTO9t%CwKx zqsI$+FBxw-Jx`Cudeau}#XSM5I;Nzk-c(YAh1G?Wh5mmIObjqRIQFnjAPq)?DqxdA zbOWI58`K�lve%^FUgEYww(%&glZeO>?Axi==|y{c#tt++l<_9!2ljpPPRivB~%< zenw@-qK>NQtN%>!$3K~2UVl_af%yNCxbppMXiSfQ18&Ch`P-Fj70Lv%tf776RuETJ zrtEw`PZL5@!wzS!khLVgXXd8@bi#M;h1LfrMFCx}kR7bP_&zq+*L zR8bcH6?rY`;k8Z4K!9COlK?}&d$qCvpvAy*HG$(B`WH=YUGj(6@Y7w18Mu_ zYNj@84Qe#G*_P9P@w5u0^HGYt-j7u8g^f%GGqmY;x;QynN5&>FQZWInEuG zHCR^o3ryge0D|&extskc8;_ma7ta;iP6mtme9dSqsTOE|9|~rJ;-Lz^yQt}lsDh|~ z#YJ3o>ro5mab2QPJ1lo?vHIFnrJDAg`lGqq zjQ35oBc+?{s)+L_#ls%HY}_5$J8mC@&8*W&nnEmp?T7QE&V@M>tFSz)hYGMa02Q_6 z(42&UQ%IT^qXaXgzYrbW!hHG7O@HJ)GwS?pza?6rLjYn;V3ZPW6%$CUO2?^APzb`< zFq1p`9jy}Yr8AmxPjRKYO2mycC$$LLxU|K#O%K{&5Qj^;dQe=8wZ+P{ek&uzzijZq zK40yBM2_mY*hD+@kq+*UxsGGKV|ES5eq3o$Up52q2FoK!7q0B?Ub9Umt=IBhHJeyz zXfaW&JQqeo>43EK3FO8j_H-xxzpDlT&Fe6s{c4Kj9BV&kv z+)LvVUFX_yE_?Ucz5bkX55S!&KPKj6lJJHHb?F5qeG#D=eyt7igzI^#`InRY+w7e|p~;V>K<7|g zp+b9B_WW0mNl*k}qrAqfd|XYDn2p{{Vf}4cc>`xA=4n=ZIbdf2NC#~)V*+4*@GrF+ z3$tJJI(b*skt@b>_V@4fKGU0m2Bs|IyikfZN`hRb8$p}YYsE2&U)E#C?#Nf<=Qe6q zW*r)DJU%^zW2bfjXhz`5S58Ic^n*tEtU_`5XJw|E?mu*u){XKi{;{VM^5*_%Dk$x5 z<^xp18<_qO3iTRW7=2n>Jb6WbQ?B53^6?kN)D*9g;I4P~QBHkHb2g#QhrFLDDIrjW zLyUjvD`lC0k+=+Dxc88j*=2J|{ZYn8jc27+hU~IV8J4eo{NE+UWrhZQ4)@E(_^ZB8s6>Iv~JW+h@61!Yidq;f_JFt3}JR%&6Bm_V4RpiaUC zX;eSXTuIvLcXGLueQEW7ZK(*--awUj&Fx12WuB>`?VRB)RG~t%$o#l~cA_`Yu8Wct z!loZ?%tk<%FRAuGE&bdX{+>9B_AK1BY|Ieo`8KU7?J{8~0vfsr>Scw%I!yl&p|?MH zJ%>V8Tbo#m21b@4r0^-X&DDU*hsiPFm^=Tkm{}XK53c(d@&E0A>grK%=iCRr1WT?Lc65K(uidKeN)t1M2C4WnfMiEy`6L1 z5#7qQDBo4jmcg$2QYgZ`;1%bdi(?JU35CC4{mb*fdKUF-;p~!`&6zXOPkY`4SW0gY z!-%g!YW=)r3X4M5e=a)CVEs%}$(7qq} zyDvI)ctQurl%~Li)ux(qv>MTSu^0qlMKx~lAWBojo;zuLMEDSSlTt$}J#gJY0!iZ& zoeJN}JQ{X?MsiB>Cg9IB#dO9Gy8c|r)-aKG#03=2+I`P90zJ2pBC+Q@UJx$~%O@*G zy55b99VoM^$3*HP9#;-p#}2(;7GbZuZ**?PXCG{U4QM>z10rAYU$&OVe>tT#vUdIh z7oM%eH*cn}EQXy}_!T~*_34vY37BLlpJScB07S2U#0cr7rU!*GnqYPJ9sxuh8soo- z3ckk=40%pO7CKRjJU<+6K+{!8_VY6+c(xqVblHf;BFN0jvc^lgs5-&>`1?0(@g^DT zo@5#Er=UV;$n|>^bYnMxH9A3kuYrAQC?p3TpfI|!jjAYmX*9Hu;l&ySxG@&i*h?<@ zai}+c(3(~x_4)rgW7_}N?(Q@|j=Bs zt@Q8c66x=%H@V})qZj<}fyrp9K~AqyOaMUmTdyx`p&l{so9qLvd6oO4eXt52afGsN zp2mnb)I}%{=FBod>I{78w|g7QIhV+Cg~`c(y$^%6ql4Fet&v6zPrXV|VV`_+BdB9j z$wIrIp{~9T@hR7D=%}{}KELME71+&_83joedlFAWXs%JFifABk_M}e=Z$!HCh^u%> zTIc%l4p(^QHJ#A!w94Pvhn>%#eQ>E^{{`B<}2g z=|oQ7ypA6R74Jwx1h%3o3qW-cfG~g&J0pX6t}H5h>TBOaBvv z9vJ{?l&`$0$Hze z03#ne;?D%5c8BqcZhedxgiKwgd+ zErzThzZ;9vb;;lBe#0C!h9s?+&hOadIaV$4odC!6!a9yGe4*^3Ap@w`FP-auj!wFE zQW!ih6ktq+YxpLdXJ#UDhE2(m)}Ef(H-bR^UNw8mgS8}`b3LO!bY|&HxjreVv7I#} z(Chu;-+ry4GDyF6%?-*PjPm08#AtG);)>ln-t|0lnIt9@cqM|KZFn0KnDt+&!n=}A zgW;MPQmABzWrBm8?l`(|hz+!VH@3~_4ReUA?6&&^h2KcAzsbz&U{_6h<;>wcF<~9b zbkn?i_De)%m0!RGJ2j#_8g|JD>exa}gpQx6wVHU&=>?L~dN6k(TfC}Km zzXDW)ngbBW6Taxju~O16oveh{``DK@i>rQM&1k9pycCcd9|jE>!nnI&@nVWDQ+&HG zYCf*L18Fz))}7H0Wvv0M^){0De_rV0OWM{C?Kyq<+=Z1HdnSL28cHlw>;xKLJ(kt= z0gREVoY3G<3x4Mnx;KY^Oxt@W<}?0AgK#$3=Z~wH-p9Ib!H(CVQ1l-HW9$WNJ<9H~ z{oyqKcw%QYwB&kEXge!K&3{%2vLhAOvGaOBSK0Q$c$lwa2OEr0>Noj&D6L)0aeK!i=Q%6O2f}u@Ut~;gy6f_qh zgJYaZu*8Gz(%ON4wf`4vuL9t-b#1RmFPu8od!yUqCOjKEssUWEj1KvyR01`~R@h@-W-qpru zPKzOGT||T5nc~B;gYchXLbPZs6KyN9eQDo2=uY zRD0<^w0YxyZIJ3_hOEd_BQ5c7-{>)%-w>vTffm1pb&fqSIb@2U6JnGh)$_G!6f)O1`0$VYEn6UXA(HR@ZbGmRT-j_L1=R{X> zZ4u1WOhe)whJO#xo3w6iDoz)WR_Z*gJc*OPE%T9;WqL8 zOtZ$zyKk?iCaK)Yzi<1p1{HoMj{Y#Fw+Si_Q0=7U`NaEZSxj6x#rNui$E0}C19i+4NTm|Eg)L-fagy-`6_`8J1rnK67uYmBGt;)Z65$hchWIRP~BRflB3IZLf2+-{6<`0 zKt0b16cxcd%KASp>%-4SEXZa+8PzY)x={{)XB*YktbH)#@RAaM6Yn`oK7-7uD2b_E z6oanM62$6Gi|stiXL=uPTvsGXF`BiLAyaa1eHm1@nTVxO_j25sC;fZCH>GgGjKd*G9rS8bHa7Obr7y^@zPhh)b=B%F6(J;^8K>VVjP z4S9Q1X6GO*&v!s_3c@%9{Njw{ zLw4KkFV^XPm>E{edQi#nl@UXIdQ+dTkQ-W75j>~yTqh3hmmSMa)m z&{-jJXxP1Q`SyJgezWyTYT$~sELIJF^i-zmJj1fM+ncdJFYX#>hzZ5x{}wfR^_4%a zI>*Dkwv_gMSCq3PVc1uUWJfD&hxOLJ_cZlVD$rWbN_)I8?GZpQHJZ$ZROq(dvYyWm z1EG*lk)Cf1RmbxvJ$-xgN>9KtAu2qR*fs>2l7XWoq0s1bwaJ!rmyRZtwY}AUG(dGM z1ayGmPsxePVgbFvT~;a`-<2iKW>vYIz> zf~qr7fg1Lp0F#T(%V?*i(Q*#z0!qUeX*XkvcUdGqN1XruTdgvs$pwRd&j?mxS7vZD z=Hp#*ISo+gFZhs+^s~ycf z0^d%2Fgv{@BSucB{0u0j@(IftgB8{Ax4s!qa=r7*-iUqv3;7^H4ON=k3!!$Tf5C`*rg0BaAHcV9bV0)BHNxkGY5C%}5M$j&ZrWEhJcO#BPNnd8oiSU?!Yjov7?de)(!#qEHMB^03> zdsD={6Zb2WS&s`3WTOM-w`3+m<{R&D=6*|-WhXAk7e+Vf%1>7=^i>vT0Q&YX6)zNV z_8A3i^`K=0G9li7tjF<{Zp|Tcf;%C!QqXw#|Nc6^7G+qjmRVnL2~{{Ji|a{IjgGDM z&~^Yi4rxgPL~U@92`~4=+fe4~u4U-C(vid~5Bq{nWtIgb*#3Pdn@dN#!FJc=z1NUm zOFY==m{Fz>d|t!L^88+k66rbv&j0b)lnK}JDkwMEOB@7$bBBR4`P}+*rJMX~ibIr_ z-u|EnjF0`&-lD3MSEwpX^%zF{!v!k#!af$MJ!EO^ zLx*Es4Ne7R4tOfxVbj8N<;as_yF1qHWp1B|GL$3L@kc(K(mFjdfin&AD#~zR^v`J# z9v)b5T>FuKu8V0x$-JZNrKAOQg+uo=y@3PJ!<5#e{$|v0fa;I2**I^-kJsc4xW#1! zq2^aOUo3%6HVEnhiQ_@Qx= z%%SW65YQy|6trBe#jrd0vLYs{T?m}H#l90-;l^BnD+qF7rGpc&>*NFM@E(6rV7T`F zd_5vm4>8(5GfRV%wnCsYH_zVn2V!vjn^66Kq=H#ZlY!G8bP9#i<*6i$v_+Rb*D|Os zV9^*szT;QVOx-{_)M-BQOvWxBFoGoRRtmUcEI1EVBcgXnyD5>?S_qFF(xF4Qf9p+V zr@+kTpJ5kiMHXn9N^+l8`eO2ow2&Xpi>pA!YZURVlzNTJ!57FgL|%9^z-$RjH`+p*qyt4oL9BCOt2+!w%(5xX1>;!%1^-RSa#NM)9Sl0_9? zYJ=9}D*{KdH#0sEc&QgbJ%bVWUKrjc>3B1vG;hxVSGLfN@HHm|vHm zXHk1mVlEa&`nGT@HuWH|J)?TVFfCNuK~`Cy1A-@;FbULyphX$iN*?E}%dmtUk-tT2 z>f`GAjz%3vOr^{YveDh>Q#HQIB)pqL9=HAc{QY z7q9kUY(-UiPprvEZxv!>849X@0@Z!~w4vmUoNRI=QyKFzWax2TwSWT>+HyC5T?s;w z2xG{TZTs{Tr2Ka6N7DCCoxP*A(v=GuTy9HEy2RtP+6DPhe75ZsB0hd2O6l74djUbJJE^EfDjYwf`72?l&v4fir<3r-|KiR1w+o&DwU z*aSJGuQBvD<%TUF_TP7gM4?21<&?%YHL=#Id#Vxymw8=jHZIGkCp#4h)+k$Nbcy}V zV7T7Ncl%kq7W_7jL^;@h*a4xTaUTl9K`2SfOhED&#UhWof*v4EXHu!*>J`!re4^P( zoLzf4h}1a?cBq3F-b>RJ(j=8KjEY8&ybx}ARoRV3F0M*(Ao#;L8WtmQxo3^?G*B(z zTDjgBEdAlH0*j%5*G>R0zzsr^vJshf1S1JM>`zv*_Q@|ZNQGd3MX6g@$PN17RDD7P z;a;XlA(nC(I+3V`vW@S@Wpxzq)^E`DMFPu8hsqE+w6}&aXnG}Yb-2DUpcQ#)VOH=s z`>H`|;AQUdCsw+lh@gtsm^1%M2YCXfIy*dc^Va|e*X8-2CpuDIY8P3g9AL(WCsrC9uU&A7YLC` z(|%^NzD5bVT!@@gAz~a*O>GWYur-yqr%RWzFfuSbx6W7V6*Epe&(B|y*n`cju6@MZ z0hcCoaJz)y+K|*a zC5bWHB;h50XElZ_9e-pO6}2#|MoBqF2o7fLNclSdNquZ|PhpEMnEt5WRq$fAPFo;3VMu9=Tw_4&>%3sDZIbF+a+jpYON@?cD!g4rzn(-u}b zLVP#aLKVL=mo9|&B=cO!?``eG>(IH1hE@1~QAoAe*EI2s@RDG_x0thS@eL~2b4$#G z!(+$*3G@VAA#Q1!>$EuZ^*uQ4uE-wmEY@At>aCQ{CM>`W0t&+fT>h4}Wf+R=tdZA> zPXu}+0g8DD{Lx|=^2k=79B8rcP*z1Th*ZBFI*@r#=I4Eyc$9Z(pNN^0M)ELheU-m| zUztNrx+bVEwuM!yHOYJHNpu7@S1-26*+t{>@Zi=ZstH+%Mv`s?*twYgQ(V1B2l1~- z_-iox+pCqfYUn`k5k$)GDZfKjuW-#P>CA0hy$2E|TEox4q7D(xeoL`ud&-fx*J2AK zj?lZc2rQ)E)7z@9E4|S-wjuHdXrS|dPe(vAik#v_x6gS~WpJ(MdvN9S#hQFaHBBZ8 zA#}J3@2LUc2Y3{~H7WOVg@dglG=KSQz;{9UYVz`eNk0El_#wQ0PKNtFBj-v-2X7PP zW{|ZPbX|#mb&UQeE5M`exV?50XcCV5zTR!06l^-sw7-xpCj-H^z%` ztXY1yYOW>cJ8eu&-14Jv`&wkWUz=Hd`EAeKx93Ca2?1cFK5Q4^AW7&@I2Uf1VaSs# z2!j#1YS_2o$+^|A(y!CQ(&Jx$!qH)U)d-d;FwzSPTqIFBu-bUv{Cm1DUuA#WLpOzJ zX9t4_HH;B=ndDj~&(%$JD%TlhvFc3}`xxSUGX64rNEIqQ_1*&}(n`aYE_`fjUsox% z>TK8N2NG@4i)`IFi6^#Z$f8WOlIba^itROB=1%v!t`bL;Thlf_j+?`j>A05F zC4~`^`H}c7N&VQqYtb#fSwH!xVzm^i!&xLx%-5B(KSL^{qZm47^J}SH>Xe2r^iX@e zjqdU1B6GmDIK%OlRy)Lho=ei#zW9MvQod4EcBLnC%}YNsebD4TWe+B;TCt4oc~;}J zTybQtRVi6{mD(Bdj+>W1uUsl1(~72t@z|pR^Vrjue6{SYgF2}Te*jnA3}5*R$aqP9 zM_X+Ie7lFK$$#@%liuH53?G$-$&HcJs2@xf14OoHwFaoKyo0&QL8ZYs6m2}fW2c&{`BXpUf8*W zEn_eFfGawaXf{vg zXuUImjK~mr`LpFO!qk(W3?Ud5K!3oZ^!|fk%S{5lJs9iHDziu20?3W64AHC87Nf9M zG29fYCcdxF1Ig_BO*Wedm$Dg?UKUDJH}VoB@&CG&ja#bJ!acPIzZM6D(G097OTuuJ zO+P_@nXCqXwBgD#sPNu4OGHr^!KoQi(1;))IFKh6T=YgV_iVAMIndiq^3YlV4kRUU zg^|ze8BO@wzLD@!cS_V(YaB!U8`EfCY;c4XFvX0k?yeY`bZ=khi}5iijZlCV3u$4T z30`WAFG>IY*VzMEhrK<1IMgN23Pc%*O@5*7M#gM^SDb#HxEk4|7+<5JgMpezHc5_@ zek1!rMpsL>ny+~Lt)g_U*i2!73=T-*MXs!mo>=LUTM0#vuF-zJj_airo8QeMChNr70QO4eSzFAY5+TO_e{C3lg9rT+vWSUr`p5k&YJoon4>q5fY za3TU&2tFNNqJ~Q>$MPMgPo14+;2jxf?<3heQx&>l4FFe(B_LQ#hJ&6(L3`ZA?nxy1 z>sOaRApO+}qB!LSs1ewVQ=cB{G*7Zv31Q}cA!%2Qq&?E9p}!^}KmIhnr7Q1elHuUf z1`RAa%AM-u#R|Z;O{L0$ds{rUb4yJxEwOC~+0x>FFstP&F*;LENxK3>Y(KZbYDXMG_RJ5U9me8S?^RgpnfdNCRM&DFf_( zR3bfr2Rxb4QK^u+0nYFuH_1B$<2Zdn1X7Xgi%V0gdq>;ZI;nMNr6imEBv%`yXy zk2VC3{##S0&hqflM&195J7|2@m>Joahd~iRun@*kZLn7oelHNF4{&D578A0IHZH|; zhQfwQk)4RU3*n4sn_38RCMD%Fhl-1Tma#jXO3IqWR(fhn_TRGlzl-6b$EVfA+z1pP zDkYMp$ou`thIkq}in22FqdzY2OIzFD2ehU}PN}`>g&mrcoUZ_+1RYJSo&HX9@CzjO zkv6gV$B;P#4Y(<(IpTkff|oIBkr>PnGtB6{w&zdt#rO(}9RGv#!F;XI8lgOYrx7PV z7hWIa*#En)n1`~vQxcE@8-raORZ0^-G@7+{%5d$%N;a=f_WsA;bi=f3A-ON?P|v7Y z;Ad7v1MxBRh5Ivb7z;l?#|bsuB4r2kJx+UtMbMNWp8RpLxyyPR8v7>^VRK1&NWwon z;oo*$4kvlNWZ}XF*sI)iiexW;y6AR809!7N*@*Xcm~k5>$xM6_wEV+I;)HiWe$`}$ z#fO2;M^Ue&bMh3>*&ud=k|VEFIbfx3Kak;mf{&q!bpu~MV&`uPYFzD}9Pb=P0VWqA z?UPstG4O>q%Qm85f>^dIg+`UJ5N( z4Y%aqMx+N-1YP(S?;eU{6w25%r!<`K(`TI0?3=`|`4hVu_g}qSnR1twfBjlqXd z^R}i>F}i%l!>UBi_-sOd94To_NUmrT0Ehg!U{{RVmy9E>+}UnI>I|}bacHP?AMuxE z#RdyOO@^aA}r$7r_31LHpqFt|rf0C_H%0 zokrh5OQi>FmkR5&Nh`M-9HV?R$aY}bffdIKNnK&d%vT|hW?3MbCLyLos!ROsSVCI5 zNV-(tSGD<^taL4B!uc|2U5Vvf5w1wp9U9+RW4piC*Nq^>L-0+EXwZd>sdq2^5PghE zJC?7xlmu$qFDGB2;77|#2mzyBW1GSr3@X6tD|hT86=|MAj|2kdzwvxYY+6R= z<#U6>9zrOOY>qT8ou;>cBFDdXH)_HrNm*}bN7_^_@fwJKT4)aCK$p^Pl7ITls0CoQ zI~UccgH1cW8dohL<9mbksA)>SOkcbzAvzpqwf9G4YcN(U2zhM9*7a^U;d$89CGAB4 zF#+kLHmJ79!>D+HRUKSGFA7u4qQ$=Nd4@Whh-x}z@YIud z=iNyRAJYPV*gd6^JVznsU!8yl5f~h+nF-MqeNVO!YAc7(cYyFG=fCpLy{us&)xUpNHJj1Z5~6F!6ereU(>nHywfzy1i&QMwt_uE--1 zx7cx^%E%8z_%t<%wIH21qRi}H%JYw3=GR-}RFn?vPGZ%&3Ti-rpd9 zYd_z)<=l2XW_po@?&n!M92uk}O1oghGaG-zPAiof{Ad5?tyooCPasOj_2&{(SY@LR z%uobZ9Ks7}s8#ogH-W75RFGQ~f}LSPR!m;3)zJAdF+t&MVB)=k-3ioS+r$cJ6{~L% z6h$ZaWEsjcpbeP{O=ngd-aPpOQgqRO$#D76tkR1acbI#ms!%8_6F$^Y6i7+UUJ#jN zxC()y);FiS(gB(pRJ!*(VFpc}-C{_N?+le&eM8mvup`%O8d&_%9x0sp+u_*|+DjAFMO?{<#VE|1*tR^fw+4cuT+hy@q r_oNLiB56p!Am9K15N#V400F~*0k--EkU@}}J}?c70ssI200CKAz-T+Q delta 13557 zcmVDN~GI4tN@<kl*#9g1QHHZKmna{yzFzb@!- z@8^b|U!C@+d=HIW5rmZBdX5~Bd&B<*AMI4|-31T?Jqf0Q3dI%UhY7BK9HEW-Q%aVJ zXu#I$rJIBk+nl$Z28tD5yu0IvLfDaC$XMA7>@zmOV|{94WxFl`hU<`h0&_@7^IC!g z-;GrY2Bih!^LijJy`h*9s+lrG9B^-lS@uv_qDGf=lWif>+;tu*!nvCjo=q{A-a%Jw zj9P;!m0#W#ypaTkZ3N?gW*$3Reks`I57g>$$=(+L!ljc_7k@Ua9m==X;`g-tEMx=Y z^NSM!1koL7e=s7IQJMLxS^QK)7tTV_!Y4(`HSBet6T~him3?cIW)k3#0ZuPKvuif3Sg)c z=|%XOUz84!rogh{LBE=P0Y;BeO}68sl%8kZ-A3WURrihCq8jdnz6_Bx2MqKX$+W_&4$xnBjR=pk|4k#R?DcRpVp#XUe+Uf9ut z{O^xe&PhN`tC{1@2e+Ns{DDxu@|8K2|9pgwFcRqw#|h$ppM_MRl+LFx&oQ=9?_d2n zF0Cx|vQBZKV*055NsfN!YwN*TS*oMF;`4U_lCnO$Yp#=PqcR?qb%sU;zMuW}T&Dck zS85S7zffTE-V8tq2cwZl+K$7|n%{U}cc+LU1wZbq8Uj>Ay9nRlw&EW}-fyW58!Oq5 zcERW3=Q`y_>MLHw#@q7NpCsKwGU;-dkopl(cjo}1^pQ) zNPhwRAWRlC;g%tA@KY@7hNprA8CCL#H*VMo>ALKaHx#}|2-jq&$0nQ+j)tXLtdh;F+e^&QD#b^^!y6?pLYZ5C@@++l$m%=J@N7qYhfcW>H6lVH zykb9+QF>I+$ElQVkWB`!HcHN`Yrb#IrJBQ9MRyG+aKM$hS1cmlDQi#%_BB)tzsT>0 z@Yoq$nc;+~Eg%2^k?#-Ai<^WytU_r-G)vD_y_~WrPr<%|%k93J>U0Hc_77n|N zL#X(FaxD$*two^rIx4HbkGRTBso#U$ns;BximKRGu3TPM_LhFX;t{jH3vY3;%5b?( z)?BO-{;EDasRcHn;g9M6Jw8ZqhckVO3 zV=0IcChIpgO)b0z+)RgBRxq}uMg-?)qQS3!>f-rcZ6-3y!%V_yiY3nHkz>FE6TdpB zG#Taiq=hX@usVK2yzsLZ4r^I{npJnugx-;nI0|Axu_}lO%iILR8?y@^Lq<>D6;G#I z^s}0FW_l+=`%K$OKm?@lKO)<8BFXcWH6nvfTF`WcB>0ZH4b5+RY`HngJT4y6ECV8c z$AJnmy2|4@DHn&&uBh{)EN}@fIL9#J={1E2j``bZuMWiBcIl+Rzb#USDE^xnW*Tmo z3Q%X%Bmttj6pI#ev!s!>HZ(3m8U(>Yeb&%_QNGPq-8>N1cN5oRnBGIcu$5lThf8E=71v62>3*wOyC3R*BvzFe zl-3A#fj!xb(R|q0e3WhuaEsqa292`=z&aoccAI3c+qLB4Ds)TLxXwc08_?9p9StkU z%boBF%a*UYw6T`kBmRJfZrFcDSuOms=4)%lr$$VWYlixBs5trzmft|4)d+qgm{;)& z(X)~bQ_B(#U`rdZDDg9orz*sMIOO>U*!Z*zfAnUT!CH>SVfe1vR9{AdndzlQXrFx9 z4@hWP#vDqyF;0Hh4w(F|wK`i8b+-!qxPD7n~$8EbUbq zU2zxAPzVK1ZYMzSXmaP(u)(0AVG6u>ltSp(fcNggARy3ISn=5;mjM)Tbc zZW79JGW-JpJAr-ITC3qUlkdfIWA-RukMvm#1P#Y@wl<91=eqd>#0O9qOOBD!39l`a z`jZkPSxoqGe&q6;L@WM(WeRnk&7Xe?gI4 zE&jqC?TRgQ$$sEXnJ7ureO;P*e1G?O7;h0>HEA*#fUSqT;TqdCa?j16lb4b`9bKRv z!m?%QyL)jt(vUt!`E-8rVJfF0#&TJUYHm=^+TW;+PAl<9M8H0O`Cz*hVa4~YJ-Aow zMFyAkP?9S4b+V}|a@^bc&y)G)k43*FDx}0g5C%1y(&=k%gc~neo*0J%H$;23M>FVl z_@FC4J&mhI?O_JFMOCOD?LQ$xXlzdZ&t($V z1}qYtz?RN7<{Kn`kMSK8*!^&<_c?}`UL5r3$vH3m@yd<0RoEpieBJ);cZ30){ojkQ zNH>0%4PvH%6~)HvElVJKrMwx{s~_jUtxceXncTB^@TQ?I1?_Z1;jS;sO`!rF&!{yP zB^%QcurQymR&L+F?SyNLG&MD3`0W~Q@#~&^f}`4cv1^@wR}ya>z83d=xEMG(bifFK zfC&3-p9Lam@b2*U~)q@Kzg zJy$r}xLO>4ST=>lC;p-b?_SVy23KV(cC42#ORFp7h z7>gse+GO&DN#P_kQzA32_m(t17CdB%is-zOy!VOPV>Dp*Cf*cs8|MecQ5*^K2jbKY z@u*JIZIvEcc6G@NXY?7bisfu3c7_3!cGK~H#prwbscLKGR_h^u zgMFYucE$Yr|0Y#?1A%D4_}n}5)Jn^jOSe=~jy^v6&KF0>M}1 zfeS#+$Rv;h`1ncM1hUf(0%w#=aMeA3fb$B0bSMi62kh)8KL0jnx(FyutY_>pG4Wjo zY|0ocrNzn=E|t~Uzh)4eb|+fCI|aH+xALgrVVDiBO0^F0K6n$nE-v*e_yEO_X2Y{5 zD6lAbFjp;?|8^g})Jh1kLy6|V&8c`yWvAD1Cn|L0#YH#!F#Flw0tX9!5q zlU*#LO_xx?GY(*KH_Fez>^dowHn8%fvZo2Twj zB-Sqtg3CL5hGEX+iN$Ty4aS~9*h_9MG$DGw+kc_|7I}gM9EMMm|1)G+_D4y@M5Hao zjO|Z)UYDR^58V>m$v(?-lAsKKHKHnO$beyb&lWNAX$UP6o@D5Z;ifEK6M{d_!rM16% znZ8`)?)tTs1ezzwT0MN;+rXmAArY3K?6k%BIx_`aEYdMQ+@;D@u9ivVbhbSlbl9n( z%+#QOGm)nY0?+2=#p6#o6zDVYs_B9!PLEFLaYP{>%&u~9HtRBfo)5}l08peTbWHI1 zP}Sfs3ks>toUZGySXxpIkCnHSL_od%ID|1O4=UX#t!uXdh#*m98r2B@EO|Ll?oed| zf^(}52)P_4x}bE1JXfKDe>Jzny2=2BA~8%Q~|!T4$X1jWNu21Fl+Ou)XH zb{%xl1Q8Kn^b+)cX*Vyg^xRd1r-_O{2&+DYx|2LR$iUKuAM+of&}%*ZJnC~osvLI8 z3?2JuvVh}(j93yfg*M9#5^0C4N=Mq>(%u5?1b~KuR0o>}cGdIS%Pz`*9c_n5#PsCnjQ70I9$H+AFgwkir^MVR{xifQYxtzDM6xt0ML?#_%C&l?7sW?K{1T;FZY?{my>UbrL+Y$(V%USSf zOvym-ru9xQfLhd!PzhD@G|7DEY3-xR{mDnep{hlB0vh}=f+P3wDW`aYd`uEm94L;6$0er%0&Lg&t9%U8o zJs>PEws$>aR*yk9&`mVy_OY{4?0oG2&}{G(edBB(eSXAo5huwH`sI6Zuc6_@Kg9xo`cv-dDQvqYI z_X|hoVO^L29>vbK0BCT>Y-!fdRb?I}IAEqd7(SBXO`!6jMZ>~^cXe%u26=VriI_ji z?Pn{xu-aR+T9T1?{*uJ_98jovx^TRI5{=ZK*r}&Dif{K`c6@bzwc3LVcj@KU@2eeN#KS`*EZ6hXn@!7=5Tj%-@-<013Zdu7NqZO>BuRoTUAU? zzO44Z^SWg*peUyJ%kadBbVhEgJQSOXXo>mc2ENBGGBWZ8XguyCjVuYK1pO;oRk_B! z@3SnBX5r1=(}w}az}p)-5fWxf3O>ZFNbf(tBQ-!D$q@JdJwiBn+~NS7uF&Uj_oXX( zL~Ze^l+iFR0@>Z&Dg~Z@!H|czg2yA+M46<0Tomnr=42ZXog8#xC&ZA?3zlWH{zzn@ zzXn!yxPM+DQKg_+=7U8FddU-zHH^6I-J!s0J-BXnuYM1%d^nWlz@C~j&|xfjKNVZ+ zI~KCz#0Pay5?DRjm;PnLReB12iR2dagTRS+l+s@GPgiqVBs5!pwVmO5)^#yH4_bbT zAfY1|4{poIT1-nfj8N3Ph?7n{B|14uKwwd6eJy@>N=wYb!L?*H+`X;Y@HU(x_hS;v z>ekJ|NBv5(>{=dA1BWR-fw!Yee>3R%uBR7?{3?tC4e=Fr{rL>hC3m~KHxE3klLi>s zZ`|D=(U}GTTUi-@-&2P2J(hc(r5^z*QiCu7BhKw!s4skVM@9$Fbxiazwe#K|i&LK4 zqKMyn=?_`}tR|1s1iE@zndOFN+%H50!@SYJM{OVF)SfOvyh@9IC@El17Y{%*FvQl#s(e)D zbxY0LY%m04Px7Y3j)X1$7+SD|tZIqK9Ivn6lQT-Gm5 z)^$Y=bnFm(`+V@k-lyumv1e|)9$ILpo$4+ zT?z+rrKIOS0y3ZpfMCn|uz;x9)na-RoKo!Q?ag>ia6cnq^>^KfW3SZxTccy7ZR#*x z#V_a0yb9Lz0184U4<*Gx37nTupXec!RJl06`k%^-7Id>iw`d#upl(mVRDs|iv>xL$ z>c!B1imgu)SM0ZX%@6J+&~|`#BTWtnQqLBZr9d9f2=?@MjA`WRowpu27J0A4uiLBH z95_7}@@sqWz9U&f4%cdVUVd;;845+)*ip#{VALkenJF%nnb$WNiU{LEoEiZlAJhLG zU60CI&pu#k3k{g>-hX_5K*hD}AC$-{8x@~_B1(JE#@-|oA8Vn$l z2b--+?5svNq38yUmrF&7ntot%z0`7ICtX2xE-~(>afYot%QiReK86bPAO(~GYB{`O zNNgY#6!u(ZvuA^y?PL;GkG!FUiPeJff!r0l`t+LNq5V^ z;u&+q-~LSjO9I3v6iy*vF!Z$CJL16^reX?d^436G$nQ+atP@5L8n0-bu zx{AoN1qR|#zF$Y2##CD7Bcy(GvpjYhjnjzI-8K_OW+N^P!)D)j?nIQ0fXpDjiw3XT z8++zd-rzMhQLCKH8Rvb-R0kKs%Ua7-tXNxJH}E-n{>>Uj6BtNChps{62oxyv$w|Hs z)a#;7HJ&1S4<)(FSyHNhNG|r5C{zcZQt=2hA4e%A4$Yij%acsNbu8Iaxaf;&-)QWD4M|QDiY!?KBQWX@bqw_R(Eb1F|-zbOwoC4tLnYj?v z_CoZW9t|O6Gc8%SJf<%um)q3jt;OL$cW=9JS=B8~n z@>>UgZ|Y9t;-^x73U6_JX0VmE#7|`h1BYq8Ui18|wk|1LSpOk27)JUhZexhbL!uT^ zNQC#!4|jeEF4&~w25dshuZq2yk0Nu{4kzJYGG#IG@VV7r12z8~QX|Ph-Uh=wncaMjSq>Rys6(dMpQ*l}Jb(88q{nE5A)N zr2F9&WHu&c>2sIp1*;@q*K~-IF0_`UX-6wxo$f?2K;P&JYA0KFW8RW zR?8g(SB(Fzv^VyiPHt^jze=V;yW+|}-}GLaE!72klGt_H9$wo1uEl?rE4ko;bbHHy z_Li@z?3MUeUS8%8OJMP7xvvubK#SaXk+Xq&j`tIPxy^LXniq4*!wQ$6YTwu=(>3#y zO=FRHV|w#pIn|`v#XaJ^Tr=PazLS&Ta9RqiSmTSBEGF-674k6snY4=cX3ugM+LOC* zPo)-oCpP-q0b5EZYEpKJC@^=^FE9ZkA0t%8>)QNx^dHxBUh*Kd#tF#=MW~-e0Ijz;3n*x= ze=s}A!gb)jv|Dp|u43Qly9ThH64u+X6yHdo|E{{G2S#>Twg%tsLsisXFE!W&STZ0k zSuGaLK#r@yLNEH@q2+R@ox|(xo)P=~_bb_df@kwP2UBiQ$go(4bUokF)dJ`j9= zd2cel#=h4P7*NhS@^6-Pl@MA?nPzOwF78`6KD_AU!F9>m8qNv`j1~%9887ibXC3t| zR5s^iD^j2W6$tvi^L|dENIGCWt|Pc>CNamFK<$-z1wH#{k+tp_6e7-zPOJYmkc)ja zW=t-+f=;q}ph)(T{h2SiXYC9|I!Dldcmd;P2}DLVkWFw!DEKl-q90hX%Lon>xf_jd z{(lwdMs4gt@cN`VL-~)p&+U)d4$6Vjm}ZI#7QpE8>u!E^NSQnwKpo!|46y{iiyG<$ z+;ZML(04qV6FikjmU1$|*3Z;18kBp1I3&pmMIiucPF^}5pc%qnQd)SJzk}F+*BW7N z&Z}D(KapB5NG57H7$w#(6;se2HI*852m zDLN@OPJ?J!cq$Qiv8_?N#e;mU0pC?(jVqHFRLu@P(Ag#-1;d!W9=*K7%2MEkQuK5C zX*R4`Z*8g}|~V5>gq#fOcR}Tg)G(o!`tau&`%?LASY%DC34Od}q9s<0C|HZKe4ZqdIX< zI!NU)m?+*{2bL;G4TAfc{hPpMoS29|3{}$grKp(r7X5wcUN)SM&{wd3qlopY*ncT7 z)|fQ+T7}Z?Vyk-DRI_=HB6~fI1jkaO%7$tGwXwRsZ2+q;Sc<0p5;kqX=Hk4TJ8oS9 z^N)C6vr`7pDwiR>{JYvpL-Tj`u#yv+y0{}H@T7gbyDbs2C z5a3O-<uDDo>-Y<+uHC6$-zy$onA!Qu@XXBCJR=Dkm*DCCVQ)d zIp52}kbH6pk`$84_>%ULJU_R*Cp8U6{KosS97MUXTmnAokV6t-23Em0i>@jzk?D~3 zGp@Sg0w2wP;+XJehTR6T3!~zPbj)WP!QO#0Si`|MINgoD(!kgaMniq851o`6O0E>! zwDCHOLD(91BxJmvmV-JF)3UaF!ru7xom!$<=}{*eGGg}ILz)9D70CqH2qBylmUi+9 zRDK{CGOuoV{CR!zLnA~>_eK{nLKGl(QZg{kR>0$ba@nNEs5F(8)(AQBvZbhelTPvg zbjq61WeQY1#FmDGSVc`cHs3nZGRUVXocHm+!-FRo2!ktXpz%!iMhGQ9(Du1dWco=e zZ&i0B-H)s0&AtK;O$PwT&5d3fH+ofiP>2}QU|1qOOy@hxap$Gt;7uHmA_!GHWGH5w zs;&Hg#q0$rI6Ejz^ywL41;17+fvLOfkB7Xt2EyDkZ(MGx&X4K5zSdB{s^ooo!&D_9$>^zHk1C6&)f=jFpy!Ff` z2~THhayp|NR^T&)-0i*HLhbsdl(6fn-I#@^C#%S6xselPhv-dCNUwZ{M zcxG1IB~D!5CmkvAT6fyWC)84*_e^AQv*Cb|IA!V`72|^_iZ{_Q~bJ(~_mOI*yq<+}-9(s>H&-g>=r@Jd;SKB5Iw17xg(;U_713uRA; zkLIiXUNCbjQCh+xpADq$gYut2+T0P-#?AytrVW{Pv)_`Hp^7G>5}b-d`GjCY{?P8BXrj9NqD>n;LBUW=(dMqX5dox9+u- zo0Xf%te6P0Op$HlpD>C#%9d(~s&c=*ofCL^kB#h!7CWE5l%VIAYIrLeg1^fX_I0PA+V~G#P5(@r*#ulF9 zmDVT6`XB%Tm!)mJEUf*ljz*$fcID-Tft=REQ5zenY%Jc?npT;EExVae5LpR6l2q!I zbLF+iVH)PmbrHI$u`pA)*Ib6mBzkY%97>L(G=a&aX+AFv*rKKg;xE_#0U8Q^=><*3 z$S9(sIs#`j4HV0*36)FT(N?dLR!?l(J$p(%4K6E>IURs z!EF@nH6_y>tk~W!GHU)p5{02hFGaFgerDu_VtUZd6OOm~W#(}u9_-P7GXCOiCGVcS z;;X+)g1QWu)l+UxaTVlo<5ZpmNQ+^bTdJ=n4RYQd<8iQPsgDNes2hk{Vz45<_(VM# z(*T!k1~PBq-Vm*w(m8TXk%eYVuk)2Q#~-sPeM%0?*A|B$Po@U!MVHR7hR~y_Ifhqv zD#p-&ue%qHOGp(^)^Z7d48g^$3Wq#2JE~LG!OE7(UNcM|#kh<%uj?=EJ{h`Znr!yx zOsGw50v+w@1%B;pSfjA!!G-54=3{wuA%Dk4KHY2+1Ec=HMbI_lkXC8>`tO-L8rc0@ zklb0{E4p3TYE?bpyL-NLgQ5q%@!AdRLFD&tD}olLfWf}WdM@UFvCaCR={}mf3BxS+ zj-9FtP-|fkV#)$s3L>^=Xu0BoN8 zTeEZyE2;jGh)K=BH@ks`lQ(qIokjVY1_mCW;J(Z2D zPvxSZH`x2vPylZ!!gU}yRT9^u&2fmkxhoq6FR*?T#yZBTRIz^8JuiG7JCL1hu3s=Z zjZOx_Cst9DU%g}?&>?$j|Gl&Z89~MR%l{Kam0z4H1+nL_1}g{63)N&tH)+874ORCH zZzc2~n_L6H_#?+DYU7I2G~M=IL`9v;`8Ily%POpYiB=+t9NjN%n-Phcb=2>-E_7vq zOiBQZ-oZbeL1*LduI#~PGMY-)fhvTUPQjf@dFztBdag*&x*d|7@ZA!j=A7AFD=;6F zdux+X2~3f6%c0P_%yDeSnQ^@`Uj(9$CJDgQi3n=~8u#tH#zmWHp)7qwJ3CoFX4yu^ zGMrd{=bhU0eXRqbH7`2yBgYR-U`Re1@A!<=;6(tQK2z0EF~w-v+sPD{O#uySR&|r| ze9>bKsEFag)Xp!zlAE&CN*+3U=`m&n1Ij>sMLFU~X9W$ES>P;rilh_=RK#*?uU+-D zb3z?uqu0eP?xYzi(VaGZ!@jBlX>04f4_mg*J|@pF%$y}igm z+gST^zH8Nhm&{pmm-48d0cRR)aniOA{iUZ9H0rj zjk|XY5%TlSCE;UgQ*6O)9 z|AEht49y!@W$WTju5rAqS6AvwNgzTXB?%UZ6fk<| z<9=(xaKKNsgo?X-$_**~Bx=maT(~U=F9x1n8Z=4MjTqa&FV$SRW-C=G@?GAR`RQ<7 zB-*I=#Zo?oHsWoao#<5LPO>_1_(Dyys2TyrJ@#1Ch<^e0egprJS_%6ee>~h><=!h? zP6HpT^^!4n!ud}iYTBl;E`+Fm^`LlI0QP&(TY=76|Js$YtwmzkL*c<8$}i()PBth( z1ykVG53}vLw%4?b3D|lir?pvl_oMhFYU_QQVG6YKkc*cx6}|JaKy^hWj5$t@*Fd1h zh6XcAkT|H_gHm|<@4b=xh;*>;BonP0oMzJQB_DuUKCHvL`JOLF)YRsG!{1(4wK5{# z_Ql@6(q>v{Gl}z@_xdkQ{o+#H6Z;c|M8r5*ro|nw^6SD5?4-~ZD?;AqTrCS|(R6&% zE#V0;V!*k_1ocLF$|bTToBd0leKF9^9MQGAbTaK8IZPiNKAl){&-}ZZazJoyoMV)T zf$uUKb}7N-;2~t0R;)rK{1+X5_%it5%H%nR_E62jH*g%i zKZbDlrLRiLU6=R!?(+;&aEer~f|kNqAHbLj5&{6w#{<%m@7KYT{p$r*&^EB#rb4;3C1NUee@!2+HYki zXQ!?mK__2en^~2ABups|%H?}5w{s|*?EY%t+1j_kE^ra%O-x3ZS^KKm4++IA+(kv)utp^d5nYRy?s4{Bv4sK)JmiQ52R<(Kh4BB zut~>@hQEmgq;0Q(9VC|?PKDF-?kj9V)T|J02agR}1UZmi)n7qL8*|b2S+)Y_PTaXB z?TktRu`L4PrXo{50Riw^iL#qGR8P?0s^%3?yRguIqX(Nj;zDriH)nD$e0vf#UsrXQ z$3l%(_R_Mbh;bpVNh8`II5RVgJ}KeA`}j{SuxV~?a7(lw^ccd1=8La;Afo=x5}U)NX}ILIR_ zY)o2zR}Ao2I_A$IE!-n~u%Bf|0Ag z$Ci-uk_PAcG@N)eWVq6Wcc_M*(0dJD{jLeu%5?;FW{lG~{&7iyuIL zlnw(i#oVwJS7#19-!6op!Xdow@bLuBZ9g)9Kbl}cLI2Q0wt_I*N^T_4P1iJ8&@lsX z1M^xX8RQl?PpVkU&MYV+sR;C!jm%@yl~O6RB4ZBPMp6`|hs9wsTWJ z7CD@Zg?2}^W@^?Xm>4);Fx#1%TDasCLZ*+`PS*1RAlRl*z2Imw^S@l-XIFqXoQEcqq#JGCGb)cDCB`8`UkFC z^qhB?8O4-ry=xh;6S~CakcPvr;Ybb2KvP+rPwbO9TfQryTX3CFI4wE4i?=_-ztLg` zaORL)Vd32r}xD+cyxWR~xLy1jT1C8u~4jk>VAb3XMxtj7fBs`uJxH?7AC zc3g#Jqvg>}3`!)jnVPTSIYFA?X_WjSBU7Kv$&%<@UG&`kf`#I<1{v!rHv;t?7ggM( z4#i~dY5Qbad1)%YZE{cKDn3A@xhADzV!=;&Y&Tq%#><@@CPP;hFGKKjgxiK>G*-7; zZwpX8o^+Ge=AsDWKtKTpXx;!Z&58>jVs4qlOBSoz`nZF#$NCgpEmNnJD9j**6?shf v6LmbfB)B&h7{L|l3%$Sq5hGg*00GE=0nYjcyNI=`J}?c70ssI200CKAok(eX diff --git a/man/CtwasResult-class.Rd b/man/CtwasResult-class.Rd new file mode 100644 index 00000000..cf833834 --- /dev/null +++ b/man/CtwasResult-class.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CtwasResult.R +\docType{class} +\name{CtwasResult-class} +\alias{CtwasResult-class} +\title{cTWAS Result Collection} +\description{ +S4 collection of cTWAS runs keyed by the identity tuple + \code{(gwasStudy, study, context, method)}. Each row holds a + \code{\linkS4class{CtwasResultEntry}} payload -- fine-mapping posteriors, + the jointly-estimated group priors, and region metadata -- for one run. +} +\details{ +Unlike the QTL family, \code{trait} is not part of the key: a cTWAS + run is multi-gene, so genes live inside the payload. The optional + \code{jointStudies} / \code{jointContexts} columns tag rows born from a + multi-study or multi-context run and participate in the uniqueness key, + exactly as in the \code{\linkS4class{TwasWeights}} and fine-mapping + families. +} +\seealso{ +\code{\link{CtwasResult}} for the constructor and + \code{\link{ctwasPipeline}} for the pipeline that builds one. +} diff --git a/man/CtwasResultEntry-class.Rd b/man/CtwasResultEntry-class.Rd new file mode 100644 index 00000000..a83a5756 --- /dev/null +++ b/man/CtwasResultEntry-class.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CtwasResultEntry.R +\docType{class} +\name{CtwasResultEntry-class} +\alias{CtwasResultEntry-class} +\title{cTWAS Per-Run Payload} +\description{ +Per-run cTWAS payload: the fine-mapping posterior table, the + full per-effect susie alpha table, the jointly-estimated group prior(s), + and per-region metadata. One entry sits in every row of a + \code{\linkS4class{CtwasResult}} collection. +} +\section{Slots}{ + +\describe{ +\item{\code{finemap}}{The per-gene (and, when SNPs are retained, per-SNP) posterior +summary table (\code{ctwas::finemap_regions} \code{finemap_res} shape), +or \code{NULL}.} + +\item{\code{susieAlpha}}{The per-effect susie alpha table +(\code{ctwas::finemap_regions} \code{susie_alpha_res} shape) -- the +fuller cTWAS output retained so the raw run is reconstructable, or +\code{NULL}.} + +\item{\code{param}}{The estimated \code{group_prior} / \code{group_prior_var} for +this run, or \code{NULL}.} + +\item{\code{regionInfo}}{Per-region metadata, or \code{NULL}.} +}} + +\seealso{ +\code{\link{CtwasResultEntry}} for the constructor. +} diff --git a/man/GwasSumStats-class.Rd b/man/GwasSumStats-class.Rd new file mode 100644 index 00000000..c48e31e2 --- /dev/null +++ b/man/GwasSumStats-class.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/gwasSumStats.R +\docType{class} +\name{GwasSumStats-class} +\alias{GwasSumStats-class} +\title{GWAS Summary-Statistic Collection} +\description{ +S4 collection of GWAS summary statistics keyed by the identity + tuple \code{(study)}. Each element is that study's per-variant + \code{GRanges} covering a single LD block, so build one collection per + block when sweeping the genome. +} +\details{ +Required column: \code{study}, unique across rows. The class-level + slots inherited from \code{\linkS4class{SumStatsBase}} -- + \code{ldSketch}, \code{genome} and \code{qcInfo} -- apply uniformly to + every row. +} +\seealso{ +\code{\link{GwasSumStats}} for the constructor and + \code{\linkS4class{QtlSumStats}} for the QTL counterpart. +} diff --git a/man/QtlDataset-class.Rd b/man/QtlDataset-class.Rd index 0d9492eb..d9d45717 100644 --- a/man/QtlDataset-class.Rd +++ b/man/QtlDataset-class.Rd @@ -89,9 +89,7 @@ than one of the things being chosen between, so it is always retained. \describe{ \item{\code{study}}{Character (length 1). Study identifier; used in collection classes to tag downstream \code{FineMappingResult} / \code{TwasWeights} -entries.} - -\item{\code{genotypes}}{The genotype source for lazy access to dosages. +entries. The \code{genotype} experiment's assay reads through this handle; the extraction accessors read it directly, so that QC can be applied per block.} diff --git a/man/QtlSumStats-class.Rd b/man/QtlSumStats-class.Rd new file mode 100644 index 00000000..c909f8f1 --- /dev/null +++ b/man/QtlSumStats-class.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/qtlSumStats.R +\docType{class} +\name{QtlSumStats-class} +\alias{QtlSumStats-class} +\title{QTL Summary-Statistic Collection} +\description{ +S4 collection of QTL summary statistics keyed by the identity + tuple \code{(study, context, trait)}. Each element is that tuple's + per-variant \code{GRanges} -- \code{variant_id} plus the per-variant + Z / N / MAF mcols. +} +\details{ +Required columns: \code{study}, \code{context} and \code{trait}; + the 3-tuple is unique. The class-level slots inherited from + \code{\linkS4class{SumStatsBase}} -- \code{ldSketch}, \code{genome} and + \code{qcInfo} -- apply uniformly to every row, and \code{qcInfo} records + which \code{\link{summaryStatsQc}} passes have run. +} +\seealso{ +\code{\link{QtlSumStats}} for the constructor and + \code{\linkS4class{GwasSumStats}} for the GWAS counterpart. +} diff --git a/man/RangedTupleList-methods.Rd b/man/RangedTupleList-methods.Rd index bbb59a79..b250d846 100644 --- a/man/RangedTupleList-methods.Rd +++ b/man/RangedTupleList-methods.Rd @@ -10,6 +10,7 @@ \alias{[,RangedTupleList,ANY,ANY,ANY-method} \alias{[[<-,RangedTupleList,ANY,ANY-method} \alias{endoapply,RangedTupleList-method} +\alias{bindROWS,RangedTupleList-method} \title{RangedTupleList methods} \usage{ \S4method{nrow}{RangedTupleList}(x) @@ -27,6 +28,14 @@ \S4method{[[}{RangedTupleList,ANY,ANY}(x, i, j, ...) <- value \S4method{endoapply}{RangedTupleList}(X, FUN, ...) + +\S4method{bindROWS}{RangedTupleList}( + x, + objects = list(), + use.names = TRUE, + ignore.mcols = FALSE, + check = TRUE +) } \arguments{ \item{x, X}{A \code{RangedTupleList} collection.} diff --git a/man/SumStatsBase-class.Rd b/man/SumStatsBase-class.Rd index f70e977a..1f3f2ea5 100644 --- a/man/SumStatsBase-class.Rd +++ b/man/SumStatsBase-class.Rd @@ -8,7 +8,8 @@ Virtual base class for QTL and GWAS summary statistics collections. Concrete subclasses (\code{QtlSumStats}, \code{GwasSumStats}) inherit from \code{\linkS4class{RangedTupleList}} and share the - \code{ldSketch} / \code{genome} / \code{qcInfo} slots. + \code{ldSketch} / \code{qcInfo} slots, and the genome build in + \code{seqinfo()}. Each element is the per-variant \code{GRanges} of one tuple, so \code{x[[i]]} is that tuple's summary statistics and the identity columns @@ -23,8 +24,6 @@ or \code{NULL}. Optional: LD-free workflows (e.g. mash, which operates across conditions per variant) carry \code{NULL}; pipelines that need LD validate its presence when they consume the collection.} -\item{\code{genome}}{Character, genome build label.} - \item{\code{qcInfo}}{A \code{list} recording which QC steps ran. Empty \code{list()} on construction; populated by \code{summaryStatsQc()} with a per-step audit record (filter names, drop counts, liftover target, RAISS settings, etc.). diff --git a/man/TupleRangesView-class.Rd b/man/TupleRangesView-class.Rd deleted file mode 100644 index 4cd731c8..00000000 --- a/man/TupleRangesView-class.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/TupleRangesView.R -\docType{class} -\name{TupleRangesView-class} -\alias{TupleRangesView-class} -\alias{[,TupleRangesView,ANY,ANY,ANY-method} -\title{Flat view of a tuple collection for plyranges verbs} -\usage{ -\S4method{[}{TupleRangesView,ANY,ANY,ANY}(x, i, j, ..., drop = TRUE) -} -\description{ -A \code{\link[GenomicRanges]{GenomicRanges}} view over a -\code{RangedTupleList}: every element's ranges concatenated, with the -collection's identity tuple broadcast onto each range. Because it is a -\code{GenomicRanges}, plyranges verbs act on it directly. -} -\details{ -Users do not normally build one. The verb methods on \code{RangedTupleList} -convert to a view, delegate, and convert back. -} -\section{Slots}{ - -\describe{ -\item{\code{delegate}}{The flattened \code{GRanges}.} -}} - -\keyword{internal} diff --git a/man/extractCsInfo.Rd b/man/extractCsInfo.Rd index 58a74555..3661559b 100644 --- a/man/extractCsInfo.Rd +++ b/man/extractCsInfo.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sumstatsQc.R +% Please edit documentation in R/fineMappingWrappers.R \name{extractCsInfo} \alias{extractCsInfo} \title{Process Credible Sets (CS) from Finemapping Results} diff --git a/man/extractTopPipInfo.Rd b/man/extractTopPipInfo.Rd index 2c1c3b77..6851486e 100644 --- a/man/extractTopPipInfo.Rd +++ b/man/extractTopPipInfo.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sumstatsQc.R +% Please edit documentation in R/fineMappingWrappers.R \name{extractTopPipInfo} \alias{extractTopPipInfo} \title{Extract Information for Top Variant from Finemapping Results} diff --git a/man/flattenTupleRanges.Rd b/man/flattenTupleRanges.Rd index ff4282be..f2c1f81c 100644 --- a/man/flattenTupleRanges.Rd +++ b/man/flattenTupleRanges.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/TupleRangesView.R +% Please edit documentation in R/RangedTupleList.R \name{flattenTupleRanges} \alias{flattenTupleRanges} \title{Flatten a tuple collection to a plain GRanges} diff --git a/man/getSusieResult.Rd b/man/getSusieResult.Rd index 31cc76f7..928f5060 100644 --- a/man/getSusieResult.Rd +++ b/man/getSusieResult.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sumstatsQc.R +% Please edit documentation in R/fineMappingWrappers.R \name{getSusieResult} \alias{getSusieResult} \title{Extract the trimmed SuSiE fit from a finemapping pipeline result} diff --git a/man/nestTupleRanges.Rd b/man/nestTupleRanges.Rd index 95ddf771..54d19155 100644 --- a/man/nestTupleRanges.Rd +++ b/man/nestTupleRanges.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/TupleRangesView.R +% Please edit documentation in R/RangedTupleList.R \name{nestTupleRanges} \alias{nestTupleRanges} \title{Re-nest a flattened GRanges into a tuple collection} diff --git a/man/show-methods.Rd b/man/show-methods.Rd index 0c54b6fb..63613ad7 100644 --- a/man/show-methods.Rd +++ b/man/show-methods.Rd @@ -3,9 +3,8 @@ % R/AnnotationMatrix.R, R/ColocResult.R, R/ColocBoostResult.R, % R/CtwasResult.R, R/GwasFineMappingResult.R, R/H2Estimate.R, R/LdData.R, % R/LdEigen.R, R/LdScore.R, R/MashPrior.R, R/QtlDataset.R, -% R/MultiStudyQtlDataset.R, R/QtlFineMappingResult.R, R/TupleRangesView.R, -% R/qtlSumStats.R, R/gwasSumStats.R, R/fineMappingRow.R, R/twasWeights.R, -% R/twasWeightsRow.R +% R/MultiStudyQtlDataset.R, R/QtlFineMappingResult.R, R/qtlSumStats.R, +% R/gwasSumStats.R, R/fineMappingRow.R, R/twasWeights.R, R/twasWeightsRow.R \name{show-methods} \alias{show-methods} \alias{show,GenotypeHandle-method} @@ -22,7 +21,6 @@ \alias{show,QtlDataset-method} \alias{show,MultiStudyQtlDataset-method} \alias{show,QtlFineMappingResult-method} -\alias{show,TupleRangesView-method} \alias{show,QtlSumStats-method} \alias{show,GwasSumStats-method} \alias{show,FineMappingRow-method} @@ -58,8 +56,6 @@ \S4method{show}{QtlFineMappingResult}(object) -\S4method{show}{TupleRangesView}(object) - \S4method{show}{QtlSumStats}(object) \S4method{show}{GwasSumStats}(object) diff --git a/tests/testthat/test_RangedTupleList.R b/tests/testthat/test_RangedTupleList.R index 64cce75f..2b3d9e18 100644 --- a/tests/testthat/test_RangedTupleList.R +++ b/tests/testthat/test_RangedTupleList.R @@ -562,3 +562,255 @@ test_that(".rtlGatherElements does not re-validate the collection", { x <- .rtl_makeKid() expect_identical(.rtlGatherElements(x, 2L), x[[2]]) }) + + +# =========================================================================== +# The plyranges bridge: the flatten / nest conversions and the dplyr verbs +# built on them. +# +# plyranges has no GRangesList support, so the collections cannot be operated +# on directly. The bridge flattens to a plain GenomicRanges -- which plyranges +# does support natively -- and nests the result back again. +# =========================================================================== + +test_that("flattenTupleRanges concatenates every element's ranges", { + data(qtlSumStatsMulticontextExample, envir = environment()) + mc <- qtlSumStatsMulticontextExample + flat <- flattenTupleRanges(mc) + expect_s4_class(flat, "GRanges") + expect_equal(length(flat), sum(lengths(mc))) +}) + +test_that("flattenTupleRanges broadcasts the identity tuple, dot-prefixed", { + data(qtlSumStatsMulticontextExample, envir = environment()) + mc <- qtlSumStatsMulticontextExample + flat <- flattenTupleRanges(mc) + cn <- colnames(mcols(flat)) + expect_true(all(is_in(c(".study", ".context", ".trait"), cn))) + # One value per range, matching the element it came from. + expect_setequal(unique(mcols(flat)$.context), as.character(mc$context)) + expect_equal( + sum(mcols(flat)$.context == "blood"), + lengths(mc)[[which(mc$context == "blood")]] + ) +}) + +test_that("the dot prefix keeps a colliding per-range column intact", { + # On gwasFineMappingExample the outer `method` is "susie" while the + # per-range `method` is "susieRss" -- the collection's label against the + # fitter actually used. Broadcasting onto the bare name would overwrite + # one with the other. + data(gwasFineMappingExample, envir = environment()) + x <- gwasFineMappingExample + expect_true(is_in("method", colnames(mcols(x[[1]])))) + flat <- flattenTupleRanges(x) + expect_true(all(is_in(c("method", ".method"), colnames(mcols(flat))))) + expect_false(identical( + unique(mcols(flat)$method), + unique(mcols(flat)$.method) + )) +}) + +test_that("flattenTupleRanges drops non-broadcastable payload columns", { + # susieFit / cvResult describe an ELEMENT, so there is no range to put + # them on. + data(qtlFineMappingExample, envir = environment()) + flat <- flattenTupleRanges(qtlFineMappingExample) + expect_false(is_in("susieFit", colnames(mcols(flat)))) + expect_false(is_in(".susieFit", colnames(mcols(flat)))) + expect_true(is_in(".study", colnames(mcols(flat)))) +}) + +test_that("flattenTupleRanges rejects a non-collection", { + expect_error( + flattenTupleRanges(GenomicRanges::GRanges()), + "RangedTupleList" + ) +}) + +test_that("nestTupleRanges round-trips an unmodified flatten", { + data(qtlSumStatsMulticontextExample, envir = environment()) + mc <- qtlSumStatsMulticontextExample + back <- nestTupleRanges(flattenTupleRanges(mc), mc) + expect_s4_class(back, "QtlSumStats") + expect_equal(lengths(back), lengths(mc)) + expect_equal(mcols(back), mcols(mc)) + # Collection-level slots survive, which is the point of nesting through a + # template rather than rebuilding from the ranges alone. + expect_identical(getLdSketch(back), getLdSketch(mc)) + expect_identical(getGenome(back), getGenome(mc)) +}) + +test_that("nestTupleRanges returns a filtered flatten to its elements", { + data(qtlSumStatsMulticontextExample, envir = environment()) + mc <- qtlSumStatsMulticontextExample + flat <- flattenTupleRanges(mc) + kept <- flat[mcols(flat)$Z > 0] + back <- nestTupleRanges(kept, mc) + expect_equal(sum(lengths(back)), length(kept)) + expect_lt(sum(lengths(back)), sum(lengths(mc))) + # Every range lands under the tuple it carried. + idx <- which(mc$context == "blood") + expect_equal( + lengths(back)[[idx]], + sum(mcols(kept)$.context == "blood") + ) +}) + +test_that("nestTupleRanges keeps a tuple whose ranges all vanished", { + # An empty element, not a dropped row: the collection keeps its shape so + # its metadata stays aligned. + data(qtlSumStatsMulticontextExample, envir = environment()) + mc <- qtlSumStatsMulticontextExample + flat <- flattenTupleRanges(mc) + onlyBlood <- flat[mcols(flat)$.context == "blood"] + back <- nestTupleRanges(onlyBlood, mc) + expect_equal(nrow(back), nrow(mc)) + expect_equal(sum(lengths(back) == 0L), nrow(mc) - 1L) +}) + +test_that("nestTupleRanges survives an NA-valued identity column", { + # str_c() propagates NA, so an NA identity value (varY is NA_real_ on a + # z-score collection) would make every key NA and the row lookup a + # logical subscript full of NAs. + data(qtlSumStatsMulticontextExample, envir = environment()) + mc <- qtlSumStatsMulticontextExample + expect_true(any(is.na(mcols(mc)$varY))) + expect_equal( + lengths(nestTupleRanges(flattenTupleRanges(mc), mc)), + lengths(mc) + ) +}) + +test_that("nestTupleRanges validates its arguments", { + data(qtlSumStatsMulticontextExample, envir = environment()) + mc <- qtlSumStatsMulticontextExample + flat <- flattenTupleRanges(mc) + expect_error(nestTupleRanges(flat, "not a collection"), "RangedTupleList") + expect_error(nestTupleRanges("not ranges", mc), "GRanges") +}) + + + + +# --------------------------------------------------------------------------- +# plyranges / dplyr verbs. +# +# These call the methods directly rather than through the generic: dispatch +# needs the S3method() entries a roxygen regen writes, and the logic under test +# is the same either way. The final test checks dispatch itself, and skips +# until the registration exists. +# --------------------------------------------------------------------------- + +# @noRd +.trv_mc <- function() { + data(qtlSumStatsMulticontextExample, envir = environment()) + qtlSumStatsMulticontextExample +} + +test_that("filter keeps the collection and narrows its elements", { + mc <- .trv_mc() + out <- filter.RangedTupleList(mc, Z > 2) + expect_s4_class(out, "QtlSumStats") + expect_equal(nrow(out), nrow(mc)) + expect_lt(sum(lengths(out)), sum(lengths(mc))) + expect_identical(getLdSketch(out), getLdSketch(mc)) +}) + +test_that("filter can mix identity and per-range columns", { + # The whole point of broadcasting the tuple: one predicate spanning both. + mc <- .trv_mc() + out <- filter.RangedTupleList(mc, .context == "blood" & Z > 1) + idx <- which(mc$context == "blood") + expect_gt(lengths(out)[[idx]], 0L) + expect_equal(sum(lengths(out)[-idx]), 0L) +}) + +test_that("mutate adds a per-range column without changing the shape", { + mc <- .trv_mc() + out <- mutate.RangedTupleList(mc, hit = Z > 2) + expect_equal(lengths(out), lengths(mc)) + expect_true(is_in("hit", colnames(mcols(out[[1]])))) +}) + +test_that("select keeps the identity columns it needs to nest", { + # Dropping them would leave the ranges with no tuple, and every one would + # fall into the first element. + mc <- .trv_mc() + out <- select.RangedTupleList(mc, Z) + expect_equal(lengths(out), lengths(mc)) +}) + +test_that("slice takes n ranges from EACH element", { + # Slicing the flattened set would take n in total and empty all but the + # first element. + mc <- .trv_mc() + out <- slice.RangedTupleList(mc, 1:5) + expect_equal(unname(lengths(out)), rep(5L, nrow(mc))) +}) + +test_that("arrange orders within each element", { + mc <- .trv_mc() + out <- arrange.RangedTupleList(mc, Z) + expect_equal(lengths(out), lengths(mc)) + for (i in seq_len(nrow(out))) { + expect_false(is.unsorted(mcols(out[[i]])$Z)) + } +}) + +test_that("summarise reduces to a table rather than a collection", { + mc <- .trv_mc() + out <- summarise.RangedTupleList(mc, n = plyranges::n()) + expect_false(is(out, "RangedTupleList")) + expect_equal(NROW(out), 1L) +}) + +test_that("group_by returns plyranges' own grouped representation", { + mc <- .trv_mc() + out <- group_by.RangedTupleList(mc, .context) + expect_s4_class(out, "GroupedGenomicRanges") + expect_equal(length(out), sum(lengths(mc))) +}) + + +test_that("the verbs are reachable through the dplyr generics", { + # Needs the S3method() entries from a roxygen regen; skips until then. + # Probed by attempting dispatch rather than by looking the function up: + # getS3method() finds it in the namespace whether or not it is registered. + mc <- .trv_mc() + dispatches <- tryCatch( + { + dplyr::filter(mc, Z > 2) + TRUE + }, + error = function(e) FALSE + ) + skip_if_not(dispatches, "S3 methods not yet registered (regen pending)") + expect_s4_class(dplyr::filter(mc, Z > 2), "QtlSumStats") + expect_s4_class(dplyr::slice(mc, 1:2), "QtlSumStats") +}) + + +# =========================================================================== +# Degenerate collections and the plyranges requirement +# =========================================================================== + +test_that("flattening a collection with no identity columns keeps its ranges", { + # With nothing to key on, every range belongs to the single element -- + # which is what a one-row collection means. + mc <- .trv_mc() + bare <- mc[1, ] + mcols(bare) <- mcols(bare)[, character(0), drop = FALSE] + flat <- flattenTupleRanges(bare) + expect_equal(length(flat), sum(lengths(bare))) +}) + +test_that(".rtlTupleKeys gives every row the same key with no key columns", { + md <- S4Vectors::DataFrame(entry = S4Vectors::SimpleList(1, 2)) + expect_equal(.rtlTupleKeys(md, character(0), 3L), rep("", 3L)) +}) + +test_that(".rtlTupleKeyCols is empty when there are no mcols", { + gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 2)) + expect_equal(.rtlTupleKeyCols(gr), character(0)) +}) diff --git a/tests/testthat/test_TupleRangesView.R b/tests/testthat/test_TupleRangesView.R deleted file mode 100644 index 58c3850c..00000000 --- a/tests/testthat/test_TupleRangesView.R +++ /dev/null @@ -1,314 +0,0 @@ -# Tests for the plyranges bridge: TupleRangesView and the flatten / nest -# conversions. -# -# plyranges has no GRangesList support, so the collections cannot be operated -# on directly. The bridge converts to a flat GenomicRanges view -- which -# plyranges does support, via the DelegatingGenomicRanges extension point -- -# and back again. - -test_that("flattenTupleRanges concatenates every element's ranges", { - data(qtlSumStatsMulticontextExample, envir = environment()) - mc <- qtlSumStatsMulticontextExample - flat <- flattenTupleRanges(mc) - expect_s4_class(flat, "GRanges") - expect_equal(length(flat), sum(lengths(mc))) -}) - -test_that("flattenTupleRanges broadcasts the identity tuple, dot-prefixed", { - data(qtlSumStatsMulticontextExample, envir = environment()) - mc <- qtlSumStatsMulticontextExample - flat <- flattenTupleRanges(mc) - cn <- colnames(mcols(flat)) - expect_true(all(is_in(c(".study", ".context", ".trait"), cn))) - # One value per range, matching the element it came from. - expect_setequal(unique(mcols(flat)$.context), as.character(mc$context)) - expect_equal( - sum(mcols(flat)$.context == "blood"), - lengths(mc)[[which(mc$context == "blood")]] - ) -}) - -test_that("the dot prefix keeps a colliding per-range column intact", { - # On gwasFineMappingExample the outer `method` is "susie" while the - # per-range `method` is "susieRss" -- the collection's label against the - # fitter actually used. Broadcasting onto the bare name would overwrite - # one with the other. - data(gwasFineMappingExample, envir = environment()) - x <- gwasFineMappingExample - expect_true(is_in("method", colnames(mcols(x[[1]])))) - flat <- flattenTupleRanges(x) - expect_true(all(is_in(c("method", ".method"), colnames(mcols(flat))))) - expect_false(identical( - unique(mcols(flat)$method), - unique(mcols(flat)$.method) - )) -}) - -test_that("flattenTupleRanges drops non-broadcastable payload columns", { - # susieFit / cvResult describe an ELEMENT, so there is no range to put - # them on. - data(qtlFineMappingExample, envir = environment()) - flat <- flattenTupleRanges(qtlFineMappingExample) - expect_false(is_in("susieFit", colnames(mcols(flat)))) - expect_false(is_in(".susieFit", colnames(mcols(flat)))) - expect_true(is_in(".study", colnames(mcols(flat)))) -}) - -test_that("flattenTupleRanges rejects a non-collection", { - expect_error( - flattenTupleRanges(GenomicRanges::GRanges()), - "RangedTupleList" - ) -}) - -test_that("nestTupleRanges round-trips an unmodified flatten", { - data(qtlSumStatsMulticontextExample, envir = environment()) - mc <- qtlSumStatsMulticontextExample - back <- nestTupleRanges(flattenTupleRanges(mc), mc) - expect_s4_class(back, "QtlSumStats") - expect_equal(lengths(back), lengths(mc)) - expect_equal(mcols(back), mcols(mc)) - # Collection-level slots survive, which is the point of nesting through a - # template rather than rebuilding from the ranges alone. - expect_identical(getLdSketch(back), getLdSketch(mc)) - expect_identical(getGenome(back), getGenome(mc)) -}) - -test_that("nestTupleRanges returns a filtered flatten to its elements", { - data(qtlSumStatsMulticontextExample, envir = environment()) - mc <- qtlSumStatsMulticontextExample - flat <- flattenTupleRanges(mc) - kept <- flat[mcols(flat)$Z > 0] - back <- nestTupleRanges(kept, mc) - expect_equal(sum(lengths(back)), length(kept)) - expect_lt(sum(lengths(back)), sum(lengths(mc))) - # Every range lands under the tuple it carried. - idx <- which(mc$context == "blood") - expect_equal( - lengths(back)[[idx]], - sum(mcols(kept)$.context == "blood") - ) -}) - -test_that("nestTupleRanges keeps a tuple whose ranges all vanished", { - # An empty element, not a dropped row: the collection keeps its shape so - # its metadata stays aligned. - data(qtlSumStatsMulticontextExample, envir = environment()) - mc <- qtlSumStatsMulticontextExample - flat <- flattenTupleRanges(mc) - onlyBlood <- flat[mcols(flat)$.context == "blood"] - back <- nestTupleRanges(onlyBlood, mc) - expect_equal(nrow(back), nrow(mc)) - expect_equal(sum(lengths(back) == 0L), nrow(mc) - 1L) -}) - -test_that("nestTupleRanges survives an NA-valued identity column", { - # str_c() propagates NA, so an NA identity value (varY is NA_real_ on a - # z-score collection) would make every key NA and the row lookup a - # logical subscript full of NAs. - data(qtlSumStatsMulticontextExample, envir = environment()) - mc <- qtlSumStatsMulticontextExample - expect_true(any(is.na(mcols(mc)$varY))) - expect_equal( - lengths(nestTupleRanges(flattenTupleRanges(mc), mc)), - lengths(mc) - ) -}) - -test_that("nestTupleRanges validates its arguments", { - data(qtlSumStatsMulticontextExample, envir = environment()) - mc <- qtlSumStatsMulticontextExample - flat <- flattenTupleRanges(mc) - expect_error(nestTupleRanges(flat, "not a collection"), "RangedTupleList") - expect_error(nestTupleRanges("not ranges", mc), "GRanges") -}) - -test_that("a TupleRangesView is a GenomicRanges and subsets to itself", { - data(qtlSumStatsMulticontextExample, envir = environment()) - flat <- flattenTupleRanges(qtlSumStatsMulticontextExample) - v <- .tupleRangesView(flat) - expect_s4_class(v, "TupleRangesView") - # Being a GenomicRanges is what makes plyranges dispatch at all. - expect_true(is(v, "GenomicRanges")) - expect_equal(length(v), length(flat)) - expect_s4_class(v[1:10], "TupleRangesView") - expect_equal(length(v[1:10]), 10L) -}) - -test_that("the view constructor keeps mcols parallel to the object", { - # DelegatingGenomicRanges carries its own elementMetadata; leaving it - # zero-row makes the class reject itself with "'mcols(x)' is not parallel - # to 'x'". - data(qtlSumStatsMulticontextExample, envir = environment()) - flat <- flattenTupleRanges(qtlSumStatsMulticontextExample) - expect_silent(v <- .tupleRangesView(flat)) - expect_true(validObject(v)) -}) - -test_that("the view rejects a two-argument subscript", { - data(qtlSumStatsMulticontextExample, envir = environment()) - v <- .tupleRangesView(flattenTupleRanges(qtlSumStatsMulticontextExample)) - expect_error(v[1, 1], "two-argument") -}) - - -# --------------------------------------------------------------------------- -# plyranges / dplyr verbs. -# -# These call the methods directly rather than through the generic: dispatch -# needs the S3method() entries a roxygen regen writes, and the logic under test -# is the same either way. The final test checks dispatch itself, and skips -# until the registration exists. -# --------------------------------------------------------------------------- - -# @noRd -.trv_mc <- function() { - data(qtlSumStatsMulticontextExample, envir = environment()) - qtlSumStatsMulticontextExample -} - -test_that("filter keeps the collection and narrows its elements", { - mc <- .trv_mc() - out <- filter.RangedTupleList(mc, Z > 2) - expect_s4_class(out, "QtlSumStats") - expect_equal(nrow(out), nrow(mc)) - expect_lt(sum(lengths(out)), sum(lengths(mc))) - expect_identical(getLdSketch(out), getLdSketch(mc)) -}) - -test_that("filter can mix identity and per-range columns", { - # The whole point of broadcasting the tuple: one predicate spanning both. - mc <- .trv_mc() - out <- filter.RangedTupleList(mc, .context == "blood" & Z > 1) - idx <- which(mc$context == "blood") - expect_gt(lengths(out)[[idx]], 0L) - expect_equal(sum(lengths(out)[-idx]), 0L) -}) - -test_that("mutate adds a per-range column without changing the shape", { - mc <- .trv_mc() - out <- mutate.RangedTupleList(mc, hit = Z > 2) - expect_equal(lengths(out), lengths(mc)) - expect_true(is_in("hit", colnames(mcols(out[[1]])))) -}) - -test_that("select keeps the identity columns it needs to nest", { - # Dropping them would leave the ranges with no tuple, and every one would - # fall into the first element. - mc <- .trv_mc() - out <- select.RangedTupleList(mc, Z) - expect_equal(lengths(out), lengths(mc)) -}) - -test_that("slice takes n ranges from EACH element", { - # Slicing the flattened set would take n in total and empty all but the - # first element. - mc <- .trv_mc() - out <- slice.RangedTupleList(mc, 1:5) - expect_equal(unname(lengths(out)), rep(5L, nrow(mc))) -}) - -test_that("arrange orders within each element", { - mc <- .trv_mc() - out <- arrange.RangedTupleList(mc, Z) - expect_equal(lengths(out), lengths(mc)) - for (i in seq_len(nrow(out))) { - expect_false(is.unsorted(mcols(out[[i]])$Z)) - } -}) - -test_that("summarise reduces to a table rather than a collection", { - mc <- .trv_mc() - out <- summarise.RangedTupleList(mc, n = plyranges::n()) - expect_false(is(out, "RangedTupleList")) - expect_equal(NROW(out), 1L) -}) - -test_that("group_by returns plyranges' own grouped representation", { - mc <- .trv_mc() - out <- group_by.RangedTupleList(mc, .context) - expect_s4_class(out, "GroupedGenomicRanges") - expect_equal(length(out), sum(lengths(mc))) -}) - -test_that("select and group_by work on the view itself", { - # plyranges' own DelegatingGenomicRanges support misses both: they work on - # a plain GRanges and fail on any delegating class. These patch that. - mc <- .trv_mc() - v <- .tupleRangesView(flattenTupleRanges(mc)) - expect_s4_class(select.TupleRangesView(v, Z), "TupleRangesView") - expect_s4_class( - group_by.TupleRangesView(v, .context), - "GroupedGenomicRanges" - ) -}) - -test_that("the verbs are reachable through the dplyr generics", { - # Needs the S3method() entries from a roxygen regen; skips until then. - # Probed by attempting dispatch rather than by looking the function up: - # getS3method() finds it in the namespace whether or not it is registered. - mc <- .trv_mc() - dispatches <- tryCatch( - { - dplyr::filter(mc, Z > 2) - TRUE - }, - error = function(e) FALSE - ) - skip_if_not(dispatches, "S3 methods not yet registered (regen pending)") - expect_s4_class(dplyr::filter(mc, Z > 2), "QtlSumStats") - expect_s4_class(dplyr::slice(mc, 1:2), "QtlSumStats") -}) - -test_that("show reports the view's range and metadata-column counts", { - # The view is internal, but its show method is what a developer sees when - # one surfaces in a browser() or an error trace. - data(qtlSumStatsMulticontextExample, envir = environment()) - flat <- flattenTupleRanges(qtlSumStatsMulticontextExample) - v <- .tupleRangesView(flat) - expect_output(show(v), "TupleRangesView:") - expect_output(show(v), str_c(length(flat), " ranges")) - expect_output(show(v), "metadata column\\(s\\)") -}) - -# =========================================================================== -# Degenerate collections and the plyranges requirement -# =========================================================================== - -test_that("flattening a collection with no identity columns keeps its ranges", { - # With nothing to key on, every range belongs to the single element -- - # which is what a one-row collection means. - mc <- .trv_mc() - bare <- mc[1, ] - mcols(bare) <- mcols(bare)[, character(0), drop = FALSE] - flat <- flattenTupleRanges(bare) - expect_equal(length(flat), sum(lengths(bare))) -}) - -test_that(".rtlTupleKeys gives every row the same key with no key columns", { - md <- S4Vectors::DataFrame(entry = S4Vectors::SimpleList(1, 2)) - expect_equal(.rtlTupleKeys(md, character(0), 3L), rep("", 3L)) -}) - -test_that(".rtlTupleKeyCols is empty when there are no mcols", { - gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 2)) - expect_equal(.rtlTupleKeyCols(gr), character(0)) -}) - -test_that(".rtlAsRanges unwraps a view and passes a GRanges through", { - flat <- flattenTupleRanges(.trv_mc()) - v <- .tupleRangesView(flat) - expect_s4_class(.rtlAsRanges(v), "GRanges") - expect_false(methods::is(.rtlAsRanges(v), "TupleRangesView")) - expect_identical(.rtlAsRanges(flat), flat) -}) - -test_that("select(.drop_ranges = TRUE) returns the bare table, not a view", { - # plyranges' own escape hatch: the caller asked for a data frame rather - # than ranges, so re-wrapping it as a view would undo the request. - flat <- flattenTupleRanges(.trv_mc()) - v <- .tupleRangesView(flat) - out <- select.TupleRangesView(v, Z, .drop_ranges = TRUE) - expect_false(methods::is(out, "TupleRangesView")) - expect_false(methods::is(out, "GRanges")) -}) diff --git a/tests/testthat/test_ctwasPipeline.R b/tests/testthat/test_ctwasPipeline.R index e7d4ebff..27daa80b 100644 --- a/tests/testthat/test_ctwasPipeline.R +++ b/tests/testthat/test_ctwasPipeline.R @@ -1642,7 +1642,7 @@ test_that("ctwasPipeline: dispatches assemble → est → screen → finemap and expect_equal(as.character(out$gwasStudy), "G1") # The run's jointly-estimated param is carried on the row. expect_equal( - unname(getCtwasParam(pecotmr:::.collectionEntry(out, 1L))$group_prior), + unname(getCtwasParam(out$entry[[1L]])$group_prior), c(0.1, 0.0001) ) # getFinemap aggregates the per-gene rows, tagged with run identity. @@ -2147,7 +2147,7 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", data(qtlDatasetExample) gss <- gwasSumStatsS4Example qd <- qtlDatasetExample - gh <- qd@genotypes + gh <- getGenotypeHandle(qd) # Two 5-variant synthetic genes from the bundled panel, one anchored in # each LD block below. cTWAS's EM runs per region and cannot fit a block @@ -2353,7 +2353,7 @@ test_that(".ctwasFilterVariants: returns NULL when no variants survive", { test_that(".ctwasBuildWeights: maxNumVariants caps the per-gene weight matrix", { data(qtlDatasetExample) qd <- qtlDatasetExample - gh <- qd@genotypes + gh <- getGenotypeHandle(qd) vids <- getSnpInfo(gh)$SNP[1:5] ent <- twasWeightsRow( variantIds = vids, @@ -2378,7 +2378,7 @@ test_that(".ctwasBuildWeights: maxNumVariants caps the per-gene weight matrix", test_that(".ctwasBuildWeights: twasWeightCutoff drops low-magnitude variants", { data(qtlDatasetExample) qd <- qtlDatasetExample - gh <- qd@genotypes + gh <- getGenotypeHandle(qd) vids <- getSnpInfo(gh)$SNP[1:5] ent <- twasWeightsRow( variantIds = vids, diff --git a/tests/testthat/test_fineMappingWrappers.R b/tests/testthat/test_fineMappingWrappers.R index 7131a23d..33be971e 100644 --- a/tests/testthat/test_fineMappingWrappers.R +++ b/tests/testthat/test_fineMappingWrappers.R @@ -3216,3 +3216,225 @@ test_that(".fmEffectIndices parses L-names and falls back to position", { expect_equal(.fmEffectIndices(list(L1 = 1, L2 = 2, L7 = 3)), c(1L, 2L, 7L)) expect_equal(.fmEffectIndices(list(1, 2, 3)), c(1L, 2L, 3L)) }) + + +context("post_finemapping_cs_extraction") + +# A single-row QtlFineMappingResult standing in for the retired +# FineMappingRow. topLoci defaults to one row per variant: the row-payload +# builder requires the two to be aligned, where the entry tolerated an empty +# table beside a non-empty variant list. +.testFineMappingRow <- function( + variantIds, + susieFit = list(), + topLoci = NULL +) { + if (is.null(topLoci)) { + topLoci <- data.frame( + variant_id = variantIds, + pip = rep(0, length(variantIds)), + stringsAsFactors = FALSE + ) + } + QtlFineMappingResult( + study = "s1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(fineMappingRow( + variantIds = variantIds, + susieFit = susieFit, + topLoci = topLoci + )) + ) +} + +# =========================================================================== +# getSusieResult +# =========================================================================== + +test_that("getSusieResult returns NULL for empty input", { + result <- getSusieResult(list()) + expect_null(result) +}) + +test_that("getSusieResult returns NULL when finemappingEntry missing", { + result <- getSusieResult(list(some_data = 42)) + expect_null(result) +}) + +test_that("getSusieResult returns trimmed result when present", { + mock_result <- list(pip = c(0.1, 0.5, 0.3), sets = list(cs = list())) + con_data <- list( + finemappingEntry = .testFineMappingRow( + variantIds = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), + susieFit = mock_result + ) + ) + result <- getSusieResult(con_data) + expect_equal(result, mock_result) +}) + +# =========================================================================== +# extractTopPipInfo +# =========================================================================== + +test_that("extractTopPipInfo finds top PIP variant", { + con_data <- list( + finemappingEntry = .testFineMappingRow( + variantIds = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), + susieFit = list(pip = c(0.1, 0.7, 0.2)) + ), + sumstats = list(z = c(1.0, 3.5, -0.5)) + ) + result <- extractTopPipInfo(con_data$finemappingEntry, con_data$sumstats) + expect_equal(result$top_variant, "chr1:200:C:T") + expect_equal(result$top_pip, 0.7) + expect_equal(result$top_z, 3.5) + expect_equal(result$top_variant_index, 2) + expect_true(is.na(result$cs_name)) + expect_true(is.na(result$variants_per_cs)) +}) + +test_that("extractTopPipInfo computes p_value from z", { + con_data <- list( + finemappingEntry = .testFineMappingRow( + variantIds = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), + susieFit = list(pip = c(0.9, 0.05, 0.05)) + ), + sumstats = list(z = c(5.0, 0.5, -0.3)) + ) + result <- extractTopPipInfo(con_data$finemappingEntry, con_data$sumstats) + expected_pval <- pecotmr:::.zToPvalue(5.0) + expect_equal(result$p_value, expected_pval) +}) + +test_that("extractTopPipInfo handles ties by taking first max", { + con_data <- list( + finemappingEntry = .testFineMappingRow( + variantIds = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), + susieFit = list(pip = c(0.5, 0.5, 0.5)) + ), + sumstats = list(z = c(1.0, 2.0, 3.0)) + ) + result <- extractTopPipInfo(con_data$finemappingEntry, con_data$sumstats) + expect_equal(result$top_variant_index, 1) + expect_equal(result$top_pip, 0.5) +}) + +# =========================================================================== +# extractCsInfo +# =========================================================================== + +test_that("extractCsInfo extracts single CS correctly", { + data(qtlSumStatsExample) + fe <- .testFineMappingRow( + variantIds = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), + susieFit = list(sets = list(cs = list(L_1 = c(1, 2)))) + ) + top_loci_table <- data.frame( + variant_id = c("chr1:100:A:G", "chr1:200:C:T"), + pip = c(0.3, 0.8), + z = c(2.0, 4.5), + stringsAsFactors = FALSE + ) + # A single CS short-circuits (no between-CS correlation), so the unrelated + # ldSource is not consulted. + result <- extractCsInfo( + fe, + csNames = "L_1", + topLociTable = top_loci_table, + ldSource = qtlSumStatsExample + ) + expect_equal(nrow(result), 1) + expect_equal(result$cs_name, "L_1") + expect_equal(result$top_variant, "chr1:200:C:T") + expect_equal(result$top_pip, 0.8) + expect_equal(result$variants_per_cs, 2) + expect_true(is.na(result$cs_corr_max)) + expect_true(is.na(result$cs_corr_min)) + expect_false("cs_corr_1" %in% colnames(result)) +}) + +test_that("extractCsInfo builds correlation columns from the ldSource", { + data(qtlSumStatsExample) + ss <- qtlSumStatsExample + vids <- rownames(getLdSketch(ss)) + set.seed(1) + fit <- list( + sets = list(cs = list(L_1 = c(1L, 2L, 3L), L_2 = c(90L, 91L))), + pip = runif(length(vids)) + ) + tl <- data.frame( + variant_id = vids, + pip = fit$pip, + z = rnorm(length(vids)), + stringsAsFactors = FALSE + ) + fe <- .testFineMappingRow( + variantIds = vids, + susieFit = fit, + topLoci = tl + ) + result <- extractCsInfo( + fe, + csNames = c("L_1", "L_2"), + topLociTable = tl, + ldSource = ss + ) + expect_equal(nrow(result), 2) + expect_true(all( + c("cs_corr_1", "cs_corr_2", "cs_corr_max", "cs_corr_min") %in% + colnames(result) + )) + # The cs_corr_j columns are the columns of the computed between-CS matrix + # (symmetric; diagonal == 1), reduced on demand from the ldSource. + cc <- computeCsCorrelation(fe, ss) + expect_equal(result$cs_corr_1, unname(cc[, 1])) + expect_equal(result$cs_corr_2, unname(cc[, 2])) + expect_equal(result$cs_corr_max, rep(abs(cc[1, 2]), 2)) + expect_equal(result$cs_corr_min, rep(abs(cc[1, 2]), 2)) +}) + +test_that("extractCsInfo computes p_value from z-score", { + data(qtlSumStatsExample) + fe <- .testFineMappingRow( + variantIds = c("chr1:100:A:G", "chr1:200:C:T"), + susieFit = list(sets = list(cs = list(L_1 = c(1, 2)))) + ) + top_loci_table <- data.frame( + variant_id = c("chr1:100:A:G", "chr1:200:C:T"), + pip = c(0.9, 0.1), + z = c(5.0, 0.5), + stringsAsFactors = FALSE + ) + result <- extractCsInfo( + fe, + csNames = "L_1", + topLociTable = top_loci_table, + ldSource = qtlSumStatsExample + ) + expected_pval <- pecotmr:::.zToPvalue(5.0) + expect_equal(result$p_value, expected_pval, tolerance = 1e-10) +}) + +# =========================================================================== +# getSusieResult: trimmed fit is empty +# =========================================================================== + +test_that("getSusieResult returns NULL when the trimmed susie fit is empty", { + conData <- list( + # An empty fit with variants present: topLoci must still be aligned + # row-for-row, which the entry did not enforce. + finemappingEntry = fineMappingRow( + variantIds = c("chr1:100:A:G", "chr1:200:C:T"), + susieFit = list(), + topLoci = data.frame( + variant_id = c("chr1:100:A:G", "chr1:200:C:T"), + pip = c(0, 0), + stringsAsFactors = FALSE + ) + ) + ) + expect_null(getSusieResult(conData)) +}) diff --git a/tests/testthat/test_ld.R b/tests/testthat/test_ld.R index cf059f71..376aeb48 100644 --- a/tests/testthat/test_ld.R +++ b/tests/testthat/test_ld.R @@ -4463,14 +4463,14 @@ test_that(".panelVariantStats reports NA MAF for an all-missing variant", { test_that(".panelVariantFilter is a no-op at its defaults", { data(qtlDatasetExample) gh <- getGenotypes(qtlDatasetExample) - handle <- qtlDatasetExample@genotypes + handle <- getGenotypeHandle(qtlDatasetExample) ids <- normalizeVariantId(getSnpInfo(handle)$SNP) expect_identical(.panelVariantFilter(handle, ids), ids) }) test_that(".panelVariantFilter drops panel-rare variants", { data(qtlDatasetExample) - handle <- qtlDatasetExample@genotypes + handle <- getGenotypeHandle(qtlDatasetExample) ids <- normalizeVariantId(getSnpInfo(handle)$SNP) loose <- .panelVariantFilter(handle, ids, mafCutoff = 0.05) tight <- .panelVariantFilter(handle, ids, mafCutoff = 0.2) @@ -4483,7 +4483,7 @@ test_that(".panelVariantFilter drops panel-rare variants", { test_that(".panelVariantFilter treats MAC as a MAF equivalent", { data(qtlDatasetExample) - handle <- qtlDatasetExample@genotypes + handle <- getGenotypeHandle(qtlDatasetExample) ids <- normalizeVariantId(getSnpInfo(handle)$SNP) nSamp <- getNSamples(handle) # macCutoff / (2 * nSamples) is the same threshold as mafCutoff. @@ -4499,7 +4499,7 @@ test_that(".panelVariantFilter treats MAC as a MAF equivalent", { test_that(".panelVariantFilter drops high-missingness variants", { data(qtlDatasetExample) - handle <- qtlDatasetExample@genotypes + handle <- getGenotypeHandle(qtlDatasetExample) ids <- normalizeVariantId(getSnpInfo(handle)$SNP) strict <- .panelVariantFilter(handle, ids, imissCutoff = 0) expect_lt(length(strict), length(ids)) @@ -4512,7 +4512,7 @@ test_that(".panelVariantFilter passes through ids absent from the panel", { # .ldFromSketch's `onMissing`; deciding it here too would let the two # disagree about the same variant. data(qtlDatasetExample) - handle <- qtlDatasetExample@genotypes + handle <- getGenotypeHandle(qtlDatasetExample) ids <- normalizeVariantId(getSnpInfo(handle)$SNP)[1:3] withGhost <- c("chr9:999:A:G", ids) expect_true(is_in( @@ -4523,7 +4523,7 @@ test_that(".panelVariantFilter passes through ids absent from the panel", { test_that(".panelVariantFilter handles empty and NULL input", { data(qtlDatasetExample) - handle <- qtlDatasetExample@genotypes + handle <- getGenotypeHandle(qtlDatasetExample) expect_length( .panelVariantFilter(handle, character(0), mafCutoff = 0.1), 0L diff --git a/tests/testthat/test_sumstatsQc.R b/tests/testthat/test_sumstatsQc.R index 85f5bea0..f06345e1 100644 --- a/tests/testthat/test_sumstatsQc.R +++ b/tests/testthat/test_sumstatsQc.R @@ -5672,204 +5672,6 @@ test_that("sliding_window_loop errors on infinite loop", { context("univariate_rss_diagnostics") -# A single-row QtlFineMappingResult standing in for the retired -# FineMappingRow. topLoci defaults to one row per variant: the row-payload -# builder requires the two to be aligned, where the entry tolerated an empty -# table beside a non-empty variant list. -.testFineMappingRow <- function( - variantIds, - susieFit = list(), - topLoci = NULL -) { - if (is.null(topLoci)) { - topLoci <- data.frame( - variant_id = variantIds, - pip = rep(0, length(variantIds)), - stringsAsFactors = FALSE - ) - } - QtlFineMappingResult( - study = "s1", - context = "c1", - trait = "t1", - method = "susie", - entry = list(fineMappingRow( - variantIds = variantIds, - susieFit = susieFit, - topLoci = topLoci - )) - ) -} - -# =========================================================================== -# getSusieResult -# =========================================================================== - -test_that("getSusieResult returns NULL for empty input", { - result <- getSusieResult(list()) - expect_null(result) -}) - -test_that("getSusieResult returns NULL when finemappingEntry missing", { - result <- getSusieResult(list(some_data = 42)) - expect_null(result) -}) - -test_that("getSusieResult returns trimmed result when present", { - mock_result <- list(pip = c(0.1, 0.5, 0.3), sets = list(cs = list())) - con_data <- list( - finemappingEntry = .testFineMappingRow( - variantIds = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), - susieFit = mock_result - ) - ) - result <- getSusieResult(con_data) - expect_equal(result, mock_result) -}) - -# =========================================================================== -# extractTopPipInfo -# =========================================================================== - -test_that("extractTopPipInfo finds top PIP variant", { - con_data <- list( - finemappingEntry = .testFineMappingRow( - variantIds = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), - susieFit = list(pip = c(0.1, 0.7, 0.2)) - ), - sumstats = list(z = c(1.0, 3.5, -0.5)) - ) - result <- extractTopPipInfo(con_data$finemappingEntry, con_data$sumstats) - expect_equal(result$top_variant, "chr1:200:C:T") - expect_equal(result$top_pip, 0.7) - expect_equal(result$top_z, 3.5) - expect_equal(result$top_variant_index, 2) - expect_true(is.na(result$cs_name)) - expect_true(is.na(result$variants_per_cs)) -}) - -test_that("extractTopPipInfo computes p_value from z", { - con_data <- list( - finemappingEntry = .testFineMappingRow( - variantIds = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), - susieFit = list(pip = c(0.9, 0.05, 0.05)) - ), - sumstats = list(z = c(5.0, 0.5, -0.3)) - ) - result <- extractTopPipInfo(con_data$finemappingEntry, con_data$sumstats) - expected_pval <- pecotmr:::.zToPvalue(5.0) - expect_equal(result$p_value, expected_pval) -}) - -test_that("extractTopPipInfo handles ties by taking first max", { - con_data <- list( - finemappingEntry = .testFineMappingRow( - variantIds = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), - susieFit = list(pip = c(0.5, 0.5, 0.5)) - ), - sumstats = list(z = c(1.0, 2.0, 3.0)) - ) - result <- extractTopPipInfo(con_data$finemappingEntry, con_data$sumstats) - expect_equal(result$top_variant_index, 1) - expect_equal(result$top_pip, 0.5) -}) - -# =========================================================================== -# extractCsInfo -# =========================================================================== - -test_that("extractCsInfo extracts single CS correctly", { - data(qtlSumStatsExample) - fe <- .testFineMappingRow( - variantIds = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), - susieFit = list(sets = list(cs = list(L_1 = c(1, 2)))) - ) - top_loci_table <- data.frame( - variant_id = c("chr1:100:A:G", "chr1:200:C:T"), - pip = c(0.3, 0.8), - z = c(2.0, 4.5), - stringsAsFactors = FALSE - ) - # A single CS short-circuits (no between-CS correlation), so the unrelated - # ldSource is not consulted. - result <- extractCsInfo( - fe, - csNames = "L_1", - topLociTable = top_loci_table, - ldSource = qtlSumStatsExample - ) - expect_equal(nrow(result), 1) - expect_equal(result$cs_name, "L_1") - expect_equal(result$top_variant, "chr1:200:C:T") - expect_equal(result$top_pip, 0.8) - expect_equal(result$variants_per_cs, 2) - expect_true(is.na(result$cs_corr_max)) - expect_true(is.na(result$cs_corr_min)) - expect_false("cs_corr_1" %in% colnames(result)) -}) - -test_that("extractCsInfo builds correlation columns from the ldSource", { - data(qtlSumStatsExample) - ss <- qtlSumStatsExample - vids <- rownames(getLdSketch(ss)) - set.seed(1) - fit <- list( - sets = list(cs = list(L_1 = c(1L, 2L, 3L), L_2 = c(90L, 91L))), - pip = runif(length(vids)) - ) - tl <- data.frame( - variant_id = vids, - pip = fit$pip, - z = rnorm(length(vids)), - stringsAsFactors = FALSE - ) - fe <- .testFineMappingRow( - variantIds = vids, - susieFit = fit, - topLoci = tl - ) - result <- extractCsInfo( - fe, - csNames = c("L_1", "L_2"), - topLociTable = tl, - ldSource = ss - ) - expect_equal(nrow(result), 2) - expect_true(all( - c("cs_corr_1", "cs_corr_2", "cs_corr_max", "cs_corr_min") %in% - colnames(result) - )) - # The cs_corr_j columns are the columns of the computed between-CS matrix - # (symmetric; diagonal == 1), reduced on demand from the ldSource. - cc <- computeCsCorrelation(fe, ss) - expect_equal(result$cs_corr_1, unname(cc[, 1])) - expect_equal(result$cs_corr_2, unname(cc[, 2])) - expect_equal(result$cs_corr_max, rep(abs(cc[1, 2]), 2)) - expect_equal(result$cs_corr_min, rep(abs(cc[1, 2]), 2)) -}) - -test_that("extractCsInfo computes p_value from z-score", { - data(qtlSumStatsExample) - fe <- .testFineMappingRow( - variantIds = c("chr1:100:A:G", "chr1:200:C:T"), - susieFit = list(sets = list(cs = list(L_1 = c(1, 2)))) - ) - top_loci_table <- data.frame( - variant_id = c("chr1:100:A:G", "chr1:200:C:T"), - pip = c(0.9, 0.1), - z = c(5.0, 0.5), - stringsAsFactors = FALSE - ) - result <- extractCsInfo( - fe, - csNames = "L_1", - topLociTable = top_loci_table, - ldSource = qtlSumStatsExample - ) - expected_pval <- pecotmr:::.zToPvalue(5.0) - expect_equal(result$p_value, expected_pval, tolerance = 1e-10) -}) - # =========================================================================== # autoDecision # =========================================================================== @@ -6307,27 +6109,6 @@ test_that("slalom coerces a non-matrix X (data.frame) to a matrix", { expect_equal(nrow(result$data), n_snps) }) -# =========================================================================== -# getSusieResult: trimmed fit is empty -# =========================================================================== - -test_that("getSusieResult returns NULL when the trimmed susie fit is empty", { - conData <- list( - # An empty fit with variants present: topLoci must still be aligned - # row-for-row, which the entry did not enforce. - finemappingEntry = fineMappingRow( - variantIds = c("chr1:100:A:G", "chr1:200:C:T"), - susieFit = list(), - topLoci = data.frame( - variant_id = c("chr1:100:A:G", "chr1:200:C:T"), - pip = c(0, 0), - stringsAsFactors = FALSE - ) - ) - ) - expect_null(getSusieResult(conData)) -}) - # =========================================================================== # autoDecision: high-correlation tagging branch is reached # =========================================================================== diff --git a/tests/testthat/test_tupleSelectors.R b/tests/testthat/test_tupleSelectors.R index 4a46435a..2ab70715 100644 --- a/tests/testthat/test_tupleSelectors.R +++ b/tests/testthat/test_tupleSelectors.R @@ -1,20 +1,38 @@ context("tupleSelectors (internal row-selector helpers)") -# These helpers (.matchTupleRows, .tupleSelectRow, .tupleSelectRowGwasFmr) -# work on anything with `nrow(x)` and `x[[col]]` semantics, so the tests -# below use plain base-R data.frames rather than building S4 collections. +# These helpers read identity columns off `mcols(x)`, so the tests below use +# a real collection rather than a plain data.frame. `.ts_coll()` builds the +# smallest one that exercises them: one empty GRanges per row, identity +# columns in mcols, no payload class. + +setClass("TsTestCollection", contains = "RangedTupleList") + +.ts_coll <- function(..., stringsAsFactors = FALSE) { + cols <- list(...) + n <- if (length(cols) == 0L) 0L else length(cols[[1L]]) + grl <- GenomicRanges::GRangesList( + rep(list(GenomicRanges::GRanges()), n) + ) + if (length(cols) > 0L) { + S4Vectors::mcols(grl) <- do.call( + S4Vectors::DataFrame, + c(cols, list(check.names = FALSE)) + ) + } + methods::new("TsTestCollection", grl) +} # =========================================================================== # .matchTupleRows # =========================================================================== test_that(".matchTupleRows: empty keys returns every row index", { - df <- data.frame(study = c("s1", "s2"), method = c("susie", "lasso")) + df <- .ts_coll(study = c("s1", "s2"), method = c("susie", "lasso")) expect_equal(pecotmr:::.matchTupleRows(df, list()), c(1L, 2L)) }) test_that(".matchTupleRows: AND-matches across multiple (column, value) pairs", { - df <- data.frame( + df <- .ts_coll( study = c("s1", "s1", "s2"), context = c("c1", "c2", "c1"), stringsAsFactors = FALSE @@ -35,7 +53,7 @@ test_that(".matchTupleRows: AND-matches across multiple (column, value) pairs", # =========================================================================== test_that(".tupleSelectRow: zero-row input errors with the class label", { - empty <- data.frame( + empty <- .ts_coll( study = character(0), context = character(0), trait = character(0), @@ -56,7 +74,7 @@ test_that(".tupleSelectRow: zero-row input errors with the class label", { }) test_that(".tupleSelectRow: single-row collection returns 1L without selectors", { - one <- data.frame( + one <- .ts_coll( study = "s1", context = "c1", trait = "t1", @@ -67,7 +85,7 @@ test_that(".tupleSelectRow: single-row collection returns 1L without selectors", }) test_that(".tupleSelectRow: multi-row + missing selectors errors with row count", { - multi <- data.frame( + multi <- .ts_coll( study = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), @@ -81,7 +99,7 @@ test_that(".tupleSelectRow: multi-row + missing selectors errors with row count" }) test_that(".tupleSelectRow: non-scalar selectors error", { - multi <- data.frame( + multi <- .ts_coll( study = c("s1", "s2"), context = c("c1", "c2"), trait = c("t1", "t2"), @@ -101,7 +119,7 @@ test_that(".tupleSelectRow: non-scalar selectors error", { }) test_that(".tupleSelectRow: matching tuple returns first row index", { - multi <- data.frame( + multi <- .ts_coll( study = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), @@ -121,7 +139,7 @@ test_that(".tupleSelectRow: matching tuple returns first row index", { }) test_that(".tupleSelectRow: missing tuple errors with the 4-tuple in the message", { - multi <- data.frame( + multi <- .ts_coll( study = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), @@ -145,7 +163,7 @@ test_that(".tupleSelectRow: missing tuple errors with the 4-tuple in the message # =========================================================================== test_that(".tupleSelectRowGwasFmr: zero-row input errors", { - empty <- data.frame( + empty <- .ts_coll( study = character(0), method = character(0), blockId = character(0), @@ -158,7 +176,7 @@ test_that(".tupleSelectRowGwasFmr: zero-row input errors", { }) test_that(".tupleSelectRowGwasFmr: single-row collection returns 1L", { - one <- data.frame( + one <- .ts_coll( study = "g1", method = "susie", blockId = "region_1", @@ -168,7 +186,7 @@ test_that(".tupleSelectRowGwasFmr: single-row collection returns 1L", { }) test_that(".tupleSelectRowGwasFmr: missing selectors on multi-row errors", { - multi <- data.frame( + multi <- .ts_coll( study = c("g1", "g2"), method = c("susie", "susie"), blockId = c("region_1", "region_1"), @@ -181,7 +199,7 @@ test_that(".tupleSelectRowGwasFmr: missing selectors on multi-row errors", { }) test_that(".tupleSelectRowGwasFmr: non-scalar region errors", { - multi <- data.frame( + multi <- .ts_coll( study = c("g1", "g1"), method = c("susie", "susie"), blockId = c("r1", "r2"), @@ -200,7 +218,7 @@ test_that(".tupleSelectRowGwasFmr: non-scalar region errors", { test_that(".tupleSelectRowGwasFmr: region disambiguates per-block rows", { # Same (study, method) across two regions; region picks the right row. - multi <- data.frame( + multi <- .ts_coll( study = c("g1", "g1"), method = c("susie", "susie"), blockId = c("chr22_1_100", "chr22_500_600"), @@ -218,7 +236,7 @@ test_that(".tupleSelectRowGwasFmr: region disambiguates per-block rows", { }) test_that(".tupleSelectRowGwasFmr: missing tuple errors and includes region in message", { - one <- data.frame( + one <- .ts_coll( study = "g1", method = "susie", blockId = "r1", @@ -238,7 +256,7 @@ test_that(".tupleSelectRowGwasFmr: missing tuple errors and includes region in m test_that(".tupleSelectRowGwasFmr: ambiguous multi-match (no region) lists candidates", { # Two rows share (study, method); .tupleSelectRowGwasFmr should error # listing the available blockIds since the caller didn't disambiguate. - multi <- data.frame( + multi <- .ts_coll( study = c("g1", "g1"), method = c("susie", "susie"), blockId = c("region_A", "region_B"), @@ -255,7 +273,7 @@ test_that(".tupleSelectRowGwasFmr: ambiguous multi-match (no region) lists candi # =========================================================================== test_that(".fmrRowsMatching: no selectors returns every row", { - df <- data.frame( + df <- .ts_coll( study = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), @@ -266,7 +284,7 @@ test_that(".fmrRowsMatching: no selectors returns every row", { }) test_that(".fmrRowsMatching: matches a subset without erroring on ambiguity", { - df <- data.frame( + df <- .ts_coll( study = c("s1", "s1", "s2"), context = c("c1", "c2", "c1"), trait = c("t1", "t1", "t1"), @@ -280,7 +298,7 @@ test_that(".fmrRowsMatching: matches a subset without erroring on ambiguity", { test_that(".fmrRowsMatching: selectors on absent columns are ignored", { # GWAS-shaped frame has no context/trait column; passing context must not # error and must not constrain the result. - gwas <- data.frame( + gwas <- .ts_coll( study = c("g1", "g1"), method = c("susie", "susie"), blockId = c("r1", "r2"), @@ -290,7 +308,7 @@ test_that(".fmrRowsMatching: selectors on absent columns are ignored", { }) test_that(".fmrRowsMatching: `region` matches the blockId column", { - gwas <- data.frame( + gwas <- .ts_coll( study = c("g1", "g1"), method = c("susie", "susie"), blockId = c("r1", "r2"), @@ -300,7 +318,7 @@ test_that(".fmrRowsMatching: `region` matches the blockId column", { }) test_that(".fmrRowsMatching: a vector selector matches any listed value", { - df <- data.frame( + df <- .ts_coll( study = c("s1", "s2", "s3"), context = c("c1", "c2", "c3"), trait = c("t1", "t1", "t1"), @@ -318,7 +336,7 @@ test_that(".fmrRowsMatching: a vector selector matches any listed value", { # =========================================================================== test_that(".fmrRowMetadata: emits all five identity columns, NA-filling absent ones", { - qtl <- data.frame( + qtl <- .ts_coll( study = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), @@ -335,7 +353,7 @@ test_that(".fmrRowMetadata: emits all five identity columns, NA-filling absent o }) test_that(".fmrRowMetadata: GWAS frame NA-fills context/trait, keeps blockId", { - gwas <- data.frame( + gwas <- .ts_coll( study = c("g1", "g1"), method = c("susie", "susie"), blockId = c("r1", "r2"), @@ -348,7 +366,7 @@ test_that(".fmrRowMetadata: GWAS frame NA-fills context/trait, keeps blockId", { }) test_that(".fmrRowMetadata: zero-row input yields a zero-row 5-column frame", { - empty <- data.frame( + empty <- .ts_coll( study = character(0), method = character(0), blockId = character(0), @@ -401,8 +419,8 @@ test_that(".rbindCollections: all-NULL input returns NULL", { expect_null(pecotmr:::.rbindCollections(list(NULL, NULL))) }) -test_that(".getRegionColumn: an absent region column yields an empty GRanges", { - gr <- pecotmr:::.getRegionColumn(S4Vectors::DataFrame(a = 1:2)) +test_that(".getRegionColumn: a zero-row collection yields an empty GRanges", { + gr <- pecotmr:::.getRegionColumn(.ts_coll(study = character(0))) expect_s4_class(gr, "GRanges") expect_length(gr, 0L) }) @@ -453,13 +471,14 @@ 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(S4Vectors::DataFrame( - traitPos = c("x", "y") - )), + pecotmr:::.validateTraitPosColumn(.ts_coll(traitPos = c("x", "y"))), "'traitPos' column must be a GRanges" ) - bad <- S4Vectors::DataFrame(a = 1:2) - bad@listData$traitPos <- GenomicRanges::GRanges( + # A one-range traitPos beside two rows: assigned through the mcols + # listData because the parallel-length check would reject it otherwise, + # which is exactly the state the validator has to catch. + bad <- .ts_coll(a = 1:2) + S4Vectors::mcols(bad)@listData$traitPos <- GenomicRanges::GRanges( "chr1", IRanges::IRanges(1, 1) ) @@ -468,7 +487,7 @@ test_that(".validateTraitPosColumn: reports non-GRanges and wrong-length traitPo "'traitPos' column must have one range per row" ) expect_length( - pecotmr:::.validateTraitPosColumn(S4Vectors::DataFrame(a = 1L)), + pecotmr:::.validateTraitPosColumn(.ts_coll(a = 1L)), 0L ) })