inst/demo_srcs/IRanges/R/IPos-class.R

In vjcitn/BiocQE: Bioconductor Quality Enhancement

### =========================================================================
### IPos objects
### -------------------------------------------------------------------------
###


setClass("IPos",
    contains=c("Pos", "IPosRanges"),
    representation(
        "VIRTUAL",
        NAMES="character_OR_NULL"  # R doesn't like @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", "IPos",
    function(x) c("NAMES", callNextMethod())
)

setClass("UnstitchedIPos",
    contains="IPos",
    representation(
        pos="integer"
    )
)

### 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", "UnstitchedIPos",
    function(x) c("pos", callNextMethod())
)

setClass("StitchedIPos",
    contains="IPos",
    representation(
        pos_runs="IRanges"  # An unnamed IRanges instance that has
                            # been "stitched" (see below).
    )
)


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Validity
###

.OLD_IPOS_INSTANCE_MSG <- c(
    "Starting with BioC 3.10, the class attribute of all ",
    "IPos **instances** needs to be set to \"StitchedIPos\". ",
    "Please update this object with 'updateObject(object, verbose=TRUE)' ",
    "and re-serialize it."
)

.validate_IPos <- function(x)
{
    if (class(x) == "IPos")
        return(paste(.OLD_IPOS_INSTANCE_MSG, collapse=""))

    NULL
}

setValidity2("IPos", .validate_IPos)

### TODO: Add validity methods for UnstitchedIPos and StitchedIPos objects.


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Very low-level UnstitchedIPos and StitchedIPos constructors
###
### For maximum efficiency, these constructors trust all the supplied
### arguments and do not validate the object.
###

.unsafe_new_UnstitchedIPos <- function(pos, names=NULL, mcols=NULL,
                                            metadata=list())
{
    new2("UnstitchedIPos", pos=pos,
                           NAMES=names,
                           elementMetadata=mcols,
                           metadata=metadata,
                           check=FALSE)
}

### Trusts all supplied arguments and does not validate the object.
.unsafe_new_StitchedIPos <- function(pos_runs, names=NULL, mcols=NULL,
                                               metadata=list())
{
    new2("StitchedIPos", pos_runs=pos_runs,
                         NAMES=names,
                         elementMetadata=mcols,
                         metadata=metadata,
                         check=FALSE)
}


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### updateObject()
###

### NOT exported but used in the GenomicRanges package.
get_IPos_version <- function(object)
{
    if (.hasSlot(object, "NAMES"))
        return("current")

    if (class(object) != "IPos")
        return(">= 2.19.4 and < 2.19.9")

    return("< 2.19.4")
}

.updateObject_IPos <- function(object, ..., verbose=FALSE)
{
    if (.hasSlot(object, "NAMES")) {
        ## 'object' was made with IRanges >= 2.19.9.
        if (verbose)
            message("[updateObject] ", class(object), " object is current.\n",
                    "[updateObject] Nothing to update.")
        return(callNextMethod())
    }

    if (verbose)
        message("[updateObject] ", class(object), " object ",
                "uses internal representation from\n",
                "[updateObject] IRanges ", get_IPos_version(object), ". ",
                "Updating it ... ", appendLF=FALSE)

    if (class(object) == "UnstitchedIPos") {
        ## 'object' is an UnstitchedIPos instance that was made with
        ## IRanges >= 2.19.4 and < 2.19.9.
        object <- .unsafe_new_UnstitchedIPos(object@pos,
                                             NULL,
                                             object@elementMetadata,
                                             object@metadata)
    } else {
        ## 'object' is either an IPos instance that was made with
        ## IRanges < 2.19.4 or a StitchedIPos instance that was made with
        ## IRanges >= 2.19.4 and < 2.19.9.
        object <- .unsafe_new_StitchedIPos(object@pos_runs,
                                           NULL,
                                           object@elementMetadata,
                                           object@metadata)
    }

    if (verbose)
        message("OK")

    callNextMethod()
}

setMethod("updateObject", "IPos", .updateObject_IPos)


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Accessors
###

setMethod("pos", "UnstitchedIPos", function(x) x@pos)
### This really should be the method for StitchedIPos objects but we define a
### method for IPos objects for backward compatibility with old IPos instances.
setMethod("pos", "IPos", function(x) unlist_as_integer(x@pos_runs))

