From b07f9fcb7468ac1b5fab0924328fba36ae943be5 Mon Sep 17 00:00:00 2001
From: Johannes Ranke <jranke@uni-bremen.de>
Date: Sun, 26 Nov 2023 20:38:30 +0100
Subject: Deal with 'saem' fits failing when updating an 'mhmkin' object

---
 R/mhmkin.R | 28 +++++++++++++++++++++-------
 R/status.R | 18 +++++++++++-------
 2 files changed, 32 insertions(+), 14 deletions(-)

(limited to 'R')

diff --git a/R/mhmkin.R b/R/mhmkin.R
index 6265a59e..14a7ac29 100644
--- a/R/mhmkin.R
+++ b/R/mhmkin.R
@@ -219,11 +219,22 @@ print.mhmkin <- function(x, ...) {
   print(status(x))
 }
 
+#' Check if fit within an mhmkin object failed
+#' @param x The object to be checked
+check_failed <- function(x) {
+  if (inherits(x, "try-error")) {
+    return(TRUE)
+  } else {
+    if (inherits(x$so, "try-error")) {
+      return(TRUE)
+    } else {
+      return(FALSE)
+    }
+  }
+}
+
 #' @export
 AIC.mhmkin <- function(object, ..., k = 2) {
-  if (inherits(object[[1]], "saem.mmkin")) {
-    check_failed <- function(x) if (inherits(x$so, "try-error")) TRUE else FALSE
-  }
   res <- sapply(object, function(x) {
     if (check_failed(x)) return(NA)
     else return(AIC(x$so, k = k))
@@ -235,9 +246,6 @@ AIC.mhmkin <- function(object, ..., k = 2) {
 
 #' @export
 BIC.mhmkin <- function(object, ...) {
-  if (inherits(object[[1]], "saem.mmkin")) {
-    check_failed <- function(x) if (inherits(x$so, "try-error")) TRUE else FALSE
-  }
   res <- sapply(object, function(x) {
     if (check_failed(x)) return(NA)
     else return(BIC(x$so))
@@ -280,7 +288,13 @@ anova.mhmkin <- function(object, ...,
   if (identical(model.names, "auto")) {
     model.names <- outer(rownames(object), colnames(object), paste)
   }
-  rlang::inject(anova(!!!(object), method = method, test = test,
+  failed_index <- which(sapply(object, check_failed), arr.ind = TRUE)
+  if (length(failed_index > 0)) {
+    rlang::inject(anova(!!!(object[-failed_index]), method = method, test = test,
+      model.names = model.names[-failed_index]))
+  } else {
+    rlang::inject(anova(!!!(object), method = method, test = test,
       model.names = model.names))
+  }
 }
 
diff --git a/R/status.R b/R/status.R
index 8bcd3a16..f9d79e7d 100644
--- a/R/status.R
+++ b/R/status.R
@@ -74,15 +74,19 @@ print.status.mmkin <- function(x, ...) {
 status.mhmkin <- function(object, ...) {
   if (inherits(object[[1]], "saem.mmkin")) {
     test_func <- function(fit) {
-      if (inherits(fit$so, "try-error")) {
-        return("E")
+      if (inherits(fit, "try-error")) {
+          return("E")
       } else {
-        if (!is.null(fit$FIM_failed)) {
-          return_values <- c("fixed effects" = "Fth",
-            "random effects and error model parameters" = "FO")
-          return(paste(return_values[fit$FIM_failed], collapse = ", "))
+        if (inherits(fit$so, "try-error")) {
+          return("E")
         } else {
-          return("OK")
+          if (!is.null(fit$FIM_failed)) {
+            return_values <- c("fixed effects" = "Fth",
+              "random effects and error model parameters" = "FO")
+            return(paste(return_values[fit$FIM_failed], collapse = ", "))
+          } else {
+            return("OK")
+          }
         }
       }
     }
-- 
cgit v1.2.1