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 31e5b2c6a..47043bc31 100644 --- a/src/rxode2_df.cpp +++ b/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++; } diff --git a/tests/testthat/test-convertId.R b/tests/testthat/test-convertId.R new file mode 100644 index 000000000..bd1e07c7e --- /dev/null +++ b/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) + + }) +}) diff --git a/tests/testthat/test-keep.R b/tests/testthat/test-keep.R index fd406bc00..f6d0bc15c 100644 --- a/tests/testthat/test-keep.R +++ b/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")