diff options
| author | Johannes Ranke <jranke@uni-bremen.de> | 2022-11-04 10:54:43 +0100 | 
|---|---|---|
| committer | Johannes Ranke <jranke@uni-bremen.de> | 2022-11-04 10:54:43 +0100 | 
| commit | ce7a20e54d8005264f13d3e9fe0c99f84d20b85e (patch) | |
| tree | 50e3ca40c5c13bb93495e4e1f2080e2e7db52439 | |
| parent | 0389d523f049945c85eba42d4a006523595043f0 (diff) | |
Make illparms.mhmkin and anova.saem.mmkin more robust
| -rw-r--r-- | R/anova.saem.mmkin.R | 5 | ||||
| -rw-r--r-- | R/illparms.R | 18 | ||||
| -rw-r--r-- | R/mhmkin.R | 3 | 
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 @@ -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))  } | 
