diff --git a/NEWS.md b/NEWS.md index 2b6947a23..8a70b08dc 100644 --- a/NEWS.md +++ b/NEWS.md @@ -164,6 +164,11 @@ mu-referencing style to run the optimization. modifying a line in-place still applies. While this is a breaking change, most code will perform the same. +- Labels can now be dropped by `ini(param=label(NULL))`. Also + parameters can be dropped with the idiom `model(param=NULL)` or + `ini(param=NULL)` changes the parameter to a covariate to align with + this idiom of dropping parameters + ## Internal new features - Add `as.model()` for list expressions, which implies `model(ui) <- diff --git a/R/piping-ini.R b/R/piping-ini.R index f636d3add..7bdbc8627 100644 --- a/R/piping-ini.R +++ b/R/piping-ini.R @@ -321,20 +321,67 @@ #' #' @inheritParams .iniHandleLine #' @return Nothing, called for side effects +#' @author Bill Denney & Matthew Fidler #' @keywords internal #' @noRd .iniHandleLabel <- function(expr, rxui, envir) { - lhs <- as.character(expr[[2]]) - newLabel <- expr[[3]][[2]] - ini <- rxui$ini - .w <- which(ini$name == lhs) + .lhs <- as.character(expr[[2]]) + .newLabel <- expr[[3]][[2]] + .ini <- rxui$ini + .w <- which(.ini$name == .lhs) if (length(.w) != 1) { - stop("cannot find parameter '", lhs, "'", call.=FALSE) - } else if (!is.character(newLabel) || !(length(newLabel) == 1)) { - stop("the new label for '", lhs, "' must be a character string") + stop("cannot find parameter '", .lhs, "'", call.=FALSE) + } else if (is.null(.newLabel)) { + .newLabel <- NA_character_ + } else if (!is.character(.newLabel) || !(length(.newLabel) == 1)) { + stop("the new label for '", .lhs, "' must be a character string", + call.=FALSE) + } + .ini$label[.w] <- .newLabel + assign("iniDf", .ini, envir=rxui) + invisible() +} +#' This handles the backTransform() piping calls +#' +#' @param expr expression for backTransform() in `ini()` piping +#' @param rxui rxode2 ui function +#' @param envir evaluation environment +#' @return nothing, called for side effects +#' @noRd +#' @author Matthew L. Fidler +.iniHandleBackTransform <- function(expr, rxui, envir) { + .lhs <- as.character(expr[[2]]) + .newExpr <- expr[[3]][[2]] + .ini <- rxui$ini + .w <- which(.ini$name == .lhs) + .good <- TRUE + if (length(.w) != 1) { + stop("cannot find parameter '", .lhs, "'", call.=FALSE) + } else if (is.null(.newExpr)) { + .newExpr <- NA_character_ + } else if (checkmate::testCharacter(.newExpr, len=1, any.missing=FALSE, + pattern="^[.]*[a-zA-Z]+[a-zA-Z0-9._]*$", + min.chars = 1)) { + } else { + .newExpr <- deparse1(.newExpr) + if (!checkmate::testCharacter(.newExpr, len=1, any.missing=FALSE, + pattern="^[.]*[a-zA-Z]+[a-zA-Z0-9._]*$", + min.chars = 1)) { + .good <- FALSE + } } - ini$label[.w] <- newLabel - assign("iniDf", ini, envir=rxui) + if (!.good) { + stop("backTransform specification malformed", + call.=FALSE) + } + if (!is.na(.newExpr)) { + if (!exists(.newExpr, envir=envir, mode="function")) { + stop("tried use a backTransform(\"", .newExpr, "\") when the function does not exist", + call.=FALSE) + } + } + .ini$backTransform[.w] <- .newExpr + assign("iniDf", .ini, envir=rxui) invisible() } @@ -548,10 +595,10 @@ # downstream operations expr <- .iniSimplifyAssignArrow(expr) - # Capture errors if (.matchesLangTemplate(expr, str2lang(".name <- NULL"))) { - stop("a NULL value for '", as.character(expr[[2]]), "' piping does not make sense", - call. = FALSE) + expr <- as.call(list(quote(`-`), expr[[2]])) + } else if (.matchesLangTemplate(expr, str2lang(".name ~ NULL"))) { + expr <- as.call(list(quote(`-`), expr[[2]])) } # Convert fix(name) or unfix(name) to name <- fix or name <- unfix @@ -563,6 +610,8 @@ if (.matchesLangTemplate(expr, str2lang(".name <- label(.)"))) { .iniHandleLabel(expr=expr, rxui=rxui, envir=envir) + } else if (.matchesLangTemplate(expr, str2lang(".name <- backTransform(.)"))) { + .iniHandleBackTransform(expr=expr, rxui=rxui, envir=envir) } else if (.isAssignment(expr) && is.character(expr[[3]])) { stop( sprintf( diff --git a/R/piping-model.R b/R/piping-model.R index c6633755f..d6c63fe01 100644 --- a/R/piping-model.R +++ b/R/piping-model.R @@ -236,7 +236,8 @@ model.rxModelVars <- model.rxode2 ret <- NULL if (.isEndpoint(expr)) { lhs <- .getLhs(expr) - if (.matchesLangTemplate(lhs, str2lang("-."))) { + if (.matchesLangTemplate(lhs, str2lang("-.")) || + .matchesLangTemplate(lhs, str2lang(". <- NULL"))) { # If it is a drop expression with a minus sign, grab the non-minus part ret <- lhs[[2]] } @@ -246,7 +247,8 @@ model.rxModelVars <- model.rxode2 .getModelLineEquivalentLhsExpressionDropDdt <- function(expr) { .expr3 <- NULL - if (.matchesLangTemplate(x = expr, template = str2lang("-d/dt(.name)"))) { + if (.matchesLangTemplate(x = expr, template = str2lang("-d/dt(.name)")) || + .matchesLangTemplate(x = expr, template = str2lang("d/dt(.name) <- NULL"))) { .expr3 <- expr # remove the minus sign from the numerator .expr3[[2]] <- .expr3[[2]][[2]] @@ -521,6 +523,48 @@ attr(rxUiGet.mvFromExpression, "desc") <- "Calculate model variables from stored } NULL } +#' This checks the different types of drop assignments +#' +#' +#' @param prefix The prefix of the drop assignment +#' @param line The line expression to check +#' @return logical to say if this matches the prefix +#' @author Matthew L. Fidler +#' @noRd +.isDropNullType <- function(prefix, line) { + .e1 <- str2lang(paste0(prefix, " <- NULL")) + .e2 <- str2lang(paste0(prefix, " = NULL")) + .e3 <- str2lang(paste0(prefix, " ~ NULL")) + if (.matchesLangTemplate(line, .e1)) return(TRUE) + if (.matchesLangTemplate(line, .e3)) return(TRUE) + if (.matchesLangTemplate(line, .e2)) return(TRUE) + FALSE +} +#' This changes NULL assignment line to a -drop line +#' +#' @param line Line to change if necessary +#' @return Drop line normalized to be `-line` instead of `line <- NULL` +#' @author Matthew L. Fidler +#' @noRd +.changeDropNullLine <- function(line) { + if (.isDropNullType("d/dt(.name)", line)) { + .ret <- line[[2]] + .ret[[2]] <- as.call(list(quote(`-`), .ret[[2]])) + return(.ret) + } + if (.isDropNullType(".name", line) || + .isDropNullType("lag(.name)", line) || + .isDropNullType("alag(.name)", line) || + .isDropNullType("f(.name)", line) || + .isDropNullType("F(.name)", line) || + .isDropNullType("rate(.name)", line) || + .isDropNullType("dur(.name)", line) || + .isDropNullType(".name(0)", line) + ) { + return(as.call(list(quote(`-`), line[[2]]))) + } + line +} #' Modify the error lines/expression #' @@ -535,6 +579,7 @@ attr(rxUiGet.mvFromExpression, "desc") <- "Calculate model variables from stored .err <- NULL .env <- environment() lapply(lines, function(line) { + line <- .changeDropNullLine(line) if (modifyIni && .isQuotedLineRhsModifiesEstimates(line, rxui)) { .iniHandleFixOrUnfix(line, rxui, envir=envir) } else { diff --git a/man/reexports.Rd b/man/reexports.Rd index f1310e9e9..365c14ab7 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -82,3 +82,4 @@ below to see their documentation. \item{rxode2random}{\code{\link[rxode2random:dot-cbindOme]{.cbindOme}}, \code{\link[rxode2random:dot-expandPars]{.expandPars}}, \code{\link[rxode2random:dot-vecDf]{.vecDf}}, \code{\link[rxode2random]{cvPost}}, \code{\link[rxode2random]{invWR1d}}, \code{\link[rxode2random]{phi}}, \code{\link[rxode2random]{rinvchisq}}, \code{\link[rxode2random]{rLKJ1}}, \code{\link[rxode2random]{rxGetSeed}}, \code{\link[rxode2random]{rxGetSeed}}, \code{\link[rxode2random]{rxRmvn}}, \code{\link[rxode2random]{rxSeedEng}}, \code{\link[rxode2random]{rxSetSeed}}, \code{\link[rxode2random]{rxSetSeed}}, \code{\link[rxode2random]{rxSetSeed}}, \code{\link[rxode2random:rxWithSeed]{rxWithPreserveSeed}}, \code{\link[rxode2random]{rxWithSeed}}, \code{\link[rxode2random]{rxWithSeed}}} }} +\value{ Inherited from parent routine } diff --git a/src/approx.c b/src/approx.c index 0d9c3c993..1e8b33ced 100644 --- a/src/approx.c +++ b/src/approx.c @@ -81,7 +81,7 @@ static inline double getValue(int idx, double *y, rx_solving_options_ind *ind, r if (op->f2 == 1.0 && op->f1 == 0.0) { // use nocb // Go forward - while (ISNA(ret) && i != ind->n_all_times){ + while (ISNA(ret) && i != ind->n_all_times-1){ i++; ret = y[ind->ix[i]]; } if (ISNA(ret)){ @@ -309,4 +309,3 @@ void _update_par_ptr(double t, unsigned int id, rx_solve *rx, int idxIn) { /* void doSort(rx_solving_options_ind *ind); */ void sortInd(rx_solving_options_ind *ind); - diff --git a/src/rxData.cpp b/src/rxData.cpp index a03907bce..265dca3d7 100644 --- a/src/rxData.cpp +++ b/src/rxData.cpp @@ -42,7 +42,7 @@ void resetSolveLinB(); using namespace Rcpp; using namespace arma; -typedef void (*seedEng_t)(uint32_t ncores); +typedef void (*seedEng_t)(int ncores); extern seedEng_t seedEng; #include "cbindThetaOmega.h" @@ -2144,15 +2144,22 @@ List rxSimThetaOmega(const Nullable ¶ms = R_NilValue, } if (_globals.gsigma != NULL) free(_globals.gsigma); rx->neps = sigma0.n_rows; - _globals.gsigma = (double*)malloc((rx->neps * rx->neps + 2 * rx->neps)* sizeof(double)); - std::copy(&sigma0[0], &sigma0[0] + rx->neps * rx->neps, _globals.gsigma + 2 * rx->neps); + if (rx->neps > 0) { + _globals.gsigma = (double*)malloc((rx->neps * rx->neps + 2 * rx->neps)* sizeof(double)); + std::copy(&sigma0[0], &sigma0[0] + rx->neps * rx->neps, + _globals.gsigma + 2 * rx->neps); + } else { + _globals.gsigma = NULL; + } _globals.nSigma = 0; } arma::vec in = as(sigmaLower); arma::vec lowerSigmaV = fillVec(in, sigma0.n_rows); arma::vec upperSigmaV = fillVec(in, sigma0.n_rows); - std::copy(&lowerSigmaV[0], &lowerSigmaV[0] + rx->neps, _globals.gsigma); - std::copy(&upperSigmaV[0], &upperSigmaV[0] + rx->neps, _globals.gsigma + rx->neps); + if (rx->neps > 0) { + std::copy(&lowerSigmaV[0], &lowerSigmaV[0] + rx->neps, _globals.gsigma); + std::copy(&upperSigmaV[0], &upperSigmaV[0] + rx->neps, _globals.gsigma + rx->neps); + } // structure of _globals.gsigma is // lower // upper @@ -4886,7 +4893,7 @@ SEXP rxSolve_(const RObject &obj, const List &rxControl, warning(_("since throwing warning with NA time, change to single threaded")); op->cores=1; } - seedEng(op->cores); + seedEng((int)(op->cores)); if (_globals.pendingDoses != NULL) { int i=0; while (_globals.pendingDoses[i] != NULL){ diff --git a/src/rxode2_df.cpp b/src/rxode2_df.cpp index 47043bc31..4a1754c0a 100644 --- a/src/rxode2_df.cpp +++ b/src/rxode2_df.cpp @@ -24,6 +24,7 @@ #include #include #include +#include #include "checkmate.h" #include // for uint64_t rather than unsigned long long #include "../inst/include/rxode2.h" @@ -751,12 +752,22 @@ extern "C" SEXP rxode2_df(int doDose0, int doTBS) { } else if (TYPEOF(tmp) == LGLSXP) { // Everything here is double dfi = LOGICAL(tmp); - dfi[ii] = (int) (get_fkeep(j, curi + ind->ix[i], ind)); + double curD = get_fkeep(j, curi + ind->ix[i], ind); + if (ISNA(curD) || std::isnan(curD)) { + dfi[ii] = NA_LOGICAL; + } else { + dfi[ii] = (int) (curD); + } } else { dfi = INTEGER(tmp); /* if (j == 0) RSprintf("j: %d, %d; %f\n", j, i, get_fkeep(j, curi + i)); */ // is this ntimes = nAllTimes or nObs time for this subject...? - dfi[ii] = (int) (get_fkeep(j, curi + ind->ix[i], ind)); + double curD = get_fkeep(j, curi + ind->ix[i], ind); + if (ISNA(curD) || std::isnan(curD)) { + dfi[ii] = NA_INTEGER; + } else { + dfi[ii] = (int) (curD); + } } jj++; } diff --git a/src/rxode2parse.cpp b/src/rxode2parse.cpp index cb64e85b7..6e6c06ac3 100644 --- a/src/rxode2parse.cpp +++ b/src/rxode2parse.cpp @@ -105,6 +105,9 @@ END_RCPP extern "C" SEXP _rxode2parse_udfEnvSet(SEXP udf) { BEGIN_RCPP + if (Rf_isNull(udf)) { + return R_NilValue; + } if (Rf_length(udf) == 0 || Rf_length(udf) == 1) { return R_NilValue; } diff --git a/tests/testthat/test-piping-ini.R b/tests/testthat/test-piping-ini.R index a0b63fedf..e504a239e 100644 --- a/tests/testthat/test-piping-ini.R +++ b/tests/testthat/test-piping-ini.R @@ -1,3 +1,59 @@ +test_that("back transformation piping", { + + mod1 <- function() { + ini({ + # central + KA <- 2.94E-01 + backTransform("exp") + CL <- 1.86E+01 + V2 <- 4.02E+01 + # peripheral + Q <- 1.05E+01 + V3 <- 2.97E+02 + # effects + Kin <- 1 + Kout <- 1 + EC50 <- 200 + }) + model({ + C2 <- centr/V2 + C3 <- peri/V3 + d/dt(depot) <- -KA*depot + d/dt(centr) <- KA*depot - CL*C2 - Q*C2 + Q*C3 + d/dt(peri) <- Q*C2 - Q*C3 + eff(0) <- 1 + d/dt(eff) <- Kin - Kout*(1-C2/(EC50+C2))*eff + }) + } + + ui <- rxode(mod1) + + expect_equal(ui$iniDf$backTransform[ui$iniDf$name == "KA"], "exp") + + p1 <- ui %>% + ini( + KA <- backTransform("log") + ) + + expect_equal(p1$iniDf$backTransform[ui$iniDf$name == "KA"], "log") + + p2 <-ui %>% + ini( + KA <- backTransform(log) + ) + + expect_equal(p2$iniDf$backTransform[ui$iniDf$name == "KA"], "log") + + p3 <- ui |> + ini(KA <- backTransform(NULL)) + + expect_equal(p3$iniDf$backTransform[ui$iniDf$name == "KA"], NA_character_) + + expect_error(ui |> + ini(KA <- backTransform(matt)), "matt") + +}) + test_that("piping with ini can update labels (rxode2/issues#351)", { mod <- function() { ini({ @@ -16,6 +72,25 @@ test_that("piping with ini can update labels (rxode2/issues#351)", { expect_equal(newLabelUi$iniDf$label[newLabelUi$iniDf$name == "a"], "bar") }) +test_that("piping with ini can remove labels (#627)", { + + mod <- function() { + ini({ + a <- 1 + label("foo") + addSd <- 2 + }) + model({ + b <- a + b ~ add(addSd) + }) + } + ui <- rxode2(mod) + expect_equal(ui$iniDf$label[ui$iniDf$name == "a"], "foo") + newLabelUi <- ini(ui, a = label(NULL)) + expect_equal(newLabelUi$iniDf$label[ui$iniDf$name == "a"], NA_character_) +}) + test_that("piping with ini gives an error pointing the user to use label for character rhs (rxode2/issues#351)", { mod <- function() { ini({ diff --git a/tests/testthat/test-ui-piping.R b/tests/testthat/test-ui-piping.R index 0103e6420..2107aa0f1 100644 --- a/tests/testthat/test-ui-piping.R +++ b/tests/testthat/test-ui-piping.R @@ -37,6 +37,73 @@ rxTest({ list(quote(d/dt(depot)))) }) + test_that("equivalent drop statements", { + + expect_equal(.changeDropNullLine(quote(a <- NULL)), + quote(-a)) + expect_equal(.changeDropNullLine(quote(a ~ NULL)), + quote(-a)) + expect_equal(.changeDropNullLine(str2lang("a = NULL")), + quote(-a)) + + expect_equal(.changeDropNullLine(quote(d/dt(a) <- NULL)), + quote(-d/dt(a))) + expect_equal(.changeDropNullLine(quote(d/dt(a) ~ NULL)), + quote(-d/dt(a))) + expect_equal(.changeDropNullLine(str2lang("d/dt(a) = NULL")), + quote(-d/dt(a))) + + expect_equal(.changeDropNullLine(quote(lag(a) <- NULL)), + quote(-lag(a))) + expect_equal(.changeDropNullLine(quote(lag(a) ~ NULL)), + quote(-lag(a))) + expect_equal(.changeDropNullLine(str2lang("lag(a) = NULL")), + quote(-lag(a))) + + expect_equal(.changeDropNullLine(quote(alag(a) <- NULL)), + quote(-alag(a))) + expect_equal(.changeDropNullLine(quote(alag(a) ~ NULL)), + quote(-alag(a))) + expect_equal(.changeDropNullLine(str2lang("alag(a) = NULL")), + quote(-alag(a))) + + expect_equal(.changeDropNullLine(quote(F(a) <- NULL)), + quote(-F(a))) + expect_equal(.changeDropNullLine(quote(F(a) ~ NULL)), + quote(-F(a))) + expect_equal(.changeDropNullLine(str2lang("F(a) = NULL")), + quote(-F(a))) + + expect_equal(.changeDropNullLine(quote(f(a) <- NULL)), + quote(-f(a))) + expect_equal(.changeDropNullLine(quote(f(a) ~ NULL)), + quote(-f(a))) + expect_equal(.changeDropNullLine(str2lang("f(a) = NULL")), + quote(-f(a))) + + expect_equal(.changeDropNullLine(quote(rate(a) <- NULL)), + quote(-rate(a))) + expect_equal(.changeDropNullLine(quote(rate(a) ~ NULL)), + quote(-rate(a))) + expect_equal(.changeDropNullLine(str2lang("rate(a) = NULL")), + quote(-rate(a))) + + expect_equal(.changeDropNullLine(quote(dur(a) <- NULL)), + quote(-dur(a))) + expect_equal(.changeDropNullLine(quote(dur(a) ~ NULL)), + quote(-dur(a))) + expect_equal(.changeDropNullLine(str2lang("dur(a) = NULL")), + quote(-dur(a))) + + expect_equal(.changeDropNullLine(quote(a(0) <- NULL)), + quote(-a(0))) + expect_equal(.changeDropNullLine(quote(a(0) ~ NULL)), + quote(-a(0))) + expect_equal(.changeDropNullLine(str2lang("a(0) = NULL")), + quote(-a(0))) + + }) + test_that("test fix/unfix for eta", { expect_equal(testPipeQuote(a~fix), list(quote(a<-fix))) @@ -762,7 +829,6 @@ rxTest({ expect_error(f %>% ini(tka=c(0, 0.5, 1, 4)), "tka") - expect_error(f %>% ini(tka=NULL), "tka") expect_error(f %>% ini(tka=c(3,2,1)), "tka") suppressMessages( @@ -841,7 +907,6 @@ rxTest({ expect_error(f %>% ini(tka=c(0, 0.5, 1, 4)), "tka") - expect_error(f %>% ini(tka=NULL), "tka") expect_error(f %>% ini(tka=c(3,2,1)), "tka") suppressMessages( @@ -912,7 +977,6 @@ rxTest({ expect_error(f %>% ini(tka=c(0, 0.5, 1, 4)), "tka") - expect_error(f %>% ini(tka=NULL), "tka") expect_error(f %>% ini(tka=c(3,2,1)), "tka") suppressMessages( @@ -2038,6 +2102,12 @@ test_that("piping append", { t <- c("-cp","-d/dt(depot)") expect_error(mod |> model(t), NA) + t <- c("cp <- NULL","d/dt(depot) = NULL") + expect_error(mod |> model(t), NA) + + t <- c("cp <- NULL","d/dt(depot) ~ NULL") + expect_error(mod |> model(t), NA) + mod5 <- mod |> model({ PD <- 1-emax*cp/(ec50+cp)