Merge pull request #620 from nlmixr2/563-write-info-about-model-piping

Add modifying models article

NAMESPACE

@@ -474,6 +474,7 @@ export(scale_y_discrete)
 export(setRxThreads)
 export(stat_amt)
 export(stat_cens)
+export(toTrialDuration)
 export(uppergamma)
 export(waiver)
 export(write.template.server)
@@ -534,6 +535,7 @@ importFrom(rxode2et,rxEvid)
 importFrom(rxode2et,rxRateDur)
 importFrom(rxode2et,rxReq)
 importFrom(rxode2et,rxStack)
+importFrom(rxode2et,toTrialDuration)
 importFrom(rxode2parse,.getLastIdLvl)
 importFrom(rxode2parse,forderForceBase)
 importFrom(rxode2parse,rxDerived)

NEWS.md

@@ -169,6 +169,8 @@ mu-referencing style to run the optimization.
   `ini(param=NULL)` changes the parameter to a covariate to align with
   this idiom of dropping parameters
 
+- `rxRename` has been refactored to run faster
+
 ## Internal new features
 
 - Add `as.model()` for list expressions, which implies `model(ui) <-
@@ -188,6 +190,9 @@ mu-referencing style to run the optimization.
 
 ## Bug fixes
 
+- Simulating/solving from functions/ui now prefers params over `omega`
+  and `sigma` in the model (#632)
+
 - Piping does not add constants to the initial estimates
 
 - When constants are specified in the `model({})` block (like `k <- 1`), they will not

R/piping-ini.R

@@ -402,18 +402,18 @@
     # Do nothing
     return()
   } else if (is.logical(append)) {
-    checkmate::assert_logical(append, any.missing = FALSE, len = 1)
+    checkmate::assertLogical(append, any.missing = FALSE, len = 1)
     if (isTRUE(append)) {
       appendClean <- Inf
     } else if (isFALSE(append)) {
       appendClean <- 0
     }
   } else if (is.numeric(append)) {
-    checkmate::assert_number(append, null.ok = FALSE, na.ok = FALSE)
+    checkmate::assertNumber(append, null.ok = FALSE, na.ok = FALSE)
     appendClean <- append
   } else if (is.character(append)) {
-    checkmate::assert_character(append, any.missing = FALSE, len = 1, null.ok = FALSE)
-    checkmate::assert_choice(append, choices = ini$name)
+    checkmate::assertCharacter(append, any.missing = FALSE, len = 1, null.ok = FALSE)
+    checkmate::assertChoice(append, choices = ini$name)
     appendClean <- which(ini$name == append)
   } else {
     stop("'append' must be NULL, logical, numeric, or character/expression of variable in model",

R/plot.R

@@ -176,8 +176,8 @@ rxTheme <- function(base_size = 11, base_family = "",
   stopifnot(length(log) == 1)
   stopifnot(is.character(log))
   stopifnot(log %in% c("", "x", "y", "xy", "yx"))
-  useLogX <- nchar(log) == 2 | log == "x"
-  useLogY <- nchar(log) == 2 | log == "y"
+  useLogX <- nchar(log) == 2L || log == "x"
+  useLogY <- nchar(log) == 2L || log == "y"
   useXgxr <-
     getOption("rxode2.xgxr", TRUE) &&
     requireNamespace("xgxr", quietly = TRUE)

R/reexport.R

@@ -272,3 +272,7 @@ rxode2parse::.getLastIdLvl
 #' @importFrom rxode2random .expandPars
 #' @export
 rxode2random::.expandPars
+
+#' @importFrom rxode2et toTrialDuration
+#' @export
+rxode2et::toTrialDuration

R/rxsolve.R

@@ -1157,16 +1157,17 @@ rxSolve.function <- function(object, params = NULL, events = NULL, inits = NULL,
   .lst <- list(...)
   .nlst <- names(.lst)
   .w <- which(vapply(names(.ctl), function(x) {
-    !(x %in% names(.nlst)) && exists(x, envir=.meta)
+    !(x %in% .nlst) && exists(x, envir=.meta)
   }, logical(1), USE.NAMES=FALSE))
   .extra <- NULL
   if (length(.w) > 0) {
     .v <- names(.ctl)[.w]
     .minfo(paste0("rxControl items read from fun: '",
-           paste(.v, collapse="', '"), "'"))
+                  paste(.v, collapse="', '"), "'"))
     .extra <- setNames(lapply(.v, function(x) {
       get(x, envir=.meta)
     }), .v)
+
   }
   do.call(rxSolve, c(list(NULL, params = NULL, events = NULL, inits = NULL),
                      .lst, .extra,
@@ -1220,6 +1221,24 @@ rxSolve.function <- function(object, params = NULL, events = NULL, inits = NULL,
       .rxControl$omega <- NULL
     }
   }
+  if (inherits(.rxControl$omega, "matrix")) {
+    .omega <- .rxControl$omega
+    .v <- vapply(dimnames(.omega)[[1]],
+                 function(v) {
+                   !(v %in% names(params))
+                 }, logical(1), USE.NAMES = FALSE)
+    if (length(.v) == 1L) {
+      if (!.v) .rxControl$omega <- NULL
+    } else {
+      .omega <- .omega[.v, .v]
+      if (all(dim(.omega) == c(0L, 0L))) {
+        .rxControl$omega <- NULL
+      } else {
+        .rxControl$omega <- .omega
+      }
+    }
+
+  }
   if (inherits(.rxControl$omega, "matrix") &&
         all(dim(.rxControl$omega) == c(0,0))) {
     .rxControl$omega <- NULL
@@ -1235,6 +1254,24 @@ rxSolve.function <- function(object, params = NULL, events = NULL, inits = NULL,
       .rxControl$sigma <- NULL
     }
   }
+  if (inherits(.rxControl$sigma, "matrix")) {
+    .sigma <- .rxControl$sigma
+    .v <- vapply(dimnames(.sigma)[[1]],
+                 function(v) {
+                   !(v %in% names(params))
+                 }, logical(1), USE.NAMES = FALSE)
+    if (length(.v) == 1L) {
+      if (!.v) .rxControl$sigma <- NULL
+    } else {
+      .sigma <- .sigma[.v, .v, drop = FALSE]
+      if (all(dim(.sigma) == c(0L, 0L))) {
+        .rxControl$sigma <- NULL
+      } else {
+        .rxControl$sigma <- .sigma
+      }
+    }
+
+  }
   if (inherits(.rxControl$sigma, "matrix") &&
         all(dim(.rxControl$sigma) == c(0,0))) {
     .rxControl$sigma <- NULL

R/ui-rename.R

@@ -41,68 +41,149 @@
   }
   list(line[[2]], line[[3]], .var.name, .var.name2)
 }
-
-#' Rename variables in the expression
+#' Renames everything in one function
 #'
-#' @param item Expression to recursively rename
-#' @param new New name
-#' @param old Old name
-#' @return new expression with variable renamed
-#' @author Matthew L. Fidler
+#' @param item language item to process
+#' @param lst list of renaming from .assertRenameErrorModelLine, ie list(new, old, newChar, oldChar)
+#' @param isLhs is the expression the left handed side of the equation
+#' @return expression renamed
 #' @noRd
-.rxRenameRecursive <- function(item, new, old, isLhs=FALSE) {
+#' @author Matthew L. Fidler
+.rxRenameRecursiveAll <- function(item, lst, isLhs=FALSE) {
   if (is.atomic(item)) {
     return(item)
   }
   if (is.name(item)) {
-    if (identical(item, old)) {
-      return(new)
-    } else {
-      return(item)
+    .env <- new.env(parent=emptyenv())
+    .env$new <- NULL
+    lapply(seq_along(lst), function(i) {
+      if (!is.null(.env$new)) return(NULL)
+      .curLst <- lst[[i]]
+      .old <- .curLst[[2]]
+      if (identical(item, .old)) {
+        .env$new <- .curLst[[1]]
+      }
+      return(NULL)
+    })
+    if (!is.null(.env$new)) {
+      return(.env$new)
     }
+    return(item)
   } else if (is.call(item)) {
     if (isLhs && identical(item[[1]], quote(`/`))) {
       # handle d/dt() differently so that d doesn't get renamed
       .num <- item[[2]]
       .denom <- item[[3]]
-      if (is.call(.num)) .num <- as.call(lapply(.num, .rxRenameRecursive, new=new, old=old, isLhs=TRUE))
-      if (is.call(.denom)) .denom <- as.call(lapply(.denom, .rxRenameRecursive, new=new, old=old, isLhs=TRUE))
+      if (is.call(.num)) .num <- as.call(lapply(.num, .rxRenameRecursiveAll, lst=lst, isLhs=TRUE))
+      if (is.call(.denom)) .denom <- as.call(lapply(.denom, .rxRenameRecursiveAll, lst=lst, isLhs=TRUE))
       return(as.call(c(list(item[[1]]), .num, .denom)))
-    } else if (isLhs && identical(item[[1]], old) && length(item) == 2L &&
+    } else if (isLhs && length(item) == 2L &&
                  is.numeric(item[[2]])) {
-      # handle x(0) = items
-      return(as.call(c(new, lapply(item[-1], .rxRenameRecursive, new=new, old=old, isLhs=isLhs))))
+      .env <- new.env(parent=emptyenv())
+      .env$new <- NULL
+      lapply(seq_along(lst),
+             function(i) {
+               if (!is.null(.env$new)) return(NULL)
+               .curLst <- lst[[i]]
+               .old <- .curLst[[2]]
+               if (identical(item[[1]], .old)) {
+                 .env$new <- .curLst[[1]]
+               }
+               return(NULL)
+             })
+      if (!is.null(.env$new)) {
+        # handle x(0) = items
+        return(as.call(c(.env$new, lapply(item[-1], .rxRenameRecursiveAll, lst=lst, isLhs=isLhs))))
+      }
     }
     if (identical(item[[1]], quote(`=`)) ||
           identical(item[[1]], quote(`<-`)) ||
           identical(item[[1]], quote(`~`))) {
-      .elhs <- lapply(item[c(-1, -3)], .rxRenameRecursive, new=new, old=old, isLhs=TRUE)
-      .erhs <- lapply(item[c(-1, -2)], .rxRenameRecursive, new=new, old=old, isLhs=FALSE)
+      .elhs <- lapply(item[c(-1, -3)], .rxRenameRecursiveAll, lst=lst, isLhs=TRUE)
+      .erhs <- lapply(item[c(-1, -2)], .rxRenameRecursiveAll, lst=lst, isLhs=FALSE)
       return(as.call(c(item[[1]], .elhs, .erhs)))
     } else {
-      return(as.call(c(list(item[[1]]), lapply(item[-1], .rxRenameRecursive, new=new, old=old, isLhs=isLhs))))
+      return(as.call(c(list(item[[1]]), lapply(item[-1], .rxRenameRecursiveAll, lst=lst, isLhs=isLhs))))
     }
   } else {
     stop("unknown expression", call.=FALSE)
   }
 }
-#' Rename one item in the rxui
+#' Rename all items in matrix dimnames
 #'
-#' @param rxui rxui for renaming
-#' @param lst list with (new, old, newChr, oldChr)
-#' @return Nothing, called for side effects
+#' @param mat matrix
+#' @param lst list for renaming
+#' @return renamed matrix
+#' @noRd
 #' @author Matthew L. Fidler
+.rxRenameAllMat <- function(mat, lst) {
+  .d <- dimnames(mat)[[1]]
+  .d <- vapply(seq_along(.d), function(i) {
+    .env <- new.env(parent=emptyenv())
+    .env$new <- NULL
+    .cur <- .d[i]
+    lapply(seq_along(lst),
+           function(j) {
+             if (!is.null(.env$new)) return(NULL)
+             .curLst <- lst[[j]]
+             .old <- .curLst[[4]]
+             if (.cur == .old) {
+               .env$new <- .curLst[[3]]
+             }
+           })
+    if (!is.null(.env$new)) return(.env$new)
+    return(.cur)
+  }, character(1), USE.NAMES=FALSE)
+  dimnames(mat) <- list(.d, .d)
+  mat
+}
+
+#' Rename all the items in the initialization data frame and model
+#'
+#' @param rxui the ui to process
+#' @param lst the list of old and new expressions (like above)
+#' @return Called for side effects
 #' @noRd
-.rxRename1 <- function(rxui, lst) {
+#' @author Matthew L. Fidler
+.rxRenameAll <- function(rxui, lst) {
+  rxui <- rxUiDecompress(rxui)
   .iniDf <- rxui$iniDf
-  .w <- which(.iniDf$name == lst[[4]])
-  if (length(.w) == 1) {
-    .iniDf$name[.w] <- lst[[3]]
-    rxui$iniDf <- .iniDf
+  .iniDf$name <- vapply(seq_along(.iniDf$name),
+                        function(i) {
+                          .env <- new.env(parent=emptyenv())
+                          .env$new <- NULL
+                          .cur <- .iniDf$name[i]
+                          lapply(seq_along(lst),
+                                 function(j) {
+                                   if (!is.null(.env$new)) return(NULL)
+                                   .curLst <- lst[[j]]
+                                   .old <- .curLst[[4]]
+                                   if (.cur == .old) {
+                                     .env$new <- .curLst[[3]]
+                                   }
+                                 })
+                          if (!is.null(.env$new)) return(.env$new)
+                          return(.cur)
+                        }, character(1), USE.NAMES=FALSE)
+  rxui$iniDf <- .iniDf
+  if (exists("sigma", rxui)) {
+    assign("sigma", .rxRenameAllMat(get("sigma", envir=rxui), lst), envir=rxui)
+  }
+  if (exists("thetaMat", rxui)) {
+    assign("thetaMat", .rxRenameAllMat(get("thetaMat", envir=rxui), lst), envir=rxui)
+  }
+  if (exists("meta", rxui)) {
+    .meta <- get("meta", rxui)
+    if (exists("sigma", .meta)) {
+      assign("sigma", .rxRenameAllMat(get("sigma", envir=.meta), lst), envir=.meta)
+    }
+    if (exists("thetaMat", .meta)) {
+      assign("thetaMat", .rxRenameAllMat(get("thetaMat", envir=.meta), lst), envir=.meta)
+    }
   }
   rxui$lstExpr <- lapply(seq_along(rxui$lstExpr),
                          function(i) {
-                           .rxRenameRecursive(rxui$lstExpr[[i]], new=lst[[1]], old=lst[[2]])
+                           .rxRenameRecursiveAll(rxui$lstExpr[[i]], lst=lst)
                          })
 }
 
@@ -164,21 +245,29 @@ rxRename <- function(.data, ..., envir=parent.frame()) {
 #' @rdname rxRename
 #' @export
 .rxRename <- function(.data, ..., envir=parent.frame()) {
+  .inCompress <- FALSE
+  if (inherits(.data, "rxUi") &&
+        inherits(.data, "raw")) {
+    .inCompress <- TRUE
+  }
   rxui <- assertRxUi(.data)
+  if (inherits(rxui, "raw")) {
+    rxui <- rxUiDecompress(rxui)
+  }
   .vars <- unique(c(rxui$mv0$state, rxui$mv0$params, rxui$mv0$lhs, rxui$predDf$var, rxui$predDf$cond, rxui$iniDf$name))
   .modelLines <- .quoteCallInfoLines(match.call(expand.dots = TRUE)[-(1:2)], envir=envir)
   .lst <- lapply(seq_along(.modelLines), function(i) {
     .assertRenameErrorModelLine(.modelLines[[i]], .vars)
   })
   rxui <- .copyUi(rxui) # copy ui so effects do not affect original
-  lapply(seq_along(.lst), function(i) {
-    .rxRename1(rxui, .lst[[i]])
-  })
+  .rxRenameAll(rxui, .lst)
   .ret <- rxui$fun()
   if (inherits(.data, "rxUi")) {
-    .x <- rxUiDecompress(.data)
-    .ret <- .newModelAdjust(.ret, .x, rename=TRUE)
-    .ret <- rxUiCompress(.ret)
+    ## .x <- rxUiDecompress(.data)
+    .ret <- .newModelAdjust(.ret, rxui, rename=TRUE)
+    if (.inCompress) {
+      .ret <- rxUiCompress(.ret)
+    }
     .cls <- setdiff(class(.data), class(.ret))
     if (length(.cls) > 0) {
       class(.ret) <- c(.cls, class(.ret))
@@ -218,4 +307,4 @@ rxRename.default <- function(.data, ...) {
   .lst <- as.list(match.call()[-1])
   .lst$.data <- .data
   do.call(.rxRename, c(.lst, list(envir=parent.frame(2))))
-} 
+}

_pkgdown.yml

@@ -207,7 +207,9 @@ navbar:
         - text: "Getting started"
         - text: "rxode2 mini language syntax"
           href: articles/rxode2-syntax.html
-        - text: "rxode2 with piping ie %>%"
+        - text: "rxode2 model modification %>%"
+          href: articles/Modifying-Models.html
+        - text: "rxode2 pipeline ie %>%"
           href: articles/rxode2-pipeline.html
         - text: "Speeding up rxode2 ODE solving"
           href: articles/rxode2-speed.html