aboutsummaryrefslogtreecommitdiff
path: root/R/mmkin.R
diff options
context:
space:
mode:
Diffstat (limited to 'R/mmkin.R')
-rw-r--r--R/mmkin.R53
1 files changed, 48 insertions, 5 deletions
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 = "")
+ }
+
+}

Contact - Imprint