setMethod("length", "UnstitchedIPos", function(x) length(x@pos))
### This really should be the method for StitchedIPos objects but we define a
### method for IPos objects for backward compatibility with old IPos instances.
setMethod("length", "IPos", function(x) sum(width(x@pos_runs)))

setMethod("names", "IPos", function(x) x@NAMES)

setReplaceMethod("names", "IPos",
    function(x, value)
    {
        x@NAMES <- S4Vectors:::normarg_names(value, "IPos", length(x))
        x
    }
)

### No `pos<-` setter at the moment for IPos objects! Should we have it?


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Collapse runs of "stitchable integer ranges"
###
### In an IntegerRanges object 'x', 2 ranges x[i] and x[i+1] are "stitchable"
### if start(x[i+1]) == end(x[i])+1. For example, in the following object:
###   1: .....xxxx.............
###   2: ...xx.................
###   3: .........xxx..........
###   4: ............xxxxxx....
###   5: ..................x...
### x[3] and x[4] are stitchable, and x[4] and x[5] are stitchable. So
### x[3], x[4], and x[5] form a run of "stitchable ranges" that will collapse
### into the following single range after stitching:
###      .........xxxxxxxxxx...
### Note that x[1] and x[3] are not stitchable because they are not
### consecutive vector elements (but they would if we removed x[2]).

### stitch_IntegerRanges() below takes any IntegerRanges derivative and
### returns an IRanges object (so is NOT an endomorphism). Note that this
### transformation preserves 'sum(width(x))'.
### Also note that this is an "inter range transformation". However unlike
### range(), reduce(), gaps(), or disjoin(), its result depends on the order
### of the elements in the input vector. It's also idempotent like range(),
### reduce(), and disjoin() (gaps() is not).

### TODO: Define and export stitch() generic and method for IntegerRanges
### objects (in inter-range-methods.R).
### Maybe it would also make sense to have an isStitched() generic like we
### have isDisjoint() to provide a quick and easy way to check the state of
### the object before applying the transformation to it. In theory each
### idempotent inter range transformation could have a "state checker" so
### maybe add isReduced() too (range() probably doesn't need one).

stitch_IntegerRanges <- function(x)
{
    if (length(x) == 0L)
        return(IRanges())
    x_start <- start(x)
    x_end <- end(x)

    ## Find runs of stitchable elements along 'x'.
    ## Each run is described by the indices of its first ('run_from') and
    ## last ('run_to') elements in 'x'.
    ## The runs form a partitioning of 'x'.
    new_run_idx <- which(x_start[-1L] != x_end[-length(x)] + 1L)
    run_from <- c(1L, new_run_idx + 1L)
    run_to <- c(new_run_idx, length(x))

    IRanges(x_start[run_from], x_end[run_to])
}


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Constructor
###

### 'pos' must be an integer vector with no NAs.
.make_StitchedIPos_from_pos <- function(pos, names=NULL, mcols=NULL,
                                             metadata=list())
{
    pos_runs <- as(pos, "IRanges")
    .unsafe_new_StitchedIPos(pos_runs, names, mcols, metadata)
}

.from_UnstitchedIPos_to_StitchedIPos <- function(from)
{
    .make_StitchedIPos_from_pos(from@pos, from@NAMES,
                                          from@elementMetadata,
                                          from@metadata)
}

### 'pos_runs' must be an IRanges object.
.make_UnstitchedIPos_from_pos_runs <- function(pos_runs, names=NULL, mcols=NULL,
                                                         metadata=list())
{
    pos <- unlist_as_integer(pos_runs)
    .unsafe_new_UnstitchedIPos(pos, names, mcols, metadata)
}

.from_StitchedIPos_to_UnstitchedIPos <- function(from)
{
    .make_UnstitchedIPos_from_pos_runs(from@pos_runs, from@NAMES,
                                                      from@elementMetadata,
                                                      from@metadata)
}

