Merge branch 'main' into 563-write-info-about-model-piping

NEWS.md

@@ -145,6 +145,11 @@ mu-referencing style to run the optimization.
   duplicate parameters and models without `ini()` blocks (#617 / #573
   / #575).
 
+- `keep` will now also keep attributes of the input data (with special
+  handling for `levels`); This means a broader variety of classes will
+  be kept carrying more information with it (for example ordered
+  factors, data frame columns with unit information, etc)
+
 ## Internal new features
 
 - Add `as.model()` for list expressions, which implies `model(ui) <-

src/rxData.cpp

@@ -2627,6 +2627,19 @@ extern "C" SEXP get_fkeepLevels(int col) {
   return wrap(cur[1]);
 }
 
+extern "C" SEXP assign_fkeepAttr(int col, SEXP in) {
+  List cur = keepFcovType[col];
+  List attr = cur[2];
+  RObject curRO = as<RObject>(in);
+  CharacterVector attrN = attr.names();
+  for (unsigned int i = 0; i < attr.size(); i++) {
+    std::string curAttr = as<std::string>(attrN[i]);
+    curRO.attr(curAttr) = attr[i];
+  }
+  return wrap(curRO);
+}
+
+
 extern "C" SEXP get_fkeepChar(int col, double val) {
   List cur = keepFcovType[col];
   StringVector levels = cur[1];

src/rxData.h

@@ -7,6 +7,7 @@ extern "C" {
   double get_fkeep(int col, int id, rx_solving_options_ind *ind);
   int get_fkeepType(int col);
   SEXP get_fkeepLevels(int col);
+  SEXP assign_fkeepAttr(int col, SEXP in);
   SEXP get_fkeepChar(int col, double val);
   double *getLlikSave(void);
   SEXP get_fkeepn(void);
@@ -34,7 +35,7 @@ extern "C" {
   int isProgSupported(void);
 
   void updateExtraDoseGlobals(rx_solving_options_ind* ind);
-  
+
 #if defined(__cplusplus)
 }
 #endif

src/rxode2_df.cpp

@@ -293,18 +293,18 @@ extern "C" SEXP rxode2_df(int doDose0, int doTBS) {
        i++) {
     int curType = get_fkeepType(j);
     if (curType == 4) {
-      df[i] = NumericVector(rx->nr);
+      df[i] = assign_fkeepAttr(j, NumericVector(rx->nr));
     } else if (curType == 1) {
+      df[i] = assign_fkeepAttr(j, StringVector(rx->nr));
       df[i] = StringVector(rx->nr);
     } else if (curType == 5) {
-      df[i] = LogicalVector(rx->nr);
+      df[i] = assign_fkeepAttr(j, LogicalVector(rx->nr));
     } else {
       IntegerVector cur(rx->nr);
       if (curType == 2) {
         cur.attr("levels") = get_fkeepLevels(j);
-        cur.attr("class") = "factor";
       }
-      df[i] = cur;
+      df[i] = assign_fkeepAttr(j,cur);
     }
     j++;
   }

tests/testthat/test-convertId.R

@@ -0,0 +1,37 @@
+rxTest({
+  test_that("in certain solves, the convertId_ did not always work, test here", {
+
+    f <- function() {
+      description <- "One compartment PK model with linear clearance"
+      ini({
+        lcl <- 1
+        label("Clearance (CL)")
+        lvc <- 3.45
+        label("Central volume of distribution (V)")
+        propSd <- c(0, 0.5)
+        label("Proportional residual error (fraction)")
+      })
+      model({
+        cl <- exp(lcl)
+        vc <- exp(lvc)
+        cp <- linCmt()
+        cp ~ prop(propSd)
+      })
+    }
+
+    dMod <-
+      data.frame(
+        Dose = c(5, 5, 5, 5, 5, 5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 5, 5, 5, 5, 5, 5),
+        ID = c("001-0001", "001-0002", "001-0003", "001-0004", "001-0005", "001-0006", "001-0007", "001-0008", "001-0009", "001-0010", "001-0011", "001-0012", "001-0013", "001-0014", "001-0015", "001-0016", "001-0017", "001-0018"),
+        TIME = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1),
+        EVID = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1),
+        CMT = c("central", "central", "central", "central", "central", "central", "central", "central", "central", "central", "central", "central", "central", "central", "central", "central", "central", "central"),
+        AMT = c(5, 5, 5, 5, 5, 5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 5, 5, 5, 5, 5, 5),
+        WT = c(70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70)
+      )
+
+    f <- rxSolve(f, dMod)
+    expect_error(print(f), NA)
+
+  })
+})

tests/testthat/test-keep.R

@@ -107,20 +107,27 @@ test_that("rxSolve 'keep' maintains character output (#190/#622)", {
   d <- nlmixr2data::theo_sd
   d$SEX <- ifelse(d$ID < 7, "M", "F")
   d$fSEX <- factor(d$SEX)
+  d$oSEX <- d$fSEX
+  class(d$oSEX) <- c("ordered", "factor")
   d$iSEX <- as.integer(d$fSEX)
   d$lSEX <- as.logical(d$iSEX == 1)
   d$dSEX <- d$iSEX + 0.5
+  library(units)
+  d$uSEX <- set_units(d$dSEX, kg)
   d$eSEX <- lapply(d$SEX, function(e) {
     str2lang(e)
   })
 
-  sim <- rxSolve(one.cmt, events = d, keep = c("SEX", "fSEX", "iSEX", "dSEX", "lSEX"))
+  sim <- rxSolve(one.cmt, events = d, keep = c("SEX", "fSEX", "iSEX", "dSEX", "oSEX", "uSEX", "lSEX"))
 
   expect_type(sim$SEX, "character")
   expect_s3_class(sim$fSEX, "factor")
   expect_equal(levels(sim$fSEX), c("F", "M"))
   expect_type(sim$iSEX, "integer")
   expect_type(sim$dSEX, "double")
+  expect_true(inherits(sim$oSEX, "ordered"))
+  expect_true(inherits(sim$uSEX, "units"))
+  expect_true(is.logical(sim$lSEX))
 
   d <- nlmixr2data::theo_sd
   d$SEX <- ifelse(d$ID < 7, "M", "F")