aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohannes Ranke <jranke@uni-bremen.de>2022-11-04 10:54:43 +0100
committerJohannes Ranke <jranke@uni-bremen.de>2022-11-04 10:54:43 +0100
commitce7a20e54d8005264f13d3e9fe0c99f84d20b85e (patch)
tree50e3ca40c5c13bb93495e4e1f2080e2e7db52439
parent0389d523f049945c85eba42d4a006523595043f0 (diff)
Make illparms.mhmkin and anova.saem.mmkin more robust
-rw-r--r--R/anova.saem.mmkin.R5
-rw-r--r--R/illparms.R18
-rw-r--r--R/mhmkin.R3
3 files changed, 14 insertions, 12 deletions
diff --git a/R/anova.saem.mmkin.R b/R/anova.saem.mmkin.R
index e506fb8b..00ddc0c3 100644
--- a/R/anova.saem.mmkin.R
+++ b/R/anova.saem.mmkin.R
@@ -30,9 +30,10 @@ anova.saem.mmkin <- function(object, ...,
is_model <- sapply(dots, is, "saem.mmkin")
if (any(is_model)) {
mods <- c(list(object), dots[is_model])
+ successful <- sapply(mods, function(x) !inherits(x$so, "try-error"))
# Ensure same data, ignoring covariates
- same_data <- sapply(dots[is_model], function(x) {
+ same_data <- sapply(mods[successful], function(x) {
identical(object$data[c("ds", "name", "time", "value")],
x$data[c("ds", "name", "time", "value")])
})
@@ -56,7 +57,7 @@ anova.saem.mmkin <- function(object, ...,
}
names(mods) <- model.names
- llks <- lapply(model.names, function(x) {
+ llks <- lapply(model.names[successful], function(x) {
llk <- try(logLik(mods[[x]], method = method))
if (inherits(llk, "try-error"))
stop("Could not obtain log likelihood with '", method, "' method for ", x)
diff --git a/R/illparms.R b/R/illparms.R
index c9a4f854..01e75cf1 100644
--- a/R/illparms.R
+++ b/R/illparms.R
@@ -93,22 +93,22 @@ print.illparms.mmkin <- function(x, ...) {
#' @rdname illparms
#' @export
illparms.saem.mmkin <- function(object, conf.level = 0.95, random = TRUE, errmod = TRUE, ...) {
- if (inherits(object, "try-error")) {
- failed <- NA
+ if (inherits(object$so, "try-error")) {
+ ill_parms <- NA
} else {
ints <- intervals(object, conf.level = conf.level)
- failed <- character(0)
+ ill_parms <- character(0)
if (random) {
- failed_random <- ints$random[, "lower"] < 0
- failed <- c(failed, names(which(failed_random)))
+ ill_parms_random <- ints$random[, "lower"] < 0
+ ill_parms <- c(ill_parms, names(which(ill_parms_random)))
}
if (errmod) {
- failed_errmod <- ints$errmod[, "lower"] < 0 & ints$errmod[, "est."] > 0
- failed <- c(failed, names(which(failed_errmod)))
+ ill_parms_errmod <- ints$errmod[, "lower"] < 0 & ints$errmod[, "est."] > 0
+ ill_parms <- c(ill_parms, names(which(ill_parms_errmod)))
}
}
- class(failed) <- "illparms.saem.mmkin"
- return(failed)
+ class(ill_parms) <- "illparms.saem.mmkin"
+ return(ill_parms)
}
#' @rdname illparms
diff --git a/R/mhmkin.R b/R/mhmkin.R
index 175d12ec..de41c733 100644
--- a/R/mhmkin.R
+++ b/R/mhmkin.R
@@ -207,6 +207,7 @@ anova.mhmkin <- function(object, ...,
if (identical(model.names, "auto")) {
model.names <- outer(rownames(object), colnames(object), paste)
}
- rlang::inject(anova(!!!(object), method = method, test = test, model.names = model.names))
+ rlang::inject(anova(!!!(object), method = method, test = test,
+ model.names = model.names))
}

Contact - Imprint