diff --git a/NEWS.md b/NEWS.md index ec1d0d80..7b375922 100644 --- a/NEWS.md +++ b/NEWS.md @@ -11,6 +11,35 @@ the dosing including dose amount and route. 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). +* 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. + +* `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. + +* `add.interval.col()` now validates the structure of `pptestcd_cdisc` and + `pptest_cdisc` rather than only checking that they are a character string or + a list. A character value must be length 1 and non-missing, and a list must + have exactly one element named `route` whose value is a named list. Values + that were previously accepted and would have produced incorrect CDISC output + (for example a multi-element character vector, or a list named something + other than `route`) now raise an error. + * Business functions (used for calculations of means, etc.) now return NA_real_ for empty inputs rather than giving an error (#559). @@ -82,6 +111,16 @@ the dosing including dose amount and route. ## Breaking changes +* The pre-existing `pknca_*` condition classes were renamed to carry an explicit + `error`/`warning`/`message` element, so code that catches them by class must be + updated. For example, `pknca_conc_none` is now `pknca_warning_no_concentration`, + `pknca_no_intervals` is now `pknca_warning_no_intervals`, and + `pknca_all_warnings_no_results` is now `pknca_warning_no_results`. One change + goes beyond renaming: the two classes `pknca_sparse_auclast_change_auclast` and + `pknca_sparse_aumclast_change_auc_type` were merged into the single class + `pknca_error_auc_last_type_override`, so they can no longer be caught + separately. + * `pknca_units_table()` called on a `PKNCAdata` object now raises an error if unit columns within the same concentration group contain mixed values (e.g., two different `concu` strings for the same subject group). Previously, `NA` diff --git a/R/001-add.interval.col.R b/R/001-add.interval.col.R index fe59f2bd..bb0de4da 100644 --- a/R/001-add.interval.col.R +++ b/R/001-add.interval.col.R @@ -4,28 +4,81 @@ 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 (!checkmate::test_string(x, na.ok = FALSE)) { + rlang::abort( + sprintf( + "`%s`, when a character string, must be length 1 and non-missing", + arg_name + ), + class = "pknca_error_cdisc_character_invalid" + ) + } + } else if (is.list(x)) { + # `identical(names(x), "route")` also confirms that x has length 1 + if (!identical(names(x), "route") || + !is.list(x$route) || + !checkmate::test_names(names(x$route), type = "named")) { + rlang::abort( + sprintf( + "`%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 = "pknca_error_cdisc_route_mapping_invalid" + ) + } + } else { + rlang::abort( + sprintf( + "`%s` must be a character string or a list", + arg_name + ), + class = "pknca_error_cdisc_invalid_type" + ) + } +} + #' 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 +149,25 @@ 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("`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 +183,56 @@ 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 = "unique") + + # Validate formalsmap and function compatibility + if (length(formalsmap) > 0) { + # Ensure FUN exists + if (is.na(FUN)) { + rlang::abort("`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( + 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( + 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 +242,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 +278,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 +289,16 @@ 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( + sprintf( + "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 } diff --git a/R/002-pk.business.rules.R b/R/002-pk.business.rules.R index 8925ed80..39560919 100644 --- a/R/002-pk.business.rules.R +++ b/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 diff --git a/R/AIC.list.R b/R/AIC.list.R index cbb39f62..1f9ebda9 100644 --- a/R/AIC.list.R +++ b/R/AIC.list.R @@ -25,7 +25,7 @@ AIC.list <- function(object, ..., assess.best=TRUE) { if ("indentation" %in% names(ret)) { ret$indentation <- ret$indentation + 1 } else { - stop("Unknown way to get a data.frame without indentation set. This is likely a bug.") # nocov + rlang::abort("Unknown way to get a data.frame without indentation set. This is likely a bug.", class = "pknca_error_internal_unknown_dataframe_indentation") # nocov } } } diff --git a/R/PKNCA.options.R b/R/PKNCA.options.R index 24bb3f02..edd6a012 100644 --- a/R/PKNCA.options.R +++ b/R/PKNCA.options.R @@ -9,16 +9,17 @@ "data points to be preferred in the calculation of half-life.")) if (default) return(0.0001) - if (length(x) != 1) - stop("adj.r.squared.factor must be a scalar") - if (is.factor(x) || - !is.numeric(x)) - stop("adj.r.squared.factor must be numeric (and not a factor)") - # Must be between 0 and 1, exclusive - if (x <= 0 || x >= 1) - stop("adj.r.squared.factor must be between 0 and 1, exclusive") - if (x > 0.01) - warning("adj.r.squared.factor is usually <0.01") + checkmate::assert_number(x, .var.name = "adj.r.squared.factor") + if (x <= 0 || x >= 1) { + rlang::abort( + "adj.r.squared.factor must be between 0 and 1, exclusive", + class = "pknca_error_adj.r.squared.factor_out_of_bounds" + ) + } + + if (x > 0.01) { + rlang::warn("adj.r.squared.factor is usually <0.01", class = "pknca_warning_adj_r2_factor_large") + } x }, max.missing=function(x, default=FALSE, description=FALSE) { @@ -28,15 +29,13 @@ "calculate summary statistics with the business.* functions.")) if (default) return(0.5) - if (length(x) != 1) - stop("max.missing must be a scalar") - if (is.factor(x) || !is.numeric(x)) - stop("max.missing must be numeric (and not a factor)") - # Must be between 0 and 1, inclusive - if (x < 0 || x >= 1) - stop("max.missing must be between 0 and 1") - if (x > 0.5) - warning("max.missing is usually <= 0.5") + checkmate::assert_number(x, .var.name = "max.missing") + if (x < 0 || x >= 1) { + rlang::abort("max.missing must be between 0 and 1", class = "pknca_error_max.missing_out_of_bounds") + } + if (x > 0.5) { + rlang::warn("max.missing is usually <= 0.5", class = "pknca_warning_max_missing_large") + } x }, auc.method=function(x, default=FALSE, description=FALSE) { @@ -58,22 +57,23 @@ "help for 'clean.conc.na' for how to use this option.")) if (default) return("drop") - if (is.na(x)) - stop("conc.na must not be NA") + if (is.na(x)) { + rlang::abort("conc.na must not be NA", class = "pknca_error_conc_na_is_na") + } if (is.factor(x)) { - warning("conc.na may not be a factor; attempting conversion") + rlang::warn("conc.na may not be a factor; attempting conversion", class = "pknca_warning_conc_na_factor") x <- as.character(x) } if (tolower(x) %in% "drop") { x <- tolower(x) } else if (is.numeric(x)) { if (is.infinite(x)) { - stop("When a number, conc.na must be finite") + rlang::abort("When a number, conc.na must be finite", class = "pknca_error_conc_na_infinite") } else if (x < 0) { - warning("conc.na is usually not < 0") + rlang::warn("conc.na is usually not < 0", class = "pknca_warning_conc_na_negative") } } else { - stop("conc.na must either be a finite number or the text 'drop'") + rlang::abort("conc.na must either be a finite number or the text 'drop'", class = "pknca_error_conc_na_invalid") } x }, @@ -88,24 +88,24 @@ middle="drop", last="keep")) check.element <- function(x) { - if (length(x) != 1) - stop("conc.blq must be a scalar") - if (is.na(x)) - stop("conc.blq must not be NA") + checkmate::assert_scalar(x, na.ok = FALSE) if (is.factor(x)) { - warning("conc.blq may not be a factor; attempting conversion") + rlang::warn("conc.blq may not be a factor; attempting conversion", class = "pknca_warning_conc_blq_factor") x <- as.character(x) } if (tolower(x) %in% c("drop", "keep")) { x <- tolower(x) } else if (is.numeric(x)) { if (is.infinite(x)) { - stop("When a number, conc.blq must be finite") + rlang::abort("When a number, conc.blq must be finite", class = "pknca_error_conc_blq_infinite") } else if (x < 0) { - warning("conc.blq is usually not < 0") + rlang::warn("conc.blq is usually not < 0", class = "pknca_warning_conc_blq_negative") } } else { - stop("conc.blq must either be a finite number or the text 'drop' or 'keep'") + rlang::abort( + "conc.blq must either be a finite number or the text 'drop' or 'keep'", + class = "pknca_error_conc_blq_invalid" + ) } x } @@ -117,15 +117,27 @@ extra.names <- setdiff(names(x), c(tfirst_names, tmax_names)) missing.names <- if (any(names(x) %in% tfirst_names)) setdiff(tfirst_names, names(x)) else setdiff(tmax_names, names(x)) duplicated.names <- names(x)[duplicated(names(x))] - if (are.names.mixed) - stop("When given as a list, prevent mixing arguments of different BLQ strategies. - Either define 'first', 'middle' and 'last' or 'before.tmax' and 'after.tmax'.") + if (are.names.mixed) { + rlang::abort( + "When given as a list, prevent mixing arguments of different BLQ strategies.\n Either define 'first', 'middle' and 'last' or 'before.tmax' and 'after.tmax'.", + class = "pknca_error_conc_blq_mixed_names" + ) + } if (length(extra.names) != 0) - stop("When given as a list, conc.blq must only have elements named 'first', 'middle' and 'last' or 'before.tmax' and 'after.tmax'.") + rlang::abort( + "When given as a list, conc.blq must only have elements named 'first', 'middle' and 'last' or 'before.tmax' and 'after.tmax'.", + class = "pknca_error_conc_blq_extra_names" + ) if (length(missing.names) != 0) - stop("When given as a list, conc.blq must include all elements named 'first', 'middle' and 'last' or 'before.tmax' and 'after.tmax'.") + rlang::abort( + "When given as a list, conc.blq must include all elements named 'first', 'middle' and 'last' or 'before.tmax' and 'after.tmax'.", + class = "pknca_error_conc_blq_missing_names" + ) if (length(duplicated.names) != 0) - stop("When given as a list, conc.blq should not have duplicated names") + rlang::abort( + "When given as a list, conc.blq should not have duplicated names", + class = "pknca_error_conc_blq_duplicated_names" + ) # After the names are confirmed, confirm each value. x <- lapply(x, check.element) } else { @@ -151,16 +163,18 @@ )) if (default) return(TRUE) - if (length(x) != 1) - stop("first.tmax must be a scalar") - if (is.na(x)) - stop("first.tmax may not be NA") + + checkmate::assert_scalar(x, na.ok = FALSE, .var.name = "first.tmax") + if (!is.logical(x)) { x <- as.logical(x) if (is.na(x)) { - stop("Could not convert first.tmax to a logical value") + rlang::abort("Could not convert first.tmax to a logical value", class = "pknca_error_first_tmax_not_logical") } else { - warning("Converting first.tmax to a logical value: ", x) + rlang::warn( + sprintf("Converting first.tmax to a logical value: %s", x), + class = "pknca_warning_first_tmax_converted" + ) } } x @@ -174,16 +188,16 @@ )) if (default) return(TRUE) - if (length(x) != 1) - stop("first.tmin must be a scalar") - if (is.na(x)) - stop("first.tmin may not be NA") + checkmate::assert_scalar(x, na.ok = FALSE, .var.name = "first.tmin") if (!is.logical(x)) { x <- as.logical(x) if (is.na(x)) { - stop("Could not convert first.tmin to a logical value") + rlang::abort("Could not convert first.tmin to a logical value", class = "pknca_error_first_tmin_not_logical") } else { - warning("Converting first.tmin to a logical value: ", x) + rlang::warn( + sprintf("Converting first.tmin to a logical value: %s", x), + class = "pknca_warning_first_tmin_converted" + ) } } x @@ -195,16 +209,19 @@ "half-life calculation? 'TRUE' is yes and 'FALSE' is no.")) if (default) return(FALSE) - if (length(x) != 1) - stop("allow.tmax.in.half.life must be a scalar") - if (is.na(x)) - stop("allow.tmax.in.half.life may not be NA") + checkmate::assert_scalar(x, na.ok = FALSE, .var.name = "allow.tmax.in.half.life") if (!is.logical(x)) { x <- as.logical(x) if (is.na(x)) { - stop("Could not convert allow.tmax.in.half.life to a logical value") + rlang::abort( + "Could not convert allow.tmax.in.half.life to a logical value", + class = "pknca_error_allow_tmax_hl_not_logical" + ) } else { - warning("Converting allow.tmax.in.half.life to a logical value: ", x) + rlang::warn( + sprintf("Converting allow.tmax.in.half.life to a logical value: %s", x), + class = "pknca_warning_allow_tmax_hl_converted" + ) } } x @@ -224,17 +241,14 @@ return("What is the minimum number of points required to calculate half-life?") if (default) return(3) - if (length(x) != 1) - stop("min.hl.points must be a scalar") - if (is.factor(x)) - stop("min.hl.points cannot be a factor") - if (!is.numeric(x)) - stop("min.hl.points must be a number") - if (x < 2) - stop("min.hl.points must be >=2") + checkmate::assert_number(x, lower = 2, na.ok = FALSE, .var.name = "min.hl.points") + if (min(x %% 1, 1 - (x %% 1)) > 100*.Machine$double.eps) { - warning("Non-integer given for min.hl.points; rounding to nearest integer") + rlang::warn( + "Non-integer given for min.hl.points; rounding to nearest integer", + class = "pknca_warning_min_hl_points_noninteger" + ) x <- round(x) } x @@ -244,16 +258,11 @@ return("What is the minimum span ratio required to consider a half-life valid?") if (default) return(2) - if (length(x) != 1) - stop("min.span.ratio must be a scalar") - if (is.factor(x)) - stop("min.span.ratio cannot be a factor") - if (!is.numeric(x)) - stop("min.span.ratio must be a number") + checkmate::assert_number(x, na.ok = FALSE, .var.name = "min.span.ratio") if (x <= 0) - stop("min.span.ratio must be > 0") + rlang::abort("min.span.ratio must be > 0", class = "pknca_error_min_span_ratio_range") if (x < 2) - warning("min.span.ratio is usually >= 2") + rlang::warn("min.span.ratio is usually >= 2", class = "pknca_warning_min_span_ratio_small") x }, max.aucinf.pext=function(x, default=FALSE, description=FALSE) { @@ -261,18 +270,19 @@ return("What is the maximum percent extrapolation to consider an AUCinf valid?") if (default) return(20) - if (length(x) != 1) - stop("max.aucinf.pext must be a scalar") - if (is.factor(x)) - stop("max.aucinf.pext cannot be a factor") - if (!is.numeric(x)) - stop("max.aucinf.pext must be a number") - if (x <= 0) - stop("max.aucinf.pext must be > 0") - if (x > 25) - warning("max.aucinf.pext is usually <=25") - if (x < 1) - warning("max.aucinf.pext is on the percent not ratio scale, value given is <1%") + checkmate::assert_number(x, na.ok = FALSE, .var.name = "max.aucinf.pext") + if (x <= 0) { + rlang::abort("max.aucinf.pext must be > 0", class = "pknca_error_max_aucinf_pext_range") + } + if (x > 25) { + rlang::warn("max.aucinf.pext is usually <=25", class = "pknca_warning_max_aucinf_pext_large") + } + if (x < 1) { + rlang::warn( + "max.aucinf.pext is on the percent not ratio scale, value given is <1%", + class = "pknca_warning_max_aucinf_pext_small" + ) + } x }, min.hl.r.squared=function(x, default=FALSE, description=FALSE) { @@ -280,16 +290,14 @@ return("What is the minimum r-squared value to consider a half-life calculation valid?") if (default) return(0.9) - if (length(x) != 1) - stop("min.hl.r.squared must be a scalar") - if (is.factor(x)) - stop("min.hl.r.squared cannot be a factor") - if (!is.numeric(x)) - stop("min.hl.r.squared must be a number") - if (x <= 0 || x >= 1) - stop("min.hl.r.squared must be between 0 and 1, exclusive") - if (x < 0.9) - warning("min.hl.r.squared is usually >= 0.9") + checkmate::assert_number(x, .var.name = "min.hl.r.squared") + if (x <= 0 || x >= 1) { + rlang::abort("min.hl.r.squared must be between 0 and 1, exclusive", class = "pknca_error_min_hl_r2_out_of_bounds") + } + + if (x < 0.9) { + rlang::warn("min.hl.r.squared is usually >= 0.9", class = "pknca_warning_min_hl_r2_small") + } x }, @@ -312,17 +320,19 @@ "interval.")) if (default) return(NA) - if (is.factor(x)) - stop("tau.choices cannot be a factor") - if (length(x) > 1 && any(is.na(x))) - stop("tau.choices may not include NA and be a vector") - if (!identical(x, NA)) - if (!is.numeric(x)) - stop("tau.choices must be a number") + # NA mixed into a numeric vector is not allowed + if (length(x) > 1 && anyNA(x)) { + rlang::abort("tau.choices may not include NA and be a vector", class = "pknca_error_tau_choices_na_in_vector") + } + + # Only validate non-NA cases + if (!identical(x, NA)) { + checkmate::assert_numeric(x, .var.name = "tau.choices") if (!is.vector(x)) { - warning("tau.choices must be a vector, converting") + rlang::warn("tau.choices must be a vector, converting", class = "pknca_warning_tau_choices_not_vector") x <- as.vector(x) } + } x }, single.dose.aucs=function(x, default=FALSE, description=FALSE) { @@ -362,10 +372,7 @@ )) if (default) return(choices[1]) - if (length(x) != 1) - stop("hl_method must be a scalar") - if (!is.character(x)) - stop("hl_method must be a character string") + checkmate::assert_string(x, .var.name = "hl_method") x <- match.arg(x, choices) x }, @@ -380,12 +387,8 @@ "uses the raw Tobit residual with no point-count penalty.")) if (default) return(0) - if (length(x) != 1) - stop("tobit_n_points_penalty must be a scalar") - if (is.factor(x) || !is.numeric(x)) - stop("tobit_n_points_penalty must be numeric (and not a factor)") - if (x < 0) - stop("tobit_n_points_penalty must be >= 0") + checkmate::assert_number(x, lower = 0, na.ok = FALSE, .var.name = "tobit_n_points_penalty" + ) x }, @@ -396,8 +399,7 @@ "Tobit regression half-life. See ?stats::optim for available options.")) if (default) return(list()) - if (!is.list(x)) - stop("tobit_optim_control must be a list") + checkmate::assert_list(x, .var.name = "tobit_optim_control") x } ) @@ -456,21 +458,29 @@ PKNCA.options <- function(..., default=FALSE, check=FALSE, name, value) { # like another argument. if (missing(name)) { if (!missing(value)) - stop("Cannot have a value without a name") + rlang::abort("Cannot have a value without a name", class = "pknca_error_value_without_name") } else { if (name %in% names(args)) - stop("Cannot give an option name both with the name argument and as a named argument.") + rlang::abort( + "Cannot give an option name both with the name argument and as a named argument.", + class = "pknca_error_duplicate_option_name" + ) if (!missing(value)) { args[[name]] <- value } else { args <- append(args, name) } } - if (default && check) - stop("Cannot request both default and check") + if (default && check) { + rlang::abort("Cannot request both default and check", class = "pknca_error_default_and_check") + } + if (default) { if (length(args) > 0) - stop("Cannot set default and set new options at the same time.") + rlang::abort( + "Cannot set default and set new options at the same time.", + class = "pknca_error_default_with_options" + ) # Extract all the default values defaults <- lapply(.PKNCA.option.check, FUN=function(x) x(default=TRUE)) @@ -478,19 +488,28 @@ PKNCA.options <- function(..., default=FALSE, check=FALSE, name, value) { assign("options", defaults, envir=.PKNCAEnv) } else if (check) { # Check an option for accuracy, but don't set it - if (length(args) != 1) - stop("Must give exactly one option to check") + if (length(args) != 1) { + rlang::abort("Must give exactly one option to check", class = "pknca_error_check_not_scalar") + } n <- names(args) - if (!(n %in% names(.PKNCA.option.check))) - stop(paste("Invalid setting for PKNCA:", n)) + if (!(n %in% names(.PKNCA.option.check))) { + rlang::abort(sprintf("Invalid setting for PKNCA: %s", n), class = "pknca_error_invalid_option_check") + } # Verify the option, and return the sanitized version return(.PKNCA.option.check[[n]](args[[n]])) } else if (length(args) > 0) { if (is.null(names(args))) { # Confirm that the settings exist - if (length(bad.args <- setdiff(unlist(args), names(current))) > 0) - stop(sprintf("PKNCA.options does not have value(s) for %s.", - paste(bad.args, collapse=", "))) + bad.args <- setdiff(unlist(args), names(current)) + if (length(bad.args) > 0) { + rlang::abort( + sprintf( + "PKNCA.options does not have value(s) for %s.", + paste(bad.args, collapse = ", ") + ), + class = "pknca_error_unknown_options" + ) + } # Get the setting(s) if (length(args) == 1) { ret <- current[[args[[1]]]] @@ -505,8 +524,9 @@ PKNCA.options <- function(..., default=FALSE, check=FALSE, name, value) { # Set a value # Verify values are viable and then set them. for (n in names(args)) { - if (!(n %in% names(.PKNCA.option.check))) - stop(paste("Invalid setting for PKNCA:", n)) + if (!(n %in% names(.PKNCA.option.check))) { + rlang::abort(sprintf("Invalid setting for PKNCA: %s", n), class = "pknca_error_invalid_option_set") + } # Verify and set the option value current[[n]] <- .PKNCA.option.check[[n]](args[[n]]) } @@ -586,7 +606,10 @@ PKNCA.options.describe <- function(name) { PKNCA.set.summary <- function(name, description, point, spread, rounding=list(signif=3), reset=FALSE) { if (reset) { - warning("`reset = TRUE` is not intended for general use, summary() may not work after resetting summary instructions") + rlang::warn( + "`reset = TRUE` is not intended for general use, summary() may not work after resetting summary instructions", + class = "pknca_warning_summary_reset" + ) current <- list() } else { current <- get("summary", envir=.PKNCAEnv) @@ -598,45 +621,44 @@ PKNCA.set.summary <- function(name, description, point, spread, } # Confirm that the name exists if (!all(found_names <- name %in% names(get("interval.cols", envir=.PKNCAEnv)))) { - stop(paste("You must first define the parameter name with add.interval.col. Parameters not yet defined are:", - paste(name[!found_names], collapse=", "))) + rlang::abort( + sprintf( + "You must first define the parameter name with add.interval.col. Parameters not yet defined are: %s", + paste(name[!found_names], collapse = ", ") + ), + class = "pknca_error_undefined_parameter" + ) } # Reset all names to prep for settings below for (current_name in name) { current[[current_name]] <- list() } # Confirm that description is a scalar character string - if (!is.character(description)) { - stop("`description` must be a character string.") - } else if (length(description) != 1) { - stop("`description` must be a scalar.") - } + checkmate::assert_string(description) for (current_name in name) { current[[current_name]]$description <- description } # Confirm that point is a function - if (!is.function(point)) { - stop("`point` must be a function") - } + checkmate::assert_function(point) for (current_name in name) { current[[current_name]]$point <- point } # Confirm that spread is a function (if given) if (!missing(spread)) { - if (!is.function(spread)) { - stop("spread must be a function") - } + checkmate::assert_function(spread) for (current_name in name) { current[[current_name]]$spread <- spread } } # Confirm that rounding is either a single-entry list or a function if (is.list(rounding)) { - if (length(rounding) != 1) { - stop("rounding must have a single value in the list") - } + checkmate::assert_list(rounding, len = 1) + if (!(names(rounding) %in% c("signif", "round"))) { - stop("When a list, rounding must have a name of either 'signif' or 'round'") + rlang::abort( + "When a list, rounding must have a name of either 'signif' or 'round'", + class = "pknca_error_rounding_list_name" + ) } for (current_name in name) { current[[current_name]]$rounding <- rounding @@ -646,10 +668,9 @@ PKNCA.set.summary <- function(name, description, point, spread, current[[current_name]]$rounding <- rounding } } else { - stop("rounding must be either a list or a function") + rlang::abort("rounding must be either a list or a function", class = "pknca_error_rounding_invalid") } # Set the summary parameters assign("summary", current, envir=.PKNCAEnv) invisible(current) } - diff --git a/R/assertions.R b/R/assertions.R index 46f79d43..843afd5e 100644 --- a/R/assertions.R +++ b/R/assertions.R @@ -9,10 +9,11 @@ #' @keywords Internal assert_intervaltime_single <- function(interval = NULL, start = NULL, end = NULL) { if (is.null(interval) && is.null(start) && is.null(end)) { - stop("One of `interval` or `start` and `end` must be given") + rlang::abort("One of `interval` or `start` and `end` must be given", class = "pknca_error_missing_interval") } + if (xor(is.null(start), is.null(end))) { - stop("Both `start` and `end` or neither must be given") + rlang::abort("Both `start` and `end` or neither must be given", class = "pknca_error_partial_interval") } if (!is.null(interval)) { checkmate::assert_numeric(x = interval, sorted = TRUE, unique = TRUE, any.missing = FALSE, len = 2) @@ -27,9 +28,23 @@ assert_intervaltime_single <- function(interval = NULL, start = NULL, end = NULL if (is.null(interval)) { interval <- c(start, end) } else if (start != interval[1]) { - stop("`start` must be the same as the first value in the interval if both are given: ", start, "!=", interval[1]) + rlang::abort( + sprintf( + "`start` must be the same as the first value in the interval if both are given: %s!=%s", + start, + interval[1] + ), + class = "pknca_error_interval_start_mismatch" + ) } else if (end != interval[2]) { - stop("`end` must be the same as the second value in the interval if both are given: ", end, "!=", interval[2]) + rlang::abort( + sprintf( + "`end` must be the same as the second value in the interval if both are given: %s!=%s", + end, + interval[2] + ), + class = "pknca_error_interval_end_mismatch" + ) } } @@ -44,20 +59,14 @@ assert_intervaltime_single <- function(interval = NULL, start = NULL, end = NULL #' @rdname assert_conc_time assert_conc <- function(conc, any_missing_conc = TRUE) { if (length(conc) == 0) { - rlang::warn( - message = "No concentration data given", - class = "pknca_conc_none" - ) + rlang::warn("No concentration data given", class = "pknca_warning_no_concentration") } else { checkmate::assert_numeric(conc, finite = TRUE, any.missing = any_missing_conc) if (all(is.na(conc))) { - rlang::warn( - message = "All concentration data are missing", - class = "pknca_conc_all_missing" - ) + rlang::warn("All concentration data are missing", class = "pknca_warning_all_concentration_missing") } else if (any(!is.na(conc) & as.numeric(conc) < 0)) { # as.numeric(conc) is required for compatibility with units - warning("Negative concentrations found") + rlang::warn("Negative concentrations found", class = "pknca_warning_negative_concentration") } } conc @@ -71,10 +80,7 @@ assert_conc <- function(conc, any_missing_conc = TRUE) { #' @rdname assert_conc_time assert_time <- function(time, sorted_time = TRUE) { if (length(time) == 0) { - rlang::warn( - message = "No time data given", - class = "pknca_time_none" - ) + rlang::warn("No time data given", class = "pknca_warning_no_time") } else { checkmate::assert_numeric(time, any.missing = FALSE, sorted = sorted_time, unique = sorted_time) } @@ -139,7 +145,7 @@ assert_numeric_between <- function(x, any.missing = FALSE, null.ok = FALSE, lowe ) } if (length(msg) > 0) { - stop(paste(msg, collapse = "\n")) + rlang::abort(paste(msg, collapse = "\n"), class = "pknca_error_numeric_between") } } x @@ -201,10 +207,10 @@ assert_aucmethod <- function(method = c("lin up/log down", "linear", "lin-log")) #' @returns The object assert_PKNCAdata <- function(object) { if (!inherits(object, "PKNCAdata")) { - stop("Must be a PKNCAdata object") + rlang::abort("Must be a PKNCAdata object", class = "pknca_error_not_PKNCAdata") } if (nrow(object$intervals) == 0) { - warning("No intervals given; no calculations will be done.") + rlang::warn("No intervals given; no calculations will be done.", class = "pknca_warning_no_intervals") } object } @@ -214,7 +220,7 @@ assert_PKNCAdata <- function(object) { #' @export assert_PKNCAresults <- function(object) { if (!inherits(object, "PKNCAresults")) { - stop("Must be a PKNCAresults object") + rlang::abort("Must be a PKNCAresults object", class = "pknca_error_not_pkncaresults") } object } @@ -224,7 +230,7 @@ assert_PKNCAresults <- function(object) { #' @export assert_PKNCAconc <- function(object) { if (!inherits(object, "PKNCAconc")) { - stop("Must be a PKNCAconc object") + rlang::abort("Must be a PKNCAconc object", class = "pknca_error_not_concdata") } object } @@ -234,7 +240,7 @@ assert_PKNCAconc <- function(object) { #' @export assert_PKNCAdose <- function(object) { if (!inherits(object, "PKNCAdose")) { - stop("Must be a PKNCAdose object") + rlang::abort("Must be a PKNCAdose object", class = "pknca_error_not_dosedata") } object } @@ -242,17 +248,10 @@ assert_PKNCAdose <- function(object) { #' @describeIn assert_unit Assert that a column name contains a character string #' (that could be a unit specification) assert_unit_col <- function(unit, data) { - if (length(unit) != 1) { - stop("`unit` must be a single value") - } else if (!is.character(unit)) { - stop("`unit` must be a character string") - } else if (!is.data.frame(data)) { - stop("`data` must be a data.frame") - } else if (!(unit %in% names(data))) { - stop("`unit` (", unit, ") must be a column name in the data") - } else if (!is.character(data[[unit]])) { - stop("`unit` (", unit, ") must contain character data") - } + checkmate::assert_character(unit, len = 1) + checkmate::assert_data_frame(data) + checkmate::assert_names(names(data), must.include = unit) + checkmate::assert_character(data[[unit]]) structure(unit, unit_type = "column") } @@ -265,11 +264,8 @@ assert_unit_value <- function(unit) { return(unit) } - if (length(unit) != 1) { - stop("`unit` must be a single value") - } else if (!is.character(unit)) { - stop("`unit` must be a character string") - } + checkmate::assert_character(unit, len = 1) + structure(unit, unit_type = "value") } @@ -290,6 +286,6 @@ assert_unit <- function(unit, data) { } else { # Re-raise the unit_col error. That is better than unit_value since it is # stricter. - stop(unit_col, call. = FALSE) + rlang::abort(unit_col, class = "pknca_error_invalid_unit") } } diff --git a/R/auc.R b/R/auc.R index f79fc5a9..ac92ba4c 100644 --- a/R/auc.R +++ b/R/auc.R @@ -98,10 +98,15 @@ pk.calc.auxc <- function(conc, time, interval=c(0, Inf), # All the data were missing or 0 before excluding points return(structure(0, exclude="DO NOT EXCLUDE")) } + auc.type <- match.arg(auc.type) interval <- assert_intervaltime_single(interval = interval) + if (auc.type %in% "AUCinf" && is.finite(interval[2])) { - warning("Requesting AUCinf when the end of the interval is not Inf") + rlang::warn( + "Requesting AUCinf when the end of the interval is not Inf", + class = "pknca_warning_aucinf_finite_interval" + ) } # Subset the data to the range of interest #### @@ -114,12 +119,18 @@ pk.calc.auxc <- function(conc, time, interval=c(0, Inf), "Requesting an AUC range starting (%g) before the first measurement (%g) is not allowed", interval_start, min(data$time) ) - rlang::warn(message = warn_message, class = "pknca_warn_auc_before_first") + rlang::warn(message = warn_message, class = "pknca_warning_auc_before_first") return(structure(NA_real_, exclude=warn_message)) } else if (interval_start > max(data$time)) { # Give this as a warning, but allow it to continue - warning(sprintf("AUC start time (%g) is after the maximum observed time (%g)", - interval_start, max(data$time))) + rlang::warn( + sprintf( + "AUC start time (%g) is after the maximum observed time (%g)", + interval_start, + max(data$time) + ), + class = "pknca_warning_auc_after_max_time" + ) } # Ensure that we have clean concentration and time data. This means that we # need to make sure that we have our starting point. Interpolation ensures @@ -168,7 +179,7 @@ pk.calc.auxc <- function(conc, time, interval=c(0, Inf), # All concentrations are BLQ (note that this has to be checked # after full subsetting and interpolation to ensure that it is # still true) - stop("Unknown error with NA tlast but non-BLQ concentrations") # nocov + rlang::abort("Unknown error with NA tlast but non-BLQ concentrations", class = "pknca_error_internal_tlast") # nocov } else { interval_method <- choose_interval_method(conc = data$conc, time = data$time, tlast = tlast, method = method, auc.type = auc.type, options = options) ret <- @@ -203,7 +214,10 @@ pk.calc.auc <- function(conc, time, ..., options=list()) { #' @export pk.calc.auc.last <- function(conc, time, ..., options=list()) { if ("auc.type" %in% names(list(...))) - stop("auc.type cannot be changed when calling pk.calc.auc.last, please use pk.calc.auc") + rlang::abort( + "auc.type cannot be changed when calling pk.calc.auc.last, please use pk.calc.auc", + class = "pknca_error_auc_last_type_override" + ) pk.calc.auc(conc=conc, time=time, ..., options=options, auc.type="AUClast", @@ -214,7 +228,10 @@ pk.calc.auc.last <- function(conc, time, ..., options=list()) { #' @export pk.calc.auc.inf <- function(conc, time, ..., options=list(), lambda.z) { if ("auc.type" %in% names(list(...))) - stop("auc.type cannot be changed when calling pk.calc.auc.inf, please use pk.calc.auc") + rlang::abort( + "auc.type cannot be changed when calling pk.calc.auc.inf, please use pk.calc.auc", + class = "pknca_error_auc_inf_type_override" + ) pk.calc.auc(conc=conc, time=time, ..., options=options, auc.type="AUCinf", @@ -243,7 +260,10 @@ pk.calc.auc.inf.pred <- function(conc, time, clast.pred, ..., options=list(), #' @export pk.calc.auc.all <- function(conc, time, ..., options=list()) { if ("auc.type" %in% names(list(...))) - stop("auc.type cannot be changed when calling pk.calc.auc.all, please use pk.calc.auc") + rlang::abort( + "auc.type cannot be changed when calling pk.calc.auc.all, please use pk.calc.auc", + class = "pknca_error_auc_all_type_override" + ) pk.calc.auc(conc=conc, time=time, ..., options=options, auc.type="AUCall", lambda.z=NA) @@ -264,7 +284,10 @@ pk.calc.aumc <- function(conc, time, ..., options=list()) { #' @export pk.calc.aumc.last <- function(conc, time, ..., options=list()) { if ("auc.type" %in% names(list(...))) - stop("auc.type cannot be changed when calling pk.calc.aumc.last, please use pk.calc.aumc") + rlang::abort( + "auc.type cannot be changed when calling pk.calc.aumc.last, please use pk.calc.aumc", + class = "pknca_error_aumc_last_type_override" + ) pk.calc.aumc(conc=conc, time=time, ..., options=options, auc.type="AUClast", lambda.z=NA) @@ -275,7 +298,10 @@ pk.calc.aumc.last <- function(conc, time, ..., options=list()) { pk.calc.aumc.inf <- function(conc, time, ..., options=list(), lambda.z) { if ("auc.type" %in% names(list(...))) { - stop("auc.type cannot be changed when calling pk.calc.aumc.inf, please use pk.calc.aumc") + rlang::abort( + "auc.type cannot be changed when calling pk.calc.aumc.inf, please use pk.calc.aumc", + class = "pknca_error_aumc_inf_type_override" + ) } pk.calc.aumc(conc=conc, time=time, ..., options=options, auc.type="AUCinf", @@ -302,7 +328,10 @@ pk.calc.aumc.inf.pred <- function(conc, time, clast.pred, ..., options=list(), #' @export pk.calc.aumc.all <- function(conc, time, ..., options=list()) { if ("auc.type" %in% names(list(...))) - stop("auc.type cannot be changed when calling pk.calc.aumc.all, please use pk.calc.aumc") + rlang::abort( + "auc.type cannot be changed when calling pk.calc.aumc.all, please use pk.calc.aumc", + class = "pknca_error_aumc_all_type_override" + ) pk.calc.aumc(conc=conc, time=time, ..., options=options, auc.type="AUCall", lambda.z=NA) @@ -345,8 +374,7 @@ add.interval.col("aucall", pretty_name="AUCall", desc="The area under the concentration time curve from the beginning of the interval to the last concentration above the limit of quantification plus the triangle from that last concentration to 0 at the first concentration below the limit of quantification", pptestcd_cdisc="AUCALL", - pptest_cdisc="AUC All" -) + pptest_cdisc="AUC All") add.interval.col("aumcinf.obs", FUN="pk.calc.aumc.inf.obs", diff --git a/R/auc_integrate.R b/R/auc_integrate.R index 952acdd6..a780b30e 100644 --- a/R/auc_integrate.R +++ b/R/auc_integrate.R @@ -85,20 +85,15 @@ extrapolate_conc_lambdaz <- function(clast, lambda.z, tlast, time_out) { #' and 'extrap_log' choose_interval_method <- function(conc, time, tlast, method, auc.type, options) { # Input checking - stopifnot(is.numeric(conc)) - stopifnot(is.numeric(time)) - stopifnot(!any(is.na(time))) - stopifnot(!any(is.na(conc))) - stopifnot(length(conc) == length(time)) + checkmate::assert_numeric(conc, any.missing = FALSE) + checkmate::assert_numeric(time, any.missing = FALSE, len = length(conc)) assert_aucmethod(method) - stopifnot(length(auc.type) == 1) - stopifnot(auc.type %in% c("AUCinf", "AUClast", "AUCall")) + checkmate::assert_choice(auc.type, choices = c("AUCinf", "AUClast", "AUCall")) if (missing(tlast)) { tlast <- pk.calc.tlast(conc, time, check=FALSE) } else { - stopifnot(is.numeric(tlast)) - stopifnot(length(tlast) == 1) + checkmate::assert_number(tlast) } ret <- rep(NA_character_, length(conc)) @@ -121,13 +116,15 @@ choose_interval_method <- function(conc, time, tlast, method, auc.type, options) # return above, since tlast is NA when all concentrations are zero. idx_tlast <- which(time == tlast) if (length(idx_tlast) != 1) { - stop( - "tlast (", tlast, ") must occur exactly once in time; ", + tlast_detail <- if (length(idx_tlast) == 0) { "tlast was not found in time (possible floating point issue)" } else { "tlast was found multiple times" } + rlang::abort( + sprintf("tlast (%s) must occur exactly once in time; %s", tlast, tlast_detail), + class = "pknca_error_tlast_not_unique" ) } @@ -151,7 +148,7 @@ choose_interval_method <- function(conc, time, tlast, method, auc.type, options) ret[c(mask_linear, FALSE)] <- "linear" ret[c(mask_log, FALSE)] <- "log" } else { - stop("Unknown integration method, please report a bug: ", method) # nocov + rlang::abort(sprintf("Unknown integration method, please report a bug: %s", method), class = "pknca_error_internal_unknown_integration_method") # nocov } ret[c(mask_zero, FALSE)] <- "zero" # What happens after tlast? @@ -205,7 +202,7 @@ auc_integrate <- function(conc, time, clast, tlast, lambda.z, interval_method, f # or clast,pred is passed in. ret[length(ret)+1] <- fun_inf(clast, tlast, lambda.z) } else if (interval_method_extrap != "zero") { - stop("Invalid interval_method_extrap, please report a bug: ", interval_method_extrap) # nocov + rlang::abort(sprintf("Invalid interval_method_extrap, please report a bug: %s", interval_method_extrap), class = "pknca_error_internal_invalid_interval_method_extrap") # nocov } ret <- sum(ret) ret diff --git a/R/aucint.R b/R/aucint.R index 5c343c68..f60cec3c 100644 --- a/R/aucint.R +++ b/R/aucint.R @@ -82,7 +82,7 @@ pk.calc.auxcint <- function(conc, time, # clast.pred is NA likely because the half-life was not calculable return(structure(NA_real_, exclude = "clast.pred is NA because the half-life is NA")) } else if (is.na(clast)) { - stop("Please report a bug. clast is NA and the half-life is not NA") # nocov + rlang::abort("Please report a bug. clast is NA and the half-life is not NA", class = "pknca_error_internal_clast_na") # nocov } else if (clast != clast_obs && interval[2] > tlast) { # If using clast.pred, we need to doubly calculate at tlast. conc_clast <- clast @@ -142,7 +142,7 @@ pk.calc.auxcint <- function(conc, time, "Time points with missing data are: ", paste(missing_times, collapse=", ")) } - warning(warning_message) + rlang::warn(warning_message, class = "pknca_warning_missing_interpolated_concentrations") return(NA_real_) } } else { diff --git a/R/check.intervals.R b/R/check.intervals.R index 1419ef3e..cdccc8c0 100644 --- a/R/check.intervals.R +++ b/R/check.intervals.R @@ -21,17 +21,21 @@ check.interval.specification <- function(x) { if (!is.data.frame(x)) { # Just a warning and let as.data.frame make it an error if it can't be # coerced. - warning("Interval specification must be a data.frame") + rlang::warn("Interval specification must be a data.frame", class = "pknca_warning_interval_not_df") x <- as.data.frame(x, stringsAsFactors=FALSE) } if (nrow(x) == 0) { - stop("interval specification has no rows") + rlang::abort("interval specification has no rows", class = "pknca_error_interval_no_rows") } # Confirm that the minimal columns (start and end) exist if (length(missing.required.cols <- setdiff(c("start", "end"), names(x))) > 0) { - stop(sprintf("Column(s) %s missing from interval specification", - paste0("'", missing.required.cols, "'", - collapse=", "))) + rlang::abort( + sprintf( + "Column(s) %s missing from interval specification", + paste0("'", missing.required.cols, "'", collapse = ", ") + ), + class = "pknca_error_interval_missing_cols" + ) } interval_cols <- get.interval.cols() # Check the edit of each column @@ -43,41 +47,53 @@ check.interval.specification <- function(x) { } else { # It would probably take malicious code to get here (altering # the intervals without using add.interval.col - stop("Cannot assign default value for interval column", n) # nocov + rlang::abort(sprintf("Cannot assign default value for interval column %s", n), class = "pknca_error_interval_default_value") # nocov } } else { # Confirm the edits of the given columns if (is.vector(interval_cols[[n]]$values)) { - if (!all(x[[n]] %in% interval_cols[[n]]$values)) - stop(sprintf("Invalid value(s) in column %s:", n), - paste(unique(setdiff(x[[n]], interval_cols[[n]]$values)), - collapse=", ")) + if (!all(x[[n]] %in% interval_cols[[n]]$values)) { + invalid_vals <- unique(setdiff(x[[n]], interval_cols[[n]]$values)) + rlang::abort( + sprintf( + "Invalid value(s) in column %s:%s", n, + paste(invalid_vals, collapse = ", ") + ), + class = "pknca_error_interval_invalid_value" + ) + } + } else if (is.function(interval_cols[[n]]$values)) { if (is.factor(x[[n]])) { - stop(sprintf("Interval column '%s' should not be a factor", n)) + rlang::abort( + sprintf("Interval column '%s' should not be a factor", n), + class = "pknca_error_interval_factor_col" + ) } interval_cols[[n]]$values(x[[n]]) } else { - stop("Invalid 'values' for column specification ", n, " (please report this as a bug).") # nocov + rlang::abort(sprintf("Invalid 'values' for column specification %s (please report this as a bug).", n), class = "pknca_error_interval_invalid_col_spec") # nocov } } } # Now check specific columns # start and end - if (any(x$start %in% NA)) { - stop("Interval specification may not have NA for the starting time") + if (anyNA(x$start)) { + rlang::abort( + "Interval specification may not have NA for the starting time", + class = "pknca_error_interval_na_start" + ) } - if (any(x$end %in% NA)) { - stop("Interval specification may not have NA for the end time") + if (anyNA(x$end)) { + rlang::abort("Interval specification may not have NA for the end time", class = "pknca_error_interval_na_end") } if (any(is.infinite(x$start))) { - stop("start may not be infinite") + rlang::abort("start may not be infinite", class = "pknca_error_interval_infinite_start") } if (any(x$start >= x$end)) { - stop("start must be < end") + rlang::abort("start must be < end", class = "pknca_error_interval_start_gte_end") } - # Confirm that something is being calculated for each interval (and warn if - # not) + # Confirm that something is being calculated for each interval (and warn if not) mask_calculated <- rep(FALSE, nrow(x)) for (n in setdiff(names(interval_cols), c("start", "end"))) { mask_calculated <- @@ -85,8 +101,13 @@ check.interval.specification <- function(x) { !(x[[n]] %in% c(NA, FALSE))) } if (any(!mask_calculated)) { - warning("Nothing to be calculated in interval specification number(s): ", - paste(seq_len(nrow(x))[!mask_calculated], collapse=", ")) + rlang::warn( + sprintf( + "Nothing to be calculated in interval specification number(s): %s", + paste(seq_len(nrow(x))[!mask_calculated], collapse = ", ") + ), + class = "pknca_warning_interval_nothing_calculated" + ) } # Put the columns in the right order and return the checked data frame x[, @@ -110,7 +131,7 @@ get.parameter.deps_helper_funmap <- function(x, all_intervals) { # It would probably take malicious code to get here (an # example of malicious code could be altering the # intervals without using add.interval.col) - stop("Invalid interval definition with no function and multiple dependencies.") # nocov + rlang::abort("Invalid interval definition with no function and multiple dependencies.", class = "pknca_error_interval_invalid_def") # nocov } } else { retfun <- x$FUN @@ -172,7 +193,10 @@ get.parameter.deps_helper_searchdeps <- function(current, funmap, all_intervals) get.parameter.deps <- function(x) { all_intervals <- get.interval.cols() if (!(x %in% names(all_intervals))) { - stop("`x` must be the name of an NCA parameter listed by the function `get.interval.cols()`") + rlang::abort( + "`x` must be the name of an NCA parameter listed by the function `get.interval.cols()`", + class = "pknca_error_invalid_parameter" + ) } funmap <- lapply( diff --git a/R/choose.intervals.R b/R/choose.intervals.R index 03e7819e..b1372e4e 100644 --- a/R/choose.intervals.R +++ b/R/choose.intervals.R @@ -31,10 +31,14 @@ choose.auc.intervals <- function(time.conc, time.dosing, single.dose.aucs=NULL) { # Check inputs single.dose.aucs <- PKNCA.choose.option(name="single.dose.aucs", value=single.dose.aucs, options=options) - if (any(is.na(time.conc))) - stop("time.conc may not have any NA values") - if (any(is.na(time.dosing))) - stop("time.dosing may not have any NA values") + if (anyNA(time.conc)) { + rlang::abort("time.conc may not have any NA values", class = "pknca_error_timeconc_na") + } + + if (anyNA(time.dosing)) { + rlang::abort("time.dosing may not have any NA values", class = "pknca_error_timedosing_na") + } + if (length(unique(time.dosing)) == 1) { # If it is single-dose data, use the time of dosing and then offset it by # the dosing time (allowing the case where dosing time is not 0). diff --git a/R/class-PKNCAconc.R b/R/class-PKNCAconc.R index 3e95ec5d..c4dd5ee2 100644 --- a/R/class-PKNCAconc.R +++ b/R/class-PKNCAconc.R @@ -81,12 +81,18 @@ PKNCAconc.data.frame <- function(data, formula, subject, concu_pref = NULL, amountu_pref = NULL, timeu_pref = NULL) { # The data must have... data if (nrow(data) == 0) { - stop("data must have at least one row.") + rlang::abort("data must have at least one row.", class = "pknca_error_data_no_rows") } # Verify that all the variables in the formula are columns in the data. missing_vars <- setdiff(all.vars(formula), names(data)) if (length(missing_vars) > 0) { - stop("All of the variables in the formula must be in the data. Missing: ", paste(missing_vars)) + rlang::abort( + sprintf( + "All of the variables in the formula must be in the data. Missing: %s", + paste(missing_vars, collapse = ", ") + ), + class = "pknca_error_formula_missing_vars" + ) } parsed_form_raw <- parse_formula_to_cols(form = formula) parsed_form_groups <- @@ -108,10 +114,13 @@ PKNCAconc.data.frame <- function(data, formula, subject, groups = parsed_form_groups ) if (length(parsed_form$concentration) != 1) { - stop("The left hand side of the formula must have exactly one variable") + rlang::abort("The left hand side of the formula must have exactly one variable", class = "pknca_error_conc_formula_lhs") } if (length(parsed_form$time) != 1) { - stop("The right hand side of the formula (excluding groups) must have exactly one variable") + rlang::abort( + "The right hand side of the formula (excluding groups) must have exactly one variable", + class = "pknca_error_conc_formula_rhs" + ) } # Assign the subject @@ -120,12 +129,9 @@ PKNCAconc.data.frame <- function(data, formula, subject, } else { # Ensure that the subject is part of the data definition and a scalar # character string. - if (!is.character(subject)) - stop("subject must be a character string") - if (!(length(subject) == 1)) - stop("subject must be a scalar") + checkmate::assert_string(subject, null.ok = FALSE) if (!(subject %in% names(data))) - stop("The subject parameter must map to a name in the data") + rlang::abort("The subject parameter must map to a name in the data", class = "pknca_error_subject_not_in_data") } parsed_form$subject <- subject if (sparse) { @@ -167,7 +173,7 @@ PKNCAconc.data.frame <- function(data, formula, subject, } else { ret <- setAttributeColumn(ret, attr_name="volume", col_or_value=volume) if (!is.numeric(getAttributeColumn(ret, attr_name="volume")[[1]])) { - stop("Volume must be numeric") + rlang::abort("Volume must be numeric", class = "pknca_error_volume_not_numeric") } } if (missing(duration)) { @@ -195,9 +201,9 @@ PKNCAconc.data.frame <- function(data, formula, subject, } if (!missing(lloq)) { ret <- setAttributeColumn(object=ret, attr_name="lloq", col_or_value=lloq) - if (!is.numeric(getAttributeColumn(object=ret, attr_name="lloq")[[1]])) { - stop("lloq must be numeric") - } + checkmate::assertNumeric( + getAttributeColumn(object = ret, attr_name = "lloq")[[1]] + ) } # Unit handling @@ -267,9 +273,15 @@ getGroups.PKNCAconc <- function(object, form=stats::formula(object), level, if (!missing(level)) if (is.factor(level) || is.character(level)) { level <- as.character(level) - if (any(!(level %in% grpnames))) - stop("Not all levels are listed in the group names. Missing levels are: ", - paste(setdiff(level, grpnames), collapse=", ")) + if (any(!(level %in% grpnames))) { + rlang::abort( + sprintf( + "Not all levels are listed in the group names. Missing levels are: %s", + paste(setdiff(level, grpnames), collapse = ", ") + ), + class = "pknca_error_conc_missing_group_levels" + ) + } grpnames <- level } else if (is.numeric(level)) { if (length(level) == 1 && @@ -318,12 +330,15 @@ setDuration.PKNCAconc <- function(object, duration, ...) { } duration.val <- getAttributeColumn(object=object, attr_name="duration")[[1]] if (is.numeric(duration.val) && - !any(is.na(duration.val)) && + !anyNA(duration.val) && !any(is.infinite(duration.val)) && all(duration.val >= 0)) { # It passes the test } else { - stop("duration must be numeric without missing (NA) or infinite values, and all values must be >= 0") + rlang::abort( + "duration must be numeric without missing (NA) or infinite values, and all values must be >= 0", + class = "pknca_error_conc_invalid_duration" + ) } object } diff --git a/R/class-PKNCAdata.R b/R/class-PKNCAdata.R index 12845726..14d20408 100644 --- a/R/class-PKNCAdata.R +++ b/R/class-PKNCAdata.R @@ -56,15 +56,18 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., impute = NA_character_, intervals, units, options=list()) { if (length(list(...))) { - stop("Unknown argument provided to PKNCAdata. All arguments other than `data.conc` and `data.dose` must be named.") + rlang::abort( + "Unknown argument provided to PKNCAdata. All arguments other than `data.conc` and `data.dose` must be named.", + class = "pknca_error_unknown_argument" + ) } ret <- list() # Generate the conc element if (inherits(data.conc, "PKNCAconc")) { if (!missing(formula.conc)) { rlang::warn( - message = "data.conc was given as a PKNCAconc object. Ignoring formula.conc", - class = "pknca_dataconc_formulaconc" + "data.conc was given as a PKNCAconc object. Ignoring formula.conc", + class = "pknca_warning_dataconc_formulaconc" ) } ret$conc <- data.conc @@ -79,20 +82,21 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., } else if (inherits(data.dose, "PKNCAdose")) { if (!missing(formula.dose)) rlang::warn( - message = "data.dose was given as a PKNCAdose object. Ignoring formula.dose", - class = "pknca_dataconc_formuladose" + "data.dose was given as a PKNCAdose object. Ignoring formula.dose", + class = "pknca_warning_dataconc_formuladose" ) ret$dose <- data.dose } else { ret$dose <- PKNCAdose(data.dose, formula.dose) } # Check the options - if (!is.list(options)) { - stop("options must be a list.") - } + checkmate::assert_list( + x = options, + names = if (length(options) > 0) "named" else NULL + ) + if (length(options) > 0) { - if (is.null(names(options))) - stop("options must have names.") + checkmate::assert_named(options) for (n in names(options)) { tmp.opt <- list(options[[n]], TRUE) names(tmp.opt) <- c(n, "check") @@ -106,12 +110,15 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., # Check the intervals if (missing(intervals) && identical(ret$dose, NA)) { - stop("If data.dose is not given, intervals must be given") + rlang::abort("If data.dose is not given, intervals must be given", class = "pknca_error_missing_intervals") } else if (missing(intervals)) { # Generate the intervals for each grouping of concentration and # dosing. if (length(ret$dose$columns$time) == 0) { - stop("Dose times were not given, so intervals must be manually specified.") + rlang::abort( + "Dose times were not given, so intervals must be manually specified.", + class = "pknca_error_missing_dose_times" + ) } n_conc_dose <- full_join_PKNCAconc_PKNCAdose( @@ -147,12 +154,21 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., if (nrow(generated_intervals) > 0) { n_conc_dose$data_intervals[[idx]] <- generated_intervals } else { - warning(warning_prefix, "No intervals generated likely due to limited concentration data") + rlang::warn( + sprintf( + "%sNo intervals generated likely due to limited concentration data", + warning_prefix + ), + class = "pknca_warning_no_intervals_limited_data" + ) } } else { rlang::warn( - message = paste(warning_prefix, "No intervals generated due to no concentration data"), - class = "pknca_no_intervals_generated" + sprintf( + "%sNo intervals generated due to no concentration data", + warning_prefix + ), + class = "pknca_warning_no_intervals_generated" ) } } @@ -173,12 +189,19 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., # Use the new automatic units table builder ret$units <- pknca_units_table(ret) } else { - stopifnot("`units` must be a data.frame"=is.data.frame(units)) - stopifnot( - "`units` data.frame must have at least names 'PPTESTCD' and 'PPORRESU'"= - all(c("PPTESTCD", "PPORRESU") %in% names(units)) - ) - stopifnot("`units` must have at least one row"=nrow(units) > 0) + + checkmate::assert_data_frame(units) + + missing_unit_cols <- setdiff(c("PPTESTCD", "PPORRESU"), names(units)) + if (length(missing_unit_cols) > 0) { + rlang::abort( + "`units` data.frame must have at least names 'PPTESTCD' and 'PPORRESU'", + class = "pknca_error_units_missing_cols" + ) + } + + checkmate::assert_data_frame(units, min.rows = 1) + ret$units <- units } diff --git a/R/class-PKNCAdose.R b/R/class-PKNCAdose.R index 1f4d1727..af7bf7d2 100644 --- a/R/class-PKNCAdose.R +++ b/R/class-PKNCAdose.R @@ -64,19 +64,21 @@ PKNCAdose.data.frame <- function(data, formula, route, rate, duration, time.nominal, exclude = NULL, ..., doseu = NULL, doseu_pref = NULL) { # The data must have... data - if (nrow(data) == 0) { - stop("data must have at least one row.") - } + checkmate::assert_data_frame(data, min.rows = 1) + # Check inputs if (!missing(time.nominal)) { if (!(time.nominal %in% names(data))) { - stop("time.nominal, if given, must be a column name in the input data.") + rlang::abort( + "time.nominal, if given, must be a column name in the input data.", + class = "pknca_error_timenominal_not_in_data" + ) } } # Verify that all the variables in the formula are columns in the data. parsed_form_raw <- parse_formula_to_cols(form = formula) if (length(parsed_form_raw$groups_left_of_slash) > 0) { - stop("formula for PKNCAdose may not include a slash") + rlang::abort("formula for PKNCAdose may not include a slash", class = "pknca_error_formula_slash") } parsed_form_groups <- if (length(parsed_form_raw$groups) > 0) { @@ -98,20 +100,29 @@ PKNCAdose.data.frame <- function(data, formula, route, rate, duration, ) # Check for variable existence and length if (!(length(parsed_form$dose) %in% c(0, 1))) { - stop("The left side of the formula must have zero or one variable") + rlang::abort("The left side of the formula must have zero or one variable", class = "pknca_error_dose_formula_lhs") } else if (length(parsed_form$dose) == 1 && !(parsed_form$dose %in% names(data))) { # the "." is handled in parse_formula_to_cols - stop("The left side formula must be a variable in the data, empty, or '.'.") + rlang::abort( + "The left side formula must be a variable in the data, empty, or '.'.", + class = "pknca_error_formula_lhs_not_in_data" + ) } if (!(length(parsed_form$time) %in% c(0, 1))) { - stop("The right side of the formula (excluding groups) must have exactly one variable") + rlang::abort( + "The right side of the formula (excluding groups) must have exactly one variable", + class = "pknca_error_dose_formula_rhs" + ) } else if (length(parsed_form$time) == 1 && !(parsed_form$time %in% names(data))) { - stop("The right side formula must be a variable in the data or '.'.") + rlang::abort( + "The right side formula must be a variable in the data or '.'.", + class = "pknca_error_formula_rhs_not_in_data" + ) } if (!all(unlist(parsed_form$groups) %in% names(data))) { - stop("All of the variables in the groups must be in the data") + rlang::abort("All of the variables in the groups must be in the data", class = "pknca_error_groups_not_in_data") } ret <- list( @@ -132,7 +143,10 @@ PKNCAdose.data.frame <- function(data, formula, route, rate, duration, # Check for missing independent variable (time) in non-excluded rows mask.indep <- is.na(getIndepVar.PKNCAdose(ret)) & !is_excluded if (any(mask.indep) && !all(is.na(getIndepVar.PKNCAdose(ret)[!is_excluded]))) { - stop("Some but not all values are missing for the independent variable, please see the help for PKNCAdose for how to specify the formula and confirm that your data has dose times for all doses.") + rlang::abort( + "Some but not all values are missing for the independent variable, please see the help for PKNCAdose for how to specify the formula and confirm that your data has dose times for all doses.", + class = "pknca_error_partial_missing_indepvar" + ) } if (missing(route)) { ret <- setRoute(ret) @@ -189,7 +203,10 @@ setRoute.PKNCAdose <- function(object, route, ...) { } if (!all(tolower(getAttributeColumn(object=object, attr_name="route")[[1]]) %in% c("extravascular", "intravascular"))) { - stop("route must have values of either 'extravascular' or 'intravascular'. Please set to one of those values and retry.") + rlang::abort( + "route must have values of either 'extravascular' or 'intravascular'. Please set to one of those values and retry.", + class = "pknca_error_invalid_route" + ) } object } @@ -217,7 +234,7 @@ setDuration.PKNCAdose <- function(object, duration, rate, dose, ...) { message_if_default="Assuming instant dosing (duration=0)") } else if (!missing(duration) && !missing(rate)) { - stop("Both duration and rate cannot be given at the same time") + rlang::abort("Both duration and rate cannot be given at the same time", class = "pknca_error_duration_and_rate") # TODO: A consistency check could be done, but that would get into # requiring near-equal checks for floating point error. } else if (!missing(duration)) { @@ -230,12 +247,15 @@ setDuration.PKNCAdose <- function(object, duration, rate, dose, ...) { } duration.val <- getAttributeColumn(object=object, attr_name="duration")[[1]] if (is.numeric(duration.val) && - !any(is.na(duration.val)) && + !anyNA(duration.val) && !any(is.infinite(duration.val)) && all(duration.val >= 0)) { # It passes } else { - stop("duration must be numeric without missing (NA) or infinite values, and all values must be >= 0") + rlang::abort( + "duration must be numeric without missing (NA) or infinite values, and all values must be >= 0", + class = "pknca_error_dose_invalid_duration" + ) } object } diff --git a/R/class-PKNCAresults.R b/R/class-PKNCAresults.R index 41dc16b1..501510f8 100644 --- a/R/class-PKNCAresults.R +++ b/R/class-PKNCAresults.R @@ -380,9 +380,15 @@ getGroups.PKNCAresults <- function(object, if (!missing(level)) if (is.factor(level) || is.character(level)) { level <- as.character(level) - if (any(!(level %in% grpnames))) - stop("Not all levels are listed in the group names. Missing levels are: ", - paste(setdiff(level, grpnames), collapse=", ")) + if (any(!(level %in% grpnames))) { + rlang::abort( + sprintf( + "Not all levels are listed in the group names. Missing levels are: %s", + paste(setdiff(level, grpnames), collapse = ", ") + ), + class = "pknca_error_results_missing_group_levels" + ) + } grpnames <- level } else if (is.numeric(level)) { if (length(level) == 1) { diff --git a/R/class-general.R b/R/class-general.R index 73280d8e..429fd126 100644 --- a/R/class-general.R +++ b/R/class-general.R @@ -47,7 +47,10 @@ getColumnValueOrNot <- function(data, value, prefix="X") { data[[col.name]] <- value ret <- list(data=data, name=col.name) } else { - stop("value was not a column name nor was it a scalar or a vector matching the length of the data.") + rlang::abort( + "value was not a column name nor was it a scalar or a vector matching the length of the data.", + class = "pknca_error_invalid_column_value" + ) } ret } @@ -93,11 +96,14 @@ setAttributeColumn <- function(object, attr_name, col_or_value, col_name, defaul dataname <- getDataName(object) # Check inputs if (!is.character(attr_name) || (length(attr_name) != 1)) { - stop("attr_name must be a character scalar.") + rlang::abort("attr_name must be a character scalar.", class = "pknca_error_invalid_attr_name") } if (!missing(col_or_value) && any(!c(missing(col_name), missing(default_value)))) { - stop("Cannot provide col_or_value and col_name or default_value") + rlang::abort( + "Cannot provide col_or_value and col_name or default_value", + class = "pknca_error_conflicting_column_args" + ) } # Apply col_or_value to col_name or to default_value if (!missing(col_or_value)) { @@ -112,12 +118,12 @@ setAttributeColumn <- function(object, attr_name, col_or_value, col_name, defaul col_name <- attr_name if (attr_name %in% names(object[[dataname]])) { rlang::inform( - message = paste0("Found column named ", attr_name, ", using it for the attribute of the same name."), - class = paste0("pknca_foundcolumn_", attr_name) + sprintf("Found column named %s, using it for the attribute of the same name.", attr_name), + class = paste0("pknca_message_foundcolumn_", attr_name) ) } } else if (!is.character(col_name) || (length(col_name) != 1)) { - stop("col_name must be a character scalar.") + rlang::abort("col_name must be a character scalar.", class = "pknca_error_invalid_col_name") } # Set the default value if (missing(default_value)) { @@ -127,17 +133,20 @@ setAttributeColumn <- function(object, attr_name, col_or_value, col_name, defaul default_value <- NA # React to using the default value, if requested if (!missing(stop_if_default)) { - stop(stop_if_default) + rlang::abort(stop_if_default, class = "pknca_error_used_default_value") } else if (!missing(warn_if_default)) { - warning(warn_if_default) + rlang::warn(warn_if_default, class = "pknca_warning_used_default_value") } else if (!missing(message_if_default)) { - message(message_if_default) + rlang::inform(message_if_default, class = "pknca_message_used_default_value") } } } # Check that the default_value can work if (!(length(default_value) %in% c(1, nrow(object[[dataname]])))) { - stop("default_value must be a scalar or the same length as the rows in the data.") + rlang::abort( + "default_value must be a scalar or the same length as the rows in the data.", + class = "pknca_error_invalid_default_value" + ) } object[[dataname]][[col_name]] <- default_value # Inform the object that the column exists @@ -158,18 +167,21 @@ setAttributeColumn <- function(object, attr_name, col_or_value, col_name, defaul #' the column does not exist) getAttributeColumn <- function(object, attr_name, warn_missing=c("attr", "column")) { if (length(setdiff(warn_missing, c("attr", "column")))) { - stop("warn_missing must have a valid value or be empty") + rlang::abort("warn_missing must have a valid value or be empty", class = "pknca_error_invalid_warn_missing") } warn_missing <- warn_missing[warn_missing %in% c("attr", "column")] columns <- object$columns[[attr_name]] dataname <- getDataName(object) if (is.null(columns)) { if ("attr" %in% warn_missing) - warning(attr_name, " is not set.") + rlang::warn(sprintf("%s is not set.", attr_name), class = "pknca_warning_attr_not_set") NULL } else if (length(missing_cols <- setdiff(columns, names(object[[dataname]])))) { if ("column" %in% warn_missing) - warning("Columns ", paste(missing_cols, collapse=", "), " are not present.") + rlang::warn( + sprintf("Columns %s are not present.", paste(missing_cols, collapse = ", ")), + class = "pknca_warning_cols_not_present" + ) NULL } else { object[[dataname]][, columns, drop=FALSE] @@ -198,11 +210,14 @@ duplicate_check <- function(object, data_type) { mask_dup[!mask_excluded] <- duplicated(object$data[!mask_excluded, key_cols]) } if (any(mask_dup)) { - stop( - "Rows that are not unique per group and time (column names: ", - paste(key_cols, collapse=", "), - ") found within ", data_type, " data. Row numbers: ", - paste(which(mask_dup), collapse=", ") + rlang::abort( + sprintf( + "Rows that are not unique per group and time (column names: %s) found within %s data. Row numbers: %s", + paste(key_cols, collapse = ", "), + data_type, + paste(which(mask_dup), collapse = ", ") + ), + class = "pknca_error_duplicate_rows" ) } object @@ -238,7 +253,7 @@ pknca_set_units <- function(object, units_orig = list(), units_pref = list()) { } else if (current_unit_type %in% "value") { object$units[[col_units]] <- all_units$orig[[col_units]] } else { - stop(paste("Please report a bug. Unit setting for", col_units)) # nocov + rlang::abort(sprintf("Please report a bug. Unit setting for %s", col_units), class = "pknca_error_internal_unit_setting_bug") # nocov } } for (pref_units in names(all_units$pref)) { @@ -249,11 +264,14 @@ pknca_set_units <- function(object, units_orig = list(), units_pref = list()) { # you can only set preferred units if you set original units original_unit_col <- gsub(x = pref_units, pattern = "_pref", replacement = "") if (!(original_unit_col %in% c(names(object$columns), names(object$units)))) { - stop("Preferred units may not be set unless original units are set: ", pref_units) + rlang::abort( + sprintf("Preferred units may not be set unless original units are set: %s", pref_units), + class = "pknca_error_pref_units_without_orig" + ) } object$units[[pref_units]] <- all_units$pref[[pref_units]] } else { - stop(paste("Please report a bug. Preferred unit setting for", pref_units)) # nocov + rlang::abort(sprintf("Please report a bug. Preferred unit setting for %s", pref_units), class = "pknca_error_internal_pref_unit_setting_bug") # nocov } } diff --git a/R/class-summary_PKNCAresults.R b/R/class-summary_PKNCAresults.R index a4ff59e7..7e56d485 100644 --- a/R/class-summary_PKNCAresults.R +++ b/R/class-summary_PKNCAresults.R @@ -108,9 +108,12 @@ summary.PKNCAresults <- function(object, ..., has_subject_col <- length(subject_col) > 0 if (is.na(summarize_n)) { summarize_n <- has_subject_col - } else if (summarize_n && !has_subject_col) { - warning("summarize_n was requested, but no subject column exists") - summarize_n <- FALSE + } else if (summarize_n && !has_subject_col) { + rlang::warn( + "summarize_n was requested, but no subject column exists", + class = "pknca_warning_summarize_n_no_subject" + ) + summarize_n <- FALSE } # Preparation #### @@ -197,7 +200,10 @@ summary.PKNCAresults <- function(object, ..., get_summary_PKNCAresults_drop_group <- function(object, drop_group) { all_group_cols <- getGroups(object) if (any(c("start", "end") %in% drop_group)) { - warning("drop.group including start or end may result in incorrect groupings (such as inaccurate comparison of intervals). Drop these with care.") + rlang::warn( + "drop.group including start or end may result in incorrect groupings (such as inaccurate comparison of intervals). Drop these with care.", + class = "pknca_warning_drop_start_end" + ) } ret <- unique( @@ -284,8 +290,8 @@ get_summary_PKNCAresults_count_N <- function(data, result_group, subject_col, su ret[[key_col]] <- NULL ret$N <- as.character(ret$N) - if (any(is.na(ret$N))) { - stop("Please report a bug. If N is requested, but it is not provided, then it should be set to not calculated.") # nocov + if (anyNA(ret$N)) { + rlang::abort("Please report a bug. If N is requested, but it is not provided, then it should be set to not calculated.", class = "pknca_error_internal_n_is_na") # nocov } } else { ret <- result_group @@ -383,8 +389,13 @@ summarize_PKNCAresults_group <- function(data, current_group, subject_col, resul current_data <- dplyr::inner_join(data, current_group, by = intersect(names(data), names(current_group))) if (nrow(current_data) == 0) { # I don't think that a user can get here - warning("No results to summarize for result row, please report a bug") # nocov - return(ret) # nocov + # nocov start + rlang::warn( + "No results to summarize for result row, please report a bug", + class = "pknca_warning_no_results_to_summarize" + ) + return(ret) + # nocov end } current_interval <- dplyr::inner_join(intervals, current_group, by = intersect(names(intervals), names(current_group))) current_param_prep <- @@ -439,10 +450,13 @@ summarize_PKNCAresults_parameter <- function(data, parameter, subject_col, inclu if (!is.null(unit_col)) { units <- unique(current_data[[unit_col]]) if (length(units) > 1) { - stop( - "Multiple units cannot be summarized together. For ", - parameter, ", trying to combine: ", - paste(units, collapse = ", ") + rlang::abort( + sprintf( + "Multiple units cannot be summarized together. For %s, trying to combine: %s", + parameter, + paste(units, collapse = ", ") + ), + class = "pknca_error_multiple_units" ) } } @@ -450,7 +464,13 @@ summarize_PKNCAresults_parameter <- function(data, parameter, subject_col, inclu if (length(subject_col) == 1) { N <- length(unique(current_data[[subject_col]])) if (any(duplicated(current_data[[subject_col]]))) { - warning("Some subjects may have more than one result for ", parameter) + rlang::warn( + sprintf( + "Some subjects may have more than one result for %s", + parameter + ), + class = "pknca_warning_duplicate_subjects" + ) } } else { N <- NULL @@ -459,7 +479,15 @@ summarize_PKNCAresults_parameter <- function(data, parameter, subject_col, inclu current_summary_instructions <- PKNCA.set.summary()[[parameter]] if (is.null(current_summary_instructions)) { - stop("No summary function is set for parameter ", parameter, ". Please set it with PKNCA.set.summary and report this as a bug in PKNCA.") # nocov + # nocov start + rlang::abort( + sprintf( + "No summary function is set for parameter %s. Please set it with PKNCA.set.summary and report this as a bug in PKNCA.", + parameter + ), + class = "pknca_error_no_summary_function" + ) + # nocov end } point <- current_summary_instructions$point(current_data[[number_col]]) @@ -578,21 +606,27 @@ print.summary_PKNCAresults <- function(x, ...) { roundingSummarize <- function(x, name) { summary_instructions <- PKNCA.set.summary() if (!(name %in% names(summary_instructions))) { - stop(name, " is not in the summarization instructions from PKNCA.set.summary") + rlang::abort( + sprintf( + "%s is not in the summarization instructions from PKNCA.set.summary", + name + ), + class = "pknca_error_missing_summary_instructions" + ) } roundingInstructions <- summary_instructions[[name]]$rounding if (is.function(roundingInstructions)) { ret <- roundingInstructions(x) } else if (is.list(roundingInstructions)) { if (length(roundingInstructions) != 1) { - stop("Cannot interpret rounding instructions for ", name, " (please report this as a bug)") # nocov + rlang::abort(sprintf("Cannot interpret rounding instructions for %s (please report this as a bug)", name), class = "pknca_error_internal_rounding_instructions") # nocov } if ("signif" == names(roundingInstructions)) { ret <- signifString(x, roundingInstructions$signif) } else if ("round" == names(roundingInstructions)) { ret <- roundString(x, roundingInstructions$round) } else { - stop("Invalid rounding instruction list name for ", name, " (please report this as a bug)") # nocov + rlang::abort(sprintf("Invalid rounding instruction list name for %s (please report this as a bug)", name), class = "pknca_error_internal_invalid_rounding_name") # nocov } } if (!is.character(ret)) { diff --git a/R/cleaners.R b/R/cleaners.R index 95a31407..5683f99f 100644 --- a/R/cleaners.R +++ b/R/cleaners.R @@ -30,7 +30,7 @@ clean.conc.na <- function(conc, time, ..., } else { # This case should already have been captured by the PKNCA.options # call above. - stop("Unknown how to handle conc.na") # nocov + rlang::abort("Unknown how to handle conc.na", class = "pknca_error_unknown_conc_na") # nocov } ret } @@ -132,7 +132,7 @@ clean.conc.blq <- function(conc, time, } else if (time_type == "after.tmax") { mask <- tmax <= ret$time & ret$conc %in% 0 } else { - stop("There is a bug in cleaning the conc.blq with position names") # nocov + rlang::abort("There is a bug in cleaning the conc.blq with position names", class = "pknca_error_conc_blq_position_bug") # nocov } # Choose the rule to apply this_rule <- unname(conc.blq)[[i]] @@ -146,8 +146,7 @@ clean.conc.blq <- function(conc, time, } else { # This case should already have been captured by the PKNCA.options # call above. - stop(sprintf("Unknown how to handle conc.blq rule %s", # nocov - as.character(this_rule))) # nocov + rlang::abort(sprintf("Unknown how to handle conc.blq rule %s", as.character(this_rule)), class = "pknca_error_unknown_conc_blq_rule") # nocov } } } diff --git a/R/exclude.R b/R/exclude.R index 15ffb275..e60e2702 100644 --- a/R/exclude.R +++ b/R/exclude.R @@ -73,17 +73,24 @@ exclude.default <- function(object, reason, mask, FUN) { mask <- !is.na(reason) } } else if (!xor(missing(mask), missing(FUN))) { - stop("Either mask or FUN must be given (but not both).") + rlang::abort("Either mask or FUN must be given (but not both).", class = "pknca_error_mask_or_fun") } if (!(length(reason) %in% c(1, nrow(object[[dataname]])))) { - stop("reason must be a scalar or have the same length as the data.") + rlang::abort("reason must be a scalar or have the same length as the data.", class = "pknca_error_reason_length") } else if (!is.character(reason)) { - stop("reason must be a character string.") + rlang::abort("reason must be a character vector.", class = "pknca_error_reason_type") } + if (!("exclude" %in% names(object$columns))) { - stop("object must have an exclude column specified.") + rlang::abort("object must have an exclude column specified.", class = "pknca_error_no_exclude_col") } else if (!(object$columns$exclude %in% names(object[[dataname]]))) { - stop("exclude column must exist in object[['", dataname, "']].") + rlang::abort( + sprintf( + "exclude column must exist in object[['%s']].", + dataname + ), + class = "pknca_error_exclude_col_missing" + ) } # Make a scalar reason a vector if (length(reason) == 1) @@ -91,7 +98,7 @@ exclude.default <- function(object, reason, mask, FUN) { # Find the original value of the 'exclude' column. orig <- object[[dataname]][[object$columns$exclude]] if (length(mask) != length(orig)) { - stop("mask must match the length of the data.") + rlang::abort("mask must match the length of the data.", class = "pknca_error_mask_length") } # No current value for exclude mask.none <- orig %in% c(NA, "") @@ -133,7 +140,7 @@ setExcludeColumn <- function(object, exclude = NULL, dataname = "data") { # If exclude is already in the object, then make sure it matches # (and do nothing). if (!(object$columns$exclude == exclude)) { - stop("exclude is already set for the object.") + rlang::abort("exclude is already set for the object.", class = "pknca_error_exclude_already_set") } } else { # If exclude is not already in the object and it is given, then add @@ -150,7 +157,10 @@ setExcludeColumn <- function(object, exclude = NULL, dataname = "data") { } else if (nrow(object[[dataname]]) == 0) { object[[dataname]][[exclude]] <- rep(NA_character_, nrow(object[[dataname]])) } else if (!(exclude %in% names(object[[dataname]]))) { - stop("exclude, if given, must be a column name in the input data.") + rlang::abort( + "exclude, if given, must be a column name in the input data.", + class = "pknca_error_exclude_not_in_data" + ) } else { if (is.factor(object[[dataname]][[exclude]])) { object[[dataname]][[exclude]] <- as.character(object[[dataname]][[exclude]]) @@ -158,7 +168,10 @@ setExcludeColumn <- function(object, exclude = NULL, dataname = "data") { all(is.na(object[[dataname]][[exclude]]))) { object[[dataname]][[exclude]] <- rep(NA_character_, nrow(object[[dataname]])) } else if (!is.character(object[[dataname]][[exclude]])) { - stop("exclude column must be character vector or something convertable to character without loss of information.") + rlang::abort( + "exclude column must be character vector or something convertable to character without loss of information.", + class = "pknca_error_exclude_not_character" + ) } } object$columns$exclude <- exclude diff --git a/R/exclude_nca.R b/R/exclude_nca.R index 91eb3cf8..788382a9 100644 --- a/R/exclude_nca.R +++ b/R/exclude_nca.R @@ -219,16 +219,24 @@ exclude_nca_by_param <- function( checkmate::expect_number(min_thr, finite = TRUE, null.ok = TRUE) checkmate::expect_number(max_thr, finite = TRUE, null.ok = TRUE) - if (isTRUE(min_thr > max_thr)) - stop("if both defined min_thr must be less than max_thr") + if (isTRUE(min_thr > max_thr)) { + rlang::abort("if both defined min_thr must be less than max_thr", class = "pknca_error_min_thr_gt_max_thr") + } function(x, ...) { ret <- rep(NA_character_, nrow(x)) idx_param <- which(x$PPTESTCD == parameter) idx_aff_params <- which(x$PPTESTCD %in% affected_parameters) - if (length(idx_param) > 1) - stop("Should not see more than one ", parameter, " (please report this as a bug)") + if (length(idx_param) > 1) { + rlang::abort( + sprintf( + "Should not see more than one %s (please report this as a bug)", + parameter + ), + class = "pknca_error_internal_duplicate_parameter" + ) + } if (length(idx_param) == 1 && !is.na(x$PPORRES[idx_param]) && length(idx_aff_params) > 0) { current_value <- x$PPORRES[idx_param] diff --git a/R/general.functions.R b/R/general.functions.R index 7a0258bc..1f6168e7 100644 --- a/R/general.functions.R +++ b/R/general.functions.R @@ -12,8 +12,10 @@ check.conversion <- function(x, FUN, ...) { if (new.na != 0) # FIXME: It would be nice to have it give the function name as # part of the error - stop(sprintf("%g new NA value(s) created during conversion", - new.na)) + rlang::abort( + sprintf("%g new NA value(s) created during conversion", new.na), + class = "pknca_error_new_na_conversion" + ) ret } @@ -79,7 +81,7 @@ roundString <- function(x, digits=0, sci_range=Inf, sci_sep="e", si_range) { } else if (length(x) == length(digits)) { mapply(roundString, x, digits=digits, sci_range=sci_range, sci_sep=sci_sep) } else { - stop("digits must either be a scalar or the same length as x") + rlang::abort("digits must either be a scalar or the same length as x", class = "pknca_error_digits_length") } } @@ -127,7 +129,7 @@ signifString.data.frame <- function(x, ...) { #' @export signifString.default <- function(x, digits=6, sci_range=6, sci_sep="e", si_range, ...) { if (length(list(...))) { - stop("Additional, unsupported arguments were passed") + rlang::abort("Additional, unsupported arguments were passed", class = "pknca_error_unsupported_args") } if (!missing(si_range)) { .Deprecated(new="roundString with the sci_range argument", @@ -190,7 +192,8 @@ signifString.default <- function(x, digits=6, sci_range=6, sci_sep="e", si_range #' @return Either `zero_length` or `FUN(...)` #' @noRd zero_len_summary <- function(FUN) { - function(..., na.rm=FALSE, zero_length=NA) { #nocov + # nocov start + function(..., na.rm=FALSE, zero_length=NA) { x <- c(...) if (na.rm) { x <- stats::na.omit(x) @@ -200,7 +203,8 @@ zero_len_summary <- function(FUN) { } else { FUN(x) } - } #nocov + } + # nocov end } #' @describeIn zero_len_summary Find the maximum value with a different value if diff --git a/R/half.life.R b/R/half.life.R index b84c77a5..d0532585 100644 --- a/R/half.life.R +++ b/R/half.life.R @@ -156,7 +156,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, tobit_optim_control <- PKNCA.choose.option(name="tobit_optim_control", value=tobit_optim_control, options=options) if (is.null(lloq)) { - stop("lloq must be provided when hl_method is 'tobit'") + rlang::abort("lloq must be provided when hl_method is 'tobit'", class = "pknca_error_lloq_required_tobit") } } @@ -279,7 +279,10 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, attr(ret, "exclude") <- "Negative half-life estimated with manually-selected points" } } else { - warning("No data to manually fit for half-life (all concentrations may be 0 or excluded)") + rlang::warn( + "No data to manually fit for half-life (all concentrations may be 0 or excluded)", + class = "pknca_warning_no_halflife_data" + ) ret <- structure( ret, exclude = "No data to manually fit for half-life (all concentrations may be 0 or excluded)" @@ -316,10 +319,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, mask_best <- half_lives_for_selection$lambda.z > 0 & if (min.hl.points == 2 && nrow(half_lives_for_selection) == 2) { - rlang::warn( - message = "2 points used for half-life calculation", - class = "pknca_halflife_2points" - ) + rlang::warn("2 points used for half-life calculation", class = "pknca_warning_halflife_2points") TRUE } else { half_lives_for_selection$adj.r.squared > @@ -341,10 +341,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, "Too few points for half-life calculation (min.hl.points=%g with only %g points)", min.hl.points, nrow(dfK) ) - rlang::warn( - message = attr(ret, "exclude"), - class = "pknca_halflife_too_few_points" - ) + rlang::warn(attr(ret, "exclude"), class = "pknca_warning_halflife_too_few_points") } # ---- Tobit method ---- @@ -376,7 +373,10 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, attr(ret, "exclude") <- "Negative half-life estimated with manually-selected points" } } else { - warning("No data to manually fit for half-life (all concentrations may be 0 or excluded)") + rlang::warn( + "No data to manually fit for half-life (all concentrations may be 0 or excluded)", + class = "pknca_warning_no_halflife_data_tobit" + ) ret <- structure( ret, exclude = "No data to manually fit for half-life (all concentrations may be 0 or excluded)" @@ -425,10 +425,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, "Too few above-LLOQ points for Tobit half-life (min.hl.points=%g with only %g above-LLOQ points)", min.hl.points, n_above_lloq ) - rlang::warn( - message = attr(ret, "exclude"), - class = "pknca_halflife_too_few_points" - ) + rlang::warn(attr(ret, "exclude"), class = "pknca_warning_halflife_too_few_points_tobit") } } @@ -547,8 +544,8 @@ fit_half_life_tobit <- function(data, tlast, optim_control = list()) { # Guard: need at least 2 above-LLOQ points for initial parameter estimation if (length(above_lloq_log_conc) < 2) { rlang::warn( - message = "Too few above-LLOQ points for Tobit half-life initial parameter estimation", - class = "pknca_tobit_too_few_points" + "Too few above-LLOQ points for Tobit half-life initial parameter estimation", + class = "pknca_warning_tobit_too_few_points" ) return(na_ret) } @@ -556,8 +553,8 @@ fit_half_life_tobit <- function(data, tlast, optim_control = list()) { sd_above <- stats::sd(above_lloq_log_conc) if (!is.finite(sd_above) || sd_above == 0) { rlang::warn( - message = "No variability in above-LLOQ concentrations for Tobit half-life fit", - class = "pknca_tobit_no_variability" + "No variability in above-LLOQ concentrations for Tobit half-life fit", + class = "pknca_warning_tobit_no_variability" ) return(na_ret) } @@ -586,10 +583,8 @@ fit_half_life_tobit <- function(data, tlast, optim_control = list()) { # code 0 = converged; any other code = failure if (fit$convergence != 0) { rlang::warn( - message = paste0( - "Tobit half-life optimization did not converge (code ", fit$convergence, ")" - ), - class = "pknca_tobit_no_convergence" + sprintf("Tobit half-life optimization did not converge (code %s)", fit$convergence), + class = "pknca_warning_tobit_no_convergence" ) return(na_ret) } @@ -863,9 +858,12 @@ get_halflife_points.PKNCAresults <- function(object) { rowid_col = rowid_col ) if (any(!is.na(ret[ret_current$rowid]))) { - stop( - "More than one half-life calculation was attempted on the following rows: ", - paste(ret_current$rowid, collapse = ", ") + rlang::abort( + sprintf( + "More than one half-life calculation was attempted on the following rows: %s", + paste(ret_current$rowid, collapse = ", ") + ), + class = "pknca_error_duplicate_halflife_rows" ) } ret[ret_current$rowid] <- ret_current$hl_used diff --git a/R/impute.R b/R/impute.R index 1127a291..44364a59 100644 --- a/R/impute.R +++ b/R/impute.R @@ -1,10 +1,12 @@ #' Get the impute function from either the intervals column or from the method #' #' @param intervals the data.frame of intervals -#' @param impute the imputation definition +#' @param impute the imputation definition -- either the name of a column in +#' `intervals` (character scalar) or `NA` to look for a generic `"impute"` +#' column. Must be an atomic scalar; a list (even of length 1) is rejected. #' @return The imputation function vector get_impute_method <- function(intervals, impute) { - stopifnot(length(impute) == 1) + checkmate::assert_scalar(impute, na.ok = TRUE) checkmate::assert_data_frame(intervals) if (impute %in% names(intervals)) { impute_funs <- intervals[[impute]] @@ -124,9 +126,12 @@ PKNCA_impute_fun_list <- function(x) { } } if (length(bad_fun) > 0) { - stop( - "The following imputation functions were not found: ", - paste(bad_fun, collapse = ", ") + rlang::abort( + sprintf( + "The following imputation functions were not found: %s", + paste(bad_fun, collapse = ", ") + ), + class = "pknca_error_impute_funs_not_found" ) } ret diff --git a/R/interpolate.conc.R b/R/interpolate.conc.R index b9507bb3..702549cc 100644 --- a/R/interpolate.conc.R +++ b/R/interpolate.conc.R @@ -103,7 +103,7 @@ interp.extrap.conc <- function(conc, time, time.out, data <- data.frame(conc, time) } if (length(time.out) < 1) { - stop("time.out must be a vector with at least one element") + rlang::abort("time.out must be a vector with at least one element", class = "pknca_error_timeout_empty") } if (all(data$conc %in% 0)) { # tlast would be NA in this case, but if everything input is zero, then all @@ -114,9 +114,9 @@ interp.extrap.conc <- function(conc, time, time.out, ret <- rep(NA, length(time.out)) for (i in seq_len(length(time.out))) if (is.na(tlast)) { - stop("Please report a bug: tlast is NA; cannot interpolate/extrapolate") # nocov + rlang::abort("Please report a bug: tlast is NA; cannot interpolate/extrapolate", class = "pknca_error_internal_tlast_na") # nocov } else if (is.na(time.out[i])) { - warning("An interpolation/extrapolation time is NA") + rlang::warn("An interpolation/extrapolation time is NA", class = "pknca_warning_timeout_na") } else if (time.out[i] <= tlast) { ret[i] <- interpolate.conc( @@ -178,7 +178,10 @@ interpolate.conc <- function(conc, time, time.out, checkmate::assert_number(x=conc.origin, na.ok=TRUE) checkmate::assert_number(x=time.out, na.ok=FALSE) if (time.out > max(data$time)) { - stop("`interpolate.conc()` does not extrapolate, use `interp.extrap.conc()`") + rlang::abort( + "`interpolate.conc()` does not extrapolate, use `interp.extrap.conc()`", + class = "pknca_error_interpolate_beyond_maxtime" + ) } # Verify that we are interpolating between the first concentration # and the last above LOQ concentration @@ -188,8 +191,11 @@ interpolate.conc <- function(conc, time, time.out, } else if (all(data$conc == 0)) { ret <- 0 } else if (time.out > tlast) { - stop("`interpolate.conc()` only works through Tlast, please use `interp.extrap.conc()` to combine both interpolation and extrapolation.") - } else if (time.out %in% data$time) { + rlang::abort( + "`interpolate.conc()` only works through Tlast, please use `interp.extrap.conc()` to combine both interpolation and extrapolation.", + class = "pknca_error_interpolate_beyond_tlast" + ) + } else if (time.out %in% data$time) { # See if there is an exact time match and return that if it # exists. ret <- data$conc[time.out == data$time] @@ -220,7 +226,7 @@ interpolate.conc <- function(conc, time, time.out, } else if (interp_method == "zero") { 0 } else { - stop("Please report a bug: invalid interp_method") # nocov + rlang::abort("Please report a bug: invalid interp_method", class = "pknca_error_internal_invalid_interp_method") # nocov } } ret @@ -255,15 +261,18 @@ extrapolate.conc <- function(conc, time, time.out, } auc.type <- tolower(auc.type) if (!(auc.type %in% c("aucinf", "aucall", "auclast"))) - stop("`auc.type` must be one of 'AUCinf', 'AUClast', or 'AUCall'") + rlang::abort("`auc.type` must be one of 'AUCinf', 'AUClast', or 'AUCall'", class = "pknca_error_invalid_auc_type") if (length(time.out) != 1) - stop("Only one time.out value may be estimated at once.") + rlang::abort("Only one time.out value may be estimated at once.", class = "pknca_error_timeout_length") tlast <- pk.calc.tlast(conc=data$conc, time=data$time, check=FALSE) if (is.na(tlast)) { # If there are no observed concentrations, return NA ret <- NA } else if (time.out <= tlast) { - stop("extrapolate.conc can only work beyond Tlast, please use interp.extrap.conc to combine both interpolation and extrapolation.") + rlang::abort( + "extrapolate.conc can only work beyond Tlast, please use interp.extrap.conc to combine both interpolation and extrapolation.", + class = "pknca_error_extrapolate_before_tlast" + ) } else { # Start the interpolation if (auc.type %in% "aucinf") { @@ -302,7 +311,7 @@ extrapolate.conc <- function(conc, time, time.out, ) } } else { - stop("Invalid auc.type caught too late (seeing this error indicates a software bug)") # nocov + rlang::abort("Invalid auc.type caught too late (seeing this error indicates a software bug)", class = "pknca_error_invalid_auc_type_late") # nocov } } ret @@ -348,16 +357,25 @@ interp.extrap.conc.dose <- function(conc, time, route.dose <- as.character(route.dose) } if (!(all(route.dose %in% c("extravascular", "intravascular")))) { - stop("route.dose must be either 'extravascular' or 'intravascular'") + rlang::abort( + "route.dose must be either 'extravascular' or 'intravascular'", + class = "pknca_error_invalid_route_dose" + ) } if (!(length(route.dose) %in% c(1, length(time.dose)))) { - stop("route.dose must either be a scalar or the same length as time.dose") + rlang::abort( + "route.dose must either be a scalar or the same length as time.dose", + class = "pknca_error_route_dose_length" + ) } if (!all(is.na(duration.dose) | (is.numeric(duration.dose) & !is.factor(duration.dose)))) { - stop("duration.dose must be NA or a number.") + rlang::abort("duration.dose must be NA or a number.", class = "pknca_error_invalid_duration_dose") } if (!(length(duration.dose) %in% c(1, length(time.dose)))) { - stop("duration.dose must either be a scalar or the same length as time.dose") + rlang::abort( + "duration.dose must either be a scalar or the same length as time.dose", + class = "pknca_error_duration_dose_length" + ) } # Generate a single timeline @@ -404,11 +422,15 @@ interp.extrap.conc.dose <- function(conc, time, TRUE~"unknown") # should never happen if (any(mask_unknown <- data_all$event %in% "unknown")) { # All events should be accounted for already - stop( # nocov - "Unknown event in interp.extrap.conc.dose at time(s): ", # nocov - paste(unique(data_all$time[mask_unknown]), collapse=", "), # nocov - " (Please report this as a bug)" # nocov - ) # nocov + # nocov start + rlang::abort( + sprintf( + "Unknown event in interp.extrap.conc.dose at time(s): %s (Please report this as a bug)", + paste(unique(data_all$time[mask_unknown]), collapse = ", ") + ), + class = "pknca_error_internal_unknown_event" + ) + # nocov end } # Remove "output_only" from event_before and event_after simple_locf <- function(x, missing_val) { @@ -429,9 +451,14 @@ interp.extrap.conc.dose <- function(conc, time, do.call(interp.extrap.conc.dose.select[[nm]]$select, list(x=data_all)) if (any(mask)) { if ("warning" %in% names(interp.extrap.conc.dose.select[[nm]])) { - warning(sprintf("%s: %d data points", - interp.extrap.conc.dose.select[[nm]]$warning, - sum(mask))) + rlang::warn( + sprintf( + "%s: %d data points", + interp.extrap.conc.dose.select[[nm]]$warning, + sum(mask) + ), + class = "pknca_warning_interp_extrap_conc_dose" + ) data_all$method[mask] <- nm } else { for (current_idx in which(mask)) { @@ -448,8 +475,15 @@ interp.extrap.conc.dose <- function(conc, time, } if (any(mask_no_method <- is.na(data_all$method))) { # This should never happen, all eventualities should be covered - stop("No method for imputing concentration at time(s): ", # nocov - paste(unique(data_all$time[mask_no_method]), collapse=", ")) # nocov + # nocov start + rlang::abort( + sprintf( + "No method for imputing concentration at time(s): %s", + paste(unique(data_all$time[mask_no_method]), collapse = ", ") + ), + class = "pknca_error_no_interp_method" + ) + # nocov end } # Filter to the requested time points and output data_out <- data_all[data_all$out,,drop=FALSE] @@ -477,12 +511,17 @@ iecd_impossible_select <- function(x) { x$event_after %in% c("conc_dose_iv_bolus_after", "dose_iv_bolus_after")) } iecd_impossible_value <- function(data_all, current_idx, ...) { - stop(sprintf( # nocov - "Impossible combination requested for interp.extrap.conc.dose (please report this as a bug). event_before: %s, event: %s, event_after: %s", # nocov - data_all$event_before[current_idx], # nocov - data_all$event[current_idx], # nocov - data_all$event_after[current_idx] # nocov - )) # nocov + # nocov start + rlang::abort( + sprintf( + "Impossible combination requested for interp.extrap.conc.dose (please report this as a bug). event_before: %s, event: %s, event_after: %s", + data_all$event_before[current_idx], + data_all$event[current_idx], + data_all$event_after[current_idx] + ), + class = "pknca_error_internal_impossible_event_combination" + ) + # nocov end } # Observed concentration #### diff --git a/R/normalize.R b/R/normalize.R index c9337699..396585e5 100644 --- a/R/normalize.R +++ b/R/normalize.R @@ -38,21 +38,30 @@ normalize.data.frame <- function(object, norm_table, parameters, suffix) { paste(apply(missing_groups, 1, paste, collapse = "\t"), collapse = "\n"), sep = "\n" ) - stop( - "The normalization table contains groups not present in the data:\n", - df_error_string + rlang::abort( + sprintf( + "The normalization table contains groups not present in the data:\n%s", + df_error_string + ), + class = "pknca_error_norm_table_missing_groups" ) } # Check for duplicate groups if (any(duplicated(norm_table[, common_colnames, drop = FALSE]))) { - stop("The normalization table contains duplicate groups.") + rlang::abort( + "The normalization table contains duplicate groups.", + class = "pknca_error_norm_table_duplicate_groups" + ) } } else { # Ungrouped case if (nrow(norm_table) != 1) { - stop("Normalization table must be a single row for ungrouped data.") + rlang::abort( + "Normalization table must be a single row for ungrouped data.", + class = "pknca_error_norm_table_not_single_row" + ) } } @@ -105,12 +114,16 @@ normalize.data.frame <- function(object, norm_table, parameters, suffix) { #' @return A data.frame with normalized parameters #' @export normalize_by_col <- function(object, col, unit, parameters, suffix){ - if (!inherits(object, "PKNCAresults")) { - stop("The object must be a PKNCAresults object") - } + assert_PKNCAresults(object) obj_conc_cols <- names(as.data.frame(as_PKNCAconc(object))) if (!col %in% obj_conc_cols) { - stop("Column ", col, " not found in the PKNCAconc of the PKNCAresults object") + rlang::abort( + sprintf( + "Column %s not found in the PKNCAconc of the PKNCAresults object", + col + ), + class = "pknca_error_norm_col_not_found" + ) } conc_groups <- dplyr::group_vars(object$data$conc) if (unit %in% obj_conc_cols) { @@ -124,7 +137,10 @@ normalize_by_col <- function(object, col, unit, parameters, suffix){ } # Check there are no duplicate groups with different normalization values if (any(duplicated(norm_table[, conc_groups, drop = FALSE]))) { - stop("There is at least one concentration group with multiple normalization values") + rlang::abort( + "There is at least one concentration group with multiple normalization values", + class = "pknca_error_norm_multiple_values" + ) } normalize(object, norm_table, parameters, suffix) } diff --git a/R/parse_formula_to_cols.R b/R/parse_formula_to_cols.R index 6aff3bdb..652a9eba 100644 --- a/R/parse_formula_to_cols.R +++ b/R/parse_formula_to_cols.R @@ -25,7 +25,7 @@ findOperator <- function(x, op, side) { if (identical(x[[1]], op)) { # We found the operator if (length(x) == 1) { - stop("call or formula with length 1 found after finding the operator, unknown how to proceed") # nocov + rlang::abort("call or formula with length 1 found after finding the operator, unknown how to proceed", class = "pknca_error_formula_length1_after_op") # nocov } else if (length(x) == 2) { # Unary operators have a right hand side only if (side == "left") { @@ -35,7 +35,7 @@ findOperator <- function(x, op, side) { } else if (side == "both") { return(x) } - stop("Unknown side with a found unary operator") # nocov + rlang::abort("Unknown side with a found unary operator", class = "pknca_error_unknown_side_unary") # nocov } else if (length(x) == 3) { # Binary operator if (side == "left") { @@ -45,12 +45,15 @@ findOperator <- function(x, op, side) { } else if (side == "both") { return(x) } - stop("Unknown side with a found binary operator") # nocov + rlang::abort("Unknown side with a found binary operator", class = "pknca_error_unknown_side_binary") # nocov } } else { # Go down the left then right side of the tree if (length(x) == 1) - stop("call or formula with length 1 found without finding the operator, unknown how to proceed") + rlang::abort( + "call or formula with length 1 found without finding the operator, unknown how to proceed", + class = "pknca_error_formula_length1_no_op" + ) # First search the left side ret <- findOperator(x[[2]], op, side) if ((identical(ret, NA) || @@ -60,8 +63,10 @@ findOperator <- function(x, op, side) { } } else { # This should not happen-- find the class that the object is - stop(sprintf("Cannot handle class %s", - paste(class(x), sep=", "))) + rlang::abort( + sprintf("Cannot handle class %s", paste(class(x), collapse = ", ")), + class = "pknca_error_unhandled_class" + ) } ret } @@ -78,7 +83,7 @@ parse_formula_to_cols <- function(form) { form <- try({stats::as.formula(form)}, silent = TRUE) } if (!inherits(form, "formula")) { - stop("form must be a formula or coercable into one") + rlang::abort("form must be a formula or coercable into one", class = "pknca_error_form_not_formula") } rhs_raw <- findOperator(form, "~", "right") groups_raw <- findOperator(rhs_raw, "|", "right") diff --git a/R/pk.calc.all.R b/R/pk.calc.all.R index eb66d9cf..72e63a0a 100644 --- a/R/pk.calc.all.R +++ b/R/pk.calc.all.R @@ -20,7 +20,9 @@ pk.nca <- function(data, verbose=FALSE) { assert_PKNCAdata(data) results <- data.frame() if (nrow(data$intervals) > 0) { - if (verbose) message("Setting up options") + if (verbose) { + rlang::inform("Setting up options", class = "pknca_message_setup_options") + } # Merge the options into the default options. tmp_options <- PKNCA.options() tmp_options[names(data$options)] <- data$options @@ -33,7 +35,9 @@ pk.nca <- function(data, verbose=FALSE) { drop=FALSE ] # Calculate the results - if (verbose) message("Starting dense PK NCA calculations.") + if (verbose) { + rlang::inform("Starting dense PK NCA calculations.", class = "pknca_message_dense_pk_start") + } results_dense <- purrr::pmap( .l = list( @@ -48,10 +52,14 @@ pk.nca <- function(data, verbose=FALSE) { sparse = FALSE, .progress = data$options$progress ) - if (verbose) message("Combining completed dense PK calculation results.") + if (verbose) { + rlang::inform("Combining completed dense PK calculation results.", class = "pknca_message_dense_pk_combine") + } results <- pk_nca_result_to_df(group_info, results_dense) if (is_sparse_pk(data)) { - if (verbose) message("Starting sparse PK NCA calculations.") + if (verbose) { + rlang::inform("Starting sparse PK NCA calculations.", class = "pknca_message_sparse_pk_start") + } results_sparse <- purrr::pmap( .l=list( @@ -65,7 +73,9 @@ pk.nca <- function(data, verbose=FALSE) { verbose=verbose, sparse=TRUE ) - if (verbose) message("Combining completed sparse PK calculation results.") + if (verbose) { + rlang::inform("Combining completed sparse PK calculation results.", class = "pknca_message_sparse_pk_combine") + } results <- dplyr::bind_rows( results, @@ -114,18 +124,15 @@ pk_nca_result_to_df <- function(group_info, result) { X=seq_along(warning_preamble), FUN=function(idx) { warning_prep <- ret_warnings$data_result[[idx]] - warning_prep$message <- paste(warning_preamble[idx], warning_prep$message, sep=": ") - warning(warning_prep) + warning_prep$message <- sprintf("%s: %s", warning_preamble[idx], warning_prep$message) + rlang::warn(warning_prep$message, class = c("pknca_warning_parameter_calculation", class(warning_prep))) } )) } ret_nowarning <- ret[!mask_warning, ] # Generate the outputs if (nrow(ret_nowarning) == 0) { - rlang::warn( - message = "All results generated warnings or errors; no results generated", - class = "pknca_all_warnings_no_results" - ) + rlang::warn("All results generated warnings or errors; no results generated", class = "pknca_warning_no_results") results <- data.frame() } else { results <- tidyr::unnest(ret_nowarning, cols="data_result") @@ -191,10 +198,10 @@ pk.nca.intervals <- function(data_conc, data_dose, data_intervals, sparse, options, impute, verbose=FALSE) { if (is.null(data_conc) || (nrow(data_conc) == 0)) { # No concentration data; potentially placebo data - return(rlang::warning_cnd(class="pknca_no_conc_data", message="No concentration data")) + return(rlang::warning_cnd(class="pknca_warning_no_conc_data", message="No concentration data")) } else if (is.null(data_intervals) || (nrow(data_intervals) == 0)) { # No intervals; potentially placebo data - return(rlang::warning_cnd(class="pknca_no_intervals", message="No intervals for data")) + return(rlang::warning_cnd(class="pknca_warning_no_intervals", message="No intervals for data")) } # Sort the group-level concentration data in time order. The interval-level # data are sorted below (per interval), but the group-level data are passed @@ -243,9 +250,17 @@ pk.nca.intervals <- function(data_conc, data_dose, data_intervals, sparse, sep="=", collapse=", ") ) if (nrow(conc_data_interval) == 0) { - warning(paste(error_preamble, "No data for interval", sep=": ")) + rlang::warn(sprintf("%s: No data for interval", error_preamble), class = "pknca_warning_no_data_for_interval") } else if (!has_calc_sparse_dense) { - if (verbose) message("No ", ifelse(sparse, "sparse", "dense"), " calculations requested for an interval") + if (verbose) { + rlang::inform( + sprintf( + "No %s calculations requested for an interval", + if (sparse) "sparse" else "dense" + ), + class = "pknca_message_no_interval_calculations" + ) + } } else { impute_method <- get_impute_method(intervals = current_interval, impute = impute) args <- list( @@ -289,7 +304,10 @@ pk.nca.intervals <- function(data_conc, data_dose, data_intervals, sparse, args$lloq <- conc_data_interval$lloq } if (uses_include_hl && uses_exclude_hl) { - stop("Cannot both include and exclude half-life points for the same interval") + rlang::abort( + "Cannot both include and exclude half-life points for the same interval", + class = "pknca_error_include_exclude_halflife" + ) } # Try the calculation if (use_debug) { @@ -299,9 +317,8 @@ pk.nca.intervals <- function(data_conc, data_dose, data_intervals, sparse, calculated_interval <- tryCatch( do.call(pk.nca.interval, args), - error=function(e) { - e$message <- paste("Please report a bug.\n", error_preamble, e$message, sep=": ") # nocov - stop(e) # nocov + error = function(e) { + rlang::abort(sprintf("Please report a bug.\n%s: %s", error_preamble, e$message), class = "pknca_error_interval_calculation", parent = e) # nocov } ) } @@ -377,12 +394,13 @@ pk.nca.interval <- function(conc, time, volume, duration.conc, impute_method=NA_character_, include_half.life=NULL, exclude_half.life=NULL, lloq=NULL, subject, sparse, interval, options=list()) { - if (!is.data.frame(interval)) { - stop("Please report a bug. Interval must be a data.frame") - } - if (nrow(interval) != 1) { - stop("Please report a bug. Interval must be a one-row data.frame") + if (!checkmate::test_data_frame(interval, nrows = 1)) { + rlang::abort( + "Please report a bug. Interval must be a one-row data.frame", + class = "pknca_error_internal_interval_not_one_row_df" + ) } + if (!all(is.na(impute_method))) { impute_funs <- PKNCA_impute_fun_list(impute_method) stopifnot(length(impute_funs) == 1) @@ -411,7 +429,7 @@ pk.nca.interval <- function(conc, time, volume, duration.conc, all_intervals <- get.interval.cols() # Set the dose to NA if its length is zero if (length(dose) == 0) { - stop("Please report a bug. Length of dose should not be zero.") # nocov + rlang::abort("Please report a bug. Length of dose should not be zero.", class = "pknca_error_internal_dose_length_zero") # nocov } # Make sure that we calculate all of the dependencies. Do this in # reverse order for dependencies of dependencies. @@ -503,10 +521,13 @@ pk.nca.interval <- function(conc, time, volume, duration.conc, } else { sprintf("'%s' mapped to '%s'", arg_formal, arg_mapped) } - stop(sprintf( - "Cannot find argument %s for NCA function '%s'", - arg_text, all_intervals[[n]]$FUN) - ) # nocov end + rlang::abort( + sprintf( + "Cannot find argument %s for NCA function '%s'", + arg_text, all_intervals[[n]]$FUN + ), # nocov end + class = "pknca_error_missing_nca_argument" + ) } } } diff --git a/R/pk.calc.c0.R b/R/pk.calc.c0.R index 3fa141b2..80006d0e 100644 --- a/R/pk.calc.c0.R +++ b/R/pk.calc.c0.R @@ -25,22 +25,18 @@ pk.calc.c0 <- function(conc, time, time.dose=0, if (check) { assert_conc_time(conc = conc, time = time) } - if (length(time.dose) != 1) { - stop("time.dose must be a scalar") - } else if (!is.numeric(time.dose) || is.factor(time.dose)) { - stop("time.dose must be a number") - } + checkmate::assert_number(time.dose, na.ok = TRUE, finite = FALSE) if (is.na(time.dose)) { - warning("time.dose is NA") + rlang::warn("time.dose is NA", class = "pknca_warning_timedose_na") return(structure(NA_real_, exclude = "dose time is missing")) } else if (time.dose > max(time)) { - warning("time.dose is after all available data") + rlang::warn("time.dose is after all available data", class = "pknca_warning_timedose_after_data") return(structure(NA_real_, exclude = "dose time is after all available concentration data")) } method <- match.arg(method, several.ok=TRUE) # Find the value ret <- NA - while (is.na(ret) & + while (is.na(ret) && length(method) > 0) { current.method <- method[1] method <- method[-1] diff --git a/R/pk.calc.simple.R b/R/pk.calc.simple.R index 8b191ea9..a0bfe61b 100644 --- a/R/pk.calc.simple.R +++ b/R/pk.calc.simple.R @@ -9,10 +9,7 @@ #' @export adj.r.squared <- function(r.sq, n) { if (n <= 2) { - rlang::warn( - message = "n must be > 2 for adj.r.squared", - class = "pknca_adjr2_2points" - ) + rlang::warn("n must be > 2 for adj.r.squared", class = "pknca_warning_adjr2_2points") structure(NA_real_, exclude="n must be > 2") } else { 1-(1-r.sq)*(n-1)/(n-2) @@ -381,7 +378,10 @@ pk.calc.aucpext <- function(auclast, aucinf) { # no length checking needs to occur } else if ((!scalar_auclast && !scalar_aucinf) && length(auclast) != length(aucinf)) { - stop("auclast and aucinf must either be a scalar or the same length.") + rlang::abort( + "auclast and aucinf must either be a scalar or the same length.", + class = "pknca_error_auclast_aucinf_length" + ) } ret <- rep(NA_real_, max(c(length(auclast), length(aucinf)))) mask_na <- @@ -397,13 +397,13 @@ pk.calc.aucpext <- function(auclast, aucinf) { mask_calc <- !mask_na & !(aucinf %in% 0) if (any(mask_greater)) rlang::warn( - message = "aucpext is typically only calculated when aucinf is greater than auclast.", - class = "pknca_aucpext_aucinf_le_auclast" + "aucpext is typically only calculated when aucinf is greater than auclast.", + class = "pknca_warning_aucpext_aucinf_le_auclast" ) if (any(mask_negative)) rlang::warn( - message = "aucpext is typically only calculated when both aucinf and auclast are positive.", - class = "pknca_aucpext_aucinf_auclast_positive" + "aucpext is typically only calculated when both aucinf and auclast are positive.", + class = "pknca_warning_aucpext_aucinf_auclast_positive" ) ret[mask_calc] <- 100*(1-auclast[mask_calc]/aucinf[mask_calc]) @@ -1071,7 +1071,7 @@ pk.calc.vz <- function(cl, lambda.z) { # likely errors here). if (!(length(cl) %in% c(1, length(lambda.z))) || !(length(lambda.z) %in% c(1, length(cl)))) - stop("'cl' and 'lambda.z' must be the same length") + rlang::abort("'cl' and 'lambda.z' must be the same length", class = "pknca_error_cl_lambdaz_length") cl/lambda.z } @@ -1444,10 +1444,10 @@ add.interval.col( pretty_name = "Cav", desc = "The average concentration during an interval (calculated with AUClast)", depends = "auclast", - formalsmap = list(auc = "auclast") - , + formalsmap = list(auc = "auclast"), pptestcd_cdisc="CAVG", pptest_cdisc="Average Conc") + add.interval.col( "cav.int.last", FUN = "pk.calc.cav", @@ -1457,7 +1457,6 @@ add.interval.col( desc = "The average concentration during an interval (calculated with AUCint.last)", depends = "aucint.last", formalsmap = list(auc = "aucint.last"), - , pptestcd_cdisc="CAVGINT", pptest_cdisc="Average Conc from T1 to T2") add.interval.col( @@ -1469,7 +1468,6 @@ add.interval.col( desc = "The average concentration during an interval (calculated with AUCint.all)", depends = "aucint.all", formalsmap = list(auc = "aucint.all"), - , pptestcd_cdisc="CAVGINA", pptest_cdisc="Cavg All") add.interval.col( @@ -1481,7 +1479,6 @@ add.interval.col( desc = "The average concentration during an interval (calculated with AUCint.inf.obs)", depends = "aucint.inf.obs", formalsmap = list(auc = "aucint.inf.obs"), - , pptestcd_cdisc="CAVGINO", pptest_cdisc="Cavg Infinity Obs") add.interval.col( @@ -1493,7 +1490,6 @@ add.interval.col( desc = "The average concentration during an interval (calculated with AUCint.inf.pred)", depends = "aucint.inf.pred", formalsmap = list(auc = "aucint.inf.pred"), - , pptestcd_cdisc="CAVGINP", pptest_cdisc="Cavg Infinity Pred") @@ -1515,7 +1511,7 @@ pk.calc.ctrough <- function(conc, time, end) { } else { # This should be impossible as assert_conc_time should catch # duplicates. - stop("More than one time matches the starting time. Please report this as a bug with a reproducible example.") # nocov + rlang::abort("More than one time matches the starting time. Please report this as a bug with a reproducible example.", class = "pknca_error_ctrough_multiple_start_times") # nocov } } add.interval.col("ctrough", @@ -1543,7 +1539,7 @@ pk.calc.cstart <- function(conc, time, start) { } else { # This should be impossible as assert_conc_time should catch # duplicates. - stop("More than one time matches the starting time. Please report this as a bug with a reproducible example.") # nocov + rlang::abort("More than one time matches the starting time. Please report this as a bug with a reproducible example.", class = "pknca_error_cstart_multiple_start_times") # nocov } } add.interval.col("cstart", @@ -1699,11 +1695,13 @@ add.interval.col("ceoi", #' Concentrations below the given concentration (`conc_above`) will be set #' to zero. #' @inheritParams pk.calc.time_above +#' @param conc_above The concentration threshold to calculate AUC above. +#' Must be finite (`Inf`/`-Inf` are not allowed); if `NA`, no AUC is +#' calculated. #' @returns The AUC of the concentration above the limit #' @export pk.calc.aucabove <- function(conc, time, conc_above = NA_real_, ..., options=list()) { - stopifnot(length(conc_above) == 1) - stopifnot(is.numeric(conc_above)) + checkmate::assert_number(conc_above, na.ok = TRUE, finite = TRUE) if (is.na(conc_above)) { ret <- structure(NA_real_, exclude = "Missing concentration to be above") } else { @@ -1723,8 +1721,7 @@ add.interval.col( pretty_name="AUC,above", desc="The area under the concentration time the beginning of the interval to the last concentration above the limit of quantification plus the triangle from that last concentration to 0 at the first concentration below the limit of quantification, with a concentration subtracted from all concentrations and values below zero after subtraction set to zero", depends="cstart", - formalsmap = list(conc_above = "cstart") - , + formalsmap = list(conc_above = "cstart"), pptestcd_cdisc="AUCABVPA", pptest_cdisc="AUC above predose") @@ -1735,8 +1732,7 @@ add.interval.col( pretty_name="AUC,above", desc="The area under the concentration time the beginning of the interval to the last concentration above the limit of quantification plus the triangle from that last concentration to 0 at the first concentration below the limit of quantification, with a concentration subtracted from all concentrations and values below zero after subtraction set to zero", depends="ctrough", - formalsmap = list(conc_above = "ctrough") - , + formalsmap = list(conc_above = "ctrough"), pptestcd_cdisc="AUCABVTA", pptest_cdisc="AUC above trough") @@ -1767,8 +1763,7 @@ add.interval.col( unit_type = "count", pretty_name = "Concentration count", desc = "Number of non-missing concentrations for an interval", - depends = NULL - , + depends = NULL, pptestcd_cdisc="CNTCONC", pptest_cdisc="Concentration count") @@ -1811,8 +1806,7 @@ add.interval.col( values=c(FALSE, TRUE), unit_type="dose", pretty_name="Total dose", - desc="Total dose administered during an interval" - , + desc="Total dose administered during an interval", pptestcd_cdisc="TDOSE", pptest_cdisc="Total dose administered") @@ -1954,13 +1948,3 @@ PKNCA.set.summary( point = business.geomean, spread = business.geocv ) - -PKNCA.set.summary( - name = c( - "cl.sparse.last", "kel.sparse.last", "mrt.sparse.last", "vss.sparse.last", - "vz.sparse.last" - ), - description = "geometric mean and geometric coefficient of variation", - point = business.geomean, - spread = business.geocv -) \ No newline at end of file diff --git a/R/pk.calc.urine.R b/R/pk.calc.urine.R index 1ee6479c..4a95bdd2 100644 --- a/R/pk.calc.urine.R +++ b/R/pk.calc.urine.R @@ -13,15 +13,9 @@ add.interval.col("volpk", values=c(FALSE, TRUE), unit_type="volume", pretty_name="Total Urine Volume", - desc="The sum of urine volumes for the interval", - pptestcd_cdisc="VOLPK", - pptest_cdisc="Volume of PK sample") -PKNCA.set.summary( - name="volpk", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) + desc="The sum of urine volumes for the interval", + pptestcd_cdisc="VOLPK", + pptest_cdisc="Volume of PK sample") #' Calculate amount excreted (typically in urine or feces) #' @@ -54,15 +48,9 @@ add.interval.col("ae", values=c(FALSE, TRUE), unit_type="amount", pretty_name="Amount excreted", - desc="The amount excreted (typically into urine or feces)", - pptestcd_cdisc="RCAMINT", - pptest_cdisc="Amt Rec from T1 to T2") -PKNCA.set.summary( - name="ae", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) + desc="The amount excreted (typically into urine or feces)", + pptestcd_cdisc="RCAMINT", + pptest_cdisc="Amt Rec from T1 to T2") #' Calculate renal clearance #' @@ -86,15 +74,10 @@ add.interval.col("clr.last", pretty_name="Renal clearance (from AUClast)", formalsmap=list(auc="auclast"), depends="ae", - desc="The renal clearance calculated using AUClast", - pptestcd_cdisc="RENALCL", - pptest_cdisc="Renal CL") -PKNCA.set.summary( - name="clr.last", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) + desc="The renal clearance calculated using AUClast", + pptestcd_cdisc="RENALCL", + pptest_cdisc="Renal CL") + add.interval.col("clr.obs", FUN="pk.calc.clr", values=c(FALSE, TRUE), @@ -102,15 +85,10 @@ add.interval.col("clr.obs", pretty_name="Renal clearance (from AUCinf,obs)", formalsmap=list(auc="aucinf.obs"), depends="ae", - desc="The renal clearance calculated using AUCinf,obs", - pptestcd_cdisc="RENALCL", - pptest_cdisc="Renal CL") -PKNCA.set.summary( - name="clr.obs", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) + desc="The renal clearance calculated using AUCinf,obs", + pptestcd_cdisc="RENALCL", + pptest_cdisc="Renal CL") + add.interval.col("clr.pred", FUN="pk.calc.clr", values=c(FALSE, TRUE), @@ -118,15 +96,10 @@ add.interval.col("clr.pred", pretty_name="Renal clearance (from AUCinf,pred)", formalsmap=list(auc="aucinf.pred"), depends="ae", - desc="The renal clearance calculated using AUCinf,pred", - pptestcd_cdisc="RENALCL", - pptest_cdisc="Renal CL") -PKNCA.set.summary( - name="clr.pred", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) + desc="The renal clearance calculated using AUCinf,pred", + pptestcd_cdisc="RENALCL", + pptest_cdisc="Renal CL") + #' Calculate fraction excreted (typically in urine or feces) #' @@ -149,15 +122,9 @@ add.interval.col("fe", pretty_name="Fraction excreted", values=c(FALSE, TRUE), depends="ae", - desc="The fraction of the dose excreted", - pptestcd_cdisc="FREXINT", - pptest_cdisc="Fract Excr from T1 to T2") -PKNCA.set.summary( - name="fe", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) + desc="The fraction of the dose excreted", + pptestcd_cdisc="FREXINT", + pptest_cdisc="Fract Excr from T1 to T2") #' Calculate the midpoint collection time of the last measurable excretion rate #' @@ -199,16 +166,10 @@ add.interval.col("ertlst", FUN="pk.calc.ertlst", unit_type="time", pretty_name="Tlast excretion rate", - desc="The midpoint collection time of the last measurable excretion rate (typically in urine or feces)", - pptestcd_cdisc="ERTLST", - pptest_cdisc="Time of Last Excretion Rate") + desc="The midpoint collection time of the last measurable excretion rate (typically in urine or feces)", + pptestcd_cdisc="ERTLST", + pptest_cdisc="Time of Last Excretion Rate") -PKNCA.set.summary( - name="ertlst", - description="median and range", - point=business.median, - spread=business.range -) #' Calculate the maximum excretion rate #' @@ -249,16 +210,10 @@ add.interval.col("ermax", FUN="pk.calc.ermax", unit_type="amount_time", pretty_name="Maximum excretion rate", - desc="The maximum excretion rate (typically in urine or feces)", - pptestcd_cdisc="ERMAX", - pptest_cdisc="Max Excretion Rate") + desc="The maximum excretion rate (typically in urine or feces)", + pptestcd_cdisc="ERMAX", + pptest_cdisc="Max Excretion Rate") -PKNCA.set.summary( - name="ermax", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) #' Calculate the midpoint collection time of the maximum excretion rate #' @@ -306,17 +261,23 @@ add.interval.col("ertmax", FUN="pk.calc.ertmax", unit_type="time", pretty_name="Tmax excretion rate", - desc="The midpoint collection time of the maximum excretion rate (typically in urine or feces)", - pptestcd_cdisc="ERTMAX", - pptest_cdisc="Midpoint of Interval of Maximum ER") + desc="The midpoint collection time of the maximum excretion rate (typically in urine or feces)", + pptestcd_cdisc="ERTMAX", + pptest_cdisc="Midpoint of Interval of Maximum ER") PKNCA.set.summary( - name="ertmax", - description="median and range", - point=business.median, - spread=business.range + name = c("volpk", "ae", "clr.last", "clr.obs", "clr.pred", "fe", "ermax"), + description = "geometric mean and geometric coefficient of variation", + point = business.geomean, + spread = business.geocv ) +PKNCA.set.summary( + name = c("ertlst", "ertmax"), + description = "median and range", + point = business.median, + spread = business.range +) # Helper to generate missing-data checking messages for paired vectors diff --git a/R/prepare_data.R b/R/prepare_data.R index 2fd0125b..58ef0be3 100644 --- a/R/prepare_data.R +++ b/R/prepare_data.R @@ -13,12 +13,15 @@ #' @keywords Internal #' @noRd full_join_PKNCAconc_PKNCAdose <- function(o_conc, o_dose, extra_cols_conc = character()) { - stopifnot(inherits(x=o_conc, what="PKNCAconc")) + checkmate::assert_class(o_conc, "PKNCAconc") if (identical(o_dose, NA)) { - message("No dose information provided, calculations requiring dose will return NA.") + rlang::inform( + "No dose information provided, calculations requiring dose will return NA.", + class = "pknca_message_missing_dose" + ) n_dose <- tibble::tibble(data_dose=list(NA)) } else { - stopifnot(inherits(x=o_dose, what="PKNCAdose")) + checkmate::assert_class(o_dose, "PKNCAdose") n_dose <- prepare_PKNCAdose(o_dose, sparse=is_sparse_pk(o_conc), subject_col=o_conc$columns$subject) } n_conc <- prepare_PKNCAconc(o_conc, extra_cols = extra_cols_conc) @@ -207,9 +210,12 @@ prepare_PKNCAdose <- function(.dat, sparse, subject_col) { } else { "Not all subjects have the same dosing information." } - stop( - "With sparse PK, all subjects in a group must have the same dosing information.\n", - msg_error + rlang::abort( + sprintf( + "With sparse PK, all subjects in a group must have the same dosing information.\n%s", + msg_error + ), + class = "pknca_error_sparse_dose_mismatch" ) } } @@ -281,7 +287,7 @@ check_reserved_column_names <- function(x) { ngettext(length(overlap), msg1="name", msg2="names"), "and retry." ) - stop(msg) + rlang::abort(msg, class = "pknca_error_reserved_column_names") } } @@ -296,25 +302,30 @@ check_reserved_column_names <- function(x) { #' @noRd #' @keywords Internal standardize_column_names <- function(x, cols, group_cols=NULL, insert_if_missing=list()) { - stopifnot("cols must be a list"=is.list(cols)) - stopifnot("cols must be named"=!is.null(names(cols))) - stopifnot("all cols must be named"=!any(names(cols) %in% "")) - stopifnot("all original cols names must be names of x"=all(unlist(cols) %in% names(x))) - stopifnot("group_cols must be NULL or a character vector"=is.null(group_cols) || is.character(group_cols)) + checkmate::assert_list(cols, .var.name = "cols") + checkmate::assert_named(cols, .var.name = "cols") + checkmate::assert_subset(unlist(cols), choices = names(x), .var.name = "cols") + checkmate::assert_character(group_cols, null.ok = TRUE,.var.name = "group_cols") if (!is.null(group_cols) && (length(group_cols) > 0)) { # Give a clear error message if group columns overlap mask_overlap_colvalues <- group_cols %in% unlist(cols) mask_overlap_colnames <- group_cols %in% names(cols) if (any(mask_overlap_colvalues)) { - stop( - "group_cols must not overlap with other column names. Change the name of the following groups: ", - paste(group_cols[mask_overlap_colvalues], collapse=", ") + rlang::abort( + sprintf( + "group_cols must not overlap with other column names. Change the name of the following groups: %s", + paste(group_cols[mask_overlap_colvalues], collapse = ", ") + ), + class = "pknca_error_group_cols_overlap_values" ) } if (any(mask_overlap_colnames)) { - stop( - "group_cols must not overlap with standardized column names. Change the name of the following groups: ", - paste(group_cols[mask_overlap_colnames], collapse=", ") + rlang::abort( + sprintf( + "group_cols must not overlap with standardized column names. Change the name of the following groups: %s", + paste(group_cols[mask_overlap_colnames], collapse = ", ") + ), + class = "pknca_error_group_cols_overlap_names" ) } new_group_cols <- paste0("group", seq_along(group_cols)) @@ -341,11 +352,10 @@ restore_group_col_names <- function(x, group_cols=NULL) { return(x) } new_group_cols <- paste0("group", seq_along(group_cols)) - stopifnot("missing intermediate group_cols names"=all(new_group_cols %in% names(x))) - stopifnot( - "Intermediate group_cols are out of order"= - all(names(x)[names(x) %in% new_group_cols] == new_group_cols) - ) + if (!all(new_group_cols %in% names(x))) + rlang::abort("missing intermediate group_cols names", class = "pknca_error_missing_group_cols") + if (!all(names(x)[names(x) %in% new_group_cols] == new_group_cols)) + rlang::abort("Intermediate group_cols are out of order", class = "pknca_error_group_cols_order") names(x)[names(x) %in% new_group_cols] <- group_cols x } diff --git a/R/provenance.R b/R/provenance.R index 6840247c..9e0ea1a8 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -23,7 +23,10 @@ addProvenance <- function(object, replace=FALSE) { attr(object, "provenance")$hash <- digest::digest(as.character(object), serialize=FALSE) } else { - stop("object already has provenance and the option to replace it was not selected.") + rlang::abort( + "object already has provenance and the option to replace it was not selected.", + class = "pknca_error_provenance_already_exists" + ) } object } diff --git a/R/set_and_assert_intervals.R b/R/set_and_assert_intervals.R index 19d42ab1..a2529245 100644 --- a/R/set_and_assert_intervals.R +++ b/R/set_and_assert_intervals.R @@ -33,14 +33,9 @@ set_intervals <- function(data, intervals) { #' #' @export assert_intervals <- function(intervals, data) { - if (!is.data.frame(intervals)) { - stop("The 'intervals' argument must be a data frame or a data frame-like object.") - } - - if (!inherits(data, "PKNCAdata")) { - stop("The 'data' argument must be a PKNCAdata object.") - } - + checkmate::assert_data_frame(intervals) + checkmate::assert_class(data, classes = "PKNCAdata", .var.name = "data") + allowed_columns <- c( names(getGroups.PKNCAdata(data)), @@ -55,7 +50,13 @@ assert_intervals <- function(intervals, data) { invalid_columns <- setdiff(names(intervals), allowed_columns) if (length(invalid_columns) > 0) { - stop("The following columns in 'intervals' are not allowed: ", paste(invalid_columns, collapse = ", ")) + rlang::abort( + sprintf( + "The following columns in 'intervals' are not allowed: %s", + paste(invalid_columns, collapse = ", ") + ), + class = "pknca_error_invalid_interval_columns" + ) } intervals diff --git a/R/sparse.R b/R/sparse.R index dcbb32f6..49bff1f8 100644 --- a/R/sparse.R +++ b/R/sparse.R @@ -43,11 +43,16 @@ as_sparse_pk <- function(conc, time, subject) { #' @keywords Internal sparse_pk_attribute <- function(sparse_pk, ...) { args <- list(...) - stopifnot(length(args) == 1) + checkmate::assert_list(args, len = 1) if (is.null(names(args))) { vapply(X=sparse_pk, FUN="[[", args[[1]], FUN.VALUE = 1) } else { - stopifnot(length(args[[1]]) == length(sparse_pk)) + if (length(args[[1]]) != length(sparse_pk)) { + rlang::abort( + "The length of the argument must match the length of sparse_pk", + class = "pknca_error_sparse_pk_attribute_length" + ) + } for (idx in seq_along(sparse_pk)) { sparse_pk[[idx]][names(args)[1]] <- args[[1]][idx] } @@ -127,7 +132,13 @@ sparse_mean <- function(sparse_pk, sparse_mean_method=c("arithmetic mean, <=50% } else if (sparse_mean_method == "arithmetic mean") { # do nothing } else { - stop("Invalid sparse_mean_method: ", sparse_mean_method) # nocov + rlang::abort( + sprintf( + "Invalid sparse_mean_method: %s", + sparse_mean_method + ), + class = "pknca_error_invalid_sparse_mean_method" + ) } sparse_pk <- sparse_pk_attribute(sparse_pk, mean=ret) sparse_pk <- sparse_pk_attribute(sparse_pk, mean_method=rep(sparse_mean_method, length(ret))) @@ -180,8 +191,8 @@ var_sparse_auc <- function(sparse_pk) { sum(weights^4 * diag(covariance)^2/(n^2*(n-1))) if (sum(covariance[lower.tri(covariance)] != 0) > 0) { rlang::warn( - message = "Cannot yet calculate sparse degrees of freedom for multiple samples per subject", - class = "pknca_sparse_df_multi" + "Cannot yet calculate sparse degrees of freedom for multiple samples per subject", + class = "pknca_warning_sparse_df_multi" ) df <- NA_real_ } @@ -310,10 +321,7 @@ pk.calc.sparse_auc <- function(conc, time, subject, # argument so it is used consistently below (and so other methods could be # enabled here in the future), but only "linear" is currently allowed. if (!identical(method, "linear")) { - rlang::abort( - message = 'Sparse AUC calculation only supports `method = "linear"`.', - class = "pknca_sparse_method" - ) + rlang::abort('Sparse AUC calculation only supports `method = "linear"`.', class = "pknca_error_sparse_auc_method") } sparse_pk <- as_sparse_pk(conc=conc, time=time, subject=subject) sparse_pk_wt <- sparse_auc_weight_linear(sparse_pk) @@ -347,8 +355,8 @@ pk.calc.sparse_auc <- function(conc, time, subject, pk.calc.sparse_auclast <- function(conc, time, subject, ..., options=list()) { if ("auc.type" %in% names(list(...))) { rlang::abort( - message = "auc.type cannot be changed when calling pk.calc.sparse_auclast, please use pk.calc.sparse_auc", - class = "pknca_sparse_auclast_change_auclast" + "auc.type cannot be changed when calling pk.calc.sparse_auclast, please use pk.calc.sparse_auc", + class = "pknca_error_sparse_auclast_change_auclast" ) } ret <- @@ -487,8 +495,8 @@ var_sparse_aumc <- function(sparse_pk) { if (sum(covariance[lower.tri(covariance)] != 0) > 0) { rlang::warn( - message = "Cannot yet calculate sparse degrees of freedom for multiple samples per subject", - class = "pknca_sparse_df_multi" + "Cannot yet calculate sparse degrees of freedom for multiple samples per subject", + class = "pknca_warning_sparse_aumc_df_multi" ) df <- NA_real_ } @@ -529,10 +537,7 @@ pk.calc.sparse_aumc <- function(conc, time, subject, options = list()) { # Sparse AUMC is only defined for linear interpolation (see pk.calc.sparse_auc). if (!identical(method, "linear")) { - rlang::abort( - message = 'Sparse AUMC calculation only supports `method = "linear"`.', - class = "pknca_sparse_method" - ) + rlang::abort('Sparse AUMC calculation only supports `method = "linear"`.', class = "pknca_error_sparse_aumc_method") } # Create sparse_pk object from data sparse_pk <- as_sparse_pk(conc = conc, time = time, subject = subject) @@ -572,8 +577,8 @@ pk.calc.sparse_aumc <- function(conc, time, subject, pk.calc.sparse_aumclast <- function(conc, time, subject, ..., options = list()) { if ("auc.type" %in% names(list(...))) { rlang::abort( - message = "auc.type cannot be changed when calling pk.calc.sparse_aumclast, please use pk.calc.sparse_aumc", - class = "pknca_sparse_aumclast_change_auc_type" + "auc.type cannot be changed when calling pk.calc.sparse_aumclast, please use pk.calc.sparse_aumc", + class = "pknca_error_sparse_aumclast_change_auc_type" ) } ret <- pk.calc.sparse_aumc( diff --git a/R/superposition.R b/R/superposition.R index f1084957..32a1b96e 100644 --- a/R/superposition.R +++ b/R/superposition.R @@ -80,7 +80,10 @@ superposition.numeric <- function(conc, time, dose.input = NULL, assert_conc_time(conc = conc, time = time) if (check.blq) { if (!(conc[1] %in% 0)) { - stop("The first concentration must be 0 (and not NA). To change this set check.blq=FALSE.") + rlang::abort( + "The first concentration must be 0 (and not NA). To change this set check.blq=FALSE.", + class = "pknca_error_superposition_blq" + ) } } assert_number_between(dose.input, na.ok = FALSE, null.ok = TRUE, lower = 0) @@ -89,11 +92,17 @@ superposition.numeric <- function(conc, time, dose.input = NULL, # dose.amount if (!missing(dose.amount)) { if (missing(dose.input)) { - stop("must give dose.input to give dose.amount") + rlang::abort( + "must give dose.input to give dose.amount", + class = "pknca_error_superposition_dose_amount_without_input" + ) } assert_numeric_between(x = dose.amount, lower = 0, finite = TRUE) if (!(length(dose.amount) %in% c(1, length(dose.times)))) - stop("dose.amount must either be a scalar or match the length of dose.times") + rlang::abort( + "dose.amount must either be a scalar or match the length of dose.times", + class = "pknca_error_superposition_dose_amount_length" + ) } checkmate::assert_number(n.tau, lower = 1) if (is.finite(n.tau)) { @@ -121,39 +130,40 @@ superposition.numeric <- function(conc, time, dose.input = NULL, # additional.times if (length(additional.times) > 0) { if (any(is.na(additional.times))) { - stop("No additional.times may be NA (to not include any additional.times, enter c() as the function argument)") + rlang::abort( + "No additional.times may be NA (to not include any additional.times, enter c() as the function argument)", + class = "pknca_error_superposition_additional_times_na" + ) } - if (!is.numeric(additional.times) || is.factor(additional.times)) - stop("additional.times must be a number") - if (any(additional.times < 0)) - stop("All additional.times must be nonnegative") - if (any(additional.times > tau)) - stop("All additional.times must be <= tau") + checkmate::assert_numeric(additional.times, lower = 0, upper = tau) } # steady.state.tol - if (length(steady.state.tol) != 1) - stop("steady.state.tol must be a scalar") - if (!is.numeric(steady.state.tol) || is.factor(steady.state.tol) || is.na(steady.state.tol)) - stop("steady.state.tol must be a number") - if (steady.state.tol <= 0 || - steady.state.tol >= 1) - stop("steady.state.tol must be between 0 and 1, exclusive.") - if (steady.state.tol > 0.01) - warning("steady.state.tol is usually <= 0.01") + checkmate::assert_number(steady.state.tol, na.ok = FALSE) + if (steady.state.tol <= 0 || steady.state.tol >= 1) + rlang::abort( + "steady.state.tol must be between 0 and 1, exclusive.", + class = "pknca_error_superposition_steady_state_tol_range" + ) + if (steady.state.tol > 0.01) { + rlang::warn("steady.state.tol is usually <= 0.01", class = "pknca_warning_superposition_steady_state_tol_large") + } # We get all or none of lambda.z, clast, and tlast has.lambda.z <- !missing(lambda.z) has.clast.pred <- !is.logical(clast.pred) has.tlast <- !missing(tlast) if (any(c(has.lambda.z, has.clast.pred, has.tlast)) && !all(c(has.lambda.z, has.clast.pred, has.tlast))) - stop("Either give all or none of the values for these arguments: lambda.z, clast.pred, and tlast") + rlang::abort( + "Either give all or none of the values for these arguments: lambda.z, clast.pred, and tlast", + class = "pknca_error_superposition_lambdaz_clast_tlast_incomplete" + ) # combine dose.input and dose.amount as applicable to scale the # outputs. if (!missing(dose.amount)) { dose.scaling <- dose.amount / dose.input if (length(dose.scaling) != length(dose.times)) { if (length(dose.scaling) != 1) - stop("bug in dose.amount, dose.times, and dose.input handling") # nocov + rlang::abort("bug in dose.amount, dose.times, and dose.input handling", class = "pknca_error_internal_dose_scaling") # nocov # it is a scalar and there is more than one dose dose.scaling <- rep(dose.scaling, length(dose.times)) } diff --git a/R/time.above.R b/R/time.above.R index a3857d36..b3b168f6 100644 --- a/R/time.above.R +++ b/R/time.above.R @@ -22,14 +22,12 @@ pk.calc.time_above <- function(conc, time, arglist <- list(...) method <- PKNCA.choose.option(name="auc.method", value=arglist$method, options=options) if (missing(conc)) { - stop("conc must be given") + rlang::abort("conc must be given", class = "pknca_error_time_above_missing_conc") } if (missing(time)) { - stop("time must be given") + rlang::abort("time must be given", class = "pknca_error_time_above_missing_time") } - stopifnot("conc_above must be a scalar"=length(conc_above) == 1) - stopifnot("conc_above must not be NA"=!is.na(conc_above)) - stopifnot("conc_above must be numeric"=is.numeric(conc_above)) + checkmate::assert_number(conc_above, na.ok = FALSE) if (check) { assert_conc_time(conc = conc, time = time) } diff --git a/R/time_calc.R b/R/time_calc.R index 7f0643d4..379891ed 100644 --- a/R/time_calc.R +++ b/R/time_calc.R @@ -23,13 +23,16 @@ time_calc <- function(time_event, time_obs, units=NULL) { #' @export time_calc.numeric <- function(time_event, time_obs, units=NULL) { if (length(time_event) == 0) { - warning("No events provided") + rlang::warn("No events provided", class = "pknca_warning_time_calc_no_events") time_event <- NA_real_ } else if (any(order(stats::na.omit(time_event)) != seq_along(stats::na.omit(time_event)))) { - stop("`time_event` must be sorted.") + rlang::abort("`time_event` must be sorted.", class = "pknca_error_time_calc_unsorted") } if (!is.numeric(time_obs)) { - stop("Both `time_event` and `time_obs` must be the same class (numeric).") + rlang::abort( + "Both `time_event` and `time_obs` must be the same class (numeric).", + class = "pknca_error_time_calc_class_mismatch_numeric" + ) } ret <- data.frame( @@ -70,10 +73,13 @@ time_calc.numeric <- function(time_event, time_obs, units=NULL) { #' @export time_calc.POSIXt <- function(time_event, time_obs, units=NULL) { if (is.null(units)) { - stop("`units` must be provided.") + rlang::abort("`units` must be provided.", class = "pknca_error_time_calc_posixt_missing_units") } if (!("POSIXt" %in% class(time_obs))) { - stop("Both `time_event` and `time_obs` must be the same class (POSIXt).") + rlang::abort( + "Both `time_event` and `time_obs` must be the same class (POSIXt).", + class = "pknca_error_time_calc_class_mismatch_posix" + ) } first_event <- min(time_event, na.rm=TRUE) time_calc( @@ -86,10 +92,13 @@ time_calc.POSIXt <- function(time_event, time_obs, units=NULL) { #' @export time_calc.difftime <- function(time_event, time_obs, units=NULL) { if (is.null(units)) { - stop("`units` must be provided.") + rlang::abort("`units` must be provided.", class = "pknca_error_time_calc_difftime_missing_units") } if (!("difftime" %in% class(time_obs))) { - stop("Both `time_event` and `time_obs` must be the same class (difftime).") + rlang::abort( + "Both `time_event` and `time_obs` must be the same class (difftime).", + class = "pknca_error_time_calc_class_mismatch_difftime" + ) } time_calc( time_event=as.numeric(time_event, units=units), diff --git a/R/tss.R b/R/tss.R index c126078a..48816568 100644 --- a/R/tss.R +++ b/R/tss.R @@ -25,10 +25,10 @@ pk.tss.data.prep <- function(conc, time, subject, treatment, assert_conc_time(conc = conc, time = time, sorted_time = sorted_time) } if (!missing(subject.dosing) && missing(subject)) { - stop("Cannot give subject.dosing without subject") + rlang::abort("Cannot give subject.dosing without subject", class = "pknca_error_tss_subject_dosing_without_subject") } - if (any(is.na(time.dosing))) { - stop("time.dosing may not contain any NA values") + if (anyNA(time.dosing)) { + rlang::abort("time.dosing may not contain any NA values", class = "pknca_error_tss_time_dosing_na") } if (!missing(subject)) { if (!missing(treatment)) { @@ -122,7 +122,7 @@ pk.tss <- function(..., if (identical(NA, ret)) { ret <- ret_monoexponential } else { - stop("Bug in pk.tss where ret is set to non-NA too early. Please report the bug with a reproducible example.") # nocov + rlang::abort("Bug in pk.tss where ret is set to non-NA too early. Please report the bug with a reproducible example.", class = "pknca_error_internal_pk_tss_ret_non_na") # nocov } # Set check to FALSE if it has already been checked (so that it # doesn't happen again in stepwise.linear) diff --git a/R/tss.monoexponential.R b/R/tss.monoexponential.R index 77c0fcb8..eccdaa20 100644 --- a/R/tss.monoexponential.R +++ b/R/tss.monoexponential.R @@ -38,25 +38,26 @@ pk.tss.monoexponential <- function(..., verbose=FALSE) { # Check inputs modeldata <- pk.tss.data.prep(..., check=check) - if (is.factor(tss.fraction) || - !is.numeric(tss.fraction)) - stop("tss.fraction must be a number") - if (!length(tss.fraction) == 1) { - warning("Only first value of tss.fraction is being used") + if (length(tss.fraction) > 1) { + rlang::warn("Only first value of tss.fraction is being used", class = "pknca_warning_tss_fraction_multiple") tss.fraction <- tss.fraction[1] } + checkmate::assert_number(tss.fraction, na.ok = FALSE) + if (tss.fraction <= 0 || tss.fraction >= 1) { - stop("tss.fraction must be between 0 and 1, exclusive") + rlang::abort("tss.fraction must be between 0 and 1, exclusive", class = "pknca_error_tss_fraction_range") } else if (tss.fraction < 0.8) { - warning("tss.fraction is usually >= 0.8") + rlang::warn("tss.fraction is usually >= 0.8", class = "pknca_warning_tss_fraction_small") } # Note that this will by default choose "population" if nothing is # requested. output <- match.arg(output, several.ok=TRUE) if (!("subject" %in% names(modeldata))) { if (any(c("population", "popind", "individual") %in% output)) { - warning("Cannot give 'population', 'popind', or 'individual' ", - "output without multiple subjects of data") + rlang::warn( + "Cannot give 'population', 'popind', or 'individual' output without multiple subjects of data", + class = "pknca_warning_tss_output_no_subjects" + ) output <- setdiff(output, c("population", "popind", "individual")) } } @@ -89,7 +90,7 @@ pk.tss.monoexponential <- function(..., } else if (!identical(NA, ret_individual)) { ret_individual } else { - stop("Error in selection of return values for pk.tss.monoexponential. This is likely a bug.") # nocov + rlang::abort("Error in selection of return values for pk.tss.monoexponential. This is likely a bug.", class = "pknca_error_internal_tss_return_selection") # nocov } ret } @@ -236,7 +237,10 @@ pk.tss.monoexponential.population <- function(data, print(all.model.summary) if (all(is.na(all.model.summary$AIC)) || length(all.model.summary) == 0) { - warning("No population model for monoexponential Tss converged, no results given") + rlang::warn( + "No population model for monoexponential Tss converged, no results given", + class = "pknca_warning_tss_population_no_convergence" + ) ret <- data.frame( tss.monoexponential.population=NA, @@ -267,7 +271,10 @@ pk.tss.monoexponential.population <- function(data, all=TRUE ) } else if ("popind" %in% output) { - warning("tss.monoexponential.popind was requested, but the best model did not include a random effect for tss. Set to NA.") + rlang::warn( + "tss.monoexponential.popind was requested, but the best model did not include a random effect for tss. Set to NA.", + class = "pknca_warning_tss_popind_no_random_effect" + ) ret <- merge( ret, @@ -364,7 +371,7 @@ pk.tss.monoexponential.individual <- function(data, } else if ("subject" %in% names(data)) { dplyr::grouped_df(data, vars="subject") } else { - stop("Please report a bug. Subject must be specified to have subject-level fitting") # nocov + rlang::abort("Please report a bug. Subject must be specified to have subject-level fitting", class = "pknca_error_internal_tss_no_subject_for_individual") # nocov } ret_sub <- dplyr::summarize( diff --git a/R/tss.stepwise.linear.R b/R/tss.stepwise.linear.R index 034311ce..62d4cf9d 100644 --- a/R/tss.stepwise.linear.R +++ b/R/tss.stepwise.linear.R @@ -27,32 +27,33 @@ pk.tss.stepwise.linear <- function(..., check=TRUE) { # Check inputs modeldata <- pk.tss.data.prep(..., check=check) - if (is.factor(min.points) || - !is.numeric(min.points)) - stop("min.points must be a number") if (!length(min.points) == 1) { - warning("Only first value of min.points is used") + rlang::warn("Only first value of min.points is used", class = "pknca_warning_min_points_length") min.points <- min.points[1] } - if (min.points < 3) - stop("min.points must be at least 3") - if (is.factor(level) || - !is.numeric(level)) { - stop("level must be a number") - } + + checkmate::assert_number(min.points, lower = 3) + if (!length(level) == 1) { - warning("Only first value of level is being used") + rlang::warn("Only first value of level is being used", class = "pknca_warning_tss_level_multiple") level <- level[1] } + + checkmate::assert_numeric(level, any.missing = FALSE) + if (level <= 0 || level >= 1) { - stop("level must be between 0 and 1, exclusive") + rlang::abort("level must be between 0 and 1, exclusive", class = "pknca_error_tss_level_range") } + # Confirm that we may have sufficient data to complete the # modeling. Because of the variety of methods used for estimating # time to steady-state, assurance that we have enough data is more # simply determined by model convergence. if (length(unique(modeldata$time)) < min.points) { - warning("After removing non-dosing time points, insufficient data remains for tss calculation") + rlang::warn( + "After removing non-dosing time points, insufficient data remains for tss calculation", + class = "pknca_warning_tss_insufficient_data" + ) return(NA) } # Assign treatment if given and with multiple levels @@ -66,7 +67,7 @@ pk.tss.stepwise.linear <- function(..., while (is.na(ret) & (length(remaining.time) >= min.points)) { if (verbose) { - message("Trying ", min(remaining.time, na.rm=TRUE)) + rlang::inform(sprintf("Trying %s", min(remaining.time, na.rm = TRUE)), class = "pknca_message_tss_trying_time") } try({ # Try to make the model @@ -91,11 +92,14 @@ pk.tss.stepwise.linear <- function(..., c(ci[1], stats::coef(current.model)[["time"]], ci[2]) } if (verbose) { - message( - sprintf("Current interval %g [%g, %g]", - current.interval[2], - current.interval[1], - current.interval[3]) + rlang::inform( + sprintf( + "Current interval %g [%g, %g]", + current.interval[2], + current.interval[1], + current.interval[3] + ), + class = "pknca_message_tss_interval" ) } # If the signs of the upper and lower bounds of the slope of diff --git a/R/unit-support.R b/R/unit-support.R index e004bfda..461fce8a 100644 --- a/R/unit-support.R +++ b/R/unit-support.R @@ -113,7 +113,10 @@ pknca_units_table.default <- function(concu, doseu, amountu, timeu, # Use the original conversions argument over `conversions_pref` mask_pref <- conversions_pref$PPORRESU %in% conversions$PPORRESU[idx] if (!any(mask_pref)) { - stop("Cannot find PPORRESU match between conversions and preferred unit conversions. Check PPORRESU values in 'conversions' argument.") + rlang::abort( + "Cannot find PPORRESU match between conversions and preferred unit conversions. Check PPORRESU values in 'conversions' argument.", + class = "pknca_error_units_pporresu_no_match" + ) } conversions_pref$PPSTRESU[mask_pref] <- conversions$PPSTRESU[idx] conversions_pref$conversion_factor[mask_pref] <- conversions$conversion_factor[idx] @@ -123,17 +126,33 @@ pknca_units_table.default <- function(concu, doseu, amountu, timeu, extra_cols <- setdiff(ret$PPTESTCD, names(get.interval.cols())) if (length(extra_cols) > 0) { - stop("Please report a bug. Unknown NCA parameters have units defined: ", paste(extra_cols, collapse=", ")) # nocov + # nocov start + rlang::abort( + sprintf( + "Please report a bug. Unknown NCA parameters have units defined: %s", + paste(extra_cols, collapse = ", ") + ), + class = "pknca_error_internal_unknown_nca_units" + ) + # nocov end } # Apply conversion factors if (nrow(conversions) > 0) { - stopifnot(!duplicated(conversions$PPORRESU)) + if (any(duplicated(conversions$PPORRESU))) + rlang::abort( + "conversions$PPORRESU must not have duplicated values", + class = "pknca_error_units_pporresu_duplicated" + ) # PPSTRESU may be duplicated because some differing original units may # converge (e.g. cmax.dn and vss) - stopifnot(length(setdiff(names(conversions), c("PPORRESU", "PPSTRESU", "conversion_factor"))) == 0) + if (length(setdiff(names(conversions), c("PPORRESU", "PPSTRESU", "conversion_factor"))) != 0) + rlang::abort( + "conversions must only have columns named 'PPORRESU', 'PPSTRESU', and 'conversion_factor'", + class = "pknca_error_units_conversions_extra_cols" + ) if (any(is.na(conversions$conversion_factor)) && !requireNamespace("units", quietly=TRUE)) { - stop("The units package is required for automatic unit conversion") # nocov + rlang::abort("The units package is required for automatic unit conversion", class = "pknca_error_missing_units_package") # nocov } for (idx in which(is.na(conversions$conversion_factor))) { conversions$conversion_factor[idx] <- @@ -149,9 +168,12 @@ pknca_units_table.default <- function(concu, doseu, amountu, timeu, } unexpected_conversions <- setdiff(conversions$PPORRESU, ret$PPORRESU) if (length(unexpected_conversions) > 0) { - warning( - "The following unit conversions were supplied but do not match any units to convert: ", - paste0("'", unexpected_conversions, "'", collapse=", ") + rlang::warn( + sprintf( + "The following unit conversions were supplied but do not match any units to convert: %s", + paste0("'", unexpected_conversions, "'", collapse = ", ") + ), + class = "pknca_warning_units_unexpected_conversions" ) } ret <- @@ -245,10 +267,12 @@ pknca_units_table.PKNCAdata <- function(concu, ..., conversions = data.frame()) ) } ) - stop( - "Units should be uniform at least across concentration groups. ", - "Review the units for the next group(s):\n", - paste(mismatching_units_groups_msg, collapse = "\n") + rlang::abort( + sprintf( + "Units should be uniform at least across concentration groups. Review the units for the next group(s):\n%s", + paste(mismatching_units_groups_msg, collapse = "\n") + ), + class = "pknca_error_units_nonuniform_groups" ) } @@ -345,7 +369,13 @@ useless <- function(x) { if (missing(x)) { return(TRUE) } else if (length(x) > 1) { - stop("Only one unit may be provided at a time: ", paste(x, collapse = ", ")) + rlang::abort( + sprintf( + "Only one unit may be provided at a time: %s", + paste(x, collapse = ", ") + ), + class = "pknca_error_units_multiple_provided" + ) } is.null(x) || is.na(x) } @@ -547,8 +577,7 @@ pknca_units_table_conc_time_amount_dose <- function(concu, timeu, amountu, doseu #' @returns A character vector of parameters with a given unit type #' @keywords Internal pknca_find_units_param <- function(unit_type) { - stopifnot(length(unit_type) == 1) - stopifnot(is.character(unit_type)) + checkmate::assert_string(unit_type) all_intervals <- get.interval.cols() ret <- character() for (nm in names(all_intervals)) { @@ -557,7 +586,13 @@ pknca_find_units_param <- function(unit_type) { } } if (length(ret) == 0) { - stop("No parameters found for unit_type=", unit_type) + rlang::abort( + sprintf( + "No parameters found for unit_type=%s", + unit_type + ), + class = "pknca_error_units_no_params_for_type" + ) } ret } @@ -596,9 +631,15 @@ pknca_unit_conversion <- function(result, units, allow_partial_missing_units = F paste(sort(unique(ret$PPTESTCD[mask_missing_units])), collapse = ", ") ) if (allow_partial_missing_units) { - warning(msg_missing) + rlang::warn(msg_missing, class = "pknca_warning_units_partial_missing") } else { - stop(msg_missing, "\nThis error can be converted to a warning using `PKNCA.options(allow_partial_missing_units = TRUE)`") + rlang::abort( + sprintf( + "%s\nThis error can be converted to a warning using `PKNCA.options(allow_partial_missing_units = TRUE)`", + msg_missing + ), + class = "pknca_error_units_partial_missing" + ) } } if ("conversion_factor" %in% names(units)) { diff --git a/R/update.PKNCAresults.R b/R/update.PKNCAresults.R index 11eb9dc0..863a9162 100644 --- a/R/update.PKNCAresults.R +++ b/R/update.PKNCAresults.R @@ -24,11 +24,14 @@ update.PKNCAresults <- function(object, data, ...) { data$options <- PKNCA.options() } if (identical(as_PKNCAdata(object), data)) { - message("No changes detected in data") + rlang::inform("No changes detected in data", class = "pknca_message_no_changes") return(object) } if (!identical(strip_source_data(as_PKNCAdata(object)), strip_source_data(data))) { - warning("Full recalculation: changes detected in data other than source concentration or dose data") + rlang::warn( + "Full recalculation: changes detected in data other than source concentration or dose data", + class = "pknca_warning_full_recalculation" + ) return(pk.nca(data)) } # detect changed groups @@ -68,7 +71,8 @@ strip_source_data <- function(data) { #' a list of data.frames (PKNCAdata) #' @noRd find_changed_group <- function(old, new) { - stopifnot(all(class(old) == class(new))) + if (!all(class(old) == class(new))) + rlang::abort("old and new must be the same class", class = "pknca_error_find_changed_group_class_mismatch") if (inherits(old, "PKNCAdata")) { # Find subjects that changed (for PKNCAdata by going into conc and dose) list( diff --git a/man/add.interval.col.Rd b/man/add.interval.col.Rd index 60a5dde4..94e5cf97 100644 --- a/man/add.interval.col.Rd +++ b/man/add.interval.col.Rd @@ -20,14 +20,19 @@ add.interval.col( ) } \arguments{ -\item{name}{The column name as a character string} +\item{name}{The column name as a non-empty character string (length 1, +may not be \code{NA} or \code{""}).} \item{FUN}{The function to run (as a character string) or \code{NA} if the parameter is automatically calculated when calculating another parameter.} -\item{values}{Valid values for the column} +\item{values}{Valid values for the column: either a function used to +coerce/validate values (e.g. \code{as.numeric}) or a vector of allowed values +(e.g. \code{c(FALSE, TRUE)}).} -\item{unit_type}{The type of units to use for assigning and converting units.} +\item{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.} \item{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 @@ -45,11 +50,15 @@ comply with SDTM)} to NCA parameter names. See the details for information on use of \code{formalsmap}.} -\item{datatype}{The type of data used for the calculation} +\item{datatype}{The data type used for the calculation. The default is +\code{"interval"}, which is currently the only supported value. The +\code{"individual"} and \code{"population"} data types are reserved for future +use and will currently raise an error if selected.} \item{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., \code{list(route = list(extravascular = "CLF/FO", intravascular = "CLO"))}). Defaults to \code{name} if not provided.} +mappings with a \code{route} element whose value is itself a named list keyed +by route (e.g. \code{list(route = list(extravascular = "CLF/FO", intravascular = "CLO"))}). Defaults to \code{name} if not provided.} \item{pptest_cdisc}{The CDISC PPTEST name for this parameter. Can be a character string or a named list (same structure as \code{pptestcd_cdisc}). diff --git a/man/get_impute_method.Rd b/man/get_impute_method.Rd index 62f48a35..1323373d 100644 --- a/man/get_impute_method.Rd +++ b/man/get_impute_method.Rd @@ -9,7 +9,9 @@ get_impute_method(intervals, impute) \arguments{ \item{intervals}{the data.frame of intervals} -\item{impute}{the imputation definition} +\item{impute}{the imputation definition -- either the name of a column in +\code{intervals} (character scalar) or \code{NA} to look for a generic \code{"impute"} +column. Must be an atomic scalar; a list (even of length 1) is rejected.} } \value{ The imputation function vector diff --git a/man/pk.calc.aucabove.Rd b/man/pk.calc.aucabove.Rd index c1517870..5dfb8eff 100644 --- a/man/pk.calc.aucabove.Rd +++ b/man/pk.calc.aucabove.Rd @@ -11,7 +11,9 @@ pk.calc.aucabove(conc, time, conc_above = NA_real_, ..., options = list()) \item{time}{Time of the measurement of the concentrations} -\item{conc_above}{The concentration to be above} +\item{conc_above}{The concentration threshold to calculate AUC above. +Must be finite (\code{Inf}/\code{-Inf} are not allowed); if \code{NA}, no AUC is +calculated.} \item{...}{Extra arguments. Currently, the only extra argument that is used is \code{method} as described in the details section.} diff --git a/tests/testthat/test-001-add.interval.col.R b/tests/testthat/test-001-add.interval.col.R index 97fdd05f..88334d0e 100644 --- a/tests/testthat/test-001-add.interval.col.R +++ b/tests/testthat/test-001-add.interval.col.R @@ -3,103 +3,143 @@ original_state <- get("interval.cols", envir=PKNCA:::.PKNCAEnv) test_that("add.interval.col", { # Invalid inputs fail + # name expect_error( - add.interval.col(name=1), - regexp="name must be a character string", - info="interval column name must be a character string" + add.interval.col(name = 1), + regexp = "Must be of type 'character'" ) expect_error( - add.interval.col(name=c("a", "b")), - regexp="name must have length", - info="interval column name must be a scalar character string" + add.interval.col(name = c("a", "b")), + regexp = "Must have length 1" ) - expect_error( - add.interval.col(name="a", FUN=c("a", "b")), - regexp="FUN must have length == 1", - info="interval column function must be a scalar character string or NA" + add.interval.col(name = ""), + regexp = "at least 1 character" ) expect_error( - add.interval.col(name="a", FUN=1), - regexp="FUN must be a character string or NA", - info="interval column function must be a character string or NA" + add.interval.col(name = NA_character_), + regexp = "may not contain missing values|Contains missing values" ) - + + # FUN expect_error( - add.interval.col(name="a", FUN=NA, datatype="interval", desc="test addition"), - regexp='argument "unit_type" is missing, with no default' + add.interval.col(name = "a", FUN = c("a", "b")), + regexp = "Must have length 1" ) expect_error( - add.interval.col(name="a", FUN=NA, unit_type="foo", datatype="interval", desc="test addition"), - regexp="should be one of .*inverse_time" + add.interval.col(name = "a", FUN = 1), + regexp = "Must be of type 'character'" ) - + expect_error( + add.interval.col(name = "a", FUN = "this function does not exist", unit_type = "conc", pretty_name = "foo", datatype = "interval", desc = "test addition"), + class = "pknca_error_fun_not_found" + ) + + # unit_type + expect_error( + add.interval.col(name = "a", FUN = NA, pretty_name = "a", datatype = "interval", desc = "test addition"), + regexp = 'argument "unit_type" is missing, with no default' + ) + expect_error( + add.interval.col(name = "a", FUN = NA, pretty_name = "a", unit_type = "foo", datatype = "interval", desc = "test addition"), + regexp = "should be one of .*inverse_time" + ) + # pretty_name checks expect_error( - add.interval.col(name="a", FUN=NA, unit_type="conc", pretty_name=1:2, datatype="interval", desc=1), - regexp="pretty_name must be a scalar" + add.interval.col(name = "a", FUN = NA, unit_type = "conc", pretty_name = 1:2, datatype = "interval", desc = 1), + regexp = "Must be of type 'character'" ) expect_error( - add.interval.col(name="a", FUN=NA, unit_type="conc", pretty_name=1, datatype="interval", desc=1), - regexp="pretty_name must be a character" + add.interval.col(name = "a", FUN = NA, unit_type = "conc", pretty_name = 1, datatype = "interval", desc = 1), + regexp = "Must be of type 'character'" ) expect_error( - add.interval.col(name="a", FUN=NA, unit_type="conc", pretty_name="", datatype="interval", desc=1), - regexp="pretty_name must not be an empty string" + add.interval.col(name = "a", FUN = NA, unit_type = "conc", pretty_name = "", datatype = "interval", desc = 1), + regexp = "All elements must have at least 1 characters" ) - + + # datatype expect_error( - add.interval.col(name="a", FUN=NA, unit_type="conc", pretty_name="a", datatype="individual"), - regexp="Only the 'interval' datatype is currently supported.", - info="interval column datatype must be 'interval'" + add.interval.col(name = "a", FUN = NA, unit_type = "conc", pretty_name = "a", datatype = "individual"), + regexp = "Must be element of set \\{'interval'\\}" ) - + + # description expect_error( - add.interval.col(name="a", FUN=NA, unit_type="conc", pretty_name="a", datatype="interval", desc=1:2), - regexp="desc must have length == 1", - info="interval column description must be a scalar" + add.interval.col(name = "a", FUN = NA, unit_type = "conc", pretty_name = "a", datatype = "interval", desc = 1:2), + regexp = "Must be of type 'character'" ) expect_error( - add.interval.col(name="a", FUN=NA, unit_type="conc", pretty_name="a", datatype="interval", desc=1), - regexp="desc must be a character string", - info="interval column description must be a character scalar" + add.interval.col(name = "a", FUN = NA, unit_type = "conc", pretty_name = "a", datatype = "interval", desc = 1), + regexp = "Must be of type 'character'" ) expect_error( - add.interval.col(name="a", FUN=NA, depends = 1, unit_type="conc", pretty_name="a", datatype="interval", desc=1), - regexp="'depends' must be NULL or a character vector", - info="depends column must be a NULL or a character string" + add.interval.col( + name = "a", FUN = NA, unit_type = "conc", + pretty_name = "a", datatype = "interval", desc = NA_character_ + ), + regexp = "Contains missing values" ) - expect_error( - add.interval.col(name="a", FUN="this function does not exist", unit_type="conc", pretty_name="foo", datatype="interval", desc="test addition"), - regexp="The function named '.*' is not defined. Please define the function before calling add.interval.col.", - info="interval column function must exist (or be NA)" + add.interval.col( + name = "a", FUN = NA, unit_type = "conc", + pretty_name = "a", datatype = "interval", + desc = c("a", "b") + ), + regexp = "Must have length 1" ) + # depends + expect_error( + add.interval.col(name = "a", FUN = NA, depends = 1, unit_type = "conc", pretty_name = "a", datatype = "interval", desc = "a"), + regexp = "Must be of type 'character'" + ) + + # values + expect_error( + add.interval.col( + name = "a", FUN = NA, unit_type = "conc", + pretty_name = "a", datatype = "interval", desc = "a", + values = NULL + ), + class = "pknca_error_values_invalid" + ) + expect_error( + add.interval.col( + name = "a", FUN = NA, unit_type = "conc", + pretty_name = "a", datatype = "interval", desc = "a", + values = quote(x) + ), + class = "pknca_error_values_invalid" + ) + # formalsmap expect_error( - add.interval.col(name="a", FUN="mean", unit_type="conc", pretty_name="foo", formalsmap=NA), - regexp="formalsmap must be a list" + add.interval.col(name = "a", FUN = "mean", unit_type = "conc", pretty_name = "foo", formalsmap = NA), + regexp = "Must be of type 'list'" ) expect_error( - add.interval.col(name="a", FUN="mean", unit_type="conc", pretty_name="foo", formalsmap=list(1)), - regexp="formalsmap must be a named list" + add.interval.col(name = "a", FUN = "mean", unit_type = "conc", pretty_name = "foo", formalsmap = list(1)), + regexp = "Must have names" ) expect_error( - add.interval.col(name="a", FUN=NA, unit_type="conc", pretty_name="foo", formalsmap=list(A="b")), - regexp="formalsmap may not be given when FUN is NA", - info="formalsmap cannot be used with FUN=NA" + add.interval.col(name = "a", FUN = NA, unit_type = "conc", pretty_name = "foo", formalsmap = list(A = "b")), + class = "pknca_error_formalsmap_with_na_fun" ) expect_error( - add.interval.col(name="a", FUN="mean", unit_type="conc", pretty_name="foo", formalsmap=list(A="a", "b")), - regexp="All formalsmap elements must be named" + add.interval.col(name = "a", FUN = "mean", unit_type = "conc", pretty_name = "foo", formalsmap = list(A = "a", "b")), + regexp = "Must have names" ) expect_error( - add.interval.col(name="a", FUN="mean", unit_type="conc", pretty_name="a", formalsmap=list(y="a")), - regexp="All names for the formalsmap list must be arguments to the function", - info="formalsmap arguments must map to function arguments" + add.interval.col(name = "a", FUN = "mean", unit_type = "conc", pretty_name = "a", formalsmap = list(y = "a")), + class = "pknca_error_formalsmap_invalid_names" ) - + expect_error( + add.interval.col(name = "a", FUN = "mean", unit_type = "conc", pretty_name = "foo", formalsmap = list(x = "a", x = "b")), + regexp = "Must have unique names" + ) + expect_equal( { add.interval.col(name="a", FUN=NA, unit_type="conc", pretty_name="a", datatype="interval", desc="test addition") @@ -117,8 +157,7 @@ test_that("add.interval.col", { datatype="interval", pptestcd_cdisc="a", pptest_cdisc="test addition" - ), - info="interval column assignment works with FUN=NA" + ) ) expect_equal( { @@ -137,8 +176,7 @@ test_that("add.interval.col", { datatype="interval", pptestcd_cdisc="a", pptest_cdisc="test addition" - ), - info="interval column assignment works with FUN=a character string" + ) ) expect_equal( { @@ -157,8 +195,7 @@ test_that("add.interval.col", { datatype="interval", pptestcd_cdisc="a", pptest_cdisc="test addition" - ), - info="interval column assignment works with FUN=NA" + ) ) }) @@ -177,24 +214,110 @@ test_that("fake parameters", { ) expect_error( sort_interval_cols(), - regexp="Invalid dependencies for interval column (please report this as a bug): fake_parameter The following dependencies are missing: does_not_exist", - fixed=TRUE + regexp="Invalid dependencies for interval column \\(please report this as a bug\\): fake_parameter The following dependencies are missing: does_not_exist" ) }) -test_that("add.interval.col rejects invalid pptestcd_cdisc types", { +test_that("add.interval.col rejects pptestcd_cdisc types", { + + # invalid types + expect_error( + add.interval.col( + name = "a", FUN = "mean", unit_type = "conc", + pretty_name = "a", desc = "test", + pptestcd_cdisc = 123 + ), + class = "pknca_error_cdisc_invalid_type" + ) + + # invalid character values + expect_error( + add.interval.col( + name = "a", FUN = "mean", unit_type = "conc", + pretty_name = "a", desc = "test", + pptestcd_cdisc = c("PCMAX", "PCMIN") + ), + class = "pknca_error_cdisc_character_invalid" + ) + expect_error( - add.interval.col(name="a", FUN="mean", unit_type="conc", pretty_name="a", - desc="test", pptestcd_cdisc=123), - regexp="pptestcd_cdisc must be a character string or a list" + add.interval.col( + name = "a", FUN = "mean", unit_type = "conc", + pretty_name = "a", desc = "test", + pptestcd_cdisc = NA_character_ + ), + class = "pknca_error_cdisc_character_invalid" + ) + + # invalid route mappings + expect_error( + add.interval.col( + name = "a", FUN = "mean", unit_type = "conc", + pretty_name = "a", desc = "test", + pptestcd_cdisc = list(foo = "PCMAX") + ), + class = "pknca_error_cdisc_route_mapping_invalid" + ) + + expect_error( + add.interval.col( + name = "a", FUN = "mean", unit_type = "conc", + pretty_name = "a", desc = "test", + pptestcd_cdisc = list(route = "PCMAX") + ), + class = "pknca_error_cdisc_route_mapping_invalid" ) }) -test_that("add.interval.col rejects invalid pptest_cdisc types", { + +test_that("add.interval.col rejects pptest_cdisc types", { + + # invalid types + expect_error( + add.interval.col( + name = "a", FUN = "mean", unit_type = "conc", + pretty_name = "a", desc = "test", + pptest_cdisc = 123 + ), + class = "pknca_error_cdisc_invalid_type" + ) + + # invalid character values expect_error( - add.interval.col(name="a", FUN="mean", unit_type="conc", pretty_name="a", - desc="test", pptest_cdisc=123), - regexp="pptest_cdisc must be a character string or a list" + add.interval.col( + name = "a", FUN = "mean", unit_type = "conc", + pretty_name = "a", desc = "test", + pptest_cdisc = c("PCMAX", "PCMIN") + ), + class = "pknca_error_cdisc_character_invalid" + ) + + expect_error( + add.interval.col( + name = "a", FUN = "mean", unit_type = "conc", + pretty_name = "a", desc = "test", + pptest_cdisc = NA_character_ + ), + class = "pknca_error_cdisc_character_invalid" + ) + + # invalid route mappings + expect_error( + add.interval.col( + name = "a", FUN = "mean", unit_type = "conc", + pretty_name = "a", desc = "test", + pptest_cdisc = list(foo = "PCMAX") + ), + class = "pknca_error_cdisc_route_mapping_invalid" + ) + + expect_error( + add.interval.col( + name = "a", FUN = "mean", unit_type = "conc", + pretty_name = "a", desc = "test", + pptest_cdisc = list(route = "PCMAX") + ), + class = "pknca_error_cdisc_route_mapping_invalid" ) }) @@ -209,5 +332,16 @@ test_that("add.interval.col accepts list for pptestcd_cdisc", { expect_equal(result$pptestcd_cdisc$route$intravascular, "IV") }) +test_that("add.interval.col accepts list for pptest_cdisc", { + add.interval.col(name="a", FUN="mean", unit_type="conc", pretty_name="a", + desc="test", + pptestcd_cdisc="a", + pptest_cdisc=list(route=list(extravascular="Route Test EV", intravascular="Route Test IV"))) + result <- get("interval.cols", envir=PKNCA:::.PKNCAEnv)[["a"]] + expect_true(is.list(result$pptest_cdisc)) + expect_equal(result$pptest_cdisc$route$extravascular, "Route Test EV") + expect_equal(result$pptest_cdisc$route$intravascular, "Route Test IV") +}) + # Reset the original state assign("interval.cols", original_state, envir=PKNCA:::.PKNCAEnv) diff --git a/tests/testthat/test-PKNCA.options.R b/tests/testthat/test-PKNCA.options.R index f805ccd8..483d859c 100644 --- a/tests/testthat/test-PKNCA.options.R +++ b/tests/testthat/test-PKNCA.options.R @@ -97,13 +97,13 @@ test_that("PKNCA.options", { # adj.r.squared.factor expect_error(PKNCA.options(adj.r.squared.factor=c(0.1, 0.9), check=TRUE), - regexp="adj.r.squared.factor must be a scalar") + regexp="Must have length 1") expect_error(PKNCA.options(adj.r.squared.factor=1, check=TRUE), regexp="adj.r.squared.factor must be between 0 and 1, exclusive") expect_error(PKNCA.options(adj.r.squared.factor=0, check=TRUE), regexp="adj.r.squared.factor must be between 0 and 1, exclusive") expect_error(PKNCA.options(adj.r.squared.factor="A", check=TRUE), - regexp="adj.r.squared.factor must be numeric \\(and not a factor\\)") + regexp="Must be of type 'number'") expect_warning(v1 <- PKNCA.options(adj.r.squared.factor=0.9, check=TRUE)) expect_equal(v1, 0.9) expect_warning(PKNCA.options(adj.r.squared.factor=0.9, check=TRUE), @@ -111,9 +111,9 @@ test_that("PKNCA.options", { # max.missing expect_error(PKNCA.options(max.missing=c(1, 2), check=TRUE), - regexp="max.missing must be a scalar") + regexp="Must have length 1") expect_error(PKNCA.options(max.missing="A", check=TRUE), - regexp="max.missing must be numeric \\(and not a factor\\)") + regexp="Must be of type 'number'") expect_error(PKNCA.options(max.missing=-1, check=TRUE), regexp="max.missing must be between 0 and 1") expect_error(PKNCA.options(max.missing=1, check=TRUE), @@ -173,9 +173,9 @@ test_that("PKNCA.options", { expect_error(PKNCA.options(conc.blq="foo", check=TRUE), regexp="conc.blq must either be a finite number or the text 'drop' or 'keep'") expect_error(PKNCA.options(conc.blq=c(1, 2), check=TRUE), - regexp="conc.blq must be a scalar") + regexp="Must have length 1") expect_error(PKNCA.options(conc.blq=NA, check=TRUE), - regexp="conc.blq must not be NA") + regexp="May not be NA") # Confirm that list-style input also works expect_equal(PKNCA.options(conc.blq=list(first="drop", middle=5, last="keep"), @@ -223,7 +223,8 @@ test_that("PKNCA.options", { expect_equal(PKNCA.options(first.tmax=FALSE, check=TRUE), FALSE) expect_error(PKNCA.options(first.tmax=c(FALSE, TRUE), check=TRUE), - regexp="first.tmax must be a scalar") + regexp="Must have length 1") + # Conversion works expect_warning(v1 <- PKNCA.options(first.tmax="T", check=TRUE), regexp="Converting first.tmax to a logical value: TRUE") @@ -232,37 +233,35 @@ test_that("PKNCA.options", { regexp="Converting first.tmax to a logical value: TRUE") expect_equal(v1, TRUE) expect_error(PKNCA.options(first.tmax=NA, check=TRUE), - regexp="first.tmax may not be NA") + regexp="May not be NA") expect_error(PKNCA.options(first.tmax="x", check=TRUE), regexp="Could not convert first.tmax to a logical value") # min.hl.points - expect_equal(PKNCA.options(min.hl.points=3, check=TRUE), - 3) + expect_equal(PKNCA.options(min.hl.points=3, check=TRUE), 3) expect_error(PKNCA.options(min.hl.points=c(3, 4), check=TRUE), - regexp="min.hl.points must be a scalar") + regexp="Must have length 1") expect_error(PKNCA.options(min.hl.points=factor(3), check=TRUE), - regexp="min.hl.points cannot be a factor") + regexp="Must be of type 'number'") expect_error(PKNCA.options(min.hl.points="a", check=TRUE), - regexp="min.hl.points must be a number") + regexp="Must be of type 'number'") expect_error(PKNCA.options(min.hl.points=1.5, check=TRUE), - regexp="min.hl.points must be >=2") + regexp="Element 1 is not >= 2") expect_warning(v1 <- PKNCA.options(min.hl.points=2.5, check=TRUE), regexp="Non-integer given for min.hl.points; rounding to nearest integer") # Note that R uses the engineer's rule of rounding expect_equal(v1, 2) # min.span.ratio - expect_equal(PKNCA.options(min.span.ratio=2, check=TRUE), - 2) + expect_equal(PKNCA.options(min.span.ratio=2, check=TRUE), 2) expect_error(PKNCA.options(min.span.ratio=0, check=TRUE), regexp="min.span.ratio must be > 0") expect_error(PKNCA.options(min.span.ratio=c(2, 1), check=TRUE), - regexp="min.span.ratio must be a scalar") + regexp="Must have length 1") expect_error(PKNCA.options(min.span.ratio=factor(1), check=TRUE), - regexp="min.span.ratio cannot be a factor") + regexp="Must be of type 'number'") expect_error(PKNCA.options(min.span.ratio="a", check=TRUE), - regexp="min.span.ratio must be a number") + regexp="Must be of type 'number'") expect_warning(PKNCA.options(min.span.ratio=1, check=TRUE), regexp="min.span.ratio is usually >= 2") @@ -272,11 +271,11 @@ test_that("PKNCA.options", { expect_error(PKNCA.options(max.aucinf.pext=0, check=TRUE), regexp="max.aucinf.pext must be > 0") expect_error(PKNCA.options(max.aucinf.pext=c(2, 1), check=TRUE), - regexp="max.aucinf.pext must be a scalar") + regexp="Must have length 1") expect_error(PKNCA.options(max.aucinf.pext=factor(1), check=TRUE), - regexp="max.aucinf.pext cannot be a factor") + regexp="Must be of type 'number'") expect_error(PKNCA.options(max.aucinf.pext="a", check=TRUE), - regexp="max.aucinf.pext must be a number") + regexp="Must be of type 'number'") expect_warning(PKNCA.options(max.aucinf.pext=25.1, check=TRUE), regexp="max.aucinf.pext is usually <=25") expect_warning(PKNCA.options(max.aucinf.pext=0.1, check=TRUE), @@ -288,11 +287,11 @@ test_that("PKNCA.options", { expect_error(PKNCA.options(min.hl.r.squared=0, check=TRUE), regexp="min.hl.r.squared must be between 0 and 1, exclusive") expect_error(PKNCA.options(min.hl.r.squared=c(2, 1), check=TRUE), - regexp="min.hl.r.squared must be a scalar") + regexp="Must have length 1") expect_error(PKNCA.options(min.hl.r.squared=factor(1), check=TRUE), - regexp="min.hl.r.squared cannot be a factor") + regexp="Must be of type 'number'") expect_error(PKNCA.options(min.hl.r.squared="a", check=TRUE), - regexp="min.hl.r.squared must be a number") + regexp="Must be of type 'number'") expect_warning(PKNCA.options(min.hl.r.squared=0.89, check=TRUE), regexp="min.hl.r.squared is usually >= 0.9") @@ -304,7 +303,7 @@ test_that("PKNCA.options", { expect_error(PKNCA.options(tau.choices=c(NA, 1), check=TRUE), regexp="tau.choices may not include NA and be a vector") expect_error(PKNCA.options(tau.choices="x", check=TRUE), - regexp="tau.choices must be a number") + regexp="Must be of type 'numeric'") # Reset all options to their default to ensure that any subsequent # tests work correctly. @@ -362,39 +361,42 @@ test_that("PKNCA.choose.option", { test_that("PKNCA.set.summary input checking", { # Get the current state to reset it at the end initial.summary.set <- PKNCA.set.summary() - expect_warning(PKNCA.set.summary(reset = TRUE), - regexp = "`reset = TRUE` is not intended for general use") + expect_warning( + PKNCA.set.summary(reset=TRUE), + class = "pknca_warning_summary_reset" + ) # Confirm that reset actually resets the summary settings expect_equal(PKNCA.set.summary(), list()) - + # name must already be defined expect_error(PKNCA.set.summary("blah"), regexp="You must first define the parameter name with add.interval.col") # point must be a function expect_error(PKNCA.set.summary("auclast", description="A", point="a"), - regexp="`point` must be a function") + regexp="Must be a function") # description is required and must be a scalar character string expect_error( PKNCA.set.summary("auclast", description=1), - regexp="`description` must be a character string", + regexp="Must be of type 'string'", fixed=TRUE ) expect_error( PKNCA.set.summary("auclast", description=c("A", "B")), - regexp="`description` must be a scalar.", + regexp="Must have length 1", fixed=TRUE ) expect_error(PKNCA.set.summary("auclast", description=1)) # spread must be a function expect_error(PKNCA.set.summary("auclast", description="A", point=mean, spread="a"), - regexp="spread must be a function") + regexp="Must be a function") + # Rounding must either be a function or a list expect_error(PKNCA.set.summary("auclast", description="A", point=mean, spread=sd, rounding="a"), regexp="rounding must be either a list or a function") expect_error(PKNCA.set.summary("auclast", description="A", point=mean, spread=sd, rounding=list(foo=3, bar=4)), - regexp="rounding must have a single value in the list") + regexp="Must have length 1") expect_error(PKNCA.set.summary("auclast", description="A", point=mean, spread=sd, rounding=list(foo=3)), regexp="When a list, rounding must have a name of either 'signif' or 'round'") @@ -418,8 +420,10 @@ test_that("PKNCA.set.summary input checking", { list(auclast=list(description="A", point=mean, spread=sd, rounding=list(round=2)))) # Changing a vector of settings works - expect_warning(PKNCA.set.summary(reset = TRUE), - regexp = "`reset = TRUE` is not intended for general use") + expect_warning( + PKNCA.set.summary(reset=TRUE), + class = "pknca_warning_summary_reset" + ) expect_equal( PKNCA.set.summary( name=c("cmax", "auclast"), @@ -441,10 +445,12 @@ test_that("PKNCA.set.summary input checking", { ) ) ) - + # Reset all the values to the defaults - expect_warning(PKNCA.set.summary(reset = TRUE), - regexp = "`reset = TRUE` is not intended for general use") + expect_warning( + PKNCA.set.summary(reset=TRUE), + class = "pknca_warning_summary_reset" + ) for (n in names(initial.summary.set)) { tmp <- initial.summary.set[[n]] tmp$name <- n diff --git a/tests/testthat/test-assertions.R b/tests/testthat/test-assertions.R index 99023b69..e4016303 100644 --- a/tests/testthat/test-assertions.R +++ b/tests/testthat/test-assertions.R @@ -158,25 +158,24 @@ test_that("assert_unit_col", { ) expect_error( assert_unit_col(unit = 1:2), - regexp = "`unit` must be a single value" + regexp = "Must be of type 'character'" ) expect_error( assert_unit_col(unit = 1), - regexp = "`unit` must be a character string" + regexp = "Must be of type 'character'" ) expect_error( assert_unit_col(unit = "D", data = "A"), - regexp = "`data` must be a data.frame" + regexp = "Must be of type 'data.frame'" ) expect_error( assert_unit_col(unit = "D", data = d), - regexp = "`unit` (D) must be a column name in the data", + regexp = "Names must include the elements {'D'}", fixed = TRUE ) expect_error( assert_unit_col(unit = "A", data = d), - regexp = "`unit` (A) must contain character data", - fixed = TRUE + regexp = "Must be of type 'character'" ) }) @@ -185,11 +184,11 @@ test_that("assert_unit_value", { expect_null(assert_unit_value(NULL)) expect_error( assert_unit_value(c("A", "B")), - regexp = "`unit` must be a single value" + regexp = "Must have length 1" ) expect_error( assert_unit_value(1), - regexp = "`unit` must be a character string" + regexp = "Must be of type 'character'" ) }) @@ -207,6 +206,6 @@ test_that("assert_unit", { ) expect_error( assert_unit(unit = 1, data = d), - regexp = "`unit` must be a character string" + regexp = "Must be of type 'character'" ) }) diff --git a/tests/testthat/test-auc.R b/tests/testthat/test-auc.R index 4700ccd8..834ced91 100644 --- a/tests/testthat/test-auc.R +++ b/tests/testthat/test-auc.R @@ -5,13 +5,18 @@ test_that("pk.calc.auxc", { pk.calc.auxc(conc=1:2, time=0:1, interval=2:1, method="linear"), regexp="Assertion on 'interval' failed: Must be sorted." ) - expect_warning(pk.calc.auxc(conc=1:2, time=2:3, interval=c(1, 3), - method="linear"), - regexp="Requesting an AUC range starting \\(1\\) before the first measurement \\(2\\) is not allowed", - info="AUC should start at or after the first measurement and should be before the last measurement") - expect_warning(v1 <- pk.calc.auxc(conc=1:2, time=2:3, interval=c(1, 3), - method="linear"), - info="Starting before the beginning time returns NA (not an error)") + expect_warning( + pk.calc.auxc(conc=1:2, time=2:3, interval=c(1, 3), + method="linear"), + regexp="Requesting an AUC range starting \\(1\\) before the first measurement \\(2\\) is not allowed", + info="AUC should start at or after the first measurement and should be before the last measurement" + ) + expect_warning( + v1 <- pk.calc.auxc( + conc=1:2, time=2:3, interval=c(1, 3), + method="linear"), + info="Starting before the beginning time returns NA (not an error)" + ) expect_equal( v1, structure(NA_real_, exclude = 'Requesting an AUC range starting (1) before the first measurement (2) is not allowed'), @@ -47,9 +52,11 @@ test_that("pk.calc.auxc", { info="Mixed zeros and NA is still zero." ) # Invalid integration method - expect_error(pk.calc.auxc(conc=c(NA, 0, NA), time=2:4, interval=c(1, 3), - method="foo"), - info="Invalid integration methods are caught.") + expect_error( + pk.calc.auxc(conc=c(NA, 0, NA), time=2:4, interval=c(1, 3), + method="foo"), + info="Invalid integration methods are caught." + ) }) test_that("pk.calc.auc: Linear AUC when the conc at the end of the interval is above LOQ", { @@ -392,7 +399,7 @@ test_that("pk.calc.auc: warning with beginning of interval before the beginning middle="drop", last="keep"), method=t), - class="pknca_warn_auc_before_first" + class="pknca_warning_auc_before_first" ) expect_equal(v1, tests[[t]][[n]], @@ -443,7 +450,7 @@ test_that("pk.calc.auc: warning with beginning of interval before the beginning middle="drop", last="keep"), method=t), - class = "pknca_warn_auc_before_first" + class = "pknca_warning_auc_before_first" ) expect_equal(v1, tests[[t]][[n]], diff --git a/tests/testthat/test-class-PKNCAconc.R b/tests/testthat/test-class-PKNCAconc.R index 2d7841bd..6c7f25c4 100644 --- a/tests/testthat/test-class-PKNCAconc.R +++ b/tests/testthat/test-class-PKNCAconc.R @@ -63,10 +63,14 @@ test_that("PKNCAconc", { # Subject assignment expect_equal(PKNCAconc(tmp.conc.analyte, formula=conc~time|treatment+ID/analyte), PKNCAconc(tmp.conc.analyte, formula=conc~time|treatment+ID/analyte, subject="ID")) - expect_error(PKNCAconc(tmp.conc.analyte, formula=conc~time|treatment+ID/analyte, subject=5), - regexp="subject must be a character string") - expect_error(PKNCAconc(tmp.conc.analyte, formula=conc~time|treatment+ID/analyte, subject=c("", "foo")), - regexp="subject must be a scalar") + expect_error( + PKNCAconc(tmp.conc.analyte, formula=conc~time|treatment+ID/analyte, subject=5), + regexp="Must be of type 'string'" + ) + expect_error( + PKNCAconc(tmp.conc.analyte, formula=conc~time|treatment+ID/analyte, subject=c("", "foo")), + regexp="Must have length 1" + ) expect_error(PKNCAconc(tmp.conc.analyte, formula=conc~time|treatment+ID/analyte, subject="foo"), regexp="The subject parameter must map to a name in the data") @@ -660,7 +664,7 @@ test_that("PKNCAconc lloq argument is stored and validated (scalar and column)", tmp.conc.bad$bad_lloq <- "x" expect_error( PKNCAconc(tmp.conc.bad, conc ~ time | ID, lloq = "bad_lloq"), - regexp = "lloq must be numeric" + regexp = "Must be of type 'numeric'" ) # Without lloq, no lloq column or attribute is added diff --git a/tests/testthat/test-class-PKNCAdata.R b/tests/testthat/test-class-PKNCAdata.R index 042c54f9..c578351d 100644 --- a/tests/testthat/test-class-PKNCAdata.R +++ b/tests/testthat/test-class-PKNCAdata.R @@ -39,12 +39,14 @@ test_that("PKNCAdata", { info="Concentration and dose data can be created on the fly") # Input checking - expect_error(PKNCAdata(obj.conc, obj.dose, options="a"), - regexp="options must be a list.", - info="Option class") - expect_error(PKNCAdata(obj.conc, obj.dose, options=list(1)), - regexp="options must have names.", - info="Option structure") + expect_error( + PKNCAdata(obj.conc, obj.dose, options="a"), + regexp="Must be of type 'list'" + ) + expect_error( + PKNCAdata(obj.conc, obj.dose, options=list(1)), + regexp="Must have names" + ) expect_error(PKNCAdata(obj.conc, obj.dose, options=list(foo=1)), regexp="Invalid setting for PKNCA.*foo", info="Option names") @@ -79,22 +81,22 @@ test_that("PKNCAdata", { obj.dose <- PKNCAdose(tmp.dose, formula=dose~time|treatment+ID) expect_warning(expect_warning( PKNCAdata(obj.conc, obj.dose), - class = "pknca_no_intervals_generated"), - class = "pknca_no_intervals_generated", - info="Missing concentration data with dose data gives a warning." + class = "pknca_warning_no_intervals_generated"), + class = "pknca_warning_no_intervals_generated", + info="No intervals generated due to no concentration data." ) expect_warning(expect_warning(expect_warning( PKNCAdata(obj.conc, obj.dose, formula.conc=a~b), - class = "pknca_dataconc_formulaconc"), - class = "pknca_no_intervals_generated"), - class = "pknca_no_intervals_generated" + class = "pknca_warning_dataconc_formulaconc"), + class = "pknca_warning_no_intervals_generated"), + class = "pknca_warning_no_intervals_generated" ) expect_warning(expect_warning(expect_warning( PKNCAdata(obj.conc, obj.dose, formula.dose=a~b), - class = "pknca_dataconc_formuladose"), - class = "pknca_no_intervals_generated"), - class = "pknca_no_intervals_generated" + class = "pknca_warning_dataconc_formuladose"), + class = "pknca_warning_no_intervals_generated"), + class = "pknca_warning_no_intervals_generated" ) }) diff --git a/tests/testthat/test-class-PKNCAdose.R b/tests/testthat/test-class-PKNCAdose.R index 100387f5..a335d5ee 100644 --- a/tests/testthat/test-class-PKNCAdose.R +++ b/tests/testthat/test-class-PKNCAdose.R @@ -14,9 +14,10 @@ test_that("PKNCAdose", { # Data exists expect_error(PKNCAdose(data.frame()), - regexp="data must have at least one row.", - info="PKNCAconc requires data") - + regexp="Must have at least 1 rows", + info="PKNCAconc requires data" + ) + # Variables present expect_error(PKNCAdose(tmp.dose, formula=dosea~time|treatment+ID), regexp="The left side formula must be a variable in the data, empty, or '.'.", @@ -460,7 +461,7 @@ test_that("setDuration", { mydose, info="No changes with no arguments" ), - class = "pknca_foundcolumn_duration" + class = "pknca_message_foundcolumn_duration" ) expect_error(setDuration(mydose, duration="foo", rate="bar"), regexp="Both duration and rate cannot be given at the same time", @@ -470,8 +471,10 @@ test_that("setDuration", { setDuration(mydose, duration="foobar"), regexp="duration must be numeric without missing (NA) or infinite values, and all values must be >= 0", fixed=TRUE, - info="Cannot give both duration as non-numeric"), - class = "pknca_foundcolumn_duration" + info="Cannot give both duration as non-numeric", + class = "pknca_error_dose_invalid_duration"), + class = "pknca_message_foundcolumn_duration" + ) duration_example <- suppressMessages(setDuration(mydose, rate=2)) diff --git a/tests/testthat/test-class-PKNCAresults.R b/tests/testthat/test-class-PKNCAresults.R index 87e19f66..ca69f69f 100644 --- a/tests/testthat/test-class-PKNCAresults.R +++ b/tests/testthat/test-class-PKNCAresults.R @@ -377,7 +377,7 @@ test_that("units work for calculations and summaries with one set of units acros o_result_units_manipulated$result$PPSTRESU[o_result_units_manipulated$result$PPTESTCD %in% "auclast"][1] <- "foo" expect_error( summary(o_result_units_manipulated), - regexp="Multiple units cannot be summarized together. For auclast, trying to combine: foo, hr*ng/mL", + regexp="Multiple units cannot be summarized together. For auclast, trying to combine: foo, hr*ng/mL", fixed=TRUE ) }) @@ -400,7 +400,7 @@ test_that("getGroups.PKNCAresults", { ) expect_error( getGroups(o_result, level="foo"), - regexp="Not all levels are listed in the group names. Missing levels are: foo" + regexp="Not all levels are listed in the group names. Missing levels are: foo" ) expect_equal( getGroups(o_result, level=2), diff --git a/tests/testthat/test-exclude.R b/tests/testthat/test-exclude.R index 2844f914..b62eb494 100644 --- a/tests/testthat/test-exclude.R +++ b/tests/testthat/test-exclude.R @@ -135,11 +135,10 @@ test_that("exclude.default", { regexp="reason must be a scalar or have the same length as the data", info="Interpretation of a non-scalar reason is unclear") expect_error(exclude.default(obj1, - reason=1, - FUN=function(x, ...) TRUE), - regexp="reason must be a character string.", + reason=1, + FUN=function(x, ...) TRUE), + regexp="reason must be a character vector.", info="Interpretation of a non-character reason is unclear") - # Check operation obj4 <- obj1 obj4$data$exclude <- c(NA_character_, rep("Just because", nrow(obj4$data)-1)) diff --git a/tests/testthat/test-half.life.R b/tests/testthat/test-half.life.R index 1e932b99..afdb8874 100644 --- a/tests/testthat/test-half.life.R +++ b/tests/testthat/test-half.life.R @@ -122,15 +122,15 @@ test_that("pk.calc.half.life", { }) test_that("half-life manual point selection", { - expect_equal( - pk.calc.half.life(conc=c(3, 1, 0.5, 0.13, 0.12, 0.113), - time=c(0, 1, 2, 3, 4, 5), - manually.selected.points=TRUE, - min.hl.points=3, - allow.tmax.in.half.life=FALSE, - check=FALSE)$half.life, - 1.00653, - tolerance=0.0001, + expect_equal( + pk.calc.half.life(conc=c(3, 1, 0.5, 0.13, 0.12, 0.113), + time=c(0, 1, 2, 3, 4, 5), + manually.selected.points=TRUE, + min.hl.points=3, + allow.tmax.in.half.life=FALSE, + check=FALSE)$half.life, + 1.00653, + tolerance=0.0001, info="manual selection uses the given points as is") expect_true( pk.calc.half.life(conc=c(3, 1, 0.5, 0.13, 0.12, 0.113), @@ -226,8 +226,8 @@ test_that("two-point half-life succeeds (fix #114)", { tlast=1 ) ), - class = "pknca_halflife_2points"), - class = "pknca_adjr2_2points" + class = "pknca_warning_halflife_2points"), + class = "pknca_warning_adjr2_2points" ) }) @@ -588,7 +588,7 @@ test_that("fit_half_life_tobit returns NA with warning on too few above-LLOQ poi ) expect_warning( result <- PKNCA:::fit_half_life_tobit(data, tlast = 2), - class = "pknca_tobit_too_few_points" + class = "pknca_warning_tobit_too_few_points" ) expect_true(is.na(result$lambda.z)) expect_true(is.na(result$half.life)) @@ -603,7 +603,7 @@ test_that("fit_half_life_tobit returns NA with warning on no variability", { ) expect_warning( result <- PKNCA:::fit_half_life_tobit(data, tlast = 2), - class = "pknca_tobit_no_variability" + class = "pknca_warning_tobit_no_variability" ) expect_true(is.na(result$lambda.z)) }) @@ -708,7 +708,7 @@ test_that("pk.calc.half.life hl_method='tobit' warns with too few above-LLOQ poi allow.tmax.in.half.life = TRUE, min.hl.points = 3 ), - class = "pknca_halflife_too_few_points" + class = "pknca_warning_halflife_too_few_points_tobit" ) expect_true(is.na(result$lambda.z)) }) @@ -862,11 +862,11 @@ test_that("pk.calc.half.life tobit uses allow.tmax.in.half.life=FALSE", { time <- 0:3 lloq <- 0.1 # FALSE (strict >): keep time > 1 → only conc=1 at time 2 is above-LLOQ - # → 1 point < min.hl.points=2 → pknca_halflife_too_few_points warning + # → 1 point < min.hl.points=2 → pknca_warning_halflife_too_few_points_tobit warning expect_warning( pk.calc.half.life(conc, time, lloq = lloq, hl_method = "tobit", allow.tmax.in.half.life = FALSE, min.hl.points = 2), - class = "pknca_halflife_too_few_points" + class = "pknca_warning_halflife_too_few_points_tobit" ) # TRUE (>=): keep time >= 1 → conc=2 and conc=1 both above-LLOQ # → 2 points meets min.hl.points=2 → fitting succeeds @@ -974,7 +974,7 @@ test_that("fit_half_life_tobit warns on optimization non-convergence", { min.hl.points = 3, tobit_optim_control = list(maxit = 1) ), - class = "pknca_tobit_no_convergence" + class = "pknca_warning_tobit_no_convergence" ) expect_true(is.na(result$lambda.z)) }) diff --git a/tests/testthat/test-impute.R b/tests/testthat/test-impute.R index c67df8df..b07818f5 100644 --- a/tests/testthat/test-impute.R +++ b/tests/testthat/test-impute.R @@ -255,3 +255,28 @@ test_that("PKNCA_impute_fun_list errors when imputation name resolves to a non-f regexp = "The following imputation functions were not found" ) }) + +test_that("get_impute_method", { + ivals <- data.frame(start = 0, end = 24, impute = "start_conc0") + + # impute names a column in intervals directly + expect_equal( + get_impute_method(intervals = data.frame(start = 0, end = 24, myimpute = "start_conc0"), impute = "myimpute"), + "start_conc0" + ) + # impute is NA and a generic "impute" column exists + expect_equal( + get_impute_method(intervals = ivals, impute = NA), + "start_conc0" + ) + # impute is NA and no "impute" column exists -- returns NA itself + expect_equal( + get_impute_method(intervals = data.frame(start = 0, end = 24), impute = NA_character_), + NA_character_ + ) + + # the checkmate::assert_scalar() tightening + expect_error( + get_impute_method(intervals = ivals, impute = list("start_conc0")) + ) +}) diff --git a/tests/testthat/test-interpolate.conc.R b/tests/testthat/test-interpolate.conc.R index 93dff6ab..04198787 100644 --- a/tests/testthat/test-interpolate.conc.R +++ b/tests/testthat/test-interpolate.conc.R @@ -644,7 +644,7 @@ test_that("extrapolate.conc", { ), NA ), - class = "pknca_conc_all_missing" + class = "pknca_warning_all_concentration_missing" ) # Ensure that extrapolation beyond the last point works if the last point is 0 diff --git a/tests/testthat/test-normalize.R b/tests/testthat/test-normalize.R index f0168c60..1d8b5bc2 100644 --- a/tests/testthat/test-normalize.R +++ b/tests/testthat/test-normalize.R @@ -92,7 +92,7 @@ o_nca <- pk.nca(o_data) test_that("normalize_by_col errors when object is not PKNCAresults", { expect_error( normalize_by_col("not_a_results_object", col = "weight", unit = "kg", parameters = "cmax", suffix = ".wn"), - regexp = "The object must be a PKNCAresults object" + regexp = "Must be a PKNCAresults object" ) }) diff --git a/tests/testthat/test-pk.calc.all.R b/tests/testthat/test-pk.calc.all.R index c9ae35e0..ae3a541c 100644 --- a/tests/testthat/test-pk.calc.all.R +++ b/tests/testthat/test-pk.calc.all.R @@ -211,11 +211,13 @@ test_that("pk.nca warnings", { test_that("pk.nca.interval errors", { expect_error( pk.nca.interval(interval="A"), - regexp="Interval must be a data.frame" + regexp="Please report a bug. Interval must be a one-row data.frame", + class = "pknca_error_internal_interval_not_one_row_df" ) expect_error( pk.nca.interval(interval=data.frame()), - regexp="Interval must be a one-row data.frame" + regexp="Please report a bug. Interval must be a one-row data.frame", + class = "pknca_error_internal_interval_not_one_row_df" ) }) @@ -412,10 +414,10 @@ test_that("No interval requested (e.g. for placebo)", { ) expect_warning(expect_warning(expect_warning(expect_warning( myresult <- pk.nca(mydata), - class = "pknca_no_intervals"), - class = "pknca_no_intervals"), - class = "pknca_no_conc_data"), - class = "pknca_all_warnings_no_results" + class = "pknca_warning_no_intervals"), + class = "pknca_warning_no_intervals"), + class = "pknca_warning_no_conc_data"), + class = "pknca_warning_no_results" ) expect_equal( nrow(as.data.frame(myresult)), @@ -568,8 +570,8 @@ test_that("calculate with sparse data", { suppressMessages( expect_warning(expect_warning( o_nca <- pk.nca(o_data_sparse), - class = "pknca_sparse_df_multi"), - class = "pknca_halflife_too_few_points" + class = "pknca_warning_sparse_df_multi"), + class = "pknca_warning_halflife_too_few_points" ) ) df_result <- as.data.frame(o_nca) @@ -592,8 +594,8 @@ test_that("calculate with sparse data", { suppressMessages( expect_warning(expect_warning( o_nca_sparse_mixed <- pk.nca(o_data_sparse_mixed), - class = "pknca_sparse_df_multi"), - class = "pknca_sparse_df_multi" + class = "pknca_warning_sparse_df_multi"), + class = "pknca_warning_sparse_df_multi" ) ) df_result_sparse_mixed <- as.data.frame(o_nca_sparse_mixed) @@ -603,8 +605,8 @@ test_that("calculate with sparse data", { expect_message( expect_warning(expect_warning( o_nca_sparse_mixed <- pk.nca(o_data_sparse_mixed, verbose=TRUE), - class = "pknca_sparse_df_multi"), - class = "pknca_sparse_df_multi" + class = "pknca_warning_sparse_df_multi"), + class = "pknca_warning_sparse_df_multi" ), regexp="No sparse calculations requested for an interval" ) @@ -632,10 +634,10 @@ test_that("calculate with sparse data", { suppressMessages( expect_warning(expect_warning(expect_warning(expect_warning( o_nca_sparse_multi_trt <- pk.nca(o_data_sparse_multi_trt), - class = "pknca_sparse_df_multi"), - class = "pknca_sparse_df_multi"), - class = "pknca_sparse_df_multi"), - class = "pknca_sparse_df_multi" + class = "pknca_warning_sparse_df_multi"), + class = "pknca_warning_sparse_df_multi"), + class = "pknca_warning_sparse_df_multi"), + class = "pknca_warning_sparse_df_multi" ) ) expect_equal(nrow(as.data.frame(o_nca_sparse_multi_trt)), 16) diff --git a/tests/testthat/test-pk.calc.c0.R b/tests/testthat/test-pk.calc.c0.R index 4fb955c4..aa07eff3 100644 --- a/tests/testthat/test-pk.calc.c0.R +++ b/tests/testthat/test-pk.calc.c0.R @@ -4,10 +4,14 @@ test_that("pk.calc.c0", { pk.calc.c0(5:1, 4:0), regexp="Assertion on 'time' failed: Must be sorted." ) - expect_error(pk.calc.c0(5:1, 0:4, time.dose=1:2), - regexp="time.dose must be a scalar") - expect_error(pk.calc.c0(5:1, 0:4, time.dose="1"), - regexp="time.dose must be a number") + expect_error( + pk.calc.c0(5:1, 0:4, time.dose = 1:2), + regexp = "Must have length 1" + ) + expect_error( + pk.calc.c0(5:1, 0:4, time.dose = "1"), + regexp = "Must be of type 'number'" + ) expect_error(pk.calc.c0(5:1, 0:4, method="blah"), regexp="should be one of", info="method must be valid") diff --git a/tests/testthat/test-pk.calc.simple.R b/tests/testthat/test-pk.calc.simple.R index 1e20a814..4cf16c37 100644 --- a/tests/testthat/test-pk.calc.simple.R +++ b/tests/testthat/test-pk.calc.simple.R @@ -61,8 +61,8 @@ test_that("pk.calc.tmax", { # No data give a warning and NA expect_warning(expect_warning( v1 <- pk.calc.tmax(numeric(), numeric()), - class = "pknca_conc_none"), - class = "pknca_time_none" + class = "pknca_warning_no_concentration"), + class = "pknca_warning_no_time" ) expect_equal(v1, NA) @@ -91,8 +91,8 @@ test_that("pk.calc.tmin", { # No data give a warning and NA expect_warning(expect_warning( v1 <- pk.calc.tmin(numeric(), numeric()), - class = "pknca_conc_none"), - class = "pknca_time_none" + class = "pknca_warning_no_concentration"), + class = "pknca_warning_no_time" ) expect_equal(v1, NA) @@ -109,7 +109,7 @@ test_that("pk.calc.tmin", { # All NA concentrations give NA expect_warning( expect_equal(pk.calc.tmin(c(NA, NA), c(0, 1), first.tmin=TRUE), NA), - class = "pknca_conc_all_missing" + class = "pknca_warning_all_concentration_missing" ) # It calculates tmin correctly based on the first.tmin option @@ -186,7 +186,7 @@ test_that("pk.calc.clast.obs", { t1 <- c(0, 1, 2, 3) expect_warning( v1 <- pk.calc.clast.obs(c1, t1), - class = "pknca_conc_all_missing" + class = "pknca_warning_all_concentration_missing" ) expect_equal(v1, NA_real_) @@ -286,8 +286,8 @@ test_that("pk.calc.aucpext", { expect_equal(v1, -100) expect_warning(expect_warning( v2 <- pk.calc.aucpext(auclast=0, aucinf=0), - class = "pknca_aucpext_aucinf_le_auclast"), - class = "pknca_aucpext_aucinf_auclast_positive" + class = "pknca_warning_aucpext_aucinf_le_auclast"), + class = "pknca_warning_aucpext_aucinf_auclast_positive" ) expect_equal(v2, NA_real_, info="aucinf<=0 gives NA_real_ (not infinity)") @@ -529,3 +529,18 @@ test_that("pk.calc.cstart", { regexp = "Assertion on 'time' failed: Contains duplicated values, position 2." ) }) + +test_that("pk.calc.aucabove rejects non-finite conc_above", { + # This is a deliberate tightening from the previous stopifnot()-based check, + # which allowed conc_above = Inf (silently yielding AUC = 0 for all + # profiles, since conc - Inf is always -Inf). Pinned here so it isn't + # accidentally reverted. + expect_error( + pk.calc.aucabove(conc = c(1, 2, 3), time = c(0, 1, 2), conc_above = Inf), + regexp = "finite" + ) + expect_error( + pk.calc.aucabove(conc = c(1, 2, 3), time = c(0, 1, 2), conc_above = -Inf), + regexp = "finite" + ) +}) diff --git a/tests/testthat/test-prepare_data.R b/tests/testthat/test-prepare_data.R index ca93ae32..9c34db25 100644 --- a/tests/testthat/test-prepare_data.R +++ b/tests/testthat/test-prepare_data.R @@ -139,12 +139,12 @@ test_that("standardize_column_names", { # group_cols overlap with cols values fails expect_error( standardize_column_names(data.frame(a=1, b=2), cols=list(c="a", d="b"), group_cols="b"), - regexp="group_cols must not overlap with other column names. Change the name of the following groups: b" + regexp="group_cols must not overlap with other column names. Change the name of the following groups: b" ) # group_cols overlap with cols names fails expect_error( standardize_column_names(data.frame(a=1, b=2), cols=list(c="a", d="b"), group_cols="c"), - regexp="group_cols must not overlap with standardized column names. Change the name of the following groups: c" + regexp="group_cols must not overlap with standardized column names. Change the name of the following groups: c" ) # group_cols works expect_equal( diff --git a/tests/testthat/test-set_and_assert_intervals.R b/tests/testthat/test-set_and_assert_intervals.R index f6f67b1e..67cd3b3d 100644 --- a/tests/testthat/test-set_and_assert_intervals.R +++ b/tests/testthat/test-set_and_assert_intervals.R @@ -14,14 +14,13 @@ test_that("assert_intervals works with valid intervals (ungrouped)", { expect_equal(result, expected = data.frame(start = 0, end = 1, cmax = TRUE)) }) - test_that("assert_intervals errors with non-data frame intervals", { o_conc <- PKNCAconc(as.data.frame(datasets::Theoph), conc~Time|Subject) o_data <- PKNCAdata(o_conc, intervals = data.frame(start = 0, end = 1, cmax = TRUE)) non_df_intervals <- list(a = 1, b = 2) expect_error(assert_intervals(non_df_intervals, data = o_data), - regex = "The 'intervals' argument must be a data frame or a data frame-like object.", + regex = "Must be of type 'data.frame'", fixed = TRUE) }) @@ -31,14 +30,14 @@ test_that("assert_intervals errors with non-data frame intervals (ungrouped)", { non_df_intervals <- list(a = 1, b = 2) expect_error(assert_intervals(intervals = non_df_intervals, data = o_data), - regex = "The 'intervals' argument must be a data frame or a data frame-like object.", + regex = "Must be of type 'data.frame'", fixed = TRUE) }) test_that("assert_intervals errors with non-PKNCAdata data object", { expect_error(assert_intervals(intervals = data.frame(start = 0, end = 1, cmax = TRUE), - data = data.frame(a = 1, b = 2)), - regex = "The 'data' argument must be a PKNCAdata object.", + data = data.frame(a = 1, b = 2)), + regex = "Must inherit from class 'PKNCAdata'", fixed = TRUE) }) @@ -102,6 +101,5 @@ test_that("set_intervals fails when not using PKNCAdata", { o_data <- PKNCAdata(o_conc, intervals = data.frame(start = 0, end = 1, cmax = TRUE)) expect_error(set_intervals(data = o_conc, intervals = data.frame(start = 0, end = 1, cmin = TRUE)), - regex = "The 'data' argument must be a PKNCAdata object.", - fixed = TRUE) + regex = "Must inherit from class 'PKNCAdata'") }) diff --git a/tests/testthat/test-sparse.R b/tests/testthat/test-sparse.R index e685d09e..f0c1cea0 100644 --- a/tests/testthat/test-sparse.R +++ b/tests/testthat/test-sparse.R @@ -36,7 +36,7 @@ test_that("sparse_auc", { test_that("sparse_auclast expected errors", { expect_error( pk.calc.sparse_auclast(auc.type = "foo"), - class = "pknca_sparse_auclast_change_auclast" + class = "pknca_error_sparse_auclast_change_auclast" ) }) @@ -99,19 +99,19 @@ test_that("sparse AUC/AUMC only allow method = 'linear' (#469)", { # *last wrappers that forward `method` through `...` expect_error( pk.calc.sparse_auc(conc=d_sparse$conc, time=d_sparse$time, subject=subject, method="lin up/log down"), - class = "pknca_sparse_method" + class = "pknca_error_sparse_auc_method" ) expect_error( pk.calc.sparse_auclast(conc=d_sparse$conc, time=d_sparse$time, subject=subject, method="lin-log"), - class = "pknca_sparse_method" + class = "pknca_error_sparse_auc_method" ) expect_error( pk.calc.sparse_aumc(conc=d_sparse$conc, time=d_sparse$time, subject=subject, method="lin up/log down"), - class = "pknca_sparse_method" + class = "pknca_error_sparse_aumc_method" ) expect_error( pk.calc.sparse_aumclast(conc=d_sparse$conc, time=d_sparse$time, subject=subject, method="log"), - class = "pknca_sparse_method" + class = "pknca_error_sparse_aumc_method" ) }) @@ -207,7 +207,7 @@ test_that("sparse_aumclast works correctly", { test_that("sparse_aumclast expected errors", { expect_error( pk.calc.sparse_aumclast(auc.type = "foo"), - class = "pknca_sparse_aumclast_change_auc_type" + class = "pknca_error_sparse_aumclast_change_auc_type" ) }) diff --git a/tests/testthat/test-superpostion.R b/tests/testthat/test-superpostion.R index 15eb85b1..15c9c340 100644 --- a/tests/testthat/test-superpostion.R +++ b/tests/testthat/test-superpostion.R @@ -284,45 +284,47 @@ test_that("superposition inputs", { expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, additional.times=c(2, NA)), regexp="No additional.times may be NA \\(to not include any additional.times, enter c\\(\\) as the function argument\\)") + # additional.times nonnumeric expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, additional.times="1"), - regexp="additional.times must be a number") + regexp="Must be of type 'numeric'") expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, additional.times=factor("1")), - regexp="additional.times must be a number") + regexp="Must be of type 'numeric'") # additional times < 0 expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, additional.times=-1), - regexp="All additional.times must be nonnegative") + regexp="Element 1 is not >= 0") expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, additional.times=c(-1, 0)), - regexp="All additional.times must be nonnegative") + regexp="Element 1 is not >= 0") # Additional times > tau expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, additional.times=25), - regexp="All additional.times must be <= tau") + regexp="Element 1 is not <= 24") expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, additional.times=c(0, 25)), - regexp="All additional.times must be <= tau") - + regexp="Element 2 is not <= 24") + # steady.state.tol scalar expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, steady.state.tol=c(1, 2)), - regexp="steady.state.tol must be a scalar") + regexp="Must have length 1") # steady.state.tol numeric expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, steady.state.tol="1"), - regexp="steady.state.tol must be a number") + regexp="Must be of type 'number'") expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, steady.state.tol="1"), - regexp="steady.state.tol must be a number") + regexp="Must be of type 'number'") expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, steady.state.tol=factor("1")), - regexp="steady.state.tol must be a number") + regexp="Must be of type 'number'") expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, steady.state.tol=NA), - regexp="steady.state.tol must be a number") + regexp="May not be NA") + # steady.state.tol range expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, steady.state.tol=0), diff --git a/tests/testthat/test-time.above.R b/tests/testthat/test-time.above.R index 26d83f4e..9bc97bba 100644 --- a/tests/testthat/test-time.above.R +++ b/tests/testthat/test-time.above.R @@ -1,15 +1,15 @@ test_that("time_above expected errors", { expect_error( pk.calc.time_above(conc=c(1, 1), time=c(1, 2), conc_above="X", method="linear"), - regexp='conc_above must be numeric' + regexp="Must be of type 'number'" ) expect_error( pk.calc.time_above(conc=c(1, 1), time=c(1, 2), conc_above=1:2, method="linear"), - regexp='conc_above must be a scalar' + regexp='Must have length 1' ) expect_error( pk.calc.time_above(conc=c(1, 1), time=c(1, 2), conc_above=NA, method="linear"), - regexp='conc_above must not be NA' + regexp='May not be NA' ) expect_error( pk.calc.time_above(time="X", conc_above=5, method="linear"), diff --git a/tests/testthat/test-time.to.steady.state.R b/tests/testthat/test-time.to.steady.state.R index cf8697e8..f9ad2a5b 100644 --- a/tests/testthat/test-time.to.steady.state.R +++ b/tests/testthat/test-time.to.steady.state.R @@ -215,7 +215,7 @@ test_that("pk.tss.stepwise.linear", { level="A", verbose=FALSE ), - regexp="min.points must be a number" + regexp="Must be of type 'number'" ) expect_error( pk.tss.stepwise.linear( @@ -228,9 +228,9 @@ test_that("pk.tss.stepwise.linear", { level="A", verbose=FALSE ), - regexp="min.points must be at least 3" + regexp="Element 1 is not >= 3" ) - + expect_error( pk.tss.stepwise.linear(conc=tmpdata$conc, time=tmpdata$time, @@ -239,7 +239,7 @@ test_that("pk.tss.stepwise.linear", { time.dosing=0:14, level="A", verbose=FALSE), - regexp="level must be a number" + regexp="Must be of type 'numeric'" ) expect_error( @@ -536,7 +536,7 @@ test_that("pk.tss.monoexponential expected warnings and errors", { treatment=tmpdata$treatment, time.dosing=0:14, tss.fraction=factor(1)), - regexp="tss.fraction must be a number" + regexp="Must be of type 'number'" ) suppressWarnings( expect_warning(