Nothing
tests/testthat/test-cptmeanvar.R
In changepoint: Methods for Changepoint Detection
context("cpt.meanvar tests")
set.seed(1) # Note: new data sets must be added at the end.
singmeandata <- c(rnorm(100,0,1),rnorm(100,10,1))
mulmeandata <- c(rnorm(100,0,1),rnorm(100,10,1),rnorm(100,20,1),rnorm(100,50,1))
nochangedata <- c(rnorm(200,0,1))
singvardata <- c(rnorm(100,10,1),rnorm(100,10,5))
mulvardata <- c(rnorm(100,20,10),rnorm(100,20,15),rnorm(100,20,20),rnorm(100,20,25))
singmeanvardata <- c(rnorm(50,0,1),rnorm(50,3,10))
mulmeanvardata <- c(rnorm(50,0,1),rnorm(50,5,3),rnorm(50,10,1),rnorm(50,3,10))
mulmeanvarexpdata <- c(rexp(50,1), rexp(50,3), rexp(50,5), rexp(50,7)) #rate values correct
mulmeanvarpoisdata <- c(rpois(50,10), rpois(50,20), rpois(50,15), rpois(50,25)) #lambda values correct?
constantdata <- rep(1, 200)
shortdata <- c(2,4)
negativedata <- jitter(rep(-100, 200) )
#NAdata - creates 10 random NA within singmeandata
NAdata <- singmeanvardata
rn <- sample(1:length(singmeanvardata), 10, replace=F)
for(i in rn){
NAdata[i] <- NA
}
###################
data <- list(singmeanvardata,mulmeanvardata, mulmeanvarexpdata, mulmeanvarpoisdata, nochangedata, constantdata, NAdata, shortdata, negativedata)
# meandata <- list(singmeandata, mulmeandata, nochangedata)
# vardata <- list(singvardata, mulvardata, nochangedata)
# meanvardata <- list(singmeanvardata, mulmeanvardata, nochangedata)
methods <- c("AMOC", "PELT", "BinSeg") #might want to change code to convert to uppercase so less likely to break code
#Segneigh taking too long and deprecation, so leaving until very last.
#methods <- c("AMOC")
penalties <- c("None", "SIC", "BIC", "AIC", "Hannan-Quinn", "Asymptotic", "Manual", "MBIC") #CROPS segfaulting
asympenval <- list(1, 0.756, 0.234, 'return', -1, 0) #need to add character string and -1 and 0
#manpenval <- list("2+log(n)", "log(n)", "3*n", -1, "diffparam-1")
manpenval <- list(1)
QValues <- list(3, -1, 'jamie', 200000)
#QValues <- c(3, 5)
testStats <- c("Normal", "Gamma", "Exponential", "Poisson")
class <- c(TRUE, FALSE)
param.estimates <- c(TRUE, FALSE)
shap <- c(1)
cropspenval = list(c(2,2.5), c(3,1), c(5,5,6), c("a", "b"), 5, "a")
t = 0 #count for number of iterations
checkManualPenalty <- function(methodLog){
aQv <- Qv
if(methodLog == TRUE){
aqV <- QValues[[v]]
}
for(npv in 1:length(manpenval)){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", penvalue=",manpenval[npv],", test.stat=",testStats[ts]) ,{
x <- suppressWarnings(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=manpenval[[npv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]))
# browser()
if(is.numeric(manpenval[[npv]]) == FALSE){
texttest = try(eval(parse(text=paste(manpenval[[npv]]))),silent=TRUE)
if(class(texttest)=='try-error'){
expect_that(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=manpenval[[npv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error("Your manual penalty cannot be evaluated"))
#currently failing on text that says can be used in the help file.
}
}
# if(manpenval[[npv]] < 0){
# expect_that(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=manpenval[[npv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error())
# #failing test (is this correct that must be +ve?)
# }
# expect_that(2+2, equals(4))
})
t = t+1
}
}
checkAsymptoticPenalty <- function(methodLog){
aQv <- Qv
if(methodLog == TRUE){
aqV <- QValues[[v]]
}
for(apv in 1:length(asympenval)){
# browser()
test_that(paste0("Test #",t," : data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", penvalue=",asympenval[apv],", test.stat=",testStats[ts]), {
if(is.numeric(asympenval[[apv]]) == FALSE){
expect_that(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error())
#not user friendly error "Error in 1 - alpha : non-numeric argument to binary operator"
}else if(asympenval[[apv]] <= 0 || asympenval[[apv]] > 1){
expect_that(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error('Asymptotic penalty values must be > 0 and <= 1'))
#NA Error?
}
else if(testStats[ts]=="Gamma"){
expect_error(suppressWarnings(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh])),'Asymptotic penalties for the Gamma test statistic are not defined, please choose an alternative penalty type')
}
else if(methods[m] == "PELT" || methods[m] == "BinSeg"){
expect_warning(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]))
}
else{
x <- cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh])
expect_that(2+2, equals(4))
}
})
t = t+1
}
}
checkOtherPenalties <- function(methodLog){
aQv <- Qv
if(methodLog == TRUE){
aqV <- QValues[[v]]
}
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
x <- suppressWarnings(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=0,shape=shap[sh], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe))
# if(length(data=data[[d]]) <= 2){
# expect_that(cpt.meanvar(data[[d]], penalty=penalties[p], 0, method=methods[m], QValues[[v]], testStats[ts], class=cl, pe), throws_error())
# }
###Returns properly####
if(cl == TRUE){
expect_that(x, is_a('cpt'))
}else if(cl == FALSE && methodLog == TRUE){
#expect_that(x, is_a('list'))#
}else if(cl == FALSE && methodLog == FALSE){
if(methods[m] == "PELT"){
# expect_that(x, is_a('integer'))
}
# }else if(methods[m] == "AMOC"){
# #if(testStats[ts] == "CUSUM"){
# expect_that(x, is_a('numeric'))
# #}else if(testStats[ts] != "CUSUM"){
# # expect_that(x, is_a('integer'))
# #}
# }
}
})
t = t + 1
}
checkCROPS <- function(){
#test pen.value + its length + missing
#test the returns of the class
if(methods[m]!="PELT"){
expect_that(cpt.meanvar(data=data[[d]], method=methods[m],penalty=penalties[p], pen.value=cropspenval[[1]], test.stat=testStats[[ts]], class=cl, param.estimates=pe), throws_error('CROPS is a valid penalty choice only if method="PELT", please change your method or your penalty.'))
t=t+1
}
else{
for(cr in 1:length(cropspenval)){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", penval=",cropspenval[cr],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
if(is.numeric(cropspenval[[cr]]) == FALSE ){
expect_that(cpt.meanvar(data=data[[d]], method=methods[m],penalty=penalties[p], pen.value=cropspenval[[cr]], test.stat=testStats[[ts]], class=cl, param.estimates=pe), throws_error('For CROPS, pen.value must be supplied'))
}else if(length(cropspenval[[cr]]) != 2 ){
expect_that(cpt.meanvar(data=data[[d]], method=methods[m],penalty=penalties[p], pen.value=cropspenval[[cr]], test.stat=testStats[[ts]],class=cl, param.estimates=pe), throws_error('The length of pen.value must be 2'))
}else{
# expect_that(cpt.mean(data=data[[d]], penalty=penalties[p], class=cl, param.estimates=pe), throws_error('For CROPS, pen.value must be supplied'))
if(testStats[[ts]] == "Normal" || testStats[[ts]] == "Gamma" || testStats[[ts]] == "Exponential" || testStats[[ts]] == "Poisson" ){
x <- cpt.meanvar(data=data[[d]], method=methods[m],penalty=penalties[p], pen.value=cropspenval[[cr]], test.stat=testStats[[ts]], class=cl, param.estimates=pe)
if(cl == TRUE){
expect_that(x, is_a('cpt.range'))
}
}else{
expect_that(cpt.meanvar(data=data[[d]], method=methods[m],penalty=penalties[p], pen.value=cropspenval[[cr]], test.stat=testStats[[ts]], class=cl, param.estimates=pe), throws_error('Only Normal, Exponential, Gamma and Poisson are valid test statistics'))
}
}
t=t+1
})
}
#numeric return 'For CROPS, pen.value must be supplied'
#length return 'The length of pen.value must be 2'
}
}
for(d in 1:length(data)){
if(is.element(NA, data[[d]])){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]]),throws_error('Missing value: NA is not allowed in the data as changepoint methods are only sensible for regularly spaced data.'))
#not user friendly error : Error in if (teststat >= pen.value) { :
# missing value where TRUE/FALSE needed
# In addition: Warning message:
# In min(tmp, na.rm = T) : no non-missing arguments to min; returning Inf
t = t + 1
})
}else if(length(data[[d]]) <= 2){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]],method="AMOC"),throws_error("Data must have atleast"))
t = t + 1
})
}else if(is.numeric(data[[d]]) == FALSE){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]]),throws_error('Only numeric data allowed'))
t = t + 1
})
}
else{
for(p in 1:length(penalties)){
for(m in 1:length(methods)){
for(ts in 1:length(testStats)){
for(cl in class){
for(pe in param.estimates){
for(sh in 1:length(shap)){
Qv = 5
if(penalties[p] == "CROPS"){
checkCROPS()
}else{
if(testStats[ts] == "Gamma" ){
if( (sum(data[[d]]<0)) >0){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]], penalty=penalties[p], method=methods[m], Q=Qv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]),throws_error("Gamma test statistic requires positive data"))
t = t + 1
})
}else if(penalties[p] == "Asymptotic"){
checkAsymptoticPenalty(FALSE)
}
}else if(testStats[ts] == "Exponential" && (sum(data[[d]]<0)) >0){
##THROWING ERROR on poisson data with exponential??
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]], method=methods[m], Q=Qv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]),throws_error("Exponential test statistic requires positive data"))
t = t + 1
})
}else if(testStats[ts] == "Poisson" ){
if ((sum(data[[d]]<0)) >0){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]], penalty="SIC", method=methods[m], Q=Qv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]),throws_error("Poisson test statistic requires positive data"))
t = t + 1
})
}else if(is.integer(data[[d]]) == FALSE && d != 6){
## NOT FAILING ON CONSTANT DATA but is numeric type
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]], penalty="SIC", method=methods[m], Q=Qv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]),throws_error("Poisson test statistic requires integer data"))
})
}
}else{
#Q values only necessary when method is BINSEG or SEGNEIGH
if(methods[m] == "BinSeg" || methods[m] == "SegNeigh"){
for(v in 1:length(QValues)){
#causing a slight problem with when CSS and Asymptotic as cpt.meanvar throws wrong error
#if statement to get around it? if(teststat=CSS and pen=asymptotic)? loses tests?
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts],"QVal=",QValues[[v]]), {
if(is.numeric(QValues[[v]]) == FALSE){
expect_that(cpt.meanvar(data=data[[d]], method=methods[m], Q=QValues[[v]], test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error())
#error is not user friendly
}else if(QValues[[v]] < 0){
expect_that(cpt.meanvar(data=data[[d]], method=methods[m], Q=QValues[[v]], test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error())
#error is not user friendly
}else if(QValues[[v]] > (length(data[[d]])/2+1)){
expect_that(cpt.meanvar(data=data[[d]], method=methods[m], Q=QValues[[v]], test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error("Q is larger than the maximum number of segments"))
#specific user deined error "Q is larger than the maximum number of segments"
}
t = t + 1
})
if(penalties[p] == "Manual" ){
checkManualPenalty(TRUE)
}else if(penalties[p] == "Asymptotic"){
checkAsymptoticPenalty(TRUE)
}else{
checkOtherPenalties(TRUE)
}
}
}else{
#Normal and Asymptotic penalty pen values
if(penalties[p] == "Manual" ){
checkManualPenalty(FALSE)
}else if(penalties[p] == "Asymptotic"){
checkAsymptoticPenalty(FALSE)
}else{
checkOtherPenalties(FALSE)
}
}
}
}
t=t+1
}
}
}
}
}
}
}
}
Try the changepoint package in your browser
Any scripts or data that you put into this service are public.
changepoint documentation built on Nov. 4, 2024, 9:06 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("cpt.meanvar tests")
set.seed(1) # Note: new data sets must be added at the end.
singmeandata <- c(rnorm(100,0,1),rnorm(100,10,1))
mulmeandata <- c(rnorm(100,0,1),rnorm(100,10,1),rnorm(100,20,1),rnorm(100,50,1))
nochangedata <- c(rnorm(200,0,1))
singvardata <- c(rnorm(100,10,1),rnorm(100,10,5))
mulvardata <- c(rnorm(100,20,10),rnorm(100,20,15),rnorm(100,20,20),rnorm(100,20,25))
singmeanvardata <- c(rnorm(50,0,1),rnorm(50,3,10))
mulmeanvardata <- c(rnorm(50,0,1),rnorm(50,5,3),rnorm(50,10,1),rnorm(50,3,10))
mulmeanvarexpdata <- c(rexp(50,1), rexp(50,3), rexp(50,5), rexp(50,7)) #rate values correct
mulmeanvarpoisdata <- c(rpois(50,10), rpois(50,20), rpois(50,15), rpois(50,25)) #lambda values correct?
constantdata <- rep(1, 200)
shortdata <- c(2,4)
negativedata <- jitter(rep(-100, 200) )
#NAdata - creates 10 random NA within singmeandata
NAdata <- singmeanvardata
rn <- sample(1:length(singmeanvardata), 10, replace=F)
for(i in rn){
NAdata[i] <- NA
}
###################
data <- list(singmeanvardata,mulmeanvardata, mulmeanvarexpdata, mulmeanvarpoisdata, nochangedata, constantdata, NAdata, shortdata, negativedata)
# meandata <- list(singmeandata, mulmeandata, nochangedata)
# vardata <- list(singvardata, mulvardata, nochangedata)
# meanvardata <- list(singmeanvardata, mulmeanvardata, nochangedata)
methods <- c("AMOC", "PELT", "BinSeg") #might want to change code to convert to uppercase so less likely to break code
#Segneigh taking too long and deprecation, so leaving until very last.
#methods <- c("AMOC")
penalties <- c("None", "SIC", "BIC", "AIC", "Hannan-Quinn", "Asymptotic", "Manual", "MBIC") #CROPS segfaulting
asympenval <- list(1, 0.756, 0.234, 'return', -1, 0) #need to add character string and -1 and 0
#manpenval <- list("2+log(n)", "log(n)", "3*n", -1, "diffparam-1")
manpenval <- list(1)
QValues <- list(3, -1, 'jamie', 200000)
#QValues <- c(3, 5)
testStats <- c("Normal", "Gamma", "Exponential", "Poisson")
class <- c(TRUE, FALSE)
param.estimates <- c(TRUE, FALSE)
shap <- c(1)
cropspenval = list(c(2,2.5), c(3,1), c(5,5,6), c("a", "b"), 5, "a")
t = 0 #count for number of iterations
checkManualPenalty <- function(methodLog){
aQv <- Qv
if(methodLog == TRUE){
aqV <- QValues[[v]]
}
for(npv in 1:length(manpenval)){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", penvalue=",manpenval[npv],", test.stat=",testStats[ts]) ,{
x <- suppressWarnings(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=manpenval[[npv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]))
# browser()
if(is.numeric(manpenval[[npv]]) == FALSE){
texttest = try(eval(parse(text=paste(manpenval[[npv]]))),silent=TRUE)
if(class(texttest)=='try-error'){
expect_that(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=manpenval[[npv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error("Your manual penalty cannot be evaluated"))
#currently failing on text that says can be used in the help file.
}
}
# if(manpenval[[npv]] < 0){
# expect_that(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=manpenval[[npv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error())
# #failing test (is this correct that must be +ve?)
# }
# expect_that(2+2, equals(4))
})
t = t+1
}
}
checkAsymptoticPenalty <- function(methodLog){
aQv <- Qv
if(methodLog == TRUE){
aqV <- QValues[[v]]
}
for(apv in 1:length(asympenval)){
# browser()
test_that(paste0("Test #",t," : data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", penvalue=",asympenval[apv],", test.stat=",testStats[ts]), {
if(is.numeric(asympenval[[apv]]) == FALSE){
expect_that(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error())
#not user friendly error "Error in 1 - alpha : non-numeric argument to binary operator"
}else if(asympenval[[apv]] <= 0 || asympenval[[apv]] > 1){
expect_that(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error('Asymptotic penalty values must be > 0 and <= 1'))
#NA Error?
}
else if(testStats[ts]=="Gamma"){
expect_error(suppressWarnings(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh])),'Asymptotic penalties for the Gamma test statistic are not defined, please choose an alternative penalty type')
}
else if(methods[m] == "PELT" || methods[m] == "BinSeg"){
expect_warning(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]))
}
else{
x <- cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh])
expect_that(2+2, equals(4))
}
})
t = t+1
}
}
checkOtherPenalties <- function(methodLog){
aQv <- Qv
if(methodLog == TRUE){
aqV <- QValues[[v]]
}
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
x <- suppressWarnings(cpt.meanvar(data=data[[d]], penalty=penalties[p], pen.value=0,shape=shap[sh], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe))
# if(length(data=data[[d]]) <= 2){
# expect_that(cpt.meanvar(data[[d]], penalty=penalties[p], 0, method=methods[m], QValues[[v]], testStats[ts], class=cl, pe), throws_error())
# }
###Returns properly####
if(cl == TRUE){
expect_that(x, is_a('cpt'))
}else if(cl == FALSE && methodLog == TRUE){
#expect_that(x, is_a('list'))#
}else if(cl == FALSE && methodLog == FALSE){
if(methods[m] == "PELT"){
# expect_that(x, is_a('integer'))
}
# }else if(methods[m] == "AMOC"){
# #if(testStats[ts] == "CUSUM"){
# expect_that(x, is_a('numeric'))
# #}else if(testStats[ts] != "CUSUM"){
# # expect_that(x, is_a('integer'))
# #}
# }
}
})
t = t + 1
}
checkCROPS <- function(){
#test pen.value + its length + missing
#test the returns of the class
if(methods[m]!="PELT"){
expect_that(cpt.meanvar(data=data[[d]], method=methods[m],penalty=penalties[p], pen.value=cropspenval[[1]], test.stat=testStats[[ts]], class=cl, param.estimates=pe), throws_error('CROPS is a valid penalty choice only if method="PELT", please change your method or your penalty.'))
t=t+1
}
else{
for(cr in 1:length(cropspenval)){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", penval=",cropspenval[cr],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
if(is.numeric(cropspenval[[cr]]) == FALSE ){
expect_that(cpt.meanvar(data=data[[d]], method=methods[m],penalty=penalties[p], pen.value=cropspenval[[cr]], test.stat=testStats[[ts]], class=cl, param.estimates=pe), throws_error('For CROPS, pen.value must be supplied'))
}else if(length(cropspenval[[cr]]) != 2 ){
expect_that(cpt.meanvar(data=data[[d]], method=methods[m],penalty=penalties[p], pen.value=cropspenval[[cr]], test.stat=testStats[[ts]],class=cl, param.estimates=pe), throws_error('The length of pen.value must be 2'))
}else{
# expect_that(cpt.mean(data=data[[d]], penalty=penalties[p], class=cl, param.estimates=pe), throws_error('For CROPS, pen.value must be supplied'))
if(testStats[[ts]] == "Normal" || testStats[[ts]] == "Gamma" || testStats[[ts]] == "Exponential" || testStats[[ts]] == "Poisson" ){
x <- cpt.meanvar(data=data[[d]], method=methods[m],penalty=penalties[p], pen.value=cropspenval[[cr]], test.stat=testStats[[ts]], class=cl, param.estimates=pe)
if(cl == TRUE){
expect_that(x, is_a('cpt.range'))
}
}else{
expect_that(cpt.meanvar(data=data[[d]], method=methods[m],penalty=penalties[p], pen.value=cropspenval[[cr]], test.stat=testStats[[ts]], class=cl, param.estimates=pe), throws_error('Only Normal, Exponential, Gamma and Poisson are valid test statistics'))
}
}
t=t+1
})
}
#numeric return 'For CROPS, pen.value must be supplied'
#length return 'The length of pen.value must be 2'
}
}
for(d in 1:length(data)){
if(is.element(NA, data[[d]])){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]]),throws_error('Missing value: NA is not allowed in the data as changepoint methods are only sensible for regularly spaced data.'))
#not user friendly error : Error in if (teststat >= pen.value) { :
# missing value where TRUE/FALSE needed
# In addition: Warning message:
# In min(tmp, na.rm = T) : no non-missing arguments to min; returning Inf
t = t + 1
})
}else if(length(data[[d]]) <= 2){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]],method="AMOC"),throws_error("Data must have atleast"))
t = t + 1
})
}else if(is.numeric(data[[d]]) == FALSE){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]]),throws_error('Only numeric data allowed'))
t = t + 1
})
}
else{
for(p in 1:length(penalties)){
for(m in 1:length(methods)){
for(ts in 1:length(testStats)){
for(cl in class){
for(pe in param.estimates){
for(sh in 1:length(shap)){
Qv = 5
if(penalties[p] == "CROPS"){
checkCROPS()
}else{
if(testStats[ts] == "Gamma" ){
if( (sum(data[[d]]<0)) >0){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]], penalty=penalties[p], method=methods[m], Q=Qv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]),throws_error("Gamma test statistic requires positive data"))
t = t + 1
})
}else if(penalties[p] == "Asymptotic"){
checkAsymptoticPenalty(FALSE)
}
}else if(testStats[ts] == "Exponential" && (sum(data[[d]]<0)) >0){
##THROWING ERROR on poisson data with exponential??
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]], method=methods[m], Q=Qv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]),throws_error("Exponential test statistic requires positive data"))
t = t + 1
})
}else if(testStats[ts] == "Poisson" ){
if ((sum(data[[d]]<0)) >0){
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]], penalty="SIC", method=methods[m], Q=Qv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]),throws_error("Poisson test statistic requires positive data"))
t = t + 1
})
}else if(is.integer(data[[d]]) == FALSE && d != 6){
## NOT FAILING ON CONSTANT DATA but is numeric type
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts]), {
expect_that(cpt.meanvar(data=data[[d]], penalty="SIC", method=methods[m], Q=Qv, test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]),throws_error("Poisson test statistic requires integer data"))
})
}
}else{
#Q values only necessary when method is BINSEG or SEGNEIGH
if(methods[m] == "BinSeg" || methods[m] == "SegNeigh"){
for(v in 1:length(QValues)){
#causing a slight problem with when CSS and Asymptotic as cpt.meanvar throws wrong error
#if statement to get around it? if(teststat=CSS and pen=asymptotic)? loses tests?
test_that(paste0("Test #",t," :data=",d,"penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts],"QVal=",QValues[[v]]), {
if(is.numeric(QValues[[v]]) == FALSE){
expect_that(cpt.meanvar(data=data[[d]], method=methods[m], Q=QValues[[v]], test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error())
#error is not user friendly
}else if(QValues[[v]] < 0){
expect_that(cpt.meanvar(data=data[[d]], method=methods[m], Q=QValues[[v]], test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error())
#error is not user friendly
}else if(QValues[[v]] > (length(data[[d]])/2+1)){
expect_that(cpt.meanvar(data=data[[d]], method=methods[m], Q=QValues[[v]], test.stat=testStats[ts], class=cl, param.estimates=pe, shape=shap[sh]), throws_error("Q is larger than the maximum number of segments"))
#specific user deined error "Q is larger than the maximum number of segments"
}
t = t + 1
})
if(penalties[p] == "Manual" ){
checkManualPenalty(TRUE)
}else if(penalties[p] == "Asymptotic"){
checkAsymptoticPenalty(TRUE)
}else{
checkOtherPenalties(TRUE)
}
}
}else{
#Normal and Asymptotic penalty pen values
if(penalties[p] == "Manual" ){
checkManualPenalty(FALSE)
}else if(penalties[p] == "Asymptotic"){
checkAsymptoticPenalty(FALSE)
}else{
checkOtherPenalties(FALSE)
}
}
}
}
t=t+1
}
}
}
}
}
}
}
}
Try the changepoint 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.