### 'pos' must be an integer vector with no NAs or an IntegerRanges derivative.
### This is NOT checked!
new_UnstitchedIPos <- function(pos=integer(0))
{
    if (is(pos, "UnstitchedIPos"))
        return(pos)
    if (is(pos, "StitchedIPos"))
        return(.from_StitchedIPos_to_UnstitchedIPos(pos))
    if (is.integer(pos)) {
        ## Treat 'pos' as a vector of single positions.
        names <- names(pos)
        if (!is.null(names))
            names(pos) <- NULL
        return(.unsafe_new_UnstitchedIPos(pos, names))
    }
    ## 'pos' is an IntegerRanges derivative. Treat its ranges as runs of
    ## consecutive positions.
    ans_len <- sum(width(pos))  # no more integer overflow in R >= 3.5
    if (ans_len > .Machine$integer.max)
        stop("too many positions in 'pos'")
    .make_UnstitchedIPos_from_pos_runs(pos)
}

### 'pos' must be an integer vector with no NAs or an IntegerRanges derivative.
### This is NOT checked!
new_StitchedIPos <- function(pos=integer(0))
{
    if (is(pos, "StitchedIPos"))
        return(pos)
    if (is(pos, "UnstitchedIPos"))
        return(.from_UnstitchedIPos_to_StitchedIPos(pos))
    if (is.integer(pos)) {
        ## Treat 'pos' as a vector of single positions.
        names <- names(pos)
        if (!is.null(names))
            names(pos) <- NULL
        return(.make_StitchedIPos_from_pos(pos, names))
    }
    ## 'pos' is an IntegerRanges derivative. Treat its ranges as runs of
    ## consecutive positions.
    ans_len <- sum(width(pos))  # no more integer overflow in R >= 3.5
    if (ans_len > .Machine$integer.max)
        stop("too many positions in 'pos'")
    pos_runs <- stitch_IntegerRanges(pos)
    pos_runs <- pos_runs[width(pos_runs) != 0L]
    .unsafe_new_StitchedIPos(pos_runs)
}

### Returns an integer vector with no NAs or an IntegerRanges derivative.
.normarg_pos <- function(pos)
{
    if (is(pos, "IntegerRanges"))
        return(pos)
    if (is.numeric(pos)) {
        if (!is.integer(pos))
            storage.mode(pos) <- "integer"  # preserve the names
        if (anyNA(pos))
            stop("'pos' cannot contain NAs")
        return(pos)
    }
    ans <- try(as(pos, "IRanges"), silent=TRUE)
    if (inherits(ans, "try-error"))
        stop("'pos' must represent positions")
    ans
}

.normarg_stitch <- function(stitch, pos)
{
    if (!(is.logical(stitch) && length(stitch) == 1L))
        stop("'stitch' must be TRUE, FALSE, or NA")
    if (!is.na(stitch))
        return(stitch)
    is(pos, "IntegerRanges") && !is(pos, "UnstitchedIPos")
}

### If the input object 'pos' is itself an IPos object, its metadata columns
### are propagated.
IPos <- function(pos=integer(0), names=NULL, ..., stitch=NA)
{
    mcols <- DataFrame(..., check.names=FALSE)

    pos <- .normarg_pos(pos)
    stitch <- .normarg_stitch(stitch, pos)
    if (stitch) {
        ans <- new_StitchedIPos(pos)
    } else {
        ans <- new_UnstitchedIPos(pos)
    }

    if (!is.null(names))
        names(ans) <- names
    if (length(mcols) != 0L)
        mcols(ans) <- mcols
    ans
}


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Coercion
###

setAs("UnstitchedIPos", "StitchedIPos", .from_UnstitchedIPos_to_StitchedIPos)

setAs("StitchedIPos", "UnstitchedIPos", .from_StitchedIPos_to_UnstitchedIPos)

