S4Vectors/DESCRIPTION0000644000175100017510000000275412607346177015161 0ustar00biocbuildbiocbuildPackage: S4Vectors Title: S4 implementation of vectors and lists Description: The S4Vectors package defines the Vector and List virtual classes and a set of generic functions that extend the semantic of ordinary vectors and lists in R. Package developers can easily implement vector-like or list-like objects as concrete subclasses of Vector or List. In addition, a few low-level concrete subclasses of general interest (e.g. DataFrame, Rle, and Hits) are implemented in the S4Vectors package itself (many more are implemented in the IRanges package and in other Bioconductor infrastructure packages). Version: 0.8.0 Author: H. Pages, M. Lawrence and P. Aboyoun Maintainer: Bioconductor Package Maintainer biocViews: Infrastructure, DataRepresentation Depends: R (>= 3.1.0), methods, utils, stats, stats4, BiocGenerics (>= 0.15.10) Imports: methods, utils, stats, stats4, BiocGenerics Suggests: IRanges, RUnit License: Artistic-2.0 Collate: S4-utils.R show-utils.R utils.R normarg-utils.R vector-utils.R isSorted.R logical-utils.R int-utils.R str-utils.R eval-utils.R DataTable-class.R subsetting-internals.R Annotated-class.R Vector-class.R Vector-comparison.R Hits-class.R Hits-comparison.R Hits-setops.R Rle-class.R Rle-utils.R List-class.R List-utils.R SimpleList-class.R DataFrame-class.R FilterRules-class.R aggregate-methods.R split-methods.R zzz.R NeedsCompilation: yes Packaged: 2015-10-14 03:31:11 UTC; biocbuild S4Vectors/NAMESPACE0000644000175100017510000001617712607264537014675 0ustar00biocbuildbiocbuilduseDynLib(S4Vectors) import(methods) importFrom(utils, head, tail) importFrom(stats, var, cov, cor, sd, median, quantile, smoothEnds, runmed, window, "window<-", aggregate, na.omit, na.exclude, complete.cases, setNames) importFrom(stats4, summary, update) import(BiocGenerics) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S4 classes ### exportClasses( characterORNULL, vectorORfactor, DataTable, NSBS, Annotated, DataTableORNULL, Vector, Hits, Rle, List, SimpleList, DataFrame, expressionORfunction, FilterRules, FilterMatrix ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S3 methods ### S3method(aggregate, Vector) S3method(aggregate, Rle) S3method(aggregate, List) S3method(anyDuplicated, NSBS) S3method(anyDuplicated, WindowNSBS) S3method(as.data.frame, Vector) S3method(as.data.frame, Rle) S3method(as.data.frame, List) S3method(as.data.frame, DataFrame) S3method(as.list, Rle) S3method(as.list, List) S3method(as.list, SimpleList) S3method(as.vector, Rle) S3method(cbind, DataFrame) S3method(diff, Rle) S3method(droplevels, Rle) S3method(droplevels, List) S3method(duplicated, DataTable) S3method(duplicated, Vector) S3method(duplicated, Rle) S3method(head, Vector) S3method(levels, Rle) S3method(mean, Rle) S3method(median, Rle) S3method(quantile, Rle) S3method(rbind, DataFrame) S3method(rev, Rle) S3method(sort, Vector) S3method(sort, Rle) S3method(summary, Rle) S3method(tail, Vector) S3method(unique, DataTable) S3method(unique, Vector) S3method(unique, Rle) S3method(window, Vector) ### 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( aggregate.Vector, aggregate.Rle, aggregate.List, anyDuplicated.NSBS, anyDuplicated.WindowNSBS, as.data.frame.Vector, as.data.frame.Rle, as.data.frame.List, as.data.frame.DataFrame, as.list.Rle, as.list.List, as.list.SimpleList, as.vector.Rle, diff.Rle, droplevels.Rle, droplevels.List, duplicated.DataTable, duplicated.Vector, duplicated.Rle, head.Vector, levels.Rle, mean.Rle, median.Rle, quantile.Rle, rev.Rle, sort.Vector, sort.Rle, summary.Rle, tail.Vector, unique.DataTable, unique.Vector, unique.Rle, window.Vector ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S4 methods for generics not defined in S4Vectors ### exportMethods( ## Methods for generics defined in the base package: length, names, "names<-", nrow, ncol, dim, NROW, NCOL, rownames, "rownames<-", colnames, "colnames<-", dimnames, "dimnames<-", is.na, anyNA, as.logical, as.integer, as.numeric, as.complex, as.character, as.raw, as.factor, as.list, as.data.frame, as.matrix, as.table, "[", "[<-", subset, c, append, merge, "==", "!=", "<=", ">=", "<", ">", match, duplicated, unique, anyDuplicated, "%in%", sort, rank, xtfrm, t, by, transform, substr, substring, levels, "levels<-", droplevels, "[[", "[[<-", "$", "$<-", split, eval, with, within, ifelse, # Deprecated ## Methods for generics defined in the methods package: coerce, show, ## Methods for generics defined in the utils package: head, tail, ## Methods for generics defined in the stats package: window, aggregate, na.omit, na.exclude, complete.cases, ## Methods for generics defined in the stats4 package: summary, ## Methods for generics defined in the BiocGenerics package: cbind, rbind, lapply, sapply, Reduce, Filter, Find, Map, Position, unlist, do.call, union, intersect, setdiff, xtabs, start, end, width, grep, grepl ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export non-generic functions ### export( ## S4-utils.R: setValidity2, new2, setMethods, ## utils.R: wmsg, .Call2, get_showHeadLines, get_showTailLines, printAtomicVectorInAGrid, ## normarg-utils.R: isTRUEorFALSE, isSingleInteger, isSingleNumber, isSingleString, isSingleNumberOrNA, isSingleStringOrNA, recycleIntegerArg, recycleNumericArg, recycleLogicalArg, recycleCharacterArg, recycleArg, fold, ## str-utils.R: safeExplode, strsplitAsListOfIntegerVectors, svn.time, ## subsetting-internals.R: normalizeSingleBracketSubscript, normalizeDoubleBracketSubscript, ## Hits-class.R: Hits, selectHits, remapHits, ## List-class.R: List, phead, ptail, pc, ## SimpleList-class.R: SimpleList, ## DataFrame-class.R: DataFrame, ## FilterRules-class.R: FilterRules, FilterMatrix ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S4 generics defined in S4Vectors + export corresponding methods ### export( ## isSorted.R: isConstant, isSorted, isStrictlySorted, ## str-utils.R: unstrsplit, ## DataTable-class.R: ROWNAMES, as.env, ## subsetting-internals.R: NSBS, normalizeSingleBracketReplacementValue, extractROWS, replaceROWS, getListElement, setListElement, ## Annotated-class.R: metadata, "metadata<-", ## Vector-class.R: parallelSlotNames, parallelVectorNames, elementMetadata, mcols, values, "elementMetadata<-", "mcols<-", "values<-", rename, classNameForDisplay, showAsCell, ## Vector-comparison.R: compare, selfmatch, findMatches, countMatches, ## Hits-class.R: queryHits, subjectHits, queryLength, subjectLength, countQueryHits, countSubjectHits, ## Rle-class.R: runLength, "runLength<-", runValue, "runValue<-", nrun, Rle, findRun, shiftApply, ## Rle-utils.R: runsum, runmean, runwtsum, runq, ## List-class.R: elementType, elementLengths, lengths, isEmpty, revElements, ## List-utils.R: endoapply, mendoapply, ## FilterRules-class.R: active, "active<-", evalSeparately, subsetByFilter, params, filterRules ) ### Exactly the same list as above. exportMethods( isConstant, isSorted, isStrictlySorted, unstrsplit, ROWNAMES, as.env, NSBS, normalizeSingleBracketReplacementValue, extractROWS, replaceROWS, getListElement, setListElement, metadata, "metadata<-", parallelVectorNames, elementMetadata, mcols, values, "elementMetadata<-", "mcols<-", "values<-", rename, classNameForDisplay, showAsCell, compare, selfmatch, findMatches, countMatches, queryHits, subjectHits, queryLength, subjectLength, countQueryHits, countSubjectHits, runLength, "runLength<-", runValue, "runValue<-", nrun, Rle, findRun, shiftApply, runsum, runmean, runwtsum, runq, elementType, elementLengths, lengths, isEmpty, revElements, endoapply, mendoapply, active, "active<-", evalSeparately, subsetByFilter, params, filterRules ) S4Vectors/NEWS0000644000175100017510000000300112607264536014132 0ustar00biocbuildbiocbuildCHANGES IN VERSION 0.4.0 ------------------------ NEW FEATURES o Add isSorted() and isStrictlySorted() generics, plus some methods. o Add low-level wmsg() helper for formatting error/warning messages. o Add pc() function for parallel c() of list-like objects. o Add coerce,Vector,DataFrame; just adds any mcols as columns on top of the coerce,ANY,DataFrame behavior. o [[ on a List object now accepts a numeric- or character-Rle of length 1. o Add "droplevels" methods for Rle, List, and DataFrame objects. o Add table,DataTable and transform,DataTable methods. o Add prototype of a better all.equals() for S4 objects. SIGNIFICANT USER-VISIBLE CHANGES o Move Annotated, DataTable, Vector, Hits, Rle, List, SimpleList, and DataFrame classes from the IRanges package. o Move isConstant(), classNameForDisplay(), and low-level argument checking helpers isSingleNumber(), isSingleString(), etc... from the IRanges package. o Add as.data.frame,List method and remove other inconsistent and not needed anymore "as.data.frame" methods for List subclasses. o Remove useless and thus probably never used aggregate,DataTable method that followed the time-series API. o coerce,ANY,List method now propagates the names. BUG FIXES o Fix bug in coercion from list to SimpleList when the list contains matrices and arrays. o Fix subset() on a zero column DataFrame. o Fix rendering of Date/time classes as DataFrame columns. S4Vectors/R/0000755000175100017510000000000012607264537013643 5ustar00biocbuildbiocbuildS4Vectors/R/Annotated-class.R0000644000175100017510000000201512607264536017003 0ustar00biocbuildbiocbuild### ========================================================================= ### Annotated objects ### ------------------------------------------------------------------------- setClass("Annotated", representation("VIRTUAL", metadata = "list")) setGeneric("metadata", function(x, ...) standardGeneric("metadata")) setMethod("metadata", "Annotated", function(x) { if (is.null(x@metadata) || is.character(x@metadata)) list(metadata = x@metadata) else x@metadata }) setGeneric("metadata<-", function(x, ..., value) standardGeneric("metadata<-")) setReplaceMethod("metadata", "Annotated", function(x, value) { if (!is.list(value)) stop("replacement 'metadata' value must be a list") if (!length(value)) names(value) <- NULL # instead of character() x@metadata <- value x }) S4Vectors/R/DataFrame-class.R0000644000175100017510000006211512607264536016721 0ustar00biocbuildbiocbuild### ========================================================================= ### DataFrame objects ### ------------------------------------------------------------------------- ## A data.frame-like interface for S4 objects that implement length() and `[` ## NOTE: Normal data.frames always have rownames (sometimes as integers), ## but we allow the rownames to be NULL for efficiency. This means that we ## need to store the number of rows (nrows). setClass("DataFrame", representation( rownames = "characterORNULL", nrows = "integer" ), prototype(rownames = NULL, nrows = 0L, listData = structure(list(), names = character())), contains = c("DataTable", "SimpleList")) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Accessor methods. ### setMethod("nrow", "DataFrame", function(x) x@nrows) setMethod("ncol", "DataFrame", function(x) length(x)) setMethod("rownames", "DataFrame", function(x, do.NULL = TRUE, prefix = "row") { rn <- x@rownames if (is.null(rn) && !do.NULL) { nr <- NROW(x) if (nr > 0L) rn <- paste(prefix, seq_len(nr), sep = "") else rn <- character(0L) } rn }) setMethod("colnames", "DataFrame", function(x, do.NULL = TRUE, prefix = "col") { if (!identical(do.NULL, TRUE)) warning("do.NULL arg is ignored ", "in this method") cn <- names(x@listData) if (!is.null(cn)) return(cn) if (length(x@listData) != 0L) stop("DataFrame object with NULL colnames, please fix it ", "with colnames(x) <- value") return(character(0)) }) setReplaceMethod("rownames", "DataFrame", function(x, value) { if (!is.null(value)) { if (anyMissing(value)) stop("missing values not allowed in rownames") if (length(value) != nrow(x)) stop("invalid rownames length") if (anyDuplicated(value)) stop("duplicate rownames not allowed") if (!is(value, "XStringSet")) value <- as.character(value) } x@rownames <- value x }) setReplaceMethod("colnames", "DataFrame", function(x, value) { if (!is.character(value)) stop("'value' must be a character vector ", "in colnames(x) <- value") if (length(value) > length(x)) stop("more column names than columns") names(x) <- value x }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity. ### .valid.DataFrame.dim <- function(x) { nr <- dim(x)[1L] if (!length(nr) == 1) return("length of 'nrows' slot must be 1") if (nr < 0) return("number of rows must be non-negative") NULL } .valid.DataFrame.rownames <- function(x) { if (is.null(rownames(x))) return(NULL) if (length(rownames(x)) != nrow(x)) return("number of row names and number of rows differ") NULL } .valid.DataFrame.names <- function(x) { ## DataFrames with no columns can have NULL column name if (is.null(names(x)) && ncol(x) != 0) return("column names should not be NULL") if (length(names(x)) != ncol(x)) return("number of columns and number of column names differ") NULL } .valid.DataFrame <- function(x) { c(.valid.DataFrame.dim(x), .valid.DataFrame.rownames(x), .valid.DataFrame.names(x)) } setValidity2("DataFrame", .valid.DataFrame) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Constructor. ### DataFrame <- function(..., row.names = NULL, check.names = TRUE) { ## build up listData, with names from arguments if (!isTRUEorFALSE(check.names)) stop("'check.names' must be TRUE or FALSE") nr <- 0 listData <- list(...) varlist <- vector("list", length(listData)) if (length(listData) > 0) { dotnames <- names(listData) if (is.null(dotnames)) { emptynames <- rep.int(TRUE, length(listData)) } else { emptynames <- !nzchar(dotnames) } if (any(emptynames)) { qargs <- as.list(substitute(list(...)))[-1L] dotvalues <- sapply(qargs[emptynames], function(arg) deparse(arg)[1L]) names(listData)[emptynames] <- dotvalues } varnames <- as.list(names(listData)) nrows <- ncols <- integer(length(varnames)) for (i in seq_along(listData)) { element <- try(as(listData[[i]], "DataFrame"), silent = TRUE) if (inherits(element, "try-error")) stop("cannot coerce class \"", class(listData[[i]]), "\" to a DataFrame") nrows[i] <- nrow(element) ncols[i] <- ncol(element) varlist[[i]] <- as.list(element, use.names = FALSE) if (!is(listData[[i]], "AsIs")) { if (((length(dim(listData[[i]])) > 1) || (ncol(element) > 1))) { if (emptynames[i]) varnames[[i]] <- colnames(element) else varnames[[i]] <- paste(varnames[[i]], colnames(element), sep = ".") } else if (is.list(listData[[i]]) && length(names(listData[[i]]))) varnames[[i]] <- names(element) } if (is.null(row.names)) row.names <- rownames(element) } nr <- max(nrows) for (i in which((nrows > 0L) & (nrows < nr) & (nr %% nrows == 0L))) { recycle <- rep(seq_len(nrows[i]), length.out = nr) varlist[[i]] <- lapply(varlist[[i]], `[`, recycle, drop=FALSE) nrows[i] <- nr } if (!all(nrows == nr)) stop("different row counts implied by arguments") varlist <- unlist(varlist, recursive = FALSE, use.names = FALSE) nms <- unlist(varnames[ncols > 0L]) if (check.names) nms <- make.names(nms, unique = TRUE) names(varlist) <- nms } else names(varlist) <- character(0) if (!is.null(row.names)) { if (anyMissing(row.names)) stop("missing values in 'row.names'") if (length(varlist) && length(row.names) != nr) stop("invalid length of row names") if (anyDuplicated(row.names)) stop("duplicate row names") row.names <- as.character(row.names) } new2("DataFrame", listData=varlist, rownames=row.names, nrows=as.integer(max(nr, length(row.names))), check=FALSE) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Subsetting. ### setReplaceMethod("[[", "DataFrame", function(x, i, j,..., value) { nrx <- nrow(x) lv <- NROW(value) if (!missing(j) || length(list(...)) > 0) warning("arguments beyond 'i' ignored") if (missing(i)) stop("subscript is missing") if (!is.character(i) && !is.numeric(i)) stop("invalid subscript type") if (length(i) < 1L) stop("attempt to select less than one element") if (length(i) > 1L) stop("attempt to select more than one element") if (is.numeric(i) && (i < 1L || i > ncol(x) + 1L)) stop("subscript out of bounds") if (!is.null(value) && (nrx != lv)) { if ((nrx == 0) || (lv == 0) || (nrx %% lv != 0)) stop(paste(lv, "elements in value to replace", nrx, "elements")) else value <- rep(value, length.out = nrx) } callNextMethod(x, i, value=value) }) setMethod("extractROWS", "DataFrame", function(x, i) { i <- normalizeSingleBracketSubscript(i, x, exact=FALSE, as.NSBS=TRUE) slot(x, "listData", check=FALSE) <- lapply(structure(seq_len(ncol(x)), names=names(x)), function(j) extractROWS(x[[j]], i)) slot(x, "nrows", check=FALSE) <- length(i) if (!is.null(rownames(x))) { slot(x, "rownames", check=FALSE) <- make.unique(extractROWS(rownames(x), i)) } x } ) setMethod("[", "DataFrame", function(x, i, j, ..., drop=TRUE) { if (!isTRUEorFALSE(drop)) stop("'drop' must be TRUE or FALSE") if (length(list(...)) > 0L) warning("parameters in '...' not supported") ## We do list-style subsetting when [ was called with no ','. ## NOTE: matrix-style subsetting by logical matrix not supported. list_style_subsetting <- (nargs() - !missing(drop)) < 3L if (list_style_subsetting || !missing(j)) { if (list_style_subsetting) { if (!missing(drop)) warning("'drop' argument ignored by list-style subsetting") if (missing(i)) return(x) j <- i } if (!is(j, "Ranges")) { xstub <- setNames(seq_along(x), names(x)) j <- normalizeSingleBracketSubscript(j, xstub) } new_listData <- extractROWS(x@listData, j) new_mcols <- extractROWS(mcols(x), j) x <- initialize(x, listData=new_listData, elementMetadata=new_mcols) if (anyDuplicated(names(x))) names(x) <- make.names(names(x)) if (list_style_subsetting) return(x) } if (!missing(i)) x <- extractROWS(x, i) if (missing(drop)) # drop by default if only one column left drop <- ncol(x) == 1L if (drop) { ## one column left if (ncol(x) == 1L) return(x[[1L]]) ## one row left if (nrow(x) == 1L) return(as(x, "list")) } x } ) setMethod("replaceROWS", "DataFrame", function(x, i, value) { i <- normalizeSingleBracketSubscript(i, x, as.NSBS=TRUE) x_ncol <- ncol(x) value_ncol <- ncol(value) if (value_ncol > x_ncol) stop("provided ", value_ncol, " variables ", "to replace ", x_ncol, " variables") slot(x, "listData", check=FALSE) <- lapply(structure(seq_len(ncol(x)), names=names(x)), function(j) replaceROWS(x[[j]], i, value[[((j - 1L) %% value_ncol) + 1L]])) x } ) setReplaceMethod("[", "DataFrame", function(x, i, j, ..., value) { if (length(list(...)) > 0) warning("parameters in '...' not supported") useI <- FALSE newrn <- newcn <- NULL if (nargs() < 4) { if (missing(i)) { j2 <- seq_len(ncol(x)) } else { if (length(i) == 1) { if (is.logical(i) == 1 && i) i <- rep(i, ncol(x)) } xstub <- setNames(seq_along(x), names(x)) j2 <- normalizeSingleBracketSubscript(i, xstub, allow.append=TRUE) if (is.character(i)) newcn <- i[j2 > ncol(x)] } } else { if (missing(i)) { i2 <- seq_len(nrow(x)) } else { useI <- TRUE i2 <- normalizeSingleBracketSubscript(i, x, allow.append=TRUE) if (is.character(i)) newrn <- i[i2 > nrow(x)] } if (missing(j)) { j2 <- seq_len(ncol(x)) } else { xstub <- setNames(seq_along(x), names(x)) j2 <- normalizeSingleBracketSubscript(j, xstub, allow.append=TRUE) if (is.character(j)) newcn <- j[j2 > ncol(x)] } i <- i2 } j <- j2 if (!length(j)) # nothing to replace return(x) if (is(value, "list") || is(value, "List")) { null <- vapply(value, is.null, logical(1L)) if (any(null)) { ### FIXME: data.frame handles gracefully stop("NULL elements not allowed in list value") } value <- as(value, "DataFrame") } if (!is(value, "DataFrame")) { if (useI) li <- length(i) else li <- nrow(x) lv <- length(value) if (lv > 0L && li != lv) { if (li %% lv != 0) stop(paste(lv, "rows in value to replace", li, " rows")) else value <- rep(value, length.out = li) } ## come up with some default row and col names if (!length(newcn) && max(j) > length(x)) { newcn <- paste("V", seq.int(length(x) + 1L, max(j)), sep = "") if (length(newcn) != sum(j > length(x))) stop("new columns would leave holes after ", "existing columns") } if (useI) { if (length(newrn) == 0L && li > 0L && max(i) > nrow(x)) newrn <- as.character(seq.int(nrow(x) + 1L, max(i))) if (length(x@listData[j][[1]]) == 0L) x@listData[j] <- list(rep(NA, nrow(x))) x@listData[j] <- lapply(x@listData[j], function(y) {y[i] <- value; y}) } else { if (is.null(value)) x@listData[j] <- NULL else x@listData[j] <- list(value) } } else { vc <- seq_len(ncol(value)) if (ncol(value) > length(j)) stop("ncol(x[j]) < ncol(value)") if (ncol(value) < length(j)) vc <- rep(vc, length.out = length(j)) if (useI) li <- length(i) else li <- nrow(x) nrv <- nrow(value) if (li != nrv) { if ((li == 0) || (li %% nrv != 0)) stop(paste(nrv, "rows in value to replace", li, " rows")) else value <- value[rep(seq_len(nrv), length.out = li), , drop=FALSE] } ## attempt to derive new row and col names from value if (!length(newcn) && max(j) > length(x)) { newcn <- rep(names(value), length.out = length(j)) newcn <- newcn[j > length(x)] } if (useI) { if (length(newrn) == 0L && li > 0L && max(i) > nrow(x)) { if (!is.null(rownames(value))) { newrn <- rep(rownames(value), length.out = length(i)) newrn <- newrn[i > nrow(x)] } else newrn <- as.character(seq.int(nrow(x) + 1L, max(i))) } for (k in seq_len(length(j))) { if (j[k] > length(x)) v <- NULL else v <- x@listData[[j[k]]] rv <- value[[vc[k]]] if (length(dim(rv)) == 2) v[i,] <- rv else v[i] <- if (is.null(v)) rv else as(rv, class(v)) x@listData[[j[k]]] <- v } } else { if (is.logical(j)) { for (k in seq_len(length(j))) x@listData[[k]] <- value[[vc[k]]] } else { for (k in seq_len(length(j))) x@listData[[j[k]]] <- value[[vc[k]]] } } } ## update row and col names, making them unique if (length(newcn)) { oldcn <- head(colnames(x), length(x) - length(newcn)) colnames(x) <- make.unique(c(oldcn, newcn)) if (!is.null(mcols(x))) mcols(x)[tail(names(x),length(newcn)),] <- DataFrame(NA) } if (length(newrn)) { notj <- setdiff(seq_len(ncol(x)), j) x@listData[notj] <- lapply(x@listData[notj], function(y) c(y, rep(NA, length(newrn)))) x@rownames <- make.unique(c(rownames(x), newrn)) } x@nrows <- length(x[[1]]) # we should always have a column x }) hasNonDefaultMethod <- function(f, signature) { any(selectMethod(f, signature)@defined != "ANY") } hasS3Method <- function(f, signature) { !is.null(getS3method(f, signature, optional=TRUE)) } droplevels.DataFrame <- function(x, except=NULL) { canDropLevels <- function(xi) { hasNonDefaultMethod(droplevels, class(xi)) || hasS3Method("droplevels", class(xi)) } drop.levels <- vapply(x, canDropLevels, NA) if (!is.null(except)) drop.levels[except] <- FALSE x@listData[drop.levels] <- lapply(x@listData[drop.levels], droplevels) x } setMethod("droplevels", "DataFrame", droplevels.DataFrame) setMethod("rep", "DataFrame", function(x, ...) { x[rep(seq_len(nrow(x)), ...),,drop=FALSE] }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion. ### ## Break DataFrame into a normal R data.frame setAs("DataFrame", "data.frame", function(from) { as.data.frame(from, optional=TRUE) }) injectIntoScope <- function(x, ...) { nms <- sapply(tail(substitute(list(...)), -1), deparse) environment(x) <- list2env(setNames(list(...), nms), parent = environment(x)) x } ### S3/S4 combo for as.data.frame.DataFrame as.data.frame.DataFrame <- function(x, row.names=NULL, optional=FALSE, ...) { if (length(list(...))) warning("Arguments in '...' ignored") l <- as(x, "list") if (is.null(row.names)) row.names <- rownames(x) if (!length(l) && is.null(row.names)) row.names <- seq_len(nrow(x)) l <- lapply(l, function(y) { if (is(y, "SimpleList") || is(y, "CompressedList")) y <- as.list(y) if (is.list(y)) y <- I(y) y }) IRanges.data.frame <- injectIntoScope(data.frame, as.data.frame) do.call(IRanges.data.frame, c(l, list(row.names=row.names), check.names=!optional, stringsAsFactors=FALSE)) } setMethod("as.data.frame", "DataFrame", as.data.frame.DataFrame) setMethod("as.matrix", "DataFrame", function(x) { if (length(x) == 0L) m <- matrix(logical(), nrow = nrow(x), ncol = 0L) else m <- do.call(cbind, as.list(x)) rownames(m) <- rownames(x) m }) ## take data.frames to DataFrames setAs("data.frame", "DataFrame", function(from) { rn <- attributes(from)[["row.names"]] if (is.integer(rn)) rn <- NULL nr <- nrow(from) ### FIXME: this should be: ## from <- as.list(from) ### But unclass() causes deep copy attr(from, "row.names") <- NULL class(from) <- NULL new2("DataFrame", listData=from, nrows=nr, rownames=rn, check=FALSE) }) setAs("table", "DataFrame", function(from) { df <- as.data.frame(from) factors <- sapply(df, is.factor) factors[1] <- FALSE do.call(DataFrame, c(df[1], lapply(df[factors], Rle), df["Freq"])) }) setOldClass(c("xtabs", "table")) setAs("xtabs", "DataFrame", function(from) { class(from) <- "table" as(from, "DataFrame") }) .defaultAsDataFrame <- function(from) { if (length(dim(from)) == 2L) { df <- as.data.frame(from) if (0L == ncol(from)) ## colnames on matrix with 0 columns are 'NULL' names(df) <- character() as(df, "DataFrame") } else { row.names <- if (!anyDuplicated(names(from))) names(from) else NULL new2("DataFrame", listData = setNames(list(from), "X"), nrows = length(from), rownames = row.names, check=FALSE) } } setAs("ANY", "DataFrame", .defaultAsDataFrame) .VectorAsDataFrame <- function(from) { ans <- .defaultAsDataFrame(from) if (!is.null(mcols(from))) { ans <- cbind(ans, mcols(from)) } ans } ## overriding the default inheritance-based coercion from methods package setAs("SimpleList", "DataFrame", .VectorAsDataFrame) setAs("Vector", "DataFrame", .VectorAsDataFrame) ## note that any element named 'row.names' will be interpreted differently ## is this a bug or a feature? setAs("list", "DataFrame", function(from) { do.call(DataFrame, c(from, check.names = FALSE)) }) setAs("NULL", "DataFrame", function(from) as(list(), "DataFrame")) ### FIXME: only exists due to annoying S4 warning due to its caching of ### coerce methods. setAs("integer", "DataFrame", function(from) { selectMethod("coerce", c("vector", "DataFrame"))(from) }) setAs("AsIs", "DataFrame", function(from) { df <- new2("DataFrame", nrows = NROW(from), check=FALSE) df[[1]] <- from df }) setAs("ANY", "AsIs", function(from) I(from)) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Combining. ### cbind.DataFrame <- function(..., deparse.level = 1) { ans <- DataFrame(...) mcols(ans) <- rbind_mcols(...) ans } setMethod("cbind", "DataFrame", cbind.DataFrame) rbind.DataFrame <- function(..., deparse.level = 1) { do.call(rbind, lapply(list(...), as, "DataFrame")) } setMethod("rbind", "DataFrame", function(..., deparse.level=1) { args <- list(...) hasrows <- unlist(lapply(args, nrow), use.names=FALSE) > 0L hascols <- unlist(lapply(args, ncol), use.names=FALSE) > 0L if (!any(hasrows | hascols)) { return(DataFrame()) } else if (!any(hasrows)) { return(args[[which(hascols)[1L]]]) } else if (sum(hasrows) == 1) { return(args[[which(hasrows)]]) } else { args <- args[hasrows] } df <- args[[1L]] for (i in 2:length(args)) { if (ncol(df) != ncol(args[[i]])) stop("number of columns for arg ", i, " do not match those of first arg") if (!identical(colnames(df), colnames(args[[i]]))) stop("column names for arg ", i, " do not match those of first arg") } if (ncol(df) == 0) { ans <- DataFrame() ans@nrows <- sum(unlist(lapply(args, nrow), use.names=FALSE)) } else { cols <- lapply(colnames(df), function(cn) { cols <- lapply(args, `[[`, cn) isRle <- vapply(cols, is, logical(1L), "Rle") if (any(isRle) && !all(isRle)) { # would fail dispatch to c,Rle cols[isRle] <- lapply(cols[isRle], decodeRle) } isFactor <- vapply(cols, is.factor, logical(1L)) if (any(isFactor)) { cols <- lapply(cols, as.factor) levs <- unique(unlist(lapply(cols, levels), use.names=FALSE)) cols <- lapply(cols, factor, levs) } rectangular <- length(dim(cols[[1]])) == 2L if (rectangular) { combined <- do.call(rbind, unname(cols)) } else { combined <- do.call(c, unname(cols)) } if (any(isFactor)) combined <- structure(combined, class="factor", levels=levs) combined }) names(cols) <- colnames(df) ans <- new("DataFrame", listData = cols, nrows = NROW(cols[[1]])) } rn <- unlist(lapply(args, rownames), use.names=FALSE) if (!is.null(rn)) { if (length(rn) != nrow(ans)) { rn <- NULL } else if (anyDuplicated(rn)) rn <- make.unique(rn, sep = "") } rownames(ans) <- rn if (!is.null(mcols(df))) { df_mcols <- mcols(df) if (all(sapply(args, function(x) identical(mcols(x), df_mcols)))) mcols(ans) <- df_mcols } ans }) S4Vectors/R/DataTable-class.R0000644000175100017510000002346112607264536016717 0ustar00biocbuildbiocbuild### ========================================================================= ### DataTable objects ### ------------------------------------------------------------------------- ### ### DataTable is an API only (i.e. virtual class with no slots) for accessing ### objects with a rectangular shape like DataFrame or RangedData objects. ### It mimics the API for standard data.frame objects. ### setClass("DataTable", representation("VIRTUAL")) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Accessors. ### setMethod("NROW", "DataTable", function(x) nrow(x)) setMethod("NCOL", "DataTable", function(x) ncol(x)) setMethod("dim", "DataTable", function(x) c(nrow(x), ncol(x))) setGeneric("ROWNAMES", function(x) standardGeneric("ROWNAMES")) setMethod("ROWNAMES", "ANY", function (x) if (length(dim(x)) != 0L) rownames(x) else names(x) ) setMethod("ROWNAMES", "DataTable", function(x) rownames(x)) setMethod("dimnames", "DataTable", function(x) { list(rownames(x), colnames(x)) }) setReplaceMethod("dimnames", "DataTable", function(x, value) { if (!is.list(value)) stop("replacement value must be a list") rownames(x) <- value[[1L]] colnames(x) <- value[[2L]] x }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Subsetting. ### setMethod("subset", "DataTable", function(x, subset, select, drop = FALSE, ...) { i <- evalqForSubset(subset, x, ...) j <- evalqForSelect(select, x, ...) x[i, j, drop=drop] }) setMethod("na.omit", "DataTable", function(object, ...) { attr(object, "row.names") <- rownames(object) object.omit <- stats:::na.omit.data.frame(object) attr(object.omit, "row.names") <- NULL object.omit }) setMethod("na.exclude", "DataTable", function(object, ...) { attr(object, "row.names") <- rownames(object) object.ex <- stats:::na.exclude.data.frame(object) attr(object.ex, "row.names") <- NULL object.ex }) setMethod("is.na", "DataTable", function(x) { na <- do.call(cbind, lapply(seq(ncol(x)), function(xi) is.na(x[[xi]]))) rownames(na) <- rownames(x) na }) setMethod("complete.cases", "DataTable", function(...) { args <- list(...) if (length(args) == 1) { x <- args[[1L]] rowSums(is.na(x)) == 0 } else complete.cases(args[[1L]]) & do.call(complete.cases, args[-1L]) }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Transforming. ### transform.DataTable <- function(`_data`, ...) { exprs <- as.list(substitute(list(...))[-1L]) if (any(names(exprs) == "")) { stop("all arguments in '...' must be named") } ## elements in '...' can originate from different environments env <- setNames(top_prenv_dots(...), names(exprs)) for (colName in names(exprs)) { # for loop allows inter-arg dependencies `_data`[[colName]] <- safeEval(exprs[[colName]], `_data`, env[[colName]]) } `_data` } setMethod("transform", "DataTable", transform.DataTable) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Combining. ### setMethod("cbind", "DataTable", function(..., deparse.level=1) stop("missing 'cbind' method for DataTable class ", class(list(...)[[1L]]))) setMethod("rbind", "DataTable", function(..., deparse.level=1) stop("missing 'rbind' method for DataTable class ", class(list(...)[[1L]]))) setMethod("cbind2", c("ANY", "DataTable"), function(x, y, ...) { x <- as(x, "DataFrame") cbind(x, y, ...) }) setMethod("cbind2", c("DataTable", "ANY"), function(x, y, ...) { y <- as(y, "DataFrame") cbind(x, y, ...) }) setMethod("cbind2", c("DataTable", "DataTable"), function(x, y, ...) { x <- as(x, "DataFrame") y <- as(y, "DataFrame") cbind(x, y, ...) }) setMethod("rbind2", c("ANY", "DataTable"), function(x, y, ...) { x <- as(x, "DataFrame") rbind(x, y, ...) }) setMethod("rbind2", c("DataTable", "ANY"), function(x, y, ...) { y <- as(y, "DataFrame") rbind(x, y, ...) }) setMethod("rbind2", c("DataTable", "DataTable"), function(x, y, ...) { x <- as(x, "DataFrame") y <- as(y, "DataFrame") rbind(x, y, ...) }) setMethod("merge", c("DataTable", "DataTable"), function(x, y, ...) { as(merge(as(x, "data.frame"), as(y, "data.frame"), ...), class(x)) }) setMethod("merge", c("data.frame", "DataTable"), function(x, y, ...) { as(merge(x, as(y, "data.frame"), ...), class(y)) }) setMethod("merge", c("DataTable", "data.frame"), function(x, y, ...) { as(merge(as(x, "data.frame"), y, ...), class(x)) }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Looping methods. ### .by.data.frame <- by.data.frame # so it will find our generic environment(.by.data.frame) <- topenv() setMethod("by", "DataTable", function(data, INDICES, FUN, ..., simplify = TRUE) { .mc <- mc <- match.call() .mc[[1L]] <- .by.data.frame ans <- eval(.mc, parent.frame()) attr(ans, "call") <- mc ans }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Summary methods. ### ### S3/S4 combo for duplicated.DataTable duplicated.DataTable <- function(x, incomparables=FALSE, fromLast=FALSE, ...) { duplicated(as(x, "data.frame"), incomparables=incomparables, fromLast=fromLast, ...) } setMethod("duplicated", "DataTable", duplicated.DataTable) ### S3/S4 combo for unique.DataTable unique.DataTable <- unique.data.frame setMethod("unique", "DataTable", unique.DataTable) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion ### setGeneric("as.env", function(x, ...) standardGeneric("as.env")) setMethod("as.env", "NULL", function(x, enclos, tform = identity) { new.env(parent=enclos) }) addSelfRef <- function(x, env) { env$.. <- x env } setMethod("as.env", "DataTable", function(x, enclos = parent.frame(2), tform = identity) { env <- new.env(parent = enclos) lapply(colnames(x), function(col) { colFun <- function() { val <- tform(x[[col]]) rm(list=col, envir=env) assign(col, val, env) val } makeActiveBinding(col, colFun, env) }) addSelfRef(x, env) }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### The "show" method. ### setMethod("show", "DataTable", function(object) { nhead <- get_showHeadLines() ntail <- get_showTailLines() nr <- nrow(object) nc <- ncol(object) cat(class(object), " with ", nr, ifelse(nr == 1, " row and ", " rows and "), nc, ifelse(nc == 1, " column\n", " columns\n"), sep = "") if (nr > 0 && nc > 0) { nms <- rownames(object) if (nr < (nhead + ntail + 1L)) { out <- as.matrix(format(as.data.frame( lapply(object, showAsCell), optional = TRUE))) if (!is.null(nms)) rownames(out) <- nms } else { out <- rbind(as.matrix(format(as.data.frame( lapply(object, function(x) showAsCell(head(x, nhead))), optional = TRUE))), rbind(rep.int("...", nc)), as.matrix(format(as.data.frame( lapply(object, function(x) showAsCell(tail(x, ntail))), optional = TRUE)))) rownames(out) <- .rownames(nms, nr, nhead, ntail) } classinfo <- matrix(unlist(lapply(object, function(x) { paste0("<", classNameForDisplay(x)[1], ">") }), use.names = FALSE), nrow = 1, dimnames = list("", colnames(out))) out <- rbind(classinfo, out) print(out, quote = FALSE, right = TRUE) } }) .rownames <- function(nms, nrow, nhead, ntail) { p1 <- ifelse (nhead == 0, 0L, 1L) p2 <- ifelse (ntail == 0, 0L, ntail-1L) s1 <- s2 <- character(0) if (is.null(nms)) { if (nhead > 0) s1 <- paste0(as.character(p1:nhead)) if (ntail > 0) s2 <- paste0(as.character((nrow-p2):nrow)) } else { if (nhead > 0) s1 <- paste0(head(nms, nhead)) if (ntail > 0) s2 <- paste0(tail(nms, ntail)) } c(s1, "...", s2) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Statistical routines ### setMethod("xtabs", signature(data = "DataTable"), function(formula = ~., data, subset, na.action, exclude = c(NA, NaN), drop.unused.levels = FALSE) { data <- as(data, "data.frame") callGeneric() }) setMethod("table", "DataTable", function(...) { table(as.list(cbind(...))) }) ## TODO: lm, glm, loess, ... S4Vectors/R/FilterRules-class.R0000644000175100017510000003446312607264536017342 0ustar00biocbuildbiocbuild### ========================================================================= ### FilterRules objects ### ------------------------------------------------------------------------- setClassUnion("expressionORfunction", c("expression", "function")) setClass("FilterRules", representation(active = "logical"), prototype(elementType = "expressionORfunction"), contains = "SimpleList") ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Accessors. ### setGeneric("active", function(x) standardGeneric("active")) setMethod("active", "FilterRules", function(x) { a <- x@active names(a) <- names(x) a }) setGeneric("active<-", signature="x", function(x, value) standardGeneric("active<-") ) setReplaceMethod("active", "FilterRules", function(x, value) { if (is.numeric(value)) { value <- as.integer(value)[!is.na(value)] if (any(value < 1) || any(value > length(x))) stop("filter index out of range") value <- names(x)[value] } if (is.character(value)) { value <- value[!is.na(value)] ## NA's are dropped filterNames <- names(x) if (length(filterNames) == 0) stop("there are no filter names") if (any(!(value %in% filterNames))) stop("'value' contains invalid filter names") x@active <- filterNames %in% value x } else if (is.logical(value)) { nfilters <- length(x) if (length(value) > nfilters) stop("length of 'value' must not be greater than that of 'filters'") if (S4Vectors:::anyMissing(value)) stop("'value' cannot contain NA's") if (nfilters && (nfilters %% length(value) != 0)) stop("number of filters not a multiple of 'value' length") x@active <- rep(value, length.out = nfilters) x } else stop("unsupported type of 'value'") }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Constructor. ### FilterRules.parseRule <- function(expr) { if (is.character(expr)) { expr <- try(parse(text = expr, srcfile = NULL), silent = TRUE) if (is.character(expr)) stop("failed to parse filter expression: ", expr) expr } else if (is.language(expr) || is.logical(expr)) as.expression(expr) else if (is.function(expr)) as(expr, "FilterClosure") else stop("would not evaluate to logical: ", expr) } ## takes logical expressions, character vectors, or functions to parse FilterRules <- function(exprs = list(), ..., active = TRUE) { exprs <- c(as.list(substitute(list(...)))[-1L], exprs) if (length(names(exprs)) == 0) { funs <- as.logical(sapply(exprs, is.function)) nonfuns <- exprs[!funs] names(nonfuns) <- unlist(lapply(nonfuns, deparse)) chars <- as.logical(sapply(nonfuns, is.character)) names(nonfuns)[chars] <- unlist(nonfuns[chars]) names(exprs)[!funs] <- names(nonfuns) } exprs <- lapply(exprs, FilterRules.parseRule) active <- rep(active, length.out = length(exprs)) if (!is.logical(active) || S4Vectors:::anyMissing(active)) stop("'active' must be logical without any missing values") if (length(active) > length(exprs)) stop("length of 'active' is greater than number of rules") if (length(exprs) && length(exprs) %% length(active) > 0) stop("number of rules must be a multiple of length of 'active'") ans <- S4Vectors:::new_SimpleList_from_list("FilterRules", exprs, active = active) validObject(ans) ans } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Subsetting. ### setReplaceMethod("[[", "FilterRules", function(x, i, j, ..., value) { if (!missing(j) || length(list(...)) > 0) warning("arguments beyond 'i' ignored") if (missing(i)) stop("subscript is missing") rule <- FilterRules.parseRule(value) x <- callNextMethod(x, i, value = rule) if (is.numeric(i) && is.character(value)) names(x)[i] <- value active <- x@active ## in case we expanded names(active) <- names(x)[seq_along(active)] active[[i]] <- TRUE names(active) <- NULL x@active <- active names(x) <- make.names(names(x), unique = TRUE) x }) setMethod("[", "FilterRules", function(x, i, j, ..., drop) { if (!missing(j) || length(list(...)) > 0) stop("invalid subsetting") if (!missing(i)) { x@active <- setNames(setNames(x@active, names(x))[i], NULL) x <- callNextMethod(x, i) } x }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity. ### .valid.FilterRules.active <- function(x) { if (length(active(x)) != length(x)) "length of 'active' must match length of 'filters'" else if (!identical(names(active(x)), names(x))) "names of 'active' must match those of 'filters'" else if (S4Vectors:::anyMissing(active(x))) "'active' cannot contain NA's" else NULL } .valid.FilterRules.rules <- function(x) { unlist(lapply(x, function(rule) { if (is.function(rule) && length(formals(rule)) < 1) "function rule must take at least one parameter" else NULL })) } .valid.FilterRules <- function(x) c(.valid.FilterRules.active(x), .valid.FilterRules.rules(x)) setValidity2("FilterRules", .valid.FilterRules) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Combining ### setMethod("append", c("FilterRules", "FilterRules"), function(x, values, after=length(x)) { if (!isSingleNumber(after)) stop("'after' must be a single number") ans <- FilterRules(append(as.list(x, use.names = TRUE), as.list(values, use.names = TRUE), after = after)) active(ans) <- structure(append(active(x), active(values), after), names = names(ans)) mcols(ans) <- rbind(mcols(x), mcols(values)) ans }) setMethod("c", "FilterRules", function(x, ..., recursive = FALSE) { if (!identical(recursive, FALSE)) stop("\"c\" method for FilterRules objects ", "does not support the 'recursive' argument") if (missing(x)) args <- unname(list(...)) else args <- unname(list(x, ...)) args <- lapply(args, as, "FilterRules") ans <- FilterRules(unlist(lapply(args, function(x) { elts <- as.list(x) names(elts) <- names(x) elts }), recursive = FALSE)) active(ans) <- structure(unlist(lapply(args, active), use.names = FALSE), names = names(ans)) mcols(ans) <- do.call(rbind, lapply(args, mcols)) ans }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Evaluating ### setMethod("eval", signature(expr="FilterRules", envir="ANY"), function(expr, envir = parent.frame(), enclos = if(is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv()) { result <- rep.int(TRUE, NROW(envir)) rules <- as.list(expr)[active(expr)] for (i in seq_along(rules)) { rule <- rules[[i]] if (is.expression(rule)) val <- eval(rule, envir, enclos) else val <- rule(envir) if (is(val, "Rle")) val <- as.vector(val) if (!is.logical(val)) stop("filter rule evaluated to non-logical: ", names(rules)[i]) if ((NROW(envir) == 0L && length(val) > 0L) || (NROW(envir) > 0L && length(val) == 0L) || (NROW(envir) > 0L && (max(NROW(envir), length(val)) %% min(NROW(envir), length(val)) != 0))) stop("filter rule evaluated to inconsistent length: ", names(rule)[i]) if (length(rules) > 1L) envir <- extractROWS(envir, val) result[result] <- val } result }) setGeneric("evalSeparately", function(expr, envir = parent.frame(), enclos = if (is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), ...) standardGeneric("evalSeparately")) setMethod("evalSeparately", "FilterRules", function(expr, envir = parent.frame(), enclos = if (is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), serial = FALSE) { if (!isTRUEorFALSE(serial)) stop("'serial' must be TRUE or FALSE") inds <- seq_len(length(expr)) names(inds) <- names(expr) passed <- rep.int(TRUE, NROW(envir)) m <- do.call(cbind, lapply(inds, function(i) { result <- eval(expr[i], envir = envir, enclos = enclos) if (serial) { envir <<- subset(envir, .(result)) passed[passed] <<- result passed } else result })) FilterMatrix(matrix = m, filterRules = expr) }) setGeneric("subsetByFilter", function(x, filter, ...) standardGeneric("subsetByFilter")) setMethod("subsetByFilter", c("ANY", "FilterRules"), function(x, filter) { extractROWS(x, eval(filter, x)) }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Summary ### setMethod("summary", "FilterRules", function(object, subject, serial = FALSE, discarded = FALSE, percent = FALSE) { if (!isTRUEorFALSE(serial)) stop("'serial' must be TRUE or FALSE") mat <- evalSeparately(object, subject, serial = serial) summary(mat, discarded = discarded, percent = percent) }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### FilterRule closures ### setClass("FilterClosure", contains = "function") setClass("GenericFilterClosure", contains = "FilterClosure") setClass("StandardGenericFilterClosure", contains = c("GenericFilterClosure", "standardGeneric")) setAs("standardGeneric", "FilterClosure", function(from) { new("StandardGenericFilterClosure", from) }) setAs("function", "FilterClosure", function(from) { new("FilterClosure", from) }) setGeneric("params", function(x, ...) standardGeneric("params")) setMethod("params", "FilterClosure", function(x) { as.list(environment(x)) }) setMethod("show", "FilterClosure", function(object) { p <- params(object) cat("filter (", paste(names(p), "=", sapply(p, deparse, control = NULL), collapse = ", "), ")\n", sep = "") print(body(object)) }) ### ------------------------------------------------------------------------- ### FilterMatrix: coordinates results from multiple filters ### .valid.FilterMatrix <- function(object) { c(if (!is.logical(object)) "values must be logical", if (!is.null(names(filterRules))) "filterRules must not be named", if (length(object@filterRules) != ncol(object)) "length(filterRules) must equal ncol(object)") } setClass("FilterMatrix", representation(filterRules = "FilterRules"), contains = "matrix", validity = .valid.FilterMatrix) setGeneric("filterRules", function(x, ...) standardGeneric("filterRules")) setMethod("filterRules", "FilterMatrix", function(x) { setNames(x@filterRules, colnames(x)) }) setMethod("[", "FilterMatrix", function(x, i, j, ..., drop = TRUE) { if (!missing(i)) i <- as.vector(i) if (!missing(j)) j <- as.vector(j) ans <- callNextMethod() if (is.matrix(ans)) { filterRules <- filterRules(x) if (!missing(j)) filterRules <- filterRules[j] ans <- FilterMatrix(matrix = ans, filterRules = filterRules) } ans }) setMethod("rbind", "FilterMatrix", function(..., deparse.level = 1) { ans <- base::rbind(...) args <- list(...) rulesList <- lapply(args, filterRules) if (any(!sapply(rulesList, identical, rulesList[[1]]))) stop("cannot rbind filter matrices with non-identical rule sets") FilterMatrix(matrix = ans, filterRules = rulesList[[1]]) }) setMethod("cbind", "FilterMatrix", function(..., deparse.level = 1) { ans <- base::cbind(...) rules <- do.call(c, lapply(list(...), function(x) x@filterRules)) FilterMatrix(matrix = ans, filterRules = rules) }) FilterMatrix <- function(matrix, filterRules) { stopifnot(ncol(matrix) == length(filterRules)) if (is.null(colnames(matrix))) colnames(matrix) <- names(filterRules) else if (!is.null(names(filterRules)) && !identical(names(filterRules), colnames(matrix))) stop("if names(filterRules) and colnames(matrix) are both not NULL,", " the names must match") names(filterRules) <- NULL new("FilterMatrix", matrix, filterRules = filterRules) } setMethod("show", "FilterMatrix", function(object) { cat(class(object), " (", nrow(object), " x ", ncol(object), ")\n", sep = "") mat <- S4Vectors:::makePrettyMatrixForCompactPrinting(object, function(x) x@.Data) print(mat, quote = FALSE, right = TRUE) }) setMethod("summary", "FilterMatrix", function(object, discarded = FALSE, percent = FALSE) { if (!isTRUEorFALSE(discarded)) stop("'discarded' must be TRUE or FALSE") if (!isTRUEorFALSE(percent)) stop("'percent' must be TRUE or FALSE") counts <- c("" = nrow(object), colSums(object), "" = sum(rowSums(object) == ncol(object))) if (discarded) { counts <- nrow(object) - counts } if (percent) { round(counts / nrow(object), 3) } else counts }) S4Vectors/R/Hits-class.R0000644000175100017510000003675712607264536016021 0ustar00biocbuildbiocbuild### ========================================================================= ### Hits objects ### ------------------------------------------------------------------------- ### setClass("Hits", contains="Vector", representation( queryHits="integer", # integer vector of length N subjectHits="integer", # integer vector of length N queryLength="integer", # single integer subjectLength="integer" # single integer ), prototype( queryLength=0L, subjectLength=0L ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### parallelSlotNames() ### ### Combine the new parallel slots with those of the parent class. Make sure ### to put the new parallel slots *first*. setMethod("parallelSlotNames", "Hits", function(x) c("queryHits", "subjectHits", callNextMethod()) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Accessors ### setGeneric("queryHits", function(x, ...) standardGeneric("queryHits")) setMethod("queryHits", "Hits", function(x) x@queryHits) setGeneric("subjectHits", function(x, ...) standardGeneric("subjectHits")) setMethod("subjectHits", "Hits", function(x) x@subjectHits) setGeneric("queryLength", function(x, ...) standardGeneric("queryLength")) setMethod("queryLength", "Hits", function(x) x@queryLength) setGeneric("subjectLength", function(x, ...) standardGeneric("subjectLength")) setMethod("subjectLength", "Hits", function(x) x@subjectLength) setGeneric("countQueryHits", function(x, ...) standardGeneric("countQueryHits") ) .count_query_hits <- function(x) tabulate(queryHits(x), nbins=queryLength(x)) setMethod("countQueryHits", "Hits", .count_query_hits) setGeneric("countSubjectHits", function(x, ...) standardGeneric("countSubjectHits") ) .count_subject_hits <- function(x) tabulate(subjectHits(x), nbins=subjectLength(x)) setMethod("countSubjectHits", "Hits", .count_subject_hits) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity ### .valid.Hits.queryLength <- function(x) { x_q_len <- queryLength(x) if (!isSingleInteger(x_q_len) || x_q_len < 0L) return("'queryLength(x)' must be a single non-negative integer") if (!is.null(attributes(x_q_len))) return("'queryLength(x)' must be a single integer with no attributes") NULL } .valid.Hits.subjectLength <- function(x) { x_s_len <- subjectLength(x) if (!isSingleInteger(x_s_len) || x_s_len < 0L) return("'subjectLength(x)' must be a single non-negative integer") if (!is.null(attributes(x_s_len))) return("'subjectLength(x)' must be a single integer with no attributes") NULL } .valid.Hits.queryHits_or_subjectHits <- function(q_hits, q_len, what) { if (!(is.integer(q_hits) && is.null(attributes(q_hits)))) { msg <- c("'", what, "Hits(x)' must be an integer vector ", "with no attributes") return(paste(msg, collapse="")) } if (anyMissingOrOutside(q_hits, 1L, q_len)) { msg <- c("'", what, "Hits(x)' must contain non-NA values ", ">= 1 and <= '", what, "Length(x)'") return(paste(msg, collapse="")) } NULL } ### Coercion from Hits to List is very fast because it assumes that the hits ### are already sorted by query. So for a Hits object to be valid we require ### that the hits in it are already sorted by query. .valid.Hits.queryHits_ordering <- function(q_hits) { if (isNotSorted(q_hits)) return("'queryHits(x)' must be sorted") NULL } .valid.Hits.queryHits <- function(x) { x_q_hits <- queryHits(x) x_q_len <- queryLength(x) c(.valid.Hits.queryHits_or_subjectHits(x_q_hits, x_q_len, "query"), .valid.Hits.queryHits_ordering(x_q_hits)) } .valid.Hits.subjectHits <- function(x) { x_s_hits <- subjectHits(x) x_s_len <- subjectLength(x) .valid.Hits.queryHits_or_subjectHits(x_s_hits, x_s_len, "subject") } .valid.Hits <- function(x) { c(.valid.Hits.queryLength(x), .valid.Hits.subjectLength(x), .valid.Hits.queryHits(x), .valid.Hits.subjectHits(x)) } setValidity2("Hits", .valid.Hits) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Constructor ### Hits <- function(queryHits=integer(0), subjectHits=integer(0), queryLength=0L, subjectLength=0L, ...) { if (!(is.numeric(queryHits) && is.numeric(subjectHits))) stop("'queryHits' and 'subjectHits' must be integer vectors") if (!is.integer(queryHits)) queryHits <- as.integer(queryHits) if (!is.integer(subjectHits)) subjectHits <- as.integer(subjectHits) if (!(isSingleNumber(queryLength) && isSingleNumber(subjectLength))) stop("'queryLength' and 'subjectLength' must be single integers") if (!is.integer(queryLength)) queryLength <- as.integer(queryLength) if (!is.integer(subjectLength)) subjectLength <- as.integer(subjectLength) ans_mcols <- DataFrame(...) if (ncol(ans_mcols) != 0L) { revmap_envir <- new.env(parent=emptyenv()) } else { revmap_envir <- NULL } ans <- .Call2("Hits_new", queryHits, subjectHits, queryLength, subjectLength, revmap_envir, PACKAGE="S4Vectors") if (ncol(ans_mcols) != 0L) { if (nrow(ans_mcols) != length(ans)) stop("length of supplied metadata columns ", "must equal number of hits") if (exists("revmap", envir=revmap_envir)) { revmap <- get("revmap", envir=revmap_envir) ans_mcols <- ans_mcols[revmap, , drop=FALSE] } mcols(ans) <- ans_mcols } ans } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion ### setMethod("as.matrix", "Hits", function(x) cbind(queryHits=queryHits(x), subjectHits=subjectHits(x)) ) setMethod("as.table", "Hits", .count_query_hits) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Subsetting ### ### The "extractROWS" method for Vector objects doesn't test the validity of ### the result so we override it. setMethod("extractROWS", "Hits", function(x, i) { ans <- callNextMethod() pbs <- validObject(ans, test=TRUE) if (is.character(pbs)) stop(wmsg("Problem(s) found when testing validity of ", class(ans), " object returned by subsetting operation: ", paste0(pbs, collapse=", "), ". Make sure to use a ", "subscript that results in a valid ", class(ans), " object.")) ans } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Displaying ### .makeNakedMatFromHits <- function(x) { x_len <- length(x) x_mcols <- mcols(x) x_nmc <- if (is.null(x_mcols)) 0L else ncol(x_mcols) ans <- cbind(queryHits=as.character(queryHits(x)), subjectHits=as.character(subjectHits(x))) if (x_nmc > 0L) { tmp <- do.call(data.frame, c(lapply(x_mcols, showAsCell), list(check.names=FALSE))) ans <- cbind(ans, `|`=rep.int("|", x_len), as.matrix(tmp)) } ans } showHits <- function(x, margin="", print.classinfo=FALSE, print.qslengths=FALSE) { x_class <- class(x) x_len <- length(x) x_mcols <- mcols(x) x_nmc <- if (is.null(x_mcols)) 0L else ncol(x_mcols) cat(x_class, " object with ", x_len, " hit", ifelse(x_len == 1L, "", "s"), " and ", x_nmc, " metadata column", ifelse(x_nmc == 1L, "", "s"), ":\n", sep="") out <- makePrettyMatrixForCompactPrinting(x, .makeNakedMatFromHits) if (print.classinfo) { .COL2CLASS <- c( queryHits="integer", subjectHits="integer" ) classinfo <- makeClassinfoRowForCompactPrinting(x, .COL2CLASS) ## A sanity check, but this should never happen! stopifnot(identical(colnames(classinfo), colnames(out))) out <- rbind(classinfo, out) } if (nrow(out) != 0L) rownames(out) <- paste0(margin, rownames(out)) ## We set 'max' to 'length(out)' to avoid the getOption("max.print") ## limit that would typically be reached when 'showHeadLines' global ## option is set to Inf. print(out, quote=FALSE, right=TRUE, max=length(out)) if (print.qslengths) { cat(margin, "-------\n", sep="") cat(margin, "queryLength: ", queryLength(x), "\n", sep="") cat(margin, "subjectLength: ", subjectLength(x), "\n", sep="") } } setMethod("show", "Hits", function(object) showHits(object, margin=" ", print.classinfo=TRUE, print.qslengths=TRUE) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### selectHits() ### selectHits <- function(x, select=c("all", "first", "last", "arbitrary", "count")) { if (!is(x, "Hits")) stop("'x' must be a Hits object") select <- match.arg(select) if (select == "all") return(x) .Call2("select_hits", queryHits(x), subjectHits(x), queryLength(x), select, PACKAGE="S4Vectors") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### revmap() ### ### NOT exported (but used in IRanges). ### TODO: Move revmap() generic from AnnotationDbi to S4Vectors, and make this ### the "revmap" method for Hits objects. ### Note that: ### - If 'x' is a valid Hits object (i.e. the hits in it are sorted by ### query), then 'Hits_revmap(x)' returns a Hits object where hits are ### "fully sorted" i.e. sorted by query first and then by subject. ### - Because Hits_revmap() reorders the hits by query, doing ### 'Hits_revmap(Hits_revmap(x))' brings back 'x' but with the hits in it ### now "fully sorted". Hits_revmap <- function(x) Hits(x@subjectHits, x@queryHits, x@subjectLength, x@queryLength) ### FIXME: Replace this with "revmap" method for Hits objects. setMethod("t", "Hits", Hits_revmap) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Remap the query and/or subject hits ### ### Returns 'arg' as a NULL, an integer vector, or a factor. .normargMap <- function(arg, sidename, old.length) { if (is.null(arg)) return(arg) if (!is.factor(arg)) { if (!is.numeric(arg)) stop("'" , sidename, ".map' must be a vector of integers") if (!is.integer(arg)) arg <- as.integer(arg) } if (length(arg) != old.length) stop("'" , sidename, ".map' must have the length of the ", sidename) arg } .normargNewLength <- function(arg, sidename, map) { if (!isSingleNumberOrNA(arg)) stop("'new.", sidename, "Length' must be a single number or NA") if (!is.integer(arg)) arg <- as.integer(arg) if (is.null(map)) return(arg) if (is.factor(map)) { if (is.na(arg)) return(nlevels(map)) if (arg < nlevels(map)) stop("supplied 'new.", sidename, "Length' must ", "be >= 'nlevels(", sidename, ".map)'") return(arg) } if (is.na(arg)) stop("'new.", sidename, "Length' must be specified when ", "'" , sidename, ".map' is specified and is not a factor") arg } remapHits <- function(x, query.map=NULL, new.queryLength=NA, subject.map=NULL, new.subjectLength=NA, with.counts=FALSE) { if (!is(x, "Hits")) stop("'x' must be a Hits object") query.map <- .normargMap(query.map, "query", queryLength(x)) new.queryLength <- .normargNewLength(new.queryLength, "query", query.map) subject.map <- .normargMap(subject.map, "subject", subjectLength(x)) new.subjectLength <- .normargNewLength(new.subjectLength, "subject", subject.map) if (!isTRUEorFALSE(with.counts)) stop("'with.counts' must be TRUE or FALSE") q_hits <- queryHits(x) if (is.null(query.map)) { if (is.na(new.queryLength)) new.queryLength <- queryLength(x) } else { if (is.factor(query.map)) query.map <- as.integer(query.map) if (anyMissingOrOutside(query.map, 1L, new.queryLength)) stop("'query.map' cannot contain NAs, or values that ", "are < 1, or > 'new.queryLength'") q_hits <- query.map[q_hits] } s_hits <- subjectHits(x) if (is.null(subject.map)) { if (is.na(new.subjectLength)) new.subjectLength <- subjectLength(x) } else { if (is.factor(subject.map)) subject.map <- as.integer(subject.map) if (anyMissingOrOutside(subject.map, 1L, new.subjectLength)) stop("'subject.map' cannot contain NAs, or values that ", "are < 1, or > 'new.subjectLength'") s_hits <- subject.map[s_hits] } x_mcols <- mcols(x) add_counts <- function(counts) { if (is.null(x_mcols)) return(DataFrame(counts=counts)) if ("counts" %in% colnames(x_mcols)) warning("'x' has a \"counts\" metadata column, replacing it") x_mcols$counts <- counts x_mcols } if (is.null(query.map) && is.null(subject.map)) { if (with.counts) { counts <- rep.int(1L, length(x)) x_mcols <- add_counts(counts) } } else { sm <- selfmatchIntegerPairs(q_hits, s_hits) if (with.counts) { counts <- tabulate(sm, nbins=length(sm)) x_mcols <- add_counts(counts) keep_idx <- which(counts != 0L) } else { keep_idx <- which(sm == seq_along(sm)) } q_hits <- q_hits[keep_idx] s_hits <- s_hits[keep_idx] x_mcols <- extractROWS(x_mcols, keep_idx) } do.call(Hits, c(list(q_hits, s_hits, new.queryLength, new.subjectLength), as.list(x_mcols))) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### makeAllGroupInnerHits() ### ### NOT exported. ### About 10x faster and uses 4x less memory than my first attempt in pure ### R below. makeAllGroupInnerHits <- function(group.sizes, hit.type=0L) { if (!is.integer(group.sizes)) stop("'group.sizes' must be an integer vector") if (!isSingleNumber(hit.type)) stop("'hit.type' must be a single integer") if (!is.integer(hit.type)) hit.type <- as.integer(hit.type) .Call2("make_all_group_inner_hits", group.sizes, hit.type, PACKAGE="S4Vectors") } ### TODO: Remove this. makeAllGroupInnerHits.old <- function(GS) { NG <- length(GS) # nb of groups ## First Element In group i.e. first elt associated with each group. FEIG <- cumsum(c(1L, GS[-NG])) GSr <- c(0L, GS[-NG]) CGSr2 <- cumsum(GSr * GSr) GS2 <- GS * GS N <- sum(GS) # length of original vector (i.e. before grouping) ## Original Group Size Assignment i.e. group size associated with each ## element in the original vector. OGSA <- rep.int(GS, GS) # has length N q_hits <- rep.int(seq_len(N), OGSA) NH <- length(q_hits) # same as sum(GS2) ## Hit Group Assignment i.e. group associated with each hit. HGA <- rep.int(seq_len(NG), GS2) ## Hit Group Size Assignment i.e. group size associated with each hit. HGSA <- GS[HGA] s_hits <- (0:(NH-1L) - CGSr2[HGA]) %% GS[HGA] + FEIG[HGA] Hits(q_hits, s_hits, N, N) } S4Vectors/R/Hits-comparison.R0000644000175100017510000000703212607264537017047 0ustar00biocbuildbiocbuild### ========================================================================= ### Comparing and ordering hits ### ------------------------------------------------------------------------- ### .compatible_Hits <- function(x, y) { queryLength(x) == queryLength(y) && subjectLength(x) == subjectLength(y) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### compare() ### ### Hits are ordered by query hit first and then by subject hit. ### This way, the space of hits is totally ordered. ### setMethod("compare", c("Hits", "Hits"), function(x, y) { if (!.compatible_Hits(x, y)) stop("'x' and 'y' are incompatible Hits objects ", "by subject and/or query length") compareIntegerPairs(queryHits(x), subjectHits(x), queryHits(y), subjectHits(y)) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### match() ### setMethod("match", c("Hits", "Hits"), function(x, table, nomatch=NA_integer_, incomparables=NULL, method=c("auto", "quick", "hash")) { if (!.compatible_Hits(x, table)) stop("'x' and 'table' are incompatible Hits objects ", "by subject and/or query length") if (!is.null(incomparables)) stop("\"match\" method for Hits objects ", "only accepts 'incomparables=NULL'") matchIntegerPairs(queryHits(x), subjectHits(x), queryHits(table), subjectHits(table), nomatch=nomatch, method=method) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### selfmatch() ### ### Is this useful? When do we have to deal with duplicated hits in a Hits ### object? Which function return that? Would be good to know the use case. ### If there aren't any (and we don't expect any in the future), maybe we ### should enforce unicity in the validity method for Hits objects. Then ### selfmatch(), duplicated(), and unique() become pointless on Hits objects ### because their output is predictable (and thus they can be implemented ### in a trivial way that is very fast). ### #setMethod("selfmatch", "Hits", # function (x, method=c("auto", "quick", "hash")) # selfmatchIntegerPairs(queryHits(x), subjectHits(x), method=method) #) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Ordering hits ### ### order(), sort(), rank() on Hits objects are consistent with the order ### on hits implied by compare(). ### ### The current implementation doesn't take advantage of the fact that Hits ### objects are already sorted by query hit but maybe a significant speedup ### could be achieved by doing so. ### 'na.last' is pointless (Hits objects don't contain NAs) so is ignored. setMethod("order", "Hits", function(..., na.last=TRUE, decreasing=FALSE) { if (!isTRUEorFALSE(decreasing)) stop("'decreasing' must be TRUE or FALSE") ## All arguments in '...' are guaranteed to be Hits objects. args <- list(...) if (length(args) == 1L) { x <- args[[1L]] return(orderIntegerPairs(queryHits(x), subjectHits(x), decreasing=decreasing)) } order_args <- vector("list", 2L * length(args)) idx <- 2L * seq_along(args) order_args[idx - 1L] <- lapply(args, queryHits) order_args[idx] <- lapply(args, subjectHits) do.call(order, c(order_args, list(decreasing=decreasing))) } ) S4Vectors/R/Hits-setops.R0000644000175100017510000000157412607264536016216 0ustar00biocbuildbiocbuild### ========================================================================= ### Set operations ### ------------------------------------------------------------------------- ### ### union(), intersect(), and setdiff() are endomorphisms with respect to ### their first argument 'x'. ### setMethod("union", c("Hits", "Hits"), function(x, y) { m <- match(y, x) y <- y[is.na(m)] q_hits <- c(queryHits(x), queryHits(y)) s_hits <- c(subjectHits(x), subjectHits(y)) Hits(q_hits, s_hits, queryLength(x), subjectLength(x)) } ) ### Because a Hits object is not expected to contain duplicated we don't ### need to call unique() on the returned object (like base::intersect() ### and base::setdiff() do). setMethod("intersect", c("Hits", "Hits"), function(x, y) x[x %in% y]) setMethod("setdiff", c("Hits", "Hits"), function(x, y) x[!(x %in% y)]) S4Vectors/R/List-class.R0000644000175100017510000005421612607264536016013 0ustar00biocbuildbiocbuild### ========================================================================= ### List objects ### ------------------------------------------------------------------------- ### ### List objects are Vector objects with "[[", "elementType" and ### "elementLengths" methods. ### setClass("List", contains="Vector", representation( "VIRTUAL", elementType="character" ), prototype(elementType="ANY") ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Accessor methods. ### setGeneric("elementType", function(x, ...) standardGeneric("elementType")) setMethod("elementType", "List", function(x) x@elementType) setMethod("elementType", "vector", function(x) storage.mode(x)) setGeneric("elementLengths", function(x) standardGeneric("elementLengths")) setMethod("elementLengths", "ANY", sapply_NROW) setMethod("elementLengths", "List", function(x) { y <- as.list(x) if (length(y) == 0L) { ans <- integer(0) ## We must return a named integer(0) if 'x' is named names(ans) <- names(x) return(ans) } if (length(dim(y[[1L]])) < 2L) return(elementLengths(y)) return(sapply(y, NROW)) } ) setGeneric("isEmpty", function(x) standardGeneric("isEmpty")) setMethod("isEmpty", "ANY", function(x) { if (is.atomic(x)) return(length(x) == 0L) if (!is.list(x) && !is(x, "List")) stop("isEmpty() is not defined for objects of class ", class(x)) ## Recursive definition if (length(x) == 0) return(logical(0)) sapply(x, function(xx) all(isEmpty(xx))) }) ### A List object is considered empty iff all its elements are empty. setMethod("isEmpty", "List", function(x) all(elementLengths(x) == 0L)) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Constructor. ### List <- function(...) { args <- list(...) if (length(args) == 1L && is.list(args[[1L]])) args <- args[[1L]] as(args, "List") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### The "show" method. ### setMethod("show", "List", function(object) { lo <- length(object) cat(classNameForDisplay(object), " of length ", lo, "\n", sep = "") if (!is.null(names(object))) cat(labeledLine("names", names(object))) }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Subsetting. ### ### Assumes 'x' and 'i' are parallel List objects (i.e. same length). ### Returns TRUE iff 'i' contains non-NA positive values that are compatible ### with the shape of 'x'. .is_valid_NL_subscript <- function(i, x) { unlisted_i <- unlist(i, use.names=FALSE) if (!is.integer(unlisted_i)) unlisted_i <- as.integer(unlisted_i) if (anyMissingOrOutside(unlisted_i, lower=1L)) return(FALSE) x_eltlens <- elementLengths(x) i_eltlens <- elementLengths(i) if (any(unlisted_i > rep.int(x_eltlens, i_eltlens))) return(FALSE) return(TRUE) } ### Assumes 'x' and 'i' are parallel List objects (i.e. same length). ### Returns the name of one of the 3 supported fast paths ("LL", "NL", "RL") ### or NA if no fast path can be used. .select_fast_path <- function(i, x) { ## LEPType (List Element Pseudo-Type): same as "elementType" except for ## RleList objects. if (is(i, "RleList")) { i_runvals <- runValue(i) i_LEPType <- elementType(i_runvals) } else { i_LEPType <- elementType(i) } if (extends(i_LEPType, "logical")) { ## 'i' is a List of logical vectors or logical-Rle objects. ## We select the "LL" fast path ("Logical List"). return("LL") } if (extends(i_LEPType, "numeric")) { ## 'i' is a List of numeric vectors or numeric-Rle objects. if (is(i, "RleList")) { i2 <- i_runvals } else { i2 <- i } if (.is_valid_NL_subscript(i2, x)) { ## We select the "NL" fast path ("Number List"). return("NL") } } if (extends(i_LEPType, "Ranges")) { ## 'i' is a List of Ranges objects. ## We select the "RL" fast path ("Ranges List"). return("RL") } return(NA_character_) } ### Assumes 'x' and 'i' are parallel List objects (i.e. same length). ### Truncate or recycle each list element of 'i' to the length of the ### corresponding element in 'x'. .adjust_elt_lengths <- function(i, x) { x_eltlens <- unname(elementLengths(x)) i_eltlens <- unname(elementLengths(i)) idx <- which(x_eltlens != i_eltlens) ## FIXME: This is rough and doesn't follow exactly the truncate-or-recycle ## semantic of normalizeSingleBracketSubscript() on a logical vector or ## logical-Rle object. for (k in idx) i[[k]] <- rep(i[[k]], length.out=x_eltlens[k]) return(i) } ### Assumes 'x' and 'i' are parallel List objects (i.e. same length), ### and 'i' is a List of logical vectors or logical-Rle objects. .unlist_LL_subscript <- function(i, x) { i <- .adjust_elt_lengths(i, x) unlist(i, use.names=FALSE) } ### Assumes 'x' and 'i' are parallel List objects (i.e. same length), ### and 'i' is a List of numeric vectors or numeric-Rle objects. .unlist_NL_subscript <- function(i, x) { offsets <- c(0L, end(PartitioningByEnd(x))[-length(x)]) i <- i + offsets unlist(i, use.names=FALSE) } ### Assumes 'x' and 'i' are parallel List objects (i.e. same length), ### and 'i' is a List of Ranges objects. .unlist_RL_subscript <- function(i, x) { unlisted_i <- unlist(i, use.names=FALSE) offsets <- c(0L, end(PartitioningByEnd(x))[-length(x)]) shift(unlisted_i, shift=rep.int(offsets, elementLengths(i))) } ### Fast subset by List of logical vectors or logical-Rle objects. ### Assumes 'x' and 'i' are parallel List objects (i.e. same length). .fast_subset_List_by_LL <- function(x, i) { ## Unlist 'x' and 'i'. unlisted_x <- unlist(x, use.names=FALSE) unlisted_i <- .unlist_LL_subscript(i, x) ## Subset. unlisted_ans <- extractROWS(unlisted_x, unlisted_i) ## Relist. group <- rep.int(seq_along(x), elementLengths(x)) group <- extractROWS(group, unlisted_i) ans_skeleton <- PartitioningByEnd(group, NG=length(x), names=names(x)) ans <- as(relist(unlisted_ans, ans_skeleton), class(x)) metadata(ans) <- metadata(x) ans } ### Fast subset by List of numeric vectors or numeric-Rle objects. ### Assumes 'x' and 'i' are parallel List objects (i.e. same length). .fast_subset_List_by_NL <- function(x, i) { ## Unlist 'x' and 'i'. unlisted_x <- unlist(x, use.names=FALSE) unlisted_i <- .unlist_NL_subscript(i, x) ## Subset. unlisted_ans <- extractROWS(unlisted_x, unlisted_i) ## Relist. ans_breakpoints <- cumsum(unname(elementLengths(i))) ans_skeleton <- PartitioningByEnd(ans_breakpoints, names=names(x)) ans <- as(relist(unlisted_ans, ans_skeleton), class(x)) metadata(ans) <- metadata(x) ans } ### Fast subset by List of Ranges objects. ### Assumes 'x' and 'i' are parallel List objects (i.e. same length). .fast_subset_List_by_RL <- function(x, i) { ## Unlist 'x' and 'i'. unlisted_x <- unlist(x, use.names=FALSE) unlisted_i <- .unlist_RL_subscript(i, x) ## Subset. unlisted_ans <- extractROWS(unlisted_x, unlisted_i) ## Relist. ans_breakpoints <- cumsum(unlist(sum(width(i)), use.names=FALSE)) ans_skeleton <- PartitioningByEnd(ans_breakpoints, names=names(x)) ans <- as(relist(unlisted_ans, ans_skeleton), class(x)) metadata(ans) <- metadata(x) ans } ### Subset a List object by a list-like subscript. subset_List_by_List <- function(x, i) { li <- length(i) if (is.null(names(i))) { lx <- length(x) if (li > lx) stop("list-like subscript is longer than ", "list-like object to subset") if (li < lx) x <- x[seq_len(li)] } else { if (is.null(names(x))) stop("cannot subscript an unnamed list-like object ", "by a named list-like object") if (!identical(names(i), names(x))) { i2x <- match(names(i), names(x)) if (anyMissing(i2x)) stop("list-like subscript has names not in ", "list-like object to subset") x <- x[i2x] } } ## From here, 'x' and 'i' are guaranteed to have the same length. if (li == 0L) return(x) if (!is(x, "SimpleList")) { ## We'll try to take a fast path. if (is(i, "List")) { fast_path <- .select_fast_path(i, x) } else { i2 <- as(i, "List") i2_elttype <- elementType(i2) if (length(i2) == li && all(sapply(i, is, i2_elttype))) { fast_path <- .select_fast_path(i2, x) if (!is.na(fast_path)) i <- i2 } else { fast_path <- NA_character_ } } if (!is.na(fast_path)) { fast_path_FUN <- switch(fast_path, LL=.fast_subset_List_by_LL, NL=.fast_subset_List_by_NL, RL=.fast_subset_List_by_RL) return(fast_path_FUN(x, i)) # fast path } } ## Slow path (loops over the list elements of 'x'). for (k in seq_len(li)) x[[k]] <- extractROWS(x[[k]], i[[k]]) return(x) } .adjust_value_length <- function(value, i_len) { value_len <- length(value) if (value_len == i_len) return(value) if (i_len %% value_len != 0L) warning("number of values supplied is not a sub-multiple ", "of the number of values to be replaced") rep(value, length.out=i_len) } ### Assumes 'x' and 'i' are parallel List objects (i.e. same length). .fast_lsubset_List_by_List <- function(x, i, value) { ## Unlist 'x', 'i', and 'value'. unlisted_x <- unlist(x, use.names=FALSE) fast_path <- .select_fast_path(i, x) unlist_subscript_FUN <- switch(fast_path, LL=.unlist_LL_subscript, NL=.unlist_NL_subscript, RL=.unlist_RL_subscript) unlisted_i <- unlist_subscript_FUN(i, x) if (length(value) != 1L) { value <- .adjust_value_length(value, length(i)) value <- .adjust_elt_lengths(value, i) } unlisted_value <- unlist(value, use.names=FALSE) ## Subset. unlisted_ans <- replaceROWS(unlisted_x, unlisted_i, unlisted_value) ## Relist. ans <- as(relist(unlisted_ans, x), class(x)) metadata(ans) <- metadata(x) ans } lsubset_List_by_List <- function(x, i, value) { lx <- length(x) li <- length(i) if (li == 0L) { ## Surprisingly, in that case, `[<-` on standard vectors does not ## even look at 'value'. So neither do we... return(x) } lv <- length(value) if (lv == 0L) stop("replacement has length zero") value <- normalizeSingleBracketReplacementValue(value, x) if (is.null(names(i))) { if (li != lx) stop("when list-like subscript is unnamed, it must have the ", "length of list-like object to subset") if (!is(x, "SimpleList")) { ## We'll try to take a fast path. if (is(i, "List")) { fast_path <- .select_fast_path(i, x) } else { i2 <- as(i, "List") i2_elttype <- elementType(i2) if (length(i2) == li && all(sapply(i, is, i2_elttype))) { fast_path <- .select_fast_path(i2, x) if (!is.na(fast_path)) i <- i2 } else { fast_path <- NA_character_ } } if (!is.na(fast_path)) return(.fast_lsubset_List_by_List(x, i, value)) # fast path } i2x <- seq_len(li) } else { if (is.null(names(x))) stop("cannot subset an unnamed list-like object ", "by a named list-like subscript") i2x <- match(names(i), names(x)) if (anyMissing(i2x)) stop("list-like subscript has names not in ", "list-like object to subset") if (anyDuplicated(i2x)) stop("list-like subscript has duplicated names") } value <- .adjust_value_length(value, li) ## Slow path (loops over the list elements of 'x'). for (k in seq_len(li)) x[[i2x[k]]] <- replaceROWS(x[[i2x[k]]], i[[k]], value[[k]]) return(x) } setMethod("[", "List", function(x, i, j, ..., drop=TRUE) { if (!missing(j) || length(list(...)) > 0L) stop("invalid subsetting") if (missing(i)) return(x) if (is.list(i) || (is(i, "List") && !is(i, "Ranges"))) return(subset_List_by_List(x, i)) callNextMethod(x, i) } ) setReplaceMethod("[", "List", function(x, i, j, ..., value) { if (!missing(j) || length(list(...)) > 0L) stop("invalid subsetting") if (!missing(i) && (is.list(i) || (is(i, "List") && !is(i, "Ranges")))) return(lsubset_List_by_List(x, i, value)) callNextMethod(x, i, value=value) } ) setMethod("[[", "List", function(x, i, j, ...) { dotArgs <- list(...) if (length(dotArgs) > 0L) dotArgs <- dotArgs[names(dotArgs) != "exact"] if (!missing(j) || length(dotArgs) > 0L) stop("incorrect number of subscripts") ## '...' is either empty or contains only the 'exact' arg. getListElement(x, i, ...) } ) setMethod("$", "List", function(x, name) x[[name, exact=FALSE]]) setReplaceMethod("[[", "List", function(x, i, j, ..., value) { if (!missing(j) || length(list(...)) > 0) stop("invalid replacement") origLen <- length(x) x <- setListElement(x, i, value) if (origLen < length(x)) x <- rbindRowOfNAsToMetadatacols(x) x }) setReplaceMethod("$", "List", function(x, name, value) { x[[name]] <- value x }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Simple helper functions for some common subsetting operations. ### ### TODO: Move to List-utils.R (Looping methods section). ### ### phead() and ptail(): "parallel" versions of head() and tail() for List ### objects. They're just fast equivalents of 'mapply(head, x, n)' and ### 'mapply(tail, x, n)', respectively. .normarg_n <- function(n, x_eltlens) { if (!is.numeric(n)) stop("'n' must be an integer vector") if (!is.integer(n)) n <- as.integer(n) if (any(is.na(n))) stop("'n' cannot contain NAs") n <- pmin(x_eltlens, n) neg_idx <- which(n < 0L) if (length(neg_idx) != 0L) n[neg_idx] <- pmax(n[neg_idx] + x_eltlens[neg_idx], 0L) n } phead <- function(x, n=6L) { x_eltlens <- unname(elementLengths(x)) n <- .normarg_n(n, x_eltlens) unlisted_i <- IRanges(start=rep.int(1L, length(n)), width=n) i <- relist(unlisted_i, PartitioningByEnd(seq_along(x))) ans <- x[i] mcols(ans) <- mcols(x) ans } ptail <- function(x, n=6L) { x_eltlens <- unname(elementLengths(x)) n <- .normarg_n(n, x_eltlens) unlisted_i <- IRanges(end=x_eltlens, width=n) i <- relist(unlisted_i, PartitioningByEnd(seq_along(x))) ans <- x[i] mcols(ans) <- mcols(x) ans } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion. ### setAs("List", "list", function(from) as.list(from)) .as.list.List <- function(x, use.names=TRUE) { if (!isTRUEorFALSE(use.names)) stop("'use.names' must be TRUE or FALSE") ans <- lapply(x, identity) if (!use.names) names(ans) <- NULL ans } ### S3/S4 combo for as.list.List as.list.List <- function(x, ...) .as.list.List(x, ...) setMethod("as.list", "List", as.list.List) setMethod("as.env", "List", function(x, enclos = parent.frame(2), tform = identity) { nms <- names(x) if (is.null(nms)) stop("cannot convert to environment when names are NULL") env <- new.env(parent = enclos) lapply(nms, function(col) { colFun <- function() { val <- tform(x[[col]]) rm(list=col, envir=env) assign(col, val, env) val } makeActiveBinding(col, colFun, env) }) env }) listClassName <- function(impl, element.type) { if (is.null(impl)) impl <- "" listClass <- paste0(impl, "List") if (!is.null(element.type)) { cl <- c(element.type, names(getClass(element.type)@contains)) cl <- capitalize(cl) listClass <- c(paste0(cl, "List"), paste0(cl, "Set"), paste0(impl, cl, "List"), listClass) } clExists <- which(sapply(listClass, isClass) & sapply(listClass, extends, paste0(impl, "List"))) listClass[[clExists[[1L]]]] } setAs("ANY", "List", function(from) { ## since list is directed to SimpleList, we assume 'from' is non-list-like relist(from, PartitioningByEnd(seq_along(from), names=names(from))) }) ## Special cased, because integer extends ANY (somehow) and numeric, ## so ambiguities are introduced due to method caching. setAs("integer", "List", getMethod(coerce, c("ANY", "List"))) ### NOT exported. Assumes 'names1' is not NULL. make_unlist_result_names <- function(names1, names2) { if (is.null(names2)) return(names1) idx2 <- names2 != "" | is.na(names2) idx1 <- names1 != "" | is.na(names1) idx <- idx1 & idx2 if (any(idx)) names1[idx] <- paste(names1[idx], names2[idx], sep = ".") idx <- !idx1 & idx2 if (any(idx)) names1[idx] <- names2[idx] names1 } setMethod("unlist", "List", function(x, recursive=TRUE, use.names=TRUE) { if (!identical(recursive, TRUE)) stop("\"unlist\" method for List objects ", "does not support the 'recursive' argument") if (!isTRUEorFALSE(use.names)) stop("'use.names' must be TRUE or FALSE") if (length(x) == 0L) return(NULL) x_names <- names(x) if (!is.null(x_names)) names(x) <- NULL xx <- as.list(x) if (length(dim(xx[[1L]])) < 2L) { ans <- do.call(c, xx) ans_names0 <- names(ans) if (use.names) { if (!is.null(x_names)) { ans_names <- rep.int(x_names, elementLengths(x)) ans_names <- make_unlist_result_names(ans_names, ans_names0) try_result <- try(names(ans) <- ans_names, silent=TRUE) if (inherits(try_result, "try-error")) warning("failed to set names on the result ", "of unlisting a ", class(x), " object") } } else { ## This is consistent with base::unlist but is not consistent ## with unlist,CompressedList. See comments and FIXME note in ## the unlist,CompressedList code for more details. if (!is.null(ans_names0)) names(ans) <- NULL } } else { ans <- do.call(rbind, xx) if (!use.names) rownames(ans) <- NULL } ans } ) ### S3/S4 combo for as.data.frame.List as.data.frame.List <- function(x, row.names=NULL, optional=FALSE, ..., value.name="value", use.outer.mcols=FALSE, group_name.as.factor=FALSE) { if (!requireNamespace("IRanges", quietly=TRUE)) stop("Couldn't load the IRanges package. You need to install ", "the IRanges\n package to coerce a List object to data.frame.") if (!length(IRanges::togroup(x))) return(data.frame()) if (!isSingleString(value.name)) stop("'value.name' must be a single string") if (!isTRUEorFALSE(use.outer.mcols)) stop("'use.outer.mcols' must be TRUE or FALSE") if (!isTRUEorFALSE(group_name.as.factor)) stop("'group_name.as.factor' must be TRUE or FALSE") if (!(is.null(row.names) || is.character(row.names))) stop("'row.names' must be NULL or a character vector") if (!length(group_name <- names(x)[IRanges::togroup(x)])) group_name <- NA_character_ if (group_name.as.factor) group_name <- factor(group_name, levels=unique(group_name)) xx <- cbind(data.frame(group=IRanges::togroup(x), group_name, stringsAsFactors=FALSE), as.data.frame(unlist(x, use.names=FALSE), row.names=row.names, optional=optional, ...)) if (ncol(xx) == 3) colnames(xx)[3] <- value.name if (use.outer.mcols) if (length(md <- mcols(x)[IRanges::togroup(x), , drop=FALSE])) return(cbind(xx, md)) xx } setMethod("as.data.frame", "List", as.data.frame.List) setAs("List", "data.frame", function(from) as.data.frame(from)) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Element-wise appending for list-like objects ### ### TODO: Move to List-utils.R (Looping methods section). ### pc <- function(...) { args <- list(...) args <- Filter(Negate(is.null), args) if (length(args) <= 1L) { return(args[[1L]]) } if (length(unique(elementLengths(args))) > 1L) { stop("All arguments in '...' must have the same length") } ans_unlisted <- do.call(c, lapply(args, unlist, use.names=FALSE)) ans_group <- structure(do.call(c, lapply(args, togroup)), class="factor", levels=as.character(seq_along(args[[1L]]))) ans <- splitAsList(ans_unlisted, ans_group) names(ans) <- names(args[[1L]]) ans } S4Vectors/R/List-utils.R0000644000175100017510000001637112607264536016046 0ustar00biocbuildbiocbuild### ========================================================================= ### Common operations on List objects ### ------------------------------------------------------------------------- ### ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Looping on List objects ### setMethod("lapply", "List", function(X, FUN, ...) { FUN <- match.fun(FUN) ii <- seq_len(length(X)) names(ii) <- names(X) lapply(ii, function(i) FUN(X[[i]], ...)) }) .sapplyDefault <- base::sapply environment(.sapplyDefault) <- topenv() setMethod("sapply", "List", .sapplyDefault) setGeneric("endoapply", signature = "X", function(X, FUN, ...) standardGeneric("endoapply")) setMethod("endoapply", "list", function(X, FUN, ...) lapply(X = X, FUN = match.fun(FUN), ...)) setMethod("endoapply", "data.frame", function(X, FUN, ...) as.data.frame(lapply(X = X, FUN = match.fun(FUN), ...))) setMethod("endoapply", "List", function(X, FUN, ...) { elementTypeX <- elementType(X) FUN <- match.fun(FUN) for (i in seq_len(length(X))) { elt <- FUN(X[[i]], ...) if (!extends(class(elt), elementTypeX)) stop("'FUN' must return elements of class ", elementTypeX) X[[i]] <- elt } X }) setGeneric("mendoapply", signature = "...", function(FUN, ..., MoreArgs = NULL) standardGeneric("mendoapply")) setMethod("mendoapply", "list", function(FUN, ..., MoreArgs = NULL) mapply(FUN = FUN, ..., MoreArgs = MoreArgs, SIMPLIFY = FALSE)) setMethod("mendoapply", "data.frame", function(FUN, ..., MoreArgs = NULL) as.data.frame(mapply(FUN = match.fun(FUN), ..., MoreArgs = MoreArgs, SIMPLIFY = FALSE))) setMethod("mendoapply", "List", function(FUN, ..., MoreArgs = NULL) { X <- list(...)[[1L]] elementTypeX <- elementType(X) FUN <- match.fun(FUN) listData <- mapply(FUN = FUN, ..., MoreArgs = MoreArgs, SIMPLIFY = FALSE) for (i in seq_len(length(listData))) { if (!extends(class(listData[[i]]), elementTypeX)) stop("'FUN' must return elements of class ", elementTypeX) X[[i]] <- listData[[i]] } X }) setGeneric("revElements", signature="x", function(x, i) standardGeneric("revElements") ) ### These 2 methods explain the concept of revElements() but they are not ### efficient because they loop over the elements of 'x[i]'. ### There is a fast method for CompressedList objects though. setMethod("revElements", "list", function(x, i) { x[i] <- lapply(x[i], function(xx) extractROWS(xx, rev(seq_len(NROW(xx))))) x } ) setMethod("revElements", "List", function(x, i) { x[i] <- endoapply(x[i], function(xx) extractROWS(xx, rev(seq_len(NROW(xx))))) x } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Functional programming methods ### #.ReduceDefault <- base::Reduce #environment(.ReduceDefault) <- topenv() .ReduceDefault <- function(f, x, init, right = FALSE, accumulate = FALSE) { mis <- missing(init) len <- length(x) if (len == 0L) return(if (mis) NULL else init) f <- match.fun(f) # if (!is.vector(x) || is.object(x)) # x <- as.list(x) ind <- seq_len(len) if (mis) { if (right) { init <- x[[len]] ind <- ind[-len] } else { init <- x[[1L]] ind <- ind[-1L] } } if (!accumulate) { if (right) { for (i in rev(ind)) init <- f(x[[i]], init) } else { for (i in ind) init <- f(init, x[[i]]) } init } else { len <- length(ind) + 1L out <- vector("list", len) if (mis) { if (right) { out[[len]] <- init for (i in rev(ind)) { init <- f(x[[i]], init) out[[i]] <- init } } else { out[[1L]] <- init for (i in ind) { init <- f(init, x[[i]]) out[[i]] <- init } } } else { if (right) { out[[len]] <- init for (i in rev(ind)) { init <- f(x[[i]], init) out[[i]] <- init } } else { for (i in ind) { out[[i]] <- init init <- f(init, x[[i]]) } out[[len]] <- init } } if (all(sapply(out, length) == 1L)) out <- unlist(out, recursive = FALSE) out } } setMethod("Reduce", "List", .ReduceDefault) .FilterDefault <- base::Filter environment(.FilterDefault) <- topenv() setMethod("Filter", "List", .FilterDefault) .FindDefault <- base::Find environment(.FindDefault) <- topenv() setMethod("Find", "List", .FindDefault) .MapDefault <- base::Map environment(.MapDefault) <- topenv() setMethod("Map", "List", .MapDefault) setMethod("Position", "List", function(f, x, right = FALSE, nomatch = NA_integer_) { ## In R-2.12, base::Position() was modified to use seq_along() ## internally. The problem is that seq_along() was a primitive ## that would let the user define methods for it (otherwise it ## would have been worth defining a "seq_along" method for Vector ## objects). So we need to redefine seq_along() locally in order ## to make base_Position() work. seq_along <- function(along.with) seq_len(length(along.with)) base_Position <- base::Position environment(base_Position) <- environment() base_Position(f, x, right = right, nomatch = nomatch) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Evaluating. ### setMethod("within", "List", function(data, expr, ...) { ## cannot use active bindings here, as they break for replacement e <- list2env(as.list(data)) ##e <- as.env(data) safeEval(substitute(expr), e, top_prenv(expr)) l <- mget(ls(e), e) l <- l[!sapply(l, is.null)] nD <- length(del <- setdiff(names(data), (nl <- names(l)))) for (nm in nl) data[[nm]] <- l[[nm]] for (nm in del) data[[nm]] <- NULL data }) setMethod("do.call", c("ANY", "List"), function (what, args, quote = FALSE, envir = parent.frame()) { args <- as.list(args) callGeneric() }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Factors. ### droplevels.List <- function(x, except = NULL) { ix <- vapply(x, Has(levels), logical(1L)) ix[except] <- FALSE x[ix] <- lapply(x[ix], droplevels) x } setMethod("droplevels", "List", droplevels.List) S4Vectors/R/Rle-class.R0000644000175100017510000006640012607264537015621 0ustar00biocbuildbiocbuild### ========================================================================= ### Rle objects ### ------------------------------------------------------------------------- ### ### Class definitions ### setClass("Rle", representation(values = "vectorORfactor", lengths = "integer"), prototype = prototype(values = logical()), contains = "Vector", validity = function(object) { msg <- NULL run_values <- runValue(object) run_lengths <- runLength(object) if (length(run_values) != length(run_lengths)) msg <- c(msg, "run values and run lengths must have the same length") if (!all(run_lengths > 0L)) msg <- c(msg, "all run lengths must be positive") ## TODO: Fix the following test. #if (length(run_lengths) >= 2 && is.atomic(run_values) # && any(run_values[-1L] == run_values[-length(run_values)])) # msg <- c(msg, "consecutive runs must have different values") if (is.null(msg)) TRUE else msg }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Accessor methods. ### setGeneric("runLength", signature = "x", function(x) standardGeneric("runLength")) setMethod("runLength", "Rle", function(x) x@lengths) setGeneric("runValue", signature = "x", function(x) standardGeneric("runValue")) setMethod("runValue", "Rle", function(x) x@values) setGeneric("nrun", signature = "x", function(x) standardGeneric("nrun")) setMethod("nrun", "Rle", function(x) length(runLength(x))) setMethod("start", "Rle", function(x) .Call2("Rle_start", x, PACKAGE="S4Vectors")) setMethod("end", "Rle", function(x) .Call2("Rle_end", x, PACKAGE="S4Vectors")) setMethod("width", "Rle", function(x) runLength(x)) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Replace methods. ### setGeneric("runLength<-", signature="x", function(x, value) standardGeneric("runLength<-")) setReplaceMethod("runLength", "Rle", function(x, value) Rle(values = runValue(x), lengths = value)) setGeneric("runValue<-", signature="x", function(x, value) standardGeneric("runValue<-")) setReplaceMethod("runValue", "Rle", function(x, value) Rle(values = value, lengths = runLength(x))) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Constructors ### setGeneric("Rle", signature = c("values", "lengths"), function(values, lengths, ...) standardGeneric("Rle")) setMethod("Rle", signature = c(values = "missing", lengths = "missing"), function(values, lengths) new2("Rle", values = vector(), lengths = integer(), check=FALSE)) setMethod("Rle", signature = c(values = "vectorORfactor", lengths = "missing"), function(values, lengths) Rle(values, integer(0), check = FALSE)) setMethod("Rle", signature = c(values = "vectorORfactor", lengths = "integer"), function(values, lengths, check = TRUE) { if (!isTRUEorFALSE(check)) stop("'check' must be TRUE or FALSE") ans <- .Call2("Rle_constructor", values, lengths, check, 0L, PACKAGE="S4Vectors") if (is.factor(values)) { ans@values <- factor(ans@values, levels = seq_len(length(levels(values))), labels = levels(values)) } ans }) setMethod("Rle", signature = c(values = "vectorORfactor", lengths = "numeric"), function(values, lengths, check = TRUE) Rle(values = values, lengths = as.integer(lengths), check = check)) setMethod("Rle", signature = c(values = "Rle", lengths = "missing"), function(values, lengths, check = TRUE) values) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion ### setAs("vector", "Rle", function(from) Rle(from)) setAs("logical", "Rle", function(from) Rle(from)) setAs("integer", "Rle", function(from) Rle(from)) setAs("numeric", "Rle", function(from) Rle(from)) setAs("complex", "Rle", function(from) Rle(from)) setAs("character", "Rle", function(from) Rle(from)) setAs("raw", "Rle", function(from) Rle(from)) setAs("factor", "Rle", function(from) Rle(from)) setAs("Rle", "vector", function(from) as.vector(from)) setAs("Rle", "logical", function(from) as.logical(from)) setAs("Rle", "integer", function(from) as.integer(from)) setAs("Rle", "numeric", function(from) as.numeric(from)) setAs("Rle", "complex", function(from) as.complex(from)) setAs("Rle", "character", function(from) as.character(from)) setAs("Rle", "raw", function(from) as.raw(from)) setAs("Rle", "factor", function(from) as.factor(from)) setAs("Rle", "list", function(from) as.list(from)) setAs("Rle", "data.frame", function(from) as.data.frame(from)) as.vector.Rle <- function(x, mode) rep.int(as.vector(runValue(x), mode), runLength(x)) setMethod("as.vector", "Rle", as.vector.Rle) setMethod("as.factor", "Rle", function(x) rep.int(as.factor(runValue(x)), runLength(x))) asFactorOrFactorRle <- function(x) { if (is(x, "Rle")) { runValue(x) <- as.factor(runValue(x)) x } else { as.factor(x) } } ### S3/S4 combo for as.list.Rle .as.list.Rle <- function(x) as.list(as.vector(x)) as.list.Rle <- function(x, ...) .as.list.Rle(x, ...) setMethod("as.list", "Rle", as.list.Rle) decodeRle <- function(x) rep.int(runValue(x), runLength(x)) ### S3/S4 combo for as.data.frame.Rle as.data.frame.Rle <- function(x, row.names=NULL, optional=FALSE, ...) { value <- decodeRle(x) as.data.frame(value, row.names=row.names, optional=optional, ...) } setMethod("as.data.frame", "Rle", as.data.frame.Rle) getStartEndRunAndOffset <- function(x, start, end) { .Call2("Rle_getStartEndRunAndOffset", x, start, end, PACKAGE="S4Vectors") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### General methods ### setMethod("extractROWS", "Rle", function(x, i) { ## FIXME: Right now, the subscript 'i' is turned into an IRanges ## object so we need stuff that lives in the IRanges package for this ## to work. This is ugly/hacky and needs to be fixed (thru a redesign ## of this method). if (!requireNamespace("IRanges", quietly=TRUE)) stop("Couldn't load the IRanges package. You need to install ", "the IRanges\n package in order to subset an Rle object.") i <- normalizeSingleBracketSubscript(i, x, as.NSBS=TRUE) ## TODO: Maybe make this the coercion method from NSBS to Ranges. if (is(i, "RangesNSBS")) { ir <- i@subscript } else { ir <- as(as.integer(i), "IRanges") } ## Rle_seqselect .Call entry point will segfault if 'ir' contains ## empty ranges! ir <- ir[width(ir) != 0L] ansList <- .Call2("Rle_seqselect", x, start(ir), width(ir), PACKAGE="S4Vectors") ans_values <- ansList[["values"]] ans_lengths <- ansList[["lengths"]] if (is.factor(runValue(x))) attributes(ans_values) <- list(levels=levels(x), class="factor") ans <- Rle(ans_values, ans_lengths) ans <- as(ans, class(x)) mcols(ans) <- extractROWS(mcols(ans), i) ans } ) setMethod("[", "Rle", function(x, i, j, ..., drop=getOption("dropRle", default=FALSE)) { if (!missing(j) || length(list(...)) > 0) stop("invalid subsetting") if (!missing(i)) x <- extractROWS(x, i) if (drop) x <- decodeRle(x) x } ) setMethod("replaceROWS", "Rle", function(x, i, value) { ## FIXME: Right now, the subscript 'i' is turned into an IRanges ## object so we need stuff that lives in the IRanges package for this ## to work. This is ugly/hacky and needs to be fixed (thru a redesign ## of this method). if (!requireNamespace("IRanges", quietly=TRUE)) stop("Couldn't load the IRanges package. You need to install ", "the IRanges\n package in order to replace values in ", "an Rle object.") i <- normalizeSingleBracketSubscript(i, x, as.NSBS=TRUE) lv <- length(value) if (lv != 1L) return(Rle(replaceROWS(decodeRle(x), i, as.vector(value)))) ## From here, 'value' is guaranteed to be of length 1. ## TODO: Maybe make this the coercion method from NSBS to Ranges. if (is(i, "RangesNSBS")) { ir <- i@subscript } else { ir <- as(as.integer(i), "IRanges") } ir <- IRanges::reduce(ir) if (length(ir) == 0L) return(x) isFactorRle <- is.factor(runValue(x)) value <- normalizeSingleBracketReplacementValue(value, x) value <- as.vector(value) if (isFactorRle) { value <- factor(value, levels=levels(x)) dummy_value <- factor(levels(x), levels=levels(x)) } if (anyMissingOrOutside(start(ir), 1L, length(x)) || anyMissingOrOutside(end(ir), 1L, length(x))) stop("some ranges are out of bounds") valueWidths <- width(ir) ir <- IRanges::gaps(ir, start=1, end=length(x)) k <- length(ir) start <- start(ir) end <- end(ir) info <- getStartEndRunAndOffset(x, start, end) runStart <- info[["start"]][["run"]] offsetStart <- info[["start"]][["offset"]] runEnd <- info[["end"]][["run"]] offsetEnd <- info[["end"]][["offset"]] if ((length(ir) == 0L) || (start(ir)[1L] != 1L)) { k <- k + 1L runStart <- c(1L, runStart) offsetStart <- c(0L, offsetStart) runEnd <- c(0L, runEnd) offsetEnd <- c(0L, offsetEnd) } if ((length(ir) > 0L) && (end(ir[length(ir)]) != length(x))) { k <- k + 1L runStart <- c(runStart, 1L) offsetStart <- c(offsetStart, 0L) runEnd <- c(runEnd, 0L) offsetEnd <- c(offsetEnd, 0L) } subseqs <- vector("list", length(valueWidths) + k) if (k > 0L) { if (isFactorRle) { subseqs[seq(1L, length(subseqs), by=2L)] <- lapply(seq_len(k), function(i) { ans <- .Call2("Rle_window_aslist", x, runStart[i], runEnd[i], offsetStart[i], offsetEnd[i], PACKAGE="S4Vectors") ans[["values"]] <- dummy_value[ans[["values"]]] ans}) } else { subseqs[seq(1L, length(subseqs), by=2L)] <- lapply(seq_len(k), function(i) .Call2("Rle_window_aslist", x, runStart[i], runEnd[i], offsetStart[i], offsetEnd[i], PACKAGE="S4Vectors")) } } if (length(valueWidths) > 0L) { subseqs[seq(2L, length(subseqs), by=2L)] <- lapply(seq_len(length(valueWidths)), function(i) list(values=value, lengths=valueWidths[i])) } values <- unlist(lapply(subseqs, "[[", "values")) if (isFactorRle) values <- dummy_value[values] Rle(values=values, lengths=unlist(lapply(subseqs, "[[", "lengths"))) } ) setReplaceMethod("[", "Rle", function(x, i, j,..., value) { if (!missing(j) || length(list(...)) > 0L) stop("invalid subsetting") i <- normalizeSingleBracketSubscript(i, x, as.NSBS=TRUE) li <- length(i) if (li == 0L) { ## Surprisingly, in that case, `[<-` on standard vectors does not ## even look at 'value'. So neither do we... return(x) } lv <- length(value) if (lv == 0L) stop("replacement has length zero") replaceROWS(x, i, value) } ) setMethod("%in%", "Rle", function(x, table) Rle(values = runValue(x) %in% table, lengths = runLength(x), check = FALSE)) setMethod("c", "Rle", function(x, ..., recursive = FALSE) { if (!identical(recursive, FALSE)) stop("\"c\" method for Rle objects ", "does not support the 'recursive' argument") args <- lapply(unname(list(x, ...)), Rle) args <- args[sapply(args, length) > 0] if (length(args) == 0L) return(x) ans_values <- unlist(lapply(args, slot, "values")) ans_lengths <- unlist(lapply(args, slot, "lengths")) Rle(ans_values, ans_lengths) }) setGeneric("findRun", signature = "vec", function(x, vec) standardGeneric("findRun")) setMethod("findRun", signature = c(vec = "Rle"), function(x, vec) { runs <- findIntervalAndStartFromWidth(as.integer(x), runLength(vec))[["interval"]] runs[x == 0 | x > length(vec)] <- NA runs }) setMethod("is.na", "Rle", function(x) Rle(values = is.na(runValue(x)), lengths = runLength(x), check = FALSE)) setMethod("anyNA", "Rle", function(x) anyNA(runValue(x))) setMethod("is.unsorted", "Rle", function(x, na.rm = FALSE, strictly = FALSE) { ans <- is.unsorted(runValue(x), na.rm = na.rm, strictly = strictly) if (strictly && !ans) ans <- any(runLength(x) > 1L) ans }) setMethod("length", "Rle", function(x) sum(runLength(x))) setMethod("match", c("ANY", "Rle"), function(x, table, nomatch=NA_integer_, incomparables=NULL) { table_run_starts <- start(table) table <- runValue(table) m <- callGeneric() table_run_starts[m] } ) setMethod("match", c("Rle", "ANY"), function(x, table, nomatch=NA_integer_, incomparables=NULL) { x_run_lens <- runLength(x) x <- runValue(x) m <- callGeneric() Rle(m, x_run_lens) } ) setMethod("match", c("Rle", "Rle"), function(x, table, nomatch=NA_integer_, incomparables=NULL) { x_run_lens <- runLength(x) x <- runValue(x) m <- callGeneric() Rle(m, x_run_lens) } ) setMethod("rep", "Rle", function(x, times, length.out, each) { usedEach <- FALSE if (!missing(each) && length(each) > 0) { each <- as.integer(each[1L]) if (!is.na(each)) { if (each < 0) stop("invalid 'each' argument") usedEach <- TRUE if (each == 0) x <- new(class(x), values = runValue(x)[0L]) else x@lengths <- each[1L] * runLength(x) } } if (!missing(length.out) && length(length.out) > 0) { n <- length(x) length.out <- as.integer(length.out[1L]) if (!is.na(length.out)) { if (length.out == 0) { x <- new(class(x), values = runValue(x)[0L]) } else if (length.out < n) { x <- window(x, 1, length.out) } else if (length.out > n) { if (n == 0) { x <- Rle(rep(runValue(x), length.out=1), length.out) } else { x <- window(rep.int(x, ceiling(length.out / n)), 1, length.out) } } } } else if (!missing(times)) { if (usedEach && length(times) != 1) stop("invalid 'times' argument") x <- rep.int(x, times) } x }) setMethod("rep.int", "Rle", function(x, times) { n <- length(x) if (!is.integer(times)) times <- as.integer(times) if ((length(times) > 1 && length(times) < n) || anyMissingOrOutside(times, 0L)) stop("invalid 'times' argument") if (length(times) == n) { runLength(x) <- diffWithInitialZero(cumsum(times)[end(x)]) } else if (length(times) == 1) { times <- as.vector(times) x <- Rle(values = rep.int(runValue(x), times), lengths = rep.int(runLength(x), times)) } x }) ### S3/S4 combo for rev.Rle rev.Rle <- function(x) { x@values <- rev(runValue(x)) x@lengths <- rev(runLength(x)) x } setMethod("rev", "Rle", rev.Rle) setGeneric("shiftApply", signature = c("X", "Y"), function(SHIFT, X, Y, FUN, ..., OFFSET = 0L, simplify = TRUE, verbose = FALSE) standardGeneric("shiftApply")) setMethod("shiftApply", signature(X = "Rle", Y = "Rle"), function(SHIFT, X, Y, FUN, ..., OFFSET = 0L, simplify = TRUE, verbose = FALSE) { FUN <- match.fun(FUN) N <- length(X) if (N != length(Y)) stop("'X' and 'Y' must be of equal length") if (!is.integer(SHIFT)) SHIFT <- as.integer(SHIFT) if (length(SHIFT) == 0 || anyMissingOrOutside(SHIFT, 0L)) stop("all 'SHIFT' values must be non-negative") if (!is.integer(OFFSET)) OFFSET <- as.integer(OFFSET) if (length(OFFSET) == 0 || anyMissingOrOutside(OFFSET, 0L)) stop("'OFFSET' must be non-negative") ## Perform X setup infoX <- getStartEndRunAndOffset(X, rep.int(1L + OFFSET, length(SHIFT)), N - SHIFT) runStartX <- infoX[["start"]][["run"]] offsetStartX <- infoX[["start"]][["offset"]] runEndX <- infoX[["end"]][["run"]] offsetEndX <- infoX[["end"]][["offset"]] ## Perform Y setup infoY <- getStartEndRunAndOffset(Y, 1L + SHIFT, rep.int(N - OFFSET, length(SHIFT))) runStartY <- infoY[["start"]][["run"]] offsetStartY <- infoY[["start"]][["offset"]] runEndY <- infoY[["end"]][["run"]] offsetEndY <- infoY[["end"]][["offset"]] ## Performance Optimization ## Use a stripped down loop with empty Rle object newX <- new("Rle") newY <- new("Rle") if (verbose) { maxI <- length(SHIFT) ans <- sapply(seq_len(length(SHIFT)), function(i) { cat("\r", i, "/", maxI) FUN(.Call2("Rle_window", X, runStartX[i], runEndX[i], offsetStartX[i], offsetEndX[i], newX, PACKAGE = "S4Vectors"), .Call2("Rle_window", Y, runStartY[i], runEndY[i], offsetStartY[i], offsetEndY[i], newY, PACKAGE = "S4Vectors"), ...) }, simplify = simplify) cat("\n") } else { ans <- sapply(seq_len(length(SHIFT)), function(i) FUN(.Call2("Rle_window", X, runStartX[i], runEndX[i], offsetStartX[i], offsetEndX[i], newX, PACKAGE = "S4Vectors"), .Call2("Rle_window", Y, runStartY[i], runEndY[i], offsetStartY[i], offsetEndY[i], newY, PACKAGE = "S4Vectors"), ...), simplify = simplify) } ans }) ### FIXME: Remove in R 3.3 setMethod("order", "Rle", function(..., na.last=TRUE, decreasing=FALSE) { args <- lapply(unname(list(...)), decodeRle) do.call(order, c(args, list(na.last=na.last, decreasing=decreasing))) } ) ### S3/S4 combo for sort.Rle .sort.Rle <- function(x, decreasing=FALSE, na.last=NA, ...) { if (is.na(na.last)) { if (anyMissing(runValue(x))) x <- x[!is.na(x)] } if (is.integer(runValue(x)) || is.factor(runValue(x))) ord <- orderInteger(runValue(x), decreasing=decreasing, na.last=na.last) else ord <- order(runValue(x), decreasing=decreasing, na.last=na.last) Rle(values=runValue(x)[ord], lengths=runLength(x)[ord], check=FALSE) } sort.Rle <- function(x, decreasing=FALSE, ...) .sort.Rle(x, decreasing=decreasing, ...) setMethod("sort", "Rle", sort.Rle) setMethod("xtfrm", "Rle", function(x) { initialize(x, values=xtfrm(runValue(x))) }) setMethod("rank", "Rle", function (x, na.last = TRUE, ties.method = c("average", "first", "random", "max", "min")) { ties.method <- match.arg(ties.method) if (ties.method == "min" || ties.method == "first") { callNextMethod() } else { x <- as.vector(x) ans <- callGeneric() if (ties.method %in% c("average", "max", "min")) { Rle(ans) } else { ans } } }) setMethod("table", "Rle", function(...) { ## Currently only 1 Rle is supported. An approach for multiple ## Rle's could be disjoin(), findRun() to find matches, then ## xtabs(length ~ value ...). x <- sort(list(...)[[1L]]) if (is.factor(runValue(x))) { dn <- levels(x) tab <- integer(length(dn)) tab[dn %in% runValue(x)] <- runLength(x) dims <- length(dn) } else { dn <- as.character(runValue(x)) tab <- runLength(x) dims <- nrun(x) } ## Adjust 'dn' for consistency with base::table if (length(dn) == 0L) dn <- NULL dn <- list(dn) names(dn) <- .list.names(...) y <- array(tab, dims, dimnames=dn) class(y) <- "table" y } ) .list.names <- function(...) { l <- as.list(substitute(list(...)))[-1L] deparse.level <- 1 nm <- names(l) fixup <- if (is.null(nm)) seq_along(l) else nm == "" dep <- vapply(l[fixup], function(x) switch(deparse.level + 1, "", if (is.symbol(x)) as.character(x) else "", deparse(x, nlines = 1)[1L]), "") if (is.null(nm)) dep else { nm[fixup] <- dep nm } } ### S3/S4 combo for duplicated.Rle .duplicated.Rle <- function(x, incomparables=FALSE, fromLast=FALSE) stop("no \"duplicated\" method for Rle objects yet, sorry") duplicated.Rle <- function(x, incomparables=FALSE, ...) .duplicated.Rle(x, incomparables=incomparables, ...) setMethod("duplicated", "Rle", duplicated.Rle) ### S3/S4 combo for unique.Rle unique.Rle <- function(x, incomparables=FALSE, ...) unique(runValue(x), incomparables=incomparables, ...) setMethod("unique", "Rle", unique.Rle) ### S3/S4 combo for anyDuplicated.Rle anyDuplicated.Rle <- function(x, incomparables=FALSE, ...) all(runLength(x) == 1L) && anyDuplicated(runValue(x)) setMethod("anyDuplicated", "Rle", anyDuplicated.Rle) setMethod("isStrictlySorted", "Rle", function(x) all(runLength(x) == 1L) && isStrictlySorted(runValue(x)) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Set methods ### ### The return values of these do not have any duplicated values, so ### it would obviously be more efficient to return plain vectors. That ### might violate user expectations though. setMethod("union", c("Rle", "Rle"), function(x, y) { Rle(union(runValue(x), runValue(y))) }) setMethod("union", c("ANY", "Rle"), function(x, y) { Rle(union(as.vector(x), runValue(y))) }) setMethod("union", c("Rle", "ANY"), function(x, y) { Rle(union(runValue(x), as.vector(y))) }) setMethod("intersect", c("Rle", "Rle"), function(x, y) { Rle(intersect(runValue(x), runValue(y))) }) setMethod("intersect", c("ANY", "Rle"), function(x, y) { Rle(intersect(as.vector(x), runValue(y))) }) setMethod("intersect", c("Rle", "ANY"), function(x, y) { Rle(intersect(runValue(x), as.vector(y))) }) setMethod("setdiff", c("Rle", "Rle"), function(x, y) { Rle(setdiff(runValue(x), runValue(y))) }) setMethod("setdiff", c("ANY", "Rle"), function(x, y) { Rle(setdiff(as.vector(x), runValue(y))) }) setMethod("setdiff", c("Rle", "ANY"), function(x, y) { Rle(setdiff(runValue(x), as.vector(y))) }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### The "show" method ### setMethod("show", "Rle", function(object) { lo <- length(object) nr <- nrun(object) halfWidth <- getOption("width") %/% 2L cat(classNameForDisplay(runValue(object)), "-Rle of length ", lo, " with ", nr, ifelse(nr == 1, " run\n", " runs\n"), sep = "") first <- max(1L, halfWidth) showMatrix <- rbind(as.character(head(runLength(object), first)), as.character(head(runValue(object), first))) if (nr > first) { last <- min(nr - first, halfWidth) showMatrix <- cbind(showMatrix, rbind(as.character(tail(runLength(object), last)), as.character(tail(runValue(object), last)))) } if (is.character(runValue(object))) { showMatrix[2L,] <- paste("\"", showMatrix[2L,], "\"", sep = "") } showMatrix <- format(showMatrix, justify = "right") cat(labeledLine(" Lengths", showMatrix[1L,], count = FALSE)) cat(labeledLine(" Values ", showMatrix[2L,], count = FALSE)) if (is.factor(runValue(object))) cat(labeledLine("Levels", levels(object))) }) setMethod("showAsCell", "Rle", function(object) as.vector(object)) S4Vectors/R/Rle-utils.R0000644000175100017510000006543012607264536015655 0ustar00biocbuildbiocbuild### ========================================================================= ### Common operations on Rle objects ### ------------------------------------------------------------------------- ### ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Group generic methods ### .sumprodRle <- function(e1, e2, na.rm = FALSE) { n1 <- length(e1) n2 <- length(e2) if (n1 == 0 || n2 == 0) { ends <- integer(0) which1 <- integer(0) which2 <- integer(0) } else { n <- max(n1, n2) if (max(n1, n2) %% min(n1, n2) != 0) warning("longer object length is not a multiple of shorter object length") if (n1 < n) e1 <- rep(e1, length.out = n) if (n2 < n) e2 <- rep(e2, length.out = n) # ends <- sort(unique(c(end(e1), end(e2)))) ends <- sortedMerge(end(e1), end(e2)) which1 <- findIntervalAndStartFromWidth(ends, runLength(e1))[["interval"]] which2 <- findIntervalAndStartFromWidth(ends, runLength(e2))[["interval"]] } lengths <- diffWithInitialZero(ends) values <- runValue(e1)[which1] * runValue(e2)[which2] sum(lengths * values, na.rm = na.rm) } setMethod("Ops", signature(e1 = "Rle", e2 = "Rle"), function(e1, e2) { n1 <- length(e1) n2 <- length(e2) if (n1 == 0 || n2 == 0) { ends <- integer(0) which1 <- integer(0) which2 <- integer(0) } else { n <- max(n1, n2) if (max(n1, n2) %% min(n1, n2) != 0) warning("longer object length is not a multiple of shorter object length") if (n1 < n) e1 <- rep(e1, length.out = n) if (n2 < n) e2 <- rep(e2, length.out = n) # ends <- sort(unique(c(end(e1), end(e2)))) ends <- sortedMerge(end(e1), end(e2)) which1 <- findIntervalAndStartFromWidth(ends, runLength(e1))[["interval"]] which2 <- findIntervalAndStartFromWidth(ends, runLength(e2))[["interval"]] } Rle(values = callGeneric(runValue(e1)[which1], runValue(e2)[which2]), lengths = diffWithInitialZero(ends), check = FALSE) }) setMethod("Ops", signature(e1 = "Rle", e2 = "vector"), function(e1, e2) callGeneric(e1, Rle(e2))) setMethod("Ops", signature(e1 = "vector", e2 = "Rle"), function(e1, e2) callGeneric(Rle(e1), e2)) setMethod("Math", "Rle", function(x) switch(.Generic, cumsum = { whichZero <- which(runValue(x) == 0) widthZero <- runLength(x)[whichZero] startZero <- cumsum(c(1L, runLength(x)))[whichZero] y <- x y@lengths[y@values == 0] <- 1L values <- cumsum(as.vector(y)) lengths <- rep.int(1L, length(values)) lengths[startZero - c(0L, cumsum(head(widthZero, -1) - 1L))] <- widthZero Rle(values = values, lengths = lengths, check = FALSE) }, cumprod = { whichOne <- which(runValue(x) == 0) widthOne <- runLength(x)[whichOne] startOne <- cumsum(c(1L, runLength(x)))[whichOne] y <- x y@lengths[y@values == 0] <- 1L values <- cumprod(as.vector(y)) lengths <- rep.int(1L, length(values)) lengths[startOne - c(0L, cumsum(head(widthOne, -1) - 1L))] <- widthOne Rle(values = values, lengths = lengths, check = FALSE) }, Rle(values = callGeneric(runValue(x)), lengths = runLength(x), check = FALSE))) setMethod("Math2", "Rle", function(x, digits) { if (missing(digits)) digits <- ifelse(.Generic == "round", 0, 6) Rle(values = callGeneric(runValue(x), digits = digits), lengths = runLength(x), check = FALSE) }) setMethod("Summary", "Rle", function(x, ..., na.rm = FALSE) { switch(.Generic, all =, any =, min =, max =, range = callGeneric(runValue(x), ..., na.rm=na.rm), sum = withCallingHandlers({ sum(runValue(x) * runLength(x), ..., na.rm=na.rm) }, warning=function(warn) { msg <- conditionMessage(warn) exp <- gettext("integer overflow - use sum(as.numeric(.))", domain="R") if (msg == exp) { msg <- sub("sum\\(as.numeric\\(.\\)\\)", "runValue(.) <- as.numeric(runValue(.))", msg) warning(simpleWarning(msg, conditionCall(warn))) invokeRestart("muffleWarning") } else { warn } }), prod = prod(runValue(x) ^ runLength(x), ..., na.rm=na.rm)) } ) setMethod("Complex", "Rle", function(z) Rle(values = callGeneric(runValue(z)), lengths = runLength(z), check = FALSE)) ### S3/S4 combo for summary.Rle summary.Rle <- function(object, ..., digits=max(3, getOption("digits") - 3)) { value <- if (is.logical(runValue(object))) c(ValueMode = "logical", { tb <- table(object, exclude = NULL) if (!is.null(n <- dimnames(tb)[[1L]]) && any(iN <- is.na(n))) dimnames(tb)[[1L]][iN] <- "NA's" tb }) else if (is.numeric(runValue(object))) { nas <- is.na(object) object <- object[!nas] qq <- quantile(object) qq <- signif(c(qq[1L:3L], mean(object), qq[4L:5L]), digits) names(qq) <- c("Min.", "1st Qu.", "Median", "Mean", "3rd Qu.", "Max.") if (any(nas)) c(qq, `NA's` = sum(nas)) else qq } else c(Length = length(object), Class = class(object), ValueMode = mode(runValue(object))) class(value) <- c("summaryDefault", "table") value } setMethod("summary", "Rle", summary.Rle) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Other logical data methods ### setMethod("!", "Rle", function(x) Rle(values = !runValue(x), lengths = runLength(x), check = FALSE)) setMethod("which", "Rle", function(x, arr.ind = FALSE) { if (!is.logical(runValue(x))) stop("argument to 'which' is not logical") ok <- runValue(x) ok[is.na(ok)] <- FALSE from <- start(x)[ok] to <- end(x)[ok] if (length(from) == 0) integer(0) else mseq(from, to) }) setMethod("which.max", "Rle", function(x) { start(x)[which.max(runValue(x))] }) ## base::ifelse works fine for S4 'test', but not for S4 yes/no .ifelse_generic_deprecation_msg <- c( " The \"ifelse\" methods for Rle objects are deprecated. Please use", "\n\n as(ifelse(test, as.vector(yes), as.vector(no)), \"Rle\")", "\n\n instead." ) setMethod("ifelse", c(yes = "Rle"), function(test, yes, no) { .Deprecated(msg=.ifelse_generic_deprecation_msg) yes <- as.vector(yes) as(callGeneric(), "Rle") }) setMethod("ifelse", c(no = "Rle"), function(test, yes, no) { .Deprecated(msg=.ifelse_generic_deprecation_msg) no <- as.vector(no) as(callGeneric(), "Rle") }) setMethod("ifelse", c(yes = "Rle", no = "Rle"), function(test, yes, no) { .Deprecated(msg=.ifelse_generic_deprecation_msg) yes <- as.vector(yes) no <- as.vector(no) as(callGeneric(), "Rle") }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Other numerical data methods ### ### S3/S4 combo for diff.Rle .diff.Rle <- function(x, lag = 1, differences = 1) { if (!isSingleNumber(lag) || lag < 1L || !isSingleNumber(differences) || differences < 1L) stop("'lag' and 'differences' must be integers >= 1") lag <- as.integer(lag) differences <- as.integer(differences) if (lag * differences >= length(x)) return(Rle(vector(class(runValue(x))))) for (i in seq_len(differences)) { n <- length(x) x <- window(x, 1L + lag, n) - window(x, 1L, n - lag) } x } diff.Rle <- function(x, ...) .diff.Rle(x, ...) setMethod("diff", "Rle", .diff.Rle) .psummary.Rle <- function(FUN, ..., MoreArgs = NULL) { args <- list(...) ends <- end(args[[1L]]) if (length(args) > 1) { for (i in 2:length(args)) ends <- sortedMerge(ends, end(args[[i]])) } Rle(values = do.call(FUN, c(lapply(args, function(x) { runs <- findIntervalAndStartFromWidth(ends, runLength(x))[["interval"]] runValue(x)[runs] }), MoreArgs)), lengths = diffWithInitialZero(ends), check = FALSE) } setMethod("pmax", "Rle", function(..., na.rm = FALSE) .psummary.Rle(pmax, ..., MoreArgs = list(na.rm = na.rm))) setMethod("pmin", "Rle", function(..., na.rm = FALSE) .psummary.Rle(pmin, ..., MoreArgs = list(na.rm = na.rm))) setMethod("pmax.int", "Rle", function(..., na.rm = FALSE) .psummary.Rle(pmax.int, ..., MoreArgs = list(na.rm = na.rm))) setMethod("pmin.int", "Rle", function(..., na.rm = FALSE) .psummary.Rle(pmin.int, ..., MoreArgs = list(na.rm = na.rm))) ### S3/S4 combo for mean.Rle .mean.Rle <- function(x, na.rm = FALSE) { if (is.integer(runValue(x))) runValue(x) <- as.double(runValue(x)) if (na.rm) n <- length(x) - sum(runLength(x)[is.na(runValue(x))]) else n <- length(x) sum(x, na.rm = na.rm) / n } mean.Rle <- function(x, ...) .mean.Rle(x, ...) setMethod("mean", "Rle", .mean.Rle) setMethod("var", signature = c(x = "Rle", y = "missing"), function(x, y = NULL, na.rm = FALSE, use) { if (na.rm) n <- length(x) - sum(runLength(x)[is.na(runValue(x))]) else n <- length(x) centeredValues <- runValue(x) - mean(x, na.rm = na.rm) sum(runLength(x) * centeredValues * centeredValues, na.rm = na.rm) / (n - 1) }) setMethod("var", signature = c(x = "Rle", y = "Rle"), function(x, y = NULL, na.rm = FALSE, use) { # Direct change to slots for fast computation x@values <- runValue(x) - mean(x, na.rm = na.rm) y@values <- runValue(y) - mean(y, na.rm = na.rm) z <- x * y if (na.rm) n <- length(z) - sum(runLength(z)[is.na(runValue(z))]) else n <- length(z) sum(z, na.rm = na.rm) / (n - 1) }) setMethod("cov", signature = c(x = "Rle", y = "Rle"), function(x, y = NULL, use = "everything", method = c("pearson", "kendall", "spearman")) { use <- match.arg(use, c("all.obs", "complete.obs", "pairwise.complete.obs", "everything", "na.or.complete")) method <- match.arg(method) if (method != "pearson") stop("only 'pearson' method is supported for Rle objects") na.rm <- use %in% c("complete.obs", "pairwise.complete.obs", "na.or.complete") if (use == "all.obs" && (anyMissing(x) || anyMissing(y))) stop("missing observations in cov/cor") var(x, y, na.rm = na.rm) }) setMethod("cor", signature = c(x = "Rle", y = "Rle"), function(x, y = NULL, use = "everything", method = c("pearson", "kendall", "spearman")) { use <- match.arg(use, c("all.obs", "complete.obs", "pairwise.complete.obs", "everything", "na.or.complete")) method <- match.arg(method) if (method != "pearson") stop("only 'pearson' method is supported for Rle objects") na.rm <- use %in% c("complete.obs", "pairwise.complete.obs", "na.or.complete") isMissing <- is.na(x) | is.na(y) if (any(isMissing)) { if (use == "all.obs") { stop("missing observations in cov/cor") } else if (na.rm) { x <- x[!isMissing] y <- y[!isMissing] } } # Direct change to slots for fast computation x@values <- runValue(x) - mean(x, na.rm = na.rm) y@values <- runValue(y) - mean(y, na.rm = na.rm) .sumprodRle(x, y, na.rm = na.rm) / (sqrt(sum(runLength(x) * runValue(x) * runValue(x), na.rm = na.rm)) * sqrt(sum(runLength(y) * runValue(y) * runValue(y), na.rm = na.rm))) }) setMethod("sd", signature = c(x = "Rle"), function(x, na.rm = FALSE) sqrt(var(x, na.rm = na.rm))) ### S3/S4 combo for median.Rle ### FIXME: code duplication needed for S3 / S4 dispatch ### drop NA's here, so dropRle==TRUE allows x[FALSE][NA] in median.default median.Rle <- function(x, na.rm = FALSE) { if (na.rm) x <- x[!is.na(x)] oldOption <- getOption("dropRle") options("dropRle" = TRUE) on.exit(options("dropRle" = oldOption)) NextMethod("median", na.rm=FALSE) } setMethod("median", "Rle", function(x, na.rm = FALSE) { if (na.rm) x <- x[!is.na(x)] oldOption <- getOption("dropRle") options("dropRle" = TRUE) on.exit(options("dropRle" = oldOption)) callNextMethod(x=x, na.rm=FALSE) }) quantile.Rle <- function(x, probs = seq(0, 1, 0.25), na.rm = FALSE, names = TRUE, type = 7, ...) { if (na.rm) x <- x[!is.na(x)] oldOption <- getOption("dropRle") options("dropRle" = TRUE) on.exit(options("dropRle" = oldOption)) NextMethod("quantile", na.rm=FALSE) } setMethod("mad", "Rle", function(x, center = median(x), constant = 1.4826, na.rm = FALSE, low = FALSE, high = FALSE) { if (na.rm) x <- x[!is.na(x)] oldOption <- getOption("dropRle") options("dropRle" = TRUE) on.exit(options("dropRle" = oldOption)) callNextMethod(x=x, center=center, constant=constant, na.rm=FALSE, low=FALSE, high=FALSE) }) setMethod("IQR", "Rle", function(x, na.rm = FALSE) diff(quantile(x, c(0.25, 0.75), na.rm = na.rm, names = FALSE))) setMethod("smoothEnds", "Rle", function(y, k = 3) { oldOption <- getOption("dropRle") options("dropRle" = TRUE) on.exit(options("dropRle" = oldOption)) callNextMethod(y = y, k = k) }) setGeneric("runmean", signature="x", function(x, k, endrule = c("drop", "constant"), ...) standardGeneric("runmean")) setMethod("runmean", "Rle", function(x, k, endrule = c("drop", "constant"), na.rm = FALSE) { sums <- runsum(x, k, endrule, na.rm) if (na.rm) { d <- Rle(rep(1L, length(x))) d[is.na(x)] <- 0L sums / runsum(d, k, endrule, na.rm) } else { sums / k } }) setMethod("runmed", "Rle", function(x, k, endrule = c("median", "keep", "drop", "constant"), algorithm = NULL, print.level = 0) { if (!all(is.finite(as.vector(x)))) stop("NA/NaN/Inf not supported in runmed,Rle-method") endrule <- match.arg(endrule) n <- length(x) k <- normargRunK(k = k, n = n, endrule = endrule) i <- (k + 1L) %/% 2L ans <- runq(x, k = k, i = i) if (endrule == "constant") { runLength(ans)[1L] <- runLength(ans)[1L] + (i - 1L) runLength(ans)[nrun(ans)] <- runLength(ans)[nrun(ans)] + (i - 1L) } else if (endrule != "drop") { ans <- c(head(x, i - 1L), ans, tail(x, i - 1L)) if (endrule == "median") { ans <- smoothEnds(ans, k = k) } } ans }) setGeneric("runsum", signature="x", function(x, k, endrule = c("drop", "constant"), ...) standardGeneric("runsum")) setMethod("runsum", "Rle", function(x, k, endrule = c("drop", "constant"), na.rm = FALSE) { endrule <- match.arg(endrule) n <- length(x) k <- normargRunK(k = k, n = n, endrule = endrule) ans <- .Call2("Rle_runsum", x, as.integer(k), as.logical(na.rm), PACKAGE="S4Vectors") if (endrule == "constant") { j <- (k + 1L) %/% 2L runLength(ans)[1L] <- runLength(ans)[1L] + (j - 1L) runLength(ans)[nrun(ans)] <- runLength(ans)[nrun(ans)] + (j - 1L) } ans }) setGeneric("runwtsum", signature="x", function(x, k, wt, endrule = c("drop", "constant"), ...) standardGeneric("runwtsum")) setMethod("runwtsum", "Rle", function(x, k, wt, endrule = c("drop", "constant"), na.rm = FALSE) { endrule <- match.arg(endrule) n <- length(x) k <- normargRunK(k = k, n = n, endrule = endrule) ans <- .Call2("Rle_runwtsum", x, as.integer(k), as.numeric(wt), as.logical(na.rm), PACKAGE="S4Vectors") if (endrule == "constant") { j <- (k + 1L) %/% 2L runLength(ans)[1L] <- runLength(ans)[1L] + (j - 1L) runLength(ans)[nrun(ans)] <- runLength(ans)[nrun(ans)] + (j - 1L) } ans }) setGeneric("runq", signature="x", function(x, k, i, endrule = c("drop", "constant"), ...) standardGeneric("runq")) setMethod("runq", "Rle", function(x, k, i, endrule = c("drop", "constant"), na.rm = FALSE) { endrule <- match.arg(endrule) n <- length(x) k <- normargRunK(k = k, n = n, endrule = endrule) ans <- .Call2("Rle_runq", x, as.integer(k), as.integer(i), as.logical(na.rm), PACKAGE="S4Vectors") if (endrule == "constant") { j <- (k + 1L) %/% 2L runLength(ans)[1L] <- runLength(ans)[1L] + (j - 1L) runLength(ans)[nrun(ans)] <- runLength(ans)[nrun(ans)] + (j - 1L) } ans }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Other character data methods ### setMethod("nchar", "Rle", function(x, type = "chars", allowNA = FALSE) Rle(values = nchar(runValue(x), type = type, allowNA = allowNA), lengths = runLength(x), check = FALSE)) setMethod("substr", "Rle", function(x, start, stop) { if (is.factor(runValue(x))) { levels(x) <- substr(levels(x), start = start, stop = stop) } else { runValue(x) <- substr(runValue(x), start = start, stop = stop) } x }) setMethod("substring", "Rle", function(text, first, last = 1000000L) { if (is.factor(runValue(text))) { levels(text) <- substring(levels(text), first = first, last = last) } else { runValue(text) <- substring(runValue(text), first = first, last = last) } text }) setMethod("chartr", c(old = "ANY", new = "ANY", x = "Rle"), function(old, new, x) { if (is.factor(runValue(x))) { levels(x) <- chartr(old = old, new = new, levels(x)) } else { runValue(x) <- chartr(old = old, new = new, runValue(x)) } x }) setMethod("tolower", "Rle", function(x) { if (is.factor(runValue(x))) { levels(x) <- tolower(levels(x)) } else { runValue(x) <- tolower(runValue(x)) } x }) setMethod("toupper", "Rle", function(x) { if (is.factor(runValue(x))) { levels(x) <- toupper(levels(x)) } else { runValue(x) <- toupper(runValue(x)) } x }) setMethod("sub", signature = c(pattern = "ANY", replacement = "ANY", x = "Rle"), function(pattern, replacement, x, ignore.case = FALSE, perl = FALSE, fixed = FALSE, useBytes = FALSE) { if (is.factor(runValue(x))) { levels(x) <- sub(pattern = pattern, replacement = replacement, x = levels(x), ignore.case = ignore.case, perl = perl, fixed = fixed, useBytes = useBytes) } else { runValue(x) <- sub(pattern = pattern, replacement = replacement, x = runValue(x), ignore.case = ignore.case, perl = perl, fixed = fixed, useBytes = useBytes) } x }) setMethod("gsub", signature = c(pattern = "ANY", replacement = "ANY", x = "Rle"), function(pattern, replacement, x, ignore.case = FALSE, perl = FALSE, fixed = FALSE, useBytes = FALSE) { if (is.factor(runValue(x))) { levels(x) <- gsub(pattern = pattern, replacement = replacement, x = levels(x), ignore.case = ignore.case, perl = perl, fixed = fixed, useBytes = useBytes) } else { runValue(x) <- gsub(pattern = pattern, replacement = replacement, x = runValue(x), ignore.case = ignore.case, perl = perl, fixed = fixed, useBytes = useBytes) } x }) .pasteTwoRles <- function(e1, e2, sep = " ", collapse = NULL) { n1 <- length(e1) n2 <- length(e2) if (n1 == 0 || n2 == 0) { ends <- integer(0) which1 <- integer(0) which2 <- integer(0) } else { n <- max(n1, n2) if (max(n1, n2) %% min(n1, n2) != 0) warning("longer object length is not a multiple of shorter object length") if (n1 < n) e1 <- rep(e1, length.out = n) if (n2 < n) e2 <- rep(e2, length.out = n) # ends <- sort(unique(c(end(e1), end(e2)))) ends <- sortedMerge(end(e1), end(e2)) which1 <- findIntervalAndStartFromWidth(ends, runLength(e1))[["interval"]] which2 <- findIntervalAndStartFromWidth(ends, runLength(e2))[["interval"]] } if (is.null(collapse) && is.factor(runValue(e1)) && is.factor(runValue(e2))) { levelsTable <- expand.grid(levels(e2), levels(e1), KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE) values <- structure((as.integer(runValue(e1)[which1]) - 1L) * nlevels(e2) + as.integer(runValue(e2)[which2]), levels = paste(levelsTable[[2L]], levelsTable[[1L]], sep = sep), class = "factor") } else { values <- paste(runValue(e1)[which1], runValue(e2)[which2], sep = sep, collapse = collapse) } Rle(values = values, lengths = diffWithInitialZero(ends), check = FALSE) } setMethod("paste", "Rle", function(..., sep = " ", collapse = NULL) { args <- list(...) ans <- args[[1L]] if (length(args) > 1) { for (i in 2:length(args)) { ans <- .pasteTwoRles(ans, args[[i]], sep = sep, collapse = collapse) } } ans }) setMethod("grepl", c("ANY", "Rle"), function(pattern, x, ignore.case = FALSE, perl = FALSE, fixed = FALSE, useBytes = FALSE) { v <- grepl(pattern, runValue(x), ignore.case, perl, fixed, useBytes) Rle(v, runLength(x)) }) setMethod("grep", c("ANY", "Rle"), function(pattern, x, ignore.case = FALSE, perl = FALSE, value = FALSE, fixed = FALSE, useBytes = FALSE, invert = FALSE) { if (isTRUE(value)) { v <- grep(pattern, x, ignore.case, perl, value=TRUE, fixed, useBytes, invert) Rle(v, runLength(x)) } else { # obviously inefficient Rle(callNextMethod()) } }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Other factor data methods ### ### S3/S4 combo for levels.Rle levels.Rle <- function(x) levels(runValue(x)) setMethod("levels", "Rle", levels.Rle) setReplaceMethod("levels", "Rle", function(x, value) { levels(x@values) <- value if (anyDuplicated(value)) { x <- Rle(values = runValue(x), lengths = runLength(x), check = FALSE) } x }) droplevels.Rle <- function(x) { if (!is.factor(runValue(x))) { stop("levels can only be dropped when runValue(x) is a factor") } runValue(x) <- droplevels(runValue(x)) x } setMethod("droplevels", "Rle", droplevels.Rle) S4Vectors/R/S4-utils.R0000644000175100017510000002515112607264537015416 0ustar00biocbuildbiocbuild### ========================================================================= ### Some low-level S4 classes and utilities ### ------------------------------------------------------------------------- ### setClassUnion("characterORNULL", c("character", "NULL")) ### WARNING: The behavior of is.vector(), is( , "vector"), is.list(), and ### is( ,"list") makes no sense: ### 1. is.vector(matrix()) is FALSE but is(matrix(), "vector") is TRUE. ### 2. is.list(data.frame()) is TRUE but is(data.frame(), "list") is FALSE. ### 3. is(data.frame(), "list") is FALSE but extends("data.frame", "list") ### is TRUE. ### 4. is.vector(data.frame()) is FALSE but is.list(data.frame()) and ### is.vector(list()) are both TRUE. In other words: a data frame is a ### list and a list is a vector but a data frame is not a vector. ### 5. I'm sure there is more but you get it! ### Building our software on top of such a mess won't give us anything good. ### For example, it's not too surprising that the union class we define below ### is broken: ### 6. is(data.frame(), "vectorORfactor") is TRUE even though ### is(data.frame(), "vector") and is(data.frame(), "factor") are both ### FALSE. ### Results above obtained with R-3.1.2 and R-3.2.0. ### TODO: Be brave and report this craziness to the R bug tracker. setClassUnion("vectorORfactor", c("vector", "factor")) ### We define the coercion method below as a workaround to the following ### bug in R: ### ### setClass("A", representation(stuff="numeric")) ### setMethod("as.vector", "A", function(x, mode="any") x@stuff) ### ### a <- new("A", stuff=3:-5) ### > as.vector(a) ### [1] 3 2 1 0 -1 -2 -3 -4 -5 ### > as(a, "vector") ### Error in as.vector(from) : ### no method for coercing this S4 class to a vector ### > selectMethod("coerce", c("A", "vector")) ### Method Definition: ### ### function (from, to, strict = TRUE) ### { ### value <- as.vector(from) ### if (strict) ### attributes(value) <- NULL ### value ### } ### ### ### Signatures: ### from to ### target "A" "vector" ### defined "ANY" "vector" ### > setAs("ANY", "vector", function(from) as.vector(from)) ### > as(a, "vector") ### [1] 3 2 1 0 -1 -2 -3 -4 -5 ### ### ML: The problem is that the default coercion method is defined ### in the methods namespace, which does not see the as.vector() ### generic we define. Solution in this case would probably be to ### make as.vector a dispatching primitive like as.character(), but ### the "mode" argument makes things complicated. setAs("ANY", "vector", function(from) as.vector(from)) coercerToClass <- function(class) { if (extends(class, "vector")) .as <- get(paste0("as.", class)) else .as <- function(from) as(from, class) function(from) { to <- .as(from) if (!is.null(names(from)) && is.null(names(to))) { names(to) <- names(from) } to } } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### setValidity2(), new2() ### ### Give more contol over when object validation should happen. ### .validity_options <- new.env(hash=TRUE, parent=emptyenv()) assign("debug", FALSE, envir=.validity_options) assign("disabled", FALSE, envir=.validity_options) debugValidity <- function(debug) { if (missing(debug)) return(get("debug", envir=.validity_options)) debug <- isTRUE(debug) assign("debug", debug, envir=.validity_options) debug } disableValidity <- function(disabled) { if (missing(disabled)) return(get("disabled", envir=.validity_options)) disabled <- isTRUE(disabled) assign("disabled", disabled, envir=.validity_options) disabled } setValidity2 <- function(Class, valid.func, where=topenv(parent.frame())) { setValidity(Class, function(object) { if (disableValidity()) return(TRUE) if (debugValidity()) { whoami <- paste("validity method for", Class, "object") cat("[debugValidity] Entering ", whoami, "\n", sep="") on.exit(cat("[debugValidity] Leaving ", whoami, "\n", sep="")) } problems <- valid.func(object) if (isTRUE(problems) || length(problems) == 0L) return(TRUE) problems }, where=where ) } new2 <- function(..., check=TRUE) { if (!isTRUEorFALSE(check)) stop("'check' must be TRUE or FALSE") old_val <- disableValidity() on.exit(disableValidity(old_val)) disableValidity(!check) new(...) } stopIfProblems <- function(problems) if (!is.null(problems)) stop(paste(problems, collapse="\n ")) ### 'signatures' must be a list of character vectors. To use when many methods ### share the same implementation. setMethods <- function(f, signatures=list(), definition, where=topenv(parent.frame()), ...) { for (signature in signatures) setMethod(f, signature=signature, definition, where=where, ...) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### setReplaceAs() ### ### Supplying a "coerce<-" method to the 'replace' argument of setAs() is ### optional but not supplying a "coerce" method (thru the 'def' argument). ### However there are legitimate situations where we want to define a ### "coerce<-" method only. setReplaceAs() can be used for that. ### ### Same interface as setAs() (but no 'replace' argument). setReplaceAs <- function(from, to, def, where=topenv(parent.frame())) { ## Code below taken from setAs() and slightly adapted. args <- formalArgs(def) if (identical(args, c("from", "to", "value"))) { method <- def } else { if (length(args) != 2L) stop(gettextf("the method definition must be a function of 2 ", "arguments, got %d", length(args)), domain=NA) def <- body(def) if (!identical(args, c("from", "value"))) { ll <- list(quote(from), quote(value)) names(ll) <- args def <- substituteDirect(def, ll) warning(gettextf("argument names in method definition changed ", "to agree with 'coerce<-' generic:\n%s", paste(deparse(def), sep="\n ")), domain=NA) } method <- eval(function(from, to, value) NULL) functionBody(method, envir=.GlobalEnv) <- def } setMethod("coerce<-", c(from, to), method, where=where) } ### We also provide 2 canonical "coerce<-" methods that can be used when the ### "from class" is a subclass of the "to class". They do what the methods ### automatically generated by the methods package are expected to do except ### that the latter are broken. See ### https://bugs.r-project.org/bugzilla/show_bug.cgi?id=16421 ### for the bug report. ### Naive/straight-forward implementation (easy to understand so it explains ### the semantic of canonical "coerce<-"). canonical_replace_as <- function(from, to, value) { for (what in slotNames(to)) slot(from, what) <- slot(value, what) from } ### Does the same as canonical_replace_as() but tries to generate only one ### copy of 'from' instead of one copy each time one of its slots is modified. canonical_replace_as_2 <- function(from, to, value) { firstTime <- TRUE for (what in slotNames(to)) { v <- slot(value, what) if (firstTime) { slot(from, what, FALSE) <- v firstTime <- FALSE } else { `slot<-`(from, what, FALSE, v) } } from } ### Usage (assuming B is a subclass of A): ### ### setReplaceAs("B", "A", canonical_replace_as_2) ### ### Note that this is used in the VariantAnnotation package. ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Manipulating the prototype of an S4 class. ### ### Gets or sets the default value of the given slot of the given class by ### reading or altering the prototype of the class. setDefaultSlotValue() is ### typically used in the .onLoad() hook of a package when the DLL of the ### package needs to be loaded *before* the default value of a slot can be ### computed. getDefaultSlotValue <- function(classname, slotname, where=.GlobalEnv) { classdef <- getClass(classname, where=where) if (!(slotname %in% names(attributes(classdef@prototype)))) stop("prototype for class \"", classname, "\" ", "has no \"", slotname, "\" attribute") attr(classdef@prototype, slotname, exact=TRUE) } setDefaultSlotValue <- function(classname, slotname, value, where=.GlobalEnv) { classdef <- getClass(classname, where=where) if (!(slotname %in% names(attributes(classdef@prototype)))) stop("prototype for class \"", classname, "\" ", "has no \"", slotname, "\" attribute") attr(classdef@prototype, slotname) <- value assignClassDef(classname, classdef, where=where) ## Re-compute the complete definition of the class. methods::setValidity() ## does that after calling assignClassDef() so we do it too. resetClass(classname, classdef, where=where) } setPrototypeFromObject <- function(classname, object, where=.GlobalEnv) { classdef <- getClass(classname, where=where) if (class(object) != classname) stop("'object' must be a ", classname, " instance") object_attribs <- attributes(object) object_attribs$class <- NULL ## Sanity check. stopifnot(identical(names(object_attribs), names(attributes(classdef@prototype)))) attributes(classdef@prototype) <- object_attribs assignClassDef(classname, classdef, where=where) ## Re-compute the complete definition of the class. methods::setValidity() ## does that after calling assignClassDef() so we do it too. resetClass(classname, classdef, where=where) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### allEqualsS4: just a hack that auomatically digs down ### deeply nested objects to detect differences. ### .allEqualS4 <- function(x, y) { eq <- all.equal(x, y) canCompareS4 <- !isTRUE(eq) && isS4(x) && isS4(y) && class(x) == class(y) if (canCompareS4) { child.diffs <- mapply(.allEqualS4, attributes(x), attributes(y), SIMPLIFY=FALSE) child.diffs$class <- NULL dfs <- mapply(function(d, nm) { if (!is.data.frame(d)) { data.frame(comparison = I(list(d))) } else d }, child.diffs, names(child.diffs), SIMPLIFY=FALSE) do.call(rbind, dfs) } else { eq[1] } } allEqualS4 <- function(x, y) { eq <- .allEqualS4(x, y) setNames(eq$comparison, rownames(eq))[sapply(eq$comparison, Negate(isTRUE))] } S4Vectors/R/SimpleList-class.R0000644000175100017510000001660512607264537017166 0ustar00biocbuildbiocbuild### ========================================================================= ### SimpleList objects ### ------------------------------------------------------------------------- setClass("SimpleList", contains="List", representation( listData="list" ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Accessor methods. ### setMethod("length", "SimpleList", function(x) length(as.list(x))) setMethod("names", "SimpleList", function(x) names(as.list(x))) setReplaceMethod("names", "SimpleList", function(x, value) { names(x@listData) <- value x }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Constructor. ### ### Low-level. NOT exported. ### Stuff to put in elementMetadata slot can be passed either with ### new_SimpleList_from_list(..., elementMetadata=somestuff) ### or with ### new_SimpleList_from_list(..., mcols=somestuff) ### The latter is the new recommended form. new_SimpleList_from_list <- function(Class, x, ..., mcols) { if (!extends(Class, "SimpleList")) stop("class ", Class, " must extend SimpleList") if (!is.list(x)) stop("'x' must be a list") if (is.array(x)) { # drop any unwanted dimensions tmp_names <- names(x) dim(x) <- NULL # clears the names names(x) <- tmp_names } class(x) <- "list" ans_elementType <- elementType(new(Class)) if (!all(sapply(x, function(xi) extends(class(xi), ans_elementType)))) stop("all elements in 'x' must be ", ans_elementType, " objects") if (missing(mcols)) return(new2(Class, listData=x, ..., check=FALSE)) new2(Class, listData=x, ..., elementMetadata=mcols, check=FALSE) } SimpleList <- function(...) { args <- list(...) ## The extends(class(x), "list") test is NOT equivalent to is.list(x) or ## to is(x, "list") or to inherits(x, "list"). Try for example with ## x <- data.frame() or x <- matrix(list()). We use the former below ## because it seems to closely mimic what the methods package uses for ## checking the "listData" slot of the SimpleList object that we try to ## create later with new(). For example if we were using is.list() instead ## of extends(), the test would pass on matrix(list()) but new() then would ## fail with the following message: ## Error in validObject(.Object) : ## invalid class “SimpleList†object: invalid object for slot "listData" ## in class "SimpleList": got class "matrix", should be or extend class ## "list" if (length(args) == 1L && extends(class(args[[1L]]), "list")) args <- args[[1L]] new("SimpleList", listData=args) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity. ### .valid.SimpleList.listData <- function(x) { elementTypeX <- elementType(x) if (!all(sapply(as.list(x), function(xi) extends(class(xi), elementTypeX)))) return(paste("the 'listData' slot must be a list containing", elementTypeX, "objects")) NULL } .valid.SimpleList <- function(x) { c(.valid.SimpleList.listData(x)) } setValidity2("SimpleList", .valid.SimpleList) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### classNameForDisplay() ### setMethod("classNameForDisplay", "SimpleList", function(x) sub("^Simple", "", class(x)) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Subsetting. ### setMethod("extractROWS", "SimpleList", function(x, i) { i <- normalizeSingleBracketSubscript(i, x, as.NSBS=TRUE) initialize(x, listData=extractROWS(x@listData, i), elementMetadata=extractROWS(x@elementMetadata, i)) } ) setMethod("replaceROWS", "SimpleList", function(x, i, value) { i <- normalizeSingleBracketSubscript(i, x, as.NSBS=TRUE) initialize(x, listData=replaceROWS(x@listData, i, value@listData)) } ) setMethod("getListElement", "SimpleList", function(x, i, exact=TRUE) getListElement(x@listData, i, exact=exact) ) setMethod("setListElement", "SimpleList", function(x, i, value) { x@listData[[i]] <- value x } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Combining. ### ## NOTE: while the 'c' function does not have an 'x', the generic does ## c() is a primitive, so 'x' can be missing; dispatch is by position, ## although sometimes this does not work so well, so it's best to keep ## names off the parameters whenever feasible. #setMethod("c", "SimpleList", # function(x, ..., recursive = FALSE) { # slot(x, "listData") <- # do.call(c, lapply(unname(list(x, ...)), as.list)) # if (!is.null(mcols(x))) # mcols(x) <- rbind.mcols(x, ...) # x # }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Looping. ### setMethod("lapply", "SimpleList", function(X, FUN, ...) lapply(as.list(X), FUN = FUN, ...)) setMethod("endoapply", "SimpleList", function(X, FUN, ...) { FUN <- match.fun(FUN) listData <- lapply(X, FUN = FUN, ...) elementTypeX <- elementType(X) if (!all(sapply(listData, function(Xi) extends(class(Xi), elementTypeX)))) stop("all results must be of class '", elementTypeX, "'") slot(X, "listData", check=FALSE) <- listData X }) setMethod("mendoapply", "SimpleList", function(FUN, ..., MoreArgs = NULL) { X <- list(...)[[1L]] elementTypeX <- elementType(X) FUN <- match.fun(FUN) listData <- mapply(FUN = FUN, ..., MoreArgs = MoreArgs, SIMPLIFY = FALSE) if (!all(sapply(listData, function(Xi) extends(class(Xi), elementTypeX)))) stop("all results must be of class '", elementTypeX, "'") slot(X, "listData", check=FALSE) <- listData X }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion. ### .as.list.SimpleList <- function(x, use.names=TRUE) { if (!isTRUEorFALSE(use.names)) stop("'use.names' must be TRUE or FALSE") ans <- x@listData if (!use.names) names(ans) <- NULL ans } ### S3/S4 combo for as.list.SimpleList as.list.SimpleList <- function(x, ...) .as.list.SimpleList(x, ...) setMethod("as.list", "SimpleList", as.list.SimpleList) setAs("ANY", "SimpleList", function(from) { coerceToSimpleList(from) }) setAs("list", "List", function(from) { coerceToSimpleList(from) }) coerceToSimpleList <- function(from, element.type, ...) { if (missing(element.type)) { if (is(from, "List")) element.type <- from@elementType else if (is.list(from)) element.type <- listElementType(from) else element.type <- class(from) } SimpleListClass <- listClassName("Simple", element.type) if (!is(from, SimpleListClass)) { listData <- as.list(from) if (!is.null(element.type)) listData <- lapply(listData, coercerToClass(element.type), ...) new_SimpleList_from_list(SimpleListClass, listData) } else { from } } S4Vectors/R/Vector-class.R0000644000175100017510000004326412607264537016344 0ustar00biocbuildbiocbuild### ========================================================================= ### Vector objects ### ------------------------------------------------------------------------- ### ### The Vector virtual class is a general container for storing a finite ### sequence i.e. an ordered finite collection of elements. ### setClassUnion("DataTableORNULL", c("DataTable", "NULL")) setClass("Vector", contains="Annotated", representation( "VIRTUAL", elementMetadata="DataTableORNULL" ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### parallelSlotNames() ### ### For internal use only. ### ### Must return the names of all the slots in Vector object 'x' that are ### "parallel" to 'x'. Slot 'foo' is considered to be "parallel" to 'x' if: ### (a) 'x@foo' is NULL or an object for which NROW() is equal to ### 'length(x)', and ### (b) the i-th element in 'x@foo' describes some component of the i-th ### element in 'x'. ### For example, the "start", "width", "NAMES", and "elementMetadata" slots ### of an IRanges object are parallel to the object. Note that the "NAMES" ### and "elementMetadata" slots can be set to NULL. ### The *first" slot name returned by parallelSlotNames() is used to get the ### length of 'x'. ### setGeneric("parallelSlotNames", function(x) standardGeneric("parallelSlotNames") ) setMethod("parallelSlotNames", "Vector", function(x) "elementMetadata") ### Methods for Vector subclasses only need to specify the parallel slots they ### add to their parent class. See Hits-class.R file for an example. ### parallelVectorNames() is for internal use only. setGeneric("parallelVectorNames", function(x) standardGeneric("parallelVectorNames")) setMethod("parallelVectorNames", "ANY", function(x) character()) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Getters. ### setMethod("length", "Vector", function(x) NROW(slot(x, parallelSlotNames(x)[[1L]])) ) setMethod("lengths", "Vector", function(x, use.names=TRUE) { if (!isTRUEorFALSE(use.names)) stop("'use.names' must be TRUE or FALSE") ans <- elementLengths(x) if (!use.names) names(ans) <- NULL ans } ) setMethod("NROW", "Vector", function(x) length(x)) setMethod("ROWNAMES", "Vector", function(x) names(x)) ### 3 accessors for the same slot: elementMetadata(), mcols(), and values(). ### mcols() is the recommended one, use of elementMetadata() or values() is ### discouraged. setGeneric("elementMetadata", function(x, use.names=FALSE, ...) standardGeneric("elementMetadata") ) setMethod("elementMetadata", "Vector", function(x, use.names=FALSE, ...) { if (!isTRUEorFALSE(use.names)) stop("'use.names' must be TRUE or FALSE") ans <- x@elementMetadata if (use.names && !is.null(ans)) rownames(ans) <- names(x) ans } ) setGeneric("mcols", function(x, use.names=FALSE, ...) standardGeneric("mcols") ) setMethod("mcols", "Vector", function(x, use.names=FALSE, ...) elementMetadata(x, use.names=use.names, ...) ) setGeneric("values", function(x, ...) standardGeneric("values")) setMethod("values", "Vector", function(x, ...) elementMetadata(x, ...)) setMethod("anyNA", "Vector", function(x) any(is.na(x))) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity. ### .valid.Vector.length <- function(x) { x_len <- length(x) if (!isSingleInteger(x_len) || x_len < 0L) return("'length(x)' must be a single non-negative integer") if (!is.null(attributes(x_len))) return("'length(x)' must be a single integer with no attributes") NULL } .valid.Vector.parallelSlots <- function(x) { x_len <- length(x) x_pslotnames <- parallelSlotNames(x) if (!is.character(x_pslotnames) || anyMissing(x_pslotnames) || anyDuplicated(x_pslotnames)) { msg <- c("'parallelSlotNames(x)' must be a character vector ", "with no NAs and no duplicates") return(paste(msg, collapse="")) } if (x_pslotnames[[length(x_pslotnames)]] != "elementMetadata") { msg <- c("last string in 'parallelSlotNames(x)' ", "must be \"elementMetadata\"") return(paste(msg, collapse="")) } for (slotname in x_pslotnames) { tmp <- slot(x, slotname) if (!(is.null(tmp) || NROW(tmp) == x_len)) { msg <- c("'x@", slotname, "' is not parallel to 'x'") return(paste(msg, collapse="")) } } NULL } .valid.Vector.names <- function(x) { x_names <- names(x) if (is.null(x_names)) return(NULL) if (!is.character(x_names) || !is.null(attributes(x_names))) { msg <- c("'names(x)' must be NULL or a character vector ", "with no attributes") return(paste(msg, collapse="")) } if (length(x_names) != length(x)) return("'names(x)' must be NULL or have the length of 'x'") NULL } .valid.Vector.mcols <- function(x) { x_mcols <- mcols(x) if (!is(x_mcols, "DataTableORNULL")) return("'mcols(x)' must be a DataTable object or NULL") if (is.null(x_mcols)) return(NULL) ## 'x_mcols' is a DataTable object. x_mcols_rownames <- rownames(x_mcols) if (is.null(x_mcols_rownames)) return(NULL) if (!identical(x_mcols_rownames, names(x))) { msg <- c("the rownames of DataTable 'mcols(x)' ", "must match the names of 'x'") return(paste(msg, collapse="")) } NULL } .valid.Vector <- function(x) { c(.valid.Vector.length(x), .valid.Vector.parallelSlots(x), .valid.Vector.names(x), .valid.Vector.mcols(x)) } setValidity2("Vector", .valid.Vector) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion. ### setMethod("as.logical", "Vector", function(x) as.vector(x, mode="logical") ) setMethod("as.integer", "Vector", function(x) as.vector(x, mode="integer") ) setMethod("as.numeric", "Vector", function(x) as.vector(x, mode="numeric") ) ### Even though as.double() is a generic function (as reported by ### 'getGeneric("as.double")', it seems impossible to define methods for this ### generic. Trying to do so like in the code below actually creates an ### "as.numeric" method. #setMethod("as.double", "Vector", # function(x) as.vector(x, mode="double") #) setMethod("as.complex", "Vector", function(x) as.vector(x, mode="complex") ) setMethod("as.character", "Vector", function(x) as.vector(x, mode="character") ) setMethod("as.raw", "Vector", function(x) as.vector(x, mode="raw") ) setAs("Vector", "vector", function(from) as.vector(from)) setAs("Vector", "logical", function(from) as.logical(from)) setAs("Vector", "integer", function(from) as.integer(from)) setAs("Vector", "numeric", function(from) as.numeric(from)) setAs("Vector", "complex", function(from) as.complex(from)) setAs("Vector", "character", function(from) as.character(from)) setAs("Vector", "raw", function(from) as.raw(from)) setAs("Vector", "factor", function(from) as.factor(from)) setAs("Vector", "data.frame", function(from) as.data.frame(from)) ### S3/S4 combo for as.data.frame.Vector as.data.frame.Vector <- function(x, row.names=NULL, optional=FALSE, ...) { x <- as.vector(x) as.data.frame(x, row.names=NULL, optional=optional, ...) } setMethod("as.data.frame", "Vector", as.data.frame.Vector) makeFixedColumnEnv <- function(x, parent, tform = identity) { env <- new.env(parent=parent) pvnEnv <- environment(selectMethod("parallelVectorNames", class(x))) lapply(parallelVectorNames(x), function(nm) { accessor <- get(nm, pvnEnv, mode="function") makeActiveBinding(nm, function() { val <- tform(accessor(x)) rm(list=nm, envir=env) assign(nm, val, env) val }, env) }) env } setMethod("as.env", "Vector", function(x, enclos, tform = identity) { addSelfRef(x, makeFixedColumnEnv(x, as.env(mcols(x), enclos, tform), tform)) }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Setters. ### setGeneric("elementMetadata<-", function(x, ..., value) standardGeneric("elementMetadata<-")) setReplaceMethod("elementMetadata", "Vector", function(x, ..., value) { if (!is(value, "DataTableORNULL")) stop("replacement 'elementMetadata' value must be ", "a DataTable object or NULL") if ("elementMetadata" %in% names(attributes(x))) { if (!is.null(value) && length(x) != nrow(value)) stop("supplied metadata columns must have the length of 'x'") if (!is.null(value)) rownames(value) <- NULL x@elementMetadata <- value } x } ) setGeneric("mcols<-", function(x, ..., value) standardGeneric("mcols<-")) setReplaceMethod("mcols", "Vector", function(x, ..., value) `elementMetadata<-`(x, ..., value=value) ) setGeneric("values<-", function(x, ..., value) standardGeneric("values<-")) setReplaceMethod("values", "Vector", function(x, value) { elementMetadata(x) <- value x }) setGeneric("rename", function(x, ...) standardGeneric("rename")) .renameVector <- function(x, ...) { newNames <- c(...) if (!is.character(newNames) || any(is.na(newNames))) { stop("arguments in '...' must be character and not NA") } badOldNames <- setdiff(names(newNames), names(x)) if (length(badOldNames)) stop("Some 'from' names in value not found on 'x': ", paste(badOldNames, collapse = ", ")) names(x)[match(names(newNames), names(x))] <- newNames x } setMethod("rename", "vector", .renameVector) setMethod("rename", "Vector", .renameVector) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Subsetting. ### ### The "[" and "[<-" methods for Vector objects are just delegating to ### extractROWS() and replaceROWS() for performing the real work. Most of ### the times, the author of a Vector subclass only needs to implement an ### "extractROWS" and "replaceROWS" method for his/her objects. ### setMethod("[", "Vector", function(x, i, j, ..., drop=TRUE) { if (!missing(j) || length(list(...)) > 0L) stop("invalid subsetting") if (missing(i)) return(x) extractROWS(x, i) } ) ### We provide a default "extractROWS" method for Vector objects that only ### subsets the individual parallel slots. That should be enough for most ### Vector derivatives that have parallelSlotNames() properly set. setMethod("extractROWS", "Vector", function(x, i) { i <- normalizeSingleBracketSubscript(i, x, as.NSBS=TRUE) x_pslotnames <- parallelSlotNames(x) ans_pslots <- lapply(setNames(x_pslotnames, x_pslotnames), function(slotname) extractROWS(slot(x, slotname), i)) ## Does NOT validate the object before returning it, because, most of ## the times, this is not needed. There are exceptions though. See ## for example the "extractROWS" method for Hits objects. do.call(BiocGenerics:::replaceSlots, c(list(x), ans_pslots, list(check=FALSE))) } ) setReplaceMethod("[", "Vector", function(x, i, j, ..., value) { if (!missing(j) || length(list(...)) > 0L) stop("invalid subsetting") i <- normalizeSingleBracketSubscript(i, x, as.NSBS=TRUE) li <- length(i) if (li == 0L) { ## Surprisingly, in that case, `[<-` on standard vectors does not ## even look at 'value'. So neither do we... return(x) } lv <- NROW(value) if (lv == 0L) stop("replacement has length zero") value <- normalizeSingleBracketReplacementValue(value, x) if (li != lv) { if (li %% lv != 0L) warning("number of values supplied is not a sub-multiple ", "of the number of values to be replaced") value <- extractROWS(value, rep(seq_len(lv), length.out=li)) } replaceROWS(x, i, value) } ) ### Works on any Vector object for which c() and [ work. Assumes 'value' is ### compatible with 'x'. setMethod("replaceROWS", "Vector", function(x, i, value) { idx <- seq_along(x) i <- extractROWS(setNames(idx, names(x)), i) ## Assuming that objects of class 'class(x)' can be combined with c(). ans <- c(x, value) idx[i] <- length(x) + seq_len(length(value)) ## Assuming that [ works on objects of class 'class(x)'. ans <- ans[idx] ## Restore the original decoration. metadata(ans) <- metadata(x) names(ans) <- names(x) mcols(ans) <- mcols(x) ans } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Convenience wrappers for common subsetting operations. ### ### S3/S4 combo for window.Vector .window.Vector <- function(x, start=NA, end=NA, width=NA) { i <- WindowNSBS(x, start=start, end=end, width=width) extractROWS(x, i) } window.Vector <- function(x, ...) .window.Vector(x, ...) setMethod("window", "Vector", window.Vector) ### S3/S4 combo for head.Vector head.Vector <- function(x, n=6L, ...) { if (!isSingleNumber(n)) stop("'n' must be a single integer") if (!is.integer(n)) n <- as.integer(n) x_NROW <- NROW(x) if (n >= 0L) { n <- min(x_NROW, n) } else { n <- max(0L, x_NROW + n) } window(x, start=1L, width=n) } setMethod("head", "Vector", head.Vector) ## S3/S4 combo for tail.Vector tail.Vector <- function(x, n=6L, ...) { if (!isSingleNumber(n)) stop("'n' must be a single integer") if (!is.integer(n)) n <- as.integer(n) x_NROW <- NROW(x) if (n >= 0L) { n <- min(x_NROW, n) } else { n <- max(0L, x_NROW + n) } window(x, end=x_NROW, width=n) } setMethod("tail", "Vector", tail.Vector) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Internal helpers used by the "show" method of various Vector subclasses. ### setGeneric("classNameForDisplay", function(x) standardGeneric("classNameForDisplay")) setMethod("classNameForDisplay", "ANY", function(x) { ## Selecting the 1st element guarantees that we return a single string ## (e.g. on an ordered factor, class(x) returns a character vector of ## length 2). class(x)[1L] } ) setMethod("classNameForDisplay", "AsIs", function(x) { class(x) <- setdiff(class(x), "AsIs") classNameForDisplay(x) }) setGeneric("showAsCell", function(object) standardGeneric("showAsCell") ) setMethod("showAsCell", "ANY", function(object) { if (length(dim(object)) > 2) dim(object) <- c(nrow(object), prod(tail(dim(object), -1))) if (NCOL(object) > 1) { class(object) <- setdiff(class(object), "AsIs") df <- as.data.frame(object[, head(seq_len(ncol(object)), 3), drop = FALSE]) attempt <- do.call(paste, df) if (ncol(object) > 3) attempt <- paste(attempt, "...") attempt } else if (NCOL(object) == 0L) { rep.int("", NROW(object)) } else { attempt <- try(as.vector(object), silent=TRUE) if (is(attempt, "try-error")) rep.int("########", length(object)) else attempt } }) setMethod("showAsCell", "Vector", function(object) rep.int("########", length(object))) setMethod("showAsCell", "Date", function(object) object) setMethod("showAsCell", "POSIXt", function(object) object) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Combining. ### makeZeroColDataFrame <- function(x) new("DataFrame", nrows=length(x)) ### Somewhat painful that we do not always have a DataFrame in elementMetadata ensureMcols <- function(x) { mc <- mcols(x) if (is.null(mc)) { mc <- makeZeroColDataFrame(x) } mc } rbind_mcols <- function(x, ...) { args <- list(x, ...) mcols_list <- lapply(args, mcols) if (length(mcols_list) == 1L) return(mcols_list[[1L]]) mcols_is_null <- sapply(mcols_list, is.null) if (all(mcols_is_null)) return(NULL) mcols_list[mcols_is_null] <- lapply(args[mcols_is_null], makeZeroColDataFrame) colnames_list <- lapply(mcols_list, colnames) allCols <- unique(unlist(colnames_list, use.names=FALSE)) fillCols <- function(df) { if (nrow(df)) df[setdiff(allCols, colnames(df))] <- DataFrame(NA) df } do.call(rbind, lapply(mcols_list, fillCols)) } rbindRowOfNAsToMetadatacols <- function(x) { x_mcols <- mcols(x) if (!is.null(x_mcols)) mcols(x)[nrow(x_mcols)+1L,] <- NA x } ### FIXME: This method doesn't work properly on DataTable objects if 'after' ### is >= 1 and < length(x). setMethod("append", c("Vector", "Vector"), function(x, values, after=length(x)) { if (!isSingleNumber(after)) stop("'after' must be a single number") x_len <- length(x) if (after == 0L) c(values, x) else if (after >= x_len) c(x, values) else c(head(x, n=after), values, tail(x, n=-after)) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Evaluating. ### setMethod("eval", c("expression", "Vector"), function(expr, envir, enclos = parent.frame()) eval(expr, as.env(envir, enclos)) ) setMethod("eval", c("language", "Vector"), function(expr, envir, enclos = parent.frame()) eval(expr, as.env(envir, enclos)) ) setMethod("with", "Vector", function(data, expr, ...) { safeEval(substitute(expr), data, parent.frame(), ...) }) S4Vectors/R/Vector-comparison.R0000644000175100017510000002554212607264537017410 0ustar00biocbuildbiocbuild### ========================================================================= ### Comparing, ordering, and tabulating vector-like objects ### ------------------------------------------------------------------------- ### ### Functions/operators for comparing, ordering, tabulating: ### ### compare ### == ### != ### <= ### >= ### < ### > ### match ### selfmatch ### duplicated ### unique ### %in% ### findMatches ### countMatches ### order ### sort ### rank ### table ### Method signatures for binary comparison operators. .OP2_SIGNATURES <- list( c("Vector", "Vector"), c("Vector", "ANY"), c("ANY", "Vector") ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Element-wise (aka "parallel") comparison of 2 Vector objects. ### setGeneric("compare", function(x, y) standardGeneric("compare")) ### The methods below are implemented on top of compare(). setMethods("==", .OP2_SIGNATURES, function(e1, e2) { compare(e1, e2) == 0L } ) setMethods("<=", .OP2_SIGNATURES, function(e1, e2) { compare(e1, e2) <= 0L } ) ### The methods below are implemented on top of == and <=. setMethods("!=", .OP2_SIGNATURES, function(e1, e2) { !(e1 == e2) }) setMethods(">=", .OP2_SIGNATURES, function(e1, e2) { e2 <= e1 }) setMethods("<", .OP2_SIGNATURES, function(e1, e2) { !(e2 <= e1) }) setMethods(">", .OP2_SIGNATURES, function(e1, e2) { !(e1 <= e2) }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### selfmatch() ### ### The default "selfmatch" method below is implemented on top of match(). ### setGeneric("selfmatch", function(x, ...) standardGeneric("selfmatch")) ### Default "selfmatch" method. Args in ... are propagated to match(). setMethod("selfmatch", "ANY", function(x, ...) match(x, x, ...)) ### 'selfmatch_mapping' must be an integer vector like one returned by ### selfmatch(), that is, values are non-NAs and such that any value 'v' in it ### must appear for the first time at *position* 'v'. ### Such a vector can be seen as a many-to-one mapping that maps any position ### in the vector to a lower position and that has the additional property of ### being idempotent. ### More formally, any vector returned by selfmatch() has the 2 following ### properties: ### ### (1) for any 1 <= i <= length(selfmatch_mapping), ### selfmatch_mapping[i] must be >= 1 and <= i ### and ### ### (2) selfmatch_mapping[selfmatch_mapping] is the same as selfmatch_mapping ### ### reverseSelfmatchMapping() creates the "reverse mapping" as an ordinary ### list. reverseSelfmatchMapping <- function(selfmatch_mapping) { ans <- vector(mode="list", length=length(selfmatch_mapping)) sparse_ans <- split(seq_along(selfmatch_mapping), selfmatch_mapping) ans[as.integer(names(sparse_ans))] <- sparse_ans ans } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### duplicated() & unique() ### ### The "duplicated" method below is implemented on top of selfmatch(). ### The "unique" method below is implemented on top of duplicated(). ### ### S3/S4 combo for duplicated.Vector duplicated.Vector <- function(x, incomparables=FALSE, ...) { if (!identical(incomparables, FALSE)) stop("the \"duplicated\" method for Vector objects ", "only accepts 'incomparables=FALSE'") args <- list(...) if ("fromLast" %in% names(args)) { fromLast <- args$fromLast if (!isTRUEorFALSE(fromLast)) stop("'fromLast' must be TRUE or FALSE") args$fromLast <- NULL if (fromLast) x <- rev(x) } else { fromLast <- FALSE } xx <- do.call(selfmatch, c(list(x), args)) ans <- xx != seq_along(xx) if (fromLast) ans <- rev(ans) ans } setMethod("duplicated", "Vector", duplicated.Vector) ### S3/S4 combo for unique.Vector unique.Vector <- function(x, incomparables=FALSE, ...) { i <- !duplicated(x, incomparables=incomparables, ...) extractROWS(x, i) } setMethod("unique", "Vector", unique.Vector) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### %in% ### ### The method below is implemented on top of match(). ### setMethods("%in%", .OP2_SIGNATURES, function(x, table) { match(x, table, nomatch=0L) > 0L } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### findMatches() & countMatches() ### ### The default "findMatches" and "countMatches" methods below are ### implemented on top of match(). ### setGeneric("findMatches", signature=c("x", "table"), function(x, table, select=c("all", "first", "last"), ...) standardGeneric("findMatches") ) ### Equivalent to 'countQueryHits(findMatches(x, table))' but the default ### "countMatches" method below has a more efficient implementation. setGeneric("countMatches", signature=c("x", "table"), function(x, table, ...) standardGeneric("countMatches") ) ### Problem: using transpose=TRUE generates an invalid Hits object (hits are ### not ordered): ### > S4Vectors:::.findAllMatchesInSmallTable(1:6, c(7:5, 4:5), ### transpose=TRUE) ### Hits of length 4 ### queryLength: 5 ### subjectLength: 6 ### queryHits subjectHits ### ### 1 4 4 ### 2 3 5 ### 3 5 5 ### 4 2 6 ### and the cost of ordering them would probably defeat the purpose of the ### "put the smallest object on the right" optimization trick. .findAllMatchesInSmallTable <- function(x, table, ..., transpose=FALSE) { x2 <- match(x, table, ...) table2 <- selfmatch(table, ...) table_low2high <- reverseSelfmatchMapping(table2) hits_per_x <- table_low2high[x2] x_hits <- rep.int(seq_along(hits_per_x), sapply_NROW(hits_per_x)) if (length(x_hits) == 0L) { table_hits <- integer(0) } else { table_hits <- unlist(hits_per_x, use.names=FALSE) } if (transpose) { Hits(table_hits, x_hits, length(table), length(x)) } else { Hits(x_hits, table_hits, length(x), length(table)) } } ### Default "findMatches" method. Args in ... are propagated to match() and ### selfmatch(). setMethod("findMatches", c("ANY", "ANY"), function(x, table, select=c("all", "first", "last"), ...) { select <- match.arg(select) if (select != "all") stop("'select' is not supported yet. Note that you can use ", "match() if you want to do 'select=\"first\"'. Otherwise ", "you're welcome to request this on the Bioconductor ", "mailing list.") ## "put the smallest object on the right" optimization trick #if (length(x) < length(table)) # return(.findAllMatchesInSmallTable(table, x, ..., transpose=TRUE)) .findAllMatchesInSmallTable(x, table, ...) } ) ### Default "countMatches" method. Args in ... are propagated to match() and ### selfmatch(). .countMatches.default <- function(x, table, ...) { x_len <- length(x) table_len <- length(table) if (x_len <= table_len) { table2 <- match(table, x, ...) # can contain NAs nbins <- x_len x2 <- selfmatch(x, ...) # no NAs } else { table2 <- selfmatch(table, ...) # no NAs nbins <- table_len + 1L x2 <- match(x, table, nomatch=nbins, ...) } tabulate(table2, nbins=nbins)[x2] } setMethod("countMatches", c("ANY", "ANY"), .countMatches.default) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### sort() ### ### The method below is implemented on top of order(). ### ### S3/S4 combo for sort.Vector .sort.Vector <- function(x, decreasing=FALSE, na.last=NA, by) { if (!missing(by)) { i <- orderBy(by, x, decreasing=decreasing, na.last=na.last) } else { i <- order(x, na.last=na.last, decreasing=decreasing) } extractROWS(x, i) } sort.Vector <- function(x, decreasing=FALSE, ...) .sort.Vector(x, decreasing=decreasing, ...) setMethod("sort", "Vector", sort.Vector) formulaAsListCall <- function(formula) attr(terms(formula), "variables") orderBy <- function(formula, x, decreasing=FALSE, na.last=TRUE) { terms <- eval(formulaAsListCall(formula), as.env(x, environment(formula))) do.call(order, c(decreasing=decreasing, na.last=na.last, terms)) } setMethod("xtfrm", "Vector", function(x) { as.vector(rank(x, ties.method = "min", na.last = "keep")) }) setMethod("rank", "Vector", function(x, na.last=TRUE, ties.method=c("average", "first", "random", "max", "min")) { if (missing(ties.method)) { ties.method <- "first" } ties.method <- match.arg(ties.method) if (ties.method == "first") { oo <- order(x, na.last=na.last) ## 'ans' is the reverse permutation of 'oo' ans <- integer(length(oo)) ans[oo] <- seq_len(length(oo)) ans } else if (ties.method == "min") { rank(x, na.last=na.last, ties.method="first")[selfmatch(x)] } else { stop("only tie methods \"first\" and \"min\" are supported") } }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### table() ### ### The method below is implemented on top of selfmatch(), order(), and ### as.character(). ### ### This is a copy/paste of the list.names() function locally defined inside ### base::table(). .list.names <- function(...) { deparse.level <- 1 l <- as.list(substitute(list(...)))[-1L] nm <- names(l) fixup <- if (is.null(nm)) seq_along(l) else nm == "" dep <- vapply(l[fixup], function(x) switch(deparse.level + 1, "", if (is.symbol(x)) as.character(x) else "", deparse(x, nlines = 1)[1L]), "") if (is.null(nm)) dep else { nm[fixup] <- dep nm } } ### Works on any object for which selfmatch(), order(), and as.character() ### are supported. .compute_table <- function(x) { xx <- selfmatch(x) t <- tabulate(xx, nbins=length(xx)) keep_idx <- which(t != 0L) x2 <- x[keep_idx] t2 <- t[keep_idx] oo <- order(x2) x2 <- x2[oo] t2 <- t2[oo] ans <- array(t2) ## Some "as.character" methods propagate the names (e.g. the method for ## GenomicRanges objects). We drop them. dimnames(ans) <- list(unname(as.character(x2))) ans } setMethod("table", "Vector", function(...) { args <- list(...) if (length(args) != 1L) stop("\"table\" method for Vector objects ", "can only take one input object") x <- args[[1L]] ## Compute the table as an array. ans <- .compute_table(x) ## Some cosmetic adjustments. names(dimnames(ans)) <- .list.names(...) class(ans) <- "table" ans } ) S4Vectors/R/aggregate-methods.R0000644000175100017510000001726212607264536017364 0ustar00biocbuildbiocbuild### ========================================================================= ### "aggregate" methods ### ------------------------------------------------------------------------- ### ### This is messy and broken! E.g. ### ### aggregate(DataFrame(state.x77), FUN=mean, start=1:20, width=10) ### ### doesn't work as expected. Or: ### ### aggregate(Rle(2:-2, 5:9), FUN=mean, start=1:20, width=17) ### ### doesn't give the same result as: ### ### aggregate(rep(2:-2, 5:9), FUN=mean, start=1:20, width=17) ### ### See also the FIXME note down below (the one preceding the definition of ### the method for vector) for more mess. ### ### FIXME: Fix the aggregate() mess. Before fixing, it would be good to ### simplify by gettting rid of the 'frequency' and 'delta' arguments. ### Then the 'start', 'end', and 'width' arguments wouldn't be needed ### anymore because the user can aggregate by range by passing ### IRanges(start, end, width) to 'by'. After removing these arguments, ### the remaining arguments would be as in stats:::aggregate.data.frame. ### Finally make sure that, when 'by' is not a Ranges, the "aggregate" method ### for vector objects behaves exactly like stats:::aggregate.data.frame ### (the easiest way would be to delegate to it). ### ### A nice extension would be to have 'by' accept an IntegerList object, not ### just a Ranges (which is a special case of IntegerList), to let the user ### specify the subsets of 'x'. When 'by' is an IntegerList, aggregate() would ### be equivalent to: ### ### sapply(seq_along(by), ### function(i) FUN(x[by[[i]]], ...), simplify=simplify) ### ### This could be how it is implemented, except for the common use case where ### 'by' is a Ranges (needs special treatment in order to remain as fast as it ### is at the moment). This could even be extended to 'by' being a List (e.g. ### CharacterList, RleList, etc...) ### ### Other options (non-exclusive) to explore: ### ### (a) aggregateByRanges() new generic (should go in IRanges). aggregate() ### would simply delegate to it when 'by' is a Ranges object (but that ### means that the "aggregate" methods should also go in IRanges). ### ### (b) lapply/sapply on Views objects (but only works if Views(x, ...) ### works and views can only be created on a few specific types of ### objects). ### setMethod("aggregate", "matrix", stats:::aggregate.default) setMethod("aggregate", "data.frame", stats:::aggregate.data.frame) setMethod("aggregate", "ts", stats:::aggregate.ts) ### S3/S4 combo for aggregate.Vector aggregate.Vector <- function(x, by, FUN, start=NULL, end=NULL, width=NULL, frequency=NULL, delta=NULL, ..., simplify=TRUE) { FUN <- match.fun(FUN) if (!missing(by)) { if (is.list(by)) { ans <- aggregate(as.data.frame(x), by=by, FUN=FUN, ..., simplify=simplify) return(ans) } start <- structure(start(by), names=names(by)) end <- end(by) } else { if (!is.null(width)) { if (is.null(start)) start <- end - width + 1L else if (is.null(end)) end <- start + width - 1L } ## Unlike as.integer(), as( , "integer") propagates the names. start <- as(start, "integer") end <- as(end, "integer") } if (length(start) != length(end)) stop("'start', 'end', and 'width' arguments have unequal length") n <- length(start) if (!is.null(names(start))) indices <- structure(seq_len(n), names = names(start)) else indices <- structure(seq_len(n), names = names(end)) if (is.null(frequency) && is.null(delta)) { sapply(indices, function(i) FUN(window.Vector(x, start = start[i], end = end[i]), ...), simplify = simplify) } else { frequency <- rep(frequency, length.out = n) delta <- rep(delta, length.out = n) sapply(indices, function(i) FUN(window(x, start = start[i], end = end[i], frequency = frequency[i], delta = delta[i]), ...), simplify = simplify) } } setMethod("aggregate", "Vector", aggregate.Vector) ### FIXME: This "aggregate" method for vector overrides stats::aggregate() ### on vector without preserving its behavior! For example: ### ### aggregate(c(NA, 12:20), by=list(rep(1:2, 5)), is.unsorted, TRUE) ### ### doesn't give the same result if S4Vectors is loaded or not. ### As a general rule we should not mask base functionalities with our own, ### and even less when they behave differently. setMethod("aggregate", "vector", aggregate.Vector) ### S3/S4 combo for aggregate.Rle aggregate.Rle <- function(x, by, FUN, start=NULL, end=NULL, width=NULL, frequency=NULL, delta=NULL, ..., simplify=TRUE) { FUN <- match.fun(FUN) if (!missing(by)) { start <- structure(start(by), names=names(by)) end <- end(by) } else { if (!is.null(width)) { if (is.null(start)) start <- end - width + 1L else if (is.null(end)) end <- start + width - 1L } start <- as(start, "integer") end <- as(end, "integer") } if (length(start) != length(end)) stop("'start', 'end', and 'width' arguments have unequal length") n <- length(start) if (!is.null(names(start))) indices <- structure(seq_len(n), names = names(start)) else indices <- structure(seq_len(n), names = names(end)) if (is.null(frequency) && is.null(delta)) { info <- getStartEndRunAndOffset(x, start, end) runStart <- info[["start"]][["run"]] offsetStart <- info[["start"]][["offset"]] runEnd <- info[["end"]][["run"]] offsetEnd <- info[["end"]][["offset"]] ## Performance Optimization ## Use a stripped down loop with empty Rle object newRle <- new(class(x)) sapply(indices, function(i) FUN(.Call2("Rle_window", x, runStart[i], runEnd[i], offsetStart[i], offsetEnd[i], newRle, PACKAGE = "S4Vectors"), ...), simplify = simplify) } else { frequency <- rep(frequency, length.out = n) delta <- rep(delta, length.out = n) sapply(indices, function(i) FUN(window(x, start = start[i], end = end[i], frequency = frequency[i], delta = delta[i]), ...), simplify = simplify) } } setMethod("aggregate", "Rle", aggregate.Rle) ### S3/S4 combo for aggregate.List aggregate.List <- function(x, by, FUN, start=NULL, end=NULL, width=NULL, frequency=NULL, delta=NULL, ..., simplify=TRUE) { if (missing(by) || !requireNamespace("IRanges", quietly=TRUE) || !is(by, "RangesList")) { ans <- aggregate.Vector( x, by, FUN, start=start, end=end, width=width, frequency=frequency, delta=delta, ..., simplify=simplify) return(ans) } if (length(x) != length(by)) stop("for Ranges 'by', 'length(x) != length(by)'") y <- as.list(x) result <- lapply(structure(seq_len(length(x)), names = names(x)), function(i) aggregate(y[[i]], by = by[[i]], FUN = FUN, frequency = frequency, delta = delta, ..., simplify = simplify)) ans <- try(SimpleAtomicList(result), silent = TRUE) if (inherits(ans, "try-error")) ans <- new_SimpleList_from_list("SimpleList", result) ans } setMethod("aggregate", "List", aggregate.List) S4Vectors/R/eval-utils.R0000644000175100017510000000420512607264536016053 0ustar00biocbuildbiocbuild### ========================================================================= ### Helpers for environments and evaluation ### ------------------------------------------------------------------------- safeEval <- function(expr, envir, enclos, strict=FALSE) { expr <- eval(call("bquote", expr, enclos)) if (strict) { enclos <- makeGlobalWarningEnv(expr, envir, enclos) } eval(expr, envir, enclos) } makeGlobalWarningEnv <- function(expr, envir, enclos) { envir <- as.env(envir, enclos) globals <- setdiff(all.names(expr, functions=FALSE), ls(envir)) env <- new.env(parent=enclos) lapply(globals, function(g) { makeActiveBinding(g, function() { val <- get(g, enclos) warning("Symbol '", g, "' resolved from calling frame; ", "escape with .(", g, ") for safety.") val }, env) }) env } evalArg <- function(expr, envir, ..., where=parent.frame()) { enclos <- eval(call("top_prenv", expr, where)) expr <- eval(call("substitute", expr), where) safeEval(expr, envir, enclos, ...) } normSubsetIndex <- function(i) { i <- try(as.logical(i), silent=TRUE) if (inherits(i, "try-error")) stop("'subset' must be coercible to logical") i & !is.na(i) } missingArg <- function(arg, where=parent.frame()) { eval(call("missing", arg), where) } evalqForSubset <- function(expr, envir, ...) { if (missingArg(substitute(expr), parent.frame())) { TRUE } else { i <- evalArg(substitute(expr), envir, ..., where=parent.frame()) normSubsetIndex(i) } } evalqForSelect <- function(expr, df, ...) { if (missingArg(substitute(expr), parent.frame())) { rep(TRUE, ncol(df)) } else { nl <- as.list(seq_len(ncol(df))) names(nl) <- colnames(df) evalArg(substitute(expr), nl, ..., where=parent.frame()) } } top_prenv <- function(x, where=parent.frame()) { sym <- substitute(x) if (!is.name(sym)) { stop("'x' did not substitute to a symbol") } if (!is.environment(where)) { stop("'where' must be an environment") } .Call2("top_prenv", sym, where, PACKAGE="S4Vectors") } top_prenv_dots <- function(...) { .Call("top_prenv_dots", environment(), PACKAGE="S4Vectors") } S4Vectors/R/int-utils.R0000644000175100017510000004767712607264536015742 0ustar00biocbuildbiocbuild### ========================================================================= ### Some low-level (not exported) utility functions to operate on integer ### vectors ### ------------------------------------------------------------------------- anyMissingOrOutside <- function(x, lower = -.Machine$integer.max, upper = .Machine$integer.max) { if (!is.integer(x)) stop("'x' must be an integer vector") if (!is.integer(lower)) lower <- as.integer(lower) if (!is.integer(upper)) upper <- as.integer(upper) .Call2("Integer_any_missing_or_outside", x, lower, upper, PACKAGE="S4Vectors") } ### Returns 'sum(x)', or an error if 'x' contains NAs or negative values or if ### an integer overflow occurs while summing. sumNonNegInts <- function(x) .Call2("Integer_sum_non_neg_vals", x, PACKAGE="S4Vectors") ### Equivalent to (but much faster than): ### ### diff(c(0L, x)) ### ### except that NAs are not supported. diffWithInitialZero <- function(x) { if (!is.integer(x)) stop("'x' must be an integer vector") .Call2("Integer_diff_with_0", x, PACKAGE="S4Vectors") } ### Equivalent to (but much faster than): ### ### diff(c(x, last)) ### ### except that NAs are not supported. diffWithLast <- function(x, last) { if (!is.integer(x)) stop("'x' must be an integer vector") if (!isSingleInteger(last)) stop("'last' must be a single, non-NA integer") .Call2("Integer_diff_with_last", x, last, PACKAGE="S4Vectors") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Fast ordering of an integer vector. ### ### We want this ordering to be "stable". orderInteger <- function(x, decreasing=FALSE, na.last=NA) { if (is.factor(x)) { input_is_factor <- TRUE x_delta <- length(levels(x)) - 1L x <- as.integer(x) } else { if (!is.integer(x)) stop("'x' must be an integer vector or a factor") input_is_factor <- FALSE } x_min <- suppressWarnings(min(x, na.rm=TRUE)) if (x_min == Inf) { if (is.na(na.last)) return(integer(0)) else return(seq_len(length(x))) } ## At this point 'x' is guaranteed to contain at least one non NA value. has_NAs <- anyNA(x) if (!has_NAs && !decreasing && isStrictlySorted(x)) { return(seq_along(x)) } if (!input_is_factor) x_delta <- max(x, na.rm=TRUE) - x_min if (x_delta < 100000L) { if (!has_NAs) { na.last <- TRUE } ## "radix" method is stable. return(sort.list(x, decreasing=decreasing, na.last=na.last, method="radix")) } if (!has_NAs || is.na(na.last)) { if (has_NAs) x <- x[!is.na(x)] ## Uses _get_order_of_int_array() at the C level which is stable. return(.Call2("Integer_order", x, decreasing, PACKAGE="S4Vectors")) } ## At this point 'x' has NAs and we must keep them ('na.last' is not NA). ## We can't use sort.list() with method="quick" or method="shell" here ## because they are not stable algorithms (and in addition method="quick" ## is only supported when 'na.last' is NA). So we use order() with an ## extra vector to break ties, which is a trick to make it stable. ## Unfortunately this is very inefficient (about twice slower than ## using sort.list() with method="shell"). ## TODO: Modify .Call entry point Integer_order to support 'na.last' arg. if (decreasing) y <- length(x):1L else y <- seq_len(length(x)) order(x, y, decreasing=decreasing, na.last=na.last) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Fast ordering/comparing of integer pairs. ### .normargIntegerOrFactor <- function(arg, argname) { if (is.factor(arg)) arg <- as.integer(arg) else if (is(arg, "Rle") && (is(runValue(arg), "integer") || is(runValue(arg), "factor"))) arg <- as.integer(arg) else if (!is.integer(arg)) stop("'", argname, "' must be an integer vector or factor") arg } .normargMethod <- function(method=c("auto", "quick", "hash"), a_len) { method <- match.arg(method) if (method == "auto") { if (a_len <= 2^29) method <- "hash" else method <- "quick" } method } compareIntegerPairs <- function(a1, b1, a2, b2) { a1 <- .normargIntegerOrFactor(a1, "a1") b1 <- .normargIntegerOrFactor(b1, "b1") if (length(a1) != length(b1)) stop("'a1' and 'b1' must have the same length") a2 <- .normargIntegerOrFactor(a2, "a2") b2 <- .normargIntegerOrFactor(b2, "b2") if (length(a2) != length(b2)) stop("'a2' and 'b2' must have the same length") .Call2("Integer_compare2", a1, b1, a2, b2, PACKAGE="S4Vectors") } sortedIntegerPairs <- function(a, b, decreasing=FALSE, strictly=FALSE) { a <- .normargIntegerOrFactor(a, "a") b <- .normargIntegerOrFactor(b, "b") .Call2("Integer_sorted2", a, b, decreasing, strictly, PACKAGE="S4Vectors") } ### For 'a' and 'b' integer vectors of equal length with no NAs, ### 'orderIntegerPairs(a, b)' is equivalent to (but faster than): ### ### order(a, b) ### ### Benchmarking: ### ### # Generating random pairs (representing ranges). ### library(S4Vectors) ### N <- 20000000L # nb of ranges ### W <- 40L # average width of the ranges ### max_end <- 55000000L ### set.seed(777) ### a <- sample(max_end - W - 2L, N, replace=TRUE) ### b <- W + sample(-3:3, N, replace=TRUE) ### ## Takes < 10 sec.: ### oo <- S4Vectors:::orderIntegerPairs(a, b) ### ## Takes about 1 min.: ### oo2 <- order(a, b) ### identical(oo, oo2) # TRUE ### ### For efficiency reasons, we don't support (and don't even check) for NAs. orderIntegerPairs <- function(a, b, decreasing=FALSE) { a <- .normargIntegerOrFactor(a, "a") b <- .normargIntegerOrFactor(b, "b") .Call2("Integer_order2", a, b, decreasing, PACKAGE="S4Vectors") } .matchIntegerPairs_quick <- function(a1, b1, a2, b2, nomatch=NA_integer_) { .Call2("Integer_match2_quick", a1, b1, a2, b2, nomatch, PACKAGE="S4Vectors") } .matchIntegerPairs_hash <- function(a1, b1, a2, b2, nomatch=NA_integer_) { .Call2("Integer_match2_hash", a1, b1, a2, b2, nomatch, PACKAGE="S4Vectors") } matchIntegerPairs <- function(a1, b1, a2, b2, nomatch=NA_integer_, method=c("auto", "quick", "hash")) { a1 <- .normargIntegerOrFactor(a1, "a1") b1 <- .normargIntegerOrFactor(b1, "b1") if (length(a1) != length(b1)) stop("'a1' and 'b1' must have the same length") a2 <- .normargIntegerOrFactor(a2, "a2") b2 <- .normargIntegerOrFactor(b2, "b2") if (length(a2) != length(b2)) stop("'a2' and 'b2' must have the same length") if (!isSingleNumberOrNA(nomatch)) stop("'nomatch' must be a single number or NA") if (!is.integer(nomatch)) nomatch <- as.integer(nomatch) method <- .normargMethod(method, length(a2)) if (method == "quick") { ans <- .matchIntegerPairs_quick(a1, b1, a2, b2, nomatch=nomatch) } else { ans <- .matchIntegerPairs_hash(a1, b1, a2, b2, nomatch=nomatch) } ans } .selfmatchIntegerPairs_quick <- function(a, b) { .Call2("Integer_selfmatch2_quick", a, b, PACKAGE="S4Vectors") } ### Author: Martin Morgan .selfmatchIntegerPairs_hash <- function(a, b) { .Call2("Integer_selfmatch2_hash", a, b, PACKAGE="S4Vectors") } selfmatchIntegerPairs <- function(a, b, method=c("auto", "quick", "hash")) { a <- .normargIntegerOrFactor(a, "a") b <- .normargIntegerOrFactor(b, "b") if (length(a) != length(b)) stop("'a' and 'b' must have the same length") method <- .normargMethod(method, length(a)) if (method == "quick") { ans <- .selfmatchIntegerPairs_quick(a, b) } else { ans <- .selfmatchIntegerPairs_hash(a, b) } ans } ### For 'a' and 'b' integer vectors of equal length with no NAs, ### 'duplicatedIntegerPairs(a, b)' is equivalent to (but much faster than): ### ### duplicated(cbind(a, b)) ### ### For efficiency reasons, we don't support (and don't even check) for NAs. duplicatedIntegerPairs <- function(a, b, fromLast=FALSE, method=c("auto", "quick", "hash")) { a <- .normargIntegerOrFactor(a, "a") b <- .normargIntegerOrFactor(b, "b") if (length(a) != length(b)) stop("'a' and 'b' must have the same length") if (!isTRUEorFALSE(fromLast)) stop("'fromLast' must be TRUE or FALSE") if (length(a) == 0L) return(logical(0L)) if (length(a) == 1L) return(FALSE) ## This is a temporary (and inefficient) workaround until "quick" ## and "hash" methods can natively support fromLast=TRUE. ## TODO: Add support for fromLast=TRUE to "quick" and "hash" methods. if (fromLast) return(rev(duplicatedIntegerPairs(rev(a), rev(b), method=method))) sm <- selfmatchIntegerPairs(a, b, method=method) sm != seq_len(length(sm)) } ### For 'a' and 'b' integer vectors of equal length with no NAs, ### 'runEndsOfIntegerPairs(a, b)' finds the runs of identical rows in ### 'cbind(a, b)' and returns the indices of the last row in each run. ### In other words, it's equivalent to (but much faster than): ### ### cumsum(runLength(Rle(paste(a, b, sep="|")))) ### ### Note that, if the rows in 'cbind(a, b)' are already sorted, then ### 'runEndsOfIntegerPairs(a, b)' returns the indices of the unique rows. ### In other words, 'runEndsOfIntegerPairs()' could be used to efficiently ### extract the unique pairs of integers from a presorted set of pairs. ### However, at the moment (April 2011) using 'duplicatedIntegerPairs()' ### is still faster than using 'runEndsOfIntegerPairs()' for finding the ### duplicated or unique pairs of integers in a presorted set of pairs. ### But this only because 'runEndsOfIntegerPairs()' is not as fast as it ### could/should be (an all-in-C implementation would probably solve this). ### ### For efficiency reasons, we don't support (and don't even check) for NAs. ### TODO: What happens if 'a' and 'b' don't have the same length? Shouldn't ### we check for that? runEndsOfIntegerPairs <- function(a, b) { not_same_as_prev <- diffWithInitialZero(a) != 0L | diffWithInitialZero(b) != 0L if (length(not_same_as_prev) == 0L) return(integer()) which(c(not_same_as_prev[-1L], TRUE)) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Fast ordering/comparing of integer quadruplets. ### ### For 'a', 'b', 'c' and 'd' integer vectors of equal length with no NAs, ### 'orderIntegerQuads(a, b, c, d)' is equivalent to (but faster than): ### ### order(a, b, c, d) ### ### For efficiency reasons, we don't support (and don't even check) for NAs. orderIntegerQuads <- function(a, b, c, d, decreasing=FALSE) { a <- .normargIntegerOrFactor(a, "a") b <- .normargIntegerOrFactor(b, "b") c <- .normargIntegerOrFactor(c, "c") d <- .normargIntegerOrFactor(d, "d") .Call2("Integer_order4", a, b, c, d, decreasing, PACKAGE="S4Vectors") } .matchIntegerQuads_quick <- function(a1, b1, c1, d1, a2, b2, c2, d2, nomatch=NA_integer_) { .Call2("Integer_match4_quick", a1, b1, c1, d1, a2, b2, c2, d2, nomatch, PACKAGE="S4Vectors") } .matchIntegerQuads_hash <- function(a1, b1, c1, d1, a2, b2, c2, d2, nomatch=NA_integer_) { .Call2("Integer_match4_hash", a1, b1, c1, d1, a2, b2, c2, d2, nomatch, PACKAGE="S4Vectors") } matchIntegerQuads <- function(a1, b1, c1, d1, a2, b2, c2, d2, nomatch=NA_integer_, method=c("auto", "quick", "hash")) { a1 <- .normargIntegerOrFactor(a1, "a1") b1 <- .normargIntegerOrFactor(b1, "b1") c1 <- .normargIntegerOrFactor(c1, "c1") d1 <- .normargIntegerOrFactor(d1, "d1") if (length(a1) != length(b1) || length(b1) != length(c1) || length(c1) != length(d1)) stop("'a1', 'b1', 'c1' and 'd1' must have the same length") a2 <- .normargIntegerOrFactor(a2, "a2") b2 <- .normargIntegerOrFactor(b2, "b2") c2 <- .normargIntegerOrFactor(c2, "c2") d2 <- .normargIntegerOrFactor(d2, "d2") if (length(a2) != length(b2) || length(b2) != length(c2) || length(c2) != length(d2)) stop("'a2', 'b2', 'c2' and 'd2' must have the same length") if (!isSingleNumberOrNA(nomatch)) stop("'nomatch' must be a single number or NA") if (!is.integer(nomatch)) nomatch <- as.integer(nomatch) method <- .normargMethod(method, length(a2)) if (method == "quick") { ans <- .matchIntegerQuads_quick(a1, b1, c1, d1, a2, b2, c2, d2, nomatch=nomatch) } else { ans <- .matchIntegerQuads_hash(a1, b1, c1, d1, a2, b2, c2, d2, nomatch=nomatch) } ans } .selfmatchIntegerQuads_quick <- function(a, b, c, d) { .Call2("Integer_selfmatch4_quick", a, b, c, d, PACKAGE="S4Vectors") } .selfmatchIntegerQuads_hash <- function(a, b, c, d) { .Call2("Integer_selfmatch4_hash", a, b, c, d, PACKAGE="S4Vectors") } selfmatchIntegerQuads <- function(a, b, c, d, method=c("auto", "quick", "hash")) { a <- .normargIntegerOrFactor(a, "a") b <- .normargIntegerOrFactor(b, "b") c <- .normargIntegerOrFactor(c, "c") d <- .normargIntegerOrFactor(d, "d") if (length(a) != length(b) || length(b) != length(c) || length(c) != length(d)) stop("'a', 'b', 'c' and 'd' must have the same length") method <- .normargMethod(method, length(a)) if (method == "quick") { ans <- .selfmatchIntegerQuads_quick(a, b, c, d) } else { ans <- .selfmatchIntegerQuads_hash(a, b, c, d) } ans } duplicatedIntegerQuads <- function(a, b, c, d, fromLast=FALSE, method=c("auto", "quick", "hash")) { a <- .normargIntegerOrFactor(a, "a") b <- .normargIntegerOrFactor(b, "b") c <- .normargIntegerOrFactor(c, "c") d <- .normargIntegerOrFactor(d, "d") if (length(a) != length(b) || length(b) != length(c) || length(c) != length(d)) stop("'a', 'b', 'c' and 'd' must have the same length") if (!isTRUEorFALSE(fromLast)) stop("'fromLast' must be TRUE or FALSE") if (length(a) == 0L) return(logical(0L)) if (length(a) == 1L) return(FALSE) ## This is a temporary (and inefficient) workaround until "quick" ## and "hash" methods can natively support fromLast=TRUE. ## TODO: Add support for fromLast=TRUE to "quick" and "hash" methods. if (fromLast) return(rev(duplicatedIntegerQuads(rev(a), rev(b), rev(c), rev(d), method=method))) sm <- selfmatchIntegerQuads(a, b, c, d, method=method) sm != seq_len(length(sm)) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### tabulate2() ### ### An enhanced version of base::tabulate() that: (1) handles integer weights ### (NA and negative weights are OK), and (2) throws an error if 'strict' is ### TRUE and if 'x' contains NAs or values not in the [1, 'nbins'] interval. ### Unlike with base::tabulate(), 'nbins' needs to be specified (no default ### value). Also for now, it only works if 'x' is an integer vector. ### tabulate2 <- function(x, nbins, weight=1L, strict=FALSE) { if (!is.integer(x)) stop("'x' must be an integer vector") if (!isSingleNumber(nbins)) stop("'nbins' must be a single integer") if (!is.integer(nbins)) nbins <- as.integer(nbins) if (!is.integer(weight)) stop("'weight' must be an integer vector") if (!isTRUEorFALSE(strict)) stop("'strict' must be TRUE or FALSE") .Call2("Integer_tabulate2", x, nbins, weight, strict, PACKAGE="S4Vectors") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Bitwise operations. ### ### The bitwise operations in this section don't treat the integer NA (aka ### NA_integer_) in any particular way: at the C level an NA_integer_ is ### just a 32-bit pattern like any other int in C. ### makePowersOfTwo <- function(nbit) { if (!isSingleInteger(nbit) || nbit < 0L) stop("'nbit' must be a single non-negative integer") if (nbit == 0L) return(integer(0)) as.integer(cumprod(c(1L, rep.int(2L, nbit-1L)))) } ### Returns an integer matrix with 'length(x)' rows and 'length(bitpos)' cols. explodeIntBits <- function(x, bitpos=1:32) { if (!is.integer(x)) stop("'x' must be an integer vector") if (!is.integer(bitpos)) stop("'bitpos' must be an integer vector") ## Old implementation: not very efficient and also broken on NAs and ## negative integers! #if (length(bitpos) == 0L) # return(matrix(nrow=length(x), ncol=0L)) #nbit <- max(bitpos) #if (is.na(nbit) || min(bitpos) <= 0L) # stop("'bitpos' must contain potive values only") #ans <- matrix(nrow=length(x), ncol=nbit) #for (i in seq_len(ncol(ans))) { # ans[ , i] <- x %% 2L # x <- x %/% 2L #} #ans[ , bitpos, drop=FALSE] .Call2("Integer_explode_bits", x, bitpos, PACKAGE="S4Vectors") } ### FIXME: Broken if ncol(x) = 32. implodeIntBits <- function(x) { if (!is.matrix(x)) stop("'x' must be a matrix") tx <- t(x) data <- tx * makePowersOfTwo(nrow(tx)) ## In some circumstances (e.g. if 'tx' has 0 col), the "dim" attribute ## gets lost during the above multiplication. if (is.null(dim(data))) dim(data) <- dim(tx) as.integer(colSums(data)) } intbitsNOT <- function(x) { stop("not yet implemented") # fix implodeIntBits() first! xbits <- explodeIntBits(x) implodeIntBits(!xbits) } intbitsAND <- function(x, y) { stop("not yet implemented") # fix implodeIntBits() first! xbits <- explodeIntBits(x) ybits <- explodeIntBits(y) implodeIntBits(xbits & ybits) } intbitsOR <- function(x, y) { stop("not yet implemented") # fix implodeIntBits() first! xbits <- explodeIntBits(x) ybits <- explodeIntBits(y) implodeIntBits(xbits | ybits) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Others. ### sortedMerge <- function(x, y) .Call2("Integer_sorted_merge", x, y, PACKAGE="S4Vectors") mseq <- function(from, to) { if (!is.integer(from)) from <- as.integer(from) if (!is.integer(to)) to <- as.integer(to) .Call2("Integer_mseq", from, to, PACKAGE="S4Vectors") } fancy_mseq <- function(lengths, offset=0L, rev=FALSE) { if (!is.integer(lengths)) lengths <- as.integer(lengths) if (!is.integer(offset)) offset <- as.integer(offset) if (!is.logical(rev)) stop("'rev' must be a logical vector") #unlist(lapply(seq_len(length(lengths)), # function(i) { # tmp <- seq_len(lengths[i]) + offset[i] # if (rev[i]) # tmp <- rev(tmp) # tmp # })) .Call2("Integer_fancy_mseq", lengths, offset, rev, PACKAGE="S4Vectors") } make_XYZxyz_to_XxYyZz_subscript <- function(N) as.vector(matrix(seq_len(2L * N), nrow=2L, byrow=TRUE)) findIntervalAndStartFromWidth <- function(x, width) .Call2("findIntervalAndStartFromWidth", x, width, PACKAGE="S4Vectors") ### Reverse an injection from 1:M to 1:N. ### The injection is represented by an integer vector of length M (eventually ### with NAs). Fundamental property: ### ### reverseIntegerInjection(reverseIntegerInjection(injection, N), M) ### ### is the identity function. ### Can be used to efficiently reverse the result of a call to 'order()'. reverseIntegerInjection <- function(injection, N) { M <- length(injection) ans <- rep.int(NA_integer_, N) is_not_na <- !is.na(injection) ans[injection[is_not_na]] <- seq_len(M)[is_not_na] ans } S4Vectors/R/isSorted.R0000644000175100017510000001465612607264536015575 0ustar00biocbuildbiocbuild### ========================================================================= ### isConstant(), isSorted(), isStrictlySorted() ### ------------------------------------------------------------------------- ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### isConstant() ### setGeneric("isConstant", function(x) standardGeneric("isConstant")) ### There are many ways to implement the "isConstant" method for integer ### vectors: ### isConstant1 <- function(x) {length(x) <= 1L || all(x == x[1L])} ### isConstant2 <- function(x) {length(unique(x)) <= 1L} ### isConstant3 <- function(x) {length(x) <= 1L || all(duplicated(x)[-1L])} ### isConstant4 <- function(x) {length(x) <= 1L || ### sum(duplicated(x)) == length(x) - 1L} ### isConstant5 <- function(x) {length(x) <= 1L || min(x) == max(x)} ### isConstant6 <- function(x) {length(x) <= 1L || ### {rx <- range(x); rx[1L] == rx[2L]}} ### Which one is faster is hard to guess. It happens to be isConstant5(): ### it's 2.7x faster than isConstant1(), 6x faster than isConstant2(), 11x ### faster than isConstant3(), 5.2x faster than isConstant4() and 1.6x faster ### than isConstant6(). ### Results obtained on 'x0 <- rep.int(112L, 999999L)' with R-2.13 Under ### development (unstable) (2011-01-08 r53945). ### For this method we use a modified version of isConstant5() above that ### handles NAs. setMethod("isConstant", "integer", function(x) { if (length(x) <= 1L) return(TRUE) x_min <- min(x, na.rm=FALSE) if (!is.na(x_min)) # success means 'x' contains no NAs return(x_min == max(x, na.rm=FALSE)) ## From here 'x' is guaranteed to have a length >= 2 and to contain ## at least an NA. ## 'min(x, na.rm=TRUE)' issues a warning if 'x' contains only NAs. ## In that case, and in that case only, it returns Inf. x_min <- suppressWarnings(min(x, na.rm=TRUE)) if (x_min == Inf) return(NA) ## From here 'x' is guaranteed to contain a mix of NAs and non-NAs. x_max <- max(x, na.rm=TRUE) if (x_min == x_max) return(NA) FALSE } ) ### Like the method for integer vectors this method also uses a comparison ### between min(x) and max(x). In addition it needs to handle rounding errors ### and special values: NA, NaN, Inf and -Inf. ### Using all.equal() ensures that TRUE is returned on c(11/3, 2/3+4/3+5/3). setMethod("isConstant", "numeric", function(x) { if (length(x) <= 1L) return(TRUE) x_min <- min(x, na.rm=FALSE) if (!is.na(x_min)) { # success means 'x' contains no NAs and no NaNs x_max <- max(x, na.rm=FALSE) if (is.finite(x_min) && is.finite(x_max)) return(isTRUE(all.equal(x_min, x_max))) if (x_min == x_max) # both are Inf or both are -Inf return(NA) return(FALSE) } ## From here 'x' is guaranteed to have a length >= 2 and to contain ## at least an NA or NaN. ## 'min(x, na.rm=TRUE)' issues a warning if 'x' contains only NAs ## and NaNs. x_min <- suppressWarnings(min(x, na.rm=TRUE)) if (x_min == Inf) { ## Only possible values in 'x' are NAs, NaNs or Infs. is_in_x <- c(NA, NaN, Inf) %in% x if (is_in_x[2L] && is_in_x[3L]) return(FALSE) return(NA) } ## From here 'x' is guaranteed to contain at least one value that is ## not NA or NaN or Inf. x_max <- max(x, na.rm=TRUE) if (x_max == -Inf) { ## Only possible values in 'x' are NAs, NaNs or -Infs. is_in_x <- c(NA, NaN, -Inf) %in% x if (is_in_x[2L] && is_in_x[3L]) return(FALSE) return(NA) } if (is.infinite(x_min) || is.infinite(x_max)) return(FALSE) if (!isTRUE(all.equal(x_min, x_max))) return(FALSE) if (NaN %in% x) return(FALSE) return(NA) } ) setMethod("isConstant", "array", function(x) isConstant(as.vector(x))) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### isNotSorted(), isNotStrictlySorted() ### ### NOT exported. ### ### isNotStrictlySorted() takes for granted that 'x' contains no NAs (behaviour ### is undefined if this is not the case). This allows isNotStrictlySorted() to ### be MUCH faster than is.unsorted() in some situations: ### > x <- c(99L, 1:1000000) ### > system.time(for (i in 1:1000) isNotStrictlySorted(x)) ### user system elapsed ### 0.004 0.000 0.003 ### > system.time(for (i in 1:1000) is.unsorted(x, strictly=TRUE)) ### user system elapsed ### 6.925 1.756 8.690 ### So let's keep it for now! Until someone has enough time and energy to ### convince the R core team to fix is.unsorted()... ### Note that is.unsorted() does not only have a performance problem: ### a) It also has a semantic problem: is.unsorted(NA) returns NA despite the ### man page stating that all objects of length 0 or 1 are sorted (sounds ### like a fair statement). ### b) The sort()/is.unsorted() APIs and semantics are inconsistent. ### c) Why did they choose to have is.unsorted() instead of is.sorted() in the ### first place? Having is.unsorted( , strictly=TRUE) being a "looser test" ### (or a "weaker condition") than is.unsorted( , strictly=FALSE) is really ### counterintuitive! ### > is.unsorted(c(5L, 5:8), strictly=FALSE) ### [1] FALSE ### > is.unsorted(c(5L, 5:8), strictly=TRUE) ### [1] TRUE ### Common sense would expect to have less objects that are "strictly ### something" than objects that are "just something". ..Internal <- .Internal # a silly trick to keep 'R CMD check' quiet isNotSorted <- function(x) ..Internal(is.unsorted(x, FALSE)) isNotStrictlySorted <- function(x) ..Internal(is.unsorted(x, TRUE)) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### isSorted() ### setGeneric("isSorted", function(x) standardGeneric("isSorted")) setMethod("isSorted", "ANY", function(x) !isNotSorted(x)) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### isStrictlySorted() ### setGeneric("isStrictlySorted", function(x) standardGeneric("isStrictlySorted") ) setMethod("isStrictlySorted", "ANY", function(x) !isNotStrictlySorted(x)) S4Vectors/R/logical-utils.R0000644000175100017510000000172212607264536016537 0ustar00biocbuildbiocbuild### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Basic manipulation of a "compact bit vector" i.e. a bit vector stored in ### a standard raw vector. ### logicalAsCompactBitvector <- function(x) { if (!is.logical(x)) stop("'x' must be a logical vector") .Call2("logical_as_compact_bitvector", x, PACKAGE="S4Vectors") } compactBitvectorAsLogical <- function(x, length.out) { if (!is.raw(x)) stop("'x' must be a raw vector") if (!isSingleNumber(length.out)) stop("'length.out' must be a single number") if (!is.integer(length.out)) length.out <- as.integer(length.out) .Call2("compact_bitvector_as_logical", x, length.out, PACKAGE="S4Vectors") } subsetCompactBitvector <- function(x, i) { if (!is.raw(x)) stop("'x' must be a raw vector") if (!is.integer(i)) stop("'i' must be an integer vector") .Call2("subset_compact_bitvector", x, i, PACKAGE="S4Vectors") } S4Vectors/R/normarg-utils.R0000644000175100017510000003146712607264536016603 0ustar00biocbuildbiocbuild### ========================================================================= ### Utility functions for checking/fixing user-supplied arguments ### ------------------------------------------------------------------------- ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### For checking only. ### isTRUEorFALSE <- function(x) { is.logical(x) && length(x) == 1L && !is.na(x) } isSingleInteger <- function(x) { is.integer(x) && length(x) == 1L && !is.na(x) } isSingleNumber <- function(x) { is.numeric(x) && length(x) == 1L && !is.na(x) } isSingleString <- function(x) { is.character(x) && length(x) == 1L && !is.na(x) } ### We want these functions to return TRUE when passed an NA of whatever type. isSingleNumberOrNA <- function(x) { is.atomic(x) && length(x) == 1L && (is.numeric(x) || is.na(x)) } isSingleStringOrNA <- function(x) { is.atomic(x) && length(x) == 1L && (is.character(x) || is.na(x)) } ### NOT exported. anyMissing <- function(x) .Call2("anyMissing", x, PACKAGE="S4Vectors") ### NOT exported. isNumericOrNAs <- function(x) { is.numeric(x) || (is.atomic(x) && is.vector(x) && all(is.na(x))) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Vertical/horiontal recycling of a vector-like/list-like object. ### ### Vertical recycling (of any vector-like object). ### NOT exported. V_recycle <- function(x, skeleton, x_what="x", skeleton_what="skeleton") { x_len <- length(x) skeleton_len <- length(skeleton) if (x_len == skeleton_len) return(x) if (x_len > skeleton_len && x_len != 1L) stop(wmsg( "'", x_what, "' cannot be longer than '", skeleton_what, "'" )) if (x_len == 0L) stop(wmsg( "'", x_what, "' is a zero-length object but '", skeleton_what, "' is not" )) if (skeleton_len %% x_len != 0L) warning(wmsg( "'length(", skeleton_what, ")' is not a multiple of 'length(", x_what, ")'" )) rep(x, length.out=skeleton_len) } ### Horizontal recycling (of a list-like object only). ### NOT exported. H_recycle <- function(x, skeleton, x_what="x", skeleton_what="skeleton", more_blahblah=NA) { stopifnot(is.list(x) || is(x, "List")) stopifnot(is.list(skeleton) || is(skeleton, "List")) x_len <- length(x) skeleton_len <- length(skeleton) stopifnot(x_len == skeleton_len) x_what2 <- paste0("some list elements in '", x_what, "'") if (!is.na(more_blahblah)) x_what2 <- paste0(x_what2, " (", more_blahblah, ")") x_eltlens <- unname(elementLengths(x)) skeleton_eltlens <- unname(elementLengths(skeleton)) idx <- which(x_eltlens != skeleton_eltlens) if (length(idx) == 0L) return(x) longer_idx <- which(x_eltlens > skeleton_eltlens) shorter_idx <- which(x_eltlens < skeleton_eltlens) if (length(longer_idx) == 0L && length(shorter_idx) == 0L) return(x) if (length(longer_idx) != 0L) { if (max(x_eltlens[longer_idx]) >= 2L) stop(wmsg( x_what2, " are longer than their corresponding ", "list element in '", skeleton_what, "'" )) } if (length(shorter_idx) != 0L) { tmp <- x_eltlens[shorter_idx] if (min(tmp) == 0L) stop(wmsg( x_what2, " are of length 0, but their corresponding ", "list element in '", skeleton_what, "' is not" )) if (max(tmp) >= 2L) stop(wmsg( x_what2, " are shorter than their corresponding ", "list element in '", skeleton_what, "', but have ", "a length >= 2. \"Horizontal\" recycling only supports ", "list elements of length 1 at the moment." )) } ## From here 'x[idx]' is guaranteed to contain list elements of length 1. ## We use an "unlist => stretch => relist" algo to perform the horizontal ## recycling. Because of this, the returned value is not necessary of the ## same class as 'x' (e.g. can be an IntegerList if 'x' is an ordinary ## list of integers and 'skeleton' a List object). unlisted_x <- unlist(x, use.names=FALSE) times <- rep.int(1L, length(unlisted_x)) idx2 <- cumsum(x_eltlens)[idx] times[idx2] <- skeleton_eltlens[idx] unlisted_ans <- rep.int(unlisted_x, times) ans <- relist(unlisted_ans, skeleton) names(ans) <- names(x) ans } ### Performs first vertical then horizontal recycling (of a list-like object ### only). ### NOT exported. VH_recycle <- function(x, skeleton, x_what="x", skeleton_what="skeleton", more_blahblah=NA) { x <- V_recycle(x, skeleton, x_what=x_what, skeleton_what=skeleton_what) H_recycle(x, skeleton, x_what=x_what, skeleton_what=skeleton_what, more_blahblah=more_blahblah) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### More recycling of a vector-like object. ### ### TODO: This section needs to be cleaned. Some of the stuff in it is ### redundant with and superseded by V_recycle() and/or H_recycle() (defined ### in the previous section). ### ### NOT exported. ### recycleVector() vs rep(x, length.out=length): ### - The former seems a little bit faster (1.5x - 2x). ### - The former will issue a warning that "number of items to replace is not ### a multiple of replacement length". The latter will always remain silent. recycleVector <- function(x, length.out) { if (length(x) == length.out) { x } else { ans <- vector(storage.mode(x), length.out) ans[] <- x ans } } ### Must always drop the names of 'arg'. recycleArg <- function(arg, argname, length.out) { if (length.out == 0L) { if (length(arg) > 1L) stop("invalid length for '", argname, "'") if (length(arg) == 1L && is.na(arg)) stop("'", argname, "' contains NAs") return(recycleVector(arg, length.out)) # drops the names } if (length(arg) == 0L) stop("'", argname, "' has no elements") if (length(arg) > length.out) stop("'", argname, "' is longer than 'x'") if (anyMissing(arg)) stop("'", argname, "' contains NAs") if (length(arg) < length.out) arg <- recycleVector(arg, length.out) # drops the names else arg <- unname(arg) arg } recycleIntegerArg <- function(arg, argname, length.out) { if (!is.numeric(arg)) stop("'", argname, "' must be a vector of integers") if (!is.integer(arg)) arg <- as.integer(arg) recycleArg(arg, argname, length.out) } recycleNumericArg <- function(arg, argname, length.out) { if (!is.numeric(arg)) stop("'", argname, "' must be a numeric vector") recycleArg(arg, argname, length.out) } recycleLogicalArg <- function(arg, argname, length.out) { if (!is.logical(arg)) stop("'", argname, "' must be a logical vector") recycleArg(arg, argname, length.out) } recycleCharacterArg <- function(arg, argname, length.out) { if (!is.character(arg)) stop("'", argname, "' must be a character vector") recycleArg(arg, argname, length.out) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Normalization of replacement values ### ### NOT exported. normalize_names_replacement_value <- function(value, x) { if (is.null(value)) return(NULL) value <- as.character(value) value_len <- length(value) x_len <- length(x) if (value_len > x_len) stop(wmsg("attempt to set too many names (", value_len, ") ", "on ", class(x), " object of length ", x_len)) if (value_len < x_len) { ## We pad with NA's to mimic what 'names(x) <- value' does on an ## ordinary vector. value <- c(value, rep.int(NA_character_, x_len - value_len)) } value } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Fold a vector-like object. ### ### We use a signature in the style of IRanges::successiveIRanges() or ### IRanges::successiveViews(). ### The current implementation should be fast enough if length(x)/circle.length ### is small (i.e. < 10 or 20). This will actually be the case for the typical ### usecase which is the calculation of "circular coverage vectors", that is, ### we use fold() on the "linear coverage vector" to turn it into a "circular ### coverage vector" of length 'circle.length' where 'circle.length' is the ### length of the circular sequence. fold <- function(x, circle.length, from=1) { if (typeof(x) != "S4" && !is.numeric(x) && !is.complex(x)) stop("'x' must be a vector-like object with elements that can be added") if (!isSingleNumber(circle.length)) stop("'circle.length' must be a single integer") if (!is.integer(circle.length)) circle.length <- as.integer(circle.length) if (circle.length <= 0L) stop("'circle.length' must be positive") if (!isSingleNumber(from)) stop("'from' must be a single integer") if (!is.integer(from)) from <- as.integer(from) from <- 1L + (from - 1L) %% circle.length if (typeof(x) == "S4") { ans <- as(rep.int(0L, circle.length), class(x)) if (length(ans) != circle.length) stop("don't know how to handle 'x' of class ", class(x)) } else { ans <- vector(typeof(x), length=circle.length) } if (from > length(x)) { ## Nothing to fold jj <- seq_len(length(x)) + circle.length - from + 1L ans[jj] <- x return(ans) } if (from > 1L) { ii <- seq_len(from - 1L) jj <- ii + circle.length - from + 1L ans[jj] <- x[ii] } max_from <- length(x) - circle.length + 1L while (from <= max_from) { ii <- from:(from+circle.length-1L) ans[] <- ans[] + x[ii] from <- from + circle.length } if (from > length(x)) return(ans) ii <- from:length(x) jj <- ii - from + 1L ans[jj] <- ans[jj] + x[ii] ans } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Other non exported normarg* functions. ### ### NOT exported. normargSingleStartOrNA <- function(start) { if (!isSingleNumberOrNA(start)) stop("'start' must be a single integer or NA") if (!is.integer(start)) start <- as.integer(start) start } ### NOT exported. normargSingleEndOrNA <- function(end) { if (!isSingleNumberOrNA(end)) stop("'end' must be a single integer or NA") if (!is.integer(end)) end <- as.integer(end) end } ### NOT exported. normargUseNames <- function(use.names) { if (is.null(use.names)) return(TRUE) if (!isTRUEorFALSE(use.names)) stop("'use.names' must be TRUE or FALSE") use.names } ### NOT exported. normargRunK <- function(k, n, endrule) { if (!is.numeric(k)) stop("'k' must be a numeric vector") if (k < 0) stop("'k' must be positive") if ((endrule != "drop") && (k %% 2 == 0)) { k <- 1L + 2L * (k %/% 2L) warning(paste("'k' must be odd when 'endrule != \"drop\"'!", "Changing 'k' to ", k)) } if (k > n) { k <- 1L + 2L * ((n - 1L) %/% 2L) warning("'k' is bigger than 'n'! Changing 'k' to ", k) } as.integer(k) } ### NOT exported. normargSubset2_iOnly <- function(x, i, j, ..., .conditionPrefix=character()) { if (!missing(j) || length(list(...)) > 0) warning(.conditionPrefix, "arguments beyond 'i' ignored") if (missing(i)) stop(.conditionPrefix, "subscript 'i' is missing") if (!is.character(i) && !is.numeric(i)) stop(.conditionPrefix, "invalid subscript 'i' type") if (length(i) < 1L) stop(.conditionPrefix, "attempt to select less than one element") if (length(i) > 1L) stop(.conditionPrefix, "attempt to select more than one element") if (is.numeric(i) && (i < 1L || i > length(x)+1)) stop(.conditionPrefix, "subscript 'i' out of bounds") if (is.character(i)) { i <- match(i, names(x)) if (is.na(i)) i <- length(x) + 1L } i } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Miscellaneous. ### ### NOT exported. numeric2integer <- function(x) { if (is.numeric(x) && !is.integer(x)) as.integer(x) else x } ### NOT exported. extraArgsAsList <- function(.valid.argnames, ...) { args <- list(...) argnames <- names(args) if (length(args) != 0L && (is.null(argnames) || any(argnames %in% c("", NA)))) stop("all extra arguments must be named") if (!is.null(.valid.argnames) && !all(argnames %in% .valid.argnames)) stop("valid extra argument names are ", paste("'", .valid.argnames, "'", sep="", collapse=", ")) if (anyDuplicated(argnames)) stop("argument names must be unique") args } S4Vectors/R/show-utils.R0000644000175100017510000002370712607264536016114 0ustar00biocbuildbiocbuild### ========================================================================= ### Some low-level (not exported) utility functions used by various "show" ### methods ### ------------------------------------------------------------------------- ### ### Unless stated otherwise, nothing in this file is exported. ### ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### selectSome() ### ### taken directly from Biobase, then added 'ellipsisPos' argument selectSome <- function(obj, maxToShow = 5, ellipsis = "...", ellipsisPos = c("middle", "end", "start"), quote=FALSE) { if(is.character(obj) && quote) obj <- sQuote(obj) ellipsisPos <- match.arg(ellipsisPos) len <- length(obj) if (maxToShow < 3) maxToShow <- 3 if (len > maxToShow) { maxToShow <- maxToShow - 1 if (ellipsisPos == "end") { c(head(obj, maxToShow), ellipsis) } else if (ellipsisPos == "start") { c(ellipsis, tail(obj, maxToShow)) } else { bot <- ceiling(maxToShow/2) top <- len - (maxToShow - bot - 1) nms <- obj[c(1:bot, top:len)] c(as.character(nms[1:bot]), ellipsis, as.character(nms[-c(1:bot)])) } } else { obj } } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### labeledLine() ### .qualifyByName <- function(x, qualifier="=") { nms <- names(x) x <- as.character(x) aliased <- nzchar(nms) x[aliased] <- paste0(nms[aliased], qualifier, x[aliased]) x } .padToAlign <- function(x) { whitespace <- paste(rep(" ", getOption("width")), collapse="") padlen <- max(nchar(x)) - nchar(x) substring(whitespace, 1L, padlen) } .ellipsize <- function(obj, width = getOption("width"), sep = " ", ellipsis = "...", pos = c("middle", "end", "start")) { pos <- match.arg(pos) if (is.null(obj)) obj <- "NULL" if (is.factor(obj)) obj <- as.character(obj) ## get order selectSome() would print if (pos == "middle") { if (length(obj) > 2 * width) obj <- c(head(obj, width), tail(obj, width)) half <- seq_len(ceiling(length(obj) / 2L)) ind <- as.vector(rbind(half, length(obj) - half + 1L)) } else if (pos == "end") { obj <- head(obj, width) ind <- seq_len(length(obj)) } else { obj <- tail(obj, width) ind <- rev(seq_len(length(obj))) } str <- encodeString(obj) nc <- cumsum(nchar(str[ind]) + nchar(sep)) - nchar(sep) last <- findInterval(width, nc) if (length(obj) > last) { ## make sure ellipsis fits while (last && (nc[last] + nchar(sep)*2^(last>1) + nchar(ellipsis)) > width) last <- last - 1L if (last == 0) { ## have to truncate the first/last element if (pos == "start") { str <- paste(ellipsis, substring(tail(str, 1L), nchar(tail(str, 1L))-(width-nchar(ellipsis))+1L, nchar(ellipsis)), sep = "") } else { str <- paste(substring(str[1L], 1, width - nchar(ellipsis)), ellipsis, sep = "") } } else if (last == 1) { ## can only show the first/last if (pos == "start") str <- c(ellipsis, tail(str, 1L)) else str <- c(str[1L], ellipsis) } else { str <- selectSome(str, last + 1L, ellipsis, pos) } } paste(str, collapse = sep) } labeledLine <- function(label, els, count = TRUE, labelSep = ":", sep = " ", ellipsis = "...", ellipsisPos = c("middle", "end", "start"), vectorized = FALSE, pad = vectorized) { if (!is.null(els)) { label[count] <- paste(label, "(", if (vectorized) lengths(els) else length(els), ")", sep = "")[count] if (!is.null(names(els))) { els <- .qualifyByName(els) } } label <- paste(label, labelSep, " ", sep = "") if (pad) { label <- paste0(label, .padToAlign(label)) } width <- getOption("width") - nchar(label) ellipsisPos <- match.arg(ellipsisPos) if (vectorized) { .ellipsize <- Vectorize(.ellipsize) } line <- .ellipsize(els, width, sep, ellipsis, ellipsisPos) paste(label, line, "\n", sep = "") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### get_showHeadLines() and get_showTailLines() ### ### showHeadLines and showTailLines robust to NA, Inf and non-integer .get_showLines <- function(default, option) { opt <- getOption(option, default=default) if (!is.infinite(opt)) opt <- as.integer(opt) if (is.na(opt)) opt <- default opt } ### Exported! get_showHeadLines <- function() { .get_showLines(5L, "showHeadLines") } ### Exported! get_showTailLines <- function() { .get_showLines(5L, "showTailLines") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Pretty printing ### ### Exported! printAtomicVectorInAGrid <- function(x, prefix="", justify="left") { if (!is.character(x)) x <- setNames(as.character(x), names(x)) ## Nothing to print if length(x) is 0. if (length(x) == 0L) return(invisible(x)) ## Determine the nb of cols in the grid. grid_width <- getOption("width") + 1L - nchar(prefix) cell_width <- max(3L, nchar(x), nchar(names(x))) ncol <- grid_width %/% (cell_width + 1L) ## Determine the nb of rows in the grid. nrow <- length(x) %/% ncol remainder <- length(x) %% ncol if (remainder != 0L) { nrow <- nrow + 1L x <- c(x, character(ncol - remainder)) } ## Print the grid. print_line <- function(y) { cells <- format(y, justify=justify, width=cell_width) cat(prefix, paste0(cells, collapse=" "), "\n", sep="") } print_grid_row <- function(i) { idx <- (i - 1L) * ncol + seq_len(ncol) slice <- x[idx] if (!is.null(names(slice))) print_line(names(slice)) print_line(slice) } n1 <- get_showHeadLines() n2 <- get_showTailLines() if (nrow <= n1 + n2) { for (i in seq_len(nrow)) print_grid_row(i) } else { idx1 <- seq_len(n1) idx2 <- nrow - n2 + seq_len(n2) for (i in idx1) print_grid_row(i) print_line(rep.int("...", ncol)) for (i in idx2) print_grid_row(i) } invisible(x) } .rownames2 <- function(names=NULL, len=NULL, tindex=NULL, bindex=NULL) { if (is.null(tindex) && is.null(bindex)) { ## all lines if (len == 0L) character(0) else if (is.null(names)) paste0("[", seq_len(len), "]") else names } else { ## head and tail if (!is.null(names)) { c(names[tindex], "...", names[bindex]) } else { s1 <- paste0("[", tindex, "]") s2 <- paste0("[", bindex, "]") if (all(tindex == 0)) s1 <- character(0) if (all(bindex == 0)) s2 <- character(0) c(s1, "...", s2) } } } ### 'makeNakedMat.FUN' must be a function returning a character matrix. makePrettyMatrixForCompactPrinting <- function(x, makeNakedMat.FUN) { lx <- NROW(x) nhead <- get_showHeadLines() ntail <- get_showTailLines() if (lx < (nhead + ntail + 1L)) { ans <- makeNakedMat.FUN(x) ans_rownames <- .rownames2(names(x), lx) } else { top_idx <- 1:nhead if (nhead == 0) top_idx <- 0 bottom_idx=(lx-ntail+1L):lx if (ntail == 0) bottom_idx <- 0 ans_top <- makeNakedMat.FUN(x[top_idx,,drop=FALSE]) ans_bottom <- makeNakedMat.FUN(x[bottom_idx,,drop=FALSE]) ans <- rbind(ans_top, matrix(rep.int("...", ncol(ans_top)), nrow=1L), ans_bottom) ans_rownames <- .rownames2(names(x), lx, top_idx, bottom_idx) } rownames(ans) <- format(ans_rownames, justify="right") ans } makeClassinfoRowForCompactPrinting <- function(x, col2class) { ans_names <- names(col2class) no_bracket <- ans_names == "" ans_names[no_bracket] <- col2class[no_bracket] left_brackets <- right_brackets <- character(length(col2class)) left_brackets[!no_bracket] <- "<" right_brackets[!no_bracket] <- ">" ans <- paste0(left_brackets, col2class, right_brackets) names(ans) <- ans_names x_mcols <- mcols(x) x_nmc <- if (is.null(x_mcols)) 0L else ncol(x_mcols) if (x_nmc > 0L) { tmp <- sapply(x_mcols, function(xx) paste0("<", classNameForDisplay(xx), ">")) ans <- c(ans, `|`="|", tmp) } matrix(ans, nrow=1L, dimnames=list("", names(ans))) } ### Works as long as length(), "[" and as.numeric() work on 'x'. ### Not exported. toNumSnippet <- function(x, max.width) { if (length(x) <= 2L) return(paste(format(as.numeric(x)), collapse=" ")) if (max.width < 0L) max.width <- 0L ## Elt width and nb of elt to display if they were all 0. elt_width0 <- 1L nelt_to_display0 <- min(length(x), (max.width+1L) %/% (elt_width0+1L)) head_ii0 <- seq_len(nelt_to_display0 %/% 2L) tail_ii0 <- length(x) + head_ii0 - length(head_ii0) ii0 <- c(head_ii0, tail_ii0) ## Effective elt width and nb of elt to display elt_width <- format.info(as.numeric(x[ii0]))[1L] nelt_to_display <- min(length(x), (max.width+1L) %/% (elt_width+1L)) if (nelt_to_display == length(x)) return(paste(format(as.numeric(x), width=elt_width), collapse=" ")) head_ii <- seq_len((nelt_to_display+1L) %/% 2L) tail_ii <- length(x) + seq_len(nelt_to_display %/% 2L) - nelt_to_display %/% 2L ans_head <- format(as.numeric(x[head_ii]), width=elt_width) ans_tail <- format(as.numeric(x[tail_ii]), width=elt_width) ans <- paste(paste(ans_head, collapse=" "), "...", paste(ans_tail, collapse=" ")) if (nchar(ans) <= max.width || length(ans_head) == 0L) return(ans) ans_head <- ans_head[-length(ans_head)] ans <- paste(paste(ans_head, collapse=" "), "...", paste(ans_tail, collapse=" ")) if (nchar(ans) <= max.width || length(ans_tail) == 0L) return(ans) ans_tail <- ans_tail[-length(ans_tail)] paste(paste(ans_head, collapse=" "), "...", paste(ans_tail, collapse=" ")) } S4Vectors/R/split-methods.R0000644000175100017510000000261512607264536016565 0ustar00biocbuildbiocbuild### ========================================================================= ### Split a vector-like object as a list-like object ### ------------------------------------------------------------------------- setMethod("split", c("list", "Vector"), function(x, f, drop=FALSE, ...) split(x, as.vector(f), drop=drop, ...) ) ### The remaining methods delegate to IRanges::splitAsList(). setMethod("split", c("Vector", "ANY"), function(x, f, drop=FALSE) { if (!requireNamespace("IRanges", quietly=TRUE)) stop("Couldn't load the IRanges package. You need to install ", "the IRanges\n package in order to split a Vector object.") IRanges::splitAsList(x, f, drop=drop) } ) setMethod("split", c("ANY", "Vector"), function(x, f, drop=FALSE) { if (!requireNamespace("IRanges", quietly=TRUE)) stop("Couldn't load the IRanges package. You need to install ", "the IRanges\n package in order to split by a Vector object.") IRanges::splitAsList(x, f, drop=drop) } ) setMethod("split", c("Vector", "Vector"), function(x, f, drop=FALSE) { if (!requireNamespace("IRanges", quietly=TRUE)) stop("Couldn't load the IRanges package. You need to install ", "the IRanges\n package in order to split a Vector object.") IRanges::splitAsList(x, f, drop=drop) } ) S4Vectors/R/str-utils.R0000644000175100017510000000661312607264536015741 0ustar00biocbuildbiocbuild### ========================================================================= ### Some utility functions to operate on strings ### ------------------------------------------------------------------------- ### NOT exported capitalize <- function(x) { substring(x, 1L, 1L) <- toupper(substring(x, 1L, 1L)) x } ### NOT exported ### Reduce size of each input string by keeping only its head and tail ### separated by 3 dots. Each returned strings is guaranteed to have a number ### characters <= width. sketchStr <- function(x, width=23) { if (!is.character(x)) stop("'x' must be a character vector") if (!isSingleNumber(width)) stop("'width' must be a single integer") if (!is.integer(width)) width <- as.integer(width) if (width < 7L) width <- 7L x_nchar <- nchar(x, type="width") idx <- which(x_nchar > width) if (length(idx) != 0L) { xx <- x[idx] xx_nchar <- x_nchar[idx] w1 <- (width - 2L) %/% 2L w2 <- (width - 3L) %/% 2L x[idx] <- paste0(substr(xx, start=1L, stop=w1), "...", substr(xx, start=xx_nchar - w2 + 1L, stop=xx_nchar)) } x } setGeneric("unstrsplit", signature="x", function(x, sep="") standardGeneric("unstrsplit") ) setMethod("unstrsplit", "list", function(x, sep="") .Call2("unstrsplit_list", x, sep, PACKAGE="S4Vectors") ) setMethod("unstrsplit", "character", function(x, sep="") x ) ### Safe alternative to 'strsplit(x, NULL, fixed=TRUE)[[1L]]'. safeExplode <- function(x) { if (!isSingleString(x)) stop("'x' must be a single string") .Call2("safe_strexplode", x, PACKAGE="S4Vectors") } ### strsplitAsListOfIntegerVectors(x) is an alternative to: ### lapply(strsplit(x, ",", fixed=TRUE), as.integer) ### except that: ### - strsplit() accepts NAs, we don't (raise an error); ### - as.integer() introduces NAs by coercion (with a warning), we don't ### (raise an error); ### - as.integer() supports "inaccurate integer conversion in coercion" ### when the value to coerce is > INT_MAX (then it's coerced to INT_MAX), ### we don't (raise an error); ### - as.integer() will coerce non-integer values (e.g. 10.3) to an int ### by truncating them, we don't (raise an error). ### When it fails, strsplit_as_list_of_ints() will print a detailed parse ### error message. ### It's also faster and uses much less memory. E.g. it's 8x faster and uses ### < 1 Mb versus > 60 Mb on the character vector 'biginput' created with: ### library(rtracklayer) ### session <- browserSession() ### genome(session) <- "hg18" ### query <- ucscTableQuery(session, "UCSC Genes") ### tx <- getTable(query) ### biginput <- c(tx$exonStarts, tx$exonEnds) # 133606 elements strsplitAsListOfIntegerVectors <- function(x, sep=",") { if (!is.character(x)) stop("'x' must be a character vector") if (!isSingleString(sep) || nchar(sep) != 1L) stop("'sep' must be a string containing just one single-byte character") ans <- .Call2("strsplit_as_list_of_ints", x, sep, PACKAGE="S4Vectors") names(ans) <- names(x) ans } ### svn.time() returns the time in Subversion format, e.g.: ### "2007-12-07 10:03:15 -0800 (Fri, 07 Dec 2007)" ### The -0800 part will be adjusted if daylight saving time is in effect. ### TODO: Find a better home for this function. svn.time <- function() .Call2("svn_time", PACKAGE="S4Vectors") S4Vectors/R/subsetting-internals.R0000644000175100017510000003763412607264536020166 0ustar00biocbuildbiocbuild### ========================================================================= ### Internal subsetting utilities ### ------------------------------------------------------------------------- ### ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Formal representation of a Normalized Single Bracket Subscript, i.e. a ### subscript that holds positive integer values that can be used for single ### bracket subsetting ([ or [<-). ### ### NSBS and its subclasses are for internal use only. ### setClass("NSBS", representation( "VIRTUAL", upper_bound="integer", # single integer >= 0 upper_bound_is_strict="logical", # TRUE or FALSE ## 'subscript' is an object that holds integer values >= 1 and ## <= upper_bound. The precise type of the object depends on the NSBS ## subclass and is specified in the subclass definition. subscript="ANY" ), prototype( upper_bound=0L, upper_bound_is_strict=TRUE ) ) ### There are currently 4 NSBS concrete subclasses: ### - in S4Vectors: ### 1) NativeNSBS: subscript slot is a vector of positive integers ### 2) WindowNSBS: subscript slot is c(start, end) ### - in IRanges: ### 3) RleNSBS: subscript slot is an integer-Rle ### 4) RangesNSBS: subscript slot is an IRanges ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### NSBS API: ### - NSBS() constructor function ### - upperBound() ### - upperBoundIsStrict() ### - as.integer() ### - length() ### - anyDuplicated() ### - isStrictlySorted() ### setGeneric("NSBS", signature="i", function(i, x, exact=TRUE, upperBoundIsStrict=TRUE) standardGeneric("NSBS") ) setGeneric("upperBound", function(x) standardGeneric("upperBound")) setGeneric("upperBoundIsStrict", function(x) standardGeneric("upperBoundIsStrict") ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Default methods. ### setMethod("NSBS", "NSBS", function(i, x, exact=TRUE, upperBoundIsStrict=TRUE) { x_NROW <- NROW(x) if (upperBound(i) != x_NROW || upperBoundIsStrict(i) < upperBoundIsStrict) stop("subscript is a NSBS object that is ", "incompatible\n with the current subsetting operation") i } ) setMethod("upperBound", "NSBS", function(x) x@upper_bound) setMethod("upperBoundIsStrict", "NSBS", function(x) x@upper_bound_is_strict) ### The 3 default methods below are overriden by NSBS subclasses: WindowNSBS, ### RleNSBS, and RangesNSBS. setMethod("length", "NSBS", function(x) length(as.integer(x))) ## S3/S4 combo for anyDuplicated.NSBS anyDuplicated.NSBS <- function(x, incomparables=FALSE, ...) anyDuplicated(as.integer(x)) setMethod("anyDuplicated", "NSBS", anyDuplicated.NSBS) setMethod("isStrictlySorted", "NSBS", function(x) isStrictlySorted(as.integer(x)) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### NativeNSBS objects. ### setClass("NativeNSBS", # not exported contains="NSBS", representation( subscript="integer" ), prototype( subscript=integer(0) ) ) ### Construction methods. ### Supplied arguments are trusted so we don't check them! .NativeNSBS <- function(subscript, upper_bound, upper_bound_is_strict) new("NativeNSBS", subscript=subscript, upper_bound=upper_bound, upper_bound_is_strict=upper_bound_is_strict) setMethod("NSBS", "missing", function(i, x, exact=TRUE, upperBoundIsStrict=TRUE) { x_NROW <- NROW(x) i <- seq_len(x_NROW) .NativeNSBS(i, x_NROW, upperBoundIsStrict) } ) setMethod("NSBS", "NULL", function(i, x, exact=TRUE, upperBoundIsStrict=TRUE) { x_NROW <- NROW(x) i <- integer(0) .NativeNSBS(i, x_NROW, upperBoundIsStrict) } ) .NSBS.numeric <- function(i, x, exact=TRUE, upperBoundIsStrict=TRUE) { x_NROW <- NROW(x) if (!is.integer(i)) i <- as.integer(i) if (upperBoundIsStrict) { if (anyMissingOrOutside(i, upper=x_NROW)) stop("subscript contains NAs or out-of-bounds indices") } else { if (any(is.na(i))) stop("subscript contains NAs") } nonzero_idx <- which(i != 0L) i <- i[nonzero_idx] if (length(i) != 0L) { any_pos <- any(i > 0L) any_neg <- any(i < 0L) if (any_neg && any_pos) stop("cannot mix negative with positive indices") ## From here, indices are guaranteed to be either all positive or ## all negative. if (any_neg) i <- seq_len(x_NROW)[i] } .NativeNSBS(i, x_NROW, upperBoundIsStrict) } setMethod("NSBS", "numeric", .NSBS.numeric) setMethod("NSBS", "logical", function(i, x, exact=TRUE, upperBoundIsStrict=TRUE) { x_NROW <- NROW(x) if (anyMissing(i)) stop("subscript contains NAs") li <- length(i) if (upperBoundIsStrict && li > x_NROW) { if (any(i[(x_NROW+1L):li])) stop("subscript is a logical vector with out-of-bounds ", "TRUE values") i <- i[seq_len(x_NROW)] } if (li < x_NROW) i <- rep(i, length.out=x_NROW) i <- which(i) .NativeNSBS(i, x_NROW, upperBoundIsStrict) } ) .NSBS.characterORfactor <- function(i, x, exact=TRUE, upperBoundIsStrict=TRUE) { x_NROW <- NROW(x) x_ROWNAMES <- ROWNAMES(x) what <- if (length(dim(x)) != 0L) "rownames" else "names" if (is.null(x_ROWNAMES)) { if (upperBoundIsStrict) stop("cannot subset by character when ", what, " are NULL") i <- x_NROW + seq_along(i) return(i) } if (exact) { i <- match(i, x_ROWNAMES, incomparables=c(NA_character_, "")) } else { i <- pmatch(i, x_ROWNAMES, duplicates.ok=TRUE) } if (!upperBoundIsStrict) { na_idx <- which(is.na(i)) i[na_idx] <- x_NROW + seq_along(na_idx) return(i) } if (anyMissing(i)) stop("subscript contains invalid ", what) .NativeNSBS(i, x_NROW, upperBoundIsStrict) } setMethod("NSBS", "character", .NSBS.characterORfactor) setMethod("NSBS", "factor", .NSBS.characterORfactor) setMethod("NSBS", "array", function(i, x, exact=TRUE, upperBoundIsStrict=TRUE) { warning("subscript is an array, passing it thru as.vector() first") i <- as.vector(i) callGeneric() } ) ### Other methods. setMethod("as.integer", "NativeNSBS", function(x) x@subscript) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### WindowNSBS objects. ### setClass("WindowNSBS", # not exported contains="NSBS", representation( subscript="integer" ), prototype( subscript=c(1L, 0L) ) ) ### Constructor. .normarg_window_start <- function(start, argname="start") { if (!isSingleNumberOrNA(start)) stop("'", argname, "' must be a single number or NA") if (!is.integer(start)) start <- as.integer(start) start } ### Replacement for IRanges:::solveUserSEWForSingleSeq() ### TODO: Get rid of IRanges:::solveUserSEWForSingleSeq() and use WindowNSBS() ### instead. WindowNSBS <- function(x, start=NA, end=NA, width=NA) { x_NROW <- NROW(x) start <- .normarg_window_start(start, "start") end <- .normarg_window_start(end, "end") width <- .normarg_window_start(width, "width") if (is.na(width)) { if (is.na(start)) start <- 1L if (is.na(end)) end <- x_NROW } else if (is.na(start) != is.na(end)) { if (is.na(start)) { start <- end - width + 1L } else { end <- start + width - 1L } } else { if (is.na(start) && is.na(end)) { start <- 1L end <- x_NROW } if (width != end - start + 1L) stop("the supplied 'start', 'end', and 'width' are incompatible") } if (!(start >= 1L && start <= x_NROW + 1L && end <= x_NROW && end >= 0L)) stop("the specified window is out-of-bounds") if (end < start - 1L) stop("the specified window has a negative width") new("WindowNSBS", subscript=c(start, end), upper_bound=x_NROW) } setMethod("as.integer", "WindowNSBS", function(x) { start_end <- x@subscript if (diff(start_end) < 0L) return(integer(0)) seq.int(start_end[[1L]], start_end[[2L]]) } ) setMethod("length", "WindowNSBS", function(x) { start_end <- x@subscript start_end[[2L]] - start_end[[1L]] + 1L } ) ## S3/S4 combo for anyDuplicated.WindowNSBS anyDuplicated.WindowNSBS <- function(x, incomparables=FALSE, ...) 0L setMethod("anyDuplicated", "WindowNSBS", anyDuplicated.WindowNSBS) setMethod("isStrictlySorted", "WindowNSBS", function(x) TRUE) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### normalizeSingleBracketSubscript() ### normalizeSingleBracketSubscript <- function(i, x, exact=TRUE, allow.append=FALSE, as.NSBS=FALSE) { if (!isTRUEorFALSE(exact)) stop("'exact' must be TRUE or FALSE") if (!isTRUEorFALSE(allow.append)) stop("'allow.append' must be TRUE or FALSE") if (!isTRUEorFALSE(as.NSBS)) stop("'as.NSBS' must be TRUE or FALSE") if (missing(i)) { i <- NSBS( , x, exact=exact, upperBoundIsStrict=!allow.append) } else { i <- NSBS(i, x, exact=exact, upperBoundIsStrict=!allow.append) } if (!as.NSBS) i <- as.integer(i) i } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### normalizeSingleBracketReplacementValue() ### ### Dispatch on the 2nd argument! setGeneric("normalizeSingleBracketReplacementValue", signature="x", function(value, x, i) standardGeneric("normalizeSingleBracketReplacementValue") ) ### Default method. setMethod("normalizeSingleBracketReplacementValue", "ANY", function(value, x) { if (is(value, class(x))) return(value) lv <- length(value) value <- try(as(value, class(x)), silent=TRUE) if (inherits(value, "try-error")) stop("'value' must be a ", class(x), " object (or coercible ", "to a ", class(x), " object)") if (length(value) != lv) stop("coercing replacement value to ", class(x), "\n", " changed its length!\n", " Please do the explicit coercion ", "yourself with something like:\n", " x[...] <- as(value, \"", class(x), "\")\n", " but first make sure this coercion does what you want.") value } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### extractROWS(), replaceROWS() ### ### 2 internal generics to ease implementation of [ and [<- subsetting for ### Vector subclasses. ### ### A Vector subclass Foo should only need to implement an "extractROWS" and ### "replaceROWS" method to make "[" and "[<-" work out-of-the-box. ### extractROWS() does NOT need to support a missing 'i' so "extractROWS" ### methods don't need to do 'if (missing(i)) return(x)'. ### For replaceROWS(), it's OK to assume that 'value' is "compatible" with 'x' ### i.e. that it has gone thru normalizeSingleBracketReplacementValue(). ### See "extractROWS" and "replaceROWS" methods for Hits objects for an ### example. ### setGeneric("extractROWS", signature=c("x", "i"), function(x, i) standardGeneric("extractROWS") ) setGeneric("replaceROWS", signature="x", function(x, i, value) standardGeneric("replaceROWS") ) ### Used in IRanges! extractROWSWithBracket <- function(x, i) { if (missing(i)) return(x) ## dynamically call [i,,,..,drop=FALSE] with as many "," as length(dim)-1 ndim <- max(length(dim(x)), 1L) i <- normalizeSingleBracketSubscript(i, x) args <- rep(alist(foo=), ndim) names(args) <- NULL args[[1]] <- i args <- c(list(x), args, list(drop=FALSE)) do.call(`[`, args) } replaceROWSWithBracket <- function(x, i, value) { ndim <- max(length(dim(x)), 1L) i <- normalizeSingleBracketSubscript(i, x, allow.append=TRUE) args <- rep(alist(foo=), ndim) names(args) <- NULL args[[1]] <- i args <- c(list(x), args, list(value=value)) do.call(`[<-`, args) } setMethod("extractROWS", "ANY", extractROWSWithBracket) setMethod("replaceROWS", "ANY", replaceROWSWithBracket) setMethod("extractROWS", "NULL", function(x, i) NULL) setMethod("replaceROWS", "NULL", function(x, i, value) NULL) setMethod("extractROWS", c("vectorORfactor", "WindowNSBS"), function(x, i) { start_end <- i@subscript ans <- .Call2("vector_extract_window", x, start_end[[1L]], start_end[[2L]], PACKAGE="S4Vectors") if (is.factor(x)) attributes(ans) <- list(levels=levels(x), class="factor") ans } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### normalizeDoubleBracketSubscript() ### ### Supported types for 'i': single NA, or numeric or character vector of ### length 1, or numeric- or character-Rle of length 1. ### Always returns a single integer. When called with 'error.if.nomatch=FALSE', ### returns an NA_integer_ if no match is found. Otherwise (the default), ### raises an error if no match is found so the returned integer is guaranteed ### to be a non-NA positive integer referring to a valid position in 'x'. ### normalizeDoubleBracketSubscript <- function(i, x, exact=TRUE, error.if.nomatch=TRUE) { if (!isTRUEorFALSE(exact)) stop("'exact' must be TRUE or FALSE") if (!isTRUEorFALSE(error.if.nomatch)) stop("'error.if.nomatch' must be TRUE or FALSE") if (missing(i)) stop("subscript is missing") subscript_type <- class(i) if (is(i, "Rle")) { i <- decodeRle(i) subscript_type <- paste0(class(i), "-", subscript_type) } if (is.vector(i) && length(i) == 1L && is.na(i)) { if (error.if.nomatch) stop("subsetting by NA returns no match") return(NA_integer_) } if (!is.numeric(i) && !is.character(i)) stop("invalid [[ subscript type: ", subscript_type) if (length(i) < 1L) stop("attempt to extract less than one element") if (length(i) > 1L) stop("attempt to extract more than one element") if (is.numeric(i)) { if (!is.integer(i)) i <- as.integer(i) if (i < 1L || length(x) < i) stop("subscript is out of bounds") return(i) } ## 'i' is a character string x_names <- names(x) if (is.null(x_names)) { if (error.if.nomatch) stop("attempt to extract by name when elements have no names") return(NA_integer_) } #if (i == "") # stop("invalid subscript \"\"") if (exact) { ans <- match(i, x_names, incomparables=c(NA_character_, "")) } else { ## Because 'i' has length 1, it doesn't matter whether we use ## 'duplicates.ok=FALSE' (the default) or 'duplicates.ok=TRUE' but ## the latter seems to be just a little bit faster. ans <- pmatch(i, x_names, duplicates.ok=TRUE) } if (is.na(ans) && error.if.nomatch) stop("subscript \"", i, "\" matches no name") ans } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### 2 internal generics to ease implementation of [[ and [[<- subsetting for ### new List subclasses. ### setGeneric("getListElement", signature="x", function(x, i, exact=TRUE) standardGeneric("getListElement") ) setGeneric("setListElement", signature="x", function(x, i, value) standardGeneric("setListElement") ) setMethod("getListElement", "list", function(x, i, exact=TRUE) { i <- normalizeDoubleBracketSubscript(i, x, exact=exact, error.if.nomatch=FALSE) x[[i]] } ) S4Vectors/R/utils.R0000644000175100017510000000242412607264536015127 0ustar00biocbuildbiocbuild### ========================================================================= ### Miscellaneous low-level utils ### ------------------------------------------------------------------------- ### ### Unless stated otherwise, nothing in this file is exported. ### ### Wrap the message in lines that don't exceed the terminal width (obtained ### with 'getOption("width")'). Usage: ### stop(wmsg(...)) ### warning(wmsg(...)) ### message(wmsg(...)) wmsg <- function(...) paste0(strwrap(paste0(c(...), collapse="")), collapse="\n ") errorIfWarning <- function(expr) { old_options <- options(warn=2) on.exit(options(old_options)) eval(expr) } .AEbufs_use_malloc <- function(x) .Call("AEbufs_use_malloc", x, PACKAGE="S4Vectors") .AEbufs_free <- function() .Call("AEbufs_free", PACKAGE="S4Vectors") ### Exported! .Call2 <- function(.NAME, ..., PACKAGE) { ## Uncomment the 2 lines below to switch from R_alloc- to malloc-based ## Auto-Extending buffers. #.AEbufs_use_malloc(TRUE) #on.exit({.AEbufs_free(); .AEbufs_use_malloc(FALSE)}) .Call(.NAME, ..., PACKAGE=PACKAGE) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Functional fun ### Has <- function(FUN) { function(x) { !is.null(FUN(x)) } } S4Vectors/R/vector-utils.R0000644000175100017510000000357512607264537016440 0ustar00biocbuildbiocbuild### ========================================================================= ### Some low-level (not exported) utility functions to operate on ordinary ### vectors ### ------------------------------------------------------------------------- sapply_NROW <- function(x) { if (!is.list(x)) x <- as.list(x) ans <- try(.Call2("sapply_NROW", x, PACKAGE="S4Vectors"), silent=TRUE) if (!inherits(ans, "try-error")) { names(ans) <- names(x) return(ans) } ## From here, 'length(x)' is guaranteed to be != 0 return(sapply(x, NROW)) } listElementType <- function(x) { cl <- lapply(x, class) clnames <- unique(unlist(cl, use.names=FALSE)) if (length(clnames) == 1L) { clnames } else { contains <- lapply(cl, function(x) getClass(x, TRUE)@contains) clnames <- c(clnames, unlist(lapply(contains, names), use.names=FALSE)) cltab <- table(factor(clnames, unique(clnames))) clnames <- names(cltab)[cltab == length(x)] if (length(clnames) > 0L) { clnames[1] } else { NULL } } } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### quick_unlist() and quick_unsplit() ### ### Both functions *assume* that 'x' is a list of length >= 1 with no names, ### and that the list elements in 'x' have the same type. But they don't ### actually check this! ### quick_unlist <- function(x) { x1 <- x[[1L]] if (is.factor(x1)) { ## Fast unlisting of a list of factors that all have the same levels ## in the same order. structure(unlist(x), class="factor", levels=levels(x1)) } else { do.call(c, x) # doesn't work on list of factors } } quick_unsplit <- function(x, f) { idx <- split(seq_along(f), f) idx <- unlist(idx, use.names=FALSE) revidx <- integer(length(idx)) revidx[idx] <- seq_along(idx) quick_unlist(x)[revidx] } S4Vectors/R/zzz.R0000644000175100017510000000007412607264536014623 0ustar00biocbuildbiocbuild.test <- function() BiocGenerics:::testPackage("S4Vectors") S4Vectors/TODO0000644000175100017510000000424012607264537014132 0ustar00biocbuildbiocbuildIRanges before the split (version 1.23.5) ----------------------------------------- R files: 73 files Going to S4Vectors (29 files in total): X S4-utils.R X utils.R X isConstant.R (renamed isSorted.R) X normarg-utils.R X compact_bitvector.R (renamed logical-utils.R) X int-utils.R X str-utils.R X vector-utils.R (NEW!) X eval-utils.R X Annotated-class.R X DataTable-API.R (rename DataTable-class.R, put DataTable class def here) X DataTable-stats.R (merge with DataTable-class.R) X subsetting-utils.R (rename subsetting-internals.R) X Vector-class.R (there are some leftovers in IRanges/R/Vector-class.R) X Vector-comparison.R X Hits-class.R (there are some leftovers in IRanges/R/Hits-class.R) X Rle-class.R (too big! split in Rle-class.R + Rle-utils.R) X runstat.R (merge with Rle-utils.R) X List-class.R (split in List-class.R + List-utils.R) X endoapply.R (merge with List-utils.R) X funprog-methods.R (merge with List-utils.R) X SimpleList-class.R X DataFrame-class.R List-comparison.R (methods for CompressedList need to stay in IRanges) DataFrame-utils.R expand-methods.R (merge with DataFrame-utils.R) X FilterRules-class.R classNameForDisplay-methods.R (no more, has been diluted in other files) updateObject-methods.R (need to remove methods for range-based objects) zzz.R C files: - 36 compilation units (.c files) Going to S4Vectors (15 files in total): X safe_arithm.c X sort_utils.c X hash_utils.c X AEbufs.c X SEXP_utils.c (split in SEXP_utils.c + vector_utils.c + eval_utils.c) X anyMissing.c X compact_bitvector.c (renamed logical_utils.c) X int_utils.c X str_utils.c X Hits_class.c X Rle_class.c X Rle_utils.c X Vector_class.c (renamed List_class.c) X SimpleList_class.c X DataFrame_class.c - 9 header files (.h files) None goes to S4Vectors. Other TODO items that originated in the IRanges package ------------------------------------------------------- o FilterRules: - refactor, using ShortRead filter framework (becomes FilterList) - support subsetting DataFrame/RangedData directly S4Vectors/build/0000755000175100017510000000000012607346177014542 5ustar00biocbuildbiocbuildS4Vectors/build/vignette.rds0000644000175100017510000000032312607346177017077 0ustar00biocbuildbiocbuild‹uQA ƒ0Œ‰µÕ"ü@^à+ÄK/E<ôL„P% Ò[_^»V-º¥Ýl23›Yr !”0J eP²’q‚pˆK|ØÃ¬R¹ÕÅ­3Ó#0çºi¹0’O´ÿúF–<®šƒ•èMX.]QwFÜn¾OT£Œ¯_H¿P<1µrÎêÑ×v‘o8ÞÌqS úÙB®»ï]’t. Ûùé¿Å·u/ã„ã>= options(width=60) @ <>= rollmeanRle <- function (x, k) { n <- length(x) cumsum(c(Rle(sum(window(x, 1, k))), window(x, k + 1, n) - window(x, 1, n - k))) / k } @ <>= rollvarRle <- function(x, k) { n <- length(x) means <- rollmeanRle(x, k) nextMean <- window(means, 2, n - k + 1) cumsum(c(Rle(sum((window(x, 1, k) - means[1])^2)), k * diff(means)^2 - (window(x, 1, n - k) - nextMean)^2 + (window(x, k + 1, n) - nextMean)^2)) / (k - 1) } @ <>= rollcovRle <- function(x, y, k) { n <- length(x) meanX <- rollmeanRle(x, k) meanY <- rollmeanRle(y, k) nextMeanX <- window(meanX, 2, n - k + 1) nextMeanY <- window(meanY, 2, n - k + 1) cumsum(c(Rle(sum((window(x, 1, k) - meanX[1]) * (window(y, 1, k) - meanY[1]))), k * diff(meanX) * diff(meanY) - (window(x, 1, n - k) - nextMeanX) * (window(y, 1, n - k) - nextMeanY) + (window(x, k + 1, n) - nextMeanX) * (window(y, k + 1, n) - nextMeanY))) / (k - 1) } @ <>= rollsdRle <- function(x, k) { sqrt(rollvarRle(x, k)) } @ <>= rollcorRle <- function(x, y, k) { rollcovRle(x, y, k) / (rollsdRle(x, k) * rollsdRle(y, k)) } @ \end{document} S4Vectors/inst/doc/RleTricks.pdf0000644000175100017510000012433412607346177017571 0ustar00biocbuildbiocbuild%PDF-1.5 %ÐÔÅØ 5 0 obj << /Length 704 /Filter /FlateDecode >> stream xÚíX[oÓ0~߯ðcBg7¶c7‘Hô ¦<4C‚^`êÖB»[…øïØñIs¿­Ù(§ñõ;ß¹ø8é›àd8æÑaT¸(X Æ"%CÒõˆïz(˜¡së̦ÖÕÜÆÜq¬àRu~(Ùê>µ¾¨æJÉÌt{ä[½fj3i-£…Á»á˜úˆRâ Á"=.ñ¤D˜yÄó™QóÑf£ïFIŒá) ÌÔë¯6VµÚéŸõm¤Z#ì×Ñhœð‘kÐ>èýim6Î7GXT ñSÓfªí(¡Âpäò‰/™Ô1õÂC˜KEH¾²±`ÜÚh`ík%s;qÇŒÏÍò—ª‰Ms¡š·°j Æ^ÚÊ,ùäÍêAÉ©Ñ~T£4²ÖQÔ"OF³äWÅ£=pŠÆÖ4¾ïFK¬» PfA§`Éuä¤ Ó¤™xc?T²áK ÜAK<“À|{Ð¥y *V1hÔÃ]q3Hiˆ êÑÜ0^RðßñSsÔ«MÏ;HÍÍ©I6/s ù³¸-(iza4fv?€ ï3ò|’©hО «N®|67Qîû8÷rªÓ&•¹á\Wo%É!ú¬„•”ƒšJÎza3`¼©‰BF%p­qñ!.©¨éÁú¤+c;è•m· Ú‰mu‰Ë 6m®K]Êçúw=—ÏÝ?VI'ÏQIe=‡°»>«y™_:VôÉ“Tô&Úá¡´ÃÿQ½ÂE”¾QÚ1Ø=žAX~Ö]¢‡+pRfl˽aήšð—¯ÍIß!íSÖ{Ç|÷ã½~9…Í_^ÏñZ±³é‹Lsú _Š7‰†v”µ„žäls¼odí^"Û’(ÉÍætªGú> stream xÚt4œíÖ6 (ÑëŒÞ¢½E:ŒŒÆèQ_%…D"zKA"DOÔ(AôÞ5щå›”÷œóžÿ_ëûÖ¬õ̽û}í½¯››ÃÈDXÅ퇢QXaˆXPÓ¿ `°¸,âæ6E`‘ð?j·9ã@£äþÃA ‡añ:uï§F:>H"@¤ä Òr`0 ËþíˆÆÈê0_„3 /è Qpo·Ú3ƒpuÃâËü}øœøˆ¬¬´Ð¯p@ÅŽA8ÁP€> ë÷ÀWt‚!´Ž øG >7,ÖSNTÔÏÏOæá-‚Ƹ*ò ~¬pî ÇøÂŸ€˜ü727`ê†ðþ­7A»`ý`8€W Np”7>Âå Çøâ€‰¶`è GývÖûí üé ü+ݟ蟉¨_Á0''´‡' €@¹.$0„ê‰`ý±B åüÓ†ôFããa¾0æˆwøusU1`x€ày;ažXooò'DÑŸið]Ö@9«¡=<à(¬7èçýÔ¸¾í¢¿'{…öCý\(g—Ÿ œ}ÿmÕÆÂðôPA¹"ÿÕF„7áw6B`Ü~ïÐßSÀ§G"Pp#´7âçcãö_6<áœnãoü¬~™àx>ý³¤Ê íü“xb’R ƒ€ð£ÇK’@ÏPg¸ÿ¯ÕDEPh,>Àà \ÐÐωJÈ¢ø'ë§ôÄN> žq¿F¯ú·ü‹Þp¸?Ü 4>‚v’t/¬?|¥rÍOx±÷Æ ÷¢ÅS~á qLƒÏñåKùËÒïÎböUw6_™š×àÛSž`? Z­©¸S›l\÷#øÄþáÍþÅ:ÐXý‡Où«*oÚXÉX„M•—‚O½‚ÍÃoÕ¾×áÎöò‘¹l”Ksèתéÿ¦ 7Ù=²h¼T&¥K~‚N4K° 1Äã˜1ÌÈI‚f% Þò§ÚÛ¤ÎútήóP²–(^tkNìÞÑpàôKS1ïF&.¦[Œ¬D{ÔÝýcV½fbz˜{=pŽ et gžãcÿ!'ïw¸óV!ƒ . &M=W¨ûê±YQu4–>Óé¶5“9[ò5Œ´²òÕ«4¥N&¥]é”UzrûîlbëÇïveü$ ì»7°Ÿµ&¨(å¥RkªC0º>¯â?ž™©#žÑWhaKÊûCöÙFÎî8±qÛÌzm†ÙÔÖ.IJørX§Ùh׿¾Ú|SvB÷aÉ)ž<ËZ¼£¯s¤Ÿe~Ù}ß7Hj–ñшÍa p“åÕùŒSœéÆÑ£ Ó+]‘)]ÆoüMB š]ºA°Xµ[ªš™ 6Ö€I¾Ëqº¼Ñ-b†àAó'¥RÚF\\È__V '3ÌY72®Á{:ãÛ™I™t»Gyĸ]9–Æèt3¥ ù ïè¿ke œñIJÍŽ’xV'𜲭™²¸ÿ\ö}oá¬Rkžî#z'~ÆŸ>Ûl¹faKx”Šæï}jýþEbºê×¼TÏ•íl`£V–ß;a¸?òI¹ÀBÌŸ}EÆ‹CÏy tþzõÎÄ\4¡Cõ†òëïÇëà¤&«tà×úQßA{wkÉûþN:¿Ï3ŸÅlѸ–Y ÔþTIÛí#•ÏJŽªÇ”„A®r™t,Å™´¨#@êànãÄ À ¥,ŒdÔCIšìøñ ¯¾*ËÔ <,”ýÆx£ƒ7i¯û´^ûÄÍà¸b$hÁ¸üB¤çë4ìAGŒ¨|ÞÈÓÁ©¿öÍ£U¹Êb8º„1¿ÄcÊ‘<þ”XàØáÙê¥ÖœäÙdQ—½– d·‘†XŽ›¹ ¿‰ªžè’Ž~C’§–©’7{”/ úØHÎw½vÌ’%Iâ$'xJ)ts tµ©Õ”oÁÞbë‚£ÊY¨n0ZŸÜžfdð‰ÅÕÙ3–‡ ” ú+çRaÅÙ¯í`ØLvReCÈjŽht›ýÑ[ñ¶ë©óNTúú£}šm·N§­‰<^ž×~J€†’Q#qGÅœÍ:Š¥ð‹cæª÷-TYB–Íù\œ2é˜D0 ål†Ï¼Ø¼IM_M_ÐPMl'Â5eˆ¬4è]ìó?¼øœÑÞº×Ò<ö*Cûîwãì2JS£ó=߈ì#¼K(Éól‚9ê–|\ìC¿ý 2ÁAÄLz7>y`¯ì %ά5kóíd2롳•ÕCûáV1„M·ÐžH]v__°ÝÑ3,Z>h×M^b,N¿bn.?–Sß;x™’ºÔPÄ0s!T/#S<±ÖåšuÃæÆœ2'tîXzhšãøãéÃwæá÷|H×Ò¦Œ Ç’ÄiŽêÜpÊðG›Ï§G0 cëî;@±ì/ó‚êÝ@’·Ýíõ\oç{i¨Ë›H/•ä-ç˰èe2ÙÞ»º…ÃÇäâ"| ÔßÅëkJËrië!Îx’UÆ\¯}F!¥ctÈîC +wtÉWzò 難0vùF'‡Î sy–+­G+xÇ{ ,&ú#xsÁáºÀÝ3Qb|À‡Ì1“¹Y $ÓÞ¨¢U0œ%N Ù±Îö¯ù2…¨ø”à2(‰XK䙌‰9ú=t°EùpfF7õîòiò6ÎT¶; Åò‚Òž6ù~þLÔV_4AvÓ’¥=S+ÉtÔ,YöS5)š•Ÿ·¾†ñ±©P «hú7 S2>"»>‚óãœÇ»Šò[B¡ýÜ t]Ùl¶?Qø©÷Ý«#LÔ¨ÿ§¡•'³€ë™ÇÃÄJó€½Ê‰«ýœ¶×ï0>yáé»ÓD™Áý0u¬­P£*ûªÚJ­D rÜŠÅ9+_?(”!è»m3¯ûŠ0{P>¯ñÛP22zÌGB>–`°÷œP~îsóÙËæë„I%WNfêã><Ïy<ßFIƒ#òn|.«P©yŸRMÃ!Êük®Û\Cg+7qr/´mÔÐú¥ÿjD(îAg¿¸xý‘ì¨ìÚ­DoÙB^‡ù6Ê5̄őœÁ£‚µïÁ½öGUìÊ$.év¬ÓQçèåêmôÔ™K¸ßf¿¬w(GOÁóýEêj*$ EpÍ´ ™•c‘ÎÖ”·‚.½í…¾ìŸíËUK»b²¢¿‹)ùÕ“’\ø¶[¿7ÓbIËãaÎ÷¥LÆ0ºús\‘J/Bɬ”LlïlGe]H-9B¢UG¾¾L&cOÉðå­TÅAÝ¥˜ž=Þ(Ò˜…YÇÞu94ò—ӊʦ þvÉâ¤B~R“m„öŠ §¸êwÉñÝ“¥ÃÏZ6œƒÅÖ$‡”ÞÔu'IƒCYœ§¢˜´Nêén¥·(ÑFÜ[W¾ïEþtÆB—±ŠÖ¥_dz’5½ÛªÃåØorÉÚJÑòÄ{”ò#*™â|;¿º7ï[ÆëµÞTµc½© C¾_õcŸ=j•!W.©ÿ¢ìâìÒÆ$ífÜ%š{u%T•×B ˆºçG͵çp„Ì8<ÚXUç±` ëÀ-Œ[Öp‘h;X¦êÆjç—Ô“…v ‹Œ[±l+¡èŠ1)W쿯¡¦Â›I)ßžÌcU ˆ…õ(Q)ñO”ˆígèíì£&]i“*ïdÒ¸/ŸèÀöªo½PW5ffK Þú¶iнìa5HñÑ ò½±çÃhæâÜÐAþÆè·G•;¢‰ò—L˜x)ìjöä°u^»+£õ/~¡ÁÖì’ï­¥›4öºp¯¨ýÑmSÞš­Ì+ò™ ¼®¡Æ|±H=5H²e+ ÙÃüäõp´Õk  \i!¾/¢f"ØÈ’gi¹Ãï¼`"ÖC.^¬“¢?ÑùÉ·=XÉEÊV ï4^õð4Ô•&´8…Çó·LŽÍÀâ´RJænÕ –Iø$š…¼ok]nù^HBkôs|L±z¼öàˆcˆP›tÈj±p0‹I—{Å©@£¬zíGÚ ÕñnmÛka&$àúî`íU·ËÝÖÆÑzn8+áÅ»wL0g0I@ßÈJ³h¸OžMöb"‹íÅ¢~+úø(eɰ¤éÙ~>fÐaúCEòŒ–ˆªNu-÷˜Ü+óÞtº»þS) %‘fʼn¾‘²²œO·Ÿ”N [åyRÊ®+,O<{µÀïÒ¿ Ls¨j¯RÊ×v"P6ÑâIQ8'®OÚ¸÷EÈЄg@ï²ØÌ›¿Æ‰·íÂJT8êçå¶i38òü·ˆSî:~Ò?ù볨KˆølJÚêÇçíóœšE)WK–y]ô½û/ ±[Z˜†œìWVU[µV&Ú‘‡ r»÷´sh½ÛŒ7Ô:'íì¹Çnô6^~%¦¼w'ôájßœËåá¶S×A\ã—pT“¼jnJá’© ‘&Œ§¬uë_5m+'—0f=ƒ½¬¦MU uŠ‹þŠD[VèóíÜ'ÁT½¸>é0Ú‡² rŸtF^ðe-u¨åÕFfŸ†Î½æX¬8ÉÙ4jîZ z”K¢QötóF¯'lÅŽ<|ÌmÕð6‘CFÕFÚ¼çá1E‰ŒOÀf'ez÷±È%ÄÉ«EP²)àÇé´ípÆñµÃƵËfB%„ï°ÙüK9­ìw†Q­“|¥öpÃð¯¬Pówg^}$ôŠ/}VæZ…5åb?o·FdF¥iݲá¾o¶î;ÖHÀFÙ8oÇ8÷Q51€;ÌÀôKõ[ñŒ¥–«sJõ´:I‡ôƒâ‘¬ˆùQ-å©á.Ÿ"NoWßYMÛ;õå k÷¡æí1™oV¯ëGœ°3J'ÓçRXí¨½)ióøZi÷¶LÓGÒ^3íÒaå8äù*¬hÂùÙ\b÷—-МÄ_¯!%¨XûêŠ!ž$‚K.8WY7.ÖãÂ6B[åMý#‡1»MÝ}yÉb’|¿öÕº‹ Ú¯M•Bq•»³VW>/Ú§Zvú7ר­0W¾²ªïíËÝOœpf»t³€hHVÁ^¥XÆ=¢åÿR ÃåwÖº}ù$k=ôÂçœÔd™QV7‰)òj«©nÌ’kÁϵ3ù­a„õ— þñ×¼Ú#ò.jó¥œ×»_‘Ô{Óntª vckäz¨þ…ÆìSó¿:«DÁ†Ó—·äz7—[?å·¥CÞïT"CÇá×Ú |•/0_|¹ÆN72»RñìƒÝ„Ôµ ÑÌ€þ°­êç”qÖe½qWÞukdæ5û17¯ÁØ®Qä.!vô`‘ Ô!î]¯–;•äÅ-†´…úS-mZ¼%¾”ºˆŠñ¾÷Œ¸t¹ ©t«(p7þqu¼bõ²Ì:»§°^?OGÞ¢M]EÀ¡¢»Ù!%wcú}§7N©Ö÷cÝ;›“¿’èFN»>8ºD NÖ¿›‰ÌDs’%Ž¿0#«ìßuýæÚ[¸÷À§šÝŸªÐBcy0]{ÙwáX þB‡ëþ¹„’¥˜mó‰B­g=¹i£;Ïìšú¼ôàèòô§fë»w( ’’ú¤×ø?äï¦j¡d^¨-,Q‘æü¤}SAT {ªßÖþýÈ{ñyØÛ²Ú–ß“\òŠÒû‰¾œ:ý!H3þÜRcíEÊ•‘oŸ9ûZ8t&M¤/7NX±•‘²¬oºOR²ò Œ«¬èP/ž¯©#¥ž ¾±—b³È%å[nÂljuõ¯ë“Œ¥zOÎ%z_l,+¥|âÝ_;h9 …28›kê .Ó{Ó½Ô<ËŸ³­.òªh¹Ø¹Oè–ÐFõòèèÛËÀHõ"¬2…øœúYZÖŠþ˜²¢;¿‚…›Ã‚~}¬âùhnçùÏð¹usuáà'µµ–T!ý/Ô0q L;T:VÈ]O/<ÍKzd"OÇ9X¯»?x½÷¡ivÕeèÁ±Í2óéÝP2+3¹|*Yc𷛀ºMë]J-Ÿ!©sã¶Ó¾§¼ÆâŽòþ׫ﱋﲛtËáܯ®OrWcu^UìÊ1<ßHgŘτ73ùÛ¾ª!©Wäÿ²™ÕTi†Ì8"’D¿»b½œÓ•¿"dÀSÈKƒ(гym`ܤ½£5Ôó½½QÉTn]y ºÉ°lpN~ÉIJiüZá%ÛœÅIxƒ„K T½Êíþ¤ÈØÓ üv&ÄýÂlQ(¿S!òØ[Õt}j„ßËÈ­ÈoÃ+›‡ö·Äël@oǰëggVŸ%î3@ïØ§ù7%F™eÇóZ&U¶ÇDj*S™\‘Ò&·aO\žÚW<‘ë4·ÿq¡Sqø¹¬€68„~°Ò†3hŒŽtSÜl"ðÃv§Ï4Ý…¨{Kו`è ×f¶(0Y4Šï)UÁiòF´Ò·N3¼éèÖØëÓ2’nb(c[·Z°è.‡v—ØÕŨÖKùÍy´åPåhð¿£?ZÞÖ”Œ¬]!¡,H˜qf:&ï~<V¨µSêüì0°À|`=r#/_«û–DJ(È0¶T÷=½/Ú¢SCÛìÖc ±> ép{(ÄntþÀßu'чµLnN}F*‘LºUG7ÓuÐ×Ó[eaÑ8•¦MhÊ­¸+‰)ÈwJ"˜ÿ¦ø+AD‘WqÐY£H Poô„¤ñó¹¡RÙ5ëÌ‹ˆ9:¢c+1? ¨»Œå åX´ª¨Âhóø+rކ£!½Uwê&Þ~u §!°ª . K‘?†"î9út"Á…ðÊ ú2ÞF^ÝÓš°ªV›â ±2ÜÉÛ¼G¤ŒV í\ ƒ¤±ØïؾS©„t‰Z—éÀ©±­·_ã|š¿9©Óî.ÊÓ>;r$Yú~èèÆÕëOØå03Ûëýö\+‹nÈ®-^:ñ-!qi`°´â]¹”˜DÛ¨™$½ÿà\ endstream endobj 19 0 obj << /Length1 1691 /Length2 9313 /Length3 0 /Length 10404 /Filter /FlateDecode >> stream xÚ·P\Ù.ŒÜÝ‚kãî$¸;4Ð@#5îîîn!\ƒ‡<\ƒC àä‘™¹3sïÿW½W§ªÏù–{­µ«šVC›CÚÚÙü ãàæŠdUµ¸y@ /'ȃÎÀ 9‚ÿ£3èÝÜ!ÎP‘ȺA°'™öd§ê ({8¸yÜ"Ü‚"@ €þ¡³›@ä ±¨r”¡`wtYg7ˆ­ì)Í>ÌV,naaAö?ÜÒN`7ˆ PÁìÀNO­@Žmg+æó_!˜Åì`0..///N“;§³›­ ;À ³hÝÁnž`kÀoÂ5øOfœè ;ˆûŸrmg˜È x8B¬ÀP÷'¨5Ø ð” ­¤PwCÿ4VùÓ€ð×Ù¸9¹ÿ÷—÷ï@èÎ ++g'ÔµØ@Áõ*œ0o;µþmrtw~òy‚ Ž Ë'ƒ?*^Hk@Oÿ¢çnåq¹sºCSäúæé”å¡Ö²ÎNN`(Ìýw}r7°ÕÓ±ûpýÙY¨³Ôï/`ZÛü&aíáÂ¥ …¸z€•äþ2y¡ÿ#³Ãü@ PP˜v€½­ì¸~‡×ñqÿ¡äþ-~bàçâì°y"€Ø€Ÿ^è~î O0ææðû·â¿:77ÀbX‚m!Pô¢?‰Á6â§æ»A¼ÆÀ§Ùã?™>—µ3ÔÑçó?úË¥¯g  ð’íOÆëddœ½~¼|~n€°@øï(óÿ÷?¤ È_µÿ ¨µqÿIáéìþCÃó¯©`þkcXÿAÍùi”Áæ&ßÈ´zúáþžÿ?\þÿÆþw”ÿÛäÿoA/<ÿP3ÿ¡ÿÿ¨ANGŸ¿ ž&Ùö´ªÎO»ý_S}🛬 ¶†x8ý¯V zÚi¨­ãßÇqñ[k@`VvŽÐºðÞk8»C~ß5n ðtOûfåðtŸ¸?õêøiþ;¥<ÔÊÙú÷Þñð @nn tàÓxñðóü¸ŸÔìýÇd¸8¡Î°'À½€³úïŽ ð¸¤‹þ@‚Â.õ¿‘À¥ñ7pþAB.ËГŸÕ߈ï =íë?ÖÜOóÌþòó¸l žàéŸÊ€ü >årør?ý| æüO¶§ÜOwî¿ÔOéÝþ\°R?ùÂìÜÀÿ*æ)8ÌËù_OÉ=þÿd{âí vûÓü¿:aåáæötCý±+Omúþã:ƒ½ÁVè‹sÎV¢áöMáÝ× Ò^;ŸÅ§vô³Y8üÝzˆT¼ìdEöÿù=4üѯ?°\5'ϾFVøËµD¢Çh–åý#³IsðÉ ÿ0h?"¦B†9*Jæc4ªqkGÚ*E –xl\XqùFÍ¢­×4,òúýjèÌh70ï$æ„2Ëãu8V”yIaË?ˆš9r‡~FI!¬j8qx6Ã"Æ«=IŠaÝ[ Ü7G¢BíÊwÑË@±%æÅÄ]ìrf¦&çYö6¾7ŸSa EÚímtôóU*±ïtÞ/Îí¸4Õs–Èe±Ñ¶øŸž÷ÓvÁÏŸ•ž«›ï¸}Õ50òâÊÖ£¡ëØrÝ~™ †yý˜–Zrü «ÈI£šÅ›év+‰‘GÀÏÂÅfÎ'†äjâ5‚to{B¥Z=aÒ¥†Zs†}BÝ(©—[9Eâ=•gþiEáyýñ%f_Î~–àÊIÍlFâ<>„£–¬‡Wlä1NšL J‚(¥ ¡&¹|„I:`ÙÉÇöܶïÖ_Meö3 §°$‡Sm+@>o¤_7Mšm·UY $]çòsîC2ØÂâß)#{×cŠô•í®Lh}›°Þ¬ÿ²ÛwÔ½%ò¥­2eŠr“ü%ÉjC³víŸ<{9É\*®Ð7Ô+…Ü…‰uÈ ôÝ.Å–©_Jô¯n)Æ7K±~ήŽ2@Céª!Ì¥Òé¿Gö9J å¿ rI?n×*Ò½j?%`vwV$‡2er¬ç½i"Ș„)=J{³Ž•ÑoЮØÒh!’*kÃQV‹jõéÁê®HÒ:¾NP]¬™ä±%Pß[æ$ŒÐL#½}ë5‘Ä"ÙX.ûl­8SÏ’PÐlÓ!¯ðÍ…²hºÚûtÖ3¬ÅÊ÷¯_­/úç¥ÎôSGë¾z´¯[+Ýítœ ÚH˜²Ë@6FãY\kýR”LMc´î©{ž»éØ­áÏÀ¢7ÜŽítÜ9_]@…/ÎØ BÿVC|®œØïžnNU6Ö”šƒì“´Hîï§Zš 0ÐRø1K&+IÐ^éŠ5„$*x$›'‹ü¾DsWÁ€ù˜-%ȇ!õGô9•²›Sþ'`œÆ¢pÊŽÉ¥fj‹Í;ÃsÜ ²I2n OaŽOŽJ$+ÔìmRkÉtQ2+c߉˂ۦwÂÝ?‘º8ÉÌ'ÏAêDÛ|,q‡FÖÑÌ e,`é-‡«°TçäøqMª±ëá5jq›¬—j¬[š¡ðšóv¡˜ƒPj½hF•à°"WZY_–Ö’"iÿ»Úé`”¹ÝV¢yö”þã¬+añáˆ5± š—lÒ05mÌ/Æ´ŒµÈÉ”;ƒôAþ³WN := ÏöÝ<" ¥T¡±mŸõ-$Éq4…¨Î½xm©‚D»1¬ËQÚW?:£“wðÜc¦énœ]x¼ØÌ–‹c 4Ô¹`Ò:&·Ÿ‚+ržã¦R­‚¨<$±Á§‰¨?´rY\I…}›.šNÜ!‚#åkOl©VFÇ—ÁŒ¡¯6Í6(¡I§Ù‰•4ÓÉÎÄVEQ²~yú‹  Î(,nKÁ\ "ã%6F“\”Hj˜© Î=3>î p·Ã;VK׿\ª †§(Ç{–™išÖ‡Ë–{»Þè˜rn.@tÆ”Iöã «æ[æº7¦…ý8üZ Æ}ÌòµÒÊ´¼î"È`VéÒï+ec˜ÈFU#òî-j“ñN-V_ªN89—o$0£>DOŸæKhöF1vPd{×íüëð…fc÷FG:ÈV6ظês,f܇ ¸Æ8£²f»°q^ÚÚ;»QÛÁ(’>KòŠð”ÃO})^äÐz‰]ºÒa6t½àTÆö#}³!š+ „ÞZ¦ÖIzª}fSÎÚª'`,¦?Èû•,†áƒÿý¹ ÎÕD"”<ìܾSg;î"Št±/Jhg¦È·q°@Á9ZøýØ IíM°î+ï(#Z³Aœw^ò y›Æ©Ÿ£m§Çü>> .Ë:µÇ&òœKÄ—ËxwzðNN÷CªÕí&”¥‡sr›»%Ì*ð…=‹¦“}X)P™”œ`íÓu"ÖjϲBËÒU¦)vAZÞÅý´wÖ´=ZðéyAѹ­¬'Å(!½Û»Å$ÚuƒrÖ ýä©–ô ·z'ÑUf°L¾;~pʪ¢Z´Û€b­R9»zªÓz9ÙÆžci3Mdzøc¤šúwÒ¥çÞ 8´ê:…Ïôv8º˜Ûh•[ÛŒÞù¬¡õTÒšÖûίHÍs¾ ~sC„É7Á‘”&§ÒÂo¸³_ëjZQÏEíö­"wÏv¼^ƒ!-ÎPcý½7ó½wñŒô½ÕÁì%¥w†Ö_™ÃYE ¯¬-¢KK¥Uo5,Ãã#9 ¯R¢öëaH©¦Ï[Ëc†mG§Á•Yµ8{™–üÖ“¬êòhüÉXº:v·d_={…»(ÌYàofÈÆè]dór‡~Pá²1·«&¢Ív/iüÒ‹KUw)ù8 ³’µèœ-Þæ%4× ñ×J32í§Fs+çb°`’פO‹„JÊ»$&n€\ñJcMêo¾3±|2ç[¤zðÒ°¤ž­ÕzNÂÌjU/N`(o4c¹'$ c©\"‚ƒê4͵ÓEüP¼×!þÖÝ¡ð,ïuhMŸü/9G‰Îb0=¡ÒÅòY;tñ=ðJ‚躤Ôáùz—dŸKÿFËãxZÿý¬µ€˜jù=­97 {zÀڭɯüÎ3u‹=mJêÔ”mámJO¬ì2ŽoÇÏi¨u [×ûò$ž’q6diŸ‚¦Á„|¨6yeûK)·ŠLCõþsåí&øÖã÷gý'íT.$$@¢q!Ügƒe|¼”—‚F*rt ²Œs›]%îJJÉ{X?Ó¨s¼R¡BIÑ* ÜÇVØa$²¨l,±0¶’¦7n—€ë|ïÂûOâÑ-Aõ]½;¾ýJïh‘^½uÃ+¨õ¨¹HÇdò¡èº›ZŠÚ¦ÀS'p¨ˆ|‹¿â"ªYªs!-d>ÃÙúÂí}3œ~:²m‘‚¢÷>ã„Q^¡(Dò­.)öÜ5!¦ìrÖpŽ `‡Åð"=R}­ªçêwªïÄþÍŒîñŸ1ë hlŸC­'¢ŒÓ¼ð¶ÃC ÌáÖ‹‰YÎ3Î4WæéÎ<Ø[b_»ªÐ¢)‡±úp¨£¼U“•zÍÐ{Îké­åt¾ÍáÞ`NõÛ´­‡¦AüÕ9¿É {Yj#tºÊ ú&oÌ厴жæòØ#¼š»#¨Ä]_·Dµr˦é8]NÑ'çÆ’¦[ƒ”Žp·ÂwñE@SB^Rõ©Ër«I¿Ù&±å?Ô7ócFöix\*”¢nè[‚ ‘à¨Ï)%Ê} OOÍŽé­Î-§é¥ I&EXE¦3 €û‚°wð}Ê¢¼ψ“D íõ7^1pøÇ -µÍfêðrW¬v>£>‘ŸÅ\ʲù#Vöú@E+WV޾zÖwÚ‘OŠP3fçŠ^çV}ÅùbEGÿiHh.«Ù‹ršç’˜»‰íÁ(wG™äNýöÇéù©Ï^xRê hb^/p⢚0–^%ž…Æ$PÅDÏùïâ 3¢æ÷ b¯Ú¸ âl¼ Öì„¶qTøc4ñw¹Œcz(IÓBƒÕµ<À$w; å¾p·õöŸêÙíõ¿…¤k-Õy¶¸bt]Û;9¢GÆæòÑ®“ »¥†ÿ O€ íãZx Ñ6ñÓ“7[!UÞèêæÜ© X®ÄiÇ»¶–!ö{,󋯶ó*2¼£î³gù}l^3&ƒ¯ø}¥.¼‡X‘²€–BÖåÇ–•±(O§Õíf†‹›þ®¢æ)BÓq Ù€ð»sž•á‡û BÆCû¢àFÁùTär¥Ìëø ¦MWgÊ%Zì/²µ£¼B0­ö¦?ObÚ‹/¢ sÉP¢`^‘ ûä¨+–@‡ŒÜ±EU&鸊e- YÊÎ5U³€[ÓHkvf¯ì‘AFÀ¬‚2+ÎÑÌ;í ?ឬ÷so9D->ø¥”šTvüÂì+›úí¯7a<« ¯>@æÜJ'‘#(K ¼c'ÇùÊã…>µ†7F”ò;Ί<ôÈy¹ÐU‹ÚŸ4H#ÝÖ¢}¶ÐÖ2ykˆ„ÝÈ9奶Nr/Û˜â°ãCP¸ê¡ø|ŸY{BM°à‰³Æ¥DBa+º—Tµ!÷[Hýõ‚— --!LÛKê ×ò€â̼uŠ)øõ –¥³/…n¬Óx|ú.óôÅ”º~Tño+'Ceb(ÎEñ‘ä®KÅ9¥è õ1×­ëlä’ÕϼûäˆÓýôß¹Îü§TµnÛ8,â)Öë1߈ ìªÞúõÛž_<ªŒO™»QfBlÉsåq¼ÒÚÚûæÂÙ‚ãƒ\έ—š  “ä êÚsœ»lë:Ï-î,è!hC)ù<Òy;Œ”afM_÷È´|'Åmðbö3Y®mí¥¿¦1yGYÊhX‹Õo•›M%²OÓâô—xÎî8-`(Ó¦4²ŠÕ5ri7!Œ|@W0 2^Öâݸ•æaS ³þA·é ÷BMþ"Õøˆ§äó´‘šZ¨ÕÖ‡o4v¤Dñeþ4øÇ/¿IðOÅqò3¿Ü¸%š–`C cãëò™•ª$ZE.Hü"3ûÓØ¦½;ý­†ŠÃâ/>#&=åd<…¶¼‚ÃÿÍ…–žª›š5=ž}ÂUµW˜¼¨³6á™Ó‚óò ö> Ý‚ôd$(ºpï²% ʽcÀúN.ƒµ ÖƒŸCoœ¶ WÕ#I½>x©{°ª _c;Ày[Åä<ê•Íô ×(~pjà}5Ç{Rúùôt>h6ï¼4Œ3D;…m„DЧ'6Åd`Òô}¥þZ m©Új¹Ë"¨ÿ'0Õ&©Û1é+´k]^.³ÅuOÖMä¤áŒ ogæ@I¼l.eps¬@¿•‘XÈ:ÅIVw¡M´Mö@±U`\k´V…g?”Ûâoˆ¨ÉG3²++FdžXøIâ¼½s+ÿÉŠ!(-ï~©iïÆˆ'e?Èó="¡ö1õW)‹^ããì9'µR+R_µ¤)'ua³}¦ þ³ÀýhF0ߣR€N¨êä˜!œ 'år;zå»ÇçG‰ÓÅâø1+wº/v•²ÖÃ(GÓIâÕ>½Ó¸& ÒÇ9ÕÁ\õÌ@¬„Å-Œ…U©øçƒÊ‰•¾ño˜~À)¼iûDEò’3=CR‡R4|† Õ’LÕ‰ÙÔO„äDÑ¡ ¶?׺GÏ ã’|eë»5õýhu%3• + k8âÅœ>z#}vÿÜ÷•,-B7º¦‹|ñag‡Ùû–G.KâtaĵåY±(曃üݦÖU߸ËXwô‰Ö{É_?[µ„"“ Ù ~´¦'tõKÜeêj´e`îô4¡xi<€a;à¿j´e>Û'\H’Ój>õ\ÍX”e;ô§©‰îrUØâäÄó<‡8ºj]åMq}M6o©rVvXt5…f›ñɧË\œ¹5sIU ¡Fi‹b\•ä^Çá3‚PÊŸ4Uý4Úxmâ¸äÒ­?õb$Â:„¥®äí "S§& :&ö ­5Ú¼c,ŠvˆlÝíV¬=Ò‡D :uH…iCÚWŽ‘ 6>wÈP]vI0iF­0}‚œ¾LÍ•oe†U\ÏóÀâÍîö©èëd‹Y"µ¥ê}Ö¢ÍÉ Sæµ3Ë>*ÞŸHÓ³g]Ú®áýJË u€Z‘ŸÕQBÌßV¡oòÁ¶‹JÃSŒX¼á”aùæ3=äfC‡kœB^1Õ§$ü.ÅŠ7EyP;(”ånÈ.¼SµtlfôcöhöÄA†ÅK8ì ¶'ü[JÉýLk?ÞÀrSÚôÆÇiQg ›˜nÞ«V¶D#&ßÅäô8°MOˆcæ|óÊ|»Ê.ú6JåâH•Êá÷STrš±bIÊz&Ët½T‚mi¬ÅG¬=îYÛl•hÛcaÏ„©¯Á•–èùTÞÆ Â’/áç±þ¹-bi¶ZJÐ;@Øs’ÖŽ•rèB4Ò3HŸ_šÛ›Dö8¡±r–5ª£S‚x‰L~êáJàAkP¯J“ð9BÏ@lƒ_Xc0¶´gµ¤=-§º7аÉ;t›{Q5{ãO7Ó)ÍÓSÏV¤<\x†ž=&jûƒO, ¹ºFßD9Yû*/”vú¼a™7¸U‡Ìgឪ’µãÚ¸8Íd†-ÑzµÀbîÊ·Gî[Xòù&I~å[,ܪ3~fŽ¡“’Ä å–›~˜C–ãÙî{1ϯ0^²kŒ÷:ÞPH9¹bô¹T3ºUåæ‹YùqnTNZ)üj°ýnK2û¦ÕË•ê Ãï+tϨÁ<Qù,(ØßšoµôO?Hþ:(7lY&¨©àSp/Öˆd.x¨+|é“™ó®rG4jVòΕ¡¿ö©»¬M`ì³#ŽËçTþüó ]Wq >~"ÞKÓ"üs΂Äè0̽Œ®Ÿ|×®wõIX×]kR¨Žù|zîÉ •üë– Êp¿QkìC¾Þ6?u ¾ïCdªfP¯ê(ã/‡ÁßB·—cI΋'x7|ýºì~x¦+gþÌÝ}½¦ó2J.l6‡{2ó|W/'*D#×D½Ì1ö¨K×£Áùε"TÅÒû+ ‘ÑU~F4Ö@³vß”AQíU]d‹±¦}“ì F•jÒ*e«Ãi •û¨%nCÈbSÓÿÔ|¬G‘{ìð«f.TŽQ6vk…ÉW­í2ÛŒdÁ+­p #A½‘ŒÂ×Üéªp8æê Î3Én_¼ý¹ÛYKþåQ:R>/¤g!¯ÖüoO5›íËÂôH¶(c-&?/ûŽøÈ”t…¯à º¦æ*S}vÄKÅ V¡¹ŽíÁ¤‡QÕ³5{çóÓû±©¹Q¨Ò+æ˜né>0kU@½8;vF‘÷3¸qˆ’È“VàÜÙ´š·m,ò@ ¿Ô…Wã¨òy ÑnÀ²óÄßæØÕߥì;ÉÌÇvEÜ©¿SoL÷×E˜®MË÷DjäË„ ß|KÚ^ÈÕ|ˆ¡kržcÙ¢á§IOÒ-У4'0?=x­UZÓͲ¤×FÏMõ‹+E„! Z‘›év×…Õù‡ØÖe/8OÒûí¥«oáOÞvÝ¿ªŸ)Öþœƒ8*µ3‰Aí kÚÖ>tY~ gÚVŽ+¢uï½z[í1ÈÚ¡vð³Yç×ތѡÖsõ¡@{J?#È5üµ>ìòÌj:?@i§"MGø¼~ E•<èÔpûuÄ@>tE/j~‰{Ie¸“l£Ž/áðú% i {`$‡Í:AÍlÂH8âzjE 9婯IYE2BÌ'wQ1˜7Ó³â«^']âfñ¾û—#Áï\áY€gdZçëºh]*3š¡3Ç5‰{L½þòW` æ«‚sÐÈzÈ+ø&DÇ,Bëì¼4kn—™õ£}м#êåÊO:æJ&e…¹0Jî¡®LQÜ BrÖÞ2ÙW>&ïà?âá+lN‡fov”΢ÛÃýá[^|>ºsÍ|†¬p˜Ì×k„ۚ݀ÍâқЙÀ =™v•?øò{¸!ƒFŸ”‡tú§÷ð›~áðv´¹dÐú½ÙBLDv=§¾Ùäú=ö|:÷Ä$i¡í¶¿VqúL©újwd‚}¶;çsš˜·,híêb þñ>Ÿ‰T¡ø±/{pÙ-BÑIS1GÆ/9=Q¯©×b¯K@µ‚>ÎÁìÙs.á[tØf×mÍ—<õ¥!â:]\ªF_Xãûv¶NBg}Ó„~•ù^ÑÆí·Ë [nKq„$qFÖ±&îqÏ…ÏOÿ“wCç t9‡Qam²±eÇÝés¦«Xá9É‘QÃüÎfNÔ“[!Qœ÷A™t8Ú‹Q^{}v7Øa.ÒŽÃÊWoõ’h‚Õ\RjÛ5÷Çk4tíM©Ù’*ÌÉ™Qê»Gߥ_2Ðù¯·†óô¾óÒ‡` št%Ý$živá Ëé ˜$ {@*­4Dd¯WäN”t·u&£¼¥ºÝcÎ^ ÁÅ’Z2ÎØmŸÈ΄-N‘ö“‹.Pb!'diQ/öXëÜÀ#jAô”·¾¬JŸ9º¢îðÑçÅEcŽ-Ê;Ôvge «‡wGp|9¿úÎŒgP*3ŽëZ@ñ*úå>¼åÁ^ñãz²Žš¥ô@É;>]Öâ@<ÏÜ>L Ö6RçXW\ ¬xø3ê+?ù€n‹l¤ü©CR–ïÎÒ×—2 õb)¿´|‡.òwlÕI뛎ú¢8Šc™°sYwý$!_¶ÁõÆ¢‰Á+E˜ppzÛóû?Ï *}ð2pæÌ’Õ_TˆÀ¢=ËÜ'ytêÙiÞNãU´õ >‹—¹ù8<àZáçiAÛ¢¿½0|ãJïÚD°I˜ñpÜnàÎ'¼Ì$»½O4žæŒêêG U_侺±oÓÖ†7aw{´­cËø“Á†nIAÞîma²…ëãÔ9»Ìc^Y··dÿNkÃ<Ù˜u7“ðy¡n€xìˆUeBðäë"M§è驎üºð,Âr*¦rÌŠt´2kx©³¬æ9åî[SÁ´·¿b¦·!¼ÚxD:a9‡ZŒ4&ùÅ-*Rgš8H:Ü%Û_½ûg­’T—8$.sGi‹‡›AÏ/ÞK÷ùEµ£¢åHatëèÓî‹/“ˆŒ+±ëæ—¯…Ißly££t¾wPtÙÑNh¨p3êô)(Vä©?3­Žþ?c³³ endstream endobj 21 0 obj << /Length1 1561 /Length2 8187 /Length3 0 /Length 9202 /Filter /FlateDecode >> stream xÚ¶TÞ-L§4Ò1”tƒtwwK3À3tHwƒ”t£tIwwI‡t(ÒòÐ_ÿ¿o­÷Ö¬ÅÌ>uÏ>wŸ» ¡PÕ`³€˜¥!`fv6~€„’:;€“……†FäbüÓŒB£ trAÀüÿ pšº<Û$M]žã” `€¼«€ÀþšŸ‡Ÿ ÀÁÆÆ÷W ĉ iê²(±ä!` 3 ÄÁÓ deíò|Ì_?tæôv>>¦ßé1{ ÈÜ P2u±Ú?ŸhnjЀ˜ƒ€.žÿ)A'híââÀÏÊêîîÎbjïÌq²¦g¸ƒ\¬ê@g “Ðð‹0@ÙÔø3€¦5Èù»ÄÒÅÝÔ x6ØÌ`çç W°Ð ð|8@CN âÿ¬øGàÏÙØYØÿ.÷gö¯B ðïdSssˆ½ƒ)ضX‚ì€iE&€)ØâW ©3ä9ßÔÍdgjöð»sS€´˜Àô™àŸôœÍ@.Î,Î »_Y•yž²ØBbo»8£üêOä4»'ë7k †¸ƒ½þ– °…å/®¬Z`£+PNòÏgÊ?6+  €›‡t=Ì­Y•×ôtþv²ÿ2?3ðñr€8,ŸI}@–Àç//gS7 ÀÅÉèãõoÇ ;;Àdî0ZÀ(ÿT6-ÿÀÏ—ïò°=kÀöëó÷/ÃgyY@Àvžÿ„ÿ¾_V =}M=IÆ?ÿí‡x¼˜99ÌÜl>.nÀç¿Uþæÿ÷ßVUSП½±ýSPl ðýAáyvÑpûStn =à¿'(Cž¥ Ðý£ü7lÜlæÏØÿŸõÿ;åÿOö¿ªüß”ÿ¿ I»ÚÙývÓýöÿܦö ;Ï?ž•ìêò¼JçÝÿo¨ðMVZ€\íÿ×+çbú¼b`+»¿Çr–y-TA.æÖHè¯[x.oU!Π_o €™í|Ïûfnûüž8?ßÕoðyþ{¤Øbñkï8¸_LœL=QØžåÅÁÍ ðb^P  ÇoeXYÀ—çÀ3=€%Ä å×òrXÕ™þ@\VÍ¿€ÕôÄ`5ÿýê•Õâ_À üä°‚þŸ+Ùþ òXíþìÏ¥Àÿ‚Ï-9ü >÷äô/ø\Ùù7üÏÌ]œžß‡ßJ}Ò_ø÷czÍQ–æ!æÁ6Ÿ‚Ûn«ÅˆÝ™w'„fhvuR陽–œÚ] #&ÓWe®;]‹%÷`®lKÑ]‰.“?z4×!†µ$ªµÞ{?Ç«Oí¶¢,~Ƙ,<«í'E&aÖýêýèè­` Û Ý)O“ëèÊ‹®šsëÞ'ãQÛ_úe,t~WíkÕkÔ‡Òiæ­è7E³4yfYs”.̤H ا³W×3Ø9“OäòñŒ(>‡1œ¼ô78bïæÞ®–kr8wRêÂ^aM½òß{/¿àUü1 ³‰e”#ÿQ>Ëð0eQž‚Îh׿×ËfB¡Qòðz#ò•0´}ôë¿Òé[é6‰:¤¨¯:!z2ÝB-öj$¤a,sLýëNïÛ9×#ù©¢t<™?Ú[ÇZsdìK§\:~mýìÒw>L®‹…ݧVùRýN½¼õâzXzèûëª3"É2Ëù¹˜ð_TÓx:0V3º¿¦›D#·µbÇ Û ÞFÏKk*mÝOj(V’…Ù¤ÚY˜òÔ—iO2?‹¦Ð¬ÖÝL¹ñ±²uäË’ÅÆ?DË¿òªxdó ¿¾ U9ºÃ}ßój[gnÿŠ+`ïšÁcËzºm+¬žTÎý½ÚH‚`¶$ïü©§6þž[úàTå£ËCÈäój¸Ö'C%éÞ¦‡õýÁŽè 3&ÍÚ9r³A$“5–MKâ×?°è,~È©óA‰ Ò—Î?üd &éÒˆN¼ñ¯c̱2XV?¦L<µ—ñÏ¢÷#™Ù¬Å *ï1ƒBÄé÷¨’‘¾a‘²:<Ÿ®;þ–1¡êüMÖÞª¦ª-sàxÙCJ#.-é²Ë'ŸÚê¨e³2x=cËô# ™I¯'“REÓfÔ=A-·åS3”«UÉŠ›ÓvûÕêY»êá+ˆódT“oÀy¤ÐÛCò ØÕ9»‹ø7¨ã½"e†nF"ï0„Ü–˜…‡Ñøp±°}E›£Ì1Ó Ç å‰Ö FcÛ넹PrÏÝA§ d²hEWéxÊÝa¦WR–'aQ‘ùÎYs’kH8˜“Ì^žFÉj-¸IÛö$äþîïdÐ¥ü6^ð·ïe¡xñw­¼¼’~k,çž;²hé/zÿuÃ߯âF0%N§JºÝ0T®zò²Ÿøî5ÖTÔ„³;Åd’,¶ ŸÒÈ4%LMž›8NôUeÿ¦0½eÑ{°¡ÅT\„ør-èg;8‡3iGÖF )ÚÅ•DL9XÃçåNˆ_I>Q!t+¶oŠ)Íd¹±Bµñ§’)|¤@¦á¶QL_8¾°m~¬V­·ÐeaÄ8npÕõíÛ ÄÅvBô­lþ¿öÀ±Ãw&$¤XT$93ÎD½]dCà‰¦I>»âÚvk‰fgóXr:¼Q’óbËx¡;*~NF¬ýú#¾àÃpkr±{‘ŽžfÏÚ@жÿ± Ź÷ì„õ#"ÓÔã"†®µ'w™Ÿ9'Í,ëô#â5&™°Æ«•TM×ð¦å…^5µdÚ ]9­Pq¾øÅhþ óÉÝ%Ó-Ök‡•Ib¥ý·¤{péÊÀÜ¡NX˜E›#^<óltù2þ†«gð`F¹ßhâˆ?YHt±\5éqU´­À‹uRîùeÙò½7ÞïŽ pwˆ7û”½ƒþ» ùA:™l £’¡šie¨µËÁ2ŸG/V4ç‚NRvloxzg™ó>þì‚ýY¯b™!N_«5%a)ÅËR‹&§Ãæµ¶5(3ûñ8$i¹G¼æ&rI¤ç4)‡é*nSv —¤®æÁ²JƒÆ†•ܹõ¦ “ÚÉïÌ!øk!6f-êS­“&¹)e”>†ïȱ‚#= »4h—8`ÈiU£Æb 'ÞÐRŸF> ž¼Sgó1XåɘÉ#ñ«Ú|Ó\ç,êK¾pçœÒÌÝÔÚäÁ›ñ’ûF®âx¥”¼T±b‚z+€>•nG”™Æóáµ1‡’þ+?jïÏ ´Ì­ãK¥ÇÂP™ê5^,äS…<ãNc' \‹`Mv‘ÚÊ"[Ïe¸ºP¯ÜgîRƒf-ûCŽâ·hÖ»xÝ”ÈÐïirnj‰iØÌùFõßXºèÛ…ÞX©f–'5žyÒÖcâ#70¼1è°ê¤ùœø%Š2â°ìû"ÒnâKÅ[EœÔ þ{ç"óö)„Ý¡~Oo(ý'BÆÊ± `~º1U¶°«O*ß Ÿõf ŸZ*vöóþ ®ÆˆHo’‡ÞQ³gÝ$¿dÜ›KËía£áµ¨†C\u80Ê.ís ßé¦3¯]`7Ì'ÁQšôt+ € úé {ç‰o|¦„Àí‹V˜ªvàÑ ~ÊÝOTO–ÝnÌYK"í‚9"„¦ ö"Ø€Àü%šM²x‡pl/6‹9jÑtÊX~†~•8¶ïòÀåâÄÆÀžnå,5bÛ²ýPÝ$»–k=O‘¬âÑ¥¥Ò\B7æíe£*9à‡ifbD؀Ƒ:í1ve2”YãÔ]~yÅ¥.ð‡tõjÓ°Q¦¹B×4Ë.º,'ïš.ÓÍÇ$ÃøäZáÄ‘fòo X%âol°UD¨)2 8õU]pŽ^L?W³í P=kð$?»…·ðRP·vå[rLGí¾\Ö7ó `ƒò”ÔYÁPoŠÁ˜åÆŒº 2¾ž›ïØâH{ :]Æ~]›•±sU ƒå5ÈrÕšeøª–ð}’v°oùÄt—žÅ ¡²lR£?²Zª›0Ýd….M6#IR÷nAç(o”ä;æ]°»LCŽ"êYääP‰ôÊ£²Èþà0­¹©1lƒÁœÚ¹»¦Àø[›qÝðƒ ùqÐËÆ=pT B8¨¥í4Õ¶B«NT¿1€n”„ÙÂÑ’p[åÐÚØèP¿Rž6k’O¶Tq 7¥°½Ù$Ž}‘PFàSê›ùš~üÁy¾ïµÑ¡Þ.pO·ºØ“ïŽ*zjÏ>øS¹”ÐøSQ®D9 7‡¹ŠÊV|e- ’¥óÞ•jžÇùÁE¡·€v(ån€^úˆžžìþ}¶èR$¦Gup2Mêp¿»í8é·O/KÖ±“ŠÂ’Ìá*+.a‘Äê„ûæRPÔ_æ¥ûñµÇ…Jh´*uÕ´\}ã ^F߃‡——ÅMÁš$’QÑâ²±¨h«µà–$Ù}£º ên,ãÜâOQmHRÎãI¹á°*+í¯PÿÄ]cçøž¨…¼ï*ú$XdnvavÆ 2½I¶õ‰¿yÅ>ìòbjÈg×ýJ4 c‘ìns7]&äq_›ÐZ.ù‡AÁáó8Lø¤£†gZÞi—ÂâA˜GRAîëB_à©mžÖ´ŽiÙ<úïHÂ÷æÙŠؘä’â¡ëzh6 ŒµÞØ=tÃA?é ƒ®ñFè”…èÆ¡Ý3½ ¢Ùg.M?ê} rU•ûrï'+¾£öî¾ã¼ßzï)´~9Ô—7÷ট(¥‹Ð1lµ -GðÃ2úû…îÇV%«#_ƒmÝÆ§C 1…{ ƒˆšyh™d“¿)íÅV÷ ´p|¶KåÌâ) ‘úæ eßtR¤QõÒ‚‚Jñ›{WÞm¨<š®#–f:Å‘æÛEOý‘EG_"ÑT›X’FfoªVe$rûðì ’xÔš™ìØ”´ÃP"TGÉð±0éêSà:S¬²B¿Øê RS¼ƒ·Xld‹”¿Q…_Iðøƒ«…_Ï ©‹U‚z‘•u@8óÖ£¬‡C>ƒ¾`¢ºœ‹TTß`ýX†bϲZücÕ¡7#Îc}Ë£L#ÆÞcÂæ¨xû•Ó¦u}=$©Oس±ÎPÿ«ˆÅ´ÙPòcÜ6HL©¹f1 îAÍ+ä…ŸbÊðÃW±ØœFÑÑky·+&ÀƒdWí4µñœGs¬Æ[Öj÷þ©˜ÒH\½Mt;¨ƒÛü´ß-ëʨo Ÿ:µ+‚ æ´´®JU_³#o7Dº}ÛiäJB$ïp tU C[{1¯ÒqÌäòMNò$(‡„ýó·os„³Þcok\_”rÓãMœ¦zêȳҵÓ9WÀ©3¶ÕãgHV&—6ÎeÇÖ;Ä4Š*j.ïÕõP¯S¿€ëëàH² 7\I¬T¹Þ¨')QÐønQ}ïB‚9P9= ,/éÕ'j‰M7¼ì2@5Y‘‰/Ç_CN¶y"ƒÈ4ÉŠÖ㨇¤^ L#Ü3eÓ› ˜ÎÐ^DâíÚGáFµ42 ?}ßÞ§B±_#$»Z±Ž‡7{Hë´Õ8`ÉØy+õÄ*ô¾ÕÈÔémC¡ ú{²Ç×¹e¯ãIfÁ'}ë]xÆ=IŒ$µB7êõˆöøm9˜Ÿ.Ø#€åf•A3>9IàVéÐ89çǯÂG®å5hEX+ð¨Î¼ªÞª²ÛzV¡‹'´8?2tœ¨­] ¸hè –‚OøyÞâc°ÇMÕ ¥åíŸìí¸|ƒºsé‘ù¹fú®Aÿ8½Õ~Ù ¿P%­&sz¶pÆœ~É—ë—„yé¾/7ªÒÎ@ãû’&uŽjî–ÅïÛ¥K¿4Ý•RÑÉLjÒÂú|î:'£0y8£?*è°| Pa…Øt‹¸À°‰¨ûæÿ üžýaÆ~ù¸¢Ƙ3x&"@"£jÝs7J„|@ƒ }ªÙ_C?ºÀtP(k3©ÓO–G÷éüG¾t9c¶-ÿÃ83OzSRw®€^Ö «øµ‰À§ðŒÆ[ûÍb7!bS‡´ëÁ")ÔZP€2è]K®8µîQÔ;ß}x*%3`±ã›(i^–ÛÕèWìæ"¡Tø‘+âB5—?¶– ñÂøGàexÁ?ê$“¶” pJgÕåÍ0'Ò+43fê_ôÚXž®éQ_µÓ²+R ¡ò3ì’ÄJ?1_ÏDŒggM|# ôȻǗí b‚¯è!ˆ¤/l ÛÏ1PÓ +c­5½ç˜•Lp0yŠ0œt¹å~¡7Qu9ãæÕ:]¿À ­ÑcçëÅÈ™ûáæ‡áím_¶öéîǤµÅ¥èZé5ß͵> pUSëUxnJ th_püAƒWÚv”X‚†½Ní×CnʨG')·¥Ýpªt$ËÖgy™}š]vš˜òº -|ií¤ò¾)?¸ÄÃχJS=m , ‡–|³«)Ô^ž¸8òª¶v¹ž¡^ɯzŽïW% ˜Ò§YJŽ@¦½¥3b‘B³hŒYsy`^5èJ^OUøîñgÔ;ð¨Ö-®‰TÇ k­Yžô„ |L;¥Ùµ0Ã%ÙwÔÍvŽ’ÕÛI¨Ùˆ¸ÀŒÍ¶×F¯Ç b$ î$É ñS*€uZ-µjébÄ1Ä£“Ï<0?¬­ ·RN?i y¶&mŽc›ð 5ˆ]’+Š—Q±L"™î·ägšSAwÂ岕.ФxðÆãe¥’9\<$(Q=ÂjÈã8œÛ'éT§fŠRM-ÆÿÔy«Š+VŠš³;`ØPàëni8Š8£ÃîS>y}:8fÖÉe¤j’Â@¸±7X ‹1B™Ÿ¦yT7,²¤=r–Ÿì—è»î$ï€ãúðåg¢kÞÔ¬ë•ÜÙâüòKr…П('¡G e¨¡­x£Á=… n´„KÅ1—/Ó¬*xŸëô°¡žÒ¿rxkq!­xõ3ûÙùÿ[™LWgðÕˆQh€"åôMÚøa¯¯º\öÕ¾´äb$êÆ{“eò-(–¸'‰®T˜•kýPdád#äË>l…4lAD bùòMPÉÇ-åÒ¥>a(5{7̶¢TAù2àñ ìQuû“YëWÃ_•¤ß@%«ÍÒõk`dÔžÀÒ£žv ¾w>yŠlâϦ›±DØwÁÞžÙÌ|‹ŽléZ÷ÜÇܾ—jgÀ{”%–NÁ5æ¾6Eg©52’íqýY“ÞQGGqԔʵÁ‹pƒ]²ÐGš²() ·Œ2ñDï°žÿ¶=[ÇÑg\˜¸,Vݶ@|-‰6¡Å¦ >ðæ®íŒeÕ3ec†©, ¡Ïºã ý#ðsØ×[O[¿“ÛÁóW9 ¥³gNèÑ\}±H“MWC«BF5ªœãŽUÒÄ£ËqØÊB·w¶¤ÞíoúÉ-ùY×ëS ¯Ê§æ½ÇÄv•’1˜Fñ u’fº(© TF‘®éˆ³´°!/{‚d"§Œ¥­xvlëÃEš  Ë/˜ÅÇúµf®$%tz¥Ž}ÙòqÝņ¤=Q¹Âóz½B¸•o'àΤ“œ­×9ûû móc:> Ìúý¾Þл˜sˆ‡c„H¯,‘éHƒÐ–v—4I¨[4N Þå¥Ê,‘ŒûsdEîxE&0¢E–)‹¯Sß.3àÔxâ±…åâ°¥îs¬pi ar©™ö¦±VH¹ðçÚ8@~:E&Y÷‘$~»¹ÐÁÀd³ ã½®nyŒ•º’•<7­¨`K+¢ÅBæö©/^¾Hˆ'JRb“ä:çúS´Ã{ ûQÎ?ÉÂ,ƒéø…ag $4R:s[b1äù0" l‘´ñ´ÐŒn4óLªŠæýdipÃ`j7f’óeú Wçïøyø¶(( &"“„ë´8²½ëvëkêÙ’0¹.ß­rY:м¯Vq‡Ž /ä =‡/r2žëóyõÈÆÄt1*ݶ [ß¿÷\ýNE V¤™€º"&.hláQM¼•@b)~úd”.ÀŸ@RÝÓ§zl‰oÀ[ÍÓN$Ð}T³«ÅzE“39˾7™±¨9ÚEà¦!à±û‘ÕOð[ÇBeÀ.%-°ókþJCÑ©šÆÄýâu ¡ÿ÷P 6®ÀóM“Ôx‚б"ïò¯½œ.ÆçÒÉ…Ã:Hßµ»P úÚÛTõÆË·WÎ2ûæôÅCƒ+#š˜Q©ß6ÖÐ’­+61ÊèmD˜ÄéeÖ]Œ_«Øí¤M cŠ¢ÕJå›ô!•Lͱk1s*@2f‘Qlû}õGtóþ‰‡ØW…]PÇÑç×7VêYMü¬²ñ.º0;pœØ$ªËVïKý†,K*G4âTB¡Yñîð,yõßú:쉵Bâʦ,^&0–?=ØÜ…ËaH~éˆÕ3|®²äìÍÆ)½¾©E±tQg3zr¯Û§rêoåðqDz EàÞ}tX±xì6s€je†ëp‚{ žHùÜÆBá8øMÞ ®€E_Áx¶Âq£WÕƒ©Z_ñ ‚ö…Ã;3‹ûnª¼Xç¨aâ,S!~¦LâÁÀìâ>®$åÖÌ„md&3jY²N‡ú8ïÞs¥ûÆcÂû§17üùºoÃ|± M?”íþ¤ªVžK7¢@ì˜þï6ÙµzØèëÌÕ6*E†T™…&Ø.ç¿ldËùõ©·['7™ŠªÚVÂ/H`}†îo̦ø‹ ùî²;Ñ5>šÝ¾zÄìR pgqH@G.ωžµ ©Ce>-kº@¢Âì~ÇÑA¹›ö½BPÖS¤˜ë¡˜têci…2qÚþlßÇ{¥ÁÏTŽ— v×Ã÷µZMú@|š=Ϻ٣îË\+2Á´rùZ,µÅ =Åyq±i2%k‘¬«|~°"}>º])wï ˆêB÷ÅGy YDé™»Üô–óqU¹C­ÉJîù·(ïkÜä¨ÂKTÐIëDù‹ð#§—Bä¿„k"p_LrÍ^šíX}Ç¿k7qÁ)¼_…ÔÇ(šØkq–;s‹­•†ñvyÉZÞ04Ìã£¨×æß4\ùÏÙ#ÆÓa]C• MM‰&˜yS}h›\X4ÄŸ§^†"–`Úrê{}IߥRÿˆÖ®Æpبoš—”“7}\Ž [ÕpJ›yã™L™ûr–DwEš§rT@k°¡v¡ôÒHbh¢8®«Ó ]œ|gú!çkü SØXûæ±côYA4(…mÏCËÃúusØŽ&éÃý²þÍÇjµåê‰u.¸Zi+»Ù)y* "!(Ç×ýîš6G;Üž‘/T¬ÝãÛbîó© ¶¿•§‹N¡ Xæ°ð›GÄpˆ{»ÃñÁE ³,,JÄ·m>r¨ÜvºpTEÐŽlß–i¸ÓPûh%Þ ™”§»ó_W6%ZGþx¡>Ø´‚þúÚÝß‹0@L,²–lööª‡ÂÛIÇŸÍäfY2þu\ßú­wp—ØØrÕŽE_̵Žûl~ ä–’x´˜Áâ©3¤»×Tæs‰[Ÿ J#ÇŠ?D¹nØçwq˜›Ûƒ2O¤•³Œ’¶PŽÈ«¸"ieáÛ÷$IK†Å¦#ÝoaÌÓ笳~âÁ£èÔÌqŽ¨Ñ¨ëÕõŠlÞøéäÍ„ 7aîFÏï8'êã•<&º,F²žöøÀ×¥MEñá¥Ò²n1Äâëf:7–Œ3ÏÙTÙ™½6οÌ9ª÷XtÖÝX?‡ˆPçêþá”êÈ endstream endobj 23 0 obj << /Length1 2108 /Length2 12297 /Length3 0 /Length 13574 /Filter /FlateDecode >> stream xÚ¶uTÚòŠC±"Å-@qww)î—@/w—"…¢-ÐâÅÝ­w+w—âZä¥çž{zîï½?Þb­™ùF¾Ù3{‡ŽZC›M äd–wr„²q±s dTµUtt¸8œœ<윜Üètt:¨=øî5ØÅâä(ü/ŒŒ …édPTÕÉ äfàâpñ s sr¸99…þ trÈÝ! €*;@ÉÉìŠN'ãäìå±¶Â2ý÷+€Ñ’ À%$$Àú—;@Êì±:TP°,£%Рíd C½þ'£¨ ê,ÌÁáááÁtpewr±gbx@ 6-°+ØÅ ü¦ P:€ÿ!ÇŽNб¸þǤídõº€0…=Äìè srs]°ümE€º3Øñ?`•ÿX·ÀÅÎõO¸¿½‚8þå ´´trp:zA­V{0@]^…ê eA¿@{W'˜?бZÀÈKi€0Ž3tµt8C]Ù]!ö¿Yrük´œ#HÆÉÁìuEÿ]Ÿ,Äl ë¼Ç?GlçèäáèóG¶‚8‚¬~S¹9sè:BÞ¸eÿFÁTètÖ`(€““Sv°à7°§¥ Çï$:^Î࿌\¿Õ0~>ÎNÎ+°Ä û‡îã t .n`?ŸþWB熖P€Øâˆþ':L ¶ú ›ˆ'Àˆ6„\Îßÿ|3ÍÈÉÑÞëü¯ƒæx%'§'§ÈòéÌÒÒNž6nN7€ŸKÀ/Äðûß@ÿ´à¿ôÿÒj!—÷¯€ŠŽVN¡ÿ°€µï¿LÜÿÆ¿·‡ ð¿Ôœ`c 0þÙcN>NKØ×ÿï]øËåÿk~Gùÿ±ÿ·&y7{û¿Œÿ…ü¿@ˆ½×ߨ`»AaK¢ê[Çÿ Õÿg·UÁ ˆ›Ãÿµ*B°e‘r´† <›;/ÿÔWyˆ'¤ZÚü5<ÿ=X{ˆ#XÃÉòû°qý÷Pþ±Á6ÐÒvɸÂí/¶`ÿ›UÎÑÒ ô{¹ùø@ :'lÔ¸ùø>\°•=ÿšr»£æ€1ôX9¹ ÿ>Z‡êoÕ_’ 7€Cë$àÐÿ# 8 þ‘„`~À?/Lrµ„@,!.–nÿèy¹ëa …¸Úý£äâæpX¸-Áö`+è¿Ô|«ÿ3;ÿÄæúÚ ý¼Ï?úÿã+ÔòO °Ò`÷•ßb·™ô/–ü/V³Õ¿DXëD~˜Ñú÷C›‘?X ›? a4l¼œm`·ëLù—kÞ¿úÁ ë³ýŸ°êìù;ŒÐŸžrÁVŸã_±a× ‡ÓŸì0,ìYú#ÃÀΰ‡ÀñzÇËõ·ö;Ç ãêlïö¯Ô°wãÍ¿DÓç‚Ñúæ…±rµºÚü Ààø6ÃP§™anÿa}pÿ—£âñ¯ñ€y{þK„QðúKüŸ}°tsÑ‚þuuÁ–å¿ò_Ïì ¶DŸ›q² µ­m½©”"ó`Ûåéâ×½zr£âEµ‡ß`Gø¦FlWDÆ›})˜œ)«1d#^n„¨ŠþŽL.VÀÃNHº? A!Šô½FTMóqü”³‹4!†8õÓžŒW¯Â1uÉ•¸Ìžv¸AÅáÎîu2ʒܲgê»3LB„wÁ?Õìý5…Q¾´ËrÚG¤b(uÔOÜ2(bÔ^ã—µá™OÏtKcñ|…­>± 3(néླiS–l‡ÿÊšý™açœ5àzN1ÑŸö¥˜‹€&aK4Àí[R¬üÌÑwó¥b¬º‰³‡øØwæPáÌ4ÛgVAù6 ?ã¼³Šù§?áMv@&‡Íi·>©½% ÏV|!3«=f½§&ÕÔpHrõdŸ°%ÏŸ`jVKòÌà~:©ºŠÞ¨£ôºd÷̊삨.Û9e® 4Ê%?òegü0´«¼6óÂ_N^ÇH°•« è™´Á0—;-lÙ=énbxÒYº]î^3¦:ÁÅ’P¤ï}8Q@é>Æc,UFòØòR,GÊd|~‡ä{åÝ锸¬ƒ‡²Y·Þ¥ÃuptŒÙ3¥ï×dØ ÷T,5ÌèÕŠ$^Ža™ZŠÎ"±};‰Z` ·œ5zaL ZzˆÚÃÑI4ãÔ'+šçœÆ½ŠMŸóx³rÀNKèËp´Ÿ/_xœ=FXІ…]ÇNŒŒº=‰åµ¯ãK]YêiœÚ[KÕÂÆœO]Ç@¾é[»…#„Ó‰= !ŒN:Þå1@Šá!­$Cá>d©7Y,ã•à8>Cb!¡NÈ·¢3‡w¼±­˜]=?%íá'ôÖx}}(ú…ºCM_Cûâ8òë‹ ìÛrE“}'±d˯º—&SßûÙI舵ÙAßí]ûT^¦µ·àÅæ|< ¦,bм,gÃÛZõ¶Æwãá;n¥±æ%uIÔM$sé ´¼ª>ØJ-G)ôAä#~VÞpxÇñª'YØÐAçNÓDF•û³JFj>’úÇ gHö»b×!4Æfl»F)RJ&Uvl“›Î-Ó)zÛÏr¼k“”_ßÕd® Ü7Z»¤Œ¤] »ƒt5p7LÝž%ä,=± CS Òt“ù»‚!÷ä ~ov©é…/ *øØ(=â6÷j ’p°ŒÙ¡¥:øuÉUvnþÇZÈMø®’_I«¸¹Ó£<¨[ÿŸÅû¾̵P€,#Ý9S£Ùמĉ/ÄH×:Þ®·=*,z:Wkkj%Ϩ,îäC+ˆŒq¥MsãȆ7¶js¶y‹íb42Zúáxÿ|8ÿ¼º¦V‡36Tˆ•ù(ŒŠLIè|(–:ŸƒFŒàJ§ÏŠbµ÷>ðàJ3ôlâ ¾€Ô©!¸ƒýtÇnM‹4 Õ;¾“;}ŸËÿHzÄàb³:ºVMóy5né}Üù.H‘ëyÜnŒµ‡!¢Ùœ†”f“ †Tºøk«¶½ô²¾÷´7ò±…+@Å—º2^bÏ;ë‘Î “°…,_©pé]Иæ’  ^qÑî?—À!ŠS2¶;/·žÍë÷=®ÜôÖ®¥©/¶¤z’¤g¼dËçeBš0¸>`÷–b&~ð®÷nÖÝR7þVïµnÜ;¥»ŽÑ×íãâØUEœÓÆÜX k*‰ù‡/ëK6Jò¼‡Õµ¯‘Þøa¤j^âfªI7üñË“r‚òñWÝ–7/ÊõªtÎSTqzŸçM8¤DOtICªîÑuòØ«[„ Ìò%vc=>Þ*´SíÉ©fÄ4žgÑÕO÷JÛo³§vN³4ð¶#ÐãŸ<µ¹7sE¯#_ µº×žÌØ©G6Ží5`© ¨ù™È¥ú&íç û¦}»oÒÑ2åžaN?4ÛžÂÉ‘iu¦#¨´È>÷¾d¨q÷|кåÁª`},h¦‹Ó°é(YÅ9}ïæ(‡I~Ví5á¼êÙ©ÈGÃV`a2ïÕ)¶Çœçl²h7«Œ8ë­ªnaì€Ï‹mY²¨ÂÁ Ê4id}9YñÑ&âC9[2âÏ7Ÿât ÄÇz®WöxÂŒà|>à?®‘~¾[]2Uv§£=0”çŒ+W ëFuZå‰ëì7†g¥aμÎé´¥~VÀ]‡f O}[KïËòÖó6Hî|h¬³,ý+ARaÎ¥PPigÞô|]·Ë©¦É¶~÷„wF6ü¬ú8qUsÖH{Ffܹ8MÒŠ‚¬X9wÇ®….ë¬\õÚWõ­SSr¡ÅÝDü†Öi¦þ‚€3j׿WŸ}8WîYR8Â]Ū¢æöåÖêŸgãèã~ ¢ÌyoµUƒ½G;›%£Çÿ‘gÊôKlö‘j7˜5¤Éq4,–›Õ„X›†d7±§eLœ§–áœleíù±¤oÓ1®ùÊ H½9iƒ´øT:èŒÃèbìX'¢ÃïÁ8þð¡ö›F¾yíÞÃ\ ‘Fó©TÉ]/µ!Êk¶w5rX@¢&½t]dz‘ÚTãU¹tèÄÖ·K²°i¢ eµÏ¾[tßy÷‘¦ß]ÉÚzðbÅfÕ/KoC)k"OD{Œç¶«Þ˜µ!”á7Uj,½Iúý$~ÇÇÜQpsŒäyÄíËŠHùê°“i½™Pa^ܳhGã+/{¯!ßK#sˆÐ•„=;Æ ò¤~¦ÂtG²ö-ÆñSì¡ÿ8[æ%ºC€CHóæ>6K¢‚ïHIb_5«Í,1Ù§ðé­‘©™ñ‹’¼Ž”&ù¤‹%²w›c¼ïp•P_QcÍ»m–h¤[iq_‹d–t6f²<ã¥ÊšËŽž^2Âå ç ¶½.Ñp|Î’»~79«©o© ÅHýŒ(‘`MÆ-À#€®Ç“€Æi½5¸Sxˆusš“3+I—æJšå2ìpÀ¹ØÀ%ϱœ«Žo}îy…![O¢wãjñƒoùUp‹ÁÔ?“.Û âõx;GJƒa®s®ú¡’½þ¥ò×GüHzö ËG‹«B(ES4fwu0Ly™åp1¡üþá"y"ü¦m¤FŒ¨ñ[‹LHüu+áIɯ;IͲ¼à](•y’ q¾/ŸÜÅQGchå@ËápäöÌh–æ“•&ƒq7ÃU{bÔ‹é©9~ßúd[J(#Þ¾}‘¼Á*òÅÚDZ²èû3ÖUÁæ™ ¦s6£³_ˆåœp™yÔ*pºÊSÃò €õLàΦl„?<­ç΋ܵP¤ñ`‹/hýKré×oÀ¾Ð›X)’ž÷gïs’:VPÝé¾›ƒkª^vaPÿùH¨IÕ¤xTËøµ·ë³:ÕÑ|O–†:ÉDŽ—«i!Ǫˆ‰ÄÎãëœÁÊ»!¡Sz^34À{ðD63‹è³¤KqYî¢ü  Ûo“ìïùð~ä÷Xü½öR/eä$,­ô Œãt^ÄÁÁquoñšÒÉ>¨4{OÖbb ?B ÷féžmŠ[I‚ïû 0´‰ÎC<Ò‘ZÝ6«ö%Â>Ó+n,n*®|ö9¤›bY°ÁÚ7Ç%R\ß“™Ù ¹>4çÍ>všvœ½W±¹Ñ×o@Îòöoþ:È-,ÓFú8<:róÚúéTüYs–1’˜ao+†Æ%O~„^–îô¡áå/GÚ,5f\?£òÆSçåñî)"ðlÃûp¦„JüÎÝZùKÛ*xqƒÆ"Ü=bB›±STL1ø_yOv¤ÈÑü5ó³ïÇ~tï,i¼œJ¦¡Û¦JÑ8M*%Ky0<ƒ™•ôεǵ7Y 夞q÷¿n[õû©î5«-à²eY´Z(¡ðtþ"‚ ÿ;Yd<Ï/ÆoN¾&ºÈ°V¹g îbŸ¾g!S½BpW޽q8—²wK/^I,¡¬ª‹uyèªÙ׿ØËFZ‡NþxÁ̦§fð=1Ý©4Ði‹vÉ쬯«é©‚™˜|úGH›ììÄÊ”ú«a±t]Z¤ÙQ¤È#^%ª?OK~GJ¢“/=ˆuÝvyx ¥%àâ"Ÿ*¥ï5¾ K'âZÑ¿£+:‹suÛ°žlœ|W“xèçºÿ Ë,Õ¥ôRM­0°íÃ÷tGkÑùÇ|- °¸fÚáR€“T„}=¿(#§ìðáÕ‡¨vùnCÀˆgø/¢ÐwÁ‘*O;œtŸØ½ÄU›q¦ª¼fi¶J æbÃÚ‚þ†Œ±·£‚‹ì_ÖyüÓ¦§(:»¿±,+5Ô9E,† ?™dÚͱÔ?±µúØH)ŠU 刨*œÐ ±‰ÛŸ*Q¸O)Ô}ªÌ—Zá ÛFÒèÓ›6âDõÍâ=ÔWb r»!2DŸ6ä e&è…gûÏh‚ÔÄù:¹>, =YDaÌÙ¢EBý“(Â8)f–ß}r-¡r$â¹_g-ojç«?RkÊVBšœ¥n,>x¿²OêX91y"·5sO°W-Õv@&O–?mLy¿¼èšˆ¶ˆV¡l;S3˜ ]‡:`÷Õ:ñdˇ…ߣgQž?U‘­]º‰”=‘ýâ¥Q\*A`*ýPúmo~×;RP¹a÷†:žéè#1[TA¢ Ù78Ã=â$ˆ„$ñ *†Mî=‹­4µâ)_ñ°äWŠÞ½Ñ<ð~­Ðþšô5+«Èga°'0ÔV[RÓ¾ñ¼•†mŸ*mÜ‹[ °æp³p¬7€ë“blí!P’Þí½5öÊI1H¾jÔ”y,‘ƒw}¦ÿõòvÔs]{djïñN„Ä Õ[•{ÞË=‚Y\)Q)©”*e]HÆÔñ.nÀ/æúWи WA'…£õؠ臭#û¼AÏFO¶½UЇN´q¢Æl8?º‘8ŽNMÖÎ+\9ÊÀäñ=›?Q}Þ}ÀXÍÕŠ›^YšgÃ÷ÅØHÿ j㈼€b‡-ƒ$ 3®WÕ¬':©0ç*Ÿ ®îI”ŽT9饓{ #¼éMÛ”ëo–ëÆãÝ-úx1û"˜HÁcèvFYŽv>@ŠiûE¡Nï…HâkŒ’¸ jý.ãD}Ž öΨäíù²!AùÏ~w=‹ñKt˜\Á|¦Qî½Aë*æot‡³`¿.KB4·GÄ2É=N4áWÊÙv:ð‰£PÛ¡æuþž‚Lô‡´|üØD BJ‰&³ ‚U)VÄ6ó Ū‹ùכ䜔vˆ¨òÖ©7¯Â4U¥1œÚ¬¶$èŸ$ßÜÊ‹¨˜¼ (ãÒ0¡º;›Ʋu ;³{ÖHd˜cUÈ_Tà’«&íù5Ï•Uɱ´T`´MbMFzââöð2d÷èø¹éRô‰ [FxøRxâÞO¤E\´{U9KCwÕqã\wW8ùTí6Úwfœ#eàÃÚÚ.gGˆí§µJ](žŒ,9Š5•fû Œ§½FèÐÖÖcÄ&møè|5«…ÚZžòýßár#ú:³´ž‚"ËòÞ¾É åí<@Ìš°±~5¹-KêÙ.-ÐNõS^ª¬ %gÈíá:Ÿzk^ÄÑcUŸóaÉ#Y^‘ ¤yÅÍšÿ}#Ä)Ll'+‰Tl¿E²…¹¯“x"ž©GVŸj;„ëmµè=öpÿ~ýñŽÐŠ6Ε r+~ `òΖýÐ8K»S"fç4âƒ<³ØVkßã¡û'e¡Ä ´ð‚Š9Î[®ÊŒ ŸÊ7p&­¯0ƒƒÍÎXâØ×„GŠ©ÐQϬÐò^ðñ=Cï“òÈÿúìþ¹øôÖ¹ö&º`bÂ1 Of"E•B|‰öÌ)«ºkïøÝëg˜¿Šd®KçÏÆÕnd·…ûº}×ò‹äjóå÷ÎûüåIGtïŽM~Fõ7V´Æ||Ç{à•4/ì0.ò2Îß ¾u33Ïi¼zô ‹Pä‹–$¤õ‡®[ÿ¡õ·Ðq=EÍpÈ£¥y1½·›_Y‹ñcˆb™—r²ëm`úØÈv}}%hÝóer¹!hãÇ9 O ²ˆ†ÿâ|*èÒ±ó}ðY£íŒæ üBTzUñº¥b*¶^}dæêUðÜâk3Áé¡W²p/α Eí±šßׯŒ×èZ-¯Ò”š©è}8ÄKÿØ\‰àE¤•.ºTÜ÷‚ke:‘A8ÎhÈM(9wŸ\ÙIzú:ŸŽ^pSe-;‹ ¹¦«ˆÊæž3zíÅÌƯN‚W“ì4ëÙº·/31}zBâôA³ýáëŸÑ0/VG·4Å+Ä߉”zaG0°ôh†÷“·½¡G n¿r!Íšßů˜FÔpðpeã6Éx×mJjŸ²:jV Òð×à©-U°ªµññçÈ¡×yÄÄÒ–$îù²®·NÖàÍ®«Åtö¼·‹è 4Ryb¨@¹õÞ[°zÙþr±ýË×=­Ê]ßJd G¶HpÃQ¡ÛÔ.D=˜*¶t[‰ÈdPHk(=qŠ $ãMS-ieò¹ÅŠX4пB·pE¬f6ï5]~D)>ëN—ÁB#ÿ¤RbF¨¤%íeÿ‘ TGu¼—JV€ê”~Q‡BŽÙjåË¿,ŒQd;ðK´wgÈQšöÙó)6ã½á%V6NYïv¨7ÑÆ¼34Zpd©ßÍ Wg¨Müc£¾b·ÌÙÀ9tÿìúTÓ]&ž*i±k`5¬[͉7NL4šàò7ÕuÛNªÈ#N4‹Ë¼ege¡uè ,G§Öá>G¶DäÂQÞJÙu:²k7• §6d‘Ež+ y`àlЖ ¾ÌÆcý¨Õ ÅLìû´çйáaüPqm·¶ñ+v”ó»Ï`zÜb(cX b¸\(_$)o8 â™Ç/wAMnÔêfÛ x®ÞZ'çˆ]¿¢ŒI- ¹zí³0„{3´2ZÑ-ùbT@¹H3FWÐ^­]q¿O•#cv?èkÉÈ¾šžØ ƒx%œU«÷™ŽÁ€«ø§k±²öpÐÞ€¡t4}6`I ¼ÛZÕ¡ÀuxµLÖ”/ɾþfÚrª¸™§J\ D¯ÁÒäꯖ¶ÄUêkÊP1×îu ½-—ÅËÓPQà t³ .21q“sçspþLD3LžÑ¢àrL@=Í5KØ%%ôѦÿ`®å(p»ÆØz"<˜"véá$*–$ûŒUlšŸÍA'±¹1±å#–ë^Êž¾QˆÍjÉ¢ˆó%&P·ðW¢8!£NØËÖ¾{šáZ. úfõ'có=OȉDyEvâO¬ñGY×éÖÕÕ}—éAÿØ– w.éa²If[zrCši c+ÒójYÕžGÊ*¤ìGôŽHçŤ=¾•£\Ÿ Ìô—%cuïÏ@ QïÍbP  øBGq2캋̄|»z&3ä(WŽ u.VOК¦=ç®ÄAfï±W®D´–þ ú"ÄY3,L–ÅÇôV¾§žaé\j¬¿{Ô‘+o–š!çmòœƒŠê·ÞþQ?½~„ü/©×|jcÚ 0ÿ¬ºŽÈªSKü<ãz¥]²C¼Ale¥F'÷˜SñÉ嘇cR ÿ…òý;Þ¤z»“D5âÔÔ£$Í2.ßÊ%”{¤*¹Ùb]Þ)Ô»èmù=Ͷ§Ï1×8Hk(_¨DÉ0ë+_ +r7|~´ ®„J¼Íƒô~~€Ïý櫚¼zšæÛ†pœ2J²T ÑåÛL–ÚJÔ€7étΞ٫@ñ¸¤#ŽôkîdÍW–_Û­i²YŠ ²ÍJ=Ÿ‚?ÕpÁ;Ó¼BoT¸GæbáÔ3Ín’¦ØÒG`ì¯~½;c49ìüH‹V’ÓÖ)l)7¹Çî²ÁÝózW'ÍC1É_¸Ò±ÕÚŠ×ÐÆ2‰ìeÀ³F³¹qÄÌ”Lwž—›¸tQ1©~ÐJ„~áÍž`…LB¥QE±FŸ-#Æ›w‘ªëüÒ-è}5©åÞŽ ¥•YÓ`d½ÀÖjÌvF»y.͹uw@ CÏ‹W­ë2,{XoÂl²í¾çÈîå=¤œø,U3krÎu<Ÿ¨¦o°¡ IM egŠêFfAGêÞýÖC~¢–¬‰þi¶i<éCVÃ:™àAÖm§£­·^ï9jWx=%ýÛEêÃØÀPLPÔˆÙ’BKMEÙLoj Èó¼ÑÂØL«öÁ²ï•×ùç „Z¨ìeÏÇγoç~\Šd5ÿ(3‡«×€?ŸR~˜ÿÙXêGKküüø€Œ<$†IákÃû;L[Ùuß¹„Ÿ¥ª’|Éôfˆw$îB¡–¢C/•Ý=D6Ü/zõÏ|ª„5 ˜öCµnPúÇØ}­ê‰ þÒ–[š«m!%‘OrŸ.r¬‹±‹fHf#Œ¸ žŸT4ǸýôuëC ¬wÅCH]áŸ"£‹.* m+SN3rÈ”¼Ê5®t˜Þ—ŒÄ^kœ&ù(õ£6ü67ž™êŠæ*h žf•ñ8}JLæšœËË[øc¸ó™çg:¸I9ïô¯¿îÚ6…‹ÙúZ÷–?››‡`×9çŒ ~o~õü‘Œ·“gÏRª¹MYªhd&`´eĽë)éa“t½%5{ðXõÜù\neŸô‘?1S›H cØùp*ª8œ:ø.^N¤–ÙÅ︭âð0¡„.½/1@|lÃŒßêB_XöL¥ŽÎNVŠä®qþ{&íàT1”ç£8>(‚oWE`¦K¬àÌj:-€]1’š# ™³žv¥:¬…c!ŽÚ1"ë’T… êØ+QMàRÎVaß÷¼“}¨³§h1ÌŨE{©³ѵ‹z¡I&ñQ`ãZ}›"ŸëÛºvš½ÂÍÁq¥¿ãM ovͲ¥JÄH@ÄJû@hšæjwõ‡˜¡BT`ù™lV>œãªK‚Ô™0ÏTâ‘)9_³¢±kZ%»ÅåÙ–¯‘|³}ª[ƒ`i¿õ¢…Nsq g¶ kUœà†[G}·›r¢^–XÖܻR|†ÇP‰Ç­µéºQ%ëmÃc£å±?':±N=LݱõH¸Å&œ;ˆ›¹&‰lóRùëºÓýý*ªË !LdS}ÇBȸ©#M™è7j•ÉÏSªá^}óuTºá-×âP¬ïEÜRyø‘ú~ÎqJ>AÐÿ’+å%ê¿R9Àg,$¤' †«<¦-¶ós›“D‡ã¸(Ÿ“håú£â´™X™üª‹ü’Àå‡\Q3 ^"½,¿Öó¶-§üHv1ò/ëiCfðW?uëÕхǶ+Ó¨>À½TkrÏYñ[ûŽþKÚÈ×M4Ü.4ËjžŽ!³±Ä£_zÔ–tO†sŽäñ÷Ýq=o7@à[hä`ö눙|›™Ÿc¾o.’sqf4œ«ç´«÷ÊÌWRcT#N:ƒÃë|.Y·´{F¬èÛ!ÑD“Ï#/ÚÝ Ð{½êTÉ¿Óm/ÖTrËß÷aGó\Bž/+*¿=l/.«…þÈ®wÍ"#ÿ&wTÞ’ª¾ÓևĚEß4;ÉR ‚xØ>å0Ö3n“©òѱϨ)ÞúkUHZ¦²ÀO¶™Ä_³™ ežÌÝñ~²&äÞÂK{ЖH&®Îžÿ„~ÿ?÷€2àVxn¨ämàžYY»«v>Èû¼ûÛpëóà\ô<×°ûìêjβu€ …‘ͯΈ>Óÿá°ÉUõ™hŽ×Íœ³ŒùVq`Às_hQéÚ¹j3á²W× ¡±4ùó™¤ßWØùño%™×ÖåKo»G:¡Ôâ[ÑÀgsÂË «ƒªÍMÖøh I‘E@²ÅM#¹¯n‡ói:²2Áã(ú¯–½òž[¿Ì#U•dº-Òòî;Bôï<7<Û2¢ä63Ü~tV%*è’ç`i„H±Ö7Ë¢]õ÷ó‘ýô%ÈÙÙÃ~å{lkWzø(éùÆVÕö hΑœ°CÙ¢þ:•’R ¤ÀG›>{OyQ5*rÞ»tŠLËÊñ\&pCeݬŒ$dM[û\²ËA÷S™È» .|ÕÃÒ\VTxî x&òö_?úv&¹Üî¬ðã:ÆkêÉ* …OVZ-”ü‚N$£áÃÈa4Í¢¾^Ôvo âÌ–÷òQ£Ì}Syµ2ÕÂÓ¦zôÔ9ÛÞP1®¹!?^ R⤧BÙO„Sþ}Ð)ìê'î³ ¡y|*§Ey`·_™Ú6büû[y:NÒû†¾Üö5§k–­PÏ%&dÿéôuÙd=¼´Q`R<_\œ_Ëg—"Å¥®’pú(?78D ó8Îð+7W—Ìü*íÝë±#‰½1œÂß³ ßèöBÖ¿2{ _d4kPv|öó ŠÇ¡ý1nç½MZN36ÜEK¿1¨mç8£:"0Ä|®€ãì:=Y¬MœÄ ÂúÐTü!O´y÷m¾´¿x£îøž0<óÚ¹¤æèIš…ÓOéD­Þ#â@‚*Õ8tÎòiêÏ«ÞTäB΄hK̤ûÌ¡®|µµ£QBiPŸ5ø¨|zß©ÇТ2Šs‘¼Û7ݦÂ2 ­<(¯¶ðžc•䈌ÖåWDyWO16­zÓ7~¸­ž4u2Ù²-Ñæ‚~f–Ó—n¾W_ïñû-,ýj/Rûöóv+˱9½VÒû|*\(Q¾øÇX±ÛNzk¼›ß {ÊBÈr‹áÒ‰ÂÁ!ioAœÖRÃë^fÚ_˜\wãáóʸ}Ų*«¡ä['Ý>Ü~ðò9·.;Žîwšn¿£1»?™“)±„ß¼Bwæá£\A~òs|Þ³±X*Wi>i`‹M”rÂì—\tÂòjÝßÌ«}¤êuŒ~¬xzw» ÿ1&àlBŒÂSâÿºto~ñ `ýݴ—ªõ  9­"YÇ(/Æs>Ý[XàÖ”¡=Îz‡ËhpODÊ\Èt÷ÒÕ PÙ s¾#%·Ôn¬Yÿj(òöÍGϘm<¥'ðóú­üÈÓéZ!ÄBx=&väí­ÜÇnIIÄ©CŠÙ#sd´I¥N¯kV³\l…:aZÆ{ËÝ+ÙÝýÄ< Û¤U㈟mžå«’&Ј>™fš Fâ®ú:÷^¤!÷î‰Û36¼@Þ^DÛ¼–µíj³&~Šç$ÅIžùD†an¢µ'ÞyÉ]Á¾§Σ{…b4L ãù’)‡’9ð,€—ǹ"”!¦ßÿœ-BeœbýÓêEh8Ä»¬˜%ÉÆÇ:Èa aÉæ<ÈKréP­Æä`žµ^ÓqA2¥K»G^±niD#3êuB é0aíÙ·š~¼ðã‘’üŒÍeãF ª=hQʶi'Uƒ´ÿQÍódÙ”08††É `ڻÌ•ú¢õZDbʯhJŒÞ÷E:ϱ·åÆ4 c£ýÂȬDÑ}€´«ï'ÏéFɨ«­œp¨Ê¡6$*åc^sà¹^Y?Ä[ÉT¶)æW™¨OÊ…K=Æâ*‰ÉD4ùr¯Õ E*|¦Ü\ôi…Ëó@”ýb5Ù9§YVI='>uSRÖS˜N¥ÔJÜô{tçqÉûÔç¥ú@ÁulXkæ °/ÑÛ´Ò$èÊF SÄ„wABs¾µ&Ùñ‰«H“§GÞÁ÷¼ÌáØUÝŽö„Î ¹¸Eï’dùoúÍÁjèä_ó¹=š¿t˹U§íz”0“e¨Oý¥õCø7¿ò‹\JáPB»<$mÒ=½?-Å2ʈŒ'áÚµA¾þ¨¦|=BüÓ53óNyuñÚʨ!Ùé[xõ @ŸÉzLÝ^Óñåû".I^‰méÇ÷|’p+^=GCÚz¸Ù(Y/Õ;S5¿ÑºtL•N¹ŽèºÔú¿aëä¦}ÿ“¼¦©š»jqÑÏ>Ÿ§Š^p8ã•…¥w†¡é ¹‡2]u,Cõ¯5¨ _¿¶áîÊž©{{éáLã¬_ëý¨vø ö6Œ§=gIgGVjí4€)–Ûó—]nqÓ–(Àॵ݆OÉùÎ/ÑÛq{Ư…:Äû_&~xëÚ½[WÌ `„›è×+¤ü,üÒžþ&[úŧ‚]ïŠq2Ë-û‡Ìm”9üŒåhô›µa›í.Ož‰Õ©6vÚY˜ŒµÁßa9clFÐßYÐ8†º¨ÁÉ)œegN”>…=9ŽmvYŠX6À)ž¼®™ZžöçQ)³mì¦ßG;Æ ¿Ø*+yá66Â}› >ç¬jö„íÆŸ`ÿ%C'…Þ#dQ8I…?ƒÅ ^ñµIõH¼60ðž•~+‡²¬‚¥÷}xR'Ò ñ (M Ïë-t¤¨ê½Íâc“¼<ä±Ñàd–Lq§lú*s> endobj 2 0 obj << /Type /ObjStm /N 21 /First 150 /Length 1116 /Filter /FlateDecode >> stream xÚíVÝOã8ï_1 ÄN,­VJ¹p Ú[`!˜6"mzIº ÷×ߨ mZ@·Õíã=Äϧãñh80 9hà‚C\3A0\‚ˆ‰A;#+ÐÒ8SxLú*î Ò 5A¬ˆ!p’:±¤dà8JB BE䋈'Sr-Ó… ¦¦¡é‰ˆþÚô>}£°·’Ny 8Èê;øü™Ä=½Ì-àE2¶=<,fµÕ(§×ÃK[‹2µ!ñŒ3û%Å3Ü2bh q×#ó’ìÜqœZëyïúæbˆ˜ ˜†Ù"Ïï>P ½ "B»¦7 Ã4 ,Ç-Ê”iI»´4tìòæH²Å‹²H‡¶†[‚ÙŽìs Þí­bìŽVJßÿß/ÿ(³" …¨ô‰ cèÿ´:/¯_¤¹ãkAÞ›µáD2m¤Û³( ½0¢’ÒZí^^¤ã@z-©$ñ“Þ’¤œ“fl¼•|õ×X¶¾£U…KßN‹>Θ^n”‰×¯S«sJ厰¤„1AWî- <7231DE762177C6D39C30F009C718761A>] /Length 88 /Filter /FlateDecode >> stream xÚÊ·€@CQéï]|íP 0t@LÐ1  Þ~ àspàõè:JD´¶xi¥‘Njé%–DRÉèƒýç «µà|XK.¯µ’AF™xnà½ã¾;ç endstream endobj startxref 42890 %%EOF S4Vectors/inst/include/0000755000175100017510000000000012607264537016042 5ustar00biocbuildbiocbuildS4Vectors/inst/include/S4Vectors_defines.h0000644000175100017510000000522712607264536021551 0ustar00biocbuildbiocbuild/***************************************************************************** S4Vectors C interface: typedefs and defines ------------------------------------------- The S4Vectors C interface is split in 2 files: 1. S4Vectors_defines.h (this file): contains the typedefs and defines of the interface. 2. S4Vectors_interface.h (in this directory): contains the prototypes of the S4Vectors C routines that are part of the interface. Please consult S4Vectors_interface.h for how to use this interface in your package. *****************************************************************************/ #ifndef S4VECTORS_DEFINES_H #define S4VECTORS_DEFINES_H #include #include /* Hash table -- modified from R_HOME/src/main/unique.c */ struct htab { int K, M; unsigned int Mminus1; int *buckets; }; /* * Auto-Extending buffers used for temporary storage of incoming data whose * size is not known in advance: * * o IntAE: Auto-Extending buffer of ints; * o IntAEAE: Auto-Extending buffer of Auto-Extending buffers of ints; * o IntPairAE: Auto-Extending buffer of pairs of ints; * o IntPairAEAE: Auto-Extending buffer of Auto-Extending buffers of pairs * of ints; * o LLongAE: Auto-Extending buffer of long long ints; * o CharAE: Auto-Extending buffer of chars; * o CharAEAE: Auto-Extending buffer of Auto-Extending buffers of chars. * * Some differences between AE buffers and SEXP: (a) AE buffers auto-extend * i.e. they automatically reallocate when more room is needed to add a new * element, (b) they are faster, and (c) they don't require any * PROTECT/UNPROTECT mechanism. */ typedef struct int_ae { int _buflength; int _nelt; int *elts; } IntAE; typedef struct int_aeae { int _buflength; int _nelt; IntAE **elts; } IntAEAE; typedef struct intpair_ae { IntAE *a; IntAE *b; } IntPairAE; typedef struct intpair_aeae { int _buflength; int _nelt; IntPairAE **elts; } IntPairAEAE; typedef struct longlong_ae { int _buflength; int _nelt; long long *elts; } LLongAE; typedef struct char_ae { int _buflength; int _nelt; char *elts; } CharAE; typedef struct char_aeae { int _buflength; int _nelt; CharAE **elts; } CharAEAE; /* * Holder structs. */ typedef struct chars_holder { const char *ptr; int length; } Chars_holder; typedef struct ints_holder { const int *ptr; int length; } Ints_holder; typedef struct doubles_holder { const double *ptr; int length; } Doubles_holder; /* * Hit selection modes. */ #define ALL_HITS 1 #define FIRST_HIT 2 #define LAST_HIT 3 #define ARBITRARY_HIT 4 #define COUNT_HITS 5 #endif S4Vectors/inst/include/S4Vectors_interface.h0000644000175100017510000001574212607264536022077 0ustar00biocbuildbiocbuild/***************************************************************************** S4Vectors C interface: prototypes --------------------------------- The S4Vectors C interface is split in 2 files: 1. S4Vectors_defines.h (in this directory): contains the typedefs and defines of the interface. 2. S4Vectors_interface.h (this file): contains the prototypes of the S4Vectors C routines that are part of the interface. *****************************************************************************/ #include "S4Vectors_defines.h" /* * Safe signed integer arithmetic. * (see safe_arithm.c) */ void reset_ovflow_flag(); int get_ovflow_flag(); int safe_int_add( int x, int y ); int safe_int_mult( int x, int y ); /* * Low-level sorting utilities. * (see sort_utils.c) */ void sort_int_array( int *x, int nelt, int desc ); void get_order_of_int_array( const int *x, int nelt, int desc, int *out, int out_shift ); void get_order_of_int_pairs( const int *a, const int *b, int nelt, int desc, int *out, int out_shift ); void get_matches_of_ordered_int_pairs( const int *a1, const int *b1, const int *o1, int nelt1, const int *a2, const int *b2, const int *o2, int nelt2, int nomatch, int *out, int out_shift ); void get_order_of_int_quads( const int *a, const int *b, const int *c, const int *d, int nelt, int desc, int *out, int out_shift ); void get_matches_of_ordered_int_quads( const int *a1, const int *b1, const int *c1, const int *d1, const int *o1, int nelt1, const int *a2, const int *b2, const int *c2, const int *d2, const int *o2, int nelt2, int nomatch, int *out, int out_shift ); /* * Hash table management. * (see hash_utils.c) */ struct htab new_htab(int n); int get_hbucket_val( const struct htab *htab, int bucket_idx ); void set_hbucket_val( struct htab *htab, int bucket_idx, int val ); /* * Low-level manipulation of the Auto-Extending buffers. * (see AEbufs.c) */ int get_new_buflength(int buflength); int IntAE_get_nelt(const IntAE *ae); int IntAE_set_nelt( IntAE *ae, int nelt ); void IntAE_set_val( const IntAE *ae, int val ); void IntAE_insert_at( IntAE *ae, int at, int val ); IntAE *new_IntAE( int buflength, int nelt, int val ); void IntAE_append( IntAE *ae, const int *newvals, int nnewval ); void IntAE_delete_at( IntAE *ae, int at ); void IntAE_shift( const IntAE *ae, int shift ); void IntAE_sum_and_shift( const IntAE *ae1, const IntAE *ae2, int shift ); void IntAE_append_shifted_vals( IntAE *ae, const int *newvals, int nnewval, int shift ); void IntAE_qsort( const IntAE *ae, int desc ); void IntAE_delete_adjdups(IntAE *ae); SEXP new_INTEGER_from_IntAE(const IntAE *ae); IntAE *new_IntAE_from_INTEGER(SEXP x); IntAE *new_IntAE_from_CHARACTER( SEXP x, int keyshift ); int IntAEAE_get_nelt(const IntAEAE *aeae); int IntAEAE_set_nelt( IntAEAE *aeae, int nelt ); void IntAEAE_insert_at( IntAEAE *aeae, int at, IntAE *ae ); IntAEAE *new_IntAEAE( int buflength, int nelt ); void IntAEAE_eltwise_append( const IntAEAE *aeae1, const IntAEAE *aeae2 ); void IntAEAE_shift( const IntAEAE *aeae, int shift ); void IntAEAE_sum_and_shift( const IntAEAE *aeae1, const IntAEAE *aeae2, int shift ); SEXP new_LIST_from_IntAEAE( const IntAEAE *aeae, int mode ); IntAEAE *new_IntAEAE_from_LIST(SEXP x); SEXP IntAEAE_toEnvir( const IntAEAE *aeae, SEXP envir, int keyshift ); int IntPairAE_get_nelt(const IntPairAE *ae); int IntPairAE_set_nelt( IntPairAE *ae, int nelt ); void IntPairAE_insert_at( IntPairAE *ae, int at, int a, int b ); IntPairAE *new_IntPairAE( int buflength, int nelt ); int IntPairAEAE_get_nelt(const IntPairAEAE *aeae); int IntPairAEAE_set_nelt( IntPairAEAE *aeae, int nelt ); void IntPairAEAE_insert_at( IntPairAEAE *aeae, int at, IntPairAE *ae ); IntPairAEAE *new_IntPairAEAE( int buflength, int nelt ); int LLongAE_get_nelt(const LLongAE *ae); int LLongAE_set_nelt( LLongAE *ae, int nelt ); void LLongAE_set_val( const LLongAE *ae, long long val ); void LLongAE_insert_at( LLongAE *ae, int at, long long val ); LLongAE *new_LLongAE( int buflength, int nelt, long long val ); int CharAE_get_nelt(const CharAE *ae); int CharAE_set_nelt( CharAE *ae, int nelt ); void CharAE_insert_at( CharAE *ae, int at, char c ); CharAE *new_CharAE(int buflength); CharAE *new_CharAE_from_string(const char *string); void append_string_to_CharAE( CharAE *ae, const char *string ); void CharAE_delete_at( CharAE *ae, int at, int nelt ); SEXP new_RAW_from_CharAE(const CharAE *ae); SEXP new_LOGICAL_from_CharAE(const CharAE *ae); int CharAEAE_get_nelt(const CharAEAE *aeae); int CharAEAE_set_nelt( CharAEAE *aeae, int nelt ); void CharAEAE_insert_at( CharAEAE *aeae, int at, CharAE *ae ); CharAEAE *new_CharAEAE( int buflength, int nelt ); void append_string_to_CharAEAE( CharAEAE *aeae, const char *string ); SEXP new_CHARACTER_from_CharAEAE(const CharAEAE *aeae); /* * SEXP_utils.c */ const char *get_classname(SEXP x); /* * vector_utils.c */ int vector_memcmp( SEXP x1, int x1_offset, SEXP x2, int x2_offset, int nelt ); void vector_memcpy( SEXP out, int out_offset, SEXP in, int in_offset, int nelt ); SEXP list_as_data_frame( SEXP x, int nrow ); /* * int_utils.c */ int sum_non_neg_ints( const int *x, int x_len, const char *varname ); int check_integer_pairs( SEXP a, SEXP b, const int **a_p, const int **b_p, const char *a_argname, const char *b_argname ); SEXP find_interv_and_start_from_width( const int *x, int x_len, const int *width, int width_len ); /* * Low-level manipulation of Hits objects. * (see Hits_class.c) */ SEXP new_Hits( int *q_hits, const int *s_hits, int nhit, int q_len, int s_len, int already_sorted ); int get_select_mode(SEXP select); /* * Low-level manipulation of Rle objects. * (see Rle_class.c) */ SEXP logical_Rle_constructor( const int *values, int nvalues, const int *lengths, int buflength ); SEXP integer_Rle_constructor( const int *values, int nvalues, const int *lengths, int buflength ); SEXP numeric_Rle_constructor( const double *values, int nvalues, const int *lengths, int buflength ); SEXP complex_Rle_constructor( const Rcomplex *values, int nvalues, const int *lengths, int buflength ); SEXP character_Rle_constructor( SEXP values, const int *lengths, int buflength ); SEXP raw_Rle_constructor( const Rbyte *values, int nvalues, const int *lengths, int buflength ); SEXP seqselect_Rle(SEXP x, const int *start, const int *width, int length ); /* * Low-level manipulation of Vector objects. * (see List_class.c) */ const char *get_List_elementType(SEXP x); void set_List_elementType(SEXP x, const char *type); /* * Low-level manipulation of SimpleList objects. * (see SimpleList_class.c) */ SEXP new_SimpleList(const char *classname, SEXP listData); /* * Low-level manipulation of DataFrame objects. * (see DataFrame_class.c) */ SEXP new_DataFrame(const char *classname, SEXP vars, SEXP rownames, SEXP nrows); S4Vectors/inst/include/_S4Vectors_stubs.c0000644000175100017510000003130412607264537021422 0ustar00biocbuildbiocbuild#include "S4Vectors_interface.h" #define DEFINE_CCALLABLE_STUB(retT, stubname, Targs, args) \ typedef retT(*__ ## stubname ## _funtype__)Targs; \ retT stubname Targs \ { \ static __ ## stubname ## _funtype__ fun = NULL; \ if (fun == NULL) \ fun = (__ ## stubname ## _funtype__) R_GetCCallable("S4Vectors", "_" #stubname); \ return fun args; \ } /* * Using the above macro when retT (the returned type) is void will make Sun * Studio 12 C compiler unhappy. So we need to use the following macro to * handle that case. */ #define DEFINE_NOVALUE_CCALLABLE_STUB(stubname, Targs, args) \ typedef void(*__ ## stubname ## _funtype__)Targs; \ void stubname Targs \ { \ static __ ## stubname ## _funtype__ fun = NULL; \ if (fun == NULL) \ fun = (__ ## stubname ## _funtype__) R_GetCCallable("S4Vectors", "_" #stubname); \ fun args; \ return; \ } /* * Stubs for callables defined in safe_arithm.c */ DEFINE_NOVALUE_CCALLABLE_STUB(reset_ovflow_flag, (), () ) DEFINE_CCALLABLE_STUB(int, get_ovflow_flag, (), () ) DEFINE_CCALLABLE_STUB(int, safe_int_add, (int x, int y), ( x, y) ) DEFINE_CCALLABLE_STUB(int, safe_int_mult, (int x, int y), ( x, y) ) /* * Stubs for callables defined in sort_utils.c */ DEFINE_NOVALUE_CCALLABLE_STUB(sort_int_array, (int *x, int nelt, int desc), ( x, nelt, desc) ) DEFINE_NOVALUE_CCALLABLE_STUB(get_order_of_int_array, (const int *x, int nelt, int desc, int *out, int out_shift), ( x, nelt, desc, out, out_shift) ) DEFINE_NOVALUE_CCALLABLE_STUB(get_order_of_int_pairs, (const int *a, const int *b, int nelt, int desc, int *out, int out_shift), ( a, b, nelt, desc, out, out_shift) ) DEFINE_NOVALUE_CCALLABLE_STUB(get_matches_of_ordered_int_pairs, (const int *a1, const int *b1, const int *o1, int nelt1, const int *a2, const int *b2, const int *o2, int nelt2, int nomatch, int *out, int out_shift), ( a1, b1, o1, nelt1, a2, b2, o2, nelt2, nomatch, out, out_shift) ) DEFINE_NOVALUE_CCALLABLE_STUB(get_order_of_int_quads, (const int *a, const int *b, const int *c, const int *d, int nelt, int desc, int *out, int out_shift), ( a, b, c, d, nelt, desc, out, out_shift) ) DEFINE_NOVALUE_CCALLABLE_STUB(get_matches_of_ordered_int_quads, (const int *a1, const int *b1, const int *c1, const int *d1, const int *o1, int nelt1, const int *a2, const int *b2, const int *c2, const int *d2, const int *o2, int nelt2, int nomatch, int *out, int out_shift), ( a1, b1, c1, d1, o1, nelt1, a2, b2, c2, d2, o2, nelt2, nomatch, out, out_shift) ) /* * Stubs for callables defined in hash_utils.c */ DEFINE_CCALLABLE_STUB(struct htab, new_htab, (int n), ( n) ) DEFINE_CCALLABLE_STUB(int, get_hbucket_val, (const struct htab *htab, int bucket_idx), ( htab, bucket_idx) ) DEFINE_NOVALUE_CCALLABLE_STUB(set_hbucket_val, (struct htab *htab, int bucket_idx, int val), ( htab, bucket_idx, val) ) /* * Stubs for callables defined in AEbufs.c */ DEFINE_CCALLABLE_STUB(int, get_new_buflength, (int buflength), ( buflength) ) DEFINE_CCALLABLE_STUB(int, IntAE_get_nelt, (const IntAE *ae), ( ae) ) DEFINE_CCALLABLE_STUB(int, IntAE_set_nelt, (IntAE *ae, int nelt), ( ae, nelt) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAE_set_val, (const IntAE *ae, int val), ( ae, val) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAE_insert_at, (IntAE *ae, int at, int val), ( ae, at, val) ) DEFINE_CCALLABLE_STUB(IntAE *, new_IntAE, (int buflength, int nelt, int val), ( buflength, nelt, val) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAE_append, (IntAE *ae, const int *newvals, int nnewval), ( ae, newvals, nnewval) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAE_delete_at, (IntAE *ae, int at), ( ae, at) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAE_shift, (const IntAE *ae, int shift), ( ae, shift) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAE_sum_and_shift, (const IntAE *ae1, const IntAE *ae2, int shift), ( ae1, ae2, shift) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAE_append_shifted_vals, (IntAE *ae, const int *newvals, int nnewval, int shift), ( ae, newvals, nnewval, shift) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAE_qsort, (const IntAE *ae, int desc), ( ae, desc) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAE_delete_adjdups, (IntAE *ae), ( ae) ) DEFINE_CCALLABLE_STUB(SEXP, new_INTEGER_from_IntAE, (const IntAE *ae), ( ae) ) DEFINE_CCALLABLE_STUB(IntAE *, new_IntAE_from_INTEGER, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(IntAE *, new_IntAE_from_CHARACTER, (SEXP x, int keyshift), ( x, keyshift) ) DEFINE_CCALLABLE_STUB(int, IntAEAE_get_nelt, (const IntAEAE *aeae), ( aeae) ) DEFINE_CCALLABLE_STUB(int, IntAEAE_set_nelt, (IntAEAE *aeae, int nelt), ( aeae, nelt) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAEAE_insert_at, (IntAEAE *aeae, int at, IntAE *ae), ( aeae, at, ae) ) DEFINE_CCALLABLE_STUB(IntAEAE *, new_IntAEAE, (int buflength, int nelt), ( buflength, nelt) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAEAE_eltwise_append, (const IntAEAE *aeae1, const IntAEAE *aeae2), ( aeae1, aeae2) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAEAE_shift, (const IntAEAE *aeae, int shift), ( aeae, shift) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntAEAE_sum_and_shift, (const IntAEAE *aeae1, const IntAEAE *aeae2, int shift), ( aeae1, aeae2, shift) ) DEFINE_CCALLABLE_STUB(SEXP, new_LIST_from_IntAEAE, (const IntAEAE *aeae, int mode), ( aeae, mode) ) DEFINE_CCALLABLE_STUB(IntAEAE *, new_IntAEAE_from_LIST, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(SEXP, IntAEAE_toEnvir, (const IntAEAE *aeae, SEXP envir, int keyshift), ( aeae, envir, keyshift) ) DEFINE_CCALLABLE_STUB(int, IntPairAE_get_nelt, (const IntPairAE *ae), ( ae) ) DEFINE_CCALLABLE_STUB(int, IntPairAE_set_nelt, (IntPairAE *ae, int nelt), ( ae, nelt) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntPairAE_insert_at, (IntPairAE *ae, int at, int a, int b), ( ae, at, a, b) ) DEFINE_CCALLABLE_STUB(IntPairAE *, new_IntPairAE, (int buflength, int nelt), ( buflength, nelt) ) DEFINE_CCALLABLE_STUB(int, IntPairAEAE_get_nelt, (const IntPairAEAE *aeae), ( aeae) ) DEFINE_CCALLABLE_STUB(int, IntPairAEAE_set_nelt, (IntPairAEAE *aeae, int nelt), ( aeae, nelt) ) DEFINE_NOVALUE_CCALLABLE_STUB(IntPairAEAE_insert_at, (IntPairAEAE *aeae, int at, IntPairAE *ae), ( aeae, at, ae) ) DEFINE_CCALLABLE_STUB(IntPairAEAE *, new_IntPairAEAE, (int buflength, int nelt), ( buflength, nelt) ) DEFINE_CCALLABLE_STUB(int, LLongAE_get_nelt, (const LLongAE *ae), ( ae) ) DEFINE_CCALLABLE_STUB(int, LLongAE_set_nelt, (LLongAE *ae, int nelt), ( ae, nelt) ) DEFINE_NOVALUE_CCALLABLE_STUB(LLongAE_set_val, (const LLongAE *ae, long long val), ( ae, val) ) DEFINE_NOVALUE_CCALLABLE_STUB(LLongAE_insert_at, (LLongAE *ae, int at, long long val), ( ae, at, val) ) DEFINE_CCALLABLE_STUB(LLongAE *, new_LLongAE, (int buflength, int nelt, long long val), ( buflength, nelt, val) ) DEFINE_CCALLABLE_STUB(int, CharAE_get_nelt, (const CharAE *ae), ( ae) ) DEFINE_CCALLABLE_STUB(int, CharAE_set_nelt, (CharAE *ae, int nelt), ( ae, nelt) ) DEFINE_NOVALUE_CCALLABLE_STUB(CharAE_insert_at, (CharAE *ae, int at, char c), ( ae, at, c) ) DEFINE_CCALLABLE_STUB(CharAE *, new_CharAE, (int buflength), ( buflength) ) DEFINE_CCALLABLE_STUB(CharAE *, new_CharAE_from_string, (const char *string), ( string) ) DEFINE_NOVALUE_CCALLABLE_STUB(append_string_to_CharAE, (CharAE *ae, const char *string), ( ae, string) ) DEFINE_NOVALUE_CCALLABLE_STUB(CharAE_delete_at, (CharAE *ae, int at, int nelt), ( ae, at, nelt) ) DEFINE_CCALLABLE_STUB(SEXP, new_RAW_from_CharAE, (const CharAE *ae), ( ae) ) DEFINE_CCALLABLE_STUB(SEXP, new_LOGICAL_from_CharAE, (const CharAE *ae), ( ae) ) DEFINE_CCALLABLE_STUB(int, CharAEAE_get_nelt, (const CharAEAE *aeae), ( aeae) ) DEFINE_CCALLABLE_STUB(int, CharAEAE_set_nelt, (CharAEAE *aeae, int nelt), ( aeae, nelt) ) DEFINE_NOVALUE_CCALLABLE_STUB(CharAEAE_insert_at, (CharAEAE *aeae, int at, CharAE *ae), ( aeae, at, ae) ) DEFINE_CCALLABLE_STUB(CharAEAE *, new_CharAEAE, (int buflength, int nelt), ( buflength, nelt) ) DEFINE_NOVALUE_CCALLABLE_STUB(append_string_to_CharAEAE, (CharAEAE *aeae, const char *string), ( aeae, string) ) DEFINE_CCALLABLE_STUB(SEXP, new_CHARACTER_from_CharAEAE, (const CharAEAE *aeae), ( aeae) ) /* * Stubs for callables defined in SEXP_utils.c */ DEFINE_CCALLABLE_STUB(const char *, get_classname, (SEXP x), ( x) ) /* * Stubs for callables defined in vector_utils.c */ DEFINE_CCALLABLE_STUB(int, vector_memcmp, (SEXP x1, int x1_offset, SEXP x2, int x2_offset, int nelt), ( x1, x1_offset, x2, x2_offset, nelt) ) DEFINE_NOVALUE_CCALLABLE_STUB(vector_memcpy, (SEXP out, int out_offset, SEXP in, int in_offset, int nelt), ( out, out_offset, in, in_offset, nelt) ) DEFINE_CCALLABLE_STUB(SEXP, list_as_data_frame, (SEXP x, int nrow), ( x, nrow) ) /* * Stubs for callables defined in int_utils.c */ DEFINE_CCALLABLE_STUB(int, sum_non_neg_ints, (const int *x, int x_len, const char *varname), ( x, x_len, varname) ) DEFINE_CCALLABLE_STUB(int, check_integer_pairs, (SEXP a, SEXP b, const int **a_p, const int **b_p, const char *a_argname, const char *b_argname), ( a, b, a_p, b_p, a_argname, b_argname) ) DEFINE_CCALLABLE_STUB(SEXP, find_interv_and_start_from_width, (const int *x, int x_len, const int *width, int width_len), ( x, x_len, width, width_len) ) /* * Stubs for callables defined in Hits_class.c */ DEFINE_CCALLABLE_STUB(SEXP, new_Hits, (int *q_hits, const int *s_hits, int nhit, int q_len, int s_len, int already_sorted), ( q_hits, s_hits, nhit, q_len, s_len, already_sorted) ) DEFINE_CCALLABLE_STUB(int, get_select_mode, (SEXP select), ( select) ) /* * Stubs for callables defined in Rle_class.c */ DEFINE_CCALLABLE_STUB(SEXP, logical_Rle_constructor, (const int *values, int nvalues, const int *lengths, int buflength), ( values, nvalues, lengths, buflength) ) DEFINE_CCALLABLE_STUB(SEXP, integer_Rle_constructor, (const int *values, int nvalues, const int *lengths, int buflength), ( values, nvalues, lengths, buflength) ) DEFINE_CCALLABLE_STUB(SEXP, numeric_Rle_constructor, (const double *values, int nvalues, const int *lengths, int buflength), ( values, nvalues, lengths, buflength) ) DEFINE_CCALLABLE_STUB(SEXP, complex_Rle_constructor, (const Rcomplex *values, int nvalues, const int *lengths, int buflength), ( values, nvalues, lengths, buflength) ) DEFINE_CCALLABLE_STUB(SEXP, character_Rle_constructor, (SEXP values, const int *lengths, int buflength), ( values, lengths, buflength) ) DEFINE_CCALLABLE_STUB(SEXP, raw_Rle_constructor, (const Rbyte *values, int nvalues, const int *lengths, int buflength), ( values, nvalues, lengths, buflength) ) DEFINE_CCALLABLE_STUB(SEXP, seqselect_Rle, (SEXP x, const int *start, const int *width, int length), ( x, start, width, length) ) /* * Stubs for callables defined in List_class.c */ DEFINE_CCALLABLE_STUB(const char *, get_List_elementType, (SEXP x), ( x) ) DEFINE_NOVALUE_CCALLABLE_STUB(set_List_elementType, (SEXP x, const char *type), ( x, type) ) /* * Stubs for callables defined in SimpleList_class.c */ DEFINE_CCALLABLE_STUB(SEXP, new_SimpleList, (const char *classname, SEXP listData), ( classname, listData) ) /* * Stubs for callables defined in DataFrame_class.c */ DEFINE_CCALLABLE_STUB(SEXP, new_DataFrame, (const char *classname, SEXP vars, SEXP rownames, SEXP nrows), ( classname, vars, rownames, nrows) ) S4Vectors/inst/unitTests/0000755000175100017510000000000012607264537016421 5ustar00biocbuildbiocbuildS4Vectors/inst/unitTests/test_DataFrame-class.R0000644000175100017510000003527712607264536022547 0ustar00biocbuildbiocbuildtest_DataFrame_construction <- function() { score <- c(X=1L, Y=3L, Z=NA) counts <- c(10L, 2L, NA) ## na in rn checkException(DataFrame(score, row.names = c("a", NA, "b")), silent = TRUE) ## invalid rn length checkException(DataFrame(score, row.names = "a"), silent = TRUE) ## dups in rn checkException(DataFrame(score, row.names = c("a", "b", "a")), silent = TRUE) DF <- DataFrame() # no args checkTrue(validObject(DF)) row.names <- c("one", "two", "three") DF <- DataFrame(row.names = row.names) # no args, but row.names checkTrue(validObject(DF)) checkIdentical(rownames(DF), row.names) DF <- DataFrame(score) # single, unnamed arg checkTrue(validObject(DF)) checkIdentical(DF[["score"]], score) DF <- DataFrame(score, row.names = row.names) #with row names checkTrue(validObject(DF)) checkIdentical(rownames(DF), row.names) DF <- DataFrame(vals = score) # named vector arg checkTrue(validObject(DF)) checkIdentical(DF[["vals"]], score) DF <- DataFrame(counts, vals = score) # mixed named and unnamed checkTrue(validObject(DF)) checkIdentical(DF[["vals"]], score) checkIdentical(DF[["counts"]], counts) DF <- DataFrame(score + score) # unnamed arg with invalid name expression checkTrue(validObject(DF)) checkIdentical(DF[["score...score"]], score + score) mat <- cbind(score) DF <- DataFrame(mat) # single column matrix with column name checkTrue(validObject(DF)) checkIdentical(DF[["score"]], unname(score)) mat <- cbind(score, counts) DF <- DataFrame(mat) # two column matrix with col names checkTrue(validObject(DF)) checkIdentical(DF[["score"]], unname(score)) checkIdentical(DF[["counts"]], counts) colnames(mat) <- NULL DF <- DataFrame(mat) # two column matrix without col names checkTrue(validObject(DF)) checkIdentical(DF[["V1"]], unname(score)) sw <- DataFrame(swiss, row.names = rownames(swiss)) # a data.frame checkIdentical(as.data.frame(sw), swiss) rownames(swiss) <- NULL # strip row names to make them comparable sw <- DataFrame(swiss) # a data.frame checkIdentical(as.data.frame(sw), swiss) sw <- DataFrame(swiss[1:3,], score = unname(score)) checkIdentical(as.data.frame(sw), data.frame(swiss[1:3,], score)) sw <- DataFrame(score = score, swiss = swiss[1:3,]) # named data.frame/matrix checkIdentical(as.data.frame(sw), data.frame(score = score, swiss = swiss[1:3,])) ## identity df <- DataFrame(A=I(list(1:3))) checkIdentical(as.data.frame(df), data.frame(A=I(list(1:3)))) ## recycling DF <- DataFrame(1, score) checkIdentical(DF[[1]], rep(1, 3)) checkIdentical(DF[[2]], score) } test_DataFrame_coerce <- function() { ## need to introduce character() dim names checkTrue(validObject(as(matrix(0L, 0L, 0L), "DataFrame"))) score <- c(X=1L, Y=3L, Z=NA) DF <- as(score, "DataFrame") checkTrue(validObject(DF)) checkIdentical(DF[[1]], score) } test_DataFrame_subset <- function() { data(swiss) sw <- DataFrame(swiss) rn <- rownames(swiss) checkException(sw[list()], silent = TRUE) # non-atomic checkException(sw[NA], silent = TRUE) # column indices cannot be NA checkException(sw[100], silent = TRUE) # out of bounds col checkException(sw[,100], silent = TRUE) checkException(sw[1000,], silent = TRUE) # out of bounds row oldOpts <- options(warn=2) checkException(sw[1:3, drop=TRUE], silent = TRUE) # drop ignored checkException(sw[drop=TRUE], silent = TRUE) checkException(sw[foo = "bar"], silent = TRUE) # invalid argument options(oldOpts) checkException(sw[,"Fert"], silent = TRUE) # bad column name sw <- DataFrame(swiss) checkIdentical(sw[], sw) # identity subset checkIdentical(sw[,], sw) checkIdentical(sw[NULL], DataFrame(swiss[NULL])) # NULL subsetting checkIdentical(sw[,NULL], DataFrame(swiss[,NULL])) checkIdentical(as.data.frame(sw[NULL,]), structure(data.frame(swiss[NULL,]), row.names = character())) rownames(sw) <- rn ## select columns checkIdentical(as.data.frame(sw[1:3]), swiss[1:3]) checkIdentical(as.data.frame(sw[, 1:3]), swiss[1:3]) ## select rows checkIdentical(as.data.frame(sw[1:3,]), swiss[1:3,]) checkIdentical(as.data.frame(sw[1:3,]), swiss[1:3,]) checkIdentical(as.data.frame(sw[sw[["Education"]] == 7,]), swiss[swiss[["Education"]] == 7,]) checkIdentical(as.data.frame(sw[Rle(sw[["Education"]] == 7),]), swiss[swiss[["Education"]] == 7,]) ## select rows and columns checkIdentical(as.data.frame(sw[4:5, 1:3]), swiss[4:5,1:3]) checkIdentical(as.data.frame(sw[1]), swiss[1]) # a one-column data frame checkIdentical(sw[,"Fertility"], swiss[,"Fertility"]) ## the same checkIdentical(as.data.frame(sw[, 1, drop = FALSE]), swiss[, 1, drop = FALSE]) checkIdentical(sw[, 1], swiss[,1]) # a (unnamed) vector checkIdentical(sw[[1]], swiss[[1]]) # the same checkIdentical(sw[["Fertility"]], swiss[["Fertility"]]) checkIdentical(sw[["Fert"]], swiss[["Fert"]]) # should return 'NULL' checkIdentical(sw[,c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE)], swiss[,c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE)]) checkIdentical(as.data.frame(sw[1,]), swiss[1,]) # a one-row data frame checkIdentical(sw[1,, drop=TRUE], swiss[1,, drop=TRUE]) # a list ## duplicate row, unique row names are created checkIdentical(as.data.frame(sw[c(1, 1:2),]), swiss[c(1,1:2),]) ## NOTE: NA subsetting not yet supported for XVectors ##checkIdentical(as.data.frame(sw[c(1, NA, 1:2, NA),]), # mixin some NAs ## swiss[c(1, NA, 1:2, NA),]) checkIdentical(as.data.frame(sw["Courtelary",]), swiss["Courtelary",]) subswiss <- swiss[1:5,1:4] subsw <- sw[1:5,1:4] checkIdentical(as.data.frame(subsw["C",]), subswiss["C",]) # partially matches ## NOTE: NA subsetting not yet supported for XVectors ##checkIdentical(as.data.frame(subsw["foo",]), # bad row name ## subswiss["foo",]) ##checkIdentical(as.data.frame(sw[match("C", row.names(sw)), ]), ## swiss[match("C", row.names(sw)), ]) # no exact match } test_DataFrame_dimnames_replace <- function() { data(swiss) cn <- paste("X", seq_len(ncol(swiss)), sep = ".") sw <- DataFrame(swiss) colnames(sw) <- cn checkIdentical(colnames(sw), cn) cn <- as.character(seq_len(ncol(swiss))) colnames(sw) <- cn colnames(swiss) <- cn checkIdentical(colnames(sw), colnames(swiss)) colnames(sw) <- cn[1] colnames(swiss) <- cn[1] checkIdentical(colnames(sw), colnames(swiss)) rn <- seq(nrow(sw)) rownames(sw) <- rn checkIdentical(rownames(sw), as.character(rn)) checkException(rownames(sw) <- rn[1], silent = TRUE) checkException(rownames(sw) <- rep(rn[1], nrow(sw)), silent = TRUE) rn[1] <- NA checkException(rownames(sw) <- rn, silent = TRUE) } test_DataFrame_replace <- function() { score <- c(1L, 3L, NA) counts <- c(10L, 2L, NA) DF <- DataFrame(score) # single, unnamed arg DF[["counts"]] <- counts checkIdentical(DF[["counts"]], counts) DF[[3]] <- score checkIdentical(DF[[3]], score) DF[[3]] <- NULL # deletion DF[["counts"]] <- NULL DF$counts <- counts checkIdentical(DF$counts, counts) checkException(DF[[13]] <- counts, silent = TRUE) # index must be < length+1 checkException(DF[["tooshort"]] <- counts[1:2], silent = TRUE) sw <- DataFrame(swiss, row.names = rownames(swiss)) # a data.frame sw1 <- sw; swiss1 <- swiss sw1[] <- 1L; swiss1[] <- 1L checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[] <- 1; swiss1[] <- 1 checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1["Education"] <- 1; swiss1["Education"] <- 1 checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[,"Education"] <- 1; swiss1[,"Education"] <- 1 checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1["Courtelary",] <- 1; swiss1["Courtelary",] <- 1 checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[1:3] <- 1; swiss1[1:3] <- 1 checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[,1:3] <- 1; swiss1[,1:3] <- 1 checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[2:4,1:3] <- 1; swiss1[2:4,1:3] <- 1 checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[2:4,-c(2,4,5)] <- 1; swiss1[2:4,-c(2,4,5)] <- 1 checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[,1:3] <- sw1[,2:4]; swiss1[,1:3] <- swiss1[,2:4] checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[2:4,] <- sw1[1:3,]; swiss1[2:4,] <- swiss1[1:3,] checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[2:4,1:3] <- sw1[1:3,2:4]; swiss1[2:4,1:3] <- swiss1[1:3,2:4] checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1["NewCity",] <- NA; swiss1["NewCity",] <- NA checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[nrow(sw1)+(1:2),] <- NA; swiss1[nrow(swiss1)+(1:2),] <- NA checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1["NewCol"] <- seq(nrow(sw1)); swiss1["NewCol"] <- seq(nrow(sw1)) checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[ncol(sw1)+1L] <- seq(nrow(sw1)); swiss1[ncol(swiss1)+1L] <- seq(nrow(sw1)) checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[,"NewCol"] <- seq(nrow(sw1)); swiss1[,"NewCol"] <- seq(nrow(sw1)) checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1["NewCity","NewCol"] <- 0 swiss1["NewCity","NewCol"] <- 0 checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1["NewCity",] <- DataFrame(NA); swiss1["NewCity",] <- data.frame(NA) checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[nrow(sw1)+(1:2),] <- DataFrame(NA) swiss1[nrow(swiss1)+(1:2),] <- data.frame(NA) checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1["NewCol"] <- DataFrame(seq(nrow(sw1))) swiss1["NewCol"] <- data.frame(seq(nrow(sw1))) checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[ncol(sw1)+1L] <- DataFrame(seq(nrow(sw1))) swiss1[ncol(swiss1)+1L] <- data.frame(seq(nrow(sw1))) checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1[,"NewCol"] <- DataFrame(seq(nrow(sw1))) swiss1[,"NewCol"] <- data.frame(seq(nrow(sw1))) checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw; swiss1 <- swiss sw1["NewCity","NewCol"] <- DataFrame(0) swiss1["NewCity","NewCol"] <- data.frame(0) checkIdentical(as.data.frame(sw1), swiss1) sw1 <- sw mcols(sw1) <- DataFrame(id = seq_len(ncol(sw1))) sw1["NewCol"] <- DataFrame(seq(nrow(sw1))) checkIdentical(mcols(sw1, use.names=TRUE), DataFrame(id = c(seq_len(ncol(sw1)-1), NA), row.names = colnames(sw1))) } ## combining test_DataFrame_combine <- function() { data(swiss) rn <- rownames(swiss) sw <- DataFrame(swiss, row.names=rn) swisssplit <- split(swiss, swiss$Education) ## rbind checkIdentical(rbind(DataFrame(), DataFrame()), DataFrame()) score <- c(X=1L, Y=3L, Z=NA) DF <- DataFrame(score) checkIdentical(rbind(DF, DF)[[1]], c(score, score)) zr <- sw[FALSE,] checkIdentical(rbind(DataFrame(), zr, zr[,1:2]), zr) checkIdentical(as.data.frame(rbind(DataFrame(), zr, sw)), swiss) target <- do.call(rbind, swisssplit) current <- do.call(rbind, lapply(swisssplit, DataFrame)) rownames(target) <- rownames(current) <- NULL checkIdentical(target, as.data.frame(current)) DF <- DataFrame(A=I(list(1:3))) df <- as.data.frame(DF) checkIdentical(as.data.frame(rbind(DF, DF)), rbind(df, df)) ## combining factors df1 <- data.frame(species = c("Mouse", "Chicken"), n = c(5, 6)) DF1 <- DataFrame(df1) df2 <- data.frame(species = c("Human", "Chimp"), n = c(1, 2)) DF2 <- DataFrame(df2) df12 <- rbind(df1, df2) rownames(df12) <- NULL checkIdentical(as.data.frame(rbind(DF1, DF2)), df12) checkIdentical(rownames(rbind(sw, DataFrame(swiss))), rownames(rbind(swiss, swiss))) checkIdentical(rownames(do.call(rbind, lapply(swisssplit, DataFrame))), unlist(lapply(swisssplit, rownames), use.names=FALSE)) checkException(rbind(sw[,1:2], sw), silent = TRUE) other <- sw colnames(other)[1] <- "foo" checkException(rbind(other, sw), silent = TRUE) } test_DataFrame_looping <- function() { data(iris) actual <- by(iris, iris$Species, nrow) ## a bit tricky because of the 'call' attribute attr(actual, "call")[[1]] <- as.name("by") iris <- DataFrame(iris, row.names=rownames(iris)) checkIdentical(actual, by(iris, iris$Species, nrow)) } test_DataFrame_annotation <- function() { df <- DataFrame(x = c(1L, 3L, NA), y = c(10L, 2L, NA)) mcols(df) <- DataFrame(a = 1:2) checkIdentical(mcols(df)[,1], 1:2) checkIdentical(mcols(df[2:1])[,1], 2:1) checkIdentical(mcols(cbind(df,df))[,1], rep(1:2,2)) df$z <- 1:3 checkIdentical(mcols(df, use.names=TRUE), DataFrame(a = c(1L, 2L, NA), row.names = c("x", "y", "z"))) } ## '[<-' setter test_DataFrame_Setter <- function() { .SingleBracket <- function(df0, df1, idx) { target <- df0 for (i in seq_len(length(df0))[idx]) target[[i]] <- df1[[i]] df <- df0 df[idx] <- df1[idx] stopifnot(identical(target, df)) df <- DataFrame(df0) df[idx] <- DataFrame(df1)[idx] if (!identical(DataFrame(target), df)) FALSE else TRUE } df0 <- data.frame(x=11:12, y=21:22, z=31:32) df1 <- data.frame(matrix(LETTERS[1:6], ncol=3)) checkTrue(.SingleBracket(df0, df1, c(FALSE, FALSE, TRUE))) checkTrue(.SingleBracket(df0, df1, c(TRUE, FALSE, TRUE))) checkTrue(.SingleBracket(df0, df1, c(TRUE, TRUE, TRUE))) checkTrue(.SingleBracket(df0, df1, TRUE)) target <- df0 target[] <- df1[] df <- DataFrame(df0) df[] <- DataFrame(df1)[] checkIdentical(DataFrame(target), df) for (i in c('a', 'c', 'e')) { DF <- DataFrame(A=1:5, row.names=letters[1:5]) df <- data.frame(A=1:5, row.names=letters[1:5]) DF[i, 'B'] <- df[i, 'B'] <- 1 checkIdentical(as.data.frame(DF), df) } } test_DataFrame_droplevels <- function() { df <- DataFrame(state.name, state.region, state.region.rle=Rle(state.region)) df2 <- head(df) checkIdentical(lapply(droplevels(df2), levels), list(state.name=NULL, state.region=c("South", "West"), state.region.rle=c("South", "West"))) } test_DataFrame_transform <- function() { DF <- DataFrame(state.name, state.region, state.area) df <- as.data.frame(DF) checkIdentical(transform(DF), DF) TF <- transform(DF, log.area = log(state.area), ratio = log.area / state.area) tf <- transform(transform(df, log.area = log(state.area)), ratio = log.area / state.area) checkIdentical(tf, as.data.frame(TF)) } S4Vectors/inst/unitTests/test_DataTable-class.R0000644000175100017510000000176412607264536022536 0ustar00biocbuildbiocbuildtest_DataTable_basic <- function() { x <- DataFrame(a = 1:10, b = 11:20) y <- as.data.frame(x) checkIdentical(x[,1], y[,1]) checkIdentical(as.data.frame(x[,2:1]), y[,2:1]) # checkIdentical(as.data.frame(cbind(x,x)), cbind(y,y)) checkIdentical(dim(x), dim(y)) checkIdentical(nrow(x), nrow(y)) checkIdentical(ncol(x), ncol(y)) checkIdentical(as.data.frame(head(x)), head(y)) checkIdentical(as.data.frame(rbind(x,x)), rbind(y,y)) # checkIdentical(as.data.frame(tail(x)), tail(y)) } test_DataTable_subset <- function() { y <- airquality rownames(y) <- as.character(seq_len(nrow(y))) x <- as(y, "DataFrame") checkIdentical(as.data.frame(subset(x, Temp > 80, select = c(Ozone, Temp))), subset(y, Temp > 80, select = c(Ozone, Temp))) checkIdentical(as.data.frame(subset(x, Day == 1, select = -Temp)), subset(y, Day == 1, select = -Temp)) checkIdentical(as.data.frame(subset(x, select = Ozone:Wind)), subset(y, select = Ozone:Wind)) } S4Vectors/inst/unitTests/test_FilterRules.R0000644000175100017510000001206212607264536022043 0ustar00biocbuildbiocbuildtest_FilterRules_construct <- function() { ## as a simple character vector filts <- c("peaks", "promoters") parsedFilts <- list(peaks = expression(peaks), promoters = expression(promoters)) filters <- FilterRules() checkTrue(validObject(filters)) checkIdentical(as.list(filters), list()) filters <- FilterRules(filts) checkTrue(validObject(filters)) checkIdentical(as.list(filters), parsedFilts) checkIdentical(active(filters), structure(rep(TRUE, 2), names=filts)) ## with functions and expressions filts <- c(parsedFilts, list(find_eboxes = function(rd) rep(FALSE, nrow(rd)))) filters <- FilterRules(filts, active = FALSE) checkTrue(validObject(filters)) filts$find_eboxes <- new("FilterClosure", filts$find_eboxes) checkIdentical(as.list(filters), filts) checkIdentical(active(filters), structure(rep(FALSE, 3), names=names(filts))) ## direct, quoted args (character literal parsed) filters <- FilterRules(under_peaks = peaks, in_promoters = "promoters") filts <- list(under_peaks = expression(peaks), in_promoters = expression(promoters)) checkTrue(validObject(filters)) checkIdentical(as.list(filters), filts) ## mix them up filters <- FilterRules(filts, diffexp = de) checkTrue(validObject(filters)) checkIdentical(as.list(filters), c(list(diffexp = expression(de)), filts)) filts <- as.list(filters) checkException(FilterRules(c(filts, 1)), silent = TRUE) checkException(FilterRules(filts, active = filts), silent = TRUE) checkException(FilterRules(list(find_eboxes = function() NULL)), silent = TRUE) } test_FilterRules_append <- function() { filts <- c("peaks", "promoters") filts2 <- c("introns", "exons") filters <- FilterRules(filts) filters2 <- FilterRules(filts2, active=FALSE) both <- append(filters, filters2) checkTrue(validObject(both)) bothFilts <- structure(list(quote(peaks), quote(promoters), quote(introns), quote(exons)), names = c(filts, filts2)) checkIdentical(unlist(as.list(both)), bothFilts) bothActive <- structure(c(TRUE, TRUE, FALSE, FALSE), names = names(bothFilts)) checkIdentical(active(both), bothActive) both <- c(filters, filters2) checkTrue(validObject(both)) checkIdentical(unlist(as.list(both)), bothFilts) checkIdentical(active(both), bothActive) filters[["cons"]] <- "cons" filts <- list(peaks = quote(peaks), promoters = quote(promoters)) filts <- c(filts, cons = quote(cons)) checkIdentical(unlist(as.list(filters)), filts) filters[["cons"]] <- quote(cons) checkIdentical(unlist(as.list(filters)), filts) filters[["cons"]] <- expression(cons) checkIdentical(unlist(as.list(filters)), filts) fun <- function(rd) rep(FALSE, nrow(rd)) filters[[4]] <- fun filts <- c(filts, X = new("FilterClosure", fun)) checkIdentical(unlist(as.list(filters)), filts) checkException(filters[[]] <- "threeprime", silent = TRUE) checkException(filters[[1]] <- 2, silent = TRUE) checkException(filters[[1]] <- list(quote(foo), quote(bar)), silent = TRUE) } test_FilterRules_subset <- function() { filts <- c("peaks", "promoters", "introns") filters <- FilterRules(filts) checkIdentical(sapply(unlist(filters[1:2]), deparse), structure(filts[1:2], names = filts[1:2])) checkIdentical(sapply(unlist(filters[]),deparse), structure(filts, names = filts)) checkException(filters[1,2], silent = TRUE) } test_FilterRules_active <- function() { filts <- c("peaks", "promoters", "introns") filters <- FilterRules(filts) ## set the active state directly active(filters) <- FALSE checkIdentical(active(filters), structure(rep(FALSE, 3), names = filts)) active(filters) <- TRUE checkIdentical(active(filters), structure(rep(TRUE, 3), names = filts)) active(filters) <- c(FALSE, FALSE, TRUE) checkIdentical(active(filters), structure(c(FALSE, FALSE, TRUE), names = filts)) active(filters)["promoters"] <- TRUE checkIdentical(active(filters), structure(c(FALSE, TRUE, TRUE), names = filts)) checkException(active(filters) <- rep(FALSE, 2), silent = TRUE) checkException(active(filters) <- rep(FALSE, 5), silent = TRUE) checkException(active(filters)["introns"] <- NA, silent = TRUE) ## toggle the active state by name or index active(filters) <- c(NA, 2) # NA's are dropped checkIdentical(active(filters), structure(c(FALSE, TRUE, FALSE), names = filts)) active(filters) <- c("peaks", NA) checkIdentical(active(filters), structure(c(TRUE, FALSE, FALSE), names = filts)) checkException(active(filters) <- "foo", silent = TRUE) checkException(active(filters) <- 15, silent = TRUE) } test_FilterRules_annotation <- function() { filts <- c("peaks", "promoters") filters <- FilterRules(filts) mcols(filters) <- DataFrame(a = 1:2) checkIdentical(mcols(filters)[,1], 1:2) checkIdentical(mcols(filters[2:1])[,1], 2:1) checkIdentical(mcols(c(filters,filters))[,1], rep(1:2,2)) checkIdentical(mcols(append(filters,filters))[,1], rep(1:2,2)) } S4Vectors/inst/unitTests/test_Hits-class.R0000644000175100017510000001116612607264536021621 0ustar00biocbuildbiocbuildtest_Hits_coercion <- function() { ## sparse q_hits <- c(1L, 1L, 3L) s_hits <- 1:3 hits <- Hits(q_hits, s_hits, 3, 3) checkIdentical(as.matrix(hits), cbind(queryHits=q_hits, subjectHits=s_hits)) checkIdentical(as.table(hits), c(2L, 0L, 1L)) checkIdentical(as.table(t(hits)), c(1L, 1L, 1L)) ## dense q_hits <- rep(1:2, each=2) s_hits <- rep(1:2, 2) hits <- Hits(q_hits, s_hits, 3, 2) checkIdentical(as.matrix(hits), cbind(queryHits=q_hits, subjectHits=s_hits)) checkIdentical(as.table(hits), c(2L, 2L, 0L)) checkIdentical(as.table(t(hits)), c(2L, 2L)) } test_remapHits <- function() { query_hits0 <- c(1L, 1L, 2L, 3L, 3L) subject_hits0 <- c(1L, 2L, 5L, 2L, 4L) hits0 <- Hits(query_hits0, subject_hits0, 3L, 6L) ## No remapping (i.e. map is missing or is the identity function). checkIdentical(remapHits(hits0), hits0) query.map1 <- seq_len(queryLength(hits0)) new.queryLength1 <- queryLength(hits0) subject.map1 <- seq_len(subjectLength(hits0)) new.subjectLength1 <- subjectLength(hits0) hits10 <- remapHits(hits0, query.map=query.map1, new.queryLength=new.queryLength1) checkIdentical(hits10, hits0) hits01 <- remapHits(hits0, subject.map=subject.map1, new.subjectLength=new.subjectLength1) checkIdentical(hits01, hits0) hits11 <- remapHits(hits0, query.map=query.map1, new.queryLength=new.queryLength1, subject.map=subject.map1, new.subjectLength=new.subjectLength1) checkIdentical(hits11, hits0) ## With maps that add a fixed offset to the query hits, and a fixed offset ## to the subject hits. query.map2 <- query.map1 + 20L new.queryLength2 <- new.queryLength1 + 20L subject.map2 <- subject.map1 + 30L new.subjectLength2 <- new.subjectLength1 + 30L hits20 <- remapHits(hits0, query.map=query.map2, new.queryLength=new.queryLength2) expected_hits20 <- Hits(query_hits0 + 20L, subject_hits0, 23, 6) checkIdentical(hits20, expected_hits20) hits02 <- remapHits(hits0, subject.map=subject.map2, new.subjectLength=new.subjectLength2) expected_hits02 <- Hits(query_hits0, subject_hits0 + 30L, 3, 36) checkIdentical(hits02, expected_hits02) hits22 <- remapHits(hits0, query.map=query.map2, new.queryLength=new.queryLength2, subject.map=subject.map2, new.subjectLength=new.subjectLength2) expected_hits22 <- Hits(query_hits0 + 20L, subject_hits0 + 30L, 23, 36) checkIdentical(hits22, expected_hits22) ## With injective and non-ascending maps. query.map3 <- 100L * rev(query.map1) + query.map1 new.queryLength3 <- 400L subject.map3 <- 100L * rev(subject.map1) + subject.map1 new.subjectLength3 <- 700L hits30 <- remapHits(hits0, query.map=query.map3, new.queryLength=new.queryLength3) expected_hits30 <- Hits(c(103, 103, 202, 301, 301), c( 2, 4, 5, 1, 2), 400, 6) checkIdentical(hits30, expected_hits30) hits03 <- remapHits(hits0, subject.map=subject.map3, new.subjectLength=new.subjectLength3) expected_hits03 <- Hits(query_hits0, c(502, 601, 205, 304, 502), 3, 700) checkIdentical(t(hits03), t(expected_hits03)) hits33 <- remapHits(hits0, query.map=query.map3, new.queryLength=new.queryLength3, subject.map=subject.map3, new.subjectLength=new.subjectLength3) expected_hits33 <- Hits(c(103, 103, 202, 301, 301), c(304, 502, 205, 502, 601), 400, 700) checkIdentical(t(hits33), t(expected_hits33)) ## With non-injective maps (as factors). query.map4 <- factor(c("B", "A", "B"), levels=c("A", "B")) subject.map4 <- factor(c("a", "b", "a", "b", "a", "b"), levels=c("a", "b")) hits40 <- remapHits(hits0, query.map=query.map4) expected_hits40 <- Hits(c(1, 2, 2, 2), c(5, 1, 2, 4), 2, 6) checkIdentical(hits40, expected_hits40) hits04 <- remapHits(hits0, subject.map=subject.map4) expected_hits04 <- Hits(c(1, 1, 2, 3), c(1, 2, 1, 2), 3, 2) checkIdentical(hits04, expected_hits04) hits44 <- remapHits(hits0, query.map=query.map4, subject.map=subject.map4) expected_hits44 <- Hits(c(1, 2, 2), c(1, 1, 2), 2, 2) checkIdentical(hits44, expected_hits44) } S4Vectors/inst/unitTests/test_List-class.R0000644000175100017510000002634412607264536021631 0ustar00biocbuildbiocbuild### NOTE: List is an abstract type, so we just test with IntegerList library(IRanges) test_List_replace_names <- function() { int1 <- c(1L,2L,3L,5L,2L,8L) int2 <- c(15L,45L,20L,1L,15L,100L,80L,5L) for (compress in c(TRUE, FALSE)) { collection <- IntegerList(int1, int2, compress=compress) names(collection) <- c("one", "two") checkIdentical(names(collection), c("one", "two")) names(collection) <- NULL checkIdentical(names(collection), NULL) names(collection) <- "one" checkIdentical(names(collection), c("one", NA)) checkException(names(collection) <- c("one", "two", "three"), silent=TRUE) } } test_List_extraction <- function() { int1 <- c(1L,2L,3L,5L,2L,8L) int2 <- c(15L,45L,20L,1L,15L,100L,80L,5L) for (compress in c(TRUE, FALSE)) { collection <- IntegerList(int1, int2, compress=compress) checkException(collection[[]], silent=TRUE) checkException(collection[[1, 2]], silent=TRUE) checkException(collection[[numeric()]], silent=TRUE) checkException(collection[[NULL]], silent=TRUE) checkException(collection[[c(1,2)]], silent=TRUE) checkException(collection[[-1]], silent=TRUE) checkException(collection[[5]], silent=TRUE) checkIdentical(collection[[NA_integer_]], NULL) checkIdentical(collection[[1]], int1) checkIdentical(collection[[2]], int2) checkIdentical(collection[["1"]], NULL) checkIdentical(collection$foo, NULL) checkIdentical(IntegerList(one=int1, int2, compress=compress)[["one"]], int1) checkIdentical(IntegerList(one=int1, int2, compress=compress)$one, int1) } } test_List_subset <- function() { int1 <- c(1L,2L,3L,5L,2L,8L) int2 <- c(15L,45L,20L,1L,15L,100L,80L,5L) for (compress in c(TRUE, FALSE)) { collection <- IntegerList(one=int1, int2, compress=compress) unnamed <- IntegerList(int1, int2, compress=compress) checkException(collection[1,2], silent=TRUE) if (compress) { checkException(collection[5], silent=TRUE) checkException(collection[c(NA, 2)], silent=TRUE) checkException(collection[c(TRUE, TRUE, TRUE)], silent=TRUE) checkException(unnamed["one"], silent=TRUE) } checkException(collection[c(-1,2)], silent=TRUE) empty <- IntegerList(compress=compress) names(empty) <- character(0) checkIdentical(collection[0], empty) checkIdentical(collection[numeric()], empty) checkIdentical(collection[logical()], empty) checkIdentical(collection[character()], empty) checkIdentical(collection[NULL], empty) checkIdentical(collection[], collection) checkIdentical(collection[FALSE], empty) checkIdentical(collection[c(FALSE, FALSE)], empty) checkIdentical(collection[list()], empty) checkIdentical(collection[TRUE], collection) checkIdentical(collection[c(TRUE, FALSE)], IntegerList(one=int1, compress=compress)) rl2 <- IntegerList(int2, compress=compress) names(rl2) <- "" checkIdentical(collection[2], rl2) checkIdentical(collection[c(2,1)], IntegerList(int2, one=int1, compress=compress)) checkIdentical(collection[-1], rl2) checkIdentical(collection["one"], IntegerList(one=int1, compress=compress)) } } test_List_replace <- function() { int1 <- c(1L,2L,3L,5L,2L,8L) int2 <- c(15L,45L,20L,1L,15L,100L,80L,5L) for (compress in c(TRUE, FALSE)) { collection <- IntegerList(one=int1, int2, compress=compress) checkException(collection[1,2] <- 1L, silent=TRUE) checkException(collection[c(-1,2)] <- 1L, silent=TRUE) newcollection <- collection newcollection[list()] <- 1L checkIdentical(newcollection, collection) newcollection <- collection newcollection[] <- collection checkIdentical(newcollection, collection) newcollection1 <- newcollection2 <- collection newcollection1[2:1] <- collection checkIdentical(newcollection1, IntegerList(one=int2, int1, compress=compress)) newcollection2[] <- collection[2:1] checkIdentical(newcollection2, newcollection1) value <- IntegerList(1:10, compress=compress) newcollection <- collection newcollection[TRUE] <- value checkIdentical(newcollection, IntegerList(one=1:10, 1:10, compress=compress)) newcollection <- collection newcollection[c(TRUE, FALSE)] <- value checkIdentical(newcollection, IntegerList(one=1:10, int2, compress=compress)) newcollection <- collection newcollection["one"] <- value checkIdentical(newcollection, IntegerList(one=1:10, int2, compress=compress)) newcollection <- collection newcollection[list(6:5, TRUE)] <- list(-1:-2, -99:-100) checkIdentical(newcollection, IntegerList(one=c(1,2,3,5,-2,-1), rep(c(-99,-100), 4), compress=compress)) collection <- IntegerList(one=int1, two=int2, compress=compress) newcollection <- collection newcollection[c("two", "one")] <- collection checkIdentical(newcollection, IntegerList(one=int2, two=int1, compress=compress)) newcollection <- collection newcollection[list(two=6:5, one=TRUE)] <- list(-1:-2, -99:-100) checkIdentical(newcollection, IntegerList(one=rep(c(-99,-100), 3), two=c(15,45,20,1,-2,-1,80,5), compress=compress)) collection <- IntegerList(one=c(a=1,b=2), two=c(d=1,b=0,a=5), compress=compress) newcollection1 <- newcollection2 <- collection newcollection1[list(two=2, one=2:1)] <- list(99, 11:12) checkIdentical(newcollection1, IntegerList(one=c(a=12,b=11), two=c(d=1,b=99,a=5), compress=compress)) newcollection2[list(two="b", one=c("b", "a"))] <- list(99, 11:12) checkIdentical(newcollection2, newcollection1) } } test_List_combine <- function() { int1 <- c(1L,2L,3L,5L,2L,8L) int2 <- c(15L,45L,20L,1L,15L,100L,80L,5L) for (compress in c(TRUE, FALSE)) { col1 <- IntegerList(one=int1, int2, compress=compress) col2 <- IntegerList(two=int2, one=int1, compress=compress) col3 <- IntegerList(int2, compress=compress) if (compress) checkException(append(col1, col2, c(1,2,3)), silent=TRUE) checkException(append(col1, col2, col3), silent=TRUE) checkIdentical(append(col1, col2), IntegerList(one=int1, int2, two=int2, one=int1, compress=compress)) checkIdentical(append(col1, col2, 1), IntegerList(one=int1, two=int2, one=int1, int2, compress=compress)) checkIdentical(append(col1, col2, 0), IntegerList(two=int2, one=int1, one=int1, int2, compress=compress)) checkIdentical(append(append(col1, col2), col3), IntegerList(one=int1, int2, two=int2, one=int1, int2, compress=compress)) ## for 'c' checkIdentical(c(col1, col2, col3), IntegerList(one=int1, int2, two=int2, one=int1, int2, compress=compress)) if (compress) { checkException(c(col1, int2), silent=TRUE) checkException(c(col1, col2, recursive=TRUE), silent=TRUE) } } } test_List_apply <- function() { int1 <- c(1L,2L,3L,5L,2L,8L) int2 <- c(15L,45L,20L,1L,15L,100L,80L,5L) for (compress in c(TRUE, FALSE)) { col1 <- IntegerList(one=int1, int2, compress=compress) checkIdentical(lapply(col1, mean), list(one=mean(int1), mean(int2))) checkException(lapply(col1, 2), silent=TRUE) } } test_List_unlist <- function() { for (compress in c(TRUE, FALSE)) { x0 <- list(c(a=1L), 21:23, 33L) x <- IntegerList(x0, compress=compress) target <- unlist(x0) current <- unlist(x) checkIdentical(target, current) names(x0) <- names(x) <- LETTERS[1:3] target <- unlist(x0) names(target)[2:4] <- "B" # base::unlist() behaviour not what we want! current <- unlist(x) checkIdentical(target, current) names(x0)[2] <- names(x)[2] <- "" target <- unlist(x0) current <- unlist(x) checkIdentical(target, current) names(x0)[2] <- names(x)[2] <- NA target <- unlist(x0) names(target)[2:4] <- NA # base::unlist() behaviour not what we want! current <- unlist(x) checkIdentical(target, current) names(x0[[2]])[] <- names(x[[2]])[] <- NA target <- unlist(x0) current <- unlist(x) checkIdentical(target, current) names(x0[[2]]) <- names(x[[2]]) <- "b" target <- unlist(x0) current <- unlist(x) checkIdentical(target, current) names(x0[[2]])[] <- names(x[[2]])[] <- "a" target <- unlist(x0) current <- unlist(x) checkIdentical(target, current) names(x0)[2] <- names(x)[2] <- "A" target <- unlist(x0) current <- unlist(x) checkIdentical(target, current) } } test_List_annotation <- function() { int1 <- c(1L,2L,3L,5L,2L,8L) int2 <- c(15L,45L,20L,1L,15L,100L,80L,5L) for (compress in c(TRUE, FALSE)) { ilist <- IntegerList(int1, int2, compress=compress) mcols(ilist) <- DataFrame(a=1:2) checkIdentical(mcols(ilist)[,1], 1:2) checkIdentical(mcols(ilist[2:1])[,1], 2:1) checkIdentical(mcols(c(ilist,ilist))[,1], rep(1:2,2)) checkIdentical(mcols(append(ilist,ilist))[,1], rep(1:2,2)) } } test_List_as.data.frame <- function() { for (compress in c(TRUE, FALSE)) { ## empty-ish current <- as.data.frame(IntegerList(compress=compress)) checkIdentical(data.frame(), current) current <- as.data.frame(IntegerList(NA, compress=compress)) expected <- data.frame(group=1L, group_name=NA_character_, value=NA_integer_, stringsAsFactors=FALSE) checkIdentical(expected, current) ilist <- IntegerList(C=1:5, A=NA, B=10:11, compress=compress) ## group, group_name, value current <- as.data.frame(ilist) checkTrue(ncol(current) == 3L) checkIdentical(togroup(ilist), current$group) checkIdentical(names(ilist)[togroup(ilist)], current$group_name) current <- as.data.frame(ilist, group_name.as.factor=TRUE) expected <- names(ilist)[togroup(ilist)] checkTrue(is(current$group_name, "factor")) checkIdentical(names(ilist), levels(current$group_name)) names(ilist) <- NULL current <- as.data.frame(ilist, group_name.as.factor=TRUE) checkIdentical(character(), levels(current$group_name)) checkException(as.data.frame(ilist, group_name.as.factor=NULL), silent=TRUE) checkIdentical(unlist(ilist, use.names=FALSE), current$value) current <- as.data.frame(ilist, value.name="test") checkIdentical(unlist(ilist, use.names=FALSE), current$test) checkException(as.data.frame(ilist, value.name=NULL), silent=TRUE) ## outer mcols mcols(ilist) <- DataFrame(foo=c("ccc", "aaa", "bbb")) current <- as.data.frame(ilist, use.outer.mcols=TRUE) expected <- c("group", "group_name", "value", "foo") checkIdentical(expected, colnames(current)) checkException(as.data.frame(ilist, use.outer.mcols=NULL), silent=TRUE) ## relist names(ilist) <- c("C", "A", "B") mcols(ilist) <- NULL current <- as.data.frame(ilist) if (compress == TRUE) checkIdentical(relist(current$value, ilist), ilist) } } S4Vectors/inst/unitTests/test_List-utils.R0000644000175100017510000000217612607264537021662 0ustar00biocbuildbiocbuild### NOTE: List is an abstract type, so we just test with IntegerList library(IRanges) test_List_funprog <- function() { int1 <- c(1L,2L,3L,5L,2L,8L) int2 <- c(15L,45L,20L,1L,15L,100L) for (compress in c(TRUE, FALSE)) { collection <- IntegerList(int1, int2, int1, compress=compress) addcollect <- IntegerList(int2, int1, int1, compress=compress) checkIdentical(Reduce("+", collection), Reduce("+", list(int1, int2, int1))) checkIdentical(as.list(Filter(function(x) mean(x) > 10, collection)), Filter(function(x) mean(x) > 10, list(int1, int2, int1))) checkIdentical(Find(function(x) mean(x) > 10, collection), Find(function(x) mean(x) > 10, list(int1, int2, int1))) checkIdentical(Map("+", collection, addcollect), Map("+", list(int1, int2, int1), list(int2, int1, int1))) checkIdentical(mapply("+", collection, addcollect), mapply("+", list(int1, int2, int1), list(int2, int1, int1))) checkIdentical(Position(function(x) mean(x) > 10, collection), Position(function(x) mean(x) > 10, list(int1, int2, int1))) } } S4Vectors/inst/unitTests/test_Rle-class.R0000644000175100017510000001670012607264536021433 0ustar00biocbuildbiocbuildtest_Rle_construction <- function() { empty <- Rle() checkTrue(validObject(empty)) checkIdentical(Rle(), new("Rle")) checkIdentical(length(empty), 0L) x <- Rle(rep(6:10, 1:5)) checkTrue(validObject(x)) checkIdentical(x, Rle(6:10, 1:5)) y <- Rle(factor(rep(letters, 1:26))) checkTrue(validObject(y)) checkIdentical(y, Rle(factor(letters), 1:26)) checkIdentical(Rle(c(TRUE, TRUE, FALSE, FALSE, FALSE, NA, NA, NA)), Rle(c(TRUE, FALSE, NA), c(2, 3, 3))) checkIdentical(Rle(c(1L, 1L, 1L, 2L, 2L, NA, NA, NA)), Rle(c(1L, 2L, NA), c(3, 2, 3))) checkIdentical(Rle(c(1, 1, 1, 2, 2, NA, NA, NA)), Rle(c(1, 2, NA), c(3, 2, 3))) checkIdentical(Rle(c("a", "a", "b", "b", "b", NA, NA, NA)), Rle(c("a", "b", NA), c(2, 3, 3))) } test_Rle_replace <- function() { x <- Rle(1:26, 1:26) runValue(x) <- letters checkTrue(validObject(x)) checkIdentical(x, Rle(letters, 1:26)) runLength(x) <- 26:1 checkTrue(validObject(x)) checkIdentical(x, Rle(letters, 26:1)) } test_Rle_coercion <- function() { x <- rep(6:10, 1:5) xRle <- Rle(x) y <- c(TRUE,TRUE,FALSE,FALSE,TRUE,FALSE,TRUE,TRUE,TRUE) yRle <- Rle(y) checkIdentical(x, as.vector(xRle)) checkIdentical(as.integer(x), as.integer(xRle)) checkIdentical(as.numeric(x), as.numeric(xRle)) checkIdentical(as.complex(x), as.complex(xRle)) checkIdentical(as.factor(x), as.factor(xRle)) checkIdentical(y, as.vector(yRle)) checkIdentical(as.logical(y), as.logical(yRle)) checkIdentical(as.character(y), as.character(yRle)) checkIdentical(as.raw(y), as.raw(yRle)) checkIdentical(as.factor(y), as.factor(yRle)) } test_Rle_general <- function() { x <- rep(6:10, 1:5) xRle <- Rle(x) checkIdentical(unique(x), unique(xRle)) checkIdentical(x[c(3,2,4,6)], as.vector(xRle[c(3,2,4,6)])) checkIdentical(append(x,x), as.vector(append(xRle,xRle))) checkIdentical(append(x,x,3), as.vector(append(xRle,xRle,3))) checkIdentical(c(x,x) %in% c(7:9), as.vector(c(xRle,xRle)) %in% c(7:9)) checkIdentical(c(x, x), as.vector(c(xRle, xRle))) checkIdentical(is.na(c(NA, x, NA, NA, NA, x, NA)), as.vector(is.na(c(Rle(NA), xRle, Rle(NA, 3), xRle, Rle(NA))))) checkIdentical(is.unsorted(c(1,2,2,3)), is.unsorted(Rle(c(1,2,2,3)))) checkIdentical(is.unsorted(c(1,2,2,3), strictly = TRUE), is.unsorted(Rle(c(1,2,2,3)), strictly = TRUE)) checkIdentical(length(x), length(xRle)) checkIdentical(match(c(x,x), c(7:9)), as.vector(match(c(xRle,xRle), c(7:9)))) checkIdentical(rep(x, times = 2), as.vector(rep(xRle, times = 2))) checkIdentical(rep(x, times = x), as.vector(rep(xRle, times = x))) checkIdentical(rep(x, length.out = 20), as.vector(rep(xRle, length.out = 20))) checkIdentical(rep(x, each = 2), as.vector(rep(xRle, each = 2))) checkIdentical(rep(x, x, 20), as.vector(rep(xRle, x, 20))) checkException(rep(xRle, x, each = 2), silent = TRUE) checkIdentical(rep(x, 2, each = 2), as.vector(rep(xRle, 2, each = 2))) checkIdentical(rep(x, length.out = 20, each = 2), as.vector(rep(xRle, length.out = 20, each = 2))) checkIdentical(rep(x, x, 20, 2), as.vector(rep(xRle, x, 20, 2))) checkIdentical(rep.int(x, times = 2), as.vector(rep.int(xRle, times = 2))) checkIdentical(rev(x), as.vector(rev(xRle))) library(IRanges) checkIdentical(as.vector(xRle[IRanges(start=1:3, width=1:3)]), x[c(1,2,3,3,4,5)]) z <- x z[] <- rev(z) zRle <- xRle zRle[] <- rev(zRle) checkIdentical(z, as.vector(zRle)) z <- x z[c(1,5,3)] <- 3:1 zRle <- xRle zRle[c(1,5,3)] <- 3:1 checkIdentical(z, as.vector(zRle)) z <- x z[1:5] <- 0L zRle <- xRle zRle[IRanges(start=1:3, width=1:3)] <- 0L checkIdentical(z, as.vector(zRle)) checkIdentical(sort(c(x,x)), as.vector(sort(c(xRle,xRle)))) checkIdentical(as.vector(subset(xRle, rep(c(TRUE, FALSE), length.out = length(.(x))))), subset(x, rep(c(TRUE, FALSE), length.out = length(x)))) checkIdentical(as.vector(window(x, start = 3, end = 13)), as.vector(window(xRle, start = 3, end = 13))) checkIdentical(as.vector(window(x, start = 3, end = 13, frequency = 1/2)), as.vector(window(xRle, start = 3, end = 13, frequency = 1/2))) checkIdentical(as.vector(window(x, start = 3, end = 13, delta = 3)), as.vector(window(xRle, start = 3, end = 13, delta = 3))) z <- x z[3:13] <- 0L zRle <- xRle window(zRle, start = 3, end = 13) <- 0L checkIdentical(z, as.vector(zRle)) } ## --------------------------------------------- ## table() and sort() ## --------------------------------------------- test_Rle_sort <- function() { ## atomic ix <- c(NA, 3L, NA) nx <- c(2, 5, 1, 2, NA, 5, NA) cx <- c("c", "B", NA, "a") lx <- c(FALSE, FALSE, NA, TRUE, NA) checkIdentical(sort(nx), as.numeric(sort(Rle(nx)))) checkIdentical(sort(nx, na.last=TRUE), as.numeric(sort(Rle(nx), na.last=TRUE))) checkIdentical(sort(nx, na.last=FALSE), as.numeric(sort(Rle(nx), na.last=FALSE))) checkIdentical(sort(ix), as.integer(sort(Rle(ix)))) checkIdentical(sort(cx), as.character(sort(Rle(cx)))) checkIdentical(sort(lx), as.logical(sort(Rle(lx)))) checkIdentical(sort(numeric()), as.numeric(sort(Rle(numeric())))) checkIdentical(sort(character()), as.character(sort(Rle(character())))) ## factor nf <- factor(nx) checkIdentical(sort(nf), as.factor(sort(Rle(nf)))) checkIdentical(sort(nf, decreasing=TRUE, na.last=TRUE), as.factor(sort(Rle(nf), decreasing=TRUE, na.last=TRUE))) checkIdentical(sort(nf, na.last=FALSE), as.factor(sort(Rle(nf), na.last=FALSE))) checkIdentical(sort(factor()), as.factor(sort(Rle(factor())))) ## factor, unused levels nf <- factor(nx, levels=1:6) checkIdentical(levels(sort(nf)), levels(sort(Rle(nf)))) } test_Rle_table <- function() { ## atomic ix <- c(NA, 3L, NA) nx <- c(2, 5, 1, 2, NA, 5, NA) cx <- c("c", "B", NA, "a") lx <- c(FALSE, FALSE, NA, TRUE, NA) checkIdentical(table(ix), table("ix"=Rle(ix))) checkIdentical(table(nx), table("nx"=Rle(nx))) checkIdentical(table(cx), table("cx"=Rle(cx))) checkIdentical(table(lx), table("lx"=Rle(lx))) checkIdentical(table(numeric()), table(Rle(numeric()))) checkIdentical(table(character()), table(Rle(character()))) ## factor nf <- factor(nx) checkIdentical(table("nx"=nx), table("nx"=Rle(nx))) checkIdentical(table(factor()), table(Rle(factor()))) ## factor, unused levels nf <- factor(nx, levels=1:6) cf <- factor(cx, levels=c("a", "c", "B", "b")) checkIdentical(as.factor(table(nf)), as.factor(table(Rle(nf)))) checkIdentical(as.factor(table(cf)), as.factor(table(Rle(cf)))) } test_Rle_Integer_overflow <- function() { x0 <- Rle(values=as.integer(c(1,(2^31)-1,1))) checkIdentical(NA_integer_, suppressWarnings(sum(x0))) testWarning <- NULL suppressWarnings(withCallingHandlers({sum(x0) }, warning=function(warn) { msg <- conditionMessage(warn) exp <- gettext("integer overflow - use runValue(.) <- as.numeric(runValue(.))", domain="R") if (msg == exp) testWarning <<- TRUE })) checkTrue(testWarning) x <- Rle(values=c(1,(2^31)-1,1)) checkIdentical(mean(x0), mean(x)) } S4Vectors/inst/unitTests/test_Rle-utils.R0000644000175100017510000005745312607264537021501 0ustar00biocbuildbiocbuildtest_Rle_groupGeneric <- function() { set.seed(0) x <- sample(0:3, 50, replace = TRUE) xRle <- Rle(x) checkIdentical(numeric(0) + 1, as.vector(Rle(numeric(0)) + 1)) checkIdentical(x + 1, as.vector(xRle + 1)) checkIdentical(2 * x + 3, as.vector(2 * xRle + 3)) checkIdentical(x[(x > 0) & (x < 3)], as.vector(xRle[(xRle > 0) & (xRle < 3)])) checkIdentical(log(x), as.vector(log(xRle))) checkIdentical(range(x), range(xRle)) checkIdentical(sum(x), sum(xRle)) checkIdentical(prod(x), prod(xRle)) checkIdentical(cumsum(x), as.vector(cumsum(xRle))) checkIdentical(cumprod(x), as.vector(cumprod(xRle))) checkIdentical(round(x + .25), as.vector(round(xRle + .25))) checkIdentical(signif(x + .25), as.vector(signif(xRle + .25))) checkIdentical(Im(x + 5i), as.vector(Im(xRle + 5i))) } test_Rle_general <- function() { x <- rep(6:10, 1:5) xRle <- Rle(x) checkIdentical(aggregate(xRle, IRanges(start = 3:6, end = 13:10), FUN = mean), aggregate(xRle, FUN = mean, start = 3:6, width = seq(11, 5, by = -2))) exp <- c(mean(x[3:13]), mean(x[4:12]), mean(x[5:11]), mean(x[6:10])) agg <- aggregate(xRle, FUN = function(x) x, start = 3:6, end = 13:10) checkEquals(exp, aggregate(xRle, FUN = mean, start = 3:6, end = 13:10)) checkEquals(as.vector(aggregate.ts(ts(x, frequency = 5), FUN = mean)), aggregate(xRle, FUN = mean, start = c(1, 6, 11), end = c(5, 10, 15))) #checkIdentical(findRange(c(1, 3, 5), xRle), IRanges(start = c(1,2,4), width = 1:3)) #checkIdentical(head(x, 8), as.vector(head(xRle, 8))) #checkIdentical(head(x, -3), as.vector(head(xRle, -3))) #checkException(split(Rle(1:26), integer()), silent = TRUE) #checkException(split(Rle(1:26), Rle()), silent = TRUE) #checkIdentical(lapply(as.list(split(Rle(1:26), letters)), as.vector), # split(1:26, letters)) #checkIdentical(lapply(as.list(split(Rle(1:26), Rle(letters))), as.vector), # split(1:26, letters)) #checkIdentical(lapply(as.list(split(Rle(1:26), letters[1:2])), as.vector), # split(1:26, letters[1:2])) #checkIdentical(lapply(as.list(split(Rle(1:26), Rle(letters[1:2]))), as.vector), # split(1:26, letters[1:2])) #checkIdentical(lapply(as.list(split(Rle(integer()), letters)), as.vector), # split(integer(), letters)) #checkIdentical(lapply(as.list(split(Rle(integer()), Rle(letters))), as.vector), # split(integer(), letters)) #checkIdentical(splitRanges(Rle(letters, 1:26)), # split(IRanges(end = cumsum(1:26), width = 1:26), letters)) checkIdentical(summary(x), summary(xRle)) #checkIdentical(tail(x, 8), as.vector(tail(xRle, 8))) #checkIdentical(tail(x, -3), as.vector(tail(xRle, -3))) #checkException(tapply(xRle), silent = TRUE) #checkIdentical(tapply(x, x), tapply(xRle, xRle)) #checkIdentical(tapply(x, x, mean), tapply(xRle, xRle, mean)) #checkIdentical(tapply(xRle, x, mean), tapply(xRle, xRle, mean)) #checkIdentical(tapply(x, x, mean, simplify = FALSE), # tapply(xRle, xRle, mean, simplify = FALSE)) #checkIdentical(tapply(xRle, x, mean, simplify = FALSE), # tapply(xRle, xRle, mean, simplify = FALSE)) } test_Rle_logical <- function() { checkIdentical(logical(), as.vector(Rle(logical()))) x <- c(TRUE,TRUE,FALSE,FALSE,TRUE,FALSE,TRUE,TRUE,TRUE) xRle <- Rle(x) checkIdentical(!x, as.vector(!x)) checkIdentical(which(x), as.vector(which(x))) checkIdentical(as(xRle, "IRanges"), IRanges(start = c(1,5,7), width = c(2, 1, 3))) } test_Rle_numerical <- function() { checkIdentical(numeric(), as.vector(Rle(numeric()))) x <- cumsum(cumsum(1:10)) xRle <- Rle(x) checkIdentical(pmax(x, rev(x)), as.vector(pmax(xRle, rev(xRle)))) checkIdentical(pmin(x, rev(x)), as.vector(pmin(xRle, rev(xRle)))) checkIdentical(pmax.int(x, rev(x)), as.vector(pmax.int(xRle, rev(xRle)))) checkIdentical(pmin.int(x, rev(x)), as.vector(pmin.int(xRle, rev(xRle)))) checkIdentical(diff(x), as.vector(diff(xRle))) checkIdentical(diff(x, lag = 2), as.vector(diff(xRle, lag = 2))) checkIdentical(diff(x, differences = 2), as.vector(diff(xRle, differences = 2))) checkIdentical(diff(x, lag = 2, differences = 2), as.vector(diff(xRle, lag = 2, differences = 2))) x <- rep(c(1.2, 3.4, NA, 7.8, 9.0), 1:5) y <- x - rev(x) xRle <- Rle(x) yRle <- Rle(y) checkIdentical(mean(x), mean(xRle)) checkIdentical(mean(x, na.rm = TRUE), mean(xRle, na.rm = TRUE)) checkIdentical(var(x), var(xRle)) checkEqualsNumeric(var(x, na.rm = TRUE), var(xRle, na.rm = TRUE)) checkIdentical(var(x, y), var(xRle, yRle)) checkEqualsNumeric(var(x, y, na.rm = TRUE), var(xRle, yRle, na.rm = TRUE)) checkIdentical(cov(x, y), cov(xRle, yRle)) checkEqualsNumeric(cov(x, y, use = "complete"), cov(xRle, yRle, use = "complete")) checkIdentical(cor(x, y), cor(xRle, yRle)) checkEqualsNumeric(cor(x, y, use = "complete"), cor(xRle, yRle, use = "complete")) checkIdentical(sd(x), sd(xRle)) checkEqualsNumeric(sd(x, na.rm = TRUE), sd(xRle, na.rm = TRUE)) checkIdentical(median(x), median(xRle)) checkIdentical(median(x, na.rm = TRUE), median(xRle, na.rm = TRUE)) checkIdentical(quantile(x, na.rm = TRUE), quantile(xRle, na.rm = TRUE)) checkIdentical(mad(x), mad(xRle)) checkIdentical(mad(x, na.rm = TRUE), mad(xRle, na.rm = TRUE)) checkIdentical(IQR(x, na.rm = TRUE), IQR(xRle, na.rm = TRUE)) y <- (-20:20)^2 y[c(1,10,21,41)] <- c(100L, 30L, 400L, 470L) checkEqualsNumeric(smoothEnds(y), as.vector(smoothEnds(Rle(y)))) checkEqualsNumeric(runmed(y, 7), as.vector(runmed(Rle(y), 7))) checkEqualsNumeric(runmed(y, 11), as.vector(runmed(Rle(y), 11))) checkEqualsNumeric(runmed(y, 7, "keep"), as.vector(runmed(Rle(y), 7, "keep"))) checkEqualsNumeric(runmed(y, 11, "keep"), as.vector(runmed(Rle(y), 11, "keep"))) checkEqualsNumeric(runmed(y, 7, "constant"), as.vector(runmed(Rle(y), 7, "constant"))) checkEqualsNumeric(runmed(y, 11, "constant"), as.vector(runmed(Rle(y), 11, "constant"))) x <- rep(c(1.2, 3.4, 5.6, 7.8, 9.0), 1:5) y <- rep(1:5, c(4, 2, 5, 1, 3)) xRle <- Rle(x) yRle <- Rle(y) checkEqualsNumeric(sapply(1:13, function(i) sum(window(x, i, i + 2))), as.numeric(runsum(xRle, k = 3))) # checkEqualsNumeric(sapply(1:13, function(i) sum(window(rev(x), i, i + 2))), # as.numeric(runsum(rev(xRle), k = 3))) checkEqualsNumeric(sapply(1:13, function(i) sum(window(y, i, i + 2))), as.integer(runsum(yRle, k = 3))) checkEqualsNumeric(sapply(1:13, function(i) sum(window(rev(y), i, i + 2))), as.integer(runsum(rev(yRle), k = 3))) checkEqualsNumeric(sapply(1:13, function(i) mean(window(x, i, i + 2))), as.numeric(runmean(xRle, k = 3))) checkEqualsNumeric(sapply(1:13, function(i) mean(window(rev(x), i, i + 2))), as.numeric(runmean(rev(xRle), k = 3))) checkEqualsNumeric(sapply(1:13, function(i) mean(window(y, i, i + 2))), as.numeric(runmean(yRle, k = 3))) checkEqualsNumeric(sapply(1:13, function(i) mean(window(rev(y), i, i + 2))), as.numeric(runmean(rev(yRle), k = 3))) checkEqualsNumeric(sapply(1:13, function(i) sum(window(x, i, i + 2))), as.numeric(runwtsum(xRle, k = 3, wt = rep(1,3)))) checkEqualsNumeric(sapply(1:13, function(i) sum(window(x, i, i + 2)/3)), as.numeric(runwtsum(xRle, k = 3, wt = rep(1/3,3)))) checkEqualsNumeric(sapply(1:13, function(i) sum(window(y, i, i + 2))), as.numeric(runwtsum(yRle, k = 3, wt = rep(1,3)))) checkEqualsNumeric(sapply(1:13, function(i) sum(window(y, i, i + 2)/3)), as.numeric(runwtsum(yRle, k = 3, wt = rep(1/3,3)))) checkEqualsNumeric(sapply(1:13, function(i) min(window(x, i, i + 2))), as.numeric(runq(xRle, k = 3, i = 1))) checkEqualsNumeric(sapply(1:13, function(i) median(window(x, i, i + 2))), as.numeric(runq(xRle, k = 3, i = 2))) checkEqualsNumeric(sapply(1:13, function(i) max(window(x, i, i + 2))), as.numeric(runq(xRle, k = 3, i = 3))) checkIdentical(runq(xRle, k = 3, i = 2), rev(runq(rev(xRle), k = 3, i = 2))) checkEqualsNumeric(sapply(1:13, function(i) min(window(y, i, i + 2))), as.numeric(runq(yRle, k = 3, i = 1))) checkEqualsNumeric(sapply(1:13, function(i) median(window(y, i, i + 2))), as.numeric(runq(yRle, k = 3, i = 2))) checkEqualsNumeric(sapply(1:13, function(i) max(window(y, i, i + 2))), as.numeric(runq(yRle, k = 3, i = 3))) checkIdentical(runq(yRle, k = 3, i = 2), rev(runq(rev(yRle), k = 3, i = 2))) } test_Rle_character <- function() { checkIdentical(character(), as.vector(Rle(character()))) txt <- c("The", "licenses", "for", "most", "software", "are", "designed", "to", "take", "away", "your", "freedom", "to", "share", "and", "change", "it.", "", "By", "contrast,", "the", "GNU", "General", "Public", "License", "is", "intended", "to", "guarantee", "your", "freedom", "to", "share", "and", "change", "free", "software", "--", "to", "make", "sure", "the", "software", "is", "free", "for", "all", "its", "users") txt <- rep(txt, seq_len(length(txt))) txtRle <- Rle(txt) checkIdentical(nchar(txt), as.vector(nchar(txtRle))) checkIdentical(substr(txt, 3, 7), as.vector(substr(txtRle, 3, 7))) checkIdentical(substring(txt, 4, 9), as.vector(substring(txtRle, 4, 9))) checkIdentical(chartr("@!*", "alo", txt), as.vector(chartr("@!*", "alo", txtRle))) checkIdentical(tolower(txt), as.vector(tolower(txtRle))) checkIdentical(toupper(txt), as.vector(toupper(txtRle))) checkIdentical(sub("[b-e]",".", txt), as.vector(sub("[b-e]",".", txtRle))) checkIdentical(gsub("[b-e]",".", txt), as.vector(gsub("[b-e]",".", txtRle))) checkIdentical(paste(txt, rev(txt), sep = "|"), as.vector(paste(txtRle, rev(txtRle), sep = "|"))) modifyFactor <- function(x, FUN, ...) { levels(x) <- FUN(levels(x), ...) x } fac <- factor(txt) facRle <- Rle(fac) checkIdentical(modifyFactor(fac, substr, 3, 7), as.factor(substr(facRle, 3, 7))) checkIdentical(modifyFactor(fac, substring, 4, 9), as.factor(substring(facRle, 4, 9))) checkIdentical(modifyFactor(fac, chartr, old = "@!*", new = "alo"), as.factor(chartr("@!*", "alo", facRle))) checkIdentical(modifyFactor(fac, tolower), as.factor(tolower(facRle))) checkIdentical(modifyFactor(fac, toupper), as.factor(toupper(facRle))) checkIdentical(modifyFactor(fac, sub, pattern = "[b-e]", replacement = "."), as.factor(sub("[b-e]",".", facRle))) checkIdentical(modifyFactor(fac, gsub, pattern = "[b-e]", replacement = "."), as.factor(gsub("[b-e]",".", facRle))) checkTrue(is.factor(runValue(paste(facRle, rev(facRle), sep = "|")))) } test_Rle_factor <- function() { checkIdentical(factor(character()), as.factor(Rle(factor(character())))) x <- factor(rep(letters, 1:26)) xRle <- Rle(x) checkIdentical(levels(x), levels(xRle)) levels(x) <- LETTERS levels(xRle) <- LETTERS checkIdentical(levels(x), levels(xRle)) checkIdentical(nlevels(x), 26L) xRle[] <- xRle checkIdentical(Rle(x), xRle) checkIdentical(x, xRle[TRUE,drop=TRUE]) } ## --------------------------------------------- ## runsum(), runmean(), runwtsum() ## --------------------------------------------- .naive_runsum <- function(x, k, na.rm=FALSE) sapply(0:(length(x)-k), function(offset) sum(x[1:k + offset], na.rm=na.rm)) checkIdenticalIfNaNsWereNAs <- function(x, y) { x[is.nan(x)] <- NA_real_ y[is.nan(y)] <- NA_real_ checkIdentical(x, y) } test_Rle_runsum_real <- function() { x0 <- c(NA, NaN, Inf, -Inf) x <- Rle(x0) ## na.rm = TRUE target1 <- .naive_runsum(x0, 4, na.rm=TRUE) target2 <- .naive_runsum(x, 4, na.rm=TRUE) checkIdenticalIfNaNsWereNAs(target1, target2) current <- as.vector(runsum(x, 4, na.rm=TRUE)) checkIdenticalIfNaNsWereNAs(target1, current) ## na.rm = FALSE target1 <- .naive_runsum(x0, 4, na.rm=FALSE) target2 <- .naive_runsum(x, 4, na.rm=FALSE) checkIdenticalIfNaNsWereNAs(target1, target2) current <- as.vector(runsum(x, 4, na.rm=FALSE)) checkIdenticalIfNaNsWereNAs(target1, current) x0 <- c(NA, Inf, NA, -Inf, Inf, -Inf, NaN, Inf, NaN, -Inf) x <- Rle(x0) for (k in 1:2) { target1 <- .naive_runsum(x0, k, na.rm=TRUE) target2 <- .naive_runsum(x, k, na.rm=TRUE) checkIdenticalIfNaNsWereNAs(target1, target2) current <- as.vector(runsum(x, k, na.rm=TRUE)) checkIdenticalIfNaNsWereNAs(target1, current) target1 <- .naive_runsum(x0, k, na.rm=FALSE) target2 <- .naive_runsum(x, k, na.rm=FALSE) checkIdenticalIfNaNsWereNAs(target1, target2) current <- as.vector(runsum(x, k, na.rm=FALSE)) checkIdenticalIfNaNsWereNAs(target1, current) } ## NOTE : Inconsistent behavior in base::sum() ## sum(x, y) and x + y: ## > sum(NaN, NA) ## [1] NA ## > NaN + NA ## [1] NaN ## also between sum(c(x, y)) and sum(x, y): ## This inconsistency only exists on linux, not Mac or Windows ## > sum(c(NaN, NA)) ## [1] NaN ## > sum(NaN, NA) ## [1] NA ## x0 <- c(NA, NaN, NA) ## x <- Rle(x0) ## target1 <- c(x0[1] + x0[2], x0[2] + x0[3]) ## target2 <- as.vector(c(x[1] + x[2], x[2] + x[3])) ## checkIdentical(target1, target2) ## current <- as.vector(runsum(x, k=2, na.rm=FALSE)) ## checkIdentical(target1, current) } test_Rle_runsum_integer <- function() { x0 <- c(NA_integer_, 1L, 1L) x <- Rle(x0) for (k in 1:3) { target1 <- .naive_runsum(x0, k, na.rm=TRUE) target2 <- .naive_runsum(x, k, na.rm=TRUE) checkIdentical(target1, target2) current <- as.vector(runsum(x, k, na.rm=TRUE)) checkIdentical(target1, current) target1 <- .naive_runsum(x0, k, na.rm=FALSE) target2 <- .naive_runsum(x, k, na.rm=FALSE) checkIdentical(target1, target2) current <- as.vector(runsum(x, k, na.rm=FALSE)) checkIdentical(target1, current) } x0 <- c(1L, NA_integer_, 1L) x <- Rle(x0) for (k in 1:3) { target1 <- .naive_runsum(x0, k, na.rm=TRUE) target2 <- .naive_runsum(x, k, na.rm=TRUE) checkIdentical(target1, target2) current <- as.vector(runsum(x, k, na.rm=TRUE)) checkIdentical(target1, current) target1 <- .naive_runsum(x0, k, na.rm=FALSE) target2 <- .naive_runsum(x, k, na.rm=FALSE) checkIdentical(target1, target2) current <- as.vector(runsum(x, k, na.rm=FALSE)) checkIdentical(target1, current) } } .naive_runmean <- function(x, k, na.rm=FALSE) sapply(0:(length(x)-k), function(offset) mean(x[1:k + offset], na.rm=na.rm)) test_Rle_runmean <- function() { x0 <- c(NA, 1, 1) x <- Rle(x0) for (k in 1:3) { target1 <- .naive_runmean(x0, k, na.rm=TRUE) target2 <- .naive_runmean(x, k, na.rm=TRUE) checkIdentical(target1, target2) current <- as.vector(runmean(x, k, na.rm=TRUE)) checkIdentical(target1, current) target1 <- .naive_runmean(x0, k, na.rm=FALSE) target2 <- .naive_runmean(x, k, na.rm=FALSE) checkIdentical(target1, target2) current <- as.vector(runmean(x, k, na.rm=FALSE)) checkIdentical(target1, current) } x0 <- c(0, NA, NaN, 0, NA, Inf, 0, NA, -Inf, 0, Inf, -Inf) x <- Rle(x0) for (k in 1:2) { target1 <- .naive_runmean(x0, k, na.rm=TRUE) target2 <- .naive_runmean(x, k, na.rm=TRUE) checkIdentical(target1, target2) current <- as.vector(runmean(x, k, na.rm=TRUE)) checkIdentical(target1, current) target1 <- .naive_runmean(x0, k, na.rm=FALSE) target2 <- .naive_runmean(x, k, na.rm=FALSE) checkIdentical(target1, target2) #current <- as.vector(runmean(x, k, na.rm=FALSE)) #checkIdentical(target1, current) } } .naive_runwtsum <- function(x, k, wt, na.rm=FALSE) sapply(0:(length(x)-k), function(offset) { xwt <- x[1:k + offset] * wt sum(xwt, na.rm=na.rm)}) test_Rle_runwtsum_real <- function() { x0 <- c(NA, NaN, Inf, -Inf) x <- Rle(x0) wt <- rep(1, 4) target1 <- .naive_runwtsum(x0, 4, wt, na.rm=TRUE) target2 <- .naive_runwtsum(x, 4, wt, na.rm=TRUE) checkIdentical(target1, target2) current <- as.vector(runwtsum(x, 4, wt, na.rm=TRUE)) checkIdentical(target1, current) target1 <- .naive_runwtsum(x0, 4, wt, na.rm=FALSE) target2 <- .naive_runwtsum(x, 4, wt, na.rm=FALSE) checkIdentical(target1, target2) #current <- as.vector(runwtsum(x, 4, wt, na.rm=FALSE)) #checkIdentical(target1, current) x0 <- c(NA, Inf, NA, -Inf, Inf, -Inf, NaN, Inf, NaN, -Inf) x <- Rle(x0) for (k in 1:2) { if (k==1) wt <- 1 else wt <- c(1, 1) target1 <- .naive_runwtsum(x0, k, wt, na.rm=TRUE) target2 <- .naive_runwtsum(x, k, wt, na.rm=TRUE) checkIdentical(target1, target2) current <- as.vector(runwtsum(x, k, wt, na.rm=TRUE)) checkIdentical(target1, current) target1 <- .naive_runwtsum(x0, k, wt, na.rm=FALSE) target2 <- .naive_runwtsum(x, k, wt, na.rm=FALSE) checkIdentical(target1, target2) current <- as.vector(runwtsum(x, k, wt, na.rm=FALSE)) checkIdentical(target1, current) } x0 <- c(1, NA, 1, NaN, 1, NA) x <- Rle(x0) for (k in 1:2) { if (k==1) wt <- 2 else wt <- c(1, 1) target1 <- .naive_runwtsum(x0, k, wt, na.rm=FALSE) target2 <- .naive_runwtsum(x, k, wt, na.rm=FALSE) checkIdentical(target1, target2) current <- as.vector(runwtsum(x, k, wt, na.rm=FALSE)) checkIdentical(target1, current) } } test_Rle_runwtsum_integer <- function() { x0 <- c(NA_integer_, 1L, 1L) x <- Rle(x0) iwt <- rep(2L, 3) for (k in 1:3) { wt <- iwt[1:k] target1 <- .naive_runwtsum(x0, k, wt, na.rm=TRUE) target2 <- .naive_runwtsum(x, k, wt, na.rm=TRUE) checkIdentical(target1, target2) current <- as.vector(runwtsum(x, k, wt, na.rm=TRUE)) checkIdentical(as.numeric(target1), current) target1 <- .naive_runwtsum(x0, k, wt, na.rm=FALSE) target2 <- .naive_runwtsum(x, k, wt, na.rm=FALSE) checkIdentical(target1, target2) current <- as.vector(runwtsum(x, k, wt, na.rm=FALSE)) checkIdentical(as.numeric(target1), current) } x0 <- c(1L, NA_integer_, 1L) x <- Rle(x0) iwt <- rep(2L, 3) for (k in 1:3) { wt <- iwt[1:k] target1 <- .naive_runwtsum(x0, k, wt, na.rm=TRUE) target2 <- .naive_runwtsum(x, k, wt, na.rm=TRUE) checkIdentical(target1, target2) current <- as.vector(runwtsum(x, k, wt, na.rm=TRUE)) checkIdentical(as.numeric(target1), current) target1 <- .naive_runwtsum(x0, k, wt, na.rm=FALSE) target2 <- .naive_runwtsum(x, k, wt, na.rm=FALSE) checkIdentical(target1, target2) current <- as.vector(runwtsum(x, k, wt, na.rm=FALSE)) checkIdentical(as.numeric(target1), current) } } .naive_runq <- function(x, k, i, na.rm=FALSE) sapply(0:(length(x)-k), function(offset) { xsub <- x[1:k + offset] if (!na.rm) { ## Manually handle NA's because they are not allowed ## in 'x' of quantile(x, ...) when na.rm=FALSE. if (any(is.na(xsub))) NA else quantile(xsub, probs=i/k, na.rm=na.rm, names=FALSE, type=3) } else { ## If all NA's, just return first NA value. ## Not handled in quantile(). if (all(is.na(xsub))) { xsub[1] } else { xsub <- xsub[!is.na(xsub)] quantile(xsub, probs=i/k, na.rm=na.rm, names=FALSE, type=3) } } }, USE.NAMES=FALSE) test_Rle_runq_real <- function() { x0 <- c(NA_real_) x <- Rle(x0) k <- length(x); i <- 1 target1 <- as.numeric(.naive_runq(x0, k, i, na.rm=TRUE)) current <- as.numeric(runq(x, k, i, na.rm=TRUE)) checkIdentical(target1, current) x0 <- c(3, NA, 1, NaN, 4, Inf, 2, -Inf) x <- Rle(x0) k <- length(x) for (i in c(1, length(x))) { target1 <- as.numeric(.naive_runq(x0, k, i, na.rm=TRUE)) current <- as.numeric(runq(x, k, i, na.rm=TRUE)) checkIdentical(target1, current) target1 <- as.numeric(.naive_runq(x0, k, i, na.rm=FALSE)) current <- as.numeric(runq(x, k, i, na.rm=FALSE)) checkIdentical(target1, current) } x0 <- c(3, NA, 1, NaN, 4, Inf, 2, -Inf) x <- Rle(x0) i <- 1 ## NOTE : special case k=1, returns NA not NaN target1 <- c(3, NA, 1, NA, 4, Inf, 2, -Inf) current <- as.numeric(runq(x, k=1, i=1, na.rm=TRUE)) checkIdentical(target1, current) for (k in c(2:length(x))) { target1 <- as.numeric(.naive_runq(x0, k, i, na.rm=TRUE)) current <- as.numeric(runq(x, k, i, na.rm=TRUE)) checkIdentical(target1, current) target1 <- as.numeric(.naive_runq(x0, k, i, na.rm=FALSE)) current <- as.numeric(runq(x, k, i, na.rm=FALSE)) checkIdentical(target1, current) } x0 <- c(1, 2, 3, 4, 5) x <- Rle(x0) k <- length(x); i <- 4 target1 <- .naive_runq(x0, k, i, na.rm=TRUE) current <- as.vector(runq(x, k, i, na.rm=TRUE)) checkIdentical(target1, current) x0 <- c(1, 2, 3, NA, NA) x <- Rle(x0) k <- length(x); i <- 4 target1 <- .naive_runq(x0, k, i, na.rm=TRUE) current <- as.vector(runq(x, k, i, na.rm=TRUE)) checkIdentical(target1, current) } test_Rle_runq_integer <- function() { x0 <- c(NA_integer_) x <- Rle(x0) k <- length(x); i <- 1 target1 <- as.numeric(.naive_runq(x0, k, i, na.rm=TRUE)) current <- as.numeric(runq(x, k, i, na.rm=TRUE)) checkIdentical(target1, current) x0 <- NA_integer_ x <- Rle(x0) k <- i <- 1 target1 <- unlist(.naive_runq(x0, k, i, na.rm=TRUE)) target2 <- as.vector(do.call(c, (.naive_runq(x, k, i, na.rm=TRUE)))) checkIdentical(target1, target2) current <- as.vector(runq(x, k, i, na.rm=TRUE)) checkIdentical(as.integer(unname(target1)), current) x0 <- c(NA_integer_, 2L, 1L) x <- Rle(x0) k <- 3 for (i in 1:3) { target1 <- unlist(.naive_runq(x0, k, i, na.rm=TRUE)) current <- as.vector(runq(x, k, i, na.rm=TRUE)) checkIdentical(unname(target1), current) target1 <- unlist(.naive_runq(x0, k, i, na.rm=FALSE)) current <- as.integer(runq(x, k, i, na.rm=FALSE)) checkIdentical(as.integer(target1), current) } x0 <- c(3L, 2L, NA_integer_, NA_integer_, 1L, 2L) x <- Rle(x0) i <- 1 for (k in 1:6) { target1 <- unlist(.naive_runq(x0, k, i, na.rm=TRUE)) current <- as.vector(runq(x, k, i, na.rm=TRUE)) checkIdentical(target1, current) target1 <- unlist(.naive_runq(x0, k, i, na.rm=FALSE)) current <- as.integer(runq(x, k, i, na.rm=FALSE)) checkIdentical(as.integer(target1), current) } } S4Vectors/man/0000755000175100017510000000000012607264537014215 5ustar00biocbuildbiocbuildS4Vectors/man/Annotated-class.Rd0000644000175100017510000000215412607264536017525 0ustar00biocbuildbiocbuild\name{Annotated-class} \docType{class} \alias{Annotated} \alias{Annotated-class} % accessors \alias{metadata} \alias{metadata,Annotated-method} \alias{metadata<-} \alias{metadata<-,Annotated-method} \title{Annotated class} \description{The virtual class \code{Annotated} is used to standardize the storage of metadata with a subclass.} \details{ The \code{Annotated} class supports the storage of global metadata in a subclass. This is done through the \code{metadata} slot that stores a list object. } \section{Accessors}{ In the following code snippets, \code{x} is an \code{Annotated} object. \describe{ \item{}{\code{metadata(x)}, \code{metadata(x) <- value}: Get or set the list holding arbitrary R objects as annotations. May be, and often is, empty. } } } \author{P. Aboyoun} \seealso{ The \link{Vector} class, which extends Annotated directly. } \examples{ showClass("Annotated") # shows (some of) the known subclasses ## If the IRanges package was not already loaded, this will show ## more subclasses: library(IRanges) showClass("Annotated") } \keyword{methods} \keyword{classes} S4Vectors/man/DataFrame-class.Rd0000644000175100017510000002214312607264536017434 0ustar00biocbuildbiocbuild\name{DataFrame-class} \docType{class} \alias{class:DataFrame} \alias{DataFrame-class} % accessor \alias{nrow,DataFrame-method} \alias{ncol,DataFrame-method} \alias{rownames,DataFrame-method} \alias{colnames,DataFrame-method} \alias{rownames<-,DataFrame-method} \alias{colnames<-,DataFrame-method} % constructor \alias{DataFrame} % subsetting \alias{[,DataFrame-method} \alias{[<-,DataFrame-method} \alias{[[<-,DataFrame-method} % coercion \alias{as.data.frame.DataFrame} \alias{as.data.frame,DataFrame-method} \alias{as.matrix,DataFrame-method} \alias{coerce,matrix,DataFrame-method} \alias{coerce,vector,DataFrame-method} \alias{coerce,list,DataFrame-method} \alias{coerce,integer,DataFrame-method} \alias{coerce,Vector,DataFrame-method} \alias{coerce,data.frame,DataFrame-method} \alias{coerce,NULL,DataFrame-method} \alias{coerce,table,DataFrame-method} \alias{coerce,AsIs,DataFrame-method} \alias{coerce,DataFrame,data.frame-method} \alias{coerce,xtabs,DataFrame-method} \alias{coerce,ANY,DataFrame-method} \alias{coerce,SimpleList,DataFrame-method} \alias{coerce,ANY,AsIs-method} % combining \alias{cbind,DataFrame-method} \alias{rbind,DataFrame-method} \title{DataFrame objects} \description{ The \code{DataFrame} class extends the \link{DataTable} virtual class and supports the storage of any type of object (with \code{length} and \code{[} methods) as columns. } \details{ On the whole, the \code{DataFrame} behaves very similarly to \code{data.frame}, in terms of construction, subsetting, splitting, combining, etc. The most notable exception is that the row names are optional. This means calling \code{rownames(x)} will return \code{NULL} if there are no row names. Of course, it could return \code{seq_len(nrow(x))}, but returning \code{NULL} informs, for example, combination functions that no row names are desired (they are often a luxury when dealing with large data). As \code{DataFrame} derives from \code{\linkS4class{Vector}}, it is possible to set an \code{annotation} string. Also, another \code{DataFrame} can hold metadata on the columns. For a class to be supported as a column, it must have \code{length} and \code{[} methods, where \code{[} supports subsetting only by \code{i} and respects \code{drop=FALSE}. Optionally, a method may be defined for the \code{showAsCell} generic, which should return a vector of the same length as the subset of the column passed to it. This vector is then placed into a \code{data.frame} and converted to text with \code{format}. Thus, each element of the vector should be some simple, usually character, representation of the corresponding element in the column. } \section{Constructor}{ \describe{\code{DataFrame(..., row.names = NULL, check.names = TRUE)}: Constructs a \code{DataFrame} in similar fashion to \code{\link{data.frame}}. Each argument in \code{...} is coerced to a \code{DataFrame} and combined column-wise. No special effort is expended to automatically determine the row names from the arguments. The row names should be given in \code{row.names}; otherwise, there are no row names. This is by design, as row names are normally undesirable when data is large. If \code{check.names} is \code{TRUE}, the column names will be checked for syntactic validity and made unique, if necessary. To store an object of a class that does not support coercion to \code{DataFrame}, wrap it in \code{I()}. The class must still have methods for \code{length} and \code{[}. } } \section{Accessors}{ In the following code snippets, \code{x} is a \code{DataFrame}. \describe{ \item{}{\code{dim(x)}: Get the length two integer vector indicating in the first and second element the number of rows and columns, respectively. } \item{}{\code{dimnames(x)}, \code{dimnames(x) <- value}: Get and set the two element list containing the row names (character vector of length \code{nrow(x)} or \code{NULL}) and the column names (character vector of length \code{ncol(x)}). } } } \section{Coercion}{ \describe{ \item{}{\code{as(from, "DataFrame")}: By default, constructs a new \code{DataFrame} with \code{from} as its only column. If \code{from} is a \code{matrix} or \code{data.frame}, all of its columns become columns in the new \code{DataFrame}. If \code{from} is a list, each element becomes a column, recycling as necessary. Note that for the \code{DataFrame} to behave correctly, each column object must support element-wise subsetting via the \code{[} method and return the number of elements with \code{length}. It is recommended to use the \code{DataFrame} constructor, rather than this interface. } \item{}{\code{as.list(x)}: Coerces \code{x}, a \code{DataFrame}, to a \code{list}. } \item{}{\code{as.data.frame(x, row.names=NULL, optional=FALSE)}: Coerces \code{x}, a \code{DataFrame}, to a \code{data.frame}. Each column is coerced to a \code{data.frame} and then column bound together. If \code{row.names} is \code{NULL}, they are retrieved from \code{x}, if it has any. Otherwise, they are inferred by the \code{data.frame} constructor. NOTE: conversion of \code{x} to a \code{data.frame} is not supported if \code{x} contains any \code{list}, \code{SimpleList}, or \code{CompressedList} columns. } \item{}{\code{as(from, "data.frame")}: Coerces a \code{DataFrame} to a \code{data.frame} by calling \code{as.data.frame(from)}. } \item{}{\code{as.matrix(x)}: Coerces the \code{DataFrame} to a \code{matrix}, if possible. } } } \section{Subsetting}{ In the following code snippets, \code{x} is a \code{DataFrame}. \describe{ \item{}{\code{x[i,j,drop]}: Behaves very similarly to the \code{\link{[.data.frame}} method, except \code{i} can be a logical \code{Rle} object and subsetting by \code{matrix} indices is not supported. Indices containing \code{NA}'s are also not supported. } \item{}{\code{x[i,j] <- value}: Behaves very similarly to the \code{\link{[<-.data.frame}} method. } \item{}{\code{x[[i]]}: Behaves very similarly to the \code{\link{[[.data.frame}} method, except arguments \code{j} and \code{exact} are not supported. Column name matching is always exact. Subsetting by matrices is not supported. } \item{}{\code{x[[i]] <- value}: Behaves very similarly to the \code{\link{[[<-.data.frame}} method, except argument \code{j} is not supported. } } } \section{Combining}{ In the following code snippets, \code{x} is a \code{DataFrame}. \describe{ \item{}{ \code{rbind(...)}: Creates a new \code{DataFrame} by combining the rows of the \code{DataFrame} objects in \code{...}. Very similar to \code{\link{rbind.data.frame}}, except in the handling of row names. If all elements have row names, they are concatenated and made unique. Otherwise, the result does not have row names. Currently, factors are not handled well (their levels are dropped). This is not a high priority until there is an \code{XFactor} class. } \item{}{ \code{cbind(...)}: Creates a new \code{DataFrame} by combining the columns of the \code{DataFrame} objects in \code{...}. Very similar to \code{\link{cbind.data.frame}}, except row names, if any, are dropped. Consider the \code{DataFrame} as an alternative that allows one to specify row names. } } } \author{Michael Lawrence} \seealso{ \itemize{ \item \link{DataTable} and \link{SimpleList} which DataFrame extends directly. } } \examples{ score <- c(1L, 3L, NA) counts <- c(10L, 2L, NA) row.names <- c("one", "two", "three") df <- DataFrame(score) # single column df[["score"]] df <- DataFrame(score, row.names = row.names) #with row names rownames(df) df <- DataFrame(vals = score) # explicit naming df[["vals"]] # arrays ary <- array(1:4, c(2,1,2)) sw <- DataFrame(I(ary)) # a data.frame sw <- DataFrame(swiss) as.data.frame(sw) # swiss, without row names # now with row names sw <- DataFrame(swiss, row.names = rownames(swiss)) as.data.frame(sw) # swiss # subsetting sw[] # identity subset sw[,] # same sw[NULL] # no columns sw[,NULL] # no columns sw[NULL,] # no rows ## select columns sw[1:3] sw[,1:3] # same as above sw[,"Fertility"] sw[,c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE)] ## select rows and columns sw[4:5, 1:3] sw[1] # one-column DataFrame ## the same sw[, 1, drop = FALSE] sw[, 1] # a (unnamed) vector sw[[1]] # the same sw[["Fertility"]] sw[["Fert"]] # should return 'NULL' sw[1,] # a one-row DataFrame sw[1,, drop=TRUE] # a list ## duplicate row, unique row names are created sw[c(1, 1:2),] ## indexing by row names sw["Courtelary",] subsw <- sw[1:5,1:4] subsw["C",] # partially matches ## row and column names cn <- paste("X", seq_len(ncol(swiss)), sep = ".") colnames(sw) <- cn colnames(sw) rn <- seq(nrow(sw)) rownames(sw) <- rn rownames(sw) ## column replacement df[["counts"]] <- counts df[["counts"]] df[[3]] <- score df[["X"]] df[[3]] <- NULL # deletion } \keyword{classes} \keyword{methods} S4Vectors/man/DataTable-class.Rd0000644000175100017510000001547012607264537017437 0ustar00biocbuildbiocbuild\name{DataTable-class} \docType{class} \alias{class:DataTable} \alias{DataTable-class} \alias{DataTable} \alias{NROW,DataTable-method} \alias{NCOL,DataTable-method} \alias{dim,DataTable-method} \alias{ROWNAMES} \alias{ROWNAMES,ANY-method} \alias{ROWNAMES,DataTable-method} \alias{dimnames,DataTable-method} \alias{dimnames<-,DataTable-method} \alias{subset,DataTable-method} \alias{na.omit,DataTable-method} \alias{na.exclude,DataTable-method} \alias{is.na,DataTable-method} \alias{complete.cases,DataTable-method} \alias{cbind,DataTable-method} \alias{rbind,DataTable-method} \alias{merge,DataTable,DataTable-method} \alias{merge,data.frame,DataTable-method} \alias{merge,DataTable,data.frame-method} \alias{by,DataTable-method} \alias{duplicated,DataTable-method} \alias{duplicated.DataTable} \alias{unique,DataTable-method} \alias{unique.DataTable} \alias{as.env} \alias{as.env,NULL-method} \alias{as.env,DataTable-method} \alias{show,DataTable-method} \alias{xtabs,DataTable-method} \title{DataTable objects} \description{ DataTable is an API only (i.e. virtual class with no slots) for accessing objects with a rectangular shape like \link{DataFrame} or \link[IRanges]{RangedData} objects. It mimics the API for standard \link{data.frame} objects. } \section{Accessors}{ In the following code snippets, \code{x} is a \code{DataTable}. \describe{ \item{}{ \code{nrow(x)}, \code{ncol(x)}: Get the number of rows and columns, respectively. } \item{}{ \code{NROW(x)}, \code{NCOL(x)}: Same as \code{nrow(x)} and \code{ncol(x)}, respectively. } \item{}{ \code{dim(x)}: Length two integer vector defined as \code{c(nrow(x), ncol(x))}. } \item{}{ \code{rownames(x)}, \code{colnames(x)}: Get the names of the rows and columns, respectively. } \item{}{ \code{dimnames(x)}: Length two list of character vectors defined as \code{list(rownames(x), colnames(x))}. } } } \section{Subsetting}{ In the code snippets below, \code{x} is a DataTable object. \describe{ \item{}{ \code{x[i, j, drop=TRUE]}: Return a new DataTable object made of the selected rows and columns. For single column selection, the \code{drop} argument specifies whether or not to coerce the returned sequence to a standard vector. } \item{}{ \code{head(x, n=6L)}: If \code{n} is non-negative, returns the first n rows of the DataTable object. If \code{n} is negative, returns all but the last \code{abs(n)} rows of the DataTable object. } \item{}{ \code{tail(x, n=6L)}: If \code{n} is non-negative, returns the last n rows of the DataTable object. If \code{n} is negative, returns all but the first \code{abs(n)} rows of the DataTable object. } \item{}{ \code{subset(x, subset, select, drop=FALSE)}: Return a new DataTable object using: \describe{ \item{subset}{logical expression indicating rows to keep, where missing values are taken as FALSE.} \item{select}{expression indicating columns to keep.} \item{drop}{passed on to \code{[} indexing operator.} } } \item{}{ \code{\link[stats:na.fail]{na.omit}(object)}: Returns a subset with incomplete cases removed. } \item{}{ \code{\link[stats:na.fail]{na.exclude}(object)}: Returns a subset with incomplete cases removed (but to be included with NAs in statistical results). } \item{}{ \code{\link[base:NA]{is.na}(x)}: Returns a logical matrix indicating which cells are missing. } \item{}{ \code{\link[stats]{complete.cases}(x)}: Returns a logical vector identifying which cases have no missing values. } } } \section{Combining}{ In the code snippets below, \code{x} is a DataTable object. \describe{ \item{}{ \code{cbind(...)}: Creates a new \code{DataTable} by combining the columns of the \code{DataTable} objects in \code{...}. } \item{}{ \code{rbind(...)}: Creates a new \code{DataTable} by combining the rows of the \code{DataTable} objects in \code{...}. } \item{}{ \code{merge(x, y, ...)}: Merges two \code{DataTable} objects \code{x} and \code{y}, with arguments in \code{...} being the same as those allowed by the base \code{\link{merge}}. It is allowed for either \code{x} or \code{y} to be a \code{data.frame}. } } } \section{Looping}{ In the code snippets below, \code{x} is a DataTable object. \describe{ \item{}{ \code{by(data, INDICES, FUN, ..., simplify = TRUE)}: Apply \code{FUN} to each group of \code{data}, a \code{DataTable}, formed by the factor (or list of factors) \code{INDICES}. Exactly the same contract as \code{\link{as.data.frame}}. } } } \section{Utilities}{ \describe{ \item{}{\code{duplicated(x)}: Returns a logical vector indicating the rows that are identical to a previous row. } \item{}{\code{unique(x)}: Returns a new \code{DataTable} after removing the duplicated rows from \code{x}. } \item{}{ \code{show(x)}: By default the \code{show} method displays 5 head and 5 tail lines. The number of lines can be altered by setting the global options \code{showHeadLines} and \code{showTailLines}. If the object length is less than the sum of the options, the full object is displayed. These options affect GRanges, GAlignments, Ranges, DataTable and XString objects. } } } \section{Coercion}{ \describe{ \item{}{\code{as.env(x, enclos = parent.frame())}: Creates an environment from \code{x} with a symbol for each \code{colnames(x)}. The values are not actually copied into the environment. Rather, they are dynamically bound using \code{\link{makeActiveBinding}}. This prevents unnecessary copying of the data from the external vectors into R vectors. The values are cached, so that the data is not copied every time the symbol is accessed. } } } \section{Statistical modeling with DataTable}{ A number of wrappers are implemented for performing statistical procedures, such as model fitting, with DataTable objects. \subsection{Tabulation}{ \describe{ \item{}{\code{xtabs(formula = ~., data, subset, na.action, exclude = c(NA, NaN), drop.unused.levels = FALSE)}: Like the original \code{\link{xtabs}}, except \code{data} is a \code{DataTable}. } } } } \seealso{ \itemize{ \item \link{DataFrame} for an implementation that mimics \code{data.frame}. \item \link{data.frame} } } \examples{ showClass("DataTable") # shows (some of) the known subclasses library(IRanges) df <- DataFrame(as.data.frame(UCBAdmissions)) xtabs(Freq ~ Gender + Admit, df) } \keyword{methods} \keyword{classes} S4Vectors/man/FilterMatrix-class.Rd0000644000175100017510000000367712607264537020236 0ustar00biocbuildbiocbuild\name{FilterMatrix-class} \docType{class} \alias{FilterMatrix-class} % accessors \alias{filterRules,FilterMatrix-method} % subsetting \alias{[,FilterMatrix-method} % splitting and combining \alias{cbind,FilterMatrix-method} \alias{rbind,FilterMatrix-method} % constructor \alias{FilterMatrix} % utilities \alias{show,FilterMatrix-method} \alias{summary,FilterMatrix-method} \title{Matrix for Filter Results} \description{A \code{FilterMatrix} object is a matrix meant for storing the logical output of a set of \code{\linkS4class{FilterRules}}, where each rule corresponds to a column. The \code{FilterRules} are stored within the \code{FilterMatrix} object, for the sake of provenance. In general, a \code{FilterMatrix} behaves like an ordinary \code{\link{matrix}}. } \section{Accessor methods}{ In the code snippets below, \code{x} is a \code{FilterMatrix} object. \describe{ \item{}{\code{filterRules(x)}: Get the \code{FilterRules} corresponding to the columns of the matrix. } } } \section{Constructor}{ \describe{ \item{}{ \code{FilterMatrix(matrix, filterRules)}: Constructs a \code{FilterMatrix}, from a given \code{matrix} and \code{filterRules}. Not usually called by the user, see \code{\link{evalSeparately}}. } } } \section{Utilities}{ \describe{ \item{}{ \code{summary(object, discarded = FALSE, percent = FALSE)}: Returns a numeric vector containing the total number of records (\code{nrow}), the number passed by each filter, and the number of records that passed every filter. If \code{discarded} is \code{TRUE}, then the numbers are inverted (i.e., the values are subtracted from the number of rows). If \code{percent} is \code{TRUE}, then the numbers are percent of total. } } } \author{ Michael Lawrence } \seealso{ \code{\link{evalSeparately}} is the typical way to generate this object. } \keyword{classes} \keyword{methods} S4Vectors/man/FilterRules-class.Rd0000644000175100017510000002302212607264536020045 0ustar00biocbuildbiocbuild\name{FilterRules-class} \docType{class} \alias{class:expressionORfunction} \alias{expressionORfunction-class} \alias{expressionORfunction} \alias{class:FilterRules} \alias{FilterRules-class} % accessors \alias{active} \alias{active,FilterRules-method} \alias{active<-} \alias{active<-,FilterRules-method} % subsetting \alias{[,FilterRules-method} \alias{[[<-,FilterRules-method} \alias{subsetByFilter} \alias{subsetByFilter,ANY,FilterRules-method} % splitting and combining \alias{append,FilterRules,FilterRules-method} \alias{c,FilterRules-method} % evaluating \alias{eval,FilterRules,ANY-method} \alias{evalSeparately} \alias{evalSeparately,FilterRules-method} % constructor \alias{FilterRules} % general \alias{summary,FilterRules-method} % filter closures \alias{params} \alias{params,FilterClosure-method} \alias{coerce,standardGeneric,FilterClosure-method} \alias{coerce,function,FilterClosure-method} \alias{show,FilterClosure-method} \title{Collection of Filter Rules} \description{A \code{FilterRules} object is a collection of filter rules, which can be either \code{expression} or \code{function} objects. Rules can be disabled/enabled individually, facilitating experimenting with different combinations of filters.} \details{ It is common to split a dataset into subsets during data analysis. When data is large, however, representing subsets (e.g. by logical vectors) and storing them as copies might become too costly in terms of space. The \code{FilterRules} class represents subsets as lightweight \code{expression} and/or \code{function} objects. Subsets can then be calculated when needed (on the fly). This avoids copying and storing a large number of subsets. Although it might take longer to frequently recalculate a subset, it often is a relatively fast operation and the space savings tend to be more than worth it when data is large. Rules may be either expressions or functions. Evaluating an expression or invoking a function should result in a logical vector. Expressions are often more convenient, but functions (i.e. closures) are generally safer and more powerful, because the user can specify the enclosing environment. If a rule is an expression, it is evaluated inside the \code{envir} argument to the \code{eval} method (see below). If a function, it is invoked with \code{envir} as its only argument. See examples. } \section{Accessor methods}{ In the code snippets below, \code{x} is a \code{FilterRules} object. \describe{ \item{}{\code{active(x)}: Get the logical vector of length \code{length(x)}, where \code{TRUE} for an element indicates that the corresponding rule in \code{x} is active (and inactive otherwise). Note that \code{names(active(x))} is equal to \code{names(x)}.} \item{}{\code{active(x) <- value}: Replace the active state of the filter rules. If \code{value} is a logical vector, it should be of length \code{length(x)} and indicate which rules are active. Otherwise, it can be either numeric or character vector, in which case it sets the indicated rules (after dropping NA's) to active and all others to inactive. See examples.} } } \section{Constructor}{ \describe{ \item{}{ \code{FilterRules(exprs = list(), ..., active = TRUE)}: Constructs a \code{FilterRules} with the rules given in the list \code{exprs} or in \code{...}. The initial active state of the rules is given by \code{active}, which is recycled as necessary. Elements in \code{exprs} may be either character (parsed into an expression), a language object (coerced to an expression), an expression, or a function that takes at least one argument. \strong{IMPORTANTLY}, all arguments in \code{...} are \strong{\code{quote()}}'d and then coerced to an expression. So, for example, character data is only parsed if it is a literal. The names of the filters are taken from the names of \code{exprs} and \code{...}, if given. Otherwise, the character vectors take themselves as their name and the others are deparsed (before any coercion). Thus, it is recommended to always specify meaningful names. In any case, the names are made valid and unique. } } } \section{Subsetting and Replacement}{ In the code snippets below, \code{x} is a \code{FilterRules} object. \describe{ \item{}{ \code{x[i]}: Subsets the filter rules using the same interface as for \code{\linkS4class{Vector}}. } \item{}{ \code{x[[i]]}: Extracts an expression or function via the same interface as for \code{\linkS4class{List}}. } \item{}{ \code{x[[i]] <- value}: The same interface as for \code{\linkS4class{List}}. The default active state for new rules is \code{TRUE}. } } } \section{Combining}{ In the code snippets below, \code{x} is a \code{FilterRules} object. \describe{ \item{}{\code{append(x, values, after = length(x))}: Appends the \code{values} \code{FilterRules} instance onto \code{x} at the index given by \code{after}. } \item{}{\code{c(x, ..., recursive = FALSE)}: Concatenates the \code{FilterRule} instances in \code{...} onto the end of \code{x}. } } } \section{Evaluating}{ \describe{ \item{}{ \code{eval(expr, envir = parent.frame(), enclos = if (is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv())}: Evaluates a \code{FilterRules} instance (passed as the \code{expr} argument). Expression rules are evaluated in \code{envir}, while function rules are invoked with \code{envir} as their only argument. The evaluation of a rule should yield a logical vector. The results from the rule evaluations are combined via the AND operation (i.e. \code{&}) so that a single logical vector is returned from \code{eval}. } \item{}{ \code{evalSeparately(expr, envir = parent.frame(), enclos = if (is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv())}: Evaluates separately each rule in a \code{FilterRules} instance (passed as the \code{expr} argument). Expression rules are evaluated in \code{envir}, while function rules are invoked with \code{envir} as their only argument. The evaluation of a rule should yield a logical vector. The results from the rule evaluations are combined into a logical matrix, with a column for each rule. This is essentially the parallel evaluator, while \code{eval} is the serial evaluator. } \item{}{ \code{subsetByFilter(x, filter)}: Evaluates \code{filter} on \code{x} and uses the result to subset \code{x}. The result contains only the elements in \code{x} for which \code{filter} evaluates to \code{TRUE}. } \item{}{\code{summary(object, subject)}: Returns an integer vector with the number of elements in \code{subject} that pass each rule in \code{object}, along with a count of the elements that pass all filters. } } } \section{Filter Closures}{ When a closure (function) is included as a filter in a \code{FilterRules} object, it is converted to a \code{FilterClosure}, which is currently nothing more than a marker class that extends \code{function}. When a \code{FilterClosure} filter is extracted, there are some accessors and utilities for manipulating it: \describe{ \item{}{\code{params}: Gets a named list of the objects that are present in the enclosing environment (without inheritance). This assumes that a filter is constructed via a constructor function, and the objects in the frame of the constructor (typically, the formal arguments) are the parameters of the filter. } } } \author{ Michael Lawrence } \seealso{ \code{\link[IRanges]{rdapply}} in the \pkg{IRanges} package, which accepts a \code{FilterRules} instance to filter each space before invoking the user function. } \examples{ ## constructing a FilterRules instance ## an empty set of filters filters <- FilterRules() ## as a simple character vector filts <- c("peaks", "promoters") filters <- FilterRules(filts) active(filters) # all TRUE ## with functions and expressions filts <- list(peaks = expression(peaks), promoters = expression(promoters), find_eboxes = function(rd) rep(FALSE, nrow(rd))) filters <- FilterRules(filts, active = FALSE) active(filters) # all FALSE ## direct, quoted args (character literal parsed) filters <- FilterRules(under_peaks = peaks, in_promoters = "promoters") filts <- list(under_peaks = expression(peaks), in_promoters = expression(promoters)) ## specify both exprs and additional args filters <- FilterRules(filts, diffexp = de) filts <- c("promoters", "peaks", "introns") filters <- FilterRules(filts) ## evaluation df <- DataFrame(peaks = c(TRUE, TRUE, FALSE, FALSE), promoters = c(TRUE, FALSE, FALSE, TRUE), introns = c(TRUE, FALSE, FALSE, FALSE)) eval(filters, df) fm <- evalSeparately(filters, df) identical(filterRules(fm), filters) summary(fm) summary(fm, percent = TRUE) fm <- evalSeparately(filters, df, serial = TRUE) ## set the active state directly active(filters) <- FALSE # all FALSE active(filters) <- TRUE # all TRUE active(filters) <- c(FALSE, FALSE, TRUE) active(filters)["promoters"] <- TRUE # use a filter name ## toggle the active state by name or index active(filters) <- c(NA, 2) # NA's are dropped active(filters) <- c("peaks", NA) } \keyword{classes} \keyword{methods} S4Vectors/man/Hits-class.Rd0000644000175100017510000001532512607264536016523 0ustar00biocbuildbiocbuild\name{Hits-class} \docType{class} \alias{class:Hits} \alias{Hits-class} \alias{Hits} % accessors \alias{queryHits} \alias{queryHits,Hits-method} \alias{subjectHits} \alias{subjectHits,Hits-method} \alias{queryLength} \alias{queryLength,Hits-method} \alias{subjectLength} \alias{subjectLength,Hits-method} \alias{countQueryHits} \alias{countQueryHits,Hits-method} \alias{countSubjectHits} \alias{countSubjectHits,Hits-method} % coercion \alias{as.matrix,Hits-method} \alias{as.table,Hits-method} % subsetting \alias{extractROWS,Hits-method} % displaying \alias{show,Hits-method} % other \alias{t,Hits-method} \alias{remapHits} \title{Hits objects} \description{ The \code{Hits} class stores a set of hits between 2 vector-like objects, one called the "query" and the other one the "subject". For example, the \code{\link[IRanges]{findOverlaps}} function, defined and documented in the \pkg{IRanges} package, returns the hits between the \code{query} and \code{subject} arguments in a \code{Hits} object. } \details{ The \code{as.matrix} method coerces a \code{Hits} object to a two column \code{matrix} with one row for each hit, where the value in the first column is the index of an element in the query and the value in the second column is the index of an element in the subject. The \code{as.table} method counts the number of hits for each query element and outputs the counts as a \code{table}. To transpose a \code{Hits} \code{x}, so that the subject and query are interchanged, call \code{t(x)}. This allows, for example, counting the number of hits for each subject element using \code{as.table}. } \section{Coercion}{ In the code snippets below, \code{x} is a \code{Hits} object. \describe{ \item{}{\code{as.matrix(x)}: Coerces \code{x} to a two column integer matrix, with each row representing a hit between a query index (first column) and subject index (second column). } \item{}{\code{as.table(x)}: counts the number of hits for each query element in \code{x} and outputs the counts as a \code{table}. } \item{}{\code{t(x)}: Interchange the query and subject in \code{x}, returns a transposed \code{Hits}.} } } \section{Subsetting}{ \describe{ \item{}{\code{x[i]}: Subset the Hits object.} } } \section{Accessors}{ \describe{ \item{}{\code{length(x)}: get the number of hits} \item{}{\code{queryHits(x)}: Equivalent to \code{as.data.frame(x)[[1]]}.} \item{}{\code{subjectHits(x)}: Equivalent to \code{as.data.frame(x)[[2]]}.} \item{}{\code{queryLength(x)}, \code{nrow(x)}: get the number of elements in the query} \item{}{\code{subjectLength(x)}, \code{ncol(x)}: get the number of elements in the subject} \item{}{\code{countQueryHits(x)}: Counts the number of hits for each query, returning an integer vector. } \item{}{\code{countSubjectHits(x)}: Counts the number of hits for each subject, returning an integer vector. } } } \section{Other operations}{ \describe{ \item{}{\code{remapHits(x, query.map=NULL, new.queryLength=NA, subject.map=NULL, new.subjectLength=NA)}: Remaps the hits in \code{x} thru a "query map" and/or a "subject map" map. The query hits are remapped thru the "query map", which is specified via the \code{query.map} and \code{new.queryLength} arguments. The subject hits are remapped thru the "subject map", which is specified via the \code{subject.map} and \code{new.subjectLength} arguments. The "query map" is conceptually a function (in the mathematical sense) and is also known as the "mapping function". It must be defined on the 1..M interval and take values in the 1..N interval, where N is \code{queryLength(x)} and M is the value specified by the user via the \code{new.queryLength} argument. Note that this mapping function doesn't need to be injective or surjective. Also it is not represented by an R function but by an integer vector of length M with no NAs. More precisely \code{query.map} can be NULL (identity map), or a vector of \code{queryLength(x)} non-NA integers that are >= 1 and <= \code{new.queryLength}, or a factor of length \code{queryLength(x)} with no NAs (a factor is treated as an integer vector, and, if missing, \code{new.queryLength} is taken to be its number of levels). Note that a factor will typically be used to represent a mapping function that is not injective. The same apply to the "subject map". \code{remapHits} returns a Hits object where all the query and subject hits (accessed with \code{queryHits} and \code{subjectHits}, respectively) have been remapped thru the 2 specified maps. This remapping is actually only the 1st step of the transformation, and is followed by 2 additional steps: (2) the removal of duplicated hits, and (3) the reordering of the hits (first by query hits, then by subject hits). Note that if the 2 maps are injective then the remapping won't introduce duplicated hits, so, in that case, step (2) is a no-op (but is still performed). Also if the "query map" is strictly ascending and the "subject map" ascending then the remapping will preserve the order of the hits, so, in that case, step (3) is also a no-op (but is still performed). } } } \author{Michael Lawrence and H. Pages} \seealso{ \itemize{ \item \link{Hits-comparison} for comparing and ordering hits. \item \code{\link[IRanges]{findOverlaps}} in the \pkg{IRanges} package, which generates an instance of this class. \item \link[IRanges]{Hits-examples} in the \pkg{IRanges} package, for some examples of Hits object basic manipulation. \item \link[IRanges]{setops-methods} in the \pkg{IRanges} package, for set operations on Hits objects. } } \examples{ x <- c("a", "b", "a", "c", "d") y <- c("a", "e", "d", "a", "a", "d") hits <- findMatches(x, y) hits ## --------------------------------------------------------------------- ## selectHits() ## --------------------------------------------------------------------- selectHits(hits, select="all") # no-op selectHits(hits, select="first") selectHits(hits, select="last") selectHits(hits, select="arbitrary") selectHits(hits, select="count") ## --------------------------------------------------------------------- ## remapHits() ## --------------------------------------------------------------------- query.map=factor(c(a="A", b="B", c="C", d="D")[x] , levels=LETTERS[1:4]) remapHits(hits, query.map=query.map) ## See ?`Hits-examples` in the IRanges package for more examples of basic ## manipulation of Hits objects. } \keyword{methods} \keyword{classes} S4Vectors/man/Hits-comparison.Rd0000644000175100017510000001063712607264536017571 0ustar00biocbuildbiocbuild\name{Hits-comparison} \alias{Hits-comparison} \alias{compare,Hits,Hits-method} \alias{match,Hits,Hits-method} \alias{order,Hits-method} \title{Comparing and ordering hits} \description{ \code{==}, \code{!=}, \code{<=}, \code{>=}, \code{<}, \code{>}, \code{match()}, \code{\%in\%}, \code{order()}, \code{sort()}, and \code{rank()} can be used on \link{Hits} objects to compare and order hits. Note that only the \code{"compare"}, \code{"match"}, and \code{"order"} methods are actually defined for \link{Hits} objects. This is all what is needed to make all the other comparing and ordering operations (i.e. \code{==}, \code{!=}, \code{<=}, \code{>=}, \code{<}, \code{>}, \code{\%in\%}, \code{sort()}, and \code{rank()}) work on these objects (see \code{?`\link{Vector-comparison}`} for more information about this). } \usage{ \S4method{compare}{Hits,Hits}(x, y) \S4method{match}{Hits,Hits}(x, table, nomatch=NA_integer_, incomparables=NULL, method=c("auto", "quick", "hash")) \S4method{order}{Hits}(..., na.last=TRUE, decreasing=FALSE) } \arguments{ \item{x, y, table}{ \emph{Compatible} \link{Hits} objects, that is, \link{Hits} objects with the same subject and query lengths. } \item{nomatch}{ The value to be returned in the case when no match is found. It is coerced to an \code{integer}. } \item{incomparables}{ Not supported. } \item{method}{ Use a Quicksort-based (\code{method="quick"}) or a hash-based (\code{method="hash"}) algorithm. The latter tends to give better performance, except maybe for some pathological input that we've not been able to determine so far. When \code{method="auto"} is specified, the most efficient algorithm will be used, that is, the hash-based algorithm if \code{length(x) <= 2^29}, otherwise the Quicksort-based algorithm. } \item{...}{ One or more \link{Hits} objects. The additional \link{Hits} objects are used to break ties. } \item{na.last}{ Ignored. } \item{decreasing}{ \code{TRUE} or \code{FALSE}. } } \details{ Only hits that belong to \link{Hits} objects with same subject and query lengths can be compared. Hits are ordered by query hit first, and then by subject hit. On a \link{Hits} object, \code{order}, \code{sort}, and \code{rank} are consistent with this order. \describe{ \item{}{ \code{compare(x, y)}: Performs element-wise (aka "parallel") comparison of 2 \link{Hits} objects \code{x} and \code{y}, that is, returns an integer vector where the i-th element is less than, equal to, or greater than zero if \code{x[i]} is considered to be respectively less than, equal to, or greater than \code{y[i]}. See \code{?`\link{Vector-comparison}`} for how \code{x} or \code{y} is recycled when the 2 objects don't have the same length. } \item{}{ \code{match(x, table, nomatch=NA_integer_, method=c("auto", "quick", "hash"))}: Returns an integer vector of the length of \code{x}, containing the index of the first matching hit in \code{table} (or \code{nomatch} if there is no matching hit) for each hit in \code{x}. } \item{}{ \code{order(...)}: Returns a permutation which rearranges its first argument (a \link{Hits} object) into ascending order, breaking ties by further arguments (also \link{Hits} objects). } } } \author{H. Pages} \seealso{ \itemize{ \item \link{Hits} objects. \item \link{Vector-comparison} for general information about comparing, ordering, and tabulating vector-like objects. } } \examples{ ## --------------------------------------------------------------------- ## A. ELEMENT-WISE (AKA "PARALLEL") COMPARISON OF 2 Hits OBJECTS ## --------------------------------------------------------------------- hits <- Hits(c(2, 4, 4, 4, 5, 5), c(3, 1, 3, 2, 3, 2), 6, 3) hits compare(hits, hits[3]) compare(hits[3], hits) hits == hits[3] hits != hits[3] hits >= hits[3] hits < hits[3] ## --------------------------------------------------------------------- ## B. match(), %in% ## --------------------------------------------------------------------- table <- hits[-c(1, 3)] match(hits, table) hits \%in\% table ## --------------------------------------------------------------------- ## C. order(), sort(), rank() ## --------------------------------------------------------------------- order(hits) sort(hits) rank(hits) } \keyword{methods} S4Vectors/man/Hits-setops.Rd0000644000175100017510000000442312607264536016730 0ustar00biocbuildbiocbuild\name{Hits-setops} \alias{Hits-setops} \alias{setops-methods} \alias{union,Hits,Hits-method} \alias{intersect,Hits,Hits-method} \alias{setdiff,Hits,Hits-method} \title{Set operations on Hits objects} \description{ Perform set operations on \link{Hits} objects. } \usage{ \S4method{union}{Hits,Hits}(x, y) \S4method{intersect}{Hits,Hits}(x, y) \S4method{setdiff}{Hits,Hits}(x, y) } \arguments{ \item{x, y}{ \emph{Compatible} \link{Hits} objects, that is, \link{Hits} objects with the same subject and query lengths. } } \details{ The \code{union}, \code{intersect}, and \code{setdiff} methods for \link{Hits} objects return a \link{Hits} object containing respectively the union, intersection, and (asymmetric!) difference of the sets of hits in \code{x} and \code{y}. These methods only work if \code{x} and \code{y} are \emph{compatible} \link{Hits} objects, that is, if they have the same subject and query lengths. } \value{ \code{union} returns a \link{Hits} object obtained by appending to \code{x} the hits in \code{y} that are not already in \code{x}. The original metadata columns are dropped. \code{intersect} returns a \link{Hits} object obtained by keeping only the hits in \code{x} that are also in \code{y}. \code{setdiff} returns a \link{Hits} object obtained by dropping from \code{x} the hits that are in \code{y}. Both \code{intersect} and \code{setdiff} propagate the metadata columns from \code{x}. } \author{H. Pages and Michael Lawrence} \seealso{ \itemize{ \item \link{Hits} objects. \item \link{Hits-comparison} for comparing and ordering hits. \item \code{BiocGenerics::\link[BiocGenerics]{union}}, \code{BiocGenerics::\link[BiocGenerics]{intersect}}, and \code{BiocGenerics::\link[BiocGenerics]{setdiff}} in the \pkg{BiocGenerics} package for general information about these generic functions. } } \examples{ x <- Hits(c(2, 4, 4, 4, 5, 5), c(3, 1, 3, 2, 3, 2), 6, 3) x y <- Hits(c(1, 3, 4, 4, 5, 5, 5), c(3, 3, 2, 1, 2, 1, 3), 6, 3) y union(x, y) union(y, x) # same hits as in union(x, y), but in different order intersect(x, y) intersect(y, x) # same hits as in intersect(x, y), but in # different order setdiff(x, y) setdiff(y, x) } \keyword{methods} S4Vectors/man/List-class.Rd0000644000175100017510000002350512607264536016526 0ustar00biocbuildbiocbuild\name{List-class} \docType{class} % List class, functions and methods: \alias{class:List} \alias{List-class} \alias{List} \alias{elementType} \alias{elementType,List-method} \alias{elementType,vector-method} \alias{elementLengths} \alias{elementLengths,ANY-method} \alias{elementLengths,List-method} \alias{isEmpty} \alias{isEmpty,ANY-method} \alias{isEmpty,List-method} \alias{coerce,List,list-method} \alias{as.list.List} \alias{coerce,ANY,List-method} \alias{coerce,integer,List-method} \alias{as.list,List-method} \alias{as.env,List-method} \alias{unlist,List-method} \alias{as.data.frame.List} \alias{as.data.frame,List-method} \alias{coerce,List,data.frame-method} \alias{[,List-method} \alias{[<-,List-method} \alias{[[,List-method} \alias{[[<-,List-method} \alias{$,List-method} \alias{$<-,List-method} \alias{show,List-method} \title{List objects} \description{ List objects are \link{Vector} objects with a \code{"[["}, \code{elementType} and \code{elementLengths} method. The List class serves a similar role as \link[base]{list} in base R. It adds one slot, the \code{elementType} slot, to the two slots shared by all \link{Vector} objects. The \code{elementType} slot is the preferred location for List subclasses to store the type of data represented in the sequence. It is designed to take a character of length 1 representing the class of the sequence elements. While the List class performs no validity checking based on \code{elementType}, if a subclass expects elements to be of a given type, that subclass is expected to perform the necessary validity checking. For example, the subclass \link[IRanges]{IntegerList} (defined in the \pkg{IRanges} package) has \code{elementType = "integer"} and its validity method checks if this condition is TRUE. To be functional, a class that inherits from List must define at least a \code{"[["} method (in addition to the minimum set of \link{Vector} methods). } \section{Construction}{ List objects are typically constructed using one of the 3 following methods: \itemize{ \item Use of a constructor function. Many constructor functions are provided for List objects e.g. \code{List}, \code{\link[IRanges]{IntegerList}}, \code{\link[IRanges]{RleList}}, \code{\link[IRanges]{RangesList}}, \code{\link[GenomicRanges]{GRangesList}}, etc... Which one to use depends on the particular type of List object to construct. The name of a constructor function is always the name of a valid class. If it's the name of a \emph{concrete} class (e.g. the \code{\link[GenomicRanges]{GRangesList}} constructor defined in the \pkg{GenomicRanges} package), then the constructor function returns an instance of that class. If it's the name of a \emph{virtual} class (e.g. the \code{List} constructor defined in this package, or the \code{\link[IRanges]{IntegerList}} or \code{\link[IRanges]{RleList}} or \code{\link[IRanges]{RangesList}} constructors defined in the \pkg{IRanges} package), then the returned object belongs to a concrete subclass of that virtual class. Which subclass exactly depends on each constructor function (see man page of a particular constructor function for the details). \item Coercion to List or to a List subclass. Many coercion methods are provided to turn any object into a List object. One general and convenient way to convert any vector-like object into a List is to call \code{as(x, "List")}. This will typically yield an object from a subclass of \link[IRanges]{CompressedList}. \item Use of \code{\link[IRanges]{extractList}}. This function, defined in the \pkg{IRanges} package, extracts user-specified groups of elements from a vector-like object and returns them in a List (or sometimes list) object. } } \section{Accessors}{ In the following code snippets, \code{x} is a List object. \describe{ \item{}{ \code{length(x)}: Get the number of list elements in \code{x}. } \item{}{ \code{names(x)}, \code{names(x) <- value}: Get or set the names of the elements in the List. } \item{}{ \code{mcols(x, use.names=FALSE)}, \code{mcols(x) <- value}: Get or set the metadata columns. See \link{Vector} man page for more information. } \item{}{ \code{elementType(x)}: Get the scalar string naming the class from which all elements must derive. } \item{}{ \code{elementLengths(x)}: Get the length (or nb of row for a matrix-like object) of each of the elements. Equivalent to \code{sapply(x, NROW)}. } \item{}{ \code{isEmpty(x)}: Returns a logical indicating either if the sequence has no elements or if all its elements are empty. } } } \section{Coercion}{ To List. \describe{ \item{}{ \code{as(x, "List")}: Converts a vector-like object into a List, usually a \link[IRanges]{CompressedList} derivative. One notable exception is when \code{x} is an ordinary list, in which case \code{as(x, "List")} returns a \link{SimpleList} derivative. To explicitly request a \link{SimpleList} derivative, call \code{as(x, "SimpleList")}. See \code{?\link[IRanges]{CompressedList}} (you might need to load the \pkg{IRanges} package first) and \code{?\link{SimpleList}} for more information about the CompressedList and SimpleList representations. } } From List. In the code snippets below, \code{x} is a List object. \describe{ \item{}{ \code{as.list(x, ...)}, \code{as(from, "list")}: Turns \code{x} into an ordinary list. } \item{}{ \code{unlist(x, recursive=TRUE, use.names=TRUE)}: Concatenates the elements of \code{x} into a single vector-like object (of class \code{elementType(x)}). } \item{}{ \code{as.data.frame(x, row.names=NULL, optional=FALSE , value.name="value", use.outer.mcols=FALSE, group_name.as.factor=FALSE, ...)}: Coerces a \code{List} to a \code{data.frame}. The result has the same length as unlisted \code{x} with two additional columns, \code{group} and \code{group_name}. \code{group} is an \code{integer} that indicates which list element the record came from. \code{group_name} holds the list name associated with each record; value is \code{character} by default and \code{factor} when \code{group_name.as.factor} is TRUE. When \code{use.outer.mcols} is TRUE the metadata columns on the outer list elements of \code{x} are replicated out and included in the \code{data.frame}. List objects that unlist to a single vector (column) are given the column name `value` by default. A custom name can be provided in \code{value.name}. Splitting values in the resulting \code{data.frame} by the original groups in \code{x} should be done using the \code{group} column as the \code{f} argument to \code{splitAsList}. To relist data, use \code{x} as the \code{skeleton} argument to \code{relist}. } \item{}{ \code{as.env(x, enclos = parent.frame())}: Creates an environment from \code{x} with a symbol for each \code{names(x)}. The values are not actually copied into the environment. Rather, they are dynamically bound using \code{\link{makeActiveBinding}}. This prevents unnecessary copying of the data from the external vectors into R vectors. The values are cached, so that the data is not copied every time the symbol is accessed. } } } \section{Subsetting}{ In the code snippets below, \code{x} is a List object. \describe{ \item{}{ \code{x[i]}: Return a new List object made of the list elements selected by subscript \code{i}. Subscript \code{i} can be of any type supported by subsetting of a Vector object (see \link{Vector} man page for the details), plus the following types: \link[IRanges]{IntegerList}, \link[IRanges]{LogicalList}, \link[IRanges]{CharacterList}, integer-\link[IRanges]{RleList}, logical-\link[IRanges]{RleList}, character-\link[IRanges]{RleList}, and \link[IRanges]{RangesList}. Those additional types perform subsetting within the list elements rather than across them. } \item{}{ \code{x[i] <- value}: Replacement version of \code{x[i]}. } \item{}{ \code{x[[i]]}: Return the selected list element \code{i}, where \code{i} is an numeric or character vector of length 1. } \item{}{ \code{x[[i]] <- value}: Replacement version of \code{x[[i]]}. } \item{}{ \code{x$name}, \code{x$name <- value}: Similar to \code{x[[name]]} and \code{x[[name]] <- value}, but \code{name} is taken literally as an element name. } } } \author{P. Aboyoun and H. Pages} \seealso{ \itemize{ \item \link{List-utils} for common operations on List objects. \item \link{Vector} objects for the parent class. \item The \link{SimpleList} class for a direct extension of the List class. \item The \link[IRanges]{CompressedList} class defined in the \pkg{IRanges} package for another direct extension of the List class. \item The \link[IRanges]{IntegerList}, \link[IRanges]{RleList}, and \link[IRanges]{IRanges} classes and constructors defined in the \pkg{IRanges} package for more examples of concrete List subclasses. \item The \link[IRanges]{extractList} function defined in the \pkg{IRanges} package for grouping elements of a vector-like object into a list-like object. } } \examples{ showClass("List") # shows (some of) the known subclasses } \keyword{methods} \keyword{classes} S4Vectors/man/List-utils.Rd0000644000175100017510000001400012607264536016547 0ustar00biocbuildbiocbuild\name{List-utils} \alias{List-utils} \alias{lapply,List-method} \alias{sapply,List-method} \alias{endoapply} \alias{endoapply,list-method} \alias{endoapply,data.frame-method} \alias{endoapply,List-method} \alias{mendoapply} \alias{mendoapply,list-method} \alias{mendoapply,data.frame-method} \alias{mendoapply,List-method} \alias{revElements} \alias{revElements,list-method} \alias{revElements,List-method} \alias{Reduce,List-method} \alias{Filter,List-method} \alias{Find,List-method} \alias{Map,List-method} \alias{Position,List-method} \alias{within,List-method} \title{Common operations on List objects} \description{ Various functions and methods for looping on \link{List} objects, functional programming on \link{List} objects, and evaluation of an expression in a \link{List} object. } \usage{ ## Looping on List objects: ## ------------------------ \S4method{lapply}{List}(X, FUN, ...) \S4method{sapply}{List}(X, FUN, ..., simplify=TRUE, USE.NAMES=TRUE) endoapply(X, FUN, ...) mendoapply(FUN, ..., MoreArgs=NULL) revElements(x, i) ## Functional programming methods for List objects: ## ------------------------------------------------ \S4method{Reduce}{List}(f, x, init, right=FALSE, accumulate=FALSE) \S4method{Filter}{List}(f, x) \S4method{Find}{List}(f, x, right=FALSE, nomatch=NULL) \S4method{Map}{List}(f, ...) \S4method{Position}{List}(f, x, right=FALSE, nomatch=NA_integer_) ## Evaluation of an expression in a List object: ## --------------------------------------------- \S4method{within}{List}(data, expr, ...) } \arguments{ \item{X, x}{ A list, data.frame or \link{List} object. } \item{FUN}{ The function to be applied to each element of \code{X} (for \code{endoapply}) or for the elements in \code{...} (for \code{mendoapply}). } \item{...}{ For \code{lapply}, \code{sapply}, and \code{endoapply}, optional arguments to \code{FUN}. For \code{mendoapply}, a set of list, data.frame or \link{List} objects to compute over. For \code{Map}, one or more \link{List} objects. (FIXME: Mixing \link{List} objects with ordinary lists doesn't seem to work properly at the moment.) } \item{simplify, USE.NAMES}{ See \code{?base::\link[base]{sapply}} for a description of these arguments. } \item{MoreArgs}{ A list of other arguments to \code{FUN}. } \item{i}{ Index specifying the elements to replace. Can be anything supported by \code{`[<-`}. } \item{f, init, right, accumulate, nomatch}{ See \code{?base::\link[base]{Reduce}} for a description of these arguments. } \item{data}{ A \link{List} object. } \item{expr}{ Expression to evaluate. } } \details{ \subsection{Looping on List objects}{ Like the standard \code{\link[base]{lapply}} function defined in the \pkg{base} package, the \code{lapply} method for \link{List} objects returns a list of the same length as \code{X}, with each element being the result of applying \code{FUN} to the corresponding element of \code{X}. Like the standard \code{\link[base]{sapply}} function defined in the \pkg{base} package, the \code{sapply} method for \link{List} objects is a user-friendly version of \code{lapply} by default returning a vector or matrix if appropriate. \code{endoapply} and \code{mendoapply} perform the endomorphic equivalents of \code{\link[base]{lapply}} and \code{\link[base]{mapply}} by returning objects of the same class as the inputs rather than a list. \code{revElements} is a convenient way to do \code{x[i] <- endoapply(x[i], rev)}. } \subsection{Functional programming methods for List objects}{ The R base package defines some higher-order functions that are commonly found in Functional Programming Languages. See \code{?base::\link[base]{Reduce}} for the details, and, in particular, for a description of their arguments. The \pkg{S4Vectors} package provides methods for \link{List} objects, so, in addition to be an ordinary vector or list, the \code{x} argument can also be a \link{List} object. } \subsection{Evaluation of an expression in a List object}{ \code{within} evaluates \code{expr} within \code{as.env(data)} via \code{eval(data)}. Similar to \code{with}, except assignments made during evaluation are taken as assignments into \code{data}, i.e., new symbols have their value appended to \code{data}, and assigning new values to existing symbols results in replacement. } } \value{ \code{endoapply} returns an object of the same class as \code{X}, each element of which is the result of applying \code{FUN} to the corresponding element of \code{X}. \code{mendoapply} returns an object of the same class as the first object specified in \code{\dots}, each element of which is the result of applying \code{FUN} to the corresponding elements of \code{\dots}. See \code{?base::\link[base]{Reduce}} for the value returned by the functional programming methods. See \code{?base::\link[base]{within}} for the value returned by \code{within}. } \author{P. Aboyoun} \seealso{ \itemize{ \item The \link{List} class. \item \code{base::\link[base]{lapply}} and \code{base::\link[base]{mapply}} for the default \code{lapply} and \code{mapply} methods. \item \code{base::\link[base]{Reduce}} for the default functional programming methods. \item \code{base::\link[base]{within}} for the default \code{within} method. } } \examples{ a <- data.frame(x = 1:10, y = rnorm(10)) b <- data.frame(x = 1:10, y = rnorm(10)) endoapply(a, function(x) (x - mean(x))/sd(x)) mendoapply(function(e1, e2) (e1 - mean(e1)) * (e2 - mean(e2)), a, b) library(IRanges) x <- IntegerList(a=1:3, b=16:11, c=22:21, d=31:36) x Reduce("+", x) Filter(is.unsorted, x) pos1 <- Position(is.unsorted, x) stopifnot(identical(Find(is.unsorted, x), x[[pos1]])) pos2 <- Position(is.unsorted, x, right=TRUE) stopifnot(identical(Find(is.unsorted, x, right=TRUE), x[[pos2]])) y <- x * 1000L Map("c", x, y) } \keyword{utilities} \keyword{methods} S4Vectors/man/Rle-class.Rd0000644000175100017510000003051512607264536016334 0ustar00biocbuildbiocbuild\name{Rle-class} \docType{class} \alias{class:Rle} \alias{Rle-class} \alias{Rle} \alias{Rle,missing,missing-method} \alias{Rle,vectorORfactor,missing-method} \alias{Rle,vectorORfactor,integer-method} \alias{Rle,vectorORfactor,numeric-method} \alias{runLength} \alias{runLength,Rle-method} \alias{runValue} \alias{runValue,Rle-method} \alias{nrun} \alias{nrun,Rle-method} \alias{start,Rle-method} \alias{end,Rle-method} \alias{width,Rle-method} \alias{runLength<-} \alias{runLength<-,Rle-method} \alias{runValue<-} \alias{runValue<-,Rle-method} \alias{as.vector,Rle-method} \alias{as.vectorORfactor} \alias{as.vectorORfactor,Rle-method} \alias{as.factor,Rle-method} \alias{as.data.frame.Rle} \alias{as.data.frame,Rle-method} \alias{as.list.Rle} \alias{as.list,Rle-method} \alias{coerce,Rle,list-method} \alias{coerce,vector,Rle-method} \alias{coerce,logical,Rle-method} \alias{coerce,integer,Rle-method} \alias{coerce,numeric,Rle-method} \alias{coerce,complex,Rle-method} \alias{coerce,character,Rle-method} \alias{coerce,raw,Rle-method} \alias{coerce,factor,Rle-method} \alias{coerce,Rle,vector-method} \alias{coerce,Rle,logical-method} \alias{coerce,Rle,integer-method} \alias{coerce,Rle,numeric-method} \alias{coerce,Rle,complex-method} \alias{coerce,Rle,character-method} \alias{coerce,Rle,raw-method} \alias{coerce,Rle,factor-method} \alias{coerce,Rle,data.frame-method} \alias{[,Rle-method} \alias{[<-,Rle-method} \alias{\%in\%,Rle,ANY-method} \alias{c,Rle-method} \alias{findRun} \alias{findRun,Rle-method} \alias{is.na,Rle-method} \alias{is.unsorted,Rle-method} \alias{length,Rle-method} \alias{match,Rle,ANY-method} \alias{rep,Rle-method} \alias{rep.int,Rle-method} \alias{rev.Rle} \alias{rev,Rle-method} \alias{shiftApply,Rle,Rle-method} \alias{show,Rle-method} \alias{showAsCell,Rle-method} \alias{order,Rle-method} \alias{sort.Rle} \alias{sort,Rle-method} \alias{table,Rle-method} \alias{unique.Rle} \alias{unique,Rle-method} \alias{duplicated,Rle-method} \alias{duplicated.Rle} \alias{setdiff,Rle,Rle-method} \alias{setdiff,ANY,Rle-method} \alias{setdiff,Rle,ANY-method} \alias{intersect,Rle,Rle-method} \alias{intersect,ANY,Rle-method} \alias{intersect,Rle,ANY-method} \alias{union,Rle,Rle-method} \alias{union,ANY,Rle-method} \alias{union,Rle,ANY-method} \title{Rle objects} \description{ The Rle class is a general container for storing an atomic vector that is stored in a run-length encoding format. It is based on the \code{\link[base]{rle}} function from the base package. } \section{Constructors}{ \describe{ \item{}{ \code{Rle(values)}: This constructor creates an Rle instances out of an atomic vector \code{values}. } \item{}{ \code{Rle(values, lengths)}: This constructor creates an Rle instances out of an atomic vector or factor object \code{values} and an integer or numeric vector \code{lengths} with all positive elements that represent how many times each value is repeated. The length of these two vectors must be the same. } \item{}{ \code{as(from, "Rle")}: This constructor creates an Rle instances out of an atomic vector \code{from}. } } } \section{Accessors}{ In the code snippets below, \code{x} is an Rle object: \describe{ \item{}{ \code{runLength(x)}: Returns the run lengths for \code{x}. } \item{}{ \code{runValue(x)}: Returns the run values for \code{x}. } \item{}{ \code{nrun(x)}: Returns the number of runs in \code{x}. } \item{}{ \code{start(x)}: Returns the starts of the runs for \code{x}. } \item{}{ \code{end(x)}: Returns the ends of the runs for \code{x}. } \item{}{ \code{width(x)}: Same as \code{runLength(x)}. } } } \section{Replacers}{ In the code snippets below, \code{x} is an Rle object: \describe{ \item{}{ \code{runLength(x) <- value}: Replaces \code{x} with a new Rle object using run values \code{runValue(x)} and run lengths \code{value}. } \item{}{ \code{runValue(x) <- value}: Replaces \code{x} with a new Rle object using run values \code{value} and run lengths \code{runLength(x)}. } } } \section{Coercion}{ In the code snippets below, \code{x} and \code{from} are Rle objects: \describe{ \item{}{ \code{as.vector(x, mode="any")}, \code{as(from, "vector")}: Creates an atomic vector based on the values contained in \code{x}. The vector will be coerced to the requested \code{mode}, unless \code{mode} is "any", in which case the most appropriate type is chosen. } \item{}{ \code{as.vectorORfactor(x)}: Creates an atomic vector or factor, based on the type of values contained in \code{x}. This is the most general way to decompress the Rle to a native R data structure. } \item{}{ \code{as.factor(x)}, \code{as(from, "factor")}: Creates a factor object based on the values contained in \code{x}. } \item{}{ \code{as.data.frame(x)}, \code{as(from, "data.frame")}: Creates a \code{data.frame} with a single column holding the result of \code{as.vector(x)}. } } } \section{General Methods}{ In the code snippets below, \code{x} is an Rle object: \describe{ \item{}{ \code{x[i, drop=getOption("dropRle", default=FALSE)]}: Subsets \code{x} by index \code{i}, where \code{i} can be positive integers, negative integers, a logical vector of the same length as \code{x}, an Rle object of the same length as \code{x} containing logical values, or an \link[IRanges]{IRanges} object. When \code{drop=FALSE} returns an Rle object. When \code{drop=TRUE}, returns an atomic vector. } \item{}{ \code{x[i] <- value}: Replaces elements in \code{x} specified by \code{i} with corresponding elements in \code{value}. Supports the same types for \code{i} as \code{x[i]}. } \item{}{ \code{x \%in\% table}: Returns a logical Rle representing set membership in \code{table}. } \item{}{ \code{append(x, values, after = length(x))}: Insert one Rle into another Rle. \describe{ \item{\code{values}}{the Rle to insert.} \item{\code{after}}{the subscript in \code{x} after which the values are to be inserted.} } } \item{}{ \code{c(x, ...)}: Combines a set of Rle objects. } \item{}{ \code{findRun(x, vec)}: Returns an integer vector indicating the run indices in Rle \code{vec} that are referenced by the indices in the integer vector \code{x}. } \item{}{ \code{head(x, n = 6L)}: If \code{n} is non-negative, returns the first n elements of \code{x}. If \code{n} is negative, returns all but the last \code{abs(n)} elements of \code{x}. } \item{}{ \code{is.na(x)}: Returns a logical Rle indicating with values are \code{NA}. } \item{}{ \code{is.unsorted(x, na.rm = FALSE, strictly = FALSE)}: Returns a logical value specifying if \code{x} is unsorted. \describe{ \item{\code{na.rm}}{remove missing values from check.} \item{\code{strictly}}{check for _strictly_ increasing values.} } } \item{}{ \code{length(x)}: Returns the underlying vector length of \code{x}. } \item{}{ \code{match(x, table, nomatch = NA_integer_, incomparables = NULL)}: Matches the values in \code{x} to \code{table}: \describe{ \item{\code{table}}{the values to be matched against.} \item{\code{nomatch}}{the value to be returned in the case when no match is found.} \item{\code{incomparables}}{a vector of values that cannot be matched. Any value in \code{x} matching a value in this vector is assigned the \code{nomatch} value.} } } \item{}{ \code{rep(x, times, length.out, each)}, \code{rep.int(x, times)}: Repeats the values in \code{x} through one of the following conventions: \describe{ \item{\code{times}}{Vector giving the number of times to repeat each element if of length \code{length(x)}, or to repeat the whole vector if of length 1.} \item{\code{length.out}}{Non-negative integer. The desired length of the output vector.} \item{\code{each}}{Non-negative integer. Each element of \code{x} is repeated \code{each} times.} } } \item{}{ \code{rev(x)}: Reverses the order of the values in \code{x}. } \item{}{ \code{shiftApply(SHIFT, X, Y, FUN, ..., OFFSET = 0L, simplify = TRUE, verbose = FALSE)}: Let \code{i} be the indices in \code{SHIFT}, \code{X_i = window(X, 1 + OFFSET, length(X) - SHIFT[i])}, and \code{Y_i = window(Y, 1 + SHIFT[i], length(Y) - OFFSET)}. Calculates the set of \code{FUN(X_i, Y_i, ...)} values and return the results in a convenient form: \describe{ \item{\code{SHIFT}}{A non-negative integer vector of shift values.} \item{\code{X}, \code{Y}}{The Rle objects to shift.} \item{\code{FUN}}{The function, found via \code{match.fun}, to be applied to each set of shifted vectors.} \item{\dots}{Further arguments for \code{FUN}.} \item{OFFSET}{A non-negative integer offset to maintain throughout the shift operations.} \item{\code{simplify}}{A logical value specifying whether or not the result should be simplified to a vector or matrix if possible.} \item{\code{verbose}}{A logical value specifying whether or not to print the \code{i} indices to track the iterations.} } } \item{}{ \code{show(object)}: Prints out the Rle object in a user-friendly way. } \item{}{ \code{order(..., na.last = TRUE, decreasing = FALSE)}: Returns a permutation which rearranges its first argument into ascending or descending order, breaking ties by further arguments. See \code{\link[BiocGenerics]{order}}. } \item{}{ \code{sort(x, decreasing = FALSE, na.last = NA)}: Sorts the values in \code{x}. \describe{ \item{\code{decreasing}}{If \code{TRUE}, sort values in decreasing order. If \code{FALSE}, sort values in increasing order.} \item{\code{na.last}}{If \code{TRUE}, missing values are placed last. If \code{FALSE}, they are placed first. If \code{NA}, they are removed.} } } \item{}{ \code{subset(x, subset)}: Returns a new Rle object made of the subset using logical vector \code{subset}. } \item{}{ \code{table(...)}: Returns a table containing the counts of the unique values. Supported arguments include \code{useNA} with values of `no' and `ifany'. Multiple Rle's must be combined with \code{c()} before calling \code{table}. } \item{}{ \code{tail(x, n = 6L)}: If \code{n} is non-negative, returns the last n elements of \code{x}. If \code{n} is negative, returns all but the first \code{abs(n)} elements of \code{x}. } \item{}{ \code{unique(x, incomparables = FALSE, ...)}: Returns the unique run values. The \code{incomparables} argument takes a vector of values that cannot be compared with \code{FALSE} being a special value that means that all values can be compared. } } } \section{Set Operations}{ In the code snippets below, \code{x} and \code{y} are Rle object or some other vector-like object: \describe{ \item{}{ \code{setdiff(x, y)}: Returns the unique elements in \code{x} that are not in \code{y}. } \item{}{ \code{union(x, y)}: Returns the unique elements in either \code{x} or \code{y}. } \item{}{ \code{intersect(x, y)}: Returns the unique elements in both \code{x} and \code{y}. } } } \author{P. Aboyoun} \seealso{ \link{Rle-utils}, \link{Rle-runstat}, and \link[S4Vectors]{aggregate} for more operations on Rle objects. \code{\link[base]{rle}} \link{Vector-class} } \examples{ x <- Rle(10:1, 1:10) x runLength(x) runValue(x) nrun(x) diff(x) unique(x) sort(x) x[c(1,3,5,7,9)] x > 4 x2 <- Rle(LETTERS[c(21:26, 25:26)], 8:1) table(x2) y <- Rle(c(TRUE,TRUE,FALSE,FALSE,TRUE,FALSE,TRUE,TRUE,TRUE)) y as.vector(y) rep(y, 10) c(y, x > 5) } \keyword{methods} \keyword{classes} S4Vectors/man/Rle-runstat.Rd0000644000175100017510000001100712607264537016723 0ustar00biocbuildbiocbuild\name{Rle-runstat} \alias{Rle-runstat} \alias{runsum} \alias{runsum,Rle-method} \alias{runmean} \alias{runmean,Rle-method} \alias{smoothEnds,Rle-method} \alias{runmed,Rle-method} \alias{runwtsum} \alias{runwtsum,Rle-method} \alias{runq} \alias{runq,Rle-method} \title{Fixed-width running window summaries} \description{ The \code{runsum}, \code{runmean}, \code{runmed}, \code{runwtsum}, \code{runq} functions calculate the sum, mean, median, weighted sum, and order statistic for fixed width running windows. } \usage{ runsum(x, k, endrule = c("drop", "constant"), ...) runmean(x, k, endrule = c("drop", "constant"), ...) \S4method{smoothEnds}{Rle}(y, k = 3) \S4method{runmed}{Rle}(x, k, endrule = c("median", "keep", "drop", "constant"), algorithm = NULL, print.level = 0) runwtsum(x, k, wt, endrule = c("drop", "constant"), ...) runq(x, k, i, endrule = c("drop", "constant"), ...) } \arguments{ \item{x}{ The data object. } \item{k}{ An integer indicating the fixed width of the running window. Must be odd when \code{endrule != "drop"}. } \item{endrule}{ A character string indicating how the values at the beginning and the end (of the data) should be treated. \describe{ \item{\code{"median"}}{see \code{\link[stats]{runmed}};} \item{\code{"keep"}}{see \code{\link[stats]{runmed}};} \item{\code{"drop"}}{do not extend the running statistics to be the same length as the underlying vectors;} \item{\code{"constant"}}{copies running statistic to the first values and analogously for the last ones making the smoothed ends \emph{constant}.} } } \item{wt}{ A numeric vector of length \code{k} that provides the weights to use. } \item{i}{ An integer in [0, k] indicating which order statistic to calculate. } \item{\dots}{Additional arguments passed to methods. Specifically, \code{na.rm}. When \code{na.rm = TRUE}, the \code{NA} and \code{NaN} values are removed. When \code{na.rm = FALSE}, \code{NA} is returned if either \code{NA} or \code{NaN} are in the specified window. } } \details{ The \code{runsum}, \code{runmean}, \code{runmed}, \code{runwtsum}, and \code{runq} functions provide efficient methods for calculating the specified numeric summary by performing the looping in compiled code. } \value{ An object of the same class as \code{x}. } \author{P. Aboyoun and V. Obenchain} \seealso{ \code{\link[stats]{runmed}}, \link{Rle-class}, \link[IRanges]{RleList-class} } \examples{ x <- Rle(1:10, 1:10) runsum(x, k = 3) runsum(x, k = 3, endrule = "constant") runmean(x, k = 3) runwtsum(x, k = 3, wt = c(0.25, 0.5, 0.25)) runq(x, k = 5, i = 3, endrule = "constant") ## Missing and non-finite values x <- Rle(c(1, 2, NA, 0, 3, Inf, 4, NaN)) runsum(x, k = 2) runsum(x, k = 2, na.rm = TRUE) runmean(x, k = 2, na.rm = TRUE) runwtsum(x, k = 2, wt = c(0.25, 0.5), na.rm = TRUE) runq(x, k = 2, i = 2, na.rm = TRUE) ## max value in window ## The .naive_runsum() function demonstrates the semantics of ## runsum(). This test ensures the behavior is consistent with ## base::sum(). .naive_runsum <- function(x, k, na.rm=FALSE) sapply(0:(length(x)-k), function(offset) sum(x[1:k + offset], na.rm=na.rm)) x0 <- c(1, Inf, 3, 4, 5, NA) x <- Rle(x0) target1 <- .naive_runsum(x0, 3, na.rm = TRUE) target2 <- .naive_runsum(x, 3, na.rm = TRUE) stopifnot(target1 == target2) current <- as.vector(runsum(x, 3, na.rm = TRUE)) stopifnot(target1 == current) ## runmean() and runwtsum() : x <- Rle(c(2, 1, NA, 0, 1, -Inf)) runmean(x, k = 3) runmean(x, k = 3, na.rm = TRUE) runwtsum(x, k = 3, wt = c(0.25, 0.50, 0.25)) runwtsum(x, k = 3, wt = c(0.25, 0.50, 0.25), na.rm = TRUE) ## runq() : runq(x, k = 3, i = 1, na.rm = TRUE) ## smallest value in window runq(x, k = 3, i = 3, na.rm = TRUE) ## largest value in window ## When na.rm = TRUE, it is possible the number of non-NA ## values in the window will be less than the 'i' specified. ## Here we request the 4th smallest value in the window, ## which tranlates to the value at the 4/5 (0.8) percentile. x <- Rle(c(1, 2, 3, 4, 5)) runq(x, k=length(x), i=4, na.rm=TRUE) ## The same request on a Rle with two missing values ## finds the value at the 0.8 percentile of the vector ## at the new length of 3 after the NA's have been removed. ## This translates to round((0.8) * 3). x <- Rle(c(1, 2, 3, NA, NA)) runq(x, k=length(x), i=4, na.rm=TRUE) } \keyword{methods} \keyword{algebra} \keyword{arith} S4Vectors/man/Rle-utils.Rd0000644000175100017510000002437512607264536016376 0ustar00biocbuildbiocbuild\name{Rle-utils} \alias{Rle-utils} \alias{Ops,Rle,Rle-method} \alias{Ops,Rle,vector-method} \alias{Ops,vector,Rle-method} \alias{Math,Rle-method} \alias{Math2,Rle-method} \alias{Summary,Rle-method} \alias{Complex,Rle-method} \alias{summary.Rle} \alias{summary,Rle-method} \alias{!,Rle-method} \alias{which,Rle-method} \alias{pmax,Rle-method} \alias{pmin,Rle-method} \alias{pmax.int,Rle-method} \alias{pmin.int,Rle-method} \alias{which.max,Rle-method} \alias{diff.Rle} \alias{diff,Rle-method} \alias{mean.Rle} \alias{mean,Rle-method} \alias{var,Rle,missing-method} \alias{var,Rle,Rle-method} \alias{cov,Rle,Rle-method} \alias{cor,Rle,Rle-method} \alias{sd,Rle-method} \alias{median.Rle} \alias{median,Rle-method} \alias{quantile.Rle} \alias{quantile,Rle-method} \alias{mad.Rle} \alias{mad,Rle-method} \alias{IQR,Rle-method} \alias{nchar,Rle-method} \alias{substr,Rle-method} \alias{substring,Rle-method} \alias{chartr,ANY,ANY,Rle-method} \alias{tolower,Rle-method} \alias{toupper,Rle-method} \alias{sub,ANY,ANY,Rle-method} \alias{gsub,ANY,ANY,Rle-method} \alias{paste,Rle-method} \alias{levels.Rle} \alias{levels,Rle-method} \alias{levels<-,Rle-method} % old stuff (Deprecated or Defunct) \alias{ifelse,ANY,ANY,Rle-method} \alias{ifelse,ANY,Rle,ANY-method} \alias{ifelse,ANY,Rle,Rle-method} \title{Common operations on Rle objects} \description{ Common operations on \link{Rle} objects. } \section{Group Generics}{ Rle objects have support for S4 group generic functionality: \describe{ \item{\code{Arith}}{\code{"+"}, \code{"-"}, \code{"*"}, \code{"^"}, \code{"\%\%"}, \code{"\%/\%"}, \code{"/"}} \item{\code{Compare}}{\code{"=="}, \code{">"}, \code{"<"}, \code{"!="}, \code{"<="}, \code{">="}} \item{\code{Logic}}{\code{"&"}, \code{"|"}} \item{\code{Ops}}{\code{"Arith"}, \code{"Compare"}, \code{"Logic"}} \item{\code{Math}}{\code{"abs"}, \code{"sign"}, \code{"sqrt"}, \code{"ceiling"}, \code{"floor"}, \code{"trunc"}, \code{"cummax"}, \code{"cummin"}, \code{"cumprod"}, \code{"cumsum"}, \code{"log"}, \code{"log10"}, \code{"log2"}, \code{"log1p"}, \code{"acos"}, \code{"acosh"}, \code{"asin"}, \code{"asinh"}, \code{"atan"}, \code{"atanh"}, \code{"exp"}, \code{"expm1"}, \code{"cos"}, \code{"cosh"}, \code{"sin"}, \code{"sinh"}, \code{"tan"}, \code{"tanh"}, \code{"gamma"}, \code{"lgamma"}, \code{"digamma"}, \code{"trigamma"}} \item{\code{Math2}}{\code{"round"}, \code{"signif"}} \item{\code{Summary}}{\code{"max"}, \code{"min"}, \code{"range"}, \code{"prod"}, \code{"sum"}, \code{"any"}, \code{"all"}} \item{\code{Complex}}{\code{"Arg"}, \code{"Conj"}, \code{"Im"}, \code{"Mod"}, \code{"Re"}} } See \link[methods]{S4groupGeneric} for more details. } \section{Summary}{ In the code snippets below, \code{x} is an Rle object: \describe{ \item{}{ \code{summary(object, ..., digits = max(3, getOption("digits") - 3))}: Summarizes the Rle object using an atomic vector convention. The \code{digits} argument is used for number formatting with \code{signif()}. } } } \section{Logical Data Methods}{ In the code snippets below, \code{x} is an Rle object: \describe{ \item{}{ \code{!x}: Returns logical negation (NOT) of \code{x}. } \item{}{ \code{which(x)}: Returns an integer vector representing the \code{TRUE} indices of \code{x}. } } } \section{Numerical Data Methods}{ In the code snippets below, \code{x} is an Rle object: \describe{ \item{}{ \code{diff(x, lag = 1, differences = 1}: Returns suitably lagged and iterated differences of \code{x}. \describe{ \item{\code{lag}}{An integer indicating which lag to use.} \item{\code{differences}}{An integer indicating the order of the difference.} } } \item{}{ \code{pmax(..., na.rm = FALSE)}, \code{pmax.int(..., na.rm = FALSE)}: Parallel maxima of the Rle input values. Removes \code{NA}s when \code{na.rm = TRUE}. } \item{}{ \code{pmin(..., na.rm = FALSE)}, \code{pmin.int(..., na.rm = FALSE)}: Parallel minima of the Rle input values. Removes \code{NA}s when \code{na.rm = TRUE}. } \item{}{ \code{which.max(x)}: Returns the index of the first element matching the maximum value of \code{x}. } \item{}{ \code{mean(x, na.rm = FALSE)}: Calculates the mean of \code{x}. Removes \code{NA}s when \code{na.rm = TRUE}. } \item{}{ \code{var(x, y = NULL, na.rm = FALSE)}: Calculates the variance of \code{x} or covariance of \code{x} and \code{y} if both are supplied. Removes \code{NA}s when \code{na.rm = TRUE}. } \item{}{ \code{cov(x, y, use = "everything")}, \code{cor(x, y, use = "everything")}: Calculates the covariance and correlation respectively of Rle objects \code{x} and \code{y}. The \code{use} argument is an optional character string giving a method for computing covariances in the presence of missing values. This must be (an abbreviation of) one of the strings \code{"everything"}, \code{"all.obs"}, \code{"complete.obs"}, \code{"na.or.complete"}, or \code{"pairwise.complete.obs"}. } \item{}{ \code{sd(x, na.rm = FALSE)}: Calculates the standard deviation of \code{x}. Removes \code{NA}s when \code{na.rm = TRUE}. } \item{}{ \code{median(x, na.rm = FALSE)}: Calculates the median of \code{x}. Removes \code{NA}s when \code{na.rm = TRUE}. } \item{}{ \code{quantile(x, probs = seq(0, 1, 0.25), na.rm = FALSE, names = TRUE, type = 7, ...)}: Calculates the specified quantiles of \code{x}. \describe{ \item{\code{probs}}{A numeric vector of probabilities with values in [0,1].} \item{\code{na.rm}}{If \code{TRUE}, removes \code{NA}s from \code{x} before the quantiles are computed.} \item{\code{names}}{If \code{TRUE}, the result has names describing the quantiles.} \item{\code{type}}{An integer between 1 and 9 selecting one of the nine quantile algorithms detailed in \code{\link[stats]{quantile}}.} \item{\dots}{Further arguments passed to or from other methods.} } } \item{}{ \code{mad(x, center = median(x), constant = 1.4826, na.rm = FALSE, low = FALSE, high = FALSE)}: Calculates the median absolute deviation of \code{x}. \describe{ \item{\code{center}}{The center to calculate the deviation from.} \item{\code{constant}}{The scale factor.} \item{\code{na.rm}}{If \code{TRUE}, removes \code{NA}s from \code{x} before the mad is computed.} \item{\code{low}}{If \code{TRUE}, compute the 'lo-median'.} \item{\code{high}}{If \code{TRUE}, compute the 'hi-median'.} } } \item{}{ \code{IQR(x, na.rm = FALSE)}: Calculates the interquartile range of \code{x}. \describe{ \item{\code{na.rm}}{If \code{TRUE}, removes \code{NA}s from \code{x} before the IQR is computed.} } } \item{}{ \code{smoothEnds(y, k = 3)}: Smooth end points of an Rle \code{y} using subsequently smaller medians and Tukey's end point rule at the very end. \describe{ \item{\code{k}}{An integer indicating the width of largest median window; must be odd.} } } } } \section{Character Data Methods}{ In the code snippets below, \code{x} is an Rle object: \describe{ \item{}{ \code{nchar(x, type = "chars", allowNA = FALSE)}: Returns an integer Rle representing the number of characters in the corresponding values of \code{x}. \describe{ \item{\code{type}}{One of \code{c("bytes", "chars", "width")}.} \item{\code{allowNA}}{Should \code{NA} be returned for invalid multibyte strings rather than throwing an error?} } } \item{}{ \code{substr(x, start, stop)}, \code{substring(text, first, last = 1000000L)}: Returns a character or factor Rle containing the specified substrings beginning at \code{start}/\code{first} and ending at \code{stop}/\code{last}. } \item{}{ \code{chartr(old, new, x)}: Returns a character or factor Rle containing a translated version of \code{x}. \describe{ \item{\code{old}}{A character string specifying the characters to be translated.} \item{\code{new}}{A character string specifying the translations.} } } \item{}{ \code{tolower(x)}: Returns a character or factor Rle containing a lower case version of \code{x}. } \item{}{ \code{toupper(x)}: Returns a character or factor Rle containing an upper case version of \code{x}. } \item{}{ \code{sub(pattern, replacement, x, ignore.case = FALSE, perl = FALSE, fixed = FALSE, useBytes = FALSE)}: Returns a character or factor Rle containing replacements based on matches determined by regular expression matching. See \code{\link{sub}} for a description of the arguments. } \item{}{ \code{gsub(pattern, replacement, x, ignore.case = FALSE, perl = FALSE, fixed = FALSE, useBytes = FALSE)}: Returns a character or factor Rle containing replacements based on matches determined by regular expression matching. See \code{\link{gsub}} for a description of the arguments. } \item{}{ \code{paste(..., sep = " ", collapse = NULL)}: Returns a character or factor Rle containing a concatenation of the values in \code{...}. } } } \section{Factor Data Methods}{ In the code snippets below, \code{x} is an Rle object: \describe{ \item{}{ \code{levels(x)}, \code{levels(x) <- value}: Gets and sets the factor levels, respectively. } \item{}{ \code{nlevels(x)}: Returns the number of factor levels. } } } \author{P. Aboyoun} \seealso{ \link{Rle} objects \link[methods]{S4groupGeneric} } \examples{ x <- Rle(10:1, 1:10) x sqrt(x) x^2 + 2 * x + 1 range(x) sum(x) mean(x) z <- c("the", "quick", "red", "fox", "jumps", "over", "the", "lazy", "brown", "dog") z <- Rle(z, seq_len(length(z))) chartr("a", "@", z) toupper(z) } \keyword{utilities} \keyword{methods} \keyword{arith} S4Vectors/man/S4Vectors-internals.Rd0000644000175100017510000000163612607264536020342 0ustar00biocbuildbiocbuild\name{S4Vectors internals} % Stuff from R/S4-utils.R: \alias{class:characterORNULL} \alias{characterORNULL-class} \alias{characterORNULL} \alias{class:vectorORfactor} \alias{vectorORfactor-class} \alias{vectorORfactor} \alias{coerce,ANY,vector-method} \alias{setValidity2} \alias{new2} \alias{setMethods} % Stuff from R/utils.R: \alias{wmsg} \alias{.Call2} \alias{get_showHeadLines} \alias{get_showTailLines} \alias{printAtomicVectorInAGrid} % Low-level helper functions from R/normarg-utils.R: \alias{isTRUEorFALSE} \alias{isSingleInteger} \alias{isSingleNumber} \alias{isSingleString} \alias{isSingleNumberOrNA} \alias{isSingleStringOrNA} \alias{recycleIntegerArg} \alias{recycleNumericArg} \alias{fold} \title{S4Vectors internals} \description{ Objects, classes and methods defined in the \pkg{S4Vectors} package that are not intended to be used directly. } \keyword{internal} \keyword{classes} \keyword{methods} S4Vectors/man/SimpleList-class.Rd0000644000175100017510000000560712607264537017704 0ustar00biocbuildbiocbuild\name{SimpleList-class} \docType{class} \alias{class:SimpleList} \alias{SimpleList} \alias{SimpleList-class} % accessors \alias{length,SimpleList-method} \alias{names,SimpleList-method} \alias{names<-,SimpleList-method} % coercion \alias{as.list,SimpleList-method} \alias{as.list.SimpleList} \alias{coerce,ANY,SimpleList-method} \alias{coerce,list,List-method} % combining \alias{c,SimpleList-method} % looping \alias{lapply,SimpleList-method} \alias{endoapply,SimpleList-method} \alias{mendoapply,SimpleList-method} % displaying \alias{classNameForDisplay,SimpleList-method} \title{SimpleList objects} \description{ The (non-virtual) SimpleList class extends the \link{List} virtual class. } \details{ The SimpleList class is the simplest, most generic concrete implementation of the \link{List} abstraction. It provides an implementation that subclasses can easily extend. In a SimpleList object the list elements are stored internally in an ordinary list. } \section{Constructor}{ See the \link{List} man page for a quick overview of how to construct \link{List} objects in general. The following constructor is provided for SimpleList objects: \describe{ \item{}{\code{SimpleList(...)}: Takes possibly named objects as elements for the new SimpleList object. } } } \section{Accessors}{ Same as for \link{List} objects. See the \link{List} man page for more information. } \section{Coercion}{ All the coercions documented in the \link{List} man page apply to \link{SimpleList} objects. } \section{Subsetting}{ Same as for \link{List} objects. See the \link{List} man page for more information. } \section{Looping and functional programming}{ Same as for \link{List} objects. See \code{?`\link{List-utils}`} for more information. } \section{Displaying}{ When a SimpleList object is displayed, the "Simple" prefix is removed from the real class name of the object. See \code{\link{classNameForDisplay}} for more information about this. } \seealso{ \itemize{ \item \link{List} objects for the parent class. \item The \link[IRanges]{CompressedList} class defined in the \pkg{IRanges} package for a more efficient alternative to SimpleList. \item The \link[IRanges]{SimpleIntegerList} class defined in the \pkg{IRanges} package for a SimpleList subclass example. \item The \link{DataFrame} class for another SimpleList subclass example. } } \examples{ ## Displaying a SimpleList object: x1 <- SimpleList(a=letters, i=Rle(22:20, 4:2)) class(x1) ## The "Simple" prefix is removed from the real class name of the ## object: x1 library(IRanges) x2 <- IntegerList(11:12, integer(0), 3:-2, compress=FALSE) class(x2) ## The "Simple" prefix is removed from the real class name of the ## object: x2 ## This is controlled by internal helper classNameForDisplay(): classNameForDisplay(x2) } \keyword{methods} \keyword{classes} S4Vectors/man/Vector-class.Rd0000644000175100017510000002137012607264536017053 0ustar00biocbuildbiocbuild\name{Vector-class} \docType{class} \alias{class:DataTableORNULL} \alias{DataTableORNULL-class} \alias{DataTableORNULL} % Vector class, functions and methods: \alias{class:Vector} \alias{Vector-class} \alias{Vector} \alias{length,Vector-method} \alias{lengths,Vector-method} \alias{NROW,Vector-method} \alias{ROWNAMES,Vector-method} \alias{elementMetadata} \alias{elementMetadata,Vector-method} \alias{mcols} \alias{mcols,Vector-method} \alias{values} \alias{values,Vector-method} \alias{elementMetadata<-} \alias{elementMetadata<-,Vector-method} \alias{mcols<-} \alias{mcols<-,Vector-method} \alias{values<-} \alias{values<-,Vector-method} \alias{rename} \alias{rename,vector-method} \alias{rename,Vector-method} \alias{as.logical,Vector-method} \alias{as.integer,Vector-method} \alias{as.numeric,Vector-method} \alias{as.double,Vector-method} \alias{as.complex,Vector-method} \alias{as.character,Vector-method} \alias{as.raw,Vector-method} \alias{coerce,Vector,vector-method} \alias{coerce,Vector,logical-method} \alias{coerce,Vector,integer-method} \alias{coerce,Vector,numeric-method} \alias{coerce,Vector,double-method} \alias{coerce,Vector,complex-method} \alias{coerce,Vector,character-method} \alias{coerce,Vector,raw-method} \alias{coerce,Vector,factor-method} \alias{coerce,Vector,data.frame-method} \alias{as.data.frame.Vector} \alias{as.data.frame,Vector-method} \alias{as.env,Vector-method} \alias{[,Vector-method} \alias{[<-,Vector-method} \alias{replaceROWS,Vector-method} \alias{append,Vector,Vector-method} \alias{classNameForDisplay} \alias{classNameForDisplay,ANY-method} \alias{classNameForDisplay,AsIs-method} \alias{showAsCell} \alias{showAsCell,ANY-method} \alias{showAsCell,Vector-method} \alias{parallelVectorNames} \alias{parallelVectorNames,ANY-method} \title{Vector objects} \description{ The Vector virtual class serves as the heart of the S4Vectors package and has over 90 subclasses. It serves a similar role as \link[base]{vector} in base R. The Vector class supports the storage of \emph{global} and \emph{element-wise} metadata: \enumerate{ \item The \emph{global} metadata annotates the object as a whole: this metadata is accessed via the \code{metadata} accessor and is represented as an ordinary list; \item The \emph{element-wise} metadata annotates individual elements of the object: this metadata is accessed via the \code{mcols} accessor (\code{mcols} stands for \emph{metadata columns}) and is represented as a \link{DataTable} object (i.e. as an instance of a concrete subclass of \link{DataTable}, e.g. a \link{DataFrame} object), with a row for each element and a column for each metadata variable. Note that the element-wise metadata can also be \code{NULL}. } To be functional, a class that inherits from Vector must define at least a \code{length} and a \code{"["} method. } \section{Accessors}{ In the following code snippets, \code{x} is a Vector object. \describe{ \item{}{ \code{length(x)}: Get the number of elements in \code{x}. } \item{}{ \code{lengths(x, use.names=TRUE)}: Get the length of each of the elements. Note: The \code{lengths} method for Vector objects is currently defined as an alias for \code{\link{elementLengths}} (with addition of the \code{use.names} argument), so is equivalent to \code{sapply(x, NROW)}, not to \code{sapply(x, length)}. See \code{?BiocGenerics::\link[BiocGenerics]{lengths}} in the \pkg{BiocGenerics} package for more information about this. } \item{}{ \code{NROW(x)}: Defined as \code{length(x)} for any Vector object that is \emph{not} a \link{DataTable} object. If \code{x} is a \link{DataTable} object, then it's defined as \code{nrow(x)}. } \item{}{ \code{names(x)}, \code{names(x) <- value}: Get or set the names of the elements in the Vector. } \item{}{ \code{rename(x, value, ...)}: Replace the names of \code{x} according to a mapping defined by a named character vector, formed by concatenating \code{value} with any arguments in \code{...}. The names of the character vector indicate the source names, and the corresponding values the destination names. This also works on a plain old \code{vector}. } \item{}{ \code{nlevels(x)}: Returns the number of factor levels. } \item{}{ \code{mcols(x, use.names=FALSE)}, \code{mcols(x) <- value}: Get or set the metadata columns. If \code{use.names=TRUE} and the metadata columns are not \code{NULL}, then the names of \code{x} are propagated as the row names of the returned \link{DataTable} object. When setting the metadata columns, the supplied value must be \code{NULL} or a \link{DataTable} object holding element-wise metadata. } \item{}{ \code{elementMetadata(x, use.names=FALSE)}, \code{elementMetadata(x) <- value}, \code{values(x, use.names=FALSE)}, \code{values(x) <- value}: Alternatives to \code{mcols} functions. Their use is discouraged. } } } \section{Coercion}{ \describe{ \item{}{\code{as(from, "data.frame")}, \code{as.data.frame(from)}: Coerces \code{from}, a \code{Vector}, to a \code{data.frame} by first coercing the \code{Vector} to a \code{vector} via \code{as.vector}. Note that many \code{Vector} derivatives do not support \code{as.vector}, so this coercion is possible only for certain types. } \item{}{\code{as.env(x)}: Constructs an environment object containing the elements of \code{mcols(x)}. } } } \section{Subsetting}{ In the code snippets below, \code{x} is a Vector object or regular R vector object. The R vector object methods for \code{window} are defined in this package and the remaining methods are defined in base R. \describe{ \item{}{ \code{x[i, drop=TRUE]}: If defined, returns a new Vector object made of selected elements \code{i}, which can be missing; an NA-free logical, numeric, or character vector; or a logical Rle object. The \code{drop} argument specifies whether or not to coerce the returned sequence to an ordinary vector. } \item{}{ \code{x[i] <- value}: Replacement version of \code{x[i]}. } } } \section{Combining}{ In the code snippets below, \code{x} is a Vector object. \describe{ \item{}{ \code{c(x, ...)}: Combine \code{x} and the Vector objects in \code{...} together. Any object in \code{...} must belong to the same class as \code{x}, or to one of its subclasses, or must be \code{NULL}. The result is an object of the same class as \code{x}. } \item{}{\code{append(x, values, after = length(x))}: Insert the \code{Vector} \code{values} onto \code{x} at the position given by \code{after}. \code{values} must have an \code{elementType} that extends that of \code{x}. } } } \section{Displaying}{ [FOR ADVANCED USERS OR DEVELOPERS] Displaying of a Vector object is controlled by 2 internal helpers, \code{classNameForDisplay} and \code{showAsCell}. For most objects \code{classNameForDisplay(x)} just returns \code{class(x)}. However, for some objects it can return the name of a parent class that is more suitable for display because it's simpler and as informative as the real class name. See \link{SimpleList} objects (defined in this package) and \link[IRanges]{CompressedList} objects (defined in the \pkg{IRanges} package) for examples of objects for which \code{classNameForDisplay} returns the name of a parent class. \code{showAsCell(x)} produces a character vector \emph{parallel} to \code{x} (i.e. with one string per vector element in \code{x}) that contains compact string representations of each elements in \code{x}. Note that \code{classNameForDisplay} and \code{showAsCell} are generic functions so developers can implement methods to control how their own Vector extension gets displayed. } \seealso{ \itemize{ \item \link{Rle}, \link[IRanges]{IRanges} and \link[XVector]{XRaw} for example implementations. \item \link{Vector-comparison} for comparing, ordering, and tabulating vector-like objects. \item \link{List} for a direct Vector extension that serves a similar role as \link[base]{list} in base R. \item \link[IRanges]{extractList} for grouping elements of a vector-like object into a list-like object. \item \link{DataTable} which is the type of objects returned by the \code{mcols} accessor. \item The \link{Annotated} class, which Vector extends. } } \examples{ showClass("Vector") # shows (some of) the known subclasses } \keyword{methods} \keyword{classes} S4Vectors/man/Vector-comparison.Rd0000644000175100017510000003207112607264536020120 0ustar00biocbuildbiocbuild\name{Vector-comparison} \alias{Vector-comparison} \alias{compare} \alias{==,Vector,Vector-method} \alias{==,Vector,ANY-method} \alias{==,ANY,Vector-method} \alias{<=,Vector,Vector-method} \alias{<=,Vector,ANY-method} \alias{<=,ANY,Vector-method} \alias{!=,Vector,Vector-method} \alias{!=,Vector,ANY-method} \alias{!=,ANY,Vector-method} \alias{>=,Vector,Vector-method} \alias{>=,Vector,ANY-method} \alias{>=,ANY,Vector-method} \alias{<,Vector,Vector-method} \alias{<,Vector,ANY-method} \alias{<,ANY,Vector-method} \alias{>,Vector,Vector-method} \alias{>,Vector,ANY-method} \alias{>,ANY,Vector-method} \alias{selfmatch} \alias{selfmatch,ANY-method} \alias{duplicated,Vector-method} \alias{duplicated.Vector} \alias{unique,Vector-method} \alias{unique.Vector} \alias{\%in\%,Vector,Vector-method} \alias{\%in\%,Vector,ANY-method} \alias{\%in\%,ANY,Vector-method} \alias{findMatches} \alias{findMatches,ANY,ANY-method} \alias{countMatches} \alias{countMatches,ANY,ANY-method} \alias{sort,Vector-method} \alias{sort.Vector} \alias{rank,Vector-method} \alias{table,Vector-method} \title{Compare, order, tabulate vector-like objects} \description{ Generic functions and methods for comparing, ordering, and tabulating vector-like objects. } \usage{ ## Element-wise (aka "parallel") comparison of 2 Vector objects ## ------------------------------------------------------------ compare(x, y) \S4method{==}{Vector,Vector}(e1, e2) \S4method{==}{Vector,ANY}(e1, e2) \S4method{==}{ANY,Vector}(e1, e2) \S4method{<=}{Vector,Vector}(e1, e2) \S4method{<=}{Vector,ANY}(e1, e2) \S4method{<=}{ANY,Vector}(e1, e2) \S4method{!=}{Vector,Vector}(e1, e2) \S4method{!=}{Vector,ANY}(e1, e2) \S4method{!=}{ANY,Vector}(e1, e2) \S4method{>=}{Vector,Vector}(e1, e2) \S4method{>=}{Vector,ANY}(e1, e2) \S4method{>=}{ANY,Vector}(e1, e2) \S4method{<}{Vector,Vector}(e1, e2) \S4method{<}{Vector,ANY}(e1, e2) \S4method{<}{ANY,Vector}(e1, e2) \S4method{>}{Vector,Vector}(e1, e2) \S4method{>}{Vector,ANY}(e1, e2) \S4method{>}{ANY,Vector}(e1, e2) ## selfmatch() ## ----------- selfmatch(x, ...) ## duplicated() & unique() ## ----------------------- \S4method{duplicated}{Vector}(x, incomparables=FALSE, ...) \S4method{unique}{Vector}(x, incomparables=FALSE, ...) ## %in% ## ---- \S4method{\%in\%}{Vector,Vector}(x, table) \S4method{\%in\%}{Vector,ANY}(x, table) \S4method{\%in\%}{ANY,Vector}(x, table) ## findMatches() & countMatches() ## ------------------------------ findMatches(x, table, select=c("all", "first", "last"), ...) countMatches(x, table, ...) ## sort() ## ------ \S4method{sort}{Vector}(x, decreasing=FALSE, ...) ## table() ## ------- \S4method{table}{Vector}(...) } \arguments{ \item{x, y, e1, e2, table}{ Vector-like objects. } \item{incomparables}{ The \code{duplicated} method for \link{Vector} objects does NOT support this argument. The \code{unique} method for \link{Vector} objects, which is implemented on top of \code{duplicated}, propagates this argument to its call to \code{duplicated}. See \code{?base::\link[base]{duplicated}} and \code{?base::\link[base]{unique}} for more information about this argument. } \item{select}{ Only \code{select="all"} is supported at the moment. Note that you can use \code{match} if you want to do \code{select="first"}. Otherwise you're welcome to request this on the Bioconductor mailing list. } \item{decreasing}{ See \code{?base::\link[base]{sort}}. } \item{...}{ A \link{Vector} object for \code{table} (the \code{table} method for \link{Vector} objects can only take one input object). Otherwise, extra arguments supported by specific methods. In particular: \itemize{ \item The default \code{selfmatch} method, which is implemented on top of \code{match}, propagates the extra arguments to its call to \code{match}. \item The \code{duplicated} method for \link{Vector} objects, which is implemented on top of \code{selfmatch}, accepts extra argument \code{fromLast} and propagates the other extra arguments to its call to \code{selfmatch}. See \code{?base::\link[base]{duplicated}} for more information about this argument. \item The \code{unique} method for \link{Vector} objects, which is implemented on top of \code{duplicated}, propagates the extra arguments to its call to \code{duplicated}. \item The default \code{findMatches} and \code{countMatches} methods, which are implemented on top of \code{match} and \code{selfmatch}, propagate the extra arguments to their calls to \code{match} and \code{selfmatch}. \item The \code{sort} method for \link{Vector} objects, which is implemented on top of \code{order}, only accepts extra argument \code{na.last} and propagates it to its call to \code{order}. } } } \details{ Doing \code{compare(x, y)} on 2 vector-like objects \code{x} and \code{y} of length 1 must return an integer less than, equal to, or greater than zero if the single element in \code{x} is considered to be respectively less than, equal to, or greater than the single element in \code{y}. If \code{x} or \code{y} have a length != 1, then they are typically expected to have the same length so \code{compare(x, y)} can operate element-wise, that is, in that case it returns an integer vector of the same length as \code{x} and \code{y} where the i-th element is the result of compairing \code{x[i]} and \code{y[i]}. If \code{x} and \code{y} don't have the same length and are not zero-length vectors, then the shortest is first recycled to the length of the longest. If one of them is a zero-length vector then \code{compare(x, y)} returns a zero-length integer vector. \code{selfmatch(x, ...)} is equivalent to \code{match(x, x, ...)}. This is actually how the default method is implemented. However note that \code{selfmatch(x, ...)} will typically be more efficient than \code{match(x, x, ...)} on vector-like objects for which a specific \code{selfmatch} method is implemented. \code{findMatches} is an enhanced version of \code{match} which, by default (i.e. if \code{select="all"}), returns all the matches in a \link{Hits} object. \code{countMatches} returns an integer vector of the length of \code{x} containing the number of matches in \code{table} for each element in \code{x}. } \value{ For \code{compare}: see Details section above. For \code{selfmatch}: an integer vector of the same length as \code{x}. For \code{duplicated}, \code{unique}, and \code{\%in\%}: see \code{?BiocGenerics::\link[BiocGenerics]{duplicated}}, \code{?BiocGenerics::\link[BiocGenerics]{unique}}, and \code{?`\link{\%in\%}`}. For \code{findMatches}: a \link{Hits} object by default (i.e. if \code{select="all"}). For \code{countMatches}: an integer vector of the length of \code{x} containing the number of matches in \code{table} for each element in \code{x}. For \code{sort}: see \code{?BiocGenerics::\link[BiocGenerics]{sort}}. For \code{table}: a 1D array of integer values promoted to the \code{"table"} class. See \code{?BiocGeneric::\link[BiocGenerics]{table}} for more information. } \note{ The following notes are for developers who want to implement comparing, ordering, and tabulating methods for their own \link{Vector} subclass: \enumerate{ \item The 6 traditional binary comparison operators are: \code{==}, \code{!=}, \code{<=}, \code{>=}, \code{<}, and \code{>}. The \pkg{S4Vectors} package provides the following methods for these operators: \preformatted{ setMethod("==", c("Vector", "Vector"), function(e1, e2) { compare(e1, e2) == 0L } ) setMethod("<=", c("Vector", "Vector"), function(e1, e2) { compare(e1, e2) <= 0L } ) setMethod("!=", c("Vector", "Vector"), function(e1, e2) { !(e1 == e2) } ) setMethod(">=", c("Vector", "Vector"), function(e1, e2) { e2 <= e1 } ) setMethod("<", c("Vector", "Vector"), function(e1, e2) { !(e2 <= e1) } ) setMethod(">", c("Vector", "Vector"), function(e1, e2) { !(e1 <= e2) } ) } With these definitions, the 6 binary operators work out-of-the-box on \link{Vector} objects for which \code{compare} works the expected way. If \code{compare} is not implemented, then it's enough to implement \code{==} and \code{<=} methods to have the 4 remaining operators (\code{!=}, \code{>=}, \code{<}, and \code{>}) work out-of-the-box. \item The \pkg{S4Vectors} package provides no \code{compare} method for \link{Vector} objects. Specific \code{compare} methods need to be implemented for specific \link{Vector} subclasses (e.g. for \link{Hits} and \link[IRanges]{Ranges} objects). These specific methods must obey the rules described in the Details section above. \item The \code{duplicated}, \code{unique}, and \code{\%in\%} methods for \link{Vector} objects are implemented on top of \code{selfmatch}, \code{duplicated}, and \code{match}, respectively, so they work out-of-the-box on \link{Vector} objects for which \code{selfmatch}, \code{duplicated}, and \code{match} work the expected way. \item Also the default \code{findMatches} and \code{countMatches} methods are implemented on top of \code{match} and \code{selfmatch} so they work out-of-the-box on \link{Vector} objects for which those things work the expected way. \item However, since \code{selfmatch} itself is also implemented on top of \code{match}, then having \code{match} work the expected way is actually enough to get \code{selfmatch}, \code{duplicated}, \code{unique}, \code{\%in\%}, \code{findMatches}, and \code{countMatches} work out-of-the-box on \link{Vector} objects. \item The \code{sort} method for \link{Vector} objects is implemented on top of \code{order}, so it works out-of-the-box on \link{Vector} objects for which \code{order} works the expected way. \item The \code{table} method for \link{Vector} objects is implemented on top of \code{selfmatch}, \code{order}, and \code{as.character}, so it works out-of-the-box on a \link{Vector} object for which those things work the expected way. \item The \pkg{S4Vectors} package provides no \code{match} or \code{order} methods for \link{Vector} objects. Specific methods need to be implemented for specific \link{Vector} subclasses (e.g. for \link{Hits} and \link[IRanges]{Ranges} objects). } } \author{H. Pages} \seealso{ \itemize{ \item The \link{Vector} class. \item \link{Hits-comparison} for comparing and ordering hits. \item \link[IRanges]{Ranges-comparison} in the \pkg{IRanges} package for comparing and ordering ranges. \item \code{\link{==}} and \code{\link{\%in\%}} in the \pkg{base} package, and \code{BiocGenerics::\link[BiocGenerics]{match}}, \code{BiocGenerics::\link[BiocGenerics]{duplicated}}, \code{BiocGenerics::\link[BiocGenerics]{unique}}, \code{BiocGenerics::\link[BiocGenerics]{order}}, \code{BiocGenerics::\link[BiocGenerics]{sort}}, \code{BiocGenerics::\link[BiocGenerics]{rank}} in the \pkg{BiocGenerics} package for general information about the comparison/ordering operators and functions. \item The \link{Hits} class. \item \code{BiocGeneric::\link[BiocGenerics]{table}} in the \pkg{BiocGenerics} package. } } \examples{ ## --------------------------------------------------------------------- ## A. SIMPLE EXAMPLES ## --------------------------------------------------------------------- y <- c(16L, -3L, -2L, 15L, 15L, 0L, 8L, 15L, -2L) selfmatch(y) x <- c(unique(y), 999L) findMatches(x, y) countMatches(x, y) ## See ?`Ranges-comparison` for more examples (on Ranges objects). You ## might need to load the IRanges package first. ## --------------------------------------------------------------------- ## B. FOR DEVELOPERS: HOW TO IMPLEMENT THE BINARY COMPARISON OPERATORS ## FOR YOUR Vector SUBCLASS ## --------------------------------------------------------------------- ## The answer is: don't implement them. Just implement compare() and the ## binary comparison operators will work out-of-the-box. Here is an ## example: ## (1) Implement a simple Vector subclass. setClass("Raw", contains="Vector", representation(data="raw")) setMethod("length", "Raw", function(x) length(x@data)) setMethod("[", "Raw", function(x, i, j, ..., drop) { x@data <- x@data[i]; x } ) x <- new("Raw", data=charToRaw("AB.x0a-BAA+C")) stopifnot(identical(length(x), 12L)) stopifnot(identical(x[7:3], new("Raw", data=charToRaw("-a0x.")))) ## (2) Implement a "compare" method for Raw objects. setMethod("compare", c("Raw", "Raw"), function(x, y) {as.integer(x@data) - as.integer(y@data)} ) stopifnot(identical(which(x == x[1]), c(1L, 9L, 10L))) stopifnot(identical(x[x < x[5]], new("Raw", data=charToRaw(".-+")))) } \keyword{methods} S4Vectors/man/aggregate-methods.Rd0000644000175100017510000000730412607264536020076 0ustar00biocbuildbiocbuild\name{aggregate-methods} \alias{aggregate-methods} \alias{aggregate} \alias{aggregate,matrix-method} \alias{aggregate,data.frame-method} \alias{aggregate,ts-method} \alias{aggregate.Vector} \alias{aggregate,Vector-method} \alias{aggregate,vector-method} \alias{aggregate.Rle} \alias{aggregate,Rle-method} \alias{aggregate.List} \alias{aggregate,List-method} \title{Compute summary statistics of subsets of vector-like objects} \description{ The \pkg{S4Vectors} package defines \code{\link[stats]{aggregate}} methods for \link{Vector}, \link{Rle}, and \link{List} objects. } \usage{ \S4method{aggregate}{Vector}(x, by, FUN, start=NULL, end=NULL, width=NULL, frequency=NULL, delta=NULL, ..., simplify=TRUE) \S4method{aggregate}{Rle}(x, by, FUN, start=NULL, end=NULL, width=NULL, frequency=NULL, delta=NULL, ..., simplify=TRUE) \S4method{aggregate}{List}(x, by, FUN, start=NULL, end=NULL, width=NULL, frequency=NULL, delta=NULL, ..., simplify=TRUE) } \arguments{ \item{x}{ A \link{Vector}, \link{Rle}, or \link{List} object. } \item{by}{ An object with \code{\link[BiocGenerics]{start}}, \code{\link[BiocGenerics]{end}}, and \code{\link[BiocGenerics]{width}} methods. If \code{x} is a \link{List} object, the \code{by} parameter can be a \link[IRanges]{RangesList} object to aggregate within the list elements rather than across them. When \code{by} is a \link[IRanges]{RangesList} object, the output is either a \link[IRanges]{SimpleAtomicList} object, if possible, or a \link{SimpleList} object, if not. } \item{FUN}{ The function, found via \code{match.fun}, to be applied to each subset of \code{x}. } \item{start, end, width}{ The start, end, and width of the subsets. If \code{by} is missing, then two of the three must be supplied and have the same length. } \item{frequency, delta}{ Optional arguments that specify the sampling frequency and increment within the subsets (in the same fashion as \code{\link[stats]{window}} from the \pkg{stats} package does). } \item{...}{ Optional arguments to \code{FUN}. } \item{simplify}{ A logical value specifying whether the result should be simplified to a vector or matrix if possible. } } \details{ Subsets of \code{x} can be specified either via the \code{by} argument or via the \code{start}, \code{end}, \code{width}, \code{frequency}, and \code{delta} arguments. For example, if \code{start} and \code{end} are specified, then: \preformatted{ aggregate(x, FUN=FUN, start=start, end=end, ..., simplify=simplify) } is equivalent to: \preformatted{ sapply(seq_along(start), function(i) FUN(x[start[i]:end[i]], ...), simplify=simplify) } (replace \code{x[start[i]:end[i]]} with 2D-style subsetting \code{x[start[i]:end[i], ]} if \code{x} is a \link{DataFrame} object). } \seealso{ \itemize{ \item The \code{\link[stats]{aggregate}} function in the \pkg{stats} package. \item \link{Vector}, \link{Rle}, \link{List}, and \link{DataFrame} objects. \item The \code{\link[BiocGenerics]{start}}, \code{\link[BiocGenerics]{end}}, and \code{\link[BiocGenerics]{width}} generic functions defined in the \pkg{BiocGenerics} package. } } \examples{ x <- Rle(10:2, 1:9) aggregate(x, x > 4, mean) aggregate(x, FUN=mean, start=1:26, width=20) ## Note that aggregate() works on a DataFrame object the same way it ## works on an ordinary data frame: aggregate(DataFrame(state.x77), list(Region=state.region), mean) aggregate(weight ~ feed, data=DataFrame(chickwts), mean) library(IRanges) by <- IRanges(start=1:26, width=20, names=LETTERS) aggregate(x, by, is.unsorted) } \keyword{methods} \keyword{utilities} S4Vectors/man/isSorted.Rd0000644000175100017510000000634112607264536016303 0ustar00biocbuildbiocbuild\name{isSorted} \alias{isSorted} \alias{isSorted,ANY-method} \alias{isConstant} \alias{isConstant,integer-method} \alias{isConstant,numeric-method} \alias{isConstant,array-method} \alias{isStrictlySorted} \alias{isStrictlySorted,ANY-method} \title{Test if a vector-like object is sorted} \description{ \code{isSorted} and \code{isStrictlySorted} test if a vector-like object is sorted or strictly sorted, respectively. \code{isConstant} tests if a vector-like or array-like object is constant. Currently only \code{isConstant} methods for vectors or arrays of type integer or double are implemented. } \usage{ isSorted(x) isStrictlySorted(x) isConstant(x) } \arguments{ \item{x}{ A vector-like object. Can also be an array-like object for \code{isConstant}. } } \details{ Vector-like objects of length 0 or 1 are always considered to be sorted, strictly sorted, and constant. Strictly sorted and constant objects are particular cases of sorted objects. \code{isStrictlySorted(x)} is equivalent to \code{isSorted(x) && !anyDuplicated(x)} } \value{ A single logical i.e. \code{TRUE}, \code{FALSE} or \code{NA}. } \author{H. Pages} \seealso{ \itemize{ \item \code{\link{is.unsorted}}. \item \code{\link{duplicated}} and \code{\link{unique}}. \item \code{\link{all.equal}}. \item \code{\link{NA}} and \code{\link{is.finite}}. } } \examples{ ## --------------------------------------------------------------------- ## A. isSorted() and isStrictlySorted() ## --------------------------------------------------------------------- x <- 1:10 isSorted(x) # TRUE isSorted(-x) # FALSE isSorted(rev(x)) # FALSE isSorted(-rev(x)) # TRUE isStrictlySorted(x) # TRUE x2 <- rep(x, each=2) isSorted(x2) # TRUE isStrictlySorted(x2) # FALSE ## --------------------------------------------------------------------- ## B. "isConstant" METHOD FOR integer VECTORS ## --------------------------------------------------------------------- ## On a vector with no NAs: stopifnot(isConstant(rep(-29L, 10000))) ## On a vector with NAs: stopifnot(!isConstant(c(0L, NA, -29L))) stopifnot(is.na(isConstant(c(-29L, -29L, NA)))) ## On a vector of length <= 1: stopifnot(isConstant(NA_integer_)) ## --------------------------------------------------------------------- ## C. "isConstant" METHOD FOR numeric VECTORS ## --------------------------------------------------------------------- ## This method does its best to handle rounding errors and special ## values NA, NaN, Inf and -Inf in a way that "makes sense". ## Below we only illustrate handling of rounding errors. ## Here values in 'x' are "conceptually" the same: x <- c(11/3, 2/3 + 4/3 + 5/3, 50 + 11/3 - 50, 7.00001 - 1000003/300000) ## However, due to machine rounding errors, they are not *strictly* ## equal: duplicated(x) unique(x) ## only *nearly* equal: all.equal(x, rep(11/3, 4)) # TRUE ## 'isConstant(x)' uses 'all.equal()' internally to decide whether ## the values in 'x' are all the same or not: stopifnot(isConstant(x)) ## This is not perfect though: isConstant((x - 11/3) * 1e8) # FALSE on Intel Pentium paltforms # (but this is highly machine dependent!) } \keyword{utilities} S4Vectors/man/split-methods.Rd0000644000175100017510000000412112607264536017275 0ustar00biocbuildbiocbuild\name{split-methods} \alias{split-methods} \alias{split} \alias{split,Vector,ANY-method} \alias{split,ANY,Vector-method} \alias{split,Vector,Vector-method} \alias{split,list,Vector-method} \title{Divide a vector-like object into groups} \description{ \code{split} divides the data in a vector-like object \code{x} into the groups defined by \code{f}. NOTE: This man page is for the \code{split} methods defined in the \pkg{S4Vectors} package. See \code{?base::\link[base]{split}} for the default method (defined in the \pkg{base} package). } \usage{ \S4method{split}{Vector,ANY}(x, f, drop=FALSE) \S4method{split}{ANY,Vector}(x, f, drop=FALSE) \S4method{split}{Vector,Vector}(x, f, drop=FALSE) \S4method{split}{list,Vector}(x, f, drop=FALSE, ...) } \arguments{ \item{x, f}{ 2 vector-like objects of the same length. \code{f} will typically be a factor, but not necessarily. } \item{drop}{ Logical indicating if levels that do not occur should be dropped (if \code{f} is a factor). } \item{...}{ Arguments passed to \code{base::\link{split}} (see Details below). } } \details{ The first 3 methods just delegate to the \code{IRanges::\link[IRanges]{splitAsList}} function defined in the \pkg{IRanges} package. The method for \code{list} does: \preformatted{ split(x, as.vector(f), drop=drop, ...) } } \value{ All these methods behave like \code{base::\link{split}} except that the first 3 methods return a \link{List} object instead of an ordinary list. } \seealso{ \itemize{ \item The \code{\link[base]{split}} function in the \pkg{base} package. \item The \code{\link[IRanges]{splitAsList}} function in the \pkg{IRanges} package. \item \link{Vector} and \link{List} objects. \item \link{Rle} and \link{DataFrame} objects. } } \examples{ ## On an Rle object: x <- Rle(101:105, 6:2) split(x, c("B", "B", "A", "B", "A")) ## On a DataFrame object: groups <- c("group1", "group2") DF <- DataFrame( a=letters[1:10], i=101:110, group=rep(factor(groups, levels=groups), c(3, 7)) ) split(DF, DF$group) } \keyword{manip} S4Vectors/man/str-utils.Rd0000644000175100017510000001113612607264537016454 0ustar00biocbuildbiocbuild\name{str-utils} \alias{unstrsplit} \alias{unstrsplit,list-method} \alias{unstrsplit,character-method} \alias{safeExplode} \alias{strsplitAsListOfIntegerVectors} \alias{svn.time} \title{Some utility functions to operate on strings} \description{ Some low-level string utilities that operate on ordinary character vectors. For more advanced string manipulations, see the \pkg{Biostrings} package. } \usage{ unstrsplit(x, sep="") # 'sep' default is "" (empty string) strsplitAsListOfIntegerVectors(x, sep=",") # 'sep' default is "," } \arguments{ \item{x}{ For \code{unstrsplit}: A list-like object where each list element is a character vector, or a character vector (identity). For \code{strsplitAsListOfIntegerVectors}: A character vector where each element is a string containing comma-separated decimal integer values. } \item{sep}{ A single string containing the separator character. For \code{strsplitAsListOfIntegerVectors}, the separator must be a single-byte character. } } \details{ \subsection{unstrsplit}{ \code{unstrsplit(x, sep)} is equivalent to (but much faster than) \code{sapply(x, paste0, collapse=sep)}. It's performing the reverse transformation of \code{\link{strsplit}( , fixed=TRUE)}, that is, if \code{x} is a character vector with no NAs and \code{sep} a single string, then \code{unstrsplit(strsplit(x, split=sep, fixed=TRUE), sep)} is identical to \code{x}. A notable exception to this though is when \code{strsplit} finds a match at the end of a string, in which case the last element of the output (which should normally be an empty string) is not returned (see \code{?strsplit} for the details). } \subsection{strsplitAsListOfIntegerVectors}{ \code{strsplitAsListOfIntegerVectors} is similar to the \code{strsplitAsListOfIntegerVectors2} function shown in the Examples section below, except that the former generally raises an error where the latter would have inserted an \code{NA} in the returned object. More precisely: \itemize{ \item The latter accepts NAs in the input, the former doesn't (raises an error). \item The latter introduces NAs by coercion (with a warning), the former doesn't (raises an error). \item The latter supports "inaccurate integer conversion in coercion" when the value to coerce is > INT_MAX (then it's coerced to INT_MAX), the former doesn't (raises an error). \item The latter coerces non-integer values (e.g. 10.3) to an int by truncating them, the former doesn't (raises an error). } When it fails, \code{strsplitAsListOfIntegerVectors} will print an informative error message. Finally, \code{strsplitAsListOfIntegerVectors} is faster and uses much less memory than \code{strsplitAsListOfIntegerVectors2}. } } \value{ \code{unstrsplit} returns a character vector with one string per list element in \code{x}. \code{strsplitAsListOfIntegerVectors} returns a list where each list element is an integer vector. There is one list element per string in \code{x}. } \author{H. Pages} \seealso{ \itemize{ \item The \code{\link[base]{strsplit}} function in the \pkg{base} package. } } \examples{ ## --------------------------------------------------------------------- ## unstrsplit() ## --------------------------------------------------------------------- x <- list(A=c("abc", "XY"), B=NULL, C=letters[1:4]) unstrsplit(x) unstrsplit(x, sep=",") unstrsplit(x, sep=" => ") data(islands) x <- names(islands) y <- strsplit(x, split=" ", fixed=TRUE) x2 <- unstrsplit(y, sep=" ") stopifnot(identical(x, x2)) ## But... names(x) <- x y <- strsplit(x, split="in", fixed=TRUE) x2 <- unstrsplit(y, sep="in") y[x != x2] ## In other words: strsplit() behavior sucks :-/ ## --------------------------------------------------------------------- ## strsplitAsListOfIntegerVectors() ## --------------------------------------------------------------------- x <- c("1116,0,-19", " +55291 , 2476,", "19184,4269,5659,6470,6721,7469,14601", "7778889, 426900, -4833,5659,6470,6721,7096", "19184 , -99999") y <- strsplitAsListOfIntegerVectors(x) y ## In normal situations (i.e. when the input is well-formed), ## strsplitAsListOfIntegerVectors() does actually the same as the ## function below but is more efficient (both in speed and memory ## footprint): strsplitAsListOfIntegerVectors2 <- function(x, sep=",") { tmp <- strsplit(x, sep, fixed=TRUE) lapply(tmp, as.integer) } y2 <- strsplitAsListOfIntegerVectors2(x) stopifnot(identical(y, y2)) } \keyword{utilities} S4Vectors/man/subsetting-internals.Rd0000644000175100017510000000222112607264536020664 0ustar00biocbuildbiocbuild\name{subsetting-internals} \alias{subsetting-internals} \alias{class:NSBS} \alias{NSBS-class} \alias{length,NSBS-method} \alias{anyDuplicated.NSBS} \alias{anyDuplicated,NSBS-method} \alias{isStrictlySorted,NSBS-method} \alias{NSBS} \alias{NSBS,NSBS-method} \alias{NSBS,missing-method} \alias{NSBS,NULL-method} \alias{NSBS,numeric-method} \alias{NSBS,logical-method} \alias{NSBS,character-method} \alias{NSBS,factor-method} \alias{NSBS,array-method} \alias{as.integer,NativeNSBS-method} \alias{normalizeSingleBracketSubscript} \alias{normalizeSingleBracketReplacementValue} \alias{normalizeSingleBracketReplacementValue,ANY-method} \alias{extractROWS} \alias{replaceROWS} \alias{extractROWS,ANY-method} \alias{replaceROWS,ANY-method} \alias{extractROWS,NULL-method} \alias{replaceROWS,NULL-method} \alias{normalizeDoubleBracketSubscript} \alias{getListElement} \alias{setListElement} \title{Subsetting internals} \description{ Internal helper functions and classes defined in the \pkg{S4Vectors} package to support subsetting of vector-like objects. They are not intended to be used directly. } \keyword{internal} \keyword{classes} \keyword{methods} S4Vectors/src/0000755000175100017510000000000012607346177014232 5ustar00biocbuildbiocbuildS4Vectors/src/AEbufs.c0000644000175100017510000007336212607346177015556 0ustar00biocbuildbiocbuild/**************************************************************************** * Auto-Extending buffers * * * * Author: Herve Pages * ****************************************************************************/ #include "S4Vectors.h" #include /* for malloc, free, realloc */ #define MAX_BUFLENGTH_INC (32 * 1024 * 1024) #define MAX_BUFLENGTH (32 * MAX_BUFLENGTH_INC) static int debug = 0; SEXP debug_AEbufs() { #ifdef DEBUG_S4VECTORS debug = !debug; Rprintf("Debug mode turned %s in file %s\n", debug ? "on" : "off", __FILE__); #else Rprintf("Debug mode not available in file %s\n", __FILE__); #endif return R_NilValue; } /**************************************************************************** * Low-level memory management. */ static int use_malloc = 0; SEXP AEbufs_use_malloc(SEXP x) { use_malloc = LOGICAL(x)[0]; return R_NilValue; } /* 'nmemb' must be > 0. This is NOT checked! */ static void *alloc2(int nmemb, size_t size) { void *ptr; if (use_malloc) { //printf("alloc2: nmemb=%d\n", nmemb); size *= nmemb; ptr = malloc(size); if (ptr == NULL) error("S4Vectors internal error in alloc2(): " "cannot allocate memory"); } else { ptr = (void *) R_alloc(size, nmemb); } return ptr; } /* 'new_nmemb' must be > 'old_nmemb'. */ static void *realloc2(void *ptr, int new_nmemb, int old_nmemb, size_t size) { void *new_ptr; if (new_nmemb <= old_nmemb) error("S4Vectors internal error in realloc2(): " "'new_nmemb' <= 'old_nmemb'"); if (old_nmemb == 0) return alloc2(new_nmemb, size); if (use_malloc) { //printf("realloc2: new_nmemb=%d old_nmemb=%d\n", // new_nmemb, old_nmemb); size *= new_nmemb; new_ptr = realloc(ptr, size); if (new_ptr == NULL) error("S4Vectors internal error in realloc2(): " "cannot reallocate memory"); } else { new_ptr = (void *) R_alloc(size, new_nmemb); memcpy(new_ptr, ptr, size * old_nmemb); } return new_ptr; } /* Guaranteed to return a new buflength > 'buflength', or to raise an error. */ int _get_new_buflength(int buflength) { if (buflength >= MAX_BUFLENGTH) error("_get_new_buflength(): MAX_BUFLENGTH reached"); if (buflength == 0) return 128; if (buflength <= MAX_BUFLENGTH_INC) return 2 * buflength; buflength += MAX_BUFLENGTH_INC; if (buflength <= MAX_BUFLENGTH) return buflength; return MAX_BUFLENGTH; } /**************************************************************************** * IntAE buffers */ #define INTAE_POOL_MAXLEN 256 static IntAE *IntAE_pool[INTAE_POOL_MAXLEN]; static int IntAE_pool_len = 0; int _IntAE_get_nelt(const IntAE *ae) { return ae->_nelt; } int _IntAE_set_nelt(IntAE *ae, int nelt) { return ae->_nelt = nelt; } static IntAE *new_empty_IntAE() { IntAE *ae; if (use_malloc && IntAE_pool_len >= INTAE_POOL_MAXLEN) error("S4Vectors internal error in new_empty_IntAE(): " "IntAE pool is full"); ae = (IntAE *) alloc2(1, sizeof(IntAE)); ae->_buflength = ae->_nelt = 0; if (use_malloc) IntAE_pool[IntAE_pool_len++] = ae; return ae; } void _IntAE_set_val(const IntAE *ae, int val) { int nelt, i, *elt; nelt = _IntAE_get_nelt(ae); for (i = 0, elt = ae->elts; i < nelt; i++, elt++) *elt = val; return; } static void IntAE_extend(IntAE *ae, int new_buflength) { int old_buflength; old_buflength = ae->_buflength; if (new_buflength == -1) new_buflength = _get_new_buflength(old_buflength); ae->elts = (int *) realloc2(ae->elts, new_buflength, old_buflength, sizeof(int)); ae->_buflength = new_buflength; return; } void _IntAE_insert_at(IntAE *ae, int at, int val) { int nelt, i; int *elt1_p; const int *elt2_p; nelt = _IntAE_get_nelt(ae); if (nelt >= ae->_buflength) IntAE_extend(ae, -1); elt1_p = ae->elts + nelt; elt2_p = elt1_p - 1; for (i = nelt; i > at; i--) *(elt1_p--) = *(elt2_p--); *elt1_p = val; _IntAE_set_nelt(ae, nelt + 1); return; } IntAE *_new_IntAE(int buflength, int nelt, int val) { IntAE *ae; ae = new_empty_IntAE(); if (buflength != 0) { IntAE_extend(ae, buflength); _IntAE_set_nelt(ae, nelt); _IntAE_set_val(ae, val); } return ae; } void _IntAE_append(IntAE *ae, const int *newvals, int nnewval) { int new_nelt, *dest; new_nelt = _IntAE_get_nelt(ae) + nnewval; if (new_nelt > ae->_buflength) IntAE_extend(ae, new_nelt); dest = ae->elts + _IntAE_get_nelt(ae); memcpy(dest, newvals, nnewval * sizeof(int)); _IntAE_set_nelt(ae, new_nelt); return; } void _IntAE_delete_at(IntAE *ae, int at) { int *elt1_p; const int *elt2_p; int nelt0, i2; elt1_p = ae->elts + at; elt2_p = elt1_p + 1; nelt0 = _IntAE_get_nelt(ae); for (i2 = at + 1; i2 < nelt0; i2++) *(elt1_p++) = *(elt2_p++); _IntAE_set_nelt(ae, nelt0 - 1); return; } void _IntAE_shift(const IntAE *ae, int shift) { int nelt, i, *elt; nelt = _IntAE_get_nelt(ae); for (i = 0, elt = ae->elts; i < nelt; i++, elt++) *elt += shift; return; } /* * Left and right IntAE objects must have the same length. This is * NOT checked! */ void _IntAE_sum_and_shift(const IntAE *ae1, const IntAE *ae2, int shift) { int nelt, i, *elt1, *elt2; nelt = _IntAE_get_nelt(ae1); for (i = 0, elt1 = ae1->elts, elt2 = ae2->elts; i < nelt; i++, elt1++, elt2++) *elt1 += *elt2 + shift; return; } void _IntAE_append_shifted_vals(IntAE *ae, const int *newvals, int nnewval, int shift) { int nelt, new_nelt, i, *elt1; const int *elt2; nelt = _IntAE_get_nelt(ae); new_nelt = nelt + nnewval; if (new_nelt > ae->_buflength) IntAE_extend(ae, new_nelt); for (i = 0, elt1 = ae->elts + nelt, elt2 = newvals; i < nnewval; i++, elt1++, elt2++) *elt1 = *elt2 + shift; _IntAE_set_nelt(ae, new_nelt); return; } void _IntAE_qsort(const IntAE *ae, int desc) { _sort_int_array(ae->elts, _IntAE_get_nelt(ae), desc); return; } void _IntAE_delete_adjdups(IntAE *ae) { int nelt, *elt1; const int *elt2; int i2; nelt = _IntAE_get_nelt(ae); if (nelt <= 1) return; elt1 = ae->elts; elt2 = elt1 + 1; for (i2 = 1; i2 < nelt; i2++) { if (*elt2 != *elt1) { elt1++; *elt1 = *elt2; } elt2++; } _IntAE_set_nelt(ae, elt1 - ae->elts + 1); return; } SEXP _new_INTEGER_from_IntAE(const IntAE *ae) { int nelt; SEXP ans; nelt = _IntAE_get_nelt(ae); PROTECT(ans = NEW_INTEGER(nelt)); memcpy(INTEGER(ans), ae->elts, sizeof(int) * nelt); UNPROTECT(1); return ans; } static void copy_INTEGER_to_IntAE(SEXP x, IntAE *ae) { _IntAE_set_nelt(ae, LENGTH(x)); memcpy(ae->elts, INTEGER(x), sizeof(int) * LENGTH(x)); return; } IntAE *_new_IntAE_from_INTEGER(SEXP x) { IntAE *ae; ae = _new_IntAE(LENGTH(x), 0, 0); copy_INTEGER_to_IntAE(x, ae); return ae; } IntAE *_new_IntAE_from_CHARACTER(SEXP x, int keyshift) { IntAE *ae; int i, *elt; #ifdef DEBUG_S4VECTORS if (debug) { Rprintf("[DEBUG] _new_IntAE_from_CHARACTER(): BEGIN ... " "LENGTH(x)=%d keyshift=%d\n", LENGTH(x), keyshift); } #endif ae = _new_IntAE(LENGTH(x), 0, 0); _IntAE_set_nelt(ae, ae->_buflength); for (i = 0, elt = ae->elts; i < ae->_buflength; i++, elt++) { sscanf(CHAR(STRING_ELT(x, i)), "%d", elt); *elt += keyshift; #ifdef DEBUG_S4VECTORS if (debug) { if (i < 100 || i >= ae->_buflength - 100) Rprintf("[DEBUG] _new_IntAE_from_CHARACTER(): " "i=%d key=%s *elt=%d\n", i, CHAR(STRING_ELT(x, i)), *elt); } #endif } #ifdef DEBUG_S4VECTORS if (debug) { Rprintf("[DEBUG] _new_IntAE_from_CHARACTER(): END\n"); } #endif return ae; } /* Must be used on a malloc-based IntAE */ static void IntAE_free(IntAE *ae) { if (ae->_buflength != 0) free(ae->elts); free(ae); return; } static void flush_IntAE_pool() { IntAE *ae; #ifdef DEBUG_S4VECTORS if (debug && IntAE_pool_len != 0) { printf("flush_IntAE_pool: " "flushing %d IntAE buffers\n", IntAE_pool_len); fflush(stdout); } #endif while (IntAE_pool_len > 0) { IntAE_pool_len--; ae = IntAE_pool[IntAE_pool_len]; IntAE_free(ae); } return; } static int remove_from_IntAE_pool(const IntAE *ae) { int i; IntAE **ae1_p, **ae2_p; i = IntAE_pool_len; while (--i >= 0 && IntAE_pool[i] != ae) {;} if (i < 0) return -1; ae1_p = IntAE_pool + i; ae2_p = ae1_p + 1; for (i = i + 1; i < IntAE_pool_len; i++) *(ae1_p++) = *(ae2_p++); IntAE_pool_len--; return 0; } /**************************************************************************** * IntAEAE buffers */ #define INTAEAE_POOL_MAXLEN 256 static IntAEAE *IntAEAE_pool[INTAEAE_POOL_MAXLEN]; static int IntAEAE_pool_len = 0; int _IntAEAE_get_nelt(const IntAEAE *aeae) { return aeae->_nelt; } int _IntAEAE_set_nelt(IntAEAE *aeae, int nelt) { return aeae->_nelt = nelt; } static IntAEAE *new_empty_IntAEAE() { IntAEAE *aeae; if (use_malloc && IntAEAE_pool_len >= INTAEAE_POOL_MAXLEN) error("S4Vectors internal error in new_empty_IntAEAE(): " "IntAEAE pool is full"); aeae = (IntAEAE *) alloc2(1, sizeof(IntAEAE)); aeae->_buflength = aeae->_nelt = 0; if (use_malloc) IntAEAE_pool[IntAEAE_pool_len++] = aeae; return aeae; } static void IntAEAE_extend(IntAEAE *aeae, int new_buflength) { int old_buflength, i; old_buflength = aeae->_buflength; if (new_buflength == -1) new_buflength = _get_new_buflength(old_buflength); aeae->elts = (IntAE **) realloc2(aeae->elts, new_buflength, old_buflength, sizeof(IntAE *)); for (i = old_buflength; i < new_buflength; i++) aeae->elts[i] = NULL; aeae->_buflength = new_buflength; return; } void _IntAEAE_insert_at(IntAEAE *aeae, int at, IntAE *ae) { int nelt, i; IntAE **ae1_p, **ae2_p; nelt = _IntAEAE_get_nelt(aeae); if (nelt >= aeae->_buflength) IntAEAE_extend(aeae, -1); if (use_malloc && remove_from_IntAE_pool(ae) == -1) error("S4Vectors internal error in _IntAEAE_insert_at(): " "IntAE to insert cannot be found in pool for removal"); ae1_p = aeae->elts + nelt; ae2_p = ae1_p - 1; for (i = nelt; i > at; i--) *(ae1_p--) = *(ae2_p--); *ae1_p = ae; _IntAEAE_set_nelt(aeae, nelt + 1); return; } IntAEAE *_new_IntAEAE(int buflength, int nelt) { IntAEAE *aeae; int i; IntAE *ae; aeae = new_empty_IntAEAE(); if (buflength != 0) { IntAEAE_extend(aeae, buflength); for (i = 0; i < nelt; i++) { ae = new_empty_IntAE(); _IntAEAE_insert_at(aeae, i, ae); } } return aeae; } /* * Left and right IntAEAE objects must have the same length. This is * NOT checked! */ void _IntAEAE_eltwise_append(const IntAEAE *aeae1, const IntAEAE *aeae2) { int nelt, i; IntAE *ae1; const IntAE *ae2; nelt = _IntAEAE_get_nelt(aeae1); for (i = 0; i < nelt; i++) { ae1 = aeae1->elts[i]; ae2 = aeae2->elts[i]; _IntAE_append(ae1, ae2->elts, _IntAE_get_nelt(ae2)); } return; } void _IntAEAE_shift(const IntAEAE *aeae, int shift) { int nelt, i; IntAE *ae; nelt = _IntAEAE_get_nelt(aeae); for (i = 0; i < nelt; i++) { ae = aeae->elts[i]; _IntAE_shift(ae, shift); } return; } /* * Left and right IntAEAE objects must have the same length. This is * NOT checked! */ void _IntAEAE_sum_and_shift(const IntAEAE *aeae1, const IntAEAE *aeae2, int shift) { int nelt, i; IntAE *ae1; const IntAE *ae2; nelt = _IntAEAE_get_nelt(aeae1); for (i = 0; i < nelt; i++) { ae1 = aeae1->elts[i]; ae2 = aeae2->elts[i]; _IntAE_sum_and_shift(ae1, ae2, shift); } return; } /* * 'mode' controls how empty list elements should be represented: * 0 -> integer(0); 1 -> NULL; 2 -> NA */ SEXP _new_LIST_from_IntAEAE(const IntAEAE *aeae, int mode) { int nelt, i; SEXP ans, ans_elt; const IntAE *ae; nelt = _IntAEAE_get_nelt(aeae); PROTECT(ans = NEW_LIST(nelt)); for (i = 0; i < nelt; i++) { ae = aeae->elts[i]; if (_IntAE_get_nelt(ae) != 0 || mode == 0) { PROTECT(ans_elt = _new_INTEGER_from_IntAE(ae)); } else if (mode == 1) { continue; } else { // Not sure new LOGICALs are initialized with NAs, // need to check! If not, then LOGICAL(ans_elt)[0] must // be set to NA but I don't know how to do this :-/ PROTECT(ans_elt = NEW_LOGICAL(1)); } SET_VECTOR_ELT(ans, i, ans_elt); UNPROTECT(1); } UNPROTECT(1); return ans; } IntAEAE *_new_IntAEAE_from_LIST(SEXP x) { IntAEAE *aeae; int i; SEXP x_elt; IntAE *ae; aeae = _new_IntAEAE(LENGTH(x), 0); for (i = 0; i < aeae->_buflength; i++) { x_elt = VECTOR_ELT(x, i); if (TYPEOF(x_elt) != INTSXP) error("S4Vectors internal error in " "_new_IntAEAE_from_LIST(): " "not all elements in the list " "are integer vectors"); ae = _new_IntAE_from_INTEGER(x_elt); _IntAEAE_insert_at(aeae, i, ae); } return aeae; } SEXP _IntAEAE_toEnvir(const IntAEAE *aeae, SEXP envir, int keyshift) { int nelt, i; const IntAE *ae; char key[11]; SEXP value; nelt = _IntAEAE_get_nelt(aeae); #ifdef DEBUG_S4VECTORS int nkey = 0, cum_length = 0; if (debug) { Rprintf("[DEBUG] _IntAEAE_toEnvir(): BEGIN ... " "aeae->_nelt=%d keyshift=%d\n", nelt, keyshift); } #endif for (i = 0; i < nelt; i++) { ae = aeae->elts[i]; #ifdef DEBUG_S4VECTORS if (debug) { if (i < 100 || i >= nelt - 100) Rprintf("[DEBUG] _IntAEAE_toEnvir(): " "nkey=%d aeae->elts[%d]._nelt=%d\n", nkey, i, _IntAE_get_nelt(ae)); } #endif if (_IntAE_get_nelt(ae) == 0) continue; //snprintf(key, sizeof(key), "%d", i + keyshift); snprintf(key, sizeof(key), "%010d", i + keyshift); #ifdef DEBUG_S4VECTORS if (debug) { if (i < 100 || i >= nelt - 100) Rprintf("[DEBUG] _IntAEAE_toEnvir(): " "installing key=%s ... ", key); } #endif PROTECT(value = _new_INTEGER_from_IntAE(ae)); defineVar(install(key), value, envir); UNPROTECT(1); #ifdef DEBUG_S4VECTORS if (debug) { nkey++; cum_length += _IntAE_get_nelt(ae); if (i < 100 || i >= nelt - 100) Rprintf("OK (nkey=%d cum_length=%d)\n", nkey, cum_length); } #endif } #ifdef DEBUG_S4VECTORS if (debug) { Rprintf("[DEBUG] _IntAEAE_toEnvir(): END " "(nkey=%d cum_length=%d)\n", nkey, cum_length); } #endif return envir; } /* Must be used on a malloc-based IntAEAE */ static void IntAEAE_free(IntAEAE *aeae) { int buflength, i; IntAE *ae; buflength = aeae->_buflength; for (i = 0; i < buflength; i++) { ae = aeae->elts[i]; if (ae != NULL) IntAE_free(ae); } if (buflength != 0) free(aeae->elts); free(aeae); return; } static void flush_IntAEAE_pool() { IntAEAE *aeae; #ifdef DEBUG_S4VECTORS if (debug && IntAEAE_pool_len != 0) { printf("flush_IntAEAE_pool: " "flushing %d IntAEAE buffers\n", IntAEAE_pool_len); fflush(stdout); } #endif while (IntAEAE_pool_len > 0) { IntAEAE_pool_len--; aeae = IntAEAE_pool[IntAEAE_pool_len]; IntAEAE_free(aeae); } return; } /**************************************************************************** * IntPairAE buffers */ #define INTPAIRAE_POOL_MAXLEN 256 static IntPairAE *IntPairAE_pool[INTPAIRAE_POOL_MAXLEN]; static int IntPairAE_pool_len = 0; int _IntPairAE_get_nelt(const IntPairAE *ae) { return _IntAE_get_nelt(ae->a); } int _IntPairAE_set_nelt(IntPairAE *ae, int nelt) { _IntAE_set_nelt(ae->a, nelt); _IntAE_set_nelt(ae->b, nelt); return nelt; } static IntPairAE *new_empty_IntPairAE() { IntAE *a, *b; IntPairAE *ae; if (use_malloc && IntPairAE_pool_len >= INTPAIRAE_POOL_MAXLEN) error("S4Vectors internal error in new_empty_IntPairAE(): " "IntPairAE pool is full"); a = new_empty_IntAE(); b = new_empty_IntAE(); ae = (IntPairAE *) alloc2(1, sizeof(IntPairAE)); ae->a = a; ae->b = b; if (use_malloc) { if (remove_from_IntAE_pool(a) == -1 || remove_from_IntAE_pool(b) == -1) error("S4Vectors internal error " "in new_empty_IntPairAE(): " "IntAEs to stick in IntPairAE cannot be found " "in pool for removal"); IntPairAE_pool[IntPairAE_pool_len++] = ae; } return ae; } static void IntPairAE_extend(IntPairAE *ae, int new_buflength) { IntAE_extend(ae->a, new_buflength); IntAE_extend(ae->b, new_buflength); return; } void _IntPairAE_insert_at(IntPairAE *ae, int at, int a, int b) { _IntAE_insert_at(ae->a, at, a); _IntAE_insert_at(ae->b, at, b); return; } IntPairAE *_new_IntPairAE(int buflength, int nelt) { IntPairAE *ae; ae = new_empty_IntPairAE(); if (buflength != 0) { IntPairAE_extend(ae, buflength); /* Elements are NOT initialized. */ _IntPairAE_set_nelt(ae, nelt); } return ae; } /* Must be used on a malloc-based IntPairAE */ static void IntPairAE_free(IntPairAE *ae) { IntAE_free(ae->a); IntAE_free(ae->b); free(ae); return; } static void flush_IntPairAE_pool() { IntPairAE *ae; #ifdef DEBUG_S4VECTORS if (debug && IntPairAE_pool_len != 0) { printf("flush_IntPairAE_pool: " "flushing %d IntPairAE buffers\n", IntPairAE_pool_len); fflush(stdout); } #endif while (IntPairAE_pool_len > 0) { IntPairAE_pool_len--; ae = IntPairAE_pool[IntPairAE_pool_len]; IntPairAE_free(ae); } return; } static int remove_from_IntPairAE_pool(const IntPairAE *ae) { int i; IntPairAE **ae1_p, **ae2_p; i = IntPairAE_pool_len; while (--i >= 0 && IntPairAE_pool[i] != ae) {;} if (i < 0) return -1; ae1_p = IntPairAE_pool + i; ae2_p = ae1_p + 1; for (i = i + 1; i < IntPairAE_pool_len; i++) *(ae1_p++) = *(ae2_p++); IntPairAE_pool_len--; return 0; } /**************************************************************************** * IntPairAEAE buffers */ #define INTPAIRAEAE_POOL_MAXLEN 256 static IntPairAEAE *IntPairAEAE_pool[INTPAIRAEAE_POOL_MAXLEN]; static int IntPairAEAE_pool_len = 0; int _IntPairAEAE_get_nelt(const IntPairAEAE *aeae) { return aeae->_nelt; } int _IntPairAEAE_set_nelt(IntPairAEAE *aeae, int nelt) { return aeae->_nelt = nelt; } static IntPairAEAE *new_empty_IntPairAEAE() { IntPairAEAE *aeae; if (use_malloc && IntPairAEAE_pool_len >= INTPAIRAEAE_POOL_MAXLEN) error("S4Vectors internal error in new_empty_IntPairAEAE(): " "IntPairAEAE pool is full"); aeae = (IntPairAEAE *) alloc2(1, sizeof(IntPairAEAE)); aeae->_buflength = aeae->_nelt = 0; if (use_malloc) IntPairAEAE_pool[IntPairAEAE_pool_len++] = aeae; return aeae; } static void IntPairAEAE_extend(IntPairAEAE *aeae, int new_buflength) { int old_buflength, i; old_buflength = aeae->_buflength; if (new_buflength == -1) new_buflength = _get_new_buflength(old_buflength); aeae->elts = (IntPairAE **) realloc2(aeae->elts, new_buflength, old_buflength, sizeof(IntPairAE *)); for (i = old_buflength; i < new_buflength; i++) aeae->elts[i] = NULL; aeae->_buflength = new_buflength; return; } void _IntPairAEAE_insert_at(IntPairAEAE *aeae, int at, IntPairAE *ae) { int nelt, i; IntPairAE **ae1_p, **ae2_p; nelt = _IntPairAEAE_get_nelt(aeae); if (nelt >= aeae->_buflength) IntPairAEAE_extend(aeae, -1); if (use_malloc && remove_from_IntPairAE_pool(ae) == -1) error("S4Vectors internal error in _IntPairAEAE_insert_at(): " "IntPairAE to insert cannot be found in pool for " "removal"); ae1_p = aeae->elts + nelt; ae2_p = ae1_p - 1; for (i = nelt; i > at; i--) *(ae1_p--) = *(ae2_p--); *ae1_p = ae; _IntPairAEAE_set_nelt(aeae, nelt + 1); return; } IntPairAEAE *_new_IntPairAEAE(int buflength, int nelt) { IntPairAEAE *aeae; int i; IntPairAE *ae; aeae = new_empty_IntPairAEAE(); if (buflength != 0) { IntPairAEAE_extend(aeae, buflength); for (i = 0; i < nelt; i++) { ae = new_empty_IntPairAE(); _IntPairAEAE_insert_at(aeae, i, ae); } } return aeae; } /* Must be used on a malloc-based IntPairAEAE */ static void IntPairAEAE_free(IntPairAEAE *aeae) { int buflength, i; IntPairAE *ae; buflength = aeae->_buflength; for (i = 0; i < buflength; i++) { ae = aeae->elts[i]; if (ae != NULL) IntPairAE_free(ae); } if (buflength != 0) free(aeae->elts); free(aeae); return; } static void flush_IntPairAEAE_pool() { IntPairAEAE *aeae; #ifdef DEBUG_S4VECTORS if (debug && IntPairAEAE_pool_len != 0) { printf("flush_IntPairAEAE_pool: " "flushing %d IntPairAEAE buffers\n", IntPairAEAE_pool_len); fflush(stdout); } #endif while (IntPairAEAE_pool_len > 0) { IntPairAEAE_pool_len--; aeae = IntPairAEAE_pool[IntPairAEAE_pool_len]; IntPairAEAE_free(aeae); } return; } /**************************************************************************** * LLongAE buffers */ #define LLONGAE_POOL_MAXLEN 256 static LLongAE *LLongAE_pool[LLONGAE_POOL_MAXLEN]; static int LLongAE_pool_len = 0; int _LLongAE_get_nelt(const LLongAE *ae) { return ae->_nelt; } int _LLongAE_set_nelt(LLongAE *ae, int nelt) { return ae->_nelt = nelt; } static LLongAE *new_empty_LLongAE() { LLongAE *ae; if (use_malloc && LLongAE_pool_len >= LLONGAE_POOL_MAXLEN) error("S4Vectors internal error in new_empty_LLongAE(): " "LLongAE pool is full"); ae = (LLongAE *) alloc2(1, sizeof(LLongAE)); ae->_buflength = ae->_nelt = 0; if (use_malloc) LLongAE_pool[LLongAE_pool_len++] = ae; return ae; } void _LLongAE_set_val(const LLongAE *ae, long long val) { int nelt, i; long long *elt; nelt = _LLongAE_get_nelt(ae); for (i = 0, elt = ae->elts; i < nelt; i++, elt++) *elt = val; return; } static void LLongAE_extend(LLongAE *ae, int new_buflength) { int old_buflength; old_buflength = ae->_buflength; if (new_buflength == -1) new_buflength = _get_new_buflength(old_buflength); ae->elts = (long long *) realloc2(ae->elts, new_buflength, old_buflength, sizeof(long long)); ae->_buflength = new_buflength; return; } void _LLongAE_insert_at(LLongAE *ae, int at, long long val) { int nelt, i; long long *elt1_p; const long long *elt2_p; nelt = _LLongAE_get_nelt(ae); if (nelt >= ae->_buflength) LLongAE_extend(ae, -1); elt1_p = ae->elts + nelt; elt2_p = elt1_p - 1; for (i = nelt; i > at; i--) *(elt1_p--) = *(elt2_p--); *elt1_p = val; _LLongAE_set_nelt(ae, nelt + 1); return; } LLongAE *_new_LLongAE(int buflength, int nelt, long long val) { LLongAE *ae; ae = new_empty_LLongAE(); if (buflength != 0) { LLongAE_extend(ae, buflength); _LLongAE_set_nelt(ae, nelt); _LLongAE_set_val(ae, val); } return ae; } /* Must be used on a malloc-based LLongAE */ static void LLongAE_free(LLongAE *ae) { if (ae->_buflength != 0) free(ae->elts); free(ae); return; } static void flush_LLongAE_pool() { LLongAE *ae; #ifdef DEBUG_S4VECTORS if (debug && LLongAE_pool_len != 0) { printf("flush_LLongAE_pool: " "flushing %d LLongAE buffers\n", LLongAE_pool_len); fflush(stdout); } #endif while (LLongAE_pool_len > 0) { LLongAE_pool_len--; ae = LLongAE_pool[LLongAE_pool_len]; LLongAE_free(ae); } return; } /**************************************************************************** * CharAE buffers */ #define CHARAE_POOL_MAXLEN 256 static CharAE *CharAE_pool[CHARAE_POOL_MAXLEN]; static int CharAE_pool_len = 0; int _CharAE_get_nelt(const CharAE *ae) { return ae->_nelt; } int _CharAE_set_nelt(CharAE *ae, int nelt) { return ae->_nelt = nelt; } static CharAE *new_empty_CharAE() { CharAE *ae; if (use_malloc && CharAE_pool_len >= CHARAE_POOL_MAXLEN) error("S4Vectors internal error in new_empty_CharAE(): " "CharAE pool is full"); ae = (CharAE *) alloc2(1, sizeof(CharAE)); ae->_buflength = ae->_nelt = 0; if (use_malloc) CharAE_pool[CharAE_pool_len++] = ae; return ae; } static void CharAE_extend(CharAE *ae, int new_buflength) { int old_buflength; old_buflength = ae->_buflength; if (new_buflength == -1) new_buflength = _get_new_buflength(old_buflength); ae->elts = (char *) realloc2(ae->elts, new_buflength, old_buflength, sizeof(char)); ae->_buflength = new_buflength; return; } void _CharAE_insert_at(CharAE *ae, int at, char c) { int nelt, i; char *elt1_p; const char *elt2_p; nelt = _CharAE_get_nelt(ae); if (nelt >= ae->_buflength) CharAE_extend(ae, -1); elt1_p = ae->elts + nelt; elt2_p = elt1_p - 1; for (i = nelt; i > at; i--) *(elt1_p--) = *(elt2_p--); *elt1_p = c; _CharAE_set_nelt(ae, nelt + 1); return; } CharAE *_new_CharAE(int buflength) { CharAE *ae; ae = new_empty_CharAE(); if (buflength != 0) CharAE_extend(ae, buflength); return ae; } CharAE *_new_CharAE_from_string(const char *string) { CharAE *ae; ae = _new_CharAE(strlen(string)); _CharAE_set_nelt(ae, ae->_buflength); memcpy(ae->elts, string, ae->_buflength); return ae; } void _append_string_to_CharAE(CharAE *ae, const char *string) { int nnewval, nelt, new_nelt; char *dest; nnewval = strlen(string); nelt = _CharAE_get_nelt(ae); new_nelt = nelt + nnewval; if (new_nelt > ae->_buflength) CharAE_extend(ae, new_nelt); dest = ae->elts + nelt; memcpy(dest, string, sizeof(char) * nnewval); _CharAE_set_nelt(ae, new_nelt); return; } /* * Delete 'nelt' elements, starting at position 'at'. * Doing _CharAE_delete_at(x, at, nelt) is equivalent to doing * _CharAE_delete_at(x, at, 1) 'nelt' times. */ void _CharAE_delete_at(CharAE *ae, int at, int nelt) { char *c1_p; const char *c2_p; int nelt0, i2; if (nelt == 0) return; c1_p = ae->elts + at; c2_p = c1_p + nelt; nelt0 = _CharAE_get_nelt(ae); for (i2 = at + nelt; i2 < nelt0; i2++) *(c1_p++) = *(c2_p++); _CharAE_set_nelt(ae, nelt0 - nelt); return; } SEXP _new_RAW_from_CharAE(const CharAE *ae) { int nelt; SEXP ans; if (sizeof(Rbyte) != sizeof(char)) // should never happen! error("_new_RAW_from_CharAE(): sizeof(Rbyte) != sizeof(char)"); nelt = _CharAE_get_nelt(ae); PROTECT(ans = NEW_RAW(nelt)); memcpy(RAW(ans), ae->elts, sizeof(char) * nelt); UNPROTECT(1); return ans; } /* only until we have a bitset or something smaller than char */ SEXP _new_LOGICAL_from_CharAE(const CharAE *ae) { int nelt, i, *ans_elt; SEXP ans; const char *elt; nelt = _CharAE_get_nelt(ae); PROTECT(ans = NEW_LOGICAL(nelt)); for (i = 0, ans_elt = LOGICAL(ans), elt = ae->elts; i < nelt; i++, ans_elt++, elt++) { *ans_elt = *elt; } UNPROTECT(1); return ans; } /* Must be used on a malloc-based CharAE */ static void CharAE_free(CharAE *ae) { if (ae->_buflength != 0) free(ae->elts); free(ae); return; } static void flush_CharAE_pool() { CharAE *ae; #ifdef DEBUG_S4VECTORS if (debug && CharAE_pool_len != 0) { printf("flush_CharAE_pool: " "flushing %d CharAE buffers\n", CharAE_pool_len); fflush(stdout); } #endif while (CharAE_pool_len > 0) { CharAE_pool_len--; ae = CharAE_pool[CharAE_pool_len]; CharAE_free(ae); } return; } static int remove_from_CharAE_pool(const CharAE *ae) { int i; CharAE **ae1_p, **ae2_p; i = CharAE_pool_len; while (--i >= 0 && CharAE_pool[i] != ae) {;} if (i < 0) return -1; ae1_p = CharAE_pool + i; ae2_p = ae1_p + 1; for (i = i + 1; i < CharAE_pool_len; i++) *(ae1_p++) = *(ae2_p++); CharAE_pool_len--; return 0; } /**************************************************************************** * CharAEAE buffers */ #define CHARAEAE_POOL_MAXLEN 256 static CharAEAE *CharAEAE_pool[CHARAEAE_POOL_MAXLEN]; static int CharAEAE_pool_len = 0; int _CharAEAE_get_nelt(const CharAEAE *aeae) { return aeae->_nelt; } int _CharAEAE_set_nelt(CharAEAE *aeae, int nelt) { return aeae->_nelt = nelt; } static CharAEAE *new_empty_CharAEAE() { CharAEAE *aeae; if (use_malloc && CharAEAE_pool_len >= CHARAEAE_POOL_MAXLEN) error("S4Vectors internal error in new_empty_CharAEAE(): " "CharAEAE pool is full"); aeae = (CharAEAE *) alloc2(1, sizeof(CharAEAE)); aeae->_buflength = aeae->_nelt = 0; if (use_malloc) CharAEAE_pool[CharAEAE_pool_len++] = aeae; return aeae; } static void CharAEAE_extend(CharAEAE *aeae, int new_buflength) { int old_buflength, i; old_buflength = aeae->_buflength; if (new_buflength == -1) new_buflength = _get_new_buflength(old_buflength); aeae->elts = (CharAE **) realloc2(aeae->elts, new_buflength, old_buflength, sizeof(CharAE *)); for (i = old_buflength; i < new_buflength; i++) aeae->elts[i] = NULL; aeae->_buflength = new_buflength; return; } void _CharAEAE_insert_at(CharAEAE *aeae, int at, CharAE *ae) { int nelt, i; CharAE **ae1_p, **ae2_p; nelt = _CharAEAE_get_nelt(aeae); if (nelt >= aeae->_buflength) CharAEAE_extend(aeae, -1); if (use_malloc && remove_from_CharAE_pool(ae) == -1) error("S4Vectors internal error in _CharAEAE_insert_at(): " "CharAE to insert cannot be found in pool for removal"); ae1_p = aeae->elts + nelt; ae2_p = ae1_p - 1; for (i = nelt; i > at; i--) *(ae1_p--) = *(ae2_p--); *ae1_p = ae; _CharAEAE_set_nelt(aeae, nelt + 1); return; } CharAEAE *_new_CharAEAE(int buflength, int nelt) { CharAEAE *aeae; int i; CharAE *ae; aeae = new_empty_CharAEAE(); if (buflength != 0) { CharAEAE_extend(aeae, buflength); for (i = 0; i < nelt; i++) { ae = new_empty_CharAE(); _CharAEAE_insert_at(aeae, i, ae); } } return aeae; } void _append_string_to_CharAEAE(CharAEAE *aeae, const char *string) { CharAE *ae; ae = _new_CharAE_from_string(string); _CharAEAE_insert_at(aeae, _CharAEAE_get_nelt(aeae), ae); return; } SEXP _new_CHARACTER_from_CharAEAE(const CharAEAE *aeae) { int nelt, i; SEXP ans, ans_elt; CharAE *ae; nelt = _CharAEAE_get_nelt(aeae); PROTECT(ans = NEW_CHARACTER(nelt)); for (i = 0; i < nelt; i++) { ae = aeae->elts[i]; PROTECT(ans_elt = mkCharLen(ae->elts, _CharAE_get_nelt(ae))); SET_STRING_ELT(ans, i, ans_elt); UNPROTECT(1); } UNPROTECT(1); return ans; } /* Must be used on a malloc-based CharAEAE */ static void CharAEAE_free(CharAEAE *aeae) { int buflength, i; CharAE *ae; buflength = aeae->_buflength; for (i = 0; i < buflength; i++) { ae = aeae->elts[i]; if (ae != NULL) CharAE_free(ae); } if (buflength != 0) free(aeae->elts); free(aeae); return; } static void flush_CharAEAE_pool() { CharAEAE *aeae; #ifdef DEBUG_S4VECTORS if (debug && CharAEAE_pool_len != 0) { printf("flush_CharAEAE_pool: " "flushing %d CharAEAE buffers\n", CharAEAE_pool_len); fflush(stdout); } #endif while (CharAEAE_pool_len > 0) { CharAEAE_pool_len--; aeae = CharAEAE_pool[CharAEAE_pool_len]; CharAEAE_free(aeae); } return; } /**************************************************************************** * Freeing the malloc-based AEbufs. */ SEXP AEbufs_free() { flush_IntAE_pool(); flush_IntAEAE_pool(); flush_IntPairAE_pool(); flush_IntPairAEAE_pool(); flush_LLongAE_pool(); flush_CharAE_pool(); flush_CharAEAE_pool(); return R_NilValue; } S4Vectors/src/DataFrame_class.c0000644000175100017510000000145712607346177017416 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of DataFrame objects ****************************************************************************/ #include "S4Vectors.h" static SEXP rownames_symbol = NULL, nrows_symbol = NULL; static void set_DataFrame_rownames(SEXP x, SEXP value) { INIT_STATIC_SYMBOL(rownames) SET_SLOT(x, rownames_symbol, value); } static void set_DataFrame_nrows(SEXP x, SEXP value) { INIT_STATIC_SYMBOL(nrows) SET_SLOT(x, nrows_symbol, value); } SEXP _new_DataFrame(const char *classname, SEXP vars, SEXP rownames, SEXP nrows) { SEXP ans; PROTECT(ans = _new_SimpleList(classname, vars)); set_DataFrame_rownames(ans, rownames); set_DataFrame_nrows(ans, nrows); UNPROTECT(1); return ans; } S4Vectors/src/Hits_class.c0000644000175100017510000002363412607346177016502 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of Hits objects * ****************************************************************************/ #include "S4Vectors.h" /**************************************************************************** * C-level constructors */ static SEXP new_Hits0(SEXP queryHits, SEXP subjectHits, int q_len, int s_len) { SEXP classdef, ans, ans_queryLength, ans_subjectLength; PROTECT(classdef = MAKE_CLASS("Hits")); PROTECT(ans = NEW_OBJECT(classdef)); SET_SLOT(ans, install("queryHits"), queryHits); SET_SLOT(ans, install("subjectHits"), subjectHits); PROTECT(ans_queryLength = ScalarInteger(q_len)); SET_SLOT(ans, install("queryLength"), ans_queryLength); UNPROTECT(1); PROTECT(ans_subjectLength = ScalarInteger(s_len)); SET_SLOT(ans, install("subjectLength"), ans_subjectLength); UNPROTECT(1); UNPROTECT(2); return ans; } static SEXP new_Hits1(const int *q_hits, const int *s_hits, int nhit, int q_len, int s_len) { SEXP ans_queryHits, ans_subjectHits, ans; size_t n; PROTECT(ans_queryHits = NEW_INTEGER(nhit)); PROTECT(ans_subjectHits = NEW_INTEGER(nhit)); n = sizeof(int) * nhit; memcpy(INTEGER(ans_queryHits), q_hits, n); memcpy(INTEGER(ans_subjectHits), s_hits, n); ans = new_Hits0(ans_queryHits, ans_subjectHits, q_len, s_len); UNPROTECT(2); return ans; } /**************************************************************************** * High-level user-friendly constructor */ /* Based on qsort(). Time is O(nhit*log(nhit)). If 'revmap' is not NULL, then 'qh_in' is not modified. */ static void qsort_hits(int *qh_in, const int *sh_in, int *qh_out, int *sh_out, int nhit, int *revmap) { int k; if (revmap == NULL) revmap = sh_out; _get_order_of_int_array(qh_in, nhit, 0, revmap, 0); for (k = 0; k < nhit; k++) qh_out[k] = qh_in[revmap[k]]; if (revmap == sh_out) { memcpy(qh_in, revmap, sizeof(int) * nhit); revmap = qh_in; } for (k = 0; k < nhit; k++) sh_out[k] = sh_in[revmap[k]++]; return; } /* Tabulated sorting. Time is O(nhit). WARNINGS: 'nhit' MUST be >= 'q_len'. 'qh_in' is ALWAYS modified. */ static void tsort_hits(int *qh_in, const int *sh_in, int *qh_out, int *sh_out, int nhit, int q_len, int *revmap) { int i, k, offset, count, prev_offset, j; /* Compute nb of hits per query. We need a place for this so we temporarily use 'qh_out' which is assumed to have at least 'q_len' elements. */ for (i = 0; i < q_len; i++) qh_out[i] = 0; for (k = 0; k < nhit; k++) qh_out[--qh_in[k]]++; /* make 'qh_in[k]' 0-based */ /* Replace counts with offsets. */ offset = 0; for (i = 0; i < q_len; i++) { count = qh_out[i]; qh_out[i] = offset; offset += count; } /* Fill 'sh_out' and 'revmap'. */ for (k = 0; k < nhit; k++) { offset = qh_out[qh_in[k]]++; sh_out[offset] = sh_in[k]; if (revmap != NULL) revmap[offset] = k + 1; } /* Fill 'qh_out'. */ memcpy(qh_in, qh_out, sizeof(int) * q_len); k = offset = 0; for (i = 1; i <= q_len; i++) { prev_offset = offset; offset = qh_in[i - 1]; for (j = prev_offset; j < offset; j++) qh_out[k++] = i; } return; } SEXP _new_Hits(int *q_hits, const int *s_hits, int nhit, int q_len, int s_len, int already_sorted) { SEXP ans_queryHits, ans_subjectHits, ans; int *qh_out, *sh_out; if (already_sorted || nhit <= 1 || q_len <= 1) return new_Hits1(q_hits, s_hits, nhit, q_len, s_len); PROTECT(ans_queryHits = NEW_INTEGER(nhit)); PROTECT(ans_subjectHits = NEW_INTEGER(nhit)); qh_out = INTEGER(ans_queryHits); sh_out = INTEGER(ans_subjectHits); if (nhit >= q_len) tsort_hits(q_hits, s_hits, qh_out, sh_out, nhit, q_len, NULL); else qsort_hits(q_hits, s_hits, qh_out, sh_out, nhit, NULL); ans = new_Hits0(ans_queryHits, ans_subjectHits, q_len, s_len); UNPROTECT(2); return ans; } static SEXP new_Hits_with_revmap( const int *q_hits, const int *s_hits, int nhit, int q_len, int s_len, int *revmap) { SEXP ans_queryHits, ans_subjectHits, ans; int *q_hits2, *qh_out, *sh_out; if (revmap == NULL || nhit >= q_len) { q_hits2 = (int *) R_alloc(sizeof(int), nhit); memcpy(q_hits2, q_hits, sizeof(int) * nhit); } if (revmap == NULL) return _new_Hits(q_hits2, s_hits, nhit, q_len, s_len, 0); PROTECT(ans_queryHits = NEW_INTEGER(nhit)); PROTECT(ans_subjectHits = NEW_INTEGER(nhit)); qh_out = INTEGER(ans_queryHits); sh_out = INTEGER(ans_subjectHits); if (nhit >= q_len) { tsort_hits(q_hits2, s_hits, qh_out, sh_out, nhit, q_len, revmap); } else { qsort_hits((int *) q_hits, s_hits, qh_out, sh_out, nhit, revmap); } ans = new_Hits0(ans_queryHits, ans_subjectHits, q_len, s_len); UNPROTECT(2); return ans; } static int get_q_len_or_s_len(SEXP len, const char *what) { int len0; if (!IS_INTEGER(len) || LENGTH(len) != 1) error("'%s' must be a single integer", what); len0 = INTEGER(len)[0]; if (len0 == NA_INTEGER || len0 < 0) error("'%s' must be a single non-negative integer", what); return len0; } /* Return 1 if 'q_hits' is already sorted and 0 otherwise. */ static int check_hits(const int *q_hits, const int *s_hits, int nhit, int q_len, int s_len) { int already_sorted, prev_i, k, i, j; already_sorted = 1; prev_i = -1; for (k = 0; k < nhit; k++, q_hits++, s_hits++) { i = *q_hits; if (i == NA_INTEGER || i < 1 || i > q_len) error("'queryHits' must contain non-NA values " ">= 1 and <= 'queryLength'"); if (i < prev_i) already_sorted = 0; prev_i = i; j = *s_hits; if (j == NA_INTEGER || j < 1 || j > s_len) error("'subjectHits' must contain non-NA values " ">= 1 and <= 'subjectLength'"); } return already_sorted; } /* --- .Call ENTRY POINT --- */ SEXP Hits_new(SEXP q_hits, SEXP s_hits, SEXP q_len, SEXP s_len, SEXP revmap_envir) { int nhit, q_len0, s_len0, already_sorted, *revmap_p; const int *q_hits_p, *s_hits_p; SEXP ans, revmap, symbol; nhit = _check_integer_pairs(q_hits, s_hits, &q_hits_p, &s_hits_p, "queryHits", "subjectHits"); q_len0 = get_q_len_or_s_len(q_len, "queryLength"); s_len0 = get_q_len_or_s_len(s_len, "subjectLength"); already_sorted = check_hits(q_hits_p, s_hits_p, nhit, q_len0, s_len0); if (already_sorted) return new_Hits1(q_hits_p, s_hits_p, nhit, q_len0, s_len0); if (revmap_envir == R_NilValue) { revmap_p = NULL; } else { PROTECT(revmap = NEW_INTEGER(nhit)); revmap_p = INTEGER(revmap); } PROTECT(ans = new_Hits_with_revmap(q_hits_p, s_hits_p, nhit, q_len0, s_len0, revmap_p)); if (revmap_envir == R_NilValue) { UNPROTECT(1); return ans; } PROTECT(symbol = mkChar("revmap")); defineVar(install(translateChar(symbol)), revmap, revmap_envir); UNPROTECT(3); return ans; } /**************************************************************************** * select_hits() */ int _get_select_mode(SEXP select) { const char *select0; if (!IS_CHARACTER(select) || LENGTH(select) != 1) error("'select' must be a single string"); select = STRING_ELT(select, 0); if (select == NA_STRING) error("'select' cannot be NA"); select0 = CHAR(select); if (strcmp(select0, "all") == 0) return ALL_HITS; if (strcmp(select0, "first") == 0) return FIRST_HIT; if (strcmp(select0, "last") == 0) return LAST_HIT; if (strcmp(select0, "arbitrary") == 0) return ARBITRARY_HIT; if (strcmp(select0, "count") == 0) return COUNT_HITS; error("'select' must be \"all\", \"first\", " "\"last\", \"arbitrary\", or \"count\""); return 0; } /* --- .Call ENTRY POINT --- */ SEXP select_hits(SEXP q_hits, SEXP s_hits, SEXP q_len, SEXP select) { int nhit, ans_len, select_mode, init_val, i, k, j1; const int *q_hits_p, *s_hits_p; SEXP ans; nhit = _check_integer_pairs(q_hits, s_hits, &q_hits_p, &s_hits_p, "queryHits(x)", "subjectHits(x)"); ans_len = INTEGER(q_len)[0]; select_mode = _get_select_mode(select); PROTECT(ans = NEW_INTEGER(ans_len)); init_val = select_mode == COUNT_HITS ? 0 : NA_INTEGER; for (i = 0; i < ans_len; i++) INTEGER(ans)[i] = init_val; for (k = 0; k < nhit; k++, q_hits_p++, s_hits_p++) { i = *q_hits_p - 1; if (select_mode == COUNT_HITS) { INTEGER(ans)[i]++; continue; } j1 = *s_hits_p; if (INTEGER(ans)[i] == NA_INTEGER || (select_mode == FIRST_HIT) == (j1 < INTEGER(ans)[i])) INTEGER(ans)[i] = j1; } UNPROTECT(1); return ans; } /**************************************************************************** * make_all_group_inner_hits() * * --- .Call ENTRY POINT --- * 'hit_type' must be 0, -1 or 1 (single integer). */ SEXP make_all_group_inner_hits(SEXP group_sizes, SEXP hit_type) { int ngroup, htype, ans_len, i, j, k, gs, nhit, iofeig, *left, *right; const int *group_sizes_elt; SEXP ans_q_hits, ans_s_hits, ans; ngroup = LENGTH(group_sizes); htype = INTEGER(hit_type)[0]; for (i = ans_len = 0, group_sizes_elt = INTEGER(group_sizes); i < ngroup; i++, group_sizes_elt++) { gs = *group_sizes_elt; if (gs == NA_INTEGER || gs < 0) error("'group_sizes' contains NAs or negative values"); nhit = htype == 0 ? gs * gs : (gs * (gs - 1)) / 2; ans_len += nhit; } PROTECT(ans_q_hits = NEW_INTEGER(ans_len)); PROTECT(ans_s_hits = NEW_INTEGER(ans_len)); left = INTEGER(ans_q_hits); right = INTEGER(ans_s_hits); iofeig = 0; /* 0-based Index Of First Element In Group */ for (i = 0, group_sizes_elt = INTEGER(group_sizes); i < ngroup; i++, group_sizes_elt++) { gs = *group_sizes_elt; if (htype > 0) { for (j = 1; j < gs; j++) { for (k = j + 1; k <= gs; k++) { *(left++) = j + iofeig; *(right++) = k + iofeig; } } } else if (htype < 0) { for (j = 2; j <= gs; j++) { for (k = 1; k < j; k++) { *(left++) = j + iofeig; *(right++) = k + iofeig; } } } else { for (j = 1; j <= gs; j++) { for (k = 1; k <= gs; k++) { *(left++) = j + iofeig; *(right++) = k + iofeig; } } } iofeig += gs; } ans = new_Hits0(ans_q_hits, ans_s_hits, iofeig, iofeig); UNPROTECT(2); return ans; } S4Vectors/src/List_class.c0000644000175100017510000000165512607346177016505 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of List objects * * Authors: Patrick Aboyoun, Michael Lawrence, Herve Pages * ****************************************************************************/ #include "S4Vectors.h" /**************************************************************************** * C-level slot getters. */ static SEXP elementType_symbol = NULL; const char *_get_List_elementType(SEXP x) { INIT_STATIC_SYMBOL(elementType) return CHAR(STRING_ELT(GET_SLOT(x, elementType_symbol), 0)); } /**************************************************************************** * C-level slot setters. */ void _set_List_elementType(SEXP x, const char *type) { SEXP value; INIT_STATIC_SYMBOL(elementType) PROTECT(value = mkString(type)); SET_SLOT(x, elementType_symbol, value); UNPROTECT(1); return; } S4Vectors/src/R_init_S4Vectors.c0000644000175100017510000001503112607346177017536 0ustar00biocbuildbiocbuild#include "S4Vectors.h" #define CALLMETHOD_DEF(fun, numArgs) {#fun, (DL_FUNC) &fun, numArgs} #define REGISTER_CCALLABLE(fun) \ R_RegisterCCallable("S4Vectors", #fun, (DL_FUNC) &fun) static const R_CallMethodDef callMethods[] = { /* AEbufs.c */ CALLMETHOD_DEF(debug_AEbufs, 0), CALLMETHOD_DEF(AEbufs_use_malloc, 1), CALLMETHOD_DEF(AEbufs_free, 0), /* anyMissing.c */ CALLMETHOD_DEF(anyMissing, 1), /* vector_utils.c */ CALLMETHOD_DEF(sapply_NROW, 1), CALLMETHOD_DEF(vector_subsetByRanges, 3), CALLMETHOD_DEF(vector_seqselect, 3), /* logical_utils.c */ CALLMETHOD_DEF(logical_as_compact_bitvector, 1), CALLMETHOD_DEF(compact_bitvector_as_logical, 2), CALLMETHOD_DEF(subset_compact_bitvector, 2), CALLMETHOD_DEF(compact_bitvector_bit_count, 1), CALLMETHOD_DEF(compact_bitvector_last_bit, 1), CALLMETHOD_DEF(compact_bitvector_set_op, 3), /* int_utils.c */ CALLMETHOD_DEF(Integer_any_missing_or_outside, 3), CALLMETHOD_DEF(Integer_sum_non_neg_vals, 1), CALLMETHOD_DEF(Integer_diff_with_0, 1), CALLMETHOD_DEF(Integer_diff_with_last, 2), CALLMETHOD_DEF(Integer_order, 2), CALLMETHOD_DEF(Integer_compare2, 4), CALLMETHOD_DEF(Integer_sorted2, 4), CALLMETHOD_DEF(Integer_order2, 3), CALLMETHOD_DEF(Integer_match2_quick, 5), CALLMETHOD_DEF(Integer_selfmatch2_quick, 2), CALLMETHOD_DEF(Integer_match2_hash, 5), CALLMETHOD_DEF(Integer_selfmatch2_hash, 2), CALLMETHOD_DEF(Integer_order4, 5), CALLMETHOD_DEF(Integer_match4_quick, 9), CALLMETHOD_DEF(Integer_selfmatch4_quick, 4), CALLMETHOD_DEF(Integer_match4_hash, 9), CALLMETHOD_DEF(Integer_selfmatch4_hash, 4), CALLMETHOD_DEF(Integer_tabulate2, 4), CALLMETHOD_DEF(Integer_explode_bits, 2), CALLMETHOD_DEF(Integer_sorted_merge, 2), CALLMETHOD_DEF(Integer_mseq, 2), CALLMETHOD_DEF(Integer_fancy_mseq, 3), CALLMETHOD_DEF(findIntervalAndStartFromWidth, 2), /* str_utils.c */ CALLMETHOD_DEF(unstrsplit_list, 2), CALLMETHOD_DEF(safe_strexplode, 1), CALLMETHOD_DEF(strsplit_as_list_of_ints, 2), CALLMETHOD_DEF(svn_time, 0), /* eval_utils.c */ CALLMETHOD_DEF(top_prenv, 2), CALLMETHOD_DEF(top_prenv_dots, 1), /* subsetting_internals.c */ CALLMETHOD_DEF(vector_extract_window, 3), /* Hits_class.c */ CALLMETHOD_DEF(Hits_new, 5), CALLMETHOD_DEF(select_hits, 4), CALLMETHOD_DEF(make_all_group_inner_hits, 2), /* Rle_class.c */ CALLMETHOD_DEF(Rle_constructor, 4), CALLMETHOD_DEF(Rle_start, 1), CALLMETHOD_DEF(Rle_end, 1), CALLMETHOD_DEF(Rle_getStartEndRunAndOffset, 3), CALLMETHOD_DEF(Rle_window_aslist, 5), CALLMETHOD_DEF(Rle_window, 6), CALLMETHOD_DEF(Rle_seqselect, 3), /* Rle_utils.c */ CALLMETHOD_DEF(Rle_runsum, 3), CALLMETHOD_DEF(Rle_runwtsum, 4), CALLMETHOD_DEF(Rle_runq, 4), {NULL, NULL, 0} }; void R_init_S4Vectors(DllInfo *info) { R_registerRoutines(info, NULL, callMethods, NULL, NULL); /* safe_arithm.c */ REGISTER_CCALLABLE(_reset_ovflow_flag); REGISTER_CCALLABLE(_get_ovflow_flag); REGISTER_CCALLABLE(_safe_int_add); REGISTER_CCALLABLE(_safe_int_mult); /* sort_utils.c */ REGISTER_CCALLABLE(_sort_int_array); REGISTER_CCALLABLE(_get_order_of_int_array); REGISTER_CCALLABLE(_get_order_of_int_pairs); REGISTER_CCALLABLE(_get_matches_of_ordered_int_pairs); REGISTER_CCALLABLE(_get_order_of_int_quads); REGISTER_CCALLABLE(_get_matches_of_ordered_int_quads); /* hash_utils.c */ REGISTER_CCALLABLE(_new_htab); REGISTER_CCALLABLE(_get_hbucket_val); REGISTER_CCALLABLE(_set_hbucket_val); /* AEbufs.c */ REGISTER_CCALLABLE(_get_new_buflength); REGISTER_CCALLABLE(_IntAE_get_nelt); REGISTER_CCALLABLE(_IntAE_set_nelt); REGISTER_CCALLABLE(_IntAE_set_val); REGISTER_CCALLABLE(_IntAE_insert_at); REGISTER_CCALLABLE(_new_IntAE); REGISTER_CCALLABLE(_IntAE_append); REGISTER_CCALLABLE(_IntAE_delete_at); REGISTER_CCALLABLE(_IntAE_shift); REGISTER_CCALLABLE(_IntAE_sum_and_shift); REGISTER_CCALLABLE(_IntAE_append_shifted_vals); REGISTER_CCALLABLE(_IntAE_qsort); REGISTER_CCALLABLE(_IntAE_delete_adjdups); REGISTER_CCALLABLE(_new_INTEGER_from_IntAE); REGISTER_CCALLABLE(_new_IntAE_from_INTEGER); REGISTER_CCALLABLE(_new_IntAE_from_CHARACTER); REGISTER_CCALLABLE(_IntAEAE_get_nelt); REGISTER_CCALLABLE(_IntAEAE_set_nelt); REGISTER_CCALLABLE(_IntAEAE_insert_at); REGISTER_CCALLABLE(_new_IntAEAE); REGISTER_CCALLABLE(_IntAEAE_eltwise_append); REGISTER_CCALLABLE(_IntAEAE_shift); REGISTER_CCALLABLE(_IntAEAE_sum_and_shift); REGISTER_CCALLABLE(_new_LIST_from_IntAEAE); REGISTER_CCALLABLE(_new_IntAEAE_from_LIST); REGISTER_CCALLABLE(_IntAEAE_toEnvir); REGISTER_CCALLABLE(_IntPairAE_get_nelt); REGISTER_CCALLABLE(_IntPairAE_set_nelt); REGISTER_CCALLABLE(_IntPairAE_insert_at); REGISTER_CCALLABLE(_new_IntPairAE); REGISTER_CCALLABLE(_IntPairAEAE_get_nelt); REGISTER_CCALLABLE(_IntPairAEAE_set_nelt); REGISTER_CCALLABLE(_IntPairAEAE_insert_at); REGISTER_CCALLABLE(_new_IntPairAEAE); REGISTER_CCALLABLE(_LLongAE_get_nelt); REGISTER_CCALLABLE(_LLongAE_set_nelt); REGISTER_CCALLABLE(_LLongAE_set_val); REGISTER_CCALLABLE(_LLongAE_insert_at); REGISTER_CCALLABLE(_new_LLongAE); REGISTER_CCALLABLE(_CharAE_get_nelt); REGISTER_CCALLABLE(_CharAE_set_nelt); REGISTER_CCALLABLE(_CharAE_insert_at); REGISTER_CCALLABLE(_new_CharAE); REGISTER_CCALLABLE(_new_CharAE_from_string); REGISTER_CCALLABLE(_append_string_to_CharAE); REGISTER_CCALLABLE(_CharAE_delete_at); REGISTER_CCALLABLE(_new_RAW_from_CharAE); REGISTER_CCALLABLE(_new_LOGICAL_from_CharAE); REGISTER_CCALLABLE(_CharAEAE_get_nelt); REGISTER_CCALLABLE(_CharAEAE_set_nelt); REGISTER_CCALLABLE(_CharAEAE_insert_at); REGISTER_CCALLABLE(_new_CharAEAE); REGISTER_CCALLABLE(_append_string_to_CharAEAE); REGISTER_CCALLABLE(_new_CHARACTER_from_CharAEAE); /* SEXP_utils.c */ REGISTER_CCALLABLE(_get_classname); /* vector_utils.c */ REGISTER_CCALLABLE(_vector_memcmp); REGISTER_CCALLABLE(_vector_memcpy); REGISTER_CCALLABLE(_list_as_data_frame); /* int_utils.c */ REGISTER_CCALLABLE(_sum_non_neg_ints); REGISTER_CCALLABLE(_check_integer_pairs); REGISTER_CCALLABLE(_find_interv_and_start_from_width); /* Hits_class.c */ REGISTER_CCALLABLE(_new_Hits); REGISTER_CCALLABLE(_get_select_mode); /* Rle_class.c */ REGISTER_CCALLABLE(_logical_Rle_constructor); REGISTER_CCALLABLE(_integer_Rle_constructor); REGISTER_CCALLABLE(_numeric_Rle_constructor); REGISTER_CCALLABLE(_complex_Rle_constructor); REGISTER_CCALLABLE(_character_Rle_constructor); REGISTER_CCALLABLE(_raw_Rle_constructor); REGISTER_CCALLABLE(_seqselect_Rle); /* List_class.c */ REGISTER_CCALLABLE(_get_List_elementType); REGISTER_CCALLABLE(_set_List_elementType); /* SimpleList_class.c */ REGISTER_CCALLABLE(_new_SimpleList); /* DataFrame_class.c */ REGISTER_CCALLABLE(_new_DataFrame); return; } S4Vectors/src/Rle_class.c0000644000175100017510000005025712607346177016316 0ustar00biocbuildbiocbuild#include "S4Vectors.h" static SEXP _new_Rle(SEXP values, SEXP lengths) { SEXP classdef, ans; PROTECT(classdef = MAKE_CLASS("Rle")); PROTECT(ans = NEW_OBJECT(classdef)); SET_SLOT(ans, install("values"), values); SET_SLOT(ans, install("lengths"), lengths); UNPROTECT(2); return ans; } /**************************************************************************** * The compute__runs() low-level helper functions. * * To compute only the nb of runs without actually computing the runs * (degraded mode), set 'run_lengths' to NULL. */ static int compute_int_runs(const int *values, int nvalues, const int *lengths, int *run_values, int *run_lengths) { int i, nrun, lengths_elt; int val0; for (i = nrun = 0, lengths_elt = 1; i < nvalues; i++, values++) { if (lengths != NULL) { lengths_elt = lengths[i]; if (lengths_elt == 0) continue; } if (nrun != 0 && *values == val0) { if (run_lengths != NULL) run_lengths[nrun - 1] += lengths_elt; continue; } val0 = *values; if (run_lengths != NULL) { run_lengths[nrun] = lengths_elt; run_values[nrun] = val0; } nrun++; } return nrun; } static int compute_double_runs(const double *values, int nvalues, const int *lengths, double *run_values, int *run_lengths) { int i, nrun, lengths_elt; double val0; for (i = nrun = 0, lengths_elt = 1; i < nvalues; i++, values++) { if (lengths != NULL) { lengths_elt = lengths[i]; if (lengths_elt == 0) continue; } if (nrun != 0 && ((*values == val0) || (R_IsNA(*values) && R_IsNA(val0)) || (R_IsNaN(*values) && R_IsNaN(val0)))) { if (run_lengths != NULL) run_lengths[nrun - 1] += lengths_elt; continue; } val0 = *values; if (run_lengths != NULL) { run_lengths[nrun] = lengths_elt; run_values[nrun] = val0; } nrun++; } return nrun; } static int compute_Rcomplex_runs(const Rcomplex *values, int nvalues, const int *lengths, Rcomplex *run_values, int *run_lengths) { int i, nrun, lengths_elt; Rcomplex val0; for (i = nrun = 0, lengths_elt = 1; i < nvalues; i++, values++) { if (lengths != NULL) { lengths_elt = lengths[i]; if (lengths_elt == 0) continue; } if (nrun != 0 && ((values->r == val0.r) || (R_IsNA(values->r) && R_IsNA(val0.r)) || (R_IsNaN(values->r) && R_IsNaN(val0.r))) && ((values->i == val0.i) || (R_IsNA(values->i) && R_IsNA(val0.i)) || (R_IsNaN(values->i) && R_IsNaN(val0.i)))) { if (run_lengths != NULL) run_lengths[nrun - 1] += lengths_elt; continue; } val0 = *values; if (run_lengths != NULL) { run_lengths[nrun] = lengths_elt; run_values[nrun] = val0; } nrun++; } return nrun; } static int compute_CHARSXP_runs(SEXP values, const int *lengths, SEXP run_values, int *run_lengths) { int nvalues, i, nrun, lengths_elt; SEXP values_elt, val0 = NULL; nvalues = LENGTH(values); for (i = nrun = 0, lengths_elt = 1; i < nvalues; i++) { if (lengths != NULL) { lengths_elt = lengths[i]; if (lengths_elt == 0) continue; } values_elt = STRING_ELT(values, i); if (nrun != 0 && values_elt == val0) { if (run_lengths != NULL) run_lengths[nrun - 1] += lengths_elt; continue; } val0 = values_elt; if (run_lengths != NULL) { run_lengths[nrun] = lengths_elt; SET_STRING_ELT(run_values, nrun, val0); } nrun++; } return nrun; } static int compute_Rbyte_runs(const Rbyte *values, int nvalues, const int *lengths, Rbyte *run_values, int *run_lengths) { int i, nrun, lengths_elt; Rbyte val0; for (i = nrun = 0, lengths_elt = 1; i < nvalues; i++, values++) { if (lengths != NULL) { lengths_elt = lengths[i]; if (lengths_elt == 0) continue; } if (nrun != 0 && *values == val0) { if (run_lengths != NULL) run_lengths[nrun - 1] += lengths_elt; continue; } val0 = *values; if (run_lengths != NULL) { run_lengths[nrun] = lengths_elt; run_values[nrun] = val0; } nrun++; } return nrun; } /**************************************************************************** * The C level Rle smart constructors. * * 'lengths' must be either (a) an int array of length 'nvalues' with no NA * or negative values, or (b) NULL. If (b) then it's treated as an array of * length 'nvalues' filled with 1's (i.e. each element is set to 1). * 'buflength' is the length of the temporary buffers allocated internally by * the smart constructor for computing the runs. If set to 0, then a 2-pass * algo is used that doesn't use any temporary buffer, typically leading to * 20%-30% less memory used (it also seems slightly faster on my machine). * Setting 'buflength' to 'nvalues' is safe because the number of runs can * only be <= 'nvalues'. If 'buflength' is > 'nvalues', then 'nvalues' is used * instead. * WARNING: Avoid using a 'buflength' that is > 0 and < 'nvalues' unless you * know what you are doing! */ SEXP _logical_Rle_constructor(const int *values, int nvalues, const int *lengths, int buflength) { int nrun, *buf_lengths; int *buf_values; SEXP ans_lengths, ans_values, ans; if (buflength > nvalues) buflength = nvalues; if (buflength == 0) { /* 1st pass: compute only the nb of runs */ buf_values = NULL; buf_lengths = NULL; } else { buf_values = (int *) R_alloc(buflength, sizeof(int)); buf_lengths = (int *) R_alloc(buflength, sizeof(int)); } nrun = compute_int_runs(values, nvalues, lengths, buf_values, buf_lengths); PROTECT(ans_values = NEW_LOGICAL(nrun)); PROTECT(ans_lengths = NEW_INTEGER(nrun)); if (buflength == 0) { /* 2nd pass: fill 'ans_values' and 'ans_lengths' */ compute_int_runs(values, nvalues, lengths, LOGICAL(ans_values), INTEGER(ans_lengths)); } else { memcpy(LOGICAL(ans_values), buf_values, nrun * sizeof(int)); memcpy(INTEGER(ans_lengths), buf_lengths, nrun * sizeof(int)); } PROTECT(ans = _new_Rle(ans_values, ans_lengths)); UNPROTECT(3); return ans; } SEXP _integer_Rle_constructor(const int *values, int nvalues, const int *lengths, int buflength) { int nrun, *buf_lengths; int *buf_values; SEXP ans_lengths, ans_values, ans; if (buflength > nvalues) buflength = nvalues; if (buflength == 0) { /* 1st pass: compute only the nb of runs */ buf_values = NULL; buf_lengths = NULL; } else { buf_values = (int *) R_alloc(buflength, sizeof(int)); buf_lengths = (int *) R_alloc(buflength, sizeof(int)); } nrun = compute_int_runs(values, nvalues, lengths, buf_values, buf_lengths); PROTECT(ans_values = NEW_INTEGER(nrun)); PROTECT(ans_lengths = NEW_INTEGER(nrun)); if (buflength == 0) { /* 2nd pass: fill 'ans_values' and 'ans_lengths' */ compute_int_runs(values, nvalues, lengths, INTEGER(ans_values), INTEGER(ans_lengths)); } else { memcpy(INTEGER(ans_values), buf_values, nrun * sizeof(int)); memcpy(INTEGER(ans_lengths), buf_lengths, nrun * sizeof(int)); } PROTECT(ans = _new_Rle(ans_values, ans_lengths)); UNPROTECT(3); return ans; } SEXP _numeric_Rle_constructor(const double *values, int nvalues, const int *lengths, int buflength) { int nrun, *buf_lengths; double *buf_values; SEXP ans_lengths, ans_values, ans; if (buflength > nvalues) buflength = nvalues; if (buflength == 0) { /* 1st pass: compute only the nb of runs */ buf_values = NULL; buf_lengths = NULL; } else { buf_values = (double *) R_alloc(buflength, sizeof(double)); buf_lengths = (int *) R_alloc(buflength, sizeof(int)); } nrun = compute_double_runs(values, nvalues, lengths, buf_values, buf_lengths); PROTECT(ans_values = NEW_NUMERIC(nrun)); PROTECT(ans_lengths = NEW_INTEGER(nrun)); if (buflength == 0) { /* 2nd pass: fill 'ans_values' and 'ans_lengths' */ compute_double_runs(values, nvalues, lengths, REAL(ans_values), INTEGER(ans_lengths)); } else { memcpy(REAL(ans_values), buf_values, nrun * sizeof(double)); memcpy(INTEGER(ans_lengths), buf_lengths, nrun * sizeof(int)); } PROTECT(ans = _new_Rle(ans_values, ans_lengths)); UNPROTECT(3); return ans; } SEXP _complex_Rle_constructor(const Rcomplex *values, int nvalues, const int *lengths, int buflength) { int nrun, *buf_lengths; Rcomplex *buf_values; SEXP ans_lengths, ans_values, ans; if (buflength > nvalues) buflength = nvalues; if (buflength == 0) { /* 1st pass: compute only the nb of runs */ buf_values = NULL; buf_lengths = NULL; } else { buf_values = (Rcomplex *) R_alloc(buflength, sizeof(Rcomplex)); buf_lengths = (int *) R_alloc(buflength, sizeof(int)); } nrun = compute_Rcomplex_runs(values, nvalues, lengths, buf_values, buf_lengths); PROTECT(ans_values = NEW_COMPLEX(nrun)); PROTECT(ans_lengths = NEW_INTEGER(nrun)); if (buflength == 0) { /* 2nd pass: fill 'ans_values' and 'ans_lengths' */ compute_Rcomplex_runs(values, nvalues, lengths, COMPLEX(ans_values), INTEGER(ans_lengths)); } else { memcpy(COMPLEX(ans_values), buf_values, nrun * sizeof(Rcomplex)); memcpy(INTEGER(ans_lengths), buf_lengths, nrun * sizeof(int)); } PROTECT(ans = _new_Rle(ans_values, ans_lengths)); UNPROTECT(3); return ans; } SEXP _character_Rle_constructor(SEXP values, const int *lengths, int buflength) { int nvalues, nrun, *buf_lengths, i; SEXP buf_values, ans_lengths, ans_values, ans; nvalues = LENGTH(values); if (buflength > nvalues) buflength = nvalues; if (buflength == 0) { /* 1st pass: compute only the nb of runs */ buf_values = NULL; buf_lengths = NULL; } else { PROTECT(buf_values = NEW_CHARACTER(buflength)); buf_lengths = (int *) R_alloc(buflength, sizeof(int)); } nrun = compute_CHARSXP_runs(values, lengths, buf_values, buf_lengths); PROTECT(ans_values = NEW_CHARACTER(nrun)); PROTECT(ans_lengths = NEW_INTEGER(nrun)); if (buflength == 0) { /* 2nd pass: fill 'ans_values' and 'ans_lengths' */ compute_CHARSXP_runs(values, lengths, ans_values, INTEGER(ans_lengths)); } else { for (i = 0; i < nrun; i++) SET_STRING_ELT(ans_values, i, STRING_ELT(buf_values, i)); memcpy(INTEGER(ans_lengths), buf_lengths, nrun * sizeof(int)); } PROTECT(ans = _new_Rle(ans_values, ans_lengths)); UNPROTECT(buflength == 0 ? 3 : 4); return ans; } SEXP _raw_Rle_constructor(const Rbyte *values, int nvalues, const int *lengths, int buflength) { int nrun, *buf_lengths; Rbyte *buf_values; SEXP ans_lengths, ans_values, ans; if (buflength > nvalues) buflength = nvalues; if (buflength == 0) { /* 1st pass: compute only the nb of runs */ buf_values = NULL; buf_lengths = NULL; } else { buf_values = (Rbyte *) R_alloc(buflength, sizeof(Rbyte)); buf_lengths = (int *) R_alloc(buflength, sizeof(int)); } nrun = compute_Rbyte_runs(values, nvalues, lengths, buf_values, buf_lengths); PROTECT(ans_values = NEW_RAW(nrun)); PROTECT(ans_lengths = NEW_INTEGER(nrun)); if (buflength == 0) { /* 2nd pass: fill 'ans_values' and 'ans_lengths' */ compute_Rbyte_runs(values, nvalues, lengths, RAW(ans_values), INTEGER(ans_lengths)); } else { memcpy(RAW(ans_values), buf_values, nrun * sizeof(Rbyte)); memcpy(INTEGER(ans_lengths), buf_lengths, nrun * sizeof(int)); } PROTECT(ans = _new_Rle(ans_values, ans_lengths)); UNPROTECT(3); return ans; } /**************************************************************************** * The Rle constructor (.Call ENTRY POINT). */ SEXP Rle_constructor(SEXP values, SEXP lengths, SEXP check, SEXP buflength) { int nvalues, buflength0; const int *lengths_p; nvalues = LENGTH(values); if (LOGICAL(check)[0] && LENGTH(lengths) > 0) { if (LENGTH(lengths) != nvalues) error("'length(lengths)' != 'length(values)'"); _sum_non_neg_ints(INTEGER(lengths), LENGTH(lengths), "lengths"); } lengths_p = LENGTH(lengths) > 0 ? INTEGER(lengths) : NULL; buflength0 = INTEGER(buflength)[0]; switch (TYPEOF(values)) { case LGLSXP: return _logical_Rle_constructor(LOGICAL(values), nvalues, lengths_p, buflength0); case INTSXP: return _integer_Rle_constructor(INTEGER(values), nvalues, lengths_p, buflength0); case REALSXP: return _numeric_Rle_constructor(REAL(values), nvalues, lengths_p, buflength0); case CPLXSXP: return _complex_Rle_constructor(COMPLEX(values), nvalues, lengths_p, buflength0); case STRSXP: return _character_Rle_constructor(values, lengths_p, buflength0); case RAWSXP: return _raw_Rle_constructor(RAW(values), nvalues, lengths_p, buflength0); } error("Rle of type '%s' is not supported", CHAR(type2str(TYPEOF(values)))); return R_NilValue; } /**************************************************************************** * The Rle start() and end() getters (.Call ENTRY POINTS). */ SEXP Rle_start(SEXP x) { int i, nrun, *len_elt, *prev_start, *curr_start; SEXP lengths, ans; lengths = GET_SLOT(x, install("lengths")); nrun = LENGTH(lengths); PROTECT(ans = NEW_INTEGER(nrun)); if (nrun > 0) { INTEGER(ans)[0] = 1; for(i = 1, len_elt = INTEGER(lengths), prev_start = INTEGER(ans), curr_start = INTEGER(ans) + 1; i < nrun; i++, len_elt++, prev_start++, curr_start++) { *curr_start = *prev_start + *len_elt; } } UNPROTECT(1); return ans; } SEXP Rle_end(SEXP x) { int i, nrun, *len_elt, *prev_end, *curr_end; SEXP lengths, ans; lengths = GET_SLOT(x, install("lengths")); nrun = LENGTH(lengths); PROTECT(ans = NEW_INTEGER(nrun)); if (nrun > 0) { INTEGER(ans)[0] = INTEGER(lengths)[0]; for(i = 1, len_elt = INTEGER(lengths) + 1, prev_end = INTEGER(ans), curr_end = INTEGER(ans) + 1; i < nrun; i++, len_elt++, prev_end++, curr_end++) { *curr_end = *prev_end + *len_elt; } } UNPROTECT(1); return ans; } /**************************************************************************** * Rle_getStartEndRunAndOffset() */ static SEXP get_StartEndRunAndOffset_from_runLength( const int *runlength, int runlength_len, const int *start, const int *end, int length) { int i, *soff_elt, *eoff_elt; const int *start_elt, *end_elt, *erun_elt; SEXP info_start, info_end, ans, ans_names; SEXP ans_start, ans_start_names, ans_end, ans_end_names; SEXP start_run, start_offset, end_run, end_offset; PROTECT(info_start = _find_interv_and_start_from_width(start, length, runlength, runlength_len)); PROTECT(info_end = _find_interv_and_start_from_width(end, length, runlength, runlength_len)); start_run = VECTOR_ELT(info_start, 0); start_offset = VECTOR_ELT(info_start, 1); end_run = VECTOR_ELT(info_end, 0); end_offset = VECTOR_ELT(info_end, 1); for (i = 0, start_elt = start, end_elt = end, soff_elt = INTEGER(start_offset), eoff_elt = INTEGER(end_offset), erun_elt = INTEGER(end_run); i < length; i++, start_elt++, end_elt++, soff_elt++, eoff_elt++, erun_elt++) { *soff_elt = *start_elt - *soff_elt; *eoff_elt = *eoff_elt + runlength[*erun_elt - 1] - 1 - *end_elt; } PROTECT(ans_start = NEW_LIST(2)); PROTECT(ans_start_names = NEW_CHARACTER(2)); SET_VECTOR_ELT(ans_start, 0, start_run); SET_VECTOR_ELT(ans_start, 1, start_offset); SET_STRING_ELT(ans_start_names, 0, mkChar("run")); SET_STRING_ELT(ans_start_names, 1, mkChar("offset")); SET_NAMES(ans_start, ans_start_names); PROTECT(ans_end = NEW_LIST(2)); PROTECT(ans_end_names = NEW_CHARACTER(2)); SET_VECTOR_ELT(ans_end, 0, end_run); SET_VECTOR_ELT(ans_end, 1, end_offset); SET_STRING_ELT(ans_end_names, 0, mkChar("run")); SET_STRING_ELT(ans_end_names, 1, mkChar("offset")); SET_NAMES(ans_end, ans_end_names); PROTECT(ans = NEW_LIST(2)); PROTECT(ans_names = NEW_CHARACTER(2)); SET_VECTOR_ELT(ans, 0, ans_start); SET_VECTOR_ELT(ans, 1, ans_end); SET_STRING_ELT(ans_names, 0, mkChar("start")); SET_STRING_ELT(ans_names, 1, mkChar("end")); SET_NAMES(ans, ans_names); UNPROTECT(8); return ans; } /* --- .Call ENTRY POINT --- */ SEXP Rle_getStartEndRunAndOffset(SEXP x, SEXP start, SEXP end) { int n; SEXP lengths; n = LENGTH(start); if (LENGTH(end) != n) error("length of 'start' must equal length of 'end'"); lengths = GET_SLOT(x, install("lengths")); return get_StartEndRunAndOffset_from_runLength( INTEGER(lengths), LENGTH(lengths), INTEGER(start), INTEGER(end), n); } /* * --- .Call ENTRY POINT --- */ SEXP Rle_window_aslist(SEXP x, SEXP runStart, SEXP runEnd, SEXP offsetStart, SEXP offsetEnd) { SEXP values, lengths, runWidth, ans, ans_names, ans_values, ans_lengths; values = GET_SLOT(x, install("values")); lengths = GET_SLOT(x, install("lengths")); if (!IS_INTEGER(runStart) || LENGTH(runStart) != 1 || INTEGER(runStart)[0] == NA_INTEGER || INTEGER(runStart)[0] < 1) error("invalid 'runStart' argument"); if (!IS_INTEGER(runEnd) || LENGTH(runEnd) != 1 || INTEGER(runEnd)[0] == NA_INTEGER || (INTEGER(runEnd)[0] + 1) < INTEGER(runStart)[0] || INTEGER(runEnd)[0] > LENGTH(values)) error("invalid 'runWidth' argument"); PROTECT(runWidth = NEW_INTEGER(1)); INTEGER(runWidth)[0] = INTEGER(runEnd)[0] - INTEGER(runStart)[0] + 1; PROTECT(ans = NEW_LIST(2)); PROTECT(ans_names = NEW_CHARACTER(2)); PROTECT(ans_values = vector_seqselect(values, runStart, runWidth)); PROTECT(ans_lengths = vector_seqselect(lengths, runStart, runWidth)); if (INTEGER(runWidth)[0] > 0) { INTEGER(ans_lengths)[0] -= INTEGER(offsetStart)[0]; INTEGER(ans_lengths)[INTEGER(runWidth)[0] - 1] -= INTEGER(offsetEnd)[0]; } SET_VECTOR_ELT(ans, 0, ans_values); SET_VECTOR_ELT(ans, 1, ans_lengths); SET_STRING_ELT(ans_names, 0, mkChar("values")); SET_STRING_ELT(ans_names, 1, mkChar("lengths")); SET_NAMES(ans, ans_names); UNPROTECT(5); return ans; } /* * --- .Call ENTRY POINT --- */ /* * Rle_window accepts an Rle object to support fast R-level aggregate usage */ SEXP Rle_window(SEXP x, SEXP runStart, SEXP runEnd, SEXP offsetStart, SEXP offsetEnd, SEXP ans) { SEXP ans_list; PROTECT(ans_list = Rle_window_aslist(x, runStart, runEnd, offsetStart, offsetEnd)); ans = Rf_duplicate(ans); SET_SLOT(ans, install("values"), VECTOR_ELT(ans_list, 0)); SET_SLOT(ans, install("lengths"), VECTOR_ELT(ans_list, 1)); UNPROTECT(1); return ans; } /**************************************************************************** * Rle_seqselect() */ SEXP _seqselect_Rle(SEXP x, const int *start, const int *width, int length) { int i, index, *end_elt, *width_run_elt, *len_elt; const int *start_elt, *width_elt, *soff_elt, *eoff_elt; SEXP values, lengths, end; SEXP info, info_start, info_end; SEXP start_run, end_run, width_run, start_offset, end_offset; SEXP ans, ans_names, ans_values, ans_lengths; values = GET_SLOT(x, install("values")); lengths = GET_SLOT(x, install("lengths")); PROTECT(end = NEW_INTEGER(length)); for (i = 0, start_elt = start, end_elt = INTEGER(end), width_elt = width; i < length; i++, start_elt++, end_elt++, width_elt++) { *end_elt = *start_elt + *width_elt - 1; } PROTECT(info = get_StartEndRunAndOffset_from_runLength( INTEGER(lengths), LENGTH(lengths), start, INTEGER(end), length)); info_start = VECTOR_ELT(info, 0); start_run = VECTOR_ELT(info_start, 0); start_offset = VECTOR_ELT(info_start, 1); info_end = VECTOR_ELT(info, 1); end_run = VECTOR_ELT(info_end, 0); end_offset = VECTOR_ELT(info_end, 1); PROTECT(width_run = NEW_INTEGER(length)); for (i = 0, start_elt = INTEGER(start_run), end_elt = INTEGER(end_run), width_run_elt = INTEGER(width_run); i < length; i++, start_elt++, end_elt++, width_run_elt++) { *width_run_elt = *end_elt - *start_elt + 1; } PROTECT(ans_values = vector_seqselect(values, start_run, width_run)); PROTECT(ans_lengths = vector_seqselect(lengths, start_run, width_run)); index = 0; len_elt = INTEGER(ans_lengths); for (i = 0, soff_elt = INTEGER(start_offset), eoff_elt = INTEGER(end_offset), width_elt = INTEGER(width_run); i < length; i++, soff_elt++, eoff_elt++, width_elt++) { if (*width_elt > 0) { len_elt[index] -= *soff_elt; index += *width_elt; len_elt[index - 1] -= *eoff_elt; } } PROTECT(ans = NEW_LIST(2)); PROTECT(ans_names = NEW_CHARACTER(2)); SET_VECTOR_ELT(ans, 0, ans_values); SET_VECTOR_ELT(ans, 1, ans_lengths); SET_STRING_ELT(ans_names, 0, mkChar("values")); SET_STRING_ELT(ans_names, 1, mkChar("lengths")); SET_NAMES(ans, ans_names); UNPROTECT(7); return ans; } /* --- .Call ENTRY POINT --- */ SEXP Rle_seqselect(SEXP x, SEXP start, SEXP width) { int n; n = LENGTH(start); if (LENGTH(width) != n) error("length of 'start' must equal length of 'width'"); return _seqselect_Rle(x, INTEGER(start), INTEGER(width), n); } S4Vectors/src/Rle_utils.c0000644000175100017510000006075612607346177016356 0ustar00biocbuildbiocbuild#include "S4Vectors.h" #include /* * roundingScale() function taken from the src/lib/common.c file from the Kent * source tree: * http://genome-source.cse.ucsc.edu/gitweb/?p=kent.git;a=blob_plain;f=src/lib/common.c */ static int roundingScale(int a, int p, int q) /* returns rounded a*p/q */ { if (a > 100000 || p > 100000) { double x = a; x *= p; x /= q; return round(x); } else return (a*p + q/2)/q; } SEXP Rle_integer_runsum(SEXP x, SEXP k, SEXP na_rm) { int i, j, nrun, window_len, buf_len, x_vec_len, ans_len; int prev_offset, curr_offset; int stat, stat_na; int *prev_length, *curr_length, *buf_lengths, *buf_lengths_elt; int *prev_value, *curr_value, *buf_values, *buf_values_elt; int *prev_value_na, *curr_value_na; SEXP values, lengths; SEXP orig_values, na_index; const int narm = LOGICAL(na_rm)[0]; if (!IS_INTEGER(k) || LENGTH(k) != 1 || INTEGER(k)[0] == NA_INTEGER || INTEGER(k)[0] <= 0) error("'k' must be a positive integer"); /* Set NA values to 0 * Create NA index : 1 = NA; 0 = not NA */ orig_values = GET_SLOT(x, install("values")); values = PROTECT(Rf_allocVector(INTSXP, LENGTH(orig_values))); na_index = PROTECT(Rf_allocVector(INTSXP, LENGTH(orig_values))); int *vlu = INTEGER(orig_values); for(i = 0; i < LENGTH(orig_values); i++) { if (vlu[i] == NA_INTEGER) { INTEGER(na_index)[i] = 1; INTEGER(values)[i] = 0; } else { INTEGER(na_index)[i] = 0; INTEGER(values)[i] = INTEGER(orig_values)[i]; } } lengths = GET_SLOT(x, install("lengths")); nrun = LENGTH(lengths); window_len = INTEGER(k)[0]; ans_len = 0; x_vec_len = 0; buf_len = - window_len + 1; for(i = 0, curr_length = INTEGER(lengths); i < nrun; i++, curr_length++) { x_vec_len += *curr_length; buf_len += *curr_length; if (window_len < *curr_length) buf_len -= *curr_length - window_len; } buf_values = NULL; buf_lengths = NULL; if (buf_len > 0) { buf_values = (int *) R_alloc((long) buf_len, sizeof(int)); buf_lengths = (int *) R_alloc((long) buf_len, sizeof(int)); memset(buf_lengths, 0, buf_len * sizeof(int)); stat = 0; stat_na = 0; buf_values_elt = buf_values; buf_lengths_elt = buf_lengths; prev_value = INTEGER(values); curr_value = INTEGER(values); prev_length = INTEGER(lengths); curr_length = INTEGER(lengths); prev_offset = INTEGER(lengths)[0]; curr_offset = INTEGER(lengths)[0]; prev_value_na = INTEGER(na_index); curr_value_na = INTEGER(na_index); for (i = 0; i < buf_len; i++) { if (i % 100000 == 99999) R_CheckUserInterrupt(); /* calculate stat */ if (i == 0) { j = 0; ans_len = 1; while (j < window_len) { if (curr_offset == 0) { curr_value++; curr_value_na++; curr_length++; curr_offset = *curr_length; } int times = curr_offset < window_len - j ? curr_offset : window_len - j; stat += times * (*curr_value); stat_na += times * (*curr_value_na); curr_offset -= times; j += times; } } else { stat += (*curr_value - *prev_value); stat_na += (*curr_value_na - *prev_value_na); /* increment values and lengths based on stat */ if (narm | (stat_na == 0)) { if (stat != *buf_values_elt) { ans_len++; buf_values_elt++; buf_lengths_elt++; } } else { if ((stat_na != 0) && (*buf_values_elt != NA_INTEGER)) { ans_len++; buf_values_elt++; buf_lengths_elt++; } } } /* NA handling */ if (!narm && (stat_na != 0)) *buf_values_elt = NA_INTEGER; else *buf_values_elt = stat; /* determine length */ if (i == 0) { if (prev_value == curr_value) { /* NA handling */ if (!narm && (*curr_value_na == 1)) { if (prev_value_na == curr_value_na) *buf_lengths_elt += *curr_length - window_len + 1; else *buf_lengths_elt += *curr_length - window_len + 1; } else { *buf_lengths_elt += *curr_length - window_len + 1; } prev_offset = window_len; curr_offset = 0; } else { *buf_lengths_elt += 1; } } else { if ((prev_offset == 1) && (window_len < *curr_length) && ((prev_value + 1) == curr_value)) { /* moving through run lengths > window size */ *buf_lengths_elt += *curr_length - window_len + 1; prev_offset = window_len; curr_offset = 0; prev_value++; prev_value_na++; prev_length++; } else { /* NA handling */ if (!narm && (*curr_value_na == 1)) { if (prev_value_na == curr_value_na) *buf_lengths_elt += *curr_length - window_len + 1; else *buf_lengths_elt += 1; } else { *buf_lengths_elt += 1; } prev_offset--; curr_offset--; if (prev_offset == 0) { prev_value++; prev_value_na++; prev_length++; prev_offset = *prev_length; } } } if ((curr_offset == 0) && (i != buf_len - 1)) { curr_value++; curr_value_na++; curr_length++; curr_offset = *curr_length; } } } UNPROTECT(2); return _integer_Rle_constructor(buf_values, ans_len, buf_lengths, 0); } SEXP Rle_real_runsum(SEXP x, SEXP k, SEXP na_rm) { int i, j, nrun, window_len, buf_len, x_vec_len, ans_len; int prev_offset, curr_offset, m_offset; double stat; int *prev_length, *curr_length, *buf_lengths, *buf_lengths_elt; double *prev_value, *curr_value, *buf_values, *buf_values_elt; double *m_value; int *m_length; SEXP values, lengths; SEXP orig_values; const int narm = LOGICAL(na_rm)[0]; if (!IS_INTEGER(k) || LENGTH(k) != 1 || INTEGER(k)[0] == NA_INTEGER || INTEGER(k)[0] <= 0) error("'k' must be a positive integer"); if (narm) { /* set NA and NaN values to 0 */ orig_values = GET_SLOT(x, install("values")); values = PROTECT(Rf_allocVector(REALSXP, LENGTH(orig_values))); double *vlu = REAL(orig_values); for(i = 0; i < LENGTH(orig_values); i++) { if (ISNAN(vlu[i])) { REAL(values)[i] = 0; } else { REAL(values)[i] = REAL(orig_values)[i]; } } } else { values = GET_SLOT(x, install("values")); } lengths = GET_SLOT(x, install("lengths")); nrun = LENGTH(lengths); window_len = INTEGER(k)[0]; ans_len = 0; x_vec_len = 0; buf_len = - window_len + 1; for(i = 0, curr_length = INTEGER(lengths); i < nrun; i++, curr_length++) { x_vec_len += *curr_length; buf_len += *curr_length; if (window_len < *curr_length) buf_len -= *curr_length - window_len; } buf_values = NULL; buf_lengths = NULL; if (buf_len > 0) { buf_values = (double *) R_alloc((long) buf_len, sizeof(double)); buf_lengths = (int *) R_alloc((long) buf_len, sizeof(int)); memset(buf_lengths, 0, buf_len * sizeof(int)); stat = 0; buf_values_elt = buf_values; buf_lengths_elt = buf_lengths; prev_value = REAL(values); curr_value = REAL(values); prev_length = INTEGER(lengths); curr_length = INTEGER(lengths); prev_offset = INTEGER(lengths)[0]; curr_offset = INTEGER(lengths)[0]; for (i = 0; i < buf_len; i++) { if (i % 100000 == 99999) R_CheckUserInterrupt(); /* calculate stat */ if (i == 0) { j = 0; stat = 0; ans_len = 1; while (j < window_len) { if (curr_offset == 0) { curr_value++; curr_length++; curr_offset = *curr_length; } int times = curr_offset < window_len - j ? curr_offset : window_len - j; stat += times * (*curr_value); curr_offset -= times; j += times; } } else { j = 0; stat = 0; m_offset = prev_offset - 1; m_value = prev_value; m_length = prev_length; while (j < window_len) { if (m_offset == 0) { m_value++; m_length++; m_offset = *m_length; } int times = m_offset < window_len - j ? m_offset : window_len - j; stat += times * (*m_value); m_offset -= times; j += times; } if (!R_FINITE(stat) && !R_FINITE(*buf_values_elt)) { if ((R_IsNA(stat) && !R_IsNA(*buf_values_elt)) || (!R_IsNA(stat) && R_IsNA(*buf_values_elt)) || (R_IsNaN(stat) && !R_IsNaN(*buf_values_elt)) || (!R_IsNaN(stat) && R_IsNaN(*buf_values_elt)) || ((stat == R_PosInf) && (*buf_values_elt != R_PosInf)) || ((stat != R_PosInf) && (*buf_values_elt == R_PosInf)) || ((stat == R_NegInf) && (*buf_values_elt != R_NegInf)) || ((stat != R_NegInf) && (*buf_values_elt == R_NegInf))) { ans_len++; buf_values_elt++; buf_lengths_elt++; } } else { if (stat != *buf_values_elt) { ans_len++; buf_values_elt++; buf_lengths_elt++; } } } *buf_values_elt = stat; /* determine length */ if (i == 0) { if (prev_value == curr_value) { *buf_lengths_elt += *curr_length - window_len + 1; prev_offset = window_len; curr_offset = 0; } else { *buf_lengths_elt += 1; } } else { if ((prev_offset == 1) && (window_len < *curr_length) && ((prev_value + 1) == curr_value)) { /* moving through run lengths > window size */ *buf_lengths_elt += *curr_length - window_len + 1; prev_offset = window_len; curr_offset = 0; prev_value++; prev_length++; } else { *buf_lengths_elt += 1; prev_offset--; curr_offset--; if (prev_offset == 0) { prev_value++; prev_length++; prev_offset = *prev_length; } } } if ((curr_offset == 0) && (i != buf_len - 1)) { curr_value++; curr_length++; curr_offset = *curr_length; } } } if (narm) UNPROTECT(1); return _numeric_Rle_constructor(buf_values, ans_len, buf_lengths, 0); } /* * --- .Call ENTRY POINT --- */ SEXP Rle_runsum(SEXP x, SEXP k, SEXP na_rm) { SEXP ans = R_NilValue; switch(TYPEOF(GET_SLOT(x, install("values")))) { case INTSXP: PROTECT(ans = Rle_integer_runsum(x, k, na_rm)); break; case REALSXP: PROTECT(ans = Rle_real_runsum(x, k, na_rm)); break; default: error("runsum only supported for integer and numeric Rle objects"); } UNPROTECT(1); return ans; } SEXP Rle_integer_runwtsum(SEXP x, SEXP k, SEXP wt, SEXP na_rm) { int i, j, nrun, window_len, buf_len, x_vec_len, ans_len; int start_offset, curr_offset; double stat; int stat_na; int *curr_value_na, *values_elt_na; int *lengths_elt, *curr_length, *buf_lengths, *buf_lengths_elt; int *values_elt, *curr_value; double *wt_elt, *buf_values, *buf_values_elt; SEXP values, lengths; SEXP orig_values, na_index; const int narm = LOGICAL(na_rm)[0]; if (!IS_INTEGER(k) || LENGTH(k) != 1 || INTEGER(k)[0] == NA_INTEGER || INTEGER(k)[0] <= 0) error("'k' must be a positive integer"); /* Set NA values to 0 * Create NA index : 1 = NA; 0 = not NA */ orig_values = GET_SLOT(x, install("values")); values = PROTECT(Rf_allocVector(INTSXP, LENGTH(orig_values))); na_index = PROTECT(Rf_allocVector(INTSXP, LENGTH(orig_values))); int *vlu = INTEGER(orig_values); for(i = 0; i < LENGTH(orig_values); i++) { if (vlu[i] == NA_INTEGER) { INTEGER(na_index)[i] = 1; INTEGER(values)[i] = 0; } else { INTEGER(na_index)[i] = 0; INTEGER(values)[i] = INTEGER(orig_values)[i]; } } lengths = GET_SLOT(x, install("lengths")); nrun = LENGTH(lengths); window_len = INTEGER(k)[0]; if (!IS_NUMERIC(wt) || LENGTH(wt) != window_len) error("'wt' must be a numeric vector of length 'k'"); ans_len = 0; x_vec_len = 0; buf_len = - window_len + 1; for(i = 0, lengths_elt = INTEGER(lengths); i < nrun; i++, lengths_elt++) { x_vec_len += *lengths_elt; buf_len += *lengths_elt; if (window_len < *lengths_elt) buf_len -= *lengths_elt - window_len; } buf_values = NULL; buf_lengths = NULL; if (buf_len > 0) { buf_values = (double *) R_alloc((long) buf_len, sizeof(double)); buf_lengths = (int *) R_alloc((long) buf_len, sizeof(int)); memset(buf_lengths, 0, buf_len * sizeof(int)); buf_values_elt = buf_values; buf_lengths_elt = buf_lengths; values_elt = INTEGER(values); values_elt_na = INTEGER(na_index); lengths_elt = INTEGER(lengths); start_offset = INTEGER(lengths)[0]; for (i = 0; i < buf_len; i++) { if (i % 100000 == 99999) R_CheckUserInterrupt(); /* calculate stat */ stat = 0; stat_na = 0; curr_value = values_elt; curr_value_na = values_elt_na; curr_length = lengths_elt; curr_offset = start_offset; for (j = 0, wt_elt = REAL(wt); j < window_len; j++, wt_elt++) { stat += (*wt_elt) * (*curr_value); stat_na += *curr_value_na; curr_offset--; if (curr_offset == 0) { curr_value++; curr_value_na++; curr_length++; curr_offset = *curr_length; } } /* assign value */ if (ans_len == 0) { ans_len = 1; } else { /* increment values and lengths based on stat */ if (narm | (stat_na == 0)) { if (stat != *buf_values_elt) { ans_len++; buf_values_elt++; buf_lengths_elt++; } } else { if ((stat_na != 0) && (*buf_values_elt != NA_REAL)) { ans_len++; buf_values_elt++; buf_lengths_elt++; } } } /* NA handling */ if (!narm && (stat_na != 0)) *buf_values_elt = NA_REAL; else *buf_values_elt = stat; /* determine length */ if (window_len < start_offset) { *buf_lengths_elt += *lengths_elt - window_len + 1; start_offset = window_len - 1; } else { *buf_lengths_elt += 1; start_offset--; } /* move pointers if end of run */ if (start_offset == 0) { values_elt++; values_elt_na++; lengths_elt++; start_offset = *lengths_elt; } } } UNPROTECT(2); return _numeric_Rle_constructor(buf_values, ans_len, buf_lengths, 0); } SEXP Rle_real_runwtsum(SEXP x, SEXP k, SEXP wt, SEXP na_rm) { int i, j, nrun, window_len, buf_len, x_vec_len, ans_len; int start_offset, curr_offset; double stat; int *lengths_elt, *curr_length, *buf_lengths, *buf_lengths_elt; double *values_elt, *curr_value; double *wt_elt, *buf_values, *buf_values_elt; SEXP values, lengths; SEXP orig_values; const int narm = LOGICAL(na_rm)[0]; if (!IS_INTEGER(k) || LENGTH(k) != 1 || INTEGER(k)[0] == NA_INTEGER || INTEGER(k)[0] <= 0) error("'k' must be a positive integer"); window_len = INTEGER(k)[0]; if (!IS_NUMERIC(wt) || LENGTH(wt) != window_len) error("'wt' must be a numeric vector of length 'k'"); if (narm) { /* set NA and NaN values to 0 */ orig_values = GET_SLOT(x, install("values")); values = PROTECT(Rf_allocVector(REALSXP, LENGTH(orig_values))); double *vlu = REAL(orig_values); for(i = 0; i < LENGTH(orig_values); i++) { if (ISNAN(vlu[i])) REAL(values)[i] = 0; else REAL(values)[i] = REAL(orig_values)[i]; } } else { values = GET_SLOT(x, install("values")); } lengths = GET_SLOT(x, install("lengths")); nrun = LENGTH(lengths); ans_len = 0; x_vec_len = 0; buf_len = - window_len + 1; for(i = 0, lengths_elt = INTEGER(lengths); i < nrun; i++, lengths_elt++) { x_vec_len += *lengths_elt; buf_len += *lengths_elt; if (window_len < *lengths_elt) buf_len -= *lengths_elt - window_len; } buf_values = NULL; buf_lengths = NULL; if (buf_len > 0) { buf_values = (double *) R_alloc((long) buf_len, sizeof(double)); buf_lengths = (int *) R_alloc((long) buf_len, sizeof(int)); memset(buf_lengths, 0, buf_len * sizeof(int)); buf_values_elt = buf_values; buf_lengths_elt = buf_lengths; values_elt = REAL(values); lengths_elt = INTEGER(lengths); start_offset = INTEGER(lengths)[0]; for (i = 0; i < buf_len; i++) { if (i % 100000 == 99999) R_CheckUserInterrupt(); /* calculate stat */ stat = 0; curr_value = values_elt; curr_length = lengths_elt; curr_offset = start_offset; for (j = 0, wt_elt = REAL(wt); j < window_len; j++, wt_elt++) { stat += (*wt_elt) * (*curr_value); curr_offset--; if (curr_offset == 0) { curr_value++; curr_length++; curr_offset = *curr_length; } } /* assign value */ if (ans_len == 0) { ans_len = 1; } else if (!R_FINITE(stat) && !R_FINITE(*buf_values_elt)) { if ((R_IsNA(stat) && !R_IsNA(*buf_values_elt)) || (!R_IsNA(stat) && R_IsNA(*buf_values_elt)) || (R_IsNaN(stat) && !R_IsNaN(*buf_values_elt)) || (!R_IsNaN(stat) && R_IsNaN(*buf_values_elt)) || ((stat == R_PosInf) && (*buf_values_elt != R_PosInf)) || ((stat != R_PosInf) && (*buf_values_elt == R_PosInf)) || ((stat == R_NegInf) && (*buf_values_elt != R_NegInf)) || ((stat != R_NegInf) && (*buf_values_elt == R_NegInf))) { ans_len++; buf_values_elt++; buf_lengths_elt++; } } else { if (stat != *buf_values_elt) { ans_len++; buf_values_elt++; buf_lengths_elt++; } } *buf_values_elt = stat; /* determine length */ if (window_len < start_offset) { *buf_lengths_elt += *lengths_elt - window_len + 1; start_offset = window_len - 1; } else { *buf_lengths_elt += 1; start_offset--; } /* move pointers if end of run */ if (start_offset == 0) { values_elt++; lengths_elt++; start_offset = *lengths_elt; } } } if (narm) UNPROTECT(1); return _numeric_Rle_constructor(buf_values, ans_len, buf_lengths, 0); } /* * --- .Call ENTRY POINT --- */ SEXP Rle_runwtsum(SEXP x, SEXP k, SEXP wt, SEXP na_rm) { SEXP ans = R_NilValue; switch(TYPEOF(GET_SLOT(x, install("values")))) { case INTSXP: PROTECT(ans = Rle_integer_runwtsum(x, k, wt, na_rm)); break; case REALSXP: PROTECT(ans = Rle_real_runwtsum(x, k, wt, na_rm)); break; default: error("runwtsum only supported for integer and numeric Rle objects"); } UNPROTECT(1); return ans; } SEXP Rle_integer_runq(SEXP x, SEXP k, SEXP which, SEXP na_rm) { int i, j, nrun, window_len, buf_len, x_vec_len, ans_len; int start_offset, curr_offset; int q_index; int stat, count_na, window_len_na; int *lengths_elt, *curr_length, *buf_lengths, *buf_lengths_elt; int *window, *values_elt, *curr_value, *buf_values, *buf_values_elt; SEXP values, lengths; const int narm = LOGICAL(na_rm)[0]; const int constw = INTEGER(which)[0]; const int constk = INTEGER(k)[0]; if (!IS_INTEGER(k) || LENGTH(k) != 1 || INTEGER(k)[0] == NA_INTEGER || INTEGER(k)[0] <= 0) error("'k' must be a positive integer"); if (!IS_INTEGER(which) || LENGTH(which) != 1 || INTEGER(which)[0] == NA_INTEGER || INTEGER(which)[0] < 1 || INTEGER(which)[0] > INTEGER(k)[0]) error("'i' must be an integer in [0, k]"); values = GET_SLOT(x, install("values")); lengths = GET_SLOT(x, install("lengths")); nrun = LENGTH(lengths); window_len = INTEGER(k)[0]; ans_len = 0; x_vec_len = 0; buf_len = - window_len + 1; for(i = 0, lengths_elt = INTEGER(lengths); i < nrun; i++, lengths_elt++) { x_vec_len += *lengths_elt; buf_len += *lengths_elt; if (window_len < *lengths_elt) buf_len -= *lengths_elt - window_len; } buf_values = NULL; buf_lengths = NULL; if (buf_len > 0) { window = (int *) R_alloc(window_len, sizeof(int)); buf_values = (int *) R_alloc((long) buf_len, sizeof(int)); buf_lengths = (int *) R_alloc((long) buf_len, sizeof(int)); memset(buf_lengths, 0, buf_len * sizeof(int)); buf_values_elt = buf_values; buf_lengths_elt = buf_lengths; values_elt = INTEGER(values); lengths_elt = INTEGER(lengths); start_offset = INTEGER(lengths)[0]; for (i = 0; i < buf_len; i++) { if (i % 100000 == 99999) R_CheckUserInterrupt(); /* create window */ count_na = 0; curr_value = values_elt; curr_length = lengths_elt; curr_offset = start_offset; window_len_na = INTEGER(k)[0]; q_index = INTEGER(which)[0] - 1; for(j = 0; j < window_len; j++) { if (*curr_value == NA_INTEGER) count_na += 1; window[j] = *curr_value; curr_offset--; if (curr_offset == 0) { curr_value++; curr_length++; curr_offset = *curr_length; } } /* calculate stat */ if (!narm && count_na > 0) { stat = NA_INTEGER; } else { /* NA handling */ if (count_na != 0) { window_len_na = window_len - count_na; q_index = roundingScale(window_len_na, constw, constk); if (q_index > 0) q_index = q_index - 1; } /* If window shrank to 0, return NA. */ if (window_len_na == 0) { stat = NA_INTEGER; } else { /* NA's sorted last in iPsort */ iPsort(window, window_len, q_index); stat = window[q_index]; } } if (ans_len == 0) { ans_len = 1; } else if (stat != *buf_values_elt) { ans_len++; buf_values_elt++; buf_lengths_elt++; } *buf_values_elt = stat; /* determine length */ if (window_len < start_offset) { *buf_lengths_elt += *lengths_elt - window_len + 1; start_offset = window_len - 1; } else { *buf_lengths_elt += 1; start_offset--; } /* move pointers if end of run */ if (start_offset == 0) { values_elt++; lengths_elt++; start_offset = *lengths_elt; } } } return _integer_Rle_constructor(buf_values, ans_len, buf_lengths, 0); } SEXP Rle_real_runq(SEXP x, SEXP k, SEXP which, SEXP na_rm) { int i, j, nrun, window_len, buf_len, x_vec_len, ans_len; int start_offset, curr_offset; int q_index; double stat; int count_na, window_len_na; int *lengths_elt, *curr_length, *buf_lengths, *buf_lengths_elt; double *window, *values_elt, *curr_value, *buf_values, *buf_values_elt; SEXP values, lengths; const int narm = LOGICAL(na_rm)[0]; const int constw = INTEGER(which)[0]; const int constk = INTEGER(k)[0]; if (!IS_INTEGER(k) || LENGTH(k) != 1 || INTEGER(k)[0] == NA_INTEGER || INTEGER(k)[0] <= 0) error("'k' must be a positive integer"); if (!IS_INTEGER(which) || LENGTH(which) != 1 || INTEGER(which)[0] == NA_INTEGER || INTEGER(which)[0] < 1 || INTEGER(which)[0] > INTEGER(k)[0]) error("'which' must be an integer in [0, k]"); values = GET_SLOT(x, install("values")); lengths = GET_SLOT(x, install("lengths")); nrun = LENGTH(lengths); window_len = INTEGER(k)[0]; ans_len = 0; x_vec_len = 0; buf_len = - window_len + 1; for(i = 0, lengths_elt = INTEGER(lengths); i < nrun; i++, lengths_elt++) { x_vec_len += *lengths_elt; buf_len += *lengths_elt; if (window_len < *lengths_elt) buf_len -= *lengths_elt - window_len; } buf_values = NULL; buf_lengths = NULL; if (buf_len > 0) { window = (double *) R_alloc(window_len, sizeof(double)); buf_values = (double *) R_alloc((long) buf_len, sizeof(double)); buf_lengths = (int *) R_alloc((long) buf_len, sizeof(int)); memset(buf_lengths, 0, buf_len * sizeof(int)); buf_values_elt = buf_values; buf_lengths_elt = buf_lengths; values_elt = REAL(values); lengths_elt = INTEGER(lengths); start_offset = INTEGER(lengths)[0]; for (i = 0; i < buf_len; i++) { if (i % 100000 == 99999) R_CheckUserInterrupt(); /* create window */ count_na = 0; curr_value = values_elt; curr_length = lengths_elt; curr_offset = start_offset; window_len_na = INTEGER(k)[0]; q_index = INTEGER(which)[0] - 1; for(j = 0; j < window_len; j++) { if (ISNAN(*curr_value)) count_na += 1; window[j] = *curr_value; curr_offset--; if (curr_offset == 0) { curr_value++; curr_length++; curr_offset = *curr_length; } } /* calculate stat */ if (!narm && count_na > 0) { stat = NA_REAL; } else { /* NA handling */ if (count_na != 0) window_len_na = window_len - count_na; q_index = roundingScale(window_len_na, constw, constk); if (q_index >0) q_index = q_index - 1; /* If window shrank to 0, return NA. */ if (window_len_na == 0) { stat = NA_REAL; } else { /* NA's sorted last in rPsort */ rPsort(window, window_len, q_index); stat = window[q_index]; } } if (ans_len == 0) { ans_len = 1; } else if (stat != *buf_values_elt) { ans_len++; buf_values_elt++; buf_lengths_elt++; } *buf_values_elt = stat; /* determine length */ if (window_len < start_offset) { *buf_lengths_elt += *lengths_elt - window_len + 1; start_offset = window_len - 1; } else { *buf_lengths_elt += 1; start_offset--; } /* move pointers if end of run */ if (start_offset == 0) { values_elt++; lengths_elt++; start_offset = *lengths_elt; } } } return _numeric_Rle_constructor(buf_values, ans_len, buf_lengths, 0); } /* * --- .Call ENTRY POINT --- */ SEXP Rle_runq(SEXP x, SEXP k, SEXP which, SEXP na_rm) { SEXP ans = R_NilValue; switch(TYPEOF(GET_SLOT(x, install("values")))) { case INTSXP: PROTECT(ans = Rle_integer_runq(x, k, which, na_rm)); break; case REALSXP: PROTECT(ans = Rle_real_runq(x, k, which, na_rm)); break; default: error("runq only supported for integer and numeric Rle objects"); } UNPROTECT(1); return ans; } S4Vectors/src/S4Vectors.h0000644000175100017510000002407412607346177016246 0ustar00biocbuildbiocbuild#include "../inst/include/S4Vectors_defines.h" #include #define DEBUG_S4VECTORS 1 #define INIT_STATIC_SYMBOL(NAME) \ { \ if (NAME ## _symbol == NULL) \ NAME ## _symbol = install(# NAME); \ } /* safe_arithm.c */ void _reset_ovflow_flag(); int _get_ovflow_flag(); int _safe_int_add( int x, int y ); int _safe_int_mult( int x, int y ); /* sort_utils.c */ void _sort_int_array( int *x, int nelt, int desc ); void _get_order_of_int_array( const int *x, int nelt, int desc, int *out, int out_shift ); void _compare_int_pairs( const int *a1, const int *b1, int nelt1, const int *a2, const int *b2, int nelt2, int *out, int out_len, int with_warning ); int _int_pairs_are_sorted( const int *a, const int *b, int nelt, int desc, int strict ); void _get_order_of_int_pairs( const int *a, const int *b, int nelt, int desc, int *out, int out_shift ); void _get_matches_of_ordered_int_pairs( const int *a1, const int *b1, const int *o1, int nelt1, const int *a2, const int *b2, const int *o2, int nelt2, int nomatch, int *out, int out_shift ); void _get_order_of_int_quads( const int *a, const int *b, const int *c, const int *d, int nelt, int desc, int *out, int out_shift ); void _get_matches_of_ordered_int_quads( const int *a1, const int *b1, const int *c1, const int *d1, const int *o1, int nelt1, const int *a2, const int *b2, const int *c2, const int *d2, const int *o2, int nelt2, int nomatch, int *out, int out_shift ); /* hash_utils.c */ struct htab _new_htab(int n); int _get_hbucket_val( const struct htab *htab, int bucket_idx ); void _set_hbucket_val( struct htab *htab, int bucket_idx, int val ); /* AEbufs.c */ SEXP debug_AEbufs(); SEXP AEbufs_use_malloc(SEXP x); int _get_new_buflength(int buflength); int _IntAE_get_nelt(const IntAE *ae); int _IntAE_set_nelt( IntAE *ae, int nelt ); void _IntAE_set_val( const IntAE *ae, int val ); void _IntAE_insert_at( IntAE *ae, int at, int val ); IntAE *_new_IntAE( int buflength, int nelt, int val ); void _IntAE_append( IntAE *ae, const int *newvals, int nnewval ); void _IntAE_delete_at( IntAE *ae, int at ); void _IntAE_shift( const IntAE *ae, int shift ); void _IntAE_sum_and_shift( const IntAE *ae1, const IntAE *ae2, int shift ); void _IntAE_append_shifted_vals( IntAE *ae, const int *newvals, int nnewval, int shift ); void _IntAE_qsort( const IntAE *ae, int desc ); void _IntAE_delete_adjdups(IntAE *ae); SEXP _new_INTEGER_from_IntAE(const IntAE *ae); IntAE *_new_IntAE_from_INTEGER(SEXP x); IntAE *_new_IntAE_from_CHARACTER( SEXP x, int keyshift ); int _IntAEAE_get_nelt(const IntAEAE *aeae); int _IntAEAE_set_nelt( IntAEAE *aeae, int nelt ); void _IntAEAE_insert_at( IntAEAE *aeae, int at, IntAE *ae ); IntAEAE *_new_IntAEAE( int buflength, int nelt ); void _IntAEAE_eltwise_append( const IntAEAE *aeae1, const IntAEAE *aeae2 ); void _IntAEAE_shift( const IntAEAE *aeae, int shift ); void _IntAEAE_sum_and_shift( const IntAEAE *aeae1, const IntAEAE *aeae2, int shift ); SEXP _new_LIST_from_IntAEAE( const IntAEAE *aeae, int mode ); IntAEAE *_new_IntAEAE_from_LIST(SEXP x); SEXP _IntAEAE_toEnvir( const IntAEAE *aeae, SEXP envir, int keyshift ); int _IntPairAE_get_nelt(const IntPairAE *ae); int _IntPairAE_set_nelt( IntPairAE *ae, int nelt ); void _IntPairAE_insert_at( IntPairAE *ae, int at, int a, int b ); IntPairAE *_new_IntPairAE( int buflength, int nelt ); int _IntPairAEAE_get_nelt(const IntPairAEAE *aeae); int _IntPairAEAE_set_nelt( IntPairAEAE *aeae, int nelt ); void _IntPairAEAE_insert_at( IntPairAEAE *aeae, int at, IntPairAE *ae ); IntPairAEAE *_new_IntPairAEAE( int buflength, int nelt ); int _LLongAE_get_nelt(const LLongAE *ae); int _LLongAE_set_nelt( LLongAE *ae, int nelt ); void _LLongAE_set_val( const LLongAE *ae, long long val ); void _LLongAE_insert_at( LLongAE *ae, int at, long long val ); LLongAE *_new_LLongAE( int buflength, int nelt, long long val ); int _CharAE_get_nelt(const CharAE *ae); int _CharAE_set_nelt( CharAE *ae, int nelt ); void _CharAE_insert_at( CharAE *ae, int at, char c ); CharAE *_new_CharAE(int buflength); CharAE *_new_CharAE_from_string(const char *string); void _append_string_to_CharAE( CharAE *ae, const char *string ); void _CharAE_delete_at( CharAE *ae, int at, int nelt ); SEXP _new_RAW_from_CharAE(const CharAE *ae); SEXP _new_LOGICAL_from_CharAE(const CharAE *ae); int _CharAEAE_get_nelt(const CharAEAE *aeae); int _CharAEAE_set_nelt( CharAEAE *aeae, int nelt ); void _CharAEAE_insert_at( CharAEAE *aeae, int at, CharAE *ae ); CharAEAE *_new_CharAEAE( int buflength, int nelt ); void _append_string_to_CharAEAE( CharAEAE *aeae, const char *string ); SEXP _new_CHARACTER_from_CharAEAE(const CharAEAE *aeae); SEXP AEbufs_free(); /* SEXP_utils.c */ const char *_get_classname(SEXP x); /* anyMissing.c */ SEXP anyMissing(SEXP x); /* vector_utils.c */ int _vector_memcmp( SEXP x1, int x1_offset, SEXP x2, int x2_offset, int nelt ); void _vector_memcpy( SEXP out, int out_offset, SEXP in, int in_offset, int nelt ); SEXP sapply_NROW(SEXP x); SEXP vector_subsetByRanges( SEXP x, SEXP start, SEXP width ); SEXP vector_seqselect( SEXP x, SEXP start, SEXP width ); SEXP _list_as_data_frame( SEXP x, int nrow ); /* logical_utils.c */ SEXP logical_as_compact_bitvector(SEXP x); SEXP compact_bitvector_as_logical(SEXP x, SEXP length_out); SEXP subset_compact_bitvector(SEXP x, SEXP subscript); SEXP compact_bitvector_bit_count(SEXP x); SEXP compact_bitvector_last_bit(SEXP x); SEXP compact_bitvector_set_op(SEXP query, SEXP ref, SEXP align); /* int_utils.c */ SEXP Integer_any_missing_or_outside(SEXP x, SEXP lower, SEXP upper); int _sum_non_neg_ints( const int *x, int x_len, const char *varname ); SEXP Integer_sum_non_neg_vals(SEXP x); SEXP Integer_diff_with_0(SEXP x); SEXP Integer_diff_with_last(SEXP x, SEXP last); SEXP Integer_order( SEXP x, SEXP decreasing ); int _check_integer_pairs( SEXP a, SEXP b, const int **a_p, const int **b_p, const char *a_argname, const char *b_argname ); SEXP Integer_compare2( SEXP a1, SEXP b1, SEXP a2, SEXP b2 ); SEXP Integer_sorted2( SEXP a, SEXP b, SEXP decreasing, SEXP strictly ); SEXP Integer_order2( SEXP a, SEXP b, SEXP decreasing ); SEXP Integer_match2_quick( SEXP a1, SEXP b1, SEXP a2, SEXP b2, SEXP nomatch ); SEXP Integer_selfmatch2_quick( SEXP a, SEXP b ); SEXP Integer_match2_hash( SEXP a1, SEXP b1, SEXP a2, SEXP b2, SEXP nomatch ); SEXP Integer_selfmatch2_hash( SEXP a, SEXP b ); int _check_integer_quads( SEXP a, SEXP b, SEXP c, SEXP d, const int **a_p, const int **b_p, const int **c_p, const int **d_p, const char *a_argname, const char *b_argname, const char *c_argname, const char *d_argname ); SEXP Integer_order4( SEXP a, SEXP b, SEXP c, SEXP d, SEXP decreasing ); SEXP Integer_match4_quick( SEXP a1, SEXP b1, SEXP c1, SEXP d1, SEXP a2, SEXP b2, SEXP c2, SEXP d2, SEXP nomatch ); SEXP Integer_selfmatch4_quick( SEXP a, SEXP b, SEXP c, SEXP d ); SEXP Integer_match4_hash( SEXP a1, SEXP b1, SEXP c1, SEXP d1, SEXP a2, SEXP b2, SEXP c2, SEXP d2, SEXP nomatch ); SEXP Integer_selfmatch4_hash( SEXP a, SEXP b, SEXP c, SEXP d ); SEXP Integer_tabulate2( SEXP x, SEXP nbins, SEXP weight, SEXP strict ); SEXP Integer_explode_bits( SEXP x, SEXP bitpos ); SEXP Integer_sorted_merge( SEXP x, SEXP y ); SEXP Integer_mseq( SEXP from, SEXP to ); SEXP Integer_fancy_mseq( SEXP lengths, SEXP offset, SEXP rev ); SEXP _find_interv_and_start_from_width( const int *x, int x_len, const int *width, int width_len ); SEXP findIntervalAndStartFromWidth( SEXP x, SEXP vec ); /* str_utils.c */ SEXP unstrsplit_list(SEXP x, SEXP sep); SEXP safe_strexplode(SEXP s); SEXP strsplit_as_list_of_ints(SEXP x, SEXP sep); SEXP svn_time(); /* eval_utils.c */ SEXP top_prenv(SEXP nm, SEXP env); SEXP top_prenv_dots(SEXP env); /* subsetting_internals.c */ SEXP vector_extract_window(SEXP x, SEXP start, SEXP end); /* Hits_class.c */ SEXP _new_Hits( int *q_hits, const int *s_hits, int nhit, int q_len, int s_len, int already_sorted ); SEXP Hits_new( SEXP q_hits, SEXP s_hits, SEXP q_len, SEXP s_len, SEXP revmap_envir ); int _get_select_mode(SEXP select); SEXP select_hits( SEXP q_hits, SEXP s_hits, SEXP q_len, SEXP select ); SEXP make_all_group_inner_hits( SEXP group_sizes, SEXP hit_type ); /* Rle_class.c */ SEXP _logical_Rle_constructor( const int *values, int nvalues, const int *lengths, int buflength ); SEXP _integer_Rle_constructor( const int *values, int nvalues, const int *lengths, int buflength ); SEXP _numeric_Rle_constructor( const double *values, int nvalues, const int *lengths, int buflength ); SEXP _complex_Rle_constructor( const Rcomplex *values, int nvalues, const int *lengths, int buflength ); SEXP _character_Rle_constructor( SEXP values, const int *lengths, int buflength ); SEXP _raw_Rle_constructor( const Rbyte *values, int nvalues, const int *lengths, int buflength ); SEXP Rle_constructor( SEXP values, SEXP lengths, SEXP check, SEXP buflength ); SEXP Rle_start(SEXP x); SEXP Rle_end(SEXP x); SEXP Rle_getStartEndRunAndOffset( SEXP x, SEXP start, SEXP end ); SEXP Rle_window_aslist( SEXP x, SEXP runStart, SEXP runEnd, SEXP offsetStart, SEXP offsetEnd ); SEXP Rle_window( SEXP x, SEXP runStart, SEXP runEnd, SEXP offsetStart, SEXP offsetEnd, SEXP ans ); SEXP _seqselect_Rle( SEXP x, const int *start, const int *width, int length ); SEXP Rle_seqselect( SEXP x, SEXP start, SEXP width ); /* Rle_utils.c */ SEXP Rle_runsum( SEXP x, SEXP k, SEXP na_rm ); SEXP Rle_runwtsum( SEXP x, SEXP k, SEXP wt, SEXP na_rm ); SEXP Rle_runq( SEXP x, SEXP k, SEXP which, SEXP na_rm ); /* List_class.c */ const char *_get_List_elementType(SEXP x); void _set_List_elementType( SEXP x, const char *type ); /* SimpleList_class.c */ SEXP _new_SimpleList( const char *classname, SEXP listData ); /* DataFrame_class.c */ SEXP _new_DataFrame( const char *classname, SEXP vars, SEXP rownames, SEXP nrows ); S4Vectors/src/SEXP_utils.c0000644000175100017510000000015412607346177016375 0ustar00biocbuildbiocbuild#include "S4Vectors.h" const char *_get_classname(SEXP x) { return CHAR(STRING_ELT(GET_CLASS(x), 0)); } S4Vectors/src/SimpleList_class.c0000644000175100017510000000124012607346177017645 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of SimpleList objects ****************************************************************************/ #include "S4Vectors.h" static SEXP listData_symbol = NULL; static void set_SimpleList_listData(SEXP x, SEXP value) { INIT_STATIC_SYMBOL(listData) SET_SLOT(x, listData_symbol, value); return; } SEXP _new_SimpleList(const char *classname, SEXP listData) { SEXP classdef, ans; PROTECT(classdef = MAKE_CLASS(classname)); PROTECT(ans = NEW_OBJECT(classdef)); set_SimpleList_listData(ans, listData); UNPROTECT(2); return ans; } S4Vectors/src/anyMissing.c0000644000175100017510000000403412607346177016520 0ustar00biocbuildbiocbuild/*************************************************************************** Public methods: anyMissing(SEXP x) TO DO: Support list():s too. Copyright Henrik Bengtsson, 2007 **************************************************************************/ /* Include R packages */ #include SEXP anyMissing(SEXP x) { SEXP ans; int n, ii; PROTECT(ans = allocVector(LGLSXP, 1)); LOGICAL(ans)[0] = 0; n = length(x); /* anyMissing() on zero-length objects should always return FALSE, just like any(double(0)). */ if (n == 0) { UNPROTECT(1); return(ans); } switch (TYPEOF(x)) { case REALSXP: for (ii=0; ii < n; ii++) { if ISNAN(REAL(x)[ii]) { LOGICAL(ans)[0] = 1; break; } } break; case INTSXP: for (ii=0; ii < n; ii++) { if (INTEGER(x)[ii] == NA_INTEGER) { LOGICAL(ans)[0] = 1; break; } } break; case LGLSXP: for (ii=0; ii < n; ii++) { if (LOGICAL(x)[ii] == NA_LOGICAL) { LOGICAL(ans)[0] = 1; break; } } break; case CPLXSXP: for (ii=0; ii < n; ii++) { if (ISNAN(COMPLEX(x)[ii].r) || ISNAN(COMPLEX(x)[ii].i)) { LOGICAL(ans)[0] = 1; break; } } break; case STRSXP: for (ii=0; ii < n; ii++) { if (STRING_ELT(x, ii) == NA_STRING) { LOGICAL(ans)[0] = 1; break; } } break; case RAWSXP: /* no such thing as a raw NA */ break; default: break; /* warningcall(call, _("%s() applied to non-vector of type '%s'"), "anyMissing", type2char(TYPEOF(x))); */ } /* switch() */ UNPROTECT(1); /* ans */ return(ans); } // anyMissing() /*************************************************************************** HISTORY: 2007-08-14 [HB] o Created using do_isna() in src/main/coerce.c as a template. **************************************************************************/ S4Vectors/src/eval_utils.c0000644000175100017510000000144712607346177016553 0ustar00biocbuildbiocbuild#include "S4Vectors.h" static SEXP _top_prenv(SEXP promise, SEXP env) { while(TYPEOF(promise) == PROMSXP) { env = PRENV(promise); promise = PREXPR(promise); } return env; } /* * --- .Call ENTRY POINT --- * Gets the top environment associated with a (nested) promise. */ SEXP top_prenv(SEXP nm, SEXP env) { SEXP promise = findVar(nm, env); return _top_prenv(promise, env); } /* * --- .Call ENTRY POINT --- * Gets the top environment associated with each promise in '...' */ SEXP top_prenv_dots(SEXP env) { SEXP dots = findVar(R_DotsSymbol, env); SEXP ans = allocVector(VECSXP, length(dots)); if (TYPEOF(dots) == DOTSXP) { int i = 0; for (SEXP p = dots; p != R_NilValue; p = CDR(p)) { SET_VECTOR_ELT(ans, i++, _top_prenv(CAR(p), env)); } } return ans; } S4Vectors/src/hash_utils.c0000644000175100017510000000214212607346177016540 0ustar00biocbuildbiocbuild/**************************************************************************** * Hash table management * ****************************************************************************/ #include "S4Vectors.h" /* * Author: Martin Morgan * Modified from R_HOME/src/main/unique.c */ static void htab_init(struct htab *htab, int n) { int n2, i; /* max supported value for n is 2^29 */ if (n < 0 || n > 536870912) /* protect against overflow to -ve */ error("length %d is too large for hashing", n); n2 = 2 * n; htab->M = 2; htab->K = 1; while (htab->M < n2) { htab->M *= 2; htab->K += 1; } htab->Mminus1 = htab->M - 1; htab->buckets = (int *) R_alloc(sizeof(int), htab->M); for (i = 0; i < htab->M; i++) htab->buckets[i] = NA_INTEGER; return; } struct htab _new_htab(int n) { struct htab htab; htab_init(&htab, n); return htab; } int _get_hbucket_val(const struct htab *htab, int bucket_idx) { return htab->buckets[bucket_idx]; } void _set_hbucket_val(struct htab *htab, int bucket_idx, int val) { htab->buckets[bucket_idx] = val; return; } S4Vectors/src/int_utils.c0000644000175100017510000006011612607346177016414 0ustar00biocbuildbiocbuild#include "S4Vectors.h" #include /* for INT_MAX */ static int get_bucket_idx_for_int_pair(const struct htab *htab, int a1, int b1, const int *a2, const int *b2) { unsigned int hval; int bucket_idx, i2; const int *buckets; /* use 2 consecutive prime numbers (seems to work well, no serious justification for it) */ hval = 3951551U * a1 + 3951553U * b1; bucket_idx = hval & htab->Mminus1; buckets = htab->buckets; while ((i2 = buckets[bucket_idx]) != NA_INTEGER) { if (a2[i2] == a1 && b2[i2] == b1) break; bucket_idx = (bucket_idx + 1) % htab->M; } return bucket_idx; } static int get_bucket_idx_for_int_quad(const struct htab *htab, int a1, int b1, int c1, int d1, const int *a2, const int *b2, const int *c2, const int *d2) { unsigned int hval; int bucket_idx, i2; const int *buckets; /* use 4 consecutive prime numbers (seems to work well, no serious justification for it) */ hval = 3951551U * a1 + 3951553U * b1 + 3951557U * c1 + 3951559U * d1; bucket_idx = hval & htab->Mminus1; buckets = htab->buckets; while ((i2 = buckets[bucket_idx]) != NA_INTEGER) { if (a2[i2] == a1 && b2[i2] == b1 && c2[i2] == c1 && d2[i2] == d1) break; bucket_idx = (bucket_idx + 1) % htab->M; } return bucket_idx; } /**************************************************************************** * --- .Call ENTRY POINT --- * any(is.na(x) | x < lower | x > upper) */ SEXP Integer_any_missing_or_outside(SEXP x, SEXP lower, SEXP upper) { int x_len, lower0, upper0, ans, i; const int *x_p; x_len = length(x); lower0 = INTEGER(lower)[0]; upper0 = INTEGER(upper)[0]; ans = 0; for (i = 0, x_p = INTEGER(x); i < x_len; i++, x_p++) { if (*x_p == NA_INTEGER || *x_p < lower0 || *x_p > upper0) { ans = 1; break; } } return ScalarLogical(ans); } /**************************************************************************** * Sum non-negative integers. */ /* * Walk 'x' and sum its elements. Stop walking at the first occurence of one * of the 3 following conditions: (1) the element is NA, or (2) the element is * negative, or (3) the partial sum is > INT_MAX (integer overflow). * How the function handles those conditions depends on 'varname'. If it's NULL * then no error is raised and a negative code is returned (indicating the kind * of condition that occured). Otherwise an error is raised (when not NULL, * 'varname' must be a C string i.e. 0-terminated). * If none of the 3 above conditions happen, then 'sum(x)' is returned. */ int _sum_non_neg_ints(const int *x, int x_len, const char *varname) { int i; unsigned int sum; for (i = sum = 0; i < x_len; i++, x++) { if (*x == NA_INTEGER || *x < 0) { if (varname == NULL) return -1; error("'%s' contains NAs or negative values", varname); } sum += *x; if (sum > (unsigned int) INT_MAX) { if (varname == NULL) return -2; error("integer overflow while summing elements " "in '%s'", varname); } } return sum; } /* * --- .Call ENTRY POINT --- */ SEXP Integer_sum_non_neg_vals(SEXP x) { return ScalarInteger(_sum_non_neg_ints(INTEGER(x), LENGTH(x), "x")); } /**************************************************************************** * --- .Call ENTRY POINT --- * diff(c(0L, x)) */ SEXP Integer_diff_with_0(SEXP x) { int i, len, *x_ptr1, *x_ptr2, *ans_ptr; SEXP ans; len = LENGTH(x); PROTECT(ans = NEW_INTEGER(len)); if (len > 0) { INTEGER(ans)[0] = INTEGER(x)[0]; if (len > 1) { for (i = 1, x_ptr1 = INTEGER(x), x_ptr2 = INTEGER(x) + 1, ans_ptr = INTEGER(ans) + 1; i < len; i++, x_ptr1++, x_ptr2++, ans_ptr++) { *ans_ptr = *x_ptr2 - *x_ptr1; } } } UNPROTECT(1); return ans; } /**************************************************************************** * --- .Call ENTRY POINT --- * diff(c(x, last)) */ SEXP Integer_diff_with_last(SEXP x, SEXP last) { int i, len, *x_ptr1, *x_ptr2, *ans_ptr; SEXP ans; len = LENGTH(x); PROTECT(ans = NEW_INTEGER(len)); if (len > 0) { for (i = 1, x_ptr1 = INTEGER(x), x_ptr2 = INTEGER(x) + 1, ans_ptr = INTEGER(ans); i < len; i++, x_ptr1++, x_ptr2++, ans_ptr++) { *ans_ptr = *x_ptr2 - *x_ptr1; } INTEGER(ans)[len - 1] = INTEGER(last)[0] - INTEGER(x)[len - 1]; } UNPROTECT(1); return ans; } /**************************************************************************** * The .Call entry points in this section are the workhorses behind * orderInteger(), orderIntegerPairs(), matchIntegerPairs(), and * duplicatedIntegerPairs(). */ /* * Nothing deep, just checking that 'a' and 'b' are integer vectors of the * same length. We don't look at the individual elements in them, and, * in particular, we don't check for NAs. */ int _check_integer_pairs(SEXP a, SEXP b, const int **a_p, const int **b_p, const char *a_argname, const char *b_argname) { int len; if (!IS_INTEGER(a) || !IS_INTEGER(b)) error("'%s' and '%s' must be integer vectors", a_argname, b_argname); len = LENGTH(a); if (LENGTH(b) != len) error("'%s' and '%s' must have the same length", a_argname, b_argname); *a_p = INTEGER(a); *b_p = INTEGER(b); return len; } /* --- .Call ENTRY POINT --- */ SEXP Integer_order(SEXP x, SEXP decreasing) { int ans_length; SEXP ans; ans_length = LENGTH(x); PROTECT(ans = NEW_INTEGER(ans_length)); _get_order_of_int_array(INTEGER(x), ans_length, LOGICAL(decreasing)[0], INTEGER(ans), 1); UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- * 'a1' and 'b1': integer vectors of the same length M. * 'a2' and 'b2': integer vectors of the same length N. * The 4 integer vectors are assumed to be NA free. For efficiency reason, this * is not checked. * If M != N then the shorter object is recycled to the length of the longer * object, except if M or N is 0 in which case the object with length != 0 is * truncated to length 0. */ SEXP Integer_compare2(SEXP a1, SEXP b1, SEXP a2, SEXP b2) { int npair1, npair2, ans_len; const int *a1_p, *b1_p, *a2_p, *b2_p; SEXP ans; npair1 = _check_integer_pairs(a1, b1, &a1_p, &b1_p, "a1", "b1"); npair2 = _check_integer_pairs(a2, b2, &a2_p, &b2_p, "a2", "b2"); if (npair1 == 0 || npair2 == 0) ans_len = 0; else ans_len = npair1 >= npair2 ? npair1 : npair2; PROTECT(ans = NEW_INTEGER(ans_len)); _compare_int_pairs(a1_p, b1_p, npair1, a2_p, b2_p, npair2, INTEGER(ans), ans_len, 1); UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- */ SEXP Integer_sorted2(SEXP a, SEXP b, SEXP decreasing, SEXP strictly) { const int *a_p, *b_p; int npair, ans; npair = _check_integer_pairs(a, b, &a_p, &b_p, "a", "b"); ans = _int_pairs_are_sorted(a_p, b_p, npair, LOGICAL(decreasing)[0], LOGICAL(strictly)[0]); return ScalarLogical(ans); } /* --- .Call ENTRY POINT --- */ SEXP Integer_order2(SEXP a, SEXP b, SEXP decreasing) { int ans_length; const int *a_p, *b_p; SEXP ans; ans_length = _check_integer_pairs(a, b, &a_p, &b_p, "a", "b"); PROTECT(ans = NEW_INTEGER(ans_length)); _get_order_of_int_pairs(a_p, b_p, ans_length, LOGICAL(decreasing)[0], INTEGER(ans), 1); UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- */ SEXP Integer_match2_quick(SEXP a1, SEXP b1, SEXP a2, SEXP b2, SEXP nomatch) { int len1, len2, nomatch0, *o1, *o2; const int *a1_p, *b1_p, *a2_p, *b2_p; SEXP ans; len1 = _check_integer_pairs(a1, b1, &a1_p, &b1_p, "a1", "b1"); len2 = _check_integer_pairs(a2, b2, &a2_p, &b2_p, "a2", "b2"); nomatch0 = INTEGER(nomatch)[0]; o1 = (int *) R_alloc(sizeof(int), len1); o2 = (int *) R_alloc(sizeof(int), len2); _get_order_of_int_pairs(a1_p, b1_p, len1, 0, o1, 0); _get_order_of_int_pairs(a2_p, b2_p, len2, 0, o2, 0); PROTECT(ans = NEW_INTEGER(len1)); _get_matches_of_ordered_int_pairs(a1_p, b1_p, o1, len1, a2_p, b2_p, o2, len2, nomatch0, INTEGER(ans), 1); UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- */ SEXP Integer_selfmatch2_quick(SEXP a, SEXP b) { int len, *o1; const int *a_p, *b_p; SEXP ans; len = _check_integer_pairs(a, b, &a_p, &b_p, "a", "b"); o1 = (int *) R_alloc(sizeof(int), len); _get_order_of_int_pairs(a_p, b_p, len, 0, o1, 0); PROTECT(ans = NEW_INTEGER(len)); _get_matches_of_ordered_int_pairs(a_p, b_p, o1, len, a_p, b_p, o1, len, -1, INTEGER(ans), 1); UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- */ SEXP Integer_match2_hash(SEXP a1, SEXP b1, SEXP a2, SEXP b2, SEXP nomatch) { int len1, len2, nomatch0, *ans0, i, bucket_idx, i2; const int *a1_p, *b1_p, *a2_p, *b2_p; struct htab htab; SEXP ans; len1 = _check_integer_pairs(a1, b1, &a1_p, &b1_p, "a1", "b1"); len2 = _check_integer_pairs(a2, b2, &a2_p, &b2_p, "a2", "b2"); nomatch0 = INTEGER(nomatch)[0]; htab = _new_htab(len2); for (i = 0; i < len2; i++) { bucket_idx = get_bucket_idx_for_int_pair(&htab, a2_p[i], b2_p[i], a2_p, b2_p); if (_get_hbucket_val(&htab, bucket_idx) == NA_INTEGER) _set_hbucket_val(&htab, bucket_idx, i); } PROTECT(ans = NEW_INTEGER(len1)); ans0 = INTEGER(ans); for (i = 0; i < len1; i++) { bucket_idx = get_bucket_idx_for_int_pair(&htab, a1_p[i], b1_p[i], a2_p, b2_p); i2 = _get_hbucket_val(&htab, bucket_idx); if (i2 == NA_INTEGER) ans0[i] = nomatch0; else ans0[i] = i2 + 1; } UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- */ SEXP Integer_selfmatch2_hash(SEXP a, SEXP b) { int ans_length, *ans0, i, bucket_idx, i2; const int *a_p, *b_p; struct htab htab; SEXP ans; ans_length = _check_integer_pairs(a, b, &a_p, &b_p, "a", "b"); htab = _new_htab(ans_length); PROTECT(ans = NEW_INTEGER(ans_length)); ans0 = INTEGER(ans); for (i = 0; i < ans_length; i++) { bucket_idx = get_bucket_idx_for_int_pair(&htab, a_p[i], b_p[i], a_p, b_p); i2 = _get_hbucket_val(&htab, bucket_idx); if (i2 == NA_INTEGER) { _set_hbucket_val(&htab, bucket_idx, i); ans0[i] = i + 1; } else { ans0[i] = i2 + 1; } } UNPROTECT(1); return ans; } /**************************************************************************** * The .Call entry points in this section are the workhorses behind * orderIntegerQuads(), matchIntegerQuads() and duplicatedIntegerQuads(). */ /* * Nothing deep, just checking that 'a', 'b', 'c' and 'd' are integer vectors * of the same length. We don't look at the individual elements in them, and, * in particular, we don't check for NAs. */ int _check_integer_quads(SEXP a, SEXP b, SEXP c, SEXP d, const int **a_p, const int **b_p, const int **c_p, const int **d_p, const char *a_argname, const char *b_argname, const char *c_argname, const char *d_argname) { int len; if (!IS_INTEGER(a) || !IS_INTEGER(b) || !IS_INTEGER(c) || !IS_INTEGER(d)) error("'%s', '%s', '%s' and '%s' must be integer vectors", a_argname, b_argname, c_argname, d_argname); len = LENGTH(a); if (LENGTH(b) != len || LENGTH(c) != len || LENGTH(d) != len) error("'%s', '%s', '%s' and '%s' must have the same length", a_argname, b_argname, c_argname, d_argname); *a_p = INTEGER(a); *b_p = INTEGER(b); *c_p = INTEGER(c); *d_p = INTEGER(d); return len; } /* --- .Call ENTRY POINT --- */ SEXP Integer_order4(SEXP a, SEXP b, SEXP c, SEXP d, SEXP decreasing) { int ans_length; const int *a_p, *b_p, *c_p, *d_p; SEXP ans; ans_length = _check_integer_quads(a, b, c, d, &a_p, &b_p, &c_p, &d_p, "a", "b", "c", "d"); PROTECT(ans = NEW_INTEGER(ans_length)); _get_order_of_int_quads(a_p, b_p, c_p, d_p, ans_length, LOGICAL(decreasing)[0], INTEGER(ans), 1); UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- */ SEXP Integer_match4_quick(SEXP a1, SEXP b1, SEXP c1, SEXP d1, SEXP a2, SEXP b2, SEXP c2, SEXP d2, SEXP nomatch) { int len1, len2, nomatch0, *o1, *o2; const int *a1_p, *b1_p, *c1_p, *d1_p, *a2_p, *b2_p, *c2_p, *d2_p; SEXP ans; len1 = _check_integer_quads(a1, b1, c1, d1, &a1_p, &b1_p, &c1_p, &d1_p, "a1", "b1", "c1", "d1"); len2 = _check_integer_quads(a2, b2, c2, d2, &a2_p, &b2_p, &c2_p, &d2_p, "a2", "b2", "c2", "d2"); nomatch0 = INTEGER(nomatch)[0]; o1 = (int *) R_alloc(sizeof(int), len1); o2 = (int *) R_alloc(sizeof(int), len2); _get_order_of_int_quads(a1_p, b1_p, c1_p, d1_p, len1, 0, o1, 0); _get_order_of_int_quads(a2_p, b2_p, c2_p, d2_p, len2, 0, o2, 0); PROTECT(ans = NEW_INTEGER(len1)); _get_matches_of_ordered_int_quads(a1_p, b1_p, c1_p, d1_p, o1, len1, a2_p, b2_p, c2_p, d2_p, o2, len2, nomatch0, INTEGER(ans), 1); UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- */ SEXP Integer_selfmatch4_quick(SEXP a, SEXP b, SEXP c, SEXP d) { int len, *o1; const int *a_p, *b_p, *c_p, *d_p; SEXP ans; len = _check_integer_quads(a, b, c, d, &a_p, &b_p, &c_p, &d_p, "a", "b", "c", "d"); o1 = (int *) R_alloc(sizeof(int), len); _get_order_of_int_quads(a_p, b_p, c_p, d_p, len, 0, o1, 0); PROTECT(ans = NEW_INTEGER(len)); _get_matches_of_ordered_int_quads(a_p, b_p, c_p, d_p, o1, len, a_p, b_p, c_p, d_p, o1, len, -1, INTEGER(ans), 1); UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- */ SEXP Integer_match4_hash(SEXP a1, SEXP b1, SEXP c1, SEXP d1, SEXP a2, SEXP b2, SEXP c2, SEXP d2, SEXP nomatch) { int len1, len2, nomatch0, *ans0, i, bucket_idx, i2; const int *a1_p, *b1_p, *c1_p, *d1_p, *a2_p, *b2_p, *c2_p, *d2_p; struct htab htab; SEXP ans; len1 = _check_integer_quads(a1, b1, c1, d1, &a1_p, &b1_p, &c1_p, &d1_p, "a1", "b1", "c1", "d1"); len2 = _check_integer_quads(a2, b2, c2, d2, &a2_p, &b2_p, &c2_p, &d2_p, "a2", "b2", "c2", "d2"); nomatch0 = INTEGER(nomatch)[0]; htab = _new_htab(len2); for (i = 0; i < len2; i++) { bucket_idx = get_bucket_idx_for_int_quad(&htab, a2_p[i], b2_p[i], c2_p[i], d2_p[i], a2_p, b2_p, c2_p, d2_p); if (_get_hbucket_val(&htab, bucket_idx) == NA_INTEGER) _set_hbucket_val(&htab, bucket_idx, i); } PROTECT(ans = NEW_INTEGER(len1)); ans0 = INTEGER(ans); for (i = 0; i < len1; i++) { bucket_idx = get_bucket_idx_for_int_quad(&htab, a1_p[i], b1_p[i], c1_p[i], d1_p[i], a2_p, b2_p, c2_p, d2_p); i2 = _get_hbucket_val(&htab, bucket_idx); if (i2 == NA_INTEGER) ans0[i] = nomatch0; else ans0[i] = i2 + 1; } UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- */ SEXP Integer_selfmatch4_hash(SEXP a, SEXP b, SEXP c, SEXP d) { int ans_length, *ans0, i, bucket_idx, i2; const int *a_p, *b_p, *c_p, *d_p; struct htab htab; SEXP ans; ans_length = _check_integer_quads(a, b, c, d, &a_p, &b_p, &c_p, &d_p, "a", "b", "c", "d"); htab = _new_htab(ans_length); PROTECT(ans = NEW_INTEGER(ans_length)); ans0 = INTEGER(ans); for (i = 0; i < ans_length; i++) { bucket_idx = get_bucket_idx_for_int_quad(&htab, a_p[i], b_p[i], c_p[i], d_p[i], a_p, b_p, c_p, d_p); i2 = _get_hbucket_val(&htab, bucket_idx); if (i2 == NA_INTEGER) { _set_hbucket_val(&htab, bucket_idx, i); ans0[i] = i + 1; } else { ans0[i] = i2 + 1; } } UNPROTECT(1); return ans; } /**************************************************************************** * An enhanced version of base::tabulate() that: (1) handles integer weights * (NA and negative weights are OK), and (2) throws an error if 'strict' is * TRUE and if 'x' contains NAs or values not in the [1, 'nbins'] interval. */ SEXP Integer_tabulate2(SEXP x, SEXP nbins, SEXP weight, SEXP strict) { SEXP ans; int x_len, nbins0, weight_len, strict0, *one_based_ans_p, i, j, x_elt, weight_elt; const int *x_p, *weight_p; x_len = LENGTH(x); nbins0 = INTEGER(nbins)[0]; weight_len = LENGTH(weight); weight_p = INTEGER(weight); strict0 = LOGICAL(strict)[0]; j = 0; PROTECT(ans = NEW_INTEGER(nbins0)); memset(INTEGER(ans), 0, nbins0 * sizeof(int)); one_based_ans_p = INTEGER(ans) - 1; // We do unsafe arithmetic, which is 40% faster than safe arithmetic. // For now, the only use case for tabulate2() is fast tabulation of // integer- and factor-Rle's (passing the run values and run lengths // to 'x' and 'weight', respectively), so we are safe (the cumulated // run lengths of an Rle must be < 2^31). //_reset_ovflow_flag(); for (i = j = 0, x_p = INTEGER(x); i < x_len; i++, j++, x_p++) { if (j >= weight_len) j = 0; /* recycle */ x_elt = *x_p; if (x_elt == NA_INTEGER || x_elt < 1 || x_elt > nbins0) { if (!strict0) continue; UNPROTECT(1); error("'x' contains NAs or values not in the " "[1, 'nbins'] interval"); } weight_elt = weight_p[j]; //ans_elt = one_based_ans_p[x_elt]; //one_based_ans_p[x_elt] = _safe_int_add(ans_elt, weight_elt); one_based_ans_p[x_elt] += weight_elt; } //if (_get_ovflow_flag()) // warning("NAs produced by integer overflow"); UNPROTECT(1); return ans; } /**************************************************************************** * Bitwise operations. */ SEXP Integer_explode_bits(SEXP x, SEXP bitpos) { SEXP ans; int ans_nrow, ans_ncol, i, j, *ans_elt, bitmask; const int *x_elt, *bitpos_elt; ans_nrow = LENGTH(x); ans_ncol = LENGTH(bitpos); PROTECT(ans = allocMatrix(INTSXP, ans_nrow, ans_ncol)); ans_elt = INTEGER(ans); for (j = 0, bitpos_elt = INTEGER(bitpos); j < ans_ncol; j++, bitpos_elt++) { if (*bitpos_elt == NA_INTEGER || *bitpos_elt < 1) error("'bitpos' must contain values >= 1"); bitmask = 1 << (*bitpos_elt - 1); for (i = 0, x_elt = INTEGER(x); i < ans_nrow; i++, x_elt++) *(ans_elt++) = (*x_elt & bitmask) != 0; } UNPROTECT(1); return ans; } /**************************************************************************** * --- .Call ENTRY POINT --- * Creates the (sorted) union of two sorted integer vectors */ SEXP Integer_sorted_merge(SEXP x, SEXP y) { int x_i, y_i, x_len, y_len, ans_len; const int *x_ptr, *y_ptr; int *ans_ptr; SEXP ans; x_len = LENGTH(x); y_len = LENGTH(y); x_i = 0; y_i = 0; x_ptr = INTEGER(x); y_ptr = INTEGER(y); ans_len = 0; while (x_i < x_len && y_i < y_len) { if (*x_ptr == *y_ptr) { x_ptr++; x_i++; y_ptr++; y_i++; } else if (*x_ptr < *y_ptr) { x_ptr++; x_i++; } else { y_ptr++; y_i++; } ans_len++; } if (x_i < x_len) { ans_len += x_len - x_i; } else if (y_i < y_len) { ans_len += y_len - y_i; } PROTECT(ans = NEW_INTEGER(ans_len)); x_i = 0; y_i = 0; x_ptr = INTEGER(x); y_ptr = INTEGER(y); ans_ptr = INTEGER(ans); while (x_i < x_len && y_i < y_len) { if (*x_ptr == *y_ptr) { *ans_ptr = *x_ptr; x_ptr++; x_i++; y_ptr++; y_i++; } else if (*x_ptr < *y_ptr) { *ans_ptr = *x_ptr; x_ptr++; x_i++; } else { *ans_ptr = *y_ptr; y_ptr++; y_i++; } ans_ptr++; } if (x_i < x_len) { memcpy(ans_ptr, x_ptr, (x_len - x_i) * sizeof(int)); } else if (y_i < y_len) { memcpy(ans_ptr, y_ptr, (y_len - y_i) * sizeof(int)); } UNPROTECT(1); return ans; } /**************************************************************************** * --- .Call ENTRY POINT --- */ SEXP Integer_mseq(SEXP from, SEXP to) { int i, j, n, ans_length, *from_elt, *to_elt, *ans_elt; SEXP ans; if (!IS_INTEGER(from) || !IS_INTEGER(to)) error("'from' and 'to' must be integer vectors"); n = LENGTH(from); if (n != LENGTH(to)) error("lengths of 'from' and 'to' must be equal"); ans_length = 0; for (i = 0, from_elt = INTEGER(from), to_elt = INTEGER(to); i < n; i++, from_elt++, to_elt++) { ans_length += (*from_elt <= *to_elt ? *to_elt - *from_elt : *from_elt - *to_elt) + 1; } PROTECT(ans = NEW_INTEGER(ans_length)); ans_elt = INTEGER(ans); for (i = 0, from_elt = INTEGER(from), to_elt = INTEGER(to); i < n; i++, from_elt++, to_elt++) { if (*from_elt == NA_INTEGER || *to_elt == NA_INTEGER) error("'from' and 'to' contain NAs"); if (*from_elt <= *to_elt) { for (j = *from_elt; j <= *to_elt; j++) { *ans_elt = j; ans_elt++; } } else { for (j = *from_elt; j >= *to_elt; j--) { *ans_elt = j; ans_elt++; } } } UNPROTECT(1); return ans; } SEXP Integer_fancy_mseq(SEXP lengths, SEXP offset, SEXP rev) { int lengths_length, offset_length, rev_length, ans_length, i, length, *ans_elt, i2, i3, offset_elt, rev_elt, j; const int *lengths_elt; SEXP ans; lengths_length = LENGTH(lengths); offset_length = LENGTH(offset); rev_length = LENGTH(rev); if (lengths_length != 0) { if (offset_length == 0) error("'offset' has length 0 but not 'lengths'"); if (rev_length == 0) error("'rev' has length 0 but not 'lengths'"); } ans_length = 0; for (i = 0, lengths_elt = INTEGER(lengths); i < lengths_length; i++, lengths_elt++) { length = *lengths_elt; if (length == NA_INTEGER) error("'lengths' contains NAs"); if (length < 0) length = -length; ans_length += length; } PROTECT(ans = NEW_INTEGER(ans_length)); ans_elt = INTEGER(ans); for (i = i2 = i3 = 0, lengths_elt = INTEGER(lengths); i < lengths_length; i++, i2++, i3++, lengths_elt++) { if (i2 >= offset_length) i2 = 0; /* recycle */ if (i3 >= rev_length) i3 = 0; /* recycle */ length = *lengths_elt; offset_elt = INTEGER(offset)[i2]; if (length != 0 && offset_elt == NA_INTEGER) { UNPROTECT(1); error("'offset' contains NAs"); } rev_elt = INTEGER(rev)[i3]; if (length >= 0) { if (length >= 2 && rev_elt == NA_LOGICAL) { UNPROTECT(1); error("'rev' contains NAs"); } if (rev_elt) { for (j = length; j >= 1; j--) *(ans_elt++) = j + offset_elt; } else { for (j = 1; j <= length; j++) *(ans_elt++) = j + offset_elt; } } else { if (length <= -2 && rev_elt == NA_LOGICAL) { UNPROTECT(1); error("'rev' contains NAs"); } if (rev_elt) { for (j = length; j <= -1; j++) *(ans_elt++) = j - offset_elt; } else { for (j = -1; j >= length; j--) *(ans_elt++) = j - offset_elt; } } } UNPROTECT(1); return ans; } /**************************************************************************** * findIntervalAndStartFromWidth() * * 'x' and 'width' are integer vectors */ SEXP _find_interv_and_start_from_width(const int *x, int x_len, const int *width, int width_len) { int i, interval, start; const int *x_elt, *width_elt; int *interval_elt, *start_elt, *x_order_elt; SEXP ans, ans_class, ans_names, ans_rownames, ans_interval, ans_start; SEXP x_order; for (i = 0, width_elt = width; i < width_len; i++, width_elt++) { if (*width_elt == NA_INTEGER) error("'width' cannot contain missing values"); else if (*width_elt < 0) error("'width' must contain non-negative values"); } width_elt = width; ans_rownames = R_NilValue; PROTECT(ans_interval = NEW_INTEGER(x_len)); PROTECT(ans_start = NEW_INTEGER(x_len)); if (x_len > 0 && width_len > 0) { start = 1; interval = 1; PROTECT(x_order = NEW_INTEGER(x_len)); _get_order_of_int_array(x, x_len, 0, INTEGER(x_order), 0); for (i = 0, x_order_elt = INTEGER(x_order); i < x_len; i++, x_order_elt++) { x_elt = x + *x_order_elt; interval_elt = INTEGER(ans_interval) + *x_order_elt; start_elt = INTEGER(ans_start) + *x_order_elt; if (*x_elt == NA_INTEGER) error("'x' cannot contain missing values"); else if (*x_elt < 0) error("'x' must contain non-negative values"); if (*x_elt == 0) { *interval_elt = 0; *start_elt = NA_INTEGER; } else { while (interval < width_len && *x_elt >= (start + *width_elt)) { interval++; start += *width_elt; width_elt++; } if (*x_elt > start + *width_elt) error("'x' values larger than vector length 'sum(width)'"); *interval_elt = interval; *start_elt = start; } } UNPROTECT(1); PROTECT(ans_rownames = NEW_INTEGER(2)); INTEGER(ans_rownames)[0] = NA_INTEGER; INTEGER(ans_rownames)[1] = -x_len; } else { PROTECT(ans_rownames = NEW_INTEGER(0)); } PROTECT(ans = NEW_LIST(2)); PROTECT(ans_class = NEW_CHARACTER(1)); PROTECT(ans_names = NEW_CHARACTER(2)); SET_STRING_ELT(ans_class, 0, mkChar("data.frame")); SET_STRING_ELT(ans_names, 0, mkChar("interval")); SET_STRING_ELT(ans_names, 1, mkChar("start")); SET_NAMES(ans, ans_names); SET_VECTOR_ELT(ans, 0, ans_interval); SET_VECTOR_ELT(ans, 1, ans_start); setAttrib(ans, install("row.names"), ans_rownames); SET_CLASS(ans, ans_class); UNPROTECT(6); return ans; } /* --- .Call ENTRY POINT --- */ SEXP findIntervalAndStartFromWidth(SEXP x, SEXP width) { if (!IS_INTEGER(x)) error("'x' must be an integer vector"); if (!IS_INTEGER(width)) error("'width' must be an integer vector"); return _find_interv_and_start_from_width(INTEGER(x), LENGTH(x), INTEGER(width), LENGTH(width)); } S4Vectors/src/logical_utils.c0000644000175100017510000001063612607346177017236 0ustar00biocbuildbiocbuild#include "S4Vectors.h" #include /* for CHAR_BIT */ #include /* for div() */ #define BIT7_MASK (1 << (CHAR_BIT-1)) #define END_OP 0 #define S_H_OP 1 #define N_OP 2 #define BAD_OP 3 #define P_OP 4 #define I_OP 5 #define D_OP 6 #define M_OP 7 static const unsigned char BitsSetTable256[256] = { # define B2(n) n, n+1, n+1, n+2 # define B4(n) B2(n), B2(n+1), B2(n+1), B2(n+2) # define B6(n) B4(n), B4(n+1), B4(n+1), B4(n+2) B6(0), B6(1), B6(1), B6(2) }; /* Turns a logical vector into a "compact bit vector" */ SEXP logical_as_compact_bitvector(SEXP x) { SEXP ans; Rbyte *ans_elt; int x_length, ans_length, i, j, x_elt; div_t q; x_length = LENGTH(x); q = div(x_length, CHAR_BIT); ans_length = q.quot; if (q.rem != 0) ans_length++; PROTECT(ans = NEW_RAW(ans_length)); for (i = j = 0, ans_elt = RAW(ans); i < x_length; i++, j++) { if (j >= CHAR_BIT) { j = 0; ans_elt++; } *ans_elt <<= 1; x_elt = LOGICAL(x)[i]; if (x_elt == NA_INTEGER) { UNPROTECT(1); error("'x' contains NAs"); } if (x_elt) *ans_elt |= 1; } if (q.rem != 0) *ans_elt <<= CHAR_BIT - q.rem; UNPROTECT(1); return ans; } /* Turns a "compact bit vector" into a logical vector */ SEXP compact_bitvector_as_logical(SEXP x, SEXP length_out) { SEXP ans; Rbyte x_elt; int ans_length, x_length, i, j, k; ans_length = INTEGER(length_out)[0]; x_length = LENGTH(x); if (ans_length > x_length * CHAR_BIT) error("'length_out' is > 'length(x)' * %d", CHAR_BIT); PROTECT(ans = NEW_LOGICAL(ans_length)); for (i = j = 0, x_elt = RAW(x)[k = 0]; i < ans_length; i++, j++) { if (j >= CHAR_BIT) { j = 0; x_elt = RAW(x)[++k]; } LOGICAL(ans)[i] = (x_elt & BIT7_MASK) != 0; x_elt <<= 1; } UNPROTECT(1); return ans; } /* Subsets a "compact bit vector" */ SEXP subset_compact_bitvector(SEXP x, SEXP subscript) { SEXP ans; Rbyte *ans_elt; int x_length, subscript_length, ans_length, i, j, sub_i; div_t q, q2; x_length = LENGTH(x); subscript_length = LENGTH(subscript); q = div(subscript_length, CHAR_BIT); ans_length = q.quot; if (q.rem != 0) ans_length++; PROTECT(ans = NEW_RAW(ans_length)); for (i = j = 0, ans_elt = RAW(ans); i < subscript_length; i++, j++) { if (j >= CHAR_BIT) { j = 0; ans_elt++; } *ans_elt <<= 1; sub_i = INTEGER(subscript)[i]; if (sub_i == NA_INTEGER) { UNPROTECT(1); error("subscript contains NAs"); } sub_i--; q2 = div(sub_i, CHAR_BIT); if (sub_i < 0 || q2.quot >= x_length) { UNPROTECT(1); error("subscript out of bounds"); } if (RAW(x)[q2.quot] & (BIT7_MASK >> q2.rem)) *ans_elt |= 1; } if (q.rem != 0) *ans_elt <<= CHAR_BIT - q.rem; UNPROTECT(1); return ans; } SEXP compact_bitvector_bit_count(SEXP x) { SEXP ans; Rbyte *x_elt; int *ans_elt, ans_length, i; ans_length = LENGTH(x); PROTECT(ans = NEW_INTEGER(ans_length)); for (i = 0, x_elt = RAW(x), ans_elt = INTEGER(ans); i < ans_length; i++, x_elt++, ans_elt++) { *ans_elt = BitsSetTable256[*x_elt]; } UNPROTECT(1); return(ans); } SEXP compact_bitvector_last_bit(SEXP x) { SEXP ans; Rbyte LAST_MASK, *x_elt; int *ans_elt, ans_length, i; LAST_MASK = BIT7_MASK >> 7; ans_length = LENGTH(x); PROTECT(ans = NEW_INTEGER(ans_length)); for (i = 0, x_elt = RAW(x), ans_elt = INTEGER(ans); i < ans_length; i++, x_elt++, ans_elt++) { *ans_elt = (*x_elt & LAST_MASK) != 0; } UNPROTECT(1); return(ans); } SEXP compact_bitvector_set_op(SEXP query, SEXP ref, SEXP align) { SEXP ans; Rbyte *ans_elt, query_elt, ref_elt, align_elt; int ans_length, i, j, k, op; ans_length = 8 * LENGTH(query); PROTECT(ans = NEW_RAW(ans_length)); j = k = 0; query_elt = RAW(query)[0]; ref_elt = RAW(ref)[0]; align_elt = RAW(align)[0]; for (i = 0, ans_elt = RAW(ans); i < ans_length; i++, ans_elt++) { if (j >= CHAR_BIT) { j = 0; k++; query_elt = RAW(query)[k]; ref_elt = RAW(ref)[k]; align_elt = RAW(align)[k]; } op = ((query_elt & BIT7_MASK) != 0) + (((ref_elt & BIT7_MASK) != 0) << 1) + (((align_elt & BIT7_MASK) != 0) << 2); switch (op) { case M_OP: *ans_elt = 'M'; break; case I_OP: *ans_elt = 'I'; break; case D_OP: *ans_elt = 'D'; break; case N_OP: *ans_elt = 'N'; break; case S_H_OP: *ans_elt = 'S'; break; case P_OP: *ans_elt = 'P'; break; case END_OP: *ans_elt = '|'; break; case BAD_OP: *ans_elt = '?'; break; } query_elt <<= 1; ref_elt <<= 1; align_elt <<= 1; j++; } UNPROTECT(1); return(ans); } S4Vectors/src/safe_arithm.c0000644000175100017510000000323612607346177016664 0ustar00biocbuildbiocbuild/**************************************************************************** * Safe signed integer arithmetic * * ------------------------------ * * TODO: Extend to support safe double arithmetic when the need arises. * ****************************************************************************/ #include "S4Vectors.h" #include /* for INT_MAX and INT_MIN */ static int ovflow_flag; void _reset_ovflow_flag() { ovflow_flag = 0; return; } int _get_ovflow_flag() { return ovflow_flag; } /* Reference: * The CERT C Secure Coding Standard * Rule INT32-C. Ensure that operations on signed integers do not result * in overflow */ int _safe_int_add(int x, int y) { if (x == NA_INTEGER || y == NA_INTEGER) return NA_INTEGER; if (((y > 0) && (x > (INT_MAX - y))) || ((y < 0) && (x < (INT_MIN - y)))) { ovflow_flag = 1; return NA_INTEGER; } return x + y; } int _safe_int_mult(int x, int y) { if (x == NA_INTEGER || y == NA_INTEGER) return NA_INTEGER; if (x > 0) { /* x is positive */ if (y > 0) { /* x and y are positive */ if (x > (INT_MAX / y)) { ovflow_flag = 1; return NA_INTEGER; } } else { /* x is positive, y is non-positive */ if (y < (INT_MIN / x)) { ovflow_flag = 1; return NA_INTEGER; } } } else { /* x is non-positive */ if (y > 0) { /* x is non-positive, y is positive */ if (x < (INT_MIN / y)) { ovflow_flag = 1; return NA_INTEGER; } } else { /* x and y are non-positive */ if ((x != 0) && (y < (INT_MAX / x))) { ovflow_flag = 1; return NA_INTEGER; } } } return x * y; } S4Vectors/src/sort_utils.c0000644000175100017510000002036712607346177016615 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level sorting utilities * * --------------------------- * * * * All sortings/orderings are based on the qsort() function from the * * standard C lib. * * Note that C qsort() is NOT "stable" so the ordering functions below * * (_get_order_of_*() functions) need to ultimately break ties by position * * (this is done by adding a little extra code at the end of the comparison * * function used in the call to qsort()). * ****************************************************************************/ #include "S4Vectors.h" #include /* for qsort() */ static const int *aa, *bb, *cc, *dd; /**************************************************************************** * Sorting or getting the order of an int array. */ static int compar_ints_for_asc_sort(const void *p1, const void *p2) { return *((const int *) p1) - *((const int *) p2); } static int compar_ints_for_desc_sort(const void *p1, const void *p2) { return compar_ints_for_asc_sort(p2, p1); } void _sort_int_array(int *x, int nelt, int desc) { int (*compar)(const void *, const void *); compar = desc ? compar_ints_for_desc_sort : compar_ints_for_asc_sort; qsort(x, nelt, sizeof(int), compar); return; } static int compar_aa_for_stable_asc_order(const void *p1, const void *p2) { int i1, i2, ret; i1 = *((const int *) p1); i2 = *((const int *) p2); ret = aa[i1] - aa[i2]; if (ret != 0) return ret; /* Break tie by position so the ordering is "stable". */ return i1 - i2; } /* We cannot just define compar_aa_for_stable_desc_order(p1, p2) to be * compar_aa_for_stable_asc_order(p2, p1) because of the tie-break * by position. */ static int compar_aa_for_stable_desc_order(const void *p1, const void *p2) { int i1, i2, ret; i1 = *((const int *) p1); i2 = *((const int *) p2); ret = aa[i2] - aa[i1]; if (ret != 0) return ret; /* Break tie by position so the ordering is "stable". */ return i1 - i2; } void _get_order_of_int_array(const int *x, int nelt, int desc, int *out, int out_shift) { int i, (*compar)(const void *, const void *); aa = x - out_shift; for (i = 0; i < nelt; i++) out[i] = i + out_shift; compar = desc ? compar_aa_for_stable_desc_order : compar_aa_for_stable_asc_order; qsort(out, nelt, sizeof(int), compar); return; } /**************************************************************************** * Getting the order of 2 int arrays of the same length. * The second array ('b') is used to break ties in the first array ('a'). */ static int compar_int_pairs(int a1, int b1, int a2, int b2) { int ret; ret = a1 - a2; if (ret != 0) return ret; ret = b1 - b2; return ret; } /* Vectorized comparison of 2 vectors of integer pairs. */ void _compare_int_pairs(const int *a1, const int *b1, int nelt1, const int *a2, const int *b2, int nelt2, int *out, int out_len, int with_warning) { int i, j, k; for (i = j = k = 0; k < out_len; i++, j++, k++) { if (i >= nelt1) i = 0; /* recycle i */ if (j >= nelt2) j = 0; /* recycle j */ out[k] = compar_int_pairs(a1[i], b1[i], a2[j], b2[j]); } /* This warning message is meaningful only when 'out_len' is 'max(nelt1, nelt2)' and is consistent with the warning we get from binary arithmetic/comparison operations on numeric vectors. */ if (with_warning && out_len != 0 && (i != nelt1 || j != nelt2)) warning("longer object length is not a multiple " "of shorter object length"); return; } int _int_pairs_are_sorted(const int *a, const int *b, int nelt, int desc, int strict) { int a1, b1, a2, b2, i, ret; if (nelt == 0) return 1; a2 = a[0]; b2 = b[0]; for (i = 1; i < nelt; i++) { a1 = a2; b1 = b2; a2 = a[i]; b2 = b[i]; ret = compar_int_pairs(a1, b1, a2, b2); if (ret == 0) { if (strict) return 0; continue; } if (desc != (ret > 0)) return 0; } return 1; } static int compar_aabb(int i1, int i2) { int ret; ret = aa[i1] - aa[i2]; if (ret != 0) return ret; ret = bb[i1] - bb[i2]; return ret; } static int compar_aabb_for_stable_asc_order(const void *p1, const void *p2) { int i1, i2, ret; i1 = *((const int *) p1); i2 = *((const int *) p2); ret = compar_aabb(i1, i2); if (ret != 0) return ret; /* Break tie by position so the ordering is "stable". */ return i1 - i2; } /* We cannot just define compar_aabb_for_stable_desc_order(p1, p2) to be * compar_aabb_for_stable_asc_order(p2, p1) because of the tie-break * by position. */ static int compar_aabb_for_stable_desc_order(const void *p1, const void *p2) { int i1, i2, ret; i1 = *((const int *) p1); i2 = *((const int *) p2); ret = compar_aabb(i2, i1); if (ret != 0) return ret; /* Break tie by position so the ordering is "stable". */ return i1 - i2; } void _get_order_of_int_pairs(const int *a, const int *b, int nelt, int desc, int *out, int out_shift) { int i, (*compar)(const void *, const void *); aa = a - out_shift; bb = b - out_shift; for (i = 0; i < nelt; i++, out_shift++) out[i] = out_shift; compar = desc ? compar_aabb_for_stable_desc_order : compar_aabb_for_stable_asc_order; qsort(out, nelt, sizeof(int), compar); return; } void _get_matches_of_ordered_int_pairs( const int *a1, const int *b1, const int *o1, int nelt1, const int *a2, const int *b2, const int *o2, int nelt2, int nomatch, int *out, int out_shift) { int i1, i2, ret; i2 = 0; ret = 0; for (i1 = 0; i1 < nelt1; i1++, o1++) { while (i2 < nelt2) { ret = compar_int_pairs( a1[*o1], b1[*o1], a2[*o2], b2[*o2]); if (ret <= 0) break; i2++, o2++; } out[*o1] = ret == 0 ? *o2 + out_shift : nomatch; } return; } /**************************************************************************** * Getting the order of 4 int arrays of the same length. * 2nd, 3rd and 4th arrays are used to successively break ties. */ static int compar_int_quads(int a1, int b1, int c1, int d1, int a2, int b2, int c2, int d2) { int ret; ret = compar_int_pairs(a1, b1, a2, b2); if (ret != 0) return ret; ret = c1 - c2; if (ret != 0) return ret; ret = d1 - d2; return ret; } static int compar_aabbccdd(int i1, int i2) { int ret; ret = compar_aabb(i1, i2); if (ret != 0) return ret; ret = cc[i1] - cc[i2]; if (ret != 0) return ret; ret = dd[i1] - dd[i2]; return ret; } static int compar_aabbccdd_for_stable_asc_order(const void *p1, const void *p2) { int i1, i2, ret; i1 = *((const int *) p1); i2 = *((const int *) p2); ret = compar_aabbccdd(i1, i2); if (ret != 0) return ret; /* Break tie by position so the ordering is "stable". */ return i1 - i2; } /* We cannot just define compar_aabbccdd_for_stable_desc_order(p1, p2) to be * compar_aabbccdd_for_stable_asc_order(p2, p1) because of the tie-break * by position. */ static int compar_aabbccdd_for_stable_desc_order(const void *p1, const void *p2) { int i1, i2, ret; i1 = *((const int *) p1); i2 = *((const int *) p2); ret = compar_aabbccdd(i2, i1); if (ret != 0) return ret; /* Break tie by position so the ordering is "stable". */ return i1 - i2; } void _get_order_of_int_quads(const int *a, const int *b, const int *c, const int *d, int nelt, int desc, int *out, int out_shift) { int i, (*compar)(const void *, const void *); aa = a - out_shift; bb = b - out_shift; cc = c - out_shift; dd = d - out_shift; for (i = 0; i < nelt; i++, out_shift++) out[i] = out_shift; compar = desc ? compar_aabbccdd_for_stable_desc_order : compar_aabbccdd_for_stable_asc_order; qsort(out, nelt, sizeof(int), compar); return; } void _get_matches_of_ordered_int_quads( const int *a1, const int *b1, const int *c1, const int *d1, const int *o1, int nelt1, const int *a2, const int *b2, const int *c2, const int *d2, const int *o2, int nelt2, int nomatch, int *out, int out_shift) { int i1, i2, ret; i2 = 0; ret = 0; for (i1 = 0; i1 < nelt1; i1++, o1++) { while (i2 < nelt2) { ret = compar_int_quads( a1[*o1], b1[*o1], c1[*o1], d1[*o1], a2[*o2], b2[*o2], c2[*o2], d2[*o2]); if (ret <= 0) break; i2++, o2++; } out[*o1] = ret == 0 ? *o2 + out_shift : nomatch; } return; } S4Vectors/src/str_utils.c0000644000175100017510000001727512607346177016442 0ustar00biocbuildbiocbuild/* * Defining the _XOPEN_SOURCE feature test macro is required in order to obtain * declaration of tzset() and 'timezone' from (see man tzset). * However, it seems that Solaris wants it to have a value (as reported by * Brian D. Ripley to maintainer@bioconductor.org on 2015-29-08). */ #define _XOPEN_SOURCE 600 #include "S4Vectors.h" #include /* for UINT_MAX and UINT_MIN */ #include /* for isblank() and isdigit() */ #include /* for free() */ #include static char errmsg_buf[200]; /**************************************************************************** * unstrsplit_list() */ /* * Assumes 'x' is a character vector (this is NOT checked). * The destination string 'dest' must be large enough to receive the result. */ static void join_strings_in_buf(char *dest, SEXP x, const char *sep, int sep_len) { int x_len, i; SEXP x_elt; x_len = LENGTH(x); for (i = 0; i < x_len; i++) { if (i != 0) { memcpy(dest, sep, sep_len); dest += sep_len; } x_elt = STRING_ELT(x, i); memcpy(dest, CHAR(x_elt), LENGTH(x_elt)); dest += LENGTH(x_elt); } return; } /* * Returns a CHARSXP if success, or R_NilValue if failure. */ static SEXP join_strings(SEXP x, const char *sep, int sep_len) { SEXP ans; int x_len, bufsize, i; char *buf; if (!IS_CHARACTER(x)) { snprintf(errmsg_buf, sizeof(errmsg_buf), "join_strings() expects a character vector"); return R_NilValue; } x_len = LENGTH(x); /* 1st pass: Loop over 'x' to compute the size of the buffer. */ bufsize = 0; if (x_len != 0) { for (i = 0; i < x_len; i++) bufsize += LENGTH(STRING_ELT(x, i)); bufsize += (x_len - 1) * sep_len; } /* Allocate memory for the buffer. */ buf = (char *) malloc((size_t) bufsize); if (buf == NULL) { snprintf(errmsg_buf, sizeof(errmsg_buf), "malloc() failed"); return R_NilValue; } /* 2nd pass: Loop over 'x' again to fill 'buf'. */ join_strings_in_buf(buf, x, sep, sep_len); /* Turn 'buf' into a CHARSXP and return it. */ PROTECT(ans = mkCharLen(buf, bufsize)); free(buf); UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- */ SEXP unstrsplit_list(SEXP x, SEXP sep) { SEXP ans, sep0, x_elt, ans_elt, ans_names; int x_len, sep0_len, i; if (!IS_LIST(x)) error("'x' must be a list"); if (!(IS_CHARACTER(sep) && LENGTH(sep) == 1)) error("'sep' must be a single string"); x_len = LENGTH(x); sep0 = STRING_ELT(sep, 0); sep0_len = LENGTH(sep0); PROTECT(ans = NEW_CHARACTER(x_len)); for (i = 0; i < x_len; i++) { x_elt = VECTOR_ELT(x, i); if (x_elt == R_NilValue) continue; PROTECT(ans_elt = join_strings(x_elt, CHAR(sep0), sep0_len)); if (ans_elt == R_NilValue) { UNPROTECT(2); error("in list element %d: %s", i + 1, errmsg_buf); } SET_STRING_ELT(ans, i, ans_elt); UNPROTECT(1); } PROTECT(ans_names = duplicate(GET_NAMES(x))); SET_NAMES(ans, ans_names); UNPROTECT(2); return ans; } /**************************************************************************** * --- .Call ENTRY POINT --- * We cannot rely on the strsplit() R function to split a string into single * characters when the string contains junk. For example: * > r <- as.raw(c(10, 255)) * > s <- rawToChar(r) * > s * [1] "\n\xff" * > strsplit(s, NULL, fixed=TRUE)[[1]] * [1] NA * doesn't work! * The function below should be safe, whatever the content of 's' is! * The length of the returned string is the number of chars in single * string 's'. Not vectorized. */ SEXP safe_strexplode(SEXP s) { SEXP s0, ans; int s0_length, i; char buf[2] = "X"; /* we only care about having buf[1] == 0 */ s0 = STRING_ELT(s, 0); s0_length = LENGTH(s0); PROTECT(ans = NEW_CHARACTER(s0_length)); for (i = 0; i < s0_length; i++) { buf[0] = CHAR(s0)[i]; SET_STRING_ELT(ans, i, mkChar(buf)); } UNPROTECT(1); return ans; } /**************************************************************************** * strsplit_as_list_of_ints() */ static SEXP explode_string_as_integer_vector(SEXP s, char sep0, IntAE *tmp_buf) { const char *str; int offset, n, ret; long int val; str = CHAR(s); offset = _IntAE_set_nelt(tmp_buf, 0); while (str[offset]) { ret = sscanf(str + offset, "%ld%n", &val, &n); if (ret != 1) { snprintf(errmsg_buf, sizeof(errmsg_buf), "decimal integer expected at char %d", offset + 1); return R_NilValue; } offset += n; while (isblank(str[offset])) offset++; if (val < INT_MIN || val > INT_MAX) { UNPROTECT(1); snprintf(errmsg_buf, sizeof(errmsg_buf), "out of range integer at char %d", offset + 1); return R_NilValue; } _IntAE_insert_at(tmp_buf, _IntAE_get_nelt(tmp_buf), (int) val); if (str[offset] == '\0') break; if (str[offset] != sep0) { snprintf(errmsg_buf, sizeof(errmsg_buf), "separator expected at char %d", offset + 1); return R_NilValue; } offset++; } return _new_INTEGER_from_IntAE(tmp_buf); } /* --- .Call ENTRY POINT --- */ SEXP strsplit_as_list_of_ints(SEXP x, SEXP sep) { SEXP ans, x_elt, ans_elt; int ans_length, i; char sep0; IntAE *tmp_buf; ans_length = LENGTH(x); sep0 = CHAR(STRING_ELT(sep, 0))[0]; if (isdigit(sep0) || sep0 == '+' || sep0 == '-') error("'sep' cannot be a digit, \"+\" or \"-\""); tmp_buf = _new_IntAE(0, 0, 0); PROTECT(ans = NEW_LIST(ans_length)); for (i = 0; i < ans_length; i++) { x_elt = STRING_ELT(x, i); if (x_elt == NA_STRING) { UNPROTECT(1); error("'x' contains NAs"); } PROTECT(ans_elt = explode_string_as_integer_vector(x_elt, sep0, tmp_buf)); if (ans_elt == R_NilValue) { UNPROTECT(2); error("in list element %d: %s", i + 1, errmsg_buf); } SET_VECTOR_ELT(ans, i, ans_elt); UNPROTECT(1); } UNPROTECT(1); return ans; } /**************************************************************************** * svn_time() returns the time in Subversion format, e.g.: * "2007-12-07 10:03:15 -0800 (Fri, 07 Dec 2007)" * The -0800 part will be adjusted if daylight saving time is in effect. * * TODO: Find a better home for this function. */ /* * 'out_size' should be at least 45 (for year < 10000, 44 chars will be * printed to it + '\0'). */ static int get_svn_time(time_t t, char *out, size_t out_size) { //#if defined(__INTEL_COMPILER) // return -1; //#else /* defined(__INTEL_COMPILER) */ struct tm result; int utc_offset, n; static const char *wday2str[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}, *mon2str[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}, *svn_format = "%d-%02d-%02d %02d:%02d:%02d %+03d00 (%s, %02d %s %d)"; //localtime_r() not available on Windows+MinGW //localtime_r(&t, &result); result = *localtime(&t); #if defined(__APPLE__) || defined(__FreeBSD__) //'struct tm' has no member named 'tm_gmtoff' on Windows+MinGW utc_offset = result.tm_gmtoff / 3600; #else /* defined(__APPLE__) || defined(__FreeBSD__) */ tzset(); //timezone is not portable (is a function, not a long, on OS X Tiger) utc_offset = - (timezone / 3600); if (result.tm_isdst > 0) utc_offset++; #endif /* defined(__APPLE__) || defined(__FreeBSD__) */ n = snprintf(out, out_size, svn_format, result.tm_year + 1900, result.tm_mon + 1, result.tm_mday, result.tm_hour, result.tm_min, result.tm_sec, utc_offset, wday2str[result.tm_wday], result.tm_mday, mon2str[result.tm_mon], result.tm_year + 1900); return n >= out_size ? -1 : 0; //#endif /* defined(__INTEL_COMPILER) */ } /* --- .Call ENTRY POINT --- */ SEXP svn_time() { time_t t; char buf[45]; t = time(NULL); if (t == (time_t) -1) error("S4Vectors internal error in svn_time(): " "time(NULL) failed"); if (get_svn_time(t, buf, sizeof(buf)) != 0) error("S4Vectors internal error in svn_time(): " "get_svn_time() failed"); return mkString(buf); } S4Vectors/src/subsetting_internals.c0000644000175100017510000000271712607346177020653 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level internal subsetting utilities * ****************************************************************************/ #include "S4Vectors.h" /* * --- .Call ENTRY POINT --- * Args: * x: An atomic vector or a list. * start, end: Single integer values defining a valid window on 'x'. */ SEXP vector_extract_window(SEXP x, SEXP start, SEXP end) { int x_len, nranges, start0, end0, offset, ans_len; const int *start_p, *end_p; SEXP ans, x_names, ans_names; x_len = LENGTH(x); nranges = _check_integer_pairs(start, end, &start_p, &end_p, "start", "end"); if (nranges != 1) error("'start' and 'end' must be of length 1"); start0 = start_p[0]; end0 = end_p[0]; if (start0 == NA_INTEGER || start0 < 1 || start0 > x_len + 1) error("'start' must be >= 1 and <= 'length(x)' + 1"); if (end0 == NA_INTEGER || end0 < 0 || end0 > x_len) error("'end' must be >= 0 and <= 'length(x)'"); offset = start0 - 1; if (end0 < offset) error("'end' must be >= 'start' - 1"); ans_len = end0 - offset; PROTECT(ans = allocVector(TYPEOF(x), ans_len)); _vector_memcpy(ans, 0, x, offset, ans_len); x_names = GET_NAMES(x); if (x_names != R_NilValue) { PROTECT(ans_names = NEW_CHARACTER(ans_len)); _vector_memcpy(ans_names, 0, x_names, offset, ans_len); SET_NAMES(ans, ans_names); UNPROTECT(1); } UNPROTECT(1); return ans; } S4Vectors/src/vector_utils.c0000644000175100017510000002251212607346177017122 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of ordinary R vectors * ****************************************************************************/ #include "S4Vectors.h" /* * memcmp()-based comparison of 2 vectors of the same type. * NOTE: Doesn't support STRSXP and VECSXP. */ int _vector_memcmp(SEXP x1, int x1_offset, SEXP x2, int x2_offset, int nelt) { const void *s1 = NULL, *s2 = NULL; /* gcc -Wall */ size_t eltsize = 0; /* gcc -Wall */ if (x1_offset < 0 || x1_offset + nelt > LENGTH(x1) || x2_offset < 0 || x2_offset + nelt > LENGTH(x2)) error("S4Vectors internal error in _vector_memcmp(): " "elements to compare are out of vector bounds"); switch (TYPEOF(x1)) { case RAWSXP: s1 = (const void *) (RAW(x1) + x1_offset); s2 = (const void *) (RAW(x2) + x2_offset); eltsize = sizeof(Rbyte); break; case LGLSXP: case INTSXP: s1 = (const void *) (INTEGER(x1) + x1_offset); s2 = (const void *) (INTEGER(x2) + x2_offset); eltsize = sizeof(int); break; case REALSXP: s1 = (const void *) (REAL(x1) + x1_offset); s2 = (const void *) (REAL(x2) + x2_offset); eltsize = sizeof(double); break; case CPLXSXP: s1 = (const void *) (COMPLEX(x1) + x1_offset); s2 = (const void *) (COMPLEX(x2) + x2_offset); eltsize = sizeof(Rcomplex); break; default: error("S4Vectors internal error in _vector_memcmp(): " "%s type not supported", CHAR(type2str(TYPEOF(x1)))); } return s1 == s2 ? 0 : memcmp(s1, s2, nelt * eltsize); } /* * memcpy()-based copy of data from a vector to a vector of the same type. */ void _vector_memcpy(SEXP out, int out_offset, SEXP in, int in_offset, int nelt) { void *dest; const void *src; size_t eltsize; int i; SEXP in_elt; // out_elt; if (out_offset < 0 || out_offset + nelt > LENGTH(out) || in_offset < 0 || in_offset + nelt > LENGTH(in)) error("subscripts out of bounds"); switch (TYPEOF(out)) { case RAWSXP: dest = (void *) (RAW(out) + out_offset); src = (const void *) (RAW(in) + in_offset); eltsize = sizeof(Rbyte); break; case LGLSXP: dest = (void *) (LOGICAL(out) + out_offset); src = (const void *) (LOGICAL(in) + in_offset); eltsize = sizeof(int); break; case INTSXP: dest = (void *) (INTEGER(out) + out_offset); src = (const void *) (INTEGER(in) + in_offset); eltsize = sizeof(int); break; case REALSXP: dest = (void *) (REAL(out) + out_offset); src = (const void *) (REAL(in) + in_offset); eltsize = sizeof(double); break; case CPLXSXP: dest = (void *) (COMPLEX(out) + out_offset); src = (const void *) (COMPLEX(in) + in_offset); eltsize = sizeof(Rcomplex); break; case STRSXP: for (i = 0; i < nelt; i++) { in_elt = STRING_ELT(in, in_offset + i); SET_STRING_ELT(out, out_offset + i, in_elt); //PROTECT(out_elt = duplicate(in_elt)); //SET_STRING_ELT(out, out_offset + i, out_elt); //UNPROTECT(1); } return; case VECSXP: for (i = 0; i < nelt; i++) { in_elt = VECTOR_ELT(in, in_offset + i); SET_VECTOR_ELT(out, out_offset + i, in_elt); //PROTECT(out_elt = duplicate(in_elt)); //SET_VECTOR_ELT(out, out_offset + i, out_elt); //UNPROTECT(1); } return; default: error("S4Vectors internal error in _vector_memcpy(): " "%s type not supported", CHAR(type2str(TYPEOF(out)))); return; // gcc -Wall } memcpy(dest, src, nelt * eltsize); return; } static int get_NROW(SEXP x) { SEXP x_dim, x_rownames; if (x == R_NilValue) return 0; if (!IS_VECTOR(x)) error("get_NROW() defined only on a vector (or NULL)"); /* A data.frame doesn't have a "dim" attribute but the dimensions can be inferred from the "names" and "row.names" attributes. */ x_rownames = getAttrib(x, R_RowNamesSymbol); if (x_rownames != R_NilValue) return LENGTH(x_rownames); x_dim = GET_DIM(x); if (x_dim == R_NilValue || LENGTH(x_dim) == 0) return LENGTH(x); return INTEGER(x_dim)[0]; } /* * --- .Call ENTRY POINT --- * A C implementation of 'sapply(x, NROW)' that works only on a list of * vectors (or NULLs). */ SEXP sapply_NROW(SEXP x) { SEXP ans, x_elt; int x_len, i, *ans_elt; x_len = LENGTH(x); PROTECT(ans = NEW_INTEGER(x_len)); for (i = 0, ans_elt = INTEGER(ans); i < x_len; i++, ans_elt++) { x_elt = VECTOR_ELT(x, i); if (x_elt != R_NilValue && !IS_VECTOR(x_elt)) { UNPROTECT(1); error("element %d not a vector (or NULL)", i + 1); } *ans_elt = get_NROW(x_elt); } UNPROTECT(1); return ans; } /**************************************************************************** * vector_subsetByRanges() and vector_seqselect() * * TODO: These 2 functions are redundant. We only need one: the fastest. */ static void vector_copy_ranges(SEXP out, SEXP in, const int *start, const int *width, int nranges) { int i, out_offset, in_offset, nelt; out_offset = 0; for (i = 0; i < nranges; i++) { in_offset = start[i] - 1; nelt = width[i]; if (nelt < 0) error("negative widths are not allowed"); _vector_memcpy(out, out_offset, in, in_offset, nelt); out_offset += nelt; } return; } /* --- .Call ENTRY POINT --- * 'start' and 'width': integer vectors of the same length with no NAs. 'width' * is assumed to be >= 0. */ SEXP vector_subsetByRanges(SEXP x, SEXP start, SEXP width) { int x_len, nranges, ans_len, i, offset_i, width_i, end_i; const int *start_p, *width_p; SEXP ans, x_names, ans_names; x_len = LENGTH(x); nranges = _check_integer_pairs(start, width, &start_p, &width_p, "start", "width"); ans_len = 0; _reset_ovflow_flag(); for (i = 0; i < nranges; i++) { width_i = width_p[i]; if (width_i == NA_INTEGER || width_i < 0) error("'width' cannot contain NAs or negative values"); offset_i = start_p[i] - 1; end_i = offset_i + width_i; if (offset_i < 0 || end_i > x_len) error("some ranges are out of bounds"); ans_len = _safe_int_add(ans_len, width_i); } if (_get_ovflow_flag()) error("Subsetting %s object by subscript containing " "ranges produces a result\n of length > %d. " "This is not supported yet.", CHAR(type2str(TYPEOF(x))), INT_MAX); PROTECT(ans = allocVector(TYPEOF(x), ans_len)); vector_copy_ranges(ans, x, start_p, width_p, nranges); x_names = GET_NAMES(x); if (x_names != R_NilValue) { PROTECT(ans_names = NEW_CHARACTER(ans_len)); vector_copy_ranges(ans_names, x_names, start_p, width_p, nranges); SET_NAMES(ans, ans_names); UNPROTECT(1); } UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- * TODO: Remove this at some point (use vector_subsetByRanges instead). */ SEXP vector_seqselect(SEXP x, SEXP start, SEXP width) { int ans_offset, i, j, s, w; SEXP ans, ans_names; if (!IS_INTEGER(start)) error("'start' must be an integer vector"); if (!IS_INTEGER(width)) error("'width' must be an integer vector"); if (LENGTH(start) != LENGTH(width)) error("length of 'start' must equal length of 'width'"); ans_offset = 0; _reset_ovflow_flag(); for (i = 0; i < LENGTH(start); i++) { s = INTEGER(start)[i]; w = INTEGER(width)[i]; if (s == NA_INTEGER || s < 1) error("each element in 'start' must be a positive integer"); if (w == NA_INTEGER || w < 0) error("each element in 'width' must be a non-negative integer"); if (LENGTH(x) < s + w - 1) error("some ranges are out of bounds"); ans_offset = _safe_int_add(ans_offset, w); } if (_get_ovflow_flag()) error("Subsetting %s object by subscript containing " "ranges produces a result\n of length > %d. " "This is not supported yet.", CHAR(type2str(TYPEOF(x))), INT_MAX); PROTECT(ans = allocVector(TYPEOF(x), ans_offset)); for (i = ans_offset = 0; i < LENGTH(start); i++, ans_offset += w) { s = INTEGER(start)[i] - 1; w = INTEGER(width)[i]; switch (TYPEOF(x)) { case LGLSXP: case INTSXP: memcpy(INTEGER(ans) + ans_offset, INTEGER(x) + s, w * sizeof(int)); break; case REALSXP: memcpy(REAL(ans) + ans_offset, REAL(x) + s, w * sizeof(double)); break; case CPLXSXP: memcpy(COMPLEX(ans) + ans_offset, COMPLEX(x) + s, w * sizeof(Rcomplex)); break; case STRSXP: for (j = 0; j < w; j++) SET_STRING_ELT(ans, ans_offset + j, STRING_ELT(x, s + j)); break; case VECSXP: for (j = 0; j < w; j++) SET_VECTOR_ELT(ans, ans_offset + j, VECTOR_ELT(x, s + j)); break; case RAWSXP: memcpy(RAW(ans) + ans_offset, RAW(x) + s, w * sizeof(char)); break; default: error("S4Vectors internal error in vector_seqselect(): " "%s type not supported", CHAR(type2str(TYPEOF(x)))); } } ans_names = GET_NAMES(x); if (ans_names != R_NilValue) SET_NAMES(ans, vector_seqselect(ans_names, start, width)); UNPROTECT(1); return ans; } /**************************************************************************** * _list_as_data_frame() */ /* Performs IN-PLACE coercion of list 'x' into a data frame! */ SEXP _list_as_data_frame(SEXP x, int nrow) { SEXP rownames, class; int i; if (!IS_LIST(x) || GET_NAMES(x) == R_NilValue) error("S4Vectors internal error in _list_as_data_frame(): " "'x' must be a named list"); /* Set the "row.names" attribute. */ PROTECT(rownames = NEW_INTEGER(nrow)); for (i = 0; i < nrow; i++) INTEGER(rownames)[i] = i + 1; SET_ATTR(x, R_RowNamesSymbol, rownames); UNPROTECT(1); /* Set the "class" attribute. */ PROTECT(class = mkString("data.frame")); SET_CLASS(x, class); UNPROTECT(1); return x; } S4Vectors/tests/0000755000175100017510000000000012607264536014603 5ustar00biocbuildbiocbuildS4Vectors/tests/S4Vectors_unit_tests.R0000644000175100017510000000012512607264536021041 0ustar00biocbuildbiocbuildrequire("S4Vectors") || stop("unable to load S4Vectors package") S4Vectors:::.test() S4Vectors/vignettes/0000755000175100017510000000000012607346177015453 5ustar00biocbuildbiocbuildS4Vectors/vignettes/RleTricks.Rnw0000644000175100017510000000365012607264536020047 0ustar00biocbuildbiocbuild\documentclass{article} % \VignetteIndexEntry{Rle Tips and Tricks} % \VignetteDepends{} % \VignetteKeywords{Rle} % \VignettePackage{S4Vectors} \usepackage{times} \usepackage{hyperref} \textwidth=6.5in \textheight=8.5in % \parskip=.3cm \oddsidemargin=-.1in \evensidemargin=-.1in \headheight=-.3in \newcommand{\Rfunction}[1]{{\texttt{#1}}} \newcommand{\Robject}[1]{{\texttt{#1}}} \newcommand{\Rpackage}[1]{{\textit{#1}}} \newcommand{\Rmethod}[1]{{\texttt{#1}}} \newcommand{\Rfunarg}[1]{{\texttt{#1}}} \newcommand{\Rclass}[1]{{\textit{#1}}} \newcommand{\Rcode}[1]{{\texttt{#1}}} \newcommand{\software}[1]{\textsf{#1}} \newcommand{\R}{\software{R}} \title{Rle Tips and Tricks} \author{Patrick Aboyoun} \date{\today} \begin{document} \maketitle <>= options(width=60) @ <>= rollmeanRle <- function (x, k) { n <- length(x) cumsum(c(Rle(sum(window(x, 1, k))), window(x, k + 1, n) - window(x, 1, n - k))) / k } @ <>= rollvarRle <- function(x, k) { n <- length(x) means <- rollmeanRle(x, k) nextMean <- window(means, 2, n - k + 1) cumsum(c(Rle(sum((window(x, 1, k) - means[1])^2)), k * diff(means)^2 - (window(x, 1, n - k) - nextMean)^2 + (window(x, k + 1, n) - nextMean)^2)) / (k - 1) } @ <>= rollcovRle <- function(x, y, k) { n <- length(x) meanX <- rollmeanRle(x, k) meanY <- rollmeanRle(y, k) nextMeanX <- window(meanX, 2, n - k + 1) nextMeanY <- window(meanY, 2, n - k + 1) cumsum(c(Rle(sum((window(x, 1, k) - meanX[1]) * (window(y, 1, k) - meanY[1]))), k * diff(meanX) * diff(meanY) - (window(x, 1, n - k) - nextMeanX) * (window(y, 1, n - k) - nextMeanY) + (window(x, k + 1, n) - nextMeanX) * (window(y, k + 1, n) - nextMeanY))) / (k - 1) } @ <>= rollsdRle <- function(x, k) { sqrt(rollvarRle(x, k)) } @ <>= rollcorRle <- function(x, y, k) { rollcovRle(x, y, k) / (rollsdRle(x, k) * rollsdRle(y, k)) } @ \end{document}