DelayedArray/DESCRIPTION0000644000175400017540000000265313177207140015664 0ustar00biocbuildbiocbuildPackage: DelayedArray Title: Delayed operations on array-like objects Description: Wrapping an array-like object (typically an on-disk object) in a DelayedArray object allows one to perform common array operations on it without loading the object in memory. In order to reduce memory usage and optimize performance, operations on the object are either delayed or executed using a block processing mechanism. Note that this also works on in-memory array-like objects like DataFrame objects (typically with Rle columns), Matrix objects, and ordinary arrays and data frames. Version: 0.4.1 Encoding: UTF-8 Author: Hervé Pagès Maintainer: Hervé Pagès biocViews: Infrastructure, DataRepresentation, Annotation, GenomeAnnotation Depends: R (>= 3.4), methods, matrixStats, BiocGenerics, S4Vectors (>= 0.15.3), IRanges (>= 2.11.17) Imports: stats Suggests: Matrix, HDF5Array, genefilter, SummarizedExperiment, airway, pryr, knitr, BiocStyle License: Artistic-2.0 VignetteBuilder: knitr Collate: utils.R bind-arrays.R Array-class.R ArrayGrid-class.R show-utils.R subset_seed_as_array.R ConformableSeedCombiner-class.R SeedBinder-class.R DelayedArray-class.R realize.R block_processing.R DelayedArray-utils.R DelayedMatrix-utils.R DelayedArray-stats.R DelayedMatrix-stats.R RleArray-class.R zzz.R NeedsCompilation: no Packaged: 2017-11-04 00:48:32 UTC; biocbuild DelayedArray/NAMESPACE0000644000175400017540000001012513176705261015374 0ustar00biocbuildbiocbuildimport(methods) importFrom(stats, setNames, dbinom, pbinom, qbinom, dpois, ppois, qpois, dlogis, plogis, qlogis) import(BiocGenerics) import(S4Vectors) import(IRanges) import(matrixStats) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S4 classes ### exportClasses( Array, ArrayViewport, ArrayGrid, ArrayArbitraryGrid, ArrayRegularGrid, DelayedArray, DelayedMatrix, RealizationSink, arrayRealizationSink, RleArraySeed, SolidRleArraySeed, RleRealizationSink, ChunkedRleArraySeed, RleArray, RleMatrix ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S3 methods ### S3method(as.array, DelayedArray) S3method(as.character, ArrayGrid) S3method(as.character, DelayedArray) S3method(as.complex, DelayedArray) S3method(as.data.frame, DelayedArray) S3method(as.integer, DelayedArray) S3method(as.logical, DelayedArray) S3method(as.matrix, DelayedArray) S3method(as.numeric, DelayedArray) S3method(as.raw, DelayedArray) S3method(as.vector, DelayedArray) S3method(mean, DelayedArray) S3method(split, DelayedArray) ### We also export them thru the export() directive so that (a) they can be ### called directly, (b) tab-completion on the name of the generic shows them, ### and (c) methods() doesn't asterisk them. export( as.array.DelayedArray, as.character.ArrayGrid, as.character.DelayedArray, as.complex.DelayedArray, as.data.frame.DelayedArray, as.integer.DelayedArray, as.logical.DelayedArray, as.matrix.DelayedArray, as.numeric.DelayedArray, as.raw.DelayedArray, as.vector.DelayedArray, mean.DelayedArray, split.DelayedArray ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S4 methods for generics not defined in DelayedArray ### exportMethods( ## Methods for generics defined in the base package: length, names, "names<-", dim, "dim<-", dimnames, "dimnames<-", "[", "[[", "[<-", lengths, as.array, as.matrix, as.data.frame, as.vector, as.logical, as.integer, as.numeric, as.complex, as.character, as.raw, c, split, drop, t, is.na, is.finite, is.infinite, is.nan, "!", #"+", "-", "*", "/", "^", "%%", "%/%", # "Arith" group generic "==", "!=", "<=", ">=", "<", ">", # "Compare" group generic anyNA, which, max, min, range, sum, prod, any, all, # "Summary" group generic mean, round, signif, rowSums, colSums, rowMeans, colMeans, nchar, tolower, toupper, ## Methods for generics defined in the methods package: coerce, show, ## Methods for generics defined in the stats package: dbinom, pbinom, qbinom, dpois, ppois, qpois, dlogis, plogis, qlogis, ## Methods for generics defined in the BiocGenerics package: cbind, rbind, ## Methods for generics defined in the S4Vectors package: isEmpty, ## Methods for generics defined in the IRanges package: ranges, start, end, width, splitAsList ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export non-generic functions ### export( ArrayViewport, makeNindexFromArrayViewport, ArrayArbitraryGrid, ArrayRegularGrid, supportedRealizationBackends, getRealizationBackend, setRealizationBackend, write_array_to_sink, RleArray ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S4 generics defined in DelayedArray + export corresponding methods ### export( arbind, acbind, refdim, isLinear, subset_seed_as_array, matrixClass, DelayedArray, seed, type, chunk_dim, write_block_to_sink, close, realize, pmax2, pmin2, apply, rowMaxs, colMaxs, rowMins, colMins, rowRanges, colRanges ) ### Exactly the same list as above. exportMethods( arbind, acbind, refdim, isLinear, subset_seed_as_array, matrixClass, DelayedArray, seed, type, chunk_dim, write_block_to_sink, close, realize, pmax2, pmin2, apply, rowMaxs, colMaxs, rowMins, colMins, rowRanges, colRanges ) DelayedArray/NOTES0000644000175400017540000000421513175715524014775 0ustar00biocbuildbiocbuild## Should this go in the SummarizedExperiment package? As an additional section ## in the vignette? As a separate vignette? As a man page? Probably the former. ## The problem ## =========== ## ## When trying to create a SummarizedExperiment object with big dimensions it's ## critical to use a memory-efficient container for the assay data. Depending ## on the nature of the data, in-memory containers that compress the data (e.g. ## a DataFrame of Rle's or a sparse matrix from the Matrix package) might help ## to a certain extent. However, even after compression some data might remain ## too big to fit in memory. In that case, one solution is to split the ## SummarizedExperiment object in smaller objects, then process the smaller ## objects separately, and finally combine the results. A disadvantage of this ## approach is that the split/process/combine mechanism is the responsibility ## of the SummarizedExperiment-based application so it makes the development of ## such applications more complicated. Having the assay data stored in an ## on-disk container like HDF5Matrix should greatly simplify this: the goal is ## to make it possible for the end-user to manipulate the big ## SummarizedExperiment object as a whole and have the split/process/combine ## mechanism automatically and transparently happen behind the scene . ## Comparison of assay data containers ## =================================== ## ## Each container has its strengths and weaknesses and which one to use exactly ## depends on several factors. ## ## DataFrame of Rle's ## ------------------ ## Works great for coverage data. See ?GPos in GenomicRanges for an example. ## Sparse matrix object from the Matrix package ## -------------------------------------------- ## This sounds like a natural candidate for RNA-seq count data which tends to ## be sparse. Unfortunately, because the Matrix package can only store the ## counts as doubles and not as integers, trying to use it on real RNA-seq ## count data actually increases the size of the matrix of counts: library(Matrix) library(airway) data(airway) head(assay(airway)) object.size(assay(airway)) object.size(Matrix(assay(airway), sparse=TRUE)) DelayedArray/R/0000755000175400017540000000000013175715525014362 5ustar00biocbuildbiocbuildDelayedArray/R/Array-class.R0000644000175400017540000000505213175715524016667 0ustar00biocbuildbiocbuild### ========================================================================= ### Array objects ### ------------------------------------------------------------------------- ### A virtual class with no slots to be extended by concrete subclasses with ### an array-like semantic. setClass("Array", representation("VIRTUAL")) ### Even though prod() always returns a double, it seems that the length() ### primitive function takes care of turning this double into an integer if ### it's <= .Machine$integer.max setMethod("length", "Array", function(x) prod(dim(x))) ### 'subscripts' is assumed to be an integer vector parallel to 'dim(x)' and ### with no out-of-bounds subscripts (i.e. 'all(subscripts >= 1)' and ### 'all(subscripts <= dim(x))'). ### NOT exported at the moment but should probably be at some point (like ### S4Vectors::getListElement() is. setGeneric("getArrayElement", signature="x", function(x, subscripts) standardGeneric("getArrayElement") ) ### Return an integer vector parallel to 'dim' and guaranteed to contain no ### out-of-bounds subscripts. .from_linear_to_multi_subscript <- function(i, dim) { stopifnot(isSingleInteger(i)) if (i < 1L || i > prod(dim)) stop("subscript is out of bounds") i <- i - 1L subscripts <- integer(length(dim)) for (along in seq_along(dim)) { d <- dim[[along]] subscripts[[along]] <- offset <- i %% d i <- (i - offset) %/% d } subscripts + 1L } ### Support multi-dimensional and linear subsetting. setMethod("[[", "Array", function(x, i, j, ...) { if (missing(x)) stop("'x' is missing") Nindex <- extract_Nindex_from_syscall(sys.call(), parent.frame()) nsubscript <- length(Nindex) x_dim <- dim(x) x_ndim <- length(x_dim) if (!(nsubscript == x_ndim || nsubscript == 1L)) stop("incorrect number of subscripts") ok <- vapply(Nindex, isSingleInteger, logical(1), USE.NAMES=FALSE) if (!all(ok)) stop(wmsg("each subscript must be a single integer ", "when subsetting an ", class(x), " object with [[")) if (nsubscript == x_ndim) { subscripts <- unlist(Nindex, use.names=FALSE) if (!(all(subscripts >= 1L) && all(subscripts <= x_dim))) stop("some subscripts are out of bounds") } else { ## Translate linear subsetting into multi-dimensional subsetting. subscripts <- .from_linear_to_multi_subscript(Nindex[[1L]], x_dim) } getArrayElement(x, subscripts) } ) DelayedArray/R/ArrayGrid-class.R0000644000175400017540000004561613175715524017507 0ustar00biocbuildbiocbuild### ========================================================================= ### ArrayViewport and ArrayGrid objects ### ------------------------------------------------------------------------- ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### ArrayViewport objects ### ### We don't extend the IRanges class because we don't want to inherit the ### full Ranges API (most operations in that API would do the wrong thing on ### ArrayViewport objects). setClass("ArrayViewport", contains="Array", representation( refdim="integer", # Dimensions of "the reference array" i.e. the # array on top of which the viewport is defined # (a.k.a. "the underlying array"). ranges="IRanges" # Must be parallel to the 'refdim' slot. ) ) ### Validity .validate_ranges_slot <- function(x) { x_ranges <- x@ranges x_refdim <- x@refdim if (length(x_ranges) != length(x_refdim)) return(wmsg2("'ranges' and 'refdim' slots must have the same length")) ## Check that the viewport is contained in the reference array. x_start <- start(x_ranges) x_end <- end(x_ranges) if (!(all(x_start >= 1L) && all(x_end <= x_refdim))) return(wmsg2("object represents a viewport that is not ", "within the bounds of the reference array")) ## A viewport cannot be longer than 2^31-1. x_dim <- width(x_ranges) if (prod(x_dim) > .Machine$integer.max) return(wmsg2("a viewport cannot be longer than .Machine$integer.max")) TRUE } .validate_ArrayViewport <- function(x) { msg <- validate_dim_slot(x, "refdim") if (!isTRUE(msg)) return(msg) msg <- .validate_ranges_slot(x) if (!isTRUE(msg)) return(msg) TRUE } setValidity2("ArrayViewport", .validate_ArrayViewport) ### Getters setGeneric("refdim", function(x) standardGeneric("refdim")) setMethod("refdim", "ArrayViewport", function(x) x@refdim) setMethod("ranges", "ArrayViewport", function(x) x@ranges) setMethod("start", "ArrayViewport", function(x) start(ranges(x))) setMethod("width", "ArrayViewport", function(x) width(ranges(x))) setMethod("end", "ArrayViewport", function(x) end(ranges(x))) ### 'width(x)' and 'dim(x)' are synonyms. setMethod("dim", "ArrayViewport", function(x) width(ranges(x))) ### Constructor ### If 'ranges' is omitted, return a viewport that covers the whole ### reference array. ArrayViewport <- function(refdim, ranges=NULL) { if (is.null(ranges)) ranges <- IRanges(rep.int(1L, length(refdim)), refdim) new("ArrayViewport", refdim=refdim, ranges=ranges) } ### Show make_string_from_ArrayViewport <- function(viewport, dimnames=NULL, with.brackets=FALSE) { if (!isTRUEorFALSE(with.brackets)) stop("'with.brackets' must be TRUE or FALSE") viewport_ranges <- ranges(viewport) viewport_dim <- dim(viewport) viewport_refdim <- refdim(viewport) ans <- as.character(viewport_ranges) ans[viewport_dim == viewport_refdim] <- "" if (!is.null(dimnames)) { stopifnot(is.list(dimnames), length(viewport_dim) == length(dimnames)) usename_idx <- which(viewport_dim == 1L & viewport_refdim != 1L & lengths(dimnames) != 0L) ans[usename_idx] <- mapply(`[`, dimnames[usename_idx], start(viewport_ranges)[usename_idx], SIMPLIFY=FALSE) } if (ans[[1L]] == "" && with.brackets) ans[[1L]] <- " " ans <- paste0(ans, collapse=", ") if (with.brackets) ans <- paste0("[", ans, "]") ans } setMethod("show", "ArrayViewport", function(object) { refdim_in1string <- paste0(refdim(object), collapse=" x ") cat(class(object), " object on a ", refdim_in1string, " array: ", sep="") s <- make_string_from_ArrayViewport(object, with.brackets=TRUE) cat(s, "\n", sep="") } ) ### makeNindexFromArrayViewport() ### Used in HDF5Array! makeNindexFromArrayViewport <- function(viewport, expand.RangeNSBS=FALSE) { viewport_ranges <- ranges(viewport) viewport_dim <- dim(viewport) viewport_refdim <- refdim(viewport) ndim <- length(viewport_dim) Nindex <- vector(mode="list", length=ndim) is_not_missing <- viewport_dim < viewport_refdim if (expand.RangeNSBS) { expand_idx <- which(is_not_missing) } else { viewport_starts <- start(viewport_ranges) viewport_ends <- end(viewport_ranges) is_width1 <- viewport_dim == 1L expand_idx <- which(is_not_missing & is_width1) RangeNSBS_idx <- which(is_not_missing & !is_width1) Nindex[RangeNSBS_idx] <- lapply(RangeNSBS_idx, function(i) { range_start <- viewport_starts[[i]] range_end <- viewport_ends[[i]] upper_bound <- viewport_refdim[[i]] new2("RangeNSBS", subscript=c(range_start, range_end), upper_bound=upper_bound, check=FALSE) } ) } Nindex[expand_idx] <- as.list(viewport_ranges[expand_idx]) Nindex } ### 2 utilities for extracting/replacing blocks from/in an array-like object extract_block <- function(x, viewport) { stopifnot(identical(dim(x), refdim(viewport))) Nindex <- makeNindexFromArrayViewport(viewport) subset_by_Nindex(x, Nindex) } ### Return the modified array. replace_block <- function(x, viewport, block) { stopifnot(identical(dim(x), refdim(viewport)), identical(dim(viewport), dim(block))) Nindex <- makeNindexFromArrayViewport(viewport) replace_by_Nindex(x, Nindex, block) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### ArrayGrid objects ### ### An ArrayGrid object represents a grid on top of an array (called "the ### reference array" or "the underlying array"). The ArrayGrid class is a ### virtual class with 2 concrete subclasses, ArrayArbitraryGrid and ### ArrayRegularGrid, for representing an arbitrarily-spaced or a ### regularly-spaced grid, respectively. The API we implement on these objects ### is divided into 3 groups of methods: ### 1) One special method: ### - refdim(x): Return the dimensions of the reference array. ### 2) Methods from the array API (an ArrayGrid object can be seen as an ### array of ArrayViewport objects that cover the reference array without ### overlapping with each others): ### - dim(x): Return the number of grid elements (i.e. viewports) along ### each dimension of the reference array. ### - x[[i_1, i_2, ..., i_n]]: Multi-dimensional double bracket ### subsetting. Return an ArrayViewport object. ### 3) Methods from the list API: ### - length(): Return the total number of grid elements. ### - x[[i]]: Linear double bracket subsetting. Return an ArrayViewport ### object. ### Groups 2) and 3) give these objects 2 semantics: array-like and list-like. ### Note that length() and "linear double bracket subsetting" are consistent ### with dim() and "multi-dimensional double bracket subsetting", respectively. ### So the array-like and list-like semantics are compatible. ### setClass("ArrayGrid", contains=c("Array", "List"), representation("VIRTUAL"), prototype(elementType="ArrayViewport") ) setClass("ArrayArbitraryGrid", contains="ArrayGrid", representation( tickmarks="list" # A list of integer vectors, one along each # dimension of the reference array, # representing the tickmarks along that # dimension. Each integer vector must be sorted # in ascending order. ) ) setClass("ArrayRegularGrid", contains="ArrayGrid", representation( refdim="integer", # Dimensions of the reference array. spacings="integer" # Grid spacing along each dimension. ) ) ### Low-level helpers .get_ArrayArbitraryGrid_spacings_along <- function(x, along) S4Vectors:::diffWithInitialZero(x@tickmarks[[along]]) .get_ArrayArbitraryGrid_max_spacings <- function(x) { vapply(seq_along(x@tickmarks), function(along) max(0L, .get_ArrayArbitraryGrid_spacings_along(x, along)), integer(1)) } .get_ArrayRegularGrid_dim <- function(refdim, spacings) { ans <- refdim %/% spacings + (refdim %% spacings != 0L) ans[is.na(ans)] <- 1L ans } .get_ArrayRegularGrid_spacings_along <- function(x, along) { D <- x@refdim[[along]] if (D == 0L) return(0L) spacing <- x@spacings[[along]] ans <- rep.int(spacing, D %/% spacing) r <- D %% spacing if (r != 0L) ans <- c(ans, r) ans } ### Validity .valid_tickmarks <- function(tm) { is.integer(tm) && !S4Vectors:::anyMissingOrOutside(tm, 0L) && isSorted(tm) } .validate_ArrayArbitraryGrid <- function(x) { x_tickmarks <- x@tickmarks if (!is.list(x_tickmarks)) return(wmsg2("'tickmarks' slot must be a list")) ok <- vapply(x_tickmarks, .valid_tickmarks, logical(1), USE.NAMES=FALSE) if (!all(ok)) return(wmsg2("each list element in 'tickmarks' slot must be a ", "sorted integer vector of non-negative values")) max_spacings <- .get_ArrayArbitraryGrid_max_spacings(x) if (prod(max_spacings) > .Machine$integer.max) return(wmsg2("grid is too coarse (all grid elements must have a ", "length <= .Machine$integer.max)")) TRUE } setValidity2("ArrayArbitraryGrid", .validate_ArrayArbitraryGrid) .validate_ArrayRegularGrid <- function(x) { msg <- validate_dim_slot(x, "refdim") if (!isTRUE(msg)) return(msg) msg <- validate_dim_slot(x, "spacings") if (!isTRUE(msg)) return(msg) x_spacings <- x@spacings x_refdim <- x@refdim if (length(x_spacings) != length(x_refdim)) return(wmsg2("'spacings' and 'refdim' slots must have ", "the same length")) if (!all(x_spacings <= x_refdim)) return(wmsg2("values in 'spacings' slot must be <= the ", "corresponding values in 'refdim' slot")) if (any(x_spacings == 0L & x_refdim != 0L)) return(wmsg2("values in 'spacings' slot cannot be 0 unless the ", "corresponding values in 'refdim' slot are 0")) if (prod(x_spacings) > .Machine$integer.max) return(wmsg2("grid is too coarse (all grid elements must have a ", "length <= .Machine$integer.max)")) TRUE } setValidity2("ArrayRegularGrid", .validate_ArrayRegularGrid) ### Getters setMethod("refdim", "ArrayArbitraryGrid", function(x) { mapply(function(tm, tm_len) if (tm_len == 0L) 0L else tm[[tm_len]], x@tickmarks, lengths(x@tickmarks), USE.NAMES=FALSE) } ) setMethod("refdim", "ArrayRegularGrid", function(x) x@refdim) setMethod("dim", "ArrayArbitraryGrid", function(x) lengths(x@tickmarks)) setMethod("dim", "ArrayRegularGrid", function(x) .get_ArrayRegularGrid_dim(refdim(x), x@spacings) ) ### Constructors ArrayArbitraryGrid <- function(tickmarks) new("ArrayArbitraryGrid", tickmarks=tickmarks) ### Note that none of the dimensions of an ArrayRegularGrid object can be 0, ### even when some dimensions of the reference array are 0 (in which case, ### the corresponding dimensions of the grid object are set to 1). As a ### consequence, an ArrayRegularGrid object always contains at least 1 grid ### element. Each dimension of the first grid element is always equal to the ### spacing along that dimension i.e. for any ArrayRegularGrid object, ### 'dim(grid[[1]])' is identical to 'spacings'. ### If 'spacings' is omitted, return a grid with a single grid element ### covering the whole reference array. ArrayRegularGrid <- function(refdim, spacings=refdim) new("ArrayRegularGrid", refdim=refdim, spacings=spacings) ### [[ setMethod("getArrayElement", "ArrayArbitraryGrid", function(x, subscripts) { x_refdim <- refdim(x) ans_end <- mapply(`[[`, x@tickmarks, subscripts) ans_width <- mapply( function(along, i) .get_ArrayArbitraryGrid_spacings_along(x, along)[[i]], seq_along(x_refdim), subscripts) ans_ranges <- IRanges(end=ans_end, width=ans_width) ArrayViewport(x_refdim, ans_ranges) } ) setMethod("getArrayElement", "ArrayRegularGrid", function(x, subscripts) { x_refdim <- refdim(x) ans_offset <- (subscripts - 1L) * x@spacings ans_end <- pmin(ans_offset + x@spacings, refdim(x)) ans_ranges <- IRanges(start=ans_offset + 1L, end=ans_end) ArrayViewport(x_refdim, ans_ranges) } ) ### lengths() ### NOT exported. setGeneric("get_spacings_along", signature="x", function(x, along) standardGeneric("get_spacings_along") ) setMethod("get_spacings_along", "ArrayArbitraryGrid", .get_ArrayArbitraryGrid_spacings_along ) setMethod("get_spacings_along", "ArrayRegularGrid", .get_ArrayRegularGrid_spacings_along ) ### Equivalent to 'vapply(x, length, integer(1))' but faster. ### The sum of the hyper-volumes of all the grid elements should be equal ### to the hyper-volume of the reference array. ### More concisely: sum(lengths(x)) should be equal to 'prod(refdim(x))'. setMethod("lengths", "ArrayGrid", function (x, use.names=TRUE) { ans <- get_spacings_along(x, 1L) x_ndim <- length(refdim(x)) if (x_ndim >= 2L) { for (along in 2:x_ndim) ans <- ans * rep(get_spacings_along(x, along), each=length(ans)) } ans } ) ### Show ### S3/S4 combo for as.character.ArrayGrid .as.character.ArrayGrid <- function(x, with.brackets=FALSE) { data <- vapply(x, function(viewport) make_string_from_ArrayViewport(viewport, with.brackets=with.brackets), character(1) ) array(data, dim(x)) } as.character.ArrayGrid <- function(x, ...) .as.character.ArrayGrid(x, ...) setMethod("as.character", "ArrayGrid", .as.character.ArrayGrid) setMethod("show", "ArrayGrid", function(object) { dim_in1string <- paste0(dim(object), collapse=" x ") refdim_in1string <- paste0(refdim(object), collapse=" x ") cat(dim_in1string, " ", class(object), " object ", "on a ", refdim_in1string, " array:\n", sep="") ## Turn 'object' into a character array. print(as.character(object, TRUE), quote=FALSE) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### get_max_spacings_for_hypercube_blocks() ### ### Typically used to create a grid that divides the reference array 'x' into ### blocks that have a shape that is as close as possible to an hypercube ### (while having their length <= 'max_block_len'): ### ### max_block_len <- get_max_block_length(type(x)) ### spacings <- get_max_spacings_for_hypercube_blocks(dim(x), max_block_len) ### grid <- ArrayRegularGrid(dim(x), spacings) ### ### NOT exported but used in HDF5Array! get_max_spacings_for_hypercube_blocks <- function(refdim, max_block_len) { if (!isSingleNumber(max_block_len)) stop("'max_block_len' must be a single number") p <- prod(refdim) if (p <= max_block_len) return(refdim) spacings <- refdim L <- max(spacings) while (TRUE) { is_max <- spacings == L not_max_spacings <- spacings[!is_max] L <- (max_block_len / prod(not_max_spacings)) ^ (1 / sum(is_max)) if (length(not_max_spacings) == 0L) break L2 <- max(not_max_spacings) if (L >= L2) break L <- L2 spacings[is_max] <- L } spacings[is_max] <- as.integer(L) q <- .get_ArrayRegularGrid_dim(refdim, spacings + 1L) / .get_ArrayRegularGrid_dim(refdim, spacings) for (along in which(is_max)[order(q[is_max])]) { spacings[[along]] <- spacings[[along]] + 1L p <- prod(spacings) if (p == max_block_len) break if (p > max_block_len) { spacings[[along]] <- spacings[[along]] - 1L break } } spacings } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Grids with "linear grid elements" ### ### The grid elements are said to be "linear" if they divide the reference ### array in "linear blocks", i.e. in blocks that would be made of array ### elements contiguous in memory if the reference array was an ordinary R ### array (where the fastest changing dimension is the first one). ### Note that if the 1st grid element is linear, then they all are. ### setGeneric("isLinear", function(x) standardGeneric("isLinear")) setMethod("isLinear", "ArrayViewport", function(x) { x_width <- width(x) idx <- which(x_width != refdim(x)) if (length(idx) == 0L) return(TRUE) all(tail(x_width, n=-idx[[1L]]) == 1L) } ) setMethod("isLinear", "ArrayGrid", function(x) { if (length(x) == 0L) return(TRUE) isLinear(x[[1L]]) } ) ### Typically used to create a regular grid with "linear grid elements" i.e. ### a grid that divides the reference array 'x' into "linear blocks": ### ### max_block_len <- get_max_block_length(type(x)) ### spacings <- get_max_spacings_for_linear_blocks(dim(x), max_block_len) ### grid <- ArrayRegularGrid(dim(x), spacings) ### ### All the grid elements are guaranteed to have a length <= 'max_block_len'. ### NOT exported but used in HDF5Array! get_max_spacings_for_linear_blocks <- function(refdim, max_block_len) { if (!isSingleNumber(max_block_len)) stop("'max_block_len' must be a single number") if (!is.integer(max_block_len)) max_block_len <- as.integer(max_block_len) p <- cumprod(refdim) w <- which(p <= max_block_len) N <- if (length(w) == 0L) 1L else w[[length(w)]] + 1L if (N > length(refdim)) return(refdim) if (N == 1L) { by <- max_block_len } else { by <- max_block_len %/% as.integer(p[[N - 1L]]) } c(head(refdim, n=N-1L), by, rep.int(1L, length(refdim)-N)) } ### NOT exported but used in unit tests. split_array_in_linear_blocks <- function(x, max_block_len) { spacings <- get_max_spacings_for_linear_blocks(dim(x), max_block_len) grid <- ArrayRegularGrid(dim(x), spacings) lapply(grid, function(viewport) extract_block(x, viewport)) } ### NOT exported but used in unit tests. ### Rebuild the original array from the blocks obtained by ### split_array_in_linear_blocks() as an *ordinary* array. ### So if 'x' is an ordinary array, then: ### ### blocks <- split_array_in_linear_blocks(x, max_block_len) ### unsplit_array_from_linear_blocks(blocks, x) ### ### should be a no-op for any 'max_block_len' < 'length(x)'. unsplit_array_from_linear_blocks <- function(blocks, x) { ans <- combine_array_objects(blocks) dim(ans) <- dim(x) ans } DelayedArray/R/ConformableSeedCombiner-class.R0000644000175400017540000000551513175715524022324 0ustar00biocbuildbiocbuild### ========================================================================= ### ConformableSeedCombiner objects ### ------------------------------------------------------------------------- ### ### This class is for internal use only and is not exported. ### setClass("ConformableSeedCombiner", representation( seeds="list", # List of n conformable array-like objects # to combine. Each object is expected to # satisfy the "seed contract" i.e. to # support dim(), dimnames(), and # subset_seed_as_array(). COMBINING_OP="function", # n-ary operator to combine the seeds. Rargs="list" # Additional arguments to the n-ary # operator. ), prototype( seeds=list(new("array")), COMBINING_OP=identity ) ) .objects_are_conformable_arrays <- function(objects) { dims <- lapply(objects, dim) ndims <- lengths(dims) first_ndim <- ndims[[1L]] if (!all(ndims == first_ndim)) return(FALSE) tmp <- unlist(dims, use.names=FALSE) if (is.null(tmp)) return(FALSE) dims <- matrix(tmp, nrow=first_ndim) first_dim <- dims[ , 1L] all(dims == first_dim) } .validate_ConformableSeedCombiner <- function(x) { ## 'seeds' slot. if (length(x@seeds) == 0L) return(wmsg2("'x@seeds' cannot be empty")) if (!.objects_are_conformable_arrays(x@seeds)) return(wmsg2("'x@seeds' must be a list of conformable ", "array-like objects")) TRUE } setValidity2("ConformableSeedCombiner", .validate_ConformableSeedCombiner) new_ConformableSeedCombiner <- function(seed=new("array"), ..., COMBINING_OP=identity, Rargs=list()) { seeds <- unname(list(seed, ...)) COMBINING_OP <- match.fun(COMBINING_OP) new2("ConformableSeedCombiner", seeds=seeds, COMBINING_OP=COMBINING_OP, Rargs=Rargs) } ### Implement the "seed contract" i.e. dim(), dimnames(), and ### subset_seed_as_array(). .get_ConformableSeedCombiner_dim <- function(x) dim(x@seeds[[1L]]) setMethod("dim", "ConformableSeedCombiner", .get_ConformableSeedCombiner_dim ) .get_ConformableSeedCombiner_dimnames <- function(x) { combine_dimnames(x@seeds) } setMethod("dimnames", "ConformableSeedCombiner", .get_ConformableSeedCombiner_dimnames ) .subset_ConformableSeedCombiner_as_array <- function(seed, index) { arrays <- lapply(seed@seeds, subset_seed_as_array, index) do.call(seed@COMBINING_OP, c(arrays, seed@Rargs)) } setMethod("subset_seed_as_array", "ConformableSeedCombiner", .subset_ConformableSeedCombiner_as_array ) DelayedArray/R/DelayedArray-class.R0000644000175400017540000010213513175715524020157 0ustar00biocbuildbiocbuild### ========================================================================= ### DelayedArray objects ### ------------------------------------------------------------------------- setClass("DelayedArray", contains="Array", representation( seed="ANY", # An array-like object expected to satisfy # the "seed contract" i.e. to support dim(), # dimnames(), and subset_seed_as_array(). index="list", # List (possibly named) of subscripts as # positive integer vectors, one vector per # seed dimension. *Missing* list elements # are allowed and represented by NULLs. metaindex="integer", # Index into the "index" slot specifying the # seed dimensions to keep. delayed_ops="list", # List of delayed operations. See below # for the details. is_transposed="logical" # Is the object considered to be transposed # with respect to the seed? ), prototype( seed=new("array"), index=list(NULL), metaindex=1L, is_transposed=FALSE ) ) ### Extending DataTable gives us a few things for free (head(), tail(), ### etc...) setClass("DelayedMatrix", contains=c("DelayedArray", "DataTable"), prototype=prototype( seed=new("matrix"), index=list(NULL, NULL), metaindex=1:2 ) ) ### Automatic coercion method from DelayedArray to DelayedMatrix silently ### returns a broken object (unfortunately these dummy automatic coercion ### methods don't bother to validate the object they return). So we overwrite ### it. setAs("DelayedArray", "DelayedMatrix", function(from) new("DelayedMatrix", from) ) ### For internal use only. setGeneric("matrixClass", function(x) standardGeneric("matrixClass")) setMethod("matrixClass", "DelayedArray", function(x) "DelayedMatrix") ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity ### .validate_DelayedArray <- function(x) { x_dim <- dim(x@seed) x_ndim <- length(x_dim) ## 'seed' slot. if (x_ndim == 0L) return(wmsg2("'x@seed' must have dimensions")) ## 'index' slot. if (length(x@index) != x_ndim) return(wmsg2("'x@index' must have one list element per dimension ", "in 'x@seed'")) if (!all(S4Vectors:::sapply_isNULL(x@index) | vapply(x@index, is.integer, logical(1), USE.NAMES=FALSE))) return(wmsg2("every list element in 'x@index' must be either NULL ", "or an integer vector")) ## 'metaindex' slot. if (length(x@metaindex) == 0L) return(wmsg2("'x@metaindex' cannot be empty")) if (S4Vectors:::anyMissingOrOutside(x@metaindex, 1L, x_ndim)) return(wmsg2("all values in 'x@metaindex' must be >= 1 ", "and <= 'length(x@index)'")) if (!isStrictlySorted(x@metaindex)) return(wmsg2("'x@metaindex' must be strictly sorted")) if (!all(get_Nindex_lengths(x@index, x_dim)[-x@metaindex] == 1L)) return(wmsg2("all the dropped dimensions in 'x' must be equal to 1")) ## 'is_transposed' slot. if (!isTRUEorFALSE(x@is_transposed)) return(wmsg2("'x@is_transposed' must be TRUE or FALSE")) TRUE } setValidity2("DelayedArray", .validate_DelayedArray) ### TODO: Move this to S4Vectors and make it the validity method for DataTable ### object. .validate_DelayedMatrix <- function(x) { if (length(dim(x)) != 2L) return(wmsg2("'x' must have exactly 2 dimensions")) TRUE } setValidity2("DelayedMatrix", .validate_DelayedMatrix) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Constructor ### ### NOT exported but used in HDF5Array! new_DelayedArray <- function(seed=new("array"), Class="DelayedArray") { seed <- remove_pristine_DelayedArray_wrapping(seed) seed_ndim <- length(dim(seed)) if (seed_ndim == 2L) Class <- matrixClass(new(Class)) index <- vector(mode="list", length=seed_ndim) new2(Class, seed=seed, index=index, metaindex=seq_along(index)) } setGeneric("DelayedArray", function(seed) standardGeneric("DelayedArray")) setMethod("DelayedArray", "ANY", function(seed) new_DelayedArray(seed)) ### Calling DelayedArray() on a DelayedArray object is a no-op. setMethod("DelayedArray", "DelayedArray", function(seed) seed) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### seed() ### setGeneric("seed", function(x) standardGeneric("seed")) setMethod("seed", "DelayedArray", function(x) x@seed) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Pristine objects ### ### A pristine DelayedArray object is an object that does not carry any ### delayed operation on it. In other words, it's in sync with (i.e. reflects ### the content of) its seed. ### ### NOT exported but used in HDF5Array! ### Note that false negatives happen when 'x' carries delayed operations that ### do nothing, but that's ok. is_pristine <- function(x) { ## 'x' should not carry any delayed operation on it, that is, all the ## DelayedArray slots must be in their original state. x2 <- new_DelayedArray(seed(x)) class(x) <- class(x2) <- "DelayedArray" identical(x, x2) } ### Remove the DelayedArray wrapping (or nested wrappings) from around the ### seed if the wrappings are pristine. remove_pristine_DelayedArray_wrapping <- function(x) { if (!(is(x, "DelayedArray") && is_pristine(x))) return(x) remove_pristine_DelayedArray_wrapping(seed(x)) } ### When a pristine DelayedArray derived object (i.e. an HDF5Array object) is ### about to be touched, we first need to downgrade it to a DelayedArray or ### DelayedMatrix *instance*. downgrade_to_DelayedArray_or_DelayedMatrix <- function(x) { if (is(x, "DelayedMatrix")) return(as(x, "DelayedMatrix")) as(x, "DelayedArray") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### dim() ### ### dim() getter. .get_DelayedArray_dim_before_transpose <- function(x) { get_Nindex_lengths(x@index, dim(seed(x)))[x@metaindex] } .get_DelayedArray_dim <- function(x) { ans <- .get_DelayedArray_dim_before_transpose(x) if (x@is_transposed) ans <- rev(ans) ans } setMethod("dim", "DelayedArray", .get_DelayedArray_dim) setMethod("isEmpty", "DelayedArray", function(x) any(dim(x) == 0L)) ### dim() setter. .normalize_dim_replacement_value <- function(value, x_dim) { if (is.null(value)) stop(wmsg("you can't do that, sorry")) if (!is.numeric(value)) stop(wmsg("the supplied dim vector must be numeric")) if (length(value) == 0L) stop(wmsg("the supplied dim vector cannot be empty")) if (!is.integer(value)) value <- as.integer(value) if (S4Vectors:::anyMissingOrOutside(value, 0L)) stop(wmsg("the supplied dim vector cannot contain negative ", "or NA values")) if (length(value) > length(x_dim)) stop(wmsg("too many dimensions supplied")) prod1 <- prod(value) prod2 <- prod(x_dim) if (prod1 != prod2) stop(wmsg("the supplied dims [product ", prod1, "] do not match ", "the length of object [", prod2, "]")) unname(value) } .map_new_to_old_dim <- function(new_dim, old_dim, x_class) { idx1 <- which(new_dim != 1L) idx2 <- which(old_dim != 1L) cannot_map_msg <- wmsg( "Cannot map the supplied dim vector to the current dimensions of ", "the object. On a ", x_class, " object, the dim() setter can only ", "be used to drop some of the ineffective dimensions (the dimensions ", "equal to 1 are the ineffective dimensions)." ) can_map <- function() { if (length(idx1) != length(idx2)) return(FALSE) if (length(idx1) == 0L) return(TRUE) if (!all(new_dim[idx1] == old_dim[idx2])) return(FALSE) tmp <- idx2 - idx1 tmp[[1L]] >= 0L && isSorted(tmp) } if (!can_map()) stop(cannot_map_msg) new2old <- seq_along(new_dim) + rep.int(c(0L, idx2 - idx1), diff(c(1L, idx1, length(new_dim) + 1L))) if (new2old[[length(new2old)]] > length(old_dim)) stop(cannot_map_msg) new2old } .set_DelayedArray_dim <- function(x, value) { x_dim <- dim(x) value <- .normalize_dim_replacement_value(value, x_dim) new2old <- .map_new_to_old_dim(value, x_dim, class(x)) stopifnot(identical(value, x_dim[new2old])) # sanity check if (x@is_transposed) { x_metaindex <- rev(rev(x@metaindex)[new2old]) } else { x_metaindex <- x@metaindex[new2old] } if (!identical(x@metaindex, x_metaindex)) { x <- downgrade_to_DelayedArray_or_DelayedMatrix(x) x@metaindex <- x_metaindex } if (length(dim(x)) == 2L) x <- as(x, matrixClass(x)) x } setReplaceMethod("dim", "DelayedArray", .set_DelayedArray_dim) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### drop() ### setMethod("drop", "DelayedArray", function(x) { x_dim <- dim(x) dim(x) <- x_dim[x_dim != 1L] x } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### dimnames() ### ### dimnames() getter. .get_DelayedArray_dimnames_before_transpose <- function(x) { x_seed_dimnames <- dimnames(seed(x)) ans <- lapply(x@metaindex, get_Nindex_names_along, Nindex=x@index, dimnames=x_seed_dimnames) if (all(S4Vectors:::sapply_isNULL(ans))) return(NULL) ans } .get_DelayedArray_dimnames <- function(x) { ans <- .get_DelayedArray_dimnames_before_transpose(x) if (x@is_transposed) ans <- rev(ans) ans } setMethod("dimnames", "DelayedArray", .get_DelayedArray_dimnames) ### dimnames() setter. .normalize_dimnames_replacement_value <- function(value, ndim) { if (is.null(value)) return(vector("list", length=ndim)) if (!is.list(value)) stop("the supplied dimnames must be a list") if (length(value) > ndim) stop(wmsg("the supplied dimnames is longer ", "than the number of dimensions")) if (length(value) <- ndim) length(value) <- ndim value } .set_DelayedArray_dimnames <- function(x, value) { value <- .normalize_dimnames_replacement_value(value, length(x@metaindex)) if (x@is_transposed) value <- rev(value) ## We quickly identify a no-op situation. While doing so, we are careful to ## not trigger a copy of the "index" slot (which can be big). The goal is ## to make a no-op like 'dimnames(x) <- dimnames(x)' as fast as possible. x_seed_dimnames <- dimnames(seed(x)) touched_midx <- which(mapply( function(N, names) !identical( get_Nindex_names_along(x@index, x_seed_dimnames, N), names ), x@metaindex, value, USE.NAMES=FALSE )) if (length(touched_midx) == 0L) return(x) # no-op x <- downgrade_to_DelayedArray_or_DelayedMatrix(x) touched_idx <- x@metaindex[touched_midx] x_seed_dim <- dim(seed(x)) x@index[touched_idx] <- mapply( function(N, names) { i <- x@index[[N]] if (is.null(i)) i <- seq_len(x_seed_dim[[N]]) # expand 'i' setNames(i, names) }, touched_idx, value[touched_midx], SIMPLIFY=FALSE, USE.NAMES=FALSE ) x } setReplaceMethod("dimnames", "DelayedArray", .set_DelayedArray_dimnames) ### names() getter & setter. .get_DelayedArray_names <- function(x) { if (length(dim(x)) != 1L) return(NULL) dimnames(x)[[1L]] } setMethod("names", "DelayedArray", .get_DelayedArray_names) .set_DelayedArray_names <- function(x, value) { if (length(dim(x)) != 1L) { if (!is.null(value)) stop(wmsg("setting the names of a ", class(x), " object ", "with more than 1 dimension is not supported")) return(x) } dimnames(x)[[1L]] <- value x } setReplaceMethod("names", "DelayedArray", .set_DelayedArray_names) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Transpose ### ### The actual transposition of the data is delayed i.e. it will be realized ### on the fly only when as.array() (or as.vector() or as.matrix()) is called ### on 'x'. setMethod("t", "DelayedArray", function(x) { x <- downgrade_to_DelayedArray_or_DelayedMatrix(x) x@is_transposed <- !x@is_transposed x } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Management of delayed operations ### ### The 'delayed_ops' slot represents the list of delayed operations op1, op2, ### etc... Each delayed operation is itself represented by a list of length 4: ### 1) The name of the function to call (e.g. "+" or "log"). ### 2) The list of "left arguments" i.e. the list of arguments to place ### before the array in the function call. ### 3) The list of "right arguments" i.e. the list of arguments to place ### after the array in the function call. ### 4) A single logical. Indicates the dimension along which the (left or ### right) argument of the function call needs to be recycled when the ### operation is actually executed (done by .execute_delayed_ops() which ### is called by as.array()). FALSE: along the 1st dim; TRUE: along ### the last dim; NA: no recycling. Recycling is only supported for ### function calls with 2 arguments (i.e. the array and the recycled ### argument) at the moment. ### ### Each operation must return an array of the same dimensions as the original ### array. ### register_delayed_op <- function(x, FUN, Largs=list(), Rargs=list(), recycle_along_last_dim=NA) { if (isTRUEorFALSE(recycle_along_last_dim)) { nLargs <- length(Largs) nRargs <- length(Rargs) ## Recycling is only supported for function calls with 2 arguments ## (i.e. the array and the recycled argument) at the moment. stopifnot(nLargs + nRargs == 1L) partially_recycled_arg <- if (nLargs == 1L) Largs[[1L]] else Rargs[[1L]] stopifnot(length(partially_recycled_arg) == nrow(x)) } delayed_op <- list(FUN, Largs, Rargs, recycle_along_last_dim) x <- downgrade_to_DelayedArray_or_DelayedMatrix(x) x@delayed_ops <- c(x@delayed_ops, list(delayed_op)) x } .subset_delayed_op_args <- function(delayed_op, i, subset_along_last_dim) { recycle_along_last_dim <- delayed_op[[4L]] if (is.na(recycle_along_last_dim) || recycle_along_last_dim != subset_along_last_dim) return(delayed_op) Largs <- delayed_op[[2L]] Rargs <- delayed_op[[3L]] nLargs <- length(Largs) nRargs <- length(Rargs) stopifnot(nLargs + nRargs == 1L) if (nLargs == 1L) { new_arg <- extractROWS(Largs[[1L]], i) delayed_op[[2L]] <- list(new_arg) } else { new_arg <- extractROWS(Rargs[[1L]], i) delayed_op[[3L]] <- list(new_arg) } if (length(new_arg) == 1L) delayed_op[[4L]] <- NA delayed_op } .subset_delayed_ops_args <- function(delayed_ops, i, subset_along_last_dim) lapply(delayed_ops, .subset_delayed_op_args, i, subset_along_last_dim) ### 'a' is the ordinary array returned by the "combining" operator. .execute_delayed_ops <- function(a, delayed_ops) { a_dim <- dim(a) first_dim <- a_dim[[1L]] last_dim <- a_dim[[length(a_dim)]] a_len <- length(a) if (a_len == 0L) { p1 <- p2 <- 0L } else { p1 <- a_len / first_dim p2 <- a_len / last_dim } recycle_arg <- function(partially_recycled_arg, recycle_along_last_dim) { if (recycle_along_last_dim) { stopifnot(length(partially_recycled_arg) == last_dim) rep(partially_recycled_arg, each=p2) } else { stopifnot(length(partially_recycled_arg) == first_dim) rep.int(partially_recycled_arg, p1) } } prepare_call_args <- function(a, delayed_op) { Largs <- delayed_op[[2L]] Rargs <- delayed_op[[3L]] recycle_along_last_dim <- delayed_op[[4L]] if (isTRUEorFALSE(recycle_along_last_dim)) { nLargs <- length(Largs) nRargs <- length(Rargs) stopifnot(nLargs + nRargs == 1L) if (nLargs == 1L) { Largs <- list(recycle_arg(Largs[[1L]], recycle_along_last_dim)) } else { Rargs <- list(recycle_arg(Rargs[[1L]], recycle_along_last_dim)) } } c(Largs, list(a), Rargs) } for (delayed_op in delayed_ops) { FUN <- delayed_op[[1L]] call_args <- prepare_call_args(a, delayed_op) ## Perform the delayed operation. a <- do.call(FUN, call_args) ## Some vectorized operations on an ordinary array can drop the dim ## attribute (e.g. comparing a zero-col matrix with an atomic vector). a_new_dim <- dim(a) if (is.null(a_new_dim)) { ## Restore the dim attribute. dim(a) <- a_dim } else { ## Sanity check. stopifnot(identical(a_dim, a_new_dim)) } } a } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Multi-dimensional single bracket subsetting ### ### x[i_1, i_2, ..., i_n] ### ### Return an object of the same class as 'x' (endomorphism). ### 'user_Nindex' must be a "multidimensional subsetting Nindex" i.e. a ### list with one subscript per dimension in 'x'. Missing subscripts must ### be represented by NULLs. ### .subset_DelayedArray_by_Nindex <- function(x, user_Nindex) { stopifnot(is.list(user_Nindex)) x_index <- x@index x_ndim <- length(x@metaindex) x_seed_dim <- dim(seed(x)) x_seed_dimnames <- dimnames(seed(x)) x_delayed_ops <- x@delayed_ops for (n in seq_along(user_Nindex)) { subscript <- user_Nindex[[n]] if (is.null(subscript)) next n0 <- if (x@is_transposed) x_ndim - n + 1L else n N <- x@metaindex[[n0]] i <- x_index[[N]] if (is.null(i)) { i <- seq_len(x_seed_dim[[N]]) # expand 'i' names(i) <- get_Nindex_names_along(x_index, x_seed_dimnames, N) } subscript <- normalizeSingleBracketSubscript(subscript, i, as.NSBS=TRUE) x_index[[N]] <- extractROWS(i, subscript) if (n0 == 1L) x_delayed_ops <- .subset_delayed_ops_args(x_delayed_ops, subscript, FALSE) if (n0 == x_ndim) x_delayed_ops <- .subset_delayed_ops_args(x_delayed_ops, subscript, TRUE) } if (!identical(x@index, x_index)) { x <- downgrade_to_DelayedArray_or_DelayedMatrix(x) x@index <- x_index if (!identical(x@delayed_ops, x_delayed_ops)) x@delayed_ops <- x_delayed_ops } x } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### type() ### ### For internal use only. ### setGeneric("type", function(x) standardGeneric("type")) setMethod("type", "array", function(x) typeof(x)) ### If 'x' is a DelayedArray object, 'type(x)' must always return the same ### as 'typeof(as.array(x))'. setMethod("type", "DelayedArray", function(x) { user_Nindex <- as.list(integer(length(dim(x)))) ## x0 <- x[0, ..., 0] x0 <- .subset_DelayedArray_by_Nindex(x, user_Nindex) typeof(as.array(x0, drop=TRUE)) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Linear single bracket subsetting ### ### x[i] ### ### Return an atomic vector. ### .subset_DelayedArray_by_1Dindex <- function(x, i) { if (!is.numeric(i)) stop(wmsg("1D-style subsetting of a DelayedArray object only ", "accepts a numeric subscript at the moment")) if (length(i) == 0L) { user_Nindex <- as.list(integer(length(dim(x)))) ## x0 <- x[0, ..., 0] x0 <- .subset_DelayedArray_by_Nindex(x, user_Nindex) return(as.vector(x0)) } if (anyNA(i)) stop(wmsg("1D-style subsetting of a DelayedArray object does ", "not support NA indices yet")) if (min(i) < 1L) stop(wmsg("1D-style subsetting of a DelayedArray object only ", "supports positive indices at the moment")) if (max(i) > length(x)) stop(wmsg("subscript contains out-of-bounds indices")) if (length(i) == 1L) return(.get_DelayedArray_element(x, i)) ## We want to walk only on the blocks that we actually need to visit so we ## don't use block_APPLY() or family because they walk on all the blocks. max_block_len <- get_max_block_length(type(x)) spacings <- get_max_spacings_for_linear_blocks(dim(x), max_block_len) grid <- ArrayRegularGrid(dim(x), spacings) nblock <- length(grid) breakpoints <- cumsum(lengths(grid)) part_idx <- get_part_index(i, breakpoints) split_part_idx <- split_part_index(part_idx, length(breakpoints)) block_idx <- which(lengths(split_part_idx) != 0L) # blocks to visit res <- lapply(block_idx, function(b) { if (get_verbose_block_processing()) message("Visiting block ", b, "/", nblock, " ... ", appendLF=FALSE) block <- extract_block(x, grid[[b]]) if (!is.array(block)) block <- as.array(block) block_ans <- block[split_part_idx[[b]]] if (get_verbose_block_processing()) message("OK") block_ans }) unlist(res, use.names=FALSE)[get_rev_index(part_idx)] } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### [ ### .subset_DelayedArray <- function(x, i, j, ..., drop=TRUE) { if (missing(x)) stop("'x' is missing") user_Nindex <- extract_Nindex_from_syscall(sys.call(), parent.frame()) nsubscript <- length(user_Nindex) if (nsubscript != 0L && nsubscript != length(dim(x))) { if (nsubscript != 1L) stop("incorrect number of subscripts") return(.subset_DelayedArray_by_1Dindex(x, user_Nindex[[1L]])) } .subset_DelayedArray_by_Nindex(x, user_Nindex) } setMethod("[", "DelayedArray", .subset_DelayedArray) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### [<- ### .filling_error_msg <- c( "filling a DelayedArray object 'x' with a value (i.e. 'x[] <- value') ", "is supported only when 'value' is an atomic vector and 'length(value)' ", "is a divisor of 'nrow(x)'" ) .subassign_error_msg <- c( "subassignment to a DelayedArray object 'x' (i.e. 'x[i] <- value') is ", "supported only when the subscript 'i' is a logical DelayedArray object ", "with the same dimensions as 'x' and when 'value' is a scalar (i.e. an ", "atomic vector of length 1)" ) .fill_DelayedArray_with_value <- function(x, value) { if (!(is.vector(value) && is.atomic(value))) stop(wmsg(.filling_error_msg)) value_len <- length(value) if (value_len == 1L) return(register_delayed_op(x, `[<-`, Rargs=list(value=value))) x_len <- length(x) if (value_len > x_len) stop(wmsg("'value' is longer than 'x'")) x_nrow <- nrow(x) if (x_nrow != 0L) { if (value_len == 0L || x_nrow %% value_len != 0L) stop(wmsg(.filling_error_msg)) value <- rep(value, length.out=x_nrow) } register_delayed_op(x, `[<-`, Rargs=list(value=value), recycle_along_last_dim=x@is_transposed) } .subassign_DelayedArray <- function(x, i, j, ..., value) { if (missing(x)) stop("'x' is missing") user_Nindex <- extract_Nindex_from_syscall(sys.call(), parent.frame()) nsubscript <- length(user_Nindex) if (nsubscript == 0L) return(.fill_DelayedArray_with_value(x, value)) if (nsubscript != 1L) stop(wmsg(.subassign_error_msg)) i <- user_Nindex[[1L]] if (!(is(i, "DelayedArray") && identical(dim(x), dim(i)) && type(i) == "logical")) stop(wmsg(.subassign_error_msg)) if (!(is.vector(value) && is.atomic(value) && length(value) == 1L)) stop(wmsg(.subassign_error_msg)) DelayedArray(new_ConformableSeedCombiner(x, i, COMBINING_OP=`[<-`, Rargs=list(value=value))) } setReplaceMethod("[", "DelayedArray", .subassign_DelayedArray) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Realization in memory ### ### as.array(x) ### ### TODO: Do we actually need this? Using drop() should do it. .reduce_array_dimensions <- function(x) { x_dim <- dim(x) x_dimnames <- dimnames(x) effdim_idx <- which(x_dim != 1L) # index of effective dimensions if (length(effdim_idx) >= 2L) { dim(x) <- x_dim[effdim_idx] dimnames(x) <- x_dimnames[effdim_idx] } else { dim(x) <- NULL if (length(effdim_idx) == 1L) names(x) <- x_dimnames[[effdim_idx]] } x } ### Realize the object i.e. execute all the delayed operations and turn the ### object back into an ordinary array. .from_DelayedArray_to_array <- function(x, drop=FALSE) { if (!isTRUEorFALSE(drop)) stop("'drop' must be TRUE or FALSE") ans <- subset_seed_as_array(seed(x), unname(x@index)) dim(ans) <- .get_DelayedArray_dim_before_transpose(x) ans <- .execute_delayed_ops(ans, x@delayed_ops) dimnames(ans) <- .get_DelayedArray_dimnames_before_transpose(x) if (drop) ans <- .reduce_array_dimensions(ans) ## Base R doesn't support transposition of an array of arbitrary dimension ## (generalized transposition) so the call to t() below will fail if 'ans' ## has more than 2 dimensions. If we want as.array() to work on a ## transposed DelayedArray object of arbitrary dimension, we need to ## implement our own generalized transposition of an ordinary array. if (x@is_transposed) { if (length(dim(ans)) > 2L) stop("can't do as.array() on this object, sorry") ans <- t(ans) } ans } ### S3/S4 combo for as.array.DelayedArray as.array.DelayedArray <- function(x, ...) .from_DelayedArray_to_array(x, ...) setMethod("as.array", "DelayedArray", .from_DelayedArray_to_array) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Other coercions based on as.array() ### slicing_tip <- c( "Consider reducing its number of effective dimensions by slicing it ", "first (e.g. x[8, 30, , 2, ]). Make sure that all the indices used for ", "the slicing have length 1 except at most 2 of them which can be of ", "arbitrary length or missing." ) .from_DelayedArray_to_matrix <- function(x) { x_dim <- dim(x) if (sum(x_dim != 1L) > 2L) stop(wmsg(class(x), " object with more than 2 effective dimensions ", "cannot be coerced to a matrix. ", slicing_tip)) ans <- as.array(x, drop=TRUE) if (length(x_dim) == 2L) { dim(ans) <- x_dim dimnames(ans) <- dimnames(x) } else { as.matrix(ans) } ans } ### S3/S4 combo for as.matrix.DelayedArray as.matrix.DelayedArray <- function(x, ...) .from_DelayedArray_to_matrix(x, ...) setMethod("as.matrix", "DelayedArray", .from_DelayedArray_to_matrix) ### S3/S4 combo for as.data.frame.DelayedArray as.data.frame.DelayedArray <- function(x, row.names=NULL, optional=FALSE, ...) as.data.frame(as.array(x, drop=TRUE), row.names=row.names, optional=optional, ...) setMethod("as.data.frame", "DelayedArray", as.data.frame.DelayedArray) ### S3/S4 combo for as.vector.DelayedArray as.vector.DelayedArray <- function(x, mode="any") { ans <- as.array(x, drop=TRUE) as.vector(ans, mode=mode) } setMethod("as.vector", "DelayedArray", as.vector.DelayedArray) ### S3/S4 combo for as.logical.DelayedArray as.logical.DelayedArray <- function(x, ...) as.vector(x, mode="logical", ...) setMethod("as.logical", "DelayedArray", as.logical.DelayedArray) ### S3/S4 combo for as.integer.DelayedArray as.integer.DelayedArray <- function(x, ...) as.vector(x, mode="integer", ...) setMethod("as.integer", "DelayedArray", as.integer.DelayedArray) ### S3/S4 combo for as.numeric.DelayedArray as.numeric.DelayedArray <- function(x, ...) as.vector(x, mode="numeric", ...) setMethod("as.numeric", "DelayedArray", as.numeric.DelayedArray) ### S3/S4 combo for as.complex.DelayedArray as.complex.DelayedArray <- function(x, ...) as.vector(x, mode="complex", ...) setMethod("as.complex", "DelayedArray", as.complex.DelayedArray) ### S3/S4 combo for as.character.DelayedArray as.character.DelayedArray <- function(x, ...) as.vector(x, mode="character", ...) setMethod("as.character", "DelayedArray", as.character.DelayedArray) ### S3/S4 combo for as.raw.DelayedArray as.raw.DelayedArray <- function(x) as.vector(x, mode="raw") setMethod("as.raw", "DelayedArray", as.raw.DelayedArray) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion to sparse matrix (requires the Matrix package) ### .from_DelayedMatrix_to_dgCMatrix <- function(from) { idx <- which(from != 0L) array_ind <- arrayInd(idx, dim(from)) i <- array_ind[ , 1L] j <- array_ind[ , 2L] x <- from[idx] Matrix::sparseMatrix(i, j, x=x, dims=dim(from), dimnames=dimnames(from)) } setAs("DelayedMatrix", "dgCMatrix", .from_DelayedMatrix_to_dgCMatrix) setAs("DelayedMatrix", "sparseMatrix", .from_DelayedMatrix_to_dgCMatrix) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### [[ ### .get_DelayedArray_element <- function(x, i) { i <- normalizeDoubleBracketSubscript(i, x) user_Nindex <- as.list(arrayInd(i, dim(x))) as.vector(.subset_DelayedArray_by_Nindex(x, user_Nindex)) } ### Only support linear subscripting at the moment. ### TODO: Support multidimensional subscripting e.g. x[[5, 15, 2]] or ### x[["E", 15, "b"]]. setMethod("[[", "DelayedArray", function(x, i, j, ...) { dots <- list(...) if (length(dots) > 0L) dots <- dots[names(dots) != "exact"] if (!missing(j) || length(dots) > 0L) stop("incorrect number of subscripts") .get_DelayedArray_element(x, i) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Show ### setMethod("show", "DelayedArray", show_compact_array) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Combining and splitting ### ### Note that combining arrays with c() is NOT an endomorphism! setMethod("c", "DelayedArray", function (x, ..., recursive=FALSE) { if (!identical(recursive, FALSE)) stop(wmsg("\"c\" method for DelayedArray objects ", "does not support the 'recursive' argument")) if (missing(x)) { objects <- list(...) } else { objects <- list(x, ...) } combine_array_objects(objects) } ) setMethod("splitAsList", "DelayedArray", function(x, f, drop=FALSE, ...) splitAsList(as.vector(x), f, drop=drop, ...) ) ### S3/S4 combo for split.DelayedArray split.DelayedArray <- function(x, f, drop=FALSE, ...) splitAsList(x, f, drop=drop, ...) setMethod("split", c("DelayedArray", "ANY"), split.DelayedArray) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Binding ### ### We only support binding DelayedArray objects along the rows or the cols ### at the moment. No binding along an arbitrary dimension yet! (i.e. no ### "abind" method yet) ### ### arbind() and acbind() .DelayedArray_arbind <- function(...) { objects <- unname(list(...)) dims <- get_dims_to_bind(objects, 1L) if (is.character(dims)) stop(wmsg(dims)) DelayedArray(new_SeedBinder(objects, 1L)) } .DelayedArray_acbind <- function(...) { objects <- unname(list(...)) dims <- get_dims_to_bind(objects, 2L) if (is.character(dims)) stop(wmsg(dims)) DelayedArray(new_SeedBinder(objects, 2L)) } setMethod("arbind", "DelayedArray", .DelayedArray_arbind) setMethod("acbind", "DelayedArray", .DelayedArray_acbind) ### rbind() and cbind() setMethod("rbind", "DelayedMatrix", .DelayedArray_arbind) setMethod("cbind", "DelayedMatrix", .DelayedArray_acbind) .as_DelayedMatrix_objects <- function(objects) { lapply(objects, function(object) { if (length(dim(object)) != 2L) stop(wmsg("cbind() and rbind() are not supported on ", "DelayedArray objects that don't have exactly ", "2 dimensions. Please use acbind() or arnind() ", "instead.")) as(object, "DelayedMatrix") }) } .DelayedArray_rbind <- function(...) { objects <- .as_DelayedMatrix_objects(list(...)) do.call("rbind", objects) } .DelayedArray_cbind <- function(...) { objects <- .as_DelayedMatrix_objects(list(...)) do.call("cbind", objects) } setMethod("rbind", "DelayedArray", .DelayedArray_rbind) setMethod("cbind", "DelayedArray", .DelayedArray_cbind) DelayedArray/R/DelayedArray-stats.R0000644000175400017540000000540413175715524020211 0ustar00biocbuildbiocbuild### ========================================================================= ### Statistical methods for DelayedArray objects ### ------------------------------------------------------------------------- ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### The Binomial Distribution ### ### All these methods return a DelayedArray object of the same dimensions ### as their first argument. ### setMethod("dbinom", "DelayedArray", function(x, size, prob, log=FALSE) register_delayed_op(x, "dbinom", Rargs=list(size=size, prob=prob, log=log)) ) setMethod("pbinom", "DelayedArray", function(q, size, prob, lower.tail=TRUE, log.p=FALSE) register_delayed_op(q, "pbinom", Rargs=list(size=size, prob=prob, lower.tail=lower.tail, log.p=log.p)) ) setMethod("qbinom", "DelayedArray", function(p, size, prob, lower.tail=TRUE, log.p=FALSE) register_delayed_op(p, "qbinom", Rargs=list(size=size, prob=prob, lower.tail=lower.tail, log.p=log.p)) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### The Poisson Distribution ### ### All these methods return a DelayedArray object of the same dimensions ### as their first argument. ### setMethod("dpois", "DelayedArray", function(x, lambda, log=FALSE) register_delayed_op(x, "dpois", Rargs=list(lambda=lambda, log=log)) ) setMethod("ppois", "DelayedArray", function(q, lambda, lower.tail=TRUE, log.p=FALSE) register_delayed_op(q, "ppois", Rargs=list(lambda=lambda, lower.tail=lower.tail, log.p=log.p)) ) setMethod("qpois", "DelayedArray", function(p, lambda, lower.tail=TRUE, log.p=FALSE) register_delayed_op(p, "qpois", Rargs=list(lambda=lambda, lower.tail=lower.tail, log.p=log.p)) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### The Logistic Distribution ### ### All these methods return a DelayedArray object of the same dimensions ### as their first argument. ### setMethod("dlogis", "DelayedArray", function(x, location=0, scale=1, log=FALSE) register_delayed_op(x, "dlogis", Rargs=list(location=location, scale=scale, log=log)) ) setMethod("plogis", "DelayedArray", function(q, location=0, scale=1, lower.tail=TRUE, log.p=FALSE) register_delayed_op(q, "plogis", Rargs=list(location=location, scale=scale, lower.tail=lower.tail, log.p=log.p)) ) setMethod("qlogis", "DelayedArray", function(p, location=0, scale=1, lower.tail=TRUE, log.p=FALSE) register_delayed_op(p, "qlogis", Rargs=list(location=location, scale=scale, lower.tail=lower.tail, log.p=log.p)) ) DelayedArray/R/DelayedArray-utils.R0000644000175400017540000004135413175715525020220 0ustar00biocbuildbiocbuild### ========================================================================= ### Common operations on DelayedArray objects ### ------------------------------------------------------------------------- ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### "Ops" group generics ### ### Arith members: "+", "-", "*", "/", "^", "%%", "%/%" ### Compare members: ==, !=, <=, >=, <, > ### Logic members: &, | ### ### Return a DelayedArray object of the same dimensions as 'e1'. .DelayedArray_Ops_with_right_vector <- function(.Generic, e1, e2) { stopifnot(is(e1, "DelayedArray")) e1_class <- class(e1) e2_class <- class(e2) if (!is.vector(e2)) e2 <- as.vector(e2) if (!is.atomic(e2)) stop(wmsg("`", .Generic, "` between ", e1_class, " and ", e2_class, " objects is not supported")) e2_len <- length(e2) if (e2_len == 1L) return(register_delayed_op(e1, .Generic, Rargs=list(e2))) e1_len <- length(e1) if (e2_len > e1_len) stop(wmsg("right object is longer than left object")) e1_nrow <- nrow(e1) if (e1_nrow != 0L) { if (e2_len == 0L || e1_nrow %% e2_len != 0L) stop(wmsg("length of right object is not a divisor ", "of number of rows in left object")) e2 <- rep(e2, length.out=e1_nrow) } register_delayed_op(e1, .Generic, Rargs=list(e2), recycle_along_last_dim=e1@is_transposed) } ### Return a DelayedArray object of the same dimensions as 'e2'. .DelayedArray_Ops_with_left_vector <- function(.Generic, e1, e2) { stopifnot(is(e2, "DelayedArray")) e1_class <- class(e1) e2_class <- class(e2) if (!is.vector(e1)) e1 <- as.vector(e1) if (!is.atomic(e1)) stop(wmsg("`", .Generic, "` between ", e1_class, " and ", e2_class, " objects is not supported")) e1_len <- length(e1) if (e1_len == 1L) return(register_delayed_op(e2, .Generic, Largs=list(e1))) e2_len <- length(e2) if (e1_len > e2_len) stop(wmsg("left object is longer than right object")) e2_nrow <- nrow(e2) if (e2_nrow != 0L) { if (e1_len == 0L || e2_nrow %% e1_len != 0L) stop(wmsg("length of left object is not a divisor ", "of number of rows in right object")) e1 <- rep(e1, length.out=e2_nrow) } register_delayed_op(e2, .Generic, Largs=list(e1), recycle_along_last_dim=e2@is_transposed) } ### Return a DelayedArray object of the same dimensions as 'e1' and 'e2'. .DelayedArray_Ops_COMBINE_seeds <- function(.Generic, e1, e2) { if (!identical(dim(e1), dim(e2))) stop("non-conformable arrays") DelayedArray(new_ConformableSeedCombiner(e1, e2, COMBINING_OP=.Generic)) } .DelayedArray_Ops <- function(.Generic, e1, e2) { e1_dim <- dim(e1) e2_dim <- dim(e2) if (identical(e1_dim, e2_dim)) return(.DelayedArray_Ops_COMBINE_seeds(.Generic, e1, e2)) ## Effective dimensions. effdim_idx1 <- which(e1_dim != 1L) effdim_idx2 <- which(e2_dim != 1L) if ((length(effdim_idx1) == 1L) == (length(effdim_idx2) == 1L)) stop("non-conformable arrays") if (length(effdim_idx1) == 1L) { .DelayedArray_Ops_with_left_vector(.Generic, e1, e2) } else { .DelayedArray_Ops_with_right_vector(.Generic, e1, e2) } } setMethod("Ops", c("DelayedArray", "vector"), function(e1, e2) .DelayedArray_Ops_with_right_vector(.Generic, e1, e2) ) setMethod("Ops", c("vector", "DelayedArray"), function(e1, e2) .DelayedArray_Ops_with_left_vector(.Generic, e1, e2) ) setMethod("Ops", c("DelayedArray", "DelayedArray"), function(e1, e2) .DelayedArray_Ops(.Generic, e1, e2) ) ### Support unary operators "+" and "-". setMethod("+", c("DelayedArray", "missing"), function(e1, e2) register_delayed_op(e1, .Generic, Largs=list(0L)) ) setMethod("-", c("DelayedArray", "missing"), function(e1, e2) register_delayed_op(e1, .Generic, Largs=list(0L)) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### pmax2() and pmin2() ### ### We treat them like the binary operators of the "Ops" group generics. ### setGeneric("pmax2", function(e1, e2) standardGeneric("pmax2")) setGeneric("pmin2", function(e1, e2) standardGeneric("pmin2")) ### Mimicking how the "Ops" members combine the "dim", "names", and "dimnames" ### attributes of the 2 operands. .check_and_combine_dims <- function(e1, e2) { dim1 <- dim(e1) dim2 <- dim(e2) if (is.null(dim1)) return(dim2) if (is.null(dim2)) return(dim1) if (!identical(dim1, dim2)) stop("non-conformable arrays") dim1 } .combine_names <- function(e1, e2) { len1 <- length(e1) len2 <- length(e2) names1 <- names(e1) if (len1 > len2) return(names1) names2 <- names(e2) if (len2 > len1 || is.null(names1)) return(names2) names1 } setMethod("pmax2", c("ANY", "ANY"), function(e1, e2) { ans_dim <- .check_and_combine_dims(e1, e2) ans <- pmax(e1, e2) if (is.null(ans_dim)) { names(ans) <- .combine_names(e1, e2) } else { dim(ans) <- ans_dim dimnames(ans) <- combine_dimnames(list(e1, e2)) } ans } ) setMethod("pmin2", c("ANY", "ANY"), function(e1, e2) { ans_dim <- .check_and_combine_dims(e1, e2) ans <- pmin(e1, e2) if (is.null(ans_dim)) { names(ans) <- .combine_names(e1, e2) } else { dim(ans) <- ans_dim dimnames(ans) <- combine_dimnames(list(e1, e2)) } ans } ) for (.Generic in c("pmax2", "pmin2")) { setMethod(.Generic, c("DelayedArray", "vector"), function(e1, e2) .DelayedArray_Ops_with_right_vector(.Generic, e1, e2) ) setMethod(.Generic, c("vector", "DelayedArray"), function(e1, e2) .DelayedArray_Ops_with_left_vector(.Generic, e1, e2) ) setMethod(.Generic, c("DelayedArray", "DelayedArray"), function(e1, e2) .DelayedArray_Ops(.Generic, e1, e2) ) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Various unary operators + the "Math" and "Math2" groups ### ### All these operations return a DelayedArray object of the same dimensions ### as 'x'. ### .UNARY_OPS <- c("is.na", "is.finite", "is.infinite", "is.nan", "!", "tolower", "toupper") for (.Generic in .UNARY_OPS) { setMethod(.Generic, "DelayedArray", function(x) register_delayed_op(x, .Generic) ) } setMethod("nchar", "DelayedArray", function(x, type="chars", allowNA=FALSE, keepNA=NA) register_delayed_op(x, "nchar", Rargs=list(type=type, allowNA=allowNA, keepNA=keepNA)) ) setMethod("Math", "DelayedArray", function(x) register_delayed_op(x, .Generic) ) .DelayedArray_Math2 <- function(.Generic, x, digits) { stopifnot(is(x, "DelayedArray")) if (!isSingleNumberOrNA(digits)) stop(wmsg("'digits' must be a single numeric")) if (!is.integer(digits)) digits <- as.integer(digits) register_delayed_op(x, .Generic, Rargs=list(digits=digits)) } ### Note that round() and signif() don't use the same default for 'digits'. setMethod("round", "DelayedArray", function(x, digits=0) .DelayedArray_Math2("round", x, digits) ) setMethod("signif", "DelayedArray", function(x, digits=6) .DelayedArray_Math2("signif", x, digits) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### A low-level utility for putting DelayedArray object in a "straight" form ### ### Untranspose the DelayedArray object and put its rows and columns in their ### "native" order. The result is a DelayedArray object where the array ### elements are in the same order as in the seeds. This makes block-processing ### faster if the seeds are on-disk objects where the 1st dimension is the fast ### changing dimension (e.g. 5x faster if the seeds are HDF5ArraySeed objects). ### .straighten_index <- function(i) { i_len <- length(i) if (i_len == 0L) return(i) i_max <- max(i) ## Threshold is a rough estimate obtained empirically. ## TODO: Refine this. if (i_max <= 2L * i_len * log(i_len)) { which(as.logical(tabulate(i, nbins=i_max))) } else { sort(unique(i)) } } .straighten <- function(x, untranspose=FALSE, straighten.index=FALSE) { if (is.array(x)) return(x) if (untranspose) x@is_transposed <- FALSE if (!straighten.index) return(x) x_index <- x@index x_seed_dim <- dim(seed(x)) for (N in x@metaindex) { i <- x_index[[N]] if (is.null(i) || isStrictlySorted(i)) next x_index[[N]] <- .straighten_index(i) } if (!identical(x@index, x_index)) x@index <- x_index x } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### anyNA() ### ### Used in unit tests! .DelayedArray_block_anyNA <- function(x, recursive=FALSE) { APPLY <- anyNA COMBINE <- function(b, block, init, reduced) { init || reduced } init <- FALSE BREAKIF <- identity x <- .straighten(x, untranspose=TRUE, straighten.index=TRUE) block_APPLY_and_COMBINE(x, APPLY, COMBINE, init, BREAKIF) } setMethod("anyNA", "DelayedArray", .DelayedArray_block_anyNA) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### which() ### ### Used in unit tests! .DelayedArray_block_which <- function(x, arr.ind=FALSE, useNames=TRUE) { if (!isTRUEorFALSE(arr.ind)) stop("'arr.ind' must be TRUE or FALSE") if (!isTRUEorFALSE(useNames)) stop("'useNames' must be TRUE or FALSE") APPLY <- base::which COMBINE <- function(b, block, init, reduced) { if (length(reduced) != 0L) { reduced <- reduced + init[["offset"]] part_number <- sprintf("%010d", b) init[[part_number]] <- reduced } init[["offset"]] <- init[["offset"]] + length(block) init } offset <- 0L ## If 'x' is a "long array" (i.e. longer than 2^31), we use an offset of ## type double to avoid integer overflow. x_len <- length(x) if (is.double(x_len)) offset <- as.double(offset) init <- new.env(parent=emptyenv()) init[["offset"]] <- offset init <- block_APPLY_and_COMBINE(x, APPLY, COMBINE, init) stopifnot(identical(x_len, init[["offset"]])) # sanity check rm(list="offset", envir=init) if (length(init) == 0L) { ans <- if (is.integer(x_len)) integer(0) else numeric(0) } else { ans <- unlist(as.list(init, sorted=TRUE), recursive=FALSE, use.names=FALSE) } if (arr.ind) ans <- arrayInd(ans, dim(x), dimnames(x), useNames=useNames) ans } setMethod("which", "DelayedArray", .DelayedArray_block_which) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### "Summary" group generic ### ### Members: max, min, range, sum, prod, any, all ### .collect_objects <- function(x, ...) { if (missing(x)) { objects <- unname(list(...)) } else { objects <- unname(list(x, ...)) } NULL_idx <- which(S4Vectors:::sapply_isNULL(objects)) if (length(NULL_idx) != 0L) objects <- objects[-NULL_idx] is_array_like <- function(x) is(x, "DelayedArray") || is.array(x) if (!all(vapply(objects, is_array_like, logical(1)))) stop("the supplied objects must be array-like objects (or NULLs)") objects } ### Used in unit tests! .DelayedArray_block_Summary <- function(.Generic, x, ..., na.rm=FALSE) { objects <- .collect_objects(x, ...) GENERIC <- match.fun(.Generic) APPLY <- function(block) { ## We get a warning if 'block' is empty (which can't happen, blocks ## can't be empty) or if 'na.rm' is TRUE and 'block' contains only ## NA's or NaN's. reduced <- tryCatch(GENERIC(block, na.rm=na.rm), warning=identity) if (is(reduced, "warning")) return(NULL) reduced } COMBINE <- function(b, block, init, reduced) { if (is.null(init) && is.null(reduced)) return(NULL) GENERIC(init, reduced) } init <- NULL BREAKIF <- function(init) { if (is.null(init)) return(FALSE) switch(.Generic, max= is.na(init) || init == Inf, min= is.na(init) || init == -Inf, range= is.na(init[[1L]]) || all(init == c(-Inf, Inf)), sum=, prod= is.na(init), any= identical(init, TRUE), all= identical(init, FALSE), FALSE) # fallback (actually not needed) } for (x in objects) { if (.Generic %in% c("sum", "prod")) { x <- .straighten(x, untranspose=TRUE) } else { x <- .straighten(x, untranspose=TRUE, straighten.index=TRUE) } init <- block_APPLY_and_COMBINE(x, APPLY, COMBINE, init, BREAKIF) } if (is.null(init)) init <- GENERIC() init } setMethod("Summary", "DelayedArray", function(x, ..., na.rm=FALSE) .DelayedArray_block_Summary(.Generic, x, ..., na.rm=na.rm) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### mean() ### ### Same arguments as base::mean.default(). .DelayedArray_block_mean <- function(x, trim=0, na.rm=FALSE) { if (!identical(trim, 0)) stop("\"mean\" method for DelayedArray objects ", "does not support the 'trim' argument yet") APPLY <- function(block) { tmp <- as.vector(block, mode="numeric") block_sum <- sum(tmp, na.rm=na.rm) block_nval <- length(tmp) if (na.rm) block_nval <- block_nval - sum(is.na(tmp)) c(block_sum, block_nval) } COMBINE <- function(b, block, init, reduced) { init + reduced } init <- numeric(2) # sum and nval BREAKIF <- function(init) is.na(init[[1L]]) x <- .straighten(x, untranspose=TRUE) ans <- block_APPLY_and_COMBINE(x, APPLY, COMBINE, init, BREAKIF) ans[[1L]] / ans[[2L]] } ### S3/S4 combo for mean.DelayedArray mean.DelayedArray <- function(x, trim=0, na.rm=FALSE, ...) .DelayedArray_block_mean(x, trim=trim, na.rm=na.rm, ...) setMethod("mean", "DelayedArray", .DelayedArray_block_mean) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### apply() ### setGeneric("apply", signature="X") .simplify_apply_answer <- function(ans) { if (!all(vapply(ans, is.atomic, logical(1), USE.NAMES=FALSE))) return(ans) # won't simplify ans_lens <- lengths(ans, use.names=FALSE) mat_nrow <- ans_lens[[1L]] if (!all(ans_lens == mat_nrow)) return(ans) # won't simplify mat_data <- unlist(unname(ans)) if (mat_nrow == 0L) return(mat_data) # zero-length atomic vector mat_colnames <- names(ans) if (mat_nrow == 1L) return(setNames(mat_data, mat_colnames)) # atomic vector parallel # to 'ans' ## Simplify as matrix. mat_data_names <- names(mat_data) # comes from the 'ans' inner names if (is.null(mat_data_names)) { mat_rownames <- NULL } else { mat_rownames <- head(mat_data_names, n=mat_nrow) if (!all(mat_data_names == mat_rownames)) mat_rownames <- NULL } if (is.null(mat_rownames) && is.null(mat_colnames)) { mat_dimnames <- NULL } else { mat_dimnames <- list(mat_rownames, mat_colnames) } matrix(mat_data, ncol=length(ans), dimnames=mat_dimnames) } ### MARGIN must be a single integer. .DelayedArray_apply <- function(X, MARGIN, FUN, ...) { FUN <- match.fun(FUN) X_dim <- dim(X) if (!isSingleNumber(MARGIN)) stop("'MARGIN' must be a single integer") if (!is.integer(MARGIN)) MARGIN <- as.integer(MARGIN) if (MARGIN < 1L || MARGIN > length(X_dim)) stop("'MARGIN' must be >= 1 and <= length(dim(X))") if (X_dim[[MARGIN]] == 0L) { ## base::apply seems to be doing something like that! ans <- FUN(X, ...) return(as.vector(ans[0L])) } ## TODO: Try using sapply() instead of lapply(). Maybe we're lucky ## and it achieves the kind of simplification that we're doing with ## .simplify_apply_answer() so we can get rid of .simplify_apply_answer(). ans_names <- dimnames(X)[[MARGIN]] ans <- lapply(setNames(seq_len(X_dim[[MARGIN]]), ans_names), function(i) { Nindex <- vector(mode="list", length=length(X_dim)) Nindex[[MARGIN]] <- i slice <- subset_by_Nindex(X, Nindex, drop=TRUE) dim(slice) <- dim(slice)[-MARGIN] FUN(slice, ...) }) ## Try to simplify the answer. .simplify_apply_answer(ans) } setMethod("apply", "DelayedArray", .DelayedArray_apply) DelayedArray/R/DelayedMatrix-stats.R0000644000175400017540000002130313175715525020374 0ustar00biocbuildbiocbuild### ========================================================================= ### Statistical/summarization methods for DelayedMatrix objects ### ------------------------------------------------------------------------- ### ### Raise an error if invalid input type. Otherwise return "integer", ### "numeric", "double", or "complex". .get_ans_type <- function(x, must.be.numeric=FALSE) { x_type <- type(x) ans_type <- switch(x_type, logical="integer", integer=, numeric=, double=, complex=x_type, stop(wmsg("operation not supported on matrices of type ", x_type))) if (must.be.numeric && !is.numeric(get(ans_type)(0))) stop(wmsg("operation not supported on matrices of type ", x_type)) ans_type } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### row/colSums() and row/colMeans() ### .normarg_dims <- function(dims, method) { if (!identical(dims, 1)) stop("\"", method, "\" method for DelayedMatrix objects ", "does not support the 'dims' argument yet") } ### row/colSums() .DelayedMatrix_block_rowSums <- function(x, na.rm=FALSE, dims=1) { .normarg_dims(dims, "rowSums") if (is(x, "DelayedArray") && x@is_transposed) return(.DelayedMatrix_block_colSums(t(x), na.rm=na.rm, dims=dims)) .get_ans_type(x) # check input type APPLY <- function(m) rowSums(m, na.rm=na.rm) COMBINE <- function(b, m, init, reduced) { init + reduced } init <- numeric(nrow(x)) ans <- colblock_APPLY_and_COMBINE(x, APPLY, COMBINE, init) setNames(ans, rownames(x)) } .DelayedMatrix_block_colSums <- function(x, na.rm=FALSE, dims=1) { .normarg_dims(dims, "colSums") if (is(x, "DelayedArray") && x@is_transposed) return(.DelayedMatrix_block_rowSums(t(x), na.rm=na.rm, dims=dims)) .get_ans_type(x) # check input type colsums_list <- colblock_APPLY(x, colSums, na.rm=na.rm) if (length(colsums_list) == 0L) return(numeric(ncol(x))) unlist(colsums_list, recursive=FALSE) } setMethod("rowSums", "DelayedMatrix", .DelayedMatrix_block_rowSums) setMethod("colSums", "DelayedMatrix", .DelayedMatrix_block_colSums) ### row/colMeans() .DelayedMatrix_block_rowMeans <- function(x, na.rm=FALSE, dims=1) { .normarg_dims(dims, "rowMeans") if (is(x, "DelayedMatrix") && x@is_transposed) return(.DelayedMatrix_block_colMeans(t(x), na.rm=na.rm, dims=dims)) .get_ans_type(x) # check input type APPLY <- function(m) { m_sums <- rowSums(m, na.rm=na.rm) m_nvals <- ncol(m) if (na.rm) m_nvals <- m_nvals - rowSums(is.na(m)) cbind(m_sums, m_nvals) } COMBINE <- function(b, m, init, reduced) { init + reduced } init <- cbind( numeric(nrow(x)), # sums numeric(nrow(x)) # nvals ) ans <- colblock_APPLY_and_COMBINE(x, APPLY, COMBINE, init) setNames(ans[ , 1L] / ans[ , 2L], rownames(x)) } .DelayedMatrix_block_colMeans <- function(x, na.rm=FALSE, dims=1) { .normarg_dims(dims, "colMeans") if (is(x, "DelayedArray") && x@is_transposed) return(.DelayedMatrix_block_rowMeans(t(x), na.rm=na.rm, dims=dims)) .get_ans_type(x) # check input type colmeans_list <- colblock_APPLY(x, colMeans, na.rm=na.rm) if (length(colmeans_list) == 0L) return(rep.int(NaN, ncol(x))) unlist(colmeans_list, recursive=FALSE) } setMethod("rowMeans", "DelayedMatrix", .DelayedMatrix_block_rowMeans) setMethod("colMeans", "DelayedMatrix", .DelayedMatrix_block_colMeans) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Row/column summarization from the matrixStats package ### ### row/colMaxs(), row/colMins(), row/colRanges(), ### row/colProds(), row/colAnys(), row/colAlls(), row/colMedians() ### .fix_type <- function(x, ans_type) { if (ans_type == "integer" && !is.integer(x) && all(is.finite(x))) storage.mode(x) <- ans_type x } ### row/colMaxs() .DelayedMatrix_block_rowMaxs <- function(x, rows=NULL, cols=NULL, na.rm=FALSE, dim.=dim(x)) { if (is(x, "DelayedArray") && x@is_transposed) return(.DelayedMatrix_block_colMaxs(t(x), rows=rows, cols=cols, na.rm=na.rm, dim.=dim.)) ans_type <- .get_ans_type(x, must.be.numeric=TRUE) APPLY <- function(m) rowMaxs(m, na.rm=na.rm) COMBINE <- function(b, m, init, reduced) .fix_type(pmax(init, reduced), ans_type) init <- .fix_type(rep.int(-Inf, nrow(x)), ans_type) ans <- colblock_APPLY_and_COMBINE(x, APPLY, COMBINE, init) setNames(ans, rownames(x)) } .DelayedMatrix_block_colMaxs <- function(x, rows=NULL, cols=NULL, na.rm=FALSE, dim.=dim(x)) { if (is(x, "DelayedArray") && x@is_transposed) return(.DelayedMatrix_block_rowMaxs(t(x), rows=rows, cols=cols, na.rm=na.rm, dim.=dim.)) ans_type <- .get_ans_type(x, must.be.numeric=TRUE) colmaxs_list <- colblock_APPLY(x, colMaxs, na.rm=na.rm) if (length(colmaxs_list) == 0L) return(.fix_type(rep.int(-Inf, ncol(x)), ans_type)) unlist(colmaxs_list, recursive=FALSE) } setGeneric("rowMaxs", signature="x") setGeneric("colMaxs", signature="x") setMethod("rowMaxs", "DelayedMatrix", .DelayedMatrix_block_rowMaxs) setMethod("colMaxs", "DelayedMatrix", .DelayedMatrix_block_colMaxs) ### row/colMins() .DelayedMatrix_block_rowMins <- function(x, rows=NULL, cols=NULL, na.rm=FALSE, dim.=dim(x)) { if (is(x, "DelayedArray") && x@is_transposed) return(.DelayedMatrix_block_colMins(t(x), rows=rows, cols=cols, na.rm=na.rm, dim.=dim.)) ans_type <- .get_ans_type(x, must.be.numeric=TRUE) APPLY <- function(m) rowMins(m, na.rm=na.rm) COMBINE <- function(b, m, init, reduced) .fix_type(pmin(init, reduced), ans_type) init <- .fix_type(rep.int(Inf, nrow(x)), ans_type) ans <- colblock_APPLY_and_COMBINE(x, APPLY, COMBINE, init) setNames(ans, rownames(x)) } .DelayedMatrix_block_colMins <- function(x, rows=NULL, cols=NULL, na.rm=FALSE, dim.=dim(x)) { if (is(x, "DelayedArray") && x@is_transposed) return(.DelayedMatrix_block_rowMins(t(x), rows=rows, cols=cols, na.rm=na.rm, dim.=dim.)) ans_type <- .get_ans_type(x, must.be.numeric=TRUE) colmins_list <- colblock_APPLY(x, colMins, na.rm=na.rm) if (length(colmins_list) == 0L) return(.fix_type(rep.int(Inf, ncol(x)), ans_type)) unlist(colmins_list, recursive=FALSE) } setGeneric("rowMins", signature="x") setGeneric("colMins", signature="x") setMethod("rowMins", "DelayedMatrix", .DelayedMatrix_block_rowMins) setMethod("colMins", "DelayedMatrix", .DelayedMatrix_block_colMins) ### row/colRanges() .DelayedMatrix_block_rowRanges <- function(x, rows=NULL, cols=NULL, na.rm=FALSE, dim.=dim(x)) { if (is(x, "DelayedArray") && x@is_transposed) return(.DelayedMatrix_block_colRanges(t(x), rows=rows, cols=cols, na.rm=na.rm, dim.=dim.)) ans_type <- .get_ans_type(x, must.be.numeric=TRUE) APPLY <- function(m) rowRanges(m, na.rm=na.rm) COMBINE <- function(b, m, init, reduced) { .fix_type(cbind(pmin(init[ , 1L], reduced[ , 1L]), pmax(init[ , 2L], reduced[ , 2L])), ans_type) } init <- .fix_type(matrix(rep(c(Inf, -Inf), each=nrow(x)), ncol=2L), ans_type) ans <- colblock_APPLY_and_COMBINE(x, APPLY, COMBINE, init) setNames(ans, rownames(x)) } .DelayedMatrix_block_colRanges <- function(x, rows=NULL, cols=NULL, na.rm=FALSE, dim.=dim(x)) { if (is(x, "DelayedArray") && x@is_transposed) return(.DelayedMatrix_block_rowRanges(t(x), rows=rows, cols=cols, na.rm=na.rm, dim.=dim.)) ans_type <- .get_ans_type(x, must.be.numeric=TRUE) colranges_list <- colblock_APPLY(x, colRanges, na.rm=na.rm) if (length(colranges_list) == 0L) return(.fix_type(matrix(rep(c(Inf, -Inf), each=ncol(x)), ncol=2L), ans_type)) do.call(rbind, colranges_list) } .rowRanges.useAsDefault <- function(x, ...) matrixStats::rowRanges(x, ...) setGeneric("rowRanges", signature="x", function(x, ...) standardGeneric("rowRanges"), useAsDefault=.rowRanges.useAsDefault ) setGeneric("colRanges", signature="x") setMethod("rowRanges", "DelayedMatrix", .DelayedMatrix_block_rowRanges) setMethod("colRanges", "DelayedMatrix", .DelayedMatrix_block_colRanges) ### TODO: Add more row/column summarization generics/methods. DelayedArray/R/DelayedMatrix-utils.R0000644000175400017540000000447413175715525020410 0ustar00biocbuildbiocbuild### ========================================================================= ### Common operations on DelayedMatrix objects ### ------------------------------------------------------------------------- ### ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Matrix multiplication ### ### We only support multiplication of an ordinary matrix (typically ### small) by a DelayedMatrix object (typically big). Multiplication of 2 ### DelayedMatrix objects is not supported. ### .DelayedMatrix_block_mult_by_left_matrix <- function(x, y) { stopifnot(is.matrix(x), is(y, "DelayedMatrix") || is.matrix(y), ncol(x) == nrow(y)) ans_dim <- c(nrow(x), ncol(y)) ans_dimnames <- list(rownames(x), colnames(y)) ans_type <- typeof(match.fun(type(x))(1) * match.fun(type(y))(1)) sink <- RealizationSink(ans_dim, ans_dimnames, ans_type) on.exit(close(sink)) ## We're going to walk along the columns so need to increase the block ## length so that each block is made of at least one column. max_block_len <- max(get_max_block_length(type(y)), nrow(y)) spacings <- get_max_spacings_for_linear_blocks(dim(y), max_block_len) y_grid <- ArrayRegularGrid(dim(y), spacings) spacings[[1L]] <- ans_dim[[1L]] ans_grid <- ArrayRegularGrid(ans_dim, spacings) # parallel to 'y_grid' nblock <- length(y_grid) # same as 'length(ans_grid)' for (b in seq_len(nblock)) { if (get_verbose_block_processing()) message("Processing block ", b, "/", nblock, " ... ", appendLF=FALSE) y_viewport <- y_grid[[b]] block <- as.matrix(extract_block(y, y_viewport)) block_ans <- x %*% block write_block_to_sink(block_ans, sink, ans_grid[[b]]) if (get_verbose_block_processing()) message("OK") } as(sink, "DelayedArray") } setMethod("%*%", c("DelayedMatrix", "matrix"), function(x, y) t(t(y) %*% t(x)) ) setMethod("%*%", c("matrix", "DelayedMatrix"), .DelayedMatrix_block_mult_by_left_matrix ) setMethod("%*%", c("DelayedMatrix", "DelayedMatrix"), function(x, y) stop(wmsg("multiplication of 2 DelayedMatrix objects is not ", "supported, only multiplication of an ordinary matrix by ", "a DelayedMatrix object at the moment")) ) DelayedArray/R/RleArray-class.R0000644000175400017540000003470013175715525017335 0ustar00biocbuildbiocbuild### ========================================================================= ### RleArray objects ### ------------------------------------------------------------------------- setClass("RleArraySeed", contains="Array", representation( "VIRTUAL", ## Must use upper case or won't be able to extend the class. ## See https://stat.ethz.ch/pipermail/r-devel/2017-June/074383.html DIM="integer", DIMNAMES="list" ) ) ### We don't support long SolidRleArraySeed objects yet! This would first ### require that S4Vectors:::extract_positions_from_Rle() accepts 'pos' as ### a numeric vector. setClass("SolidRleArraySeed", contains="RleArraySeed", representation( rle="Rle" ) ) ### The RleRealizationSink class is a concrete RealizationSink subclass that ### implements realization of an array-like object as an RleArray object that ### will have a ChunkedRleArraySeed seed (once writting to the sink is ### complete). setClass("RleRealizationSink", contains=c("RleArraySeed", "RealizationSink"), representation( type="character", chunks="environment" ) ) ### We support long ChunkedRleArraySeed objects but for now the chunks ### cannot be long. Supporting long chunks would require that ### S4Vectors:::extract_positions_from_Rle() accepts 'pos' as a numeric ### vector. setClass("ChunkedRleArraySeed", contains="RleRealizationSink", representation( ## A numeric vector of length the nb of chunks. Contains the cumulated ## lengths of the chunks so must be "numeric" (and not "integer") to ## support long objects. A chunk cannot be empty so 'breakpoints' must ## contain *strictly* sorted positive values. ## If the object is of length 0, then 'breakpoints' is empty. ## Otherwise, its last element must equal the length of the object. breakpoints="numeric" ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Low-level chunk accessors ### .get_chunk <- function(envir, k) { name <- sprintf("%06d", k) stopifnot(nchar(name) == 6L) get(name, envir=envir, inherits=FALSE) } .get_chunk_lens <- function(envir) { ## Too bad we can't just do 'lengths(envir)' for this. ## Also would have been nice to be able to just do ## 'unlist(eapply(envir, length))' but the list returned by eapply() ## is not guaranteed to be sorted and eapply() does not have a 'sorted' ## argument. So would need to manually sort it. ## Another possibility would be to vapply() on the sorted symbols returned ## by 'ls(envir, sorted=TRUE)'. vapply(seq_len(length(envir)), function(k) length(.get_chunk(envir, k)), numeric(1)) } .set_chunk <- function(envir, k, chunk) { name <- sprintf("%06d", k) stopifnot(nchar(name) == 6L) assign(name, chunk, envir=envir) } .append_chunk <- function(envir, chunk) { .set_chunk(envir, length(envir) + 1L, chunk) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity ### .validate_RleArraySeed <- function(x) { msg <- validate_dim_slot(x, "DIM") if (!isTRUE(msg)) return(msg) msg <- validate_dimnames_slot(x, x@DIM, "DIMNAMES") if (!isTRUE(msg)) return(msg) TRUE } setValidity2("RleArraySeed", .validate_RleArraySeed) .validate_SolidRleArraySeed <- function(x) { ## 'rle' slot. if (!is(x@rle, "Rle")) return(wmsg2("'rle' slot must be an Rle object")) x_len <- length(x) data_len <- length(x@rle) if (x_len != data_len) return(wmsg2("object dimensions [product ", x_len, "] do not ", "match the length of its data [" , data_len, "]")) ## Until S4Vectors:::extract_positions_from_Rle() accepts 'pos' as a ## numeric vector, we cannot support long SolidRleArraySeed objects. if (x_len > .Machine$integer.max) return(wmsg2("long SolidRleArraySeed objects are not supported yet")) TRUE } setValidity2("SolidRleArraySeed", .validate_SolidRleArraySeed) .validate_RleRealizationSink <- function(x) { ## 'type' slot. if (!isSingleString(x@type)) return(wmsg2("'type' slot must be a single string")) ## 'chunks' slot. if (!is.environment(x@chunks)) return(wmsg2("'chunks' slot must be an environment")) # TODO: Validate the content of 'chunks'. TRUE } setValidity2("RleRealizationSink", .validate_RleRealizationSink) .get_data_length_from_breakpoints <- function(breakpoints) { breakpoints_len <- length(breakpoints) if (breakpoints_len == 0L) 0L else breakpoints[[breakpoints_len]] } .validate_ChunkedRleArraySeed <- function(x) { ## 'breakpoints' slot. if (!is.numeric(x@breakpoints) || S4Vectors:::anyMissing(x@breakpoints) || is.unsorted(x@breakpoints, strictly=TRUE) || length(x@breakpoints) != 0L && x@breakpoints[[1L]] <= 0L) return(wmsg2("'x@breakpoints' must be a numeric vector containing ", "strictly sorted positive values")) x_len <- length(x) data_len <- .get_data_length_from_breakpoints(x@breakpoints) if (data_len != x_len) return(wmsg2("length of object data [" , data_len, "] does not ", "match object dimensions [product ", x_len, "]")) chunk_lens <- diff(c(0, x@breakpoints)) # chunk lengths as inferred from # 'breakpoints' ## Until S4Vectors:::extract_positions_from_Rle() accepts 'pos' as a ## numeric vector, the chunks cannot be long Rle objects. if (any(chunk_lens > .Machine$integer.max)) return(wmsg2("ChunkedRleArraySeed objects do not support ", "long chunks yet")) # TODO: Check that the chunk lengths as inferred from 'breakpoints' # actually match the real ones. TRUE } setValidity2("ChunkedRleArraySeed", .validate_ChunkedRleArraySeed) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Getters ### setMethod("dim", "RleArraySeed", function(x) x@DIM) setMethod("dimnames", "RleArraySeed", function(x) { ans <- x@DIMNAMES if (all(S4Vectors:::sapply_isNULL(ans))) return(NULL) ans } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion to Rle objects ### setAs("SolidRleArraySeed", "Rle", function(from) from@rle) ### In practice this coercion is not used on a RleRealizationSink instance ### but on a *ChunkedRleArraySeed* instance (by the coercion method from ### ChunkedRleArraySeed to SolidRleArraySeed defined below in this file). setAs("RleRealizationSink", "Rle", function(from) { ans <- Rle(match.fun(from@type)(0)) if (length(from@chunks) == 0L) return(ans) list_of_Rles <- c(list(ans), unname(as.list(from@chunks, sorted=TRUE))) do.call("c", list_of_Rles) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### subset_seed_as_array() ### .subset_SolidRleArraySeed_as_array <- function(seed, index) { seed_dim <- dim(seed) i <- to_linear_index(index, seed_dim) ans <- S4Vectors:::extract_positions_from_Rle(seed@rle, i, decoded=TRUE) dim(ans) <- get_Nindex_lengths(index, seed_dim) ans } setMethod("subset_seed_as_array", "SolidRleArraySeed", .subset_SolidRleArraySeed_as_array ) .subset_ChunkedRleArraySeed_as_array <- function(seed, index) { seed_dim <- dim(seed) i <- to_linear_index(index, seed_dim) ans <- match.fun(seed@type)(0) if (length(i) != 0L) { part_idx <- get_part_index(i, seed@breakpoints) split_part_idx <- split_part_index(part_idx, length(seed@breakpoints)) chunk_idx <- which(lengths(split_part_idx) != 0L) # chunks to visit res <- lapply(chunk_idx, function(i1) { chunk <- .get_chunk(seed@chunks, i1) ## Because a valid ChunkedRleArraySeed object is guaranteed to not ## contain long chunks at the moment, 'i2' can be represented as ## an integer vector. i2 <- as.integer(split_part_idx[[i1]]) S4Vectors:::extract_positions_from_Rle(chunk, i2, decoded=TRUE) }) res <- c(list(ans), res) ans <- unlist(res, use.names=FALSE)[get_rev_index(part_idx)] } dim(ans) <- get_Nindex_lengths(index, seed_dim) ans } setMethod("subset_seed_as_array", "ChunkedRleArraySeed", .subset_ChunkedRleArraySeed_as_array ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Construction of RleRealizationSink and RleArraySeed objects ### ### NOT exported! RleRealizationSink <- function(dim, dimnames=NULL, type="double") { if (is.null(dimnames)) dimnames <- vector("list", length(dim)) chunks <- new.env(hash=TRUE, parent=emptyenv()) new2("RleRealizationSink", DIM=dim, DIMNAMES=dimnames, type=type, chunks=chunks) } .append_Rle_to_sink <- function(x, sink) { stopifnot(is(x, "Rle")) if (length(x) == 0L) return() # nothing to do if (sink@type == "integer") { run_values <- runValue(x) ## Replace integer-Rle with raw-Rle if this doesn't loose ## information. if (!S4Vectors:::anyMissingOrOutside(run_values, 0L, 255L)) runValue(x) <- as.raw(run_values) } .append_chunk(sink@chunks, x) } ### This coercion is used by the RleArraySeed() constructor and by the ### coercion method from RleRealizationSink to RleArray. setAs("RleRealizationSink", "ChunkedRleArraySeed", function(from) { breakpoints <- cumsum(as.double(.get_chunk_lens(from@chunks))) new2("ChunkedRleArraySeed", from, breakpoints=breakpoints) } ) ### NOT exported! RleArraySeed <- function(rle, dim, dimnames=NULL, chunksize=NULL) { if (!is.numeric(dim)) stop(wmsg("the supplied dim vector must be numeric")) if (!is.integer(dim)) dim <- as.integer(dim) if (is.null(dimnames)) dimnames <- vector("list", length=length(dim)) if (is.null(chunksize)) return(new2("SolidRleArraySeed", DIM=dim, DIMNAMES=dimnames, rle=rle)) type <- typeof(runValue(rle)) sink <- RleRealizationSink(dim, dimnames, type) ## FIXME: breakInChunks() does not accept a 'totalsize' >= 2^31 at the ## moment so this won't work on a long Rle. partitioning <- breakInChunks(length(rle), chunksize) rle_list <- relist(rle, partitioning) for (k in seq_along(rle_list)) .append_Rle_to_sink(rle_list[[k]], sink) as(sink, "ChunkedRleArraySeed") } setAs("ChunkedRleArraySeed", "SolidRleArraySeed", function(from) RleArraySeed(as(from, "Rle"), dim(from), dimnames(from)) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### RleArray and RleMatrix objects ### setClass("RleArray", contains="DelayedArray") setClass("RleMatrix", contains=c("DelayedMatrix", "RleArray")) ### Automatic coercion method from RleArray to RleMatrix silently returns ### a broken object (unfortunately these dummy automatic coercion methods ### don't bother to validate the object they return). So we overwrite it. setAs("RleArray", "RleMatrix", function(from) new2("RleMatrix", from)) ### For internal use only. setMethod("matrixClass", "RleArray", function(x) "RleMatrix") .validate_RleArray <- function(x) { if (!is(seed(x), "RleArraySeed")) return(wmsg2("'seed(x)' must be an RleArraySeed object")) if (!is_pristine(x)) return(wmsg2("'x' carries delayed operations on it")) TRUE } setValidity2("RleArray", .validate_RleArray) setAs("ANY", "RleMatrix", function(from) as(as(from, "RleArray"), "RleMatrix") ) setMethod("DelayedArray", "RleArraySeed", function(seed) new_DelayedArray(seed, Class="RleArray") ) ### Works directly on an RleArraySeed object, in which case it must be called ### with a single argument. RleArray <- function(rle, dim, dimnames=NULL, chunksize=NULL) { if (is(rle, "RleArraySeed")) { if (!(missing(dim) && is.null(dimnames) && is.null(chunksize))) stop(wmsg("RleArray() must be called with a single argument ", "when passed an RleArraySeed object")) seed <- rle } else { seed <- RleArraySeed(rle, dim, dimnames=dimnames, chunksize=chunksize) } DelayedArray(seed) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Realization as an RleArray object ### setMethod("write_block_to_sink", "RleRealizationSink", function(block, sink, viewport) { stopifnot(identical(dim(sink), refdim(viewport)), identical(dim(block), dim(viewport))) ## 'viewport' is ignored! .append_Rle_to_sink(Rle(block), sink) } ) setAs("RleRealizationSink", "RleArray", function(from) RleArray(as(from, "ChunkedRleArraySeed")) ) setAs("RleRealizationSink", "DelayedArray", function(from) as(from, "RleArray")) .as_RleArray <- function(from) { sink <- RleRealizationSink(dim(from), dimnames(from), type(from)) write_array_to_sink(from, sink) as(sink, "RleArray") } setAs("ANY", "RleArray", .as_RleArray) ### Automatic coercion methods from DelayedArray to RleArray and from ### DelayedMatrix to RleMatrix silently return broken objects (unfortunately ### these dummy automatic coercion methods don't bother to validate the object ### they return). So we overwrite them. setAs("DelayedArray", "RleArray", .as_RleArray) setAs("DelayedMatrix", "RleMatrix", .as_RleArray) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Switching between DataFrame and RleMatrix representation ### ### From DataFrame to RleMatrix. .from_DataFrame_to_RleMatrix <- function(from) { as(DelayedArray(from), "RleMatrix") } setAs("DataFrame", "RleMatrix", .from_DataFrame_to_RleMatrix) setAs("DataFrame", "RleArray", .from_DataFrame_to_RleMatrix) ### From RleMatrix to DataFrame. .from_RleMatrix_to_DataFrame <- function(from) { ## We mangle the colnames exactly like as.data.frame() would do. ans_colnames <- colnames(as.data.frame(from[0L, ])) rle <- as(seed(from), "Rle") partitioning <- PartitioningByEnd(nrow(from) * seq_len(ncol(from)), names=ans_colnames) listData <- as.list(relist(rle, partitioning)) new2("DataFrame", listData=listData, nrows=nrow(from), rownames=rownames(from)) } setAs("RleMatrix", "DataFrame", .from_RleMatrix_to_DataFrame) ### From DelayedMatrix to DataFrame. setAs("DelayedMatrix", "DataFrame", function(from) as(as(from, "RleMatrix"), "DataFrame") ) DelayedArray/R/SeedBinder-class.R0000644000175400017540000000565313175715525017625 0ustar00biocbuildbiocbuild### ========================================================================= ### SeedBinder objects ### ------------------------------------------------------------------------- ### ### This class is for internal use only and is not exported. ### setClass("SeedBinder", representation( seeds="list", # List of array-like objects to bind. Each object # is expected to satisfy the "seed contract" i.e. # to support dim(), dimnames(), and # subset_seed_as_array(). along="integer" # Single integer indicating the dimension along # which to bind the seeds. ), prototype( seeds=list(new("array")), along=1L ) ) .validate_SeedBinder <- function(x) { if (length(x@seeds) == 0L) return(wmsg2("'x@seeds' cannot be empty")) if (!(isSingleInteger(x@along) && x@along > 0L)) return(wmsg2("'x@along' must be a single positive integer")) dims <- get_dims_to_bind(x@seeds, x@along) if (is.character(dims)) return(wmsg2(dims)) TRUE } setValidity2("SeedBinder", .validate_SeedBinder) new_SeedBinder <- function(seeds, along) { seeds <- lapply(seeds, remove_pristine_DelayedArray_wrapping) new2("SeedBinder", seeds=seeds, along=along) } ### Implement the "seed contract" i.e. dim(), dimnames(), and ### subset_seed_as_array(). .get_SeedBinder_dim <- function(x) { dims <- get_dims_to_bind(x@seeds, x@along) combine_dims_along(dims, x@along) } setMethod("dim", "SeedBinder", .get_SeedBinder_dim) .get_SeedBinder_dimnames <- function(x) { dims <- get_dims_to_bind(x@seeds, x@along) combine_dimnames_along(x@seeds, dims, x@along) } setMethod("dimnames", "SeedBinder", .get_SeedBinder_dimnames) .subset_SeedBinder_as_array <- function(seed, index) { i <- index[[seed@along]] if (is.null(i)) { ## This is the easy situation. tmp <- lapply(seed@seeds, subset_seed_as_array, index) ## Bind the ordinary arrays in 'tmp'. ans <- do.call(simple_abind, c(tmp, list(along=seed@along))) return(ans) } ## From now on 'i' is a vector of positive integers. dims <- get_dims_to_bind(seed@seeds, seed@along) breakpoints <- cumsum(dims[seed@along, ]) part_idx <- get_part_index(i, breakpoints) split_part_idx <- split_part_index(part_idx, length(breakpoints)) FUN <- function(s) { index[[seed@along]] <- split_part_idx[[s]] subset_seed_as_array(seed@seeds[[s]], index) } tmp <- lapply(seq_along(seed@seeds), FUN) ## Bind the ordinary arrays in 'tmp'. ans <- do.call(simple_abind, c(tmp, list(along=seed@along))) ## Reorder the rows or columns in 'ans'. Nindex <- vector(mode="list", length=length(index)) Nindex[[seed@along]] <- get_rev_index(part_idx) subset_by_Nindex(ans, Nindex) } setMethod("subset_seed_as_array", "SeedBinder", .subset_SeedBinder_as_array) DelayedArray/R/bind-arrays.R0000644000175400017540000001273613175715525016731 0ustar00biocbuildbiocbuild### ========================================================================= ### Bind arrays with an arbitrary number of dimensions along an arbitrary ### dimension ### ------------------------------------------------------------------------- ### ### Return a matrix with one row per dim and one column per object if the ### objects are bindable. Otherwise return a character vector describing why ### the objects are not bindable. This design allows the function to be used ### in the context of a validity method. ### NOT exported but used in the HDF5Array package. get_dims_to_bind <- function(objects, no.check.along) { dims <- lapply(objects, dim) ndims <- lengths(dims) ndim <- ndims[[1L]] if (!all(ndims == ndim)) return(c("all the objects to bind must have ", "the same number of dimensions")) tmp <- unlist(dims, use.names=FALSE) if (is.null(tmp)) return("the objects to bind have no dimensions") dims <- matrix(tmp, nrow=ndim) tmp <- dims[-no.check.along, , drop=FALSE] if (!all(tmp == tmp[ , 1L])) return("the objects to bind have incompatible dimensions") dims } ### Combine the dims the rbind/cbind way. combine_dims_along <- function(dims, along) { ans_dim <- dims[ , 1L] ans_dim[[along]] <- sum(dims[along, ]) ans_dim } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Combine the dimnames of a list of array-like objects ### ### Assume all the arrays in 'objects' have the same number of dimensions. ### NOT exported but used in the HDF5Array package. combine_dimnames <- function(objects) { lapply(seq_along(dim(objects[[1L]])), function(n) { for (x in objects) { dn <- dimnames(x)[[n]] if (!is.null(dn)) return(dn) } NULL }) } ### Combine the dimnames the rbind/cbind way. ### NOT exported but used in the HDF5Array package. combine_dimnames_along <- function(objects, dims, along) { dimnames <- combine_dimnames(objects) along_names <- lapply(objects, function(x) dimnames(x)[[along]]) along_names_lens <- lengths(along_names) if (any(along_names_lens != 0L)) { fix_idx <- which(along_names_lens != dims[along, ]) along_names[fix_idx] <- lapply(dims[along, fix_idx], character) } along_names <- unlist(along_names, use.names=FALSE) if (!is.null(along_names)) dimnames[[along]] <- along_names if (all(S4Vectors:::sapply_isNULL(dimnames))) dimnames <- NULL dimnames } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### simple_abind() ### ### 'objects' is assumed to be a list of vector-like objects. ### 'block_lens' is assumed to be an integer vector parallel to 'objects' ### specifying the block length for each object in 'objects'. In addition the ### length of 'object[[i]]' must be 'k * block_lens[[i]]' (k is the same for ### all the objects). .intertwine_blocks <- function(objects, block_lens) { data <- unlist(objects, recursive=FALSE, use.names=FALSE) objects_lens <- lengths(objects) if (all(objects_lens == 0L)) return(data) k <- objects_lens %/% block_lens k <- unique(k[!is.na(k)]) stopifnot(length(k) == 1L) # sanity check nobject <- length(objects) objects_cumlens <- cumsum(objects_lens) ranges <- lapply(seq_len(nobject), function(i) { width <- block_lens[[i]] offset <- if (i == 1L) 0L else objects_cumlens[[i - 1L]] successiveIRanges(rep.int(width, k), from=offset + 1L) }) ranges <- do.call(c, ranges) i <- as.vector(matrix(seq_len(nobject * k), nrow=nobject, byrow=TRUE)) extractROWS(data, ranges[i]) } ### A stripped-down version of abind::abind(). ### Some differences: ### (a) Treatment of dimnames: simple_abind() treatment of dimnames is ### consistent with base::rbind() and base::cbind(). This is not the ### case for abind::abind() which does some strange things with the ### dimnames. ### (b) Performance: simple_abind() has a little bit more overhead than ### abind::abind(). This makes it slower on small objects. However it ### tends to be slightly faster on big objects. ### NOT exported but used in the HDF5Array package. simple_abind <- function(..., along) { objects <- list(...) object_is_NULL <- S4Vectors:::sapply_isNULL(objects) if (any(object_is_NULL)) objects <- objects[!object_is_NULL] if (length(objects) == 0L) return(NULL) if (length(objects) == 1L) return(objects[[1L]]) ## Check dim compatibility. dims <- get_dims_to_bind(objects, no.check.along=along) if (is.character(dims)) stop(wmsg(dims)) ## Perform the binding. block_lens <- dims[along, ] for (n in seq_len(along - 1L)) block_lens <- block_lens * dims[n, ] ans <- .intertwine_blocks(objects, block_lens) ## Set the dim. dim(ans) <- combine_dims_along(dims, along) ## Combine and set the dimnames. dimnames(ans) <- combine_dimnames_along(objects, dims, along) ans } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Bind arrays along their 1st or 2nd dimension ### setGeneric("arbind", function(...) standardGeneric("arbind")) setGeneric("acbind", function(...) standardGeneric("acbind")) setMethod("arbind", "array", function(...) simple_abind(..., along=1L)) setMethod("acbind", "array", function(...) simple_abind(..., along=2L)) DelayedArray/R/block_processing.R0000644000175400017540000001561613175715525020044 0ustar00biocbuildbiocbuild### ========================================================================= ### Internal utilities for block processing an array ### ------------------------------------------------------------------------- ### ### Unless stated otherwise, nothing in this file is exported. ### ### Default block size in bytes. DEFAULT_BLOCK_SIZE <- 4500000L # 4.5 Mb ### Atomic type sizes in bytes. .TYPE_SIZES <- c( logical=4L, integer=4L, numeric=8L, double=8L, complex=16L, character=8L, # just the overhead of a CHARSXP; doesn't account for the # string data itself raw=1L ) ### Used in HDF5Array! get_max_block_length <- function(type) { type_size <- .TYPE_SIZES[type] idx <- which(is.na(type_size)) if (length(idx) != 0L) { unsupported_types <- unique(type[idx]) in1string <- paste0(unsupported_types, collapse=", ") stop("unsupported type(s): ", in1string) } block_size <- getOption("DelayedArray.block.size", default=DEFAULT_BLOCK_SIZE) as.integer(block_size / type_size) } ### Used in HDF5Array! get_verbose_block_processing <- function() { getOption("DelayedArray.verbose.block.processing", default=FALSE) } ### Used in HDF5Array! set_verbose_block_processing <- function(verbose) { if (!isTRUEorFALSE(verbose)) stop("'verbose' must be TRUE or FALSE") old_verbose <- get_verbose_block_processing() options(DelayedArray.verbose.block.processing=verbose) old_verbose } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Walking on the blocks ### ### 3 utility functions to process array-like objects by block. ### .as_array_or_matrix <- function(x) { if (length(dim(x)) == 2L) return(as.matrix(x)) as.array(x) } ### An lapply-like function. block_APPLY <- function(x, APPLY, ..., sink=NULL, max_block_len=NULL) { APPLY <- match.fun(APPLY) if (is.null(max_block_len)) max_block_len <- get_max_block_length(type(x)) spacings <- get_max_spacings_for_linear_blocks(dim(x), max_block_len) grid <- ArrayRegularGrid(dim(x), spacings) nblock <- length(grid) lapply(seq_len(nblock), function(b) { if (get_verbose_block_processing()) message("Processing block ", b, "/", nblock, " ... ", appendLF=FALSE) viewport <- grid[[b]] block <- extract_block(x, viewport) if (!is.array(block)) block <- .as_array_or_matrix(block) block_ans <- APPLY(block, ...) if (!is.null(sink)) { write_block_to_sink(block_ans, sink, viewport) block_ans <- NULL } if (get_verbose_block_processing()) message("OK") block_ans }) } ### A mapply-like function for conformable arrays. block_MAPPLY <- function(MAPPLY, ..., sink=NULL, max_block_len=NULL) { MAPPLY <- match.fun(MAPPLY) dots <- unname(list(...)) dims <- sapply(dots, dim) x_dim <- dims[ , 1L] if (!all(dims == x_dim)) stop("non-conformable arrays") if (is.null(max_block_len)) { types <- unlist(lapply(dots, type)) max_block_len <- min(get_max_block_length(types)) } spacings <- get_max_spacings_for_linear_blocks(x_dim, max_block_len) grid <- ArrayRegularGrid(x_dim, spacings) nblock <- length(grid) lapply(seq_len(nblock), function(b) { if (get_verbose_block_processing()) message("Processing block ", b, "/", nblock, " ... ", appendLF=FALSE) viewport <- grid[[b]] blocks <- lapply(dots, function(x) { block <- extract_block(x, viewport) if (!is.array(block)) block <- .as_array_or_matrix(block) block }) block_ans <- do.call(MAPPLY, blocks) if (!is.null(sink)) { write_block_to_sink(block_ans, sink, viewport) block_ans <- NULL } if (get_verbose_block_processing()) message("OK") block_ans }) } ### A Reduce-like function. block_APPLY_and_COMBINE <- function(x, APPLY, COMBINE, init, BREAKIF=NULL, max_block_len=NULL) { APPLY <- match.fun(APPLY) COMBINE <- match.fun(COMBINE) if (!is.null(BREAKIF)) BREAKIF <- match.fun(BREAKIF) if (is.null(max_block_len)) max_block_len <- get_max_block_length(type(x)) spacings <- get_max_spacings_for_linear_blocks(dim(x), max_block_len) grid <- ArrayRegularGrid(dim(x), spacings) nblock <- length(grid) for (b in seq_len(nblock)) { if (get_verbose_block_processing()) message("Processing block ", b, "/", nblock, " ... ", appendLF=FALSE) block <- extract_block(x, grid[[b]]) if (!is.array(block)) block <- .as_array_or_matrix(block) reduced <- APPLY(block) init <- COMBINE(b, block, init, reduced) if (get_verbose_block_processing()) message("OK") if (!is.null(BREAKIF) && BREAKIF(init)) { if (get_verbose_block_processing()) message("BREAK condition encountered") break } } init } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Walking on the blocks of columns ### ### 2 convenience wrappers around block_APPLY() and block_APPLY_and_COMBINE() ### to process a matrix-like object by block of columns. ### colblock_APPLY <- function(x, APPLY, ..., sink=NULL) { x_dim <- dim(x) if (length(x_dim) != 2L) stop("'x' must be a matrix-like object") APPLY <- match.fun(APPLY) ## We're going to walk along the columns so need to increase the block ## length so each block is made of at least one column. max_block_len <- max(get_max_block_length(type(x)), x_dim[[1L]]) block_APPLY(x, APPLY, ..., sink=sink, max_block_len=max_block_len) } colblock_APPLY_and_COMBINE <- function(x, APPLY, COMBINE, init) { x_dim <- dim(x) if (length(x_dim) != 2L) stop("'x' must be a matrix-like object") ## We're going to walk along the columns so need to increase the block ## length so each block is made of at least one column. max_block_len <- max(get_max_block_length(type(x)), x_dim[[1L]]) block_APPLY_and_COMBINE(x, APPLY, COMBINE, init, max_block_len=max_block_len) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Block by block realization of an array-like object ### ### Exported! ### Split the array-like object into blocks, then realize and write one block ### at a time to disk. write_array_to_sink <- function(x, sink) { stopifnot(identical(dim(x), dim(sink))) block_APPLY(DelayedArray(x), identity, sink=sink) } DelayedArray/R/realize.R0000644000175400017540000002011513175715525016137 0ustar00biocbuildbiocbuild### ========================================================================= ### realize() ### ------------------------------------------------------------------------- ### ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### RealizationSink objects ### ### Virtual class with no slots. Intended to be extended by implementations ### of DelayedArray backends. Concrete subclasses must implement: ### 1) A constructor function that takes argument 'dim', 'dimnames', and ### 'type'. ### 2) "dim" and "dimnames" methods. ### 3) A "chunk_dim" method (optional). ### 4) A "write_block_to_sink" method. ### 5) A "close" method (optional). ### 6) Coercion to DelayedArray. ### See the arrayRealizationSink class below, or the RleRealizationSink class ### in RleArray-class.R, or the HDF5RealizationSink class in the HDF5Array ### package for examples of concrete RealizationSink subclasses. setClass("RealizationSink", representation("VIRTUAL")) setGeneric("chunk_dim", function(x) standardGeneric("chunk_dim")) ### The default "chunk_dim" method for RealizationSink objects returns NULL ### (i.e. no chunking i.e. implicit chunks of dimensions rep(1, length(dim(x))) ### i.e. 1 array element per chunk). setMethod("chunk_dim", "RealizationSink", function(x) NULL) ### 'block', 'sink', and 'viewport' are expected to be an ordinary array, a ### RealizationSink, and a Viewport object, respectively. They must satisfy: ### ### stopifnot(identical(dim(sink), refdim(viewport)), ### identical(dim(block), dim(viewport))) ### ### Just to be safe, methods should perform this sanity check. setGeneric("write_block_to_sink", signature="sink", function(block, sink, viewport) standardGeneric("write_block_to_sink") ) setGeneric("close") ### The default "close" method for RealizationSink objects is a no-op. setMethod("close", "RealizationSink", function(con) invisible(NULL)) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### arrayRealizationSink objects ### ### The arrayRealizationSink class is a concrete RealizationSink subclass that ### implements an in-memory realization sink. ### setClass("arrayRealizationSink", contains="RealizationSink", representation( result_envir="environment" ) ) .get_arrayRealizationSink_result <- function(sink) { get("result", envir=sink@result_envir) } .set_arrayRealizationSink_result <- function(sink, result) { assign("result", result, envir=sink@result_envir) } setMethod("dim", "arrayRealizationSink", function(x) dim(.get_arrayRealizationSink_result(x)) ) arrayRealizationSink <- function(dim, dimnames=NULL, type="double") { result <- array(get(type)(0), dim=dim, dimnames=dimnames) result_envir <- new.env(parent=emptyenv()) sink <- new("arrayRealizationSink", result_envir=result_envir) .set_arrayRealizationSink_result(sink, result) sink } setMethod("write_block_to_sink", "arrayRealizationSink", function(block, sink, viewport) { stopifnot(identical(dim(sink), refdim(viewport)), identical(dim(block), dim(viewport))) result <- .get_arrayRealizationSink_result(sink) result <- replace_block(result, viewport, block) .set_arrayRealizationSink_result(sink, result) } ) setAs("arrayRealizationSink", "DelayedArray", function(from) DelayedArray(.get_arrayRealizationSink_result(from)) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Get/set the "realization backend" for the current session ### .realization_backend_envir <- new.env(parent=emptyenv()) getRealizationBackend <- function() { BACKEND <- try(get("BACKEND", envir=.realization_backend_envir), silent=TRUE) if (is(BACKEND, "try-error")) return(NULL) BACKEND } .SUPPORTED_REALIZATION_BACKENDS <- data.frame( BACKEND=c("RleArray", "HDF5Array"), package=c("DelayedArray", "HDF5Array"), realization_sink_class=c("RleRealizationSink", "HDF5RealizationSink"), stringsAsFactors=FALSE ) supportedRealizationBackends <- function() { ans <- .SUPPORTED_REALIZATION_BACKENDS[ , c("BACKEND", "package")] backend <- getRealizationBackend() Lcol <- ifelse(ans[ , "BACKEND"] %in% backend, "->", "") Rcol <- ifelse(ans[ , "BACKEND"] %in% backend, "<-", "") cbind(data.frame(` `=Lcol, check.names=FALSE), ans, data.frame(` `=Rcol, check.names=FALSE)) } .load_BACKEND_package <- function(BACKEND) { if (!isSingleString(BACKEND)) stop(wmsg("'BACKEND' must be a single string or NULL")) backends <- .SUPPORTED_REALIZATION_BACKENDS m <- match(BACKEND, backends[ , "BACKEND"]) if (is.na(m)) stop(wmsg("\"", BACKEND, "\" is not a supported backend. Please ", "use supportedRealizationBackends() to get the list of ", "supported \"realization backends\".")) package <- backends[ , "package"][[m]] class_package <- attr(BACKEND, "package") if (is.null(class_package)) { attr(BACKEND, "package") <- package } else if (!identical(package, class_package)) { stop(wmsg("\"package\" attribute on supplied 'BACKEND' is ", "inconsistent with package normally associated with ", "this backend")) } library(package, character.only=TRUE) stopifnot(getClass(BACKEND)@package == package) } .get_REALIZATION_SINK_CONSTRUCTOR <- function(BACKEND) { backends <- .SUPPORTED_REALIZATION_BACKENDS m <- match(BACKEND, backends[ , "BACKEND"]) realization_sink_class <- backends[ , "realization_sink_class"][[m]] package <- backends[ , "package"][[m]] REALIZATION_SINK_CONSTRUCTOR <- get(realization_sink_class, envir=.getNamespace(package), inherits=FALSE) stopifnot(is.function(REALIZATION_SINK_CONSTRUCTOR)) stopifnot(identical(head(formalArgs(REALIZATION_SINK_CONSTRUCTOR), n=3L), c("dim", "dimnames", "type"))) REALIZATION_SINK_CONSTRUCTOR } setRealizationBackend <- function(BACKEND=NULL) { if (is.null(BACKEND)) { remove(list=ls(envir=.realization_backend_envir), envir=.realization_backend_envir) return(invisible(NULL)) } .load_BACKEND_package(BACKEND) REALIZATION_SINK_CONSTRUCTOR <- .get_REALIZATION_SINK_CONSTRUCTOR(BACKEND) assign("BACKEND", BACKEND, envir=.realization_backend_envir) assign("REALIZATION_SINK_CONSTRUCTOR", REALIZATION_SINK_CONSTRUCTOR, envir=.realization_backend_envir) return(invisible(NULL)) } .get_realization_sink_constructor <- function() { if (is.null(getRealizationBackend())) return(arrayRealizationSink) REALIZATION_SINK_CONSTRUCTOR <- try(get("REALIZATION_SINK_CONSTRUCTOR", envir=.realization_backend_envir), silent=TRUE) if (is(REALIZATION_SINK_CONSTRUCTOR, "try-error")) stop(wmsg("This operation requires a \"realization backend\". ", "Please see '?setRealizationBackend' for how to set one.")) REALIZATION_SINK_CONSTRUCTOR } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### realize() ### setGeneric("realize", function(x, ...) standardGeneric("realize")) setMethod("realize", "ANY", function(x, BACKEND=getRealizationBackend()) { x <- DelayedArray(x) if (is.null(BACKEND)) return(DelayedArray(as.array(x))) .load_BACKEND_package(BACKEND) ans <- as(x, BACKEND) ## Temporarily needed because coercion to HDF5Array currently drops ## the dimnames. See R/writeHDF5Array.R in the HDF5Array package for ## more information about this. ## TODO: Remove line below when this is addressed. dimnames(ans) <- dimnames(x) ans } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### RealizationSink constructor ### RealizationSink <- function(dim, dimnames=NULL, type="double") { .get_realization_sink_constructor()(dim, dimnames, type) } DelayedArray/R/show-utils.R0000644000175400017540000002575613175715525016642 0ustar00biocbuildbiocbuild### ========================================================================= ### Compact display of an array-like object ### ------------------------------------------------------------------------- ### ### Nothing in this file is exported. ### .format_as_character_vector <- function(x, justify, quote=TRUE) { x_names <- names(x) x <- as.vector(x) if (quote && typeof(x) == "character" && length(x) != 0L) x <- paste0("\"", x, "\"") names(x) <- x_names format(x, justify=justify) } .format_as_character_matrix <- function(x, justify, quote=TRUE) { x <- as.matrix(x) if (quote && typeof(x) == "character" && length(x) != 0L) { x_dim <- dim(x) x_dimnames <- dimnames(x) x <- paste0("\"", x, "\"") dim(x) <- x_dim dimnames(x) <- x_dimnames } format(x, justify=justify) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### 1D array ### .split_1D_array_names <- function(x_names, idx1, idx2, justify) { make_elt_indices <- function(i) { if (length(i) == 0L) return(character(0)) paste0("[", i, "]", sep="") } if (is.null(x_names)) { s1 <- make_elt_indices(idx1) s2 <- make_elt_indices(idx2) } else { s1 <- x_names[idx1] s2 <- x_names[idx2] } format(c(s1, ".", s2), justify=justify) } .prepare_1D_array_sample <- function(x, n1, n2, justify, quote=TRUE) { x_len <- length(x) x_names <- names(x) if (x_len <= n1 + n2 + 1L) { ans <- .format_as_character_vector(x, justify, quote=quote) idx1 <- seq_len(x_len) idx2 <- integer(0) names(ans) <- .split_1D_array_names(x_names, idx1, idx2, justify)[idx1] } else { idx1 <- seq_len(n1) idx2 <- seq(to=x_len, by=1L, length.out=n2) ans1 <- .format_as_character_vector(x[idx1], justify, quote=quote) ans2 <- .format_as_character_vector(x[idx2], justify, quote=quote) ans <- c(ans1, ".", ans2) names(ans) <- .split_1D_array_names(x_names, idx1, idx2, justify) } ans } .print_1D_array_data <- function(x, n1, n2, quote=TRUE) { stopifnot(length(dim(x)) == 1L) right <- type(x) != "character" justify <- if (right) "right" else "left" out <- .prepare_1D_array_sample(x, n1, n2, justify, quote=quote) print(out, quote=FALSE, right=right, max=length(out)) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### 2D array ### .split_rownames <- function(x_rownames, idx1, idx2, justify) { make_row_indices <- function(i) { if (length(i) == 0L) return(character(0)) paste0("[", i, ",]", sep="") } if (is.null(x_rownames)) { s1 <- make_row_indices(idx1) s2 <- make_row_indices(idx2) } else { s1 <- x_rownames[idx1] s2 <- x_rownames[idx2] } max_width <- max(nchar(s1, type="width"), nchar(s2, type="width")) if (max_width <= 1L) { ellipsis <- "." } else if (max_width == 2L) { ellipsis <- ".." } else { ellipsis <- "..." } format(c(s1, ellipsis, s2), justify=justify) } .split_colnames <- function(x_colnames, idx1, idx2, justify) { make_col_indices <- function(j) { if (length(j) == 0L) return(character(0)) paste0("[,", j, "]", sep="") } if (is.null(x_colnames)) { s1 <- make_col_indices(idx1) s2 <- make_col_indices(idx2) } else { s1 <- x_colnames[idx1] s2 <- x_colnames[idx2] } ans <- format(c(s1, s2), justify=justify) c(head(ans, n=length(s1)), "...", tail(ans, n=length(s2))) } .rsplit_2D_array_data <- function(x, m1, m2, justify, quote=TRUE) { x_nrow <- nrow(x) x_rownames <- rownames(x) idx1 <- seq_len(m1) idx2 <- seq(to=x_nrow, by=1L, length.out=m2) ans1 <- .format_as_character_matrix(x[idx1, , drop=FALSE], justify, quote=quote) ans2 <- .format_as_character_matrix(x[idx2, , drop=FALSE], justify, quote=quote) dots <- rep.int(".", ncol(ans1)) ans <- rbind(ans1, matrix(dots, nrow=1L), ans2) rownames(ans) <- .split_rownames(x_rownames, idx1, idx2, justify) ans } .csplit_2D_array_data <- function(x, n1, n2, justify, quote=TRUE) { x_ncol <- ncol(x) x_colnames <- colnames(x) idx1 <- seq_len(n1) idx2 <- seq(to=x_ncol, by=1L, length.out=n2) ans1 <- .format_as_character_matrix(x[ , idx1, drop=FALSE], justify, quote=quote) ans2 <- .format_as_character_matrix(x[ , idx2, drop=FALSE], justify, quote=quote) dots <- rep.int(".", nrow(ans1)) ans <- cbind(ans1, matrix(dots, ncol=1L), ans2) colnames(ans) <- .split_colnames(x_colnames, idx1, idx2, justify) ans } .split_2D_array_data <- function(x, m1, m2, n1, n2, justify, quote=TRUE) { x_ncol <- ncol(x) x_colnames <- colnames(x) idx1 <- seq_len(n1) idx2 <- seq(to=x_ncol, by=1L, length.out=n2) x1 <- x[ , idx1, drop=FALSE] x2 <- x[ , idx2, drop=FALSE] ans1 <- .rsplit_2D_array_data(x1, m1, m2, justify, quote=quote) ans2 <- .rsplit_2D_array_data(x2, m1, m2, justify, quote=quote) dots <- rep.int(".", nrow(ans1)) ans <- cbind(ans1, matrix(dots, ncol=1L), ans2) colnames(ans) <- .split_colnames(x_colnames, idx1, idx2, justify) ans } .prepare_2D_array_sample <- function(x, m1, m2, n1, n2, justify, quote=TRUE) { ## An attempt at reducing the nb of columns to display when 'x' has ## dimnames so the object fits in getOption("width"). Won't necessarily ## pick up the optimal nb of columns so should be revisited at some point. x_rownames <- rownames(x) if (is.null(x_rownames)) { rownames_width <- 6L } else { rownames_width <- nchar(x_rownames[[1L]]) } half_width <- (getOption("width") - rownames_width) / 2 x_colnames <- colnames(x) if (!is.null(x_colnames)) { colnames1 <- head(x_colnames, n=n1) colnames2 <- tail(x_colnames, n=n2) n1 <- pmax(sum(cumsum(nchar(colnames1) + 1L) < half_width), 1L) n2 <- pmax(sum(cumsum(nchar(colnames2) + 1L) < half_width), 1L) } x_nrow <- nrow(x) x_ncol <- ncol(x) if (x_nrow <= m1 + m2 + 1L) { if (x_ncol <= n1 + n2 + 1L) { ans <- .format_as_character_matrix(x, justify, quote=quote) ## Only needed because of this bug in base::print.default: ## https://stat.ethz.ch/pipermail/r-devel/2016-March/072479.html ## TODO: Remove when the bug is fixed. if (is.null(colnames(ans))) { idx1 <- seq_len(ncol(ans)) idx2 <- integer(0) colnames(ans) <- .split_colnames(NULL, idx1, idx2, justify)[idx1] } } else { ans <- .csplit_2D_array_data(x, n1, n2, justify, quote=quote) } } else { if (x_ncol <= n1 + n2 + 1L) { ans <- .rsplit_2D_array_data(x, m1, m2, justify, quote=quote) ## Only needed because of this bug in base::print.default: ## https://stat.ethz.ch/pipermail/r-devel/2016-March/072479.html ## TODO: Remove when the bug is fixed. if (is.null(colnames(ans))) { idx1 <- seq_len(ncol(ans)) idx2 <- integer(0) colnames(ans) <- .split_colnames(NULL, idx1, idx2, justify)[idx1] } } else { ans <- .split_2D_array_data(x, m1, m2, n1, n2, justify, quote=quote) } } ans } .print_2D_array_data <- function(x, m1, m2, n1, n2, quote=TRUE) { stopifnot(length(dim(x)) == 2L) right <- type(x) != "character" justify <- if (right) "right" else "left" out <- .prepare_2D_array_sample(x, m1, m2, n1, n2, justify, quote=quote) print(out, quote=FALSE, right=right, max=length(out)) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Array of arbitrary dimensions ### .print_2D_slices <- function(x, m1, m2, n1, n2, grid, idx, quote=TRUE) { x_dimnames <- dimnames(x) for (i in idx) { viewport <- grid[[i]] s <- make_string_from_ArrayViewport(viewport, dimnames=x_dimnames) cat(s, "\n", sep="") slice <- extract_block(x, viewport) dim(slice) <- dim(slice)[1:2] .print_2D_array_data(slice, m1, m2, n1, n2, quote=quote) cat("\n") } } .print_nD_array_data <- function(x, n1, n2, quote=TRUE) { x_dim <- dim(x) x_nrow <- x_dim[[1L]] x_ncol <- x_dim[[2L]] if (x_ncol <= 5L) { if (x_nrow <= 3L) { m1 <- m2 <- 3L # print all rows of each slice z1 <- z2 <- 3L # print first 3 and last 3 slices } else { m1 <- m2 <- 2L # print first 2 and last 2 rows of each slice z1 <- z2 <- 1L # print only first and last slices } } else { if (x_nrow <= 3L) { m1 <- m2 <- 2L # print first 2 and last 2 rows of each slice z1 <- z2 <- 2L # print first 2 and last 2 slices } else { m1 <- m2 <- 2L # print first 2 and last 2 rows of each slice z1 <- z2 <- 1L # print only first and last slices } } spacings <- get_max_spacings_for_linear_blocks(x_dim, prod(x_dim[1:2])) grid <- ArrayRegularGrid(x_dim, spacings) nblock <- length(grid) if (nblock <= z1 + z2 + 1L) { idx <- seq_len(nblock) .print_2D_slices(x, m1, m2, n1, n2, grid, idx, quote=quote) } else { idx1 <- seq_len(z1) idx2 <- seq(to=nblock, by=1L, length.out=z2) .print_2D_slices(x, m1, m2, n1, n2, grid, idx1, quote=quote) cat("...\n\n") .print_2D_slices(x, m1, m2, n1, n2, grid, idx2, quote=quote) } } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### show_compact_array() ### .print_array_data <- function(x, n1, n2, quote=TRUE) { x_dim <- dim(x) if (length(x_dim) == 1L) return(.print_1D_array_data(x, n1, n2, quote=quote)) if (length(x_dim) == 2L) { nhead <- get_showHeadLines() ntail <- get_showTailLines() return(.print_2D_array_data(x, nhead, ntail, n1, n2, quote=quote)) } .print_nD_array_data(x, n1, n2, quote=quote) } show_compact_array <- function(object) { object_class <- class(object) object_dim <- dim(object) dim_in1string <- paste0(object_dim, collapse=" x ") object_type <- type(object) if (any(object_dim == 0L)) { cat(sprintf("<%s> %s object of type \"%s\"\n", dim_in1string, object_class, object_type)) } else { cat(sprintf("%s object of %s %s%s:\n", object_class, dim_in1string, object_type, ifelse(any(object_dim >= 2L), "s", ""))) if (object_type == "integer") { n1 <- n2 <- 4L } else { n1 <- 3L n2 <- 2L } .print_array_data(object, n1, n2) } } DelayedArray/R/subset_seed_as_array.R0000644000175400017540000001012313175715525020670 0ustar00biocbuildbiocbuild### ========================================================================= ### subset_seed_as_array() ### ------------------------------------------------------------------------- ### ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Low-level helpers ### ### Return the slice as a list. .extract_data_frame_slice <- function(x, index) { slice <- subset_by_Nindex(x, index) ## Turn into a list and replace factors with character vectors. lapply(slice, as.vector) } .extract_DataFrame_slice <- function(x, index) { slice <- subset_by_Nindex(x, index) slice <- as.data.frame(slice) ## Turn into a list and replace factors with character vectors. lapply(slice, as.vector) } ### Return a list with one list element per column in data frame 'x'. ### All the list elements have length 0. .extract_data_frame_slice0 <- function(x) { slice0 <- x[0L, , drop=FALSE] ## Turn into a list and replace factors with character vectors. lapply(slice0, as.vector) } .extract_DataFrame_slice0 <- function(x) { slice0 <- x[0L, , drop=FALSE] slice0 <- as.data.frame(slice0) if (ncol(slice0) != ncol(x)) stop(wmsg("DataFrame object 'x' can be used as the seed of ", "a DelayedArray object only if as.data.frame(x) ", "preserves the number of columns")) ## Turn into a list and replace factors with character vectors. lapply(slice0, as.vector) } ### Equivalent to 'typeof(as.matrix(x))' but with an almost-zero ### memory footprint (it avoids the cost of turning 'x' into a matrix). .get_data_frame_type <- function(x) { if (ncol(x) == 0L) return("logical") slice0 <- .extract_data_frame_slice0(x) typeof(unlist(slice0, use.names=FALSE)) } ### Equivalent to 'typeof(as.matrix(as.data.frame(x)))' but with an ### almost-zero memory footprint (it avoids the cost of turning 'x' first ### into a data frame then into a matrix). .get_DataFrame_type <- function(x) { if (ncol(x) == 0L) return("logical") slice0 <- .extract_DataFrame_slice0(x) typeof(unlist(slice0, use.names=FALSE)) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### subset_seed_as_array() generic and methods ### ### 'index' is expected to be an unnamed list of subscripts as positive integer ### vectors, one vector per seed dimension. *Missing* list elements are allowed ### and represented by NULLs. ### The "subset_seed_as_array" methods don't need to support anything else. ### They must return an ordinary array. No need to propagate the dimnames. setGeneric("subset_seed_as_array", signature="seed", function(seed, index) standardGeneric("subset_seed_as_array") ) setMethod("subset_seed_as_array", "ANY", function(seed, index) { slice <- subset_by_Nindex(seed, index) as.array(slice) } ) setMethod("subset_seed_as_array", "array", function(seed, index) subset_by_Nindex(seed, index) ) ### Equivalent to ### ### subset_by_Nindex(as.matrix(x), index) ### ### but avoids the cost of turning the full data frame 'x' into a matrix so ### memory footprint stays small when 'index' is small. setMethod("subset_seed_as_array", "data.frame", function(seed, index) { #ans_type <- .get_data_frame_type(seed) slice0 <- .extract_data_frame_slice0(seed) slice <- .extract_data_frame_slice(seed, index) data <- unlist(c(slice0, slice), use.names=FALSE) array(data, dim=get_Nindex_lengths(index, dim(seed))) } ) ### Equivalent to ### ### subset_by_Nindex(as.matrix(as.data.frame(x)), index) ### ### but avoids the cost of turning the full DataFrame 'x' first into a data ### frame then into a matrix so memory footprint stays small when 'index' is ### small. setMethod("subset_seed_as_array", "DataFrame", function(seed, index) { #ans_type <- .get_DataFrame_type(seed) slice0 <- .extract_DataFrame_slice0(seed) slice <- .extract_DataFrame_slice(seed, index) data <- unlist(c(slice0, slice), use.names=FALSE) array(data, dim=get_Nindex_lengths(index, dim(seed))) } ) DelayedArray/R/utils.R0000644000175400017540000001767513175715525015665 0ustar00biocbuildbiocbuild### ========================================================================= ### Some low-level utilities ### ------------------------------------------------------------------------- ### ### Nothing in this file is exported. ### ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Used in validity methods ### ### A modified version of S4Vectors::wmsg() that is better suited for use ### by validity methods. ### TODO: Put this in S4Vectors next to wmsg(). Would probably need a better ### name. wmsg2 <- function(...) paste0("\n ", paste0(strwrap(paste0(c(...), collapse="")), collapse="\n ")) validate_dim_slot <- function(x, slotname="dim") { x_dim <- slot(x, slotname) if (!is.integer(x_dim)) return(wmsg2(sprintf("'%s' slot must be an integer vector", slotname))) if (length(x_dim) == 0L) return(wmsg2(sprintf("'%s' slot cannot be empty", slotname))) if (S4Vectors:::anyMissingOrOutside(x_dim, 0L)) return(wmsg2(sprintf("'%s' slot cannot contain negative or NA values", slotname))) TRUE } validate_dimnames_slot <- function(x, dim, slotname="dimnames") { x_dimnames <- slot(x, slotname) if (!is.list(x_dimnames)) return(wmsg2(sprintf("'%s' slot must be a list", slotname))) if (length(x_dimnames) != length(dim)) return(wmsg2(sprintf("'%s' slot must have ", slotname), "one list element per dimension in the object")) ok <- vapply(seq_along(dim), function(along) { dn <- x_dimnames[[along]] if (is.null(dn)) return(TRUE) is.character(dn) && length(dn) == dim[[along]] }, logical(1), USE.NAMES=FALSE) if (!all(ok)) return(wmsg2(sprintf("each list element in '%s' slot ", slotname), "must be NULL or a character vector along ", "the corresponding dimension in the object")) TRUE } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Manipulating an Nindex ### ### An Nindex is a "multidimensional subsetting index". It's represented as a ### list with one subscript per dimension in the array-like object to subset. ### NULL list elements in it are interpreted as missing subscripts, that is, as ### subscripts that run along the full extend of the corresponding dimension. ### Before an Nindex can be used in a call to `[`, `[<-`, `[[` or `[[<-`, the ### NULL list elements must be replaced with object of class "name". ### ### For use in "[", "[<-", "[[", or "[[<-" methods to extract the user ### supplied subscripts as an Nindex. NULL subscripts are replace with ### integer(0). Missing subscripts are set to NULL. extract_Nindex_from_syscall <- function(call, eframe) { Nindex <- lapply(seq_len(length(call) - 2L), function(i) { subscript <- call[[2L + i]] if (missing(subscript)) return(NULL) subscript <- eval(subscript, envir=eframe, enclos=eframe) if (is.null(subscript)) return(integer(0)) subscript } ) argnames <- tail(names(call), n=-2L) if (!is.null(argnames)) Nindex <- Nindex[!(argnames %in% c("drop", "exact", "value"))] if (length(Nindex) == 1L && is.null(Nindex[[1L]])) Nindex <- Nindex[0L] Nindex } ### Used in HDF5Array! expand_Nindex_RangeNSBS <- function(Nindex) { stopifnot(is.list(Nindex)) RangeNSBS_idx <- which(vapply(Nindex, is, logical(1), "RangeNSBS")) Nindex[RangeNSBS_idx] <- lapply(Nindex[RangeNSBS_idx], as.integer) Nindex } .make_subscripts_from_Nindex <- function(Nindex, x) { stopifnot(is.list(Nindex), length(Nindex) == length(dim(x))) if (is.array(x)) Nindex <- expand_Nindex_RangeNSBS(Nindex) ## Replace NULLs with list elements of class "name". subscripts <- rep.int(alist(foo=), length(Nindex)) names(subscripts ) <- names(Nindex) not_missing_idx <- which(!S4Vectors:::sapply_isNULL(Nindex)) subscripts[not_missing_idx] <- Nindex[not_missing_idx] subscripts } subset_by_Nindex <- function(x, Nindex, drop=FALSE) { subscripts <- .make_subscripts_from_Nindex(Nindex, x) do.call(`[`, c(list(x), subscripts, list(drop=drop))) } ### Return the modified array. replace_by_Nindex <- function(x, Nindex, value) { subscripts <- .make_subscripts_from_Nindex(Nindex, x) do.call(`[<-`, c(list(x), subscripts, list(value=value))) } ### Used in HDF5Array! ### Return the lengths of the subscripts in 'Nindex'. The length of a ### missing subscript is the length it would have after expansion. get_Nindex_lengths <- function(Nindex, dim) { stopifnot(is.list(Nindex), length(Nindex) == length(dim)) ans <- lengths(Nindex) missing_idx <- which(S4Vectors:::sapply_isNULL(Nindex)) ans[missing_idx] <- dim[missing_idx] ans } ### 'dimnames' must be NULL or a list of the same length as 'Nindex'. ### 'along' must be an integer >= 1 and <= length(Nindex). get_Nindex_names_along <- function(Nindex, dimnames, along) { stopifnot(is.list(Nindex)) i <- Nindex[[along]] if (is.null(i)) return(dimnames[[along]]) names(i) } ### Convert 'Nindex' to a "linear index". ### Return the "linear index" as an integer vector if prod(dim) <= ### .Machine$integer.max, otherwise as a vector of doubles. to_linear_index <- function(Nindex, dim) { stopifnot(is.list(Nindex), is.integer(dim), length(Nindex) == length(dim)) if (prod(dim) <= .Machine$integer.max) { ans <- p <- 1L } else { ans <- p <- 1 } for (along in seq_along(Nindex)) { d <- dim[[along]] i <- Nindex[[along]] if (is.null(i)) i <- seq_len(d) ans <- rep((i - 1L) * p, each=length(ans)) + ans p <- p * d } ans } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### combine_array_objects() ### ### 'objects' must be a list of array-like objects that support as.vector(). combine_array_objects <- function(objects) { if (!is.list(objects)) stop("'objects' must be a list") NULL_idx <- which(S4Vectors:::sapply_isNULL(objects)) if (length(NULL_idx) != 0L) objects <- objects[-NULL_idx] if (length(objects) == 0L) return(NULL) unlist(lapply(objects, as.vector), recursive=FALSE, use.names=FALSE) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Translate an index into the whole to an index into the parts ### ### This is .rowidx2rowkeys() from BSgenome/R/OnDiskLongTable-class.R, copied ### here and renamed get_part_index() ! ### TODO: Put it somewhere else where it can be shared. ### .breakpoints2offsets <- function(breakpoints) { breakpoints_len <- length(breakpoints) if (breakpoints_len == 0L) return(integer(0)) c(0L, breakpoints[-breakpoints_len]) } ### breakpoints: integer vector of break points that define the parts. ### idx: index into the whole as an integer vector. ### Return a list of 2 integer vectors parallel to 'idx'. The 1st vector ### contains part numbers and the 2nd vector indices into the parts. ### In addition, if 'breakpoints' has names (part names) then they are ### propagated to the 1st vector. get_part_index <- function(idx, breakpoints) { part_idx <- findInterval(idx, breakpoints + 1L) + 1L names(part_idx) <- names(breakpoints)[part_idx] rel_idx <- idx - .breakpoints2offsets(unname(breakpoints))[part_idx] list(part_idx, rel_idx) } split_part_index <- function(part_index, npart) { ans <- rep.int(list(integer(0)), npart) tmp <- split(unname(part_index[[2L]]), part_index[[1L]]) ans[as.integer(names(tmp))] <- tmp ans } get_rev_index <- function(part_index) { f <- part_index[[1L]] idx <- split(seq_along(f), f) idx <- unlist(idx, use.names=FALSE) rev_idx <- integer(length(idx)) rev_idx[idx] <- seq_along(idx) rev_idx } DelayedArray/R/zzz.R0000644000175400017540000000115713175715525015346 0ustar00biocbuildbiocbuild.onLoad <- function(libname, pkgname) { options(DelayedArray.block.size=DEFAULT_BLOCK_SIZE) } .test <- function() { cat("------------------------------------------------------------------\n") cat("Running tests with realization backend set to \"RleArray\" ...\n") setRealizationBackend("RleArray") BiocGenerics:::testPackage("DelayedArray") cat("\n") cat("------------------------------------------------------------------\n") cat("Running tests with realization backend set to \"HDF5Array\" ...\n") setRealizationBackend("HDF5Array") BiocGenerics:::testPackage("DelayedArray") } DelayedArray/TODO0000644000175400017540000000106313175715525014651 0ustar00biocbuildbiocbuild- Document global option DelayedArray.block.size - Add man page and unit tests for statistical methods defined in DelayedArray-stats.R - Make DelayedArray contain Annotated from S4Vectors. - Add more examples to the man pages (using the toy dataset). - Add unit tests for round() and signif() (Math2 group). - Add vignette. - Support subsetting an arbitrary object by a DelayedArray or DelayedMatrix of type logical. - Support more matrix- and array-like operations. - How well supported are DelayedArray of type "character"? - Add more unit tests. DelayedArray/build/0000755000175400017540000000000013177207140015247 5ustar00biocbuildbiocbuildDelayedArray/build/vignette.rds0000644000175400017540000000044313177207140017607 0ustar00biocbuildbiocbuildJ@7?MMQ(yB  z3KM'6Ү g̞y1\.s=uj :Wa> yRӚUq@+́6Dg4h#.biP);tLd\)G7:M[=$9l\,> bqixBS'zR{`x"J1MAQ zgkINj5GL0wS~?Rc3|m>;[ tVxIJ} kDelayedArray/inst/0000755000175400017540000000000013177207140015125 5ustar00biocbuildbiocbuildDelayedArray/inst/doc/0000755000175400017540000000000013177207140015672 5ustar00biocbuildbiocbuildDelayedArray/inst/doc/Working_with_large_arrays.R0000644000175400017540000000630413177207130023225 0ustar00biocbuildbiocbuild## ----setup, include=FALSE----------------------------------------------------- library(knitr) opts_chunk$set(size="scriptsize") if (!dir.exists("~/mydata")) dir.create("~/mydata") options(width=80) library(Matrix) library(DelayedArray) library(HDF5Array) library(SummarizedExperiment) library(airway) library(pryr) ## ----airway------------------------------------------------------------------- library(airway) data(airway) m <- unname(assay(airway)) dim(m) typeof(m) ## ----airway2------------------------------------------------------------------ head(m, n=4) tail(m, n=4) sum(m != 0) / length(m) ## ----object_size-------------------------------------------------------------- library(pryr) # for object_size() object_size(m) library(Matrix) object_size(as(m, "dgCMatrix")) library(DelayedArray) object_size(as(m, "RleMatrix")) object_size(as(t(m), "RleMatrix")) library(HDF5Array) object_size(as(m, "HDF5Matrix")) ## ----M------------------------------------------------------------------------ M <- as(m, "HDF5Matrix") M ## ----M2----------------------------------------------------------------------- M2 <- M[10:12, 1:5] M2 ## ----seed_of_M2--------------------------------------------------------------- seed(M2) ## ----------------------------------------------------------------------------- M3 <- t(M2) M3 ## ----------------------------------------------------------------------------- seed(M3) ## ----------------------------------------------------------------------------- M4 <- cbind(M3, M[1:5, 6:8]) M4 ## ----------------------------------------------------------------------------- seed(M4) ## ----------------------------------------------------------------------------- M5 <- M == 0 M5 ## ----------------------------------------------------------------------------- seed(M5) ## ----------------------------------------------------------------------------- M6 <- round(M[11:14, ] / M[1:4, ], digits=3) M6 ## ----------------------------------------------------------------------------- seed(M6) ## ----------------------------------------------------------------------------- M6a <- as(M6, "HDF5Array") M6a ## ----------------------------------------------------------------------------- seed(M6a) ## ----------------------------------------------------------------------------- M6b <- as(M6, "RleArray") M6b ## ----------------------------------------------------------------------------- seed(M6b) ## ----------------------------------------------------------------------------- setHDF5DumpFile("~/mydata/M6c.h5") setHDF5DumpName("M6c") M6c <- as(M6, "HDF5Array") ## ----------------------------------------------------------------------------- seed(M6c) h5ls("~/mydata/M6c.h5") ## ----------------------------------------------------------------------------- showHDF5DumpLog() ## ----------------------------------------------------------------------------- DelayedArray:::set_verbose_block_processing(TRUE) colSums(M) ## ----------------------------------------------------------------------------- getOption("DelayedArray.block.size") options(DelayedArray.block.size=1e6) colSums(M) ## ----cleanup, include=FALSE--------------------------------------------------- unlink("~/mydata", recursive=TRUE, force=TRUE) DelayedArray/inst/doc/Working_with_large_arrays.Rnw0000644000175400017540000004451113175715525023606 0ustar00biocbuildbiocbuild%\VignetteEngine{knitr::knitr} %\VignetteIndexEntry{Working with large arrays in R} %\VignetteDepends{knitr,Matrix,DelayedArray,HDF5Array,SummarizedExperiment,airway,pryr} \documentclass[8pt]{beamer} \mode { \usetheme{Madrid} \usecolortheme{whale} } \usepackage{slides} \renewcommand\Rclass[1]{{\texttt{#1}\index{#1 (class)}}} \AtBeginSection[] { \begin{frame} \tableofcontents[currentsection] \end{frame} } \title{Working with large arrays in R} \subtitle{A look at HDF5Array/RleArray/DelayedArray objects} \author{Herv\'e Pag\`es\\ \href{mailto:hpages@fredhutch.org}{hpages@fredhutch.org}} \institute{Bioconductor conference\\Boston} \date{July 2017} \begin{document} <>= library(knitr) opts_chunk$set(size="scriptsize") if (!dir.exists("~/mydata")) dir.create("~/mydata") options(width=80) library(Matrix) library(DelayedArray) library(HDF5Array) library(SummarizedExperiment) library(airway) library(pryr) @ \maketitle \frame{\tableofcontents} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Motivation and challenges} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{frame}[fragile] \frametitle{Motivation and challenges} R ordinary {\bf matrix} or {\bf array} is not suitable for big datasets: \begin{block}{} \begin{itemize} \item 10x Genomics dataset (single cell experiment): 30,000 genes x 1.3 million cells = 36.5 billion values \item in an ordinary integer matrix ==> 136G in memory! \end{itemize} \end{block} \bigskip Need for alternative containers: \begin{block}{} \begin{itemize} \item but at the same time, the object should be (almost) as easy to manipulate as an ordinary matrix or array \item {\em standard R matrix/array API}: \Rcode{dim}, \Rcode{dimnames}, \Rcode{t}, \Rcode{is.na}, \Rcode{==}, \Rcode{+}, \Rcode{log}, \Rcode{cbind}, \Rcode{max}, \Rcode{sum}, \Rcode{colSums}, etc... \item not limited to 2 dimensions ==> also support arrays of arbitrary number of dimensions \end{itemize} \end{block} \bigskip 2 approaches: {\bf in-memory data} vs {\bf on-disk data} \end{frame} \begin{frame}[fragile] \frametitle{Motivation and challenges} \centerline{\bf In-memory data} \begin{block}{} \begin{itemize} \item a 30k x 1.3M matrix might still fit in memory if the data can be efficiently compressed \item example: sparse data (small percentage of non-zero values) ==> {\em sparse representation} (storage of non-zero values only) \item example: data with long runs of identical values ==> {\em RLE compression (Run Length Encoding)} \item choose the {\em smallest type} to store the values: \Rcode{raw} (1 byte) < \Rcode{integer} (4 bytes) < \Rcode{double} (8 bytes) \item if using {\em RLE compression}: \begin{itemize} \item choose the {\em best orientation} to store the values: {\em by row} or {\em by column} (one might give better compression than the other) \item store the data by chunk ==> opportunity to pick up {\em best type} and {\em best orientation} on a chunk basis (instead of for the whole data) \end{itemize} \item size of 30k x 1.3M matrix in memory can be reduced from 136G to 16G! \end{itemize} \end{block} \end{frame} \begin{frame}[fragile] \frametitle{Motivation and challenges} \centerline{\bf Examples of in-memory containers} \bigskip {\bf dgCMatrix} container from the \Biocpkg{Matrix} package: \begin{block}{} \begin{itemize} \item sparse matrix representation \item non-zero values stored as \Rcode{double} \end{itemize} \end{block} \bigskip {\bf RleArray} and {\bf RleMatrix} containers from the \Biocpkg{DelayedArray} package: \begin{block}{} \begin{itemize} \item use RLE compression \item arbitrary number of dimensions \item type of values: any R atomic type (\Rcode{integer}, \Rcode{double}, \Rcode{logical}, \Rcode{complex}, \Rcode{character}, and \Rcode{raw}) \end{itemize} \end{block} \end{frame} \begin{frame}[fragile] \frametitle{Motivation and challenges} \centerline{\bf On-disk data} \bigskip However... \begin{itemize} \item if data is too big to fit in memory (even after compression) ==> must use {\em on-disk representation} \item challenge: should still be (almost) as easy to manipulate as an ordinary matrix! ({\em standard R matrix/array API}) \end{itemize} \end{frame} \begin{frame}[fragile] \frametitle{Motivation and challenges} \centerline{\bf Examples of on-disk containers} \bigskip Direct manipulation of an {\bf HDF5 dataset} via the \Biocpkg{rhdf5} API. Low level API! \bigskip {\bf HDF5Array} and {\bf HDF5Matrix} containers from the \Biocpkg{HDF5Array} package: \begin{block}{} Provide access to the HDF5 dataset via an API that mimics the standard R matrix/array API \end{block} \end{frame} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Memory footprint} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{frame}[fragile] \frametitle{Memory footprint} \centerline{\bf The "airway" dataset} \begin{columns}[t] \begin{column}{0.36\textwidth} \begin{exampleblock}{} <>= library(airway) data(airway) m <- unname(assay(airway)) dim(m) typeof(m) @ \end{exampleblock} \end{column} \begin{column}{0.52\textwidth} \begin{exampleblock}{} <>= head(m, n=4) tail(m, n=4) sum(m != 0) / length(m) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{Memory footprint} \centerline{{\bf dgCMatrix} vs {\bf RleMatrix} vs {\bf HDF5Matrix}} \begin{columns}[t] \begin{column}{0.60\textwidth} \begin{exampleblock}{} <>= library(pryr) # for object_size() object_size(m) library(Matrix) object_size(as(m, "dgCMatrix")) library(DelayedArray) object_size(as(m, "RleMatrix")) object_size(as(t(m), "RleMatrix")) library(HDF5Array) object_size(as(m, "HDF5Matrix")) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{Memory footprint} Some limitations of the sparse matrix implementation in the \Biocpkg{Matrix} package: \begin{block}{} \begin{itemize} \item non-zero values always stored as \Rcode{double}, the most memory consuming type \item number of non-zero values must be $< 2^{31}$ \item limited to 2 dimensions: no support for arrays of arbitrary number of dimensions \end{itemize} \end{block} \end{frame} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{RleArray and HDF5Array objects} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} RleMatrix/RleArray and HDF5Matrix/HDF5Array provide: \begin{block}{} \begin{itemize} \item support all R atomic types \item no limits in size (but each dimension must be $< 2^{31}$) \item arbitrary number of dimensions \end{itemize} \end{block} \bigskip And also: \begin{block}{} \begin{itemize} \item {\bf delayed operations} \item {\bf block-processing} (behind the scene) \item TODO: multicore block-processing (sequential only at the moment) \end{itemize} \end{block} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \centerline{\bf Delayed operations} \bigskip \centerline{We start with HDF5Matrix object \Rcode{M}:} \begin{columns}[t] \begin{column}{0.60\textwidth} \begin{exampleblock}{} <>= M <- as(m, "HDF5Matrix") M @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} Subsetting is delayed: \begin{columns}[t] \begin{column}{0.40\textwidth} \begin{exampleblock}{} <>= M2 <- M[10:12, 1:5] M2 @ \end{exampleblock} \end{column} \begin{column}{0.48\textwidth} \begin{exampleblock}{} <>= seed(M2) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} Transposition is delayed: \begin{columns}[t] \begin{column}{0.40\textwidth} \begin{exampleblock}{} <<>>= M3 <- t(M2) M3 @ \end{exampleblock} \end{column} \begin{column}{0.48\textwidth} \begin{exampleblock}{} <<>>= seed(M3) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \Rcode{cbind()} / \Rcode{rbind()} are delayed: \begin{columns}[t] \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= M4 <- cbind(M3, M[1:5, 6:8]) M4 @ \end{exampleblock} \end{column} \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= seed(M4) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} All the operations in the following groups are delayed: \begin{itemize} \item \Rcode{Arith} (\Rcode{+}, \Rcode{-}, ...) \item \Rcode{Compare} (\Rcode{==}, \Rcode{<}, ...) \item \Rcode{Logic} (\Rcode{\&}, \Rcode{|}) \item \Rcode{Math} (\Rcode{log}, \Rcode{sqrt}) \item and more ... \end{itemize} \begin{columns}[t] \begin{column}{0.42\textwidth} \begin{exampleblock}{} <<>>= M5 <- M == 0 M5 @ \end{exampleblock} \end{column} \begin{column}{0.47\textwidth} \begin{exampleblock}{} <<>>= seed(M5) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \begin{columns}[t] \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= M6 <- round(M[11:14, ] / M[1:4, ], digits=3) M6 @ \end{exampleblock} \end{column} \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= seed(M6) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \centerline{\bf Realization} \bigskip Delayed operations can be {\bf realized} by coercing the DelayedMatrix object to HDF5Array: \begin{columns}[t] \begin{column}{0.40\textwidth} \begin{exampleblock}{} <<>>= M6a <- as(M6, "HDF5Array") M6a @ \end{exampleblock} \end{column} \begin{column}{0.48\textwidth} \begin{exampleblock}{} <<>>= seed(M6a) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \bigskip ... or by coercing it to RleArray: \begin{columns}[t] \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= M6b <- as(M6, "RleArray") M6b @ \end{exampleblock} \end{column} \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= seed(M6b) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \centerline{\bf Controlling where HDF5 datasets are realized} \bigskip {\em HDF5 dump management utilities}: a set of utilities to control where HDF5 datasets are written to disk. \begin{columns}[t] \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= setHDF5DumpFile("~/mydata/M6c.h5") setHDF5DumpName("M6c") M6c <- as(M6, "HDF5Array") @ \end{exampleblock} \end{column} \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= seed(M6c) h5ls("~/mydata/M6c.h5") @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \centerline{\Rcode{showHDF5DumpLog()}} \begin{exampleblock}{} <<>>= showHDF5DumpLog() @ \end{exampleblock} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \centerline{\bf Block processing} \bigskip The following operations are NOT delayed. They are implemented via a {\em block processing} mechanism that loads and processes one block at a time: \begin{itemize} \item operations in the \Rcode{Summary} group (\Rcode{max}, \Rcode{min}, \Rcode{sum}, \Rcode{any}, \Rcode{all}) \item \Rcode{mean} \item Matrix row/col summarization operations (\Rcode{col/rowSums}, \Rcode{col/rowMeans}, ...) \item \Rcode{anyNA}, \Rcode{which} \item \Rcode{apply} \item and more ... \end{itemize} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \begin{columns}[t] \begin{column}{0.75\textwidth} \begin{exampleblock}{} <<>>= DelayedArray:::set_verbose_block_processing(TRUE) colSums(M) @ \end{exampleblock} Control the block size: \begin{exampleblock}{} <<>>= getOption("DelayedArray.block.size") options(DelayedArray.block.size=1e6) colSums(M) @ \end{exampleblock} \end{column} \end{columns} \end{frame} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Hands-on} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{frame}[fragile] \frametitle{Hands-on} \begin{block}{} 1. Load the "airway" dataset. \end{block} \begin{block}{} 2. It's wrapped in a SummarizedExperiment object. Get the count data as an ordinary matrix. \end{block} \begin{block}{} 3. Wrap it in an HDF5Matrix object: (1) using \Rcode{writeHDF5Array()}; then (2) using coercion. \end{block} \begin{block}{} 4. When using coercion, where has the data been written on disk? \end{block} \begin{block}{} 5. See \Rcode{?setHDF5DumpFile} for how to control the location of "automatic" HDF5 datasets. Try to control the destination of the data when coercing. \end{block} \end{frame} \begin{frame}[fragile] \frametitle{Hands-on} \begin{block}{} 6. Use \Rcode{showHDF5DumpLog()} to see all the HDF5 datasets written to disk during the current session. \end{block} \bigskip \begin{block}{} 7. Try some operations on the HDF5Matrix object: (1) some delayed ones; (2) some non-delayed ones (block processing). \end{block} \bigskip \begin{block}{} 8. Use \Rcode{DelayedArray:::set\_verbose\_block\_processing(TRUE)} to see block processing in action. \end{block} \bigskip \begin{block}{} 9. Control the block size via \Rcode{DelayedArray.block.size} global option. \end{block} \end{frame} \begin{frame}[fragile] \frametitle{Hands-on} \begin{block}{} 10. Stick the HDF5Matrix object back in the SummarizedExperiment object. The resulting object is an "HDF5-backed SummarizedExperiment object". \end{block} \bigskip \begin{block}{} 11. The HDF5-backed SummarizedExperiment object can be manipulated (almost) like an in-memory SummarizedExperiment object. Try \Rcode{[}, \Rcode{cbind}, \Rcode{rbind} on it. \end{block} \bigskip \begin{block}{} 12. The \Biocpkg{SummarizedExperiment} package provides \Rcode{saveHDF5SummarizedExperiment} to save a SummarizedExperiment object (HDF5-backed or not) as an HDF5-backed SummarizedExperiment object. Try it. \end{block} \end{frame} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{DelayedArray/HDF5Array: Future developments} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{frame}[fragile] \frametitle{Future developments} \centerline{\bf Block processing improvements} \begin{block}{} Block genometry: (1) better by default, (2) let the user have more control on it \end{block} \begin{block}{} Support multicore \end{block} \begin{block}{} Expose it: \Rcode{blockApply()} \end{block} \end{frame} \begin{frame}[fragile] \frametitle{Future developments} \centerline{\bf HDF5Array improvements} \begin{block}{} Store the \Rcode{dimnames} in the HDF5 file (in {\em HDF5 Dimension Scale datasets} - \url{https://www.hdfgroup.org/HDF5/Tutor/h5dimscale.html}) \end{block} \begin{block}{} Use better default chunk geometry when realizing an HDF5Array object \end{block} \begin{block}{} Block processing should take advantage of the chunk geometry (e.g. \Rcode{realize()} should use blocks that are clusters of chunks) \end{block} \begin{block}{} Unfortunately: not possible to support multicore realization at the moment (HDF5 does not support concurrent writing to a dataset yet) \end{block} \end{frame} \begin{frame}[fragile] \frametitle{Future developments} \centerline{\bf RleArray improvements} \begin{block}{} Let the user have more control on the chunk geometry when constructing/realizing an RleArray object \end{block} \begin{block}{} Like for HDF5Array objects, block processing should take advantage of the chunk geometry \end{block} \begin{block}{} Support multicore realization \end{block} \begin{block}{} Provide C/C++ low-level API for direct row/column access from C/C++ code (e.g. from the \Biocpkg{beachmat} package) \end{block} \end{frame} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% <>= unlink("~/mydata", recursive=TRUE, force=TRUE) @ \end{document} DelayedArray/inst/doc/Working_with_large_arrays.pdf0000644000175400017540000054515613177207140023613 0ustar00biocbuildbiocbuild%PDF-1.5 % 35 0 obj << /Type /XObject /Subtype /Form /BBox [0 0 5669.291 8] /FormType 1 /Matrix [1 0 0 1 0 0] /Resources 36 0 R /Length 15 /Filter /FlateDecode >> stream xP( endstream endobj 37 0 obj << /Type /XObject /Subtype /Form /BBox [0 0 8 8] /FormType 1 /Matrix [1 0 0 1 0 0] /Resources 38 0 R /Length 15 /Filter /FlateDecode >> stream xP( endstream endobj 39 0 obj << /Type /XObject /Subtype /Form /BBox [0 0 16 16] /FormType 1 /Matrix [1 0 0 1 0 0] /Resources 40 0 R /Length 15 /Filter /FlateDecode >> stream xP( endstream endobj 65 0 obj << /Length 1612 /Filter /FlateDecode >> stream xYKS7q9̠hM9SXvb` ء59KG*K窚ɋ Jd$pbީj d @ZVK%&̋_9D-!ak &؏7"ٮ5 E9TKF̌$m @k2@hg^$Li 51WuKMwr^& _ޜZ#\74f^Lbm RԬe8hg8z2[rg/J3VT|xgR@|Զhv$T/@dZPWi!H;Z/?"-:wawZDFx$dO7\bj: z+ =LbE?ŋ/&b,GJdyHY^VxnUk0;+@]J`'aDz5 FHDc/?5 Uf{@DZ5yPkg<8hW3m! A &*µ)qt,>?zՎ ;Hf~C'3?%2bpų|l,[4 uɟ U uHP5+mv a_[U\ӳ% PbYD$xp>vzC_Ŀ[c3quݒxECSI=_C~%uSPRZEN'Mηx44+7ǥ畉1Q*#KƣNٛ y M!q jpyAKVM(VDokdw }5Lсy'9(&n$(MՎjU컦ϥ4]$}?W%~OF6ʏ5y*TT=*)m0E#dXm> stream xP( endstream endobj 106 0 obj << /Length 1479 /Filter /FlateDecode >> stream xY[Oc7~W1y>uW"J@ڇn!ZB>H-+c{<`c&د;b^& -󝣅Idqv̺5+z'3!%cJq u50-$aMaKD wJ1@r1;b;G4kA'g((`䩹A!x6AnD*c7X+3Ucag ,X),Mfbb]AtO+sM9e_9e %DiZllB\\ԧ4b)yU p si%ZQU'cg-il}i(zxhq44;ڀeS\HBm;scHdC!0 oF۾HM)n}'(TY"Ef{SuBj. ݈U!HTt1<HAБ/1xP䜥1y?Nט,aiW[ 3Rys|WF= e>E4CS,mz(z8wkF\]a1.;jGVT;p*ɫDMYd|u_,lwф՗w/O X6@bD׾`u4ƾJ;.)zT2"zm ϰ(SSSe8zH/ e4-(y]f³kDpWwkp(>xОz+ȸAW1q\bt+&@Zg5.IG1媍6xȍ1n0tJ'|=r,?Nb`;=R2W,&b1KCZ&?VkE_bw 7u4|P-钾)גog‹IEVB{Y/x!t7"./xcB-|#/b$/ˆ I $ngeGьh>OE01T,4i,iQ+(ůQNPmq8(uqZXj۵~ɿ-^e)D_+ƫ8v[*}úFhGc s endstream endobj 113 0 obj << /Type /XObject /Subtype /Form /BBox [0 0 9.2 9.2] /FormType 1 /Matrix [1 0 0 1 0 0] /Resources 114 0 R /Length 15 /Filter /FlateDecode >> stream xP( endstream endobj 143 0 obj << /Length 1509 /Filter /FlateDecode >> stream xYYo7~ ѧ&p]@A]˒[K# $W[c%Cr8pȐ0kj-PFP'5VP. ¤k*H|, IyZ\\#u\d؋e$)"|SzQ5AFٺMYq:2 ~ΉiCNӛ\Y8ؙfyF\-+| yw /itпD< øC3qp"I5 \(qFPPednW`ǔԙ2!"UpH [^iԮL,T()ꝃO{ )s< n<_e h(:0ny'^C{W-r pInBu FY,6t{RNK|W ^G8 wQ[ [p'6c5cY2H/(~,q%xg;ybϞlq*7caW ^"Āo]B5~@U*h@U L Բ^@-~\Te4zqB|2BZ:ç9n OȾ{m,s X^eHb ^X.~\e#jy!(' C)KQh- [KسmnQqV>!Gzi/ݞsL0>BP r ]ߠん]휁 ngo꿢)/|l˻u=W,+Z>'`뿲 /n9F]GW&dW3Q: ?D캋!,CݯW5>=4LOܸ8)geЇ"W p>Mu{I BIgێ-X@6a[_2fe"o KТh݂)ADBIk \׷ﳖvQbqDP:g6Zxڲz޴ tSpu-@\Y @+ }jO+c endstream endobj 11 0 obj << /Type /ObjStm /N 100 /First 841 /Length 2170 /Filter /FlateDecode >> stream xZ]s۸}ׯcPdl3lNgA+12顩4=G%;V[e"A.=Hc*)PFh%6 DD ~(&iI# FqtHB; 0Axk(4KaPzPr2E?06A~:YvpԲ #A9;$0>#RE'%Š4hwJA9P $2Pҁ%1Xphe[[ S@_OQ/\ )QW:r=cDo1 > pp#F1QZAEIDD0pm<Ϙb#< ѐEJ0SX 1jآ0~3-y/!/jPQ(*SsUrxq) G)1#ÚC˭Q`B$ыӠzm}(,)X(n5la(p_S{7|;A\v}<}ѷz=QmY7ԕ,K/M7<&M-XΆiUV/oJku޴_ŧ.ICjm_{WtjѤOM}Mok5˅Wisq^7=Iq(ʃIwh{{l8ԧ=E_E%H?7Ӧ=*T'kl·ZKOظiǗ\`V`އ lnV Rc ſZ?yWǸ?_7# LG͸(>jtw߀)?R~xs N͖RX,es-}b^pc2"];q!qyb\żuyvYȞbaxZ 0 u,<5(f֎K~5Tu󥿷AE#<x |;L-POuthҍǣ0p}ae*T*M(6؄bM(6؄K(&.8ۤciUۇCǘ pBP83) g"p'MDnonCqŕ6HWHL-׊q6 2OĀnZD.ĵke:SxpX΍Aߧ)`ÿitv?l֍Ί=}69✇s "*pIiO}3SR9շS:GgƖ![52 뺪E@vHYϠ<@2W,PhSioBZ2;'}6;Bϻ+lEX}YC0 SRyy|r zU4+lc Wt$( ߣ$d"@Fm~)yP!FjQftUXG5ؽNTq%ݲ\$xt$ҦIit'CR:Bڕ16{L(1ĄJL(1Ą Q% '#|2 &lJ)[蝞)z mwzNO);=e5=e-m2mh-I "N;!3Ta] t$LF^z)I8ۓOm+{ &@~K+"P{KOt6$++g+n(%wO7@>.&3WHK8^KE6qqX{;M\Cry,> stream xP( endstream endobj 174 0 obj << /Length 2607 /Filter /FlateDecode >> stream xZoG_&ޙ.. pЇ=(kYՒlKNH~h%vڦE xgKr8pYbZZ(PV2L!+Ʉݤ<8zrdnZ~/iZ+ŹC9CYt(RLySx[ŀN )L@1i=h(@*$ n0iqpNu0CIf sІ̣VFN8`bj &w8S hG!ÚHZcJdx+ G">9f9*p!_ 2WNo?d93,<{уei .Xsۅm&*-#)It*ij/[9oWn; }nZ Hpv.-aMNIDiRV4aHja9іEJ@RvIg2/XSZX|͠MtϨ LKI\_,e[6Opm!5*(RT~Qe۲;.)Uz"Nn|/ _f|9FΗɇm"<3p=!?~jv!J=)d#{NQ? xOӰ<wM%{}G-`w]踳>0Y!5V9l{qBC `/U YUQݚn`iGt HP'LF'6f5# {Q>%?syF`J?PkDUanK@HF3'ׇH-&I#ZBL,tV84 c#8B4R[蕏 .OD/b ¦B¦ygBUaq( e Eb(&o2 1 9“I@?k#`0ܘ iOYc/ENض`ِ ibY85iiXl%xOdr݇4)waJ8#Zi2yTľ<4|ǽ7l1߰k2+@F6hr8 ?C(-s1,;yꈊ 0\Q晫#:<h:dX 4d3怲 Tޯc-I_M _G7G*Ү?g@h%1 2hFӄ6D<1I}&"F\nbyHsGGtIz)󁼷L>jYVW䙋1BQ|\|?\ȪKIu`:! τXz>H۫A=AAy?g*pS '/~}W >"/5偪i+x[-&hL=t}Ng3F]$1A-;~0N2NcOg%mʰ&p&?%dؾ>O]N@75wZ鹵^5ycK:wPB)IÖ1uPU&n;R0R6U&%>WٮHMfI>ƉO]CkLn|6w\=/d;@MgB{shy@Hĭ %}1%o):EMxt3p@؏HO+^ 3{L/cO\UFrO$Wj|Nd1_ҋtD\O\Y1"]_5b[K>5.1xYCwiK䢂ɭjB ᱟE endstream endobj 181 0 obj << /Type /XObject /Subtype /Form /BBox [0 0 3.022 3.022] /FormType 1 /Matrix [1 0 0 1 0 0] /Resources 182 0 R /Length 15 /Filter /FlateDecode >> stream xP( endstream endobj 207 0 obj << /Length 2622 /Filter /FlateDecode >> stream xZYo~ׯQ3{l,b+1@$؇8Ԉ$R>Up:(gb@stUWuvӬW::`[wwJX+ъ SΪӳ_[Ϋ%5.|(*\{Ex%lMu0^tVWT1ʻ VJ04Cu\#UU8Q@A4sVKil4%P+n% /㠒18W42) <@ӸV:D6Դ@Rp簦H #ʐ7F򣗑1c$=qLl4kk[tt HFҏe^ ˉ—<#O\sZ9%{)_?FnF? }Ib F(1(x0,b#I6\3gB܌5BQFLI({K!S`^iհ??&q-@MνAQ|ߚ?z bW!4SЦgտ&6C>2 =k) Ww_;x%\o3A۵zV:hiGr%'ZYHZkT^xYJ639nś `(,V$Up ݺ[[zFXV\yO,R0|Zhɀ 1nj_?2rhASMURiPe$Tyf$! ekQH֫ ,DL`o6 3"`zRT[A&'Y" -rR)4k1UGQ=a6''ЗQjjKCXNRqB f: ǻt-$ߠV]|P! ]~׽˨Gþzu/ P=*~1zDHޗ#8 ۀԷ:a=fɶ-'f{iXo1jwXGcÖ[ẖx etʾ} z~7E-|u#l?ܾ~Хh)SC-`. OQ6>PBEj"D+3%uwG}!G,|Ar>1g5YPB#Ms?`=eiuzX `Jߺu<| l+xi5C3Ef$XV`V7>ln %YcWugkՊ y=%H -`4C3yW~7lCd4/,{?O\r@&C`3Mm&9A%2M6}!,%=@k!qè  yipW擭ɗ='eEI)7֓'rr0^\;XmiA;[M/pcՓ=zc//lN }ⵧ~ @9uxL`{.Arpq b*ײ-EU.GuN~4Z(桝:$ -dx6/s,gIuPRc,oa#ZpZkcnfEnb@#J8; ofs۴`B5z6FyT3S2٘.:..1yOԛ_؜C*ul:PP}Q(#,Ik3,:6 y݇PHL$x X> E6$6?'Ƴ P@)2Bc;Eg#NENE R[KY[\nHZNP:Sc©4q8P#jfU7ja%>@A(jlN爫d }«~®#-`Z<NS{hcMCaaT@_=9x5'Fqk e swgb?u38Ɉ]`G6ȴ[?8jUzHCTs`8bBj&gy$ S/ktVrc64)~g uq{zl]Qp|P>v| W8]̗@:KO:y~ gÓ߲\q*(ű@N.ӁT> stream xZYoG~ׯG }iV8.N)&a񎝱3= (H2u!xiH~Ǩ] [׎Ox1 *~O;Ff7Z) /pS=jjz i )QT-[G!H0-rd훯-PыDH>/aHGWI:?eyms@3F {7~Wv֜$|+O9 -lI?&nN}%}/v/ɷn[:#uTȼ2,X6DR0:cĄya ;>4hҹŴ)5i7樺 N^k9%K'5Fgn}},&pJ)5A-]oz .B'UL;PTҰaѵp. 4]ܣevV /wNJO㷆ZOilIꂣp ʬq?`[4spkXnkCkdᲄy\.qE|YEZ-ũ$-y4Fi ;ǫyugV@Mő{ $Tͥq|l] z56FXW+AFNcnM ^4qlQaTTv Dt܏)m`K]q z(FRLT:(3Ќ$$T tzˮ 8GenWzi$*ۿݎ` pz!ُwPAzs3bQZ3(IwAG?QU-4R 6!KmU%IakOA؊ˠpĶjzCbMY=0Xyh @łY%U'lL?#ԘFEAzQTUj|%`ZՀ2^ҽ*Lj0㫭z9Zz)_1kISDzdt{"Hc@v:06X V/znorzǚ [|}WN;֮Dž=Dm\]v mڹ >6udW*@g&ۥd]Q1A3Ga5}M]DtբOQ=NQCB3IPiK R|,tQc5]e"(<'%46ӈiX ;dqU_!Uؠ;LkW%X=n\Q %g4V|lӬoe{?P٬|#7=| %Gy i'. t'x Aˀ#Gdo|A;?+Aaqsc9걪 AG->(Ysce::a ovc̚0ƿ^=\!~)GcL#ma;HG:<?s 6]ndYX6 Hm=6A)i2 AifJ#ɽ9➔r[:_rzyXͤႼ.eOr?P xA~{|Q6ƞ?~#!'B09R՟@L*:f|*b/6Ӯԗx/ya{o> uܳ lx7]\8Xڹ;7c3pS+ endstream endobj 239 0 obj << /Type /XObject /Subtype /Form /BBox [0 0 3.751 3.751] /FormType 1 /Matrix [1 0 0 1 0 0] /Resources 240 0 R /Length 15 /Filter /FlateDecode >> stream xP( endstream endobj 265 0 obj << /Length 1459 /Filter /FlateDecode >> stream xXO#7pߒvZLJԇ҇ܒHr3cwPwR^=|yQb"yOmF P`0xq=㽣{LWN+l}>! ^#/V脆ډfw%m[dĝ@+QET>J jkmZ9tĉ8{G*J Q@AYIU1HC)ece,@aM]Fi紳^_Pe5*5+M6@k|f ũBvgAzEJgL`La?6 J>%}&_Vź0cT@AI_>9!g"vlnaIޕVJ̭h qx;loK% /2XT>f&Y T0eAU @}t}żW @%LˢoboUotf\CJI6<ӎ!+L- Y?.|ђ[4*#^[cY@lK¼%YqqgJWV<m!ç$L9'pL-"4 ("h̡Y'o`&ń`0ĽJ~sek B0J\p 2o |c[K;ɂ-+~ aunlRio6%-%YR{z# 0/)b<w,sdr!~D\2XYac9EzXҦ4"Jmq mdy>aG3Or0\ۧd@x_DەѬ +0 t+̣zK/墸4Pj4ry&cn A[FA6/U[ ~)!I^2iiwA6Lq|qSB 9H9uulͪ-}ژW3:XbMz`#u Ov^'ZO)'Jܜ%+P%& 0tbrw/uIwZEE-\ ]B^iV=y=UV endstream endobj 147 0 obj << /Type /ObjStm /N 100 /First 923 /Length 2183 /Filter /FlateDecode >> stream x[r}Wq-+j*,j䬥X⸨Ѯ9=ӤuDKLLH`FqcڬFQ.*9+E+oUiQydl@G{r,E.sUT*+JCQTQ<*G&sr>A蕋rUQ*)oGd 6hŕlI$B*،Lbd pƫȯ*R䒨7absR1xXȪ¶1JŶJDа8TJ)%TتP%#R2,UPdHĩ6^ӌ&!K6q1!*aK$u$WK%  Ew\mD8 Չ`SX/Be,?2O\ d k!&3B `a=ĶBE=\<r)c Y(7dx '4SrP䲂!%vEϓx= 9sϢ xײϛµ“&ΤzC&ۮkfqd0qeӑ;Til<ػfXhWPU/7/Oi;wz|[|I4LJ.emJFsR^utǫnvwvzjw2ŸӳCofvrMOtxe uM>T?u 赪~?UteG_it~jz(7f1WaWw Ɖ &A;`&ӗooŶyjjNTة'tn$}Q?f~ybC?WGFåtNcnѼA4V_c WZL/eAVu-S=%J\jԫ?W_}e@\0)>C܅7H+ tPs|T{C)8w8xv^<.Ŵ }/k?~qto .jx(2pUDq?DӌTCJ:IA(i4KZ4 ^(xQE/ ^>l0Hɮ,~zDp=.dF ѫi`&E H&m;FZ"{ lT$iCI|5"8ɋ"1i"yXRK9{˚ڛE]~ qBr^E>S~[E, !㻈HX qr"F3r]U8\+GzL? {yt8jQN XKù=hԋٖL$7nt9%qU:OQKI1/x*wsR̹s/̿ǥ15C+4<>'&?5B5T>~qq4Jo@c\^+qׅ18l5dMY,Bz! ^B/d E"tE"xE+Wc?2ޕJ~m-ia bI"y!gz߸R!?^/LI^TYܳ gArς= {$,HYܳ gArςFFqK;?i74JBM!47 endstream endobj 295 0 obj << /Length 1892 /Filter /FlateDecode >> stream xYKo7W74dOMIȡAX˲˪%N}g$Ǐ&MrwyϐfLÑF PӵN[ťrGGLbװ匕ڱp.Q%ҚkoƲv>alL i,crW Fk`qŽ9aM0GIY csǫFs 95َO:Ȃ1-*}_5a\^F{;0(D\EW@-~ dZPy"zHP&%̴7M ߞl`M?;.ϱ2UFW?$ӓ${)?; "L&nA'Ij{xEjY/|`%m[ȼ2j!k<ļ=.N$ͥFTVZ)pԦx8a͔<" #8Cf+%DlҲ,s5LI:N5f~Oo3<#;c ^'x$ {͇KsahAu} 5}J+'t2)ٓIxlpmGN1܁ǣW*#.cZB<Ұ m\i!Юڹwj1],Ɓ <@h=%9)[s+p~X_ޫc$\,|z<7?O=0hBP *!2]9`kPy2 OW`UmNjsk0BS0Ւ/ ҮK2r*RX[j^!l Fo/Q't~-XCHOy9AWw`gd[쳆knQ՘:fc.vN\"0]:s BvZ#z;iI㌀\|^9H$Kx" /!$:3a글gx쇕@LyK E@1b_|RvQc4}\75Nd}P:dSo8-;.*ݖLn ܦRiGdTMtAPtu<݄s.>a`cUUQ ɊXЅ0n_X"_ 5}|28 "eQs̢GF}CWAu%/PR?Hfi`e?`dixy҂Ô7YE{N,x=d1N<'+@_Cvwd52҅?n ^lMӌ] AÜD9m K^ endstream endobj 326 0 obj << /Length 1517 /Filter /FlateDecode >> stream xYKo7W(DsfOMຆA]˲[ˊ}g%w%l@p8ϏCr-ؘ k[))+WI'9HnG|haҳ[.Y9v;f񏒚_j='3cK&*8 &;7lguD ް0ϥ " `(;D6qŽՏ340\A!x6AiD*<lRXGy#Z3S{bo}#g #p, E@tqfz$il}e"Z us+b$rL? L 92+iH)?e79m h3PIo?;v' 2DDFsѓ%6D̳E=P:0W0YbjY@_K6kem ZO /C_#mĈ/}%%>9ǔ- =RN/ۙiEXngoIEi}Ka:vMAH]To;W\Lr `D{$~R zH pLw\ |r'F|n:V*!'QMH~43^ɪ͟(N/ _|iҬY\P5xH\L'KB;Rd_kSRJ()żͱe}>sX5vm7#ivd_k)8vq75 snxka{c endstream endobj 354 0 obj << /Length 2478 /Filter /FlateDecode >> stream xn]_x_8Hu@ dd4:dߪ4 źaiŪ6h[!Vʹ:9#ڸmyLusZ× m/=!ђB© Qds]̡W x"H8H+r#aP!_k8S4j(ɠ` zeO!P:l5Cnṽ8U T[!P&0m^zFhxlLkQM -M "Z [@(!l=KS\tgrY1P3G {7^+;sl4'1`~ft'ٜ6wr'$/PDÏdh7_a?$9 tFZQR_D]fisL;BN тbN$i9GZa*C#qH$d![C&!se)T4HI"AŜ),P jG >$C2Qa;AZɋ?㗞u9xড়$}\0ޞeP'S'$0Ar<iYK2%̣ 6쫷+^0nD㦝 * S kҬk2{t-B0::xRLV\VOW#ny5Bj ˈ[.F>e؟=P%,xi`A)Unӣ#tyx7j@x|4ϣ䌜Sq+ɬ˺Mo cTH !?-g'32)~bݠ( 8M &,v1J J~p*E5\uD-aOEϋ\2D3ĦӬt9Ģ? Z>Ԁſ\MnAqW.KpR1\L;bͧB#ܨ0ȿ[/1Wx&ٯI?̫L]xPCnrU9IX^z ǹTK4 OTZ֓g6ej5% 8 XDR]΁s(z fa7⽙sk1%Uxe\T@>ݵ,_#6l@l[g>1 x΁foyo0'E(_(~=jWOw7QN a7,^Ͷ jӕzo60]PtqwPJFLmX@Z-.|ﰶa )FRoi?}X޺~E\(yL6zykˋ`lcA~8y%+lotϦ[$=KV܎nĘ浟jM${`Vhpkft/pβ|7Z?V[y1:q ~^dCۻK*.LOM[$ #E#.O[ xM\ږ7n"ZE"܊ZPhy*ͅ*Q*QyLN >_Ldltʆe"<9O[&(|0oa?49B%SzzzJǔi @)~rFijĝx:j>7J'(p>9&]ĝ( $^)aNDu{H416xL}X^Wa7Z?? M+7'9aXh郧0{_i @iķĈ|a.goyx/`eRnz8apKcj`\%W: endstream endobj 268 0 obj << /Type /ObjStm /N 100 /First 916 /Length 1875 /Filter /FlateDecode >> stream xZmo7_1/\QӜ NPm십 _yc G3aTg#$z'"eHL>*$AF$\fX4;,2sfyKQ|`}Ǡ X%+Iә٬(,)Dp@jȐt.P(XGQYP,S 9D@@_bG0.y&(E S*X]@.+3DYD~9p=ANXXqL9gZNJ2ZZ*~pg:K Nd|):A |i8o9V}N0OA &8 __Qp@T@2\B몊$벊9a}1R?dgU&Y7x;-:@kb :;8JCG@u2;B˾qvY}!e_N;#G@';d„6l/9 {U(A\l;Pܽ5/`=QL2#-Xؚ߉[ل-K rS\LW?*>|5 }-rƮ]s.wRc!C_GuS["?T/ UUUՇZї-Wm>H>ʍdj<_*WyU|竼PޟD9T%R({R^u >%uC]P8%u A3c9I endstream endobj 382 0 obj << /Length 2049 /Filter /FlateDecode >> stream xn7]_A/Хy,6M @ Ї(\EZQ}.]َ-wܵ`K&D Z  i׆)T],p-W,XSQMoRu#qQY)IuWs6FhHo[(se|pB2L0) ;dC-. l?6 !D,@r¤['Ӡ1~Ykm <8PbLy{`VL o(]vO[AW t I_Ҍ$LGgiiMps p&: d&Wew$+\VFY?ID̓(zM ;Ĵ;>Ehڏ TF()0qʰBZLbA؀HsiDEYo[Z/Zm2$UBzN3DBi(Z)@ Msy"A2Ć(sv^WF2\xI9X0a5}Zr-N)-=JW:'?2(ÉxI:[ 9d8RTyQê%:̽7 7.{ݸ-v=7ν4Tgє “}P-@${ydD˔Hb?M_fr)7Yg @WΔ{s5-sӮgo_(i,b%j-L=.ppڽ}X}m!UFaeէtH 肍lgOaԾ2ߌ:}3ͦ7}p{\mm=AAׇ)m/r [Mظ0@h@s0:n^t? qz0:~FO؈|ftھ }4 UʕHU^5&V#>.=ׅJB4Nր̘ ^]thP8rζh4vB/5V\Z]c1wM%.~FI`) OֳYtC;C#,`9U_:؉x~sa+tCI*¶vXdh z> &~鯗bIVw{a:u|b cRmm9u.vbQO:w&Oˏ\_z;h/`Wo%! "A߆4Zɽ6rf\sP_g7_,<oJ{QU>k endstream endobj 410 0 obj << /Length 1926 /Filter /FlateDecode >> stream xn7]_G yAC{-F,+8w\>4j@3{kΦ_pY[ele-dc6n =y% -WTIMeam ܃!.*K0TaV[ú 6-45! lwȼk`@׶J1 7hcvi5=0ißvY6jiJ{Tm`T0~5 !@M%"ΤFQ+ ԮU5)-ia AT-Bૐ@p,N98uýHKm * F!-kڶ<:G $WeFq ={C2B|Q N3 ĴOŽ~<'ߴ,MePEԿ]FEEfZQomurLPAhNt "5Z$ PF w $6Ć(HtxǠ7ELͭ53)Ld.A@21~x}-]*2ُr1nAjrw9GO?W^4ɇ%񓰉a"E-͐p 8Ti(A]K_v5ޤ0C. )s"]Jq*_^ Addf48g Fb8vϣJ)5G@#i%WO} ˧zS?p4&4чÛ]\tP.+) 1j%E'SЌB} 'K-BcrzP~*4W51"gcp}x[!$Hb[:8;MsɃ gS"B|&Іf&%[ ot"9 |- *x|c5D M IAgYLhm7%M)d\6Z*XJ*T…4U(`kVBopUvtsܒz%ըҭ [L8#-' CC.|^ 48#&eg6qLMV5Rm*2XQa N}X7:/H,:xpEpF̽ qA.'OqI7I1mzvxSž0{ y9u|>Pߍ_Qz:zNy[AHw>豻/ڟ?:~6,t m+mveQ,(7]/m!6u,!^򍪧a w4k5֬)5es9bE .v(b R | ?p endstream endobj 441 0 obj << /Length 1513 /Filter /FlateDecode >> stream xYIo[7W(Ds_zj5 YZR,/}g>IO,ljX,Ca #& ʅ!!9Z'$~-H{f×GR\qIN/H,}zQ~;-ˉХ?$CMֵ54@SaEAOӻ>] ;|Nels|W^/!ʍn/kSX$ܾcArt)f=f[KmVW`;84#Hfzh DKw  TPZhS@f_ү?Cc2GT`K :ːlUSJ8kǘ!]13bRGCO>@_Lm)}f~O n-'qX d]j+8B+5wQуtr>\( CXˋlسm{ݮSރx(0K I{?PVQ=&YH!ŞU 4c\pJ|ADF}[(CS/|mCκi>tؕ->Spῲ /o9F<%C3(T?x6JC"F^",F_/>(RŽ"?3>b&^ !4a 5Õ] "B2~ :Κ'o["F/9X;۱=;͗­acC-mK@$0*ݣ"#kja8uά&sg%s)!&|QSp=-@\Y2RwzNM78$c endstream endobj 470 0 obj << /Length 2175 /Filter /FlateDecode >> stream xZYo7 ~aƺG*i\(Z;fk7M}Iͱ>4-b`wf(")Rcg;|ppp g)d#k!-ӣdӰsV>[Rcֱ\ܣ"/:K0TaFMg23=C+ji=o` 5J1 7o9@NY:(أ$S ޱ%HCEjW3&lMpDcT2&wff7Z) p}w /[rtF(P""ʰ\X,b[Ipo FYgVV&SHsZАk%@Mk6k(Y$bdJ.μ7E&;A53n15}6S2vxxm'YI0\e޿4sD Ӹ(h]ѐ=[,>;)w&v|dx5k7/H7X—akfbf3l5uc݆oΚ fY -ioip/xMЄюۋ$ol.םedD'k@YXLU8X_)=li&Z*eĄhT)eAw'i2zě ӷKEv;dZ ΐ9B7)q>.S3v=ZYӄyQ`fzqpqԥFn#M9if5lςvO ~AB^ m=EؗA{4=i.'Uq F]2ẞ`vI9uls7I\_O EkE7>^8\ =Do4Os]E| Z.%!Aj|'\`n?~x_*6 Wjr8k!wU+j 526؄W7U;^D>[|]o -SG8>܆"az? O\CO!Dx*Co5Ӌ')8x}PPR:`¥5\PqHM Y,s|mpqŨs@FRsްPtZgJ+7'}CgO`xo16r}̻S_>Ys> stream xZo~߿  vR7\ TKwiպ}ٛiΧuEAv8q87KN):aǕ\4Z*A,k9: 5Îb,I؜eV:ŠKpjBG LjNtQ`1 E\,,b bk*פ 0EtUa:)詬:7t;%Zᆦ0т I 0&T=Zrd_qG pMjrA\&x^Bt ,X 2\Ps˕j'PQ aA86W" x^Af3jF LrN"*:KG*XZ:I\m"11kX\cRI*\Kppp> @. R7`(DU@B:"鈢"Ѧ fvX]#B#Q{QL/%V!V:(: 0 /KX -Ы K̔4tLE ֩ B5:6;:o)c`p\Ïw 6M7z}byfv68lߎߞqp4'cmoSY!}\V4ku;* ~8;Fw pvt)fPԯ|AOp] 76p~9{xNH Duϋa^sYx[6ͣOn__.篻by>,'ק> )YkN*, Bv|_./0ٟ׳˫qnp~q;]գ""RqԍwJTT{ig}B}ާOj<Ϫۚfokۚffk+}ZYdmkM_M-{v~d}qo_wwwS`eB$g+OŸ6˾y8[oR)`RZa0IUl\^t XV!PtgUxW%c{H]ج~ݟX"UkuFcXg4uFcf4M_4}cǦM>s~_1929292929[p?l7don{vyoخ ulOww:ݘƲ'|wn{»kz=qlxw%{`;a[1#DlĔZ*n[l6g-˭La} Mk,;Fp?o2$Y/sew_吰qcKjqu-[/!|7\?EC V޶dՇdՇdU,wWUKz-v[쮷]obwzKާo|N)Mu:!{SNCuPNC9m endstream endobj 498 0 obj << /Length 2150 /Filter /FlateDecode >> stream xn7]_A$/=bbvd0 A2dZRtx}d_sxF+`duţ-%΅;j5B0^hAK^ܜ[Eqs.ã?k5|Dʧ@ @9 +q(v2ZQfGTyZ!Ц@n]1akr&K~Ad +Ґu^2fFx>^`y@-s^ՌT!FbuA/X*"2+UƾSg[BήBz72JqbjJ:VޜX̩/hf(6W{9аJ$[bm7r؟o?l-<3R%Jtex|" 2J-G5hQY:H<*:B05T:xl%Vu<ﴨNbx{~1Xk$'U><-ͮ_#? hCaLYkiNpylGqww_lU޾I7szzN-Z$D5F>̌B-qJzz\benN>`su:홶:`= m!]62[h@/gϰx×{ /,\=D6OKrF\oq^480D*Bv*̿Eu >>!nY*HփS=bp8Ҿ?o<3Gm|jY v53&o'gSv1 0_h wpu$ZV74YЫX;j2V:mk?)jWF'_2XS yI)W8ne6d@C_^D@&M"6 c_&ԷڳFEz}M-;KSEi!42t/؉?h:,6 endstream endobj 525 0 obj << /Length 2429 /Filter /FlateDecode >> stream xnG]_P^fu#ʆccJVtū_uuL3Ʋ1U],"UduU'ެ^͡P_U҈I] +.Lu=vfQOvsr5sq,^ )ušjrvU͠WsxHzO\U3{x|ƙFCU;R:U« `O0n>8PKW4[#o&6a HYhoG yʳ1 q#@0,6rad}IOz#rPeIKF{k =A2-@_*t\Nb~+('91m͹8y 6 :5νĴKA/oom/ TF:Q?GLQa!@y.8#LPednO@)3$ECjA&!4dgply 1R{H,fb13Iu큾ߵ| 8"Oa]3?'O2fFMu9h=kWI>E_+9F y%pHni\ni>Qˠ$ON'eJ"n '@@qV=qA%8̓ޫƵTrڅt7wd@PZL Ѓ\dQ6 S?LUBFsU1o kݏk)YnmCK".yor{3nAF۰lC ]`'AcF  {  H rtBdl4=$?lV#1P^ރa5LhۏK-x=0#=xr2˙тV3zܭu?i5&d\Mc R<iq$xikV@aP4"2 2""W x\v <%,Ϩh<[d Qm]fx %(LEa;Y6ȖD\>^.9#Wx&YI>.*P=^4>+ Z ,SZ7ހ s49eٌY'ua3$C T&0]+ U%[^o,ڛqy~ꮗ7~^uz3^w|J9:77OO- @fVTH'R;rBx27s:Cc#kh] tF˽TfJIgFH!7rNp)V`&rRqehJP%1ءd+WG`K"7 tC^Pp((4> T/QLC$x$Pi%4ȈeUJFB56V(: ^ GV]ݣ}52qؙUƴ cwNncxL/Cthay;=A뛔(&M2N6-@,R7d>68Z4rfHzh@Od؊6[nQ0.-0Vnl( 4$-Fl$+8f{7 ?j\y築KJ8,oBw*4LwTk+7od<+J5HL&&9 6PpfyF|v>] ! [L71s_^ :Pn݂r;oGwػ[S,EvX 0=[z;E޿7bY6Dg d'mkh ]ʠ7hɝ/(/Ɲ{|yW 8yZKGt?g7qߵXeo" |Q>#*PO\N ?[ 9LxxD芟sx'?g=t&)%~sQVP$Kfhxr4AHALJdYYOy"n]XE>gY+se!m[D{2s5z!ND;02|q-w{FXfO dx/?EfX9HBM[@-w> 0-re툛  wf endstream endobj 552 0 obj << /Length 2391 /Filter /FlateDecode >> stream x[YoG~ׯ(/$},!60`lt,BQǫU IaN hf>NUX~ VI#'u%h0ո|oDluu\ݗҚ>ո*^ ;]EgJHH+oFӵjmH;]}Pr0y4[+묔64bکvPҩ*^ v(` T {)hC# w IMCo[9 T &w9qf7FJpi=96t@Rp0DGnPǖk Pi"$?y$bMF5[kFD]$SfF;Ҙbm?IZj`efr+ J3K9ۛ$s:#(icD*0npxdN$pͼA f22Gǔԙ*!S'LP2ųضCS=V$J63ʨ:z큿A s`VQ0SG##{#㣼̱Znr 䆚Ɠmg़RuW 8*Q*sr .8_y4hXT]2q-v!]!M!;n0Sk[fmc \ )^O 4SЦG`wg7~ +; 7R!ΏY nnAK2|:ots=nI.FCap1D0|<|xZ>/`p?=-`|?g_:XL{ȼk֗ib^0:^=dr2lOVW9V x1Q%":`Vx5Dٯh3+l1 dooQIkWAKwsoeRHgt4n؅pck* X:}Ѓ!0Tk;,-kbYX%3vIg2/XRɸқgMS= e )fN{z`Im,2| zhJ6եa-)f2z^ڗIMu<&z=u'ɪD/hL6ysN8P(NQ1IܶpuDuOqu#牚(`puDmG43;B,kxvPpƴW0D)akW,*4+ ++X::[ގmxh H`\uX0ס{/Z6d8M]KP^Yv>1,YLbHzfu%,Ѩ~RD7C~p wHnbs2pL2Nu*'l۩N^q`D^H x~%?= ˙顡b[xGb EZIZ < ۻle [QGsyUjvH> mFGK--G-V0aAɥ ~$5iIE ?@y) % t2B'[iT=VF-1P @PvfP9*Cbbhsb.8`| 娷n,d1UAӓ|gfLC2|2͙Gͳl]aYg=re pγ ]1;$ <[c){yYYhE92u53BPB{yc?Ǥ I]_:ӳ2a}A~=~ x ׭l\;$~a=ūhzؘ NgG-?Oo_a6H0 275N 0rn'+_8%Ej\IwbǙm4`k)UϪpfPҡxXjR/r6]`9p<*J;'c*L*X" \ W/0˕6Q71N 1 endstream endobj 579 0 obj << /Length 2437 /Filter /FlateDecode >> stream xn9_QȼWYԭ>Yg0?8Y#/ITݶ{xJ,^DdEuV\JYxe*dVtcohk#qYU4iWqOd,R |L5ܸ6Ы<7Hn*HD P!_$0^G^WWQd P|u""U!ӎS'#t%m :o?_>ǛҏlJ1N^~{#xX]xg|yݒ6WmhmOz89QaHQpe7N+d45dG0E36Madr8J&'8myr~@pQTa9ٍX$sxsQ(RO ֣{/ j OyO E޹՛k?=k/J0M{Jp92t;B!RSjՉg.*͚Ico G35ԏ u="h1Hlxm5Ķ|鉤m~VDFVlu%3ߔWrұ^<.]Lgje zc-s/Xt5[Tp8?0 '6bLOlf1gF}; Oz9oF3Wf_%zEԮ4!`yx +ai!\ py=>&5(\M9m 7G`"AY׮jP=tmv#0īkY?; I&ʘ~\se9bV]6Yf\2I{olyS\\y=*ZͽFyn`5ZxtJ#/d1 |.*O2 T_|VvxKdOΈ.KPތQ"rҀ">̀2;ʑ 88H Yڵ8N4'd)LRI%6GwUx]]ܵ-"8TDnHEvӥ0 ;4v*Қ"P]d5̔˜OvT jdmSzAG轤|Bڔsۂ/w?z[]o ~4^Rs k<6>osc7_A(@hoޢu[%q . W<f@> |vûڤ$suB߶!VײݞՅgEzn+"z]wdQ^k}wPwzkkj9} 9 .B_w+ݓ TjAupqq}ڞ W?/*0^T>bWLjR|AaB<S@C9Gn(ktph{n٭V̠A3 Eo 'e!eX8D2Gc1WgF1h{ve\: _~_j0J{Y^tr_m"? }ٛ.Pk^NY-9_0hsE+}~#d|NEvc_N۷P<ıF_zClNr^ƃ#ל~; 3g|JƓ^i6?m35_F_ l)R?ʠ֪\ɲ״dsr3- Y< U)>"232F^o W mKC|KQ~Kh*zʟ8V9y endstream endobj 473 0 obj << /Type /ObjStm /N 100 /First 917 /Length 1691 /Filter /FlateDecode >> stream xZmoG~b>/w;;REZm&q!1-}<r*^fyvvvorB199ez(6Rqj'T'bdb︉1)"3rŭBXa3lj,69Qm yKr*LTt/^X"B!F5N]#,B0,Bh^q* qz%jF!1pjիHF!>p͍8\~ ɩ6EAK;Ҟ)vDQ!6¬3c. +s G!XfIj զP.I ᯸ dTXm0g0Q︥1!( U=Aj$xB+I"`P A "ASE/c.P5ᐆ$a5$v%FQE Ol"b̬*f ^5~(>g5xG5س ى'#IyR[ &jˌ#$: )5Mw9urto./ru1_:\w}=BY=[liYW+mPM;dIrݽoOL|-mħ2aDvDaDKsėV3y었OpP[҇?|3';p.9ciuj~{7wSdx~݊oZ-WV[ 5rarǾs[ɦ6U\~~jvj7/ެ_;{LEzN--+F5P_)ZzśW>ޔW¦z=_-oN}~x;Z.=#<,~Q>9' =O~װW(tvWu`W#bZV0}pDޟǘC[5ꗾ|~ݗ4{˷O"$mgjNQKZ}n\SMk7oӲ`+W ^1jxUëW7xg{q|6]`~u/B,5O=:-(a]A/gW>y:n%b_")Hvm|KL |JFHNCI<Iq/(_ҭh% dmPQ2Im-Vz]I.r+i2iIMo~_yfG{_D/{~ EË /^47kM` endstream endobj 607 0 obj << /Length 2770 /Filter /FlateDecode >> stream xn7]_PxXgm0lltyp@VVU&#t1b],ȪWG^SS RV2L%dB:\ٚ!Zd?:?SqMj}|yw HT`*TY2^  T+$9<6E|S&ة-j v Ԍ?@B!DIQSQoK'd<<)`L l  9H.gTEI$>K!@h$=\)g3cx3ٺ 囲oOpepZIcNL1r' /`cgԹLRv2؟o5 it@LQ! @ ÃEf*`ϵ2"!q [IFj L,f2>d>vޯ _I2{Ag0SEi##g{c <ġ|<=1ZiZrE KMArF+,>:)Cq[Hp24G%Qe,QGc0wNׇe7C.gܹbJ4k=u | v ו4h{MNs &jVJpr& !b77 p^j K1JP@;a?;!ke^?Ԝ~\A3=^5:>O"j(N}FS#4_s0@kxI4L\JbX@X?lZkٍ͉Oes@ţ餁mh:*ֳ49-Dğ (`j82B}320c ]s.kF VDb8.r~0dJϜV˘؀x,hoՖ1jT x|/Kow^=a|q[NCg2oq 3J/c!V//.X7C9jXej\zxmay勌z8` KSzQH$qŴ!VxƤݔ졙8 g|^Q|w5yoAFG'^[Q֍MjG#9EMOHW~H(tz35̆M -Heu joM*W osrʸ9Fh`Kۄ։o2ޚb𤡜Q-̤U]SZpƵwKzϸ{>ak)GbDXhEjAci v uS=< ,L7q43.7gwV@p/*@jB)3f5stmZD><wD'/Yd@'88f<,8֮4+<ړWuo2ޚa20}Xvzg;wvWyg/sb{YK@iBpIlCzr VIxS ꐊi.w&*`f@?_/"Sح `ve90nX?[ EVfxͨF ~q+;MW}kὊOV%yhJ3t%d zn~@1K߿K)s$3GtGgMfG*Baڶou} !5+Ndu!d&&gqp' MuiҸ-h8j53B~݃ϓ_u>8|ty*  wmߖlM[!ĐKU A[)ػ><_pF=?xg.՚2]B{GM]xx:/y>&&ޒetshNR=nSfhLeGOŃ(H̘?yOigk]w1)gg edvAۋbu5oX , B9?eU?-]LA;:HW/cUvo]w,,`-_ηrN[Z5TU4F.\8XڹMo8" endstream endobj 635 0 obj << /Length 2664 /Filter /FlateDecode >> stream xkOI;2HtSNMraNd&8^Ϳ?3dD]=X~ VI#'u%h0ը:^ۙ Zވ*|lu5_5)>ո*^ ;]EcJHH+ogkz5'w\!ea<(WY)+hi\jZAJx*؁S5 i*ォ΀BDfhKW4 LH%anf6#o4[ll@L w:%lDTs|b!CrG1*`%@)L&iA_i˕f{уd,@n}lqQ wsbZΓ8y-^&jF/]s!}yi/DI øC39d5\(qFPPed)3$eCI!5dgply 9xH,fb1ʰ큽8"Oa]3?fhFM0߇@Yy'^CLJyһ0lA}N 9-dIļU[m!9d4V`~Eì}~?evZ*09$BF;w* ^L\Iޛn 6߀i>ūOJhhj+ 7^K)8?g1iC>Ûj|vؠPa+4LhY?^ kr["֣-g-Y%!aHBեd[.1&zu4gz{=u''dgke;APJR2 m| MfBAdwٜ>qX>.mWb~r κ);.1ËHCdLH edGZRIhbޅ^ V/J;9Afy-$γ(f1Ͷ7Juto}`e[Ol?VFB+6i<hglPX`*7R"1RCQSq5 l$֧R\ JׄWRI 媻8fQ~"_FGp>ɟ]lt o8^nɅ~5yhm'u(鍀 D`C |c Gn[J|k矸ϭﮕɍ¯ž{Oɍlf& L쪠3qJ@DlzG>E|z[;[$ll=BXfXﯵhwhm9DRh)g6Ry9V\cbmVZ ?l/F؀}1;h{~WS;f}Zahtͬǹm=σTS2Gcʁ-iBe:܆2 վ0*>qa'[ӓ&E)+8o WmcÀjSi0TF+NBl`YL_TV F$?&Kn`O sR&HN+ϡG4O&s1S O`/օZYAA%~K{` C-RP{}Hې5t".hwQ,H M[U6rE^z1C8g/Ȉ60-de8no!?J$vN#/羳+k2qW ߣB~&t3JǠ32 endstream endobj 662 0 obj << /Length 2560 /Filter /FlateDecode >> stream xnF]_A(/3I},amxe E#Ǻv%uN~Or%]bQÚglpppkVt\9Y Zމ&lsy/5)ո&^ {]EcFHIonfgz'wy E:a<(7Y)hit^l SMxA@@:{3Gv 7-tW &L}܀焙;) E=*Icf04s,C@3hxxg x%_dwe1lA>4v 59- Jd$pb^Tq $O8pZZkE\00k sa,a=EV*09$BNCB8* XLЭ\d>-“[`Z@L!ēftmj;S<%MR>Ⳙ< -MxXyov}5}Ŋ6+ k.VಪH~\ϱm%b"ZO)z *xPA*Aw: 7Wl<< X^we~BIIoP4VټH2CGc25!=GP@O~D]_~?9<'mYmk<#!ZOF<̟Qq% cB[_?ʢVv 'oL?{ta]_ΌKv,Nղ3.4RL mCېKs;-<' 3  @Y#2 2""W<,p?kmָ[r ~FCcNS Dtsgoz6Z&WWӱ=)}ۼ;rܝl/oc%6;ٻ-"z}O(סVWv&P^5vs*^%VMzDqa`M9 ?.MxoeB'm$JK+oR+9u7-H^1v[VJ9ܻ? w.1% !R]O2%.Sc;RNI,wLYJYk O瀞A$ɯLȩf"2G≘c\mpya<8B ̈́FynIѴUVP*G<'3:fZf` Q7MyldK+. |h$]i*LeP$\YH}_вs''-q0|8[D~a?92“Gq,Q'],nj?W2̲Mm`6qRθQ[TR lu3a endstream endobj 689 0 obj << /Length 2387 /Filter /FlateDecode >> stream xr_1V1ZwQS R6`6̚nit ઝM-[#bKJhX*nx\WWgwUƎsնj/ђB4© QlژCx"H8\V1G;àBQqDh vjc(ڋAEhxz>BdDm6 gm^@@QH}&G55c$Fov'2?'92-DNH^rfHݯdhײ_`$>_1ĥ@DKYf)9!Gh@1 \ݴ՜cZa*Ab9v2IԐIH0l9F=IZDHR3ʤ:I|rv _AR c00MO{!s0'HX#ȡy.sxi SNHо ^.ߟ(ꓨ‘y͐$iJXPvc0.%o/B1i6 ݹS b,r{OF '/7>C"} GOɊ+(@a7xyG1OZ1G!=OaKy_цJp(wÕVRśX0ԼJtRb4܍r^UxNjm N2YƠ1؝Uhø2|u."F串Z>/g槠32Fj+8hh0ʯ?~Zt 83긌!f.(ݯBt(Qg\&QD:a3H%AKiH <ʫP7=_fW>)~>; \@:= AA0 )ј;@5PD2}sĜZu &F@ZjՠnU9GXm0Elf~ڂ>p֑oo/5 o!5q1 on%mPܣ TdZErts{煛 ЧoSJ :^߁lkeNE #ޫx=rVd9WdsqގŪ{cFY\Jmc5_c:[3w]S=JAګwJI!GcrJgqd oЄ]psI{zlt ^^^7-Ux|XΪ¯f4xͲ<߼VY&{rY=R%wD}~66zޱT A@v0)۩KJhw00U!H>ؾiڱ,~߯vkpvX0m_hSb=l-0aŇfD]{~sS T2{s2 b&dP7Rwi`#Y1gaV!?q1V ܾ,9yKo#=㵏t\frC3%.Oh ;|(9a&'Ϯ"i΀n7vŴ Y <)kJ{?? ɲA():}!!cN֢a?d8D'ڹ|}76:FpyYl\lä.-:#)+|08˥1~矠69) endstream endobj 582 0 obj << /Type /ObjStm /N 100 /First 916 /Length 1686 /Filter /FlateDecode >> stream xZQoG~Gxٝݭ" RDD$.$>8-<6 huGIwvfnw>.It6V\]J[ [] ,{W1'erDrpLRf % ̀99~8)_UqJ _ 4R.T:/SDd3.cGzǑ0cujp,/Uv\isMX`ŲC`.rZ\LE1 ]RY?L{g@HKu a _,ү87(h;A $*2T.Xd'D| rRN.S]H&3"pcp`].\A\%MJPb=+AԊFB\Ƀ2Q\fK^W!*j"I"YE#F"QHBp\Lz~`$QL^bv|!W%AJ'IkQ$JH$ #Z#x!#>mi9zK+:`5%!2"A%7%}C>u}λjƓr9[]X~vp9]LڃnY7;Ў'oe_Oh$9hj @_r]fʓEwr8Ck.)yMr6_^#a5dvٷG?NϦO΋m :Fa.0 K0F_yjɬf_Y2^5jxUë+*Q oTxި>DŽ o-*ww =SdL^Q4̊l5L  /^0`xccCrrohg^mis}u&ח{4ʽQro{("q6Pxlʸ;^+k*RԢ)hJ-RԢEK /^2dx%K(蟿"vEmk+<G;¨F7*Q oTx`7l^rwcrԏ^7!dYb2$m8Wd[6ٖMeóXJ6<{W,R ^1<{T}RI' GܛI?Ku endstream endobj 717 0 obj << /Length 2491 /Filter /FlateDecode >> stream xr]_1}VeCh%'Qޭ-zHa:~{AR"%ӑjt7@&Ē%G{K:ȹ0(9;^"_Er}4'+Ae&Zϸ9AZ4Ot:I9ݻJГ<$ɧI C]x|m!e"38Mc*nNy[xrd "sqd)rpך[a@j60y.'䮐-V-iA_XnɐW-F6|׫@)C'5 4˵+ mG2:U oZ[Oqd0 : ~' orf́gڭlq727H.V0"ba79f"̹f v3 *a:BB8v褌!S4]0Ƥ1]| o 7J R@Us0AEFPɆbDd05+"5mNN3] Olf7`w j0ZN!N9B}T!@lbUObymᗹ-t~7zwK `8d?D86#E7N㒴h4B旋,l &;NWG r&tᚯ^?<[\MY˙QN4dɑNpB-ѲlkVKRﴈt ;C.rnȡadU3b5L[BG(ys96m$Q6 lUL` WJ%1\R葸y rWʴ|秘]NFnB=ObmwjE0tP?y)S ?1&;T [ݘhH<}0+Y#?&΀HLK9݈lvFnӎFYizu _̸! Q Jc iòyωKHm_J_]Cj/F]"/*Ey}B0[1e t1?͠oAWTEBED6BED+*5޴k&rbHW+ Xd`eCީ֕+F&;/:> 7N7Nˏ<}nSVc<.ҋk؝ULܤ󛻏~&t$cA2ufL>0#R_L/X-}u'UN8#4w#8|Y/}/pv/[LJ[aѡSLJO'j-_& X.nms?JSKG%Cشp`lix'&dO3NO 🪓V/1+ƷYrәHօ?+k0qMIߐ?9V9z:e^HME5A'b[~xبU;Uh91v9n '~2hhgiKzWCϓ)[[F0Yk4&B޸ٜ)4[L2睷W (R,)yV! endstream endobj 744 0 obj << /Length 2003 /Filter /FlateDecode >> stream xko5 K;@B$A >U&gfX]zIHh+Zyόi lgG^@ΔWI'[!-{}Ď'KD[bs _+Yeֳ>2@%TU0ΰn>9g%t'TeHr|+m |SI@ܠ#]6EJYz@@@[ u9pC,YQ^ lO'128EF?Y̴ҹ_'s xԜ&}$-F[.ܥ1򉒷BZ2,m@ R0m7~q_ ~d hBh\a7㦂7kp8y 87mژ1)g(*YӤNf "qܱ|.u}C"Jm PhgyIV{2媀} O0tWX|N(OTpڞKx3Xx:q/r!&ЎRI\ނ\jI&E ]| bEcfV o.XM}ݺj' "3&mzƻ(Wk4*2R'Z-3URzUY=fMDoVfz ǩ*TdRD`TYmQ&w`=yF%k DŀԬ"#RQċ #jy~@Z@rC 9DτeV?" B<2^ cfn} cΆ@\u Lc`/Z ,*1,' jm| (w{> 2c+qT>Ty0kT084AkX1ΩQ45 Ò4a"ׯ[.͡F0t֌?AvC'i~;ʘ^58Z pEҭnhixnڥ5ˤޢxA:HZ(Cq1p  lHhw/_QR$(Q.MB}YE21*UZƌ$|YZԟ%R/>CX~!,?Q a= a9CX]zIf=7 ךG:yL4OJl%SewwM0͓s?$Ctf##c967 ;l^?=.}+ .?xp_RfzjTKxV bH ӭN SB-&I#쎐~qqI 5H#S A{bA A?-?v /hū[t%dv!1) {#\G:5Ԣ~› z*[mm٧xʜAJƢs^8qT݊RzdIE5n endstream endobj 771 0 obj << /Length 1643 /Filter /FlateDecode >> stream xYo7 _Ge}貢@5 uqub'M~$qg8q׵:H(G)1J%@L;ŽLUKrNn =zOŖS֞WZZgxrdJkeVKv:tIo CKrA4>TB2+6),n1{ޢ7,} \p&!EqVx40j28m'l f`a?gQr<]U܃HF >e*9 %>JEeq*P\NVEy&dL𒶋$9BiH_i˝܆r0dcDځn&}P6NV>MdҖ:Y ,-7 /Hگ &DɥÈ"]! ȜIK+CTqs)g.h[(ٵĄpW~˒mrhڕBB:݀`X{f˚qcAsAx~r0<h9%))븕@?zG}ٛg Zz/_2BV?O^]W72ձ<% V/`yѫ<9׻k0!OV+>G7hbQ< PPlOl*"Q\M _ȱ Ar[ *2PjIͯ|Ϻ7Ff>X{l1y`*͐19<_&$?Gݟi,ntwe+~70" r9Y'8p&*Q1V-(v Q;Z{a#gh܂%;ݦL')W#09?R>I+,pًEokx) g%iY׃G'b|č5ZQ+]dw|GK=SWML)/*k(eIlz"ਬsJ'QaE>o3*ZP9q)AR'1e7SɧH*Uה ˔c.,Uyk1o8\SZPmWq,YwGH l5C2&fުc_v 5t5`kԒ/WDW"p/C;<O:#,7xvѲk'zڥY|1.ʧ&엪s:;狍:E?֌Ot:zAP([?ɒ>#8y9 1{I z*#GJWh4U)jήSSF _:4-Ƌj:\ܖqޡ~2zU}5^@R뤣]֣=mס;v}e\-ySؗ{:i=Bn͎6v1Ns\CXɽw"˿FV FQ BTUOHFyD|\8Y endstream endobj 798 0 obj << /Length 2286 /Filter /FlateDecode >> stream xn}Bh^#~ Pq"mrЇ%inu_Hj쮽kg[ fFEeǂ1vFb`)e+.cNhwh'W,]}8c޿5O|  {HʒLiuL[oY}1dt6't }bHrW.G/$kIaq!."e0EA@@i&pC*󂣹)ۖNaFfnWY(Py1 <%)C4WĦT@0,v˦T "N%0H<2σ"!4FජA_)2YLfo vzW[E\I>X04K;|] 03Xzx6ϼ2~]1ZP/gm9CJG]IJO)v,pfNIzm!)<'DΪ`DBR0jIsaQ~sbƕ6rڕ܂92 x^ Ѝ\ds0F&6A ÔuJ 9>>uzZ1mYC.wW}5Ւ:\<(S `<`^x>vE{Vx'HX{+y9 ZkHE{`;:..-:%Vo8Sat:vd)I획)tY`Aӄiۣ1M Fp#V8ǝ7(䲇iU@\6]hVqsB jolK$ʆF' } _l3rUg/IXS֢ޣӣWs%4wMfRu7(nYz"zҟm=̷j.P-ĉdh.3խg,{woUګWskլW}x0Z=ESh.[E>ʑXcgZX$ z.C6wyh}b#rB /C+ޱV)ɍ EGܓWQ2H m (vu0m y9ۿYtЄ4G-sg F1HQ^l&A%!-{-ϟ?_m5e.a /gg3͟bRƫg+ ,&hWa!œֳy?̈́ x9ȵ_At6gbZ/~U\Ko,kH܂~1]~f3m]K&YMf7m.1Q@f , L]tAb'hDH]#p 7S"YM]g<4^@;M\UƓpC% OIRFk|SH3)Cqzc/ۘ8`EoTښ1:d\=JVT8#HQ|3j 橶P xiT[xL ʛk [Cmed}-ܩF+g]j AЪ[j O,k Ok O{ij'z/.BMmf" 7$6 g\ջ e-1} AX$>(j ís//]׼Sq)K r"C *)Ooj ή>m5M slB[s%܏r}XK)ljg!kz*V"ҷ^dP+ʰ=%ex*}2-rhx+e9Qs'#/ jWCQOwȎ1]N2].gj SR<-lN$Cp\T\INN5үB +T.óJCʫߜ6N`1lH/(OSGΥiajzI'H?^e6ߚjnV5gi,/nK ?XUscwANp=Q5.I*!oΚݐJh]7soL>_4![5-֬ 㺚}juRw!=lqXLfݝ9K endstream endobj 692 0 obj << /Type /ObjStm /N 100 /First 916 /Length 1717 /Filter /FlateDecode >> stream xo7k{l]EZ-Ñ\!ܢٛKCB$Vw;_=r(#ςS1P)%1R.cT.S*' (CtM ġ2yO>'Ȕ@^TKal\o?d `9Vd7"[L<ܩ'ت8W!N B+b8G\4fCD69w. ܠWu ˋk?^ͩ_,U~>wxtw|aAwIhst'+zRiu.˩UKb O{{Rw?ꩻG_?ɋ7)yQo67n%go\CL0DJFWNڠ@i+N>??>V~q>;{|jl~/׫m|vk裖"88m\#ѓu87h[~Eۿ엇f'sj\PXjh~>koϛ>w35wwx%@ώl3G6Bgiُ|#YV.WKFp wxg/N7DxM7Dxj$" GA6}l,?k=>6}K}ӵOig؏wΰ_KM7~M7g~G8-R&.qO;qO{0+fEìd ےa[2lKmɰ-%ӗL_2}eӗM_6}eӗM_6} ~R]3v{M7ބ{M'^vk}^ ?| ֿ6\Y"WXR ֊Z1X+kRL_1}osc5}Ug3L ǣQW endstream endobj 830 0 obj << /Length 1512 /Filter /FlateDecode >> stream xYKo7W(D \0~=4=kYrkI;C.jer88J #֓Ó(H#+(,FrdeҳTd1&鏒 _j%)Egq"kajRMn ; $&_ N! Ge\g$83rBNpSn .Q@ SQ Dwd Ґ":H)rIa.PxcbbjNLmv,pf7r*8PoG.Y@M$O6%6s|墋bt^5,*rO!"qdLwOiF@=hd&we1$SD (I6' :ILoJn` |dr~H'JJJXe b̉$)$po!@e_?SRgJn5 p3v 35{|)`Y,qY\Ϛ'x$xaՂ(}r &tyX`O2)g'b[(9d sT:=:8|ḿϿr[!])`}xWE(*!K.lF$6krEtVQY %jP 7H]T>J,z{iٝ)x8{K5貆m qaQ!eC9K{LyC=`h칉qADF}[(CS/|mCκi>(tؕ->`뿲 n9F3Fg&d_3Qz q8D ,c5>܇Z 44LX:W1Hge0JVp.M_RFO|BYˤm` P xjVWU?ѳti/1_1$It|n!nT!x5{i+1bq(SFo={V2G2McN5Lcĕ=a#u?J#~c endstream endobj 858 0 obj << /Length 2337 /Filter /FlateDecode >> stream x[Ks6WrYj{2[~Te[U&>ݍ$<3LU&Fw@?NXPr(2YHJ\,9: }pYW,x G?d4T{Ozđٹ24Ґ>X)GVU ϖl`#H|W61;Ag̟4sN|l40WU^A|s?$§tF(a0""(/1YVZd$Ypl.4AURa:RshА)5@ڲ m:Z(̠ו:z]$ f8`QC3އ#zFMee < 1^/&#ZMkM9M9+O|h`OMx %.8QGwi"O;b3̋_ݰgc \*p9v!M!L![o@P\ /@;˚F޼ |{y\ )]@ WpSmoy~61rnMCI`PUTV2.bJLzu=Ź:Y 䫩`Ps'L\M%js`Ƭje*q뗧RaD #bÈFC 9f'^(a*D <^S_V/l xv 3yq+%.. b r,~[w jo/kg3Cdl݅-rR/f*YBhz{H-|8A 3γ#Ρ@|Q@*0Os8*5q]IaM+SaHǍHizqLm܂t%8t"jkcH\hơ!A G6XщD1ܟh+ CkL3ޭ#xuǠb0pF[#z}Ll}ZVe9=]A" ⪕5.YjH0#@z@ώvF|4nAFи2pĠRG ,ё ۩IBy؋IbBuܛ8֟9&3N8jҤMZȵшǚ/%L?d%[J&+j2$?4aD4P7^i1'\ىO"WK":%r-^HE{(%ַ @.bx?q"=Lӧl`;EhXE^fksLGVoJ mAgTˀ\뉪vtVݲْۛ9H^@BcoV֫rjLzص&àu#09}zY/[{/s@8ljZdze-oeSMXm4ܻT0_<$g " /%Lz W*؏q \$ 7x ;oo8, ,|…p_G&T3ῑx5UU[\ 4~Zp޾W-q2E55Β t^PxIEaO)1%"6\͌cLg5sUAR@}_ҍMxW+Už> ]yg>/F1^?g=+)ҩg`n)CM 淪0ʹJ^+u> endstream endobj 885 0 obj << /Length 2141 /Filter /FlateDecode >> stream x[Ks6W9ƛs:˵[JIhFzv7祗c;)jh4 ٔqvWJ()+k fք]֒_n+iZc\Pܣ,:K0TaZ5[cgtIygCkji=ho`5J1 l,^(` 5?Dwlڐ"s9<6P*1akj#(S)߁ę(j,>ÁyML$ 1%ex+&tU"\m9MU'B)𓿄D\:H_i3kBݓ,qwwe7128EF?iIi1殟 K-X4И95NQ9r؟/HjG:#(i`DEayn=2'"AH~J V[-qL$4zАk5 H6[(̤bm(-;z)r ' ڃ9LS3ߧo3FFCe-z^IWҰmemd5BNcRUPJY&%{t28)$(y:VW 8*Y*sr .8cyC6li\) .. )s  Sk+WO^k9%Ick#pz<;]¥Z\~?y@l{$ &1Z L\Ɨ[^m4`F:ū& e #RVa"o  ܷlOi9 G3WGRtvij.G =۽rcS+ḙ'8KjAt::jh.H)xfdԚ]Uҙ f&d2Բ@tĺizŨ"@x^NaJl#'eVYToNEk_4*zӒRչncNo[zLjcWӽZaQxe4`xW6 %IuRNbNX`)\OaIpeu'ƒ5<[3=?Uر*MyH45><ƒ&죶U.&@pXPFB8:w_Aq`q~.p?nܢN$܏gp? rNtLh81IvxnrM..,|pOB#EA-mP%v xlwkߓ\az@J_ )INR %xBkuTG`xX hh &Ɗ^Ηħ%xL 0ehCD4e[2׼Rt @RHn (Xv(ck LQy#RX;0۫Q%Y6`D-+_zoս f  ,P2"G`2YYA{ =sɌUh`[Z২,`4l#4B7]޺0S4O8v TPqVn7vJw@*ψ3N*/_$}"~hf=J,?}xwE8"L99姈=6o kst KC(!⸈p}v g?πյ3;l#  g@Y<(*V @X>]!:\R`T0 EмzMIGW3'݀e,a@*uDǓWfI|;08G '<(K52\il)%>O f,_ [̨z;R^c~Q+6}b>ZJTTN6NbyB>=G( B8m3 > stream xZn7}W}3 h.uZM8~Pl5qHjH/N+е&\EQhЊ\6W`Y%86O ("QUI@*j ԶX`R]TŌ(dش(⭶舩ƎrrKdGK  +r 0!|nN>)C!AK<4B(3)ah%t)ņv)gtɥIP\jU11E N3Pp9Otd%+M!v)%WBwʮĊOBt+3_FIdiq"#XaN%E3  D Ռ ֙_q6VJpAҁ)J'FM:'v-`lDj]ʈ ]1(j4=[Cb cS eM2ƴ9gHЏ #B dT4EDh0x 7Ƅy1U cQ*Et96x 蔪y A( QI{*E$]6RrDLW]$).c8;r*uvt4j[j3N^?\,Ϻ۫b8`݆~wϮ9ug 1pJҬ[u'zr]O盋Ւgy_[Yh~#nu'9Ƀ߸>(xNWdrE_ &}ՕeRNaLxyQ%RH 袹&Wk"$DwЯ-!$ҰL$xf1>ОK'L2iI7' 1/cR|<v{IZ`/t#ic_gL"BM G$_AH(H0ִ[LÞ;ln칗pYDz8E;ܞ=?1o7Oƹ#by~یqQBʞ=^kt]|gƮ]T5U|ݭ3^pg^xכg~~逩"SGP[{q%ǟ\ r*h/^wSYXO^=7zhͽ|p`1$?4^ E'g8~/%A K=GUǮ{xq=0f\B7u .Wg^}8^qëJn^| \o1t#SkcQmd-[^4hx f._=p YX&Y$,,cu4FXdir,zv" 9D-Ckeir,8K&Y8AdAzBYF-9"ol؊QUS7L¤}&^_E^/0#Nǭ^Zכ*ݺ rѻ6i^T;Txɶg-PS1SO ]#z*F|*[5.%l[BU!B֪ ɪ ɪ %K /^6lxeyDՉ:U'FScNh2DSubNLՉ:1U'K{_Zi:[% xO-='!^1eULYSVŔU1VLSjŔL,^U3cm ZFdRxd, Fᵱ(dRx›ޤFz=3 endstream endobj 913 0 obj << /Length 2206 /Filter /FlateDecode >> stream x[YoG~ׯ( ݮx[dX`uyHAV貝ׇd]}ǐf,Ud}3qV@{ΔWI'[!->a[#d.VYx({(L*ժ`^gbuŶFlB'T}a(r|+m zSI`D]^t :أS u%hC,£Z)NNxJ03ՂپxA%UhTփHZ>ejer@r#Gq|k9MU^fB)S" d̃tL,<1e<@n&}ɝ|+O9+|ɚ@ւ;4odjԾX.={U${A{0g)bj6Mtw@@"ґjjTuuEN~7|oo&3LfM/9K]3:_)5ib@~@c LpD@ 'jD@4gh3G̸'-x}ųWO;<[aՕ6YEi"v{వF[;ۿos(Hvs߽݆_ܓo>Ǿ #=i'һ 9+>#b1\~.F`{rэ/QP DicC8> stream xY[Oc7~W1yK+JJ% z%\Vz@Hx6sTYKc !Lz,!)F5V+Pd 5Fv1]Gq .{s@YC!wf!=Tz:֨ӯLpVLs29Qv+y _DLpYmL.0I_?x)_ꅗ# " LDH<!n"x'cDͯg wZJq',Ycī$ݻ|a&f5#?SA$v.e4-t5O["=_r 4޷c'zv/ [8=zW(sH%^EG"#Bqy=+Lg0E_拚k&1nڞ!J_mg9?-c endstream endobj 972 0 obj << /Length 1938 /Filter /FlateDecode >> stream xZYo6~d6h"O#F^k=|%M58 sp>Ql8V@+ gUZBVfNLOnKf7w/aCeZ/C9@^4`RR9< k[lk0- $a_\3[qʻ rm0Lp8dlk9fi` L]r3@9˦ )2q* (LT%=M|EdaP[oK(J*}ʡ"ե5-4([!`Zrdmϖ'W@6d/a $wOi^W@3z Z7~|Sv9A#Sd kB5y$`ϥ`7Iaql2$~\%l 2*.*,bW*BVJJXtb{X<4"r-([΀ao "KiYw:ɔ Q S37+#6~y~7,sD 2UPiRT4i=&O iIƱ7(U|Uqb1'̋_հƅ`rR@B:wހX /@+RۛH/vv@pͤJ#pnzt-Fso](F'x{?fWS_>VM^4ވ*زU AXoؖ@꼬BrJ]EyC3@PQH+#V*JugxMxX2*;S~AFu&YĢn RԴth!'>.iz^jWdѮA?,TP?_51TMǽH_l/<\n^͓EZKTӨb݌RʭFE-d ,yI"ba s${~#tTNDL`u5,[H"V_#~hrƚh&2ZAVaPh{5Z{A906xK']zǎ 46|*ZK>TXW!*ݲ*ݨjhjE ]'n>3|v7HS@OƧE_< L.|4?kБ6HF}z87gsv9`!0:u1ۓۣ*]6fjԼ)PåzAִr.s\|\5XJ> stream x[Ks8W(HM`O;id,Ö丼~e;L6DF>4iV VNɡP҈J]ZT\b=)Gg;B_]VXϊ5v|WEX((⅐Njk]Gw{ѣHY]<(rWJj kk) li8:CIpqآSU 4s Іy⑕ReZpSQm#-Qx&rh\gr#4pҡXʂH J}Y>4 yxa4T{ ѧO⺏đٻ26ҐX#GUյgG6:HލߕMwlNThf4'9*ܴ5x WFiF~/97ICbtFQcDEa79f2Gf ~3TF˔ԉGc#D Il[N/qs:igx"c:a\JjQÂiCk'5Z5:l3A[n^}xÂU?_&XrFePń]~;^4 o=<\jWOlzZ]U =CG1lJ}4X ~$H* ,TgB eQ*l^gzII$JYjTؕM̵,~ܵЀ,{t8ncÓ(ޯ \Zm3J5u8pGY$%/.cWuFɯ>8^o5Mu&kr.Rr`a_6e[6@-"I+o0-zEq_o\[n{ي27ސ/wbl}7a o|NĘ4F=\Oɏќ42& _\uhMDD-'Q[%j;pCiע\4^^Zl  of%; k6QíYfzŽXk5@5=Ž9BQ=>ؤU=Y1x̤9GDGInvT\(K[?#=dq\ZmtLn3=椶5%<" RG?8;8;8;\<jW }"iIH){!H,[_eD]\-Um헉+]i$ ]!C7ܓG9hVSOBêƷzm>yڇ@!3t]w^JNGtQq<п83O?;~ΆI~Xl> ~q[myX> stream x[[o~篘ev朹B;kXMm-"WV_,rbZGDB@rϜ\Q8Sr13j(S37x2)zS3$TrDv\ѡÆt@B $4pBB\ Wg n&PJF C1fb:P¤"^ ^їb|bqRaIEh+t ̂,&y$g±)@^ foR+#xR!8UbdvbG&,!pVbrb!&gqq@>kIEB+4o ▀xdzkl^ YS@2J 6 dT-RaU%z$1՘$HX@ _zWMjD9Q"Kw_ڊz_d bIL8 `jGYL܈tIO,B{d0i ۆFbo2pzONN&ͫ^y\v9}/M']vy|F3O7EZb%3M991͙iu:<5={vϻ%G/&ȇ$a+SX UKC''Y|h/Yd:{,2c#8v|:_^/6ŚR2w3[g- oE|Y$&%8+3 /tl1_ӷ͗\v~A}RIEVM'Q2<>vi?Lmy{uuIMUwխήzċi߷ggo4ݲ>%YdXG~/ oo%,Ue[`ڌ_`/!/V쬅SӼjCae.,v5koj|{oPq"[ {x|f Ua_d2/zn-k&mE5?׭זemQۤmVׯ8Xŕ,.+{2\6޴Es/y?_nW7ug*Zw$†p7! I&)$PjBMRI 1I!&+?V~XSHv*?V~J+W:tA8Wv?ĥCc` ?KqN!ѹ qÁ@ܱwlI${-!W9i❍r܊X"IH9ER"D2\ؓ()]q!xS&߯Nc-y*Fj@j@j@*D*D*D*DBBBT~Q%嗔_R~I%嗔_R~I%èNcub|0 ( :LuՉcuX8V'ՉcuxOF:Ñ;ʽkW{jt͊6˿[kEZQkQV_Q~z^z^> GG7Am1ΏS endstream endobj 1028 0 obj << /Length 2249 /Filter /FlateDecode >> stream x[s۶QצL^A%Y/e[3_A;Iی<#X`@s`^* 3ediUd-K! 'dW˳'MƲ PN%TTbJ57`: $l>0daqʻ rmPM c䴚^$WQ;,iH)HuTYA2g”T K1J9cq^QdFQ*e4C !ե5-4)BૐC$hEp*_2M>KTC$)c#-+ryY6wxdH盲 ݉/qfp}B>DIKl+ͩ2d$&~h/|IcĈ%/ Å qX9T)* h7cAmQ)߀=,תJ<4"r-[Ec1$-"%EltaIN۽Sp[A13n5{&QgD(mq?m;*]5m)iI2+8{j#ZüxӰ ;KoJKe ܹb5k^EAL )*LY Dzݏ _fWXq=7O4ҶP9ƴńթYQUWF}͌-\#v0~zb-1X{U&I++L˪vksٮEF/dm -PN lxVFڠ9 -V7Ђ( Ra OjJ;e HB"AWV8oݮ* DVTC 2 K~\t&YĢ)jMA8s*il2=[/WeFɮQ?JWMl{Jek35`a"-ZTڢ` rըTk醋BUkA޶uEŠ._l|qσj ]ωe^#|h7* bu$ZVcX谚!ֺ W k `9QUk=;i F|ѬW0YGCī]i Suv7ƹ:(y>E{ʜOJ4PYQ+T _+  #{OXV!`_|r?xuD-hAKxd"F >.|(p`-%M$&tsqCמco.}_B)H:t9 g%J< )Džh 2+@:CXZ uMyUak$kбve1unHe\o m K}Rk?E'DGY sEֳ}K蜀A,yz 3Mp3Ct/ rNӏGC>[e-,K=KױE#}̐y;1ژ/'/)4#a.䩵Ǟ?2|o7Xu8i4۸H.bWi-҉1ړ0 W>=t%_Av,,ZkSjelK6e p@rQu=RoK 5K :W endstream endobj 1037 0 obj << /Length1 2318 /Length2 10142 /Length3 0 /Length 11499 /Filter /FlateDecode >> stream xڍT HK tݍ 1C )%4Jwt H;{Wz5k1xvρFMUjB`lIey--N7&=fWIrrC!H:Lap) n \N'P'+PB@ΘP'5 ?/|,AN`sS@f G47hB (a0vv7776S{g6 f 9\A_ETLA e v[ :pq@,@Nxx@Xo?pqK/"0/gSss) X@U%6;` ehj Ln WK@gs'̙lH_4>KC,$ W~R`'9;_[ /C,,b ;10ˬ@0/?[ KK [_^Φ `6@V`ovd7`@NǯϿCfy6euWZ ; @iL< ;[x?CϊK ]qrp\/Q)ɸe= ^_ejaXo9YP̭ڿ6 A.~8G/E + 1ZZ7.^ >Q\aA0 ^dv_KԿ.q~#nogQʿ?]_Ω95~#o9M#xf'9ۂ7%췜_Nf$<<$:v? <$7K.Z-sK uqnb'e;Exw=A?,2A? ?7_#쿙{_oG@[ t;?Fuc}B̓mƆԥBj[Jw29KJmZY14B:͖_ 0I.|NHE#Ʊcn(ԜI>Cs}zaP(եֶ*J ׁ?T|Ц?Iqb)7_1(`5_V ń?2/4umݦ( (2a넥b^ 9c*cO9$%Mx ~ydv<6@;{bh] ! ~$R]ev]jѭ=q ֝"g/[hn1%?Ah<|;YCYF~p=j G{V.2byOzh6Qd4W餀]C:?X'kIp}5a3I23rM/mN<47ǰDqtқu:)%Ӡj5^cЕȿYb ngpsk/e>rD#>uiP՚bFiTejf5&0i,p,g XY :wK $:#1+"lwg&OADՕIL9rj{`w<#w`"Z"w-+wqȶ?x1qH#}#oњO:UI 2m#CMYbc팺| kհ3nR]}EF\PEkk,3GҿV "nz:M2poyW;a ~ZA Ǯ`k.Qr}w=^ [GD&~0\θ ף] E Vr|BKش 9SEOԺﭻH 1u8B@ 7Qwȫ .-X(OLq%'wzU(#%VB9ĜH[+8OdnL6rJԛNXwv vfR'H,Z;曈Du'2cJ@>ۦh)HC2i(}_PBXFWtؚ5t(SflAg,*ma\՘y~v|iA >uB'JI|o=lƛS[HENy3O/Vm-\=*j!Td&E꧷mPK#i7HyxO @)LKK4ڧ^K^MwZi[3P&~_f1|iFBQ|8@M'!u=mZJb=~I*Vz]פ-[A^L; bR IAَvB;I#ѱFB%y+iFTmAg5kJu_[r2/4WE>.1>twhV$K!aP4,54iBLi n#88n)WQ˚sʬ ,LI+#5*jvܰO_ 9J̚Ie!t&:pkal_Sܬa87W$)a1/H3nJ4A3Dx })POwc!<Js"bo)xyn~Էg>~DWX&.=yf${OMzń2pNjd6O bG*<ߓM91<{3$wVf?sѪ7ăRY UݵP-yzSEHӼ/H x'.!6=XM5R!PSh*3V*yi!J<~=i:teJR.Z`F5X5sdTh+tY@o;&;I4q@JKg9*(5ʁ3Aw?湾RΔjKHXOԚKqh7cҬVl3hߠپ{|NN{wζɐ7li.XbafQ'➡Qs(wV~\`ay Hs$v\Ĉ",^SN)-`N`ˋ7uA!_E|9hA5pTq :OQ"- Q,VL\2OV<: 8YTn5B{!=]YcLC׸Ѥ_Zwy}$~OD<-""p8u&4D olA !X6ʩޏ/xI6\p5)!ՙݛF׋+ꪼ\;Jp/ }pFOg?l1eKĊ:ϏoF3WcP j#^u`t= )dIwy'wl>d&oV~( O}U/6E? M^*3-glKMS|A0}ኈyW傼g>4'Zv;`kGXkMD-U?D&OתcX3Nr)>v.UJP%ˤ}-w`x@/l qToeE)clra,fAdNîCmkÆwAmͦ,;^9DɏȚ $uk܉W{[PlQ.9B9| Sw4}Ax+ip>J'L%5ƣYf<49"<|Ed́!'jD%a/ JKXSɌCcxl:t.~(s݂dX ?81ѦtpfߩpG$ !>y=4 Y rg-ammW>i_wVTQK(]mP*ؚ8)>ޱ]%5ӤɴS0?Xp#uM GǩŇ .¬?*ҏK*.HĐg~EoUe<=ϊ?a3Lʨ94ODC^kZڃ̾/Zc6"[)'Ȭm+j}0›rzϬh_ݿݑd9~=XұKji:6˃wV7<[,^|JDYnH+g b^A76w]0)Ӧwnd*F@r?ڈpqb,Wy6$aìTC(uS[q qa]ش㩵/v/W?=v-f-r{wҲq2*vܢ"^覝 T+ Ҍw0?a aRvt^mOpf*Ռ6/'$ڀqX䙴0 +6&ÐԢ\-'%cĥ]+\+1~M(fb1vSݎyH^e0"b6 ںz}A|*͇|LM1˛/{uk$Iw̘Vo#1k"iz?O? &j=8+qטSU|ӡL g}tv)9g4dO$d/t^-2QKQfq(6kҵd#K~^p4רf9: %jNay*7ON!7xhP 98Spg[ai5 eTG=SFꪀ"B]\WT} ;fr#M>*}hZ꺯0TU4M`=y 1 =tQ{ĒGlJ>6%~2\?ԥW_9CVS7)f&"e$(s]E_hKN(C ˆ1oMo&i;<֫@dAOąR}|awNke!"ax}vاӾiYF_ "pkk7(x E’D{8i(\֎1Ή*zō+7mz4)[b;?'˦FiQ}p:ghT?#9g~-/ ΢;p|:p"N9sbdq{;Jjy:i뛦o'uՄK8wI.%C`wUɶܙQz'' ⷩoL(",a#(G#59ylq6j7ksxrfvTJ&fA9=nl/ QC#4Lfռ(x%2_aF>v)AF|ta[g⯧cG?f2hA^e σ"| -Ӿbw^xi`_no 3藻FjflOfOb˰3%{=*bk'}h嵠H;9۹n<ʊw# Տm=ZJ_j6ΰ(PFK WBOJ}ٗ:T=]e5 22b%>ޞY)sv0lK9kLFO=ʜ9m%Z[1v(+jogi=w9זnj]#jaH>h6 hGc8g荽zIn.>//6yf00;.LdYi?  2*GFk@OEE^ʁv*=Rj"Ӕ;wa(FY"v1 4.,+UBu!|{D_W^+ltf%yFzsn-y>ħ+>Iۻw~ ds9,kQ scmudaZq6WDK80[igO\N{ R7S caE:UK;znP۞{#RvC _ g&LYJqk-+jI4UNEwp85*nYH d,mY:a 51J\ƅ P@MVsؕkQ^*zw=<b糪Wo't!E-KXmm ՝X@_ܖT^K2[oO=uS=ENbgB$9`nHȑ^KxmP`™>j!ɖ{w6\/ UߍMLqpNCe9mb6 ;q4v]g Q-kr IJQ,wzqмE|{c^f%̦9VJ#{d/jʢU}R9t3¬*P-d>vڡ2ԡAzHJf\xW W_Nr1u;aaM،E|3,2wBvkMrF{\n>&\8yY= #Q2_]b6?SG6ɻcTSmq -891dzDz;L")Hk*6ꪦ H8/$A?a:OUZ}46](~tH2qx7}xu>'Kכ-꜁ǃ`H3։#؝]+gK3Cl!1)oWFS34 s{,@{E1c feDrJU"ס\C3絠"0cځecuhL5zO %#3zDŽR(cs&i5iz,LKp#$}Fʲt8&texD\_ ,"A幔:4֗ aj?V%5IkPx nelU.iƩ]6˯U:()"} 3 ]n(A~ sU>U=nwR- (Jz}#!Ճ7N4/_Zi e}EQO`w%\kԼ ]?$!qmGK˨R8ѧzfay!zU"6@w_ 2UrP#HOKK/Awofk9`X}^pPzD1 eOeE_acT~0DdyM)ۍHQ0Osm~%Wnjof4P<&T*BJ~@xM^iO\bl/؂In.q;Ly\T`zd]懲Fş4)%Jd ov5$켓QiVCȸjk&C+ܺXXxn>[X=3ʏsiR8~lo{mZ-JXlk̏-UsIq+L< s7C\:+Xg+N[ b˜{+y$| G.u(sl[T3S>v\q^}7O"IpeO-ShG҃tf^zu~lXU~{KٷM ȡ+/r;jm7h "m9UɭSOt]L܌x%j)Nxk"RP~[+L՗qj8OZ m"8oqI|tkdF\{J%k7˱';NK;vǑ3] ٗ'+~u o$g~fj|ūCmXxR8GWsUQU/'GMpκ+U؆Mbjj[H/km@m1+sϐ_honqĀ;[Ǒ6xT* SY2O.xP\~L^ u eڥ(ĕNDXhԶшXq?^x7DSqqrUM?wġlxvCB`L"yh_GNvSBwt(@B]@8Ui'7NdS!`CďYERۤx=5ixH;Y>;Q*z~ | GLơ%1@gHUo+n 6vh e 'WU u13N9W߸P>PpM"npkb2cVC-0#bvSHv6rL` ')Rw|cUmcIўkFm[/#J9{wK˔kQh̢pA`bQ@TyD(E;j|{q$$=<ԒI_ ; endstream endobj 1039 0 obj << /Length1 1408 /Length2 6052 /Length3 0 /Length 7020 /Filter /FlateDecode >> stream xڍtT6H(RJ?:g(r`FB@)TTyǸ}k}ߚ~sgs1ۣla*($0X $fc3cnb6cBJ/ ,N =DJ@J ,/ CPz-~@QnpG' v-N;.".~w: AshE(;8 RN7?͏p'@yx_PW؟C'8z! O=ni:n0/l?f*GN١\ݠH_8p#`&? @P͇zA-s("@mwàpį~2^ CbĿS{+f](o_w5 SS sa]!1!|~7uB~@ G쏆z',iC =HTǺal{} 0{^($?+`igP>?0'( ]. rՐ(.ղ_pUb(,maXn a?oNQW!OwwC]߿,k=1Xh:@7GZ0{G0P䑎X6Ap f 9/!H. `af}@Xb AXa~_/?PFڡ OPDzx@}WDV0( 68<] 6nvv~ʿߚ|`v(;*yzoR[Ǧ| 1#6 fhLCT܏s>O/ܩ>代x6ic# 78&i L8qd-Dl{*S٨RUI n}QֶpYd#w51ktL Gޕd]ݳ팭q^a۬Qren%aJق繥^TZ4݊)oh,AoА/V I?i KcvSiz;;B}4?߻2 pz^'oΜ$6ANm~V.Q)aI띉jgf(HGB.ۚ`0-c 4vc5zWZ vI yh2J䠎c/nAߔco(w+YH.N?6X0+r)>2$DF{2t ǏPv|SFrOUՇB347H$tw2txb_>N eh 0яSr/8;(s4j|)Ղ0dCwkd|R ~t10]^-%{tÒA9xm-[F \7*}9s{_pM@/Au A)Jqj?\}(-9>PvN92F,u;voDL>w?G<gj҇G"3]3[\W1׽Yڸ,f]8 eD7+gԕo7Bs_?/g$!cm] V%Lr}݈NR]r5PƽSk+9. q {EHˋEaAguᵇs&~ WFȯuXMv"#Kqg0$r9<)A J g4j [4Ѐh\g?P(2~ڕ\h彈|^`'"q-EnZh f;c|I3 8v%B F7tYxt( nĬIEk2 v#6ܙe "r6 -1GY|]opU * DZTkg#2Z7LAsRawRGJ͂mߎC$ >2}&{F"{DȂa&&< YNO#h:t,ͩw.+d=h>s|WwHv5 ׹1w847JV5G;-1hJu$V#UY+þfW9Rgf&hb'tt JxJ+QD,mY|t0ZaEOJ1]M;Ww/m CyP(7QVg9!'`ܙ͍U>*27s{mhd'>ى\U?P2 Jd'-fBM= :7#ϥR&)cZ3JcIUvҤxu),*;^l(k%oH_Bn`xт0Ba;$V+!{gSfZriY&+> ˦v̛T 2ydt#&"GB1SM>ctK4]8dOInkܻ,k>nť'e3E5]+d1`58<,`m.mB:Rv*s)؄ф&nFd^Ѹ]5["M C7;,`n^k8՚3KjDiR;*D4")fwv] Fu#o*G2|\u,ݥōS1r$x;Q9ͤҦţ5[̂p͵.Z ڤ77:Go6227 " `V:zQNr7 ve-IeD_ 9ND1s6TL쾅1^Xow" nOҬ@^ho$΄|d-qU(s0B߅'=)r 3Cx*bւ 5q5z~%"g讌33%r1SyUUC7[6X޷?brCWN`<[I"DPkҼ)\%(Iy{vuT фT@aڝ6c4L&$9Mng/T#_S],o߯8b:D?+uPFdﲬ,`.b%8h)Ѯ$(jqijYB? 󈆚bbXWSll86*nꥺxoѳ3<_,j"K/%$p:du:"Bߣ鼡7F|Q{=f 3Nq=MTНSvw÷$V4x3]U ڍ;;.PWH=nw}I04P.;59Pogkqg/HTf j.xKa+i 7+hO9^흐~>gҍzTߣ' m\`֫f`Ul"X|a`daR#R 7K4W;zvo]1|dTTaK}#z(^r0N\ѓ-H;Cw*b[rtRZS8uG|wԼ=Hlg4צy\nV-$+|OeFw^A jvM:\^Qʍ>]Yv5e_)Ԣb4/^Ϯ}6Zs싃+6+tcT U^#Mɨ^WSW j01H*[,(nSʓeF_!7ϐOcfdN9lͻ>V^R)0#EwxgHp]cK30CCK#T/ SZ Ex(58m@yIOjh9X:fXh ݡ+)?亵ONw@柖yv.~WI $%-) nРZP?3"IGz!wc܊Lާ|bݙ^uZg~e/ͯڤF\Jj˫RK dxkv0UJp@ =tg"Z͞0Oܵ[!n_n"^Χ< {ϲS%.(n mҨjhzgjXOh=,IoN\@T5 ~z7l%Y_ jp#%@OjR{d/9 A<<˾wdClJ!b3$rn/vξqb !A2udUy7zX.G}΁aCqƚ+[Ցѽ2.F5s|w7Uż+APSo]39=rBY& C#m6%,¡1S<r>Dv@? ݭ:*Գ[(JJmz<,|=d^hhuOY4Z\} ᢺ5!Ҽ#2Wkr{hCeQzQU{՞GQL8)-Pu/q:r\pP< fGB"7*kc,vF.5cO騜ˀDu䯰Ng?P>iKOdŎRok1ޗ̢6G\KuljLJZܩb~v' Ñ\7EvxG.ܡJ#!ʂir] gT/ cs9 wئNtl_c "_e&wr69lfYG[eSms%- %y9{?ˣ )"4ٖ2KF@+a˜/\ d[L1T/asذCV[dKD ^jL Z] XSԅȗTBfV%iuAI̺AD~ҫk Yvζ_;fBY2n(f &wVltChyG1Fυћ!!ONz/fw;b }4 kƩEuk]d:Et|>^nJk%)U1 )|he1ՃrWɎh)ߦͩhs} H6p&ڹYvg;̟.V̵ ؇tI7PpFĢd鿅P6&LgNL&FI ܠndCߑ+kM:R:½x!7:e޳y'Wܚe4>n/βqI\O07gZdCWT9BI \c̉g~ I‘Ȕx㥀s"ZDpU#l Ynͤio':p+Ytq2:QM^51Wl endstream endobj 1041 0 obj << /Length1 1832 /Length2 9386 /Length3 0 /Length 10518 /Filter /FlateDecode >> stream xڍP+PkpNqw Xp-E ZhšPCqwқ-g3NfYow&tTZlVP ɝ(V@nv NN: f! d2 w p q . P?PW! bPa(AntPgW;,LNAA~?`W% r;2ZZPKB0غ; qpxyyء6bL/-@v[h r;:@B jr`% dvj`2`}8NvG ӟ KK3d8jr 7( 8,`Ij@qG?YJvrwC>+v>\{'deGV:N602; `Җ>?a=9Cְ6k0 z~W7sr 01/W7?N?O& :9k+Rzw(?6>N/ ((wu2~sUtvL`{?K \097-a_ߐ:[ßzƿ ?z#o zÖ@ [5*`+jAetq !nro:yKǦ9@P7w l,al(Ta)e,V/ Af G+c `w\PW?)/C_$ /8T!N_!A%XIa?o $ /7 aߐaq]hZdߐa a;EqVo7p aex2<CX^",ϟ_Cb +\d`o% R8̮6Fԋmkeu=:/ם~6VYU%P\YkRQo㮬\w8پ S.0f?5zI9Cc87NvvC#*=N2!ƀv1Nz\kqg5|oabIUi[v&֕/MKS4JHp.UH M覱^ BiɃKʣ? "l\EI%^ z0OIo^[4jy^8bJET)wUUk8<@M-De9@~%dt$w@T%b {_WW- q&Nko|xO0:JN2٬/%#ZM};)9z"ȾeN@i6d23[ YbBprp+KA_Ub⽓)!6W]o8q26x+5]HP;H!_D JAźF'1NA1p z!%Y֟F4kx?nmc}(Q ~ qЀ΢g.Dll^E_+"t@A>|؈Qc g8Sԉ]tH#;g > 0  w(\N$ﬡjP<1>pA tD%ń$Za`EsOV5geD.&cwKbD'.tN|mT&R\?]ܬ N8T~G 1c'ً?%#Rɾp0-z WKM|S'Hψ;3H%[7%K鎀8] j ]񓕏# 硙z绎' $iK~P4rd<jeL~-|Fj(cydm_㹘+MQ枍[r$3ݯ?d:UQҋ?'sW Lhw%VyΛ[-]{UVNrH23~`ԧ?n1,vӋsRmd([3,058 Cү 8gK u[z E_V.?/9{ &A|RuX(>)G "7Nt۪nɀOW=WijӄN`MU-9O8* 9#Z8 d2AZ'ޖ.·zm !e3b7\ f;G$ Jrînx.YxX mQdj)ږ gهgULr9hL{SJ1zϲ 4Ge yB37>~4sF7{AZ.C?AYRu,샿]Rb"5@^U5y{1F=k?(.dg5( \Ak.޽ z=V^S..hl] B4 ϳ 㻮ϭ:V=܃YA3eqN[,>f3*Bom3f'LYU/ݗ0cB .0F^+b5D5Jkоp9/Ke.bb۲ҹ ^3g>j&uΑP G[zU*lM<1ݣLq_鵯> %ĢICK`+:DL:xqymqv̙isܞ KW~8cr,`22y}{c^f ' %m }P䂪WQam[4@9 @&Z* ms-AoS{w' ruكZFCq}ǖx\5٪VdqsSꗘ|rOkө$C:c,C3M눟NډSN ;-be퉳21`n25b7鉝1CQMݯEfQ#8.ãX%{b$YikEku}Ls9|O İlu-Zi_dcQCu!/#(E)cSx)ϸBR$xL~xZHa<ޣshFn[LE,8\O N M̳9t R* ؗ+~5`G"l<  6šgK 'w.6DaI=wݞäPDtһCN/sIÖ9G^θ!Ƞ}sSDmSu]t/ٔo-:Ks{jK'V Pǰ]d U;S}H<ße *~Gw7!MRFb7%\+lQlHyIxhw"ߪ3Ag~!$̏H,7)Lfh6(+&%3m">x µlSjCnܑer~@.\`bDVȡ*_S MܰX}dU GKmԷ^2(2s(tF&7Q53vGOO,dU!͟-><>)J)7+4)6@`n$Lbv3M7^DžS#.3BoIIMlk$Wė*Vl^Twᘼ$?tlO:ތ?.wOVdd+k` ?Q ­NoIoy\+ y>$7:+%5oJjV zΐm*dX?*BEjĠ W]?w%&b ]!P@+(Z[3 aJ!!.PRFBQ|(Fi\L:}J7ڟ Eω9ݥl|q ͛ʄaQ)'Ƌ-q] \]rxc_Wi:Q@;ĞĚ?@+bu!zu5;0Rv5eAxk2Kۇa^{ Jّ!H?f6r\'\7'-HHTe]^ 2g4293F߸R5Z^Cב;Nݽޞ{`ynmZRMqNww3h5gJLY&sB"3F W[`z괠†d4ݯ:U 1 hlL?V8A[d\K9q"Uh.Bbev9;(괮wV`PV~n@M=bd5!5e}SE`G)oCƦrHZ*ʎT1H\P֜XCX \{9-.q_~p]`֜z#2w0,MfkDf+ŕGe]3Yܴf?=$/N>VNQ Ufb}c4 rHC ֋ib5OߔG$leeGj!"BMj@)#j))GESCnxi{뷅 f(wumTg4 =e:lZR еP3 [UA^̭иm5Ψ9W|ݝ^BVͥnZsVY.Y4X$syǛЖD$%z9:"mhA MjFQ3Ze|?L>K9p s ӓ|9R8Y>`z͋T:Eޞ60$Oq푌8\#i(ۗ!۠äzAc ꉾ1}f*}??%ΠW='/2qfxM'OYꃾ")/6h13,4SOfx*O-0GPi [i &qj{Ƌn>[5H9?(Il׸u'[t$J-R9eYuRm4TtQ]?<B'rw+ֱ1a֩mbl*u6Mw vF(DD %2҂P9ϪižWޯQmE l>񤛥Ipó5,Po{Eg@pCi֓I5?a"="?g/޾ {'򂽗~"8DtfL_9qLCM|N_`%3kz:8 ÕQ*Izqcc{.NRQ~ǚځ/".4-:3oTV}[Ζ⊨taY)4|76 ¯10߃!axY 0 ‘O (КǖOu*5zX} Cd*'Eřtn{?9Pq=蜤_'d4#46ۡ`),p48E ?pq+pH=L%,OŰ+yv-vDC˗.=e$O8w|{* FJz5+Uh-TECh4YX:'B3^?c}dl/ 8–U .16l]˦P]ZoԾXgu>wjj_N̯)ijN3S_k|z-$]!Z R̬yNs Us\W*,SӅ)+kz\X !5gMqPf]̵*  {ߦwt)4p0E 7S ~NzyJdVo^ݲ{ 9-[f1lNȍtfd#3Ӂ&P&&DaAQ2nϾ`}:D հxA+ ;g_bNU  ŏ1nY?<6_ӯTn)#.W%pl,8EhA;1`|n&lNczwGk>,[Hl/ 'bmY|pCӷVlzaҸ2*IYėXFvodi%+Aķ2Sя$'_@Ry|z]0? h ٳ4ME8\#{PmViaZ˜ \@8:O;RhCZEIqkz\EJ7ژxI>h?r[v!済 p^7Q\l5:]{BPdck' " 噾&dsߪ]zx@ӐFp0C$tK\K)igP, c趾I=cq~ڻ]Y@7Ek#}fvEuOp_X}hPi|9JIbzEF:m9ܾvFs+18K;P3ׄp% u͏(Fh޽Im>ϊί VJJk]'3[ {\1݆/f)XB?_ gWLWm/ zd\%rbxz.X Y~ذ:yXdBJ.1֑2y&UyP"ʃ1Ɓi%$SNm9CtKnb$iy0>sLiNimey7T  [+_M?J_2)Q*<~>ݗ},:XBNXT1~:TI 88E uUΏo~o\c:N._VN =(m2(MXg|+ݔ˸ua $b$eX]|iPZf/}I4 qob[x,]tY-gn6DW<׉ޝ06KPbQnKpya?ig\De)EdlVeRjVNJRXd{<ua*N~=ϣ>'xc^n皆KJ=n ό)SU;MK9WbyBhqnV_w?=x){9XI4eu׵N8`QȻ3X+e$~Ɏ~0T'\9 j$sr,x׭:A\Pcw f{u/9Zok /"k.yed܏=QY7"i?`D&pbze0~U WF=RNI'I/,̄f;+>YϬvs/tj^nC_6*{4BGyi l-hs~}iMex[lZHitUXh=¢cԎim-ԙr %btM2CHA^M ?ºtQf%g|5p,J-pr oʊc;F}c (Uap~ҍc~t8=US7\z%2E};AW?$$;JմG9H)F+I {>RIL> ,t̵x+7Xg._R9Pt[z PMC)C,'ʷcl} z=%mdbË7.DVve4|S\OZlVl2pc endstream endobj 1043 0 obj << /Length1 2551 /Length2 13589 /Length3 0 /Length 15044 /Filter /FlateDecode >> stream xڍP  -R ŝ=8whXqw)^\Jqw-=3 3!m׭OrbEz!S1PdLSQ01201 Z:#,Av<82Q#g b`f0s0s01XgrZ ;L*j377'_![@h f41L, Agl`dr4Y:[N@GW)Wy#[ߕ1 T-,̜݌hp3:)Y=ocٿ odkodaig0eݝFv l@`#W#K#c_ąF)ىW€,fg*9;!Ohnߓy,L~abϨfg,B-3:ؙ@ĂWxU{_ʿ |A3p@K3 +S_ 04q-~Gfc-:Lc0xLAv6/9,Lf&'3a,I鷯w6/c7<@%ebg20^\m(oKwKMGmdkixi] 5}r@SKr6Ϳmtt*Z:X-~]Pdgfb?:iXNK_)L@N`h2h tk v g \ k`%q#No`b"N&o `X+xO#6ofr]7+슿O7F`>\oqѿgd^#96gME` 2 hs{9Z?ݙ/ ש†أI ASx4w~Yb[@BSgwg1JȆ:0:qO={yN{G[@ q"sPfT1ن.J$N3Tep[8νǖNdP@J 4tOiAtF' a萒oa0ei|/.H\ wC}Ӻ.Qņ4IZi~p*/%.5R4BWZO'h^Н̗Ł(Q DQcX(ٲDIkTՇxC]Θ:ޔ4s6drYb "jD'l@"vv<~yOs2[yq2Jqҧxo 9Y8%M%S oa轖ڪ7mL"#qLŵֽ $IC!c|IULq'1w'J!p Z"\Rk{'xv>, X&'l0ezO<26⏄#d!)qC"i&\ ՊE3 '[l&^8%t86xZ^+ ye$#nդݯ_E+\ $'>+u$6bH4 _ wQZP*u0e4=C)!55I3_ENs7%VW IlϪ9=K"+9{bv-8Tt.by gy}wL)rN]èz6 ̃bjL-椘`!۳r鋐µU֔Ⅹ{NUe9D+qZbJZR"fF A%+5, 2UFӑe)y/2(r찾%|#ƆWﮚԚ`a(LFSY@vV؜%SoW1W{TTc&KZ(YnBZl VVk]ܻ_Ҍc`uLARgmY8Cdָ (!xE T`IlN.#0e᩸(Ec0tI9MEX q̀z|Y\2OZEɳwq|qX$S¥'M=լ)_gUC]46?^s"h;0eC;ғG Ȍa $g{> ʙ8xҲcwࠁ[bD'>*Un0Ol#*}k.TLvހGc.J9_0~>bhWx,I<_PHUHσO,Hi'EhDR;iaE?})~%pe$!0 q xPcmy9NbF9͙sS}o.O:m:HSނЧ'`$fS, bq,2^lH-<w^ ߙd 5y'Bl;eQUZtkeWClNEb V#ٙWBޣ}Yå><śToF#aD! H $xsY?~(|x!OUy*ɶ^%$X<&5tc)r`6)%]Xs'Z$/@het^ DԎ!H{W+FYw3NnLeQP[)tDܣ5oh†L%3溎~Tc!ބoM!?ƛ"tީ} t\jYڡɇ FH.0B3#`S'5 fehLz7T#؊>#UG7JێSv=Rn tg]zC#p䫏F-ֺ"",ՌD^dyP OȶvqcU9]I$H q'_F_zlEGwĭy0zx'lл3 R:uxP3[hꓺt,}QԓD7(FSM Ev;!W|seM m#*VSb)2]HiY0 N˙F)"Xg.;eT)BfF"<ݭEgGnr5>BC_nJX5qVQL# hIy۵wc ǹr!@!v6 Ż,͌ɯ] vJ$G@NE,пБ$0mߠ?Q0>b TZyb.9#n14NtItl.H-$OS`}kmM!=up RWW)jHbqLt}ӑ0|W?+&u)oQZj]Xl   !bYdJ_̄-[Ab}ړos%5τiFdT(cu-Q~^> _9}`bvAhE_g2B=?.yJca17v07[ofӐ9謒yTֈcGoqg+v5QHy >#OHwh݃m7#C}_gM()F|܄=O҇9Lvf;1S*xDVa5 spCO+c]t_!4Y&RKQIS۽;aE{r%L[+l Fpnr %v#ׄvz},O'?HHj~DCbH!#ϟRo* 1lQ4" erqzT*r*NSY]/@; yhc 3}J5͋q$ [yϞq-Uz".Nog@ cI$5d{eZT(ƽB`0:AUz30 fo"_ &+2N٩o7CBl\~dc'`o4J"p,j˕ ]ʢ K5D'!stt-&̖LiP2H׳?6/Sd=M mچvB:j*/9 Uh9e2y&'4I"܇'(dE*Nsz+v~N DZ;2 *DaWkIK51Ɛ[Wzfr"65%/v~ѣLlv:3r׀76l熙NܡǛ[$Y_+/8{e<%SQNߥ]G(~޺Kc>oUuxTo6>y>:W&6BډIH R^B&Kv0B,(q*lM=~OZ@_IFlABg8/O51mtdZ>7.~:,5,^xJ/ χ=f}CI$~[Sipqȥo"ldWE]'Yb'}rU )Rpp'܈1.)ݡ*-M'<:ocòJ-&QY5|>Y]|D^A@dzrʂLNI& z (^xE.[;TOT8NOG $|3uxD!(KLo"\Hs9mROIW4{F={ʉ/ 6Pv6Ô>.qOg!v/mv8o 5sU/^v:K<Aދi0i>ðMQ~N 2!Fκg|s k]FleQ1aEc r07;H9t+[(Kmd+NAߌv@nOךXEwq&Ʈ_!7Sg(dѣ;NKlnIqRT~NRZp#h},>с$V36lG<+tE~w8v>Y[MlJb'H}[c=QU4N8XvRX1e}>$L⒆V<˞l ۬N+"_'%c>aЩ(q>iȰK (,?F 8-D"|Uw" UẴkYP8~_2hE#?W`~2% Ɋ8ӋZ'+ RI6 urV|.Rwבٍyq,=[28|u&ԃXDFE 4{]z=B=(o2> Q6ܚ=HKYmъ&imUܛjByov.q `A3ƣ$nXV͒B'#^AٸD#P/yyovMֻ2G7acQmUG.,!DҍvGj.oŵinSP^_ 1mmvJ){Y:<Q$ې}al{vJu:DAv1lj_9vXX_$ʨs/M66A#{2X2sqOB-GXYӵ#ܭk^^1 A@ItaN_k@#A*OKF\ުOGU_4ځ2 0aáA:{Bs[C ʹTkRs_@lƆs^T;F:m+Gy ǒ;Ehi|RaAi_)f89†;$t'R*0^I1v*i0Hq[F9n'3LWr,/͡6Dʊu"x%An3of3m8(kst,M 0_̫ٴ~TCd!텅ig T_Z ޓ~O46[ ?Hk4Z.}eDzCK +{gzU$eO%n)`{aJT"\0Fn/S7ŋᝯϔ0`<snsj0rEEsq&3t5 x85*Ol3$;+̽~BDċGUA)޵([Kvnv6bĜV2'%L(ffTD<򥓢B%X|EoE-KڸG->Ԅ@((Ǡ3Akih@fgPgyeS ~ekX˂UpRe{҂om0j$\nOnS2M'b+D;L8sWFC7g1HI#[̜y?: &4U/t[S2 | h+e'Y+S<&Oq+ͣ]ϏbPFpK_|nȽTKJ}j;#rأ(N`sA-t۪AݡY1M =baAhKH=W:^g**L >4l=Uy3:G^ȓv dP2Yiw\NR1AD Eă@!b#6O8pr r%YA *˩ۂqF[`ld]W&EdlQ>7faJ}>̥y=y݌gݛKL1j1{lg skhٝL1qX"q 3)gֻAś+ AEB nA4ZXdzrsgUej3ITOX'Yl#ZQN4LGoӵw#]%F{}3zsUӠ2b5Fa)%yZ[z-ivD{uOnw1p|Ǝ樤 4ӱf,F0c3Tg61E.8Q&/Q AQ9]؄'iu =Q?9z ͇ e .1ibcEH,X|C#k '+)MTD?p,=hP+Lp۪Jp;K":"3<."QKKtV> ka㥿 fX5)yv SjYwښY!tO(Eӱe+1[~ 0)D+FpB8P &+'mԕQ$u%g6WLbh<\4؋^[w/Z>7kqL 6sDؗ[㑿b ;O0Z(ʕn'/c=)yO=uARw\6#+/ĽR TW=$|09-"OVEX# Q?6'9kB}FAMt`pŰY,^}`mG\+U)ukd/y QzhB!Ue /c$HHl-B5q~ 5ž| a~q*d6w 3Q'Έjk]~en4{.R2cîc_ o?Mjg_J^ WZezztPϧ4J2?p/|oB&^`E |=Qw]pUP\{ɰ%< 7b !3ϔAWVTJt깁6L:hr`%>ҲEDdM:z'_קs_IIgb'4bEq9P߬}gЎm-G%}JOHU2?)_!v]aSy(5&? 8O':psG^2\X[)K&-qQM~$V-*Cżfg~_魼O0WE g}esWCn QqGҦf8ưXYP,+>CV+-M+& t5j+'o߸D-sLN%RDY2gO/y,M`U1ծNE3( 'B2*YF\0# z禳c?rc`vO{~U_ns)aE?(C&8YR}wT':ݑ`Wh"dI BŞ(Yp_3ɉ@2pf`[Ц7ȕ%0Yx{d'Ө>%?*cbqʉC%c ĉoOh1q1ͤE7nqar|llTªz I4TpMwP^/~͡(W8-*flȢKWI4G|}Xg]Uk JOƚhF{i-]55˜4N{ F@hVJ%{s'ERnTZdM tJk*J(z [bW%UЁGqE%miM&J ̎yӆЪ=^C3l-ddF<91Ыp H]xА,M4! w - Cd^%`^qU |LkO"cmhw37(9UT` ai.K1pRYu75dNԼƥh(|= %5BO Mǫ`c*)Zv8M^MɄ^cɖo*J tA6w?&}+F lHNkJγӃ q=|| ) WF=DY\@@⒚'uFMWA;?MF9 J]jtȍI(}`މPd߮{oocé\z3.T Ly5MWԲT+yeY%K. ͔ނUAFO%|*_J3@sސAU!!n}rr)c=UqoAn  ë{aچ>L$B3ڊm07 FWuZm6g%G0i5ֆuɗlF'ˬD*RD 2 7}o2.[lZ5Ook1{SdZ1+泅 BeZr_W%x&&ݘ>U4X(='7d> AXZ~ƣˈR+8g>:ת}.+{u5ɗywuhɔ&@s$T0g/FYIej0`qH/\{?؀WIZ3F ꉸn8W {ֿ[nP YU|rxx(B05&Ჸy}~n`GstBq.RK^|IuiXtR\ٜ503t^|P\hă#,-YdhDڈ۔T^̯^dy K "˜oО$iԲF7֌aCe"f7:ڝ$kq܉vL(lC{186`k.34RqT]GDs%r:o^O}K:^rp2 bD-$ ]=uwE淘ŅB+[A̺)dx |͆oH:|m#qG]|Gz̜}φ'L+Y!oi5rӔܐnStD/GH C:G |~ErlNwBk(tN:מ!ʘȠ9Z(*yhٮ9q \v:9uxY9Pi3CQxʸ%c- aYxt$82v.]|*"vZU+.y"GrVEt98C9 - I w~~qzr1˕S; D\+*9Zߖ:[+vO8;0IًtNljɼ_IDQ=^J瑩x?%\d*8X N~B9ф[3\YCE*spWY4ubaC l#!ki[ .yF=QFؒhtMkIi7N@07g |>ϫHxX"P(?=ŵ@F-|zH/Oc;"DTV>I X3鈇e 9NqȪƕkԎ&=z$$(t;q͉6EhMO&5qk@܃? -e.f)Gt EDl"L.]Vummʛ"(,?+,Me+m2e`zd+uS񞄡v@!I$?Ǧ/y _I) , U{k¤Of9~8 @x)<@i5o>EV#Rζp:sʂAϫ&Zl!\?Py޽>?l4$,"[ʴ.M{I֫7#6ɨ]UXj0orlۛSi\b9z3CS'EEKeiZ1IEcPWF(Ehw]}t$( Q ;7ZMt&HFr'l*7n~ջ> stream xڍuXZۯi;SZj`RR[%$~w⺆Z󬡥|*i1B\X98U45rr8888Pii.vTZ q#5tyI]CU EW;'7O_!?@! gTGO(y `0gp A@ d9 1\<;;ޙ cd] g dkU=ͱ4!.@(l\,@PMe#`X9'W!@ss#`ہjl..,_@;gs> =-T:C.l`vW烖qx 98O ?'Wlqw͖` ˿bȮvr)H'لfrrppp@N5_hy:vre~އ#`/@]A:P99`s d?w0xnBN_~3z3 /4-%xsXx9~WzG ?OD3( y`wrr?p)nGoMvvG0Oy'湇]]A<;TKA,O<Vv%Yxv1ik5rv`3g|sfn8?w.2捋BLoyv6s ysK[KeR7 إ ]_&.o+*鹊ڿ$xZs7=k1MUNE,Egq`??Y|Z֞g|j>+Ye:J\!. 3w >+r/gEn"|V>+ ]GC<@ s$c"7oXNJQ\zeL64ssez8emUnVν>Q{\RZQ%>]~K&l)M"*¼!x!naիIC_=N^_1EeRA.MfZۼoFfQ)ݢ&` ,cuF*mЄ`J ,x/s;6Õ8X#C7[SJ"wl;HZy57EHGeqgzaQ)=-s/"w+%`;a_Dp_ѷ6 dɆ*`mu9Gu@WřS| D4R!YsՇtp}1FEyjRl:6HVT%9d5f"k݋s'..$ 6x;m1-7ӕ:$'!cؗ-<{2H,WIv\q!/h 꿲N~e/ 悎a*EL%R#.!o]{\idAay.,>Pwq\f cU3pý&3A0l )eyʸ6 iuz(~:yS/Fq]+C8R%*W &RDӉd 8/&_F٤EE8>FRbxD=Pmͭ ?:w>jǘc-^e"Y_x&D֌ A9/+mueydqc#ooN+ӑo2i2eg6 A I?(70U~lgZ}w$PZ 7,t.:Q7c^gtvzUDﭱtQ /_'qvgIu٢.fSzN1HUK P u!$/W?+ jpqhC-b'?n%TqZt0/¼4v v5XM"h-ԋ7%[G}N""dBpUpM >; "/  _u}s!%hJh8>B?LAxq3+ePGGq5h.A?+lR_kVxa~^KU1R&V8Q8"ěiP(o3@EĊJ {"$"T&!D1K&J0_O-͗6,\cgX14V7.͸TJ$lF AS!`rGW Y`$UuF4\CCS֗ ؊8gfxAo<$CWVc$(rT&8gFTP|K êeP$u.Vy/0nU1bImDwpH<jOY#tb7jp[E*[8qX^ޚC?|סAM32!Tۓcgq}e.{%פ$No;00+y ,~W0uO=a#{_~yWvsI;oXm LY5@"۱2]ƮbYwo 4ԓrf+V0,x6O_$m=_xt@Q#-<2xdQxs]iygpAi:9Czǜ.ȥ! k$*͑0 ՌM=qnPO0PqyNu-C}fh\2$uqH0ܭXLMV>l=^ЧYb:ҙl/"8nk*3!Dgqt%Vx4jOfSk} 5Z&zʮԌ_/06` Q 'fzK[ڌ/lXApGT"Ѿ8ԹY@#]wGSX|v=M39E;tn|Ď[H1HvZj Eiw낳dmۦVTk%xvEx^"e?Ⱥ&J/&UYQ_U;$LUi [ǎ!.nu.,]xg%}N 1}eأS[Q_!́]Xa{F͕% i9l[!b'M o `SbW Sg$U1iJNUY: Qt w|_cf%>Z~ jR:ۀ ` ?̔P9uSK˙U'VV#bFcG ɓ'.dɏ {a$[Z2ȵX YL3}Ӑ/vUaR8y}/SF@q:ci4yEt=3Ǭ]Նkw\T3CΓԽ~v0E:MsA[d/98>FV(Im˯E@qݢ WMbɧ;"B[E߇Q{Ev>zy . A?.;#PJyb9;l}ӒbyΏMlMj1܎{e^$ke,Hd~B8- iESVۏ2ADUb|ZCz CƛVya ~(V"lrHPń+*J؊pg`n뱑r~Zm׷fn=1* q0V/"K<_?'o+k͌ yk<ZfTXs-ΎKș>>Cm:9vQBN5*l?tbLPBqUe<eжD(rӯr22P *-ah2#fJp<ŽZ,{&6{Awx͠CV2mVj:V4*o/{y6R@Ѯ33jN2\gRB1GK}[lZ Pzwglb/DլSif: *N ]5Nx{r-䐩^6#,}*ߐ ko2&_&ѫv^yߏv?#}};mc`T/g9\mkf~!Y$V$/20t:t%\ E-=W8p ĚC3U8VR(0w6@?ש v4~Fom_L8#_TrRf-6C>:Fcx}yDb-H#_6*4V'Xfz􎘢<b#>Ye>6NQ l?m}df1sRKæo$敻З#垁PT8GEJBClK^qālTo᜶Hbw,Q, 2fkㄒ īx d-dǢ}/Sy}ԣ9u(#!aoYc$oWfvkv1+1\G ʝ. )A5pD)f ÜBXG&yYxBiI35 fbٖ=5Sd=a0IlޑCp|dsMv@f/T oJ,ڋ娝,:/Kew8ϪVwF wlmG]"Ρ\X18b@J.M; 4!= |籠E ;9zߘIvƧT\,2gh(YOṣb"7b6Al3qztqOl^*9<꿓 TsPL}䟬?5(2B!A/p.EaEwj{u';*#H]#ƬbkSRhQ,Au:(|[J햯uvF3h DZB w‡Yhʘ3ꎜ }_22`ND.ejbs˝1:C'e Ȝ:,;^f k5Ѡjv%! 3I^ɲ~zƞ#<;/( x?r^l(itn'}֩iG<1ce}tCW{u2B5鈗KZvaޔRkTw;x᳢ YHfk~)_909 -cs4嬔)j@h-+]Z ~cmhyj)T l{ƨ: r؏ɋMPhv/e|\~ X&itA V~ˊ*a<ơG瘻DoFvkc5lKgqLޕUl Aa d ͊fdy%Ip7V}~JǤ'Xapc5c=">JG`+;r'IQ9? {33*rlvp<͝Z5Qw (G Ss Y-Z=s͌IL"Ӵ+FhWܬLZG7D6XA_֓]>?"uk*N1:oY٩fe CLmT^_0׿S=2|{R%6oHfE!OS46Z| Ȱ'XiLBc/1.ΥTـ/u6<֦>qp7n?G_ΉT^|O8sbɅ&đҏN(zؤUCmgzC$+T/L02v{jZUNP{vD_Oad|/t47~Ӄ'GkJ׮}l`GWP5 Z}{cBT] ˹lAiI|?fM_'ő`a 閏BВ XǞOdyg#Vt`n[Z[tuW5X#|;]5j;@OݴcqZ M?IVs <9 GmאcԈ|<Ǣ&>(FlM_4Pse"E6Y*>系̕ߞGa ˸ikKQ&ybKOFR??rz˩ŎI?zeb{[s' }+lcg\H*> mM#m;w7A}RC+ 47?5 ofL* 0,ҷDmG&:F+1-h.daqzqUL))HH_ [CimHSl!U_"zs8D1CC[LH"c~jAuvk_KlmI⾎" _f7$Hl#׵ ?&g ~*:䕯EUpq& M~{mms=z1ƆyhEXHC7MiQKY8/#q0[/8ꎰ`k-71b[+O> OX8q_ɴ`r3<{*'wk߸v`%R Q/fI~u3tQ/WlҪYyx[aʺZb]FR#`r/=Mcy(ɩE 4Gԙ!/cGpICuW ,}K7_ TJaRL? |]؇ +p,C6 Uxv ޔOX- {? Uѯ޹\6#c9'ZzFjrZhreV,5yC y;ȖQRjOS4{Ed^j]W9~Bil@ȹ8P|K {s7jE0#YbկpOg:uiS95 t Ũ; :r[/6so.^ [(Ϟ^eE+Z5ZW44'[ @\*@ 咽+\. aU:ꖡL*·(߹"8g6Ǫ|>\dOAzY]Z\hizn.FW~ʑ.awN| U*-#>|!*ѦҒ hy20 }mpx3`eSw+݆hS'I nV~)QB.b@Uȿ`aT00oe Asl3Tn}'FP["iE٘Ƒ5) RD;@KݴN~?AAbyj:;zFGk9cW(A$όi.SAK &wbEDﭖ =ZJlZ"eƪ^F`Z?֑,K)pH Xߣפ(!$ ^ a8[d6r *[V~xPʗr_3'ӗJkgZA uI Q 6C:6cjoA&q.[zZ^mpfY^˯4Z;b'1:\B#Vv .^0bU+"<}L } ֋J?:Q.6p$ۏ\?{V3S-s`%4">XxɳK.PQ%ݦnޭ}t=_ZPO?}Sޠ.}*ouPwҼI|˅ɱ%N5_(AJmY6S8òa/8n#{j'E5;'r2wmB`?T>SA{sI9-"%$$ tc}ɝLm%wW:?xr8]g*l`y[2 /*:L1Vlm-0a|,v猾b-^=aD.D>``+tys@WjTA5X[(1;nBCVx } "W}~D!ڝ ڍua_&1x'*D͜Oa_W<̥JLs6q\w(r zN.vnk qUUj1k$bf/;c_Bd/hb"Ī'[b?(K,ղܑpGn42}zU0I/¾sI]x=Q ξi ך(rƵ ͕Z|qjUD3eސs҇bdZDa yWPR; sfrH WyypSn*ev\>DU$rAd2/I*Jۇ@_T_#\$^3^0 EZ+ϐ /qkk-ngvq>oy}"HKJ3wK-pOs{ܤz$ֆhabSfqUN 0tm2j2.4I5实咳j2>J1݀x;qxe'YO(hm[tE?N-0@ ;)>Y|S[.q#UW +bOu5 cQiӠfWAwYd7fC/1eqKppφdE,Ti@eN3X:ۄʁL!ݻH9 GK Kn4DP&/i:j ^LPvQB!뱼Lc72hs*Dӊ&ܱajF%Zvˇ5>'t!酩W9խlxenmiJ dfZopYLxぜZ6e[hnx܃Sͅ;aNb*C*Ee}'jUAɋ!!iז Y^UQFM=RQ]lEQLpJ?9V_̐Q@"_E #D)6>mX/$ p@:E$҇' ( _[Ls+_> stream xڍuTZ.% H 1 1C7!HwJ HI)"! H(R߻ֽy|޽w >,n Qüx@@q(qXX ^.qX P8Ly¦`Ԅj.$,@( P 8,p78 11 iqEtq/*MחՓ z9 kd+xqXPϿp{/_apA`o@tj 5s8/rd*lcgwuCa{  ڸx6>6P_mJĄiuW1+pWW?q|\3 { Ub&6@EwΑW7_N/3b@71$jA ߈ T#ao$"F*zH g!Ffv_|? Paq qwsD<#6A`DPu AB<|? ވX7+ s{]s==]l<@ҟ? oȏDp"hKv^ ApfgvN4|22}EDܲ!|wGۆg!hM*ɖ0QkxH~i|]?~bn[_]^~Dz1 zWF=[NST+gI2oQ $:c<[YmiƨJSZKVN؂RJXYJؚj-9Hohuɿyp'$ƞx#0K~ Dzi[*`]4UkҀN 2/=?*7'8@,4). `;0+ᆴ}#S`凡~&jzq+UjK?_9M *ޚdG.IwJ(Q͏7 ȉ(!yÍ/Udhiǟi>~dmH{ &vzDh~.m/JOG:;>ćkNq=FDrNܣ𣕮9] 6aq}fE E2zp˹ Z}s>̙ hx@ynU~dZRnY INUZZ&8jԸ A gI m{fV}z;|x9sn8OLvYu_bxg5 / JO(6N+uasAF۫1Y]e*?4 t]*d[XLSDKqU4sSȒݶ3915ZV(c՗&xgrv^ 0rƮ 6[N6?!`kS;j3ϱ\ԨTd[:1nyܝULm#oُqe[DG#R-j%3A~̟pN8j+H2Q""HW#x ׽+ mvDsWn~#uQ/r'HzG~eߪ%5{%1^Љ1٫ T언;Sܹ'h=*3v_:x^ɸҏax*rhɳ3Y_d ȸ Nkgoٵc '{ /x)O;?ud›2Ck \OL6 Y*bR0byvx a.p} i,)= jzH}|W<#Hy!+'||vb(f*}S]Т:R5A&8ƃ(qx#WZWNO0VqL`(@8 ,VuxC]2i}3)orSŢr0սe%aFX#tIJL?!V V݄rLaYPLnhai/;[ԈO3oPS ?<{X0L99ΠV\|[@ٞV:+c9o_QЍ=ͫptX+ @#H ϖ -fZ1-:^,ݍ,78)sĜ嬍?5~ͪT셹dnGH\Ċp$\pv.?]1 YOI" <|Tl|+hC&z!f2.(OԚEv9|Ł%VfyP/%W^֓7FB4>R°Xe܎hs `t[vb M-w6u2eG8!.="CwM*F*F^/5`~"TF g hU|Ɖ^?yHltdOgQyݺi X\6sU;'C r[;/\)@-8 t%pds0zAݫwrOSμW\ b> ƹjMp[X m48#$ 2xy021TzN}nn{}Utg8*#*3 RgZӷ o14ZNگਐpo nMsNI7%2zdWFzoj"(Gr; >Ws$Ma?IdAK%SI o^ /60?vNv~%X뀜M߽mEd-*&S͜ĿV9#`.پ9j.s[l+0v<ѷ IQ3_}gƝP>\>Նʘڱ]*#Q)־sH;3{6IāXզO:_nW l/}0첩:}+NLpaK,#Vsu3X (6ZE :u&(۽(r/&+.\o;Ԭ3o6mMQ';ja}&y_EӃ4WhQF;FGa˻#ALBUK,vρ\M%ocF>M5I&@1[>uuI.EfZj?) .yO즯|&7gTӾZO&V΋iՌCR3:0!JTClV$>0U,{&G࠴J9*\~ͧ#j.+(FvXsXLt]~a#Hףb7>gJwe(ifsX܅Tv9==C.tZ*`nB$~F ϓ??mE`=oׇm0U|W-tX}p||AC?Pu?`+&f~)M>;Yis+94YJs?ͣuE0R4JC(Zdf`aZ#6Zd<ِCwل9̎|7"8"k &"S uc@)G>36̩R/w%?2,h0,gʏǖNH6 ]/1ߙ!QB7\`I~0QBP3^h1qp@xmt#Ge?tN:s81 ƦFO-<)0 &2P@ՖᗇTK=>eL2i np?RZfŽR'%ΞO}`,@7'/˓-S)S _ rpH3 9y P?O~"Ƃ]h>J 'WD63Y, ՖGRe^\4D{0h(V@1ewE&QS%񣓲YBz D) Gmk耇 G{xƁ2NRA5wb9 I"#++:gmrw.4ƅꍺnDif$0Jύ9gKH?|O :`e(8~[M15T.Nìk+zbMHl{DUH)rA}4?[arJQѱ!&u2|8;%ݔJV|u (ؗ`FS@z~OzʭB9DtQt4w[зI8~Քqj_~&n~UJ,Wy9D<5?CX0^}% O-Lyל *ld 8cY(?-IaIh>_ӌ^;תּ8J5hkYS:w D }jΣwHX+%dAɕt<qT4G+)[I7~&Lse{%yɾ;%yD7_dܔܲ&eo7:}p[A⃋jjeGՊ]Q=jv8M3vl̻ۛKEý5 \^d *L6z"ڟAI7.BgZ*vIһڞ1"8GXp֥J?rpATH+kLw쒳^G,l&*SO\MoSn[+Fw?fegx >>cy;./K+.飫+'0ƭ!~Y(KqG!W/;F2(4X֜i{ۨB:ǂM"+_{Vof1ώb"KAȍ~8j|+R:r.q>_/Ҟcǯc@qi-ý6ZSKLnGl0Q+@,/' SrOsI|ΜZ9bXd߳퉸㈶&G%J5ޣ"{{L2 (.kIP kVεiYymU#b\r)ievw+ B£)֋'psEVDJL }Y|Vin2v}NM?G,Bgq@dۤkԑ 7?3ҝL>ӟ:tƁpIao~>2Sn-4v[ 5>+BRQձl.EnO-q71gHJ {m77,yme'5=."׶M]~l)T*oj 3 ^CNf/lEz|`aǒZ9JBkqr*C^93OY8EX=> stream xڍT.Ltw ݝ҈ 0Cwww ( % - !w{Z.ya!l\5]]A'';''7*.N8! Bi@Wfp s sr99#q5v2J'qr[۸B+т %$$:@ :Ԁ6 {G @bz FQWWGav ;Zvh\@ K@{ߙtm.u V@gJ[\n g9@GIr[XoV?psk߆)-, @/5 lhȫzv.>C 3Յl;EfUsۃ\]P' vY@wgm >+$,9^8@J@IO4k+Sr<-l8~rMfqXA@>.@w '*l 0YPC 1`O1'tf /Kד_0zah"w!6>77/$o#@?Ap>i*9XAB -umC3 0> 'yRVo#ɻfav^@G:j8>UY ݿeȃ=A`W o+fviB\o xн <A=9X@,7? B儎7 Ͽ&q ΨM8C 8dC_$ B\' P|B<'Ԟԟ Bi>!'xO_wN*74D#;KГ.T)sZsg-X>y2Y- vС7)Gt8@7 `f :v@?@kid*avo6(SS&x9ڀ@h>yJZć򏌸OTk7{4&-..hOlG#_߭f30y":ڹ7S;o伿WP炦d7Qz> 7h}\.6=s8 h?6ܞ&.?+mZa? jV)f%oups z:)y,P "C;k<ؾMpb >Gߖ#q S3/3s{]bk@irM0Bc큋Jw+Kk“Vas&"Vo_r+ҷV_Uٜ 34M  ÅvJtVKIv)=w!9qB!7b9+,x >yξx^/?ʫ) v]"cyGh˸f2 9+BTpXæ~J6. P Ntztva ҋR+}u)EޫN/Ē=,46|6^{|H,q Dn-zVs({X:\5uί&+ Q&5t棍LXD\cFk.Wpw5w11\}& j4CG\mkQ*,D]*HY2BkS/1LjݻpJJ)pO%ͦwM6PL|t(w8"5#\8B^l`n@L0Aw5 D[ oU_ ZϔDl8ݭrbXǵ/C$ ߁E-3WpɯVaG[}dl8 JL%y\K$/_s.;Vc-U'nG~a=:t$i>|~qAz짞3WOCa|^ظQ$ B4֩}N_2.vzivW1Pe8>+@kz֛u.Sq&o]&w5fO4%Q\xJ#l I b_$ܢi[E= E3 ULΐOI'SaGfM~y av K^|+{3]qK*mq,wVrg&9gl) %1}o _>ipla˛u[;>2l&<`@Էݗ:m}ݗ{w'5 1(B&T JVmdHȶzjHQ6ZCWǟCX L)-&.US0>>Rn{\2RY]I::[^+_eh8'ZҎ"2&Hܕ˲G+;_HˏU?X#htk a|Kp_׭x$a܎wgC:vr]Wc}o6X}=ߡ dg匶_͛irߴJ xNjK *Y+.li^g)O.V s?/L+9xdL>U 7f.FnrJ_ﷃBHWxOKeXyc>ڷ&UQsסJbèޒ@9;'gIW&"³pH[YQ%gUS@4}ϧp;9o^|z}]Hthz=rWWb5.P\_G(fQBV\8ikȕ(B]dh:$\ePQZZ:G"@\皐rP:ԗ8AGIE>k.a&g4JFR,`™F#g5^oʼn=|Qa Ԓ%ӼǿwLv!l@O}f$nM eD\: 3+h6c#vi/⧄hx *?n yx:Ce^>8K"aD̈́mlNG=TxVfUhRn˂ {]LױgM)B@$ֽ=s⣑/jy)>Zĥ`YkɅU^ĘGZ> @&Uq=.mikYWR ewv"k,!겄N 4-wٻQ k{a)B0? ?ڗ(7GTF&oO,.?EcV|I`~v/G 2ݾf`!1ݪJ4څŴ@펂xo80~m7;9Q'*J1lmjzO*Ҽ>"Oq=4P"/F5b> ӗ&=dpntps9 eLf#L`ƾiW".۷̣2LoPKPwwm0h ~[&<ez>z(1~K{$ҧ1Ғ6Kf{6{E;2 o^p)AZt ~ 1Lm_FQ?MC7:5t0#7RᜬдdS8+t2g!IxPە*zdyF)[iJܯ=.LA+/G?M*um/|N/Ɛ'a9ǚ0UZ4л*?r#޿d pU<ݚLy^ze@=c-wxZ*Fo}cBƯɁQQd&zs IZ9e C`,e<_0kÎ; 4*}פQ]N8^-څ݇Adc֫l|*mLc:6}j^p\'d(Z0>t3G8,-=VЬkQk nt_ Nږj$O%|icMKs-QjO%%6|-r댢;'?v:r >Ľ ˖ T+#Vf̻ eljHs!ţi6+nIL%c7V0gM iJª\>Msy!B~OSRX{ 2My_0ͩtuj j2*TjO L,E<ԦUi.k23`3d{K(U %&_]#V|Ծ<;8 _̵P78}dr=BB=ֿǁזN[f_խ4R7b™ x? W;H," é 3gkr\h?S7"oL#zc#fJw0C`8P+Nfh۴IAmqN#ốuuSԅwVM{*Rf`|q )kpK`ę=4H'Gqck_^ŷcQщLAd< R W֛?ڥT8X# s>}l&8;grN/ʋKZ􈃐"^Deȵy/q? 5lT˗&)~ҡA6|*ElI??aQɐV eSgeeo:r_.Ns|s(7owa#2n: % *u`3}&,'P4EM-Z0lmM{r}dJaHܾ3je/=D'׶aj3 S0 jh>}(b k$"Ogp0'0L3xXYkFIPmMgXtLM.'%aYcseCwCW|[X Ob 2F.'6Kd׍cm N47"t\ܲYja??_ːO?"XкzZ*6}NN;G"Gub(' ?0)O¼WEt(*LC|wI0nR#lN0츄Y@s잾mOl-sT'I@LN4y)PHQʫRfh#*Eo?18-2{S; sY8D D o F,pYWfKӽቸ1OYm$X5-o^`kcM^~fs/w36.<1B7e]޺r#S"ģ`z) #XˊDH&c}HTq wduO)_jR Q%!Ax,WШ 26;ŋ fUN8tL%\Nڸ@1/nE{:G$]")v}z3mz Nѐ&c51VK΢sgܣ~8?p3Ů8!Ӣ(;Ys%m7nhځYmqTLY!G(1cUْm.bm\[؆:sG@| gb-їp'eC[`LUÄ_OSaQJFXPpTŜ'+^dQWarc"}6s9V_A/@jyukv;,Fi\gR[5ĝ5@Jxk aiۚvc\s#w\^s5[8WUy?%d=00SvsK 6vUpB68'3+{ql _McXrؓ& If|oF7G$'^q9 njn!nv\UU pBIDREX.P7Grʉ2\zȚ7VF{tAǿJ$I[O-czQq4\Ifmx{.4,ko~ZD{7;((4 dˢyhUR.'q9Y+Lzpׇi/I.rw`+CQST@A˷Χc,W4`I^ЩVdQy׻"+"I~OU)]"st͑GktC DŦ"J *tS?"]1XwJSZ5H$oFܿw2%C5%aV&4|ZTnx.6f7܇d,͏+'bNrǢۖ΃skd ,~O/&廱,SR]y(j[&u[Fe{ra15:Vžck sf[Z}W,cֿhH Q:r[`j˖?x"-+f3G1M2̪6$wrlA_]Z QSWRӄwe}nU*`R H>|=$JijMWF)Diy[YE@:'i[1;]LagFTkuŰN "e6AfFmqH`6}ee\6}Q Y4Y~PM|j8_^DqQnx:rCm?>m'.?!D*vY Hr'`-e4 qp|v;M!m5Z~yYxZ %uj1Y)ՄoH_e{3?WyK p:߬D$.|6fUF9/+:pޖ;N-˯Ϻ5Jae }?P]CjjNoII0Sq؞؍l,:O8'4Yw! J:|,nq6mh{U+y\by'pCO S7&I{Fz @":.{wdib m<3y.crbjo;Zg+EXaKvAL.NqLbMHү[{I8Z]UrUQ +|xWDh]J+HkJV{4;}((m*HPvn\xHFI/^g$[V|*h{D}چٯ=PO]@0ϭaa,XSH$9b]z i8~J/VVz-eu?2"k +u.[޹ BD~=l&$FrAL/YY-тiSgeZBYǣ^--ѻN]O6I&oW{v4knRd#8Ue7J;o;O'sQkH  +4[`R% Ulq ]pB]vAݹ>3fz`U/9N;߻nHeRExN??l< \ M{8ڦǜ m/2.NP=AeNJ3rW)4WA&s7N?Byk`_۰ &d2bmIBEL#6*,@Lt`Nϐ!J j«Xo+s,V2$Rv Oav$ƚgy!G{GKy(YoLm駈NaYhڗkHvD; |uPߚR"~ n~U=aZl_a:F1Zؚ;Ia:ߵ)$vL-lb (aH((S&șC=>"'ɋW}AټoJS7`SP~ J mLTa9 7_ 63M;K~tc2FĚ ;o*bt*r"ri{_u D*}{|"s# H3qxz+8ڕ)S^_sOfҏ}S2n7Ԃ'RFM+r͇W3RD͇v-n޺}= nZ G=*}=&z\@+m$Jfqw!q_WˠZ&Xը;rtW?t2y]-빸JO(J,*QuL PC?ʣp>\E mk|W޷oun3o| >v&L_t,1l*T7|陞yʎ endstream endobj 1002 0 obj << /Type /ObjStm /N 100 /First 974 /Length 3820 /Filter /FlateDecode >> stream x\s8uJm]=<&k{v2ZflȒeRt=_չ* hJ bRLyi2k|:",(gdR ">VkzfM5kTx4b"F_@ :Ϻ-Z3e%8S@<;*Up-["D̄-![Bnl9˖l9˖l9j9j9PD}-VMk?'Uan%tcV=#}}d"+ ԧ]Ƌ8՛}\az7橠}*h ڧ}*h +-T<_՘.:h(YB1{>糋W*fX+F^WӪ\Tԃc1ϫr|u]6O=K[zYw}Wk={{a\~/$Ay2ϐG U߿ ְWX| X蚞؀cod!˲1q[ܻ:wLm+Zx1E=|0,sJ4Ti9Peq;qůqO ag&sKue OW(C' vB2"FGw׀oedNL52& s8< @Ap@1+v ֮iGwx$W5߽ =}J4F__DD㩐MdO؜0l(=;dkH%AiDjU JH-#WUF!F`D.58CMwq)4)b> 1O10[g$:`))gwK#Up':)]EN"YS4a:|K&W.($S&"er˄pIܡsAlZRK}n{j97x'g j1'7P}d~=x|T x2-/̤.:KJLAzpPƸ"[3/˛UE)Rj_5t2~1V'Muw%Ne42*k,^~/?2{~O/jէk|  %'޼cYN'i˚_+~U5O;k>yU/&3>Yo:"* CD-5_E-&_bZ.xÛxeΗ|9w1̿?z >4}ۍ7:}62`:)毎Ѣ-$>b4Z,3߾ylgNioyy2f+pLi+w)0g<"@lh QqzBPeS!vfu<-ONn#.fsN F7[--܋i4IRvwDYãm.ekb Rmfc0`ݿ}S([(emiv]m[T;3D B Cs-v~{p;=M6z &Hrvx2i&Ӌ ~6LZ)ױ.tpR/4n#7䢹Z|[M˺|#;ёzů-պ|ӟ*Z>oc چZ3P \lW_ >P`FlW@=p]=+Ny-| 8\,q>|%Od>u>mCzUe 1)jL/LL/l>hSw6B\%ßϐ^||ѧÄ*flIxL)w 1[Ĥ!>͠=]۾C1C>{Q>Te3EmSYs+ѮFN`e9,)۝eΝ3SDc30Vz//UHdH. ɰbdw2]Fr#b$0gÝIS3r۹A#/fqЬHL'͚6gzw=$=Zn{fm|9@МWWN;& T=DT -5S.A3heܮ[K{ٛݕCA3,7L pzܠ7۽~㩽vsGhAbz3> endobj 1069 0 obj << /Type /ObjStm /N 4 /First 33 /Length 338 /Filter /FlateDecode >> stream xm?o0=# }g)TP[&Đ"AM{?_2/ ܙ./lh&eؙؗ,ѷ}bͥeirO᱘tT-qY>FE{xxsd׸} >}}nO& 0d\uuiU_| x\\֟ܕ]/Il&4*RKX3YT*Ier ] /Length 2331 /Filter /FlateDecode >> stream x%IdIkKvW1A"'禗P<\H,#CoO s//*_*뺩 )^}3b:f`&ưanveFGyxྀ sロS0ut_|{nNusfnfay7zu=٣/ќЅO\c>`!a1`)a9V`%Va5`-a=؀؄v[pWw7'B7;ppp0؃؇8888888KU Ԯ=?MmUܭH+!1)9^%^'\`n/ZSُx?YUU9PNdddddddddddddddd䙡~`hKhOeq %ŚŚŚŚO$,|ȲȲȲȲȲbbȧBwM;Ƕ3m7eeee[oɬvh)pY3 131Y9hY< o5nWCflB,b,R,rJjZCkw ؈qlVlN,؁s8 Kn^~AaQqIiYL2cWolv9nnZO/oi_+)tCCCCCCCCuU U U TYTW*******j:b:::::::::bb^UUkڼڼڼڼڼڼZn ݯ׶Ӱ~5J5|5|5|5|5|5|5|5|m**(TPR]}v"m1T1T1T1T1T1T1!`)i1l\ះ}K˰+kClFc6c b/'syvcbNN .bG>mr/0˸v7ppwppO:xxKwi6;(xHQDQDQDQDQDQDQDQDQDQDQDQDQDX79Qv""""""""""""""""""6l6NX, n'WD1JCCCCCCCCCCCCCCCCCC_@E=v(F)b(b(b(b(b(b(b(b(b(b(b(b(b(b(b(b(b(b(+-Yװ~x5s/x6 o} x:C5s0b,",,E}s]¡nwCԇOjZzx1܀&llC.L(VWw9NN zwI I I I I 0q=nF/hGVHbHbHbHbHbHbHbHbHbHbHbHbH˰+NNNNNNMc!,,,,$$$$$$$$$'H>IRIOONBL}EIIII:uзrtзO׻] z[oo os >jGV%K@/i@/^z#"zܽ{s{K헆jg`޾}{'wG/=x|ێNvt2юNtܼގ΄?2Vڷ 7^ox^6{/dv6Y?lDi(`)a_G[po endstream endobj startxref 180302 %%EOF DelayedArray/inst/unitTests/0000755000175400017540000000000013175715525017140 5ustar00biocbuildbiocbuildDelayedArray/inst/unitTests/test_ArrayGrid-class.R0000644000175400017540000002414413175715525023316 0ustar00biocbuildbiocbuild#setRealizationBackend("RleArray") #setRealizationBackend("HDF5Array") test_get_max_spacings_for_hypercube_blocks <- function() { get_max_spacings_for_hypercube_blocks <- DelayedArray:::get_max_spacings_for_hypercube_blocks refdim <- c(15L, 10L, 5L, 8L, 10L) target <- c( 3L, 3L, 3L, 3L, 3L) current <- get_max_spacings_for_hypercube_blocks(refdim, 243) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 323) checkIdentical(target, current) target <- c( 3L, 3L, 3L, 4L, 3L) current <- get_max_spacings_for_hypercube_blocks(refdim, 324) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 431) checkIdentical(target, current) target <- c( 3L, 4L, 3L, 4L, 3L) current <- get_max_spacings_for_hypercube_blocks(refdim, 432) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 575) checkIdentical(target, current) target <- c( 3L, 4L, 3L, 4L, 4L) current <- get_max_spacings_for_hypercube_blocks(refdim, 576) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 767) checkIdentical(target, current) target <- c( 4L, 4L, 3L, 4L, 4L) current <- get_max_spacings_for_hypercube_blocks(refdim, 768) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 1023) checkIdentical(target, current) target <- c( 4L, 4L, 4L, 4L, 4L) current <- get_max_spacings_for_hypercube_blocks(refdim, 1024) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 1279) checkIdentical(target, current) target <- c( 4L, 4L, 5L, 4L, 4L) current <- get_max_spacings_for_hypercube_blocks(refdim, 1280) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 1599) checkIdentical(target, current) target <- c( 4L, 5L, 5L, 4L, 4L) current <- get_max_spacings_for_hypercube_blocks(refdim, 1600) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 1999) checkIdentical(target, current) target <- c( 4L, 5L, 5L, 4L, 5L) current <- get_max_spacings_for_hypercube_blocks(refdim, 2000) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 2499) checkIdentical(target, current) target <- c( 5L, 5L, 5L, 4L, 5L) current <- get_max_spacings_for_hypercube_blocks(refdim, 2500) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 3124) checkIdentical(target, current) target <- c( 5L, 5L, 5L, 5L, 5L) current <- get_max_spacings_for_hypercube_blocks(refdim, 3125) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 3749) checkIdentical(target, current) target <- c( 6L, 5L, 5L, 5L, 5L) current <- get_max_spacings_for_hypercube_blocks(refdim, 3750) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 4499) checkIdentical(target, current) target <- c( 6L, 6L, 5L, 5L, 5L) current <- get_max_spacings_for_hypercube_blocks(refdim, 4500) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 5399) checkIdentical(target, current) target <- c( 6L, 6L, 5L, 6L, 5L) current <- get_max_spacings_for_hypercube_blocks(refdim, 5400) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 6479) checkIdentical(target, current) target <- c( 6L, 6L, 5L, 6L, 6L) current <- get_max_spacings_for_hypercube_blocks(refdim, 6480) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 7559) checkIdentical(target, current) target <- c( 7L, 6L, 5L, 6L, 6L) current <- get_max_spacings_for_hypercube_blocks(refdim, 7560) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 8819) checkIdentical(target, current) target <- c( 7L, 7L, 5L, 6L, 6L) current <- get_max_spacings_for_hypercube_blocks(refdim, 8820) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 10289) checkIdentical(target, current) target <- c( 7L, 7L, 5L, 7L, 6L) current <- get_max_spacings_for_hypercube_blocks(refdim, 10290) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 12004) checkIdentical(target, current) target <- c( 7L, 7L, 5L, 7L, 7L) current <- get_max_spacings_for_hypercube_blocks(refdim, 12005) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 13719) checkIdentical(target, current) target <- c( 7L, 7L, 5L, 8L, 7L) current <- get_max_spacings_for_hypercube_blocks(refdim, 13720) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 15679) checkIdentical(target, current) target <- c( 8L, 7L, 5L, 8L, 7L) current <- get_max_spacings_for_hypercube_blocks(refdim, 15680) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 17919) checkIdentical(target, current) target <- c( 8L, 8L, 5L, 8L, 7L) current <- get_max_spacings_for_hypercube_blocks(refdim, 17920) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 20479) checkIdentical(target, current) target <- c( 8L, 8L, 5L, 8L, 8L) current <- get_max_spacings_for_hypercube_blocks(refdim, 20480) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 23039) checkIdentical(target, current) target <- c( 9L, 8L, 5L, 8L, 8L) current <- get_max_spacings_for_hypercube_blocks(refdim, 23040) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 25919) checkIdentical(target, current) target <- c( 9L, 9L, 5L, 8L, 8L) current <- get_max_spacings_for_hypercube_blocks(refdim, 25920) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 29159) checkIdentical(target, current) target <- c( 9L, 9L, 5L, 8L, 9L) current <- get_max_spacings_for_hypercube_blocks(refdim, 29160) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 32399) checkIdentical(target, current) target <- c( 9L, 10L, 5L, 8L, 9L) current <- get_max_spacings_for_hypercube_blocks(refdim, 32400) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 35999) checkIdentical(target, current) target <- c( 9L, 10L, 5L, 8L, 10L) current <- get_max_spacings_for_hypercube_blocks(refdim, 36000) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 39999) checkIdentical(target, current) target <- c( 10L, 10L, 5L, 8L, 10L) current <- get_max_spacings_for_hypercube_blocks(refdim, 40000) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 43999) checkIdentical(target, current) target <- c( 11L, 10L, 5L, 8L, 10L) current <- get_max_spacings_for_hypercube_blocks(refdim, 44000) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, 47999) checkIdentical(target, current) target <- c( 14L, 10L, 5L, 8L, 10L) current <- get_max_spacings_for_hypercube_blocks(refdim, prod(refdim)-1) checkIdentical(target, current) current <- get_max_spacings_for_hypercube_blocks(refdim, prod(refdim)) checkIdentical(refdim, current) } test_split_array_in_linear_blocks <- function() { split_array_in_linear_blocks <- DelayedArray:::split_array_in_linear_blocks unsplit_array_from_linear_blocks <- DelayedArray:::unsplit_array_from_linear_blocks a1 <- array(1:300, c(3, 10, 2, 5)) A1 <- realize(a1) for (max_block_len in c(1:7, 29:31, 39:40, 59:60, 119:120)) { blocks <- split_array_in_linear_blocks(a1, max_block_len) current <- unsplit_array_from_linear_blocks(blocks, a1) checkIdentical(a1, current) blocks <- split_array_in_linear_blocks(A1, max_block_len) current <- unsplit_array_from_linear_blocks(blocks, A1) checkIdentical(a1, current) } } test_split_matrix_in_blocks <- function() { split_array_in_linear_blocks <- DelayedArray:::split_array_in_linear_blocks unsplit_array_from_linear_blocks <- DelayedArray:::unsplit_array_from_linear_blocks a1 <- array(1:300, c(3, 10, 2, 5)) A1 <- realize(a1) m1 <- a1[2, c(9, 3:7), 2, -4] M1a <- drop(A1[2, c(9, 3:7), 2, -4]) checkIdentical(m1, as.matrix(M1a)) M1b <- realize(m1) checkIdentical(m1, as.matrix(M1b)) tm1 <- t(m1) tM1a <- t(M1a) checkIdentical(tm1, as.matrix(tM1a)) tM1b <- t(M1b) checkIdentical(tm1, as.matrix(tM1b)) for (max_block_len in seq_len(length(m1) * 2L)) { blocks <- split_array_in_linear_blocks(m1, max_block_len) current <- unsplit_array_from_linear_blocks(blocks, m1) checkIdentical(m1, current) blocks <- split_array_in_linear_blocks(M1a, max_block_len) current <- unsplit_array_from_linear_blocks(blocks, M1a) checkIdentical(m1, current) blocks <- split_array_in_linear_blocks(M1b, max_block_len) current <- unsplit_array_from_linear_blocks(blocks, M1b) checkIdentical(m1, current) blocks <- split_array_in_linear_blocks(tm1, max_block_len) current <- unsplit_array_from_linear_blocks(blocks, tm1) checkIdentical(tm1, current) blocks <- split_array_in_linear_blocks(tM1a, max_block_len) current <- unsplit_array_from_linear_blocks(blocks, tM1a) checkIdentical(tm1, current) blocks <- split_array_in_linear_blocks(tM1b, max_block_len) current <- unsplit_array_from_linear_blocks(blocks, tM1b) checkIdentical(tm1, current) } } DelayedArray/inst/unitTests/test_DelayedArray-class.R0000644000175400017540000002251713175715525024002 0ustar00biocbuildbiocbuild#setRealizationBackend("RleArray") #setRealizationBackend("HDF5Array") test_DelayedArray_constructor <- function() { check_DelayedMatrix <- function(m, M) { checkTrue(is(M, "DelayedMatrix")) checkTrue(validObject(M, complete=TRUE)) checkIdentical(typeof(m), type(M)) checkIdentical(typeof(m), type(M[ , -2])) checkIdentical(typeof(m), type(M[ , 0])) checkIdentical(typeof(m), type(M[0 , ])) checkIdentical(dim(m), dim(M)) checkIdentical(rownames(m), rownames(M)) checkIdentical(colnames(m), colnames(M)) } ## 6-col seed DF1 <- DataFrame(aa=1:5, bb=letters[1:5], cc=Rle(c(-0.25, 7.1), 3:2), dd=factor(c("E", "B", "A", "A", "B"), levels=LETTERS), ee=Rle(factor(c("d", "b"), levels=letters[1:5]), 2:3), ff=c(FALSE, TRUE, TRUE, FALSE, FALSE)) df1 <- as.data.frame(DF1) m1 <- as.matrix(df1) # character matrix M1a <- DelayedArray(m1) # matrix seed check_DelayedMatrix(m1, M1a) checkIdentical(m1, as.matrix(M1a)) checkIdentical(m1, as.array(M1a)) M1b <- DelayedArray(df1) # data.frame seed rownames(M1b) <- NULL check_DelayedMatrix(m1, M1b) M1c <- DelayedArray(DF1) # DataFrame seed check_DelayedMatrix(m1, M1c) ## 5-col seed DF2 <- DF1[ , -2, drop=FALSE] df2 <- as.data.frame(DF2) m2 <- as.matrix(df2) # character matrix M2a <- DelayedArray(m2) # matrix seed check_DelayedMatrix(m2, M2a) checkIdentical(m2, as.matrix(M2a)) checkIdentical(m2, as.array(M2a)) M2b <- DelayedArray(df2) # data.frame seed rownames(M2b) <- NULL check_DelayedMatrix(m2, M2b) M2c <- DelayedArray(DF2) # DataFrame seed check_DelayedMatrix(m2, M2c) ## 4-col seed DF3 <- DF1[ , -c(2, 4), drop=FALSE] df3 <- as.data.frame(DF3) m3 <- as.matrix(df3) # character matrix M3a <- DelayedArray(m3) # matrix seed check_DelayedMatrix(m3, M3a) checkIdentical(m3, as.matrix(M3a)) checkIdentical(m3, as.array(M3a)) M3b <- DelayedArray(df3) # data.frame seed rownames(M3b) <- NULL check_DelayedMatrix(m3, M3b) M3c <- DelayedArray(DF3) # DataFrame seed check_DelayedMatrix(m3, M3c) ## 3-col seed DF4 <- DF1[ , -c(2, 4, 5), drop=FALSE] df4 <- as.data.frame(DF4) m4 <- as.matrix(df4) # double matrix M4a <- DelayedArray(m4) # matrix seed check_DelayedMatrix(m4, M4a) checkIdentical(m4, as.matrix(M4a)) checkIdentical(m4, as.array(M4a)) M4b <- DelayedArray(df4) # data.frame seed rownames(M4b) <- NULL check_DelayedMatrix(m4, M4b) checkIdentical(m4, as.matrix(M4b)) checkIdentical(m4, as.array(M4b)) M4c <- DelayedArray(DF4) # DataFrame seed check_DelayedMatrix(m4, M4c) checkIdentical(m4, as.matrix(M4c)) checkIdentical(m4, as.array(M4c)) ## 2-col seed DF5 <- DF1[ , c(1, 6), drop=FALSE] df5 <- as.data.frame(DF5) m5 <- as.matrix(df5) # integer matrix M5a <- DelayedArray(m5) # matrix seed check_DelayedMatrix(m5, M5a) checkIdentical(m5, as.matrix(M5a)) checkIdentical(m5, as.array(M5a)) M5b <- DelayedArray(df5) # data.frame seed rownames(M5b) <- NULL check_DelayedMatrix(m5, M5b) checkIdentical(m5, as.matrix(M5b)) checkIdentical(m5, as.array(M5b)) M5c <- DelayedArray(DF5) # DataFrame seed check_DelayedMatrix(m5, M5c) checkIdentical(m5, as.matrix(M5c)) checkIdentical(m5, as.array(M5c)) ## 1-col seed DF6 <- DF1[ , 6, drop=FALSE] df6 <- as.data.frame(DF6) m6 <- as.matrix(df6) # logical matrix M6a <- DelayedArray(m6) # matrix seed check_DelayedMatrix(m6, M6a) checkIdentical(m6, as.matrix(M6a)) checkIdentical(m6, as.array(M6a)) M6b <- DelayedArray(df6) # data.frame seed rownames(M6b) <- NULL check_DelayedMatrix(m6, M6b) checkIdentical(m6, as.matrix(M6b)) checkIdentical(m6, as.array(M6b)) M6c <- DelayedArray(DF6) # DataFrame seed check_DelayedMatrix(m6, M6c) checkIdentical(m6, as.matrix(M6c)) checkIdentical(m6, as.array(M6c)) } test_DelayedArray_subsetting <- function() { a <- array(runif(78000), dim=c(600, 26, 5), dimnames=list(NULL, LETTERS, letters[1:5])) A <- realize(a) checkTrue(is(A, "DelayedArray")) checkTrue(validObject(A, complete=TRUE)) checkIdentical(A, A[ , , ]) checkIdentical(a, as.array(A[ , , ])) checkException(A[ , 27, ], silent=TRUE) checkException(A[ , , "f"], silent=TRUE) target <- a[0, , ] checkIdentical(target, as.array(A[0, , ])) checkIdentical(target, as.array(A[integer(0), , ])) checkIdentical(target, as.array(A[NULL, , ])) target <- a[ , 0, ] checkIdentical(target, as.array(A[ , 0, ])) checkIdentical(target, as.array(A[ , integer(0), ])) checkIdentical(target, as.array(A[ , NULL, ])) target <- a[ , , 0] checkIdentical(target, as.array(A[ , , 0])) checkIdentical(target, as.array(A[ , , integer(0)])) checkIdentical(target, as.array(A[ , , NULL])) target <- a[ , 0, 0] checkIdentical(target, as.array(A[ , 0, 0])) checkIdentical(target, as.array(A[ , integer(0), integer(0)])) checkIdentical(target, as.array(A[ , NULL, NULL])) target <- a[0, , 0] checkIdentical(target, as.array(A[0, , 0])) checkIdentical(target, as.array(A[integer(0), , integer(0)])) checkIdentical(target, as.array(A[NULL, , NULL])) target <- a[0, 0, ] checkIdentical(target, as.array(A[0, 0, ])) checkIdentical(target, as.array(A[integer(0), integer(0), ])) checkIdentical(target, as.array(A[NULL, NULL, ])) target <- a[0, 0, 0] checkIdentical(target, as.array(A[0, 0, 0])) checkIdentical(target, as.array(A[integer(0), integer(0), integer(0)])) checkIdentical(target, as.array(A[NULL, NULL, NULL])) i <- c(FALSE, TRUE) target <- a[i, , ] checkIdentical(target, as.array(A[i, , ])) target <- a[i, 0, ] checkIdentical(target, as.array(A[i, 0, ])) checkIdentical(target, as.array(A[i, integer(0), ])) checkIdentical(target, as.array(A[i, NULL, ])) i <- c(FALSE, TRUE, TRUE, FALSE, FALSE) target <- a[i, , ] checkIdentical(target, as.array(A[i, , ])) target <- a[i, 0, ] checkIdentical(target, as.array(A[i, 0, ])) checkIdentical(target, as.array(A[i, integer(0), ])) checkIdentical(target, as.array(A[i, NULL, ])) k <- c(TRUE, FALSE) target <- a[ , , k] checkIdentical(target, as.array(A[ , , k])) target <- a[0, , k] checkIdentical(target, as.array(A[0, , k])) checkIdentical(target, as.array(A[integer(0), , k])) checkIdentical(target, as.array(A[NULL, , k])) target <- a[i, , k] checkIdentical(target, as.array(A[i, , k])) target <- a[i, 0, k] checkIdentical(target, as.array(A[i, 0, k])) checkIdentical(target, as.array(A[i, integer(0), k])) checkIdentical(target, as.array(A[i, NULL, k])) j <- c(20:5, 11:22) target <- a[0, j, ] checkIdentical(target, as.array(A[0, j, ])) checkIdentical(target, as.array(A[integer(0), j, ])) checkIdentical(target, as.array(A[NULL, j, ])) target <- a[0, j, 0] checkIdentical(target, as.array(A[0, j, 0])) checkIdentical(target, as.array(A[integer(0), j, integer(0)])) checkIdentical(target, as.array(A[NULL, j, NULL])) target <- a[99:9, j, ] checkIdentical(target, as.array(A[99:9, j, ])) k <- c("e", "b", "b", "d", "e", "c") target <- a[-3, j, k] checkIdentical(target, as.array(A[-3, j, k])) target <- a[-3, -j, k] checkIdentical(target, as.array(A[-3, -j, k])) target <- a[-3, -j, ] checkIdentical(target, as.array(A[-3, -j, ])) target <- a[-3, -j, -555555] checkIdentical(target, as.array(A[-3, -j, -555555])) target <- a[99:9, j, k] checkIdentical(target, as.array(A[99:9, j, k])) i <- c(150:111, 88:90, 75:90) target <- a[i, j, k] checkIdentical(target, as.array(A[i, j, k])) target1 <- a[99, j, k] checkIdentical(target1, as.matrix(A[99, j, k])) B1 <- drop(A[99, j, k]) checkIdentical(target1, as.array(B1)) target <- target1[15:8, c("c", "b")] checkIdentical(target, as.array(B1[15:8, c("c", "b")])) target <- target1[0, ] checkIdentical(target, as.array(B1[0, ])) target <- target1[ , 0] checkIdentical(target, as.array(B1[ , 0])) target <- target1[0, 0] checkIdentical(target, as.array(B1[0, 0])) target2 <- a[i, 22, k] checkIdentical(target2, as.matrix(A[i, 22, k])) B2 <- drop(A[i, 22, k]) checkIdentical(target2, as.array(B2)) target <- target2[15:8, c("c", "b")] checkIdentical(target, as.array(B2[15:8, c("c", "b")])) target <- target2[0, ] checkIdentical(target, as.array(B2[0, ])) target <- target2[ , 0] checkIdentical(target, as.array(B2[ , 0])) target <- target2[0, 0] checkIdentical(target, as.array(B2[0, 0])) target3 <- a[i, j, 5] checkIdentical(target3, as.matrix(A[i, j, 5])) B3 <- drop(A[i, j, 5]) checkIdentical(target3, as.array(B3)) target <- target3[15:8, LETTERS[18:12]] checkIdentical(target, as.array(B3[15:8, LETTERS[18:12]])) target <- target3[0, ] checkIdentical(target, as.array(B3[0, ])) target <- target3[ , 0] checkIdentical(target, as.array(B3[ , 0])) target <- target3[0, 0] checkIdentical(target, as.array(B3[0, 0])) } DelayedArray/inst/unitTests/test_DelayedArray-utils.R0000644000175400017540000002431413175715525024032 0ustar00biocbuildbiocbuild#setRealizationBackend("RleArray") #setRealizationBackend("HDF5Array") DEFAULT_BLOCK_SIZE <- DelayedArray:::DEFAULT_BLOCK_SIZE Arith_members <- c("+", "-", "*", "/", "^", "%%", "%/%") Compare_members <- c("==", "!=", "<=", ">=", "<", ">") Logic_members <- c("&", "|") # currently untested a1 <- array(sample(5L, 150, replace=TRUE), c(5, 10, 3)) # integer array a2 <- a1 + runif(150) - 0.5 # numeric array block_sizes1 <- c(12L, 20L, 50L, 15000L) block_sizes2 <- 2L * block_sizes1 test_DelayedArray_unary_ops <- function() { a <- 2:-2 / (a1 - 3) a[2, 9, 2] <- NA # same as a[[92]] <- NA A <- realize(a) for (.Generic in c("is.na", "is.finite", "is.infinite", "is.nan")) { GENERIC <- match.fun(.Generic) checkIdentical(GENERIC(a), as.array(GENERIC(A))) } a <- array(sample(c(LETTERS, letters), 60, replace=TRUE), 5:3) A <- realize(a) ## For some obscure reason, the tests below fail in the context of ## 'DelayedArray:::.test()' or 'R CMD check'. ## TODO: Investigate this. #for (.Generic in c("nchar", "tolower", "toupper")) { # GENERIC <- match.fun(.Generic) # checkIdentical(GENERIC(a), as.array(GENERIC(A))) #} } test_DelayedArray_Math_ans_Arith <- function() { toto1 <- function(a) { 100 / floor(abs((5 * log(a + 0.2) - 1)^3)) } toto2 <- function(a) { 100L + (5L * (a - 2L)) %% 7L } ## with an integer array a <- a1 a[2, 9, 2] <- NA # same as a[[92]] <- NA A <- realize(a) ## Not sure what's going on but it seems that this call to checkIdentical() ## crashes the RUnit package but only when the tests are run by ## 'R CMD check'. #checkIdentical(toto2(a), as.array(toto2(A))) ## with a numeric array a <- a2 a[2, 9, 2] <- NA # same as a[[92]] <- NA A <- realize(a) checkIdentical(toto1(a), as.array(toto1(A))) checkIdentical(toto2(a), as.array(toto2(A))) checkIdentical(toto2(toto1(a)), as.array(toto2(toto1(A)))) checkIdentical(toto1(toto2(a)), as.array(toto1(toto2(A)))) a <- a[ , 10:4, -2] A <- A[ , 10:4, -2] checkIdentical(toto1(a), as.array(toto1(A))) checkIdentical(toto2(a), as.array(toto2(A))) checkIdentical(toto2(toto1(a)), as.array(toto2(toto1(A)))) checkIdentical(toto1(toto2(a)), as.array(toto1(toto2(A)))) ## with a numeric matrix m <- a[ , , 2] M <- realize(m) checkIdentical(toto1(m), as.matrix(toto1(M))) checkIdentical(t(toto1(m)), as.matrix(toto1(t(M)))) checkIdentical(t(toto1(m)), as.matrix(t(toto1(M)))) M <- drop(A[ , , 2]) checkIdentical(toto1(m), as.matrix(toto1(M))) checkIdentical(t(toto1(m)), as.matrix(toto1(t(M)))) checkIdentical(t(toto1(m)), as.matrix(t(toto1(M)))) } test_DelayedArray_Ops_with_left_or_right_vector <- function() { test_delayed_Ops_on_array <- function(.Generic, a, A, m, M) { on.exit(options(DelayedArray.block.size=DEFAULT_BLOCK_SIZE)) GENERIC <- match.fun(.Generic) target_current <- list( list(GENERIC(a, m[ , 1]), GENERIC(A, M[ , 1])), list(GENERIC(m[ , 1], a), GENERIC(M[ , 1], A)), list(GENERIC(a, a[ , 1, 1]), GENERIC(A, A[ , 1, 1])), list(GENERIC(a[ , 1, 1], a), GENERIC(A[ , 1, 1], A)), list(GENERIC(a, a[[1]]), GENERIC(A, A[[1]])), list(GENERIC(a[[1]], a), GENERIC(A[[1]], A)) ) for (i in seq_along(target_current)) { target <- target_current[[i]][[1L]] current <- target_current[[i]][[2L]] checkIdentical(target, as.array(current)) checkIdentical(target[5:3, , -2], as.array(current[5:3, , -2])) checkIdentical(target[0, 0, 0], as.array(current[0, 0, 0])) checkIdentical(target[0, 0, -2], as.array(current[0, 0, -2])) checkIdentical(target[ , 0, ], as.array(current[ , 0, ])) for (block_size in block_sizes2) { options(DelayedArray.block.size=block_size) checkEquals(sum(target, na.rm=TRUE), sum(current, na.rm=TRUE)) } } } a <- a2 a[2, 9, 2] <- NA # same as a[[92]] <- NA A <- realize(a) m <- a[ , , 2] M <- realize(m) ## "Logic" members currently untested. for (.Generic in c(Arith_members, Compare_members)) test_delayed_Ops_on_array(.Generic, a, A, m, M) ## Takes too long and probably not that useful. #M <- drop(A[ , , 2]) #for (.Generic in c(Arith_members, Compare_members)) # test_delayed_Ops_on_array(.Generic, a, A, m, M) } test_DelayedArray_Ops_COMBINE_seeds <- function() { ## comparing 2 DelayedArray objects A1 <- realize(a1) A2 <- realize(a2) a3 <- array(sample(5L, 150, replace=TRUE), c(5, 10, 3)) a3[2, 9, 2] <- NA # same as a3[[92]] <- NA A3 <- realize(a3) ## "Logic" members currently untested. for (.Generic in c(Arith_members, Compare_members)) { GENERIC <- match.fun(.Generic) target1 <- GENERIC(a1, a2) target2 <- GENERIC(a2, a1) target3 <- GENERIC(a1, a3) checkIdentical(target1, as.array(GENERIC(A1, A2))) checkIdentical(target2, as.array(GENERIC(A2, A1))) checkIdentical(target3, as.array(GENERIC(A1, A3))) } } test_DelayedArray_anyNA <- function() { on.exit(options(DelayedArray.block.size=DEFAULT_BLOCK_SIZE)) DelayedArray_block_anyNA <- DelayedArray:::.DelayedArray_block_anyNA A1 <- realize(a1) a <- a1 a[2, 9, 2] <- NA # same as a[[92]] <- NA A <- realize(a) for (block_size in block_sizes2) { options(DelayedArray.block.size=block_size) checkIdentical(FALSE, anyNA(A1)) checkIdentical(FALSE, DelayedArray_block_anyNA(a1)) checkIdentical(TRUE, anyNA(A)) checkIdentical(TRUE, DelayedArray_block_anyNA(a)) } } test_DelayedArray_which <- function() { on.exit(options(DelayedArray.block.size=DEFAULT_BLOCK_SIZE)) DelayedArray_block_which <- DelayedArray:::.DelayedArray_block_which a <- a1 == 1L a[2, 9, 2] <- NA # same as a[[92]] <- NA A <- realize(a) target <- which(a) for (block_size in block_sizes2) { options(DelayedArray.block.size=block_size) checkIdentical(target, which(A)) checkIdentical(target, DelayedArray_block_which(a)) } a <- a1 == -1L # all FALSE a[2, 9, 2] <- NA # same as a[[92]] <- NA A <- realize(a) target <- integer(0) for (block_size in block_sizes2) { options(DelayedArray.block.size=block_size) checkIdentical(target, which(A)) checkIdentical(target, DelayedArray_block_which(a)) } } test_DelayedArray_Summary <- function() { test_Summary <- function(.Generic, a, block_sizes) { on.exit(options(DelayedArray.block.size=DEFAULT_BLOCK_SIZE)) DelayedArray_block_Summary <- DelayedArray:::.DelayedArray_block_Summary GENERIC <- match.fun(.Generic) target1 <- GENERIC(a) target2 <- GENERIC(a, na.rm=TRUE) A <- realize(a) for (block_size in block_sizes) { options(DelayedArray.block.size=block_size) checkIdentical(target1, GENERIC(A)) checkIdentical(target1, GENERIC(t(A))) checkIdentical(target1, DelayedArray_block_Summary(.Generic, a)) checkIdentical(target2, GENERIC(A, na.rm=TRUE)) checkIdentical(target2, GENERIC(t(A), na.rm=TRUE)) checkIdentical(target2, DelayedArray_block_Summary(.Generic, a, na.rm=TRUE)) } } ## on an integer array a <- a1 a[2, 9, 2] <- NA # same as a[[92]] <- NA #for (.Generic in c("max", "min", "range", "sum", "prod")) { for (.Generic in c("max", "min", "range", "sum")) test_Summary(.Generic, a, block_sizes1) ## on a numeric array a <- a2 a[2, 9, 2] <- NA # same as a[[92]] <- NA a[2, 10, 2] <- Inf # same as a[[97]] <- Inf for (.Generic in c("max", "min", "range", "sum", "prod")) test_Summary(.Generic, a, block_sizes2) ## on a logical array a <- array(c(rep(NA, 62), rep(TRUE, 87), FALSE), c(5, 10, 3)) for (.Generic in c("any", "all")) test_Summary(.Generic, a, block_sizes1) } test_DelayedArray_mean <- function() { on.exit(options(DelayedArray.block.size=DEFAULT_BLOCK_SIZE)) ## on a numeric array a <- a2 a[2, 9, 2] <- NA # same as a[[92]] <- NA A <- realize(a) target1 <- mean(a) target2 <- mean(a, na.rm=TRUE) target3 <- mean(a[ , 10:4, -2]) for (block_size in block_sizes2) { options(DelayedArray.block.size=block_size) checkIdentical(target1, mean(A)) checkIdentical(target1, mean(t(A))) checkIdentical(target2, mean(A, na.rm=TRUE)) checkIdentical(target2, mean(t(A), na.rm=TRUE)) checkIdentical(target3, mean(A[ , 10:4, -2])) checkIdentical(target3, mean(t(A[ , 10:4, -2]))) } } test_DelayedArray_apply <- function() { test_apply <- function(a) { A <- realize(a) for (MARGIN in seq_along(dim(a))) { checkIdentical(apply(a, MARGIN, dim), apply(A, MARGIN, dim)) checkIdentical(apply(a, MARGIN, sum), apply(A, MARGIN, sum)) checkIdentical(apply(a, MARGIN, sum, na.rm=TRUE), apply(A, MARGIN, sum, na.rm=TRUE)) ## row/colSums and row/colMeans don't work yet in that case. if (dim(A)[[MARGIN]] == 0L && length(dim(A)) >= 3L) next checkIdentical(apply(a, MARGIN, rowSums), apply(A, MARGIN, rowSums)) checkIdentical(apply(a, MARGIN, rowSums, na.rm=TRUE), apply(A, MARGIN, rowSums, na.rm=TRUE)) checkIdentical(apply(a, MARGIN, colMeans), apply(A, MARGIN, colMeans)) checkIdentical(apply(a, MARGIN, colMeans, na.rm=TRUE), apply(A, MARGIN, colMeans, na.rm=TRUE)) } } a <- a1 a[2, 9, 2] <- NA # same as a[[92]] <- NA test_apply(a) test_apply(a[ , , 0]) dimnames(a) <- list(NULL, NULL, LETTERS[1:3]) test_apply(a) test_apply(a[ , , 0]) dimnames(a) <- list(NULL, letters[1:10], LETTERS[1:3]) test_apply(a) test_apply(a[ , , 0]) } DelayedArray/inst/unitTests/test_DelayedMatrix-stats.R0000644000175400017540000000426213175715525024216 0ustar00biocbuildbiocbuild#setRealizationBackend("RleArray") #setRealizationBackend("HDF5Array") DEFAULT_BLOCK_SIZE <- DelayedArray:::DEFAULT_BLOCK_SIZE a1 <- array(sample(5L, 150, replace=TRUE), c(5, 10, 3)) # integer array a2 <- a1 + runif(150) - 0.5 # numeric array m2 <- matrix(runif(60), ncol=6) # numeric matrix block_sizes1 <- c(12L, 20L, 50L, 15000L) block_sizes2 <- 2L * block_sizes1 test_DelayedMatrix_row_col_summarization <- function() { test_row_col_summary <- function(FUN, m, M, block_sizes) { on.exit(options(DelayedArray.block.size=DEFAULT_BLOCK_SIZE)) FUN <- match.fun(FUN) target1 <- FUN(m) target2 <- FUN(m, na.rm=TRUE) target3 <- FUN(t(m)) target4 <- FUN(t(m), na.rm=TRUE) for (block_size in block_sizes) { options(DelayedArray.block.size=block_size) current <- FUN(M) checkEquals(target1, current) checkIdentical(typeof(target1), typeof(current)) current <- FUN(M, na.rm=TRUE) checkEquals(target2, current) checkIdentical(typeof(target2), typeof(current)) current <- FUN(t(M)) checkEquals(target3, current) checkIdentical(typeof(target3), typeof(current)) current <- FUN(t(M), na.rm=TRUE) checkEquals(target4, current) checkIdentical(typeof(target4), typeof(current)) } } FUNS <- c("rowSums", "colSums", "rowMeans", "colMeans", "rowMaxs", "colMaxs", "rowMins", "colMins", "rowRanges", "colRanges") ## on an integer matrix m <- a1[ , , 1] A1 <- realize(a1) M <- drop(A1[ , , 1]) for (FUN in FUNS) { test_row_col_summary(FUN, m, M, block_sizes2) test_row_col_summary(FUN, m[ , 0], M[ , 0], block_sizes2) } ## on a numeric matrix m <- m2 m[2, 4] <- NA m[5, 4] <- Inf m[6, 3] <- -Inf M <- realize(m) for (FUN in FUNS) test_row_col_summary(FUN, m, M, block_sizes2) library(genefilter) ## Note that the matrixStats package also defines a rowVars() function. test_row_col_summary(genefilter::rowVars, m, M, block_sizes2) } DelayedArray/inst/unitTests/test_DelayedMatrix-utils.R0000644000175400017540000001006413175715525024215 0ustar00biocbuildbiocbuild#setRealizationBackend("RleArray") #setRealizationBackend("HDF5Array") DEFAULT_BLOCK_SIZE <- DelayedArray:::DEFAULT_BLOCK_SIZE Arith_members <- c("+", "-", "*", "/", "^", "%%", "%/%") Compare_members <- c("==", "!=", "<=", ">=", "<", ">") Logic_members <- c("&", "|") # currently untested a1 <- array(sample(5L, 150, replace=TRUE), c(5, 10, 3)) # integer array a2 <- a1 + runif(150) - 0.5 # numeric array m2 <- matrix(runif(60), ncol=6) # numeric matrix block_sizes1 <- c(12L, 20L, 50L, 15000L) block_sizes2 <- 2L * block_sizes1 test_DelayedMatrix_Ops <- function() { test_delayed_Ops_on_matrix <- function(.Generic, m, M) { GENERIC <- match.fun(.Generic) target_current <- list( list(GENERIC(m, m[ , 1]), GENERIC(M, M[ , 1])), list(GENERIC(m[ , 2], m), GENERIC(M[ , 2], M)) ) for (i in seq_along(target_current)) { target <- target_current[[i]][[1L]] current <- target_current[[i]][[2L]] checkIdentical(target, as.matrix(current)) checkIdentical(t(target), as.matrix(t(current))) checkIdentical(target[-2, 8:5], as.matrix(current[-2, 8:5])) checkIdentical(t(target[-2, 8:5]), as.matrix(t(current[-2, 8:5]))) checkIdentical(target[-2, 0], as.matrix(current[-2, 0])) checkIdentical(t(target[-2, 0]), as.matrix(t(current[-2, 0]))) checkIdentical(target[0, ], as.matrix(current[0, ])) checkIdentical(t(target[0, ]), as.matrix(t(current[0, ]))) } target_current <- list( list(GENERIC(t(m), 8:-1), GENERIC(t(M), 8:-1)), list(GENERIC(8:-1, t(m)), GENERIC(8:-1, t(M))), list(GENERIC(t(m), m[1 , ]), GENERIC(t(M), M[1 , ])), list(GENERIC(m[2 , ], t(m)), GENERIC(M[2 , ], t(M))), list(GENERIC(t(m), m[1 , 6:10]), GENERIC(t(M), M[1 , 6:10])), list(GENERIC(m[2 , 8:7], t(m)), GENERIC(M[2 , 8:7], t(M))) ) for (i in seq_along(target_current)) { target <- target_current[[i]][[1L]] current <- target_current[[i]][[2L]] checkIdentical(target, as.matrix(current)) checkIdentical(target[1:3 , ], as.matrix(current[1:3 , ])) checkIdentical(target[ , 1:3], as.matrix(current[ , 1:3])) checkIdentical(t(target), as.matrix(t(current))) checkIdentical(t(target)[1:3 , ], as.matrix(t(current)[1:3 , ])) checkIdentical(t(target)[ , 1:3], as.matrix(t(current)[ , 1:3])) checkIdentical(target[8:5, -2], as.matrix(current[8:5, -2])) checkIdentical(t(target[8:5, -2]), as.matrix(t(current[8:5, -2]))) checkIdentical(target[0, -2], as.matrix(current[0, -2])) checkIdentical(t(target[0, -2]), as.matrix(t(current[0, -2]))) checkIdentical(target[ , 0], as.matrix(current[ , 0])) checkIdentical(t(target[ , 0]), as.matrix(t(current[ , 0]))) } } a <- a2 a[2, 9, 2] <- NA # same as a[[92]] <- NA toto <- function(x) t((5 * x[ , 1:2] ^ 3 + 1L) * log(x)[, 10:9])[ , -1] m <- a[ , , 2] M <- realize(m) checkIdentical(toto(m), as.array(toto(M))) ## "Logic" members currently untested. for (.Generic in c(Arith_members, Compare_members)) test_delayed_Ops_on_matrix(.Generic, m, M) A <- realize(a)[ , , 2] M <- drop(A) checkIdentical(toto(m), as.array(toto(M))) for (.Generic in c(Arith_members, Compare_members)) test_delayed_Ops_on_matrix(.Generic, m, M) } test_DelayedMatrix_mult <- function() { m <- m2 m[2, 4] <- NA m[5, 4] <- Inf m[6, 3] <- -Inf M <- realize(m) Lm <- rbind(rep(1L, 10), rep(c(1L, 0L), 5), rep(-100L, 10)) Rm <- rbind(Lm + 7.05, 0.1 * Lm) on.exit(options(DelayedArray.block.size=DEFAULT_BLOCK_SIZE)) for (block_size in block_sizes2) { options(DelayedArray.block.size=block_size) P <- Lm %*% M checkEquals(Lm %*% m, as.matrix(P)) P <- M %*% Rm checkEquals(m %*% Rm, as.matrix(P)) } } DelayedArray/inst/unitTests/test_RleArray-class.R0000644000175400017540000000253413175715525023152 0ustar00biocbuildbiocbuildDEFAULT_BLOCK_SIZE <- DelayedArray:::DEFAULT_BLOCK_SIZE test_RleArray <- function() { rle <- Rle(1:200000, 125) A1 <- RleArray(rle, c(62500, 400)) A2 <- RleArray(rle, c(62500, 400), chunksize=1e8) on.exit(options(DelayedArray.block.size=DEFAULT_BLOCK_SIZE)) options(DelayedArray.block.size=10e6) rs1 <- rowSums(A1) rs2 <- rowSums(A2) checkIdentical(rs1, rs2) cs1 <- colSums(A1) cs2 <- colSums(A2) checkIdentical(cs1, cs2) ## TODO: Add more tests... } test_long_RleArray <- function() { ## Right now it's not possible to create a long RleArray object with ## the RleArray() constructor function. So we use the low-level RleArray ## construction API to do this: RleRealizationSink <- DelayedArray:::RleRealizationSink append_Rle_to_sink <- DelayedArray:::.append_Rle_to_sink sink <- RleRealizationSink(c(30000L, 75000L), type="integer") #rle1 <- Rle(1:500000, 2000) rle1 <- Rle(1:5000, 200000) append_Rle_to_sink(rle1, sink) #rle2 <- Rle(1:2000000, 125) rle2 <- Rle(1:20000, 12500) append_Rle_to_sink(rle2, sink) #rle3 <- Rle(1:5000000, 200) rle3 <- Rle(1:50000, 20000) append_Rle_to_sink(rle3, sink) A <- as(sink, "RleArray") checkTrue(validObject(A, complete=TRUE)) checkTrue(is(seed(A), "ChunkedRleArraySeed")) ## TODO: Add more tests... } DelayedArray/inst/unitTests/test_bind-arrays.R0000644000175400017540000000565513175715525022550 0ustar00biocbuildbiocbuild.TEST_matrices <- list( matrix(1:15, nrow=3, ncol=5, dimnames=list(NULL, paste0("M1y", 1:5))), matrix(101:135, nrow=7, ncol=5, dimnames=list(paste0("M2x", 1:7), paste0("M2y", 1:5))), matrix(1001:1025, nrow=5, ncol=5, dimnames=list(paste0("M3x", 1:5), NULL)) ) .TEST_arrays <- list( array(1:60, c(3, 5, 4), dimnames=list(NULL, paste0("M1y", 1:5), NULL)), array(101:240, c(7, 5, 4), dimnames=list(paste0("M2x", 1:7), paste0("M2y", 1:5), NULL)), array(10001:10100, c(5, 5, 4), dimnames=list(paste0("M3x", 1:5), NULL, paste0("M3z", 1:4))) ) test_arbind <- function() { ## on matrices target <- do.call(rbind, .TEST_matrices) current <- do.call(arbind, .TEST_matrices) checkIdentical(target, current) ## on empty matrices m1 <- matrix(nrow=0, ncol=3, dimnames=list(NULL, letters[1:3])) m2 <- matrix(1:15, ncol=3, dimnames=list(NULL, LETTERS[1:3])) target <- do.call(rbind, list(m1, m2)) current <- do.call(arbind, list(m1, m2)) checkIdentical(target, current) target <- do.call(rbind, list(m2, m1)) current <- do.call(arbind, list(m2, m1)) checkIdentical(target, current) target <- do.call(rbind, list(m1, m1)) current <- do.call(arbind, list(m1, m1)) checkIdentical(target, current) ## on arrays current <- do.call(arbind, .TEST_arrays) check_2D_slice <- function(k) { slices <- lapply(.TEST_arrays, `[`, , , k) target_slice <- do.call(rbind, slices) checkIdentical(target_slice, current[ , , k]) } for (k in seq_len(dim(current)[[3L]])) check_2D_slice(k) } test_acbind <- function() { ## on matrices matrices <- lapply(.TEST_matrices, t) target <- do.call(cbind, matrices) current <- do.call(acbind, matrices) checkIdentical(target, current) ## on empty matrices m1 <- matrix(nrow=3, ncol=0, dimnames=list(letters[1:3], NULL)) m2 <- matrix(1:15, nrow=3, dimnames=list(LETTERS[1:3], NULL)) target <- do.call(cbind, list(m1, m2)) current <- do.call(acbind, list(m1, m2)) checkIdentical(target, current) target <- do.call(cbind, list(m2, m1)) current <- do.call(acbind, list(m2, m1)) checkIdentical(target, current) target <- do.call(cbind, list(m1, m1)) current <- do.call(acbind, list(m1, m1)) checkIdentical(target, current) ## on arrays ## transpose the 1st 2 dimensions arrays <- lapply(.TEST_arrays, function(a) { a_dimnames <- dimnames(a) dim(a)[1:2] <- dim(a)[2:1] a_dimnames[1:2] <- a_dimnames[2:1] dimnames(a) <- a_dimnames a }) current <- do.call(acbind, arrays) check_2D_slice <- function(k) { slices <- lapply(arrays, `[`, , , k) target_slice <- do.call(cbind, slices) checkIdentical(target_slice, current[ , , k]) } for (k in seq_len(dim(current)[[3L]])) check_2D_slice(k) } DelayedArray/inst/unitTests/test_cbind-methods.R0000644000175400017540000001053313175715525023044 0ustar00biocbuildbiocbuild#setRealizationBackend("RleArray") #setRealizationBackend("HDF5Array") .TEST_matrices <- list( matrix(1:15, nrow=3, ncol=5, dimnames=list(NULL, paste0("M1y", 1:5))), matrix(101:135, nrow=7, ncol=5, dimnames=list(paste0("M2x", 1:7), paste0("M2y", 1:5))), matrix(1001:1025, nrow=5, ncol=5, dimnames=list(paste0("M3x", 1:5), NULL)) ) .TEST_arrays <- list( array(1:60, c(3, 5, 4), dimnames=list(NULL, paste0("M1y", 1:5), NULL)), array(101:240, c(7, 5, 4), dimnames=list(paste0("M2x", 1:7), paste0("M2y", 1:5), NULL)), array(10001:10100, c(5, 5, 4), dimnames=list(paste0("M3x", 1:5), NULL, paste0("M3z", 1:4))) ) test_DelayedMatrix_rbind_cbind <- function() { m1 <- .TEST_matrices[[1]] m2 <- .TEST_matrices[[2]] m3 <- .TEST_matrices[[3]] M1 <- realize(m1) M2 <- realize(m2) M3 <- realize(m3) target <- rbind(a=m1, b=m2, c=m3) current <- rbind(a=M1, b=M2, c=M3) checkTrue(is(current, "DelayedMatrix")) checkTrue(validObject(current, complete=TRUE)) checkIdentical(target, as.matrix(current)) current <- cbind(a=t(M1), b=t(M2), c=t(M3)) checkTrue(is(current, "DelayedMatrix")) checkTrue(validObject(current, complete=TRUE)) checkIdentical(t(target), as.matrix(current)) ## unary form target <- rbind(a=m1) current <- rbind(a=M1) checkTrue(is(current, "DelayedMatrix")) checkTrue(validObject(current, complete=TRUE)) checkIdentical(target, as.matrix(current)) target <- cbind(a=m1) current <- cbind(a=M1) checkTrue(is(current, "DelayedMatrix")) checkTrue(validObject(current, complete=TRUE)) checkIdentical(target, as.matrix(current)) ## with empty matrices m1 <- matrix(nrow=0, ncol=3, dimnames=list(NULL, letters[1:3])) m2 <- matrix(1:15, ncol=3, dimnames=list(NULL, LETTERS[1:3])) M1 <- realize(m1) M2 <- realize(m2) target <- rbind(a=m1, a=m2) current <- rbind(a=M1, b=M2) checkTrue(is(current, "DelayedMatrix")) checkTrue(validObject(current, complete=TRUE)) checkIdentical(target, as.matrix(current)) target <- rbind(a=m2, a=m1) current <- rbind(a=M2, b=M1) checkTrue(is(current, "DelayedMatrix")) checkTrue(validObject(current, complete=TRUE)) checkIdentical(target, as.matrix(current)) target <- rbind(a=m1, a=m1) current <- rbind(a=M1, b=M1) checkTrue(is(current, "DelayedMatrix")) checkTrue(validObject(current, complete=TRUE)) checkIdentical(target, as.matrix(current)) } test_DelayedArray_arbind <- function() { TEST_hdf5arrays <- lapply(.TEST_arrays, realize) target <- do.call(arbind, .TEST_arrays) current <- do.call(arbind, TEST_hdf5arrays) checkTrue(is(current, "DelayedArray")) checkTrue(validObject(current, complete=TRUE)) checkIdentical(target, as.array(current)) ## For some mysterious reason, the code below fails in the context ## of 'R CMD check' but not when running the tests interactively with ## DelayedArray:::.test(). #check_2D_slice <- function(k) { # slices <- lapply(lapply(TEST_hdf5arrays, `[`, , , k), drop) # target_slice <- do.call(rbind, slices) # checkIdentical(as.matrix(target_slice), as.matrix(current[ , , k])) #} #for (k in seq_len(dim(current)[[3L]])) check_2D_slice(k) } test_DelayedArray_acbind <- function() { ## transpose the 1st 2 dimensions arrays <- lapply(.TEST_arrays, function(a) { a_dimnames <- dimnames(a) dim(a)[1:2] <- dim(a)[2:1] a_dimnames[1:2] <- a_dimnames[2:1] dimnames(a) <- a_dimnames a }) TEST_hdf5arrays <- lapply(arrays, realize) target <- do.call(acbind, arrays) current <- do.call(acbind, TEST_hdf5arrays) checkTrue(is(current, "DelayedArray")) checkTrue(validObject(current, complete=TRUE)) checkIdentical(target, as.array(current)) ## For some mysterious reason, the code below fails in the context ## of 'R CMD check' but not when running the tests interactively with ## DelayedArray:::.test(). #check_2D_slice <- function(k) { # slices <- lapply(lapply(TEST_hdf5arrays, `[`, , , k), drop) # target_slice <- do.call(cbind, slices) # checkIdentical(as.matrix(target_slice), as.matrix(current[ , , k])) #} #for (k in seq_len(dim(current)[[3L]])) check_2D_slice(k) } DelayedArray/man/0000755000175400017540000000000013175715525014734 5ustar00biocbuildbiocbuildDelayedArray/man/Array-class.Rd0000644000175400017540000000077113175715525017411 0ustar00biocbuildbiocbuild\name{Array-class} \docType{class} \alias{class:Array} \alias{Array-class} \alias{Array} \alias{length,Array-method} \alias{[[,Array-method} \title{Array objects} \description{ Array is a virtual class intended to be extended by concrete subclasses with an array-like semantic. } \seealso{ \link{DelayedArray}, \link{ArrayGrid}, and \link{ArrayViewport} for examples of classes with an array-like semantic. } \examples{ showClass("Array") # virtual class with no slots } \keyword{internal} DelayedArray/man/ArrayGrid-class.Rd0000644000175400017540000000701413175715525020214 0ustar00biocbuildbiocbuild\name{ArrayGrid-class} \docType{class} \alias{class:ArrayViewport} \alias{ArrayViewport-class} \alias{ArrayViewport} \alias{refdim} \alias{refdim,ArrayViewport-method} \alias{ranges,ArrayViewport-method} \alias{start,ArrayViewport-method} \alias{width,ArrayViewport-method} \alias{end,ArrayViewport-method} \alias{dim,ArrayViewport-method} \alias{show,ArrayViewport-method} \alias{makeNindexFromArrayViewport} \alias{class:ArrayGrid} \alias{ArrayGrid-class} \alias{ArrayGrid} \alias{class:ArrayArbitraryGrid} \alias{ArrayArbitraryGrid-class} \alias{ArrayArbitraryGrid} \alias{class:ArrayRegularGrid} \alias{ArrayRegularGrid-class} \alias{ArrayRegularGrid} \alias{refdim,ArrayArbitraryGrid-method} \alias{refdim,ArrayRegularGrid-method} \alias{dim,ArrayArbitraryGrid-method} \alias{dim,ArrayRegularGrid-method} \alias{as.character.ArrayGrid} \alias{as.character,ArrayGrid-method} \alias{lengths,ArrayGrid-method} \alias{show,ArrayGrid-method} \alias{isLinear} \alias{isLinear,ArrayViewport-method} \alias{isLinear,ArrayGrid-method} \title{ArrayGrid and ArrayViewport objects} \description{ ArrayGrid and ArrayViewport objects are used internally to support block processing of array-like objects. } \examples{ ## --------------------------------------------------------------------- ## ArrayGrid OBJECTS ## --------------------------------------------------------------------- ## Create a regularly-spaced grid on top of a 3700 x 100 x 33 array: grid <- ArrayRegularGrid(c(3700L, 100L, 33L), c(250L, 100L, 10L)) ## Dimensions of the reference array: refdim(grid) ## Number of grid elements along each dimension of the reference array: dim(grid) ## Total number of grid elements: length(grid) ## First element in the grid: grid[[1L]] # same as grid[[1L, 1L, 1L]] ## Last element in the grid: grid[[length(grid)]] # same as grid[[15L, 1L, 4L]] ## Lengths of the grid elements: lengths(grid) stopifnot(prod(refdim(grid)) == sum(lengths(grid))) ## --------------------------------------------------------------------- ## ArrayViewport OBJECTS ## --------------------------------------------------------------------- ## Grid elements are ArrayViewport objects: class(grid[[1L]]) m0 <- matrix(1:30, ncol=5) block_dim <- c(4, 3) viewport1 <- ArrayViewport(dim(m0), IRanges(c(3, 2), width=block_dim)) viewport1 dim(viewport1) # 'block_dim' length(viewport1) ranges(viewport1) ## 2 utilities (not exported yet) for extracting/replacing blocks from/in ## an array-like object: extract_block <- DelayedArray:::extract_block replace_block <- DelayedArray:::replace_block block1 <- extract_block(m0, viewport1) block1 ## No-op: replace_block(m0, viewport1, block1) stopifnot(identical(m0, replace_block(m0, viewport1, block1))) replace_block(m0, viewport1, block1 + 100L) viewport2 <- ArrayViewport(dim(m0), IRanges(c(1, 3), width=block_dim)) replace_block(m0, viewport2, block1 + 100L) ## Using a grid: grid <- ArrayRegularGrid(dim(m0), spacings=c(3L, 2L)) grid extract_block(m0, grid[[3L]]) extract_block(m0, grid[[1L, 3L]]) ## Walk on the grid, colum by column: m1 <- m0 for (b in seq_along(grid)) { viewport <- grid[[b]] block <- extract_block(m1, viewport) block <- b * 1000L + block m1 <- replace_block(m1, viewport, block) } m1 ## Walk on the grid, row by row: m2 <- m0 for (i in seq_len(dim(grid)[[1]])) { for (j in seq_len(dim(grid)[[2]])) { viewport <- grid[[i, j]] block <- extract_block(m2, viewport) block <- (i * 10L + j) * 1000L + block m2 <- replace_block(m2, viewport, block) } } m2 } \keyword{internal} DelayedArray/man/DelayedArray-class.Rd0000644000175400017540000003227513175715525020705 0ustar00biocbuildbiocbuild\name{DelayedArray-class} \docType{class} \alias{class:DelayedArray} \alias{DelayedArray-class} \alias{class:DelayedMatrix} \alias{DelayedMatrix-class} \alias{DelayedMatrix} \alias{coerce,DelayedArray,DelayedMatrix-method} \alias{DelayedArray} \alias{DelayedArray,ANY-method} \alias{DelayedArray,DelayedArray-method} \alias{seed} \alias{seed,DelayedArray-method} \alias{dim,DelayedArray-method} \alias{dim<-,DelayedArray-method} \alias{isEmpty,DelayedArray-method} \alias{dimnames,DelayedArray-method} \alias{dimnames<-,DelayedArray-method} \alias{names,DelayedArray-method} \alias{names<-,DelayedArray-method} \alias{drop,DelayedArray-method} \alias{[,DelayedArray-method} \alias{t,DelayedArray-method} \alias{as.array.DelayedArray} \alias{as.array,DelayedArray-method} \alias{as.matrix.DelayedArray} \alias{as.matrix,DelayedArray-method} \alias{as.data.frame.DelayedArray} \alias{as.data.frame,DelayedArray-method} \alias{as.vector.DelayedArray} \alias{as.vector,DelayedArray-method} \alias{as.logical.DelayedArray} \alias{as.logical,DelayedArray-method} \alias{as.integer.DelayedArray} \alias{as.integer,DelayedArray-method} \alias{as.numeric.DelayedArray} \alias{as.numeric,DelayedArray-method} \alias{as.complex.DelayedArray} \alias{as.complex,DelayedArray-method} \alias{as.character.DelayedArray} \alias{as.character,DelayedArray-method} \alias{as.raw.DelayedArray} \alias{as.raw,DelayedArray-method} \alias{coerce,DelayedMatrix,dgCMatrix-method} \alias{coerce,DelayedMatrix,sparseMatrix-method} \alias{type} \alias{type,array-method} \alias{type,DelayedArray-method} \alias{[[,DelayedArray-method} \alias{show,DelayedArray-method} \alias{c,DelayedArray-method} \alias{splitAsList,DelayedArray-method} \alias{split.DelayedArray} \alias{split,DelayedArray,ANY-method} \alias{rbind} \alias{rbind,DelayedMatrix-method} \alias{rbind,DelayedArray-method} \alias{arbind,DelayedArray-method} \alias{cbind} \alias{cbind,DelayedMatrix-method} \alias{cbind,DelayedArray-method} \alias{acbind,DelayedArray-method} % Internal stuff \alias{matrixClass} \alias{matrixClass,DelayedArray-method} \title{DelayedArray objects} \description{ Wrapping an array-like object (typically an on-disk object) in a DelayedArray object allows one to perform common array operations on it without loading the object in memory. In order to reduce memory usage and optimize performance, operations on the object are either delayed or executed using a block processing mechanism. } \usage{ DelayedArray(seed) # constructor function seed(x) # seed getter type(x) } \arguments{ \item{seed}{ An array-like object. } \item{x}{ A DelayedArray object. (Can also be an ordinary array in case of \code{type}.) } } \section{In-memory versus on-disk realization}{ To \emph{realize} a DelayedArray object (i.e. to trigger execution of the delayed operations carried by the object and return the result as an ordinary array), call \code{as.array} on it. However this realizes the full object at once \emph{in memory} which could require too much memory if the object is big. A big DelayedArray object is preferrably realized \emph{on disk} e.g. by calling \code{\link[HDF5Array]{writeHDF5Array}} on it (this function is defined in the \pkg{HDF5Array} package) or coercing it to an \link[HDF5Array]{HDF5Array} object with \code{as(x, "HDF5Array")}. Other on-disk backends can be supported. This uses a block-processing strategy so that the full object is not realized at once in memory. Instead the object is processed block by block i.e. the blocks are realized in memory and written to disk one at a time. See \code{?\link[HDF5Array]{writeHDF5Array}} in the \pkg{HDF5Array} package for more information about this. } \section{Accessors}{ DelayedArray objects support the same set of getters as ordinary arrays i.e. \code{dim()}, \code{length()}, and \code{dimnames()}. In addition, they support \code{type()}, which is the DelayedArray equivalent of \code{typeof()} or \code{storage.mode()} for ordinary arrays. Note that, for convenience and consistency, \code{type()} also works on ordinary arrays. Only \code{dimnames()} is supported as a setter. } \section{Subsetting}{ A DelayedArray object can be subsetted with \code{[} like an ordinary array but with the following differences: \itemize{ \item \emph{Multi-dimensional single bracket subsetting} (i.e. subsetting of the form \code{x[i_1, i_2, ..., i_n]} with one (possibly missing) subscript per dimension) returns a DelayedArray object where the subsetting is actually delayed. So it's a very light operation. \item The \code{drop} argument of the \code{[} operator is ignored i.e. subsetting a DelayedArray object always returns a DelayedArray object with the same number of dimensions as the original object. You need to call \code{drop()} on the subsetted object to actually drop its ineffective dimensions (i.e. the dimensions equal to 1). \code{drop()} is also a delayed operation so is very light. \item \emph{Linear single bracket subsetting} (a.k.a. 1D-style subsetting, that is, subsetting of the form \code{x[i]}) only works if subscript \code{i} is a numeric vector at the moment. Furthermore, \code{i} cannot contain NAs and all the indices in it must be >= 1 and <= \code{length(x)} for now. It returns an atomic vector of the same length as \code{i}. This is NOT a delayed operation. } Subsetting with \code{[[} is supported but only the \emph{linear} form of it at the moment i.e. the \code{x[[i]]} form where \code{i} is a \emph{single} numeric value >= 1 and <= \code{length(x)}. It is equivalent to \code{x[i]}. DelayedArray objects support only 2 forms of subassignment at the moment: \code{x[i] <- value} and \code{x[] <- value}. The former is supported only when the subscript \code{i} is a logical DelayedArray object with the same dimensions as \code{x} and when \code{value} is a \emph{scalar} (i.e. an atomic vector of length 1). The latter is supported only when \code{value} is an atomic vector and \code{length(value)} is a divisor of \code{nrow(x)}. Both are delayed operations so are very light. Single value replacement (\code{x[[...]] <- value}) is not supported. } \section{Binding}{ Binding DelayedArray objects along the rows (or columns) is supported via the \code{rbind} and \code{arbind} (or \code{cbind} and \code{acbind}) methods for DelayedArray objects. All these operations are delayed. } \seealso{ \itemize{ \item \code{\link{realize}} for realizing a DelayedArray object in memory or on disk. \item \link{DelayedArray-utils} for common operations on DelayedArray objects. \item \code{\link[base]{cbind}} in the \pkg{base} package for rbind/cbind'ing ordinary arrays. \item \code{\link{acbind}} in this package (\pkg{DelayedArray}) for arbind/acbind'ing ordinary arrays. \item \link{RleArray} objects. \item \link[HDF5Array]{HDF5Array} objects in the \pkg{HDF5Array} package. \item \link[S4Vectors]{DataFrame} objects in the \pkg{S4Vectors} package. \item \link[base]{array} objects in base R. } } \examples{ ## --------------------------------------------------------------------- ## A. WRAP AN ORDINARY ARRAY IN A DelayedArray OBJECT ## --------------------------------------------------------------------- a <- array(runif(1500000), dim=c(10000, 30, 5)) A <- DelayedArray(a) A ## The seed of A is treated as a "read-only" object so won't change when ## we start operating on A: stopifnot(identical(a, seed(A))) type(A) ## Multi-dimensional single bracket subsetting: m <- a[11:20 , 5, ] # a matrix A[11:20 , 5, ] # not a DelayedMatrix (still 3 dimensions) M <- drop(A[11:20 , 5, ]) # a DelayedMatrix object stopifnot(identical(m, as.array(M))) stopifnot(identical(a, seed(M))) ## Linear single bracket subsetting: A[11:20] A[which(A <= 1e-5)] ## Subassignment: A[A < 0.2] <- NA a[a < 0.2] <- NA stopifnot(identical(a, as.array(A))) ## Other operations: toto <- function(x) (5 * x[ , , 1] ^ 3 + 1L) * log(x[, , 2]) b <- toto(a) head(b) B <- toto(A) # very fast! (operations are delayed) B # still 3 dimensions (subsetting a DelayedArray object never drops # dimensions) B <- drop(B) B cs <- colSums(b) CS <- colSums(B) stopifnot(identical(cs, CS)) ## --------------------------------------------------------------------- ## B. WRAP A DataFrame OBJECT IN A DelayedArray OBJECT ## --------------------------------------------------------------------- ## Generate random coverage and score along an imaginary chromosome: cov <- Rle(sample(20, 5000, replace=TRUE), sample(6, 5000, replace=TRUE)) score <- Rle(sample(100, nrun(cov), replace=TRUE), runLength(cov)) DF <- DataFrame(cov, score) A2 <- DelayedArray(DF) A2 seed(A2) # 'DF' ## Coercion of a DelayedMatrix object to DataFrame produces a DataFrame ## object with Rle columns: as(A2, "DataFrame") stopifnot(identical(DF, as(A2, "DataFrame"))) t(A2) # transposition is delayed so is very fast and very memory # efficient stopifnot(identical(DF, seed(t(A2)))) # the "seed" is still the same colSums(A2) ## --------------------------------------------------------------------- ## C. A HDF5Array OBJECT IS A (PARTICULAR KIND OF) DelayedArray OBJECT ## --------------------------------------------------------------------- library(HDF5Array) A3 <- as(a, "HDF5Array") # write 'a' to an HDF5 file A3 is(A3, "DelayedArray") # TRUE seed(A3) # a HDF5ArraySeed object B3 <- toto(A3) # very fast! (operations are delayed) B3 # not a HDF5Array object because now it # carries delayed operations B3 <- drop(B3) CS3 <- colSums(B3) stopifnot(identical(cs, CS3)) ## --------------------------------------------------------------------- ## D. PERFORM THE DELAYED OPERATIONS ## --------------------------------------------------------------------- as(B3, "HDF5Array") # "realize" 'B3' on disk ## If this is just an intermediate result, you can either keep going ## with B3 or replace it with its "realized" version: B3 <- as(B3, "HDF5Array") # no more delayed operations on new 'B3' seed(B3) ## For convenience, realize() can be used instead of explicit coercion. ## The current "realization backend" controls where realization ## happens e.g. in memory if set to NULL or in an HDF5 file if set ## to "HDF5Array": D <- cbind(B3, exp(B3)) D setRealizationBackend("HDF5Array") D <- realize(D) D ## See '?realize' for more information about "realization backends". ## --------------------------------------------------------------------- ## E. BIND DelayedArray OBJECTS ## --------------------------------------------------------------------- ## rbind/cbind library(HDF5Array) toy_h5 <- system.file("extdata", "toy.h5", package="HDF5Array") h5ls(toy_h5) M1 <- HDF5Array(toy_h5, "M1") M2 <- HDF5Array(toy_h5, "M2") M12 <- rbind(M1, t(M2)) M12 colMeans(M12) ## arbind/acbind example(acbind) # to create arrays a1, a2, a3 A1 <- DelayedArray(a1) A2 <- DelayedArray(a2) A3 <- DelayedArray(a3) A <- arbind(A1, A2, A3) A ## Sanity check: stopifnot(identical(arbind(a1, a2, a3), as.array(A))) ## --------------------------------------------------------------------- ## F. WRAP A SPARSE MATRIX IN A DelayedArray OBJECT ## --------------------------------------------------------------------- \dontrun{ library(Matrix) M <- 75000L N <- 1800L p <- sparseMatrix(sample(M, 9000000, replace=TRUE), sample(N, 9000000, replace=TRUE), x=runif(9000000), dims=c(M, N)) P <- DelayedArray(p) P p2 <- as(P, "sparseMatrix") stopifnot(identical(p, p2)) ## The following is based on the following post by Murat Tasan on the ## R-help mailing list: ## https://stat.ethz.ch/pipermail/r-help/2017-May/446702.html ## As pointed out by Murat, the straight-forward row normalization ## directly on sparse matrix 'p' would consume too much memory: row_normalized_p <- p / rowSums(p^2) # consumes too much memory ## because the rowSums() result is being recycled (appropriately) into a ## *dense* matrix with dimensions equal to dim(p). ## Murat came up with the following solution that is very fast and memory ## efficient: row_normalized_p1 <- Diagonal(x=1/sqrt(Matrix::rowSums(p^2))) %*% p ## With a DelayedArray object, the straight-forward approach uses a ## block processing strategy behind the scene so it doesn't consume ## too much memory. ## First, let's see the block processing in action: DelayedArray:::set_verbose_block_processing(TRUE) ## and set block size to a bigger value than the default: getOption("DelayedArray.block.size") options(DelayedArray.block.size=80e6) row_normalized_P <- P / sqrt(DelayedArray::rowSums(P^2)) ## Increasing the block size increases the speed but also memory usage: options(DelayedArray.block.size=200e6) row_normalized_P2 <- P / sqrt(DelayedArray::rowSums(P^2)) stopifnot(all.equal(row_normalized_P, row_normalized_P2)) ## Back to sparse representation: DelayedArray:::set_verbose_block_processing(FALSE) row_normalized_p2 <- as(row_normalized_P, "sparseMatrix") stopifnot(all.equal(row_normalized_p1, row_normalized_p2)) options(DelayedArray.block.size=10e6) } } \keyword{methods} \keyword{classes} DelayedArray/man/DelayedArray-utils.Rd0000644000175400017540000001434613175715525020737 0ustar00biocbuildbiocbuild\name{DelayedArray-utils} \alias{DelayedArray-utils} % DelayedArray utils \alias{+,DelayedArray,missing-method} \alias{-,DelayedArray,missing-method} \alias{pmax2} \alias{pmin2} \alias{pmax2,ANY,ANY-method} \alias{pmin2,ANY,ANY-method} \alias{pmax2,DelayedArray,vector-method} \alias{pmin2,DelayedArray,vector-method} \alias{pmax2,vector,DelayedArray-method} \alias{pmin2,vector,DelayedArray-method} \alias{pmax2,DelayedArray,DelayedArray-method} \alias{pmin2,DelayedArray,DelayedArray-method} \alias{is.na,DelayedArray-method} \alias{is.finite,DelayedArray-method} \alias{is.infinite,DelayedArray-method} \alias{is.nan,DelayedArray-method} \alias{!,DelayedArray-method} \alias{nchar,DelayedArray-method} \alias{tolower,DelayedArray-method} \alias{toupper,DelayedArray-method} \alias{round,DelayedArray-method} \alias{signif,DelayedArray-method} \alias{anyNA,DelayedArray-method} \alias{which,DelayedArray-method} \alias{mean.DelayedArray} \alias{mean,DelayedArray-method} \alias{apply} \alias{apply,DelayedArray-method} % DelayedMatrix utils \alias{\%*\%} \alias{\%*\%,DelayedMatrix,matrix-method} \alias{\%*\%,matrix,DelayedMatrix-method} \alias{\%*\%,DelayedMatrix,DelayedMatrix-method} % DelayedMatrix row/col summarization \alias{rowSums} \alias{rowSums,DelayedMatrix-method} \alias{colSums} \alias{colSums,DelayedMatrix-method} \alias{rowMeans} \alias{rowMeans,DelayedMatrix-method} \alias{colMeans} \alias{colMeans,DelayedMatrix-method} \alias{rowMaxs} \alias{rowMaxs,DelayedMatrix-method} \alias{colMaxs} \alias{colMaxs,DelayedMatrix-method} \alias{rowMins} \alias{rowMins,DelayedMatrix-method} \alias{colMins} \alias{colMins,DelayedMatrix-method} \alias{rowRanges} \alias{rowRanges,DelayedMatrix-method} \alias{colRanges} \alias{colRanges,DelayedMatrix-method} \title{Common operations on DelayedArray objects} \description{ Common operations on \link{DelayedArray} objects. } \details{ The operations currently supported on \link{DelayedArray} objects are: Delayed operations: \itemize{ \item all the members of the \code{\link[methods]{Ops}}, \code{\link[methods]{Math}}, and \code{\link[methods]{Math2}} groups \item \code{!} \item \code{is.na}, \code{is.finite}, \code{is.infinite}, \code{is.nan} \item \code{nchar}, \code{tolower}, \code{toupper} \item \code{pmax2} and \code{pmin2} \item \code{rbind} and \code{cbind} (documented in \link{DelayedArray}) } Block-processed operations: \itemize{ \item \code{anyNA}, \code{which} \item all the members of the \code{\link[methods]{Summary}} group \item \code{mean} \item \code{apply} \item matrix multiplication (\%*\%) of an ordinary matrix by a \link{DelayedMatrix} object \item matrix row/col summarization [\link{DelayedMatrix} objects only]: \code{rowSums}, \code{colSums}, \code{rowMeans}, \code{colMeans}, \code{rowMaxs}, \code{colMaxs}, \code{rowMins}, \code{colMins}, \code{rowRanges}, and \code{colRanges} } } \seealso{ \itemize{ \item \code{\link[base]{is.na}}, \code{\link[base]{!}}, \code{\link[base]{mean}}, \code{\link[base]{apply}}, and \code{\link[base]{\%*\%}} in the \pkg{base} package for the corresponding operations on ordinary arrays or matrices. \item \code{\link[base]{rowSums}} in the \pkg{base} package and \code{\link[matrixStats]{rowMaxs}} in the \pkg{matrixStats} package for row/col summarization of an ordinary matrix. \item \code{\link{setRealizationBackend}} for how to set a \emph{realization backend}. \item \code{\link[HDF5Array]{writeHDF5Array}} in the \pkg{HDF5Array} package for writting an array-like object to an HDF5 file and other low-level utilities to control the location of automatically created HDF5 datasets. \item \link{DelayedArray} objects. \item \link[HDF5Array]{HDF5Array} objects in the \pkg{HDF5Array} package. \item \code{\link[methods]{S4groupGeneric}} in the \pkg{methods} package for the members of the \code{\link[methods]{Ops}}, \code{\link[methods]{Math}}, and \code{\link[methods]{Math2}} groups. \item \link[base]{array} objects in base R. } } \examples{ library(HDF5Array) toy_h5 <- system.file("extdata", "toy.h5", package="HDF5Array") h5ls(toy_h5) M1 <- HDF5Array(toy_h5, "M1") range(M1) M1 >= 0.5 & M1 < 0.75 log(M1) M2 <- HDF5Array(toy_h5, "M2") pmax2(M2, 0) M3 <- rbind(M1, t(M2)) M3 ## --------------------------------------------------------------------- ## MATRIX MULTIPLICATION ## --------------------------------------------------------------------- ## Matrix multiplication is not delayed: the output matrix is realized ## block by block. The current "realization backend" controls where ## realization happens e.g. in memory if set to NULL or in an HDF5 file ## if set to "HDF5Array". See '?realize' for more information about ## "realization backends". ## The output matrix is returned as a DelayedMatrix object with no delayed ## operations on it. The exact class of the object depends on the backend ## e.g. it will be HDF5Matrix with "HDF5Array" backend. m <- matrix(runif(50000), ncol=nrow(M1)) ## Set backend to NULL for in-memory realization: setRealizationBackend() P1 <- m \%*\% M1 P1 ## Set backend to HDF5Array for realization in HDF5 file: setRealizationBackend("HDF5Array") ## With the HDF5Array backend, the output matrix will be written to an ## automatic location on disk: getHDF5DumpFile() # HDF5 file where the output matrix will be written lsHDF5DumpFile() P2 <- m \%*\% M1 P2 lsHDF5DumpFile() ## Use setHDF5DumpFile() and setHDF5DumpName() from the HDF5Array package ## to control the location of automatically created HDF5 datasets. stopifnot(identical(as.array(P1), as.array(P2))) ## --------------------------------------------------------------------- ## MATRIX ROW/COL SUMMARIZATION ## --------------------------------------------------------------------- rowSums(M1) colSums(M1) rowMeans(M1) colMeans(M1) rmaxs <- rowMaxs(M1) cmaxs <- colMaxs(M1) rmins <- rowMins(M1) cmins <- colMins(M1) rranges <- rowRanges(M1) cranges <- colRanges(M1) stopifnot(identical(cbind(rmins, rmaxs, deparse.level=0), rranges)) stopifnot(identical(cbind(cmins, cmaxs, deparse.level=0), cranges)) } \keyword{methods} DelayedArray/man/RleArray-class.Rd0000644000175400017540000000732213175715525020053 0ustar00biocbuildbiocbuild\name{RleArray-class} \docType{class} \alias{class:RleArraySeed} \alias{RleArraySeed-class} \alias{class:SolidRleArraySeed} \alias{SolidRleArraySeed-class} \alias{class:RleRealizationSink} \alias{RleRealizationSink-class} \alias{class:ChunkedRleArraySeed} \alias{ChunkedRleArraySeed-class} \alias{dim,RleArraySeed-method} \alias{dimnames,RleArraySeed-method} \alias{coerce,SolidRleArraySeed,Rle-method} \alias{coerce,RleRealizationSink,Rle-method} \alias{subset_seed_as_array,SolidRleArraySeed-method} \alias{subset_seed_as_array,ChunkedRleArraySeed-method} \alias{coerce,RleRealizationSink,ChunkedRleArraySeed-method} \alias{coerce,ChunkedRleArraySeed,SolidRleArraySeed-method} \alias{class:RleArray} \alias{RleArray-class} \alias{class:RleMatrix} \alias{RleMatrix-class} \alias{RleMatrix} \alias{coerce,RleArray,RleMatrix-method} \alias{matrixClass,RleArray-method} \alias{coerce,ANY,RleMatrix-method} \alias{DelayedArray,RleArraySeed-method} \alias{RleArray} \alias{write_block_to_sink,RleRealizationSink-method} \alias{coerce,RleRealizationSink,RleArray-method} \alias{coerce,RleRealizationSink,DelayedArray-method} \alias{coerce,ANY,RleArray-method} \alias{coerce,DelayedArray,RleArray-method} \alias{coerce,DelayedMatrix,RleMatrix-method} \alias{coerce,DataFrame,RleMatrix-method} \alias{coerce,DataFrame,RleArray-method} \alias{coerce,RleMatrix,DataFrame-method} \alias{coerce,DelayedMatrix,DataFrame-method} \title{RleArray objects} \description{ The RleArray class is an array-like container where the values are stored in a run-length encoding format. RleArray objects support delayed operations and block processing. } \usage{ RleArray(rle, dim, dimnames=NULL, chunksize=NULL) # constructor function } \arguments{ \item{rle}{ An \link[S4Vectors]{Rle} object. } \item{dim}{ The dimensions of the object to be created, that is, an integer vector of length one or more giving the maximal indices in each dimension. } \item{dimnames}{ Either \code{NULL} or the names for the dimensions. This must a list of length the number of dimensions. Each list element must be either \code{NULL} or a character vector along the corresponding dimension. } \item{chunksize}{ Experimental. Don't use! } } \details{ RleArray extends \link{DelayedArray}. All the operations available on \link{DelayedArray} objects work on RleArray objects. } \seealso{ \itemize{ \item \link[S4Vectors]{Rle} objects in the \pkg{S4Vectors} package. \item \link{DelayedArray} objects. \item \link{DelayedArray-utils} for common operations on \link{DelayedArray} objects. \item \code{\link{realize}} for realizing a DelayedArray object in memory or on disk. \item \link[HDF5Array]{HDF5Array} objects in the \pkg{HDF5Array} package. \item \link[S4Vectors]{DataFrame} objects in the \pkg{S4Vectors} package. \item \link[base]{array} objects in base R. } } \examples{ rle <- Rle(sample(6L, 500000, replace=TRUE), 8) a <- array(rle, dim=c(50, 20, 4000)) # array() expands the Rle object # internally with as.vector() A <- RleArray(rle, dim=c(50, 20, 4000)) # Rle object is NOT expanded A object.size(a) object.size(A) stopifnot(identical(a, as.array(A))) toto <- function(x) (5 * x[ , , 1] ^ 3 + 1L) * log(x[, , 2]) b <- toto(a) head(b) B <- toto(A) # very fast! (operations are delayed) B # still 3 dimensions (subsetting a DelayedArray object never drops # dimensions) B <- drop(B) B stopifnot(identical(b, as.array(B))) cs <- colSums(b) CS <- colSums(B) stopifnot(identical(cs, CS)) ## Coercion of a DelayedMatrix object to DataFrame produces a DataFrame ## object with Rle columns: as(B, "DataFrame") } \keyword{methods} \keyword{classes} DelayedArray/man/bind-arrays.Rd0000644000175400017540000000237013175715525017440 0ustar00biocbuildbiocbuild\name{bind-arrays} \alias{bind-arrays} \alias{bind arrays} \alias{arbind} \alias{acbind} \alias{arbind,array-method} \alias{acbind,array-method} \title{Bind arrays along their rows or columns} \description{ Bind array-like objects with an arbitrary number of dimensions along their rows (\code{arbind}) or columns (\code{acbind}). } \usage{ arbind(...) acbind(...) } \arguments{ \item{...}{ The array-like objects to bind. } } \value{ An array-like object, typically of the same class as the input objects if they all have the same class. } \seealso{ \itemize{ \item \code{\link{DelayedArray}} in this package for arbind/acbind'ing DelayedArray objects. \item \code{\link[base]{rbind}} and \code{\link[base]{cbind}} in the \pkg{base} package for the corresponding operations on matrix-like objects. \item The \pkg{abind} package on CRAN. } } \examples{ a1 <- array(1:60, c(3, 5, 4), dimnames=list(NULL, paste0("M1y", 1:5), NULL)) a2 <- array(101:240, c(7, 5, 4), dimnames=list(paste0("M2x", 1:7), paste0("M2y", 1:5), NULL)) a3 <- array(10001:10100, c(5, 5, 4), dimnames=list(paste0("M3x", 1:5), NULL, paste0("M3z", 1:4))) arbind(a1, a2, a3) } \keyword{methods} DelayedArray/man/block_processing.Rd0000644000175400017540000000065113175715525020553 0ustar00biocbuildbiocbuild\name{block_processing} \alias{block_processing} \alias{write_array_to_sink} \title{Block processing of an array} \description{ A set of utilities for processing an array-like object block by block. } \details{ Coming soon... } \seealso{ \itemize{ \item \link{DelayedArray} objects. \item \code{\link{realize}} for realizing a DelayedArray object in memory or on disk. } } \keyword{methods} DelayedArray/man/realize.Rd0000644000175400017540000000535113175715525016662 0ustar00biocbuildbiocbuild\name{realize} \alias{class:RealizationSink} \alias{RealizationSink-class} \alias{chunk_dim} \alias{chunk_dim,RealizationSink-method} \alias{write_block_to_sink} \alias{close,RealizationSink-method} \alias{class:arrayRealizationSink} \alias{arrayRealizationSink-class} \alias{dim,arrayRealizationSink-method} \alias{write_block_to_sink,arrayRealizationSink-method} \alias{coerce,arrayRealizationSink,DelayedArray-method} \alias{supportedRealizationBackends} \alias{getRealizationBackend} \alias{setRealizationBackend} \alias{realize} \alias{realize,ANY-method} \title{Realize a DelayedArray object} \description{ Realize a \link{DelayedArray} object in memory or on disk. Get or set the \emph{realization backend} for the current session with \code{getRealizationBackend} or \code{setRealizationBackend}. } \usage{ supportedRealizationBackends() getRealizationBackend() setRealizationBackend(BACKEND=NULL) realize(x, ...) \S4method{realize}{ANY}(x, BACKEND=getRealizationBackend()) } \arguments{ \item{x}{ The array-like object to realize. } \item{...}{ Additional arguments passed to methods. } \item{BACKEND}{ \code{NULL} (the default), or a single string specifying the name of the backend. When the backend is set to \code{NULL}, \code{x} is realized in memory as an ordinary array by just calling \code{as.array} on it. } } \details{ The \emph{realization backend} controls where/how realization happens e.g. as an ordinary array if set to \code{NULL}, as an \link{RleArray} object if set to \code{"RleArray"}, or in an HDF5 file if set to \code{"HDF5Array"}. } \value{ \code{realize(x)} returns a \link{DelayedArray} object. More precisely, it returns \code{DelayedArray(as.array(x))} when the backend is set to \code{NULL} (the default). Otherwise it returns an instance of the class associated with the specified backend (which should extend \link{DelayedArray}). } \seealso{ \itemize{ \item \link{DelayedArray} objects. \item \link{RleArray} objects. \item \link[HDF5Array]{HDF5Array} objects in the \pkg{HDF5Array} package. \item \link[base]{array} objects in base R. } } \examples{ library(HDF5Array) toy_h5 <- system.file("extdata", "toy.h5", package="HDF5Array") h5ls(toy_h5) M1 <- HDF5Array(toy_h5, "M1") M2 <- HDF5Array(toy_h5, "M2") M3 <- rbind(log(M1), t(M2)) supportedRealizationBackends() getRealizationBackend() # backend is set to NULL realize(M3) # realization as ordinary array setRealizationBackend("RleArray") getRealizationBackend() # backend is set to "RleArray" realize(M3) # realization as RleArray object setRealizationBackend("HDF5Array") getRealizationBackend() # backend is set to "HDF5Array" realize(M3) # realization in HDF5 file } \keyword{methods} DelayedArray/man/subset_seed_as_array.Rd0000644000175400017540000000266413175715525021421 0ustar00biocbuildbiocbuild\name{subset_seed_as_array} \alias{subset_seed_as_array} \alias{subset_seed_as_array,ANY-method} \alias{subset_seed_as_array,array-method} \alias{subset_seed_as_array,data.frame-method} \alias{subset_seed_as_array,DataFrame-method} \alias{dim,ConformableSeedCombiner-method} \alias{dimnames,ConformableSeedCombiner-method} \alias{subset_seed_as_array,ConformableSeedCombiner-method} \alias{dim,SeedBinder-method} \alias{dimnames,SeedBinder-method} \alias{subset_seed_as_array,SeedBinder-method} \title{subset_seed_as_array} \description{ \code{subset_seed_as_array} is an internal generic function not aimed to be used directly by the user. It has methods defined for array, data.frame, DataFrame objects and other array-like objects. The \code{DelayedArray()} constructor function will accept any seed that supports \code{dim()}, \code{dimnames()}, and \code{subset_seed_as_array()}. } \usage{ subset_seed_as_array(seed, index) } \arguments{ \item{seed}{ An array-like object. } \item{index}{ An unnamed list of subscripts as positive integer vectors, one vector per seed dimension. \emph{Missing} list elements are allowed and must be represented by \code{NULL}s. } } \seealso{ \itemize{ \item \link{DelayedArray} objects. \item \link[base]{array} and \link[base]{data.frame} objects in base R. \item \link[S4Vectors]{DataFrame} objects in the \pkg{S4Vectors} package. } } \keyword{internal} DelayedArray/tests/0000755000175400017540000000000013175715525015323 5ustar00biocbuildbiocbuildDelayedArray/tests/run_unitTests.R0000644000175400017540000000013613175715525020334 0ustar00biocbuildbiocbuildrequire("DelayedArray") || stop("unable to load DelayedArray package") DelayedArray:::.test() DelayedArray/vignettes/0000755000175400017540000000000013177207140016160 5ustar00biocbuildbiocbuildDelayedArray/vignettes/Working_with_large_arrays.Rnw0000644000175400017540000004451113175715525024074 0ustar00biocbuildbiocbuild%\VignetteEngine{knitr::knitr} %\VignetteIndexEntry{Working with large arrays in R} %\VignetteDepends{knitr,Matrix,DelayedArray,HDF5Array,SummarizedExperiment,airway,pryr} \documentclass[8pt]{beamer} \mode { \usetheme{Madrid} \usecolortheme{whale} } \usepackage{slides} \renewcommand\Rclass[1]{{\texttt{#1}\index{#1 (class)}}} \AtBeginSection[] { \begin{frame} \tableofcontents[currentsection] \end{frame} } \title{Working with large arrays in R} \subtitle{A look at HDF5Array/RleArray/DelayedArray objects} \author{Herv\'e Pag\`es\\ \href{mailto:hpages@fredhutch.org}{hpages@fredhutch.org}} \institute{Bioconductor conference\\Boston} \date{July 2017} \begin{document} <>= library(knitr) opts_chunk$set(size="scriptsize") if (!dir.exists("~/mydata")) dir.create("~/mydata") options(width=80) library(Matrix) library(DelayedArray) library(HDF5Array) library(SummarizedExperiment) library(airway) library(pryr) @ \maketitle \frame{\tableofcontents} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Motivation and challenges} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{frame}[fragile] \frametitle{Motivation and challenges} R ordinary {\bf matrix} or {\bf array} is not suitable for big datasets: \begin{block}{} \begin{itemize} \item 10x Genomics dataset (single cell experiment): 30,000 genes x 1.3 million cells = 36.5 billion values \item in an ordinary integer matrix ==> 136G in memory! \end{itemize} \end{block} \bigskip Need for alternative containers: \begin{block}{} \begin{itemize} \item but at the same time, the object should be (almost) as easy to manipulate as an ordinary matrix or array \item {\em standard R matrix/array API}: \Rcode{dim}, \Rcode{dimnames}, \Rcode{t}, \Rcode{is.na}, \Rcode{==}, \Rcode{+}, \Rcode{log}, \Rcode{cbind}, \Rcode{max}, \Rcode{sum}, \Rcode{colSums}, etc... \item not limited to 2 dimensions ==> also support arrays of arbitrary number of dimensions \end{itemize} \end{block} \bigskip 2 approaches: {\bf in-memory data} vs {\bf on-disk data} \end{frame} \begin{frame}[fragile] \frametitle{Motivation and challenges} \centerline{\bf In-memory data} \begin{block}{} \begin{itemize} \item a 30k x 1.3M matrix might still fit in memory if the data can be efficiently compressed \item example: sparse data (small percentage of non-zero values) ==> {\em sparse representation} (storage of non-zero values only) \item example: data with long runs of identical values ==> {\em RLE compression (Run Length Encoding)} \item choose the {\em smallest type} to store the values: \Rcode{raw} (1 byte) < \Rcode{integer} (4 bytes) < \Rcode{double} (8 bytes) \item if using {\em RLE compression}: \begin{itemize} \item choose the {\em best orientation} to store the values: {\em by row} or {\em by column} (one might give better compression than the other) \item store the data by chunk ==> opportunity to pick up {\em best type} and {\em best orientation} on a chunk basis (instead of for the whole data) \end{itemize} \item size of 30k x 1.3M matrix in memory can be reduced from 136G to 16G! \end{itemize} \end{block} \end{frame} \begin{frame}[fragile] \frametitle{Motivation and challenges} \centerline{\bf Examples of in-memory containers} \bigskip {\bf dgCMatrix} container from the \Biocpkg{Matrix} package: \begin{block}{} \begin{itemize} \item sparse matrix representation \item non-zero values stored as \Rcode{double} \end{itemize} \end{block} \bigskip {\bf RleArray} and {\bf RleMatrix} containers from the \Biocpkg{DelayedArray} package: \begin{block}{} \begin{itemize} \item use RLE compression \item arbitrary number of dimensions \item type of values: any R atomic type (\Rcode{integer}, \Rcode{double}, \Rcode{logical}, \Rcode{complex}, \Rcode{character}, and \Rcode{raw}) \end{itemize} \end{block} \end{frame} \begin{frame}[fragile] \frametitle{Motivation and challenges} \centerline{\bf On-disk data} \bigskip However... \begin{itemize} \item if data is too big to fit in memory (even after compression) ==> must use {\em on-disk representation} \item challenge: should still be (almost) as easy to manipulate as an ordinary matrix! ({\em standard R matrix/array API}) \end{itemize} \end{frame} \begin{frame}[fragile] \frametitle{Motivation and challenges} \centerline{\bf Examples of on-disk containers} \bigskip Direct manipulation of an {\bf HDF5 dataset} via the \Biocpkg{rhdf5} API. Low level API! \bigskip {\bf HDF5Array} and {\bf HDF5Matrix} containers from the \Biocpkg{HDF5Array} package: \begin{block}{} Provide access to the HDF5 dataset via an API that mimics the standard R matrix/array API \end{block} \end{frame} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Memory footprint} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{frame}[fragile] \frametitle{Memory footprint} \centerline{\bf The "airway" dataset} \begin{columns}[t] \begin{column}{0.36\textwidth} \begin{exampleblock}{} <>= library(airway) data(airway) m <- unname(assay(airway)) dim(m) typeof(m) @ \end{exampleblock} \end{column} \begin{column}{0.52\textwidth} \begin{exampleblock}{} <>= head(m, n=4) tail(m, n=4) sum(m != 0) / length(m) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{Memory footprint} \centerline{{\bf dgCMatrix} vs {\bf RleMatrix} vs {\bf HDF5Matrix}} \begin{columns}[t] \begin{column}{0.60\textwidth} \begin{exampleblock}{} <>= library(pryr) # for object_size() object_size(m) library(Matrix) object_size(as(m, "dgCMatrix")) library(DelayedArray) object_size(as(m, "RleMatrix")) object_size(as(t(m), "RleMatrix")) library(HDF5Array) object_size(as(m, "HDF5Matrix")) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{Memory footprint} Some limitations of the sparse matrix implementation in the \Biocpkg{Matrix} package: \begin{block}{} \begin{itemize} \item non-zero values always stored as \Rcode{double}, the most memory consuming type \item number of non-zero values must be $< 2^{31}$ \item limited to 2 dimensions: no support for arrays of arbitrary number of dimensions \end{itemize} \end{block} \end{frame} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{RleArray and HDF5Array objects} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} RleMatrix/RleArray and HDF5Matrix/HDF5Array provide: \begin{block}{} \begin{itemize} \item support all R atomic types \item no limits in size (but each dimension must be $< 2^{31}$) \item arbitrary number of dimensions \end{itemize} \end{block} \bigskip And also: \begin{block}{} \begin{itemize} \item {\bf delayed operations} \item {\bf block-processing} (behind the scene) \item TODO: multicore block-processing (sequential only at the moment) \end{itemize} \end{block} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \centerline{\bf Delayed operations} \bigskip \centerline{We start with HDF5Matrix object \Rcode{M}:} \begin{columns}[t] \begin{column}{0.60\textwidth} \begin{exampleblock}{} <>= M <- as(m, "HDF5Matrix") M @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} Subsetting is delayed: \begin{columns}[t] \begin{column}{0.40\textwidth} \begin{exampleblock}{} <>= M2 <- M[10:12, 1:5] M2 @ \end{exampleblock} \end{column} \begin{column}{0.48\textwidth} \begin{exampleblock}{} <>= seed(M2) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} Transposition is delayed: \begin{columns}[t] \begin{column}{0.40\textwidth} \begin{exampleblock}{} <<>>= M3 <- t(M2) M3 @ \end{exampleblock} \end{column} \begin{column}{0.48\textwidth} \begin{exampleblock}{} <<>>= seed(M3) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \Rcode{cbind()} / \Rcode{rbind()} are delayed: \begin{columns}[t] \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= M4 <- cbind(M3, M[1:5, 6:8]) M4 @ \end{exampleblock} \end{column} \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= seed(M4) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} All the operations in the following groups are delayed: \begin{itemize} \item \Rcode{Arith} (\Rcode{+}, \Rcode{-}, ...) \item \Rcode{Compare} (\Rcode{==}, \Rcode{<}, ...) \item \Rcode{Logic} (\Rcode{\&}, \Rcode{|}) \item \Rcode{Math} (\Rcode{log}, \Rcode{sqrt}) \item and more ... \end{itemize} \begin{columns}[t] \begin{column}{0.42\textwidth} \begin{exampleblock}{} <<>>= M5 <- M == 0 M5 @ \end{exampleblock} \end{column} \begin{column}{0.47\textwidth} \begin{exampleblock}{} <<>>= seed(M5) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \begin{columns}[t] \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= M6 <- round(M[11:14, ] / M[1:4, ], digits=3) M6 @ \end{exampleblock} \end{column} \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= seed(M6) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \centerline{\bf Realization} \bigskip Delayed operations can be {\bf realized} by coercing the DelayedMatrix object to HDF5Array: \begin{columns}[t] \begin{column}{0.40\textwidth} \begin{exampleblock}{} <<>>= M6a <- as(M6, "HDF5Array") M6a @ \end{exampleblock} \end{column} \begin{column}{0.48\textwidth} \begin{exampleblock}{} <<>>= seed(M6a) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \bigskip ... or by coercing it to RleArray: \begin{columns}[t] \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= M6b <- as(M6, "RleArray") M6b @ \end{exampleblock} \end{column} \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= seed(M6b) @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \centerline{\bf Controlling where HDF5 datasets are realized} \bigskip {\em HDF5 dump management utilities}: a set of utilities to control where HDF5 datasets are written to disk. \begin{columns}[t] \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= setHDF5DumpFile("~/mydata/M6c.h5") setHDF5DumpName("M6c") M6c <- as(M6, "HDF5Array") @ \end{exampleblock} \end{column} \begin{column}{0.44\textwidth} \begin{exampleblock}{} <<>>= seed(M6c) h5ls("~/mydata/M6c.h5") @ \end{exampleblock} \end{column} \end{columns} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \centerline{\Rcode{showHDF5DumpLog()}} \begin{exampleblock}{} <<>>= showHDF5DumpLog() @ \end{exampleblock} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \centerline{\bf Block processing} \bigskip The following operations are NOT delayed. They are implemented via a {\em block processing} mechanism that loads and processes one block at a time: \begin{itemize} \item operations in the \Rcode{Summary} group (\Rcode{max}, \Rcode{min}, \Rcode{sum}, \Rcode{any}, \Rcode{all}) \item \Rcode{mean} \item Matrix row/col summarization operations (\Rcode{col/rowSums}, \Rcode{col/rowMeans}, ...) \item \Rcode{anyNA}, \Rcode{which} \item \Rcode{apply} \item and more ... \end{itemize} \end{frame} \begin{frame}[fragile] \frametitle{RleArray and HDF5Array objects} \begin{columns}[t] \begin{column}{0.75\textwidth} \begin{exampleblock}{} <<>>= DelayedArray:::set_verbose_block_processing(TRUE) colSums(M) @ \end{exampleblock} Control the block size: \begin{exampleblock}{} <<>>= getOption("DelayedArray.block.size") options(DelayedArray.block.size=1e6) colSums(M) @ \end{exampleblock} \end{column} \end{columns} \end{frame} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Hands-on} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{frame}[fragile] \frametitle{Hands-on} \begin{block}{} 1. Load the "airway" dataset. \end{block} \begin{block}{} 2. It's wrapped in a SummarizedExperiment object. Get the count data as an ordinary matrix. \end{block} \begin{block}{} 3. Wrap it in an HDF5Matrix object: (1) using \Rcode{writeHDF5Array()}; then (2) using coercion. \end{block} \begin{block}{} 4. When using coercion, where has the data been written on disk? \end{block} \begin{block}{} 5. See \Rcode{?setHDF5DumpFile} for how to control the location of "automatic" HDF5 datasets. Try to control the destination of the data when coercing. \end{block} \end{frame} \begin{frame}[fragile] \frametitle{Hands-on} \begin{block}{} 6. Use \Rcode{showHDF5DumpLog()} to see all the HDF5 datasets written to disk during the current session. \end{block} \bigskip \begin{block}{} 7. Try some operations on the HDF5Matrix object: (1) some delayed ones; (2) some non-delayed ones (block processing). \end{block} \bigskip \begin{block}{} 8. Use \Rcode{DelayedArray:::set\_verbose\_block\_processing(TRUE)} to see block processing in action. \end{block} \bigskip \begin{block}{} 9. Control the block size via \Rcode{DelayedArray.block.size} global option. \end{block} \end{frame} \begin{frame}[fragile] \frametitle{Hands-on} \begin{block}{} 10. Stick the HDF5Matrix object back in the SummarizedExperiment object. The resulting object is an "HDF5-backed SummarizedExperiment object". \end{block} \bigskip \begin{block}{} 11. The HDF5-backed SummarizedExperiment object can be manipulated (almost) like an in-memory SummarizedExperiment object. Try \Rcode{[}, \Rcode{cbind}, \Rcode{rbind} on it. \end{block} \bigskip \begin{block}{} 12. The \Biocpkg{SummarizedExperiment} package provides \Rcode{saveHDF5SummarizedExperiment} to save a SummarizedExperiment object (HDF5-backed or not) as an HDF5-backed SummarizedExperiment object. Try it. \end{block} \end{frame} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{DelayedArray/HDF5Array: Future developments} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{frame}[fragile] \frametitle{Future developments} \centerline{\bf Block processing improvements} \begin{block}{} Block genometry: (1) better by default, (2) let the user have more control on it \end{block} \begin{block}{} Support multicore \end{block} \begin{block}{} Expose it: \Rcode{blockApply()} \end{block} \end{frame} \begin{frame}[fragile] \frametitle{Future developments} \centerline{\bf HDF5Array improvements} \begin{block}{} Store the \Rcode{dimnames} in the HDF5 file (in {\em HDF5 Dimension Scale datasets} - \url{https://www.hdfgroup.org/HDF5/Tutor/h5dimscale.html}) \end{block} \begin{block}{} Use better default chunk geometry when realizing an HDF5Array object \end{block} \begin{block}{} Block processing should take advantage of the chunk geometry (e.g. \Rcode{realize()} should use blocks that are clusters of chunks) \end{block} \begin{block}{} Unfortunately: not possible to support multicore realization at the moment (HDF5 does not support concurrent writing to a dataset yet) \end{block} \end{frame} \begin{frame}[fragile] \frametitle{Future developments} \centerline{\bf RleArray improvements} \begin{block}{} Let the user have more control on the chunk geometry when constructing/realizing an RleArray object \end{block} \begin{block}{} Like for HDF5Array objects, block processing should take advantage of the chunk geometry \end{block} \begin{block}{} Support multicore realization \end{block} \begin{block}{} Provide C/C++ low-level API for direct row/column access from C/C++ code (e.g. from the \Biocpkg{beachmat} package) \end{block} \end{frame} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% <>= unlink("~/mydata", recursive=TRUE, force=TRUE) @ \end{document} DelayedArray/vignettes/slides.sty0000644000175400017540000000211313175715525020212 0ustar00biocbuildbiocbuild\usepackage{Sweave} \usepackage{color, graphics} \usepackage{latexsym, amsmath, amssymb} %% simple macros \newcommand{\software}[1]{\textsl{#1}} \newcommand\R{\textsl{R}} \newcommand\Bioconductor{\textsl{Bioconductor}} \newcommand\Rpackage[1]{{\textsl{#1}\index{#1 (package)}}} \newcommand\Biocpkg[1]{% {\href{http://bioconductor.org/packages/release/bioc/html/#1.html}% {\textsl{#1}}}% \index{#1 (package)}} \newcommand\Rpkg[1]{% {\href{http://cran.fhcrc.org/web/packages/#1/index.html}% {\textsl{#1}}}% \index{#1 (package)}} \newcommand\Biocdatapkg[1]{% {\href{http://bioconductor.org/packages/release/data/experiment/html/#1.html}% {\textsl{#1}}}% \index{#1 (package)}} \newcommand\Robject[1]{{\small\texttt{#1}}} \newcommand\Rclass[1]{{\textit{#1}\index{#1 (class)}}} \newcommand\Rfunction[1]{{{\small\texttt{#1}}\index{#1 (function)}}} \newcommand\Rmethod[1]{{\texttt{#1}}} \newcommand\Rfunarg[1]{{\small\texttt{#1}}} \newcommand\Rcode[1]{{\small\texttt{#1}}} %% \AtBeginSection[] %% { %% \begin{frame}{Outline} %% \tableofcontents %% \end{frame} %% }