fix return code handling, add iterations to output

helske · Sep 21, 2024 · 53d0b37 · 53d0b37
1 parent 6d44d0b
commit 53d0b37
Show file tree

Hide file tree

Showing 3 changed files with 12 additions and 10 deletions.
diff --git a/R/fit_mnhmm.R b/R/fit_mnhmm.R
@@ -163,7 +163,7 @@ fit_mnhmm <- function(model, inits, init_sd, restarts, threads, hessian, ...) {
 
     logliks <- unlist(lapply(out, "[[", "objective"))
     return_codes <- unlist(lapply(out, "[[", "status"))
-    successful <- which(return_codes == 0)
+    successful <- which(return_codes > 0)
     optimum <- successful[which.max(logliks[successful])]
     init <- out[[optimum]]$solution
   } else {
@@ -182,7 +182,7 @@ fit_mnhmm <- function(model, inits, init_sd, restarts, threads, hessian, ...) {
     opts = dots
   )
   if (out$status < 0) {
-    warning_(paste("Local optimization terminated:", out$message))
+    warning_(paste("Optimization terminated due to error:", out$message))
   }
   pars <- out$solution
   model$coefficients$gamma_pi_raw <- create_gamma_pi_raw_mnhmm(
@@ -222,6 +222,7 @@ fit_mnhmm <- function(model, inits, init_sd, restarts, threads, hessian, ...) {
     loglik = out$objective, 
     return_code = out$status,
     message = out$message,
+    iterations = out$iterations,
     logliks_of_restarts = if(restarts > 0L) logliks else NULL, 
     return_codes_of_restarts = if(restarts > 0L) return_codes else NULL
   )

diff --git a/R/fit_nhmm.R b/R/fit_nhmm.R
@@ -133,7 +133,7 @@ fit_nhmm <- function(model, inits, init_sd, restarts, threads, hessian, ...) {
 
     logliks <- unlist(lapply(out, "[[", "objective"))
     return_codes <- unlist(lapply(out, "[[", "status"))
-    successful <- which(return_codes == 0)
+    successful <- which(return_codes > 0)
     optimum <- successful[which.max(logliks[successful])]
     init <- out[[optimum]]$solution
   } else {
@@ -152,7 +152,7 @@ fit_nhmm <- function(model, inits, init_sd, restarts, threads, hessian, ...) {
     opts = dots
   )
   if (out$status < 0) {
-    warning_(paste("Local optimization terminated:", out$message))
+    warning_(paste("Optimization terminated due to error:", out$message))
   }
   pars <- out$solution
   model$coefficients$gamma_pi_raw <- create_gamma_pi_raw_nhmm(pars[seq_len(n_i)], S, K_i)
@@ -185,6 +185,7 @@ fit_nhmm <- function(model, inits, init_sd, restarts, threads, hessian, ...) {
     loglik = out$objective, 
     return_code = out$status,
     message = out$message,
+    iterations = out$iterations,
     logliks_of_restarts = if(restarts > 0L) logliks else NULL, 
     return_codes_of_restarts = if(restarts > 0L) return_codes else NULL
   )

diff --git a/tests/testthat/test-forward_backward.R b/tests/testthat/test-forward_backward.R
@@ -39,7 +39,7 @@ test_that("'forward_backward' works for multichannel 'nhmm'", {
       hmm_biofam$observations, n_states = 5,
       inits = hmm_biofam[
         c("initial_probs", "transition_probs", "emission_probs")
-      ]
+      ], maxeval = 1
     ),
     NA
   )
@@ -65,16 +65,16 @@ test_that("'forward_backward' works for single-channel 'nhmm'", {
   expect_error(
     fit <- estimate_nhmm(
       hmm_biofam$observations[[1]], n_states = 3,
-      restarts = 2, threads = 1
+      restarts = 2, threads = 1, maxeval = 2
     ),
     NA
   )
   expect_error(
     fb <- forward_backward(fit, as_data_frame = FALSE),
     NA
   )
-  expect_gte(min(fb$forward_probs), -60)
-  expect_gte(min(fb$backward_probs), -60)
+  expect_gte(min(fb$forward_probs), -2000)
+  expect_gte(min(fb$backward_probs), -2000)
   expect_lte(max(fb$forward_probs), 0)
   expect_lte(max(fb$backward_probs), 0)
 
@@ -99,8 +99,8 @@ test_that("'forward_backward' works for multichannel 'mnhmm'", {
     fb <- forward_backward(fit, as_data_frame = FALSE),
     NA
   )
-  expect_gte(min(fb$forward_probs), -130)
-  expect_gte(min(fb$backward_probs), -120)
+  expect_gte(min(fb$forward_probs), -2000)
+  expect_gte(min(fb$backward_probs), -2000)
   expect_lte(max(fb$forward_probs), 0)
   expect_lte(max(fb$backward_probs), 0)