Merge pull request #618 from nlmixr2/617-use-c-for-rxappendmodel-as-well

Adding more complex types (and testing) of model binding

NEWS.md

@@ -140,6 +140,11 @@ mu-referencing style to run the optimization.
 - Allow character vectors to be converted to expressions for piping
   (#552)
 
+- `rxAppendModel()` will now take an arbitrary number of models and
+  append them together; It also has better handling of models with
+  duplicate parameters and models without `ini()` blocks (#617 / #573
+  / #575).
+
 ## Internal new features
 
 - Add `as.model()` for list expressions, which implies `model(ui) <-

R/ui-bind.R

@@ -1,14 +1,119 @@
+#' Combine Model Lines
+#'
+#' @param model1 rxUi model1
+#' @param model2 rxUi model2
+#' @param ini Final ini for model
+#' @return new model with both models appended together and ini from input
+#' @noRd
+#' @author Matthew L. Fidler
+.combineModelLines <- function(model1, model2, ini) {
+  # Add the meta information from model2 into the meta information of new model
+  .ls <- ls(model2$meta, all.names=TRUE)
+  for (.i in seq_along(.ls)) {
+    assign(.ls[.i], model2$meta[[.ls[.i]]], envir=model1$meta)
+  }
+  model1$iniDf <- ini
+  model1$lstExpr <- c(model1$lstExpr, model2$lstExpr)
+  model1$fun()
+}
+#' Append 2 models
+#'
+#'
+#' @param model1 rxUi type of model
+#' @param model2 rxUi type of model
+#' @param common boolean; when `TRUE` require models to have variables in common
+#' @return rxUi combined model of model1 and model2
+#' @noRd
+#' @author Matthew L. Fidler
+rxAppendModel_ <- function(model1, model2, common=TRUE) {
+  model1 <- assertRxUi(model1)
+  model1 <- .copyUi(model1) # so modifications do not affect first model
+  model2 <- assertRxUi(model2)
+  model2 <- .copyUi(model2)
+  .ini1 <- model1$iniDf
+  .ini2 <- model2$iniDf
+  .bind <- intersect(c(model1$mv0$lhs, model1$mv0$state), model2$allCovs)
+  if (common && length(.bind) == 0) {
+    stop("not all the models have variables in common (use `common=FALSE` to allow this)",
+         call.=FALSE)
+  }
+  if (is.null(.ini1) && is.null(.ini2)) {
+    return(.combineModelLines(model1, model2, NULL))
+  }
+  if (!is.null(.ini1) && is.null(.ini2)) {
+    return(.combineModelLines(model1, model2, .ini1))
+  }
+  if (is.null(.ini1) && !is.null(.ini2)) {
+    return(.combineModelLines(model1, model2, .ini2))
+  }
+  # both exist
+  .ini1theta <- .ini1[!is.na(.ini1$ntheta),, drop = FALSE]
+  .ini2theta <- .ini2[!is.na(.ini2$ntheta),, drop = FALSE]
+  .both <- intersect(.ini1theta$name, .ini2theta$name)
+  if (length(.both) > 0) {
+    .minfo("duplicated population parameters when combining 2 models")
+    .minfo(paste0("keeping initialization from first model: '",
+                  paste(.both, collapse="', '"), "'"))
+    .ini2theta <- .ini2theta[!(.ini2theta$name %in% .both),, drop =FALSE]
+  }
+  .ini2theta$ntheta <- length(.ini1theta$ntheta) + seq_along(.ini2theta$ntheta)
+  .iniT <- rbind(.ini1theta, .ini2theta)
+  # now look at the etas
+  .ini1eta <- .ini1[is.na(.ini1$ntheta),, drop = FALSE]
+  .ini2eta <- .ini2[is.na(.ini2$ntheta),, drop = FALSE]
+  .both <- intersect(.ini1eta$name, .ini2eta$name)
+  if (length(.both) > 0) {
+    # See if any of the items have covariances defined
+    .complex1 <- which(vapply(.both, function(v) {
+      .eta <- .ini1eta[.ini1eta$name == v, "neta1"]
+      any((.ini1eta$neta1 == .eta & .ini1eta$neta2 != .eta) |
+            (.ini1eta$neta2 == .eta & .ini1eta$neta1 != .eta))
+    }, logical(1), USE.NAMES = FALSE))
+    .complex2 <- which(vapply(.both, function(v) {
+      .eta <- .ini2eta[.ini2eta$name == v, "neta1"]
+      any((.ini2eta$neta1 == .eta & .ini2eta$neta2 != .eta) |
+            (.ini2eta$neta2 == .eta & .ini2eta$neta1 != .eta) )
+    }, logical(1), USE.NAMES = FALSE))
+    .err <- unique(c(.both[.complex1], .both[.complex2]))
+    if (length(.err) > 0) {
+      stop("duplicated parameter has covariance, will not append models: '",
+           paste0(.err, collapse="', '"), "'",
+           call.=FALSE)
+    } else {
+      # drop in the second
+      .minfo("duplicated eta parameters when combining 2 models")
+      .minfo(paste0("keeping initialization from first model: '",
+                    paste(.both, collapse="', '"), "'"))
+
+      .ini2eta <- .ini2eta[!(.ini2eta$name %in% .both),, drop =FALSE]
+    }
+  }
+  .maxEta <- suppressWarnings(max(.ini1eta$neta1))
+  if (is.finite(.maxEta)) {
+    .ini2eta$neta1 <- .ini2eta$neta1 + .maxEta
+    .ini2eta$neta2 <- .ini2eta$neta2 + .maxEta
+  }
+  .iniE <- rbind(.ini1eta, .ini2eta)
+  if (length(.iniE$name) > 0) {
+    .iniE <- .iniE[order(.iniE$neta1, .iniE$neta2), ]
+    .ini <- rbind(.iniT, .iniE)
+  } else {
+    .ini <- .iniT[order(.iniT$ntheta), ]
+  }
+  .combineModelLines(model1, model2, .ini)
+}
+
 #' Append two rxui models together
 #'
-#' @param model1 rxUi model 1
-#' @param model2 rxUi model 2
+#' @param ... models to append together
+#' @param common boolean that determines if you need a common value to bind
 #' @return New model with both models appended together
 #' @author Matthew L. Fidler
 #' @export
 #' @examples
-#' 
+#'
 #' \donttest{
-#' 
+#'
 #' ocmt <- function() {
 #'   ini({
 #'     tka <- exp(0.45) # Ka
@@ -46,49 +151,20 @@
 #' }
 #'
 #' rxAppendModel(ocmt %>% model(ceff=cp,append=TRUE), idr)
-#' 
+#'
 #' }
 #'
-rxAppendModel <- function(model1, model2) {
-  model1 <- assertRxUi(model1)
-  model1 <- .copyUi(model1) # so modifications do not affect first model
-  model2 <- assertRxUi(model2)
-  model2 <- .copyUi(model2)
-  .ini1 <- model1$iniDf
-  .ini2 <- model2$iniDf
-  .bind <- intersect(c(model1$mv0$lhs, model1$mv0$state), model2$allCovs)
-  if (length(.bind) == 0) {
-    stop("the first model does not have variables that are used by the second model",
-         call.=FALSE)
-  }
-  .maxTheta <- suppressWarnings(max(.ini1$ntheta, na.rm=TRUE))
-  if (!is.finite(.maxTheta)) {
-    stop("there needs to be at least one population parameter in 'model1'",
-         call.=FALSE)
-  }
-  .ini2$ntheta <- .ini2$ntheta + .maxTheta
-  .maxEta <- suppressWarnings(max(.ini1$neta1, na.rm=TRUE))
-  if (is.finite(.maxEta)) {
-    .ini2$neta1 <- .ini2$neta1 + .maxEta
-    .ini2$neta2 <- .ini2$neta2 + .maxEta
-  }
-  .ini <- rbind(.ini1, .ini2)
-  .etas <- which(is.na(.ini$ntheta))
-  if (length(.etas) > 0) {
-    .iniT <- .ini[-.etas, ]
-    .iniT <- .iniT[order(.iniT$ntheta), ]
-    .iniE <- .ini[.etas, ]
-    .iniE <- .iniE[order(.iniE$neta1, .iniE$neta2), ]
-    .ini <- rbind(.iniT, .iniE)
-  } else {
-    .ini <- .ini[order(.ini$ntheta), ]
-  }
-  # Add the meta information from model2 into the meta information of new model
-  .ls <- ls(model2$meta, all.names=TRUE)
-  for (.i in seq_along(.ls)) {
-    assign(.ls[.i], model2$meta[[.ls[.i]]], envir=model1$meta)
-  }
-  model1$iniDf <- .ini
-  model1$lstExpr <- c(model1$lstExpr, model2$lstExpr)
-  model1$fun()
+rxAppendModel <- function(..., common=TRUE) {
+  .env <- new.env(parent=emptyenv())
+  .env$ret <- NULL
+  .lst <- list(...)
+  lapply(seq_along(.lst), function(i) {
+    .m <- .lst[[i]]
+    if (is.null(.env$ret)) {
+      .env$ret <- .m
+    } else {
+      .env$ret <- rxAppendModel_(.env$ret, .m, common=common)
+    }
+  })
+  .env$ret
 }

man-roxygen/rmdhunks/speed.Rmdh

@@ -345,8 +345,14 @@ Note compiler settings can be tricky and if you setup your system wide
 `ccache` the compile may not be produced with the same options since
 it was cached with the other options.
 
-Anyhow, there is some minimal speed improvement by adding this compile
-option.
+For example, on the github runner (which generates this page), there
+is no advantage to the `"fast"` compile.  However, on my development
+laptop there is [some minimal speed
+increase](https://github.com/nlmixr2/rxode2/issues/583#issuecomment-1834468627).
+You should probably check before using this yourself.
+
+This is disabled by default since there is only minimum increase in
+speed.
 
 # A real life example