mkin coverage - 89.31%

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

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

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


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])
  }
}

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 or an object coercible to a dataframe
#'   (e.g. a \code{tibble}) 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)

  # Coerce observed data to a dataframe
  observed <- as.data.frame(observed)

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

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

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, ...)
}

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

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

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

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 = c(1:25, 33, 35:38, 40:41, 47:57, 60:90)[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])
      }
    }
  }
}

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

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

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])
  }
}

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

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

#' 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 `deSolve::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 `deSolve::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, ...)
}

#' 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 `nlme::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)
}

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


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

}

#' 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 = "", ...)
{
  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, ]

  if (orig$transformations == "mkin") {
    degparm_names_transformed <- names(start_degparms)
    degparm_index <- which(names(orig_parms) %in% degparm_names_transformed)
    orig_degparms <- 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)

    orig_parms_back <- orig_parms
    orig_parms_back[degparm_index] <- orig_degparms
    names(orig_parms_back)[degparm_index] <- degparm_names
    orig_parms <- orig_parms_back

    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)[degparm_index] <- 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))
  i_negative <- selected_scaled_parms <= 0
  parms_with_negative_scaled_values <- paste(names(which(apply(i_negative, 2, any))), collapse = ", ")
  if (any(i_negative)) {
    warning("There are negative values for ", parms_with_negative_scaled_values, " which are set to NA for plotting")
  }
  selected_scaled_parms[i_negative] <- NA
  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"))
}

#' @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]])
}

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

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

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

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

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


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


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

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

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

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

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

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

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

#' 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", las = 2)
#' 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), las = 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
}

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


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

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


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

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

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

