diff options
Diffstat (limited to 'R')
| -rw-r--r-- | R/convergence.R | 71 | ||||
| -rw-r--r-- | R/illparms.R | 62 | ||||
| -rw-r--r-- | R/mmkin.R | 51 | ||||
| -rw-r--r-- | R/summary.mmkin.R | 56 |
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) +} @@ -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) +} + |