Merge pull request #480 from nlmixr2/480-session-info

Minimum session information

DESCRIPTION

@@ -81,7 +81,8 @@ Suggests:
     withr,
     xgxr,
     sfsmisc,
-    minpack.lm
+    minpack.lm,
+    remotes
 LinkingTo:
     BH,
     n1qn1 (>= 6.0.1-12),

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)

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)) {

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

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=","),")"))
+}

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)

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)

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

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

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

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

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

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

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