1		#' Number of observations on which an mkinfit object was fitted
2		#'
3		#' @importFrom stats nobs
4		#' @param object An mkinfit object
5		#' @param \dots For compatibility with the generic method
6		#' @return The number of rows in the data included in the mkinfit object
7		#' @export
8	166810x	nobs.mkinfit <- function(object, ...) nrow(object$data)

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		#' 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		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		#' 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		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		#' 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		#' 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		#' 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		#' 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		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 = c(1:25, 33, 35:38, 40:41, 47:57, 60:90)[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		#' 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		#' 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		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		#' 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		#' Function to plot the confidence intervals obtained using mkinfit
2		#'
3		#' This function plots the confidence intervals for the parameters fitted using
4		#' \code{\link{mkinfit}}.
5		#'
6		#' @param object A fit represented in an \code{\link{mkinfit}} object.
7		#' @return Nothing is returned by this function, as it is called for its side
8		#' effect, namely to produce a plot.
9		#' @author Johannes Ranke
10		#' @examples
11		#'
12		#' \dontrun{
13		#' model <- mkinmod(
14		#' T245 = mkinsub("SFO", to = c("phenol"), sink = FALSE),
15		#' phenol = mkinsub("SFO", to = c("anisole")),
16		#' anisole = mkinsub("SFO"), use_of_ff = "max")
17		#' fit <- mkinfit(model, subset(mccall81_245T, soil == "Commerce"), quiet = TRUE)
18		#' mkinparplot(fit)
19		#' }
20		#' @export
21		mkinparplot <- function(object) {
22	70x	state.optim = rownames(subset(object$start, type == "state"))
23	70x	deparms.optim = rownames(subset(object$start, type == "deparm"))
24	70x	fractions.optim = grep("^f_", deparms.optim, value = TRUE)
25	70x	N.optim = grep("^N_", deparms.optim, value = TRUE)
26	!	if ("g" %in% deparms.optim) fractions.optim <- c("g", fractions.optim)
27	70x	rates.optim.unsorted = setdiff(deparms.optim, union(fractions.optim, N.optim))
28	70x	rates.optim <- rownames(object$start[rates.optim.unsorted, ])
29	70x	n.plot <- c(state.optim = length(state.optim),
30	70x	rates.optim = length(rates.optim),
31	70x	N.optim = length(N.optim),
32	70x	fractions.optim = length(fractions.optim))
33	70x	n.plot <- n.plot[n.plot > 0]
34
35	70x	oldpar <- par(no.readonly = TRUE)
36	70x	on.exit(par(oldpar, no.readonly = TRUE))
37	70x	layout(matrix(1:length(n.plot), ncol = 1), heights = n.plot + 1)
38
39	70x	s <- summary(object)
40	70x	bpar <- data.frame(t(s$bpar[, c("Estimate", "Lower", "Upper")]))
41	70x	par(mar = c(2.1, 2.1, 0.1, 2.1))
42	70x	par(cex = 1)
43	70x	for (type in names(n.plot)) {
44	140x	parnames <- get(type)
45	140x	values <- bpar[parnames]
46	140x	values_with_confints <- data.frame(t(subset(data.frame(t(values)), !is.na("Lower"))))
47	140x	xlim = switch(type,
48	140x	state.optim = range(c(0, unlist(values)),
49	140x	na.rm = TRUE, finite = TRUE),
50	140x	rates.optim = range(c(0, unlist(values)),
51	140x	na.rm = TRUE, finite = TRUE),
52	140x	N.optim = range(c(0, 1, unlist(values)),
53	140x	na.rm = TRUE, finite = TRUE),
54	140x	fractions.optim = range(c(0, 1, unlist(values)),
55	140x	na.rm = TRUE, finite = TRUE))
56	140x	parname_index <- length(parnames):1 # Reverse order for strip chart
57
58	140x	stripchart(values["Estimate", ][parname_index],
59	140x	xlim = xlim,
60	140x	ylim = c(0.5, length(get(type)) + 0.5),
61	140x	yaxt = "n")
62	70x	if (type %in% c("rates.optim", "fractions.optim")) abline(v = 0, lty = 2)
63	!	if (type %in% c("N.optim", "fractions.optim")) abline(v = 1, lty = 2)
64	140x	position <- ifelse(values["Estimate", ] < mean(xlim), "right", "left")
65	140x	text(ifelse(position == "left", min(xlim), max(xlim)),
66	140x	parname_index, parnames,
67	140x	pos = ifelse(position == "left", 4, 2))
68
69	140x	values.upper.nonInf <- ifelse(values["Upper", ] == Inf, 1.5 * xlim[[2]], values["Upper", ])
70		# Suppress warnings for non-existing arrow lengths
71	140x	suppressWarnings(arrows(as.numeric(values["Lower", ]), parname_index,
72	140x	as.numeric(values.upper.nonInf), parname_index,
73	140x	code = 3, angle = 90, length = 0.05))
74		}
75		}

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 `deSolve::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 `deSolve::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		#' 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 `nlme::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		#' 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		#' 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		#' 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	orig <- attr(object, "orig")
39	176x	orig_parms <- parms(orig)
40	176x	start_degparms <- orig$mean_dp_start
41	176x	all_parms <- parms(object, exclude_failed = FALSE)
42
43	176x	if (inherits(object, "multistart.saem.mmkin")) {
44	176x	llfunc <- function(object) {
45	!	if (inherits(object$so, "try-error")) return(NA)
46	1408x	else return(logLik(object$so))
47		}
48		} else {
49	!	stop("parplot is only implemented for multistart.saem.mmkin objects")
50		}
51	176x	ll <- sapply(object, llfunc)
52	176x	if (!is.na(llquant[1])) {
53	!	if (llmin != -Inf) warning("Overriding 'llmin' because 'llquant' was specified")
54	88x	llmin <- quantile(ll, 1 - llquant)
55		}
56	176x	selected <- which(ll > llmin)
57	176x	selected_parms <- all_parms[selected, ]
58
59	176x	if (orig$transformations == "mkin") {
60	88x	degparm_names_transformed <- names(start_degparms)
61	88x	degparm_index <- which(names(orig_parms) %in% degparm_names_transformed)
62	88x	orig_degparms <- backtransform_odeparms(
63	88x	orig_parms[degparm_names_transformed],
64	88x	orig$mmkin[[1]]$mkinmod,
65	88x	transform_rates = orig$mmkin[[1]]$transform_rates,
66	88x	transform_fractions = orig$mmkin[[1]]$transform_fractions)
67	88x	start_degparms <- backtransform_odeparms(start_degparms,
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	degparm_names <- names(start_degparms)
72
73	88x	orig_parms_back <- orig_parms
74	88x	orig_parms_back[degparm_index] <- orig_degparms
75	88x	names(orig_parms_back)[degparm_index] <- degparm_names
76	88x	orig_parms <- orig_parms_back
77
78	88x	selected_parms[, degparm_names_transformed] <-
79	88x	t(apply(selected_parms[, degparm_names_transformed], 1, backtransform_odeparms,
80	88x	orig$mmkin[[1]]$mkinmod,
81	88x	transform_rates = orig$mmkin[[1]]$transform_rates,
82	88x	transform_fractions = orig$mmkin[[1]]$transform_fractions))
83	88x	colnames(selected_parms)[degparm_index] <- degparm_names
84		}
85
86	176x	start_errparms <- orig$so@model@error.init
87	176x	names(start_errparms) <- orig$so@model@name.sigma
88
89	176x	start_omegaparms <- orig$so@model@omega.init
90
91	176x	start_parms <- c(start_degparms, start_errparms)
92
93	176x	scale <- match.arg(scale)
94	176x	parm_scale <- switch(scale,
95	176x	best = selected_parms[which.best(object[selected]), ],
96	176x	median = apply(selected_parms, 2, median)
97		)
98
99		# Boxplots of all scaled parameters
100	176x	selected_scaled_parms <- t(apply(selected_parms, 1, function(x) x / parm_scale))
101	176x	i_negative <- selected_scaled_parms <= 0
102	176x	parms_with_negative_scaled_values <- paste(names(which(apply(i_negative, 2, any))), collapse = ", ")
103	176x	if (any(i_negative)) {
104	!	warning("There are negative values for ", parms_with_negative_scaled_values, " which are set to NA for plotting")
105		}
106	176x	selected_scaled_parms[i_negative] <- NA
107	176x	boxplot(selected_scaled_parms, log = "y", main = main, ,
108	176x	ylab = "Normalised parameters", ...)
109
110		# Show starting parameters
111	176x	start_scaled_parms <- rep(NA_real_, length(orig_parms))
112	176x	names(start_scaled_parms) <- names(orig_parms)
113	176x	start_scaled_parms[names(start_parms)] <-
114	176x	start_parms / parm_scale[names(start_parms)]
115	176x	points(start_scaled_parms, col = 3, cex = 3)
116
117		# Show parameters of original run
118	176x	orig_scaled_parms <- orig_parms / parm_scale
119	176x	points(orig_scaled_parms, col = 2, cex = 2)
120
121	176x	abline(h = 1, lty = 2)
122
123	176x	legend(lpos, inset = c(0.05, 0.05), bty = "n",
124	176x	pch = 1, col = 3:1, lty = c(NA, NA, 1),
125	176x	legend = c(
126	176x	"Original start",
127	176x	"Original results",
128	176x	"Multistart runs"))
129		}

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		#' Summary method for class "saem.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 [saem.mmkin]
10		#' @param x an object of class [summary.saem.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 digits Number of digits to use for printing
17		#' @param \dots optional arguments passed to methods like \code{print}.
18		#' @inheritParams endpoints
19		#' @return The summary function returns a list based on the [saemix::SaemixObject]
20		#' obtained in the fit, with at least the following additional components
21		#' \item{saemixversion, mkinversion, Rversion}{The saemix, 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 degradation model}
25		#' \item{use_of_ff}{Was maximum or minimum use made of formation fractions}
26		#' \item{data}{The data}
27		#' \item{confint_trans}{Transformed parameters as used in the optimisation, with confidence intervals}
28		#' \item{confint_back}{Backtransformed parameters, with confidence intervals if available}
29		#' \item{confint_errmod}{Error model parameters with confidence intervals}
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 vcov
36		#' @author Johannes Ranke for the mkin specific parts
37		#' saemix authors for the parts inherited from saemix.
38		#' @examples
39		#' # Generate five datasets following DFOP-SFO kinetics
40		#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120)
41		#' dfop_sfo <- mkinmod(parent = mkinsub("DFOP", "m1"),
42		#' m1 = mkinsub("SFO"), quiet = TRUE)
43		#' set.seed(1234)
44		#' k1_in <- rlnorm(5, log(0.1), 0.3)
45		#' k2_in <- rlnorm(5, log(0.02), 0.3)
46		#' g_in <- plogis(rnorm(5, qlogis(0.5), 0.3))
47		#' f_parent_to_m1_in <- plogis(rnorm(5, qlogis(0.3), 0.3))
48		#' k_m1_in <- rlnorm(5, log(0.02), 0.3)
49		#'
50		#' pred_dfop_sfo <- function(k1, k2, g, f_parent_to_m1, k_m1) {
51		#' mkinpredict(dfop_sfo,
52		#' c(k1 = k1, k2 = k2, g = g, f_parent_to_m1 = f_parent_to_m1, k_m1 = k_m1),
53		#' c(parent = 100, m1 = 0),
54		#' sampling_times)
55		#' }
56		#'
57		#' ds_mean_dfop_sfo <- lapply(1:5, function(i) {
58		#' mkinpredict(dfop_sfo,
59		#' c(k1 = k1_in[i], k2 = k2_in[i], g = g_in[i],
60		#' f_parent_to_m1 = f_parent_to_m1_in[i], k_m1 = k_m1_in[i]),
61		#' c(parent = 100, m1 = 0),
62		#' sampling_times)
63		#' })
64		#' names(ds_mean_dfop_sfo) <- paste("ds", 1:5)
65		#'
66		#' ds_syn_dfop_sfo <- lapply(ds_mean_dfop_sfo, function(ds) {
67		#' add_err(ds,
68		#' sdfunc = function(value) sqrt(1^2 + value^2 * 0.07^2),
69		#' n = 1)[[1]]
70		#' })
71		#'
72		#' \dontrun{
73		#' # Evaluate using mmkin and saem
74		#' f_mmkin_dfop_sfo <- mmkin(list(dfop_sfo), ds_syn_dfop_sfo,
75		#' quiet = TRUE, error_model = "tc", cores = 5)
76		#' f_saem_dfop_sfo <- saem(f_mmkin_dfop_sfo)
77		#' print(f_saem_dfop_sfo)
78		#' illparms(f_saem_dfop_sfo)
79		#' f_saem_dfop_sfo_2 <- update(f_saem_dfop_sfo,
80		#' no_random_effect = c("parent_0", "log_k_m1"))
81		#' illparms(f_saem_dfop_sfo_2)
82		#' intervals(f_saem_dfop_sfo_2)
83		#' summary(f_saem_dfop_sfo_2, data = TRUE)
84		#' # Add a correlation between random effects of g and k2
85		#' cov_model_3 <- f_saem_dfop_sfo_2$so@model@covariance.model
86		#' cov_model_3["log_k2", "g_qlogis"] <- 1
87		#' cov_model_3["g_qlogis", "log_k2"] <- 1
88		#' f_saem_dfop_sfo_3 <- update(f_saem_dfop_sfo,
89		#' covariance.model = cov_model_3)
90		#' intervals(f_saem_dfop_sfo_3)
91		#' # The correlation does not improve the fit judged by AIC and BIC, although
92		#' # the likelihood is higher with the additional parameter
93		#' anova(f_saem_dfop_sfo, f_saem_dfop_sfo_2, f_saem_dfop_sfo_3)
94		#' }
95		#'
96		#' @export
97		summary.saem.mmkin <- function(object, data = FALSE, verbose = FALSE,
98		covariates = NULL, covariate_quantile = 0.5,
99		distimes = TRUE, ...) {
100
101	800x	mod_vars <- names(object$mkinmod$diffs)
102
103	800x	pnames <- names(object$mean_dp_start)
104	800x	names_fixed_effects <- object$so@results@name.fixed
105	800x	n_fixed <- length(names_fixed_effects)
106
107	800x	conf.int <- object$so@results@conf.int
108	800x	rownames(conf.int) <- conf.int$name
109	800x	confint_trans <- as.matrix(parms(object, ci = TRUE))
110	800x	colnames(confint_trans)[1] <- "est."
111
112		# In case objects were produced by earlier versions of saem
113	!	if (is.null(object$transformations)) object$transformations <- "mkin"
114
115	800x	if (object$transformations == "mkin") {
116	396x	bp <- backtransform_odeparms(confint_trans[pnames, "est."], object$mkinmod,
117	396x	object$transform_rates, object$transform_fractions)
118	396x	bpnames <- names(bp)
119
120		# Transform boundaries of CI for one parameter at a time,
121		# with the exception of sets of formation fractions (single fractions are OK).
122	396x	f_names_skip <- character(0)
123	396x	for (box in mod_vars) { # Figure out sets of fractions to skip
124	492x	f_names <- grep(paste("^f", box, sep = "_"), pnames, value = TRUE)
125	492x	n_paths <- length(f_names)
126	!	if (n_paths > 1) f_names_skip <- c(f_names_skip, f_names)
127		}
128
129	396x	confint_back <- matrix(NA, nrow = length(bp), ncol = 3,
130	396x	dimnames = list(bpnames, colnames(confint_trans)))
131	396x	confint_back[, "est."] <- bp
132
133	396x	for (pname in pnames) {
134	1291x	if (!pname %in% f_names_skip) {
135	1291x	par.lower <- confint_trans[pname, "lower"]
136	1291x	par.upper <- confint_trans[pname, "upper"]
137	1291x	names(par.lower) <- names(par.upper) <- pname
138	1291x	bpl <- backtransform_odeparms(par.lower, object$mkinmod,
139	1291x	object$transform_rates,
140	1291x	object$transform_fractions)
141	1291x	bpu <- backtransform_odeparms(par.upper, object$mkinmod,
142	1291x	object$transform_rates,
143	1291x	object$transform_fractions)
144	1291x	confint_back[names(bpl), "lower"] <- bpl
145	1291x	confint_back[names(bpu), "upper"] <- bpu
146		}
147		}
148		} else {
149	404x	confint_back <- confint_trans[names_fixed_effects, ]
150		}
151
152		# Correlation of fixed effects (inspired by summary.nlme)
153	800x	cov_so <- try(solve(object$so@results@fim), silent = TRUE)
154	800x	if (inherits(cov_so, "try-error")) {
155	!	object$corFixed <- NA
156		} else {
157	800x	varFix <- cov_so[1:n_fixed, 1:n_fixed]
158	800x	stdFix <- sqrt(diag(varFix))
159	800x	object$corFixed <- array(
160	800x	t(varFix/stdFix)/stdFix,
161	800x	dim(varFix),
162	800x	list(names_fixed_effects, names_fixed_effects))
163		}
164
165		# Random effects
166	800x	sdnames <- intersect(rownames(conf.int), paste0("SD.", pnames))
167	800x	corrnames <- grep("^Corr.", rownames(conf.int), value = TRUE)
168	800x	confint_ranef <- as.matrix(conf.int[c(sdnames, corrnames), c("estimate", "lower", "upper")])
169	800x	colnames(confint_ranef)[1] <- "est."
170
171		# Error model
172	800x	enames <- if (object$err_mod == "const") "a.1" else c("a.1", "b.1")
173	800x	confint_errmod <- as.matrix(conf.int[enames, c("estimate", "lower", "upper")])
174	800x	colnames(confint_errmod)[1] <- "est."
175
176	800x	object$confint_trans <- confint_trans
177	800x	object$confint_ranef <- confint_ranef
178	800x	object$confint_errmod <- confint_errmod
179	800x	object$confint_back <- confint_back
180
181	800x	object$date.summary = date()
182	800x	object$use_of_ff = object$mkinmod$use_of_ff
183	800x	object$error_model_algorithm = object$mmkin_orig[[1]]$error_model_algorithm
184	800x	err_mod = object$mmkin_orig[[1]]$err_mod
185
186	800x	object$diffs <- object$mkinmod$diffs
187	800x	object$print_data <- data # boolean: Should we print the data?
188	800x	so_pred <- object$so@results@predictions
189
190	800x	names(object$data)[4] <- "observed" # rename value to observed
191
192	800x	object$verbose <- verbose
193
194	800x	object$fixed <- object$mmkin_orig[[1]]$fixed
195	800x	ll <-try(logLik(object$so, method = "is"), silent = TRUE)
196	800x	if (inherits(ll, "try-error")) {
197	!	object$logLik <- object$AIC <- object $BIC <- NA
198		} else {
199	800x	object$logLik = logLik(object$so, method = "is")
200	800x	object$AIC = AIC(object$so)
201	800x	object$BIC = BIC(object$so)
202		}
203
204	800x	ep <- endpoints(object)
205	800x	object$covariates <- ep$covariates
206	800x	if (length(ep$ff) != 0)
207	330x	object$ff <- ep$ff
208	800x	if (distimes) object$distimes <- ep$distimes
209	!	if (length(ep$SFORB) != 0) object$SFORB <- ep$SFORB
210	800x	class(object) <- c("summary.saem.mmkin")
211	800x	return(object)
212		}
213
214		#' @rdname summary.saem.mmkin
215		#' @export
216		print.summary.saem.mmkin <- function(x, digits = max(3, getOption("digits") - 3), verbose = x$verbose, ...) {
217	242x	cat("saemix version used for fitting: ", x$saemixversion, "\n")
218	242x	cat("mkin version used for pre-fitting: ", x$mkinversion, "\n")
219	242x	cat("R version used for fitting: ", x$Rversion, "\n")
220
221	242x	cat("Date of fit: ", x$date.fit, "\n")
222	242x	cat("Date of summary:", x$date.summary, "\n")
223
224	242x	cat("\nEquations:\n")
225	242x	nice_diffs <- gsub("^(d.*) =", "\\1/dt =", x[["diffs"]])
226	242x	writeLines(strwrap(nice_diffs, exdent = 11))
227
228	242x	cat("\nData:\n")
229	242x	cat(nrow(x$data), "observations of",
230	242x	length(unique(x$data$name)), "variable(s) grouped in",
231	242x	length(unique(x$data$ds)), "datasets\n")
232
233	242x	cat("\nModel predictions using solution type", x$solution_type, "\n")
234
235	242x	cat("\nFitted in", x$time[["elapsed"]], "s\n")
236	242x	cat("Using", paste(x$so@options$nbiter.saemix, collapse = ", "),
237	242x	"iterations and", x$so@options$nb.chains, "chains\n")
238
239	242x	cat("\nVariance model: ")
240	242x	cat(switch(x$err_mod,
241	242x	const = "Constant variance",
242	242x	obs = "Variance unique to each observed variable",
243	242x	tc = "Two-component variance function"), "\n")
244
245	242x	cat("\nStarting values for degradation parameters:\n")
246	242x	print(x$mean_dp_start, digits = digits)
247
248	242x	cat("\nFixed degradation parameter values:\n")
249	242x	if(length(x$fixed$value) == 0) cat("None\n")
250	!	else print(x$fixed, digits = digits)
251
252	242x	cat("\nStarting values for random effects (square root of initial entries in omega):\n")
253	242x	print(sqrt(x$so@model@omega.init), digits = digits)
254
255	242x	cat("\nStarting values for error model parameters:\n")
256	242x	errparms <- x$so@model@error.init
257	242x	names(errparms) <- x$so@model@name.sigma
258	242x	errparms <- errparms[x$so@model@indx.res]
259	242x	print(errparms, digits = digits)
260
261	242x	cat("\nResults:\n\n")
262	242x	cat("Likelihood computed by importance sampling\n")
263	242x	print(data.frame(AIC = x$AIC, BIC = x$BIC, logLik = x$logLik,
264	242x	row.names = " "), digits = digits)
265
266	242x	cat("\nOptimised parameters:\n")
267	242x	print(x$confint_trans, digits = digits)
268
269	242x	if (identical(x$corFixed, NA)) {
270	!	cat("\nCorrelation is not available\n")
271		} else {
272	242x	corr <- x$corFixed
273	242x	class(corr) <- "correlation"
274	242x	print(corr, title = "\nCorrelation:", rdig = digits, ...)
275		}
276
277	242x	cat("\nRandom effects:\n")
278	242x	print(x$confint_ranef, digits = digits)
279
280	242x	cat("\nVariance model:\n")
281	242x	print(x$confint_errmod, digits = digits)
282
283	242x	if (x$transformations == "mkin") {
284	125x	cat("\nBacktransformed parameters:\n")
285	125x	print(x$confint_back, digits = digits)
286		}
287
288	242x	if (!is.null(x$covariates)) {
289	!	cat("\nCovariates used for endpoints below:\n")
290	!	print(x$covariates)
291		}
292
293	242x	printSFORB <- !is.null(x$SFORB)
294	242x	if(printSFORB){
295	!	cat("\nEstimated Eigenvalues of SFORB model(s):\n")
296	!	print(x$SFORB, digits = digits,...)
297		}
298
299	242x	printff <- !is.null(x$ff)
300	242x	if(printff){
301	117x	cat("\nResulting formation fractions:\n")
302	117x	print(data.frame(ff = x$ff), digits = digits,...)
303		}
304
305	242x	printdistimes <- !is.null(x$distimes)
306	242x	if(printdistimes){
307	242x	cat("\nEstimated disappearance times:\n")
308	242x	print(x$distimes, digits = digits,...)
309		}
310
311	242x	if (x$print_data){
312	!	cat("\nData:\n")
313	!	print(format(x$data, digits = digits, ...), row.names = FALSE)
314		}
315
316	242x	invisible(x)
317		}

