mkin coverage - 89.32%

- Files -
- Source -

- - -

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

utils::globalVariables(c("predicted", "std"))

#' Fit nonlinear mixed models with SAEM
#'
#' This function uses [saemix::saemix()] as a backend for fitting nonlinear mixed
#' effects models created from [mmkin] row objects using the Stochastic Approximation
#' Expectation Maximisation algorithm (SAEM).
#'
#' An mmkin row object is essentially a list of mkinfit objects that have been
#' obtained by fitting the same model to a list of datasets using [mkinfit].
#'
#' Starting values for the fixed effects (population mean parameters, argument
#' psi0 of [saemix::saemixModel()] are the mean values of the parameters found
#' using [mmkin].
#'
#' @importFrom utils packageVersion
#' @importFrom saemix saemix
#' @param object An [mmkin] row object containing several fits of the same
#' [mkinmod] model to different datasets
#' @param verbose Should we print information about created objects of
#' type [saemix::SaemixModel] and [saemix::SaemixData]?
#' @param transformations Per default, all parameter transformations are done
#' in mkin. If this argument is set to 'saemix', parameter transformations
#' are done in 'saemix' for the supported cases, i.e. (as of version 1.1.2)
#' SFO, FOMC, DFOP and HS without fixing `parent_0`, and SFO or DFOP with
#' one SFO metabolite.
#' @param error_model Possibility to override the error model used in the mmkin object
#' @param degparms_start Parameter values given as a named numeric vector will
#' be used to override the starting values obtained from the 'mmkin' object.
#' @param test_log_parms If TRUE, an attempt is made to use more robust starting
#' values for population parameters fitted as log parameters in mkin (like
#' rate constants) by only considering rate constants that pass the t-test
#' when calculating mean degradation parameters using [mean_degparms].
#' @param conf.level Possibility to adjust the required confidence level
#' for parameter that are tested if requested by 'test_log_parms'.
#' @param solution_type Possibility to specify the solution type in case the
#' automatic choice is not desired
#' @param no_random_effect Character vector of degradation parameters for
#' which there should be no variability over the groups. Only used
#' if the covariance model is not explicitly specified.
#' @param covariance.model Will be passed to [saemix::saemixModel()]. Per
#' default, uncorrelated random effects are specified for all degradation
#' parameters.
#' @param omega.init Will be passed to [saemix::saemixModel()]. If using
#' mkin transformations and the default covariance model with optionally
#' excluded random effects, the variances of the degradation parameters
#' are estimated using [mean_degparms], with testing of untransformed
#' log parameters for significant difference from zero. If not using
#' mkin transformations or a custom covariance model, the default
#' initialisation of [saemix::saemixModel] is used for omega.init.
#' @param covariates A data frame with covariate data for use in
#' 'covariate_models', with dataset names as row names.
#' @param covariate_models A list containing linear model formulas with one explanatory
#' variable, i.e. of the type 'parameter ~ covariate'. Covariates must be available
#' in the 'covariates' data frame.
#' @param error.init Will be passed to [saemix::saemixModel()].
#' @param quiet Should we suppress the messages saemix prints at the beginning
#' and the end of the optimisation process?
#' @param nbiter.saemix Convenience option to increase the number of
#' iterations
#' @param control Passed to [saemix::saemix].
#' @param \dots Further parameters passed to [saemix::saemixModel].
#' @return An S3 object of class 'saem.mmkin', containing the fitted
#' [saemix::SaemixObject] as a list component named 'so'. The
#' object also inherits from 'mixed.mmkin'.
#' @seealso [summary.saem.mmkin] [plot.mixed.mmkin]
#' @examples
#' \dontrun{
#' ds <- lapply(experimental_data_for_UBA_2019[6:10],
#'  function(x) subset(x$data[c("name", "time", "value")]))
#' names(ds) <- paste("Dataset", 6:10)
#' f_mmkin_parent_p0_fixed <- mmkin("FOMC", ds,
#'   state.ini = c(parent = 100), fixed_initials = "parent", quiet = TRUE)
#' f_saem_p0_fixed <- saem(f_mmkin_parent_p0_fixed)
#'
#' f_mmkin_parent <- mmkin(c("SFO", "FOMC", "DFOP"), ds, quiet = TRUE)
#' f_saem_sfo <- saem(f_mmkin_parent["SFO", ])
#' f_saem_fomc <- saem(f_mmkin_parent["FOMC", ])
#' f_saem_dfop <- saem(f_mmkin_parent["DFOP", ])
#' anova(f_saem_sfo, f_saem_fomc, f_saem_dfop)
#' anova(f_saem_sfo, f_saem_dfop, test = TRUE)
#' illparms(f_saem_dfop)
#' f_saem_dfop_red <- update(f_saem_dfop, no_random_effect = "g_qlogis")
#' anova(f_saem_dfop, f_saem_dfop_red, test = TRUE)
#'
#' anova(f_saem_sfo, f_saem_fomc, f_saem_dfop)
#' # The returned saem.mmkin object contains an SaemixObject, therefore we can use
#' # functions from saemix
#' library(saemix)
#' compare.saemix(f_saem_sfo$so, f_saem_fomc$so, f_saem_dfop$so)
#' plot(f_saem_fomc$so, plot.type = "convergence")
#' plot(f_saem_fomc$so, plot.type = "individual.fit")
#' plot(f_saem_fomc$so, plot.type = "npde")
#' plot(f_saem_fomc$so, plot.type = "vpc")
#'
#' f_mmkin_parent_tc <- update(f_mmkin_parent, error_model = "tc")
#' f_saem_fomc_tc <- saem(f_mmkin_parent_tc["FOMC", ])
#' anova(f_saem_fomc, f_saem_fomc_tc, test = TRUE)
#'
#' sfo_sfo <- mkinmod(parent = mkinsub("SFO", "A1"),
#'   A1 = mkinsub("SFO"))
#' fomc_sfo <- mkinmod(parent = mkinsub("FOMC", "A1"),
#'   A1 = mkinsub("SFO"))
#' dfop_sfo <- mkinmod(parent = mkinsub("DFOP", "A1"),
#'   A1 = mkinsub("SFO"))
#' # The following fit uses analytical solutions for SFO-SFO and DFOP-SFO,
#' # and compiled ODEs for FOMC that are much slower
#' f_mmkin <- mmkin(list(
#'     "SFO-SFO" = sfo_sfo, "FOMC-SFO" = fomc_sfo, "DFOP-SFO" = dfop_sfo),
#'   ds, quiet = TRUE)
#' # saem fits of SFO-SFO and DFOP-SFO to these data take about five seconds
#' # each on this system, as we use analytical solutions written for saemix.
#' # When using the analytical solutions written for mkin this took around
#' # four minutes
#' f_saem_sfo_sfo <- saem(f_mmkin["SFO-SFO", ])
#' f_saem_dfop_sfo <- saem(f_mmkin["DFOP-SFO", ])
#' # We can use print, plot and summary methods to check the results
#' print(f_saem_dfop_sfo)
#' plot(f_saem_dfop_sfo)
#' summary(f_saem_dfop_sfo, data = TRUE)
#'
#' # The following takes about 6 minutes
#' f_saem_dfop_sfo_deSolve <- saem(f_mmkin["DFOP-SFO", ], solution_type = "deSolve",
#'   nbiter.saemix = c(200, 80))
#'
#' #anova(
#' #  f_saem_dfop_sfo,
#' #  f_saem_dfop_sfo_deSolve))
#'
#' # If the model supports it, we can also use eigenvalue based solutions, which
#' # take a similar amount of time
#' #f_saem_sfo_sfo_eigen <- saem(f_mmkin["SFO-SFO", ], solution_type = "eigen",
#' #  control = list(nbiter.saemix = c(200, 80), nbdisplay = 10))
#' }
#' @export
saem <- function(object, ...) UseMethod("saem")

#' @rdname saem
#' @export
saem.mmkin <- function(object,
  transformations = c("mkin", "saemix"),
  error_model = "auto",
  degparms_start = numeric(),
  test_log_parms = TRUE,
  conf.level = 0.6,
  solution_type = "auto",
  covariance.model = "auto",
  omega.init = "auto",
  covariates = NULL,
  covariate_models = NULL,
  no_random_effect = NULL,
  error.init = c(1, 1),
  nbiter.saemix = c(300, 100),
  control = list(displayProgress = FALSE, print = FALSE,
    nbiter.saemix = nbiter.saemix,
    save = FALSE, save.graphs = FALSE),
  verbose = FALSE, quiet = FALSE, ...)
{
  call <- match.call()
  transformations <- match.arg(transformations)
  m_saemix <- saemix_model(object, verbose = verbose,
    error_model = error_model,
    degparms_start = degparms_start,
    test_log_parms = test_log_parms, conf.level = conf.level,
    solution_type = solution_type,
    transformations = transformations,
    covariance.model = covariance.model,
    omega.init = omega.init,
    covariates = covariates,
    covariate_models = covariate_models,
    error.init = error.init,
    no_random_effect = no_random_effect,
    ...)
  d_saemix <- saemix_data(object, covariates = covariates, verbose = verbose)

  fit_failed <- FALSE
  FIM_failed <- NULL
  fit_time <- system.time({
    utils::capture.output(f_saemix <- try(saemix(m_saemix, d_saemix, control)), split = !quiet)
    if (inherits(f_saemix, "try-error")) fit_failed <- TRUE
  })

  return_data <- nlme_data(object)

  if (!fit_failed) {
    if (any(is.na(f_saemix@results@se.fixed))) FIM_failed <- c(FIM_failed, "fixed effects")
    if (any(is.na(c(f_saemix@results@se.omega, f_saemix@results@se.respar)))) {
      FIM_failed <- c(FIM_failed, "random effects and error model parameters")
    }

    transparms_optim <- f_saemix@results@fixed.effects
    names(transparms_optim) <- f_saemix@results@name.fixed

    if (transformations == "mkin") {
      bparms_optim <- backtransform_odeparms(transparms_optim,
        object[[1]]$mkinmod,
        object[[1]]$transform_rates,
        object[[1]]$transform_fractions)
    } else {
      bparms_optim <- transparms_optim
    }

    saemix_data_ds <- f_saemix@data@data$ds
    mkin_ds_order <- as.character(unique(return_data$ds))
    saemix_ds_order <- unique(saemix_data_ds)

    psi <- saemix::psi(f_saemix)
    rownames(psi) <- saemix_ds_order
    return_data$predicted <- f_saemix@model@model(
      psi = psi[mkin_ds_order, ],
      id = as.numeric(return_data$ds),
      xidep = return_data[c("time", "name")])

    return_data <- transform(return_data,
      residual = value - predicted,
      std = sigma_twocomp(predicted,
        f_saemix@results@respar[1], f_saemix@results@respar[2]))
    return_data <- transform(return_data,
      standardized = residual / std)
  }

  result <- list(
    mkinmod = object[[1]]$mkinmod,
    mmkin = object,
    solution_type = object[[1]]$solution_type,
    transformations = transformations,
    transform_rates = object[[1]]$transform_rates,
    transform_fractions = object[[1]]$transform_fractions,
    covariates = covariates,
    covariate_models = covariate_models,
    sm = m_saemix,
    so = f_saemix,
    call = call,
    time = fit_time,
    FIM_failed = FIM_failed,
    mean_dp_start = attr(m_saemix, "mean_dp_start"),
    bparms.fixed = object[[1]]$bparms.fixed,
    data = return_data,
    err_mod = object[[1]]$err_mod,
    date.fit = date(),
    saemixversion = as.character(utils::packageVersion("saemix")),
    mkinversion = as.character(utils::packageVersion("mkin")),
    Rversion = paste(R.version$major, R.version$minor, sep=".")
  )

  if (!fit_failed) {
    result$mkin_ds_order <- mkin_ds_order
    result$saemix_ds_order <- saemix_ds_order
    result$bparms.optim <- bparms_optim
  }

  class(result) <- c("saem.mmkin", "mixed.mmkin")
  return(result)
}

#' @export
#' @rdname saem
#' @param x An saem.mmkin object to print
#' @param digits Number of digits to use for printing
print.saem.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) {
  cat( "Kinetic nonlinear mixed-effects model fit by SAEM" )
  cat("\nStructural model:\n")
  diffs <- x$mmkin[[1]]$mkinmod$diffs
  nice_diffs <- gsub("^(d.*) =", "\\1/dt =", diffs)
  writeLines(strwrap(nice_diffs, exdent = 11))
  cat("\nData:\n")
  cat(nrow(x$data), "observations of",
    length(unique(x$data$name)), "variable(s) grouped in",
    length(unique(x$data$ds)), "datasets\n")

  if (inherits(x$so, "try-error")) {
    cat("\nFit did not terminate successfully\n")
  } else {
    cat("\nLikelihood computed by importance sampling\n")
    ll <- try(logLik(x$so, type = "is"), silent = TRUE)
    if (inherits(ll, "try-error")) {
      cat("Not available\n")
    } else {
      print(data.frame(
          AIC = AIC(x$so, type = "is"),
          BIC = BIC(x$so, type = "is"),
          logLik = logLik(x$so, type = "is"),
          row.names = " "), digits = digits)
    }

    cat("\nFitted parameters:\n")
    conf.int <- parms(x, ci = TRUE)
    print(conf.int, digits = digits)
  }

  invisible(x)
}

#' @rdname saem
#' @return An [saemix::SaemixModel] object.
#' @export
saemix_model <- function(object, solution_type = "auto",
  transformations = c("mkin", "saemix"), error_model = "auto",
  degparms_start = numeric(),
  covariance.model = "auto", no_random_effect = NULL,
  omega.init = "auto",
  covariates = NULL, covariate_models = NULL,
  error.init = numeric(),
  test_log_parms = FALSE, conf.level = 0.6, verbose = FALSE, ...)
{
  if (nrow(object) > 1) stop("Only row objects allowed")

  mkin_model <- object[[1]]$mkinmod

  if (length(mkin_model$spec) > 1 & solution_type[1] == "analytical") {
    stop("mkin analytical solutions not supported for more thane one observed variable")
  }

  degparms_optim <-  mean_degparms(object, test_log_parms = test_log_parms)
  na_degparms <- names(which(is.na(degparms_optim)))
  if (length(na_degparms) > 0) {
    message("Did not find valid starting values for ", paste(na_degparms, collapse = ", "), "\n",
      "Now trying with test_log_parms = FALSE")
    degparms_optim <-  mean_degparms(object, test_log_parms = FALSE)
  }
  if (transformations == "saemix") {
    degparms_optim <- backtransform_odeparms(degparms_optim,
      object[[1]]$mkinmod,
      object[[1]]$transform_rates,
      object[[1]]$transform_fractions)
  }
  degparms_fixed <- object[[1]]$bparms.fixed

  # Transformations are done in the degradation function by default
  # (transformations = "mkin")
  transform.par = rep(0, length(degparms_optim))

  odeini_optim_parm_names <- grep('_0$', names(degparms_optim), value = TRUE)
  odeini_fixed_parm_names <- grep('_0$', names(degparms_fixed), value = TRUE)

  odeparms_fixed_names <- setdiff(names(degparms_fixed), odeini_fixed_parm_names)
  odeparms_fixed <- degparms_fixed[odeparms_fixed_names]

  odeini_fixed <- degparms_fixed[odeini_fixed_parm_names]
  names(odeini_fixed) <- gsub('_0$', '', odeini_fixed_parm_names)

  model_function <- FALSE

  # Model functions with analytical solutions
  # Fixed parameters, use_of_ff = "min" and turning off sinks currently not supported here
  # In general, we need to consider exactly how the parameters in mkinfit were specified,
  # as the parameters are currently mapped by position in these solutions
  sinks <- sapply(mkin_model$spec, function(x) x$sink)
  if (length(odeparms_fixed) == 0 & mkin_model$use_of_ff == "max" & all(sinks)) {
    # Parent only
    if (length(mkin_model$spec) == 1) {
      parent_type <- mkin_model$spec[[1]]$type
      if (length(odeini_fixed) == 1 && !grepl("_bound$", names(odeini_fixed))) {
        if (transformations == "saemix") {
          stop("saemix transformations are not supported for parent fits with fixed initial parent value")
        }
        if (parent_type == "SFO") {
          stop("saemix needs at least two parameters to work on.")
        }
        if (parent_type == "FOMC") {
          model_function <- function(psi, id, xidep) {
            odeini_fixed / (xidep[, "time"]/exp(psi[id, 2]) + 1)^exp(psi[id, 1])
          }
        }
        if (parent_type == "DFOP") {
          model_function <- function(psi, id, xidep) {
            g <- plogis(psi[id, 3])
            t <- xidep[, "time"]
            odeini_fixed * (g * exp(- exp(psi[id, 1]) * t) +
              (1 - g) * exp(- exp(psi[id, 2]) * t))
          }
        }
        if (parent_type == "HS") {
          model_function <- function(psi, id, xidep) {
            tb <- exp(psi[id, 3])
            t <- xidep[, "time"]
            k1 = exp(psi[id, 1])
            odeini_fixed * ifelse(t <= tb,
              exp(- k1 * t),
              exp(- k1 * tb) * exp(- exp(psi[id, 2]) * (t - tb)))
          }
        }
      } else {
        if (length(odeini_fixed) == 2) {
          stop("SFORB with fixed initial parent value is not supported")
        }
        if (parent_type == "SFO") {
          if (transformations == "mkin") {
            model_function <- function(psi, id, xidep) {
              psi[id, 1] * exp( - exp(psi[id, 2]) * xidep[, "time"])
            }
          } else {
            model_function <- function(psi, id, xidep) {
              psi[id, 1] * exp( - psi[id, 2] * xidep[, "time"])
            }
            transform.par = c(0, 1)
          }
        }
        if (parent_type == "FOMC") {
          if (transformations == "mkin") {
            model_function <- function(psi, id, xidep) {
              psi[id, 1] / (xidep[, "time"]/exp(psi[id, 3]) + 1)^exp(psi[id, 2])
            }
          } else {
            model_function <- function(psi, id, xidep) {
              psi[id, 1] / (xidep[, "time"]/psi[id, 3] + 1)^psi[id, 2]
            }
            transform.par = c(0, 1, 1)
          }
        }
        if (parent_type == "DFOP") {
          if (transformations == "mkin") {
            model_function <- function(psi, id, xidep) {
              g <- plogis(psi[id, 4])
              t <- xidep[, "time"]
              psi[id, 1] * (g * exp(- exp(psi[id, 2]) * t) +
                (1 - g) * exp(- exp(psi[id, 3]) * t))
            }
          } else {
            model_function <- function(psi, id, xidep) {
              g <- psi[id, 4]
              t <- xidep[, "time"]
              psi[id, 1] * (g * exp(- psi[id, 2] * t) +
                (1 - g) * exp(- psi[id, 3] * t))
            }
            transform.par = c(0, 1, 1, 3)
          }
        }
        if (parent_type == "SFORB") {
          if (transformations == "mkin") {
            model_function <- function(psi, id, xidep) {
              k_12 <- exp(psi[id, 3])
              k_21 <- exp(psi[id, 4])
              k_1output <- exp(psi[id, 2])
              t <- xidep[, "time"]

              sqrt_exp = sqrt(1/4 * (k_12 + k_21 + k_1output)^2 - k_1output * k_21)
              b1 = 0.5 * (k_12 + k_21 + k_1output) + sqrt_exp
              b2 = 0.5 * (k_12 + k_21 + k_1output) - sqrt_exp

              psi[id, 1] * (((k_12 + k_21 - b1)/(b2 - b1)) * exp(-b1 * t) +
                ((k_12 + k_21 - b2)/(b1 - b2)) * exp(-b2 * t))
            }
          } else {
            model_function <- function(psi, id, xidep) {
              k_12 <- psi[id, 3]
              k_21 <- psi[id, 4]
              k_1output <- psi[id, 2]
              t <- xidep[, "time"]

              sqrt_exp = sqrt(1/4 * (k_12 + k_21 + k_1output)^2 - k_1output * k_21)
              b1 = 0.5 * (k_12 + k_21 + k_1output) + sqrt_exp
              b2 = 0.5 * (k_12 + k_21 + k_1output) - sqrt_exp

              psi[id, 1] * (((k_12 + k_21 - b1)/(b2 - b1)) * exp(-b1 * t) +
                ((k_12 + k_21 - b2)/(b1 - b2)) * exp(-b2 * t))
            }
            transform.par = c(0, 1, 1, 1)
          }
        }
        if (parent_type == "HS") {
          if (transformations == "mkin") {
            model_function <- function(psi, id, xidep) {
              tb <- exp(psi[id, 4])
              t <- xidep[, "time"]
              k1 <- exp(psi[id, 2])
              psi[id, 1] * ifelse(t <= tb,
                exp(- k1 * t),
                exp(- k1 * tb) * exp(- exp(psi[id, 3]) * (t - tb)))
            }
          } else {
            model_function <- function(psi, id, xidep) {
              tb <- psi[id, 4]
              t <- xidep[, "time"]
              psi[id, 1] * ifelse(t <= tb,
                exp(- psi[id, 2] * t),
                exp(- psi[id, 2] * tb) * exp(- psi[id, 3] * (t - tb)))
            }
            transform.par = c(0, 1, 1, 1)
          }
        }
      }
    }

    # Parent with one metabolite
    # Parameter names used in the model functions are as in
    # https://nbviewer.jupyter.org/urls/jrwb.de/nb/Symbolic%20ODE%20solutions%20for%20mkin.ipynb
    types <- unname(sapply(mkin_model$spec, function(x) x$type))
    if (length(mkin_model$spec) == 2 &! "SFORB" %in% types ) {
      # Initial value for the metabolite (n20) must be fixed
      if (names(odeini_fixed) == names(mkin_model$spec)[2]) {
        n20 <- odeini_fixed
        parent_name <- names(mkin_model$spec)[1]
        if (identical(types, c("SFO", "SFO"))) {
          if (transformations == "mkin") {
            model_function <- function(psi, id, xidep) {
              t <- xidep[, "time"]
              n10 <- psi[id, 1]
              k1 <- exp(psi[id, 2])
              k2 <- exp(psi[id, 3])
              f12 <- plogis(psi[id, 4])
              ifelse(xidep[, "name"] == parent_name,
                n10 * exp(- k1 * t),
                (((k2 - k1) * n20 - f12 * k1 * n10) * exp(- k2 * t)) / (k2 - k1) +
                  (f12 * k1 * n10 * exp(- k1 * t)) / (k2 - k1)
              )
            }
          } else {
            model_function <- function(psi, id, xidep) {
              t <- xidep[, "time"]
              n10 <- psi[id, 1]
              k1 <- psi[id, 2]
              k2 <- psi[id, 3]
              f12 <- psi[id, 4]
              ifelse(xidep[, "name"] == parent_name,
                n10 * exp(- k1 * t),
                (((k2 - k1) * n20 - f12 * k1 * n10) * exp(- k2 * t)) / (k2 - k1) +
                  (f12 * k1 * n10 * exp(- k1 * t)) / (k2 - k1)
              )
            }
            transform.par = c(0, 1, 1, 3)
          }
        }
        if (identical(types, c("DFOP", "SFO"))) {
          if (transformations == "mkin") {
            model_function <- function(psi, id, xidep) {
              t <- xidep[, "time"]
              n10 <- psi[id, 1]
              k2 <- exp(psi[id, 2])
              f12 <- plogis(psi[id, 3])
              l1 <- exp(psi[id, 4])
              l2 <- exp(psi[id, 5])
              g <- plogis(psi[id, 6])
              ifelse(xidep[, "name"] == parent_name,
                n10 * (g * exp(- l1 * t) + (1 - g) * exp(- l2 * t)),
                ((f12 * g - f12) * l2 * n10 * exp(- l2 * t)) / (l2 - k2) -
                  (f12 * g * l1 * n10 * exp(- l1 * t)) / (l1 - k2) +
                  ((((l1 - k2) * l2 - k2 * l1 + k2^2) * n20 +
                      ((f12 * l1 + (f12 * g - f12) * k2) * l2 -
                        f12 * g * k2 * l1) * n10) * exp( - k2 * t)) /
                  ((l1 - k2) * l2 - k2 * l1 + k2^2)
              )
            }
          } else {
            model_function <- function(psi, id, xidep) {
              t <- xidep[, "time"]
              n10 <- psi[id, 1]
              k2 <- psi[id, 2]
              f12 <- psi[id, 3]
              l1 <- psi[id, 4]
              l2 <- psi[id, 5]
              g <- psi[id, 6]
              ifelse(xidep[, "name"] == parent_name,
                n10 * (g * exp(- l1 * t) + (1 - g) * exp(- l2 * t)),
                ((f12 * g - f12) * l2 * n10 * exp(- l2 * t)) / (l2 - k2) -
                  (f12 * g * l1 * n10 * exp(- l1 * t)) / (l1 - k2) +
                  ((((l1 - k2) * l2 - k2 * l1 + k2^2) * n20 +
                      ((f12 * l1 + (f12 * g - f12) * k2) * l2 -
                        f12 * g * k2 * l1) * n10) * exp( - k2 * t)) /
                  ((l1 - k2) * l2 - k2 * l1 + k2^2)
              )
            }
            transform.par = c(0, 1, 3, 1, 1, 3)
          }
        }
      }
    }
  }

  if (is.function(model_function) & solution_type == "auto") {
    solution_type = "analytical saemix"
  } else {

    if (transformations == "saemix") {
      stop("Using saemix transformations is only supported if an analytical solution is implemented for saemix")
    }

    if (solution_type == "auto")
      solution_type <- object[[1]]$solution_type

    # Define some variables to avoid function calls in model function
    transparms_optim_names <- names(degparms_optim)
    odeini_optim_names <- gsub('_0$', '', odeini_optim_parm_names)
    diff_names <- names(mkin_model$diffs)
    ode_transparms_optim_names <- setdiff(transparms_optim_names, odeini_optim_parm_names)
    transform_rates <- object[[1]]$transform_rates
    transform_fractions <- object[[1]]$transform_fractions

    # Get native symbol info for speed
    use_symbols = FALSE
    if (solution_type == "deSolve" & !is.null(mkin_model$cf)) {
      mkin_model$symbols <- try(deSolve::checkDLL(
        dllname = mkin_model$dll_info[["name"]],
        func = "diffs", initfunc = "initpar",
        jacfunc = NULL, nout = 0, outnames = NULL))
      if (!inherits(mkin_model$symbols, "try-error")) {
        use_symbols = TRUE
      }
    }

    # Define the model function
    model_function <- function(psi, id, xidep) {

      uid <- unique(id)

      res_list <- lapply(uid, function(i) {

        transparms_optim <- as.numeric(psi[i, ]) # psi[i, ] is a dataframe when called in saemix.predict
        names(transparms_optim) <- transparms_optim_names

        odeini_optim <- transparms_optim[odeini_optim_parm_names]
        names(odeini_optim) <- odeini_optim_names

        odeini <- c(odeini_optim, odeini_fixed)[diff_names]

        odeparms_optim <- backtransform_odeparms(transparms_optim[ode_transparms_optim_names], mkin_model,
          transform_rates = transform_rates,
          transform_fractions = transform_fractions)
        odeparms <- c(odeparms_optim, odeparms_fixed)

        xidep_i <- xidep[which(id == i), ]

        if (solution_type[1] == "analytical") {
          out_values <- mkin_model$deg_func(xidep_i, odeini, odeparms)
        } else {

          i_time <- xidep_i$time
          i_name <- xidep_i$name

          out_wide <- mkinpredict(mkin_model,
            odeparms = odeparms, odeini = odeini,
            solution_type = solution_type,
            outtimes = sort(unique(i_time)),
            na_stop = FALSE
          )

          out_index <- cbind(as.character(i_time), as.character(i_name))
          out_values <- out_wide[out_index]
        }
        return(out_values)
      })
      res <- unlist(res_list)
      return(res)
    }
  }

  if (identical(error_model, "auto")) {
    error_model = object[[1]]$err_mod
  }
  error.model <- switch(error_model,
    const = "constant",
    tc = "combined",
    obs = "constant")

  if (error_model == "obs") {
    warning("The error model 'obs' (variance by variable) can currently not be transferred to an saemix model")
  }

  degparms_psi0 <- degparms_optim
  degparms_psi0[names(degparms_start)] <- degparms_start
  psi0_matrix <- matrix(degparms_psi0, nrow = 1,
    dimnames = list("(Intercept)", names(degparms_psi0)))

  if (covariance.model[1] == "auto") {
    covariance_diagonal <- rep(1, length(degparms_optim))
    if (!is.null(no_random_effect)) {
      degparms_no_random <- which(names(degparms_psi0) %in% no_random_effect)
      covariance_diagonal[degparms_no_random] <- 0
    }
    covariance.model = diag(covariance_diagonal)
  }

  if (omega.init[1] == "auto") {
    if (transformations == "mkin") {
      degparms_eta_ini <- as.numeric( # remove names
        mean_degparms(object,
          random = TRUE, test_log_parms = TRUE)$eta)

      omega.init <- 2 * diag(degparms_eta_ini^2)
    } else {
      omega.init <- matrix(nrow = 0, ncol = 0)
    }
  }

  if (is.null(covariate_models)) {
    covariate.model <- matrix(nrow = 0, ncol = 0) # default in saemixModel()
  } else {
    degparms_dependent <- sapply(covariate_models, function(x) as.character(x[[2]]))
    covariates_in_models = unique(unlist(lapply(
      covariate_models, function(x)
        colnames(attr(terms(x), "factors"))
      )))
    covariates_not_available <- setdiff(covariates_in_models, names(covariates))
    if (length(covariates_not_available) > 0) {
      stop("Covariate(s) ", paste(covariates_not_available, collapse = ", "),
        " used in the covariate models not available in the covariate data")
    }
    psi0_matrix <- rbind(psi0_matrix,
      matrix(0, nrow = length(covariates), ncol = ncol(psi0_matrix),
        dimnames = list(names(covariates), colnames(psi0_matrix))))
    covariate.model <- matrix(0, nrow = length(covariates),
      ncol = ncol(psi0_matrix),
      dimnames = list(
        covariates = names(covariates),
        degparms = colnames(psi0_matrix)))
    if (transformations == "saemix") {
      stop("Covariate models with saemix transformations currently not supported")
    }
    parms_trans <- as.data.frame(t(sapply(object, parms, transformed = TRUE)))
    for (covariate_model in covariate_models) {
      covariate_name <- as.character(covariate_model[[2]])
      model_data <- cbind(parms_trans, covariates)
      ini_model <- lm(covariate_model, data = model_data)
      ini_coef <- coef(ini_model)
      psi0_matrix[names(ini_coef), covariate_name] <- ini_coef
      covariate.model[names(ini_coef)[-1], covariate_name] <- as.numeric(as.logical(ini_coef[-1]))
    }
  }

  res <- saemix::saemixModel(model_function,
    psi0 = psi0_matrix,
    "Mixed model generated from mmkin object",
    transform.par = transform.par,
    error.model = error.model,
    verbose = verbose,
    covariance.model = covariance.model,
    covariate.model = covariate.model,
    omega.init = omega.init,
    error.init = error.init,
    ...
  )
  attr(res, "mean_dp_start") <- degparms_optim
  return(res)
}

#' @rdname saem
#' @importFrom rlang !!!
#' @return An [saemix::SaemixData] object.
#' @export
saemix_data <- function(object, covariates = NULL, verbose = FALSE, ...) {
  if (nrow(object) > 1) stop("Only row objects allowed")
  ds_names <- colnames(object)

  ds_list <- lapply(object, function(x) x$data[c("time", "variable", "observed")])
  names(ds_list) <- ds_names
  ds_saemix_all <- vctrs::vec_rbind(!!!ds_list, .names_to = "ds")
  ds_saemix <- data.frame(ds = ds_saemix_all$ds,
    name = as.character(ds_saemix_all$variable),
    time = ds_saemix_all$time,
    value = ds_saemix_all$observed,
    stringsAsFactors = FALSE)
  if (!is.null(covariates)) {
    name.covariates <- names(covariates)
    covariates$ds <- rownames(covariates)
    ds_saemix <- merge(ds_saemix, covariates, sort = FALSE)
  } else {
    name.covariates <- character(0)
  }

  res <- saemix::saemixData(ds_saemix,
    name.group = "ds",
    name.predictors = c("time", "name"),
    name.response = "value",
    name.covariates = name.covariates,
    verbose = verbose,
    ...)
  return(res)
}

#' logLik method for saem.mmkin objects
#'
#' @param object The fitted [saem.mmkin] object
#' @param \dots Passed to [saemix::logLik.SaemixObject]
#' @param method Passed to [saemix::logLik.SaemixObject]
#' @export
logLik.saem.mmkin <- function(object, ..., method = c("is", "lin", "gq")) {
  method <- match.arg(method)
  return(logLik(object$so, method = method))
}

#' @export
update.saem.mmkin <- function(object, ..., evaluate = TRUE) {
  call <- object$call
  # For some reason we get saem.mmkin in the call when using mhmkin
  # so we need to fix this so we do not have to export saem.mmkin in
  # addition to the S3 method
  call[[1]] <- saem

  # We also need to provide the mmkin object in the call, so it
  # will also be found when called by testthat or pkgdown
  call[[2]] <- object$mmkin

  update_arguments <- match.call(expand.dots = FALSE)$...

  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
}

#' @export
#' @rdname parms
#' @param ci Should a matrix with estimates and confidence interval boundaries
#' be returned? If FALSE (default), a vector of estimates is returned if no
#' covariates are given, otherwise a matrix of estimates is returned, with
#' each column corresponding to a row of the data frame holding the covariates
#' @param covariates A data frame holding covariate values for which to
#' return parameter values. Only has an effect if 'ci' is FALSE.
parms.saem.mmkin <- function(object, ci = FALSE, covariates = NULL, ...) {
  cov.mod <- object$sm@covariance.model
  n_cov_mod_parms <- sum(cov.mod[upper.tri(cov.mod, diag = TRUE)])
  n_parms <- length(object$sm@name.modpar) +
    n_cov_mod_parms +
    length(object$sm@name.sigma)

  if (inherits(object$so, "try-error")) {
    conf.int <- matrix(rep(NA, 3 * n_parms), ncol = 3)
    colnames(conf.int) <- c("estimate", "lower", "upper")
  } else {
    conf.int <- object$so@results@conf.int[c("estimate", "lower", "upper")]
    rownames(conf.int) <- object$so@results@conf.int[["name"]]
    conf.int.var <- grepl("^Var\\.", rownames(conf.int))
    conf.int <- conf.int[!conf.int.var, ]
    conf.int.cov <- grepl("^Cov\\.", rownames(conf.int))
    conf.int <- conf.int[!conf.int.cov, ]
  }
  estimate <- conf.int[, "estimate"]

  names(estimate) <- rownames(conf.int)

  if (ci) {
    return(conf.int)
  } else {
    if (is.null(covariates)) {
      return(estimate)
    } else {
      est_for_cov <- matrix(NA,
        nrow = length(object$sm@name.modpar), ncol = nrow(covariates),
        dimnames = (list(object$sm@name.modpar, rownames(covariates))))
      covmods <- object$covariate_models
      names(covmods) <- sapply(covmods, function(x) as.character(x[[2]]))
      for (deg_parm_name in rownames(est_for_cov)) {
        if (deg_parm_name %in% names(covmods)) {
          covariate <- covmods[[deg_parm_name]][[3]]
          beta_degparm_name <- paste0("beta_", covariate,
            "(", deg_parm_name, ")")
          est_for_cov[deg_parm_name, ] <- estimate[deg_parm_name] +
            covariates[[covariate]] * estimate[beta_degparm_name]
        } else {
          est_for_cov[deg_parm_name, ] <- estimate[deg_parm_name]
        }
      }
      return(est_for_cov)
    }
  }
}

#' Method to get status information for fit array objects
#'
#' @param object The object to investigate
#' @param x The object to be printed
#' @param \dots For potential future extensions
#' @return  An object with the same dimensions as the fit array
#' suitable printing method.
#' @export
status <- function(object, ...)
{
  UseMethod("status", object)
}

#' @rdname status
#' @export
#' @examples
#' \dontrun{
#' fits <- mmkin(
#'   c("SFO", "FOMC"),
#'   list("FOCUS A" = FOCUS_2006_A,
#'        "FOCUS B" = FOCUS_2006_C),
#'   quiet = TRUE)
#' status(fits)
#' }
status.mmkin <- function(object, ...) {
  all_summary_warnings <- character()
  sww <- 0 # Counter for Shapiro-Wilks warnings

  result <- lapply(object,
    function(fit) {
      if (inherits(fit, "try-error")) return("E")
      sw <- fit$summary_warnings
      swn <- names(sw)
      if (length(sw) > 0) {
        if (any(grepl("S", swn))) {
          sww <<- sww + 1
          swn <- gsub("S", paste0("S", sww), swn)
        }
        warnstring <- paste(swn, collapse = ", ")
        names(sw) <- swn
        all_summary_warnings <<- c(all_summary_warnings, sw)
        return(warnstring)
      } else {
        return("OK")
      }
    })
  result <- unlist(result)
  dim(result) <- dim(object)
  dimnames(result) <- dimnames(object)

  u_swn <- unique(names(all_summary_warnings))
  attr(result, "unique_warnings") <- all_summary_warnings[u_swn]
  class(result) <- "status.mmkin"
  return(result)
}

#' @rdname status
#' @export
print.status.mmkin <- function(x, ...) {
  u_w <- attr(x, "unique_warnings")
  attr(x, "unique_warnings") <- NULL
  class(x) <- NULL
  print(x, quote = FALSE)
  cat("\n")
  for (i in seq_along(u_w)) {
    cat(names(u_w)[i], ": ", u_w[i], "\n", sep = "")
  }
  if (any(x == "OK")) cat("OK: No warnings\n")
  if (any(x == "E")) cat("E: Error\n")
}

#' @rdname status
#' @export
status.mhmkin <- function(object, ...) {
  if (inherits(object[[1]], "saem.mmkin")) {
    test_func <- function(fit) {
      if (inherits(fit, "try-error")) {
          return("E")
      } else {
        if (inherits(fit$so, "try-error")) {
          return("E")
        } else {
          if (!is.null(fit$FIM_failed)) {
            return_values <- c("fixed effects" = "Fth",
              "random effects and error model parameters" = "FO")
            return(paste(return_values[fit$FIM_failed], collapse = ", "))
          } else {
            return("OK")
          }
        }
      }
    }
  } else {
    stop("Only mhmkin objects containing saem.mmkin objects currently supported")
  }
  result <- lapply(object, test_func)
  result <- unlist(result)
  dim(result) <- dim(object)
  dimnames(result) <- dimnames(object)

  class(result) <- "status.mhmkin"
  return(result)
}

#' @rdname status
#' @export
print.status.mhmkin <- function(x, ...) {
  class(x) <- NULL
  print(x, quote = FALSE)
  cat("\n")
  if (any(x == "OK")) cat("OK: Fit terminated successfully\n")
  if (any(x == "Fth")) cat("Fth: Could not invert FIM for fixed effects\n")
  if (any(x == "FO")) cat("FO: Could not invert FIM for random effects and error model parameters\n")
  if (any(x == "Fth, FO")) cat("Fth, FO: Could not invert FIM for fixed effects, nor for random effects and error model parameters\n")
  if (any(x == "E")) cat("E: Error\n")
}


#' Function to calculate endpoints for further use from kinetic models fitted
#' with mkinfit
#'
#' This function calculates DT50 and DT90 values as well as formation fractions
#' from kinetic models fitted with mkinfit. If the SFORB model was specified
#' for one of the parents or metabolites, the Eigenvalues are returned. These
#' are equivalent to the rate constants of the DFOP model, but with the
#' advantage that the SFORB model can also be used for metabolites.
#'
#' Additional DT50 values are calculated from the FOMC DT90 and k1 and k2 from
#' HS and DFOP, as well as from Eigenvalues b1 and b2 of any SFORB models
#'
#' @param fit An object of class [mkinfit], [nlme.mmkin] or [saem.mmkin], or
#' another object that has list components mkinmod containing an [mkinmod]
#' degradation model, and two numeric vectors, bparms.optim and bparms.fixed,
#' that contain parameter values for that model.
#' @param covariates Numeric vector with covariate values for all variables in
#' any covariate models in the object. If given, it overrides 'covariate_quantile'.
#' @param covariate_quantile This argument only has an effect if the fitted
#' object has covariate models. If so, the default is to show endpoints
#' for the median of the covariate values (50th percentile).
#' @importFrom stats optimize
#' @return A list with a matrix of dissipation times named distimes, and, if
#' applicable, a vector of formation fractions named ff and, if the SFORB model
#' was in use, a vector of eigenvalues of these SFORB models, equivalent to
#' DFOP rate constants
#' @note The function is used internally by [summary.mkinfit],
#' [summary.nlme.mmkin] and [summary.saem.mmkin].
#' @author Johannes Ranke
#' @examples
#'
#'   fit <- mkinfit("FOMC", FOCUS_2006_C, quiet = TRUE)
#'   endpoints(fit)
#'   \dontrun{
#'     fit_2 <- mkinfit("DFOP", FOCUS_2006_C, quiet = TRUE)
#'     endpoints(fit_2)
#'     fit_3 <- mkinfit("SFORB", FOCUS_2006_C, quiet = TRUE)
#'     endpoints(fit_3)
#'   }
#'
#' @export
endpoints <- function(fit, covariates = NULL, covariate_quantile = 0.5) {
  mkinmod <- fit$mkinmod
  obs_vars <- names(mkinmod$spec)

  if (!is.null(fit$covariate_models)) {
    if (is.null(covariates)) {
      covariates = as.data.frame(
        apply(fit$covariates, 2, quantile,
          covariate_quantile, simplify = FALSE))
    } else {
      covariate_m <- matrix(covariates, byrow = TRUE)
      colnames(covariate_m) <- names(covariates)
      rownames(covariate_m) <- "User"
      covariates <- as.data.frame(covariate_m)
    }
    degparms_trans <- parms(fit, covariates = covariates)[, 1]
    if (inherits(fit, "saem.mmkin") & (fit$transformations == "saemix")) {
      degparms <- degparms_trans
    } else {
      degparms <- backtransform_odeparms(degparms_trans,
        fit$mkinmod,
        transform_rates = fit$transform_rates,
        transform_fractions = fit$transform_fractions)
    }
  } else {
    degparms <- c(fit$bparms.optim, fit$bparms.fixed)
  }

  # Set up object to return
  ep <- list()
  ep$covariates <- covariates
  ep$ff <- vector()
  ep$SFORB <- vector()
  ep$distimes <- data.frame(
    DT50 = rep(NA, length(obs_vars)),
    DT90 = rep(NA, length(obs_vars)),
    row.names = obs_vars)

  for (obs_var in obs_vars) {
    type = names(mkinmod$map[[obs_var]])[1]

    # Get formation fractions if directly fitted, and calculate remaining fraction to sink
    f_names = grep(paste("^f", obs_var, sep = "_"), names(degparms), value=TRUE)
    if (length(f_names) > 0) {
      f_values = degparms[f_names]
      f_to_sink = 1 - sum(f_values)
      names(f_to_sink) = ifelse(type == "SFORB",
        paste(obs_var, "free", "sink", sep = "_"),
        paste(obs_var, "sink", sep = "_"))
      for (f_name in f_names) {
        ep$ff[[sub("f_", "", sub("_to_", "_", f_name))]] = f_values[[f_name]]
      }
      ep$ff = append(ep$ff, f_to_sink)
    }

    # Get the rest
    if (type == "SFO") {
      k_names = grep(paste("^k", obs_var, sep="_"), names(degparms), value=TRUE)
      k_tot = sum(degparms[k_names])
      DT50 = log(2)/k_tot
      DT90 = log(10)/k_tot
      if (mkinmod$use_of_ff == "min" && length(obs_vars) > 1) {
        for (k_name in k_names)
        {
          ep$ff[[sub("k_", "", k_name)]] = degparms[[k_name]] / k_tot
        }
      }
    }
    if (type == "FOMC") {
      alpha = degparms["alpha"]
      beta = degparms["beta"]
      DT50 = beta * (2^(1/alpha) - 1)
      DT90 = beta * (10^(1/alpha) - 1)
      DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011
      ep$distimes[obs_var, c("DT50back")] = DT50_back
    }
    if (type == "IORE") {
      k_names = grep(paste("^k__iore", obs_var, sep="_"), names(degparms), value=TRUE)
      k_tot = sum(degparms[k_names])
      # From the NAFTA kinetics guidance, p. 5
      n = degparms[paste("N", obs_var, sep = "_")]
      k = k_tot
      # Use the initial concentration of the parent compound
      source_name = mkinmod$map[[1]][[1]]
      c0 = degparms[paste(source_name, "0", sep = "_")]
      alpha = 1 / (n - 1)
      beta = (c0^(1 - n))/(k * (n - 1))
      DT50 = beta * (2^(1/alpha) - 1)
      DT90 = beta * (10^(1/alpha) - 1)
      DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011
      ep$distimes[obs_var, c("DT50back")] = DT50_back
      if (mkinmod$use_of_ff == "min") {
        for (k_name in k_names)
        {
          ep$ff[[sub("k_", "", k_name)]] = degparms[[k_name]] / k_tot
        }
      }
    }
    if (type == "DFOP") {
      k1 = degparms["k1"]
      k2 = degparms["k2"]
      g = degparms["g"]
      f <- function(log_t, x) {
        t <- exp(log_t)
        fraction <- g * exp( - k1 * t) + (1 - g) * exp( - k2 * t)
        (fraction - (1 - x/100))^2
      }
      DT50_k1 = log(2)/k1
      DT50_k2 = log(2)/k2
      DT90_k1 = log(10)/k1
      DT90_k2 = log(10)/k2

      DT50 <- try(exp(optimize(f, c(log(DT50_k1), log(DT50_k2)), x=50)$minimum),
                  silent = TRUE)
      DT90 <- try(exp(optimize(f, c(log(DT90_k1), log(DT90_k2)), x=90)$minimum),
                  silent = TRUE)
      if (inherits(DT50, "try-error")) DT50 = NA
      if (inherits(DT90, "try-error")) DT90 = NA
      DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011

      ep$distimes[obs_var, c("DT50back")] = DT50_back
      ep$distimes[obs_var, c("DT50_k1")] = DT50_k1
      ep$distimes[obs_var, c("DT50_k2")] = DT50_k2
    }
    if (type == "HS") {
      k1 = degparms["k1"]
      k2 = degparms["k2"]
      tb = degparms["tb"]
      DTx <- function(x) {
        DTx.a <- (log(100/(100 - x)))/k1
        DTx.b <- tb + (log(100/(100 - x)) - k1 * tb)/k2
        if (DTx.a < tb) DTx <- DTx.a
        else DTx <- DTx.b
        return(DTx)
      }
      DT50 <- DTx(50)
      DT90 <- DTx(90)
      DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011
      DT50_k1 = log(2)/k1
      DT50_k2 = log(2)/k2
      ep$distimes[obs_var, c("DT50back")] = DT50_back
      ep$distimes[obs_var, c("DT50_k1")] = DT50_k1
      ep$distimes[obs_var, c("DT50_k2")] = DT50_k2
    }
    if (type == "SFORB") {
      # FOCUS kinetics (2006), p. 60 f
      k_out_names = grep(paste("^k", obs_var, "free", sep="_"), names(degparms), value=TRUE)
      k_out_names = setdiff(k_out_names, paste("k", obs_var, "free", "bound", sep="_"))
      k_1output = sum(degparms[k_out_names])
      k_12 = degparms[paste("k", obs_var, "free", "bound", sep="_")]
      k_21 = degparms[paste("k", obs_var, "bound", "free", sep="_")]

      sqrt_exp = sqrt(1/4 * (k_12 + k_21 + k_1output)^2 - k_1output * k_21)
      b1 = 0.5 * (k_12 + k_21 + k_1output) + sqrt_exp
      b2 = 0.5 * (k_12 + k_21 + k_1output) - sqrt_exp
      g = (k_12 + k_21 - b1)/(b2 - b1)

      DT50_b1 = log(2)/b1
      DT50_b2 = log(2)/b2
      DT90_b1 = log(10)/b1
      DT90_b2 = log(10)/b2

      SFORB_fraction = function(t) {
        g * exp(-b1 * t) + (1 - g) * exp(-b2 * t)
      }

      f_50 <- function(log_t) (SFORB_fraction(exp(log_t)) - 0.5)^2
      log_DT50 <- try(optimize(f_50, c(log(DT50_b1), log(DT50_b2)))$minimum,
                      silent = TRUE)
      f_90 <- function(log_t) (SFORB_fraction(exp(log_t)) - 0.1)^2
      log_DT90 <- try(optimize(f_90, c(log(DT90_b1), log(DT90_b2)))$minimum,
                      silent = TRUE)

      DT50 = if (inherits(log_DT50, "try-error")) NA
             else exp(log_DT50)
      DT90 = if (inherits(log_DT90, "try-error")) NA
             else exp(log_DT90)

      DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011

      for (k_out_name in k_out_names)
      {
        ep$ff[[sub("k_", "", k_out_name)]] = degparms[[k_out_name]] / k_1output
      }

      # Return the eigenvalues for comparison with DFOP rate constants
      ep$SFORB[[paste(obs_var, "b1", sep="_")]] = b1
      ep$SFORB[[paste(obs_var, "b2", sep="_")]] = b2
      # Return g for comparison with DFOP
      ep$SFORB[[paste(obs_var, "g", sep="_")]] = g

      ep$distimes[obs_var, c("DT50back")] = DT50_back
      ep$distimes[obs_var, c(paste("DT50", obs_var, "b1", sep = "_"))] = DT50_b1
      ep$distimes[obs_var, c(paste("DT50", obs_var, "b2", sep = "_"))] = DT50_b2
    }
    if (type == "logistic") {
      # FOCUS kinetics (2014) p. 67
      kmax = degparms["kmax"]
      k0 = degparms["k0"]
      r = degparms["r"]
      DT50 = (1/r) * log(1 - ((kmax/k0) * (1 - 2^(r/kmax))))
      DT90 = (1/r) * log(1 - ((kmax/k0) * (1 - 10^(r/kmax))))

      DT50_k0 = log(2)/k0
      DT50_kmax = log(2)/kmax
      ep$distimes[obs_var, c("DT50_k0")] = DT50_k0
      ep$distimes[obs_var, c("DT50_kmax")] = DT50_kmax
    }
    ep$distimes[obs_var, c("DT50", "DT90")] = c(DT50, DT90)
  }
  if (length(ep$ff) == 0) ep$ff <- NULL
  if (length(ep$SFORB) == 0) ep$SFORB <- NULL
  return(ep)
}

- -

#' Fit nonlinear mixed-effects models built from one or more kinetic
#' degradation models and one or more error models
#'
#' The name of the methods expresses that (**m**ultiple) **h**ierarchichal
#' (also known as multilevel) **m**ulticompartment **kin**etic models are
#' fitted. Our kinetic models are nonlinear, so we can use various nonlinear
#' mixed-effects model fitting functions.
#'
#' @param objects A list of [mmkin] objects containing fits of the same
#' degradation models to the same data, but using different error models.
#' Alternatively, a single [mmkin] object containing fits of several
#' degradation models to the same data
#' @param backend The backend to be used for fitting. Currently, only saemix is
#' supported
#' @param no_random_effect Default is NULL and will be passed to [saem]. If a
#' character vector is supplied, it will be passed to all calls to [saem],
#' which will exclude random effects for all matching parameters. Alternatively,
#' a list of character vectors or an object of class [illparms.mhmkin] can be
#' specified. They have to have the same dimensions that the return object of
#' the current call will have, i.e. the number of rows must match the number
#' of degradation models in the mmkin object(s), and the number of columns must
#' match the number of error models used in the mmkin object(s).
#' @param algorithm The algorithm to be used for fitting (currently not used)
#' @param \dots Further arguments that will be passed to the nonlinear mixed-effects
#' model fitting function.
#' @param cores The number of cores to be used for multicore processing. This
#' is only used when the \code{cluster} argument is \code{NULL}. On Windows
#' machines, cores > 1 is not supported, you need to use the \code{cluster}
#' argument to use multiple logical processors. Per default, all cores detected
#' by [parallel::detectCores()] are used, except on Windows where the default
#' is 1.
#' @param cluster A cluster as returned by [makeCluster] to be used for
#' parallel execution.
#' @importFrom parallel mclapply parLapply detectCores
#' @return A two-dimensional [array] of fit objects and/or try-errors that can
#' be indexed using the degradation model names for the first index (row index)
#' and the error model names for the second index (column index), with class
#' attribute 'mhmkin'.
#' @author Johannes Ranke
#' @seealso \code{\link{[.mhmkin}} for subsetting [mhmkin] objects
#' @export
mhmkin <- function(objects, ...) {
  UseMethod("mhmkin")
}

#' @export
#' @rdname mhmkin
mhmkin.mmkin <- function(objects, ...) {
  mhmkin(list(objects), ...)
}

#' @export
#' @rdname mhmkin
#' @examples
#' \dontrun{
#' # We start with separate evaluations of all the first six datasets with two
#' # degradation models and two error models
#' f_sep_const <- mmkin(c("SFO", "FOMC"), ds_fomc[1:6], cores = 2, quiet = TRUE)
#' f_sep_tc <- update(f_sep_const, error_model = "tc")
#' # The mhmkin function sets up hierarchical degradation models aka
#' # nonlinear mixed-effects models for all four combinations, specifying
#' # uncorrelated random effects for all degradation parameters
#' f_saem_1 <- mhmkin(list(f_sep_const, f_sep_tc), cores = 2)
#' status(f_saem_1)
#' # The 'illparms' function shows that in all hierarchical fits, at least
#' # one random effect is ill-defined (the confidence interval for the
#' # random effect expressed as standard deviation includes zero)
#' illparms(f_saem_1)
#' # Therefore we repeat the fits, excluding the ill-defined random effects
#' f_saem_2 <- update(f_saem_1, no_random_effect = illparms(f_saem_1))
#' status(f_saem_2)
#' illparms(f_saem_2)
#' # Model comparisons show that FOMC with two-component error is preferable,
#' # and confirms our reduction of the default parameter model
#' anova(f_saem_1)
#' anova(f_saem_2)
#' # The convergence plot for the selected model looks fine
#' saemix::plot(f_saem_2[["FOMC", "tc"]]$so, plot.type = "convergence")
#' # The plot of predictions versus data shows that we have a pretty data-rich
#' # situation with homogeneous distribution of residuals, because we used the
#' # same degradation model, error model and parameter distribution model that
#' # was used in the data generation.
#' plot(f_saem_2[["FOMC", "tc"]])
#' # We can specify the same parameter model reductions manually
#' no_ranef <- list("parent_0", "log_beta", "parent_0", c("parent_0", "log_beta"))
#' dim(no_ranef) <- c(2, 2)
#' f_saem_2m <- update(f_saem_1, no_random_effect = no_ranef)
#' anova(f_saem_2m)
#' }
mhmkin.list <- function(objects, backend = "saemix", algorithm = "saem",
  no_random_effect = NULL,
  ...,
  cores = if (Sys.info()["sysname"] == "Windows") 1 else parallel::detectCores(), cluster = NULL)
{
  call <- match.call()
  dot_args <- list(...)
  backend_function <- switch(backend,
    saemix = "saem"
  )

  deg_models <- lapply(objects[[1]][, 1], function(x) x$mkinmod)
  names(deg_models) <- dimnames(objects[[1]])$model
  n.deg <- length(deg_models)

  ds <- lapply(objects[[1]][1, ], function(x) x$data)

  for (other in objects[-1]) {
    # Check if the degradation models in all objects are the same
    for (deg_model_name in names(deg_models)) {
      if (!all.equal(other[[deg_model_name, 1]]$mkinmod$spec,
            deg_models[[deg_model_name]]$spec))
      {
        stop("The mmkin objects have to be based on the same degradation models")
      }
    }
    # Check if they have been fitted to the same dataset
    other_object_ds <- lapply(other[1, ], function(x) x$data)
    for (i in 1:length(ds)) {
      if (!all.equal(ds[[i]][c("time", "variable", "observed")],
          other_object_ds[[i]][c("time", "variable", "observed")]))
      {
        stop("The mmkin objects have to be fitted to the same datasets")
      }
    }
  }

  n.o <- length(objects)

  error_models = sapply(objects, function(x) x[[1]]$err_mod)
  n.e <- length(error_models)

  n.fits <- n.deg * n.e
  fit_indices <- matrix(1:n.fits, ncol = n.e)
  dimnames(fit_indices) <- list(degradation = names(deg_models),
                                error = error_models)

  if (is.null(no_random_effect) || is.null(dim(no_random_effect))) {
    no_ranef <- rep(list(no_random_effect), n.fits)
    dim(no_ranef) <- dim(fit_indices)
  } else {
    if (!identical(dim(no_random_effect), dim(fit_indices))) {
      stop("Dimensions of argument 'no_random_effect' are not suitable")
    }
    if (is(no_random_effect, "illparms.mhmkin")) {
      no_ranef_dim <- dim(no_random_effect)
      no_ranef <- lapply(no_random_effect, function(x) {
        no_ranef_split <- strsplit(x, ", ")
        ret <- sapply(no_ranef_split, function(y) {
          gsub("sd\\((.*)\\)", "\\1", y)
        })
        return(ret)
      })
      dim(no_ranef) <- no_ranef_dim
    } else {
      no_ranef <- no_random_effect
    }
  }

  fit_function <- function(fit_index) {
    w <- which(fit_indices == fit_index, arr.ind = TRUE)
    deg_index <- w[1]
    error_index <- w[2]
    mmkin_row <- objects[[error_index]][deg_index, ]
    res <- try(do.call(backend_function,
        args = c(
          list(mmkin_row),
          dot_args,
          list(no_random_effect = no_ranef[[deg_index, error_index]]))))
    return(res)
  }


  fit_time <- system.time({
    if (is.null(cluster)) {
      results <- parallel::mclapply(as.list(1:n.fits), fit_function,
        mc.cores = cores, mc.preschedule = FALSE)
    } else {
      results <- parallel::parLapply(cluster, as.list(1:n.fits), fit_function)
    }
  })

  attributes(results) <- attributes(fit_indices)
  attr(results, "call") <- call
  attr(results, "time") <- fit_time
  class(results) <- switch(backend,
    saemix = c("mhmkin.saem.mmkin", "mhmkin")
  )
  return(results)
}

#' Subsetting method for mhmkin objects
#'
#' @param x An [mhmkin] object.
#' @param i Row index selecting the fits for specific models
#' @param j Column index selecting the fits to specific datasets
#' @param drop If FALSE, the method always returns an mhmkin object, otherwise
#'   either a list of fit objects or a single fit object.
#' @return An object inheriting from \code{\link{mhmkin}}.
#' @rdname mhmkin
#' @export
`[.mhmkin` <- function(x, i, j, ..., drop = FALSE) {
  original_class <- class(x)
  class(x) <- NULL
  x_sub <- x[i, j, drop = drop]

  if (!drop) {
    class(x_sub) <- original_class
  }
  return(x_sub)
}

#' Print method for mhmkin objects
#'
#' @rdname mhmkin
#' @export
print.mhmkin <- function(x, ...) {
  cat("<mhmkin> object\n")
  cat("Status of individual fits:\n\n")
  print(status(x))
}

#' Check if fit within an mhmkin object failed
#' @param x The object to be checked
check_failed <- function(x) {
  if (inherits(x, "try-error")) {
    return(TRUE)
  } else {
    if (inherits(x$so, "try-error")) {
      return(TRUE)
    } else {
      return(FALSE)
    }
  }
}

#' @export
AIC.mhmkin <- function(object, ..., k = 2) {
  res <- sapply(object, function(x) {
    if (check_failed(x)) return(NA)
    else return(AIC(x$so, k = k))
  })
  dim(res) <- dim(object)
  dimnames(res) <- dimnames(object)
  return(res)
}

#' @export
BIC.mhmkin <- function(object, ...) {
  res <- sapply(object, function(x) {
    if (check_failed(x)) return(NA)
    else return(BIC(x$so))
  })
  dim(res) <- dim(object)
  dimnames(res) <- dimnames(object)
  return(res)
}

#' @export
update.mhmkin <- function(object, ..., evaluate = TRUE) {
  call <- attr(object, "call")
  # For some reason we get mhkin.list in call[[1]] when using mhmkin from the
  # loaded package so we need to fix this so we do not have to export
  # mhmkin.list in addition to the S3 method mhmkin
  call[[1]] <- mhmkin

  update_arguments <- match.call(expand.dots = FALSE)$...

  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
}

#' @export
anova.mhmkin <- function(object, ...,
  method = c("is", "lin", "gq"), test = FALSE, model.names = "auto") {
  if (identical(model.names, "auto")) {
    model.names <- outer(rownames(object), colnames(object), paste)
  }
  failed_index <- which(sapply(object, check_failed), arr.ind = TRUE)
  if (length(failed_index > 0)) {
    rlang::inject(anova(!!!(object[-failed_index]), method = method, test = test,
      model.names = model.names[-failed_index]))
  } else {
    rlang::inject(anova(!!!(object), method = method, test = test,
      model.names = model.names))
  }
}


#' Evaluate parent kinetics using the NAFTA guidance
#'
#' The function fits the SFO, IORE and DFOP models using \code{\link{mmkin}}
#' and returns an object of class \code{nafta} that has methods for printing
#' and plotting.
#'
#' @param ds A dataframe that must contain one variable called "time" with the
#'   time values specified by the \code{time} argument, one column called
#'   "name" with the grouping of the observed values, and finally one column of
#'   observed values called "value".
#' @param title Optional title of the dataset
#' @param quiet Should the evaluation text be shown?
#' @param \dots Further arguments passed to \code{\link{mmkin}} (not for the
#'  printing method).
#' @importFrom stats qf
#' @return An list of class \code{nafta}. The list element named "mmkin" is the
#'   \code{\link{mmkin}} object containing the fits of the three models. The
#'   list element named "title" contains the title of the dataset used. The
#'   list element "data" contains the dataset used in the fits.
#' @author Johannes Ranke
#' @source NAFTA (2011) Guidance for evaluating and calculating degradation
#'   kinetics in environmental media. NAFTA Technical Working Group on
#'   Pesticides
#'   \url{https://www.epa.gov/pesticide-science-and-assessing-pesticide-risks/guidance-evaluating-and-calculating-degradation}
#'   accessed 2019-02-22
#'
#'   US EPA (2015) Standard Operating Procedure for Using the NAFTA Guidance to
#'   Calculate Representative Half-life Values and Characterizing Pesticide
#'   Degradation
#'   \url{https://www.epa.gov/pesticide-science-and-assessing-pesticide-risks/standard-operating-procedure-using-nafta-guidance}
#' @examples
#'
#'   nafta_evaluation <- nafta(NAFTA_SOP_Appendix_D, cores = 1)
#'   print(nafta_evaluation)
#'   plot(nafta_evaluation)
#'
#' @export
nafta <- function(ds, title = NA, quiet = FALSE, ...) {
  if (length(levels(ds$name)) > 1) {
    stop("The NAFTA procedure is only defined for decline data for a single compound")
  }
  n <- nrow(subset(ds, !is.na(value)))
  models <- c("SFO", "IORE", "DFOP")

  result <- list(title = title, data = ds)
  result$mmkin <- mmkin(models, list(ds), quiet = TRUE, ...)

  distimes <- lapply(result$mmkin, function(x) as.numeric(endpoints(x)$distimes["parent", ]))

  result$distimes <- matrix(NA, nrow = 3, ncol = 3,
    dimnames = list(models, c("DT50", "DT90", "DT50_rep")))
  result$distimes["SFO", ] <- distimes[[1]][c(1, 2, 1)]
  result$distimes["IORE", ] <- distimes[[2]][c(1, 2, 3)]
  result$distimes["DFOP", ] <- distimes[[3]][c(1, 2, 5)]

  # Get parameters with statistics
  result$parameters <- lapply(result$mmkin, function(x) {
    summary(x)$bpar[, c(1, 4:6)]
  })
  names(result$parameters) <- models

  # Compare the sum of squared residuals (SSR) to the upper bound of the
  # confidence region of the SSR for the IORE model
  result$S <- sapply(result$mmkin, function(x) sum(x$data$residual^2))
  names(result$S) <- c("SFO", "IORE", "DFOP")
  # Equation (3) on p. 3
  p <- 3
  result$S["IORE"]
  result$S_c <- result$S[["IORE"]] * (1 + p/(n - p) * qf(0.5, p, n - p))

  result$t_rep <- .evaluate_nafta_results(result$S, result$S_c,
    result$distimes, quiet = quiet)

  class(result) <- "nafta"
  return(result)
}

#' Plot the results of the three models used in the NAFTA scheme.
#'
#' The plots are ordered with increasing complexity of the model in this
#' function (SFO, then IORE, then DFOP).
#'
#' Calls \code{\link{plot.mmkin}}.
#'
#' @param x An object of class \code{\link{nafta}}.
#' @param legend Should a legend be added?
#' @param main Possibility to override the main title of the plot.
#' @param \dots Further arguments passed to \code{\link{plot.mmkin}}.
#' @return The function is called for its side effect.
#' @author Johannes Ranke
#' @export
plot.nafta <- function(x, legend = FALSE, main = "auto", ...) {
  if (main == "auto") {
    if (is.na(x$title)) main = ""
    else main = x$title
  }
  plot(x$mmkin, ..., legend = legend, main = main)
}

#' Print nafta objects
#'
#' Print nafta objects. The results for the three models are printed in the
#' order of increasing model complexity, i.e. SFO, then IORE, and finally DFOP.
#'
#' @param x An \code{\link{nafta}} object.
#' @param digits Number of digits to be used for printing parameters and
#'   dissipation times.
#' @rdname nafta
#' @export
print.nafta <- function(x, quiet = TRUE, digits = 3, ...) {
  cat("Sums of squares:\n")
  print(x$S)
  cat("\nCritical sum of squares for checking the SFO model:\n")
  print(x$S_c)
  cat("\nParameters:\n")
  print(x$parameters, digits = digits)
  t_rep <- .evaluate_nafta_results(x$S, x$S_c, x$distimes, quiet = quiet)
  cat("\nDTx values:\n")
  print(signif(x$distimes, digits = digits))
  cat("\nRepresentative half-life:\n")
  print(round(t_rep, 2))
}

.evaluate_nafta_results <- function(S, S_c, distimes, quiet = FALSE) {
  t_SFO <- distimes["IORE", "DT50"]
  t_IORE <- distimes["IORE", "DT50_rep"]
  t_DFOP2 <- distimes["DFOP", "DT50_rep"]

  if (S["SFO"] < S_c) {
    if (!quiet) {
      message("S_SFO is lower than the critical value S_c, use the SFO model")
    }
    t_rep <- t_SFO
  } else {
    if (!quiet) {
      message("The SFO model is rejected as S_SFO is equal or higher than the critical value S_c")
    }
    if (t_IORE < t_DFOP2) {
      if (!quiet) {
        message("The half-life obtained from the IORE model may be used")
      }
      t_rep <- t_IORE
    } else {
      if (!quiet) {
        message("The representative half-life of the IORE model is longer than the one corresponding")
        message("to the terminal degradation rate found with the DFOP model.")
        message("The representative half-life obtained from the DFOP model may be used")
      }
      t_rep <- t_DFOP2
    }
  }
  return(t_rep)
}

#' Summary method for class "nlme.mmkin"
#'
#' Lists model equations, initial parameter values, optimised parameters
#' for fixed effects (population), random effects (deviations from the
#' population mean) and residual error model, as well as the resulting
#' endpoints such as formation fractions and DT50 values. Optionally
#' (default is FALSE), the data are listed in full.
#'
#' @param object an object of class [nlme.mmkin]
#' @param x an object of class [summary.nlme.mmkin]
#' @param data logical, indicating whether the full data should be included in
#'   the summary.
#' @param verbose Should the summary be verbose?
#' @param distimes logical, indicating whether DT50 and DT90 values should be
#'   included.
#' @param alpha error level for confidence interval estimation from the t
#'   distribution
#' @param digits Number of digits to use for printing
#' @param \dots optional arguments passed to methods like \code{print}.
#' @return The summary function returns a list based on the [nlme] object
#'   obtained in the fit, with at least the following additional components
#'   \item{nlmeversion, mkinversion, Rversion}{The nlme, mkin and R versions used}
#'   \item{date.fit, date.summary}{The dates where the fit and the summary were
#'     produced}
#'   \item{diffs}{The differential equations used in the degradation model}
#'   \item{use_of_ff}{Was maximum or minimum use made of formation fractions}
#'   \item{data}{The data}
#'   \item{confint_trans}{Transformed parameters as used in the optimisation, with confidence intervals}
#'   \item{confint_back}{Backtransformed parameters, with confidence intervals if available}
#'   \item{ff}{The estimated formation fractions derived from the fitted
#'      model.}
#'   \item{distimes}{The DT50 and DT90 values for each observed variable.}
#'   \item{SFORB}{If applicable, eigenvalues of SFORB components of the model.}
#'   The print method is called for its side effect, i.e. printing the summary.
#' @importFrom stats predict
#' @author Johannes Ranke for the mkin specific parts
#'   José Pinheiro and Douglas Bates for the components inherited from nlme
#' @examples
#'
#' # Generate five datasets following SFO kinetics
#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120)
#' dt50_sfo_in_pop <- 50
#' k_in_pop <- log(2) / dt50_sfo_in_pop
#' set.seed(1234)
#' k_in <- rlnorm(5, log(k_in_pop), 0.5)
#' SFO <- mkinmod(parent = mkinsub("SFO"))
#'
#' pred_sfo <- function(k) {
#'   mkinpredict(SFO,
#'     c(k_parent = k),
#'     c(parent = 100),
#'     sampling_times)
#' }
#'
#' ds_sfo_mean <- lapply(k_in, pred_sfo)
#' names(ds_sfo_mean) <- paste("ds", 1:5)
#'
#' set.seed(12345)
#' ds_sfo_syn <- lapply(ds_sfo_mean, function(ds) {
#'   add_err(ds,
#'     sdfunc = function(value) sqrt(1^2 + value^2 * 0.07^2),
#'     n = 1)[[1]]
#' })
#'
#' \dontrun{
#' # Evaluate using mmkin and nlme
#' library(nlme)
#' f_mmkin <- mmkin("SFO", ds_sfo_syn, quiet = TRUE, error_model = "tc", cores = 1)
#' f_nlme <- nlme(f_mmkin)
#' summary(f_nlme, data = TRUE)
#' }
#'
#' @export
summary.nlme.mmkin <- function(object, data = FALSE, verbose = FALSE, distimes = TRUE, alpha = 0.05, ...) {

  mod_vars <- names(object$mkinmod$diffs)

  confint_trans <- intervals(object, which = "fixed", level = 1 - alpha)$fixed
  attr(confint_trans, "label") <- NULL
  pnames <- rownames(confint_trans)

  bp <- backtransform_odeparms(confint_trans[, "est."], object$mkinmod,
    object$transform_rates, object$transform_fractions)
  bpnames <- names(bp)

  #  variance-covariance estimates for fixed effects (from summary.lme)
  fixed <- fixef(object)
  stdFixed <- sqrt(diag(as.matrix(object$varFix)))
  object$corFixed <- array(
    t(object$varFix/stdFixed)/stdFixed,
    dim(object$varFix),
    list(names(fixed), names(fixed)))

  # Transform boundaries of CI for one parameter at a time,
  # with the exception of sets of formation fractions (single fractions are OK).
  f_names_skip <- character(0)
  for (box in mod_vars) { # Figure out sets of fractions to skip
    f_names <- grep(paste("^f", box, sep = "_"), pnames, value = TRUE)
    n_paths <- length(f_names)
    if (n_paths > 1) f_names_skip <- c(f_names_skip, f_names)
  }

  confint_back <- matrix(NA, nrow = length(bp), ncol = 3,
    dimnames = list(bpnames, colnames(confint_trans)))
  confint_back[, "est."] <- bp

  for (pname in pnames) {
    if (!pname %in% f_names_skip) {
      par.lower <- confint_trans[pname, "lower"]
      par.upper <- confint_trans[pname, "upper"]
      names(par.lower) <- names(par.upper) <- pname
      bpl <- backtransform_odeparms(par.lower, object$mkinmod,
                                            object$transform_rates,
                                            object$transform_fractions)
      bpu <- backtransform_odeparms(par.upper, object$mkinmod,
                                            object$transform_rates,
                                            object$transform_fractions)
      confint_back[names(bpl), "lower"] <- bpl
      confint_back[names(bpu), "upper"] <- bpu
    }
  }

  object$confint_trans <- confint_trans
  object$confint_back <- confint_back

  object$date.summary = date()
  object$use_of_ff = object$mkinmod$use_of_ff
  object$error_model_algorithm = object$mmkin[[1]]$error_model_algorithm
  err_mod = object$mmkin[[1]]$err_mod

  object$diffs <- object$mkinmod$diffs
  object$print_data <- data
  object$data[["observed"]] <- object$data[["value"]]
  object$data[["value"]] <- NULL
  object$data[["predicted"]] <- predict(object)
  object$data[["residual"]] <- residuals(object, type = "response")
  if (is.null(object$modelStruct$varStruct)) {
    object$data[["std"]] <- object$sigma
  } else {
    object$data[["std"]] <- 1/attr(object$modelStruct$varStruct, "weights")
  }
  object$data[["standardized"]] <- residuals(object, type = "pearson")
  object$verbose <- verbose

  object$fixed <- object$mmkin[[1]]$fixed
  object$AIC = AIC(object)
  object$BIC = BIC(object)
  object$logLik = logLik(object)

  ep <- endpoints(object)
  if (length(ep$ff) != 0)
    object$ff <- ep$ff
  if (distimes) object$distimes <- ep$distimes
  if (length(ep$SFORB) != 0) object$SFORB <- ep$SFORB
  class(object) <- c("summary.nlme.mmkin", "nlme.mmkin", "nlme", "lme")
  return(object)
}

#' @rdname summary.nlme.mmkin
#' @export
print.summary.nlme.mmkin <- function(x, digits = max(3, getOption("digits") - 3), verbose = x$verbose, ...) {
  cat("nlme version used for fitting:     ", x$nlmeversion, "\n")
  cat("mkin version used for pre-fitting: ", x$mkinversion, "\n")
  cat("R version used for fitting:        ", x$Rversion, "\n")

  cat("Date of fit:    ", x$date.fit, "\n")
  cat("Date of summary:", x$date.summary, "\n")

  cat("\nEquations:\n")
  nice_diffs <- gsub("^(d.*) =", "\\1/dt =", x[["diffs"]])
  writeLines(strwrap(nice_diffs, exdent = 11))

  cat("\nData:\n")
  cat(nrow(x$data), "observations of",
    length(unique(x$data$name)), "variable(s) grouped in",
    length(unique(x$data$ds)), "datasets\n")

  cat("\nModel predictions using solution type", x$solution_type, "\n")

  cat("\nFitted in", x$time[["elapsed"]],  "s using", x$numIter, "iterations\n")

  cat("\nVariance model: ")
  cat(switch(x$err_mod,
    const = "Constant variance",
    obs = "Variance unique to each observed variable",
    tc = "Two-component variance function"), "\n")

  cat("\nMean of starting values for individual parameters:\n")
  print(x$mean_dp_start, digits = digits)

  cat("\nFixed degradation parameter values:\n")
  if(length(x$fixed$value) == 0) cat("None\n")
  else print(x$fixed, digits = digits)

  cat("\nResults:\n\n")
  print(data.frame(AIC = x$AIC, BIC = x$BIC, logLik = x$logLik,
      row.names = " "), digits = digits, ...)

  cat("\nOptimised, transformed parameters with symmetric confidence intervals:\n")
  print(x$confint_trans, digits = digits, ...)

  if (nrow(x$confint_trans) > 1) {
    corr <- x$corFixed
    class(corr) <- "correlation"
    print(corr, title = "\nCorrelation:", rdig = digits, ...)
  }

  cat("\n") # Random effects
  print(summary(x$modelStruct), sigma = x$sigma,
        reEstimates = x$coef$random, digits = digits, verbose = verbose, ...)

  cat("\nBacktransformed parameters with asymmetric confidence intervals:\n")
  print(x$confint_back, digits = digits, ...)


  printSFORB <- !is.null(x$SFORB)
  if(printSFORB){
    cat("\nEstimated Eigenvalues of SFORB model(s):\n")
    print(x$SFORB, digits = digits,...)
  }

  printff <- !is.null(x$ff)
  if(printff){
    cat("\nResulting formation fractions:\n")
    print(data.frame(ff = x$ff), digits = digits, ...)
  }

  printdistimes <- !is.null(x$distimes)
  if(printdistimes){
    cat("\nEstimated disappearance times:\n")
    print(x$distimes, digits = digits, ...)
  }

  if (x$print_data){
    cat("\nData:\n")
    print(format(x$data, digits = digits, ...), row.names = FALSE)
  }

  invisible(x)
}

utils::globalVariables(c("variable", "residual"))

#' Function to plot squared residuals and the error model for an mkin object
#' 
#' This function plots the squared residuals for the specified subset of the
#' observed variables from an mkinfit object. In addition, one or more dashed
#' line(s) show the fitted error model.  A combined plot of the fitted model
#' and this error model plot can be obtained with \code{\link{plot.mkinfit}}
#' using the argument \code{show_errplot = TRUE}.
#' 
#' @param object A fit represented in an \code{\link{mkinfit}} object.
#' @param obs_vars A character vector of names of the observed variables for
#'   which residuals should be plotted. Defaults to all observed variables in
#'   the model
#' @param xlim plot range in x direction.
#' @param xlab Label for the x axis.
#' @param ylab Label for the y axis.
#' @param maxy Maximum value of the residuals. This is used for the scaling of
#'   the y axis and defaults to "auto".
#' @param legend Should a legend be plotted?
#' @param lpos Where should the legend be placed? Default is "topright". Will
#'   be passed on to \code{\link{legend}}.
#' @param col_obs Colors for the observed variables.
#' @param pch_obs Symbols to be used for the observed variables.
#' @param frame Should a frame be drawn around the plots?
#' @param \dots further arguments passed to \code{\link{plot}}.
#' @return Nothing is returned by this function, as it is called for its side
#'   effect, namely to produce a plot.
#' @author Johannes Ranke
#' @seealso \code{\link{mkinplot}}, for a way to plot the data and the fitted
#'   lines of the mkinfit object.
#' @keywords hplot
#' @examples
#' 
#' \dontrun{
#' model <- mkinmod(parent = mkinsub("SFO", "m1"), m1 = mkinsub("SFO"))
#' fit <- mkinfit(model, FOCUS_2006_D, error_model = "tc", quiet = TRUE)
#' mkinerrplot(fit)
#' }
#' 
#' @export
mkinerrplot <- function (object,
  obs_vars = names(object$mkinmod$map),
  xlim = c(0, 1.1 * max(object$data$predicted)),
  xlab = "Predicted", ylab = "Squared residual",
  maxy = "auto", legend= TRUE, lpos = "topright",
  col_obs = "auto", pch_obs = "auto",
  frame = TRUE,
  ...)
{
  obs_vars_all <- as.character(unique(object$data$variable))

  if (length(obs_vars) > 0){
      obs_vars <- intersect(obs_vars_all, obs_vars)
  } else obs_vars <- obs_vars_all

  residuals <- subset(object$data, variable %in% obs_vars, residual)

  if (maxy == "auto") maxy = max(residuals^2, na.rm = TRUE)

  # Set colors and symbols
  if (col_obs[1] == "auto") {
    col_obs <- 1:length(obs_vars)
  }

  if (pch_obs[1] == "auto") {
    pch_obs <- 1:length(obs_vars)
  }
  names(col_obs) <- names(pch_obs) <- obs_vars

  plot(0, type = "n",
       xlab = xlab, ylab = ylab,
       xlim = xlim,
       ylim = c(0, 1.2 * maxy), frame = frame, ...)

  for(obs_var in obs_vars){
    residuals_plot <- subset(object$data, variable == obs_var, c("predicted", "residual"))
    points(residuals_plot[["predicted"]],
           residuals_plot[["residual"]]^2,
           pch = pch_obs[obs_var], col = col_obs[obs_var])
  }

  if (object$err_mod == "const") {
    abline(h = object$errparms^2, lty = 2, col = 1)
  }
  if (object$err_mod == "obs") {
    for (obs_var in obs_vars) {
      sigma_name = paste0("sigma_", obs_var)
      abline(h = object$errparms[sigma_name]^2, lty = 2,
             col = col_obs[obs_var])
    }
  }
  if (object$err_mod == "tc") {
    sigma_plot <- function(predicted) {
      sigma_twocomp(predicted,
                    sigma_low = object$errparms[1],
                    rsd_high = object$errparms[2])^2
    }
    plot(sigma_plot, from = 0, to = max(object$data$predicted),
         add = TRUE, lty = 2, col = 1)
  }

  if (legend == TRUE) {
    legend(lpos, inset = c(0.05, 0.05), legend = obs_vars,
      col = col_obs[obs_vars], pch = pch_obs[obs_vars])
  }
}

#' Plot parameter variability of multistart objects
#'
#' Produces a boxplot with all parameters from the multiple runs, scaled
#' either by the parameters of the run with the highest likelihood,
#' or by their medians as proposed in the paper by Duchesne et al. (2021).
#'
#' Starting values of degradation model parameters and error model parameters
#' are shown as green circles. The results obtained in the original run
#' are shown as red circles.
#'
#' @param object The [multistart] object
#' @param llmin The minimum likelihood of objects to be shown
#' @param llquant Fractional value for selecting only the fits with higher
#' likelihoods. Overrides 'llmin'.
#' @param scale By default, scale parameters using the best
#' available fit.
#' If 'median', parameters are scaled using the median parameters from all fits.
#' @param main Title of the plot
#' @param lpos Positioning of the legend.
#' @param \dots Passed to [boxplot]
#' @references Duchesne R, Guillemin A, Gandrillon O, Crauste F. Practical
#' identifiability in the frame of nonlinear mixed effects models: the example
#' of the in vitro erythropoiesis. BMC Bioinformatics. 2021 Oct 4;22(1):478.
#' doi: 10.1186/s12859-021-04373-4.
#' @seealso [multistart]
#' @importFrom stats median quantile
#' @export
parplot <- function(object, ...) {
  UseMethod("parplot")
}

#' @rdname parplot
#' @export
parplot.multistart.saem.mmkin <- function(object, llmin = -Inf, llquant = NA,
  scale = c("best", "median"),
  lpos = "bottomleft", main = "", ...)
{
  oldpar <- par(no.readonly = TRUE)
  on.exit(par(oldpar, no.readonly = TRUE))

  orig <- attr(object, "orig")
  orig_parms <- parms(orig)
  start_degparms <- orig$mean_dp_start
  all_parms <- parms(object, exclude_failed = FALSE)

  if (inherits(object, "multistart.saem.mmkin")) {
    llfunc <- function(object) {
      if (inherits(object$so, "try-error")) return(NA)
      else return(logLik(object$so))
    }
  } else {
    stop("parplot is only implemented for multistart.saem.mmkin objects")
  }
  ll <- sapply(object, llfunc)
  if (!is.na(llquant[1])) {
    if (llmin != -Inf) warning("Overriding 'llmin' because 'llquant' was specified")
    llmin <- quantile(ll, 1 - llquant)
  }
  selected <- which(ll > llmin)
  selected_parms <- all_parms[selected, ]

  par(las = 1)
  if (orig$transformations == "mkin") {
    degparm_names_transformed <- names(start_degparms)
    degparm_index <- which(names(orig_parms) %in% degparm_names_transformed)
    orig_parms[degparm_names_transformed] <- backtransform_odeparms(
      orig_parms[degparm_names_transformed],
      orig$mmkin[[1]]$mkinmod,
      transform_rates = orig$mmkin[[1]]$transform_rates,
      transform_fractions = orig$mmkin[[1]]$transform_fractions)
    start_degparms <- backtransform_odeparms(start_degparms,
      orig$mmkin[[1]]$mkinmod,
      transform_rates = orig$mmkin[[1]]$transform_rates,
      transform_fractions = orig$mmkin[[1]]$transform_fractions)
    degparm_names <- names(start_degparms)

    names(orig_parms) <- c(degparm_names, names(orig_parms[-degparm_index]))

    selected_parms[, degparm_names_transformed] <-
      t(apply(selected_parms[, degparm_names_transformed], 1, backtransform_odeparms,
      orig$mmkin[[1]]$mkinmod,
      transform_rates = orig$mmkin[[1]]$transform_rates,
      transform_fractions = orig$mmkin[[1]]$transform_fractions))
    colnames(selected_parms)[1:length(degparm_names)] <- degparm_names
  }

  start_errparms <- orig$so@model@error.init
  names(start_errparms) <- orig$so@model@name.sigma

  start_omegaparms <- orig$so@model@omega.init

  start_parms <- c(start_degparms, start_errparms)

  scale <- match.arg(scale)
  parm_scale <- switch(scale,
    best = selected_parms[which.best(object[selected]), ],
    median = apply(selected_parms, 2, median)
  )

  # Boxplots of all scaled parameters
  selected_scaled_parms <- t(apply(selected_parms, 1, function(x) x / parm_scale))
  boxplot(selected_scaled_parms, log = "y", main = main, ,
    ylab = "Normalised parameters", ...)

  # Show starting parameters
  start_scaled_parms <- rep(NA_real_, length(orig_parms))
  names(start_scaled_parms) <- names(orig_parms)
  start_scaled_parms[names(start_parms)] <-
    start_parms / parm_scale[names(start_parms)]
  points(start_scaled_parms, col = 3, cex = 3)

  # Show parameters of original run
  orig_scaled_parms <- orig_parms / parm_scale
  points(orig_scaled_parms, col = 2, cex = 2)

  abline(h = 1, lty = 2)

  legend(lpos, inset = c(0.05, 0.05), bty = "n",
    pch = 1, col = 3:1, lty = c(NA, NA, 1),
    legend = c(
      "Original start",
      "Original results",
      "Multistart runs"))
}

utils::globalVariables("ds")

#' Plot predictions from a fitted nonlinear mixed model obtained via an mmkin row object
#'
#' @param x An object of class [mixed.mmkin], [saem.mmkin] or [nlme.mmkin]
#' @param i A numeric index to select datasets for which to plot the individual predictions,
#' in case plots get too large
#' @inheritParams plot.mkinfit
#' @param standardized Should the residuals be standardized? Only takes effect if
#' `resplot = "time"`.
#' @param pop_curves Per default, one population curve is drawn in case
#' population parameters are fitted by the model, e.g. for saem objects.
#' In case there is a covariate model, the behaviour depends on the value
#' of 'covariates'
#' @param covariates Data frame with covariate values for all variables in
#' any covariate models in the object. If given, it overrides 'covariate_quantiles'.
#' Each line in the data frame will result in a line drawn for the population.
#' Rownames are used in the legend to label the lines.
#' @param covariate_quantiles This argument only has an effect if the fitted
#' object has covariate models. If so, the default is to show three population
#' curves, for the 5th percentile, the 50th percentile and the 95th percentile
#' of the covariate values used for fitting the model.
#' @note Covariate models are currently only supported for saem.mmkin objects.
#' @param pred_over Named list of alternative predictions as obtained
#' from [mkinpredict] with a compatible [mkinmod].
#' @param test_log_parms Passed to [mean_degparms] in the case of an
#' [mixed.mmkin] object
#' @param conf.level Passed to [mean_degparms] in the case of an
#' [mixed.mmkin] object
#' @param default_log_parms Passed to [mean_degparms] in the case of an
#' [mixed.mmkin] object
#' @param rel.height.legend The relative height of the legend shown on top
#' @param rel.height.bottom The relative height of the bottom plot row
#' @param ymax Vector of maximum y axis values
#' @param ncol.legend Number of columns to use in the legend
#' @param nrow.legend Number of rows to use in the legend
#' @param resplot Should the residuals plotted against time or against
#' predicted values?
#' @param col_ds Colors used for plotting the observed data and the
#' corresponding model prediction lines for the different datasets.
#' @param pch_ds Symbols to be used for plotting the data.
#' @param lty_ds Line types to be used for the model predictions.
#' @importFrom stats coefficients
#' @return The function is called for its side effect.
#' @author Johannes Ranke
#' @examples
#' ds <- lapply(experimental_data_for_UBA_2019[6:10],
#'  function(x) x$data[c("name", "time", "value")])
#' names(ds) <- paste0("ds ", 6:10)
#' dfop_sfo <- mkinmod(parent = mkinsub("DFOP", "A1"),
#'   A1 = mkinsub("SFO"), quiet = TRUE)
#' \dontrun{
#' f <- mmkin(list("DFOP-SFO" = dfop_sfo), ds, quiet = TRUE)
#' plot(f[, 3:4], standardized = TRUE)
#'
#' # For this fit we need to increase pnlsMaxiter, and we increase the
#' # tolerance in order to speed up the fit for this example evaluation
#' # It still takes 20 seconds to run
#' f_nlme <- nlme(f, control = list(pnlsMaxIter = 120, tolerance = 1e-3))
#' plot(f_nlme)
#'
#' f_saem <- saem(f, transformations = "saemix")
#' plot(f_saem)
#'
#' f_obs <- mmkin(list("DFOP-SFO" = dfop_sfo), ds, quiet = TRUE, error_model = "obs")
#' f_nlmix <- nlmix(f_obs)
#' plot(f_nlmix)
#'
#' # We can overlay the two variants if we generate predictions
#' pred_nlme <- mkinpredict(dfop_sfo,
#'   f_nlme$bparms.optim[-1],
#'   c(parent = f_nlme$bparms.optim[[1]], A1 = 0),
#'   seq(0, 180, by = 0.2))
#' plot(f_saem, pred_over = list(nlme = pred_nlme))
#' }
#' @export
plot.mixed.mmkin <- function(x,
  i = 1:ncol(x$mmkin),
  obs_vars = names(x$mkinmod$map),
  standardized = TRUE,
  covariates = NULL,
  covariate_quantiles = c(0.5, 0.05, 0.95),
  xlab = "Time",
  xlim = range(x$data$time),
  resplot = c("predicted", "time"),
  pop_curves = "auto",
  pred_over = NULL,
  test_log_parms = FALSE,
  conf.level = 0.6,
  default_log_parms = NA,
  ymax = "auto", maxabs = "auto",
  ncol.legend = ifelse(length(i) <= 3, length(i) + 1, ifelse(length(i) <= 8, 3, 4)),
  nrow.legend = ceiling((length(i) + 1) / ncol.legend),
  rel.height.legend = 0.02 + 0.07 * nrow.legend,
  rel.height.bottom = 1.1,
  pch_ds = 1:length(i),
  col_ds = pch_ds + 1,
  lty_ds = col_ds,
  frame = TRUE, ...
)
{
  # Prepare parameters and data
  fit_1 <- x$mmkin[[1]]
  ds_names <- colnames(x$mmkin)

  backtransform = TRUE

  if (identical(class(x), "mixed.mmkin")) {
    if (identical(pop_curves, "auto")) {
      pop_curves <- FALSE
    } else {
      pop_curves <- TRUE
    }
    if (pop_curves) {
      degparms_pop <- mean_degparms(x$mmkin, test_log_parms = test_log_parms,
        conf.level = conf.level, default_log_parms = default_log_parms)
    }

    degparms_tmp <- parms(x$mmkin, transformed = TRUE)
    degparms_i <- as.data.frame(t(degparms_tmp[setdiff(rownames(degparms_tmp), names(fit_1$errparms)), ]))
    residual_type = ifelse(standardized, "standardized", "residual")
    residuals <- x$data[[residual_type]]
  }

  if (inherits(x, "nlme.mmkin")) {
    if (identical(pop_curves, "auto")) {
      pop_curves <- TRUE
    } else {
      pop_curves <- FALSE
    }
    degparms_i <- coefficients(x)
    degparms_pop <- nlme::fixef(x)
    residuals <- residuals(x,
      type = ifelse(standardized, "pearson", "response"))
  }

  if (inherits(x, "saem.mmkin")) {
    if (x$transformations == "saemix") backtransform = FALSE
    psi <- saemix::psi(x$so)
    rownames(psi) <- x$saemix_ds_order
    degparms_i <- psi[ds_names, ]
    degparms_i_names <- colnames(degparms_i)
    residual_type = ifelse(standardized, "standardized", "residual")
    residuals <- x$data[[residual_type]]

    if (identical(pop_curves, "auto")) {
      if (length(x$covariate_models) == 0) {
        degparms_pop <- x$so@results@fixed.effects
        names(degparms_pop) <- degparms_i_names
        pop_curves <- TRUE
      } else {
        if (is.null(covariates)) {
          covariates = as.data.frame(
            apply(x$covariates, 2, quantile,
             covariate_quantiles, simplify = FALSE))
          rownames(covariates) <- paste(
            ifelse(length(x$covariate_models) == 1,
              "Covariate", "Covariates"),
              rownames(covariates))
        }
        degparms_pop <- parms(x, covariates = covariates)
        pop_curves <- TRUE
      }
    } else {
      pop_curves <- FALSE
    }
  }

  if (pop_curves) {
    # Make sure degparms_pop is a matrix, columns corresponding to population curve(s)
    if (is.null(dim(degparms_pop))) {
      degparms_pop <- matrix(degparms_pop, ncol = 1,
        dimnames = list(names(degparms_pop), "Population"))
    }
  }

  degparms_fixed <- fit_1$fixed$value
  names(degparms_fixed) <- rownames(fit_1$fixed)
  degparms_all <- cbind(as.matrix(degparms_i),
    matrix(rep(degparms_fixed, nrow(degparms_i)),
      ncol = length(degparms_fixed),
      nrow = nrow(degparms_i), byrow = TRUE))
  degparms_all_names <- c(names(degparms_i), names(degparms_fixed))
  colnames(degparms_all) <- degparms_all_names

  odeini_names <- grep("_0$", degparms_all_names, value = TRUE)
  odeparms_names <- setdiff(degparms_all_names, odeini_names)

  observed <- cbind(x$data[c("ds", "name", "time", "value")],
    residual = residuals)

  solution_type = fit_1$solution_type

  outtimes <- sort(unique(c(x$data$time,
    seq(xlim[1], xlim[2], length.out = 50))))

  pred_list <- lapply(i, function(ds_i)   {
    odeparms_trans <- degparms_all[ds_i, odeparms_names]
    names(odeparms_trans) <- odeparms_names # needed if only one odeparm
    if (backtransform) {
      odeparms <- backtransform_odeparms(odeparms_trans,
        x$mkinmod,
        transform_rates = fit_1$transform_rates,
        transform_fractions = fit_1$transform_fractions)
    } else {
      odeparms <- odeparms_trans
    }

    odeini <- degparms_all[ds_i, odeini_names]
    names(odeini) <- gsub("_0", "", odeini_names)

    out <- mkinpredict(x$mkinmod, odeparms, odeini,
      outtimes, solution_type = solution_type,
      atol = fit_1$atol, rtol = fit_1$rtol)
  })
  names(pred_list) <- ds_names[i]
  pred_ds <- vctrs::vec_rbind(!!!pred_list, .names_to = "ds")

  if (pop_curves) {
    pred_list_pop <- lapply(1:ncol(degparms_pop), function(cov_i)   {
      degparms_all_pop_i <- c(degparms_pop[, cov_i], degparms_fixed)
      odeparms_pop_trans_i <- degparms_all_pop_i[odeparms_names]
      names(odeparms_pop_trans_i) <- odeparms_names # needed if only one odeparm
      if (backtransform) {
        odeparms_pop_i <- backtransform_odeparms(odeparms_pop_trans_i,
          x$mkinmod,
          transform_rates = fit_1$transform_rates,
          transform_fractions = fit_1$transform_fractions)
      } else {
        odeparms_pop_i <- odeparms_pop_trans_i
      }

      odeini <- degparms_all_pop_i[odeini_names]
      names(odeini) <- gsub("_0", "", odeini_names)

      out <- mkinpredict(x$mkinmod, odeparms_pop_i, odeini,
        outtimes, solution_type = solution_type,
        atol = fit_1$atol, rtol = fit_1$rtol)
    })
    names(pred_list_pop) <- colnames(degparms_pop)

  } else {
    pred_list_pop <- NULL
  }

  # Start of graphical section
  oldpar <- par(no.readonly = TRUE)
  on.exit(par(oldpar, no.readonly = TRUE))

  n_plot_rows = length(obs_vars)
  n_plots = n_plot_rows * 2

  # Set relative plot heights, so the first plot row is the norm
  rel.heights <- if (n_plot_rows > 1) {
    c(rel.height.legend, c(rep(1, n_plot_rows - 1), rel.height.bottom))
  } else {
    c(rel.height.legend, 1)
  }

  layout_matrix = matrix(c(1, 1, 2:(n_plots + 1)),
    n_plot_rows + 1, 2, byrow = TRUE)
  layout(layout_matrix, heights = rel.heights)

  par(mar = c(0.1, 2.1, 0.1, 2.1))

  # Empty plot with legend
  if (!is.null(pred_over)) lty_over <- seq(2, length.out = length(pred_over))
  else lty_over <- NULL
  if (pop_curves) {
    if (is.null(covariates)) {
      lty_pop <- 1
      names(lty_pop) <- "Population"
    } else {
      lty_pop <- 1:nrow(covariates)
      names(lty_pop) <- rownames(covariates)
    }
  } else {
    lty_pop <- NULL
  }
  n_pop_over <- length(lty_pop) + length(lty_over)

  plot(0, type = "n", axes = FALSE, ann = FALSE)
  legend("center", bty = "n", ncol = ncol.legend,
    legend = c(names(lty_pop), names(pred_over), ds_names[i]),
    lty = c(lty_pop, lty_over, lty_ds),
    lwd = c(rep(2, n_pop_over), rep(1, length(i))),
    col = c(rep(1, n_pop_over), col_ds),
    pch = c(rep(NA, n_pop_over), pch_ds))

  resplot <- match.arg(resplot)

  # Loop plot rows
  for (plot_row in 1:n_plot_rows) {

    obs_var <- obs_vars[plot_row]
    observed_row <- subset(observed, name == obs_var)

    # Set ylim to sensible default, or use ymax
    if (identical(ymax, "auto")) {
      ylim_row = c(0,
        max(c(observed_row$value, pred_ds[[obs_var]]), na.rm = TRUE))
    } else {
      ylim_row = c(0, ymax[plot_row])
    }

    # Margins for bottom row of plots when we have more than one row
    # This is the only row that needs to show the x axis legend
    if (plot_row == n_plot_rows) {
      par(mar = c(5.1, 4.1, 1.1, 2.1))
    } else {
      par(mar = c(3.0, 4.1, 1.1, 2.1))
    }

    plot(0, type = "n",
      xlim = xlim, ylim = ylim_row,
      xlab = xlab, ylab = paste("Residues", obs_var), frame = frame)

    if (!is.null(pred_over)) {
      for (i_over in seq_along(pred_over)) {
        pred_frame <- as.data.frame(pred_over[[i_over]])
        lines(pred_frame$time, pred_frame[[obs_var]],
          lwd = 2, lty = lty_over[i_over])
      }
    }

    for (ds_i in seq_along(i)) {
      points(subset(observed_row, ds == ds_names[ds_i], c("time", "value")),
        col = col_ds[ds_i], pch = pch_ds[ds_i])
      lines(subset(pred_ds, ds == ds_names[ds_i], c("time", obs_var)),
        col = col_ds[ds_i], lty = lty_ds[ds_i])
    }

    if (pop_curves) {
      for (cov_i in seq_along(pred_list_pop)) {
        cov_name <- names(pred_list_pop)[cov_i]
        lines(
          pred_list_pop[[cov_i]][, "time"],
          pred_list_pop[[cov_i]][, obs_var],
          type = "l", lwd = 2, lty = lty_pop[cov_i])
      }
    }

    if (identical(maxabs, "auto")) {
      maxabs = max(abs(observed_row$residual), na.rm = TRUE)
    }

    if (identical(resplot, "time")) {
      plot(0, type = "n", xlim = xlim, xlab = "Time",
        ylim = c(-1.2 * maxabs, 1.2 * maxabs),
        ylab = if (standardized) "Standardized residual" else "Residual",
        frame = frame)

      abline(h = 0, lty = 2)

      for (ds_i in seq_along(i)) {
        points(subset(observed_row, ds == ds_names[ds_i], c("time", "residual")),
          col = col_ds[ds_i], pch = pch_ds[ds_i])
      }
    }

    if (identical(resplot, "predicted")) {
      plot(0, type = "n",
        xlim = c(0, max(pred_ds[[obs_var]])),
        xlab = "Predicted",
        ylim = c(-1.2 * maxabs, 1.2 * maxabs),
        ylab = if (standardized) "Standardized residual" else "Residual",
        frame = frame)

      abline(h = 0, lty = 2)

      for (ds_i in seq_along(i)) {
        observed_row_ds <- merge(
          subset(observed_row, ds == ds_names[ds_i], c("time", "residual")),
          subset(pred_ds, ds == ds_names[ds_i], c("time", obs_var)))
        points(observed_row_ds[c(3, 2)],
          col = col_ds[ds_i], pch = pch_ds[ds_i])
      }
    }
  }
}

#' Summary method for class "mkinfit"
#'
#' Lists model equations, initial parameter values, optimised parameters with
#' some uncertainty statistics, the chi2 error levels calculated according to
#' FOCUS guidance (2006) as defined therein, formation fractions, DT50 values
#' and optionally the data, consisting of observed, predicted and residual
#' values.
#'
#' @param object an object of class [mkinfit].
#' @param x an object of class \code{summary.mkinfit}.
#' @param data logical, indicating whether the data should be included in the
#' summary.
#' @param distimes logical, indicating whether DT50 and DT90 values should be
#' included.
#' @param alpha error level for confidence interval estimation from t
#' distribution
#' @param digits Number of digits to use for printing
#' @param \dots optional arguments passed to methods like \code{print}.
#' @importFrom stats qt pt cov2cor
#' @return The summary function returns a list with components, among others
#'   \item{version, Rversion}{The mkin and R versions used}
#'   \item{date.fit, date.summary}{The dates where the fit and the summary were
#'     produced}
#'   \item{diffs}{The differential equations used in the model}
#'   \item{use_of_ff}{Was maximum or minimum use made of formation fractions}
#'   \item{bpar}{Optimised and backtransformed
#'     parameters}
#'   \item{data}{The data (see Description above).}
#'   \item{start}{The starting values and bounds, if applicable, for optimised
#'     parameters.}
#'   \item{fixed}{The values of fixed parameters.}
#'   \item{errmin }{The chi2 error levels for
#'     each observed variable.}
#'   \item{bparms.ode}{All backtransformed ODE
#'     parameters, for use as starting parameters for related models.}
#'   \item{errparms}{Error model parameters.}
#'   \item{ff}{The estimated formation fractions derived from the fitted
#'      model.}
#'   \item{distimes}{The DT50 and DT90 values for each observed variable.}
#'   \item{SFORB}{If applicable, eigenvalues and fractional eigenvector component
#'      g of SFORB systems in the model.}
#'   The print method is called for its side effect, i.e. printing the summary.
#' @author Johannes Ranke
#' @references FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence
#'   and Degradation Kinetics from Environmental Fate Studies on Pesticides in
#'   EU Registration} Report of the FOCUS Work Group on Degradation Kinetics,
#'   EC Document Reference Sanco/10058/2005 version 2.0, 434 pp,
#'   \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics}
#' @examples
#'
#'   summary(mkinfit("SFO", FOCUS_2006_A, quiet = TRUE))
#'
#' @export
summary.mkinfit <- function(object, data = TRUE, distimes = TRUE, alpha = 0.05, ...) {
  param  <- object$par
  pnames <- names(param)
  bpnames <- names(object$bparms.optim)
  epnames <- names(object$errparms)
  p      <- length(param)
  mod_vars <- names(object$mkinmod$diffs)
  covar  <- try(solve(object$hessian), silent = TRUE)
  covar_notrans  <- try(solve(object$hessian_notrans), silent = TRUE)
  rdf <- object$df.residual

  if (!is.numeric(covar) | is.na(covar[1])) {
    covar <- NULL
    se <- lci <- uci <- rep(NA, p)
  } else {
    rownames(covar) <- colnames(covar) <- pnames
    se     <- sqrt(diag(covar))
    lci    <- param + qt(alpha/2, rdf) * se
    uci    <- param + qt(1-alpha/2, rdf) * se
  }

  beparms.optim <- c(object$bparms.optim, object$par[epnames])
  if (!is.numeric(covar_notrans) | is.na(covar_notrans[1])) {
    covar_notrans <- NULL
    se_notrans <- tval <- pval <- rep(NA, p)
  } else {
    rownames(covar_notrans) <- colnames(covar_notrans) <- c(bpnames, epnames)
    se_notrans <- sqrt(diag(covar_notrans))
    tval  <- beparms.optim / se_notrans
    pval  <- pt(abs(tval), rdf, lower.tail = FALSE)
  }

  names(se) <- pnames

  param <- cbind(param, se, lci, uci)
  dimnames(param) <- list(pnames, c("Estimate", "Std. Error", "Lower", "Upper"))

  bparam <- cbind(Estimate = beparms.optim, se_notrans,
                  "t value" = tval, "Pr(>t)" = pval, Lower = NA, Upper = NA)

  # Transform boundaries of CI for one parameter at a time,
  # with the exception of sets of formation fractions (single fractions are OK).
  f_names_skip <- character(0)
  for (box in mod_vars) { # Figure out sets of fractions to skip
    f_names <- grep(paste("^f", box, sep = "_"), pnames, value = TRUE)
    n_paths <- length(f_names)
    if (n_paths > 1) f_names_skip <- c(f_names_skip, f_names)
  }

  for (pname in pnames) {
    if (!pname %in% f_names_skip) {
      par.lower <- param[pname, "Lower"]
      par.upper <- param[pname, "Upper"]
      names(par.lower) <- names(par.upper) <- pname
      bpl <- backtransform_odeparms(par.lower, object$mkinmod,
                                            object$transform_rates,
                                            object$transform_fractions)
      bpu <- backtransform_odeparms(par.upper, object$mkinmod,
                                            object$transform_rates,
                                            object$transform_fractions)
      bparam[names(bpl), "Lower"] <- bpl
      bparam[names(bpu), "Upper"] <- bpu
    }
  }
  bparam[epnames, c("Lower", "Upper")] <- param[epnames, c("Lower", "Upper")]

  ans <- list(
    version = as.character(utils::packageVersion("mkin")),
    Rversion = paste(R.version$major, R.version$minor, sep="."),
    date.fit = object$date,
    date.summary = date(),
    solution_type = object$solution_type,
    warnings = object$summary_warnings,
    use_of_ff = object$mkinmod$use_of_ff,
    error_model_algorithm = object$error_model_algorithm,
    df = c(p, rdf),
    covar = covar,
    covar_notrans = covar_notrans,
    err_mod = object$err_mod,
    niter = object$iterations,
    calls = object$calls,
    time = object$time,
    par = param,
    bpar = bparam)

  if (!is.null(object$version)) {
    ans$fit_version <- object$version
    ans$fit_Rversion <- object$Rversion
    if (ans$fit_version >= "0.9.49.6") {
      ans$AIC = AIC(object)
      ans$BIC = BIC(object)
      ans$logLik = logLik(object)
    }
  }

  ans$diffs <- object$mkinmod$diffs
  if(data) ans$data <- object$data
  ans$start <- object$start
  ans$start_transformed <- object$start_transformed

  ans$fixed <- object$fixed

  ans$errmin <- mkinerrmin(object, alpha = 0.05)

  if (object$calls > 0) {
    if (!is.null(ans$covar)){
      Corr <- cov2cor(ans$covar)
      rownames(Corr) <- colnames(Corr) <- rownames(ans$par)
      ans$Corr <- Corr
    } else {
      warning("Could not calculate correlation; no covariance matrix")
    }
  }

  ans$bparms.ode <- object$bparms.ode
  ans$shapiro.p <- object$shapiro.p
  ep <- endpoints(object)
  if (length(ep$ff) != 0)
    ans$ff <- ep$ff
  if (distimes) ans$distimes <- ep$distimes
  if (length(ep$SFORB) != 0) ans$SFORB <- ep$SFORB
  if (!is.null(object$d_3_message)) ans$d_3_message <- object$d_3_message
  class(ans) <- "summary.mkinfit"
  return(ans)
}

#' @rdname summary.mkinfit
#' @export
print.summary.mkinfit <- function(x, digits = max(3, getOption("digits") - 3), ...) {
  if (is.null(x$fit_version)) {
    cat("mkin version:   ", x$version, "\n")
    cat("R version:      ", x$Rversion, "\n")
  } else {
    cat("mkin version used for fitting:   ", x$fit_version, "\n")
    cat("R version used for fitting:      ", x$fit_Rversion, "\n")
  }

  cat("Date of fit:    ", x$date.fit, "\n")
  cat("Date of summary:", x$date.summary, "\n")

  cat("\nEquations:\n")
  nice_diffs <- gsub("^(d.*) =", "\\1/dt =", x[["diffs"]])
  writeLines(strwrap(nice_diffs, exdent = 11))
  df  <- x$df
  rdf <- df[2]

  cat("\nModel predictions using solution type", x$solution_type, "\n")

  cat("\nFitted using", x$calls, "model solutions performed in", x$time[["elapsed"]],  "s\n")

  if (!is.null(x$err_mod)) {
    cat("\nError model: ")
    cat(switch(x$err_mod,
               const = "Constant variance",
               obs = "Variance unique to each observed variable",
               tc = "Two-component variance function"), "\n")

    cat("\nError model algorithm:", x$error_model_algorithm, "\n")
    if (!is.null(x$d_3_message)) cat(x$d_3_message, "\n")
  }

  cat("\nStarting values for parameters to be optimised:\n")
  print(x$start)

  cat("\nStarting values for the transformed parameters actually optimised:\n")
  print(x$start_transformed)

  cat("\nFixed parameter values:\n")
  if(length(x$fixed$value) == 0) cat("None\n")
  else print(x$fixed)

  # We used to only have one warning - show this for summarising old objects
   if (!is.null(x[["warning"]])) cat("\n\nWarning:", x$warning, "\n\n")

  if (length(x$warnings) > 0) {
    cat("\n\nWarning(s):", "\n")
    cat(x$warnings, sep = "\n")
  }

  if (!is.null(x$AIC)) {
    cat("\nResults:\n\n")
    print(data.frame(AIC = x$AIC, BIC = x$BIC, logLik = x$logLik,
      row.names = " "))
  }

  cat("\nOptimised, transformed parameters with symmetric confidence intervals:\n")
  print(signif(x$par, digits = digits))

  if (x$calls > 0) {
    cat("\nParameter correlation:\n")
    if (!is.null(x$covar)){
      print(x$Corr, digits = digits, ...)
    } else {
      cat("No covariance matrix")
    }
  }

  cat("\nBacktransformed parameters:\n")
  cat("Confidence intervals for internally transformed parameters are asymmetric.\n")
  if ((x$version) < "0.9-36") {
    cat("To get the usual (questionable) t-test, upgrade mkin and repeat the fit.\n")
    print(signif(x$bpar, digits = digits))
  } else {
    cat("t-test (unrealistically) based on the assumption of normal distribution\n")
    cat("for estimators of untransformed parameters.\n")
    print(signif(x$bpar[, c(1, 3, 4, 5, 6)], digits = digits))
  }

  cat("\nFOCUS Chi2 error levels in percent:\n")
  x$errmin$err.min <- 100 * x$errmin$err.min
  print(x$errmin, digits=digits,...)

  printSFORB <- !is.null(x$SFORB)
  if(printSFORB){
    cat("\nEstimated Eigenvalues and DFOP g parameter of SFORB model(s):\n")
    print(x$SFORB, digits=digits,...)
  }

  printff <- !is.null(x$ff)
  if(printff){
    cat("\nResulting formation fractions:\n")
    print(data.frame(ff = x$ff), digits=digits,...)
  }

  printdistimes <- !is.null(x$distimes)
  if(printdistimes){
    cat("\nEstimated disappearance times:\n")
    print(x$distimes, digits=digits,...)
  }

  printdata <- !is.null(x$data)
  if (printdata){
    cat("\nData:\n")
    print(format(x$data, digits = digits, ...), row.names = FALSE)
  }

  invisible(x)
}

utils::globalVariables(c("name", "time", "value"))

#' Fit a kinetic model to data with one or more state variables
#'
#' This function maximises the likelihood of the observed data using the Port
#' algorithm [stats::nlminb()], and the specified initial or fixed
#' parameters and starting values.  In each step of the optimisation, the
#' kinetic model is solved using the function [mkinpredict()], except
#' if an analytical solution is implemented, in which case the model is solved
#' using the degradation function in the [mkinmod] object. The
#' parameters of the selected error model are fitted simultaneously with the
#' degradation model parameters, as both of them are arguments of the
#' likelihood function.
#'
#' Per default, parameters in the kinetic models are internally transformed in
#' order to better satisfy the assumption of a normal distribution of their
#' estimators.
#'
#' @param mkinmod A list of class [mkinmod], containing the kinetic
#'   model to be fitted to the data, or one of the shorthand names ("SFO",
#'   "FOMC", "DFOP", "HS", "SFORB", "IORE"). If a shorthand name is given, a
#'   parent only degradation model is generated for the variable with the
#'   highest value in \code{observed}.
#' @param observed A dataframe with the observed data.  The first column called
#'   "name" must contain the name of the observed variable for each data point.
#'   The second column must contain the times of observation, named "time".
#'   The third column must be named "value" and contain the observed values.
#'   Zero values in the "value" column will be removed, with a warning, in
#'   order to avoid problems with fitting the two-component error model. This
#'   is not expected to be a problem, because in general, values of zero are
#'   not observed in degradation data, because there is a lower limit of
#'   detection.
#' @param parms.ini A named vector of initial values for the parameters,
#'   including parameters to be optimised and potentially also fixed parameters
#'   as indicated by \code{fixed_parms}.  If set to "auto", initial values for
#'   rate constants are set to default values.  Using parameter names that are
#'   not in the model gives an error.
#'
#'   It is possible to only specify a subset of the parameters that the model
#'   needs. You can use the parameter lists "bparms.ode" from a previously
#'   fitted model, which contains the differential equation parameters from
#'   this model.  This works nicely if the models are nested. An example is
#'   given below.
#' @param state.ini A named vector of initial values for the state variables of
#'   the model. In case the observed variables are represented by more than one
#'   model variable, the names will differ from the names of the observed
#'   variables (see \code{map} component of [mkinmod]). The default
#'   is to set the initial value of the first model variable to the mean of the
#'   time zero values for the variable with the maximum observed value, and all
#'   others to 0.  If this variable has no time zero observations, its initial
#'   value is set to 100.
#' @param err.ini A named vector of initial values for the error model
#'   parameters to be optimised.  If set to "auto", initial values are set to
#'   default values.  Otherwise, inital values for all error model parameters
#'   must be given.
#' @param fixed_parms The names of parameters that should not be optimised but
#'   rather kept at the values specified in \code{parms.ini}. Alternatively,
#'   a named numeric vector of parameters to be fixed, regardless of the values
#'   in parms.ini.
#' @param fixed_initials The names of model variables for which the initial
#'   state at time 0 should be excluded from the optimisation. Defaults to all
#'   state variables except for the first one.
#' @param from_max_mean If this is set to TRUE, and the model has only one
#'   observed variable, then data before the time of the maximum observed value
#'   (after averaging for each sampling time) are discarded, and this time is
#'   subtracted from all remaining time values, so the time of the maximum
#'   observed mean value is the new time zero.
#' @param solution_type If set to "eigen", the solution of the system of
#'   differential equations is based on the spectral decomposition of the
#'   coefficient matrix in cases that this is possible. If set to "deSolve", a
#'   numerical [ode solver from package deSolve][deSolve::ode()] is used. If
#'   set to "analytical", an analytical solution of the model is used. This is
#'   only implemented for relatively simple degradation models.  The default is
#'   "auto", which uses "analytical" if possible, otherwise "deSolve" if a
#'   compiler is present, and "eigen" if no compiler is present and the model
#'   can be expressed using eigenvalues and eigenvectors.
#' @param method.ode The solution method passed via [mkinpredict()]
#'   to [deSolve::ode()] in case the solution type is "deSolve". The default
#'   "lsoda" is performant, but sometimes fails to converge.
#' @param use_compiled If set to \code{FALSE}, no compiled version of the
#'   [mkinmod] model is used in the calls to [mkinpredict()] even if a compiled
#'   version is present.
#' @param control A list of control arguments passed to [stats::nlminb()].
#' @param transform_rates Boolean specifying if kinetic rate constants should
#'   be transformed in the model specification used in the fitting for better
#'   compliance with the assumption of normal distribution of the estimator. If
#'   TRUE, also alpha and beta parameters of the FOMC model are
#'   log-transformed, as well as k1 and k2 rate constants for the DFOP and HS
#'   models and the break point tb of the HS model.  If FALSE, zero is used as
#'   a lower bound for the rates in the optimisation.
#' @param transform_fractions Boolean specifying if formation fractions
#'   should be transformed in the model specification used in the fitting for
#'   better compliance with the assumption of normal distribution of the
#'   estimator. The default (TRUE) is to do transformations. If TRUE,
#'   the g parameter of the DFOP model is also transformed. Transformations
#'   are described in [transform_odeparms].
#' @param quiet Suppress printing out the current value of the negative
#'   log-likelihood after each improvement?
#' @param atol Absolute error tolerance, passed to [deSolve::ode()]. Default
#'   is 1e-8, which is lower than the default in the [deSolve::lsoda()]
#'   function which is used per default.
#' @param rtol Absolute error tolerance, passed to [deSolve::ode()]. Default
#'   is 1e-10, much lower than in [deSolve::lsoda()].
#' @param error_model If the error model is "const", a constant standard
#'   deviation is assumed.
#'
#'   If the error model is "obs", each observed variable is assumed to have its
#'   own variance.
#'
#'   If the error model is "tc" (two-component error model), a two component
#'   error model similar to the one described by Rocke and Lorenzato (1995) is
#'   used for setting up the likelihood function.  Note that this model
#'   deviates from the model by Rocke and Lorenzato, as their model implies
#'   that the errors follow a lognormal distribution for large values, not a
#'   normal distribution as assumed by this method.
#' @param error_model_algorithm If "auto", the selected algorithm depends on
#'   the error model.  If the error model is "const", unweighted nonlinear
#'   least squares fitting ("OLS") is selected. If the error model is "obs", or
#'   "tc", the "d_3" algorithm is selected.
#'
#'   The algorithm "d_3" will directly minimize the negative log-likelihood
#'   and independently also use the three step algorithm described below.
#'   The fit with the higher likelihood is returned.
#'
#'   The algorithm "direct" will directly minimize the negative log-likelihood.
#'
#'   The algorithm "twostep" will minimize the negative log-likelihood after an
#'   initial unweighted least squares optimisation step.
#'
#'   The algorithm "threestep" starts with unweighted least squares, then
#'   optimizes only the error model using the degradation model parameters
#'   found, and then minimizes the negative log-likelihood with free
#'   degradation and error model parameters.
#'
#'   The algorithm "fourstep" starts with unweighted least squares, then
#'   optimizes only the error model using the degradation model parameters
#'   found, then optimizes the degradation model again with fixed error model
#'   parameters, and finally minimizes the negative log-likelihood with free
#'   degradation and error model parameters.
#'
#'   The algorithm "IRLS" (Iteratively Reweighted Least Squares) starts with
#'   unweighted least squares, and then iterates optimization of the error
#'   model parameters and subsequent optimization of the degradation model
#'   using those error model parameters, until the error model parameters
#'   converge.
#' @param reweight.tol Tolerance for the convergence criterion calculated from
#'   the error model parameters in IRLS fits.
#' @param reweight.max.iter Maximum number of iterations in IRLS fits.
#' @param trace_parms Should a trace of the parameter values be listed?
#' @param test_residuals Should the residuals be tested for normal distribution?
#' @param \dots Further arguments that will be passed on to
#'   [deSolve::ode()].
#' @importFrom stats nlminb aggregate dist shapiro.test
#' @return A list with "mkinfit" in the class attribute.
#' @note When using the "IORE" submodel for metabolites, fitting with
#'   "transform_rates = TRUE" (the default) often leads to failures of the
#'   numerical ODE solver. In this situation it may help to switch off the
#'   internal rate transformation.
#' @author Johannes Ranke
#' @seealso [summary.mkinfit], [plot.mkinfit], [parms] and [lrtest].
#'
#'   Comparisons of models fitted to the same data can be made using
#'   \code{\link{AIC}} by virtue of the method \code{\link{logLik.mkinfit}}.
#'
#'   Fitting of several models to several datasets in a single call to
#'   \code{\link{mmkin}}.
#' @references Rocke DM and Lorenzato S (1995) A two-component model
#'   for measurement error in analytical chemistry. *Technometrics* 37(2), 176-184.
#'
#'   Ranke J and Meinecke S (2019) Error Models for the Kinetic Evaluation of Chemical
#'   Degradation Data. *Environments* 6(12) 124
#'   \doi{10.3390/environments6120124}.
#' @examples
#'
#' # Use shorthand notation for parent only degradation
#' fit <- mkinfit("FOMC", FOCUS_2006_C, quiet = TRUE)
#' summary(fit)
#'
#' # One parent compound, one metabolite, both single first order.
#' # We remove zero values from FOCUS dataset D in order to avoid warnings
#' FOCUS_D <- subset(FOCUS_2006_D, value != 0)
#' # Use mkinsub for convenience in model formulation. Pathway to sink included per default.
#' SFO_SFO <- mkinmod(
#'   parent = mkinsub("SFO", "m1"),
#'   m1 = mkinsub("SFO"))
#'
#' # Fit the model quietly to the FOCUS example dataset D using defaults
#' fit <- mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE)
#' plot_sep(fit)
#' # As lower parent values appear to have lower variance, we try an alternative error model
#' fit.tc <- mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE, error_model = "tc")
#' # This avoids the warning, and the likelihood ratio test confirms it is preferable
#' lrtest(fit.tc, fit)
#' # We can also allow for different variances of parent and metabolite as error model
#' fit.obs <- mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE, error_model = "obs")
#' # The two-component error model has significantly higher likelihood
#' lrtest(fit.obs, fit.tc)
#' parms(fit.tc)
#' endpoints(fit.tc)
#'
#' # We can show a quick (only one replication) benchmark for this case, as we
#' # have several alternative solution methods for the model. We skip
#' # uncompiled deSolve, as it is so slow. More benchmarks are found in the
#' # benchmark vignette
#' \dontrun{
#' if(require(rbenchmark)) {
#'   benchmark(replications = 1, order = "relative", columns = c("test", "relative", "elapsed"),
#'     deSolve_compiled = mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE, error_model = "tc",
#'       solution_type = "deSolve", use_compiled = TRUE),
#'     eigen = mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE, error_model = "tc",
#'       solution_type = "eigen"),
#'     analytical = mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE, error_model = "tc",
#'       solution_type = "analytical"))
#' }
#' }
#'
#' # Use stepwise fitting, using optimised parameters from parent only fit, FOMC-SFO
#' \dontrun{
#' FOMC_SFO <- mkinmod(
#'   parent = mkinsub("FOMC", "m1"),
#'   m1 = mkinsub("SFO"))
#' fit.FOMC_SFO <- mkinfit(FOMC_SFO, FOCUS_D, quiet = TRUE)
#' # Again, we get a warning and try a more sophisticated error model
#' fit.FOMC_SFO.tc <- mkinfit(FOMC_SFO, FOCUS_D, quiet = TRUE, error_model = "tc")
#' # This model has a higher likelihood, but not significantly so
#' lrtest(fit.tc, fit.FOMC_SFO.tc)
#' # Also, the missing standard error for log_beta and the t-tests for alpha
#' # and beta indicate overparameterisation
#' summary(fit.FOMC_SFO.tc, data = FALSE)
#'
#' # We can easily use starting parameters from the parent only fit (only for illustration)
#' fit.FOMC = mkinfit("FOMC", FOCUS_2006_D, quiet = TRUE, error_model = "tc")
#' fit.FOMC_SFO <- mkinfit(FOMC_SFO, FOCUS_D, quiet = TRUE,
#'   parms.ini = fit.FOMC$bparms.ode, error_model = "tc")
#' }
#' @export
mkinfit <- function(mkinmod, observed,
  parms.ini = "auto",
  state.ini = "auto",
  err.ini = "auto",
  fixed_parms = NULL,
  fixed_initials = names(mkinmod$diffs)[-1],
  from_max_mean = FALSE,
  solution_type = c("auto", "analytical", "eigen", "deSolve"),
  method.ode = "lsoda",
  use_compiled = "auto",
  control = list(eval.max = 300, iter.max = 200),
  transform_rates = TRUE,
  transform_fractions = TRUE,
  quiet = FALSE,
  atol = 1e-8, rtol = 1e-10,
  error_model = c("const", "obs", "tc"),
  error_model_algorithm = c("auto", "d_3", "direct", "twostep", "threestep", "fourstep", "IRLS", "OLS"),
  reweight.tol = 1e-8, reweight.max.iter = 10,
  trace_parms = FALSE,
  test_residuals = FALSE,
  ...)
{
  call <- match.call()

  summary_warnings <- character()

  # Derive the name used for the model
  if (is.character(mkinmod)) {
    mkinmod_name <- mkinmod
  } else {
    if (is.null(mkinmod$name)) {
      mkinmod_name <- deparse(substitute(mkinmod))
    } else {
      mkinmod_name <- mkinmod$name
    }
  }

  # Check mkinmod and generate a model for the variable whith the highest value
  # if a suitable string is given
  parent_models_available = c("SFO", "FOMC", "DFOP", "HS", "SFORB", "IORE", "logistic")
  if (!inherits(mkinmod, "mkinmod")) {
    presumed_parent_name = observed[which.max(observed$value), "name"]
    if (mkinmod[[1]] %in% parent_models_available) {
      speclist <- list(list(type = mkinmod, sink = TRUE))
      names(speclist) <- presumed_parent_name
      mkinmod <- mkinmod(speclist = speclist, use_of_ff = "max")
    } else {
      stop("Argument mkinmod must be of class mkinmod or a string containing one of\n  ",
           paste(parent_models_available, collapse = ", "))
    }
  }

  # Get the names of the state variables in the model
  mod_vars <- names(mkinmod$diffs)

  # Get the names of observed variables
  obs_vars <- names(mkinmod$spec)

  # Subset observed data with names of observed data in the model and remove NA values
  observed <- subset(observed, name %in% obs_vars)
  observed <- subset(observed, !is.na(value))

  # Also remove zero values to avoid instabilities (e.g. of the 'tc' error model)
  if (any(observed$value == 0)) {
    zero_warning <- "Observations with value of zero were removed from the data"
    summary_warnings <- c(summary_warnings, Z = zero_warning)
    warning(zero_warning)
    observed <- subset(observed, value != 0)
  }

  # Sort observed values for efficient analytical predictions
  observed$name <- ordered(observed$name, levels = obs_vars)
  observed <- observed[order(observed$name, observed$time), ]

  # Obtain data for decline from maximum mean value if requested
  if (from_max_mean) {
    # This is only used for simple decline models
    if (length(obs_vars) > 1)
      stop("Decline from maximum is only implemented for models with a single observed variable")
    observed$name <- as.character(observed$name)

    means <- aggregate(value ~ time, data = observed, mean, na.rm=TRUE)
    t_of_max <- means[which.max(means$value), "time"]
    observed <- subset(observed, time >= t_of_max)
    observed$time <- observed$time - t_of_max
  }

  # Number observations used for fitting
  n_observed <- nrow(observed)

  # Define starting values for parameters where not specified by the user
  if (parms.ini[[1]] == "auto") parms.ini = vector()

  # Override parms.ini for parameters given as a numeric vector in
  # fixed_parms
  if (is.numeric(fixed_parms)) {
    fixed_parm_names <- names(fixed_parms)
    parms.ini[fixed_parm_names] <- fixed_parms
    fixed_parms <- fixed_parm_names
  }

  # Warn for inital parameter specifications that are not in the model
  wrongpar.names <- setdiff(names(parms.ini), mkinmod$parms)
  if (length(wrongpar.names) > 0) {
    warning("Initial parameter(s) ", paste(wrongpar.names, collapse = ", "),
         " not used in the model")
    parms.ini <- parms.ini[setdiff(names(parms.ini), wrongpar.names)]
  }

  # Warn that the sum of formation fractions may exceed one if they are not
  # fitted in the transformed way
  if (mkinmod$use_of_ff == "max" & transform_fractions == FALSE) {
    warning("The sum of formation fractions may exceed one if you do not use ",
            "transform_fractions = TRUE." )
    for (box in mod_vars) {
      # Stop if formation fractions are not transformed and we have no sink
      if (mkinmod$spec[[box]]$sink == FALSE) {
        stop("If formation fractions are not transformed during the fitting, ",
             "it is not supported to turn off pathways to sink.\n ",
             "Consider turning on the transformation of formation fractions or ",
             "setting up a model with use_of_ff = 'min'.\n")
      }
    }
  }

  # Do not allow fixing formation fractions if we are using the ilr transformation,
  # this is not supported
  if (transform_fractions == TRUE && length(fixed_parms) > 0) {
    if (any(grepl("^f_", fixed_parms))) {
      stop("Fixing formation fractions is not supported when using the ilr ",
           "transformation.")
    }
  }

  # Set initial parameter values, including a small increment (salt)
  # to avoid linear dependencies (singular matrix) in Eigenvalue based solutions
  k_salt = 0
  defaultpar.names <- setdiff(mkinmod$parms, names(parms.ini))
  for (parmname in defaultpar.names) {
    # Default values for rate constants, depending on the parameterisation
    if (grepl("^k", parmname)) {
      parms.ini[parmname] = 0.1 + k_salt
      k_salt = k_salt + 1e-4
    }
    # Default values for rate constants for reversible binding
    if (grepl("free_bound$", parmname)) parms.ini[parmname] = 0.1
    if (grepl("bound_free$", parmname)) parms.ini[parmname] = 0.02
    # Default values for IORE exponents
    if (grepl("^N", parmname)) parms.ini[parmname] = 1.1
    # Default values for the FOMC, DFOP and HS models
    if (parmname == "alpha") parms.ini[parmname] = 1
    if (parmname == "beta") parms.ini[parmname] = 10
    if (parmname == "k1") parms.ini[parmname] = 0.1
    if (parmname == "k2") parms.ini[parmname] = 0.01
    if (parmname == "tb") parms.ini[parmname] = 5
    if (parmname == "g") parms.ini[parmname] = 0.5
    if (parmname == "kmax") parms.ini[parmname] = 0.1
    if (parmname == "k0") parms.ini[parmname] = 0.0001
    if (parmname == "r") parms.ini[parmname] = 0.2
  }
  # Default values for formation fractions in case they are present
  for (obs_var in obs_vars) {
    origin <- mkinmod$map[[obs_var]][[1]]
    f_names <- mkinmod$parms[grep(paste0("^f_", origin), mkinmod$parms)]
    if (length(f_names) > 0) {
      # We need to differentiate between default and specified fractions
      # and set the unspecified to 1 - sum(specified)/n_unspecified
      f_default_names <- intersect(f_names, defaultpar.names)
      f_specified_names <- setdiff(f_names, defaultpar.names)
      sum_f_specified = sum(parms.ini[f_specified_names])
      if (sum_f_specified > 1) {
        stop("Starting values for the formation fractions originating from ",
             origin, " sum up to more than 1.")
      }
      if (mkinmod$spec[[obs_var]]$sink) n_unspecified = length(f_default_names) + 1
      else {
        n_unspecified = length(f_default_names)
      }
      parms.ini[f_default_names] <- (1 - sum_f_specified) / n_unspecified
    }
  }

  # Set default for state.ini if appropriate
  parent_name = names(mkinmod$spec)[[1]]
  parent_time_0 = subset(observed, time == 0 & name == parent_name)$value
  parent_time_0_mean = mean(parent_time_0, na.rm = TRUE)
  if (is.na(parent_time_0_mean)) {
    state.ini_auto = c(100, rep(0, length(mkinmod$diffs) - 1))
  } else {
    state.ini_auto = c(parent_time_0_mean, rep(0, length(mkinmod$diffs) - 1))
  }
  names(state.ini_auto) <- mod_vars

  if (state.ini[1] == "auto") {
    state.ini_used <- state.ini_auto
  } else {
    state.ini_used <- state.ini_auto
    state.ini_good <- intersect(names(mkinmod$diffs), names(state.ini))
    state.ini_used[state.ini_good] <- state.ini[state.ini_good]
  }
  state.ini <- state.ini_used

  # Name the inital state variable values if they are not named yet
  if(is.null(names(state.ini))) names(state.ini) <- mod_vars

  # Transform initial parameter values for fitting
  transparms.ini <- transform_odeparms(parms.ini, mkinmod,
                                       transform_rates = transform_rates,
                                       transform_fractions = transform_fractions)

  # Parameters to be optimised:
  # Kinetic parameters in parms.ini whose names are not in fixed_parms
  parms.fixed <- parms.ini[fixed_parms]
  parms.optim <- parms.ini[setdiff(names(parms.ini), fixed_parms)]

  transparms.fixed <- transform_odeparms(parms.fixed, mkinmod,
                                       transform_rates = transform_rates,
                                       transform_fractions = transform_fractions)
  transparms.optim <- transform_odeparms(parms.optim, mkinmod,
                                       transform_rates = transform_rates,
                                       transform_fractions = transform_fractions)

  # Inital state variables in state.ini whose names are not in fixed_initials
  state.ini.fixed <- state.ini[fixed_initials]
  state.ini.optim <- state.ini[setdiff(names(state.ini), fixed_initials)]

  # Preserve names of state variables before renaming initial state variable
  # parameters
  state.ini.optim.boxnames <- names(state.ini.optim)
  state.ini.fixed.boxnames <- names(state.ini.fixed)
  if(length(state.ini.optim) > 0) {
    names(state.ini.optim) <- paste(names(state.ini.optim), "0", sep="_")
  }
  if(length(state.ini.fixed) > 0) {
    names(state.ini.fixed) <- paste(names(state.ini.fixed), "0", sep="_")
  }

  # Decide if the solution of the model can be based on a simple analytical
  # formula, the spectral decomposition of the matrix (fundamental system)
  # or a numeric ode solver from the deSolve package
  # Prefer deSolve over eigen if a compiled model is present and use_compiled
  # is not set to FALSE
  solution_type = match.arg(solution_type)
  if (solution_type == "analytical" && !is.function(mkinmod$deg_func))
     stop("Analytical solution not implemented for this model.")
  if (solution_type == "eigen" && !is.matrix(mkinmod$coefmat))
     stop("Eigenvalue based solution not possible, coefficient matrix not present.")
  if (solution_type == "auto") {
    if (length(mkinmod$spec) == 1 || is.function(mkinmod$deg_func)) {
      solution_type = "analytical"
    } else {
      if (!is.null(mkinmod$cf) & use_compiled[1] != FALSE) {
        solution_type = "deSolve"
      } else {
        if (is.matrix(mkinmod$coefmat)) {
          solution_type = "eigen"
          if (max(observed$value, na.rm = TRUE) < 0.1) {
            stop("The combination of small observed values (all < 0.1) and solution_type = eigen is error-prone")
          }
        } else {
          solution_type = "deSolve"
        }
      }
    }
  }

  # Get native symbol before iterations info for speed
  use_symbols = FALSE
  if (solution_type == "deSolve" & use_compiled[1] != FALSE) {
    mkinmod[["symbols"]] <- try(
      deSolve::checkDLL(dllname = mkinmod$dll_info[["name"]],
        func = "diffs", initfunc = "initpar",
        jacfunc = NULL, nout = 0, outnames = NULL))
    if (!inherits(mkinmod[["symbols"]], "try-error")) {
      use_symbols = TRUE
    }
  }

  # Get the error model and the algorithm for fitting
  err_mod <- match.arg(error_model)
  error_model_algorithm = match.arg(error_model_algorithm)
  if (error_model_algorithm == "OLS") {
    if (err_mod != "const") stop("OLS is only appropriate for constant variance")
  }
  if (error_model_algorithm == "auto") {
    error_model_algorithm = switch(err_mod,
      const = "OLS", obs = "d_3", tc = "d_3")
  }
  errparm_names <- switch(err_mod,
    "const" = "sigma",
    "obs" = paste0("sigma_", obs_vars),
    "tc" = c("sigma_low", "rsd_high"))
  errparm_names_optim <- if (error_model_algorithm == "OLS") NULL else errparm_names

  # Define starting values for the error model
  if (err.ini[1] != "auto") {
    if (!identical(names(err.ini), errparm_names)) {
      stop("Please supply initial values for error model components ", paste(errparm_names, collapse = ", "))
    } else {
      errparms = err.ini
    }
  } else {
    if (err_mod == "const") {
      errparms = 3
    }
    if (err_mod == "obs") {
      errparms = rep(3, length(obs_vars))
    }
    if (err_mod == "tc") {
      errparms <- c(sigma_low = 0.1, rsd_high = 0.1)
    }
    names(errparms) <- errparm_names
  }
  if (error_model_algorithm == "OLS") {
    errparms_optim <- NULL
  } else {
    errparms_optim <- errparms
  }

  # Unique outtimes for model solution.
  outtimes <- sort(unique(observed$time))

  # Define the objective function for optimisation, including (back)transformations
  cost_function <- function(P, trans = TRUE, OLS = FALSE, fixed_degparms = FALSE, fixed_errparms = FALSE, update_data = TRUE, ...)
  {
    assign("calls", calls + 1, inherits = TRUE) # Increase the model solution counter

    #browser()

    # Trace parameter values if requested and if we are actually optimising
    if(trace_parms & update_data) cat(format(P, width = 10, digits = 6), "\n")

    # Determine local parameter values for the cost estimation
    if (is.numeric(fixed_degparms)) {
      cost_degparms <- fixed_degparms
      cost_errparms <- P
      degparms_fixed = TRUE
    } else {
      degparms_fixed = FALSE
    }

    if (is.numeric(fixed_errparms)) {
      cost_degparms <- P
      cost_errparms <- fixed_errparms
      errparms_fixed = TRUE
    } else {
      errparms_fixed = FALSE
    }

    if (OLS) {
      cost_degparms <- P
      cost_errparms <- numeric(0)
    }

    if (!OLS & !degparms_fixed & !errparms_fixed) {
      cost_degparms <- P[1:(length(P) - length(errparms))]
      cost_errparms <- P[(length(cost_degparms) + 1):length(P)]
    }

    # Initial states for t0
    if(length(state.ini.optim) > 0) {
      odeini <- c(cost_degparms[1:length(state.ini.optim)], state.ini.fixed)
      names(odeini) <- c(state.ini.optim.boxnames, state.ini.fixed.boxnames)
    } else {
      odeini <- state.ini.fixed
      names(odeini) <- state.ini.fixed.boxnames
    }

    odeparms.optim <- cost_degparms[(length(state.ini.optim) + 1):length(cost_degparms)]

    if (trans == TRUE) {
      odeparms <- c(odeparms.optim, transparms.fixed)
      parms <- backtransform_odeparms(odeparms, mkinmod,
                                      transform_rates = transform_rates,
                                      transform_fractions = transform_fractions)
    } else {
      parms <- c(odeparms.optim, parms.fixed)
    }

    # Solve the system with current parameter values
    if (solution_type == "analytical") {
      observed$predicted <- mkinmod$deg_func(observed, odeini, parms)
    } else {
      out <- mkinpredict(mkinmod, parms,
                         odeini, outtimes,
                         solution_type = solution_type,
                         use_compiled = use_compiled,
                         use_symbols = use_symbols,
                         method.ode = method.ode,
                         atol = atol, rtol = rtol,
                         ...)

      observed_index <- cbind(as.character(observed$time), as.character(observed$name))
      observed$predicted <- out[observed_index]
    }

    # Define standard deviation for each observation
    if (err_mod == "const") {
      observed$std <- if (OLS) NA else cost_errparms["sigma"]
    }
    if (err_mod == "obs") {
      std_names <- paste0("sigma_", observed$name)
      observed$std <- cost_errparms[std_names]
    }
    if (err_mod == "tc") {
      observed$std <- sqrt(cost_errparms["sigma_low"]^2 + observed$predicted^2 * cost_errparms["rsd_high"]^2)
    }

    # Calculate model cost
    if (OLS) {
      # Cost is the sum of squared residuals
      cost <- with(observed, sum((value - predicted)^2))
    } else {
      # Cost is the negative log-likelihood
      cost <- - with(observed,
        sum(dnorm(x = value, mean = predicted, sd = std, log = TRUE)))
    }

    # We update the current cost and data during the optimisation, not
    # during hessian calculations
    if (update_data) {

      assign("current_data", observed, inherits = TRUE)

      if (cost < cost.current) {
        assign("cost.current", cost, inherits = TRUE)
        if (!quiet) message(ifelse(OLS, "Sum of squared residuals", "Negative log-likelihood"),
                        " at call ", calls, ": ", signif(cost.current, 6), "\n")
      }
    }
    return(cost)
  }

  names_optim <- c(names(state.ini.optim),
                   names(transparms.optim),
                   errparm_names_optim)
  n_optim <- length(names_optim)

  # Define lower and upper bounds other than -Inf and Inf for parameters
  # for which no internal transformation is requested in the call to mkinfit
  # and for optimised error model parameters
  lower <- rep(-Inf, n_optim)
  upper <- rep(Inf, n_optim)
  names(lower) <- names(upper) <- names_optim

  # IORE exponents are not transformed, but need a lower bound
  index_N <- grep("^N", names(lower))
  lower[index_N] <- 0

  if (!transform_rates) {
    index_k <- grep("^k_", names(lower))
    lower[index_k] <- 0
    index_k__iore <- grep("^k__iore_", names(lower))
    lower[index_k__iore] <- 0
    other_rate_parms <- intersect(c("alpha", "beta", "k1", "k2", "tb", "r"), names(lower))
    lower[other_rate_parms] <- 0
  }

  if (!transform_fractions) {
    index_f <- grep("^f_", names(upper))
    lower[index_f] <- 0
    upper[index_f] <- 1
    other_fraction_parms <- intersect(c("g"), names(upper))
    lower[other_fraction_parms] <- 0
    upper[other_fraction_parms] <- 1
  }

  if (err_mod == "const") {
    if (error_model_algorithm != "OLS") {
      lower["sigma"] <- 0
    }
  }
  if (err_mod == "obs") {
    index_sigma <- grep("^sigma_", names(lower))
    lower[index_sigma] <- 0
  }
  if (err_mod == "tc") {
    lower["sigma_low"] <- 0
    lower["rsd_high"] <- 0
  }

  # Counter for cost function evaluations
  calls = 0
  cost.current <- Inf
  out_predicted <- NA
  current_data <- NA

  # Show parameter names if tracing is requested
  if(trace_parms) cat(format(names_optim, width = 10), "\n")

  #browser()

  # Do the fit and take the time until the hessians are calculated
  fit_time <- system.time({
    degparms <- c(state.ini.optim, transparms.optim)
    n_degparms <- length(degparms)
    degparms_index <- seq(1, n_degparms)
    errparms_index <- seq(n_degparms + 1, length.out = length(errparms))

    if (error_model_algorithm == "d_3") {
      if (!quiet) message("Directly optimising the complete model")
      parms.start <- c(degparms, errparms)
      fit_direct <- try(nlminb(parms.start, cost_function,
        lower = lower[names(parms.start)],
        upper = upper[names(parms.start)],
        control = control, ...))
      if (!inherits(fit_direct, "try-error")) {
        fit_direct$logLik <- - cost.current
        cost.current <- Inf # reset to avoid conflict with the OLS step
        data_direct <- current_data # We need this later if it was better
        direct_failed = FALSE
      } else {
        direct_failed = TRUE
      }
    }
    if (error_model_algorithm != "direct") {
      if (!quiet) message("Ordinary least squares optimisation")
      fit <- nlminb(degparms, cost_function, control = control,
        lower = lower[names(degparms)],
        upper = upper[names(degparms)], OLS = TRUE, ...)
      degparms <- fit$par

      # Get the maximum likelihood estimate for sigma at the optimum parameter values
      current_data$residual <- current_data$value - current_data$predicted
      sigma_mle <- sqrt(sum(current_data$residual^2)/nrow(current_data))

      # Use that estimate for the constant variance, or as first guess if err_mod = "obs"
      if (err_mod != "tc") {
        errparms[names(errparms)] <- sigma_mle
      }
      fit$par <- c(fit$par, errparms)

      cost.current <- cost_function(c(degparms, errparms), OLS = FALSE)
      fit$logLik <- - cost.current
    }
    if (error_model_algorithm %in% c("threestep", "fourstep", "d_3")) {
      if (!quiet) message("Optimising the error model")
      fit <- nlminb(errparms, cost_function, control = control,
        lower = lower[names(errparms)],
        upper = upper[names(errparms)],
        fixed_degparms = degparms, ...)
      errparms <- fit$par
    }
    if (error_model_algorithm == "fourstep") {
      if (!quiet) message("Optimising the degradation model")
      fit <- nlminb(degparms, cost_function, control = control,
        lower = lower[names(degparms)],
        upper = upper[names(degparms)],
        fixed_errparms = errparms, ...)
      degparms <- fit$par
    }
    if (error_model_algorithm %in%
      c("direct", "twostep", "threestep", "fourstep", "d_3")) {
      if (!quiet) message("Optimising the complete model")
      parms.start <- c(degparms, errparms)
      fit <- nlminb(parms.start, cost_function,
        lower = lower[names(parms.start)],
        upper = upper[names(parms.start)],
        control = control, ...)
      degparms <- fit$par[degparms_index]
      errparms <- fit$par[errparms_index]
      fit$logLik <- - cost.current

      if (error_model_algorithm == "d_3") {
        d_3_messages = c(
           direct_failed = "Direct fitting failed, results of three-step fitting are returned",
           same = "Direct fitting and three-step fitting yield approximately the same likelihood",
           threestep = "Three-step fitting yielded a higher likelihood than direct fitting",
           direct = "Direct fitting yielded a higher likelihood than three-step fitting")
        if (direct_failed) {
          if (!quiet) message(d_3_messages["direct_failed"])
          fit$d_3_message <- d_3_messages["direct_failed"]
        } else {
          rel_diff <- abs((fit_direct$logLik - fit$logLik))/-mean(c(fit_direct$logLik, fit$logLik))
          if (rel_diff < 0.0001) {
            if (!quiet) message(d_3_messages["same"])
            fit$d_3_message <- d_3_messages["same"]
          } else {
            if (fit$logLik > fit_direct$logLik) {
              if (!quiet) message(d_3_messages["threestep"])
              fit$d_3_message <- d_3_messages["threestep"]
            } else {
              if (!quiet) message(d_3_messages["direct"])
              fit <- fit_direct
              fit$d_3_message <- d_3_messages["direct"]
              degparms <- fit$par[degparms_index]
              errparms <- fit$par[errparms_index]
              current_data  <- data_direct
            }
          }
        }
      }
    }
    if (err_mod != "const" & error_model_algorithm == "IRLS") {
      reweight.diff <- 1
      n.iter <- 0
      errparms_last <- errparms

      while (reweight.diff > reweight.tol &
             n.iter < reweight.max.iter) {

        if (!quiet) message("Optimising the error model")
        fit <- nlminb(errparms, cost_function, control = control,
          lower = lower[names(errparms)],
          upper = upper[names(errparms)],
          fixed_degparms = degparms, ...)
        errparms <- fit$par

        if (!quiet) message("Optimising the degradation model")
        fit <- nlminb(degparms, cost_function, control = control,
          lower = lower[names(degparms)],
          upper = upper[names(degparms)],
          fixed_errparms = errparms, ...)
        degparms <- fit$par

        reweight.diff <- dist(rbind(errparms, errparms_last))
        errparms_last <- errparms

        fit$par <- c(fit$par, errparms)
        cost.current <- cost_function(c(degparms, errparms), OLS = FALSE)
        fit$logLik <- - cost.current
      }
    }

    dim_hessian <- length(c(degparms, errparms))

    fit$hessian <- try(numDeriv::hessian(cost_function, c(degparms, errparms), OLS = FALSE,
        update_data = FALSE), silent = TRUE)
    if (inherits(fit$hessian, "try-error")) {
      fit$hessian <- matrix(NA, nrow = dim_hessian, ncol = dim_hessian)
    }
    dimnames(fit$hessian) <- list(names(c(degparms, errparms)),
      names(c(degparms, errparms)))

    # Backtransform parameters
    bparms.optim = backtransform_odeparms(degparms, mkinmod,
      transform_rates = transform_rates,
      transform_fractions = transform_fractions)
    bparms.fixed = c(state.ini.fixed, parms.fixed)
    bparms.all = c(bparms.optim, parms.fixed)

    fit$hessian_notrans <- try(numDeriv::hessian(cost_function, c(bparms.optim, errparms),
        OLS = FALSE, trans = FALSE, update_data = FALSE), silent = TRUE)
    if (inherits(fit$hessian_notrans, "try-error")) {
      fit$hessian_notrans <- matrix(NA, nrow = dim_hessian, ncol = dim_hessian)
    }
    dimnames(fit$hessian_notrans) <- list(names(c(bparms.optim, errparms)),
      names(c(bparms.optim, errparms)))
  })

  fit$call <- call

  fit$error_model_algorithm <- error_model_algorithm

  if (fit$convergence != 0) {
    convergence_warning = paste0("Optimisation did not converge:\n", fit$message)
    summary_warnings <- c(summary_warnings, C = convergence_warning)
    warning(convergence_warning)
  } else {
    if(!quiet) message("Optimisation successfully terminated.\n")
  }

  # We need to return some more data for summary and plotting
  fit$solution_type <- solution_type
  fit$transform_rates <- transform_rates
  fit$transform_fractions <- transform_fractions
  fit$reweight.tol <- reweight.tol
  fit$reweight.max.iter <- reweight.max.iter
  fit$control <- control
  fit$calls <- calls
  fit$time <- fit_time

  # We also need the model and a model name for summary and plotting,
  # but without symbols because they could become invalid
  fit$symbols <- NULL
  fit$mkinmod <- mkinmod
  fit$mkinmod$name <- mkinmod_name
  fit$obs_vars <- obs_vars

  # Residual sum of squares as a function of the fitted parameters
  fit$rss <- function(P) cost_function(P, OLS = TRUE, update_data = FALSE)

  # Log-likelihood with possibility to fix degparms or errparms
  fit$ll <- function(P, fixed_degparms = FALSE, fixed_errparms = FALSE, trans = FALSE) {
    - cost_function(P, trans = trans, fixed_degparms = fixed_degparms,
      fixed_errparms = fixed_errparms, OLS = FALSE, update_data = FALSE)
  }

  # Collect initial parameter values in three dataframes
  fit$start <- data.frame(value = c(state.ini.optim,
                                    parms.optim, errparms_optim))
  fit$start$type = c(rep("state", length(state.ini.optim)),
                     rep("deparm", length(parms.optim)),
                     rep("error", length(errparms_optim)))

  fit$start_transformed = data.frame(
      value = c(state.ini.optim, transparms.optim, errparms_optim),
      lower = lower,
      upper = upper)

  fit$fixed <- data.frame(value = c(state.ini.fixed, parms.fixed))
  fit$fixed$type = c(rep("state", length(state.ini.fixed)),
                     rep("deparm", length(parms.fixed)))

  fit$data <- data.frame(time = current_data$time,
                         variable = current_data$name,
                         observed = current_data$value,
                         predicted = current_data$predicted)

  fit$data$residual <- fit$data$observed - fit$data$predicted

  fit$atol <- atol
  fit$rtol <- rtol
  fit$err_mod <- err_mod

  # Return different sets of backtransformed parameters for summary and plotting
  fit$bparms.optim <- bparms.optim
  fit$bparms.fixed <- bparms.fixed

  # Return ode and state parameters for further fitting
  fit$bparms.ode <- bparms.all[mkinmod$parms]
  fit$bparms.state <- c(bparms.all[setdiff(names(bparms.all), names(fit$bparms.ode))],
                        state.ini.fixed)
  names(fit$bparms.state) <- gsub("_0$", "", names(fit$bparms.state))

  fit$errparms <- errparms
  fit$df.residual <- n_observed - length(c(degparms, errparms))

  # Assign the class here so method dispatch works for residuals
  class(fit) <- c("mkinfit")

  if (test_residuals) {
    # Check for normal distribution of residuals
    fit$shapiro.p <- shapiro.test(residuals(fit, standardized = TRUE))$p.value
    if (fit$shapiro.p < 0.05) {
      shapiro_warning <- paste("Shapiro-Wilk test for standardized residuals: p = ", signif(fit$shapiro.p, 3))
      warning(shapiro_warning)
      summary_warnings <- c(summary_warnings, S = shapiro_warning)
    }
  }

  fit$summary_warnings <- summary_warnings

  fit$date <- date()
  fit$version <- as.character(utils::packageVersion("mkin"))
  fit$Rversion <- paste(R.version$major, R.version$minor, sep=".")

  return(fit)
}

#' Method to get the names of ill-defined parameters
#'
#' The method for generalised nonlinear regression fits as obtained
#' with [mkinfit] and [mmkin] checks if the degradation parameters
#' pass the Wald test (in degradation kinetics often simply called t-test) for
#' significant difference from zero. For this test, the parameterisation
#' without parameter transformations is used.
#'
#' The method for hierarchical model fits, also known as nonlinear
#' mixed-effects model fits as obtained with [saem] and [mhmkin]
#' checks if any of the confidence intervals for the random
#' effects expressed as standard deviations include zero, and if
#' the confidence intervals for the error model parameters include
#' zero.
#'
#' @param object The object to investigate
#' @param x The object to be printed
#' @param conf.level The confidence level for checking p values
#' @param \dots For potential future extensions
#' @param random For hierarchical fits, should random effects be tested?
#' @param errmod For hierarchical fits, should error model parameters be
#' tested?
#' @param slopes For hierarchical [saem] fits using saemix as backend,
#' should slope parameters in the covariate model(starting with 'beta_') be
#' tested?
#' @return For [mkinfit] or [saem] objects, a character vector of parameter
#' names. For [mmkin] or [mhmkin] objects, a matrix like object of class
#' 'illparms.mmkin' or 'illparms.mhmkin'.
#' @note All return objects have printing methods. For the single fits, printing
#' does not output anything in the case no ill-defined parameters are found.
#' @export
illparms <- function(object, ...)
{
  UseMethod("illparms", object)
}

#' @rdname illparms
#' @export
#' @examples
#' fit <- mkinfit("FOMC", FOCUS_2006_A, quiet = TRUE)
#' illparms(fit)
illparms.mkinfit <- function(object, conf.level = 0.95, ...) {
  p_values <- suppressWarnings(summary(object)$bpar[, "Pr(>t)"])
  na <- is.na(p_values)
  failed <- p_values > 1 - conf.level
  ret <- names(parms(object))[na | failed]
  class(ret) <- "illparms.mkinfit"
  return(ret)
}

#' @rdname illparms
#' @export
print.illparms.mkinfit <- function(x, ...) {
  class(x) <- NULL
  if (length(x) > 0) {
    print(as.character(x))
  }
}

#' @rdname illparms
#' @export
#' @examples
#' \dontrun{
#' fits <- mmkin(
#'   c("SFO", "FOMC"),
#'   list("FOCUS A" = FOCUS_2006_A,
#'        "FOCUS C" = FOCUS_2006_C),
#'   quiet = TRUE)
#' illparms(fits)
#' }
illparms.mmkin <- function(object, conf.level = 0.95, ...) {
  result <- lapply(object,
    function(fit) {
      if (inherits(fit, "try-error")) return("E")
      ill <- illparms(fit, conf.level = conf.level)
      if (length(ill) > 0) {
        return(paste(ill, collapse = ", "))
      } else {
        return("")
      }
    })
  result <- unlist(result)
  dim(result) <- dim(object)
  dimnames(result) <- dimnames(object)
  class(result) <- "illparms.mmkin"
  return(result)
}

#' @rdname illparms
#' @export
print.illparms.mmkin <- function(x, ...) {
  class(x) <- NULL
  print(x, quote = FALSE)
}

#' @rdname illparms
#' @export
illparms.saem.mmkin <- function(object, conf.level = 0.95, random = TRUE, errmod = TRUE, slopes = TRUE, ...) {
  if (inherits(object$so, "try-error")) {
    ill_parms <- NA
  } else {
    ints <- intervals(object, conf.level = conf.level)
    ill_parms <- character(0)
    if (random) {
      ill_parms_random_i <- which(ints$random[, "lower"] < 0)
      ill_parms_random <- rownames(ints$random)[ill_parms_random_i]
      ill_parms <- c(ill_parms, ill_parms_random)
    }
    if (errmod) {
      ill_parms_errmod_i <- which(ints$errmod[, "lower"] < 0 & ints$errmod[, "upper"] > 0)
      ill_parms_errmod <- rownames(ints$errmod)[ill_parms_errmod_i]
      ill_parms <- c(ill_parms, ill_parms_errmod)
    }
    if (slopes) {
      if (is.null(object$so)) stop("Slope testing is only implemented for the saemix backend")
      slope_names <- grep("^beta_", object$so@model@name.fixed, value = TRUE)
      ci <- object$so@results@conf.int
      rownames(ci) <- ci$name
      slope_ci <- ci[slope_names, ]
      ill_parms_slopes <- slope_ci[, "lower"] < 0 & slope_ci[, "upper"] > 0
      ill_parms <- c(ill_parms, slope_names[ill_parms_slopes])
    }
  }
  class(ill_parms) <- "illparms.saem.mmkin"
  return(ill_parms)
}

#' @rdname illparms
#' @export
print.illparms.saem.mmkin <- print.illparms.mkinfit

#' @rdname illparms
#' @export
illparms.mhmkin <- function(object, conf.level = 0.95, random = TRUE, errmod = TRUE, ...) {
  if (inherits(object[[1]], "saem.mmkin")) {
    check_failed <- function(x) if (inherits(x$so, "try-error")) TRUE else FALSE
  }
  result <- lapply(object,
    function(fit) {
      if (check_failed(fit)) {
        return("E")
      } else {
        if (!is.null(fit$FIM_failed) &&
          "random effects and error model parameters" %in% fit$FIM_failed) {
          return("NA")
        } else {
          ill <- illparms(fit, conf.level = conf.level, random = random, errmod = errmod)
          if (length(ill) > 0) {
            return(paste(ill, collapse = ", "))
          } else {
            return("")
          }
        }
      }
    })
  result <- unlist(result)
  dim(result) <- dim(object)
  dimnames(result) <- dimnames(object)
  class(result) <- "illparms.mhmkin"
  return(result)
}

#' @rdname illparms
#' @export
print.illparms.mhmkin <- function(x, ...) {
  class(x) <- NULL
  print(x, quote = FALSE)
}

utils::globalVariables(c("type", "variable", "observed"))

#' Plot the observed data and the fitted model of an mkinfit object
#'
#' Solves the differential equations with the optimised and fixed parameters
#' from a previous successful call to \code{\link{mkinfit}} and plots the
#' observed data together with the solution of the fitted model.
#'
#' If the current plot device is a \code{\link[tikzDevice]{tikz}} device, then
#' latex is being used for the formatting of the chi2 error level, if
#' \code{show_errmin = TRUE}.
#'
#' @aliases plot.mkinfit plot_sep plot_res plot_err
#' @param x Alias for fit introduced for compatibility with the generic S3
#'   method.
#' @param fit An object of class \code{\link{mkinfit}}.
#' @param obs_vars A character vector of names of the observed variables for
#'   which the data and the model should be plotted. Defauls to all observed
#'   variables in the model.
#' @param xlab Label for the x axis.
#' @param ylab Label for the y axis.
#' @param xlim Plot range in x direction.
#' @param ylim Plot range in y direction. If given as a list, plot ranges
#'   for the different plot rows can be given for row layout.
#' @param col_obs Colors used for plotting the observed data and the
#'   corresponding model prediction lines.
#' @param pch_obs Symbols to be used for plotting the data.
#' @param lty_obs Line types to be used for the model predictions.
#' @param add Should the plot be added to an existing plot?
#' @param legend Should a legend be added to the plot?
#' @param show_residuals Should residuals be shown? If only one plot of the
#'   fits is shown, the residual plot is in the lower third of the plot.
#'   Otherwise, i.e. if "sep_obs" is given, the residual plots will be located
#'   to the right of the plots of the fitted curves. If this is set to
#'   'standardized', a plot of the residuals divided by the standard deviation
#'    given by the fitted error model will be shown.
#' @param standardized When calling 'plot_res', should the residuals be
#'   standardized in the residual plot?
#' @param show_errplot Should squared residuals and the error model be shown?
#'   If only one plot of the fits is shown, this plot is in the lower third of
#'   the plot.  Otherwise, i.e. if "sep_obs" is given, the residual plots will
#'   be located to the right of the plots of the fitted curves.
#' @param maxabs Maximum absolute value of the residuals. This is used for the
#'   scaling of the y axis and defaults to "auto".
#' @param sep_obs Should the observed variables be shown in separate subplots?
#'   If yes, residual plots requested by "show_residuals" will be shown next
#'   to, not below the plot of the fits.
#' @param rel.height.middle The relative height of the middle plot, if more
#'   than two rows of plots are shown.
#' @param row_layout Should we use a row layout where the residual plot or the
#'   error model plot is shown to the right?
#' @param lpos Position(s) of the legend(s). Passed to \code{\link{legend}} as
#'   the first argument.  If not length one, this should be of the same length
#'   as the obs_var argument.
#' @param inset Passed to \code{\link{legend}} if applicable.
#' @param show_errmin Should the FOCUS chi2 error value be shown in the upper
#'   margin of the plot?
#' @param errmin_digits The number of significant digits for rounding the FOCUS
#'   chi2 error percentage.
#' @param frame Should a frame be drawn around the plots?
#' @param \dots Further arguments passed to \code{\link{plot}}.
#' @import graphics
#' @importFrom grDevices dev.cur
#' @return The function is called for its side effect.
#' @author Johannes Ranke
#' @examples
#'
#' # One parent compound, one metabolite, both single first order, path from
#' # parent to sink included
#' \dontrun{
#' SFO_SFO <- mkinmod(parent = mkinsub("SFO", "m1", full = "Parent"),
#'                    m1 = mkinsub("SFO", full = "Metabolite M1" ))
#' fit <- mkinfit(SFO_SFO, FOCUS_2006_D, quiet = TRUE)
#' fit <- mkinfit(SFO_SFO, FOCUS_2006_D, quiet = TRUE, error_model = "tc")
#' plot(fit)
#' plot_res(fit)
#' plot_res(fit, standardized = FALSE)
#' plot_err(fit)
#'
#' # Show the observed variables separately, with residuals
#' plot(fit, sep_obs = TRUE, show_residuals = TRUE, lpos = c("topright", "bottomright"),
#'      show_errmin = TRUE)
#'
#' # The same can be obtained with less typing, using the convenience function plot_sep
#' plot_sep(fit, lpos = c("topright", "bottomright"))
#'
#' # Show the observed variables separately, with the error model
#' plot(fit, sep_obs = TRUE, show_errplot = TRUE, lpos = c("topright", "bottomright"),
#'      show_errmin = TRUE)
#' }
#'
#' @export
plot.mkinfit <- function(x, fit = x,
  obs_vars = names(fit$mkinmod$map),
  xlab = "Time", ylab = "Residue",
  xlim = range(fit$data$time),
  ylim = "default",
  col_obs = 1:length(obs_vars),
  pch_obs = col_obs,
  lty_obs = rep(1, length(obs_vars)),
  add = FALSE, legend = !add,
  show_residuals = FALSE,
  show_errplot = FALSE,
  maxabs = "auto",
  sep_obs = FALSE, rel.height.middle = 0.9,
  row_layout = FALSE,
  lpos = "topright", inset = c(0.05, 0.05),
  show_errmin = FALSE, errmin_digits = 3,
  frame = TRUE, ...)
{
  if (identical(show_residuals, "standardized")) {
    show_residuals <- TRUE
    standardized <- TRUE
  } else {
    standardized <- FALSE
  }

  if (add && show_residuals) stop("If adding to an existing plot we can not show residuals")
  if (add && show_errplot) stop("If adding to an existing plot we can not show the error model plot")
  if (show_residuals && show_errplot) stop("We can either show residuals over time or the error model plot, not both")
  if (add && sep_obs) stop("If adding to an existing plot we can not show observed variables separately")


  solution_type = fit$solution_type
  parms.all <- c(fit$bparms.optim, fit$bparms.fixed)

  ininames <- c(
    rownames(subset(fit$start, type == "state")),
    rownames(subset(fit$fixed, type == "state")))
  odeini <- parms.all[ininames]

  # Order initial state variables
  names(odeini) <- sub("_0", "", names(odeini))
  odeini <- odeini[names(fit$mkinmod$diffs)]

  outtimes <- seq(xlim[1], xlim[2], length.out=100)

  odenames <- c(
    rownames(subset(fit$start, type == "deparm")),
    rownames(subset(fit$fixed, type == "deparm")))
  odeparms <- parms.all[odenames]


  if (solution_type == "deSolve" & !is.null(fit$mkinmod$cf)) {
    fit$mkinmod[["symbols"]] <- deSolve::checkDLL(dllname = fit$mkinmod$dll_info[["name"]],
      func = "diffs", initfunc = "initpar",
      jacfunc = NULL, nout = 0, outnames = NULL)
  }
  out <- mkinpredict(fit$mkinmod, odeparms, odeini, outtimes,
           solution_type = solution_type, atol = fit$atol, rtol = fit$rtol)

  out <- as.data.frame(out)

  names(col_obs) <- names(pch_obs) <- names(lty_obs) <- obs_vars

  # Create a plot layout only if not to be added to an existing plot
  # or only a single plot is requested (e.g. by plot.mmkin)
  do_layout = FALSE
  if (show_residuals | sep_obs | show_errplot) do_layout = TRUE
  n_plot_rows = if (sep_obs) length(obs_vars) else 1

  if (do_layout) {
    # Layout should be restored afterwards
    oldpar <- par(no.readonly = TRUE)
    on.exit(par(oldpar, no.readonly = TRUE))

    # If the observed variables are shown separately, or if requested, do row layout
    if (sep_obs | row_layout) {
      row_layout <- TRUE
      n_plot_cols = if (show_residuals | show_errplot) 2 else 1
      n_plots = n_plot_rows * n_plot_cols

      # Set relative plot heights, so the first and the last plot are the norm
      # and the middle plots (if n_plot_rows >2) are smaller by rel.height.middle
      rel.heights <- if (n_plot_rows > 2) c(1, rep(rel.height.middle, n_plot_rows - 2), 1)
                     else rep(1, n_plot_rows)
      layout_matrix = matrix(1:n_plots,
                             n_plot_rows, n_plot_cols, byrow = TRUE)
      layout(layout_matrix, heights = rel.heights)
    } else { # else show residuals in the lower third to keep compatibility
      layout(matrix(c(1, 2), 2, 1), heights = c(2, 1.3))
            par(mar = c(3, 4, 4, 2) + 0.1)
    }
  }

  # Replicate legend position argument if necessary
  if (length(lpos) == 1) lpos = rep(lpos, n_plot_rows)

  # Loop over plot rows
  for (plot_row in 1:n_plot_rows) {

    row_obs_vars = if (sep_obs) obs_vars[plot_row] else obs_vars

    # Set ylim to sensible default, or to the specified value
    if (is.list(ylim)) {
      ylim_row <- ylim[[plot_row]]
    } else {
      if (ylim[[1]] == "default") {
        ylim_row = c(0, max(c(subset(fit$data, variable %in% row_obs_vars)$observed,
                            unlist(out[row_obs_vars])), na.rm = TRUE))
      } else {
        ylim_row = ylim
      }
    }

    if (row_layout) {
      # Margins for top row of plots when we have more than one row
      # Reduce bottom margin by 2.1 - hides x axis legend
      if (plot_row == 1 & n_plot_rows > 1) {
        par(mar = c(3.0, 4.1, 4.1, 2.1))
      }

      # Margins for middle rows of plots, if any
      if (plot_row > 1 & plot_row < n_plot_rows) {
        # Reduce top margin by 2 after the first plot as we have no main title,
        # reduced plot height, therefore we need rel.height.middle in the layout
        par(mar = c(3.0, 4.1, 2.1, 2.1))
      }

      # Margins for bottom row of plots when we have more than one row
      if (plot_row == n_plot_rows & n_plot_rows > 1) {
        # Restore bottom margin for last plot to show x axis legend
        par(mar = c(5.1, 4.1, 2.1, 2.1))
      }
    }

    # Set up the main plot if not to be added to an existing plot
    if (add == FALSE) {
      plot(0, type="n",
        xlim = xlim, ylim = ylim_row,
        xlab = xlab, ylab = ylab, frame = frame, ...)
    }

    # Plot the data
    for (obs_var in row_obs_vars) {
      points(subset(fit$data, variable == obs_var, c(time, observed)),
        pch = pch_obs[obs_var], col = col_obs[obs_var])
    }

    # Plot the model output
    matlines(out$time, out[row_obs_vars], col = col_obs[row_obs_vars], lty = lty_obs[row_obs_vars])

    if (legend == TRUE) {
      # Get full names from model definition if they are available
      legend_names = lapply(row_obs_vars, function(x) {
                            if (!is.null(fit$mkinmod$spec[[x]]$full_name))
                              if (is.na(fit$mkinmod$spec[[x]]$full_name)) x
                              else fit$mkinmod$spec[[x]]$full_name
                            else x
        })
      legend(lpos[plot_row], inset= inset, legend = legend_names,
        col = col_obs[row_obs_vars], pch = pch_obs[row_obs_vars], lty = lty_obs[row_obs_vars])
    }

    # Show chi2 error value if requested
    if (show_errmin) {
      if (length(row_obs_vars) == 1) {
        errmin_var = row_obs_vars
      } else {
        errmin_var = "All data"
        if (length(row_obs_vars) != length(fit$mkinmod$map)) {
          warning("Showing chi2 error level for all data, but only ",
                  row_obs_vars, " were selected for plotting")
        }
      }

      chi2 <- signif(100 * mkinerrmin(fit)[errmin_var, "err.min"], errmin_digits)
      # Use LateX if the current plotting device is tikz
      if (names(dev.cur()) == "tikz output") {
        chi2_text <- paste0("$\\chi^2$ error level = ", chi2, "\\%")
      } else {
        chi2_perc <- paste0(chi2, "%")
        chi2_text <- bquote(chi^2 ~ "error level" == .(chi2_perc))
      }
      mtext(chi2_text, cex = 0.7, line = 0.4)
    }

    if (do_layout & !row_layout) {
      par(mar = c(5, 4, 0, 2) + 0.1)
    }

    # Show residuals if requested
    if (show_residuals) {
      mkinresplot(fit, obs_vars = row_obs_vars, standardized = standardized,
        pch_obs = pch_obs[row_obs_vars], col_obs = col_obs[row_obs_vars],
        legend = FALSE, frame = frame, xlab = xlab, xlim = xlim, maxabs = maxabs)
    }

    # Show error model plot if requested
    if (show_errplot) {
      mkinerrplot(fit, obs_vars = row_obs_vars,
        pch_obs = pch_obs[row_obs_vars], col_obs = col_obs[row_obs_vars],
        legend = FALSE, frame = frame)
    }
  }
}

#' @rdname plot.mkinfit
#' @export
plot_sep <- function(fit, show_errmin = TRUE,
  show_residuals = ifelse(identical(fit$err_mod, "const"), TRUE, "standardized"), ...) {
  plot.mkinfit(fit, sep_obs = TRUE, show_residuals = show_residuals,
          show_errmin = show_errmin, ...)
}

#' @rdname plot.mkinfit
#' @export
plot_res <- function(fit, sep_obs = FALSE, show_errmin = sep_obs,
  standardized = ifelse(identical(fit$err_mod, "const"), FALSE, TRUE), ...)
{
  plot.mkinfit(fit, sep_obs = sep_obs, show_errmin = show_errmin,
    show_residuals = ifelse(standardized, "standardized", TRUE),
    row_layout = TRUE, ...)
}

#' @rdname plot.mkinfit
#' @export
plot_err <- function(fit, sep_obs = FALSE, show_errmin = sep_obs, ...) {
  plot.mkinfit(fit, sep_obs = sep_obs, show_errmin = show_errmin,
    show_errplot = TRUE, row_layout = TRUE, ...)
}

#' Plot the observed data and the fitted model of an mkinfit object
#'
#' Deprecated function. It now only calls the plot method
#' \code{\link{plot.mkinfit}}.
#'
#' @param fit an object of class \code{\link{mkinfit}}.
#' @param \dots further arguments passed to \code{\link{plot.mkinfit}}.
#' @return The function is called for its side effect.
#' @author Johannes Ranke
#' @export
mkinplot <- function(fit, ...)
{
  plot(fit, ...)
}

#' Create a mixed effects model from an mmkin row object
#'
#' @importFrom rlang !!!
#' @param object An [mmkin] row object
#' @param method The method to be used
#' @param \dots Currently not used
#' @return An object of class 'mixed.mmkin' which has the observed data in a
#'   single dataframe which is convenient for plotting
#' @examples
#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120)
#' n_biphasic <- 8
#' err_1 = list(const = 1, prop = 0.07)
#'
#' DFOP_SFO <- mkinmod(
#'   parent = mkinsub("DFOP", "m1"),
#'   m1 = mkinsub("SFO"),
#'   quiet = TRUE)
#'
#' set.seed(123456)
#' log_sd <- 0.3
#' syn_biphasic_parms <- as.matrix(data.frame(
#'   k1 = rlnorm(n_biphasic, log(0.05), log_sd),
#'   k2 = rlnorm(n_biphasic, log(0.01), log_sd),
#'   g = plogis(rnorm(n_biphasic, 0, log_sd)),
#'   f_parent_to_m1 = plogis(rnorm(n_biphasic, 0, log_sd)),
#'   k_m1 = rlnorm(n_biphasic, log(0.002), log_sd)))
#'
#' ds_biphasic_mean <- lapply(1:n_biphasic,
#'   function(i) {
#'     mkinpredict(DFOP_SFO, syn_biphasic_parms[i, ],
#'       c(parent = 100, m1 = 0), sampling_times)
#'   }
#' )
#'
#' set.seed(123456L)
#' ds_biphasic <- lapply(ds_biphasic_mean, function(ds) {
#'   add_err(ds,
#'     sdfunc = function(value) sqrt(err_1$const^2 + value^2 * err_1$prop^2),
#'     n = 1, secondary = "m1")[[1]]
#' })
#'
#' \dontrun{
#' f_mmkin <- mmkin(list("DFOP-SFO" = DFOP_SFO), ds_biphasic, error_model = "tc", quiet = TRUE)
#'
#' f_mixed <- mixed(f_mmkin)
#' print(f_mixed)
#' plot(f_mixed)
#' }
#' @export
mixed <- function(object, ...) {
  UseMethod("mixed")
}

#' @export
#' @rdname mixed
mixed.mmkin <- function(object, method = c("none"), ...) {
  if (nrow(object) > 1) stop("Only row objects allowed")

  method <- match.arg(method)

  ds_names <- colnames(object)
  res <- list(mmkin = object, mkinmod = object[[1]]$mkinmod)

  if (method[1] == "none") {
    ds_list <- lapply(object,
      function(x) x$data[c("variable", "time", "observed", "predicted", "residual")])

    names(ds_list) <- ds_names
    res$data <- vctrs::vec_rbind(!!!ds_list, .names_to = "ds")
    names(res$data)[1:4] <- c("ds", "name", "time", "value")
    res$data$name <- as.character(res$data$name)
    res$data$ds <- ordered(res$data$ds, levels = unique(res$data$ds))
    standardized <- unlist(lapply(object, residuals, standardized = TRUE))
    res$data$std <- res$data$residual / standardized
    res$data$standardized <- standardized

    class(res) <- c("mixed.mmkin")
    return(res)
  }
}

#' @export
#' @rdname mixed
#' @param x A mixed.mmkin object to print
#' @param digits Number of digits to use for printing.
print.mixed.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) {
  cat("Kinetic model fitted by nonlinear regression to each dataset" )
  cat("\nStructural model:\n")
  diffs <- x$mmkin[[1]]$mkinmod$diffs
  nice_diffs <- gsub("^(d.*) =", "\\1/dt =", diffs)
  writeLines(strwrap(nice_diffs, exdent = 11))
  cat("\nData:\n")
  cat(nrow(x$data), "observations of",
    length(unique(x$data$name)), "variable(s) grouped in",
    length(unique(x$data$ds)), "datasets\n\n")

  print(x$mmkin, digits = digits)

  cat("\nMean fitted parameters:\n")
  print(mean_degparms(x$mmkin), digits = digits)

  invisible(x)
}

#' Extract model parameters
#'
#' This function returns degradation model parameters as well as error
#' model parameters per default, in order to avoid working with a fitted model
#' without considering the error structure that was assumed for the fit.
#'
#' @param object A fitted model object.
#' @param \dots Not used
#' @return Depending on the object, a numeric vector of fitted model parameters,
#' a matrix (e.g. for mmkin row objects), or a list of matrices (e.g. for
#' mmkin objects with more than one row).
#' @seealso [saem], [multistart]
#' @examples
#' # mkinfit objects
#' fit <- mkinfit("SFO", FOCUS_2006_C, quiet = TRUE)
#' parms(fit)
#' parms(fit, transformed = TRUE)
#'
#' # mmkin objects
#' ds <- lapply(experimental_data_for_UBA_2019[6:10],
#'  function(x) subset(x$data[c("name", "time", "value")]))
#' names(ds) <- paste("Dataset", 6:10)
#' \dontrun{
#' fits <- mmkin(c("SFO", "FOMC", "DFOP"), ds, quiet = TRUE, cores = 1)
#' parms(fits["SFO", ])
#' parms(fits[, 2])
#' parms(fits)
#' parms(fits, transformed = TRUE)
#' }
#' @export
parms <- function(object, ...)
{
  UseMethod("parms", object)
}

#' @param transformed Should the parameters be returned as used internally
#' during the optimisation?
#' @param errparms Should the error model parameters be returned
#' in addition to the degradation parameters?
#' @rdname parms
#' @export
parms.mkinfit <- function(object, transformed = FALSE, errparms = TRUE, ...)
{
  res <- if (transformed) object$par
    else c(object$bparms.optim, object$errparms)
  if (!errparms) {
    res[setdiff(names(res), names(object$errparms))]
  }
  else return(res)
}

#' @rdname parms
#' @export
parms.mmkin <- function(object, transformed = FALSE, errparms = TRUE, ...)
{
  if (nrow(object) == 1) {
    res <- sapply(object, parms, transformed = transformed,
      errparms = errparms, ...)
    colnames(res) <- colnames(object)
  } else {
    res <- list()
    for (i in 1:nrow(object)) {
      res[[i]] <- parms(object[i, ], transformed = transformed,
        errparms = errparms, ...)
    }
    names(res) <- rownames(object)
  }
  return(res)
}

#' @param exclude_failed For [multistart] objects, should rows for failed fits
#' be removed from the returned parameter matrix?
#' @rdname parms
#' @export
parms.multistart <- function(object, exclude_failed = TRUE, ...) {
  res <- t(sapply(object, parms))
  successful <- which(!is.na(res[, 1]))
  first_success <- successful[1]
  colnames(res) <- names(parms(object[[first_success]]))
  if (exclude_failed[1]) res <- res[successful, ]
  return(res)
}

#' Fit one or more kinetic models with one or more state variables to one or
#' more datasets
#'
#' This function calls \code{\link{mkinfit}} on all combinations of models and
#' datasets specified in its first two arguments.
#'
#' @param models Either a character vector of shorthand names like
#'   \code{c("SFO", "FOMC", "DFOP", "HS", "SFORB")}, or an optionally named
#'   list of \code{\link{mkinmod}} objects.
#' @param datasets An optionally named list of datasets suitable as observed
#'   data for \code{\link{mkinfit}}.
#' @param cores The number of cores to be used for multicore processing. This
#'   is only used when the \code{cluster} argument is \code{NULL}. On Windows
#'   machines, cores > 1 is not supported, you need to use the \code{cluster}
#'   argument to use multiple logical processors. Per default, all cores
#'   detected by [parallel::detectCores()] are used, except on Windows where
#'   the default is 1.
#' @param cluster A cluster as returned by \code{\link{makeCluster}} to be used
#'   for parallel execution.
#' @param \dots Further arguments that will be passed to \code{\link{mkinfit}}.
#' @importFrom parallel mclapply parLapply detectCores
#' @return A two-dimensional \code{\link{array}} of \code{\link{mkinfit}}
#'   objects and/or try-errors that can be indexed using the model names for the
#'   first index (row index) and the dataset names for the second index (column
#'   index).
#' @author Johannes Ranke
#' @seealso \code{\link{[.mmkin}} for subsetting, \code{\link{plot.mmkin}} for
#'   plotting.
#' @keywords optimize
#' @examples
#'
#' \dontrun{
#' m_synth_SFO_lin <- mkinmod(parent = mkinsub("SFO", "M1"),
#'                            M1 = mkinsub("SFO", "M2"),
#'                            M2 = mkinsub("SFO"), use_of_ff = "max")
#'
#' m_synth_FOMC_lin <- mkinmod(parent = mkinsub("FOMC", "M1"),
#'                             M1 = mkinsub("SFO", "M2"),
#'                             M2 = mkinsub("SFO"), use_of_ff = "max")
#'
#' models <- list(SFO_lin = m_synth_SFO_lin, FOMC_lin = m_synth_FOMC_lin)
#' datasets <- lapply(synthetic_data_for_UBA_2014[1:3], function(x) x$data)
#' names(datasets) <- paste("Dataset", 1:3)
#'
#' time_default <- system.time(fits.0 <- mmkin(models, datasets, quiet = TRUE))
#' time_1 <- system.time(fits.4 <- mmkin(models, datasets, cores = 1, quiet = TRUE))
#'
#' time_default
#' time_1
#'
#' endpoints(fits.0[["SFO_lin", 2]])
#'
#' # plot.mkinfit handles rows or columns of mmkin result objects
#' plot(fits.0[1, ])
#' plot(fits.0[1, ], obs_var = c("M1", "M2"))
#' plot(fits.0[, 1])
#' # Use double brackets to extract a single mkinfit object, which will be plotted
#' # by plot.mkinfit and can be plotted using plot_sep
#' plot(fits.0[[1, 1]], sep_obs = TRUE, show_residuals = TRUE, show_errmin = TRUE)
#' plot_sep(fits.0[[1, 1]])
#' # Plotting with mmkin (single brackets, extracting an mmkin object) does not
#' # allow to plot the observed variables separately
#' plot(fits.0[1, 1])
#'
#' # On Windows, we can use multiple cores by making a cluster first
#' cl <- parallel::makePSOCKcluster(12)
#' f <- mmkin(c("SFO", "FOMC", "DFOP"),
#'   list(A = FOCUS_2006_A, B = FOCUS_2006_B, C = FOCUS_2006_C, D = FOCUS_2006_D),
#'   cluster = cl, quiet = TRUE)
#' print(f)
#' # We get false convergence for the FOMC fit to FOCUS_2006_A because this
#' # dataset is really SFO, and the FOMC fit is overparameterised
#' parallel::stopCluster(cl)
#' }
#'
#' @export mmkin
mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets,
  cores = if (Sys.info()["sysname"] == "Windows") 1 else parallel::detectCores(), cluster = NULL, ...)
{
  call <- match.call()
  parent_models_available = c("SFO", "FOMC", "DFOP", "HS", "SFORB", "IORE", "logistic")
  n.m <- length(models)
  n.d <- length(datasets)
  n.fits <- n.m * n.d
  fit_indices <- matrix(1:n.fits, ncol = n.d)

  # Check models and define their names
  if (!all(sapply(models, function(x) inherits(x, "mkinmod")))) {
    if (!all(models %in% parent_models_available)) {
      stop("Please supply models as a list of mkinmod objects or a vector combined of\n  ",
           paste(parent_models_available, collapse = ", "))
    } else {
      names(models) <- models
    }
  } else {
    if (is.null(names(models))) names(models) <- as.character(1:n.m)
  }

  # Check datasets and define their names
  if (is.null(names(datasets))) names(datasets) <- as.character(1:n.d)

  # Define names for fit index
  dimnames(fit_indices) <- list(model = names(models),
                                dataset = names(datasets))


  fit_function <- function(fit_index) {
    w <- which(fit_indices == fit_index, arr.ind = TRUE)
    model_index <- w[1]
    dataset_index <- w[2]
    res <- try(mkinfit(models[[model_index]], datasets[[dataset_index]], ...))
    if (!inherits(res, "try-error")) res$mkinmod$name <- names(models)[model_index]
    return(res)
  }

  fit_time <- system.time({
    if (is.null(cluster)) {
      results <- parallel::mclapply(as.list(1:n.fits), fit_function,
        mc.cores = cores, mc.preschedule = FALSE)
    } else {
      results <- parallel::parLapply(cluster, as.list(1:n.fits), fit_function)
    }
  })

  attributes(results) <- attributes(fit_indices)
  attr(results, "call") <- call
  attr(results, "time") <- fit_time
  class(results) <- "mmkin"
  return(results)
}

#' Subsetting method for mmkin objects
#'
#' @param x An \code{\link{mmkin} object}
#' @param i Row index selecting the fits for specific models
#' @param j Column index selecting the fits to specific datasets
#' @param ... Not used, only there to satisfy the generic method definition
#' @param drop If FALSE, the method always returns an mmkin object, otherwise
#'   either a list of mkinfit objects or a single mkinfit object.
#' @return An object of class \code{\link{mmkin}}.
#' @author Johannes Ranke
#' @rdname Extract.mmkin
#' @examples
#'
#'   # Only use one core, to pass R CMD check --as-cran
#'   fits <- mmkin(c("SFO", "FOMC"), list(B = FOCUS_2006_B, C = FOCUS_2006_C),
#'                 cores = 1, quiet = TRUE)
#'   fits["FOMC", ]
#'   fits[, "B"]
#'   fits["SFO", "B"]
#'
#'   head(
#'     # This extracts an mkinfit object with lots of components
#'     fits[["FOMC", "B"]]
#'   )
#' @export
`[.mmkin` <- function(x, i, j, ..., drop = FALSE) {
  class(x) <- NULL
  x_sub <- x[i, j, drop = drop]
  if (!drop) class(x_sub) <- "mmkin"
  return(x_sub)
}

#' Print method for mmkin objects
#'
#' @param x An [mmkin] object.
#' @param \dots Not used.
#' @rdname mmkin
#' @export
print.mmkin <- function(x, ...) {
  cat("<mmkin> object\n")
  cat("Status of individual fits:\n\n")
  print(status(x))
}

#' @export
update.mmkin <- function(object, ..., evaluate = TRUE)
{
  call <- attr(object, "call")

  update_arguments <- match.call(expand.dots = FALSE)$...

  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
}

#' Produce predictions from a kinetic model using specific parameters
#'
#' This function produces a time series for all the observed variables in a
#' kinetic model as specified by [mkinmod], using a specific set of
#' kinetic parameters and initial values for the state variables.
#'
#' @aliases mkinpredict mkinpredict.mkinmod mkinpredict.mkinfit
#' @param x A kinetic model as produced by [mkinmod], or a kinetic fit as
#' fitted by [mkinfit]. In the latter case, the fitted parameters are used for
#' the prediction.
#' @param odeparms A numeric vector specifying the parameters used in the
#' kinetic model, which is generally defined as a set of ordinary differential
#' equations.
#' @param odeini A numeric vector containing the initial values of the state
#' variables of the model. Note that the state variables can differ from the
#' observed variables, for example in the case of the SFORB model.
#' @param outtimes A numeric vector specifying the time points for which model
#' predictions should be generated.
#' @param solution_type The method that should be used for producing the
#' predictions. This should generally be "analytical" if there is only one
#' observed variable, and usually "deSolve" in the case of several observed
#' variables. The third possibility "eigen" is fast in comparison to uncompiled
#' ODE models, but not applicable to some models, e.g. using FOMC for the
#' parent compound.
#' @param method.ode The solution method passed via [mkinpredict] to [ode]] in
#' case the solution type is "deSolve" and we are not using compiled code.
#' When using compiled code, only lsoda is supported.
#' @param use_compiled If set to \code{FALSE}, no compiled version of the
#' [mkinmod] model is used, even if is present.
#' @param use_symbols If set to \code{TRUE} (default), symbol info present in
#' the [mkinmod] object is used if available for accessing compiled code
#' @param atol Absolute error tolerance, passed to the ode solver.
#' @param rtol Absolute error tolerance, passed to the ode solver.
#' @param maxsteps Maximum number of steps, passed to the ode solver.
#' @param map_output Boolean to specify if the output should list values for
#'   the observed variables (default) or for all state variables (if set to
#'   FALSE). Setting this to FALSE has no effect for analytical solutions,
#'   as these always return mapped output.
#' @param na_stop Should it be an error if [ode] returns NaN values
#' @param \dots Further arguments passed to the ode solver in case such a
#'   solver is used.
#' @return A matrix with the numeric solution in wide format
#' @author Johannes Ranke
#' @examples
#'
#' SFO <- mkinmod(degradinol = mkinsub("SFO"))
#' # Compare solution types
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20,
#'       solution_type = "analytical")
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20,
#'       solution_type = "deSolve")
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20,
#'       solution_type = "deSolve", use_compiled = FALSE)
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20,
#'       solution_type = "eigen")
#'
#' # Compare integration methods to analytical solution
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20,
#'       solution_type = "analytical")[21,]
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20,
#'       method = "lsoda", use_compiled = FALSE)[21,]
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20,
#'       method = "ode45", use_compiled = FALSE)[21,]
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20,
#'       method = "rk4", use_compiled = FALSE)[21,]
#' # rk4 is not as precise here
#'
#' # The number of output times used to make a lot of difference until the
#' # default for atol was adjusted
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100),
#'       seq(0, 20, by = 0.1))[201,]
#' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100),
#'       seq(0, 20, by = 0.01))[2001,]
#'
#' # Comparison of the performance of solution types
#' SFO_SFO = mkinmod(parent = list(type = "SFO", to = "m1"),
#'                   m1 = list(type = "SFO"), use_of_ff = "max")
#' if(require(rbenchmark)) {
#'   benchmark(replications = 10, order = "relative", columns = c("test", "relative", "elapsed"),
#'     eigen = mkinpredict(SFO_SFO,
#'       c(k_parent = 0.15, f_parent_to_m1 = 0.5, k_m1 = 0.01),
#'       c(parent = 100, m1 = 0), seq(0, 20, by = 0.1),
#'       solution_type = "eigen")[201,],
#'     deSolve_compiled = mkinpredict(SFO_SFO,
#'       c(k_parent = 0.15, f_parent_to_m1 = 0.5, k_m1 = 0.01),
#'       c(parent = 100, m1 = 0), seq(0, 20, by = 0.1),
#'       solution_type = "deSolve")[201,],
#'     deSolve = mkinpredict(SFO_SFO,
#'       c(k_parent = 0.15, f_parent_to_m1 = 0.5, k_m1 = 0.01),
#'       c(parent = 100, m1 = 0), seq(0, 20, by = 0.1),
#'       solution_type = "deSolve", use_compiled = FALSE)[201,],
#'     analytical = mkinpredict(SFO_SFO,
#'       c(k_parent = 0.15, f_parent_to_m1 = 0.5, k_m1 = 0.01),
#'       c(parent = 100, m1 = 0), seq(0, 20, by = 0.1),
#'       solution_type = "analytical", use_compiled = FALSE)[201,])
#' }
#'
#' \dontrun{
#'   # Predict from a fitted model
#'   f <- mkinfit(SFO_SFO, FOCUS_2006_C, quiet = TRUE)
#'   f <- mkinfit(SFO_SFO, FOCUS_2006_C, quiet = TRUE, solution_type = "deSolve")
#'   head(mkinpredict(f))
#' }
#'
#' @export
mkinpredict <- function(x, odeparms, odeini, outtimes, ...)
{
  UseMethod("mkinpredict", x)
}

#' @rdname mkinpredict
#' @export
mkinpredict.mkinmod <- function(x,
  odeparms = c(k_parent_sink = 0.1),
  odeini = c(parent = 100),
  outtimes = seq(0, 120, by = 0.1),
  solution_type = "deSolve",
  use_compiled = "auto",
  use_symbols = FALSE,
  method.ode = "lsoda", atol = 1e-8, rtol = 1e-10, maxsteps = 20000L,
  map_output = TRUE,
  na_stop = TRUE,
  ...)
{

  # Names of state variables and observed variables
  mod_vars <- names(x$diffs)
  obs_vars <- names(x$spec)

  # Order the inital values for state variables if they are named
  if (!is.null(names(odeini))) {
    odeini <- odeini[mod_vars]
  }

  out_obs <- matrix(NA, nrow = length(outtimes), ncol = 1 + length(obs_vars),
    dimnames = list(as.character(outtimes), c("time", obs_vars)))
  out_obs[, "time"] <- outtimes

  n_out_na <- 0 # to check if we get NA values with deSolve

  if (solution_type == "analytical") {
    # This is clumsy, as we wanted fast analytical predictions for mkinfit,
    # which bypasses mkinpredict in the case of analytical solutions
    pseudo_observed <-
      data.frame(name = rep(obs_vars, each = length(outtimes)),
      time = rep(outtimes, length(obs_vars)))
    pseudo_observed$predicted <- x$deg_func(pseudo_observed, odeini, odeparms)
    for (obs_var in obs_vars) {
      out_obs[, obs_var] <- pseudo_observed[pseudo_observed$name == obs_var, "predicted"]
    }
    # We don't have solutions for unobserved state variables, the output of
    # analytical solutions is always mapped to observed variables
    return(out_obs)
  }

  if (solution_type == "eigen") {
    evalparse <- function(string) {
      eval(parse(text=string), as.list(c(odeparms, odeini)))
    }

    coefmat.num <- matrix(sapply(as.vector(x$coefmat), evalparse),
      nrow = length(mod_vars))
    e <- eigen(coefmat.num)
    c <- solve(e$vectors, odeini)
    f.out <- function(t) {
      e$vectors %*% diag(exp(e$values * t), nrow=length(mod_vars)) %*% c
    }
    o <- matrix(mapply(f.out, outtimes),
      nrow = length(mod_vars), ncol = length(outtimes))
    out <- cbind(outtimes, t(o))
    colnames(out) <- c("time", mod_vars)
  }

  if (solution_type == "deSolve") {
    if (!is.null(x$cf) & use_compiled[1] != FALSE) {

      if (!is.null(x$symbols) & use_symbols) {
        lsoda_func <- x$symbols
      } else {
        lsoda_func <- "diffs"
      }

      out <- deSolve::lsoda(
        y = odeini,
        times = outtimes,
        func = lsoda_func,
        initfunc = "initpar",
        dllname = x$dll_info[["name"]],
        parms = odeparms[x$parms], # Order matters when using compiled models
        atol = atol,
        rtol = rtol,
        maxsteps = maxsteps,
        ...
      )

      colnames(out) <- c("time", mod_vars)
    } else {
      mkindiff <- function(t, state, parms) {

        time <- t
        diffs <- vector()
        for (box in names(x$diffs))
        {
          diffname <- paste("d", box, sep="_")
          diffs[diffname] <- with(as.list(c(time, state, parms)),
            eval(parse(text=x$diffs[[box]])))
        }
        return(list(c(diffs)))
      }
      out <- deSolve::ode(
        y = odeini,
        times = outtimes,
        func = mkindiff,
        parms = odeparms,
        method = method.ode,
        atol = atol,
        rtol = rtol,
        maxsteps = maxsteps,
        ...
      )
    }
    n_out_na <- sum(is.na(out))
    if (n_out_na > 0 & na_stop) {
      cat("odeini:\n")
      print(odeini)
      cat("odeparms:\n")
      print(odeparms)
      cat("out:\n")
      print(out)
      stop("Differential equations were not integrated for all output times because\n",
        n_out_na, " NaN values occurred in output from ode()")
    }
  }

  if (map_output) {
    # Output transformation for models with unobserved compartments like SFORB
    # if not already mapped in analytical solution
    if (n_out_na > 0 & !na_stop) {
      available <- c(TRUE, rep(FALSE, length(outtimes) - 1))
    } else {
      available <- rep(TRUE, length(outtimes))
    }
    for (var in names(x$map)) {
      if((length(x$map[[var]]) == 1)) {
        out_obs[available, var] <- out[available, var]
      } else {
        out_obs[available, var] <- out[available, x$map[[var]][1]] +
          out[available, x$map[[var]][2]]
      }
    }
    return(out_obs)
  } else {
    dimnames(out) <- list(time = as.character(outtimes), c("time", mod_vars))
    return(out)
  }
}

#' @rdname mkinpredict
#' @export
mkinpredict.mkinfit <- function(x,
  odeparms = x$bparms.ode,
  odeini = x$bparms.state,
  outtimes = seq(0, 120, by = 0.1),
  solution_type = "deSolve",
  use_compiled = "auto",
  method.ode = "lsoda", atol = 1e-8, rtol = 1e-10,
  map_output = TRUE, ...)
{
  mkinpredict(x$mkinmod, odeparms, odeini, outtimes, solution_type, use_compiled,
              method.ode, atol, rtol, map_output, ...)
}

#' Anova method for saem.mmkin objects
#'
#' Generate an anova object. The method to calculate the BIC is that from the
#' saemix package. As in other prominent anova methods, models are sorted by
#' number of parameters, and the tests (if requested) are always relative to
#' the model on the previous line.
#'
#' @param object An [saem.mmkin] object
#' @param ...   further such objects
#' @param method Method for likelihood calculation: "is" (importance sampling),
#' "lin" (linear approximation), or "gq" (Gaussian quadrature). Passed
#' to [saemix::logLik.SaemixObject]
#' @param test Should a likelihood ratio test be performed? If TRUE,
#' the alternative models are tested against the first model. Should
#' only be done for nested models.
#' @param model.names Optional character vector of model names
#' @importFrom stats anova logLik update pchisq terms
#' @importFrom methods is
#' @importFrom utils capture.output
#' @export
#' @return an "anova" data frame; the traditional (S3) result of anova()
anova.saem.mmkin <- function(object, ...,
  method = c("is", "lin", "gq"), test = FALSE, model.names = NULL)
{
  # The following code is heavily inspired by anova.lmer in the lme4 package
  mCall <- match.call(expand.dots = TRUE)
  dots <- list(...)
  method <- match.arg(method)

  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"))

    if (is.null(model.names))
        model.names <- vapply(as.list(mCall)[c(FALSE, TRUE, is_model)], deparse1, "")

    # Sanitize model names
    if (length(model.names) != length(mods))
      stop("Model names vector and model list have different lengths")

    if (any(duplicated(model.names)))
      stop("Duplicate model names are not allowed")

    if (max(nchar(model.names)) > 200) {
      warning("Model names longer than 200 characters, assigning generic names")
      model.names <- paste0("MODEL",seq_along(model.names))
    }
    names(mods) <- model.names
    mods <- mods[successful]

    # Ensure same data, ignoring covariates
    same_data <- sapply(mods[-1], function(x) {
      identical(mods[[1]]$data[c("ds", "name", "time", "value")],
        x$data[c("ds", "name", "time", "value")])
    })
    if (!all(same_data)) {
      stop(sum(!same_data), " objects have not been fitted to the same data")
    }

    llks <- lapply(names(mods), function(x) {
      llk <- try(logLik(mods[[x]], method = method), silent = TRUE)
      if (inherits(llk, "try-error")) {
        warning("Could not obtain log likelihood with '", method, "' method for ", x)
        llk <- NA
      }
      return(llk)
    })
    available <- !sapply(llks, is.na)
    llks <- llks[available]
    mods <- mods[available]

    # Order models by increasing degrees of freedom:
    npar <- vapply(llks, attr, FUN.VALUE=numeric(1), "df")
    ii <- order(npar)
    mods <- mods[ii]
    llks <- llks[ii]
    npar   <- npar[ii]

    # Describe data for the header, as in summary.saem.mmkin
    header <- paste("Data:", nrow(object$data), "observations of",
      length(unique(object$data$name)), "variable(s) grouped in",
      length(unique(object$data$ds)), "datasets\n")

    # Calculate statistics
    llk <- unlist(llks)
    chisq <- 2 * pmax(0, c(NA, diff(llk)))
    dfChisq <- c(NA, diff(npar))

    bic <- function(x, method) {
      BIC(x$so, method = method)
    }
    val <- data.frame(
      npar = npar,
      AIC = sapply(llks, AIC),
      BIC = sapply(mods, bic, method = method), # We use the saemix method here
      Lik = llk,
      row.names = names(mods), check.names = FALSE)

    if (test) {
      testval <- data.frame(
        Chisq = chisq,
        Df = dfChisq,
        "Pr(>Chisq)" = ifelse(dfChisq == 0, NA,
          pchisq(chisq, dfChisq, lower.tail = FALSE)),
        row.names = names(mods), check.names = FALSE)
      val <- cbind(val, testval)
    }
    class(val) <- c("anova", class(val))
    structure(val, heading = c(header))
  } else {
    stop("Currently, no anova method is implemented for the case of a single saem.mmkin object")
  }
}

#' Create degradation functions for known analytical solutions
#'
#' @param spec List of model specifications as contained in mkinmod objects
#' @param use_of_ff Minimum or maximum use of formation fractions
#' @return Degradation function to be attached to mkinmod objects
#' @examples
#'
#' SFO_SFO <- mkinmod(
#'   parent = mkinsub("SFO", "m1"),
#'   m1 = mkinsub("SFO"))
#' FOCUS_D <- subset(FOCUS_2006_D, value != 0) # to avoid warnings
#' fit_1 <- mkinfit(SFO_SFO, FOCUS_D, solution_type = "analytical", quiet = TRUE)
#' \dontrun{
#' fit_2 <- mkinfit(SFO_SFO, FOCUS_D, solution_type = "deSolve", quiet = TRUE)
#' if (require(rbenchmark))
#'   benchmark(
#'     analytical = mkinfit(SFO_SFO, FOCUS_D, solution_type = "analytical", quiet = TRUE),
#'     deSolve = mkinfit(SFO_SFO, FOCUS_D, solution_type = "deSolve", quiet = TRUE),
#'     replications = 2)
#'   DFOP_SFO <- mkinmod(
#'     parent = mkinsub("DFOP", "m1"),
#'     m1 = mkinsub("SFO"))
#'   benchmark(
#'     analytical = mkinfit(DFOP_SFO, FOCUS_D, solution_type = "analytical", quiet = TRUE),
#'     deSolve = mkinfit(DFOP_SFO, FOCUS_D, solution_type = "deSolve", quiet = TRUE),
#'     replications = 2)
#' }
#' @export
create_deg_func <- function(spec, use_of_ff = c("min", "max")) {

  use_of_ff <- match.arg(use_of_ff)
  min_ff <- use_of_ff == "min"
  obs_vars <- names(spec)

  parent <- obs_vars[1]
  parent_type <- spec[[1]]$type

  supported <- TRUE # This may be modified below

  predicted_text <- character(0)

  if (parent_type == "SFO") {
    if (min_ff) {
      targets <- c(spec[[1]]$to, if (spec[[1]]$sink) "sink" else NULL)
      k_parent <- paste(paste0("k_", parent, "_", targets), collapse = " + ")
    } else {
      k_parent <- paste0("k_", parent)
    }
  }

  predicted_text[parent] <- paste0(parent_type, ".solution(t, odeini['", parent,
    if (parent_type == "SFORB") "_free", "'], ",
    switch(parent_type,
      SFO = k_parent,
      FOMC = "alpha, beta",
      IORE = paste0("k__iore_", parent, if (min_ff) "_sink" else "", ", N_", parent),
      DFOP = "k1, k2, g",
      SFORB = paste0("k_", parent, "_free_bound, k_", parent, "_bound_free, k_", parent, "_free", if (min_ff) "_sink" else ""),
      HS = "k1, k2, tb",
      logistic = "kmax, k0, r"
    ),
  ")")

  if (length(obs_vars) >= 2) supported <- FALSE
  # Except for the following cases:

  if (length(obs_vars) == 2) {
    n1 <- obs_vars[1]
    n2 <- obs_vars[2]
    n10 <- paste0("odeini['", parent, "']")
    n20 <- paste0("odeini['", n2, "']")

    # sfo_sfo
    if (all(
        spec[[1]]$sink == FALSE,
        spec[[1]]$type == "SFO",
        spec[[2]]$type == "SFO",
        is.null(spec[[2]]$to))) {
      supported <- TRUE
      k1 <- k_parent
      k2 <- paste0("k_", n2, if(min_ff) "_sink" else "")
      predicted_text[n2] <- paste0(
        "(((", k2, "-", k1, ")*", n20, "-", k1, "*", n10, ")*exp(-", k2, "*t)+",
        k1, "*", n10, "*exp(-", k1, "*t))/(", k2, "-", k1, ")")
    }

    # sfo_f12_sfo
    if (all(
        use_of_ff == "max",
        spec[[1]]$sink == TRUE,
        spec[[1]]$type == "SFO",
        spec[[2]]$type == "SFO",
        is.null(spec[[2]]$to))) {
      supported <- TRUE
      k1 <- k_parent
      k2 <- paste0("k_", n2)
      f12 <- paste0("f_", n1, "_to_", n2)
      predicted_text[n2] <- paste0(
        "(((", k2, "-", k1, ")*", n20, "-", f12, "*", k1, "*", n10, ")*exp(-", k2, "*t)+",
        f12, "*", k1, "*", n10, "*exp(-", k1, "*t))/(", k2, "-", k1, ")")
    }

    # sfo_k120_sfo
    if (all(
        use_of_ff == "min",
        spec[[1]]$sink == TRUE,
        spec[[1]]$type == "SFO",
        spec[[2]]$type == "SFO",
        is.null(spec[[2]]$to))) {
      supported <- TRUE
      k12 <- paste0("k_", n1, "_", n2)
      k10 <- paste0("k_", n1, "_sink")
      k2 <- paste0("k_", n2, "_sink")
      predicted_text[n2] <- paste0(
        "(((", k2, "-", k12, "-", k10, ")*", n20, "-", k12, "*", n10, ")*exp(-", k2, "*t)+",
        k12, "*", n10, "*exp(-(", k_parent, ")*t))/(", k2, "-(", k_parent, "))")
    }

    # dfop_f12_sfo
    if (all(
        use_of_ff == "max",
        spec[[1]]$sink == TRUE,
        spec[[1]]$type == "DFOP",
        spec[[2]]$type == "SFO",
        is.null(spec[[2]]$to))) {
      supported <- TRUE
      f12 <- paste0("f_", n1, "_to_", n2)
      k2 <- paste0("k_", n2)
      predicted_text[n2] <- paste0(
        "((", f12, "* g - ", f12, ") * k2 * ", n10, " * exp(- k2 * t))/(k2 - ", k2, ") - ",
        "((", f12, "* g) * k1 * ", n10, " * exp(- k1 * t))/(k1 - ", k2, ") + ",
        "(((k1 - ", k2, ") * k2 - ", k2, "* k1 + ", k2, "^2) * ", n20, "+",
        "((", f12, "* k1 + (", f12, "*g - ", f12, ") * ", k2, ") * k2 - ", f12, " * g * ", k2, " * k1) * ", n10, ") * ",
        "exp( - ", k2, " * t)/((k1 - ", k2, ") * k2 - ", k2, " * k1 + ", k2, "^2)")
    }

  }

  if (supported) {
    deg_func <- function(observed, odeini, odeparms) {}

    f_body <- paste0("{\n",
      "predicted <- numeric(0)\n",
      "with(as.list(odeparms), {\n")
    for (obs_var in obs_vars) {
      f_body <- paste0(f_body,
      "t <- observed[observed$name == '", obs_var, "', 'time']\n",
      "predicted <<- c(predicted, ", predicted_text[obs_var], ")\n")
    }
    f_body <- paste0(f_body,
      "})\n",
      "return(predicted)\n}\n")

    body(deg_func) <- parse(text = f_body)
    return(deg_func)
  } else {
    return(NULL)
  }
}

#' Helper functions to create nlme models from mmkin row objects
#'
#' These functions facilitate setting up a nonlinear mixed effects model for
#' an mmkin row object. An mmkin row object is essentially a list of mkinfit
#' objects that have been obtained by fitting the same model to a list of
#' datasets. They are used internally by the [nlme.mmkin()] method.
#'
#' @param object An mmkin row object containing several fits of the same model to different datasets
#' @import nlme
#' @rdname nlme
#' @seealso \code{\link{nlme.mmkin}}
#' @examples
#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120)
#' m_SFO <- mkinmod(parent = mkinsub("SFO"))
#' d_SFO_1 <- mkinpredict(m_SFO,
#'   c(k_parent = 0.1),
#'   c(parent = 98), sampling_times)
#' d_SFO_1_long <- mkin_wide_to_long(d_SFO_1, time = "time")
#' d_SFO_2 <- mkinpredict(m_SFO,
#'   c(k_parent = 0.05),
#'   c(parent = 102), sampling_times)
#' d_SFO_2_long <- mkin_wide_to_long(d_SFO_2, time = "time")
#' d_SFO_3 <- mkinpredict(m_SFO,
#'   c(k_parent = 0.02),
#'   c(parent = 103), sampling_times)
#' d_SFO_3_long <- mkin_wide_to_long(d_SFO_3, time = "time")
#'
#' d1 <- add_err(d_SFO_1, function(value) 3, n = 1)
#' d2 <- add_err(d_SFO_2, function(value) 2, n = 1)
#' d3 <- add_err(d_SFO_3, function(value) 4, n = 1)
#' ds <- c(d1 = d1, d2 = d2, d3 = d3)
#'
#' f <- mmkin("SFO", ds, cores = 1, quiet = TRUE)
#' mean_dp <- mean_degparms(f)
#' grouped_data <- nlme_data(f)
#' nlme_f <- nlme_function(f)
#' # These assignments are necessary for these objects to be
#' # visible to nlme and augPred when evaluation is done by
#' # pkgdown to generate the html docs.
#' assign("nlme_f", nlme_f, globalenv())
#' assign("grouped_data", grouped_data, globalenv())
#'
#' library(nlme)
#' m_nlme <- nlme(value ~ nlme_f(name, time, parent_0, log_k_parent_sink),
#'   data = grouped_data,
#'   fixed = parent_0 + log_k_parent_sink ~ 1,
#'   random = pdDiag(parent_0 + log_k_parent_sink ~ 1),
#'   start = mean_dp)
#' summary(m_nlme)
#' plot(augPred(m_nlme, level = 0:1), layout = c(3, 1))
#' # augPred does not work on fits with more than one state
#' # variable
#' #
#' # The procedure is greatly simplified by the nlme.mmkin function
#' f_nlme <- nlme(f)
#' plot(f_nlme)
#' @return A function that can be used with nlme
#' @export
nlme_function <- function(object) {
  if (nrow(object) > 1) stop("Only row objects allowed")

  mkin_model <- object[[1]]$mkinmod

  degparm_names <- names(mean_degparms(object))

  # Inspired by https://stackoverflow.com/a/12983961/3805440
  # and https://stackoverflow.com/a/26280789/3805440
  model_function_alist <- replicate(length(degparm_names) + 2, substitute())
  names(model_function_alist) <- c("name", "time", degparm_names)

  model_function_body <- quote({
    arg_frame <- as.data.frame(as.list((environment())), stringsAsFactors = FALSE)
    res_frame <- arg_frame[1:2]
    parm_frame <- arg_frame[-(1:2)]
    parms_unique <- unique(parm_frame)

    n_unique <- nrow(parms_unique)

    times_ds <- list()
    names_ds <- list()
    for (i in 1:n_unique) {
      times_ds[[i]] <-
        arg_frame[which(arg_frame[[3]] == parms_unique[i, 1]), "time"]
      names_ds[[i]] <-
        arg_frame[which(arg_frame[[3]] == parms_unique[i, 1]), "name"]
    }

    res_list <- lapply(1:n_unique, function(x) {
      transparms_optim <- unlist(parms_unique[x, , drop = TRUE])
      parms_fixed <- object[[1]]$bparms.fixed

      odeini_optim_parm_names <- grep('_0$', names(transparms_optim), value = TRUE)
      odeini_optim <- transparms_optim[odeini_optim_parm_names]
      names(odeini_optim) <- gsub('_0$', '', odeini_optim_parm_names)
      odeini_fixed_parm_names <- grep('_0$', names(parms_fixed), value = TRUE)
      odeini_fixed <- parms_fixed[odeini_fixed_parm_names]
      names(odeini_fixed) <- gsub('_0$', '', odeini_fixed_parm_names)
      odeini <- c(odeini_optim, odeini_fixed)[names(mkin_model$diffs)]

      ode_transparms_optim_names <- setdiff(names(transparms_optim), odeini_optim_parm_names)
      odeparms_optim <- backtransform_odeparms(transparms_optim[ode_transparms_optim_names], mkin_model,
        transform_rates = object[[1]]$transform_rates,
        transform_fractions = object[[1]]$transform_fractions)
      odeparms_fixed_names <- setdiff(names(parms_fixed), odeini_fixed_parm_names)
      odeparms_fixed <- parms_fixed[odeparms_fixed_names]
      odeparms <- c(odeparms_optim, odeparms_fixed)

      out_wide <- mkinpredict(mkin_model,
        odeparms = odeparms, odeini = odeini,
        solution_type = object[[1]]$solution_type,
        outtimes = sort(unique(times_ds[[x]])))
      out_array <- out_wide[, -1, drop = FALSE]
      rownames(out_array) <- as.character(unique(times_ds[[x]]))
      out_times <- as.character(times_ds[[x]])
      out_names <- as.character(names_ds[[x]])
      out_values <- mapply(function(times, names) out_array[times, names],
        out_times, out_names)
      return(as.numeric(out_values))
    })
    res <- unlist(res_list)
    return(res)
  })
  model_function <- as.function(c(model_function_alist, model_function_body))
  return(model_function)
}

#' @rdname nlme
#' @importFrom rlang !!!
#' @return A \code{\link{groupedData}} object
#' @export
nlme_data <- function(object) {
  if (nrow(object) > 1) stop("Only row objects allowed")
  ds_names <- colnames(object)

  ds_list <- lapply(object, function(x) x$data[c("time", "variable", "observed")])
  names(ds_list) <- ds_names
  ds_nlme <- vctrs::vec_rbind(!!!ds_list, .names_to = "ds")
  ds_nlme$variable <- as.character(ds_nlme$variable)
  ds_nlme$ds <- ordered(ds_nlme$ds, levels = unique(ds_nlme$ds))
  ds_nlme_renamed <- data.frame(ds = ds_nlme$ds, name = ds_nlme$variable,
    time = ds_nlme$time, value = ds_nlme$observed,
    stringsAsFactors = FALSE)
  ds_nlme_grouped <- groupedData(value ~ time | ds, ds_nlme_renamed, order.groups = FALSE)
  return(ds_nlme_grouped)
}

#' Functions to transform and backtransform kinetic parameters for fitting
#'
#' The transformations are intended to map parameters that should only take on
#' restricted values to the full scale of real numbers. For kinetic rate
#' constants and other parameters that can only take on positive values, a
#' simple log transformation is used. For compositional parameters, such as the
#' formations fractions that should always sum up to 1 and can not be negative,
#' the [ilr] transformation is used.
#'
#' The transformation of sets of formation fractions is fragile, as it supposes
#' the same ordering of the components in forward and backward transformation.
#' This is no problem for the internal use in [mkinfit].
#'
#' @param parms Parameters of kinetic models as used in the differential
#'   equations.
#' @param transparms Transformed parameters of kinetic models as used in the
#'   fitting procedure.
#' @param mkinmod The kinetic model of class [mkinmod], containing
#'   the names of the model variables that are needed for grouping the
#'   formation fractions before [ilr] transformation, the parameter
#'   names and the information if the pathway to sink is included in the model.
#' @param transform_rates Boolean specifying if kinetic rate constants should
#'   be transformed in the model specification used in the fitting for better
#'   compliance with the assumption of normal distribution of the estimator. If
#'   TRUE, also alpha and beta parameters of the FOMC model are
#'   log-transformed, as well as k1 and k2 rate constants for the DFOP and HS
#'   models and the break point tb of the HS model.
#' @param transform_fractions Boolean specifying if formation fractions
#'   constants should be transformed in the model specification used in the
#'   fitting for better compliance with the assumption of normal distribution
#'   of the estimator. The default (TRUE) is to do transformations.
#'   The g parameter of the DFOP model is also seen as a fraction.
#'   If a single fraction is transformed (g parameter of DFOP or only a single
#'   target variable e.g. a single metabolite plus a pathway to sink), a
#'   logistic transformation is used [stats::qlogis()]. In other cases, i.e. if
#'   two or more formation fractions need to be transformed whose sum cannot
#'   exceed one, the [ilr] transformation is used.
#' @return A vector of transformed or backtransformed parameters
#' @importFrom stats plogis qlogis
#' @author Johannes Ranke
#' @examples
#'
#' SFO_SFO <- mkinmod(
#'   parent = list(type = "SFO", to = "m1", sink = TRUE),
#'   m1 = list(type = "SFO"), use_of_ff = "min")
#'
#' # Fit the model to the FOCUS example dataset D using defaults
#' FOCUS_D <- subset(FOCUS_2006_D, value != 0) # remove zero values to avoid warning
#' fit <- mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE)
#' fit.s <- summary(fit)
#' # Transformed and backtransformed parameters
#' print(fit.s$par, 3)
#' print(fit.s$bpar, 3)
#'
#' \dontrun{
#' # Compare to the version without transforming rate parameters (does not work
#' # with analytical solution, we get NA values for m1 in predictions)
#' fit.2 <- mkinfit(SFO_SFO, FOCUS_D, transform_rates = FALSE,
#'   solution_type = "deSolve", quiet = TRUE)
#' fit.2.s <- summary(fit.2)
#' print(fit.2.s$par, 3)
#' print(fit.2.s$bpar, 3)
#' }
#'
#' initials <- fit$start$value
#' names(initials) <- rownames(fit$start)
#' transformed <- fit$start_transformed$value
#' names(transformed) <- rownames(fit$start_transformed)
#' transform_odeparms(initials, SFO_SFO)
#' backtransform_odeparms(transformed, SFO_SFO)
#'
#' \dontrun{
#' # The case of formation fractions (this is now the default)
#' SFO_SFO.ff <- mkinmod(
#'   parent = list(type = "SFO", to = "m1", sink = TRUE),
#'   m1 = list(type = "SFO"),
#'   use_of_ff = "max")
#'
#' fit.ff <- mkinfit(SFO_SFO.ff, FOCUS_D, quiet = TRUE)
#' fit.ff.s <- summary(fit.ff)
#' print(fit.ff.s$par, 3)
#' print(fit.ff.s$bpar, 3)
#' initials <- c("f_parent_to_m1" = 0.5)
#' transformed <- transform_odeparms(initials, SFO_SFO.ff)
#' backtransform_odeparms(transformed, SFO_SFO.ff)
#'
#' # And without sink
#' SFO_SFO.ff.2 <- mkinmod(
#'   parent = list(type = "SFO", to = "m1", sink = FALSE),
#'   m1 = list(type = "SFO"),
#'   use_of_ff = "max")
#'
#'
#' fit.ff.2 <- mkinfit(SFO_SFO.ff.2, FOCUS_D, quiet = TRUE)
#' fit.ff.2.s <- summary(fit.ff.2)
#' print(fit.ff.2.s$par, 3)
#' print(fit.ff.2.s$bpar, 3)
#' }
#'
#' @export transform_odeparms
transform_odeparms <- function(parms, mkinmod,
  transform_rates = TRUE, transform_fractions = TRUE)
{
  # We need the model specification for the names of the model
  # variables and the information on the sink
  spec = mkinmod$spec

  # Set up container for transformed parameters
  transparms <- numeric(0)

  # Do not transform initial values for state variables
  state.ini.optim <- parms[grep("_0$", names(parms))]
  transparms[names(state.ini.optim)] <- state.ini.optim

  # Log transformation for rate constants if requested
  k <- parms[grep("^k_", names(parms))]
  k__iore <- parms[grep("^k__iore_", names(parms))]
  k <- c(k, k__iore)
  if (length(k) > 0) {
    if(transform_rates) {
      transparms[paste0("log_", names(k))] <- log(k)
    } else transparms[names(k)] <- k
  }

  # Do not transform exponents in IORE models
  N <- parms[grep("^N", names(parms))]
  transparms[names(N)] <- N

  # Go through state variables and transform formation fractions if requested
  mod_vars = names(spec)
  for (box in mod_vars) {
    f <- parms[grep(paste("^f", box, sep = "_"), names(parms))]

    if (length(f) > 0) {
      if(transform_fractions) {
        if (spec[[box]]$sink) {
          if (length(f) == 1) {
            trans_f_name <- paste("f", box, "qlogis", sep = "_")
            transparms[trans_f_name] <- qlogis(f)
          } else {
            trans_f <- ilr(c(f, 1 - sum(f)))
            trans_f_names <- paste("f", box, "ilr", 1:length(trans_f), sep = "_")
            transparms[trans_f_names] <- trans_f
          }
        } else {
          if (length(f) > 1) {
            trans_f <- ilr(f)
            trans_f_names <- paste("f", box, "ilr", 1:length(trans_f), sep = "_")
            transparms[trans_f_names] <- trans_f
          }
        }
      } else {
        transparms[names(f)] <- f
      }
    }
  }

  # Transform also FOMC parameters alpha and beta, DFOP and HS rates k1 and k2
  # and HS parameter tb as well as logistic model parameters kmax, k0 and r if
  # transformation of rates is requested
  for (pname in c("alpha", "beta", "k1", "k2", "tb", "kmax", "k0", "r")) {
    if (!is.na(parms[pname])) {
      if (transform_rates) {
        transparms[paste0("log_", pname)] <- log(parms[pname])
      } else {
        transparms[pname] <- parms[pname]
      }
    }
  }

  # DFOP parameter g is treated as a fraction
  if (!is.na(parms["g"])) {
    g <- parms["g"]
    if (transform_fractions) {
      transparms["g_qlogis"] <- qlogis(g)
    } else {
      transparms["g"] <- g
    }
  }

  return(transparms)
}

#' @rdname transform_odeparms
#' @export backtransform_odeparms
backtransform_odeparms <- function(transparms, mkinmod,
                                   transform_rates = TRUE,
                                   transform_fractions = TRUE)
{
  # We need the model specification for the names of the model
  # variables and the information on the sink
  spec = mkinmod$spec

  # Set up container for backtransformed parameters
  parms <- numeric(0)

  # Do not transform initial values for state variables
  state.ini.optim <- transparms[grep("_0$", names(transparms))]
  parms[names(state.ini.optim)] <- state.ini.optim

  # Exponential transformation for rate constants
  if(transform_rates) {
    trans_k <- transparms[grep("^log_k_", names(transparms))]
    trans_k__iore <- transparms[grep("^log_k__iore_", names(transparms))]
    trans_k = c(trans_k, trans_k__iore)
    if (length(trans_k) > 0) {
      k_names <- gsub("^log_k", "k", names(trans_k))
      parms[k_names] <- exp(trans_k)
    }
  } else {
    trans_k <- transparms[grep("^k_", names(transparms))]
    parms[names(trans_k)] <- trans_k
    trans_k__iore <- transparms[grep("^k__iore_", names(transparms))]
    parms[names(trans_k__iore)] <- trans_k__iore
  }

  # Do not transform exponents in IORE models
  N <- transparms[grep("^N", names(transparms))]
  parms[names(N)] <- N

  # Go through state variables and apply inverse transformations to formation fractions
  mod_vars = names(spec)
  for (box in mod_vars) {
    # Get the names as used in the model
    f_names = grep(paste("^f", box, sep = "_"), mkinmod$parms, value = TRUE)

    # Get the formation fraction parameters
    trans_f = transparms[grep(paste("^f", box, sep = "_"), names(transparms))]
    if (length(trans_f) > 0) {
      if(transform_fractions) {
        if (any(grepl("qlogis", names(trans_f)))) {
          f_tmp  <- plogis(trans_f)
          parms[f_names] <- f_tmp
        } else {
          f_tmp <- invilr(trans_f)
          if (spec[[box]]$sink) {
            parms[f_names] <- f_tmp[1:length(f_tmp)-1]
          } else {
            parms[f_names] <- f_tmp
          }
        }
      } else {
        parms[names(trans_f)] <- trans_f
      }
    }
  }

  # Transform parameters also for FOMC, DFOP, HS and logistic models
  for (pname in c("alpha", "beta", "k1", "k2", "tb", "kmax", "k0", "r")) {
    if (transform_rates) {
      pname_trans = paste0("log_", pname)
      if (!is.na(transparms[pname_trans])) {
        parms[pname] <- exp(transparms[pname_trans])
      }
    } else {
      if (!is.na(transparms[pname])) {
        parms[pname] <- transparms[pname]
      }
    }
  }

  # DFOP parameter g is now transformed using qlogis
  if (!is.na(transparms["g_qlogis"])) {
    g_qlogis <- transparms["g_qlogis"]
    parms["g"] <- plogis(g_qlogis)
  }
  # In earlier times we used ilr for g, so we keep this around
  if (!is.na(transparms["g_ilr"])) {
    g_ilr <- transparms["g_ilr"]
    parms["g"] <- invilr(g_ilr)[1]
  }
  if (!is.na(transparms["g"])) {
    parms["g"] <- transparms["g"]
  }

  return(parms)
}
# vim: set ts=2 sw=2 expandtab:

#' Hierarchical kinetics template
#'
#' R markdown format for setting up hierarchical kinetics based on a template
#' provided with the mkin package. This format is based on [rmarkdown::pdf_document].
#' Chunk options are adapted. Echoing R code from code chunks and caching are
#' turned on per default. character for prepending output from code chunks is
#' set to the empty string, code tidying is off, figure alignment defaults to
#' centering, and positioning of figures is set to "H", which means that
#' figures will not move around in the document, but stay where the user
#' includes them.
#'
#' The latter feature (positioning the figures with "H") depends on the LaTeX
#' package 'float'. In addition, the LaTeX package 'listing' is used in the
#' template for showing model fit summaries in the Appendix. This means that
#' the LaTeX packages 'float' and 'listing' need to be installed in the TeX
#' distribution used.
#'
#' On Windows, the easiest way to achieve this (if no TeX distribution
#' is present before) is to install the 'tinytex' R package, to run
#' 'tinytex::install_tinytex()' to get the basic tiny Tex distribution,
#' and then to run 'tinytex::tlmgr_install(c("float", "listing"))'.
#'
#' @inheritParams rmarkdown::pdf_document
#' @param ... Arguments to \code{rmarkdown::pdf_document}
#'
#' @return R Markdown output format to pass to
#'   \code{\link[rmarkdown:render]{render}}
#'
#' @examples
#'
#' \dontrun{
#' library(rmarkdown)
#' # The following is now commented out after the relase of v1.2.3 for the generation
#' # of online docs, as the command creates a directory and opens an editor
#' #draft("example_analysis.rmd", template = "hierarchical_kinetics", package = "mkin")
#' }
#'
#' @export
hierarchical_kinetics <- function(..., keep_tex = FALSE) {

  if (getRversion() < "4.1.0")
    stop("You need R with version > 4.1.0 to compile this document")

  if (!requireNamespace("knitr")) stop("Please install the knitr package to use this template")
  if (!requireNamespace("rmarkdown")) stop("Please install the rmarkdown package to use this template")
  knitr::opts_chunk$set(cache = TRUE, comment = "", tidy = FALSE, echo = TRUE)
  knitr::opts_chunk$set(fig.align = "center", fig.pos = "H")
  options(knitr.kable.NA = "")

  fmt <- rmarkdown::pdf_document(...,
    keep_tex = keep_tex,
    toc = TRUE,
    toc_depth = 3,
    includes = rmarkdown::includes(in_header = "header.tex"),
    extra_dependencies = c("float", "listing", "framed")
  )

  return(fmt)
}

# Code inspired by nlme::nlme.nlsList and R/nlme_fit.R from nlmixr

# We need to assign the degradation function created in nlme.mmkin to an
# environment that is always accessible, also e.g. when evaluation is done by
# testthat or pkgdown. Therefore parent.frame() is not good enough. The
# following environment will be in the mkin namespace.
.nlme_env <- new.env(parent = emptyenv())

#' @export
nlme::nlme

#' Retrieve a degradation function from the mmkin namespace
#'
#' @importFrom utils getFromNamespace
#' @return A function that was likely previously assigned from within
#'   nlme.mmkin
#' @export
get_deg_func <- function() {
  return(get("deg_func", getFromNamespace(".nlme_env", "mkin")))
}

#' Create an nlme model for an mmkin row object
#'
#' This functions sets up a nonlinear mixed effects model for an mmkin row
#' object. An mmkin row object is essentially a list of mkinfit objects that
#' have been obtained by fitting the same model to a list of datasets.
#'
#' Note that the convergence of the nlme algorithms depends on the quality
#' of the data. In degradation kinetics, we often only have few datasets
#' (e.g. data for few soils) and complicated degradation models, which may
#' make it impossible to obtain convergence with nlme.
#'
#' @param model An [mmkin] row object.
#' @param data Ignored, data are taken from the mmkin model
#' @param fixed Ignored, all degradation parameters fitted in the
#'   mmkin model are used as fixed parameters
#' @param random If not specified, no correlations between random effects are
#'   set up for the optimised degradation model parameters. This is
#'   achieved by using the [nlme::pdDiag] method.
#' @param groups See the documentation of nlme
#' @param start If not specified, mean values of the fitted degradation
#'   parameters taken from the mmkin object are used
#' @param correlation See the documentation of nlme
#' @param weights passed to nlme
#' @param subset passed to nlme
#' @param method passed to nlme
#' @param na.action passed to nlme
#' @param naPattern passed to nlme
#' @param control passed to nlme
#' @param verbose passed to nlme
#' @importFrom stats na.fail as.formula
#' @return Upon success, a fitted 'nlme.mmkin' object, which is an nlme object
#'   with additional elements. It also inherits from 'mixed.mmkin'.
#' @note As the object inherits from [nlme::nlme], there is a wealth of
#'   methods that will automatically work on 'nlme.mmkin' objects, such as
#'   [nlme::intervals()], [nlme::anova.lme()] and [nlme::coef.lme()].
#' @export
#' @seealso [nlme_function()], [plot.mixed.mmkin], [summary.nlme.mmkin]
#' @examples
#' ds <- lapply(experimental_data_for_UBA_2019[6:10],
#'  function(x) subset(x$data[c("name", "time", "value")], name == "parent"))
#'
#' \dontrun{
#'   f <- mmkin(c("SFO", "DFOP"), ds, quiet = TRUE, cores = 1)
#'   library(nlme)
#'   f_nlme_sfo <- nlme(f["SFO", ])
#'   f_nlme_dfop <- nlme(f["DFOP", ])
#'   anova(f_nlme_sfo, f_nlme_dfop)
#'   print(f_nlme_dfop)
#'   plot(f_nlme_dfop)
#'   endpoints(f_nlme_dfop)
#'
#'   ds_2 <- lapply(experimental_data_for_UBA_2019[6:10],
#'    function(x) x$data[c("name", "time", "value")])
#'   m_sfo_sfo <- mkinmod(parent = mkinsub("SFO", "A1"),
#'     A1 = mkinsub("SFO"), use_of_ff = "min", quiet = TRUE)
#'   m_sfo_sfo_ff <- mkinmod(parent = mkinsub("SFO", "A1"),
#'     A1 = mkinsub("SFO"), use_of_ff = "max", quiet = TRUE)
#'   m_dfop_sfo <- mkinmod(parent = mkinsub("DFOP", "A1"),
#'     A1 = mkinsub("SFO"), quiet = TRUE)
#'
#'   f_2 <- mmkin(list("SFO-SFO" = m_sfo_sfo,
#'    "SFO-SFO-ff" = m_sfo_sfo_ff,
#'    "DFOP-SFO" = m_dfop_sfo),
#'     ds_2, quiet = TRUE)
#'
#'   f_nlme_sfo_sfo <- nlme(f_2["SFO-SFO", ])
#'   plot(f_nlme_sfo_sfo)
#'
#'   # With formation fractions this does not coverge with defaults
#'   # f_nlme_sfo_sfo_ff <- nlme(f_2["SFO-SFO-ff", ])
#'   #plot(f_nlme_sfo_sfo_ff)
#'
#'   # For the following, we need to increase pnlsMaxIter and the tolerance
#'   # to get convergence
#'   f_nlme_dfop_sfo <- nlme(f_2["DFOP-SFO", ],
#'     control = list(pnlsMaxIter = 120, tolerance = 5e-4))
#'
#'   plot(f_nlme_dfop_sfo)
#'
#'   anova(f_nlme_dfop_sfo, f_nlme_sfo_sfo)
#'
#'   endpoints(f_nlme_sfo_sfo)
#'   endpoints(f_nlme_dfop_sfo)
#'
#'   if (length(findFunction("varConstProp")) > 0) { # tc error model for nlme available
#'     # Attempts to fit metabolite kinetics with the tc error model are possible,
#'     # but need tweeking of control values and sometimes do not converge
#'
#'     f_tc <- mmkin(c("SFO", "DFOP"), ds, quiet = TRUE, error_model = "tc")
#'     f_nlme_sfo_tc <- nlme(f_tc["SFO", ])
#'     f_nlme_dfop_tc <- nlme(f_tc["DFOP", ])
#'     AIC(f_nlme_sfo, f_nlme_sfo_tc, f_nlme_dfop, f_nlme_dfop_tc)
#'     print(f_nlme_dfop_tc)
#'   }
#'
#'   f_2_obs <- update(f_2, error_model = "obs")
#'   f_nlme_sfo_sfo_obs <- nlme(f_2_obs["SFO-SFO", ])
#'   print(f_nlme_sfo_sfo_obs)
#'   f_nlme_dfop_sfo_obs <- nlme(f_2_obs["DFOP-SFO", ],
#'     control = list(pnlsMaxIter = 120, tolerance = 5e-4))
#'
#'   f_2_tc <- update(f_2, error_model = "tc")
#'   # f_nlme_sfo_sfo_tc <- nlme(f_2_tc["SFO-SFO", ]) # No convergence with 50 iterations
#'   # f_nlme_dfop_sfo_tc <- nlme(f_2_tc["DFOP-SFO", ],
#'   #  control = list(pnlsMaxIter = 120, tolerance = 5e-4)) # Error in X[, fmap[[nm]]] <- gradnm
#'
#'   anova(f_nlme_dfop_sfo, f_nlme_dfop_sfo_obs)
#'
#' }
nlme.mmkin <- function(model, data = "auto",
  fixed = lapply(as.list(names(mean_degparms(model))),
    function(el) eval(parse(text = paste(el, 1, sep = "~")))),
  random = pdDiag(fixed),
  groups,
  start = mean_degparms(model, random = TRUE, test_log_parms = TRUE),
  correlation = NULL, weights = NULL,
  subset, method = c("ML", "REML"),
  na.action = na.fail, naPattern,
  control = list(), verbose= FALSE)
{
  if (nrow(model) > 1) stop("Only row objects allowed")

  thisCall <- as.list(match.call())[-1]

  # Warn in case arguments were used that are overriden
  if (any(!is.na(match(names(thisCall),
               c("data"))))) {
    warning("'nlme.mmkin' will redefine 'data'")
  }

  # Get native symbol info for speed
  if (model[[1]]$solution_type == "deSolve" & !is.null(model[[1]]$mkinmod$cf)) {
    # The mkinmod stored in the first fit will be used by nlme
    model[[1]]$mkinmod$symbols <- deSolve::checkDLL(
      dllname = model[[1]]$mkinmod$dll_info[["name"]],
      func = "diffs", initfunc = "initpar",
      jacfunc = NULL, nout = 0, outnames = NULL)
  }

  deg_func <- nlme_function(model)

  assign("deg_func", deg_func, getFromNamespace(".nlme_env", "mkin"))

  # For the formula, get the degradation function from the mkin namespace
  this_model_text <- paste0("value ~ mkin::get_deg_func()(",
    paste(names(formals(deg_func)), collapse = ", "), ")")
  this_model <- as.formula(this_model_text)

  thisCall[["model"]] <- this_model

  thisCall[["data"]] <- nlme_data(model)

  thisCall[["start"]] <- start

  thisCall[["fixed"]] <- fixed

  thisCall[["random"]] <- random

  error_model <- model[[1]]$err_mod

  if (missing(weights)) {
    thisCall[["weights"]] <- switch(error_model,
      const = NULL,
      obs = varIdent(form = ~ 1 | name),
      tc = varConstProp())
    sigma <- switch(error_model,
      tc = 1,
      NULL)
  }

  control <- thisCall[["control"]]
  if (error_model == "tc") {
    control$sigma = 1
    thisCall[["control"]] <- control
  }

  fit_time <- system.time(val <- do.call("nlme.formula", thisCall))
  val$time <- fit_time

  val$mkinmod <- model[[1]]$mkinmod
  # Don't return addresses that will become invalid
  val$mkinmod$symbols <- NULL

  val$data <- thisCall[["data"]]
  val$mmkin <- model
  if (is.list(start)) val$mean_dp_start <- start$fixed
  else val$mean_dp_start <- start
  val$transform_rates <- model[[1]]$transform_rates
  val$transform_fractions <- model[[1]]$transform_fractions
  val$solution_type <- model[[1]]$solution_type
  val$err_mode <- error_model

  val$bparms.optim <- backtransform_odeparms(val$coefficients$fixed,
    val$mkinmod,
    transform_rates = val$transform_rates,
    transform_fractions = val$transform_fractions)

  val$bparms.fixed <- model[[1]]$bparms.fixed
  val$date.fit <- date()
  val$nlmeversion <- as.character(utils::packageVersion("nlme"))
  val$mkinversion <- as.character(utils::packageVersion("mkin"))
  val$Rversion <- paste(R.version$major, R.version$minor, sep=".")
  class(val) <- c("nlme.mmkin", "mixed.mmkin", "nlme", "lme")
  return(val)
}

#' @export
#' @rdname nlme.mmkin
#' @param x An nlme.mmkin object to print
#' @param digits Number of digits to use for printing
print.nlme.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) {
  cat( "Kinetic nonlinear mixed-effects model fit by " )
  cat( if(x$method == "REML") "REML\n" else "maximum likelihood\n")
  cat("\nStructural model:\n")
  diffs <- x$mmkin[[1]]$mkinmod$diffs
  nice_diffs <- gsub("^(d.*) =", "\\1/dt =", diffs)
  writeLines(strwrap(nice_diffs, exdent = 11))
  cat("\nData:\n")
  cat(nrow(x$data), "observations of",
    length(unique(x$data$name)), "variable(s) grouped in",
    length(unique(x$data$ds)), "datasets\n")
  cat("\nLog-", if(x$method == "REML") "restricted-" else "",
      "likelihood: ", format(x$logLik, digits = digits), "\n", sep = "")
  fixF <- x$call$fixed
  cat("\nFixed effects:\n",
      deparse(
  if(inherits(fixF, "formula") || is.call(fixF) || is.name(fixF))
    x$call$fixed
  else
    lapply(fixF, function(el) as.name(deparse(el)))), "\n")
  print(fixef(x), digits = digits, ...)
  cat("\n")
  print(summary(x$modelStruct), sigma = x$sigma, digits = digits, ...)
  invisible(x)
}

#' @export
#' @rdname nlme.mmkin
#' @param object An nlme.mmkin object to update
#' @param ... Update specifications passed to update.nlme
update.nlme.mmkin <- function(object, ...) {
  res <- NextMethod()
  res$mmkin <- object$mmkin
  class(res) <- c("nlme.mmkin", "nlme", "lme")
  return(res)
}

utils::globalVariables(c("variable", "residual"))

#' Function to plot residuals stored in an mkin object
#'
#' This function plots the residuals for the specified subset of the observed
#' variables from an mkinfit object. A combined plot of the fitted model and
#' the residuals can be obtained using \code{\link{plot.mkinfit}} using the
#' argument \code{show_residuals = TRUE}.
#'
#' @importFrom stats residuals
#' @param object A fit represented in an \code{\link{mkinfit}} object.
#' @param obs_vars A character vector of names of the observed variables for
#'   which residuals should be plotted. Defaults to all observed variables in
#'   the model
#' @param xlim plot range in x direction.
#' @param xlab Label for the x axis.
#' @param standardized Should the residuals be standardized by dividing by the
#'   standard deviation given by the error model of the fit?
#' @param ylab Label for the y axis.
#' @param maxabs Maximum absolute value of the residuals. This is used for the
#'   scaling of the y axis and defaults to "auto".
#' @param legend Should a legend be plotted?
#' @param lpos Where should the legend be placed? Default is "topright". Will
#'   be passed on to \code{\link{legend}}.
#' @param col_obs Colors for the observed variables.
#' @param pch_obs Symbols to be used for the observed variables.
#' @param frame Should a frame be drawn around the plots?
#' @param \dots further arguments passed to \code{\link{plot}}.
#' @return Nothing is returned by this function, as it is called for its side
#'   effect, namely to produce a plot.
#' @author Johannes Ranke and Katrin Lindenberger
#' @seealso \code{\link{mkinplot}}, for a way to plot the data and the fitted
#'   lines of the mkinfit object, and \code{\link{plot_res}} for a function
#'   combining the plot of the fit and the residual plot.
#' @examples
#'
#' model <- mkinmod(parent = mkinsub("SFO", "m1"), m1 = mkinsub("SFO"))
#' fit <- mkinfit(model, FOCUS_2006_D, quiet = TRUE)
#' mkinresplot(fit, "m1")
#'
#' @export
mkinresplot <- function (object,
  obs_vars = names(object$mkinmod$map),
  xlim = c(0, 1.1 * max(object$data$time)),
  standardized = FALSE,
  xlab = "Time", ylab = ifelse(standardized, "Standardized residual", "Residual"),
  maxabs = "auto", legend = TRUE, lpos = "topright",
  col_obs = "auto", pch_obs = "auto",
  frame = TRUE,
  ...)
{
  obs_vars_all <- as.character(unique(object$data$variable))

  if (length(obs_vars) > 0){
      obs_vars <- intersect(obs_vars_all, obs_vars)
  } else obs_vars <- obs_vars_all

  if (standardized) {
    res_col <- "standardized"
    object$data[[res_col]] <- residuals(object, standardized = TRUE)
  } else {
    res_col <- "residual"
  }
  res <- subset(object$data, variable %in% obs_vars)[res_col]

  if (maxabs == "auto") maxabs = max(abs(res), na.rm = TRUE)

  # Set colors and symbols
  if (col_obs[1] == "auto") {
    col_obs <- 1:length(obs_vars)
  }

  if (pch_obs[1] == "auto") {
    pch_obs <- 1:length(obs_vars)
  }
  names(col_obs) <- names(pch_obs) <- obs_vars

  plot(0, type = "n", frame = frame,
       xlab = xlab, ylab = ylab,
       xlim = xlim,
       ylim = c(-1.2 * maxabs, 1.2 * maxabs), ...)

  for(obs_var in obs_vars){
    residuals_plot <- subset(object$data, variable == obs_var, c("time", res_col))
    points(residuals_plot, pch = pch_obs[obs_var], col = col_obs[obs_var])
  }

  abline(h = 0, lty = 2)

  if (legend == TRUE) {
    legend(lpos, inset = c(0.05, 0.05), legend = obs_vars,
      col = col_obs[obs_vars], pch = pch_obs[obs_vars])
  }
}

#' Plot model fits (observed and fitted) and the residuals for a row or column
#' of an mmkin object
#'
#' When x is a row selected from an mmkin object (\code{\link{[.mmkin}}), the
#' same model fitted for at least one dataset is shown. When it is a column,
#' the fit of at least one model to the same dataset is shown.
#'
#' If the current plot device is a \code{\link[tikzDevice]{tikz}} device, then
#' latex is being used for the formatting of the chi2 error level.
#'
#' @param x An object of class \code{\link{mmkin}}, with either one row or one
#'   column.
#' @param main The main title placed on the outer margin of the plot.
#' @param legends An index for the fits for which legends should be shown.
#' @param resplot Should the residuals plotted against time, using
#'   \code{\link{mkinresplot}}, or as squared residuals against predicted
#'   values, with the error model, using \code{\link{mkinerrplot}}.
#' @param ylab Label for the y axis.
#' @param standardized Should the residuals be standardized? This option
#'   is passed to \code{\link{mkinresplot}}, it only takes effect if
#'   `resplot = "time"`.
#' @param show_errmin Should the chi2 error level be shown on top of the plots
#'   to the left?
#' @param errmin_var The variable for which the FOCUS chi2 error value should
#'   be shown.
#' @param errmin_digits The number of significant digits for rounding the FOCUS
#'   chi2 error percentage.
#' @param cex Passed to the plot functions and \code{\link{mtext}}.
#' @param rel.height.middle The relative height of the middle plot, if more
#'   than two rows of plots are shown.
#' @param ymax Maximum y axis value for \code{\link{plot.mkinfit}}.
#' @param \dots Further arguments passed to \code{\link{plot.mkinfit}} and
#'   \code{\link{mkinresplot}}.
#' @return The function is called for its side effect.
#' @author Johannes Ranke
#' @examples
#'
#'   \dontrun{
#'   # Only use one core not to offend CRAN checks
#'   fits <- mmkin(c("FOMC", "HS"),
#'                 list("FOCUS B" = FOCUS_2006_B, "FOCUS C" = FOCUS_2006_C), # named list for titles
#'                 cores = 1, quiet = TRUE, error_model = "tc")
#'   plot(fits[, "FOCUS C"])
#'   plot(fits["FOMC", ])
#'   plot(fits["FOMC", ], show_errmin = FALSE)
#'
#'   # We can also plot a single fit, if we like the way plot.mmkin works, but then the plot
#'   # height should be smaller than the plot width (this is not possible for the html pages
#'   # generated by pkgdown, as far as I know).
#'   plot(fits["FOMC", "FOCUS C"]) # same as plot(fits[1, 2])
#'
#'   # Show the error models
#'   plot(fits["FOMC", ], resplot = "errmod")
#'   }
#'
#' @export
plot.mmkin <- function(x, main = "auto", legends = 1,
  resplot = c("time", "errmod"),
  ylab = "Residue",
  standardized = FALSE,
  show_errmin = TRUE,
  errmin_var = "All data", errmin_digits = 3,
  cex = 0.7, rel.height.middle = 0.9,
  ymax = "auto", ...)
{

  oldpar <- par(no.readonly = TRUE)
  on.exit(par(oldpar, no.readonly = TRUE))

  n.m <- nrow(x)
  n.d <- ncol(x)

  resplot <- match.arg(resplot)

  # We can handle either a row (different models, same dataset)
  # or a column (same model, different datasets)
  if (n.m > 1 & n.d > 1) stop("Please select fits either for one model or for one dataset")
  if (n.m == 1 & n.d == 1) loop_over = "none"
  if (n.m > 1) loop_over <- "models"
  if (n.d > 1) loop_over <- "datasets"
  n.fits <- length(x)

  # Set the main plot titles from the names of the models or the datasets
  # Will be integer indexes if no other names are present in the mmkin object
  if (main == "auto") {
    main = switch(loop_over,
                  none = paste(rownames(x), colnames(x)),
                  models = colnames(x),
                  datasets = rownames(x))
  }

  # Set relative plot heights, so the first and the last plot are the norm
  # and the middle plots (if n.fits >2) are smaller by rel.height.middle
  rel.heights <- if (n.fits > 2) c(1, rep(rel.height.middle, n.fits - 2), 1)
                 else rep(1, n.fits)
  layout(matrix(1:(2 * n.fits), n.fits, 2, byrow = TRUE), heights = rel.heights)

  par(cex = cex)

  for (i.fit in 1:n.fits) {

    # Margins for top row of plots when we have more than one row
    # Reduce bottom margin by 2.1 - hides x axis legend
    if (i.fit == 1 & n.fits > 1) {
      par(mar = c(3.0, 4.1, 4.1, 2.1))
    }

    # Margins for middle rows of plots, if any
    if (i.fit > 1 & i.fit < n.fits) {
      # Reduce top margin by 2 after the first plot as we have no main title,
      # reduced plot height, therefore we need rel.height.middle in the layout
      par(mar = c(3.0, 4.1, 2.1, 2.1))
    }

    # Margins for bottom row of plots when we have more than one row
    if (i.fit == n.fits & n.fits > 1) {
      # Restore bottom margin for last plot to show x axis legend
      par(mar = c(5.1, 4.1, 2.1, 2.1))
    }

    fit <- x[[i.fit]]
    if (ymax == "auto") {
      plot(fit, legend = legends == i.fit, ylab = ylab, ...)
    } else {
      plot(fit, legend = legends == i.fit, ylim = c(0, ymax), ylab = ylab, ...)
    }

    title(main, outer = TRUE, line = -2)

    fit_name <- switch(loop_over,
                       models = rownames(x)[i.fit],
                       datasets = colnames(x)[i.fit],
                       none = "")

    if (show_errmin) {
      chi2 <- signif(100 * mkinerrmin(fit)[errmin_var, "err.min"], errmin_digits)

      # Use LateX if the current plotting device is tikz
      if (names(dev.cur()) == "tikz output") {
        chi2_text <- paste0(fit_name, " $\\chi^2$ error level = ", chi2, "\\%")
      } else {
        chi2_perc <- paste0(chi2, "%")
        chi2_text <- bquote(.(fit_name) ~ chi^2 ~ "error level" == .(chi2_perc))
      }
      mtext(chi2_text, cex = cex, line = 0.4)
    } else {
      mtext(fit_name, cex = cex, line = 0.4)
    }

    if (resplot == "time") {
      mkinresplot(fit, legend = FALSE, standardized = standardized, ...)
    } else {
      mkinerrplot(fit, legend = FALSE, ...)
    }
    mtext(paste(fit_name, "residuals"), cex = cex, line = 0.4)
  }
}

#' Summary method for class "mmkin"
#'
#' Shows status information on the [mkinfit] objects contained in the object
#' and gives an overview of ill-defined parameters calculated by [illparms].
#'
#' @param object an object of class [mmkin]
#' @param x an object of class \code{summary.mmkin}.
#' @param conf.level confidence level for testing parameters
#' @param digits number of digits to use for printing
#' @param \dots optional arguments passed to methods like \code{print}.
#' @examples
#'
#' fits <- mmkin(
#'   c("SFO", "FOMC"),
#'   list("FOCUS A" = FOCUS_2006_A,
#'        "FOCUS C" = FOCUS_2006_C),
#'   quiet = TRUE, cores = 1)
#'   summary(fits)
#'
#' @export
summary.mmkin <- function(object, conf.level = 0.95, ...) {

  ans <- list(
    err_mod = object[[1, 1]]$err_mod,
    time = attr(object, "time"),
    illparms = illparms(object),
    status = status(object)
  )

  class(ans) <- c("summary.mmkin")
  return(ans)
}

#' @rdname summary.mmkin
#' @export
print.summary.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) {
  if (!is.null(x$err_mod)) {
    cat("Error model: ")
    cat(switch(x$err_mod,
               const = "Constant variance",
               obs = "Variance unique to each observed variable",
               tc = "Two-component variance function"), "\n")
  }
  cat("Fitted in", x$time[["elapsed"]],  "s\n")

  cat("\nStatus:\n")
  print(x$status)

  if (any(x$illparms != "")) {
    cat("\nIll-defined parameters:\n")
    print(x$illparms)
  }

  invisible(x)
}


#' Read datasets and relevant meta information from a spreadsheet file
#'
#' This function imports one dataset from each sheet of a spreadsheet file.
#' These sheets are selected based on the contents of a sheet 'Datasets', with
#' a column called 'Dataset Number', containing numbers identifying the dataset
#' sheets to be read in. In the second column there must be a grouping
#' variable, which will often be named 'Soil'. Optionally, time normalization
#' factors can be given in columns named 'Temperature' and 'Moisture'.
#'
#' There must be a sheet 'Compounds', with columns 'Name' and 'Acronym'.
#' The first row read after the header read in from this sheet is assumed
#' to contain name and acronym of the parent compound.
#'
#' The dataset sheets should be named using the dataset numbers read in from
#' the 'Datasets' sheet, i.e. '1', '2', ... . In each dataset sheet, the name
#' of the observed variable (e.g. the acronym of the parent compound or
#' one of its transformation products) should be in the first column,
#' the time values should be in the second colum, and the observed value
#' in the third column.
#'
#' In case relevant covariate data are available, they should be given
#' in a sheet 'Covariates', containing one line for each value of the grouping
#' variable specified in 'Datasets'. These values should be in the first
#' column and the column must have the same name as the second column in
#' 'Datasets'. Covariates will be read in from columns four and higher.
#' Their names should preferably not contain special characters like spaces,
#' so they can be easily used for specifying covariate models.
#'
#' A similar data structure is defined as the R6 class [mkindsg], but
#' is probably more complicated to use.
#'
#' @param path Absolute or relative path to the spreadsheet file
#' @param valid_datasets Optional numeric index of the valid datasets, default is
#' to use all datasets
#' @param parent_only Should only the parent data be used?
#' @param normalize Should the time scale be normalized using temperature
#' and moisture normalisation factors in the sheet 'Datasets'?
#' @export
read_spreadsheet <- function(path, valid_datasets = "all",
  parent_only = FALSE, normalize = TRUE)
{
  if (!requireNamespace("readxl", quietly = TRUE))
    stop("Please install the readxl package to use this function")

  # Read the compound table
  compounds <- readxl::read_excel(path, sheet = "Compounds")
  parent <- compounds[1, ]$Acronym

  # Read in meta information
  ds_meta <- readxl::read_excel(path, sheet = "Datasets")
  ds_meta["Dataset Number"] <- as.character(ds_meta[["Dataset Number"]])

  # Select valid datasets
  if (valid_datasets[1] == "all") valid_datasets <- 1:nrow(ds_meta)
  ds_numbers_valid <- ds_meta[valid_datasets, ]$`Dataset Number`
  grouping_factor <- names(ds_meta[2]) # Often "Soil"

  # Read in valid datasets
  ds_raw <- lapply(ds_numbers_valid,
    function(dsn) readxl::read_excel(path, sheet = as.character(dsn)))

  # Make data frames compatible with mmkin
  ds_tmp <- lapply(ds_raw, function(x) {
    ds_ret <- x[1:3] |>
      rlang::set_names(c("name", "time", "value")) |>
      transform(value = as.numeric(value))
  })
  names(ds_tmp) <- ds_numbers_valid

  # Normalize with temperature and moisture correction factors
  if (normalize) {
    ds_norm <- lapply(ds_numbers_valid, function(ds_number) {
      f_corr <- as.numeric(ds_meta[ds_number, c("Temperature", "Moisture")])
      ds_corr <- ds_tmp[[ds_number]] |>
        transform(time = time * f_corr[1] * f_corr[2])
      return(ds_corr)
    })
  } else {
    ds_norm <- ds_tmp
  }
  names(ds_norm) <- ds_numbers_valid

  # Select parent data only if requested
  if (parent_only) {
    ds_norm <- lapply(ds_norm, function(x) subset(x, name == parent))
    compounds <- compounds[1, ]
  }

  # Create a single long table to combine datasets with the same group name
  ds_all <- vctrs::vec_rbind(!!!ds_norm, .names_to = "Dataset Number")
  ds_all_group <- merge(ds_all, ds_meta[c("Dataset Number", grouping_factor)])
  groups <- unique(ds_meta[valid_datasets, ][[grouping_factor]])

  ds <- lapply(groups, function(x) {
      ret <- ds_all_group[ds_all_group[[grouping_factor]] == x, ]
      ret[c("name", "time", "value")]
    }
  )
  names(ds) <- groups

  # Get covariates
  covariates_raw <- readxl::read_excel(path, sheet = "Covariates")
  covariates <- as.data.frame(covariates_raw[4:ncol(covariates_raw)])
  nocov <- setdiff(groups, covariates_raw[[1]])
  if (length(nocov) > 0) {
    message("Did not find covariate data for ", paste(nocov, collapse = ", "))
    message("Not returning covariate data")
    attr(ds, "covariates") <- NULL
  } else {
    rownames(covariates) <- covariates_raw[[1]]
    covariates <- covariates[which(colnames(covariates) != "Remarks")]
    # Attach covariate data if available
    attr(ds, "covariates") <- covariates[groups, , drop = FALSE]
  }

  # Attach the compound list to support automatic model building
  attr(ds, "compounds") <- as.data.frame(compounds)

  return(ds)
}

#' Export a list of datasets format to a CAKE study file
#' 
#' In addition to the datasets, the pathways in the degradation model can be
#' specified as well.
#' 
#' @param ds A named list of datasets in long format as compatible with
#'   \code{\link{mkinfit}}.
#' @param map A character vector with CAKE compartment names (Parent, A1, ...),
#'   named with the names used in the list of datasets.
#' @param links An optional character vector of target compartments, named with
#'   the names of the source compartments. In order to make this easier, the
#'   names are used as in the datasets supplied.
#' @param filename Where to write the result. Should end in .csf in order to be
#'   compatible with CAKE.
#' @param path An optional path to the output file.
#' @param overwrite If TRUE, existing files are overwritten.
#' @param study The name of the study.
#' @param description An optional description.
#' @param time_unit The time unit for the residue data.
#' @param res_unit The unit used for the residues.
#' @param comment An optional comment.
#' @param date The date of file creation.
#' @param optimiser Can be OLS or IRLS.
#' @importFrom utils write.table
#' @return The function is called for its side effect.
#' @author Johannes Ranke
#' @export
CAKE_export <- function(ds, map = c(parent = "Parent"),
  links = NA,
  filename = "CAKE_export.csf", path = ".", overwrite = FALSE,
  study = "Degradinol aerobic soil degradation",
  description = "",
  time_unit = "days",
  res_unit = "% AR",
  comment = "",
  date = Sys.Date(),
  optimiser = "IRLS")
{
  file <- file.path(path, filename)
  if (file.exists(file) & !overwrite) stop(file, " already exists, stopping")
  csf <- file(file, encoding = "latin1", open = "w+")
  on.exit(close(csf))

  CAKE_compartments = c("Parent", "A1", "A2", "A3", "B1", "B2", "C1")
  if (!all(map %in% CAKE_compartments)) {
    stop("The elements of map have to be CAKE compartment names")
  }

  add <- function(x) cat(paste0(x, "\r\n"), file = csf, append = TRUE)
  add0 <- function(x) cat(x, file = csf, append = TRUE)

  add("[FileInfo]")
  add("CAKE-Version: 3.4 (Release)")
  add(paste("Name:", study))
  add(paste("Description:", description))
  add(paste("MeasurementUnits:", res_unit))
  add(paste("TimeUnits:", time_unit))
  add(paste("Comments:", comment))
  add(paste("Date:", date))
  add(paste("Optimiser:", optimiser))
  add("")

  add("[Data]")

  for (i in seq_along(ds)) {
    add(paste("NewDataSet:", names(ds)[i]))
    d <- mkin_long_to_wide(ds[[i]])
    names(d) <- c("Time", map[names(d)[-1]])
    write.table(d, csf,
      sep = "\t", col.names = TRUE,
      row.names = FALSE,
      quote = FALSE, eol = "\r\n", na = "")
    add("")
  }

  if (!is.na(links)) {
    add("")
    add("[Model]")
    add(paste0("ParentCompartment: Parent\t", names(map)[1], "\t", names(map)[1]))
    for (name in names(map)[-1]) {
      add(paste0("Compartment: ", map[name], "\t", name, "\t", name))
    }
    for (li in names(links)) {
      add(paste0("Link: ", map[li], "\t", map[links[li]], "\t0.5\t0\t1\tFree\tExplicit"))
    }

  }

  add("")
  add("[ComponentNames]")
  for (name in names(map)) {
    add(paste0(map[name], ":", name))
  }

}

#' Display the output of a summary function according to the output format
#'
#' This function is intended for use in a R markdown code chunk with the chunk
#' option `results = "asis"`.
#'
#' @param object The object for which the summary is to be listed
#' @param caption An optional caption
#' @param label An optional label, ignored in html output
#' @param clearpage Should a new page be started after the listing? Ignored in html output
#' @export
summary_listing <- function(object, caption = NULL, label = NULL,
  clearpage = TRUE) {
  if (knitr::is_latex_output()) {
    tex_listing(object = object, caption = caption, label = label,
      clearpage = clearpage)
  }
  if (knitr::is_html_output()) {
    html_listing(object = object, caption = caption)
  }
}

#' @rdname summary_listing
#' @export
tex_listing <- function(object, caption = NULL, label = NULL,
  clearpage = TRUE) {
  cat("\n")
  cat("\\begin{listing}", "\n")
  if (!is.null(caption)) {
    cat("\\caption{", caption, "}", "\n", sep = "")
  }
  if (!is.null(label)) {
    cat("\\caption{", label, "}", "\n", sep = "")
  }
  cat("\\begin{snugshade}", "\n")
  cat("\\scriptsize", "\n")
  cat("\\begin{verbatim}", "\n")
  cat(capture.output(suppressWarnings(summary(object))), sep = "\n")
  cat("\n")
  cat("\\end{verbatim}", "\n")
  cat("\\end{snugshade}", "\n")
  cat("\\end{listing}", "\n")
  if (clearpage) {
    cat("\\clearpage", "\n")
  }
}

#' @rdname summary_listing
#' @export
html_listing <- function(object, caption = NULL) {
  cat("\n")
  if (!is.null(caption)) {
    cat("<caption>", caption, "</caption>", "\n", sep = "")
  }
  cat("<pre><code>\n")
  cat(capture.output(suppressWarnings(summary(object))), sep = "\n")
  cat("\n")
  cat("</pre></code>\n")
}


#' Perform a hierarchical model fit with multiple starting values
#'
#' The purpose of this method is to check if a certain algorithm for fitting
#' nonlinear hierarchical models (also known as nonlinear mixed-effects models)
#' will reliably yield results that are sufficiently similar to each other, if
#' started with a certain range of reasonable starting parameters. It is
#' inspired by the article on practical identifiabiliy in the frame of nonlinear
#' mixed-effects models by Duchesne et al (2021).
#'
#' @param object The fit object to work with
#' @param n How many different combinations of starting parameters should be
#' used?
#' @param cores How many fits should be run in parallel (only on posix platforms)?
#' @param cluster A cluster as returned by [parallel::makeCluster] to be used
#' for parallel execution.
#' @param \dots Passed to the update function.
#' @param x The multistart object to print
#' @return A list of [saem.mmkin] objects, with class attributes
#' 'multistart.saem.mmkin' and 'multistart'.
#' @seealso [parplot], [llhist]
#'
#' @references Duchesne R, Guillemin A, Gandrillon O, Crauste F. Practical
#' identifiability in the frame of nonlinear mixed effects models: the example
#' of the in vitro erythropoiesis. BMC Bioinformatics. 2021 Oct 4;22(1):478.
#' doi: 10.1186/s12859-021-04373-4.
#' @export
#' @examples
#' \dontrun{
#' library(mkin)
#' dmta_ds <- lapply(1:7, function(i) {
#'   ds_i <- dimethenamid_2018$ds[[i]]$data
#'   ds_i[ds_i$name == "DMTAP", "name"] <-  "DMTA"
#'   ds_i$time <- ds_i$time * dimethenamid_2018$f_time_norm[i]
#'   ds_i
#' })
#' names(dmta_ds) <- sapply(dimethenamid_2018$ds, function(ds) ds$title)
#' dmta_ds[["Elliot"]] <- rbind(dmta_ds[["Elliot 1"]], dmta_ds[["Elliot 2"]])
#' dmta_ds[["Elliot 1"]] <- dmta_ds[["Elliot 2"]] <- NULL
#'
#' f_mmkin <- mmkin("DFOP", dmta_ds, error_model = "tc", cores = 7, quiet = TRUE)
#' f_saem_full <- saem(f_mmkin)
#' f_saem_full_multi <- multistart(f_saem_full, n = 16, cores = 16)
#' parplot(f_saem_full_multi, lpos = "topleft")
#' illparms(f_saem_full)
#'
#' f_saem_reduced <- update(f_saem_full, no_random_effect = "log_k2")
#' illparms(f_saem_reduced)
#' # On Windows, we need to create a PSOCK cluster first and refer to it
#' # in the call to multistart()
#' library(parallel)
#' cl <- makePSOCKcluster(12)
#' f_saem_reduced_multi <- multistart(f_saem_reduced, n = 16, cluster = cl)
#' parplot(f_saem_reduced_multi, lpos = "topright", ylim = c(0.5, 2))
#' stopCluster(cl)
#' }
multistart <- function(object, n = 50,
  cores = if (Sys.info()["sysname"] == "Windows") 1 else parallel::detectCores(),
  cluster = NULL, ...)
{
  UseMethod("multistart", object)
}

#' @rdname multistart
#' @export
multistart.saem.mmkin <- function(object, n = 50, cores = 1,
  cluster = NULL, ...) {
  call <- match.call()
  if (n <= 1) stop("Please specify an n of at least 2")

  mmkin_object <- object$mmkin

  mmkin_parms <- parms(mmkin_object, errparms = FALSE,
    transformed = object$transformations == "mkin")
  start_parms <- apply(
    mmkin_parms, 1,
    function(x) stats::runif(n, min(x), max(x)))

  saem_call <- object$call
  saem_call[[1]] <- saem
  saem_call[[2]] <- mmkin_object
  i_startparms <- which(names(saem_call) == "degparms_start")

  fit_function <- function(x) {

    new_startparms <- str2lang(
      paste0(capture.output(dput(start_parms[x, ])),
        collapse = ""))

    if (length(i_startparms) == 0) {
      saem_call <- c(as.list(saem_call), degparms_start = new_startparms)
      saem_call <- as.call(saem_call)
    } else {
      saem_call[i_startparms] <- new_startparms
    }

    ret <- eval(saem_call)

    return(ret)
  }

  if (is.null(cluster)) {
    res <- parallel::mclapply(1:n, fit_function,
      mc.cores = cores, mc.preschedule = FALSE)
  } else {
    res <- parallel::parLapplyLB(cluster, 1:n, fit_function)
  }
  attr(res, "orig") <- object
  attr(res, "start_parms") <- start_parms
  attr(res, "call") <- call
  class(res) <- c("multistart.saem.mmkin", "multistart")
  return(res)
}

#' @export
status.multistart <- function(object, ...) {
  all_summary_warnings <- character()

  result <- lapply(object,
    function(fit) {
      if (inherits(fit, "try-error")) return("E")
      else {
        return("OK")
      }
  })
  result <- unlist(result)

  class(result) <- "status.multistart"
  return(result)
}

#' @export
status.multistart.saem.mmkin <- function(object, ...) {
  all_summary_warnings <- character()

  result <- lapply(object,
    function(fit) {
      if (inherits(fit$so, "try-error")) return("E")
      else {
        return("OK")
      }
  })
  result <- unlist(result)

  class(result) <- "status.multistart"
  return(result)
}

#' @export
print.status.multistart <- function(x, ...) {
  class(x) <- NULL
  print(table(x, dnn = NULL))
  if (any(x == "OK")) cat("OK: Fit terminated successfully\n")
  if (any(x == "E")) cat("E: Error\n")
}

#' @rdname multistart
#' @export
print.multistart <- function(x, ...) {
  cat("<multistart> object with", length(x), "fits:\n")
  print(status(x))
}

#' @rdname multistart
#' @export
best <- function(object, ...)
{
  UseMethod("best", object)
}

#' @export
#' @return The object with the highest likelihood
#' @rdname multistart
best.default <- function(object, ...)
{
  return(object[[which.best(object)]])
}

#' @return The index of the object with the highest likelihood
#' @rdname multistart
#' @export
which.best <- function(object, ...)
{
  UseMethod("which.best", object)
}

#' @rdname multistart
#' @export
which.best.default <- function(object, ...)
{
  llfunc <- function(object) {
    ret <- try(logLik(object))
    if (inherits(ret, "try-error")) return(NA)
    else return(ret)
  }
  ll <- sapply(object, llfunc)
  return(which.max(ll))
}

#' @export
update.multistart <- function(object, ..., evaluate = TRUE) {
  call <- attr(object, "call")
  # For some reason we get multistart.saem.mmkin in call[[1]] when using multistart
  # from the loaded package so we need to fix this so we do not have to export
  # multistart.saem.mmkin
  call[[1]] <- multistart

  update_arguments <- match.call(expand.dots = FALSE)$...

  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
}

#' @importFrom lmtest lrtest
#' @export
lmtest::lrtest

#' Likelihood ratio test for mkinfit models
#'
#' Compare two mkinfit models based on their likelihood. If two fitted
#' mkinfit objects are given as arguments, it is checked if they have been
#' fitted to the same data. It is the responsibility of the user to make sure
#' that the models are nested, i.e. one of them has less degrees of freedom
#' and can be expressed by fixing the parameters of the other.
#'
#' Alternatively, an argument to mkinfit can be given which is then passed
#' to \code{\link{update.mkinfit}} to obtain the alternative model.
#'
#' The comparison is then made by the \code{\link[lmtest]{lrtest.default}}
#' method from the lmtest package. The model with the higher number of fitted
#' parameters (alternative hypothesis) is listed first, then the model with the
#' lower number of fitted parameters (null hypothesis).
#'
#' @importFrom stats logLik update
#' @param object An \code{\link{mkinfit}} object, or an \code{\link{mmkin}} column
#'  object containing two fits to the same data.
#' @param object_2 Optionally, another mkinfit object fitted to the same data.
#' @param \dots Argument to \code{\link{mkinfit}}, passed to
#'   \code{\link{update.mkinfit}} for creating the alternative fitted object.
#' @examples
#' \dontrun{
#' test_data <- subset(synthetic_data_for_UBA_2014[[12]]$data, name == "parent")
#' sfo_fit <- mkinfit("SFO", test_data, quiet = TRUE)
#' dfop_fit <- mkinfit("DFOP", test_data, quiet = TRUE)
#' lrtest(dfop_fit, sfo_fit)
#' lrtest(sfo_fit, dfop_fit)
#'
#' # The following two examples are commented out as they fail during
#' # generation of the static help pages by pkgdown
#' #lrtest(dfop_fit, error_model = "tc")
#' #lrtest(dfop_fit, fixed_parms = c(k2 = 0))
#'
#' # However, this equivalent syntax also works for static help pages
#' lrtest(dfop_fit, update(dfop_fit, error_model = "tc"))
#' lrtest(dfop_fit, update(dfop_fit, fixed_parms = c(k2 = 0)))
#' }
#' @export
lrtest.mkinfit <- function(object, object_2 = NULL, ...) {

  name_function <- function(x) {
    object_name <- paste(x$mkinmod$name, "with error model", x$err_mod)
    if (length(x$bparms.fixed) > 0) {
      object_name <- paste(object_name,
        "and fixed parameter(s)",
        paste(names(x$bparms.fixed), collapse = ", "))
    }
    return(object_name)
  }

  if (is.null(object_2)) {
    object_2 <- update(object, ...)
  } else {
    data_object <- object$data[c("time", "variable", "observed")]
    data_object_2 <- object_2$data[c("time", "variable", "observed")]
    if (!identical(data_object, data_object_2)) {
      stop("It seems that the mkinfit objects have not been fitted to the same data")
    }
  }
  if (attr(logLik(object), "df") > attr(logLik(object_2), "df")) {
    lmtest::lrtest.default(object, object_2, name = name_function)
  } else {
    lmtest::lrtest.default(object_2, object, name = name_function)
  }
}

#' @rdname lrtest.mkinfit
#' @export
lrtest.mmkin <- function(object, ...) {
  if (nrow(object) != 2 | ncol(object) > 1) stop("Only works for a column containing two mkinfit objects")
  object[[1, 1]]$mkinmod$name <- rownames(object)[1]
  object[[2, 1]]$mkinmod$name <- rownames(object)[2]
  lrtest(object[[1, 1]], object[[2, 1]])
}

#' Calculate Akaike weights for model averaging
#'
#' Akaike weights are calculated based on the relative
#' expected Kullback-Leibler information as specified
#' by Burnham and Anderson (2004).
#'
#' @param object An [mmkin] column object, containing two or more
#'   [mkinfit] models that have been fitted to the same data,
#'   or an mkinfit object. In the latter case, further mkinfit
#'   objects fitted to the same data should be specified
#'   as dots arguments.
#' @param \dots Not used in the method for [mmkin] column objects,
#'   further [mkinfit] objects in the method for mkinfit objects.
#' @references Burnham KP and Anderson DR (2004) Multimodel
#'   Inference: Understanding AIC and BIC in Model Selection.
#'   *Sociological Methods & Research* **33**(2) 261-304
#' @md
#' @examples
#' \dontrun{
#' f_sfo <- mkinfit("SFO", FOCUS_2006_D, quiet = TRUE)
#' f_dfop <- mkinfit("DFOP", FOCUS_2006_D, quiet = TRUE)
#' aw_sfo_dfop <- aw(f_sfo, f_dfop)
#' sum(aw_sfo_dfop)
#' aw_sfo_dfop # SFO gets more weight as it has less parameters and a similar fit
#' f <- mmkin(c("SFO", "FOMC", "DFOP"), list("FOCUS D" = FOCUS_2006_D), cores = 1, quiet = TRUE)
#' aw(f)
#' sum(aw(f))
#' aw(f[c("SFO", "DFOP")])
#' }
#' @export
aw <- function(object, ...) UseMethod("aw")

.aw <- function(all_objects) {
  AIC_all <- sapply(all_objects, AIC)
  delta_i <- AIC_all - min(AIC_all)
  denom <- sum(exp(-delta_i/2))
  w_i <- exp(-delta_i/2) / denom
  return(w_i)
}

#' @export
#' @rdname aw
aw.mkinfit <- function(object, ...) {
  oo <- list(...)
  data_object <- object$data[c("time", "variable", "observed")]
  for (i in seq_along(oo)) {
    if (!inherits(oo[[i]], "mkinfit")) stop("Please supply only mkinfit objects")
    data_other_object <- oo[[i]]$data[c("time", "variable", "observed")]
    if (!identical(data_object, data_other_object)) {
      stop("It seems that the mkinfit objects have not all been fitted to the same data")
    }
  }
  all_objects <- list(object, ...)
  .aw(all_objects)
}

#' @export
#' @rdname aw
aw.mmkin <- function(object, ...) {
  if (ncol(object) > 1) stop("Please supply an mmkin column object")
  do.call(aw, object)
}

#' @export
#' @rdname aw
aw.mixed.mmkin <- function(object, ...) {
  oo <- list(...)
  data_object <- object$data[c("ds", "name", "time", "value")]
  for (i in seq_along(oo)) {
    if (!inherits(oo[[i]], "mixed.mmkin")) stop("Please supply objects inheriting from mixed.mmkin")
    data_other_object <- oo[[i]]$data[c("ds", "name", "time", "value")]
    if (!identical(data_object, data_other_object)) {
      stop("It seems that the mixed.mmkin objects have not all been fitted to the same data")
    }
  }
  all_objects <- list(object, ...)
  .aw(all_objects)
}

#' @export
#' @rdname aw
aw.multistart <- function(object, ...) {
  do.call(aw, object)
}

#' Calculate mean degradation parameters for an mmkin row object
#'
#' @return If random is FALSE (default), a named vector containing mean values
#'   of the fitted degradation model parameters. If random is TRUE, a list with
#'   fixed and random effects, in the format required by the start argument of
#'   nlme for the case of a single grouping variable ds.
#' @param object An mmkin row object containing several fits of the same model to different datasets
#' @param random Should a list with fixed and random effects be returned?
#' @param test_log_parms If TRUE, log parameters are only considered in
#'   the mean calculations if their untransformed counterparts (most likely
#'   rate constants) pass the t-test for significant difference from zero.
#' @param conf.level Possibility to adjust the required confidence level
#'   for parameter that are tested if requested by 'test_log_parms'.
#' @param default_log_parms If set to a numeric value, this is used
#'   as a default value for the tested log parameters that failed the
#'   t-test.
#' @export
mean_degparms <- function(object, random = FALSE, test_log_parms = FALSE, conf.level = 0.6,
  default_log_parms = NA)
{
  if (nrow(object) > 1) stop("Only row objects allowed")
  parm_mat_trans <- sapply(object, parms, transformed = TRUE)

  if (test_log_parms) {
      parm_mat_dim <- dim(parm_mat_trans)
      parm_mat_dimnames <- dimnames(parm_mat_trans)

      log_parm_trans_names <- grep("^log_", rownames(parm_mat_trans), value = TRUE)
      log_parm_names <- gsub("^log_", "", log_parm_trans_names)

      t_test_back_OK <- matrix(
        sapply(object, function(o) {
          suppressWarnings(summary(o)$bpar[log_parm_names, "Pr(>t)"] < (1 - conf.level))
        }), nrow = length(log_parm_names))
      rownames(t_test_back_OK) <- log_parm_trans_names

      parm_mat_trans_OK <- parm_mat_trans
      for (trans_parm in log_parm_trans_names) {
        parm_mat_trans_OK[trans_parm, ] <- ifelse(t_test_back_OK[trans_parm, ],
          parm_mat_trans[trans_parm, ], log(default_log_parms))
      }
    } else {
    parm_mat_trans_OK <- parm_mat_trans
  }

  mean_degparm_names <- setdiff(rownames(parm_mat_trans), names(object[[1]]$errparms))
  degparm_mat_trans <- parm_mat_trans[mean_degparm_names, , drop = FALSE]
  degparm_mat_trans_OK <- parm_mat_trans_OK[mean_degparm_names, , drop = FALSE]

  # fixed in the sense of fixed effects, as this function was
  # written to supply starting parameters for nlme
  fixed <- apply(degparm_mat_trans_OK, 1, mean, na.rm = TRUE)
  if (random) {
    random <- t(apply(degparm_mat_trans[mean_degparm_names, , drop = FALSE], 2, function(column) column - fixed))
    # If we only have one parameter, apply returns a vector so we get a single row
    if (nrow(degparm_mat_trans) == 1) random <- t(random)
    rownames(random) <- levels(nlme_data(object)$ds)

    # For nlmixr we can specify starting values for standard deviations eta, and
    # we ignore uncertain parameters if test_log_parms is FALSE
    eta <- apply(degparm_mat_trans_OK, 1, stats::sd, na.rm = TRUE)

    return(list(fixed = fixed, random = list(ds = random), eta = eta))
  } else {
    return(fixed)
  }
}


# This file is part of the R package mkin

# mkin is free software: you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation, either version 3 of the License, or (at your option) any later
# version.

# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
# details.

# You should have received a copy of the GNU General Public License along with
# this program. If not, see <http://www.gnu.org/licenses/>

#' Function to perform isometric log-ratio transformation
#' 
#' This implementation is a special case of the class of isometric log-ratio
#' transformations.
#' 
#' @aliases ilr invilr
#' @param x A numeric vector. Naturally, the forward transformation is only
#'   sensible for vectors with all elements being greater than zero.
#' @return The result of the forward or backward transformation. The returned
#'   components always sum to 1 for the case of the inverse log-ratio
#'   transformation.
#' @author René Lehmann and Johannes Ranke
#' @seealso Another implementation can be found in R package
#'   \code{robCompositions}.
#' @references Peter Filzmoser, Karel Hron (2008) Outlier Detection for
#'   Compositional Data Using Robust Methods. Math Geosci 40 233-248
#' @keywords manip
#' @examples
#' 
#' # Order matters
#' ilr(c(0.1, 1, 10))
#' ilr(c(10, 1, 0.1))
#' # Equal entries give ilr transformations with zeros as elements
#' ilr(c(3, 3, 3))
#' # Almost equal entries give small numbers
#' ilr(c(0.3, 0.4, 0.3))
#' # Only the ratio between the numbers counts, not their sum
#' invilr(ilr(c(0.7, 0.29, 0.01)))
#' invilr(ilr(2.1 * c(0.7, 0.29, 0.01)))
#' # Inverse transformation of larger numbers gives unequal elements
#' invilr(-10)
#' invilr(c(-10, 0))
#' # The sum of the elements of the inverse ilr is 1
#' sum(invilr(c(-10, 0)))
#' # This is why we do not need all elements of the inverse transformation to go back:
#' a <- c(0.1, 0.3, 0.5)
#' b <- invilr(a)
#' length(b) # Four elements
#' ilr(c(b[1:3], 1 - sum(b[1:3]))) # Gives c(0.1, 0.3, 0.5)
#' 
#' @export
ilr <- function(x) {
  z <- vector()
  for (i in 1:(length(x) - 1)) {
    z[i] <- sqrt(i/(i+1)) * log((prod(x[1:i]))^(1/i) / x[i+1])
  }
  return(z)
}

#' @rdname ilr
#' @export
invilr<-function(x) {
  D <- length(x) + 1
  z <- c(x, 0)
  y <- rep(0, D)
  s <- sqrt(1:D*2:(D+1))
  q <- z/s
  y[1] <- sum(q[1:D])
  for (i in 2:D) {
    y[i] <- sum(q[i:D]) - sqrt((i-1)/i) * z[i-1]
  }
  z <- vector()
  for (i in 1:D) {
    z[i] <- exp(y[i])/sum(exp(y))
  }

  # Work around a numerical problem with NaN values returned by the above
  # Only works if there is only one NaN value: replace it with 1
  # if the sum of the other components is < 1e-10
  if (sum(is.na(z)) == 1 && sum(z[!is.na(z)]) < 1e-10)
    z = ifelse(is.na(z), 1, z)

  return(z)
}

#' Function to calculate maximum time weighted average concentrations from
#' kinetic models fitted with mkinfit
#' 
#' This function calculates maximum moving window time weighted average
#' concentrations (TWAs) for kinetic models fitted with \code{\link{mkinfit}}.
#' Currently, only calculations for the parent are implemented for the SFO,
#' FOMC, DFOP and HS models, using the analytical formulas given in the PEC
#' soil section of the FOCUS guidance.
#' 
#' @aliases max_twa_parent max_twa_sfo max_twa_fomc max_twa_dfop max_twa_hs
#' @param fit An object of class \code{\link{mkinfit}}.
#' @param windows The width of the time windows for which the TWAs should be
#'   calculated.
#' @param M0 The initial concentration for which the maximum time weighted
#'   average over the decline curve should be calculated. The default is to use
#'   a value of 1, which means that a relative maximum time weighted average
#'   factor (f_twa) is calculated.
#' @param k The rate constant in the case of SFO kinetics.
#' @param t The width of the time window.
#' @param alpha Parameter of the FOMC model.
#' @param beta Parameter of the FOMC model.
#' @param k1 The first rate constant of the DFOP or the HS kinetics.
#' @param k2 The second rate constant of the DFOP or the HS kinetics.
#' @param g Parameter of the DFOP model.
#' @param tb Parameter of the HS model.
#' @return For \code{max_twa_parent}, a numeric vector, named using the
#'   \code{windows} argument.  For the other functions, a numeric vector of
#'   length one (also known as 'a number').
#' @author Johannes Ranke
#' @references FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence
#'   and Degradation Kinetics from Environmental Fate Studies on Pesticides in
#'   EU Registration} Report of the FOCUS Work Group on Degradation Kinetics,
#'   EC Document Reference Sanco/10058/2005 version 2.0, 434 pp,
#'   \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics}
#' @examples
#' 
#'   fit <- mkinfit("FOMC", FOCUS_2006_C, quiet = TRUE)
#'   max_twa_parent(fit, c(7, 21))
#' 
#' @export
max_twa_parent <- function(fit, windows) {
  parms.all <- c(fit$bparms.optim, fit$bparms.fixed)
  obs_vars <- fit$obs_vars
  if (length(obs_vars) > 1) {
    warning("Calculation of maximum time weighted average concentrations is",
            "currently only implemented for the parent compound using",
            "analytical solutions")
  }
  obs_var <- obs_vars[1]
  spec = fit$mkinmod$spec
  type = spec[[1]]$type

  M0 <- parms.all[paste0(obs_var, "_0")]

  if (type == "SFO") {
    k_name <- paste0("k_", obs_var)
    if (fit$mkinmod$use_of_ff == "min") {
      k_name <- paste0(k_name, "_sink")
    }
    k <- parms.all[k_name]
    twafunc <- function(t) {
      max_twa_sfo(M0, k, t)
    }
  }
  if (type == "FOMC") {
    alpha <- parms.all["alpha"]
    beta <- parms.all["beta"]
    twafunc <- function(t) {
      max_twa_fomc(M0, alpha, beta, t)
    }
  }
  if (type == "DFOP") {
    k1 <- parms.all["k1"]
    k2 <- parms.all["k2"]
    g <- parms.all["g"]
    twafunc <- function(t) {
      max_twa_dfop(M0, k1, k2, g, t)
    }
  }
  if (type == "HS") {
    k1 <- parms.all["k1"]
    k2 <- parms.all["k2"]
    tb <- parms.all["tb"]
    twafunc <- function(t) {
      ifelse(t <= tb,
        max_twa_sfo(M0, k1, t),
        max_twa_hs(M0, k1, k2, tb, t)
      )
    }
  }
  if (type %in% c("IORE", "SFORB")) {
    stop("Calculation of maximum time weighted average concentrations is currently ",
         "not implemented for the ", type, " model.")
  }
  res <- twafunc(windows)
  names(res) <- windows
  return(res)
}

#' @rdname max_twa_parent
#' @export
max_twa_sfo <- function(M0 = 1, k, t) {
  M0 * (1 - exp(- k * t)) / (k * t)
}

#' @rdname max_twa_parent
#' @export
max_twa_fomc <- function(M0 = 1, alpha, beta, t) {
  M0 * (beta)/(t * (1 - alpha)) * ((t/beta + 1)^(1 - alpha) - 1)
}

#' @rdname max_twa_parent
#' @export
max_twa_dfop <- function(M0 = 1, k1, k2, g, t) {
  M0/t * ((g/k1) * (1 - exp(- k1 * t)) + ((1 - g)/k2) * (1 - exp(- k2 * t)))
}

#' @rdname max_twa_parent
#' @export
max_twa_hs <- function(M0 = 1, k1, k2, tb, t) {
  (M0 / t) * (
    (1/k1) * (1 - exp(- k1 * tb)) +
    (exp(- k1 * tb) / k2) * (1 - exp(- k2 * (t - tb)))
  )
}

utils::globalVariables("D24_2014")

#' Normalisation factors for aerobic soil degradation according to FOCUS guidance
#'
#' Time step normalisation factors for aerobic soil degradation as described
#' in Appendix 8 to the FOCUS kinetics guidance (FOCUS 2014, p. 369).
#'
#' @param object An object containing information used for the calculations
#' @param temperature Numeric vector of temperatures in °C
#' @param moisture Numeric vector of moisture contents in \\% w/w
#' @param field_moisture Numeric vector of moisture contents at field capacity
#'   (pF2) in \\% w/w
#' @param study_moisture_ref_source Source for the reference value
#'   used to calculate the study moisture. If 'auto', preference is given
#'   to a reference moisture given in the meta information, otherwise
#'   the focus soil moisture for the soil class is used
#' @param Q10 The Q10 value used for temperature normalisation
#' @param walker The Walker exponent used for moisture normalisation
#' @param f_na The factor to use for NA values. If set to NA, only factors
#'  for complete cases will be returned.
#' @param \dots Currently not used
#' @references
#' FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence
#'   and Degradation Kinetics from Environmental Fate Studies on Pesticides in
#'   EU Registration} Report of the FOCUS Work Group on Degradation Kinetics,
#'   EC Document Reference Sanco/10058/2005 version 2.0, 434 pp,
#'   \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics}
#' FOCUS (2014) \dQuote{Generic guidance for Estimating Persistence
#'   and Degradation Kinetics from Environmental Fate Studies on Pesticides in
#'   EU Registration} Report of the FOCUS Work Group on Degradation Kinetics,
#'   Version 1.1, 18 December 2014
#'   \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics}
#' @seealso [focus_soil_moisture]
#' @examples
#' f_time_norm_focus(25, 20, 25) # 1.37, compare FOCUS 2014 p. 184
#'
#' D24_2014$meta
#' # No moisture normalisation in the first dataset, so we use f_na = 1 to get
#' # temperature only normalisation as in the EU evaluation
#' f_time_norm_focus(D24_2014, study_moisture_ref_source = "focus", f_na = 1)
#' @export
f_time_norm_focus <- function(object, ...) {
  UseMethod("f_time_norm_focus")
}

#' @rdname f_time_norm_focus
#' @export
f_time_norm_focus.numeric <- function(object,
  moisture = NA, field_moisture = NA,
  temperature = object,
  Q10 = 2.58, walker = 0.7, f_na = NA, ...)
{
  f_temp <- ifelse(is.na(temperature),
    f_na,
    ifelse(temperature <= 0,
      0,
      Q10^((temperature - 20)/10)))
  f_moist <- ifelse(is.na(moisture),
    f_na,
    ifelse(moisture >= field_moisture,
      1,
      (moisture / field_moisture)^walker))
  f_time_norm <- f_temp * f_moist
  f_time_norm
}

#' @rdname f_time_norm_focus
#' @export
f_time_norm_focus.mkindsg <- function(object,
  study_moisture_ref_source = c("auto", "meta", "focus"),
  Q10 = 2.58, walker = 0.7, f_na = NA, ...) {

  study_moisture_ref_source <- match.arg(study_moisture_ref_source)
  meta <- object$meta

  if (is.null(meta$field_moisture)) {
    field_moisture <- focus_soil_moisture[meta$usda_soil_type, "pF2"]
  } else {
    field_moisture <- ifelse(is.na(meta$field_moisture),
      focus_soil_moisture[meta$usda_soil_type, "pF2"],
      meta$field_moisture)
  }

  study_moisture_ref_focus <-
    focus_soil_moisture[as.matrix(meta[c("usda_soil_type", "study_moisture_ref_type")])]

  if (study_moisture_ref_source == "auto") {
    study_moisture_ref <- ifelse (is.na(meta$study_ref_moisture),
      study_moisture_ref_focus,
      meta$study_ref_moisture)
  } else {
    if (study_moisture_ref_source == "meta") {
      study_moisture_ref <- meta$study_moisture_ref
    } else {
      study_moisture_ref <- study_moisture_ref_focus
    }
  }

  if ("study_moisture" %in% names(meta)) {
    study_moisture <- ifelse(is.na(meta$study_moisture),
      meta$rel_moisture * study_moisture_ref,
      meta$study_moisture)
  } else {
    study_moisture <- meta$rel_moisture * study_moisture_ref
  }

  object$f_time_norm <- f_time_norm_focus(meta$temperature,
    moisture = study_moisture, field_moisture = field_moisture,
    Q10 = Q10, walker = walker, f_na = f_na)
  message("$f_time_norm was (re)set to normalised values")
  invisible(object$f_time_norm)
}

#' A dataset class for mkin
#'
#' @description
#' At the moment this dataset class is hardly used in mkin. For example,
#' mkinfit does not take mkinds datasets as argument, but works with dataframes
#' such as the on contained in the data field of mkinds objects. Some datasets
#' provided by this package come as mkinds objects nevertheless.
#'
#' @importFrom R6 R6Class
#' @examples
#'
#' mds <- mkinds$new("FOCUS A", FOCUS_2006_A)
#' print(mds)
#'
#' @export
mkinds <- R6Class("mkinds",
  public = list(

    #' @field title A full title for the dataset
    title = NULL,

    #' @field sampling_times The sampling times
    sampling_times = NULL,

    #' @field time_unit The time unit
    time_unit = NULL,

    #' @field observed Names of the observed variables
    observed = NULL,

    #' @field unit The unit of the observations
    unit = NULL,

    #' @field replicates The maximum number of replicates per sampling time
    replicates = NULL,

    #' @field data A data frame with at least the columns name, time
    #' and value in order to be compatible with mkinfit
    data = NULL,

    #' @description
    #' Create a new mkinds object
    #' @param title The dataset title
    #' @param data The data
    #' @param time_unit The time unit
    #' @param unit The unit of the observations
    initialize = function(title = "", data, time_unit = NA, unit = NA) {

      self$title <- title
      self$sampling_times <- sort(unique(data$time))
      self$time_unit <- time_unit
      self$observed <- unique(data$name)
      self$unit <- unit
      self$replicates <- max(by(data, list(data$name, data$time), nrow))
      if (is.null(data$override)) data$override <- NA
      if (is.null(data$err)) data$err <- 1
      self$data <- data

    }
  )
)

#' Print mkinds objects
#'
#' @rdname mkinds
#' @param x An [mkinds] object.
#' @param data Should the data be printed?
#' @param \dots Not used.
#' @export
print.mkinds <- function(x, data = FALSE, ...) {
  cat("<mkinds> with $title: ",  x$title, "\n")
  cat("Observed compounds $observed: ", paste(x$observed, collapse = ", "), "\n")
  cat("Sampling times $sampling_times:\n")
  cat(paste(x$sampling_times, collapse = ", "), "\n")
  cat("With a maximum of ", x$replicates, " replicates\n")
  if (!is.na(x$time_unit)) cat("Time unit: ", x$time_unit, "\n")
  if (!is.na(x$unit)) cat("Observation unit: ", x$unit, "\n")
  if (data) print(mkin_long_to_wide(x$data))
}

#' A class for dataset groups for mkin
#'
#' @description
#' A container for working with datasets that share at least one compound,
#' so that combined evaluations are desirable.
#'
#' Time normalisation factors are initialised with a value of 1 for each
#' dataset if no data are supplied.
#'
#' @examples
#'
#' mdsg <- mkindsg$new("Experimental X", experimental_data_for_UBA_2019[6:10])
#' print(mdsg)
#' print(mdsg, verbose = TRUE)
#' print(mdsg, verbose = TRUE, data = TRUE)
#'
#' @export
mkindsg <- R6Class("mkindsg",
  public = list(

    #' @field title A title for the dataset group
    title = NULL,

    #' @field ds A list of mkinds objects
    ds = NULL,

    #' @field observed_n Occurrence counts of compounds in datasets
    observed_n = NULL,

    #' @field f_time_norm Time normalisation factors
    f_time_norm = NULL,

    #' @field meta A data frame with a row for each dataset,
    #'   containing additional information in the form
    #'   of categorical data (factors) or numerical data
    #'   (e.g. temperature, moisture,
    #'   or covariates like soil pH).
    meta = NULL,

    #' @description
    #' Create a new mkindsg object
    #' @param title The title
    #' @param ds A list of mkinds objects
    #' @param f_time_norm Time normalisation factors
    #' @param meta The meta data
    initialize = function(title = "", ds,
      f_time_norm = rep(1, length(ds)), meta)
    {
      self$title <- title
      if (all(sapply(ds, inherits, "mkinds"))) {
        self$ds <- ds
      } else {
        stop("Please supply a list of mkinds objects")
      }

      all_observed <- unlist(lapply(ds, function(x) x$observed))
      observed <- factor(all_observed, levels = unique(all_observed))
      self$observed_n <- table(observed)
      names(dimnames(self$observed_n)) <- NULL
      self$f_time_norm <- f_time_norm

      if (!missing(meta)) {
        rownames(meta) <- lapply(ds, function(x) x$title)
        self$meta <- meta
      }
    }
  )
)

#' Print mkindsg objects
#'
#' @rdname mkindsg
#' @param x An [mkindsg] object.
#' @param verbose Should the mkinds objects be printed?
#' @param data Should the mkinds objects be printed with their data?
#' @param \dots Not used.
#' @export
print.mkindsg <- function(x, data = FALSE, verbose = data, ...) {
  cat("<mkindsg> holding", length(x$ds), "mkinds objects\n")
  cat("Title $title: ",  x$title, "\n")
  cat("Occurrence of observed compounds $observed_n:\n")
  print(x$observed_n)
  if (any(x$f_time_norm != 1)) {
    cat("Time normalisation factors $f_time_norm:\n")
    print(x$f_time_norm)
  }
  if (!is.null(x$meta)) {
    cat("Meta information $meta:\n")
    print(x$meta)
  }
  if (verbose) {
    cat("\nDatasets $ds:")
    for (ds in x$ds) {
      cat("\n")
      print(ds, data = data)
    }
  }
}

utils::globalVariables(c("name", "value_mean"))

#' Calculate the minimum error to assume in order to pass the variance test
#'
#' This function finds the smallest relative error still resulting in passing
#' the chi-squared test as defined in the FOCUS kinetics report from 2006.
#'
#' This function is used internally by \code{\link{summary.mkinfit}}.
#'
#' @param fit an object of class \code{\link{mkinfit}}.
#' @param alpha The confidence level chosen for the chi-squared test.
#' @importFrom stats qchisq aggregate
#' @return A dataframe with the following components: \item{err.min}{The
#' relative error, expressed as a fraction.} \item{n.optim}{The number of
#' optimised parameters attributed to the data series.} \item{df}{The number of
#' remaining degrees of freedom for the chi2 error level calculations.  Note
#' that mean values are used for the chi2 statistic and therefore every time
#' point with observed values in the series only counts one time.} The
#' dataframe has one row for the total dataset and one further row for each
#' observed state variable in the model.
#' @references FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence
#' and Degradation Kinetics from Environmental Fate Studies on Pesticides in EU
#' Registration} Report of the FOCUS Work Group on Degradation Kinetics, EC
#' Document Reference Sanco/10058/2005 version 2.0, 434 pp,
#' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics}
#' @keywords manip
#' @examples
#'
#' SFO_SFO = mkinmod(parent = mkinsub("SFO", to = "m1"),
#'                   m1 = mkinsub("SFO"),
#'                   use_of_ff = "max")
#'
#' fit_FOCUS_D = mkinfit(SFO_SFO, FOCUS_2006_D, quiet = TRUE)
#' round(mkinerrmin(fit_FOCUS_D), 4)
#' \dontrun{
#'   fit_FOCUS_E = mkinfit(SFO_SFO, FOCUS_2006_E, quiet = TRUE)
#'   round(mkinerrmin(fit_FOCUS_E), 4)
#' }
#'
#' @export
mkinerrmin <- function(fit, alpha = 0.05)
{
  parms.optim <- fit$par

  kinerrmin <- function(errdata, n.parms) {
    means.mean <- mean(errdata$observed, na.rm = TRUE)
    df = nrow(errdata) - n.parms

    err.min <- sqrt((1 / qchisq(1 - alpha, df)) *
               sum((errdata$observed - errdata$predicted)^2)/(means.mean^2))

    return(list(err.min = err.min, n.optim = n.parms, df = df))
  }

  errdata <- aggregate(cbind(observed, predicted) ~ time + variable, data = fit$data, mean, na.rm=TRUE)
  errdata <- errdata[order(errdata$time, errdata$variable), ]

  # Remove values at time zero for variables whose value for state.ini is fixed,
  # as these will not have any effect in the optimization and should therefore not
  # be counted as degrees of freedom.
  fixed_initials = gsub("_0$", "", rownames(subset(fit$fixed, type == "state")))
  errdata <- subset(errdata, !(time == 0 & variable %in% fixed_initials))

  n.optim.overall <- length(parms.optim) - length(fit$errparms)

  errmin.overall <- kinerrmin(errdata, n.optim.overall)
  errmin <- data.frame(err.min = errmin.overall$err.min,
    n.optim = errmin.overall$n.optim, df = errmin.overall$df)
  rownames(errmin) <- "All data"

  # The degrees of freedom are counted according to FOCUS kinetics (2011, p. 164)
  for (obs_var in fit$obs_vars)
  {
    errdata.var <- subset(errdata, variable == obs_var)

    # Check if initial value is optimised
    n.initials.optim <- length(grep(paste(obs_var, ".*", "_0", sep=""), names(parms.optim)))

    # Rate constants and IORE exponents are attributed to the source variable
    n.k.optim <- length(grep(paste("^k", obs_var, sep="_"), names(parms.optim)))
    n.k.optim <- n.k.optim + length(grep(paste("^log_k", obs_var, sep="_"),
                                         names(parms.optim)))
    n.k__iore.optim <- length(grep(paste("^k__iore", obs_var, sep="_"), names(parms.optim)))
    n.k__iore.optim <- n.k__iore.optim + length(grep(paste("^log_k__iore",
          obs_var, sep = "_"), names(parms.optim)))

    n.N.optim <- length(grep(paste("^N", obs_var, sep="_"), names(parms.optim)))

    n.ff.optim <- 0
    # Formation fractions are attributed to the target variable, so look
    # for source compartments with formation fractions
    for (source_var in fit$obs_vars) {
      n.ff.source = length(grep(paste("^f", source_var, sep = "_"),
                                 names(parms.optim)))
      n.paths.source = length(fit$mkinmod$spec[[source_var]]$to)
      for (target_var in fit$mkinmod$spec[[source_var]]$to) {
        if (obs_var == target_var) {
          n.ff.optim <- n.ff.optim + n.ff.source/n.paths.source
        }
      }
    }

    n.optim <- sum(n.initials.optim, n.k.optim, n.k__iore.optim, n.N.optim, n.ff.optim)

    # FOMC, DFOP and HS parameters are only counted if we are looking at the
    # first variable in the model which is always the source variable
    if (obs_var == fit$obs_vars[[1]]) {
      special_parms = c("alpha", "log_alpha", "beta", "log_beta",
                        "k1", "log_k1", "k2", "log_k2",
                        "g", "g_ilr", "g_qlogis", "tb", "log_tb")
      n.optim <- n.optim + length(intersect(special_parms, names(parms.optim)))
    }

    # Calculate and add a line to the dataframe holding the results
    errmin.tmp <- kinerrmin(errdata.var, n.optim)
    errmin[obs_var, c("err.min", "n.optim", "df")] <- errmin.tmp
  }

  return(errmin)
}

#' Extract residuals from an mkinfit model
#'
#' @param object A \code{\link{mkinfit}} object
#' @param standardized Should the residuals be standardized by dividing by the
#'   standard deviation obtained from the fitted error model?
#' @param \dots Not used
#' @export
#' @examples
#' f <- mkinfit("DFOP", FOCUS_2006_C, quiet = TRUE)
#' residuals(f)
#' residuals(f, standardized = TRUE)
residuals.mkinfit <- function(object, standardized = FALSE, ...) {
  res <- object$data[["residual"]]
  if (standardized) {
    if (object$err_mod == "const") {
      sigma_fitted <- object$errparms["sigma"]
    }
    if (object$err_mod == "obs") {
      sigma_names = paste0("sigma_", object$data[["variable"]])
      sigma_fitted <- object$errparms[sigma_names]
    }
    if (object$err_mod == "tc") {
      sigma_fitted <- sigma_twocomp(object$data[["predicted"]],
        sigma_low = object$errparms[1],
        rsd_high = object$errparms[2])
    }
    return(res / sigma_fitted)
  }
  return(res)
}


#' Calculate the AIC for a column of an mmkin object
#'
#' Provides a convenient way to compare different kinetic models fitted to the
#' same dataset.
#'
#' @importFrom stats AIC BIC
#' @param object An object of class \code{\link{mmkin}}, containing only one
#'   column.
#' @param \dots For compatibility with the generic method
#' @param k As in the generic method
#' @return As in the generic method (a numeric value for single fits, or a
#'   dataframe if there are several fits in the column).
#' @author Johannes Ranke
#' @examples
#'
#'   \dontrun{ # skip, as it takes > 10 s on winbuilder
#'   f <- mmkin(c("SFO", "FOMC", "DFOP"),
#'     list("FOCUS A" = FOCUS_2006_A,
#'          "FOCUS C" = FOCUS_2006_C), cores = 1, quiet = TRUE)
#'   # We get a warning because the FOMC model does not converge for the
#'   # FOCUS A dataset, as it is well described by SFO
#'
#'   AIC(f["SFO", "FOCUS A"]) # We get a single number for a single fit
#'   AIC(f[["SFO", "FOCUS A"]]) # or when extracting an mkinfit object
#'
#'   # For FOCUS A, the models fit almost equally well, so the higher the number
#'   # of parameters, the higher (worse) the AIC
#'   AIC(f[, "FOCUS A"])
#'   AIC(f[, "FOCUS A"], k = 0) # If we do not penalize additional parameters, we get nearly the same
#'   BIC(f[, "FOCUS A"])        # Comparing the BIC gives a very similar picture
#'
#'   # For FOCUS C, the more complex models fit better
#'   AIC(f[, "FOCUS C"])
#'   BIC(f[, "FOCUS C"])
#'   }
#'
#' @export
AIC.mmkin <- function(object, ..., k = 2)
{
  # We can only handle a single column
  if (ncol(object) != 1) stop("Please provide a single column object")
  n.fits <- length(object)
  model_names <- rownames(object)

  code <- paste0("AIC(",
    paste0("object[[", 1:n.fits, "]]", collapse = ", "),
    ", k = k)")
  res <- eval(parse(text = code))
  if (n.fits > 1) rownames(res) <- model_names
  return(res)
}

#' @rdname AIC.mmkin
#' @export
BIC.mmkin <- function(object, ...)
{
  # We can only handle a single column
  if (ncol(object) != 1) stop("Please provide a single column object")
  n.fits <- length(object)
  model_names <- rownames(object)

  code <- paste0("BIC(",
    paste0("object[[", 1:n.fits, "]]", collapse = ", "),
    ")")
  res <- eval(parse(text = code))
  if (n.fits > 1) rownames(res) <- model_names
  return(res)
}

#' @importFrom nlme intervals
#' @export
nlme::intervals

#' Confidence intervals for parameters in saem.mmkin objects
#'
#' @param object The fitted saem.mmkin object
#' @param level The confidence level. Must be the default of 0.95 as this is what
#'   is available in the saemix object
#' @param backtransform In case the model was fitted with mkin transformations,
#'  should we backtransform the parameters where a one to one correlation
#'  between transformed and backtransformed parameters exists?
#' @param \dots For compatibility with the generic method
#' @return An object with 'intervals.saem.mmkin' and 'intervals.lme' in the
#'  class attribute
#' @export
intervals.saem.mmkin <- function(object, level = 0.95, backtransform = TRUE, ...)
{
  if (!identical(level, 0.95)) {
    stop("Confidence intervals are only available for a level of 95%")
  }

  mod_vars <- names(object$mkinmod$diffs)

  pnames <- names(object$mean_dp_start)

  # Confidence intervals are available in the SaemixObject, so
  # we just need to extract them and put them into a list modelled
  # after the result of nlme::intervals.lme

  conf.int <- object$so@results@conf.int
  rownames(conf.int) <- conf.int$name
  colnames(conf.int)[2] <- "est."
  confint_trans <- as.matrix(conf.int[pnames, c("lower", "est.", "upper")])

  # Fixed effects
  # In case objects were produced by earlier versions of saem
  if (is.null(object$transformations)) object$transformations <- "mkin"

  if (object$transformations == "mkin" & backtransform) {
    bp <- backtransform_odeparms(confint_trans[, "est."], object$mkinmod,
      object$transform_rates, object$transform_fractions)
    bpnames <- names(bp)

    # Transform boundaries of CI for one parameter at a time,
    # with the exception of sets of formation fractions (single fractions are OK).
    f_names_skip <- character(0)
    for (box in mod_vars) { # Figure out sets of fractions to skip
      f_names <- grep(paste("^f", box, sep = "_"), pnames, value = TRUE)
      n_paths <- length(f_names)
      if (n_paths > 1) f_names_skip <- c(f_names_skip, f_names)
    }

    confint_back <- matrix(NA, nrow = length(bp), ncol = 3,
      dimnames = list(bpnames, colnames(confint_trans)))
    confint_back[, "est."] <- bp

    for (pname in pnames) {
      if (!pname %in% f_names_skip) {
        par.lower <- confint_trans[pname, "lower"]
        par.upper <- confint_trans[pname, "upper"]
        names(par.lower) <- names(par.upper) <- pname
        bpl <- backtransform_odeparms(par.lower, object$mkinmod,
                                              object$transform_rates,
                                              object$transform_fractions)
        bpu <- backtransform_odeparms(par.upper, object$mkinmod,
                                              object$transform_rates,
                                              object$transform_fractions)
        confint_back[names(bpl), "lower"] <- bpl
        confint_back[names(bpu), "upper"] <- bpu
      }
    }
    confint_ret <- confint_back
  } else {
    confint_ret <- confint_trans
  }
  attr(confint_ret, "label") <- "Fixed effects:"

  # Random effects
  sdnames <- intersect(rownames(conf.int), paste("SD", pnames, sep = "."))
  corrnames <- grep("^Corr.", rownames(conf.int), value = TRUE)
  ranef_ret <- as.matrix(conf.int[c(sdnames, corrnames), c("lower", "est.", "upper")])
  sdnames_ret <- paste0(gsub("SD\\.", "sd(", sdnames), ")")
  corrnames_ret <- gsub("Corr\\.(.*)\\.(.*)", "corr(\\1,\\2)", corrnames)
  rownames(ranef_ret) <- c(sdnames_ret, corrnames_ret)

  attr(ranef_ret, "label") <- "Random effects:"


  # Error model
  enames <- if (object$err_mod == "const") "a.1" else c("a.1", "b.1")
  err_ret <- as.matrix(conf.int[enames, c("lower", "est.", "upper")])

  res <- list(
    fixed = confint_ret,
    random = ranef_ret,
    errmod = err_ret
  )
  class(res) <- c("intervals.saemix.mmkin", "intervals.lme")
  attr(res, "level") <- level
  return(res)
}

#' 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
}

#' Confidence intervals for parameters of mkinfit objects
#'
#' The default method 'quadratic' is based on the quadratic approximation of
#' the curvature of the likelihood function at the maximum likelihood parameter
#' estimates.
#' The alternative method 'profile' is based on the profile likelihood for each
#' parameter. The 'profile' method uses two nested optimisations and can take a
#' very long time, even if parallelized by specifying 'cores' on unixoid
#' platforms. The speed of the method could likely be improved by using the
#' method of Venzon and Moolgavkar (1988).
#'
#' @param object An \code{\link{mkinfit}} object
#' @param parm A vector of names of the parameters which are to be given
#'   confidence intervals. If missing, all parameters are considered.
#' @param level The confidence level required
#' @param alpha The allowed error probability, overrides 'level' if specified.
#' @param cutoff Possibility to specify an alternative cutoff for the difference
#'   in the log-likelihoods at the confidence boundary. Specifying an explicit
#'   cutoff value overrides arguments 'level' and 'alpha'
#' @param method The 'quadratic' method approximates the likelihood function at
#'   the optimised parameters using the second term of the Taylor expansion,
#'   using a second derivative (hessian) contained in the object.
#'   The 'profile' method searches the parameter space for the
#'   cutoff of the confidence intervals by means of a likelihood ratio test.
#' @param transformed If the quadratic approximation is used, should it be
#'   applied to the likelihood based on the transformed parameters?
#' @param backtransform If we approximate the likelihood in terms of the
#'   transformed parameters, should we backtransform the parameters with
#'   their confidence intervals?
#' @param rel_tol If the method is 'profile', what should be the accuracy
#'   of the lower and upper bounds, relative to the estimate obtained from
#'   the quadratic method?
#' @param cores The number of cores to be used for multicore processing.
#'   On Windows machines, cores > 1 is currently not supported.
#' @param quiet Should we suppress the message "Profiling the likelihood"
#' @return A matrix with columns giving lower and upper confidence limits for
#'   each parameter.
#' @param \dots Not used
#' @importFrom stats qnorm
#' @references
#'   Bates DM and Watts GW (1988) Nonlinear regression analysis & its applications
#'
#'   Pawitan Y (2013) In all likelihood - Statistical modelling and
#'   inference using likelihood. Clarendon Press, Oxford.
#'
#'   Venzon DJ and Moolgavkar SH (1988) A Method for Computing
#'   Profile-Likelihood Based Confidence Intervals, Applied Statistics, 37,
#'   87–94.
#' @examples
#' f <- mkinfit("SFO", FOCUS_2006_C, quiet = TRUE)
#' confint(f, method = "quadratic")
#'
#' \dontrun{
#' confint(f, method = "profile")
#'
#' # Set the number of cores for the profiling method for further examples
#' if (identical(Sys.getenv("NOT_CRAN"), "true")) {
#'   n_cores <- parallel::detectCores() - 1
#' } else {
#'   n_cores <- 1
#' }
#' if (Sys.getenv("TRAVIS") != "") n_cores = 1
#' if (Sys.info()["sysname"] == "Windows") n_cores = 1
#'
#' SFO_SFO <- mkinmod(parent = mkinsub("SFO", "m1"), m1 = mkinsub("SFO"),
#'   use_of_ff = "min", quiet = TRUE)
#' SFO_SFO.ff <- mkinmod(parent = mkinsub("SFO", "m1"), m1 = mkinsub("SFO"),
#'   use_of_ff = "max", quiet = TRUE)
#' f_d_1 <- mkinfit(SFO_SFO, subset(FOCUS_2006_D, value != 0), quiet = TRUE)
#' system.time(ci_profile <- confint(f_d_1, method = "profile", cores = 1, quiet = TRUE))
#' # Using more cores does not save much time here, as parent_0 takes up most of the time
#' # If we additionally exclude parent_0 (the confidence of which is often of
#' # minor interest), we get a nice performance improvement if we use at least 4 cores
#' system.time(ci_profile_no_parent_0 <- confint(f_d_1, method = "profile",
#'   c("k_parent_sink", "k_parent_m1", "k_m1_sink", "sigma"), cores = n_cores))
#' ci_profile
#' ci_quadratic_transformed <- confint(f_d_1, method = "quadratic")
#' ci_quadratic_transformed
#' ci_quadratic_untransformed <- confint(f_d_1, method = "quadratic", transformed = FALSE)
#' ci_quadratic_untransformed
#' # Against the expectation based on Bates and Watts (1988), the confidence
#' # intervals based on the internal parameter transformation are less
#' # congruent with the likelihood based intervals. Note the superiority of the
#' # interval based on the untransformed fit for k_m1_sink
#' rel_diffs_transformed <- abs((ci_quadratic_transformed - ci_profile)/ci_profile)
#' rel_diffs_untransformed <- abs((ci_quadratic_untransformed - ci_profile)/ci_profile)
#' rel_diffs_transformed < rel_diffs_untransformed
#' signif(rel_diffs_transformed, 3)
#' signif(rel_diffs_untransformed, 3)
#'
#'
#' # Investigate a case with formation fractions
#' f_d_2 <- mkinfit(SFO_SFO.ff, subset(FOCUS_2006_D, value != 0), quiet = TRUE)
#' ci_profile_ff <- confint(f_d_2, method = "profile", cores = n_cores)
#' ci_profile_ff
#' ci_quadratic_transformed_ff <- confint(f_d_2, method = "quadratic")
#' ci_quadratic_transformed_ff
#' ci_quadratic_untransformed_ff <- confint(f_d_2, method = "quadratic", transformed = FALSE)
#' ci_quadratic_untransformed_ff
#' rel_diffs_transformed_ff <- abs((ci_quadratic_transformed_ff - ci_profile_ff)/ci_profile_ff)
#' rel_diffs_untransformed_ff <- abs((ci_quadratic_untransformed_ff - ci_profile_ff)/ci_profile_ff)
#' # While the confidence interval for the parent rate constant is closer to
#' # the profile based interval when using the internal parameter
#' # transformation, the interval for the metabolite rate constant is 'better
#' # without internal parameter transformation.
#' rel_diffs_transformed_ff < rel_diffs_untransformed_ff
#' rel_diffs_transformed_ff
#' rel_diffs_untransformed_ff
#'
#' # The profiling for the following fit does not finish in a reasonable time,
#' # therefore we use the quadratic approximation
#' m_synth_DFOP_par <- mkinmod(parent = mkinsub("DFOP", c("M1", "M2")),
#'   M1 = mkinsub("SFO"),
#'   M2 = mkinsub("SFO"),
#'   use_of_ff = "max", quiet = TRUE)
#' DFOP_par_c <- synthetic_data_for_UBA_2014[[12]]$data
#' f_tc_2 <- mkinfit(m_synth_DFOP_par, DFOP_par_c, error_model = "tc",
#'   error_model_algorithm = "direct", quiet = TRUE)
#' confint(f_tc_2, method = "quadratic")
#' confint(f_tc_2, "parent_0", method = "quadratic")
#' }
#' @export
confint.mkinfit <- function(object, parm,
  level = 0.95, alpha = 1 - level, cutoff,
  method = c("quadratic", "profile"),
  transformed = TRUE, backtransform = TRUE,
  cores = parallel::detectCores(), rel_tol = 0.01, quiet = FALSE, ...)
{
  tparms <- parms(object, transformed = TRUE)
  bparms <- parms(object, transformed = FALSE)
  tpnames <- names(tparms)
  bpnames <- names(bparms)

  return_pnames <- if (missing(parm)) {
    if (backtransform) bpnames else tpnames
  } else {
    parm
  }

  p <- length(return_pnames)

  method <- match.arg(method)

  a <- c(alpha / 2, 1 - (alpha / 2))

  quantiles <- qt(a, object$df.residual)

  covar_pnames <- if (missing(parm)) {
    if (transformed) tpnames else bpnames
  } else {
    parm
  }

  return_parms <- if (backtransform) bparms[return_pnames]
    else tparms[return_pnames]

  covar_parms <- if (transformed) tparms[covar_pnames]
    else bparms[covar_pnames]

  if (transformed) {
    covar <- try(solve(object$hessian), silent = TRUE)
  } else {
    covar <- try(solve(object$hessian_notrans), silent = TRUE)
  }

  # If inverting the covariance matrix failed or produced NA values
  if (!is.numeric(covar) | is.na(covar[1])) {
    ses <- lci <- uci <- rep(NA, p)
  } else {
    ses     <- sqrt(diag(covar))[covar_pnames]
    lci    <- covar_parms + quantiles[1] * ses
    uci    <- covar_parms + quantiles[2] * ses
    if (transformed & backtransform) {
      lci_back <- backtransform_odeparms(lci,
        object$mkinmod, object$transform_rates, object$transform_fractions)
      uci_back <- backtransform_odeparms(uci,
        object$mkinmod, object$transform_rates, object$transform_fractions)

      return_errparm_names <- intersect(names(object$errparms), return_pnames)
      lci <- c(lci_back, lci[return_errparm_names])
      uci <- c(uci_back, uci[return_errparm_names])
    }
  }
  ci <- cbind(lower = lci, upper = uci)

  if (method == "profile") {

    ci_quadratic <- ci

    if (!quiet) message("Profiling the likelihood")

    lci <- uci <- rep(NA, p)
    names(lci) <- names(uci) <- return_pnames

    profile_pnames <- if(missing(parm)) names(parms(object))
      else parm

    if (missing(cutoff)) {
      cutoff <- 0.5 * qchisq(1 - alpha, 1)
    }

    all_parms <- parms(object)

    get_ci <- function(pname) {
      pnames_free <- setdiff(names(all_parms), pname)
      profile_ll <- function(x)
      {
        pll_cost <- function(P) {
          parms_cost <- all_parms
          parms_cost[pnames_free] <- P[pnames_free]
          parms_cost[pname] <- x
          - object$ll(parms_cost)
        }
        - nlminb(all_parms[pnames_free], pll_cost)$objective
      }

      cost <- function(x) {
        (cutoff - (object$logLik - profile_ll(x)))^2
      }

      lower_quadratic <- ci_quadratic["lower"][pname]
      upper_quadratic <- ci_quadratic["upper"][pname]
      ltol <- if (!is.na(lower_quadratic)) rel_tol * lower_quadratic else .Machine$double.eps^0.25
      utol <- if (!is.na(upper_quadratic)) rel_tol * upper_quadratic else .Machine$double.eps^0.25
      lci_pname <- optimize(cost, lower = 0, upper = all_parms[pname], tol = ltol)$minimum
      uci_pname <- optimize(cost, lower = all_parms[pname],
        upper = ifelse(grepl("^f_|^g$", pname), 1, 15 * all_parms[pname]),
        tol = utol)$minimum
      return(c(lci_pname, uci_pname))
    }
    ci <- t(parallel::mcmapply(get_ci, profile_pnames, mc.cores = cores))
  }

  colnames(ci) <- paste0(
    format(100 * a, trim = TRUE, scientific = FALSE, digits = 3), "%")

  return(ci)
}

#' Set non-detects and unquantified values in residue series without replicates
#'
#' This function automates replacing unquantified values in residue time and
#' depth series. For time series, the function performs part of the residue
#' processing proposed in the FOCUS kinetics guidance for parent compounds
#' and metabolites. For two-dimensional residue series over time and depth,
#' it automates the proposal of Boesten et al (2015).
#'
#' @param res_raw Character vector of a residue time series, or matrix of
#' residue values with rows representing depth profiles for a specific sampling
#' time, and columns representing time series of residues at the same depth.
#' Values below the limit of detection (lod) have to be coded as "nd", values
#' between the limit of detection and the limit of quantification, if any, have
#' to be coded as "nq". Samples not analysed have to be coded as "na". All
#' values that are not "na", "nd" or "nq" have to be coercible to numeric
#' @param lod Limit of detection (numeric)
#' @param loq Limit of quantification(numeric). Must be specified if the FOCUS rule to
#' stop after the first non-detection is to be applied
#' @param time_zero_presence Do we assume that residues occur at time zero?
#' This only affects samples from the first sampling time that have been
#' reported as "nd" (not detected).
#' @references Boesten, J. J. T. I., van der Linden, A. M. A., Beltman, W. H.
#' J. and Pol, J. W. (2015). Leaching of plant protection products and their
#' transformation products; Proposals for improving the assessment of leaching
#' to groundwater in the Netherlands — Version 2. Alterra report 2630, Alterra
#' Wageningen UR (University & Research centre)
#' @references FOCUS (2014) Generic Guidance for Estimating Persistence and Degradation
#'   Kinetics from Environmental Fate Studies on Pesticides in EU Registration, Version 1.1,
#'   18 December 2014, p. 251
#' @return A numeric vector, if a vector was supplied, or a numeric matrix otherwise
#' @export
#' @examples
#' # FOCUS (2014) p. 75/76 and 131/132
#' parent_1 <- c(.12, .09, .05, .03, "nd", "nd", "nd", "nd", "nd", "nd")
#' set_nd_nq(parent_1, 0.02)
#' parent_2 <- c(.12, .09, .05, .03, "nd", "nd", .03, "nd", "nd", "nd")
#' set_nd_nq(parent_2, 0.02)
#' set_nd_nq_focus(parent_2, 0.02, loq = 0.05)
#' parent_3 <- c(.12, .09, .05, .03, "nd", "nd", .06, "nd", "nd", "nd")
#' set_nd_nq(parent_3, 0.02)
#' set_nd_nq_focus(parent_3, 0.02, loq = 0.05)
#' metabolite <- c("nd", "nd", "nd", 0.03, 0.06, 0.10, 0.11, 0.10, 0.09, 0.05, 0.03, "nd", "nd")
#' set_nd_nq(metabolite, 0.02)
#' set_nd_nq_focus(metabolite, 0.02, 0.05)
#' #
#' # Boesten et al. (2015), p. 57/58
#' table_8 <- matrix(
#'   c(10, 10, rep("nd", 4),
#'     10, 10, rep("nq", 2), rep("nd", 2),
#'     10, 10, 10, "nq", "nd", "nd",
#'     "nq", 10, "nq", rep("nd", 3),
#'     "nd", "nq", "nq", rep("nd", 3),
#'     rep("nd", 6), rep("nd", 6)),
#'   ncol = 6, byrow = TRUE)
#' set_nd_nq(table_8, 0.5, 1.5, time_zero_presence = TRUE)
#' table_10 <- matrix(
#'   c(10, 10, rep("nd", 4),
#'     10, 10, rep("nd", 4),
#'     10, 10, 10, rep("nd", 3),
#'     "nd", 10, rep("nd", 4),
#'     rep("nd", 18)),
#'   ncol = 6, byrow = TRUE)
#' set_nd_nq(table_10, 0.5, time_zero_presence = TRUE)
set_nd_nq <- function(res_raw, lod, loq = NA, time_zero_presence = FALSE) {
  if (!is.character(res_raw)) {
    stop("Please supply a vector or a matrix of character values")
  }
  if (is.vector(res_raw)) {
    was_vector <- TRUE
    res_raw <- as.matrix(res_raw)
  } else {
    was_vector <- FALSE
    if (!is.matrix(res_raw)) {
      stop("Please supply a vector or a matrix of character values")
    }
  }
  nq <- 0.5 * (loq + lod)
  nda <- 0.5 * lod # not detected but adjacent to detection
  res_raw[res_raw == "nq"] <- nq

  if (!time_zero_presence) {
    for (j in 1:ncol(res_raw)) {
      if (res_raw[1, j] == "nd") res_raw[1, j] <- "na"
    }
  }
  res_raw[res_raw == "na"] <- NA

  not_nd_na <- function(value) !(grepl("nd", value) | is.na(value))

  for (i in 1:nrow(res_raw)) {
    for (j in 1:ncol(res_raw)) {
      if (!is.na(res_raw[i, j]) && res_raw[i, j] == "nd") {
        if (i > 1) { # check earlier sample in same layer
          if (not_nd_na(res_raw[i - 1, j])) res_raw[i, j] <- "nda"
        }
        if (i < nrow(res_raw)) { # check later sample
          if (not_nd_na(res_raw[i + 1, j])) res_raw[i, j] <- "nda"
        }
        if (j > 1) { # check above sample at the same time
          if (not_nd_na(res_raw[i, j - 1])) res_raw[i, j] <- "nda"
        }
        if (j < ncol(res_raw)) { # check sample below at the same time
          if (not_nd_na(res_raw[i, j + 1])) res_raw[i, j] <- "nda"
        }
      }
    }
  }
  res_raw[res_raw == "nda"] <- nda
  res_raw[res_raw == "nd"] <- NA

  result <- as.numeric(res_raw)
  dim(result) <- dim(res_raw)
  dimnames(result) <- dimnames(res_raw)
  if (was_vector) result <- as.vector(result)
  return(result)
}

#' @describeIn set_nd_nq Set non-detects in residue time series according to FOCUS rules
#' @param set_first_sample_nd Should the first sample be set to "first_sample_nd_value"
#' in case it is a non-detection?
#' @param first_sample_nd_value Value to be used for the first sample if it is a non-detection
#' @param ignore_below_loq_after_first_nd Should we ignore values below the LOQ after the first
#' non-detection that occurs after the quantified values?
#' @export
set_nd_nq_focus <- function(res_raw, lod, loq = NA,
  set_first_sample_nd = TRUE, first_sample_nd_value = 0,
  ignore_below_loq_after_first_nd = TRUE)
{

  if (!is.vector(res_raw)) stop("FOCUS rules are only specified for one-dimensional time series")

  if (ignore_below_loq_after_first_nd & is.na(loq)) {
    stop("You need to specify an LOQ")
  }

  n <- length(res_raw)
  if (ignore_below_loq_after_first_nd) {
    for (i in 3:n) {
      if (!res_raw[i - 2] %in% c("na", "nd")) {
        if (res_raw[i - 1] == "nd") {
          res_remaining <- res_raw[i:n]
          res_remaining_unquantified <- ifelse(res_remaining == "na", TRUE,
            ifelse(res_remaining == "nd", TRUE,
              ifelse(res_remaining == "nq", TRUE,
                ifelse(suppressWarnings(as.numeric(res_remaining)) < loq, TRUE, FALSE))))
          res_remaining_numeric <- suppressWarnings(as.numeric(res_remaining))
          res_remaining_below_loq <- ifelse(res_remaining == "nq", TRUE,
                ifelse(!is.na(res_remaining_numeric) & res_remaining_numeric < loq, TRUE, FALSE))
          if (all(res_remaining_unquantified)) {
            res_raw[i:n] <- ifelse(res_remaining_below_loq, "nd", res_remaining)
          }
        }
      }
    }
  }

  result <- set_nd_nq(res_raw, lod = lod, loq = loq)

  if (set_first_sample_nd) {
    if (res_raw[1] == "nd") result[1] <- first_sample_nd_value
  }

  return(result)
}

#' Function to plot the confidence intervals obtained using mkinfit
#' 
#' This function plots the confidence intervals for the parameters fitted using
#' \code{\link{mkinfit}}.
#' 
#' @param object A fit represented in an \code{\link{mkinfit}} object.
#' @return Nothing is returned by this function, as it is called for its side
#'   effect, namely to produce a plot.
#' @author Johannes Ranke
#' @examples
#' 
#' \dontrun{
#' model <- mkinmod(
#'   T245 = mkinsub("SFO", to = c("phenol"), sink = FALSE),
#'   phenol = mkinsub("SFO", to = c("anisole")),
#'   anisole = mkinsub("SFO"), use_of_ff = "max")
#' fit <- mkinfit(model, subset(mccall81_245T, soil == "Commerce"), quiet = TRUE)
#' mkinparplot(fit)
#' }
#' @export
mkinparplot <- function(object) {
  state.optim = rownames(subset(object$start, type == "state"))
  deparms.optim = rownames(subset(object$start, type == "deparm"))
  fractions.optim = grep("^f_", deparms.optim, value = TRUE)
  N.optim = grep("^N_", deparms.optim, value = TRUE)
  if ("g" %in% deparms.optim) fractions.optim <- c("g", fractions.optim)
  rates.optim.unsorted = setdiff(deparms.optim, union(fractions.optim, N.optim))
  rates.optim <- rownames(object$start[rates.optim.unsorted, ])
  n.plot <- c(state.optim = length(state.optim),
              rates.optim = length(rates.optim),
	      N.optim = length(N.optim),
              fractions.optim = length(fractions.optim))
  n.plot <- n.plot[n.plot > 0]

  oldpar <- par(no.readonly = TRUE)
  on.exit(par(oldpar, no.readonly = TRUE))
  layout(matrix(1:length(n.plot), ncol = 1), heights = n.plot + 1)

  s <- summary(object)
  bpar <- data.frame(t(s$bpar[, c("Estimate", "Lower", "Upper")]))
  par(mar = c(2.1, 2.1, 0.1, 2.1))
  par(cex = 1)
  for (type in names(n.plot)) {
    parnames <- get(type)
    values <- bpar[parnames]
    values_with_confints <- data.frame(t(subset(data.frame(t(values)), !is.na("Lower"))))
    xlim = switch(type,
                  state.optim = range(c(0, unlist(values)),
                                      na.rm = TRUE, finite = TRUE),
                  rates.optim = range(c(0, unlist(values)),
                                      na.rm = TRUE, finite = TRUE),
                  N.optim = range(c(0, 1, unlist(values)),
                                      na.rm = TRUE, finite = TRUE),
                  fractions.optim = range(c(0, 1, unlist(values)),
                                          na.rm = TRUE, finite = TRUE))
    parname_index <- length(parnames):1 # Reverse order for strip chart

    stripchart(values["Estimate", ][parname_index],
               xlim = xlim,
               ylim = c(0.5, length(get(type)) + 0.5),
               yaxt = "n")
    if (type %in% c("rates.optim", "fractions.optim")) abline(v = 0, lty = 2)
    if (type %in% c("N.optim", "fractions.optim")) abline(v = 1, lty = 2)
    position <- ifelse(values["Estimate", ] < mean(xlim), "right", "left")
    text(ifelse(position == "left", min(xlim), max(xlim)),
         parname_index, parnames,
         pos = ifelse(position == "left", 4, 2))

    values.upper.nonInf <- ifelse(values["Upper", ] == Inf, 1.5 * xlim[[2]], values["Upper", ])
    # Suppress warnings for non-existing arrow lengths
    suppressWarnings(arrows(as.numeric(values["Lower", ]), parname_index,
	   as.numeric(values.upper.nonInf), parname_index,
	   code = 3, angle = 90, length = 0.05))
  }
}

#' Summary method for class "saem.mmkin"
#'
#' Lists model equations, initial parameter values, optimised parameters
#' for fixed effects (population), random effects (deviations from the
#' population mean) and residual error model, as well as the resulting
#' endpoints such as formation fractions and DT50 values. Optionally
#' (default is FALSE), the data are listed in full.
#'
#' @param object an object of class [saem.mmkin]
#' @param x an object of class [summary.saem.mmkin]
#' @param data logical, indicating whether the full data should be included in
#'   the summary.
#' @param verbose Should the summary be verbose?
#' @param distimes logical, indicating whether DT50 and DT90 values should be
#'   included.
#' @param digits Number of digits to use for printing
#' @param \dots optional arguments passed to methods like \code{print}.
#' @inheritParams endpoints
#' @return The summary function returns a list based on the [saemix::SaemixObject]
#'   obtained in the fit, with at least the following additional components
#'   \item{saemixversion, mkinversion, Rversion}{The saemix, mkin and R versions used}
#'   \item{date.fit, date.summary}{The dates where the fit and the summary were
#'     produced}
#'   \item{diffs}{The differential equations used in the degradation model}
#'   \item{use_of_ff}{Was maximum or minimum use made of formation fractions}
#'   \item{data}{The data}
#'   \item{confint_trans}{Transformed parameters as used in the optimisation, with confidence intervals}
#'   \item{confint_back}{Backtransformed parameters, with confidence intervals if available}
#'   \item{confint_errmod}{Error model parameters with confidence intervals}
#'   \item{ff}{The estimated formation fractions derived from the fitted
#'      model.}
#'   \item{distimes}{The DT50 and DT90 values for each observed variable.}
#'   \item{SFORB}{If applicable, eigenvalues of SFORB components of the model.}
#'   The print method is called for its side effect, i.e. printing the summary.
#' @importFrom stats predict vcov
#' @author Johannes Ranke for the mkin specific parts
#'   saemix authors for the parts inherited from saemix.
#' @examples
#' # Generate five datasets following DFOP-SFO kinetics
#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120)
#' dfop_sfo <- mkinmod(parent = mkinsub("DFOP", "m1"),
#'  m1 = mkinsub("SFO"), quiet = TRUE)
#' set.seed(1234)
#' k1_in <- rlnorm(5, log(0.1), 0.3)
#' k2_in <- rlnorm(5, log(0.02), 0.3)
#' g_in <- plogis(rnorm(5, qlogis(0.5), 0.3))
#' f_parent_to_m1_in <- plogis(rnorm(5, qlogis(0.3), 0.3))
#' k_m1_in <- rlnorm(5, log(0.02), 0.3)
#'
#' pred_dfop_sfo <- function(k1, k2, g, f_parent_to_m1, k_m1) {
#'   mkinpredict(dfop_sfo,
#'     c(k1 = k1, k2 = k2, g = g, f_parent_to_m1 = f_parent_to_m1, k_m1 = k_m1),
#'     c(parent = 100, m1 = 0),
#'     sampling_times)
#' }
#'
#' ds_mean_dfop_sfo <- lapply(1:5, function(i) {
#'   mkinpredict(dfop_sfo,
#'     c(k1 = k1_in[i], k2 = k2_in[i], g = g_in[i],
#'       f_parent_to_m1 = f_parent_to_m1_in[i], k_m1 = k_m1_in[i]),
#'     c(parent = 100, m1 = 0),
#'     sampling_times)
#' })
#' names(ds_mean_dfop_sfo) <- paste("ds", 1:5)
#'
#' ds_syn_dfop_sfo <- lapply(ds_mean_dfop_sfo, function(ds) {
#'   add_err(ds,
#'     sdfunc = function(value) sqrt(1^2 + value^2 * 0.07^2),
#'     n = 1)[[1]]
#' })
#'
#' \dontrun{
#' # Evaluate using mmkin and saem
#' f_mmkin_dfop_sfo <- mmkin(list(dfop_sfo), ds_syn_dfop_sfo,
#'   quiet = TRUE, error_model = "tc", cores = 5)
#' f_saem_dfop_sfo <- saem(f_mmkin_dfop_sfo)
#' print(f_saem_dfop_sfo)
#' illparms(f_saem_dfop_sfo)
#' f_saem_dfop_sfo_2 <- update(f_saem_dfop_sfo,
#'   no_random_effect = c("parent_0", "log_k_m1"))
#' illparms(f_saem_dfop_sfo_2)
#' intervals(f_saem_dfop_sfo_2)
#' summary(f_saem_dfop_sfo_2, data = TRUE)
#' # Add a correlation between random effects of g and k2
#' cov_model_3 <- f_saem_dfop_sfo_2$so@model@covariance.model
#' cov_model_3["log_k2", "g_qlogis"] <- 1
#' cov_model_3["g_qlogis", "log_k2"] <- 1
#' f_saem_dfop_sfo_3 <- update(f_saem_dfop_sfo,
#'   covariance.model = cov_model_3)
#' intervals(f_saem_dfop_sfo_3)
#' # The correlation does not improve the fit judged by AIC and BIC, although
#' # the likelihood is higher with the additional parameter
#' anova(f_saem_dfop_sfo, f_saem_dfop_sfo_2, f_saem_dfop_sfo_3)
#' }
#'
#' @export
summary.saem.mmkin <- function(object, data = FALSE, verbose = FALSE,
  covariates = NULL, covariate_quantile = 0.5,
  distimes = TRUE, ...) {

  mod_vars <- names(object$mkinmod$diffs)

  pnames <- names(object$mean_dp_start)
  names_fixed_effects <- object$so@results@name.fixed
  n_fixed <- length(names_fixed_effects)

  conf.int <- object$so@results@conf.int
  rownames(conf.int) <- conf.int$name
  confint_trans <- as.matrix(parms(object, ci = TRUE))
  colnames(confint_trans)[1] <- "est."

  # In case objects were produced by earlier versions of saem
  if (is.null(object$transformations)) object$transformations <- "mkin"

  if (object$transformations == "mkin") {
    bp <- backtransform_odeparms(confint_trans[pnames, "est."], object$mkinmod,
      object$transform_rates, object$transform_fractions)
    bpnames <- names(bp)

    # Transform boundaries of CI for one parameter at a time,
    # with the exception of sets of formation fractions (single fractions are OK).
    f_names_skip <- character(0)
    for (box in mod_vars) { # Figure out sets of fractions to skip
      f_names <- grep(paste("^f", box, sep = "_"), pnames, value = TRUE)
      n_paths <- length(f_names)
      if (n_paths > 1) f_names_skip <- c(f_names_skip, f_names)
    }

    confint_back <- matrix(NA, nrow = length(bp), ncol = 3,
      dimnames = list(bpnames, colnames(confint_trans)))
    confint_back[, "est."] <- bp

    for (pname in pnames) {
      if (!pname %in% f_names_skip) {
        par.lower <- confint_trans[pname, "lower"]
        par.upper <- confint_trans[pname, "upper"]
        names(par.lower) <- names(par.upper) <- pname
        bpl <- backtransform_odeparms(par.lower, object$mkinmod,
                                              object$transform_rates,
                                              object$transform_fractions)
        bpu <- backtransform_odeparms(par.upper, object$mkinmod,
                                              object$transform_rates,
                                              object$transform_fractions)
        confint_back[names(bpl), "lower"] <- bpl
        confint_back[names(bpu), "upper"] <- bpu
      }
    }
  } else {
    confint_back <- confint_trans[names_fixed_effects, ]
  }

  #  Correlation of fixed effects (inspired by summary.nlme)
  cov_so <- try(solve(object$so@results@fim), silent = TRUE)
  if (inherits(cov_so, "try-error")) {
    object$corFixed <- NA
  } else {
    varFix <- cov_so[1:n_fixed, 1:n_fixed]
    stdFix <- sqrt(diag(varFix))
    object$corFixed <- array(
      t(varFix/stdFix)/stdFix,
      dim(varFix),
      list(names_fixed_effects, names_fixed_effects))
  }

  # Random effects
  sdnames <- intersect(rownames(conf.int), paste0("SD.", pnames))
  corrnames <- grep("^Corr.", rownames(conf.int), value = TRUE)
  confint_ranef <- as.matrix(conf.int[c(sdnames, corrnames), c("estimate", "lower", "upper")])
  colnames(confint_ranef)[1] <- "est."

  # Error model
  enames <- if (object$err_mod == "const") "a.1" else c("a.1", "b.1")
  confint_errmod <- as.matrix(conf.int[enames, c("estimate", "lower", "upper")])
  colnames(confint_errmod)[1] <- "est."

  object$confint_trans <- confint_trans
  object$confint_ranef <- confint_ranef
  object$confint_errmod <- confint_errmod
  object$confint_back <- confint_back

  object$date.summary = date()
  object$use_of_ff = object$mkinmod$use_of_ff
  object$error_model_algorithm = object$mmkin_orig[[1]]$error_model_algorithm
  err_mod = object$mmkin_orig[[1]]$err_mod

  object$diffs <- object$mkinmod$diffs
  object$print_data <- data # boolean: Should we print the data?
  so_pred <- object$so@results@predictions

  names(object$data)[4] <- "observed" # rename value to observed

  object$verbose <- verbose

  object$fixed <- object$mmkin_orig[[1]]$fixed
  ll <-try(logLik(object$so, method = "is"), silent = TRUE)
  if (inherits(ll, "try-error")) {
    object$logLik <- object$AIC <- object $BIC <- NA
  } else {
    object$logLik = logLik(object$so, method = "is")
    object$AIC = AIC(object$so)
    object$BIC = BIC(object$so)
  }

  ep <- endpoints(object)
  object$covariates <- ep$covariates
  if (length(ep$ff) != 0)
    object$ff <- ep$ff
  if (distimes) object$distimes <- ep$distimes
  if (length(ep$SFORB) != 0) object$SFORB <- ep$SFORB
  class(object) <- c("summary.saem.mmkin")
  return(object)
}

#' @rdname summary.saem.mmkin
#' @export
print.summary.saem.mmkin <- function(x, digits = max(3, getOption("digits") - 3), verbose = x$verbose, ...) {
  cat("saemix version used for fitting:     ", x$saemixversion, "\n")
  cat("mkin version used for pre-fitting: ", x$mkinversion, "\n")
  cat("R version used for fitting:        ", x$Rversion, "\n")

  cat("Date of fit:    ", x$date.fit, "\n")
  cat("Date of summary:", x$date.summary, "\n")

  cat("\nEquations:\n")
  nice_diffs <- gsub("^(d.*) =", "\\1/dt =", x[["diffs"]])
  writeLines(strwrap(nice_diffs, exdent = 11))

  cat("\nData:\n")
  cat(nrow(x$data), "observations of",
    length(unique(x$data$name)), "variable(s) grouped in",
    length(unique(x$data$ds)), "datasets\n")

  cat("\nModel predictions using solution type", x$solution_type, "\n")

  cat("\nFitted in", x$time[["elapsed"]],  "s\n")
  cat("Using", paste(x$so@options$nbiter.saemix, collapse = ", "),
    "iterations and", x$so@options$nb.chains, "chains\n")

  cat("\nVariance model: ")
  cat(switch(x$err_mod,
    const = "Constant variance",
    obs = "Variance unique to each observed variable",
    tc = "Two-component variance function"), "\n")

  cat("\nStarting values for degradation parameters:\n")
  print(x$mean_dp_start, digits = digits)

  cat("\nFixed degradation parameter values:\n")
  if(length(x$fixed$value) == 0) cat("None\n")
  else print(x$fixed, digits = digits)

  cat("\nStarting values for random effects (square root of initial entries in omega):\n")
  print(sqrt(x$so@model@omega.init), digits = digits)

  cat("\nStarting values for error model parameters:\n")
  errparms <- x$so@model@error.init
  names(errparms) <- x$so@model@name.sigma
  errparms <- errparms[x$so@model@indx.res]
  print(errparms, digits = digits)

  cat("\nResults:\n\n")
  cat("Likelihood computed by importance sampling\n")
  print(data.frame(AIC = x$AIC, BIC = x$BIC, logLik = x$logLik,
      row.names = " "), digits = digits)

  cat("\nOptimised parameters:\n")
  print(x$confint_trans, digits = digits)

  if (identical(x$corFixed, NA)) {
    cat("\nCorrelation is not available\n")
  } else {
    corr <- x$corFixed
    class(corr) <- "correlation"
    print(corr, title = "\nCorrelation:", rdig = digits, ...)
  }

  cat("\nRandom effects:\n")
  print(x$confint_ranef, digits = digits)

  cat("\nVariance model:\n")
  print(x$confint_errmod, digits = digits)

  if (x$transformations == "mkin") {
    cat("\nBacktransformed parameters:\n")
    print(x$confint_back, digits = digits)
  }

  if (!is.null(x$covariates)) {
    cat("\nCovariates used for endpoints below:\n")
    print(x$covariates)
  }

  printSFORB <- !is.null(x$SFORB)
  if(printSFORB){
    cat("\nEstimated Eigenvalues of SFORB model(s):\n")
    print(x$SFORB, digits = digits,...)
  }

  printff <- !is.null(x$ff)
  if(printff){
    cat("\nResulting formation fractions:\n")
    print(data.frame(ff = x$ff), digits = digits,...)
  }

  printdistimes <- !is.null(x$distimes)
  if(printdistimes){
    cat("\nEstimated disappearance times:\n")
    print(x$distimes, digits = digits,...)
  }

  if (x$print_data){
    cat("\nData:\n")
    print(format(x$data, digits = digits, ...), row.names = FALSE)
  }

  invisible(x)
}

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

#' Convert a dataframe from long to wide format
#' 
#' This function takes a dataframe in the long form, i.e. with a row for each
#' observed value, and converts it into a dataframe with one independent
#' variable and several dependent variables as columns.
#' 
#' @param long_data The dataframe must contain one variable called "time" with
#'   the time values specified by the \code{time} argument, one column called
#'   "name" with the grouping of the observed values, and finally one column of
#'   observed values called "value".
#' @param time The name of the time variable in the long input data.
#' @param outtime The name of the time variable in the wide output data.
#' @return Dataframe in wide format.
#' @author Johannes Ranke
#' @examples
#' 
#' mkin_long_to_wide(FOCUS_2006_D)
#' 
#' @export mkin_long_to_wide
mkin_long_to_wide <- function(long_data, time = "time", outtime = "time")
{
  colnames <- unique(long_data$name)
  wide_data <- data.frame(time = subset(long_data, name == colnames[1], time))
  names(wide_data) <- outtime
  for (var in colnames) {
    wide_data[var] <- subset(long_data, name == var, value)
  }
  return(wide_data)
}

#' Lack-of-fit test for models fitted to data with replicates
#'
#' This is a generic function with a method currently only defined for mkinfit
#' objects. It fits an anova model to the data contained in the object and
#' compares the likelihoods using the likelihood ratio test
#' \code{\link[lmtest]{lrtest.default}} from the lmtest package.
#'
#' The anova model is interpreted as the simplest form of an mkinfit model,
#' assuming only a constant variance about the means, but not enforcing any
#' structure of the means, so we have one model parameter for every mean
#' of replicate samples.
#'
#' @param object A model object with a defined loftest method
#' @param \dots Not used
#' @export
loftest <- function(object, ...) {
  UseMethod("loftest")
}

#' @rdname loftest
#' @importFrom stats logLik lm dnorm coef
#' @seealso lrtest
#' @examples
#' \dontrun{
#' test_data <- subset(synthetic_data_for_UBA_2014[[12]]$data, name == "parent")
#' sfo_fit <- mkinfit("SFO", test_data, quiet = TRUE)
#' plot_res(sfo_fit) # We see a clear pattern in the residuals
#' loftest(sfo_fit)  # We have a clear lack of fit
#' #
#' # We try a different model (the one that was used to generate the data)
#' dfop_fit <- mkinfit("DFOP", test_data, quiet = TRUE)
#' plot_res(dfop_fit) # We don't see systematic deviations, but heteroscedastic residuals
#' # therefore we should consider adapting the error model, although we have
#' loftest(dfop_fit) # no lack of fit
#' #
#' # This is the anova model used internally for the comparison
#' test_data_anova <- test_data
#' test_data_anova$time <- as.factor(test_data_anova$time)
#' anova_fit <- lm(value ~ time, data = test_data_anova)
#' summary(anova_fit)
#' logLik(anova_fit) # We get the same likelihood and degrees of freedom
#' #
#' test_data_2 <- synthetic_data_for_UBA_2014[[12]]$data
#' m_synth_SFO_lin <- mkinmod(parent = list(type = "SFO", to = "M1"),
#'   M1 = list(type = "SFO", to = "M2"),
#'   M2 = list(type = "SFO"), use_of_ff = "max")
#' sfo_lin_fit <- mkinfit(m_synth_SFO_lin, test_data_2, quiet = TRUE)
#' plot_res(sfo_lin_fit) # not a good model, we try parallel formation
#' loftest(sfo_lin_fit)
#' #
#' m_synth_SFO_par <- mkinmod(parent = list(type = "SFO", to = c("M1", "M2")),
#'   M1 = list(type = "SFO"),
#'   M2 = list(type = "SFO"), use_of_ff = "max")
#' sfo_par_fit <- mkinfit(m_synth_SFO_par, test_data_2, quiet = TRUE)
#' plot_res(sfo_par_fit) # much better for metabolites
#' loftest(sfo_par_fit)
#' #
#' m_synth_DFOP_par <- mkinmod(parent = list(type = "DFOP", to = c("M1", "M2")),
#'   M1 = list(type = "SFO"),
#'   M2 = list(type = "SFO"), use_of_ff = "max")
#' dfop_par_fit <- mkinfit(m_synth_DFOP_par, test_data_2, quiet = TRUE)
#' plot_res(dfop_par_fit) # No visual lack of fit
#' loftest(dfop_par_fit)  # no lack of fit found by the test
#' #
#' # The anova model used for comparison in the case of transformation products
#' test_data_anova_2 <- dfop_par_fit$data
#' test_data_anova_2$variable <- as.factor(test_data_anova_2$variable)
#' test_data_anova_2$time <- as.factor(test_data_anova_2$time)
#' anova_fit_2 <- lm(observed ~ time:variable - 1, data = test_data_anova_2)
#' summary(anova_fit_2)
#' }
#' @export
loftest.mkinfit <- function(object, ...) {

  name_function <- function(x) {
    object_name <- paste(x$mkinmod$name, "with error model", x$err_mod)
    if (length(x$bparms.fixed) > 0) {
      object_name <- paste(object_name,
        "and fixed parameter(s)",
        paste(names(x$bparms.fixed), collapse = ", "))
    }
    return(object_name)
  }

  # Check if we have replicates in the data
  if (max(aggregate(object$data$observed,
    by = list(object$data$variable, object$data$time), length)$x) == 1) {
    stop("Not defined for fits to data without replicates")
  }

  data_anova <- object$data
  data_anova$time <- as.factor(data_anova$time)
  data_anova$variable <- as.factor(data_anova$variable)
  if (nlevels(data_anova$variable) == 1) {
    object_2 <- lm(observed ~ time - 1, data = data_anova)
  } else {
    object_2 <- lm(observed ~ variable:time - 1,
      data = data_anova)
  }

  object_2$mkinmod <- list(name = "ANOVA")
  object_2$err_mod <- "const"
  sigma_mle <- sqrt(sum(residuals(object_2)^2)/nobs(object_2))
  object_2$logLik <- sum(dnorm(x = object_2$residuals,
      mean = 0, sd = sigma_mle, log = TRUE))
  object_2$data <- object$data # to make the nobs.mkinfit method work
  object_2$bparms.optim <- coef(object_2)
  object_2$errparms <- 1 # We have estimated one error model parameter
  class(object_2) <- "mkinfit"

  lmtest::lrtest.default(object_2, object, name = name_function)
}

#' Add normally distributed errors to simulated kinetic degradation data
#' 
#' Normally distributed errors are added to data predicted for a specific
#' degradation model using \code{\link{mkinpredict}}. The variance of the error
#' may depend on the predicted value and is specified as a standard deviation.
#' 
#' @param prediction A prediction from a kinetic model as produced by
#'   \code{\link{mkinpredict}}.
#' @param sdfunc A function taking the predicted value as its only argument and
#'   returning a standard deviation that should be used for generating the
#'   random error terms for this value.
#' @param secondary The names of state variables that should have an initial
#'   value of zero
#' @param n The number of datasets to be generated.
#' @param LOD The limit of detection (LOD). Values that are below the LOD after
#'   adding the random error will be set to NA.
#' @param reps The number of replicates to be generated within the datasets.
#' @param digits The number of digits to which the values will be rounded.
#' @param seed The seed used for the generation of random numbers. If NA, the
#'   seed is not set.
#' @importFrom stats rnorm
#' @return A list of datasets compatible with \code{\link{mmkin}}, i.e. the
#'   components of the list are datasets compatible with \code{\link{mkinfit}}.
#' @author Johannes Ranke
#' @references Ranke J and Lehmann R (2015) To t-test or not to t-test, that is
#' the question. XV Symposium on Pesticide Chemistry 2-4 September 2015,
#' Piacenza, Italy
#' https://jrwb.de/posters/piacenza_2015.pdf
#' @examples
#' 
#' # The kinetic model
#' m_SFO_SFO <- mkinmod(parent = mkinsub("SFO", "M1"),
#'                      M1 = mkinsub("SFO"), use_of_ff = "max")
#' 
#' # Generate a prediction for a specific set of parameters
#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120)
#' 
#' # This is the prediction used for the "Type 2 datasets" on the Piacenza poster
#' # from 2015
#' d_SFO_SFO <- mkinpredict(m_SFO_SFO,
#'                          c(k_parent = 0.1, f_parent_to_M1 = 0.5,
#'                            k_M1 = log(2)/1000),
#'                          c(parent = 100, M1 = 0),
#'                          sampling_times)
#' 
#' # Add an error term with a constant (independent of the value) standard deviation
#' # of 10, and generate three datasets
#' d_SFO_SFO_err <- add_err(d_SFO_SFO, function(x) 10, n = 3, seed = 123456789 )
#' 
#' # Name the datasets for nicer plotting
#' names(d_SFO_SFO_err) <- paste("Dataset", 1:3)
#' 
#' # Name the model in the list of models (with only one member in this case) for
#' # nicer plotting later on.  Be quiet and use only one core not to offend CRAN
#' # checks
#' \dontrun{
#' f_SFO_SFO <- mmkin(list("SFO-SFO" = m_SFO_SFO),
#'                    d_SFO_SFO_err, cores = 1,
#'                    quiet = TRUE)
#' 
#' plot(f_SFO_SFO)
#' 
#' # We would like to inspect the fit for dataset 3 more closely
#' # Using double brackets makes the returned object an mkinfit object
#' # instead of a list of mkinfit objects, so plot.mkinfit is used
#' plot(f_SFO_SFO[[3]], show_residuals = TRUE)
#' 
#' # If we use single brackets, we should give two indices (model and dataset),
#' # and plot.mmkin is used
#' plot(f_SFO_SFO[1, 3])
#' }
#' 
#' @export
add_err <- function(prediction, sdfunc, secondary = c("M1", "M2"),
  n = 10, LOD = 0.1, reps = 2, digits = 1, seed = NA)
{
  if (!is.na(seed)) set.seed(seed)

  prediction <- as.data.frame(prediction)

  # The output of mkinpredict is in wide format
  d_long = mkin_wide_to_long(prediction, time = "time")

  # Set up the list to be returned
  d_return = list()

  # Generate datasets one by one in a loop
  for (i in 1:n) {
    d_rep = data.frame(lapply(d_long, rep, each = reps))
    d_rep$value = rnorm(length(d_rep$value), d_rep$value, sdfunc(d_rep$value))

    d_rep[d_rep$time == 0 & d_rep$name %in% secondary, "value"] <- 0

    # Set values below the LOD to NA
    d_NA <- transform(d_rep, value = ifelse(value < LOD, NA, value))

    # Round the values for convenience
    d_NA$value <- round(d_NA$value, digits)

    d_return[[i]] <- d_NA
  }

  return(d_return)
}

utils::globalVariables(c("name", "time", "value"))

#' Convert a dataframe with observations over time into long format
#' 
#' This function simply takes a dataframe with one independent variable and
#' several dependent variable and converts it into the long form as required by
#' \code{\link{mkinfit}}.
#' 
#' @param wide_data The dataframe must contain one variable with the time
#'   values specified by the \code{time} argument and usually more than one
#'   column of observed values.
#' @param time The name of the time variable.
#' @return Dataframe in long format as needed for \code{\link{mkinfit}}.
#' @author Johannes Ranke
#' @keywords manip
#' @examples
#' 
#' wide <- data.frame(t = c(1,2,3), x = c(1,4,7), y = c(3,4,5))
#' mkin_wide_to_long(wide)
#' 
#' @export
mkin_wide_to_long <- function(wide_data, time = "t")
{
  wide_data <- as.data.frame(wide_data)
  colnames <- names(wide_data)
  if (!(time %in% colnames)) stop("The data in wide format have to contain a variable named ", time, ".")
  vars <- subset(colnames, colnames != time)
  n <- length(colnames) - 1
  long_data <- data.frame(
    name = rep(vars, each = length(wide_data[[time]])),
    time = as.numeric(rep(wide_data[[time]], n)),
    value = as.numeric(unlist(wide_data[vars])),
    row.names = NULL)
  return(long_data)
}

#' Single First-Order kinetics
#'
#' Function describing exponential decline from a defined starting value.
#'
#' @family parent solutions
#' @param t Time.
#' @param parent_0 Starting value for the response variable at time zero.
#' @param k Kinetic rate constant.
#' @return The value of the response variable at time \code{t}.
#' @references
#' FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence
#'   and Degradation Kinetics from Environmental Fate Studies on Pesticides in
#'   EU Registration} Report of the FOCUS Work Group on Degradation Kinetics,
#'   EC Document Reference Sanco/10058/2005 version 2.0, 434 pp,
#'   \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics}
#' FOCUS (2014) \dQuote{Generic guidance for Estimating Persistence
#'   and Degradation Kinetics from Environmental Fate Studies on Pesticides in
#'   EU Registration} Report of the FOCUS Work Group on Degradation Kinetics,
#'   Version 1.1, 18 December 2014
#'   \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics}
#' @examples
#'
#'   \dontrun{plot(function(x) SFO.solution(x, 100, 3), 0, 2)}
#'
#' @export
SFO.solution <- function(t, parent_0, k)
{
  parent = parent_0 * exp(-k * t)
}

#' First-Order Multi-Compartment kinetics
#'
#' Function describing exponential decline from a defined starting value, with
#' a decreasing rate constant.
#'
#' The form given here differs slightly from the original reference by
#' Gustafson and Holden (1990). The parameter \code{beta} corresponds to 1/beta
#' in the original equation.
#'
#' @family parent solutions
#' @inherit SFO.solution
#' @param alpha Shape parameter determined by coefficient of variation of rate
#' constant values.
#' @param beta Location parameter.
#' @note The solution of the FOMC kinetic model reduces to the
#' \code{\link{SFO.solution}} for large values of \code{alpha} and \code{beta}
#' with \eqn{k = \frac{\beta}{\alpha}}{k = beta/alpha}.
#' @references
#' FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence
#'   and Degradation Kinetics from Environmental Fate Studies on Pesticides in
#'   EU Registration} Report of the FOCUS Work Group on Degradation Kinetics,
#'   EC Document Reference Sanco/10058/2005 version 2.0, 434 pp,
#'   \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics}
#'
#' FOCUS (2014) \dQuote{Generic guidance for Estimating Persistence
#'   and Degradation Kinetics from Environmental Fate Studies on Pesticides in
#'   EU Registration} Report of the FOCUS Work Group on Degradation Kinetics,
#'   Version 1.1, 18 December 2014
#'   \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics}
#'
#'   Gustafson DI and Holden LR (1990) Nonlinear pesticide dissipation in soil:
#'   A new model based on spatial variability. \emph{Environmental Science and
#'   Technology} \bold{24}, 1032-1038
#' @examples
#'
#'   plot(function(x) FOMC.solution(x, 100, 10, 2), 0, 2, ylim = c(0, 100))
#'
#' @export
FOMC.solution <- function(t, parent_0, alpha, beta)
{
  parent = parent_0 / (t/beta + 1)^alpha
}

#' Indeterminate order rate equation kinetics
#'
#' Function describing exponential decline from a defined starting value, with
#' a concentration dependent rate constant.
#'
#' @family parent solutions
#' @inherit SFO.solution
#' @param k__iore Rate constant. Note that this depends on the concentration
#' units used.
#' @param N Exponent describing the nonlinearity of the rate equation
#' @note The solution of the IORE kinetic model reduces to the
#' \code{\link{SFO.solution}} if N = 1.  The parameters of the IORE model can
#' be transformed to equivalent parameters of the FOMC mode - see the NAFTA
#' guidance for details.
#' @references NAFTA Technical Working Group on Pesticides (not dated) Guidance
#' for Evaluating and Calculating Degradation Kinetics in Environmental Media
#' @examples
#'
#'   plot(function(x) IORE.solution(x, 100, 0.2, 1.3), 0, 2, ylim = c(0, 100))
#'   \dontrun{
#'     fit.fomc <- mkinfit("FOMC", FOCUS_2006_C, quiet = TRUE)
#'     fit.iore <- mkinfit("IORE", FOCUS_2006_C, quiet = TRUE)
#'     fit.iore.deS <- mkinfit("IORE", FOCUS_2006_C, solution_type = "deSolve", quiet = TRUE)
#'
#'     print(data.frame(fit.fomc$par, fit.iore$par, fit.iore.deS$par,
#'                      row.names = paste("model par", 1:4)))
#'     print(rbind(fomc = endpoints(fit.fomc)$distimes, iore = endpoints(fit.iore)$distimes,
#'                 iore.deS = endpoints(fit.iore)$distimes))
#'   }
#'
#' @export
IORE.solution <- function(t, parent_0, k__iore, N)
{
  parent = (parent_0^(1 - N) - (1 - N) * k__iore * t)^(1/(1 - N))
}

#' Double First-Order in Parallel kinetics
#'
#' Function describing decline from a defined starting value using the sum of
#' two exponential decline functions.
#'
#' @family parent solutions
#' @inherit SFO.solution
#' @param t Time.
#' @param k1 First kinetic constant.
#' @param k2 Second kinetic constant.
#' @param g Fraction of the starting value declining according to the first
#' kinetic constant.
#' @examples
#'
#'   plot(function(x) DFOP.solution(x, 100, 5, 0.5, 0.3), 0, 4, ylim = c(0,100))
#'
#' @export
DFOP.solution <- function(t, parent_0, k1, k2, g)
{
  parent = g * parent_0 * exp(-k1 * t) +
     (1 - g) * parent_0 * exp(-k2 * t)
}

#' Hockey-Stick kinetics
#'
#' Function describing two exponential decline functions with a break point
#' between them.
#'
#' @family parent solutions
#' @inherit DFOP.solution
#' @param tb Break point. Before this time, exponential decline according to
#' \code{k1} is calculated, after this time, exponential decline proceeds
#' according to \code{k2}.
#' @examples
#'
#'   plot(function(x) HS.solution(x, 100, 2, 0.3, 0.5), 0, 2, ylim=c(0,100))
#'
#' @export
HS.solution <- function(t, parent_0, k1, k2, tb)
{
  parent = ifelse(t <= tb,
    parent_0 * exp(-k1 * t),
    parent_0 * exp(-k1 * tb) * exp(-k2 * (t - tb)))
}

#' Single First-Order Reversible Binding kinetics
#'
#' Function describing the solution of the differential equations describing
#' the kinetic model with first-order terms for a two-way transfer from a free
#' to a bound fraction, and a first-order degradation term for the free
#' fraction.  The initial condition is a defined amount in the free fraction
#' and no substance in the bound fraction.
#'
#' @family parent solutions
#' @inherit SFO.solution
#' @param k_12 Kinetic constant describing transfer from free to bound.
#' @param k_21 Kinetic constant describing transfer from bound to free.
#' @param k_1output Kinetic constant describing degradation of the free
#' fraction.
#' @return The value of the response variable, which is the sum of free and
#' bound fractions at time \code{t}.
#' @examples
#'
#'   \dontrun{plot(function(x) SFORB.solution(x, 100, 0.5, 2, 3), 0, 2)}
#'
#' @export
SFORB.solution = function(t, parent_0, k_12, k_21, k_1output) {
  sqrt_exp = sqrt(1/4 * (k_12 + k_21 + k_1output)^2 - k_1output * k_21)
  b1 = 0.5 * (k_12 + k_21 + k_1output) + sqrt_exp
  b2 = 0.5 * (k_12 + k_21 + k_1output) - sqrt_exp

  parent = parent_0 *
        (((k_12 + k_21 - b1)/(b2 - b1)) * exp(-b1 * t) +
        ((k_12 + k_21 - b2)/(b1 - b2)) * exp(-b2 * t))
}

#' Logistic kinetics
#'
#' Function describing exponential decline from a defined starting value, with
#' an increasing rate constant, supposedly caused by microbial growth
#'
#' @family parent solutions
#' @inherit SFO.solution
#' @param kmax Maximum rate constant.
#' @param k0 Minimum rate constant effective at time zero.
#' @param r Growth rate of the increase in the rate constant.
#' @note The solution of the logistic model reduces to the
#' \code{\link{SFO.solution}} if \code{k0} is equal to \code{kmax}.
#' @examples
#'
#'   # Reproduce the plot on page 57 of FOCUS (2014)
#'   plot(function(x) logistic.solution(x, 100, 0.08, 0.0001, 0.2),
#'        from = 0, to = 100, ylim = c(0, 100),
#'        xlab = "Time", ylab = "Residue")
#'   plot(function(x) logistic.solution(x, 100, 0.08, 0.0001, 0.4),
#'        from = 0, to = 100, add = TRUE, lty = 2, col = 2)
#'   plot(function(x) logistic.solution(x, 100, 0.08, 0.0001, 0.8),
#'        from = 0, to = 100, add = TRUE, lty = 3, col = 3)
#'   plot(function(x) logistic.solution(x, 100, 0.08, 0.001, 0.2),
#'        from = 0, to = 100, add = TRUE, lty = 4, col = 4)
#'   plot(function(x) logistic.solution(x, 100, 0.08, 0.08, 0.2),
#'        from = 0, to = 100, add = TRUE, lty = 5, col = 5)
#'   legend("topright", inset = 0.05,
#'          legend = paste0("k0 = ", c(0.0001, 0.0001, 0.0001, 0.001, 0.08),
#'                          ", r = ", c(0.2, 0.4, 0.8, 0.2, 0.2)),
#'          lty = 1:5, col = 1:5)
#'
#'   # Fit with synthetic data
#'   logistic <- mkinmod(parent = mkinsub("logistic"))
#'
#'   sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120)
#'   parms_logistic <- c(kmax = 0.08, k0 = 0.0001, r = 0.2)
#'   d_logistic <- mkinpredict(logistic,
#'     parms_logistic, c(parent = 100),
#'     sampling_times)
#'   d_2_1 <- add_err(d_logistic,
#'     sdfunc = function(x) sigma_twocomp(x, 0.5, 0.07),
#'     n = 1, reps = 2, digits = 5, LOD = 0.1, seed = 123456)[[1]]
#'
#'   m <- mkinfit("logistic", d_2_1, quiet = TRUE)
#'   plot_sep(m)
#'   summary(m)$bpar
#'   endpoints(m)$distimes
#'
#' @export
logistic.solution <- function(t, parent_0, kmax, k0, r)
{
  parent = parent_0 * (kmax / (kmax - k0 + k0 * exp (r * t))) ^(kmax/r)
}

#' Plot the distribution of log likelihoods from multistart objects
#'
#' Produces a histogram of log-likelihoods. In addition, the likelihood of the
#' original fit is shown as a red vertical line.
#'
#' @param object The [multistart] object
#' @param breaks Passed to [hist]
#' @param lpos Positioning of the legend.
#' @param main Title of the plot
#' @param \dots Passed to [hist]
#' @seealso [multistart]
#' @export
llhist <- function(object, breaks = "Sturges", lpos = "topleft", main = "",
  ...)
{
  oldpar <- par(no.readonly = TRUE)
  on.exit(par(oldpar, no.readonly = TRUE))

  if (inherits(object, "multistart.saem.mmkin")) {
    llfunc <- function(object) {
      if (inherits(object$so, "try-error")) return(NA)
      else return(logLik(object$so))
    }
  } else {
    stop("llhist is only implemented for multistart.saem.mmkin objects")
  }

  ll_orig <- logLik(attr(object, "orig"))
  ll <- stats::na.omit(sapply(object, llfunc))

  par(las = 1)
  h <- hist(ll, freq = TRUE,
    xlab = "", main = main,
    ylab = "Frequency of log likelihoods", breaks = breaks, ...)

  freq_factor <- h$counts[1] / h$density[1]

  abline(v = ll_orig, col = 2)

  legend(lpos, inset = c(0.05, 0.05), bty = "n",
    lty = 1, col = c(2),
    legend = "original fit")
}

#' Calculated the log-likelihood of a fitted mkinfit object
#'
#' This function returns the product of the likelihood densities of each
#' observed value, as calculated as part of the fitting procedure using
#' \code{\link{dnorm}}, i.e. assuming normal distribution, and with the means
#' predicted by the degradation model, and the standard deviations predicted by
#' the error model.
#'
#' The total number of estimated parameters returned with the value of the
#' likelihood is calculated as the sum of fitted degradation model parameters
#' and the fitted error model parameters.
#'
#' @param object An object of class \code{\link{mkinfit}}.
#' @param \dots For compatibility with the generic method
#' @return An object of class \code{\link{logLik}} with the number of estimated
#'   parameters (degradation model parameters plus variance model parameters)
#'   as attribute.
#' @author Johannes Ranke
#' @seealso Compare the AIC of columns of \code{\link{mmkin}} objects using
#'   \code{\link{AIC.mmkin}}.
#' @examples
#'
#'   \dontrun{
#'   sfo_sfo <- mkinmod(
#'     parent = mkinsub("SFO", to = "m1"),
#'     m1 = mkinsub("SFO")
#'   )
#'   d_t <- subset(FOCUS_2006_D, value != 0)
#'   f_nw <- mkinfit(sfo_sfo, d_t, quiet = TRUE) # no weighting (weights are unity)
#'   f_obs <- update(f_nw, error_model = "obs")
#'   f_tc <- update(f_nw, error_model = "tc")
#'   AIC(f_nw, f_obs, f_tc)
#'   }
#'
#' @export
logLik.mkinfit <- function(object, ...) {
  val <- object$logLik
  # Number of estimated parameters
  attr(val, "df") <- length(object$bparms.optim) + length(object$errparms)
  attr(val, "nobs") <- nobs(object)
  class(val) <- "logLik"
  return(val)
}

- -

#' Two-component error model
#'
#' Function describing the standard deviation of the measurement error in
#' dependence of the measured value \eqn{y}:
#'
#' \deqn{\sigma = \sqrt{ \sigma_{low}^2 + y^2 * {rsd}_{high}^2}} sigma =
#' sqrt(sigma_low^2 + y^2 * rsd_high^2)
#'
#' This is the error model used for example by Werner et al. (1978). The model
#' proposed by Rocke and Lorenzato (1995) can be written in this form as well,
#' but assumes approximate lognormal distribution of errors for high values of
#' y.
#'
#' @param y The magnitude of the observed value
#' @param sigma_low The asymptotic minimum of the standard deviation for low
#'   observed values
#' @param rsd_high The coefficient describing the increase of the standard
#'   deviation with the magnitude of the observed value
#' @return The standard deviation of the response variable.
#' @references Werner, Mario, Brooks, Samuel H., and Knott, Lancaster B. (1978)
#'   Additive, Multiplicative, and Mixed Analytical Errors. Clinical Chemistry
#'   24(11), 1895-1898.
#'
#'   Rocke, David M. and Lorenzato, Stefan (1995) A two-component model for
#'   measurement error in analytical chemistry. Technometrics 37(2), 176-184.
#'
#'   Ranke J and Meinecke S (2019) Error Models for the Kinetic Evaluation of Chemical
#'   Degradation Data. *Environments* 6(12) 124
#'   \doi{10.3390/environments6120124}.
#'
#' @examples
#' times <- c(0, 1, 3, 7, 14, 28, 60, 90, 120)
#' d_pred <- data.frame(time = times, parent = 100 * exp(- 0.03 * times))
#' set.seed(123456)
#' d_syn <- add_err(d_pred, function(y) sigma_twocomp(y, 1, 0.07),
#'   reps = 2, n = 1)[[1]]
#' f_nls <- nls(value ~ SSasymp(time, 0, parent_0, lrc), data = d_syn,
#'  start = list(parent_0 = 100, lrc = -3))
#' library(nlme)
#' f_gnls <- gnls(value ~ SSasymp(time, 0, parent_0, lrc),
#'   data = d_syn, na.action = na.omit,
#'   start = list(parent_0 = 100, lrc = -3))
#' if (length(findFunction("varConstProp")) > 0) {
#'   f_gnls_tc <- update(f_gnls, weights = varConstProp())
#'   f_gnls_tc_sf <- update(f_gnls_tc, control = list(sigma = 1))
#' }
#' f_mkin <- mkinfit("SFO", d_syn, error_model = "const", quiet = TRUE)
#' f_mkin_tc <- mkinfit("SFO", d_syn, error_model = "tc", quiet = TRUE)
#' plot_res(f_mkin_tc, standardized = TRUE)
#' AIC(f_nls, f_gnls, f_gnls_tc, f_gnls_tc_sf, f_mkin, f_mkin_tc)
#' @export
sigma_twocomp <- function(y, sigma_low, rsd_high) {
  sqrt(sigma_low^2 + y^2 * rsd_high^2)
}

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

#' @rdname mkinmod
#' @param submodel Character vector of length one to specify the submodel type.
#'   See \code{\link{mkinmod}} for the list of allowed submodel names.
#' @param to Vector of the names of the state variable to which a
#'   transformation shall be included in the model.
#' @param sink Should a pathway to sink be included in the model in addition to
#'   the pathways to other state variables?
#' @param full_name An optional name to be used e.g. for plotting fits
#'   performed with the model.  You can use non-ASCII characters here, but then
#'   your R code will not be portable, \emph{i.e.} may produce unintended plot
#'   results on other operating systems or system configurations.
#' @return A list for use with \code{\link{mkinmod}}.
#' @export
mkinsub <- function(submodel, to = NULL, sink = TRUE, full_name = NA)
{
  return(list(type = submodel, to = to, sink = sink, full_name = full_name))
}

- -

1		- #' Method to get status information for fit array objects -
2		- #' -
3		- #' @param object The object to investigate -
4		- #' @param x The object to be printed -
5		- #' @param \dots For potential future extensions -
6		- #' @return An object with the same dimensions as the fit array -
7		- #' suitable printing method. -
8		- #' @export -
9		- status <- function(object, ...) -
10		- { -
11	589x	- UseMethod("status", object) -
12		- } -
13		- -
14		- #' @rdname status -
15		- #' @export -
16		- #' @examples -
17		- #' \dontrun{ -
18		- #' fits <- mmkin( -
19		- #' c("SFO", "FOMC"), -
20		- #' list("FOCUS A" = FOCUS_2006_A, -
21		- #' "FOCUS B" = FOCUS_2006_C), -
22		- #' quiet = TRUE) -
23		- #' status(fits) -
24		- #' } -
25		- status.mmkin <- function(object, ...) { -
26	376x	- all_summary_warnings <- character() -
27	376x	- sww <- 0 # Counter for Shapiro-Wilks warnings -
28		- -
29	376x	- result <- lapply(object, -
30	376x	- function(fit) { -
31	!	- if (inherits(fit, "try-error")) return("E") -
32	4391x	- sw <- fit$summary_warnings -
33	4391x	- swn <- names(sw) -
34	4391x	- if (length(sw) > 0) { -
35	!	- if (any(grepl("S", swn))) { -
36	!	- sww <<- sww + 1 -
37	!	- swn <- gsub("S", paste0("S", sww), swn) -
38		- } -
39	!	- warnstring <- paste(swn, collapse = ", ") -
40	!	- names(sw) <- swn -
41	!	- all_summary_warnings <<- c(all_summary_warnings, sw) -
42	!	- return(warnstring) -
43		- } else { -
44	4391x	- return("OK") -
45		- } -
46		- }) -
47	376x	- result <- unlist(result) -
48	376x	- dim(result) <- dim(object) -
49	376x	- dimnames(result) <- dimnames(object) -
50		- -
51	376x	- u_swn <- unique(names(all_summary_warnings)) -
52	376x	- attr(result, "unique_warnings") <- all_summary_warnings[u_swn] -
53	376x	- class(result) <- "status.mmkin" -
54	376x	- return(result) -
55		- } -
56		- -
57		- #' @rdname status -
58		- #' @export -
59		- print.status.mmkin <- function(x, ...) { -
60	376x	- u_w <- attr(x, "unique_warnings") -
61	376x	- attr(x, "unique_warnings") <- NULL -
62	376x	- class(x) <- NULL -
63	376x	- print(x, quote = FALSE) -
64	376x	- cat("\n") -
65	376x	- for (i in seq_along(u_w)) { -
66	!	- cat(names(u_w)[i], ": ", u_w[i], "\n", sep = "") -
67		- } -
68	376x	- if (any(x == "OK")) cat("OK: No warnings\n") -
69	!	- if (any(x == "E")) cat("E: Error\n") -
70		- } -
71		- -
72		- #' @rdname status -
73		- #' @export -
74		- status.mhmkin <- function(object, ...) { -
75	125x	- if (inherits(object[[1]], "saem.mmkin")) { -
76	125x	- test_func <- function(fit) { -
77	500x	- if (inherits(fit, "try-error")) { -
78	!	- return("E") -
79		- } else { -
80	500x	- if (inherits(fit$so, "try-error")) { -
81	!	- return("E") -
82		- } else { -
83	500x	- if (!is.null(fit$FIM_failed)) { -
84	!	- return_values <- c("fixed effects" = "Fth", -
85	!	- "random effects and error model parameters" = "FO") -
86	!	- return(paste(return_values[fit$FIM_failed], collapse = ", ")) -
87		- } else { -
88	500x	- return("OK") -
89		- } -
90		- } -
91		- } -
92		- } -
93		- } else { -
94	!	- stop("Only mhmkin objects containing saem.mmkin objects currently supported") -
95		- } -
96	125x	- result <- lapply(object, test_func) -
97	125x	- result <- unlist(result) -
98	125x	- dim(result) <- dim(object) -
99	125x	- dimnames(result) <- dimnames(object) -
100		- -
101	125x	- class(result) <- "status.mhmkin" -
102	125x	- return(result) -
103		- } -
104		- -
105		- #' @rdname status -
106		- #' @export -
107		- print.status.mhmkin <- function(x, ...) { -
108	125x	- class(x) <- NULL -
109	125x	- print(x, quote = FALSE) -
110	125x	- cat("\n") -
111	125x	- if (any(x == "OK")) cat("OK: Fit terminated successfully\n") -
112	!	- if (any(x == "Fth")) cat("Fth: Could not invert FIM for fixed effects\n") -
113	!	- if (any(x == "FO")) cat("FO: Could not invert FIM for random effects and error model parameters\n") -
114	!	- if (any(x == "Fth, FO")) cat("Fth, FO: Could not invert FIM for fixed effects, nor for random effects and error model parameters\n") -
115	!	- if (any(x == "E")) cat("E: Error\n") -
116		- } -
117		- -

1		- #' Evaluate parent kinetics using the NAFTA guidance -
2		- #' -
3		- #' The function fits the SFO, IORE and DFOP models using \code{\link{mmkin}} -
4		- #' and returns an object of class \code{nafta} that has methods for printing -
5		- #' and plotting. -
6		- #' -
7		- #' @param ds A dataframe that must contain one variable called "time" with the -
8		- #' time values specified by the \code{time} argument, one column called -
9		- #' "name" with the grouping of the observed values, and finally one column of -
10		- #' observed values called "value". -
11		- #' @param title Optional title of the dataset -
12		- #' @param quiet Should the evaluation text be shown? -
13		- #' @param \dots Further arguments passed to \code{\link{mmkin}} (not for the -
14		- #' printing method). -
15		- #' @importFrom stats qf -
16		- #' @return An list of class \code{nafta}. The list element named "mmkin" is the -
17		- #' \code{\link{mmkin}} object containing the fits of the three models. The -
18		- #' list element named "title" contains the title of the dataset used. The -
19		- #' list element "data" contains the dataset used in the fits. -
20		- #' @author Johannes Ranke -
21		- #' @source NAFTA (2011) Guidance for evaluating and calculating degradation -
22		- #' kinetics in environmental media. NAFTA Technical Working Group on -
23		- #' Pesticides -
24		- #' \url{https://www.epa.gov/pesticide-science-and-assessing-pesticide-risks/guidance-evaluating-and-calculating-degradation} -
25		- #' accessed 2019-02-22 -
26		- #' -
27		- #' US EPA (2015) Standard Operating Procedure for Using the NAFTA Guidance to -
28		- #' Calculate Representative Half-life Values and Characterizing Pesticide -
29		- #' Degradation -
30		- #' \url{https://www.epa.gov/pesticide-science-and-assessing-pesticide-risks/standard-operating-procedure-using-nafta-guidance} -
31		- #' @examples -
32		- #' -
33		- #' nafta_evaluation <- nafta(NAFTA_SOP_Appendix_D, cores = 1) -
34		- #' print(nafta_evaluation) -
35		- #' plot(nafta_evaluation) -
36		- #' -
37		- #' @export -
38		- nafta <- function(ds, title = NA, quiet = FALSE, ...) { -
39	264x	- if (length(levels(ds$name)) > 1) { -
40	88x	- stop("The NAFTA procedure is only defined for decline data for a single compound") -
41		- } -
42	176x	- n <- nrow(subset(ds, !is.na(value))) -
43	176x	- models <- c("SFO", "IORE", "DFOP") -
44		- -
45	176x	- result <- list(title = title, data = ds) -
46	176x	- result$mmkin <- mmkin(models, list(ds), quiet = TRUE, ...) -
47		- -
48	176x	- distimes <- lapply(result$mmkin, function(x) as.numeric(endpoints(x)$distimes["parent", ])) -
49		- -
50	176x	- result$distimes <- matrix(NA, nrow = 3, ncol = 3, -
51	176x	- dimnames = list(models, c("DT50", "DT90", "DT50_rep"))) -
52	176x	- result$distimes["SFO", ] <- distimes[[1]][c(1, 2, 1)] -
53	176x	- result$distimes["IORE", ] <- distimes[[2]][c(1, 2, 3)] -
54	176x	- result$distimes["DFOP", ] <- distimes[[3]][c(1, 2, 5)] -
55		- -
56		- # Get parameters with statistics -
57	176x	- result$parameters <- lapply(result$mmkin, function(x) { -
58	528x	- summary(x)$bpar[, c(1, 4:6)] -
59		- }) -
60	176x	- names(result$parameters) <- models -
61		- -
62		- # Compare the sum of squared residuals (SSR) to the upper bound of the -
63		- # confidence region of the SSR for the IORE model -
64	176x	- result$S <- sapply(result$mmkin, function(x) sum(x$data$residual^2)) -
65	176x	- names(result$S) <- c("SFO", "IORE", "DFOP") -
66		- # Equation (3) on p. 3 -
67	176x	- p <- 3 -
68	176x	- result$S["IORE"] -
69	176x	- result$S_c <- result$S[["IORE"]] * (1 + p/(n - p) * qf(0.5, p, n - p)) -
70		- -
71	176x	- result$t_rep <- .evaluate_nafta_results(result$S, result$S_c, -
72	176x	- result$distimes, quiet = quiet) -
73		- -
74	176x	- class(result) <- "nafta" -
75	176x	- return(result) -
76		- } -
77		- -
78		- #' Plot the results of the three models used in the NAFTA scheme. -
79		- #' -
80		- #' The plots are ordered with increasing complexity of the model in this -
81		- #' function (SFO, then IORE, then DFOP). -
82		- #' -
83		- #' Calls \code{\link{plot.mmkin}}. -
84		- #' -
85		- #' @param x An object of class \code{\link{nafta}}. -
86		- #' @param legend Should a legend be added? -
87		- #' @param main Possibility to override the main title of the plot. -
88		- #' @param \dots Further arguments passed to \code{\link{plot.mmkin}}. -
89		- #' @return The function is called for its side effect. -
90		- #' @author Johannes Ranke -
91		- #' @export -
92		- plot.nafta <- function(x, legend = FALSE, main = "auto", ...) { -
93	176x	- if (main == "auto") { -
94	!	- if (is.na(x$title)) main = "" -
95	176x	- else main = x$title -
96		- } -
97	176x	- plot(x$mmkin, ..., legend = legend, main = main) -
98		- } -
99		- -
100		- #' Print nafta objects -
101		- #' -
102		- #' Print nafta objects. The results for the three models are printed in the -
103		- #' order of increasing model complexity, i.e. SFO, then IORE, and finally DFOP. -
104		- #' -
105		- #' @param x An \code{\link{nafta}} object. -
106		- #' @param digits Number of digits to be used for printing parameters and -
107		- #' dissipation times. -
108		- #' @rdname nafta -
109		- #' @export -
110		- print.nafta <- function(x, quiet = TRUE, digits = 3, ...) { -
111	176x	- cat("Sums of squares:\n") -
112	176x	- print(x$S) -
113	176x	- cat("\nCritical sum of squares for checking the SFO model:\n") -
114	176x	- print(x$S_c) -
115	176x	- cat("\nParameters:\n") -
116	176x	- print(x$parameters, digits = digits) -
117	176x	- t_rep <- .evaluate_nafta_results(x$S, x$S_c, x$distimes, quiet = quiet) -
118	176x	- cat("\nDTx values:\n") -
119	176x	- print(signif(x$distimes, digits = digits)) -
120	176x	- cat("\nRepresentative half-life:\n") -
121	176x	- print(round(t_rep, 2)) -
122		- } -
123		- -
124		- .evaluate_nafta_results <- function(S, S_c, distimes, quiet = FALSE) { -
125	352x	- t_SFO <- distimes["IORE", "DT50"] -
126	352x	- t_IORE <- distimes["IORE", "DT50_rep"] -
127	352x	- t_DFOP2 <- distimes["DFOP", "DT50_rep"] -
128		- -
129	352x	- if (S["SFO"] < S_c) { -
130	!	- if (!quiet) { -
131	!	- message("S_SFO is lower than the critical value S_c, use the SFO model") -
132		- } -
133	!	- t_rep <- t_SFO -
134		- } else { -
135	352x	- if (!quiet) { -
136	88x	- message("The SFO model is rejected as S_SFO is equal or higher than the critical value S_c") -
137		- } -
138	352x	- if (t_IORE < t_DFOP2) { -
139	176x	- if (!quiet) { -
140	88x	- message("The half-life obtained from the IORE model may be used") -
141		- } -
142	176x	- t_rep <- t_IORE -
143		- } else { -
144	176x	- if (!quiet) { -
145	!	- message("The representative half-life of the IORE model is longer than the one corresponding") -
146	!	- message("to the terminal degradation rate found with the DFOP model.") -
147	!	- message("The representative half-life obtained from the DFOP model may be used") -
148		- } -
149	176x	- t_rep <- t_DFOP2 -
150		- } -
151		- } -
152	352x	- return(t_rep) -
153		- } -

1		- utils::globalVariables(c("variable", "residual")) -
2		- -
3		- #' Function to plot squared residuals and the error model for an mkin object -
4		- #' -
5		- #' This function plots the squared residuals for the specified subset of the -
6		- #' observed variables from an mkinfit object. In addition, one or more dashed -
7		- #' line(s) show the fitted error model. A combined plot of the fitted model -
8		- #' and this error model plot can be obtained with \code{\link{plot.mkinfit}} -
9		- #' using the argument \code{show_errplot = TRUE}. -
10		- #' -
11		- #' @param object A fit represented in an \code{\link{mkinfit}} object. -
12		- #' @param obs_vars A character vector of names of the observed variables for -
13		- #' which residuals should be plotted. Defaults to all observed variables in -
14		- #' the model -
15		- #' @param xlim plot range in x direction. -
16		- #' @param xlab Label for the x axis. -
17		- #' @param ylab Label for the y axis. -
18		- #' @param maxy Maximum value of the residuals. This is used for the scaling of -
19		- #' the y axis and defaults to "auto". -
20		- #' @param legend Should a legend be plotted? -
21		- #' @param lpos Where should the legend be placed? Default is "topright". Will -
22		- #' be passed on to \code{\link{legend}}. -
23		- #' @param col_obs Colors for the observed variables. -
24		- #' @param pch_obs Symbols to be used for the observed variables. -
25		- #' @param frame Should a frame be drawn around the plots? -
26		- #' @param \dots further arguments passed to \code{\link{plot}}. -
27		- #' @return Nothing is returned by this function, as it is called for its side -
28		- #' effect, namely to produce a plot. -
29		- #' @author Johannes Ranke -
30		- #' @seealso \code{\link{mkinplot}}, for a way to plot the data and the fitted -
31		- #' lines of the mkinfit object. -
32		- #' @keywords hplot -
33		- #' @examples -
34		- #' -
35		- #' \dontrun{ -
36		- #' model <- mkinmod(parent = mkinsub("SFO", "m1"), m1 = mkinsub("SFO")) -
37		- #' fit <- mkinfit(model, FOCUS_2006_D, error_model = "tc", quiet = TRUE) -
38		- #' mkinerrplot(fit) -
39		- #' } -
40		- #' -
41		- #' @export -
42		- mkinerrplot <- function (object, -
43		- obs_vars = names(object$mkinmod$map), -
44		- xlim = c(0, 1.1 * max(object$data$predicted)), -
45		- xlab = "Predicted", ylab = "Squared residual", -
46		- maxy = "auto", legend= TRUE, lpos = "topright", -
47		- col_obs = "auto", pch_obs = "auto", -
48		- frame = TRUE, -
49		- ...) -
50		- { -
51	275x	- obs_vars_all <- as.character(unique(object$data$variable)) -
52		- -
53	275x	- if (length(obs_vars) > 0){ -
54	275x	- obs_vars <- intersect(obs_vars_all, obs_vars) -
55	!	- } else obs_vars <- obs_vars_all -
56		- -
57	275x	- residuals <- subset(object$data, variable %in% obs_vars, residual) -
58		- -
59	275x	- if (maxy == "auto") maxy = max(residuals^2, na.rm = TRUE) -
60		- -
61		- # Set colors and symbols -
62	275x	- if (col_obs[1] == "auto") { -
63	70x	- col_obs <- 1:length(obs_vars) -
64		- } -
65		- -
66	275x	- if (pch_obs[1] == "auto") { -
67	70x	- pch_obs <- 1:length(obs_vars) -
68		- } -
69	275x	- names(col_obs) <- names(pch_obs) <- obs_vars -
70		- -
71	275x	- plot(0, type = "n", -
72	275x	- xlab = xlab, ylab = ylab, -
73	275x	- xlim = xlim, -
74	275x	- ylim = c(0, 1.2 * maxy), frame = frame, ...) -
75		- -
76	275x	- for(obs_var in obs_vars){ -
77	410x	- residuals_plot <- subset(object$data, variable == obs_var, c("predicted", "residual")) -
78	410x	- points(residuals_plot[["predicted"]], -
79	410x	- residuals_plot[["residual"]]^2, -
80	410x	- pch = pch_obs[obs_var], col = col_obs[obs_var]) -
81		- } -
82		- -
83	275x	- if (object$err_mod == "const") { -
84	140x	- abline(h = object$errparms^2, lty = 2, col = 1) -
85		- } -
86	275x	- if (object$err_mod == "obs") { -
87	65x	- for (obs_var in obs_vars) { -
88	130x	- sigma_name = paste0("sigma_", obs_var) -
89	130x	- abline(h = object$errparms[sigma_name]^2, lty = 2, -
90	130x	- col = col_obs[obs_var]) -
91		- } -
92		- } -
93	275x	- if (object$err_mod == "tc") { -
94	70x	- sigma_plot <- function(predicted) { -
95	70x	- sigma_twocomp(predicted, -
96	70x	- sigma_low = object$errparms[1], -
97	70x	- rsd_high = object$errparms[2])^2 -
98		- } -
99	70x	- plot(sigma_plot, from = 0, to = max(object$data$predicted), -
100	70x	- add = TRUE, lty = 2, col = 1) -
101		- } -
102		- -
103	275x	- if (legend == TRUE) { -
104	70x	- legend(lpos, inset = c(0.05, 0.05), legend = obs_vars, -
105	70x	- col = col_obs[obs_vars], pch = pch_obs[obs_vars]) -
106		- } -
107		- } -

1		- #' Plot parameter variability of multistart objects -
2		- #' -
3		- #' Produces a boxplot with all parameters from the multiple runs, scaled -
4		- #' either by the parameters of the run with the highest likelihood, -
5		- #' or by their medians as proposed in the paper by Duchesne et al. (2021). -
6		- #' -
7		- #' Starting values of degradation model parameters and error model parameters -
8		- #' are shown as green circles. The results obtained in the original run -
9		- #' are shown as red circles. -
10		- #' -
11		- #' @param object The [multistart] object -
12		- #' @param llmin The minimum likelihood of objects to be shown -
13		- #' @param llquant Fractional value for selecting only the fits with higher -
14		- #' likelihoods. Overrides 'llmin'. -
15		- #' @param scale By default, scale parameters using the best -
16		- #' available fit. -
17		- #' If 'median', parameters are scaled using the median parameters from all fits. -
18		- #' @param main Title of the plot -
19		- #' @param lpos Positioning of the legend. -
20		- #' @param \dots Passed to [boxplot] -
21		- #' @references Duchesne R, Guillemin A, Gandrillon O, Crauste F. Practical -
22		- #' identifiability in the frame of nonlinear mixed effects models: the example -
23		- #' of the in vitro erythropoiesis. BMC Bioinformatics. 2021 Oct 4;22(1):478. -
24		- #' doi: 10.1186/s12859-021-04373-4. -
25		- #' @seealso [multistart] -
26		- #' @importFrom stats median quantile -
27		- #' @export -
28		- parplot <- function(object, ...) { -
29	176x	- UseMethod("parplot") -
30		- } -
31		- -
32		- #' @rdname parplot -
33		- #' @export -
34		- parplot.multistart.saem.mmkin <- function(object, llmin = -Inf, llquant = NA, -
35		- scale = c("best", "median"), -
36		- lpos = "bottomleft", main = "", ...) -
37		- { -
38	176x	- oldpar <- par(no.readonly = TRUE) -
39	176x	- on.exit(par(oldpar, no.readonly = TRUE)) -
40		- -
41	176x	- orig <- attr(object, "orig") -
42	176x	- orig_parms <- parms(orig) -
43	176x	- start_degparms <- orig$mean_dp_start -
44	176x	- all_parms <- parms(object, exclude_failed = FALSE) -
45		- -
46	176x	- if (inherits(object, "multistart.saem.mmkin")) { -
47	176x	- llfunc <- function(object) { -
48	!	- if (inherits(object$so, "try-error")) return(NA) -
49	1408x	- else return(logLik(object$so)) -
50		- } -
51		- } else { -
52	!	- stop("parplot is only implemented for multistart.saem.mmkin objects") -
53		- } -
54	176x	- ll <- sapply(object, llfunc) -
55	176x	- if (!is.na(llquant[1])) { -
56	!	- if (llmin != -Inf) warning("Overriding 'llmin' because 'llquant' was specified") -
57	88x	- llmin <- quantile(ll, 1 - llquant) -
58		- } -
59	176x	- selected <- which(ll > llmin) -
60	176x	- selected_parms <- all_parms[selected, ] -
61		- -
62	176x	- par(las = 1) -
63	176x	- if (orig$transformations == "mkin") { -
64	88x	- degparm_names_transformed <- names(start_degparms) -
65	88x	- degparm_index <- which(names(orig_parms) %in% degparm_names_transformed) -
66	88x	- orig_parms[degparm_names_transformed] <- backtransform_odeparms( -
67	88x	- orig_parms[degparm_names_transformed], -
68	88x	- orig$mmkin[[1]]$mkinmod, -
69	88x	- transform_rates = orig$mmkin[[1]]$transform_rates, -
70	88x	- transform_fractions = orig$mmkin[[1]]$transform_fractions) -
71	88x	- start_degparms <- backtransform_odeparms(start_degparms, -
72	88x	- orig$mmkin[[1]]$mkinmod, -
73	88x	- transform_rates = orig$mmkin[[1]]$transform_rates, -
74	88x	- transform_fractions = orig$mmkin[[1]]$transform_fractions) -
75	88x	- degparm_names <- names(start_degparms) -
76		- -
77	88x	- names(orig_parms) <- c(degparm_names, names(orig_parms[-degparm_index])) -
78		- -
79	88x	- selected_parms[, degparm_names_transformed] <- -
80	88x	- t(apply(selected_parms[, degparm_names_transformed], 1, backtransform_odeparms, -
81	88x	- orig$mmkin[[1]]$mkinmod, -
82	88x	- transform_rates = orig$mmkin[[1]]$transform_rates, -
83	88x	- transform_fractions = orig$mmkin[[1]]$transform_fractions)) -
84	88x	- colnames(selected_parms)[1:length(degparm_names)] <- degparm_names -
85		- } -
86		- -
87	176x	- start_errparms <- orig$so@model@error.init -
88	176x	- names(start_errparms) <- orig$so@model@name.sigma -
89		- -
90	176x	- start_omegaparms <- orig$so@model@omega.init -
91		- -
92	176x	- start_parms <- c(start_degparms, start_errparms) -
93		- -
94	176x	- scale <- match.arg(scale) -
95	176x	- parm_scale <- switch(scale, -
96	176x	- best = selected_parms[which.best(object[selected]), ], -
97	176x	- median = apply(selected_parms, 2, median) -
98		- ) -
99		- -
100		- # Boxplots of all scaled parameters -
101	176x	- selected_scaled_parms <- t(apply(selected_parms, 1, function(x) x / parm_scale)) -
102	176x	- boxplot(selected_scaled_parms, log = "y", main = main, , -
103	176x	- ylab = "Normalised parameters", ...) -
104		- -
105		- # Show starting parameters -
106	176x	- start_scaled_parms <- rep(NA_real_, length(orig_parms)) -
107	176x	- names(start_scaled_parms) <- names(orig_parms) -
108	176x	- start_scaled_parms[names(start_parms)] <- -
109	176x	- start_parms / parm_scale[names(start_parms)] -
110	176x	- points(start_scaled_parms, col = 3, cex = 3) -
111		- -
112		- # Show parameters of original run -
113	176x	- orig_scaled_parms <- orig_parms / parm_scale -
114	176x	- points(orig_scaled_parms, col = 2, cex = 2) -
115		- -
116	176x	- abline(h = 1, lty = 2) -
117		- -
118	176x	- legend(lpos, inset = c(0.05, 0.05), bty = "n", -
119	176x	- pch = 1, col = 3:1, lty = c(NA, NA, 1), -
120	176x	- legend = c( -
121	176x	- "Original start", -
122	176x	- "Original results", -
123	176x	- "Multistart runs")) -
124		- } -

1		- #' Method to get the names of ill-defined parameters -
2		- #' -
3		- #' The method for generalised nonlinear regression fits as obtained -
4		- #' with [mkinfit] and [mmkin] checks if the degradation parameters -
5		- #' pass the Wald test (in degradation kinetics often simply called t-test) for -
6		- #' significant difference from zero. For this test, the parameterisation -
7		- #' without parameter transformations is used. -
8		- #' -
9		- #' The method for hierarchical model fits, also known as nonlinear -
10		- #' mixed-effects model fits as obtained with [saem] and [mhmkin] -
11		- #' checks if any of the confidence intervals for the random -
12		- #' effects expressed as standard deviations include zero, and if -
13		- #' the confidence intervals for the error model parameters include -
14		- #' zero. -
15		- #' -
16		- #' @param object The object to investigate -
17		- #' @param x The object to be printed -
18		- #' @param conf.level The confidence level for checking p values -
19		- #' @param \dots For potential future extensions -
20		- #' @param random For hierarchical fits, should random effects be tested? -
21		- #' @param errmod For hierarchical fits, should error model parameters be -
22		- #' tested? -
23		- #' @param slopes For hierarchical [saem] fits using saemix as backend, -
24		- #' should slope parameters in the covariate model(starting with 'beta_') be -
25		- #' tested? -
26		- #' @return For [mkinfit] or [saem] objects, a character vector of parameter -
27		- #' names. For [mmkin] or [mhmkin] objects, a matrix like object of class -
28		- #' 'illparms.mmkin' or 'illparms.mhmkin'. -
29		- #' @note All return objects have printing methods. For the single fits, printing -
30		- #' does not output anything in the case no ill-defined parameters are found. -
31		- #' @export -
32		- illparms <- function(object, ...) -
33		- { -
34	2471x	- UseMethod("illparms", object) -
35		- } -
36		- -
37		- #' @rdname illparms -
38		- #' @export -
39		- #' @examples -
40		- #' fit <- mkinfit("FOMC", FOCUS_2006_A, quiet = TRUE) -
41		- #' illparms(fit) -
42		- illparms.mkinfit <- function(object, conf.level = 0.95, ...) { -
43	8x	- p_values <- suppressWarnings(summary(object)$bpar[, "Pr(>t)"]) -
44	8x	- na <- is.na(p_values) -
45	8x	- failed <- p_values > 1 - conf.level -
46	8x	- ret <- names(parms(object))[na \| failed] -
47	8x	- class(ret) <- "illparms.mkinfit" -
48	8x	- return(ret) -
49		- } -
50		- -
51		- #' @rdname illparms -
52		- #' @export -
53		- print.illparms.mkinfit <- function(x, ...) { -
54	190x	- class(x) <- NULL -
55	190x	- if (length(x) > 0) { -
56	!	- print(as.character(x)) -
57		- } -
58		- } -
59		- -
60		- #' @rdname illparms -
61		- #' @export -
62		- #' @examples -
63		- #' \dontrun{ -
64		- #' fits <- mmkin( -
65		- #' c("SFO", "FOMC"), -
66		- #' list("FOCUS A" = FOCUS_2006_A, -
67		- #' "FOCUS C" = FOCUS_2006_C), -
68		- #' quiet = TRUE) -
69		- #' illparms(fits) -
70		- #' } -
71		- illparms.mmkin <- function(object, conf.level = 0.95, ...) { -
72	1x	- result <- lapply(object, -
73	1x	- function(fit) { -
74	!	- if (inherits(fit, "try-error")) return("E") -
75	8x	- ill <- illparms(fit, conf.level = conf.level) -
76	8x	- if (length(ill) > 0) { -
77	3x	- return(paste(ill, collapse = ", ")) -
78		- } else { -
79	5x	- return("") -
80		- } -
81		- }) -
82	1x	- result <- unlist(result) -
83	1x	- dim(result) <- dim(object) -
84	1x	- dimnames(result) <- dimnames(object) -
85	1x	- class(result) <- "illparms.mmkin" -
86	1x	- return(result) -
87		- } -
88		- -
89		- #' @rdname illparms -
90		- #' @export -
91		- print.illparms.mmkin <- function(x, ...) { -
92	1x	- class(x) <- NULL -
93	1x	- print(x, quote = FALSE) -
94		- } -
95		- -
96		- #' @rdname illparms -
97		- #' @export -
98		- illparms.saem.mmkin <- function(object, conf.level = 0.95, random = TRUE, errmod = TRUE, slopes = TRUE, ...) { -
99	2091x	- if (inherits(object$so, "try-error")) { -
100	!	- ill_parms <- NA -
101		- } else { -
102	2091x	- ints <- intervals(object, conf.level = conf.level) -
103	2091x	- ill_parms <- character(0) -
104	2091x	- if (random) { -
105	2091x	- ill_parms_random_i <- which(ints$random[, "lower"] < 0) -
106	2091x	- ill_parms_random <- rownames(ints$random)[ill_parms_random_i] -
107	2091x	- ill_parms <- c(ill_parms, ill_parms_random) -
108		- } -
109	2091x	- if (errmod) { -
110	2091x	- ill_parms_errmod_i <- which(ints$errmod[, "lower"] < 0 & ints$errmod[, "upper"] > 0) -
111	2091x	- ill_parms_errmod <- rownames(ints$errmod)[ill_parms_errmod_i] -
112	2091x	- ill_parms <- c(ill_parms, ill_parms_errmod) -
113		- } -
114	2091x	- if (slopes) { -
115	!	- if (is.null(object$so)) stop("Slope testing is only implemented for the saemix backend") -
116	2091x	- slope_names <- grep("^beta_", object$so@model@name.fixed, value = TRUE) -
117	2091x	- ci <- object$so@results@conf.int -
118	2091x	- rownames(ci) <- ci$name -
119	2091x	- slope_ci <- ci[slope_names, ] -
120	2091x	- ill_parms_slopes <- slope_ci[, "lower"] < 0 & slope_ci[, "upper"] > 0 -
121	2091x	- ill_parms <- c(ill_parms, slope_names[ill_parms_slopes]) -
122		- } -
123		- } -
124	2091x	- class(ill_parms) <- "illparms.saem.mmkin" -
125	2091x	- return(ill_parms) -
126		- } -
127		- -
128		- #' @rdname illparms -
129		- #' @export -
130		- print.illparms.saem.mmkin <- print.illparms.mkinfit -
131		- -
132		- #' @rdname illparms -
133		- #' @export -
134		- illparms.mhmkin <- function(object, conf.level = 0.95, random = TRUE, errmod = TRUE, ...) { -
135	371x	- if (inherits(object[[1]], "saem.mmkin")) { -
136	371x	- check_failed <- function(x) if (inherits(x$so, "try-error")) TRUE else FALSE -
137		- } -
138	371x	- result <- lapply(object, -
139	371x	- function(fit) { -
140	1484x	- if (check_failed(fit)) { -
141	!	- return("E") -
142		- } else { -
143	1484x	- if (!is.null(fit$FIM_failed) && -
144	1484x	- "random effects and error model parameters" %in% fit$FIM_failed) { -
145	!	- return("NA") -
146		- } else { -
147	1484x	- ill <- illparms(fit, conf.level = conf.level, random = random, errmod = errmod) -
148	1484x	- if (length(ill) > 0) { -
149	1000x	- return(paste(ill, collapse = ", ")) -
150		- } else { -
151	484x	- return("") -
152		- } -
153		- } -
154		- } -
155		- }) -
156	371x	- result <- unlist(result) -
157	371x	- dim(result) <- dim(object) -
158	371x	- dimnames(result) <- dimnames(object) -
159	371x	- class(result) <- "illparms.mhmkin" -
160	371x	- return(result) -
161		- } -
162		- -
163		- #' @rdname illparms -
164		- #' @export -
165		- print.illparms.mhmkin <- function(x, ...) { -
166	125x	- class(x) <- NULL -
167	125x	- print(x, quote = FALSE) -
168		- } -

1		- #' Function to calculate endpoints for further use from kinetic models fitted -
2		- #' with mkinfit -
3		- #' -
4		- #' This function calculates DT50 and DT90 values as well as formation fractions -
5		- #' from kinetic models fitted with mkinfit. If the SFORB model was specified -
6		- #' for one of the parents or metabolites, the Eigenvalues are returned. These -
7		- #' are equivalent to the rate constants of the DFOP model, but with the -
8		- #' advantage that the SFORB model can also be used for metabolites. -
9		- #' -
10		- #' Additional DT50 values are calculated from the FOMC DT90 and k1 and k2 from -
11		- #' HS and DFOP, as well as from Eigenvalues b1 and b2 of any SFORB models -
12		- #' -
13		- #' @param fit An object of class [mkinfit], [nlme.mmkin] or [saem.mmkin], or -
14		- #' another object that has list components mkinmod containing an [mkinmod] -
15		- #' degradation model, and two numeric vectors, bparms.optim and bparms.fixed, -
16		- #' that contain parameter values for that model. -
17		- #' @param covariates Numeric vector with covariate values for all variables in -
18		- #' any covariate models in the object. If given, it overrides 'covariate_quantile'. -
19		- #' @param covariate_quantile This argument only has an effect if the fitted -
20		- #' object has covariate models. If so, the default is to show endpoints -
21		- #' for the median of the covariate values (50th percentile). -
22		- #' @importFrom stats optimize -
23		- #' @return A list with a matrix of dissipation times named distimes, and, if -
24		- #' applicable, a vector of formation fractions named ff and, if the SFORB model -
25		- #' was in use, a vector of eigenvalues of these SFORB models, equivalent to -
26		- #' DFOP rate constants -
27		- #' @note The function is used internally by [summary.mkinfit], -
28		- #' [summary.nlme.mmkin] and [summary.saem.mmkin]. -
29		- #' @author Johannes Ranke -
30		- #' @examples -
31		- #' -
32		- #' fit <- mkinfit("FOMC", FOCUS_2006_C, quiet = TRUE) -
33		- #' endpoints(fit) -
34		- #' \dontrun{ -
35		- #' fit_2 <- mkinfit("DFOP", FOCUS_2006_C, quiet = TRUE) -
36		- #' endpoints(fit_2) -
37		- #' fit_3 <- mkinfit("SFORB", FOCUS_2006_C, quiet = TRUE) -
38		- #' endpoints(fit_3) -
39		- #' } -
40		- #' -
41		- #' @export -
42		- endpoints <- function(fit, covariates = NULL, covariate_quantile = 0.5) { -
43	56208x	- mkinmod <- fit$mkinmod -
44	56208x	- obs_vars <- names(mkinmod$spec) -
45		- -
46	56208x	- if (!is.null(fit$covariate_models)) { -
47	110x	- if (is.null(covariates)) { -
48	110x	- covariates = as.data.frame( -
49	110x	- apply(fit$covariates, 2, quantile, -
50	110x	- covariate_quantile, simplify = FALSE)) -
51		- } else { -
52	!	- covariate_m <- matrix(covariates, byrow = TRUE) -
53	!	- colnames(covariate_m) <- names(covariates) -
54	!	- rownames(covariate_m) <- "User" -
55	!	- covariates <- as.data.frame(covariate_m) -
56		- } -
57	110x	- degparms_trans <- parms(fit, covariates = covariates)[, 1] -
58	110x	- if (inherits(fit, "saem.mmkin") & (fit$transformations == "saemix")) { -
59	!	- degparms <- degparms_trans -
60		- } else { -
61	110x	- degparms <- backtransform_odeparms(degparms_trans, -
62	110x	- fit$mkinmod, -
63	110x	- transform_rates = fit$transform_rates, -
64	110x	- transform_fractions = fit$transform_fractions) -
65		- } -
66		- } else { -
67	56098x	- degparms <- c(fit$bparms.optim, fit$bparms.fixed) -
68		- } -
69		- -
70		- # Set up object to return -
71	56208x	- ep <- list() -
72	56208x	- ep$covariates <- covariates -
73	56208x	- ep$ff <- vector() -
74	56208x	- ep$SFORB <- vector() -
75	56208x	- ep$distimes <- data.frame( -
76	56208x	- DT50 = rep(NA, length(obs_vars)), -
77	56208x	- DT90 = rep(NA, length(obs_vars)), -
78	56208x	- row.names = obs_vars) -
79		- -
80	56208x	- for (obs_var in obs_vars) { -
81	73858x	- type = names(mkinmod$map[[obs_var]])[1] -
82		- -
83		- # Get formation fractions if directly fitted, and calculate remaining fraction to sink -
84	73858x	- f_names = grep(paste("^f", obs_var, sep = "_"), names(degparms), value=TRUE) -
85	73858x	- if (length(f_names) > 0) { -
86	15068x	- f_values = degparms[f_names] -
87	15068x	- f_to_sink = 1 - sum(f_values) -
88	15068x	- names(f_to_sink) = ifelse(type == "SFORB", -
89	15068x	- paste(obs_var, "free", "sink", sep = "_"), -
90	15068x	- paste(obs_var, "sink", sep = "_")) -
91	15068x	- for (f_name in f_names) { -
92	17338x	- ep$ff[[sub("f_", "", sub("_to_", "_", f_name))]] = f_values[[f_name]] -
93		- } -
94	15068x	- ep$ff = append(ep$ff, f_to_sink) -
95		- } -
96		- -
97		- # Get the rest -
98	73858x	- if (type == "SFO") { -
99	40900x	- k_names = grep(paste("^k", obs_var, sep="_"), names(degparms), value=TRUE) -
100	40900x	- k_tot = sum(degparms[k_names]) -
101	40900x	- DT50 = log(2)/k_tot -
102	40900x	- DT90 = log(10)/k_tot -
103	40900x	- if (mkinmod$use_of_ff == "min" && length(obs_vars) > 1) { -
104	622x	- for (k_name in k_names) -
105		- { -
106	932x	- ep$ff[[sub("k_", "", k_name)]] = degparms[[k_name]] / k_tot -
107		- } -
108		- } -
109		- } -
110	73858x	- if (type == "FOMC") { -
111	1790x	- alpha = degparms["alpha"] -
112	1790x	- beta = degparms["beta"] -
113	1790x	- DT50 = beta * (2^(1/alpha) - 1) -
114	1790x	- DT90 = beta * (10^(1/alpha) - 1) -
115	1790x	- DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011 -
116	1790x	- ep$distimes[obs_var, c("DT50back")] = DT50_back -
117		- } -
118	73858x	- if (type == "IORE") { -
119	352x	- k_names = grep(paste("^k__iore", obs_var, sep="_"), names(degparms), value=TRUE) -
120	352x	- k_tot = sum(degparms[k_names]) -
121		- # From the NAFTA kinetics guidance, p. 5 -
122	352x	- n = degparms[paste("N", obs_var, sep = "_")] -
123	352x	- k = k_tot -
124		- # Use the initial concentration of the parent compound -
125	352x	- source_name = mkinmod$map[[1]][[1]] -
126	352x	- c0 = degparms[paste(source_name, "0", sep = "_")] -
127	352x	- alpha = 1 / (n - 1) -
128	352x	- beta = (c0^(1 - n))/(k * (n - 1)) -
129	352x	- DT50 = beta * (2^(1/alpha) - 1) -
130	352x	- DT90 = beta * (10^(1/alpha) - 1) -
131	352x	- DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011 -
132	352x	- ep$distimes[obs_var, c("DT50back")] = DT50_back -
133	352x	- if (mkinmod$use_of_ff == "min") { -
134	!	- for (k_name in k_names) -
135		- { -
136	!	- ep$ff[[sub("k_", "", k_name)]] = degparms[[k_name]] / k_tot -
137		- } -
138		- } -
139		- } -
140	73858x	- if (type == "DFOP") { -
141	27729x	- k1 = degparms["k1"] -
142	27729x	- k2 = degparms["k2"] -
143	27729x	- g = degparms["g"] -
144	27729x	- f <- function(log_t, x) { -
145	684705x	- t <- exp(log_t) -
146	684705x	- fraction <- g * exp( - k1 * t) + (1 - g) * exp( - k2 * t) -
147	684705x	- (fraction - (1 - x/100))^2 -
148		- } -
149	27729x	- DT50_k1 = log(2)/k1 -
150	27729x	- DT50_k2 = log(2)/k2 -
151	27729x	- DT90_k1 = log(10)/k1 -
152	27729x	- DT90_k2 = log(10)/k2 -
153		- -
154	27729x	- DT50 <- try(exp(optimize(f, c(log(DT50_k1), log(DT50_k2)), x=50)$minimum), -
155	27729x	- silent = TRUE) -
156	27729x	- DT90 <- try(exp(optimize(f, c(log(DT90_k1), log(DT90_k2)), x=90)$minimum), -
157	27729x	- silent = TRUE) -
158	!	- if (inherits(DT50, "try-error")) DT50 = NA -
159	!	- if (inherits(DT90, "try-error")) DT90 = NA -
160	27729x	- DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011 -
161		- -
162	27729x	- ep$distimes[obs_var, c("DT50back")] = DT50_back -
163	27729x	- ep$distimes[obs_var, c("DT50_k1")] = DT50_k1 -
164	27729x	- ep$distimes[obs_var, c("DT50_k2")] = DT50_k2 -
165		- } -
166	73858x	- if (type == "HS") { -
167	318x	- k1 = degparms["k1"] -
168	318x	- k2 = degparms["k2"] -
169	318x	- tb = degparms["tb"] -
170	318x	- DTx <- function(x) { -
171	636x	- DTx.a <- (log(100/(100 - x)))/k1 -
172	636x	- DTx.b <- tb + (log(100/(100 - x)) - k1 * tb)/k2 -
173	339x	- if (DTx.a < tb) DTx <- DTx.a -
174	297x	- else DTx <- DTx.b -
175	636x	- return(DTx) -
176		- } -
177	318x	- DT50 <- DTx(50) -
178	318x	- DT90 <- DTx(90) -
179	318x	- DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011 -
180	318x	- DT50_k1 = log(2)/k1 -
181	318x	- DT50_k2 = log(2)/k2 -
182	318x	- ep$distimes[obs_var, c("DT50back")] = DT50_back -
183	318x	- ep$distimes[obs_var, c("DT50_k1")] = DT50_k1 -
184	318x	- ep$distimes[obs_var, c("DT50_k2")] = DT50_k2 -
185		- } -
186	73858x	- if (type == "SFORB") { -
187		- # FOCUS kinetics (2006), p. 60 f -
188	2616x	- k_out_names = grep(paste("^k", obs_var, "free", sep="_"), names(degparms), value=TRUE) -
189	2616x	- k_out_names = setdiff(k_out_names, paste("k", obs_var, "free", "bound", sep="_")) -
190	2616x	- k_1output = sum(degparms[k_out_names]) -
191	2616x	- k_12 = degparms[paste("k", obs_var, "free", "bound", sep="_")] -
192	2616x	- k_21 = degparms[paste("k", obs_var, "bound", "free", sep="_")] -
193		- -
194	2616x	- sqrt_exp = sqrt(1/4 * (k_12 + k_21 + k_1output)^2 - k_1output * k_21) -
195	2616x	- b1 = 0.5 * (k_12 + k_21 + k_1output) + sqrt_exp -
196	2616x	- b2 = 0.5 * (k_12 + k_21 + k_1output) - sqrt_exp -
197	2616x	- g = (k_12 + k_21 - b1)/(b2 - b1) -
198		- -
199	2616x	- DT50_b1 = log(2)/b1 -
200	2616x	- DT50_b2 = log(2)/b2 -
201	2616x	- DT90_b1 = log(10)/b1 -
202	2616x	- DT90_b2 = log(10)/b2 -
203		- -
204	2616x	- SFORB_fraction = function(t) { -
205	60096x	- g * exp(-b1 * t) + (1 - g) * exp(-b2 * t) -
206		- } -
207		- -
208	2616x	- f_50 <- function(log_t) (SFORB_fraction(exp(log_t)) - 0.5)^2 -
209	2616x	- log_DT50 <- try(optimize(f_50, c(log(DT50_b1), log(DT50_b2)))$minimum, -
210	2616x	- silent = TRUE) -
211	2616x	- f_90 <- function(log_t) (SFORB_fraction(exp(log_t)) - 0.1)^2 -
212	2616x	- log_DT90 <- try(optimize(f_90, c(log(DT90_b1), log(DT90_b2)))$minimum, -
213	2616x	- silent = TRUE) -
214		- -
215	2616x	- DT50 = if (inherits(log_DT50, "try-error")) NA -
216	2616x	- else exp(log_DT50) -
217	2616x	- DT90 = if (inherits(log_DT90, "try-error")) NA -
218	2616x	- else exp(log_DT90) -
219		- -
220	2616x	- DT50_back = DT90 / (log(10)/log(2)) # Backcalculated DT50 as recommended in FOCUS 2011 -
221		- -
222	2616x	- for (k_out_name in k_out_names) -
223		- { -
224	2618x	- ep$ff[[sub("k_", "", k_out_name)]] = degparms[[k_out_name]] / k_1output -
225		- } -
226		- -
227		- # Return the eigenvalues for comparison with DFOP rate constants -
228	2616x	- ep$SFORB[[paste(obs_var, "b1", sep="_")]] = b1 -
229	2616x	- ep$SFORB[[paste(obs_var, "b2", sep="_")]] = b2 -
230		- # Return g for comparison with DFOP -
231	2616x	- ep$SFORB[[paste(obs_var, "g", sep="_")]] = g -
232		- -
233	2616x	- ep$distimes[obs_var, c("DT50back")] = DT50_back -
234	2616x	- ep$distimes[obs_var, c(paste("DT50", obs_var, "b1", sep = "_"))] = DT50_b1 -
235	2616x	- ep$distimes[obs_var, c(paste("DT50", obs_var, "b2", sep = "_"))] = DT50_b2 -
236		- } -
237	73858x	- if (type == "logistic") { -
238		- # FOCUS kinetics (2014) p. 67 -
239	153x	- kmax = degparms["kmax"] -
240	153x	- k0 = degparms["k0"] -
241	153x	- r = degparms["r"] -
242	153x	- DT50 = (1/r) * log(1 - ((kmax/k0) * (1 - 2^(r/kmax)))) -
243	153x	- DT90 = (1/r) * log(1 - ((kmax/k0) * (1 - 10^(r/kmax)))) -
244		- -
245	153x	- DT50_k0 = log(2)/k0 -
246	153x	- DT50_kmax = log(2)/kmax -
247	153x	- ep$distimes[obs_var, c("DT50_k0")] = DT50_k0 -
248	153x	- ep$distimes[obs_var, c("DT50_kmax")] = DT50_kmax -
249		- } -
250	73858x	- ep$distimes[obs_var, c("DT50", "DT90")] = c(DT50, DT90) -
251		- } -
252	38846x	- if (length(ep$ff) == 0) ep$ff <- NULL -
253	53592x	- if (length(ep$SFORB) == 0) ep$SFORB <- NULL -
254	56208x	- return(ep) -
255		- } -

1		- #' Fit nonlinear mixed-effects models built from one or more kinetic -
2		- #' degradation models and one or more error models -
3		- #' -
4		- #' The name of the methods expresses that (multiple) hierarchichal -
5		- #' (also known as multilevel) multicompartment kinetic models are -
6		- #' fitted. Our kinetic models are nonlinear, so we can use various nonlinear -
7		- #' mixed-effects model fitting functions. -
8		- #' -
9		- #' @param objects A list of [mmkin] objects containing fits of the same -
10		- #' degradation models to the same data, but using different error models. -
11		- #' Alternatively, a single [mmkin] object containing fits of several -
12		- #' degradation models to the same data -
13		- #' @param backend The backend to be used for fitting. Currently, only saemix is -
14		- #' supported -
15		- #' @param no_random_effect Default is NULL and will be passed to [saem]. If a -
16		- #' character vector is supplied, it will be passed to all calls to [saem], -
17		- #' which will exclude random effects for all matching parameters. Alternatively, -
18		- #' a list of character vectors or an object of class [illparms.mhmkin] can be -
19		- #' specified. They have to have the same dimensions that the return object of -
20		- #' the current call will have, i.e. the number of rows must match the number -
21		- #' of degradation models in the mmkin object(s), and the number of columns must -
22		- #' match the number of error models used in the mmkin object(s). -
23		- #' @param algorithm The algorithm to be used for fitting (currently not used) -
24		- #' @param \dots Further arguments that will be passed to the nonlinear mixed-effects -
25		- #' model fitting function. -
26		- #' @param cores The number of cores to be used for multicore processing. This -
27		- #' is only used when the \code{cluster} argument is \code{NULL}. On Windows -
28		- #' machines, cores > 1 is not supported, you need to use the \code{cluster} -
29		- #' argument to use multiple logical processors. Per default, all cores detected -
30		- #' by [parallel::detectCores()] are used, except on Windows where the default -
31		- #' is 1. -
32		- #' @param cluster A cluster as returned by [makeCluster] to be used for -
33		- #' parallel execution. -
34		- #' @importFrom parallel mclapply parLapply detectCores -
35		- #' @return A two-dimensional [array] of fit objects and/or try-errors that can -
36		- #' be indexed using the degradation model names for the first index (row index) -
37		- #' and the error model names for the second index (column index), with class -
38		- #' attribute 'mhmkin'. -
39		- #' @author Johannes Ranke -
40		- #' @seealso \code{\link{[.mhmkin}} for subsetting [mhmkin] objects -
41		- #' @export -
42		- mhmkin <- function(objects, ...) { -
43	375x	- UseMethod("mhmkin") -
44		- } -
45		- -
46		- #' @export -
47		- #' @rdname mhmkin -
48		- mhmkin.mmkin <- function(objects, ...) { -
49	!	- mhmkin(list(objects), ...) -
50		- } -
51		- -
52		- #' @export -
53		- #' @rdname mhmkin -
54		- #' @examples -
55		- #' \dontrun{ -
56		- #' # We start with separate evaluations of all the first six datasets with two -
57		- #' # degradation models and two error models -
58		- #' f_sep_const <- mmkin(c("SFO", "FOMC"), ds_fomc[1:6], cores = 2, quiet = TRUE) -
59		- #' f_sep_tc <- update(f_sep_const, error_model = "tc") -
60		- #' # The mhmkin function sets up hierarchical degradation models aka -
61		- #' # nonlinear mixed-effects models for all four combinations, specifying -
62		- #' # uncorrelated random effects for all degradation parameters -
63		- #' f_saem_1 <- mhmkin(list(f_sep_const, f_sep_tc), cores = 2) -
64		- #' status(f_saem_1) -
65		- #' # The 'illparms' function shows that in all hierarchical fits, at least -
66		- #' # one random effect is ill-defined (the confidence interval for the -
67		- #' # random effect expressed as standard deviation includes zero) -
68		- #' illparms(f_saem_1) -
69		- #' # Therefore we repeat the fits, excluding the ill-defined random effects -
70		- #' f_saem_2 <- update(f_saem_1, no_random_effect = illparms(f_saem_1)) -
71		- #' status(f_saem_2) -
72		- #' illparms(f_saem_2) -
73		- #' # Model comparisons show that FOMC with two-component error is preferable, -
74		- #' # and confirms our reduction of the default parameter model -
75		- #' anova(f_saem_1) -
76		- #' anova(f_saem_2) -
77		- #' # The convergence plot for the selected model looks fine -
78		- #' saemix::plot(f_saem_2[["FOMC", "tc"]]$so, plot.type = "convergence") -
79		- #' # The plot of predictions versus data shows that we have a pretty data-rich -
80		- #' # situation with homogeneous distribution of residuals, because we used the -
81		- #' # same degradation model, error model and parameter distribution model that -
82		- #' # was used in the data generation. -
83		- #' plot(f_saem_2[["FOMC", "tc"]]) -
84		- #' # We can specify the same parameter model reductions manually -
85		- #' no_ranef <- list("parent_0", "log_beta", "parent_0", c("parent_0", "log_beta")) -
86		- #' dim(no_ranef) <- c(2, 2) -
87		- #' f_saem_2m <- update(f_saem_1, no_random_effect = no_ranef) -
88		- #' anova(f_saem_2m) -
89		- #' } -
90		- mhmkin.list <- function(objects, backend = "saemix", algorithm = "saem", -
91		- no_random_effect = NULL, -
92		- ..., -
93		- cores = if (Sys.info()["sysname"] == "Windows") 1 else parallel::detectCores(), cluster = NULL) -
94		- { -
95	375x	- call <- match.call() -
96	375x	- dot_args <- list(...) -
97	375x	- backend_function <- switch(backend, -
98	375x	- saemix = "saem" -
99		- ) -
100		- -
101	375x	- deg_models <- lapply(objects[[1]][, 1], function(x) x$mkinmod) -
102	375x	- names(deg_models) <- dimnames(objects[[1]])$model -
103	375x	- n.deg <- length(deg_models) -
104		- -
105	375x	- ds <- lapply(objects[[1]][1, ], function(x) x$data) -
106		- -
107	375x	- for (other in objects[-1]) { -
108		- # Check if the degradation models in all objects are the same -
109	375x	- for (deg_model_name in names(deg_models)) { -
110	750x	- if (!all.equal(other[[deg_model_name, 1]]$mkinmod$spec, -
111	750x	- deg_models[[deg_model_name]]$spec)) -
112		- { -
113	!	- stop("The mmkin objects have to be based on the same degradation models") -
114		- } -
115		- } -
116		- # Check if they have been fitted to the same dataset -
117	375x	- other_object_ds <- lapply(other[1, ], function(x) x$data) -
118	375x	- for (i in 1:length(ds)) { -
119	2250x	- if (!all.equal(ds[[i]][c("time", "variable", "observed")], -
120	2250x	- other_object_ds[[i]][c("time", "variable", "observed")])) -
121		- { -
122	!	- stop("The mmkin objects have to be fitted to the same datasets") -
123		- } -
124		- } -
125		- } -
126		- -
127	375x	- n.o <- length(objects) -
128		- -
129	375x	- error_models = sapply(objects, function(x) x[[1]]$err_mod) -
130	375x	- n.e <- length(error_models) -
131		- -
132	375x	- n.fits <- n.deg * n.e -
133	375x	- fit_indices <- matrix(1:n.fits, ncol = n.e) -
134	375x	- dimnames(fit_indices) <- list(degradation = names(deg_models), -
135	375x	- error = error_models) -
136		- -
137	375x	- if (is.null(no_random_effect) \|\| is.null(dim(no_random_effect))) { -
138	129x	- no_ranef <- rep(list(no_random_effect), n.fits) -
139	129x	- dim(no_ranef) <- dim(fit_indices) -
140		- } else { -
141	246x	- if (!identical(dim(no_random_effect), dim(fit_indices))) { -
142	!	- stop("Dimensions of argument 'no_random_effect' are not suitable") -
143		- } -
144	246x	- if (is(no_random_effect, "illparms.mhmkin")) { -
145	125x	- no_ranef_dim <- dim(no_random_effect) -
146	125x	- no_ranef <- lapply(no_random_effect, function(x) { -
147	500x	- no_ranef_split <- strsplit(x, ", ") -
148	500x	- ret <- sapply(no_ranef_split, function(y) { -
149	500x	- gsub("sd\\((.*)\\)", "\\1", y) -
150		- }) -
151	500x	- return(ret) -
152		- }) -
153	125x	- dim(no_ranef) <- no_ranef_dim -
154		- } else { -
155	121x	- no_ranef <- no_random_effect -
156		- } -
157		- } -
158		- -
159	375x	- fit_function <- function(fit_index) { -
160	12x	- w <- which(fit_indices == fit_index, arr.ind = TRUE) -
161	12x	- deg_index <- w[1] -
162	12x	- error_index <- w[2] -
163	12x	- mmkin_row <- objects[[error_index]][deg_index, ] -
164	12x	- res <- try(do.call(backend_function, -
165	12x	- args = c( -
166	12x	- list(mmkin_row), -
167	12x	- dot_args, -
168	12x	- list(no_random_effect = no_ranef[[deg_index, error_index]])))) -
169	12x	- return(res) -
170		- } -
171		- -
172		- -
173	375x	- fit_time <- system.time({ -
174	375x	- if (is.null(cluster)) { -
175	375x	- results <- parallel::mclapply(as.list(1:n.fits), fit_function, -
176	375x	- mc.cores = cores, mc.preschedule = FALSE) -
177		- } else { -
178	!	- results <- parallel::parLapply(cluster, as.list(1:n.fits), fit_function) -
179		- } -
180		- }) -
181		- -
182	363x	- attributes(results) <- attributes(fit_indices) -
183	363x	- attr(results, "call") <- call -
184	363x	- attr(results, "time") <- fit_time -
185	363x	- class(results) <- switch(backend, -
186	363x	- saemix = c("mhmkin.saem.mmkin", "mhmkin") -
187		- ) -
188	363x	- return(results) -
189		- } -
190		- -
191		- #' Subsetting method for mhmkin objects -
192		- #' -
193		- #' @param x An [mhmkin] object. -
194		- #' @param i Row index selecting the fits for specific models -
195		- #' @param j Column index selecting the fits to specific datasets -
196		- #' @param drop If FALSE, the method always returns an mhmkin object, otherwise -
197		- #' either a list of fit objects or a single fit object. -
198		- #' @return An object inheriting from \code{\link{mhmkin}}. -
199		- #' @rdname mhmkin -
200		- #' @export -
201		- `[.mhmkin` <- function(x, i, j, ..., drop = FALSE) { -
202	!	- original_class <- class(x) -
203	!	- class(x) <- NULL -
204	!	- x_sub <- x[i, j, drop = drop] -
205		- -
206	!	- if (!drop) { -
207	!	- class(x_sub) <- original_class -
208		- } -
209	!	- return(x_sub) -
210		- } -
211		- -
212		- #' Print method for mhmkin objects -
213		- #' -
214		- #' @rdname mhmkin -
215		- #' @export -
216		- print.mhmkin <- function(x, ...) { -
217	125x	- cat("<mhmkin> object\n") -
218	125x	- cat("Status of individual fits:\n\n") -
219	125x	- print(status(x)) -
220		- } -
221		- -
222		- #' Check if fit within an mhmkin object failed -
223		- #' @param x The object to be checked -
224		- check_failed <- function(x) { -
225	1936x	- if (inherits(x, "try-error")) { -
226	!	- return(TRUE) -
227		- } else { -
228	1936x	- if (inherits(x$so, "try-error")) { -
229	!	- return(TRUE) -
230		- } else { -
231	1936x	- return(FALSE) -
232		- } -
233		- } -
234		- } -
235		- -
236		- #' @export -
237		- AIC.mhmkin <- function(object, ..., k = 2) { -
238	125x	- res <- sapply(object, function(x) { -
239	!	- if (check_failed(x)) return(NA) -
240	500x	- else return(AIC(x$so, k = k)) -
241		- }) -
242	125x	- dim(res) <- dim(object) -
243	125x	- dimnames(res) <- dimnames(object) -
244	125x	- return(res) -
245		- } -
246		- -
247		- #' @export -
248		- BIC.mhmkin <- function(object, ...) { -
249	125x	- res <- sapply(object, function(x) { -
250	!	- if (check_failed(x)) return(NA) -
251	500x	- else return(BIC(x$so)) -
252		- }) -
253	125x	- dim(res) <- dim(object) -
254	125x	- dimnames(res) <- dimnames(object) -
255	125x	- return(res) -
256		- } -
257		- -
258		- #' @export -
259		- update.mhmkin <- function(object, ..., evaluate = TRUE) { -
260	246x	- call <- attr(object, "call") -
261		- # For some reason we get mhkin.list in call[[1]] when using mhmkin from the -
262		- # loaded package so we need to fix this so we do not have to export -
263		- # mhmkin.list in addition to the S3 method mhmkin -
264	246x	- call[[1]] <- mhmkin -
265		- -
266	246x	- update_arguments <- match.call(expand.dots = FALSE)$... -
267		- -
268	246x	- if (length(update_arguments) > 0) { -
269	246x	- update_arguments_in_call <- !is.na(match(names(update_arguments), names(call))) -
270		- } -
271		- -
272	246x	- for (a in names(update_arguments)[update_arguments_in_call]) { -
273	!	- call[[a]] <- update_arguments[[a]] -
274		- } -
275		- -
276	246x	- update_arguments_not_in_call <- !update_arguments_in_call -
277	246x	- if(any(update_arguments_not_in_call)) { -
278	246x	- call <- c(as.list(call), update_arguments[update_arguments_not_in_call]) -
279	246x	- call <- as.call(call) -
280		- } -
281	246x	- if(evaluate) eval(call, parent.frame()) -
282	!	- else call -
283		- } -
284		- -
285		- #' @export -
286		- anova.mhmkin <- function(object, ..., -
287		- method = c("is", "lin", "gq"), test = FALSE, model.names = "auto") { -
288	234x	- if (identical(model.names, "auto")) { -
289	234x	- model.names <- outer(rownames(object), colnames(object), paste) -
290		- } -
291	234x	- failed_index <- which(sapply(object, check_failed), arr.ind = TRUE) -
292	234x	- if (length(failed_index > 0)) { -
293	!	- rlang::inject(anova(!!!(object[-failed_index]), method = method, test = test, -
294	!	- model.names = model.names[-failed_index])) -
295		- } else { -
296	234x	- rlang::inject(anova(!!!(object), method = method, test = test, -
297	234x	- model.names = model.names)) -
298		- } -
299		- } -
300		- -

1		- #' Summary method for class "nlme.mmkin" -
2		- #' -
3		- #' Lists model equations, initial parameter values, optimised parameters -
4		- #' for fixed effects (population), random effects (deviations from the -
5		- #' population mean) and residual error model, as well as the resulting -
6		- #' endpoints such as formation fractions and DT50 values. Optionally -
7		- #' (default is FALSE), the data are listed in full. -
8		- #' -
9		- #' @param object an object of class [nlme.mmkin] -
10		- #' @param x an object of class [summary.nlme.mmkin] -
11		- #' @param data logical, indicating whether the full data should be included in -
12		- #' the summary. -
13		- #' @param verbose Should the summary be verbose? -
14		- #' @param distimes logical, indicating whether DT50 and DT90 values should be -
15		- #' included. -
16		- #' @param alpha error level for confidence interval estimation from the t -
17		- #' distribution -
18		- #' @param digits Number of digits to use for printing -
19		- #' @param \dots optional arguments passed to methods like \code{print}. -
20		- #' @return The summary function returns a list based on the [nlme] object -
21		- #' obtained in the fit, with at least the following additional components -
22		- #' \item{nlmeversion, mkinversion, Rversion}{The nlme, mkin and R versions used} -
23		- #' \item{date.fit, date.summary}{The dates where the fit and the summary were -
24		- #' produced} -
25		- #' \item{diffs}{The differential equations used in the degradation model} -
26		- #' \item{use_of_ff}{Was maximum or minimum use made of formation fractions} -
27		- #' \item{data}{The data} -
28		- #' \item{confint_trans}{Transformed parameters as used in the optimisation, with confidence intervals} -
29		- #' \item{confint_back}{Backtransformed parameters, with confidence intervals if available} -
30		- #' \item{ff}{The estimated formation fractions derived from the fitted -
31		- #' model.} -
32		- #' \item{distimes}{The DT50 and DT90 values for each observed variable.} -
33		- #' \item{SFORB}{If applicable, eigenvalues of SFORB components of the model.} -
34		- #' The print method is called for its side effect, i.e. printing the summary. -
35		- #' @importFrom stats predict -
36		- #' @author Johannes Ranke for the mkin specific parts -
37		- #' José Pinheiro and Douglas Bates for the components inherited from nlme -
38		- #' @examples -
39		- #' -
40		- #' # Generate five datasets following SFO kinetics -
41		- #' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120) -
42		- #' dt50_sfo_in_pop <- 50 -
43		- #' k_in_pop <- log(2) / dt50_sfo_in_pop -
44		- #' set.seed(1234) -
45		- #' k_in <- rlnorm(5, log(k_in_pop), 0.5) -
46		- #' SFO <- mkinmod(parent = mkinsub("SFO")) -
47		- #' -
48		- #' pred_sfo <- function(k) { -
49		- #' mkinpredict(SFO, -
50		- #' c(k_parent = k), -
51		- #' c(parent = 100), -
52		- #' sampling_times) -
53		- #' } -
54		- #' -
55		- #' ds_sfo_mean <- lapply(k_in, pred_sfo) -
56		- #' names(ds_sfo_mean) <- paste("ds", 1:5) -
57		- #' -
58		- #' set.seed(12345) -
59		- #' ds_sfo_syn <- lapply(ds_sfo_mean, function(ds) { -
60		- #' add_err(ds, -
61		- #' sdfunc = function(value) sqrt(1^2 + value^2 * 0.07^2), -
62		- #' n = 1)[[1]] -
63		- #' }) -
64		- #' -
65		- #' \dontrun{ -
66		- #' # Evaluate using mmkin and nlme -
67		- #' library(nlme) -
68		- #' f_mmkin <- mmkin("SFO", ds_sfo_syn, quiet = TRUE, error_model = "tc", cores = 1) -
69		- #' f_nlme <- nlme(f_mmkin) -
70		- #' summary(f_nlme, data = TRUE) -
71		- #' } -
72		- #' -
73		- #' @export -
74		- summary.nlme.mmkin <- function(object, data = FALSE, verbose = FALSE, distimes = TRUE, alpha = 0.05, ...) { -
75		- -
76	319x	- mod_vars <- names(object$mkinmod$diffs) -
77		- -
78	319x	- confint_trans <- intervals(object, which = "fixed", level = 1 - alpha)$fixed -
79	319x	- attr(confint_trans, "label") <- NULL -
80	319x	- pnames <- rownames(confint_trans) -
81		- -
82	319x	- bp <- backtransform_odeparms(confint_trans[, "est."], object$mkinmod, -
83	319x	- object$transform_rates, object$transform_fractions) -
84	319x	- bpnames <- names(bp) -
85		- -
86		- # variance-covariance estimates for fixed effects (from summary.lme) -
87	319x	- fixed <- fixef(object) -
88	319x	- stdFixed <- sqrt(diag(as.matrix(object$varFix))) -
89	319x	- object$corFixed <- array( -
90	319x	- t(object$varFix/stdFixed)/stdFixed, -
91	319x	- dim(object$varFix), -
92	319x	- list(names(fixed), names(fixed))) -
93		- -
94		- # Transform boundaries of CI for one parameter at a time, -
95		- # with the exception of sets of formation fractions (single fractions are OK). -
96	319x	- f_names_skip <- character(0) -
97	319x	- for (box in mod_vars) { # Figure out sets of fractions to skip -
98	436x	- f_names <- grep(paste("^f", box, sep = "_"), pnames, value = TRUE) -
99	436x	- n_paths <- length(f_names) -
100	!	- if (n_paths > 1) f_names_skip <- c(f_names_skip, f_names) -
101		- } -
102		- -
103	319x	- confint_back <- matrix(NA, nrow = length(bp), ncol = 3, -
104	319x	- dimnames = list(bpnames, colnames(confint_trans))) -
105	319x	- confint_back[, "est."] <- bp -
106		- -
107	319x	- for (pname in pnames) { -
108	1410x	- if (!pname %in% f_names_skip) { -
109	1410x	- par.lower <- confint_trans[pname, "lower"] -
110	1410x	- par.upper <- confint_trans[pname, "upper"] -
111	1410x	- names(par.lower) <- names(par.upper) <- pname -
112	1410x	- bpl <- backtransform_odeparms(par.lower, object$mkinmod, -
113	1410x	- object$transform_rates, -
114	1410x	- object$transform_fractions) -
115	1410x	- bpu <- backtransform_odeparms(par.upper, object$mkinmod, -
116	1410x	- object$transform_rates, -
117	1410x	- object$transform_fractions) -
118	1410x	- confint_back[names(bpl), "lower"] <- bpl -
119	1410x	- confint_back[names(bpu), "upper"] <- bpu -
120		- } -
121		- } -
122		- -
123	319x	- object$confint_trans <- confint_trans -
124	319x	- object$confint_back <- confint_back -
125		- -
126	319x	- object$date.summary = date() -
127	319x	- object$use_of_ff = object$mkinmod$use_of_ff -
128	319x	- object$error_model_algorithm = object$mmkin[[1]]$error_model_algorithm -
129	319x	- err_mod = object$mmkin[[1]]$err_mod -
130		- -
131	319x	- object$diffs <- object$mkinmod$diffs -
132	319x	- object$print_data <- data -
133	319x	- object$data[["observed"]] <- object$data[["value"]] -
134	319x	- object$data[["value"]] <- NULL -
135	319x	- object$data[["predicted"]] <- predict(object) -
136	319x	- object$data[["residual"]] <- residuals(object, type = "response") -
137	319x	- if (is.null(object$modelStruct$varStruct)) { -
138	!	- object$data[["std"]] <- object$sigma -
139		- } else { -
140	319x	- object$data[["std"]] <- 1/attr(object$modelStruct$varStruct, "weights") -
141		- } -
142	319x	- object$data[["standardized"]] <- residuals(object, type = "pearson") -
143	319x	- object$verbose <- verbose -
144		- -
145	319x	- object$fixed <- object$mmkin[[1]]$fixed -
146	319x	- object$AIC = AIC(object) -
147	319x	- object$BIC = BIC(object) -
148	319x	- object$logLik = logLik(object) -
149		- -
150	319x	- ep <- endpoints(object) -
151	319x	- if (length(ep$ff) != 0) -
152	117x	- object$ff <- ep$ff -
153	319x	- if (distimes) object$distimes <- ep$distimes -
154	!	- if (length(ep$SFORB) != 0) object$SFORB <- ep$SFORB -
155	319x	- class(object) <- c("summary.nlme.mmkin", "nlme.mmkin", "nlme", "lme") -
156	319x	- return(object) -
157		- } -
158		- -
159		- #' @rdname summary.nlme.mmkin -
160		- #' @export -
161		- print.summary.nlme.mmkin <- function(x, digits = max(3, getOption("digits") - 3), verbose = x$verbose, ...) { -
162	117x	- cat("nlme version used for fitting: ", x$nlmeversion, "\n") -
163	117x	- cat("mkin version used for pre-fitting: ", x$mkinversion, "\n") -
164	117x	- cat("R version used for fitting: ", x$Rversion, "\n") -
165		- -
166	117x	- cat("Date of fit: ", x$date.fit, "\n") -
167	117x	- cat("Date of summary:", x$date.summary, "\n") -
168		- -
169	117x	- cat("\nEquations:\n") -
170	117x	- nice_diffs <- gsub("^(d.*) =", "\\1/dt =", x[["diffs"]]) -
171	117x	- writeLines(strwrap(nice_diffs, exdent = 11)) -
172		- -
173	117x	- cat("\nData:\n") -
174	117x	- cat(nrow(x$data), "observations of", -
175	117x	- length(unique(x$data$name)), "variable(s) grouped in", -
176	117x	- length(unique(x$data$ds)), "datasets\n") -
177		- -
178	117x	- cat("\nModel predictions using solution type", x$solution_type, "\n") -
179		- -
180	117x	- cat("\nFitted in", x$time[["elapsed"]], "s using", x$numIter, "iterations\n") -
181		- -
182	117x	- cat("\nVariance model: ") -
183	117x	- cat(switch(x$err_mod, -
184	117x	- const = "Constant variance", -
185	117x	- obs = "Variance unique to each observed variable", -
186	117x	- tc = "Two-component variance function"), "\n") -
187		- -
188	117x	- cat("\nMean of starting values for individual parameters:\n") -
189	117x	- print(x$mean_dp_start, digits = digits) -
190		- -
191	117x	- cat("\nFixed degradation parameter values:\n") -
192	117x	- if(length(x$fixed$value) == 0) cat("None\n") -
193	!	- else print(x$fixed, digits = digits) -
194		- -
195	117x	- cat("\nResults:\n\n") -
196	117x	- print(data.frame(AIC = x$AIC, BIC = x$BIC, logLik = x$logLik, -
197	117x	- row.names = " "), digits = digits, ...) -
198		- -
199	117x	- cat("\nOptimised, transformed parameters with symmetric confidence intervals:\n") -
200	117x	- print(x$confint_trans, digits = digits, ...) -
201		- -
202	117x	- if (nrow(x$confint_trans) > 1) { -
203	117x	- corr <- x$corFixed -
204	117x	- class(corr) <- "correlation" -
205	117x	- print(corr, title = "\nCorrelation:", rdig = digits, ...) -
206		- } -
207		- -
208	117x	- cat("\n") # Random effects -
209	117x	- print(summary(x$modelStruct), sigma = x$sigma, -
210	117x	- reEstimates = x$coef$random, digits = digits, verbose = verbose, ...) -
211		- -
212	117x	- cat("\nBacktransformed parameters with asymmetric confidence intervals:\n") -
213	117x	- print(x$confint_back, digits = digits, ...) -
214		- -
215		- -
216	117x	- printSFORB <- !is.null(x$SFORB) -
217	117x	- if(printSFORB){ -
218	!	- cat("\nEstimated Eigenvalues of SFORB model(s):\n") -
219	!	- print(x$SFORB, digits = digits,...) -
220		- } -
221		- -
222	117x	- printff <- !is.null(x$ff) -
223	117x	- if(printff){ -
224	!	- cat("\nResulting formation fractions:\n") -
225	!	- print(data.frame(ff = x$ff), digits = digits, ...) -
226		- } -
227		- -
228	117x	- printdistimes <- !is.null(x$distimes) -
229	117x	- if(printdistimes){ -
230	117x	- cat("\nEstimated disappearance times:\n") -
231	117x	- print(x$distimes, digits = digits, ...) -
232		- } -
233		- -
234	117x	- if (x$print_data){ -
235	!	- cat("\nData:\n") -
236	!	- print(format(x$data, digits = digits, ...), row.names = FALSE) -
237		- } -
238		- -
239	117x	- invisible(x) -
240		- } -

1		- utils::globalVariables("ds") -
2		- -
3		- #' Plot predictions from a fitted nonlinear mixed model obtained via an mmkin row object -
4		- #' -
5		- #' @param x An object of class [mixed.mmkin], [saem.mmkin] or [nlme.mmkin] -
6		- #' @param i A numeric index to select datasets for which to plot the individual predictions, -
7		- #' in case plots get too large -
8		- #' @inheritParams plot.mkinfit -
9		- #' @param standardized Should the residuals be standardized? Only takes effect if -
10		- #' `resplot = "time"`. -
11		- #' @param pop_curves Per default, one population curve is drawn in case -
12		- #' population parameters are fitted by the model, e.g. for saem objects. -
13		- #' In case there is a covariate model, the behaviour depends on the value -
14		- #' of 'covariates' -
15		- #' @param covariates Data frame with covariate values for all variables in -
16		- #' any covariate models in the object. If given, it overrides 'covariate_quantiles'. -
17		- #' Each line in the data frame will result in a line drawn for the population. -
18		- #' Rownames are used in the legend to label the lines. -
19		- #' @param covariate_quantiles This argument only has an effect if the fitted -
20		- #' object has covariate models. If so, the default is to show three population -
21		- #' curves, for the 5th percentile, the 50th percentile and the 95th percentile -
22		- #' of the covariate values used for fitting the model. -
23		- #' @note Covariate models are currently only supported for saem.mmkin objects. -
24		- #' @param pred_over Named list of alternative predictions as obtained -
25		- #' from [mkinpredict] with a compatible [mkinmod]. -
26		- #' @param test_log_parms Passed to [mean_degparms] in the case of an -
27		- #' [mixed.mmkin] object -
28		- #' @param conf.level Passed to [mean_degparms] in the case of an -
29		- #' [mixed.mmkin] object -
30		- #' @param default_log_parms Passed to [mean_degparms] in the case of an -
31		- #' [mixed.mmkin] object -
32		- #' @param rel.height.legend The relative height of the legend shown on top -
33		- #' @param rel.height.bottom The relative height of the bottom plot row -
34		- #' @param ymax Vector of maximum y axis values -
35		- #' @param ncol.legend Number of columns to use in the legend -
36		- #' @param nrow.legend Number of rows to use in the legend -
37		- #' @param resplot Should the residuals plotted against time or against -
38		- #' predicted values? -
39		- #' @param col_ds Colors used for plotting the observed data and the -
40		- #' corresponding model prediction lines for the different datasets. -
41		- #' @param pch_ds Symbols to be used for plotting the data. -
42		- #' @param lty_ds Line types to be used for the model predictions. -
43		- #' @importFrom stats coefficients -
44		- #' @return The function is called for its side effect. -
45		- #' @author Johannes Ranke -
46		- #' @examples -
47		- #' ds <- lapply(experimental_data_for_UBA_2019[6:10], -
48		- #' function(x) x$data[c("name", "time", "value")]) -
49		- #' names(ds) <- paste0("ds ", 6:10) -
50		- #' dfop_sfo <- mkinmod(parent = mkinsub("DFOP", "A1"), -
51		- #' A1 = mkinsub("SFO"), quiet = TRUE) -
52		- #' \dontrun{ -
53		- #' f <- mmkin(list("DFOP-SFO" = dfop_sfo), ds, quiet = TRUE) -
54		- #' plot(f[, 3:4], standardized = TRUE) -
55		- #' -
56		- #' # For this fit we need to increase pnlsMaxiter, and we increase the -
57		- #' # tolerance in order to speed up the fit for this example evaluation -
58		- #' # It still takes 20 seconds to run -
59		- #' f_nlme <- nlme(f, control = list(pnlsMaxIter = 120, tolerance = 1e-3)) -
60		- #' plot(f_nlme) -
61		- #' -
62		- #' f_saem <- saem(f, transformations = "saemix") -
63		- #' plot(f_saem) -
64		- #' -
65		- #' f_obs <- mmkin(list("DFOP-SFO" = dfop_sfo), ds, quiet = TRUE, error_model = "obs") -
66		- #' f_nlmix <- nlmix(f_obs) -
67		- #' plot(f_nlmix) -
68		- #' -
69		- #' # We can overlay the two variants if we generate predictions -
70		- #' pred_nlme <- mkinpredict(dfop_sfo, -
71		- #' f_nlme$bparms.optim[-1], -
72		- #' c(parent = f_nlme$bparms.optim[[1]], A1 = 0), -
73		- #' seq(0, 180, by = 0.2)) -
74		- #' plot(f_saem, pred_over = list(nlme = pred_nlme)) -
75		- #' } -
76		- #' @export -
77		- plot.mixed.mmkin <- function(x, -
78		- i = 1:ncol(x$mmkin), -
79		- obs_vars = names(x$mkinmod$map), -
80		- standardized = TRUE, -
81		- covariates = NULL, -
82		- covariate_quantiles = c(0.5, 0.05, 0.95), -
83		- xlab = "Time", -
84		- xlim = range(x$data$time), -
85		- resplot = c("predicted", "time"), -
86		- pop_curves = "auto", -
87		- pred_over = NULL, -
88		- test_log_parms = FALSE, -
89		- conf.level = 0.6, -
90		- default_log_parms = NA, -
91		- ymax = "auto", maxabs = "auto", -
92		- ncol.legend = ifelse(length(i) <= 3, length(i) + 1, ifelse(length(i) <= 8, 3, 4)), -
93		- nrow.legend = ceiling((length(i) + 1) / ncol.legend), -
94		- rel.height.legend = 0.02 + 0.07 * nrow.legend, -
95		- rel.height.bottom = 1.1, -
96		- pch_ds = 1:length(i), -
97		- col_ds = pch_ds + 1, -
98		- lty_ds = col_ds, -
99		- frame = TRUE, ... -
100		- ) -
101		- { -
102		- # Prepare parameters and data -
103	283x	- fit_1 <- x$mmkin[[1]] -
104	283x	- ds_names <- colnames(x$mmkin) -
105		- -
106	283x	- backtransform = TRUE -
107		- -
108	283x	- if (identical(class(x), "mixed.mmkin")) { -
109	65x	- if (identical(pop_curves, "auto")) { -
110	!	- pop_curves <- FALSE -
111		- } else { -
112	65x	- pop_curves <- TRUE -
113		- } -
114	65x	- if (pop_curves) { -
115	65x	- degparms_pop <- mean_degparms(x$mmkin, test_log_parms = test_log_parms, -
116	65x	- conf.level = conf.level, default_log_parms = default_log_parms) -
117		- } -
118		- -
119	65x	- degparms_tmp <- parms(x$mmkin, transformed = TRUE) -
120	65x	- degparms_i <- as.data.frame(t(degparms_tmp[setdiff(rownames(degparms_tmp), names(fit_1$errparms)), ])) -
121	65x	- residual_type = ifelse(standardized, "standardized", "residual") -
122	65x	- residuals <- x$data[[residual_type]] -
123		- } -
124		- -
125	283x	- if (inherits(x, "nlme.mmkin")) { -
126	65x	- if (identical(pop_curves, "auto")) { -
127	65x	- pop_curves <- TRUE -
128		- } else { -
129	!	- pop_curves <- FALSE -
130		- } -
131	65x	- degparms_i <- coefficients(x) -
132	65x	- degparms_pop <- nlme::fixef(x) -
133	65x	- residuals <- residuals(x, -
134	65x	- type = ifelse(standardized, "pearson", "response")) -
135		- } -
136		- -
137	283x	- if (inherits(x, "saem.mmkin")) { -
138	65x	- if (x$transformations == "saemix") backtransform = FALSE -
139	153x	- psi <- saemix::psi(x$so) -
140	153x	- rownames(psi) <- x$saemix_ds_order -
141	153x	- degparms_i <- psi[ds_names, ] -
142	153x	- degparms_i_names <- colnames(degparms_i) -
143	153x	- residual_type = ifelse(standardized, "standardized", "residual") -
144	153x	- residuals <- x$data[[residual_type]] -
145		- -
146	153x	- if (identical(pop_curves, "auto")) { -
147	153x	- if (length(x$covariate_models) == 0) { -
148	153x	- degparms_pop <- x$so@results@fixed.effects -
149	153x	- names(degparms_pop) <- degparms_i_names -
150	153x	- pop_curves <- TRUE -
151		- } else { -
152	!	- if (is.null(covariates)) { -
153	!	- covariates = as.data.frame( -
154	!	- apply(x$covariates, 2, quantile, -
155	!	- covariate_quantiles, simplify = FALSE)) -
156	!	- rownames(covariates) <- paste( -
157	!	- ifelse(length(x$covariate_models) == 1, -
158	!	- "Covariate", "Covariates"), -
159	!	- rownames(covariates)) -
160		- } -
161	!	- degparms_pop <- parms(x, covariates = covariates) -
162	!	- pop_curves <- TRUE -
163		- } -
164		- } else { -
165	!	- pop_curves <- FALSE -
166		- } -
167		- } -
168		- -
169	283x	- if (pop_curves) { -
170		- # Make sure degparms_pop is a matrix, columns corresponding to population curve(s) -
171	283x	- if (is.null(dim(degparms_pop))) { -
172	283x	- degparms_pop <- matrix(degparms_pop, ncol = 1, -
173	283x	- dimnames = list(names(degparms_pop), "Population")) -
174		- } -
175		- } -
176		- -
177	283x	- degparms_fixed <- fit_1$fixed$value -
178	283x	- names(degparms_fixed) <- rownames(fit_1$fixed) -
179	283x	- degparms_all <- cbind(as.matrix(degparms_i), -
180	283x	- matrix(rep(degparms_fixed, nrow(degparms_i)), -
181	283x	- ncol = length(degparms_fixed), -
182	283x	- nrow = nrow(degparms_i), byrow = TRUE)) -
183	283x	- degparms_all_names <- c(names(degparms_i), names(degparms_fixed)) -
184	283x	- colnames(degparms_all) <- degparms_all_names -
185		- -
186	283x	- odeini_names <- grep("_0$", degparms_all_names, value = TRUE) -
187	283x	- odeparms_names <- setdiff(degparms_all_names, odeini_names) -
188		- -
189	283x	- observed <- cbind(x$data[c("ds", "name", "time", "value")], -
190	283x	- residual = residuals) -
191		- -
192	283x	- solution_type = fit_1$solution_type -
193		- -
194	283x	- outtimes <- sort(unique(c(x$data$time, -
195	283x	- seq(xlim[1], xlim[2], length.out = 50)))) -
196		- -
197	283x	- pred_list <- lapply(i, function(ds_i) { -
198	2945x	- odeparms_trans <- degparms_all[ds_i, odeparms_names] -
199	2945x	- names(odeparms_trans) <- odeparms_names # needed if only one odeparm -
200	2945x	- if (backtransform) { -
201	2620x	- odeparms <- backtransform_odeparms(odeparms_trans, -
202	2620x	- x$mkinmod, -
203	2620x	- transform_rates = fit_1$transform_rates, -
204	2620x	- transform_fractions = fit_1$transform_fractions) -
205		- } else { -
206	325x	- odeparms <- odeparms_trans -
207		- } -
208		- -
209	2945x	- odeini <- degparms_all[ds_i, odeini_names] -
210	2945x	- names(odeini) <- gsub("_0", "", odeini_names) -
211		- -
212	2945x	- out <- mkinpredict(x$mkinmod, odeparms, odeini, -
213	2945x	- outtimes, solution_type = solution_type, -
214	2945x	- atol = fit_1$atol, rtol = fit_1$rtol) -
215		- }) -
216	283x	- names(pred_list) <- ds_names[i] -
217	283x	- pred_ds <- vctrs::vec_rbind(!!!pred_list, .names_to = "ds") -
218		- -
219	283x	- if (pop_curves) { -
220	283x	- pred_list_pop <- lapply(1:ncol(degparms_pop), function(cov_i) { -
221	283x	- degparms_all_pop_i <- c(degparms_pop[, cov_i], degparms_fixed) -
222	283x	- odeparms_pop_trans_i <- degparms_all_pop_i[odeparms_names] -
223	283x	- names(odeparms_pop_trans_i) <- odeparms_names # needed if only one odeparm -
224	283x	- if (backtransform) { -
225	218x	- odeparms_pop_i <- backtransform_odeparms(odeparms_pop_trans_i, -
226	218x	- x$mkinmod, -
227	218x	- transform_rates = fit_1$transform_rates, -
228	218x	- transform_fractions = fit_1$transform_fractions) -
229		- } else { -
230	65x	- odeparms_pop_i <- odeparms_pop_trans_i -
231		- } -
232		- -
233	283x	- odeini <- degparms_all_pop_i[odeini_names] -
234	283x	- names(odeini) <- gsub("_0", "", odeini_names) -
235		- -
236	283x	- out <- mkinpredict(x$mkinmod, odeparms_pop_i, odeini, -
237	283x	- outtimes, solution_type = solution_type, -
238	283x	- atol = fit_1$atol, rtol = fit_1$rtol) -
239		- }) -
240	283x	- names(pred_list_pop) <- colnames(degparms_pop) -
241		- -
242		- } else { -
243	!	- pred_list_pop <- NULL -
244		- } -
245		- -
246		- # Start of graphical section -
247	283x	- oldpar <- par(no.readonly = TRUE) -
248	283x	- on.exit(par(oldpar, no.readonly = TRUE)) -
249		- -
250	283x	- n_plot_rows = length(obs_vars) -
251	283x	- n_plots = n_plot_rows * 2 -
252		- -
253		- # Set relative plot heights, so the first plot row is the norm -
254	283x	- rel.heights <- if (n_plot_rows > 1) { -
255	218x	- c(rel.height.legend, c(rep(1, n_plot_rows - 1), rel.height.bottom)) -
256		- } else { -
257	65x	- c(rel.height.legend, 1) -
258		- } -
259		- -
260	283x	- layout_matrix = matrix(c(1, 1, 2:(n_plots + 1)), -
261	283x	- n_plot_rows + 1, 2, byrow = TRUE) -
262	283x	- layout(layout_matrix, heights = rel.heights) -
263		- -
264	283x	- par(mar = c(0.1, 2.1, 0.1, 2.1)) -
265		- -
266		- # Empty plot with legend -
267	!	- if (!is.null(pred_over)) lty_over <- seq(2, length.out = length(pred_over)) -
268	283x	- else lty_over <- NULL -
269	283x	- if (pop_curves) { -
270	283x	- if (is.null(covariates)) { -
271	283x	- lty_pop <- 1 -
272	283x	- names(lty_pop) <- "Population" -
273		- } else { -
274	!	- lty_pop <- 1:nrow(covariates) -
275	!	- names(lty_pop) <- rownames(covariates) -
276		- } -
277		- } else { -
278	!	- lty_pop <- NULL -
279		- } -
280	283x	- n_pop_over <- length(lty_pop) + length(lty_over) -
281		- -
282	283x	- plot(0, type = "n", axes = FALSE, ann = FALSE) -
283	283x	- legend("center", bty = "n", ncol = ncol.legend, -
284	283x	- legend = c(names(lty_pop), names(pred_over), ds_names[i]), -
285	283x	- lty = c(lty_pop, lty_over, lty_ds), -
286	283x	- lwd = c(rep(2, n_pop_over), rep(1, length(i))), -
287	283x	- col = c(rep(1, n_pop_over), col_ds), -
288	283x	- pch = c(rep(NA, n_pop_over), pch_ds)) -
289		- -
290	283x	- resplot <- match.arg(resplot) -
291		- -
292		- # Loop plot rows -
293	283x	- for (plot_row in 1:n_plot_rows) { -
294		- -
295	501x	- obs_var <- obs_vars[plot_row] -
296	501x	- observed_row <- subset(observed, name == obs_var) -
297		- -
298		- # Set ylim to sensible default, or use ymax -
299	501x	- if (identical(ymax, "auto")) { -
300	501x	- ylim_row = c(0, -
301	501x	- max(c(observed_row$value, pred_ds[[obs_var]]), na.rm = TRUE)) -
302		- } else { -
303	!	- ylim_row = c(0, ymax[plot_row]) -
304		- } -
305		- -
306		- # Margins for bottom row of plots when we have more than one row -
307		- # This is the only row that needs to show the x axis legend -
308	501x	- if (plot_row == n_plot_rows) { -
309	283x	- par(mar = c(5.1, 4.1, 1.1, 2.1)) -
310		- } else { -
311	218x	- par(mar = c(3.0, 4.1, 1.1, 2.1)) -
312		- } -
313		- -
314	501x	- plot(0, type = "n", -
315	501x	- xlim = xlim, ylim = ylim_row, -
316	501x	- xlab = xlab, ylab = paste("Residues", obs_var), frame = frame) -
317		- -
318	501x	- if (!is.null(pred_over)) { -
319	!	- for (i_over in seq_along(pred_over)) { -
320	!	- pred_frame <- as.data.frame(pred_over[[i_over]]) -
321	!	- lines(pred_frame$time, pred_frame[[obs_var]], -
322	!	- lwd = 2, lty = lty_over[i_over]) -
323		- } -
324		- } -
325		- -
326	501x	- for (ds_i in seq_along(i)) { -
327	4915x	- points(subset(observed_row, ds == ds_names[ds_i], c("time", "value")), -
328	4915x	- col = col_ds[ds_i], pch = pch_ds[ds_i]) -
329	4915x	- lines(subset(pred_ds, ds == ds_names[ds_i], c("time", obs_var)), -
330	4915x	- col = col_ds[ds_i], lty = lty_ds[ds_i]) -
331		- } -
332		- -
333	501x	- if (pop_curves) { -
334	501x	- for (cov_i in seq_along(pred_list_pop)) { -
335	501x	- cov_name <- names(pred_list_pop)[cov_i] -
336	501x	- lines( -
337	501x	- pred_list_pop[[cov_i]][, "time"], -
338	501x	- pred_list_pop[[cov_i]][, obs_var], -
339	501x	- type = "l", lwd = 2, lty = lty_pop[cov_i]) -
340		- } -
341		- } -
342		- -
343	501x	- if (identical(maxabs, "auto")) { -
344	283x	- maxabs = max(abs(observed_row$residual), na.rm = TRUE) -
345		- } -
346		- -
347	501x	- if (identical(resplot, "time")) { -
348	!	- plot(0, type = "n", xlim = xlim, xlab = "Time", -
349	!	- ylim = c(-1.2 * maxabs, 1.2 * maxabs), -
350	!	- ylab = if (standardized) "Standardized residual" else "Residual", -
351	!	- frame = frame) -
352		- -
353	!	- abline(h = 0, lty = 2) -
354		- -
355	!	- for (ds_i in seq_along(i)) { -
356	!	- points(subset(observed_row, ds == ds_names[ds_i], c("time", "residual")), -
357	!	- col = col_ds[ds_i], pch = pch_ds[ds_i]) -
358		- } -
359		- } -
360		- -
361	501x	- if (identical(resplot, "predicted")) { -
362	501x	- plot(0, type = "n", -
363	501x	- xlim = c(0, max(pred_ds[[obs_var]])), -
364	501x	- xlab = "Predicted", -
365	501x	- ylim = c(-1.2 * maxabs, 1.2 * maxabs), -
366	501x	- ylab = if (standardized) "Standardized residual" else "Residual", -
367	501x	- frame = frame) -
368		- -
369	501x	- abline(h = 0, lty = 2) -
370		- -
371	501x	- for (ds_i in seq_along(i)) { -
372	4915x	- observed_row_ds <- merge( -
373	4915x	- subset(observed_row, ds == ds_names[ds_i], c("time", "residual")), -
374	4915x	- subset(pred_ds, ds == ds_names[ds_i], c("time", obs_var))) -
375	4915x	- points(observed_row_ds[c(3, 2)], -
376	4915x	- col = col_ds[ds_i], pch = pch_ds[ds_i]) -
377		- } -
378		- } -
379		- } -
380		- } -

1		- #' Summary method for class "mkinfit" -
2		- #' -
3		- #' Lists model equations, initial parameter values, optimised parameters with -
4		- #' some uncertainty statistics, the chi2 error levels calculated according to -
5		- #' FOCUS guidance (2006) as defined therein, formation fractions, DT50 values -
6		- #' and optionally the data, consisting of observed, predicted and residual -
7		- #' values. -
8		- #' -
9		- #' @param object an object of class [mkinfit]. -
10		- #' @param x an object of class \code{summary.mkinfit}. -
11		- #' @param data logical, indicating whether the data should be included in the -
12		- #' summary. -
13		- #' @param distimes logical, indicating whether DT50 and DT90 values should be -
14		- #' included. -
15		- #' @param alpha error level for confidence interval estimation from t -
16		- #' distribution -
17		- #' @param digits Number of digits to use for printing -
18		- #' @param \dots optional arguments passed to methods like \code{print}. -
19		- #' @importFrom stats qt pt cov2cor -
20		- #' @return The summary function returns a list with components, among others -
21		- #' \item{version, Rversion}{The mkin and R versions used} -
22		- #' \item{date.fit, date.summary}{The dates where the fit and the summary were -
23		- #' produced} -
24		- #' \item{diffs}{The differential equations used in the model} -
25		- #' \item{use_of_ff}{Was maximum or minimum use made of formation fractions} -
26		- #' \item{bpar}{Optimised and backtransformed -
27		- #' parameters} -
28		- #' \item{data}{The data (see Description above).} -
29		- #' \item{start}{The starting values and bounds, if applicable, for optimised -
30		- #' parameters.} -
31		- #' \item{fixed}{The values of fixed parameters.} -
32		- #' \item{errmin }{The chi2 error levels for -
33		- #' each observed variable.} -
34		- #' \item{bparms.ode}{All backtransformed ODE -
35		- #' parameters, for use as starting parameters for related models.} -
36		- #' \item{errparms}{Error model parameters.} -
37		- #' \item{ff}{The estimated formation fractions derived from the fitted -
38		- #' model.} -
39		- #' \item{distimes}{The DT50 and DT90 values for each observed variable.} -
40		- #' \item{SFORB}{If applicable, eigenvalues and fractional eigenvector component -
41		- #' g of SFORB systems in the model.} -
42		- #' The print method is called for its side effect, i.e. printing the summary. -
43		- #' @author Johannes Ranke -
44		- #' @references FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence -
45		- #' and Degradation Kinetics from Environmental Fate Studies on Pesticides in -
46		- #' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, -
47		- #' EC Document Reference Sanco/10058/2005 version 2.0, 434 pp, -
48		- #' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} -
49		- #' @examples -
50		- #' -
51		- #' summary(mkinfit("SFO", FOCUS_2006_A, quiet = TRUE)) -
52		- #' -
53		- #' @export -
54		- summary.mkinfit <- function(object, data = TRUE, distimes = TRUE, alpha = 0.05, ...) { -
55	52158x	- param <- object$par -
56	52158x	- pnames <- names(param) -
57	52158x	- bpnames <- names(object$bparms.optim) -
58	52158x	- epnames <- names(object$errparms) -
59	52158x	- p <- length(param) -
60	52158x	- mod_vars <- names(object$mkinmod$diffs) -
61	52158x	- covar <- try(solve(object$hessian), silent = TRUE) -
62	52158x	- covar_notrans <- try(solve(object$hessian_notrans), silent = TRUE) -
63	52158x	- rdf <- object$df.residual -
64		- -
65	52158x	- if (!is.numeric(covar) \| is.na(covar[1])) { -
66	!	- covar <- NULL -
67	!	- se <- lci <- uci <- rep(NA, p) -
68		- } else { -
69	52158x	- rownames(covar) <- colnames(covar) <- pnames -
70	52158x	- se <- sqrt(diag(covar)) -
71	52158x	- lci <- param + qt(alpha/2, rdf) * se -
72	52158x	- uci <- param + qt(1-alpha/2, rdf) * se -
73		- } -
74		- -
75	52158x	- beparms.optim <- c(object$bparms.optim, object$par[epnames]) -
76	52158x	- if (!is.numeric(covar_notrans) \| is.na(covar_notrans[1])) { -
77	88x	- covar_notrans <- NULL -
78	88x	- se_notrans <- tval <- pval <- rep(NA, p) -
79		- } else { -
80	52070x	- rownames(covar_notrans) <- colnames(covar_notrans) <- c(bpnames, epnames) -
81	52070x	- se_notrans <- sqrt(diag(covar_notrans)) -
82	52070x	- tval <- beparms.optim / se_notrans -
83	52070x	- pval <- pt(abs(tval), rdf, lower.tail = FALSE) -
84		- } -
85		- -
86	52158x	- names(se) <- pnames -
87		- -
88	52158x	- param <- cbind(param, se, lci, uci) -
89	52158x	- dimnames(param) <- list(pnames, c("Estimate", "Std. Error", "Lower", "Upper")) -
90		- -
91	52158x	- bparam <- cbind(Estimate = beparms.optim, se_notrans, -
92	52158x	- "t value" = tval, "Pr(>t)" = pval, Lower = NA, Upper = NA) -
93		- -
94		- # Transform boundaries of CI for one parameter at a time, -
95		- # with the exception of sets of formation fractions (single fractions are OK). -
96	52158x	- f_names_skip <- character(0) -
97	52158x	- for (box in mod_vars) { # Figure out sets of fractions to skip -
98	70671x	- f_names <- grep(paste("^f", box, sep = "_"), pnames, value = TRUE) -
99	70671x	- n_paths <- length(f_names) -
100	1135x	- if (n_paths > 1) f_names_skip <- c(f_names_skip, f_names) -
101		- } -
102		- -
103	52158x	- for (pname in pnames) { -
104	293621x	- if (!pname %in% f_names_skip) { -
105	290217x	- par.lower <- param[pname, "Lower"] -
106	290217x	- par.upper <- param[pname, "Upper"] -
107	290217x	- names(par.lower) <- names(par.upper) <- pname -
108	290217x	- bpl <- backtransform_odeparms(par.lower, object$mkinmod, -
109	290217x	- object$transform_rates, -
110	290217x	- object$transform_fractions) -
111	290217x	- bpu <- backtransform_odeparms(par.upper, object$mkinmod, -
112	290217x	- object$transform_rates, -
113	290217x	- object$transform_fractions) -
114	290217x	- bparam[names(bpl), "Lower"] <- bpl -
115	290217x	- bparam[names(bpu), "Upper"] <- bpu -
116		- } -
117		- } -
118	52158x	- bparam[epnames, c("Lower", "Upper")] <- param[epnames, c("Lower", "Upper")] -
119		- -
120	52158x	- ans <- list( -
121	52158x	- version = as.character(utils::packageVersion("mkin")), -
122	52158x	- Rversion = paste(R.version$major, R.version$minor, sep="."), -
123	52158x	- date.fit = object$date, -
124	52158x	- date.summary = date(), -
125	52158x	- solution_type = object$solution_type, -
126	52158x	- warnings = object$summary_warnings, -
127	52158x	- use_of_ff = object$mkinmod$use_of_ff, -
128	52158x	- error_model_algorithm = object$error_model_algorithm, -
129	52158x	- df = c(p, rdf), -
130	52158x	- covar = covar, -
131	52158x	- covar_notrans = covar_notrans, -
132	52158x	- err_mod = object$err_mod, -
133	52158x	- niter = object$iterations, -
134	52158x	- calls = object$calls, -
135	52158x	- time = object$time, -
136	52158x	- par = param, -
137	52158x	- bpar = bparam) -
138		- -
139	52158x	- if (!is.null(object$version)) { -
140	52158x	- ans$fit_version <- object$version -
141	52158x	- ans$fit_Rversion <- object$Rversion -
142	52158x	- if (ans$fit_version >= "0.9.49.6") { -
143	52156x	- ans$AIC = AIC(object) -
144	52156x	- ans$BIC = BIC(object) -
145	52156x	- ans$logLik = logLik(object) -
146		- } -
147		- } -
148		- -
149	52158x	- ans$diffs <- object$mkinmod$diffs -
150	52158x	- if(data) ans$data <- object$data -
151	52158x	- ans$start <- object$start -
152	52158x	- ans$start_transformed <- object$start_transformed -
153		- -
154	52158x	- ans$fixed <- object$fixed -
155		- -
156	52158x	- ans$errmin <- mkinerrmin(object, alpha = 0.05) -
157		- -
158	52158x	- if (object$calls > 0) { -
159	52158x	- if (!is.null(ans$covar)){ -
160	52158x	- Corr <- cov2cor(ans$covar) -
161	52158x	- rownames(Corr) <- colnames(Corr) <- rownames(ans$par) -
162	52158x	- ans$Corr <- Corr -
163		- } else { -
164	!	- warning("Could not calculate correlation; no covariance matrix") -
165		- } -
166		- } -
167		- -
168	52158x	- ans$bparms.ode <- object$bparms.ode -
169	52158x	- ans$shapiro.p <- object$shapiro.p -
170	52158x	- ep <- endpoints(object) -
171	52158x	- if (length(ep$ff) != 0) -
172	15612x	- ans$ff <- ep$ff -
173	52158x	- if (distimes) ans$distimes <- ep$distimes -
174	2442x	- if (length(ep$SFORB) != 0) ans$SFORB <- ep$SFORB -
175	43972x	- if (!is.null(object$d_3_message)) ans$d_3_message <- object$d_3_message -
176	52158x	- class(ans) <- "summary.mkinfit" -
177	52158x	- return(ans) -
178		- } -
179		- -
180		- #' @rdname summary.mkinfit -
181		- #' @export -
182		- print.summary.mkinfit <- function(x, digits = max(3, getOption("digits") - 3), ...) { -
183	4x	- if (is.null(x$fit_version)) { -
184	!	- cat("mkin version: ", x$version, "\n") -
185	!	- cat("R version: ", x$Rversion, "\n") -
186		- } else { -
187	4x	- cat("mkin version used for fitting: ", x$fit_version, "\n") -
188	4x	- cat("R version used for fitting: ", x$fit_Rversion, "\n") -
189		- } -
190		- -
191	4x	- cat("Date of fit: ", x$date.fit, "\n") -
192	4x	- cat("Date of summary:", x$date.summary, "\n") -
193		- -
194	4x	- cat("\nEquations:\n") -
195	4x	- nice_diffs <- gsub("^(d.*) =", "\\1/dt =", x[["diffs"]]) -
196	4x	- writeLines(strwrap(nice_diffs, exdent = 11)) -
197	4x	- df <- x$df -
198	4x	- rdf <- df[2] -
199		- -
200	4x	- cat("\nModel predictions using solution type", x$solution_type, "\n") -
201		- -
202	4x	- cat("\nFitted using", x$calls, "model solutions performed in", x$time[["elapsed"]], "s\n") -
203		- -
204	4x	- if (!is.null(x$err_mod)) { -
205	4x	- cat("\nError model: ") -
206	4x	- cat(switch(x$err_mod, -
207	4x	- const = "Constant variance", -
208	4x	- obs = "Variance unique to each observed variable", -
209	4x	- tc = "Two-component variance function"), "\n") -
210		- -
211	4x	- cat("\nError model algorithm:", x$error_model_algorithm, "\n") -
212	!	- if (!is.null(x$d_3_message)) cat(x$d_3_message, "\n") -
213		- } -
214		- -
215	4x	- cat("\nStarting values for parameters to be optimised:\n") -
216	4x	- print(x$start) -
217		- -
218	4x	- cat("\nStarting values for the transformed parameters actually optimised:\n") -
219	4x	- print(x$start_transformed) -
220		- -
221	4x	- cat("\nFixed parameter values:\n") -
222	1x	- if(length(x$fixed$value) == 0) cat("None\n") -
223	3x	- else print(x$fixed) -
224		- -
225		- # We used to only have one warning - show this for summarising old objects -
226	!	- if (!is.null(x[["warning"]])) cat("\n\nWarning:", x$warning, "\n\n") -
227		- -
228	4x	- if (length(x$warnings) > 0) { -
229	!	- cat("\n\nWarning(s):", "\n") -
230	!	- cat(x$warnings, sep = "\n") -
231		- } -
232		- -
233	4x	- if (!is.null(x$AIC)) { -
234	4x	- cat("\nResults:\n\n") -
235	4x	- print(data.frame(AIC = x$AIC, BIC = x$BIC, logLik = x$logLik, -
236	4x	- row.names = " ")) -
237		- } -
238		- -
239	4x	- cat("\nOptimised, transformed parameters with symmetric confidence intervals:\n") -
240	4x	- print(signif(x$par, digits = digits)) -
241		- -
242	4x	- if (x$calls > 0) { -
243	4x	- cat("\nParameter correlation:\n") -
244	4x	- if (!is.null(x$covar)){ -
245	4x	- print(x$Corr, digits = digits, ...) -
246		- } else { -
247	!	- cat("No covariance matrix") -
248		- } -
249		- } -
250		- -
251	4x	- cat("\nBacktransformed parameters:\n") -
252	4x	- cat("Confidence intervals for internally transformed parameters are asymmetric.\n") -
253	4x	- if ((x$version) < "0.9-36") { -
254	!	- cat("To get the usual (questionable) t-test, upgrade mkin and repeat the fit.\n") -
255	!	- print(signif(x$bpar, digits = digits)) -
256		- } else { -
257	4x	- cat("t-test (unrealistically) based on the assumption of normal distribution\n") -
258	4x	- cat("for estimators of untransformed parameters.\n") -
259	4x	- print(signif(x$bpar[, c(1, 3, 4, 5, 6)], digits = digits)) -
260		- } -
261		- -
262	4x	- cat("\nFOCUS Chi2 error levels in percent:\n") -
263	4x	- x$errmin$err.min <- 100 * x$errmin$err.min -
264	4x	- print(x$errmin, digits=digits,...) -
265		- -
266	4x	- printSFORB <- !is.null(x$SFORB) -
267	4x	- if(printSFORB){ -
268	1x	- cat("\nEstimated Eigenvalues and DFOP g parameter of SFORB model(s):\n") -
269	1x	- print(x$SFORB, digits=digits,...) -
270		- } -
271		- -
272	4x	- printff <- !is.null(x$ff) -
273	4x	- if(printff){ -
274	3x	- cat("\nResulting formation fractions:\n") -
275	3x	- print(data.frame(ff = x$ff), digits=digits,...) -
276		- } -
277		- -
278	4x	- printdistimes <- !is.null(x$distimes) -
279	4x	- if(printdistimes){ -
280	4x	- cat("\nEstimated disappearance times:\n") -
281	4x	- print(x$distimes, digits=digits,...) -
282		- } -
283		- -
284	4x	- printdata <- !is.null(x$data) -
285	4x	- if (printdata){ -
286	4x	- cat("\nData:\n") -
287	4x	- print(format(x$data, digits = digits, ...), row.names = FALSE) -
288		- } -
289		- -
290	4x	- invisible(x) -
291		- } -

1		- utils::globalVariables(c("type", "variable", "observed")) -
2		- -
3		- #' Plot the observed data and the fitted model of an mkinfit object -
4		- #' -
5		- #' Solves the differential equations with the optimised and fixed parameters -
6		- #' from a previous successful call to \code{\link{mkinfit}} and plots the -
7		- #' observed data together with the solution of the fitted model. -
8		- #' -
9		- #' If the current plot device is a \code{\link[tikzDevice]{tikz}} device, then -
10		- #' latex is being used for the formatting of the chi2 error level, if -
11		- #' \code{show_errmin = TRUE}. -
12		- #' -
13		- #' @aliases plot.mkinfit plot_sep plot_res plot_err -
14		- #' @param x Alias for fit introduced for compatibility with the generic S3 -
15		- #' method. -
16		- #' @param fit An object of class \code{\link{mkinfit}}. -
17		- #' @param obs_vars A character vector of names of the observed variables for -
18		- #' which the data and the model should be plotted. Defauls to all observed -
19		- #' variables in the model. -
20		- #' @param xlab Label for the x axis. -
21		- #' @param ylab Label for the y axis. -
22		- #' @param xlim Plot range in x direction. -
23		- #' @param ylim Plot range in y direction. If given as a list, plot ranges -
24		- #' for the different plot rows can be given for row layout. -
25		- #' @param col_obs Colors used for plotting the observed data and the -
26		- #' corresponding model prediction lines. -
27		- #' @param pch_obs Symbols to be used for plotting the data. -
28		- #' @param lty_obs Line types to be used for the model predictions. -
29		- #' @param add Should the plot be added to an existing plot? -
30		- #' @param legend Should a legend be added to the plot? -
31		- #' @param show_residuals Should residuals be shown? If only one plot of the -
32		- #' fits is shown, the residual plot is in the lower third of the plot. -
33		- #' Otherwise, i.e. if "sep_obs" is given, the residual plots will be located -
34		- #' to the right of the plots of the fitted curves. If this is set to -
35		- #' 'standardized', a plot of the residuals divided by the standard deviation -
36		- #' given by the fitted error model will be shown. -
37		- #' @param standardized When calling 'plot_res', should the residuals be -
38		- #' standardized in the residual plot? -
39		- #' @param show_errplot Should squared residuals and the error model be shown? -
40		- #' If only one plot of the fits is shown, this plot is in the lower third of -
41		- #' the plot. Otherwise, i.e. if "sep_obs" is given, the residual plots will -
42		- #' be located to the right of the plots of the fitted curves. -
43		- #' @param maxabs Maximum absolute value of the residuals. This is used for the -
44		- #' scaling of the y axis and defaults to "auto". -
45		- #' @param sep_obs Should the observed variables be shown in separate subplots? -
46		- #' If yes, residual plots requested by "show_residuals" will be shown next -
47		- #' to, not below the plot of the fits. -
48		- #' @param rel.height.middle The relative height of the middle plot, if more -
49		- #' than two rows of plots are shown. -
50		- #' @param row_layout Should we use a row layout where the residual plot or the -
51		- #' error model plot is shown to the right? -
52		- #' @param lpos Position(s) of the legend(s). Passed to \code{\link{legend}} as -
53		- #' the first argument. If not length one, this should be of the same length -
54		- #' as the obs_var argument. -
55		- #' @param inset Passed to \code{\link{legend}} if applicable. -
56		- #' @param show_errmin Should the FOCUS chi2 error value be shown in the upper -
57		- #' margin of the plot? -
58		- #' @param errmin_digits The number of significant digits for rounding the FOCUS -
59		- #' chi2 error percentage. -
60		- #' @param frame Should a frame be drawn around the plots? -
61		- #' @param \dots Further arguments passed to \code{\link{plot}}. -
62		- #' @import graphics -
63		- #' @importFrom grDevices dev.cur -
64		- #' @return The function is called for its side effect. -
65		- #' @author Johannes Ranke -
66		- #' @examples -
67		- #' -
68		- #' # One parent compound, one metabolite, both single first order, path from -
69		- #' # parent to sink included -
70		- #' \dontrun{ -
71		- #' SFO_SFO <- mkinmod(parent = mkinsub("SFO", "m1", full = "Parent"), -
72		- #' m1 = mkinsub("SFO", full = "Metabolite M1" )) -
73		- #' fit <- mkinfit(SFO_SFO, FOCUS_2006_D, quiet = TRUE) -
74		- #' fit <- mkinfit(SFO_SFO, FOCUS_2006_D, quiet = TRUE, error_model = "tc") -
75		- #' plot(fit) -
76		- #' plot_res(fit) -
77		- #' plot_res(fit, standardized = FALSE) -
78		- #' plot_err(fit) -
79		- #' -
80		- #' # Show the observed variables separately, with residuals -
81		- #' plot(fit, sep_obs = TRUE, show_residuals = TRUE, lpos = c("topright", "bottomright"), -
82		- #' show_errmin = TRUE) -
83		- #' -
84		- #' # The same can be obtained with less typing, using the convenience function plot_sep -
85		- #' plot_sep(fit, lpos = c("topright", "bottomright")) -
86		- #' -
87		- #' # Show the observed variables separately, with the error model -
88		- #' plot(fit, sep_obs = TRUE, show_errplot = TRUE, lpos = c("topright", "bottomright"), -
89		- #' show_errmin = TRUE) -
90		- #' } -
91		- #' -
92		- #' @export -
93		- plot.mkinfit <- function(x, fit = x, -
94		- obs_vars = names(fit$mkinmod$map), -
95		- xlab = "Time", ylab = "Residue", -
96		- xlim = range(fit$data$time), -
97		- ylim = "default", -
98		- col_obs = 1:length(obs_vars), -
99		- pch_obs = col_obs, -
100		- lty_obs = rep(1, length(obs_vars)), -
101		- add = FALSE, legend = !add, -
102		- show_residuals = FALSE, -
103		- show_errplot = FALSE, -
104		- maxabs = "auto", -
105		- sep_obs = FALSE, rel.height.middle = 0.9, -
106		- row_layout = FALSE, -
107		- lpos = "topright", inset = c(0.05, 0.05), -
108		- show_errmin = FALSE, errmin_digits = 3, -
109		- frame = TRUE, ...) -
110		- { -
111	1503x	- if (identical(show_residuals, "standardized")) { -
112	!	- show_residuals <- TRUE -
113	!	- standardized <- TRUE -
114		- } else { -
115	1503x	- standardized <- FALSE -
116		- } -
117		- -
118	!	- if (add && show_residuals) stop("If adding to an existing plot we can not show residuals") -
119	!	- if (add && show_errplot) stop("If adding to an existing plot we can not show the error model plot") -
120	!	- if (show_residuals && show_errplot) stop("We can either show residuals over time or the error model plot, not both") -
121	!	- if (add && sep_obs) stop("If adding to an existing plot we can not show observed variables separately") -
122		- -
123		- -
124	1503x	- solution_type = fit$solution_type -
125	1503x	- parms.all <- c(fit$bparms.optim, fit$bparms.fixed) -
126		- -
127	1503x	- ininames <- c( -
128	1503x	- rownames(subset(fit$start, type == "state")), -
129	1503x	- rownames(subset(fit$fixed, type == "state"))) -
130	1503x	- odeini <- parms.all[ininames] -
131		- -
132		- # Order initial state variables -
133	1503x	- names(odeini) <- sub("_0", "", names(odeini)) -
134	1503x	- odeini <- odeini[names(fit$mkinmod$diffs)] -
135		- -
136	1503x	- outtimes <- seq(xlim[1], xlim[2], length.out=100) -
137		- -
138	1503x	- odenames <- c( -
139	1503x	- rownames(subset(fit$start, type == "deparm")), -
140	1503x	- rownames(subset(fit$fixed, type == "deparm"))) -
141	1503x	- odeparms <- parms.all[odenames] -
142		- -
143		- -
144	1503x	- if (solution_type == "deSolve" & !is.null(fit$mkinmod$cf)) { -
145	140x	- fit$mkinmod[["symbols"]] <- deSolve::checkDLL(dllname = fit$mkinmod$dll_info[["name"]], -
146	140x	- func = "diffs", initfunc = "initpar", -
147	140x	- jacfunc = NULL, nout = 0, outnames = NULL) -
148		- } -
149	1503x	- out <- mkinpredict(fit$mkinmod, odeparms, odeini, outtimes, -
150	1503x	- solution_type = solution_type, atol = fit$atol, rtol = fit$rtol) -
151		- -
152	1503x	- out <- as.data.frame(out) -
153		- -
154	1503x	- names(col_obs) <- names(pch_obs) <- names(lty_obs) <- obs_vars -
155		- -
156		- # Create a plot layout only if not to be added to an existing plot -
157		- # or only a single plot is requested (e.g. by plot.mmkin) -
158	1503x	- do_layout = FALSE -
159	485x	- if (show_residuals \| sep_obs \| show_errplot) do_layout = TRUE -
160	1503x	- n_plot_rows = if (sep_obs) length(obs_vars) else 1 -
161		- -
162	1503x	- if (do_layout) { -
163		- # Layout should be restored afterwards -
164	485x	- oldpar <- par(no.readonly = TRUE) -
165	485x	- on.exit(par(oldpar, no.readonly = TRUE)) -
166		- -
167		- # If the observed variables are shown separately, or if requested, do row layout -
168	485x	- if (sep_obs \| row_layout) { -
169	415x	- row_layout <- TRUE -
170	415x	- n_plot_cols = if (show_residuals \| show_errplot) 2 else 1 -
171	415x	- n_plots = n_plot_rows * n_plot_cols -
172		- -
173		- # Set relative plot heights, so the first and the last plot are the norm -
174		- # and the middle plots (if n_plot_rows >2) are smaller by rel.height.middle -
175	415x	- rel.heights <- if (n_plot_rows > 2) c(1, rep(rel.height.middle, n_plot_rows - 2), 1) -
176	415x	- else rep(1, n_plot_rows) -
177	415x	- layout_matrix = matrix(1:n_plots, -
178	415x	- n_plot_rows, n_plot_cols, byrow = TRUE) -
179	415x	- layout(layout_matrix, heights = rel.heights) -
180		- } else { # else show residuals in the lower third to keep compatibility -
181	70x	- layout(matrix(c(1, 2), 2, 1), heights = c(2, 1.3)) -
182	70x	- par(mar = c(3, 4, 4, 2) + 0.1) -
183		- } -
184		- } -
185		- -
186		- # Replicate legend position argument if necessary -
187	1503x	- if (length(lpos) == 1) lpos = rep(lpos, n_plot_rows) -
188		- -
189		- # Loop over plot rows -
190	1503x	- for (plot_row in 1:n_plot_rows) { -
191		- -
192	1503x	- row_obs_vars = if (sep_obs) obs_vars[plot_row] else obs_vars -
193		- -
194		- # Set ylim to sensible default, or to the specified value -
195	1503x	- if (is.list(ylim)) { -
196	!	- ylim_row <- ylim[[plot_row]] -
197		- } else { -
198	1503x	- if (ylim[[1]] == "default") { -
199	1503x	- ylim_row = c(0, max(c(subset(fit$data, variable %in% row_obs_vars)$observed, -
200	1503x	- unlist(out[row_obs_vars])), na.rm = TRUE)) -
201		- } else { -
202	!	- ylim_row = ylim -
203		- } -
204		- } -
205		- -
206	1503x	- if (row_layout) { -
207		- # Margins for top row of plots when we have more than one row -
208		- # Reduce bottom margin by 2.1 - hides x axis legend -
209	415x	- if (plot_row == 1 & n_plot_rows > 1) { -
210	!	- par(mar = c(3.0, 4.1, 4.1, 2.1)) -
211		- } -
212		- -
213		- # Margins for middle rows of plots, if any -
214	415x	- if (plot_row > 1 & plot_row < n_plot_rows) { -
215		- # Reduce top margin by 2 after the first plot as we have no main title, -
216		- # reduced plot height, therefore we need rel.height.middle in the layout -
217	!	- par(mar = c(3.0, 4.1, 2.1, 2.1)) -
218		- } -
219		- -
220		- # Margins for bottom row of plots when we have more than one row -
221	415x	- if (plot_row == n_plot_rows & n_plot_rows > 1) { -
222		- # Restore bottom margin for last plot to show x axis legend -
223	!	- par(mar = c(5.1, 4.1, 2.1, 2.1)) -
224		- } -
225		- } -
226		- -
227		- # Set up the main plot if not to be added to an existing plot -
228	1503x	- if (add == FALSE) { -
229	1503x	- plot(0, type="n", -
230	1503x	- xlim = xlim, ylim = ylim_row, -
231	1503x	- xlab = xlab, ylab = ylab, frame = frame, ...) -
232		- } -
233		- -
234		- # Plot the data -
235	1503x	- for (obs_var in row_obs_vars) { -
236	1708x	- points(subset(fit$data, variable == obs_var, c(time, observed)), -
237	1708x	- pch = pch_obs[obs_var], col = col_obs[obs_var]) -
238		- } -
239		- -
240		- # Plot the model output -
241	1503x	- matlines(out$time, out[row_obs_vars], col = col_obs[row_obs_vars], lty = lty_obs[row_obs_vars]) -
242		- -
243	1503x	- if (legend == TRUE) { -
244		- # Get full names from model definition if they are available -
245	695x	- legend_names = lapply(row_obs_vars, function(x) { -
246	900x	- if (!is.null(fit$mkinmod$spec[[x]]$full_name)) -
247	410x	- if (is.na(fit$mkinmod$spec[[x]]$full_name)) x -
248	!	- else fit$mkinmod$spec[[x]]$full_name -
249	490x	- else x -
250		- }) -
251	695x	- legend(lpos[plot_row], inset= inset, legend = legend_names, -
252	695x	- col = col_obs[row_obs_vars], pch = pch_obs[row_obs_vars], lty = lty_obs[row_obs_vars]) -
253		- } -
254		- -
255		- # Show chi2 error value if requested -
256	1503x	- if (show_errmin) { -
257	70x	- if (length(row_obs_vars) == 1) { -
258	70x	- errmin_var = row_obs_vars -
259		- } else { -
260	!	- errmin_var = "All data" -
261	!	- if (length(row_obs_vars) != length(fit$mkinmod$map)) { -
262	!	- warning("Showing chi2 error level for all data, but only ", -
263	!	- row_obs_vars, " were selected for plotting") -
264		- } -
265		- } -
266		- -
267	70x	- chi2 <- signif(100 * mkinerrmin(fit)[errmin_var, "err.min"], errmin_digits) -
268		- # Use LateX if the current plotting device is tikz -
269	70x	- if (names(dev.cur()) == "tikz output") { -
270	!	- chi2_text <- paste0("$\\chi^2$ error level = ", chi2, "\\%") -
271		- } else { -
272	70x	- chi2_perc <- paste0(chi2, "%") -
273	70x	- chi2_text <- bquote(chi^2 ~ "error level" == .(chi2_perc)) -
274		- } -
275	70x	- mtext(chi2_text, cex = 0.7, line = 0.4) -
276		- } -
277		- -
278	1503x	- if (do_layout & !row_layout) { -
279	70x	- par(mar = c(5, 4, 0, 2) + 0.1) -
280		- } -
281		- -
282		- # Show residuals if requested -
283	1503x	- if (show_residuals) { -
284	280x	- mkinresplot(fit, obs_vars = row_obs_vars, standardized = standardized, -
285	280x	- pch_obs = pch_obs[row_obs_vars], col_obs = col_obs[row_obs_vars], -
286	280x	- legend = FALSE, frame = frame, xlab = xlab, xlim = xlim, maxabs = maxabs) -
287		- } -
288		- -
289		- # Show error model plot if requested -
290	1503x	- if (show_errplot) { -
291	205x	- mkinerrplot(fit, obs_vars = row_obs_vars, -
292	205x	- pch_obs = pch_obs[row_obs_vars], col_obs = col_obs[row_obs_vars], -
293	205x	- legend = FALSE, frame = frame) -
294		- } -
295		- } -
296		- } -
297		- -
298		- #' @rdname plot.mkinfit -
299		- #' @export -
300		- plot_sep <- function(fit, show_errmin = TRUE, -
301		- show_residuals = ifelse(identical(fit$err_mod, "const"), TRUE, "standardized"), ...) { -
302	70x	- plot.mkinfit(fit, sep_obs = TRUE, show_residuals = show_residuals, -
303	70x	- show_errmin = show_errmin, ...) -
304		- } -
305		- -
306		- #' @rdname plot.mkinfit -
307		- #' @export -
308		- plot_res <- function(fit, sep_obs = FALSE, show_errmin = sep_obs, -
309		- standardized = ifelse(identical(fit$err_mod, "const"), FALSE, TRUE), ...) -
310		- { -
311	140x	- plot.mkinfit(fit, sep_obs = sep_obs, show_errmin = show_errmin, -
312	140x	- show_residuals = ifelse(standardized, "standardized", TRUE), -
313	140x	- row_layout = TRUE, ...) -
314		- } -
315		- -
316		- #' @rdname plot.mkinfit -
317		- #' @export -
318		- plot_err <- function(fit, sep_obs = FALSE, show_errmin = sep_obs, ...) { -
319	205x	- plot.mkinfit(fit, sep_obs = sep_obs, show_errmin = show_errmin, -
320	205x	- show_errplot = TRUE, row_layout = TRUE, ...) -
321		- } -
322		- -
323		- #' Plot the observed data and the fitted model of an mkinfit object -
324		- #' -
325		- #' Deprecated function. It now only calls the plot method -
326		- #' \code{\link{plot.mkinfit}}. -
327		- #' -
328		- #' @param fit an object of class \code{\link{mkinfit}}. -
329		- #' @param \dots further arguments passed to \code{\link{plot.mkinfit}}. -
330		- #' @return The function is called for its side effect. -
331		- #' @author Johannes Ranke -
332		- #' @export -
333		- mkinplot <- function(fit, ...) -
334		- { -
335	!	- plot(fit, ...) -
336		- } -

1		- #' Create a mixed effects model from an mmkin row object -
2		- #' -
3		- #' @importFrom rlang !!! -
4		- #' @param object An [mmkin] row object -
5		- #' @param method The method to be used -
6		- #' @param \dots Currently not used -
7		- #' @return An object of class 'mixed.mmkin' which has the observed data in a -
8		- #' single dataframe which is convenient for plotting -
9		- #' @examples -
10		- #' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120) -
11		- #' n_biphasic <- 8 -
12		- #' err_1 = list(const = 1, prop = 0.07) -
13		- #' -
14		- #' DFOP_SFO <- mkinmod( -
15		- #' parent = mkinsub("DFOP", "m1"), -
16		- #' m1 = mkinsub("SFO"), -
17		- #' quiet = TRUE) -
18		- #' -
19		- #' set.seed(123456) -
20		- #' log_sd <- 0.3 -
21		- #' syn_biphasic_parms <- as.matrix(data.frame( -
22		- #' k1 = rlnorm(n_biphasic, log(0.05), log_sd), -
23		- #' k2 = rlnorm(n_biphasic, log(0.01), log_sd), -
24		- #' g = plogis(rnorm(n_biphasic, 0, log_sd)), -
25		- #' f_parent_to_m1 = plogis(rnorm(n_biphasic, 0, log_sd)), -
26		- #' k_m1 = rlnorm(n_biphasic, log(0.002), log_sd))) -
27		- #' -
28		- #' ds_biphasic_mean <- lapply(1:n_biphasic, -
29		- #' function(i) { -
30		- #' mkinpredict(DFOP_SFO, syn_biphasic_parms[i, ], -
31		- #' c(parent = 100, m1 = 0), sampling_times) -
32		- #' } -
33		- #' ) -
34		- #' -
35		- #' set.seed(123456L) -
36		- #' ds_biphasic <- lapply(ds_biphasic_mean, function(ds) { -
37		- #' add_err(ds, -
38		- #' sdfunc = function(value) sqrt(err_1$const^2 + value^2 * err_1$prop^2), -
39		- #' n = 1, secondary = "m1")[[1]] -
40		- #' }) -
41		- #' -
42		- #' \dontrun{ -
43		- #' f_mmkin <- mmkin(list("DFOP-SFO" = DFOP_SFO), ds_biphasic, error_model = "tc", quiet = TRUE) -
44		- #' -
45		- #' f_mixed <- mixed(f_mmkin) -
46		- #' print(f_mixed) -
47		- #' plot(f_mixed) -
48		- #' } -
49		- #' @export -
50		- mixed <- function(object, ...) { -
51	182x	- UseMethod("mixed") -
52		- } -
53		- -
54		- #' @export -
55		- #' @rdname mixed -
56		- mixed.mmkin <- function(object, method = c("none"), ...) { -
57	!	- if (nrow(object) > 1) stop("Only row objects allowed") -
58		- -
59	182x	- method <- match.arg(method) -
60		- -
61	182x	- ds_names <- colnames(object) -
62	182x	- res <- list(mmkin = object, mkinmod = object[[1]]$mkinmod) -
63		- -
64	182x	- if (method[1] == "none") { -
65	182x	- ds_list <- lapply(object, -
66	182x	- function(x) x$data[c("variable", "time", "observed", "predicted", "residual")]) -
67		- -
68	182x	- names(ds_list) <- ds_names -
69	182x	- res$data <- vctrs::vec_rbind(!!!ds_list, .names_to = "ds") -
70	182x	- names(res$data)[1:4] <- c("ds", "name", "time", "value") -
71	182x	- res$data$name <- as.character(res$data$name) -
72	182x	- res$data$ds <- ordered(res$data$ds, levels = unique(res$data$ds)) -
73	182x	- standardized <- unlist(lapply(object, residuals, standardized = TRUE)) -
74	182x	- res$data$std <- res$data$residual / standardized -
75	182x	- res$data$standardized <- standardized -
76		- -
77	182x	- class(res) <- c("mixed.mmkin") -
78	182x	- return(res) -
79		- } -
80		- } -
81		- -
82		- #' @export -
83		- #' @rdname mixed -
84		- #' @param x A mixed.mmkin object to print -
85		- #' @param digits Number of digits to use for printing. -
86		- print.mixed.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) { -
87	117x	- cat("Kinetic model fitted by nonlinear regression to each dataset" ) -
88	117x	- cat("\nStructural model:\n") -
89	117x	- diffs <- x$mmkin[[1]]$mkinmod$diffs -
90	117x	- nice_diffs <- gsub("^(d.*) =", "\\1/dt =", diffs) -
91	117x	- writeLines(strwrap(nice_diffs, exdent = 11)) -
92	117x	- cat("\nData:\n") -
93	117x	- cat(nrow(x$data), "observations of", -
94	117x	- length(unique(x$data$name)), "variable(s) grouped in", -
95	117x	- length(unique(x$data$ds)), "datasets\n\n") -
96		- -
97	117x	- print(x$mmkin, digits = digits) -
98		- -
99	117x	- cat("\nMean fitted parameters:\n") -
100	117x	- print(mean_degparms(x$mmkin), digits = digits) -
101		- -
102	117x	- invisible(x) -
103		- } -

1		- #' Extract model parameters -
2		- #' -
3		- #' This function returns degradation model parameters as well as error -
4		- #' model parameters per default, in order to avoid working with a fitted model -
5		- #' without considering the error structure that was assumed for the fit. -
6		- #' -
7		- #' @param object A fitted model object. -
8		- #' @param \dots Not used -
9		- #' @return Depending on the object, a numeric vector of fitted model parameters, -
10		- #' a matrix (e.g. for mmkin row objects), or a list of matrices (e.g. for -
11		- #' mmkin objects with more than one row). -
12		- #' @seealso [saem], [multistart] -
13		- #' @examples -
14		- #' # mkinfit objects -
15		- #' fit <- mkinfit("SFO", FOCUS_2006_C, quiet = TRUE) -
16		- #' parms(fit) -
17		- #' parms(fit, transformed = TRUE) -
18		- #' -
19		- #' # mmkin objects -
20		- #' ds <- lapply(experimental_data_for_UBA_2019[6:10], -
21		- #' function(x) subset(x$data[c("name", "time", "value")])) -
22		- #' names(ds) <- paste("Dataset", 6:10) -
23		- #' \dontrun{ -
24		- #' fits <- mmkin(c("SFO", "FOMC", "DFOP"), ds, quiet = TRUE, cores = 1) -
25		- #' parms(fits["SFO", ]) -
26		- #' parms(fits[, 2]) -
27		- #' parms(fits) -
28		- #' parms(fits, transformed = TRUE) -
29		- #' } -
30		- #' @export -
31		- parms <- function(object, ...) -
32		- { -
33	91384x	- UseMethod("parms", object) -
34		- } -
35		- -
36		- #' @param transformed Should the parameters be returned as used internally -
37		- #' during the optimisation? -
38		- #' @param errparms Should the error model parameters be returned -
39		- #' in addition to the degradation parameters? -
40		- #' @rdname parms -
41		- #' @export -
42		- parms.mkinfit <- function(object, transformed = FALSE, errparms = TRUE, ...) -
43		- { -
44	88039x	- res <- if (transformed) object$par -
45	88039x	- else c(object$bparms.optim, object$errparms) -
46	88039x	- if (!errparms) { -
47	3000x	- res[setdiff(names(res), names(object$errparms))] -
48		- } -
49	85039x	- else return(res) -
50		- } -
51		- -
52		- #' @rdname parms -
53		- #' @export -
54		- parms.mmkin <- function(object, transformed = FALSE, errparms = TRUE, ...) -
55		- { -
56	265x	- if (nrow(object) == 1) { -
57	265x	- res <- sapply(object, parms, transformed = transformed, -
58	265x	- errparms = errparms, ...) -
59	265x	- colnames(res) <- colnames(object) -
60		- } else { -
61	!	- res <- list() -
62	!	- for (i in 1:nrow(object)) { -
63	!	- res[[i]] <- parms(object[i, ], transformed = transformed, -
64	!	- errparms = errparms, ...) -
65		- } -
66	!	- names(res) <- rownames(object) -
67		- } -
68	265x	- return(res) -
69		- } -
70		- -
71		- #' @param exclude_failed For [multistart] objects, should rows for failed fits -
72		- #' be removed from the returned parameter matrix? -
73		- #' @rdname parms -
74		- #' @export -
75		- parms.multistart <- function(object, exclude_failed = TRUE, ...) { -
76	176x	- res <- t(sapply(object, parms)) -
77	176x	- successful <- which(!is.na(res[, 1])) -
78	176x	- first_success <- successful[1] -
79	176x	- colnames(res) <- names(parms(object[[first_success]])) -
80	!	- if (exclude_failed[1]) res <- res[successful, ] -
81	176x	- return(res) -
82		- } -

1		- #' Fit one or more kinetic models with one or more state variables to one or -
2		- #' more datasets -
3		- #' -
4		- #' This function calls \code{\link{mkinfit}} on all combinations of models and -
5		- #' datasets specified in its first two arguments. -
6		- #' -
7		- #' @param models Either a character vector of shorthand names like -
8		- #' \code{c("SFO", "FOMC", "DFOP", "HS", "SFORB")}, or an optionally named -
9		- #' list of \code{\link{mkinmod}} objects. -
10		- #' @param datasets An optionally named list of datasets suitable as observed -
11		- #' data for \code{\link{mkinfit}}. -
12		- #' @param cores The number of cores to be used for multicore processing. This -
13		- #' is only used when the \code{cluster} argument is \code{NULL}. On Windows -
14		- #' machines, cores > 1 is not supported, you need to use the \code{cluster} -
15		- #' argument to use multiple logical processors. Per default, all cores -
16		- #' detected by [parallel::detectCores()] are used, except on Windows where -
17		- #' the default is 1. -
18		- #' @param cluster A cluster as returned by \code{\link{makeCluster}} to be used -
19		- #' for parallel execution. -
20		- #' @param \dots Further arguments that will be passed to \code{\link{mkinfit}}. -
21		- #' @importFrom parallel mclapply parLapply detectCores -
22		- #' @return A two-dimensional \code{\link{array}} of \code{\link{mkinfit}} -
23		- #' objects and/or try-errors that can be indexed using the model names for the -
24		- #' first index (row index) and the dataset names for the second index (column -
25		- #' index). -
26		- #' @author Johannes Ranke -
27		- #' @seealso \code{\link{[.mmkin}} for subsetting, \code{\link{plot.mmkin}} for -
28		- #' plotting. -
29		- #' @keywords optimize -
30		- #' @examples -
31		- #' -
32		- #' \dontrun{ -
33		- #' m_synth_SFO_lin <- mkinmod(parent = mkinsub("SFO", "M1"), -
34		- #' M1 = mkinsub("SFO", "M2"), -
35		- #' M2 = mkinsub("SFO"), use_of_ff = "max") -
36		- #' -
37		- #' m_synth_FOMC_lin <- mkinmod(parent = mkinsub("FOMC", "M1"), -
38		- #' M1 = mkinsub("SFO", "M2"), -
39		- #' M2 = mkinsub("SFO"), use_of_ff = "max") -
40		- #' -
41		- #' models <- list(SFO_lin = m_synth_SFO_lin, FOMC_lin = m_synth_FOMC_lin) -
42		- #' datasets <- lapply(synthetic_data_for_UBA_2014[1:3], function(x) x$data) -
43		- #' names(datasets) <- paste("Dataset", 1:3) -
44		- #' -
45		- #' time_default <- system.time(fits.0 <- mmkin(models, datasets, quiet = TRUE)) -
46		- #' time_1 <- system.time(fits.4 <- mmkin(models, datasets, cores = 1, quiet = TRUE)) -
47		- #' -
48		- #' time_default -
49		- #' time_1 -
50		- #' -
51		- #' endpoints(fits.0[["SFO_lin", 2]]) -
52		- #' -
53		- #' # plot.mkinfit handles rows or columns of mmkin result objects -
54		- #' plot(fits.0[1, ]) -
55		- #' plot(fits.0[1, ], obs_var = c("M1", "M2")) -
56		- #' plot(fits.0[, 1]) -
57		- #' # Use double brackets to extract a single mkinfit object, which will be plotted -
58		- #' # by plot.mkinfit and can be plotted using plot_sep -
59		- #' plot(fits.0[[1, 1]], sep_obs = TRUE, show_residuals = TRUE, show_errmin = TRUE) -
60		- #' plot_sep(fits.0[[1, 1]]) -
61		- #' # Plotting with mmkin (single brackets, extracting an mmkin object) does not -
62		- #' # allow to plot the observed variables separately -
63		- #' plot(fits.0[1, 1]) -
64		- #' -
65		- #' # On Windows, we can use multiple cores by making a cluster first -
66		- #' cl <- parallel::makePSOCKcluster(12) -
67		- #' f <- mmkin(c("SFO", "FOMC", "DFOP"), -
68		- #' list(A = FOCUS_2006_A, B = FOCUS_2006_B, C = FOCUS_2006_C, D = FOCUS_2006_D), -
69		- #' cluster = cl, quiet = TRUE) -
70		- #' print(f) -
71		- #' # We get false convergence for the FOMC fit to FOCUS_2006_A because this -
72		- #' # dataset is really SFO, and the FOMC fit is overparameterised -
73		- #' parallel::stopCluster(cl) -
74		- #' } -
75		- #' -
76		- #' @export mmkin -
77		- mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets, -
78		- cores = if (Sys.info()["sysname"] == "Windows") 1 else parallel::detectCores(), cluster = NULL, ...) -
79		- { -
80	4032x	- call <- match.call() -
81	4032x	- parent_models_available = c("SFO", "FOMC", "DFOP", "HS", "SFORB", "IORE", "logistic") -
82	4032x	- n.m <- length(models) -
83	4032x	- n.d <- length(datasets) -
84	4032x	- n.fits <- n.m * n.d -
85	4032x	- fit_indices <- matrix(1:n.fits, ncol = n.d) -
86		- -
87		- # Check models and define their names -
88	4032x	- if (!all(sapply(models, function(x) inherits(x, "mkinmod")))) { -
89	2323x	- if (!all(models %in% parent_models_available)) { -
90	50x	- stop("Please supply models as a list of mkinmod objects or a vector combined of\n ", -
91	50x	- paste(parent_models_available, collapse = ", ")) -
92		- } else { -
93	2273x	- names(models) <- models -
94		- } -
95		- } else { -
96	1087x	- if (is.null(names(models))) names(models) <- as.character(1:n.m) -
97		- } -
98		- -
99		- # Check datasets and define their names -
100	1575x	- if (is.null(names(datasets))) names(datasets) <- as.character(1:n.d) -
101		- -
102		- # Define names for fit index -
103	3982x	- dimnames(fit_indices) <- list(model = names(models), -
104	3982x	- dataset = names(datasets)) -
105		- -
106		- -
107	3982x	- fit_function <- function(fit_index) { -
108	793x	- w <- which(fit_indices == fit_index, arr.ind = TRUE) -
109	793x	- model_index <- w[1] -
110	793x	- dataset_index <- w[2] -
111	793x	- res <- try(mkinfit(models[[model_index]], datasets[[dataset_index]], ...)) -
112	793x	- if (!inherits(res, "try-error")) res$mkinmod$name <- names(models)[model_index] -
113	793x	- return(res) -
114		- } -
115		- -
116	3982x	- fit_time <- system.time({ -
117	3982x	- if (is.null(cluster)) { -
118	2154x	- results <- parallel::mclapply(as.list(1:n.fits), fit_function, -
119	2154x	- mc.cores = cores, mc.preschedule = FALSE) -
120		- } else { -
121	1828x	- results <- parallel::parLapply(cluster, as.list(1:n.fits), fit_function) -
122		- } -
123		- }) -
124		- -
125	3798x	- attributes(results) <- attributes(fit_indices) -
126	3798x	- attr(results, "call") <- call -
127	3798x	- attr(results, "time") <- fit_time -
128	3798x	- class(results) <- "mmkin" -
129	3798x	- return(results) -
130		- } -
131		- -
132		- #' Subsetting method for mmkin objects -
133		- #' -
134		- #' @param x An \code{\link{mmkin} object} -
135		- #' @param i Row index selecting the fits for specific models -
136		- #' @param j Column index selecting the fits to specific datasets -
137		- #' @param ... Not used, only there to satisfy the generic method definition -
138		- #' @param drop If FALSE, the method always returns an mmkin object, otherwise -
139		- #' either a list of mkinfit objects or a single mkinfit object. -
140		- #' @return An object of class \code{\link{mmkin}}. -
141		- #' @author Johannes Ranke -
142		- #' @rdname Extract.mmkin -
143		- #' @examples -
144		- #' -
145		- #' # Only use one core, to pass R CMD check --as-cran -
146		- #' fits <- mmkin(c("SFO", "FOMC"), list(B = FOCUS_2006_B, C = FOCUS_2006_C), -
147		- #' cores = 1, quiet = TRUE) -
148		- #' fits["FOMC", ] -
149		- #' fits[, "B"] -
150		- #' fits["SFO", "B"] -
151		- #' -
152		- #' head( -
153		- #' # This extracts an mkinfit object with lots of components -
154		- #' fits[["FOMC", "B"]] -
155		- #' ) -
156		- #' @export -
157		- `[.mmkin` <- function(x, i, j, ..., drop = FALSE) { -
158	2760x	- class(x) <- NULL -
159	2760x	- x_sub <- x[i, j, drop = drop] -
160	2760x	- if (!drop) class(x_sub) <- "mmkin" -
161	2760x	- return(x_sub) -
162		- } -
163		- -
164		- #' Print method for mmkin objects -
165		- #' -
166		- #' @param x An [mmkin] object. -
167		- #' @param \dots Not used. -
168		- #' @rdname mmkin -
169		- #' @export -
170		- print.mmkin <- function(x, ...) { -
171	375x	- cat("<mmkin> object\n") -
172	375x	- cat("Status of individual fits:\n\n") -
173	375x	- print(status(x)) -
174		- } -
175		- -
176		- #' @export -
177		- update.mmkin <- function(object, ..., evaluate = TRUE) -
178		- { -
179	256x	- call <- attr(object, "call") -
180		- -
181	256x	- update_arguments <- match.call(expand.dots = FALSE)$... -
182		- -
183	256x	- if (length(update_arguments) > 0) { -
184	256x	- update_arguments_in_call <- !is.na(match(names(update_arguments), names(call))) -
185		- } -
186		- -
187	256x	- for (a in names(update_arguments)[update_arguments_in_call]) { -
188	115x	- call[[a]] <- update_arguments[[a]] -
189		- } -
190		- -
191	256x	- update_arguments_not_in_call <- !update_arguments_in_call -
192	256x	- if(any(update_arguments_not_in_call)) { -
193	206x	- call <- c(as.list(call), update_arguments[update_arguments_not_in_call]) -
194	206x	- call <- as.call(call) -
195		- } -
196		- -
197	256x	- if(evaluate) eval(call, parent.frame()) -
198	!	- else call -
199		- } -

1		- #' Produce predictions from a kinetic model using specific parameters -
2		- #' -
3		- #' This function produces a time series for all the observed variables in a -
4		- #' kinetic model as specified by [mkinmod], using a specific set of -
5		- #' kinetic parameters and initial values for the state variables. -
6		- #' -
7		- #' @aliases mkinpredict mkinpredict.mkinmod mkinpredict.mkinfit -
8		- #' @param x A kinetic model as produced by [mkinmod], or a kinetic fit as -
9		- #' fitted by [mkinfit]. In the latter case, the fitted parameters are used for -
10		- #' the prediction. -
11		- #' @param odeparms A numeric vector specifying the parameters used in the -
12		- #' kinetic model, which is generally defined as a set of ordinary differential -
13		- #' equations. -
14		- #' @param odeini A numeric vector containing the initial values of the state -
15		- #' variables of the model. Note that the state variables can differ from the -
16		- #' observed variables, for example in the case of the SFORB model. -
17		- #' @param outtimes A numeric vector specifying the time points for which model -
18		- #' predictions should be generated. -
19		- #' @param solution_type The method that should be used for producing the -
20		- #' predictions. This should generally be "analytical" if there is only one -
21		- #' observed variable, and usually "deSolve" in the case of several observed -
22		- #' variables. The third possibility "eigen" is fast in comparison to uncompiled -
23		- #' ODE models, but not applicable to some models, e.g. using FOMC for the -
24		- #' parent compound. -
25		- #' @param method.ode The solution method passed via [mkinpredict] to [ode]] in -
26		- #' case the solution type is "deSolve" and we are not using compiled code. -
27		- #' When using compiled code, only lsoda is supported. -
28		- #' @param use_compiled If set to \code{FALSE}, no compiled version of the -
29		- #' [mkinmod] model is used, even if is present. -
30		- #' @param use_symbols If set to \code{TRUE} (default), symbol info present in -
31		- #' the [mkinmod] object is used if available for accessing compiled code -
32		- #' @param atol Absolute error tolerance, passed to the ode solver. -
33		- #' @param rtol Absolute error tolerance, passed to the ode solver. -
34		- #' @param maxsteps Maximum number of steps, passed to the ode solver. -
35		- #' @param map_output Boolean to specify if the output should list values for -
36		- #' the observed variables (default) or for all state variables (if set to -
37		- #' FALSE). Setting this to FALSE has no effect for analytical solutions, -
38		- #' as these always return mapped output. -
39		- #' @param na_stop Should it be an error if [ode] returns NaN values -
40		- #' @param \dots Further arguments passed to the ode solver in case such a -
41		- #' solver is used. -
42		- #' @return A matrix with the numeric solution in wide format -
43		- #' @author Johannes Ranke -
44		- #' @examples -
45		- #' -
46		- #' SFO <- mkinmod(degradinol = mkinsub("SFO")) -
47		- #' # Compare solution types -
48		- #' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, -
49		- #' solution_type = "analytical") -
50		- #' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, -
51		- #' solution_type = "deSolve") -
52		- #' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, -
53		- #' solution_type = "deSolve", use_compiled = FALSE) -
54		- #' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, -
55		- #' solution_type = "eigen") -
56		- #' -
57		- #' # Compare integration methods to analytical solution -
58		- #' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, -
59		- #' solution_type = "analytical")[21,] -
60		- #' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, -
61		- #' method = "lsoda", use_compiled = FALSE)[21,] -
62		- #' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, -
63		- #' method = "ode45", use_compiled = FALSE)[21,] -
64		- #' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), 0:20, -
65		- #' method = "rk4", use_compiled = FALSE)[21,] -
66		- #' # rk4 is not as precise here -
67		- #' -
68		- #' # The number of output times used to make a lot of difference until the -
69		- #' # default for atol was adjusted -
70		- #' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), -
71		- #' seq(0, 20, by = 0.1))[201,] -
72		- #' mkinpredict(SFO, c(k_degradinol = 0.3), c(degradinol = 100), -
73		- #' seq(0, 20, by = 0.01))[2001,] -
74		- #' -
75		- #' # Comparison of the performance of solution types -
76		- #' SFO_SFO = mkinmod(parent = list(type = "SFO", to = "m1"), -
77		- #' m1 = list(type = "SFO"), use_of_ff = "max") -
78		- #' if(require(rbenchmark)) { -
79		- #' benchmark(replications = 10, order = "relative", columns = c("test", "relative", "elapsed"), -
80		- #' eigen = mkinpredict(SFO_SFO, -
81		- #' c(k_parent = 0.15, f_parent_to_m1 = 0.5, k_m1 = 0.01), -
82		- #' c(parent = 100, m1 = 0), seq(0, 20, by = 0.1), -
83		- #' solution_type = "eigen")[201,], -
84		- #' deSolve_compiled = mkinpredict(SFO_SFO, -
85		- #' c(k_parent = 0.15, f_parent_to_m1 = 0.5, k_m1 = 0.01), -
86		- #' c(parent = 100, m1 = 0), seq(0, 20, by = 0.1), -
87		- #' solution_type = "deSolve")[201,], -
88		- #' deSolve = mkinpredict(SFO_SFO, -
89		- #' c(k_parent = 0.15, f_parent_to_m1 = 0.5, k_m1 = 0.01), -
90		- #' c(parent = 100, m1 = 0), seq(0, 20, by = 0.1), -
91		- #' solution_type = "deSolve", use_compiled = FALSE)[201,], -
92		- #' analytical = mkinpredict(SFO_SFO, -
93		- #' c(k_parent = 0.15, f_parent_to_m1 = 0.5, k_m1 = 0.01), -
94		- #' c(parent = 100, m1 = 0), seq(0, 20, by = 0.1), -
95		- #' solution_type = "analytical", use_compiled = FALSE)[201,]) -
96		- #' } -
97		- #' -
98		- #' \dontrun{ -
99		- #' # Predict from a fitted model -
100		- #' f <- mkinfit(SFO_SFO, FOCUS_2006_C, quiet = TRUE) -
101		- #' f <- mkinfit(SFO_SFO, FOCUS_2006_C, quiet = TRUE, solution_type = "deSolve") -
102		- #' head(mkinpredict(f)) -
103		- #' } -
104		- #' -
105		- #' @export -
106		- mkinpredict <- function(x, odeparms, odeini, outtimes, ...) -
107		- { -
108	47544878x	- UseMethod("mkinpredict", x) -
109		- } -
110		- -
111		- #' @rdname mkinpredict -
112		- #' @export -
113		- mkinpredict.mkinmod <- function(x, -
114		- odeparms = c(k_parent_sink = 0.1), -
115		- odeini = c(parent = 100), -
116		- outtimes = seq(0, 120, by = 0.1), -
117		- solution_type = "deSolve", -
118		- use_compiled = "auto", -
119		- use_symbols = FALSE, -
120		- method.ode = "lsoda", atol = 1e-8, rtol = 1e-10, maxsteps = 20000L, -
121		- map_output = TRUE, -
122		- na_stop = TRUE, -
123		- ...) -
124		- { -
125		- -
126		- # Names of state variables and observed variables -
127	47544878x	- mod_vars <- names(x$diffs) -
128	47544878x	- obs_vars <- names(x$spec) -
129		- -
130		- # Order the inital values for state variables if they are named -
131	47544878x	- if (!is.null(names(odeini))) { -
132	47544878x	- odeini <- odeini[mod_vars] -
133		- } -
134		- -
135	47544878x	- out_obs <- matrix(NA, nrow = length(outtimes), ncol = 1 + length(obs_vars), -
136	47544878x	- dimnames = list(as.character(outtimes), c("time", obs_vars))) -
137	47544878x	- out_obs[, "time"] <- outtimes -
138		- -
139	47544878x	- n_out_na <- 0 # to check if we get NA values with deSolve -
140		- -
141	47544878x	- if (solution_type == "analytical") { -
142		- # This is clumsy, as we wanted fast analytical predictions for mkinfit, -
143		- # which bypasses mkinpredict in the case of analytical solutions -
144	1843695x	- pseudo_observed <- -
145	1843695x	- data.frame(name = rep(obs_vars, each = length(outtimes)), -
146	1843695x	- time = rep(outtimes, length(obs_vars))) -
147	1843695x	- pseudo_observed$predicted <- x$deg_func(pseudo_observed, odeini, odeparms) -
148	1843695x	- for (obs_var in obs_vars) { -
149	2431585x	- out_obs[, obs_var] <- pseudo_observed[pseudo_observed$name == obs_var, "predicted"] -
150		- } -
151		- # We don't have solutions for unobserved state variables, the output of -
152		- # analytical solutions is always mapped to observed variables -
153	1843695x	- return(out_obs) -
154		- } -
155		- -
156	45701183x	- if (solution_type == "eigen") { -
157	97082x	- evalparse <- function(string) { -
158	392283x	- eval(parse(text=string), as.list(c(odeparms, odeini))) -
159		- } -
160		- -
161	97082x	- coefmat.num <- matrix(sapply(as.vector(x$coefmat), evalparse), -
162	97082x	- nrow = length(mod_vars)) -
163	97082x	- e <- eigen(coefmat.num) -
164	97082x	- c <- solve(e$vectors, odeini) -
165	97082x	- f.out <- function(t) { -
166	1085040x	- e$vectors %% diag(exp(e$values t), nrow=length(mod_vars)) %*% c -
167		- } -
168	97082x	- o <- matrix(mapply(f.out, outtimes), -
169	97082x	- nrow = length(mod_vars), ncol = length(outtimes)) -
170	97082x	- out <- cbind(outtimes, t(o)) -
171	97082x	- colnames(out) <- c("time", mod_vars) -
172		- } -
173		- -
174	45701183x	- if (solution_type == "deSolve") { -
175	45604101x	- if (!is.null(x$cf) & use_compiled[1] != FALSE) { -
176		- -
177	45603235x	- if (!is.null(x$symbols) & use_symbols) { -
178	1427314x	- lsoda_func <- x$symbols -
179		- } else { -
180	44175921x	- lsoda_func <- "diffs" -
181		- } -
182		- -
183	45603235x	- out <- deSolve::lsoda( -
184	45603235x	- y = odeini, -
185	45603235x	- times = outtimes, -
186	45603235x	- func = lsoda_func, -
187	45603235x	- initfunc = "initpar", -
188	45603235x	- dllname = x$dll_info[["name"]], -
189	45603235x	- parms = odeparms[x$parms], # Order matters when using compiled models -
190	45603235x	- atol = atol, -
191	45603235x	- rtol = rtol, -
192	45603235x	- maxsteps = maxsteps, -
193		- ... -
194		- ) -
195		- -
196	45603235x	- colnames(out) <- c("time", mod_vars) -
197		- } else { -
198	866x	- mkindiff <- function(t, state, parms) { -
199		- -
200	145229x	- time <- t -
201	145229x	- diffs <- vector() -
202	145229x	- for (box in names(x$diffs)) -
203		- { -
204	145229x	- diffname <- paste("d", box, sep="_") -
205	145229x	- diffs[diffname] <- with(as.list(c(time, state, parms)), -
206	145229x	- eval(parse(text=x$diffs[[box]]))) -
207		- } -
208	145229x	- return(list(c(diffs))) -
209		- } -
210	866x	- out <- deSolve::ode( -
211	866x	- y = odeini, -
212	866x	- times = outtimes, -
213	866x	- func = mkindiff, -
214	866x	- parms = odeparms, -
215	866x	- method = method.ode, -
216	866x	- atol = atol, -
217	866x	- rtol = rtol, -
218	866x	- maxsteps = maxsteps, -
219		- ... -
220		- ) -
221		- } -
222	45604101x	- n_out_na <- sum(is.na(out)) -
223	45604101x	- if (n_out_na > 0 & na_stop) { -
224	!	- cat("odeini:\n") -
225	!	- print(odeini) -
226	!	- cat("odeparms:\n") -
227	!	- print(odeparms) -
228	!	- cat("out:\n") -
229	!	- print(out) -
230	!	- stop("Differential equations were not integrated for all output times because\n", -
231	!	- n_out_na, " NaN values occurred in output from ode()") -
232		- } -
233		- } -
234		- -
235	45701183x	- if (map_output) { -
236		- # Output transformation for models with unobserved compartments like SFORB -
237		- # if not already mapped in analytical solution -
238	45701183x	- if (n_out_na > 0 & !na_stop) { -
239	!	- available <- c(TRUE, rep(FALSE, length(outtimes) - 1)) -
240		- } else { -
241	45701183x	- available <- rep(TRUE, length(outtimes)) -
242		- } -
243	45701183x	- for (var in names(x$map)) { -
244	93237433x	- if((length(x$map[[var]]) == 1)) { -
245	93235081x	- out_obs[available, var] <- out[available, var] -
246		- } else { -
247	2352x	- out_obs[available, var] <- out[available, x$map[[var]][1]] + -
248	2352x	- out[available, x$map[[var]][2]] -
249		- } -
250		- } -
251	45701183x	- return(out_obs) -
252		- } else { -
253	!	- dimnames(out) <- list(time = as.character(outtimes), c("time", mod_vars)) -
254	!	- return(out) -
255		- } -
256		- } -
257		- -
258		- #' @rdname mkinpredict -
259		- #' @export -
260		- mkinpredict.mkinfit <- function(x, -
261		- odeparms = x$bparms.ode, -
262		- odeini = x$bparms.state, -
263		- outtimes = seq(0, 120, by = 0.1), -
264		- solution_type = "deSolve", -
265		- use_compiled = "auto", -
266		- method.ode = "lsoda", atol = 1e-8, rtol = 1e-10, -
267		- map_output = TRUE, ...) -
268		- { -
269	!	- mkinpredict(x$mkinmod, odeparms, odeini, outtimes, solution_type, use_compiled, -
270	!	- method.ode, atol, rtol, map_output, ...) -
271		- } -

1		- #' Anova method for saem.mmkin objects -
2		- #' -
3		- #' Generate an anova object. The method to calculate the BIC is that from the -
4		- #' saemix package. As in other prominent anova methods, models are sorted by -
5		- #' number of parameters, and the tests (if requested) are always relative to -
6		- #' the model on the previous line. -
7		- #' -
8		- #' @param object An [saem.mmkin] object -
9		- #' @param ... further such objects -
10		- #' @param method Method for likelihood calculation: "is" (importance sampling), -
11		- #' "lin" (linear approximation), or "gq" (Gaussian quadrature). Passed -
12		- #' to [saemix::logLik.SaemixObject] -
13		- #' @param test Should a likelihood ratio test be performed? If TRUE, -
14		- #' the alternative models are tested against the first model. Should -
15		- #' only be done for nested models. -
16		- #' @param model.names Optional character vector of model names -
17		- #' @importFrom stats anova logLik update pchisq terms -
18		- #' @importFrom methods is -
19		- #' @importFrom utils capture.output -
20		- #' @export -
21		- #' @return an "anova" data frame; the traditional (S3) result of anova() -
22		- anova.saem.mmkin <- function(object, ..., -
23		- method = c("is", "lin", "gq"), test = FALSE, model.names = NULL) -
24		- { -
25		- # The following code is heavily inspired by anova.lmer in the lme4 package -
26	518x	- mCall <- match.call(expand.dots = TRUE) -
27	518x	- dots <- list(...) -
28	518x	- method <- match.arg(method) -
29		- -
30	518x	- is_model <- sapply(dots, is, "saem.mmkin") -
31	518x	- if (any(is_model)) { -
32	518x	- mods <- c(list(object), dots[is_model]) -
33	518x	- successful <- sapply(mods, function(x) !inherits(x$so, "try-error")) -
34		- -
35	518x	- if (is.null(model.names)) -
36	284x	- model.names <- vapply(as.list(mCall)[c(FALSE, TRUE, is_model)], deparse1, "") -
37		- -
38		- # Sanitize model names -
39	518x	- if (length(model.names) != length(mods)) -
40	!	- stop("Model names vector and model list have different lengths") -
41		- -
42	518x	- if (any(duplicated(model.names))) -
43	!	- stop("Duplicate model names are not allowed") -
44		- -
45	518x	- if (max(nchar(model.names)) > 200) { -
46	!	- warning("Model names longer than 200 characters, assigning generic names") -
47	!	- model.names <- paste0("MODEL",seq_along(model.names)) -
48		- } -
49	518x	- names(mods) <- model.names -
50	518x	- mods <- mods[successful] -
51		- -
52		- # Ensure same data, ignoring covariates -
53	518x	- same_data <- sapply(mods[-1], function(x) { -
54	1182x	- identical(mods[[1]]$data[c("ds", "name", "time", "value")], -
55	1182x	- x$data[c("ds", "name", "time", "value")]) -
56		- }) -
57	518x	- if (!all(same_data)) { -
58	!	- stop(sum(!same_data), " objects have not been fitted to the same data") -
59		- } -
60		- -
61	518x	- llks <- lapply(names(mods), function(x) { -
62	1700x	- llk <- try(logLik(mods[[x]], method = method), silent = TRUE) -
63	1700x	- if (inherits(llk, "try-error")) { -
64	!	- warning("Could not obtain log likelihood with '", method, "' method for ", x) -
65	!	- llk <- NA -
66		- } -
67	1700x	- return(llk) -
68		- }) -
69	518x	- available <- !sapply(llks, is.na) -
70	518x	- llks <- llks[available] -
71	518x	- mods <- mods[available] -
72		- -
73		- # Order models by increasing degrees of freedom: -
74	518x	- npar <- vapply(llks, attr, FUN.VALUE=numeric(1), "df") -
75	518x	- ii <- order(npar) -
76	518x	- mods <- mods[ii] -
77	518x	- llks <- llks[ii] -
78	518x	- npar <- npar[ii] -
79		- -
80		- # Describe data for the header, as in summary.saem.mmkin -
81	518x	- header <- paste("Data:", nrow(object$data), "observations of", -
82	518x	- length(unique(object$data$name)), "variable(s) grouped in", -
83	518x	- length(unique(object$data$ds)), "datasets\n") -
84		- -
85		- # Calculate statistics -
86	518x	- llk <- unlist(llks) -
87	518x	- chisq <- 2 * pmax(0, c(NA, diff(llk))) -
88	518x	- dfChisq <- c(NA, diff(npar)) -
89		- -
90	518x	- bic <- function(x, method) { -
91	1700x	- BIC(x$so, method = method) -
92		- } -
93	518x	- val <- data.frame( -
94	518x	- npar = npar, -
95	518x	- AIC = sapply(llks, AIC), -
96	518x	- BIC = sapply(mods, bic, method = method), # We use the saemix method here -
97	518x	- Lik = llk, -
98	518x	- row.names = names(mods), check.names = FALSE) -
99		- -
100	518x	- if (test) { -
101	196x	- testval <- data.frame( -
102	196x	- Chisq = chisq, -
103	196x	- Df = dfChisq, -
104	196x	- "Pr(>Chisq)" = ifelse(dfChisq == 0, NA, -
105	196x	- pchisq(chisq, dfChisq, lower.tail = FALSE)), -
106	196x	- row.names = names(mods), check.names = FALSE) -
107	196x	- val <- cbind(val, testval) -
108		- } -
109	518x	- class(val) <- c("anova", class(val)) -
110	518x	- structure(val, heading = c(header)) -
111		- } else { -
112	!	- stop("Currently, no anova method is implemented for the case of a single saem.mmkin object") -
113		- } -
114		- } -

1		- #' Create degradation functions for known analytical solutions -
2		- #' -
3		- #' @param spec List of model specifications as contained in mkinmod objects -
4		- #' @param use_of_ff Minimum or maximum use of formation fractions -
5		- #' @return Degradation function to be attached to mkinmod objects -
6		- #' @examples -
7		- #' -
8		- #' SFO_SFO <- mkinmod( -
9		- #' parent = mkinsub("SFO", "m1"), -
10		- #' m1 = mkinsub("SFO")) -
11		- #' FOCUS_D <- subset(FOCUS_2006_D, value != 0) # to avoid warnings -
12		- #' fit_1 <- mkinfit(SFO_SFO, FOCUS_D, solution_type = "analytical", quiet = TRUE) -
13		- #' \dontrun{ -
14		- #' fit_2 <- mkinfit(SFO_SFO, FOCUS_D, solution_type = "deSolve", quiet = TRUE) -
15		- #' if (require(rbenchmark)) -
16		- #' benchmark( -
17		- #' analytical = mkinfit(SFO_SFO, FOCUS_D, solution_type = "analytical", quiet = TRUE), -
18		- #' deSolve = mkinfit(SFO_SFO, FOCUS_D, solution_type = "deSolve", quiet = TRUE), -
19		- #' replications = 2) -
20		- #' DFOP_SFO <- mkinmod( -
21		- #' parent = mkinsub("DFOP", "m1"), -
22		- #' m1 = mkinsub("SFO")) -
23		- #' benchmark( -
24		- #' analytical = mkinfit(DFOP_SFO, FOCUS_D, solution_type = "analytical", quiet = TRUE), -
25		- #' deSolve = mkinfit(DFOP_SFO, FOCUS_D, solution_type = "deSolve", quiet = TRUE), -
26		- #' replications = 2) -
27		- #' } -
28		- #' @export -
29		- create_deg_func <- function(spec, use_of_ff = c("min", "max")) { -
30		- -
31	8117x	- use_of_ff <- match.arg(use_of_ff) -
32	8117x	- min_ff <- use_of_ff == "min" -
33	8117x	- obs_vars <- names(spec) -
34		- -
35	8117x	- parent <- obs_vars[1] -
36	8117x	- parent_type <- spec[[1]]$type -
37		- -
38	8117x	- supported <- TRUE # This may be modified below -
39		- -
40	8117x	- predicted_text <- character(0) -
41		- -
42	8117x	- if (parent_type == "SFO") { -
43	5916x	- if (min_ff) { -
44	599x	- targets <- c(spec[[1]]$to, if (spec[[1]]$sink) "sink" else NULL) -
45	599x	- k_parent <- paste(paste0("k_", parent, "_", targets), collapse = " + ") -
46		- } else { -
47	5317x	- k_parent <- paste0("k_", parent) -
48		- } -
49		- } -
50		- -
51	8117x	- predicted_text[parent] <- paste0(parent_type, ".solution(t, odeini['", parent, -
52	8117x	- if (parent_type == "SFORB") "_free", "'], ", -
53	8117x	- switch(parent_type, -
54	8117x	- SFO = k_parent, -
55	8117x	- FOMC = "alpha, beta", -
56	8117x	- IORE = paste0("k__iore_", parent, if (min_ff) "_sink" else "", ", N_", parent), -
57	8117x	- DFOP = "k1, k2, g", -
58	8117x	- SFORB = paste0("k_", parent, "_free_bound, k_", parent, "_bound_free, k_", parent, "_free", if (min_ff) "_sink" else ""), -
59	8117x	- HS = "k1, k2, tb", -
60	8117x	- logistic = "kmax, k0, r" -
61		- ), -
62		- ")") -
63		- -
64	3728x	- if (length(obs_vars) >= 2) supported <- FALSE -
65		- # Except for the following cases: -
66		- -
67	8117x	- if (length(obs_vars) == 2) { -
68	3036x	- n1 <- obs_vars[1] -
69	3036x	- n2 <- obs_vars[2] -
70	3036x	- n10 <- paste0("odeini['", parent, "']") -
71	3036x	- n20 <- paste0("odeini['", n2, "']") -
72		- -
73		- # sfo_sfo -
74	3036x	- if (all( -
75	3036x	- spec[[1]]$sink == FALSE, -
76	3036x	- spec[[1]]$type == "SFO", -
77	3036x	- spec[[2]]$type == "SFO", -
78	3036x	- is.null(spec[[2]]$to))) { -
79	741x	- supported <- TRUE -
80	741x	- k1 <- k_parent -
81	741x	- k2 <- paste0("k_", n2, if(min_ff) "_sink" else "") -
82	741x	- predicted_text[n2] <- paste0( -
83	741x	- "(((", k2, "-", k1, ")", n20, "-", k1, "", n10, ")exp(-", k2, "t)+", -
84	741x	- k1, "", n10, "exp(-", k1, "*t))/(", k2, "-", k1, ")") -
85		- } -
86		- -
87		- # sfo_f12_sfo -
88	3036x	- if (all( -
89	3036x	- use_of_ff == "max", -
90	3036x	- spec[[1]]$sink == TRUE, -
91	3036x	- spec[[1]]$type == "SFO", -
92	3036x	- spec[[2]]$type == "SFO", -
93	3036x	- is.null(spec[[2]]$to))) { -
94	1129x	- supported <- TRUE -
95	1129x	- k1 <- k_parent -
96	1129x	- k2 <- paste0("k_", n2) -
97	1129x	- f12 <- paste0("f_", n1, "_to_", n2) -
98	1129x	- predicted_text[n2] <- paste0( -
99	1129x	- "(((", k2, "-", k1, ")", n20, "-", f12, "", k1, "", n10, ")exp(-", k2, "*t)+", -
100	1129x	- f12, "", k1, "", n10, "exp(-", k1, "t))/(", k2, "-", k1, ")") -
101		- } -
102		- -
103		- # sfo_k120_sfo -
104	3036x	- if (all( -
105	3036x	- use_of_ff == "min", -
106	3036x	- spec[[1]]$sink == TRUE, -
107	3036x	- spec[[1]]$type == "SFO", -
108	3036x	- spec[[2]]$type == "SFO", -
109	3036x	- is.null(spec[[2]]$to))) { -
110	351x	- supported <- TRUE -
111	351x	- k12 <- paste0("k_", n1, "_", n2) -
112	351x	- k10 <- paste0("k_", n1, "_sink") -
113	351x	- k2 <- paste0("k_", n2, "_sink") -
114	351x	- predicted_text[n2] <- paste0( -
115	351x	- "(((", k2, "-", k12, "-", k10, ")", n20, "-", k12, "", n10, ")exp(-", k2, "t)+", -
116	351x	- k12, "", n10, "exp(-(", k_parent, ")*t))/(", k2, "-(", k_parent, "))") -
117		- } -
118		- -
119		- # dfop_f12_sfo -
120	3036x	- if (all( -
121	3036x	- use_of_ff == "max", -
122	3036x	- spec[[1]]$sink == TRUE, -
123	3036x	- spec[[1]]$type == "DFOP", -
124	3036x	- spec[[2]]$type == "SFO", -
125	3036x	- is.null(spec[[2]]$to))) { -
126	565x	- supported <- TRUE -
127	565x	- f12 <- paste0("f_", n1, "_to_", n2) -
128	565x	- k2 <- paste0("k_", n2) -
129	565x	- predicted_text[n2] <- paste0( -
130	565x	- "((", f12, "* g - ", f12, ") * k2 * ", n10, " * exp(- k2 * t))/(k2 - ", k2, ") - ", -
131	565x	- "((", f12, "* g) * k1 * ", n10, " * exp(- k1 * t))/(k1 - ", k2, ") + ", -
132	565x	- "(((k1 - ", k2, ") * k2 - ", k2, "* k1 + ", k2, "^2) * ", n20, "+", -
133	565x	- "((", f12, "* k1 + (", f12, "g - ", f12, ") ", k2, ") * k2 - ", f12, " * g * ", k2, " * k1) * ", n10, ") * ", -
134	565x	- "exp( - ", k2, " * t)/((k1 - ", k2, ") * k2 - ", k2, " * k1 + ", k2, "^2)") -
135		- } -
136		- -
137		- } -
138		- -
139	8117x	- if (supported) { -
140	7175x	- deg_func <- function(observed, odeini, odeparms) {} -
141		- -
142	7175x	- f_body <- paste0("{\n", -
143	7175x	- "predicted <- numeric(0)\n", -
144	7175x	- "with(as.list(odeparms), {\n") -
145	7175x	- for (obs_var in obs_vars) { -
146	9961x	- f_body <- paste0(f_body, -
147	9961x	- "t <- observed[observed$name == '", obs_var, "', 'time']\n", -
148	9961x	- "predicted <<- c(predicted, ", predicted_text[obs_var], ")\n") -
149		- } -
150	7175x	- f_body <- paste0(f_body, -
151	7175x	- "})\n", -
152	7175x	- "return(predicted)\n}\n") -
153		- -
154	7175x	- body(deg_func) <- parse(text = f_body) -
155	7175x	- return(deg_func) -
156		- } else { -
157	942x	- return(NULL) -
158		- } -
159		- } -

1		- #' Helper functions to create nlme models from mmkin row objects -
2		- #' -
3		- #' These functions facilitate setting up a nonlinear mixed effects model for -
4		- #' an mmkin row object. An mmkin row object is essentially a list of mkinfit -
5		- #' objects that have been obtained by fitting the same model to a list of -
6		- #' datasets. They are used internally by the [nlme.mmkin()] method. -
7		- #' -
8		- #' @param object An mmkin row object containing several fits of the same model to different datasets -
9		- #' @import nlme -
10		- #' @rdname nlme -
11		- #' @seealso \code{\link{nlme.mmkin}} -
12		- #' @examples -
13		- #' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120) -
14		- #' m_SFO <- mkinmod(parent = mkinsub("SFO")) -
15		- #' d_SFO_1 <- mkinpredict(m_SFO, -
16		- #' c(k_parent = 0.1), -
17		- #' c(parent = 98), sampling_times) -
18		- #' d_SFO_1_long <- mkin_wide_to_long(d_SFO_1, time = "time") -
19		- #' d_SFO_2 <- mkinpredict(m_SFO, -
20		- #' c(k_parent = 0.05), -
21		- #' c(parent = 102), sampling_times) -
22		- #' d_SFO_2_long <- mkin_wide_to_long(d_SFO_2, time = "time") -
23		- #' d_SFO_3 <- mkinpredict(m_SFO, -
24		- #' c(k_parent = 0.02), -
25		- #' c(parent = 103), sampling_times) -
26		- #' d_SFO_3_long <- mkin_wide_to_long(d_SFO_3, time = "time") -
27		- #' -
28		- #' d1 <- add_err(d_SFO_1, function(value) 3, n = 1) -
29		- #' d2 <- add_err(d_SFO_2, function(value) 2, n = 1) -
30		- #' d3 <- add_err(d_SFO_3, function(value) 4, n = 1) -
31		- #' ds <- c(d1 = d1, d2 = d2, d3 = d3) -
32		- #' -
33		- #' f <- mmkin("SFO", ds, cores = 1, quiet = TRUE) -
34		- #' mean_dp <- mean_degparms(f) -
35		- #' grouped_data <- nlme_data(f) -
36		- #' nlme_f <- nlme_function(f) -
37		- #' # These assignments are necessary for these objects to be -
38		- #' # visible to nlme and augPred when evaluation is done by -
39		- #' # pkgdown to generate the html docs. -
40		- #' assign("nlme_f", nlme_f, globalenv()) -
41		- #' assign("grouped_data", grouped_data, globalenv()) -
42		- #' -
43		- #' library(nlme) -
44		- #' m_nlme <- nlme(value ~ nlme_f(name, time, parent_0, log_k_parent_sink), -
45		- #' data = grouped_data, -
46		- #' fixed = parent_0 + log_k_parent_sink ~ 1, -
47		- #' random = pdDiag(parent_0 + log_k_parent_sink ~ 1), -
48		- #' start = mean_dp) -
49		- #' summary(m_nlme) -
50		- #' plot(augPred(m_nlme, level = 0:1), layout = c(3, 1)) -
51		- #' # augPred does not work on fits with more than one state -
52		- #' # variable -
53		- #' # -
54		- #' # The procedure is greatly simplified by the nlme.mmkin function -
55		- #' f_nlme <- nlme(f) -
56		- #' plot(f_nlme) -
57		- #' @return A function that can be used with nlme -
58		- #' @export -
59		- nlme_function <- function(object) { -
60	!	- if (nrow(object) > 1) stop("Only row objects allowed") -
61		- -
62	1168x	- mkin_model <- object[[1]]$mkinmod -
63		- -
64	1168x	- degparm_names <- names(mean_degparms(object)) -
65		- -
66		- # Inspired by https://stackoverflow.com/a/12983961/3805440 -
67		- # and https://stackoverflow.com/a/26280789/3805440 -
68	1168x	- model_function_alist <- replicate(length(degparm_names) + 2, substitute()) -
69	1168x	- names(model_function_alist) <- c("name", "time", degparm_names) -
70		- -
71	1168x	- model_function_body <- quote({ -
72	252739x	- arg_frame <- as.data.frame(as.list((environment())), stringsAsFactors = FALSE) -
73	252739x	- res_frame <- arg_frame[1:2] -
74	252739x	- parm_frame <- arg_frame[-(1:2)] -
75	252739x	- parms_unique <- unique(parm_frame) -
76		- -
77	252739x	- n_unique <- nrow(parms_unique) -
78		- -
79	252739x	- times_ds <- list() -
80	252739x	- names_ds <- list() -
81	252739x	- for (i in 1:n_unique) { -
82	2342789x	- times_ds[[i]] <- -
83	2342789x	- arg_frame[which(arg_frame[[3]] == parms_unique[i, 1]), "time"] -
84	2342789x	- names_ds[[i]] <- -
85	2342789x	- arg_frame[which(arg_frame[[3]] == parms_unique[i, 1]), "name"] -
86		- } -
87		- -
88	252739x	- res_list <- lapply(1:n_unique, function(x) { -
89	2342789x	- transparms_optim <- unlist(parms_unique[x, , drop = TRUE]) -
90	2342789x	- parms_fixed <- object[[1]]$bparms.fixed -
91		- -
92	2342789x	- odeini_optim_parm_names <- grep('_0$', names(transparms_optim), value = TRUE) -
93	2342789x	- odeini_optim <- transparms_optim[odeini_optim_parm_names] -
94	2342789x	- names(odeini_optim) <- gsub('_0$', '', odeini_optim_parm_names) -
95	2342789x	- odeini_fixed_parm_names <- grep('_0$', names(parms_fixed), value = TRUE) -
96	2342789x	- odeini_fixed <- parms_fixed[odeini_fixed_parm_names] -
97	2342789x	- names(odeini_fixed) <- gsub('_0$', '', odeini_fixed_parm_names) -
98	2342789x	- odeini <- c(odeini_optim, odeini_fixed)[names(mkin_model$diffs)] -
99		- -
100	2342789x	- ode_transparms_optim_names <- setdiff(names(transparms_optim), odeini_optim_parm_names) -
101	2342789x	- odeparms_optim <- backtransform_odeparms(transparms_optim[ode_transparms_optim_names], mkin_model, -
102	2342789x	- transform_rates = object[[1]]$transform_rates, -
103	2342789x	- transform_fractions = object[[1]]$transform_fractions) -
104	2342789x	- odeparms_fixed_names <- setdiff(names(parms_fixed), odeini_fixed_parm_names) -
105	2342789x	- odeparms_fixed <- parms_fixed[odeparms_fixed_names] -
106	2342789x	- odeparms <- c(odeparms_optim, odeparms_fixed) -
107		- -
108	2342789x	- out_wide <- mkinpredict(mkin_model, -
109	2342789x	- odeparms = odeparms, odeini = odeini, -
110	2342789x	- solution_type = object[[1]]$solution_type, -
111	2342789x	- outtimes = sort(unique(times_ds[[x]]))) -
112	2342789x	- out_array <- out_wide[, -1, drop = FALSE] -
113	2342789x	- rownames(out_array) <- as.character(unique(times_ds[[x]])) -
114	2342789x	- out_times <- as.character(times_ds[[x]]) -
115	2342789x	- out_names <- as.character(names_ds[[x]]) -
116	2342789x	- out_values <- mapply(function(times, names) out_array[times, names], -
117	2342789x	- out_times, out_names) -
118	2342789x	- return(as.numeric(out_values)) -
119		- }) -
120	252739x	- res <- unlist(res_list) -
121	252739x	- return(res) -
122		- }) -
123	1168x	- model_function <- as.function(c(model_function_alist, model_function_body)) -
124	1168x	- return(model_function) -
125		- } -
126		- -
127		- #' @rdname nlme -
128		- #' @importFrom rlang !!! -
129		- #' @return A \code{\link{groupedData}} object -
130		- #' @export -
131		- nlme_data <- function(object) { -
132	!	- if (nrow(object) > 1) stop("Only row objects allowed") -
133	5677x	- ds_names <- colnames(object) -
134		- -
135	5677x	- ds_list <- lapply(object, function(x) x$data[c("time", "variable", "observed")]) -
136	5677x	- names(ds_list) <- ds_names -
137	5677x	- ds_nlme <- vctrs::vec_rbind(!!!ds_list, .names_to = "ds") -
138	5677x	- ds_nlme$variable <- as.character(ds_nlme$variable) -
139	5677x	- ds_nlme$ds <- ordered(ds_nlme$ds, levels = unique(ds_nlme$ds)) -
140	5677x	- ds_nlme_renamed <- data.frame(ds = ds_nlme$ds, name = ds_nlme$variable, -
141	5677x	- time = ds_nlme$time, value = ds_nlme$observed, -
142	5677x	- stringsAsFactors = FALSE) -
143	5677x	- ds_nlme_grouped <- groupedData(value ~ time \| ds, ds_nlme_renamed, order.groups = FALSE) -
144	5677x	- return(ds_nlme_grouped) -
145		- } -

1		- #' Functions to transform and backtransform kinetic parameters for fitting -
2		- #' -
3		- #' The transformations are intended to map parameters that should only take on -
4		- #' restricted values to the full scale of real numbers. For kinetic rate -
5		- #' constants and other parameters that can only take on positive values, a -
6		- #' simple log transformation is used. For compositional parameters, such as the -
7		- #' formations fractions that should always sum up to 1 and can not be negative, -
8		- #' the [ilr] transformation is used. -
9		- #' -
10		- #' The transformation of sets of formation fractions is fragile, as it supposes -
11		- #' the same ordering of the components in forward and backward transformation. -
12		- #' This is no problem for the internal use in [mkinfit]. -
13		- #' -
14		- #' @param parms Parameters of kinetic models as used in the differential -
15		- #' equations. -
16		- #' @param transparms Transformed parameters of kinetic models as used in the -
17		- #' fitting procedure. -
18		- #' @param mkinmod The kinetic model of class [mkinmod], containing -
19		- #' the names of the model variables that are needed for grouping the -
20		- #' formation fractions before [ilr] transformation, the parameter -
21		- #' names and the information if the pathway to sink is included in the model. -
22		- #' @param transform_rates Boolean specifying if kinetic rate constants should -
23		- #' be transformed in the model specification used in the fitting for better -
24		- #' compliance with the assumption of normal distribution of the estimator. If -
25		- #' TRUE, also alpha and beta parameters of the FOMC model are -
26		- #' log-transformed, as well as k1 and k2 rate constants for the DFOP and HS -
27		- #' models and the break point tb of the HS model. -
28		- #' @param transform_fractions Boolean specifying if formation fractions -
29		- #' constants should be transformed in the model specification used in the -
30		- #' fitting for better compliance with the assumption of normal distribution -
31		- #' of the estimator. The default (TRUE) is to do transformations. -
32		- #' The g parameter of the DFOP model is also seen as a fraction. -
33		- #' If a single fraction is transformed (g parameter of DFOP or only a single -
34		- #' target variable e.g. a single metabolite plus a pathway to sink), a -
35		- #' logistic transformation is used [stats::qlogis()]. In other cases, i.e. if -
36		- #' two or more formation fractions need to be transformed whose sum cannot -
37		- #' exceed one, the [ilr] transformation is used. -
38		- #' @return A vector of transformed or backtransformed parameters -
39		- #' @importFrom stats plogis qlogis -
40		- #' @author Johannes Ranke -
41		- #' @examples -
42		- #' -
43		- #' SFO_SFO <- mkinmod( -
44		- #' parent = list(type = "SFO", to = "m1", sink = TRUE), -
45		- #' m1 = list(type = "SFO"), use_of_ff = "min") -
46		- #' -
47		- #' # Fit the model to the FOCUS example dataset D using defaults -
48		- #' FOCUS_D <- subset(FOCUS_2006_D, value != 0) # remove zero values to avoid warning -
49		- #' fit <- mkinfit(SFO_SFO, FOCUS_D, quiet = TRUE) -
50		- #' fit.s <- summary(fit) -
51		- #' # Transformed and backtransformed parameters -
52		- #' print(fit.s$par, 3) -
53		- #' print(fit.s$bpar, 3) -
54		- #' -
55		- #' \dontrun{ -
56		- #' # Compare to the version without transforming rate parameters (does not work -
57		- #' # with analytical solution, we get NA values for m1 in predictions) -
58		- #' fit.2 <- mkinfit(SFO_SFO, FOCUS_D, transform_rates = FALSE, -
59		- #' solution_type = "deSolve", quiet = TRUE) -
60		- #' fit.2.s <- summary(fit.2) -
61		- #' print(fit.2.s$par, 3) -
62		- #' print(fit.2.s$bpar, 3) -
63		- #' } -
64		- #' -
65		- #' initials <- fit$start$value -
66		- #' names(initials) <- rownames(fit$start) -
67		- #' transformed <- fit$start_transformed$value -
68		- #' names(transformed) <- rownames(fit$start_transformed) -
69		- #' transform_odeparms(initials, SFO_SFO) -
70		- #' backtransform_odeparms(transformed, SFO_SFO) -
71		- #' -
72		- #' \dontrun{ -
73		- #' # The case of formation fractions (this is now the default) -
74		- #' SFO_SFO.ff <- mkinmod( -
75		- #' parent = list(type = "SFO", to = "m1", sink = TRUE), -
76		- #' m1 = list(type = "SFO"), -
77		- #' use_of_ff = "max") -
78		- #' -
79		- #' fit.ff <- mkinfit(SFO_SFO.ff, FOCUS_D, quiet = TRUE) -
80		- #' fit.ff.s <- summary(fit.ff) -
81		- #' print(fit.ff.s$par, 3) -
82		- #' print(fit.ff.s$bpar, 3) -
83		- #' initials <- c("f_parent_to_m1" = 0.5) -
84		- #' transformed <- transform_odeparms(initials, SFO_SFO.ff) -
85		- #' backtransform_odeparms(transformed, SFO_SFO.ff) -
86		- #' -
87		- #' # And without sink -
88		- #' SFO_SFO.ff.2 <- mkinmod( -
89		- #' parent = list(type = "SFO", to = "m1", sink = FALSE), -
90		- #' m1 = list(type = "SFO"), -
91		- #' use_of_ff = "max") -
92		- #' -
93		- #' -
94		- #' fit.ff.2 <- mkinfit(SFO_SFO.ff.2, FOCUS_D, quiet = TRUE) -
95		- #' fit.ff.2.s <- summary(fit.ff.2) -
96		- #' print(fit.ff.2.s$par, 3) -
97		- #' print(fit.ff.2.s$bpar, 3) -
98		- #' } -
99		- #' -
100		- #' @export transform_odeparms -
101		- transform_odeparms <- function(parms, mkinmod, -
102		- transform_rates = TRUE, transform_fractions = TRUE) -
103		- { -
104		- # We need the model specification for the names of the model -
105		- # variables and the information on the sink -
106	25587x	- spec = mkinmod$spec -
107		- -
108		- # Set up container for transformed parameters -
109	25587x	- transparms <- numeric(0) -
110		- -
111		- # Do not transform initial values for state variables -
112	25587x	- state.ini.optim <- parms[grep("_0$", names(parms))] -
113	25587x	- transparms[names(state.ini.optim)] <- state.ini.optim -
114		- -
115		- # Log transformation for rate constants if requested -
116	25587x	- k <- parms[grep("^k_", names(parms))] -
117	25587x	- k__iore <- parms[grep("^k__iore_", names(parms))] -
118	25587x	- k <- c(k, k__iore) -
119	25587x	- if (length(k) > 0) { -
120	15485x	- if(transform_rates) { -
121	14379x	- transparms[paste0("log_", names(k))] <- log(k) -
122	1106x	- } else transparms[names(k)] <- k -
123		- } -
124		- -
125		- # Do not transform exponents in IORE models -
126	25587x	- N <- parms[grep("^N", names(parms))] -
127	25587x	- transparms[names(N)] <- N -
128		- -
129		- # Go through state variables and transform formation fractions if requested -
130	25587x	- mod_vars = names(spec) -
131	25587x	- for (box in mod_vars) { -
132	41283x	- f <- parms[grep(paste("^f", box, sep = "_"), names(parms))] -
133		- -
134	41283x	- if (length(f) > 0) { -
135	6522x	- if(transform_fractions) { -
136	5910x	- if (spec[[box]]$sink) { -
137	5908x	- if (length(f) == 1) { -
138	5894x	- trans_f_name <- paste("f", box, "qlogis", sep = "_") -
139	5894x	- transparms[trans_f_name] <- qlogis(f) -
140		- } else { -
141	14x	- trans_f <- ilr(c(f, 1 - sum(f))) -
142	14x	- trans_f_names <- paste("f", box, "ilr", 1:length(trans_f), sep = "_") -
143	14x	- transparms[trans_f_names] <- trans_f -
144		- } -
145		- } else { -
146	2x	- if (length(f) > 1) { -
147	2x	- trans_f <- ilr(f) -
148	2x	- trans_f_names <- paste("f", box, "ilr", 1:length(trans_f), sep = "_") -
149	2x	- transparms[trans_f_names] <- trans_f -
150		- } -
151		- } -
152		- } else { -
153	612x	- transparms[names(f)] <- f -
154		- } -
155		- } -
156		- } -
157		- -
158		- # Transform also FOMC parameters alpha and beta, DFOP and HS rates k1 and k2 -
159		- # and HS parameter tb as well as logistic model parameters kmax, k0 and r if -
160		- # transformation of rates is requested -
161	25587x	- for (pname in c("alpha", "beta", "k1", "k2", "tb", "kmax", "k0", "r")) { -
162	204696x	- if (!is.na(parms[pname])) { -
163	6006x	- if (transform_rates) { -
164	6006x	- transparms[paste0("log_", pname)] <- log(parms[pname]) -
165		- } else { -
166	!	- transparms[pname] <- parms[pname] -
167		- } -
168		- } -
169		- } -
170		- -
171		- # DFOP parameter g is treated as a fraction -
172	25587x	- if (!is.na(parms["g"])) { -
173	1978x	- g <- parms["g"] -
174	1978x	- if (transform_fractions) { -
175	1978x	- transparms["g_qlogis"] <- qlogis(g) -
176		- } else { -
177	!	- transparms["g"] <- g -
178		- } -
179		- } -
180		- -
181	25587x	- return(transparms) -
182		- } -
183		- -
184		- #' @rdname transform_odeparms -
185		- #' @export backtransform_odeparms -
186		- backtransform_odeparms <- function(transparms, mkinmod, -
187		- transform_rates = TRUE, -
188		- transform_fractions = TRUE) -
189		- { -
190		- # We need the model specification for the names of the model -
191		- # variables and the information on the sink -
192	49214214x	- spec = mkinmod$spec -
193		- -
194		- # Set up container for backtransformed parameters -
195	49214214x	- parms <- numeric(0) -
196		- -
197		- # Do not transform initial values for state variables -
198	49214214x	- state.ini.optim <- transparms[grep("_0$", names(transparms))] -
199	49214214x	- parms[names(state.ini.optim)] <- state.ini.optim -
200		- -
201		- # Exponential transformation for rate constants -
202	49214214x	- if(transform_rates) { -
203	49140623x	- trans_k <- transparms[grep("^log_k_", names(transparms))] -
204	49140623x	- trans_k__iore <- transparms[grep("^log_k__iore_", names(transparms))] -
205	49140623x	- trans_k = c(trans_k, trans_k__iore) -
206	49140623x	- if (length(trans_k) > 0) { -
207	47598103x	- k_names <- gsub("^log_k", "k", names(trans_k)) -
208	47598103x	- parms[k_names] <- exp(trans_k) -
209		- } -
210		- } else { -
211	73591x	- trans_k <- transparms[grep("^k_", names(transparms))] -
212	73591x	- parms[names(trans_k)] <- trans_k -
213	73591x	- trans_k__iore <- transparms[grep("^k__iore_", names(transparms))] -
214	73591x	- parms[names(trans_k__iore)] <- trans_k__iore -
215		- } -
216		- -
217		- # Do not transform exponents in IORE models -
218	49214214x	- N <- transparms[grep("^N", names(transparms))] -
219	49214214x	- parms[names(N)] <- N -
220		- -
221		- # Go through state variables and apply inverse transformations to formation fractions -
222	49214214x	- mod_vars = names(spec) -
223	49214214x	- for (box in mod_vars) { -
224		- # Get the names as used in the model -
225	97593385x	- f_names = grep(paste("^f", box, sep = "_"), mkinmod$parms, value = TRUE) -
226		- -
227		- # Get the formation fraction parameters -
228	97593385x	- trans_f = transparms[grep(paste("^f", box, sep = "_"), names(transparms))] -
229	97593385x	- if (length(trans_f) > 0) { -
230	46632823x	- if(transform_fractions) { -
231	46588453x	- if (any(grepl("qlogis", names(trans_f)))) { -
232	46059152x	- f_tmp <- plogis(trans_f) -
233	46059152x	- parms[f_names] <- f_tmp -
234		- } else { -
235	529301x	- f_tmp <- invilr(trans_f) -
236	529301x	- if (spec[[box]]$sink) { -
237	528393x	- parms[f_names] <- f_tmp[1:length(f_tmp)-1] -
238		- } else { -
239	908x	- parms[f_names] <- f_tmp -
240		- } -
241		- } -
242		- } else { -
243	44370x	- parms[names(trans_f)] <- trans_f -
244		- } -
245		- } -
246		- } -
247		- -
248		- # Transform parameters also for FOMC, DFOP, HS and logistic models -
249	49214214x	- for (pname in c("alpha", "beta", "k1", "k2", "tb", "kmax", "k0", "r")) { -
250	393713712x	- if (transform_rates) { -
251	393124984x	- pname_trans = paste0("log_", pname) -
252	393124984x	- if (!is.na(transparms[pname_trans])) { -
253	4306142x	- parms[pname] <- exp(transparms[pname_trans]) -
254		- } -
255		- } else { -
256	588728x	- if (!is.na(transparms[pname])) { -
257	!	- parms[pname] <- transparms[pname] -
258		- } -
259		- } -
260		- } -
261		- -
262		- # DFOP parameter g is now transformed using qlogis -
263	49214214x	- if (!is.na(transparms["g_qlogis"])) { -
264	2034008x	- g_qlogis <- transparms["g_qlogis"] -
265	2034008x	- parms["g"] <- plogis(g_qlogis) -
266		- } -
267		- # In earlier times we used ilr for g, so we keep this around -
268	49214214x	- if (!is.na(transparms["g_ilr"])) { -
269	!	- g_ilr <- transparms["g_ilr"] -
270	!	- parms["g"] <- invilr(g_ilr)[1] -
271		- } -
272	49214214x	- if (!is.na(transparms["g"])) { -
273	!	- parms["g"] <- transparms["g"] -
274		- } -
275		- -
276	49214214x	- return(parms) -
277		- } -
278		- # vim: set ts=2 sw=2 expandtab: -

1		- #' Hierarchical kinetics template -
2		- #' -
3		- #' R markdown format for setting up hierarchical kinetics based on a template -
4		- #' provided with the mkin package. This format is based on [rmarkdown::pdf_document]. -
5		- #' Chunk options are adapted. Echoing R code from code chunks and caching are -
6		- #' turned on per default. character for prepending output from code chunks is -
7		- #' set to the empty string, code tidying is off, figure alignment defaults to -
8		- #' centering, and positioning of figures is set to "H", which means that -
9		- #' figures will not move around in the document, but stay where the user -
10		- #' includes them. -
11		- #' -
12		- #' The latter feature (positioning the figures with "H") depends on the LaTeX -
13		- #' package 'float'. In addition, the LaTeX package 'listing' is used in the -
14		- #' template for showing model fit summaries in the Appendix. This means that -
15		- #' the LaTeX packages 'float' and 'listing' need to be installed in the TeX -
16		- #' distribution used. -
17		- #' -
18		- #' On Windows, the easiest way to achieve this (if no TeX distribution -
19		- #' is present before) is to install the 'tinytex' R package, to run -
20		- #' 'tinytex::install_tinytex()' to get the basic tiny Tex distribution, -
21		- #' and then to run 'tinytex::tlmgr_install(c("float", "listing"))'. -
22		- #' -
23		- #' @inheritParams rmarkdown::pdf_document -
24		- #' @param ... Arguments to \code{rmarkdown::pdf_document} -
25		- #' -
26		- #' @return R Markdown output format to pass to -
27		- #' \code{\link[rmarkdown:render]{render}} -
28		- #' -
29		- #' @examples -
30		- #' -
31		- #' \dontrun{ -
32		- #' library(rmarkdown) -
33		- #' # The following is now commented out after the relase of v1.2.3 for the generation -
34		- #' # of online docs, as the command creates a directory and opens an editor -
35		- #' #draft("example_analysis.rmd", template = "hierarchical_kinetics", package = "mkin") -
36		- #' } -
37		- #' -
38		- #' @export -
39		- hierarchical_kinetics <- function(..., keep_tex = FALSE) { -
40		- -
41	!	- if (getRversion() < "4.1.0") -
42	!	- stop("You need R with version > 4.1.0 to compile this document") -
43		- -
44	!	- if (!requireNamespace("knitr")) stop("Please install the knitr package to use this template") -
45	!	- if (!requireNamespace("rmarkdown")) stop("Please install the rmarkdown package to use this template") -
46	!	- knitr::opts_chunk$set(cache = TRUE, comment = "", tidy = FALSE, echo = TRUE) -
47	!	- knitr::opts_chunk$set(fig.align = "center", fig.pos = "H") -
48	!	- options(knitr.kable.NA = "") -
49		- -
50	!	- fmt <- rmarkdown::pdf_document(..., -
51	!	- keep_tex = keep_tex, -
52	!	- toc = TRUE, -
53	!	- toc_depth = 3, -
54	!	- includes = rmarkdown::includes(in_header = "header.tex"), -
55	!	- extra_dependencies = c("float", "listing", "framed") -
56		- ) -
57		- -
58	!	- return(fmt) -
59		- } -

1		- # Code inspired by nlme::nlme.nlsList and R/nlme_fit.R from nlmixr -
2		- -
3		- # We need to assign the degradation function created in nlme.mmkin to an -
4		- # environment that is always accessible, also e.g. when evaluation is done by -
5		- # testthat or pkgdown. Therefore parent.frame() is not good enough. The -
6		- # following environment will be in the mkin namespace. -
7		- .nlme_env <- new.env(parent = emptyenv()) -
8		- -
9		- #' @export -
10		- nlme::nlme -
11		- -
12		- #' Retrieve a degradation function from the mmkin namespace -
13		- #' -
14		- #' @importFrom utils getFromNamespace -
15		- #' @return A function that was likely previously assigned from within -
16		- #' nlme.mmkin -
17		- #' @export -
18		- get_deg_func <- function() { -
19	217279x	- return(get("deg_func", getFromNamespace(".nlme_env", "mkin"))) -
20		- } -
21		- -
22		- #' Create an nlme model for an mmkin row object -
23		- #' -
24		- #' This functions sets up a nonlinear mixed effects model for an mmkin row -
25		- #' object. An mmkin row object is essentially a list of mkinfit objects that -
26		- #' have been obtained by fitting the same model to a list of datasets. -
27		- #' -
28		- #' Note that the convergence of the nlme algorithms depends on the quality -
29		- #' of the data. In degradation kinetics, we often only have few datasets -
30		- #' (e.g. data for few soils) and complicated degradation models, which may -
31		- #' make it impossible to obtain convergence with nlme. -
32		- #' -
33		- #' @param model An [mmkin] row object. -
34		- #' @param data Ignored, data are taken from the mmkin model -
35		- #' @param fixed Ignored, all degradation parameters fitted in the -
36		- #' mmkin model are used as fixed parameters -
37		- #' @param random If not specified, no correlations between random effects are -
38		- #' set up for the optimised degradation model parameters. This is -
39		- #' achieved by using the [nlme::pdDiag] method. -
40		- #' @param groups See the documentation of nlme -
41		- #' @param start If not specified, mean values of the fitted degradation -
42		- #' parameters taken from the mmkin object are used -
43		- #' @param correlation See the documentation of nlme -
44		- #' @param weights passed to nlme -
45		- #' @param subset passed to nlme -
46		- #' @param method passed to nlme -
47		- #' @param na.action passed to nlme -
48		- #' @param naPattern passed to nlme -
49		- #' @param control passed to nlme -
50		- #' @param verbose passed to nlme -
51		- #' @importFrom stats na.fail as.formula -
52		- #' @return Upon success, a fitted 'nlme.mmkin' object, which is an nlme object -
53		- #' with additional elements. It also inherits from 'mixed.mmkin'. -
54		- #' @note As the object inherits from [nlme::nlme], there is a wealth of -
55		- #' methods that will automatically work on 'nlme.mmkin' objects, such as -
56		- #' [nlme::intervals()], [nlme::anova.lme()] and [nlme::coef.lme()]. -
57		- #' @export -
58		- #' @seealso [nlme_function()], [plot.mixed.mmkin], [summary.nlme.mmkin] -
59		- #' @examples -
60		- #' ds <- lapply(experimental_data_for_UBA_2019[6:10], -
61		- #' function(x) subset(x$data[c("name", "time", "value")], name == "parent")) -
62		- #' -
63		- #' \dontrun{ -
64		- #' f <- mmkin(c("SFO", "DFOP"), ds, quiet = TRUE, cores = 1) -
65		- #' library(nlme) -
66		- #' f_nlme_sfo <- nlme(f["SFO", ]) -
67		- #' f_nlme_dfop <- nlme(f["DFOP", ]) -
68		- #' anova(f_nlme_sfo, f_nlme_dfop) -
69		- #' print(f_nlme_dfop) -
70		- #' plot(f_nlme_dfop) -
71		- #' endpoints(f_nlme_dfop) -
72		- #' -
73		- #' ds_2 <- lapply(experimental_data_for_UBA_2019[6:10], -
74		- #' function(x) x$data[c("name", "time", "value")]) -
75		- #' m_sfo_sfo <- mkinmod(parent = mkinsub("SFO", "A1"), -
76		- #' A1 = mkinsub("SFO"), use_of_ff = "min", quiet = TRUE) -
77		- #' m_sfo_sfo_ff <- mkinmod(parent = mkinsub("SFO", "A1"), -
78		- #' A1 = mkinsub("SFO"), use_of_ff = "max", quiet = TRUE) -
79		- #' m_dfop_sfo <- mkinmod(parent = mkinsub("DFOP", "A1"), -
80		- #' A1 = mkinsub("SFO"), quiet = TRUE) -
81		- #' -
82		- #' f_2 <- mmkin(list("SFO-SFO" = m_sfo_sfo, -
83		- #' "SFO-SFO-ff" = m_sfo_sfo_ff, -
84		- #' "DFOP-SFO" = m_dfop_sfo), -
85		- #' ds_2, quiet = TRUE) -
86		- #' -
87		- #' f_nlme_sfo_sfo <- nlme(f_2["SFO-SFO", ]) -
88		- #' plot(f_nlme_sfo_sfo) -
89		- #' -
90		- #' # With formation fractions this does not coverge with defaults -
91		- #' # f_nlme_sfo_sfo_ff <- nlme(f_2["SFO-SFO-ff", ]) -
92		- #' #plot(f_nlme_sfo_sfo_ff) -
93		- #' -
94		- #' # For the following, we need to increase pnlsMaxIter and the tolerance -
95		- #' # to get convergence -
96		- #' f_nlme_dfop_sfo <- nlme(f_2["DFOP-SFO", ], -
97		- #' control = list(pnlsMaxIter = 120, tolerance = 5e-4)) -
98		- #' -
99		- #' plot(f_nlme_dfop_sfo) -
100		- #' -
101		- #' anova(f_nlme_dfop_sfo, f_nlme_sfo_sfo) -
102		- #' -
103		- #' endpoints(f_nlme_sfo_sfo) -
104		- #' endpoints(f_nlme_dfop_sfo) -
105		- #' -
106		- #' if (length(findFunction("varConstProp")) > 0) { # tc error model for nlme available -
107		- #' # Attempts to fit metabolite kinetics with the tc error model are possible, -
108		- #' # but need tweeking of control values and sometimes do not converge -
109		- #' -
110		- #' f_tc <- mmkin(c("SFO", "DFOP"), ds, quiet = TRUE, error_model = "tc") -
111		- #' f_nlme_sfo_tc <- nlme(f_tc["SFO", ]) -
112		- #' f_nlme_dfop_tc <- nlme(f_tc["DFOP", ]) -
113		- #' AIC(f_nlme_sfo, f_nlme_sfo_tc, f_nlme_dfop, f_nlme_dfop_tc) -
114		- #' print(f_nlme_dfop_tc) -
115		- #' } -
116		- #' -
117		- #' f_2_obs <- update(f_2, error_model = "obs") -
118		- #' f_nlme_sfo_sfo_obs <- nlme(f_2_obs["SFO-SFO", ]) -
119		- #' print(f_nlme_sfo_sfo_obs) -
120		- #' f_nlme_dfop_sfo_obs <- nlme(f_2_obs["DFOP-SFO", ], -
121		- #' control = list(pnlsMaxIter = 120, tolerance = 5e-4)) -
122		- #' -
123		- #' f_2_tc <- update(f_2, error_model = "tc") -
124		- #' # f_nlme_sfo_sfo_tc <- nlme(f_2_tc["SFO-SFO", ]) # No convergence with 50 iterations -
125		- #' # f_nlme_dfop_sfo_tc <- nlme(f_2_tc["DFOP-SFO", ], -
126		- #' # control = list(pnlsMaxIter = 120, tolerance = 5e-4)) # Error in X[, fmap[[nm]]] <- gradnm -
127		- #' -
128		- #' anova(f_nlme_dfop_sfo, f_nlme_dfop_sfo_obs) -
129		- #' -
130		- #' } -
131		- nlme.mmkin <- function(model, data = "auto", -
132		- fixed = lapply(as.list(names(mean_degparms(model))), -
133		- function(el) eval(parse(text = paste(el, 1, sep = "~")))), -
134		- random = pdDiag(fixed), -
135		- groups, -
136		- start = mean_degparms(model, random = TRUE, test_log_parms = TRUE), -
137		- correlation = NULL, weights = NULL, -
138		- subset, method = c("ML", "REML"), -
139		- na.action = na.fail, naPattern, -
140		- control = list(), verbose= FALSE) -
141		- { -
142	!	- if (nrow(model) > 1) stop("Only row objects allowed") -
143		- -
144	1013x	- thisCall <- as.list(match.call())[-1] -
145		- -
146		- # Warn in case arguments were used that are overriden -
147	1013x	- if (any(!is.na(match(names(thisCall), -
148	1013x	- c("data"))))) { -
149	!	- warning("'nlme.mmkin' will redefine 'data'") -
150		- } -
151		- -
152		- # Get native symbol info for speed -
153	1013x	- if (model[[1]]$solution_type == "deSolve" & !is.null(model[[1]]$mkinmod$cf)) { -
154		- # The mkinmod stored in the first fit will be used by nlme -
155	189x	- model[[1]]$mkinmod$symbols <- deSolve::checkDLL( -
156	189x	- dllname = model[[1]]$mkinmod$dll_info[["name"]], -
157	189x	- func = "diffs", initfunc = "initpar", -
158	189x	- jacfunc = NULL, nout = 0, outnames = NULL) -
159		- } -
160		- -
161	1013x	- deg_func <- nlme_function(model) -
162		- -
163	1013x	- assign("deg_func", deg_func, getFromNamespace(".nlme_env", "mkin")) -
164		- -
165		- # For the formula, get the degradation function from the mkin namespace -
166	1013x	- this_model_text <- paste0("value ~ mkin::get_deg_func()(", -
167	1013x	- paste(names(formals(deg_func)), collapse = ", "), ")") -
168	1013x	- this_model <- as.formula(this_model_text) -
169		- -
170	1013x	- thisCall[["model"]] <- this_model -
171		- -
172	1013x	- thisCall[["data"]] <- nlme_data(model) -
173		- -
174	1013x	- thisCall[["start"]] <- start -
175		- -
176	1013x	- thisCall[["fixed"]] <- fixed -
177		- -
178	1013x	- thisCall[["random"]] <- random -
179		- -
180	1013x	- error_model <- model[[1]]$err_mod -
181		- -
182	1013x	- if (missing(weights)) { -
183	1013x	- thisCall[["weights"]] <- switch(error_model, -
184	1013x	- const = NULL, -
185	1013x	- obs = varIdent(form = ~ 1 \| name), -
186	1013x	- tc = varConstProp()) -
187	1013x	- sigma <- switch(error_model, -
188	1013x	- tc = 1, -
189	1013x	- NULL) -
190		- } -
191		- -
192	1013x	- control <- thisCall[["control"]] -
193	1013x	- if (error_model == "tc") { -
194	928x	- control$sigma = 1 -
195	928x	- thisCall[["control"]] <- control -
196		- } -
197		- -
198	1013x	- fit_time <- system.time(val <- do.call("nlme.formula", thisCall)) -
199	1013x	- val$time <- fit_time -
200		- -
201	1013x	- val$mkinmod <- model[[1]]$mkinmod -
202		- # Don't return addresses that will become invalid -
203	1013x	- val$mkinmod$symbols <- NULL -
204		- -
205	1013x	- val$data <- thisCall[["data"]] -
206	1013x	- val$mmkin <- model -
207	824x	- if (is.list(start)) val$mean_dp_start <- start$fixed -
208	189x	- else val$mean_dp_start <- start -
209	1013x	- val$transform_rates <- model[[1]]$transform_rates -
210	1013x	- val$transform_fractions <- model[[1]]$transform_fractions -
211	1013x	- val$solution_type <- model[[1]]$solution_type -
212	1013x	- val$err_mode <- error_model -
213		- -
214	1013x	- val$bparms.optim <- backtransform_odeparms(val$coefficients$fixed, -
215	1013x	- val$mkinmod, -
216	1013x	- transform_rates = val$transform_rates, -
217	1013x	- transform_fractions = val$transform_fractions) -
218		- -
219	1013x	- val$bparms.fixed <- model[[1]]$bparms.fixed -
220	1013x	- val$date.fit <- date() -
221	1013x	- val$nlmeversion <- as.character(utils::packageVersion("nlme")) -
222	1013x	- val$mkinversion <- as.character(utils::packageVersion("mkin")) -
223	1013x	- val$Rversion <- paste(R.version$major, R.version$minor, sep=".") -
224	1013x	- class(val) <- c("nlme.mmkin", "mixed.mmkin", "nlme", "lme") -
225	1013x	- return(val) -
226		- } -
227		- -
228		- #' @export -
229		- #' @rdname nlme.mmkin -
230		- #' @param x An nlme.mmkin object to print -
231		- #' @param digits Number of digits to use for printing -
232		- print.nlme.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) { -
233	117x	- cat( "Kinetic nonlinear mixed-effects model fit by " ) -
234	117x	- cat( if(x$method == "REML") "REML\n" else "maximum likelihood\n") -
235	117x	- cat("\nStructural model:\n") -
236	117x	- diffs <- x$mmkin[[1]]$mkinmod$diffs -
237	117x	- nice_diffs <- gsub("^(d.*) =", "\\1/dt =", diffs) -
238	117x	- writeLines(strwrap(nice_diffs, exdent = 11)) -
239	117x	- cat("\nData:\n") -
240	117x	- cat(nrow(x$data), "observations of", -
241	117x	- length(unique(x$data$name)), "variable(s) grouped in", -
242	117x	- length(unique(x$data$ds)), "datasets\n") -
243	117x	- cat("\nLog-", if(x$method == "REML") "restricted-" else "", -
244	117x	- "likelihood: ", format(x$logLik, digits = digits), "\n", sep = "") -
245	117x	- fixF <- x$call$fixed -
246	117x	- cat("\nFixed effects:\n", -
247	117x	- deparse( -
248	117x	- if(inherits(fixF, "formula") \|\| is.call(fixF) \|\| is.name(fixF)) -
249	117x	- x$call$fixed -
250		- else -
251	117x	- lapply(fixF, function(el) as.name(deparse(el)))), "\n") -
252	117x	- print(fixef(x), digits = digits, ...) -
253	117x	- cat("\n") -
254	117x	- print(summary(x$modelStruct), sigma = x$sigma, digits = digits, ...) -
255	117x	- invisible(x) -
256		- } -
257		- -
258		- #' @export -
259		- #' @rdname nlme.mmkin -
260		- #' @param object An nlme.mmkin object to update -
261		- #' @param ... Update specifications passed to update.nlme -
262		- update.nlme.mmkin <- function(object, ...) { -
263	85x	- res <- NextMethod() -
264	85x	- res$mmkin <- object$mmkin -
265	85x	- class(res) <- c("nlme.mmkin", "nlme", "lme") -
266	85x	- return(res) -
267		- } -

1		- utils::globalVariables(c("variable", "residual")) -
2		- -
3		- #' Function to plot residuals stored in an mkin object -
4		- #' -
5		- #' This function plots the residuals for the specified subset of the observed -
6		- #' variables from an mkinfit object. A combined plot of the fitted model and -
7		- #' the residuals can be obtained using \code{\link{plot.mkinfit}} using the -
8		- #' argument \code{show_residuals = TRUE}. -
9		- #' -
10		- #' @importFrom stats residuals -
11		- #' @param object A fit represented in an \code{\link{mkinfit}} object. -
12		- #' @param obs_vars A character vector of names of the observed variables for -
13		- #' which residuals should be plotted. Defaults to all observed variables in -
14		- #' the model -
15		- #' @param xlim plot range in x direction. -
16		- #' @param xlab Label for the x axis. -
17		- #' @param standardized Should the residuals be standardized by dividing by the -
18		- #' standard deviation given by the error model of the fit? -
19		- #' @param ylab Label for the y axis. -
20		- #' @param maxabs Maximum absolute value of the residuals. This is used for the -
21		- #' scaling of the y axis and defaults to "auto". -
22		- #' @param legend Should a legend be plotted? -
23		- #' @param lpos Where should the legend be placed? Default is "topright". Will -
24		- #' be passed on to \code{\link{legend}}. -
25		- #' @param col_obs Colors for the observed variables. -
26		- #' @param pch_obs Symbols to be used for the observed variables. -
27		- #' @param frame Should a frame be drawn around the plots? -
28		- #' @param \dots further arguments passed to \code{\link{plot}}. -
29		- #' @return Nothing is returned by this function, as it is called for its side -
30		- #' effect, namely to produce a plot. -
31		- #' @author Johannes Ranke and Katrin Lindenberger -
32		- #' @seealso \code{\link{mkinplot}}, for a way to plot the data and the fitted -
33		- #' lines of the mkinfit object, and \code{\link{plot_res}} for a function -
34		- #' combining the plot of the fit and the residual plot. -
35		- #' @examples -
36		- #' -
37		- #' model <- mkinmod(parent = mkinsub("SFO", "m1"), m1 = mkinsub("SFO")) -
38		- #' fit <- mkinfit(model, FOCUS_2006_D, quiet = TRUE) -
39		- #' mkinresplot(fit, "m1") -
40		- #' -
41		- #' @export -
42		- mkinresplot <- function (object, -
43		- obs_vars = names(object$mkinmod$map), -
44		- xlim = c(0, 1.1 * max(object$data$time)), -
45		- standardized = FALSE, -
46		- xlab = "Time", ylab = ifelse(standardized, "Standardized residual", "Residual"), -
47		- maxabs = "auto", legend = TRUE, lpos = "topright", -
48		- col_obs = "auto", pch_obs = "auto", -
49		- frame = TRUE, -
50		- ...) -
51		- { -
52	1228x	- obs_vars_all <- as.character(unique(object$data$variable)) -
53		- -
54	1228x	- if (length(obs_vars) > 0){ -
55	1228x	- obs_vars <- intersect(obs_vars_all, obs_vars) -
56	!	- } else obs_vars <- obs_vars_all -
57		- -
58	1228x	- if (standardized) { -
59	!	- res_col <- "standardized" -
60	!	- object$data[[res_col]] <- residuals(object, standardized = TRUE) -
61		- } else { -
62	1228x	- res_col <- "residual" -
63		- } -
64	1228x	- res <- subset(object$data, variable %in% obs_vars)[res_col] -
65		- -
66	1228x	- if (maxabs == "auto") maxabs = max(abs(res), na.rm = TRUE) -
67		- -
68		- # Set colors and symbols -
69	1228x	- if (col_obs[1] == "auto") { -
70	948x	- col_obs <- 1:length(obs_vars) -
71		- } -
72		- -
73	1228x	- if (pch_obs[1] == "auto") { -
74	948x	- pch_obs <- 1:length(obs_vars) -
75		- } -
76	1228x	- names(col_obs) <- names(pch_obs) <- obs_vars -
77		- -
78	1228x	- plot(0, type = "n", frame = frame, -
79	1228x	- xlab = xlab, ylab = ylab, -
80	1228x	- xlim = xlim, -
81	1228x	- ylim = c(-1.2 * maxabs, 1.2 * maxabs), ...) -
82		- -
83	1228x	- for(obs_var in obs_vars){ -
84	1298x	- residuals_plot <- subset(object$data, variable == obs_var, c("time", res_col)) -
85	1298x	- points(residuals_plot, pch = pch_obs[obs_var], col = col_obs[obs_var]) -
86		- } -
87		- -
88	1228x	- abline(h = 0, lty = 2) -
89		- -
90	1228x	- if (legend == TRUE) { -
91	!	- legend(lpos, inset = c(0.05, 0.05), legend = obs_vars, -
92	!	- col = col_obs[obs_vars], pch = pch_obs[obs_vars]) -
93		- } -
94		- } -

1		- #' Plot model fits (observed and fitted) and the residuals for a row or column -
2		- #' of an mmkin object -
3		- #' -
4		- #' When x is a row selected from an mmkin object (\code{\link{[.mmkin}}), the -
5		- #' same model fitted for at least one dataset is shown. When it is a column, -
6		- #' the fit of at least one model to the same dataset is shown. -
7		- #' -
8		- #' If the current plot device is a \code{\link[tikzDevice]{tikz}} device, then -
9		- #' latex is being used for the formatting of the chi2 error level. -
10		- #' -
11		- #' @param x An object of class \code{\link{mmkin}}, with either one row or one -
12		- #' column. -
13		- #' @param main The main title placed on the outer margin of the plot. -
14		- #' @param legends An index for the fits for which legends should be shown. -
15		- #' @param resplot Should the residuals plotted against time, using -
16		- #' \code{\link{mkinresplot}}, or as squared residuals against predicted -
17		- #' values, with the error model, using \code{\link{mkinerrplot}}. -
18		- #' @param ylab Label for the y axis. -
19		- #' @param standardized Should the residuals be standardized? This option -
20		- #' is passed to \code{\link{mkinresplot}}, it only takes effect if -
21		- #' `resplot = "time"`. -
22		- #' @param show_errmin Should the chi2 error level be shown on top of the plots -
23		- #' to the left? -
24		- #' @param errmin_var The variable for which the FOCUS chi2 error value should -
25		- #' be shown. -
26		- #' @param errmin_digits The number of significant digits for rounding the FOCUS -
27		- #' chi2 error percentage. -
28		- #' @param cex Passed to the plot functions and \code{\link{mtext}}. -
29		- #' @param rel.height.middle The relative height of the middle plot, if more -
30		- #' than two rows of plots are shown. -
31		- #' @param ymax Maximum y axis value for \code{\link{plot.mkinfit}}. -
32		- #' @param \dots Further arguments passed to \code{\link{plot.mkinfit}} and -
33		- #' \code{\link{mkinresplot}}. -
34		- #' @return The function is called for its side effect. -
35		- #' @author Johannes Ranke -
36		- #' @examples -
37		- #' -
38		- #' \dontrun{ -
39		- #' # Only use one core not to offend CRAN checks -
40		- #' fits <- mmkin(c("FOMC", "HS"), -
41		- #' list("FOCUS B" = FOCUS_2006_B, "FOCUS C" = FOCUS_2006_C), # named list for titles -
42		- #' cores = 1, quiet = TRUE, error_model = "tc") -
43		- #' plot(fits[, "FOCUS C"]) -
44		- #' plot(fits["FOMC", ]) -
45		- #' plot(fits["FOMC", ], show_errmin = FALSE) -
46		- #' -
47		- #' # We can also plot a single fit, if we like the way plot.mmkin works, but then the plot -
48		- #' # height should be smaller than the plot width (this is not possible for the html pages -
49		- #' # generated by pkgdown, as far as I know). -
50		- #' plot(fits["FOMC", "FOCUS C"]) # same as plot(fits[1, 2]) -
51		- #' -
52		- #' # Show the error models -
53		- #' plot(fits["FOMC", ], resplot = "errmod") -
54		- #' } -
55		- #' -
56		- #' @export -
57		- plot.mmkin <- function(x, main = "auto", legends = 1, -
58		- resplot = c("time", "errmod"), -
59		- ylab = "Residue", -
60		- standardized = FALSE, -
61		- show_errmin = TRUE, -
62		- errmin_var = "All data", errmin_digits = 3, -
63		- cex = 0.7, rel.height.middle = 0.9, -
64		- ymax = "auto", ...) -
65		- { -
66		- -
67	316x	- oldpar <- par(no.readonly = TRUE) -
68	316x	- on.exit(par(oldpar, no.readonly = TRUE)) -
69		- -
70	316x	- n.m <- nrow(x) -
71	316x	- n.d <- ncol(x) -
72		- -
73	316x	- resplot <- match.arg(resplot) -
74		- -
75		- # We can handle either a row (different models, same dataset) -
76		- # or a column (same model, different datasets) -
77	!	- if (n.m > 1 & n.d > 1) stop("Please select fits either for one model or for one dataset") -
78	!	- if (n.m == 1 & n.d == 1) loop_over = "none" -
79	246x	- if (n.m > 1) loop_over <- "models" -
80	70x	- if (n.d > 1) loop_over <- "datasets" -
81	316x	- n.fits <- length(x) -
82		- -
83		- # Set the main plot titles from the names of the models or the datasets -
84		- # Will be integer indexes if no other names are present in the mmkin object -
85	316x	- if (main == "auto") { -
86	140x	- main = switch(loop_over, -
87	140x	- none = paste(rownames(x), colnames(x)), -
88	140x	- models = colnames(x), -
89	140x	- datasets = rownames(x)) -
90		- } -
91		- -
92		- # Set relative plot heights, so the first and the last plot are the norm -
93		- # and the middle plots (if n.fits >2) are smaller by rel.height.middle -
94	316x	- rel.heights <- if (n.fits > 2) c(1, rep(rel.height.middle, n.fits - 2), 1) -
95	316x	- else rep(1, n.fits) -
96	316x	- layout(matrix(1:(2 * n.fits), n.fits, 2, byrow = TRUE), heights = rel.heights) -
97		- -
98	316x	- par(cex = cex) -
99		- -
100	316x	- for (i.fit in 1:n.fits) { -
101		- -
102		- # Margins for top row of plots when we have more than one row -
103		- # Reduce bottom margin by 2.1 - hides x axis legend -
104	948x	- if (i.fit == 1 & n.fits > 1) { -
105	316x	- par(mar = c(3.0, 4.1, 4.1, 2.1)) -
106		- } -
107		- -
108		- # Margins for middle rows of plots, if any -
109	948x	- if (i.fit > 1 & i.fit < n.fits) { -
110		- # Reduce top margin by 2 after the first plot as we have no main title, -
111		- # reduced plot height, therefore we need rel.height.middle in the layout -
112	316x	- par(mar = c(3.0, 4.1, 2.1, 2.1)) -
113		- } -
114		- -
115		- # Margins for bottom row of plots when we have more than one row -
116	948x	- if (i.fit == n.fits & n.fits > 1) { -
117		- # Restore bottom margin for last plot to show x axis legend -
118	316x	- par(mar = c(5.1, 4.1, 2.1, 2.1)) -
119		- } -
120		- -
121	948x	- fit <- x[[i.fit]] -
122	948x	- if (ymax == "auto") { -
123	948x	- plot(fit, legend = legends == i.fit, ylab = ylab, ...) -
124		- } else { -
125	!	- plot(fit, legend = legends == i.fit, ylim = c(0, ymax), ylab = ylab, ...) -
126		- } -
127		- -
128	948x	- title(main, outer = TRUE, line = -2) -
129		- -
130	948x	- fit_name <- switch(loop_over, -
131	948x	- models = rownames(x)[i.fit], -
132	948x	- datasets = colnames(x)[i.fit], -
133	948x	- none = "") -
134		- -
135	948x	- if (show_errmin) { -
136	948x	- chi2 <- signif(100 * mkinerrmin(fit)[errmin_var, "err.min"], errmin_digits) -
137		- -
138		- # Use LateX if the current plotting device is tikz -
139	948x	- if (names(dev.cur()) == "tikz output") { -
140	!	- chi2_text <- paste0(fit_name, " $\\chi^2$ error level = ", chi2, "\\%") -
141		- } else { -
142	948x	- chi2_perc <- paste0(chi2, "%") -
143	948x	- chi2_text <- bquote(.(fit_name) ~ chi^2 ~ "error level" == .(chi2_perc)) -
144		- } -
145	948x	- mtext(chi2_text, cex = cex, line = 0.4) -
146		- } else { -
147	!	- mtext(fit_name, cex = cex, line = 0.4) -
148		- } -
149		- -
150	948x	- if (resplot == "time") { -
151	948x	- mkinresplot(fit, legend = FALSE, standardized = standardized, ...) -
152		- } else { -
153	!	- mkinerrplot(fit, legend = FALSE, ...) -
154		- } -
155	948x	- mtext(paste(fit_name, "residuals"), cex = cex, line = 0.4) -
156		- } -
157		- } -

1		- #' Summary method for class "mmkin" -
2		- #' -
3		- #' Shows status information on the [mkinfit] objects contained in the object -
4		- #' and gives an overview of ill-defined parameters calculated by [illparms]. -
5		- #' -
6		- #' @param object an object of class [mmkin] -
7		- #' @param x an object of class \code{summary.mmkin}. -
8		- #' @param conf.level confidence level for testing parameters -
9		- #' @param digits number of digits to use for printing -
10		- #' @param \dots optional arguments passed to methods like \code{print}. -
11		- #' @examples -
12		- #' -
13		- #' fits <- mmkin( -
14		- #' c("SFO", "FOMC"), -
15		- #' list("FOCUS A" = FOCUS_2006_A, -
16		- #' "FOCUS C" = FOCUS_2006_C), -
17		- #' quiet = TRUE, cores = 1) -
18		- #' summary(fits) -
19		- #' -
20		- #' @export -
21		- summary.mmkin <- function(object, conf.level = 0.95, ...) { -
22		- -
23	1x	- ans <- list( -
24	1x	- err_mod = object[[1, 1]]$err_mod, -
25	1x	- time = attr(object, "time"), -
26	1x	- illparms = illparms(object), -
27	1x	- status = status(object) -
28		- ) -
29		- -
30	1x	- class(ans) <- c("summary.mmkin") -
31	1x	- return(ans) -
32		- } -
33		- -
34		- #' @rdname summary.mmkin -
35		- #' @export -
36		- print.summary.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) { -
37	1x	- if (!is.null(x$err_mod)) { -
38	1x	- cat("Error model: ") -
39	1x	- cat(switch(x$err_mod, -
40	1x	- const = "Constant variance", -
41	1x	- obs = "Variance unique to each observed variable", -
42	1x	- tc = "Two-component variance function"), "\n") -
43		- } -
44	1x	- cat("Fitted in", x$time[["elapsed"]], "s\n") -
45		- -
46	1x	- cat("\nStatus:\n") -
47	1x	- print(x$status) -
48		- -
49	1x	- if (any(x$illparms != "")) { -
50	1x	- cat("\nIll-defined parameters:\n") -
51	1x	- print(x$illparms) -
52		- } -
53		- -
54	1x	- invisible(x) -
55		- } -
56		- -

1		- #' Read datasets and relevant meta information from a spreadsheet file -
2		- #' -
3		- #' This function imports one dataset from each sheet of a spreadsheet file. -
4		- #' These sheets are selected based on the contents of a sheet 'Datasets', with -
5		- #' a column called 'Dataset Number', containing numbers identifying the dataset -
6		- #' sheets to be read in. In the second column there must be a grouping -
7		- #' variable, which will often be named 'Soil'. Optionally, time normalization -
8		- #' factors can be given in columns named 'Temperature' and 'Moisture'. -
9		- #' -
10		- #' There must be a sheet 'Compounds', with columns 'Name' and 'Acronym'. -
11		- #' The first row read after the header read in from this sheet is assumed -
12		- #' to contain name and acronym of the parent compound. -
13		- #' -
14		- #' The dataset sheets should be named using the dataset numbers read in from -
15		- #' the 'Datasets' sheet, i.e. '1', '2', ... . In each dataset sheet, the name -
16		- #' of the observed variable (e.g. the acronym of the parent compound or -
17		- #' one of its transformation products) should be in the first column, -
18		- #' the time values should be in the second colum, and the observed value -
19		- #' in the third column. -
20		- #' -
21		- #' In case relevant covariate data are available, they should be given -
22		- #' in a sheet 'Covariates', containing one line for each value of the grouping -
23		- #' variable specified in 'Datasets'. These values should be in the first -
24		- #' column and the column must have the same name as the second column in -
25		- #' 'Datasets'. Covariates will be read in from columns four and higher. -
26		- #' Their names should preferably not contain special characters like spaces, -
27		- #' so they can be easily used for specifying covariate models. -
28		- #' -
29		- #' A similar data structure is defined as the R6 class [mkindsg], but -
30		- #' is probably more complicated to use. -
31		- #' -
32		- #' @param path Absolute or relative path to the spreadsheet file -
33		- #' @param valid_datasets Optional numeric index of the valid datasets, default is -
34		- #' to use all datasets -
35		- #' @param parent_only Should only the parent data be used? -
36		- #' @param normalize Should the time scale be normalized using temperature -
37		- #' and moisture normalisation factors in the sheet 'Datasets'? -
38		- #' @export -
39		- read_spreadsheet <- function(path, valid_datasets = "all", -
40		- parent_only = FALSE, normalize = TRUE) -
41		- { -
42	117x	- if (!requireNamespace("readxl", quietly = TRUE)) -
43	!	- stop("Please install the readxl package to use this function") -
44		- -
45		- # Read the compound table -
46	117x	- compounds <- readxl::read_excel(path, sheet = "Compounds") -
47	117x	- parent <- compounds[1, ]$Acronym -
48		- -
49		- # Read in meta information -
50	117x	- ds_meta <- readxl::read_excel(path, sheet = "Datasets") -
51	117x	- ds_meta["Dataset Number"] <- as.character(ds_meta[["Dataset Number"]]) -
52		- -
53		- # Select valid datasets -
54	!	- if (valid_datasets[1] == "all") valid_datasets <- 1:nrow(ds_meta) -
55	117x	- ds_numbers_valid <- ds_meta[valid_datasets, ]$`Dataset Number` -
56	117x	- grouping_factor <- names(ds_meta[2]) # Often "Soil" -
57		- -
58		- # Read in valid datasets -
59	117x	- ds_raw <- lapply(ds_numbers_valid, -
60	117x	- function(dsn) readxl::read_excel(path, sheet = as.character(dsn))) -
61		- -
62		- # Make data frames compatible with mmkin -
63	117x	- ds_tmp <- lapply(ds_raw, function(x) { -
64	1287x	- ds_ret <- x[1:3] \|> -
65	1287x	- rlang::set_names(c("name", "time", "value")) \|> -
66	1287x	- transform(value = as.numeric(value)) -
67		- }) -
68	117x	- names(ds_tmp) <- ds_numbers_valid -
69		- -
70		- # Normalize with temperature and moisture correction factors -
71	117x	- if (normalize) { -
72	117x	- ds_norm <- lapply(ds_numbers_valid, function(ds_number) { -
73	1287x	- f_corr <- as.numeric(ds_meta[ds_number, c("Temperature", "Moisture")]) -
74	1287x	- ds_corr <- ds_tmp[[ds_number]] \|> -
75	1287x	- transform(time = time * f_corr[1] * f_corr[2]) -
76	1287x	- return(ds_corr) -
77		- }) -
78		- } else { -
79	!	- ds_norm <- ds_tmp -
80		- } -
81	117x	- names(ds_norm) <- ds_numbers_valid -
82		- -
83		- # Select parent data only if requested -
84	117x	- if (parent_only) { -
85	!	- ds_norm <- lapply(ds_norm, function(x) subset(x, name == parent)) -
86	!	- compounds <- compounds[1, ] -
87		- } -
88		- -
89		- # Create a single long table to combine datasets with the same group name -
90	117x	- ds_all <- vctrs::vec_rbind(!!!ds_norm, .names_to = "Dataset Number") -
91	117x	- ds_all_group <- merge(ds_all, ds_meta[c("Dataset Number", grouping_factor)]) -
92	117x	- groups <- unique(ds_meta[valid_datasets, ][[grouping_factor]]) -
93		- -
94	117x	- ds <- lapply(groups, function(x) { -
95	819x	- ret <- ds_all_group[ds_all_group[[grouping_factor]] == x, ] -
96	819x	- ret[c("name", "time", "value")] -
97		- } -
98		- ) -
99	117x	- names(ds) <- groups -
100		- -
101		- # Get covariates -
102	117x	- covariates_raw <- readxl::read_excel(path, sheet = "Covariates") -
103	117x	- covariates <- as.data.frame(covariates_raw[4:ncol(covariates_raw)]) -
104	117x	- nocov <- setdiff(groups, covariates_raw[[1]]) -
105	117x	- if (length(nocov) > 0) { -
106	!	- message("Did not find covariate data for ", paste(nocov, collapse = ", ")) -
107	!	- message("Not returning covariate data") -
108	!	- attr(ds, "covariates") <- NULL -
109		- } else { -
110	117x	- rownames(covariates) <- covariates_raw[[1]] -
111	117x	- covariates <- covariates[which(colnames(covariates) != "Remarks")] -
112		- # Attach covariate data if available -
113	117x	- attr(ds, "covariates") <- covariates[groups, , drop = FALSE] -
114		- } -
115		- -
116		- # Attach the compound list to support automatic model building -
117	117x	- attr(ds, "compounds") <- as.data.frame(compounds) -
118		- -
119	117x	- return(ds) -
120		- } -

1		- #' Export a list of datasets format to a CAKE study file -
2		- #' -
3		- #' In addition to the datasets, the pathways in the degradation model can be -
4		- #' specified as well. -
5		- #' -
6		- #' @param ds A named list of datasets in long format as compatible with -
7		- #' \code{\link{mkinfit}}. -
8		- #' @param map A character vector with CAKE compartment names (Parent, A1, ...), -
9		- #' named with the names used in the list of datasets. -
10		- #' @param links An optional character vector of target compartments, named with -
11		- #' the names of the source compartments. In order to make this easier, the -
12		- #' names are used as in the datasets supplied. -
13		- #' @param filename Where to write the result. Should end in .csf in order to be -
14		- #' compatible with CAKE. -
15		- #' @param path An optional path to the output file. -
16		- #' @param overwrite If TRUE, existing files are overwritten. -
17		- #' @param study The name of the study. -
18		- #' @param description An optional description. -
19		- #' @param time_unit The time unit for the residue data. -
20		- #' @param res_unit The unit used for the residues. -
21		- #' @param comment An optional comment. -
22		- #' @param date The date of file creation. -
23		- #' @param optimiser Can be OLS or IRLS. -
24		- #' @importFrom utils write.table -
25		- #' @return The function is called for its side effect. -
26		- #' @author Johannes Ranke -
27		- #' @export -
28		- CAKE_export <- function(ds, map = c(parent = "Parent"), -
29		- links = NA, -
30		- filename = "CAKE_export.csf", path = ".", overwrite = FALSE, -
31		- study = "Degradinol aerobic soil degradation", -
32		- description = "", -
33		- time_unit = "days", -
34		- res_unit = "% AR", -
35		- comment = "", -
36		- date = Sys.Date(), -
37		- optimiser = "IRLS") -
38		- { -
39	741x	- file <- file.path(path, filename) -
40	247x	- if (file.exists(file) & !overwrite) stop(file, " already exists, stopping") -
41	494x	- csf <- file(file, encoding = "latin1", open = "w+") -
42	494x	- on.exit(close(csf)) -
43		- -
44	494x	- CAKE_compartments = c("Parent", "A1", "A2", "A3", "B1", "B2", "C1") -
45	494x	- if (!all(map %in% CAKE_compartments)) { -
46	247x	- stop("The elements of map have to be CAKE compartment names") -
47		- } -
48		- -
49	247x	- add <- function(x) cat(paste0(x, "\r\n"), file = csf, append = TRUE) -
50	247x	- add0 <- function(x) cat(x, file = csf, append = TRUE) -
51		- -
52	247x	- add("[FileInfo]") -
53	247x	- add("CAKE-Version: 3.4 (Release)") -
54	247x	- add(paste("Name:", study)) -
55	247x	- add(paste("Description:", description)) -
56	247x	- add(paste("MeasurementUnits:", res_unit)) -
57	247x	- add(paste("TimeUnits:", time_unit)) -
58	247x	- add(paste("Comments:", comment)) -
59	247x	- add(paste("Date:", date)) -
60	247x	- add(paste("Optimiser:", optimiser)) -
61	247x	- add("") -
62		- -
63	247x	- add("[Data]") -
64		- -
65	247x	- for (i in seq_along(ds)) { -
66	494x	- add(paste("NewDataSet:", names(ds)[i])) -
67	494x	- d <- mkin_long_to_wide(ds[[i]]) -
68	494x	- names(d) <- c("Time", map[names(d)[-1]]) -
69	494x	- write.table(d, csf, -
70	494x	- sep = "\t", col.names = TRUE, -
71	494x	- row.names = FALSE, -
72	494x	- quote = FALSE, eol = "\r\n", na = "") -
73	494x	- add("") -
74		- } -
75		- -
76	247x	- if (!is.na(links)) { -
77	247x	- add("") -
78	247x	- add("[Model]") -
79	247x	- add(paste0("ParentCompartment: Parent\t", names(map)[1], "\t", names(map)[1])) -
80	247x	- for (name in names(map)[-1]) { -
81	247x	- add(paste0("Compartment: ", map[name], "\t", name, "\t", name)) -
82		- } -
83	247x	- for (li in names(links)) { -
84	247x	- add(paste0("Link: ", map[li], "\t", map[links[li]], "\t0.5\t0\t1\tFree\tExplicit")) -
85		- } -
86		- -
87		- } -
88		- -
89	247x	- add("") -
90	247x	- add("[ComponentNames]") -
91	247x	- for (name in names(map)) { -
92	494x	- add(paste0(map[name], ":", name)) -
93		- } -
94		- -
95		- } -

1		- #' Display the output of a summary function according to the output format -
2		- #' -
3		- #' This function is intended for use in a R markdown code chunk with the chunk -
4		- #' option `results = "asis"`. -
5		- #' -
6		- #' @param object The object for which the summary is to be listed -
7		- #' @param caption An optional caption -
8		- #' @param label An optional label, ignored in html output -
9		- #' @param clearpage Should a new page be started after the listing? Ignored in html output -
10		- #' @export -
11		- summary_listing <- function(object, caption = NULL, label = NULL, -
12		- clearpage = TRUE) { -
13	!	- if (knitr::is_latex_output()) { -
14	!	- tex_listing(object = object, caption = caption, label = label, -
15	!	- clearpage = clearpage) -
16		- } -
17	!	- if (knitr::is_html_output()) { -
18	!	- html_listing(object = object, caption = caption) -
19		- } -
20		- } -
21		- -
22		- #' @rdname summary_listing -
23		- #' @export -
24		- tex_listing <- function(object, caption = NULL, label = NULL, -
25		- clearpage = TRUE) { -
26	!	- cat("\n") -
27	!	- cat("\\begin{listing}", "\n") -
28	!	- if (!is.null(caption)) { -
29	!	- cat("\\caption{", caption, "}", "\n", sep = "") -
30		- } -
31	!	- if (!is.null(label)) { -
32	!	- cat("\\caption{", label, "}", "\n", sep = "") -
33		- } -
34	!	- cat("\\begin{snugshade}", "\n") -
35	!	- cat("\\scriptsize", "\n") -
36	!	- cat("\\begin{verbatim}", "\n") -
37	!	- cat(capture.output(suppressWarnings(summary(object))), sep = "\n") -
38	!	- cat("\n") -
39	!	- cat("\\end{verbatim}", "\n") -
40	!	- cat("\\end{snugshade}", "\n") -
41	!	- cat("\\end{listing}", "\n") -
42	!	- if (clearpage) { -
43	!	- cat("\\clearpage", "\n") -
44		- } -
45		- } -
46		- -
47		- #' @rdname summary_listing -
48		- #' @export -
49		- html_listing <- function(object, caption = NULL) { -
50	!	- cat("\n") -
51	!	- if (!is.null(caption)) { -
52	!	- cat("<caption>", caption, "</caption>", "\n", sep = "") -
53		- } -
54	!	- cat("<pre><code>\n") -
55	!	- cat(capture.output(suppressWarnings(summary(object))), sep = "\n") -
56	!	- cat("\n") -
57	!	- cat("</pre></code>\n") -
58		- } -
59		- -

1		- #' Perform a hierarchical model fit with multiple starting values -
2		- #' -
3		- #' The purpose of this method is to check if a certain algorithm for fitting -
4		- #' nonlinear hierarchical models (also known as nonlinear mixed-effects models) -
5		- #' will reliably yield results that are sufficiently similar to each other, if -
6		- #' started with a certain range of reasonable starting parameters. It is -
7		- #' inspired by the article on practical identifiabiliy in the frame of nonlinear -
8		- #' mixed-effects models by Duchesne et al (2021). -
9		- #' -
10		- #' @param object The fit object to work with -
11		- #' @param n How many different combinations of starting parameters should be -
12		- #' used? -
13		- #' @param cores How many fits should be run in parallel (only on posix platforms)? -
14		- #' @param cluster A cluster as returned by [parallel::makeCluster] to be used -
15		- #' for parallel execution. -
16		- #' @param \dots Passed to the update function. -
17		- #' @param x The multistart object to print -
18		- #' @return A list of [saem.mmkin] objects, with class attributes -
19		- #' 'multistart.saem.mmkin' and 'multistart'. -
20		- #' @seealso [parplot], [llhist] -
21		- #' -
22		- #' @references Duchesne R, Guillemin A, Gandrillon O, Crauste F. Practical -
23		- #' identifiability in the frame of nonlinear mixed effects models: the example -
24		- #' of the in vitro erythropoiesis. BMC Bioinformatics. 2021 Oct 4;22(1):478. -
25		- #' doi: 10.1186/s12859-021-04373-4. -
26		- #' @export -
27		- #' @examples -
28		- #' \dontrun{ -
29		- #' library(mkin) -
30		- #' dmta_ds <- lapply(1:7, function(i) { -
31		- #' ds_i <- dimethenamid_2018$ds[[i]]$data -
32		- #' ds_i[ds_i$name == "DMTAP", "name"] <- "DMTA" -
33		- #' ds_i$time <- ds_i$time * dimethenamid_2018$f_time_norm[i] -
34		- #' ds_i -
35		- #' }) -
36		- #' names(dmta_ds) <- sapply(dimethenamid_2018$ds, function(ds) ds$title) -
37		- #' dmta_ds[["Elliot"]] <- rbind(dmta_ds[["Elliot 1"]], dmta_ds[["Elliot 2"]]) -
38		- #' dmta_ds[["Elliot 1"]] <- dmta_ds[["Elliot 2"]] <- NULL -
39		- #' -
40		- #' f_mmkin <- mmkin("DFOP", dmta_ds, error_model = "tc", cores = 7, quiet = TRUE) -
41		- #' f_saem_full <- saem(f_mmkin) -
42		- #' f_saem_full_multi <- multistart(f_saem_full, n = 16, cores = 16) -
43		- #' parplot(f_saem_full_multi, lpos = "topleft") -
44		- #' illparms(f_saem_full) -
45		- #' -
46		- #' f_saem_reduced <- update(f_saem_full, no_random_effect = "log_k2") -
47		- #' illparms(f_saem_reduced) -
48		- #' # On Windows, we need to create a PSOCK cluster first and refer to it -
49		- #' # in the call to multistart() -
50		- #' library(parallel) -
51		- #' cl <- makePSOCKcluster(12) -
52		- #' f_saem_reduced_multi <- multistart(f_saem_reduced, n = 16, cluster = cl) -
53		- #' parplot(f_saem_reduced_multi, lpos = "topright", ylim = c(0.5, 2)) -
54		- #' stopCluster(cl) -
55		- #' } -
56		- multistart <- function(object, n = 50, -
57		- cores = if (Sys.info()["sysname"] == "Windows") 1 else parallel::detectCores(), -
58		- cluster = NULL, ...) -
59		- { -
60	200x	- UseMethod("multistart", object) -
61		- } -
62		- -
63		- #' @rdname multistart -
64		- #' @export -
65		- multistart.saem.mmkin <- function(object, n = 50, cores = 1, -
66		- cluster = NULL, ...) { -
67	200x	- call <- match.call() -
68	!	- if (n <= 1) stop("Please specify an n of at least 2") -
69		- -
70	200x	- mmkin_object <- object$mmkin -
71		- -
72	200x	- mmkin_parms <- parms(mmkin_object, errparms = FALSE, -
73	200x	- transformed = object$transformations == "mkin") -
74	200x	- start_parms <- apply( -
75	200x	- mmkin_parms, 1, -
76	200x	- function(x) stats::runif(n, min(x), max(x))) -
77		- -
78	200x	- saem_call <- object$call -
79	200x	- saem_call[[1]] <- saem -
80	200x	- saem_call[[2]] <- mmkin_object -
81	200x	- i_startparms <- which(names(saem_call) == "degparms_start") -
82		- -
83	200x	- fit_function <- function(x) { -
84		- -
85	16x	- new_startparms <- str2lang( -
86	16x	- paste0(capture.output(dput(start_parms[x, ])), -
87	16x	- collapse = "")) -
88		- -
89	16x	- if (length(i_startparms) == 0) { -
90	16x	- saem_call <- c(as.list(saem_call), degparms_start = new_startparms) -
91	16x	- saem_call <- as.call(saem_call) -
92		- } else { -
93	!	- saem_call[i_startparms] <- new_startparms -
94		- } -
95		- -
96	16x	- ret <- eval(saem_call) -
97		- -
98	16x	- return(ret) -
99		- } -
100		- -
101	200x	- if (is.null(cluster)) { -
102	200x	- res <- parallel::mclapply(1:n, fit_function, -
103	200x	- mc.cores = cores, mc.preschedule = FALSE) -
104		- } else { -
105	!	- res <- parallel::parLapplyLB(cluster, 1:n, fit_function) -
106		- } -
107	184x	- attr(res, "orig") <- object -
108	184x	- attr(res, "start_parms") <- start_parms -
109	184x	- attr(res, "call") <- call -
110	184x	- class(res) <- c("multistart.saem.mmkin", "multistart") -
111	184x	- return(res) -
112		- } -
113		- -
114		- #' @export -
115		- status.multistart <- function(object, ...) { -
116	!	- all_summary_warnings <- character() -
117		- -
118	!	- result <- lapply(object, -
119	!	- function(fit) { -
120	!	- if (inherits(fit, "try-error")) return("E") -
121		- else { -
122	!	- return("OK") -
123		- } -
124		- }) -
125	!	- result <- unlist(result) -
126		- -
127	!	- class(result) <- "status.multistart" -
128	!	- return(result) -
129		- } -
130		- -
131		- #' @export -
132		- status.multistart.saem.mmkin <- function(object, ...) { -
133	88x	- all_summary_warnings <- character() -
134		- -
135	88x	- result <- lapply(object, -
136	88x	- function(fit) { -
137	!	- if (inherits(fit$so, "try-error")) return("E") -
138		- else { -
139	704x	- return("OK") -
140		- } -
141		- }) -
142	88x	- result <- unlist(result) -
143		- -
144	88x	- class(result) <- "status.multistart" -
145	88x	- return(result) -
146		- } -
147		- -
148		- #' @export -
149		- print.status.multistart <- function(x, ...) { -
150	88x	- class(x) <- NULL -
151	88x	- print(table(x, dnn = NULL)) -
152	88x	- if (any(x == "OK")) cat("OK: Fit terminated successfully\n") -
153	!	- if (any(x == "E")) cat("E: Error\n") -
154		- } -
155		- -
156		- #' @rdname multistart -
157		- #' @export -
158		- print.multistart <- function(x, ...) { -
159	88x	- cat("<multistart> object with", length(x), "fits:\n") -
160	88x	- print(status(x)) -
161		- } -
162		- -
163		- #' @rdname multistart -
164		- #' @export -
165		- best <- function(object, ...) -
166		- { -
167	184x	- UseMethod("best", object) -
168		- } -
169		- -
170		- #' @export -
171		- #' @return The object with the highest likelihood -
172		- #' @rdname multistart -
173		- best.default <- function(object, ...) -
174		- { -
175	184x	- return(object[[which.best(object)]]) -
176		- } -
177		- -
178		- #' @return The index of the object with the highest likelihood -
179		- #' @rdname multistart -
180		- #' @export -
181		- which.best <- function(object, ...) -
182		- { -
183	360x	- UseMethod("which.best", object) -
184		- } -
185		- -
186		- #' @rdname multistart -
187		- #' @export -
188		- which.best.default <- function(object, ...) -
189		- { -
190	360x	- llfunc <- function(object) { -
191	2528x	- ret <- try(logLik(object)) -
192	!	- if (inherits(ret, "try-error")) return(NA) -
193	2528x	- else return(ret) -
194		- } -
195	360x	- ll <- sapply(object, llfunc) -
196	360x	- return(which.max(ll)) -
197		- } -
198		- -
199		- #' @export -
200		- update.multistart <- function(object, ..., evaluate = TRUE) { -
201	!	- call <- attr(object, "call") -
202		- # For some reason we get multistart.saem.mmkin in call[[1]] when using multistart -
203		- # from the loaded package so we need to fix this so we do not have to export -
204		- # multistart.saem.mmkin -
205	!	- call[[1]] <- multistart -
206		- -
207	!	- update_arguments <- match.call(expand.dots = FALSE)$... -
208		- -
209	!	- if (length(update_arguments) > 0) { -
210	!	- update_arguments_in_call <- !is.na(match(names(update_arguments), names(call))) -
211		- } -
212		- -
213	!	- for (a in names(update_arguments)[update_arguments_in_call]) { -
214	!	- call[[a]] <- update_arguments[[a]] -
215		- } -
216		- -
217	!	- update_arguments_not_in_call <- !update_arguments_in_call -
218	!	- if(any(update_arguments_not_in_call)) { -
219	!	- call <- c(as.list(call), update_arguments[update_arguments_not_in_call]) -
220	!	- call <- as.call(call) -
221		- } -
222	!	- if(evaluate) eval(call, parent.frame()) -
223	!	- else call -
224		- } -

1		- #' @importFrom lmtest lrtest -
2		- #' @export -
3		- lmtest::lrtest -
4		- -
5		- #' Likelihood ratio test for mkinfit models -
6		- #' -
7		- #' Compare two mkinfit models based on their likelihood. If two fitted -
8		- #' mkinfit objects are given as arguments, it is checked if they have been -
9		- #' fitted to the same data. It is the responsibility of the user to make sure -
10		- #' that the models are nested, i.e. one of them has less degrees of freedom -
11		- #' and can be expressed by fixing the parameters of the other. -
12		- #' -
13		- #' Alternatively, an argument to mkinfit can be given which is then passed -
14		- #' to \code{\link{update.mkinfit}} to obtain the alternative model. -
15		- #' -
16		- #' The comparison is then made by the \code{\link[lmtest]{lrtest.default}} -
17		- #' method from the lmtest package. The model with the higher number of fitted -
18		- #' parameters (alternative hypothesis) is listed first, then the model with the -
19		- #' lower number of fitted parameters (null hypothesis). -
20		- #' -
21		- #' @importFrom stats logLik update -
22		- #' @param object An \code{\link{mkinfit}} object, or an \code{\link{mmkin}} column -
23		- #' object containing two fits to the same data. -
24		- #' @param object_2 Optionally, another mkinfit object fitted to the same data. -
25		- #' @param \dots Argument to \code{\link{mkinfit}}, passed to -
26		- #' \code{\link{update.mkinfit}} for creating the alternative fitted object. -
27		- #' @examples -
28		- #' \dontrun{ -
29		- #' test_data <- subset(synthetic_data_for_UBA_2014[[12]]$data, name == "parent") -
30		- #' sfo_fit <- mkinfit("SFO", test_data, quiet = TRUE) -
31		- #' dfop_fit <- mkinfit("DFOP", test_data, quiet = TRUE) -
32		- #' lrtest(dfop_fit, sfo_fit) -
33		- #' lrtest(sfo_fit, dfop_fit) -
34		- #' -
35		- #' # The following two examples are commented out as they fail during -
36		- #' # generation of the static help pages by pkgdown -
37		- #' #lrtest(dfop_fit, error_model = "tc") -
38		- #' #lrtest(dfop_fit, fixed_parms = c(k2 = 0)) -
39		- #' -
40		- #' # However, this equivalent syntax also works for static help pages -
41		- #' lrtest(dfop_fit, update(dfop_fit, error_model = "tc")) -
42		- #' lrtest(dfop_fit, update(dfop_fit, fixed_parms = c(k2 = 0))) -
43		- #' } -
44		- #' @export -
45		- lrtest.mkinfit <- function(object, object_2 = NULL, ...) { -
46		- -
47	6x	- name_function <- function(x) { -
48	10x	- object_name <- paste(x$mkinmod$name, "with error model", x$err_mod) -
49	10x	- if (length(x$bparms.fixed) > 0) { -
50	7x	- object_name <- paste(object_name, -
51	7x	- "and fixed parameter(s)", -
52	7x	- paste(names(x$bparms.fixed), collapse = ", ")) -
53		- } -
54	10x	- return(object_name) -
55		- } -
56		- -
57	6x	- if (is.null(object_2)) { -
58	!	- object_2 <- update(object, ...) -
59		- } else { -
60	6x	- data_object <- object$data[c("time", "variable", "observed")] -
61	6x	- data_object_2 <- object_2$data[c("time", "variable", "observed")] -
62	6x	- if (!identical(data_object, data_object_2)) { -
63	1x	- stop("It seems that the mkinfit objects have not been fitted to the same data") -
64		- } -
65		- } -
66	5x	- if (attr(logLik(object), "df") > attr(logLik(object_2), "df")) { -
67	2x	- lmtest::lrtest.default(object, object_2, name = name_function) -
68		- } else { -
69	3x	- lmtest::lrtest.default(object_2, object, name = name_function) -
70		- } -
71		- } -
72		- -
73		- #' @rdname lrtest.mkinfit -
74		- #' @export -
75		- lrtest.mmkin <- function(object, ...) { -
76	!	- if (nrow(object) != 2 \| ncol(object) > 1) stop("Only works for a column containing two mkinfit objects") -
77	!	- object[[1, 1]]$mkinmod$name <- rownames(object)[1] -
78	!	- object[[2, 1]]$mkinmod$name <- rownames(object)[2] -
79	!	- lrtest(object[[1, 1]], object[[2, 1]]) -
80		- } -

1		- #' Calculate Akaike weights for model averaging -
2		- #' -
3		- #' Akaike weights are calculated based on the relative -
4		- #' expected Kullback-Leibler information as specified -
5		- #' by Burnham and Anderson (2004). -
6		- #' -
7		- #' @param object An [mmkin] column object, containing two or more -
8		- #' [mkinfit] models that have been fitted to the same data, -
9		- #' or an mkinfit object. In the latter case, further mkinfit -
10		- #' objects fitted to the same data should be specified -
11		- #' as dots arguments. -
12		- #' @param \dots Not used in the method for [mmkin] column objects, -
13		- #' further [mkinfit] objects in the method for mkinfit objects. -
14		- #' @references Burnham KP and Anderson DR (2004) Multimodel -
15		- #' Inference: Understanding AIC and BIC in Model Selection. -
16		- #' Sociological Methods & Research 33(2) 261-304 -
17		- #' @md -
18		- #' @examples -
19		- #' \dontrun{ -
20		- #' f_sfo <- mkinfit("SFO", FOCUS_2006_D, quiet = TRUE) -
21		- #' f_dfop <- mkinfit("DFOP", FOCUS_2006_D, quiet = TRUE) -
22		- #' aw_sfo_dfop <- aw(f_sfo, f_dfop) -
23		- #' sum(aw_sfo_dfop) -
24		- #' aw_sfo_dfop # SFO gets more weight as it has less parameters and a similar fit -
25		- #' f <- mmkin(c("SFO", "FOMC", "DFOP"), list("FOCUS D" = FOCUS_2006_D), cores = 1, quiet = TRUE) -
26		- #' aw(f) -
27		- #' sum(aw(f)) -
28		- #' aw(f[c("SFO", "DFOP")]) -
29		- #' } -
30		- #' @export -
31	1482x	- aw <- function(object, ...) UseMethod("aw") -
32		- -
33		- .aw <- function(all_objects) { -
34	494x	- AIC_all <- sapply(all_objects, AIC) -
35	494x	- delta_i <- AIC_all - min(AIC_all) -
36	494x	- denom <- sum(exp(-delta_i/2)) -
37	494x	- w_i <- exp(-delta_i/2) / denom -
38	494x	- return(w_i) -
39		- } -
40		- -
41		- #' @export -
42		- #' @rdname aw -
43		- aw.mkinfit <- function(object, ...) { -
44	988x	- oo <- list(...) -
45	988x	- data_object <- object$data[c("time", "variable", "observed")] -
46	988x	- for (i in seq_along(oo)) { -
47	247x	- if (!inherits(oo[[i]], "mkinfit")) stop("Please supply only mkinfit objects") -
48	988x	- data_other_object <- oo[[i]]$data[c("time", "variable", "observed")] -
49	988x	- if (!identical(data_object, data_other_object)) { -
50	247x	- stop("It seems that the mkinfit objects have not all been fitted to the same data") -
51		- } -
52		- } -
53	494x	- all_objects <- list(object, ...) -
54	494x	- .aw(all_objects) -
55		- } -
56		- -
57		- #' @export -
58		- #' @rdname aw -
59		- aw.mmkin <- function(object, ...) { -
60	247x	- if (ncol(object) > 1) stop("Please supply an mmkin column object") -
61	247x	- do.call(aw, object) -
62		- } -
63		- -
64		- #' @export -
65		- #' @rdname aw -
66		- aw.mixed.mmkin <- function(object, ...) { -
67	!	- oo <- list(...) -
68	!	- data_object <- object$data[c("ds", "name", "time", "value")] -
69	!	- for (i in seq_along(oo)) { -
70	!	- if (!inherits(oo[[i]], "mixed.mmkin")) stop("Please supply objects inheriting from mixed.mmkin") -
71	!	- data_other_object <- oo[[i]]$data[c("ds", "name", "time", "value")] -
72	!	- if (!identical(data_object, data_other_object)) { -
73	!	- stop("It seems that the mixed.mmkin objects have not all been fitted to the same data") -
74		- } -
75		- } -
76	!	- all_objects <- list(object, ...) -
77	!	- .aw(all_objects) -
78		- } -
79		- -
80		- #' @export -
81		- #' @rdname aw -
82		- aw.multistart <- function(object, ...) { -
83	!	- do.call(aw, object) -
84		- } -

1		- #' Calculate mean degradation parameters for an mmkin row object -
2		- #' -
3		- #' @return If random is FALSE (default), a named vector containing mean values -
4		- #' of the fitted degradation model parameters. If random is TRUE, a list with -
5		- #' fixed and random effects, in the format required by the start argument of -
6		- #' nlme for the case of a single grouping variable ds. -
7		- #' @param object An mmkin row object containing several fits of the same model to different datasets -
8		- #' @param random Should a list with fixed and random effects be returned? -
9		- #' @param test_log_parms If TRUE, log parameters are only considered in -
10		- #' the mean calculations if their untransformed counterparts (most likely -
11		- #' rate constants) pass the t-test for significant difference from zero. -
12		- #' @param conf.level Possibility to adjust the required confidence level -
13		- #' for parameter that are tested if requested by 'test_log_parms'. -
14		- #' @param default_log_parms If set to a numeric value, this is used -
15		- #' as a default value for the tested log parameters that failed the -
16		- #' t-test. -
17		- #' @export -
18		- mean_degparms <- function(object, random = FALSE, test_log_parms = FALSE, conf.level = 0.6, -
19		- default_log_parms = NA) -
20		- { -
21	!	- if (nrow(object) > 1) stop("Only row objects allowed") -
22	7271x	- parm_mat_trans <- sapply(object, parms, transformed = TRUE) -
23		- -
24	7271x	- if (test_log_parms) { -
25	4668x	- parm_mat_dim <- dim(parm_mat_trans) -
26	4668x	- parm_mat_dimnames <- dimnames(parm_mat_trans) -
27		- -
28	4668x	- log_parm_trans_names <- grep("^log_", rownames(parm_mat_trans), value = TRUE) -
29	4668x	- log_parm_names <- gsub("^log_", "", log_parm_trans_names) -
30		- -
31	4668x	- t_test_back_OK <- matrix( -
32	4668x	- sapply(object, function(o) { -
33	49860x	- suppressWarnings(summary(o)$bpar[log_parm_names, "Pr(>t)"] < (1 - conf.level)) -
34	4668x	- }), nrow = length(log_parm_names)) -
35	4668x	- rownames(t_test_back_OK) <- log_parm_trans_names -
36		- -
37	4668x	- parm_mat_trans_OK <- parm_mat_trans -
38	4668x	- for (trans_parm in log_parm_trans_names) { -
39	9398x	- parm_mat_trans_OK[trans_parm, ] <- ifelse(t_test_back_OK[trans_parm, ], -
40	9398x	- parm_mat_trans[trans_parm, ], log(default_log_parms)) -
41		- } -
42		- } else { -
43	2603x	- parm_mat_trans_OK <- parm_mat_trans -
44		- } -
45		- -
46	7271x	- mean_degparm_names <- setdiff(rownames(parm_mat_trans), names(object[[1]]$errparms)) -
47	7271x	- degparm_mat_trans <- parm_mat_trans[mean_degparm_names, , drop = FALSE] -
48	7271x	- degparm_mat_trans_OK <- parm_mat_trans_OK[mean_degparm_names, , drop = FALSE] -
49		- -
50		- # fixed in the sense of fixed effects, as this function was -
51		- # written to supply starting parameters for nlme -
52	7271x	- fixed <- apply(degparm_mat_trans_OK, 1, mean, na.rm = TRUE) -
53	7271x	- if (random) { -
54	2322x	- random <- t(apply(degparm_mat_trans[mean_degparm_names, , drop = FALSE], 2, function(column) column - fixed)) -
55		- # If we only have one parameter, apply returns a vector so we get a single row -
56	!	- if (nrow(degparm_mat_trans) == 1) random <- t(random) -
57	2322x	- rownames(random) <- levels(nlme_data(object)$ds) -
58		- -
59		- # For nlmixr we can specify starting values for standard deviations eta, and -
60		- # we ignore uncertain parameters if test_log_parms is FALSE -
61	2322x	- eta <- apply(degparm_mat_trans_OK, 1, stats::sd, na.rm = TRUE) -
62		- -
63	2322x	- return(list(fixed = fixed, random = list(ds = random), eta = eta)) -
64		- } else { -
65	4949x	- return(fixed) -
66		- } -
67		- } -
68		- -

1		- # This file is part of the R package mkin -
2		- -
3		- # mkin is free software: you can redistribute it and/or modify it under the -
4		- # terms of the GNU General Public License as published by the Free Software -
5		- # Foundation, either version 3 of the License, or (at your option) any later -
6		- # version. -
7		- -
8		- # This program is distributed in the hope that it will be useful, but WITHOUT -
9		- # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS -
10		- # FOR A PARTICULAR PURPOSE. See the GNU General Public License for more -
11		- # details. -
12		- -
13		- # You should have received a copy of the GNU General Public License along with -
14		- # this program. If not, see <http://www.gnu.org/licenses/> -
15		- -
16		- #' Function to perform isometric log-ratio transformation -
17		- #' -
18		- #' This implementation is a special case of the class of isometric log-ratio -
19		- #' transformations. -
20		- #' -
21		- #' @aliases ilr invilr -
22		- #' @param x A numeric vector. Naturally, the forward transformation is only -
23		- #' sensible for vectors with all elements being greater than zero. -
24		- #' @return The result of the forward or backward transformation. The returned -
25		- #' components always sum to 1 for the case of the inverse log-ratio -
26		- #' transformation. -
27		- #' @author René Lehmann and Johannes Ranke -
28		- #' @seealso Another implementation can be found in R package -
29		- #' \code{robCompositions}. -
30		- #' @references Peter Filzmoser, Karel Hron (2008) Outlier Detection for -
31		- #' Compositional Data Using Robust Methods. Math Geosci 40 233-248 -
32		- #' @keywords manip -
33		- #' @examples -
34		- #' -
35		- #' # Order matters -
36		- #' ilr(c(0.1, 1, 10)) -
37		- #' ilr(c(10, 1, 0.1)) -
38		- #' # Equal entries give ilr transformations with zeros as elements -
39		- #' ilr(c(3, 3, 3)) -
40		- #' # Almost equal entries give small numbers -
41		- #' ilr(c(0.3, 0.4, 0.3)) -
42		- #' # Only the ratio between the numbers counts, not their sum -
43		- #' invilr(ilr(c(0.7, 0.29, 0.01))) -
44		- #' invilr(ilr(2.1 * c(0.7, 0.29, 0.01))) -
45		- #' # Inverse transformation of larger numbers gives unequal elements -
46		- #' invilr(-10) -
47		- #' invilr(c(-10, 0)) -
48		- #' # The sum of the elements of the inverse ilr is 1 -
49		- #' sum(invilr(c(-10, 0))) -
50		- #' # This is why we do not need all elements of the inverse transformation to go back: -
51		- #' a <- c(0.1, 0.3, 0.5) -
52		- #' b <- invilr(a) -
53		- #' length(b) # Four elements -
54		- #' ilr(c(b[1:3], 1 - sum(b[1:3]))) # Gives c(0.1, 0.3, 0.5) -
55		- #' -
56		- #' @export -
57		- ilr <- function(x) { -
58	16x	- z <- vector() -
59	16x	- for (i in 1:(length(x) - 1)) { -
60	44x	- z[i] <- sqrt(i/(i+1)) * log((prod(x[1:i]))^(1/i) / x[i+1]) -
61		- } -
62	16x	- return(z) -
63		- } -
64		- -
65		- #' @rdname ilr -
66		- #' @export -
67		- invilr<-function(x) { -
68	529301x	- D <- length(x) + 1 -
69	529301x	- z <- c(x, 0) -
70	529301x	- y <- rep(0, D) -
71	529301x	- s <- sqrt(1:D*2:(D+1)) -
72	529301x	- q <- z/s -
73	529301x	- y[1] <- sum(q[1:D]) -
74	529301x	- for (i in 2:D) { -
75	1585969x	- y[i] <- sum(q[i:D]) - sqrt((i-1)/i) * z[i-1] -
76		- } -
77	529301x	- z <- vector() -
78	529301x	- for (i in 1:D) { -
79	2115270x	- z[i] <- exp(y[i])/sum(exp(y)) -
80		- } -
81		- -
82		- # Work around a numerical problem with NaN values returned by the above -
83		- # Only works if there is only one NaN value: replace it with 1 -
84		- # if the sum of the other components is < 1e-10 -
85	529301x	- if (sum(is.na(z)) == 1 && sum(z[!is.na(z)]) < 1e-10) -
86	!	- z = ifelse(is.na(z), 1, z) -
87		- -
88	529301x	- return(z) -
89		- } -

1		- #' Function to calculate maximum time weighted average concentrations from -
2		- #' kinetic models fitted with mkinfit -
3		- #' -
4		- #' This function calculates maximum moving window time weighted average -
5		- #' concentrations (TWAs) for kinetic models fitted with \code{\link{mkinfit}}. -
6		- #' Currently, only calculations for the parent are implemented for the SFO, -
7		- #' FOMC, DFOP and HS models, using the analytical formulas given in the PEC -
8		- #' soil section of the FOCUS guidance. -
9		- #' -
10		- #' @aliases max_twa_parent max_twa_sfo max_twa_fomc max_twa_dfop max_twa_hs -
11		- #' @param fit An object of class \code{\link{mkinfit}}. -
12		- #' @param windows The width of the time windows for which the TWAs should be -
13		- #' calculated. -
14		- #' @param M0 The initial concentration for which the maximum time weighted -
15		- #' average over the decline curve should be calculated. The default is to use -
16		- #' a value of 1, which means that a relative maximum time weighted average -
17		- #' factor (f_twa) is calculated. -
18		- #' @param k The rate constant in the case of SFO kinetics. -
19		- #' @param t The width of the time window. -
20		- #' @param alpha Parameter of the FOMC model. -
21		- #' @param beta Parameter of the FOMC model. -
22		- #' @param k1 The first rate constant of the DFOP or the HS kinetics. -
23		- #' @param k2 The second rate constant of the DFOP or the HS kinetics. -
24		- #' @param g Parameter of the DFOP model. -
25		- #' @param tb Parameter of the HS model. -
26		- #' @return For \code{max_twa_parent}, a numeric vector, named using the -
27		- #' \code{windows} argument. For the other functions, a numeric vector of -
28		- #' length one (also known as 'a number'). -
29		- #' @author Johannes Ranke -
30		- #' @references FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence -
31		- #' and Degradation Kinetics from Environmental Fate Studies on Pesticides in -
32		- #' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, -
33		- #' EC Document Reference Sanco/10058/2005 version 2.0, 434 pp, -
34		- #' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} -
35		- #' @examples -
36		- #' -
37		- #' fit <- mkinfit("FOMC", FOCUS_2006_C, quiet = TRUE) -
38		- #' max_twa_parent(fit, c(7, 21)) -
39		- #' -
40		- #' @export -
41		- max_twa_parent <- function(fit, windows) { -
42	4x	- parms.all <- c(fit$bparms.optim, fit$bparms.fixed) -
43	4x	- obs_vars <- fit$obs_vars -
44	4x	- if (length(obs_vars) > 1) { -
45	!	- warning("Calculation of maximum time weighted average concentrations is", -
46	!	- "currently only implemented for the parent compound using", -
47	!	- "analytical solutions") -
48		- } -
49	4x	- obs_var <- obs_vars[1] -
50	4x	- spec = fit$mkinmod$spec -
51	4x	- type = spec[[1]]$type -
52		- -
53	4x	- M0 <- parms.all[paste0(obs_var, "_0")] -
54		- -
55	4x	- if (type == "SFO") { -
56	1x	- k_name <- paste0("k_", obs_var) -
57	1x	- if (fit$mkinmod$use_of_ff == "min") { -
58	!	- k_name <- paste0(k_name, "_sink") -
59		- } -
60	1x	- k <- parms.all[k_name] -
61	1x	- twafunc <- function(t) { -
62	1x	- max_twa_sfo(M0, k, t) -
63		- } -
64		- } -
65	4x	- if (type == "FOMC") { -
66	1x	- alpha <- parms.all["alpha"] -
67	1x	- beta <- parms.all["beta"] -
68	1x	- twafunc <- function(t) { -
69	1x	- max_twa_fomc(M0, alpha, beta, t) -
70		- } -
71		- } -
72	4x	- if (type == "DFOP") { -
73	1x	- k1 <- parms.all["k1"] -
74	1x	- k2 <- parms.all["k2"] -
75	1x	- g <- parms.all["g"] -
76	1x	- twafunc <- function(t) { -
77	1x	- max_twa_dfop(M0, k1, k2, g, t) -
78		- } -
79		- } -
80	4x	- if (type == "HS") { -
81	1x	- k1 <- parms.all["k1"] -
82	1x	- k2 <- parms.all["k2"] -
83	1x	- tb <- parms.all["tb"] -
84	1x	- twafunc <- function(t) { -
85	1x	- ifelse(t <= tb, -
86	1x	- max_twa_sfo(M0, k1, t), -
87	1x	- max_twa_hs(M0, k1, k2, tb, t) -
88		- ) -
89		- } -
90		- } -
91	4x	- if (type %in% c("IORE", "SFORB")) { -
92	!	- stop("Calculation of maximum time weighted average concentrations is currently ", -
93	!	- "not implemented for the ", type, " model.") -
94		- } -
95	4x	- res <- twafunc(windows) -
96	4x	- names(res) <- windows -
97	4x	- return(res) -
98		- } -
99		- -
100		- #' @rdname max_twa_parent -
101		- #' @export -
102		- max_twa_sfo <- function(M0 = 1, k, t) { -
103	1x	- M0 * (1 - exp(- k * t)) / (k * t) -
104		- } -
105		- -
106		- #' @rdname max_twa_parent -
107		- #' @export -
108		- max_twa_fomc <- function(M0 = 1, alpha, beta, t) { -
109	1x	- M0 * (beta)/(t * (1 - alpha)) * ((t/beta + 1)^(1 - alpha) - 1) -
110		- } -
111		- -
112		- #' @rdname max_twa_parent -
113		- #' @export -
114		- max_twa_dfop <- function(M0 = 1, k1, k2, g, t) { -
115	1x	- M0/t * ((g/k1) * (1 - exp(- k1 * t)) + ((1 - g)/k2) * (1 - exp(- k2 * t))) -
116		- } -
117		- -
118		- #' @rdname max_twa_parent -
119		- #' @export -
120		- max_twa_hs <- function(M0 = 1, k1, k2, tb, t) { -
121	1x	- (M0 / t) * ( -
122	1x	- (1/k1) * (1 - exp(- k1 * tb)) + -
123	1x	- (exp(- k1 * tb) / k2) * (1 - exp(- k2 * (t - tb))) -
124		- ) -
125		- } -

1		- utils::globalVariables("D24_2014") -
2		- -
3		- #' Normalisation factors for aerobic soil degradation according to FOCUS guidance -
4		- #' -
5		- #' Time step normalisation factors for aerobic soil degradation as described -
6		- #' in Appendix 8 to the FOCUS kinetics guidance (FOCUS 2014, p. 369). -
7		- #' -
8		- #' @param object An object containing information used for the calculations -
9		- #' @param temperature Numeric vector of temperatures in °C -
10		- #' @param moisture Numeric vector of moisture contents in \\% w/w -
11		- #' @param field_moisture Numeric vector of moisture contents at field capacity -
12		- #' (pF2) in \\% w/w -
13		- #' @param study_moisture_ref_source Source for the reference value -
14		- #' used to calculate the study moisture. If 'auto', preference is given -
15		- #' to a reference moisture given in the meta information, otherwise -
16		- #' the focus soil moisture for the soil class is used -
17		- #' @param Q10 The Q10 value used for temperature normalisation -
18		- #' @param walker The Walker exponent used for moisture normalisation -
19		- #' @param f_na The factor to use for NA values. If set to NA, only factors -
20		- #' for complete cases will be returned. -
21		- #' @param \dots Currently not used -
22		- #' @references -
23		- #' FOCUS (2006) \dQuote{Guidance Document on Estimating Persistence -
24		- #' and Degradation Kinetics from Environmental Fate Studies on Pesticides in -
25		- #' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, -
26		- #' EC Document Reference Sanco/10058/2005 version 2.0, 434 pp, -
27		- #' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} -
28		- #' FOCUS (2014) \dQuote{Generic guidance for Estimating Persistence -
29		- #' and Degradation Kinetics from Environmental Fate Studies on Pesticides in -
30		- #' EU Registration} Report of the FOCUS Work Group on Degradation Kinetics, -
31		- #' Version 1.1, 18 December 2014 -
32		- #' \url{http://esdac.jrc.ec.europa.eu/projects/degradation-kinetics} -
33		- #' @seealso [focus_soil_moisture] -
34		- #' @examples -
35		- #' f_time_norm_focus(25, 20, 25) # 1.37, compare FOCUS 2014 p. 184 -
36		- #' -
37		- #' D24_2014$meta -
38		- #' # No moisture normalisation in the first dataset, so we use f_na = 1 to get -
39		- #' # temperature only normalisation as in the EU evaluation -
40		- #' f_time_norm_focus(D24_2014, study_moisture_ref_source = "focus", f_na = 1) -
41		- #' @export -
42		- f_time_norm_focus <- function(object, ...) { -
43	765x	- UseMethod("f_time_norm_focus") -
44		- } -
45		- -
46		- #' @rdname f_time_norm_focus -
47		- #' @export -
48		- f_time_norm_focus.numeric <- function(object, -
49		- moisture = NA, field_moisture = NA, -
50		- temperature = object, -
51		- Q10 = 2.58, walker = 0.7, f_na = NA, ...) -
52		- { -
53	459x	- f_temp <- ifelse(is.na(temperature), -
54	459x	- f_na, -
55	459x	- ifelse(temperature <= 0, -
56	459x	- 0, -
57	459x	- Q10^((temperature - 20)/10))) -
58	459x	- f_moist <- ifelse(is.na(moisture), -
59	459x	- f_na, -
60	459x	- ifelse(moisture >= field_moisture, -
61	459x	- 1, -
62	459x	- (moisture / field_moisture)^walker)) -
63	459x	- f_time_norm <- f_temp * f_moist -
64	459x	- f_time_norm -
65		- } -
66		- -
67		- #' @rdname f_time_norm_focus -
68		- #' @export -
69		- f_time_norm_focus.mkindsg <- function(object, -
70		- study_moisture_ref_source = c("auto", "meta", "focus"), -
71		- Q10 = 2.58, walker = 0.7, f_na = NA, ...) { -
72		- -
73	306x	- study_moisture_ref_source <- match.arg(study_moisture_ref_source) -
74	306x	- meta <- object$meta -
75		- -
76	306x	- if (is.null(meta$field_moisture)) { -
77	306x	- field_moisture <- focus_soil_moisture[meta$usda_soil_type, "pF2"] -
78		- } else { -
79	!	- field_moisture <- ifelse(is.na(meta$field_moisture), -
80	!	- focus_soil_moisture[meta$usda_soil_type, "pF2"], -
81	!	- meta$field_moisture) -
82		- } -
83		- -
84	306x	- study_moisture_ref_focus <- -
85	306x	- focus_soil_moisture[as.matrix(meta[c("usda_soil_type", "study_moisture_ref_type")])] -
86		- -
87	306x	- if (study_moisture_ref_source == "auto") { -
88	153x	- study_moisture_ref <- ifelse (is.na(meta$study_ref_moisture), -
89	153x	- study_moisture_ref_focus, -
90	153x	- meta$study_ref_moisture) -
91		- } else { -
92	153x	- if (study_moisture_ref_source == "meta") { -
93	!	- study_moisture_ref <- meta$study_moisture_ref -
94		- } else { -
95	153x	- study_moisture_ref <- study_moisture_ref_focus -
96		- } -
97		- } -
98		- -
99	306x	- if ("study_moisture" %in% names(meta)) { -
100	!	- study_moisture <- ifelse(is.na(meta$study_moisture), -
101	!	- meta$rel_moisture * study_moisture_ref, -
102	!	- meta$study_moisture) -
103		- } else { -
104	306x	- study_moisture <- meta$rel_moisture * study_moisture_ref -
105		- } -
106		- -
107	306x	- object$f_time_norm <- f_time_norm_focus(meta$temperature, -
108	306x	- moisture = study_moisture, field_moisture = field_moisture, -
109	306x	- Q10 = Q10, walker = walker, f_na = f_na) -
110	306x	- message("$f_time_norm was (re)set to normalised values") -
111	306x	- invisible(object$f_time_norm) -
112		- } -

1		- #' A dataset class for mkin -
2		- #' -
3		- #' @description -
4		- #' At the moment this dataset class is hardly used in mkin. For example, -
5		- #' mkinfit does not take mkinds datasets as argument, but works with dataframes -
6		- #' such as the on contained in the data field of mkinds objects. Some datasets -
7		- #' provided by this package come as mkinds objects nevertheless. -
8		- #' -
9		- #' @importFrom R6 R6Class -
10		- #' @examples -
11		- #' -
12		- #' mds <- mkinds$new("FOCUS A", FOCUS_2006_A) -
13		- #' print(mds) -
14		- #' -
15		- #' @export -
16		- mkinds <- R6Class("mkinds", -
17		- public = list( -
18		- -
19		- #' @field title A full title for the dataset -
20		- title = NULL, -
21		- -
22		- #' @field sampling_times The sampling times -
23		- sampling_times = NULL, -
24		- -
25		- #' @field time_unit The time unit -
26		- time_unit = NULL, -
27		- -
28		- #' @field observed Names of the observed variables -
29		- observed = NULL, -
30		- -
31		- #' @field unit The unit of the observations -
32		- unit = NULL, -
33		- -
34		- #' @field replicates The maximum number of replicates per sampling time -
35		- replicates = NULL, -
36		- -
37		- #' @field data A data frame with at least the columns name, time -
38		- #' and value in order to be compatible with mkinfit -
39		- data = NULL, -
40		- -
41		- #' @description -
42		- #' Create a new mkinds object -
43		- #' @param title The dataset title -
44		- #' @param data The data -
45		- #' @param time_unit The time unit -
46		- #' @param unit The unit of the observations -
47		- initialize = function(title = "", data, time_unit = NA, unit = NA) { -
48		- -
49	104x	- self$title <- title -
50	104x	- self$sampling_times <- sort(unique(data$time)) -
51	104x	- self$time_unit <- time_unit -
52	104x	- self$observed <- unique(data$name) -
53	104x	- self$unit <- unit -
54	104x	- self$replicates <- max(by(data, list(data$name, data$time), nrow)) -
55	104x	- if (is.null(data$override)) data$override <- NA -
56	104x	- if (is.null(data$err)) data$err <- 1 -
57	104x	- self$data <- data -
58		- -
59		- } -
60		- ) -
61		- ) -
62		- -
63		- #' Print mkinds objects -
64		- #' -
65		- #' @rdname mkinds -
66		- #' @param x An [mkinds] object. -
67		- #' @param data Should the data be printed? -
68		- #' @param \dots Not used. -
69		- #' @export -
70		- print.mkinds <- function(x, data = FALSE, ...) { -
71	104x	- cat("<mkinds> with $title: ", x$title, "\n") -
72	104x	- cat("Observed compounds $observed: ", paste(x$observed, collapse = ", "), "\n") -
73	104x	- cat("Sampling times $sampling_times:\n") -
74	104x	- cat(paste(x$sampling_times, collapse = ", "), "\n") -
75	104x	- cat("With a maximum of ", x$replicates, " replicates\n") -
76	104x	- if (!is.na(x$time_unit)) cat("Time unit: ", x$time_unit, "\n") -
77	104x	- if (!is.na(x$unit)) cat("Observation unit: ", x$unit, "\n") -
78	!	- if (data) print(mkin_long_to_wide(x$data)) -
79		- } -
80		- -
81		- #' A class for dataset groups for mkin -
82		- #' -
83		- #' @description -
84		- #' A container for working with datasets that share at least one compound, -
85		- #' so that combined evaluations are desirable. -
86		- #' -
87		- #' Time normalisation factors are initialised with a value of 1 for each -
88		- #' dataset if no data are supplied. -
89		- #' -
90		- #' @examples -
91		- #' -
92		- #' mdsg <- mkindsg$new("Experimental X", experimental_data_for_UBA_2019[6:10]) -
93		- #' print(mdsg) -
94		- #' print(mdsg, verbose = TRUE) -
95		- #' print(mdsg, verbose = TRUE, data = TRUE) -
96		- #' -
97		- #' @export -
98		- mkindsg <- R6Class("mkindsg", -
99		- public = list( -
100		- -
101		- #' @field title A title for the dataset group -
102		- title = NULL, -
103		- -
104		- #' @field ds A list of mkinds objects -
105		- ds = NULL, -
106		- -
107		- #' @field observed_n Occurrence counts of compounds in datasets -
108		- observed_n = NULL, -
109		- -
110		- #' @field f_time_norm Time normalisation factors -
111		- f_time_norm = NULL, -
112		- -
113		- #' @field meta A data frame with a row for each dataset, -
114		- #' containing additional information in the form -
115		- #' of categorical data (factors) or numerical data -
116		- #' (e.g. temperature, moisture, -
117		- #' or covariates like soil pH). -
118		- meta = NULL, -
119		- -
120		- #' @description -
121		- #' Create a new mkindsg object -
122		- #' @param title The title -
123		- #' @param ds A list of mkinds objects -
124		- #' @param f_time_norm Time normalisation factors -
125		- #' @param meta The meta data -
126		- initialize = function(title = "", ds, -
127		- f_time_norm = rep(1, length(ds)), meta) -
128		- { -
129	104x	- self$title <- title -
130	104x	- if (all(sapply(ds, inherits, "mkinds"))) { -
131	104x	- self$ds <- ds -
132		- } else { -
133	!	- stop("Please supply a list of mkinds objects") -
134		- } -
135		- -
136	104x	- all_observed <- unlist(lapply(ds, function(x) x$observed)) -
137	104x	- observed <- factor(all_observed, levels = unique(all_observed)) -
138	104x	- self$observed_n <- table(observed) -
139	104x	- names(dimnames(self$observed_n)) <- NULL -
140	104x	- self$f_time_norm <- f_time_norm -
141		- -
142	104x	- if (!missing(meta)) { -
143	!	- rownames(meta) <- lapply(ds, function(x) x$title) -
144	!	- self$meta <- meta -
145		- } -
146		- } -
147		- ) -
148		- ) -
149		- -
150		- #' Print mkindsg objects -
151		- #' -
152		- #' @rdname mkindsg -
153		- #' @param x An [mkindsg] object. -
154		- #' @param verbose Should the mkinds objects be printed? -
155		- #' @param data Should the mkinds objects be printed with their data? -
156		- #' @param \dots Not used. -
157		- #' @export -
158		- print.mkindsg <- function(x, data = FALSE, verbose = data, ...) { -
159	208x	- cat("<mkindsg> holding", length(x$ds), "mkinds objects\n") -
160	208x	- cat("Title $title: ", x$title, "\n") -
161	208x	- cat("Occurrence of observed compounds $observed_n:\n") -
162	208x	- print(x$observed_n) -
163	208x	- if (any(x$f_time_norm != 1)) { -
164	104x	- cat("Time normalisation factors $f_time_norm:\n") -
165	104x	- print(x$f_time_norm) -
166		- } -
167	208x	- if (!is.null(x$meta)) { -
168	104x	- cat("Meta information $meta:\n") -
169	104x	- print(x$meta) -
170		- } -
171	208x	- if (verbose) { -
172	!	- cat("\nDatasets $ds:") -
173	!	- for (ds in x$ds) { -
174	!	- cat("\n") -
175	!	- print(ds, data = data) -
176		- } -
177		- } -
178		- } -