From 4c868d65be04c8ee3fedc89d28d0e7d8c5da05e0 Mon Sep 17 00:00:00 2001
From: Johannes Ranke <jranke@uni-bremen.de>
Date: Fri, 28 Oct 2022 10:31:16 +0200
Subject: Rename 'convergence' method to 'status'

The reason is that it is misleading in the case of saem.mmkin objects,
because convergence is not really checked there.
---
 R/status.R | 70 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 70 insertions(+)
 create mode 100644 R/status.R

(limited to 'R/status.R')

diff --git a/R/status.R b/R/status.R
new file mode 100644
index 00000000..44d2a9bc
--- /dev/null
+++ b/R/status.R
@@ -0,0 +1,70 @@
+#' Method to get status information for fit array objects
+#'
+#' @param object The object to investigate
+#' @param x The object to be printed
+#' @param \dots For potential future extensions
+#' @return  An object with the same dimensions as the fit array
+#' suitable printing method.
+#' @export
+status <- function(object, ...)
+{
+  UseMethod("status", object)
+}
+
+#' @rdname status
+#' @export
+#' @examples
+#' \dontrun{
+#' fits <- mmkin(
+#'   c("SFO", "FOMC"),
+#'   list("FOCUS A" = FOCUS_2006_A,
+#'        "FOCUS B" = FOCUS_2006_C),
+#'   quiet = TRUE)
+#' status(fits)
+#' }
+status.mmkin <- function(object, ...) {
+  all_summary_warnings <- character()
+  sww <- 0 # Counter for Shapiro-Wilks warnings
+
+  result <- lapply(object,
+    function(fit) {
+      if (inherits(fit, "try-error")) return("E")
+      sw <- fit$summary_warnings
+      swn <- names(sw)
+      if (length(sw) > 0) {
+        if (any(grepl("S", swn))) {
+          sww <<- sww + 1
+          swn <- gsub("S", paste0("S", sww), swn)
+        }
+        warnstring <- paste(swn, collapse = ", ")
+        names(sw) <- swn
+        all_summary_warnings <<- c(all_summary_warnings, sw)
+        return(warnstring)
+      } else {
+        return("OK")
+      }
+    })
+  result <- unlist(result)
+  dim(result) <- dim(object)
+  dimnames(result) <- dimnames(object)
+
+  u_swn <- unique(names(all_summary_warnings))
+  attr(result, "unique_warnings") <- all_summary_warnings[u_swn]
+  class(result) <- "status.mmkin"
+  return(result)
+}
+
+#' @rdname status
+#' @export
+print.status.mmkin <- function(x, ...) {
+  u_w <- attr(x, "unique_warnings")
+  attr(x, "unique_warnings") <- NULL
+  class(x) <- NULL
+  print(x, quote = FALSE)
+  cat("\n")
+  for (i in seq_along(u_w)) {
+    cat(names(u_w)[i], ": ", u_w[i], "\n", sep = "")
+  }
+  if (any(x == "OK")) cat("OK: No warnings\n")
+  if (any(x == "E")) cat("E: Error\n")
+}
-- 
cgit v1.2.1