context("cpt.mean 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,1), rpois(50,2), rpois(50,3), rpois(50,5)) #lambda values correct? constantdata <- rep(1, 200) shortdata <- c(2) negativedata <- jitter(rep(-100, 200) ) characterdata <- rep("ert", 200) #NAdata - creates 10 random NA within singmeandata NAdata <- singmeandata rn <- sample(1:length(singmeandata), 10, replace=F) for(i in rn){ NAdata[i] <- NA } ################### data <- list(singmeandata,mulmeandata, nochangedata, constantdata, NAdata, shortdata, negativedata, characterdata) # 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") 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") #null, alt, tau*2 don't work (comes back with user defind error "your manual cannot be evaluated") manpenval <- list("-1") QValues <- list(3, -1, 'jamie', 200000) #data variable needs to be modified - larger than data length and over half data length #QValues <- c(3, 5) testStats <- c("Normal", "CUSUM") #asym and cusum return user defined "no asymptotic penalty" && "asymptotic penalties not implemented" class <- c(TRUE, FALSE) param.estimates <- c(TRUE, FALSE) minseglen <- c(-1, 10, 20000) 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 <- cpt.mean(data=data[[d]], penalty=penalties[p], pen.value=manpenval[[npv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe) # 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.mean(data=data[[d]], penalty=penalties[p], pen.value=manpenval[[npv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe), throws_error("Your manual penalty cannot be evaluated")) t = t + 1 } } if(manpenval[[npv]] < 0){ expect_that(cpt.mean(data=data[[d]], penalty=penalties[p], pen.value=manpenval[[npv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe), throws_error('pen.value cannot be negative, please change your penalty value')) } 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],", pen.value=", asympenval[[apv]],", method=",methods[m],",class=",cl,", param=",pe,", penvalue=",asympenval[[apv]],", test.stat=",testStats[ts]), { if(testStats[ts] == "CUSUM"){ expect_that(cpt.mean(data=data[[d]], penalty=penalties[p], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe), throws_error()) #edit this line to include specific error messsage } else if(is.numeric(asympenval[[apv]]) == FALSE){ expect_that(cpt.mean(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe), throws_error()) } else if(asympenval[[apv]] <= 0 || asympenval[[apv]] > 1){ expect_that(cpt.mean(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe), throws_error("Asymptotic penalty values must be > 0 and <= 1")) } else if(methods[m] == "PELT" || methods[m] == "BinSeg"){ expect_warning(cpt.mean(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe)) } else{ x <- cpt.mean(data=data[[d]], penalty=penalties[p], pen.value=asympenval[[apv]], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe) expect_that(2+2, equals(4)) } }) t = t+1 } } checkCROPS <- function(){ #test pen.value + its length + missing #test the returns of the class if(methods[m]!="PELT"){ expect_that(cpt.mean(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.mean(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.mean(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.mean(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.mean(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' } } 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.mean(data=data[[d]], penalty=penalties[p], method=methods[m], Q=aQv, test.stat=testStats[ts], class=cl, param.estimates=pe)) # if(length(data=data[[d]]) <= 2){ # expect_that(cpt.mean(data[[d]], penalty=penalties[p], 0, method=methods[m], QValues[[v]], testStats[ts], class=cl, pe), throws_error()) # } ###Returns properly#### if(cl == TRUE){ if(methods[m] == "PELT" || methods[m] == "AMOC"){ expect_that(x, is_a('cpt')) } else{ expect_that(x, is_a('cpt.range')) } ######change this based on methods ####check some values for the class }else if(cl == FALSE && methodLog == TRUE){ # expect_that(x, is_a('list')) #####this is now an integer in BINSEG. }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 }) } for(d in 1:length(data)){ if(is.element(NA, data[[d]])){ test_that(paste0("Test #",t," :data=",d), { expect_that(cpt.mean(data=data[[d]]),throws_error("Missing value: NA is not allowed in the data as changepoint methods are only sensible for regularly spaced data.")) t = t + 1 }) }else if(length(data[[d]]) < 2){ test_that(paste0("Test #",t," :data=",d), { expect_that(cpt.mean(data=data[[d]]),throws_error()) t = t + 1 }) }else if(is.numeric(data[[d]]) == FALSE){ test_that(paste0("Test #",t," :data=",d), { expect_that(cpt.mean(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){ Qv = 5 # if(t == 1112){ # browser() # } ####data checks#### if(penalties[p] == "CROPS"){ checkCROPS() }else{ #Q values only necessary when method is BINSEG or SEGNEIGH if(methods[m] == "BinSeg" || methods[m] == "SegNeigh"){ for(v in 1:length(QValues)){ 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.mean(data=data[[d]], penalty=penalties[p], method=methods[m], Q=QValues[[v]], test.stat=testStats[ts], class=cl, param.estimates=pe), throws_error()) }else if(QValues[[v]] < 0){ expect_that(cpt.mean(data=data[[d]], penalty=penalties[p], method=methods[m], Q=QValues[[v]], test.stat=testStats[ts], class=cl, param.estimates=pe), throws_error()) }else if(QValues[[v]] > (length(data[[d]]))/2+1){ expect_that(cpt.mean(data=data[[d]], penalty=penalties[p], method=methods[m], Q=QValues[[v]], test.stat=testStats[ts], class=cl, param.estimates=pe), throws_error()) #specific user defined 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 if(penalties[p]=="MBIC"){ if(testStats[ts]=="CUSUM"||testStats[ts]=="CSS"){ test_that(paste0("Test #",t," :data=", d, "penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts],"QVal=",Qv),expect_error(cpt.mean(data=data[[d]],penalty=penalties[p],method=methods[m],Q=aQv,test.stat=testStats[ts],class=cl,param.estimates=pe))) }else{ checkOtherPenalties(TRUE) } }else{ checkOtherPenalties(TRUE) } } }else{ #Normal and Asymptotic penalty pen values if(methods[m] == "PELT" && testStats[ts] == "CUSUM"){ test_that(paste0("Test #",t," :data=", d, "penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts],"QVal=",Qv), { expect_that(cpt.mean(data=data[[d]], penalty=penalties[p], method=methods[m], Q=Qv, test.stat=testStats[ts], class=cl, param.estimates=pe), throws_error("Invalid Method, must be AMOC, SegNeigh or BinSeg")) }) t = t + 1 }else{ if(penalties[p] == "Manual" ){ checkManualPenalty(FALSE) }else if(penalties[p] == "Asymptotic"){ checkAsymptoticPenalty(FALSE) }else if(penalties[p]=="MBIC"){ if(testStats[ts]=="CUSUM"||testStats[ts]=="CSS"){ test_that(paste0("Test #",t," :data=", d, "penalty=",penalties[p],", method=",methods[m],",class=",cl,", param=",pe,", test.stat=",testStats[ts],"QVal=",Qv),expect_error(cpt.mean(data=data[[d]],penalty=penalties[p],method=methods[m],Q=aQv,test.stat=testStats[ts],class=cl,param.estimates=pe))) }else{ checkOtherPenalties(FALSE) } }else{ checkOtherPenalties(FALSE) } } } } t = t+1 } } } } } } }