1		#' Set non-detects and unquantified values in residue series without replicates
2		#'
3		#' This function automates replacing unquantified values in residue time and
4		#' depth series. For time series, the function performs part of the residue
5		#' processing proposed in the FOCUS kinetics guidance for parent compounds
6		#' and metabolites. For two-dimensional residue series over time and depth,
7		#' it automates the proposal of Boesten et al (2015).
8		#'
9		#' @param res_raw Character vector of a residue time series, or matrix of
10		#' residue values with rows representing depth profiles for a specific sampling
11		#' time, and columns representing time series of residues at the same depth.
12		#' Values below the limit of detection (lod) have to be coded as "nd", values
13		#' between the limit of detection and the limit of quantification, if any, have
14		#' to be coded as "nq". Samples not analysed have to be coded as "na". All
15		#' values that are not "na", "nd" or "nq" have to be coercible to numeric
16		#' @param lod Limit of detection (numeric)
17		#' @param loq Limit of quantification(numeric). Must be specified if the FOCUS rule to
18		#' stop after the first non-detection is to be applied
19		#' @param time_zero_presence Do we assume that residues occur at time zero?
20		#' This only affects samples from the first sampling time that have been
21		#' reported as "nd" (not detected).
22		#' @references Boesten, J. J. T. I., van der Linden, A. M. A., Beltman, W. H.
23		#' J. and Pol, J. W. (2015). Leaching of plant protection products and their
24		#' transformation products; Proposals for improving the assessment of leaching
25		#' to groundwater in the Netherlands — Version 2. Alterra report 2630, Alterra
26		#' Wageningen UR (University & Research centre)
27		#' @references FOCUS (2014) Generic Guidance for Estimating Persistence and Degradation
28		#' Kinetics from Environmental Fate Studies on Pesticides in EU Registration, Version 1.1,
29		#' 18 December 2014, p. 251
30		#' @return A numeric vector, if a vector was supplied, or a numeric matrix otherwise
31		#' @export
32		#' @examples
33		#' # FOCUS (2014) p. 75/76 and 131/132
34		#' parent_1 <- c(.12, .09, .05, .03, "nd", "nd", "nd", "nd", "nd", "nd")
35		#' set_nd_nq(parent_1, 0.02)
36		#' parent_2 <- c(.12, .09, .05, .03, "nd", "nd", .03, "nd", "nd", "nd")
37		#' set_nd_nq(parent_2, 0.02)
38		#' set_nd_nq_focus(parent_2, 0.02, loq = 0.05)
39		#' parent_3 <- c(.12, .09, .05, .03, "nd", "nd", .06, "nd", "nd", "nd")
40		#' set_nd_nq(parent_3, 0.02)
41		#' set_nd_nq_focus(parent_3, 0.02, loq = 0.05)
42		#' metabolite <- c("nd", "nd", "nd", 0.03, 0.06, 0.10, 0.11, 0.10, 0.09, 0.05, 0.03, "nd", "nd")
43		#' set_nd_nq(metabolite, 0.02)
44		#' set_nd_nq_focus(metabolite, 0.02, 0.05)
45		#' #
46		#' # Boesten et al. (2015), p. 57/58
47		#' table_8 <- matrix(
48		#' c(10, 10, rep("nd", 4),
49		#' 10, 10, rep("nq", 2), rep("nd", 2),
50		#' 10, 10, 10, "nq", "nd", "nd",
51		#' "nq", 10, "nq", rep("nd", 3),
52		#' "nd", "nq", "nq", rep("nd", 3),
53		#' rep("nd", 6), rep("nd", 6)),
54		#' ncol = 6, byrow = TRUE)
55		#' set_nd_nq(table_8, 0.5, 1.5, time_zero_presence = TRUE)
56		#' table_10 <- matrix(
57		#' c(10, 10, rep("nd", 4),
58		#' 10, 10, rep("nd", 4),
59		#' 10, 10, 10, rep("nd", 3),
60		#' "nd", 10, rep("nd", 4),
61		#' rep("nd", 18)),
62		#' ncol = 6, byrow = TRUE)
63		#' set_nd_nq(table_10, 0.5, time_zero_presence = TRUE)
64		set_nd_nq <- function(res_raw, lod, loq = NA, time_zero_presence = FALSE) {
65	10x	if (!is.character(res_raw)) {
66	!	stop("Please supply a vector or a matrix of character values")
67		}
68	10x	if (is.vector(res_raw)) {
69	8x	was_vector <- TRUE
70	8x	res_raw <- as.matrix(res_raw)
71		} else {
72	2x	was_vector <- FALSE
73	2x	if (!is.matrix(res_raw)) {
74	!	stop("Please supply a vector or a matrix of character values")
75		}
76		}
77	10x	nq <- 0.5 * (loq + lod)
78	10x	nda <- 0.5 * lod # not detected but adjacent to detection
79	10x	res_raw[res_raw == "nq"] <- nq
80
81	10x	if (!time_zero_presence) {
82	8x	for (j in 1:ncol(res_raw)) {
83	3x	if (res_raw[1, j] == "nd") res_raw[1, j] <- "na"
84		}
85		}
86	10x	res_raw[res_raw == "na"] <- NA
87
88	10x	not_nd_na <- function(value) !(grepl("nd", value) \| is.na(value))
89
90	10x	for (i in 1:nrow(res_raw)) {
91	94x	for (j in 1:ncol(res_raw)) {
92	164x	if (!is.na(res_raw[i, j]) && res_raw[i, j] == "nd") {
93	98x	if (i > 1) { # check earlier sample in same layer
94	17x	if (not_nd_na(res_raw[i - 1, j])) res_raw[i, j] <- "nda"
95		}
96	98x	if (i < nrow(res_raw)) { # check later sample
97	7x	if (not_nd_na(res_raw[i + 1, j])) res_raw[i, j] <- "nda"
98		}
99	98x	if (j > 1) { # check above sample at the same time
100	9x	if (not_nd_na(res_raw[i, j - 1])) res_raw[i, j] <- "nda"
101		}
102	98x	if (j < ncol(res_raw)) { # check sample below at the same time
103	2x	if (not_nd_na(res_raw[i, j + 1])) res_raw[i, j] <- "nda"
104		}
105		}
106		}
107		}
108	10x	res_raw[res_raw == "nda"] <- nda
109	10x	res_raw[res_raw == "nd"] <- NA
110
111	10x	result <- as.numeric(res_raw)
112	10x	dim(result) <- dim(res_raw)
113	10x	dimnames(result) <- dimnames(res_raw)
114	8x	if (was_vector) result <- as.vector(result)
115	10x	return(result)
116		}
117
118		#' @describeIn set_nd_nq Set non-detects in residue time series according to FOCUS rules
119		#' @param set_first_sample_nd Should the first sample be set to "first_sample_nd_value"
120		#' in case it is a non-detection?
121		#' @param first_sample_nd_value Value to be used for the first sample if it is a non-detection
122		#' @param ignore_below_loq_after_first_nd Should we ignore values below the LOQ after the first
123		#' non-detection that occurs after the quantified values?
124		#' @export
125		set_nd_nq_focus <- function(res_raw, lod, loq = NA,
126		set_first_sample_nd = TRUE, first_sample_nd_value = 0,
127		ignore_below_loq_after_first_nd = TRUE)
128		{
129
130	!	if (!is.vector(res_raw)) stop("FOCUS rules are only specified for one-dimensional time series")
131
132	5x	if (ignore_below_loq_after_first_nd & is.na(loq)) {
133	1x	stop("You need to specify an LOQ")
134		}
135
136	4x	n <- length(res_raw)
137	4x	if (ignore_below_loq_after_first_nd) {
138	4x	for (i in 3:n) {
139	35x	if (!res_raw[i - 2] %in% c("na", "nd")) {
140	21x	if (res_raw[i - 1] == "nd") {
141	5x	res_remaining <- res_raw[i:n]
142	5x	res_remaining_unquantified <- ifelse(res_remaining == "na", TRUE,
143	5x	ifelse(res_remaining == "nd", TRUE,
144	5x	ifelse(res_remaining == "nq", TRUE,
145	5x	ifelse(suppressWarnings(as.numeric(res_remaining)) < loq, TRUE, FALSE))))
146	5x	res_remaining_numeric <- suppressWarnings(as.numeric(res_remaining))
147	5x	res_remaining_below_loq <- ifelse(res_remaining == "nq", TRUE,
148	5x	ifelse(!is.na(res_remaining_numeric) & res_remaining_numeric < loq, TRUE, FALSE))
149	5x	if (all(res_remaining_unquantified)) {
150	4x	res_raw[i:n] <- ifelse(res_remaining_below_loq, "nd", res_remaining)
151		}
152		}
153		}
154		}
155		}
156
157	4x	result <- set_nd_nq(res_raw, lod = lod, loq = loq)
158
159	4x	if (set_first_sample_nd) {
160	1x	if (res_raw[1] == "nd") result[1] <- first_sample_nd_value
161		}
162
163	4x	return(result)
164		}

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