1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
#' 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("SFO", subset(FOCUS_2006_D, value != 0), quiet = TRUE)
#' parms(fit)
#' plot_err(fit)
#' fit_2 <- update(fit, error_model = "tc")
#' parms(fit_2)
#' plot_err(fit_2)
#' }
#' @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
}
|
