Add na handling routines for time and importing

nlmixr2 · May 2, 2024 · c7e1348 · c7e1348
1 parent efd2e7b
commit c7e1348
Show file tree

Hide file tree

Showing 3 changed files with 49 additions and 8 deletions.
diff --git a/R/dataImport.R b/R/dataImport.R
@@ -1,3 +1,28 @@
+#' Monolix data import can include spaces in NAs, look for these cases
+#'
+#' @param data input data
+#' @param na.strings na strings
+#' @return converted dataset with na
+#' @noRd
+#' @author Matthew L. Fidler
+.monolixNaApply <- function(data, na.strings) {
+  .dat <- data
+  for (v in names(.dat)) {
+    if (is.character(.dat[[v]])) {
+      .n <- suppressWarnings(as.numeric(.dat[[v]]))
+      .w <- which(is.na(.n))
+      if (length(.w) == 0) {
+        .dat[[v]] <- .n
+      } else if (all(grepl(paste0("^ *(",
+                           paste(na.strings, collapse="|"),
+                           ") *$"), .dat[[v]][.w]))) {
+        .dat[[v]] <- .n
+      }
+    }
+  }
+  .dat
+}
+
 #' Load data from a mlxtran defined dataset
 #'
 #' @param mlxtran mlxtran file where data input is specified
@@ -24,7 +49,7 @@
         # has header (and it matches)
         .data <- utils::read.table(.file, header = TRUE, sep=.sep, row.names=NULL,
                             na.strings=na.strings)
-        return(.data)
+        return(.monolixNaApply(.data, na.strings))
       } else {
         .num <- vapply(.head,
                        function(v) {
@@ -42,7 +67,7 @@
                  call.=FALSE)
           }
           names(.data) <- mlxtran$DATAFILE$FILEINFO$FILEINFO$header
-          return(.data)
+          return(.monolixNaApply(.data, na.strings))
         } else {
           # missing header
           .data <- utils::read.table(.file, header = FALSE, sep=.sep, row.names=NULL,
@@ -52,7 +77,7 @@
                  call.=FALSE)
           }
           names(.data) <- mlxtran$DATAFILE$FILEINFO$FILEINFO$header
-          return(.data)
+          return(.monolixNaApply(.data, na.strings))
         }
       }
     } else {
@@ -232,6 +257,12 @@ monolixDataImport <- function(ui, data, na.strings=c("NA", ".")) {
   if (length(.wt) == 0) {
     .minfo("added dummy time column")
     data$time <- seq_along(data[, 1])
+  } else {
+    .wt0 <- which(is.na(data[, .wt]))
+    if (length(.wt0) > 0) {
+      .minfo("replaced na time with zero")
+      data[.wt0, .wt] <- 0
+    }
   }
   data
 }
diff --git a/R/monolix2rx.R b/R/monolix2rx.R
@@ -162,6 +162,7 @@ monolix2rx <- function(mlxtran, update=TRUE, thetaMatType=c("sa", "lin"),
                   crayon::bold$blue("$monolixData"), ")"))
     .ui$monolixData <- .monolixData
     .ui$sticky <- "monolixData"
+
   }
   .etaData <- try(monolixEtaImport(.ui))
   if (inherits(.etaData, "try-error")) .etaData <- NULL
@@ -177,7 +178,18 @@ monolix2rx <- function(mlxtran, update=TRUE, thetaMatType=c("sa", "lin"),
                   crayon::blue$bold("$predIpredData"), ")"))
     .ui$predIpredData <- .predIpredData
   }
-  .ui <- .validateModel(.ui)
+  if (!is.null(.ui$monolixData) && (.dfObs <= 0L || .dfSub <= 0L)) {
+    .trans <- rxode2::etTrans(.ui$monolixData, .ui)
+    .lst <- attr(class(.trans), ".rxode2.lst")
+    if (.dfObs <= 0L) {
+      assign("dfObs", as.double(.lst$nobs), envir=.ui$meta)
+    }
+    .dfSub <- attr(.mlxtran, "dfSub")
+    if (.dfSub <= 0L) {
+      assign("dfSub", as.double(.lst$nid), envir=.ui$meta)
+    }
+  }
+
   .ui <- rxode2::rxUiCompress(.ui)
   class(.ui) <- c("monolix2rx", class(.ui))
   .ui

diff --git a/tests/testthat/test-rxsolve.R b/tests/testthat/test-rxsolve.R
@@ -18,8 +18,8 @@ test_that("solving makes sense", {
 
   s <- .rxSolve(f, nStud=1)
 
-  ## expect_equal(s$env$.args$dfObs, 2280)
-  ## expect_equal(s$env$.args$dfSub, 120)
+  expect_equal(s$env$.args$dfObs, 120)
+  expect_equal(s$env$.args$dfSub, 12)
 
   expect_equal(s$env$.args$thetaMat, f$thetaMat)
   expect_equal(s$env$.args$omega, f$omega)
@@ -28,6 +28,4 @@ test_that("solving makes sense", {
     expect_true(all(s$params[[v]] == f$theta[v]))
   }
 
-  # now test model that does not translate the error
-  # force rik's model
 })