aboutsummaryrefslogtreecommitdiff
path: root/R/status.R
diff options
context:
space:
mode:
Diffstat (limited to 'R/status.R')
-rw-r--r--R/status.R113
1 files changed, 113 insertions, 0 deletions
diff --git a/R/status.R b/R/status.R
new file mode 100644
index 00000000..8bcd3a16
--- /dev/null
+++ b/R/status.R
@@ -0,0 +1,113 @@
+#' 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")
+}
+
+#' @rdname status
+#' @export
+status.mhmkin <- function(object, ...) {
+ if (inherits(object[[1]], "saem.mmkin")) {
+ test_func <- function(fit) {
+ if (inherits(fit$so, "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 = ", "))
+ } else {
+ return("OK")
+ }
+ }
+ }
+ } else {
+ stop("Only mhmkin objects containing saem.mmkin objects currently supported")
+ }
+ result <- lapply(object, test_func)
+ result <- unlist(result)
+ dim(result) <- dim(object)
+ dimnames(result) <- dimnames(object)
+
+ class(result) <- "status.mhmkin"
+ return(result)
+}
+
+#' @rdname status
+#' @export
+print.status.mhmkin <- function(x, ...) {
+ class(x) <- NULL
+ print(x, quote = FALSE)
+ cat("\n")
+ if (any(x == "OK")) cat("OK: Fit terminated successfully\n")
+ if (any(x == "Fth")) cat("Fth: Could not invert FIM for fixed effects\n")
+ if (any(x == "FO")) cat("FO: Could not invert FIM for random effects and error model parameters\n")
+ if (any(x == "Fth, FO")) cat("Fth, FO: Could not invert FIM for fixed effects, nor for random effects and error model parameters\n")
+ if (any(x == "E")) cat("E: Error\n")
+}
+

Contact - Imprint