compareKernelSmoothing <- function(y, bandwidth) { n <- length(y) kernel <- function(x) ifelse(abs(x) <= 1 + 1e-15, 3 / 4 * (1 - x^2), 0) L <- max(0, min(as.integer(bandwidth * n + 1e-14), n - 1)) K <- kernel(-L:L / (bandwidth * n)) ret <- numeric(n) for (i in 1:n) { ret[i] <- sum(K[max(L + 2 - i, 1):min(n - i + L + 1, 2 * L + 1)] * y[max(i - L, 1):min(i + L, n)]) / sum(K[max(L + 2 - i, 1):min(n - i + L + 1, 2 * L + 1)]) } ret } compareImSy <- function(y, bandwidth) { n <- length(y) kernel <- function(x) ifelse(abs(x) <= 1 + 1e-15, 3 / 4 * (1 - x^2), 0) L <- max(0, min(as.integer(bandwidth * n + 1e-14), n - 1)) K <- kernel(-L:L / (bandwidth * n)) y - .kernelSmoothing(y, K) } compareImSX <- function(y, bandwidth) { n <- length(y) kernel <- function(x) ifelse(abs(x) <= 1 + 1e-15, 3 / 4 * (1 - x^2), 0) L <- max(0, min(as.integer(bandwidth * n + 1e-14), n - 1)) K <- kernel(-L:L / (bandwidth * n)) Matrix::bandSparse(n, n - 1, k = (-L + 1):L - 1, diagonals = .createImSX(n = n, K = rev(cumsum(K)))) } compareXty <- function(y, bandwidth, x = NULL) { if (is.null(x)) { x <- compareImSX(y, bandwidth) } Matrix::t(x) %*% y / length(y) } compareXtX <- function(y, bandwidth, x = NULL) { if (is.null(x)) { x <- compareImSX(y, bandwidth) } Matrix::t(x) %*% x / length(y) } comparePcplus <- function(y, lambda, bandwidth, sd, thresh, maxit) { ImSX <- compareImSX(y, bandwidth) ImSy <- compareImSy(y, bandwidth) ret <- glmnet::glmnet(x = ImSX, y = ImSy, lambda = lambda, standardize = FALSE, intercept = FALSE) fit <- c(0, cumsum(as.numeric(ret$beta))) n <- length(y) kernel <- function(x) ifelse(abs(x) <= 1 + 1e-15, 3 / 4 * (1 - x^2), 0) L <- max(0, min(as.integer(bandwidth * n + 1e-14), n - 1)) K <- kernel(-L:L / (bandwidth * n)) smooth <- .kernelSmoothing(y - fit, K) pelt <- .pelt(obs = as.numeric(y - smooth), sd = sd) J <- pelt$cps ImSX <- cbind(rep(0, n), ImSX) if (length(J) > 0) { fitJ <- as.numeric(Matrix::solve(Matrix::t(ImSX[, J, drop = FALSE]) %*% ImSX[, J, drop = FALSE], as.numeric(Matrix::t(ImSX[, J, drop = FALSE]) %*% ImSy))) fit <- numeric(n) fit[J] <- fitJ fit <- cumsum(fit) smooth <- .kernelSmoothing(y - fit, K) } else { fit <- rep(0, n) smooth <- .kernelSmoothing(y, K) } list(est = fit + smooth, smooth = smooth, cpfun = fit, cps = J) } comparePcplusInf <- function(y, sd) { pelt <- .pelt(obs = y - mean(y), sd = sd) list(est = pelt$est + mean(y), smooth = rep(mean(y), length(y)), cpfun = pelt$est, cps = pelt$cps) } test_that("pcplus is giving correct results I", { testy <- rnorm(100) testbandwidth <- 0.05 testlambda <- 0.01 testthresh <- 1e-7 testmaxit <- 1e5 testsd <- 1 object <- pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = testsd, nlambda = 30L, thresh = testthresh, maxit = testmaxit) expected <- comparePcplus(testy, testlambda, testbandwidth, testsd, testthresh, testmaxit) expect_equal(object, expected) }) test_that("pcplus is giving correct results II", { testy <- rnorm(100) testy[40:100] <- testy[40:100] + 3 testy[70:100] <- testy[70:100] + 5 testbandwidth <- 0.15 testlambda <- 0.03 testthresh <- 1e-7 testmaxit <- 1e5 testsd <- 1 object <- pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = testsd, nlambda = 30L, thresh = testthresh, maxit = testmaxit) expected <- comparePcplus(testy, testlambda, testbandwidth, testsd, testthresh, testmaxit) expect_equal(object, expected) }) test_that("pcplus is giving correct results III", { testy <- rnorm(100) testy[7:100] <- testy[7:100] + 50 testy[12:100] <- testy[12:100] + 20 testy[90:100] <- testy[90:100] + 20 testbandwidth <- 0.15 testlambda <- 0.04 testthresh <- 1e-7 testmaxit <- 1e5 testsd <- 0.5 object <- pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = testsd, nlambda = 30L, thresh = testthresh, maxit = testmaxit) expected <- comparePcplus(testy, testlambda, testbandwidth, testsd, testthresh, testmaxit) expect_equal(object, expected) }) test_that("argument y is checked", { testy <- rnorm(100) testbandwidth <- 0.1 testlambda <- 0.03 expect_error(pcplus()) expect_error(pcplus(lambda = testlambda, bandwidth = testbandwidth)) expect_error(pcplus(y = NA, lambda = testlambda, bandwidth = testbandwidth)) expect_error(pcplus(y = as.numeric(NA), lambda = testlambda, bandwidth = testbandwidth)) expect_error(pcplus(y = c(testy, "s"), lambda = testlambda, bandwidth = testbandwidth)) expect_error(pcplus(y = c(testy, Inf), lambda = testlambda, bandwidth = testbandwidth)) expect_error(pcplus(y = c(-Inf, testy), lambda = testlambda, bandwidth = testbandwidth)) expect_error(pcplus(y = c(NaN, testy), lambda = testlambda, bandwidth = testbandwidth)) }) test_that("argument bandwidth is checked", { testy <- rnorm(100) testy[7:100] <- testy[7:100] + 50 testy[12:100] <- testy[12:100] + 20 testy[90:100] <- testy[90:100] + 20 testlambda <- seq(1, 0.05, -0.05) testthresh <- 1e-7 testmaxit <- 1e5 testsd <- 0.5 expect_error(pcplus(y = testy, lambda = testlambda)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = "s")) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = NA)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = -0.05)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = as.numeric(NA))) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = c(0.05, 0.1))) expect_equal(pcplus(y = testy, lambda = testlambda, bandwidth = Inf, sd = testsd), comparePcplusInf(testy, testsd)) expect_warning(object <- pcplus(y = testy, lambda = testlambda, bandwidth = 0.5, sd = testsd)) expect_equal(object, comparePcplusInf(testy, testsd)) expect_identical(pcplus(y = testy, lambda = Inf, bandwidth = Inf), list(est = rep(mean(testy), length(testy)), smooth = rep(mean(testy), length(testy)), cpfun = rep(0, length(testy)), cps = integer(0))) expect_warning(object <- pcplus(y = testy, lambda = testlambda, bandwidth = 0.005, sd = testsd, nlambda = 30L, thresh = testthresh, maxit = testmaxit)) expected <- pcplus(y = testy, lambda = testlambda, bandwidth = 0.01, sd = testsd, nlambda = 30L, thresh = testthresh, maxit = testmaxit) expect_equal(object, expected) }) test_that("argument lambda is checked", { testy <- rnorm(100) testy[7:100] <- testy[7:100] + 50 testy[12:100] <- testy[12:100] + 20 testy[90:100] <- testy[90:100] + 20 testbandwidth <- 0.1 testthresh <- 1e-7 testmaxit <- 1e5 testsd <- 0.5 expect_error(pcplus(y = testy, bandwidth = testbandwidth)) expect_error(pcplus(y = testy, lambda = "s", bandwidth = testbandwidth)) expect_error(pcplus(y = testy, lambda = NA, bandwidth = testbandwidth)) expect_error(pcplus(y = testy, lambda = -0.5, bandwidth = testbandwidth)) expect_error(pcplus(y = testy, lambda = as.numeric(NA), bandwidth = testbandwidth)) expect_equal(pcplus(y = testy, lambda = seq(1, 0.05, -0.05), bandwidth = testbandwidth), pcplus(y = testy, lambda = 0.05, bandwidth = testbandwidth, nlambda = 1), tolerance = 1e-12) expect_warning(object <- pcplus(y = testy, lambda = rev(seq(1, 0.05, -0.05)), bandwidth = testbandwidth)) expect_equal(object, pcplus(y = testy, lambda = 0.05, bandwidth = testbandwidth, nlambda = 1), tolerance = 1e-12) expect_warning(object <- pcplus(y = testy, lambda = c(seq(1, 0.2, -0.05), 0.05, 0.15, 0.1), bandwidth = testbandwidth)) expect_equal(object, pcplus(y = testy, lambda = 0.05, bandwidth = testbandwidth, nlambda = 1), tolerance = 1e-12) expect_error(pcplus(y = testy, lambda = c(seq(1, 0.05, -0.05), "s"), bandwidth = testbandwidth)) expect_error(pcplus(y = testy, lambda = c(as.numeric(NA), seq(1, 0.05, -0.05)), bandwidth = testbandwidth)) expect_error(pcplus(y = testy, lambda = c(seq(1, 0.5, -0.05), -0.05, seq(0.45, 0.05, -0.05)), bandwidth = testbandwidth)) object <- pcplus(y = testy, lambda = 1e12, bandwidth = testbandwidth, sd = testsd, nlambda = 1L, thresh = testthresh, maxit = testmaxit) expected <- comparePcplus(testy, 1e12, testbandwidth, testsd, testthresh, testmaxit) expect_equal(object, expected) compareSmooth <- compareKernelSmoothing(testy, testbandwidth) expect_equal(pcplus(y = testy, lambda = Inf, bandwidth = testbandwidth, nlambda = 1L), list(est = compareSmooth, smooth = compareSmooth, cpfun = rep(0, length(testy)), cps = integer(0))) }) test_that("argument sd is checked", { testy <- rnorm(100) testy[7:100] <- testy[7:100] + 50 testy[12:100] <- testy[12:100] + 20 testy[90:100] <- testy[90:100] + 20 testlambda <- seq(1, 0.05, -0.05) testbandwidth <- 0.05 testthresh <- 1e-7 testmaxit <- 1e5 testsd <- as.numeric(diff(quantile(diff(testy), c(0.25, 0.75))) / diff(qnorm(c(0.25, 0.75))) / sqrt(2)) expect_equal(pcplus(y = testy, lambda = testlambda, bandwidth = Inf), comparePcplusInf(testy, testsd)) object <- pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = 30L, thresh = testthresh, maxit = testmaxit) expected <- comparePcplus(testy, testlambda[length(testlambda)], testbandwidth, testsd, testthresh, testmaxit) expect_equal(object, expected) object <- pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = NULL, nlambda = 30L, thresh = testthresh, maxit = testmaxit) expect_equal(object, expected) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = "s")) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = NA)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = -0.05)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = NaN)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = as.numeric(NA))) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = c(0.05, 0.1))) }) test_that("argument nlambda is checked", { testy <- rnorm(100) testy[7:100] <- testy[7:100] + 50 testy[12:100] <- testy[12:100] + 20 testy[90:100] <- testy[90:100] + 20 testbandwidth <- 0.1 testlambda <- 0.05 testthresh <- 1e-7 testmaxit <- 1e5 testsd <- 0.5 expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = "s")) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = NA)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = NaN)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = Inf)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = -10)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = as.numeric(NA))) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = c(5, 10))) expect_identical(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth), pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = 30L)) expect_identical(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = 10), pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = 10L)) expect_equal(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = 1L), pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth)) expect_equal(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = 2L), pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth)) expect_equal(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = 5L), pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth)) expect_equal(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = 10L), pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth)) expect_equal(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = 20L), pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth)) expect_equal(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = 50L), pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth)) expect_equal(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, nlambda = 100L), pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth)) expect_identical(pcplus(y = testy, lambda = Inf, bandwidth = testbandwidth, nlambda = 30L), pcplus(y = testy, lambda = Inf, bandwidth = testbandwidth, nlambda = 1L)) }) test_that("argument thresh is checked", { testy <- rnorm(100) testy[7:100] <- testy[7:100] + 50 testy[12:100] <- testy[12:100] + 20 testy[90:100] <- testy[90:100] + 20 testbandwidth <- 0.1 testlambda <- seq(1, 0.05, -0.05) testmaxit <- 1e5 testsd <- 0.5 expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, thresh = "s")) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, thresh = NA)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, thresh = NaN)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, thresh = Inf)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, thresh = -10)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, thresh = 0)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, thresh = as.numeric(NA))) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, thresh = c(5, 10))) expect_identical(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth), pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, thresh = 1e-7)) object <- pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = testsd, nlambda = 30L, thresh = 1e-9, maxit = testmaxit) expected <- comparePcplus(testy, testlambda[length(testlambda)], testbandwidth, testsd, 1e-9, testmaxit) expect_equal(object, expected) object <- pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = testsd, nlambda = 30L, thresh = 1e-3, maxit = testmaxit) expected <- comparePcplus(testy, testlambda[length(testlambda)], testbandwidth, testsd, 1e-3, testmaxit) expect_equal(object, expected) object <- pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = testsd, nlambda = 30L, thresh = 1e-2, maxit = testmaxit) expected <- comparePcplus(testy, testlambda[length(testlambda)], testbandwidth, testsd, 1e-2, testmaxit) expect_equal(object, expected, tolerance = 1e-1) }) test_that("argument maxit is checked", { testy <- rnorm(100) testy[7:100] <- testy[7:100] + 50 testy[12:100] <- testy[12:100] + 20 testy[90:100] <- testy[90:100] + 20 testbandwidth <- 0.1 testlambda <- c(0.5, 0.4) testthresh <- 1e7 testsd <- 0.5 expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, maxit = "s")) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, maxit = NA)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, maxit = NaN)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, maxit = Inf)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, maxit = -10)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, maxit = 0)) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, maxit = as.numeric(NA))) expect_error(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, maxit = c(5, 10))) expect_identical(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth), pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, maxit = 1e5L)) expect_identical(pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth), pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, maxit = 1e5)) object <- pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = testsd, nlambda = 30L, thresh = testthresh, maxit = 1e3) expected <- comparePcplus(testy, testlambda[length(testlambda)], testbandwidth, testsd, testthresh, 1e3) expect_equal(object, expected) object <- pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = testsd, nlambda = 30L, thresh = testthresh, maxit = 5) expected <- comparePcplus(testy, testlambda[length(testlambda)], testbandwidth, testsd, testthresh, 5) expect_equal(object, expected) object <- pcplus(y = testy, lambda = testlambda, bandwidth = testbandwidth, sd = testsd, nlambda = 30L, thresh = testthresh, maxit = 1) expected <- comparePcplus(testy, testlambda[length(testlambda)], testbandwidth, testsd, testthresh, 1) expect_equal(object, expected) })