### This method does NOT preserve normality.
## WARNING: -end(x) *must* appear first in this expression if we want
## the supplied 'start' and 'end' to be recycled properly.
## Remember that in R, because of the recycling, addition of numeric
## vectors of different lengths is not associative i.e. in general
## '(x + y) + z' is not the same as 'x + (y + z)'. For example:
## callNextMethod() temporarily breaks 'x' as a NormalIRanges object
## because the returned ranges are ordered from right to left.

n2p <- match(c("start", "end", "use.names"), argnames)
x@ranges <- reverse(ranges(x), start=1L, end=length(subject(x)))

"run values and run lengths must have the same length"
#if (length(run_lengths) >= 2 && is.atomic(run_values)
#      && any(run_values[-1L] == run_values[-length(run_values)]))
#    msg <- c(msg, "consecutive runs must have different values")
"cannot coerce a non-logical 'Rle' or a logical 'Rle' "
"longer object length is not a multiple of shorter object length"
# ends <- sort(unique(c(end(e1), end(e2))))
"integer overflow - use sum(as.numeric(.))"
## From here, 'value' is guaranteed to be of length 1.
## Use a stripped down loop with empty Rle object
"all 'x' values must be in [1, 'length(vec)']"
"all 'SHIFT' values must be non-negative"
## Currently only 1 Rle is supported. An approach for multiple
## Rle's could be disjoin(), findRun() to find matches, then
## Adjust 'dn' for consistency with base::table
"no \"duplicated\" method for Rle objects yet, sorry"
## base::ifelse works fine for S4 'test', but not for S4 yes/no
"'lag' and 'differences' must be integers >= 1"
# Direct change to slots for fast computation
"only 'pearson' method is supported for Rle objects"
### FIXME: code duplication needed for S3 / S4 dispatch
### drop NA's here, so dropRle==TRUE allows x[FALSE][NA] in median.default
"NA/NaN/Inf not supported in runmed,Rle-method"
"levels can only be dropped when runValue(x) is a factor"

