Refactoring with checkmate and rlang

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(AIC,list)
 S3method(PKNCAconc,data.frame)
 S3method(PKNCAconc,default)
 S3method(PKNCAconc,tbl_df)

NEWS.md

@@ -6,12 +6,36 @@ the dosing including dose amount and route.
 
 # Development version
 
-* Bug fix: `pk.nca()` no longer errors on unsorted concentration-time data.
-  Group-level concentration data are now sorted by time before calculation, so
-  parameters that use the full group (e.g. `aucint.all` and the other `aucint*`
-  parameters) work when the input rows are not in time order (#568).
-
-* Business functions (used for calculations of means, etc.) now return NA_real_
+* Migrated input validation across the package from base R checks
+  (`stopifnot()`, `is.character()`, `is.numeric()`, etc.) to `checkmate`
+  assertions, and standardized error/warning signaling on classed
+  `rlang::abort()`/`rlang::warn()` conditions (e.g. `pknca_error_*`,
+  `pknca_warning_*`) instead of unclassed base `stop()`/`warning()`. This
+  makes failure modes catchable by class rather than by matching message
+  text. As a side effect, some validations became stricter (rejecting
+  previously-accepted edge cases like non-finite numbers); see
+  the entries below for specifics.
+
+* Fixed a regression in `pk_nca_result_to_df()` where warnings raised during
+  interval calculations (e.g. `pknca_warning_no_intervals`,
+  `pknca_warning_no_conc_data`) were passed to `rlang::warn()` as the raw
+  condition object instead of its message text, and lost their original
+  class in the process. This caused `pk.nca()` to error (`message must be a
+  character vector`) instead of warning, and would have broken any code
+  catching a specific warning subclass. The condition's message is now
+  extracted via `conditionMessage()`, and its original class is preserved
+  alongside the new `pknca_warning_parameter_calculation` class.
+
+* `pk.calc.aucabove()` now requires `conc_above` to be finite. Previously,
+  `Inf` or `-Inf` were silently accepted and produced a degenerate result
+  (AUC of 0 for all profiles, since `conc - Inf` is always `-Inf`). Passing
+  a non-finite `conc_above` now raises an error instead.
+
+* `get_impute_method()` now requires `impute` to be an atomic scalar (via
+  `checkmate::assert_scalar()`). Previously, a bare `length(impute) == 1`
+  check meant a length-1 list (e.g. `list("start_conc0")`) could pass through,
+  relying on `%in%`'s implicit list coercion downstream instead of failing
+  clearly. Passing a list now raises an error instead.* Business functions (used for calculations of means, etc.) now return NA_real_
   for empty inputs rather than giving an error (#559).
 
 * `PKNCAconc()` gains an `lloq` argument (a column name or a numeric scalar) that
@@ -49,9 +73,7 @@ the dosing including dose amount and route.
 * When `out_format = "cdisc"` and any parameter has "INT" in its PPTESTCD,
   PPSTINT and PPENINT columns are added with ISO 8601 durations relative to
   the last dose time.  The time unit is taken from `timeu_pref` or `timeu`
-  (#403)
-
-## Bug Fixes
+  (#403)## Bug Fixes
 
 * `normalize.data.frame()` no longer triggers a dplyr deprecation warning
   (`Using 'by = character()' to perform a cross join was deprecated in dplyr 1.1.0`)

R/001-add.interval.col.R

@@ -4,28 +4,86 @@ assign("options", NULL, envir=.PKNCAEnv)
 assign("summary", list(), envir=.PKNCAEnv)
 assign("interval.cols", list(), envir=.PKNCAEnv)
 
+# Validate a CDISC pptestcd/pptest argument: must be a character string, or a
+# named list with a "route" element containing a named list of
+# route-specific values (e.g. list(route = list(extravascular = ...))).
+# Not exported -- internal helper shared by add.interval.col().
+#' @param x The CDISC argument value to validate.
+#' @param arg_name The argument name used in error messages.
+#'
+#' @keywords internal
+#' @noRd
+validate_cdisc_arg <- function(x, arg_name) {
+  if (is.character(x)) {
+    if (length(x) != 1 || is.na(x)) {
+      rlang::abort(
+        message = sprintf(
+          "`%s`, when a character string, must be length 1 and non-missing",
+          arg_name
+        ),
+        class = sprintf("pknca_error_%s_character_invalid", arg_name)
+      )
+    }
+  } else if (is.list(x)) {
+    if (length(x) != 1 ||
+        !identical(names(x), "route") ||
+        !is.list(x$route) ||
+        is.null(names(x$route)) ||
+        any(names(x$route) == "") ||
+        anyNA(names(x$route))) {
+      rlang::abort(
+        message = sprintf(
+          paste0(
+            "`%s`, when a list, must have exactly one named element, \"route\", ",
+            "whose value is itself a named list mapping route to value."
+          ),
+          arg_name
+        ),
+        class = sprintf("pknca_error_%s_route_mapping_invalid", arg_name)
+      )
+    }
+  } else {
+    rlang::abort(
+      message = sprintf(
+        "`%s` must be a character string or a list",
+        arg_name
+      ),
+      class = sprintf("pknca_error_%s_invalid_type", arg_name)
+    )
+  }
+}
+
 #' Add columns for calculations within PKNCA intervals
 #'
-#' @param name The column name as a character string
+#' @param name The column name as a non-empty character string (length 1,
+#'   may not be `NA` or `""`).
 #' @param FUN The function to run (as a character string) or `NA` if the
 #'   parameter is automatically calculated when calculating another parameter.
-#' @param values Valid values for the column
+#' @param values Valid values for the column: either a function used to
+#'   coerce/validate values (e.g. `as.numeric`) or a vector of allowed values
+#'   (e.g. `c(FALSE, TRUE)`).
+#' @param unit_type The type of units to use for assigning and converting
+#'   units. Must be one of the pre-defined unit types (see Details). This
+#'   argument is required and has no default; omitting it raises an error.
+#' @param pretty_name The name of the parameter to use for printing in summary
+#'   tables with units.  (If an analysis does not include units, then the normal
+#'   name is used.)
 #' @param depends Character vector of columns that must be run before this
 #'   column.
 #' @param desc A human-readable description of the parameter (<=40 characters to
 #'   comply with SDTM)
 #' @param sparse Is the calculation for sparse PK?
-#' @param unit_type The type of units to use for assigning and converting units.
-#' @param pretty_name The name of the parameter to use for printing in summary
-#'   tables with units.  (If an analysis does not include units, then the normal
-#'   name is used.)
 #' @param formalsmap A named list mapping parameter names in the function call
 #'   to NCA parameter names.  See the details for information on use of
 #'   `formalsmap`.
-#' @param datatype The type of data used for the calculation
+#' @param datatype The data type used for the calculation. The default is
+#'   `"interval"`, which is currently the only supported value. The
+#'   `"individual"` and `"population"` data types are reserved for future
+#'   use and will currently raise an error if selected.
 #' @param pptestcd_cdisc The CDISC PPTESTCD code for this parameter.  Can be a
 #'   character string for simple mappings, or a named list for route-dependent
-#'   mappings (e.g., `list(route = list(extravascular = "CLF/FO", intravascular
+#'   mappings with a `route` element whose value is itself a named list keyed
+#'   by route (e.g. `list(route = list(extravascular = "CLF/FO", intravascular
 #'   = "CLO"))`).  Defaults to `name` if not provided.
 #' @param pptest_cdisc The CDISC PPTEST name for this parameter.  Can be a
 #'   character string or a named list (same structure as `pptestcd_cdisc`).
@@ -96,27 +154,28 @@ add.interval.col <- function(name,
                              sparse=FALSE,
                              formalsmap=list(),
                              datatype=c("interval",
-                               "individual",
-                               "population"),
+                                        "individual",
+                                        "population"),
                              pptestcd_cdisc=NULL,
                              pptest_cdisc=NULL) {
   # Check inputs
-  if (!is.character(name)) {
-    stop("name must be a character string")
-  } else if (length(name) != 1) {
-    stop("name must have length == 1")
-  }
-  if (length(FUN) != 1) {
-    stop("FUN must have length == 1")
-  } else if (!(is.character(FUN) || is.na(FUN))) {
-    stop("FUN must be a character string or NA")
-  }
-  if (!is.null(depends)) {
-    if (!is.character(depends)) {
-      stop("'depends' must be NULL or a character vector")
-    }
+  checkmate::assert_character(x = name, len = 1, min.chars = 1, any.missing = FALSE)
+  checkmate::assert_character(x = FUN, len = 1, any.missing = TRUE) # allows NA
+  checkmate::assert_logical(x = sparse, len = 1, any.missing=FALSE)
+  checkmate::assert_character(x = pretty_name, len = 1, min.chars = 1, any.missing=FALSE)
+  checkmate::assert_character(x = desc, len = 1, any.missing=FALSE)
+  checkmate::assert_character(x = depends, null.ok = TRUE)  
+
+  # `values` must be either a function (used to validate/coerce) or a vector
+  # of allowed values -- both are acceptable, so just ensure it was supplied
+  # and is one of those two forms.
+  if (!is.function(values) && !is.vector(values)) {
+    rlang::abort(
+      message = "`values` must be a function or a vector of allowed values",
+      class = "pknca_error_values_invalid"
+    )
   }
-  checkmate::assert_logical(sparse, any.missing=FALSE, len=1)
+
   unit_type <-
     match.arg(
       unit_type,
@@ -132,42 +191,62 @@ add.interval.col <- function(name,
         "clearance", "renal_clearance", "renal_clearance_dosenorm"
       )
     )
-  stopifnot("pretty_name must be a scalar"=length(pretty_name) == 1)
-  stopifnot("pretty_name must be a character"=is.character(pretty_name))
-  stopifnot("pretty_name must not be an empty string"=nchar(pretty_name) > 0)
+
+  # Validate datatype (only "interval" is currently supported)
   datatype <- match.arg(datatype)
-  if (!(datatype %in% "interval")) {
-    stop("Only the 'interval' datatype is currently supported.")
-  }
-  if (length(desc) != 1) {
-    stop("desc must have length == 1")
-  } else if (!is.character(desc)) {
-    stop("desc must be a character string")
-  }
-  if (!is.list(formalsmap)) {
-    stop("formalsmap must be a list")
-  } else if (length(formalsmap) > 0 &&
-             is.null(names(formalsmap))) {
-    stop("formalsmap must be a named list")
-  } else if (length(formalsmap) > 0 &&
-             is.na(FUN)) {
-    stop("formalsmap may not be given when FUN is NA.")
-  } else if (!all(nchar(names(formalsmap)) > 0)) {
-    stop("All formalsmap elements must be named")
+  checkmate::assert_choice(x = datatype, choices = "interval")
+
+  # Validate formalsmap
+  checkmate::assert_list(
+    x = formalsmap,
+    names = if (length(formalsmap) > 0) "unique" else NULL
+  )
+
+  # Validate formalsmap and function compatibility
+  if (length(formalsmap) > 0) {
+    # Ensure FUN exists
+    if (is.na(FUN)) {
+      rlang::abort(
+        message = "`formalsmap` may not be provided when `FUN` is NA",
+        class = "pknca_error_formalsmap_with_na_fun"
+      )
+    }
+    # Ensure formalsmap names are unique
+    checkmate::assert_character(x = names(formalsmap), min.chars = 1, any.missing = FALSE)
   }
+
   # Ensure that the function exists
-  if (!is.na(FUN) &&
-      length(utils::getAnywhere(FUN)$objs) == 0) {
-    stop("The function named '", FUN, "' is not defined.  Please define the function before calling add.interval.col.")
-  }
-  if (!is.na(FUN) &&
-      length(formalsmap) > 0) {
-    # Ensure that the formalsmap parameters are all in the list of
-    # formal arguments to the function.
-    if (!all(names(formalsmap) %in% names(formals(utils::getAnywhere(FUN)$objs[[1]])))) {
-      stop("All names for the formalsmap list must be arguments to the function.")
+  if (!is.na(FUN)) {
+    # Ensure that the function exists
+    fun_obj <- utils::getAnywhere(FUN)
+    if (length(fun_obj$objs) == 0) {
+      rlang::abort(
+        message = sprintf(
+          "The function named '%s' is not defined. Please define it before calling add.interval.col().",
+          FUN
+        ),
+        class = "pknca_error_fun_not_found"
+      ) 
+    }
+
+    # Validate formalsmap parameters match function formals
+    if (length(formalsmap) > 0) {
+      fun_formals <- names(formals(fun_obj$objs[[1]]))
+      invalid_formals <- setdiff(names(formalsmap), fun_formals)
+      if (length(invalid_formals) > 0) {
+        rlang::abort(
+          message = sprintf(
+            "All names in `formalsmap` must be arguments to the function '%s'. Invalid names: %s",
+            FUN,
+            paste(dQuote(invalid_formals), collapse = ", ")
+          ),
+          class = "pknca_error_formalsmap_invalid_names"
+        )
+      }
     }
+
   }
+
   # Default CDISC mappings to name/desc when not provided
   if (is.null(pptestcd_cdisc)) {
     pptestcd_cdisc <- name
@@ -177,12 +256,9 @@ add.interval.col <- function(name,
   }
   # Validate CDISC arguments: must be a character string or a named list
   # with a "route" element containing named sub-elements
-  if (!is.character(pptestcd_cdisc) && !is.list(pptestcd_cdisc)) {
-    stop("pptestcd_cdisc must be a character string or a list")
-  }
-  if (!is.character(pptest_cdisc) && !is.list(pptest_cdisc)) {
-    stop("pptest_cdisc must be a character string or a list")
-  }
+  validate_cdisc_arg(pptestcd_cdisc, "pptestcd_cdisc")
+  validate_cdisc_arg(pptest_cdisc, "pptest_cdisc")
+
   current <- get("interval.cols", envir=.PKNCAEnv)
   current[[name]] <-
     list(
@@ -216,7 +292,7 @@ sort_interval_cols <- function() {
   myorder <- rep(NA, length(current))
   names(myorder) <- names(current)
   nextnum <- 1
-  while (any(is.na(myorder))) {
+  while (anyNA(myorder)) {
     for (nextorder in seq_along(myorder)[is.na(myorder)]) {
       if (length(current[[nextorder]]$depends) == 0) {
         # If it doesn't depend on anything then it can go next in order.
@@ -227,14 +303,20 @@ sort_interval_cols <- function() {
         deps <- unique(unlist(current[[nextorder]]$depends))
         missing_deps <- deps[!(deps %in% names(myorder))]
         if (length(missing_deps) > 0) {
-          stop(
-            "Invalid dependencies for interval column (please report this as a bug): ",
-            names(myorder)[nextorder],
-            " The following dependencies are missing: ",
-            paste(missing_deps, collapse=", ")
+          rlang::abort(
+            message = sprintf(
+              paste0(
+                "Invalid dependencies for interval column ",
+                "(please report this as a bug): %s ",
+                "The following dependencies are missing: %s"
+              ),
+              names(myorder)[nextorder],
+              paste(missing_deps, collapse = ", ")
+            ),
+            class = "pknca_error_invalid_dependency"
           )
         }
-        if (!any(is.na(myorder[deps]))) {
+        if (!anyNA(myorder[deps])) {
           myorder[nextorder] <- nextnum
           nextnum <- nextnum + 1
         }

R/002-pk.business.rules.R

@@ -53,7 +53,7 @@ pk.business <- function(FUN,
 geomean <- function(x, na.rm=FALSE) {
   if (na.rm)
     x <- stats::na.omit(x)
-  if (any(is.na(x))) {
+  if (anyNA(x)) {
     NA_real_
   } else if (any(x == 0)) {
     0