From 4c868d65be04c8ee3fedc89d28d0e7d8c5da05e0 Mon Sep 17 00:00:00 2001 From: Johannes Ranke Date: Fri, 28 Oct 2022 10:31:16 +0200 Subject: Rename 'convergence' method to 'status' The reason is that it is misleading in the case of saem.mmkin objects, because convergence is not really checked there. --- R/convergence.R | 71 ------------------------------------------------------- R/mhmkin.R | 9 ++++--- R/mmkin.R | 2 +- R/multistart.R | 12 +++++----- R/status.R | 70 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ R/summary.mmkin.R | 8 +++---- 6 files changed, 85 insertions(+), 87 deletions(-) delete mode 100644 R/convergence.R create mode 100644 R/status.R (limited to 'R') diff --git a/R/convergence.R b/R/convergence.R deleted file mode 100644 index e75bb1b1..00000000 --- a/R/convergence.R +++ /dev/null @@ -1,71 +0,0 @@ -#' 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/mhmkin.R b/R/mhmkin.R index 542bddf7..47b84b9d 100644 --- a/R/mhmkin.R +++ b/R/mhmkin.R @@ -133,11 +133,10 @@ mhmkin.list <- function(objects, backend = "saemix", print.mhmkin <- function(x, ...) { cat(" object\n") cat("Status of individual fits:\n\n") - print(convergence(x)) + print(status(x)) } -#' @export -convergence.mhmkin <- function(object, ...) { +status.mhmkin <- function(object, ...) { if (inherits(object[[1]], "saem.mmkin")) { test_func <- function(fit) { if (inherits(fit$so, "try-error")) { @@ -160,12 +159,12 @@ convergence.mhmkin <- function(object, ...) { dim(result) <- dim(object) dimnames(result) <- dimnames(object) - class(result) <- "convergence.mhmkin" + class(result) <- "status.mhmkin" return(result) } #' @export -print.convergence.mhmkin <- function(x, ...) { +print.status.mhmkin <- function(x, ...) { class(x) <- NULL print(x, quote = FALSE) cat("\n") diff --git a/R/mmkin.R b/R/mmkin.R index 247fd5fa..01e53290 100644 --- a/R/mmkin.R +++ b/R/mmkin.R @@ -171,7 +171,7 @@ mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets, print.mmkin <- function(x, ...) { cat(" object\n") cat("Status of individual fits:\n\n") - print(convergence(x)) + print(status(x)) } #' @export diff --git a/R/multistart.R b/R/multistart.R index fc2dcd7d..29ccdc44 100644 --- a/R/multistart.R +++ b/R/multistart.R @@ -112,7 +112,7 @@ multistart.saem.mmkin <- function(object, n = 50, cores = 1, } #' @export -convergence.multistart <- function(object, ...) { +status.multistart <- function(object, ...) { all_summary_warnings <- character() result <- lapply(object, @@ -124,12 +124,12 @@ convergence.multistart <- function(object, ...) { }) result <- unlist(result) - class(result) <- "convergence.multistart" + class(result) <- "status.multistart" return(result) } #' @export -convergence.multistart.saem.mmkin <- function(object, ...) { +status.multistart.saem.mmkin <- function(object, ...) { all_summary_warnings <- character() result <- lapply(object, @@ -141,12 +141,12 @@ convergence.multistart.saem.mmkin <- function(object, ...) { }) result <- unlist(result) - class(result) <- "convergence.multistart" + class(result) <- "status.multistart" return(result) } #' @export -print.convergence.multistart <- function(x, ...) { +print.status.multistart <- function(x, ...) { class(x) <- NULL print(table(x, dnn = NULL)) if (any(x == "OK")) cat("OK: Fit terminated successfully\n") @@ -157,7 +157,7 @@ print.convergence.multistart <- function(x, ...) { #' @export print.multistart <- function(x, ...) { cat(" object with", length(x), "fits:\n") - print(convergence(x)) + print(status(x)) } #' @rdname multistart diff --git a/R/status.R b/R/status.R new file mode 100644 index 00000000..44d2a9bc --- /dev/null +++ b/R/status.R @@ -0,0 +1,70 @@ +#' Method to get status information for fit array objects +#' +#' @param object The object to investigate +#' @param x The object to be printed +#' @param \dots For potential future extensions +#' @return An object with the same dimensions as the fit array +#' suitable printing method. +#' @export +status <- function(object, ...) +{ + UseMethod("status", object) +} + +#' @rdname status +#' @export +#' @examples +#' \dontrun{ +#' fits <- mmkin( +#' c("SFO", "FOMC"), +#' list("FOCUS A" = FOCUS_2006_A, +#' "FOCUS B" = FOCUS_2006_C), +#' quiet = TRUE) +#' status(fits) +#' } +status.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) <- "status.mmkin" + return(result) +} + +#' @rdname status +#' @export +print.status.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/summary.mmkin.R b/R/summary.mmkin.R index 5f4a048b..06472e18 100644 --- a/R/summary.mmkin.R +++ b/R/summary.mmkin.R @@ -1,6 +1,6 @@ #' Summary method for class "mmkin" #' -#' Shows convergence information on the [mkinfit] objects contained in the object +#' Shows status 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] @@ -24,7 +24,7 @@ summary.mmkin <- function(object, conf.level = 0.95, ...) { err_mod = object[[1, 1]]$err_mod, time = attr(object, "time"), illparms = illparms(object), - convergence = convergence(object) + status = status(object) ) class(ans) <- c("summary.mmkin") @@ -43,8 +43,8 @@ print.summary.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ... } cat("Fitted in", x$time[["elapsed"]], "s\n") - cat("\nConvergence:\n") - print(x$convergence) + cat("\nStatus:\n") + print(x$status) if (any(x$illparms != "")) { cat("\nIll-defined parameters:\n") -- cgit v1.2.1