diff --git a/DESCRIPTION b/DESCRIPTION index 4ba61abe..7e32a1d2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: pharmr.extra Title: Extension of pharmr (Pharmpy) functionality -Version: 0.0.0.9140 +Version: 0.0.0.9141 Authors@R: c( person("Ron", "Keizer", email = "ron@insight-rx.com", role = c("cre", "aut")), person("Michael", "McCarthy", email = "michael.mccarthy@insight-rx.com", role = "ctb"), diff --git a/R/create_model_from_file.R b/R/create_model_from_file.R index 05618dd3..3134ee44 100644 --- a/R/create_model_from_file.R +++ b/R/create_model_from_file.R @@ -3,7 +3,11 @@ #' @param model_file the model file (.mod) to read. #' @param ext_file optional path to a .ext file containing final parameter #' estimates that will be used to update the initial estimates in the model. -#' @param data the filename of the dataset (or an actual data.frame) +#' @param data CSV filename or data.frame. Supplied data is written to a separate +#' working CSV with unquoted data fields. Its header matches the character IGNORE +#' rule (`#` when absent); conditional filters and `$INPUT` DROP flags are +#' preserved. R missing values are written as NONMEM null fields. Source +#' files are not modified. #' @param verbose verbose output #' #' @returns a Pharmpy model object @@ -17,13 +21,16 @@ create_model_from_file <- function( ) { ## Checks - dataset_file <- NULL if(! inherits(model_file, "character")) { cli::cli_abort("Model file should be a string.") } if(! file.exists(model_file)) { cli::cli_abort("Model file {model_file} does not exist") } + model_code <- readLines(model_file) |> + paste(collapse = "\n") |> + fix_eta_dummy_bug() |> + strip_input_commas() if(inherits(data, "data.frame") || inherits(data, "tibble")) { ## Do nothing } else if (inherits(data, "character")) { @@ -31,7 +38,8 @@ create_model_from_file <- function( if (!file.exists(dataset_file)) { cli::cli_abort("Data file {dataset_file} does not exist") } - data <- read.csv(dataset_file) + data <- read.csv(dataset_file, check.names = FALSE, colClasses = "character", na.strings = NULL) + data <- strip_nonmem_header_marker(data, model_code) } ## Drop bookkeeping columns whose names are not valid NONMEM $INPUT symbols @@ -42,9 +50,8 @@ create_model_from_file <- function( ## (`_DROP1`, `_DROP2`, ...) are exempt: their leading underscore is not a ## valid symbol either, but sync_input_to_dataset() re-emits them as a bare ## `DROP`, so they must survive to keep the underlying values (e.g. the DV - ## that `set_dv()` demoted) round-trippable. When we drop any, force a freshly - ## written dataset below so $DATA points at a CSV whose columns match the - ## rewritten $INPUT. + ## that `set_dv()` demoted) round-trippable. The working CSV below follows + ## the filtered columns so it stays aligned with the rewritten $INPUT. if(!is.null(data)) { valid_input <- grepl("^[A-Za-z][A-Za-z0-9_]*$", names(data)) | grepl("^_DROP[0-9]*$", names(data)) @@ -54,16 +61,11 @@ create_model_from_file <- function( "Dropping column{?s} {.val {dropped}} from the dataset: not a valid NONMEM $INPUT name." ) data <- data[, valid_input, drop = FALSE] - dataset_file <- NULL } } ## Create Pharmpy object tryCatch({ - model_code <- readLines(model_file) |> - paste(collapse = "\n") |> - fix_eta_dummy_bug() |> - strip_input_commas() if(!is.null(data)) { ## if `data` supplied, then make sure current path is DUMMYPATH ## otherwise, if it points to a file that does not exists, @@ -108,20 +110,10 @@ create_model_from_file <- function( ## later item on its row instead of raising an error -- a wrong fit or ## simulation rather than a loud failure. Replace those values with the ## NONMEM missing marker `.` (the column is dropped anyway, so nothing - ## NONMEM would have read is lost), and force a fresh dataset so the - ## sanitised values are what actually gets written. + ## NONMEM would have read is lost) before writing the working CSV. non_numeric <- names(data)[!vapply(data, is_numeric_column, logical(1))] - sanitised <- blank_unreadable_values(data, non_numeric) - if(!identical(sanitised, data)) { - data <- sanitised - dataset_file <- NULL - } - if(is.null(dataset_file)) { - dataset_file <- tempfile(pattern = "data", fileext = ".csv") - write.csv(data, dataset_file, quote = F, row.names = F) - } + data <- blank_unreadable_values(data, non_numeric) model_code <- model$code - model_path <- tempfile(fileext = ".mod") ## Deliberately not using pharmr::set_dataset(datatype = "nonmem") here: ## it rewrites $INPUT from the dataframe's columns and thereby discards the ## DROP flags declared in the model file's original $INPUT. Pharmpy then @@ -130,7 +122,7 @@ create_model_from_file <- function( ## DatasetError. Instead sync $INPUT to the dataset columns ourselves, ## carrying the original tokens (and their DROP flags) over. See #99/#101. model_code <- sync_input_to_dataset(model_code, names(data), non_numeric) |> - change_nonmem_dataset(dataset_file) |> + bind_nonmem_dataset(data) |> fix_eta_dummy_bug() tryCatch({ model <- pharmr::read_model_from_string(model_code) @@ -140,6 +132,40 @@ create_model_from_file <- function( model } +# Only undo a header marker when $INPUT confirms the underlying column name. +strip_nonmem_header_marker <- function(data, code) { + first <- input_token_name(unname(get_input_tokens(code))[1]) + if(toupper(first) %in% c("DROP", "SKIP")) first <- "_DROP1" + parser <- reticulate::import("pharmpy.model.external.nonmem.nmtran_parser")$NMTranParser() + marker <- parser$parse(code)$get_records("DATA")[[1]]$ignore_character %||% "#" + if(marker == "@") marker <- "#" + if(identical(names(data)[1], paste0(marker, first)) || + (marker == "," && identical(names(data)[1], ""))) names(data)[1] <- first + data +} + +# Preserve character filters too: replacing IGNORE=I with @ can discard valid text rows. +bind_nonmem_dataset <- function(code, data, dataset_file = tempfile(pattern = "data", fileext = ".csv")) { + parser <- reticulate::import("pharmpy.model.external.nonmem.nmtran_parser")$NMTranParser() + stream <- parser$parse(code) + record <- stream$get_records("DATA")[[1]] + marker <- record$ignore_character %||% "#" + header <- names(data) + skipped <- if(marker == "@") grepl("^[A-Za-z#@]", header[1]) else startsWith(header[1], marker) + if(!skipped) { + header[1] <- switch(marker, + '@' = paste0("#", header[1]), + '"' = paste0('"', header[1], '"'), + ',' = "", + paste0(marker, header[1]) + ) + } + write.table(data, dataset_file, sep = ",", col.names = header, + quote = FALSE, row.names = FALSE, na = "") + updated <- record$set_filename(dataset_file)$set_ignore_character(marker) + reticulate::py_str(stream$replace_records(list(record), list(updated))) +} + #' Strip commas from the $INPUT record of NONMEM model code #' #' Comma-separated `$INPUT` items are valid NONMEM but not accepted by diff --git a/R/prepare_run_folder.R b/R/prepare_run_folder.R index 3f9d9b55..e9c83b76 100644 --- a/R/prepare_run_folder.R +++ b/R/prepare_run_folder.R @@ -29,6 +29,7 @@ prepare_run_folder <- function( model_file <- "run.mod" output_file <- "run.lst" model_path <- file.path(fit_folder, model_file) + model_code <- model$code ## When a dictionary was applied in create_model(), use the original data ## (with original column names) so the CSV is an exact copy of the input. @@ -62,15 +63,15 @@ prepare_run_folder <- function( if(!isTRUE(file.copy(from = data, to = dataset_path))) { cli::cli_abort("Failed to copy dataset from {.path {data}} to {.path {dataset_path}}.") } - ## If the source CSV has quoted headers (e.g. `"ID","TIME",...`), NONMEM - ## will try to parse the header row as data. Detect this and rewrite the - ## dataset with unquoted headers. + ## Normalize a quoted CSV through the same writer used when binding a model. + ## Its header must still match any existing character IGNORE rule. first_line <- tryCatch(readLines(dataset_path, n = 1), error = function(e) character(0)) if (length(first_line) && grepl('^["\']', first_line)) { if (verbose) cli::cli_alert_info("Stripping quoted column names from dataset header") - df <- read.csv(dataset_path, check.names = FALSE) + df <- read.csv(dataset_path, check.names = FALSE, colClasses = "character", na.strings = NULL) df <- unquote_column_names(df) - write.csv(df, file = dataset_path, quote = FALSE, row.names = FALSE) + df <- strip_nonmem_header_marker(df, model_code) + model_code <- bind_nonmem_dataset(model_code, df, dataset_path) } } } else { @@ -89,7 +90,7 @@ prepare_run_folder <- function( ) } if(verbose) cli::cli_alert_info("Updating model dataset with provided dataset") - write.csv(data, file = dataset_path, quote = FALSE, row.names = FALSE) + model_code <- bind_nonmem_dataset(model_code, data, dataset_path) } } else if (!is.null(original_data)) { ## When `copy_dataset = FALSE` and the model's $DATA record already points @@ -112,7 +113,7 @@ prepare_run_folder <- function( } if (verbose) proc <- cli::cli_process_start("Copying dataset (original column names)") original_data <- unquote_column_names(original_data) - write.csv(original_data, file = dataset_path, quote = FALSE, row.names = FALSE) + model_code <- bind_nonmem_dataset(model_code, original_data, dataset_path) } } else { ## `data` is NULL: resolve dataset from the model. Try the $DATA record @@ -141,14 +142,13 @@ prepare_run_folder <- function( )) } if (verbose) proc <- cli::cli_process_start("Copying dataset from model object") - write.csv(model$dataset, file = dataset_path, quote = FALSE, row.names = FALSE) + model_code <- bind_nonmem_dataset(model_code, model$dataset, dataset_path) } else { cli::cli_abort("No dataset could be resolved: `model$dataset` is NULL and no existing file was found from the model's $DATA record.") } } ## Copy modelfile - model_code <- model$code ## Replace dictionary placeholder column names with DROP model_code <- gsub("_DDRP_[A-Za-z0-9_]+", "DROP", model_code, perl = TRUE) ## Only rewrite $DATA when the dataset was placed into the run folder. When diff --git a/man/create_model_from_file.Rd b/man/create_model_from_file.Rd index 6adca436..0a42c59d 100644 --- a/man/create_model_from_file.Rd +++ b/man/create_model_from_file.Rd @@ -17,7 +17,11 @@ create_model_from_file( \item{ext_file}{optional path to a .ext file containing final parameter estimates that will be used to update the initial estimates in the model.} -\item{data}{the filename of the dataset (or an actual data.frame)} +\item{data}{CSV filename or data.frame. Supplied data is written to a separate +working CSV with unquoted data fields. Its header matches the character IGNORE +rule (\verb{#} when absent); conditional filters and \verb{$INPUT} DROP flags are +preserved. R missing values are written as NONMEM null fields. Source +files are not modified.} \item{verbose}{verbose output} } diff --git a/tests/testthat/test-create_model_from_file.R b/tests/testthat/test-create_model_from_file.R index a42d355e..8ffe38dd 100644 --- a/tests/testthat/test-create_model_from_file.R +++ b/tests/testthat/test-create_model_from_file.R @@ -462,3 +462,151 @@ test_that("input_token_name resolves plain, labelled and DROP tokens", { expect_equal(input_token_name("DROP=VISITDATE"), "VISITDATE") expect_equal(input_token_name("CLOCK=SKIP"), "CLOCK") }) + +for (input_kind in c("frame", "quoted CSV", "unquoted CSV")) { + for (data_options in c("", "IGNORE=@", "IGNORE='#'", "IGNORE=(ID.EQ.2)", + "ACCEPT=(ID.EQ.1)", "IGNORE=@\n IGNORE=(ID.EQ.2)")) { + test_that(paste("dataset binding handles", input_kind, "with", data_options), { + local_pharmr.extra_options() + tmp <- withr::local_tempdir() + dat <- data.frame(ID = c(1, 1, 2), TIME = c(0, 1, 0), + CONC = c(0, 2.5, 4), CLOCK = c("9:00", "10:00", "9:00")) + code <- paste("$PROBLEM Header binding", "$INPUT ID TIME DV=CONC CLOCK=DROP", + paste("$DATA dummy", data_options, "; retain data options"), + "$PRED Y=THETA(1)+EPS(1)", "$THETA 1", "$SIGMA 1", + "$ESTIMATION METHOD=0 MAXEVAL=0", sep = "\n") + mod_file <- file.path(tmp, "model.mod") + writeLines(code, mod_file) + csv_file <- file.path(tmp, "input.csv") + write.csv(dat, csv_file, row.names = FALSE, quote = input_kind != "unquoted CSV") + original <- readBin(csv_file, "raw", n = file.info(csv_file)$size) + supplied <- if (input_kind == "frame") dat else csv_file + + model <- create_model_from_file(mod_file, data = supplied, verbose = FALSE) + + retained <- if (grepl("ID.EQ", data_options, fixed = TRUE)) c(1, 2) else 1:3 + expect_equal(model$dataset$ID, dat$ID[retained]) + expect_equal(model$dataset$CONC, dat$CONC[retained]) + expect_equal(names(model$dataset), names(dat)) + expect_true(grepl("DV=CONC CLOCK=DROP", model$code, fixed = TRUE)) + if (grepl("ID.EQ", data_options, fixed = TRUE)) { + filter <- if (grepl("ACCEPT", data_options)) "ACCEPT=(ID.EQ.1)" else "IGNORE=(ID.EQ.2)" + expect_true(grepl(filter, model$code, fixed = TRUE)) + } + expect_equal(readBin(csv_file, "raw", n = file.info(csv_file)$size), original) + expect_equal(readLines(mod_file), strsplit(code, "\n", fixed = TRUE)[[1]]) + copy <- as.character(model$datainfo$path) + expect_false(identical(copy, csv_file)) + expect_equal(read.csv(copy, col.names = names(dat), check.names = FALSE), dat) + writeLines(model$code, file.path(tmp, "bound.mod")) + rebound <- create_model_from_file(file.path(tmp, "bound.mod"), data = copy, verbose = FALSE) + expect_equal(lapply(rebound$dataset, identity), lapply(model$dataset, identity)) + prepared <- prepare_run_folder("prepared", model, tmp, data = dat, verbose = FALSE) + ready <- pharmr::read_model(file.path(prepared$fit_folder, prepared$model_file)) + expect_equal(lapply(ready$dataset, identity), lapply(model$dataset, identity)) + }) + } +} + +test_that("dataset binding preserves CSV null tokens and numeric text", { + local_pharmr.extra_options() + tmp <- withr::local_tempdir() + mod_file <- file.path(tmp, "model.mod") + csv_file <- file.path(tmp, "input.csv") + writeLines(c("$PROBLEM Null tokens", "$INPUT ID TIME DV", + "$DATA dummy NULL=9 IGNORE=@", "$PRED Y=THETA(1)+EPS(1)", + "$THETA 1", "$SIGMA 1"), mod_file) + writeLines(c('"ID","TIME","DV"', '001,0,.', '001,1,', + '001,2,1.2345678901234567'), csv_file) + + model <- create_model_from_file(mod_file, data = csv_file, verbose = FALSE) + + expect_equal(model$dataset$DV, c(9, 9, 1.2345678901234567)) + expect_true(grepl("NULL=9", model$code, fixed = TRUE)) + expect_equal(readLines(as.character(model$datainfo$path))[-1], readLines(csv_file)[-1]) +}) + +test_that("dataset binding writes missing frame values as NONMEM nulls", { + local_pharmr.extra_options() + tmp <- withr::local_tempdir() + mod_file <- file.path(tmp, "model.mod") + writeLines(c("$PROBLEM Missing values", "$INPUT ID TIME DV", "$DATA dummy NULL=9", + "$PRED Y=THETA(1)+EPS(1)", "$THETA 1", "$SIGMA 1"), mod_file) + + model <- create_model_from_file( + mod_file, data = data.frame(ID = 1, TIME = c(0, 1), DV = c(NA, 2)), verbose = FALSE + ) + + expect_equal(model$dataset$DV, c(9, 2)) +}) + +test_that("run_sim binds a model filename without a header skip before execution", { + local_pharmr.extra_options() + tmp <- withr::local_tempdir() + withr::local_dir(tmp) + code <- sub("IGNORE=@", "", make_model_without_cov()$code, fixed = TRUE) + writeLines(code, "model.mod") + received <- NULL + local_mocked_bindings( + run_nlme = function(model, ...) { + received <<- model$dataset + .mock_nlme_result() + }, + .package = "pharmr.extra" + ) + + out <- run_sim(model = "model.mod", data = .sim_dat(), update_table = FALSE, + verbose = FALSE) + + expect_equal(received$ID, .sim_dat()$ID) + expect_equal(received$DV, .sim_dat()$DV) + expect_equal(nrow(out), 3) +}) + +for (first_column in c("INDEX", "_DROP1")) { + for (marker in c("I", "_", "2", "#", "")) { + test_that(paste("dataset binding preserves leading DROP data with", first_column, marker), { + local_pharmr.extra_options() + tmp <- withr::local_tempdir() + dat <- data.frame(INDEX = c("A", "9", "2"), ID = 1:3, TIME = 0, DV = 1:3) + names(dat)[1] <- first_column + input <- if (first_column == "INDEX") "INDEX=DROP" else "DROP" + options <- if (nzchar(marker)) paste0("IGNORE=", marker) else "" + code <- paste("$PROBLEM Leading dropped column", paste("$INPUT", input, "ID TIME DV"), + paste("$DATA dummy", options), "$PRED Y=THETA(1)+EPS(1)", + "$THETA 1", "$SIGMA 1", sep = "\n") + mod_file <- file.path(tmp, "model.mod") + writeLines(code, mod_file) + + model <- create_model_from_file(mod_file, data = dat, verbose = FALSE) + + rows <- if(marker == "2") 1:2 else 1:3 + expect_equal(model$dataset$ID, dat$ID[rows]) + expect_equal(model$dataset[[first_column]], dat[[first_column]][rows]) + writeLines(model$code, mod_file) + rebound <- create_model_from_file(mod_file, data = as.character(model$datainfo$path), verbose = FALSE) + expect_equal(lapply(rebound$dataset, identity), lapply(model$dataset, identity)) + prepared <- prepare_run_folder("prepared", model, tmp, data = dat, verbose = FALSE) + ready <- pharmr::read_model(file.path(prepared$fit_folder, prepared$model_file)) + expect_equal(lapply(ready$dataset, identity), lapply(model$dataset, identity)) + }) + } +} + +for (marker in c('"', ',')) { + test_that(paste("dataset binding round-trips CSV punctuation IGNORE", marker), { + local_pharmr.extra_options() + tmp <- withr::local_tempdir() + mod_file <- file.path(tmp, "model.mod") + writeLines(c("$PROBLEM Quoted header", "$INPUT ID TIME DV", + paste0("$DATA dummy IGNORE='", marker, "'"), + "$PRED Y=THETA(1)+EPS(1)", "$THETA 1", "$SIGMA 1"), mod_file) + dat <- data.frame(ID = c(1, 2), TIME = 0, DV = c(2, 3)) + + model <- create_model_from_file(mod_file, data = dat, verbose = FALSE) + writeLines(model$code, mod_file) + rebound <- create_model_from_file(mod_file, data = as.character(model$datainfo$path), verbose = FALSE) + + expect_equal(lapply(rebound$dataset, identity), lapply(dat, identity)) + }) +}