Nothing
tests/testthat/test-computeStat.R
In stepR: Multiscale Change-Point Inference
context("computeStat")
source(system.file("tests/comparisons/indices.R", package = "stepR"))
source(system.file("tests/comparisons/singleStat.R", package = "stepR"))
statAll <- function(y, left, right, value, indices, singleStat, lengths, ...) {
indices <- indices(length(y), lengths = lengths, ...)
stat <- rep(-Inf, length(y))
for (i in 1:length(indices$li)) {
index <- sum(left <= indices$li[i])
if (index == length(right) - sum(right >= indices$ri[i]) + 1) {
stat[indices$ri[i] - indices$li[i] + 1] <- max(stat[indices$ri[i] - indices$li[i] + 1],
singleStat(y, value[index],
indices$li[i], indices$ri[i], ...))
}
}
stat
}
test <- function(testy = NULL, testsignal = 0, left = NULL, right = NULL, value = NULL,
testfamily = NULL, testintervalSystem = NULL, testlengths = NULL,
finallengths = NULL, testnq = length(testy), defaultPenalty = NULL, indices = NULL,
singleStat = NULL, tolerance = 1e-12, shift = 0, ...) {
# none
compare <- statAll(testy, left = left, right = right, value = value, indices = indices,
singleStat = singleStat, lengths = finallengths, ...)[finallengths]
expect_equal(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "none",
nq = testnq, output = "maximum", ...),
max(compare), info = "none", tolerance = tolerance)
expect_equal(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "none",
nq = testnq, output = "vector", ...),
compare, info = "none", tolerance = tolerance)
ret <- computeStat(testy, signal = testsignal, family = testfamily, intervalSystem = testintervalSystem,
lengths = testlengths, penalty = "none", nq = testnq, output = "list", ...)
expect_equal(ret, list(maximum = max(compare), stat = compare, lengths = finallengths),
info = "none", tolerance = tolerance)
expect_identical(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "none",
nq = testnq, ...), ret, info = "none")
# sqrt
compare <- statAll(testy, left = left, right = right, value = value, indices = indices,
singleStat = singleStat, lengths = finallengths, ...)[finallengths]
finite <- compare != -Inf
compare[finite] <- sqrt(2 * compare[finite]) - sqrt(2 * log(exp(1) * testnq / (finallengths[finite] + shift)))
expect_equal(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "sqrt",
nq = testnq, output = "maximum", ...),
max(compare), info = "sqrt", tolerance = tolerance)
expect_equal(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "sqrt",
nq = testnq, output = "vector", ...),
compare, info = "sqrt", tolerance = tolerance)
ret <- computeStat(testy, signal = testsignal, family = testfamily, intervalSystem = testintervalSystem,
lengths = testlengths, penalty = "sqrt", nq = testnq, output = "list", ...)
expect_equal(ret, list(maximum = max(compare), stat = compare, lengths = finallengths),
info = "sqrt", tolerance = tolerance)
expect_identical(computeStat(testy, signal = testsignal, family = testfamily, penalty = "sqrt",
intervalSystem = testintervalSystem, lengths = testlengths, nq = testnq, ...),
ret, info = "sqrt")
# log
compare <- statAll(testy, left = left, right = right, value = value, indices = indices,
singleStat = singleStat, lengths = finallengths, ...)[finallengths] -
log(exp(1) * testnq / (finallengths + shift))
expect_equal(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "log",
nq = testnq, output = "maximum", ...),
max(compare), info = "log", tolerance = tolerance)
expect_equal(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "log",
nq = testnq, output = "vector", ...),
compare, info = "log", tolerance = tolerance)
ret <- computeStat(testy, signal = testsignal, family = testfamily, intervalSystem = testintervalSystem,
lengths = testlengths, penalty = "log", nq = testnq, output = "list", ...)
expect_equal(ret, list(maximum = max(compare), stat = compare, lengths = finallengths),
info = "log", tolerance = tolerance)
expect_identical(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "log",
nq = testnq, ...), ret, info = "log")
# default penalty
expect_identical(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "maximum", nq = testnq, ...),
computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "maximum", nq = testnq, penalty = defaultPenalty, ...))
expect_identical(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "vector", nq = testnq, ...),
computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "vector", nq = testnq, penalty = defaultPenalty, ...))
expect_identical(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "list", nq = testnq, ...),
computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "list", nq = testnq, penalty = defaultPenalty, ...))
expect_identical(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
nq = testnq, ...),
computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "list", nq = testnq, penalty = defaultPenalty, ...))
}
test_that("argument y is tested", {
testn <- 100L
testy <- rnorm(testn)
expect_error(computeStat())
expect_error(computeStat(numeric(0)))
expect_identical(computeStat(testy), computeStat(testy, family = "gauss", intervalSystem = "all",
lengths = 1:testn, penalty = "sqrt", nq = testn,
output = "list", sd = sdrobnorm(testy)))
expect_error(computeStat(as.integer(testy)))
expect_error(computeStat(c(testy, "s")))
expect_error(computeStat(c(rnorm(10), NA)))
test(testy, left = 1L, right = testn, value = 0, finallengths = 1:testn,
indices = indicesAll, singleStat = singleStatGauss, sd = 1, defaultPenalty = "sqrt")
})
test_that("argument signal is tested and works in the default case", {
testn <- 34L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 12L), rightIndex = c(11L, 34L), value = c(0, 1))
expect_error(computeStat(testy, signal = NULL))
expect_error(computeStat(testy, signal = "s"))
expect_identical(computeStat(testy, signal = 0L), computeStat(testy, signal = 0))
expect_error(computeStat(testy, signal = c(1, 2)))
expect_error(computeStat(testy, signal = NA))
expect_error(computeStat(testy, signal = Inf))
expect_identical(computeStat(testy, signal = 1),
computeStat(testy, signal = list(leftIndex = 1L, rightIndex = 34L, value = 1)))
expect_equal(computeStat(testy, signal = 0),
computeStat(testy, signal = list(leftIndex = 1L, rightIndex = 34L, value = 0)),
tolerance = 1e-14)
expect_error(computeStat(testy, signal = list()))
expect_error(computeStat(testy, signal = list(leftIndex = 1L,
rightIndex = 34L, value = NULL)))
expect_error(computeStat(testy, signal = list(leftIndex = 1L,
rightIndex = c(17L, 34L), value = numeric(0))))
expect_error(computeStat(testy, signal = list(leftIndex = c(1L, 18L),
rightIndex = c(17L, 34L), value = numeric(0))))
expect_error(computeStat(testy, signal = list(leftIndex = c(1L, Inf),
rightIndex = c(17L, 34L), value = c(1, 2))))
expect_error(computeStat(testy, signal = list(leftIndex = c(1L, 18L),
rightIndex = c(17L, 34L), value = c(1, NA))))
expect_identical(computeStat(testy, signal = list(leftIndex = 1L, rightIndex = 34L, value = 1L)),
computeStat(testy, signal = list(leftIndex = 1L, rightIndex = 34L, value = 1)))
expect_identical(computeStat(testy, signal = list(leftIndex = 1, rightIndex = 34, value = 1)),
computeStat(testy, signal = list(leftIndex = 1L, rightIndex = 34L, value = 1)))
expect_error(computeStat(testy, signal = list(leftIndex = 2L, rightIndex = 35L, value = 1)))
expect_error(computeStat(testy, signal = list(leftIndex = c(1L, 18L),
rightIndex = c(17L, 35L), value = c(1, 2))))
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", finallengths = 1:testn,
indices = indicesAll, singleStat = singleStatGauss, sd = 1.23,
defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
finallengths = 1:testn, indices = indicesAll, singleStat = singleStatGauss,
sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "gauss", finallengths = 1:testn,
indices = indicesAll, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
testsignal <- list(leftIndex = c(1L, 12L), rightIndex = c(11L, 34L), value = c(0, 1))
testsignal2 <- list(lefxx = "s", rtg = 1:10, leftIndex = c(1L, 12L), rightIndex = c(11L, 34L), value = c(0, 1))
expect_identical(computeStat(testy, signal = testsignal2), computeStat(testy, signal = testsignal))
teststepfit <- stepfit(23, family = "gauss", value = c(0, 1), param = 2, leftEnd = c(1L, 12L) / 34,
rightEnd = c(11L, 34L) / 34, x0 = -1, leftIndex = c(1L, 12L), rightIndex = c(11L, 34L))
expect_identical(computeStat(testy, signal = teststepfit), computeStat(testy, signal = testsignal))
})
test_that("argument family is tested and works in the default case", { # other families below
testn <- 34L
testy <- rnorm(testn)
expect_error(computeStat(testy, family = ""))
expect_error(computeStat(testy, family = "bisom"))
expect_error(computeStat(testy, family = c("gauss", "hsmuce")))
expect_identical(computeStat(testy, signal = 0), computeStat(testy, signal = 0, family = "gauss"))
})
test_that("argument intervalSystem is tested and works", {
testn <- 34L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 12L), rightIndex = c(11L, 34L), value = c(0, 1))
expect_error(computeStat(testy, intervalSystem = ""))
expect_error(computeStat(testy, intervalSystem = "dya"))
expect_error(computeStat(testy, intervalSystem = "dyalen"))
expect_error(computeStat(testy, intervalSystem = "dyapar"))
expect_error(computeStat(testy, intervalSystem = c("dyaPar", "all")))
expect_identical(computeStat(testy, signal = 0), computeStat(testy, signal = 0, intervalSystem = "all"))
expect_identical(computeStat(rep(testy, 30), signal = 0),
computeStat(rep(testy, 30), signal = 0, intervalSystem = "dyaLen"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", finallengths = 2^(0:5),
testintervalSystem = "dyaLen", indices = indicesDyaLen, singleStat = singleStatGauss,
sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
finallengths = 2^(0:5), testintervalSystem = "dyaLen",
indices = indicesDyaLen, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "gauss", finallengths = 2^(0:5), testintervalSystem = "dyaLen",
indices = indicesDyaLen, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", finallengths = 2^(0:5),
testintervalSystem = "dyaPar", indices = indicesDyaPar, singleStat = singleStatGauss,
sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
finallengths = 2^(0:5), testintervalSystem = "dyaPar",
indices = indicesDyaPar, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "gauss", finallengths = 2^(0:5), testintervalSystem = "dyaPar",
indices = indicesDyaPar, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
})
test_that("argument lengths is tested and works", {
testn <- 45L
testy <- c(rnorm(20, 1, 0.23), rnorm(testn - 20, -1, 0.34))
testsignal <- list(leftIndex = c(1L, 23L), rightIndex = c(22L, 45L), value = c(0, -1))
expect_error(computeStat(testy, lengths = "s"))
expect_error(computeStat(testy, lengths = c(1:10, NA)))
expect_error(computeStat(testy, lengths = c(1:10, Inf)))
expect_error(computeStat(testy, lengths = 0:10))
expect_error(computeStat(testy, lengths = -1L))
expect_error(computeStat(testy, lengths = c(1L, 46L)))
expect_error(computeStat(testy, intervalSystem = "dyaLen", lengths = 3L))
expect_error(computeStat(testy, intervalSystem = "dyaLen", lengths = 64L))
expect_error(computeStat(testy, intervalSystem = "dyaPar", lengths = 3L))
expect_error(computeStat(testy, intervalSystem = "dyaPar", lengths = 64L))
expect_warning(ret <- computeStat(testy, lengths = c(1:10, 10)))
expect_identical(ret, computeStat(testy, lengths = c(1:10)))
expect_identical(computeStat(testy, lengths = c(10:1)),
computeStat(testy, lengths = c(1:10)))
expect_identical(computeStat(testy, lengths = c(1:10 + 0.5)),
computeStat(testy, lengths = c(1:10)))
expect_equal(computeStat(testy, lengths = 2^(0:5)), computeStat(testy, intervalSystem = "dyaLen"))
expect_equal(computeStat(testy, lengths = 2^(3:4)),
computeStat(testy, intervalSystem = "dyaLen", lengths = 2^(3:4)))
testlengths <- c(1, 3:5, 10:23)
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", testlengths = testlengths,
finallengths = testlengths, indices = indicesAllLengths,
singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
testlengths = testlengths, finallengths = testlengths,
indices = indicesAllLengths, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 23L), right = c(22L, 45L), value = c(0, -1),
testfamily = "gauss", testlengths = testlengths, finallengths = testlengths,
indices = indicesAllLengths, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
testlengths <- c(1, 4, 32)
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", testlengths = testlengths,
finallengths = testlengths, indices = indicesDyaLenLengths,
singleStat = singleStatGauss, sd = 1.23, testintervalSystem = "dyaLen", defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaLenLengths, singleStat = singleStatGauss, sd = 1.23,
testintervalSystem = "dyaLen", defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 23L), right = c(22L, 45L), value = c(0, -1),
testfamily = "gauss", testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaLenLengths, singleStat = singleStatGauss, sd = 1.23,
testintervalSystem = "dyaLen", defaultPenalty = "sqrt")
testlengths <- c(2, 4, 16)
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", testlengths = testlengths,
finallengths = testlengths, indices = indicesDyaParLengths,
singleStat = singleStatGauss, sd = 1.23, testintervalSystem = "dyaPar", defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaParLengths, singleStat = singleStatGauss, sd = 1.23,
testintervalSystem = "dyaPar", defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 23L), right = c(22L, 45L), value = c(0, -1),
testfamily = "gauss", testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaParLengths, singleStat = singleStatGauss, sd = 1.23,
testintervalSystem = "dyaPar", defaultPenalty = "sqrt")
suppressWarnings(ret <- computeStat(testy, lengths = integer(0)))
expect_identical(ret$maximum, -Inf)
expect_identical(ret$stat, numeric(0))
expect_identical(ret$lengths, integer(0))
})
test_that("argument penalty is tested and works in the default case", {
testn <- 34L
testy <- rnorm(testn)
expect_error(computeStat(testy, penalty = ""))
expect_error(computeStat(testy, penalty = c("gauss")))
expect_error(computeStat(testy, penalty = c("sqrt", "log")))
expect_identical(computeStat(testy, signal = 0), computeStat(testy, signal = 0, penalty = "sqrt"))
})
test_that("argument nq is tested and works", {
testn <- 34L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 12L), rightIndex = c(11L, 34L), value = c(0, 1))
expect_error(computeStat(testy, nq = "s"))
expect_error(computeStat(testy, nq = c(1L, 2L)))
expect_error(computeStat(testy, nq = NA))
expect_error(computeStat(testy, nq = Inf))
expect_error(computeStat(testy, nq = 0L))
expect_error(computeStat(testy, nq = -1L))
expect_error(computeStat(testy, nq = 33L))
expect_error(computeStat(testy, intervalSystem = "dyaPar", lengths = 64L, nq = 64L))
expect_identical(computeStat(testy), computeStat(testy, nq = testn))
expect_identical(computeStat(testy, nq = 100), computeStat(testy, nq = 100L))
expect_identical(computeStat(testy, nq = 100.5), computeStat(testy, nq = 100L))
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", finallengths = 1:testn,
testnq = 100L, indices = indicesAll, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
finallengths = 1:testn, testnq = 64L, indices = indicesAll, singleStat = singleStatGauss,
sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "gauss", finallengths = 1:testn, testnq = 55L,
indices = indicesAll, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
testlengths <- c(1, 3:5, 10:23)
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", testlengths = testlengths,
finallengths = testlengths, testnq = 100L, indices = indicesAllLengths,
singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
testlengths = testlengths, finallengths = testlengths, testnq = 64L,
indices = indicesAllLengths, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "gauss", testlengths = testlengths, finallengths = testlengths, testnq = 45L,
indices = indicesAllLengths, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
})
test_that("argument output is tested and works in the default case", {
testn <- 34L
testy <- rnorm(testn)
expect_error(computeStat(testy, output = 1))
expect_error(computeStat(testy, output = "mu"))
expect_identical(computeStat(testy, signal = 0), computeStat(testy, signal = 0, output = "l"))
})
test_that("... is tested and works", {
testn <- 34L
testy <- rnorm(testn)
expect_error(computeStat(testy, std = 1))
expect_error(computeStat(testy, familty = "hsmuce"))
expect_error(computeStat(testy, covariances = c(1, 0.6)))
expect_error(computeStat(testy, sd = "s"))
expect_error(computeStat(testy, sd = c(1, 2)))
expect_error(computeStat(testy, sd = NA))
expect_error(computeStat(c(1, 2)))
expect_error(computeStat(testy, sd = Inf))
expect_error(computeStat(testy, sd = 0))
expect_error(computeStat(testy, sd = -0.1))
expect_identical(computeStat(testy), computeStat(testy, sd = sdrobnorm(testy)))
expect_identical(computeStat(testy, sd = 1L), computeStat(testy, sd = 1))
})
test_that("family hsmuce works", {
testn <- 100L
testy <- rnorm(testn)
expect_error(computeStat(family = "hsmuce"))
expect_error(computeStat(numeric(0), family = "hsmuce"))
expect_identical(computeStat(testy, family = "hsmuce"),
computeStat(testy, family = "hsmuce", intervalSystem = "dyaPar", lengths = 2^(1:6),
penalty = "none", nq = testn, output = "list"))
expect_error(computeStat(as.integer(testy), family = "hsmuce"))
expect_error(computeStat(c(testy, "s"), family = "hsmuce"))
expect_error(computeStat(c(rnorm(10), NA), family = "hsmuce"))
expect_error(computeStat(c(rnorm(10), Inf), family = "hsmuce"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", finallengths = 2^(1:6),
indices = indicesDyaPar, singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
testn <- 34L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 12L), rightIndex = c(11L, 34L), value = c(0, 1))
expect_equal(computeStat(testy, signal = 0, family = "hsmuce"),
computeStat(testy, signal = list(leftIndex = 1L, rightIndex = 34L, value = 0),
family = "hsmuce"), tolerance = 1e-6)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", finallengths = 2^(1:5),
indices = indicesDyaPar, singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hsmuce",
finallengths = 2^(1:5), indices = indicesDyaPar, singleStat = singleStatHsmuce,
defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "hsmuce", finallengths = 2^(1:5), indices = indicesDyaPar, singleStat = singleStatHsmuce,
defaultPenalty = "none", tolerance = 1e-6)
expect_identical(computeStat(testy, family = "hsm"), computeStat(testy, family = "hsmuce"))
expect_identical(computeStat(testy, signal = 0, family = "hsmuce"),
computeStat(testy, signal = 0, family = "hsmuce", intervalSystem = "dyaPar"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", finallengths = 2:testn,
testintervalSystem = "all", indices = indicesAll, singleStat = singleStatHsmuce,
defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hsmuce",
finallengths = 2:testn, testintervalSystem = "all", indices = indicesAll, singleStat = singleStatHsmuce,
defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "hsmuce", finallengths = 2:testn, testintervalSystem = "all",
indices = indicesAll, singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", finallengths = 2^(1:5),
testintervalSystem = "dyaLen", indices = indicesDyaLen, singleStat = singleStatHsmuce,
defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hsmuce",
finallengths = 2^(1:5), testintervalSystem = "dyaLen", indices = indicesDyaLen,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "hsmuce", finallengths = 2^(1:5), testintervalSystem = "dyaLen", indices = indicesDyaLen,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
testn <- 45L
testy <- c(rnorm(20, 1, 0.23), rnorm(testn - 20, -1, 0.34))
testsignal <- list(leftIndex = c(1L, 23L), rightIndex = c(22L, 45L), value = c(0, -1))
expect_error(computeStat(testy, family = "hsmuce", lengths = 1:3))
expect_error(computeStat(testy, family = "hsmuce", intervalSystem = "all", lengths = 1:45))
expect_error(computeStat(testy, family = "hsmuce", intervalSystem = "dyaLen", lengths = 1:2))
testlengths <- c(2, 6:10, 23:45)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", testintervalSystem = "all",
testlengths = testlengths, finallengths = testlengths, indices = indicesAllLengths,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hsmuce",
testintervalSystem = "all", testlengths = testlengths, finallengths = testlengths,
indices = indicesAllLengths, singleStat = singleStatHsmuce, defaultPenalty = "none",
tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 23L), right = c(22L, 45L), value = c(0, -1),
testfamily = "hsmuce", testintervalSystem = "all", testlengths = testlengths,
finallengths = testlengths, indices = indicesAllLengths,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
testlengths <- c(2, 4, 32)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", testlengths = testlengths,
finallengths = testlengths, indices = indicesDyaLenLengths, singleStat = singleStatHsmuce,
defaultPenalty = "none", tolerance = 1e-6, testintervalSystem = "dyaLen")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hsmuce",
testlengths = testlengths, finallengths = testlengths, indices = indicesDyaLenLengths,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6, testintervalSystem = "dyaLen")
test(testy, testsignal = testsignal, left = c(1L, 23L), right = c(22L, 45L), value = c(0, -1),
testfamily = "hsmuce", testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaLenLengths, singleStat = singleStatHsmuce, defaultPenalty = "none",
tolerance = 1e-6, testintervalSystem = "dyaLen")
testlengths <- c(4, 8, 16)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", testlengths = testlengths,
finallengths = testlengths, indices = indicesDyaParLengths,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hsmuce",
testlengths = testlengths, finallengths = testlengths, indices = indicesDyaParLengths,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 23L), right = c(22L, 45L), value = c(0, -1),
testfamily = "hsmuce", testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaParLengths, singleStat = singleStatHsmuce, defaultPenalty = "none",
tolerance = 1e-6)
expect_identical(computeStat(testy, signal = 0, family = "hsmuce"),
computeStat(testy, signal = 0, family = "hsmuce", penalty = "none"))
expect_identical(computeStat(testy, signal = 0, family = "hsmuce", penalty = "weights"),
computeStat(testy, signal = 0, family = "hsmuce", penalty = "none"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", finallengths = 2^(1:5),
testnq = 100L, indices = indicesDyaPar, singleStat = singleStatHsmuce, defaultPenalty = "none",
tolerance = 1e-6)
expect_error(computeStat(testy, family = "hsmuce", sd = 1))
expect_error(computeStat(testy, family = "hsmuce", intervalsystem = "all"))
suppressWarnings(ret <- computeStat(c(1), family = "hsmuce"))
expect_identical(ret$maximum, -Inf)
expect_identical(ret$stat, numeric(0))
expect_identical(ret$lengths, integer(0))
})
test_that("family mDependentPS works", {
testn <- 30L
testy <- rnorm(testn)
testCovariances <- seq(1, 0.2, -0.2)
expect_error(computeStat(family = "mDependentPS", covariances = testCovariances))
expect_error(computeStat(numeric(0), family = "mDependentPS", covariances = testCovariances))
expect_identical(computeStat(testy, family = "mDependentPS", covariances = testCovariances),
computeStat(testy, family = "mDependentPS", intervalSystem = "dyaLen", lengths = 2^(0:4),
penalty = "sqrt", nq = testn, output = "list", covariances = testCovariances))
expect_error(computeStat(as.integer(testy), family = "mDependentPS", covariances = testCovariances))
expect_error(computeStat(c(testy, "s"), family = "mDependentPS", covariances = testCovariances))
expect_error(computeStat(c(rnorm(10), NA), family = "mDependentPS", covariances = testCovariances))
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", finallengths = 2^(0:4),
indices = indicesDyaLen, singleStat = singleStatmDependentPS,
covariances = testCovariances, defaultPenalty = "sqrt")
testn <- 18L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 12L), rightIndex = c(11L, 18L), value = c(0, 1))
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", finallengths = 2^(0:4),
indices = indicesDyaLen, singleStat = singleStatmDependentPS,
covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "mDependentPS",
finallengths = 2^(0:4), indices = indicesDyaLen, singleStat = singleStatmDependentPS,
covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, testn), value = c(0, 1),
testfamily = "mDependentPS", finallengths = 2^(0:4), indices = indicesDyaLen,
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
expect_identical(computeStat(testy, signal = 0, family = "mDependentPS", covariances = testCovariances),
computeStat(testy, signal = 0, family = "mDependentPS", intervalSystem = "dyaLen",
covariances = testCovariances))
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", finallengths = 1:testn,
testintervalSystem = "all", indices = indicesAll, singleStat = singleStatmDependentPS,
covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "mDependentPS",
finallengths = 1:testn, testintervalSystem = "all", indices = indicesAll,
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, testn), value = c(0, 1),
testfamily = "mDependentPS", finallengths = 1:testn, testintervalSystem = "all", indices = indicesAll,
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", finallengths = 2^(0:4),
testintervalSystem = "dyaPar", indices = indicesDyaPar,
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "mDependentPS",
finallengths = 2^(0:4), testintervalSystem = "dyaPar", indices = indicesDyaPar,
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, testn), value = c(0, 1),
testfamily = "mDependentPS", finallengths = 2^(0:4), testintervalSystem = "dyaPar",
indices = indicesDyaPar, singleStat = singleStatmDependentPS, covariances = testCovariances,
defaultPenalty = "sqrt")
testn <- 17L
testcovariances <- as.numeric(ARMAacf(ar = c(), ma = c(0.8, 0.5, 0.3), lag.max = 3))
testsignal <- list(leftIndex = c(1L, 13L), rightIndex = c(12L, testn), value = c(0, -1))
testy <- as.numeric(arima.sim(n = testn, list(ar = c(), ma = c(0.8, 0.5, 0.3)), sd = 1))
testlengths <- c(1, 3:5, 10:14)
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", testlengths = testlengths,
finallengths = testlengths, indices = indicesAllLengths, testintervalSystem = "all",
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "mDependentPS",
testlengths = testlengths, finallengths = testlengths, testintervalSystem = "all", defaultPenalty = "sqrt",
indices = indicesAllLengths, singleStat = singleStatmDependentPS, covariances = testCovariances)
test(testy, testsignal = testsignal, left = c(1L, 13L), right = c(12L, testn), value = c(0, -1),
testfamily = "mDependentPS", testlengths = testlengths, finallengths = testlengths,
testintervalSystem = "all", indices = indicesAllLengths, singleStat = singleStatmDependentPS,
covariances = testCovariances, defaultPenalty = "sqrt")
testlengths <- c(1, 4, 16)
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", testlengths = testlengths,
finallengths = testlengths, indices = indicesDyaLenLengths,
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "mDependentPS",
testlengths = testlengths, finallengths = testlengths, defaultPenalty = "sqrt",
indices = indicesDyaLenLengths, singleStat = singleStatmDependentPS, covariances = testCovariances)
test(testy, testsignal = testsignal, left = c(1L, 13L), right = c(12L, testn), value = c(0, -1),
testfamily = "mDependentPS", testlengths = testlengths, finallengths = testlengths, defaultPenalty = "sqrt",
indices = indicesDyaLenLengths, singleStat = singleStatmDependentPS, covariances = testCovariances)
testlengths <- c(2, 4, 16)
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", testlengths = testlengths,
finallengths = testlengths, defaultPenalty = "sqrt", indices = indicesDyaParLengths,
singleStat = singleStatmDependentPS, covariances = testCovariances, testintervalSystem = "dyaPar")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "mDependentPS",
testlengths = testlengths, finallengths = testlengths, indices = indicesDyaParLengths,
singleStat = singleStatmDependentPS, covariances = testCovariances,
testintervalSystem = "dyaPar", defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 13L), right = c(12L, testn), value = c(0, -1),
testfamily = "mDependentPS", testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaParLengths, singleStat = singleStatmDependentPS, covariances = testCovariances,
testintervalSystem = "dyaPar", defaultPenalty = "sqrt")
expect_identical(computeStat(testy, family = "mDependentPS", signal = 0, covariances = testCovariances),
computeStat(testy, family = "mDependentPS", signal = 0, covariances = testCovariances,
penalty = "sqrt"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", finallengths = 2^(0:4),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatmDependentPS,
covariances = testCovariances, defaultPenalty = "sqrt")
})
test_that("arguments in ... are tested and work for family mDependentPS", {
testn <- 17L
testcovariances <- as.numeric(ARMAacf(ar = c(), ma = c(0.8, 0.5, 0.3), lag.max = 3)) * 2^2
testcorrelations <- testcovariances / testcovariances[1]
testsignal <- list(leftIndex = c(1L, 13L), rightIndex = c(12L, testn), value = c(0, -1))
testfilter <- list(acf = testcorrelations)
class(testfilter) <- c("lowpassFilter", class(testfilter))
testy <- as.numeric(arima.sim(n = testn, list(ar = c(), ma = c(0.8, 0.5, 0.3)), sd = 2))
expect_error(computeStat(testy, family = "mDependentPS", covariances = testCovariances, std = 1))
expect_error(computeStat(testy, family = "mDependentPS", correlations = testcorrelations, std = 1))
expect_error(computeStat(testy, family = "mDependentPS", filter = testfilter, std = 1))
expect_error(computeStat(testy, family = "mDependentPS", intervalsystem = "all"))
expect_error(computeStat(testy, family = "mDependentPS"))
expect_error(computeStat(testy, family = "mDependentPS", sd = 1))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(testcovariances, "s")))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(testcovariances, NA)))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(testcovariances, Inf)))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(0.01, testcovariances)))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(-10, testcovariances)))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(1, testcovariances)))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(testcovariances, 0)))
expect_error(computeStat(testy, family = "mDependentPS", correlations = c(testcorrelations, "s")))
expect_error(computeStat(testy, family = "mDependentPS", correlations = c(testcorrelations, NA)))
expect_error(computeStat(testy, family = "mDependentPS", correlations = c(testcorrelations, Inf)))
expect_error(computeStat(testy, family = "mDependentPS", correlations = c(testcorrelations, 1.1)))
expect_error(computeStat(testy, family = "mDependentPS", correlations = c(0.99, testcorrelations[-1])))
expect_error(computeStat(testy, family = "mDependentPS", correlations = c(testcorrelations, 0)))
expect_error(computeStat(testy, sd = "s", family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(testy, sd = c(1, 2), family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(testy, sd = NA, family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(c(1, 2), family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(testy, sd = Inf, family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(testy, sd = 0, family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(testy, sd = -0.1, family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(testy, family = "mDependentPS",
filter = list(param = list(acf = testcorrelations))))
expect_error(computeStat(testy, sd = "s", family = "mDependentPS", filter = testfilter))
expect_error(computeStat(testy, sd = c(1, 2), family = "mDependentPS", filter = testfilter))
expect_error(computeStat(testy, sd = NA, family = "mDependentPS", filter = testfilter))
expect_error(computeStat(c(1, 2), family = "mDependentPS", filter = testfilter))
expect_error(computeStat(testy, sd = Inf, family = "mDependentPS", filter = testfilter))
expect_error(computeStat(testy, sd = 0, family = "mDependentPS", filter = testfilter))
expect_error(computeStat(testy, sd = -0.1, family = "mDependentPS", filter = testfilter))
expect_identical(computeStat(testy, family = "mDependentPS",
covariances = sdrobnorm(testy, lag = 4)^2 * testcorrelations),
computeStat(testy, family = "mDependentPS", correlations = testcorrelations))
expect_identical(computeStat(testy, family = "mDependentPS",
covariances = 1.1^2 * testcorrelations),
computeStat(testy, family = "mDependentPS", correlations = testcorrelations, sd = 1.1))
expect_identical(computeStat(testy, family = "mDependentPS",
covariances = sdrobnorm(testy, lag = 4)^2 * testcorrelations),
computeStat(testy, family = "mDependentPS", filter = testfilter))
expect_identical(computeStat(testy, family = "mDependentPS",
covariances = 1.1^2 * testcorrelations),
computeStat(testy, family = "mDependentPS", filter = testfilter, sd = 1.1))
})
test_that("family jsmurf works", {
testn <- 70L
testy <- rnorm(testn)
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4L, cutoff = 0.1), sr = 1e4)
expect_error(computeStat(family = "jsmurf", filter = testfilter))
expect_error(computeStat(numeric(0), family = "jsmurf", filter = testfilter))
expect_identical(computeStat(testy, family = "jsmurf", filter = testfilter),
computeStat(testy, family = "jsmurf", intervalSystem = "dyaLen", lengths = 2^(4:6),
penalty = "sqrt", nq = testn, output = "list", filter = testfilter))
expect_error(computeStat(as.integer(testy), family = "jsmurf", filter = testfilter))
expect_error(computeStat(c(testy, "s"), family = "jsmurf", filter = testfilter))
expect_error(computeStat(c(rnorm(10), NA), family = "jsmurf", filter = testfilter))
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurf", finallengths = 2^(4:6),
indices = indicesDyaLen, singleStat = singleStatJsmurf, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = - testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfPS", finallengths = 2^(4:6),
indices = indicesDyaLen, singleStat = singleStatJsmurfPS, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = - testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfLR", finallengths = 2^(4:6),
indices = indicesDyaLen, singleStat = singleStatJsmurfLR, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = - testfilter$len)
testn <- 68L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 22L), rightIndex = c(21L, 68L), value = c(0, 1))
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234),
testfamily = "jsmurf", finallengths = 2^(4:6), indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurf, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234),
testfamily = "jsmurfPS", finallengths = 2^(4:6), indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234),
testfamily = "jsmurfLR", finallengths = 2^(4:6), indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurfLR, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurf", finallengths = 2^(4:6), indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurf, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfPS", finallengths = 2^(4:6), indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt",
shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfLR", finallengths = 2^(4:6), indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurfLR, filter = testfilter, defaultPenalty = "sqrt",
shift = -testfilter$len)
expect_identical(computeStat(testy, signal = 0, family = "jsmurf", filter = testfilter),
computeStat(testy, signal = 0, family = "jsmurf", intervalSystem = "dyaLen",
filter = testfilter))
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurf", finallengths = (testfilter$len + 1):testn,
testintervalSystem = "all", indices = indicesAll, sd = 1, singleStat = singleStatJsmurf,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "jsmurfPS",
finallengths = (testfilter$len + 1):testn, testintervalSystem = "all", indices = indicesAll, sd = 1,
singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfLR", finallengths = (testfilter$len + 1):testn,
testintervalSystem = "all", indices = indicesAll, sd = 1, singleStat = singleStatJsmurfLR,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurf", finallengths = 2^(4:6),
testintervalSystem = "dyaPar", indices = indicesDyaPar, sd = 1, singleStat = singleStatJsmurf,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "jsmurfPS",
finallengths = 2^(4:6), testintervalSystem = "dyaPar", indices = indicesDyaPar, sd = 1,
singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfLR", finallengths = 2^(4:6),
testintervalSystem = "dyaPar", indices = indicesDyaPar, sd = 1, singleStat = singleStatJsmurfLR,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
expect_error(computeStat(y = testy, family = "jsmurf", filter = testfilter, lengths = c(8L, 16L)))
expect_error(computeStat(y = testy, family = "jsmurfPS", filter = testfilter, lengths = c(8L, 16L)))
expect_error(computeStat(y = testy, family = "jsmurfLR", filter = testfilter, lengths = c(8L, 16L)))
testlengths <- c(16L, 64L)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfLR", finallengths = testlengths,
indices = indicesDyaLen, testlengths = testlengths, singleStat = singleStatJsmurfLR, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = - testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234), testlengths = testlengths,
testfamily = "jsmurf", finallengths = testlengths, indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurf, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfPS", finallengths = testlengths, indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt",
testlengths = testlengths, shift = -testfilter$len)
testlengths <- c(13L, 15:18, 64L)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfLR", finallengths = testlengths,
testintervalSystem = "all", indices = indicesAll, testlengths = testlengths, singleStat = singleStatJsmurfLR,
sd = 1, filter = testfilter, defaultPenalty = "sqrt", shift = - testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234), testlengths = testlengths,
testintervalSystem = "all", testfamily = "jsmurf", finallengths = testlengths, indices = indicesAll, sd = 1,
singleStat = singleStatJsmurf, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfPS", finallengths = testlengths, indices = indicesAll, sd = 1,
testintervalSystem = "all", singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt",
testlengths = testlengths, shift = -testfilter$len)
testlengths <- c(32L, 64L)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfLR", finallengths = testlengths,
testintervalSystem = "dyaPar", indices = indicesDyaPar, testlengths = testlengths,
singleStat = singleStatJsmurfLR, tolerance = 1e-10,
sd = 1, filter = testfilter, defaultPenalty = "sqrt", shift = - testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234), testlengths = testlengths,
testintervalSystem = "dyaPar", testfamily = "jsmurf", finallengths = testlengths, indices = indicesDyaPar,
sd = 1, singleStat = singleStatJsmurf, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfPS", finallengths = testlengths, indices = indicesDyaPar, sd = 1,
testintervalSystem = "dyaPar", singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt",
testlengths = testlengths, shift = -testfilter$len)
expect_identical(computeStat(testy, family = "jsmurf", signal = 0, filter = testfilter),
computeStat(testy, family = "jsmurf", signal = 0, filter = testfilter,
penalty = "sqrt"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurf", finallengths = 2^(4:6),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatJsmurf, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfPS", finallengths = 2^(4:6),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatJsmurfPS, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfLR", finallengths = 2^(4:6),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatJsmurfLR, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
suppressWarnings(ret <- computeStat(rnorm(10), family = "jsmurfLR", filter = testfilter, sd = 1))
expect_identical(ret$maximum, -Inf)
expect_identical(ret$stat, numeric(0))
expect_identical(ret$lengths, integer(0))
})
test_that("arguments in ... are tested and work for family jsmurf", {
testn <- 35L
testy <- rnorm(testn)
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4L, cutoff = 0.1), sr = 1e4)
expect_error(computeStat(testy, family = "jsmurf", filter = testfilter, std = 1))
expect_error(computeStat(testy, family = "jsmurf", filter = testfilter, intervalsystem = "all"))
expect_error(computeStat(testy, family = "jsmurf"))
expect_error(computeStat(testy, family = "jsmurf", sd = 1))
expect_error(computeStat(testy, family = "jsmurf", filter = unclass(testfilter)))
expect_error(computeStat(testy, sd = "s", family = "jsmurf", filter = testfilter))
expect_error(computeStat(testy, sd = c(1, 2), family = "jsmurf", filter = testfilter))
expect_error(computeStat(testy, sd = NA, family = "jsmurf", filter = testfilter))
expect_error(computeStat(c(1, 2), family = "jsmurf", filter = testfilter))
expect_error(computeStat(testy, sd = Inf, family = "jsmurf", filter = testfilter))
expect_error(computeStat(testy, sd = 0, family = "jsmurf", filter = testfilter))
expect_error(computeStat(testy, sd = -0.1, family = "jsmurf", filter = testfilter))
expect_identical(computeStat(testy, family = "jsmurf", filter = testfilter),
computeStat(testy, family = "jsmurf", filter = testfilter,
sd = sdrobnorm(testy, lag = testfilter$len + 1)))
expect_error(computeStat(testy, family = "jsmurfPS", filter = testfilter, std = 1))
expect_error(computeStat(testy, family = "jsmurfPS", filter = testfilter, intervalsystem = "all"))
expect_error(computeStat(testy, family = "jsmurfPS"))
expect_error(computeStat(testy, family = "jsmurfPS", sd = 1))
expect_error(computeStat(testy, family = "jsmurfPS", filter = unclass(testfilter)))
expect_error(computeStat(testy, sd = "s", family = "jsmurfPS", filter = testfilter))
expect_error(computeStat(testy, sd = c(1, 2), family = "jsmurfPS", filter = testfilter))
expect_error(computeStat(testy, sd = NA, family = "jsmurfPS", filter = testfilter))
expect_error(computeStat(c(1, 2), family = "jsmurfPS", filter = testfilter))
expect_error(computeStat(testy, sd = Inf, family = "jsmurfPS", filter = testfilter))
expect_error(computeStat(testy, sd = 0, family = "jsmurfPS", filter = testfilter))
expect_error(computeStat(testy, sd = -0.1, family = "jsmurfPS", filter = testfilter))
expect_identical(computeStat(testy, family = "jsmurfPS", filter = testfilter),
computeStat(testy, family = "jsmurfPS", filter = testfilter,
sd = sdrobnorm(testy, lag = testfilter$len + 1)))
expect_error(computeStat(testy, family = "jsmurfLR", filter = testfilter, std = 1))
expect_error(computeStat(testy, family = "jsmurfLR", filter = testfilter, intervalsystem = "all"))
expect_error(computeStat(testy, family = "jsmurfLR"))
expect_error(computeStat(testy, family = "jsmurfLR", sd = 1))
expect_error(computeStat(testy, family = "jsmurfLR", filter = unclass(testfilter)))
expect_error(computeStat(testy, sd = "s", family = "jsmurfLR", filter = testfilter))
expect_error(computeStat(testy, sd = c(1, 2), family = "jsmurfLR", filter = testfilter))
expect_error(computeStat(testy, sd = NA, family = "jsmurfLR", filter = testfilter))
expect_error(computeStat(c(1, 2), family = "jsmurfLR", filter = testfilter))
expect_error(computeStat(testy, sd = Inf, family = "jsmurfLR", filter = testfilter))
expect_error(computeStat(testy, sd = 0, family = "jsmurfLR", filter = testfilter))
expect_error(computeStat(testy, sd = -0.1, family = "jsmurfLR", filter = testfilter))
expect_identical(computeStat(testy, family = "jsmurfLR", filter = testfilter),
computeStat(testy, family = "jsmurfLR", filter = testfilter,
sd = sdrobnorm(testy, lag = testfilter$len + 1)))
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 6L, cutoff = 0.25),
sr = 5e4, shift = 0.2)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurf", finallengths = 2^(2:5),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatJsmurf, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfPS", finallengths = 2^(2:5),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatJsmurfPS, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfLR", finallengths = 2^(2:5),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatJsmurfLR, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
})
test_that("family hjsmurf works", {
testn <- 70L
testy <- rnorm(testn)
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4L, cutoff = 0.1), sr = 1e4)
expect_error(computeStat(family = "hjsmurf", filter = testfilter))
expect_error(computeStat(numeric(0), family = "hjsmurf", filter = testfilter))
expect_identical(computeStat(testy, family = "hjsmurf", filter = testfilter),
computeStat(testy, family = "hjsmurf", intervalSystem = "dyaLen", lengths = 2^(4:6),
penalty = "none", nq = testn, output = "list", filter = testfilter))
expect_error(computeStat(as.integer(testy), family = "hjsmurf", filter = testfilter))
expect_error(computeStat(c(testy, "s"), family = "hjsmurf", filter = testfilter))
expect_error(computeStat(c(rnorm(10), NA), family = "hjsmurf", filter = testfilter))
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurf", finallengths = 2^(4:6),
indices = indicesDyaLen, singleStat = singleStatHjsmurf,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfSPS", finallengths = 2^(4:6),
indices = indicesDyaLen, singleStat = singleStatHjsmurfSPS,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfLR", finallengths = 2^(4:6),
indices = indicesDyaLen, singleStat = singleStatHjsmurfLR,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
testn <- 68L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 22L), rightIndex = c(21L, 68L), value = c(0, 1))
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234),
testfamily = "hjsmurf", finallengths = 2^(4:6), indices = indicesDyaLen,
singleStat = singleStatHjsmurf, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234),
testfamily = "hjsmurfSPS", finallengths = 2^(4:6), indices = indicesDyaLen,
singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234),
testfamily = "hjsmurfLR", finallengths = 2^(4:6), indices = indicesDyaLen,
singleStat = singleStatHjsmurfLR, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurf", finallengths = 2^(4:6), indices = indicesDyaLen,
singleStat = singleStatHjsmurf, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfSPS", finallengths = 2^(4:6), indices = indicesDyaLen,
singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none",
shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfLR", finallengths = 2^(4:6), indices = indicesDyaLen,
singleStat = singleStatHjsmurfLR, filter = testfilter, defaultPenalty = "none",
shift = -testfilter$len)
expect_identical(computeStat(testy, signal = 0, family = "hjsmurf", filter = testfilter),
computeStat(testy, signal = 0, family = "hjsmurf", intervalSystem = "dyaLen",
filter = testfilter))
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurf", finallengths = (testfilter$len + 2):testn,
testintervalSystem = "all", indices = indicesAll, singleStat = singleStatHjsmurf,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len, tolerance = 1e-6)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hjsmurfSPS",
finallengths = (testfilter$len + 2):testn, testintervalSystem = "all", indices = indicesAll,
singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len,
tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfLR", finallengths = (testfilter$len + 2):testn,
testintervalSystem = "all", indices = indicesAll, singleStat = singleStatHjsmurfLR,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len, tolerance = 1e-6)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurf", finallengths = 2^(4:6),
testintervalSystem = "dyaPar", indices = indicesDyaPar, singleStat = singleStatHjsmurf,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hjsmurfSPS",
finallengths = 2^(4:6), testintervalSystem = "dyaPar", indices = indicesDyaPar,
singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfLR", finallengths = 2^(4:6),
testintervalSystem = "dyaPar", indices = indicesDyaPar, singleStat = singleStatHjsmurfLR,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
expect_error(computeStat(y = testy, family = "hjsmurf", filter = testfilter, lengths = c(8L, 16L)))
expect_error(computeStat(y = testy, family = "hjsmurfPS", filter = testfilter, lengths = c(8L, 16L)))
expect_error(computeStat(y = testy, family = "hjsmurfLR", filter = testfilter, lengths = c(8L, 16L)))
testlengths <- c(16L, 64L)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfLR", finallengths = testlengths,
indices = indicesDyaLen, testlengths = testlengths, singleStat = singleStatHjsmurfLR,
filter = testfilter, defaultPenalty = "none", shift = - testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234), testlengths = testlengths,
testfamily = "hjsmurf", finallengths = testlengths, indices = indicesDyaLen,
singleStat = singleStatHjsmurf, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfSPS", finallengths = testlengths, indices = indicesDyaLen,
singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none",
testlengths = testlengths, shift = -testfilter$len)
testlengths <- c(13L, 15:18, 64L)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfLR", finallengths = testlengths,
testintervalSystem = "all", indices = indicesAll, testlengths = testlengths, singleStat = singleStatHjsmurfLR,
filter = testfilter, defaultPenalty = "none", shift = - testfilter$len, tolerance = 1e-6)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234), testlengths = testlengths,
testintervalSystem = "all", testfamily = "hjsmurf", finallengths = testlengths, indices = indicesAll,
singleStat = singleStatHjsmurf, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len,
tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfSPS", finallengths = testlengths, indices = indicesAll,
testintervalSystem = "all", singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none",
testlengths = testlengths, shift = -testfilter$len, tolerance = 1e-6)
testlengths <- c(32L, 64L)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfLR", finallengths = testlengths,
testintervalSystem = "dyaPar", indices = indicesDyaPar, testlengths = testlengths,
singleStat = singleStatHjsmurfLR, filter = testfilter, defaultPenalty = "none", shift = - testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234), testlengths = testlengths,
testintervalSystem = "dyaPar", testfamily = "hjsmurf", finallengths = testlengths, indices = indicesDyaPar,
singleStat = singleStatHjsmurf, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfSPS", finallengths = testlengths, indices = indicesDyaPar,
testintervalSystem = "dyaPar", singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none",
testlengths = testlengths, shift = -testfilter$len)
expect_identical(computeStat(testy, family = "hjsmurf", signal = 0, filter = testfilter),
computeStat(testy, family = "hjsmurf", signal = 0, filter = testfilter,
penalty = "none"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurf", finallengths = 2^(4:6),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatHjsmurf,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfSPS", finallengths = 2^(4:6),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatHjsmurfSPS,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfLR", finallengths = 2^(4:6),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatHjsmurfLR,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
suppressWarnings(ret <- computeStat(rnorm(10), family = "hjsmurfLR", filter = testfilter))
expect_identical(ret$maximum, -Inf)
expect_identical(ret$stat, numeric(0))
expect_identical(ret$lengths, integer(0))
})
test_that("arguments in ... are tested and work for family hjsmurf", {
testn <- 35L
testy <- rnorm(testn)
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4L, cutoff = 0.1), sr = 1e4)
expect_error(computeStat(testy, family = "hjsmurf", filter = testfilter, sd = 1))
expect_error(computeStat(testy, family = "hjsmurf", filter = testfilter, intervalsystem = "all"))
expect_error(computeStat(testy, family = "hjsmurf"))
expect_error(computeStat(testy, family = "hjsmurf", filter = unclass(testfilter)))
expect_error(computeStat(testy, family = "hjsmurfSPS", filter = testfilter, sd = 1))
expect_error(computeStat(testy, family = "hjsmurfSPS", filter = testfilter, intervalsystem = "all"))
expect_error(computeStat(testy, family = "hjsmurfSPS"))
expect_error(computeStat(testy, family = "hjsmurfSPS", filter = unclass(testfilter)))
expect_error(computeStat(testy, family = "hjsmurfLR", filter = testfilter, sd = 1))
expect_error(computeStat(testy, family = "hjsmurfLR", filter = testfilter, intervalsystem = "all"))
expect_error(computeStat(testy, family = "hjsmurfLR"))
expect_error(computeStat(testy, family = "hjsmurfLR", filter = unclass(testfilter)))
})
context("local tests statistics in computeStat")
testJump <- function(grid, time, data, filter, correlations, leftValue, rightValue) {
len <- length(data)
m <- min(len, length(correlations) - 1L)
if (len == 1) {
A <- matrix(correlations[1], 1, 1)
} else {
A <- matrix(0, len, len)
for (i in 1:(len - 1)) {
A[i, i] <- correlations[1]
A[i, i + 1:min(m, len - i)] <- correlations[2:min(m + 1, len - i + 1)]
A[i + 1:min(m, len - i), i] <- correlations[2:min(m + 1, len - i + 1)]
}
A[len, len] <- correlations[1]
}
costs <- numeric(length(grid))
for (i in seq(along = grid)) {
mu <- lowpassFilter::getConvolutionJump(time, grid[i], leftValue, rightValue, filter)
costs[i] <- sum((data - mu) * solve(A, data - mu))
}
grid[which.min(costs)]
}
statAll <- function(y, filter, fit, singleStat, lengths, add, ...) {
stat <- rep(-Inf, length(lengths))
y[add] <- NA
for (inLen in seq(along = lengths)) {
len <- lengths[inLen]
start <- fit$leftEnd[1] + filter$len - 1L
end <- fit$rightEnd[1] - len - filter$len + 1L
if (start <= end) {
for (li in start:end) {
ri <- li + len
obs <- y[(li + 1):(ri + filter$len - 1)]
time <- (li + 1):(ri + filter$len - 1) / filter$sr
newStat <- singleStat(obs = obs, time = time, filter = filter,
left = li / filter$sr, right = ri / filter$sr,
leftValue = fit$value[1], rightValue = fit$value[1],
leftVar = fit$var[1], rightVar = fit$var[1], cp = 0, ...)
if (!is.na(newStat)) {
stat[inLen] <- max(stat[inLen], newStat)
}
}
}
for (inSeg in seq(along = fit$leftEnd)[-1]) {
start <- max(fit$rightEnd[inSeg - 1L] - len - filter$len + 2L, start)
end <- min(fit$leftEnd[inSeg] + filter$len - 2L, fit$rightEnd[inSeg] - len - filter$len + 1L)
if (start <= end) {
for (li in start:end) {
ri <- li + len
obs <- y[(li + 1):(ri + filter$len - 1)]
time <- (li + 1):(ri + filter$len - 1) / filter$sr
newStat <- singleStat(obs = obs, time = time, filter = filter,
left = li / filter$sr, right = ri / filter$sr,
leftValue = fit$value[inSeg - 1L], rightValue = fit$value[inSeg],
leftVar = fit$var[inSeg - 1L], rightVar = fit$var[inSeg],
cp = (fit$leftEnd[inSeg] - 1L) / filter$sr, ...)
if (!is.na(newStat)) {
stat[inLen] <- max(stat[inLen], newStat)
}
}
}
start <- fit$leftEnd[inSeg] + filter$len - 1L
end <- fit$rightEnd[inSeg] - len - filter$len + 1L
if (start <= end) {
for (li in start:end) {
ri <- li + len
obs <- y[(li + 1):(ri + filter$len - 1)]
time <- (li + 1):(ri + filter$len - 1) / filter$sr
newStat <- singleStat(obs = obs, time = time, filter = filter,
left = li / filter$sr, right = ri / filter$sr,
leftValue = fit$value[inSeg], rightValue = fit$value[inSeg],
leftVar = fit$var[inSeg], rightVar = fit$var[inSeg], cp = 0, ...)
if (!is.na(newStat)) {
stat[inLen] <- max(stat[inLen], newStat)
}
}
}
}
}
stat
}
test_that("family LR works", {
testn <- 50L
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4, cutoff = 0.1), sr = 1e4)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
testfit <- stepblock(0, leftEnd = 0, rightEnd = testn / testfilter$sr, x0 = 0)
expect_error(computeStat(family = "LR", filter = testfilter, fit = testfit))
expect_error(computeStat(y = numeric(0), family = "LR", filter = testfilter, fit = testfit))
expect_error(computeStat(y = as.integer(testy), family = "LR", filter = testfilter, fit = testfit))
expect_error(computeStat(y = c(testy[-1], "s"), family = "LR", filter = testfilter, fit = testfit))
expect_error(computeStat(y = c(testy[-1], NA), family = "LR", filter = testfilter, fit = testfit))
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfit),
computeStat(testy, family = "LR", intervalSystem = "all", lengths = 1:20,
penalty = "none", nq = testn, output = "list", filter = testfilter, fit = testfit))
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR")
testcor <- testfilter$acf
testcor[1] <- 2
comparefit <- stepblock(stats::median(testy[11:39]), leftEnd = 1, rightEnd = c(testn), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = integer(0), sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_identical(computeStat(testy, family = "LR", filter = testfilter, lengths = c(1, 2, 4, 8, 16)),
computeStat(testy, family = "LR", intervalSystem = "dyaLen", filter = testfilter))
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR", lengths = c(1:3, 5, 25))
expect_identical(ret, computeStat(y = testy, filter = testfilter, family = "LR", lengths = c(1:3, 5, 25)))
testcor <- testfilter$acf
testcor[1] <- 2
comparefit <- stepblock(stats::median(testy[11:39]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = c(1:3, 5, 25), add = integer(0), sd = sdrobnorm(testy, lag = testfilter$len + 1L),
regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_warning(ret2 <- computeStat(y = testy, filter = testfilter, signal = testfit,
fit = testfit, family = "LR", lengths = c(1:3, 5, 25)))
expect_identical(ret, ret2)
expect_error(computeStat(y = testy, filter = testfilter, intervalSystem = "dyaPar",
fit = testfit, family = "LR", lengths = c(1, 4, 16)))
expect_identical(computeStat(y = testy, filter = testfilter, family = "LR", lengths = c(1:3, 5, 25),
output = "maximum"), ret$maximum)
expect_identical(computeStat(y = testy, filter = testfilter, family = "LR", lengths = c(1:3, 5, 25),
output = "vector"), ret$stat)
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR", lengths = c(1:3, 5, 25),
penalty = "sqrt", nq = 100L, output = "maximum")
expect_equal(ret, max(sqrt(2 * compare) - sqrt(2 * log(exp(1) * 100L / c(1:3, 5, 25)))))
suppressWarnings(ret <- computeStat(y = rnorm(20), filter = testfilter, family = "LR"))
expect_identical(ret$maximum, -Inf)
expect_identical(ret$stat, rep(-Inf, 20))
expect_identical(ret$lengths, 1:20)
testn <- 100L
testfit <- stepblock(c(0, 1), leftEnd = c(0, 50 / testfilter$sr),
rightEnd = c(50 / testfilter$sr, testn / testfilter$sr), x0 = 0)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR")
testcor <- testfilter$acf
testcor[1] <- 2
j <- as.integer(testJump(39:50 / testfilter$sr, 40:60 / testfilter$sr, testy[40:60], testfilter, testcor,
stats::median(testy[11:39]), stats::median(testy[61:89])) * testfilter$sr + 1e-6)
comparefit <- stepblock(c(stats::median(testy[11:39]), stats::median(testy[61:89])),
leftEnd = c(0, j), rightEnd = c(j, 100), x0 = 0)
comparefit <- stepblock(c(stats::median(testy[11:39]), stats::median(testy[61:89])),
leftEnd = c(1, j + 1), rightEnd = c(j, 100), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = integer(0), sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1, 0), leftEnd = c(0, 50 / testfilter$sr, 53 / testfilter$sr),
rightEnd = c(50 / testfilter$sr, 53 / testfilter$sr, testn / testfilter$sr), x0 = 0)
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR")
comparefit <- stepblock(c(stats::median(testy[11:39]), NA, stats::median(testy[64:89])),
leftEnd = c(1, 51, 54), rightEnd = c(50, 53, 100), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = 39:53, sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1, 0, 1, 0), leftEnd = c(0, 50:53 / testfilter$sr),
rightEnd = c(50:53 / testfilter$sr, testn / testfilter$sr), x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR"))
comparefit <- stepblock(c(stats::median(testy[11:39]), NA, stats::median(testy[64:89])),
leftEnd = c(1, 51, 54), rightEnd = c(50, 53, 100), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = 39:53, sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1, 0, 1), leftEnd = c(0, 25, 50, 75) / testfilter$sr,
rightEnd = c(25, 50, 75, testn) / testfilter$sr, x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR"))
expect_identical(ret$stat, rep(-Inf, 20))
testfit <- stepblock(c(0, 1), leftEnd = c(0, 20 / testfilter$sr),
rightEnd = c(20 / testfilter$sr, testn / testfilter$sr), x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR"))
comparefit <- stepblock(c(NA, stats::median(testy[31:89])),
leftEnd = c(1, 21), rightEnd = c(20, 100), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = 1:20, sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1), leftEnd = c(0, 80 / testfilter$sr),
rightEnd = c(80 / testfilter$sr, testn / testfilter$sr), x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR"))
comparefit <- stepblock(c(stats::median(testy[11:69]), NA),
leftEnd = c(1, 81), rightEnd = c(80, 100), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = 69:100, sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepR::stepblock(0, leftEnd = 1, rightEnd = 1 + testn / testfilter$sr, x0 = 1)
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit))
})
test_that("arguments in ... are tested and work for family LR", {
testn <- 50L
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4, cutoff = 0.1), sr = 1e4)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
testfit <- stepblock(0, leftEnd = 0, rightEnd = testn / testfilter$sr, x0 = 0)
expect_error(computeStat(testy, family = "LR", filter = unclass(testfilter), fit = testfit))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = unclass(testfit)))
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = list(fit = testfit)),
computeStat(testy, family = "LR", filter = testfilter, fit = testfit))
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfit),
computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
startTime = 0, thresholdLongSegment = 10L, localValue = stats::median,
regularization = 1, suppressWarningNoDeconvolution = FALSE, localList = NULL))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, startTime = NA))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, startTime = c(0, 1)))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, startTime = 1))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, startTime = -1))
testfitStartTime <- stepblock(0, leftEnd = -1, rightEnd = testn / testfilter$sr - 1, x0 = -1)
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfitStartTime, startTime = -1),
computeStat(testy, family = "LR", filter = testfilter, fit = testfit, startTime = 0))
testfitStartTime <- stepblock(0, leftEnd = 0.001, rightEnd = testn / testfilter$sr + 0.001, x0 = 0.001)
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfitStartTime, startTime = 0.001),
computeStat(testy, family = "LR", filter = testfilter, fit = testfit, startTime = 0))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, thresholdLongSegment = NA))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, thresholdLongSegment = -1L))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
thresholdLongSegment = c(10L, 23L)))
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, thresholdLongSegment = 10.5),
computeStat(testy, family = "LR", filter = testfilter, fit = testfit))
expect_warning(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, thresholdLongSegment = 30))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, localValue = 1))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, localValue = function() 1))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, localValue = function(a) NA))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, localValue = function(a) c(1, 2)))
ret <- computeStat(testy, family = "LR", filter = testfilter, fit = testfit, localValue = mean)
testcor <- testfilter$acf
testcor[1] <- 2
comparefit <- stepblock(mean(testy[11:39]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = integer(0), sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, regularization = NULL))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, regularization = c(1, NA)))
ret <- computeStat(testy, family = "LR", filter = testfilter, fit = testfit, regularization = 2)
testcor <- testfilter$acf
testcor[1] <- 3
comparefit <- stepblock(stats::median(testy[11:39]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = integer(0), sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
ret <- computeStat(testy, family = "LR", filter = testfilter, fit = testfit, regularization = c(2, 1))
testcor <- testfilter$acf
testcor[1] <- 3
testcor[2] <- testcor[2] + 1
comparefit <- stepblock(stats::median(testy[11:39]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = integer(0), sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, correlations = "s"))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, correlations = c(Inf, 3)))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, correlations = c(1, 0)))
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
correlations = testcor), ret)
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = 1))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = as.logical(NA)))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = c(TRUE, TRUE)))
testfit <- stepblock(c(0, 1, 2, 3), leftEnd = c(0, 40, 41, 42) / testfilter$sr,
rightEnd = c(40, 41, 42, testn) / testfilter$sr, x0 = 0)
expect_warning(ret <- computeStat(testy, family = "LR", filter = testfilter, fit = testfit))
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = TRUE), ret)
})
test_that("family 2Param works (short version)", {
testn <- 70L
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4, cutoff = 0.1), sr = 1e4)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
testfit <- stepblock(0, leftEnd = 0, rightEnd = testn / testfilter$sr, x0 = 0)
expect_error(computeStat(family = "2Param", filter = testfilter, fit = testfit))
expect_error(computeStat(y = numeric(0), family = "2Param", filter = testfilter, fit = testfit))
expect_error(computeStat(y = as.integer(testy), family = "2Param", filter = testfilter, fit = testfit))
expect_error(computeStat(y = c(testy[-1], "s"), family = "2Param", filter = testfilter, fit = testfit))
expect_error(computeStat(y = c(testy[-1], NA), family = "2Param", filter = testfilter, fit = testfit))
# this takes very long
# expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit),
# computeStat(testy, family = "2Param", intervalSystem = "all", lengths = 1:65,
# penalty = "none", nq = testn, output = "list", filter = testfilter, fit = testfit))
testlengths = c(1:3, 15, 64:65)
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param", lengths = testlengths)
comparefit <- stepblock(stats::median(testy[11:59]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
comparefit$var <- sdrobnorm(testy[11:59], lag = testfilter$len + 1L)^2
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = testlengths, add = integer(0), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
})
test_that("family 2Param works (long version)", {
testthat::skip_on_cran()
testn <- 70L
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4, cutoff = 0.1), sr = 1e4)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
testfit <- stepblock(0, leftEnd = 0, rightEnd = testn / testfilter$sr, x0 = 0)
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, lengths = c(1, 2, 4, 8, 16, 32, 64)),
computeStat(testy, family = "2Param", intervalSystem = "dyaLen", filter = testfilter))
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param", lengths = c(1:3, 5, 25))
expect_identical(ret, computeStat(y = testy, filter = testfilter, family = "2Param", lengths = c(1:3, 5, 25)))
testcor <- testfilter$acf
testcor[1] <- 2
comparefit <- stepblock(stats::median(testy[11:59]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
comparefit$var <- sdrobnorm(testy[11:59], lag = testfilter$len + 1L)^2
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(1:3, 5, 25), add = integer(0), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_warning(ret2 <- computeStat(y = testy, filter = testfilter, signal = testfit,
fit = testfit, family = "2Param", lengths = c(1:3, 5, 25)))
expect_identical(ret, ret2)
expect_error(computeStat(y = testy, filter = testfilter, intervalSystem = "dyaPar",
fit = testfit, family = "2Param", lengths = c(1, 4, 16)))
expect_identical(computeStat(y = testy, filter = testfilter, family = "2Param", lengths = c(1:3, 5, 25),
output = "maximum"), ret$maximum)
expect_identical(computeStat(y = testy, filter = testfilter, family = "2Param", lengths = c(1:3, 5, 25),
output = "vector"), ret$stat)
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param", lengths = c(1:3, 5, 25),
penalty = "sqrt", nq = 100L, output = "maximum")
expect_equal(ret, max(sqrt(2 * compare) - sqrt(2 * log(exp(1) * 100L / c(1:3, 5, 25)))))
suppressWarnings(ret <- computeStat(y = rnorm(20), filter = testfilter, family = "2Param"))
expect_identical(ret$maximum, -Inf)
expect_identical(ret$stat, rep(-Inf, 20))
expect_identical(ret$lengths, 1:20)
testn <- 100L
testfit <- stepblock(c(0, 1), leftEnd = c(0, 50 / testfilter$sr),
rightEnd = c(50 / testfilter$sr, testn / testfilter$sr), x0 = 0)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param", lengths = c(1:3, 5, 25))
testcor <- testfilter$acf
testcor[1] <- 2
j <- as.integer(testJump(39:50 / testfilter$sr, 40:60 / testfilter$sr, testy[40:60], testfilter, testcor,
stats::median(testy[11:39]), stats::median(testy[61:89])) * testfilter$sr + 1e-6)
comparefit <- stepblock(c(stats::median(testy[11:39]), stats::median(testy[61:89])),
leftEnd = c(1, j + 1), rightEnd = c(j, 100), x0 = 0)
comparefit$var <- c(sdrobnorm(testy[11:39], lag = testfilter$len + 1L)^2,
sdrobnorm(testy[61:89], lag = testfilter$len + 1L)^2)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(1:3, 5, 25), add = integer(0), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-4)
testfit <- stepblock(c(0, 1, 0), leftEnd = c(0, 50 / testfilter$sr, 53 / testfilter$sr),
rightEnd = c(50 / testfilter$sr, 53 / testfilter$sr, testn / testfilter$sr), x0 = 0)
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param", lengths = c(1:2, 5, 13))
comparefit <- stepblock(c(stats::median(testy[11:39]), NA, stats::median(testy[64:89])),
leftEnd = c(1, 51, 54), rightEnd = c(50, 53, 100), x0 = 0)
comparefit$var <- c(sdrobnorm(testy[11:39], lag = testfilter$len + 1L)^2, NA,
sdrobnorm(testy[64:89], lag = testfilter$len + 1L)^2)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(1:2, 5, 13), add = 39:53, regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1, 0, 1, 0), leftEnd = c(0, 50:53 / testfilter$sr),
rightEnd = c(50:53 / testfilter$sr, testn / testfilter$sr), x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit,
family = "2Param", lengths = c(1:3, 5, 15)))
comparefit <- stepblock(c(stats::median(testy[11:39]), NA, stats::median(testy[64:89])),
leftEnd = c(1, 51, 54), rightEnd = c(50, 53, 100), x0 = 0)
comparefit$var <- c(sdrobnorm(testy[11:39], lag = testfilter$len + 1L)^2, NA,
sdrobnorm(testy[64:89], lag = testfilter$len + 1L)^2)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(1:3, 5, 15), add = 39:53, regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1, 0, 1), leftEnd = c(0, 25, 50, 75) / testfilter$sr,
rightEnd = c(25, 50, 75, testn) / testfilter$sr, x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param",
lengths = c(1:3, 5, 25)))
expect_identical(ret$stat, rep(-Inf, 5))
testfit <- stepblock(c(0, 1), leftEnd = c(0, 20 / testfilter$sr),
rightEnd = c(20 / testfilter$sr, testn / testfilter$sr), x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param",
lengths = c(7:9, 12)))
comparefit <- stepblock(c(NA, stats::median(testy[31:89])),
leftEnd = c(1, 21), rightEnd = c(20, 100), x0 = 0)
comparefit$var <- c(NA, sdrobnorm(testy[31:89], lag = testfilter$len + 1L)^2)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(7:9, 12), add = 1:20, regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1), leftEnd = c(0, 80 / testfilter$sr),
rightEnd = c(80 / testfilter$sr, testn / testfilter$sr), x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param",
lengths = c(11:13)))
comparefit <- stepblock(c(stats::median(testy[11:69]), NA),
leftEnd = c(1, 81), rightEnd = c(80, 100), x0 = 0)
comparefit$var <- c(sdrobnorm(testy[11:69], lag = testfilter$len + 1L)^2, NA)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(11:13), add = 69:100, regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepR::stepblock(0, leftEnd = 1, rightEnd = 1 + testn / testfilter$sr, x0 = 1)
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = testlengths))
})
test_that("arguments in ... are tested and work for family 2Param", {
testthat::skip_on_cran()
testn <- 50L
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4, cutoff = 0.1), sr = 1e4)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
testfit <- stepblock(0, leftEnd = 0, rightEnd = testn / testfilter$sr, x0 = 0)
expect_error(computeStat(testy, family = "2Param", filter = unclass(testfilter), fit = testfit))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = unclass(testfit)))
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = list(fit = testfit),
lengths = c(7:9, 12)),
computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = c(7:9, 12)))
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = c(7:9, 12)),
computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = c(7:9, 12),
startTime = 0, thresholdLongSegment = 10L, localValue = stats::median,
localVar = function(data) sdrobnorm(data, lag = testfilter$len + 1L)^2,
regularization = 1, suppressWarningNoDeconvolution = FALSE, localList = NULL))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, startTime = NA))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, startTime = c(0, 1)))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
startTime = (testn + 1) / testfilter$sr))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, startTime = -1 / testfilter$sr))
testfitStartTime <- stepblock(0, leftEnd = -1, rightEnd = testn / testfilter$sr - 1, x0 = -1)
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfitStartTime, startTime = -1),
computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, startTime = 0))
testfitStartTime <- stepblock(0, leftEnd = 0.001, rightEnd = testn / testfilter$sr + 0.001, x0 = 0.001)
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfitStartTime, startTime = 0.001),
computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, startTime = 0))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, thresholdLongSegment = NA))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, thresholdLongSegment = -1L))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
thresholdLongSegment = c(10L, 23L)))
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
thresholdLongSegment = 25.5, lengths = c(7:9, 12, 37)),
computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = c(7:9, 12, 37)))
expect_warning(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, thresholdLongSegment = 30,
lengths = c(7:9, 12)))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localValue = 1))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localValue = function() 1))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localValue = function(a) NA))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
localValue = function(a) c(1, 2)))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localVar = 1))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localVar = function() 1))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localVar = function(a) NA))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
localVar = function(a) c(1, 2)))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localVar = function(a) -1))
ret <- computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localValue = mean,
localVar = function(data) 1, lengths = c(7:9, 12))
testcor <- testfilter$acf
testcor[1] <- 2
comparefit <- stepblock(mean(testy[11:39]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
comparefit$var <- 1
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(7:9, 12), add = integer(0), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, regularization = NULL))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, regularization = c(1, NA)))
ret <- computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, regularization = 2,
lengths = c(7:9, 12))
testcor <- testfilter$acf
testcor[1] <- 3
comparefit <- stepblock(stats::median(testy[11:39]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
comparefit$var <- sdrobnorm(testy[11:39], lag = 12)^2
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(7:9, 12), add = integer(0), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, correlations = "s"))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, correlations = c(Inf, 3)))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, correlations = c(1, 0)))
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
correlations = testcor, lengths = c(7:9, 12)), ret)
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = 1))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = as.logical(NA)))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = c(TRUE, TRUE)))
testfit <- stepblock(c(0, 1, 2, 3), leftEnd = c(0, 47, 48, 49) / testfilter$sr,
rightEnd = c(47, 48, 49, testn) / testfilter$sr, x0 = 0)
expect_warning(ret <- computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = c(7:9, 12)))
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = c(7:9, 12),
suppressWarningNoDeconvolution = TRUE), ret)
})
Try the stepR package in your browser
Any scripts or data that you put into this service are public.
stepR documentation built on Nov. 14, 2023, 1:09 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
context("computeStat")
source(system.file("tests/comparisons/indices.R", package = "stepR"))
source(system.file("tests/comparisons/singleStat.R", package = "stepR"))
statAll <- function(y, left, right, value, indices, singleStat, lengths, ...) {
indices <- indices(length(y), lengths = lengths, ...)
stat <- rep(-Inf, length(y))
for (i in 1:length(indices$li)) {
index <- sum(left <= indices$li[i])
if (index == length(right) - sum(right >= indices$ri[i]) + 1) {
stat[indices$ri[i] - indices$li[i] + 1] <- max(stat[indices$ri[i] - indices$li[i] + 1],
singleStat(y, value[index],
indices$li[i], indices$ri[i], ...))
}
}
stat
}
test <- function(testy = NULL, testsignal = 0, left = NULL, right = NULL, value = NULL,
testfamily = NULL, testintervalSystem = NULL, testlengths = NULL,
finallengths = NULL, testnq = length(testy), defaultPenalty = NULL, indices = NULL,
singleStat = NULL, tolerance = 1e-12, shift = 0, ...) {
# none
compare <- statAll(testy, left = left, right = right, value = value, indices = indices,
singleStat = singleStat, lengths = finallengths, ...)[finallengths]
expect_equal(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "none",
nq = testnq, output = "maximum", ...),
max(compare), info = "none", tolerance = tolerance)
expect_equal(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "none",
nq = testnq, output = "vector", ...),
compare, info = "none", tolerance = tolerance)
ret <- computeStat(testy, signal = testsignal, family = testfamily, intervalSystem = testintervalSystem,
lengths = testlengths, penalty = "none", nq = testnq, output = "list", ...)
expect_equal(ret, list(maximum = max(compare), stat = compare, lengths = finallengths),
info = "none", tolerance = tolerance)
expect_identical(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "none",
nq = testnq, ...), ret, info = "none")
# sqrt
compare <- statAll(testy, left = left, right = right, value = value, indices = indices,
singleStat = singleStat, lengths = finallengths, ...)[finallengths]
finite <- compare != -Inf
compare[finite] <- sqrt(2 * compare[finite]) - sqrt(2 * log(exp(1) * testnq / (finallengths[finite] + shift)))
expect_equal(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "sqrt",
nq = testnq, output = "maximum", ...),
max(compare), info = "sqrt", tolerance = tolerance)
expect_equal(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "sqrt",
nq = testnq, output = "vector", ...),
compare, info = "sqrt", tolerance = tolerance)
ret <- computeStat(testy, signal = testsignal, family = testfamily, intervalSystem = testintervalSystem,
lengths = testlengths, penalty = "sqrt", nq = testnq, output = "list", ...)
expect_equal(ret, list(maximum = max(compare), stat = compare, lengths = finallengths),
info = "sqrt", tolerance = tolerance)
expect_identical(computeStat(testy, signal = testsignal, family = testfamily, penalty = "sqrt",
intervalSystem = testintervalSystem, lengths = testlengths, nq = testnq, ...),
ret, info = "sqrt")
# log
compare <- statAll(testy, left = left, right = right, value = value, indices = indices,
singleStat = singleStat, lengths = finallengths, ...)[finallengths] -
log(exp(1) * testnq / (finallengths + shift))
expect_equal(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "log",
nq = testnq, output = "maximum", ...),
max(compare), info = "log", tolerance = tolerance)
expect_equal(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "log",
nq = testnq, output = "vector", ...),
compare, info = "log", tolerance = tolerance)
ret <- computeStat(testy, signal = testsignal, family = testfamily, intervalSystem = testintervalSystem,
lengths = testlengths, penalty = "log", nq = testnq, output = "list", ...)
expect_equal(ret, list(maximum = max(compare), stat = compare, lengths = finallengths),
info = "log", tolerance = tolerance)
expect_identical(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths, penalty = "log",
nq = testnq, ...), ret, info = "log")
# default penalty
expect_identical(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "maximum", nq = testnq, ...),
computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "maximum", nq = testnq, penalty = defaultPenalty, ...))
expect_identical(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "vector", nq = testnq, ...),
computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "vector", nq = testnq, penalty = defaultPenalty, ...))
expect_identical(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "list", nq = testnq, ...),
computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "list", nq = testnq, penalty = defaultPenalty, ...))
expect_identical(computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
nq = testnq, ...),
computeStat(testy, signal = testsignal, family = testfamily,
intervalSystem = testintervalSystem, lengths = testlengths,
output = "list", nq = testnq, penalty = defaultPenalty, ...))
}
test_that("argument y is tested", {
testn <- 100L
testy <- rnorm(testn)
expect_error(computeStat())
expect_error(computeStat(numeric(0)))
expect_identical(computeStat(testy), computeStat(testy, family = "gauss", intervalSystem = "all",
lengths = 1:testn, penalty = "sqrt", nq = testn,
output = "list", sd = sdrobnorm(testy)))
expect_error(computeStat(as.integer(testy)))
expect_error(computeStat(c(testy, "s")))
expect_error(computeStat(c(rnorm(10), NA)))
test(testy, left = 1L, right = testn, value = 0, finallengths = 1:testn,
indices = indicesAll, singleStat = singleStatGauss, sd = 1, defaultPenalty = "sqrt")
})
test_that("argument signal is tested and works in the default case", {
testn <- 34L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 12L), rightIndex = c(11L, 34L), value = c(0, 1))
expect_error(computeStat(testy, signal = NULL))
expect_error(computeStat(testy, signal = "s"))
expect_identical(computeStat(testy, signal = 0L), computeStat(testy, signal = 0))
expect_error(computeStat(testy, signal = c(1, 2)))
expect_error(computeStat(testy, signal = NA))
expect_error(computeStat(testy, signal = Inf))
expect_identical(computeStat(testy, signal = 1),
computeStat(testy, signal = list(leftIndex = 1L, rightIndex = 34L, value = 1)))
expect_equal(computeStat(testy, signal = 0),
computeStat(testy, signal = list(leftIndex = 1L, rightIndex = 34L, value = 0)),
tolerance = 1e-14)
expect_error(computeStat(testy, signal = list()))
expect_error(computeStat(testy, signal = list(leftIndex = 1L,
rightIndex = 34L, value = NULL)))
expect_error(computeStat(testy, signal = list(leftIndex = 1L,
rightIndex = c(17L, 34L), value = numeric(0))))
expect_error(computeStat(testy, signal = list(leftIndex = c(1L, 18L),
rightIndex = c(17L, 34L), value = numeric(0))))
expect_error(computeStat(testy, signal = list(leftIndex = c(1L, Inf),
rightIndex = c(17L, 34L), value = c(1, 2))))
expect_error(computeStat(testy, signal = list(leftIndex = c(1L, 18L),
rightIndex = c(17L, 34L), value = c(1, NA))))
expect_identical(computeStat(testy, signal = list(leftIndex = 1L, rightIndex = 34L, value = 1L)),
computeStat(testy, signal = list(leftIndex = 1L, rightIndex = 34L, value = 1)))
expect_identical(computeStat(testy, signal = list(leftIndex = 1, rightIndex = 34, value = 1)),
computeStat(testy, signal = list(leftIndex = 1L, rightIndex = 34L, value = 1)))
expect_error(computeStat(testy, signal = list(leftIndex = 2L, rightIndex = 35L, value = 1)))
expect_error(computeStat(testy, signal = list(leftIndex = c(1L, 18L),
rightIndex = c(17L, 35L), value = c(1, 2))))
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", finallengths = 1:testn,
indices = indicesAll, singleStat = singleStatGauss, sd = 1.23,
defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
finallengths = 1:testn, indices = indicesAll, singleStat = singleStatGauss,
sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "gauss", finallengths = 1:testn,
indices = indicesAll, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
testsignal <- list(leftIndex = c(1L, 12L), rightIndex = c(11L, 34L), value = c(0, 1))
testsignal2 <- list(lefxx = "s", rtg = 1:10, leftIndex = c(1L, 12L), rightIndex = c(11L, 34L), value = c(0, 1))
expect_identical(computeStat(testy, signal = testsignal2), computeStat(testy, signal = testsignal))
teststepfit <- stepfit(23, family = "gauss", value = c(0, 1), param = 2, leftEnd = c(1L, 12L) / 34,
rightEnd = c(11L, 34L) / 34, x0 = -1, leftIndex = c(1L, 12L), rightIndex = c(11L, 34L))
expect_identical(computeStat(testy, signal = teststepfit), computeStat(testy, signal = testsignal))
})
test_that("argument family is tested and works in the default case", { # other families below
testn <- 34L
testy <- rnorm(testn)
expect_error(computeStat(testy, family = ""))
expect_error(computeStat(testy, family = "bisom"))
expect_error(computeStat(testy, family = c("gauss", "hsmuce")))
expect_identical(computeStat(testy, signal = 0), computeStat(testy, signal = 0, family = "gauss"))
})
test_that("argument intervalSystem is tested and works", {
testn <- 34L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 12L), rightIndex = c(11L, 34L), value = c(0, 1))
expect_error(computeStat(testy, intervalSystem = ""))
expect_error(computeStat(testy, intervalSystem = "dya"))
expect_error(computeStat(testy, intervalSystem = "dyalen"))
expect_error(computeStat(testy, intervalSystem = "dyapar"))
expect_error(computeStat(testy, intervalSystem = c("dyaPar", "all")))
expect_identical(computeStat(testy, signal = 0), computeStat(testy, signal = 0, intervalSystem = "all"))
expect_identical(computeStat(rep(testy, 30), signal = 0),
computeStat(rep(testy, 30), signal = 0, intervalSystem = "dyaLen"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", finallengths = 2^(0:5),
testintervalSystem = "dyaLen", indices = indicesDyaLen, singleStat = singleStatGauss,
sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
finallengths = 2^(0:5), testintervalSystem = "dyaLen",
indices = indicesDyaLen, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "gauss", finallengths = 2^(0:5), testintervalSystem = "dyaLen",
indices = indicesDyaLen, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", finallengths = 2^(0:5),
testintervalSystem = "dyaPar", indices = indicesDyaPar, singleStat = singleStatGauss,
sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
finallengths = 2^(0:5), testintervalSystem = "dyaPar",
indices = indicesDyaPar, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "gauss", finallengths = 2^(0:5), testintervalSystem = "dyaPar",
indices = indicesDyaPar, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
})
test_that("argument lengths is tested and works", {
testn <- 45L
testy <- c(rnorm(20, 1, 0.23), rnorm(testn - 20, -1, 0.34))
testsignal <- list(leftIndex = c(1L, 23L), rightIndex = c(22L, 45L), value = c(0, -1))
expect_error(computeStat(testy, lengths = "s"))
expect_error(computeStat(testy, lengths = c(1:10, NA)))
expect_error(computeStat(testy, lengths = c(1:10, Inf)))
expect_error(computeStat(testy, lengths = 0:10))
expect_error(computeStat(testy, lengths = -1L))
expect_error(computeStat(testy, lengths = c(1L, 46L)))
expect_error(computeStat(testy, intervalSystem = "dyaLen", lengths = 3L))
expect_error(computeStat(testy, intervalSystem = "dyaLen", lengths = 64L))
expect_error(computeStat(testy, intervalSystem = "dyaPar", lengths = 3L))
expect_error(computeStat(testy, intervalSystem = "dyaPar", lengths = 64L))
expect_warning(ret <- computeStat(testy, lengths = c(1:10, 10)))
expect_identical(ret, computeStat(testy, lengths = c(1:10)))
expect_identical(computeStat(testy, lengths = c(10:1)),
computeStat(testy, lengths = c(1:10)))
expect_identical(computeStat(testy, lengths = c(1:10 + 0.5)),
computeStat(testy, lengths = c(1:10)))
expect_equal(computeStat(testy, lengths = 2^(0:5)), computeStat(testy, intervalSystem = "dyaLen"))
expect_equal(computeStat(testy, lengths = 2^(3:4)),
computeStat(testy, intervalSystem = "dyaLen", lengths = 2^(3:4)))
testlengths <- c(1, 3:5, 10:23)
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", testlengths = testlengths,
finallengths = testlengths, indices = indicesAllLengths,
singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
testlengths = testlengths, finallengths = testlengths,
indices = indicesAllLengths, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 23L), right = c(22L, 45L), value = c(0, -1),
testfamily = "gauss", testlengths = testlengths, finallengths = testlengths,
indices = indicesAllLengths, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
testlengths <- c(1, 4, 32)
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", testlengths = testlengths,
finallengths = testlengths, indices = indicesDyaLenLengths,
singleStat = singleStatGauss, sd = 1.23, testintervalSystem = "dyaLen", defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaLenLengths, singleStat = singleStatGauss, sd = 1.23,
testintervalSystem = "dyaLen", defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 23L), right = c(22L, 45L), value = c(0, -1),
testfamily = "gauss", testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaLenLengths, singleStat = singleStatGauss, sd = 1.23,
testintervalSystem = "dyaLen", defaultPenalty = "sqrt")
testlengths <- c(2, 4, 16)
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", testlengths = testlengths,
finallengths = testlengths, indices = indicesDyaParLengths,
singleStat = singleStatGauss, sd = 1.23, testintervalSystem = "dyaPar", defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaParLengths, singleStat = singleStatGauss, sd = 1.23,
testintervalSystem = "dyaPar", defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 23L), right = c(22L, 45L), value = c(0, -1),
testfamily = "gauss", testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaParLengths, singleStat = singleStatGauss, sd = 1.23,
testintervalSystem = "dyaPar", defaultPenalty = "sqrt")
suppressWarnings(ret <- computeStat(testy, lengths = integer(0)))
expect_identical(ret$maximum, -Inf)
expect_identical(ret$stat, numeric(0))
expect_identical(ret$lengths, integer(0))
})
test_that("argument penalty is tested and works in the default case", {
testn <- 34L
testy <- rnorm(testn)
expect_error(computeStat(testy, penalty = ""))
expect_error(computeStat(testy, penalty = c("gauss")))
expect_error(computeStat(testy, penalty = c("sqrt", "log")))
expect_identical(computeStat(testy, signal = 0), computeStat(testy, signal = 0, penalty = "sqrt"))
})
test_that("argument nq is tested and works", {
testn <- 34L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 12L), rightIndex = c(11L, 34L), value = c(0, 1))
expect_error(computeStat(testy, nq = "s"))
expect_error(computeStat(testy, nq = c(1L, 2L)))
expect_error(computeStat(testy, nq = NA))
expect_error(computeStat(testy, nq = Inf))
expect_error(computeStat(testy, nq = 0L))
expect_error(computeStat(testy, nq = -1L))
expect_error(computeStat(testy, nq = 33L))
expect_error(computeStat(testy, intervalSystem = "dyaPar", lengths = 64L, nq = 64L))
expect_identical(computeStat(testy), computeStat(testy, nq = testn))
expect_identical(computeStat(testy, nq = 100), computeStat(testy, nq = 100L))
expect_identical(computeStat(testy, nq = 100.5), computeStat(testy, nq = 100L))
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", finallengths = 1:testn,
testnq = 100L, indices = indicesAll, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
finallengths = 1:testn, testnq = 64L, indices = indicesAll, singleStat = singleStatGauss,
sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "gauss", finallengths = 1:testn, testnq = 55L,
indices = indicesAll, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
testlengths <- c(1, 3:5, 10:23)
test(testy, left = 1L, right = testn, value = 0, testfamily = "gauss", testlengths = testlengths,
finallengths = testlengths, testnq = 100L, indices = indicesAllLengths,
singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "gauss",
testlengths = testlengths, finallengths = testlengths, testnq = 64L,
indices = indicesAllLengths, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "gauss", testlengths = testlengths, finallengths = testlengths, testnq = 45L,
indices = indicesAllLengths, singleStat = singleStatGauss, sd = 1.23, defaultPenalty = "sqrt")
})
test_that("argument output is tested and works in the default case", {
testn <- 34L
testy <- rnorm(testn)
expect_error(computeStat(testy, output = 1))
expect_error(computeStat(testy, output = "mu"))
expect_identical(computeStat(testy, signal = 0), computeStat(testy, signal = 0, output = "l"))
})
test_that("... is tested and works", {
testn <- 34L
testy <- rnorm(testn)
expect_error(computeStat(testy, std = 1))
expect_error(computeStat(testy, familty = "hsmuce"))
expect_error(computeStat(testy, covariances = c(1, 0.6)))
expect_error(computeStat(testy, sd = "s"))
expect_error(computeStat(testy, sd = c(1, 2)))
expect_error(computeStat(testy, sd = NA))
expect_error(computeStat(c(1, 2)))
expect_error(computeStat(testy, sd = Inf))
expect_error(computeStat(testy, sd = 0))
expect_error(computeStat(testy, sd = -0.1))
expect_identical(computeStat(testy), computeStat(testy, sd = sdrobnorm(testy)))
expect_identical(computeStat(testy, sd = 1L), computeStat(testy, sd = 1))
})
test_that("family hsmuce works", {
testn <- 100L
testy <- rnorm(testn)
expect_error(computeStat(family = "hsmuce"))
expect_error(computeStat(numeric(0), family = "hsmuce"))
expect_identical(computeStat(testy, family = "hsmuce"),
computeStat(testy, family = "hsmuce", intervalSystem = "dyaPar", lengths = 2^(1:6),
penalty = "none", nq = testn, output = "list"))
expect_error(computeStat(as.integer(testy), family = "hsmuce"))
expect_error(computeStat(c(testy, "s"), family = "hsmuce"))
expect_error(computeStat(c(rnorm(10), NA), family = "hsmuce"))
expect_error(computeStat(c(rnorm(10), Inf), family = "hsmuce"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", finallengths = 2^(1:6),
indices = indicesDyaPar, singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
testn <- 34L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 12L), rightIndex = c(11L, 34L), value = c(0, 1))
expect_equal(computeStat(testy, signal = 0, family = "hsmuce"),
computeStat(testy, signal = list(leftIndex = 1L, rightIndex = 34L, value = 0),
family = "hsmuce"), tolerance = 1e-6)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", finallengths = 2^(1:5),
indices = indicesDyaPar, singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hsmuce",
finallengths = 2^(1:5), indices = indicesDyaPar, singleStat = singleStatHsmuce,
defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "hsmuce", finallengths = 2^(1:5), indices = indicesDyaPar, singleStat = singleStatHsmuce,
defaultPenalty = "none", tolerance = 1e-6)
expect_identical(computeStat(testy, family = "hsm"), computeStat(testy, family = "hsmuce"))
expect_identical(computeStat(testy, signal = 0, family = "hsmuce"),
computeStat(testy, signal = 0, family = "hsmuce", intervalSystem = "dyaPar"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", finallengths = 2:testn,
testintervalSystem = "all", indices = indicesAll, singleStat = singleStatHsmuce,
defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hsmuce",
finallengths = 2:testn, testintervalSystem = "all", indices = indicesAll, singleStat = singleStatHsmuce,
defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "hsmuce", finallengths = 2:testn, testintervalSystem = "all",
indices = indicesAll, singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", finallengths = 2^(1:5),
testintervalSystem = "dyaLen", indices = indicesDyaLen, singleStat = singleStatHsmuce,
defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hsmuce",
finallengths = 2^(1:5), testintervalSystem = "dyaLen", indices = indicesDyaLen,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, 34L), value = c(0, 1),
testfamily = "hsmuce", finallengths = 2^(1:5), testintervalSystem = "dyaLen", indices = indicesDyaLen,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
testn <- 45L
testy <- c(rnorm(20, 1, 0.23), rnorm(testn - 20, -1, 0.34))
testsignal <- list(leftIndex = c(1L, 23L), rightIndex = c(22L, 45L), value = c(0, -1))
expect_error(computeStat(testy, family = "hsmuce", lengths = 1:3))
expect_error(computeStat(testy, family = "hsmuce", intervalSystem = "all", lengths = 1:45))
expect_error(computeStat(testy, family = "hsmuce", intervalSystem = "dyaLen", lengths = 1:2))
testlengths <- c(2, 6:10, 23:45)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", testintervalSystem = "all",
testlengths = testlengths, finallengths = testlengths, indices = indicesAllLengths,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hsmuce",
testintervalSystem = "all", testlengths = testlengths, finallengths = testlengths,
indices = indicesAllLengths, singleStat = singleStatHsmuce, defaultPenalty = "none",
tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 23L), right = c(22L, 45L), value = c(0, -1),
testfamily = "hsmuce", testintervalSystem = "all", testlengths = testlengths,
finallengths = testlengths, indices = indicesAllLengths,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
testlengths <- c(2, 4, 32)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", testlengths = testlengths,
finallengths = testlengths, indices = indicesDyaLenLengths, singleStat = singleStatHsmuce,
defaultPenalty = "none", tolerance = 1e-6, testintervalSystem = "dyaLen")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hsmuce",
testlengths = testlengths, finallengths = testlengths, indices = indicesDyaLenLengths,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6, testintervalSystem = "dyaLen")
test(testy, testsignal = testsignal, left = c(1L, 23L), right = c(22L, 45L), value = c(0, -1),
testfamily = "hsmuce", testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaLenLengths, singleStat = singleStatHsmuce, defaultPenalty = "none",
tolerance = 1e-6, testintervalSystem = "dyaLen")
testlengths <- c(4, 8, 16)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", testlengths = testlengths,
finallengths = testlengths, indices = indicesDyaParLengths,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hsmuce",
testlengths = testlengths, finallengths = testlengths, indices = indicesDyaParLengths,
singleStat = singleStatHsmuce, defaultPenalty = "none", tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 23L), right = c(22L, 45L), value = c(0, -1),
testfamily = "hsmuce", testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaParLengths, singleStat = singleStatHsmuce, defaultPenalty = "none",
tolerance = 1e-6)
expect_identical(computeStat(testy, signal = 0, family = "hsmuce"),
computeStat(testy, signal = 0, family = "hsmuce", penalty = "none"))
expect_identical(computeStat(testy, signal = 0, family = "hsmuce", penalty = "weights"),
computeStat(testy, signal = 0, family = "hsmuce", penalty = "none"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "hsmuce", finallengths = 2^(1:5),
testnq = 100L, indices = indicesDyaPar, singleStat = singleStatHsmuce, defaultPenalty = "none",
tolerance = 1e-6)
expect_error(computeStat(testy, family = "hsmuce", sd = 1))
expect_error(computeStat(testy, family = "hsmuce", intervalsystem = "all"))
suppressWarnings(ret <- computeStat(c(1), family = "hsmuce"))
expect_identical(ret$maximum, -Inf)
expect_identical(ret$stat, numeric(0))
expect_identical(ret$lengths, integer(0))
})
test_that("family mDependentPS works", {
testn <- 30L
testy <- rnorm(testn)
testCovariances <- seq(1, 0.2, -0.2)
expect_error(computeStat(family = "mDependentPS", covariances = testCovariances))
expect_error(computeStat(numeric(0), family = "mDependentPS", covariances = testCovariances))
expect_identical(computeStat(testy, family = "mDependentPS", covariances = testCovariances),
computeStat(testy, family = "mDependentPS", intervalSystem = "dyaLen", lengths = 2^(0:4),
penalty = "sqrt", nq = testn, output = "list", covariances = testCovariances))
expect_error(computeStat(as.integer(testy), family = "mDependentPS", covariances = testCovariances))
expect_error(computeStat(c(testy, "s"), family = "mDependentPS", covariances = testCovariances))
expect_error(computeStat(c(rnorm(10), NA), family = "mDependentPS", covariances = testCovariances))
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", finallengths = 2^(0:4),
indices = indicesDyaLen, singleStat = singleStatmDependentPS,
covariances = testCovariances, defaultPenalty = "sqrt")
testn <- 18L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 12L), rightIndex = c(11L, 18L), value = c(0, 1))
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", finallengths = 2^(0:4),
indices = indicesDyaLen, singleStat = singleStatmDependentPS,
covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "mDependentPS",
finallengths = 2^(0:4), indices = indicesDyaLen, singleStat = singleStatmDependentPS,
covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, testn), value = c(0, 1),
testfamily = "mDependentPS", finallengths = 2^(0:4), indices = indicesDyaLen,
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
expect_identical(computeStat(testy, signal = 0, family = "mDependentPS", covariances = testCovariances),
computeStat(testy, signal = 0, family = "mDependentPS", intervalSystem = "dyaLen",
covariances = testCovariances))
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", finallengths = 1:testn,
testintervalSystem = "all", indices = indicesAll, singleStat = singleStatmDependentPS,
covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "mDependentPS",
finallengths = 1:testn, testintervalSystem = "all", indices = indicesAll,
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, testn), value = c(0, 1),
testfamily = "mDependentPS", finallengths = 1:testn, testintervalSystem = "all", indices = indicesAll,
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", finallengths = 2^(0:4),
testintervalSystem = "dyaPar", indices = indicesDyaPar,
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "mDependentPS",
finallengths = 2^(0:4), testintervalSystem = "dyaPar", indices = indicesDyaPar,
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 12L), right = c(11L, testn), value = c(0, 1),
testfamily = "mDependentPS", finallengths = 2^(0:4), testintervalSystem = "dyaPar",
indices = indicesDyaPar, singleStat = singleStatmDependentPS, covariances = testCovariances,
defaultPenalty = "sqrt")
testn <- 17L
testcovariances <- as.numeric(ARMAacf(ar = c(), ma = c(0.8, 0.5, 0.3), lag.max = 3))
testsignal <- list(leftIndex = c(1L, 13L), rightIndex = c(12L, testn), value = c(0, -1))
testy <- as.numeric(arima.sim(n = testn, list(ar = c(), ma = c(0.8, 0.5, 0.3)), sd = 1))
testlengths <- c(1, 3:5, 10:14)
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", testlengths = testlengths,
finallengths = testlengths, indices = indicesAllLengths, testintervalSystem = "all",
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "mDependentPS",
testlengths = testlengths, finallengths = testlengths, testintervalSystem = "all", defaultPenalty = "sqrt",
indices = indicesAllLengths, singleStat = singleStatmDependentPS, covariances = testCovariances)
test(testy, testsignal = testsignal, left = c(1L, 13L), right = c(12L, testn), value = c(0, -1),
testfamily = "mDependentPS", testlengths = testlengths, finallengths = testlengths,
testintervalSystem = "all", indices = indicesAllLengths, singleStat = singleStatmDependentPS,
covariances = testCovariances, defaultPenalty = "sqrt")
testlengths <- c(1, 4, 16)
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", testlengths = testlengths,
finallengths = testlengths, indices = indicesDyaLenLengths,
singleStat = singleStatmDependentPS, covariances = testCovariances, defaultPenalty = "sqrt")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "mDependentPS",
testlengths = testlengths, finallengths = testlengths, defaultPenalty = "sqrt",
indices = indicesDyaLenLengths, singleStat = singleStatmDependentPS, covariances = testCovariances)
test(testy, testsignal = testsignal, left = c(1L, 13L), right = c(12L, testn), value = c(0, -1),
testfamily = "mDependentPS", testlengths = testlengths, finallengths = testlengths, defaultPenalty = "sqrt",
indices = indicesDyaLenLengths, singleStat = singleStatmDependentPS, covariances = testCovariances)
testlengths <- c(2, 4, 16)
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", testlengths = testlengths,
finallengths = testlengths, defaultPenalty = "sqrt", indices = indicesDyaParLengths,
singleStat = singleStatmDependentPS, covariances = testCovariances, testintervalSystem = "dyaPar")
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "mDependentPS",
testlengths = testlengths, finallengths = testlengths, indices = indicesDyaParLengths,
singleStat = singleStatmDependentPS, covariances = testCovariances,
testintervalSystem = "dyaPar", defaultPenalty = "sqrt")
test(testy, testsignal = testsignal, left = c(1L, 13L), right = c(12L, testn), value = c(0, -1),
testfamily = "mDependentPS", testlengths = testlengths, finallengths = testlengths,
indices = indicesDyaParLengths, singleStat = singleStatmDependentPS, covariances = testCovariances,
testintervalSystem = "dyaPar", defaultPenalty = "sqrt")
expect_identical(computeStat(testy, family = "mDependentPS", signal = 0, covariances = testCovariances),
computeStat(testy, family = "mDependentPS", signal = 0, covariances = testCovariances,
penalty = "sqrt"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "mDependentPS", finallengths = 2^(0:4),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatmDependentPS,
covariances = testCovariances, defaultPenalty = "sqrt")
})
test_that("arguments in ... are tested and work for family mDependentPS", {
testn <- 17L
testcovariances <- as.numeric(ARMAacf(ar = c(), ma = c(0.8, 0.5, 0.3), lag.max = 3)) * 2^2
testcorrelations <- testcovariances / testcovariances[1]
testsignal <- list(leftIndex = c(1L, 13L), rightIndex = c(12L, testn), value = c(0, -1))
testfilter <- list(acf = testcorrelations)
class(testfilter) <- c("lowpassFilter", class(testfilter))
testy <- as.numeric(arima.sim(n = testn, list(ar = c(), ma = c(0.8, 0.5, 0.3)), sd = 2))
expect_error(computeStat(testy, family = "mDependentPS", covariances = testCovariances, std = 1))
expect_error(computeStat(testy, family = "mDependentPS", correlations = testcorrelations, std = 1))
expect_error(computeStat(testy, family = "mDependentPS", filter = testfilter, std = 1))
expect_error(computeStat(testy, family = "mDependentPS", intervalsystem = "all"))
expect_error(computeStat(testy, family = "mDependentPS"))
expect_error(computeStat(testy, family = "mDependentPS", sd = 1))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(testcovariances, "s")))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(testcovariances, NA)))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(testcovariances, Inf)))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(0.01, testcovariances)))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(-10, testcovariances)))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(1, testcovariances)))
expect_error(computeStat(testy, family = "mDependentPS", covariances = c(testcovariances, 0)))
expect_error(computeStat(testy, family = "mDependentPS", correlations = c(testcorrelations, "s")))
expect_error(computeStat(testy, family = "mDependentPS", correlations = c(testcorrelations, NA)))
expect_error(computeStat(testy, family = "mDependentPS", correlations = c(testcorrelations, Inf)))
expect_error(computeStat(testy, family = "mDependentPS", correlations = c(testcorrelations, 1.1)))
expect_error(computeStat(testy, family = "mDependentPS", correlations = c(0.99, testcorrelations[-1])))
expect_error(computeStat(testy, family = "mDependentPS", correlations = c(testcorrelations, 0)))
expect_error(computeStat(testy, sd = "s", family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(testy, sd = c(1, 2), family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(testy, sd = NA, family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(c(1, 2), family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(testy, sd = Inf, family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(testy, sd = 0, family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(testy, sd = -0.1, family = "mDependentPS", correlations = testcorrelations))
expect_error(computeStat(testy, family = "mDependentPS",
filter = list(param = list(acf = testcorrelations))))
expect_error(computeStat(testy, sd = "s", family = "mDependentPS", filter = testfilter))
expect_error(computeStat(testy, sd = c(1, 2), family = "mDependentPS", filter = testfilter))
expect_error(computeStat(testy, sd = NA, family = "mDependentPS", filter = testfilter))
expect_error(computeStat(c(1, 2), family = "mDependentPS", filter = testfilter))
expect_error(computeStat(testy, sd = Inf, family = "mDependentPS", filter = testfilter))
expect_error(computeStat(testy, sd = 0, family = "mDependentPS", filter = testfilter))
expect_error(computeStat(testy, sd = -0.1, family = "mDependentPS", filter = testfilter))
expect_identical(computeStat(testy, family = "mDependentPS",
covariances = sdrobnorm(testy, lag = 4)^2 * testcorrelations),
computeStat(testy, family = "mDependentPS", correlations = testcorrelations))
expect_identical(computeStat(testy, family = "mDependentPS",
covariances = 1.1^2 * testcorrelations),
computeStat(testy, family = "mDependentPS", correlations = testcorrelations, sd = 1.1))
expect_identical(computeStat(testy, family = "mDependentPS",
covariances = sdrobnorm(testy, lag = 4)^2 * testcorrelations),
computeStat(testy, family = "mDependentPS", filter = testfilter))
expect_identical(computeStat(testy, family = "mDependentPS",
covariances = 1.1^2 * testcorrelations),
computeStat(testy, family = "mDependentPS", filter = testfilter, sd = 1.1))
})
test_that("family jsmurf works", {
testn <- 70L
testy <- rnorm(testn)
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4L, cutoff = 0.1), sr = 1e4)
expect_error(computeStat(family = "jsmurf", filter = testfilter))
expect_error(computeStat(numeric(0), family = "jsmurf", filter = testfilter))
expect_identical(computeStat(testy, family = "jsmurf", filter = testfilter),
computeStat(testy, family = "jsmurf", intervalSystem = "dyaLen", lengths = 2^(4:6),
penalty = "sqrt", nq = testn, output = "list", filter = testfilter))
expect_error(computeStat(as.integer(testy), family = "jsmurf", filter = testfilter))
expect_error(computeStat(c(testy, "s"), family = "jsmurf", filter = testfilter))
expect_error(computeStat(c(rnorm(10), NA), family = "jsmurf", filter = testfilter))
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurf", finallengths = 2^(4:6),
indices = indicesDyaLen, singleStat = singleStatJsmurf, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = - testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfPS", finallengths = 2^(4:6),
indices = indicesDyaLen, singleStat = singleStatJsmurfPS, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = - testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfLR", finallengths = 2^(4:6),
indices = indicesDyaLen, singleStat = singleStatJsmurfLR, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = - testfilter$len)
testn <- 68L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 22L), rightIndex = c(21L, 68L), value = c(0, 1))
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234),
testfamily = "jsmurf", finallengths = 2^(4:6), indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurf, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234),
testfamily = "jsmurfPS", finallengths = 2^(4:6), indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234),
testfamily = "jsmurfLR", finallengths = 2^(4:6), indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurfLR, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurf", finallengths = 2^(4:6), indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurf, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfPS", finallengths = 2^(4:6), indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt",
shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfLR", finallengths = 2^(4:6), indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurfLR, filter = testfilter, defaultPenalty = "sqrt",
shift = -testfilter$len)
expect_identical(computeStat(testy, signal = 0, family = "jsmurf", filter = testfilter),
computeStat(testy, signal = 0, family = "jsmurf", intervalSystem = "dyaLen",
filter = testfilter))
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurf", finallengths = (testfilter$len + 1):testn,
testintervalSystem = "all", indices = indicesAll, sd = 1, singleStat = singleStatJsmurf,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "jsmurfPS",
finallengths = (testfilter$len + 1):testn, testintervalSystem = "all", indices = indicesAll, sd = 1,
singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfLR", finallengths = (testfilter$len + 1):testn,
testintervalSystem = "all", indices = indicesAll, sd = 1, singleStat = singleStatJsmurfLR,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurf", finallengths = 2^(4:6),
testintervalSystem = "dyaPar", indices = indicesDyaPar, sd = 1, singleStat = singleStatJsmurf,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "jsmurfPS",
finallengths = 2^(4:6), testintervalSystem = "dyaPar", indices = indicesDyaPar, sd = 1,
singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfLR", finallengths = 2^(4:6),
testintervalSystem = "dyaPar", indices = indicesDyaPar, sd = 1, singleStat = singleStatJsmurfLR,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
expect_error(computeStat(y = testy, family = "jsmurf", filter = testfilter, lengths = c(8L, 16L)))
expect_error(computeStat(y = testy, family = "jsmurfPS", filter = testfilter, lengths = c(8L, 16L)))
expect_error(computeStat(y = testy, family = "jsmurfLR", filter = testfilter, lengths = c(8L, 16L)))
testlengths <- c(16L, 64L)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfLR", finallengths = testlengths,
indices = indicesDyaLen, testlengths = testlengths, singleStat = singleStatJsmurfLR, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = - testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234), testlengths = testlengths,
testfamily = "jsmurf", finallengths = testlengths, indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurf, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfPS", finallengths = testlengths, indices = indicesDyaLen, sd = 1,
singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt",
testlengths = testlengths, shift = -testfilter$len)
testlengths <- c(13L, 15:18, 64L)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfLR", finallengths = testlengths,
testintervalSystem = "all", indices = indicesAll, testlengths = testlengths, singleStat = singleStatJsmurfLR,
sd = 1, filter = testfilter, defaultPenalty = "sqrt", shift = - testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234), testlengths = testlengths,
testintervalSystem = "all", testfamily = "jsmurf", finallengths = testlengths, indices = indicesAll, sd = 1,
singleStat = singleStatJsmurf, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfPS", finallengths = testlengths, indices = indicesAll, sd = 1,
testintervalSystem = "all", singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt",
testlengths = testlengths, shift = -testfilter$len)
testlengths <- c(32L, 64L)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfLR", finallengths = testlengths,
testintervalSystem = "dyaPar", indices = indicesDyaPar, testlengths = testlengths,
singleStat = singleStatJsmurfLR, tolerance = 1e-10,
sd = 1, filter = testfilter, defaultPenalty = "sqrt", shift = - testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234), testlengths = testlengths,
testintervalSystem = "dyaPar", testfamily = "jsmurf", finallengths = testlengths, indices = indicesDyaPar,
sd = 1, singleStat = singleStatJsmurf, filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "jsmurfPS", finallengths = testlengths, indices = indicesDyaPar, sd = 1,
testintervalSystem = "dyaPar", singleStat = singleStatJsmurfPS, filter = testfilter, defaultPenalty = "sqrt",
testlengths = testlengths, shift = -testfilter$len)
expect_identical(computeStat(testy, family = "jsmurf", signal = 0, filter = testfilter),
computeStat(testy, family = "jsmurf", signal = 0, filter = testfilter,
penalty = "sqrt"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurf", finallengths = 2^(4:6),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatJsmurf, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfPS", finallengths = 2^(4:6),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatJsmurfPS, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfLR", finallengths = 2^(4:6),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatJsmurfLR, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
suppressWarnings(ret <- computeStat(rnorm(10), family = "jsmurfLR", filter = testfilter, sd = 1))
expect_identical(ret$maximum, -Inf)
expect_identical(ret$stat, numeric(0))
expect_identical(ret$lengths, integer(0))
})
test_that("arguments in ... are tested and work for family jsmurf", {
testn <- 35L
testy <- rnorm(testn)
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4L, cutoff = 0.1), sr = 1e4)
expect_error(computeStat(testy, family = "jsmurf", filter = testfilter, std = 1))
expect_error(computeStat(testy, family = "jsmurf", filter = testfilter, intervalsystem = "all"))
expect_error(computeStat(testy, family = "jsmurf"))
expect_error(computeStat(testy, family = "jsmurf", sd = 1))
expect_error(computeStat(testy, family = "jsmurf", filter = unclass(testfilter)))
expect_error(computeStat(testy, sd = "s", family = "jsmurf", filter = testfilter))
expect_error(computeStat(testy, sd = c(1, 2), family = "jsmurf", filter = testfilter))
expect_error(computeStat(testy, sd = NA, family = "jsmurf", filter = testfilter))
expect_error(computeStat(c(1, 2), family = "jsmurf", filter = testfilter))
expect_error(computeStat(testy, sd = Inf, family = "jsmurf", filter = testfilter))
expect_error(computeStat(testy, sd = 0, family = "jsmurf", filter = testfilter))
expect_error(computeStat(testy, sd = -0.1, family = "jsmurf", filter = testfilter))
expect_identical(computeStat(testy, family = "jsmurf", filter = testfilter),
computeStat(testy, family = "jsmurf", filter = testfilter,
sd = sdrobnorm(testy, lag = testfilter$len + 1)))
expect_error(computeStat(testy, family = "jsmurfPS", filter = testfilter, std = 1))
expect_error(computeStat(testy, family = "jsmurfPS", filter = testfilter, intervalsystem = "all"))
expect_error(computeStat(testy, family = "jsmurfPS"))
expect_error(computeStat(testy, family = "jsmurfPS", sd = 1))
expect_error(computeStat(testy, family = "jsmurfPS", filter = unclass(testfilter)))
expect_error(computeStat(testy, sd = "s", family = "jsmurfPS", filter = testfilter))
expect_error(computeStat(testy, sd = c(1, 2), family = "jsmurfPS", filter = testfilter))
expect_error(computeStat(testy, sd = NA, family = "jsmurfPS", filter = testfilter))
expect_error(computeStat(c(1, 2), family = "jsmurfPS", filter = testfilter))
expect_error(computeStat(testy, sd = Inf, family = "jsmurfPS", filter = testfilter))
expect_error(computeStat(testy, sd = 0, family = "jsmurfPS", filter = testfilter))
expect_error(computeStat(testy, sd = -0.1, family = "jsmurfPS", filter = testfilter))
expect_identical(computeStat(testy, family = "jsmurfPS", filter = testfilter),
computeStat(testy, family = "jsmurfPS", filter = testfilter,
sd = sdrobnorm(testy, lag = testfilter$len + 1)))
expect_error(computeStat(testy, family = "jsmurfLR", filter = testfilter, std = 1))
expect_error(computeStat(testy, family = "jsmurfLR", filter = testfilter, intervalsystem = "all"))
expect_error(computeStat(testy, family = "jsmurfLR"))
expect_error(computeStat(testy, family = "jsmurfLR", sd = 1))
expect_error(computeStat(testy, family = "jsmurfLR", filter = unclass(testfilter)))
expect_error(computeStat(testy, sd = "s", family = "jsmurfLR", filter = testfilter))
expect_error(computeStat(testy, sd = c(1, 2), family = "jsmurfLR", filter = testfilter))
expect_error(computeStat(testy, sd = NA, family = "jsmurfLR", filter = testfilter))
expect_error(computeStat(c(1, 2), family = "jsmurfLR", filter = testfilter))
expect_error(computeStat(testy, sd = Inf, family = "jsmurfLR", filter = testfilter))
expect_error(computeStat(testy, sd = 0, family = "jsmurfLR", filter = testfilter))
expect_error(computeStat(testy, sd = -0.1, family = "jsmurfLR", filter = testfilter))
expect_identical(computeStat(testy, family = "jsmurfLR", filter = testfilter),
computeStat(testy, family = "jsmurfLR", filter = testfilter,
sd = sdrobnorm(testy, lag = testfilter$len + 1)))
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 6L, cutoff = 0.25),
sr = 5e4, shift = 0.2)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurf", finallengths = 2^(2:5),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatJsmurf, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfPS", finallengths = 2^(2:5),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatJsmurfPS, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "jsmurfLR", finallengths = 2^(2:5),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatJsmurfLR, sd = 1,
filter = testfilter, defaultPenalty = "sqrt", shift = -testfilter$len)
})
test_that("family hjsmurf works", {
testn <- 70L
testy <- rnorm(testn)
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4L, cutoff = 0.1), sr = 1e4)
expect_error(computeStat(family = "hjsmurf", filter = testfilter))
expect_error(computeStat(numeric(0), family = "hjsmurf", filter = testfilter))
expect_identical(computeStat(testy, family = "hjsmurf", filter = testfilter),
computeStat(testy, family = "hjsmurf", intervalSystem = "dyaLen", lengths = 2^(4:6),
penalty = "none", nq = testn, output = "list", filter = testfilter))
expect_error(computeStat(as.integer(testy), family = "hjsmurf", filter = testfilter))
expect_error(computeStat(c(testy, "s"), family = "hjsmurf", filter = testfilter))
expect_error(computeStat(c(rnorm(10), NA), family = "hjsmurf", filter = testfilter))
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurf", finallengths = 2^(4:6),
indices = indicesDyaLen, singleStat = singleStatHjsmurf,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfSPS", finallengths = 2^(4:6),
indices = indicesDyaLen, singleStat = singleStatHjsmurfSPS,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfLR", finallengths = 2^(4:6),
indices = indicesDyaLen, singleStat = singleStatHjsmurfLR,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
testn <- 68L
testy <- c(rnorm(testn / 2), rnorm(testn / 2, 1))
testsignal <- list(leftIndex = c(1L, 22L), rightIndex = c(21L, 68L), value = c(0, 1))
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234),
testfamily = "hjsmurf", finallengths = 2^(4:6), indices = indicesDyaLen,
singleStat = singleStatHjsmurf, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234),
testfamily = "hjsmurfSPS", finallengths = 2^(4:6), indices = indicesDyaLen,
singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234),
testfamily = "hjsmurfLR", finallengths = 2^(4:6), indices = indicesDyaLen,
singleStat = singleStatHjsmurfLR, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurf", finallengths = 2^(4:6), indices = indicesDyaLen,
singleStat = singleStatHjsmurf, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfSPS", finallengths = 2^(4:6), indices = indicesDyaLen,
singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none",
shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfLR", finallengths = 2^(4:6), indices = indicesDyaLen,
singleStat = singleStatHjsmurfLR, filter = testfilter, defaultPenalty = "none",
shift = -testfilter$len)
expect_identical(computeStat(testy, signal = 0, family = "hjsmurf", filter = testfilter),
computeStat(testy, signal = 0, family = "hjsmurf", intervalSystem = "dyaLen",
filter = testfilter))
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurf", finallengths = (testfilter$len + 2):testn,
testintervalSystem = "all", indices = indicesAll, singleStat = singleStatHjsmurf,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len, tolerance = 1e-6)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hjsmurfSPS",
finallengths = (testfilter$len + 2):testn, testintervalSystem = "all", indices = indicesAll,
singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len,
tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfLR", finallengths = (testfilter$len + 2):testn,
testintervalSystem = "all", indices = indicesAll, singleStat = singleStatHjsmurfLR,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len, tolerance = 1e-6)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurf", finallengths = 2^(4:6),
testintervalSystem = "dyaPar", indices = indicesDyaPar, singleStat = singleStatHjsmurf,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = 1, left = 1L, right = testn, value = 1, testfamily = "hjsmurfSPS",
finallengths = 2^(4:6), testintervalSystem = "dyaPar", indices = indicesDyaPar,
singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfLR", finallengths = 2^(4:6),
testintervalSystem = "dyaPar", indices = indicesDyaPar, singleStat = singleStatHjsmurfLR,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
expect_error(computeStat(y = testy, family = "hjsmurf", filter = testfilter, lengths = c(8L, 16L)))
expect_error(computeStat(y = testy, family = "hjsmurfPS", filter = testfilter, lengths = c(8L, 16L)))
expect_error(computeStat(y = testy, family = "hjsmurfLR", filter = testfilter, lengths = c(8L, 16L)))
testlengths <- c(16L, 64L)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfLR", finallengths = testlengths,
indices = indicesDyaLen, testlengths = testlengths, singleStat = singleStatHjsmurfLR,
filter = testfilter, defaultPenalty = "none", shift = - testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234), testlengths = testlengths,
testfamily = "hjsmurf", finallengths = testlengths, indices = indicesDyaLen,
singleStat = singleStatHjsmurf, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfSPS", finallengths = testlengths, indices = indicesDyaLen,
singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none",
testlengths = testlengths, shift = -testfilter$len)
testlengths <- c(13L, 15:18, 64L)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfLR", finallengths = testlengths,
testintervalSystem = "all", indices = indicesAll, testlengths = testlengths, singleStat = singleStatHjsmurfLR,
filter = testfilter, defaultPenalty = "none", shift = - testfilter$len, tolerance = 1e-6)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234), testlengths = testlengths,
testintervalSystem = "all", testfamily = "hjsmurf", finallengths = testlengths, indices = indicesAll,
singleStat = singleStatHjsmurf, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len,
tolerance = 1e-6)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfSPS", finallengths = testlengths, indices = indicesAll,
testintervalSystem = "all", singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none",
testlengths = testlengths, shift = -testfilter$len, tolerance = 1e-6)
testlengths <- c(32L, 64L)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfLR", finallengths = testlengths,
testintervalSystem = "dyaPar", indices = indicesDyaPar, testlengths = testlengths,
singleStat = singleStatHjsmurfLR, filter = testfilter, defaultPenalty = "none", shift = - testfilter$len)
test(testy, testsignal = 1.234, left = c(1L), right = c(testn), value = c(1.234), testlengths = testlengths,
testintervalSystem = "dyaPar", testfamily = "hjsmurf", finallengths = testlengths, indices = indicesDyaPar,
singleStat = singleStatHjsmurf, filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, testsignal = testsignal, left = c(1L, 22L), right = c(21L, testn), value = c(0, 1),
testfamily = "hjsmurfSPS", finallengths = testlengths, indices = indicesDyaPar,
testintervalSystem = "dyaPar", singleStat = singleStatHjsmurfSPS, filter = testfilter, defaultPenalty = "none",
testlengths = testlengths, shift = -testfilter$len)
expect_identical(computeStat(testy, family = "hjsmurf", signal = 0, filter = testfilter),
computeStat(testy, family = "hjsmurf", signal = 0, filter = testfilter,
penalty = "none"))
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurf", finallengths = 2^(4:6),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatHjsmurf,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfSPS", finallengths = 2^(4:6),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatHjsmurfSPS,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
test(testy, left = 1L, right = testn, value = 0, testfamily = "hjsmurfLR", finallengths = 2^(4:6),
testnq = 100L, indices = indicesDyaLen, singleStat = singleStatHjsmurfLR,
filter = testfilter, defaultPenalty = "none", shift = -testfilter$len)
suppressWarnings(ret <- computeStat(rnorm(10), family = "hjsmurfLR", filter = testfilter))
expect_identical(ret$maximum, -Inf)
expect_identical(ret$stat, numeric(0))
expect_identical(ret$lengths, integer(0))
})
test_that("arguments in ... are tested and work for family hjsmurf", {
testn <- 35L
testy <- rnorm(testn)
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4L, cutoff = 0.1), sr = 1e4)
expect_error(computeStat(testy, family = "hjsmurf", filter = testfilter, sd = 1))
expect_error(computeStat(testy, family = "hjsmurf", filter = testfilter, intervalsystem = "all"))
expect_error(computeStat(testy, family = "hjsmurf"))
expect_error(computeStat(testy, family = "hjsmurf", filter = unclass(testfilter)))
expect_error(computeStat(testy, family = "hjsmurfSPS", filter = testfilter, sd = 1))
expect_error(computeStat(testy, family = "hjsmurfSPS", filter = testfilter, intervalsystem = "all"))
expect_error(computeStat(testy, family = "hjsmurfSPS"))
expect_error(computeStat(testy, family = "hjsmurfSPS", filter = unclass(testfilter)))
expect_error(computeStat(testy, family = "hjsmurfLR", filter = testfilter, sd = 1))
expect_error(computeStat(testy, family = "hjsmurfLR", filter = testfilter, intervalsystem = "all"))
expect_error(computeStat(testy, family = "hjsmurfLR"))
expect_error(computeStat(testy, family = "hjsmurfLR", filter = unclass(testfilter)))
})
context("local tests statistics in computeStat")
testJump <- function(grid, time, data, filter, correlations, leftValue, rightValue) {
len <- length(data)
m <- min(len, length(correlations) - 1L)
if (len == 1) {
A <- matrix(correlations[1], 1, 1)
} else {
A <- matrix(0, len, len)
for (i in 1:(len - 1)) {
A[i, i] <- correlations[1]
A[i, i + 1:min(m, len - i)] <- correlations[2:min(m + 1, len - i + 1)]
A[i + 1:min(m, len - i), i] <- correlations[2:min(m + 1, len - i + 1)]
}
A[len, len] <- correlations[1]
}
costs <- numeric(length(grid))
for (i in seq(along = grid)) {
mu <- lowpassFilter::getConvolutionJump(time, grid[i], leftValue, rightValue, filter)
costs[i] <- sum((data - mu) * solve(A, data - mu))
}
grid[which.min(costs)]
}
statAll <- function(y, filter, fit, singleStat, lengths, add, ...) {
stat <- rep(-Inf, length(lengths))
y[add] <- NA
for (inLen in seq(along = lengths)) {
len <- lengths[inLen]
start <- fit$leftEnd[1] + filter$len - 1L
end <- fit$rightEnd[1] - len - filter$len + 1L
if (start <= end) {
for (li in start:end) {
ri <- li + len
obs <- y[(li + 1):(ri + filter$len - 1)]
time <- (li + 1):(ri + filter$len - 1) / filter$sr
newStat <- singleStat(obs = obs, time = time, filter = filter,
left = li / filter$sr, right = ri / filter$sr,
leftValue = fit$value[1], rightValue = fit$value[1],
leftVar = fit$var[1], rightVar = fit$var[1], cp = 0, ...)
if (!is.na(newStat)) {
stat[inLen] <- max(stat[inLen], newStat)
}
}
}
for (inSeg in seq(along = fit$leftEnd)[-1]) {
start <- max(fit$rightEnd[inSeg - 1L] - len - filter$len + 2L, start)
end <- min(fit$leftEnd[inSeg] + filter$len - 2L, fit$rightEnd[inSeg] - len - filter$len + 1L)
if (start <= end) {
for (li in start:end) {
ri <- li + len
obs <- y[(li + 1):(ri + filter$len - 1)]
time <- (li + 1):(ri + filter$len - 1) / filter$sr
newStat <- singleStat(obs = obs, time = time, filter = filter,
left = li / filter$sr, right = ri / filter$sr,
leftValue = fit$value[inSeg - 1L], rightValue = fit$value[inSeg],
leftVar = fit$var[inSeg - 1L], rightVar = fit$var[inSeg],
cp = (fit$leftEnd[inSeg] - 1L) / filter$sr, ...)
if (!is.na(newStat)) {
stat[inLen] <- max(stat[inLen], newStat)
}
}
}
start <- fit$leftEnd[inSeg] + filter$len - 1L
end <- fit$rightEnd[inSeg] - len - filter$len + 1L
if (start <= end) {
for (li in start:end) {
ri <- li + len
obs <- y[(li + 1):(ri + filter$len - 1)]
time <- (li + 1):(ri + filter$len - 1) / filter$sr
newStat <- singleStat(obs = obs, time = time, filter = filter,
left = li / filter$sr, right = ri / filter$sr,
leftValue = fit$value[inSeg], rightValue = fit$value[inSeg],
leftVar = fit$var[inSeg], rightVar = fit$var[inSeg], cp = 0, ...)
if (!is.na(newStat)) {
stat[inLen] <- max(stat[inLen], newStat)
}
}
}
}
}
stat
}
test_that("family LR works", {
testn <- 50L
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4, cutoff = 0.1), sr = 1e4)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
testfit <- stepblock(0, leftEnd = 0, rightEnd = testn / testfilter$sr, x0 = 0)
expect_error(computeStat(family = "LR", filter = testfilter, fit = testfit))
expect_error(computeStat(y = numeric(0), family = "LR", filter = testfilter, fit = testfit))
expect_error(computeStat(y = as.integer(testy), family = "LR", filter = testfilter, fit = testfit))
expect_error(computeStat(y = c(testy[-1], "s"), family = "LR", filter = testfilter, fit = testfit))
expect_error(computeStat(y = c(testy[-1], NA), family = "LR", filter = testfilter, fit = testfit))
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfit),
computeStat(testy, family = "LR", intervalSystem = "all", lengths = 1:20,
penalty = "none", nq = testn, output = "list", filter = testfilter, fit = testfit))
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR")
testcor <- testfilter$acf
testcor[1] <- 2
comparefit <- stepblock(stats::median(testy[11:39]), leftEnd = 1, rightEnd = c(testn), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = integer(0), sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_identical(computeStat(testy, family = "LR", filter = testfilter, lengths = c(1, 2, 4, 8, 16)),
computeStat(testy, family = "LR", intervalSystem = "dyaLen", filter = testfilter))
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR", lengths = c(1:3, 5, 25))
expect_identical(ret, computeStat(y = testy, filter = testfilter, family = "LR", lengths = c(1:3, 5, 25)))
testcor <- testfilter$acf
testcor[1] <- 2
comparefit <- stepblock(stats::median(testy[11:39]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = c(1:3, 5, 25), add = integer(0), sd = sdrobnorm(testy, lag = testfilter$len + 1L),
regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_warning(ret2 <- computeStat(y = testy, filter = testfilter, signal = testfit,
fit = testfit, family = "LR", lengths = c(1:3, 5, 25)))
expect_identical(ret, ret2)
expect_error(computeStat(y = testy, filter = testfilter, intervalSystem = "dyaPar",
fit = testfit, family = "LR", lengths = c(1, 4, 16)))
expect_identical(computeStat(y = testy, filter = testfilter, family = "LR", lengths = c(1:3, 5, 25),
output = "maximum"), ret$maximum)
expect_identical(computeStat(y = testy, filter = testfilter, family = "LR", lengths = c(1:3, 5, 25),
output = "vector"), ret$stat)
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR", lengths = c(1:3, 5, 25),
penalty = "sqrt", nq = 100L, output = "maximum")
expect_equal(ret, max(sqrt(2 * compare) - sqrt(2 * log(exp(1) * 100L / c(1:3, 5, 25)))))
suppressWarnings(ret <- computeStat(y = rnorm(20), filter = testfilter, family = "LR"))
expect_identical(ret$maximum, -Inf)
expect_identical(ret$stat, rep(-Inf, 20))
expect_identical(ret$lengths, 1:20)
testn <- 100L
testfit <- stepblock(c(0, 1), leftEnd = c(0, 50 / testfilter$sr),
rightEnd = c(50 / testfilter$sr, testn / testfilter$sr), x0 = 0)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR")
testcor <- testfilter$acf
testcor[1] <- 2
j <- as.integer(testJump(39:50 / testfilter$sr, 40:60 / testfilter$sr, testy[40:60], testfilter, testcor,
stats::median(testy[11:39]), stats::median(testy[61:89])) * testfilter$sr + 1e-6)
comparefit <- stepblock(c(stats::median(testy[11:39]), stats::median(testy[61:89])),
leftEnd = c(0, j), rightEnd = c(j, 100), x0 = 0)
comparefit <- stepblock(c(stats::median(testy[11:39]), stats::median(testy[61:89])),
leftEnd = c(1, j + 1), rightEnd = c(j, 100), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = integer(0), sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1, 0), leftEnd = c(0, 50 / testfilter$sr, 53 / testfilter$sr),
rightEnd = c(50 / testfilter$sr, 53 / testfilter$sr, testn / testfilter$sr), x0 = 0)
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR")
comparefit <- stepblock(c(stats::median(testy[11:39]), NA, stats::median(testy[64:89])),
leftEnd = c(1, 51, 54), rightEnd = c(50, 53, 100), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = 39:53, sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1, 0, 1, 0), leftEnd = c(0, 50:53 / testfilter$sr),
rightEnd = c(50:53 / testfilter$sr, testn / testfilter$sr), x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR"))
comparefit <- stepblock(c(stats::median(testy[11:39]), NA, stats::median(testy[64:89])),
leftEnd = c(1, 51, 54), rightEnd = c(50, 53, 100), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = 39:53, sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1, 0, 1), leftEnd = c(0, 25, 50, 75) / testfilter$sr,
rightEnd = c(25, 50, 75, testn) / testfilter$sr, x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR"))
expect_identical(ret$stat, rep(-Inf, 20))
testfit <- stepblock(c(0, 1), leftEnd = c(0, 20 / testfilter$sr),
rightEnd = c(20 / testfilter$sr, testn / testfilter$sr), x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR"))
comparefit <- stepblock(c(NA, stats::median(testy[31:89])),
leftEnd = c(1, 21), rightEnd = c(20, 100), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = 1:20, sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1), leftEnd = c(0, 80 / testfilter$sr),
rightEnd = c(80 / testfilter$sr, testn / testfilter$sr), x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "LR"))
comparefit <- stepblock(c(stats::median(testy[11:69]), NA),
leftEnd = c(1, 81), rightEnd = c(80, 100), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = 69:100, sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepR::stepblock(0, leftEnd = 1, rightEnd = 1 + testn / testfilter$sr, x0 = 1)
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit))
})
test_that("arguments in ... are tested and work for family LR", {
testn <- 50L
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4, cutoff = 0.1), sr = 1e4)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
testfit <- stepblock(0, leftEnd = 0, rightEnd = testn / testfilter$sr, x0 = 0)
expect_error(computeStat(testy, family = "LR", filter = unclass(testfilter), fit = testfit))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = unclass(testfit)))
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = list(fit = testfit)),
computeStat(testy, family = "LR", filter = testfilter, fit = testfit))
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfit),
computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
startTime = 0, thresholdLongSegment = 10L, localValue = stats::median,
regularization = 1, suppressWarningNoDeconvolution = FALSE, localList = NULL))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, startTime = NA))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, startTime = c(0, 1)))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, startTime = 1))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, startTime = -1))
testfitStartTime <- stepblock(0, leftEnd = -1, rightEnd = testn / testfilter$sr - 1, x0 = -1)
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfitStartTime, startTime = -1),
computeStat(testy, family = "LR", filter = testfilter, fit = testfit, startTime = 0))
testfitStartTime <- stepblock(0, leftEnd = 0.001, rightEnd = testn / testfilter$sr + 0.001, x0 = 0.001)
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfitStartTime, startTime = 0.001),
computeStat(testy, family = "LR", filter = testfilter, fit = testfit, startTime = 0))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, thresholdLongSegment = NA))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, thresholdLongSegment = -1L))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
thresholdLongSegment = c(10L, 23L)))
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, thresholdLongSegment = 10.5),
computeStat(testy, family = "LR", filter = testfilter, fit = testfit))
expect_warning(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, thresholdLongSegment = 30))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, localValue = 1))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, localValue = function() 1))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, localValue = function(a) NA))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, localValue = function(a) c(1, 2)))
ret <- computeStat(testy, family = "LR", filter = testfilter, fit = testfit, localValue = mean)
testcor <- testfilter$acf
testcor[1] <- 2
comparefit <- stepblock(mean(testy[11:39]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = integer(0), sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, regularization = NULL))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, regularization = c(1, NA)))
ret <- computeStat(testy, family = "LR", filter = testfilter, fit = testfit, regularization = 2)
testcor <- testfilter$acf
testcor[1] <- 3
comparefit <- stepblock(stats::median(testy[11:39]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = integer(0), sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
ret <- computeStat(testy, family = "LR", filter = testfilter, fit = testfit, regularization = c(2, 1))
testcor <- testfilter$acf
testcor[1] <- 3
testcor[2] <- testcor[2] + 1
comparefit <- stepblock(stats::median(testy[11:39]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStatLR,
lengths = 1:20, add = integer(0), sd = sdrobnorm(testy, lag = testfilter$len + 1L), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, correlations = "s"))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, correlations = c(Inf, 3)))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit, correlations = c(1, 0)))
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
correlations = testcor), ret)
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = 1))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = as.logical(NA)))
expect_error(computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = c(TRUE, TRUE)))
testfit <- stepblock(c(0, 1, 2, 3), leftEnd = c(0, 40, 41, 42) / testfilter$sr,
rightEnd = c(40, 41, 42, testn) / testfilter$sr, x0 = 0)
expect_warning(ret <- computeStat(testy, family = "LR", filter = testfilter, fit = testfit))
expect_identical(computeStat(testy, family = "LR", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = TRUE), ret)
})
test_that("family 2Param works (short version)", {
testn <- 70L
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4, cutoff = 0.1), sr = 1e4)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
testfit <- stepblock(0, leftEnd = 0, rightEnd = testn / testfilter$sr, x0 = 0)
expect_error(computeStat(family = "2Param", filter = testfilter, fit = testfit))
expect_error(computeStat(y = numeric(0), family = "2Param", filter = testfilter, fit = testfit))
expect_error(computeStat(y = as.integer(testy), family = "2Param", filter = testfilter, fit = testfit))
expect_error(computeStat(y = c(testy[-1], "s"), family = "2Param", filter = testfilter, fit = testfit))
expect_error(computeStat(y = c(testy[-1], NA), family = "2Param", filter = testfilter, fit = testfit))
# this takes very long
# expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit),
# computeStat(testy, family = "2Param", intervalSystem = "all", lengths = 1:65,
# penalty = "none", nq = testn, output = "list", filter = testfilter, fit = testfit))
testlengths = c(1:3, 15, 64:65)
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param", lengths = testlengths)
comparefit <- stepblock(stats::median(testy[11:59]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
comparefit$var <- sdrobnorm(testy[11:59], lag = testfilter$len + 1L)^2
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = testlengths, add = integer(0), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
})
test_that("family 2Param works (long version)", {
testthat::skip_on_cran()
testn <- 70L
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4, cutoff = 0.1), sr = 1e4)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
testfit <- stepblock(0, leftEnd = 0, rightEnd = testn / testfilter$sr, x0 = 0)
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, lengths = c(1, 2, 4, 8, 16, 32, 64)),
computeStat(testy, family = "2Param", intervalSystem = "dyaLen", filter = testfilter))
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param", lengths = c(1:3, 5, 25))
expect_identical(ret, computeStat(y = testy, filter = testfilter, family = "2Param", lengths = c(1:3, 5, 25)))
testcor <- testfilter$acf
testcor[1] <- 2
comparefit <- stepblock(stats::median(testy[11:59]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
comparefit$var <- sdrobnorm(testy[11:59], lag = testfilter$len + 1L)^2
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(1:3, 5, 25), add = integer(0), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_warning(ret2 <- computeStat(y = testy, filter = testfilter, signal = testfit,
fit = testfit, family = "2Param", lengths = c(1:3, 5, 25)))
expect_identical(ret, ret2)
expect_error(computeStat(y = testy, filter = testfilter, intervalSystem = "dyaPar",
fit = testfit, family = "2Param", lengths = c(1, 4, 16)))
expect_identical(computeStat(y = testy, filter = testfilter, family = "2Param", lengths = c(1:3, 5, 25),
output = "maximum"), ret$maximum)
expect_identical(computeStat(y = testy, filter = testfilter, family = "2Param", lengths = c(1:3, 5, 25),
output = "vector"), ret$stat)
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param", lengths = c(1:3, 5, 25),
penalty = "sqrt", nq = 100L, output = "maximum")
expect_equal(ret, max(sqrt(2 * compare) - sqrt(2 * log(exp(1) * 100L / c(1:3, 5, 25)))))
suppressWarnings(ret <- computeStat(y = rnorm(20), filter = testfilter, family = "2Param"))
expect_identical(ret$maximum, -Inf)
expect_identical(ret$stat, rep(-Inf, 20))
expect_identical(ret$lengths, 1:20)
testn <- 100L
testfit <- stepblock(c(0, 1), leftEnd = c(0, 50 / testfilter$sr),
rightEnd = c(50 / testfilter$sr, testn / testfilter$sr), x0 = 0)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param", lengths = c(1:3, 5, 25))
testcor <- testfilter$acf
testcor[1] <- 2
j <- as.integer(testJump(39:50 / testfilter$sr, 40:60 / testfilter$sr, testy[40:60], testfilter, testcor,
stats::median(testy[11:39]), stats::median(testy[61:89])) * testfilter$sr + 1e-6)
comparefit <- stepblock(c(stats::median(testy[11:39]), stats::median(testy[61:89])),
leftEnd = c(1, j + 1), rightEnd = c(j, 100), x0 = 0)
comparefit$var <- c(sdrobnorm(testy[11:39], lag = testfilter$len + 1L)^2,
sdrobnorm(testy[61:89], lag = testfilter$len + 1L)^2)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(1:3, 5, 25), add = integer(0), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-4)
testfit <- stepblock(c(0, 1, 0), leftEnd = c(0, 50 / testfilter$sr, 53 / testfilter$sr),
rightEnd = c(50 / testfilter$sr, 53 / testfilter$sr, testn / testfilter$sr), x0 = 0)
ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param", lengths = c(1:2, 5, 13))
comparefit <- stepblock(c(stats::median(testy[11:39]), NA, stats::median(testy[64:89])),
leftEnd = c(1, 51, 54), rightEnd = c(50, 53, 100), x0 = 0)
comparefit$var <- c(sdrobnorm(testy[11:39], lag = testfilter$len + 1L)^2, NA,
sdrobnorm(testy[64:89], lag = testfilter$len + 1L)^2)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(1:2, 5, 13), add = 39:53, regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1, 0, 1, 0), leftEnd = c(0, 50:53 / testfilter$sr),
rightEnd = c(50:53 / testfilter$sr, testn / testfilter$sr), x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit,
family = "2Param", lengths = c(1:3, 5, 15)))
comparefit <- stepblock(c(stats::median(testy[11:39]), NA, stats::median(testy[64:89])),
leftEnd = c(1, 51, 54), rightEnd = c(50, 53, 100), x0 = 0)
comparefit$var <- c(sdrobnorm(testy[11:39], lag = testfilter$len + 1L)^2, NA,
sdrobnorm(testy[64:89], lag = testfilter$len + 1L)^2)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(1:3, 5, 15), add = 39:53, regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1, 0, 1), leftEnd = c(0, 25, 50, 75) / testfilter$sr,
rightEnd = c(25, 50, 75, testn) / testfilter$sr, x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param",
lengths = c(1:3, 5, 25)))
expect_identical(ret$stat, rep(-Inf, 5))
testfit <- stepblock(c(0, 1), leftEnd = c(0, 20 / testfilter$sr),
rightEnd = c(20 / testfilter$sr, testn / testfilter$sr), x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param",
lengths = c(7:9, 12)))
comparefit <- stepblock(c(NA, stats::median(testy[31:89])),
leftEnd = c(1, 21), rightEnd = c(20, 100), x0 = 0)
comparefit$var <- c(NA, sdrobnorm(testy[31:89], lag = testfilter$len + 1L)^2)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(7:9, 12), add = 1:20, regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepblock(c(0, 1), leftEnd = c(0, 80 / testfilter$sr),
rightEnd = c(80 / testfilter$sr, testn / testfilter$sr), x0 = 0)
expect_warning(ret <- computeStat(y = testy, filter = testfilter, fit = testfit, family = "2Param",
lengths = c(11:13)))
comparefit <- stepblock(c(stats::median(testy[11:69]), NA),
leftEnd = c(1, 81), rightEnd = c(80, 100), x0 = 0)
comparefit$var <- c(sdrobnorm(testy[11:69], lag = testfilter$len + 1L)^2, NA)
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(11:13), add = 69:100, regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
testfit <- stepR::stepblock(0, leftEnd = 1, rightEnd = 1 + testn / testfilter$sr, x0 = 1)
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = testlengths))
})
test_that("arguments in ... are tested and work for family 2Param", {
testthat::skip_on_cran()
testn <- 50L
testfilter <- lowpassFilter::lowpassFilter(type = "bessel", param = list(pole = 4, cutoff = 0.1), sr = 1e4)
testy <- lowpassFilter::randomGenerationMA(n = testn, filter = testfilter, seed = "no")
testfit <- stepblock(0, leftEnd = 0, rightEnd = testn / testfilter$sr, x0 = 0)
expect_error(computeStat(testy, family = "2Param", filter = unclass(testfilter), fit = testfit))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = unclass(testfit)))
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = list(fit = testfit),
lengths = c(7:9, 12)),
computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = c(7:9, 12)))
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = c(7:9, 12)),
computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = c(7:9, 12),
startTime = 0, thresholdLongSegment = 10L, localValue = stats::median,
localVar = function(data) sdrobnorm(data, lag = testfilter$len + 1L)^2,
regularization = 1, suppressWarningNoDeconvolution = FALSE, localList = NULL))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, startTime = NA))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, startTime = c(0, 1)))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
startTime = (testn + 1) / testfilter$sr))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, startTime = -1 / testfilter$sr))
testfitStartTime <- stepblock(0, leftEnd = -1, rightEnd = testn / testfilter$sr - 1, x0 = -1)
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfitStartTime, startTime = -1),
computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, startTime = 0))
testfitStartTime <- stepblock(0, leftEnd = 0.001, rightEnd = testn / testfilter$sr + 0.001, x0 = 0.001)
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfitStartTime, startTime = 0.001),
computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, startTime = 0))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, thresholdLongSegment = NA))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, thresholdLongSegment = -1L))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
thresholdLongSegment = c(10L, 23L)))
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
thresholdLongSegment = 25.5, lengths = c(7:9, 12, 37)),
computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = c(7:9, 12, 37)))
expect_warning(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, thresholdLongSegment = 30,
lengths = c(7:9, 12)))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localValue = 1))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localValue = function() 1))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localValue = function(a) NA))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
localValue = function(a) c(1, 2)))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localVar = 1))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localVar = function() 1))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localVar = function(a) NA))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
localVar = function(a) c(1, 2)))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localVar = function(a) -1))
ret <- computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, localValue = mean,
localVar = function(data) 1, lengths = c(7:9, 12))
testcor <- testfilter$acf
testcor[1] <- 2
comparefit <- stepblock(mean(testy[11:39]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
comparefit$var <- 1
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(7:9, 12), add = integer(0), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, regularization = NULL))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, regularization = c(1, NA)))
ret <- computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, regularization = 2,
lengths = c(7:9, 12))
testcor <- testfilter$acf
testcor[1] <- 3
comparefit <- stepblock(stats::median(testy[11:39]), leftEnd = c(1), rightEnd = c(testn), x0 = 0)
comparefit$var <- sdrobnorm(testy[11:39], lag = 12)^2
compare <- statAll(y = testy, filter = testfilter, fit = comparefit, singleStat = singleStat2Param,
lengths = c(7:9, 12), add = integer(0), regu = 1)
expect_equal(ret$stat, compare, tolerance = 1e-12)
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, correlations = "s"))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, correlations = c(Inf, 3)))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, correlations = c(1, 0)))
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
correlations = testcor, lengths = c(7:9, 12)), ret)
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = 1))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = as.logical(NA)))
expect_error(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit,
suppressWarningNoDeconvolution = c(TRUE, TRUE)))
testfit <- stepblock(c(0, 1, 2, 3), leftEnd = c(0, 47, 48, 49) / testfilter$sr,
rightEnd = c(47, 48, 49, testn) / testfilter$sr, x0 = 0)
expect_warning(ret <- computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = c(7:9, 12)))
expect_identical(computeStat(testy, family = "2Param", filter = testfilter, fit = testfit, lengths = c(7:9, 12),
suppressWarningNoDeconvolution = TRUE), ret)
})
Try the stepR package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.