aboutsummaryrefslogtreecommitdiff
path: root/R/update.mkinfit.R
diff options
context:
space:
mode:
Diffstat (limited to 'R/update.mkinfit.R')
-rw-r--r--R/update.mkinfit.R57
1 files changed, 57 insertions, 0 deletions
diff --git a/R/update.mkinfit.R b/R/update.mkinfit.R
new file mode 100644
index 00000000..2f0814e0
--- /dev/null
+++ b/R/update.mkinfit.R
@@ -0,0 +1,57 @@
+#' Update an mkinfit model with different arguments
+#'
+#' This function will return an updated mkinfit object. The fitted degradation
+#' model parameters from the old fit are used as starting values for the
+#' updated fit. Values specified as 'parms.ini' and/or 'state.ini' will
+#' override these starting values.
+#'
+#' @param object An mkinfit object to be updated
+#' @param \dots Arguments to \code{\link{mkinfit}} that should replace
+#' the arguments from the original call. Arguments set to NULL will
+#' remove arguments given in the original call
+#' @param evaluate Should the call be evaluated or returned as a call
+#' @examples
+#' \dontrun{
+#' fit <- mkinfit("DFOP", subset(FOCUS_2006_D, value != 0), quiet = TRUE)
+#' update(fit, error_model = "tc")
+#' }
+#' @export
+update.mkinfit <- function(object, ..., evaluate = TRUE)
+{
+ call <- object$call
+
+ update_arguments <- match.call(expand.dots = FALSE)$...
+
+ # Get optimised ODE parameters and let parms.ini override them
+ ode_optim_names <- intersect(names(object$bparms.optim), names(object$bparms.ode))
+ ode_start <- object$bparms.optim[ode_optim_names]
+ if ("parms.ini" %in% names(update_arguments)) {
+ ode_start[names(update_arguments["parms.ini"])] <- update_arguments["parms.ini"]
+ }
+ if (length(ode_start)) update_arguments[["parms.ini"]] <- ode_start
+
+ # Get optimised values for initial states and let state.ini override them
+ state_optim_names <- intersect(names(object$bparms.optim), paste0(names(object$bparms.state), "_0"))
+ state_start <- object$bparms.optim[state_optim_names]
+ names(state_start) <- gsub("_0$", "", names(state_start))
+ if ("state.ini" %in% names(update_arguments)) {
+ state_start[names(update_arguments["state.ini"])] <- update_arguments["state.ini"]
+ }
+ if (length(state_start)) update_arguments[["state.ini"]] <- state_start
+
+ if (length(update_arguments) > 0) {
+ update_arguments_in_call <- !is.na(match(names(update_arguments), names(call)))
+
+ for (a in names(update_arguments)[update_arguments_in_call]) {
+ call[[a]] <- update_arguments[[a]]
+ }
+
+ update_arguments_not_in_call <- !update_arguments_in_call
+ if(any(update_arguments_not_in_call)) {
+ call <- c(as.list(call), update_arguments[update_arguments_not_in_call])
+ call <- as.call(call)
+ }
+ }
+ if(evaluate) eval(call, parent.frame())
+ else call
+}

Contact - Imprint