diff --git a/R/piping-ini.R b/R/piping-ini.R index 8d7d1836e..fb1213469 100644 --- a/R/piping-ini.R +++ b/R/piping-ini.R @@ -448,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) @@ -608,6 +607,17 @@ #' @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) @@ -627,7 +637,6 @@ } 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(.)"))) { @@ -913,52 +922,24 @@ zeroRe <- function(object, which = c("omega", "sigma"), fix = TRUE) { .ret } -#' This removes the off-diagonal BSV from a rxode2 model +#' 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 model with off-diagonals removed -#' -#' @export -#' +#' @return iniDf with modified diagonal +#' @noRd #' @author Matthew L. Fidler -#' -#' @examples -#' -#' one.compartment <- function() { -#' ini({ -#' tka <- log(1.57); label("Ka") -#' tcl <- log(2.72); label("Cl") -#' tv <- log(31.5); label("V") -#' eta.ka ~ c(0.6) -#' eta.cl ~ c(0.01, 0.3) -#' eta.v ~ c(0.01, 0.01, 0.1) -#' add.sd <- 0.7 -#' }) -#' model({ -#' ka <- exp(tka + eta.ka) -#' cl <- exp(tcl + eta.cl) -#' v <- exp(tv + eta.v) -#' d/dt(depot) = -ka * depot -#' d/dt(center) = ka * depot - cl / v * center -#' cp = center / v -#' cp ~ add(add.sd) -#' }) -#' } -#' -.rmDiag <- function(ui, diag=character(0)) { - .ui <- rxode2::assertRxUi(ui) - .iniDf <- .ui$iniDf +.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[which(.w),, drop=FALSE] + .eta <- .eta[.w,, drop=FALSE] .iniDf <- rbind(.theta, .eta) - ini(.ui) <- .iniDf } else { .rmNames <- character(0) for (.e in diag) { @@ -981,13 +962,62 @@ zeroRe <- function(object, which = c("omega", "sigma"), fix = TRUE) { .eta <- .eta[.w,,drop=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) - ini(.ui) <- .iniDf } if (rxode2.verbose.pipe) { for (.v in .rmNames) { .minfo(paste0("remove covariance {.code ", .v, "}")) } } - .ui + .iniDf +} + +.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]]) + }) + ## .mat <- as.matrix(lotri::as.lotri(rxui$iniDf)) + ## attr(.mat, "lotriEst") <- NULL + ## class(.mat) <- NULL + ## .tmp <- expand.grid(r=.env$names, c=.env$names) + ## .tmp <- .tmp[.tmp$r != .tmp$c,] + ## .tmp$r <- paste(.tmp$r) + ## .tmp$c <- paste(.tmp$c) + ## .tmp$r <- vapply(.tmp$r, + ## function(x) { + ## which(x == colnames(.mat)) + ## }, integer(1)) + ## .tmp$c <- vapply(.tmp$c, + ## function(x) { + ## which(x == colnames(.mat)) + ## }, integer(1)) + ## for (.i in seq_along(.tmp$r)) { + ## .mat[.tmp$r[.i], .tmp$c[.i]] <- 0.0 + ## } + ## .mat <- lotri::rcm(.mat) + ## class(.mat) <- c("lotriFix", class(.mat)) + ## .ini <- as.data.frame(.mat) + # remove covariates between the expressions + assign("iniDf", .iniDfRmDiag(rxui$iniDf, .env$names), envir=rxui) + } } diff --git a/R/piping.R b/R/piping.R index 099c1ee69..e59bcadd9 100644 --- a/R/piping.R +++ b/R/piping.R @@ -373,9 +373,17 @@ # Capture empty arguments (rxode2#688) warning("empty argument ignored") return(NULL) + } else if (is.symbol(.quoted) && + identical(.quoted, quote(`diag`))) { + .quoted <- str2lang("~diag()") + } else if (length(.quoted) >= 1 && + identical(.quoted[[1]], quote(`diag`))) { + .quoted <- as.call(c(list(quote(`~`)), .quoted)) } else if (length(.quoted) == 1) { .bracket[i] <- TRUE assign(".bracket", .bracket, envir=.env) + } else if (identical(.quoted[[1]], quote(`diag`))) { + } else if (identical(.quoted[[1]], quote(`{`)) || identical(.quoted[[1]], quote(`c`)) || identical(.quoted[[1]], quote(`list`))) { diff --git a/R/ui.R b/R/ui.R index da481d9cb..d77738e47 100644 --- a/R/ui.R +++ b/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,12 @@ #' 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()} or \code{diag(iivKa, iivCL)} for example removing all +#' off-diagonals can be removed with `ini(diag())`, or the off +#' diagonals between clearance and ka could be removed by +#' \code{ini(diag(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