.check_IntegerRanges_for_coercion_to_IPos <- function(from, to)
{
    if (!all(width(from) == 1L))
        stop(wmsg("all the ranges in the ", class(from), " object to ",
                  "coerce to ", to, " must have a width of 1"))
}
.from_IntegerRanges_to_UnstitchedIPos <- function(from)
{
    .check_IntegerRanges_for_coercion_to_IPos(from, "UnstitchedIPos")
    ans <- new_UnstitchedIPos(from)
    names(ans) <- names(from)
    mcols(ans) <- mcols(from, use.names=FALSE)
    metadata(ans) <- metadata(from)
    ans
}
.from_IntegerRanges_to_StitchedIPos <- function(from)
{
    .check_IntegerRanges_for_coercion_to_IPos(from, "StitchedIPos")
    ans <- new_StitchedIPos(from)
    names(ans) <- names(from)
    mcols(ans) <- mcols(from, use.names=FALSE)
    metadata(ans) <- metadata(from)
    ans
}
setAs("IntegerRanges", "UnstitchedIPos", .from_IntegerRanges_to_UnstitchedIPos)
setAs("IntegerRanges", "StitchedIPos", .from_IntegerRanges_to_StitchedIPos)
setAs("IntegerRanges", "IPos", .from_IntegerRanges_to_UnstitchedIPos)

setAs("ANY", "UnstitchedIPos", function(from) IPos(from, stitch=FALSE))
setAs("ANY", "StitchedIPos", function(from) IPos(from, stitch=TRUE))
setAs("ANY", "IPos", function(from) IPos(from))

### S3/S4 combo for as.data.frame.IPos
### The "as.data.frame" method for IntegerRanges objects works on an IPos
### object but returns a data.frame with identical "start" and "end" columns,
### and a "width" column filled with 1. We overwrite it to return a data.frame
### with a "pos" column instead of the "start" and "end" columns, and no
### "width" column.
.as.data.frame.IPos <- function(x, row.names=NULL, optional=FALSE)
{
    if (!identical(optional, FALSE))
        warning(wmsg("'optional' argument was ignored"))
    ans <- data.frame(pos=pos(x), row.names=row.names, stringsAsFactors=FALSE)
    x_mcols <- mcols(x, use.names=FALSE)  # can be NULL!
    if (!is.null(x_mcols))
        ans <- cbind(ans, as.data.frame(x_mcols, optional=TRUE))
    ans
}
as.data.frame.IPos <- function(x, row.names=NULL, optional=FALSE, ...)
    .as.data.frame.IPos(x, row.names=NULL, optional=FALSE, ...)
setMethod("as.data.frame", "IPos", .as.data.frame.IPos)


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Subsetting
###

### NOT exported but used in the GenomicRanges package.
### 'pos_runs' must be an IRanges or GRanges object or any range-based
### object as long as it supports start(), end(), width(), and is subsettable.
### 'i' must be an IntegerRanges object with no zero-width ranges.
extract_pos_runs_by_ranges <- function(pos_runs, i)
{
    map <- S4Vectors:::map_ranges_to_runs(width(pos_runs),
                                          start(i), width(i))
    ## Because 'i' has no zero-width ranges, 'mapped_range_span' cannot
    ## contain zeroes and so 'mapped_range_Ltrim' and 'mapped_range_Rtrim'
    ## cannot contain garbbage.
    mapped_range_offset <- map[[1L]]
    mapped_range_span <- map[[2L]]
    mapped_range_Ltrim <- map[[3L]]
    mapped_range_Rtrim <- map[[4L]]
    run_idx <- sequence(mapped_range_span, from=mapped_range_offset+1L)
    pos_runs <- pos_runs[run_idx]
    if (length(run_idx) != 0L) {
        Rtrim_idx <- cumsum(mapped_range_span)
        Ltrim_idx <- c(1L, Rtrim_idx[-length(Rtrim_idx)] + 1L)
        trimmed_start <- start(pos_runs)[Ltrim_idx] +
                         mapped_range_Ltrim
        trimmed_end <- end(pos_runs)[Rtrim_idx] - mapped_range_Rtrim
        start(pos_runs)[Ltrim_idx] <- trimmed_start
        end(pos_runs)[Rtrim_idx] <- trimmed_end
        new_len <- sum(width(pos_runs))  # no more integer overflow in R >= 3.5
        if (new_len > .Machine$integer.max)
            stop("subscript is too big")
    }
    pos_runs
}

