XVector/DESCRIPTION0000644000175200017520000000313114710323443014673 0ustar00biocbuildbiocbuildPackage: XVector Title: Foundation of external vector representation and manipulation in Bioconductor Description: Provides memory efficient S4 classes for storing sequences "externally" (e.g. behind an R external pointer, or on disk). biocViews: Infrastructure, DataRepresentation URL: https://bioconductor.org/packages/XVector BugReports: https://github.com/Bioconductor/XVector/issues Version: 0.46.0 License: Artistic-2.0 Encoding: UTF-8 Author: Hervé Pagès and Patrick Aboyoun Maintainer: Hervé Pagès Depends: R (>= 4.0.0), methods, BiocGenerics (>= 0.37.0), S4Vectors (>= 0.27.12), IRanges (>= 2.23.9) Imports: methods, utils, tools, zlibbioc, BiocGenerics, S4Vectors, IRanges LinkingTo: S4Vectors, IRanges Suggests: Biostrings, drosophila2probe, RUnit Collate: io-utils.R RDS-random-access.R 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 RdaCollection-class.R RdsCollection-class.R intra-range-methods.R compact-methods.R reverse-methods.R slice-methods.R view-summarization-methods.R updateObject-methods.R zzz.R git_url: https://git.bioconductor.org/packages/XVector git_branch: RELEASE_3_20 git_last_commit: 1c8f81d git_last_commit_date: 2024-10-29 Repository: Bioconductor 3.20 Date/Publication: 2024-10-29 NeedsCompilation: yes Packaged: 2024-10-30 03:25:23 UTC; biocbuild XVector/MD50000644000175200017520000000762714710323443013513 0ustar00biocbuildbiocbuild6a5ddd39ee2a583aad9ebd720c42a691 *DESCRIPTION ad1d78ab7f7d676e83bf2e73f01ba376 *NAMESPACE 7178f0c1acfe4a2727348d9b34bf0446 *R/OnDiskRaw-class.R 70e2fea8e7e65e38d245bc97036bc0dd *R/RDS-random-access.R ec2662485a365b1bbef3cce9f77e14c5 *R/RdaCollection-class.R 4b59f3e5d139d3f24e8c1d72f49eb206 *R/RdsCollection-class.R bd26ff0c8b13e6729bc7a611467dd47c *R/SharedDouble-class.R 5ad91cc5e67b3ef01dcbacb8806cfdde *R/SharedInteger-class.R 165bbddde77b02c6ad436ddb289d9ec3 *R/SharedRaw-class.R 61dde670146f721920683d0baa6df4ff *R/SharedVector-class.R d6673fb2050cec33a2ff0e25485115ab *R/XDouble-class.R 43e5de528bbf5535d5f5f9b0a0a893f2 *R/XDoubleViews-class.R 4f789f6013740fb19e4c15a230a41468 *R/XInteger-class.R b95cbadbde8cbe17f3f8812f79a66cb5 *R/XIntegerViews-class.R 5b5da2560f4bbff6628b28a709574589 *R/XRaw-class.R c1d8ca4a25a789a229bddad996fbbcdb *R/XRawList-class.R a510aa4d920e2ce3072626b50ae1d0e0 *R/XRawList-comparison.R 29c5b93a8574b72ada3cf933d996bfdb *R/XVector-class.R 511b8fd665456bac5c9ecf42abea1042 *R/XVectorList-class.R 0d6dcb5793138bb77ee1f30fffc86c80 *R/compact-methods.R 1033df1395ab382aa5e30d42c8c3fdc3 *R/intra-range-methods.R aada1e486cd9e16ca47182ed9f38b785 *R/io-utils.R 60f3b4b80421687e299a92cd3362a790 *R/reverse-methods.R 5b8a71e56a0ce9bdda87315ebc63ae34 *R/slice-methods.R 415ac8b30ca8b415fd7cd5bf18780a24 *R/updateObject-methods.R c6c7a43259d21e4876755f5bd235daa3 *R/view-summarization-methods.R c492b4ef1eb85ed40df7436b531f3009 *R/zzz.R 0791ef066299ba6362d60a5630903b85 *README.md d74302a75e588df4e664687a32e5f81b *TODO 88002124148a4395204e63bd171ca536 *inst/include/XVector_defines.h 4710b0530ce1401dbc1081824e1964cd *inst/include/XVector_interface.h 39a1c40ca271b177d03cf8847afb9551 *inst/include/_XVector_stubs.c f97ffc3063b771fcbeb2a1ab87d39f84 *inst/unitTests/test_slice-methods.R fa93017a37a34799fb092fe46f7b2f04 *inst/unitTests/test_view-summarization-methods.R 6b3cd1f66949f6ddfde1c598d4bd8696 *man/OnDiskRaw-class.Rd 53e5bcec488f0ac62eeea49625958a00 *man/XDoubleViews-class.Rd ac90cd69bb3450f644d705efd8bb44df *man/XIntegerViews-class.Rd 3fd8330728225fd09df43dab5423dee7 *man/XRawList-class.Rd 2c8e666ed0cbec12431770b156c0169f *man/XRawList-comparison.Rd 1df0520a85a34381b2e9ba2f85aa42e0 *man/XVector-class.Rd 43b4b5da7d3a6ffa5d3498394c3d9c97 *man/XVector-internals.Rd e4ab36bb2eee348df989da4c2f666017 *man/XVectorList-class.Rd 766abd1a57961fab5d11862d57d6a920 *man/compact-methods.Rd 4e28a8def62d6527834276ada6db7ca5 *man/intra-range-methods.Rd 151b5d683c6b7d0886da5c4da55873c3 *man/reverse-methods.Rd 244f20bc387d8c5d6005728a5e434891 *man/slice-methods.Rd e3a19c17e392412dfc463947b1d09465 *man/updateObject-methods.Rd 3980078a842b9724e4cc2a8d812ff622 *man/view-summarization-methods.Rd b0447144238dce005a1fa8a625d1563c *src/IRanges_stubs.c 8a8d0e197e34e74255eb32ccb53887c3 *src/Makevars b50f96f87428681558c8d1c4cb3de00d *src/Makevars.win f7e64fcf584d27da6b84b3d06d4a156c *src/Ocopy_byteblocks.c c64cd57d670b933995f35f9962d433cc *src/RDS_random_access.c fdf61a6381b6caba121577108b2fa1a6 *src/R_init_XVector.c bab0b4b09cf160fa0109ae25fbb471ef *src/S4Vectors_stubs.c f9a661dee58a856e638a61c969168371 *src/SharedDouble_class.c 8d9e5527ae53765473e3191db2f57645 *src/SharedInteger_class.c 47de0764a18c4e9df1b140f6fa72f48c *src/SharedRaw_class.c 87014c46b5833f3274eb7bd4a7d21bd0 *src/SharedVector_class.c a34db1d7915af11f762afc8671c99755 *src/XDouble_class.c ac8f3e7784992d1b7a692991dcc75fa7 *src/XInteger_class.c 2a68c03990e4dd451180191347e56690 *src/XRawList_comparison.c 3eabeb3cd961848362801b909cdd85c0 *src/XRaw_class.c e87eb567d1baa97205333b4291fbf4f0 *src/XVector.h 83b7eef4521dc595009f5bd705ce4f5a *src/XVectorList_class.c e1cef31e2d85e1ae83853f4ad9d16ab8 *src/XVector_class.c 163f4aa6cfc19d08f9b026431aed8019 *src/io_utils.c 30419f0d0a8d45a71bf8355d03065832 *src/slice_methods.c ee1ef45813f8578fc8c972b76baf8d37 *src/vector_copy.c 33310e4defa8ce1f57893beddc018f7f *src/view_summarization_methods.c 42870dfc470fede28d6881e355511172 *tests/run_unitTests.R XVector/NAMESPACE0000644000175200017520000000600614710220211014375 0ustar00biocbuildbiocbuilduseDynLib(XVector) import(methods) importFrom(utils, relist, download.file) importFrom(tools, file_path_as_absolute) import(zlibbioc) import(BiocGenerics) import(S4Vectors) import(IRanges) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S4 classes ### exportClasses( SharedVector, SharedVector_Pool, SharedRaw, SharedRaw_Pool, SharedInteger, SharedDouble, XVector, XRaw, XInteger, XDouble, GroupedIRanges, XVectorList, XRawList, XIntegerViews, RdaCollection, RdsCollection ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### 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( ## Methods for generics defined in the base package: length, names, "names<-", "[", "[<-", "[[", "[[<-", rev, as.vector, as.integer, as.numeric, as.raw, as.data.frame, toString, c, "==", "!=", "<=", duplicated, match, order, rank, is.unsorted, ## Methods for generics defined in the methods package: show, coerce, ## Methods for generics defined in the utils package: relist, ## Methods for generics defined in the BiocGenerics package: updateObject, width, path, ## Methods for generics defined in the S4Vectors package: showAsCell, bindROWS, extractROWS, getListElement, parallel_slot_names, pcompare, elementNROWS, relistToClass, ## Methods for generics defined in the IRanges package: Views, viewMins, viewMaxs, viewSums, viewMeans, viewWhichMins, viewWhichMaxs, extractList, windows, reverse, slice ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export non-generic functions ### export( open_input_files, 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, unsplit_list_of_XVectorList, RdaCollection, RdsCollection ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Export S4 generics defined in XVector + export corresponding methods ### export( ## XVector-class.R: subseq, "subseq<-", ## RdaCollection-class.R: rdaPath, ## compact-methods.R: xvcopy, compact, ## reverse-methods.R: reverse ) ### Exactly the same list as above. exportMethods( subseq, "subseq<-", rdaPath, xvcopy, compact, reverse ) XVector/R/0000755000175200017520000000000014710220211013355 5ustar00biocbuildbiocbuildXVector/R/OnDiskRaw-class.R0000644000175200017520000004403514710220211016452 0ustar00biocbuildbiocbuild### ========================================================================= ### 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/RDS-random-access.R0000644000175200017520000000272314710220211016651 0ustar00biocbuildbiocbuild### ========================================================================= ### Random access to the elements of a serialized atomic vector or array ### ------------------------------------------------------------------------- ### Should probably move this to R/io-utils.R .open_input_file <- function(file) { filexp_list <- open_input_files(file) stopifnot(length(filexp_list) == 1L) filexp_list[[1L]] } .read_RDS_file <- function(file, mode, attribs_dump=NULL) { filexp <- .open_input_file(file) .Call("RDS_read_file", filexp, mode, attribs_dump, PACKAGE="XVector") } read_RDS <- function(file, attribs.only=FALSE) { mode <- if (attribs.only) 3L else 0L attribs_dump <- new.env(parent=emptyenv()) ans <- .read_RDS_file(file, mode, attribs_dump=attribs_dump) if (attribs.only) ans <- attribs_dump ans } read_RDS_typeof_and_length <- function(file) .read_RDS_file(file, 4L) extract_subvector_from_RDS_vector <- function(file, pos) { filexp <- .open_input_file(file) .Call("RDS_extract_subvector", filexp, pos, PACKAGE="XVector") } extract_subarray_from_RDS_array <- function(file, index) { attribs_dump <- read_RDS(file, attribs.only=TRUE) x_dim <- try(get("dim", envir=attribs_dump, inherits=FALSE), silent=TRUE) if (inherits(x_dim , "try-error")) stop("serialized object is not an array") filexp <- .open_input_file(file) .Call("RDS_extract_subarray", filexp, x_dim, index, PACKAGE="XVector") } XVector/R/RdaCollection-class.R0000644000175200017520000001206114710220211017325 0ustar00biocbuildbiocbuild### ========================================================================= ### RdaCollection objects ### ------------------------------------------------------------------------- ### ### June 2020: THE RdaCollection CLASS IS SUPERSEDED BY THE RdsCollection ### CLASS! ### TODO: Deprecate the RdaCollection class. ### ### An RdaCollection object points to a collection of serialized R objects ### stored as 1 object per rda file, all located in the same folder on the ### file system. In addition the name of each rda file must be .rda, ### where is the name of the serialized object. Each serialized ### object must have a name that is unique within the RdaCollection object. ### setClass("RdaCollection", representation( dirpath="character", # a single string objnames="character" # a vector of unique object names (no NAs, no # empty strings) ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### 3 low-level helper functions. ### .check_objname <- function(objname, x_objnames) { not_ok_idx <- which(!(objname %in% x_objnames)) nb_not_ok_idx <- length(not_ok_idx) if (nb_not_ok_idx != 0L) { if (nb_not_ok_idx == 1L) { what <- "name" } else { what <- "names" } objnames_in_1string <- paste(objname[not_ok_idx], collapse=", ") stop("invalid object ", what, ": ", objnames_in_1string) } } ### Recycles shortest arg along longest. .get_rdapath <- function(dirpath, objname) { if (length(objname) == 0L) return(character(0)) filename <- paste0(objname, ".rda") file.path(dirpath, filename) } .load_serialized_object <- function(dirpath, objname) { filepath <- .get_rdapath(dirpath, objname) tempenv <- new.env(parent=emptyenv()) loaded_names <- load(filepath, envir=tempenv) if (length(loaded_names) != 1L) stop("file '", filepath, "' contains 0 or more ", "than 1 serialized object") if (loaded_names != objname) stop("serialized object in file '", filepath, "' ", "doesn't have the expected name (expected: ", objname, " -- current: ", loaded_names, ")") get(objname, envir=tempenv) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Getters. ### setMethod("length", "RdaCollection", function(x) length(x@objnames)) setMethod("names", "RdaCollection", function(x) x@objnames) setGeneric("rdaPath", signature="x", function(x, objname) standardGeneric("rdaPath") ) ### Vectorized with respect to 'objname'. setMethod("rdaPath", "RdaCollection", function(x, objname) { if (!is.character(objname)) stop("'objname' must be a character vector") .check_objname(objname, names(x)) .get_rdapath(x@dirpath, objname) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity. ### .valid.RdaCollection <- function(x) { x_dirpath <- x@dirpath x_objnames <- x@objnames if (!is.character(x_objnames) || !is.null(names(x_objnames))) return("\"objnames\" slot must be an unnamed character vector") if (anyDuplicated(x_objnames)) return("\"objnames\" slot contains duplicates") if (any(x_objnames %in% c(NA_character_, ""))) return("\"objnames\" slot contains NAs or empty strings") ## Only checks that all the rda files exist. Does NOT try to check ## their content (that would be too expensive). filepaths <- .get_rdapath(x_dirpath, x_objnames) missing_idx <- which(!file.exists(filepaths)) nb_missing <- length(missing_idx) if (nb_missing != 0L) { if (nb_missing == 1L) { what <- "file" is_or_are <- "is" } else { what <- "files" is_or_are <- "are" } filepaths_in_1string <- paste(paste0("'", filepaths[missing_idx], "'"), collapse=", ") is_or_are <- ifelse(length(missing_idx) == 1L, "is", "are") msg <- c(what, filepaths_in_1string, is_or_are, "missing") return(paste(msg, collapse=" ")) } NULL } setValidity2("RdaCollection", .valid.RdaCollection) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Constructor. ### RdaCollection <- function(dirpath, objnames) { new("RdaCollection", dirpath=dirpath, objnames=objnames) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### "[[" method (list-element extraction). ### ### We only support subetting by name. ### setMethod("[[", "RdaCollection", function(x, i, j, ...) { if (!missing(j) || length(list(...)) > 0L) stop("invalid subsetting") if (!is.character(i)) stop("an RdaCollection object can only be subsetted by name") if (length(i) < 1L) stop("attempt to select less than one element") if (length(i) > 1L) stop("attempt to select more than one element") .check_objname(i, names(x)) .load_serialized_object(x@dirpath, i) } ) XVector/R/RdsCollection-class.R0000644000175200017520000001512414710220211017352 0ustar00biocbuildbiocbuild### ========================================================================= ### RdsCollection objects ### ------------------------------------------------------------------------- ### ### An RdsCollection object points to a collection of serialized R objects ### stored as 1 object per .rds file, all located in the same directory on ### the file system. ### setClass("RdsCollection", contains="List", representation( dirpath="character", # Absolute path to an existing directory. filenames="character" # Vector of file names. The vector itself # must have names on it. ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### parallel_slot_names() ### ### Combine the new "parallel slots" with those of the parent class. Make ### sure to put the new parallel slots **first**. See R/Vector-class.R file ### in the S4Vectors package for what slots should or should not be considered ### "parallel". setMethod("parallel_slot_names", "RdsCollection", function(x) c("filenames", callNextMethod()) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Validity ### ### Similarly to validity methods, helper functions used by the validity ### method must return TRUE if the component to validate is valid, or a single ### string describing why it's not. With a small difference: while validity ### methods in general are allowed to return a character vector of arbitrary ### length describing a list of problems, our helper functions are only ### allowed to return a single string (or a TRUE). The returned string must ### describe the first encountered problem. ### .validate_dirpath <- function(dirpath, what="the 'dirpath' slot") { if (!isSingleString(dirpath)) return(paste0(what, " must be a single string specifying the path ", "to the directory where the .rds files are located")) if (!dir.exists(dirpath)) return(paste0(what, " must contain the path to an existing directory")) TRUE } .RDS_FILEEXT <- ".rds" .bad_files_msg <- function(filenames, in_what, be_what) { filenames_in1string <- paste0(paste0("\"", filenames, "\""), collapse=", ") paste0("All the files specified in ", in_what, " must be ", be_what, ". ", "The following are not: ", filenames_in1string, ".") } .validate_filenames <- function(filenames, dirpath, what="the 'filenames' slot") { if (!is.character(filenames)) return(paste0(what, " must be a character vector")) if (anyNA(filenames)) return(paste0(what, " cannot contain NAs")) ## Check extension. suffix_ends <- nchar(filenames) suffix_starts <- suffix_ends - nchar(.RDS_FILEEXT) + 1L suffixes <- substr(filenames, suffix_starts, suffix_ends) if (!all(suffixes == .RDS_FILEEXT)) return(paste0("all filenames in ", what, " must have ", "file extension \"", .RDS_FILEEXT, "\"")) ## Check that the .rds files exist. filepaths <- file.path(dirpath, filenames) missing_idx <- which(!file.exists(filepaths)) if (length(missing_idx) != 0L) { be_what <- paste0("present in directory \"", dirpath, "\"") return(.bad_files_msg(filenames[missing_idx], what, be_what)) } ## Check that the .rds files are valid RDS files. ## Do NOT try to check their content, that would be too expensive! not_ok <- vapply(filepaths, function(filepath) { inherits(try(infoRDS(filepath), silent=TRUE), "try-error") }, logical(1) ) not_ok_idx <- which(not_ok) if (length(not_ok_idx) != 0L) return(.bad_files_msg(filenames[not_ok_idx], what, "valid RDS files")) TRUE } .validate_filenames_names <- function(names, what="the 'filenames' slot") { if (is.null(names)) return(paste0(what, " must have names on it")) if (any(names %in% c(NA_character_, ""))) return(paste0("the names on ", what, " cannot contain NAs ", "or empty strings")) TRUE } .validate_RdsCollection <- function(x) { ## Validate the 'dirpath' slot. msg <- .validate_dirpath(x@dirpath) if (!isTRUE(msg)) return(msg) abspath <- file_path_as_absolute(x@dirpath) if (abspath != x@dirpath) return(paste0("the 'dirpath' slot must contain the absolute ", "path (", abspath, ") to directory ", x@dirpath)) ## Validate the 'filenames' slot. msg <- .validate_filenames(x@filenames, x@dirpath) if (!isTRUE(msg)) return(msg) ## Validate the names on the 'filenames' slot. msg <- .validate_filenames_names(names(x@filenames)) if (!isTRUE(msg)) return(msg) TRUE } setValidity2("RdsCollection", .validate_RdsCollection) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Constructor ### RdsCollection <- function(path=".", filenames=NULL) { msg <- .validate_dirpath(path, what="'path'") if (!isTRUE(msg)) stop(wmsg(msg)) check <- FALSE if (is.null(filenames)) { ## Autogenerate the filenames. pattern <- paste0("\\", .RDS_FILEEXT, "$") filenames <- dir(path, pattern=pattern, all.files=TRUE) check <- TRUE } else { msg <- .validate_filenames(filenames, path, what="'filenames'") if (!isTRUE(msg)) stop(wmsg(msg)) } names <- names(filenames) if (is.null(names)) { ## Infer names from the filenames. noext_ends <- nchar(filenames) - nchar(.RDS_FILEEXT) noext_filenames <- substr(filenames, 1L, noext_ends) names(filenames) <- noext_filenames check <- TRUE } else { msg <- .validate_filenames_names(names, what="'filenames'") if (!isTRUE(msg)) stop(wmsg(msg)) } new2("RdsCollection", dirpath=file_path_as_absolute(path), filenames=filenames, check=check) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Getters ### setMethod("path", "RdsCollection", function(object) object@dirpath) setMethod("names", "RdsCollection", function(x) names(x@filenames)) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Subsetting ### setMethod("extractROWS", "RdsCollection", function(x, i) { i <- normalizeSingleBracketSubscript(i, x) x@filenames <- x@filenames[i] x } ) setMethod("getListElement", "RdsCollection", function(x, i, exact=TRUE) { i <- normalizeDoubleBracketSubscript(i, x, exact=exact) readRDS(file.path(path(x), x@filenames[[i]])) } ) XVector/R/SharedDouble-class.R0000644000175200017520000000556214710220211017154 0ustar00biocbuildbiocbuild### ========================================================================= ### 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.R0000644000175200017520000000561214710220211017333 0ustar00biocbuildbiocbuild### ========================================================================= ### 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.R0000644000175200017520000002112314710220211016462 0ustar00biocbuildbiocbuild### ========================================================================= ### 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) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### extract_character_from_SharedRaw_by_positions() and ### extract_character_from_SharedRaw_by_ranges() ### ### Typical use: ### x <- SharedRaw(5, charToRaw("Hello")) ### extract_character_from_SharedRaw_by_positions(x, 5:2) ### extract_character_from_SharedRaw_by_positions(x, 5:2, collapse=TRUE) extract_character_from_SharedRaw_by_positions <- function(x, pos, collapse=FALSE, lkup=NULL) { .Call("C_extract_character_from_SharedRaw_by_positions", x, pos, collapse, lkup, PACKAGE="XVector") } ### Typical use: ### x <- SharedRaw(5, charToRaw("Hello")) ### extract_character_from_SharedRaw_by_ranges(x, 3:1, c(2:1, 4L)) ### extract_character_from_SharedRaw_by_ranges(x, 3:1, c(2:1, 4L), ### collapse=TRUE) extract_character_from_SharedRaw_by_ranges <- function(x, start, width, collapse=FALSE, lkup=NULL) { .Call("C_extract_character_from_SharedRaw_by_ranges", x, start, width, collapse, lkup, PACKAGE="XVector") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Read/write functions ### ### NOTE: This is pretty old stuff! Some of it is now superseded by more ### modern extract_character_from_SharedRaw_by_positions() and ### extract_character_from_SharedRaw_by_ranges() above. ### ### 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.R0000644000175200017520000002725314710220211017205 0ustar00biocbuildbiocbuild### ========================================================================= ### 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" ), prototype( .link_to_cached_object=new.env(hash=FALSE, parent=emptyenv()) ) ) 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("get_object_address", x, PACKAGE="XVector") ### 'x' must be a list. Fast implementation of sapply(x, address). addresses <- function(x) .Call2("get_list_addresses", 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.R0000644000175200017520000000374014710220211016151 0ustar00biocbuildbiocbuild### ========================================================================= ### 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.R0000644000175200017520000001724214710220211017171 0ustar00biocbuildbiocbuild### ========================================================================= ### 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) IRanges:::new_Views(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 <- S4Vectors:::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: ", S4Vectors:::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 || S4Vectors:::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.R0000644000175200017520000000365314710220211016337 0ustar00biocbuildbiocbuild### ========================================================================= ### 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.R0000644000175200017520000001730114710220211017350 0ustar00biocbuildbiocbuild### ========================================================================= ### 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) IRanges:::new_Views(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 <- S4Vectors:::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: ", S4Vectors:::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 || S4Vectors:::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.R0000644000175200017520000000673014710220211015472 0ustar00biocbuildbiocbuild### ========================================================================= ### 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) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### extract_character_from_XRaw_by_positions() and ### extract_character_from_XRaw_by_ranges() ### ### Typical use: ### x <- subseq(as(charToRaw("--Hello--"), "XRaw"), 3, 7) ### extract_character_from_XRaw_by_positions(x, 5:2) ### extract_character_from_XRaw_by_positions(x, 5:2, collapse=TRUE) ### lkup <- S4Vectors:::TOUPPER_LOOKUP ### extract_character_from_XRaw_by_positions(x, 5:2, lkup=lkup) ### extract_character_from_XRaw_by_positions(x, 5:2, collapse=TRUE, lkup=lkup) extract_character_from_XRaw_by_positions <- function(x, pos, collapse=FALSE, lkup=NULL) { .Call("C_extract_character_from_XRaw_by_positions", x, pos, collapse, lkup, PACKAGE="XVector") } ### Typical use: ### x <- subseq(as(charToRaw("--Hello--"), "XRaw"), 3, 7) ### extract_character_from_XRaw_by_ranges(x, 3:1, c(2:1, 4L)) ### extract_character_from_XRaw_by_ranges(x, 3:1, c(2:1, 4L), collapse=TRUE) ### lkup <- S4Vectors:::TOUPPER_LOOKUP ### extract_character_from_XRaw_by_ranges(x, 3:1, c(2:1, 4L), lkup=lkup) ### extract_character_from_XRaw_by_ranges(x, 3:1, c(2:1, 4L), collapse=TRUE, ### lkup=lkup) extract_character_from_XRaw_by_ranges <- function(x, start, width, collapse=FALSE, lkup=NULL) { .Call("C_extract_character_from_XRaw_by_ranges", x, start, width, collapse, lkup, PACKAGE="XVector") } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### 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.R0000644000175200017520000000113314710220211016316 0ustar00biocbuildbiocbuild### ========================================================================= ### 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.R0000644000175200017520000001103614710220211017366 0ustar00biocbuildbiocbuild### ========================================================================= ### Comparing and ordering the elements in one or more XRawList objects ### ------------------------------------------------------------------------- ### ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### pcompare() ### setMethod("pcompare", c("XRawList", "XRawList"), function(x, y) .Call2("XRawList_pcompare", 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) pcompare(e1, e2) == 0L ) setMethod("<=", c("XRawList", "XRawList"), function(e1, e2) pcompare(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") } ) ### 'na.last' is pointless (XRawList objects don't contain NAs) so is ignored. ### 'method' is also ignored at the moment. setMethod("order", "XRawList", function(..., na.last=TRUE, decreasing=FALSE, method=c("auto", "shell", "radix")) { ## Turn off this warning for now since it triggers spurious warnings ## when calling sort() on an XRawList derivative. The root of the ## problem is inconsistent defaults for 'na.last' between order() ## and sort(), as reported here: ## https://stat.ethz.ch/pipermail/r-devel/2015-November/072012.html #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.R0000644000175200017520000001313314710220211016176 0ustar00biocbuildbiocbuild### ========================================================================= ### 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) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Subsetting ### setMethod("extractROWS", "XVector", function(x, i) { i <- normalizeSingleBracketSubscript(i, x) 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) x@elementMetadata <- extractROWS(x@elementMetadata, i) 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) <- extractROWS(mcols(x, use.names=FALSE), 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)) ) setAs("XVector", "Rle", function(from) { Rle(as.vector(from)) }) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### The "show" method ### setMethod("show", "XVector", function(object) { lo <- length(object) cat(class(object), " of length ", lo, "\n", sep="") if (lo != 0L) cat(" [1] ", S4Vectors:::toNumSnippet(object, getOption("width")-5), "\n", sep="") } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Concatenation ### .concatenate_XVector_objects <- function(x, objects=list(), use.names=TRUE, ignore.mcols=FALSE, check=TRUE) { objects <- S4Vectors:::prepare_objects_to_bind(x, objects) all_objects <- c(list(x), objects) ans_len <- suppressWarnings(sum(lengths(all_objects))) if (is.na(ans_len)) stop("too many vector elements to concatenate") ## 1. Take care of the parallel slots ## Call method for Vector objects to concatenate all the parallel ## slots (only "elementMetadata" in the case of XVector) and stick them ## into 'ans'. Note that the resulting 'ans' can be an invalid object ## because its "elementMetadata" slot can be longer (i.e. have more rows) ## than 'ans' itself so we use 'check=FALSE' to skip validation. ans <- callNextMethod(x, objects, use.names=use.names, ignore.mcols=ignore.mcols, check=FALSE) ## 2. Take care of the non-parallel slots ans_shared <- SharedVector(class(x@shared), length=ans_len) dest_offset <- 0L for (object in all_objects) { object_len <- length(object) if (object_len == 0L) # would be TRUE on NULLs too... next ## From here 'object' is guaranteed to be an XVector object. src <- object@shared src_start <- object@offset + 1L SharedVector.mcopy(ans_shared, dest_offset, src, src_start, object_len) dest_offset <- dest_offset + object_len } BiocGenerics:::replaceSlots(ans, shared=ans_shared, offset=0L, length=ans_len, check=check) } setMethod("bindROWS", "XVector", .concatenate_XVector_objects) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### 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.R0000644000175200017520000002504614710220211017040 0ustar00biocbuildbiocbuild### ========================================================================= ### 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" ) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### parallel_slot_names() ### ### Combine the new "parallel slots" with those of the parent class. Make ### sure to put the new parallel slots **first**. See R/Vector-class.R file ### in the S4Vectors package for what slots should or should not be considered ### "parallel". ### Ugly workaround a serious callNextMethod inefficiency reported here: ### https://bugs.r-project.org/bugzilla/show_bug.cgi?id=16974 .GroupedIRanges_parallel_slot_names <- c("group", parallel_slot_names(new("IRanges"))) setMethod("parallel_slot_names", "GroupedIRanges", #function(x) c("group", callNextMethod()) function(x) .GroupedIRanges_parallel_slot_names ) setMethod("parallel_slot_names", "XVectorList", function(x) c("ranges", callNextMethod()) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### 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)) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### XVectorList accessors ### setMethod("width", "XVectorList", function(x) width(x@ranges)) setMethod("elementNROWS", "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) addr <- addresses(x@pool@xp_list) keep_idx <- which(!duplicated(addr)) remap <- match(addr, addr[keep_idx]) x@pool <- x@pool[keep_idx] x@ranges@group <- remap[x@ranges@group] x } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### XVectorList constructors ### 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) } ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Going from XVector to XVectorList with extractList() and family ### setMethod("relistToClass", "XVector", function(x) paste0(class(x), "List") ) ### Takes one XVector object ('x') and a IntegerRanges object ('i') defining ### 1-based ranges on 'x' (conceptually equivalent to defining views on ### subject 'x'). .unsafe.extractList <- function(x, i) { ans_class <- relistToClass(x) ans_pool <- as(x@shared, "SharedVector_Pool") if (!is(i, "IRanges")) i <- as(i, "IRanges") ranges_group <- rep.int(1L, length(i)) ans_ranges <- new2("GroupedIRanges", shift(i, x@offset), group=ranges_group, check=FALSE) new2(ans_class, pool=ans_pool, ranges=ans_ranges, check=FALSE) } ### Does not copy the sequence data! setMethod("relist", c("XVector", "PartitioningByEnd"), function(flesh, skeleton) { skeleton_len <- length(skeleton) if (skeleton_len == 0L) { flesh_len2 <- 0L } else { flesh_len2 <- end(skeleton)[skeleton_len] } if (length(flesh) != flesh_len2) stop("shape of 'skeleton' is not compatible with 'length(flesh)'") .unsafe.extractList(flesh, skeleton) } ) ### Does not copy the sequence data! setMethod("extractList", c("XVector", "IntegerRanges"), function(x, i) { if (length(i) != 0L && (min(start(i)) < 1L || max(end(i)) > length(x))) stop("some ranges are out of bounds") .unsafe.extractList(x, i) } ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### XVectorList subsetting ### .getListElement_XVectorList <- function(x, i, exact=TRUE) { i2 <- normalizeDoubleBracketSubscript(i, x, exact=exact, allow.NA=TRUE, allow.nomatch=TRUE) if (is.na(i2)) return(NULL) ans_class <- elementType(x) ans_shared <- x@pool[[x@ranges@group[i2]]] ans_offset <- x@ranges@start[i2] - 1L ans_length <- x@ranges@width[i2] new2(ans_class, shared=ans_shared, offset=ans_offset, length=ans_length, check=FALSE) } setMethod("getListElement", "XVectorList", .getListElement_XVectorList) ### Drop unused pool elements. setMethod("extractROWS", "XVectorList", function(x, i) .dropUnusedPoolElts(callNextMethod()) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### subseq() ### setMethod("subseq", "XVectorList", function(x, start=NA, end=NA, width=NA) narrow(x, start=start, end=end, width=width) ) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### Concatenation ### .concatenate_XVectorList_objects <- function(x, objects=list(), use.names=TRUE, ignore.mcols=FALSE, check=TRUE) { objects <- S4Vectors:::prepare_objects_to_bind(x, objects) all_objects <- c(list(x), objects) ## 1. Take care of the parallel slots ## Call method for Vector objects to concatenate all the parallel slots ## (i.e. "ranges" and "elementMetadata" in the case of XVectorList) and ## stick them into 'ans'. Note that the resulting 'ans' can be an invalid ## object so we use 'check=FALSE' to skip validation. ans <- callNextMethod(x, objects, use.names=use.names, ignore.mcols=ignore.mcols, check=FALSE) ## 2. Take care of the non-parallel slots ## Concatenate the "pool" slots. pool_list <- lapply(all_objects, slot, "pool") ans_pool <- do.call(c, pool_list) ## 3. Fix parallel slot "ranges" ans_ranges <- ans@ranges breakpoints <- cumsum(lengths(pool_list)) offsets <- c(0L, breakpoints[-length(breakpoints)]) offsets <- rep.int(offsets, lengths(all_objects)) ans_ranges@group <- ans_ranges@group + offsets if (!(use.names || is.null(names(ans_ranges)))) names(ans_ranges) <- NULL ans <- BiocGenerics:::replaceSlots(ans, pool=ans_pool, ranges=ans_ranges, check=check) .dropDuplicatedPoolElts(ans) } setMethod("bindROWS", "XVectorList", .concatenate_XVectorList_objects) ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### 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(lengths(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.R0000644000175200017520000001136414710220211016574 0ustar00biocbuildbiocbuild### ========================================================================= ### 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/intra-range-methods.R0000644000175200017520000000161014710220211017346 0ustar00biocbuildbiocbuild### ========================================================================= ### Intra-range methods ### ------------------------------------------------------------------------- ### ### The default "narrow" method calls windows() so we only need to implement ### a "windows" method for XVectorList objects to make narrow() work on these ### objects. setMethod("windows", "XVectorList", function(x, start=NA, end=NA, width=NA) { x@ranges <- windows(x@ranges, start=start, end=end, width=width) x } ) 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/io-utils.R0000644000175200017520000001025214710220211015245 0ustar00biocbuildbiocbuild### ========================================================================= ### Some low-level (not exported) I/O utility functions ### ------------------------------------------------------------------------- ### ### Unless stated otherwise, nothing in this file is exported. ### new_input_filexp <- function(filepath) { .Call2("new_input_filexp", filepath, PACKAGE="XVector") } rewind_filexp <- function(filexp) { .Call2("rewind_filexp", filexp, PACKAGE="XVector") } new_output_filexp <- function(filepath, append, compress, compression_level) { .Call2("new_output_filexp", filepath, append, compress, compression_level, PACKAGE="XVector") } close_filexp <- function(filexp) { .Call2("close_filexp", filexp, PACKAGE="XVector") } .normarg_input_filepath <- function(filepath) { if (!is.character(filepath) || any(is.na(filepath))) stop(wmsg("'filepath' must be a character vector with no NAs")) ## First pass: expand local paths and download any remote file. filepath2 <- character(length(filepath)) for (i in seq_len(length(filepath))) { fp <- filepath[i] con <- file(fp) con_class <- class(con)[1L] close(con) if (con_class == "url") { filepath2[i] <- tempfile() download.file(fp, filepath2[i]) } else { filepath2[i] <- path.expand(fp) } } ## Second pass: check the type of the local files (all files are ## now local). filetype <- character(length(filepath2)) for (i in seq_len(length(filepath2))) { fp <- filepath2[i] con <- file(fp) filetype[i] <- base::summary(con)$class close(con) if (!(filetype[i] %in% c("file", "gzfile"))) stop(wmsg("file \"", filepath[i], "\" ", "has unsupported type: ", filetype[i])) } names(filepath2) <- filetype filepath2 } ### Return a named list of "file external pointers". open_input_files <- function(filepath) { filepath2 <- .normarg_input_filepath(filepath) ans <- lapply(filepath2, function(fp) { filexp <- new_input_filexp(fp) reg.finalizer(filexp, close_filexp, onexit=TRUE) filexp }) names(ans) <- filepath ans } .normarg_compress <- function(compress) { if (isTRUEorFALSE(compress)) { if (compress) return("gzip") return("no") } if (isSingleString(compress)) { # Types of compression supported by save(): #VALID_COMPRESS <- c("no", "gzip", "bzip2", "xz") VALID_COMPRESS <- c("no", "gzip") if (!(compress %in% VALID_COMPRESS)) stop(wmsg("when 'compress' is a single string, it must be one of ", paste(paste0("\"", VALID_COMPRESS, "\""), collapse=", "))) return(compress) } stop(wmsg("'compress' must be TRUE or FALSE or a single string")) } .normarg_compression_level <- function(compression_level, compress) { if (!isSingleNumberOrNA(compression_level)) stop(wmsg("'compression_level' must be a single number or NA")) if (is.na(compression_level)) return(switch(compress, no=0L, gzip=6L, bzip2=9L, xz=9L)) if (!is.integer(compression_level)) compression_level <- as.integer(compression_level) if (compression_level < 0L) stop(wmsg("'compression_level' cannot be negative")) compression_level } ### Return a named list of one "file external pointer". open_output_file <- function(filepath, append=FALSE, compress=FALSE, compression_level=NA) { if (!isSingleString(filepath)) stop(wmsg("'filepath' must be a single string")) if (!isTRUEorFALSE(append)) stop(wmsg("'append' must be TRUE or FALSE")) compress <- .normarg_compress(compress) compression_level <- .normarg_compression_level(compression_level, compress) filepath2 <- path.expand(filepath) filexp <- new_output_filexp(filepath2, append, compress, compression_level) reg.finalizer(filexp, close_filexp, onexit=TRUE) ans <- list(filexp) names(ans) <- filepath ans } XVector/R/reverse-methods.R0000644000175200017520000000047114710220211016616 0ustar00biocbuildbiocbuild### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ### "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.R0000644000175200017520000000430614710220211016243 0ustar00biocbuildbiocbuild### ========================================================================= ### 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.R0000644000175200017520000000253214710220211017554 0ustar00biocbuildbiocbuild### ################################################################### ### 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.R0000644000175200017520000000503414710220211021015 0ustar00biocbuildbiocbuild### ========================================================================= ### 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.R0000644000175200017520000000407614710220211014344 0ustar00biocbuildbiocbuild### .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: S4Vectors:::setDefaultSlotValue("SharedRaw", "xp", newExternalptrWithTag(raw(0L)), where=asNamespace(pkgname)) S4Vectors:::setDefaultSlotValue("SharedInteger", "xp", newExternalptrWithTag(integer(0L)), where=asNamespace(pkgname)) S4Vectors:::setDefaultSlotValue("SharedDouble", "xp", newExternalptrWithTag(double(0L)), where=asNamespace(pkgname)) ## 3 XVector concrete subclasses: S4Vectors:::setDefaultSlotValue("XRaw", "shared", new("SharedRaw"), # is fixed now! where=asNamespace(pkgname)) S4Vectors:::setDefaultSlotValue("XInteger", "shared", new("SharedInteger"), # is fixed now! where=asNamespace(pkgname)) S4Vectors:::setDefaultSlotValue("XDouble", "shared", new("SharedDouble"), # is fixed now! where=asNamespace(pkgname)) } .onUnload <- function(libpath) { library.dynam.unload("XVector", libpath) } .test <- function() BiocGenerics:::testPackage("XVector") XVector/README.md0000644000175200017520000000071614710220211014437 0ustar00biocbuildbiocbuild[](https://bioconductor.org/) **XVector** is an R/Bioconductor package that provides the foundation of external vector representation and manipulation in Bioconductor. See https://bioconductor.org/packages/XVector for more information including how to install the release version of the package (please refrain from installing directly from GitHub). XVector/TODO0000644000175200017520000000002114710220211013635 0ustar00biocbuildbiocbuild- Add vignette. XVector/inst/0000755000175200017520000000000014710220211014131 5ustar00biocbuildbiocbuildXVector/inst/include/0000755000175200017520000000000014710220211015554 5ustar00biocbuildbiocbuildXVector/inst/include/XVector_defines.h0000644000175200017520000000170014710220211021012 0ustar00biocbuildbiocbuild/***************************************************************************** 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 xvector_list_holder { const char *classname; const char *element_type; SEXP xp_list; int length; const int *start; const int *width; const int *group; } XVectorList_holder; #endif XVector/inst/include/XVector_interface.h0000644000175200017520000001360614710220211021345 0ustar00biocbuildbiocbuild/***************************************************************************** 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" /* * io_utils.c */ int filexp_read( SEXP filexp, char *buf, int buf_size ); int filexp_gets( SEXP filexp, char *buf, int buf_size, int *EOL_in_buf ); long long int filexp_tell(SEXP filexp); void filexp_seek( SEXP filexp, long long int offset, int whence ); void filexp_rewind(SEXP filexp); int filexp_puts( SEXP filexp, const char *s ); void filexp_putc( SEXP filexp, int c ); int delete_trailing_LF_or_CRLF( const char *buf, int buf_len ); /* * 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); SEXP new_XVector(const char *classname, SEXP shared, int offset, int length); /* * Low-level manipulation of XRaw objects. * (see XRaw_class.c) */ Chars_holder hold_XRaw(SEXP x); SEXP new_XRaw_from_tag(const char *classname, SEXP tag); SEXP alloc_XRaw(const char *classname, int length); /* * Low-level manipulation of XInteger objects. * (see XInteger_class.c) */ Ints_holder hold_XInteger(SEXP x); SEXP new_XInteger_from_tag(const char *classname, SEXP tag); SEXP alloc_XInteger(const char *classname, int length); /* * Low-level manipulation of XDouble objects. * (see XDouble_class.c) */ Doubles_holder hold_XDouble(SEXP x); SEXP new_XDouble_from_tag(const char *classname, SEXP tag); 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); XVectorList_holder hold_XVectorList(SEXP x); int get_length_from_XVectorList_holder(const XVectorList_holder *x_holder); Chars_holder get_elt_from_XRawList_holder( const XVectorList_holder *x_holder, int i ); Ints_holder get_elt_from_XIntegerList_holder( const XVectorList_holder *x_holder, int i ); Doubles_holder get_elt_from_XDoubleList_holder( const XVectorList_holder *x_holder, int i ); XVectorList_holder get_linear_subset_from_XVectorList_holder( const XVectorList_holder *x_holder, int offset, int length ); 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.c0000644000175200017520000002477514710220211020710 0ustar00biocbuildbiocbuild#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 io_utils.c */ DEFINE_CCALLABLE_STUB(int, filexp_read, (SEXP filexp, char *buf, int buf_size), ( filexp, buf, buf_size) ) DEFINE_CCALLABLE_STUB(int, filexp_gets, (SEXP filexp, char *buf, int buf_size, int *EOL_in_buf), ( filexp, buf, buf_size, EOL_in_buf) ) DEFINE_CCALLABLE_STUB(long long int, filexp_tell, (SEXP filexp), ( filexp) ) DEFINE_NOVALUE_CCALLABLE_STUB(filexp_seek, (SEXP filexp, long long int offset, int whence), ( filexp, offset, whence) ) DEFINE_NOVALUE_CCALLABLE_STUB(filexp_rewind, (SEXP filexp), ( filexp) ) DEFINE_CCALLABLE_STUB(int, filexp_puts, (SEXP filexp, const char *s), ( filexp, s) ) DEFINE_NOVALUE_CCALLABLE_STUB(filexp_putc, (SEXP filexp, int c), ( filexp, c) ) DEFINE_CCALLABLE_STUB(int, delete_trailing_LF_or_CRLF, (const char *buf, int buf_len), ( buf, buf_len) ) /* * 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(SEXP, new_XVector, (const char *classname, SEXP shared, int offset, int length), ( classname, shared, offset, length) ) /* * Stubs for callables defined in XRaw_class.c */ DEFINE_CCALLABLE_STUB(Chars_holder, hold_XRaw, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(SEXP, new_XRaw_from_tag, (const char *classname, SEXP tag), ( classname, tag) ) DEFINE_CCALLABLE_STUB(SEXP, alloc_XRaw, (const char *classname, int length), ( classname, length) ) /* * Stubs for callables defined in XInteger_class.c */ DEFINE_CCALLABLE_STUB(Ints_holder, hold_XInteger, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(SEXP, new_XInteger_from_tag, (const char *classname, SEXP tag), ( classname, tag) ) DEFINE_CCALLABLE_STUB(SEXP, alloc_XInteger, (const char *classname, int length), ( classname, length) ) /* * Stubs for callables defined in XDouble_class.c */ DEFINE_CCALLABLE_STUB(Doubles_holder, hold_XDouble, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(SEXP, new_XDouble_from_tag, (const char *classname, SEXP tag), ( classname, tag) ) 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(XVectorList_holder, hold_XVectorList, (SEXP x), ( x) ) DEFINE_CCALLABLE_STUB(int, get_length_from_XVectorList_holder, (const XVectorList_holder *x_holder), ( x_holder) ) DEFINE_CCALLABLE_STUB(Chars_holder, get_elt_from_XRawList_holder, (const XVectorList_holder *x_holder, int i), ( x_holder, i) ) DEFINE_CCALLABLE_STUB(Ints_holder, get_elt_from_XIntegerList_holder, (const XVectorList_holder *x_holder, int i), ( x_holder, i) ) DEFINE_CCALLABLE_STUB(Doubles_holder, get_elt_from_XDoubleList_holder, (const XVectorList_holder *x_holder, int i), ( x_holder, i) ) DEFINE_CCALLABLE_STUB(XVectorList_holder, get_linear_subset_from_XVectorList_holder, (const XVectorList_holder *x_holder, int offset, int length), ( x_holder, offset, length) ) 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/0000755000175200017520000000000014710220211016133 5ustar00biocbuildbiocbuildXVector/inst/unitTests/test_slice-methods.R0000644000175200017520000000103314710220211022052 0ustar00biocbuildbiocbuildtest_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.R0000644000175200017520000000433014710220211024630 0ustar00biocbuildbiocbuildtest_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/0000755000175200017520000000000014710220211013727 5ustar00biocbuildbiocbuildXVector/man/OnDiskRaw-class.Rd0000644000175200017520000000041714710220211017164 0ustar00biocbuildbiocbuild\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. Pagès} \keyword{methods} \keyword{classes} XVector/man/XDoubleViews-class.Rd0000644000175200017520000000701614710220211017705 0ustar00biocbuildbiocbuild\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.Rd0000644000175200017520000000654214710220211020073 0ustar00biocbuildbiocbuild\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.Rd0000644000175200017520000000055714710220211017045 0ustar00biocbuildbiocbuild\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. Pagès} \seealso{ \link{XRaw-class}, \link{XVectorList-class} } \keyword{methods} \keyword{classes} XVector/man/XRawList-comparison.Rd0000644000175200017520000000570214710220211020107 0ustar00biocbuildbiocbuild\name{XRawList-comparison} \alias{XRawList-comparison} \alias{pcompare} \alias{pcompare,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, method=c("auto", "shell", "radix")) \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{pcompare}{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, method}{ 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. Pagès} \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.Rd0000644000175200017520000001275714710220211016727 0ustar00biocbuildbiocbuild\name{XVector-class} \docType{class} % XVector class, functions and methods: \alias{class:XVector} \alias{XVector-class} \alias{XVector} \alias{length,XVector-method} \alias{bindROWS,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[S4Vectors]{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. Pagès} \seealso{ \link[S4Vectors]{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.Rd0000644000175200017520000000341214710220211017605 0ustar00biocbuildbiocbuild\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.Rd0000644000175200017520000000174014710220211017551 0ustar00biocbuildbiocbuild\name{XVectorList-class} \docType{class} \alias{class:GroupedIRanges} \alias{GroupedIRanges-class} \alias{GroupedIRanges} \alias{class:XVectorList} \alias{XVectorList-class} \alias{XVectorList} \alias{parallel_slot_names,GroupedIRanges-method} \alias{parallel_slot_names,XVectorList-method} \alias{as.data.frame,GroupedIRanges-method} \alias{show,GroupedIRanges-method} \alias{width,XVectorList-method} \alias{elementNROWS,XVectorList-method} \alias{names,XVectorList-method} \alias{names<-,XVectorList-method} \alias{[,XVectorList-method} \alias{subseq,XVectorList-method} \alias{bindROWS,XVectorList-method} \alias{showAsCell,XVectorList-method} \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. Pagès} \seealso{ \link{XVector-class}, \link{XRawList-class}, \code{\link{compact}} } \keyword{methods} \keyword{classes} XVector/man/compact-methods.Rd0000644000175200017520000001032114710220211017302 0ustar00biocbuildbiocbuild\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. Pagès} \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.Rd0000644000175200017520000000504714710220211020074 0ustar00biocbuildbiocbuild\name{intra-range-methods} \alias{intra-range-methods} \alias{narrow} \alias{windows,XVectorList-method} \alias{narrow,XVectorList-method} \alias{threebands} \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 \pkg{IRanges} package. Only 2 of them have methods for \link{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 \pkg{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. Pagès} \seealso{ \itemize{ \item \link[IRanges]{intra-range-methods} in the \pkg{IRanges} package for intra range transformations. \item \code{\link[IRanges]{solveUserSEW}} in the \pkg{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.Rd0000644000175200017520000000303014710220211017326 0ustar00biocbuildbiocbuild\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[S4Vectors]{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.Rd0000644000175200017520000000404514710220211016761 0ustar00biocbuildbiocbuild\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.Rd0000644000175200017520000000220314710220211020265 0ustar00biocbuildbiocbuild\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.Rd0000644000175200017520000000563614710220211021543 0ustar00biocbuildbiocbuild\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/0000755000175200017520000000000014710323443013756 5ustar00biocbuildbiocbuildXVector/src/IRanges_stubs.c0000644000175200017520000000003414710220211016654 0ustar00biocbuildbiocbuild#include "_IRanges_stubs.c" XVector/src/Makevars0000644000175200017520000000001714710220211015435 0ustar00biocbuildbiocbuildPKG_LIBS = -lz XVector/src/Makevars.win0000644000175200017520000000044314710220211016234 0ustar00biocbuildbiocbuildZLIB_CFLAGS += $(shell echo 'zlibbioc::pkgconfig("PKG_CFLAGS")' |\ "${R_HOME}/bin/R" --vanilla --slave) PKG_LIBS += $(shell echo 'zlibbioc::pkgconfig("PKG_LIBS_shared")' |\ "${R_HOME}/bin/R" --vanilla --slave) %.o: %.c $(CC) $(ZLIB_CFLAGS) $(ALL_CPPFLAGS) $(ALL_CFLAGS) -c $< -o $@ XVector/src/Ocopy_byteblocks.c0000644000175200017520000003254414710220211017431 0ustar00biocbuildbiocbuild#include "XVector.h" /**************************************************************************** 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/RDS_random_access.c0000644000175200017520000005615314710220211017432 0ustar00biocbuildbiocbuild/**************************************************************************** **************************************************************************** * Random access to the elements of a serialized atomic vector or array * * Author: H. Pag\`es * **************************************************************************** ****************************************************************************/ #include "XVector.h" #include "IRanges_interface.h" #include "S4Vectors_interface.h" #include // for INT_MAX static int verbose = 0; #define IS_ATOMIC_TYPE(type) \ ((type) == LGLSXP || (type) == INTSXP || (type) == REALSXP || \ (type) == CPLXSXP || (type) == RAWSXP || (type) == STRSXP) /* Equivalent to the DATAPTR() macro defined in Rinternals.h For some reason I don't understand, I can't use the DATAPTR() macro. */ static void *dataptr(SEXP x) { switch (TYPEOF(x)) { case LGLSXP: return LOGICAL(x); case INTSXP: return INTEGER(x); case REALSXP: return REAL(x); case CPLXSXP: return COMPLEX(x); case RAWSXP: return RAW(x); } error("XVector internal error in dataptr(): " "%s type not supported", CHAR(type2str(TYPEOF(x)))); } static size_t type2atomsize(SEXPTYPE type) { switch (type) { case LGLSXP: case INTSXP: return sizeof(int); case REALSXP: return sizeof(double); case CPLXSXP: return sizeof(Rcomplex); case RAWSXP: return sizeof(Rbyte); } error("XVector internal error in type2atomsize(): " "undefined atom size for type %s", CHAR(type2str(type))); } /**************************************************************************** * A simple RDS parser * * The current implementation assumes that: * - sizeof(int) = 4 * - sizeof(double) = sizeof(long long int) = 8 * - platform is little endian */ static void printf_margin(int indent) { int i; for (i = 0; i < indent; i++) printf(" "); return; } #define PRINTIFVERBOSE1(msg) \ { \ if (verbose) { \ printf_margin(indent); \ printf(msg); \ printf("\n"); \ } \ } #define PRINTIFVERBOSE2(format, value) \ { \ if (verbose) { \ printf_margin(indent); \ printf(format, value); \ printf("\n"); \ } \ } static SEXPTYPE RDStype2Rtype(unsigned char type) { /* NULL type is 0xfe in RDS, not NILSXP */ return type == 0xfe ? NILSXP : type; } static const char *RDS_read_bytes(SEXP filexp, size_t n, int parse_only, unsigned char *buf) { int n2, n3; static char errmsg_buf[40]; /* Because the 'buf_size' argument in _filexp_read() must be an int, we cannot read more than INT_MAX bytes per call to _filexp_read(). */ while (n > 0) { n2 = n <= INT_MAX ? n : INT_MAX; if (parse_only) { _filexp_seek(filexp, n2, SEEK_CUR); } else { n3 = _filexp_read(filexp, (char *) buf, n2); if (n3 != n2) { snprintf(errmsg_buf, sizeof(errmsg_buf), "read error or unexpected end of file"); return errmsg_buf; } buf += n2; } n -= n2; } return NULL; } static void RDS_read_chars(SEXP filexp, size_t n, int parse_only, CharAE *string_buf) { const char *errmsg; if (!parse_only && n > string_buf->_buflength) CharAE_extend(string_buf, n); errmsg = RDS_read_bytes(filexp, n, parse_only, (unsigned char *) string_buf->elts); if (errmsg != NULL) error("%s", errmsg); if (!parse_only) CharAE_set_nelt(string_buf, n); return; } static void swap_4_bytes(unsigned char *bytes) { unsigned int *tmp; tmp = (unsigned int *) bytes; *tmp = (*tmp << 24) | ((*tmp & 0xff00) << 8) | ((*tmp & 0xff0000) >> 8) | (*tmp >> 24); return; } static const char *RDS_read_ints(SEXP filexp, size_t n, int parse_only, int *buf) { const char *errmsg; size_t i; /* Integer values are *always* 4 bytes in an RDS file, even if sizeof(int) != 4 on the machine running this code! */ errmsg = RDS_read_bytes(filexp, n * 4, parse_only, (unsigned char *) buf); if (errmsg != NULL) return errmsg; /* FIXME: Don't swap bytes if platform is big endian */ if (!parse_only) for (i = 0; i < n; i++) swap_4_bytes((unsigned char *) (buf + i)); return NULL; } static void swap_8_bytes(unsigned char *bytes) { unsigned long long int *tmp; tmp = (unsigned long long int *) bytes; *tmp = (*tmp << 56) | ((*tmp & 0xff00) << 40) | ((*tmp & 0xff0000) << 24) | ((*tmp & 0xff000000) << 8) | ((*tmp & 0xff00000000) >> 8) | ((*tmp & 0xff0000000000) >> 24) | ((*tmp & 0xff000000000000) >> 40) | (*tmp >> 56); return; } static const char *RDS_read_doubles(SEXP filexp, size_t n, int parse_only, double *buf) { const char *errmsg; size_t i; /* Double values are *always* 8 bytes in an RDS file, even if sizeof(double) != 8 on the machine running this code! */ errmsg = RDS_read_bytes(filexp, n * 8, parse_only, (unsigned char *) buf); if (errmsg != NULL) return errmsg; /* FIXME: Don't swap bytes if platform is big endian */ if (!parse_only) for (i = 0; i < n; i++) swap_8_bytes((unsigned char *) (buf + i)); return NULL; } static R_xlen_t RDS_read_vector_length(SEXP filexp) { const char *errmsg; const unsigned char LONG_LENGTH_bytes[4] = {0xff, 0xff, 0xff, 0xff}; unsigned char buf[8]; int *length; long long int *long_length; errmsg = RDS_read_bytes(filexp, 4, 0, buf); if (errmsg != NULL) error("%s", errmsg); if (memcmp(buf, LONG_LENGTH_bytes, 4) != 0) { swap_4_bytes(buf); length = (int *) buf; return (R_xlen_t) *length; } errmsg = RDS_read_bytes(filexp, 8, 0, buf); if (errmsg != NULL) error("%s", errmsg); swap_8_bytes(buf); long_length = (long long int *) buf; return (R_xlen_t) *long_length; } SEXP get_typeof_and_length_as_list(SEXP filexp, SEXPTYPE type) { R_xlen_t length; SEXP ans, ans_elt, ans_names, ans_names_elt; length = type == NILSXP ? 0 : RDS_read_vector_length(filexp); ans = PROTECT(NEW_LIST(2)); /* Set "typeof" element. */ ans_elt = PROTECT(ScalarString(type2str(type))); SET_VECTOR_ELT(ans, 0, ans_elt); UNPROTECT(1); /* Set "length" element. */ if (length <= INT_MAX) ans_elt = PROTECT(ScalarInteger((int) length)); else ans_elt = PROTECT(ScalarReal((double) length)); SET_VECTOR_ELT(ans, 1, ans_elt); UNPROTECT(1); ans_names = PROTECT(NEW_CHARACTER(2)); ans_names_elt = PROTECT(mkChar("typeof")); SET_STRING_ELT(ans_names, 0, ans_names_elt); UNPROTECT(1); ans_names_elt = PROTECT(mkChar("length")); SET_STRING_ELT(ans_names, 1, ans_names_elt); UNPROTECT(1); SET_NAMES(ans, ans_names); UNPROTECT(1); UNPROTECT(1); return ans; } /* Encoded strings not supported. */ static int RDS_read_string(SEXP filexp, int parse_only, CharAE *string_buf) { const char *errmsg; const unsigned char NA_STRING_bytes[4] = {0xff, 0xff, 0xff, 0xff}; unsigned char buf[4]; R_xlen_t ans_len; errmsg = RDS_read_bytes(filexp, sizeof(buf), 0, buf); if (errmsg != NULL) error("%s", errmsg); if (buf[0] != 0 || buf[2] != 0 || buf[3] != 0x09) error("unsupported RDS file"); if (buf[1] == 0) { errmsg = RDS_read_bytes(filexp, sizeof(buf), 0, buf); if (errmsg != NULL) error("%s", errmsg); if (memcmp(buf, NA_STRING_bytes, sizeof(buf)) != 0) error("unsupported RDS file"); return 1; } if (buf[1] != 0x04) error("unsupported string header"); ans_len = RDS_read_vector_length(filexp); RDS_read_chars(filexp, (size_t) ans_len, parse_only, string_buf); return 0; } /* Return R_NilValue if parse_only != 0. */ static SEXP RDS_read_character_vector(SEXP filexp, int parse_only, CharAE *string_buf, int indent) { R_xlen_t ans_len, i; int is_na; SEXP ans, ans_elt; PRINTIFVERBOSE1("start reading character vector"); ans_len = RDS_read_vector_length(filexp); PRINTIFVERBOSE2("object length: %td", ans_len); ans = parse_only ? R_NilValue : PROTECT(NEW_CHARACTER(ans_len)); for (i = 0; i < ans_len; i++) { is_na = RDS_read_string(filexp, parse_only, string_buf); if (parse_only) continue; if (is_na) { SET_STRING_ELT(ans, i, NA_STRING); } else { PROTECT(ans_elt = new_CHARSXP_from_CharAE(string_buf)); SET_STRING_ELT(ans, i, ans_elt); UNPROTECT(1); } } if (!parse_only) UNPROTECT(1); PRINTIFVERBOSE1("done reading character vector"); return ans; } /* Return R_NilValue if parse_only != 0. */ static SEXP RDS_read_atomic_vector(SEXP filexp, SEXPTYPE type, int parse_only, int indent) { R_xlen_t ans_len; SEXP ans; const char *errmsg; PRINTIFVERBOSE2("start reading %s vector", CHAR(type2str(type))); ans_len = RDS_read_vector_length(filexp); PRINTIFVERBOSE2("object length: %td", ans_len); ans = parse_only ? R_NilValue : PROTECT(allocVector(type, ans_len)); switch (type) { case LGLSXP: case INTSXP: errmsg = RDS_read_ints(filexp, (size_t) ans_len, parse_only, parse_only ? NULL : dataptr(ans)); break; case REALSXP: errmsg = RDS_read_doubles(filexp, (size_t) ans_len, parse_only, parse_only ? NULL : dataptr(ans)); break; case CPLXSXP: errmsg = RDS_read_doubles(filexp, (size_t) ans_len * 2, parse_only, parse_only ? NULL : dataptr(ans)); break; case RAWSXP: errmsg = RDS_read_bytes(filexp, (size_t) ans_len, parse_only, parse_only ? NULL : dataptr(ans)); break; default: error("XVector internal error in RDS_read_atomic_vector(): " "unexpected type: %s", CHAR(type2str(type))); } if (errmsg != NULL) error("%s", errmsg); if (!parse_only) UNPROTECT(1); PRINTIFVERBOSE2("done reading %s vector", CHAR(type2str(type))); return ans; } static SEXP RDS_read_object(SEXP filexp, int mode, SEXP attribs_dump, CharAE *string_buf, CharAEAE *symbols_buf, int indent); /* Return R_NilValue if parse_only != 0. */ static SEXP RDS_read_list(SEXP filexp, int parse_only, CharAE *string_buf, CharAEAE *symbols_buf, int indent) { R_xlen_t ans_len, i; SEXP ans, ans_elt; PRINTIFVERBOSE1("start reading list object"); ans_len = RDS_read_vector_length(filexp); PRINTIFVERBOSE2("object length: %td", ans_len); ans = parse_only ? R_NilValue : PROTECT(NEW_LIST(ans_len)); for (i = 0; i < ans_len; i++) { ans_elt = RDS_read_object(filexp, parse_only, R_NilValue, string_buf, symbols_buf, indent + 1); if (parse_only) continue; PROTECT(ans_elt); SET_VECTOR_ELT(ans, i, ans_elt); UNPROTECT(1); } if (!parse_only) UNPROTECT(1); PRINTIFVERBOSE1("done reading list object"); return ans; } static int RDS_read_attrib_separator(SEXP filexp) { const char *errmsg; const unsigned char EOA_bytes[4] = {0x00, 0x00, 0x00, 0xfe}, ATTRIB_SEP_bytes[4] = {0x00, 0x00, 0x04, 0x02}; unsigned char buf[4]; errmsg = RDS_read_bytes(filexp, sizeof(buf), 0, buf); if (errmsg != NULL) error("%s", errmsg); if (memcmp(buf, EOA_bytes, sizeof(buf)) == 0) return 0; if (memcmp(buf, ATTRIB_SEP_bytes, sizeof(buf)) != 0) error("unrecognized attribute header"); return 1; } /* Store symbol (as 0-terminated string) in one of 'symbols_buf' elements. Return the "key" of this element i.e. its 0-based index in 'symbols_buf'. */ static unsigned int RDS_read_symbol(SEXP filexp, CharAEAE *symbols_buf, int indent) { const char *errmsg; const unsigned char NEW_SYMBOL_bytes[4] = {0x00, 0x00, 0x00, 0x01}; unsigned char buf[4]; unsigned int key; CharAE *namebuf; PRINTIFVERBOSE1("start reading symbol"); errmsg = RDS_read_bytes(filexp, sizeof(buf), 0, buf); if (errmsg != NULL) error("%s", errmsg); if (memcmp(buf, NEW_SYMBOL_bytes, sizeof(buf)) == 0) { /* New symbol. */ namebuf = new_CharAE(0); if (RDS_read_string(filexp, 0, namebuf)) error("invalid symbol (NA)"); CharAE_insert_at(namebuf, CharAE_get_nelt(namebuf), '\0'); key = CharAEAE_get_nelt(symbols_buf); CharAEAE_insert_at(symbols_buf, key, namebuf); } else { /* Known symbol (i.e. already in 'symbols_buf'). */ key = (((unsigned int) buf[0]) << 16) | (((unsigned int) buf[1]) << 8) | ((unsigned int) buf[2]); if (buf[3] != 0xff || key == 0) error("unsupported symbol specifier"); key--; } PRINTIFVERBOSE2("done reading symbol [%s]", symbols_buf->elts[key]->elts); return key; } /* Always parse the full attributes. In mode 0: Load and set the attributes on 'object', return R_NilValue. In mode 1: (parse-only mode) Don't load anything, don't set anything on 'object' (which should be R_NilValue), and return R_NilValue; In mode 2: Load the attributes and do NOT set them on 'object' ('object' is ignored), but dump them in the 'attribs_dump' environment. */ static void RDS_read_attribs(SEXP filexp, int mode, SEXP object, SEXP attribs_dump, CharAE *string_buf, CharAEAE *symbols_buf, int indent) { unsigned int key; SEXP attrval; const char *symbol; PRINTIFVERBOSE1("start reading object attributes"); while (RDS_read_attrib_separator(filexp)) { key = RDS_read_symbol(filexp, symbols_buf, indent + 1); attrval = RDS_read_object(filexp, mode == 1, R_NilValue, string_buf, symbols_buf, indent + 1); if (mode == 1) continue; PROTECT(attrval); symbol = symbols_buf->elts[key]->elts; if (mode == 0) setAttrib(object, install(symbol), attrval); else // mode 2 defineVar(install(symbol), attrval, attribs_dump); UNPROTECT(1); } PRINTIFVERBOSE1("done reading object attributes"); return; } static SEXP RDS_read_object(SEXP filexp, int mode, SEXP attribs_dump, CharAE *string_buf, CharAEAE *symbols_buf, int indent) { const char *errmsg; unsigned char obj_header[4]; int has_attribs; SEXPTYPE type; SEXP ans; PRINTIFVERBOSE1("start reading object header"); errmsg = RDS_read_bytes(filexp, sizeof(obj_header), 0, obj_header); if (errmsg != NULL) error("%s", errmsg); if (obj_header[0] != 0 || obj_header[1] != 0) error("unsupported RDS file"); PRINTIFVERBOSE1("done reading object header"); if (obj_header[2] == 0) { /* Object has no attributes. */ if (mode == 3) return R_NilValue; // early bail out has_attribs = 0; } else if (obj_header[2] == 0x02 || obj_header[2] == 0x03) { /* Object has attributes (code 0x03 seems to be specific to factors). */ if (mode == 3) mode = 2; has_attribs = 1; } else { error("unexpected 3rd byte in object header"); } type = RDStype2Rtype(obj_header[3]); PRINTIFVERBOSE2("object type: %s", CHAR(type2str(type))); if (mode == 4) return get_typeof_and_length_as_list(filexp, type); if (type == NILSXP) { ans = R_NilValue; } else if (type == STRSXP) { ans = RDS_read_character_vector(filexp, mode != 0, string_buf, indent); } else if (IS_ATOMIC_TYPE(type)) { ans = RDS_read_atomic_vector(filexp, type, mode != 0, indent); } else if (type == VECSXP) { ans = RDS_read_list(filexp, mode != 0, string_buf, symbols_buf, indent); } else { error("RDS parser does not support type: %s", CHAR(type2str(type))); } if (has_attribs) { if (!isNull(ans)) PROTECT(ans); RDS_read_attribs(filexp, mode, ans, attribs_dump, string_buf, symbols_buf, indent); if (!isNull(ans)) UNPROTECT(1); } return ans; } static void RDS_read_file_header(SEXP filexp) { const char *errmsg; const unsigned char RDS_header[14] = {0x58, 0x0a, 0x00, 0x00, 0x00, 0x02, 0x00, 0x03, 0x04, 0x02, 0x00, 0x02, 0x03, 0x00}; unsigned char file_header[sizeof(RDS_header)]; int indent; indent = 0; PRINTIFVERBOSE1("start reading file header"); errmsg = RDS_read_bytes(filexp, sizeof(file_header), 0, file_header); if (errmsg != NULL) error("%s", errmsg); if (memcmp(file_header, RDS_header, sizeof(file_header)) != 0) error("does not look like an RDS file"); PRINTIFVERBOSE1("done reading file header"); return; } /**************************************************************************** * RDS_read_file() * * --- .Call ENTRY POINT --- * Read/parse an RDS file. Only support a serialized atomic vector or a NULL * or a list (possibly nested) made of the formers. Support attributes (if * made of the formers). * Args: * filexp: External pointer to a FILE pointer. * mode: Control what parts of the object to load. In modes 0, 1, 2 the * full object gets parsed: * mode 0: Load everything and return the full object. * mode 1: (parse-only mode) Don't load anything and return * R_NilValue. * mode 2: Load only the attributes and dump them in the * 'attribs_dump' environment. * Mode 3 is like mode 2 but with early bailout if the object header * indicates that the object has no attributes. So in this mode the * object gets fully parsed only if it has attributes. Otherwise * only its header gets parsed. * In mode 4 only the object header and length get parsed. * attribs_dump: Environment used in modes 2 and 3 to dump the attributes. */ SEXP RDS_read_file(SEXP filexp, SEXP mode, SEXP attribs_dump) { int mode0; CharAE *string_buf; CharAEAE *symbols_buf; RDS_read_file_header(filexp); mode0 = INTEGER(mode)[0]; string_buf = new_CharAE(0); symbols_buf = new_CharAEAE(0, 0); return RDS_read_object(filexp, mode0, attribs_dump, string_buf, symbols_buf, 1); } /**************************************************************************** * RDS_extract_subvector() */ static SEXPTYPE extract_top_level_object_type(SEXP filexp) { const char *errmsg; unsigned char obj_header[4]; SEXPTYPE x_type; RDS_read_file_header(filexp); errmsg = RDS_read_bytes(filexp, sizeof(obj_header), 0, obj_header); if (errmsg != NULL) error("%s", errmsg); x_type = RDStype2Rtype(obj_header[3]); if (!IS_ATOMIC_TYPE(x_type) || x_type == STRSXP) error("extracting elements from a serialized object of " "type %s is not supported", CHAR(type2str(x_type))); return x_type; } static const char *get_pos(int pos_type, const void *pos, R_xlen_t i, long long int *pos_elt) { int tmp0, is_na; double tmp1; long long int tmp2; static char errmsg_buf[80]; switch (pos_type) { case 0: // 'pos' contains int values tmp0 = ((const int *) pos)[i]; is_na = tmp0 == NA_INTEGER; *pos_elt = (long long int) tmp0; break; case 1: // 'pos' contains double values tmp1 = ((const double *) pos)[i]; is_na = ISNAN(tmp1); *pos_elt = (long long int) tmp1; break; case 2: // 'pos' contains long long int values tmp2 = ((const long long int *) pos)[i]; is_na = tmp2 == NA_LLINT; *pos_elt = tmp2; break; default: snprintf(errmsg_buf, sizeof(errmsg_buf), "XVector internal error in get_pos(): " "unsupported 'pos' type"); return errmsg_buf; } if (is_na) { snprintf(errmsg_buf, sizeof(errmsg_buf), "'pos' cannot contain NAs"); return errmsg_buf; } return NULL; } static void RDS_read_atom_at_offset(SEXP filexp, long long int offset, SEXP ans, R_xlen_t i) { size_t n; const char *errmsg; if (offset < 0) error("positions of elements to extract must be sorted"); n = offset * type2atomsize(TYPEOF(ans)); errmsg = RDS_read_bytes(filexp, n, 1, NULL); if (errmsg != NULL) error("%s", errmsg); switch (TYPEOF(ans)) { case LGLSXP: errmsg = RDS_read_ints(filexp, 1, 0, LOGICAL(ans) + i); break; case INTSXP: errmsg = RDS_read_ints(filexp, 1, 0, INTEGER(ans) + i); break; case REALSXP: errmsg = RDS_read_doubles(filexp, 1, 0, REAL(ans) + i); break; case CPLXSXP: errmsg = RDS_read_doubles(filexp, 2, 0, (double *) (COMPLEX(ans) + i)); break; case RAWSXP: errmsg = RDS_read_bytes(filexp, 1, 0, RAW(ans) + i); break; default: error("XVector internal error in RDS_read_atom_at_offset(): " "unexpected type: %s", CHAR(type2str(TYPEOF(ans)))); } if (errmsg != NULL) error("%s", errmsg); return; } static const char *RDS_read_atoms_at_positions(SEXP filexp, R_xlen_t x_len, int pos_type, const void *pos, SEXP ans) { long long int pos_elt, prev_pos_elt, offset; R_xlen_t i; const char *errmsg; static char errmsg_buf[40]; prev_pos_elt = 0; for (i = 0; i < XLENGTH(ans); i++) { errmsg = get_pos(pos_type, pos, i, &pos_elt); if (errmsg != NULL) return errmsg; if (pos_elt < 1 || pos_elt > x_len) { snprintf(errmsg_buf, sizeof(errmsg_buf), "'pos' contains invalid positions"); return errmsg_buf; } offset = pos_elt - prev_pos_elt - 1; RDS_read_atom_at_offset(filexp, offset, ans, i); prev_pos_elt = pos_elt; } return NULL; } /* --- .Call ENTRY POINT --- * Random access to the elements of a serialized atomic vector. * Character vectors not supported. * Args: * filexp: External pointer to a FILE pointer. * pos: An integer, double, or LLint vector containing valid element * positions in the serialized vector. The positions must be 1-based. * So no NAs and all values must be >= 1 and <= vector length. * In addition 'pos' must be sorted. */ SEXP RDS_extract_subvector(SEXP filexp, SEXP pos) { SEXPTYPE x_type; R_xlen_t x_len, pos_len; int pos_type; const void *pos_dataptr; SEXP ans; const char *errmsg; /* Get type and length of serialized atomic vector. */ x_type = extract_top_level_object_type(filexp); x_len = RDS_read_vector_length(filexp); /* Get 'pos' length and pointer to data. */ if (IS_INTEGER(pos)) { pos_type = 0; pos_len = XLENGTH(pos); pos_dataptr = INTEGER(pos); } else if (IS_NUMERIC(pos)) { pos_type = 1; pos_len = XLENGTH(pos); pos_dataptr = REAL(pos); } else if (is_LLint(pos)) { pos_type = 2; pos_len = get_LLint_length(pos); pos_dataptr = get_LLint_dataptr(pos); } else { error("'pos' must be an integer, double, or LLint vector"); } ans = PROTECT(allocVector(x_type, pos_len)); errmsg = RDS_read_atoms_at_positions(filexp, x_len, pos_type, pos_dataptr, ans); UNPROTECT(1); if (errmsg != NULL) error("%s", errmsg); return ans; } /**************************************************************************** * RDS_extract_subarray() */ /* --- .Call ENTRY POINT --- * Random access to the elements of a serialized array. * Character arrays not supported. * Args: * filexp: External pointer to a FILE pointer. * dim: The dimensions of the array. Typically extracted earlier with * RDS_read_file(filexp, 3, attribs_dump). * index: A list of subscripts as positive integer vectors. One vector of * subscripts per array dimension. Each subscript must be sorted. */ SEXP RDS_extract_subarray(SEXP filexp, SEXP dim, SEXP index) { SEXPTYPE x_type; R_xlen_t x_len, dimprod; int ndim, i; SEXP subscript, ans; /* Get type and length of serialized array. */ x_type = extract_top_level_object_type(filexp); x_len = RDS_read_vector_length(filexp); /* Check 'dim'. */ if (!IS_INTEGER(dim)) error("'dim' must be an integer vector"); ndim = LENGTH(dim); dimprod = 1; for (i = 0; i < ndim; i++) dimprod *= INTEGER(dim)[i]; if (dimprod > x_len) // this is dangerous error("supplied 'dim' implies that serialized array " "has more elements than it effectively has"); if (dimprod < x_len) // this is not warning("supplied 'dim' implies that serialized array " "has less elements than it effectively has"); /* Check 'index'. */ if (!isVectorList(index)) // IS_LIST() is broken error("'index' must be a list"); if (LENGTH(index) != ndim) error("'index' must have the same length as 'dim'"); for (i = 0; i < ndim; i++) { subscript = VECTOR_ELT(index, i); if (!IS_INTEGER(subscript)) error("all subscripts in list 'index' must be " "integer vectors"); } return R_NilValue; } XVector/src/R_init_XVector.c0000644000175200017520000001441014710220211017005 0ustar00biocbuildbiocbuild#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[] = { /* io_utils.c */ CALLMETHOD_DEF(new_input_filexp, 1), CALLMETHOD_DEF(rewind_filexp, 1), CALLMETHOD_DEF(new_output_filexp, 4), CALLMETHOD_DEF(close_filexp, 1), /* RDS_random_access.c */ CALLMETHOD_DEF(RDS_read_file, 3), CALLMETHOD_DEF(RDS_extract_subvector, 2), CALLMETHOD_DEF(RDS_extract_subarray, 3), /* SharedVector_class.c */ CALLMETHOD_DEF(get_object_address, 1), CALLMETHOD_DEF(get_list_addresses, 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(SharedRaw_new, 2), CALLMETHOD_DEF(C_extract_character_from_SharedRaw_by_positions, 4), CALLMETHOD_DEF(C_extract_character_from_SharedRaw_by_ranges, 5), 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(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(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), /* XRaw_class.c */ CALLMETHOD_DEF(C_extract_character_from_XRaw_by_positions, 4), CALLMETHOD_DEF(C_extract_character_from_XRaw_by_ranges, 5), /* XRawList_comparison.c */ CALLMETHOD_DEF(XRawList_pcompare, 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); /* io_utils.c */ REGISTER_CCALLABLE(_filexp_read); REGISTER_CCALLABLE(_filexp_gets); REGISTER_CCALLABLE(_filexp_tell); REGISTER_CCALLABLE(_filexp_seek); REGISTER_CCALLABLE(_filexp_rewind); REGISTER_CCALLABLE(_filexp_puts); REGISTER_CCALLABLE(_filexp_putc); REGISTER_CCALLABLE(_delete_trailing_LF_or_CRLF); /* 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(_new_XVector); /* XRaw_class.c */ REGISTER_CCALLABLE(_hold_XRaw); REGISTER_CCALLABLE(_new_XRaw_from_tag); REGISTER_CCALLABLE(_alloc_XRaw); /* XInteger_class.c */ REGISTER_CCALLABLE(_hold_XInteger); REGISTER_CCALLABLE(_new_XInteger_from_tag); REGISTER_CCALLABLE(_alloc_XInteger); /* XDouble_class.c */ REGISTER_CCALLABLE(_hold_XDouble); REGISTER_CCALLABLE(_new_XDouble_from_tag); REGISTER_CCALLABLE(_alloc_XDouble); /* XVectorList_class.c */ REGISTER_CCALLABLE(_get_XVectorList_length); REGISTER_CCALLABLE(_get_XVectorList_width); REGISTER_CCALLABLE(_get_XVectorList_names); REGISTER_CCALLABLE(_hold_XVectorList); REGISTER_CCALLABLE(_get_length_from_XVectorList_holder); REGISTER_CCALLABLE(_get_elt_from_XRawList_holder); REGISTER_CCALLABLE(_get_elt_from_XIntegerList_holder); REGISTER_CCALLABLE(_get_elt_from_XDoubleList_holder); REGISTER_CCALLABLE(_get_linear_subset_from_XVectorList_holder); 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/S4Vectors_stubs.c0000644000175200017520000000003614710220211017162 0ustar00biocbuildbiocbuild#include "_S4Vectors_stubs.c" XVector/src/SharedDouble_class.c0000644000175200017520000000574114710220211017644 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of SharedDouble objects * * Author: H. Pag\`es * ****************************************************************************/ #include "XVector.h" 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.c0000644000175200017520000000577214710220211020033 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of SharedInteger objects * * Author: H. Pag\`es * ****************************************************************************/ #include "XVector.h" 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.c0000644000175200017520000002500714710220211017160 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of SharedRaw objects * * Author: H. Pag\`es * ****************************************************************************/ #include "XVector.h" #include "S4Vectors_interface.h" 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). * -------------------------------------------------------------------------- */ SEXP C_extract_character_from_SharedRaw_by_positions(SEXP x, SEXP pos, SEXP collapse, SEXP lkup) { SEXP x_tag; x_tag = _get_SharedVector_tag(x); if (!IS_RAW(x_tag)) error("'x' must be a SharedRaw object"); if (!IS_INTEGER(pos)) error("'pos' must be an integer vector"); if (!(IS_LOGICAL(collapse) && LENGTH(collapse) == 1)) error("'collapse' must be TRUE or FALSE"); return extract_bytes_by_positions( (const char *) RAW(x_tag), LENGTH(x_tag), INTEGER(pos), LENGTH(pos), LOGICAL(collapse)[0], lkup); } SEXP C_extract_character_from_SharedRaw_by_ranges(SEXP x, SEXP start, SEXP width, SEXP collapse, SEXP lkup) { SEXP x_tag; int nranges; const int *start_p, *width_p; x_tag = _get_SharedVector_tag(x); if (!IS_RAW(x_tag)) error("'x' must be a SharedRaw object"); nranges = check_integer_pairs(start, width, &start_p, &width_p, "start", "width"); if (!(IS_LOGICAL(collapse) && LENGTH(collapse) == 1)) error("'collapse' must be TRUE or FALSE"); return extract_bytes_by_ranges( (const char *) RAW(x_tag), LENGTH(x_tag), start_p, width_p, nranges, LOGICAL(collapse)[0], lkup); } /* * Return a single string (character vector of length 1). * From R: * x <- SharedRaw(15) * x[] < "Hello" * .Call("SharedRaw_read_chars_from_i1i2", x, 2L, 4L, 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, 20L, 25L, 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.c0000644000175200017520000003023514710220211017670 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of SharedVector and SharedVector_Pool objects * * Author: H. Pag\`es * ****************************************************************************/ #include "XVector.h" #include "IRanges_interface.h" #include "S4Vectors_interface.h" /**************************************************************************** * get_object_address() and get_list_addresses() * * From R: * .Call("get_object_address", 6:4, PACKAGE="XVector") * .Call("get_object_address", new("externalptr"), PACKAGE="XVector") */ SEXP address_as_CHARSXP(SEXP x) { static char buf[40]; /* should be enough, even for 128-bit addresses */ snprintf(buf, sizeof(buf), "%p", x); return mkChar(buf); } /* --- .Call ENTRY POINT --- */ SEXP get_object_address(SEXP x) { SEXP ans, ans_elt; PROTECT(ans_elt = address_as_CHARSXP(x)); PROTECT(ans = ScalarString(ans_elt)); UNPROTECT(2); return ans; } /* --- .Call ENTRY POINT --- */ SEXP get_list_addresses(SEXP x) { int x_len, i; SEXP ans, x_elt, ans_elt; if (!isVectorList(x)) // IS_LIST() is broken error("XVector internal error in get_list_addresses(): " "'x' must be a list"); x_len = LENGTH(x); PROTECT(ans = NEW_CHARACTER(x_len)); for (i = 0; i < x_len; i++) { x_elt = VECTOR_ELT(x, i); PROTECT(ans_elt = address_as_CHARSXP(x_elt)); SET_STRING_ELT(ans, i, ans_elt); UNPROTECT(1); } UNPROTECT(1); return ans; } /**************************************************************************** * 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/XDouble_class.c0000644000175200017520000000207214710220211016637 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of XDouble objects * * Author: H. Pag\`es * ****************************************************************************/ #include "XVector.h" Doubles_holder _hold_XDouble(SEXP x) { Doubles_holder x_holder; SEXP tag; int offset; tag = _get_XVector_tag(x); offset = _get_XVector_offset(x); x_holder.ptr = (const double *) (REAL(tag) + offset); x_holder.length = _get_XVector_length(x); return x_holder; } 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_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/XInteger_class.c0000644000175200017520000000207114710220211017021 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of XInteger objects * * Author: H. Pag\`es * ****************************************************************************/ #include "XVector.h" Ints_holder _hold_XInteger(SEXP x) { Ints_holder x_holder; SEXP tag; int offset; tag = _get_XVector_tag(x); offset = _get_XVector_offset(x); x_holder.ptr = (const int *) (INTEGER(tag) + offset); x_holder.length = _get_XVector_length(x); return x_holder; } 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; } /* Allocation WITHOUT initialization. */ 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; } XVector/src/XRawList_comparison.c0000644000175200017520000002433114710220211020061 0ustar00biocbuildbiocbuild/**************************************************************************** * Comparing and ordering the elements in one or more XRawList objects * * Author: H. Pag\`es * ****************************************************************************/ #include "XVector.h" #include "S4Vectors_interface.h" #include /* for qsort() */ /**************************************************************************** * Comparison of 2 Chars_holder structs. */ static int compar_Chars_holders(const Chars_holder *x1, const Chars_holder *x2) { int n, ret; n = x1->length < x2->length ? x1->length : x2->length; ret = memcmp(x1->ptr, x2->ptr, n); if (ret != 0) return ret; ret = x1->length - x2->length; return ret; } /* Fast version of 'compar_Chars_holders(x1, x2) == 0' */ static int equal_Chars_holders(const Chars_holder *x1, const Chars_holder *x2) { return x1->length == x2->length && memcmp(x1->ptr, x2->ptr, x1->length) == 0; } /**************************************************************************** * "Parallel" comparison of 2 XRawList objects. */ static void pcompar_from_XRawList_holders(const XVectorList_holder *x, const XVectorList_holder *y, int *out, int out_len, int with_warning) { int x_len, y_len, i, j, k; Chars_holder x_elt, y_elt; x_len = _get_length_from_XVectorList_holder(x); y_len = _get_length_from_XVectorList_holder(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_elt_from_XRawList_holder(x, i); y_elt = _get_elt_from_XRawList_holder(y, j); out[k] = compar_Chars_holders(&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_pcompare(SEXP x, SEXP y) { XVectorList_holder x_holder, y_holder; int x_len, y_len, ans_len; SEXP ans; x_holder = _hold_XVectorList(x); y_holder = _hold_XVectorList(y); x_len = _get_length_from_XVectorList_holder(&x_holder); y_len = _get_length_from_XVectorList_holder(&y_holder); 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)); pcompar_from_XRawList_holders(&x_holder, &y_holder, INTEGER(ans), ans_len, 1); UNPROTECT(1); return ans; } /**************************************************************************** * Order and rank of the elements in an XRawList object. */ static Chars_holder *XX; static int compar_XX(int i1, int i2) { return compar_Chars_holders(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_from_XRawList_holder(const XVectorList_holder *x_holder, int desc, int *out, int out_shift) { int nelt, i, (*compar)(const void *, const void *); nelt = _get_length_from_XVectorList_holder(x_holder); XX = (Chars_holder *) R_alloc(sizeof(Chars_holder), nelt); XX -= out_shift; for (i = 0; i < nelt; i++, out_shift++) { XX[out_shift] = _get_elt_from_XRawList_holder(x_holder, 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) { XVectorList_holder x_holder; int x_length, is_unsorted, i, ret0, ret; Chars_holder x_elt1, x_elt2; SEXP ans; x_holder = _hold_XVectorList(x); x_length = _get_length_from_XVectorList_holder(&x_holder); ret0 = LOGICAL(strictly)[0] ? 0 : 1; is_unsorted = 0; if (x_length >= 2) { x_elt2 = _get_elt_from_XRawList_holder(&x_holder, 0); for (i = 1; i < x_length; i++) { x_elt1 = x_elt2; x_elt2 = _get_elt_from_XRawList_holder(&x_holder, i); ret = compar_Chars_holders(&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) { XVectorList_holder x_holder; int ans_length; SEXP ans; x_holder = _hold_XVectorList(x); ans_length = _get_length_from_XVectorList_holder(&x_holder); PROTECT(ans = NEW_INTEGER(ans_length)); get_order_from_XRawList_holder(&x_holder, 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 XVectorList_holder *x_holder) { const int *oo1, *oo2; Chars_holder x_elt1, x_elt2; int i; oo1 = oo2 = oo; x_elt2 = _get_elt_from_XRawList_holder(x_holder, *oo2); out[*oo2] = 1; oo2++; for (i = 2; i <= nelt; i++) { x_elt1 = x_elt2; x_elt2 = _get_elt_from_XRawList_holder(x_holder, *oo2); out[*oo2] = equal_Chars_holders(&x_elt1, &x_elt2) ? out[*oo1] : i; oo2++; oo1++; } return; } /* --- .Call ENTRY POINT --- */ SEXP XRawList_rank(SEXP x, SEXP ties_method) { XVectorList_holder x_holder; int ans_length, *oo; const char *method; SEXP ans; x_holder = _hold_XVectorList(x); ans_length = _get_length_from_XVectorList_holder(&x_holder); method = CHAR(STRING_ELT(ties_method, 0)); oo = (int *) R_alloc(ans_length, sizeof(int)); get_order_from_XRawList_holder(&x_holder, 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), &x_holder); } else { error("ties_method \"%s\" is not supported", 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_Chars_holder(const struct htab *htab, const Chars_holder *charseq1, const XVectorList_holder *charseqs2) { unsigned int hval; int bucket_idx, i2; const int *buckets; Chars_holder charseq2; hval = djb2_hash((unsigned char *) charseq1->ptr, charseq1->length); bucket_idx = hval & htab->Mminus1; buckets = htab->buckets; while ((i2 = buckets[bucket_idx]) != NA_INTEGER) { charseq2 = _get_elt_from_XRawList_holder(charseqs2, i2); if (equal_Chars_holders(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; XVectorList_holder x_holder1, x_holder2; Chars_holder charseq; struct htab htab; SEXP ans; x_holder1 = _hold_XVectorList(x1); x_holder2 = _hold_XVectorList(x2); len1 = _get_length_from_XVectorList_holder(&x_holder1); len2 = _get_length_from_XVectorList_holder(&x_holder2); nomatch0 = INTEGER(nomatch)[0]; htab = new_htab(len2); for (i = 0; i < len2; i++) { charseq = _get_elt_from_XRawList_holder(&x_holder2, i); bucket_idx = get_bucket_idx_for_Chars_holder(&htab, &charseq, &x_holder2); 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_elt_from_XRawList_holder(&x_holder1, i); bucket_idx = get_bucket_idx_for_Chars_holder(&htab, &charseq, &x_holder2); 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; XVectorList_holder x_holder; Chars_holder charseq; struct htab htab; SEXP ans; x_holder = _hold_XVectorList(x); ans_length = _get_length_from_XVectorList_holder(&x_holder); htab = new_htab(ans_length); PROTECT(ans = NEW_INTEGER(ans_length)); ans0 = INTEGER(ans); for (i = 0; i < ans_length; i++) { charseq = _get_elt_from_XRawList_holder(&x_holder, i); bucket_idx = get_bucket_idx_for_Chars_holder(&htab, &charseq, &x_holder); 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/XRaw_class.c0000644000175200017520000000454314710220211016163 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of XRaw objects * * Author: H. Pag\`es * ****************************************************************************/ #include "XVector.h" #include "S4Vectors_interface.h" Chars_holder _hold_XRaw(SEXP x) { Chars_holder x_holder; SEXP tag; int offset; tag = _get_XVector_tag(x); offset = _get_XVector_offset(x); x_holder.ptr = (const char *) (RAW(tag) + offset); x_holder.length = _get_XVector_length(x); return x_holder; } 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; } /* 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 C_extract_character_from_XRaw_by_positions(SEXP x, SEXP pos, SEXP collapse, SEXP lkup) { SEXP x_tag; int x_off, x_len; x_tag = _get_XVector_tag(x); if (!IS_RAW(x_tag)) error("'x' must be an XRaw object"); x_off = _get_XVector_offset(x); x_len = _get_XVector_length(x); if (!IS_INTEGER(pos)) error("'pos' must be an integer vector"); if (!(IS_LOGICAL(collapse) && LENGTH(collapse) == 1)) error("'collapse' must be TRUE or FALSE"); return extract_bytes_by_positions( (const char *) (RAW(x_tag) + x_off), x_len, INTEGER(pos), LENGTH(pos), LOGICAL(collapse)[0], lkup); } SEXP C_extract_character_from_XRaw_by_ranges(SEXP x, SEXP start, SEXP width, SEXP collapse, SEXP lkup) { SEXP x_tag; int x_off, x_len; int nranges; const int *start_p, *width_p; x_tag = _get_XVector_tag(x); if (!IS_RAW(x_tag)) error("'x' must be an XRaw object"); x_off = _get_XVector_offset(x); x_len = _get_XVector_length(x); nranges = check_integer_pairs(start, width, &start_p, &width_p, "start", "width"); if (!(IS_LOGICAL(collapse) && LENGTH(collapse) == 1)) error("'collapse' must be TRUE or FALSE"); return extract_bytes_by_ranges( (const char *) (RAW(x_tag) + x_off), x_len, start_p, width_p, nranges, LOGICAL(collapse)[0], lkup); } XVector/src/XVector.h0000644000175200017520000002566414710220211015523 0ustar00biocbuildbiocbuild#include "../inst/include/XVector_defines.h" #include #define INTERNAL_ERR_IN "XVector internal error in " #define INIT_STATIC_SYMBOL(NAME) \ { \ if (NAME ## _symbol == NULL) \ NAME ## _symbol = install(# NAME); \ } /* io_utils.c */ int _filexp_read( SEXP filexp, char *buf, int buf_size ); int _filexp_gets( SEXP filexp, char *buf, int buf_size, int *EOL_in_buf ); long long int _filexp_tell(SEXP filexp); void _filexp_seek( SEXP filexp, long long int offset, int whence ); void _filexp_rewind(SEXP filexp); int _filexp_puts( SEXP filexp, const char *s ); void _filexp_putc( SEXP filexp, int c ); SEXP new_input_filexp(SEXP filepath); SEXP rewind_filexp(SEXP filexp); SEXP new_output_filexp( SEXP filepath, SEXP append, SEXP compress, SEXP compression_level ); SEXP close_filexp(SEXP filexp); int _delete_trailing_LF_or_CRLF( const char *buf, int buf_len ); /* RDS_random_access.c */ SEXP RDS_read_file( SEXP filexp, SEXP mode, SEXP attribs_dump ); SEXP RDS_extract_subvector( SEXP filexp, SEXP pos ); SEXP RDS_extract_subarray( SEXP filexp, SEXP dim, SEXP index ); /* 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 *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 get_object_address(SEXP x); SEXP get_list_addresses(SEXP x); 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 SharedRaw_new( SEXP length, SEXP val ); SEXP C_extract_character_from_SharedRaw_by_positions( SEXP x, SEXP pos, SEXP collapse, SEXP lkup ); SEXP C_extract_character_from_SharedRaw_by_ranges( SEXP x, SEXP start, SEXP width, SEXP collapse, SEXP lkup ); 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 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 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 _get_XVector_shared(SEXP x); int _get_XVector_offset(SEXP x); int _get_XVector_length(SEXP x); SEXP _get_XVector_tag(SEXP x); SEXP _new_XVector( const char *classname, SEXP shared, int offset, int length ); /* XRaw_class.c */ Chars_holder _hold_XRaw(SEXP x); SEXP _new_XRaw_from_tag( const char *classname, SEXP tag ); SEXP _alloc_XRaw( const char *classname, int length ); SEXP C_extract_character_from_XRaw_by_positions( SEXP x, SEXP pos, SEXP collapse, SEXP lkup ); SEXP C_extract_character_from_XRaw_by_ranges( SEXP x, SEXP start, SEXP width, SEXP collapse, SEXP lkup ); /* XInteger_class.c */ Ints_holder _hold_XInteger(SEXP x); SEXP _new_XInteger_from_tag( const char *classname, SEXP tag ); SEXP _alloc_XInteger( const char *classname, int length ); /* XDouble_class.c */ Doubles_holder _hold_XDouble(SEXP x); SEXP _new_XDouble_from_tag( const char *classname, SEXP tag ); SEXP _alloc_XDouble( const char *classname, int length ); /* XVectorList_class.c */ 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); XVectorList_holder _hold_XVectorList(SEXP x); int _get_length_from_XVectorList_holder(const XVectorList_holder *x_holder); Chars_holder _get_elt_from_XRawList_holder( const XVectorList_holder *x_holder, int i ); Ints_holder _get_elt_from_XIntegerList_holder( const XVectorList_holder *x_holder, int i ); Doubles_holder _get_elt_from_XDoubleList_holder( const XVectorList_holder *x_holder, int i ); XVectorList_holder _get_linear_subset_from_XVectorList_holder( const XVectorList_holder *x_holder, int offset, int length ); 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_pcompare( 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.c0000644000175200017520000003216414710220211017530 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of XVectorList objects * * Author: H. Pag\`es * ****************************************************************************/ #include "XVector.h" #include "IRanges_interface.h" #include "S4Vectors_interface.h" /**************************************************************************** * 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. */ XVectorList_holder _hold_XVectorList(SEXP x) { XVectorList_holder x_holder; SEXP ranges; x_holder.classname = get_classname(x); x_holder.element_type = get_List_elementType(x); x_holder.xp_list = _get_SharedVector_Pool_xp_list( _get_XVectorList_pool(x)); ranges = _get_XVectorList_ranges(x); x_holder.length = get_IRanges_length(ranges); x_holder.start = INTEGER(get_IRanges_start(ranges)); x_holder.width = INTEGER(get_IRanges_width(ranges)); x_holder.group = INTEGER(get_GroupedIRanges_group(ranges)); return x_holder; } int _get_length_from_XVectorList_holder(const XVectorList_holder *x_holder) { return x_holder->length; } Chars_holder _get_elt_from_XRawList_holder(const XVectorList_holder *x_holder, int i) { SEXP tag; Chars_holder x_elt_holder; tag = R_ExternalPtrTag(VECTOR_ELT(x_holder->xp_list, x_holder->group[i] - 1)); x_elt_holder.ptr = (const char *) RAW(tag) + x_holder->start[i] - 1; x_elt_holder.length = x_holder->width[i]; return x_elt_holder; } Ints_holder _get_elt_from_XIntegerList_holder(const XVectorList_holder *x_holder, int i) { SEXP tag; Ints_holder x_elt_holder; tag = R_ExternalPtrTag(VECTOR_ELT(x_holder->xp_list, x_holder->group[i] - 1)); x_elt_holder.ptr = INTEGER(tag) + x_holder->start[i] - 1; x_elt_holder.length = x_holder->width[i]; return x_elt_holder; } Doubles_holder _get_elt_from_XDoubleList_holder(const XVectorList_holder *x_holder, int i) { SEXP tag; Doubles_holder x_elt_holder; tag = R_ExternalPtrTag(VECTOR_ELT(x_holder->xp_list, x_holder->group[i] - 1)); x_elt_holder.ptr = REAL(tag) + x_holder->start[i] - 1; x_elt_holder.length = x_holder->width[i]; return x_elt_holder; } XVectorList_holder _get_linear_subset_from_XVectorList_holder( const XVectorList_holder *x_holder, int offset, int length) { XVectorList_holder y_holder; y_holder = *x_holder; y_holder.length = length; y_holder.start += offset; y_holder.width += offset; y_holder.group += offset; return y_holder; } /**************************************************************************** * 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 268435456 /* = 256 Mb if tag is a raw vector */ 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, names, 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); } names = GET_NAMES(width); if (names != R_NilValue) { PROTECT(width = duplicate(width)); SET_NAMES(width, R_NilValue); } PROTECT(ranges = new_IRanges("IRanges", start, width, names)); 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); } if (names != R_NilValue) UNPROTECT(1); 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; XVectorList_holder ans_holder; Chars_holder 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)); ans_holder = _hold_XVectorList(ans); for (i = 0; i < nelt; i++) { src = char_aeae->elts[i]; dest = _get_elt_from_XRawList_holder(&ans_holder, i); /* dest.ptr 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.ptr, 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; XVectorList_holder ans_holder; Ints_holder 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)); ans_holder = _hold_XVectorList(ans); for (i = 0; i < nelt; i++) { src = int_aeae->elts[i]; dest = _get_elt_from_XIntegerList_holder(&ans_holder, i); /* dest.ptr 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.ptr, dest.length, (const char *) src->elts, IntAE_get_nelt(src), sizeof(int)); } UNPROTECT(2); return ans; } XVector/src/XVector_class.c0000644000175200017520000000476214710220211016677 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level manipulation of XVector objects * * Author: H. Pag\`es * ****************************************************************************/ #include "XVector.h" /**************************************************************************** * 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 convenient to have. */ SEXP _get_XVector_tag(SEXP x) { return _get_SharedVector_tag(_get_XVector_shared(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 constructor * * 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; } XVector/src/io_utils.c0000644000175200017520000003615014710220211015743 0ustar00biocbuildbiocbuild/**************************************************************************** **************************************************************************** * I/O low-level utils * * Author: H. Pag\`es * **************************************************************************** ****************************************************************************/ #include "XVector.h" /**************************************************************************** * ZFile structs * ****************************************************************************/ #include /* for malloc(), free() */ #include //#ifndef _WIN32 //#include //#endif #define UNCOMPRESSED 0 #define GZ_TYPE 1 #define BZ2_TYPE 2 /* detected but not supported */ #define XZ_TYPE 3 /* detected but not supported */ typedef struct zfile { const char *path; const char *expath; const char *mode; /* "r", "w", or "a" */ int ztype; int subtype; void *file; } ZFile; /**************************************************************************** * Input functions. */ static void *iZFile_open(const char *expath, int ztype, int subtype) { void *file; switch (ztype) { case UNCOMPRESSED: case GZ_TYPE: file = gzopen(expath, "r"); break; case BZ2_TYPE: error("cannot open file '%s'\n" " bzip2-compressed files are not supported", expath); //#ifndef _WIN32 // file = BZ2_bzopen(expath, "rb"); //#else // error("cannot open file '%s'\n" // " bzip2-compressed files are not supported " // "on Windows, sorry!", expath); //#endif break; case XZ_TYPE: error("cannot open file '%s'\n" " LZMA-compressed files are not supported", expath); //#ifndef _WIN32 //requires #include //opening/closing this type of file seems quite //complicated //#else // error("cannot open file '%s'\n" // " LZMA-compressed files are not supported " // "on Windows, sorry!", expath); //#endif break; default: error(INTERNAL_ERR_IN "iZFile_open(): " "invalid ztype value %d", ztype); } return file; } static void iZFile_close(const ZFile *zfile) { int ztype; void *file; ztype = zfile->ztype; file = zfile->file; switch (ztype) { case UNCOMPRESSED: case GZ_TYPE: gzclose((gzFile) file); break; //#ifndef _WIN32 // case BZ2_TYPE: // BZ2_bzclose((BZFILE *) file); // break; //#endif default: error(INTERNAL_ERR_IN "iZFile_close(): " "invalid ztype value %d", ztype); } return; } /* Here is how gzread() is declared in zlib.h: int gzread(gzFile file, voidp buf, unsigned len); And also, according to zlib.h: gzread returns the number of uncompressed bytes actually read, less than len for end of file, or -1 for error. But gzread returns an int and len is an unsigned int so can be > INT_MAX. So how can gzread return the number of uncompressed bytes actually read when len is INT_MAX? Sounds like poor interface design to me. So for iZFile_read(), we set the type of buf_size to int, not unsigned int. */ static int iZFile_read(const ZFile *zfile, char *buf, int buf_size) { int ztype; void *file; ztype = zfile->ztype; file = zfile->file; switch (ztype) { case UNCOMPRESSED: case GZ_TYPE: return gzread((gzFile) file, buf, (unsigned int) buf_size); //#ifndef _WIN32 // case BZ2_TYPE: // break; //#endif default: error(INTERNAL_ERR_IN "iZFile_read(): " "invalid ztype value %d", ztype); } return 0; } /* * Similar to fgets()/gzgets(), except that it returns a code instead of * NULL/Z_NULL or a pointer to the buffer. The returned code can be: * 2: if reading stopped after an EOF or a newline, * 1: if reading stopped because buffer was full and no EOF or newline was * read in, * 0: if end of file occurred while no character was read, * -1: on read error. */ static int iZFile_gets(const ZFile *zfile, char *buf, int buf_size, int *EOL_in_buf) { int max_buf_len, ztype; void *file; //int i; //char *buf_p; max_buf_len = buf_size - 1; buf[max_buf_len] = 'N'; // any non '\0' would do ztype = zfile->ztype; file = zfile->file; switch (ztype) { case UNCOMPRESSED: case GZ_TYPE: if (gzgets((gzFile) file, buf, buf_size) == Z_NULL) { //if (ferror(file) != 0 || feof(file) == 0) // return -1; return 0; } break; //#ifndef _WIN32 // case BZ2_TYPE: // for (i = 0, buf_p = buf; i < max_buf_len; i++, buf_p++) { // if (BZ2_bzread((BZFILE *) file, buf_p, 1) == 0) { // if (i == 0) // return 0; // break; // } // if (*buf_p == '\n') { // buf_p++; // break; // } // } // *buf_p = '\0'; // break; //#endif default: error(INTERNAL_ERR_IN "iZFile_gets(): " "invalid ztype value %d", ztype); } *EOL_in_buf = buf[max_buf_len] == 'N' || buf[max_buf_len - 1] == '\n'; return *EOL_in_buf ? 2 : 1; } static long long int iZFile_tell(ZFile *zfile) { int ztype; void *file; long long int offset; ztype = zfile->ztype; file = zfile->file; switch (ztype) { case UNCOMPRESSED: case GZ_TYPE: offset = gztell((gzFile) file); break; default: error(INTERNAL_ERR_IN "iZFile_tell(): " "invalid ztype value %d", ztype); } return offset; } static void iZFile_seek(ZFile *zfile, long long int offset, int whence) { int ztype; void *file; ztype = zfile->ztype; file = zfile->file; switch (ztype) { case UNCOMPRESSED: case GZ_TYPE: gzseek((gzFile) file, (z_off_t) offset, whence); break; //#ifndef _WIN32 // case BZ2_TYPE: // error(INTERNAL_ERR_IN "iZFile_seek(): " // "iZFile_seek() not supported on bz2-compressed files"); // zfile->file = file; // break; //#endif default: error(INTERNAL_ERR_IN "iZFile_seek(): " "invalid ztype value %d", ztype); } return; } static void iZFile_rewind(ZFile *zfile) { int ztype; void *file; ztype = zfile->ztype; file = zfile->file; switch (ztype) { case UNCOMPRESSED: case GZ_TYPE: gzrewind((gzFile) file); break; //#ifndef _WIN32 // case BZ2_TYPE: // /* No rewind in the bzip2 library. So we close and re-open // the file. */ // BZ2_bzclose((BZFILE *) file); // file = BZ2_bzopen(zfile->expath, "rb"); // if (file == NULL) // error(INTERNAL_ERR_IN "iZFile_rewind(): " // "cannot re-open file '%s'", zfile->expath); // zfile->file = file; // break; //#endif default: error(INTERNAL_ERR_IN "iZFile_rewind(): " "invalid ztype value %d", ztype); } return; } /**************************************************************************** * Output functions. */ static void *oZFile_open(const char *expath, const char *mode, int ztype, int subtype) { void *file; switch (ztype) { case UNCOMPRESSED: file = fopen(expath, mode); break; case GZ_TYPE: file = gzopen(expath, mode); break; case BZ2_TYPE: error("cannot open file '%s'\n" " bzip2-compressed files are not supported", expath); //#ifndef _WIN32 // file = BZ2_bzopen(expath, mode); //#else // error("cannot open file '%s'\n" // " bzip2-compressed files are not supported " // "on Windows, sorry!", expath); //#endif break; case XZ_TYPE: error("cannot open file '%s'\n" " LZMA-compressed files are not supported", expath); //#ifndef _WIN32 //requires #include //opening/closing this type of file seems quite //complicated //#else // error("cannot open file '%s'\n" // " LZMA-compressed files are not supported " // "on Windows, sorry!", expath); //#endif break; default: error(INTERNAL_ERR_IN "oZFile_open(): " "invalid ztype value %d", ztype); } return file; } static void oZFile_close(const ZFile *zfile) { int ztype; void *file; ztype = zfile->ztype; file = zfile->file; switch (ztype) { case UNCOMPRESSED: fclose((FILE *) file); break; case GZ_TYPE: gzclose((gzFile) file); break; //#ifndef _WIN32 // case BZ2_TYPE: // BZ2_bzclose((BZFILE *) file); // break; //#endif default: error(INTERNAL_ERR_IN "oZFile_close(): " "invalid ztype value %d", ztype); } return; } static int oZFile_puts(const ZFile *zfile, const char *s) { int ztype, n; void *file; ztype = zfile->ztype; file = zfile->file; switch (ztype) { case UNCOMPRESSED: if ((n = fputs(s, (FILE *) file)) >= 0) return n; break; case GZ_TYPE: if ((n = gzputs((gzFile) file, s)) >= 0) return n; break; default: error(INTERNAL_ERR_IN "oZFile_puts(): " "invalid ztype value %d", ztype); } error("write error"); } static void oZFile_putc(const ZFile *zfile, int c) { int ztype; void *file; ztype = zfile->ztype; file = zfile->file; switch (ztype) { case UNCOMPRESSED: if (fputc(c, (FILE *) file) != EOF) return; break; case GZ_TYPE: if (gzputc((gzFile) file, c) != -1) return; break; default: error(INTERNAL_ERR_IN "oZFile_putc(): " "invalid ztype value %d", ztype); } error("write error"); } /**************************************************************************** * Initialization/close. */ /* Code taken from do_url() in R/src/main/connections.c */ static void detect_file_ztype(const char *expath, int *ztype, int *subtype) { FILE *fp; char buf[7]; int res; *ztype = UNCOMPRESSED; *subtype = 0; if ((fp = fopen(expath, "rb")) == NULL) return; memset(buf, 0, 7); res = fread(buf, 5, 1, fp); fclose(fp); if (res != 1) return; if (buf[0] == '\x1f' && buf[1] == '\x8b') *ztype = GZ_TYPE; else if (strncmp(buf, "BZh", 3) == 0) *ztype = BZ2_TYPE; else if (buf[0] == '\xFD' && strncmp(buf+1, "7zXZ", 4) == 0) *ztype = XZ_TYPE; else if ((buf[0] == '\xFF') && strncmp(buf+1, "LZMA", 4) == 0) { *ztype = XZ_TYPE; *subtype = 1; } else if (memcmp(buf, "]\0\0\200\0", 5) == 0) { *ztype = XZ_TYPE; *subtype = 1; } return; } static int compress2ztype(const char *compress) { if (strcmp(compress, "no") == 0) return UNCOMPRESSED; if (strcmp(compress, "gzip") == 0) return GZ_TYPE; if (strcmp(compress, "bzip2") == 0) return BZ2_TYPE; if (strcmp(compress, "xz") == 0) return XZ_TYPE; error(INTERNAL_ERR_IN "compress2ztype(): " "invalid type of compression: %s", compress); } static ZFile new_ZFile(const char *path, const char *expath, const char *mode, const char *compress, int level) { ZFile zfile; int ztype, subtype = 0; void *file; if (strcmp(mode, "r") == 0) { /* Open file for reading. */ detect_file_ztype(expath, &ztype, &subtype); file = iZFile_open(expath, ztype, subtype); } else { /* Open file for writing or appending. */ ztype = compress2ztype(compress); file = oZFile_open(expath, mode, ztype, subtype); } if (file == NULL) error("cannot open file '%s'", expath); zfile.path = path; zfile.expath = expath; zfile.mode = mode; zfile.ztype = ztype; zfile.subtype = subtype; zfile.file = file; return zfile; } static void ZFile_close(const ZFile *zfile) { const char *mode; mode = zfile->mode; if (strcmp(mode, "r") == 0) { iZFile_close(zfile); } else { oZFile_close(zfile); } return; } /**************************************************************************** * Low-level manipulation of "file external pointers" * ****************************************************************************/ #define CHECK_USER_INTERRUPT(ncall) \ { \ static int i = 0; \ if (i++ >= (ncall)) { \ R_CheckUserInterrupt(); \ i = 0; \ } \ } int _filexp_read(SEXP filexp, char *buf, int buf_size) { CHECK_USER_INTERRUPT(2000); return iZFile_read(R_ExternalPtrAddr(filexp), buf, buf_size); } int _filexp_gets(SEXP filexp, char *buf, int buf_size, int *EOL_in_buf) { CHECK_USER_INTERRUPT(2000); return iZFile_gets(R_ExternalPtrAddr(filexp), buf, buf_size, EOL_in_buf); } long long int _filexp_tell(SEXP filexp) { CHECK_USER_INTERRUPT(100); return iZFile_tell(R_ExternalPtrAddr(filexp)); } void _filexp_seek(SEXP filexp, long long int offset, int whence) { CHECK_USER_INTERRUPT(100); iZFile_seek(R_ExternalPtrAddr(filexp), offset, whence); return; } void _filexp_rewind(SEXP filexp) { CHECK_USER_INTERRUPT(100); iZFile_rewind(R_ExternalPtrAddr(filexp)); return; } int _filexp_puts(SEXP filexp, const char *s) { CHECK_USER_INTERRUPT(2000); return oZFile_puts(R_ExternalPtrAddr(filexp), s); } void _filexp_putc(SEXP filexp, int c) { CHECK_USER_INTERRUPT(100000); oZFile_putc(R_ExternalPtrAddr(filexp), c); return; } static SEXP new_filexp(SEXP filepath, const char *mode, const char *compress, int level) { SEXP filepath0, ans, string; const char *expath; ZFile zfile, *extptraddr; if (!IS_CHARACTER(filepath) || LENGTH(filepath) != 1) error("'filepath' must be a single string"); filepath0 = STRING_ELT(filepath, 0); if (filepath0 == NA_STRING) error("'filepath' is NA"); expath = R_ExpandFileName(translateChar(filepath0)); zfile = new_ZFile(CHAR(filepath0), expath, mode, compress, level); extptraddr = (ZFile *) malloc(sizeof(ZFile)); if (extptraddr == NULL) { ZFile_close(&zfile); error(INTERNAL_ERR_IN "new_filexp(): malloc() failed"); } *extptraddr = zfile; PROTECT(ans = R_MakeExternalPtr(extptraddr, R_NilValue, R_NilValue)); PROTECT(string = mkString(expath)); setAttrib(ans, install("expath"), string); UNPROTECT(2); return ans; } /* --- .Call ENTRY POINT --- * Returns an external pointer. * From R: * x <- .Call("new_input_filexp", "path/to/some/file", PACKAGE="XVector") * reg.finalizer(x, * function(e) .Call("close_filexp", e, PACKAGE="XVector"), * onexit=TRUE) */ SEXP new_input_filexp(SEXP filepath) { return new_filexp(filepath, "r", NULL, 0); } /* --- .Call ENTRY POINT --- */ SEXP rewind_filexp(SEXP filexp) { _filexp_rewind(filexp); return R_NilValue; } /* --- .Call ENTRY POINT --- * Returns an external pointer. */ SEXP new_output_filexp(SEXP filepath, SEXP append, SEXP compress, SEXP compression_level) { const char *mode, *compress0; int level; mode = LOGICAL(append)[0] ? "a" : "w"; compress0 = CHAR(STRING_ELT(compress, 0)); level = INTEGER(compression_level)[0]; return new_filexp(filepath, mode, compress0, level); } /* --- .Call ENTRY POINT --- * Closes the file pointed to by 'filexp'. */ SEXP close_filexp(SEXP filexp) { ZFile *zfile; zfile = R_ExternalPtrAddr(filexp); if (zfile != NULL) { ZFile_close(zfile); free(zfile); R_SetExternalPtrAddr(filexp, NULL); } return R_NilValue; } /**************************************************************************** * Other stuff * ****************************************************************************/ /* * Doesn't actually delete anything but returns the length the 'buf' char * array would have after deletion of the LF ("\n") or CRLF ("\r\n") chars * located at its end. * If 'buf_len' is -1, then 'buf' must be a C string (i.e. null-terminated). */ int _delete_trailing_LF_or_CRLF(const char *buf, int buf_len) { if (buf_len == -1) buf_len = strlen(buf); if (buf_len == 0) return 0; if (buf[--buf_len] != '\n') return ++buf_len; if (buf_len == 0) return 0; if (buf[--buf_len] != '\r') return ++buf_len; return buf_len; } XVector/src/slice_methods.c0000644000175200017520000000542614710220211016740 0ustar00biocbuildbiocbuild#include "XVector.h" #include "IRanges_interface.h" /* * --- .Call ENTRY POINT --- */ SEXP XInteger_slice(SEXP x, SEXP lower, SEXP upper) { Ints_holder 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 = _hold_XInteger(x); ans_length = 0; prev_elt = 0; for (i = 1, X_elt = X.ptr; 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.ptr; 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) { Doubles_holder 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 = _hold_XDouble(x); ans_length = 0; prev_elt = 0; for (i = 1, X_elt = X.ptr; 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.ptr; 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.c0000644000175200017520000002343714710220211016454 0ustar00biocbuildbiocbuild/**************************************************************************** * Low-level utilities for copying data * * from a vector to a vector of the same type * ****************************************************************************/ #include "XVector.h" #include "IRanges_interface.h" #include "S4Vectors_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) { copy_vector_block(out, (long long int) out_offset, in, (long long int) in_offset, (long long int) 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.c0000644000175200017520000003036714710220211021577 0ustar00biocbuildbiocbuild#include "XVector.h" #include "IRanges_interface.h" #include #define R_INT_MIN (1+INT_MIN) /**************************************************************************** * Low-level operations on Ints_holder (sequences of ints) and * Doubles_holder (sequences of doubles) structures. */ static Ints_holder get_view_from_Ints_holder(const Ints_holder *X, int view_start, int view_width) { Ints_holder 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.ptr = X->ptr + view_offset; X_view.length = view_width; return X_view; } static Doubles_holder get_view_from_Doubles_holder(const Doubles_holder *X, int view_start, int view_width) { Doubles_holder 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.ptr = X->ptr + 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_min_from_Ints_holder(const Ints_holder *X, int narm) { int xlen, val, i, x; xlen = X->length; val = NA_INTEGER; for (i = 0; i < xlen; i++) { x = X->ptr[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_min_from_Doubles_holder(const Doubles_holder *X, int narm) { int xlen, i; double val, x; xlen = X->length; val = R_PosInf; for (i = 0; i < xlen; i++) { x = X->ptr[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_max_from_Ints_holder(const Ints_holder *X, int narm) { int xlen, val, i, x; xlen = X->length; val = NA_INTEGER; for (i = 0; i < xlen; i++) { x = X->ptr[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_max_from_Doubles_holder(const Doubles_holder *X, int narm) { int xlen, i; double val, x; xlen = X->length; val = R_NegInf; for (i = 0; i < xlen; i++) { x = X->ptr[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_sum_from_Ints_holder(const Ints_holder *X, int narm) { int xlen, val, i, x; xlen = X->length; val = 0; for (i = 0; i < xlen; i++) { x = X->ptr[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_sum_from_Doubles_holder(const Doubles_holder *X, int narm) { int xlen, i; double val, x; xlen = X->length; val = 0.00; for (i = 0; i < xlen; i++) { x = X->ptr[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_which_min_from_Ints_holder(const Ints_holder *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->ptr[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_which_min_from_Doubles_holder(const Doubles_holder *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->ptr[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_which_max_from_Ints_holder(const Ints_holder *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->ptr[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_which_max_from_Doubles_holder(const Doubles_holder *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->ptr[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; Ints_holder S, S_view; IRanges_holder ranges_holder; const char *funname; int (*fun)(const Ints_holder *, int); int ans_len, v, view_start, view_width, *ans_elt; subject = GET_SLOT(x, install("subject")); S = _hold_XInteger(subject); ranges_holder = hold_IRanges(GET_SLOT(x, install("ranges"))); funname = CHAR(STRING_ELT(method, 0)); if (strcmp(funname, "viewMins") == 0) fun = &get_min_from_Ints_holder; else if (strcmp(funname, "viewMaxs") == 0) fun = &get_max_from_Ints_holder; else if (strcmp(funname, "viewSums") == 0) fun = &get_sum_from_Ints_holder; else error("XVector internal error in XIntegerViews_summary1(): " "invalid method \"%s\"", funname); ans_len = get_length_from_IRanges_holder(&ranges_holder); PROTECT(ans = NEW_INTEGER(ans_len)); for (v = 0, ans_elt = INTEGER(ans); v < ans_len; v++, ans_elt++) { view_start = get_start_elt_from_IRanges_holder(&ranges_holder, v); view_width = get_width_elt_from_IRanges_holder(&ranges_holder, v); S_view = get_view_from_Ints_holder(&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; Doubles_holder S, S_view; IRanges_holder ranges_holder; const char *funname; double (*fun)(const Doubles_holder *, int); int ans_len, v, view_start, view_width; double *ans_elt; subject = GET_SLOT(x, install("subject")); S = _hold_XDouble(subject); ranges_holder = hold_IRanges(GET_SLOT(x, install("ranges"))); funname = CHAR(STRING_ELT(method, 0)); if (strcmp(funname, "viewMins") == 0) fun = &get_min_from_Doubles_holder; else if (strcmp(funname, "viewMaxs") == 0) fun = &get_max_from_Doubles_holder; else if (strcmp(funname, "viewSums") == 0) fun = &get_sum_from_Doubles_holder; else error("IRanges internal error in XDoubleViews_summary1(): " "invalid method \"%s\"", funname); ans_len = get_length_from_IRanges_holder(&ranges_holder); PROTECT(ans = NEW_NUMERIC(ans_len)); for (v = 0, ans_elt = REAL(ans); v < ans_len; v++, ans_elt++) { view_start = get_start_elt_from_IRanges_holder(&ranges_holder, v); view_width = get_width_elt_from_IRanges_holder(&ranges_holder, v); S_view = get_view_from_Doubles_holder(&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; Ints_holder S, S_view; IRanges_holder ranges_holder; const char *funname; int (*fun)(const Ints_holder *, int); int ans_len, v, view_start, view_width, *ans_elt, which_min; subject = GET_SLOT(x, install("subject")); S = _hold_XInteger(subject); ranges_holder = hold_IRanges(GET_SLOT(x, install("ranges"))); funname = CHAR(STRING_ELT(method, 0)); if (strcmp(funname, "viewWhichMins") == 0) fun = &get_which_min_from_Ints_holder; else if (strcmp(funname, "viewWhichMaxs") == 0) fun = &get_which_max_from_Ints_holder; else error("XVector internal error in XIntegerViews_summary2(): " "invalid method \"%s\"", funname); ans_len = get_length_from_IRanges_holder(&ranges_holder); PROTECT(ans = NEW_INTEGER(ans_len)); for (v = 0, ans_elt = INTEGER(ans); v < ans_len; v++, ans_elt++) { view_start = get_start_elt_from_IRanges_holder(&ranges_holder, v); view_width = get_width_elt_from_IRanges_holder(&ranges_holder, v); S_view = get_view_from_Ints_holder(&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.ptr - S.ptr + which_min; } UNPROTECT(1); return ans; } SEXP XDoubleViews_summary2(SEXP x, SEXP na_rm, SEXP method) { SEXP ans, subject; Doubles_holder S, S_view; IRanges_holder ranges_holder; const char *funname; int (*fun)(const Doubles_holder *, int); int ans_len, v, view_start, view_width, *ans_elt, which_min; subject = GET_SLOT(x, install("subject")); S = _hold_XDouble(subject); ranges_holder = hold_IRanges(GET_SLOT(x, install("ranges"))); funname = CHAR(STRING_ELT(method, 0)); if (strcmp(funname, "viewWhichMins") == 0) fun = &get_which_min_from_Doubles_holder; else if (strcmp(funname, "viewWhichMaxs") == 0) fun = &get_which_max_from_Doubles_holder; else error("IRanges internal error in XDoubleViews_summary2(): " "invalid method \"%s\"", funname); ans_len = get_length_from_IRanges_holder(&ranges_holder); PROTECT(ans = NEW_INTEGER(ans_len)); for (v = 0, ans_elt = INTEGER(ans); v < ans_len; v++, ans_elt++) { view_start = get_start_elt_from_IRanges_holder(&ranges_holder, v); view_width = get_width_elt_from_IRanges_holder(&ranges_holder, v); S_view = get_view_from_Doubles_holder(&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.ptr - S.ptr + which_min; } UNPROTECT(1); return ans; } XVector/tests/0000755000175200017520000000000014710220211014316 5ustar00biocbuildbiocbuildXVector/tests/run_unitTests.R0000644000175200017520000000011714710220211017326 0ustar00biocbuildbiocbuildrequire("XVector") || stop("unable to load XVector package") XVector:::.test()