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
---
R/mkinfit.R | 6 +++---
R/mmkin.R | 53 ++++++++++++++++++++++++++++++++++++++++++++++++-----
2 files changed, 51 insertions(+), 8 deletions(-)
(limited to 'R')
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