RXR-2856 add input checks to get_map_estimates()

R/check_inputs.R

@@ -14,4 +14,32 @@ check_inputs <- function(model, data, parameters, omega, regimen, censoring, typ
   if(!("function" %in% class(model))) {
     stop("The 'model' argument requires a function, e.g. a model defined using the new_ode_model() function from the PKPDsim package.")
   }
-}
+  check_parameters_matching(model, parameters)
+}
+
+check_parameters_matching <- function(model, parameters) {
+  defined_parameters <- attr(model, "parameters")
+  if(is.null(defined_parameters)) {
+    warning("Parameter information for model missing, cannot perform parameter consistency check. Please check PKPDsim model definition.")
+  } else {
+    if(! all(defined_parameters %in% names(parameters))) {
+      missing_pars <- defined_parameters[! defined_parameters %in% names(parameters)]
+      stop(
+        paste0(
+          "One or more required parameters for the model have not been specified. Missing: ",
+          paste0(missing_pars, collapse = ", ")
+        )
+      )
+    }
+    if(any(!(names(parameters) %in% defined_parameters))) {
+      ignored_pars <- names(parameters)[! names(parameters) %in% defined_parameters]
+      warning(
+        paste0(
+          "Some supplied `parameters` are not supported by the model and will be ignored: ",
+          paste0(ignored_pars, collapse = ", "),
+          ". Passing unknown parameters may affect IIV and IOV structure and result in erroneous output."
+        )
+      )
+    }
+  }
+}

tests/testthat/setup.R

@@ -7,4 +7,4 @@ mod_1cmt_oral_lagtime <- PKPDsim::new_ode_model(
   obs = list(cmt = 2, scale = "V"),
   dose = list(cmt = 1, bioav = 1),
   parameters = list(CL = 5, V = 50, KA = 0.5, TLAG = 0.83)
-)
+)

tests/testthat/test-check_inputs.R

