From 4fdc64ac6f675dd72bf6a0ac00799d953ebc7685 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Mon, 4 Dec 2023 22:15:29 -0600 Subject: [PATCH 1/4] Add test for convertId_ that did not used to work --- tests/testthat/test-convertId.R | 35 +++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) create mode 100644 tests/testthat/test-convertId.R diff --git a/tests/testthat/test-convertId.R b/tests/testthat/test-convertId.R new file mode 100644 index 000000000..e1b56fd95 --- /dev/null +++ b/tests/testthat/test-convertId.R @@ -0,0 +1,35 @@ +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) + ) + + expect_error(rxSolve(f, dMod), NA) + +}) From 76cd99313ae9c6c7b6697b4a60b9d0169aa96e1d Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Mon, 4 Dec 2023 22:16:54 -0600 Subject: [PATCH 2/4] Test issue of invalid convertId_ called on solve --- tests/testthat/test-convertId.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-convertId.R b/tests/testthat/test-convertId.R index e1b56fd95..501417a8a 100644 --- a/tests/testthat/test-convertId.R +++ b/tests/testthat/test-convertId.R @@ -30,6 +30,7 @@ test_that("in certain solves, the convertId_ did not always work, test here", { WT = c(70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, 70) ) - expect_error(rxSolve(f, dMod), NA) + f <- rxSolve(f, dMod) + expect_error(print(f), NA) }) From 119b70a79bfc9b0e7eeb536229acd630c11d7f46 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Tue, 5 Dec 2023 05:47:39 -0600 Subject: [PATCH 3/4] Wrap test --- tests/testthat/test-convertId.R | 63 +++++++++++++++++---------------- 1 file changed, 32 insertions(+), 31 deletions(-) diff --git a/tests/testthat/test-convertId.R b/tests/testthat/test-convertId.R index 501417a8a..bd1e07c7e 100644 --- a/tests/testthat/test-convertId.R +++ b/tests/testthat/test-convertId.R @@ -1,36 +1,37 @@ -test_that("in certain solves, the convertId_ did not always work, test here", { +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) + }) + } - 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) + ) - 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) + f <- rxSolve(f, dMod) + expect_error(print(f), NA) + }) }) From 06cc1cf6d45be8c215a097d725294d587e65abee Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Tue, 5 Dec 2023 05:47:49 -0600 Subject: [PATCH 4/4] Fix df output to carry along attributes (including class) w/ new etTrans --- NEWS.md | 5 +++++ src/rxData.cpp | 13 +++++++++++++ src/rxData.h | 3 ++- src/rxode2_df.cpp | 9 ++++----- tests/testthat/test-keep.R | 30 ++++++++++++++++++------------ 5 files changed, 42 insertions(+), 18 deletions(-) diff --git a/NEWS.md b/NEWS.md index 8a06b9700..f1e0fcde2 100644 --- a/NEWS.md +++ b/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) <- diff --git a/src/rxData.cpp b/src/rxData.cpp index ef89f7c95..a03907bce 100644 --- a/src/rxData.cpp +++ b/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(in); + CharacterVector attrN = attr.names(); + for (unsigned int i = 0; i < attr.size(); i++) { + std::string curAttr = as(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]; diff --git a/src/rxData.h b/src/rxData.h index d0717ce3f..8ae91a094 100644 --- a/src/rxData.h +++ b/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 diff --git a/src/rxode2_df.cpp b/src/rxode2_df.cpp index bf61bc0a2..05608ecbc 100644 --- a/src/rxode2_df.cpp +++ b/src/rxode2_df.cpp @@ -293,16 +293,15 @@ 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] = StringVector(rx->nr); + df[i] = assign_fkeepAttr(j, StringVector(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++; } @@ -951,7 +950,7 @@ extern "C" SEXP rxode2_df(int doDose0, int doTBS) { jj++;kk++; } // Put in state names - CharacterVector stateNames2 = rxStateNames(op->modNamePtr); + CharacterVector stateNames2 = rxStateNames(op->modNamePtr); if (nPrnState){ for (j = 0; j < neq[0]; j++){ if (!rmState[j]){ diff --git a/tests/testthat/test-keep.R b/tests/testthat/test-keep.R index 5948e5975..82e81d3a5 100644 --- a/tests/testthat/test-keep.R +++ b/tests/testthat/test-keep.R @@ -27,29 +27,29 @@ test_that("Make sure the keep gives the right values", { V2 <- exp(ThetaV2) Q <- exp(ThetaQ) V3 <- exp(ThetaV3) - + K20 <- CL / V2 K23 <- Q / V2 K32 <- Q / V3 - + CP <- A2 / V2 - + ## d / dt(A1) <- -KA * A1 d / dt(A2) <- KA * transit3 - K23 * A2 + K32 * A3 - K20 * A2 d / dt(A3) <- K23 * A2 - K32 * A3 - + d / dt(transit1) <- KA * A1 - KA * transit1 d / dt(transit2) <- KA * transit1 - KA * transit2 d / dt(transit3) <- KA * transit2 - KA * transit3 - + f(A1) <- 1 - + d / dt(AUC) <- CP A1(0) <- 0 A2(0) <- 0 A3(0) <- 0 - + AGE2 <- AGE }) @@ -85,7 +85,7 @@ test_that("Make sure the keep gives the right values", { }) test_that("rxSolve 'keep' maintains character output (#190)", { - + one.cmt <- function() { ini({ tka <- 0.45 @@ -107,20 +107,26 @@ test_that("rxSolve 'keep' maintains character output (#190)", { 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$dSEX <- d$iSEX + 0.5 + library(units) + d$uSEX <- set_units(d$dSEX, kg) d$eSEX <- lapply(d$SEX, function(e) { - str2lang(e) + str2lang(e) }) - sim <- rxSolve(one.cmt, events = d, keep = c("SEX", "fSEX", "iSEX", "dSEX")) - + sim <- rxSolve(one.cmt, events = d, keep = c("SEX", "fSEX", "iSEX", "dSEX", "oSEX", "uSEX")) + 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_error(rxSolve(one.cmt, events = d, keep = c("eSEX"))) - + })