fix: keep generated datasets readable for simulation and bootstrap

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"),

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,21 +21,25 @@ 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")) {
     dataset_file <- data
     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

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

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))
+  })
+}