Merge pull request #787 from nlmixr2/786-custom-deparse

New generic

NAMESPACE

@@ -157,6 +157,9 @@ S3method(rxSolve,rxUi)
 S3method(rxSolve,rxode2tos)
 S3method(rxTrans,character)
 S3method(rxTrans,default)
+S3method(rxUiDeparse,default)
+S3method(rxUiDeparse,lotriFix)
+S3method(rxUiDeparse,rxControl)
 S3method(rxUiGet,allCovs)
 S3method(rxUiGet,cmtLines)
 S3method(rxUiGet,covLhs)
@@ -332,6 +335,7 @@ export(assertVariableExists)
 export(assertVariableName)
 export(assertVariableNew)
 export(binomProbs)
+export(boxCox)
 export(boxCoxInv)
 export(cvPost)
 export(dfWishart)
@@ -527,6 +531,7 @@ export(rxToSE)
 export(rxTrans)
 export(rxUiCompress)
 export(rxUiDecompress)
+export(rxUiDeparse)
 export(rxUiGet)
 export(rxUnload)
 export(rxUnloadAll)

NEWS.md

@@ -133,6 +133,12 @@
   level model variable `$stateProp` which has this information
   encoded in integers for each state.
 
+- A new generic method `rxUiDeparse` can be used to deparse meta
+  information into more readable expressions; This currently by
+  default supports lower triangular matrices by lotri, but can be
+  extended to support other types of objects like 'nlmixr2's
+  `foceiControl()` for instance.
+
 ## Bug fixes
 
 - Fix `ui$props$endpoint` when the ui endpoint is defined in terms of

R/rxUiGet.R

@@ -284,6 +284,49 @@ rxUiGet.multipleEndpoint <- function(x, ...) {
 }
 attr(rxUiGet.multipleEndpoint, "desc") <- "table of multiple endpoint translations"
 
