Add named random for ui

nlmixr2 · Oct 16, 2024 · da39c24 · da39c24
1 parent f7f43fb
commit da39c24
Show file tree

Hide file tree

Showing 4 changed files with 666 additions and 19 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -168,7 +168,32 @@ S3method(rxUdfUi,linModD)
 S3method(rxUdfUi,linModD0)
 S3method(rxUdfUi,linModM)
 S3method(rxUdfUi,linModM0)
+S3method(rxUdfUi,ribeta)
+S3method(rxUdfUi,ribinom)
+S3method(rxUdfUi,ricauchy)
+S3method(rxUdfUi,richisq)
+S3method(rxUdfUi,riexp)
+S3method(rxUdfUi,rif)
+S3method(rxUdfUi,rigamma)
+S3method(rxUdfUi,rigeom)
+S3method(rxUdfUi,rinorm)
+S3method(rxUdfUi,ripois)
+S3method(rxUdfUi,rit)
+S3method(rxUdfUi,riunif)
+S3method(rxUdfUi,riweibull)
+S3method(rxUdfUi,rxbeta)
+S3method(rxUdfUi,rxbinom)
+S3method(rxUdfUi,rxcauchy)
+S3method(rxUdfUi,rxchisq)
+S3method(rxUdfUi,rxexp)
+S3method(rxUdfUi,rxf)
+S3method(rxUdfUi,rxgamma)
+S3method(rxUdfUi,rxgeom)
+S3method(rxUdfUi,rxnorm)
 S3method(rxUdfUi,rxpois)
+S3method(rxUdfUi,rxt)
+S3method(rxUdfUi,rxunif)
+S3method(rxUdfUi,rxweibull)
 S3method(rxUiDeparse,default)
 S3method(rxUiDeparse,lotriFix)
 S3method(rxUiDeparse,rxControl)

diff --git a/R/build.R b/R/build.R
@@ -59,9 +59,81 @@ d/dt(blood)     = a*intestine - b*blood
   sink() # nolint
 }
 
+.generateRandomUiFun <- function(fun, args, vals=NULL) {
+  .ret <- as.call(c(
+    quote(`{`),
+    do.call(`c`,
+            lapply(args, function(arg) {
+              .dotArg <- str2lang(paste0(".", arg))
+              .arg <- str2lang(arg)
+              .ret <- bquote({
+                .(.dotArg) <- as.character(substitute(.(.arg)))
+                .tmp <- suppressWarnings(try(force(.(.arg)), silent=TRUE))
+                if (!inherits(.tmp, "try-error")) {
+                  if (is.character(.tmp)) {
+                    .(.dotArg) <- .(.arg)
+                  }
+                }
+              })
+              lapply(seq_along(.ret)[-1], function(i) {
+                .ret[[i]]
+              })
+            })),
+    str2lang(paste0("list(replace=paste0('", fun, "(', ", paste(paste0(".", args), collapse=", ', ', "), ", ')'))"))
+  ))
+  if (is.null(vals)) {
+    .f <- paste0(".", fun, " <- function(", paste(args, collapse=", "), ") ",
+                 paste(deparse(.ret), collapse="\n"),
+                 "\n")
+  } else {
+    .f <- paste0(".", fun, " <- function(", paste0(paste0(args, ifelse(is.na(vals), "", " = "), ifelse(is.na(vals), "", vals)),
+                                                  collapse=", "), ") ",
+                 paste(deparse(.ret), collapse="\n"),
+                 "\n")
+  }
+  .f <- paste0(.f, "\n#'@export\nrxUdfUi.", fun, " <- rxUdfUi.rxpois\n\n")
+  .f
+}
+
+.generateRandomUiFuns <- function() {
+  .lst <- list("rxnorm"=c("mean"=0, "sd"=1),
+               "rxpois"="lambda",
+               "rxt"="df",
+               "rxunif"=c("min"=0, "max"=1),
+               "rxweibull"=c("shape"=NA, "scale"=1),
+               "rxgeom"="prob",
+               "rxbeta"=c("shape1", "shape2"),
+               "rxgamma"=c("shape"=NA, "rate"=1),
+               "rxf"=c("df1","df2"),
+               "rxexp"="rate",
+               "rxchisq"="df",
+               "rxcauchy"=c(location = 0, scale = 1),
+               "rxbinom"=c("size", "prob"))
+  .lst2 <- .lst
+  names(.lst2) <- gsub("rx", "ri", names(.lst2))
+  .lst <- c(.lst, .lst2)
+  paste0("# This file is generated by .generateRandomUiFuns() in build.R\n## nocov start\n",
+         vapply(names(.lst), function(fun) {
+           if (is.null(names(.lst[[fun]]))) {
+             .generateRandomUiFun(fun, .lst[[fun]])
+           } else {
+             .generateRandomUiFun(fun, names(.lst[[fun]]), .lst[[fun]])
+           }
+         }, character(1), USE.NAMES=FALSE),
+         "## nocov end")
+}
+
 
 .rxodeBuildCode <- function() {
   # This builds the code needed for rxode2
+  message("Generate rxode2 random named arguments option")
+
+  .l <- .generateRandomUiFuns()
+  .R <- file(devtools::package_file("R/rxrandomui.R"), "wb")
+  writeLines(.l, .R)
+  close(.R)
+
+  message("done")
   message("Generate grammar include file")
   dparser::mkdparse(devtools::package_file("inst/tran.g"),
                     devtools::package_file("src/"),

diff --git a/R/rxrandom.R b/R/rxrandom.R
@@ -51,6 +51,8 @@ rxnormV  <- function(mean = 0, sd = 1, n = 1L, ncores = 1L) {
 #' @export
 rxnorm <- rxnormV
 
+
+
 #' Simulate random Poisson variable from threefry generator
 #'
 #' @inheritParams stats::rpois
@@ -89,25 +91,6 @@ rxpois <- function(lambda, n = 1L, ncores = 1L) {
   .Call(`_rxode2_rxpois_`, lambda, n, ncores)
 }
 
-.rxpois <- function(lambda) {
-  .lam <- as.character(substitute(lambda))
-  .tmp <- try(force(lambda), silent=TRUE)
-  if (!inherits(.tmp, "try-error")) {
-    if (is.character(.tmp)) {
-      .lam <- lambda
-    }
-  }
-  list(replace=paste0("rxpois(", .lam, ")"))
-}
-
-#' @export
-rxUdfUi.rxpois <- function(fun) {
-  .fun <- fun
-  .fun[[1]] <- str2lang(paste0(".", deparse1(fun[[1]])))
-  eval(.fun)
-}
-
-
 #' Simulate student t variable from threefry generator
 #'
 #' @inheritParams stats::rt
@@ -1301,3 +1284,10 @@ rxRmvn <- function(n, mu = NULL, sigma, lower = -Inf, upper = Inf, ncores = 1, i
   }
   return(.ret)
 }
+
+#' @export
+rxUdfUi.rxpois <- function(fun) {
+  .fun <- fun
+  .fun[[1]] <- str2lang(paste0(".", deparse1(fun[[1]])))
+  eval(.fun)
+}