aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohannes Ranke <jranke@uni-bremen.de>2020-10-24 00:04:50 +0200
committerJohannes Ranke <jranke@uni-bremen.de>2020-10-24 00:04:50 +0200
commitba806b0255821d5e508d82c7bf7dc68cc3c8328c (patch)
treeb576f68745f6f8e053c74f6cc61080f47de18ff9
parent0af6a61b84cc29cdbfad16a6fc7ee0e6f88c7d0f (diff)
Printing method for mmkin objects
-rw-r--r--NEWS.md2
-rw-r--r--R/mkinfit.R6
-rw-r--r--R/mmkin.R53
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 = "")
+ }
+
+}

Contact - Imprint