Nothing
.minfo <- function (text, ..., .envir = parent.frame())
{
cli::cli_alert_info(gettext(text), ..., .envir = .envir)
}
.nonmem2rx <- new.env(parent=emptyenv())
#' Clear the .nonmem2rx environment
#'
#' @return Nothing, called for side effects
#' @noRd
#' @author Matthew L. Fidler
.clearNonmem2rx <- function() {
.ls <- ls(all.names=TRUE, envir=.nonmem2rx)
if (length(.ls) > 0L) rm(list=.ls,envir=.nonmem2rx)
.nonmem2rx$ini <- NULL
.nonmem2rx$model <- NULL
.nonmem2rx$abbrevLin <- 0L # ode; 1 = linCmt() no ka; 2= linCmt() ka
.nonmem2rx$scale <- NULL
.nonmem2rx$advan <- 0L
.nonmem2rx$trans <- 0L
.nonmem2rx$maxa <- 0L
.nonmem2rx$addPar <- NA_character_
.nonmem2rx$propPar <- NA_character_
.nonmem2rx$dataFile <- NA_character_
.nonmem2rx$dataCond <- character(0)
.nonmem2rx$dataIgnore1 <- NULL
.nonmem2rx$dataRecords <- NA_integer_
.nonmem2rx$needNmevid <- FALSE
.nonmem2rx$needNmid <- FALSE
.nonmem2rx$tables <- list()
.nonmem2rx$scaleVol <- list()
.nonmem2rx$modelDesc <- NULL
.nonmem2rx$defdose <- 0L
.nonmem2rx$defobs <- 0L
.nonmem2rx$omegaEst <- data.frame(x=integer(0), y=integer(0))
.nonmem2rx$sigmaEst <- data.frame(x=integer(0), y=integer(0))
.nonmem2rx$dadt <- integer(0)
.nonmem2rx$thetaObs <- integer(0)
.nonmem2rx$etaObs <- integer(0)
.nonmem2rx$etaMax <- 0L
.nonmem2rx$thetaMax <- 0L
.nonmem2rx$epsMax <- 0L
.nonmem2rx$epsLabel <- NULL
.nonmem2rx$epsComment <- NULL
.nonmem2rx$epsNonmemLabel <- NULL
.nonmem2rx$etaLabel <- NULL
.nonmem2rx$etaComment <- NULL
.nonmem2rx$etaNonmemLabel <- NULL
.nonmem2rx$thetaNonmemLabel <- NULL
.nonmem2rx$replace <- list()
.nonmem2rx$replaceSeq <- NULL
.nonmem2rx$replaceLabel <- NULL
.nonmem2rx$replaceDataParItem <- NULL
.nonmem2rx$hasVol <- FALSE
.nonmem2rx$needYtype <- FALSE
.nonmem2rx$needDvid <- FALSE
.nonmem2rx$needExit <- FALSE
.nonmem2rx$atol <- 1e-12
.nonmem2rx$rtol <- 1e-12
.nonmem2rx$ssAtolSet <- FALSE
.nonmem2rx$ssAtol <- 1e-12
.nonmem2rx$ssRtolSet <- FALSE
.nonmem2rx$ssRtol <- 1e-12
.nonmem2rx$allVol <- NULL
.nonmem2rx$lhsDef <- NULL
.nonmem2rx$extendedCtl <- TRUE
.nonmem2rx$finalInput <- NULL
.nonmem2rx$esnDups <- NULL
.nonmem2rx$needExtCalc <- TRUE
.nonmem2rx$mixp <- integer(0)
.nonmem2rx$nspop <- 0L
.nonmem2rx$advan5 <- NULL
.nonmem2rx$advan5max <- 0L
.nonmem2rx$advan5k <- NULL
}
#' Add theta name to .nonmem2rx info
#'
#' @param theta string representing variable name
#' @return Nothing called for side effects
#' @noRd
#' @author Matthew L. Fidler
.addThetaName <- function(theta) {
assign("theta", c(.nonmem2rx$theta, theta), envir=.nonmem2rx)
}
#' Add to initialization block
#'
#' @param text Line to add to the initialization block
#' @return nothing, called for side effects
#' @noRd
#' @author Matthew L. Fidler
.addIni <- function(text) {
assign("ini", c(.nonmem2rx$ini, text), envir=.nonmem2rx)
}
#' Add to model block
#'
#' @param text line to add to the model block
#' @return nothing, called for side effects
#' @noRd
#' @author Matthew L. Fidler
.addModel <- function(text) {
assign("model", c(.nonmem2rx$model, text), envir=.nonmem2rx)
}
#' Use lower case for the lhs defined parts of the model
#'
#' @param rxui rxui object
#' @return lower cased rxui object
#' @noRd
#' @author Matthew L. Fidler
.toLowerLhs <- function(rxui) {
.minfo("changing most variables to lower case")
.mv <- rxode2::rxModelVars(rxui)
.rhs <- .mv$lhs
.w <- which(.rhs %in% .mv$params)
if (length(.w) > 0) {
.rhs <- .rhs[-.w]
}
.lhs <- tolower(.rhs)
.w <- which(.lhs %in% .mv$params)
if (length(.w) > 0) {
.rhs <- .rhs[-.w]
.lhs <- .lhs[-.w]
}
.w <- which(.lhs == .rhs)
if (length(.w) > 0) {
.lhs <- .lhs[-.w]
.rhs <- .rhs[-.w]
}
.ret <- eval(str2lang(paste0("rxode2::rxRename(rxui, ", paste(paste(.lhs,"=",.rhs, sep=""), collapse=", "), ")")))
.minfo("done")
.ret
}
#' Replace theta names
#'
#' @param rxui rxode2 ui
#' @param thetaNames theta names that will be replaced in the model
#' @return New ui with theta replaced
#' @noRd
#' @author Matthew L. Fidler
.replaceThetaNames <- function(rxui, thetaNames,
label="theta", prefix="t.", df=NULL,
dn=NULL) {
if (length(thetaNames) == 0) return(rxui)
.minfo(sprintf("replace %s names", label))
.mv <- rxode2::rxModelVars(rxui)
.dups <- unique(thetaNames[duplicated(thetaNames)])
if (length(.dups) > 0) {
thetaNames[(thetaNames %in% .dups)] <- ""
if (prefix == "t.") {
warning("there are duplicate theta names, not renaming duplicate parameters",
call.=FALSE)
} else {
warning("there are duplicate eta names, not renaming duplicate parameters",
call.=FALSE)
}
}
.n <- vapply(thetaNames, function(v) {
if (v == "") return("")
# They can't even match based on case or it can interfere with linCmt()
if (tolower(v) %in% tolower(c(.mv$lhs, .mv$params, "time"))) {
return(paste0(prefix, v))
}
if (.nonmem2rx$abbrevLin != 0L) {
# linear compartment protection by making sure parameters won't
# collide ie Vc and V1 in the model
if (grepl(.linCmtParReg, toupper(v))) {
return(paste0(prefix, v))
}
}
v
}, character(1), USE.NAMES = FALSE)
# These are added by the translator don't include them
if (prefix == "t.") {
.t <- rxui$iniDf$name[!is.na(rxui$iniDf$ntheta)]
.w <- which(regexpr("^(omega|sigma)[.][1-9][0-9]*[.][1-9][0-9]*$", .t) != -1)
if (length(.w) > 0) {
.t <- .t[-.w]
}
.i <- as.numeric(gsub("^theta", "", .t))
.t <- .t[order(.i)]
} else {
.t <- rxui$iniDf$name[which(is.na(rxui$iniDf$ntheta) & rxui$iniDf$neta1 == rxui$iniDf$neta2)]
.i <- as.numeric(gsub("^eta", "", .t))
.t <- .t[order(.i)]
}
.t <- .t[!(.t %in% c("icall", "irep"))]
.w <- which(.n == "")
if (length(.w) > 0) {
.n <- .n[-.w]
.t <- .t[-.w]
}
if (length(.n) == 0) {
.minfo("done (no labels)")
return(rxui)
}
if (length(.n) != length(.t)) {
.minfo("done (not changed due to label mismatch)")
return(rxui)
}
#print(data.frame(.n, .t))
.ret <-eval(parse(text=paste0("rxode2::rxRename(rxui, ", paste(paste(.n,"=", .t, sep=""), collapse=", "), ")")))
.t2 <- setNames(.n, .t)
if (!is.null(df)) {
names(df) <- vapply(names(df), function(n) {
.ret <- .t2[n]
if (is.na(.ret)) return(n)
.ret
}, character(1), USE.NAMES = FALSE)
.nonmem2rx$etas <- df
}
if (!is.null(dn)) {
dn <- vapply(dn, function(n) {
.ret <- .t2[n]
if (is.na(.ret)) return(n)
.ret
}, character(1), USE.NAMES = FALSE)
.nonmem2rx$dn <- dn
}
.minfo("done")
.ret
}
#' Replace compartment names
#'
#' @param rxui ui
#' @param cmtName compartment names to replace
#' @return updated ui with the compartment names replaced
#' @noRd
#' @author Matthew L. Fidler
.replaceCmtNames <- function(rxui, cmtName) {
if (length(cmtName) == 0L) return(rxui)
.minfo("renaming compartments")
.mv <- rxode2::rxModelVars(rxui)
.n <- vapply(cmtName,
function(v) {
v <- gsub(" +", "_", v)
if (tolower(v) %in% tolower(c(.mv$lhs, .mv$params))) {
return(paste0("c.", v))
}
if (regexpr("^[0-9]", v) != -1) {
return(paste0("c.", v))
}
v
}, character(1), USE.NAMES=FALSE)
.c <- paste0("rxddta",seq_along(.n))
.txt<- paste0("rxode2::rxRename(rxui, ", paste(paste(.n,"=", .c, sep=""), collapse=", "), ")")
.tmp <- try(eval(parse(text=.txt)),silent=TRUE)
if (inherits(.tmp, "try-error")) {
.minfo(sprintf("cmt not renamed; err evaluating: %s", .txt))
.ret <- rxui
} else {
.ret <- .tmp
.minfo("done")
}
if (utils::packageVersion("rxode2") <= "2.0.12") {
.expr <- .ret$lstExpr
.expr <- lapply(seq_along(.expr), function(i) {
.x <- .expr[[i]]
if (is.call(.x) && (identical(.x[[1]], quote(`<-`)) ||
identical(.x[[1]], quote(`=`)))) {
if (is.call(.x[[2]]) && length(.x[[2]]) == 2L &&
is.numeric(.x[[2]][[2]]) &&
grepl("^rxddta",as.character(.x[[2]][[1]]))) {
.cur <- as.character(.x[[2]][[1]])
.w <- which(.cur == .c)
if (length(.w) == 1) {
.x[[2]] <- as.call(c(str2lang(.n[.w]), lapply(.x[[2]][-1], function(i) i)))
}
}
}
.x
})
.expr <- bquote(model(.(as.call(c(quote(`{`), .expr)))))
model(.ret) <- .expr
}
.ret
}
#' Update the input model with final parmeter estimates
#'
#' @param rxui ui
#' @inheritParams nonmem2rx
#' @return List with new ui and sigma
#' @noRd
#' @author Matthew L. Fidler
.updateRxWithFinalParameters <- function(rxui, lstInfo) {
.rx <- rxui
.update.theta <- FALSE
if (!is.null(lstInfo$theta)) {
.theta <- lstInfo$theta
.theta <- .theta[!is.na(.theta)]
.rx <- rxode2::ini(.rx, .theta)
.update.theta <- TRUE
}
.update.omega <- FALSE
if (!is.null(lstInfo$omega)) {
.omega <- lstInfo$omega
.rx <- rxode2::ini(.rx, .omega)
.update.omega <- TRUE
if (length(.nonmem2rx$omegaEst$x) > 0) {
for (i in seq_along(.nonmem2rx$omegaEst$x)) {
.x <- .nonmem2rx$omegaEst$x[i]
.y <- .nonmem2rx$omegaEst$y[i]
if (.y == -1L) {
.rx <- eval(parse(text=sprintf("rxode2::ini(.rx, { omega.%d. <- %f})",
.x, .omega[.x, .x])))
} else {
.rx <- eval(parse(text=sprintf("rxode2::ini(.rx, { omega.%d.%d <- %f})",
.x, .y, .omega[.x, .y])))
}
}
}
}
.update.sigma <- FALSE
if (!is.null(lstInfo$sigma)) {
.sigma <- lstInfo$sigma
if (length(.nonmem2rx$sigmaEst$x) > 0) {
for (i in seq_along(.nonmem2rx$sigmaEst$x)) {
.x <- .nonmem2rx$sigmaEst$x[i]
.y <- .nonmem2rx$sigmaEst$y[i]
if (.y == -1L) {
.rx <- eval(parse(text=sprintf("rxode2::ini(.rx, { sigma.%d. <- %f})",
.x, .sigma[.x, .x])))
} else {
.rx <- eval(parse(text=sprintf("rxode2::ini(.rx, { sigma.%d.%d <- %f})",
.x, .y, .sigma[.x, .y])))
}
}
}
.update.sigma <- TRUE
}
list(rx=.rx, sigma=.sigma,
update=.update.theta && .update.omega && .update.sigma)
}
#' Convert a NONMEM source file to a rxode model (nlmixr2-syle)
#'
#' @param file NONMEM run file, like an `.xml` or `.lst` file or even
#' a control stream
#'
#' @param inputData this is a path to the input dataset (or `NULL` to
#' determine from the dataset). Often the input dataset may be
#' different from the place it points to in the control stream
#' because directories can be created to run NONMEM from a script.
#' Because of this, when this is specified the input data will be
#' assumed to be from here instead.
#'
#' @param nonmemOutputDir This is a path the the nonmem output
#' directory. When not `NULL` it will assume that the diretory for
#' the output files is located here instead of where the control
#' stream currently exists.
#'
#' @param rename When not `NULL` this should be a named character
#' vector that contains the parameters that should be renamed. For
#' example, if the model uses the variable `YTYPE` and has `CMT` it
#' isn't compatible with `rxode2`/`nlmixr2`. You can change this for
#' the input dataset and the model to create a new model that still
#' reproduces the NONMEM output by specifying
#' `rename=c(dvid="YTYPE")`
#'
#' @param tolowerLhs Boolean to change the lhs to lower case (default:
#' `TRUE`)
#'
#' @param thetaNames this could be a boolean indicating that the theta
#' names should be changed to the comment-labeled names (default:
#' `TRUE`). This could also be a character vector of the theta names
#' (in order) to be replaced.
#'
#' @param etaNames this could be a boolean indicating that the eta
#' names should be changed to the comment-labeled names (default:
#' `TRUE`). This could also be a character vector of the theta names
#' (in order) to be replaced.
#'
#' @param cmtNames this could be a boolean indicating that the
#' compartment names should be changed to the named compartments in
#' the `$MODEL` by `COMP = (name)` (default: `TRUE`). This could
#' also be a character vector of the compartment names (in order) to
#' be replaced.
#'
#' @param updateFinal Update the parsed model with the model estimates
#' from the `.lst` output file.
#'
#' @param determineError Boolean to try to determine the `nlmixr2`-style residual
#' error model (like `ipred ~ add(add.sd)`), otherwise endpoints are
#' not defined in the `rxode2`/`nlmixr2` model (default: `TRUE`)
#'
#' @param validate Boolean that this tool will attempt to "validate"
#' the model by solving the derived model under pred conditions
#' (etas are zero and eps values are zero)
#'
#' @param nonmemData Boolean that tells `nonmem2rx` to read in the
#' nonmem data (if possible) even if the model will not be validated
#' (like if it is a simulation run or missing final parameter
#' estimates). By default this is `FALSE`, nonmem data will not be
#' integrated into the nonmem2rx ui.
#'
#' @param strictLst The list parsing needs to be correct for a
#' successful load (default `FALSE`).
#'
#' @param unintFixed Treat uninteresting values as fixed parameters (default `FALSE`)
#'
#' @param extended Translate extended control streams from tools like
#' wings for NONMEM
#'
#' @param nLinesPro The number of lines to check for the $PROBLEM
#' statement.
#'
#' @param delta this is the offset for NONMEM times that are tied
#'
#' @param mod the NONMEM output extension, defaults to `.mod`
#'
#' @param lst the NONMEM output extension, defaults to `.lst`
#'
#' @param ext the NONMEM ext file extension, defaults to `.ext`
#'
#' @param cov the NONMEM covariance file extension, defaults to `.cov`
#'
#' @param phi the NONMEM eta/phi file extension, defaults to `.phi`
#'
#' @param xml the NONMEM xml file extension , defaults to `.xml`
#'
#' @param useXml if present, use the NONMEM xml file to import much of
#' the NONMEM information
#'
#' @param useCov if present, use the NONMEM cov file to import the
#' covariance, otherwise import the covariance with list file
#'
#' @param usePhi if present, use the NONMEM phi file to extract etas
#' (default `TRUE`), otherwise defaults to etas in the tables (if
#' present)
#'
#' @param useExt if present, use the NONMEM ext file to extract
#' parameter estimates (default `TRUE`), otherwise defaults to
#' parameter estimates extracted in the NONMEM output
#'
#' @param useLst if present, use the NONMEM lst file to extract NONMEM
#' information
#'
#' @param scanLines number of lines to scan for comment chars when
#' `IGNORE=@`, default is 50
#'
#' @param save This can be:
#'
#' - a `NULL` (meaning don't save),
#'
#' - a logical (default `FALSE`, don't save) that when `TRUE` will use
#' the base name of the control stream, append `.qs` and save the file
#' using `qs::qsave()`
#'
#' - A path to a file to write
#'
#' Note that this file will be saved with qs::qsave() and can be
#' loaded with qs::qread()
#'
#' - A `NA` value which means save if the whole process (including
#' validation) takes too much time
#'
#' @param saveTime The time that the translation/validation needs (in
#' secs) before it will save to avoid having to rerun the model
#' (default 15 for 15 seconds)
#'
#' @param overwrite is a boolean to allow overwriting the save file
#' (see `load` for more information).
#'
#' @param load a boolean that says to load the save file (if it
#' exists) instead of re-running the translation and validation.
#' Note if `overwrite=TRUE` and `load=TRUE` then this will overwrite
#' based on time stamp of the files. If the save file is newer than
#' the input file, then load that file, otherwise regenerate and
#' overwrite. This works best if you point to an output file, like
#' a `.xml` or listing file instead of the control stream
#'
#' @param compress a boolean indicating if the UI should be a
#' compressed UI. If you are using this for simulation with old
#' versions of rxode2, the compressed ui is not supported, so this
#' should be `FALSE`. Otherwise use `TRUE` if you are using a newer
#' rxode2.
#'
#' @param keep is a character vector of imported model items that are
#' kept in the model itself; The defaults is "sigma" which keeps the
#' sigma matrix in the model itself. You can add rxode2 solving
#' options that are imported from NONMEM to keep in the model.
#'
#' @details
#'
#' Since some of these options you may want to set per project, the
#' following options are queried:
#'
#' - `nonmem2rx.validate` - boolean to validate the model (default: `TRUE`)
#'
#' - `nonmem2rx.lst` - default extension for output (default: `.lst`)
#'
#' - `nonmem2rx.save` - should nonmem2rx save the model output?
#'
#' - `nonmem2rx.overwrite` - should nonmem2rx save output be
#' overwritten (default `TRUE`)
#'
#' - `nonmem2rx.load` - should nonmem2rx load a saved model instead of
#' translating and validating again? (default `TRUE`)
#'
#' - `nonmem2rx.extended` - should nonmem2rx support extended control
#' streams? (default `FALSE`)
#'
#' - `nonmem2rx.compress` - should the ui be compressed or
#' uncompressed (default: `TRUE`)
#'
#' @return rxode2 function
#' @eval .nonmem2rxBuildGram()
#' @export
#' @useDynLib nonmem2rx, .registration=TRUE
#' @importFrom Rcpp sourceCpp
#' @importFrom stats setNames
#' @importFrom lotri lotri
#' @importFrom dparser mkdparse
#' @importFrom utils read.csv
#' @import data.table
#' @import ggplot2
#' @examples
#'
#' # You can run a translation without validating the input. This is
#' # a faster way to import a dataset (and allows the CRAN machines to
#' # run a quick example)
#'
#' mod <- nonmem2rx(system.file("mods/cpt/runODE032.ctl", package="nonmem2rx"), lst=".res",
#' save=FALSE, validate=FALSE, compress=FALSE)
#'
#' \donttest{
#'
#' # Though by default you likely wish to validate the input
#'
#' mod <- nonmem2rx(system.file("mods/cpt/runODE032.ctl", package="nonmem2rx"),
#' lst=".res", save=FALSE)
#'
#' mod
#'
#' # you can plot to compare the pred/ipred differences
#'
#' plot(mod)
#'
#' # if you want to see the individual differences
#' # you can by plotting by page of plots
#'
#' plot(mod, nrow=2, ncol=2, page=1, log="y")
#'
#' # or select which pages you want to print
#'
#' plot(mod, nrow=2, ncol=2, page=c(1,3), log="y")
#'
#'
#' #' or even all the individuals with
#' # plot(page=TRUE)
#'
#' plot(mod, nrow=5, ncol=5, page=TRUE, log="y")
#'
#' # you can also convert to a nlmixr2 object, but need babelmixr2 for
#' # that conversion
#'
#' }
#'
nonmem2rx <- function(file, inputData=NULL, nonmemOutputDir=NULL,
rename=NULL, tolowerLhs=TRUE, thetaNames=TRUE,
etaNames=TRUE,
cmtNames=TRUE,
updateFinal=TRUE,
determineError=TRUE,
validate=getOption("nonmem2rx.validate",TRUE),
nonmemData=FALSE,
strictLst=FALSE,
unintFixed=FALSE,
extended=getOption("nonmem2rx.extended",FALSE),
nLinesPro=20L,
delta=1e-4,
usePhi=TRUE,
useExt=TRUE,
useCov=TRUE,
useXml=TRUE,
useLst=TRUE,
mod=".mod",
cov=".cov",
phi=".phi",
lst=getOption("nonmem2rx.lst", ".lst"),
xml=".xml",
ext=".ext",
scanLines=getOption("nonmem2rx.scanLines", 50L),
save=getOption("nonmem2rx.save", NA),
saveTime=getOption("nonmem2rx.saveTime", 15),
overwrite=getOption("nonmem2rx.overwrite", TRUE),
load=getOption("nonmem2rx.load", TRUE),
compress=getOption("nonmem2rx.compress", TRUE),
keep=getOption("nonmem2rx.keep", c("dfSub", "dfObs", "thetaMat", "sigma"))) {
if (any(grepl("[$][Pp][Rr][Oo][Bb][Ll][Ee][Mm]", file))) {
.file <- tempfile(fileext=".ctl")
writeLines(gsub("[ \t]+[$]", "$", file), .file)
file <- .file
on.exit(unlink(.file))
}
.pt <- proc.time()
.ret <- .collectWarn({
checkmate::assertFileExists(file)
if (!is.null(inputData)) checkmate::assertFileExists(inputData)
if (!is.null(nonmemOutputDir)) checkmate::assertDirectoryExists(nonmemOutputDir)
if (!is.null(rename)) checkmate::assertCharacter(rename, any.missing=FALSE, min.len=1, names="strict")
checkmate::assertIntegerish(scanLines, len=1, any.missing=FALSE, lower=1L)
checkmate::assertLogical(tolowerLhs, len=1, any.missing = FALSE)
checkmate::assertLogical(updateFinal, len=1, any.missing= FALSE)
checkmate::assertLogical(unintFixed, len=1, any.missing= FALSE)
checkmate::assertLogical(extended, len=1, any.missing= FALSE)
checkmate::assertLogical(overwrite, len=1, any.missing = FALSE)
checkmate::assertLogical(load, len=1, any.missing = FALSE)
checkmate::assertLogical(compress, len=1, any.missing = FALSE)
checkmate::assertNumeric(saveTime, len=1, lower=1.0)
checkmate::assertSubset(keep,
c("dfSub", "dfObs", "thetaMat", "sigma", "atol",
"rtol", "ssRtol", "ssAtol"))
.saveWithTime <- FALSE
if (is.logical(save)) {
checkmate::assertLogical(save, len=1, any.missing=TRUE)
if (is.na(save)) {
.saveWithTime <- TRUE
save <- TRUE
}
if (save) {
save <- paste0(tools::file_path_sans_ext(file),".qs")
} else {
save <- NULL
}
}
.digest <- digest::digest(list(utils::packageVersion("nonmem2rx"), file, inputData, nonmemOutputDir,
rename, tolowerLhs, thetaNames, etaNames, cmtNames, updateFinal,
determineError, validate, nonmemData, strictLst, unintFixed,
extended, nLinesPro, delta, usePhi, useExt, useCov, useXml,
useLst, mod, cov, phi, lst, xml, ext, scanLines, keep))
if (!is.null(save)) {
if (load && overwrite) {
if (utils::file_test("-nt", file, save)) {
.minfo("input file newer than save, overwriting instead of loading")
load <- FALSE
} else {
overwrite <- FALSE
}
}
if (load && file.exists(save)) {
.minfo(paste0("loading save file '", save, "'"))
.ret <- qs::qread(save)
if (is.null(.ret$digest)) {
.minfo(paste0("older version of nonmem2rx without digest, ignoring save file '", save, "'"))
} else if (.ret$digest == .digest) {
return(.ret)
} else {
.minfo(paste0("different options for import, ignoring save file '", save, "'"))
}
}
}
checkmate::assertCharacter(lst, len=1, any.missing= FALSE)
checkmate::assertIntegerish(nLinesPro, len=1, lower=1)
.clearNonmem2rx()
.nonmem2rx$extendedCtl <- extended
.nonmem2rx$unintFixed <- unintFixed
on.exit({
.Call(`_nonmem2rx_r_parseFree`)
})
.minfo(sprintf("getting information from '%s'", file))
.lstInfo <- nminfo(file, mod=mod, xml=xml, ext=ext, cov=cov, phi=phi, lst=lst,
useXml = useXml, useExt = useExt, useCov=useCov, usePhi=usePhi, useLst=useLst,
strictLst=strictLst, verbose=TRUE)
.minfo("done")
if (is.null(.lstInfo$control)) {
stop("cannot find control stream",
call.=FALSE)
}
.lines <- .lstInfo$control
.lines <- paste(.lines, collapse = "\n")
.parseRec(.lines)
if (.nonmem2rx$needYtype) {
warning("'ytype' variable has special meaning in rxode2, renamed to 'nmytype', rename/copy in your data too",
call.=FALSE)
}
if (.nonmem2rx$needDvid) {
warning("'dvid' variable has special meaning in rxode2, renamed to 'nmdvid', rename/copy in your data too",
call.=FALSE)
}
if (length(.nonmem2rx$esnDups) > 0) {
warning("extended control stream labels are duplicated and ignored for: '",
paste(.nonmem2rx$esnDups, collapse="', '"),
"'", call=FALSE)
}
if (inherits(thetaNames, "logical")) {
checkmate::assertLogical(thetaNames, len=1, any.missing = FALSE)
if (thetaNames) {
thetaNames <- vapply(seq_along(.nonmem2rx$theta),
function(i) {
.lab <- .nonmem2rx$thetaNonmemLabel[i]
if (.lab == "") .lab <- .nonmem2rx$theta[i]
.lab
}, character(1), USE.NAMES=FALSE)
} else {
thetaNames <- character(0)
}
} else {
checkmate::assertCharacter(thetaNames, any.missing = FALSE)
}
.sigma <- NULL
if (length(.nonmem2rx$sigma) > 0L) {
.sigma <- eval(parse(text=paste0("lotri::lotri({\n",
paste(.nonmem2rx$sigma, collapse="\n"),
"\n})")))
if (length(.nonmem2rx$sigmaEst$x) > 0) {
lapply(seq_along(.nonmem2rx$sigmaEst$x),
function(i) {
.x <- .nonmem2rx$sigmaEst$x[i]
.y <- .nonmem2rx$sigmaEst$y[i]
if (.y == -1) {
.addIni(sprintf("sigma.%d. <- %f", .x, .sigma[.x, .x]))
} else {
.addIni(sprintf("sigma.%d.%d <- %f", .x, .y, .sigma[.x, .y]))
}
})
}
}
.omega <- NULL
if (length(.nonmem2rx$omega) > 0L) {
.omega <- eval(parse(text=paste0("lotri::lotri({\n",
paste(.nonmem2rx$omega, collapse="\n"),
"\n})")))
if (length(.nonmem2rx$omegaEst$x) > 0) {
lapply(seq_along(.nonmem2rx$omegaEst$x),
function(i) {
.x <- .nonmem2rx$omegaEst$x[i]
.y <- .nonmem2rx$omegaEst$y[i]
if (.y == -1) {
.addIni(sprintf("omega.%d. <- %f", .x, .omega[.x, .x]))
} else {
.addIni(sprintf("omega.%d.%d <- %f", .x, .y, .omega[.x, .y]))
}
})
}
}
.txt <- paste0("function() {\n",
"rxode2::ini({\n",
paste(.nonmem2rx$ini, collapse="\n"),
"\n})\n",
"rxode2::model({\n",
.desPrefix(),
.missingPrefix(),
# need to add d/dt(depot) and d/dt(central) for
# linear compartment shenanigans
ifelse(.nonmem2rx$abbrevLin == 0L,"",
"d/dt(depot)=0\nd/dt(central)=0\n"),
ifelse(.nonmem2rx$needExit, "ierprdu <- -1\n", ""),
paste(.nonmem2rx$model, collapse="\n"),
.advan5odes(),
"\n})",
"}")
.fun <- try(eval(parse(text=.txt)), silent=TRUE)
if (inherits(.fun, "try-error")) {
message(.txt)
stop("error translating NONMEM, model translation so far echoed above", call.=FALSE)
}
.rx <- .fun()
.rx <- .getLinCmtModel(.rx, advan=.nonmem2rx$advan, trans=.nonmem2rx$trans)
.update <- FALSE
if (updateFinal) {
.tmp <- try(.updateRxWithFinalParameters(.rx, .lstInfo), silent=TRUE)
if (!inherits(.tmp, "try-error")) {
.rx <- .tmp$rx
if (!is.null(.tmp$sigma)) .sigma <- .tmp$sigma
.update <- .tmp$update
}
}
.msg <- NULL
if (validate) {
if (length(.nonmem2rx$mixp) > 0) {
.minfo("mixture model, not currently validated")
.msg <- "mixture model; not validated"
validate <- FALSE
}
}
if (!.update) {
if (validate) {
.minfo("final parameters not updated, will skip validation")
.msg <- "final parameters not updated, validation skipped"
validate <- FALSE
}
}
if (!is.null(rename)) {
.minfo("Renaming variables in model and data")
.r <- rename
.mv <- rxode2::rxModelVars(.rx)
.in <-c(.mv$params, .mv$state, .mv$lhs)
.w <- which(vapply(.r,
function(v) {
v %in% .in
}, logical(1), USE.NAMES=FALSE))
if (length(.w) > 0) {
.r <- .r[.w]
.rx <- eval(parse(text=paste0("rxode2::rxRename(.rx, ", paste(paste0(names(.r), "=", setNames(.r, NULL)), collapse=", "),")")))
}
.minfo("done")
}
.cov <- .getFileNameIgnoreCase(paste0(tools::file_path_sans_ext(file), cov))
if (useCov && file.exists(.cov)) {
.cov <- nmcov(.cov)
.dn <- dimnames(.cov)[[2]]
.dn <- .replaceNmDimNames(.dn)
} else if (!is.null(.lstInfo$cov)) {
.cov <- .lstInfo$cov
.dn <- dimnames(.cov)[[2]]
} else {
.cov <- NULL
.dn <- NULL
}
if (determineError) {
.tmp <- try(.determineError(.rx), silent = FALSE)
if (inherits(.tmp, "try-error")) {
.minfo("error converting to full nlmixr2-compatible ui")
.minfo("could be due to residual components being negative")
} else {
.rx <- .tmp
}
}
.ipredData <- .predData <- .etaData <- .nonmemData <- NULL
if (validate || nonmemData) {
.nonmemData <- .readInDataFromNonmem(file, inputData=inputData,
rename=rename, delta=delta, scanLines=scanLines)
}
if (validate) {
.model <- .rx$simulationModel
.predData <- .ipredData <- try(.readInIpredFromTables(file, nonmemOutputDir=nonmemOutputDir,
rename=rename))
if (inherits(.ipredData, "try-error")) .predData <- .ipredData <- NULL
if (!is.null(.ipredData)) {
.digs <- 0L
if (!is.null(.lstInfo$eta)) {
.digs <- 5L # seems to be the default for phi files
}
# get ETA data if it has better digits than the phi file (or isn't present yet)
.etaData <- try(.readInEtasFromTables(file, nonmemData=.nonmemData, rxModel=.model,
nonmemOutputDir=nonmemOutputDir,rename=rename,
digits=.digs))
if (inherits(.etaData, "try-error")) .etaData <- NULL
if (is.null(.etaData) && !is.null(.lstInfo$eta)) {
.etaData <- .lstInfo$eta
}
}
if (is.null(.predData)) {
.predData <- try(.readInPredFromTables(file, nonmemOutputDir=nonmemOutputDir,
rename=rename))
if (inherits(.predData, "try-error")) .predData <- NULL
} else if (!any(names(.ipredData) == "PRED")) {
.predData <- try(.readInPredFromTables(file, nonmemOutputDir=nonmemOutputDir,
rename=rename))
if (inherits(.predData, "try-error")) .predData <- NULL
}
}
if (tolowerLhs) {
.rx <- .toLowerLhs(.rx)
}
.nonmem2rx$dn <- NULL
.rx <- .replaceThetaNames(.rx, thetaNames, dn=.dn)
if (!is.null(.nonmem2rx$dn)) {
.dn <- .nonmem2rx$dn
}
if (inherits(etaNames, "logical")) {
checkmate::assertLogical(etaNames, len=1, any.missing=FALSE)
if (etaNames) {
etaNames <- vapply(seq_len(max(length(.nonmem2rx$etaNonmemLabel),
length(.nonmem2rx$etaLabel))),
function(i) {
if (i > length(.nonmem2rx$etaNonmemLabel)) {
return(.nonmem2rx$etaNonmemLabel[i])
} else if (i > length(.nonmem2rx$etaLabel)) {
return(.nonmem2rx$etaLabel[i])
}
.lab <- .nonmem2rx$etaNonmemLabel[i]
if (.lab == "") .lab <- .nonmem2rx$etaLabel[i]
.lab
}, character(1), USE.NAMES=FALSE)
} else {
etaNames <- character(0)
}
} else {
checkmate::assertCharacter(etaNames, any.missing = FALSE)
}
.nonmem2rx$etas <- NULL
.nonmem2rx$dn <- NULL
.rx <- .replaceThetaNames(.rx, etaNames,
label="eta", prefix="e.",
df=.etaData, dn=.dn)
if (!is.null(.nonmem2rx$etas)) {
.etaData <- .nonmem2rx$etas
}
if (!is.null(.nonmem2rx$dn)) {
.dn <- .nonmem2rx$dn
}
if (!is.null(.dn)) {
dimnames(.cov) <- list(.dn, .dn)
}
if (inherits(cmtNames, "logical")) {
checkmate::assertLogical(cmtNames, len=1, any.missing = FALSE)
if (cmtNames) {
cmtNames <- character(0)
if (exists("cmtName", envir=.nonmem2rx)) cmtNames <- .nonmem2rx$cmtName
} else {
cmtNames <- character(0)
}
} else {
checkmate::assertCharacter(cmtNames, any.missing = FALSE)
}
.rx <- .replaceCmtNames(.rx, cmtNames)
.rx <- rxode2::rxUiDecompress(.rx)
.rx$file <- file
.rx$outputExtension <- lst
.rx$sticky <- NULL
# now try to validate
if (!is.null(.nonmemData)) {
.rx$nonmemData <- .nonmemData
.rx$sticky <- "nonmemData"
}
if ("atol" %in% keep) {
.rx$meta$atol <- .nonmem2rx$atol
} else {
.rx$atol <- .nonmem2rx$atol
.rx$sticky <- c(.rx$sticky, "atol")
}
if ("rtol" %in% keep) {
.rx$meta$rtol <- .nonmem2rx$rtol
} else {
.rx$rtol <- .nonmem2rx$rtol
.rx$sticky <- c(.rx$sticky, "rtol")
}
if ("ssAtol" %in% keep) {
.rx$meta$ssAtol <- .nonmem2rx$ssAtol
} else {
.rx$ssAtol <- .nonmem2rx$ssAtol
.rx$sticky <- c(.rx$sticky, "ssAtol")
}
if ("ssRtol" %in% keep) {
.rx$meta$ssRtol <- .nonmem2rx$ssRtol
} else {
.rx$ssRtol <- .nonmem2rx$ssRtol
.rx$sticky <- c(.rx$sticky, "ssRtol")
}
.rx$etaData <- .etaData
.rx$ipredData <- .ipredData
.rx$predData <- .predData
.rx$sigmaNames <- dimnames(.sigma)[[1]]
.msg <- .nonmem2rxValidate(.rx, msg=.msg, validate=validate, ci=0.95, sigdig=3)
if (!is.null(.msg)) {
.rx$meta$validation <- .msg
}
if (length(.nonmem2rx$modelDesc) > 0) {
.rx$meta$description <- .nonmem2rx$modelDesc
}
if (!is.null(.sigma)) {
if ("sigma" %in% keep) {
.rx$meta$sigma <- .sigma
} else {
.rx$sigma <- .sigma
.rx$sticky <- c(.rx$sticky, "sigma")
}
}
if (!is.null(.cov)) {
if ("thetaMat" %in% keep) {
.rx$meta$thetaMat <- .cov
} else {
.rx$thetaMat <- .cov
}
}
if (inherits(.lstInfo$nsub, "numeric")) {
if ("dfSub" %in% keep) {
.rx$meta$dfSub <- .lstInfo$nsub
} else {
.rx$dfSub <- .lstInfo$nsub
}
}
if (inherits(.lstInfo$nobs, "numeric")) {
if ("dfObs" %in% keep) {
.rx$meta$dfObs <- .lstInfo$nobs
} else {
.rx$dfObs <- .lstInfo$nobs
}
}
.rx$digest <- .digest
.rx
})
.notes <- .ret[[2]]
.ret <- .ret[[1]]
.ret$notes <- .notes
if (compress) {
.ret <- rxode2::rxUiCompress(.rx)
} else {
.ret <- .rx
}
class(.ret) <- c("nonmem2rx", class(.ret))
if (.saveWithTime) {
if ((proc.time() - .pt)["elapsed"] < saveTime) {
save <- NULL
}
}
if (!is.null(save)) {
.minfo("save model and validation")
qs::qsave(.ret, save)
.minfo("done")
}
.ret
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.