+#' This is a generic function for deparsing certain objects when
+#' printing out a rxode2 object.  Currently it is used for any meta-information
+#'
+#' @param object object to be deparsed
+#' @param var variable name to be assigned
+#' @return parsed R expression that can be used for printing and
+#'   `as.function()` calls.
+#' @export
+#' @author Matthew L. Fidler
+#' @examples
+#'
+#' mat <- matrix(c(1, 0.1, 0.1, 1), 2, 2, dimnames=list(c("a", "b"), c("a", "b")))
+#'
+#' rxUiDeparse(matrix(c(1, 0.1, 0.1, 1), 2, 2, dimnames=list(c("a", "b"), c("a", "b"))), "x")
+rxUiDeparse <- function(object, var) {
+ UseMethod("rxUiDeparse")
+}
+
+#' @rdname rxUiDeparse
+#' @export
+rxUiDeparse.lotriFix <- function(object, var) {
+  .val <- lotri::lotriAsExpression(object)
+  bquote(.(str2lang(var)) <- .(.val))
+}
+
+#' @rdname rxUiDeparse
+#' @export
+rxUiDeparse.default <- function(object, var) {
+  # This is a default method for deparsing objects
+  if (checkmate::testMatrix(object, any.missing=FALSE,
+                            row.names="strict", col.names="strict")) {
+    .dn <- dimnames(object)
+    if (identical(.dn[[1]], .dn[[2]]) && isSymmetric(object)) {
+      return(rxUiDeparse.lotriFix(object, var))
+    }
+  }
+  .ret <- try(str2lang(paste0(var, "<-", deparse1(object))))
+  if (inherits(.ret, "try-error")) {
+    .ret <- str2lang("NULL")
+  }
+  .ret
+}
+
 #' @rdname rxUiGet
 #' @export
 rxUiGet.funPrint <- function(x, ...) {
@@ -295,20 +338,7 @@ rxUiGet.funPrint <- function(x, ...) {
   for (.i in seq_along(.ls)) {
     .var <- .ls[.i]
     .val <- .x$meta[[.ls[.i]]]
-    .isLotri <- FALSE
-    if (checkmate::testMatrix(.val, any.missing=FALSE, row.names="strict", col.names="strict")) {
-      .dn <- dimnames(.val)
-      if (identical(.dn[[1]], .dn[[2]]) && isSymmetric(.val)) {
-        class(.val) <- c("lotriFix", class(.val))
-        .val <- as.expression(.val)
-        .val <- bquote(.(str2lang(.var)) <- .(.val))
-        .ret[[.i + 1]] <- .val
-        .isLotri <- TRUE
-      }
-    }
-    if (!.isLotri) {
-      .ret[[.i + 1]] <- eval(parse(text=paste("quote(", .var, "<-", deparse1(.val), ")")))
-    }
+    .ret[[.i + 1]] <- rxUiDeparse(.val, .var)
   }
   .theta <- x$theta
   .omega <- x$omega

R/rxsolve.R

@@ -722,7 +722,8 @@ rxSolve <- function(object, params = NULL, events = NULL, inits = NULL,
                     omegaXform = c("variance", "identity", "log", "nlmixrSqrt", "nlmixrLog", "nlmixrIdentity"),
                     omegaLower = -Inf, omegaUpper = Inf,
                     nSub = 1L, thetaMat = NULL, thetaDf = NULL, thetaIsChol = FALSE,
-                    nStud = 1L, dfSub = 0.0, dfObs = 0.0, returnType = c("rxSolve", "matrix", "data.frame", "data.frame.TBS", "data.table", "tbl", "tibble"),
+                    nStud = 1L, dfSub = 0.0, dfObs = 0.0,
+                    returnType = c("rxSolve", "matrix", "data.frame", "data.frame.TBS", "data.table", "tbl", "tibble"),
                     seed = NULL, nsim = NULL,
                     minSS = 10L, maxSS = 1000L,
                     infSSstep = 12,
@@ -2254,3 +2255,65 @@ rxControlUpdateSens <- function(rxControl, sensCmt=NULL, ncmt=NULL) {
   rxControl$ssRtol <- c(rep(rxControl$ssRtol[1], ncmt - sensCmt), rep(rxControl$ssRtolSens, sensCmt))
   rxControl
 }
+
+
+#' rxUiDeparse.rxControl(rxControl(covsInterpolation="linear", method="dop853",
+#'  naInterpolation="nocb", keepInterpolation="nocb", sigmaXform="variance",
+#'  omegaXform="variance", returnType="data.frame", sumType="fsum", prodType="logify",
+#'  sensType="central"), "ctl")
+
+#' @rdname rxUiDeparse
+#' @export
+rxUiDeparse.rxControl <- function(object, var) {
+  .ret <- rxControl()
+
+  .w <- which(vapply(names(.ret), function(x) {
+    if (is.integer(.ret[[x]]) && is.integer(object[[x]])) {
+      .ret[[x]] != object[[x]]
+    } else {
+      !identical(.ret[[x]], object[[x]])
+    }
+  }, logical(1)))
+
+  .retD <- vapply(names(.ret)[.w], function(x) {
+    if (x == "covsInterpolation") {
+      .covsInterpolation <- c("linear"=0L, "locf"=1L, "nocb"=2L, "midpoint"=3L)
+      paste0(x, " =", deparse1(names(.covsInterpolation)[which(object[[x]] == .covsInterpolation)]))
+    } else if (x == "method")  {
+      .methodIdx <- c("lsoda" = 1L, "dop853" = 0L, "liblsoda" = 2L, "indLin" = 3L)
+      paste0(x, " =", deparse1(names(.methodIdx)[which(object[[x]] == .methodIdx)]))
+    } else if (x == "naInterpolation") {
+      .naInterpolation <- c("locf"=1L, "nocb"=0L)
+      paste0(x, " =", deparse1(names(.naInterpolation)[which(object[[x]] == .naInterpolation)]))
+    } else if (x == "keepInterpolation") {
+      .keepInterpolation <- c("locf"=1L, "nocb"=0L, "na"=2L)
+      paste0(x, " =", deparse1(names(.keepInterpolation)[which(object[[x]] == .keepInterpolation)]))
+    } else if (x %in% c("sigmaXform", "omegaXform")) {
+      .sigmaXform <- c(
+        "variance" = 6L, "log" = 5L, "identity" = 4L,
+        "nlmixrSqrt" = 1L, "nlmixrLog" = 2L,
+        "nlmixrIdentity" = 3L)
+      paste0(x, " =", deparse1(names(.sigmaXform)[which(object[[x]] == .sigmaXform)]))
+    } else if (x == "returnType") {
+      .matrixIdx <- c(
+        "rxSolve" = 0L, "matrix" = 1L, "data.frame" = 2L, "data.frame.TBS" = 3L, "data.table" = 4L,
+        "tbl" = 5L, "tibble" = 5L)
+      paste0(x, " =", deparse1(names(.matrixIdx)[which(object[[x]] == .matrixIdx)]))
+    } else if (x == "sumType") {
+      .sum <- c("pairwise"=1L, "fsum"=2L, "kahan"=3L , "neumaier"=4L, "c"=5L)
+      paste0(x, " = ", deparse1(names(.sum)[which(object[[x]] == .sum)]))
+    } else if (x == "prodType") {
+      .prod <- c("long double"=1L, "double"=1L, "logify"=1L)
+      paste0(x, " = ", deparse1(names(.prod)[which(object[[x]] == .prod)]))
+    } else if (x == "sensType") {
+      .sensType <- c("autodiff"=1L, "forward"=2L, "central"=3L, "advan"=4L)
+      paste0(x, " = ", deparse1(names(.sensType)[which(object[[x]] == .sensType)]))
+    } else if (x == "naTimeHandle") {
+      .naTimeHandle <- c("ignore"=1L, "warn"=2L, "error"=3L)
+      paste0(x, " = ", deparse1(names(.naTimeHandle)[which(object[[x]] == .naTimeHandle)]))
+    }  else {
+      paste0(x, "=", deparse1(object[[x]]))
+    }
+  }, character(1), USE.NAMES=FALSE)
+  str2lang(paste(var, " <- rxControl(", paste(.retD, collapse=","),")"))
+}

R/utils.R

@@ -434,8 +434,8 @@ gammapInva <- function(x, p) {
                       transform=transform, inverse=inverse)
     vapply(1:nrow(.df),
            function(i) {
-             .powerD(.df$x[i], .df$lambda[i], .df$low[i], .df$high[i],
-                     .df$transform[i], .df$inverse[i])
+             .rxTransform(.df$x[i], .df$lambda[i], .df$low[i], .df$high[i],
+                          .df$transform[i], .df$inverse[i])
     }, numeric(1), USE.NAMES = FALSE)
   } else {
     checkmate::assertNumeric(x, any.missing = FALSE)
@@ -562,12 +562,13 @@ probitNormInfo <- function(mean = 0, sd = 1, low = 0, high = 1, abs.tol = 1e-6,
 #' @param lambda lambda value for the transformation
 #' @return values from boxCox and boxCoxInv
 #' @export
+#' @examples
 #'
 #' boxCox(10, 0.5)
 #'
 #' boxCoxInv(4.32, 0.5)
 #'
-#' yeoJohson(10, 0.5)
+#' yeoJohnson(10, 0.5)
 #'
 #' yeoJohnsonInv(4.32, 0.5)
 #'

src/utilc.c

@@ -604,6 +604,12 @@ SEXP _rxode2_powerD(SEXP xS, SEXP lowS, SEXP highS, SEXP lambdaS, SEXP yjS, SEXP
   int inverse = INTEGER(inverseS)[0];
   int yj = INTEGER(yjS)[0];
   double low, high, lambda;
+  if (Rf_length(inverseS) != 1) {
+    Rf_errorcall(R_NilValue, _("'inverse' must be an logical of length 1"));
+  }
+  if (Rf_length(yjS) != 1) {
+    Rf_errorcall(R_NilValue, _("'yj' must be an integer of length 1"));
+  }
   if (Rf_length(lambdaS) != 1){
     Rf_errorcall(R_NilValue, _("'lambda' must be a numeric of length 1"));
   }

tests/testthat/test-logit.R

@@ -51,8 +51,15 @@ rxTest({
 
     expect_equal(logit(1:10, 0L, 11L), logit(as.double(1:10), 0.0, 11.0))
 
-    expect_error(logit(0.5, c(1, 2)))
-    expect_error(logit(0.5, 0, c(1, 2)))
+    expect_equal(logit(7, c(1, 2), c(10, 114)),
+                 c(logit(7, 1, 10),
+                   logit(7, 2, 114)))
+
+    expect_error(.Call(`_rxode2_powerD`, 0.5, c(1, 2), 3, 4, 4L, TRUE))
+    expect_error(.Call(`_rxode2_powerD`, 0.5, 1, c(3, 4), 4, 4L, TRUE))
+    expect_error(.Call(`_rxode2_powerD`, 0.5, 1, 3, 4, c(4L, 5L), TRUE))
+    expect_error(.Call(`_rxode2_powerD`, 0.5, 1, 3, 4, 4L, c(TRUE, FALSE)))
+
     expect_error(logit(0.5, 1, -2))
   })
 
@@ -107,9 +114,5 @@ rxTest({
     )
 
     expect_equal(expit(1:10, 0L, 11L), expit(as.double(1:10), 0.0, 11.0))
-
-    expect_error(expit(0.5, c(1, 2)))
-    expect_error(expit(0.5, 0, c(1, 2)))
-    expect_error(expit(0.5, 1, -2))
   })
 })

tests/testthat/test-rxUiDeparse.R

@@ -0,0 +1,13 @@
+test_that("rxUiDeparse()", {
+
+  rxUiDeparse(rxControl(), "a")
+  expect_equal(rxUiDeparse(rxControl(), "a"),
+               str2lang("a <- rxControl()"))
+
+  expect_equal(rxUiDeparse(rxControl(covsInterpolation="linear", method="dop853",
+                                    naInterpolation="nocb", keepInterpolation="nocb", sigmaXform="variance",
+                                    omegaXform="variance", returnType="data.frame", sumType="fsum", prodType="logify",
+                                    sensType="central"), "a"),
+               str2lang("a <- rxControl(method = \"dop853\", covsInterpolation = \"linear\", returnType = \"data.frame\", sigmaXform = \"variance\", sumType = \"fsum\", sensType = \"central\", naInterpolation = \"nocb\", keepInterpolation = \"nocb\")"))
+
+})