prototype = prototype(values = logical()),
msg <- c(msg, "run values and run lengths must have the same length")
msg <- c(msg, "all run lengths must be positive")
setGeneric("nrun", signature = "x", function(x) standardGeneric("nrun"))
setMethod("start", "Rle", function(x) .Call2("Rle_start", x, PACKAGE="IRanges"))
setMethod("end", "Rle", function(x) .Call2("Rle_end", x, PACKAGE="IRanges"))
setMethod("ranges", "Rle", function(x) IRanges(start(x), width = width(x)))
function(x, value) Rle(values = runValue(x), lengths = value))
function(x, value) Rle(values = value, lengths = runLength(x)))
setGeneric("Rle", signature = c("values", "lengths"),
setMethod("Rle", signature = c(values = "missing", lengths = "missing"),
new2("Rle", values = vector(), lengths = integer(), check=FALSE))
setMethod("Rle", signature = c(values = "vectorORfactor", lengths = "missing"),
function(values, lengths) Rle(values, integer(0), check = FALSE))
setMethod("Rle", signature = c(values = "vectorORfactor", lengths = "integer"),
setMethod("Rle", signature = c(values = "vectorORfactor", lengths = "numeric"),
Rle(values = values, lengths = as.integer(lengths),
setMethod("Rle", signature = c(values = "Rle", lengths = "missing"),
function(values, lengths, check = TRUE) values)
stop("cannot coerce a non-logical 'Rle' or a logical 'Rle' ",
setMethod("as.vector", "Rle", function(x, mode) rep.int(as.vector(runValue(x), mode), runLength(x)))
setMethod("as.logical", "Rle", function(x) rep.int(as.logical(runValue(x)), runLength(x)))
setMethod("as.integer", "Rle", function(x) rep.int(as.integer(runValue(x)), runLength(x)))
setMethod("as.numeric", "Rle", function(x) rep.int(as.numeric(runValue(x)), runLength(x)))
setMethod("as.complex", "Rle", function(x) rep.int(as.complex(runValue(x)), runLength(x)))
setMethod("as.character", "Rle", function(x) rep.int(as.character(runValue(x)), runLength(x)))
setMethod("as.raw", "Rle", function(x) rep.int(as.raw(runValue(x)), runLength(x)))
setMethod("as.factor", "Rle", function(x) rep.int(as.factor(runValue(x)), runLength(x)))
as.list.Rle <- function(x, ...) .as.list.Rle(x, ...)
decodeRle <- function(x) rep.int(runValue(x), runLength(x))
as.data.frame.Rle <- function(x, row.names=NULL, optional=FALSE, ...)
getStartEndRunAndOffset <- function(x, start, end) {
.Call2("Rle_getStartEndRunAndOffset", x, start, end, PACKAGE="IRanges")
.sumprodRle <- function(e1, e2, na.rm = FALSE)
warning("longer object length is not a multiple of shorter object length")
values <- runValue(e1)[which1] * runValue(e2)[which2]
setMethod("Ops", signature(e1 = "Rle", e2 = "Rle"),
lengths = diffWithInitialZero(ends), check = FALSE)
setMethod("Ops", signature(e1 = "Rle", e2 = "vector"),
setMethod("Ops", signature(e1 = "vector", e2 = "Rle"),
lengths[startZero - c(0L, cumsum(head(widthZero, -1) - 1L))] <- widthZero
Rle(values = values, lengths = lengths, check = FALSE)
lengths[startOne - c(0L, cumsum(head(widthOne, -1) - 1L))] <- widthOne
lengths = runLength(x), check = FALSE)))
Rle(values = callGeneric(runValue(x), digits = digits),
sum(runValue(x) * runLength(x), ..., na.rm=na.rm)
exp <- gettext("integer overflow - use sum(as.numeric(.))",
prod = prod(runValue(x) ^ runLength(x), ..., na.rm=na.rm))
Rle(values = callGeneric(runValue(z)), lengths = runLength(z),
ansList <- .Call2("Rle_seqselect", x, start(i), width(i),
function(x, i, j, ..., drop=getOption("dropRle", default=FALSE))
if (anyMissingOrOutside(start(ir), 1L, length(x)) ||
info <- getStartEndRunAndOffset(x, start, end)
if ((length(ir) > 0L) && (end(ir[length(ir)]) != length(x))) {
subseqs <- vector("list", length(valueWidths) + k)
values <- unlist(lapply(subseqs, "[[", "values"))
Rle(values = runValue(x) %in% table, lengths = runLength(x),
aggregate.Rle <- function(x, by, FUN, start=NULL, end=NULL, width=NULL,
args <- RleList(unname(list(x, ...)), compress = FALSE)
Rle(values  = unlist(lapply(args, slot, "values")),
lengths = unlist(lapply(args, slot, "lengths")))
setMethod("findRange", signature = c(vec = "Rle"),
stop("all 'x' values must be in [1, 'length(vec)']")
IRanges(start = start(vec)[run], width = width(vec)[run],
setMethod("findRun", signature = c(vec = "Rle"),
Rle(values = is.na(runValue(x)), lengths = runLength(x),
function(x, na.rm = FALSE, strictly = FALSE)
ans <- is.unsorted(runValue(x), na.rm = na.rm, strictly = strictly)
function(x, table, nomatch = NA_integer_, incomparables = NULL)
match(runValue(x), table = table, nomatch = nomatch,
setGeneric("orderAsRanges", signature = c("x"),  # not exported
function(x, na.last = TRUE, decreasing = FALSE)
ord <- orderInteger(runValue(x), na.last = na.last,
new2("IRanges", start = start(x)[ord], width = runLength(x)[ord],
if (!missing(each) && length(each) > 0) {
x <- new(class(x), values = runValue(x)[0L])
if (!missing(length.out) && length(length.out) > 0) {
if ((length(times) > 1 && length(times) < n) ||
x <- Rle(values  = rep.int(runValue(x), times),
setMethod("shiftApply", signature(X = "Rle", Y = "Rle"),
function(SHIFT, X, Y, FUN, ..., OFFSET = 0L, simplify = TRUE,
stop("'X' and 'Y' must be of equal length")
if (length(SHIFT) == 0 || anyMissingOrOutside(SHIFT, 0L))
stop("all 'SHIFT' values must be non-negative")
if (length(OFFSET) == 0 || anyMissingOrOutside(OFFSET, 0L))
getStartEndRunAndOffset(X, rep.int(1L + OFFSET, length(SHIFT)),
function(x) {if (is(x, "Rle")) decodeRle(x) else x})
.sort.Rle <- function(x, decreasing=FALSE, na.last=NA, ...)
sort.Rle <- function(x, decreasing=FALSE, ...)
split(IRanges(start = start(x), width = runLength(x)),
summary.Rle <- function(object, ..., digits=max(3, getOption("digits") - 3))
if (!is.null(n <- dimnames(tb)[[1L]]) && any(iN <- is.na(n)))
qq <- signif(c(qq[1L:3L], mean(object), qq[4L:5L]), digits)
c("Min.", "1st Qu.", "Median", "Mean", "3rd Qu.", "Max.")
tab[dn %in% runValue(x)] <- runLength(x)
dep <- vapply(l[fixup], function(x) switch(deparse.level +
1, "", if (is.symbol(x)) as.character(x) else "",
.duplicated.Rle <- function(x, incomparables=FALSE, fromLast=FALSE)
stop("no \"duplicated\" method for Rle objects yet, sorry")
duplicated.Rle <- function(x, incomparables=FALSE, ...)
unique.Rle <- function(x, incomparables=FALSE, ...)
window.Rle <- function(x, start=NA, end=NA, width=NA,
solved_SEW <- solveUserSEWForSingleSeq(length(x), start, end, width)
info <- getStartEndRunAndOffset(x, start(solved_SEW), end(solved_SEW))
x, runStart, runEnd, offsetStart, offsetEnd,
list(levels = levels(x), class = "factor")
Rle(values = !runValue(x), lengths = runLength(x), check = FALSE))
stop("argument to 'which' is not logical")
setMethod("ifelse", c(yes = "Rle"), function(test, yes, no)
setMethod("ifelse", c(no = "Rle"), function(test, yes, no)
setMethod("ifelse", c(yes = "Rle", no = "Rle"), function(test, yes, no)
.diff.Rle <- function(x, lag = 1, differences = 1)
!isSingleNumber(differences) || differences < 1L)
stop("'lag' and 'differences' must be integers >= 1")
x <- window(x, 1L + lag, n) - window(x, 1L, n - lag)
diff.Rle <- function(x, ...) .diff.Rle(x, ...)
.psummary.Rle <- function(FUN, ..., MoreArgs = NULL) {
setMethod("pmax", "Rle", function(..., na.rm = FALSE)
.psummary.Rle(pmax, ..., MoreArgs = list(na.rm = na.rm)))
setMethod("pmin", "Rle", function(..., na.rm = FALSE)
.psummary.Rle(pmin, ..., MoreArgs = list(na.rm = na.rm)))
setMethod("pmax.int", "Rle", function(..., na.rm = FALSE)
.psummary.Rle(pmax.int, ..., MoreArgs = list(na.rm = na.rm)))
setMethod("pmin.int", "Rle", function(..., na.rm = FALSE)
.psummary.Rle(pmin.int, ..., MoreArgs = list(na.rm = na.rm)))
n <- length(x) - sum(runLength(x)[is.na(runValue(x))])
mean.Rle <- function(x, ...) .mean.Rle(x, ...)
setMethod("var", signature = c(x = "Rle", y = "missing"),
function(x, y = NULL, na.rm = FALSE, use)
centeredValues <- runValue(x) - mean(x, na.rm = na.rm)
sum(runLength(x) * centeredValues * centeredValues,
setMethod("var", signature = c(x = "Rle", y = "Rle"),
x@values <- runValue(x) - mean(x, na.rm = na.rm)
y@values <- runValue(y) - mean(y, na.rm = na.rm)
n <- length(z) - sum(runLength(z)[is.na(runValue(z))])
setMethod("cov", signature = c(x = "Rle", y = "Rle"),
function(x, y = NULL, use = "everything",
method = c("pearson", "kendall", "spearman"))
stop("only 'pearson' method is supported for Rle objects")
use %in% c("complete.obs", "pairwise.complete.obs", "na.or.complete")
if (use == "all.obs" && (anyMissing(x) || anyMissing(y)))
setMethod("cor", signature = c(x = "Rle", y = "Rle"),
(sqrt(sum(runLength(x) * runValue(x) * runValue(x),
sqrt(sum(runLength(y) * runValue(y) * runValue(y),
setMethod("sd", signature = c(x = "Rle"),
function(x, na.rm = FALSE) sqrt(var(x, na.rm = na.rm)))
median.Rle <- function(x, na.rm = FALSE)
function(x, probs = seq(0, 1, 0.25), na.rm = FALSE, names = TRUE,
function(x, center = median(x), constant = 1.4826, na.rm = FALSE,
diff(quantile(x, c(0.25, 0.75), na.rm = na.rm, names = FALSE)))
setMethod("smoothEnds", "Rle", function(y, k = 3)
function(x, k, endrule = c("median", "keep", "drop", "constant"),
stop("NA/NaN/Inf not supported in runmed,Rle-method")
k <- normargRunK(k = k, n = n, endrule = endrule)
runLength(ans)[1L] <- runLength(ans)[1L] + (i - 1L)
ans <- c(head(x, i - 1L), ans, tail(x, i - 1L))
ans <- .Call2("Rle_runsum", x, as.integer(k), as.logical(na.rm),
runLength(ans)[1L] <- runLength(ans)[1L] + (j - 1L)
function(x, type = "chars", allowNA = FALSE)
Rle(values = nchar(runValue(x), type = type, allowNA = allowNA),
levels(x) <- substr(levels(x), start = start, stop = stop)
runValue(x) <- substr(runValue(x), start = start, stop = stop)
substring(levels(text), first = first, last = last)
substring(runValue(text), first = first, last = last)
setMethod("chartr", c(old = "ANY", new = "ANY", x = "Rle"),
levels(x) <- chartr(old = old, new = new, levels(x))
runValue(x) <- chartr(old = old, new = new, runValue(x))
setMethod("sub", signature = c(pattern = "ANY", replacement = "ANY", x = "Rle"),
function(pattern, replacement, x, ignore.case = FALSE,
perl = FALSE, fixed = FALSE, useBytes = FALSE)
sub(pattern = pattern, replacement = replacement,
x = levels(x), ignore.case = ignore.case,
perl = perl, fixed = fixed, useBytes = useBytes)
x = runValue(x), ignore.case = ignore.case,
setMethod("gsub", signature = c(pattern = "ANY", replacement = "ANY", x = "Rle"),
gsub(pattern = pattern, replacement = replacement,
.pasteTwoRles <- function(e1, e2, sep = " ", collapse = NULL)
expand.grid(levels(e2), levels(e1), KEEP.OUT.ATTRS = FALSE,
structure((as.integer(runValue(e1)[which1]) - 1L) * nlevels(e2) +
paste(levelsTable[[2L]], levelsTable[[1L]], sep = sep),
paste(runValue(e1)[which1], runValue(e2)[which2], sep = sep,
Rle(values = values, lengths = diffWithInitialZero(ends), check = FALSE)
function(..., sep = " ", collapse = NULL)
rleList <- RleList(..., compress = FALSE)
.pasteTwoRles(ans, rleList[[i]], sep = sep,
Rle(values = runValue(x), lengths = runLength(x),
stop("levels can only be dropped when runValue(x) is a factor")
ifelse(nr == 1, " run\n", " runs\n"), sep = "")
showMatrix <- format(showMatrix, justify = "right")