From ba806b0255821d5e508d82c7bf7dc68cc3c8328c Mon Sep 17 00:00:00 2001
From: Johannes Ranke <jranke@uni-bremen.de>
Date: Sat, 24 Oct 2020 00:04:50 +0200
Subject: Printing method for mmkin objects

---
 NEWS.md     |  2 ++
 R/mkinfit.R |  6 +++---
 R/mmkin.R   | 53 ++++++++++++++++++++++++++++++++++++++++++++++++-----
 3 files changed, 53 insertions(+), 8 deletions(-)

diff --git a/NEWS.md b/NEWS.md
index e7ee2d5d..b7e8f38c 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,5 +1,7 @@
 # mkin 0.9.50.4 (unreleased)
 
+- 'print' method for 'mmkin' objects
+
 - 'saemix_model', 'saemix_data': Helper functions to fit nonlinear mixed-effects models for mmkin row objects using the saemix package
 
 # mkin 0.9.50.3 (2020-10-08)
diff --git a/R/mkinfit.R b/R/mkinfit.R
index ee7c0b99..65dd5d75 100644
--- a/R/mkinfit.R
+++ b/R/mkinfit.R
@@ -292,7 +292,7 @@ mkinfit <- function(mkinmod, observed,
   # Also remove zero values to avoid instabilities (e.g. of the 'tc' error model)
   if (any(observed$value == 0)) {
     zero_warning <- "Observations with value of zero were removed from the data"
-    summary_warnings <- c(summary_warnings, zero_warning)
+    summary_warnings <- c(summary_warnings, Z = zero_warning)
     warning(zero_warning)
     observed <- subset(observed, value != 0)
   }
@@ -860,7 +860,7 @@ mkinfit <- function(mkinmod, observed,
 
   if (fit$convergence != 0) {
     convergence_warning = paste0("Optimisation did not converge:\n", fit$message)
-    summary_warnings <- c(summary_warnings, convergence_warning)
+    summary_warnings <- c(summary_warnings, C = convergence_warning)
     warning(convergence_warning)
   } else {
     if(!quiet) message("Optimisation successfully terminated.\n")
@@ -938,7 +938,7 @@ mkinfit <- function(mkinmod, observed,
   if (fit$shapiro.p < 0.05) {
     shapiro_warning <- paste("Shapiro-Wilk test for standardized residuals: p = ", signif(fit$shapiro.p, 3))
     warning(shapiro_warning)
-    summary_warnings <- c(summary_warnings, shapiro_warning)
+    summary_warnings <- c(summary_warnings, S = shapiro_warning)
   }
 
   fit$summary_warnings <- summary_warnings
diff --git a/R/mmkin.R b/R/mmkin.R
index d879fec4..6f088de0 100644
--- a/R/mmkin.R
+++ b/R/mmkin.R
@@ -100,9 +100,9 @@ mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets,
   }
 
   if (is.null(cluster)) {
-    results <- mclapply(as.list(1:n.fits), fit_function, mc.cores = cores)
+    results <- parallel::mclapply(as.list(1:n.fits), fit_function, mc.cores = cores)
   } else {
-    results <- parLapply(cluster, as.list(1:n.fits), fit_function)
+    results <- parallel::parLapply(cluster, as.list(1:n.fits), fit_function)
   }
 
   attributes(results) <- attributes(fit_indices)
@@ -112,8 +112,6 @@ mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets,
 
 #' Subsetting method for mmkin objects
 #'
-#' Subsetting method for mmkin objects.
-#'
 #' @param x An \code{\link{mmkin} object}
 #' @param i Row index selecting the fits for specific models
 #' @param j Column index selecting the fits to specific datasets
@@ -136,7 +134,6 @@ mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets,
 #'     # This extracts an mkinfit object with lots of components
 #'     fits[["FOMC", "B"]]
 #'   )
-#'
 #' @export
 `[.mmkin` <- function(x, i, j, ..., drop = FALSE) {
   class(x) <- NULL
@@ -144,3 +141,49 @@ mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets,
   if (!drop) class(x_sub) <- "mmkin"
   return(x_sub)
 }
+
+#' Print method for mmkin objects
+#'
+#' @param x An [mmkin] object.
+#' @param \dots Not used.
+#' @export
+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
+
+  x_t <- t(x) # To make lapply work by rows
+  display <- lapply(x_t,
+    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 = "")
+  }
+
+}
-- 
cgit v1.2.1