aboutsummaryrefslogtreecommitdiff
path: root/R
diff options
context:
space:
mode:
Diffstat (limited to 'R')
-rw-r--r--R/convergence.R71
-rw-r--r--R/illparms.R62
-rw-r--r--R/mmkin.R51
-rw-r--r--R/summary.mmkin.R56
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)
+}
+

Contact - Imprint