Merge remote-tracking branch 'origin/629-mem-issues' into 563-write-i…

…nfo-about-model-piping

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) <-

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(

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 {

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);
-

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<NumericVector> &params    = 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<arma::vec>(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){

src/rxode2_df.cpp

@@ -24,6 +24,7 @@
 #include <unistd.h>
 #include <stdio.h>
 #include <climits>
+#include <cmath>
 #include "checkmate.h"
 #include <stdint.h>    // 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++;
           }

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;
   }

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({