diff --git a/.Rbuildignore b/.Rbuildignore index 8575bee..31d05f9 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -11,3 +11,5 @@ ^CRAN-SUBMISSION$ ^\.Rhistory$ ^\.vexp$ +^covr$ +^src/.*\.(o|so|gcda|gcno|gcov)$ diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 717ed10..acb13d0 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -35,6 +35,11 @@ jobs: needs: coverage - name: Test coverage + # The whole run takes about 6 minutes. Without a step timeout, a test + # that hangs instead takes the runner down with it (exit 143, no + # output), and the `always()` steps below never run, so there is + # nothing to diagnose from. Failing the step leaves them to run. + timeout-minutes: 20 run: | cov <- covr::package_coverage( quiet = FALSE, diff --git a/.gitignore b/.gitignore index f71aec7..f9ddde3 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,12 @@ docs /sim.rds /.vexp /CRAN-SUBMISSION + +# covr leaves these behind when run with clean=FALSE; they carry absolute +# paths from whoever ran it, and stale .gcda counters break a later gcov merge +/covr +*.gcda +*.gcno +*.gcov +src/*.o +src/*.so diff --git a/NEWS.md b/NEWS.md index 4181c37..937b255 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,45 @@ # nlmixr2save 0.2.0 +* `loadFit()` (and therefore `:=`) now restores the fit table's `ID` column as a + factor. The table round-trips through a plain `.csv`, so `ID` came back as an + integer while a live fit carries a factor; anything joining the fit table to + something derived from the fit then hit a type mismatch, since + `nlme::augPred()` keeps its `id` a factor. `ggPMX::pmx_nlmixr()` on a cached + fit failed outright with "Incompatible join types: x.ID (factor) and i.ID + (integer)". The repair happens on load, so caches written by earlier versions + are fixed too. + +* `saveFit()` now records the `parHistData$type` factor levels for fits that + store `parHistData` compressed (the nlmixr2est default). It read the levels + straight out of the fit environment, where a compressed fit keeps a raw + vector rather than a data frame, so the levels were silently not recorded and + `loadFit()` fell back to a hardcoded level list. nlmixr2est has since added + types that list predates ("Analytic Gradient (relaxed)" and friends), and + those came back as `NA`. + +* `loadFit()` now repairs a `parHistData$type` that the cache's *own* restore + script dropped to `NA`. Those levels are applied by the script stored inside + the cache, so a cache written before nlmixr2est added a type has no level for + it and coerces it to `NA` -- and re-saving cannot recover it, because by then + the string is already gone. `loadFit()` reads the column back from the + `-parHistData.csv` in the cache and appends whatever the script was missing, + so existing caches are repaired in place. + +* Saving or loading a fit no longer disturbs another cache whose base name it + is a suffix of. The list of files belonging to a fit was matched with an + unanchored pattern, so a cache named `fit` also matched `myfit-env.R` -- + zipping another cache's files into its own archive and then deleting them + from disk. This is reachable whenever unzipped files are lying around, which + `saveFit(zip=FALSE)` leaves by design. The names are now matched literally + rather than as a regexp, so a base name holding a metacharacter (`my.fit` is + an ordinary R name, and as a pattern its `.` also matched `my_fit`) is + matched exactly. + +* `saveFit(fit, zip=FALSE)` now actually leaves the fit unzipped for a fit table + (a `nlmixr2FitData`). The method wrote the fit `.csv` and then called the + core method with a hardcoded `zip=TRUE`, so the argument was silently ignored + for every fit that carries data. + * `nlmixrDataSimplify()` gained `est` and `control` arguments and no longer drops the covariate columns that `est="vae"` searches for. The VAE covariate search picks its covariates out of the data instead of out of the model, so diff --git a/R/save.R b/R/save.R index 984a2a5..d319161 100644 --- a/R/save.R +++ b/R/save.R @@ -8,6 +8,37 @@ .saveFitEnv$fun <- "" .saveFitEnv$restore <- FALSE +#' The unzipped files belonging to one saved fit +#' +#' That is `-*` plus `.csv` and `.R`. +#' +#' Matched literally rather than by regexp. A base name is a variable name or +#' a `nlmixr2save.prefix`, so it can hold regexp metacharacters -- `my.fit` is +#' an ordinary R name, and as a pattern its `.` also matches `my_fit`'s files. +#' The caller zips what it gets back and then unlinks it, so matching one +#' character too many silently destroys another cache; matching one too few +#' leaves a cache that cannot be loaded. +#' +#' @param file base name of the fit, possibly with a directory +#' @return the matching paths, relative to the working directory +#' @noRd +#' @author Matthew L. Fidler +.nlmixr2saveFitFiles <- function(file) { + .base <- basename(file) + .dir <- dirname(file) + # dirname("fit") is "." but dirname("") is "", and file.path("", x) would + # make that an absolute path at the filesystem root + if (.dir == "") .dir <- "." + # all.files: a base name can start with a dot, since `.fit` is an ordinary + # R name and saveFit() takes the base name from the variable + .all <- setdiff(list.files(.dir, all.files=TRUE), c(".", "..")) + .keep <- startsWith(.all, .base) & + (substring(.all, nchar(.base) + 1L, nchar(.base) + 1L) == "-" | + .all == paste0(.base, ".csv") | + .all == paste0(.base, ".R")) + gsub("^[.]/", "", file.path(.dir, .all[.keep])) +} + .minfo <- function (text, ..., .envir = parent.frame()) { .opt <- getOption("nlmixr2save.quiet", FALSE) if (checkmate::testLogical(.opt, @@ -538,6 +569,10 @@ saveFit.nlmixr2FitCore <- function(fit, file, zip=TRUE, data=.nlmixr2saveData()) .parHistTypeLevel <- NULL if (exists("parHistData", envir=fit$env, inherits=FALSE)) { .phd <- get("parHistData", envir=fit$env) + if (is.raw(.phd)) { + # nlmixr2est stores parHistData compressed; `$` decompresses it + .phd <- fit$parHistData + } if (is.data.frame(.phd) && is.factor(.phd$type)) { .parHistTypeLevel <- levels(.phd$type) } @@ -552,9 +587,7 @@ saveFit.nlmixr2FitCore <- function(fit, file, zip=TRUE, data=.nlmixr2saveData()) .str <- .str[.str != "NULL = NULL"] .str <- paste0("env <- list(", paste(.str, collapse=",\n"), ")\nenv <- list2env(env)\n") writeLines(.str, con = paste0(file,"-env.R")) - .files <- c(list.files(dirname(file), pattern=paste0(basename(file), "(-|[.]csv$|[.]R$)"), - full.names=TRUE)) - .files <- gsub("^[.]/", "", .files) + .files <- .nlmixr2saveFitFiles(file) # nlmixr2est <= 6.0 stores parFixedDf with named "Estimate"/"SE" columns; # the $parFixed refactor (nlmixr2est#645) stores them unnamed. Record # which structure this fit uses so the restore script rebuilds it exactly. @@ -648,7 +681,12 @@ saveFit.nlmixr2FitCore <- function(fit, file, zip=TRUE, data=.nlmixr2saveData()) # use the levels recorded from the fit; fall back to the # known level set for fits saved before they were recorded " .phLevels <- .parHistType.level\n", - " if (is.null(.phLevels)) .phLevels <- c(\"Gill83 Gradient\", \"Mixed Gradient\", \"Forward Difference\", \"Central Difference\", \"Scaled\", \"Unscaled\", \"Back-Transformed\", \"Forward Sensitivity\", \"Analytic Gradient\")\n", + " if (is.null(.phLevels)) {\n", + " .phLevels <- c(\"Gill83 Gradient\", \"Mixed Gradient\", \"Forward Difference\", \"Central Difference\", \"Scaled\", \"Unscaled\", \"Back-Transformed\", \"Forward Sensitivity\", \"Analytic Gradient\")\n", + # a fit saved before the levels were recorded can still use a + # type this list predates; append it rather than drop it to NA + " .phLevels <- c(.phLevels, setdiff(unique(as.character(env$parHistData$type)), .phLevels))\n", + " }\n", " env$parHistData$type <- factor(env$parHistData$type, levels=.phLevels)\n", " env$parHistData$iter <- as.integer(env$parHistData$iter)\n", "}\n", @@ -675,9 +713,7 @@ saveFit.nlmixr2FitCore <- function(fit, file, zip=TRUE, data=.nlmixr2saveData()) con = paste0(file,".R")) if (isTRUE(zip)) { .minfo("zipping fit files") - .files <- c(list.files(dirname(file), pattern=paste0(basename(file), "(-|[.]csv$|[.]R$)"), - full.names=TRUE)) - .files <- gsub("^[.]/", "", .files) + .files <- .nlmixr2saveFitFiles(file) zip::zip(zipfile = paste0(file, ".zip"), files = .files) .minfo("removing unzipped fit files") @@ -693,7 +729,7 @@ saveFit.nlmixr2FitData <- function(fit, file, zip=TRUE, data=.nlmixr2saveData()) file <- as.character(substitute(fit)) } utils::write.csv(fit, paste0(file, ".csv"), row.names=FALSE) - saveFit.nlmixr2FitCore(fit, file, zip=TRUE, data=data) + saveFit.nlmixr2FitCore(fit, file, zip=zip, data=data) } #' @rdname saveFit @@ -703,6 +739,108 @@ saveFit.default <- function(fit, file, zip=TRUE, data=.nlmixr2saveData()) { } +#' Put the `ID` column of a restored fit back to a factor +#' +#' The fit table is written as a plain `.csv`, so `read.csv()` brings `ID` back +#' as an integer (or character) while a real fit carries a factor. Anything that +#' joins the fit table against something derived from the fit then hits a type +#' mismatch -- `nlme::augPred()` keeps `id` a factor, so `ggPMX::pmx_nlmixr()` +#' dies in a data.table join with "Incompatible join types: x.ID (factor) and +#' i.ID (integer)". +#' +#' Done here rather than in the restore script written by [saveFit()] so that +#' caches saved by earlier versions are repaired on load too. +#' +#' Levels come from `ranef`/`etaObf`, which the restore script has already put +#' back as factors with the fit's own levels; failing that, from the order the +#' IDs appear (the order nlmixr2est itself uses). +#' +#' @param fit restored object +#' @return `fit`, with `ID` a factor when it is a fit table that has one +#' @noRd +#' @author Matthew L. Fidler +.nlmixr2saveRestoreIdFactor <- function(fit) { + if (!inherits(fit, "nlmixr2FitData")) return(fit) + if (!is.data.frame(fit)) return(fit) + if (is.null(fit[["ID"]]) || is.factor(fit[["ID"]])) return(fit) + .env <- try(fit$env, silent=TRUE) + .levels <- NULL + if (is.environment(.env)) { + for (.n in c("ranef", "etaObf")) { + .df <- try(get(.n, envir=.env, inherits=FALSE), silent=TRUE) + if (is.data.frame(.df) && is.factor(.df$ID)) { + .levels <- levels(.df$ID) + break + } + } + } + .id <- as.character(fit[["ID"]]) + if (is.null(.levels)) { + .levels <- unique(.id) + } else { + # ranef should cover every subject in the table, but never turn an ID the + # table does have into NA on the way to fixing its type + .levels <- c(.levels, setdiff(unique(.id), .levels)) + } + ## `class<-` last: the class attribute of a fit carries the `.foceiEnv` + ## attribute that `$` dispatches through, and column assignment must not be + ## allowed to drop it. + .cls <- class(fit) + fit[["ID"]] <- factor(.id, levels=.levels) + class(fit) <- .cls + fit +} + +#' Repair `parHistData$type` levels a cache's own restore script dropped +#' +#' The factor levels for `parHistData$type` are applied by the restore script +#' stored *inside* the cache. A script written before a given nlmixr2est +#' version knows nothing of the types that version added ("Analytic Gradient +#' (relaxed)" and friends), so it coerces them to `NA` -- and re-saving cannot +#' recover them, because by then the strings are already gone. +#' +#' The `-parHistData.csv` still holds the original strings and has not been +#' cleaned up yet at this point in [loadFit()], so read the column back from +#' there and append whatever the script's level list was missing. +#' +#' @param fit restored object +#' @param file base name the fit was loaded from +#' @return `fit`, invisibly; `parHistData` is repaired in the fit environment +#' @noRd +#' @author Matthew L. Fidler +.nlmixr2saveRestoreParHistType <- function(fit, file) { + # a fit table dispatches `$env` through its class attribute; a data-less fit + # (`nlmixr2saveShare(noFit=TRUE)`) restores as the environment itself + .env <- if (is.environment(fit)) fit else try(fit$env, silent=TRUE) + if (!is.environment(.env)) return(invisible(fit)) + if (!exists("parHistData", envir=.env, inherits=FALSE)) return(invisible(fit)) + .phd <- try(get("parHistData", envir=.env, inherits=FALSE), silent=TRUE) + # only NA types are worth repairing; a cache whose script knew the levels is + # already correct + if (!is.data.frame(.phd) || !is.factor(.phd$type) || !anyNA(.phd$type)) { + return(invisible(fit)) + } + .csv <- paste0(file, "-parHistData.csv") + if (!file.exists(.csv)) return(invisible(fit)) + # colClasses="character": type is a level name, and letting read.csv infer + # would turn a level like "01" into 1 or "T" into TRUE on the way back + .raw <- try(utils::read.csv(.csv, check.names=FALSE, colClasses="character"), + silent=TRUE) + if (!is.data.frame(.raw) || is.null(.raw$type) || nrow(.raw) != nrow(.phd)) { + return(invisible(fit)) + } + .type <- as.character(.raw$type) + .levels <- c(levels(.phd$type), setdiff(unique(.type[!is.na(.type)]), + levels(.phd$type))) + ## `class<-` last: for a saem fit the class attribute of parHistData carries + ## the `niter` attribute, which column assignment must not drop. + .cls <- class(.phd) + .phd$type <- factor(.type, levels=.levels) + class(.phd) <- .cls + assign("parHistData", .phd, envir=.env) + invisible(fit) +} + #' Load a fitted model object from a file #' #' @param file the base name of the files to load the fit from. @@ -734,13 +872,14 @@ loadFit <- function(file, checkVersion=.nlmixr2saveCheckVersion()) { .minfo(paste0("loading fit from ", .r)) source(.r, local=TRUE) ret <- get(file) + ret <- .nlmixr2saveRestoreIdFactor(ret) + # must run before the unzipped files are removed below; it reads the csv + .nlmixr2saveRestoreParHistType(ret, file) if (isTRUE(checkVersion)) { .nlmixr2saveWarnVersion(ret) } if (.didUnzip) { - .files <- list.files(dirname(file), pattern=paste0(basename(file), "(-|[.]csv$|[.]R$)"), - full.names=TRUE) - .files <- gsub("^[.]/", "", .files) + .files <- .nlmixr2saveFitFiles(file) .minfo("removing unzipped fit files") lapply(.files, unlink) } diff --git a/tests/testthat/test-save.R b/tests/testthat/test-save.R index 2e13e73..2dfce84 100644 --- a/tests/testthat/test-save.R +++ b/tests/testthat/test-save.R @@ -12,6 +12,38 @@ test_that(".assignParent errors on non-environment", { expect_error(.assignParent(1), "env must be an environment") }) +test_that(".nlmixr2saveFitFiles matches one fit's files and no others", { + # what comes back is zipped and then unlinked, so matching one file too many + # destroys another cache and one too few leaves an unloadable one + withr::with_tempdir({ + file.create(c("fit-env.R", "fit-ui.R", "fit.csv", "fit.R", "fit.zip", + "myfit-env.R", "myfit.csv", "fitExtra-env.R", "fit2.csv", + "my.fit-env.R", "my.fit.csv", "my_fit-env.R", "my_fit.csv", + "fit+1-env.R", ".dot-env.R", ".dot.csv")) + + expect_equal(sort(.nlmixr2saveFitFiles("fit")), + c("fit-env.R", "fit-ui.R", "fit.R", "fit.csv")) + # not the .zip, and not a longer name that merely starts the same way + expect_false(any(c("fit.zip", "fit2.csv", "fitExtra-env.R", "myfit.csv") %in% + .nlmixr2saveFitFiles("fit"))) + # a base name is a variable name, so it can hold regexp metacharacters: + # as a pattern, "my.fit" would also match my_fit's files + expect_equal(sort(.nlmixr2saveFitFiles("my.fit")), + c("my.fit-env.R", "my.fit.csv")) + expect_equal(sort(.nlmixr2saveFitFiles("my_fit")), + c("my_fit-env.R", "my_fit.csv")) + expect_equal(.nlmixr2saveFitFiles("fit+1"), "fit+1-env.R") + # `.dot` is an ordinary R name, and its files are hidden + expect_equal(sort(.nlmixr2saveFitFiles(".dot")), c(".dot-env.R", ".dot.csv")) + expect_equal(length(.nlmixr2saveFitFiles("nosuch")), 0) + + dir.create("sub") + file.create(c("sub/a-env.R", "sub/a.csv", "sub/ab.csv")) + expect_equal(sort(.nlmixr2saveFitFiles(file.path("sub", "a"))), + c("sub/a-env.R", "sub/a.csv")) + }) +}) + test_that("saveFitRandom adds and removes registered random functions", { .old <- saveFitRandom() on.exit(saveFitRandom(.old), add = TRUE) @@ -555,6 +587,166 @@ if (requireNamespace("nlmixr2est", quietly = TRUE) && fitEquals(fitF, fit2F) fitEquals(fitS, fit2S) + test_that("a restored fit keeps ID a factor", { + # the fit table round-trips through a plain .csv, so ID comes back as an + # integer unless it is put back. Anything joining the fit table to + # something derived from the fit then hits a type mismatch -- + # nlme::augPred() keeps `id` a factor, and ggPMX::pmx_nlmixr() dies in a + # data.table join on it. + expect_true(is.factor(fit2F$ID)) + expect_equal(levels(fit2F$ID), levels(fitF$ID)) + expect_equal(as.character(fit2F$ID), as.character(fitF$ID)) + expect_true(is.factor(fit2S$ID)) + expect_equal(levels(fit2S$ID), levels(fitS$ID)) + }) + + # The two repair functions are exercised on hand-built objects rather + # than on another saved-and-reloaded fit. Each extra round trip rebuilds + # an rxode2 model, which is nearly free against a warm cache but costs + # minutes against a cold one -- three such tests took over 18 minutes on + # CI where all five fits together took 81 seconds. Synthetic inputs also + # pin the behavior down harder, since the levels can be made to disagree + # with the row order in a way theo_sd's IDs never do. + + test_that(".nlmixr2saveRestoreIdFactor takes its levels from ranef", { + .env <- new.env(parent=emptyenv()) + # levels deliberately in the opposite order to the rows, so following + # ranef and following the order of appearance give different answers + assign("ranef", data.frame(ID=factor(c("b", "a"), levels=c("b", "a"))), + envir=.env) + .cls <- c("nlmixr2FitData", "nlmixr2FitCore", "data.frame") + .fit <- data.frame(ID=c("a", "b", "a"), DV=1:3) + attr(.cls, ".foceiEnv") <- .env + class(.fit) <- .cls + + .r <- .nlmixr2saveRestoreIdFactor(.fit) + expect_true(is.factor(.r$ID)) + expect_equal(levels(.r$ID), c("b", "a")) + # the labels still line up with the rows; only the coding changed + expect_equal(as.character(.r$ID), c("a", "b", "a")) + # the class attribute carries the env `$` dispatches through, and + # column assignment must not drop it + expect_true(is.environment(attr(class(.r), ".foceiEnv"))) + + # with no usable ranef it falls back to the order the IDs appear, not + # a sort -- a character sort would put "10" before "2" + .env2 <- new.env(parent=emptyenv()) + assign("ranef", data.frame(ID=c(2L, 10L)), envir=.env2) + .cls2 <- c("nlmixr2FitData", "nlmixr2FitCore", "data.frame") + .fit2 <- data.frame(ID=c(2L, 10L, 2L), DV=1:3) + attr(.cls2, ".foceiEnv") <- .env2 + class(.fit2) <- .cls2 + expect_equal(levels(.nlmixr2saveRestoreIdFactor(.fit2)$ID), c("2", "10")) + + # an ID the ranef levels do not cover must not become NA + .env3 <- new.env(parent=emptyenv()) + assign("ranef", data.frame(ID=factor("a", levels="a")), envir=.env3) + .cls3 <- c("nlmixr2FitData", "nlmixr2FitCore", "data.frame") + .fit3 <- data.frame(ID=c("a", "z"), DV=1:2) + attr(.cls3, ".foceiEnv") <- .env3 + class(.fit3) <- .cls3 + .r3 <- .nlmixr2saveRestoreIdFactor(.fit3) + expect_false(anyNA(.r3$ID)) + expect_equal(levels(.r3$ID), c("a", "z")) + + # nothing to do for an object that is not a fit table with an ID + expect_identical(.nlmixr2saveRestoreIdFactor(1L), 1L) + expect_identical(.nlmixr2saveRestoreIdFactor(data.frame(a=1)), + data.frame(a=1)) + }) + + test_that(".nlmixr2saveRestoreParHistType repairs a dropped type", { + withr::with_tempdir({ + .e <- new.env(parent=emptyenv()) + .ph <- data.frame(iter=1:3, + type=c("Unscaled", "Unscaled", "Future Gradient")) + utils::write.csv(.ph, "b-parHistData.csv", row.names=FALSE) + # what the cache's own script leaves behind: a level list that + # predates the type, so it came back NA + .ph$type <- factor(.ph$type, levels="Unscaled") + expect_true(anyNA(.ph$type)) + .cls <- class(.ph) + attr(.cls, "niter") <- 42L # saem hangs this off the class + class(.ph) <- .cls + assign("parHistData", .ph, envir=.e) + + .nlmixr2saveRestoreParHistType(.e, "b") + .out <- get("parHistData", envir=.e) + expect_false(anyNA(.out$type)) + expect_equal(levels(.out$type), c("Unscaled", "Future Gradient")) + expect_equal(as.character(.out$type[3]), "Future Gradient") + # every attribute nlmixr2est hangs off the class survives + expect_equal(attr(class(.out), "niter"), 42L) + + # a type column with no NA is left exactly as it was + .e2 <- new.env(parent=emptyenv()) + .ok <- data.frame(iter=1L, type=factor("Unscaled")) + assign("parHistData", .ok, envir=.e2) + .nlmixr2saveRestoreParHistType(.e2, "b") + expect_identical(get("parHistData", envir=.e2), .ok) + + # a missing csv, or one whose rows do not line up, is left alone + .e3 <- new.env(parent=emptyenv()) + assign("parHistData", .ph, envir=.e3) + .nlmixr2saveRestoreParHistType(.e3, "nosuch") + expect_true(anyNA(get("parHistData", envir=.e3)$type)) + + utils::write.csv(.ph[1, ], "short-parHistData.csv", row.names=FALSE) + .e4 <- new.env(parent=emptyenv()) + assign("parHistData", .ph, envir=.e4) + .nlmixr2saveRestoreParHistType(.e4, "short") + expect_true(anyNA(get("parHistData", envir=.e4)$type)) + + # an env with no parHistData at all is fine + expect_error(.nlmixr2saveRestoreParHistType(new.env(), "b"), NA) + }) + }) + + test_that("a cache saved before the levels were recorded still loads", { + # A cache written by an earlier nlmixr2save has no `..id.level..` and no + # `..parHistType.level..`. Simulate one by blanking both out of the + # env script (`env` is a plain environment when those lines run, so + # assigning NULL leaves exactly what a missing entry looks like to the + # restore script), and by injecting a parHistData type that postdates + # the loader's hardcoded fallback list. + suppressMessages(saveFit(fitS, "fitOld", zip=FALSE)) + # zip=FALSE has to be honored for a fit table too, not just for a core + expect_false(file.exists("fitOld.zip")) + expect_true(file.exists("fitOld-env.R")) + expect_true(file.exists("fitOld.csv")) + cat("env$`..id.level..` <- NULL\n", + "env$`..parHistType.level..` <- NULL\n", + file="fitOld-env.R", append=TRUE, sep="") + + .ph <- utils::read.csv("fitOld-parHistData.csv", check.names=FALSE) + .ph$type[1] <- "Future Gradient" + utils::write.csv(.ph, "fitOld-parHistData.csv", row.names=FALSE) + + .old <- suppressMessages(loadFit("fitOld", checkVersion=FALSE)) + + # ID is repaired from the order the IDs appear, not from a sort -- + # a character sort would put "10" before "2". + expect_true(is.factor(.old$ID)) + expect_equal(levels(.old$ID), unique(as.character(fitS$ID))) + expect_equal(as.character(.old$ID), as.character(fitS$ID)) + + # the unrecognized type is appended to the fallback list rather than + # dropped to NA. Source the restore script directly rather than going + # through loadFit(): loadFit() also repairs an NA type from the csv, + # which would mask a broken script. + .se <- new.env() + source("fitOld.R", local=.se) + .script <- get("fitOld", envir=.se) + expect_true(is.factor(.script$parHistData$type)) + expect_false(anyNA(.script$parHistData$type)) + expect_true("Future Gradient" %in% levels(.script$parHistData$type)) + expect_equal(as.character(.script$parHistData$type[1]), "Future Gradient") + + # and the same holds through loadFit() + expect_false(anyNA(.old$parHistData$type)) + expect_equal(as.character(.old$parHistData$type[1]), "Future Gradient") + }) + test_that("saveFit(data=FALSE) omits the original data", { suppressMessages(saveFit(fitF, "fitFnd", data=FALSE)) expect_true(file.exists("fitFnd.zip")) @@ -618,6 +810,22 @@ if (requireNamespace("nlmixr2est", quietly = TRUE) && fit2IS <- loadFit("fitIS") fitEquals(fitIS, fit2IS) + test_that("a compressed fit still records its parHistData type levels", { + # nlmixr2est stores parHistData compressed (a raw vector in the env) + # unless compress=FALSE, so saveFit() has to decompress before it can + # read the type levels off it. Without that it fell through to the + # loader's hardcoded level list, which nlmixr2est has since outgrown + # ("Analytic Gradient (relaxed)" and friends), and those levels came + # back as NA. + expect_true(is.raw(get("parHistData", envir=fitIS$env))) + expect_equal(levels(fit2IS$parHistData$type), + levels(fitIS$parHistData$type)) + expect_false(anyNA(fit2IS$parHistData$type)) + expect_equal(levels(fit2IF$parHistData$type), + levels(fitIF$parHistData$type)) + expect_false(anyNA(fit2IF$parHistData$type)) + }) + one.cmt.nlm <- function() { ini({ tka <- 0.45 # Log Ka