diff --git a/R/piping-ini.R b/R/piping-ini.R index 797a38624..d0e7b14bf 100644 --- a/R/piping-ini.R +++ b/R/piping-ini.R @@ -408,6 +408,17 @@ assign("iniDf", ret, envir=rxui) invisible() } + +.iniHandleRecalc <- function(rxui) { + .fun <- rxUiDecompress(rxui$fun()) + for (.i in ls(.fun, all=TRUE)) { + if (.i != "meta") { + assign(.i, get(.i, envir=.fun), envir=rxui) + } + } + invisible() +} + #' Handle switching theta to eta and vice versa #' #' This is coded as model |> ini(~par) @@ -470,6 +481,49 @@ } .ini <- rbind(.theta, .eta) assign("iniDf", .ini, envir=rxui) + # This may change mu-referencing, recalculate everything + .iniHandleRecalc(rxui) + invisible() +} + +#' Handle dropping parameter and treating as if it is a covariate +#' +#' This is coded as model |> ini(-par) +#' +#' @param expr Expression, this would be the ~par expression +#' @param rxui rxui uncompressed environment +#' @param envir Environment for evaluation (if needed) +#' @return Nothing, called for side effects +#' @noRd +#' @author Matthew L. Fidler +.iniHandleDropType <- function(expr, rxui, envir=parent.frame()) { + .var <- as.character(expr[[2]]) + .iniDf <- rxui$iniDf + .w <- which(.iniDf$name == .var) + if (length(.w) != 1L) stop("no initial estimates for '", .var, "', cannot change to covariate", call.=FALSE) + .theta <- .iniDf[!is.na(.iniDf$ntheta),, drop = FALSE] + .eta <- .iniDf[is.na(.iniDf$ntheta),, drop = FALSE] + if (is.na(.iniDf$ntheta[.w])) { + .minfo(paste0("changing between subject variability parameter '", .var, "' to covariate parameter")) + .neta <- .iniDf$neta1[.w] + .eta <- .eta[.eta$neta1 != .neta,, drop = FALSE] + .eta <- .eta[.eta$neta2 != .neta,, drop = FALSE] + .eta$neta1 <- .eta$neta1 - ifelse(.eta$neta1 < .neta, 0L, 1L) + .eta$neta2 <- .eta$neta2 - ifelse(.eta$neta2 < .neta, 0L, 1L) + } else { + if (!is.na(.iniDf$err[.w])){ + stop("cannot switch error parameter '", .var, + "' to a covariate", call. = FALSE) + } + .minfo(paste0("changing population parameter '", .var, "' to covariate parameter")) + .ntheta <- .iniDf$ntheta[.w] + .theta <- .theta[.theta$ntheta != .ntheta,, drop = FALSE] + .theta$ntheta <- .theta$ntheta - ifelse(.theta$ntheta < .ntheta, 0L, 1L) + } + .ini <- rbind(.theta, .eta) + assign("iniDf", .ini, envir=rxui) + # This will change covariates, recalculate everything + .iniHandleRecalc(rxui) invisible() } @@ -530,6 +584,8 @@ .iniHandleFixOrUnfixEqual(expr=expr, rxui=rxui, envir=envir, maxLen=1L) } else if (.isTildeExpr(expr)) { .iniHandleSwitchType(expr=expr, rxui=rxui, envir=envir) + } else if (.isIniDropExpression(expr)){ + .iniHandleDropType(expr=expr, rxui=rxui, envir=envir) } else { # Can this error be improved to clarify what is the expression causing the # issue? It needs a single character string representation of something diff --git a/R/piping-model.R b/R/piping-model.R index 531b955fc..df4f62812 100644 --- a/R/piping-model.R +++ b/R/piping-model.R @@ -184,6 +184,10 @@ model.rxModelVars <- model.rxode2 .matchesLangTemplate(expr, str2lang("~ .")) } +.isIniDropExpression <- function(expr) { + .matchesLangTemplate(expr, str2lang("- .")) +} + # get the left hand side of an assignment or endpoint; returns NULL if the input # is not an assignment or endpoint .getLhs <- function(expr) { diff --git a/tests/testthat/test-piping-ini.R b/tests/testthat/test-piping-ini.R index 6eae63850..bf27620f7 100644 --- a/tests/testthat/test-piping-ini.R +++ b/tests/testthat/test-piping-ini.R @@ -686,3 +686,54 @@ test_that("change ini type with ~", { expect_equal(mod4$omega, lotri(lcl ~ 1)) }) + + + +test_that("change ini variable to covariate with -", { + + mod <- function() { + ini({ + lka + lcl + lvc ~ + c(0.45, + 0.01, 1, + 0.01, -0.01, 3.45) + }) + model({ + ka <- exp(lka) + cl <- exp(lcl) + vc <- exp(lvc) + kel <- cl / vc + d/dt(depot) <- -ka*depot + d/dt(central) <- ka*depot-kel*central + cp <- central / vc + }) + } + + mod2 <- mod |> ini(-lka) + + expect_equal(mod2$allCovs, "lka") + expect_equal(mod2$omega, lotri(lcl + lvc ~ c(1, -0.01, 3.45))) + + mod <- function() { + ini({ + lka ~ 0.45 + lcl ~ 1 + lvc ~ 3.45 + }) + model({ + ka <- exp(lka) + cl <- exp(lcl) + vc <- exp(lvc) + kel <- cl / vc + d/dt(depot) <- -ka*depot + d/dt(central) <- ka*depot-kel*central + cp <- central / vc + }) + } + + mod2 <- mod |> ini(-lka) + + expect_equal(mod2$allCovs, "lka") + + +})