From 63c0b41e077a966277bb825dd23da7e0b6dcb903 Mon Sep 17 00:00:00 2001 From: PavanLomati Date: Wed, 27 May 2026 09:19:50 +0530 Subject: [PATCH 1/3] Refactoring with checkmate and rlang --- NEWS.md | 10 + R/001-add.interval.col.R | 126 +++--- R/AIC.list.R | 8 +- R/PKNCA.options.R | 409 +++++++++++------- R/assertions.R | 92 ++-- R/auc.R | 68 ++- R/auc_integrate.R | 30 +- R/aucint.R | 68 +-- R/check.intervals.R | 94 +++- R/choose.intervals.R | 18 +- R/class-PKNCAconc.R | 57 ++- R/class-PKNCAdata.R | 54 ++- R/class-PKNCAdose.R | 62 ++- R/class-PKNCAresults.R | 12 +- R/class-general.R | 83 +++- R/class-summary_PKNCAresults.R | 56 ++- R/cleaners.R | 19 +- R/exclude.R | 44 +- R/exclude_nca.R | 16 +- R/general.functions.R | 16 +- R/half.life.R | 24 +- R/impute.R | 11 +- R/interpolate.conc.R | 116 +++-- R/normalize.R | 33 +- R/parse_formula_to_cols.R | 31 +- R/pk.calc.all.R | 82 +++- R/pk.calc.c0.R | 20 +- R/pk.calc.simple.R | 23 +- R/prepare_data.R | 69 ++- R/provenance.R | 5 +- R/set_and_assert_intervals.R | 19 +- R/sparse.R | 14 +- R/superposition.R | 61 ++- R/time.above.R | 14 +- R/time_calc.R | 35 +- R/tss.R | 22 +- R/tss.monoexponential.R | 54 ++- R/tss.stepwise.linear.R | 56 ++- R/unit-support.R | 73 +++- R/update.PKNCAresults.R | 19 +- man/PKNCA.options.Rd | 2 +- man/pk.nca.intervals.Rd | 2 +- tests/testthat/test-001-add.interval.col.R | 99 +---- tests/testthat/test-PKNCA.options.R | 82 +--- tests/testthat/test-assertions.R | 24 - tests/testthat/test-class-PKNCAconc.R | 4 - tests/testthat/test-class-PKNCAdata.R | 6 - tests/testthat/test-exclude.R | 5 - tests/testthat/test-pk.calc.c0.R | 4 - .../testthat/test-set_and_assert_intervals.R | 37 -- tests/testthat/test-superpostion.R | 40 +- tests/testthat/test-time.above.R | 12 - tests/testthat/test-time.to.steady.state.R | 47 +- 53 files changed, 1510 insertions(+), 977 deletions(-) diff --git a/NEWS.md b/NEWS.md index c13f0a91..de670ce4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,6 +6,16 @@ the dosing including dose amount and route. # PKNCA 0.12.2 +## Improvements + +* Replaced all `stop()` and `warning()` calls with `rlang::abort()` and + `rlang::warn()` respectively, providing structured error and warning classes + for programmatic handling (e.g. `tryCatch(..., pknca_error_* = ...)` and + `withCallingHandlers(..., pknca_warning_* = ...)`). +* Replaced manual scalar, type, and range checks with `checkmate` assertions + (`assert_number()`, `assert_numeric()`, `assert_string()`, `assert_class()`, + etc.) for cleaner and more consistent input validation across all functions. + ## Bug Fixes * `normalize.data.frame()` no longer triggers a dplyr deprecation warning diff --git a/R/001-add.interval.col.R b/R/001-add.interval.col.R index 38142573..62dcb535 100644 --- a/R/001-add.interval.col.R +++ b/R/001-add.interval.col.R @@ -92,22 +92,14 @@ add.interval.col <- function(name, "individual", "population")) { # 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_logical(sparse, any.missing=FALSE, len=1) + checkmate::assert_character(x = name, len = 1, min.chars = 1, any.missing = FALSE, .var.name = "name") + checkmate::assert_character(x = FUN, len = 1, any.missing = TRUE, .var.name = "FUN") # allows NA + checkmate::assert_logical(x = sparse, len = 1, any.missing=FALSE, .var.name = "sparse") + checkmate::assert_character(x = pretty_name, len = 1, min.chars = 1, any.missing=FALSE, .var.name = "pretty_name") + checkmate::assert_character(x = desc, len = 1, any.missing=FALSE, .var.name = "desc") + checkmate::assert_character(x = depends, null.ok = TRUE, .var.name = "depends") + + unit_type <- match.arg( unit_type, @@ -123,42 +115,66 @@ 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) + 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") + #c("interval", "individual", "population"), + checkmate::assert_choice(x = datatype, choices = "interval", .var.name = "datatype") + + checkmate::assert_list( + x = formalsmap, + names = if (length(formalsmap) > 0) "named" else NULL, + .var.name = "formalsmap" + ) + + if (length(formalsmap) > 0) { + + # Ensure FUN exists + if (is.na(FUN)) { + rlang::abort( + message = "`formalsmap` may not be provided when `FUN` is NA", + class = "pknca_error_invalid_formalsmap" + ) + } + + checkmate::assert_character(x= names(formalsmap), min.chars = 1, any.missing = FALSE, + unique = TRUE, .var.name = "names(formalsmap)" + ) } + + # Ensure that the function exists - if (!is.na(FUN) && - length(utils::getAnywhere(FUN)$objs) == 0) { - stop("The function named '", FUN, "' is not defined. Please define the function before calling add.interval.col.") - } - if (!is.na(FUN) & - length(formalsmap) > 0) { - # Ensure that the formalsmap parameters are all in the list of - # formal arguments to the function. - if (!all(names(formalsmap) %in% names(formals(utils::getAnywhere(FUN)$objs[[1]])))) { - stop("All names for the formalsmap list must be arguments to the function.") + if (!is.na(FUN)) { + # Ensure that the function exists + fun_obj <- utils::getAnywhere(FUN) + if (length(fun_obj$objs) == 0) { + rlang::abort( + message = sprintf( + "The function named '%s' is not defined. Please define it before calling add.interval.col().", + FUN + ), + class = "pknca_error_fun_not_found" + ) + } + + # Validate formalsmap parameters match function formals + if (length(formalsmap) > 0) { + fun_formals <- names(formals(fun_obj$objs[[1]])) + invalid_formals <- setdiff(names(formalsmap), fun_formals) + if (length(invalid_formals) > 0) { + rlang::abort( + message = sprintf( + "All names in `formalsmap` must be arguments to the function '%s'. Invalid names: %s", + FUN, + paste(dQuote(invalid_formals), collapse = ", ") + ), + class = "pknca_error_invalid_formalsmap" + ) + } } + } + + current <- get("interval.cols", envir=.PKNCAEnv) current[[name]] <- list( @@ -201,11 +217,17 @@ sort.interval.cols <- function() { deps <- unique(unlist(current[[nextorder]]$depends)) missing_deps <- deps[!(deps %in% names(myorder))] if (length(missing_deps) > 0) { - stop( - "Invalid dependencies for interval column (please report this as a bug): ", - names(myorder)[nextorder], - " The following dependencies are missing: ", - paste(missing_deps, collapse=", ") + rlang::abort( + message = sprintf( + paste0( + "Invalid dependencies for interval column ", + "(please report this as a bug): %s ", + "The following dependencies are missing: %s" + ), + names(myorder)[nextorder], + paste(missing_deps, collapse = ", ") + ), + class = "pknca_error_invalid_dependency" ) } if (!any(is.na(myorder[deps]))) { diff --git a/R/AIC.list.R b/R/AIC.list.R index 9773f435..a4deb239 100644 --- a/R/AIC.list.R +++ b/R/AIC.list.R @@ -25,7 +25,13 @@ 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( + message = paste( + "Unknown way to get a data.frame without indentation set.", + "This is likely a bug." # nocov + ), + class = "pknca_error_unknown_dataframe_indentation" + ) } } } diff --git a/R/PKNCA.options.R b/R/PKNCA.options.R index 0ed0a436..d7d44758 100644 --- a/R/PKNCA.options.R +++ b/R/PKNCA.options.R @@ -9,16 +9,22 @@ "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)") + + checkmate::assert_number(x, .var.name = "adj.r.squared.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") + if (x <= 0 || x >= 1) { + rlang::abort( + message = "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( + message = "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 +34,22 @@ "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)") + + checkmate::assert_number(x, .var.name = "max.missing") # 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") + if (x < 0 || x >= 1) { + rlang::abort( + message = "max.missing must be between 0 and 1", + class = "pknca_error_max.missing_out_of_bounds" + ) + } + #checkmate::assert_number(x, lower = 0, upper = 1, .var.name = "max.missing") + if (x > 0.5) { + rlang::warn( + message = "max.missing is usually <= 0.5", + class = "pknca_warning_max_missing_large" + ) + } x }, auc.method=function(x, default=FALSE, description=FALSE) { @@ -58,22 +71,38 @@ "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( + message = "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( + message = "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( + message = "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( + message = "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( + message = "conc.na must either be a finite number or the text 'drop'", + class = "pknca_error_conc_na_invalid" + ) } x }, @@ -88,24 +117,33 @@ 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( + message = "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( + message = "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( + message = "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( + message = "conc.blq must either be a finite number or the text 'drop' or 'keep'", + class = "pknca_error_conc_blq_invalid" + ) } x } @@ -117,15 +155,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( + message = "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( + message = "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( + message = "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( + message = "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 +201,21 @@ )) 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( + message = "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( + message = paste("Converting first.tmax to a logical value:", x), + class = "pknca_warning_first_tmax_converted" + ) } } x @@ -174,16 +229,19 @@ )) 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( + message = "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( + message = paste("Converting first.tmin to a logical value:", x), + class = "pknca_warning_first_tmin_converted" + ) } } x @@ -195,16 +253,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( + message = "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: ", ret) + rlang::warn( + message = paste("Converting allow.tmax.in.half.life to a logical value:", x), + class = "pknca_warning_allow_tmax_hl_converted" + ) } } x @@ -224,17 +285,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( + message = "Non-integer given for min.hl.points; rounding to nearest integer", + class = "pknca_warning_min_hl_points_noninteger" + ) x <- round(x) } x @@ -244,16 +302,17 @@ 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( + message = "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( + message = "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 +320,25 @@ 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( + message = "max.aucinf.pext must be > 0", + class = "pknca_error_max_aucinf_pext_range" + ) + } + if (x > 25) { + rlang::warn( + message = "max.aucinf.pext is usually <=25", + class = "pknca_warning_max_aucinf_pext_large" + ) + } + if (x < 1) { + rlang::warn( + message = "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 +346,21 @@ 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( + message = "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( + message = "min.hl.r.squared is usually >= 0.9", + class = "pknca_warning_min_hl_r2_small" + ) + } x }, @@ -312,17 +383,27 @@ "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( + message = "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( + message = "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 +443,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 +458,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 +470,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 } ) @@ -426,7 +499,7 @@ #' of the values when used in another function) #' @param name An option name to use with the `value`. #' @param value An option value (paired with the `name`) to set or check (if -#' `NULL`, ). +#' `NULL`, the current value of the option is returned). #' @returns If... #' \describe{ #' \item{no arguments are given}{returns the current options.} @@ -447,7 +520,7 @@ PKNCA.options <- function(..., default=FALSE, check=FALSE, name, value) { current <- get("options", envir=.PKNCAEnv) # If the options have not been initialized, initialize them and then proceed. - if (is.null(current) & !default) { + if (is.null(current) && !default) { PKNCA.options(default=TRUE) current <- get("options", envir=.PKNCAEnv) } @@ -456,21 +529,33 @@ 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( + message = "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( + message = "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( + message = "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( + message = "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 +563,34 @@ 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( + message = "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( + message = paste("Invalid setting for PKNCA:", n), + class = "pknca_error_invalid_option" + ) + } # 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( + message = 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 +605,12 @@ 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( + message = paste("Invalid setting for PKNCA:", n), + class = "pknca_error_invalid_option" + ) + } # Verify and set the option value current[[n]] <- .PKNCA.option.check[[n]](args[[n]]) } @@ -586,57 +690,59 @@ 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( + message = "`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) } - if (missing(name) & missing(point) & missing(spread)) { + if (missing(name) && missing(point) && missing(spread)) { if (reset) assign("summary", current, envir=.PKNCAEnv) return(invisible(current)) } # 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( + message = paste( + "You must first define the parameter name with add.interval.col. Parameters not yet defined are:", + 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, .var.name = "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, .var.name = "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, .var.name = "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, .var.name = "rounding") + if (!(names(rounding) %in% c("signif", "round"))) { - stop("When a list, rounding must have a name of either 'signif' or 'round'") + rlang::abort( + message = "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,7 +752,10 @@ 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( + message = "rounding must be either a list or a function", + class = "pknca_error_rounding_invalid" + ) } # Set the summary parameters assign("summary", current, envir=.PKNCAEnv) diff --git a/R/assertions.R b/R/assertions.R index 467a4765..33fb9f80 100644 --- a/R/assertions.R +++ b/R/assertions.R @@ -9,10 +9,17 @@ #' @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( + message = "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( + message = "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 +34,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( + message = 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_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( + message = 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_mismatch" + ) } } @@ -57,7 +78,10 @@ assert_conc <- function(conc, any_missing_conc = TRUE) { ) } 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( + message = "Negative concentrations found", + class = "pknca_warning_negative_concentration" + ) } } conc @@ -139,7 +163,10 @@ assert_numeric_between <- function(x, any.missing = FALSE, null.ok = FALSE, lowe ) } if (length(msg) > 0) { - stop(paste(msg, collapse = "\n")) + rlang::abort( + message = paste(msg, collapse = "\n"), + class = "pknca_error_numeric_between" + ) } } x @@ -214,7 +241,10 @@ assert_PKNCAdata <- function(object) { #' @export assert_PKNCAresults <- function(object) { if (!inherits(object, "PKNCAresults")) { - stop("Must be a PKNCAresults object") + rlang::abort( + message = "Must be a PKNCAresults object", + class = "pknca_error_not_pkncresults" + ) } object } @@ -224,7 +254,10 @@ assert_PKNCAresults <- function(object) { #' @export assert_PKNCAconc <- function(object) { if (!inherits(object, "PKNCAconc")) { - stop("Must be a PKNCAconc object") + rlang::abort( + message = "Must be a PKNCAconc object", + class = "pknca_error_not_concdata" + ) } object } @@ -234,7 +267,10 @@ assert_PKNCAconc <- function(object) { #' @export assert_PKNCAdose <- function(object) { if (!inherits(object, "PKNCAdose")) { - stop("Must be a PKNCAdose object") + rlang::abort( + message = "Must be a PKNCAdose object", + class = "pknca_error_not_dosedata" + ) } object } @@ -242,16 +278,21 @@ 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) + + if (!(unit %in% names(data))) { + rlang::abort( + message = sprintf("`unit` (%s) must be a column name in the data", unit), + class = "pknca_error_invalid_unit_column" + ) + } + + if (!is.character(data[[unit]])) { + rlang::abort( + message = sprintf("`unit` (%s) must contain character data", unit), + class = "pknca_error_invalid_unit_data" + ) } structure(unit, unit_type = "column") } @@ -264,12 +305,9 @@ assert_unit_value <- function(unit) { if (is.null(unit)) { return(unit) } + + checkmate::assert_character(unit, len = 1) - if (length(unit) != 1) { - stop("`unit` must be a single value") - } else if (!is.character(unit)) { - stop("`unit` must be a character string") - } structure(unit, unit_type = "value") } @@ -290,6 +328,10 @@ 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( + message = conditionMessage(attr(unit_col, "condition")), + class = "pknca_error_invalid_unit" + ) + #stop(unit_col, call. = FALSE) } } diff --git a/R/auc.R b/R/auc.R index 5f6718b9..575b33a2 100644 --- a/R/auc.R +++ b/R/auc.R @@ -106,7 +106,10 @@ pk.calc.auxc <- function(conc, time, interval=c(0, Inf), 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( + message = "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 #### @@ -123,8 +126,14 @@ pk.calc.auxc <- function(conc, time, interval=c(0, Inf), 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( + message = 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 @@ -173,7 +182,10 @@ 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( + message = "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 <- @@ -206,7 +218,13 @@ 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( + message = paste( + "auc.type cannot be changed when calling pk.calc.auc.last,", + "please use pk.calc.auc" + ), + class = "pknca_error_auc_type_override" + ) pk.calc.auc(conc=conc, time=time, ..., options=options, auc.type="AUClast", @@ -217,7 +235,13 @@ 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( + message = paste( + "auc.type cannot be changed when calling pk.calc.auc.inf,", + "please use pk.calc.auc" + ), + class = "pknca_error_auc_type_override" + ) pk.calc.auc(conc=conc, time=time, ..., options=options, auc.type="AUCinf", @@ -246,7 +270,13 @@ 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( + message = paste( + "auc.type cannot be changed when calling pk.calc.auc.all,", + "please use pk.calc.auc" + ), + class = "pknca_error_auc_type_override" + ) pk.calc.auc(conc=conc, time=time, ..., options=options, auc.type="AUCall", lambda.z=NA) @@ -267,7 +297,13 @@ 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( + message = paste( + "auc.type cannot be changed when calling pk.calc.aumc.last,", + "please use pk.calc.aumc" + ), + class = "pknca_error_aumc_type_override" + ) pk.calc.aumc(conc=conc, time=time, ..., options=options, auc.type="AUClast", lambda.z=NA) @@ -278,7 +314,13 @@ 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( + message = paste( + "auc.type cannot be changed when calling pk.calc.aumc.inf,", + "please use pk.calc.aumc" + ), + class = "pknca_error_aumc_type_override" + ) } pk.calc.aumc(conc=conc, time=time, ..., options=options, auc.type="AUCinf", @@ -305,7 +347,13 @@ 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( + message = paste( + "auc.type cannot be changed when calling pk.calc.aumc.all,", + "please use pk.calc.aumc" + ), + class = "pknca_error_aumc_type_override" + ) pk.calc.aumc(conc=conc, time=time, ..., options=options, auc.type="AUCall", lambda.z=NA) diff --git a/R/auc_integrate.R b/R/auc_integrate.R index 336db5ec..b7966408 100644 --- a/R/auc_integrate.R +++ b/R/auc_integrate.R @@ -76,20 +76,16 @@ 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) + checkmate::assert_numeric(conc, len = length(time)) 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)#, finite = TRUE) } # Where is tlast in the data? @@ -124,7 +120,13 @@ 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( + message = sprintf( + "Unknown integration method, please report a bug: %s", + method + ), + class = "pknca_error_unknown_integration_method" + ) # nocov } ret[c(mask_zero, FALSE)] <- "zero" # What happens after tlast? @@ -178,7 +180,13 @@ 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( + message = sprintf( + "Invalid interval_method_extrap, please report a bug: %s", + interval_method_extrap + ), + class = "pknca_error_invalid_interval_method_extrap" + ) # nocov } ret <- sum(ret) ret diff --git a/R/aucint.R b/R/aucint.R index b8aebf86..8e041299 100644 --- a/R/aucint.R +++ b/R/aucint.R @@ -74,7 +74,10 @@ pk.calc.aucint <- 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( + message = "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 @@ -134,7 +137,10 @@ pk.calc.aucint <- function(conc, time, "Time points with missing data are: ", paste(missing_times, collapse=", ")) } - warning(warning_message) + rlang::warn( + message = warning_message, + class = "pknca_warning_missing_interpolated_concentrations" + ) return(NA_real_) } } else { @@ -248,12 +254,6 @@ add.interval.col("aucint.last", pretty_name="AUCint (based on AUClast extrapolation)", desc="The area under the concentration time curve in the interval extrapolating from Tlast to infinity with zeros (matching AUClast)", formalsmap=list(conc="conc.group", time="time.group", time.dose=NULL)) -PKNCA.set.summary( - name="aucint.last", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) add.interval.col("aucint.last.dose", FUN="pk.calc.aucint.last", @@ -262,12 +262,6 @@ add.interval.col("aucint.last.dose", pretty_name="AUCint (based on AUClast extrapolation, dose-aware)", desc="The area under the concentration time curve in the interval extrapolating from Tlast to infinity with zeros (matching AUClast) with dose-aware interpolation/extrapolation of concentrations", formalsmap=list(conc="conc.group", time="time.group", time.dose="time.dose.group")) -PKNCA.set.summary( - name="aucint.last.dose", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) add.interval.col("aucint.all", FUN="pk.calc.aucint.all", @@ -276,12 +270,6 @@ add.interval.col("aucint.all", pretty_name="AUCint (based on AUCall extrapolation)", desc="The area under the concentration time curve in the interval extrapolating from Tlast to infinity with the triangle from Tlast to the next point and zero thereafter (matching AUCall)", formalsmap=list(conc="conc.group", time="time.group", time.dose=NULL)) -PKNCA.set.summary( - name="aucint.all", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) add.interval.col("aucint.all.dose", FUN="pk.calc.aucint.all", @@ -290,12 +278,6 @@ add.interval.col("aucint.all.dose", pretty_name="AUCint (based on AUCall extrapolation, dose-aware)", desc="The area under the concentration time curve in the interval extrapolating from Tlast to infinity with the triangle from Tlast to the next point and zero thereafter (matching AUCall) with dose-aware interpolation/extrapolation of concentrations", formalsmap=list(conc="conc.group", time="time.group", time.dose="time.dose.group")) -PKNCA.set.summary( - name="aucint.all.dose", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) add.interval.col("aucint.inf.obs", FUN="pk.calc.aucint.inf.obs", @@ -305,12 +287,6 @@ add.interval.col("aucint.inf.obs", desc="The area under the concentration time curve in the interval extrapolating from Tlast to infinity with zeros (matching AUClast)", formalsmap=list(conc="conc.group", time="time.group", time.dose=NULL), depends=c("lambda.z", "clast.obs")) -PKNCA.set.summary( - name="aucint.inf.obs", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) add.interval.col("aucint.inf.obs.dose", FUN="pk.calc.aucint.inf.obs", @@ -320,12 +296,6 @@ add.interval.col("aucint.inf.obs.dose", desc="The area under the concentration time curve in the interval extrapolating from Tlast to infinity with zeros (matching AUClast) with dose-aware interpolation/extrapolation of concentrations", formalsmap=list(conc="conc.group", time="time.group", time.dose="time.dose.group"), depends=c("lambda.z", "clast.obs")) -PKNCA.set.summary( - name="aucint.inf.obs.dose", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) add.interval.col("aucint.inf.pred", FUN="pk.calc.aucint.inf.pred", @@ -335,12 +305,6 @@ add.interval.col("aucint.inf.pred", desc="The area under the concentration time curve in the interval extrapolating from Tlast to infinity with the triangle from Tlast to the next point and zero thereafter (matching AUCall)", formalsmap=list(conc="conc.group", time="time.group", time.dose=NULL), depends=c("lambda.z", "clast.pred")) -PKNCA.set.summary( - name="aucint.inf.pred", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) add.interval.col("aucint.inf.pred.dose", FUN="pk.calc.aucint.inf.pred", @@ -350,8 +314,22 @@ add.interval.col("aucint.inf.pred.dose", desc="The area under the concentration time curve in the interval extrapolating from Tlast to infinity with the triangle from Tlast to the next point and zero thereafter (matching AUCall) with dose-aware interpolation/extrapolation of concentrations", formalsmap=list(conc="conc.group", time="time.group", time.dose="time.dose.group"), depends=c("lambda.z", "clast.pred")) + PKNCA.set.summary( - name="aucint.inf.pred.dose", + name= + c( + "aucint.last", + "aucint.last.dose", + + "aucint.all", + "aucint.all.dose", + + "aucint.inf.obs", + "aucint.inf.obs.dose", + + "aucint.inf.pred", + "aucint.inf.pred.dose" + ), description="geometric mean and geometric coefficient of variation", point=business.geomean, spread=business.geocv diff --git a/R/check.intervals.R b/R/check.intervals.R index 1419ef3e..fa7e57e7 100644 --- a/R/check.intervals.R +++ b/R/check.intervals.R @@ -21,17 +21,27 @@ 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( + message = "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( + message = "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( + message = 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,38 +53,67 @@ 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( + message = paste("Cannot assign default value for interval column", 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( + message = paste0( + sprintf("Invalid value(s) in column %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( + message = 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( + message = paste("Invalid 'values' for column specification", n, "(please report this as a bug)."), + 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") + #checkmate::assertNumeric(x$start, any.missing = FALSE) + if (anyNA(x$start)) { + rlang::abort( + message = "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( + message = "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( + message = "start may not be infinite", + class = "pknca_error_interval_infinite_start" + ) } if (any(x$start >= x$end)) { - stop("start must be < end") + rlang::abort( + message = "start must be < end", + class = "pknca_error_interval_start_gte_end" + ) } # Confirm that something is being calculated for each interval (and warn if # not) @@ -85,8 +124,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( + message = paste0( + "Nothing to be calculated in interval specification number(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 +154,10 @@ 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( + message = "Invalid interval definition with no function and multiple dependencies.", + class = "pknca_error_interval_invalid_def" + ) # nocov } } else { retfun <- x$FUN @@ -172,7 +219,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( + message = "`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 374c1d4d..5d8ce6b8 100644 --- a/R/choose.intervals.R +++ b/R/choose.intervals.R @@ -31,10 +31,20 @@ 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( + message = "time.conc may not have any NA values", + class = "pknca_error_timeconc_na" + ) + } + + if (anyNA(time.dosing)){ + rlang::abort( + message = "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 78ca5c48..9354c61f 100644 --- a/R/class-PKNCAconc.R +++ b/R/class-PKNCAconc.R @@ -68,12 +68,21 @@ 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( + message = "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( + message = paste( + "All of the variables in the formula must be in the data. Missing:", + paste(missing_vars, collapse = ", ") + ), + class = "pknca_error_formula_missing_vars" + ) } parsed_form_raw <- parse_formula_to_cols(form = formula) parsed_form_groups <- @@ -95,10 +104,16 @@ 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( + message = "The left hand side of the formula must have exactly one variable", + class = "pknca_error_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( + message = "The right hand side of the formula (excluding groups) must have exactly one variable", + class = "pknca_error_formula_rhs" + ) } # Do some general checking of the concentration and time data to give an early # error if the data are not correct. Do not check monotonic.time because the @@ -114,12 +129,12 @@ 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( + message = "The subject parameter must map to a name in the data", + class = "pknca_error_subject_not_in_data" + ) } parsed_form$subject <- subject if (sparse) { @@ -149,7 +164,10 @@ 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( + message = "Volume must be numeric", + class = "pknca_error_volume_not_numeric" + ) } } if (missing(duration)) { @@ -243,9 +261,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( + message = paste( + "Not all levels are listed in the group names. Missing levels are:", + paste(setdiff(level, grpnames), collapse = ", ") + ), + class = "pknca_error_missing_group_levels" + ) + } grpnames <- level } else if (is.numeric(level)) { if (length(level) == 1 && @@ -294,12 +318,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( + message = "duration must be numeric without missing (NA) or infinite values, and all values must be >= 0", + class = "pknca_error_invalid_duration" + ) } object } diff --git a/R/class-PKNCAdata.R b/R/class-PKNCAdata.R index 68d14095..10de7447 100644 --- a/R/class-PKNCAdata.R +++ b/R/class-PKNCAdata.R @@ -56,7 +56,10 @@ 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( + message = "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 @@ -87,12 +90,10 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., ret$dose <- PKNCAdose(data.dose, formula.dose) } # Check the options - if (!is.list(options)) { - stop("options must be a list.") - } + checkmate::assert_list(options) + 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 +107,18 @@ 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( + message = "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( + message = "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,7 +154,10 @@ 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( + message = paste0(warning_prefix, "No intervals generated likely due to limited concentration data"), + class = "pknca_warning_no_intervals_limited_data" + ) } } else { rlang::warn( @@ -173,12 +183,26 @@ 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) + # 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( + message = "`units` data.frame must have at least names 'PPTESTCD' and 'PPORRESU'", + class = "pknca_error_units_missing_cols" + ) + } + if (nrow(units) == 0) { + rlang::abort( + message = "`units` must have at least one row", + class = "pknca_error_units_no_rows" + ) + } ret$units <- units } diff --git a/R/class-PKNCAdose.R b/R/class-PKNCAdose.R index 18e6fe56..8b5b037a 100644 --- a/R/class-PKNCAdose.R +++ b/R/class-PKNCAdose.R @@ -64,18 +64,27 @@ PKNCAdose.data.frame <- function(data, formula, route, rate, duration, doseu = NULL, doseu_pref = NULL) { # The data must have... data if (nrow(data) == 0) { - stop("data must have at least one row.") + rlang::abort( + message = "data must have at least one row.", + class = "pknca_error_data_no_rows" + ) } # 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( + message = "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( + message = "formula for PKNCAdose may not include a slash", + class = "pknca_error_formula_slash" + ) } parsed_form_groups <- if (length(parsed_form_raw$groups) > 0) { @@ -97,20 +106,35 @@ 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( + message = "The left side of the formula must have zero or one variable", + class = "pknca_error_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( + message = "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( + message = "The right side of the formula (excluding groups) must have exactly one variable", + class = "pknca_error_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( + message = "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( + message = "All of the variables in the groups must be in the data", + class = "pknca_error_groups_not_in_data" + ) } ret <- list( @@ -127,7 +151,10 @@ PKNCAdose.data.frame <- function(data, formula, route, rate, duration, mask.indep <- is.na(getIndepVar.PKNCAdose(ret)) if (any(mask.indep) & !all(mask.indep)) { - 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( + message = "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) @@ -184,7 +211,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( + message = "route must have values of either 'extravascular' or 'intravascular'. Please set to one of those values and retry.", + class = "pknca_error_invalid_route" + ) } object } @@ -212,7 +242,10 @@ 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( + message = "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)) { @@ -225,12 +258,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( + message = "duration must be numeric without missing (NA) or infinite values, and all values must be >= 0", + class = "pknca_error_invalid_duration" + ) } object } diff --git a/R/class-PKNCAresults.R b/R/class-PKNCAresults.R index 7fdefeb9..1e456a67 100644 --- a/R/class-PKNCAresults.R +++ b/R/class-PKNCAresults.R @@ -120,9 +120,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( + message = paste0( + "Not all levels are listed in the group names. Missing levels are: ", + paste(setdiff(level, grpnames), collapse = ", ") + ), + class = "pknca_error_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 beeeb983..f96f4a3c 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( + message = "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 } @@ -92,11 +95,17 @@ 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( + message = "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( + message = "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)) { @@ -116,7 +125,10 @@ setAttributeColumn <- function(object, attr_name, col_or_value, col_name, defaul ) } } else if (!is.character(col_name) | (length(col_name) != 1)) { - stop("col_name must be a character scalar.") + rlang::abort( + message = "col_name must be a character scalar.", + class = "pknca_error_invalid_col_name" + ) } # Set the default value if (missing(default_value)) { @@ -126,17 +138,29 @@ 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( + message = stop_if_default, + class = "pknca_error_used_default_value" + ) } else if (!missing(warn_if_default)) { - warning(warn_if_default) + rlang::warn( + message = warn_if_default, + class = "pknca_warning_used_default_value" + ) } else if (!missing(message_if_default)) { - message(message_if_default) + rlang::inform( + message = 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( + message = "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 @@ -157,18 +181,27 @@ 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( + message = "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( + message = paste0(attr_name, " is not set."), + 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( + message = paste("Columns", paste(missing_cols, collapse = ", "), "are not present."), + class = "pknca_warning_cols_not_present" + ) NULL } else { object[[dataname]][, columns, drop=FALSE] @@ -197,11 +230,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( + message = paste0( + "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 = ", ") + ), + class = "pknca_error_duplicate_rows" ) } object @@ -237,7 +273,10 @@ 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( + message = paste("Please report a bug. Unit setting for", col_units), + class = "pknca_error_unit_setting_bug" + ) # nocov } } for (pref_units in names(all_units$pref)) { @@ -248,11 +287,17 @@ 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( + message = paste("Preferred units may not be set unless original units are set:", 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( + message = paste("Please report a bug. Preferred unit setting for", pref_units), + class = "pknca_error_pref_unit_setting_bug" + ) # nocov } } diff --git a/R/class-summary_PKNCAresults.R b/R/class-summary_PKNCAresults.R index 8b5e0609..b2e6a26d 100644 --- a/R/class-summary_PKNCAresults.R +++ b/R/class-summary_PKNCAresults.R @@ -109,7 +109,10 @@ summary.PKNCAresults <- function(object, ..., 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") + rlang::warn( + message = "summarize_n was requested, but no subject column exists", + class = "pknca_warning_summarize_n_no_subject" + ) summarize_n <- FALSE } @@ -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( + message = "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,11 @@ 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( + message = "Please report a bug. If N is requested, but it is not provided, then it should be set to not calculated.", # nocov + class = "pknca_error_n_is_na" + ) # nocov } } else { ret <- result_group @@ -383,7 +392,10 @@ 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 + rlang::warn( + message = "No results to summarize for result row, please report a bug", # nocov + class = "pknca_warning_no_results_to_summarize" + ) # nocov return(ret) # nocov } current_interval <- dplyr::inner_join(intervals, current_group, by = intersect(names(intervals), names(current_group))) @@ -439,10 +451,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( + message = paste0( + "Multiple units cannot be summarized together. For ", + parameter, ", trying to combine: ", + paste(units, collapse = ", ") + ), + class = "pknca_error_multiple_units" ) } } @@ -450,7 +465,10 @@ 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( + message = paste("Some subjects may have more than one result for", parameter), + class = "pknca_warning_duplicate_subjects" + ) } } else { N <- NULL @@ -459,7 +477,13 @@ 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 + rlang::abort( + message = paste0( + "No summary function is set for parameter ", parameter, + ". Please set it with PKNCA.set.summary and report this as a bug in PKNCA." + ), # nocov + class = "pknca_error_no_summary_function" + ) # nocov } point <- current_summary_instructions$point(current_data[[number_col]]) @@ -578,7 +602,10 @@ 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( + message = paste(name, "is not in the summarization instructions from PKNCA.set.summary"), + class = "pknca_error_missing_summary_instructions" + ) } roundingInstructions <- summary_instructions[[name]]$rounding if (is.function(roundingInstructions)) { @@ -592,7 +619,10 @@ roundingSummarize <- function(x, name) { } 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( + message = paste("Invalid rounding instruction list name for", name, "(please report this as a bug)"), # nocov + class = "pknca_error_invalid_rounding_name" + ) } } if (!is.character(ret)) { diff --git a/R/cleaners.R b/R/cleaners.R index 1b103923..49e54575 100644 --- a/R/cleaners.R +++ b/R/cleaners.R @@ -30,7 +30,10 @@ 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( + message = "Unknown how to handle conc.na", # nocov + class = "pknca_error_unknown_conc_na" + ) } ret } @@ -123,7 +126,10 @@ 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( + message = "There is a bug in cleaning the conc.blq with position names", # nocov + class = "pknca_error_conc_blq_position_bug" + ) } # Choose the rule to apply this_rule <- unname(conc.blq)[[i]] @@ -137,8 +143,13 @@ 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( + message = sprintf( + "Unknown how to handle conc.blq rule %s", # nocov + as.character(this_rule) + ), + class = "pknca_error_unknown_conc_blq_rule" + ) # nocov } } } diff --git a/R/exclude.R b/R/exclude.R index 837826e9..f1d7a864 100644 --- a/R/exclude.R +++ b/R/exclude.R @@ -73,17 +73,29 @@ exclude.default <- function(object, reason, mask, FUN) { mask <- !is.na(reason) } } else if (!xor(missing(mask), missing(FUN))) { - stop("Either mask for FUN must be given (but not both).") + rlang::abort( + message = "Either mask for 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.") - } else if (!is.character(reason)) { - stop("reason must be a character string.") + rlang::abort( + message = "reason must be a scalar or have the same length as the data.", + class = "pknca_error_reason_length" + ) } + checkmate::assert_character(reason, .var.name = "reason") + if (!("exclude" %in% names(object$columns))) { - stop("object must have an exclude column specified.") + rlang::abort( + message = "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( + message = paste0("exclude column must exist in object[['", dataname, "']]."), + class = "pknca_error_exclude_col_missing" + ) } # Make a scalar reason a vector if (length(reason) == 1) @@ -91,7 +103,10 @@ 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( + message = "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 +148,10 @@ 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( + message = "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 +168,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( + message = "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 +179,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( + message = "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..6bfbe948 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( + message = "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( + message = paste("Should not see more than one", parameter, "(please report this as a bug)"), + class = "pknca_error_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 37b22c40..577956cb 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( + message = sprintf("%g new NA value(s) created during conversion", new.na), + class = "pknca_error_new_na_conversion" + ) ret } @@ -79,7 +81,10 @@ 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( + message = "digits must either be a scalar or the same length as x", + class = "pknca_error_digits_length" + ) } } @@ -127,7 +132,10 @@ 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( + message = "Additional, unsupported arguments were passed", + class = "pknca_error_unsupported_args" + ) } if (!missing(si_range)) { .Deprecated(new="roundString with the sci_range argument", diff --git a/R/half.life.R b/R/half.life.R index 6dc8305c..5afb0f51 100644 --- a/R/half.life.R +++ b/R/half.life.R @@ -158,7 +158,10 @@ 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( + message = "lloq must be provided when hl_method is 'tobit'", + class = "pknca_error_lloq_required_tobit" + ) } } @@ -280,7 +283,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( + message = "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)" @@ -376,7 +382,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( + message = "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)" @@ -843,9 +852,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( + message = paste0( + "More than one half-life calculation was attempted on the following rows: ", + 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..6c167026 100644 --- a/R/impute.R +++ b/R/impute.R @@ -4,7 +4,7 @@ #' @param impute the imputation definition #' @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 +124,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( + message = paste0( + "The following imputation functions were not found: ", + 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 9aeee2b2..c6392e24 100644 --- a/R/interpolate.conc.R +++ b/R/interpolate.conc.R @@ -106,7 +106,10 @@ 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( + message = "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 @@ -117,9 +120,15 @@ 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( + message = "Please report a bug: tlast is NA; cannot interpolate/extrapolate", # nocov + class = "pknca_error_tlast_na" + ) # nocov } else if (is.na(time.out[i])) { - warning("An interpolation/extrapolation time is NA") + rlang::warn( + message = "An interpolation/extrapolation time is NA", + class = "pknca_warning_timeout_na" + ) } else if (time.out[i] <= tlast) { ret[i] <- interpolate.conc( @@ -181,7 +190,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( + message = "`interpolate.conc()` does not extrapolate, use `interp.extrap.conc()`", + class = "pknca_error_interpolate_beyond_tlast" + ) } # Verify that we are interpolating between the first concentration # and the last above LOQ concentration @@ -191,7 +203,10 @@ interpolate.conc <- function(conc, time, time.out, } else if (all(data$conc == 0)) { ret <- 0 } else if (time.out > tlast) { - stop("`interpolate.conc()` can only works through Tlast, please use `interp.extrap.conc()` to combine both interpolation and extrapolation.") + rlang::abort( + message = "`interpolate.conc()` can 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. @@ -223,7 +238,10 @@ 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( + message = "Please report a bug: invalid interp_method", # nocov + class = "pknca_error_invalid_interp_method" + ) } } ret @@ -258,15 +276,24 @@ 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( + message = "`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( + message = "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( + message = "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") { @@ -305,7 +332,10 @@ 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( + message = "Invalid auc.type caught too late (seeing this error indicates a software bug)", # nocov + class = "pknca_error_invalid_auc_type_late" + ) } } ret @@ -351,16 +381,28 @@ 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( + message = "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( + message = "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( + message = "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( + message = "duration.dose must either be a scalar or the same length as time.dose", + class = "pknca_error_duration_dose_length" + ) } # Generate a single timeline @@ -407,10 +449,13 @@ 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 + rlang::abort( # nocov + message = paste0( # 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 + class = "pknca_error_unknown_event" # nocov ) # nocov } # Remove "output_only" from event_before and event_after @@ -432,9 +477,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( + message = 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)) { @@ -451,8 +501,13 @@ 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 + rlang::abort( # nocov + message = paste0( # nocov + "No method for imputing concentration at time(s): ", # nocov + paste(unique(data_all$time[mask_no_method]), collapse = ", ") # nocov + ), # nocov + class = "pknca_error_no_interp_method" # nocov + ) # nocov } # Filter to the requested time points and output data_out <- data_all[data_all$out,,drop=FALSE] @@ -480,12 +535,15 @@ 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 + rlang::abort( # nocov + message = 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 + class = "pknca_error_impossible_event_combination" # nocov + ) # nocov } # Observed concentration #### diff --git a/R/normalize.R b/R/normalize.R index c9337699..f3c7f754 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( + message = paste0( + "The normalization table contains groups not present in the data:\n", + 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( + message = "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( + message = "Normalization table must be a single row for ungrouped data.", + class = "pknca_error_norm_table_not_single_row" + ) } } @@ -105,12 +114,13 @@ 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( + message = paste("Column", col, "not found in the PKNCAconc of the PKNCAresults object"), + class = "pknca_error_norm_col_not_found" + ) } conc_groups <- dplyr::group_vars(object$data$conc) if (unit %in% obj_conc_cols) { @@ -124,7 +134,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( + message = "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 464fec57..8162080e 100644 --- a/R/parse_formula_to_cols.R +++ b/R/parse_formula_to_cols.R @@ -25,7 +25,10 @@ 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( + message = "call or formula with length 1 found after finding the operator, unknown how to proceed", # nocov + 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 +38,10 @@ findOperator <- function(x, op, side) { } else if (side == "both") { return(x) } - stop("Unknown side with a found unary operator") # nocov + rlang::abort( + message = "Unknown side with a found unary operator", # nocov + class = "pknca_error_unknown_side_unary" + ) } else if (length(x) == 3) { # Binary operator if (side == "left") { @@ -45,12 +51,18 @@ findOperator <- function(x, op, side) { } else if (side == "both") { return(x) } - stop("Unknown side with a found binary operator") # nocov + rlang::abort( + message = "Unknown side with a found binary operator", # nocov + class = "pknca_error_unknown_side_binary" + ) } } 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( + message = "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 +72,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( + message = sprintf("Cannot handle class %s", paste(class(x), collapse = ", ")), + class = "pknca_error_unhandled_class" + ) } ret } @@ -78,7 +92,10 @@ 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( + message = "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 52d12364..5169799c 100644 --- a/R/pk.calc.all.R +++ b/R/pk.calc.all.R @@ -20,7 +20,12 @@ 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( + message = "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 +38,12 @@ pk.nca <- function(data, verbose=FALSE) { drop=FALSE ] # Calculate the results - if (verbose) message("Starting dense PK NCA calculations.") + if (verbose){ + rlang::inform( + message = "Starting dense PK NCA calculations.", + class = "pknca_message_dense_pk_start" + ) + } results_dense <- purrr::pmap( .l = list( @@ -48,10 +58,20 @@ 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( + message = "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( + message = "Starting sparse PK NCA calculations.", + class = "pknca_message_sparse_pk_start" + ) + } results_sparse <- purrr::pmap( .l=list( @@ -65,7 +85,12 @@ pk.nca <- function(data, verbose=FALSE) { verbose=verbose, sparse=TRUE ) - if (verbose) message("Combining completed sparse PK calculation results.") + if (verbose){ + rlang::inform( + message = "Combining completed sparse PK calculation results.", + class = "pknca_message_sparse_pk_combine" + ) + } results <- dplyr::bind_rows( results, @@ -182,7 +207,7 @@ any_sparse_dense_in_interval <- function(interval, sparse) { #' output from `prepare_PKNCAdose()` #' @param data_intervals A data.frame or tibble with standardized column names #' as output from `prepare_PKNCAintervals()` -#' @param impute The column name in `data_intervals` to use for imputation +#' @param impute The column name in `data_intervals` to use for imputation #' @inheritParams PKNCAdata #' @inheritParams pk.nca #' @inheritParams pk.nca.interval @@ -237,9 +262,21 @@ 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( + message = paste(error_preamble, "No data for interval", sep = ": "), + 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( + message = paste( + "No", + ifelse(sparse, "sparse", "dense"), + "calculations requested for an interval" + ), + class = "pknca_message_no_interval_calculations" + ) + } } else { impute_method <- get_impute_method(intervals = current_interval, impute = impute) args <- list( @@ -280,7 +317,10 @@ pk.nca.intervals <- function(data_conc, data_dose, data_intervals, sparse, uses_exclude_hl <- !is.null(args$exclude_half.life) && !all(is.na(args$exclude_half.life)) } if (uses_include_hl & uses_exclude_hl) { - stop("Cannot both include and exclude half-life points for the same interval") + rlang::abort( + message = "Cannot both include and exclude half-life points for the same interval", + class = "pknca_error_include_exclude_halflife" + ) } # Try the calculation if (use_debug) { @@ -369,10 +409,16 @@ pk.nca.interval <- function(conc, time, volume, duration.conc, include_half.life=NULL, exclude_half.life=NULL, subject, sparse, interval, options=list()) { if (!is.data.frame(interval)) { - stop("Please report a bug. Interval must be a data.frame") + rlang::abort( + message = "Please report a bug. Interval must be a data.frame", + class = "pknca_error_interval_not_df" + ) } if (nrow(interval) != 1) { - stop("Please report a bug. Interval must be a one-row data.frame") + rlang::abort( + message = "Please report a bug. Interval must be a one-row data.frame", + class = "pknca_error_interval_not_one_row" + ) } if (!all(is.na(impute_method))) { impute_funs <- PKNCA_impute_fun_list(impute_method) @@ -399,7 +445,10 @@ 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( + message = "Please report a bug. Length of dose should not be zero.", # nocov + class = "pknca_error_dose_length_zero" + ) # nocov } # Make sure that we calculate all of the dependencies. Do this in # reverse order for dependencies of dependencies. @@ -489,9 +538,12 @@ 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) + rlang::abort( + message = sprintf( + "Cannot find argument %s for NCA function '%s'", + arg_text, all_intervals[[n]]$FUN + ), # nocov end + class = "pknca_error_missing_nca_argument" ) # nocov end } } diff --git a/R/pk.calc.c0.R b/R/pk.calc.c0.R index d228aa7b..4c4a7602 100644 --- a/R/pk.calc.c0.R +++ b/R/pk.calc.c0.R @@ -24,16 +24,20 @@ 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( + message = "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( + message = "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) @@ -76,7 +80,7 @@ pk.calc.c0.method.logslope <- function(conc, time, time.dose=0, c2 <- conc[mask.2] t1 <- time[mask.1] t2 <- time[mask.2] - if (c2 < c1 & + if (c2 < c1 && c2 != 0) { exp(log(c1) - (log(c2)-log(c1))/(t2-t1)*(t1 - time.dose)) } else { diff --git a/R/pk.calc.simple.R b/R/pk.calc.simple.R index 193ec0ca..912dd845 100644 --- a/R/pk.calc.simple.R +++ b/R/pk.calc.simple.R @@ -420,7 +420,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( + message = "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 <- @@ -879,7 +882,10 @@ 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( + message = "'cl' and 'lambda.z' must be the same length", + class = "pknca_error_cl_lambdaz_length" + ) cl/lambda.z } # Add the columns to the interval specification @@ -1128,7 +1134,10 @@ 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( + message = "More than one time matches the starting time. Please report this as a bug with a reproducible example.", + class = "pknca_error_multiple_start_times" + ) # nocov } } add.interval.col("ctrough", @@ -1162,7 +1171,10 @@ 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( + message = "More than one time matches the starting time. Please report this as a bug with a reproducible example.", + class = "pknca_error_multiple_start_times" + ) # nocov } } add.interval.col("cstart", @@ -1337,8 +1349,7 @@ PKNCA.set.summary( #' @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 { diff --git a/R/prepare_data.R b/R/prepare_data.R index ec07ff52..b291eb2a 100644 --- a/R/prepare_data.R +++ b/R/prepare_data.R @@ -13,12 +13,17 @@ #' @keywords Internal #' @noRd full_join_PKNCAconc_PKNCAdose <- function(o_conc, o_dose, extra_cols_conc = character()) { - stopifnot(inherits(x=o_conc, what="PKNCAconc")) + #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( + message = "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")) + #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) @@ -206,9 +211,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( + message = paste0( + "With sparse PK, all subjects in a group must have the same dosing information.\n", + msg_error + ), + class = "pknca_error_sparse_dose_mismatch" ) } } @@ -280,7 +288,10 @@ check_reserved_column_names <- function(x) { ngettext(length(overlap), msg1="name", msg2="names"), "and retry." ) - stop(msg) + rlang::abort( + message = msg, + class = "pknca_error_reserved_column_names" + ) } } @@ -295,25 +306,32 @@ 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") + # 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)) 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( + message = paste0( + "group_cols must not overlap with other column names. Change the name of the following groups: ", + 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( + message = paste0( + "group_cols must not overlap with standardized column names. Change the name of the following groups: ", + paste(group_cols[mask_overlap_colnames], collapse=", ") + ), + class = "pknca_error_group_cols_overlap_names" ) } new_group_cols <- paste0("group", seq_along(group_cols)) @@ -340,11 +358,16 @@ 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( + message = "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( + message = "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..7b0db510 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( + message = "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..9dd8afc0 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, .var.name = "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( + message = paste0( + "The following columns in 'intervals' are not allowed: ", + paste(invalid_columns, collapse = ", ") + ), + class = "pknca_error_invalid_interval_columns" + ) } intervals diff --git a/R/sparse.R b/R/sparse.R index 7a59f2cc..5740612e 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, .var.name = "args") 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( + message = "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,10 @@ 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( + message = paste("Invalid sparse_mean_method:", 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))) diff --git a/R/superposition.R b/R/superposition.R index 11e0931a..8631af6a 100644 --- a/R/superposition.R +++ b/R/superposition.R @@ -79,7 +79,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( + message = "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) @@ -88,11 +91,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( + message = "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( + message = "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)) { @@ -120,39 +129,49 @@ 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( + message = "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, .var.name = "additional.times") + # if (any(additional.times > tau)) + # stop("All additional.times must be <= 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, .var.name = "steady.state.tol") + if (steady.state.tol <= 0 || steady.state.tol >= 1) + rlang::abort( + message = "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( + message = "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( + message = "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( + message = "bug in dose.amount, dose.times, and dose.input handling", + class = "pknca_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 aaad375b..5c1f5db5 100644 --- a/R/time.above.R +++ b/R/time.above.R @@ -22,14 +22,18 @@ 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( + message = "conc must be given", + class = "pknca_error_time_above_missing_conc" + ) } if (missing(time)) { - stop("time must be given") + rlang::abort( + message = "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, .var.name = "conc_above") if (check) { assert_conc_time(conc = conc, time = time) } diff --git a/R/time_calc.R b/R/time_calc.R index 7f0643d4..6e2c32e2 100644 --- a/R/time_calc.R +++ b/R/time_calc.R @@ -23,13 +23,22 @@ 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( + message = "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( + message = "`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( + message = "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 +79,16 @@ 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( + message = "`units` must be provided.", + class = "pknca_error_time_calc_missing_units" + ) } if (!("POSIXt" %in% class(time_obs))) { - stop("Both `time_event` and `time_obs` must be the same class (POSIXt).") + rlang::abort( + message = "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 +101,16 @@ 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( + message = "`units` must be provided.", + class = "pknca_error_time_calc_missing_units" + ) } if (!("difftime" %in% class(time_obs))) { - stop("Both `time_event` and `time_obs` must be the same class (difftime).") + rlang::abort( + message = "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 faf3018f..ee4ecca8 100644 --- a/R/tss.R +++ b/R/tss.R @@ -26,11 +26,17 @@ pk.tss.data.prep <- function(conc, time, subject, treatment, sorted_time <- missing(subject) & missing(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") + if (!missing(subject.dosing) && missing(subject)) { + rlang::abort( + message = "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( + message = "time.dosing may not contain any NA values", + class = "pknca_error_tss_time_dosing_na" + ) } if (!missing(subject)) { if (!missing(treatment)) { @@ -124,7 +130,13 @@ 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( + message = paste( + "Bug in pk.tss where ret is set to non-NA too early.", + "Please report the bug with a reproducible example." + ), + class = "pknca_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 bede733e..e90781a5 100644 --- a/R/tss.monoexponential.R +++ b/R/tss.monoexponential.R @@ -38,25 +38,35 @@ 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( + message = "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, .var.name = "tss.fraction") + if (tss.fraction <= 0 | tss.fraction >= 1) { - stop("tss.fraction must be between 0 and 1, exclusive") + rlang::abort( + message = "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( + message = "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( + message = "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 +99,13 @@ 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( + message = paste( + "Error in selection of return values for pk.tss.monoexponential.", + "This is likely a bug." + ), + class = "pknca_error_tss_return_selection" + ) # nocov } ret } @@ -236,7 +252,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( + message = "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 +286,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( + message = "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 +386,13 @@ 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( + message = paste( + "Please report a bug. Subject must be specified", + "to have subject-level fitting" + ), + class = "pknca_error_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 ab2cd5a2..0db2f329 100644 --- a/R/tss.stepwise.linear.R +++ b/R/tss.stepwise.linear.R @@ -27,32 +27,42 @@ 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( + message = "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, .var.name = "min.points") + if (!length(level) == 1) { - warning("Only first value of level is being used") + rlang::warn( + message = "Only first value of level is being used", + class = "pknca_warning_tss_level_multiple" + ) level <- level[1] } - if (level <= 0 | level >= 1) { - stop("level must be between 0 and 1, exclusive") + + checkmate::assert_numeric(level, any.missing = FALSE, .var.name = "level") + + if (level <= 0 || level >= 1){ + rlang::abort( + message = "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( + message = "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 +76,10 @@ 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( + message = paste("Trying", min(remaining.time, na.rm = TRUE)), + class = "pknca_message_tss_trying_time" + ) } try({ # Try to make the model @@ -91,11 +104,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( + message = 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..bab73b18 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( + message = "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,34 @@ 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 + rlang::abort( + message = paste( + "Please report a bug. Unknown NCA parameters have units defined:", + paste(extra_cols, collapse = ", ") + ), + class = "pknca_internal_unknown_nca_units" + ) # nocov } # Apply conversion factors if (nrow(conversions) > 0) { - stopifnot(!duplicated(conversions$PPORRESU)) + if (any(duplicated(conversions$PPORRESU))) + rlang::abort( + message = "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( + message = "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( + message = "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 +169,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( + message = paste0( + "The following unit conversions were supplied but do not match any units to convert: ", + paste0("'", unexpected_conversions, "'", collapse=", ") + ), + class = "pknca_warning_units_unexpected_conversions" ) } ret <- @@ -245,10 +268,13 @@ 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( + message = paste0( + "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") + ), + class = "pknca_error_units_nonuniform_groups" ) } @@ -345,7 +371,10 @@ 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( + message = paste0("Only one unit may be provided at a time: ", paste(x, collapse = ", ")), + class = "pknca_error_units_multiple_provided" + ) } is.null(x) || is.na(x) } @@ -547,8 +576,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, .var.name = "unit_type") all_intervals <- get.interval.cols() ret <- character() for (nm in names(all_intervals)) { @@ -557,7 +585,10 @@ pknca_find_units_param <- function(unit_type) { } } if (length(ret) == 0) { - stop("No parameters found for unit_type=", unit_type) + rlang::abort( + message = paste0("No parameters found for unit_type=", unit_type), + class = "pknca_error_units_no_params_for_type" + ) } ret } @@ -596,9 +627,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( + message = 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( + message = paste0(msg_missing, "\nThis error can be converted to a warning using `PKNCA.options(allow_partial_missing_units = TRUE)`"), + 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..6912405e 100644 --- a/R/update.PKNCAresults.R +++ b/R/update.PKNCAresults.R @@ -24,11 +24,20 @@ update.PKNCAresults <- function(object, data, ...) { data$options <- PKNCA.options() } if (identical(as_PKNCAdata(object), data)) { - message("No changes detected in data") + rlang::inform( + message = "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( + message = paste( + "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 +77,11 @@ 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( + message = "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/PKNCA.options.Rd b/man/PKNCA.options.Rd index 22751c45..5ede479e 100644 --- a/man/PKNCA.options.Rd +++ b/man/PKNCA.options.Rd @@ -17,7 +17,7 @@ of the values when used in another function)} \item{name}{An option name to use with the \code{value}.} \item{value}{An option value (paired with the \code{name}) to set or check (if -\code{NULL}, ).} +\code{NULL}, the current value of the option is returned).} } \value{ If... diff --git a/man/pk.nca.intervals.Rd b/man/pk.nca.intervals.Rd index 620810d3..3b7b16b5 100644 --- a/man/pk.nca.intervals.Rd +++ b/man/pk.nca.intervals.Rd @@ -30,7 +30,7 @@ dense calculations (FALSE)?} \item{options}{List of changes to the default PKNCA options (see \code{PKNCA.options()})} -\item{impute}{The column name in \code{data_intervals} to use for imputation} +\item{impute}{The column name in \code{data_intervals} to use for imputation} \item{verbose}{Indicate, by \code{message()}, the current state of calculation.} } diff --git a/tests/testthat/test-001-add.interval.col.R b/tests/testthat/test-001-add.interval.col.R index 7a7b72af..908bad7d 100644 --- a/tests/testthat/test-001-add.interval.col.R +++ b/tests/testthat/test-001-add.interval.col.R @@ -3,103 +3,7 @@ original_state <- get("interval.cols", envir=PKNCA:::.PKNCAEnv) test_that("add.interval.col", { # Invalid inputs fail - expect_error( - add.interval.col(name=1), - regexp="name must be a character string", - info="interval column name must be a character string" - ) - expect_error( - add.interval.col(name=c("a", "b")), - regexp="name must have length", - info="interval column name must be a scalar character string" - ) - 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" - ) - 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" - ) - - expect_error( - add.interval.col(name="a", FUN=NA, datatype="interval", desc="test addition"), - regexp='argument "unit_type" is missing, with no default' - ) - expect_error( - add.interval.col(name="a", FUN=NA, 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" - ) - 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" - ) - 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" - ) - - 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'" - ) - - 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" - ) - 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" - ) - 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" - ) - - 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)" - ) - - # formalsmap - expect_error( - add.interval.col(name="a", FUN="mean", unit_type="conc", pretty_name="foo", formalsmap=NA), - regexp="formalsmap must be a 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" - ) - 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" - ) - 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" - ) - 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" - ) - expect_equal( { add.interval.col(name="a", FUN=NA, unit_type="conc", pretty_name="a", datatype="interval", desc="test addition") @@ -171,8 +75,7 @@ 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" ) }) diff --git a/tests/testthat/test-PKNCA.options.R b/tests/testthat/test-PKNCA.options.R index 39e6eb59..47dfb04d 100644 --- a/tests/testthat/test-PKNCA.options.R +++ b/tests/testthat/test-PKNCA.options.R @@ -96,24 +96,16 @@ test_that("PKNCA.options", { # Check all the checks on 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") 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\\)") 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), regexp="adj.r.squared.factor is usually <0.01") # max.missing - expect_error(PKNCA.options(max.missing=c(1, 2), check=TRUE), - regexp="max.missing must be a scalar") - expect_error(PKNCA.options(max.missing="A", check=TRUE), - regexp="max.missing must be numeric \\(and not a factor\\)") 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), @@ -172,10 +164,6 @@ test_that("PKNCA.options", { expect_equal(v1, "drop") 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") - expect_error(PKNCA.options(conc.blq=NA, check=TRUE), - regexp="conc.blq must not be NA") # Confirm that list-style input also works expect_equal(PKNCA.options(conc.blq=list(first="drop", middle=5, last="keep"), @@ -222,8 +210,7 @@ test_that("PKNCA.options", { # first.tmax 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") + # Conversion works expect_warning(v1 <- PKNCA.options(first.tmax="T", check=TRUE), regexp="Converting first.tmax to a logical value: TRUE") @@ -231,22 +218,12 @@ test_that("PKNCA.options", { expect_warning(v1 <- PKNCA.options(first.tmax=1, check=TRUE), 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") 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_error(PKNCA.options(min.hl.points=c(3, 4), check=TRUE), - regexp="min.hl.points must be a scalar") - expect_error(PKNCA.options(min.hl.points=factor(3), check=TRUE), - regexp="min.hl.points cannot be a factor") - expect_error(PKNCA.options(min.hl.points="a", check=TRUE), - regexp="min.hl.points must be a number") - expect_error(PKNCA.options(min.hl.points=1.5, check=TRUE), - regexp="min.hl.points must be >=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 @@ -257,12 +234,6 @@ test_that("PKNCA.options", { 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") - expect_error(PKNCA.options(min.span.ratio=factor(1), check=TRUE), - regexp="min.span.ratio cannot be a factor") - expect_error(PKNCA.options(min.span.ratio="a", check=TRUE), - regexp="min.span.ratio must be a number") expect_warning(PKNCA.options(min.span.ratio=1, check=TRUE), regexp="min.span.ratio is usually >= 2") @@ -271,12 +242,6 @@ test_that("PKNCA.options", { 20) 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") - expect_error(PKNCA.options(max.aucinf.pext=factor(1), check=TRUE), - regexp="max.aucinf.pext cannot be a factor") - expect_error(PKNCA.options(max.aucinf.pext="a", check=TRUE), - regexp="max.aucinf.pext must be a 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), @@ -287,12 +252,6 @@ test_that("PKNCA.options", { 0.9) 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") - expect_error(PKNCA.options(min.hl.r.squared=factor(1), check=TRUE), - regexp="min.hl.r.squared cannot be a factor") - expect_error(PKNCA.options(min.hl.r.squared="a", check=TRUE), - regexp="min.hl.r.squared must be a number") expect_warning(PKNCA.options(min.hl.r.squared=0.89, check=TRUE), regexp="min.hl.r.squared is usually >= 0.9") @@ -303,8 +262,6 @@ test_that("PKNCA.options", { c(1, 2)) 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") # Reset all options to their default to ensure that any subsequent # tests work correctly. @@ -362,38 +319,21 @@ 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() - PKNCA.set.summary(reset=TRUE) + 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") - # 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", - fixed=TRUE - ) - expect_error( - PKNCA.set.summary("auclast", description=c("A", "B")), - regexp="`description` must be a scalar.", - 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") + # 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") 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'") @@ -417,7 +357,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 - PKNCA.set.summary(reset=TRUE) + expect_warning( + PKNCA.set.summary(reset=TRUE), + class = "pknca_warning_summary_reset" + ) expect_equal( PKNCA.set.summary( name=c("cmax", "auclast"), @@ -441,7 +384,10 @@ test_that("PKNCA.set.summary input checking", { ) # Reset all the values to the defaults - PKNCA.set.summary(reset=TRUE) + 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 8311ad16..82877c03 100644 --- a/tests/testthat/test-assertions.R +++ b/tests/testthat/test-assertions.R @@ -152,18 +152,6 @@ test_that("assert_unit_col", { assert_unit_col(unit = "B", data = d), structure("B", unit_type = "column") ) - expect_error( - assert_unit_col(unit = 1:2), - regexp = "`unit` must be a single value" - ) - expect_error( - assert_unit_col(unit = 1), - regexp = "`unit` must be a character string" - ) - expect_error( - assert_unit_col(unit = "D", data = "A"), - regexp = "`data` must be a data.frame" - ) expect_error( assert_unit_col(unit = "D", data = d), regexp = "`unit` (D) must be a column name in the data", @@ -179,14 +167,6 @@ test_that("assert_unit_col", { test_that("assert_unit_value", { expect_equal(assert_unit_value("A"), structure("A", unit_type = "value")) expect_null(assert_unit_value(NULL)) - expect_error( - assert_unit_value(c("A", "B")), - regexp = "`unit` must be a single value" - ) - expect_error( - assert_unit_value(1), - regexp = "`unit` must be a character string" - ) }) test_that("assert_unit", { @@ -201,8 +181,4 @@ test_that("assert_unit", { assert_unit(unit = "C", data = d), structure("C", unit_type = "value") ) - expect_error( - assert_unit(unit = 1, data = d), - regexp = "`unit` must be a character string" - ) }) diff --git a/tests/testthat/test-class-PKNCAconc.R b/tests/testthat/test-class-PKNCAconc.R index 4087a5da..f5cfca51 100644 --- a/tests/testthat/test-class-PKNCAconc.R +++ b/tests/testthat/test-class-PKNCAconc.R @@ -53,10 +53,6 @@ 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="foo"), regexp="The subject parameter must map to a name in the data") diff --git a/tests/testthat/test-class-PKNCAdata.R b/tests/testthat/test-class-PKNCAdata.R index e926403f..2578a54e 100644 --- a/tests/testthat/test-class-PKNCAdata.R +++ b/tests/testthat/test-class-PKNCAdata.R @@ -39,12 +39,6 @@ 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=list(foo=1)), regexp="Invalid setting for PKNCA.*foo", info="Option names") diff --git a/tests/testthat/test-exclude.R b/tests/testthat/test-exclude.R index e3612fea..9844e160 100644 --- a/tests/testthat/test-exclude.R +++ b/tests/testthat/test-exclude.R @@ -134,11 +134,6 @@ test_that("exclude.default", { FUN=function(x, ...) TRUE), 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.", - info="Interpretation of a non-character reason is unclear") # Check operation obj4 <- obj1 diff --git a/tests/testthat/test-pk.calc.c0.R b/tests/testthat/test-pk.calc.c0.R index 4fb955c4..d19ffe5b 100644 --- a/tests/testthat/test-pk.calc.c0.R +++ b/tests/testthat/test-pk.calc.c0.R @@ -4,10 +4,6 @@ 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, method="blah"), regexp="should be one of", info="method must be valid") diff --git a/tests/testthat/test-set_and_assert_intervals.R b/tests/testthat/test-set_and_assert_intervals.R index f6f67b1e..ce880bc0 100644 --- a/tests/testthat/test-set_and_assert_intervals.R +++ b/tests/testthat/test-set_and_assert_intervals.R @@ -14,34 +14,6 @@ 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.", - fixed = TRUE) -}) - -test_that("assert_intervals errors with non-data frame intervals (ungrouped)", { - o_conc <- PKNCAconc(as.data.frame(datasets::Theoph)[datasets::Theoph$Subject == 1,], conc~Time) - 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(intervals = non_df_intervals, data = o_data), - regex = "The 'intervals' argument must be a data frame or a data frame-like object.", - 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.", - fixed = TRUE) -}) - test_that("assert_intervals errors with invalid columns", { 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)) @@ -96,12 +68,3 @@ test_that("set_intervals fails with invalid intervals", { regex = "The following columns in 'intervals' are not allowed:", fixed = TRUE) }) - -test_that("set_intervals fails when not using PKNCAdata", { - 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)) - - 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) -}) diff --git a/tests/testthat/test-superpostion.R b/tests/testthat/test-superpostion.R index 15eb85b1..00570f01 100644 --- a/tests/testthat/test-superpostion.R +++ b/tests/testthat/test-superpostion.R @@ -284,45 +284,9 @@ 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") - expect_error(superposition(conc=c(0, 2), time=c(0, 1), tau=24, - additional.times=factor("1")), - regexp="additional.times must be a number") - # 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") - 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") - # 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") - 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") - # 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") - # 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") - 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") - 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") - 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") + + # 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..70e6a6e6 100644 --- a/tests/testthat/test-time.above.R +++ b/tests/testthat/test-time.above.R @@ -1,16 +1,4 @@ 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' - ) - 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' - ) - 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' - ) expect_error( pk.calc.time_above(time="X", conc_above=5, method="linear"), regexp='conc must be given' diff --git a/tests/testthat/test-time.to.steady.state.R b/tests/testthat/test-time.to.steady.state.R index cf8697e8..55cdcdb3 100644 --- a/tests/testthat/test-time.to.steady.state.R +++ b/tests/testthat/test-time.to.steady.state.R @@ -204,43 +204,7 @@ test_that("pk.tss.stepwise.linear", { regexp="Only first value of min.points is used" ) - expect_error( - pk.tss.stepwise.linear( - conc=tmpdata$conc, - time=tmpdata$time, - subject=tmpdata$subject, - treatment=tmpdata$treatment, - time.dosing=0:14, - min.points="A", - level="A", - verbose=FALSE - ), - regexp="min.points must be a number" - ) - expect_error( - pk.tss.stepwise.linear( - conc=tmpdata$conc, - time=tmpdata$time, - subject=tmpdata$subject, - treatment=tmpdata$treatment, - time.dosing=0:14, - min.points=1, - level="A", - verbose=FALSE - ), - regexp="min.points must be at least 3" - ) - - expect_error( - pk.tss.stepwise.linear(conc=tmpdata$conc, - time=tmpdata$time, - subject=tmpdata$subject, - treatment=tmpdata$treatment, - time.dosing=0:14, - level="A", - verbose=FALSE), - regexp="level must be a number" - ) + expect_error( pk.tss.stepwise.linear(conc=tmpdata$conc, @@ -529,15 +493,6 @@ test_that("pk.tss.monoexponential corner case tests", { test_that("pk.tss.monoexponential expected warnings and errors", { tmpdata <- generate.data() - expect_error( - pk.tss.monoexponential(conc=tmpdata$conc, - time=tmpdata$time, - subject=tmpdata$subject, - treatment=tmpdata$treatment, - time.dosing=0:14, - tss.fraction=factor(1)), - regexp="tss.fraction must be a number" - ) suppressWarnings( expect_warning( pk.tss.monoexponential( From 1609cde2c7130201fa6fddf0e1e747c521ef5702 Mon Sep 17 00:00:00 2001 From: PavanLomati Date: Tue, 2 Jun 2026 13:09:03 +0530 Subject: [PATCH 2/3] Checkmate .var.name Update --- R/001-add.interval.col.R | 38 ++++++++++++++++------------------ R/PKNCA.options.R | 8 +++---- R/assertions.R | 14 +++++++++---- R/auc.R | 13 ++++-------- R/aucint.R | 6 +----- R/class-PKNCAdata.R | 2 +- R/class-PKNCAdose.R | 17 ++++++++------- R/class-general.R | 6 +++--- R/class-summary_PKNCAresults.R | 9 +++++--- R/exclude.R | 8 +++---- R/pk.calc.all.R | 12 ++++++----- R/pk.calc.c0.R | 2 +- R/superposition.R | 8 +++---- R/tss.monoexponential.R | 10 ++++----- 14 files changed, 77 insertions(+), 76 deletions(-) diff --git a/R/001-add.interval.col.R b/R/001-add.interval.col.R index 62dcb535..708d1ee5 100644 --- a/R/001-add.interval.col.R +++ b/R/001-add.interval.col.R @@ -92,14 +92,13 @@ add.interval.col <- function(name, "individual", "population")) { # Check inputs - checkmate::assert_character(x = name, len = 1, min.chars = 1, any.missing = FALSE, .var.name = "name") - checkmate::assert_character(x = FUN, len = 1, any.missing = TRUE, .var.name = "FUN") # allows NA - checkmate::assert_logical(x = sparse, len = 1, any.missing=FALSE, .var.name = "sparse") - checkmate::assert_character(x = pretty_name, len = 1, min.chars = 1, any.missing=FALSE, .var.name = "pretty_name") - checkmate::assert_character(x = desc, len = 1, any.missing=FALSE, .var.name = "desc") - checkmate::assert_character(x = depends, null.ok = TRUE, .var.name = "depends") + 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) - unit_type <- match.arg( unit_type, @@ -116,18 +115,19 @@ add.interval.col <- function(name, ) ) + # Validate datatype datatype <- match.arg(datatype) - #c("interval", "individual", "population"), - checkmate::assert_choice(x = datatype, choices = "interval", .var.name = "datatype") - + #c("interval", "individual", "population"), # Currently only interval datatype is supported + checkmate::assert_choice(x = datatype, choices = "interval") + + # Validate formalsmap checkmate::assert_list( x = formalsmap, - names = if (length(formalsmap) > 0) "named" else NULL, - .var.name = "formalsmap" + names = if (length(formalsmap) > 0) "named" else NULL ) + # Validate formalsmap and function compatibility if (length(formalsmap) > 0) { - # Ensure FUN exists if (is.na(FUN)) { rlang::abort( @@ -135,12 +135,10 @@ add.interval.col <- function(name, class = "pknca_error_invalid_formalsmap" ) } - - checkmate::assert_character(x= names(formalsmap), min.chars = 1, any.missing = FALSE, - unique = TRUE, .var.name = "names(formalsmap)" - ) + # Ensure formalsmap names are unique + checkmate::assert_character(x= names(formalsmap), min.chars = 1, + any.missing = FALSE, unique = TRUE) } - # Ensure that the function exists if (!is.na(FUN)) { @@ -206,7 +204,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. @@ -230,7 +228,7 @@ sort.interval.cols <- function() { 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/PKNCA.options.R b/R/PKNCA.options.R index d7d44758..9aee95b8 100644 --- a/R/PKNCA.options.R +++ b/R/PKNCA.options.R @@ -718,25 +718,25 @@ PKNCA.set.summary <- function(name, description, point, spread, current[[current_name]] <- list() } # Confirm that description is a scalar character string - checkmate::assert_string(description, .var.name = "description") + checkmate::assert_string(description) for (current_name in name) { current[[current_name]]$description <- description } # Confirm that point is a function - checkmate::assert_function(point, .var.name = "point") + 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)) { - checkmate::assert_function(spread, .var.name = "spread") + 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)) { - checkmate::assert_list(rounding, len = 1, .var.name = "rounding") + checkmate::assert_list(rounding, len = 1) if (!(names(rounding) %in% c("signif", "round"))) { rlang::abort( diff --git a/R/assertions.R b/R/assertions.R index 33fb9f80..8bdd614f 100644 --- a/R/assertions.R +++ b/R/assertions.R @@ -8,7 +8,7 @@ #' @returns `interval` (or `c(start, end)`) #' @keywords Internal assert_intervaltime_single <- function(interval = NULL, start = NULL, end = NULL) { - if (is.null(interval) & is.null(start) & is.null(end)) { + if (is.null(interval) && is.null(start) && is.null(end)) { rlang::abort( message = "One of `interval` or `start` and `end` must be given", class = "pknca_error_missing_interval" @@ -140,7 +140,7 @@ assert_conc_time <- function(conc, time, any_missing_conc = TRUE, sorted_time = #' @returns `x` assert_numeric_between <- function(x, any.missing = FALSE, null.ok = FALSE, lower_eq = -Inf, lower = -Inf, upper = Inf, upper_eq = Inf, ..., .var.name = checkmate::vname(x)) { checkmate::assert_numeric(x, any.missing = any.missing, null.ok = null.ok, lower = lower_eq, upper = upper_eq, ..., .var.name = .var.name) - if (is.null(x) & null.ok) { + if (is.null(x) && null.ok) { # do nothing } else { # disallowed missing will have been previously caught @@ -228,10 +228,16 @@ 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( + message = "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( + message = "No intervals given; no calculations will be done.", + class = "pknca_warning_no_intervals" + ) } object } diff --git a/R/auc.R b/R/auc.R index 575b33a2..9b5a1608 100644 --- a/R/auc.R +++ b/R/auc.R @@ -1,4 +1,4 @@ -#' A compute the Area Under the (Moment) Curve +#' Compute the Area Under the (Moment) Curve #' #' Compute the area under the curve (AUC) and the area under the moment curve #' (AUMC) for pharmacokinetic (PK) data. AUC and AUMC are used for many @@ -21,23 +21,18 @@ #' @inheritParams choose_interval_method #' @inheritParams assert_lambdaz #' @inheritParams PKNCA.choose.option +#' @inheritParams clean.conc.blq #' @param clast,clast.obs,clast.pred The last concentration above the limit of #' quantification; this is used for AUCinf calculations. If provided as #' clast.obs (observed clast value, default), AUCinf is AUCinf,obs. If #' provided as clast.pred, AUCinf is AUCinf,pred. -#' @param conc.blq How to handle BLQ values in between the first and last above -#' LOQ concentrations. (See [clean.conc.blq()] for usage instructions.) -#' @param conc.na How to handle missing concentration values. (See -#' [clean.conc.na()] for usage instructions.) -#' @param check Run [assert_conc_time()], [clean.conc.blq()], and -#' [clean.conc.na()]? #' @param fun_linear The function to use for integration of the linear part of #' the curve (not required for AUC or AUMC functions) #' @param fun_log The function to use for integration of the logarithmic part of #' the curve (if log integration is used; not required for AUC or AUMC #' functions) #' @param fun_inf The function to use for extrapolation from the final -#' measurement to infinite time (not required for AUC or AUMC functions. +#' measurement to infinite time (not required for AUC or AUMC functions). #' @param ... For functions other than `pk.calc.auxc`, these values are passed #' to `pk.calc.auxc` #' @returns A numeric value for the AU(M)C. @@ -105,7 +100,7 @@ pk.calc.auxc <- function(conc, time, interval=c(0, Inf), } auc.type <- match.arg(auc.type) interval <- assert_intervaltime_single(interval = interval) - if (auc.type %in% "AUCinf" & is.finite(interval[2])) { + if (auc.type %in% "AUCinf" && is.finite(interval[2])) { rlang::warn( message = "Requesting AUCinf when the end of the interval is not Inf", class = "pknca_warning_aucinf_finite_interval" diff --git a/R/aucint.R b/R/aucint.R index 8e041299..9716da1a 100644 --- a/R/aucint.R +++ b/R/aucint.R @@ -12,10 +12,6 @@ #' @inheritParams pk.calc.auxc #' @inheritParams assert_intervaltime_single #' @inheritParams assert_lambdaz -#' @param clast,clast.obs,clast.pred The last concentration above the limit of -#' quantification; this is used for AUCinf calculations. If provided as -#' clast.obs (observed clast value, default), AUCinf is AUCinf,obs. If -#' provided as clast.pred, AUCinf is AUCinf,pred. #' @param time.dose,route,duration.dose The time of doses, route of #' administration, and duration of dose used with interpolation and #' extrapolation of concentration data (see [interp.extrap.conc.dose()]). If @@ -78,7 +74,7 @@ pk.calc.aucint <- function(conc, time, message = "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) { + } else if (clast != clast_obs && interval[2] > tlast) { # If using clast.pred, we need to doubly calculate at tlast. conc_clast <- clast time_clast <- tlast diff --git a/R/class-PKNCAdata.R b/R/class-PKNCAdata.R index 10de7447..7bd895ab 100644 --- a/R/class-PKNCAdata.R +++ b/R/class-PKNCAdata.R @@ -106,7 +106,7 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., class(ret) <- c("PKNCAdata", class(ret)) # Check the intervals - if (missing(intervals) & identical(ret$dose, NA)) { + if (missing(intervals) && identical(ret$dose, NA)) { rlang::abort( message = "If data.dose is not given, intervals must be given", class = "pknca_error_missing_intervals" diff --git a/R/class-PKNCAdose.R b/R/class-PKNCAdose.R index 8b5b037a..24c1b8fc 100644 --- a/R/class-PKNCAdose.R +++ b/R/class-PKNCAdose.R @@ -18,12 +18,12 @@ #' @param time.nominal (optional) The name of the nominal time column (if the #' main time variable is actual time. The `time.nominal` is not used during #' calculations; it is available to assist with data summary and checking. -#' @param exclude (optional) The name of a column with concentrations to exclude +#' @param exclude (optional) The name of a column with doses to exclude #' from calculations and summarization. If given, the column should have -#' values of `NA` or `""` for concentrations to include and non-empty text for -#' concentrations to exclude. +#' values of `NA` or `""` for doses to include and non-empty text for +#' doses to exclude. #' @param ... Ignored. -#' @returns A PKNCAconc object that can be used for automated NCA. +#' @returns A PKNCAdose object that can be used for automated NCA. #' @details The `formula` for a `PKNCAdose` object can be #' given three ways: one-sided (missing left side), one-sided (missing #' right side), or two-sided. Each of the three ways can be given @@ -37,7 +37,8 @@ #' `dose~.|treatment+subject`, and only a single row may be given #' per group. When the right side is missing, PKNCA assumes that the #' same dose is given in every interval. When given as a two-sided -#' formula +#' formula, both the dose amount and time are used directly from the +#' data. #' @family PKNCA objects #' @export PKNCAdose <- function(data, ...) @@ -237,11 +238,11 @@ setDuration.PKNCAdose <- function(object, duration, rate, dose, ...) { if (missing(dose)) { dose <- object$columns$dose } - if (missing(duration) & missing(rate)) { + if (missing(duration) && missing(rate)) { object <- setAttributeColumn(object=object, attr_name="duration", default_value=0, message_if_default="Assuming instant dosing (duration=0)") - } else if (!missing(duration) & !missing(rate)) { + } else if (!missing(duration) && !missing(rate)) { rlang::abort( message = "Both duration and rate cannot be given at the same time", class = "pknca_error_duration_and_rate" @@ -250,7 +251,7 @@ setDuration.PKNCAdose <- function(object, duration, rate, dose, ...) { # requiring near-equal checks for floating point error. } else if (!missing(duration)) { object <- setAttributeColumn(object=object, attr_name="duration", col_or_value=duration) - } else if (!missing(rate) & !missing(dose) && !is.na(dose)) { + } else if (!missing(rate) && !missing(dose) && !is.na(dose)) { tmprate <- getColumnValueOrNot(object$data, rate, "rate") tmpdose <- getColumnValueOrNot(object$data, dose, "dose") duration <- tmpdose$data[[tmpdose$name]]/tmprate$data[[tmprate$name]] diff --git a/R/class-general.R b/R/class-general.R index f96f4a3c..f9dff76f 100644 --- a/R/class-general.R +++ b/R/class-general.R @@ -94,13 +94,13 @@ setAttributeColumn <- function(object, attr_name, col_or_value, col_name, defaul stop_if_default, warn_if_default, message_if_default) { dataname <- getDataName(object) # Check inputs - if (!is.character(attr_name) | (length(attr_name) != 1)) { + if (!is.character(attr_name) || (length(attr_name) != 1)) { rlang::abort( message = "attr_name must be a character scalar.", class = "pknca_error_invalid_attr_name" ) } - if (!missing(col_or_value) & + if (!missing(col_or_value) && any(!c(missing(col_name), missing(default_value)))) { rlang::abort( message = "Cannot provide col_or_value and col_name or default_value", @@ -124,7 +124,7 @@ setAttributeColumn <- function(object, attr_name, col_or_value, col_name, defaul class = paste0("pknca_foundcolumn_", attr_name) ) } - } else if (!is.character(col_name) | (length(col_name) != 1)) { + } else if (!is.character(col_name) || (length(col_name) != 1)) { rlang::abort( message = "col_name must be a character scalar.", class = "pknca_error_invalid_col_name" diff --git a/R/class-summary_PKNCAresults.R b/R/class-summary_PKNCAresults.R index b2e6a26d..b7a4e0fa 100644 --- a/R/class-summary_PKNCAresults.R +++ b/R/class-summary_PKNCAresults.R @@ -108,7 +108,7 @@ 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) { + } else if (summarize_n && !has_subject_col) { rlang::warn( message = "summarize_n was requested, but no subject column exists", class = "pknca_warning_summarize_n_no_subject" @@ -518,7 +518,7 @@ summarize_PKNCAresults_parameter <- function(data, parameter, subject_col, inclu result_txt <- paste0(point_txt, spread_txt) } - if (na_point & na_spread) { + if (na_point && na_spread) { result_txt <- not_calculated } else if (include_units) { result_txt <- paste(result_txt, units) @@ -612,7 +612,10 @@ roundingSummarize <- function(x, name) { 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( + message = paste0("Cannot interpret rounding instructions for ", name, " (please report this as a bug)"), # nocov + class = "pknca_error_rounding_instructions" + ) } if ("signif" == names(roundingInstructions)) { ret <- signifString(x, roundingInstructions$signif) diff --git a/R/exclude.R b/R/exclude.R index f1d7a864..77df0b90 100644 --- a/R/exclude.R +++ b/R/exclude.R @@ -39,7 +39,7 @@ utils::globalVariables(c("exclude_current_group_XXX", "row_number_XXX", "exclude exclude.default <- function(object, reason, mask, FUN) { dataname <- getDataName(object) # Check inputs - if (missing(mask) & !missing(FUN)) { + if (missing(mask) && !missing(FUN)) { # operate on one group at a time groupnames <- unique(c( @@ -84,7 +84,7 @@ exclude.default <- function(object, reason, mask, FUN) { class = "pknca_error_reason_length" ) } - checkmate::assert_character(reason, .var.name = "reason") + checkmate::assert_character(reason) if (!("exclude" %in% names(object$columns))) { rlang::abort( @@ -159,7 +159,7 @@ setExcludeColumn <- function(object, exclude = NULL, dataname = "data") { add.exclude <- TRUE } if (add.exclude) { - if (missing(exclude) | is.null(exclude)) { + if (missing(exclude) || is.null(exclude)) { # Generate the column name exclude <- setdiff(c("exclude", paste0("exclude.", max(names(object[[dataname]])))), @@ -175,7 +175,7 @@ setExcludeColumn <- function(object, exclude = NULL, dataname = "data") { } else { if (is.factor(object[[dataname]][[exclude]])) { object[[dataname]][[exclude]] <- as.character(object[[dataname]][[exclude]]) - } else if (is.logical(object[[dataname]][[exclude]]) & + } else if (is.logical(object[[dataname]][[exclude]]) && all(is.na(object[[dataname]][[exclude]]))) { object[[dataname]][[exclude]] <- rep(NA_character_, nrow(object[[dataname]])) } else if (!is.character(object[[dataname]][[exclude]])) { diff --git a/R/pk.calc.all.R b/R/pk.calc.all.R index 5169799c..ac8f8476 100644 --- a/R/pk.calc.all.R +++ b/R/pk.calc.all.R @@ -316,7 +316,7 @@ pk.nca.intervals <- function(data_conc, data_dose, data_intervals, sparse, args$exclude_half.life <- conc_data_interval$exclude_half.life uses_exclude_hl <- !is.null(args$exclude_half.life) && !all(is.na(args$exclude_half.life)) } - if (uses_include_hl & uses_exclude_hl) { + if (uses_include_hl && uses_exclude_hl) { rlang::abort( message = "Cannot both include and exclude half-life points for the same interval", class = "pknca_error_include_exclude_halflife" @@ -330,9 +330,11 @@ 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( # nocov + message = paste("Please report a bug.\n", error_preamble, e$message, sep=": "), # nocov + class = "pknca_error_interval_calculation", # nocov + parent = e # nocov + ) } ) } @@ -462,7 +464,7 @@ pk.nca.interval <- function(conc, time, volume, duration.conc, request_to_calculate <- as.logical(interval[[n]]) has_calculation_function <- !is.na(all_intervals[[n]]$FUN) is_correct_sparse_dense <- all_intervals[[n]]$sparse == sparse - if (request_to_calculate & has_calculation_function & is_correct_sparse_dense) { + if (request_to_calculate && has_calculation_function && is_correct_sparse_dense) { call_args <- list() exclude_from_argument <- character(0) # Prepare to call the function by setting up its arguments. diff --git a/R/pk.calc.c0.R b/R/pk.calc.c0.R index 4c4a7602..9cbfe5ce 100644 --- a/R/pk.calc.c0.R +++ b/R/pk.calc.c0.R @@ -43,7 +43,7 @@ pk.calc.c0 <- function(conc, time, time.dose=0, 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/superposition.R b/R/superposition.R index 8631af6a..da265e79 100644 --- a/R/superposition.R +++ b/R/superposition.R @@ -134,12 +134,12 @@ superposition.numeric <- function(conc, time, dose.input = NULL, class = "pknca_error_superposition_additional_times_na" ) } - checkmate::assert_numeric(additional.times, lower = 0, upper = tau, .var.name = "additional.times") + checkmate::assert_numeric(additional.times, lower = 0, upper = tau) # if (any(additional.times > tau)) # stop("All additional.times must be <= tau") } # steady.state.tol - checkmate::assert_number(steady.state.tol, na.ok = FALSE, .var.name = "steady.state.tol") + checkmate::assert_number(steady.state.tol, na.ok = FALSE) if (steady.state.tol <= 0 || steady.state.tol >= 1) rlang::abort( message = "steady.state.tol must be between 0 and 1, exclusive.", @@ -156,7 +156,7 @@ superposition.numeric <- function(conc, time, dose.input = NULL, 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)) & + if (any(c(has.lambda.z, has.clast.pred, has.tlast)) && !all(c(has.lambda.z, has.clast.pred, has.tlast))) rlang::abort( message = "Either give all or none of the values for these arguments: lambda.z, clast.pred, and tlast", @@ -214,7 +214,7 @@ superposition.numeric <- function(conc, time, dose.input = NULL, } # cannot continue extrapolating due to missing data (likely due to # half-life not calculable) - if ((n.tau * tau) > tlast & is.na(lambda.z)) { + if ((n.tau * tau) > tlast && is.na(lambda.z)) { ret$conc <- NA } else { # Do the math! (Finally) diff --git a/R/tss.monoexponential.R b/R/tss.monoexponential.R index e90781a5..60f6d098 100644 --- a/R/tss.monoexponential.R +++ b/R/tss.monoexponential.R @@ -45,9 +45,9 @@ pk.tss.monoexponential <- function(..., ) tss.fraction <- tss.fraction[1] } - checkmate::assert_number(tss.fraction, na.ok = FALSE, .var.name = "tss.fraction") + checkmate::assert_number(tss.fraction, na.ok = FALSE) - if (tss.fraction <= 0 | tss.fraction >= 1) { + if (tss.fraction <= 0 || tss.fraction >= 1) { rlang::abort( message = "tss.fraction must be between 0 and 1, exclusive", class = "pknca_error_tss_fraction_range" @@ -92,7 +92,7 @@ pk.tss.monoexponential <- function(..., NA } ret <- - if (!identical(NA, ret_population) & !identical(NA, ret_individual)) { + if (!identical(NA, ret_population) && !identical(NA, ret_individual)) { merge(ret_population, ret_individual) } else if (!identical(NA, ret_population)) { ret_population @@ -250,7 +250,7 @@ pk.tss.monoexponential.population <- function(data, ) if (verbose) print(all.model.summary) - if (all(is.na(all.model.summary$AIC)) | + if (all(is.na(all.model.summary$AIC)) || length(all.model.summary) == 0) { rlang::warn( message = "No population model for monoexponential Tss converged, no results given", @@ -378,7 +378,7 @@ pk.tss.monoexponential.individual <- function(data, ) ) ) - if ("subject" %in% names(data) & + if ("subject" %in% names(data) && "individual" %in% output) { data_grouped <- if (all(c("treatment", "subject") %in% names(data))) { From 67087e52642cc870abcc632581fbf8c23125ac68 Mon Sep 17 00:00:00 2001 From: PavanLomati Date: Wed, 10 Jun 2026 12:14:10 +0530 Subject: [PATCH 3/3] test-coverage.yaml: All jobs failed. Updated .Rbuildignore to address the issue. --- .Rbuildignore | 1 + R/aucint.R | 3 +- R/pk.calc.all.R | 2 +- R/pk.calc.simple.R | 10 ------- R/pk.calc.urine.R | 65 +++++++++-------------------------------- man/pk.calc.auxcint.Rd | 2 +- man/pk.nca.intervals.Rd | 2 +- 7 files changed, 19 insertions(+), 66 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 18489169..58c07666 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -21,3 +21,4 @@ cran-comments.md ^\.claude$ ^design$ ^CLAUDE\.md$ +^coverage_check\.R$ \ No newline at end of file diff --git a/R/aucint.R b/R/aucint.R index 473b2cfa..705b708a 100644 --- a/R/aucint.R +++ b/R/aucint.R @@ -15,7 +15,8 @@ #' @param clast,clast.obs,clast.pred The last concentration above the limit of #' quantification; this is used for AUCinf calculations. If provided as #' `clast.obs` (observed clast value, default), AUCinf is AUCinf,obs. If -#' provided as `clast.pred`, AUCinf is AUCinf,pred.#' @param time.dose,route,duration.dose The time of doses, route of +#' provided as `clast.pred`, AUCinf is AUCinf,pred.#' +#' @param time.dose,route,duration.dose The time of doses, route of #' administration, and duration of dose used with interpolation and #' extrapolation of concentration data (see [interp.extrap.conc.dose()]). #' If `NULL`, [interp.extrap.conc()] will be used instead. diff --git a/R/pk.calc.all.R b/R/pk.calc.all.R index 0e09dd81..1f9170b8 100644 --- a/R/pk.calc.all.R +++ b/R/pk.calc.all.R @@ -545,7 +545,7 @@ pk.nca.interval <- function(conc, time, volume, duration.conc, arg_text, all_intervals[[n]]$FUN ), # nocov end class = "pknca_error_missing_nca_argument" - ) # nocov end + ) } } } diff --git a/R/pk.calc.simple.R b/R/pk.calc.simple.R index e7351407..1ad32f5f 100644 --- a/R/pk.calc.simple.R +++ b/R/pk.calc.simple.R @@ -1845,13 +1845,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 165b6135..fb29af35 100644 --- a/R/pk.calc.urine.R +++ b/R/pk.calc.urine.R @@ -14,12 +14,6 @@ add.interval.col("volpk", unit_type="volume", pretty_name="Total Urine Volume", desc="The sum of urine volumes for the interval") -PKNCA.set.summary( - name="volpk", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) #' Calculate amount excreted (typically in urine or feces) #' @@ -53,12 +47,6 @@ add.interval.col("ae", unit_type="amount", pretty_name="Amount excreted", desc="The amount excreted (typically into urine or feces)") -PKNCA.set.summary( - name="ae", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) #' Calculate renal clearance #' @@ -83,12 +71,7 @@ add.interval.col("clr.last", formalsmap=list(auc="auclast"), depends="ae", desc="The renal clearance calculated using AUClast") -PKNCA.set.summary( - name="clr.last", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) + add.interval.col("clr.obs", FUN="pk.calc.clr", values=c(FALSE, TRUE), @@ -97,12 +80,7 @@ add.interval.col("clr.obs", formalsmap=list(auc="aucinf.obs"), depends="ae", desc="The renal clearance calculated using AUCinf,obs") -PKNCA.set.summary( - name="clr.obs", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) + add.interval.col("clr.pred", FUN="pk.calc.clr", values=c(FALSE, TRUE), @@ -111,12 +89,7 @@ add.interval.col("clr.pred", formalsmap=list(auc="aucinf.pred"), depends="ae", desc="The renal clearance calculated using AUCinf,pred") -PKNCA.set.summary( - name="clr.pred", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) + #' Calculate fraction excreted (typically in urine or feces) #' @@ -140,12 +113,6 @@ add.interval.col("fe", values=c(FALSE, TRUE), depends="ae", desc="The fraction of the dose excreted") -PKNCA.set.summary( - name="fe", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) #' Calculate the midpoint collection time of the last measurable excretion rate #' @@ -189,12 +156,6 @@ add.interval.col("ertlst", pretty_name="Tlast excretion rate", desc="The midpoint collection time of the last measurable excretion rate (typically in urine or feces)") -PKNCA.set.summary( - name="ertlst", - description="median and range", - point=business.median, - spread=business.range -) #' Calculate the maximum excretion rate #' @@ -237,12 +198,6 @@ add.interval.col("ermax", pretty_name="Maximum excretion rate", desc="The maximum excretion rate (typically in urine or feces)") -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 #' @@ -293,12 +248,18 @@ add.interval.col("ertmax", desc="The midpoint collection time of the maximum excretion rate (typically in urine or feces)") 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/man/pk.calc.auxcint.Rd b/man/pk.calc.auxcint.Rd index 35a8935b..74cd2e37 100644 --- a/man/pk.calc.auxcint.Rd +++ b/man/pk.calc.auxcint.Rd @@ -144,7 +144,7 @@ integration} \item{clast, clast.obs, clast.pred}{The last concentration above the limit of quantification; this is used for AUCinf calculations. If provided as \code{clast.obs} (observed clast value, default), AUCinf is AUCinf,obs. If -provided as \code{clast.pred}, AUCinf is AUCinf,pred.} +provided as \code{clast.pred}, AUCinf is AUCinf,pred.#'} \item{lambda.z}{The elimination rate (in units of inverse time) for extrapolation} diff --git a/man/pk.nca.intervals.Rd b/man/pk.nca.intervals.Rd index 3b7b16b5..620810d3 100644 --- a/man/pk.nca.intervals.Rd +++ b/man/pk.nca.intervals.Rd @@ -30,7 +30,7 @@ dense calculations (FALSE)?} \item{options}{List of changes to the default PKNCA options (see \code{PKNCA.options()})} -\item{impute}{The column name in \code{data_intervals} to use for imputation} +\item{impute}{The column name in \code{data_intervals} to use for imputation} \item{verbose}{Indicate, by \code{message()}, the current state of calculation.} }