BiomedEngX/CircosHeatmap-aardio
2
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases 3 Wiki Activity
CircosHeatmap-aardio/dist/lib/r-library/S4Vectors/unitTests/test_Rle-utils.R

605 lines
24 KiB
R
Raw Normal View History

首次上传
2025-01-12 00:52:51 +08:00
library(IRanges) # many tests in this file use functionalities defined
# in IRanges
test_Rle_groupGeneric <- function() {
set.seed(0)
x <- sample(0:3, 50, replace = TRUE)
xRle <- Rle(x)
checkIdentical(numeric(0) + 1, as.vector(Rle(numeric(0)) + 1))
checkIdentical(x + 1, as.vector(xRle + 1))
checkIdentical(2 * x + 3, as.vector(2 * xRle + 3))
checkIdentical(x[(x > 0) & (x < 3)], as.vector(xRle[(xRle > 0) & (xRle < 3)]))
checkIdentical(log(x), as.vector(log(xRle)))
checkIdentical(range(x), range(xRle))
checkIdentical(sum(x), sum(xRle))
checkIdentical(prod(x), prod(xRle))
checkIdentical(cumsum(x), as.vector(cumsum(xRle)))
checkIdentical(cumprod(x), as.vector(cumprod(xRle)))
checkIdentical(round(x + .25), as.vector(round(xRle + .25)))
checkIdentical(signif(x + .25), as.vector(signif(xRle + .25)))
checkIdentical(Im(x + 5i), as.vector(Im(xRle + 5i)))
}
test_Rle_general <- function() {
x <- rep(6:10, 1:5)
xRle <- Rle(x)
checkIdentical(aggregate(xRle, IRanges(start = 3:6, end = 13:10), FUN = mean),
aggregate(xRle, FUN = mean, start = 3:6, width = seq(11, 5, by = -2)))
exp <- c(mean(x[3:13]), mean(x[4:12]), mean(x[5:11]), mean(x[6:10]))
agg <- aggregate(xRle, FUN = function(x) x, start = 3:6, end = 13:10)
checkEquals(exp, aggregate(xRle, FUN = mean, start = 3:6, end = 13:10))
checkEquals(as.vector(aggregate.ts(ts(x, frequency = 5), FUN = mean)),
aggregate(xRle, FUN = mean, start = c(1, 6, 11), end = c(5, 10, 15)))
#checkIdentical(findRange(c(1, 3, 5), xRle), IRanges(start = c(1,2,4), width = 1:3))
#checkIdentical(head(x, 8), as.vector(head(xRle, 8)))
#checkIdentical(head(x, -3), as.vector(head(xRle, -3)))
#checkException(split(Rle(1:26), integer()), silent = TRUE)
#checkException(split(Rle(1:26), Rle()), silent = TRUE)
#checkIdentical(lapply(as.list(split(Rle(1:26), letters)), as.vector),
# split(1:26, letters))
#checkIdentical(lapply(as.list(split(Rle(1:26), Rle(letters))), as.vector),
# split(1:26, letters))
#checkIdentical(lapply(as.list(split(Rle(1:26), letters[1:2])), as.vector),
# split(1:26, letters[1:2]))
#checkIdentical(lapply(as.list(split(Rle(1:26), Rle(letters[1:2]))), as.vector),
# split(1:26, letters[1:2]))
#checkIdentical(lapply(as.list(split(Rle(integer()), letters)), as.vector),
# split(integer(), letters))
#checkIdentical(lapply(as.list(split(Rle(integer()), Rle(letters))), as.vector),
# split(integer(), letters))
#checkIdentical(splitRanges(Rle(letters, 1:26)),
# split(IRanges(end = cumsum(1:26), width = 1:26), letters))
checkIdentical(summary(x), summary(xRle))
#checkIdentical(tail(x, 8), as.vector(tail(xRle, 8)))
#checkIdentical(tail(x, -3), as.vector(tail(xRle, -3)))
#checkException(tapply(xRle), silent = TRUE)
#checkIdentical(tapply(x, x), tapply(xRle, xRle))
#checkIdentical(tapply(x, x, mean), tapply(xRle, xRle, mean))
#checkIdentical(tapply(xRle, x, mean), tapply(xRle, xRle, mean))
#checkIdentical(tapply(x, x, mean, simplify = FALSE),
# tapply(xRle, xRle, mean, simplify = FALSE))
#checkIdentical(tapply(xRle, x, mean, simplify = FALSE),
# tapply(xRle, xRle, mean, simplify = FALSE))
}
test_Rle_logical <- function() {
checkIdentical(logical(), as.vector(Rle(logical())))
x <- c(TRUE,TRUE,FALSE,FALSE,TRUE,FALSE,TRUE,TRUE,TRUE)
xRle <- Rle(x)
checkIdentical(!x, as.vector(!x))
checkIdentical(which(x), as.vector(which(x)))
checkIdentical(as(xRle, "IRanges"),
IRanges(start = c(1,5,7), width = c(2, 1, 3)))
}
test_Rle_numerical <- function() {
checkIdentical(numeric(), as.vector(Rle(numeric())))
x <- cumsum(cumsum(1:10))
xRle <- Rle(x)
checkIdentical(pmax(x, rev(x)), as.vector(pmax(xRle, rev(xRle))))
checkIdentical(pmin(x, rev(x)), as.vector(pmin(xRle, rev(xRle))))
checkIdentical(pmax.int(x, rev(x)), as.vector(pmax.int(xRle, rev(xRle))))
checkIdentical(pmin.int(x, rev(x)), as.vector(pmin.int(xRle, rev(xRle))))
checkIdentical(diff(x), as.vector(diff(xRle)))
checkIdentical(diff(x, lag = 2), as.vector(diff(xRle, lag = 2)))
checkIdentical(diff(x, differences = 2), as.vector(diff(xRle, differences = 2)))
checkIdentical(diff(x, lag = 2, differences = 2),
as.vector(diff(xRle, lag = 2, differences = 2)))
x <- rep(c(1.2, 3.4, NA, 7.8, 9.0), 1:5)
y <- x - rev(x)
xRle <- Rle(x)
yRle <- Rle(y)
checkIdentical(mean(x), mean(xRle))
checkIdentical(mean(x, na.rm = TRUE), mean(xRle, na.rm = TRUE))
checkIdentical(var(x), var(xRle))
checkEqualsNumeric(var(x, na.rm = TRUE), var(xRle, na.rm = TRUE))
checkIdentical(var(x, y), var(xRle, yRle))
checkEqualsNumeric(var(x, y, na.rm = TRUE), var(xRle, yRle, na.rm = TRUE))
checkIdentical(cov(x, y), cov(xRle, yRle))
checkEqualsNumeric(cov(x, y, use = "complete"), cov(xRle, yRle, use = "complete"))
checkIdentical(cor(x, y), cor(xRle, yRle))
checkEqualsNumeric(cor(x, y, use = "complete"), cor(xRle, yRle, use = "complete"))
checkIdentical(sd(x), sd(xRle))
checkEqualsNumeric(sd(x, na.rm = TRUE), sd(xRle, na.rm = TRUE))
checkIdentical(8, median(Rle(8)))
checkIdentical(8L, median(Rle(8L)))
checkIdentical(median(x), median(xRle))
checkIdentical(median(x, na.rm = TRUE), median(xRle, na.rm = TRUE))
checkIdentical(quantile(x, na.rm = TRUE), quantile(xRle, na.rm = TRUE))
checkIdentical(mad(x), mad(xRle))
checkIdentical(mad(x, na.rm = TRUE), mad(xRle, na.rm = TRUE))
checkIdentical(IQR(x, na.rm = TRUE), IQR(xRle, na.rm = TRUE))
y <- (-20:20)^2
y[c(1,10,21,41)] <- c(100L, 30L, 400L, 470L)
checkEqualsNumeric(smoothEnds(y), as.vector(smoothEnds(Rle(y))))
checkEqualsNumeric(runmed(y, 7), as.vector(runmed(Rle(y), 7)))
checkEqualsNumeric(runmed(y, 11), as.vector(runmed(Rle(y), 11)))
checkEqualsNumeric(runmed(y, 7, "keep"),
as.vector(runmed(Rle(y), 7, "keep")))
checkEqualsNumeric(runmed(y, 11, "keep"),
as.vector(runmed(Rle(y), 11, "keep")))
checkEqualsNumeric(runmed(y, 7, "constant"),
as.vector(runmed(Rle(y), 7, "constant")))
checkEqualsNumeric(runmed(y, 11, "constant"),
as.vector(runmed(Rle(y), 11, "constant")))
x <- rep(c(1.2, 3.4, 5.6, 7.8, 9.0), 1:5)
y <- rep(1:5, c(4, 2, 5, 1, 3))
xRle <- Rle(x)
yRle <- Rle(y)
checkEqualsNumeric(sapply(1:13, function(i) sum(window(x, i, i + 2))),
as.numeric(runsum(xRle, k = 3)))
# checkEqualsNumeric(sapply(1:13, function(i) sum(window(rev(x), i, i + 2))),
# as.numeric(runsum(rev(xRle), k = 3)))
checkEqualsNumeric(sapply(1:13, function(i) sum(window(y, i, i + 2))),
as.integer(runsum(yRle, k = 3)))
checkEqualsNumeric(sapply(1:13, function(i) sum(window(rev(y), i, i + 2))),
as.integer(runsum(rev(yRle), k = 3)))
checkEqualsNumeric(sapply(1:13, function(i) mean(window(x, i, i + 2))),
as.numeric(runmean(xRle, k = 3)))
checkEqualsNumeric(sapply(1:13, function(i) mean(window(rev(x), i, i + 2))),
as.numeric(runmean(rev(xRle), k = 3)))
checkEqualsNumeric(sapply(1:13, function(i) mean(window(y, i, i + 2))),
as.numeric(runmean(yRle, k = 3)))
checkEqualsNumeric(sapply(1:13, function(i) mean(window(rev(y), i, i + 2))),
as.numeric(runmean(rev(yRle), k = 3)))
checkEqualsNumeric(sapply(1:13, function(i) sum(window(x, i, i + 2))),
as.numeric(runwtsum(xRle, k = 3, wt = rep(1,3))))
checkEqualsNumeric(sapply(1:13, function(i) sum(window(x, i, i + 2)/3)),
as.numeric(runwtsum(xRle, k = 3, wt = rep(1/3,3))))
checkEqualsNumeric(sapply(1:13, function(i) sum(window(y, i, i + 2))),
as.numeric(runwtsum(yRle, k = 3, wt = rep(1,3))))
checkEqualsNumeric(sapply(1:13, function(i) sum(window(y, i, i + 2)/3)),
as.numeric(runwtsum(yRle, k = 3, wt = rep(1/3,3))))
checkEqualsNumeric(sapply(1:13, function(i) min(window(x, i, i + 2))),
as.numeric(runq(xRle, k = 3, i = 1)))
checkEqualsNumeric(sapply(1:13, function(i) median(window(x, i, i + 2))),
as.numeric(runq(xRle, k = 3, i = 2)))
checkEqualsNumeric(sapply(1:13, function(i) max(window(x, i, i + 2))),
as.numeric(runq(xRle, k = 3, i = 3)))
checkIdentical(runq(xRle, k = 3, i = 2),
rev(runq(rev(xRle), k = 3, i = 2)))
checkEqualsNumeric(sapply(1:13, function(i) min(window(y, i, i + 2))),
as.numeric(runq(yRle, k = 3, i = 1)))
checkEqualsNumeric(sapply(1:13, function(i) median(window(y, i, i + 2))),
as.numeric(runq(yRle, k = 3, i = 2)))
checkEqualsNumeric(sapply(1:13, function(i) max(window(y, i, i + 2))),
as.numeric(runq(yRle, k = 3, i = 3)))
checkIdentical(runq(yRle, k = 3, i = 2),
rev(runq(rev(yRle), k = 3, i = 2)))
}
test_Rle_character <- function() {
checkIdentical(character(), as.vector(Rle(character())))
txt <-
c("The", "licenses", "for", "most", "software", "are", "designed",
"to", "take", "away", "your", "freedom", "to", "share", "and",
"change", "it.", "", "By", "contrast,", "the", "GNU", "General",
"Public", "License", "is", "intended", "to", "guarantee", "your",
"freedom", "to", "share", "and", "change", "free", "software",
"--", "to", "make", "sure", "the", "software", "is", "free", "for",
"all", "its", "users")
txt <- rep(txt, seq_len(length(txt)))
txtRle <- Rle(txt)
checkIdentical(nchar(txt), as.vector(nchar(txtRle)))
checkIdentical(substr(txt, 3, 7), as.vector(substr(txtRle, 3, 7)))
checkIdentical(substring(txt, 4, 9), as.vector(substring(txtRle, 4, 9)))
checkIdentical(chartr("@!*", "alo", txt),
as.vector(chartr("@!*", "alo", txtRle)))
checkIdentical(tolower(txt), as.vector(tolower(txtRle)))
checkIdentical(toupper(txt), as.vector(toupper(txtRle)))
checkIdentical(sub("[b-e]",".", txt), as.vector(sub("[b-e]",".", txtRle)))
checkIdentical(gsub("[b-e]",".", txt), as.vector(gsub("[b-e]",".", txtRle)))
checkIdentical(paste(txt, rev(txt), sep = "|"),
as.vector(paste(txtRle, rev(txtRle), sep = "|")))
modifyFactor <- function(x, FUN, ...) {
levels(x) <- FUN(levels(x), ...)
x
}
fac <- factor(txt)
facRle <- Rle(fac)
checkIdentical(modifyFactor(fac, substr, 3, 7),
as.factor(substr(facRle, 3, 7)))
checkIdentical(modifyFactor(fac, substring, 4, 9),
as.factor(substring(facRle, 4, 9)))
checkIdentical(modifyFactor(fac, chartr, old = "@!*", new = "alo"),
as.factor(chartr("@!*", "alo", facRle)))
checkIdentical(modifyFactor(fac, tolower), as.factor(tolower(facRle)))
checkIdentical(modifyFactor(fac, toupper), as.factor(toupper(facRle)))
checkIdentical(modifyFactor(fac, sub, pattern = "[b-e]",
replacement = "."),
as.factor(sub("[b-e]",".", facRle)))
checkIdentical(modifyFactor(fac, gsub, pattern = "[b-e]",
replacement = "."),
as.factor(gsub("[b-e]",".", facRle)))
checkTrue(is.factor(runValue(paste(facRle, rev(facRle), sep = "|"))))
}
test_Rle_factor <- function() {
checkIdentical(factor(character()),
as.factor(Rle(factor(character()))))
x <- factor(rep(letters, 1:26))
xRle <- Rle(x)
checkIdentical(levels(x), levels(xRle))
levels(x) <- LETTERS
levels(xRle) <- LETTERS
checkIdentical(levels(x), levels(xRle))
checkIdentical(nlevels(x), 26L)
xRle[] <- xRle
checkIdentical(Rle(x), xRle)
checkIdentical(x, xRle[TRUE,drop=TRUE])
}
## ---------------------------------------------
## runsum(), runmean(), runwtsum()
## ---------------------------------------------
.naive_runsum <- function(x, k, na.rm=FALSE)
sapply(0:(length(x)-k),
function(offset) sum(x[1:k + offset], na.rm=na.rm))
checkIdenticalIfNaNsWereNAs <- function(x, y)
{
x[is.nan(x)] <- NA_real_
y[is.nan(y)] <- NA_real_
checkIdentical(x, y)
}
test_Rle_runsum_real <- function() {
x0 <- c(NA, NaN, Inf, -Inf)
x <- Rle(x0)
## na.rm = TRUE
target1 <- .naive_runsum(x0, 4, na.rm=TRUE)
target2 <- .naive_runsum(x, 4, na.rm=TRUE)
checkIdenticalIfNaNsWereNAs(target1, target2)
current <- as.vector(runsum(x, 4, na.rm=TRUE))
checkIdenticalIfNaNsWereNAs(target1, current)
## na.rm = FALSE
target1 <- .naive_runsum(x0, 4, na.rm=FALSE)
target2 <- .naive_runsum(x, 4, na.rm=FALSE)
checkIdenticalIfNaNsWereNAs(target1, target2)
current <- as.vector(runsum(x, 4, na.rm=FALSE))
checkIdenticalIfNaNsWereNAs(target1, current)
x0 <- c(NA, Inf, NA, -Inf, Inf, -Inf, NaN, Inf, NaN, -Inf)
x <- Rle(x0)
for (k in 1:2) {
target1 <- .naive_runsum(x0, k, na.rm=TRUE)
target2 <- .naive_runsum(x, k, na.rm=TRUE)
checkIdenticalIfNaNsWereNAs(target1, target2)
current <- as.vector(runsum(x, k, na.rm=TRUE))
checkIdenticalIfNaNsWereNAs(target1, current)
target1 <- .naive_runsum(x0, k, na.rm=FALSE)
target2 <- .naive_runsum(x, k, na.rm=FALSE)
checkIdenticalIfNaNsWereNAs(target1, target2)
current <- as.vector(runsum(x, k, na.rm=FALSE))
checkIdenticalIfNaNsWereNAs(target1, current)
}
## NOTE : Inconsistent behavior in base::sum()
## sum(x, y) and x + y:
## > sum(NaN, NA)
## [1] NA
## > NaN + NA
## [1] NaN
## also between sum(c(x, y)) and sum(x, y):
## This inconsistency only exists on linux, not Mac or Windows
## > sum(c(NaN, NA))
## [1] NaN
## > sum(NaN, NA)
## [1] NA
## x0 <- c(NA, NaN, NA)
## x <- Rle(x0)
## target1 <- c(x0[1] + x0[2], x0[2] + x0[3])
## target2 <- as.vector(c(x[1] + x[2], x[2] + x[3]))
## checkIdentical(target1, target2)
## current <- as.vector(runsum(x, k=2, na.rm=FALSE))
## checkIdentical(target1, current)
}
test_Rle_runsum_integer <- function() {
x0 <- c(NA_integer_, 1L, 1L)
x <- Rle(x0)
for (k in 1:3) {
target1 <- .naive_runsum(x0, k, na.rm=TRUE)
target2 <- .naive_runsum(x, k, na.rm=TRUE)
checkIdentical(target1, target2)
current <- as.vector(runsum(x, k, na.rm=TRUE))
checkIdentical(target1, current)
target1 <- .naive_runsum(x0, k, na.rm=FALSE)
target2 <- .naive_runsum(x, k, na.rm=FALSE)
checkIdentical(target1, target2)
current <- as.vector(runsum(x, k, na.rm=FALSE))
checkIdentical(target1, current)
}
x0 <- c(1L, NA_integer_, 1L)
x <- Rle(x0)
for (k in 1:3) {
target1 <- .naive_runsum(x0, k, na.rm=TRUE)
target2 <- .naive_runsum(x, k, na.rm=TRUE)
checkIdentical(target1, target2)
current <- as.vector(runsum(x, k, na.rm=TRUE))
checkIdentical(target1, current)
target1 <- .naive_runsum(x0, k, na.rm=FALSE)
target2 <- .naive_runsum(x, k, na.rm=FALSE)
checkIdentical(target1, target2)
current <- as.vector(runsum(x, k, na.rm=FALSE))
checkIdentical(target1, current)
}
}
.naive_runmean <- function(x, k, na.rm=FALSE)
sapply(0:(length(x)-k),
function(offset) mean(x[1:k + offset], na.rm=na.rm))
test_Rle_runmean <- function() {
x0 <- c(NA, 1, 1)
x <- Rle(x0)
for (k in 1:3) {
target1 <- .naive_runmean(x0, k, na.rm=TRUE)
target2 <- .naive_runmean(x, k, na.rm=TRUE)
checkIdentical(target1, target2)
current <- as.vector(runmean(x, k, na.rm=TRUE))
checkIdentical(target1, current)
target1 <- .naive_runmean(x0, k, na.rm=FALSE)
target2 <- .naive_runmean(x, k, na.rm=FALSE)
checkIdentical(target1, target2)
current <- as.vector(runmean(x, k, na.rm=FALSE))
checkIdentical(target1, current)
}
x0 <- c(0, NA, NaN, 0, NA, Inf, 0, NA, -Inf, 0, Inf, -Inf)
x <- Rle(x0)
for (k in 1:2) {
target1 <- .naive_runmean(x0, k, na.rm=TRUE)
target2 <- .naive_runmean(x, k, na.rm=TRUE)
checkIdentical(target1, target2)
current <- as.vector(runmean(x, k, na.rm=TRUE))
checkIdentical(target1, current)
target1 <- .naive_runmean(x0, k, na.rm=FALSE)
target2 <- .naive_runmean(x, k, na.rm=FALSE)
checkIdentical(target1, target2)
#current <- as.vector(runmean(x, k, na.rm=FALSE))
#checkIdentical(target1, current)
}
}
.naive_runwtsum <- function(x, k, wt, na.rm=FALSE)
sapply(0:(length(x)-k),
function(offset) {
xwt <- x[1:k + offset] * wt
sum(xwt, na.rm=na.rm)})
test_Rle_runwtsum_real <- function() {
x0 <- c(NA, NaN, Inf, -Inf)
x <- Rle(x0)
wt <- rep(1, 4)
target1 <- .naive_runwtsum(x0, 4, wt, na.rm=TRUE)
target2 <- .naive_runwtsum(x, 4, wt, na.rm=TRUE)
checkIdentical(target1, target2)
current <- as.vector(runwtsum(x, 4, wt, na.rm=TRUE))
checkIdentical(target1, current)
target1 <- .naive_runwtsum(x0, 4, wt, na.rm=FALSE)
target2 <- .naive_runwtsum(x, 4, wt, na.rm=FALSE)
checkIdentical(target1, target2)
#current <- as.vector(runwtsum(x, 4, wt, na.rm=FALSE))
#checkIdentical(target1, current)
x0 <- c(NA, Inf, NA, -Inf, Inf, -Inf, NaN, Inf, NaN, -Inf)
x <- Rle(x0)
for (k in 1:2) {
if (k==1)
wt <- 1
else
wt <- c(1, 1)
target1 <- .naive_runwtsum(x0, k, wt, na.rm=TRUE)
target2 <- .naive_runwtsum(x, k, wt, na.rm=TRUE)
checkIdentical(target1, target2)
current <- as.vector(runwtsum(x, k, wt, na.rm=TRUE))
checkIdentical(target1, current)
target1 <- .naive_runwtsum(x0, k, wt, na.rm=FALSE)
target2 <- .naive_runwtsum(x, k, wt, na.rm=FALSE)
checkIdentical(target1, target2)
current <- as.vector(runwtsum(x, k, wt, na.rm=FALSE))
checkIdentical(target1, current)
}
x0 <- c(1, NA, 1, NaN, 1, NA)
x <- Rle(x0)
for (k in 1:2) {
if (k==1)
wt <- 2
else
wt <- c(1, 1)
target1 <- .naive_runwtsum(x0, k, wt, na.rm=FALSE)
target2 <- .naive_runwtsum(x, k, wt, na.rm=FALSE)
checkIdentical(target1, target2)
current <- as.vector(runwtsum(x, k, wt, na.rm=FALSE))
checkIdentical(target1, current)
}
}
test_Rle_runwtsum_integer <- function() {
x0 <- c(NA_integer_, 1L, 1L)
x <- Rle(x0)
iwt <- rep(2L, 3)
for (k in 1:3) {
wt <- iwt[1:k]
target1 <- .naive_runwtsum(x0, k, wt, na.rm=TRUE)
target2 <- .naive_runwtsum(x, k, wt, na.rm=TRUE)
checkIdentical(target1, target2)
current <- as.vector(runwtsum(x, k, wt, na.rm=TRUE))
checkIdentical(as.numeric(target1), current)
target1 <- .naive_runwtsum(x0, k, wt, na.rm=FALSE)
target2 <- .naive_runwtsum(x, k, wt, na.rm=FALSE)
checkIdentical(target1, target2)
current <- as.vector(runwtsum(x, k, wt, na.rm=FALSE))
checkIdentical(as.numeric(target1), current)
}
x0 <- c(1L, NA_integer_, 1L)
x <- Rle(x0)
iwt <- rep(2L, 3)
for (k in 1:3) {
wt <- iwt[1:k]
target1 <- .naive_runwtsum(x0, k, wt, na.rm=TRUE)
target2 <- .naive_runwtsum(x, k, wt, na.rm=TRUE)
checkIdentical(target1, target2)
current <- as.vector(runwtsum(x, k, wt, na.rm=TRUE))
checkIdentical(as.numeric(target1), current)
target1 <- .naive_runwtsum(x0, k, wt, na.rm=FALSE)
target2 <- .naive_runwtsum(x, k, wt, na.rm=FALSE)
checkIdentical(target1, target2)
current <- as.vector(runwtsum(x, k, wt, na.rm=FALSE))
checkIdentical(as.numeric(target1), current)
}
}
.naive_runq <- function(x, k, i, na.rm=FALSE)
sapply(0:(length(x)-k),
function(offset) {
xsub <- x[1:k + offset]
if (!na.rm) {
## Manually handle NA's because they are not allowed
## in 'x' of quantile(x, ...) when na.rm=FALSE.
if (any(is.na(xsub)))
NA
else
quantile(xsub, probs=i/k, na.rm=na.rm, names=FALSE, type=3)
} else {
## If all NA's, just return first NA value.
## Not handled in quantile().
if (all(is.na(xsub))) {
xsub[1]
} else {
xsub <- xsub[!is.na(xsub)]
quantile(xsub, probs=i/k, na.rm=na.rm, names=FALSE, type=3)
}
}
}, USE.NAMES=FALSE)
test_Rle_runq_real <- function() {
x0 <- c(NA_real_)
x <- Rle(x0)
k <- length(x); i <- 1
target1 <- as.numeric(.naive_runq(x0, k, i, na.rm=TRUE))
current <- as.numeric(runq(x, k, i, na.rm=TRUE))
checkIdentical(target1, current)
x0 <- c(3, NA, 1, NaN, 4, Inf, 2, -Inf)
x <- Rle(x0)
k <- length(x)
for (i in c(1, length(x))) {
target1 <- as.numeric(.naive_runq(x0, k, i, na.rm=TRUE))
current <- as.numeric(runq(x, k, i, na.rm=TRUE))
checkIdentical(target1, current)
target1 <- as.numeric(.naive_runq(x0, k, i, na.rm=FALSE))
current <- as.numeric(runq(x, k, i, na.rm=FALSE))
checkIdentical(target1, current)
}
x0 <- c(3, NA, 1, NaN, 4, Inf, 2, -Inf)
x <- Rle(x0)
i <- 1
## NOTE : special case k=1, returns NA not NaN
target1 <- c(3, NA, 1, NA, 4, Inf, 2, -Inf)
current <- as.numeric(runq(x, k=1, i=1, na.rm=TRUE))
checkIdentical(target1, current)
for (k in c(2:length(x))) {
target1 <- as.numeric(.naive_runq(x0, k, i, na.rm=TRUE))
current <- as.numeric(runq(x, k, i, na.rm=TRUE))
checkIdentical(target1, current)
target1 <- as.numeric(.naive_runq(x0, k, i, na.rm=FALSE))
current <- as.numeric(runq(x, k, i, na.rm=FALSE))
checkIdentical(target1, current)
}
x0 <- c(1, 2, 3, 4, 5)
x <- Rle(x0)
k <- length(x); i <- 4
target1 <- .naive_runq(x0, k, i, na.rm=TRUE)
current <- as.vector(runq(x, k, i, na.rm=TRUE))
checkIdentical(target1, current)
x0 <- c(1, 2, 3, NA, NA)
x <- Rle(x0)
k <- length(x); i <- 4
target1 <- .naive_runq(x0, k, i, na.rm=TRUE)
current <- as.vector(runq(x, k, i, na.rm=TRUE))
checkIdentical(target1, current)
}
test_Rle_runq_integer <- function() {
x0 <- c(NA_integer_)
x <- Rle(x0)
k <- length(x); i <- 1
target1 <- as.numeric(.naive_runq(x0, k, i, na.rm=TRUE))
current <- as.numeric(runq(x, k, i, na.rm=TRUE))
checkIdentical(target1, current)
x0 <- NA_integer_
x <- Rle(x0)
k <- i <- 1
target1 <- unlist(.naive_runq(x0, k, i, na.rm=TRUE))
target2 <- as.vector(do.call(c, (.naive_runq(x, k, i, na.rm=TRUE))))
checkIdentical(target1, target2)
current <- as.vector(runq(x, k, i, na.rm=TRUE))
checkIdentical(as.integer(unname(target1)), current)
x0 <- c(NA_integer_, 2L, 1L)
x <- Rle(x0)
k <- 3
for (i in 1:3) {
target1 <- as.integer(unlist(.naive_runq(x0, k, i, na.rm=TRUE)))
current <- as.vector(runq(x, k, i, na.rm=TRUE))
checkIdentical(unname(target1), current)
target1 <- unlist(.naive_runq(x0, k, i, na.rm=FALSE))
current <- as.integer(runq(x, k, i, na.rm=FALSE))
checkIdentical(as.integer(target1), current)
}
x0 <- c(3L, 2L, NA_integer_, NA_integer_, 1L, 2L)
x <- Rle(x0)
i <- 1
for (k in 1:6) {
target1 <- as.integer(unlist(.naive_runq(x0, k, i, na.rm=TRUE)))
current <- as.vector(runq(x, k, i, na.rm=TRUE))
checkIdentical(target1, current)
target1 <- unlist(.naive_runq(x0, k, i, na.rm=FALSE))
current <- as.integer(runq(x, k, i, na.rm=FALSE))
checkIdentical(as.integer(target1), current)
}
}
Reference in New Issue Copy Permalink