XVector/DESCRIPTION0000644000126300012640000000204212227150112015224 0ustar00biocbuildphs_compbioPackage: XVector Title: Representation and manpulation of external sequences Description: Memory efficient S4 classes for storing sequences "externally" (behind an R external pointer, or on disk). Version: 0.2.0 Author: H. Pages and P. Aboyoun Maintainer: H. Pages biocViews: Infrastructure, DataRepresentation Depends: R (>= 2.8.0), methods, BiocGenerics (>= 0.7.2), IRanges (>= 1.19.36) Imports: methods, BiocGenerics, IRanges LinkingTo: IRanges Suggests: Biostrings, drosophila2probe, RUnit License: Artistic-2.0 Collate: SharedVector-class.R SharedRaw-class.R SharedInteger-class.R SharedDouble-class.R XVector-class.R XRaw-class.R XInteger-class.R XDouble-class.R XVectorList-class.R XRawList-class.R XRawList-comparison.R XIntegerViews-class.R XDoubleViews-class.R OnDiskRaw-class.R intra-range-methods.R compact-methods.R reverse-methods.R slice-methods.R view-summarization-methods.R updateObject-methods.R debug.R zzz.R Packaged: 2013-10-15 05:19:06 UTC; biocbuild XVector/NAMESPACE0000644000126300012640000000427712227065010014753 0ustar00biocbuildphs_compbiouseDynLib(XVector) import(methods) import(BiocGenerics) import(IRanges) exportClasses( SharedVector, SharedVector_Pool, SharedRaw, SharedRaw_Pool, SharedInteger, SharedDouble, XVector, XRaw, XInteger, XDouble, GroupedIRanges, XVectorList, XRawList, XIntegerViews ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S3 methods ### S3method(duplicated, XRawList) ### 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( duplicated.XRawList ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S4 methods for generics not defined in XVector ### exportMethods( length, names, "names<-", "[", "[<-", "[[", "[[<-", elementLengths, as.vector, as.integer, as.numeric, as.raw, as.data.frame, toString, coerce, c, show, showAsCell, width, compare, "==", "!=", "<=", duplicated, match, order, rank, is.unsorted, rev, reverse, endoapply, Views, slice, viewMins, viewMaxs, viewSums, viewMeans, viewWhichMins, viewWhichMaxs, updateObject ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export non-generic functions ### export( SharedVector.compare, SharedVector.copy, SharedRaw, SharedRaw.readInts, SharedRaw.writeInts, SharedRaw.read, SharedRaw.write, SharedRaw.readComplexes, #SharedInteger, SharedInteger.read, SharedInteger.write, #SharedDouble, SharedDouble.read, SharedDouble.write, XRaw, XInteger, XDouble, XNumeric, XVectorList, unlist_list_of_XVectorList, unsplit_list_of_XVectorList ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S4 generics defined in XVector + export corresponding methods ### export( ## XVector-class.R: subseq, "subseq<-", ## compact-methods.R: xvcopy, compact, ## reverse-methods.R: reverse ) ### Exactly the same list as above. exportMethods( subseq, "subseq<-", xvcopy, compact, reverse ) XVector/R/0000755000126300012640000000000012227065007013731 5ustar00biocbuildphs_compbioXVector/R/OnDiskRaw-class.R0000644000126300012640000004403512227065007017026 0ustar00biocbuildphs_compbio### ========================================================================= ### OnDiskRaw objects ### ------------------------------------------------------------------------- setClass("OnDiskRaw", representation("VIRTUAL", filepath="character", # a single string length="integer", # a single non-negative integer .cache="environment", .objname_in_cache="character" # a single string ), prototype( .objname_in_cache="anonymous" ) ) ### OnDiskRaw API: ### - length() ### - loadSequence() ### - readXRaw() setMethod("length", "OnDiskRaw", function(x) x@length) ### Load a sequence of values from an on-disk raw vector, and return them in ### a raw vector. Every OnDiskRaw concrete subclass needs to implement a ### "loadSequence" method. setGeneric("loadSequence", signature="x", function(x, offset=0, length=NA) standardGeneric("loadSequence") #function(x, offset=0, length=NA, cyclic) standardGeneric("loadSequence") ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Check/normalize 'offset' and 'length' args against the length of an ### object. ### normargOffset <- function(offset, obj_length) { if (!isSingleNumber(offset)) stop("'offset' must be a single integer") if (!is.integer(offset)) offset <- as.integer(offset) if (offset < 0L) stop("'offset' cannot be negative") if (offset > obj_length) stop("'offset' cannot be greater than object length") offset } normargLength <- function(length, obj_length, offset) { if (!isSingleNumberOrNA(length)) stop("'length' must be a single integer or NA") if (!is.integer(length)) length <- as.integer(length) if (is.na(length)) { length <- obj_length - offset } else { if (length < 0L) stop("'length' cannot be negative") if (offset + length > obj_length) stop("invalid 'offset' / 'length' combination: would result in ", "reading data\n beyond the object") } length } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### readXRaw() ### ### Reads raw data from an OnDiskRaw object and returns it as an XRaw (or ### derived) object. Provides a cache mechanism if the full on-disk object ### is requested. Based on loadSequence(). ### ### Increment NLINKS counter in 'cache' environment. .inc_NLINKS <- function(cache) { NLINKS <- try(get("NLINKS", envir=cache, inherits=FALSE), silent=TRUE) if (is(NLINKS, "try-error")) NLINKS <- 0L NLINKS <- NLINKS + 1L assign("NLINKS", NLINKS, envir=cache) } ### Decrement NLINKS counter in 'cache' environment. .dec_NLINKS <- function(cache) { NLINKS <- get("NLINKS", envir=cache, inherits=FALSE) - 1L assign("NLINKS", NLINKS, envir=cache) } ### Return a new link to a cached object. ### 'objname' is the name of the cached object. ### 'cache' is the caching environment. ### When the number of links for a given cached object reaches 0, then the ### object is removed from the cache. .makeLinkToCachedObject <- function(objname, cache) { .inc_NLINKS(cache) ans <- new.env(parent=emptyenv()) reg.finalizer(ans, function(e) { if (.dec_NLINKS(cache) == 0L) { if (getOption("verbose")) cat("uncaching ", objname, "\n", sep="") remove(list=objname, envir=cache) } } ) ans } ### 'Class' must be "XRaw" or the name of an XRaw concrete subclass. ### Returns an instance of class 'Class'. readXRaw <- function(Class, ondiskraw, offset=0, length=NA) { if (!is(ondiskraw, "OnDiskRaw")) stop("'ondiskraw' must be an OnDiskRaw object") ## Check 'offset'. offset <- normargOffset(offset, length(ondiskraw)) ## Check 'length'. length <- normargLength(length, length(ondiskraw), offset) cache <- ondiskraw@.cache objname <- ondiskraw@.objname_in_cache ## The 'if (exists(objname, envir=cache)) get(objname, envir=cache)' ## idiom is NOT reliable and should be avoided. ## Because the symbol (objname) can disappear from the cache between ## the moment we test for its presence and the moment we try to get it. ## It's not paranoia: I've actually seen this happen! One possible ## explanation for this is that the symbol was candidate for removal ## from the cache but that removal didn't happen yet because gc() had ## not yet been called (removal from the cache is implemented thru the ## finalizers registered on the objects that are copied from the cache ## and made available to the user). Then the call to get() would trigger ## garbbage collection and that in turn would trigger the removal of ## the symbol *before* get() had a chance to get to it. So it's better to ## use 'try(get(...))': it's atomic, and should be 100% reliable! ans_shared <- try(get(objname, envir=cache, inherits=FALSE), silent=TRUE) if (is(ans_shared, "try-error")) { val <- loadSequence(ondiskraw, offset=offset, length=length) ans_shared <- SharedRaw(length, val) if (offset != 0L || length != length(ondiskraw)) { ans <- new(Class, shared=ans_shared, offset=0L, length=length) return(ans) } if (getOption("verbose")) cat("caching ", objname, "\n", sep="") assign(objname, ans_shared, envir=cache) } ans_shared@.link_to_cached_object <- .makeLinkToCachedObject(objname, cache) new(Class, shared=ans_shared, offset=offset, length=length) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### .loadSequence() ### ### Load a sequence of values from a file containing a linear array of ### fixed-size atomic values (logical, integer, double, complex, or raw). ### ### Support the same modes as readBin(), except "character" which doesn't ### have fixed-size values. .sizeOnDisk <- function(what) { switch(what, logical=, integer=, int=4L, numeric=, double=8L, complex=16L, raw=1L, stop(what, ": unsupported mode")) } ### An alternative to direct use of seek() for skipping bytes in connection, ### even when the connection doesn't support seek(). .skipBytes <- function(con, n) { if (!isSingleNumber(n) || n < 0) stop("'n' must be a single non-negative number") ## Using seek() should be straightforward and fast. Nothing can beat ## that. Unfortunately, base::seek() is notoriously unreliable on ## Windows (see '?seek') but also appears to be broken in R-3.0.0 on ## my 64-bit Ubuntu laptop when used on a gzfile connection. ## TODO: Remove the '!is(con, "gzfile")' condition when seek() is fixed. use_seek <- isSeekable(con) && .Platform$OS.type != "windows" && !is(con, "gzfile") if (use_seek) return(seek(con, n, origin="current")) ### Values to skip are read by small chunks of 8M values that we ### don't keep in memory. This requires less memory than reading them ### all at once, and thus is slightly faster. chunk_size <- 8000000L nloop <- n %/% chunk_size for (i in seq_len(nloop)) readBin(con, "raw", n=chunk_size) readBin(con, "raw", n = n %% chunk_size) } ### 'obj_offset' and 'obj_length' are the offset (in bytes) and length (in ### nb of array values) of a linear array of fixed-size atomic values called ### the "object". 'offset' and 'length' are relative to the object and both ### must be expressed in nb of array values. .loadSequence <- function(filepath, file_type, what, obj_offset, obj_length, offset=0, length=NA) { ## Check 'obj_offset'. Should typically be a double. if (!isSingleNumber(obj_offset) || obj_offset < 0) stop("'obj_offset' must be a single non-negative number") ## Check 'obj_length'. if (!isSingleNumber(obj_length)) stop("'obj_length' must be a single integer") if (!is.integer(obj_length)) obj_length <- as.integer(obj_length) if (obj_length < 0L) stop("'obj_length' cannot be negative") ## Check 'offset'. offset <- normargOffset(offset, obj_length) ## Check 'length'. length <- normargLength(length, obj_length, offset) con <- get(file_type)(filepath, open="rb") on.exit(close(con)) n <- obj_offset + as.double(offset) * .sizeOnDisk(what) .skipBytes(con, n) readBin(con, what, n=length, endian="big") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### DirectRaw -- A concrete OnDiskRaw subclass that treats the bytes stored ### in a file as the values of a raw vector. ### .getFileSize <- function(filepath) { if (!isSingleString(filepath)) stop("'filepath' must be a single string") ans <- file.info(filepath)$size if (is.na(ans) || ans > .Machine$integer.max) stop("file size not available or file too big ", "(size > '.Machine$integer.max')") as.integer(ans) } setClass("DirectRaw", contains="OnDiskRaw") DirectRaw <- function(filepath) { ans_length <- .getFileSize(filepath) ans_cache <- new.env(parent=emptyenv()) new("DirectRaw", filepath=filepath, length=ans_length, .cache=ans_cache) } setMethod("loadSequence", "DirectRaw", function(x, offset=0, length=NA) { .loadSequence(x@filepath, "file", "raw", 0, x@length, offset=offset, length=length) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### SerializedRaw -- A concrete OnDiskRaw subclass for fast access to the ### values stored in a serialized raw vector. ### ### Supports RDX2 and RDA2 formats only. These are the formats produced ### when calling save() with 'ascii=FALSE' (the default) and 'ascii=TRUE', ### respectively. .getRdaTypeAndFormat <- function(filepath) { if (!isSingleString(filepath)) stop("'filepath' must be a single string") RDX2 <- charToRaw("RDX2\nX\n") RDA2 <- charToRaw("RDA2\nA\n") ## file(), gzfile(), bzfile(), and xzfile() don't necessarily return a ## "connection" object with the type (i.e. first more specific class) ## that corresponds to the function that was called. For example, when ## called on a Xz file, gzfile() returns a "connection" object of type ## "xzfile". for (con_type in c("file", "gzfile", "bzfile", "xzfile")) { con <- get(con_type)(filepath, open="rb") buf <- readBin(con, "raw", n=7L) if (identical(buf, RDX2)) { on.exit(close(con)) file_format <- "RDX2" break } if (identical(buf, RDA2)) { on.exit(close(con)) file_format <- "RDA2" break } close(con) } if (!identical(try(isOpen(con), silent=TRUE), TRUE)) stop("unknown file type/format for serialized R objects") list(file_type=class(con)[1L], file_format=file_format) } .filepos_envir <- new.env(parent=emptyenv()) .get_filepos <- function() get("filepos", envir=.filepos_envir, inherits=FALSE) .set_filepos <- function(filepos) assign("filepos", filepos, envir=.filepos_envir) ### An enhanced readBin() that keeps track of the current position in the ### file. Needed because seek() is not supported or reliable on all ### connections. .readBin2 <- function(con, what, n=1L) { filepos <- .get_filepos() filepos <- filepos + as.double(n) * .sizeOnDisk(what) .set_filepos(filepos) readBin(con, what, n=n, endian="big") } ### The length of a serialized object seems to be stored only for a CHARSXP, ### an atomic vector (LGLSXP, INTSXP, REALSXP, CPLXSXP, STRSXP, RAWSXP), ### a list (VECSXP), and an expressions vector (EXPRSXP). ### See src/main/serialize.c in R source tree. .TYPES_WITH_LENGTH <- c(CHARSXP=9L, LGLSXP=10L, INTSXP=13L, REALSXP=14L, CPLXSXP=15L, STRSXP=16L, RAWSXP=24L, VECSXP=19L, EXPRSXP=20L) ### Supports RDX2 and RDA2 formats only. .getFirstObjectInfoFromRda <- function(filepath) { type_and_format <- .getRdaTypeAndFormat(filepath) file_type <- type_and_format$file_type file_format <- type_and_format$file_format con <- get(file_type)(filepath, open="rb") on.exit(close(con)) obj_length <- NA_integer_ obj_offset <- NA_real_ .set_filepos(0) if (file_format == "RDX2") { .readBin2(con, "raw", n=31L) obj_name_len <- .readBin2(con, "integer", n=1L) obj_name <- rawToChar(.readBin2(con, "raw", n=obj_name_len)) flags <- .readBin2(con, "raw", n=4L) obj_type <- as.integer(flags[4L]) other_flags <- as.integer(flags[3L]) is_obj <- as.logical(other_flags %% 2L) has_attr <- as.logical((other_flags %/% 2L) %% 2L) has_tag <- as.logical((other_flags %/% 4L) %% 2L) if (obj_type %in% .TYPES_WITH_LENGTH) { obj_length <- .readBin2(con, "integer", n=1L) if (obj_length < -1L) stop("negative serialized length for vector") if (obj_length == -1L) { ## Length of a long vector is encoded with 2 integers. len1len2 <- .readBin2(con, "integer", n=2L) ## Compute length as a double. obj_length <- len1len2[1L] * (2L^32L) + len1len2[2L] } obj_offset <- .get_filepos() } } else if (file_format == "RDA2") { buf <- readLines(con, n=11L) obj_name <- buf[10L] flags <- as.numeric(buf[11L]) obj_type <- as.integer(flags %% 256L) other_flags <- as.integer(flags %/% 256L) is_obj <- as.logical(other_flags %% 2L) has_attr <- as.logical((other_flags %/% 2L) %% 2L) has_tag <- as.logical((other_flags %/% 4L) %% 2L) if (obj_type %in% .TYPES_WITH_LENGTH) { obj_length <- as.integer(readLines(con, n=1L)) if (obj_length < -1L) stop("negative serialized length for vector") if (obj_length == -1L) { ## Length of a long vector is encoded with 2 integers. len1len2 <- as.integer(readLines(con, n=2L)) ## Compute length as a double. obj_length <- len1len2[1L] * (2L^32L) + len1len2[2L] } } } ans2 <- list(obj_name=obj_name, obj_type=obj_type, is_obj=is_obj, has_attr=has_attr, has_tag=has_tag, obj_length=obj_length, obj_offset=obj_offset) c(type_and_format, ans2) } ### Works on a serialized logical, integer, double, complex, or raw vector. ### Extracts only the vector values. All attributes are ignored. .loadSequenceFromRda <- function(filepath, offset=0, length=NA) { info <- .getFirstObjectInfoFromRda(filepath) file_type <- info$file_type file_format <- info$file_format obj_type <- info$obj_type obj_length <- info$obj_length obj_offset <- info$obj_offset if (is.na(obj_length)) stop("serialized object not a vector (has no length)") if (!is.integer(obj_length)) stop("serialized long vectors are not supported") type <- names(.TYPES_WITH_LENGTH)[match(obj_type, .TYPES_WITH_LENGTH)] what <- switch(type, LGLSXP="logical", INTSXP="integer", REALSXP="double", CPLXSXP="complex", RAWSXP="raw", stop(type, ": unsupported type of serialized vector")) if (file_format == "RDX2") { ans <- .loadSequence(filepath, file_type, what, obj_offset, obj_length, offset=offset, length=length) } else { stop(file_format, " format not supported yet") } ans } setClass("SerializedRaw", contains="OnDiskRaw", representation( file_type="character", file_format="character", obj_offset="numeric" # not integer, so works on a file > 2 Gb ) ) SerializedRaw <- function(filepath) { info <- .getFirstObjectInfoFromRda(filepath) file_type <- info$file_type file_format <- info$file_format obj_type <- info$obj_type obj_length <- info$obj_length obj_offset <- info$obj_offset if (file_format != "RDX2") stop("Object in file was serialized in the ", file_format, " format, ", "which is not a binary\n format. save() should be called with ", "'ascii=FALSE' (the default) in order to\n produce a binary ", "file that can be used in a SerializedRaw object.") ## TODO: Remove this when seek() is fixed. if (file_type != "file") warning("The '", filepath, "' file is compressed (type: \"", file_type, "\").\n", " At this moment (i.e. in R <= 3.0.0), seek() is reliable ", "only on an\n uncompressed file (type: \"file\"), so it ", "cannot be used for fast access\n to the data in your file. ", "This means that loadSequence() will be slow on\n your ", "SerializedRaw object. For much faster access to the data, ", "consider\n using an uncompressed '.rda' file instead. ", "This is obtained by using\n save() with 'compress=FALSE'.") if (obj_type != .TYPES_WITH_LENGTH[["RAWSXP"]]) stop("serialized object not a raw vector") if (!is.integer(obj_length)) stop("serialized object is a long raw vector -> not supported") ans_cache <- new.env(parent=emptyenv()) new("SerializedRaw", filepath=filepath, length=obj_length, .cache=ans_cache, file_type=file_type, file_format=file_format, obj_offset=obj_offset) } setMethod("loadSequence", "SerializedRaw", function(x, offset=0, length=NA) { .loadSequence(x@filepath, x@file_type, "raw", x@obj_offset, x@length, offset=offset, length=length) } ) XVector/R/SharedDouble-class.R0000644000126300012640000000572512227065007017531 0ustar00biocbuildphs_compbio### ========================================================================= ### SharedDouble objects ### ------------------------------------------------------------------------- ### ### A SharedDouble object is an external pointer to an ordinary double ### vector. ### setClass("SharedDouble", contains="SharedVector") ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Initialization. ### ### Note that, unlike 'numeric(99)', 'SharedDouble(99)' does NOT initialize its ### data. Specify the 'val' argument if you want data initialization. ### SharedDouble <- function(length=0L, val=NULL) { if (!isSingleNumber(length) || length < 0) stop("'length' must be a single non-negative integer") if (!is.integer(length)) length <- as.integer(length) if (!is.null(val)) { if (!is.numeric(val)) stop("'val' must be a numeric vector") if (!storage.mode(val) == "double") storage.mode(val) <- "double" } .Call2("SharedDouble_new", length, val, PACKAGE="XVector") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity. ### .valid.SharedDouble <- function(x) { if (!tagIsVector(x@xp, tagtype="double")) return(problemIfNotExternalVector("'x@xp'", tagmustbe="a double vector")) NULL } setValidity2("SharedDouble", .valid.SharedDouble) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Read/write functions. ### These are almost safe wrappers to unsafe C functions ("almost" because ### they don't check for NAs in their arguments). ### If length(i) == 0 then the read functions return an empty vector ### and the write functions don't do anything. ### SharedDouble.read <- function(x, i, imax=integer(0)) { if (!is.integer(i)) i <- as.integer(i) if (length(i) == 1) { if (length(imax) == 0) imax <- i else imax <- as.integer(imax) .Call2("SharedDouble_read_nums_from_i1i2", x, i, imax, PACKAGE="XVector") } else { .Call2("SharedDouble_read_nums_from_subscript", x, i, PACKAGE="XVector") } } SharedDouble.write <- function(x, i, imax=integer(0), value) { if (!is.numeric(value)) stop("'value' must be a numeric vector") if (!is.integer(i)) i <- as.integer(i) if (length(i) == 1) { if (length(imax) == 0) imax <- i else imax <- as.integer(imax) .Call2("SharedDouble_write_nums_to_i1i2", x, i, imax, value, PACKAGE="XVector") } else { .Call2("SharedDouble_write_nums_to_subscript", x, i, value, PACKAGE="XVector") } x } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion. ### setMethod("as.numeric", "SharedDouble", function(x, ...) SharedDouble.read(x, 1L, length(x)) ) XVector/R/SharedInteger-class.R0000644000126300012640000000575512227065007017717 0ustar00biocbuildphs_compbio### ========================================================================= ### SharedInteger objects ### ------------------------------------------------------------------------- ### ### A SharedInteger object is an external pointer to an ordinary integer ### vector. ### setClass("SharedInteger", contains="SharedVector") ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Initialization. ### ### Note that, unlike 'integer(99)', 'SharedInteger(99)' does NOT initialize its ### data. Specify the 'val' argument if you want data initialization. ### SharedInteger <- function(length=0L, val=NULL) { if (!isSingleNumber(length) || length < 0) stop("'length' must be a single non-negative integer") if (!is.integer(length)) length <- as.integer(length) if (!is.null(val)) { if (!is.numeric(val)) stop("'val' must be a numeric vector") if (!storage.mode(val) == "integer") storage.mode(val) <- "integer" } .Call2("SharedInteger_new", length, val, PACKAGE="XVector") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity. ### .valid.SharedInteger <- function(x) { if (!tagIsVector(x@xp, tagtype="integer")) return(problemIfNotExternalVector("'x@xp'", tagmustbe="an integer vector")) NULL } setValidity2("SharedInteger", .valid.SharedInteger) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Read/write functions. ### These are almost safe wrappers to unsafe C functions ("almost" because ### they don't check for NAs in their arguments). ### If length(i) == 0 then the read functions return an empty vector ### and the write functions don't do anything. ### SharedInteger.read <- function(x, i, imax=integer(0)) { if (!is.integer(i)) i <- as.integer(i) if (length(i) == 1) { if (length(imax) == 0) imax <- i else imax <- as.integer(imax) .Call2("SharedInteger_read_ints_from_i1i2", x, i, imax, PACKAGE="XVector") } else { .Call2("SharedInteger_read_ints_from_subscript", x, i, PACKAGE="XVector") } } SharedInteger.write <- function(x, i, imax=integer(0), value) { if (!is.integer(value)) stop("'value' must be an integer vector") if (!is.integer(i)) i <- as.integer(i) if (length(i) == 1) { if (length(imax) == 0) imax <- i else imax <- as.integer(imax) .Call2("SharedInteger_write_ints_to_i1i2", x, i, imax, value, PACKAGE="XVector") } else { .Call2("SharedInteger_write_ints_to_subscript", x, i, value, PACKAGE="XVector") } x } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion. ### setMethod("as.integer", "SharedInteger", function(x, ...) SharedInteger.read(x, 1L, length(x)) ) XVector/R/SharedRaw-class.R0000644000126300012640000001650612227065007017047 0ustar00biocbuildphs_compbio### ========================================================================= ### SharedRaw objects and SharedRaw_Pool objects ### ------------------------------------------------------------------------- ### ### A SharedRaw object is an external pointer to an ordinary raw vector. ### A SharedRaw_Pool object is *conceptually* a list of SharedRaw ### objects but is actually NOT *implemented* as a list of such objects. ### See SharedVector-class.R file for the representation details. ### setClass("SharedRaw", contains="SharedVector") setClass("SharedRaw_Pool", contains="SharedVector_Pool") ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Initialization. ### ### Note that, unlike 'raw(99)', 'SharedRaw(99)' does NOT initialize its ### data. Specify the 'val' argument if you want data initialization. SharedRaw <- function(length=0L, val=NULL) { if (!isSingleNumber(length) || length < 0) stop("'length' must be a single non-negative integer") if (!is.integer(length)) length <- as.integer(length) if (!is.null(val) && !is.raw(val)) { if (is.numeric(val)) { val <- as.raw(val) } else if (isSingleString(val)) { val <- charToRaw(val) } else { stop("don't know how to turn 'val' into a raw vector") } } .Call2("SharedRaw_new", length, val, PACKAGE="XVector") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Some low-level methods. ### setMethod("[[", "SharedRaw_Pool", function(x, i, j, ...) { if (!isSingleInteger(i) || i < 1L || i > length(x)) stop("invalid subscript") ans <- SharedRaw() ans@xp <- x@xp_list[[i]] ans@.link_to_cached_object <- x@.link_to_cached_object_list[[i]] ans } ) setReplaceMethod("[[", "SharedRaw_Pool", function(x, i, j, ..., value) { if (!isSingleInteger(i) || i < 1L || i > length(x)) stop("invalid subscript") if (class(value) != "SharedRaw") stop("replacement value must be a SharedRaw instance") x@xp_list[[i]] <- value@xp x@.link_to_cached_object_list[[i]] <- value@.link_to_cached_object x } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity. ### .valid.SharedRaw <- function(x) { if (!tagIsVector(x@xp, tagtype="raw")) return(problemIfNotExternalVector("'x@xp'", tagmustbe="a raw vector")) NULL } setValidity2("SharedRaw", .valid.SharedRaw) .valid.SharedRaw_Pool <- function(x) { if (!all(sapply(x@xp_list, function(elt) tagIsVector(elt, tagtype="raw")))) return(problemIfNotExternalVector("each element in 'x@xp_list'", tagmustbe="a raw vector")) NULL } setValidity2("SharedRaw_Pool", .valid.SharedRaw_Pool) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Read/write functions. ### These are almost safe wrappers to unsafe C functions ("almost" because ### they don't check for NAs in their arguments). ### If length(i) == 0 then the read functions return an empty vector ### and the write functions don't do anything. SharedRaw.readInts <- function(x, i, imax=integer(0)) { if (!is.integer(i)) i <- as.integer(i) if (length(i) == 1) { if (length(imax) == 0) imax <- i else imax <- as.integer(imax) .Call2("SharedRaw_read_ints_from_i1i2", x, i, imax, PACKAGE="XVector") } else { .Call2("SharedRaw_read_ints_from_subscript", x, i, PACKAGE="XVector") } } SharedRaw.writeInts <- function(x, i, imax=integer(0), value) { if (!is.integer(value)) stop("'value' must be an integer vector") if (!is.integer(i)) i <- as.integer(i) if (length(i) == 1) { if (length(imax) == 0) imax <- i else imax <- as.integer(imax) .Call2("SharedRaw_write_ints_to_i1i2", x, i, imax, value, PACKAGE="XVector") } else { .Call2("SharedRaw_write_ints_to_subscript", x, i, value, PACKAGE="XVector") } x } ### 'dec_lkup' must be NULL or a vector of integers SharedRaw.read <- function(x, i, imax=integer(0), dec_lkup=NULL) { if (!is.integer(i)) i <- as.integer(i) if (length(i) == 1) { if (length(imax) == 0) imax <- i else imax <- as.integer(imax) if (is.null(dec_lkup)) .Call2("SharedRaw_read_chars_from_i1i2", x, i, imax, PACKAGE="XVector") else .Call2("SharedRaw_read_enc_chars_from_i1i2", x, i, imax, dec_lkup, PACKAGE="XVector") } else { if (is.null(dec_lkup)) .Call2("SharedRaw_read_chars_from_subscript", x, i, PACKAGE="XVector") else .Call2("SharedRaw_read_enc_chars_from_subscript", x, i, dec_lkup, PACKAGE="XVector") } } ### 'enc_lkup' must be NULL or a vector of integers SharedRaw.write <- function(x, i, imax=integer(0), value, enc_lkup=NULL) { if (!isSingleString(value)) stop("'value' must be a single string") if (!is.integer(i)) i <- as.integer(i) if (length(i) == 1) { if (length(imax) == 0) imax <- i else imax <- as.integer(imax) if (is.null(enc_lkup)) .Call2("SharedRaw_write_chars_to_i1i2", x, i, imax, value, PACKAGE="XVector") else .Call2("SharedRaw_write_enc_chars_to_i1i2", x, i, imax, value, enc_lkup, PACKAGE="XVector") } else { if (is.null(enc_lkup)) .Call2("SharedRaw_write_chars_to_subscript", x, i, value, PACKAGE="XVector") else .Call2("SharedRaw_write_enc_chars_to_subscript", x, i, value, enc_lkup, PACKAGE="XVector") } x } ### 'lkup' must be a vector of complexes SharedRaw.readComplexes <- function(x, i, imax=integer(0), lkup) { if (!is.integer(i)) i <- as.integer(i) if (length(i) == 1) { if (length(imax) == 0) imax <- i else imax <- as.integer(imax) .Call2("SharedRaw_read_complexes_from_i1i2", x, i, imax, lkup, PACKAGE="XVector") } else { .Call2("SharedRaw_read_complexes_from_subscript", x, i, lkup, PACKAGE="XVector") } } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion. ### ### TODO: add the "as.raw" and "as.character" methods. ### setMethod("as.integer", "SharedRaw", function(x, ...) { SharedRaw.readInts(x, 1L, length(x)) } ) ### Typical use: ### x <- SharedRaw(15, as.raw(65)) ### toString(x) ### x <- SharedRaw(5, charToRaw("Hello")) ### toString(x) ### This should always rewrite the content of a SharedRaw object ### to itself, without any modification: ### SharedRaw.write(x, 1, length(x), value=toString(x)) ### whatever the content of 'x' is! setMethod("toString", "SharedRaw", function(x, ...) SharedRaw.read(x, 1, length(x)) ) XVector/R/SharedVector-class.R0000644000126300012640000002667112227065007017564 0ustar00biocbuildphs_compbio### ========================================================================= ### SharedVector and SharedVector_Pool objects ### ------------------------------------------------------------------------- ### ### A SharedVector object is an external pointer to an ordinary vector. ### A SharedVector_Pool object is *conceptually* a list of SharedVector ### objects but is actually NOT *implemented* as a list of such objects. ### This is to avoid having to generate long lists of S4 objects which the ### current S4 implementation is *very* inefficient at. ### setClass("SharedVector", representation("VIRTUAL", xp="externalptr", ## Any object that is never copied on assignment would be fine here. ## See R/BSgenome-class.R in the BSgenome package for how this slot ## is used for automatic uncaching of the sequences of a BSgenome ## object. .link_to_cached_object="environment" ) ) setClass("SharedVector_Pool", representation("VIRTUAL", xp_list="list", .link_to_cached_object_list="list" ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Low-level utilities operating directly on an externalptr object. ### .get_tag <- function(x) { if (!is(x, "externalptr")) stop("'x' must be an externalptr object") .Call2("externalptr_get_tag", x, PACKAGE="XVector") } .set_tag <- function(x, tag) { if (!is(x, "externalptr")) stop("'x' must be an externalptr object") .Call2("externalptr_set_tag", x, tag, PACKAGE="XVector") } .taglength <- function(x) { if (!is(x, "externalptr")) stop("'x' must be an externalptr object") .Call2("externalptr_taglength", x, PACKAGE="XVector") } .tagtype <- function(x) { if (!is(x, "externalptr")) stop("'x' must be an externalptr object") .Call2("externalptr_tagtype", x, PACKAGE="XVector") } tagIsVector <- function(x, tagtype=NA) { if (!is(x, "externalptr")) stop("'x' must be an externalptr object") x_tagtype <- .tagtype(x) if (!is.na(tagtype)) return(x_tagtype == tagtype) return(x_tagtype == "double" || extends(x_tagtype, "vector")) } newExternalptrWithTag <- function(tag=NULL) { xp <- .Call2("externalptr_new", PACKAGE="XVector") .set_tag(xp, tag) } ### Helper function (for debugging purpose). ### Print some info about an externalptr object. ### Typical use: ### show(new("externalptr")) setMethod("show", "externalptr", function(object) .Call2("externalptr_show", object, PACKAGE="XVector") ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### SharedVector constructor. ### ### Just dispatches on the specific constructor function (each SharedVector ### concrete subclass should define a constructor function with arguments ### 'length' and 'val'). SharedVector <- function(Class, length=0L, val=NULL) { FUN <- match.fun(Class) FUN(length=length, val=val) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### SharedVector getters. ### setMethod("length", "SharedVector", function(x) .taglength(x@xp)) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### The "show" method for SharedVector objects. ### ### Return the hexadecimal representation of the address of the first ### element of the tag (i.e. the first element of the external vector). .address0 <- function(x) .Call2("SharedVector_address0", x, PACKAGE="XVector") .oneLineDesc <- function(x) paste(class(x), " of length ", length(x), " (data starting at address ", .address0(x), ")", sep="") setMethod("show", "SharedVector", function(object) { cat(.oneLineDesc(object), "\n", sep="") } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### SharedVector_Pool low-level constructors. ### ### 'SharedVector_subclass' should be the name of a SharedVector concrete ### subclass (i.e. currently one of "SharedRaw", "SharedInteger", or ### "SharedDouble"). new_SharedVector_Pool_from_list_of_SharedVector <- function(SharedVector_subclass, x) { if (length(x) != 0L) { ## We use 'class(x_elt) == SharedVector_subclass' instead of more ## common idiom 'is(x_elt, SharedVector_subclass)' because (1) it's ## faster, and (2) the SharedVector concrete subclasses should never ## be extended anyway (i.e. they're conceptually "final classes" to ## use Java terminology). ok <- lapply(x, function(x_elt) class(x_elt) == SharedVector_subclass) if (!all(unlist(ok))) stop("all elements in 'x' must be ", SharedVector_subclass, " instances") } ans_xp_list <- lapply(x, function(x_elt) x_elt@xp) ans_link_to_cached_object_list <- lapply(x, function(x_elt) x_elt@.link_to_cached_object) ans_class <- paste(SharedVector_subclass, "_Pool", sep="") new2(ans_class, xp_list=ans_xp_list, .link_to_cached_object_list=ans_link_to_cached_object_list, check=FALSE) } ### If 'x' is a SharedVector object, then ### ### new_SharedVector_Pool_from_SharedVector(x)[[1L]] ### ### will be identical to 'x'. new_SharedVector_Pool_from_SharedVector <- function(x) { new_SharedVector_Pool_from_list_of_SharedVector(class(x), list(x)) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### SharedVector_Pool low-level methods. ### setMethod("length", "SharedVector_Pool", function(x) length(x@xp_list)) setMethod("width", "SharedVector_Pool", function(x) if (length(x) == 0L) integer(0) else sapply(x@xp_list, .taglength) ) setMethod("show", "SharedVector_Pool", function(object) { cat(class(object), " of length ", length(object), "\n", sep="") for (i in seq_len(length(object))) cat(i, ": ", .oneLineDesc(object[[i]]), "\n", sep="") } ) setAs("SharedVector", "SharedVector_Pool", function(from) new_SharedVector_Pool_from_SharedVector(from) ) ### For internal use only. No argument checking! setMethod("c", "SharedVector_Pool", function(x, ..., recursive=FALSE) { if (!identical(recursive, FALSE)) stop("\"c\" method for SharedVector_Pool objects ", "does not support the 'recursive' argument") x@xp_list <- do.call(c, lapply(unname(list(x, ...)), function(arg) arg@xp_list)) x@.link_to_cached_object_list <- do.call(c, lapply(unname(list(x, ...)), function(arg) arg@.link_to_cached_object_list)) x } ) ### For internal use only. No argument checking! setMethod("[", "SharedVector_Pool", function(x, i, j, ..., drop=TRUE) { x@xp_list <- x@xp_list[i] x@.link_to_cached_object_list <- x@.link_to_cached_object_list[i] x } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity. ### problemIfNotExternalVector <- function(what, tagmustbe="a vector") { msg <- paste(what, "must be an external pointer to", tagmustbe) return(msg) } .valid.SharedVector <- function(x) { if (!tagIsVector(x@xp)) return(problemIfNotExternalVector("'x@xp'")) NULL } setValidity2("SharedVector", .valid.SharedVector) .valid.SharedVector_Pool <- function(x) { if (length(x@xp_list) != length(x@.link_to_cached_object_list)) return("'x@xp_list' and 'x@.link_to_cached_object_list' must have the same length") if (!all(sapply(x@xp_list, function(elt) tagIsVector(elt)))) return(problemIfNotExternalVector("each element in 'x@xp_list'")) if (!all(sapply(x@.link_to_cached_object_list, function(elt) is.environment(elt)))) return("each element in 'x@.link_to_cached_object_list' must be an environment") NULL } setValidity2("SharedVector_Pool", .valid.SharedVector_Pool) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Data comparison. ### ### A wrapper to the very fast memcmp() C-function. ### Arguments MUST be the following or it will crash R: ### x1, x2: SharedVector objects ### start1, start2, width: single integers ### In addition: 1 <= start1 <= start1+width-1 <= length(x1) ### 1 <= start2 <= start2+width-1 <= length(x2) ### WARNING: This function is voluntarly unsafe (it doesn't check its ### arguments) because we want it to be the fastest possible! ### SharedVector.compare <- function(x1, start1, x2, start2, width) .Call2("SharedVector_memcmp", x1, start1, x2, start2, width, PACKAGE="XVector") ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Low-level copy. ### ### 'lkup' must be NULL or an integer vector. SharedVector.copy <- function(dest, i, imax=integer(0), src, lkup=NULL) { if (!is(src, "SharedVector")) stop("'src' must be a SharedVector object") if (!is.integer(i)) i <- as.integer(i) if (length(i) == 1) { if (length(imax) == 0) imax <- i else imax <- as.integer(imax) width <- imax - i + 1L .Call2("SharedVector_Ocopy_from_start", dest, src, i, width, lkup, FALSE, PACKAGE="XVector") } else { .Call2("SharedVector_Ocopy_from_subscript", dest, src, i, lkup, PACKAGE="XVector") } dest } ### 'lkup' must be NULL or an integer vector. SharedVector.reverseCopy <- function(dest, i, imax=integer(0), src, lkup=NULL) { if (!is(src, "SharedVector")) stop("'src' must be a SharedVector object") if (length(i) != 1) stop("'i' must be a single integer") if (!is.integer(i)) i <- as.integer(i) if (length(imax) == 0) imax <- i else imax <- as.integer(imax) width <- imax - i + 1L .Call2("SharedVector_Ocopy_from_start", dest, src, i, width, lkup, TRUE, PACKAGE="XVector") dest } ### 'lkup' must be NULL or an integer vector. SharedVector.mcopy <- function(dest, dest.offset, src, src.start, src.width, lkup=NULL, reverse=FALSE) { if (!isSingleInteger(dest.offset)) stop("'dest.offset' must be a single integer") if (!is(src, "SharedVector")) stop("'src' must be a SharedVector object") if (!is.integer(src.start) || !is.integer(src.width)) stop("'src.start' and 'src.width' must be integer vectors") if (!isTRUEorFALSE(reverse)) stop("'reverse' must be TRUE or FALSE") .Call2("SharedVector_mcopy", dest, dest.offset, src, src.start, src.width, lkup, reverse, PACKAGE="XVector") dest } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion. ### ### Works as long as as.integer() works on 'x'. setMethod("as.numeric", "SharedVector", function(x, ...) as.numeric(as.integer(x)) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Address comparison. ### ### Be careful with the semantic of the "==" operator: the addresses are ### compared, not the data they are pointing at! ### ### Return the hexadecimal address of any R object in a string. address <- function(x) .Call2("address_asSTRSXP", x, PACKAGE="XVector") setMethod("==", signature(e1="SharedVector", e2="SharedVector"), function(e1, e2) address(e1@xp) == address(e2@xp) ) setMethod("!=", signature(e1="SharedVector", e2="SharedVector"), function(e1, e2) address(e1@xp) != address(e2@xp) ) XVector/R/XDouble-class.R0000644000126300012640000000374012227065007016525 0ustar00biocbuildphs_compbio### ========================================================================= ### XDouble objects ### ------------------------------------------------------------------------- ### ### The XDouble class is a container for storing an "external double ### vector" i.e. a *single* view on a SharedDouble object. ### ### IMPORTANT NOTE: Our concept/representation/implementation of "external ### vector" in general differ significantly from those found in the ### externalVector package! ### setClass("XDouble", contains="XVector", representation( shared="SharedDouble" ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Initialization. ### setMethod("initialize", "XDouble", function(.Object, length=0L, val=NULL) { if (!isSingleNumber(length) || length < 0) stop("'length' must be a single non-negative integer") if (!is.integer(length)) length <- as.integer(length) .Object@shared <- SharedDouble(length=length, val=val) .Object@offset <- 0L .Object@length <- length .Object } ) XDouble <- function(length=base::length(val), val=NULL) new2("XDouble", length=length, val=val, check=FALSE) ### Just an alias for XDouble(). XNumeric <- function(...) XDouble(...) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion. ### ### From standard vectors to XDouble objects: setAs("numeric", "XDouble", function(from) XDouble(length(from), val=from)) setAs("numeric", "XVector", function(from) as(from, "XDouble")) ### From XDouble objects to standard vectors: setMethod("as.numeric", "XDouble", function(x, ...) SharedDouble.read(x@shared, x@offset + 1L, x@offset + x@length) ) setMethod("as.vector", "XDouble", function(x, mode="any") { if (!identical(mode, "any")) stop("\"as.vector\" method for XDouble objects ", "does not support the 'mode' argument") as.numeric(x) } ) XVector/R/XDoubleViews-class.R0000644000126300012640000001711512227065007017544 0ustar00biocbuildphs_compbio### ========================================================================= ### XDoubleViews objects ### ------------------------------------------------------------------------- ### ### The XDoubleViews class is the basic container for storing a set of views ### (start/end locations) on the same XDouble object, called the "subject" ### vector. setClass("XDoubleViews", contains="Views", representation( subject="XDouble" ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### User-friendly constructor. ### setMethod("Views", "XDouble", function(subject, start=NULL, end=NULL, width=NULL, names=NULL) newViews(subject, start=start, end=end, width=width, names=names, Class="XDoubleViews") ) setMethod("Views", "numeric", function(subject, start=NULL, end=NULL, width=NULL, names=NULL) { xsubject <- as(subject, "XDouble") Views(xsubject, start=start, end=end, width=width, names=names) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### The "show" method. ### ### The 2 helper functions below convert a given view on an XDouble object ### into a character-string. ### Both assume that 'start' <= 'end' (so they don't check it) and ### padd the result with spaces to produce the "margin effect" ### if 'start' or 'end' are out of limits. XDoubleViews.show_vframe_header <- function(iW, startW, endW, widthW) { cat(format("", width=iW+1), format("start", width=startW, justify="right"), " ", format("end", width=endW, justify="right"), " ", format("width", width=widthW, justify="right"), "\n", sep="") } XDoubleViews.show_vframe_line <- function(x, i, iW, startW, endW, widthW) { lsx <- length(subject(x)) start <- start(x)[i] end <- end(x)[i] width <- end - start + 1 snippetWidth <- getOption("width") - 6 - iW - startW - endW - widthW if (width > 0 && lsx > 0 && start <= lsx && end >= 1) { snippet <- IRanges:::toNumSnippet(subseq(subject(x), start=max(min(start,lsx),1), end=max(min(end,lsx),1)), snippetWidth) } else { snippet <- " " } cat(format(paste("[", i,"]", sep=""), width=iW, justify="right"), " ", format(start, width=startW, justify="right"), " ", format(end, width=endW, justify="right"), " ", format(width, width=widthW, justify="right"), " ", "[", snippet, "]\n", sep="") } ### 'half_nrow' must be >= 1 XDoubleViews.show_vframe <- function(x, half_nrow=9L) { cat("\nviews:") lx <- length(x) if (lx == 0) cat(" NONE\n") else { cat("\n") iW <- nchar(as.character(lx)) + 2 # 2 for the brackets startMax <- max(start(x)) startW <- max(nchar(startMax), nchar("start")) endMax <- max(end(x)) endW <- max(nchar(endMax), nchar("end")) widthMax <- max(width(x)) widthW <- max(nchar(widthMax), nchar("width")) XDoubleViews.show_vframe_header(iW, startW, endW, widthW) if (lx <= 2*half_nrow+1) { for (i in seq_len(lx)) XDoubleViews.show_vframe_line(x, i, iW, startW, endW, widthW) } else { for (i in 1:half_nrow) XDoubleViews.show_vframe_line(x, i, iW, startW, endW, widthW) cat(format("...", width=iW, justify="right"), " ", format("...", width=startW, justify="right"), " ", format("...", width=endW, justify="right"), " ", format("...", width=widthW, justify="right"), " ...\n", sep="") for (i in (lx-half_nrow+1L):lx) XDoubleViews.show_vframe_line(x, i, iW, startW, endW, widthW) } } } setMethod("show", "XDoubleViews", function(object) { subject <- subject(object) lsub <- length(subject) cat("Views on a ", lsub, "-double ", class(subject), " subject", sep="") cat("\nsubject: ", IRanges:::toNumSnippet(subject, getOption("width")-9), sep="") XDoubleViews.show_vframe(object) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Equality. ### ### Assume that 'start1', 'end1', 'start2', 'end2' are single integers ### and that start1 <= end1 and start2 <= end2. XDoubleViews.view1_equal_view2 <- function(x1, start1, end1, x2, start2, end2) { one <- as.integer(1) w1 <- end1 - start1 + one w2 <- end2 - start2 + one if (w1 != w2) return(FALSE) lx1 <- length(x1) isBlank1 <- end1 < one || start1 > lx1 lx2 <- length(x2) isBlank2 <- end2 < one || start2 > lx2 if (isBlank1 && isBlank2) return(TRUE) if (isBlank1 || isBlank2) return(FALSE) # Left margin LmarginSize1 <- start1 < one LmarginSize2 <- start2 < one if (LmarginSize1 != LmarginSize2) return(FALSE) if (LmarginSize1) { # Both views have a left margin if (start1 != start2) return(FALSE) start1 <- one start2 <- one } # Right margin RmarginSize1 <- end1 > lx1 RmarginSize2 <- end2 > lx2 if (RmarginSize1 != RmarginSize2) return(FALSE) if (RmarginSize1) { # Both views have a right margin if (end1 - lx1 != end2 - lx2) return(FALSE) end1 <- lx1 end2 <- lx2 } # At this point, we can trust that 1 <= start1 <= end1 <= lx1 # and that 1 <= start2 <= end2 <= lx2. subseq(x1, start=start1, end=end1) == subseq(x2, start=start2, end=end2) } ### 'x' and 'y' must be XDoubleViews objects. ### Returns a logical vector of length max(length(x), length(y)). ### Recycle its arguments. XDoubleViews.equal <- function(x, y) { lx <- length(x) ly <- length(y) if (lx < ly) { tmp <- x x <- y y <- tmp tmp <- lx lx <- ly ly <- tmp } if (ly == 0) return(logical(0)) # Now we are sure that lx >= ly >= 1 ans <- logical(lx) j <- 1 for (i in seq_len(lx)) { ans[i] <- XDoubleViews.view1_equal_view2( subject(x), start(x)[i], end(x)[i], subject(y), start(y)[j], end(y)[j]) # Recycle if (j < ly) j <- j + 1 else j <- 1 } if (j != 1) warning(paste("longer object length", "is not a multiple of shorter object length")) ans } ### These methods are called if at least one side of the "==" (or "!=") ### operator is an XDoubleViews object. They have precedence over the ### corresponding methods defined for XDouble objects, i.e. they will ### be called if one side is an XDoubleViews object and the other side ### is an XDouble object. setMethod("==", signature(e1="XDoubleViews", e2="XDoubleViews"), function(e1, e2) { XDoubleViews.equal(e1, e2) } ) setMethod("==", signature(e1="XDoubleViews", e2="XDouble"), function(e1, e2) { XDoubleViews.equal(e1, as(e2, "Views")) } ) setMethod("==", signature(e1="XDoubleViews", e2="numeric"), function(e1, e2) { if (length(e2) == 0 || anyMissing(e2)) stop("comparison between an XDoubleViews object and an integer ", "vector of length 0 or with NAs is not supported") XDoubleViews.equal(e1, as(e2, "Views")) } ) setMethod("==", signature(e1="XDouble", e2="XDoubleViews"), function(e1, e2) e2 == e1 ) setMethod("==", signature(e1="numeric", e2="XDoubleViews"), function(e1, e2) e2 == e1 ) XVector/R/XInteger-class.R0000644000126300012640000000365312227065007016713 0ustar00biocbuildphs_compbio### ========================================================================= ### XInteger objects ### ------------------------------------------------------------------------- ### ### The XInteger class is a container for storing an "external integer ### vector" i.e. a *single* view on a SharedInteger object. ### ### IMPORTANT NOTE: Our concept/representation/implementation of "external ### vector" in general differ significantly from those found in the ### externalVector package! ### setClass("XInteger", contains="XVector", representation( shared="SharedInteger" ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Initialization. ### setMethod("initialize", "XInteger", function(.Object, length=0L, val=NULL) { if (!isSingleNumber(length) || length < 0) stop("'length' must be a single non-negative integer") if (!is.integer(length)) length <- as.integer(length) .Object@shared <- SharedInteger(length=length, val=val) .Object@offset <- 0L .Object@length <- length .Object } ) XInteger <- function(length=base::length(val), val=NULL) new2("XInteger", length=length, val=val, check=FALSE) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion. ### ### From standard vectors to XInteger objects: setAs("numeric", "XInteger", function(from) XInteger(length(from), val=from)) setAs("integer", "XVector", function(from) as(from, "XInteger")) ### From XInteger objects to standard vectors: setMethod("as.integer", "XInteger", function(x, ...) SharedInteger.read(x@shared, x@offset + 1L, x@offset + x@length) ) setMethod("as.vector", "XInteger", function(x, mode="any") { if (!identical(mode, "any")) stop("\"as.vector\" method for XInteger objects ", "does not support the 'mode' argument") as.integer(x) } ) XVector/R/XIntegerViews-class.R0000644000126300012640000001715412227065007017732 0ustar00biocbuildphs_compbio### ========================================================================= ### XIntegerViews objects ### ------------------------------------------------------------------------- ### ### The XIntegerViews class is the basic container for storing a set of views ### (start/end locations) on the same XInteger object, called the "subject" ### vector. setClass("XIntegerViews", contains="Views", representation( subject="XInteger" ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### User-friendly constructor. ### setMethod("Views", "XInteger", function(subject, start=NULL, end=NULL, width=NULL, names=NULL) newViews(subject, start=start, end=end, width=width, names=names, Class="XIntegerViews") ) setMethod("Views", "integer", function(subject, start=NULL, end=NULL, width=NULL, names=NULL) { xsubject <- as(subject, "XInteger") Views(xsubject, start=start, end=end, width=width, names=names) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### The "show" method. ### ### The 2 helper functions below convert a given view on an XInteger object ### into a character-string. ### Both assume that 'start' <= 'end' (so they don't check it) and ### padd the result with spaces to produce the "margin effect" ### if 'start' or 'end' are out of limits. XIntegerViews.show_vframe_header <- function(iW, startW, endW, widthW) { cat(format("", width=iW+1), format("start", width=startW, justify="right"), " ", format("end", width=endW, justify="right"), " ", format("width", width=widthW, justify="right"), "\n", sep="") } XIntegerViews.show_vframe_line <- function(x, i, iW, startW, endW, widthW) { lsx <- length(subject(x)) start <- start(x)[i] end <- end(x)[i] width <- end - start + 1 snippetWidth <- getOption("width") - 6 - iW - startW - endW - widthW if (width > 0 && lsx > 0 && start <= lsx && end >= 1) { snippet <- IRanges:::toNumSnippet(subseq(subject(x), start=max(min(start,lsx),1), end=max(min(end,lsx),1)), snippetWidth) } else { snippet <- " " } cat(format(paste("[", i,"]", sep=""), width=iW, justify="right"), " ", format(start, width=startW, justify="right"), " ", format(end, width=endW, justify="right"), " ", format(width, width=widthW, justify="right"), " ", "[", snippet, "]\n", sep="") } ### 'half_nrow' must be >= 1 XIntegerViews.show_vframe <- function(x, half_nrow=9L) { cat("\nviews:") lx <- length(x) if (lx == 0) cat(" NONE\n") else { cat("\n") iW <- nchar(as.character(lx)) + 2 # 2 for the brackets startMax <- max(start(x)) startW <- max(nchar(startMax), nchar("start")) endMax <- max(end(x)) endW <- max(nchar(endMax), nchar("end")) widthMax <- max(width(x)) widthW <- max(nchar(widthMax), nchar("width")) XIntegerViews.show_vframe_header(iW, startW, endW, widthW) if (lx <= 2*half_nrow+1) { for (i in seq_len(lx)) XIntegerViews.show_vframe_line(x, i, iW, startW, endW, widthW) } else { for (i in 1:half_nrow) XIntegerViews.show_vframe_line(x, i, iW, startW, endW, widthW) cat(format("...", width=iW, justify="right"), " ", format("...", width=startW, justify="right"), " ", format("...", width=endW, justify="right"), " ", format("...", width=widthW, justify="right"), " ...\n", sep="") for (i in (lx-half_nrow+1L):lx) XIntegerViews.show_vframe_line(x, i, iW, startW, endW, widthW) } } } setMethod("show", "XIntegerViews", function(object) { subject <- subject(object) lsub <- length(subject) cat("Views on a ", lsub, "-integer ", class(subject), " subject", sep="") cat("\nsubject: ", IRanges:::toNumSnippet(subject, getOption("width")-9), sep="") XIntegerViews.show_vframe(object) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Equality. ### ### Assume that 'start1', 'end1', 'start2', 'end2' are single integers ### and that start1 <= end1 and start2 <= end2. XIntegerViews.view1_equal_view2 <- function(x1, start1, end1, x2, start2, end2) { one <- as.integer(1) w1 <- end1 - start1 + one w2 <- end2 - start2 + one if (w1 != w2) return(FALSE) lx1 <- length(x1) isBlank1 <- end1 < one || start1 > lx1 lx2 <- length(x2) isBlank2 <- end2 < one || start2 > lx2 if (isBlank1 && isBlank2) return(TRUE) if (isBlank1 || isBlank2) return(FALSE) # Left margin LmarginSize1 <- start1 < one LmarginSize2 <- start2 < one if (LmarginSize1 != LmarginSize2) return(FALSE) if (LmarginSize1) { # Both views have a left margin if (start1 != start2) return(FALSE) start1 <- one start2 <- one } # Right margin RmarginSize1 <- end1 > lx1 RmarginSize2 <- end2 > lx2 if (RmarginSize1 != RmarginSize2) return(FALSE) if (RmarginSize1) { # Both views have a right margin if (end1 - lx1 != end2 - lx2) return(FALSE) end1 <- lx1 end2 <- lx2 } # At this point, we can trust that 1 <= start1 <= end1 <= lx1 # and that 1 <= start2 <= end2 <= lx2. subseq(x1, start=start1, end=end1) == subseq(x2, start=start2, end=end2) } ### 'x' and 'y' must be XIntegerViews objects. ### Returns a logical vector of length max(length(x), length(y)). ### Recycle its arguments. XIntegerViews.equal <- function(x, y) { lx <- length(x) ly <- length(y) if (lx < ly) { tmp <- x x <- y y <- tmp tmp <- lx lx <- ly ly <- tmp } if (ly == 0) return(logical(0)) # Now we are sure that lx >= ly >= 1 ans <- logical(lx) j <- 1 for (i in seq_len(lx)) { ans[i] <- XIntegerViews.view1_equal_view2( subject(x), start(x)[i], end(x)[i], subject(y), start(y)[j], end(y)[j]) # Recycle if (j < ly) j <- j + 1 else j <- 1 } if (j != 1) warning(paste("longer object length", "is not a multiple of shorter object length")) ans } ### These methods are called if at least one side of the "==" (or "!=") ### operator is an XIntegerViews object. They have precedence over the ### corresponding methods defined for XInteger objects, i.e. they will ### be called if one side is an XIntegerViews object and the other side ### is an XInteger object. setMethod("==", signature(e1="XIntegerViews", e2="XIntegerViews"), function(e1, e2) { XIntegerViews.equal(e1, e2) } ) setMethod("==", signature(e1="XIntegerViews", e2="XInteger"), function(e1, e2) { XIntegerViews.equal(e1, as(e2, "Views")) } ) setMethod("==", signature(e1="XIntegerViews", e2="integer"), function(e1, e2) { if (length(e2) == 0 || anyMissing(e2)) stop("comparison between an XIntegerViews object and an integer ", "vector of length 0 or with NAs is not supported") XIntegerViews.equal(e1, as(e2, "Views")) } ) setMethod("==", signature(e1="XInteger", e2="XIntegerViews"), function(e1, e2) e2 == e1 ) setMethod("==", signature(e1="integer", e2="XIntegerViews"), function(e1, e2) e2 == e1 ) XVector/R/XRaw-class.R0000644000126300012640000000357112227065007016046 0ustar00biocbuildphs_compbio### ========================================================================= ### XRaw objects ### ------------------------------------------------------------------------- ### ### The XRaw class is a container for storing an "external raw vector" ### i.e. a *single* view on a SharedRaw object. ### ### IMPORTANT NOTE: Our concept/representation/implementation of "external ### vector" in general differ significantly from those found in the ### externalVector package! ### setClass("XRaw", contains="XVector", representation( shared="SharedRaw" ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Initialization. ### XRaw <- function(length=0L, val=NULL) { if (!isSingleNumber(length) || length < 0L) stop("'length' must be a single non-negative integer") if (!is.integer(length)) length <- as.integer(length) new2("XRaw", shared=SharedRaw(length=length, val=val), length=length, check=FALSE) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion. ### ### From standard vectors to XRaw objects: setAs("raw", "XRaw", function(from) XRaw(length(from), val=from)) setAs("raw", "XVector", function(from) as(from, "XRaw")) setAs("numeric", "XRaw", function(from) XRaw(length(from), val=from)) ### From XRaw objects to standard vectors: ### TODO: Modify SharedRaw.read() so it returns a raw vector instead of a ### character string, and use it here. setMethod("as.raw", "XRaw", function(x) as.raw(as.integer(x))) setMethod("as.integer", "XRaw", function(x, ...) SharedRaw.readInts(x@shared, x@offset + 1L, x@offset + x@length) ) setMethod("as.vector", "XRaw", function(x, mode="any") { if (!identical(mode, "any")) stop("\"as.vector\" method for XRaw objects ", "does not support the 'mode' argument") as.raw(x) } ) XVector/R/XRawList-class.R0000644000126300012640000000113312227065007016672 0ustar00biocbuildphs_compbio### ========================================================================= ### XRawList objects ### ------------------------------------------------------------------------- ### ### An XRawList object is *conceptually* a list of XRaw objects ### but is actually not *implemented* as a list of such objects. ### This is to avoid having to generate long lists of S4 objects which the ### current S4 implementation is *very* inefficient at. ### setClass("XRawList", contains="XVectorList", representation( pool="SharedRaw_Pool" ), prototype( elementType="XRaw" ) ) XVector/R/XRawList-comparison.R0000644000126300012640000001001512227065007017736 0ustar00biocbuildphs_compbio### ========================================================================= ### Comparing and ordering the elements in one or more XRawList objects ### ------------------------------------------------------------------------- ### ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### compare() ### setMethod("compare", c("XRawList", "XRawList"), function(x, y) .Call2("XRawList_compare", x, y, PACKAGE="XVector") ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Element-wise (aka "parallel") comparison of 2 XRawList objects. ### ### We only need to implement "==" and "<=" methods. The other comparison ### binary operators (!=, >=, <, >) will then work out-of-the-box on ### XRawList objects thanks to the methods for Vector objects. ### setMethod("==", c("XRawList", "XRawList"), function(e1, e2) compare(e1, e2) == 0L ) setMethod("<=", c("XRawList", "XRawList"), function(e1, e2) compare(e1, e2) <= 0L ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### match() and duplicated() ### setMethod("match", c("XRawList", "XRawList"), function(x, table, nomatch=NA_integer_, incomparables=NULL) { if (!is.numeric(nomatch) || length(nomatch) != 1L) stop("'nomatch' must be a single integer value") if (!is.integer(nomatch)) nomatch <- as.integer(nomatch) if (!is.null(incomparables)) stop("\"match\" method for XRawList objects ", "only accepts 'incomparables=NULL'") .Call2("XRawList_match_hash", x, table, nomatch, PACKAGE="XVector") } ) .selfmatchXRawList <- function(x) { .Call2("XRawList_selfmatch_hash", x, PACKAGE="XVector") } .duplicated.XRawList <- function(x, incomparables=FALSE) { if (!identical(incomparables, FALSE)) stop("\"duplicated\" method for XRawList objects ", "only accepts 'incomparables=FALSE'") sm <- .selfmatchXRawList(x) sm != seq_len(length(sm)) } ### S3/S4 combo for duplicated.XRawList duplicated.XRawList <- function(x, incomparables=FALSE, ...) .duplicated.XRawList(x, incomparables=incomparables, ...) setMethod("duplicated", "XRawList", duplicated.XRawList) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### order() and related methods ### setMethod("is.unsorted", "XRawList", function(x, na.rm=FALSE, strictly=FALSE) { if (!identical(na.rm, FALSE)) warning("\"is.unsorted\" method for XRawList objects ", "ignores the 'na.rm' argument") if (!isTRUEorFALSE(strictly)) stop("'strictly' must be TRUE or FALSE") .Call2("XRawList_is_unsorted", x, strictly, PACKAGE="XVector") } ) setMethod("order", "XRawList", function(..., na.last=TRUE, decreasing=FALSE) { if (!identical(na.last, TRUE)) warning("\"order\" method for XRawList objects ", "ignores the 'na.last' argument") if (!isTRUEorFALSE(decreasing)) stop("'decreasing' must be TRUE or FALSE") ## All arguments in '...' are guaranteed to be XRawList objects. args <- list(...) if (length(args) == 1L) { x <- args[[1L]] return(.Call2("XRawList_order", x, decreasing, PACKAGE="XVector")) } stop("\"order\" method for XRawList objects ", "only takes 1 XRawList object for now, sorry") } ) setMethod("rank", "XRawList", function(x, na.last=TRUE, ties.method=c("average", "first", "random", "max", "min")) { if (!identical(na.last, TRUE)) warning("\"rank\" method for XRawList objects ", "ignores the 'na.last' argument") ties.method <- match.arg(ties.method) if (!(ties.method %in% c("first", "min"))) stop("\"rank\" method for XRawList objects supports ", "only 'ties.method=\"first\"' and 'ties.method=\"min\"'") .Call2("XRawList_rank", x, ties.method, PACKAGE="XVector") } ) XVector/R/XVector-class.R0000644000126300012640000001250512227065007016554 0ustar00biocbuildphs_compbio### ========================================================================= ### XVector objects ### ------------------------------------------------------------------------- ### ### The XVector virtual class is a general container for storing ### an "external vector" i.e. a *single* view on a SharedVector object. ### ### IMPORTANT NOTE: Our concept/representation/implementation of "external ### vector" differ significantly from those found in the externalVector ### package! ### setClass("XVector", contains="Vector", representation( "VIRTUAL", shared="SharedVector", offset="integer", # a single integer length="integer" # a single integer ), prototype( offset=0L, length=0L ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Getters. ### setMethod("length", "XVector", function(x) x@length) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Combining. ### ### Should work as an endomorphism (e.g. will return a DNAString instance if ### 'x' is a DNAString instance). setMethod("c", "XVector", function(x, ..., recursive=FALSE) { if (!identical(recursive, FALSE)) stop("\"c\" method for XVector objects ", "does not support the 'recursive' argument") if (missing(x)) { args <- unname(list(...)) x <- args[[1L]] } else { args <- unname(list(x, ...)) } if (length(args) == 1L) return(x) arg_is_null <- sapply(args, is.null) ## Remove NULL elements by setting them to NULL! if (any(arg_is_null)) args[arg_is_null] <- NULL if (!all(sapply(args, is, class(x)))) stop("all arguments in '...' must be ", class(x), " objects (or NULLs)") ans_length <- sum(sapply(args, length)) ans_shared <- SharedVector(class(x@shared), length=ans_length) dest_offset <- 0L for (arg in args) { width <- length(arg) if (width == 0L) # will be TRUE on NULLs too... next ## ... so from here 'arg' is guaranteed to be an XVector object. src <- arg@shared src_start <- arg@offset + 1L SharedVector.mcopy(ans_shared, dest_offset, src, src_start, width) dest_offset <- dest_offset + width } ans <- new2(class(x), length=ans_length, check=FALSE) ans@shared <- ans_shared ans } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Subsetting. ### setMethod(IRanges:::extractROWS, "XVector", function(x, i) { i <- IRanges:::extractROWS(setNames(seq_along(x), names(x)), i) new_shared <- SharedVector(class(x@shared), length=length(i)) SharedVector.copy(new_shared, x@offset + i, src=x@shared) x@shared <- new_shared x@offset <- 0L x@length <- length(new_shared) mcols(x) <- mcols(x)[i, , drop=FALSE] x } ) ### Extracts a linear subsequence without copying the sequence data! setGeneric("subseq", signature="x", function(x, start=NA, end=NA, width=NA) standardGeneric("subseq") ) ### Replace a linear subsequence. setGeneric("subseq<-", signature="x", function(x, start=NA, end=NA, width=NA, value) standardGeneric("subseq<-") ) setMethod("subseq", "XVector", function(x, start=NA, end=NA, width=NA) { solved_SEW <- IRanges:::solveUserSEWForSingleSeq(length(x), start, end, width) x@offset <- x@offset + start(solved_SEW) - 1L x@length <- width(solved_SEW) mcols(x) <- IRanges:::extractROWS(mcols(x), solved_SEW) x } ) setReplaceMethod("subseq", "XVector", function(x, start=NA, end=NA, width=NA, value) { solved_SEW <- IRanges:::solveUserSEWForSingleSeq(length(x), start, end, width) if (!is.null(value)) { if (!is(value, class(x))) stop("'value' must be a ", class(x), " object or NULL") } c(subseq(x, end=start(solved_SEW)-1L), value, subseq(x, start=end(solved_SEW)+1L)) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Coercion. ### ### Works as long as as.integer() works on 'x'. setMethod("as.numeric", "XVector", function(x, ...) as.numeric(as.integer(x)) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### The "show" method. ### setMethod("show", "XVector", function(object) { lo <- length(object) cat(class(object), " of length ", lo, "\n", sep="") if (lo != 0L) cat(" [1] ", IRanges:::toNumSnippet(object, getOption("width")-5), "\n", sep="") } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Equality. ### .XVector.equal <- function(x, y) { if (class(x) != class(y) || x@length != y@length) return(FALSE) ans <- !SharedVector.compare(x@shared, x@offset + 1L, y@shared, y@offset + 1L, x@length) as.logical(ans) } setMethod("==", signature(e1="XVector", e2="XVector"), function(e1, e2) .XVector.equal(e1, e2) ) XVector/R/XVectorList-class.R0000644000126300012640000003265512227065007017420 0ustar00biocbuildphs_compbio### ========================================================================= ### XVectorList objects ### ------------------------------------------------------------------------- ### ### An XVectorList object is *conceptually* a list of XVector objects ### but is actually not *implemented* as a list of such objects. ### This is to avoid having to generate long lists of S4 objects which the ### current S4 implementation is *very* inefficient at. ### setClass("GroupedIRanges", contains="IRanges", representation( group="integer" ) ) setClass("XVectorList", contains="List", representation( "VIRTUAL", pool="SharedVector_Pool", ranges="GroupedIRanges" ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### GroupedIRanges methods. ### .valid.GroupedIRanges <- function(x) { if (length(x@group) != length(x)) return("slot \"group\" slot must have same length as object") NULL } setValidity2("GroupedIRanges", .valid.GroupedIRanges) setMethod("as.data.frame", "GroupedIRanges", function(x, row.names=NULL, optional=FALSE, ...) cbind(group=x@group, callNextMethod(), stringsAsFactors=FALSE) ) setMethod("show", "GroupedIRanges", function(object) show(as.data.frame(object)) ) setMethod(IRanges:::extractROWS, "GroupedIRanges", function(x, i) { i <- IRanges:::extractROWS(setNames(seq_along(x), names(x)), i) x@group <- IRanges:::extractROWS(x@group, i) callNextMethod() } ) setMethod("c", "GroupedIRanges", function(x, ..., recursive=FALSE) { if (!identical(recursive, FALSE)) stop("\"c\" method for GroupedIRanges objects ", "does not support the 'recursive' argument") old_val <- IRanges:::disableValidity() on.exit(IRanges:::disableValidity(old_val)) IRanges:::disableValidity(TRUE) ans <- callNextMethod(x, ..., recursive=FALSE) ans@group <- do.call(c, lapply(unname(list(x, ...)), function(arg) arg@group)) ans } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### XVectorList accessor-like methods. ### setMethod("length", "XVectorList", function(x) length(x@ranges)) setMethod("width", "XVectorList", function(x) width(x@ranges)) setMethod("elementLengths", "XVectorList", function(x) width(x)) setMethod("names", "XVectorList", function(x) names(x@ranges)) setReplaceMethod("names", "XVectorList", function(x, value) { names(x@ranges) <- value x } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### 2 internal bookkeeping functions to keep the XVectorList "pool" slot ### clean and tidy. ### ### Used in "extractROWS" method for XVectorList objects. .dropUnusedPoolElts <- function(x) { pool_len <- length(x@pool) if (pool_len == 0L) return(x) keep_it <- logical(pool_len) keep_it[x@ranges@group] <- TRUE keep_idx <- which(keep_it) remap <- integer(pool_len) remap[keep_idx] <- seq_len(length(keep_idx)) x@pool <- x@pool[keep_idx] x@ranges@group <- remap[x@ranges@group] x } ### Used in "c" method for XVectorList objects and in ### new_XVectorList_from_list_of_XVector() constructor. .dropDuplicatedPoolElts <- function(x) { pool_len <- length(x@pool) if (pool_len == 0L) return(x) remap <- high2low(sapply(x@pool@xp_list, address)) keep_idx <- which(is.na(remap)) remap[keep_idx] <- seq_len(length(keep_idx)) x@pool <- x@pool[keep_idx] x@ranges@group <- remap[x@ranges@group] x } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### XVectorList constructors. ### ### Takes one XVector object ('xvector') and an IRanges object defining ### 1-based ranges on 'xvector' (conceptually equivalent to defining views ### on subject 'xvector'). unsafe.newXVectorList1 <- function(classname, xvector, ranges) { if (is.null(classname)) classname <- paste(class(xvector), "List", sep="") ans_pool <- as(xvector@shared, "SharedVector_Pool") ranges_group <- rep.int(1L, length(ranges)) ans_ranges <- new2("GroupedIRanges", shift(ranges, xvector@offset), group=ranges_group, check=FALSE) new2(classname, pool=ans_pool, ranges=ans_ranges, check=FALSE) } new_XVectorList_from_list_of_XVector <- function(classname, x) { if (!is.list(x)) stop("'x' must be a list") x_names <- names(x) if (!is.null(x_names)) names(x) <- NULL ans_elementType <- elementType(new(classname)) x_len <- length(x) if (x_len != 0L) { ok <- lapply(x, function(x_elt) is(x_elt, ans_elementType)) if (!all(unlist(ok))) stop("all elements in 'x' must be ", ans_elementType, " objects") } elt0 <- new(ans_elementType) ans_pool_class <- class(elt0@shared) shared_list <- lapply(x, function(x_elt) x_elt@shared) ans_pool <- new_SharedVector_Pool_from_list_of_SharedVector(ans_pool_class, shared_list) if (x_len == 0L) { ans_ranges <- new2("GroupedIRanges", check=FALSE) } else { ans_ranges_start <- unlist(lapply(x, function(x_elt) x_elt@offset)) + 1L ans_ranges_width <- unlist(lapply(x, function(x_elt) x_elt@length)) ans_ranges_group <- seq_len(x_len) ans_ranges <- new2("GroupedIRanges", start=ans_ranges_start, width=ans_ranges_width, group=ans_ranges_group, check=FALSE) } ans <- new2(classname, pool=ans_pool, ranges=ans_ranges, check=FALSE) ans <- .dropDuplicatedPoolElts(ans) if (!is.null(x_names)) names(ans) <- x_names ans } ### Produces an XVectorList object of the given length with empty elements. XVectorList <- function(classname, length=0L) { elt0 <- new(elementType(new(classname))) ans1_pool <- as(elt0@shared, "SharedVector_Pool") ans1_ranges <- new("GroupedIRanges", IRanges(start=1L, width=0L), group=1L) ans1 <- new2(classname, pool=ans1_pool, ranges=ans1_ranges, check=FALSE) rep.int(ans1, length) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### XVectorList subsetting. ### ### TODO: Make this a "getListElement" method for XVectorList objects. XVectorList.getElement <- function(x, i) { ans_class <- elementType(x) ans_shared <- x@pool[[x@ranges@group[i]]] ans_offset <- x@ranges@start[i] - 1L ans_length <- x@ranges@width[i] ans <- new2(ans_class, shared=ans_shared, offset=ans_offset, length=ans_length, check=FALSE) return(ans) } setMethod("[[", "XVectorList", function(x, i, j, ..., exact=TRUE) { i <- IRanges:::normalizeDoubleBracketSubscript(i, x) XVectorList.getElement(x, i) } ) setMethod(IRanges:::extractROWS, "XVectorList", function(x, i) { i <- IRanges:::extractROWS(setNames(seq_along(x), names(x)), i) x@ranges <- IRanges:::extractROWS(x@ranges, i) x@elementMetadata <- IRanges:::extractROWS(x@elementMetadata, i) ## Drop unused pool elements. x <- .dropUnusedPoolElts(x) x } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### subseq() ### narrowXVectorList <- function(x, start=NA, end=NA, width=NA, use.names=TRUE) { x@ranges <- narrow(x@ranges, start=start, end=end, width=width, use.names=use.names) x } setMethod("subseq", "XVectorList", function(x, start=NA, end=NA, width=NA) narrowXVectorList(x, start=start, end=end, width=width) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Combining. ### ### The "c" method for XVectorList objects is implemented to behave like an ### endomorphism i.e. to return an object of the same class as 'x'. In ### particular 'c(x)' returns 'x' and not 'as(x, "XVectorList")'. ### It's easy to implement specific "c" methods for XVectorList subclasses. ### Typically they just need to do something like: ### ### old_val <- IRanges:::disableValidity() ### on.exit(IRanges:::disableValidity(old_val)) ### IRanges:::disableValidity(TRUE) ### ans <- callNextMethod(x, ..., recursive=FALSE) ### ... ### ### and to take care of the additional slots (aka the subclass-specific ### slots). If there aren't any additional slots (e.g. XRawList), or if the ### additional slots don't need to be modified, then no need to implement a ### specific method at all. ### ### 'Class' must be the name of a concrete subclass that extends XVectorList. ### Returns an instance of class 'Class'. unlist_list_of_XVectorList <- function(Class, x, use.names=TRUE, ignore.mcols=FALSE) { if (!isSingleString(Class)) stop("'Class' must be a single character string") if (!extends(Class, "XVectorList")) stop("'Class' must be the name of a class that extends XVectorList") if (!is.list(x)) stop("'x' must be a list") if (!isTRUEorFALSE(use.names)) stop("'use.names' must be TRUE or FALSE") ### TODO: Support 'use.names=TRUE'. if (use.names) stop("'use.names=TRUE' is not supported yet") if (!isTRUEorFALSE(ignore.mcols)) stop("'ignore.mcols' must be TRUE or FALSE") ## TODO: Implement (in C) fast elementIsNull(x), that does ## 'sapply(x, is.null, USE.NAMES=FALSE)' on list 'x', and use it here. null_idx <- which(sapply(x, is.null, USE.NAMES=FALSE)) if (length(null_idx) != 0L) x <- x[-null_idx] if (length(x) == 0L) return(new(Class)) ## TODO: Implement (in C) fast elementIs(x, class), that does ## 'sapply(x, is, class, USE.NAMES=FALSE)' on list 'x', and use it here. ## 'elementIs(x, "NULL")' should work and be equivalent to ## 'elementIsNull(x)'. if (!all(sapply(x, is, Class, USE.NAMES=FALSE))) stop("all elements in 'x' must be ", Class, " objects (or NULLs)") x_names <- names(x) names(x) <- NULL # so lapply(x, ...) below returns an unnamed list ## Combine "pool" slots. pool_slots <- lapply(x, function(xi) xi@pool) ## TODO: Implement unlist_list_of_SharedRaw_Pool() and use it here. ans_pool <- do.call(c, pool_slots) ## Combine "ranges" slots. ranges_slots <- lapply(x, function(xi) xi@ranges) ## TODO: Implement unlist_list_of_GroupedRanges() (that takes an 'offsets' ## arg) and use it here. ans_ranges <- do.call(c, ranges_slots) breakpoints <- cumsum(elementLengths(pool_slots)) offsets <- c(0L, breakpoints[-length(breakpoints)]) offsets <- rep.int(offsets, elementLengths(ranges_slots)) ans_ranges@group <- ans_ranges@group + offsets ## Combine "mcols" slots. ans_mcols <- do.call(IRanges:::rbind.mcols, x) ## Make 'ans' and return it. ans <- new(Class, pool=ans_pool, ranges=ans_ranges, elementMetadata=ans_mcols) .dropDuplicatedPoolElts(ans) } setMethod("c", "XVectorList", function(x, ..., ignore.mcols=FALSE, recursive=FALSE) { if (!identical(recursive, FALSE)) stop("\"c\" method for XVectorList objects ", "does not support the 'recursive' argument") if (missing(x)) { args <- list(...) x <- args[[1L]] } else { args <- list(x, ...) } unlist_list_of_XVectorList(class(x), args, use.names=FALSE, ignore.mcols=ignore.mcols) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Replacement methods. ### setReplaceMethod("[[", "XVectorList", function(x, i, j, ..., value) { i <- IRanges:::normalizeDoubleBracketSubscript(i, x) if (!is(value, elementType(x))) stop("supplied replacement value must be a ", elementType(x), " object") x[i] <- as(value, class(x)) x } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Looping methods. ### setMethod("endoapply", "XVectorList", function(X, FUN, ...) { Xconstructor <- get(class(X)) ## If there is no constructor for 'class(X)' or if the constructor ## doesn't work on a list (here we try on an empty list), then we ## call the default method i.e. the method for List objects. This will ## be much slower but still better than failing. if (!is.function(Xconstructor) || inherits(try(Xconstructor(list()), silent=TRUE), "try-error")) return(callNextMethod()) Xconstructor(lapply(X, FUN, ...)) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Show method for data column. ### setMethod("showAsCell", "XVectorList", function(object) as.character(object)) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### unsplit_list_of_XVectorList() ### ### Not intended for the end user. ### ### 'f' must be a factor with number of levels equal to 'length(x)' and ### length equal to 'sum(elementLengths(x))'. unsplit_list_of_XVectorList <- function(classname, x, f) { ans <- XVectorList(classname, length(f)) unlisted_x <- do.call(c, unname(x)) idx <- unname(split(seq_len(length(f)), f)) ans[unlist(idx)] <- unlisted_x ans } XVector/R/compact-methods.R0000644000126300012640000001136412227065007017150 0ustar00biocbuildphs_compbio### ========================================================================= ### Object compaction ### ------------------------------------------------------------------------- ### ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### xvcopy() ### ### Internal compact() support function. Not intended to be called directly. ### setGeneric("xvcopy", signature="x", function(x, start=NA, end=NA, width=NA, lkup=NULL, reverse=FALSE) standardGeneric("xvcopy") ) ### Downgrades 'x' to one of the 3 concrete direct subclasses of SharedVector ### (SharedRaw, SharedInteger or SharedDouble). But those subclasses should ### not be extended anyway (like final classes in Java). setMethod("xvcopy", "SharedVector", function(x, start=NA, end=NA, width=NA, lkup=NULL, reverse=FALSE) { solved_SEW <- solveUserSEW(length(x), start=start, end=end, width=width) ans_length <- width(solved_SEW) ans <- SharedVector(class(x), length=ans_length) SharedVector.mcopy(ans, 0L, x, start(solved_SEW), ans_length, lkup=lkup, reverse=reverse) return(ans) } ) ### Like the "subseq" method for XVector objects, this is an endomorphism. setMethod("xvcopy", "XVector", function(x, start=NA, end=NA, width=NA, lkup=NULL, reverse=FALSE) { y <- subseq(x, start=start, end=end, width=width) y@shared <- xvcopy(y@shared, start=y@offset+1L, width=y@length, lkup=lkup, reverse=reverse) y@offset <- 0L y } ) setMethod("xvcopy", "SharedVector_Pool", function(x, start=NA, end=NA, width=NA, lkup=NULL, reverse=FALSE) { solved_SEW <- solveUserSEW(width(x), start=start, end=end, width=width) shared_vector_list <- lapply(seq_len(length(x)), function(i) xvcopy(x[[i]], start=start(solved_SEW)[i], width=width(solved_SEW)[i], lkup=lkup, reverse=reverse)) new2(class(x), xp_list=lapply(shared_vector_list, function(xv) xv@xp), .link_to_cached_object_list=lapply(shared_vector_list, function(xv) xv@.link_to_cached_object), check=FALSE) } ) ### Like the "subseq" method for XVectorList objects, this is an endomorphism. ### TODO: Make this a method for XVectorList objects. setMethod("xvcopy", "XRawList", function(x, start=NA, end=NA, width=NA, lkup=NULL, reverse=FALSE) { y <- narrow(x, start=start, end=end, width=width) all_groups <- unique(y@ranges@group) for (group in all_groups) { ii <- which(y@ranges@group == group) ranges <- as(y@ranges[ii], "IRanges") frame <- reduce(ranges, with.inframe.attrib=TRUE) shared_length <- sum(width(frame)) shared <- SharedRaw(shared_length) SharedVector.mcopy(shared, 0L, y@pool[[group]], start(frame), width(frame), lkup=lkup, reverse=reverse) y@pool[[group]] <- shared inframe <- attr(frame, "inframe") if (reverse) ## We supply start=1 so reverse() doesn't have to determine ## it (by calling 'min(start(inframe))'). inframe <- reverse(inframe, start=1L) y@ranges@start[ii] <- start(inframe) y@ranges@width[ii] <- width(inframe) } y } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### compact() ### setGeneric("compact", signature="x", function(x, check=TRUE, ...) standardGeneric("compact") ) setMethod("compact", "ANY", function(x, check=TRUE, ...) { if (is.list(x)) { ## By assigning to x[], we keep all the attributes (e.g. the ## row.names if 'x' is a data.frame). x[] <- lapply(x, compact) return(x) } if (isS4(x)) { for (name in slotNames(x)) slot(x, name, check=check) <- compact(slot(x, name), check=check, ...) return(x) } x } ) ### Both methods below first try to compact all the slots separately by ### calling the default "compact" method. In particular this could potentially ### achieve some real compaction of the "elementMetadata" and "metadata" slots. setMethod("compact", "XVector", function(x, check=TRUE, ...) { x <- callNextMethod() xvcopy(x) } ) setMethod("compact", "XVectorList", function(x, check=TRUE, ...) { x <- callNextMethod() xvcopy(x) } ) XVector/R/debug.R0000644000126300012640000000120112227065007015134 0ustar00biocbuildphs_compbio### debug_Ocopy_byteblocks <- function() invisible(.Call2("debug_Ocopy_byteblocks", PACKAGE="XVector")) debug_SharedVector_class <- function() invisible(.Call2("debug_SharedVector_class", PACKAGE="XVector")) debug_SharedRaw_class <- function() invisible(.Call2("debug_SharedRaw_class", PACKAGE="XVector")) debug_SharedInteger_class <- function() invisible(.Call2("debug_SharedInteger_class", PACKAGE="XVector")) debug_SharedDouble_class <- function() invisible(.Call2("debug_SharedDouble_class", PACKAGE="XVector")) debug_XVector_class <- function() invisible(.Call2("debug_XVector_class", PACKAGE="XVector")) XVector/R/intra-range-methods.R0000644000126300012640000000114512227065007017725 0ustar00biocbuildphs_compbio### ========================================================================= ### Intra-range methods ### ------------------------------------------------------------------------- ### setMethod("narrow", "XVectorList", narrowXVectorList) setMethod("threebands", "XVectorList", function(x, start=NA, end=NA, width=NA) { threeranges <- threebands(x@ranges, start=start, end=end, width=width) left <- right <- x left@ranges <- threeranges$left x@ranges <- threeranges$middle right@ranges <- threeranges$right list(left=left, middle=x, right=right) } ) XVector/R/reverse-methods.R0000644000126300012640000000047112227065007017172 0ustar00biocbuildphs_compbio### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### "reverse" methods. ### setMethod("reverse", "XVector", function(x, ...) xvcopy(x, reverse=TRUE)) setMethod("rev", "XVector", function(x) reverse(x)) setMethod("reverse", "XVectorList", function(x, ...) xvcopy(x, reverse=TRUE)) XVector/R/slice-methods.R0000644000126300012640000000430612227065007016617 0ustar00biocbuildphs_compbio### ========================================================================= ### Slice the bread ### ------------------------------------------------------------------------- setMethod("slice", "integer", function(x, lower=-.Machine$integer.max, upper=.Machine$integer.max) slice(as(x, "XInteger"), lower=lower, upper=upper) ) setMethod("slice", "XInteger", function(x, lower=-.Machine$integer.max, upper=.Machine$integer.max) { if (!isSingleNumber(lower)) stop("'lower' must be a single integer") if (!is.integer(lower)) lower <- as.integer(lower) if (!isSingleNumber(upper)) stop("'upper' must be a single integer") if (!is.integer(upper)) upper <- as.integer(upper) ranges <- .Call2("XInteger_slice", x, lower, upper, PACKAGE="XVector") Views(x, ranges) } ) setMethod("slice", "numeric", function(x, lower=-Inf, upper=Inf, includeLower=TRUE, includeUpper=TRUE, rangesOnly=FALSE) slice(as(x, "XDouble"), lower=lower, upper=upper, includeLower=includeLower, includeUpper=includeUpper, rangesOnly=rangesOnly) ) setMethod("slice", "XDouble", function(x, lower=-.Machine$double.xmax, upper=.Machine$double.xmax, includeLower=TRUE, includeUpper=TRUE, rangesOnly=FALSE) { if (!isSingleNumber(lower)) stop("'lower' must be a single integer") if (!is.numeric(lower)) lower <- as.numeric(lower) if (!isSingleNumber(upper)) stop("'upper' must be a single integer") if (!is.numeric(upper)) upper <- as.numeric(upper) if (!isTRUEorFALSE(includeLower)) stop("'includeLower' must be TRUE or FALSE") if (!isTRUEorFALSE(includeUpper)) stop("'includeUpper' must be TRUE or FALSE") if (!isTRUEorFALSE(rangesOnly)) stop("'rangesOnly' must be TRUE or FALSE") ranges <- .Call2("XDouble_slice", x, lower, upper, includeLower, includeUpper, PACKAGE="XVector") if (rangesOnly) { ranges } else { Views(x, ranges) } } ) XVector/R/updateObject-methods.R0000644000126300012640000000253212227065007020130 0ustar00biocbuildphs_compbio### ################################################################### ### Update methods ### ################################################################### ## "XVector" -> "XVector" setMethod("updateObject", signature(object="XVector"), function(object, ..., verbose=FALSE) { if (verbose) message("updateObject(object = 'XVector')") if (!("metadata" %in% names(attributes(object)))) { object <- new(class(object), shared = slot(object, "shared"), offset = slot(object, "offset"), length = slot(object, "length")) } object }) ## "XIntegerViews" -> "XIntegerViews" setMethod("updateObject", signature(object="XIntegerViews"), function(object, ..., verbose=FALSE) { if (verbose) message("updateObject(object = 'XIntegerViews')") if (!("metadata" %in% names(attributes(object)))) { object <- new("XIntegerViews", subject = updateObject(slot(object, "subject")), start = slot(object, "start"), width = slot(object, "width"), NAMES = slot(object, "NAMES")) } object }) XVector/R/view-summarization-methods.R0000644000126300012640000000503412227065007021371 0ustar00biocbuildphs_compbio### ========================================================================= ### Summarize views on an XInteger or XDouble object ### setMethod("viewMins", "XIntegerViews", function(x, na.rm=FALSE) .Call2("XIntegerViews_summary1", x, na.rm, "viewMins", PACKAGE="XVector") ) setMethod("viewMins", "XDoubleViews", function(x, na.rm=FALSE) .Call2("XDoubleViews_summary1", x, na.rm, "viewMins", PACKAGE="XVector") ) setMethod("viewMaxs", "XIntegerViews", function(x, na.rm=FALSE) .Call2("XIntegerViews_summary1", x, na.rm, "viewMaxs", PACKAGE="XVector") ) setMethod("viewMaxs", "XDoubleViews", function(x, na.rm=FALSE) .Call2("XDoubleViews_summary1", x, na.rm, "viewMaxs", PACKAGE="XVector") ) setMethod("viewSums", "XIntegerViews", function(x, na.rm=FALSE) .Call2("XIntegerViews_summary1", x, na.rm, "viewSums", PACKAGE="XVector") ) setMethod("viewSums", "XDoubleViews", function(x, na.rm=FALSE) .Call2("XDoubleViews_summary1", x, na.rm, "viewSums", PACKAGE="XVector") ) setMethod("viewMeans", "XIntegerViews", function(x, na.rm=FALSE) { if (!isTRUEorFALSE(na.rm)) stop("'na.rm' must be TRUE or FALSE") if (na.rm) { n <- viewSums(Views(!is.na(Rle(as.integer(subject(x)))), as(x, "Rle"))) } else { n <- width(x) } viewSums(x, na.rm = na.rm) / n } ) setMethod("viewMeans", "XDoubleViews", function(x, na.rm=FALSE) { if (!isTRUEorFALSE(na.rm)) stop("'na.rm' must be TRUE or FALSE") if (na.rm) { n <- viewSums(Views(!is.na(Rle(as.numeric(subject(x)))), as(x, "Rle"))) } else { n <- width(x) } viewSums(x, na.rm = na.rm) / n } ) setMethod("viewWhichMins", "XIntegerViews", function(x, na.rm=FALSE) .Call2("XIntegerViews_summary2", x, na.rm, "viewWhichMins", PACKAGE="XVector") ) setMethod("viewWhichMins", "XDoubleViews", function(x, na.rm=FALSE) .Call2("XDoubleViews_summary2", x, na.rm, "viewWhichMins", PACKAGE="XVector") ) setMethod("viewWhichMaxs", "XIntegerViews", function(x, na.rm=FALSE) .Call2("XIntegerViews_summary2", x, na.rm, "viewWhichMaxs", PACKAGE="XVector") ) setMethod("viewWhichMaxs", "XDoubleViews", function(x, na.rm=FALSE) .Call2("XDoubleViews_summary2", x, na.rm, "viewWhichMaxs", PACKAGE="XVector") ) XVector/R/zzz.R0000644000126300012640000000407212227065007014714 0ustar00biocbuildphs_compbio### .onLoad <- function(libname, pkgname) { ## -- HACK! -- ## The purpose of this 2nd hack below is to fix the prototypes of the ## following classes: SharedRaw, SharedInteger, SharedDouble, XRaw, ## XInteger and XDouble. Without this hack, calling new() on any of those ## classes (with e.g. 'new("SharedRaw")') returns an invalid object. ## In order to "fix" those prototypes, we cannot use the standard ## mechanism (which is to specify default slot values in the prototype ## part of the setClass() statements) because the DLL of the package needs ## to be loaded before those default values can be produced. ## Note that we must fix the prototypes of the 3 SharedVector concrete ## subclasses defined in this package *before* we fix the prototypes of ## the 3 XVector concrete subclasses defined in this package. ## 3 SharedVector concrete subclasses: IRanges:::setDefaultSlotValue("SharedRaw", "xp", newExternalptrWithTag(raw(0L)), where=asNamespace(pkgname)) IRanges:::setDefaultSlotValue("SharedInteger", "xp", newExternalptrWithTag(integer(0L)), where=asNamespace(pkgname)) IRanges:::setDefaultSlotValue("SharedDouble", "xp", newExternalptrWithTag(double(0L)), where=asNamespace(pkgname)) ## 3 XVector concrete subclasses: IRanges:::setDefaultSlotValue("XRaw", "shared", new("SharedRaw"), # is fixed now! where=asNamespace(pkgname)) IRanges:::setDefaultSlotValue("XInteger", "shared", new("SharedInteger"), # is fixed now! where=asNamespace(pkgname)) IRanges:::setDefaultSlotValue("XDouble", "shared", new("SharedDouble"), # is fixed now! where=asNamespace(pkgname)) } .onUnload <- function(libpath) { library.dynam.unload("XVector", libpath) } run_unitTests <- function() BiocGenerics:::testPackage("XVector") XVector/TODO0000644000126300012640000000002112227065010014203 0ustar00biocbuildphs_compbio- Add vignette. XVector/inst/0000755000126300012640000000000012227065010014477 5ustar00biocbuildphs_compbioXVector/inst/include/0000755000126300012640000000000012227065010016122 5ustar00biocbuildphs_compbioXVector/inst/include/XVector_defines.h0000644000126300012640000000226412227065010021366 0ustar00biocbuildphs_compbio/***************************************************************************** XVector C interface: typedefs and defines ----------------------------------------- The XVector C interface is split in 2 files: 1. XVector_defines.h (this file): contains the typedefs and defines of the interface. 2. XVector_interface.h (in this directory): contains the prototypes of the XVector C routines that are part of the interface. Please consult XVector_interface.h for how to use this interface in your package. *****************************************************************************/ #ifndef XVECTOR_DEFINES_H #define XVECTOR_DEFINES_H #include "IRanges_defines.h" #include #include typedef struct cached_charseq { const char *seq; int length; } cachedCharSeq; typedef struct cached_intseq { const int *seq; int length; } cachedIntSeq; typedef struct cached_doubleseq { const double *seq; int length; } cachedDoubleSeq; typedef struct cached_xvectorlist { const char *classname; const char *element_type; SEXP xp_list; int length; const int *start; const int *width; const int *group; } cachedXVectorList; #endif XVector/inst/include/XVector_interface.h0000644000126300012640000001206612227065010021712 0ustar00biocbuildphs_compbio/***************************************************************************** XVector C interface: prototypes ------------------------------- The XVector C interface is split in 2 files: 1. XVector_defines.h (in this directory): contains the typedefs and defines of the interface. 2. XVector_interface.h (this file): contains the prototypes of the XVector C routines that are part of the interface. *****************************************************************************/ #include "XVector_defines.h" /* * Ocopy_byteblocks.c */ void Ocopy_byteblocks_from_i1i2( int i1, int i2, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize ); void Ocopy_byteblocks_from_subscript( const int *subset, int n, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize ); void Ocopy_byteblocks_to_i1i2( int i1, int i2, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize ); void Ocopy_byteblocks_to_subscript( const int *subset, int n, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize ); void Ocopy_bytes_from_i1i2_with_lkup( int i1, int i2, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length ); void Ocopy_bytes_from_subscript_with_lkup( const int *subset, int n, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length ); void Ocopy_bytes_to_i1i2_with_lkup( int i1, int i2, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length ); void Ocopy_bytes_to_subscript_with_lkup( const int *subset, int n, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length ); void Orevcopy_byteblocks_from_i1i2( int i1, int i2, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize ); void Orevcopy_bytes_from_i1i2_with_lkup( int i1, int i2, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length ); void Ocopy_bytes_from_i1i2_to_complex( int i1, int i2, Rcomplex *dest, int dest_nbytes, const char *src, int src_nbytes, const Rcomplex *lkup, int lkup_length ); /* * Low-level manipulation of SharedVector objects. * (see SharedVector_class.c) */ SEXP new_SharedVector(const char *classname, SEXP tag); SEXP get_SharedVector_tag(SEXP x); int get_SharedVector_length(SEXP x); /* * Low-level manipulation of XVector objects. * (see XVector_class.c) */ SEXP get_XVector_shared(SEXP x); int get_XVector_offset(SEXP x); int get_XVector_length(SEXP x); SEXP get_XVector_tag(SEXP x); cachedCharSeq cache_XRaw(SEXP x); cachedIntSeq cache_XInteger(SEXP x); cachedDoubleSeq cache_XDouble(SEXP x); SEXP new_XVector(const char *classname, SEXP shared, int offset, int length); SEXP new_XRaw_from_tag(const char *classname, SEXP tag); SEXP new_XInteger_from_tag(const char *classname, SEXP tag); SEXP new_XDouble_from_tag(const char *classname, SEXP tag); SEXP alloc_XRaw(const char *classname, int length); SEXP alloc_XInteger(const char *classname, int length); SEXP alloc_XDouble(const char *classname, int length); /* * Low-level manipulation of XVectorList objects. * (see XVectorList_class.c) */ int get_XVectorList_length(SEXP x); SEXP get_XVectorList_width(SEXP x); SEXP get_XVectorList_names(SEXP x); cachedXVectorList cache_XVectorList(SEXP x); int get_cachedXVectorList_length(const cachedXVectorList *cached_x); cachedCharSeq get_cachedXRawList_elt( const cachedXVectorList *cached_x, int i ); cachedIntSeq get_cachedXIntegerList_elt( const cachedXVectorList *cached_x, int i ); cachedDoubleSeq get_cachedXDoubleList_elt( const cachedXVectorList *cached_x, int i ); void set_XVectorList_names(SEXP x, SEXP names); SEXP new_XRawList_from_tags( const char *classname, const char *element_type, SEXP tags, SEXP ranges, SEXP ranges_group ); SEXP new_XIntegerList_from_tags( const char *classname, const char *element_type, SEXP tags, SEXP ranges, SEXP ranges_group ); SEXP new_XDoubleList_from_tags( const char *classname, const char *element_type, SEXP tags, SEXP ranges, SEXP ranges_group ); SEXP new_XRawList_from_tag( const char *classname, const char *element_type, SEXP tag, SEXP ranges ); SEXP new_XIntegerList_from_tag( const char *classname, const char *element_type, SEXP tag, SEXP ranges ); SEXP new_XDoubleList_from_tag( const char *classname, const char *element_type, SEXP tag, SEXP ranges ); SEXP alloc_XRawList( const char *classname, const char *element_type, SEXP width ); SEXP alloc_XIntegerList( const char *classname, const char *element_type, SEXP width ); SEXP alloc_XDoubleList( const char *classname, const char *element_type, SEXP width ); SEXP new_XRawList_from_CharAEAE( const char *classname, const char *element_type, const CharAEAE *char_aeae, SEXP lkup ); SEXP new_XIntegerList_from_IntAEAE( const char *classname, const char *element_type, const IntAEAE *int_aeae ); XVector/inst/include/_XVector_stubs.c0000644000126300012640000002224412227065010021243 0ustar00biocbuildphs_compbio#include "XVector_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("XVector", "_" #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("XVector", "_" #stubname); \ fun args; \ return; \ } /* * Stubs for callables defined in Ocopy_byteblocks.c */ DEFINE_NOVALUE_CCALLABLE_STUB(Ocopy_byteblocks_from_i1i2, (int i1, int i2, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize), ( i1, i2, dest, dest_nblocks, src, src_nblocks, blocksize) ) DEFINE_NOVALUE_CCALLABLE_STUB(Ocopy_byteblocks_from_subscript, (const int *subset, int n, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize), ( subset, n, dest, dest_nblocks, src, src_nblocks, blocksize) ) DEFINE_NOVALUE_CCALLABLE_STUB(Ocopy_byteblocks_to_i1i2, (int i1, int i2, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize), ( i1, i2, dest, dest_nblocks, src, src_nblocks, blocksize) ) DEFINE_NOVALUE_CCALLABLE_STUB(Ocopy_byteblocks_to_subscript, (const int *subset, int n, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize), ( subset, n, dest, dest_nblocks, src, src_nblocks, blocksize) ) DEFINE_NOVALUE_CCALLABLE_STUB(Ocopy_bytes_from_i1i2_with_lkup, (int i1, int i2, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length), ( i1, i2, dest, dest_nbytes, src, src_nbytes, lkup, lkup_length) ) DEFINE_NOVALUE_CCALLABLE_STUB(Ocopy_bytes_from_subscript_with_lkup, (const int *subset, int n, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length), ( subset, n, dest, dest_nbytes, src, src_nbytes, lkup, lkup_length) ) DEFINE_NOVALUE_CCALLABLE_STUB(Ocopy_bytes_to_i1i2_with_lkup, (int i1, int i2, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length), ( i1, i2, dest, dest_nbytes, src, src_nbytes, lkup, lkup_length) ) DEFINE_NOVALUE_CCALLABLE_STUB(Ocopy_bytes_to_subscript_with_lkup, (const int *subset, int n, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length), ( subset, n, dest, dest_nbytes, src, src_nbytes, lkup, lkup_length) ) DEFINE_NOVALUE_CCALLABLE_STUB(Orevcopy_byteblocks_from_i1i2, (int i1, int i2, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize), ( i1, i2, dest, dest_nblocks, src, src_nblocks, blocksize) ) DEFINE_NOVALUE_CCALLABLE_STUB(Orevcopy_bytes_from_i1i2_with_lkup, (int i1, int i2, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length), ( i1, i2, dest, dest_nbytes, src, src_nbytes, lkup, lkup_length) ) DEFINE_NOVALUE_CCALLABLE_STUB(Ocopy_bytes_from_i1i2_to_complex, (int i1, int i2, Rcomplex *dest, int dest_nbytes, const char *src, int src_nbytes, const Rcomplex *lkup, int lkup_length), ( i1, i2, dest, dest_nbytes, src, src_nbytes, lkup, lkup_length) ) /* * Stubs for callables defined in SharedVector_class.c */ DEFINE_CCALLABLE_STUB(SEXP, new_SharedVector, (const char *classname, SEXP tag), ( classname, tag) ) DEFINE_CCALLABLE_STUB(SEXP, get_SharedVector_tag, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(int, get_SharedVector_length, (SEXP x), ( x) ) /* * Stubs for callables defined in XVector_class.c */ DEFINE_CCALLABLE_STUB(SEXP, get_XVector_shared, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(int, get_XVector_offset, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(int, get_XVector_length, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(SEXP, get_XVector_tag, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(cachedCharSeq, cache_XRaw, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(cachedIntSeq, cache_XInteger, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(cachedDoubleSeq, cache_XDouble, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(SEXP, new_XVector, (const char *classname, SEXP shared, int offset, int length), ( classname, shared, offset, length) ) DEFINE_CCALLABLE_STUB(SEXP, new_XRaw_from_tag, (const char *classname, SEXP tag), ( classname, tag) ) DEFINE_CCALLABLE_STUB(SEXP, new_XInteger_from_tag, (const char *classname, SEXP tag), ( classname, tag) ) DEFINE_CCALLABLE_STUB(SEXP, new_XDouble_from_tag, (const char *classname, SEXP tag), ( classname, tag) ) DEFINE_CCALLABLE_STUB(SEXP, alloc_XRaw, (const char *classname, int length), ( classname, length) ) DEFINE_CCALLABLE_STUB(SEXP, alloc_XInteger, (const char *classname, int length), ( classname, length) ) DEFINE_CCALLABLE_STUB(SEXP, alloc_XDouble, (const char *classname, int length), ( classname, length) ) /* * Stubs for callables defined in XVectorList_class.c */ DEFINE_CCALLABLE_STUB(int, get_XVectorList_length, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(SEXP, get_XVectorList_width, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(SEXP, get_XVectorList_names, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(cachedXVectorList, cache_XVectorList, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(int, get_cachedXVectorList_length, (const cachedXVectorList *cached_x), ( cached_x) ) DEFINE_CCALLABLE_STUB(cachedCharSeq, get_cachedXRawList_elt, (const cachedXVectorList *cached_x, int i), ( cached_x, i) ) DEFINE_CCALLABLE_STUB(cachedIntSeq, get_cachedXIntegerList_elt, (const cachedXVectorList *cached_x, int i), ( cached_x, i) ) DEFINE_CCALLABLE_STUB(cachedDoubleSeq, get_cachedXDoubleList_elt, (const cachedXVectorList *cached_x, int i), ( cached_x, i) ) DEFINE_NOVALUE_CCALLABLE_STUB(set_XVectorList_names, (SEXP x, SEXP names), ( x, names) ) DEFINE_CCALLABLE_STUB(SEXP, new_XRawList_from_tags, (const char *classname, const char *element_type, SEXP tags, SEXP ranges, SEXP ranges_group), ( classname, element_type, tags, ranges, ranges_group) ) DEFINE_CCALLABLE_STUB(SEXP, new_XIntegerList_from_tags, (const char *classname, const char *element_type, SEXP tags, SEXP ranges, SEXP ranges_group), ( classname, element_type, tags, ranges, ranges_group) ) DEFINE_CCALLABLE_STUB(SEXP, new_XDoubleList_from_tags, (const char *classname, const char *element_type, SEXP tags, SEXP ranges, SEXP ranges_group), ( classname, element_type, tags, ranges, ranges_group) ) DEFINE_CCALLABLE_STUB(SEXP, new_XRawList_from_tag, (const char *classname, const char *element_type, SEXP tag, SEXP ranges), ( classname, element_type, tag, ranges) ) DEFINE_CCALLABLE_STUB(SEXP, new_XIntegerList_from_tag, (const char *classname, const char *element_type, SEXP tag, SEXP ranges), ( classname, element_type, tag, ranges) ) DEFINE_CCALLABLE_STUB(SEXP, new_XDoubleList_from_tag, (const char *classname, const char *element_type, SEXP tag, SEXP ranges), ( classname, element_type, tag, ranges) ) DEFINE_CCALLABLE_STUB(SEXP, alloc_XRawList, (const char *classname, const char *element_type, SEXP width), ( classname, element_type, width) ) DEFINE_CCALLABLE_STUB(SEXP, alloc_XIntegerList, (const char *classname, const char *element_type, SEXP width), ( classname, element_type, width) ) DEFINE_CCALLABLE_STUB(SEXP, alloc_XDoubleList, (const char *classname, const char *element_type, SEXP width), ( classname, element_type, width) ) DEFINE_CCALLABLE_STUB(SEXP, new_XRawList_from_CharAEAE, (const char *classname, const char *element_type, const CharAEAE *char_aeae, SEXP lkup), ( classname, element_type, char_aeae, lkup) ) DEFINE_CCALLABLE_STUB(SEXP, new_XIntegerList_from_IntAEAE, (const char *classname, const char *element_type, const IntAEAE *int_aeae), ( classname, element_type, int_aeae) ) XVector/inst/unitTests/0000755000126300012640000000000012227065010016501 5ustar00biocbuildphs_compbioXVector/inst/unitTests/test_slice-methods.R0000644000126300012640000000103312227065010022420 0ustar00biocbuildphs_compbiotest_XDouble_slice <- function() { ## Use slice against an Rle as an easy test x <- c(0.2, 0.5, 1, 1, 1, 1.5, 1.5, -.5, -.5, -.5, 10.2, 10.3) r <- Rle(x) for (lower in c(-0.5, 0, 1.2, 5)) { double.slice <- slice(x, lower) rle.slice <- slice(r, lower) checkEquals(length(double.slice), length(rle.slice)) is.same <- sapply(1:length(double.slice), function(i) { d <- as.numeric(double.slice[[i]]) r <- as.numeric(rle.slice[[i]]) checkEqualsNumeric(d, r) }) checkTrue(all(is.same)) } } XVector/inst/unitTests/test_view-summarization-methods.R0000644000126300012640000000433012227065010025176 0ustar00biocbuildphs_compbiotest_XDoubleViews_equality <- function() { x <- rnorm(100) bounds <- IRanges(c(1, 20, 50, 80), width=c(5, 10, 15, 18)) bounds2 <- IRanges(c(10, 30, 50, 80), width=c(5, 8, 15, 18)) v <- Views(x, bounds) v2 <- Views(x, bounds2) checkTrue(all(v == v)) checkTrue(all((v != v2) == c(TRUE, TRUE, FALSE, FALSE))) } test_XDoubleViews_viewMins <- function() { x <- rnorm(100) bounds <- IRanges(c(1, 20, 50, 80), width=c(5, 10, 15, 18)) v <- Views(x, bounds) val <- viewMins(v) expect <- sapply(1:length(bounds), function(i) { min(x[start(bounds)[i]:end(bounds[i])]) }) checkEqualsNumeric(val, expect) } test_XDoubleViews_viewMaxs <- function() { x <- rnorm(100) bounds <- IRanges(c(1, 20, 50, 80), width=c(5, 10, 15, 18)) v <- Views(x, bounds) val <- viewMaxs(v) expect <- sapply(1:length(bounds), function(i) { max(x[start(bounds)[i]:end(bounds[i])]) }) checkEqualsNumeric(val, expect) } test_XDoubleViews_viewSums <- function() { x <- rnorm(100) bounds <- IRanges(c(1, 20, 50, 80), width=c(5, 10, 15, 18)) v <- Views(x, bounds) val <- viewSums(v) expect <- sapply(1:length(bounds), function(i) { sum(x[start(bounds)[i]:end(bounds[i])]) }) checkEqualsNumeric(val, expect) } test_XDoubleViews_viewMeans <- function() { x <- rnorm(100) bounds <- IRanges(c(1, 20, 50, 80), width=c(5, 10, 15, 18)) v <- Views(x, bounds) val <- viewMeans(v) expect <- sapply(1:length(bounds), function(i) { mean(x[start(bounds)[i]:end(bounds[i])]) }) checkEqualsNumeric(val, expect) } test_XDoubleViews_viewWhichMins <- function() { x <- rnorm(100) bounds <- IRanges(c(1, 20, 50, 80), width=c(5, 10, 15, 18)) v <- Views(x, bounds) val <- viewWhichMins(v) expect <- sapply(1:length(bounds), function(i) { which.min(x[start(bounds)[i]:end(bounds[i])]) + start(bounds)[i] - 1L }) checkIdentical(val, expect) } test_XDoubleViews_viewWhichMaxs <- function() { x <- rnorm(100) bounds <- IRanges(c(1, 20, 50, 80), width=c(5, 10, 15, 18)) v <- Views(x, bounds) val <- viewWhichMaxs(v) expect <- sapply(1:length(bounds), function(i) { which.max(x[start(bounds)[i]:end(bounds[i])]) + start(bounds)[i] - 1L }) checkIdentical(val, expect) } XVector/man/0000755000126300012640000000000012227065010014275 5ustar00biocbuildphs_compbioXVector/man/OnDiskRaw-class.Rd0000644000126300012640000000041612227065010017531 0ustar00biocbuildphs_compbio\name{OnDiskRaw-class} \docType{class} \alias{class:OnDiskRaw} \alias{OnDiskRaw-class} \alias{OnDiskRaw} \alias{length,OnDiskRaw-method} \title{OnDiskRaw objects} \description{ THIS IS A WORK-IN-PROGRESS! } \author{H. Pages} \keyword{methods} \keyword{classes} XVector/man/XDoubleViews-class.Rd0000644000126300012640000000704312227065010020253 0ustar00biocbuildphs_compbio\name{XDoubleViews-class} \docType{class} % Classes: \alias{class:XDoubleViews} \alias{XDoubleViews-class} \alias{XDoubleViews} % Constructors: \alias{Views,XDouble-method} \alias{Views,numeric-method} % Methods: \alias{show,XDoubleViews-method} \alias{==,XDoubleViews,XDoubleViews-method} \alias{==,XDoubleViews,XDouble-method} \alias{==,XDoubleViews,numeric-method} \alias{==,XDouble,XDoubleViews-method} \alias{==,numeric,XDoubleViews-method} \title{The XDoubleViews class} \description{ The XDoubleViews class is the basic container for storing a set of views (start/end locations) on the same XDouble object. } \details{ An XDoubleViews object contains a set of views (start/end locations) on the same \link{XDouble} object called "the subject numeric vector" or simply "the subject". Each view is defined by its start and end locations: both are integers such that start <= end. An XDoubleViews object is in fact a particular case of a \link[IRanges]{Views} object (the XDoubleViews class contains the \link[IRanges]{Views} class) so it can be manipulated in a similar manner: see \code{?\link[IRanges]{Views}} for more information. Note that two views can overlap and that a view can be "out of limits" i.e. it can start before the first element of the subject or/and end after its last element. } \section{Other methods}{ In the code snippets below, \code{x}, \code{object}, \code{e1} and \code{e2} are XDoubleViews objects, and \code{i} can be a numeric or logical vector. \describe{ \item{}{ \code{x[[i]]}: Extract a view as an \link{XDouble} object. \code{i} must be a single numeric value (a numeric vector of length 1). Can't be used for extracting a view that is "out of limits" (raise an error). The returned object has the same \link{XDouble} subtype as \code{subject(x)}. } \item{}{ \code{e1 == e2}: A vector of logicals indicating the result of the view by view comparison. The views in the shorter of the two XDoubleViews object being compared are recycled as necessary. } \item{}{ \code{e1 != e2}: Equivalent to \code{!(e1 == e2)}. } } } \author{ P. Aboyoun for the \code{XIntegerViews*} code, which was adapted to work over \code{XDouble}'s by S. Lianoglou } \seealso{ \link{view-summarization-methods}, \link[IRanges]{Views-class}, \link{XDouble-class}, \link{XIntegerViews-class} } \examples{ ## One standard way to create an XDoubleViews object is to use ## the Views() constructor: subject <- as(rnorm(6), "XDouble") v4 <- Views(subject, start=3:0, end=5:8) v4 subject(v4) length(v4) start(v4) end(v4) width(v4) ## Attach a comment to views #3 and #4: names(v4)[3:4] <- "out of limits" names(v4) ## A more programatical way to "tag" the "out of limits" views: idx <- start(v4) < 1 | end(v4) > length(subject(v4)) names(v4)[idx] <- "out of limits" ## Extract a view as an XDouble object: v4[[2]] ## It is an error to try to extract an "out of limits" view: \dontrun{ v4[[3]] # Error! } ## Here the first view doesn't even overlap with the subject: subject <- as(c(97, 97, 97, 45, 45, 98), "XDouble") Views(subject, start=-3:4, end=-3:4 + c(3:6, 6:3)) ## Some fast view* functionalities: x <- rnorm(55) bounds <- IRanges(c(1, 11, 35, 20), width=c(5, 10, 15, 28)) v <- Views(x, bounds) val <- viewMins(v) expect <- sapply(1:length(bounds), function(i) { min(x[start(bounds)[i]:end(bounds[i])]) }) stopifnot(all(val == expect)) } \keyword{methods} \keyword{classes} XVector/man/XIntegerViews-class.Rd0000644000126300012640000000656712227065010020450 0ustar00biocbuildphs_compbio\name{XIntegerViews-class} \docType{class} % Classes: \alias{class:XIntegerViews} \alias{XIntegerViews-class} \alias{XIntegerViews} % Constructors: \alias{Views,XInteger-method} \alias{Views,integer-method} % Methods: \alias{show,XIntegerViews-method} \alias{==,XIntegerViews,XIntegerViews-method} \alias{==,XIntegerViews,XInteger-method} \alias{==,XIntegerViews,integer-method} \alias{==,XInteger,XIntegerViews-method} \alias{==,integer,XIntegerViews-method} \title{The XIntegerViews class} \description{ The XIntegerViews class is the basic container for storing a set of views (start/end locations) on the same XInteger object. } \details{ An XIntegerViews object contains a set of views (start/end locations) on the same \link{XInteger} object called "the subject integer vector" or simply "the subject". Each view is defined by its start and end locations: both are integers such that start <= end. An XIntegerViews object is in fact a particular case of a \link[IRanges]{Views} object (the XIntegerViews class contains the \link[IRanges]{Views} class) so it can be manipulated in a similar manner: see \code{?\link[IRanges]{Views}} for more information. Note that two views can overlap and that a view can be "out of limits" i.e. it can start before the first element of the subject or/and end after its last element. } \section{Other methods}{ In the code snippets below, \code{x}, \code{object}, \code{e1} and \code{e2} are XIntegerViews objects, and \code{i} can be a numeric or logical vector. \describe{ \item{}{ \code{x[[i]]}: Extract a view as an \link{XInteger} object. \code{i} must be a single numeric value (a numeric vector of length 1). Can't be used for extracting a view that is "out of limits" (raise an error). The returned object has the same \link{XInteger} subtype as \code{subject(x)}. } \item{}{ \code{e1 == e2}: A vector of logicals indicating the result of the view by view comparison. The views in the shorter of the two XIntegerViews object being compared are recycled as necessary. } \item{}{ \code{e1 != e2}: Equivalent to \code{!(e1 == e2)}. } } } \author{P. Aboyoun} \seealso{ \link{view-summarization-methods}, \link[IRanges]{Views-class}, \link{XInteger-class}, \link{XDoubleViews-class} } \examples{ ## One standard way to create an XIntegerViews object is to use ## the Views() constructor: subject <- as(c(45, 67, 84, 67, 45, 78), "XInteger") v4 <- Views(subject, start=3:0, end=5:8) v4 subject(v4) length(v4) start(v4) end(v4) width(v4) ## Attach a comment to views #3 and #4: names(v4)[3:4] <- "out of limits" names(v4) ## A more programatical way to "tag" the "out of limits" views: idx <- start(v4) < 1 | end(v4) > length(subject(v4)) names(v4)[idx] <- "out of limits" ## Extract a view as an XInteger object: v4[[2]] ## It is an error to try to extract an "out of limits" view: \dontrun{ v4[[3]] # Error! } ## Here the first view doesn't even overlap with the subject: subject <- as(c(97, 97, 97, 45, 45, 98), "XInteger") Views(subject, start=-3:4, end=-3:4 + c(3:6, 6:3)) ## Views on a big XInteger subject: subject <- XInteger(99999, sample(99, 99999, replace=TRUE) - 50) v5 <- Views(subject, start=1:99*1000, end=1:99*1001) v5 v5[-1] v5[[5]] ## 31 adjacent views: successiveViews(subject, 40:10) } \keyword{methods} \keyword{classes} XVector/man/XRawList-class.Rd0000644000126300012640000000055612227065010017412 0ustar00biocbuildphs_compbio\name{XRawList-class} \docType{class} \alias{class:XRawList} \alias{XRawList-class} \alias{XRawList} \title{XRawList objects} \description{ THIS IS A WORK-IN-PROGRESS! An XRawList object is *conceptually* a list of \link{XRaw} objects. } \author{H. Pages} \seealso{ \link{XRaw-class}, \link{XVectorList-class} } \keyword{methods} \keyword{classes} XVector/man/XRawList-comparison.Rd0000644000126300012640000000556712227065010020466 0ustar00biocbuildphs_compbio\name{XRawList-comparison} \alias{XRawList-comparison} \alias{compare,XRawList,XRawList-method} \alias{==,XRawList,XRawList-method} \alias{<=,XRawList,XRawList-method} \alias{duplicated.XRawList} \alias{duplicated,XRawList-method} \alias{match,XRawList,XRawList-method} \alias{is.unsorted,XRawList-method} \alias{order,XRawList-method} \alias{rank,XRawList-method} \title{Comparing and ordering the list elements of XRawList objects} \description{ Methods for comparing and ordering the elements in one or more \link{XRawList} objects. } \usage{ ## Element-wise (aka "parallel") comparison of 2 XRawList objects ## -------------------------------------------------------------- \S4method{==}{XRawList,XRawList}(e1, e2) \S4method{<=}{XRawList,XRawList}(e1, e2) ## duplicated() ## ------------ \S4method{duplicated}{XRawList}(x, incomparables=FALSE, ...) ## match() ## ------- \S4method{match}{XRawList,XRawList}(x, table, nomatch=NA_integer_, incomparables=NULL) ## order() and related methods ## --------------------------- \S4method{is.unsorted}{XRawList}(x, na.rm=FALSE, strictly=FALSE) \S4method{order}{XRawList}(..., na.last=TRUE, decreasing=FALSE) \S4method{rank}{XRawList}(x, na.last=TRUE, ties.method=c("average", "first", "random", "max", "min")) ## Generalized element-wise (aka "parallel") comparison of 2 XRawList objects ## -------------------------------------------------------------------------- \S4method{compare}{XRawList,XRawList}(x, y) } \arguments{ \item{e1, e2, x, table, y}{ \link{XRawList} objects. } \item{incomparables}{ Not supported. } \item{...}{ For \code{duplicated}: currently no additional arguments are allowed. For \code{order}: additional \link{XRawList} objects used for breaking ties. } \item{nomatch}{ The value to be returned in the case when no match is found. It is coerced to an \code{integer}. } \item{na.rm, na.last}{ Ignored. } \item{strictly}{ \code{TRUE} or \code{FALSE}. Should the check be for \emph{strictly} increasing values? } \item{decreasing}{ \code{TRUE} or \code{FALSE}. } \item{ties.method}{ A character string specifying how ties are treated. Only \code{"first"} and \code{"min"} are supported for now. } } \details{ [TODO] } \author{H. Pages} \seealso{ \itemize{ \item The \link{XRawList} class. \item \link[IRanges]{Ranges-comparison} in the IRanges package for comparing and ordering ranges. \item \code{\link{==}}, \code{\link[BiocGenerics]{duplicated}}, \code{\link[BiocGenerics]{unique}}, \code{\link[BiocGenerics]{match}}, \code{\link{\%in\%}}, \code{\link[BiocGenerics]{order}}, \code{\link[BiocGenerics]{sort}}, \code{\link[BiocGenerics]{rank}} for general information about those functions. } } \examples{ ## TODO } \keyword{methods} XVector/man/XVector-class.Rd0000644000126300012640000001301212227065010017256 0ustar00biocbuildphs_compbio\name{XVector-class} \docType{class} % XVector class, functions and methods: \alias{class:XVector} \alias{XVector-class} \alias{XVector} \alias{length,XVector-method} \alias{c,XVector-method} \alias{[,XVector-method} \alias{subseq} \alias{subseq<-} \alias{subseq,XVector-method} \alias{subseq<-,XVector-method} \alias{as.numeric,XVector-method} \alias{show,XVector-method} \alias{==,XVector,XVector-method} % XRaw class, functions and methods: \alias{class:XRaw} \alias{XRaw-class} \alias{XRaw} \alias{coerce,raw,XRaw-method} \alias{coerce,raw,XVector-method} \alias{coerce,numeric,XRaw-method} \alias{as.raw,XRaw-method} \alias{as.integer,XRaw-method} \alias{as.vector,XRaw-method} % XInteger class, functions and methods: \alias{class:XInteger} \alias{XInteger-class} \alias{XInteger} \alias{coerce,numeric,XInteger-method} \alias{coerce,integer,XVector-method} \alias{as.integer,XInteger-method} \alias{as.vector,XInteger-method} % XDouble class, functions and methods: \alias{class:XDouble} \alias{XDouble-class} \alias{XDouble} \alias{XNumeric} \alias{coerce,numeric,XDouble-method} \alias{coerce,numeric,XVector-method} \alias{as.numeric,XDouble-method} \alias{as.vector,XDouble-method} \alias{show,XDouble-method} \title{XVector objects} \description{ The XVector virtual class is a general container for storing an "external vector". It inherits from the \link[IRanges]{Vector} class, which has a rich interface. The following classes derive directly from the XVector class: The XRaw class is a container for storing an "external raw vector" i.e. an external sequence of bytes (stored as char values at the C level). The XInteger class is a container for storing an "external integer vector" i.e. an external sequence of integer values (stored as int values at the C level). The XDouble class is a container for storing an "external double vector" i.e. an external sequence of numeric values (stored as double values at the C level). Also the \link[Biostrings]{XString} class defined in the Biostrings package. The purpose of the X* containers is to provide a "pass by address" semantic and also to avoid the overhead of copying the sequence data when a linear subsequence needs to be extracted. } \section{Additional Subsetting operations on XVector objects}{ In the code snippets below, \code{x} is an XVector object. \describe{ \item{}{ \code{subseq(x, start=NA, end=NA, width=NA)}: Extract the subsequence from \code{x} specified by \code{start}, \code{end} and \code{width}. The supplied start/end/width values are solved by a call to \code{solveUserSEW(length(x), start=start, end=end, width=width)} and therefore must be compliant with the rules of the SEW (Start/End/Width) interface (see \code{?solveUserSEW} for the details). A note about performance: \code{subseq} does NOT copy the sequence data of an XVector object. Hence it's very efficient and is therefore the recommended way to extract a linear subsequence (i.e. a set of consecutive elements) from an XVector object. For example, extracting a 100Mb subsequence from Human chromosome 1 (a 250Mb \link[Biostrings:DNAString-class]{DNAString} object) with \code{subseq} is (almost) instantaneous and has (almost) no memory footprint (the cost in time and memory does not depend on the length of the original sequence or on the length of the subsequence to extract). } \item{}{ \code{subseq(x, start=NA, end=NA, width=NA) <- value}: Replace the subsequence specified on the left (i.e. the subsequence in \code{x} specified by \code{start}, \code{end} and \code{width}) by \code{value}. \code{value} must belong to the same class as \code{x}, or to one of its subclasses, or must be \code{NULL}. This replacement method can modify the length of \code{x}, depending on how the length of the left subsequence compares to the length of \code{value}. It can be used for inserting elements in \code{x} (specify an empty left subsequence for this) or deleting elements from \code{x} (use a \code{NULL} right value for this). Unlike the extraction method above, this replacement method always copies the sequence data of \code{x} (even for XVector objects). NOTE: Only works for XRaw (and derived) objects for now. } } } \author{H. Pages} \seealso{ \link[IRanges]{Vector-class}, \link[Biostrings]{DNAString-class}, \link{XVectorList-class}, \link[IRanges]{Views-class}, \code{\link[IRanges]{solveUserSEW}}, \code{\link{compact}} } \examples{ ## --------------------------------------------------------------------- ## A. XRaw OBJECTS ## --------------------------------------------------------------------- x1 <- XRaw(4) # values are not initialized x1 x2 <- as(c(255, 255, 199), "XRaw") x2 y <- c(x1, x2, NULL, x1) # NULLs are ignored y subseq(y, start=-4) subseq(y, start=-4) <- x2 y ## --------------------------------------------------------------------- ## B. XInteger OBJECTS ## --------------------------------------------------------------------- x3 <- XInteger(12, val=c(-1:10)) x3 length(x3) ## Subsetting x4 <- XInteger(99999, val=sample(99, 99999, replace=TRUE) - 50) x4 subseq(x4, start=10) subseq(x4, start=-10) subseq(x4, start=-20, end=-10) subseq(x4, start=10, width=5) subseq(x4, end=10, width=5) subseq(x4, end=10, width=0) x3[length(x3):1] x3[length(x3):1, drop=FALSE] } \keyword{methods} \keyword{classes} XVector/man/XVector-internals.Rd0000644000126300012640000000341212227065010020153 0ustar00biocbuildphs_compbio\name{XVector internals} % SharedVector and SharedVector_Pool classes, functions and methods: \alias{class:SharedVector} \alias{SharedVector-class} \alias{SharedVector} \alias{class:SharedVector_Pool} \alias{SharedVector_Pool-class} \alias{SharedVector_Pool} \alias{show,externalptr-method} \alias{length,SharedVector-method} \alias{show,SharedVector-method} \alias{length,SharedVector_Pool-method} \alias{width,SharedVector_Pool-method} \alias{show,SharedVector_Pool-method} \alias{coerce,SharedVector,SharedVector_Pool-method} \alias{c,SharedVector_Pool-method} \alias{[,SharedVector_Pool-method} \alias{SharedVector.compare} \alias{SharedVector.copy} \alias{as.numeric,SharedVector-method} \alias{==,SharedVector,SharedVector-method} \alias{!=,SharedVector,SharedVector-method} % SharedRaw and SharedRaw_Pool classes, functions and methods: \alias{class:SharedRaw} \alias{SharedRaw-class} \alias{SharedRaw} \alias{class:SharedRaw_Pool} \alias{SharedRaw_Pool-class} \alias{SharedRaw_Pool} \alias{[[,SharedRaw_Pool-method} \alias{[[<-,SharedRaw_Pool-method} \alias{SharedRaw.readInts} \alias{SharedRaw.writeInts} \alias{SharedRaw.read} \alias{SharedRaw.write} \alias{SharedRaw.readComplexes} \alias{as.integer,SharedRaw-method} \alias{toString,SharedRaw-method} % SharedInteger class, functions and methods: \alias{class:SharedInteger} \alias{SharedInteger-class} \alias{SharedInteger} \alias{as.integer,SharedInteger-method} % SharedDouble class, functions and methods: \alias{class:SharedDouble} \alias{SharedDouble-class} \alias{SharedDouble} \alias{as.numeric,SharedDouble-method} \title{XVector internals} \description{ Objects, classes and methods defined in the XVector package that are not intended to be used directly. } \keyword{internal} \keyword{methods} \keyword{classes} XVector/man/XVectorList-class.Rd0000644000126300012640000000213712227065010020120 0ustar00biocbuildphs_compbio\name{XVectorList-class} \docType{class} \alias{class:GroupedIRanges} \alias{GroupedIRanges-class} \alias{GroupedIRanges} \alias{class:XVectorList} \alias{XVectorList-class} \alias{XVectorList} \alias{as.data.frame,GroupedIRanges-method} \alias{show,GroupedIRanges-method} \alias{[,GroupedIRanges-method} \alias{c,GroupedIRanges-method} \alias{length,XVectorList-method} \alias{width,XVectorList-method} \alias{elementLengths,XVectorList-method} \alias{names,XVectorList-method} \alias{names<-,XVectorList-method} \alias{[[,XVectorList-method} \alias{[,XVectorList-method} \alias{subseq,XVectorList-method} \alias{c,XVectorList-method} \alias{[[<-,XVectorList-method} \alias{endoapply,XVectorList-method} \alias{showAsCell,XVectorList-method} \alias{unlist_list_of_XVectorList} \alias{unsplit_list_of_XVectorList} \title{XVectorList objects} \description{ THIS IS A WORK-IN-PROGRESS! An XVectorList object is *conceptually* a list of \link{XVector} objects. } \author{H. Pages} \seealso{ \link{XVector-class}, \link{XRawList-class}, \code{\link{compact}} } \keyword{methods} \keyword{classes} XVector/man/compact-methods.Rd0000644000126300012640000001032012227065010017647 0ustar00biocbuildphs_compbio\name{compact} \alias{xvcopy} \alias{xvcopy,SharedVector-method} \alias{xvcopy,XVector-method} \alias{xvcopy,SharedVector_Pool-method} \alias{xvcopy,XRawList-method} \alias{compact} \alias{compact,ANY-method} \alias{compact,XVector-method} \alias{compact,XVectorList-method} \title{Object compaction} \description{ Compacting an object is modifying its internal representation in order to reduce its size in memory. } \usage{ compact(x, check=TRUE, ...) ## Internal compact() support function. Not intended to be called ## directly: xvcopy(x, start=NA, end=NA, width=NA, lkup=NULL, reverse=FALSE) } \arguments{ \item{x}{ For \code{compact}, the object to be compacted. \code{compact} accepts any R object. However, on most of them, \code{compact} won't do anything and will just return an object identical to \code{x}. See the Details section below. For \code{xvcopy}, a \link{SharedVector}, \link{XVector}, \link{SharedVector_Pool}, or \link{XRawList} vector. } \item{check}{ After compacting the individual slots of an S4 object, this argument is passed to \code{`slot<-`} when replacing the original value of a slot with the compacted value. } \item{...}{ Arguments to be passed to or from other methods. } \item{start, end, width, lkup, reverse}{ For internal use. } } \details{ The internal reorganization of the object should be transparent to the user i.e. \code{compact(x)} should "look" the same as \code{x}, or, more precisely, \code{x} and \code{compact(x)} should be interchangeable anywhere in the user's code. However, because they have different internal representations, we generally don't expect \code{identical(x, compact(x))} to be TRUE, even though most of the times they will, because there are only very few types of objects that \code{compact} actually knows how to reorganize internally. \code{compact} is a generic function. Here is how the default method works. By default \code{compact(x)} is obtained by compacting all the "components" in \code{x}. Only 2 kinds of objects are considered to have "components": lists (the components are the list elements), and S4 objects (the components are the slots). The other objects are not considered to have components, so, by default, \code{compact} does nothing on them. In particular, it does nothing on environments. Also the attributes of an object (other than the slots of an S4 object) are not considered to be "components" and therefore are not compacted. Note that, in the absence of specialized \code{compact} methods that actually know how to reorganize an object internally, the default method would visit the tree of all the components, sub-components, sub-sub-components etc of object \code{x} without actually modifying anything in \code{x}. So of course, specialized \code{compact} methods need to be defined for the objects that can *effectively* be compacted. Otherwise the \code{compact} function would be equivalent to the \code{identity} function! At the moment, 2 specialized \code{compact} methods are defined (in addition to the default method): one for \link{XVector} objects, and one for \link{XVectorList} objects. } \value{ An object equivalent to \code{x} but eventually smaller in memory. } \author{H. Pages} \seealso{ \link{XVector-class}, \link{XVectorList-class}, \code{\link{subseq}}, \code{\link[utils]{object.size}}, \code{\link[base]{save}} } \examples{ ## We illustrate the use of compact() on an XInteger vector (XInteger ## is one of the 3 concrete subclasses of the XVector virtual class): x <- XInteger(500000, sample(500000)) ## subseq() does NOT copy the data stored in an XVector object: y <- subseq(x, start=41, end=60) x@shared y@shared # same address object.size(x) object.size(y) # same size ## compact() copies the data, but only the data actually "used" by 'y': y0 <- compact(y) y0@shared # new address object.size(y0) # much smaller now! ## Compaction is particularly relevant when saving an object with ## external references like 'y': yfile <- file.path(tempdir(), "y.rda") save(y, file=yfile) file.info(yfile)$size y0file <- file.path(tempdir(), "y0.rda") save(y0, file=y0file) file.info(y0file)$size } \keyword{methods} XVector/man/intra-range-methods.Rd0000644000126300012640000000470112227065010020436 0ustar00biocbuildphs_compbio\name{intra-range-methods} \alias{intra-range-methods} \alias{narrow,XVectorList-method} \alias{threebands,XVectorList-method} \title{Intra range transformations of an XVectorList object} \description{ The \emph{intra range transformations} are a set of generic functions defined in the IRanges package. Only 2 of them have methods for XVectorList objects: \code{\link[IRanges]{narrow}} and \code{\link[IRanges]{threebands}}. This man page describes those 2 methods only. See \code{?`\link[IRanges]{inter-range-methods}`} for more information. } \usage{ \S4method{narrow}{XVectorList}(x, start=NA, end=NA, width=NA, use.names=TRUE) \S4method{threebands}{XVectorList}(x, start=NA, end=NA, width=NA) } \arguments{ \item{x}{ An \link{XVectorList} object. } \item{start, end, width}{ Vectors of integers, possibly with NAs. See the SEW (Start/End/Width) interface in the IRanges package for the details (\code{?\link[IRanges]{solveUserSEW}}). } \item{use.names}{ \code{TRUE} or \code{FALSE}. Should names be preserved? } } \details{ \code{narrow} is equivalent to \code{subset} on an \link{XVectorList} object. \code{threebands} extends the capability of \code{narrow} by returning the 3 \link{XVectorList} objects associated with the narrowing operation. The returned value \code{y} is a list of 3 \link{XVectorList} objects named \code{"left"}, \code{"middle"} and \code{"right"}. The middle component is obtained by calling \code{narrow} with the same arguments (except that names are dropped). The left and right components are also instances of the same class as \code{x} and they contain what has been removed on the left and right sides (respectively) of the original ranges during the narrowing. } \author{H. Pages} \seealso{ \itemize{ \item \link[IRanges]{intra-range-methods} in the IRanges package for intra range transformations. \item \code{\link[IRanges]{solveUserSEW}} in the IRanges package for the SEW (Start/End/Width) interface. \item The \link{XVectorList} class. } } \examples{ ## --------------------------------------------------------------------- ## narrow() ## --------------------------------------------------------------------- #TODO: show examples ## --------------------------------------------------------------------- ## threebands() ## --------------------------------------------------------------------- #TODO: show examples } \keyword{utilities} XVector/man/reverse-methods.Rd0000644000126300012640000000302612227065010017701 0ustar00biocbuildphs_compbio\name{reverse-methods} \alias{reverse-methods} \alias{reverse,SharedRaw-method} \alias{reverse,SharedVector_Pool-method} \alias{reverse,XVector-method} \alias{rev,XVector-method} \alias{reverse,XVectorList-method} \title{Reverse an XVector or XVectorList object} \description{ Methods for reversing an \link{XVector} or \link{XVectorList} object. } \usage{ \S4method{reverse}{XVector}(x, ...) \S4method{reverse}{XVectorList}(x, ...) } \arguments{ \item{x}{ An \link{XVector} or \link{XVectorList} object. } \item{...}{ Additional arguments. Currently ignored. } } \details{ On an \link{XVector} object, \code{reverse} and \code{\link[base]{rev}} are equivalent, i.e. they both reverse the order of their elements. On an \link{XVectorList} object, \code{reverse} reverses each element individually, without modifying the top-level order of the elements. It's equivalent to, but more efficient than, doing \code{endoapply(x, rev)}. } \value{ An object of the same class and length as the original object. } \seealso{ \link{XVector-class}, \link{XVectorList-class}, \code{\link[IRanges]{endoapply}}, \code{\link[base]{rev}} } \examples{ ## On an XInteger object: x <- as(12:-2, "XInteger") reverse(x) ## On an XIntegerViews object: v <- successiveViews(x, 1:5) v reverse(v) ## On an XVectorList object: if (require(Biostrings) && require(drosophila2probe)) { library(Biostrings) library(drosophila2probe) probes <- DNAStringSet(drosophila2probe) reverse(probes) } } \keyword{methods} \keyword{manip} XVector/man/slice-methods.Rd0000644000126300012640000000404512227065010017327 0ustar00biocbuildphs_compbio\name{slice-methods} \alias{slice-methods} \alias{slice,integer-method} \alias{slice,XInteger-method} \alias{slice,numeric-method} \alias{slice,XDouble-method} \title{Slice an XInteger or XDouble object} \description{ The \code{\link[IRanges]{slice}} methods for \link{XInteger} and \link{XDouble} objects create views corresponding to the indices where the data are within the specified bounds. The views are returned in a \link{XIntegerViews} or \link{XDoubleViews} object. } \usage{ \S4method{slice}{integer}(x, lower=-.Machine$integer.max, upper=.Machine$integer.max) \S4method{slice}{XInteger}(x, lower=-.Machine$integer.max, upper=.Machine$integer.max) \S4method{slice}{numeric}(x, lower=-Inf, upper=Inf, includeLower=TRUE, includeUpper=TRUE, rangesOnly=FALSE) \S4method{slice}{XDouble}(x, lower=-.Machine$double.xmax, upper=.Machine$double.xmax, includeLower=TRUE, includeUpper=TRUE, rangesOnly=FALSE) } \arguments{ \item{x}{ An \link{XInteger} or \link{XDouble} object. Alternatively, it can also be an integer or numeric vector. } \item{lower, upper}{ The lower and upper bounds for the slice. } \item{includeLower, includeUpper}{ Logical indicating whether or not the specified boundary is open or closed. } \item{rangesOnly}{ A logical indicating whether or not to drop the original data from the output. } } \value{ An \link{XIntegerViews} or \link{XDoubleViews} object if \code{rangesOnly=FALSE}. An \link[IRanges]{IRanges} object if \code{rangesOnly=TRUE}. } \author{P. Aboyoun} \seealso{ \itemize{ \item \link{view-summarization-methods} for summarizing the views returned by \code{slice}. \item \link[IRanges]{slice-methods} in the IRanges package for more \code{slice} methods. \item The \link{XInteger}, \link{XIntegerViews}, \link{XDouble}, and \link{XDoubleViews} classes. } } \examples{ vec <- as.integer(c(19, 5, 0, 8, 5)) slice(vec, lower=5, upper=8) set.seed(0) vec <- sample(24) slice(vec, lower=4, upper=16) } \keyword{methods} XVector/man/updateObject-methods.Rd0000644000126300012640000000220312227065010020633 0ustar00biocbuildphs_compbio\name{updateObject-methods} \alias{updateObject-methods} \alias{updateObject,XVector-method} \alias{updateObject,XIntegerViews-method} \title{Update an object of a class defined in the XVector package to its current class definition} \description{ The XVector package provides an extensive collection of \code{\link[BiocGenerics]{updateObject}} methods for updating almost any instance of a class defined in the package. } \usage{ ## Showing usage of method defined for XVector objects only (usage ## is the same for all methods). \S4method{updateObject}{XVector}(object, ..., verbose=FALSE) } \arguments{ \item{object}{ Object to be updated. Many (but not all) XVector classes are supported. If no specific method is available for the object, then the default method (defined in the BiocGenerics package) is used. See \code{?\link[BiocGenerics]{updateObject}} for a description of the default method. } \item{..., verbose}{ See \code{?\link[BiocGenerics]{updateObject}}. } } \value{ Returns a valid instance of \code{object}. } \seealso{ \code{\link[BiocGenerics]{updateObject}} } \keyword{manip} XVector/man/view-summarization-methods.Rd0000644000126300012640000000563612227065010022111 0ustar00biocbuildphs_compbio\name{view-summarization-methods} \alias{view-summarization-methods} \alias{viewMins,XIntegerViews-method} \alias{viewMins,XDoubleViews-method} \alias{viewMaxs,XIntegerViews-method} \alias{viewMaxs,XDoubleViews-method} \alias{viewSums,XIntegerViews-method} \alias{viewSums,XDoubleViews-method} \alias{viewMeans,XIntegerViews-method} \alias{viewMeans,XDoubleViews-method} \alias{viewWhichMins,XIntegerViews-method} \alias{viewWhichMins,XDoubleViews-method} \alias{viewWhichMaxs,XIntegerViews-method} \alias{viewWhichMaxs,XDoubleViews-method} \title{Summarize views on an XInteger or XDouble object} \description{ The \code{viewMins}, \code{viewMaxs}, \code{viewSums}, and \code{viewMeans} methods described here calculate respectively the minima, maxima, sums, and means of the views in an \link{XIntegerViews} or \link{XDoubleViews} object. } \usage{ ## "viewMins" methods: ## ------------------- \S4method{viewMins}{XIntegerViews}(x, na.rm=FALSE) \S4method{viewMins}{XDoubleViews}(x, na.rm=FALSE) ## "viewMaxs" methods: ## ------------------- \S4method{viewMaxs}{XIntegerViews}(x, na.rm=FALSE) \S4method{viewMaxs}{XDoubleViews}(x, na.rm=FALSE) ## "viewSums" methods: ## ------------------- \S4method{viewSums}{XIntegerViews}(x, na.rm=FALSE) \S4method{viewSums}{XDoubleViews}(x, na.rm=FALSE) ## "viewMeans" methods: ## -------------------- \S4method{viewMeans}{XIntegerViews}(x, na.rm=FALSE) \S4method{viewMeans}{XDoubleViews}(x, na.rm=FALSE) ## "viewWhichMins" methods: ## ------------------------ \S4method{viewWhichMins}{XIntegerViews}(x, na.rm=FALSE) \S4method{viewWhichMins}{XDoubleViews}(x, na.rm=FALSE) ## "viewWhichMaxs" methods: ## ------------------------ \S4method{viewWhichMaxs}{XIntegerViews}(x, na.rm=FALSE) \S4method{viewWhichMaxs}{XDoubleViews}(x, na.rm=FALSE) } \arguments{ \item{x}{ An \link{XIntegerViews} or \link{XDoubleViews} object. } \item{na.rm}{ Logical indicating whether or not to include missing values in the results. } } \value{ A numeric vector of the length of \code{x}. } \note{ For convenience, methods for \code{min}, \code{max}, \code{sum}, \code{mean}, \code{which.min} and \code{which.max} are provided as wrappers around the corresponding \code{view*} functions (which might be deprecated at some point). } \author{P. Aboyoun} \seealso{ \itemize{ \item \link{slice-methods} for slicing an \link{XInteger} or \link{XDouble} object. \item \link[IRanges]{view-summarization-methods} in the IRanges package for the view summarization generics. \item The \link{XIntegerViews} and \link{XDoubleViews} classes. } } \examples{ set.seed(0) vec <- sample(24) vec_views <- slice(vec, lower=4, upper=16) vec_views viewApply(vec_views, function(x) diff(as.integer(x))) viewMins(vec_views) viewMaxs(vec_views) viewSums(vec_views) viewMeans(vec_views) viewWhichMins(vec_views) viewWhichMaxs(vec_views) } \keyword{methods} \keyword{arith} XVector/src/0000755000126300012640000000000012227065007014317 5ustar00biocbuildphs_compbioXVector/src/IRanges_stubs.c0000644000126300012640000000003412227150112017220 0ustar00biocbuildphs_compbio#include "_IRanges_stubs.c" XVector/src/Ocopy_byteblocks.c0000644000126300012640000003343512227150112017775 0ustar00biocbuildphs_compbio#include "XVector.h" static int debug = 0; SEXP debug_Ocopy_byteblocks() { #ifdef DEBUG_XVECTOR 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; } static int translate_byte(char byte, const int *lkup, int lkup_length) { int key; key = (unsigned char) byte; return key >= lkup_length ? NA_INTEGER : lkup[key]; } /**************************************************************************** All the functions below are performing cyclic copy i.e. copy with recycling either at the destination ('dest') or at the source ('src'). In this file, "Ocopy" is an abbreviation for "cyclic copy". ****************************************************************************/ /* * Performs (in short): * dest[(i-i1) % dest_nblocks] <- src[i] for i1 <= i <= i2 * Details: * - Reads the linear subset of blocks from 'src' defined by 'i1', 'i2'. * - Writing is recycled in 'dest': it starts at its first block * and comes back to it after it reaches its last block. * - Doesn't do anything if i1 > i2. */ void _Ocopy_byteblocks_from_i1i2(int i1, int i2, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize) { const char *b; int i2next, i1max, q; size_t dest_size; if (i1 > i2) return; if (i1 < 0 || i2 >= src_nblocks) error("subscript out of bounds"); if (dest_nblocks <= 0) error("no destination to copy to"); i2next = i2 + 1; i1max = i2next - dest_nblocks; b = src + i1 * blocksize; dest_size = dest_nblocks * blocksize; while (i1 <= i1max) { memcpy(dest, b, dest_size); b += dest_size; i1 += dest_nblocks; } q = i2next - i1; if (q > 0) { /* Safe because q is always < dest_nblocks */ memcpy(dest, b, q * blocksize); warning("number of items to replace is not a multiple " "of replacement length"); } return; } /* * Performs (in short): * dest[k % dest_nblocks] <- src[subscript[k] - 1] for 0 <= k <= n * Details: * - Reads the blocks from 'src' that have the 1-based offsets passed * in 'subscript'. * - Writing is recycled in 'dest': it starts at its first block * and comes back to it after it reaches its last block. */ void _Ocopy_byteblocks_from_subscript(const int *subscript, int n, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize) { char *a; const char *b; int i, k, sub_k, z; if (n != 0 && dest_nblocks <= 0) error("no destination to copy to"); a = dest; for (i = k = 0; k < n; i++, k++) { sub_k = subscript[k]; if (sub_k == NA_INTEGER) error("NAs are not allowed in subscript"); sub_k--; if (sub_k < 0 || sub_k >= src_nblocks) error("subscript out of bounds"); if (i >= dest_nblocks) { i = 0; /* recycle */ a = dest; } b = src + sub_k * blocksize; for (z = 0; z < blocksize; z++) { *(a++) = *(b++); } } if (i != dest_nblocks) warning("number of items to replace is not a multiple " "of replacement length"); return; } /* * Performs (in short): * dest[i] <- src[(i-i1) % src_nblocks] for i1 <= i <= i2 * Details: * - Writes to the linear subset of blocks in 'dest' defined by 'i1', 'i2'. * - Reading is recycled in 'src': it starts at its first block * and comes back to it after it reaches its last block. * - Doesn't do anything if i1 > i2. */ void _Ocopy_byteblocks_to_i1i2(int i1, int i2, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize) { char *a; int i2next, i1max, q; size_t src_size; if (i1 > i2) return; if (i1 < 0 || i2 >= dest_nblocks) error("subscript out of bounds"); if (src_nblocks <= 0) error("no value provided"); i2next = i2 + 1; i1max = i2next - src_nblocks; a = dest + i1 * blocksize; src_size = src_nblocks * blocksize; while (i1 <= i1max) { memcpy(a, src, src_size); a += src_size; i1 += src_nblocks; } q = i2next - i1; if (q > 0) { /* Safe because q is always < src_nblocks */ memcpy(a, src, q * blocksize); warning("number of items to replace is not a multiple " "of replacement length"); } return; } /* * Performs (in short): * dest[subscript[k] - 1] <- src[k % src_nblocks] for 0 <= k <= n * Details: * - Writes the blocks in 'dest' that have the 1-based offsets passed * in 'subscript'. * - Reading is recycled in 'src': it starts at its first block * and comes back to it after it reaches its last block. */ void _Ocopy_byteblocks_to_subscript(const int *subscript, int n, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize) { char *a; const char *b; int j, k, sub_k, z; if (n != 0 && src_nblocks <= 0) error("no value provided"); b = src; for (j = k = 0; k < n; j++, k++) { sub_k = subscript[k]; if (sub_k == NA_INTEGER) error("NAs are not allowed in subscripted assignments"); sub_k--; if (sub_k < 0 || sub_k >= dest_nblocks) error("subscript out of bounds"); if (j >= src_nblocks) { j = 0; /* recycle */ b = src; } a = dest + sub_k * blocksize; for (z = 0; z < blocksize; z++) { *(a++) = *(b++); } } if (j != src_nblocks) warning("number of items to replace is not a multiple " "of replacement length"); return; } /* * Performs (in short): * dest[(i-i1) % dest_nbytes] <- tr(src[i]) for i1 <= i <= i2 * Note: tr() stands for translation. * Details: * - Reads the linear subset of bytes from 'src' defined by 'i1', 'i2'. * - Writing is recycled in 'dest': it starts at its first byte * and comes back to it after it reaches its last byte. * - Doesn't do anything if i1 > i2. */ void _Ocopy_bytes_from_i1i2_with_lkup(int i1, int i2, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length) { const char *b; char src_elt; int i, j, tmp; if (i1 > i2) return; if (i1 < 0 || i2 >= src_nbytes) error("subscript out of bounds"); if (dest_nbytes <= 0) error("no destination to copy to"); b = src + i1; j = 0; for (i = i1; i <= i2; i++) { if (j >= dest_nbytes) { /* recycle */ j = 0; } src_elt = *(b++); if (lkup != NULL) { tmp = translate_byte(src_elt, lkup, lkup_length); if (tmp == NA_INTEGER) error("key %d (char '%c') not in lookup table", (int) src_elt, src_elt); src_elt = tmp; } dest[j++] = src_elt; } if (j < dest_nbytes) warning("number of items to replace is not a multiple " "of replacement length"); return; } /* * Performs (in short): * dest[k % dest_nbytes] <- tr(src[subscript[k] - 1]) for 0 <= k <= n * Note: tr() stands for translation. * Details: * - Reads the bytes from 'src' that have the 1-based offsets passed * in 'subscript'. * - Writing is recycled in 'dest': it starts at its first byte * and comes back to it after it reaches its last byte. */ void _Ocopy_bytes_from_subscript_with_lkup(const int *subscript, int n, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length) { char src_elt; int j, k, sub_k, tmp; if (n != 0 && dest_nbytes <= 0) error("no destination to copy to"); j = 0; for (k = 0; k < n; k++) { if (j >= dest_nbytes) { /* recycle */ j = 0; } sub_k = subscript[k]; if (sub_k == NA_INTEGER) error("NAs are not allowed in subscript"); sub_k--; if (sub_k < 0 || sub_k >= src_nbytes) error("subscript out of bounds"); src_elt = src[sub_k]; if (lkup != NULL) { tmp = translate_byte(src_elt, lkup, lkup_length); if (tmp == NA_INTEGER) error("key %d (char '%c') not in lookup table", (int) src_elt, src_elt); src_elt = tmp; } dest[j++] = src_elt; } if (j < dest_nbytes) warning("number of items to replace is not a multiple " "of replacement length"); return; } /* * Performs (in short): * dest[i] <- tr(src[(i-i1) % src_nbytes]) for i1 <= i <= i2 * Note: tr() stands for translation. * Details: * - Writes to the linear subset of bytes in 'dest' defined by 'i1', 'i2'. * - Reading is recycled in 'src': it starts at its first byte * and comes back to it after it reaches its last byte. * - Doesn't do anything if i1 > i2. */ void _Ocopy_bytes_to_i1i2_with_lkup(int i1, int i2, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length) { char *a, src_elt; int i, j, tmp; if (i1 > i2) return; if (i1 < 0 || i2 >= dest_nbytes) error("subscript out of bounds"); if (src_nbytes <= 0) error("no value provided"); a = dest + i1; for (i = i1, j = 0; i <= i2; i++, j++) { if (j >= src_nbytes) { /* recycle */ j = 0; } src_elt = src[j]; if (lkup != NULL) { tmp = translate_byte(src_elt, lkup, lkup_length); if (tmp == NA_INTEGER) error("key %d (char '%c') not in lookup table", (int) src_elt, src_elt); src_elt = tmp; } *(a++) = src_elt; } if (j < src_nbytes) warning("number of items to replace is not a multiple " "of replacement length"); return; } /* * Performs (in short): * dest[subscript[k] - 1] <- tr(src[k % src_nbytes]) for 0 <= k <= n * Note: tr() stands for translation. * Details: * - Writes the bytes in 'dest' that have the 1-based offsets passed * in 'subscript'. * - Reading is recycled in 'src': it starts at its first byte * and comes back to it after it reaches its last byte. */ void _Ocopy_bytes_to_subscript_with_lkup(const int *subscript, int n, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length) { char src_elt; int j, k, sub_k, tmp; if (n != 0 && src_nbytes <= 0) error("no value provided"); for (k = j = 0; k < n; k++, j++) { if (j >= src_nbytes) { /* recycle */ j = 0; } sub_k = subscript[k]; if (sub_k == NA_INTEGER) error("NAs are not allowed in subscripted assignments"); sub_k--; if (sub_k < 0 || sub_k >= dest_nbytes) error("subscript out of bounds"); src_elt = src[j]; if (lkup != NULL) { tmp = translate_byte(src_elt, lkup, lkup_length); if (tmp == NA_INTEGER) error("key %d (char '%c') not in lookup table", (int) src_elt, src_elt); src_elt = tmp; } dest[sub_k] = src_elt; } if (j < src_nbytes) warning("number of items to replace is not a multiple " "of replacement length"); return; } /* * Performs (in short): * dest[(dest_nblocks-1-(i-i1)) % dest_nblocks] <- src[i] for i1 <= i <= i2 * Note: the order of the blocks is reversed during the copy. * Details: * - Reads the linear subset of blocks from 'src' defined by 'i1', 'i2'. * - Writing is recycled in 'dest': it starts at its last block * and comes back to it after it reaches its first block. * - Doesn't do anything if i1 > i2. */ void _Orevcopy_byteblocks_from_i1i2(int i1, int i2, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize) { char *a; const char *b; int i, j, z; if (i1 > i2) return; if (i1 < 0 || i2 >= src_nblocks) error("subscript out of bounds"); if (dest_nblocks <= 0) error("no destination to copy to"); b = src + i1 * blocksize; for (i = i1, j = dest_nblocks - 1; i <= i2; i++, j--) { if (j < 0) { /* recycle */ j = dest_nblocks - 1; } a = dest + j * blocksize; for (z = 0; z < blocksize; z++) { *(a++) = *(b++); } } if (j >= 0) warning("number of items to replace is not a multiple " "of replacement length"); return; } /* * Performs (in short): * dest[(dest_nbytes-1-(i-i1)) % dest_nbytes] <- tr(src[i]) for i1 <= i <= i2 * Notes: - tr() stands for translation. * - the order of the bytes is reversed during the copy. * Details: * - Reads the linear subset of bytes from 'src' defined by 'i1', 'i2'. * - Writing is recycled in 'dest': it starts at its last byte * and comes back to it after it reaches its first byte. * - Doesn't do anything if i1 > i2. */ void _Orevcopy_bytes_from_i1i2_with_lkup(int i1, int i2, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length) { const char *b; char src_elt; int i, j, tmp; if (i1 > i2) return; if (i1 < 0 || i2 >= src_nbytes) error("subscript out of bounds"); if (dest_nbytes <= 0) error("no destination to copy to"); b = src + i1; j = dest_nbytes - 1; for (i = i1; i <= i2; i++) { if (j < 0) { /* recycle */ j = dest_nbytes - 1; } src_elt = *(b++); if (lkup != NULL) { tmp = translate_byte(src_elt, lkup, lkup_length); if (tmp == NA_INTEGER) error("key %d (char '%c') not in lookup table", (int) src_elt, src_elt); src_elt = tmp; } dest[j--] = src_elt; } if (j >= 0) warning("number of items to replace is not a multiple " "of replacement length"); return; } /* * Performs (in short): * dest[(i-i1) % dest_nbytes] <- toComplex(src[i]) for i1 <= i <= i2 * Note: toComplex() stands for conversion to complex values. * Details: * - Reads the linear subset of bytes from 'src' defined by 'i1', 'i2'. * - Writing is recycled in 'dest': it starts at its first element * and comes back to it after it reaches its last element. * - Doesn't do anything if i1 > i2. */ void _Ocopy_bytes_from_i1i2_to_complex(int i1, int i2, Rcomplex *dest, int dest_nbytes, const char *src, int src_nbytes, const Rcomplex *lkup, int lkup_length) { const char *b; char src_val; int i, j, lkup_key; Rcomplex lkup_val; if (i1 > i2) return; if (i1 < 0 || i2 >= src_nbytes) error("subscript out of bounds"); if (dest_nbytes <= 0) error("no destination to copy to"); b = src + i1; for (i = i1, j = 0; i <= i2; i++, j++) { if (j >= dest_nbytes) { /* recycle */ j = 0; } src_val = *(b++); lkup_key = (unsigned char) src_val; if (lkup_key >= lkup_length || ISNA((lkup_val = lkup[lkup_key]).r) || ISNA(lkup_val.i)) { error("key %d not in lookup table", lkup_key); } dest[j] = lkup_val; } if (j < dest_nbytes) warning("number of items to replace is not a multiple " "of replacement length"); return; } XVector/src/R_init_XVector.c0000644000126300012640000001310212227150112017346 0ustar00biocbuildphs_compbio#include "XVector.h" #define CALLMETHOD_DEF(fun, numArgs) {#fun, (DL_FUNC) &fun, numArgs} #define REGISTER_CCALLABLE(fun) \ R_RegisterCCallable("XVector", #fun, (DL_FUNC) &fun) static const R_CallMethodDef callMethods[] = { /* Ocopy_byteblocks.c */ CALLMETHOD_DEF(debug_Ocopy_byteblocks, 0), /* SharedVector_class.c */ CALLMETHOD_DEF(debug_SharedVector_class, 0), CALLMETHOD_DEF(address_asSTRSXP, 1), CALLMETHOD_DEF(externalptr_new, 0), CALLMETHOD_DEF(externalptr_get_tag, 1), CALLMETHOD_DEF(externalptr_set_tag, 2), CALLMETHOD_DEF(externalptr_tagtype, 1), CALLMETHOD_DEF(externalptr_taglength, 1), CALLMETHOD_DEF(externalptr_show, 1), CALLMETHOD_DEF(SharedVector_address0, 1), CALLMETHOD_DEF(SharedVector_memcmp, 5), CALLMETHOD_DEF(SharedVector_Ocopy_from_start, 6), CALLMETHOD_DEF(SharedVector_Ocopy_from_subscript, 4), CALLMETHOD_DEF(SharedVector_mcopy, 7), /* SharedRaw_class.c */ CALLMETHOD_DEF(debug_SharedRaw_class, 0), CALLMETHOD_DEF(SharedRaw_new, 2), CALLMETHOD_DEF(SharedRaw_read_chars_from_i1i2, 3), CALLMETHOD_DEF(SharedRaw_read_chars_from_subscript, 2), CALLMETHOD_DEF(SharedRaw_write_chars_to_i1i2, 4), CALLMETHOD_DEF(SharedRaw_write_chars_to_subscript, 3), CALLMETHOD_DEF(SharedRaw_read_ints_from_i1i2, 3), CALLMETHOD_DEF(SharedRaw_read_ints_from_subscript, 2), CALLMETHOD_DEF(SharedRaw_write_ints_to_i1i2, 4), CALLMETHOD_DEF(SharedRaw_write_ints_to_subscript, 3), CALLMETHOD_DEF(SharedRaw_read_enc_chars_from_i1i2, 4), CALLMETHOD_DEF(SharedRaw_read_enc_chars_from_subscript, 3), CALLMETHOD_DEF(SharedRaw_write_enc_chars_to_i1i2, 5), CALLMETHOD_DEF(SharedRaw_write_enc_chars_to_subscript, 4), CALLMETHOD_DEF(SharedRaw_read_complexes_from_i1i2, 4), CALLMETHOD_DEF(SharedRaw_read_complexes_from_subscript, 3), /* SharedInteger_class.c */ CALLMETHOD_DEF(debug_SharedInteger_class, 0), CALLMETHOD_DEF(SharedInteger_new, 2), CALLMETHOD_DEF(SharedInteger_get_show_string, 1), CALLMETHOD_DEF(SharedInteger_read_ints_from_i1i2, 3), CALLMETHOD_DEF(SharedInteger_read_ints_from_subscript, 2), CALLMETHOD_DEF(SharedInteger_write_ints_to_i1i2, 4), CALLMETHOD_DEF(SharedInteger_write_ints_to_subscript, 3), /* SharedDouble_class.c */ CALLMETHOD_DEF(debug_SharedDouble_class, 0), CALLMETHOD_DEF(SharedDouble_new, 2), CALLMETHOD_DEF(SharedDouble_get_show_string, 1), CALLMETHOD_DEF(SharedDouble_read_nums_from_i1i2, 3), CALLMETHOD_DEF(SharedDouble_read_nums_from_subscript, 2), CALLMETHOD_DEF(SharedDouble_write_nums_to_i1i2, 4), CALLMETHOD_DEF(SharedDouble_write_nums_to_subscript, 3), /* XVector_class.c */ CALLMETHOD_DEF(debug_XVector_class, 0), /* XVectorList_class.c */ CALLMETHOD_DEF(debug_XVectorList_class, 0), /* XRawList_comparison.c */ CALLMETHOD_DEF(XRawList_compare, 2), CALLMETHOD_DEF(XRawList_is_unsorted, 2), CALLMETHOD_DEF(XRawList_order, 2), CALLMETHOD_DEF(XRawList_rank, 2), CALLMETHOD_DEF(XRawList_match_hash, 3), CALLMETHOD_DEF(XRawList_selfmatch_hash, 1), /* slice_methods.c */ CALLMETHOD_DEF(XInteger_slice, 3), CALLMETHOD_DEF(XDouble_slice, 5), /* view_summarization_methods.c */ CALLMETHOD_DEF(XIntegerViews_summary1, 3), CALLMETHOD_DEF(XDoubleViews_summary1, 3), CALLMETHOD_DEF(XIntegerViews_summary2, 3), CALLMETHOD_DEF(XDoubleViews_summary2, 3), {NULL, NULL, 0} }; void R_init_XVector(DllInfo *info) { R_registerRoutines(info, NULL, callMethods, NULL, NULL); /* Ocopy_byteblocks.c */ REGISTER_CCALLABLE(_Ocopy_byteblocks_from_i1i2); REGISTER_CCALLABLE(_Ocopy_byteblocks_from_subscript); REGISTER_CCALLABLE(_Ocopy_byteblocks_to_i1i2); REGISTER_CCALLABLE(_Ocopy_byteblocks_to_subscript); REGISTER_CCALLABLE(_Ocopy_bytes_from_i1i2_with_lkup); REGISTER_CCALLABLE(_Ocopy_bytes_from_subscript_with_lkup); REGISTER_CCALLABLE(_Ocopy_bytes_to_i1i2_with_lkup); REGISTER_CCALLABLE(_Ocopy_bytes_to_subscript_with_lkup); REGISTER_CCALLABLE(_Orevcopy_byteblocks_from_i1i2); REGISTER_CCALLABLE(_Orevcopy_bytes_from_i1i2_with_lkup); REGISTER_CCALLABLE(_Ocopy_bytes_from_i1i2_to_complex); /* SharedVector_class.c */ REGISTER_CCALLABLE(_new_SharedVector); REGISTER_CCALLABLE(_get_SharedVector_tag); REGISTER_CCALLABLE(_get_SharedVector_length); /* XVector_class.c */ REGISTER_CCALLABLE(_get_XVector_shared); REGISTER_CCALLABLE(_get_XVector_offset); REGISTER_CCALLABLE(_get_XVector_length); REGISTER_CCALLABLE(_get_XVector_tag); REGISTER_CCALLABLE(_cache_XRaw); REGISTER_CCALLABLE(_cache_XInteger); REGISTER_CCALLABLE(_cache_XDouble); REGISTER_CCALLABLE(_new_XVector); REGISTER_CCALLABLE(_new_XRaw_from_tag); REGISTER_CCALLABLE(_new_XInteger_from_tag); REGISTER_CCALLABLE(_new_XDouble_from_tag); REGISTER_CCALLABLE(_alloc_XRaw); REGISTER_CCALLABLE(_alloc_XInteger); REGISTER_CCALLABLE(_alloc_XDouble); /* XVectorList_class.c */ REGISTER_CCALLABLE(_get_XVectorList_length); REGISTER_CCALLABLE(_get_XVectorList_width); REGISTER_CCALLABLE(_get_XVectorList_names); REGISTER_CCALLABLE(_cache_XVectorList); REGISTER_CCALLABLE(_get_cachedXVectorList_length); REGISTER_CCALLABLE(_get_cachedXRawList_elt); REGISTER_CCALLABLE(_get_cachedXIntegerList_elt); REGISTER_CCALLABLE(_get_cachedXDoubleList_elt); REGISTER_CCALLABLE(_set_XVectorList_names); REGISTER_CCALLABLE(_new_XRawList_from_tags); REGISTER_CCALLABLE(_new_XIntegerList_from_tags); REGISTER_CCALLABLE(_new_XDoubleList_from_tags); REGISTER_CCALLABLE(_new_XRawList_from_tag); REGISTER_CCALLABLE(_new_XIntegerList_from_tag); REGISTER_CCALLABLE(_new_XDoubleList_from_tag); REGISTER_CCALLABLE(_alloc_XRawList); REGISTER_CCALLABLE(_alloc_XIntegerList); REGISTER_CCALLABLE(_alloc_XDoubleList); REGISTER_CCALLABLE(_new_XRawList_from_CharAEAE); REGISTER_CCALLABLE(_new_XIntegerList_from_IntAEAE); return; } XVector/src/SharedDouble_class.c0000644000126300012640000000636212227150112020210 0ustar00biocbuildphs_compbio/**************************************************************************** * Low-level manipulation of SharedDouble objects * * Author: Herve Pages * ****************************************************************************/ #include "XVector.h" static int debug = 0; SEXP debug_SharedDouble_class() { #ifdef DEBUG_XVECTOR 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; } SEXP SharedDouble_new(SEXP length, SEXP val) { SEXP tag, ans; int tag_length, i; double val0; tag_length = INTEGER(length)[0]; if (val == R_NilValue) { PROTECT(tag = NEW_NUMERIC(tag_length)); } else if (LENGTH(val) == 1) { PROTECT(tag = NEW_NUMERIC(tag_length)); val0 = REAL(val)[0]; for (i = 0; i < tag_length; i++) REAL(tag)[i] = val0; } else if (LENGTH(val) == tag_length) { PROTECT(tag = duplicate(val)); } else { error("when 'val' is not a single value, its length must " "be equal to the value of the 'length' argument"); } PROTECT(ans = _new_SharedVector("SharedDouble", tag)); UNPROTECT(2); return ans; } SEXP SharedDouble_get_show_string(SEXP x) { SEXP tag; int tag_length; char buf[100]; /* should be enough... */ tag = _get_SharedVector_tag(x); tag_length = LENGTH(tag); snprintf(buf, sizeof(buf), "%d-number SharedDouble object (data starting at memory address %p)", tag_length, REAL(tag)); return mkString(buf); } /* ========================================================================== * Read/write numerics to a SharedDouble object * -------------------------------------------------------------------------- */ SEXP SharedDouble_read_nums_from_i1i2(SEXP src, SEXP imin, SEXP imax) { SEXP src_tag, ans; int i1, i2, n; src_tag = _get_SharedVector_tag(src); i1 = INTEGER(imin)[0] - 1; i2 = INTEGER(imax)[0] - 1; n = i2 - i1 + 1; PROTECT(ans = NEW_NUMERIC(n)); _Ocopy_byteblocks_from_i1i2(i1, i2, (char *) REAL(ans), LENGTH(ans), (char *) REAL(src_tag), LENGTH(src_tag), sizeof(double)); UNPROTECT(1); return ans; } SEXP SharedDouble_read_nums_from_subscript(SEXP src, SEXP subscript) { SEXP src_tag, ans; int n; src_tag = _get_SharedVector_tag(src); n = LENGTH(subscript); PROTECT(ans = NEW_NUMERIC(n)); _Ocopy_byteblocks_from_subscript(INTEGER(subscript), n, (char *) REAL(ans), n, (char *) REAL(src_tag), LENGTH(src_tag), sizeof(double)); UNPROTECT(1); return ans; } /* * 'val' must be a numeric vector. */ SEXP SharedDouble_write_nums_to_i1i2(SEXP dest, SEXP imin, SEXP imax, SEXP val) { SEXP dest_tag; int i1, i2; dest_tag = _get_SharedVector_tag(dest); i1 = INTEGER(imin)[0] - 1; i2 = INTEGER(imax)[0] - 1; _Ocopy_byteblocks_to_i1i2(i1, i2, (char *) REAL(dest_tag), LENGTH(dest_tag), (char *) REAL(val), LENGTH(val), sizeof(double)); return dest; } SEXP SharedDouble_write_nums_to_subscript(SEXP dest, SEXP subscript, SEXP val) { SEXP dest_tag; dest_tag = _get_SharedVector_tag(dest); _Ocopy_byteblocks_to_subscript(INTEGER(subscript), LENGTH(subscript), (char *) REAL(dest_tag), LENGTH(dest_tag), (char *) REAL(val), LENGTH(val), sizeof(double)); return dest; } XVector/src/SharedInteger_class.c0000644000126300012640000000641412227150112020371 0ustar00biocbuildphs_compbio/**************************************************************************** * Low-level manipulation of SharedInteger objects * * Author: Herve Pages * ****************************************************************************/ #include "XVector.h" static int debug = 0; SEXP debug_SharedInteger_class() { #ifdef DEBUG_XVECTOR 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; } SEXP SharedInteger_new(SEXP length, SEXP val) { SEXP tag, ans; int tag_length, i, val0; tag_length = INTEGER(length)[0]; if (val == R_NilValue) { PROTECT(tag = NEW_INTEGER(tag_length)); } else if (LENGTH(val) == 1) { PROTECT(tag = NEW_INTEGER(tag_length)); val0 = INTEGER(val)[0]; for (i = 0; i < tag_length; i++) INTEGER(tag)[i] = val0; } else if (LENGTH(val) == tag_length) { PROTECT(tag = duplicate(val)); } else { error("when 'val' is not a single value, its length must " "be equal to the value of the 'length' argument"); } PROTECT(ans = _new_SharedVector("SharedInteger", tag)); UNPROTECT(2); return ans; } SEXP SharedInteger_get_show_string(SEXP x) { SEXP tag; int tag_length; char buf[100]; /* should be enough... */ tag = _get_SharedVector_tag(x); tag_length = LENGTH(tag); snprintf(buf, sizeof(buf), "%d-integer SharedInteger object (data starting at memory address %p)", tag_length, INTEGER(tag)); return mkString(buf); } /* ========================================================================== * Read/write integers to a SharedInteger object. * -------------------------------------------------------------------------- */ SEXP SharedInteger_read_ints_from_i1i2(SEXP src, SEXP imin, SEXP imax) { SEXP src_tag, tag; int i1, i2, n; src_tag = _get_SharedVector_tag(src); i1 = INTEGER(imin)[0] - 1; i2 = INTEGER(imax)[0] - 1; n = i2 - i1 + 1; PROTECT(tag = NEW_INTEGER(n)); _Ocopy_byteblocks_from_i1i2(i1, i2, (char *) INTEGER(tag), LENGTH(tag), (char *) INTEGER(src_tag), LENGTH(src_tag), sizeof(int)); UNPROTECT(1); return tag; } SEXP SharedInteger_read_ints_from_subscript(SEXP src, SEXP subscript) { SEXP src_tag, tag; int n; src_tag = _get_SharedVector_tag(src); n = LENGTH(subscript); PROTECT(tag = NEW_INTEGER(n)); _Ocopy_byteblocks_from_subscript(INTEGER(subscript), n, (char *) INTEGER(tag), n, (char *) INTEGER(src_tag), LENGTH(src_tag), sizeof(int)); UNPROTECT(1); return tag; } /* * 'val' must be an integer vector. */ SEXP SharedInteger_write_ints_to_i1i2(SEXP dest, SEXP imin, SEXP imax, SEXP val) { SEXP dest_tag; int i1, i2; dest_tag = _get_SharedVector_tag(dest); i1 = INTEGER(imin)[0] - 1; i2 = INTEGER(imax)[0] - 1; _Ocopy_byteblocks_to_i1i2(i1, i2, (char *) INTEGER(dest_tag), LENGTH(dest_tag), (char *) INTEGER(val), LENGTH(val), sizeof(int)); return dest; } SEXP SharedInteger_write_ints_to_subscript(SEXP dest, SEXP subscript, SEXP val) { SEXP dest_tag; dest_tag = _get_SharedVector_tag(dest); _Ocopy_byteblocks_to_subscript(INTEGER(subscript), LENGTH(subscript), (char *) INTEGER(dest_tag), LENGTH(dest_tag), (char *) INTEGER(val), LENGTH(val), sizeof(int)); return dest; } XVector/src/SharedRaw_class.c0000644000126300012640000002315612227150112017527 0ustar00biocbuildphs_compbio/**************************************************************************** * Low-level manipulation of SharedRaw objects * * Author: Herve Pages * ****************************************************************************/ #include "XVector.h" #include "IRanges_interface.h" static int debug = 0; SEXP debug_SharedRaw_class() { #ifdef DEBUG_XVECTOR 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; } SEXP SharedRaw_new(SEXP length, SEXP val) { SEXP tag, ans; int tag_length, i; Rbyte val0; tag_length = INTEGER(length)[0]; if (val == R_NilValue) { PROTECT(tag = NEW_RAW(tag_length)); } else if (LENGTH(val) == 1) { PROTECT(tag = NEW_RAW(tag_length)); val0 = RAW(val)[0]; for (i = 0; i < tag_length; i++) RAW(tag)[i] = val0; } else if (LENGTH(val) == tag_length) { PROTECT(tag = duplicate(val)); } else { error("when 'val' is not a single value, its length must " "be equal to the value of the 'length' argument"); } PROTECT(ans = _new_SharedVector("SharedRaw", tag)); UNPROTECT(2); return ans; } /* ========================================================================== * Read/write chars from/to a SharedRaw object. * All the functions in this group assume that sizeof(Rbyte) == sizeof(char). * -------------------------------------------------------------------------- */ /* * Return a single string (character vector of length 1). * From R: * x <- SharedRaw(15) * x[] < "Hello" * .Call("SharedRaw_read_chars_from_i1i2", x, 2:2, 4:4, PACKAGE="XVector") */ SEXP SharedRaw_read_chars_from_i1i2(SEXP src, SEXP imin, SEXP imax) { SEXP src_tag; int i1, i2, n; CharAE dest; src_tag = _get_SharedVector_tag(src); i1 = INTEGER(imin)[0] - 1; i2 = INTEGER(imax)[0] - 1; n = i2 - i1 + 1; dest = new_CharAE(n + 1); dest.elts[n] = '\0'; /* assumes that sizeof(Rbyte) == sizeof(char) */ _Ocopy_byteblocks_from_i1i2(i1, i2, dest.elts, n, (char *) RAW(src_tag), LENGTH(src_tag), sizeof(char)); return mkString(dest.elts); } SEXP SharedRaw_read_chars_from_subscript(SEXP src, SEXP subscript) { SEXP src_tag; int n; CharAE dest; src_tag = _get_SharedVector_tag(src); n = LENGTH(subscript); dest = new_CharAE(n + 1); dest.elts[n] = '\0'; /* assumes that sizeof(Rbyte) == sizeof(char) */ _Ocopy_byteblocks_from_subscript(INTEGER(subscript), n, dest.elts, n, (char *) RAW(src_tag), LENGTH(src_tag), sizeof(char)); return mkString(dest.elts); } /* * 'string' must be a non-empty single string (character vector of length 1). */ SEXP SharedRaw_write_chars_to_i1i2(SEXP dest, SEXP imin, SEXP imax, SEXP string) { SEXP dest_tag, src; int i1, i2; dest_tag = _get_SharedVector_tag(dest); i1 = INTEGER(imin)[0] - 1; i2 = INTEGER(imax)[0] - 1; src = STRING_ELT(string, 0); /* assumes that sizeof(Rbyte) == sizeof(char) */ _Ocopy_byteblocks_to_i1i2(i1, i2, (char *) RAW(dest_tag), LENGTH(dest_tag), CHAR(src), LENGTH(src), sizeof(char)); return dest; } SEXP SharedRaw_write_chars_to_subscript(SEXP dest, SEXP subscript, SEXP string) { SEXP dest_tag, src; dest_tag = _get_SharedVector_tag(dest); src = STRING_ELT(string, 0); /* assumes that sizeof(Rbyte) == sizeof(char) */ _Ocopy_byteblocks_to_subscript(INTEGER(subscript), LENGTH(subscript), (char *) RAW(dest_tag), LENGTH(dest_tag), CHAR(src), LENGTH(src), sizeof(char)); return dest; } /* ========================================================================== * Read/write integers from/to a SharedRaw object * -------------------------------------------------------------------------- */ /* * Return an integer vector of length 'imax' - 'imin' + 1. * From R: * x <- SharedRaw(30) * .Call("SharedRaw_read_ints_from_i1i2", x, 20:20, 25:25, PACKAGE="XVector") */ SEXP SharedRaw_read_ints_from_i1i2(SEXP src, SEXP imin, SEXP imax) { SEXP src_tag, ans; int i1, i2, n, j; src_tag = _get_SharedVector_tag(src); i1 = INTEGER(imin)[0] - 1; i2 = INTEGER(imax)[0] - 1; if (i1 < 0 || i2 >= LENGTH(src_tag)) error("subscript out of bounds"); n = i2 - i1 + 1; PROTECT(ans = NEW_INTEGER(n)); for (j = 0; i1 <= i2; i1++, j++) { INTEGER(ans)[j] = (unsigned char) RAW(src_tag)[i1]; } UNPROTECT(1); return ans; } /* * Return an integer vector of same length as 'subscript'. * From R: * x <- SharedRaw(30) * .Call("SharedRaw_read_ints_from_subscript", x, 25:20, PACKAGE="XVector") */ SEXP SharedRaw_read_ints_from_subscript(SEXP src, SEXP subscript) { SEXP src_tag, ans; int src_length; int n, i, j; src_tag = _get_SharedVector_tag(src); src_length = LENGTH(src_tag); n = LENGTH(subscript); PROTECT(ans = NEW_INTEGER(n)); for (j = 0; j < n; j++) { i = INTEGER(subscript)[j] - 1; if (i < 0 || i >= src_length) error("subscript out of bounds"); INTEGER(ans)[j] = (unsigned char) RAW(src_tag)[i]; } UNPROTECT(1); return ans; } /* * 'val' must be an integer vector of length > 0. */ SEXP SharedRaw_write_ints_to_i1i2(SEXP dest, SEXP imin, SEXP imax, SEXP val) { SEXP dest_tag; int val_length; int i1, i2, n, j; int v; dest_tag = _get_SharedVector_tag(dest); i1 = INTEGER(imin)[0] - 1; i2 = INTEGER(imax)[0] - 1; if (i1 < 0 || i2 >= LENGTH(dest_tag)) error("subscript out of bounds"); n = i2 - i1 + 1; val_length = LENGTH(val); if (val_length == 0 && n != 0) error("no value provided"); for (j = 0; i1 <= i2; i1++, j++) { if (j >= val_length) j = 0; /* recycle */ v = INTEGER(val)[j]; if (v < 0 || v >= 256) error("value out of range"); RAW(dest_tag)[i1] = (char) v; } if (j != val_length) { warning("number of items to replace is not a multiple " "of replacement length"); } return dest; } SEXP SharedRaw_write_ints_to_subscript(SEXP dest, SEXP subscript, SEXP val) { SEXP dest_tag; int dest_length, val_length; int n, i, j, z; int v; val_length = LENGTH(val); n = LENGTH(subscript); if (val_length == 0 && n != 0) error("no value provided"); dest_tag = _get_SharedVector_tag(dest); dest_length = LENGTH(dest_tag); for (j = z = 0; z < n; j++, z++) { i = INTEGER(subscript)[z] - 1; if (i < 0 || i >= dest_length) error("subscript out of bounds"); if (j >= val_length) j = 0; /* recycle */ v = INTEGER(val)[j]; if (v < 0 || v >= 256) error("value out of range"); RAW(dest_tag)[i] = (char) v; } if (j != val_length) { warning("number of items to replace is not a multiple " "of replacement length"); } return dest; } /* ========================================================================== * Read/write encoded chars from/to a SharedRaw object * -------------------------------------------------------------------------- */ /* * Return a single string (character vector of length 1). */ SEXP SharedRaw_read_enc_chars_from_i1i2(SEXP src, SEXP imin, SEXP imax, SEXP lkup) { SEXP src_tag; int i1, i2, n; CharAE dest; src_tag = _get_SharedVector_tag(src); i1 = INTEGER(imin)[0] - 1; i2 = INTEGER(imax)[0] - 1; n = i2 - i1 + 1; dest = new_CharAE(n + 1); dest.elts[n] = '\0'; _Ocopy_bytes_from_i1i2_with_lkup(i1, i2, dest.elts, n, (char *) RAW(src_tag), LENGTH(src_tag), INTEGER(lkup), LENGTH(lkup)); return mkString(dest.elts); } SEXP SharedRaw_read_enc_chars_from_subscript(SEXP src, SEXP subscript, SEXP lkup) { SEXP src_tag; int n; CharAE dest; src_tag = _get_SharedVector_tag(src); n = LENGTH(subscript); dest = new_CharAE(n + 1); dest.elts[n] = '\0'; _Ocopy_bytes_from_subscript_with_lkup(INTEGER(subscript), n, dest.elts, n, (char *) RAW(src_tag), LENGTH(src_tag), INTEGER(lkup), LENGTH(lkup)); return mkString(dest.elts); } /* * The SharedRaw_write_enc_chars_to_i1i2() function is used when initializing * an XString object to encode and store the source string in the @shared * slot of the object. * 'string' must be a non-empty single string (character vector of length 1). */ SEXP SharedRaw_write_enc_chars_to_i1i2(SEXP dest, SEXP imin, SEXP imax, SEXP string, SEXP lkup) { SEXP dest_tag, src; int i1, i2; dest_tag = _get_SharedVector_tag(dest); i1 = INTEGER(imin)[0] - 1; i2 = INTEGER(imax)[0] - 1; src = STRING_ELT(string, 0); _Ocopy_bytes_to_i1i2_with_lkup(i1, i2, (char *) RAW(dest_tag), LENGTH(dest_tag), CHAR(src), LENGTH(src), INTEGER(lkup), LENGTH(lkup)); return dest; } SEXP SharedRaw_write_enc_chars_to_subscript(SEXP dest, SEXP subscript, SEXP string, SEXP lkup) { SEXP dest_tag, src; int n; dest_tag = _get_SharedVector_tag(dest); n = LENGTH(subscript); src = STRING_ELT(string, 0); _Ocopy_bytes_to_subscript_with_lkup(INTEGER(subscript), n, (char *) RAW(dest_tag), LENGTH(dest_tag), CHAR(src), LENGTH(src), INTEGER(lkup), LENGTH(lkup)); return dest; } /* ========================================================================== * Read chars from a SharedRaw object and convert them to a vector * of complexes. * -------------------------------------------------------------------------- */ SEXP SharedRaw_read_complexes_from_i1i2(SEXP src, SEXP imin, SEXP imax, SEXP lkup) { SEXP dest, src_tag; int i1, i2, n; src_tag = _get_SharedVector_tag(src); i1 = INTEGER(imin)[0] - 1; i2 = INTEGER(imax)[0] - 1; n = i2 - i1 + 1; PROTECT(dest = NEW_COMPLEX(n)); _Ocopy_bytes_from_i1i2_to_complex(i1, i2, COMPLEX(dest), n, (char *) RAW(src_tag), LENGTH(src_tag), COMPLEX(lkup), LENGTH(lkup)); UNPROTECT(1); return dest; } SEXP SharedRaw_read_complexes_from_subscript(SEXP src, SEXP subscript, SEXP lkup) { SEXP dest, src_tag; int n; src_tag = _get_SharedVector_tag(src); n = LENGTH(subscript); PROTECT(dest = NEW_COMPLEX(n)); error("not available yet"); UNPROTECT(1); return dest; } XVector/src/SharedVector_class.c0000644000126300012640000002731012227150112020234 0ustar00biocbuildphs_compbio/**************************************************************************** * Low-level manipulation of SharedVector and SharedVector_Pool objects * * Author: Herve Pages * ****************************************************************************/ #include "XVector.h" #include "IRanges_interface.h" static int debug = 0; SEXP debug_SharedVector_class() { #ifdef DEBUG_XVECTOR 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; } /**************************************************************************** * --- .Call ENTRY POINT --- * From R: * .Call("address_asSTRSXP", 6:4, PACKAGE="XVector") * .Call("address_asSTRSXP", new("externalptr"), PACKAGE="XVector") */ SEXP address_asSTRSXP(SEXP s) { char buf[40]; /* should be enough, even for 128-bit addresses */ snprintf(buf, sizeof(buf), "%p", s); return mkString(buf); } /**************************************************************************** * Some .Call entry points for manipulating externalptr objects. */ /* * new("externalptr") will always return the same instance of an external * pointer object! If you need a new instance, use this function instead. * From R: * x <- .Call("externalptr_new", PACKAGE="XVector") */ SEXP externalptr_new() { return R_MakeExternalPtr(NULL, R_NilValue, R_NilValue); } SEXP externalptr_get_tag(SEXP x) { return R_ExternalPtrTag(x); } SEXP externalptr_set_tag(SEXP x, SEXP tag) { R_SetExternalPtrTag(x, tag); return x; } /* * From R: * .Call("externalptr_tagtype", new("externalptr"), PACKAGE="XVector") */ SEXP externalptr_tagtype(SEXP x) { return ScalarString(type2str(TYPEOF(R_ExternalPtrTag(x)))); } SEXP externalptr_taglength(SEXP x) { return ScalarInteger(LENGTH(R_ExternalPtrTag(x))); } /* * Print some info about an externalptr object. * From R: * .Call("externalptr_show", new("externalptr"), PACKAGE="XVector") */ SEXP externalptr_show(SEXP x) { void *addr; SEXP s; Rprintf("Object of class 'externalptr':\n"); Rprintf(" x address: %p\n", x); addr = R_ExternalPtrAddr(x); Rprintf(" R_ExternalPtrAddr(x): %p\n", addr); s = R_ExternalPtrTag(x); Rprintf(" R_ExternalPtrTag(x): %p\n", s); Rprintf(" typeof(R_ExternalPtrTag(x)): %s\n", CHAR(type2str(TYPEOF(s)))); s = R_ExternalPtrProtected(x); Rprintf(" R_ExternalPtrProtected(x): %p\n", s); Rprintf(" typeof(R_ExternalPtrProtected(x)): %s\n", CHAR(type2str(TYPEOF(s)))); return R_NilValue; } /**************************************************************************** * C-level getters for SharedVector objects. * * Be careful that these functions do NOT duplicate the returned SEXP. * Thus they cannot be made .Call entry points! */ static SEXP xp_symbol = NULL, link_symbol = NULL; static SEXP get_SharedVector_xp(SEXP x) { INIT_STATIC_SYMBOL(xp) return GET_SLOT(x, xp_symbol); } SEXP _get_SharedVector_tag(SEXP x) { return R_ExternalPtrTag(get_SharedVector_xp(x)); } /* Not a strict "slot getter" but very much like. */ int _get_SharedVector_length(SEXP x) { return LENGTH(_get_SharedVector_tag(x)); } static SEXP get_SharedVector_link(SEXP x) { if (link_symbol == NULL) link_symbol = install(".link_to_cached_object"); return GET_SLOT(x, link_symbol); } /**************************************************************************** * C-level setters for SharedVector objects. * * Be careful that these functions do NOT duplicate the assigned value! */ static void set_SharedVector_tag(SEXP x, SEXP value) { SEXP xp; PROTECT(xp = R_MakeExternalPtr(NULL, value, R_NilValue)); INIT_STATIC_SYMBOL(xp) SET_SLOT(x, xp_symbol, xp); UNPROTECT(1); return; } /**************************************************************************** * C-level constructors for SharedVector objects. * * Be careful that these functions do NOT duplicate their arguments before * putting them in the slots of the returned object. * Thus they cannot be made .Call entry points! */ /* 'classname' must be "SharedRaw", "SharedInteger" or "SharedDouble" */ SEXP _new_SharedVector(const char *classname, SEXP tag) { SEXP classdef, ans; if (strcmp(classname, "SharedRaw") == 0) { if (!IS_RAW(tag)) error("XVector internal error in _new_SharedVector(): " "'tag' is not RAW"); } else if (strcmp(classname, "SharedInteger") == 0) { if (!IS_INTEGER(tag)) error("XVector internal error in _new_SharedVector(): " "'tag' is not INTEGER"); } else if (strcmp(classname, "SharedDouble") == 0) { if (!IS_NUMERIC(tag)) error("XVector internal error in _new_SharedVector(): " "'tag' is not NUMERIC"); } else { error("XVector internal error in _new_SharedVector(): " "%s: invalid 'classname'", classname); } PROTECT(classdef = MAKE_CLASS(classname)); PROTECT(ans = NEW_OBJECT(classdef)); set_SharedVector_tag(ans, tag); UNPROTECT(2); return ans; } /**************************************************************************** * Needed by the "show" method for SharedVector objects. */ SEXP SharedVector_address0(SEXP x) { SEXP tag; void *address0; char buf[20]; /* should be enough... */ tag = _get_SharedVector_tag(x); if (IS_RAW(tag)) address0 = RAW(tag); else if (IS_INTEGER(tag)) address0 = INTEGER(tag); else if (IS_NUMERIC(tag)) address0 = REAL(tag); else error("XVector internal error in SharedVector_address0(): " "%s: invalid tag type", CHAR(type2str(TYPEOF(tag)))); snprintf(buf, sizeof(buf), "%p", address0); return mkString(buf); } /**************************************************************************** * Some .Call entry points for copying data from a SharedVector object to a * SharedVector object of the same subtype. */ SEXP SharedVector_memcmp(SEXP x1, SEXP start1, SEXP x2, SEXP start2, SEXP width) { SEXP tag1, tag2, ans; int offset1, offset2, nelt; tag1 = _get_SharedVector_tag(x1); offset1 = INTEGER(start1)[0] - 1; tag2 = _get_SharedVector_tag(x2); offset2 = INTEGER(start2)[0] - 1; nelt = INTEGER(width)[0]; PROTECT(ans = NEW_INTEGER(1)); INTEGER(ans)[0] = vector_memcmp(tag1, offset1, tag2, offset2, nelt); UNPROTECT(1); return ans; } SEXP SharedVector_Ocopy_from_start(SEXP out, SEXP in, SEXP in_start, SEXP width, SEXP lkup, SEXP reverse) { SEXP out_tag, in_tag; int in_offset, nelt, reverse0; out_tag = _get_SharedVector_tag(out); in_tag = _get_SharedVector_tag(in); in_offset = INTEGER(in_start)[0] - 1; nelt = INTEGER(width)[0]; reverse0 = LOGICAL(reverse)[0]; _vector_Ocopy_from_offset(out_tag, in_tag, in_offset, nelt, lkup, reverse0); return out; } SEXP SharedVector_Ocopy_from_subscript(SEXP out, SEXP in, SEXP subscript, SEXP lkup) { SEXP out_tag, in_tag; out_tag = _get_SharedVector_tag(out); in_tag = _get_SharedVector_tag(in); _vector_Ocopy_from_subscript(out_tag, in_tag, subscript, lkup); return out; } SEXP SharedVector_mcopy(SEXP out, SEXP out_offset, SEXP in, SEXP in_start, SEXP in_width, SEXP lkup, SEXP reverse) { SEXP out_tag, in_tag; int out_offset0, reverse0; out_tag = _get_SharedVector_tag(out); out_offset0 = INTEGER(out_offset)[0]; in_tag = _get_SharedVector_tag(in); reverse0 = INTEGER(reverse)[0]; _vector_mcopy(out_tag, out_offset0, in_tag, in_start, in_width, lkup, reverse0); return out; } /**************************************************************************** * C-level getters for SharedVector_Pool objects. * * Be careful that this function does NOT duplicate the returned slot. * Thus it cannot be made a .Call entry point! */ static SEXP xp_list_symbol = NULL, link_list_symbol = NULL; SEXP _get_SharedVector_Pool_xp_list(SEXP x) { INIT_STATIC_SYMBOL(xp_list) return GET_SLOT(x, xp_list_symbol); } /**************************************************************************** * C-level setters for SharedVector_Pool objects. * * Be careful that these functions do NOT duplicate the assigned value! */ static void set_SharedVector_Pool_xp_list(SEXP x, SEXP value) { INIT_STATIC_SYMBOL(xp_list) SET_SLOT(x, xp_list_symbol, value); return; } static void set_SharedVector_Pool_link_list(SEXP x, SEXP value) { if (link_list_symbol == NULL) link_list_symbol = install(".link_to_cached_object_list"); SET_SLOT(x, link_list_symbol, value); return; } /**************************************************************************** * C-level constructors for SharedVector_Pool objects. * * Be careful that these functions do NOT duplicate their arguments before * putting them in the slots of the returned object. * Thus they cannot be made .Call entry points! */ static SEXP new_SharedVector_Pool(const char *classname, const char *element_type, SEXP tags) { SEXP classdef, ans, ans_xp_list, ans_link_list, tmp, shared_vector; int ans_length, i; PROTECT(classdef = MAKE_CLASS(classname)); PROTECT(ans = NEW_OBJECT(classdef)); ans_length = LENGTH(tags); /* set "xp_list" slot */ PROTECT(ans_xp_list = NEW_LIST(ans_length)); for (i = 0; i < ans_length; i++) { tmp = VECTOR_ELT(tags, i); PROTECT(tmp = R_MakeExternalPtr(NULL, tmp, R_NilValue)); SET_VECTOR_ELT(ans_xp_list, i, tmp); UNPROTECT(1); } set_SharedVector_Pool_xp_list(ans, ans_xp_list); UNPROTECT(1); /* set ".link_to_cached_object_list" slot */ PROTECT(classdef = MAKE_CLASS(element_type)); PROTECT(shared_vector = NEW_OBJECT(classdef)); PROTECT(ans_link_list = NEW_LIST(ans_length)); for (i = 0; i < ans_length; i++) { PROTECT(tmp = duplicate(get_SharedVector_link(shared_vector))); SET_VECTOR_ELT(ans_link_list, i, tmp); UNPROTECT(1); } set_SharedVector_Pool_link_list(ans, ans_link_list); UNPROTECT(3); UNPROTECT(2); return ans; } SEXP _new_SharedRaw_Pool(SEXP tags) { int ans_length, i; ans_length = LENGTH(tags); for (i = 0; i < ans_length; i++) { if (IS_RAW(VECTOR_ELT(tags, i))) continue; error("XVector internal error in _new_SharedRaw_Pool(): " "'tags[[%d]]' is not RAW", i + 1); } return new_SharedVector_Pool("SharedRaw_Pool", "SharedRaw", tags); } SEXP _new_SharedInteger_Pool(SEXP tags) { int ans_length, i; ans_length = LENGTH(tags); for (i = 0; i < ans_length; i++) { if (IS_INTEGER(VECTOR_ELT(tags, i))) continue; error("XVector internal error in _new_SharedInteger_Pool(): " "'tags[[%d]]' is not INTEGER", i + 1); } return new_SharedVector_Pool("SharedInteger_Pool", "SharedInteger", tags); } SEXP _new_SharedDouble_Pool(SEXP tags) { int ans_length, i; ans_length = LENGTH(tags); for (i = 0; i < ans_length; i++) { if (IS_NUMERIC(VECTOR_ELT(tags, i))) continue; error("XVector internal error in _new_SharedDouble_Pool(): " "'tags[[%d]]' is not NUMERIC", i + 1); } return new_SharedVector_Pool("SharedDouble_Pool", "SharedDouble", tags); } SEXP _new_SharedVector_Pool1(SEXP shared) { const char *shared_classname; char classname_buf[80]; SEXP classdef, ans, ans_xp_list, ans_link_list, tmp; shared_classname = get_classname(shared); if (snprintf(classname_buf, sizeof(classname_buf), "%s_Pool", shared_classname) >= sizeof(classname_buf)) error("XVector internal error in _new_SharedVector_Pool1(): " "'shared_classname' too long"); PROTECT(classdef = MAKE_CLASS(classname_buf)); PROTECT(ans = NEW_OBJECT(classdef)); /* set "xp_list" slot */ PROTECT(ans_xp_list = NEW_LIST(1)); PROTECT(tmp = duplicate(get_SharedVector_xp(shared))); SET_VECTOR_ELT(ans_xp_list, 0, tmp); set_SharedVector_Pool_xp_list(ans, ans_xp_list); UNPROTECT(2); /* set ".link_to_cached_object_list" slot */ PROTECT(ans_link_list = NEW_LIST(1)); PROTECT(tmp = duplicate(get_SharedVector_link(shared))); SET_VECTOR_ELT(ans_link_list, 0, tmp); set_SharedVector_Pool_link_list(ans, ans_link_list); UNPROTECT(2); UNPROTECT(2); return ans; } XVector/src/XRawList_comparison.c0000644000126300012640000002413112227150112020423 0ustar00biocbuildphs_compbio/**************************************************************************** * Comparing and ordering the elements in one or more XRawList objects * * Author: Herve Pages * ****************************************************************************/ #include "XVector.h" #include "IRanges_interface.h" #include /* for qsort() */ /**************************************************************************** * Comparison of 2 cachedCharSeq structs. */ static int compar_cachedCharSeqs(const cachedCharSeq *x1, const cachedCharSeq *x2) { int n, ret; n = x1->length < x2->length ? x1->length : x2->length; ret = memcmp(x1->seq, x2->seq, n); if (ret != 0) return ret; ret = x1->length - x2->length; return ret; } /* Fast version of 'compar_cachedCharSeqs(x1, x2) == 0' */ static int equal_cachedCharSeqs(const cachedCharSeq *x1, const cachedCharSeq *x2) { return x1->length == x2->length && memcmp(x1->seq, x2->seq, x1->length) == 0; } /**************************************************************************** * "Parallel" comparison of 2 XRawList objects. */ static void cachedXRawList_pcompar(const cachedXVectorList *x, const cachedXVectorList *y, int *out, int out_len, int with_warning) { int x_len, y_len, i, j, k; cachedCharSeq x_elt, y_elt; x_len = _get_cachedXVectorList_length(x); y_len = _get_cachedXVectorList_length(y); for (i = j = k = 0; k < out_len; i++, j++, k++) { if (i >= x_len) i = 0; /* recycle i */ if (j >= y_len) j = 0; /* recycle j */ x_elt = _get_cachedXRawList_elt(x, i); y_elt = _get_cachedXRawList_elt(y, j); out[k] = compar_cachedCharSeqs(&x_elt, &y_elt); } /* Warning message appropriate only when 'out_len' is 'max(x_len, y_len)' */ if (with_warning && out_len != 0 && (i != x_len || j != y_len)) warning("longer object length is not a multiple " "of shorter object length"); return; } /* --- .Call ENTRY POINT --- */ SEXP XRawList_compare(SEXP x, SEXP y) { cachedXVectorList cached_x, cached_y; int x_len, y_len, ans_len; SEXP ans; cached_x = _cache_XVectorList(x); cached_y = _cache_XVectorList(y); x_len = _get_cachedXVectorList_length(&cached_x); y_len = _get_cachedXVectorList_length(&cached_y); if (x_len == 0 || y_len == 0) ans_len = 0; else ans_len = x_len >= y_len ? x_len : y_len; PROTECT(ans = NEW_INTEGER(ans_len)); cachedXRawList_pcompar(&cached_x, &cached_y, INTEGER(ans), ans_len, 1); UNPROTECT(1); return ans; } /**************************************************************************** * Order and rank of the elements in an XRawList object. */ static cachedCharSeq *XX; static int compar_XX(int i1, int i2) { return compar_cachedCharSeqs(XX + i1, XX + i2); } static int compar_XX_for_stable_asc_order(const void *p1, const void *p2) { int i1, i2, ret; i1 = *((const int *) p1); i2 = *((const int *) p2); ret = compar_XX(i1, i2); if (ret != 0) return ret; /* Break tie by position so the ordering is "stable". */ return i1 - i2; } /* We cannot just define compar_XX_for_stable_desc_order(p1, p2) to be * compar_XX_for_stable_asc_order(p2, p1) because of the tie-break * by position. */ static int compar_XX_for_stable_desc_order(const void *p1, const void *p2) { int i1, i2, ret; i1 = *((const int *) p1); i2 = *((const int *) p2); ret = compar_XX(i2, i1); if (ret != 0) return ret; /* Break tie by position so the ordering is "stable". */ return i1 - i2; } static void get_order_of_cachedXRawList(const cachedXVectorList *cached_x, int desc, int *out, int out_shift) { int nelt, i, (*compar)(const void *, const void *); nelt = _get_cachedXVectorList_length(cached_x); XX = (cachedCharSeq *) R_alloc(sizeof(cachedCharSeq), nelt); XX -= out_shift; for (i = 0; i < nelt; i++, out_shift++) { XX[out_shift] = _get_cachedXRawList_elt(cached_x, i); out[i] = out_shift; } compar = desc ? compar_XX_for_stable_desc_order : compar_XX_for_stable_asc_order; qsort(out, nelt, sizeof(int), compar); return; } /* --- .Call ENTRY POINT --- */ SEXP XRawList_is_unsorted(SEXP x, SEXP strictly) { cachedXVectorList cached_x; int x_length, is_unsorted, i, ret0, ret; cachedCharSeq x_elt1, x_elt2; SEXP ans; cached_x = _cache_XVectorList(x); x_length = _get_cachedXVectorList_length(&cached_x); ret0 = LOGICAL(strictly)[0] ? 0 : 1; is_unsorted = 0; if (x_length >= 2) { x_elt2 = _get_cachedXRawList_elt(&cached_x, 0); for (i = 1; i < x_length; i++) { x_elt1 = x_elt2; x_elt2 = _get_cachedXRawList_elt(&cached_x, i); ret = compar_cachedCharSeqs(&x_elt1, &x_elt2); if (ret >= ret0) { is_unsorted = 1; break; } } } PROTECT(ans = NEW_LOGICAL(1)); LOGICAL(ans)[0] = is_unsorted; UNPROTECT(1); return ans; } /* --- .Call ENTRY POINT --- */ SEXP XRawList_order(SEXP x, SEXP decreasing) { cachedXVectorList cached_x; int ans_length; SEXP ans; cached_x = _cache_XVectorList(x); ans_length = _get_cachedXVectorList_length(&cached_x); PROTECT(ans = NEW_INTEGER(ans_length)); get_order_of_cachedXRawList(&cached_x, LOGICAL(decreasing)[0], INTEGER(ans), 1); UNPROTECT(1); return ans; } static void get_first_rank_from_order(const int *oo, int nelt, int *out) { int i; for (i = 1; i <= nelt; i++) out[*(oo++)] = i; return; } static void get_min_rank_from_order(const int *oo, int nelt, int *out, const cachedXVectorList *cached_x) { const int *oo1, *oo2; cachedCharSeq x_elt1, x_elt2; int i; oo1 = oo2 = oo; x_elt2 = _get_cachedXRawList_elt(cached_x, *oo2); out[*oo2] = 1; oo2++; for (i = 2; i <= nelt; i++) { x_elt1 = x_elt2; x_elt2 = _get_cachedXRawList_elt(cached_x, *oo2); out[*oo2] = equal_cachedCharSeqs(&x_elt1, &x_elt2) ? out[*oo1] : i; oo2++; oo1++; } return; } /* --- .Call ENTRY POINT --- */ SEXP XRawList_rank(SEXP x, SEXP ties_method) { cachedXVectorList cached_x; int ans_length, *oo; const char *method; SEXP ans; cached_x = _cache_XVectorList(x); ans_length = _get_cachedXVectorList_length(&cached_x); method = CHAR(STRING_ELT(ties_method, 0)); oo = (int *) R_alloc(ans_length, sizeof(int)); get_order_of_cachedXRawList(&cached_x, 0, oo, 0); PROTECT(ans = NEW_INTEGER(ans_length)); if (ans_length <= 1 || strcmp(method, "first") == 0) { get_first_rank_from_order(oo, ans_length, INTEGER(ans)); } else if (strcmp(method, "min") == 0) { get_min_rank_from_order(oo, ans_length, INTEGER(ans), &cached_x); } else { error("ties_method \"%s\" is not supported", ties_method); } UNPROTECT(1); return ans; } /**************************************************************************** * Matches between 2 XRawList objects, and self-matches within an XRawList * object. */ /* * We use the Bernstein's function to hash arbitrary arrays of bytes. * See http://www.strchr.com/hash_functions for an empirical comparison of hash * functions and http://www.cse.yorku.ca/~oz/hash.html for an implementation of * the Bernstein's function. Note that this implementation is NOT the same as * the hash function used for the Global CHARSXP cache in base R * (see char_hash() function in R_HOME/src/main/envir.c) which was taken from * the same place but slightly modified by replacing the use of unsigned char * with (plain) char. As a consequence, the hash values returned by djb2_hash() * and char_hash() will be different on a platform where (plain) char is * equivalent to signed char (e.g. gcc on Intel 32- or 64-bit Linux). * * TODO: Some people recommend to use XOR operation instead of addition in * 'hval * 33 + *s'. Try and see if that makes any difference. */ static unsigned int djb2_hash(const unsigned char *s, int len) { unsigned int hval = 5381; int i; for (i = 0; i < len; i++, s++) hval += (hval << 5) + *s; /* hval = hval * 33 + *s */ return hval; } static int get_bucket_idx_for_cachedCharSeq(const struct htab *htab, const cachedCharSeq *charseq1, const cachedXVectorList *charseqs2) { unsigned int hval; int bucket_idx, i2; const int *buckets; cachedCharSeq charseq2; hval = djb2_hash((unsigned char *) charseq1->seq, charseq1->length); bucket_idx = hval & htab->Mminus1; buckets = htab->buckets; while ((i2 = buckets[bucket_idx]) != NA_INTEGER) { charseq2 = _get_cachedXRawList_elt(charseqs2, i2); if (equal_cachedCharSeqs(charseq1, &charseq2)) break; bucket_idx = (bucket_idx + 1) % htab->M; } return bucket_idx; } /* --- .Call ENTRY POINT --- */ SEXP XRawList_match_hash(SEXP x1, SEXP x2, SEXP nomatch) { int len1, len2, nomatch0, *ans0, i, bucket_idx, i2; cachedXVectorList cached_x1, cached_x2; cachedCharSeq charseq; struct htab htab; SEXP ans; cached_x1 = _cache_XVectorList(x1); cached_x2 = _cache_XVectorList(x2); len1 = _get_cachedXVectorList_length(&cached_x1); len2 = _get_cachedXVectorList_length(&cached_x2); nomatch0 = INTEGER(nomatch)[0]; htab = new_htab(len2); for (i = 0; i < len2; i++) { charseq = _get_cachedXRawList_elt(&cached_x2, i); bucket_idx = get_bucket_idx_for_cachedCharSeq(&htab, &charseq, &cached_x2); 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++) { charseq = _get_cachedXRawList_elt(&cached_x1, i); bucket_idx = get_bucket_idx_for_cachedCharSeq(&htab, &charseq, &cached_x2); 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 XRawList_selfmatch_hash(SEXP x) { int ans_length, *ans0, i, bucket_idx, i2; cachedXVectorList cached_x; cachedCharSeq charseq; struct htab htab; SEXP ans; cached_x = _cache_XVectorList(x); ans_length = _get_cachedXVectorList_length(&cached_x); htab = new_htab(ans_length); PROTECT(ans = NEW_INTEGER(ans_length)); ans0 = INTEGER(ans); for (i = 0; i < ans_length; i++) { charseq = _get_cachedXRawList_elt(&cached_x, i); bucket_idx = get_bucket_idx_for_cachedCharSeq(&htab, &charseq, &cached_x); 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; } XVector/src/XVector.h0000644000126300012640000002311012227150112016047 0ustar00biocbuildphs_compbio#include "../inst/include/XVector_defines.h" #include #define DEBUG_XVECTOR 1 #define INIT_STATIC_SYMBOL(NAME) \ { \ if (NAME ## _symbol == NULL) \ NAME ## _symbol = install(# NAME); \ } /* Ocopy_byteblocks.c */ SEXP debug_Ocopy_byteblocks(); void _Ocopy_byteblocks_from_i1i2( int i1, int i2, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize ); void _Ocopy_byteblocks_from_subscript( const int *subscript, int n, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize ); void _Ocopy_byteblocks_to_i1i2( int i1, int i2, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize ); void _Ocopy_byteblocks_to_subscript( const int *subscript, int n, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize ); void _Ocopy_bytes_from_i1i2_with_lkup( int i1, int i2, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length ); void _Ocopy_bytes_from_subscript_with_lkup( const int *subscript, int n, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length ); void _Ocopy_bytes_to_i1i2_with_lkup( int i1, int i2, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length ); void _Ocopy_bytes_to_subscript_with_lkup( const int *subscript, int n, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length ); void _Orevcopy_byteblocks_from_i1i2( int i1, int i2, char *dest, size_t dest_nblocks, const char *src, size_t src_nblocks, size_t blocksize ); void _Orevcopy_bytes_from_i1i2_with_lkup( int i1, int i2, char *dest, int dest_nbytes, const char *src, int src_nbytes, const int *lkup, int lkup_length ); void _Ocopy_bytes_from_i1i2_to_complex( int i1, int i2, Rcomplex *dest, int dest_nbytes, const char *src, int src_nbytes, const Rcomplex *lkup, int lkup_length ); /* vector_copy.c */ int _vector_memcmp( SEXP x1, int x1_offset, SEXP x2, int x2_offset, int nelt ); void _vector_copy( SEXP out, int out_offset, SEXP in, int in_offset, int nelt ); void _vector_Ocopy( SEXP out, int out_offset, SEXP in, int in_offset, int nelt, SEXP lkup, int reverse, int Omode ); void _vector_Ocopy_from_offset( SEXP out, SEXP in, int in_offset, int nelt, SEXP lkup, int reverse ); void _vector_Ocopy_to_offset( SEXP out, SEXP in, int out_offset, int nelt, SEXP lkup ); void _vector_Ocopy_from_subscript( SEXP out, SEXP in, SEXP subscript, SEXP lkup ); void _vector_Ocopy_to_subscript( SEXP out, SEXP in, SEXP subscript, SEXP lkup ); void _vector_mcopy( SEXP out, int out_offset, SEXP in, SEXP in_start, SEXP in_width, SEXP lkup, int reverse ); /* SharedVector_class.c */ SEXP debug_SharedVector_class(); SEXP address_asSTRSXP(SEXP s); SEXP externalptr_new(); SEXP externalptr_get_tag(SEXP x); SEXP externalptr_set_tag( SEXP x, SEXP tag ); SEXP externalptr_tagtype(SEXP x); SEXP externalptr_taglength(SEXP x); SEXP externalptr_show(SEXP x); SEXP _get_SharedVector_tag(SEXP x); int _get_SharedVector_length(SEXP x); SEXP _new_SharedVector(const char *classname, SEXP tag); SEXP SharedVector_address0(SEXP x); SEXP SharedVector_memcmp( SEXP x1, SEXP start1, SEXP x2, SEXP start2, SEXP width ); SEXP SharedVector_Ocopy_from_start( SEXP out, SEXP in, SEXP in_start, SEXP width, SEXP lkup, SEXP reverse ); SEXP SharedVector_Ocopy_from_subscript( SEXP out, SEXP in, SEXP subscript, SEXP lkup ); SEXP SharedVector_mcopy( SEXP out, SEXP out_offset, SEXP in, SEXP in_start, SEXP in_width, SEXP lkup, SEXP reverse ); SEXP _get_SharedVector_Pool_xp_list(SEXP x); SEXP _new_SharedRaw_Pool(SEXP tags); SEXP _new_SharedInteger_Pool(SEXP tags); SEXP _new_SharedDouble_Pool(SEXP tags); SEXP _new_SharedVector_Pool1(SEXP shared); /* SharedRaw_class.c */ SEXP debug_SharedRaw_class(); SEXP SharedRaw_new( SEXP length, SEXP val ); SEXP SharedRaw_read_chars_from_i1i2( SEXP src, SEXP imin, SEXP imax ); SEXP SharedRaw_read_chars_from_subscript( SEXP src, SEXP subscript ); SEXP SharedRaw_write_chars_to_i1i2( SEXP dest, SEXP imin, SEXP imax, SEXP string ); SEXP SharedRaw_write_chars_to_subscript( SEXP dest, SEXP subscript, SEXP string ); SEXP SharedRaw_read_ints_from_i1i2( SEXP src, SEXP imin, SEXP imax ); SEXP SharedRaw_read_ints_from_subscript( SEXP src, SEXP subscript ); SEXP SharedRaw_write_ints_to_i1i2( SEXP dest, SEXP imin, SEXP imax, SEXP val ); SEXP SharedRaw_write_ints_to_subscript( SEXP dest, SEXP subscript, SEXP val ); SEXP SharedRaw_read_enc_chars_from_i1i2( SEXP src, SEXP imin, SEXP imax, SEXP lkup ); SEXP SharedRaw_read_enc_chars_from_subscript( SEXP src, SEXP subscript, SEXP lkup ); SEXP SharedRaw_write_enc_chars_to_i1i2( SEXP dest, SEXP imin, SEXP imax, SEXP string, SEXP lkup ); SEXP SharedRaw_write_enc_chars_to_subscript( SEXP dest, SEXP subscript, SEXP string, SEXP lkup ); SEXP SharedRaw_read_complexes_from_i1i2( SEXP src, SEXP imin, SEXP imax, SEXP lkup ); SEXP SharedRaw_read_complexes_from_subscript( SEXP src, SEXP subscript, SEXP lkup ); /* SharedInteger_class.c */ SEXP debug_SharedInteger_class(); SEXP SharedInteger_new( SEXP length, SEXP val ); SEXP SharedInteger_get_show_string(SEXP x); SEXP SharedInteger_read_ints_from_i1i2( SEXP src, SEXP imin, SEXP imax ); SEXP SharedInteger_read_ints_from_subscript( SEXP src, SEXP subscript ); SEXP SharedInteger_write_ints_to_i1i2( SEXP dest, SEXP imin, SEXP imax, SEXP val ); SEXP SharedInteger_write_ints_to_subscript( SEXP dest, SEXP subscript, SEXP val ); /* SharedDouble_class.c */ SEXP debug_SharedDouble_class(); SEXP SharedDouble_new( SEXP length, SEXP val ); SEXP SharedDouble_get_show_string(SEXP x); SEXP SharedDouble_read_nums_from_i1i2( SEXP src, SEXP imin, SEXP imax ); SEXP SharedDouble_read_nums_from_subscript( SEXP src, SEXP subscript ); SEXP SharedDouble_write_nums_to_i1i2( SEXP dest, SEXP imin, SEXP imax, SEXP val ); SEXP SharedDouble_write_nums_to_subscript( SEXP dest, SEXP subscript, SEXP val ); /* XVector_class.c */ SEXP debug_XVector_class(); SEXP _get_XVector_shared(SEXP x); int _get_XVector_offset(SEXP x); int _get_XVector_length(SEXP x); SEXP _get_XVector_tag(SEXP x); cachedCharSeq _cache_XRaw(SEXP x); cachedIntSeq _cache_XInteger(SEXP x); cachedDoubleSeq _cache_XDouble(SEXP x); SEXP _new_XVector( const char *classname, SEXP shared, int offset, int length ); SEXP _new_XRaw_from_tag( const char *classname, SEXP tag ); SEXP _new_XInteger_from_tag( const char *classname, SEXP tag ); SEXP _new_XDouble_from_tag( const char *classname, SEXP tag ); SEXP _alloc_XRaw( const char *classname, int length ); SEXP _alloc_XInteger( const char *classname, int length ); SEXP _alloc_XDouble( const char *classname, int length ); /* XVectorList_class.c */ SEXP debug_XVectorList_class(); SEXP _get_XVectorList_pool(SEXP x); SEXP _get_XVectorList_ranges(SEXP x); int _get_XVectorList_length(SEXP x); SEXP _get_XVectorList_width(SEXP x); SEXP _get_XVectorList_names(SEXP x); cachedXVectorList _cache_XVectorList(SEXP x); int _get_cachedXVectorList_length(const cachedXVectorList *cached_x); cachedCharSeq _get_cachedXRawList_elt( const cachedXVectorList *cached_x, int i ); cachedIntSeq _get_cachedXIntegerList_elt( const cachedXVectorList *cached_x, int i ); cachedDoubleSeq _get_cachedXDoubleList_elt( const cachedXVectorList *cached_x, int i ); void _set_XVectorList_names(SEXP x, SEXP names); SEXP _new_XRawList_from_tags( const char *classname, const char *element_type, SEXP tags, SEXP ranges, SEXP ranges_group ); SEXP _new_XIntegerList_from_tags( const char *classname, const char *element_type, SEXP tags, SEXP ranges, SEXP ranges_group ); SEXP _new_XDoubleList_from_tags( const char *classname, const char *element_type, SEXP tags, SEXP ranges, SEXP ranges_group ); SEXP _new_XRawList_from_tag( const char *classname, const char *element_type, SEXP tag, SEXP ranges ); SEXP _new_XIntegerList_from_tag( const char *classname, const char *element_type, SEXP tag, SEXP ranges ); SEXP _new_XDoubleList_from_tag( const char *classname, const char *element_type, SEXP tag, SEXP ranges ); SEXP _alloc_XRawList( const char *classname, const char *element_type, SEXP width ); SEXP _alloc_XIntegerList( const char *classname, const char *element_type, SEXP width ); SEXP _alloc_XDoubleList( const char *classname, const char *element_type, SEXP width ); SEXP _new_XRawList_from_CharAEAE( const char *classname, const char *element_type, const CharAEAE *char_aeae, SEXP lkup ); SEXP _new_XIntegerList_from_IntAEAE( const char *classname, const char *element_type, const IntAEAE *int_aeae ); /* XRawList_comparison.c */ SEXP XRawList_compare( SEXP x, SEXP y ); SEXP XRawList_is_unsorted( SEXP x, SEXP strictly ); SEXP XRawList_order( SEXP x, SEXP decreasing ); SEXP XRawList_rank( SEXP x, SEXP ties_method ); SEXP XRawList_match_hash( SEXP x1, SEXP x2, SEXP nomatch ); SEXP XRawList_selfmatch_hash( SEXP x ); /* slice_methods.c */ SEXP XInteger_slice( SEXP x, SEXP lower, SEXP upper ); SEXP XDouble_slice( SEXP x, SEXP lower, SEXP upper, SEXP include_lower, SEXP include_upper ); /* view_summarization_methods.c */ SEXP XIntegerViews_summary1( SEXP x, SEXP na_rm, SEXP method ); SEXP XDoubleViews_summary1( SEXP x, SEXP na_rm, SEXP method ); SEXP XIntegerViews_summary2( SEXP x, SEXP na_rm, SEXP method ); SEXP XDoubleViews_summary2( SEXP x, SEXP na_rm, SEXP method ); XVector/src/XVectorList_class.c0000644000126300012640000003140312227150112020067 0ustar00biocbuildphs_compbio/**************************************************************************** * Low-level manipulation of XVectorList objects * * Author: Herve Pages * ****************************************************************************/ #include "XVector.h" #include "IRanges_interface.h" static int debug = 0; SEXP debug_XVectorList_class() { #ifdef DEBUG_XVECTOR 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; } /**************************************************************************** * C-level slot getters for XVectorList objects. * * Be careful that these functions do NOT duplicate the returned slot. * Thus they cannot be made .Call entry points! */ static SEXP pool_symbol = NULL, ranges_symbol = NULL; SEXP _get_XVectorList_pool(SEXP x) { INIT_STATIC_SYMBOL(pool) return GET_SLOT(x, pool_symbol); } SEXP _get_XVectorList_ranges(SEXP x) { INIT_STATIC_SYMBOL(ranges) return GET_SLOT(x, ranges_symbol); } /* Not strict "slot getters" but very much like. */ int _get_XVectorList_length(SEXP x) { return get_IRanges_length(_get_XVectorList_ranges(x)); } SEXP _get_XVectorList_width(SEXP x) { return get_IRanges_width(_get_XVectorList_ranges(x)); } SEXP _get_XVectorList_names(SEXP x) { return get_IRanges_names(_get_XVectorList_ranges(x)); } /**************************************************************************** * C-level slot getter, slot setter, and constructor for GroupedIRanges * objects. */ static SEXP group_symbol = NULL; static SEXP get_GroupedIRanges_group(SEXP x) { INIT_STATIC_SYMBOL(group) return GET_SLOT(x, group_symbol); } static void set_GroupedIRanges_group(SEXP x, SEXP value) { INIT_STATIC_SYMBOL(group) SET_SLOT(x, group_symbol, value); return; } static SEXP new_GroupedIRanges(SEXP ranges, SEXP group) { SEXP ans; PROTECT(ans = new_IRanges("GroupedIRanges", get_IRanges_start(ranges), get_IRanges_width(ranges), get_IRanges_names(ranges))); set_GroupedIRanges_group(ans, group); UNPROTECT(1); return ans; } /**************************************************************************** * C-level abstract getters. */ cachedXVectorList _cache_XVectorList(SEXP x) { cachedXVectorList cached_x; SEXP ranges; cached_x.classname = get_classname(x); cached_x.element_type = get_List_elementType(x); cached_x.xp_list = _get_SharedVector_Pool_xp_list( _get_XVectorList_pool(x)); ranges = _get_XVectorList_ranges(x); cached_x.length = get_IRanges_length(ranges); cached_x.start = INTEGER(get_IRanges_start(ranges)); cached_x.width = INTEGER(get_IRanges_width(ranges)); cached_x.group = INTEGER(get_GroupedIRanges_group(ranges)); return cached_x; } int _get_cachedXVectorList_length(const cachedXVectorList *cached_x) { return cached_x->length; } cachedCharSeq _get_cachedXRawList_elt(const cachedXVectorList *cached_x, int i) { SEXP tag; cachedCharSeq charseq; tag = R_ExternalPtrTag(VECTOR_ELT(cached_x->xp_list, cached_x->group[i] - 1)); charseq.seq = (const char *) RAW(tag) + cached_x->start[i] - 1; charseq.length = cached_x->width[i]; return charseq; } cachedIntSeq _get_cachedXIntegerList_elt(const cachedXVectorList *cached_x, int i) { SEXP tag; cachedIntSeq intseq; tag = R_ExternalPtrTag(VECTOR_ELT(cached_x->xp_list, cached_x->group[i] - 1)); intseq.seq = INTEGER(tag) + cached_x->start[i] - 1; intseq.length = cached_x->width[i]; return intseq; } cachedDoubleSeq _get_cachedXDoubleList_elt(const cachedXVectorList *cached_x, int i) { SEXP tag; cachedDoubleSeq doubleseq; tag = R_ExternalPtrTag(VECTOR_ELT(cached_x->xp_list, cached_x->group[i] - 1)); doubleseq.seq = REAL(tag) + cached_x->start[i] - 1; doubleseq.length = cached_x->width[i]; return doubleseq; } /**************************************************************************** * C-level slot setters. * * Be careful that these functions do NOT duplicate the assigned value! */ static void set_XVectorList_pool(SEXP x, SEXP value) { INIT_STATIC_SYMBOL(pool) SET_SLOT(x, pool_symbol, value); return; } static void set_XVectorList_ranges(SEXP x, SEXP value) { INIT_STATIC_SYMBOL(ranges) SET_SLOT(x, ranges_symbol, value); return; } /* * Not strict a "slot getter" but very much like. * WARNING: x@ranges@NAMES is modified in-place! */ void _set_XVectorList_names(SEXP x, SEXP names) { set_IRanges_names(_get_XVectorList_ranges(x), names); return; } /**************************************************************************** * C-level constructors. * * Please be aware that these functions do NOT duplicate their arguments * before putting them in the slots of the returned object. * Thus they cannot be made .Call entry points! */ /* Constructing an XVectorList object from a list of tags. */ static SEXP new_XVectorList_from_tags(const char *classname, const char *element_type, SEXP (*new_SharedVector_Pool)(SEXP), SEXP tags, SEXP ranges, SEXP ranges_group) { SEXP classdef, ans, ans_pool, ans_ranges; PROTECT(classdef = MAKE_CLASS(classname)); PROTECT(ans = NEW_OBJECT(classdef)); /* set "elementType" slot */ set_List_elementType(ans, element_type); /* set "pool" slot */ PROTECT(ans_pool = new_SharedVector_Pool(tags)); set_XVectorList_pool(ans, ans_pool); UNPROTECT(1); /* set "ranges" slot */ PROTECT(ans_ranges = new_GroupedIRanges(ranges, ranges_group)); set_XVectorList_ranges(ans, ans_ranges); UNPROTECT(1); UNPROTECT(2); return ans; } SEXP _new_XRawList_from_tags(const char *classname, const char *element_type, SEXP tags, SEXP ranges, SEXP ranges_group) { return new_XVectorList_from_tags(classname, element_type, _new_SharedRaw_Pool, tags, ranges, ranges_group); } SEXP _new_XIntegerList_from_tags(const char *classname, const char *element_type, SEXP tags, SEXP ranges, SEXP ranges_group) { return new_XVectorList_from_tags(classname, element_type, _new_SharedInteger_Pool, tags, ranges, ranges_group); } SEXP _new_XDoubleList_from_tags(const char *classname, const char *element_type, SEXP tags, SEXP ranges, SEXP ranges_group) { return new_XVectorList_from_tags(classname, element_type, _new_SharedDouble_Pool, tags, ranges, ranges_group); } /* * Constructing an XVectorList object from a single tag. * For convenience, 'ranges' can be NULL as a way to indicate that the * returned XVectorList object has only 1 element that spans the entire tag. */ static SEXP new_XVectorList_from_tag(const char *classname, const char *element_type, SEXP (*new_SharedVector_Pool)(SEXP), SEXP tag, SEXP ranges) { SEXP tags, ans_start, ans_width, ranges_group, ans; int nprotect = 0, ans_length, i; /* prepare 'tags' */ PROTECT(tags = NEW_LIST(1)); nprotect++; SET_VECTOR_ELT(tags, 0, tag); /* prepare 'ranges' */ if (ranges == NULL) { PROTECT(ans_start = ScalarInteger(1)); PROTECT(ans_width = ScalarInteger(LENGTH(tag))); PROTECT(ranges = new_IRanges("IRanges", ans_start, ans_width, R_NilValue)); nprotect += 3; } /* prepare 'ranges_group' */ ans_length = get_IRanges_length(ranges); PROTECT(ranges_group = NEW_INTEGER(ans_length)); nprotect++; for (i = 0; i < ans_length; i++) INTEGER(ranges_group)[i] = 1; /* make the XVectorList object */ PROTECT(ans = new_XVectorList_from_tags(classname, element_type, new_SharedVector_Pool, tags, ranges, ranges_group)); nprotect++; UNPROTECT(nprotect); return ans; } SEXP _new_XRawList_from_tag(const char *classname, const char *element_type, SEXP tag, SEXP ranges) { return new_XVectorList_from_tag(classname, element_type, _new_SharedRaw_Pool, tag, ranges); } SEXP _new_XIntegerList_from_tag(const char *classname, const char *element_type, SEXP tag, SEXP ranges) { return new_XVectorList_from_tag(classname, element_type, _new_SharedInteger_Pool, tag, ranges); } SEXP _new_XDoubleList_from_tag(const char *classname, const char *element_type, SEXP tag, SEXP ranges) { return new_XVectorList_from_tag(classname, element_type, _new_SharedDouble_Pool, tag, ranges); } /* Allocation WITHOUT initialization. * This is a soft limit. Some tags could be longer than this limit if the * XVectorList object to allocate contains elements that are also longer * than this limit. */ #define MAX_TAG_LENGTH 1073741824 static SEXP alloc_XVectorList(const char *classname, const char *element_type, const char *tag_type, SEXP width) { int ans_length, tag_length, new_tag_length, i, nelt; SEXP start, group, ranges, tags, tag, ans; IntAE tag_lengths; ans_length = LENGTH(width); PROTECT(start = NEW_INTEGER(ans_length)); PROTECT(group = NEW_INTEGER(ans_length)); tag_lengths = new_IntAE(0, 0, 0); if (ans_length != 0) { tag_length = 0; for (i = 0; i < ans_length; i++) { new_tag_length = tag_length + INTEGER(width)[i]; if (new_tag_length > MAX_TAG_LENGTH || new_tag_length < tag_length) { IntAE_insert_at(&tag_lengths, IntAE_get_nelt(&tag_lengths), tag_length); tag_length = 0; } INTEGER(start)[i] = tag_length + 1; INTEGER(group)[i] = IntAE_get_nelt(&tag_lengths) + 1; tag_length += INTEGER(width)[i]; } IntAE_insert_at(&tag_lengths, IntAE_get_nelt(&tag_lengths), tag_length); } PROTECT(ranges = new_IRanges("IRanges", start, width, NULL)); nelt = IntAE_get_nelt(&tag_lengths); PROTECT(tags = NEW_LIST(nelt)); if (strcmp(tag_type, "raw") == 0) { for (i = 0; i < nelt; i++) { PROTECT(tag = NEW_RAW(tag_lengths.elts[i])); SET_VECTOR_ELT(tags, i, tag); UNPROTECT(1); } PROTECT(ans = _new_XRawList_from_tags(classname, element_type, tags, ranges, group)); } else if (strcmp(tag_type, "integer") == 0) { for (i = 0; i < nelt; i++) { PROTECT(tag = NEW_INTEGER(tag_lengths.elts[i])); SET_VECTOR_ELT(tags, i, tag); UNPROTECT(1); } PROTECT(ans = _new_XIntegerList_from_tags(classname, element_type, tags, ranges, group)); } else if (strcmp(tag_type, "double") == 0) { for (i = 0; i < nelt; i++) { PROTECT(tag = NEW_NUMERIC(tag_lengths.elts[i])); SET_VECTOR_ELT(tags, i, tag); UNPROTECT(1); } PROTECT(ans = _new_XDoubleList_from_tags(classname, element_type, tags, ranges, group)); } else { UNPROTECT(4); error("IRanges internal error in alloc_XVectorList(): " "%s: invalid 'tag_type'", tag_type); } UNPROTECT(5); return ans; } SEXP _alloc_XRawList(const char *classname, const char *element_type, SEXP width) { return alloc_XVectorList(classname, element_type, "raw", width); } SEXP _alloc_XIntegerList(const char *classname, const char *element_type, SEXP width) { return alloc_XVectorList(classname, element_type, "integer", width); } SEXP _alloc_XDoubleList(const char *classname, const char *element_type, SEXP width) { return alloc_XVectorList(classname, element_type, "double", width); } /* More constructors. */ SEXP _new_XRawList_from_CharAEAE(const char *classname, const char *element_type, const CharAEAE *char_aeae, SEXP lkup) { const int *lkup0; int lkup_length, nelt, i; SEXP ans_width, ans; const CharAE *src; cachedXVectorList cached_ans; cachedCharSeq dest; if (lkup == R_NilValue) { lkup0 = NULL; } else { lkup0 = INTEGER(lkup); lkup_length = LENGTH(lkup); } nelt = CharAEAE_get_nelt(char_aeae); PROTECT(ans_width = NEW_INTEGER(nelt)); for (i = 0; i < nelt; i++) { src = char_aeae->elts + i; INTEGER(ans_width)[i] = CharAE_get_nelt(src); } PROTECT(ans = _alloc_XRawList(classname, element_type, ans_width)); cached_ans = _cache_XVectorList(ans); for (i = 0; i < nelt; i++) { src = char_aeae->elts + i; dest = _get_cachedXRawList_elt(&cached_ans, i); /* dest.seq is a const char * so we need to cast it to char * before we can write to it */ _Ocopy_bytes_to_i1i2_with_lkup(0, dest.length - 1, (char *) dest.seq, dest.length, src->elts, CharAE_get_nelt(src), lkup0, lkup_length); } UNPROTECT(2); return ans; } SEXP _new_XIntegerList_from_IntAEAE(const char *classname, const char *element_type, const IntAEAE *int_aeae) { int nelt, i; SEXP ans_width, ans; const IntAE *src; cachedXVectorList cached_ans; cachedIntSeq dest; nelt = IntAEAE_get_nelt(int_aeae); PROTECT(ans_width = NEW_INTEGER(nelt)); for (i = 0; i < nelt; i++) { src = int_aeae->elts + i; INTEGER(ans_width)[i] = IntAE_get_nelt(src); } PROTECT(ans = _alloc_XIntegerList(classname, element_type, ans_width)); cached_ans = _cache_XVectorList(ans); for (i = 0; i < nelt; i++) { src = int_aeae->elts + i; dest = _get_cachedXIntegerList_elt(&cached_ans, i); /* dest.seq is a const int * so we need to cast it to char * before we can write to it */ _Ocopy_byteblocks_to_i1i2(0, dest.length - 1, (char *) dest.seq, dest.length, (const char *) src->elts, IntAE_get_nelt(src), sizeof(int)); } UNPROTECT(2); return ans; } XVector/src/XVector_class.c0000644000126300012640000001166712227150112017245 0ustar00biocbuildphs_compbio/**************************************************************************** * Low-level manipulation of XVector objects * * Author: Herve Pages * ****************************************************************************/ #include "XVector.h" static int debug = 0; SEXP debug_XVector_class() { #ifdef DEBUG_XVECTOR 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; } /**************************************************************************** * C-level slot getters. * * Be careful that these functions do NOT duplicate the returned slot. * Thus they cannot be made .Call entry points! */ static SEXP shared_symbol = NULL, offset_symbol = NULL, length_symbol = NULL; SEXP _get_XVector_shared(SEXP x) { INIT_STATIC_SYMBOL(shared) return GET_SLOT(x, shared_symbol); } int _get_XVector_offset(SEXP x) { INIT_STATIC_SYMBOL(offset) return INTEGER(GET_SLOT(x, offset_symbol))[0]; } int _get_XVector_length(SEXP x) { INIT_STATIC_SYMBOL(length) return INTEGER(GET_SLOT(x, length_symbol))[0]; } /* Not a strict "slot getter" but very much like. */ SEXP _get_XVector_tag(SEXP x) { return _get_SharedVector_tag(_get_XVector_shared(x)); } /**************************************************************************** * Caching. */ cachedCharSeq _cache_XRaw(SEXP x) { cachedCharSeq cached_x; SEXP tag; int offset; tag = _get_XVector_tag(x); offset = _get_XVector_offset(x); cached_x.seq = (const char *) (RAW(tag) + offset); cached_x.length = _get_XVector_length(x); return cached_x; } cachedIntSeq _cache_XInteger(SEXP x) { cachedIntSeq cached_x; SEXP tag; int offset; tag = _get_XVector_tag(x); offset = _get_XVector_offset(x); cached_x.seq = (const int *) (INTEGER(tag) + offset); cached_x.length = _get_XVector_length(x); return cached_x; } cachedDoubleSeq _cache_XDouble(SEXP x) { cachedDoubleSeq cached_x; SEXP tag; int offset; tag = _get_XVector_tag(x); offset = _get_XVector_offset(x); cached_x.seq = (const double *) (REAL(tag) + offset); cached_x.length = _get_XVector_length(x); return cached_x; } /**************************************************************************** * C-level slot setters. * * Be careful that these functions do NOT duplicate the assigned value! */ static void set_XVector_shared(SEXP x, SEXP value) { INIT_STATIC_SYMBOL(shared) SET_SLOT(x, shared_symbol, value); return; } static void set_XVector_offset(SEXP x, SEXP value) { INIT_STATIC_SYMBOL(offset) SET_SLOT(x, offset_symbol, value); return; } static void set_XVector_length(SEXP x, SEXP value) { INIT_STATIC_SYMBOL(length) SET_SLOT(x, length_symbol, value); return; } static void set_XVector_slots(SEXP x, SEXP shared, SEXP offset, SEXP length) { set_XVector_shared(x, shared); set_XVector_offset(x, offset); set_XVector_length(x, length); } /**************************************************************************** * C-level constructors. * * Be careful that these functions do NOT duplicate their arguments before * putting them in the slots of the returned object. * Thus they cannot be made .Call entry points! */ SEXP _new_XVector(const char *classname, SEXP shared, int offset, int length) { SEXP classdef, ans, ans_offset, ans_length; PROTECT(classdef = MAKE_CLASS(classname)); PROTECT(ans = NEW_OBJECT(classdef)); PROTECT(ans_offset = ScalarInteger(offset)); PROTECT(ans_length = ScalarInteger(length)); set_XVector_slots(ans, shared, ans_offset, ans_length); UNPROTECT(4); return ans; } SEXP _new_XRaw_from_tag(const char *classname, SEXP tag) { SEXP shared, ans; PROTECT(shared = _new_SharedVector("SharedRaw", tag)); PROTECT(ans = _new_XVector(classname, shared, 0, LENGTH(tag))); UNPROTECT(2); return ans; } SEXP _new_XInteger_from_tag(const char *classname, SEXP tag) { SEXP shared, ans; PROTECT(shared = _new_SharedVector("SharedInteger", tag)); PROTECT(ans = _new_XVector(classname, shared, 0, LENGTH(tag))); UNPROTECT(2); return ans; } SEXP _new_XDouble_from_tag(const char *classname, SEXP tag) { SEXP shared, ans; PROTECT(shared = _new_SharedVector("SharedDouble", tag)); PROTECT(ans = _new_XVector(classname, shared, 0, LENGTH(tag))); UNPROTECT(2); return ans; } /* Allocation WITHOUT initialization. */ SEXP _alloc_XRaw(const char *classname, int length) { SEXP tag, ans; PROTECT(tag = NEW_RAW(length)); PROTECT(ans = _new_XRaw_from_tag(classname, tag)); UNPROTECT(2); return ans; } SEXP _alloc_XInteger(const char *classname, int length) { SEXP tag, ans; PROTECT(tag = NEW_INTEGER(length)); PROTECT(ans = _new_XInteger_from_tag(classname, tag)); UNPROTECT(2); return ans; } SEXP _alloc_XDouble(const char *classname, int length) { SEXP tag, ans; PROTECT(tag = NEW_NUMERIC(length)); PROTECT(ans = _new_XDouble_from_tag(classname, tag)); UNPROTECT(2); return ans; } XVector/src/slice_methods.c0000644000126300012640000000543212227150112017301 0ustar00biocbuildphs_compbio#include "XVector.h" #include "IRanges_interface.h" /* * --- .Call ENTRY POINT --- */ SEXP XInteger_slice(SEXP x, SEXP lower, SEXP upper) { cachedIntSeq X; SEXP ans, start, width; int i, ans_length; const int *X_elt; int *start_elt, *width_elt, lower_elt, upper_elt, curr_elt, prev_elt; lower_elt = INTEGER(lower)[0]; upper_elt = INTEGER(upper)[0]; X = _cache_XInteger(x); ans_length = 0; prev_elt = 0; for (i = 1, X_elt = X.seq; i <= X.length; i++, X_elt++) { curr_elt = (*X_elt >= lower_elt) && (*X_elt <= upper_elt); if (curr_elt && !prev_elt) ans_length++; prev_elt = curr_elt; } PROTECT(start = NEW_INTEGER(ans_length)); PROTECT(width = NEW_INTEGER(ans_length)); if (ans_length > 0) { start_elt = INTEGER(start) - 1; width_elt = INTEGER(width) - 1; prev_elt = 0; for (i = 1, X_elt = X.seq; i <= X.length; i++, X_elt++) { curr_elt = (*X_elt >= lower_elt) && (*X_elt <= upper_elt); if (curr_elt) { if (prev_elt) *width_elt += 1; else { start_elt++; width_elt++; *start_elt = i; *width_elt = 1; } } prev_elt = curr_elt; } } PROTECT(ans = new_IRanges("IRanges", start, width, R_NilValue)); UNPROTECT(3); return ans; } static int gt(double x, double y) { return x > y; } static int lt(double x, double y) { return x < y; } static int ge(double x, double y) { return x >= y; } static int le(double x, double y) { return x <= y; } /* * --- .Call ENTRY POINT --- */ SEXP XDouble_slice(SEXP x, SEXP lower, SEXP upper, SEXP include_lower, SEXP include_upper) { cachedDoubleSeq X; SEXP ans, start, width; int i, ans_length; const double *X_elt; int *start_elt, *width_elt, curr_elt, prev_elt; double lower_elt, upper_elt; int (*lower_fun)(double, double); int (*upper_fun)(double, double); lower_fun = LOGICAL(include_lower)[0] ? &ge : > upper_fun = LOGICAL(include_upper)[0] ? &le : < lower_elt = REAL(lower)[0]; upper_elt = REAL(upper)[0]; X = _cache_XDouble(x); ans_length = 0; prev_elt = 0; for (i = 1, X_elt = X.seq; i <= X.length; i++, X_elt++) { curr_elt = lower_fun(*X_elt, lower_elt) && upper_fun(*X_elt, upper_elt); if (curr_elt && !prev_elt) ans_length++; prev_elt = curr_elt; } PROTECT(start = NEW_INTEGER(ans_length)); PROTECT(width = NEW_INTEGER(ans_length)); if (ans_length > 0) { start_elt = INTEGER(start) - 1; width_elt = INTEGER(width) - 1; prev_elt = 0; for (i = 1, X_elt = X.seq; i <= X.length; i++, X_elt++) { curr_elt = lower_fun(*X_elt, lower_elt) && upper_fun(*X_elt, upper_elt); if (curr_elt) { if (prev_elt) *width_elt += 1; else { start_elt++; width_elt++; *start_elt = i; *width_elt = 1; } } prev_elt = curr_elt; } } PROTECT(ans = new_IRanges("IRanges", start, width, R_NilValue)); UNPROTECT(3); return ans; } XVector/src/vector_copy.c0000644000126300012640000002327612227150112017021 0ustar00biocbuildphs_compbio/**************************************************************************** * Low-level utilities for copying data * * from a vector to a vector of the same type * ****************************************************************************/ #include "XVector.h" #include "IRanges_interface.h" /**************************************************************************** * A. _vector_Ocopy() * ================== * * 'Omode' controls on which side recycling must happen: * - Omode = 0: straight copying (no recycling); * - Omode = 1: cyclic writing to 'out'; * - Omode = -1: cyclic reading from 'in' (doesn't support reverse mode). * TODO: Add support for STRSXP and VECSXP. */ void _vector_Ocopy(SEXP out, int out_offset, SEXP in, int in_offset, int nelt, SEXP lkup, int reverse, int Omode) { void (*Ocopy_bytes)(int, int, char *, int, const char *, int, const int *, int); void (*Ocopy_byteblocks)(int, int, char *, size_t, const char *, size_t, size_t); int dest_nelt, src_nelt, i1, i2; char *dest = NULL, *src = NULL; /* gcc -Wall */ size_t blocksize = 0; /* gcc -Wall */ if (lkup == R_NilValue && reverse == 0 && Omode == 0) { vector_memcpy(out, out_offset, in, in_offset, nelt); return; } if (Omode >= 0) { if (out_offset < 0) error("subscripts out of bounds"); if (Omode == 0) { if (out_offset + nelt > LENGTH(out)) error("subscripts out of bounds"); dest_nelt = nelt; } else { dest_nelt = LENGTH(out) - out_offset; } if (reverse) { Ocopy_bytes = _Orevcopy_bytes_from_i1i2_with_lkup; Ocopy_byteblocks = _Orevcopy_byteblocks_from_i1i2; } else { Ocopy_bytes = _Ocopy_bytes_from_i1i2_with_lkup; Ocopy_byteblocks = _Ocopy_byteblocks_from_i1i2; } i1 = in_offset; in_offset = 0; src_nelt = LENGTH(in); } else { if (in_offset < 0) error("subscripts out of bounds"); src_nelt = LENGTH(in) - in_offset; if (reverse) error("XVector internal error in _vector_Ocopy(): " "reverse mode not supported when Omode = -1"); Ocopy_bytes = _Ocopy_bytes_to_i1i2_with_lkup; Ocopy_byteblocks = _Ocopy_byteblocks_to_i1i2; i1 = out_offset; out_offset = 0; dest_nelt = LENGTH(out); } i2 = i1 + nelt - 1; switch (TYPEOF(out)) { case RAWSXP: dest = (char *) (RAW(out) + out_offset); src = (char *) (RAW(in) + in_offset); if (lkup != R_NilValue) { Ocopy_bytes(i1, i2, dest, dest_nelt, src, src_nelt, INTEGER(lkup), LENGTH(lkup)); return; } blocksize = sizeof(Rbyte); break; case LGLSXP: dest = (char *) (LOGICAL(out) + out_offset); src = (char *) (LOGICAL(in) + in_offset); blocksize = sizeof(int); break; case INTSXP: dest = (char *) (INTEGER(out) + out_offset); src = (char *) (INTEGER(in) + in_offset); blocksize = sizeof(int); break; case REALSXP: dest = (char *) (REAL(out) + out_offset); src = (char *) (REAL(in) + in_offset); blocksize = sizeof(double); break; case CPLXSXP: dest = (char *) (COMPLEX(out) + out_offset); src = (char *) (COMPLEX(in) + in_offset); blocksize = sizeof(Rcomplex); break; default: error("XVector internal error in _vector_Ocopy(): " "%s type not supported", CHAR(type2str(TYPEOF(out)))); return; // gcc -Wall } Ocopy_byteblocks(i1, i2, dest, dest_nelt, src, src_nelt, blocksize); return; } /**************************************************************************** * B. CYCLIC COPYING * ================= * * The functions in this section implement cyclic copying. The user can * choose between 2 interfaces for specifying elements in the 'in' or 'out' * vectors: * * 1. The "offset/nelt" interface: the elements to access are specified via * 2 integers: 'offset' (the 0-based position of the first element to access) * and 'nelt' (the number of elements to access, all immediately following * the first element to access). * * 2. The "subscript" interface: the elements to access are specified by an * integer vector containing their 1-based positions in the 'in' or 'out' * vectors. * * The "subscript" interface is intended to be used by the subsetting * operator [ defined at the R level for SharedVector objects. * Implementing this interface requires to pay some special attention to * the following important properties of the subsetting operator [ in R. * If x is a vector and i an integer vector of length n with the following * properties: * a) i contains no NA values, * b) i can be used to subset x without being "out of bounds" (i.e all * values in i are >= 1 and <= length(x)), * then we have the following properties: * 1) READING from x: y <- x[i] produces a vector, of the same type than x, * but of the same length than i (length(y) == n). * 2) READING from then WRITING to x: x[i] <- x[i] (short for y <- x[i]; * x[i] <- y) doesn't modify the values in x. * 3) WRITING to then READING from x: if z is a vector of length n and of * the same type than x, then doing x[i] <- z; y <- x[i] guarantees that * y is identical to z only when i contains no repeated value! * * Functions in this file that implement the "subscript" interface adhere to * the above properties. */ /* * INTERFACE: "offset/nelt". * RECYCLING: Cyclic writing to 'out'. * In addition, "raw" vectors support fast on-the-fly translation via the * 'lkup' table. * Reverts the order of the copied elements if 'reverse' is != 0. */ void _vector_Ocopy_from_offset(SEXP out, SEXP in, int in_offset, int nelt, SEXP lkup, int reverse) { _vector_Ocopy(out, 0, in, in_offset, nelt, lkup, reverse, 1); return; } /* * INTERFACE: "offset/nelt". * RECYCLING: Cyclic reading from 'in'. * In addition, "raw" vectors support fast on-the-fly translation via the * 'lkup' table. */ void _vector_Ocopy_to_offset(SEXP out, SEXP in, int out_offset, int nelt, SEXP lkup) { _vector_Ocopy(out, out_offset, in, 0, nelt, lkup, 0, -1); return; } /* * INTERFACE: "subscript". * RECYCLING: Cyclic writing to 'out'. * In addition, "raw" vectors support fast on-the-fly translation via the * 'lkup' table. * TODO: Add support for STRSXP and VECSXP. */ void _vector_Ocopy_from_subscript(SEXP out, SEXP in, SEXP subscript, SEXP lkup) { switch (TYPEOF(out)) { case RAWSXP: if (lkup == R_NilValue) _Ocopy_byteblocks_from_subscript( INTEGER(subscript), LENGTH(subscript), (char *) RAW(out), LENGTH(out), (char *) RAW(in), LENGTH(in), sizeof(Rbyte)); else _Ocopy_bytes_from_subscript_with_lkup( INTEGER(subscript), LENGTH(subscript), (char *) RAW(out), LENGTH(out), (char *) RAW(in), LENGTH(in), INTEGER(lkup), LENGTH(lkup)); break; case LGLSXP: case INTSXP: _Ocopy_byteblocks_from_subscript( INTEGER(subscript), LENGTH(subscript), (char *) INTEGER(out), LENGTH(out), (char *) INTEGER(in), LENGTH(in), sizeof(int)); break; case REALSXP: _Ocopy_byteblocks_from_subscript( INTEGER(subscript), LENGTH(subscript), (char *) REAL(out), LENGTH(out), (char *) REAL(in), LENGTH(in), sizeof(double)); break; case CPLXSXP: _Ocopy_byteblocks_from_subscript( INTEGER(subscript), LENGTH(subscript), (char *) COMPLEX(out), LENGTH(out), (char *) COMPLEX(in), LENGTH(in), sizeof(Rcomplex)); break; default: error("XVector internal error in _vector_Ocopy_from_subscript(): " "%s type not supported", CHAR(type2str(TYPEOF(out)))); } return; } /* * INTERFACE: "subscript". * RECYCLING: Cyclic reading from 'in'. * In addition, "raw" vectors support fast on-the-fly translation via the * 'lkup' table. * TODO: Add support for STRSXP and VECSXP. */ void _vector_Ocopy_to_subscript(SEXP out, SEXP in, SEXP subscript, SEXP lkup) { switch (TYPEOF(out)) { case RAWSXP: if (lkup == R_NilValue) _Ocopy_byteblocks_to_subscript( INTEGER(subscript), LENGTH(subscript), (char *) RAW(out), LENGTH(out), (char *) RAW(in), LENGTH(in), sizeof(Rbyte)); else _Ocopy_bytes_to_subscript_with_lkup( INTEGER(subscript), LENGTH(subscript), (char *) RAW(out), LENGTH(out), (char *) RAW(in), LENGTH(in), INTEGER(lkup), LENGTH(lkup)); break; case LGLSXP: case INTSXP: _Ocopy_byteblocks_to_subscript( INTEGER(subscript), LENGTH(subscript), (char *) INTEGER(out), LENGTH(out), (char *) INTEGER(in), LENGTH(in), sizeof(int)); break; case REALSXP: _Ocopy_byteblocks_to_subscript( INTEGER(subscript), LENGTH(subscript), (char *) REAL(out), LENGTH(out), (char *) REAL(in), LENGTH(in), sizeof(double)); break; case CPLXSXP: _Ocopy_byteblocks_to_subscript( INTEGER(subscript), LENGTH(subscript), (char *) COMPLEX(out), LENGTH(out), (char *) COMPLEX(in), LENGTH(in), sizeof(Rcomplex)); break; default: error("XVector internal error in _vector_Ocopy_to_subscript(): " "%s type not supported", CHAR(type2str(TYPEOF(out)))); } return; } /**************************************************************************** * C. COPYING MULTIPLE RANGES (NO RECYCLING) * ========================================= * * _vector_mcopy() supports: * - fast on-the-fly translation via the 'lkup' table (only on "raw" * vectors); * - reverse copy if 'reverse' is != 0. */ void _vector_mcopy(SEXP out, int out_offset, SEXP in, SEXP in_start, SEXP in_width, SEXP lkup, int reverse) { int nranges, i1, i2, j, in_offset, nelt; const int *in_start_p, *in_width_p; nranges = check_integer_pairs(in_start, in_width, &in_start_p, &in_width_p, "start", "width"); for (i1 = 0, i2 = nranges - 1; i1 < nranges; i1++, i2--) { j = reverse ? i2 : i1; in_offset = in_start_p[j] - 1; nelt = in_width_p[j]; if (nelt < 0) error("negative widths are not allowed"); _vector_Ocopy(out, out_offset, in, in_offset, nelt, lkup, reverse, 0); out_offset += nelt; } return; } XVector/src/view_summarization_methods.c0000644000126300012640000003022512227150112022134 0ustar00biocbuildphs_compbio#include "XVector.h" #include "IRanges_interface.h" #include #define R_INT_MIN (1+INT_MIN) /**************************************************************************** * Low-level operations on cachedIntSeq (sequences of ints) and * cachedDoubleSeq (sequences of doubles) structures. */ static cachedIntSeq get_cachedIntSeq_view(const cachedIntSeq *X, int view_start, int view_width) { cachedIntSeq X_view; int view_offset, tmp; view_offset = view_start - 1; /* Trim the view if it's "out of limits". */ if (view_offset < 0) { view_width += view_offset; view_offset = 0; } if (view_width > (tmp = X->length - view_offset)) view_width = tmp; X_view.seq = X->seq + view_offset; X_view.length = view_width; return X_view; } static cachedDoubleSeq get_cachedDoubleSeq_view(const cachedDoubleSeq *X, int view_start, int view_width) { cachedDoubleSeq X_view; int view_offset, tmp; view_offset = view_start - 1; /* Trim the view if it's "out of limits". */ if (view_offset < 0) { view_width += view_offset; view_offset = 0; } if (view_width > (tmp = X->length - view_offset)) view_width = tmp; X_view.seq = X->seq + view_offset; X_view.length = view_width; return X_view; } /* * Returns NA if 'X' is empty. Note that this differs from what * 'min(integer(0))' does: the latter returns 'Inf' (which is a double) and * issues a warning. * See C function imin() in the R source code (src/main/summary.c) for the * details. */ static int get_cachedIntSeq_min(const cachedIntSeq *X, int narm) { int xlen, val, i, x; xlen = X->length; val = NA_INTEGER; for (i = 0; i < xlen; i++) { x = X->seq[i]; if (x == NA_INTEGER) { if (narm) continue; return NA_INTEGER; } if (val == NA_INTEGER || x < val) val = x; } return val; } /* * Returns NA if 'X' contains NAs and/or NaNs and 'narm' is FALSE. Note that * this differs from what min() does on a standard double vector: the latter * will return NA if the input contains NAs, and NaN if it contains NaNs but * no NAs. * See C function rmin() in the R source code (src/main/summary.c) for the * details. */ static double get_cachedDoubleSeq_min(const cachedDoubleSeq *X, int narm) { int xlen, i; double val, x; xlen = X->length; val = R_PosInf; for (i = 0; i < xlen; i++) { x = X->seq[i]; if (ISNAN(x)) { /* NA or NaN */ if (narm) continue; return NA_REAL; } if (val == R_PosInf || x < val) val = x; } return val; } /* * Returns NA if 'X' is empty. Note that this differs from what * 'max(integer(0))' does: the latter returns '-Inf' (which is a double) and * issues a warning. * See C function imax() in the R source code (src/main/summary.c) for the * details. */ static int get_cachedIntSeq_max(const cachedIntSeq *X, int narm) { int xlen, val, i, x; xlen = X->length; val = NA_INTEGER; for (i = 0; i < xlen; i++) { x = X->seq[i]; if (x == NA_INTEGER) { if (narm) continue; return NA_INTEGER; } if (val == NA_INTEGER || x > val) val = x; } return val; } /* * Returns NA if 'X' contains NAs and/or NaNs and 'narm' is FALSE. Note that * this differs from what max() does on a standard double vector: the latter * will return NA if the input contains NAs, and NaN if it contains NaNs but * no NAs. * See C function rmax() in the R source code (src/main/summary.c) for the * details. */ static double get_cachedDoubleSeq_max(const cachedDoubleSeq *X, int narm) { int xlen, i; double val, x; xlen = X->length; val = R_NegInf; for (i = 0; i < xlen; i++) { x = X->seq[i]; if (ISNAN(x)) { /* NA or NaN */ if (narm) continue; return NA_REAL; } if (val == R_NegInf || x > val) val = x; } return val; } static int get_cachedIntSeq_sum(const cachedIntSeq *X, int narm) { int xlen, val, i, x; xlen = X->length; val = 0; for (i = 0; i < xlen; i++) { x = X->seq[i]; if (x == NA_INTEGER) { if (narm) continue; return NA_INTEGER; } if ((x > 0 && INT_MAX - x < val) || (x < 0 && R_INT_MIN - x > val)) { warning("Integer overflow"); return NA_INTEGER; } val += x; } return val; } /* * Mimics exactly what sum() does on a standard double vector. * See C function rsum() in the R source code (src/main/summary.c) for the * details. */ static double get_cachedDoubleSeq_sum(const cachedDoubleSeq *X, int narm) { int xlen, i; double val, x; xlen = X->length; val = 0.00; for (i = 0; i < xlen; i++) { x = X->seq[i]; if (narm && ISNAN(x)) /* expensive ISNAN(x) in 2nd place */ continue; val += x; } return val; } /* TODO: Compare the code below with what which.min() does on a standard * integer vector. */ static int get_cachedIntSeq_which_min(const cachedIntSeq *X, int narm) { int xlen, cur_min, which_min, i, x; xlen = X->length; which_min = NA_INTEGER; for (i = 0; i < xlen; i++) { x = X->seq[i]; if (x == NA_INTEGER) { if (narm) continue; return xlen == 1 ? 1 : NA_INTEGER; } if (which_min == NA_INTEGER || x < cur_min) { cur_min = x; which_min = i + 1; } } return which_min; } /* The code below does something *close* but not identical to what which.min() * does on a standard double vector. * TODO: See do_first_min() C function in the R source code * (src/main/summary.c) for what standard which.min() does and maybe adjust * the code below. */ static int get_cachedDoubleSeq_which_min(const cachedDoubleSeq *X, int narm) { int xlen, i, which_min; double cur_min, x; xlen = X->length; which_min = NA_INTEGER; for (i = 0; i < xlen; i++) { x = X->seq[i]; if (ISNAN(x)) { /* NA or NaN */ if (narm) continue; return xlen == 1 ? 1 : NA_INTEGER; } if (which_min == NA_INTEGER || x < cur_min) { cur_min = x; which_min = i + 1; } } return which_min; } /* TODO: Compare the code below with what which.max() does on a standard * integer vector. */ static int get_cachedIntSeq_which_max(const cachedIntSeq *X, int narm) { int xlen, cur_max, which_max, i, x; xlen = X->length; which_max = NA_INTEGER; for (i = 0; i < xlen; i++) { x = X->seq[i]; if (x == NA_INTEGER) { if (narm) continue; return xlen == 1 ? 1 : NA_INTEGER; } if (which_max == NA_INTEGER || x > cur_max) { cur_max = x; which_max = i + 1; } } return which_max; } /* The code below does something *close* but not identical to what which.max() * does on a standard double vector. * TODO: See do_first_min() C function in the R source code * (src/main/summary.c) for what standard which.max() does and maybe adjust * the code below. */ static int get_cachedDoubleSeq_which_max(const cachedDoubleSeq *X, int narm) { int xlen, i, which_max; double cur_max, x; xlen = X->length; which_max = NA_INTEGER; for (i = 0; i < xlen; i++) { x = X->seq[i]; if (ISNAN(x)) { /* NA or NaN */ if (narm) continue; return xlen == 1 ? 1 : NA_INTEGER; } if (which_max == NA_INTEGER || x > cur_max) { cur_max = x; which_max = i + 1; } } return which_max; } /**************************************************************************** * XIntegerViews_summary1() and XDoubleViews_summary1() .Call entry points * for fast view summary methods: viewMins, viewMaxs, viewSums. */ SEXP XIntegerViews_summary1(SEXP x, SEXP na_rm, SEXP method) { SEXP ans, subject; cachedIntSeq S, S_view; cachedIRanges cached_ranges; const char *funname; int (*fun)(const cachedIntSeq *, int); int ans_length, v, view_start, view_width, *ans_elt; subject = GET_SLOT(x, install("subject")); S = _cache_XInteger(subject); cached_ranges = cache_IRanges(GET_SLOT(x, install("ranges"))); funname = CHAR(STRING_ELT(method, 0)); if (strcmp(funname, "viewMins") == 0) fun = &get_cachedIntSeq_min; else if (strcmp(funname, "viewMaxs") == 0) fun = &get_cachedIntSeq_max; else if (strcmp(funname, "viewSums") == 0) fun = &get_cachedIntSeq_sum; else error("XVector internal error in XIntegerViews_summary1(): " "invalid method \"%s\"", funname); ans_length = get_cachedIRanges_length(&cached_ranges); PROTECT(ans = NEW_INTEGER(ans_length)); for (v = 0, ans_elt = INTEGER(ans); v < ans_length; v++, ans_elt++) { view_start = get_cachedIRanges_elt_start(&cached_ranges, v); view_width = get_cachedIRanges_elt_width(&cached_ranges, v); S_view = get_cachedIntSeq_view(&S, view_start, view_width); *ans_elt = fun(&S_view, LOGICAL(na_rm)[0]); } UNPROTECT(1); return ans; } SEXP XDoubleViews_summary1(SEXP x, SEXP na_rm, SEXP method) { SEXP ans, subject; cachedDoubleSeq S, S_view; cachedIRanges cached_ranges; const char *funname; double (*fun)(const cachedDoubleSeq *, int); int ans_length, v, view_start, view_width; double *ans_elt; subject = GET_SLOT(x, install("subject")); S = _cache_XDouble(subject); cached_ranges = cache_IRanges(GET_SLOT(x, install("ranges"))); funname = CHAR(STRING_ELT(method, 0)); if (strcmp(funname, "viewMins") == 0) fun = &get_cachedDoubleSeq_min; else if (strcmp(funname, "viewMaxs") == 0) fun = &get_cachedDoubleSeq_max; else if (strcmp(funname, "viewSums") == 0) fun = &get_cachedDoubleSeq_sum; else error("IRanges internal error in XDoubleViews_summary1(): " "invalid method \"%s\"", funname); ans_length = get_cachedIRanges_length(&cached_ranges); PROTECT(ans = NEW_NUMERIC(ans_length)); for (v = 0, ans_elt = REAL(ans); v < ans_length; v++, ans_elt++) { view_start = get_cachedIRanges_elt_start(&cached_ranges, v); view_width = get_cachedIRanges_elt_width(&cached_ranges, v); S_view = get_cachedDoubleSeq_view(&S, view_start, view_width); *ans_elt = fun(&S_view, LOGICAL(na_rm)[0]); } UNPROTECT(1); return ans; } /**************************************************************************** * XIntegerViews_summary2() and XDoubleViews_summary2() .Call entry points * for fast view summary methods: viewWhichMins, viewWhichMaxs. */ SEXP XIntegerViews_summary2(SEXP x, SEXP na_rm, SEXP method) { SEXP ans, subject; cachedIntSeq S, S_view; cachedIRanges cached_ranges; const char *funname; int (*fun)(const cachedIntSeq *, int); int ans_length, v, view_start, view_width, *ans_elt, which_min; subject = GET_SLOT(x, install("subject")); S = _cache_XInteger(subject); cached_ranges = cache_IRanges(GET_SLOT(x, install("ranges"))); funname = CHAR(STRING_ELT(method, 0)); if (strcmp(funname, "viewWhichMins") == 0) fun = &get_cachedIntSeq_which_min; else if (strcmp(funname, "viewWhichMaxs") == 0) fun = &get_cachedIntSeq_which_max; else error("XVector internal error in XIntegerViews_summary2(): " "invalid method \"%s\"", funname); ans_length = get_cachedIRanges_length(&cached_ranges); PROTECT(ans = NEW_INTEGER(ans_length)); for (v = 0, ans_elt = INTEGER(ans); v < ans_length; v++, ans_elt++) { view_start = get_cachedIRanges_elt_start(&cached_ranges, v); view_width = get_cachedIRanges_elt_width(&cached_ranges, v); S_view = get_cachedIntSeq_view(&S, view_start, view_width); which_min = fun(&S_view, LOGICAL(na_rm)[0]); if (which_min == NA_INTEGER) *ans_elt = which_min; else *ans_elt = S_view.seq - S.seq + which_min; } UNPROTECT(1); return ans; } SEXP XDoubleViews_summary2(SEXP x, SEXP na_rm, SEXP method) { SEXP ans, subject; cachedDoubleSeq S, S_view; cachedIRanges cached_ranges; const char *funname; int (*fun)(const cachedDoubleSeq *, int); int ans_length, v, view_start, view_width, *ans_elt, which_min; subject = GET_SLOT(x, install("subject")); S = _cache_XDouble(subject); cached_ranges = cache_IRanges(GET_SLOT(x, install("ranges"))); funname = CHAR(STRING_ELT(method, 0)); if (strcmp(funname, "viewWhichMins") == 0) fun = &get_cachedDoubleSeq_which_min; else if (strcmp(funname, "viewWhichMaxs") == 0) fun = &get_cachedDoubleSeq_which_max; else error("IRanges internal error in XDoubleViews_summary2(): " "invalid method \"%s\"", funname); ans_length = get_cachedIRanges_length(&cached_ranges); PROTECT(ans = NEW_INTEGER(ans_length)); for (v = 0, ans_elt = INTEGER(ans); v < ans_length; v++, ans_elt++) { view_start = get_cachedIRanges_elt_start(&cached_ranges, v); view_width = get_cachedIRanges_elt_width(&cached_ranges, v); S_view = get_cachedDoubleSeq_view(&S, view_start, view_width); which_min = fun(&S_view, LOGICAL(na_rm)[0]); if (which_min == NA_INTEGER) *ans_elt = which_min; else *ans_elt = S_view.seq - S.seq + which_min; } UNPROTECT(1); return ans; } XVector/tests/0000755000126300012640000000000012227065007014672 5ustar00biocbuildphs_compbioXVector/tests/run_unitTests.R0000644000126300012640000000012712227065007017703 0ustar00biocbuildphs_compbiorequire("XVector") || stop("unable to load XVector package") XVector:::run_unitTests()