Merge pull request #781 from nlmixr2/781-rm-diag

`rxode2` pipe out non-diagonal elements

NEWS.md

@@ -49,6 +49,15 @@
 
 ## New features
 
+- You can remove covariances for every omega by piping with `%>%
+  ini(diag())` you can be a bit more granular by removing all
+  covariances that have either `eta.ka` or `eta.cl` by: `%>%
+  ini(diag(eta.ka, eta.cl))` or anything with correlations with
+  `eta.cl` with `%>% ini(diag(eta.cl))`
+
+- You can also remove individual covariances by `%>% ini(-cov(a, b))`
+  or `%>% ini(-cor(a,b))`.
+
 - You can specify the type of interpolation applied for added dosing
   records (or other added records) for columns that are kept with the
   `keep=` option in `rxSolve()`. This new option is

R/piping-ini.R

@@ -1,3 +1,11 @@
+#' Message about fixing or unfixing a parameter
+#'
+#' @param ini this is the iniDf data frame
+#' @param w this indicates the row number of the item that is fixed or
+#'   unfixed
+#' @param fixedValue this is a boolean
+#' @noRd
+#' @author Matthew L. Fidler
 .msgFix<- function(ini, w, fixedValue) {
   lapply(w, function(.w) {
     if (ini$fix[.w] != fixedValue) {
@@ -10,6 +18,18 @@
   })
 }
 
+#' This modifies the iniDf to fix (or unfix) parameters and related
+#' values
+#'
+#' Note that the block of etas will be fixed/unfixed when a single
+#' value is fixed/unfixed
+#'
+#' @param ini iniDf data.frame
+#' @param w which item will be fixed
+#' @param fixedValue should this be fixed `TRUE` or unfixed `FALSE`
+#' @return nothing, called for side effects
+#' @noRd
+#' @author Matthew L. Fidler
 .iniModifyFixedForThetaOrEtablock <- function(ini, w, fixedValue) {
   if (rxode2.verbose.pipe) {
     .msgFix(ini, w, fixedValue)
@@ -215,9 +235,9 @@
   rbind(ini,.ini2)
 }
 
-#'  This function handles the lotri process and integrates into current UI
+#' This function handles the lotri process and integrates into current UI
 #'
-#'  This will update the matrix and integrate the initial estimates in the UI
+#' This will update the matrix and integrate the initial estimates in the UI
 #'
 #' @param mat Lotri processed matrix from the piping ini function
 #'
@@ -428,7 +448,6 @@
     # This likely cannot be reached because all scenarios should be handled
     # above in the input checking.  The line remains in the code defensively.
     stop("Cannot find parameter '", append, "'", call.=FALSE) # nocov
-
   } else if (appendClean == wLhs) {
     warning("parameter '", lhs, "' set to be moved after itself, no change in order made",
             call. = FALSE)
@@ -588,26 +607,46 @@
 #' @keywords internal
 #' @export
 .iniHandleLine <- function(expr, rxui, envir=parent.frame(), append = NULL) {
+  if (.matchesLangTemplate(expr, str2lang("~diag()"))) {
+    .iniHandleDiag(expr=NULL, rxui=rxui)
+    return(invisible())
+  } else if (length(expr) == 2L &&
+               identical(expr[[1]], quote(`~`)) &&
+               is.call(expr[[2]]) && length(expr[[2]]) >= 2L &&
+               identical(expr[[2]][[1]], quote(`diag`))) {
+    # .matchesLangTemplate(expr, str2lang("~diag(.)")) doesn't work
+    .iniHandleDiag(expr=expr, rxui=rxui)
+    return(invisible())
+  }
   # Convert all variations on fix, fixed, FIX, FIXED; unfix, unfixed, UNFIX,
   # UNFIXED to fix and unfix to simplify all downstream operations
   expr <- .iniSimplifyFixUnfix(expr)
   # Convert assignment equal ("=") to left arrows ("<-") to simplify all
   # downstream operations
   expr <- .iniSimplifyAssignArrow(expr)
 
-  if (.matchesLangTemplate(expr, str2lang(".name <- NULL"))) {
-    expr <- as.call(list(quote(`-`), expr[[2]]))
-  } else if (.matchesLangTemplate(expr, str2lang(".name ~ NULL"))) {
+  if (.matchesLangTemplate(expr, str2lang(".name <- NULL")) ||
+        .matchesLangTemplate(expr, str2lang(".name ~ NULL")) ||
+        .matchesLangTemplate(expr, str2lang("cov(.name, .name) <- NULL")) ||
+        .matchesLangTemplate(expr, str2lang("cor(.name, .name) <- NULL")) ||
+        .matchesLangTemplate(expr, str2lang("cov(.name, .name) ~ NULL")) ||
+        .matchesLangTemplate(expr, str2lang("cor(.name, .name) ~ NULL"))) {
     expr <- as.call(list(quote(`-`), expr[[2]]))
   }
 
+  # now handle dropping covariances
+  if (.matchesLangTemplate(expr, str2lang("-cov(.name, .name)")) ||
+        .matchesLangTemplate(expr, str2lang("-cor(.name, .name)"))) {
+    .iniHandleRmCov(expr=expr, rxui=rxui)
+    return(invisible())
+  }
+
   # Convert fix(name) or unfix(name) to name <- fix or name <- unfix
   if (.matchesLangTemplate(expr, str2lang("fix(.name)"))) {
     expr <- as.call(list(quote(`<-`), expr[[2]], quote(`fix`)))
   } else if (.matchesLangTemplate(expr, str2lang("unfix(.name)"))) {
     expr <- as.call(list(quote(`<-`), expr[[2]], quote(`unfix`)))
   }
-
   if (.matchesLangTemplate(expr, str2lang(".name <- label(.)"))) {
     .iniHandleLabel(expr=expr, rxui=rxui, envir=envir)
   } else if (.matchesLangTemplate(expr, str2lang(".name <- backTransform(.)"))) {
@@ -892,3 +931,111 @@ zeroRe <- function(object, which = c("omega", "sigma"), fix = TRUE) {
   ini(.ret) <- iniDf
   .ret
 }
+
+#' This removes the off-diagonal BSV from a rxode2 iniDf
+#'
+#' @param ui rxode2 ui model
+#'
+#' @param diag character vector of diagonal values to remove
+#'
+#' @return iniDf with modified diagonal
+#' @noRd
+#' @author Matthew L. Fidler
+.iniDfRmDiag <- function(iniDf, diag=character(0)) {
+  .iniDf <- iniDf
+  .theta <- .iniDf[!is.na(.iniDf$ntheta),,drop=FALSE]
+  .eta <- .iniDf[is.na(.iniDf$ntheta),,drop=FALSE]
+  if (length(diag) == 0) {
+    .w <- which(.eta$neta1 == .eta$neta2)
+    .rmNames <- .eta[-.w, "name"]
+    .eta <- .eta[.w,, drop=FALSE]
+    .iniDf <- rbind(.theta, .eta)
+  } else {
+    .rmNames <- character(0)
+    for (.e in diag) {
+      .w <- which(.eta$name == .e)
+      if (length(.w) == 1L) {
+        .n <- .eta$neta1[.w]
+        .w <- vapply(seq_along(.eta$neta1),
+                     function(i) {
+                       if (.eta$neta1[i] == .eta$neta2[i]) {
+                         TRUE
+                       } else if (.eta$neta1[i] == .n && .eta$neta2[i] != .n) {
+                         FALSE
+                       } else if (.eta$neta2[i] == .n && .eta$neta1[i] != .n) {
+                         FALSE
+                       } else {
+                         TRUE
+                       }
+                     }, logical(1), USE.NAMES = TRUE)
+        .rmNames <- c(.rmNames, .eta$name[!.w])
+        .eta <- .eta[.w,,drop=FALSE]
+      } else {
+        stop("cannot find parameter '", .e, "' for covariance removal", call.=FALSE)
+      }
+    }
+    .mat <- lotri::as.lotri(.eta)
+    .mat <- lotri::rcm(.mat)
+    class(.mat) <- c("lotriFix", class(.mat))
+    .eta <- as.data.frame(.mat)
+    .eta$err <- NA_character_
+    .iniDf <- rbind(.theta, .eta)
+  }
+  if (rxode2.verbose.pipe) {
+    for (.v in .rmNames) {
+      .minfo(paste0("remove covariance {.code ", .v, "}"))
+    }
+  }
+  .iniDf
+}
+
+.iniHandleRmCov <- function(expr, rxui) {
+  .iniDf <- rxui$iniDf
+  .theta <- .iniDf[!is.na(.iniDf$ntheta),, drop = FALSE]
+  .eta <- .iniDf[is.na(.iniDf$ntheta),, drop = FALSE]
+  .mat <- lotri::as.lotri(.eta)
+  .n1 <- as.character(expr[[2]][[2]])
+  .v1 <- which(.n1==dimnames(.mat)[[1]])
+  if (length(.v1) != 1) {
+    stop("cannot find parameter '", .n1, "' for covariance removal", call.=FALSE)
+  }
+  .n2 <- as.character(expr[[2]][[3]])
+  .v2 <- which(.n2==dimnames(.mat)[[1]])
+  if (length(.v2) != 1) {
+    stop("cannot find parameter '", .n2, "' for covariance removal", call.=FALSE)
+  }
+  if (rxode2.verbose.pipe) {
+    .minfo(paste0("remove covariance {.code (", .n1, ", ", .n2, ")}"))
+  }
+
+  .mat[.v1, .v2] <- .mat[.v2, .v1] <- 0
+  .mat <- lotri::rcm(.mat)
+  class(.mat) <- c("lotriFix", class(.mat))
+  .eta <- as.data.frame(.mat)
+  .eta$err <- NA_character_
+  .iniDf <- rbind(.theta, .eta)
+  assign("iniDf", .iniDf, envir=rxui)
+}
+
+.iniHandleDiag <- function(expr, rxui){
+  if (is.null(expr)) {
+    assign("iniDf", .iniDfRmDiag(rxui$iniDf), envir=rxui)
+  } else {
+    # now get the variables in the diag expression
+    .env <- new.env(parent=emptyenv())
+    .env$names <- character(0)
+    .f <- function(x) {
+      if (is.name(x)) {
+        .env$names <- c(.env$names, as.character(x))
+      } else if (is.call(x)) {
+        lapply(lapply(seq_along(x)[-1], function(i) {x[[i]]}), .f)
+      }
+    }
+    expr <- expr[[2]]
+    lapply(seq_along(expr)[-1],
+           function(i) {
+              .f(expr[[i]])
+           })
+    assign("iniDf", .iniDfRmDiag(rxui$iniDf, .env$names), envir=rxui)
+  }
+}

R/piping.R

@@ -374,8 +374,17 @@
       warning("empty argument ignored")
       return(NULL)
     } else if (length(.quoted) == 1) {
-      .bracket[i] <- TRUE
-      assign(".bracket", .bracket, envir=.env)
+      if (identical(.quoted, quote(`diag`))) {
+        .quoted <- str2lang("~diag()")
+      } else {
+        .bracket[i] <- TRUE
+        assign(".bracket", .bracket, envir=.env)
+      }
+    } else if (length(.quoted) >= 1 &&
+                 identical(.quoted[[1]], quote(`diag`))) {
+      .quoted <- as.call(c(list(quote(`~`)), .quoted))
+    } else if (identical(.quoted[[1]], quote(`diag`))) {
+
     } else if (identical(.quoted[[1]], quote(`{`)) ||
           identical(.quoted[[1]], quote(`c`)) ||
           identical(.quoted[[1]], quote(`list`))) {
@@ -384,7 +393,7 @@
     } else if (identical(.quoted[[1]], quote(`as.formula`))) {
       .quoted <- .quoted[[2]]
     } else if (identical(.quoted[[1]], quote(`~`))) {
-      if (length(.quoted) == 3L) {
+      if (length(.quoted) == 3L && !is.null(.quoted[[3]])) {
         .quoted[[3]] <- .iniSimplifyFixUnfix(.quoted[[3]])
         if (identical(.quoted[[3]], quote(`fix`)) ||
               identical(.quoted[[3]], quote(`unfix`))) {

R/ui.R

@@ -137,14 +137,17 @@
 #'
 #' 'omega' values can be set as a single value or as the values of a
 #' lower-triangular matrix.  The values may be set as either a
-#' variance-covariance matrix (the default) or as a correlation matrix for the
-#' off-diagonals with the standard deviations on the diagonals.  Names may be
-#' set on the left side of the \code{~}.  To set a variance-covariance matrix
-#' with variance values of 2 and 3 and a covariance of -2.5 use \code{~c(2, 2.5,
-#' 3)}.  To set the same matrix with names of \code{iivKa} and \code{iivCL}, use
-#' \code{iivKa + iivCL~c(2, 2.5, 3)}.  To set a correlation matrix with standard
-#' deviations on the diagonal, use \code{cor()} like \code{iivKa + iivCL~cor(2,
-#' -0.5, 3)}.
+#' variance-covariance matrix (the default) or as a correlation matrix
+#' for the off-diagonals with the standard deviations on the
+#' diagonals.  Names may be set on the left side of the \code{~}.  To
+#' set a variance-covariance matrix with variance values of 2 and 3
+#' and a covariance of -2.5 use \code{~c(2, 2.5, 3)}.  To set the same
+#' matrix with names of \code{iivKa} and \code{iivCL}, use \code{iivKa
+#' + iivCL~c(2, 2.5, 3)}.  To set a correlation matrix with standard
+#' deviations on the diagonal, use \code{cor()} like \code{iivKa +
+#' iivCL~cor(2, -0.5, 3)}.  As of rxode2 3.0 you can also use
+#' \code{iivKa ~ 2, iivCL ~ c(2.5, 3)} for covariance matrices as
+#' well.
 #'
 #' Values may be fixed (and therefore not estimated) using either the name
 #' \code{fixed} at the end of the assignment or by calling \code{fixed()} as a
@@ -173,6 +176,14 @@
 #' has a label of "Typical Value of Clearance (L/hr)" is \code{tvCL <- 1;
 #' label("Typical Value of Clearance (L/hr)")}.
 #'
+#' Off diagonal values of 'omega' can be set to zero using the
+#' \code{diag()} to remove all off-diagonals can be removed with
+#' `ini(diag())`.  To remove covariances of 'omega' item with `iivKa`,
+#' you can use `%>% ini(diag(iivKa))`.  Or to remove covariances that
+#' contain either `iivKa` or `iivCl` you can use `%>% ini(diag(iivKa,
+#' iivCl))`.  For finer control you can remove the covariance between
+#' two items (like `iivKa` and `iivCl`) by `%>% ini(-cov(iivKa, iivCl))
+#'
 #' \code{rxode2}/\code{nlmixr2} will attempt to determine some
 #' back-transformations for the user.  For example, \code{CL <- exp(tvCL)} will
 #' detect that \code{tvCL} must be back-transformed by \code{exp()} for easier