From 0cc1bf4a42f39c090417822a279ab895ba276f67 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Sun, 15 Sep 2024 19:05:52 -0500 Subject: [PATCH 01/22] Add session information --- NAMESPACE | 3 ++ R/focei.R | 1 + R/sessioninfo.R | 136 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 140 insertions(+) create mode 100644 R/sessioninfo.R diff --git a/NAMESPACE b/NAMESPACE index fdbacbcf..61fc561a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -208,6 +208,8 @@ S3method(print,nlmixr2FitCore) S3method(print,nlmixr2FitCoreSilent) S3method(print,nlmixr2Gill83) S3method(print,nlmixr2LstSilent) +S3method(print,nlmixr2estPkgInfo) +S3method(print,nlmixr2estSessionInfo) S3method(print,saemFit) S3method(ranef,nlmixr2FitCore) S3method(ranef,nlmixr2FitCoreSilent) @@ -499,6 +501,7 @@ export(rxParam) export(rxParams) export(rxSolve) export(rxState) +export(rxUiDeparse.foceiControl) export(rxode) export(rxode2) export(saemControl) diff --git a/R/focei.R b/R/focei.R index 5ea04c38..22d16494 100644 --- a/R/focei.R +++ b/R/focei.R @@ -1684,6 +1684,7 @@ attr(rxUiGet.foceiOptEnv, "desc") <- "Get focei optimization environment" .ret <- .tmp } } + assign("sessioninfo", .sessionInfo(), envir=.env) nlmixrWithTiming("compress", { if (exists("saem", .env)) { .saem <- get("saem", envir=.env) diff --git a/R/sessioninfo.R b/R/sessioninfo.R new file mode 100644 index 00000000..d6ef1949 --- /dev/null +++ b/R/sessioninfo.R @@ -0,0 +1,136 @@ +#' Get abberviate package information for nlmixr2 fit object +#' +#' @param pkg package to add +#' @return list of package information +#' @noRd +#' @author Matthew L. Fidler +.pkgInfo <- function(pkg) { + .pkg <- suppressWarnings(utils::packageDescription(pkg)) + if (length(.pkg) == 1L && is.na(.pkg)) { + return(list( + Package = pkg, + Version = NA_character_, + dev = NA, + installed = FALSE, + install = NA_character_)) + } + .ret <- list( + Package = pkg, + Version = .pkg$Version) + if (!is.null(.pkg$GithubUsername)) { + .ret <- c(.ret, + list( + dev=TRUE, + installed = TRUE, + install=deparse1(bquote(remotes::install_github( + .(paste0(.pkg$GithubUsername,"/", .pkg$GithubRepo)), + ref = .(.pkg$GithubSHA1)))))) + + } else { + .ret <- c(.ret, + list( + dev=FALSE, + installed = TRUE, + install=deparse1(bquote(remotes::install_version(.(pkg), version=.(.pkg$Version)))))) + } + class(.ret) <- "nlmixr2estPkgInfo" + .ret +} + +.sessionInfoEnv <- new.env(parent=emptyenv()) +.sessionInfoEnv$pkg <- c("dparser", + "lotri", + "PreciseSums", + "rxode2ll", + "rxode2", + "lbfgsb3c", + "n1qn1", + "nlmixr2est", + "nlmixr2extra", + "nlmixr2lib", + "nlmixr2", + "nonemem2rx", + "monolix2rx", + "babelmixr2", + "PopED", + "PKNCA") + +#' Adds a package to the nlmixr2's $sessioninfo inside the fit +#' +#' +#' @param pkg character vector of the package to add +#' @return nothing, called for side effects +#' @export +#' @author Matthew L. Fidler +#' @keywords internal +#' @examples +#' .addPkgNlmixr2("nlmixr2") # already present +.addPkgNlmixr2 <- function(pkg) { + .sessionInfoEnv$pkg <- unique(c(.sessionInfoEnv$pkg, pkg)) +} +#' Create the sessionInfo for nlmixr2 fit +#' +#' @return a nlmixr2 abbreviated session information object +#' @noRd +#' @author Matthew L. Fidler +.sessionInfo <- function() { + # Get the minimum information for the nlmixr2 related packages + .extra <- character(0) + + .ret <- setNames(lapply(.sessionInfoEnv$pkg, .pkgInfo), .sessionInfoEnv$pkg) + + .os <- suppressWarnings(utils::sessionInfo("base")$running) + if (is.null(.os)) + return(NA_character_) + .os <- gsub("Service Pack", "SP", .os) + if (is.null(.os)) { + .os <- NA_character_ + } + if (!is.na(.os)) { + .extra <- paste0(.extra, paste0("# OS: ", .os, "\n")) + } + .la <- tryCatch(base::La_library(), error = function(err) NA_character_) + if (!is.na(.la)) { + .extra <- paste0(.extra, paste0("# LAPACK: ", .la, "\n")) + } + .lv <- tryCatch(base::La_version(), error = function(err) NA_character_) + if (!is.na(.lv)) { + .extra <- paste0(.extra, paste0("# LAPACK Version: ", .lv, "\n")) + } + .r <- R.version.string + if (!is.na(.r)) { + .extra <- paste0(.extra, paste0("# R Version: ", .r, "\n")) + } + class(.ret) <- "nlmixr2estSessionInfo" + attr(.ret, "extra") <- .extra + .ret +} + +#' @export +print.nlmixr2estSessionInfo <- function(x, ...) { + cat("## ==============================\n") + cat("## nlmixr2est Session Information\n") + cat("## ==============================\n") + cat(paste(attr(x, "extra"), collapse="\n"), sep="\n") + for (pkg in names(x)) { + print.nlmixr2estPkgInfo(x[[pkg]]) + } + invisible() +} + +#' @export +print.nlmixr2estPkgInfo <- function(x, ...) { + if (x$installed) { + cat("\n# Install ") + if (x$dev) { + cat("Development version of '", x$Package, "' from GitHub (shows ver ", x$Version, ")\n", sep="") + cat(x$install, "\n") + } else { + cat("Package version ", x$Version, " of '", x$Package, "'\n", sep="") + cat(x$install, "\n") + } + } else { + cat("\n# Package '", x$Package, "' is not installed, but known to enhance nlmixr2/babelmixr2\n", sep="") + } + invisible(x) +} From 9ab176e3c6e96ef87228a6786a1f2a082865d05d Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 08:14:19 -0500 Subject: [PATCH 02/22] ::doc() --- NAMESPACE | 1 + R/foceiControl.R | 3 --- R/{onLoad.R => zzz.R} | 2 ++ man/dot-addPkgNlmixr2.Rd | 24 ++++++++++++++++++++++++ 4 files changed, 27 insertions(+), 3 deletions(-) rename R/{onLoad.R => zzz.R} (97%) create mode 100644 man/dot-addPkgNlmixr2.Rd diff --git a/NAMESPACE b/NAMESPACE index 61fc561a..427280c2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -363,6 +363,7 @@ S3method(update,nlmixr2FitData) S3method(vcov,nlmixr2FitCore) S3method(vcov,nlmixr2FitCoreSilent) export("%>%") +export(.addPkgNlmixr2) export(.foceiPreProcessData) export(.nlmFinalizeList) export(.nlmFreeEnv) diff --git a/R/foceiControl.R b/R/foceiControl.R index 914d3300..92e71a31 100644 --- a/R/foceiControl.R +++ b/R/foceiControl.R @@ -1357,9 +1357,6 @@ foceiControl <- function(sigdig = 3, # return(.ret) } -# devtools::load_all("~/src/nlmixr2est");rxUiDeparse.foceiControl(foceiControl(innerOpt="BFGS", scaleType="norm", normType="std", derivMethod="central", covDerivMethod="forward", covMethod="s",diagXform="identity", addProp= "combined1"), "ctl") - -#' @export rxUiDeparse.foceiControl <- function(object, var) { .ret <- foceiControl() .outerOpt <- character(0) diff --git a/R/onLoad.R b/R/zzz.R similarity index 97% rename from R/onLoad.R rename to R/zzz.R index f9479d58..4d55aaec 100644 --- a/R/onLoad.R +++ b/R/zzz.R @@ -70,6 +70,8 @@ rxode2.api <- names(rxode2::.rxode2ptrs()) rxode2::.s3register("rxode2::getBaseSimModel", "nlmixr2FitCoreSilent") rxode2::.s3register("rxode2::getBaseSimModel", "nlmixr2FitCore") rxode2::.s3register("rxode2::getBaseSimModel", "nlmixr2FitData") + + rxode2::.s3register("rxode2::rxUiDeparse", "foceiControl") .resetCacheIfNeeded() } diff --git a/man/dot-addPkgNlmixr2.Rd b/man/dot-addPkgNlmixr2.Rd new file mode 100644 index 00000000..bd79e09b --- /dev/null +++ b/man/dot-addPkgNlmixr2.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sessioninfo.R +\name{.addPkgNlmixr2} +\alias{.addPkgNlmixr2} +\title{Adds a package to the nlmixr2's $sessioninfo inside the fit} +\usage{ +.addPkgNlmixr2(pkg) +} +\arguments{ +\item{pkg}{character vector of the package to add} +} +\value{ +nothing, called for side effects +} +\description{ +Adds a package to the nlmixr2's $sessioninfo inside the fit +} +\examples{ +.addPkgNlmixr2("nlmixr2") # already present +} +\author{ +Matthew L. Fidler +} +\keyword{internal} From 345a4d2e32ea1dffb201945bd5894624aaa09f6c Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 08:20:00 -0500 Subject: [PATCH 03/22] Add remotes --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8fd6e9b5..67b49827 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -81,7 +81,8 @@ Suggests: withr, xgxr, sfsmisc, - minpack.lm + minpack.lm, + remotes LinkingTo: BH, n1qn1 (>= 6.0.1-12), From 9e84524918bcfb49d07c2911949acb9da1c009b6 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 08:24:39 -0500 Subject: [PATCH 04/22] move around --- R/zzz.R | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/R/zzz.R b/R/zzz.R index 4d55aaec..f6b4c39a 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -51,12 +51,14 @@ rxode2.api <- names(rxode2::.rxode2ptrs()) PACKAGE = "nlmixr2est") } -.onLoad <- function(libname, pkgname) { - backports::import(pkgname) +.iniPtrs <- function() { .iniLotriPtr() .iniRxode2Ptr() .iniN1qn1ptr() .iniLbfgsb3c() +} + +.iniS3 <- function() { if (requireNamespace("generics", quietly = TRUE)) { rxode2::.s3register("generics::tidy", "nlmixr2FitCore") rxode2::.s3register("generics::tidy", "nlmixr2FitCoreSilent") @@ -75,15 +77,20 @@ rxode2.api <- names(rxode2::.rxode2ptrs()) .resetCacheIfNeeded() } +.onLoad <- function(libname, pkgname) { + backports::import(pkgname) + .iniPtrs() + .iniS3() + +} + compiled.rxode2.md5 <- rxode2::rxMd5() .onAttach <- function(libname, pkgname) { ## nocov start ## Setup rxode2.prefer.tbl - .iniLotriPtr() - .iniRxode2Ptr() - .iniN1qn1ptr() - .iniLbfgsb3c() + .iniPtrs() + .iniS3() ## nlmixr2SetupMemoize() ## options(keep.source = TRUE) ## nocov end From b283d8d66b16b5ff7d87955eb24188eb71a8b107 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 12:41:42 -0500 Subject: [PATCH 05/22] Add bobyqaControl() --- R/bobyqa.R | 6 ++++++ R/deparse.R | 50 ++++++++++++++++++++++++++++++++++++++++++++++++ R/foceiControl.R | 24 +++++------------------ R/saemControl.R | 28 +++++++++++++++++++++++++++ R/zzz.R | 2 ++ 5 files changed, 91 insertions(+), 19 deletions(-) create mode 100644 R/deparse.R diff --git a/R/bobyqa.R b/R/bobyqa.R index d6a5423c..dd35400a 100644 --- a/R/bobyqa.R +++ b/R/bobyqa.R @@ -214,6 +214,12 @@ bobyqaControl <- function(npt=NULL, .ret } +rxUiDeparse.bobyqaControl <- function(object, var) { + .default <- bobyqaControl() + .w <- .deparseDifferent(.default, object, "genRxControl") + .deparseFinal(.default, object, .w, var) +} + #' Get the bobyqa family control #' #' @param env bobyqa optimization environment diff --git a/R/deparse.R b/R/deparse.R new file mode 100644 index 00000000..9221595a --- /dev/null +++ b/R/deparse.R @@ -0,0 +1,50 @@ +.deparseShared <- function(x, value) { + if (x == "rxControl") { + .rx <- rxUiDeparse(value, "a") + .rx <- .rx[[3]] + return(paste0("rxControl = ", deparse1(.rx))) + } else if (x == "scaleType") { + .scaleTypeIdx <- c("norm" = 1L, "nlmixr2" = 2L, "mult" = 3L, "multAdd" = 4L) + paste0("scaleType =", deparse1(names(.scaleTypeIdx[which(object[[x]] == .scaleTypeIdx)]))) + } else if (x == "normType") { + .normTypeIdx <- c("rescale2" = 1L, "rescale" = 2L, "mean" = 3L, "std" = 4L, "len" = 5L, "constant" = 6L) + paste0("normType =", deparse1(names(.normTypeIdx[which(object[[x]] == .normTypeIdx)]))) + } + return(NA_character_) +} + +.deparseDifferent <- function(standard, new, internal=character(0)) { + which(vapply(names(standard), + function(x) { + if (is.function(standard[[x]])) { + warning(paste0(x, "as a function not supported in ", + class(standard), "()"), call.=FALSE) + FALSE + } else if (x %in% internal){ + FALSE + } else { + !identical(standard[[x]], new[[x]]) + } + }, logical(1), USE.NAMES=FALSE)) +} + +.deparseFinal <- function(default, object, w, var, fun=NULL) { + .cls <- class(object) + if (length(w) == 0) { + return(str2lang(paste0(var, " <- ", .cls, "()"))) + } + .retD <- vapply(names(default)[w], function(x) { + .val <- .deparseShared(x, object[[x]]) + if (!is.na(.val)) { + return(.val) + } + if (is.function(fun)) { + .val <- fun(default, x, object[[x]]) + if (!is.na(.val)) { + return(.val) + } + } + paste0(x, "=", deparse1(object[[x]])) + }, character(1), USE.NAMES=FALSE) + str2lang(paste(var, " <- ", .cls, "(", paste(.retD, collapse=","),")")) +} diff --git a/R/foceiControl.R b/R/foceiControl.R index 92e71a31..674aa7b2 100644 --- a/R/foceiControl.R +++ b/R/foceiControl.R @@ -1364,32 +1364,18 @@ rxUiDeparse.foceiControl <- function(object, var) { .outerOpt <- paste0("outerOpt=", deparse1(object$outerOptTxt)) } - .w <- which(vapply(names(.ret), function(x) { - if (x == "outerOpt" && is.function(object[[x]])) { - warning("outerOpt as a function not supported in foceiControl() -deparse", -call.=FALSE) - FALSE - } else if (x %in% .foceiControlInternal){ - FALSE - } else { - !identical(.ret[[x]], object[[x]]) - } - }, logical(1))) - + .w <- .deparseDifferent(.ret, object, .foceiControlInternal) if (length(.w) == 0 && length(.outerOpt) == 0) { return(str2lang(paste0(var, " <- foceiControl()"))) } .retD <- c(vapply(names(.ret)[.w], function(x) { + .val <- .deparseShared(x, object[[x]]) + if (!is.na(.val)) { + return(.val) + } if (x == "innerOpt") { .innerOptFun <- c("n1qn1" = 1L, "BFGS" = 2L) paste0("innerOpt =", deparse1(names(.innerOptFun[which(object[[x]] == .innerOptFun)]))) - } else if (x == "scaleType") { - .scaleTypeIdx <- c("norm" = 1L, "nlmixr2" = 2L, "mult" = 3L, "multAdd" = 4L) - paste0("scaleType =", deparse1(names(.scaleTypeIdx[which(object[[x]] == .scaleTypeIdx)]))) - } else if (x == "normType") { - .normTypeIdx <- c("rescale2" = 1L, "rescale" = 2L, "mean" = 3L, "std" = 4L, "len" = 5L, "constant" = 6L) - paste0("normType =", deparse1(names(.normTypeIdx[which(object[[x]] == .normTypeIdx)]))) } else if (x %in% c("derivMethod", "covDerivMethod", "optimHessType", "optimHessCovType", "eventType")) { .methodIdx <- c("forward" = 0L, "central" = 1L, "switch" = 3L) diff --git a/R/saemControl.R b/R/saemControl.R index 36bc20c6..c2ac2850 100644 --- a/R/saemControl.R +++ b/R/saemControl.R @@ -309,3 +309,31 @@ saemControl <- function(seed = 99, class(.ret) <- "saemControl" .ret } + +.saemDeparseExtra <- function(default, name, value) { + if (name == "mcmc") { + .ret <- character(0) + if (!identical(default$mcmc$niter, value$niter)) { + if (default$mcmc$niter[1] != value$niter[1]) { + .ret <- c(.ret, paste0("nBurn=", value$niter[1])) + } + if (default$mcmc$niter[2] != value$niter[2]) { + .ret <- c(.ret, paste0("nEm=", value$niter[2])) + } + } + if (default$mcmc$nmc != value$nmc) { + .ret <- c(.ret, paste0("nmc=", value$nmc)) + } + if (!identical(default$mcmc$nu, value$nu)) { + .ret <- c(.ret, paste0("nu=", deparse1(value$nu))) + } + return(paste0(.ret, collapse=",")) + } + NA_character_ +} + +rxUiDeparse.saemControl <- function(object, var) { + .default <- saemControl() + .w <- .deparseDifferent(.default, object, c("genRxControl", "DEBUG")) + .deparseFinal(.default, object, .w, var, fun=.saemDeparseExtra) +} diff --git a/R/zzz.R b/R/zzz.R index f6b4c39a..b310ab15 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -74,6 +74,8 @@ rxode2.api <- names(rxode2::.rxode2ptrs()) rxode2::.s3register("rxode2::getBaseSimModel", "nlmixr2FitData") rxode2::.s3register("rxode2::rxUiDeparse", "foceiControl") + rxode2::.s3register("rxode2::rxUiDeparse", "saemControl") + rxode2::.s3register("rxode2::rxUiDeparse", "bobyqaControl") .resetCacheIfNeeded() } From 33f4b776670190779c8ee08fa2fbe6533d5f3ee3 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 12:44:56 -0500 Subject: [PATCH 06/22] Add rxUiDeparse.lbfgsb3cControl --- R/lbfgsb3c.R | 6 ++++++ R/zzz.R | 1 + 2 files changed, 7 insertions(+) diff --git a/R/lbfgsb3c.R b/R/lbfgsb3c.R index e8d51fa3..2b9e4d4b 100644 --- a/R/lbfgsb3c.R +++ b/R/lbfgsb3c.R @@ -225,6 +225,12 @@ lbfgsb3cControl <- function(trace=0, .ret } +rxUiDeparse.lbfgsb3cControl <- function(object, var) { + .default <- lbfgsb3cControl() + .w <- .deparseDifferent(.default, object, "genRxControl") + .deparseFinal(.default, object, .w, var) +} + #' Get the lbfgsb3c family control #' #' @param env lbfgsb3c optimization environment diff --git a/R/zzz.R b/R/zzz.R index b310ab15..8a02f476 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -76,6 +76,7 @@ rxode2.api <- names(rxode2::.rxode2ptrs()) rxode2::.s3register("rxode2::rxUiDeparse", "foceiControl") rxode2::.s3register("rxode2::rxUiDeparse", "saemControl") rxode2::.s3register("rxode2::rxUiDeparse", "bobyqaControl") + rxode2::.s3register("rxode2::rxUiDeparse", "lbfgsb3cControl") .resetCacheIfNeeded() } From 8346947503105ae59c69bbb9e8421f3ac4c3bab5 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 13:02:14 -0500 Subject: [PATCH 07/22] Add more controls --- R/deparse.R | 26 +++++++++++++++++++++----- R/n1qn1.R | 7 +++++++ R/newuoa.R | 6 ++++++ R/nlme.R | 7 +++++++ R/nlminb.R | 6 ++++++ R/zzz.R | 3 +++ 6 files changed, 50 insertions(+), 5 deletions(-) diff --git a/R/deparse.R b/R/deparse.R index 9221595a..7ac5c1f1 100644 --- a/R/deparse.R +++ b/R/deparse.R @@ -4,13 +4,29 @@ .rx <- .rx[[3]] return(paste0("rxControl = ", deparse1(.rx))) } else if (x == "scaleType") { - .scaleTypeIdx <- c("norm" = 1L, "nlmixr2" = 2L, "mult" = 3L, "multAdd" = 4L) - paste0("scaleType =", deparse1(names(.scaleTypeIdx[which(object[[x]] == .scaleTypeIdx)]))) + if (is.integer(object[[x]])) { + .scaleTypeIdx <- c("norm" = 1L, "nlmixr2" = 2L, "mult" = 3L, "multAdd" = 4L) + paste0("scaleType =", deparse1(names(.scaleTypeIdx[which(object[[x]] == .scaleTypeIdx)]))) + } else { + paste0("scaleType =", deparse1(object[[x]])) + } } else if (x == "normType") { - .normTypeIdx <- c("rescale2" = 1L, "rescale" = 2L, "mean" = 3L, "std" = 4L, "len" = 5L, "constant" = 6L) - paste0("normType =", deparse1(names(.normTypeIdx[which(object[[x]] == .normTypeIdx)]))) + if (is.integer(object[[x]])) { + .normTypeIdx <- c("rescale2" = 1L, "rescale" = 2L, "mean" = 3L, "std" = 4L, "len" = 5L, "constant" = 6L) + paste0("normType =", deparse1(names(.normTypeIdx[which(object[[x]] == .normTypeIdx)]))) + } else { + paste0("normType =", deparse1(object[[x]])) + } + } else if (x == "solveType") { + if (is.integer(object[[x]])) { + .solveTypeIdx <- c("hessian" = 3L, "grad" = 2L, "fun" = 1L) + paste0("solveType =", deparse1(names(.solveTypeIdx[which(object[[x]] == .solveTypeIdx)]))) + } else { + paste0("normType =", deparse1(object[[x]])) + } + } else { + NA_character_ } - return(NA_character_) } .deparseDifferent <- function(standard, new, internal=character(0)) { diff --git a/R/n1qn1.R b/R/n1qn1.R index afc7b481..8e6a4060 100644 --- a/R/n1qn1.R +++ b/R/n1qn1.R @@ -190,6 +190,13 @@ n1qn1Control <- function(epsilon = (.Machine$double.eps) ^ 0.25, .ret } +rxUiDeparse.n1qn1Control <- function(object, var) { + .default <- n1qn1Control() + .w <- .deparseDifferent(.default, object, "genRxControl") + .deparseFinal(.default, object, .w, var) +} + + #' Get the n1qn1 family control #' #' @param env n1qn1 optimization environment diff --git a/R/newuoa.R b/R/newuoa.R index 1432c039..e3f69fd7 100644 --- a/R/newuoa.R +++ b/R/newuoa.R @@ -184,6 +184,12 @@ newuoaControl <- function(npt=NULL, .ret } +rxUiDeparse.newuoaControl <- function(object, var) { + .default <- newuoaControl() + .w <- .deparseDifferent(.default, object, "genRxControl") + .deparseFinal(.default, object, .w, var) +} + #' Get the newuoa family control #' #' @param env newuoa optimization environment diff --git a/R/nlme.R b/R/nlme.R index 2a58482c..dd80faa3 100644 --- a/R/nlme.R +++ b/R/nlme.R @@ -118,6 +118,13 @@ nlmixr2NlmeControl <- function(maxIter = 100, pnlsMaxIter = 100, msMaxIter = 100 .ret } +rxUiDeparse.nlmeControl <- function(object, var) { + .default <- nlmeControl() + .w <- .deparseDifferent(.default, object, "genRxControl") + .deparseFinal(.default, object, .w, var) +} + + #' @rdname nlmixr2NlmeControl #' @export nlmeControl <- nlmixr2NlmeControl diff --git a/R/nlminb.R b/R/nlminb.R index 652e256d..85279a0b 100644 --- a/R/nlminb.R +++ b/R/nlminb.R @@ -285,6 +285,12 @@ nlminbControl <- function(eval.max=200, .ret } +rxUiDeparse.nlminbControl <- function(object, var) { + .default <- nlminbControl() + .w <- .deparseDifferent(.default, object, "genRxControl") + .deparseFinal(.default, object, .w, var) +} + #' A surrogate function for nlminb to call for ode solving #' #' @param pars Parameters that will be estimated diff --git a/R/zzz.R b/R/zzz.R index 8a02f476..36af66be 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -77,6 +77,9 @@ rxode2.api <- names(rxode2::.rxode2ptrs()) rxode2::.s3register("rxode2::rxUiDeparse", "saemControl") rxode2::.s3register("rxode2::rxUiDeparse", "bobyqaControl") rxode2::.s3register("rxode2::rxUiDeparse", "lbfgsb3cControl") + rxode2::.s3register("rxode2::rxUiDeparse", "n1qn1Control") + rxode2::.s3register("rxode2::rxUiDeparse", "newuoaControl") + rxode2::.s3register("rxode2::rxUiDeparse", "nlmeControl") .resetCacheIfNeeded() } From f29026231bdea572c8d855a56d1d4ad14c5abeaa Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 13:15:23 -0500 Subject: [PATCH 08/22] Add rest of estimation controls --- R/deparse.R | 9 +++++++++ R/nlm.R | 7 +++++++ R/nls.R | 9 ++++++++- R/optim.R | 8 +++++--- R/uobyqa.R | 6 ++++++ R/zzz.R | 5 +++++ 6 files changed, 40 insertions(+), 4 deletions(-) diff --git a/R/deparse.R b/R/deparse.R index 7ac5c1f1..8cf8152f 100644 --- a/R/deparse.R +++ b/R/deparse.R @@ -24,6 +24,15 @@ } else { paste0("normType =", deparse1(object[[x]])) } + } else if (x == "") { + if (is.integer(object[[x]])) { + .eventTypeIdx <- c("central" =2L, "forward"=1L) + paste0("eventType = ", + deparse1(names(.eventTypeIdx[which(object[[x]] == .eventTypeIdx)]))) + } else { + paste0("eventType = ", + deparse1(object[[x]])) + } } else { NA_character_ } diff --git a/R/nlm.R b/R/nlm.R index 7f91b2d6..5416dfc8 100644 --- a/R/nlm.R +++ b/R/nlm.R @@ -277,6 +277,13 @@ nlmControl <- function(typsize = NULL, .ret } +rxUiDeparse.nlmControl <- function(object, var) { + .default <- nlmControl() + .w <- .deparseDifferent(.default, object, "genRxControl") + .deparseFinal(.default, object, .w, var) +} + + #' Get the nlm family control #' #' @param env nlm optimization environment diff --git a/R/nls.R b/R/nls.R index 2fd2dd08..20d67c7a 100644 --- a/R/nls.R +++ b/R/nls.R @@ -105,7 +105,6 @@ nlsControl <- function(maxiter=10000, checkmate::assertNumeric(shiErr, lower=0, any.missing=FALSE, len=1) checkmate::assertIntegerish(shi21maxFD, lower=1, any.missing=FALSE, len=1) - .eventTypeIdx <- c("central" =2L, "forward"=1L) if (checkmate::testIntegerish(eventType, len=1, lower=1, upper=6, any.missing=FALSE)) { eventType <- as.integer(eventType) @@ -248,6 +247,13 @@ nlsControl <- function(maxiter=10000, .ret } + +rxUiDeparse.nlsControl <- function(object, var) { + .default <- nlsControl() + .w <- .deparseDifferent(.default, object, "genRxControl") + .deparseFinal(.default, object, .w, var) +} + #' Get the nls family control #' #' @param env nlme optimization environment @@ -305,6 +311,7 @@ getValidNlmixrCtl.nls <- function(control) { .ctl } + .nlsEnv <- new.env(parent=emptyenv()) #' A surrogate function for nls to call for ode solving diff --git a/R/optim.R b/R/optim.R index 0852e0c3..be69f063 100644 --- a/R/optim.R +++ b/R/optim.R @@ -227,9 +227,6 @@ optimControl <- function(method = c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SA checkmate::assertIntegerish(maxOdeRecalc, any.missing=FALSE, len=1) checkmate::assertNumeric(odeRecalcFactor, len=1, lower=1, any.missing=FALSE) - - - .xtra <- list(...) .bad <- names(.xtra) .bad <- .bad[!(.bad %in% "genRxControl")] @@ -341,6 +338,11 @@ optimControl <- function(method = c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SA .ret } +rxUiDeparse.optimControl <- function(object, var) { + .default <- optimControl() + .w <- .deparseDifferent(.default, object, "genRxControl") + .deparseFinal(.default, object, .w, var) +} #' A surrogate function for optim to call for ode solving #' diff --git a/R/uobyqa.R b/R/uobyqa.R index e399a1ed..bd33441b 100644 --- a/R/uobyqa.R +++ b/R/uobyqa.R @@ -184,6 +184,12 @@ uobyqaControl <- function(npt=NULL, .ret } +rxUiDeparse.uobyqaControl <- function(object, var) { + .default <- uobyqaControl() + .w <- .deparseDifferent(.default, object, "genRxControl") + .deparseFinal(.default, object, .w, var) +} + #' Get the uobyqa family control #' #' @param env uobyqa optimization environment diff --git a/R/zzz.R b/R/zzz.R index 36af66be..30a2de43 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -80,6 +80,11 @@ rxode2.api <- names(rxode2::.rxode2ptrs()) rxode2::.s3register("rxode2::rxUiDeparse", "n1qn1Control") rxode2::.s3register("rxode2::rxUiDeparse", "newuoaControl") rxode2::.s3register("rxode2::rxUiDeparse", "nlmeControl") + rxode2::.s3register("rxode2::rxUiDeparse", "nlminbControl") + rxode2::.s3register("rxode2::rxUiDeparse", "nlmControl") + rxode2::.s3register("rxode2::rxUiDeparse", "nlsControl") + rxode2::.s3register("rxode2::rxUiDeparse", "optimControl") + rxode2::.s3register("rxode2::rxUiDeparse", "uobyqaControl") .resetCacheIfNeeded() } From 0a54c1173a374552412ef634e809b23ad1c941bc Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 13:21:00 -0500 Subject: [PATCH 09/22] shared deparse --- NAMESPACE | 1 - R/deparse.R | 11 ++++++++++- R/resid.R | 6 ++++++ R/zzz.R | 1 + 4 files changed, 17 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 427280c2..2c692ef8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -502,7 +502,6 @@ export(rxParam) export(rxParams) export(rxSolve) export(rxState) -export(rxUiDeparse.foceiControl) export(rxode) export(rxode2) export(saemControl) diff --git a/R/deparse.R b/R/deparse.R index 8cf8152f..a37dabbe 100644 --- a/R/deparse.R +++ b/R/deparse.R @@ -24,7 +24,7 @@ } else { paste0("normType =", deparse1(object[[x]])) } - } else if (x == "") { + } else if (x == "eventType") { if (is.integer(object[[x]])) { .eventTypeIdx <- c("central" =2L, "forward"=1L) paste0("eventType = ", @@ -33,6 +33,15 @@ paste0("eventType = ", deparse1(object[[x]])) } + } else if (x == "censMethod") { + if (is.integer(object[[x]])) { + .censMethodIdx <- c("truncated-normal"=3L, "cdf"=2L, "omit"=1L, "pred"=5L, "ipred"=4L, "epred"=6L) + paste0("censMethod = ", + deparse1(names(.eventTypeIdx[which(object[[x]] == .eventTypeIdx)]))) + } else { + paste0("censMethod = ", + deparse1(object[[x]])) + } } else { NA_character_ } diff --git a/R/resid.R b/R/resid.R index 71f5adfa..20b708d1 100644 --- a/R/resid.R +++ b/R/resid.R @@ -735,3 +735,9 @@ tableControl <- function(npde = NULL, class(.ret) <- "tableControl" return(.ret) } + +rxUiDeparse.tableControl <- function(object, var) { + .default <- tableControl() + .w <- .deparseDifferent(.default, object, "genRxControl") + .deparseFinal(.default, object, .w, var) +} diff --git a/R/zzz.R b/R/zzz.R index 30a2de43..b5befb16 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -85,6 +85,7 @@ rxode2.api <- names(rxode2::.rxode2ptrs()) rxode2::.s3register("rxode2::rxUiDeparse", "nlsControl") rxode2::.s3register("rxode2::rxUiDeparse", "optimControl") rxode2::.s3register("rxode2::rxUiDeparse", "uobyqaControl") + rxode2::.s3register("rxode2::rxUiDeparse", "tableControl") .resetCacheIfNeeded() } From fdabd5246c6dc7f44027d14c9915d7cf43fb9487 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 13:30:23 -0500 Subject: [PATCH 10/22] Export internal deparse methods for babelmixr2 --- NAMESPACE | 2 ++ R/deparse.R | 48 +++++++++++++++++++++++++++++++++++++ man/dot-deparseDifferent.Rd | 40 +++++++++++++++++++++++++++++++ man/dot-deparseFinal.Rd | 38 +++++++++++++++++++++++++++++ 4 files changed, 128 insertions(+) create mode 100644 man/dot-deparseDifferent.Rd create mode 100644 man/dot-deparseFinal.Rd diff --git a/NAMESPACE b/NAMESPACE index 2c692ef8..8d6468e6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -364,6 +364,8 @@ S3method(vcov,nlmixr2FitCore) S3method(vcov,nlmixr2FitCoreSilent) export("%>%") export(.addPkgNlmixr2) +export(.deparseDifferent) +export(.deparseFinal) export(.foceiPreProcessData) export(.nlmFinalizeList) export(.nlmFreeEnv) diff --git a/R/deparse.R b/R/deparse.R index a37dabbe..1c2ead5f 100644 --- a/R/deparse.R +++ b/R/deparse.R @@ -47,6 +47,32 @@ } } +#' Identify Differences Between Standard and New Objects but used in rxUiDeparse +#' +#' This function compares elements of a standard object with a new +#' object and identifies which elements are different. It is used to +#' only show values that are different from the default when deparsing +#' control objects. +#' +#' @param standard The standard object used for comparison. (for example `foceiControl()`) +#' +#' @param new The new object to be compared against the standard. This +#' would be what the user supplide like +#' `foceiControl(outerOpt="bobyqa")` +#' @param internal A character vector of element names to be ignored +#' during the comparison. Default is an empty character +#' vector. These are for internal items of the list that flag +#' certain properties like if the `rxControl()` was generated by the +#' `foceiControl()` procedure or not. +#' @return A vector of indices indicating which elements of the +#' standard object differ from the new object. +#' @examples +#' standard <- list(a = 1, b = 2, c = 3) +#' new <- list(a = 1, b = 3, c = 3) +#' .deparseDifferent(standard, new) +#' @export +#' @keywords internal +#' @author Matthew L. Fidler .deparseDifferent <- function(standard, new, internal=character(0)) { which(vapply(names(standard), function(x) { @@ -62,6 +88,28 @@ }, logical(1), USE.NAMES=FALSE)) } +#' Deparse finalize a control or related object into a language object +#' +#' This function deparses an object into a language expression, +#' optionally using a custom function for specific elements. +#' +#' @param default A default object used for comparison; This is the +#' estimation control procedure. It should have a class matching +#' the function that created it. +#' @param object The object to be deparsed into a language exression +#' @param w A vector of indices indicating which elements are +#' different and need to be deparsed. This likely comes from +#' `.deparseDifferent()` +#' @param var A string representing the variable name to be assigned +#' in the deparsed expression. +#' @param fun An optional custom function to handle specific elements +#' during deparsing. Default is NULL. This handles things that are +#' specific to an estimation control and is used by functions like +#' `rxUiDeparse.saemControl()` +#' @return A language object representing the deparsed expression. +#' @keywords internal +#' @author Matthew L. Fidler +#' @export .deparseFinal <- function(default, object, w, var, fun=NULL) { .cls <- class(object) if (length(w) == 0) { diff --git a/man/dot-deparseDifferent.Rd b/man/dot-deparseDifferent.Rd new file mode 100644 index 00000000..49a12d8d --- /dev/null +++ b/man/dot-deparseDifferent.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/deparse.R +\name{.deparseDifferent} +\alias{.deparseDifferent} +\title{Identify Differences Between Standard and New Objects but used in rxUiDeparse} +\usage{ +.deparseDifferent(standard, new, internal = character(0)) +} +\arguments{ +\item{standard}{The standard object used for comparison. (for example `foceiControl()`)} + +\item{new}{The new object to be compared against the standard. This +would be what the user supplide like +`foceiControl(outerOpt="bobyqa")`} + +\item{internal}{A character vector of element names to be ignored +during the comparison. Default is an empty character +vector. These are for internal items of the list that flag +certain properties like if the `rxControl()` was generated by the +`foceiControl()` procedure or not.} +} +\value{ +A vector of indices indicating which elements of the + standard object differ from the new object. +} +\description{ +This function compares elements of a standard object with a new +object and identifies which elements are different. It is used to +only show values that are different from the default when deparsing +control objects. +} +\examples{ +standard <- list(a = 1, b = 2, c = 3) +new <- list(a = 1, b = 3, c = 3) +.deparseDifferent(standard, new) +} +\author{ +Matthew L. Fidler +} +\keyword{internal} diff --git a/man/dot-deparseFinal.Rd b/man/dot-deparseFinal.Rd new file mode 100644 index 00000000..40cd18c3 --- /dev/null +++ b/man/dot-deparseFinal.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/deparse.R +\name{.deparseFinal} +\alias{.deparseFinal} +\title{Deparse finalize a control or related object into a language object} +\usage{ +.deparseFinal(default, object, w, var, fun = NULL) +} +\arguments{ +\item{default}{A default object used for comparison; This is the +estimation control procedure. It should have a class matching +the function that created it.} + +\item{object}{The object to be deparsed into a language exression} + +\item{w}{A vector of indices indicating which elements are +different and need to be deparsed. This likely comes from +`.deparseDifferent()`} + +\item{var}{A string representing the variable name to be assigned +in the deparsed expression.} + +\item{fun}{An optional custom function to handle specific elements +during deparsing. Default is NULL. This handles things that are +specific to an estimation control and is used by functions like +`rxUiDeparse.saemControl()`} +} +\value{ +A language object representing the deparsed expression. +} +\description{ +This function deparses an object into a language expression, +optionally using a custom function for specific elements. +} +\author{ +Matthew L. Fidler +} +\keyword{internal} From 5627fd55256f135b1d1453608db905eaf13daf1d Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 13:33:01 -0500 Subject: [PATCH 11/22] Remove explicit return --- R/deparse.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/deparse.R b/R/deparse.R index 1c2ead5f..933c334f 100644 --- a/R/deparse.R +++ b/R/deparse.R @@ -2,7 +2,7 @@ if (x == "rxControl") { .rx <- rxUiDeparse(value, "a") .rx <- .rx[[3]] - return(paste0("rxControl = ", deparse1(.rx))) + paste0("rxControl = ", deparse1(.rx)) } else if (x == "scaleType") { if (is.integer(object[[x]])) { .scaleTypeIdx <- c("norm" = 1L, "nlmixr2" = 2L, "mult" = 3L, "multAdd" = 4L) From cbe95545de2375c35d19119d2be5fb0938302deb Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 14:58:42 -0500 Subject: [PATCH 12/22] test saemControl() --- R/deparse.R | 8 ++++---- R/foceiControl.R | 6 ++++-- tests/testthat/test-rxuideparse.R | 16 ++++++++++++++++ 3 files changed, 24 insertions(+), 6 deletions(-) diff --git a/R/deparse.R b/R/deparse.R index 933c334f..4b68d3fd 100644 --- a/R/deparse.R +++ b/R/deparse.R @@ -76,11 +76,11 @@ .deparseDifferent <- function(standard, new, internal=character(0)) { which(vapply(names(standard), function(x) { - if (is.function(standard[[x]])) { - warning(paste0(x, "as a function not supported in ", - class(standard), "()"), call.=FALSE) + if (x %in% internal){ FALSE - } else if (x %in% internal){ + } else if (is.function(standard[[x]])) { + warning(paste0("'", x, "' as a function not supported in ", + class(standard), "() deparsing"), call.=FALSE) FALSE } else { !identical(standard[[x]], new[[x]]) diff --git a/R/foceiControl.R b/R/foceiControl.R index 674aa7b2..3b8a0dc9 100644 --- a/R/foceiControl.R +++ b/R/foceiControl.R @@ -1360,10 +1360,12 @@ foceiControl <- function(sigdig = 3, # rxUiDeparse.foceiControl <- function(object, var) { .ret <- foceiControl() .outerOpt <- character(0) - if (object$outerOptTxt != "nlminb") { + if (object$outerOpt == -1L) { + warning("functions for `outerOpt` cannot be deparsed, reset to default", + call.=FALSE) + } else if (object$outerOptTxt != "nlminb") { .outerOpt <- paste0("outerOpt=", deparse1(object$outerOptTxt)) } - .w <- .deparseDifferent(.ret, object, .foceiControlInternal) if (length(.w) == 0 && length(.outerOpt) == 0) { return(str2lang(paste0(var, " <- foceiControl()"))) diff --git a/tests/testthat/test-rxuideparse.R b/tests/testthat/test-rxuideparse.R index d8aef259..9ee861b3 100644 --- a/tests/testthat/test-rxuideparse.R +++ b/tests/testthat/test-rxuideparse.R @@ -5,4 +5,20 @@ test_that("foceiControl() deparse", { covMethod = "s", diagXform = "identity", innerOpt = "BFGS", scaleType = "norm", normType = "std", addProp = "combined1"))) + expect_equal(rxUiDeparse.foceiControl(foceiControl(), "ctl"), + quote(ctl <- foceiControl())) + + expect_warning(rxUiDeparse.foceiControl(foceiControl(outerOpt=optim), "ctl"), + "reset") + +}) + +test_that("saemControl() deparse", { + + expect_equal(rxUiDeparse.saemControl(saemControl(nBurn=2, nEm=2, nmc=7, nu=c(3, 3, 3)), + "ctl"), + quote(ctl <- saemControl(nBurn = 2, nEm = 2, nmc = 7, + nu = c(3, 3, 3)))) + expect_equal(rxUiDeparse.saemControl(saemControl(), "ctl"), + quote(ctl <- saemControl())) }) From ff45870d392b7c2db6262c7f09760f90686d7687 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 15:08:52 -0500 Subject: [PATCH 13/22] More tests and fixes --- R/deparse.R | 30 +++++++++++++++--------------- tests/testthat/test-rxuideparse.R | 27 +++++++++++++++++++++++++++ 2 files changed, 42 insertions(+), 15 deletions(-) diff --git a/R/deparse.R b/R/deparse.R index 4b68d3fd..95978cb6 100644 --- a/R/deparse.R +++ b/R/deparse.R @@ -4,43 +4,43 @@ .rx <- .rx[[3]] paste0("rxControl = ", deparse1(.rx)) } else if (x == "scaleType") { - if (is.integer(object[[x]])) { + if (is.integer(value)) { .scaleTypeIdx <- c("norm" = 1L, "nlmixr2" = 2L, "mult" = 3L, "multAdd" = 4L) - paste0("scaleType =", deparse1(names(.scaleTypeIdx[which(object[[x]] == .scaleTypeIdx)]))) + paste0("scaleType =", deparse1(names(.scaleTypeIdx[which(value == .scaleTypeIdx)]))) } else { - paste0("scaleType =", deparse1(object[[x]])) + paste0("scaleType =", deparse1(value)) } } else if (x == "normType") { - if (is.integer(object[[x]])) { + if (is.integer(value)) { .normTypeIdx <- c("rescale2" = 1L, "rescale" = 2L, "mean" = 3L, "std" = 4L, "len" = 5L, "constant" = 6L) - paste0("normType =", deparse1(names(.normTypeIdx[which(object[[x]] == .normTypeIdx)]))) + paste0("normType =", deparse1(names(.normTypeIdx[which(value == .normTypeIdx)]))) } else { - paste0("normType =", deparse1(object[[x]])) + paste0("normType =", deparse1(value)) } } else if (x == "solveType") { - if (is.integer(object[[x]])) { + if (is.integer(value)) { .solveTypeIdx <- c("hessian" = 3L, "grad" = 2L, "fun" = 1L) - paste0("solveType =", deparse1(names(.solveTypeIdx[which(object[[x]] == .solveTypeIdx)]))) + paste0("solveType =", deparse1(names(.solveTypeIdx[which(value == .solveTypeIdx)]))) } else { - paste0("normType =", deparse1(object[[x]])) + paste0("normType =", deparse1(value)) } } else if (x == "eventType") { - if (is.integer(object[[x]])) { + if (is.integer(value)) { .eventTypeIdx <- c("central" =2L, "forward"=1L) paste0("eventType = ", - deparse1(names(.eventTypeIdx[which(object[[x]] == .eventTypeIdx)]))) + deparse1(names(.eventTypeIdx[which(value == .eventTypeIdx)]))) } else { paste0("eventType = ", - deparse1(object[[x]])) + deparse1(value)) } } else if (x == "censMethod") { - if (is.integer(object[[x]])) { + if (is.integer(value)) { .censMethodIdx <- c("truncated-normal"=3L, "cdf"=2L, "omit"=1L, "pred"=5L, "ipred"=4L, "epred"=6L) paste0("censMethod = ", - deparse1(names(.eventTypeIdx[which(object[[x]] == .eventTypeIdx)]))) + deparse1(names(.eventTypeIdx[which(value == .eventTypeIdx)]))) } else { paste0("censMethod = ", - deparse1(object[[x]])) + deparse1(value)) } } else { NA_character_ diff --git a/tests/testthat/test-rxuideparse.R b/tests/testthat/test-rxuideparse.R index 9ee861b3..0cae758d 100644 --- a/tests/testthat/test-rxuideparse.R +++ b/tests/testthat/test-rxuideparse.R @@ -21,4 +21,31 @@ test_that("saemControl() deparse", { nu = c(3, 3, 3)))) expect_equal(rxUiDeparse.saemControl(saemControl(), "ctl"), quote(ctl <- saemControl())) + +}) + +test_that("bobyqaControl()",{ + + expect_equal(rxUiDeparse.bobyqaControl(bobyqaControl(), "var"), + quote(var <- bobyqaControl())) + + expect_equal(rxUiDeparse.bobyqaControl(bobyqaControl(scaleType="multAdd"), "var"), + quoate(var <- bobyqaControl(scaleType = "multAdd"))) + +}) + +test_that("lbfgsb3cControl()", { + expect_equal(rxUiDeparse.lbfgsb3cControl(lbfgsb3cControl(), "var"), + quote(var <- lbfgsb3cControl())) + + expect_equal(rxUiDeparse.lbfgsb3cControl(lbfgsb3cControl(normType="len"), "var"), + quote(var <- lbfgsb3cControl(normType = "len"))) +}) + +test_that("n1qn1Control()", { + expect_equal(rxUiDeparse.n1qn1Control(n1qn1Control(), "var"), + quote(var <- n1qn1Control())) + + expect_equal(rxUiDeparse.n1qn1Control(n1qn1Control(covMethod="n1qn1"), "var"), + quote(var <- n1qn1Control(covMethod = "n1qn1"))) }) From b8303c66a1ed7f094a2f265b2ad00d096007ce37 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 15:19:10 -0500 Subject: [PATCH 14/22] more deparsing tests --- tests/testthat/test-rxuideparse.R | 32 ++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-rxuideparse.R b/tests/testthat/test-rxuideparse.R index 0cae758d..5dc35c9f 100644 --- a/tests/testthat/test-rxuideparse.R +++ b/tests/testthat/test-rxuideparse.R @@ -30,7 +30,7 @@ test_that("bobyqaControl()",{ quote(var <- bobyqaControl())) expect_equal(rxUiDeparse.bobyqaControl(bobyqaControl(scaleType="multAdd"), "var"), - quoate(var <- bobyqaControl(scaleType = "multAdd"))) + quote(var <- bobyqaControl(scaleType = "multAdd"))) }) @@ -49,3 +49,33 @@ test_that("n1qn1Control()", { expect_equal(rxUiDeparse.n1qn1Control(n1qn1Control(covMethod="n1qn1"), "var"), quote(var <- n1qn1Control(covMethod = "n1qn1"))) }) + +test_that("newuoaControl()", { + expect_equal(rxUiDeparse.newuoaControl(newuoaControl(), "var"), + quote(var <- newuoaControl())) + expect_equal(rxUiDeparse.newuoaControl(newuoaControl(addProp="combined1"), "var"), + quote(var <- newuoaControl(addProp = "combined1"))) +}) + +test_that("nlmeControl()", { + expect_equal(rxUiDeparse.nlmeControl(nlmeControl(), "var"), + quote(var <- nlmeControl())) + + expect_equal(rxUiDeparse.nlmeControl(nlmeControl(opt="nlm"), "var"), + quote(var <- nlmeControl(opt = "nlm"))) +}) + +test_that("nlminbControl()", { + expect_equal(rxUiDeparse.nlminbControl(nlminbControl(), "var"), + quote(var <- nlminbControl())) + + expect_equal(rxUiDeparse.nlminbControl(nlminbControl(solveType="grad"), "var"), + quote(var <- nlminbControl(solveType = "grad"))) +}) + +test_that("nlmControl()", { + expect_equal(rxUiDeparse.nlmControl(nlmControl(), "var"), + quote(var <- nlmControl())) + expect_equal(rxUiDeparse.nlmControl(nlmControl(covMethod="r"), "var"), + quote(var <- nlmControl(covMethod = "r"))) +}) From 5f7cb866024410202a62f486c2bdb8dcbe4d481c Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 15:22:12 -0500 Subject: [PATCH 15/22] Fix warning --- R/foceiControl.R | 2 +- tests/testthat/test-rxuideparse.R | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/R/foceiControl.R b/R/foceiControl.R index 3b8a0dc9..d08ce46d 100644 --- a/R/foceiControl.R +++ b/R/foceiControl.R @@ -1360,7 +1360,7 @@ foceiControl <- function(sigdig = 3, # rxUiDeparse.foceiControl <- function(object, var) { .ret <- foceiControl() .outerOpt <- character(0) - if (object$outerOpt == -1L) { + if (object$outerOpt == -1L && object$outerOptTxt == "custom") { warning("functions for `outerOpt` cannot be deparsed, reset to default", call.=FALSE) } else if (object$outerOptTxt != "nlminb") { diff --git a/tests/testthat/test-rxuideparse.R b/tests/testthat/test-rxuideparse.R index 5dc35c9f..13c8ab89 100644 --- a/tests/testthat/test-rxuideparse.R +++ b/tests/testthat/test-rxuideparse.R @@ -79,3 +79,11 @@ test_that("nlmControl()", { expect_equal(rxUiDeparse.nlmControl(nlmControl(covMethod="r"), "var"), quote(var <- nlmControl(covMethod = "r"))) }) + + +test_that("nlsControl()", { + expect_equal(rxUiDeparse.nlsControl(nlsControl(), "var"), + quote(var <- nlsControl())) + expect_equal(rxUiDeparse.nlsControl(nlsControl(algorithm="port"), "var"), + quote(var <- nlsControl(algorithm = "port"))) +}) From d2ffec917bde6362801de76f49a9f97b4f85100a Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 15:32:26 -0500 Subject: [PATCH 16/22] eventType fixes and rest of deparse tests --- R/deparse.R | 4 ++-- tests/testthat/test-rxuideparse.R | 29 ++++++++++++++++++++++++++++- 2 files changed, 30 insertions(+), 3 deletions(-) diff --git a/R/deparse.R b/R/deparse.R index 95978cb6..c9e67aa7 100644 --- a/R/deparse.R +++ b/R/deparse.R @@ -26,7 +26,7 @@ } } else if (x == "eventType") { if (is.integer(value)) { - .eventTypeIdx <- c("central" =2L, "forward"=1L) + .eventTypeIdx <- c("central" =2L, "forward"=1L, "forward"=3L) paste0("eventType = ", deparse1(names(.eventTypeIdx[which(value == .eventTypeIdx)]))) } else { @@ -37,7 +37,7 @@ if (is.integer(value)) { .censMethodIdx <- c("truncated-normal"=3L, "cdf"=2L, "omit"=1L, "pred"=5L, "ipred"=4L, "epred"=6L) paste0("censMethod = ", - deparse1(names(.eventTypeIdx[which(value == .eventTypeIdx)]))) + deparse1(names(.censMethodIdx[which(value == .censMethodIdx)]))) } else { paste0("censMethod = ", deparse1(value)) diff --git a/tests/testthat/test-rxuideparse.R b/tests/testthat/test-rxuideparse.R index 13c8ab89..1297b105 100644 --- a/tests/testthat/test-rxuideparse.R +++ b/tests/testthat/test-rxuideparse.R @@ -5,6 +5,9 @@ test_that("foceiControl() deparse", { covMethod = "s", diagXform = "identity", innerOpt = "BFGS", scaleType = "norm", normType = "std", addProp = "combined1"))) + expect_equal(rxUiDeparse.foceiControl(foceiControl(eventType="forward"), "ctl"), + quote(ctl <- foceiControl(eventType = "forward"))) + expect_equal(rxUiDeparse.foceiControl(foceiControl(), "ctl"), quote(ctl <- foceiControl())) @@ -80,10 +83,34 @@ test_that("nlmControl()", { quote(var <- nlmControl(covMethod = "r"))) }) - test_that("nlsControl()", { expect_equal(rxUiDeparse.nlsControl(nlsControl(), "var"), quote(var <- nlsControl())) expect_equal(rxUiDeparse.nlsControl(nlsControl(algorithm="port"), "var"), quote(var <- nlsControl(algorithm = "port"))) }) + +test_that("optimControl()", { + expect_equal(rxUiDeparse.optimControl(optimControl(), "var"), + quote(var <- optimControl())) + expect_equal(rxUiDeparse.optimControl(optimControl(method="L-BFGS-B"), "var"), + quote(var <- optimControl(method = "L-BFGS-B"))) + + expect_equal(rxUiDeparse.optimControl(optimControl(eventType="forward"), "var"), + quote(var <- optimControl(eventType = "forward"))) +}) + +test_that("uobyqaControl()", { + expect_equal(rxUiDeparse.uobyqaControl(uobyqaControl(), "var"), + quote(var <- uobyqaControl())) + expect_equal(rxUiDeparse.uobyqaControl(uobyqaControl(scaleTo=4), "var"), + quote(var <- uobyqaControl(scaleTo = 4))) +}) + + +test_that("tableControl()", { + expect_equal(rxUiDeparse.tableControl(tableControl(), "var"), + quote(var <- tableControl())) + expect_equal(rxUiDeparse.tableControl(tableControl(censMethod="epred"), "var"), + quote(var <- tableControl(censMethod = "epred"))) +}) From 95eb8b17edae66cc9302be4c7cb462cf811ca529 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 15:41:00 -0500 Subject: [PATCH 17/22] explicitly export/register rxUiDeparse --- NAMESPACE | 15 +++++++++++++++ R/bobyqa.R | 1 + R/foceiControl.R | 1 + R/lbfgsb3c.R | 1 + R/n1qn1.R | 1 + R/newuoa.R | 1 + R/nlm.R | 1 + R/nlme.R | 1 + R/nlminb.R | 1 + R/nls.R | 2 +- R/optim.R | 1 + R/reexports.R | 4 ++++ R/resid.R | 1 + R/saemControl.R | 1 + R/uobyqa.R | 1 + man/reexports.Rd | 3 ++- 16 files changed, 34 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 8d6468e6..07a34944 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -230,6 +230,19 @@ S3method(rxGetDistributionNlsLines,rxUi) S3method(rxModelVarsS3,nlmixr2FitCore) S3method(rxModelVarsS3,nlmixr2FitCoreSilent) S3method(rxParams,nlmixr2FitData) +S3method(rxUiDeparse,bobyqaControl) +S3method(rxUiDeparse,foceiControl) +S3method(rxUiDeparse,lbfgsb3cControl) +S3method(rxUiDeparse,n1qn1Control) +S3method(rxUiDeparse,newuoaControl) +S3method(rxUiDeparse,nlmControl) +S3method(rxUiDeparse,nlmeControl) +S3method(rxUiDeparse,nlminbControl) +S3method(rxUiDeparse,nlsControl) +S3method(rxUiDeparse,optimControl) +S3method(rxUiDeparse,saemControl) +S3method(rxUiDeparse,tableControl) +S3method(rxUiDeparse,uobyqaControl) S3method(rxUiGet,ebe) S3method(rxUiGet,foce) S3method(rxUiGet,foceEnv) @@ -504,6 +517,7 @@ export(rxParam) export(rxParams) export(rxSolve) export(rxState) +export(rxUiDeparse) export(rxode) export(rxode2) export(saemControl) @@ -599,6 +613,7 @@ importFrom(rxode2,rxParam) importFrom(rxode2,rxParams) importFrom(rxode2,rxSolve) importFrom(rxode2,rxState) +importFrom(rxode2,rxUiDeparse) importFrom(rxode2,rxUiGet) importFrom(rxode2,rxode) importFrom(rxode2,rxode2) diff --git a/R/bobyqa.R b/R/bobyqa.R index dd35400a..14a3b7cf 100644 --- a/R/bobyqa.R +++ b/R/bobyqa.R @@ -214,6 +214,7 @@ bobyqaControl <- function(npt=NULL, .ret } +#' @export rxUiDeparse.bobyqaControl <- function(object, var) { .default <- bobyqaControl() .w <- .deparseDifferent(.default, object, "genRxControl") diff --git a/R/foceiControl.R b/R/foceiControl.R index d08ce46d..db9f66bd 100644 --- a/R/foceiControl.R +++ b/R/foceiControl.R @@ -1357,6 +1357,7 @@ foceiControl <- function(sigdig = 3, # return(.ret) } +#' @export rxUiDeparse.foceiControl <- function(object, var) { .ret <- foceiControl() .outerOpt <- character(0) diff --git a/R/lbfgsb3c.R b/R/lbfgsb3c.R index 2b9e4d4b..f9826d2c 100644 --- a/R/lbfgsb3c.R +++ b/R/lbfgsb3c.R @@ -225,6 +225,7 @@ lbfgsb3cControl <- function(trace=0, .ret } +#' @export rxUiDeparse.lbfgsb3cControl <- function(object, var) { .default <- lbfgsb3cControl() .w <- .deparseDifferent(.default, object, "genRxControl") diff --git a/R/n1qn1.R b/R/n1qn1.R index 8e6a4060..01636e73 100644 --- a/R/n1qn1.R +++ b/R/n1qn1.R @@ -190,6 +190,7 @@ n1qn1Control <- function(epsilon = (.Machine$double.eps) ^ 0.25, .ret } +#' @export rxUiDeparse.n1qn1Control <- function(object, var) { .default <- n1qn1Control() .w <- .deparseDifferent(.default, object, "genRxControl") diff --git a/R/newuoa.R b/R/newuoa.R index e3f69fd7..b88d9174 100644 --- a/R/newuoa.R +++ b/R/newuoa.R @@ -184,6 +184,7 @@ newuoaControl <- function(npt=NULL, .ret } +#' @export rxUiDeparse.newuoaControl <- function(object, var) { .default <- newuoaControl() .w <- .deparseDifferent(.default, object, "genRxControl") diff --git a/R/nlm.R b/R/nlm.R index 5416dfc8..f27a9f6f 100644 --- a/R/nlm.R +++ b/R/nlm.R @@ -277,6 +277,7 @@ nlmControl <- function(typsize = NULL, .ret } +#' @export rxUiDeparse.nlmControl <- function(object, var) { .default <- nlmControl() .w <- .deparseDifferent(.default, object, "genRxControl") diff --git a/R/nlme.R b/R/nlme.R index dd80faa3..a80c31f4 100644 --- a/R/nlme.R +++ b/R/nlme.R @@ -118,6 +118,7 @@ nlmixr2NlmeControl <- function(maxIter = 100, pnlsMaxIter = 100, msMaxIter = 100 .ret } +#' @export rxUiDeparse.nlmeControl <- function(object, var) { .default <- nlmeControl() .w <- .deparseDifferent(.default, object, "genRxControl") diff --git a/R/nlminb.R b/R/nlminb.R index 85279a0b..1d4d29ce 100644 --- a/R/nlminb.R +++ b/R/nlminb.R @@ -285,6 +285,7 @@ nlminbControl <- function(eval.max=200, .ret } +#' @export rxUiDeparse.nlminbControl <- function(object, var) { .default <- nlminbControl() .w <- .deparseDifferent(.default, object, "genRxControl") diff --git a/R/nls.R b/R/nls.R index 20d67c7a..3cf97128 100644 --- a/R/nls.R +++ b/R/nls.R @@ -247,7 +247,7 @@ nlsControl <- function(maxiter=10000, .ret } - +#' @export rxUiDeparse.nlsControl <- function(object, var) { .default <- nlsControl() .w <- .deparseDifferent(.default, object, "genRxControl") diff --git a/R/optim.R b/R/optim.R index be69f063..ee8cd250 100644 --- a/R/optim.R +++ b/R/optim.R @@ -338,6 +338,7 @@ optimControl <- function(method = c("Nelder-Mead", "BFGS", "CG", "L-BFGS-B", "SA .ret } +#' @export rxUiDeparse.optimControl <- function(object, var) { .default <- optimControl() .w <- .deparseDifferent(.default, object, "genRxControl") diff --git a/R/reexports.R b/R/reexports.R index fc990694..dda98c67 100644 --- a/R/reexports.R +++ b/R/reexports.R @@ -6,6 +6,10 @@ magrittr::`%>%` #' @export rxode2::rxode2 +#' @importFrom rxode2 rxUiDeparse +#' @export +rxode2::rxUiDeparse + #' @importFrom rxode2 as.rxUi #' @export rxode2::as.rxUi diff --git a/R/resid.R b/R/resid.R index 20b708d1..1b20cd86 100644 --- a/R/resid.R +++ b/R/resid.R @@ -736,6 +736,7 @@ tableControl <- function(npde = NULL, return(.ret) } +#' @export rxUiDeparse.tableControl <- function(object, var) { .default <- tableControl() .w <- .deparseDifferent(.default, object, "genRxControl") diff --git a/R/saemControl.R b/R/saemControl.R index c2ac2850..06768c38 100644 --- a/R/saemControl.R +++ b/R/saemControl.R @@ -332,6 +332,7 @@ saemControl <- function(seed = 99, NA_character_ } +#' @export rxUiDeparse.saemControl <- function(object, var) { .default <- saemControl() .w <- .deparseDifferent(.default, object, c("genRxControl", "DEBUG")) diff --git a/R/uobyqa.R b/R/uobyqa.R index bd33441b..6a6f3c6c 100644 --- a/R/uobyqa.R +++ b/R/uobyqa.R @@ -184,6 +184,7 @@ uobyqaControl <- function(npt=NULL, .ret } +#' @export rxUiDeparse.uobyqaControl <- function(object, var) { .default <- uobyqaControl() .w <- .deparseDifferent(.default, object, "genRxControl") diff --git a/man/reexports.Rd b/man/reexports.Rd index 1d65ff37..a968b085 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -5,6 +5,7 @@ \alias{reexports} \alias{\%>\%} \alias{rxode2} +\alias{rxUiDeparse} \alias{as.rxUi} \alias{rxode} \alias{RxODE} @@ -76,6 +77,6 @@ below to see their documentation. \item{nlme}{\code{\link[nlme]{ACF}}, \code{\link[nlme]{augPred}}, \code{\link[nlme]{fixed.effects}}, \code{\link[nlme:fixed.effects]{fixef}}, \code{\link[nlme]{getData}}, \code{\link[nlme]{getVarCov}}, \code{\link[nlme]{groupedData}}, \code{\link[nlme]{nlme}}, \code{\link[nlme]{pdBlocked}}, \code{\link[nlme]{pdCompSymm}}, \code{\link[nlme]{pdConstruct}}, \code{\link[nlme]{pdDiag}}, \code{\link[nlme]{pdFactor}}, \code{\link[nlme]{pdIdent}}, \code{\link[nlme]{pdLogChol}}, \code{\link[nlme]{pdMat}}, \code{\link[nlme]{pdMatrix}}, \code{\link[nlme]{pdNatural}}, \code{\link[nlme]{pdSymm}}, \code{\link[nlme]{random.effects}}, \code{\link[nlme:random.effects]{ranef}}, \code{\link[nlme]{reStruct}}, \code{\link[nlme]{varComb}}, \code{\link[nlme]{varConstPower}}, \code{\link[nlme]{VarCorr}}, \code{\link[nlme]{varExp}}, \code{\link[nlme]{varFixed}}, \code{\link[nlme]{varFunc}}, \code{\link[nlme]{varIdent}}, \code{\link[nlme]{varPower}}, \code{\link[nlme]{varWeights}}} - \item{rxode2}{\code{\link[rxode2]{add.dosing}}, \code{\link[rxode2]{add.sampling}}, \code{\link[rxode2]{as.rxUi}}, \code{\link[rxode2]{et}}, \code{\link[rxode2]{et}}, \code{\link[rxode2]{eventTable}}, \code{\link[rxode2:logit]{expit}}, \code{\link[rxode2:stat_amt]{geom_amt}}, \code{\link[rxode2:stat_cens]{geom_cens}}, \code{\link[rxode2]{ini}}, \code{\link[rxode2]{logit}}, \code{\link[rxode2:reexports]{lotri}}, \code{\link[rxode2]{model}}, \code{\link[rxode2]{probit}}, \code{\link[rxode2:probit]{probitInv}}, \code{\link[rxode2]{rxCat}}, \code{\link[rxode2]{rxClean}}, \code{\link[rxode2:rxSolve]{rxControl}}, \code{\link[rxode2:rxInits]{rxInit}}, \code{\link[rxode2]{rxLhs}}, \code{\link[rxode2]{rxModelVars}}, \code{\link[rxode2:rxModelVars]{rxModelVarsS3}}, \code{\link[rxode2:rxode2]{rxode}}, \code{\link[rxode2:rxode2]{RxODE}}, \code{\link[rxode2]{rxode2}}, \code{\link[rxode2:rxParams]{rxParam}}, \code{\link[rxode2]{rxParams}}, \code{\link[rxode2]{rxParams}}, \code{\link[rxode2]{rxSolve}}, \code{\link[rxode2]{rxSolve}}, \code{\link[rxode2]{rxState}}, \code{\link[rxode2]{stat_amt}}, \code{\link[rxode2]{stat_cens}}} + \item{rxode2}{\code{\link[rxode2]{add.dosing}}, \code{\link[rxode2]{add.sampling}}, \code{\link[rxode2]{as.rxUi}}, \code{\link[rxode2]{et}}, \code{\link[rxode2]{et}}, \code{\link[rxode2]{eventTable}}, \code{\link[rxode2:logit]{expit}}, \code{\link[rxode2:stat_amt]{geom_amt}}, \code{\link[rxode2:stat_cens]{geom_cens}}, \code{\link[rxode2]{ini}}, \code{\link[rxode2]{logit}}, \code{\link[rxode2:reexports]{lotri}}, \code{\link[rxode2]{model}}, \code{\link[rxode2]{probit}}, \code{\link[rxode2:probit]{probitInv}}, \code{\link[rxode2]{rxCat}}, \code{\link[rxode2]{rxClean}}, \code{\link[rxode2:rxSolve]{rxControl}}, \code{\link[rxode2:rxInits]{rxInit}}, \code{\link[rxode2]{rxLhs}}, \code{\link[rxode2]{rxModelVars}}, \code{\link[rxode2:rxModelVars]{rxModelVarsS3}}, \code{\link[rxode2:rxode2]{rxode}}, \code{\link[rxode2:rxode2]{RxODE}}, \code{\link[rxode2]{rxode2}}, \code{\link[rxode2:rxParams]{rxParam}}, \code{\link[rxode2]{rxParams}}, \code{\link[rxode2]{rxParams}}, \code{\link[rxode2]{rxSolve}}, \code{\link[rxode2]{rxSolve}}, \code{\link[rxode2]{rxState}}, \code{\link[rxode2]{rxUiDeparse}}, \code{\link[rxode2]{stat_amt}}, \code{\link[rxode2]{stat_cens}}} }} From f0aa96b2ea83a8c77fbe318d0550d58198c62ded Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 19:05:32 -0500 Subject: [PATCH 18/22] Change test --- tests/testthat/test-rxuideparse.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-rxuideparse.R b/tests/testthat/test-rxuideparse.R index 1297b105..87dda27a 100644 --- a/tests/testthat/test-rxuideparse.R +++ b/tests/testthat/test-rxuideparse.R @@ -93,7 +93,7 @@ test_that("nlsControl()", { test_that("optimControl()", { expect_equal(rxUiDeparse.optimControl(optimControl(), "var"), quote(var <- optimControl())) - expect_equal(rxUiDeparse.optimControl(optimControl(method="L-BFGS-B"), "var"), + expect_equal(rxUiDeparse.optimControl(optimControl(method="L-BFGS-B", covMethod = "optim"), "var"), quote(var <- optimControl(method = "L-BFGS-B"))) expect_equal(rxUiDeparse.optimControl(optimControl(eventType="forward"), "var"), From 87c0ac8a3376e8c01f9c833abeff7b6fc1417b1a Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 21:22:04 -0500 Subject: [PATCH 19/22] change both --- tests/testthat/test-rxuideparse.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-rxuideparse.R b/tests/testthat/test-rxuideparse.R index 87dda27a..4e5c5e85 100644 --- a/tests/testthat/test-rxuideparse.R +++ b/tests/testthat/test-rxuideparse.R @@ -94,7 +94,7 @@ test_that("optimControl()", { expect_equal(rxUiDeparse.optimControl(optimControl(), "var"), quote(var <- optimControl())) expect_equal(rxUiDeparse.optimControl(optimControl(method="L-BFGS-B", covMethod = "optim"), "var"), - quote(var <- optimControl(method = "L-BFGS-B"))) + quote(var <- optimControl(method = "L-BFGS-B", covMethod="optim"))) expect_equal(rxUiDeparse.optimControl(optimControl(eventType="forward"), "var"), quote(var <- optimControl(eventType = "forward"))) From 70dc394d977e4cf4e115985779c96e7191a4bf51 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 21:38:32 -0500 Subject: [PATCH 20/22] Explicitly call keepInterpolation="na" so that missing DV will be missing --- R/augPred.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/augPred.R b/R/augPred.R index 0c8c20b0..341ab877 100644 --- a/R/augPred.R +++ b/R/augPred.R @@ -107,6 +107,7 @@ #' @export nlmixr2AugPredSolve <- function(fit, covsInterpolation = c("locf", "nocb", "linear", "midpoint"), minimum = NULL, maximum = NULL, length.out = 51L, ...) { + browser() .si <- fit$simInfo .rx <- .getSimModel(fit, hideIpred=TRUE) .rx <- eval(.rx) @@ -127,6 +128,7 @@ nlmixr2AugPredSolve <- function(fit, covsInterpolation = c("locf", "nocb", "line # ipred .sim <- rxode2::rxSolve(object=.rx, .params, .events, + keepInterpolation="na", keep=c("DV", "CMT"), returnType="data.frame") # now do pred if (is.null(.omega)) { From 0555279358c9bde641db44f9a9635d0f30a54312 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 21:46:16 -0500 Subject: [PATCH 21/22] Remove browser() --- R/augPred.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/augPred.R b/R/augPred.R index 341ab877..4e39bbe9 100644 --- a/R/augPred.R +++ b/R/augPred.R @@ -107,7 +107,6 @@ #' @export nlmixr2AugPredSolve <- function(fit, covsInterpolation = c("locf", "nocb", "linear", "midpoint"), minimum = NULL, maximum = NULL, length.out = 51L, ...) { - browser() .si <- fit$simInfo .rx <- .getSimModel(fit, hideIpred=TRUE) .rx <- eval(.rx) From 830e6be2b7b1ad655ea38e920523857a496accd8 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Mon, 16 Sep 2024 21:50:54 -0500 Subject: [PATCH 22/22] Add tests for augPred not interpolating obs --- tests/testthat/test-augpred.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-augpred.R b/tests/testthat/test-augpred.R index acd47293..26e84bfb 100644 --- a/tests/testthat/test-augpred.R +++ b/tests/testthat/test-augpred.R @@ -38,7 +38,12 @@ nmTest({ tableControl(cwres = TRUE, npde=TRUE) ) - expect_error(augPred(fitOne.comp.KA.solved_S), NA) + expect_error(augPred(fitOne.comp.KA.solved_S), NA) + + ap <- augPred(fitOne.comp.KA.solved_S) + + expect_equal(as.character(ap[ap$id == 1 & ap$time == 120, "ind"]), + c("Individual", "Population")) skip_if_not(rxode2::.linCmtSensB())