Bump test coverage of the multiple epochs implementation.

doccstat · Sep 4, 2023 · 39b88e7 · 39b88e7
1 parent b0b900a
commit 39b88e7
Show file tree

Hide file tree

Showing 5 changed files with 23 additions and 17 deletions.
diff --git a/R/fastcpd.R b/R/fastcpd.R
@@ -383,21 +383,17 @@ fastcpd <- function(
     vanilla_percentage <- 1
   }
 
-  # User provided cost function with explicit expression.
-  # } else if (vanilla) {
-  #   fastcpd_vanilla_custom(
-  #     data, beta, segment_count, trim, momentum_coef, k, epsilon,
-  #     min_prob, winsorise_minval, winsorise_maxval, p,
-  #     function(data) {
-  #       cost(data = data, theta = NULL, family = family, lambda = 0)
-  #     }, cp_only, warm_start
-  #   )
   result <- fastcpd_impl(
     data, beta, segment_count, trim, momentum_coef, k, family, epsilon,
     min_prob, winsorise_minval, winsorise_maxval, p, cost, cost_gradient,
     cost_hessian, cp_only, vanilla_percentage
   )
 
+  result$thetas <- data.frame(result$thetas)
+  if (ncol(result$thetas) > 0) {
+    names(result$thetas) <- paste0("segment ", seq_len(ncol(result$thetas)))
+  }
+
   methods::new(
     Class = "fastcpd",
     call = match.call(),
@@ -492,14 +488,14 @@ fastcpd_impl <- function(
     cval[r_t_count] <- 0
     # `beta` adjustment seems to work but there might be better choices.
     obj <- cval + f_t[r_t_set + 1] + beta
-    min_val <- min(obj)
-    tau_star <- r_t_set[which(obj == min_val)[1]]
+    min_obj <- min(obj)
+    tau_star <- r_t_set[which(obj == min_obj)[1]]
 
     # Step 4
     cp_set[[t + 1]] <- c(cp_set[[tau_star + 1]], tau_star)
 
     # Step 5
-    pruned_left <- (cval + f_t[r_t_set + 1]) <= min_val
+    pruned_left <- (cval + f_t[r_t_set + 1]) <= min_obj
     r_t_set <- c(r_t_set[pruned_left], t)
 
     if (vanilla_percentage != 1) {
@@ -509,7 +505,7 @@ fastcpd_impl <- function(
     }
 
     # Objective function F(t).
-    f_t[t + 1] <- min_val
+    f_t[t + 1] <- min_obj
   }
 
   # Remove change-points close to the boundaries

diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp
@@ -82,7 +82,7 @@ BEGIN_RCPP
 END_RCPP
 }
 // update_fastcpd_parameters
-List update_fastcpd_parameters(List fastcpd_parameters, arma::mat data, const int t, const int i, Function k, const int tau, const double lambda, const std::string family, Function cost_gradient, Function cost_hessian, arma::vec r_t_set, const int p, const double momentum_coef, const double min_prob, const double winsorise_minval, const double winsorise_maxval, const double epsilon);
+List update_fastcpd_parameters(List fastcpd_parameters, arma::mat data, const int t, const int i, Function k, const int tau, const double lambda, const std::string family, Function cost_gradient, Function cost_hessian, arma::ucolvec r_t_set, const int p, const double momentum_coef, const double min_prob, const double winsorise_minval, const double winsorise_maxval, const double epsilon);
 RcppExport SEXP _fastcpd_update_fastcpd_parameters(SEXP fastcpd_parametersSEXP, SEXP dataSEXP, SEXP tSEXP, SEXP iSEXP, SEXP kSEXP, SEXP tauSEXP, SEXP lambdaSEXP, SEXP familySEXP, SEXP cost_gradientSEXP, SEXP cost_hessianSEXP, SEXP r_t_setSEXP, SEXP pSEXP, SEXP momentum_coefSEXP, SEXP min_probSEXP, SEXP winsorise_minvalSEXP, SEXP winsorise_maxvalSEXP, SEXP epsilonSEXP) {
 BEGIN_RCPP
     Rcpp::RObject rcpp_result_gen;
@@ -97,7 +97,7 @@ BEGIN_RCPP
     Rcpp::traits::input_parameter< const std::string >::type family(familySEXP);
     Rcpp::traits::input_parameter< Function >::type cost_gradient(cost_gradientSEXP);
     Rcpp::traits::input_parameter< Function >::type cost_hessian(cost_hessianSEXP);
-    Rcpp::traits::input_parameter< arma::vec >::type r_t_set(r_t_setSEXP);
+    Rcpp::traits::input_parameter< arma::ucolvec >::type r_t_set(r_t_setSEXP);
     Rcpp::traits::input_parameter< const int >::type p(pSEXP);
     Rcpp::traits::input_parameter< const double >::type momentum_coef(momentum_coefSEXP);
     Rcpp::traits::input_parameter< const double >::type min_prob(min_probSEXP);

diff --git a/src/fastcpd.cc b/src/fastcpd.cc
@@ -319,7 +319,7 @@ List update_fastcpd_parameters(
     const std::string family,
     Function cost_gradient,
     Function cost_hessian,
-    arma::vec r_t_set,
+    arma::ucolvec r_t_set,
     const int p,
     const double momentum_coef,
     const double min_prob,

diff --git a/src/fastcpd.h b/src/fastcpd.h
@@ -162,7 +162,7 @@ List update_fastcpd_parameters(
     const std::string family,
     Function cost_gradient,
     Function cost_hessian,
-    arma::vec r_t_set,
+    arma::ucolvec r_t_set,
     const int p,
     const double momentum_coef,
     const double min_prob,

diff --git a/tests/testthat/test-fastcpd.R b/tests/testthat/test-fastcpd.R
@@ -73,7 +73,17 @@ test_that("poisson regression", {
     epsilon = 1e-5
   )
 
+  result_two_epochs <- fastcpd(
+    formula = y ~ . - 1,
+    data = data.frame(y = y, x = x),
+    beta = (p + 1) * log(1500) / 2,
+    k = function(x) 1,
+    family = "poisson",
+    epsilon = 1e-5
+  )
+
   expect_equal(result@cp_set, c(329, 728, 1021, 1107, 1325))
+  expect_equal(result_two_epochs@cp_set, c(328, 716, 1020, 1102, 1323))
 })
 
 test_that("penalized linear regression", {