nlmixr2 / nlmixr2extra Goto Github PK

Extra utilities for nlmixr objects

Home Page: https://nlmixr2.github.io/nlmixr2extra/

License: GNU General Public License v3.0

R 98.37% C++ 1.01% C 0.29% Makefile 0.09% Shell 0.25%

nlmixr2extra's Issues

Duplicated code

While trying to fix the random CI failures in nlmixr2/nlmixr2#68, I found that the issue seemed to come from memory issues related to building the bootstrap documentation. When looking at the bootstrap documentation, I noticed that there is a lot of nearly identical code in bootstrap.R and computingutil.R. Given the fact that they are nearly the same but not the same, I'm not sure which is preferred. @mattfidler, can you please take a look and remove one of them:

nlmixr2extra/R/bootstrap.R

Lines 1 to 1238 in c13dc98

 #' Format confidence bounds for a variable into bracketed notation using string formatting 

 #' 

 #' @param var a list of values for the varaible 

 #' @param confLower the lower bounds for each of the values 

 #' @param confUpper the upper bounds for each of the values 

 #' @param sigdig the number of significant digits 

 #' 

 #' @author Vipul Mann 

 #' 

 #' @noRd 

 addConfboundsToVar <- 

 function(var, confLower, confUpper, sigdig = 3) { 

 res <- lapply(seq_along(var), function(idx) { 

 paste0( 

 signif(var[idx], sigdig), 

 " (", 

 signif(confLower[idx], sigdig), 

 ", ", 

 signif(confUpper[idx], sigdig), 

 ")" 

 ) 

 }) 

 unlist(res) 

 } 

 .buildModel <- function() { 

 .owd <- getwd() 

 on.exit(setwd(.owd)) 

 try(source(file.path(devtools::package_file(), "build", "build.R"))) 

 "" 

 } 

 #' Bootstrap nlmixr2 fit 

 #' 

 #' Bootstrap input dataset and rerun the model to get confidence bounds and aggregated parameters 

 #' 

 #' @param fit the nlmixr2 fit object 

 #' 

 #' @param nboot an integer giving the number of bootstrapped models to 

 #' be fit; default value is 200 

 #' 

 #' @param nSampIndiv an integer specifying the number of samples in 

 #' each bootstrapped sample; default is the number of unique 

 #' subjects in the original dataset 

 #' 

 #' @param stratVar Variable in the original dataset to stratify on; 

 #' This is useful to distinguish between sparse and full sampling 

 #' and other features you may wish to keep distinct in your 

 #' bootstrap 

 #' 

 #' @param pvalues a vector of pvalues indicating the probability of 

 #' each subject to get selected; default value is NULL implying that 

 #' probability of each subject is the same 

 #' 

 #' @param restart a boolean that indicates if a previous session has 

 #' to be restarted; default value is FALSE 

 #' 

 #' @param fitName Name of fit to be saved (by default the variable name supplied to fit) 

 #' 

 #' @param stdErrType This gives the standard error type for the 

 #' updated standard errors; The current possibilities are: 

 #' `"perc"` which gives the standard errors by percentiles 

 #' (default) or `"se"` which gives the standard errors by the 

 #' traditional formula. 

 #' 

 #' @param ci Confidence interval level to calculate. Default is 0.95 

 #' for a 95 percent confidence interval 

 #' 

 #' @param plotHist A boolean indicating if a histogram plot to assess 

 #' how well the bootstrap is doing. By default this is turned off (`FALSE`) 

 #' 

 #' @param pvalues a vector of pvalues indicating the probability of 

 #' each subject to get selected; default value is `NULL` implying that 

 #' probability of each subject is the same 

 #' 

 #' @param restart A boolean to try to restart an interrupted or 

 #' incomplete boostrap. By default this is `FALSE` 

 #' 

 #' @param fitName is the fit name that is used for the name of the 

 #' boostrap files. By default it is the fit provided though it 

 #' could be something else. 

 #' 

 #' 

 #' @author Vipul Mann, Matthew Fidler 

 #' 

 #' @return Nothing, called for the side effects; The original fit is 

 #' updated with the bootstrap confidence bands 

 #' 

 #' @eval .buildModel() 

 #' 

 #' @export 

 #' 

 #' @examples 

 #' 

 #' \donttest{ 

 #' 

 #' one.cmt <- function() { 

 #' ini({ 

 #' ## You may label each parameter with a comment 

 #' tka <- 0.45 # Log Ka 

 #' tcl <- 1 # Log Cl 

 #' ## This works with interactive models 

 #' ## You may also label the preceding line with label("label text") 

 #' tv <- 3.45 

 #' label("log V") 

 #' ## the label("Label name") works with all models 

 #' eta.ka ~ 0.6 

 #' eta.cl ~ 0.3 

 #' eta.v ~ 0.1 

 #' add.sd <- 0.7 

 #' }) 

 #' model({ 

 #' ka <- exp(tka + eta.ka) 

 #' cl <- exp(tcl + eta.cl) 

 #' v <- exp(tv + eta.v) 

 #' linCmt() ~ add(add.sd) 

 #' }) 

 #' } 

 #' 

 #' fit <- nlmixr2(one.cmt, nlmixr2data::theo_sd, "focei") 

 #' 

 #' withr::with_tempdir({ # Run example in temp dir 

 #' 

 #' bootstrapFit(fit, nboot = 5, restart = TRUE) # overwrites any of the existing data or model files 

 #' bootstrapFit(fit, nboot = 7) # resumes fitting using the stored data and model files 

 #' 

 #' # Note this resumes because the total number of bootstrap samples is not 50 

 #' 

 #' bootstrapFit(fit, nboot=50) 

 #' 

 #' # Note the boostrap standard error and variance/covariance matrix is retained. 

 #' # If you wish to switch back you can change the covariance matrix by 

 #' 

 #' nlmixr2est::setCov(fit,"r,s") 

 #' 

 #' # And change it back again 

 #' 

 #' nlmixr2est::setCov(fit,"boot50") 

 #' 

 #' # This change will affect any simulations with uncertainty in their parameters 

 #' 

 #' # You may also do a chi-square diagnostic plot check for the bootstrap with 

 #' 

 #' bootplot(fit) 

 #' 

 #' }) 

 #' 

 #' } 

 bootstrapFit <- function(fit, 

 nboot = 200, 

 nSampIndiv, 

 stratVar, 

 stdErrType = c("perc", "se"), 

 ci = 0.95, 

 pvalues = NULL, 

 restart = FALSE, 

 plotHist = FALSE, 

 fitName = as.character(substitute(fit))) { 

 stdErrType <- match.arg(stdErrType) 

 if (missing(stdErrType)) { 

 stdErrType <- "perc" 

 } 

 if (!(ci < 1 && ci > 0)) { 

 stop("'ci' needs to be between 0 and 1", call. = FALSE) 

 } 

 if (missing(stratVar)) { 

 performStrat <- FALSE 

 } 

 else { 

 if (!(stratVar %in% colnames(nlme::getData(fit)))) { 

 cli::cli_alert_danger("{stratVar} not in data") 

 stop("aborting ...stratifying variable not in data", call. = FALSE) 

 } 

 performStrat <- TRUE 

 } 

 if (is.null(fit$bootstrapMd5)) { 

 bootstrapMd5 <- fit$md5 

 assign("bootstrapMd5", bootstrapMd5, envir = fit$env) 

 } 

 if (performStrat) { 

 resBootstrap <- 

 modelBootstrap( 

 fit, 

 nboot = nboot, 

 nSampIndiv = nSampIndiv, 

 stratVar = stratVar, 

 pvalues = pvalues, 

 restart = restart, 

 fitName = fitName 

 ) # multiple models 

 modelsList <- resBootstrap[[1]] 

 fitList <- resBootstrap[[2]] 

 } 

 else { 

 resBootstrap <- 

 modelBootstrap( 

 fit, 

 nboot = nboot, 

 nSampIndiv = nSampIndiv, 

 pvalues = pvalues, 

 restart = restart, 

 fitName = fitName 

 ) # multiple models 

 modelsList <- resBootstrap[[1]] 

 fitList <- resBootstrap[[2]] 

 } 

 bootSummary <- 

 getBootstrapSummary(modelsList, ci, stdErrType) # aggregate values/summary 

 # modify the fit object 

 nrws <- nrow(bootSummary$parFixedDf$mean) 

 sigdig <- fit$control$sigdigTable 

 newParFixedDf <- fit$parFixedDf 

 newParFixed <- fit$parFixed 

 # Add Estimate_boot 

 est <- unname(bootSummary$parFixedDf$mean[1:nrws, 1]) 

 cLower <- unname(bootSummary$parFixedDf$confLower[1:nrws, 1]) 

 cUpper <- unname(bootSummary$parFixedDf$confUpper[1:nrws, 1]) 

 estEst <- est 

 estimateBoot <- addConfboundsToVar(est, cLower, cUpper, sigdig) 

 # Add SE_boot 

 seBoot <- unname(bootSummary$parFixedDf$stdDev[1:nrws, 1]) 

 # Add Back-transformed 

 est <- unname(bootSummary$parFixedDf$mean[1:nrws, 2]) 

 cLowerBT <- unname(bootSummary$parFixedDf$confLower[1:nrws, 2]) 

 cUpperBT <- unname(bootSummary$parFixedDf$confUpper[1:nrws, 2]) 

 backTransformed <- 

 addConfboundsToVar(est, cLowerBT, cUpperBT, sigdig) 

 estBT <- est 

 newParFixedDf["Bootstrap Estimate"] <- estEst 

 newParFixedDf["Bootstrap SE"] <- seBoot 

 newParFixedDf["Bootstrap %RSE"] <- seBoot / estEst * 100 

 newParFixedDf["Bootstrap CI Lower"] <- cLowerBT 

 newParFixedDf["Bootstrap CI Upper"] <- cUpperBT 

 newParFixedDf["Bootstrap Back-transformed"] <- estBT 

 newParFixed["Bootstrap Estimate"] <- estimateBoot 

 newParFixed["Bootstrap SE"] <- signif(seBoot, sigdig) 

 newParFixed["Bootstrap %RSE"] <- 

 signif(seBoot / estEst * 100, sigdig) 

 .w <- which(regexpr("^Bootstrap +Back[-]transformed", names(newParFixed)) != -1) 

 if (length(.w) >= 1) newParFixed <- newParFixed[, -.w] 

 newParFixed[sprintf("Bootstrap Back-transformed(%s%%CI)", ci * 100)] <- 

 backTransformed 

 # compute bias 

 bootParams <- bootSummary$parFixedDf$mean 

 origParams <- data.frame(list("Estimate" = fit$parFixedDf$Estimate, "Back-transformed" = fit$parFixedDf$`Back-transformed`)) 

 bootstrapBiasParfixed <- abs(origParams - bootParams) 

 bootstrapBiasOmega <- abs(fit$omega - bootSummary$omega$mean) 

 assign("bootBiasParfixed", bootstrapBiasParfixed, envir = fit$env) 

 assign("bootBiasOmega", bootstrapBiasOmega, envir = fit$env) 

 assign("bootCovMatrix", bootSummary$omega$covMatrix, envir = fit$env) 

 assign("bootCorMatrix", bootSummary$omega$corMatrix, envir = fit$env) 

 assign("parFixedDf", newParFixedDf, envir = fit$env) 

 assign("parFixed", newParFixed, envir = fit$env) 

 assign("bootOmegaSummary", bootSummary$omega, envir = fit$env) 

 assign("bootSummary", bootSummary, envir = fit$env) 

 # plot histogram 

 if (plotHist) { 

 # compute delta objf values for each of the models 

 origData <- nlme::getData(fit) 

 if (is.null(fit$bootstrapMd5)) { 

 bootstrapMd5 <- fit$md5 

 assign("bootstrapMd5", bootstrapMd5, envir = fit$env) 

 } 

 # already exists 

 output_dir <- paste0("nlmixr2BootstrapCache_", fitName, "_", fit$bootstrapMd5) 

 deltOBJFloaded <- NULL 

 deltOBJF <- NULL 

 rxode2::rxProgress(length(fitList)) 

 cli::cli_h1("Loading/Calculating \u0394 Objective function") 

 nlmixr2est::setOfv(fit, "focei") # Make sure we are using focei objective function 

 deltOBJF <- lapply(seq_along(fitList), function(i) { 

 x <- readRDS(file.path(output_dir, paste0("fitEnsemble_", i, ".rds"))) 

 .path <- file.path(output_dir, paste0("posthoc_", i, ".rds")) 

 if (file.exists(.path)) { 

 xPosthoc <- readRDS(.path) 

 rxode2::rxTick() 

 } else { 

 rxode2::rxProgressStop() 

 ## rxode2::rxProgressAbort("Starting to posthoc estimates") 

 ## Don't calculate the tables 

 .msg <- paste0(gettext("Running bootstrap estimates on original data for model index: "), i) 

 cli::cli_h1(.msg) 

 xPosthoc <- nlmixr2(x, 

 data = origData, est = "posthoc", 

 control = list(calcTables = FALSE, print = 1, compress=FALSE) 

 ) 

 saveRDS(xPosthoc, .path) 

 } 

 xPosthoc$objf - fit$objf 

 }) 

 rxode2::rxProgressStop() 

 .deltaO <- sort(abs(unlist(deltOBJF))) 

 .deltaN <- length(.deltaO) 

 .df <- length(fit$ini$est) 

 .chisq <- rbind( 

 data.frame( 

 deltaofv = qchisq(seq(0, 0.99, 0.01), df = .df), 

 quantiles = seq(0, 0.99, 0.01), 

 Distribution = 1L, 

 stringsAsFactors = FALSE 

 ), 

 data.frame( 

 deltaofv = .deltaO, 

 quantiles = seq(.deltaN) / .deltaN, 

 Distribution = 2L, 

 stringsAsFactors = FALSE 

 ) 

 ) 

 .fdelta <- approxfun(seq(.deltaN) / .deltaN, .deltaO) 

 .df2 <- round(mean(.deltaO, na.rm = TRUE)) 

 .dfD <- data.frame( 

 label = paste(c("df\u2248", "df="), c(.df2, .df)), 

 Distribution = c(2L, 1L), 

 quantiles = 0.7, 

 deltaofv = c(.fdelta(0.7), qchisq(0.7, df = .df)) 

 ) 

 .dfD$Distribution <- factor( 

 .dfD$Distribution, c(1L, 2L), 

 c("Reference distribution", "\u0394 objective function") 

 ) 

 .chisq$Distribution <- factor( 

 .chisq$Distribution, c(1L, 2L), 

 c("Reference distribution", "\u0394 objective function") 

 ) 

 .dataList <- list( 

 dfD = .dfD, chisq = .chisq, 

 deltaN = .deltaN, df2 = .df2 

 ) 

 assign(".bootPlotData", .dataList, envir = fit$env) 

 } 

 ## Update covariance estimate 

 .nm <- names(fit$theta)[!fit$foceiSkipCov[seq_along(fit$theta)]] 

 .cov <- fit$bootSummary$omega$covMatrixCombined[.nm, .nm] 

 .setCov(fit, covMethod = .cov) 

 assign("covMethod", paste0("boot", fit$bootSummary$nboot), fit$env) 

 invisible(fit) 

 } 

 #' Perform bootstrap-sampling from a given dataframe 

 #' 

 #' @param data the original dataframe object to sample from for bootstrapping 

 #' 

 #' @param nsamp an integer specifying the number of samples in each 

 #' bootstrapped sample; default is the number of unique subjects in 

 #' the original dataset 

 #' 

 #' @param uid_colname a string representing the unique ID of each 

 #' subject in the data; default values is 'ID' 

 #' 

 #' @param pvalues a vector of pvalues indicating the probability of 

 #' each subject to get selected; default value is NULL implying that 

 #' probability of each subject is the same 

 #' 

 #' @return returns a bootstrap sampled dataframe object 

 #' @author Vipul Mann, Matthew Fidler 

 #' 

 #' @examples 

 #' sampling(data) 

 #' sampling(data, 10) 

 #' @noRd 

 sampling <- function(data, 

 nsamp, 

 uid_colname, 

 pvalues = NULL, 

 performStrat = FALSE, 

 stratVar) { 

 checkmate::assert_data_frame(data) 

 if (missing(nsamp)) { 

 nsamp <- length(unique(data[, uid_colname])) 

 } 

 else { 

 checkmate::assert_integerish(nsamp, 

 len = 1, 

 any.missing = FALSE, 

 lower = 2 

 ) 

 } 

 if (performStrat && missing(stratVar)) { 

 print("stratVar is required for stratifying") 

 stop("aborting... stratVar not specified", call. = FALSE) 

 } 

 checkmate::assert_integerish(nsamp, 

 lower = 2, 

 len = 1, 

 any.missing = FALSE 

 ) 

 if (missing(uid_colname)) { 

 # search the dataframe for a column name of 'ID' 

 colNames <- colnames(data) 

 colNamesLower <- tolower(colNames) 

 if ("id" %in% colNames) { 

 uid_colname <- colNames[which("id" %in% colNamesLower)] 

 } 

 else { 

 uid_colname <- "ID" 

 } 

 } 

 else { 

 checkmate::assert_character(uid_colname) 

 } 

 if (performStrat) { 

 stratLevels <- 

 as.character(unique(data[, stratVar])) # char to access freq. values 

 dataSubsets <- lapply(stratLevels, function(x) { 

 data[data[, stratVar] == x, ] 

 }) 

 names(dataSubsets) <- stratLevels 

 tab <- table(data[stratVar]) 

 nTab <- sum(tab) 

 sampledDataSubsets <- lapply(names(dataSubsets), function(x) { 

 dat <- dataSubsets[[x]] 

 uids <- unique(dat[, uid_colname]) 

 uids_samp <- sample( 

 list(uids), 

 size = ceiling(nsamp * unname(tab[x]) / nTab), 

 replace = TRUE, 

 prob = pvalues 

 ) 

 sampled_df <- 

 data.frame(dat)[0, ] # initialize an empty dataframe with the same col names 

 # populate dataframe based on sampled uids 

 # new_id = 1 

 .env <- environment() 

 .env$new_id <- 1 

 do.call(rbind, lapply(uids_samp, function(u) { 

 data_slice <- dat[dat[, uid_colname] == u, ] 

 start <- NROW(sampled_df) + 1 

 end <- start + NROW(data_slice) - 1 

 data_slice[uid_colname] <- 

 .env$new_id # assign a new ID to the sliced dataframe 

 .env$new_id <- .env$new_id + 1 

 data_slice 

 })) 

 }) 

 do.call("rbind", sampledDataSubsets) 

 } 

 else { 

 uids <- unique(data[, uid_colname]) 

 uids_samp <- sample(uids, 

 size = nsamp, 

 replace = TRUE, 

 prob = pvalues 

 ) 

 sampled_df <- 

 data.frame(data)[0, ] # initialize an empty dataframe with the same col names 

 # populate dataframe based on sampled uids 

 # new_id = 1 

 .env <- environment() 

 .env$new_id <- 1 

 do.call(rbind, lapply(uids_samp, function(u) { 

 data_slice <- data[data[, uid_colname] == u, ] 

 start <- NROW(sampled_df) + 1 

 end <- start + NROW(data_slice) - 1 

 data_slice[uid_colname] <- 

 .env$new_id # assign a new ID to the sliced dataframe 

 .env$new_id <- .env$new_id + 1 

 data_slice 

 })) 

 } 

 } 

 #' Fitting multiple bootstrapped models without aggregaion; called by the function bootstrapFit() 

 #' 

 #' @param fit the nlmixr2 fit object 

 #' @param nboot an integer giving the number of bootstrapped models to be fit; default value is 100 

 #' @param nSampIndiv an integer specifying the number of samples in each bootstrapped sample; default is the number of unique subjects in the original dataset 

 #' @param pvalues a vector of pvalues indicating the probability of each subject to get selected; default value is NULL implying that probability of each subject is the same 

 #' @param restart a boolean that indicates if a previous session has to be restarted; default value is FALSE 

 #' 

 #' @return a list of lists containing the different attributed of the fit object for each of the bootstrapped models 

 #' @author Vipul Mann, Matthew Fidler 

 #' @examples 

 #' modelBootstrap(fit) 

 #' modelBootstrap(fit, 5) 

 #' modelBootstrap(fit, 5, 20) 

 #' @noRd 

 modelBootstrap <- function(fit, 

 nboot = 100, 

 nSampIndiv, 

 stratVar, 

 pvalues = NULL, 

 restart = FALSE, 

 fitName = "fit") { 

 nlmixr2est::assertNlmixrFit(fit) 

 if (missing(stratVar)) { 

 performStrat <- FALSE 

 stratVar <- NULL 

 } else { 

 performStrat <- TRUE 

 } 

 data <- nlme::getData(fit) 

 .w <- tolower(names(data)) == "id" 

 uidCol <- names(data)[.w] 

 checkmate::assert_integerish(nboot, 

 len = 1, 

 any.missing = FALSE, 

 lower = 1 

 ) 

 if (missing(nSampIndiv)) { 

 nSampIndiv <- length(unique(data[, uidCol])) 

 } 

 else { 

 checkmate::assert_integerish( 

 nSampIndiv, 

 len = 1, 

 any.missing = FALSE, 

 lower = 2 

 ) 

 } 

 # infer the ID column from data 

 colNames <- names(data) 

 colNamesLower <- tolower(colNames) 

 if ("id" %in% colNamesLower) { 

 uid_colname <- colNames[which("id" %in% colNamesLower)] 

 } 

 else { 

 stop("cannot find the 'ID' column! aborting ...", call. = FALSE) 

 } 

 ui <- fit$finalUiEnv 

 fitMeth <- getFitMethod(fit) 

 bootData <- vector(mode = "list", length = nboot) 

 if (is.null(fit$bootstrapMd5)) { 

 bootstrapMd5 <- fit$md5 

 assign("bootstrapMd5", bootstrapMd5, envir = fit$env) 

 } 

 output_dir <- 

 paste0("nlmixr2BootstrapCache_", fitName, "_", fit$bootstrapMd5) # a new directory with this name will be created 

 if (!dir.exists(output_dir)) { 

 dir.create(output_dir) 

 } else if (dir.exists(output_dir) && restart == TRUE) { 

 unlink(output_dir, recursive = TRUE, force = TRUE) # unlink any of the previous directories 

 dir.create(output_dir) # create a fresh directory 

 } 

 fnameBootDataPattern <- 

 paste0("boot_data_", "[0-9]+", ".rds", 

 sep = "" 

 ) 

 fileExists <- 

 list.files(paste0("./", output_dir), pattern = fnameBootDataPattern) 

 if (length(fileExists) == 0) { 

 restart <- TRUE 

 } 

 if (!restart) { 

 # read saved bootData from boot_data files on disk 

 if (length(fileExists) > 0) { 

 cli::cli_alert_success("resuming bootstrap data sampling using data at {paste0('./', output_dir)}") 

 bootData <- lapply(fileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 startCtr <- length(bootData) + 1 

 } else { 

 cli::cli_alert_danger( 

 cli::col_red( 

 "need the data files at {.file {paste0(getwd(), '/', output_dir)}} to resume" 

 ) 

 ) 

 stop("aborting...resume file missing", call. = FALSE) 

 } 

 } else { 

 startCtr <- 1 

 } 

 # Generate additional samples (if nboot>startCtr) 

 if (nboot >= startCtr) { 

 for (mod_idx in startCtr:nboot) { 

 bootData[[mod_idx]] <- sampling( 

 data, 

 nsamp = nSampIndiv, 

 uid_colname = uidCol, 

 pvalues = pvalues, 

 performStrat = performStrat, 

 stratVar = stratVar 

 ) 

 # save bootData in curr directory: read the file using readRDS() 

 attr(bootData, "randomSeed") <- .Random.seed 

 saveRDS(bootData[[mod_idx]], 

 file = paste0( 

 "./", 

 output_dir, 

 "/boot_data_", 

 mod_idx, 

 ".rds")) 

 } 

 } 

 # check if number of samples in stored file is the same as the required number of samples 

 fileExists <- 

 list.files(paste0("./", output_dir), pattern = fnameBootDataPattern) 

 bootData <- lapply(fileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 currBootData <- length(bootData) 

 # Fitting models to bootData now 

 .env <- environment() 

 fnameModelsEnsemblePattern <- 

 paste0("modelsEnsemble_", "[0-9]+", 

 ".rds", 

 sep = "") 

 modFileExists <- 

 list.files(paste0("./", output_dir), pattern = fnameModelsEnsemblePattern) 

 fnameFitEnsemblePattern <- 

 paste0("fitEnsemble_", "[0-9]+", 

 ".rds", 

 sep = "") 

 fitFileExists <- list.files(paste0("./", output_dir), pattern = fnameFitEnsemblePattern) 

 if (!restart) { 

 if (length(modFileExists) > 0 && 

 (length(fileExists) > 0)) { 

 # read bootData and modelsEnsemble files from disk 

 cli::cli_alert_success( 

 "resuming bootstrap model fitting using data and models stored at {paste0(getwd(), '/', output_dir)}" 

 ) 

 bootData <- lapply(fileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 modelsEnsembleLoaded <- lapply(modFileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 fitEnsembleLoaded <- lapply(fitFileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 .env$mod_idx <- length(modelsEnsembleLoaded) + 1 

 currNumModels <- .env$mod_idx - 1 

 if (currNumModels > nboot) { 

 modIdx <- .env$mod_idx-1 

 cli::cli_alert_danger( 

 cli::col_red( 

 paste0("the model file already has ", modIdx, 

 " models when max models is ", nboot, 

 "; using only the first ", nboot, 

 "model(s)" 

 )) 

 ) 

 return(list(modelsEnsembleLoaded[1:nboot], fitEnsembleLoaded[1:nboot])) 

 # return(modelsEnsembleLoaded[1:nboot]) 

 } 

 else if (currNumModels == nboot) { 

 modIdx <- .env$mod_idx-1 

 cli::col_red( 

 paste0("the model file already has ", 

 modIdx-1, 

 " models when max models is ", 

 nboot, "; loading from ", 

 nboot, " models already saved on disk") 

 ) 

 return(list(modelsEnsembleLoaded, fitEnsembleLoaded)) 

 # return(modelsEnsembleLoaded) 

 } 

 else if (currNumModels < nboot) { 

 cli::col_red("estimating the additional models ... ") 

 } 

 } 

 else { 

 cli::cli_alert_danger( 

 cli::col_red( 

 "need both the data and the model files at: {paste0(getwd(), '/', output_dir)} to resume" 

 ) 

 ) 

 stop( 

 "aborting...data and model files missing at: {paste0(getwd(), '/', output_dir)}", 

 call. = FALSE 

 ) 

 } 

 } 

 else { 

 .env$mod_idx <- 1 

 } 

 # get control settings for the 'fit' object and save computation effort by not computing the tables 

 .ctl <- fit$control 

 .ctl$print <- 0L 

 .ctl$covMethod <- 0L 

 .ctl$calcTables <- FALSE 

 .ctl$compress <- FALSE 

 modelsEnsemble <- 

 lapply(bootData[.env$mod_idx:nboot], function(boot_data) { 

 modIdx <- .env$mod_idx 

 cli::cli_h1(paste0("Running nlmixr2 for model index: ", modIdx)) 

 fit <- tryCatch( 

 { 

 fit <- suppressWarnings(nlmixr2(ui, 

 boot_data, 

 est = fitMeth, 

 control = .ctl)) 

 .env$multipleFits <- list( 

 # objf = fit$OBJF, 

 # aic = fit$AIC, 

 omega = fit$omega, 

 parFixedDf = fit$parFixedDf[, c("Estimate", "Back-transformed")], 

 message = fit$message, 

 warnings = fit$warnings) 

 fit # to return 'fit' 

 }, 

 error = function(error_message) { 

 message("error fitting the model") 

 message(error_message) 

 message("storing the models as NA ...") 

 return(NA) # return NA otherwise (instead of NULL) 

 }) 

 saveRDS( 

 .env$multipleFits, 

 file = paste0( 

 "./", 

 output_dir, 

 "/modelsEnsemble_", 

 .env$mod_idx, 

 ".rds")) 

 saveRDS( 

 fit, 

 file = paste0( 

 "./", 

 output_dir, 

 "/fitEnsemble_", 

 .env$mod_idx, 

 ".rds" 

 ) 

 ) 

 assign("mod_idx", .env$mod_idx + 1, .env) 

 }) 

 fitEnsemble <- NULL 

 if (!restart) { 

 modelsEnsemble <- c(modelsEnsembleLoaded, modelsEnsemble) 

 fitEnsemble <- c(fitEnsembleLoaded, fitEnsemble) 

 } 

 modFileExists <- 

 list.files(paste0("./", output_dir), pattern = fnameModelsEnsemblePattern) 

 modelsEnsemble <- lapply(modFileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 fitFileExists <- list.files(paste0("./", output_dir), pattern = fnameFitEnsemblePattern) 

 fitEnsemble <- lapply(fitFileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 list(modelsEnsemble, fitEnsemble) 

 } 

 #' Get the nlmixr2 method used for fitting the model 

 #' 

 #' @param fit the nlmixr2 fit object 

 #' 

 #' @return returns a string representing the method used by nlmixr2 for fitting the given model 

 #' 

 #' @author Vipul Mann, Matthew Fidler 

 #' 

 #' @examples 

 #' getFitMethod(fit) 

 #' @noRd 

 getFitMethod <- function(fit) { 

 if (!(inherits(fit, "nlmixr2FitCore"))) { 

 stop("'fit' needs to be a nlmixr2 fit", call. = FALSE) 

 } 

 fit$est 

 } 

 #' Extract all the relevant variables from a set of bootstrapped models 

 #' 

 #' @param fitlist a list of lists containing information on the multiple bootstrapped models; similar to the output of modelsBootstrap() function 

 #' @param id a character representing the variable of interest: OBJF, AIC, omega, parFixedDf, method, message, warnings 

 #' 

 #' @return returns a vector or list across of the variable of interest from all the fits/bootstrapped models 

 #' 

 #' @author Vipul Mann, Matthew Fidler 

 #' @examples 

 #' extractVars(fitlist, 1) # returns a vector of OBJF values 

 #' extractVars(fitlist, 4) # returns a list of dataframes containing parFixedDf values 

 #' @noRd 

 extractVars <- function(fitlist, id = "method") { 

 if (id == "method") { 

 # no lapply for 'method' 

 unlist(unname(fitlist[[1]][id])) 

 } 

 else { 

 # if id not equal to 'method' 

 res <- lapply(fitlist, function(x) { 

 x[[id]] 

 }) 

 if (!(id == "omega" || 

 id == "parFixedDf")) { 

 # check if all message strings are empty 

 if (id == "message") { 

 prev <- TRUE 

 for (i in length(res)) { 

 status <- (res[[i]] == "") && prev 

 prev <- status 

 } 

 if (status == TRUE) { 

 c("") 

 } 

 else { 

 # if non-empty 'message' 

 unlist(res) 

 } 

 } 

 else { 

 # if id does not equal 'message' 

 unlist(res) 

 } 

 } 

 else { 

 # if id equals 'omega' or 'parFixedDf 

 res 

 } 

 } 

 } 

 #' Summarize the bootstrapped fits/models 

 #' 

 #' @param fitList a list of lists containing information on the multiple bootstrapped models; similar to the output of modelsBootstrap() function 

 #' @return returns aggregated quantities (mean, median, standard deviation, and variance) as a list for all the quantities 

 #' @author Vipul Mann, Matthew Fidler 

 #' @examples 

 #' getBootstrapSummary(fitlist) 

 #' @noRd 

 getBootstrapSummary <- 

 function(fitList, 

 ci = 0.95, 

 stdErrType = "perc") { 

 if (!(ci < 1 && ci > 0)) { 

 stop("'ci' needs to be between 0 and 1", call. = FALSE) 

 } 

 quantLevels <- 

 c(0.5, (1 - ci) / 2, 1 - (1 - ci) / 2) # median, (1-ci)/2, 1-(1-ci)/2 

 varIds <- 

 names(fitList[[1]]) # number of different variables present in fitlist 

 summaryList <- lapply(varIds, function(id) { 

 # if (!(id %in% c("omega", "parFixedDf", "method", "message", "warnings"))) { 

 # varVec <- extractVars(fitList, id) 

 # mn <- mean(varVec) 

 # median <- median(varVec) 

 # sd <- sd(varVec) 

 # 

 # c( 

 # mean = mn, 

 # median = median, 

 # stdDev = sd 

 # ) 

 # } 

 if (id == "omega") { 

 # omega estimates 

 omegaMatlist <- extractVars(fitList, id) 

 varVec <- simplify2array(omegaMatlist) 

 mn <- apply(varVec, 1:2, mean) 

 sd <- apply(varVec, 1:2, sd) 

 quants <- apply(varVec, 1:2, function(x) { 

 unname(quantile(x, quantLevels)) 

 }) 

 median <- quants[1, , ] 

 confLower <- quants[2, , ] 

 confUpper <- quants[3, , ] 

 if (stdErrType != "perc") { 

 confLower <- mn - qnorm(quantLevels[[2]]) * sd 

 confUpper <- mn + qnorm(quantLevels[[3]]) * sd 

 } 

 # computing the covariance and correlation matrices 

 # ======================================================= 

 parFixedOmegaBootVec <- list() 

 parFixedlist <- extractVars(fitList, id = "parFixedDf") 

 parFixedlistVec <- lapply(parFixedlist, function(x) { 

 x$Estimate 

 }) 

 parFixedlistVec <- do.call("rbind", parFixedlistVec) 

 omgVecBoot <- list() 

 omegaIdx <- seq(length(omegaMatlist)) 

 omgVecBoot <- lapply(omegaIdx, function(idx) { 

 omgMat <- omegaMatlist[[idx]] 

 omgVec <- omgMat[lower.tri(omgMat, TRUE)] 

 omgVecBoot[[idx]] <- omgVec 

 }) 

 omgVecBoot <- do.call("rbind", omgVecBoot) 

 idxName <- 1 

 namesList <- list() 

 for (nam1 in colnames(omegaMatlist[[1]])) { 

 for (nam2 in colnames(omegaMatlist[[1]])) { 

 if (nam1 == nam2) { 

 if (!(nam1 %in% namesList)) { 

 namesList[idxName] <- nam1 

 idxName <- idxName + 1 

 } 

 } else { 

 nam <- paste0("(", nam1, ",", nam2, ")") 

 namRev <- paste0("(", nam2, ",", nam1, ")") 

 if (!(nam %in% namesList | namRev %in% namesList)) { 

 namesList[idxName] <- nam 

 idxName <- idxName + 1 

 } 

 } 

 } 

 } 

 colnames(omgVecBoot) <- namesList 

 .w <- which(sapply(namesList, function(x) { 

 !all(omgVecBoot[, x] == 0) 

 })) 

 omgVecBoot <- omgVecBoot[, .w] 

 parFixedOmegaCombined <- cbind(parFixedlistVec, omgVecBoot) 

 covMatrix <- cov(parFixedOmegaCombined) 

 corMatrix <- cov2cor(covMatrix) 

 diag(corMatrix) <- sqrt(diag(covMatrix)) 

 lst <- list( 

 mean = mn, 

 median = median, 

 stdDev = sd, 

 confLower = confLower, 

 confUpper = confUpper, 

 covMatrixCombined = covMatrix, 

 corMatrixCombined = corMatrix 

 ) 

 } 

 else if (id == "parFixedDf") { 

 # parameter estimates (dataframe) 

 varVec <- extractVars(fitList, id) 

 mn <- 

 apply(simplify2array(lapply(varVec, as.matrix)), 1:2, mean, na.rm = TRUE) 

 sd <- 

 apply(simplify2array(lapply(varVec, as.matrix)), 1:2, sd, na.rm = TRUE) 

 quants <- 

 apply(simplify2array(lapply(varVec, as.matrix)), 1:2, function(x) { 

 unname(quantile(x, quantLevels, na.rm = TRUE)) 

 }) 

 median <- quants[1, , ] 

 confLower <- quants[2, , ] 

 confUpper <- quants[3, , ] 

 if (stdErrType != "perc") { 

 confLower <- mn - qnorm(quantLevels[[2]]) * sd 

 confUpper <- mn + qnorm(quantLevels[[3]]) * sd 

 } 

 lst <- list( 

 mean = mn, 

 median = median, 

 stdDev = sd, 

 confLower = confLower, 

 confUpper = confUpper 

 ) 

 } 

 else { 

 # if id equals method, message, or warning 

 extractVars(fitList, id) 

 } 

 }) 

 names(summaryList) <- varIds 

 summaryList$nboot <- length(fitList) 

 summaryList$warnings <- unique(summaryList$warnings) 

 summaryList$message <- unique(summaryList$message) 

 class(summaryList) <- "nlmixr2BoostrapSummary" 

 summaryList 

 } 

 #' @export 

 print.nlmixr2BoostrapSummary <- function(x, ..., sigdig = NULL) { 

 if (is.null(sigdig)) { 

 if (any(names(x) == "sigdig")) { 

 sigdig <- x$sigdig 

 } else { 

 sigdig <- 3 

 } 

 } 

 # objf <- x$objf 

 # aic <- x$aic 

 message <- x$message 

 warnings <- x$warnings 

 omega <- x$omega 

 parFixedDf <- x$parFixedDf 

 nboot <- x$nboot 

 cli::cli_h1( 

 cli::col_red( 

 "Summary of the bootstrap models (nboot: {nboot})" 

 ) 

 ) 

 cli::cli_li(cli::col_magenta( 

 cli::style_bold( 

 "Omega matrices: mean, median, standard deviation, and confidence bousnds" 

 ), 

 cli::col_yellow(" (summary$omega)") 

 )) 

 lapply(seq_along(omega), function(x) { 

 cli::cli_text(cli::col_green(paste0("$", names(omega)[x]))) 

 print(signif(omega[[x]], sigdig)) 

 }) 

 cli::cli_li(cli::col_magenta( 

 cli::style_bold( 

 "Estimated parameters: mean, median, standard deviation, and confidence bounds" 

 ), 

 cli::col_yellow(" (summary$parFixedDf)") 

 )) 

 lapply(seq_along(parFixedDf), function(x) { 

 cli::cli_text(cli::col_yellow(paste0("$", names(parFixedDf)[x]))) 

 print(signif(parFixedDf[[x]], sigdig)) 

 }) 

 cli::cli_li(cli::cli_text( 

 cli::bg_yellow(cli::style_bold("Messages")), 

 cli::col_yellow(" (summary$message)") 

 )) 

 print(message) 

 cli::cli_li(cli::cli_text( 

 cli::bg_red(cli::style_bold(cli::col_white("Warnings"))), 

 cli::col_yellow(" (summary$warnings)") 

 )) 

 print(warnings) 

 cli::cli_h1("end") 

 invisible(x) 

 } 

 #' Assign a set of variables to the nlmixr2 fit environment 

 #' 

 #' @param namedVars a named list of variables that need to be assigned to the given environment 

 #' @param fitobject the nlmixr2 fit object that contains its environment information 

 #' @noRd 

 #' 

 assignToEnv <- function(namedVars, fitobject) { 

 if (!inherits(fitobject, "nlmixr2FitCore")) { 

 stop("'fit' needs to be a nlmixr2 fit", call. = FALSE) 

 } 

 if (is.null(names(namedVars))) { 

 stop("'namedVars needs to be a named list", call. = FALSE) 

 } 

 if (length(namedVars) != length(names(namedVars))) { 

 stop("'namedVars does not have all the elements named", call. = FALSE) 

 } 

 env <- fitobject$env 

 lapply(names(namedVars), function(x) { 

 assign(x, namedVars[[x]], envir = env) 

 }) 

 } 

 #' @title Produce delta objective function for boostrap 

 #' 

 #' @param x fit object 

 #' @param ... other parameters 

 #' @return Fit traceplot or nothing. 

 #' @author Vipul Mann, Matthew L. Fidler 

 #' @references 

 #' 

 #' R Niebecker, MO Karlsson. (2013) 

 #' *Are datasets for NLME models large enough for a bootstrap to provide reliable parameter uncertainty distributions?* 

 #' PAGE 2013. 

 #' <https://www.page-meeting.org/?abstract=2899> 

 #' 

 #' @export 

 bootplot <- function(x, ...) { 

 UseMethod("bootplot") 

 } 

 #' @rdname bootplot 

 #' @export 

 #' @importFrom ggplot2 .data 

 bootplot.nlmixr2FitCore <- function(x, ...) { 

 .fitName <- as.character(substitute(x)) 

 if (inherits(x, "nlmixr2FitCore")) { 

 if (exists("bootSummary", x$env) & (!exists(".bootPlotData", x$env))) { 

 bootstrapFit(x, x$bootSummary$nboot, plotHist = TRUE, fitName = .fitName) 

 } 

 if (exists(".bootPlotData", x$env)) { 

 if (x$bootSummary$nboot != x$env$.bootPlotData$deltaN) { 

 bootstrapFit(x, x$bootSummary$nboot, plotHist = TRUE, fitName = .fitName) 

 } 

 .chisq <- x$env$.bootPlotData$chisq 

 .dfD <- x$env$.bootPlotData$dfD 

 .deltaN <- x$env$.bootPlotData$deltaN 

 .df2 <- x$env$.bootPlotData$df2 

 .plot <- ggplot2::ggplot(.chisq, ggplot2::aes(.data$quantiles, .data$deltaofv, color = .data$Distribution)) + 

 ggplot2::geom_line() + 

 ggplot2::ylab("\u0394 objective function") + 

 ggplot2::geom_text(data = .dfD, ggplot2::aes(label = .data$label), hjust = 0) + 

 ggplot2::xlab("Distribution quantiles") + 

 ggplot2::scale_color_manual(values = c("red", "blue")) + 

 rxode2::rxTheme() + 

 ggplot2::theme(legend.position = "bottom", legend.box = "horizontal") 

 if (requireNamespace("ggtext", quietly = TRUE)) { 

 .plot <- .plot + 

 ggplot2::theme( 

 plot.title = ggtext::element_markdown(), 

 legend.position = "none" 

 ) + 

 ggplot2::labs( 

 title = paste0( 

 'Bootstrap <span style="color:blue; opacity: 0.2;">\u0394 objective function (', .deltaN, 

 " models, df\u2248", .df2, ')</span> vs <span style="color:red; opacity: 0.2;">reference \u03C7\u00B2(df=', 

 length(x$ini$est), ")</style>" 

 ), 

 caption = "\u0394 objective function curve should be on or below the reference distribution curve" 

 ) 

 } else { 

 .plot <- ggplot2::labs( 

 title = paste0("Distribution of \u0394 objective function values for ", .deltaN, " df=", .df2, " models"), 

 caption = "\u0394 objective function curve should be on or below the reference distribution curve" 

 ) 

 } 

 .plot 

 } else { 

 stop("this nlmixr2 object does not include boostrap distribution statics for comparison", 

 call. = FALSE 

 ) 

 } 

 } else { 

 stop("this is not a nlmixr2 object", 

 call. = FALSE 

 ) 

 } 

 }

nlmixr2extra/R/computingutil.R

Lines 296 to 1527 in c13dc98

 #' Format confidence bounds for a variable into bracketed notation using string formatting 

 #' 

 #' @param var a list of values for the varaible 

 #' @param confLower the lower bounds for each of the values 

 #' @param confUpper the upper bounds for each of the values 

 #' @param sigdig the number of significant digits 

 #' 

 #' @author Vipul Mann 

 #' 

 #' @noRd 

 addConfboundsToVar <- 

 function(var, confLower, confUpper, sigdig = 3) { 

 res <- lapply(seq_along(var), function(idx) { 

 paste0( 

 signif(var[idx], sigdig), 

 " (", 

 signif(confLower[idx], sigdig), 

 ", ", 

 signif(confUpper[idx], sigdig), 

 ")" 

 ) 

 }) 

 unlist(res) 

 } 

 #' Bootstrap nlmixr2 fit 

 #' 

 #' Bootstrap input dataset and rerun the model to get confidence bounds and aggregated parameters 

 #' 

 #' @param fit the nlmixr2 fit object 

 #' 

 #' @param nboot an integer giving the number of bootstrapped models to 

 #' be fit; default value is 200 

 #' 

 #' @param nSampIndiv an integer specifying the number of samples in 

 #' each bootstrapped sample; default is the number of unique 

 #' subjects in the original dataset 

 #' 

 #' @param stratVar Variable in the original dataset to stratify on; 

 #' This is useful to distinguish between sparse and full sampling 

 #' and other features you may wish to keep distinct in your 

 #' bootstrap 

 #' 

 #' @param pvalues a vector of pvalues indicating the probability of 

 #' each subject to get selected; default value is NULL implying that 

 #' probability of each subject is the same 

 #' 

 #' @param restart a boolean that indicates if a previous session has 

 #' to be restarted; default value is FALSE 

 #' 

 #' @param fitName Name of fit to be saved (by default the variable name supplied to fit) 

 #' 

 #' @param stdErrType This gives the standard error type for the 

 #' updated standard errors; The current possibilities are: 

 #' `"perc"` which gives the standard errors by percentiles 

 #' (default) or `"se"` which gives the standard errors by the 

 #' traditional formula. 

 #' 

 #' @param ci Confidence interval level to calculate. Default is 0.95 

 #' for a 95 percent confidence interval 

 #' 

 #' @param plotHist A boolean indicating if a histogram plot to assess 

 #' how well the bootstrap is doing. By default this is turned off (`FALSE`) 

 #' 

 #' @param pvalues a vector of pvalues indicating the probability of 

 #' each subject to get selected; default value is `NULL` implying that 

 #' probability of each subject is the same 

 #' 

 #' @param restart A boolean to try to restart an interrupted or 

 #' incomplete boostrap. By default this is `FALSE` 

 #' 

 #' @param fitName is the fit name that is used for the name of the 

 #' boostrap files. By default it is the fit provided though it 

 #' could be something else. 

 #' 

 #' 

 #' @author Vipul Mann, Matthew Fidler 

 #' 

 #' @return Nothing, called for the side effects; The original fit is 

 #' updated with the bootstrap confidence bands 

 #' 

 #' @export 

 #' 

 #' @examples 

 #' 

 #' \donttest{ 

 #' 

 #' one.cmt <- function() { 

 #' ini({ 

 #' ## You may label each parameter with a comment 

 #' tka <- 0.45 # Log Ka 

 #' tcl <- 1 # Log Cl 

 #' ## This works with interactive models 

 #' ## You may also label the preceding line with label("label text") 

 #' tv <- 3.45 

 #' label("log V") 

 #' ## the label("Label name") works with all models 

 #' eta.ka ~ 0.6 

 #' eta.cl ~ 0.3 

 #' eta.v ~ 0.1 

 #' add.sd <- 0.7 

 #' }) 

 #' model({ 

 #' ka <- exp(tka + eta.ka) 

 #' cl <- exp(tcl + eta.cl) 

 #' v <- exp(tv + eta.v) 

 #' linCmt() ~ add(add.sd) 

 #' }) 

 #' } 

 #' 

 #' fit <- nlmixr2(one.cmt, nlmixr2data::theo_sd, "focei") 

 #' 

 #' withr::with_tempdir({ # Run example in temp dir 

 #' 

 #' bootstrapFit(fit, nboot = 5, restart = TRUE) # overwrites any of the existing data or model files 

 #' bootstrapFit(fit, nboot = 7) # resumes fitting using the stored data and model files 

 #' 

 #' # Note this resumes because the total number of bootstrap samples is not 50 

 #' 

 #' bootstrapFit(fit, nboot=50) 

 #' 

 #' # Note the boostrap standard error and variance/covariance matrix is retained. 

 #' # If you wish to switch back you can change the covariance matrix by 

 #' 

 #' nlmixr2est::setCov(fit,"r,s") 

 #' 

 #' # And change it back again 

 #' 

 #' nlmixr2est::setCov(fit,"boot50") 

 #' 

 #' # This change will affect any simulations with uncertainty in their parameters 

 #' 

 #' # You may also do a chi-square diagnostic plot check for the bootstrap with 

 #' 

 #' bootplot(fit) 

 #' 

 #' }) 

 #' 

 #' } 

 bootstrapFit <- function(fit, 

 nboot = 200, 

 nSampIndiv, 

 stratVar, 

 stdErrType = c("perc", "se"), 

 ci = 0.95, 

 pvalues = NULL, 

 restart = FALSE, 

 plotHist = FALSE, 

 fitName = as.character(substitute(fit))) { 

 stdErrType <- match.arg(stdErrType) 

 if (missing(stdErrType)) { 

 stdErrType <- "perc" 

 } 

 if (!(ci < 1 && ci > 0)) { 

 stop("'ci' needs to be between 0 and 1", call. = FALSE) 

 } 

 if (missing(stratVar)) { 

 performStrat <- FALSE 

 } 

 else { 

 if (!(stratVar %in% colnames(nlme::getData(fit)))) { 

 cli::cli_alert_danger("{stratVar} not in data") 

 stop("aborting ...stratifying variable not in data", call. = FALSE) 

 } 

 performStrat <- TRUE 

 } 

 if (is.null(fit$bootstrapMd5)) { 

 bootstrapMd5 <- fit$md5 

 assign("bootstrapMd5", bootstrapMd5, envir = fit$env) 

 } 

 if (performStrat) { 

 resBootstrap <- 

 modelBootstrap( 

 fit, 

 nboot = nboot, 

 nSampIndiv = nSampIndiv, 

 stratVar = stratVar, 

 pvalues = pvalues, 

 restart = restart, 

 fitName = fitName 

 ) # multiple models 

 modelsList <- resBootstrap[[1]] 

 fitList <- resBootstrap[[2]] 

 } 

 else { 

 resBootstrap <- 

 modelBootstrap( 

 fit, 

 nboot = nboot, 

 nSampIndiv = nSampIndiv, 

 pvalues = pvalues, 

 restart = restart, 

 fitName = fitName 

 ) # multiple models 

 modelsList <- resBootstrap[[1]] 

 fitList <- resBootstrap[[2]] 

 } 

 bootSummary <- 

 getBootstrapSummary(modelsList, ci, stdErrType) # aggregate values/summary 

 # modify the fit object 

 nrws <- nrow(bootSummary$parFixedDf$mean) 

 sigdig <- fit$control$sigdigTable 

 newParFixedDf <- fit$parFixedDf 

 newParFixed <- fit$parFixed 

 # Add Estimate_boot 

 est <- unname(bootSummary$parFixedDf$mean[1:nrws, 1]) 

 cLower <- unname(bootSummary$parFixedDf$confLower[1:nrws, 1]) 

 cUpper <- unname(bootSummary$parFixedDf$confUpper[1:nrws, 1]) 

 estEst <- est 

 estimateBoot <- addConfboundsToVar(est, cLower, cUpper, sigdig) 

 # Add SE_boot 

 seBoot <- unname(bootSummary$parFixedDf$stdDev[1:nrws, 1]) 

 # Add Back-transformed 

 est <- unname(bootSummary$parFixedDf$mean[1:nrws, 2]) 

 cLowerBT <- unname(bootSummary$parFixedDf$confLower[1:nrws, 2]) 

 cUpperBT <- unname(bootSummary$parFixedDf$confUpper[1:nrws, 2]) 

 backTransformed <- 

 addConfboundsToVar(est, cLowerBT, cUpperBT, sigdig) 

 estBT <- est 

 newParFixedDf["Bootstrap Estimate"] <- estEst 

 newParFixedDf["Bootstrap SE"] <- seBoot 

 newParFixedDf["Bootstrap %RSE"] <- seBoot / estEst * 100 

 newParFixedDf["Bootstrap CI Lower"] <- cLowerBT 

 newParFixedDf["Bootstrap CI Upper"] <- cUpperBT 

 newParFixedDf["Bootstrap Back-transformed"] <- estBT 

 newParFixed["Bootstrap Estimate"] <- estimateBoot 

 newParFixed["Bootstrap SE"] <- signif(seBoot, sigdig) 

 newParFixed["Bootstrap %RSE"] <- 

 signif(seBoot / estEst * 100, sigdig) 

 .w <- which(regexpr("^Bootstrap +Back[-]transformed", names(newParFixed)) != -1) 

 if (length(.w) >= 1) newParFixed <- newParFixed[, -.w] 

 newParFixed[sprintf("Bootstrap Back-transformed(%s%%CI)", ci * 100)] <- 

 backTransformed 

 # compute bias 

 bootParams <- bootSummary$parFixedDf$mean 

 origParams <- data.frame(list("Estimate" = fit$parFixedDf$Estimate, "Back-transformed" = fit$parFixedDf$`Back-transformed`)) 

 bootstrapBiasParfixed <- abs(origParams - bootParams) 

 bootstrapBiasOmega <- abs(fit$omega - bootSummary$omega$mean) 

 assign("bootBiasParfixed", bootstrapBiasParfixed, envir = fit$env) 

 assign("bootBiasOmega", bootstrapBiasOmega, envir = fit$env) 

 assign("bootCovMatrix", bootSummary$omega$covMatrix, envir = fit$env) 

 assign("bootCorMatrix", bootSummary$omega$corMatrix, envir = fit$env) 

 assign("parFixedDf", newParFixedDf, envir = fit$env) 

 assign("parFixed", newParFixed, envir = fit$env) 

 assign("bootOmegaSummary", bootSummary$omega, envir = fit$env) 

 assign("bootSummary", bootSummary, envir = fit$env) 

 # plot histogram 

 if (plotHist) { 

 # compute delta objf values for each of the models 

 origData <- nlme::getData(fit) 

 if (is.null(fit$bootstrapMd5)) { 

 bootstrapMd5 <- fit$md5 

 assign("bootstrapMd5", bootstrapMd5, envir = fit$env) 

 } 

 # already exists 

 output_dir <- paste0("nlmixr2BootstrapCache_", fitName, "_", fit$bootstrapMd5) 

 deltOBJFloaded <- NULL 

 deltOBJF <- NULL 

 rxode2::rxProgress(length(fitList)) 

 cli::cli_h1("Loading/Calculating \u0394 Objective function") 

 nlmixr2est::setOfv(fit, "focei") # Make sure we are using focei objective function 

 deltOBJF <- lapply(seq_along(fitList), function(i) { 

 x <- readRDS(file.path(output_dir, paste0("fitEnsemble_", i, ".rds"))) 

 .path <- file.path(output_dir, paste0("posthoc_", i, ".rds")) 

 if (file.exists(.path)) { 

 xPosthoc <- readRDS(.path) 

 rxode2::rxTick() 

 } else { 

 rxode2::rxProgressStop() 

 ## rxode2::rxProgressAbort("Starting to posthoc estimates") 

 ## Don't calculate the tables 

 .msg <- paste0(gettext("Running bootstrap estimates on original data for model index: "), i) 

 cli::cli_h1(.msg) 

 xPosthoc <- nlmixr2(x, 

 data = origData, est = "posthoc", 

 control = list(calcTables = FALSE, print = 1, compress=FALSE) 

 ) 

 saveRDS(xPosthoc, .path) 

 } 

 xPosthoc$objf - fit$objf 

 }) 

 rxode2::rxProgressStop() 

 .deltaO <- sort(abs(unlist(deltOBJF))) 

 .deltaN <- length(.deltaO) 

 .df <- length(fit$ini$est) 

 .chisq <- rbind( 

 data.frame( 

 deltaofv = qchisq(seq(0, 0.99, 0.01), df = .df), 

 quantiles = seq(0, 0.99, 0.01), 

 Distribution = 1L, 

 stringsAsFactors = FALSE 

 ), 

 data.frame( 

 deltaofv = .deltaO, 

 quantiles = seq(.deltaN) / .deltaN, 

 Distribution = 2L, 

 stringsAsFactors = FALSE 

 ) 

 ) 

 .fdelta <- approxfun(seq(.deltaN) / .deltaN, .deltaO) 

 .df2 <- round(mean(.deltaO, na.rm = TRUE)) 

 .dfD <- data.frame( 

 label = paste(c("df\u2248", "df="), c(.df2, .df)), 

 Distribution = c(2L, 1L), 

 quantiles = 0.7, 

 deltaofv = c(.fdelta(0.7), qchisq(0.7, df = .df)) 

 ) 

 .dfD$Distribution <- factor( 

 .dfD$Distribution, c(1L, 2L), 

 c("Reference distribution", "\u0394 objective function") 

 ) 

 .chisq$Distribution <- factor( 

 .chisq$Distribution, c(1L, 2L), 

 c("Reference distribution", "\u0394 objective function") 

 ) 

 .dataList <- list( 

 dfD = .dfD, chisq = .chisq, 

 deltaN = .deltaN, df2 = .df2 

 ) 

 assign(".bootPlotData", .dataList, envir = fit$env) 

 } 

 ## Update covariance estimate 

 .nm <- names(fit$theta)[!fit$foceiSkipCov[seq_along(fit$theta)]] 

 .cov <- fit$bootSummary$omega$covMatrixCombined[.nm, .nm] 

 .setCov(fit, covMethod = .cov) 

 assign("covMethod", paste0("boot", fit$bootSummary$nboot), fit$env) 

 invisible(fit) 

 } 

 #' Perform bootstrap-sampling from a given dataframe 

 #' 

 #' @param data the original dataframe object to sample from for bootstrapping 

 #' 

 #' @param nsamp an integer specifying the number of samples in each 

 #' bootstrapped sample; default is the number of unique subjects in 

 #' the original dataset 

 #' 

 #' @param uid_colname a string representing the unique ID of each 

 #' subject in the data; default values is 'ID' 

 #' 

 #' @param pvalues a vector of pvalues indicating the probability of 

 #' each subject to get selected; default value is NULL implying that 

 #' probability of each subject is the same 

 #' 

 #' @return returns a bootstrap sampled dataframe object 

 #' @author Vipul Mann, Matthew Fidler 

 #' 

 #' @examples 

 #' sampling(data) 

 #' sampling(data, 10) 

 #' @noRd 

 sampling <- function(data, 

 nsamp, 

 uid_colname, 

 pvalues = NULL, 

 performStrat = FALSE, 

 stratVar) { 

 checkmate::assert_data_frame(data) 

 if (missing(nsamp)) { 

 nsamp <- length(unique(data[, uid_colname])) 

 } 

 else { 

 checkmate::assert_integerish(nsamp, 

 len = 1, 

 any.missing = FALSE, 

 lower = 2 

 ) 

 } 

 if (performStrat && missing(stratVar)) { 

 print("stratVar is required for stratifying") 

 stop("aborting... stratVar not specified", call. = FALSE) 

 } 

 checkmate::assert_integerish(nsamp, 

 lower = 2, 

 len = 1, 

 any.missing = FALSE 

 ) 

 if (missing(uid_colname)) { 

 # search the dataframe for a column name of 'ID' 

 colNames <- colnames(data) 

 colNamesLower <- tolower(colNames) 

 if ("id" %in% colNames) { 

 uid_colname <- colNames[which("id" %in% colNamesLower)] 

 } 

 else { 

 uid_colname <- "ID" 

 } 

 } 

 else { 

 checkmate::assert_character(uid_colname) 

 } 

 if (performStrat) { 

 stratLevels <- 

 as.character(unique(data[, stratVar])) # char to access freq. values 

 dataSubsets <- lapply(stratLevels, function(x) { 

 data[data[, stratVar] == x, ] 

 }) 

 names(dataSubsets) <- stratLevels 

 tab <- table(data[stratVar]) 

 nTab <- sum(tab) 

 sampledDataSubsets <- lapply(names(dataSubsets), function(x) { 

 dat <- dataSubsets[[x]] 

 uids <- unique(dat[, uid_colname]) 

 uids_samp <- sample( 

 list(uids), 

 size = ceiling(nsamp * unname(tab[x]) / nTab), 

 replace = TRUE, 

 prob = pvalues 

 ) 

 sampled_df <- 

 data.frame(dat)[0, ] # initialize an empty dataframe with the same col names 

 # populate dataframe based on sampled uids 

 # new_id = 1 

 .env <- environment() 

 .env$new_id <- 1 

 do.call(rbind, lapply(uids_samp, function(u) { 

 data_slice <- dat[dat[, uid_colname] == u, ] 

 start <- NROW(sampled_df) + 1 

 end <- start + NROW(data_slice) - 1 

 data_slice[uid_colname] <- 

 .env$new_id # assign a new ID to the sliced dataframe 

 .env$new_id <- .env$new_id + 1 

 data_slice 

 })) 

 }) 

 do.call("rbind", sampledDataSubsets) 

 } 

 else { 

 uids <- unique(data[, uid_colname]) 

 uids_samp <- sample(uids, 

 size = nsamp, 

 replace = TRUE, 

 prob = pvalues 

 ) 

 sampled_df <- 

 data.frame(data)[0, ] # initialize an empty dataframe with the same col names 

 # populate dataframe based on sampled uids 

 # new_id = 1 

 .env <- environment() 

 .env$new_id <- 1 

 do.call(rbind, lapply(uids_samp, function(u) { 

 data_slice <- data[data[, uid_colname] == u, ] 

 start <- NROW(sampled_df) + 1 

 end <- start + NROW(data_slice) - 1 

 data_slice[uid_colname] <- 

 .env$new_id # assign a new ID to the sliced dataframe 

 .env$new_id <- .env$new_id + 1 

 data_slice 

 })) 

 } 

 } 

 #' Fitting multiple bootstrapped models without aggregaion; called by the function bootstrapFit() 

 #' 

 #' @param fit the nlmixr2 fit object 

 #' @param nboot an integer giving the number of bootstrapped models to be fit; default value is 100 

 #' @param nSampIndiv an integer specifying the number of samples in each bootstrapped sample; default is the number of unique subjects in the original dataset 

 #' @param pvalues a vector of pvalues indicating the probability of each subject to get selected; default value is NULL implying that probability of each subject is the same 

 #' @param restart a boolean that indicates if a previous session has to be restarted; default value is FALSE 

 #' 

 #' @return a list of lists containing the different attributed of the fit object for each of the bootstrapped models 

 #' @author Vipul Mann, Matthew Fidler 

 #' @examples 

 #' modelBootstrap(fit) 

 #' modelBootstrap(fit, 5) 

 #' modelBootstrap(fit, 5, 20) 

 #' @noRd 

 modelBootstrap <- function(fit, 

 nboot = 100, 

 nSampIndiv, 

 stratVar, 

 pvalues = NULL, 

 restart = FALSE, 

 fitName = "fit") { 

 nlmixr2est::assertNlmixrFit(fit) 

 if (missing(stratVar)) { 

 performStrat <- FALSE 

 stratVar <- NULL 

 } else { 

 performStrat <- TRUE 

 } 

 data <- nlme::getData(fit) 

 .w <- tolower(names(data)) == "id" 

 uidCol <- names(data)[.w] 

 checkmate::assert_integerish(nboot, 

 len = 1, 

 any.missing = FALSE, 

 lower = 1 

 ) 

 if (missing(nSampIndiv)) { 

 nSampIndiv <- length(unique(data[, uidCol])) 

 } 

 else { 

 checkmate::assert_integerish( 

 nSampIndiv, 

 len = 1, 

 any.missing = FALSE, 

 lower = 2 

 ) 

 } 

 # infer the ID column from data 

 colNames <- names(data) 

 colNamesLower <- tolower(colNames) 

 if ("id" %in% colNamesLower) { 

 uid_colname <- colNames[which("id" %in% colNamesLower)] 

 } 

 else { 

 stop("cannot find the 'ID' column! aborting ...", call. = FALSE) 

 } 

 ui <- fit$finalUiEnv 

 fitMeth <- getFitMethod(fit) 

 bootData <- vector(mode = "list", length = nboot) 

 if (is.null(fit$bootstrapMd5)) { 

 bootstrapMd5 <- fit$md5 

 assign("bootstrapMd5", bootstrapMd5, envir = fit$env) 

 } 

 output_dir <- 

 paste0("nlmixr2BootstrapCache_", fitName, "_", fit$bootstrapMd5) # a new directory with this name will be created 

 if (!dir.exists(output_dir)) { 

 dir.create(output_dir) 

 } else if (dir.exists(output_dir) && restart == TRUE) { 

 unlink(output_dir, recursive = TRUE, force = TRUE) # unlink any of the previous directories 

 dir.create(output_dir) # create a fresh directory 

 } 

 fnameBootDataPattern <- 

 paste0("boot_data_", "[0-9]+", ".rds", 

 sep = "" 

 ) 

 fileExists <- 

 list.files(paste0("./", output_dir), pattern = fnameBootDataPattern) 

 if (length(fileExists) == 0) { 

 restart <- TRUE 

 } 

 if (!restart) { 

 # read saved bootData from boot_data files on disk 

 if (length(fileExists) > 0) { 

 cli::cli_alert_success("resuming bootstrap data sampling using data at {paste0('./', output_dir)}") 

 bootData <- lapply(fileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 startCtr <- length(bootData) + 1 

 } else { 

 cli::cli_alert_danger( 

 cli::col_red( 

 "need the data files at {.file {paste0(getwd(), '/', output_dir)}} to resume" 

 ) 

 ) 

 stop("aborting...resume file missing", call. = FALSE) 

 } 

 } else { 

 startCtr <- 1 

 } 

 # Generate additional samples (if nboot>startCtr) 

 if (nboot >= startCtr) { 

 for (mod_idx in startCtr:nboot) { 

 bootData[[mod_idx]] <- sampling( 

 data, 

 nsamp = nSampIndiv, 

 uid_colname = uidCol, 

 pvalues = pvalues, 

 performStrat = performStrat, 

 stratVar = stratVar 

 ) 

 # save bootData in curr directory: read the file using readRDS() 

 attr(bootData, "randomSeed") <- .Random.seed 

 saveRDS(bootData[[mod_idx]], 

 file = paste0( 

 "./", 

 output_dir, 

 "/boot_data_", 

 mod_idx, 

 ".rds")) 

 } 

 } 

 # check if number of samples in stored file is the same as the required number of samples 

 fileExists <- 

 list.files(paste0("./", output_dir), pattern = fnameBootDataPattern) 

 bootData <- lapply(fileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 currBootData <- length(bootData) 

 # Fitting models to bootData now 

 .env <- environment() 

 fnameModelsEnsemblePattern <- 

 paste0("modelsEnsemble_", "[0-9]+", 

 ".rds", 

 sep = "") 

 modFileExists <- 

 list.files(paste0("./", output_dir), pattern = fnameModelsEnsemblePattern) 

 fnameFitEnsemblePattern <- 

 paste0("fitEnsemble_", "[0-9]+", 

 ".rds", 

 sep = "") 

 fitFileExists <- list.files(paste0("./", output_dir), pattern = fnameFitEnsemblePattern) 

 if (!restart) { 

 if (length(modFileExists) > 0 && 

 (length(fileExists) > 0)) { 

 # read bootData and modelsEnsemble files from disk 

 cli::cli_alert_success( 

 "resuming bootstrap model fitting using data and models stored at {paste0(getwd(), '/', output_dir)}" 

 ) 

 bootData <- lapply(fileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 modelsEnsembleLoaded <- lapply(modFileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 fitEnsembleLoaded <- lapply(fitFileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 .env$mod_idx <- length(modelsEnsembleLoaded) + 1 

 currNumModels <- .env$mod_idx - 1 

 if (currNumModels > nboot) { 

 mod_idx_m1 <- .env$mod_idx-1 

 cli::cli_alert_danger( 

 cli::col_red( 

 "the model file already has {mod_idx_m1} models when max models is {nboot}; using only the first {nboot} model(s)" 

 ) 

 ) 

 return(list(modelsEnsembleLoaded[1:nboot], fitEnsembleLoaded[1:nboot])) 

 # return(modelsEnsembleLoaded[1:nboot]) 

 } else if (currNumModels == nboot) { 

 mod_idx_m1 <- .env$mod_idx-1 

 cli::col_red( 

 "the model file already has {mod_idx_m1} models when max models is {nboot}; loading from {nboot} models already saved on disk" 

 ) 

 return(list(modelsEnsembleLoaded, fitEnsembleLoaded)) 

 # return(modelsEnsembleLoaded) 

 } else if (currNumModels < nboot) { 

 cli::col_red("estimating the additional models ... ") 

 } 

 } 

 else { 

 cli::cli_alert_danger( 

 cli::col_red( 

 "need both the data and the model files at: {paste0(getwd(), '/', output_dir)} to resume" 

 ) 

 ) 

 stop( 

 "aborting...data and model files missing at: {paste0(getwd(), '/', output_dir)}", 

 call. = FALSE 

 ) 

 } 

 } 

 else { 

 .env$mod_idx <- 1 

 } 

 # get control settings for the 'fit' object and save computation effort by not computing the tables 

 .ctl <- fit$control 

 .ctl$print <- 0L 

 .ctl$covMethod <- 0L 

 .ctl$calcTables <- FALSE 

 .ctl$compress <- FALSE 

 modelsEnsemble <- 

 lapply(bootData[.env$mod_idx:nboot], function(boot_data) { 

 modIdx <- .env$mod_idx 

 cli::cli_h1(paste0("Running nlmixr2 for model index: ", 

 modIdx)) 

 fit <- tryCatch( 

 { 

 fit <- suppressWarnings(nlmixr2(ui, 

 boot_data, 

 est = fitMeth, 

 control = .ctl)) 

 .env$multipleFits <- list( 

 # objf = fit$OBJF, 

 # aic = fit$AIC, 

 omega = fit$omega, 

 parFixedDf = fit$parFixedDf[, c("Estimate", "Back-transformed")], 

 message = fit$message, 

 warnings = fit$warnings) 

 fit # to return 'fit' 

 }, 

 error = function(error_message) { 

 message("error fitting the model") 

 message(error_message) 

 message("storing the models as NA ...") 

 return(NA) # return NA otherwise (instead of NULL) 

 }) 

 saveRDS( 

 .env$multipleFits, 

 file = paste0( 

 "./", 

 output_dir, 

 "/modelsEnsemble_", 

 .env$mod_idx, 

 ".rds")) 

 saveRDS( 

 fit, 

 file = paste0( 

 "./", 

 output_dir, 

 "/fitEnsemble_", 

 .env$mod_idx, 

 ".rds" 

 ) 

 ) 

 assign("mod_idx", .env$mod_idx + 1, .env) 

 }) 

 fitEnsemble <- NULL 

 if (!restart) { 

 modelsEnsemble <- c(modelsEnsembleLoaded, modelsEnsemble) 

 fitEnsemble <- c(fitEnsembleLoaded, fitEnsemble) 

 } 

 modFileExists <- 

 list.files(paste0("./", output_dir), pattern = fnameModelsEnsemblePattern) 

 modelsEnsemble <- lapply(modFileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 fitFileExists <- list.files(paste0("./", output_dir), pattern = fnameFitEnsemblePattern) 

 fitEnsemble <- lapply(fitFileExists, function(x) { 

 readRDS(paste0("./", output_dir, "/", x, sep = "")) 

 }) 

 list(modelsEnsemble, fitEnsemble) 

 } 

 #' Get the nlmixr2 method used for fitting the model 

 #' 

 #' @param fit the nlmixr2 fit object 

 #' 

 #' @return returns a string representing the method used by nlmixr2 for fitting the given model 

 #' 

 #' @author Vipul Mann, Matthew Fidler 

 #' 

 #' @examples 

 #' getFitMethod(fit) 

 #' @noRd 

 getFitMethod <- function(fit) { 

 if (!(inherits(fit, "nlmixr2FitCore"))) { 

 stop("'fit' needs to be a nlmixr2 fit", call. = FALSE) 

 } 

 fit$est 

 } 

 #' Extract all the relevant variables from a set of bootstrapped models 

 #' 

 #' @param fitlist a list of lists containing information on the multiple bootstrapped models; similar to the output of modelsBootstrap() function 

 #' @param id a character representing the variable of interest: OBJF, AIC, omega, parFixedDf, method, message, warnings 

 #' 

 #' @return returns a vector or list across of the variable of interest from all the fits/bootstrapped models 

 #' 

 #' @author Vipul Mann, Matthew Fidler 

 #' @examples 

 #' extractVars(fitlist, 1) # returns a vector of OBJF values 

 #' extractVars(fitlist, 4) # returns a list of dataframes containing parFixedDf values 

 #' @noRd 

 extractVars <- function(fitlist, id = "method") { 

 if (id == "method") { 

 # no lapply for 'method' 

 unlist(unname(fitlist[[1]][id])) 

 } 

 else { 

 # if id not equal to 'method' 

 res <- lapply(fitlist, function(x) { 

 x[[id]] 

 }) 

 if (!(id == "omega" || 

 id == "parFixedDf")) { 

 # check if all message strings are empty 

 if (id == "message") { 

 prev <- TRUE 

 for (i in length(res)) { 

 status <- (res[[i]] == "") && prev 

 prev <- status 

 } 

 if (status == TRUE) { 

 "" 

 } 

 else { 

 # if non-empty 'message' 

 unlist(res) 

 } 

 } 

 else { 

 # if id does not equal 'message' 

 unlist(res) 

 } 

 } 

 else { 

 # if id equals 'omega' or 'parFixedDf 

 res 

 } 

 } 

 } 

 #' Summarize the bootstrapped fits/models 

 #' 

 #' @param fitList a list of lists containing information on the multiple bootstrapped models; similar to the output of modelsBootstrap() function 

 #' @return returns aggregated quantities (mean, median, standard deviation, and variance) as a list for all the quantities 

 #' @author Vipul Mann, Matthew Fidler 

 #' @examples 

 #' getBootstrapSummary(fitlist) 

 #' @noRd 

 getBootstrapSummary <- 

 function(fitList, 

 ci = 0.95, 

 stdErrType = "perc") { 

 if (!(ci < 1 && ci > 0)) { 

 stop("'ci' needs to be between 0 and 1", call. = FALSE) 

 } 

 quantLevels <- 

 c(0.5, (1 - ci) / 2, 1 - (1 - ci) / 2) # median, (1-ci)/2, 1-(1-ci)/2 

 varIds <- 

 names(fitList[[1]]) # number of different variables present in fitlist 

 summaryList <- lapply(varIds, function(id) { 

 # if (!(id %in% c("omega", "parFixedDf", "method", "message", "warnings"))) { 

 # varVec <- extractVars(fitList, id) 

 # mn <- mean(varVec) 

 # median <- median(varVec) 

 # sd <- sd(varVec) 

 # 

 # c( 

 # mean = mn, 

 # median = median, 

 # stdDev = sd 

 # ) 

 # } 

 if (id == "omega") { 

 # omega estimates 

 omegaMatlist <- extractVars(fitList, id) 

 varVec <- simplify2array(omegaMatlist) 

 mn <- apply(varVec, 1:2, mean) 

 sd <- apply(varVec, 1:2, sd) 

 quants <- apply(varVec, 1:2, function(x) { 

 unname(quantile(x, quantLevels)) 

 }) 

 median <- quants[1, , ] 

 confLower <- quants[2, , ] 

 confUpper <- quants[3, , ] 

 if (stdErrType != "perc") { 

 confLower <- mn - qnorm(quantLevels[[2]]) * sd 

 confUpper <- mn + qnorm(quantLevels[[3]]) * sd 

 } 

 # computing the covariance and correlation matrices 

 # ======================================================= 

 parFixedOmegaBootVec <- list() 

 parFixedlist <- extractVars(fitList, id = "parFixedDf") 

 parFixedlistVec <- lapply(parFixedlist, function(x) { 

 x$Estimate 

 }) 

 parFixedlistVec <- do.call("rbind", parFixedlistVec) 

 omgVecBoot <- list() 

 omegaIdx <- seq(length(omegaMatlist)) 

 omgVecBoot <- lapply(omegaIdx, function(idx) { 

 omgMat <- omegaMatlist[[idx]] 

 omgVec <- omgMat[lower.tri(omgMat, TRUE)] 

 omgVecBoot[[idx]] <- omgVec 

 }) 

 omgVecBoot <- do.call("rbind", omgVecBoot) 

 idxName <- 1 

 namesList <- list() 

 for (nam1 in colnames(omegaMatlist[[1]])) { 

 for (nam2 in colnames(omegaMatlist[[1]])) { 

 if (nam1 == nam2) { 

 if (!(nam1 %in% namesList)) { 

 namesList[idxName] <- nam1 

 idxName <- idxName + 1 

 } 

 } else { 

 nam <- paste0("(", nam1, ",", nam2, ")") 

 namRev <- paste0("(", nam2, ",", nam1, ")") 

 if (!(nam %in% namesList | namRev %in% namesList)) { 

 namesList[idxName] <- nam 

 idxName <- idxName + 1 

 } 

 } 

 } 

 } 

 colnames(omgVecBoot) <- namesList 

 .w <- which(vapply(namesList, function(x) { 

 !all(omgVecBoot[, x] == 0) 

 }, logical(1), USE.NAMES=FALSE)) 

 omgVecBoot <- omgVecBoot[, .w] 

 parFixedOmegaCombined <- cbind(parFixedlistVec, omgVecBoot) 

 covMatrix <- cov(parFixedOmegaCombined) 

 corMatrix <- cov2cor(covMatrix) 

 diag(corMatrix) <- sqrt(diag(covMatrix)) 

 lst <- list( 

 mean = mn, 

 median = median, 

 stdDev = sd, 

 confLower = confLower, 

 confUpper = confUpper, 

 covMatrixCombined = covMatrix, 

 corMatrixCombined = corMatrix 

 ) 

 } 

 else if (id == "parFixedDf") { 

 # parameter estimates (dataframe) 

 varVec <- extractVars(fitList, id) 

 mn <- 

 apply(simplify2array(lapply(varVec, as.matrix)), 1:2, mean, na.rm = TRUE) 

 sd <- 

 apply(simplify2array(lapply(varVec, as.matrix)), 1:2, sd, na.rm = TRUE) 

 quants <- 

 apply(simplify2array(lapply(varVec, as.matrix)), 1:2, function(x) { 

 unname(quantile(x, quantLevels, na.rm = TRUE)) 

 }) 

 median <- quants[1, , ] 

 confLower <- quants[2, , ] 

 confUpper <- quants[3, , ] 

 if (stdErrType != "perc") { 

 confLower <- mn - qnorm(quantLevels[[2]]) * sd 

 confUpper <- mn + qnorm(quantLevels[[3]]) * sd 

 } 

 lst <- list( 

 mean = mn, 

 median = median, 

 stdDev = sd, 

 confLower = confLower, 

 confUpper = confUpper 

 ) 

 } 

 else { 

 # if id equals method, message, or warning 

 extractVars(fitList, id) 

 } 

 }) 

 names(summaryList) <- varIds 

 summaryList$nboot <- length(fitList) 

 summaryList$warnings <- unique(summaryList$warnings) 

 summaryList$message <- unique(summaryList$message) 

 class(summaryList) <- "nlmixr2BoostrapSummary" 

 summaryList 

 } 

 #' @export 

 print.nlmixr2BoostrapSummary <- function(x, ..., sigdig = NULL) { 

 if (is.null(sigdig)) { 

 if (any(names(x) == "sigdig")) { 

 sigdig <- x$sigdig 

 } else { 

 sigdig <- 3 

 } 

 } 

 # objf <- x$objf 

 # aic <- x$aic 

 message <- x$message 

 warnings <- x$warnings 

 omega <- x$omega 

 parFixedDf <- x$parFixedDf 

 nboot <- x$nboot 

 cli::cli_h1( 

 cli::col_red( 

 "Summary of the bootstrap models (nboot: {nboot})" 

 ) 

 ) 

 cli::cli_li(cli::col_magenta( 

 cli::style_bold( 

 "Omega matrices: mean, median, standard deviation, and confidence bousnds" 

 ), 

 cli::col_yellow(" (summary$omega)") 

 )) 

 lapply(seq_along(omega), function(x) { 

 cli::cli_text(cli::col_green(paste0("$", names(omega)[x]))) 

 print(signif(omega[[x]], sigdig)) 

 }) 

 cli::cli_li(cli::col_magenta( 

 cli::style_bold( 

 "Estimated parameters: mean, median, standard deviation, and confidence bounds" 

 ), 

 cli::col_yellow(" (summary$parFixedDf)") 

 )) 

 lapply(seq_along(parFixedDf), function(x) { 

 cli::cli_text(cli::col_yellow(paste0("$", names(parFixedDf)[x]))) 

 print(signif(parFixedDf[[x]], sigdig)) 

 }) 

 cli::cli_li(cli::cli_text( 

 cli::bg_yellow(cli::style_bold("Messages")), 

 cli::col_yellow(" (summary$message)") 

 )) 

 print(message) 

 cli::cli_li(cli::cli_text( 

 cli::bg_red(cli::style_bold(cli::col_white("Warnings"))), 

 cli::col_yellow(" (summary$warnings)") 

 )) 

 print(warnings) 

 cli::cli_h1("end") 

 invisible(x) 

 } 

 #' Assign a set of variables to the nlmixr2 fit environment 

 #' 

 #' @param namedVars a named list of variables that need to be assigned to the given environment 

 #' @param fitobject the nlmixr2 fit object that contains its environment information 

 #' @noRd 

 #' 

 assignToEnv <- function(namedVars, fitobject) { 

 if (!inherits(fitobject, "nlmixr2FitCore")) { 

 stop("'fit' needs to be a nlmixr2 fit", call. = FALSE) 

 } 

 if (is.null(names(namedVars))) { 

 stop("'namedVars needs to be a named list", call. = FALSE) 

 } 

 if (length(namedVars) != length(names(namedVars))) { 

 stop("'namedVars does not have all the elements named", call. = FALSE) 

 } 

 env <- fitobject$env 

 lapply(names(namedVars), function(x) { 

 assign(x, namedVars[[x]], envir = env) 

 }) 

 } 

 #' @title Produce delta objective function for boostrap 

 #' 

 #' @param x fit object 

 #' @param ... other parameters 

 #' @return Fit traceplot or nothing. 

 #' @author Vipul Mann, Matthew L. Fidler 

 #' @references 

 #' 

 #' R Niebecker, MO Karlsson. (2013) 

 #' *Are datasets for NLME models large enough for a bootstrap to provide reliable parameter uncertainty distributions?* 

 #' PAGE 2013. 

 #' <https://www.page-meeting.org/?abstract=2899> 

 #' 

 #' @export 

 bootplot <- function(x, ...) { 

 UseMethod("bootplot") 

 } 

 #' @rdname bootplot 

 #' @export 

 #' @importFrom ggplot2 .data 

 bootplot.nlmixr2FitCore <- function(x, ...) { 

 .fitName <- as.character(substitute(x)) 

 if (inherits(x, "nlmixr2FitCore")) { 

 if (exists("bootSummary", x$env) & (!exists(".bootPlotData", x$env))) { 

 bootstrapFit(x, x$bootSummary$nboot, plotHist = TRUE, fitName = .fitName) 

 } 

 if (exists(".bootPlotData", x$env)) { 

 if (x$bootSummary$nboot != x$env$.bootPlotData$deltaN) { 

 bootstrapFit(x, x$bootSummary$nboot, plotHist = TRUE, fitName = .fitName) 

 } 

 .chisq <- x$env$.bootPlotData$chisq 

 .dfD <- x$env$.bootPlotData$dfD 

 .deltaN <- x$env$.bootPlotData$deltaN 

 .df2 <- x$env$.bootPlotData$df2 

 .plot <- ggplot2::ggplot(.chisq, ggplot2::aes(.data$quantiles, .data$deltaofv, color = .data$Distribution)) + 

 ggplot2::geom_line() + 

 ggplot2::ylab("\u0394 objective function") + 

 ggplot2::geom_text(data = .dfD, ggplot2::aes(label = .data$label), hjust = 0) + 

 ggplot2::xlab("Distribution quantiles") + 

 ggplot2::scale_color_manual(values = c("red", "blue")) + 

 rxode2::rxTheme() + 

 ggplot2::theme(legend.position = "bottom", legend.box = "horizontal") 

 if (requireNamespace("ggtext", quietly = TRUE)) { 

 .plot <- .plot + 

 ggplot2::theme( 

 plot.title = ggtext::element_markdown(), 

 legend.position = "none" 

 ) + 

 ggplot2::labs( 

 title = paste0( 

 'Bootstrap <span style="color:blue; opacity: 0.2;">\u0394 objective function (', .deltaN, 

 " models, df\u2248", .df2, ')</span> vs <span style="color:red; opacity: 0.2;">reference \u03C7\u00B2(df=', 

 length(x$ini$est), ")</style>" 

 ), 

 caption = "\u0394 objective function curve should be on or below the reference distribution curve" 

 ) 

 } else { 

 .plot <- ggplot2::labs( 

 title = paste0("Distribution of \u0394 objective function values for ", .deltaN, " df=", .df2, " models"), 

 caption = "\u0394 objective function curve should be on or below the reference distribution curve" 

 ) 

 } 

 .plot 

 } else { 

 stop("this nlmixr2 object does not include boostrap distribution statics for comparison", 

 call. = FALSE 

 ) 

 } 

 } else { 

 stop("this is not a nlmixr2 object", 

 call. = FALSE 

 ) 

 } 

 }

Drop `C++14`

Feature request: SAMBA

See https://ascpt.onlinelibrary.wiley.com/doi/epdf/10.1002/psp4.12742

bootstrap error with gctorture/valgrind

While running with valgrind and gctorture on Linux (starting about 4 days ago), I get the errors below. When running with current versions on Windows without valgrind and gctorture, I don't get the errors.

⠏ |         0 | bootstrap
⠋ |         1 | bootstrap                                                       Error in (function (..., row.names = NULL, check.rows = FALSE, check.names = TRUE,  :
  arguments imply differing number of rows: 1, 0

⠙ | 1       1 | bootstrap                                                       Error in (function (..., row.names = NULL, check.rows = FALSE, check.names = TRUE,  :
  arguments imply differing number of rows: 1, 0

⠹ | 2       1 | bootstrap                                                       Error in (function (..., row.names = NULL, check.rows = FALSE, check.names = TRUE,  :
  arguments imply differing number of rows: 1, 0

⠸ | 3       1 | bootstrap                                                       Error in (function (..., row.names = NULL, check.rows = FALSE, check.names = TRUE,  :
  arguments imply differing number of rows: 1, 0

⠼ | 4       1 | bootstrap
✖ | 4       1 | bootstrap [329398.0s]
────────────────────────────────────────────────────────────────────────────────
Error ('test-bootstrap.R:31'): resuming the fit should not return the same datasets as before
Error: arguments imply differing number of rows: 1, 0
Backtrace:
 1. base::suppressMessages(...)
      at test-bootstrap.R:31:4
 6. nlmixr2est:::nlmixr2.function(...)
 7. nlmixr2est:::nlmixr2Est0(.env)

Error ('test-bootstrap.R:89'): different confidence levels should result in different bands
Error: arguments imply differing number of rows: 1, 0
Backtrace:
 1. base::suppressMessages(...)
      at test-bootstrap.R:89:4
 6. nlmixr2est:::nlmixr2.function(...)
 7. nlmixr2est:::nlmixr2Est0(.env)

Error ('test-bootstrap.R:135'): expected columns in fit$parFixedDf object should match
Error: arguments imply differing number of rows: 1, 0
Backtrace:
 1. base::suppressMessages(...)
      at test-bootstrap.R:135:4
 6. nlmixr2est:::nlmixr2.function(...)
 7. nlmixr2est:::nlmixr2Est0(.env)

Error ('test-bootstrap.R:184'): saem bootstrap
Error: arguments imply differing number of rows: 1, 0
Backtrace:
 1. base::suppressMessages(...)
      at test-bootstrap.R:184:4
 6. nlmixr2est:::nlmixr2.function(...)
 7. nlmixr2est:::nlmixr2Est0(.env)
────────────────────────────────────────────────────────────────────────────────

Refactor: SCM using mu-referencing

Remove pureMuRef

Equationmatic is off CRAN

https://cran.r-project.org/web/packages/equatiomatic/index.html

`bootstrapFit()`, `lassoCoefficients()`, `adaptivelassoCoefficients()`, `regularmodel()`, and `adjustedlassoCoefficients()` Examples Cause CI to Fail

Related to #30

For bootstrapFit(), see

For lassoCoefficients(), see:

https://github.com/nlmixr2/nlmixr2extra/actions/runs/3877842788/jobs/6613328418

For adaptiveLassoCoefficients(), see:

https://github.com/nlmixr2/nlmixr2extra/actions/runs/3879304331/jobs/6616355585

For regularmodel(), see:

https://github.com/nlmixr2/nlmixr2extra/actions/runs/3879479666

For adjustedlassoCoefficients(), see:

https://github.com/nlmixr2/nlmixr2extra/actions/runs/3884154252/jobs/6626339968

Switch all `\dontrun`s to `\donttest`s

As discussed in #30

Some of the examples are failing on CI but working locally. The package will not be accepted back on CRAN until these are reverted to \donttest, but for now, they need to be \dontrun.

Integrate all the covariate selection mehods into one function,

covarSearchAuto() should be the function, too many user functions provide many methods to do the same thing.

Missing horseshoe prior selection methd

@vsarsani I can't seem to find the horeshoe prior covariate selection function like regularmodel(). Am I simply overlooking it?

`covarSearchAuto` doesn't work with the example

At least from nlmixr2

> rxode2::.rxWithWd(tempdir(), {# with temporary directory
+ > 
+ > auto1 <- covarSearchAuto(fit, varsVec = c("ka", "cl"),
+ >     covarsVec = c("WT"))
+ > 
+ > })

── starting forward search... ─────────────────────────────────────────────────────────────────────────────────────────────────────────
Key: U: Unscaled Parameters; X: Back-transformed parameters; G: Gill difference gradient approximation
F: Forward difference gradient approximation
C: Central difference gradient approximation
M: Mixed forward and central difference gradient approximation
Unscaled parameters for Omegas=chol(solve(omega));
Diagonals are transformed, as specified by foceiControl(diagXform=)
|-----+---------------+-----------+-----------+-----------+-----------|
|    #| Objective Fun |       tka |       tcl |        tv |    add.sd |
|.....................| cov_WT_ka |        o1 |        o2 |        o3 |
|    1|     116.80360 |   -0.7319 |   -0.4146 |     1.000 |   -0.5984 |
|.....................|    -1.000 |   -0.2735 |    0.1279 |    0.5549 |
|    U|      116.8036 |    0.4638 |     1.013 |     3.459 |    0.6946 |
|.....................|     0.000 |     1.257 |     1.951 |     2.689 |
|    X|      116.8036 |     1.590 |     2.753 |     31.79 |    0.6946 |
|.....................|     0.000 |     1.257 |     1.951 |     2.689 |
|    G|    Gill Diff. |   0.02023 |    0.1352 |   -0.3409 |   0.06867 |
|.....................| -0.001704 |    0.1258 |    0.1391 |  -0.01370 |
|    2|     179.09946 |   -0.7521 |   -0.5497 |     1.341 |   -0.6671 |
|.....................|   -0.9983 |   -0.3994 |  -0.01121 |    0.5686 |


...


── forward search complete ──

Error in inherits(fit, "nlmixr2FitCore") : object 'fit' not found
ℹ Loading nlmixr2
> traceback()
12: backwardSearch(varsVec, covarsVec, catvarsVec, fitorig = fit, 
        fitupdated = resFwd[[1]], pVal = pVal$bck, reFitCovars = FALSE, 
        outputDir = outputDir, restart = restart)
11: nlmixr2extra::covarSearchAuto(fit = fit, varsVec = varsVec, covarsVec = covarsVec, 
        pVal = pVal, catvarsVec = catvarsVec, searchType = searchType, 
        restart = restart) at hardReexports.R#274
10: covarSearchAuto(fit, varsVec = c("ka", "cl"), covarsVec = c("WT")) at file39e0e80c04c.R#34
9: force(code)
8: rxode2::.rxWithWd(tempdir(), {
       auto1 <- covarSearchAuto(fit, varsVec = c("ka", "cl"), covarsVec = c("WT"))
   }) at file39e0e80c04c.R#32
7: eval(ei, envir)
6: eval(ei, envir)
5: withVisible(eval(ei, envir))
4: source(tmp, echo = !quiet, local = env, max.deparse.length = Inf)
3: FUN(X[[i]], ...)
2: lapply(files, pkgload::run_example, run_donttest = run_donttest, 
       run_dontrun = run_dontrun)

qs:qserialize() zstd compression error

While running SCM in the documentation example, there is an error:

  Error in qs::qserialize(ui) : zstd compression error
  [1] "error fitting the model for the covariate "
  <simpleError: zstd compression error>

https://github.com/nlmixr2/nlmixr2extra/actions/runs/3852288938/jobs/6564288954#step:6:2350

It appears to occur here:

nlmixr2extra/R/SCM.R

Lines 72 to 74 in c13dc98

 #' auto2 <- covarSearchAuto(fit, varsVec = c("ka", "cl"), covarsVec = c("WT"), 

 #' catvarsVec= c("SEX"), restart = TRUE) 

 #'

I cannot replicate this locally, but it seems to happen repeatably in CI. My current guess is that this is (part of) the CI issue that I'm trying to work through in #30.

Feature request: Enable distribution of estimation across a grid

When writing up the profile method, I was thinking that it would be useful to be able to send the different parts to be run in parallel and more generally to be able to run them on a grid (or at least not directly in the current R session).

Specific places where this could help are bootstrap and likelihood profiling, but it would be generally helpful, I think.

To do it, I'd not want to support our own grid queueing system; we would build on something that others are already doing. I think that the clustermq library would be the preferred underlying choice.

My current brainstorm for it is that we would make a new function called something like nlmixr2Q (the "Q" mirrors the main command used in the clustermq library). It would take in either multiple models (a list of model specifications) or multiple datasets (a list of data objects), but not both. All other function arguments would be applied to all of the models/datasets.

It would queue things up if clustermq is setup, and it would work just like running nlmixr2 serially if clustermq is not setup.

Thoughts?

Make `bootstrapFit` quieter

Currently, bootstrapFit prints out everything (even if the original model has control = list(print = 0)). Make it quieter.

(I will take care of it when I get CI working.)

nlmixr2extra with rxode2parse

Feature request: profile function for log-likelihood profiling

I think that it'd be helpful to implement a profile() method for fit objects to perform log-likelihood profiling. (This is not a high priority request, and if not yet implemented, it's something that I could help with.)

No bootstrap result due to matrix issues

Dear Matt,

I am trying to obtain SE or confidence intervals for an nlmixr2 object (named test) after a FOCEi fit using bootstrapping. However, something seems to be wrong with the covariance matrix.

fit2 <- suppressMessages(bootstrapFit(test, nboot = 50))
Warning message:
In cov2cor(covMatrix) :
diag(.) had 0 or NA entries; non-finite result is doubtful

Can you execute the function on enclosed object without error or where may be the problem?

Many thanks and best wishes

Andreas

test.zip

SCM issue

See nlmixrdevelopment/nlmixr#648

Check covariate selection information is stored in the fit.

Not sure it is, perhaps you know @vsarsani

Add built-in model for testing.

Add this fit to the build so that it can be tested against

      one.compartment <- function() {
        ini({
          tka <- 0.45 # Log Ka
          tcl <- 1 # Log Cl
          tv <- 3.45    # Log V
          eta.ka ~ 0.6
          eta.cl ~ 0.3
          eta.v ~ 0.1
          add.sd <- 0.7
        })
        # and a model block with the error sppecification and model specification
        model({
          ka <- exp(tka + eta.ka)
          cl <- exp(tcl + eta.cl)
          v <- exp(tv + eta.v)
          d/dt(depot) = -ka * depot
          d/dt(center) = ka * depot - cl / v * center
          cp = center / v
          cp ~ add(add.sd)
        })
      }
  
 
  fit =  nlmixr2::nlmixr(one.compartment, theo_sd, est="focei")

you may be interested in this issue @john-harrold

SCM Example Fails in CI

The following error intermittently comes up in CI (I cannot replicate it locally):

Error in rxState(x) : 
    Evaluation error: Evaluation error: INTEGER() can only be applied to a 'integer', not a 'NULL'..
  [1] "error fitting the model for the covariate "
  <simpleError: Evaluation error: Evaluation error: INTEGER() can only be applied to a 'integer', not a 'NULL'..>
  Error in if (dObjf < 0) { : argument is of length zero

The problem R code appears to be here, but the underlying issue appears to be an issue on the C side:

nlmixr2extra/R/SCM.R

Lines 277 to 284 in c13dc98

 dObjf <- fit$objf - x$objf 

 dof <- length(x$finalUiEnv$ini$est) - length(fit$finalUiEnv$ini$est) 

 if (dObjf < 0) { 

 pchisqr <- 1 - pchisq(-dObjf, df = dof) 

 } 

 else { 

 pchisqr <- 1 

 }

@mattfidler, any ideas?

Valgrind Issues

I just ran valgrind, and I found the following possible issues:

And, I have a related question: Why is UDUNITS called so many times?

Feature Request: `nlmixr2.formula()` function

As initially implemented in #5, this is an issue for discussion of the feature of nlmixr2.formula().

The overall interface is below. (This isn't going to be precise at the moment as it's for discussion. The final interface will match the generic of nlmixr2().

nlmixr2.formula(object, data, ..., start, param, residualModel=~add(add_err))

object will be the formula, and upon reconsideration, I think it should be a simple formula without the double tilde notation originally proposed in #5 (more on that later).
data used for evaluation of factor levels, possibly modified, and sent to nlmixr2.function().
... passed to nlmixr2.function()
start initial parameter estimates as either a named vector or as a named list. If you have a single estimate per fixed effect, then the named vector and named list are equivalent. If you want to start with different fixed effects per factor level in your data, you need to use a list.
param is used to define random effects and factor-modeled fixed effects (the information after the second tilde in #5 moved here).
residualModel has the residual error model which is sent to model() as the right-hand-side of the prediction.

The most complex element is that param now defines both fixed and random effects based on the way it will be used. This is the way that brms defines its fixed and random effects (see example 3 in https://cran.r-project.org/web/packages/brms/vignettes/brms_multilevel.pdf). (With minimal modification, we could even make this function take in a brms::bf() object as the object argument where that would encompass the object and param arguments.)

An example call would be:

  nlmixr2.formula(
    height ~ Asym+(R0-Asym)*exp(-exp(lrc)*age),
    data = Loblolly,
    start = list(Asym = 103, R0 = -8.5, lrc = -3.3, add_err=1),
    param =
      list(
        Asym~species+(1|Seed),
        lrc~1|Seed
      ),
    est=NULL
  )

(This example doesn't actually work since "species" isn't in the Loblolly data. It is just to show an example.)

This would specify a model where Asym has a separate fixed effect estimated per level of the Loblolly$species factor. There are random effects for Asym and lrc on the Seed identifier.

This is very close to what was just discussed in the team meeting earlier. The only notable difference is moving the random effect specification into param. The benefits of moving it to param are:

There is a consistent interface to creating parameters rather than some parameters created after an unusual second tilde and others created within param.
It simplifies the way that parameters can be considered all in one place (so, there should be fewer user errors).
Generating appropriate mu-referenced covariates should be easier. (i.e. the code should be easier to maintain.)

Discussion: Reconsider `extract_eq()` in favor of `knit_print(..., type = "equations")`?

I was thinking about how we could be most helpful for making outputs, and since we're not really using any of the equatiomatic code, I thought that a knit_print method may be simpler for users to find and use.

The benefit is that:

this would remove the dependency on equatiomatic in favor of the existing suggests for knitr and
I think that knit_print is a more familiar method for printing things in knitr documents.

Thoughts?

Readme.rmd example code fails to knit

I was trying to re-knit Readme.Rmd, and the code in the example chunk succeeds when run manually, but it fails when knit.

The error appears with a warning for cli::cli_alert_danger() because .env$mod_idx - 1 starts with a dot.

Unnecessary file? nlmixr2extra.dll

I was just trying out current git versions of packages, and I noticed the "nlmixr2extra.dll" file. Should it be removed (and a .gitignore of .dll be added)?

Feature request: Allow `knit_print` for equations to have an argument of the maximum number of equations to include before a new `align*` block

nlmixr2extra/R/knit_printEquation.R

Lines 12 to 26 in 43690d3

 knit_print.nlmixr2FitCore <- function(x, ..., output = "equations") { 

 output <- match.arg(output) 

 if ("equations" %in% output) { 

 ret <- 

 paste0( 

 "\\begin{align*}\n", 

 paste( 

 extractEqHelper(x = x, ...), 

 collapse = " \\\\\n" 

 ), 

 "\n\\end{align*}\n" 

 ) 

 } 

 knitr::asis_output(ret) 

 }

SCM filter result problem

How can I solve this problem?I use the saem algorithm,
Error in covSearchRes[[which.min(resTable$pchisqr)]][[1]] :
wrong arguments for subsetting an environment

adaptivelassoCoefficients example gives error

When running the following code, I get the error below.

one.cmt <- function() {
  ini({
    ## You may label each parameter with a comment
    tka <- 0.45 # Log Ka
    tcl <- log(c(0, 2.7, 100)) # Log Cl
    ## This works with interactive models
    ## You may also label the preceding line with label("label text")
    tv <- 3.45; label("log V")
    ## the label("Label name") works with all models
    eta.ka ~ 0.6
    eta.cl ~ 0.3
    eta.v ~ 0.1
    add.sd <- 0.7
  })
  model({
    ka <- exp(tka + eta.ka)
    cl <- exp(tcl + eta.cl)
    v <- exp(tv + eta.v)
    linCmt() ~ add(add.sd)
  })
}

d <- nlmixr2data::theo_sd
d$SEX <-0
d$SEX[d$ID<=6] <-1

fit <- nlmixr2(one.cmt, d, est = "focei", control = nlmixr2est::foceiControl(print = 0))
varsVec <- c("ka","cl","v")
covarsVec <- c("WT")
catvarsVec <- c("SEX")

# Adaptive Lasso coefficients:

lassoDf <- adaptivelassoCoefficients(fit, varsVec, covarsVec, catvarsVec)

✔ Training and Testing data sets successfully created for cross-validation for fold number 1
Error : missing 'SEX_0' in data
[1] "error fitting the model for the training dataset "
<simpleError: missing 'SEX_0' in data>
Error : missing 'SEX_0' in data
[1] "error fitting the model for the testing dataset "
<simpleError: missing 'SEX_0' in data>
✖ the 'fit' object needs to have an objective functions value associated with it
ℹ try computing 'fit$objDf$$`Log-likelihood`' in console to compute and store the corresponding OBJF value
Error: aborting...objf value not associated with the current 'fit' object

Remove reference to rxode2parse and possible removed pkgs

linearization

Feature request: equations generation

I find it easier to have discussions for features on the issues side and to have a more code-focused discussion on the PR side. So, I'm opening this after the fact for PR #28.

A few notes:

I think that the easiest way to test the outputs is to run cat(extract_eq()) with the model and then paste that into an online LaTeX formatter (e.g. https://quicklatex.com/) to check it.
I'm not so happy with the way that if blocks are formatted. I'm open to any feedback on the formatting, and if blocks probably need some special attention. (All ideas are welcome, even if they don't have a clear way to implement them in LaTeX to start.)

I have used math notation rather than code notation for some symbols (most notably the logical operators as shown by running

nlmixr2extra/tests/testthat/test-extract_eq.R

Line 68 in 976014f

extract_eq(ui),

). I'm not sure if that is better (because it aligns more consistently with math) or worse (because it is farther from the model code). I'm open to input there. The code for the selected operators is at

nlmixr2extra/R/extract_eq.R

Lines 223 to 236 in 976014f

 latexOpMap <- 

 list( 

 "<"="<", 

 "<="="\\leq", 

 "=="="\\equiv", 

 ">="="\\geq", 

 ">"=">", 

 "&"="\\land", 

 "&&"="\\land", 

 "|"="\\lor", 

 "||"="\\lor", 

 "!="="\\ne", 

 "!"="\\lnot" 

 )

It took some looking for how to handle named arguments (e.g. cp ~ c(p0=0, p1=1, p2=2, 3)). I put name handing in for character and numeric values in the parse tree. It's not clear to me if there are situations where that will break. (I didn't expect for the names to show up in the way that they do, so I don't fully understand that part of the parse tree.) If you have ideas of other ways that names may show up, I want to check that I have that part right.
I don't think that there is significant benefit to matching the extract_eq() generic at this time. And there is a downside of many ignored arguments. If people may move between nlmixr2 and other supported packages and want to use the same function for extraction, there is a benefit, but I don't know how common that is. (I do it from time to time, but I'm likely in the minority.)

Covariate search issue, it seems for backward search it has to look for "fit" object

### Noticed the following error with the example model:

library(nlmixr2)
library(rxode2)
library(vpc)
library(xpose)
library(xpose.nlmixr2)
library(ggplot2)

pheno <- function() {
ini({
tcl <- log(0.008) # typical value of clearance
tv <- log(0.6) # typical value of volume
## var(eta.cl)
eta.cl + eta.v ~ c(1,
0.01, 1) ## cov(eta.cl, eta.v), var(eta.v)
# interindividual variability on clearance and volume
prop.err <- 0.1 # residual variability
})
model({
cl <- exp(tcl + eta.cl) # individual value of clearance
v <- exp(tv + eta.v) # individual value of volume
ke <- cl / v # elimination rate constant
d/dt(A1) = - ke * A1 # model differential equation
cp = A1 / v # concentration in plasma
cp ~ prop(prop.err) # define error model
})
}

fit_saem <- nlmixr(pheno, pheno_sd, "saem",
control=list(print=0),
table=list(cwres=TRUE, npde=TRUE))

rxode2::.rxWithWd(tempdir(), {# with temporary directory

auto3 <- covarSearchAuto(fit_saem, varsVec = c("v", "cl"), covarsVec = c("WT"),
catvarsVec = c("APGR"), restart = TRUE,
searchType = "backward", pVal=list(fwd=0.01,bck=0.001))
})
Error in inherits(fit, "nlmixr2FitCore") : object 'fit' not found

**However When I rename fit_saem to fit it seems to bypass this error. Is it a possible bug? This however ran into another error of "matrix multiplication: problem with matrix inverse;" So it seems whenever a model failed (probably due to over parameterization, an inherent process with most of covariate search models), the covariate search can not go on? **

fit=fit_saem
rxode2::.rxWithWd(tempdir(), {# with temporary directory

auto3 <- covarSearchAuto(fit, varsVec = c("v", "cl"), covarsVec = c("WT"),
catvarsVec = c("APGR"), restart = TRUE,
searchType = "backward", pVal=list(fwd=0.01,bck=0.001))
})

── starting backward search... ────────────────────────────────────────
ℹ use control from pipeline
→ loading into symengine environment...
→ pruning branches (if/else) of saem model...
✔ done
→ finding duplicate expressions in saem model...
[====|====|====|====|====|====|====|====|====|====] 0:00:00

✔ done
Error in .model$saem_mod(.cfg) :
matrix multiplication: problem with matrix inverse; suggest to use solve() instead
Error: matrix multiplication: problem with matrix inverse; suggest to use solve() instead

Use `ui$varLhs` instead of pureMuRef when availalble.

Use `rxode2random`

SCM not always selecting the correct model

I am testing stepwise covariate model-selection method (covarSearchAuto function) in nlmixr package and had some confusing outputs (see below output table);
I tested three covariates (WT: body weight, WT2: normalized body weight and Sex) on two PK parameters (cl and v from simulated one compartment PK data);
In forward search step 1, SEX on v has the lowest deltaOBjf value (-829.5506), however WT on cl was included (deltaObjf = -681.329) as “yes”? I am not sure why WT on cl was included (which also doesn’t have the lowest AIC or BIC?)
Did I miss anything?
I checked Nov 2, 2021 version nlmixr package help Manuel, didn’t find useful information.
Any explanation or suggested readings on this? Appreciated for your help in advance.

covariate search -- "object covInfo' not found error

rxode2::.rxWithWd(tempdir(), {# with temporary directory
library(nlmixr2)
library(rxode2)
library(vpc)
library(xpose)
library(xpose.nlmixr2)
library(ggplot2)

fit_focei <- nlmixr(pheno, pheno_sd, "focei",
control=list(print=0),
table=list(cwres=TRUE, npde=TRUE))

auto3 <- covarSearchAuto(fit_focei, varsVec = c("v", "cl"), covarsVec = c("WT","APGR"),
restart = TRUE,
searchType = "backward", pVal=list(fwd=0.01,bck=0.001))
})

.... # it was running for quite a while and everything seems OK, then it comes the error below;

Error in backwardSearch(varsVec, covarsVec, catvarsVec, fitorig = fit, :
object 'covInfo' not found

Feature Request: Extract the all bootstrap parameters

Hello I am Miss Khayam Miriam and I contact you to ask you questions .

Currently I am working using nlmixr2’s boostrap on a scientific project and I used the following function:

sticker <-boostrapFit( run_37 ,nboot= 200 ,restart = TRUE) , at the end I get some results but similar to those of the estimates.

What I would like to ask is how can I get and where can I find the results table containing all the bootstraps?
and do the results obtained correspond to an average of all bootstraps or just to the last?
thank you in advance

BootstrapFit 95CI calculation issue

Hi @mattfidler

I find that there might be an issue on the bootstrapFit statistics calculation when the stdErrType was set to "se".
Please see the related bootstrapfit code (https://github.com/nlmixr2/nlmixr2extra/blob/main/R/computingutil.R#L1151) line 1150-1153

Currently there are two options for bootstrap summary if I understand correctly.

Default setting "perc". 95CI (if ci=0.95) was derived from 2.5th, and 97.5th percentiles of the parameter estimates from a bootstrap.
stdErrType= "se". However, for this option, CI was calculated as follows, it seems that CI was computed based on mean and sd.

 if (stdErrType != "perc") {
        confLower <- mn - qnorm(quantLevels[[2]]) * sd
        confUpper <- mn + qnorm(quantLevels[[3]]) * sd
      }
confLower <- mn - qnorm(0.025) * sd  
But qnorm(0.025 )= - 1.96

I think it should be confLower <- mn + qnorm(0.025) * sd at least. (Additionally, given that for parfixed 95CI = typical estimate +/ - 1.96 * se, so whether we should use se instead of sd as well.)

I tested the example dataset to see how nlimixr2 bootstrapfit function output when stdErrType was set to "se" and find the lower values and upper values for 95CI are same (as expected).

Many thanks in advance.

library(nlmixr2)
one.cmt <- function() {
  ini({
    ## You may label each parameter with a comment
    tka <- 0.45 # Log Ka
    tcl <- 1 # Log Cl
    ## This works with interactive models
    ## You may also label the preceding line with label("label text")
    tv <- 3.45
    label("log V")
    ## the label("Label name") works with all models
    eta.ka ~ 0.6
    eta.cl ~ 0.3
    eta.v ~ 0.1
    add.sd <- 0.7
  })
  model({
    ka <- exp(tka + eta.ka)
    cl <- exp(tcl + eta.cl)
    v <- exp(tv + eta.v)
    linCmt() ~ add(add.sd)
  })
}

fit <- nlmixr2(one.cmt, theo_sd, "focei")
results<-bootstrapFit(fit, nboot=10,stdErrType = "se")

results$env$bootSummary$parFixedDf$confLower
results$env$bootSummary$parFixedDf$confUpper

ℹ parameter labels from comments will be replaced by 'label()'
Key: U: Unscaled Parameters; X: Back-transformed parameters; G: Gill difference gradient approximation
F: Forward difference gradient approximation
C: Central difference gradient approximation
M: Mixed forward and central difference gradient approximation
Unscaled parameters for Omegas=chol(solve(omega));
Diagonals are transformed, as specified by foceiControl(diagXform=)
|-----+---------------+-----------+-----------+-----------+-----------+-----------+-----------+-----------|
|    #| Objective Fun |       tka |       tcl |        tv |    add.sd |        o1 |        o2 |        o3 |
|    1|     133.56589 |    -1.000 |   -0.6333 |     1.000 |   -0.8333 |   -0.5425 |   -0.3992 |   -0.1145 |
|    U|     133.56589 |    0.4500 |     1.000 |     3.450 |    0.7000 |     1.136 |     1.351 |     1.778 |
|    X|     133.56589 |     1.568 |     2.718 |     31.50 |    0.7000 |     1.136 |     1.351 |     1.778 |
|    G|    Gill Diff. |   -0.9228 |    -1.099 |    -3.023 |     1.554 |    -9.141 |    -19.37 |    -10.99 |
|    2|     125.53391 |   -0.9621 |   -0.5882 |     1.124 |   -0.8971 |   -0.1673 |    0.3961 |    0.3369 |
|    U|     125.53391 |    0.4879 |     1.045 |     3.574 |    0.6777 |     1.466 |     1.940 |     2.032 |
|    X|     125.53391 |     1.629 |     2.844 |     35.66 |    0.6777 |     1.466 |     1.940 |     2.032 |
|    F| Forward Diff. |     1.176 |     13.34 |     40.80 |    -7.235 |     17.80 |    -1.492 |    -4.942 |
|    3|     238.64181 |   -0.9630 |   -0.8250 |    0.3920 |   -0.7919 |   -0.2977 |    0.8939 |    0.7002 |
|    U|     238.64181 |    0.4870 |    0.8083 |     2.842 |    0.7145 |     1.352 |     2.308 |     2.236 |
|    X|     238.64181 |     1.627 |     2.244 |     17.15 |    0.7145 |     1.352 |     2.308 |     2.236 |
|    4|     122.09993 |   -0.9653 |   -0.6241 |     1.014 |   -0.8777 |   -0.2152 |    0.4001 |    0.3502 |
|    U|     122.09993 |    0.4847 |     1.009 |     3.464 |    0.6845 |     1.424 |     1.943 |     2.040 |
|    X|     122.09993 |     1.624 |     2.743 |     31.96 |    0.6845 |     1.424 |     1.943 |     2.040 |
|    F| Forward Diff. |     1.770 |    0.5434 |   -0.8952 |    -4.196 |     14.78 |    -1.854 |    -7.133 |
|    5|     120.44828 |   -0.9784 |   -0.6281 |     1.021 |   -0.8465 |   -0.3248 |    0.4139 |    0.4031 |
|    U|     120.44828 |    0.4716 |     1.005 |     3.471 |    0.6954 |     1.328 |     1.953 |     2.069 |
|    X|     120.44828 |     1.603 |     2.732 |     32.17 |    0.6954 |     1.328 |     1.953 |     2.069 |
|    6|     119.87106 |   -0.9921 |   -0.6324 |     1.028 |   -0.8140 |   -0.4395 |    0.4282 |    0.4585 |
|    U|     119.87106 |    0.4579 |     1.001 |     3.478 |    0.7068 |     1.227 |     1.964 |     2.100 |
|    X|     119.87106 |     1.581 |     2.721 |     32.39 |    0.7068 |     1.227 |     1.964 |     2.100 |
|    F| Forward Diff. |   -0.9068 |    -1.897 |     5.385 |     3.542 |    -1.699 |    -1.449 |    -6.016 |
|    7|     120.04280 |   -0.9767 |   -0.5799 |    0.9463 |   -0.8829 |   -0.4342 |    0.5335 |    0.6643 |
|    U|      120.0428 |    0.4733 |     1.053 |     3.396 |    0.6826 |     1.232 |     2.042 |     2.216 |
|    X|      120.0428 |     1.605 |     2.868 |     29.85 |    0.6826 |     1.232 |     2.042 |     2.216 |
|    8|     119.89347 |   -0.9808 |   -0.6076 |    0.9612 |   -0.8587 |   -0.4196 |    0.4507 |    0.5391 |
|    U|     119.89347 |    0.4692 |     1.026 |     3.411 |    0.6911 |     1.244 |     1.980 |     2.146 |
|    X|     119.89347 |     1.599 |     2.789 |     30.30 |    0.6911 |     1.244 |     1.980 |     2.146 |
|    9|     119.60548 |   -0.9864 |   -0.6203 |    0.9938 |   -0.8365 |   -0.4287 |    0.4374 |    0.4966 |
|    U|     119.60548 |    0.4636 |     1.013 |     3.444 |    0.6989 |     1.236 |     1.970 |     2.122 |
|    X|     119.60548 |     1.590 |     2.754 |     31.30 |    0.6989 |     1.236 |     1.970 |     2.122 |
|    F| Forward Diff. |   -0.2049 |    0.6230 |    -8.751 |     1.243 |   -0.6812 |    -1.144 |    -5.799 |
|   10|     119.28501 |   -0.9846 |   -0.6280 |     1.028 |   -0.8435 |   -0.4248 |    0.4551 |    0.5398 |
|    U|     119.28501 |    0.4654 |     1.005 |     3.478 |    0.6964 |     1.240 |     1.983 |     2.146 |
|    X|     119.28501 |     1.593 |     2.733 |     32.41 |    0.6964 |     1.240 |     1.983 |     2.146 |
|    F| Forward Diff. |   -0.4998 |   -0.6105 |     6.319 |    0.9412 |   -0.5328 |   -0.8273 |    -5.436 |
|   11|     119.02933 |   -0.9815 |   -0.6313 |    0.9995 |   -0.8464 |   -0.4189 |    0.4723 |    0.5879 |
|    U|     119.02933 |    0.4685 |     1.002 |     3.450 |    0.6954 |     1.245 |     1.996 |     2.173 |
|    X|     119.02933 |     1.598 |     2.724 |     31.49 |    0.6954 |     1.245 |     1.996 |     2.173 |
|    F| Forward Diff. |  -0.03383 |    -2.584 |    -7.122 |    0.4805 |  -0.01802 |   -0.3739 |    -5.113 |
|   12|     118.75495 |   -0.9815 |   -0.6174 |     1.024 |   -0.8400 |   -0.4180 |    0.4873 |    0.6374 |
|    U|     118.75495 |    0.4685 |     1.016 |     3.474 |    0.6977 |     1.246 |     2.007 |     2.201 |
|    X|     118.75495 |     1.598 |     2.762 |     32.26 |    0.6977 |     1.246 |     2.007 |     2.201 |
|    F| Forward Diff. |   -0.2053 |     2.700 |     5.076 |     1.373 |   -0.1064 |   -0.1015 |    -4.764 |
|   13|     118.51992 |   -0.9813 |   -0.6392 |     1.009 |   -0.8479 |   -0.4138 |    0.4928 |    0.6894 |
|    U|     118.51992 |    0.4687 |    0.9942 |     3.459 |    0.6949 |     1.249 |     2.011 |     2.230 |
|    X|     118.51992 |     1.598 |     2.703 |     31.78 |    0.6949 |     1.249 |     2.011 |     2.230 |
|    F| Forward Diff. |   -0.1382 |    -4.825 |    -3.164 |    0.3100 |    0.2980 |   0.07789 |    -4.440 |
|   14|     118.28693 |   -0.9818 |   -0.6111 |     1.015 |   -0.8453 |   -0.4192 |    0.4885 |    0.7407 |
|    U|     118.28693 |    0.4682 |     1.022 |     3.465 |    0.6958 |     1.245 |     2.008 |     2.259 |
|    X|     118.28693 |     1.597 |     2.779 |     31.97 |    0.6958 |     1.245 |     2.008 |     2.259 |
|    F| Forward Diff. |  -0.05725 |     4.316 |     1.063 |    0.8054 |   -0.1731 |    0.1295 |    -4.105 |
|   15|     118.09318 |   -0.9815 |   -0.6395 |     1.016 |   -0.8494 |   -0.4147 |    0.4813 |    0.7918 |
|    U|     118.09318 |    0.4685 |    0.9938 |     3.466 |    0.6944 |     1.249 |     2.003 |     2.288 |
|    X|     118.09318 |     1.598 |     2.701 |     32.02 |    0.6944 |     1.249 |     2.003 |     2.288 |
|    F| Forward Diff. |   -0.2133 |    -4.714 |     1.014 |   0.09620 |    0.1167 |   0.02736 |    -3.767 |
|   16|     117.92220 |   -0.9808 |   -0.6138 |     1.003 |   -0.8406 |   -0.4136 |    0.4747 |    0.8422 |
|    U|      117.9222 |    0.4692 |     1.020 |     3.453 |    0.6975 |     1.250 |     1.998 |     2.316 |
|    X|      117.9222 |     1.599 |     2.772 |     31.60 |    0.6975 |     1.250 |     1.998 |     2.316 |
|    F| Forward Diff. |    0.1794 |     2.830 |    -5.604 |     1.343 |    0.1409 |   0.02118 |    -3.470 |
|   17|     117.93331 |   -0.9829 |   -0.6165 |     1.038 |   -0.8506 |   -0.4127 |    0.4697 |    0.8883 |
|    U|     117.93331 |    0.4671 |     1.017 |     3.488 |    0.6940 |     1.250 |     1.994 |     2.342 |
|    X|     117.93331 |     1.595 |     2.764 |     32.74 |    0.6940 |     1.250 |     1.994 |     2.342 |
|   18|     117.86900 |   -0.9815 |   -0.6249 |     1.025 |   -0.8459 |   -0.4141 |    0.4746 |    0.8559 |
|    U|       117.869 |    0.4685 |     1.008 |     3.475 |    0.6956 |     1.249 |     1.998 |     2.324 |
|    X|       117.869 |     1.598 |     2.741 |     32.30 |    0.6956 |     1.249 |     1.998 |     2.324 |
|    F| Forward Diff. |   -0.2303 |    0.2415 |     7.070 |    0.6746 |   0.07709 | -0.002871 |    -3.307 |
|   19|     117.75784 |   -0.9825 |   -0.6249 |     1.008 |   -0.8499 |   -0.4164 |    0.4718 |    0.8787 |
|    U|     117.75784 |    0.4675 |     1.008 |     3.458 |    0.6942 |     1.247 |     1.996 |     2.337 |
|    X|     117.75784 |     1.596 |     2.741 |     31.77 |    0.6942 |     1.247 |     1.996 |     2.337 |
|    F| Forward Diff. |  -0.04987 |   -0.4907 |    -2.816 |    0.2367 |  -0.09658 |   0.01529 |    -3.236 |
|   20|     117.68448 |   -0.9825 |   -0.6188 |     1.019 |   -0.8493 |   -0.4143 |    0.4701 |    0.9047 |
|    U|     117.68448 |    0.4675 |     1.015 |     3.469 |    0.6944 |     1.249 |     1.995 |     2.351 |
|    X|     117.68448 |     1.596 |     2.758 |     32.10 |    0.6944 |     1.249 |     1.995 |     2.351 |
|    F| Forward Diff. |   -0.1474 |     1.835 |     3.880 |    0.3842 |   0.01846 |   0.03522 |    -3.048 |
|   21|     117.60226 |   -0.9816 |   -0.6231 |     1.008 |   -0.8439 |   -0.4105 |    0.4681 |    0.9302 |
|    U|     117.60226 |    0.4684 |     1.010 |     3.458 |    0.6963 |     1.252 |     1.993 |     2.366 |
|    X|     117.60226 |     1.597 |     2.746 |     31.76 |    0.6963 |     1.252 |     1.993 |     2.366 |
|    F| Forward Diff. |   0.04319 |   0.03033 |    -2.848 |    0.9511 |    0.2859 |   0.03635 |    -2.926 |
|   22|     117.53027 |   -0.9828 |   -0.6235 |     1.018 |   -0.8520 |   -0.4155 |    0.4633 |    0.9551 |
|    U|     117.53027 |    0.4672 |     1.010 |     3.468 |    0.6935 |     1.248 |     1.990 |     2.380 |
|    X|     117.53027 |     1.595 |     2.745 |     32.07 |    0.6935 |     1.248 |     1.990 |     2.380 |
|    F| Forward Diff. |   -0.1726 |    0.2798 |     3.463 |  0.009058 |   -0.1508 |  -0.02163 |    -2.733 |
|   23|     117.46000 |   -0.9834 |   -0.6194 |     1.008 |   -0.8532 |   -0.4153 |    0.4607 |    0.9815 |
|    U|        117.46 |    0.4666 |     1.014 |     3.458 |    0.6930 |     1.248 |     1.988 |     2.395 |
|    X|        117.46 |     1.595 |     2.756 |     31.74 |    0.6930 |     1.248 |     1.988 |     2.395 |
|    F| Forward Diff. |  -0.01246 |     1.037 |    -3.030 |  -0.01893 |   -0.1124 | -0.003143 |    -2.630 |
|   24|     117.39849 |   -0.9824 |   -0.6230 |     1.016 |   -0.8421 |   -0.4083 |    0.4628 |     1.005 |
|    U|     117.39849 |    0.4676 |     1.010 |     3.466 |    0.6969 |     1.254 |     1.989 |     2.408 |
|    X|     117.39849 |     1.596 |     2.746 |     32.00 |    0.6969 |     1.254 |     1.989 |     2.408 |
|    F| Forward Diff. |  -0.08394 |    0.3339 |     2.254 |    0.9620 |    0.2984 |   0.05298 |    -2.453 |
|   25|     117.33981 |   -0.9817 |   -0.6246 |     1.007 |   -0.8475 |   -0.4114 |    0.4587 |     1.031 |
|    U|     117.33981 |    0.4683 |     1.009 |     3.457 |    0.6950 |     1.252 |     1.986 |     2.423 |
|    X|     117.33981 |     1.597 |     2.742 |     31.71 |    0.6950 |     1.252 |     1.986 |     2.423 |
|    F| Forward Diff. |   0.09415 |   -0.6344 |    -4.012 |    0.5570 |    0.1144 |   0.03751 |    -2.336 |
|   26|     117.28338 |   -0.9840 |   -0.6180 |     1.015 |   -0.8583 |   -0.4165 |    0.4517 |     1.054 |
|    U|     117.28338 |    0.4660 |     1.015 |     3.465 |    0.6913 |     1.247 |     1.981 |     2.436 |
|    X|     117.28338 |     1.594 |     2.760 |     31.96 |    0.6913 |     1.247 |     1.981 |     2.436 |
|    F| Forward Diff. |   -0.1276 |     1.668 |     1.993 |   -0.5498 |   -0.2537 |  -0.03359 |    -2.193 |
|   27|     117.22199 |   -0.9853 |   -0.6209 |     1.009 |   -0.8505 |   -0.4117 |    0.4501 |     1.081 |
|    U|     117.22199 |    0.4647 |     1.012 |     3.459 |    0.6940 |     1.251 |     1.980 |     2.450 |
|    X|     117.22199 |     1.592 |     2.752 |     31.79 |    0.6940 |     1.251 |     1.980 |     2.450 |
|   28|     117.16849 |   -0.9884 |   -0.6160 |     1.011 |   -0.8402 |   -0.4048 |    0.4471 |     1.114 |
|    U|     117.16849 |    0.4616 |     1.017 |     3.461 |    0.6976 |     1.257 |     1.978 |     2.469 |
|    X|     117.16849 |     1.587 |     2.766 |     31.85 |    0.6976 |     1.257 |     1.978 |     2.469 |
|   29|     117.15894 |   -0.9954 |   -0.6049 |     1.016 |   -0.8168 |   -0.3892 |    0.4402 |     1.191 |
|    U|     117.15894 |    0.4546 |     1.028 |     3.466 |    0.7058 |     1.271 |     1.972 |     2.512 |
|    X|     117.15894 |     1.576 |     2.797 |     32.00 |    0.7058 |     1.271 |     1.972 |     2.512 |
|    F| Forward Diff. |   -0.6095 |     5.601 |     4.079 |     3.536 |     1.393 |   0.07133 |    -1.491 |
|   30|     116.91883 |   -0.9779 |   -0.6326 |     1.008 |   -0.8278 |   -0.4074 |    0.4185 |     1.330 |
|    U|     116.91883 |    0.4721 |     1.001 |     3.458 |    0.7019 |     1.255 |     1.956 |     2.591 |
|    X|     116.91883 |     1.603 |     2.720 |     31.76 |    0.7019 |     1.255 |     1.956 |     2.591 |
|    F| Forward Diff. |    0.3779 |    -3.174 |    -3.015 |     2.261 |   0.05491 |   -0.1463 |   -0.8005 |
|   31|     117.05590 |    -1.035 |   -0.6072 |    0.9922 |   -0.8649 |   -0.4192 |    0.4632 |     1.447 |
|    U|      117.0559 |    0.4148 |     1.026 |     3.442 |    0.6890 |     1.245 |     1.989 |     2.657 |
|    X|      117.0559 |     1.514 |     2.790 |     31.25 |    0.6890 |     1.245 |     1.989 |     2.657 |
|   32|     116.85247 |   -0.9951 |   -0.6184 |     1.010 |   -0.8433 |   -0.4109 |    0.4316 |     1.365 |
|    U|     116.85247 |    0.4549 |     1.015 |     3.460 |    0.6965 |     1.252 |     1.966 |     2.610 |
|    X|     116.85247 |     1.576 |     2.759 |     31.82 |    0.6965 |     1.252 |     1.966 |     2.610 |
|    F| Forward Diff. |   -0.5352 |     1.007 |    0.1002 |    0.7417 |   -0.2178 |    0.1617 |   -0.5949 |
|   33|     116.84944 |   -0.9640 |   -0.6162 |     1.010 |   -0.8471 |   -0.4124 |    0.4096 |     1.392 |
|    U|     116.84944 |    0.4860 |     1.017 |     3.460 |    0.6952 |     1.251 |     1.950 |     2.625 |
|    X|     116.84944 |     1.626 |     2.765 |     31.83 |    0.6952 |     1.251 |     1.950 |     2.625 |
|    F| Forward Diff. |     1.173 |     1.721 |  -0.08883 |    0.4017 |   -0.1814 |   -0.2185 |   -0.4948 |
|   34|     116.85388 |   -0.9765 |   -0.6344 |     1.011 |   -0.8514 |   -0.4105 |    0.4119 |     1.397 |
|    U|     116.85388 |    0.4735 |    0.9989 |     3.461 |    0.6937 |     1.252 |     1.951 |     2.628 |
|    X|     116.85388 |     1.606 |     2.715 |     31.86 |    0.6937 |     1.252 |     1.951 |     2.628 |
|   35|     116.83786 |   -0.9697 |   -0.6246 |     1.011 |   -0.8491 |   -0.4115 |    0.4107 |     1.394 |
|    U|     116.83786 |    0.4803 |     1.009 |     3.461 |    0.6945 |     1.252 |     1.951 |     2.627 |
|    X|     116.83786 |     1.616 |     2.742 |     31.84 |    0.6945 |     1.252 |     1.951 |     2.627 |
|    F| Forward Diff. |    0.8144 |   -0.7318 |  -0.06366 |    0.1825 |   -0.1862 |   -0.1941 |   -0.4818 |
|   36|     116.83077 |   -0.9764 |   -0.6189 |     1.011 |   -0.8507 |   -0.4100 |    0.4111 |     1.400 |
|    U|     116.83077 |    0.4736 |     1.014 |     3.461 |    0.6939 |     1.253 |     1.951 |     2.630 |
|    X|     116.83077 |     1.606 |     2.758 |     31.85 |    0.6939 |     1.253 |     1.951 |     2.630 |
|    F| Forward Diff. |    0.4822 |    0.9052 |    0.6928 |    0.1889 |  -0.07033 |   -0.1642 |   -0.4516 |
|   37|     116.82941 |   -0.9789 |   -0.6226 |     1.007 |   -0.8522 |   -0.4099 |    0.4122 |     1.409 |
|    U|     116.82941 |    0.4711 |     1.011 |     3.457 |    0.6934 |     1.253 |     1.952 |     2.635 |
|    X|     116.82941 |     1.602 |     2.748 |     31.73 |    0.6934 |     1.253 |     1.952 |     2.635 |
|    F| Forward Diff. |    0.4090 |   -0.4196 |    -2.860 |   -0.1438 |   -0.1096 |   -0.1218 |   -0.4260 |
|   38|     116.82063 |   -0.9785 |   -0.6228 |     1.011 |   -0.8516 |   -0.4100 |    0.4151 |     1.418 |
|    U|     116.82063 |    0.4715 |     1.010 |     3.461 |    0.6936 |     1.253 |     1.954 |     2.640 |
|    X|     116.82063 |     1.602 |     2.747 |     31.84 |    0.6936 |     1.253 |     1.954 |     2.640 |
|    F| Forward Diff. |    0.3595 |   -0.2720 |    0.3901 |  -0.07876 |   -0.1483 |  -0.05968 |   -0.3532 |
|   39|     116.81692 |   -0.9800 |   -0.6216 |     1.010 |   -0.8515 |   -0.4095 |    0.4120 |     1.428 |
|    U|     116.81692 |    0.4700 |     1.012 |     3.460 |    0.6936 |     1.253 |     1.952 |     2.646 |
|    X|     116.81692 |     1.600 |     2.750 |     31.80 |    0.6936 |     1.253 |     1.952 |     2.646 |
|   40|     116.81368 |   -0.9802 |   -0.6214 |     1.010 |   -0.8520 |   -0.4096 |    0.4073 |     1.441 |
|    U|     116.81368 |    0.4698 |     1.012 |     3.460 |    0.6935 |     1.253 |     1.948 |     2.653 |
|    X|     116.81368 |     1.600 |     2.751 |     31.81 |    0.6935 |     1.253 |     1.948 |     2.653 |
|   41|     116.80995 |   -0.9812 |   -0.6205 |     1.010 |   -0.8529 |   -0.4096 |    0.3961 |     1.471 |
|    U|     116.80995 |    0.4688 |     1.013 |     3.460 |    0.6932 |     1.253 |     1.940 |     2.670 |
|    X|     116.80995 |     1.598 |     2.753 |     31.82 |    0.6932 |     1.253 |     1.940 |     2.670 |
|    F| Forward Diff. |    0.2588 |    0.2697 |    0.2402 |   -0.1545 |   -0.1343 |   -0.3180 |   -0.1521 |
|   42|     116.81334 |   -0.9764 |   -0.6201 |     1.008 |   -0.8520 |   -0.4112 |    0.4305 |     1.515 |
|    U|     116.81334 |    0.4736 |     1.013 |     3.458 |    0.6935 |     1.252 |     1.965 |     2.694 |
|    X|     116.81334 |     1.606 |     2.755 |     31.76 |    0.6935 |     1.252 |     1.965 |     2.694 |
|   43|     116.80634 |   -0.9803 |   -0.6213 |     1.008 |   -0.8520 |   -0.4097 |    0.4109 |     1.489 |
|    U|     116.80634 |    0.4697 |     1.012 |     3.458 |    0.6935 |     1.253 |     1.951 |     2.680 |
|    X|     116.80634 |     1.600 |     2.751 |     31.77 |    0.6935 |     1.253 |     1.951 |     2.680 |
|    F| Forward Diff. |    0.3489 |  -0.03353 |    -1.349 |   -0.1725 |   -0.1656 |  0.008266 |  -0.05480 |
|   44|     116.80455 |   -0.9864 |   -0.6238 |     1.010 |   -0.8487 |   -0.4070 |    0.4085 |     1.507 |
|    U|     116.80455 |    0.4636 |     1.010 |     3.460 |    0.6946 |     1.255 |     1.949 |     2.690 |
|    X|     116.80455 |     1.590 |     2.744 |     31.82 |    0.6946 |     1.255 |     1.949 |     2.690 |
|    F| Forward Diff. |  -0.02336 |   -0.7081 |    0.3472 |    0.1800 |  -0.02895 | -0.006532 |   0.02779 |
|   45|     116.80455 |   -0.9864 |   -0.6238 |     1.010 |   -0.8487 |   -0.4070 |    0.4085 |     1.507 |
|    U|     116.80455 |    0.4636 |     1.010 |     3.460 |    0.6946 |     1.255 |     1.949 |     2.690 |
|    X|     116.80455 |     1.590 |     2.744 |     31.82 |    0.6946 |     1.255 |     1.949 |     2.690 |
calculating covariance matrix
[====|====|====|====|====|====|====|====|====|====] 0:00:00 
done
→ Calculating residuals/tables
✔ done
→ compress origData in nlmixr2 object, save 5952
→ compress parHistData in nlmixr2 object, save 5864
> results<-bootstrapFit(fit, nboot=10,stdErrType = "se")

── Running nlmixr2 for model index: 1 ───────────────────────────────────────────────────────────────────────────────────────────────────────
done

── Running nlmixr2 for model index: 2 ───────────────────────────────────────────────────────────────────────────────────────────────────────
done

── Running nlmixr2 for model index: 3 ───────────────────────────────────────────────────────────────────────────────────────────────────────
done

── Running nlmixr2 for model index: 4 ───────────────────────────────────────────────────────────────────────────────────────────────────────
done

── Running nlmixr2 for model index: 5 ───────────────────────────────────────────────────────────────────────────────────────────────────────
done

── Running nlmixr2 for model index: 6 ───────────────────────────────────────────────────────────────────────────────────────────────────────
done

── Running nlmixr2 for model index: 7 ───────────────────────────────────────────────────────────────────────────────────────────────────────
done

── Running nlmixr2 for model index: 8 ───────────────────────────────────────────────────────────────────────────────────────────────────────
done

── Running nlmixr2 for model index: 9 ───────────────────────────────────────────────────────────────────────────────────────────────────────
done

── Running nlmixr2 for model index: 10 ──────────────────────────────────────────────────────────────────────────────────────────────────────
done
→ compress origData in nlmixr2 object, save 5952
Updated original fit object fit
> 
> results$env$bootSummary$parFixedDf$confLower
        Estimate Back-transformed
tka    1.1166837        2.7531210
tcl    1.1482029        3.1319906
tv     3.5666725       35.2181979
add.sd 0.8603533        0.8603533
> results$env$bootSummary$parFixedDf$confUpper
        Estimate Back-transformed
tka    1.1166837        2.7531210
tcl    1.1482029        3.1319906
tv     3.5666725       35.2181979
add.sd 0.8603533        0.8603533

Feature request: `tweakInits()`

At ACoP, someone asked if we had all the PsN features implemented. I said, "not yet." The specific request was for a function to tweak initial conditions to check for stability. I took a look at what PsN does (https://github.com/UUPharmacometrics/PsN/releases/download/v5.3.0/parallel_retries_userguide.pdf), and my read is that the most useful set of inputs would look something like the following:

tweakInits(object, n=5, tweakFrac= 0.1, tweakFixed = FALSE, keepAll = TRUE)

The arguments would be:

object: The fit model
n: the number of retries to perform
tweakFrac: The fraction to modify the initial estimates (always ensuring that the new initial estimate is within the bounds)
tweakFixed: Also tweak fixed parameters? (TRUE is yes, FALSE is no)
keepAll: Should the full models be saved (TRUE) or just the parameter tables (FALSE)?

The output would be an object (proposed class: nlmixr2extraTweakInits) with a data.frame-like printing method, an as.data.frame() method, and a plotting method which would show all the parameter estimates and their CI for the original (blue) and the tweaked parameters (gray) with points at the estimates and lines for the CI. The data.frame would have columns for each parameter, each parameter RSE, back-transformed parameters, and the lower and upper bound of the CI.

Edit: clarified the output object

Add `$parFixed` update for boostrap

See Issue #59

Recommend Projects

React

A declarative, efficient, and flexible JavaScript library for building user interfaces.
Vue.js

🖖 Vue.js is a progressive, incrementally-adoptable JavaScript framework for building UI on the web.
Typescript

TypeScript is a superset of JavaScript that compiles to clean JavaScript output.
TensorFlow

An Open Source Machine Learning Framework for Everyone
Django

The Web framework for perfectionists with deadlines.
Laravel

A PHP framework for web artisans
D3

Bring data to life with SVG, Canvas and HTML. 📊📈🎉

Recommend Topics

javascript

JavaScript (JS) is a lightweight interpreted programming language with first-class functions.
web

Some thing interesting about web. New door for the world.
server

A server is a program made to process requests and deliver data to clients.
Machine learning

Machine learning is a way of modeling and interpreting data that allows a piece of software to respond intelligently.
Visualization

Some thing interesting about visualization, use data art
Game

Some thing interesting about game, make everyone happy.

Recommend Org

Facebook

We are working to build community through open source technology. NB: members must have two-factor auth.
Microsoft

Open source projects and samples from Microsoft.
Google

Google ❤️ Open Source for everyone.
Alibaba

Alibaba Open Source for everyone
D3

Data-Driven Documents codes.
Tencent

China tencent open source team.

Jobs

Jooble

	#' auto2 <- covarSearchAuto(fit, varsVec = c("ka", "cl"), covarsVec = c("WT"),
	#' catvarsVec= c("SEX"), restart = TRUE)
	#'

	dObjf <- fit$objf - x$objf
	dof <- length(x$finalUiEnv$ini$est) - length(fit$finalUiEnv$ini$est)
	if (dObjf < 0) {
	pchisqr <- 1 - pchisq(-dObjf, df = dof)
	}
	else {
	pchisqr <- 1
	}

	knit_print.nlmixr2FitCore <- function(x, ..., output = "equations") {
	output <- match.arg(output)
	if ("equations" %in% output) {
	ret <-
	paste0(
	"\\begin{align*}\n",
	paste(
	extractEqHelper(x = x, ...),
	collapse = " \\\\\n"
	),
	"\n\\end{align*}\n"
	)
	}
	knitr::asis_output(ret)
	}

	latexOpMap <-
	list(
	"<"="<",
	"<="="\\leq",
	"=="="\\equiv",
	">="="\\geq",
	">"=">",
	"&"="\\land",
	"&&"="\\land",
	"\|"="\\lor",
	"\|\|"="\\lor",
	"!="="\\ne",
	"!"="\\lnot"
	)