aboutsummaryrefslogblamecommitdiff
path: root/R/update.mkinfit.R
blob: dde7f8109a3b1ac03ada973cb9287d8d415fc75c (plain) (tree) 
7091d373














ce73c044






7091d373









































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
}

Contact - Imprint