@@ -1,6 +1,7 @@
 test_that("check_inputs passes with valid MAP inputs", {
   # Create mock objects
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -13,6 +14,7 @@ test_that("check_inputs passes with valid MAP inputs", {
 test_that("check_inputs passes with valid PLS inputs", {
   # Create mock objects
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -25,6 +27,7 @@ test_that("check_inputs passes with valid PLS inputs", {
 test_that("check_inputs passes with valid pls inputs (lowercase)", {
   # Create mock objects
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -37,6 +40,7 @@ test_that("check_inputs passes with valid pls inputs (lowercase)", {
 test_that("check_inputs passes with valid MAP inputs (lowercase)", {
   # Create mock objects
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -49,6 +53,7 @@ test_that("check_inputs passes with valid MAP inputs (lowercase)", {
 test_that("check_inputs passes with valid censoring argument", {
   # Create mock objects
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -61,6 +66,7 @@ test_that("check_inputs passes with valid censoring argument", {
 test_that("check_inputs passes with other type values", {
   # Create mock objects
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -84,6 +90,7 @@ test_that("check_inputs fails when model is NULL for MAP type", {
 
 test_that("check_inputs fails when data is NULL for MAP type", {
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
   regimen <- list(dose = 100, interval = 12)
@@ -96,6 +103,7 @@ test_that("check_inputs fails when data is NULL for MAP type", {
 
 test_that("check_inputs fails when parameters is NULL for MAP type", {
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
   regimen <- list(dose = 100, interval = 12)
@@ -108,6 +116,7 @@ test_that("check_inputs fails when parameters is NULL for MAP type", {
 
 test_that("check_inputs fails when omega is NULL for MAP type", {
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   regimen <- list(dose = 100, interval = 12)
@@ -120,6 +129,7 @@ test_that("check_inputs fails when omega is NULL for MAP type", {
 
 test_that("check_inputs fails when regimen is NULL for MAP type", {
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -132,6 +142,7 @@ test_that("check_inputs fails when regimen is NULL for MAP type", {
 
 test_that("check_inputs fails when model is not a function", {
   model <- "not_a_function"
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -145,6 +156,7 @@ test_that("check_inputs fails when model is not a function", {
 
 test_that("check_inputs fails when model is a list (not a function)", {
   model <- list(not_a_function = TRUE)
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -158,6 +170,7 @@ test_that("check_inputs fails when model is a list (not a function)", {
 
 test_that("check_inputs fails when censoring is not NULL and not character", {
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -184,6 +197,7 @@ test_that("check_inputs fails when censoring is not NULL and not character", {
 
 test_that("check_inputs allows NULL censoring", {
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -195,6 +209,7 @@ test_that("check_inputs allows NULL censoring", {
 
 test_that("check_inputs allows character censoring", {
   model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -207,6 +222,7 @@ test_that("check_inputs allows character censoring", {
 test_that("check_inputs works with different function types", {
   # Test with anonymous function
   model <- function(x) x + 1
+  attr(model, "parameters") <- c("CL", "V")
   data <- data.frame(time = 1:3, dv = c(1, 2, 3))
   parameters <- list(CL = 1, V = 10)
   omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
@@ -216,5 +232,39 @@ test_that("check_inputs works with different function types", {
 
   # Test with named function
   test_model <- function() {}
+  attr(test_model, "parameters") <- c("CL", "V")
   expect_no_error(check_inputs(test_model, data, parameters, omega, regimen, NULL, "MAP"))
-}) 
+}) 
+
+test_that("check_inputs fails when not all parameters are passed, and warning when too many are passed", {
+  model <- function() {}
+  attr(model, "parameters") <- c("CL", "V")
+  data <- data.frame(time = 1:3, dv = c(1, 2, 3))
+  parameters <- list(CL = 1) # , V = 10)
+  omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
+  regimen <- list(dose = 100, interval = 12)
+
+  # Should not throw any errors with NULL censoring
+  expect_error(
+    check_inputs(model, data, parameters, omega, regimen, NULL, "MAP"),
+    "One or more required parameters for the model have not been specified. Missing: V"
+  )
+
+  parameters <- list(CL = 1, V = 10, V2 = 15, Q = 23)
+  expect_warning(
+    check_inputs(model, data, parameters, omega, regimen, NULL, "MAP"),
+    "Some supplied `parameters` are not supported by the model and will be ignored: V2, Q."
+  )
+})
+
+test_that("check_inputs warns when no parameters are defined as model attribute", {
+  model <- function() {}
+  data <- data.frame(time = 1:3, dv = c(1, 2, 3))
+  parameters <- list(CL = 1) # , V = 10)
+  omega <- matrix(c(0.1, 0, 0, 0.1), nrow = 2)
+  regimen <- list(dose = 100, interval = 12)
+  expect_warning(
+    check_inputs(model, data, parameters, omega, regimen, NULL, "MAP"),
+    "Parameter information for model missing"
+  )
+})

tests/testthat/test-get_map_estimates.R

@@ -210,6 +210,7 @@ test_that("Default MAP fits work and are equal to NONMEM", {
 })
 
 test_that("allow_obs_before_first_dose works", {
+  mod_tdminit <- PKPDsim::new_ode_model("pk_1cmt_iv", parameters = c("CL", "V", "TDM_INIT"))
   data <- data.frame(
     t = c(-0.45, 35.55),
     y = c(21.7, 17.8),
@@ -226,34 +227,15 @@ test_that("allow_obs_before_first_dose works", {
     list(
       CL = 4.5,
       V = 58.4,
-      V2 = 38.4,
-      Q = 6.5,
-      TH_CRCL = 0.8,
-      TH_DIAL_CL = 0.7,
-      TH_DIAL_V = 0.5,
       TDM_INIT = 21.7
     ),
     units = list(
       CL = "L/hr",
-      V = "L/70kg",
-      Q = "L/hr",
-      V2 = "L",
-      CLi = "L/hr",
-      Vi = "L",
-      Qi = "L/hr",
-      V2i = "L"
+      V = "L/70kg"
     )
   )
-  covariates <- list(
-    WT = PKPDsim::new_covariate(value = 67.5, unit = "kg"),
-    SEX = PKPDsim::new_covariate(value = 0),
-    AGE = PKPDsim::new_covariate(value = 55.7, unit = "years"),
-    CR = PKPDsim::new_covariate(value = c(0.67, 0.65), times = c(0, 23.3), unit = "mg_dl"),
-    DIAL = PKPDsim::new_covariate(value = 0),
-    CL_HEMO = PKPDsim::new_covariate(value = 0)
-  )
-  fixed <- c("Q", "TH_CRCL", "TH_DIAL_CL", "TH_DIAL_V", "TDM_INIT")
-  omega <- c(0.1584, 0, 0.6659, 0, 0, 0.326)
+  fixed <- c("TDM_INIT")
+  omega <- c(0.1584, 0, 0.6659)
   error <- list(prop = 0.227, add = 3.4)
   regimen <- structure(
     list(
@@ -274,10 +256,9 @@ test_that("allow_obs_before_first_dose works", {
 
   expect_error(
     get_map_estimates(
-      model = mod,
+      model = mod_tdminit,
       data = data,
       parameters = parameters,
-      covariates = covariates,
       fixed = fixed,
       as_eta = NULL,
       omega = omega,