aboutsummaryrefslogtreecommitdiff
path: root/R/nlmixr.R
diff options
context:
space:
mode:
Diffstat (limited to 'R/nlmixr.R')
-rw-r--r--R/nlmixr.R539
1 files changed, 539 insertions, 0 deletions
diff --git a/R/nlmixr.R b/R/nlmixr.R
new file mode 100644
index 00000000..9c364c4f
--- /dev/null
+++ b/R/nlmixr.R
@@ -0,0 +1,539 @@
+utils::globalVariables(c("predicted", "std", "ID", "TIME", "CMT", "DV", "IPRED", "IRES", "IWRES"))
+
+#' @export
+nlmixr::nlmixr
+
+#' Fit nonlinear mixed models using nlmixr
+#'
+#' This function uses [nlmixr::nlmixr()] 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].
+#'
+#' @importFrom nlmixr nlmixr tableControl
+#' @importFrom dplyr %>%
+#' @param object An [mmkin] row object containing several fits of the same
+#' [mkinmod] model to different datasets
+#' @param data Not used, the data are extracted from the mmkin row object
+#' @param est Estimation method passed to [nlmixr::nlmixr]
+#' @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 eta_start Standard deviations on the transformed scale 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 data Not used, as the data are extracted from the mmkin row object
+#' @param table Passed to [nlmixr::nlmixr]
+#' @param error_model Possibility to override the error model which is being
+#' set based on the error model used in the mmkin row object.
+#' @param control Passed to [nlmixr::nlmixr]
+#' @param \dots Passed to [nlmixr_model]
+#' @param save Passed to [nlmixr::nlmixr]
+#' @param envir Passed to [nlmixr::nlmixr]
+#' @return An S3 object of class 'nlmixr.mmkin', containing the fitted
+#' [nlmixr::nlmixr] object as a list component named 'nm'. The
+#' object also inherits from 'mixed.mmkin'.
+#' @seealso [summary.nlmixr.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 <- mmkin(c("SFO", "FOMC", "DFOP", "HS"), ds, quiet = TRUE, cores = 1)
+#' f_mmkin_parent_tc <- mmkin(c("SFO", "FOMC", "DFOP"), ds, error_model = "tc",
+#' cores = 1, quiet = TRUE)
+#'
+#' f_nlmixr_sfo_saem <- nlmixr(f_mmkin_parent["SFO", ], est = "saem")
+#' f_nlmixr_sfo_focei <- nlmixr(f_mmkin_parent["SFO", ], est = "focei")
+#'
+#' f_nlmixr_fomc_saem <- nlmixr(f_mmkin_parent["FOMC", ], est = "saem")
+#' f_nlmixr_fomc_focei <- nlmixr(f_mmkin_parent["FOMC", ], est = "focei")
+#'
+#' f_nlmixr_dfop_saem <- nlmixr(f_mmkin_parent["DFOP", ], est = "saem")
+#' f_nlmixr_dfop_focei <- nlmixr(f_mmkin_parent["DFOP", ], est = "focei")
+#'
+#' f_nlmixr_hs_saem <- nlmixr(f_mmkin_parent["HS", ], est = "saem")
+#' f_nlmixr_hs_focei <- nlmixr(f_mmkin_parent["HS", ], est = "focei")
+#'
+#' f_nlmixr_fomc_saem_tc <- nlmixr(f_mmkin_parent_tc["FOMC", ], est = "saem")
+#' f_nlmixr_fomc_focei_tc <- nlmixr(f_mmkin_parent_tc["FOMC", ], est = "focei")
+#'
+#' AIC(
+#' f_nlmixr_sfo_saem$nm, f_nlmixr_sfo_focei$nm,
+#' f_nlmixr_fomc_saem$nm, f_nlmixr_fomc_focei$nm,
+#' f_nlmixr_dfop_saem$nm, f_nlmixr_dfop_focei$nm,
+#' f_nlmixr_hs_saem$nm, f_nlmixr_hs_focei$nm,
+#' f_nlmixr_fomc_saem_tc$nm, f_nlmixr_fomc_focei_tc$nm)
+#'
+#' AIC(nlme(f_mmkin_parent["FOMC", ]))
+#' AIC(nlme(f_mmkin_parent["HS", ]))
+#'
+#' # nlme is comparable to nlmixr with focei, saem finds a better
+#' # solution, the two-component error model does not improve it
+#' plot(f_nlmixr_fomc_saem)
+#'
+#' 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"))
+#'
+#' f_mmkin_const <- mmkin(list(
+#' "SFO-SFO" = sfo_sfo, "FOMC-SFO" = fomc_sfo, "DFOP-SFO" = dfop_sfo),
+#' ds, quiet = TRUE, error_model = "const")
+#' f_mmkin_obs <- mmkin(list(
+#' "SFO-SFO" = sfo_sfo, "FOMC-SFO" = fomc_sfo, "DFOP-SFO" = dfop_sfo),
+#' ds, quiet = TRUE, error_model = "obs")
+#' f_mmkin_tc <- mmkin(list(
+#' "SFO-SFO" = sfo_sfo, "FOMC-SFO" = fomc_sfo, "DFOP-SFO" = dfop_sfo),
+#' ds, quiet = TRUE, error_model = "tc")
+#'
+#' # A single constant variance is currently only possible with est = 'focei' in nlmixr
+#' f_nlmixr_sfo_sfo_focei_const <- nlmixr(f_mmkin_const["SFO-SFO", ], est = "focei")
+#' f_nlmixr_fomc_sfo_focei_const <- nlmixr(f_mmkin_const["FOMC-SFO", ], est = "focei")
+#' f_nlmixr_dfop_sfo_focei_const <- nlmixr(f_mmkin_const["DFOP-SFO", ], est = "focei")
+#'
+#' # Variance by variable is supported by 'saem' and 'focei'
+#' f_nlmixr_fomc_sfo_saem_obs <- nlmixr(f_mmkin_obs["FOMC-SFO", ], est = "saem")
+#' f_nlmixr_fomc_sfo_focei_obs <- nlmixr(f_mmkin_obs["FOMC-SFO", ], est = "focei")
+#' f_nlmixr_dfop_sfo_saem_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "saem")
+#' f_nlmixr_dfop_sfo_focei_obs <- nlmixr(f_mmkin_obs["DFOP-SFO", ], est = "focei")
+#'
+#' # Identical two-component error for all variables is only possible with
+#' # est = 'focei' in nlmixr
+#' f_nlmixr_fomc_sfo_focei_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "focei")
+#' f_nlmixr_dfop_sfo_focei_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei")
+#'
+#' # Two-component error by variable is possible with both estimation methods
+#' # Variance by variable is supported by 'saem' and 'focei'
+#' f_nlmixr_fomc_sfo_saem_obs_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "saem",
+#' error_model = "obs_tc")
+#' f_nlmixr_fomc_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["FOMC-SFO", ], est = "focei",
+#' error_model = "obs_tc")
+#' f_nlmixr_dfop_sfo_saem_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "saem",
+#' error_model = "obs_tc")
+#' f_nlmixr_dfop_sfo_focei_obs_tc <- nlmixr(f_mmkin_tc["DFOP-SFO", ], est = "focei",
+#' error_model = "obs_tc")
+#'
+#' AIC(
+#' f_nlmixr_sfo_sfo_focei_const$nm,
+#' f_nlmixr_fomc_sfo_focei_const$nm,
+#' f_nlmixr_dfop_sfo_focei_const$nm,
+#' f_nlmixr_fomc_sfo_saem_obs$nm,
+#' f_nlmixr_fomc_sfo_focei_obs$nm,
+#' f_nlmixr_dfop_sfo_saem_obs$nm,
+#' f_nlmixr_dfop_sfo_focei_obs$nm,
+#' f_nlmixr_fomc_sfo_focei_tc$nm,
+#' f_nlmixr_dfop_sfo_focei_tc$nm,
+#' f_nlmixr_fomc_sfo_saem_obs_tc$nm,
+#' f_nlmixr_fomc_sfo_focei_obs_tc$nm,
+#' f_nlmixr_dfop_sfo_saem_obs_tc$nm,
+#' f_nlmixr_dfop_sfo_focei_obs_tc$nm
+#' )
+#' # Currently, FOMC-SFO with two-component error by variable fitted by focei gives the
+#' # lowest AIC
+#' plot(f_nlmixr_fomc_sfo_focei_obs_tc)
+#' summary(f_nlmixr_fomc_sfo_focei_obs_tc)
+#' }
+#' @export
+nlmixr.mmkin <- function(object, data = NULL,
+ est = NULL, control = list(),
+ table = tableControl(),
+ error_model = object[[1]]$err_mod,
+ test_log_parms = TRUE,
+ conf.level = 0.6,
+ degparms_start = "auto",
+ eta_start = "auto",
+ ...,
+ save = NULL,
+ envir = parent.frame()
+)
+{
+ m_nlmixr <- nlmixr_model(object, est = est,
+ error_model = error_model, add_attributes = TRUE,
+ test_log_parms = test_log_parms, conf.level = conf.level,
+ degparms_start = degparms_start, eta_start = eta_start
+ )
+ d_nlmixr <- nlmixr_data(object)
+
+ mean_dp_start <- attr(m_nlmixr, "mean_dp_start")
+ mean_ep_start <- attr(m_nlmixr, "mean_ep_start")
+
+ attributes(m_nlmixr) <- NULL
+
+ fit_time <- system.time({
+ f_nlmixr <- nlmixr(m_nlmixr, d_nlmixr, est = est, control = control)
+ })
+
+ if (is.null(f_nlmixr$CMT)) {
+ nlmixr_df <- as.data.frame(f_nlmixr[c("ID", "TIME", "DV", "IPRED", "IRES", "IWRES")])
+ nlmixr_df$CMT <- as.character(object[[1]]$data$variable[1])
+ } else {
+ nlmixr_df <- as.data.frame(f_nlmixr[c("ID", "TIME", "DV", "CMT", "IPRED", "IRES", "IWRES")])
+ }
+
+ return_data <- nlmixr_df %>%
+ dplyr::transmute(ds = ID, name = CMT, time = TIME, value = DV,
+ predicted = IPRED, residual = IRES,
+ std = IRES/IWRES, standardized = IWRES) %>%
+ dplyr::arrange(ds, name, time)
+
+ bparms_optim <- backtransform_odeparms(f_nlmixr$theta,
+ object[[1]]$mkinmod,
+ object[[1]]$transform_rates,
+ object[[1]]$transform_fractions)
+
+ result <- list(
+ mkinmod = object[[1]]$mkinmod,
+ mmkin = object,
+ transform_rates = object[[1]]$transform_rates,
+ transform_fractions = object[[1]]$transform_fractions,
+ nm = f_nlmixr,
+ est = est,
+ time = fit_time,
+ mean_dp_start = mean_dp_start,
+ mean_ep_start = mean_ep_start,
+ bparms.optim = bparms_optim,
+ bparms.fixed = object[[1]]$bparms.fixed,
+ data = return_data,
+ err_mod = error_model,
+ date.fit = date(),
+ nlmixrversion = as.character(utils::packageVersion("nlmixr")),
+ mkinversion = as.character(utils::packageVersion("mkin")),
+ Rversion = paste(R.version$major, R.version$minor, sep=".")
+ )
+
+ class(result) <- c("nlmixr.mmkin", "mixed.mmkin")
+ return(result)
+}
+
+#' @export
+#' @rdname nlmixr.mmkin
+#' @param x An nlmixr.mmkin object to print
+#' @param digits Number of digits to use for printing
+print.nlmixr.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) {
+ cat("Kinetic nonlinear mixed-effects model fit by", x$est, "using nlmixr")
+ 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("\nLikelihood:\n")
+ print(data.frame(
+ AIC = AIC(x$nm),
+ BIC = BIC(x$nm),
+ logLik = logLik(x$nm),
+ row.names = " "), digits = digits)
+
+ cat("\nFitted parameters:\n")
+ print(x$nm$parFixed, digits = digits)
+
+ invisible(x)
+}
+
+#' @rdname nlmixr.mmkin
+#' @param add_attributes Should the starting values used for degradation model
+#' parameters and their distribution and for the error model parameters
+#' be returned as attributes?
+#' @return An function defining a model suitable for fitting with [nlmixr::nlmixr].
+#' @export
+nlmixr_model <- function(object,
+ est = c("saem", "focei"),
+ degparms_start = "auto",
+ eta_start = "auto",
+ test_log_parms = TRUE, conf.level = 0.6,
+ error_model = object[[1]]$err_mod, add_attributes = FALSE)
+{
+ if (nrow(object) > 1) stop("Only row objects allowed")
+ est = match.arg(est)
+
+ mkin_model <- object[[1]]$mkinmod
+ obs_vars <- names(mkin_model$spec)
+
+ if (error_model == object[[1]]$err_mod) {
+
+ if (length(object[[1]]$mkinmod$spec) > 1 & est == "saem") {
+ if (error_model == "const") {
+ message(
+ "Constant variance for more than one variable is not supported for est = 'saem'\n",
+ "Changing the error model to 'obs' (variance by observed variable)")
+ error_model <- "obs"
+ }
+ if (error_model =="tc") {
+ message(
+ "With est = 'saem', a different error model is required for each observed variable",
+ "Changing the error model to 'obs_tc' (Two-component error for each observed variable)")
+ error_model <- "obs_tc"
+ }
+ }
+ }
+
+ degparms_mmkin <- mean_degparms(object,
+ test_log_parms = test_log_parms,
+ conf.level = conf.level, random = TRUE)
+
+ degparms_optim <- degparms_mmkin$fixed
+
+ degparms_optim_ilr_names <- grep("^f_.*_ilr", names(degparms_optim), value = TRUE)
+ obs_vars_ilr <- unique(gsub("f_(.*)_ilr.*$", "\\1", degparms_optim_ilr_names))
+ degparms_optim_noilr <- degparms_optim[setdiff(names(degparms_optim),
+ degparms_optim_ilr_names)]
+
+ degparms_optim_back <- backtransform_odeparms(degparms_optim,
+ object[[1]]$mkinmod,
+ object[[1]]$transform_rates,
+ object[[1]]$transform_fractions)
+
+ if (degparms_start[1] == "auto") {
+ degparms_start <- degparms_optim_noilr
+ for (obs_var_ilr in obs_vars_ilr) {
+ ff_names <- grep(paste0("^f_", obs_var_ilr, "_"),
+ names(degparms_optim_back), value = TRUE)
+ f_tffm0 <- tffm0(degparms_optim_back[ff_names])
+ f_tffm0_qlogis <- qlogis(f_tffm0)
+ names(f_tffm0_qlogis) <- paste0("f_", obs_var_ilr,
+ "_tffm0_", 1:length(f_tffm0), "_qlogis")
+ degparms_start <- c(degparms_start, f_tffm0_qlogis)
+ }
+ }
+
+ if (eta_start[1] == "auto") {
+ eta_start <- degparms_mmkin$eta[setdiff(names(degparms_optim),
+ degparms_optim_ilr_names)]
+ for (obs_var_ilr in obs_vars_ilr) {
+ ff_n <- length(grep(paste0("^f_", obs_var_ilr, "_"),
+ names(degparms_optim_back), value = TRUE))
+ eta_start_ff <- rep(0.3, ff_n)
+ names(eta_start_ff) <- paste0("f_", obs_var_ilr,
+ "_tffm0_", 1:ff_n, "_qlogis")
+ eta_start <- c(eta_start, eta_start_ff)
+ }
+ }
+
+
+ degparms_fixed <- object[[1]]$bparms.fixed
+
+ 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)
+
+ # Definition of the model function
+ f <- function(){}
+
+ ini_block <- "ini({"
+
+ # Initial values for all degradation parameters
+ for (parm_name in names(degparms_start)) {
+ # As initials for state variables are not transformed,
+ # we need to modify the name here as we want to
+ # use the original name in the model block
+ ini_block <- paste0(
+ ini_block,
+ parm_name, " = ",
+ as.character(degparms_start[parm_name]),
+ "\n",
+ "eta.", parm_name, " ~ ",
+ as.character(eta_start[parm_name]),
+ "\n"
+ )
+ }
+
+ # Error model parameters
+ error_model_mkin <- object[[1]]$err_mod
+
+ errparm_names_mkin <- names(object[[1]]$errparms)
+ errparms_mkin <- sapply(errparm_names_mkin, function(parm_name) {
+ mean(sapply(object, function(x) x$errparms[parm_name]))
+ })
+
+ sigma_tc_mkin <- errparms_ini <- errparms_mkin[1] +
+ mean(unlist(sapply(object, function(x) x$data$observed)), na.rm = TRUE) *
+ errparms_mkin[2]
+
+ if (error_model == "const") {
+ if (error_model_mkin == "tc") {
+ errparms_ini <- sigma_tc_mkin
+ } else {
+ errparms_ini <- mean(errparms_mkin)
+ }
+ names(errparms_ini) <- "sigma"
+ }
+
+ if (error_model == "obs") {
+ errparms_ini <- switch(error_model_mkin,
+ const = rep(errparms_mkin["sigma"], length(obs_vars)),
+ obs = errparms_mkin,
+ tc = sigma_tc_mkin)
+ names(errparms_ini) <- paste0("sigma_", obs_vars)
+ }
+
+ if (error_model == "tc") {
+ if (error_model_mkin != "tc") {
+ stop("Not supported")
+ } else {
+ errparms_ini <- errparms_mkin
+ }
+ }
+
+ if (error_model == "obs_tc") {
+ if (error_model_mkin != "tc") {
+ stop("Not supported")
+ } else {
+ errparms_ini <- rep(errparms_mkin, length(obs_vars))
+ names(errparms_ini) <- paste0(
+ rep(names(errparms_mkin), length(obs_vars)),
+ "_",
+ rep(obs_vars, each = 2))
+ }
+ }
+
+ for (parm_name in names(errparms_ini)) {
+ ini_block <- paste0(
+ ini_block,
+ parm_name, " = ",
+ as.character(errparms_ini[parm_name]),
+ "\n"
+ )
+ }
+
+ ini_block <- paste0(ini_block, "})")
+
+ body(f)[2] <- parse(text = ini_block)
+
+ model_block <- "model({"
+
+ # Population initial values for the ODE state variables
+ for (parm_name in odeini_optim_parm_names) {
+ model_block <- paste0(
+ model_block,
+ parm_name, "_model = ",
+ parm_name, " + eta.", parm_name, "\n",
+ gsub("(.*)_0", "\\1(0)", parm_name), " = ", parm_name, "_model\n")
+ }
+
+ # Population initial values for log rate constants
+ for (parm_name in grep("^log_", names(degparms_start), value = TRUE)) {
+ model_block <- paste0(
+ model_block,
+ gsub("^log_", "", parm_name), " = ",
+ "exp(", parm_name, " + eta.", parm_name, ")\n")
+ }
+
+ # Population initial values for logit transformed parameters
+ for (parm_name in grep("_qlogis$", names(degparms_start), value = TRUE)) {
+ model_block <- paste0(
+ model_block,
+ gsub("_qlogis$", "", parm_name), " = ",
+ "expit(", parm_name, " + eta.", parm_name, ")\n")
+ }
+
+ # Calculate formation fractions from tffm0 transformed values
+ for (obs_var_ilr in obs_vars_ilr) {
+ ff_names <- grep(paste0("^f_", obs_var_ilr, "_"),
+ names(degparms_optim_back), value = TRUE)
+ pattern <- paste0("^f_", obs_var_ilr, "_to_(.*)$")
+ target_vars <- gsub(pattern, "\\1",
+ grep(paste0("^f_", obs_var_ilr, "_to_"), names(degparms_optim_back), value = TRUE))
+ for (i in 1:length(target_vars)) {
+ ff_name <- ff_names[i]
+ ff_line <- paste0(ff_name, " = f_", obs_var_ilr, "_tffm0_", i)
+ if (i > 1) {
+ for (j in (i - 1):1) {
+ ff_line <- paste0(ff_line, " * (1 - f_", obs_var_ilr, "_tffm0_", j , ")")
+ }
+ }
+ model_block <- paste0(
+ model_block,
+ ff_line,
+ "\n"
+ )
+ }
+ }
+
+ # Differential equations
+ model_block <- paste0(
+ model_block,
+ paste(
+ gsub("d_(.*) =", "d/dt(\\1) =", mkin_model$diffs),
+ collapse = "\n"),
+ "\n"
+ )
+
+ # Error model
+ if (error_model == "const") {
+ model_block <- paste0(model_block,
+ paste(paste0(obs_vars, " ~ add(sigma)"), collapse = "\n"))
+ }
+ if (error_model == "obs") {
+ model_block <- paste0(model_block,
+ paste(paste0(obs_vars, " ~ add(sigma_", obs_vars, ")"), collapse = "\n"),
+ "\n")
+ }
+ if (error_model == "tc") {
+ model_block <- paste0(model_block,
+ paste(paste0(obs_vars, " ~ add(sigma_low) + prop(rsd_high)"), collapse = "\n"),
+ "\n")
+ }
+ if (error_model == "obs_tc") {
+ model_block <- paste0(model_block,
+ paste(
+ paste0(obs_vars, " ~ add(sigma_low_", obs_vars, ") + ",
+ "prop(rsd_high_", obs_vars, ")"), collapse = "\n"),
+ "\n")
+ }
+
+ model_block <- paste0(model_block, "})")
+
+ body(f)[3] <- parse(text = model_block)
+
+ if (add_attributes) {
+ attr(f, "mean_dp_start") <- degparms_optim
+ attr(f, "eta_start") <- degparms_mmkin$eta
+ attr(f, "mean_ep_start") <- errparms_ini
+ }
+
+ return(f)
+}
+
+#' @rdname nlmixr.mmkin
+#' @return An dataframe suitable for use with [nlmixr::nlmixr]
+#' @export
+nlmixr_data <- function(object, ...) {
+ if (nrow(object) > 1) stop("Only row objects allowed")
+ d <- lapply(object, function(x) x$data)
+ compartment_map <- 1:length(object[[1]]$mkinmod$spec)
+ names(compartment_map) <- names(object[[1]]$mkinmod$spec)
+ ds_names <- colnames(object)
+
+ ds_list <- lapply(object, function(x) x$data[c("time", "variable", "observed")])
+ names(ds_list) <- ds_names
+ ds_nlmixr <- purrr::map_dfr(ds_list, function(x) x, .id = "ds")
+ ds_nlmixr$variable <- as.character(ds_nlmixr$variable)
+ ds_nlmixr_renamed <- data.frame(
+ ID = ds_nlmixr$ds,
+ TIME = ds_nlmixr$time,
+ AMT = 0, EVID = 0,
+ CMT = ds_nlmixr$variable,
+ DV = ds_nlmixr$observed,
+ stringsAsFactors = FALSE)
+
+ return(ds_nlmixr_renamed)
+}

Contact - Imprint