### This really should be the method for StitchedIPos objects but we define a
### method for IPos objects for backward compatibility with old IPos instances.
setMethod("extractROWS", "IPos",
    function(x, i)
    {
        ans <- callNextMethod()
        if (is(x, "UnstitchedIPos"))
            return(ans)
        i <- normalizeSingleBracketSubscript(i, x, as.NSBS=TRUE)
        ## TODO: Maybe make this the coercion method from NSBS to
        ## IntegerRanges.
        if (is(i, "RangesNSBS")) {
            ir <- i@subscript
            ir <- ir[width(ir) != 0L]
        } else {
            ir <- as(as.integer(i), "IRanges")
        }
        new_pos_runs <- extract_pos_runs_by_ranges(x@pos_runs, ir)
        new_pos_runs <- stitch_IntegerRanges(new_pos_runs)
        BiocGenerics:::replaceSlots(ans, pos_runs=new_pos_runs, check=FALSE)
    }
)


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Show
###

.IPos_summary <- function(object)
{
    object_class <- classNameForDisplay(object)
    object_len <- length(object)
    object_mcols <- mcols(object, use.names=FALSE)
    object_nmc <- if (is.null(object_mcols)) 0L else ncol(object_mcols)
    paste0(object_class, " object with ", object_len, " ",
           ifelse(object_len == 1L, "position", "positions"),
           " and ", object_nmc, " metadata ",
           ifelse(object_nmc == 1L, "column", "columns"))
}

### S3/S4 combo for summary.IPos
summary.IPos <- function(object, ...) .IPos_summary(object, ...)
setMethod("summary", "IPos", summary.IPos)

.from_IPos_to_naked_character_matrix_for_display <- function(x)
{
    m <- cbind(pos=showAsCell(pos(x)))
    cbind_mcols_for_display(m, x)
}
setMethod("makeNakedCharacterMatrixForDisplay", "IPos",
    .from_IPos_to_naked_character_matrix_for_display
)

show_IPos <- function(x, margin="", print.classinfo=FALSE)
{
    version <- get_IPos_version(x)
    if (version != "current")
        stop(c(wmsg("This ", class(x), " object uses internal representation ",
                    "from IRanges ", version, ", and so needs to be updated ",
                    "before it can be displayed or used. ",
                    "Please update it with:"),
               "\n\n    object <- updateObject(object, verbose=TRUE)",
               "\n\n  and re-serialize it."))
    cat(margin, summary(x), ":\n", sep="")
    ## makePrettyMatrixForCompactPrinting() assumes that head() and tail()
    ## work on 'xx'.
    xx <- as(x, "IPos")
    out <- makePrettyMatrixForCompactPrinting(xx)
    if (print.classinfo) {
        .COL2CLASS <- c(pos="integer")
        classinfo <- makeClassinfoRowForCompactPrinting(x, .COL2CLASS)
        ## A sanity check, but this should never happen!
        stopifnot(identical(colnames(classinfo), colnames(out)))
        out <- rbind(classinfo, out)
    }
    if (nrow(out) != 0L)
        rownames(out) <- paste0(margin, "  ", rownames(out))
    ## We set 'max' to 'length(out)' to avoid the getOption("max.print")
    ## limit that would typically be reached when 'showHeadLines' global
    ## option is set to Inf.
    print(out, quote=FALSE, right=TRUE, max=length(out))
}

setMethod("show", "IPos",
    function(object) show_IPos(object, print.classinfo=TRUE)
)


### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Concatenation
###

.concatenate_StitchedIPos_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 <- sum(lengths(all_objects))  # no more integer overflow
                                          # in R >= 3.5
    if (ans_len > .Machine$integer.max)
        stop("too many integer positions 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 IPos) 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

    ## Concatenate the "pos_runs" slots.
    pos_runs_list <- lapply(all_objects, slot, "pos_runs")
    ans_pos_runs <- stitch_IntegerRanges(
        bindROWS(pos_runs_list[[1L]], pos_runs_list[-1L])
    )

    BiocGenerics:::replaceSlots(ans, pos_runs=ans_pos_runs,
                                     check=check)
}

### This really should be the method for StitchedIPos objects but we define a
### method for IPos objects for backward compatibility with old IPos instances.
setMethod("bindROWS", "IPos",
    function(x, objects=list(), use.names=TRUE, ignore.mcols=FALSE, check=TRUE)
    {
        if (is(x, "UnstitchedIPos"))
            return(callNextMethod())
        x <- updateObject(x, check=FALSE)
        .concatenate_StitchedIPos_objects(x, objects, use.names, ignore.mcols,
                                          check)
    }
)