Summary method for mmkin objects

Also, add a method for gathering convergence information
and a method for gathering information on ill-defined parameters

4 files changed, 199 insertions, 41 deletions

diff --git a/R/convergence.R b/R/convergence.R
new file mode 100644
index 00000000..e75bb1b1
--- /dev/null
+++ b/R/convergence.R
@@ -0,0 +1,71 @@
+#' Method to get convergence information
+#'
+#' @param object The object to investigate
+#' @param x The object to be printed
+#' @param \dots For potential future extensions
+#' @return For [mkinfit] objects, a character vector containing
+#' For [mmkin] objects, an object of class 'convergence.mmkin' with a
+#' suitable printing method.
+#' @export
+convergence <- function(object, ...)
+{
+  UseMethod("convergence", object)
+}
+
+#' @rdname convergence
+#' @export
+#' @examples
+#' \dontrun{
+#' fits <- mmkin(
+#'   c("SFO", "FOMC"),
+#'   list("FOCUS A" = FOCUS_2006_A,
+#'        "FOCUS B" = FOCUS_2006_C),
+#'   quiet = TRUE)
+#' convergence(fits)
+#' }
+convergence.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) <- "convergence.mmkin"
+  return(result)
+}
+
+#' @rdname convergence
+#' @export
+print.convergence.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")
+}
diff --git a/R/illparms.R b/R/illparms.R
new file mode 100644
index 00000000..f23f1cae
--- /dev/null
+++ b/R/illparms.R
@@ -0,0 +1,62 @@
+#' Method to get the names of ill-defined parameters
+#'
+#' @param object The object to investigate
+#' @param x The object to be printed
+#' @param conf.level The confidence level for checking p values
+#' @param \dots For potential future extensions
+#' @return For [mkinfit] objects, a character vector of parameter names
+#' For [mmkin] objects, an object of class 'illparms.mmkin' with a
+#' suitable printing method.
+#' @export
+illparms <- function(object, ...)
+{
+  UseMethod("illparms", object)
+}
+
+#' @rdname illparms
+#' @export
+#' @examples
+#' fit <- mkinfit("FOMC", FOCUS_2006_A, quiet = TRUE)
+#' illparms(fit)
+illparms.mkinfit <- function(object, conf.level = 0.95, ...) {
+  p_values <- suppressWarnings(summary(object)$bpar[, "Pr(>t)"])
+  na <- is.na(p_values)
+  failed <- p_values > 1 - conf.level
+  names(parms(object))[na | failed]
+}
+
+#' @rdname illparms
+#' @export
+#' @examples
+#' \dontrun{
+#' fits <- mmkin(
+#'   c("SFO", "FOMC"),
+#'   list("FOCUS A" = FOCUS_2006_A,
+#'        "FOCUS C" = FOCUS_2006_C),
+#'   quiet = TRUE)
+#' illparms(fits)
+#' }
+illparms.mmkin <- function(object, conf.level = 0.95, ...) {
+  result <- lapply(object,
+    function(fit) {
+      if (inherits(fit, "try-error")) return("E")
+      ill <- illparms(fit, conf.level = conf.level)
+      if (length(ill) > 0) {
+        return(paste(ill, collapse = ", "))
+      } else {
+        return("")
+      }
+    })
+  result <- unlist(result)
+  dim(result) <- dim(object)
+  dimnames(result) <- dimnames(object)
+  class(result) <- "illparms.mmkin"
+  return(result)
+}
+
+#' @rdname illparms
+#' @export
+print.illparms.mmkin <- function(x, ...) {
+  class(x) <- NULL
+  print(x, quote = FALSE)
+}
diff --git a/R/mmkin.R b/R/mmkin.R
index fe04129e..247fd5fa 100644
--- a/R/mmkin.R
+++ b/R/mmkin.R
@@ -114,15 +114,18 @@ mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets,
     return(res)
   }
 
-  if (is.null(cluster)) {
-    results <- parallel::mclapply(as.list(1:n.fits), fit_function,
-      mc.cores = cores, mc.preschedule = FALSE)
-  } else {
-    results <- parallel::parLapply(cluster, as.list(1:n.fits), fit_function)
-  }
+  fit_time <- system.time({
+    if (is.null(cluster)) {
+      results <- parallel::mclapply(as.list(1:n.fits), fit_function,
+        mc.cores = cores, mc.preschedule = FALSE)
+    } else {
+      results <- parallel::parLapply(cluster, as.list(1:n.fits), fit_function)
+    }
+  })
 
   attributes(results) <- attributes(fit_indices)
   attr(results, "call") <- call
+  attr(results, "time") <- fit_time
   class(results) <- "mmkin"
   return(results)
 }
@@ -168,41 +171,7 @@ mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets,
 print.mmkin <- function(x, ...) {
   cat("<mmkin> object\n")
   cat("Status of individual fits:\n\n")
-  all_summary_warnings <- character()
-  sww <- 0 # Counter for Shapiro-Wilks warnings
-
-  display <- lapply(x,
-    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")
-      }
-    })
-  display <- unlist(display)
-  dim(display) <- dim(x)
-  dimnames(display) <- dimnames(x)
-  print(display, quote = FALSE)
-
-  cat("\n")
-  if (any(display == "OK")) cat("OK: No warnings\n")
-  if (any(display == "E")) cat("E: Error\n")
-  u_swn <- unique(names(all_summary_warnings))
-  u_w <- all_summary_warnings[u_swn]
-  for (i in seq_along(u_w)) {
-    cat(names(u_w)[i], ": ", u_w[i], "\n", sep = "")
-  }
-
+  print(convergence(x))
 }
 
 #' @export
diff --git a/R/summary.mmkin.R b/R/summary.mmkin.R
new file mode 100644
index 00000000..5f4a048b
--- /dev/null
+++ b/R/summary.mmkin.R
@@ -0,0 +1,56 @@
+#' Summary method for class "mmkin"
+#'
+#' Shows convergence information on the [mkinfit] objects contained in the object
+#' and gives an overview of ill-defined parameters calculated by [illparms].
+#'
+#' @param object an object of class [mmkin]
+#' @param x an object of class \code{summary.mmkin}.
+#' @param conf.level confidence level for testing parameters
+#' @param digits number of digits to use for printing
+#' @param \dots optional arguments passed to methods like \code{print}.
+#' @examples
+#'
+#' fits <- mmkin(
+#'   c("SFO", "FOMC"),
+#'   list("FOCUS A" = FOCUS_2006_A,
+#'        "FOCUS C" = FOCUS_2006_C),
+#'   quiet = TRUE, cores = 1)
+#'   summary(fits)
+#'
+#' @export
+summary.mmkin <- function(object, conf.level = 0.95, ...) {
+
+  ans <- list(
+    err_mod = object[[1, 1]]$err_mod,
+    time = attr(object, "time"),
+    illparms = illparms(object),
+    convergence = convergence(object)
+  )
+
+  class(ans) <- c("summary.mmkin")
+  return(ans)
+}
+
+#' @rdname summary.mmkin
+#' @export
+print.summary.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) {
+  if (!is.null(x$err_mod)) {
+    cat("Error model: ")
+    cat(switch(x$err_mod,
+               const = "Constant variance",
+               obs = "Variance unique to each observed variable",
+               tc = "Two-component variance function"), "\n")
+  }
+  cat("Fitted in", x$time[["elapsed"]],  "s\n")
+
+  cat("\nConvergence:\n")
+  print(x$convergence)
+
+  if (any(x$illparms != "")) {
+    cat("\nIll-defined parameters:\n")
+    print(x$illparms)
+  }
+
+  invisible(x)
+}
+