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), diff --git a/NAMESPACE b/NAMESPACE index fdbacbcf..07a34944 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) @@ -228,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) @@ -361,6 +376,9 @@ S3method(update,nlmixr2FitData) S3method(vcov,nlmixr2FitCore) S3method(vcov,nlmixr2FitCoreSilent) export("%>%") +export(.addPkgNlmixr2) +export(.deparseDifferent) +export(.deparseFinal) export(.foceiPreProcessData) export(.nlmFinalizeList) export(.nlmFreeEnv) @@ -499,6 +517,7 @@ export(rxParam) export(rxParams) export(rxSolve) export(rxState) +export(rxUiDeparse) export(rxode) export(rxode2) export(saemControl) @@ -594,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/augPred.R b/R/augPred.R index 0c8c20b0..4e39bbe9 100644 --- a/R/augPred.R +++ b/R/augPred.R @@ -127,6 +127,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)) { diff --git a/R/bobyqa.R b/R/bobyqa.R index d6a5423c..14a3b7cf 100644 --- a/R/bobyqa.R +++ b/R/bobyqa.R @@ -214,6 +214,13 @@ bobyqaControl <- function(npt=NULL, .ret } +#' @export +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..c9e67aa7 --- /dev/null +++ b/R/deparse.R @@ -0,0 +1,132 @@ +.deparseShared <- function(x, value) { + if (x == "rxControl") { + .rx <- rxUiDeparse(value, "a") + .rx <- .rx[[3]] + paste0("rxControl = ", deparse1(.rx)) + } else if (x == "scaleType") { + if (is.integer(value)) { + .scaleTypeIdx <- c("norm" = 1L, "nlmixr2" = 2L, "mult" = 3L, "multAdd" = 4L) + paste0("scaleType =", deparse1(names(.scaleTypeIdx[which(value == .scaleTypeIdx)]))) + } else { + paste0("scaleType =", deparse1(value)) + } + } else if (x == "normType") { + if (is.integer(value)) { + .normTypeIdx <- c("rescale2" = 1L, "rescale" = 2L, "mean" = 3L, "std" = 4L, "len" = 5L, "constant" = 6L) + paste0("normType =", deparse1(names(.normTypeIdx[which(value == .normTypeIdx)]))) + } else { + paste0("normType =", deparse1(value)) + } + } else if (x == "solveType") { + if (is.integer(value)) { + .solveTypeIdx <- c("hessian" = 3L, "grad" = 2L, "fun" = 1L) + paste0("solveType =", deparse1(names(.solveTypeIdx[which(value == .solveTypeIdx)]))) + } else { + paste0("normType =", deparse1(value)) + } + } else if (x == "eventType") { + if (is.integer(value)) { + .eventTypeIdx <- c("central" =2L, "forward"=1L, "forward"=3L) + paste0("eventType = ", + deparse1(names(.eventTypeIdx[which(value == .eventTypeIdx)]))) + } else { + paste0("eventType = ", + deparse1(value)) + } + } else if (x == "censMethod") { + if (is.integer(value)) { + .censMethodIdx <- c("truncated-normal"=3L, "cdf"=2L, "omit"=1L, "pred"=5L, "ipred"=4L, "epred"=6L) + paste0("censMethod = ", + deparse1(names(.censMethodIdx[which(value == .censMethodIdx)]))) + } else { + paste0("censMethod = ", + deparse1(value)) + } + } else { + NA_character_ + } +} + +#' 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) { + if (x %in% internal){ + FALSE + } 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]]) + } + }, 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) { + 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/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/foceiControl.R b/R/foceiControl.R index 914d3300..db9f66bd 100644 --- a/R/foceiControl.R +++ b/R/foceiControl.R @@ -1357,42 +1357,28 @@ 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) - if (object$outerOptTxt != "nlminb") { + if (object$outerOpt == -1L && object$outerOptTxt == "custom") { + warning("functions for `outerOpt` cannot be deparsed, reset to default", + call.=FALSE) + } else if (object$outerOptTxt != "nlminb") { .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/lbfgsb3c.R b/R/lbfgsb3c.R index e8d51fa3..f9826d2c 100644 --- a/R/lbfgsb3c.R +++ b/R/lbfgsb3c.R @@ -225,6 +225,13 @@ lbfgsb3cControl <- function(trace=0, .ret } +#' @export +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/n1qn1.R b/R/n1qn1.R index afc7b481..01636e73 100644 --- a/R/n1qn1.R +++ b/R/n1qn1.R @@ -190,6 +190,14 @@ n1qn1Control <- function(epsilon = (.Machine$double.eps) ^ 0.25, .ret } +#' @export +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..b88d9174 100644 --- a/R/newuoa.R +++ b/R/newuoa.R @@ -184,6 +184,13 @@ newuoaControl <- function(npt=NULL, .ret } +#' @export +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/nlm.R b/R/nlm.R index 7f91b2d6..f27a9f6f 100644 --- a/R/nlm.R +++ b/R/nlm.R @@ -277,6 +277,14 @@ nlmControl <- function(typsize = NULL, .ret } +#' @export +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/nlme.R b/R/nlme.R index 2a58482c..a80c31f4 100644 --- a/R/nlme.R +++ b/R/nlme.R @@ -118,6 +118,14 @@ nlmixr2NlmeControl <- function(maxIter = 100, pnlsMaxIter = 100, msMaxIter = 100 .ret } +#' @export +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..1d4d29ce 100644 --- a/R/nlminb.R +++ b/R/nlminb.R @@ -285,6 +285,13 @@ nlminbControl <- function(eval.max=200, .ret } +#' @export +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/nls.R b/R/nls.R index 2fd2dd08..3cf97128 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 } +#' @export +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..ee8cd250 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,12 @@ 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") + .deparseFinal(.default, object, .w, var) +} #' A surrogate function for optim to call for ode solving #' 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 71f5adfa..1b20cd86 100644 --- a/R/resid.R +++ b/R/resid.R @@ -735,3 +735,10 @@ tableControl <- function(npde = NULL, class(.ret) <- "tableControl" return(.ret) } + +#' @export +rxUiDeparse.tableControl <- function(object, var) { + .default <- tableControl() + .w <- .deparseDifferent(.default, object, "genRxControl") + .deparseFinal(.default, object, .w, var) +} diff --git a/R/saemControl.R b/R/saemControl.R index 36bc20c6..06768c38 100644 --- a/R/saemControl.R +++ b/R/saemControl.R @@ -309,3 +309,32 @@ 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_ +} + +#' @export +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/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) +} diff --git a/R/uobyqa.R b/R/uobyqa.R index e399a1ed..6a6f3c6c 100644 --- a/R/uobyqa.R +++ b/R/uobyqa.R @@ -184,6 +184,13 @@ uobyqaControl <- function(npt=NULL, .ret } +#' @export +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/onLoad.R b/R/zzz.R similarity index 75% rename from R/onLoad.R rename to R/zzz.R index f9479d58..b5befb16 100644 --- a/R/onLoad.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") @@ -70,18 +72,37 @@ 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") + 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") + 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") + rxode2::.s3register("rxode2::rxUiDeparse", "tableControl") .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 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} 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} 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}}} }} 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()) diff --git a/tests/testthat/test-rxuideparse.R b/tests/testthat/test-rxuideparse.R index d8aef259..4e5c5e85 100644 --- a/tests/testthat/test-rxuideparse.R +++ b/tests/testthat/test-rxuideparse.R @@ -5,4 +5,112 @@ 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())) + + 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())) + +}) + +test_that("bobyqaControl()",{ + + expect_equal(rxUiDeparse.bobyqaControl(bobyqaControl(), "var"), + quote(var <- bobyqaControl())) + + expect_equal(rxUiDeparse.bobyqaControl(bobyqaControl(scaleType="multAdd"), "var"), + quote(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"))) +}) + +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"))) +}) + +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", covMethod = "optim"), "var"), + quote(var <- optimControl(method = "L-BFGS-B", covMethod="optim"))) + + 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"))) })