From 63c0b41e077a966277bb825dd23da7e0b6dcb903 Mon Sep 17 00:00:00 2001 From: PavanLomati Date: Wed, 27 May 2026 09:19:50 +0530 Subject: [PATCH 1/9] 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/9] 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/9] 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.} } From dc401a9d6716d7c69e61cf0e94fbd3e92a702817 Mon Sep 17 00:00:00 2001 From: PavanLomati Date: Wed, 29 Jul 2026 14:44:26 +0530 Subject: [PATCH 4/9] drop the 40-character desc requirement from this PR --- R/001-add.interval.col.R | 12 ------------ tests/testthat/test-001-add.interval.col.R | 12 +----------- 2 files changed, 1 insertion(+), 23 deletions(-) diff --git a/R/001-add.interval.col.R b/R/001-add.interval.col.R index e54bdbda..b6e13a48 100644 --- a/R/001-add.interval.col.R +++ b/R/001-add.interval.col.R @@ -166,18 +166,6 @@ add.interval.col <- function(name, checkmate::assert_character(x = desc, len = 1, any.missing=FALSE) checkmate::assert_character(x = depends, null.ok = TRUE) - # desc should comply with the 40-character SDTM limit, but this is a soft - # limit -- warn rather than block the column from being added. - if (nchar(desc) > 40) { - rlang::warn( - message = sprintf( - "`desc` should be 40 characters or fewer to comply with SDTM (got %d characters): %s", - nchar(desc), desc - ), - class = "pknca_warning_desc_too_long" - ) - } - # `values` must be either a function (used to validate/coerce) or a vector # of allowed values -- both are acceptable, so just ensure it was supplied # and is one of those two forms. diff --git a/tests/testthat/test-001-add.interval.col.R b/tests/testthat/test-001-add.interval.col.R index 935762f4..14613325 100644 --- a/tests/testthat/test-001-add.interval.col.R +++ b/tests/testthat/test-001-add.interval.col.R @@ -89,17 +89,7 @@ test_that("add.interval.col", { ), regexp = "Must have length 1" ) - - # desc must comply with the 40-character SDTM limit - expect_warning( - add.interval.col( - name = "a", FUN = NA, unit_type = "conc", - pretty_name = "a", datatype = "interval", - desc = strrep("x", 41) - ), - class = "pknca_warning_desc_too_long" - ) - + # depends expect_error( add.interval.col(name = "a", FUN = NA, depends = 1, unit_type = "conc", pretty_name = "a", datatype = "interval", desc = "a"), From 0147e24564195ffe98e54eb54f646533b4618e1b Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Thu, 13 Aug 2026 21:22:47 -0400 Subject: [PATCH 5/9] Fix NEWS.md, revert AIC.list S3 export, drop reformatting churn NEWS.md: - Restore the deleted changelog entry for the unsorted concentration-time fix, which a merge dropped while leaving its code and test in place. - Split two bullets that a merge glued together, and put the "Bug Fixes" heading back on its own line so the section renders. - Remove the pk_nca_result_to_df() entry: that regression was introduced and fixed within this branch, so no released version exhibited it. - Document the pknca_* condition class renames under Breaking changes, including the two sparse classes merged into one. Revert the new S3method(AIC,list) registration. AIC.list() keeps @noRd, so AIC() dispatch on lists is unchanged from main. Restore the base formatting of aucint.R, pk.calc.c0.R, time.above.R, and AIC.list.R, keeping only the condition-signaling changes. These four were reindented wholesale, which inflated the diff without changing behavior: aucint.R alone was 991 changed lines carrying 22 real ones. The branch diff drops from 4760 changed lines to 3184; the test suite is unchanged at 2745 passing. Co-Authored-By: Claude Opus 5 --- NAMESPACE | 1 - NEWS.md | 33 +- R/AIC.list.R | 145 +++---- R/aucint.R | 999 +++++++++++++++++++++++++------------------------ R/pk.calc.c0.R | 270 ++++++------- R/time.above.R | 184 ++++----- 6 files changed, 824 insertions(+), 808 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 68704256..da3d96db 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,5 @@ # Generated by roxygen2: do not edit by hand -S3method(AIC,list) S3method(PKNCAconc,data.frame) S3method(PKNCAconc,default) S3method(PKNCAconc,tbl_df) diff --git a/NEWS.md b/NEWS.md index 8e11ca05..32bea1a6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,6 +6,11 @@ the dosing including dose amount and route. # Development version +* Bug fix: `pk.nca()` no longer errors on unsorted concentration-time data. + Group-level concentration data are now sorted by time before calculation, so + parameters that use the full group (e.g. `aucint.all` and the other `aucint*` + parameters) work when the input rows are not in time order (#568). + * Migrated input validation across the package from base R checks (`stopifnot()`, `is.character()`, `is.numeric()`, etc.) to `checkmate` assertions, and standardized error/warning signaling on classed @@ -16,16 +21,6 @@ the dosing including dose amount and route. previously-accepted edge cases like non-finite numbers); see the entries below for specifics. -* Fixed a regression in `pk_nca_result_to_df()` where warnings raised during - interval calculations (e.g. `pknca_warning_no_intervals`, - `pknca_warning_no_conc_data`) were passed to `rlang::warn()` as the raw - condition object instead of its message text, and lost their original - class in the process. This caused `pk.nca()` to error (`message must be a - character vector`) instead of warning, and would have broken any code - catching a specific warning subclass. The condition's message is now - extracted via `conditionMessage()`, and its original class is preserved - alongside the new `pknca_warning_parameter_calculation` class. - * `pk.calc.aucabove()` now requires `conc_above` to be finite. Previously, `Inf` or `-Inf` were silently accepted and produced a degenerate result (AUC of 0 for all profiles, since `conc - Inf` is always `-Inf`). Passing @@ -35,7 +30,9 @@ the dosing including dose amount and route. `checkmate::assert_scalar()`). Previously, a bare `length(impute) == 1` check meant a length-1 list (e.g. `list("start_conc0")`) could pass through, relying on `%in%`'s implicit list coercion downstream instead of failing - clearly. Passing a list now raises an error instead.* Business functions (used for calculations of means, etc.) now return NA_real_ + clearly. Passing a list now raises an error instead. + +* Business functions (used for calculations of means, etc.) now return NA_real_ for empty inputs rather than giving an error (#559). * `PKNCAconc()` gains an `lloq` argument (a column name or a numeric scalar) that @@ -73,7 +70,9 @@ the dosing including dose amount and route. * When `out_format = "cdisc"` and any parameter has "INT" in its PPTESTCD, PPSTINT and PPENINT columns are added with ISO 8601 durations relative to the last dose time. The time unit is taken from `timeu_pref` or `timeu` - (#403)## Bug Fixes + (#403) + +## Bug Fixes * `normalize.data.frame()` no longer triggers a dplyr deprecation warning (`Using 'by = character()' to perform a cross join was deprecated in dplyr 1.1.0`) @@ -104,6 +103,16 @@ the dosing including dose amount and route. ## Breaking changes +* The pre-existing `pknca_*` condition classes were renamed to carry an explicit + `error`/`warning`/`message` element, so code that catches them by class must be + updated. For example, `pknca_conc_none` is now `pknca_warning_no_concentration`, + `pknca_no_intervals` is now `pknca_warning_no_intervals`, and + `pknca_all_warnings_no_results` is now `pknca_warning_no_results`. One change + goes beyond renaming: the two classes `pknca_sparse_auclast_change_auclast` and + `pknca_sparse_aumclast_change_auc_type` were merged into the single class + `pknca_error_auc_last_type_override`, so they can no longer be caught + separately. + * `pknca_units_table()` called on a `PKNCAdata` object now raises an error if unit columns within the same concentration group contain mixed values (e.g., two different `concu` strings for the same subject group). Previously, `NA` diff --git a/R/AIC.list.R b/R/AIC.list.R index 0bb35df5..2976f073 100644 --- a/R/AIC.list.R +++ b/R/AIC.list.R @@ -1,76 +1,77 @@ - #' Assess the AIC for all models in a list of models - #' - #' @param object the list of models - #' @param \dots parameters passed to the underlying AIC function (typically the - #' parameter k) - #' @param assess.best determine which model is the best (by lowest AIC) - #' @seealso [get.best.model()] - #' @returns a data frame with row names matching the names of the list `x` and - #' columns for degrees of freedom (`df`) and `AIC`. If `assess.best` is true, - #' then there will be another column `isBest`. - #' @noRd - #' @exportS3Method - AIC.list <- function(object, ..., assess.best=TRUE) { - allAICs <- - lapply(object, FUN=function(subobject, ...) { - # Return the AIC of the new model relative to the reference model - if (identical(NA, subobject)) { - ret <- data.frame(AIC=NA, df=NA, indentation=0) - } else { - ret <- stats::AIC(subobject, ...) - if (is.numeric(ret)) { - ret <- data.frame(AIC=ret, - df=attr(stats::logLik(subobject), "df"), - indentation=0) - } else if (is.data.frame(ret)) { - if ("indentation" %in% names(ret)) { - ret$indentation <- ret$indentation + 1 - } else { - rlang::abort( - message = "Unknown way to get a data.frame without indentation set. This is likely a bug.", - class = "pknca_error_internal_unknown_dataframe_indentation" - ) - } +#' Assess the AIC for all models in a list of models +#' +#' @param object the list of models +#' @param \dots parameters passed to the underlying AIC function (typically the +#' parameter k) +#' @param assess.best determine which model is the best (by lowest AIC) +#' @seealso [get.best.model()] +#' @returns a data frame with row names matching the names of the list `x` and +#' columns for degrees of freedom (`df`) and `AIC`. If `assess.best` is true, +#' then there will be another column `isBest`. +#' @noRd +AIC.list <- function(object, ..., assess.best=TRUE) { + allAICs <- + lapply(object, FUN=function(subobject, ...) { + # Return the AIC of the new model relative to the reference model + if (identical(NA, subobject)) { + ret <- data.frame(AIC=NA, df=NA, indentation=0) + } else { + ret <- stats::AIC(subobject, ...) + if (is.numeric(ret)) { + ret <- data.frame(AIC=ret, + df=attr(stats::logLik(subobject), "df"), + indentation=0) + } else if (is.data.frame(ret)) { + if ("indentation" %in% names(ret)) { + ret$indentation <- ret$indentation + 1 + } else { + # nocov start + rlang::abort( + message = "Unknown way to get a data.frame without indentation set. This is likely a bug.", + class = "pknca_error_internal_unknown_dataframe_indentation" + ) + # nocov end } } - ret - }) - retnames <- names(allAICs) - if (is.null(retnames)) - retnames <- rep("", length(allAICs)) - ret <- data.frame() - for (i in seq_len(length(allAICs))) { - tmpAICs <- allAICs[[i]] - # If the best value has already been established, drop it for assessment - # later. - tmpAICs$isBest <- NULL - # Assign the correct rownames to tmpAICs - if (!(retnames[i] %in% "")) - if (nrow(tmpAICs) > 1 || - !identical(rownames(tmpAICs), as.character(seq_len(nrow(tmpAICs))))) { - rownames(tmpAICs) <- paste(retnames[i], rownames(tmpAICs)) - } else { - rownames(tmpAICs) <- retnames[i] - } - # Add tmpAICs to the data frame to return - ret <- rbind(ret, tmpAICs) - } - if (assess.best) { - ret$isBest <- "" - # The next row prevents warnings about no data when na.rm=TRUE - if (any(!is.na(ret$AIC))) - ret$isBest[ret$AIC %in% min(ret$AIC, na.rm=TRUE)] <- "Best Model" - } - ret + } + ret + }) + retnames <- names(allAICs) + if (is.null(retnames)) + retnames <- rep("", length(allAICs)) + ret <- data.frame() + for (i in seq_len(length(allAICs))) { + tmpAICs <- allAICs[[i]] + # If the best value has already been established, drop it for assessment + # later. + tmpAICs$isBest <- NULL + # Assign the correct rownames to tmpAICs + if (!(retnames[i] %in% "")) + if (nrow(tmpAICs) > 1 || + !identical(rownames(tmpAICs), as.character(seq_len(nrow(tmpAICs))))) { + rownames(tmpAICs) <- paste(retnames[i], rownames(tmpAICs)) + } else { + rownames(tmpAICs) <- retnames[i] + } + # Add tmpAICs to the data frame to return + ret <- rbind(ret, tmpAICs) } - - #' Extract the best model from a list of models using the AIC. - #' - #' @param object the list of models - #' @param \dots Passed to `AIC()` - #' @returns The model which is assessed as best. If more than one are equal, - #' the first is chosen. - #' @export - get.best.model <- function(object, ...) { - object[stats::AIC(object, ...)$isBest %in% "Best Model"][[1]] + if (assess.best) { + ret$isBest <- "" + # The next row prevents warnings about no data when na.rm=TRUE + if (any(!is.na(ret$AIC))) + ret$isBest[ret$AIC %in% min(ret$AIC, na.rm=TRUE)] <- "Best Model" } + ret +} + +#' Extract the best model from a list of models using the AIC. +#' +#' @param object the list of models +#' @param \dots Passed to `AIC()` +#' @returns The model which is assessed as best. If more than one are equal, +#' the first is chosen. +#' @export +get.best.model <- function(object, ...) { + object[stats::AIC(object, ...)$isBest %in% "Best Model"][[1]] +} diff --git a/R/aucint.R b/R/aucint.R index 97ad3653..0880f4e2 100644 --- a/R/aucint.R +++ b/R/aucint.R @@ -1,497 +1,504 @@ -#' Calculate AUXC (AUC or AUMC) over an interval with interpolation/extrapolation -#' -#' Calculates AUC or AUMC over a given interval, optionally interpolating or -#' extrapolating concentrations. -#' -#' @details -#' When `pk.calc.auxcint()` needs to extrapolate using `lambda.z` (in other -#' words, using the half-life), it will always extrapolate using the logarithmic -#' trapezoidal rule to align with using a half-life calculation for the -#' extrapolation. -#' -#' @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 `NULL`, [interp.extrap.conc()] will be used instead. -#' @param fun_linear,fun_log,fun_inf Integration functions for linear, -#' logarithmic, and infinite extrapolation methods. -#' @param ... Additional arguments passed to `pk.calc.auxc` and -#' `interp.extrap.conc` -#' -#' @return The AUXC for an interval of time as a number -#' -#' @family AUC calculations -#' @family AUMC calculations -#' @seealso [PKNCA.options()], [interp.extrap.conc.dose()] -#' @export -pk.calc.auxcint <- function(conc, time, - interval=NULL, start=NULL, end=NULL, - clast=pk.calc.clast.obs(conc, time), - lambda.z=NA, - time.dose=NULL, - route="extravascular", - duration.dose=0, - auc.type=c("AUClast", "AUCinf", "AUCall"), - options=list(), - method=NULL, - conc.blq=NULL, - conc.na=NULL, - check=TRUE, - fun_linear, - fun_log, - fun_inf, - ...) { - # Check inputs - auc.type <- match.arg(auc.type) - method <- PKNCA.choose.option(name="auc.method", value=method, options=options) - if (check) { - assert_conc_time(conc, time) - data <- - clean.conc.blq( - conc = conc, time = time, - conc.blq = conc.blq, conc.na = conc.na, options = options, - check = FALSE - ) - } else { - data <- data.frame(conc, time) - } - if (all(data$conc %in% 0)) { - return(structure(0, exclude = "DO NOT EXCLUDE")) - } - interval <- assert_intervaltime_single(interval = interval, start = start, end = end) - missing_times <- - if (is.infinite(interval[2])) { - setdiff(c(interval[1], time.dose), data$time) - } else { - setdiff(c(interval, time.dose), data$time) - } - # Handle the potential double-calculation (before/after tlast) with AUCinf/AUMCinf - conc_clast <- NULL - time_clast <- NULL - if (auc.type %in% "AUCinf") { - tlast <- pk.calc.tlast(conc=data$conc, time=data$time) - clast_obs <- pk.calc.clast.obs(conc=data$conc, time=data$time) - if (is.na(clast) && is.na(lambda.z)) { - # 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)) { - 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 - time_clast <- tlast - } - } - extrap_times <- numeric() - if (length(missing_times) > 0) { - if (is.null(time.dose)) { - missing_conc <- - interp.extrap.conc( - conc = data$conc, time = data$time, - time.out = missing_times, - method = method, - auc.type = auc.type, - clast = clast, - lambda.z = lambda.z, - options = options, - ... - ) - } else { - missing_conc <- - interp.extrap.conc.dose( - conc = data$conc, time = data$time, - time.out = missing_times, - method = method, - auc.type = auc.type, - clast = clast, lambda.z = lambda.z, - options = options, - # arguments specific to interp.extrap.conc.dose - time.dose = time.dose, - route.dose = route, - duration.dose = duration.dose, - out.after = FALSE, - ... - ) - } - new_data <- data.frame(conc=c(data$conc, conc_clast, missing_conc), - time=c(data$time, time_clast, missing_times)) - tlast <- pk.calc.tlast(conc = data$conc, time = data$time, check = FALSE) - extrap_times <- missing_times[missing_times > tlast] - new_data <- new_data[new_data$time >= interval[1] & - new_data$time <= interval[2],] - new_data <- new_data[order(new_data$time),] - conc_interp <- new_data$conc - time_interp <- new_data$time - if (any(mask_na_conc <- is.na(conc_interp))) { - missing_times <- time_interp[mask_na_conc] - warning_message <- - if (any(is.na(lambda.z))) { - paste("Some interpolated/extrapolated concentration values are missing", - "(may be due to interpolating or extrapolating over a dose with lambda.z=NA).", - "Time points with missing data are: ", - paste(missing_times, collapse=", ")) - } else { - paste("Some interpolated/extrapolated concentration values are missing", - "Time points with missing data are: ", - paste(missing_times, collapse=", ")) - } - rlang::warn( - message = warning_message, - class = "pknca_warning_missing_interpolated_concentrations" - ) - return(NA_real_) - } - } else { - mask_time <- data$time >= interval[1] & data$time <= interval[2] - conc_interp <- data$conc[mask_time] - time_interp <- data$time[mask_time] - } - - interval_method <- - choose_interval_method( - conc = conc_interp, - time = time_interp, - tlast = max(time_interp), - method = method, - auc.type = auc.type, - options = options - ) - if (is.finite(interval[2])) { - interval_method[length(interval_method)] <- "zero" - } - if (length(extrap_times) > 0) { - interval_method[which(time_interp == extrap_times) - 1] <- "log" - } - ret <- - auc_integrate( - conc = conc_interp, time = time_interp, - clast = clast, tlast = tlast, lambda.z = lambda.z, - interval_method = interval_method, - fun_linear = fun_linear, - fun_log = fun_log, - fun_inf = fun_inf - ) - # Add method details as an attribute - attr(ret, "method") <- paste0("AUC: ", method) - - ret -} - -#' @describeIn pk.calc.auxcint Calculate AUC over an interval -#' @export -pk.calc.aucint <- function(conc, time, ..., options=list()) { - pk.calc.auxcint(conc = conc, time = time, ..., - options = options, - fun_linear = aucintegrate_linear, - fun_log = aucintegrate_log, - fun_inf = aucintegrate_inf) -} - -#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for -#' AUClast -#' @export -pk.calc.aucint.last <- function(conc, time, start=NULL, end=NULL, time.dose, ..., options=list()) { - if (missing(time.dose)) - time.dose <- NULL - pk.calc.aucint(conc=conc, time=time, - start=start, end=end, - options=options, - time.dose=time.dose, - ..., - auc.type="AUClast") -} -#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for -#' AUCall -#' @export -pk.calc.aucint.all <- function(conc, time, start=NULL, end=NULL, time.dose, ..., options=list()) { - if (missing(time.dose)) - time.dose <- NULL - pk.calc.aucint(conc=conc, time=time, - start=start, end=end, - options=options, - time.dose=time.dose, - ..., - auc.type="AUCall") -} -#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for -#' AUCinf.obs -#' @export -pk.calc.aucint.inf.obs <- function(conc, time, start=NULL, end=NULL, time.dose, lambda.z, clast.obs, ..., options=list()) { - if (missing(time.dose)) - time.dose <- NULL - pk.calc.aucint(conc=conc, time=time, - start=start, end=end, - time.dose=time.dose, - lambda.z=lambda.z, clast=clast.obs, - options=options, ..., - auc.type="AUCinf") -} -#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for -#' AUCinf.pred -#' @export -pk.calc.aucint.inf.pred <- function(conc, time, start=NULL, end=NULL, time.dose, lambda.z, clast.pred, ..., options=list()) { - if (missing(time.dose)) { - time.dose <- NULL - } - pk.calc.aucint(conc=conc, time=time, - start=start, end=end, - time.dose=time.dose, - lambda.z=lambda.z, clast=clast.pred, - options=options, ..., - auc.type="AUCinf") -} - -add.interval.col("aucint.last", - FUN="pk.calc.aucint.last", - values=c(FALSE, TRUE), - unit_type="auc", - 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), - pptestcd_cdisc="AUCINT", - pptest_cdisc="AUC from T1 to T2") - -add.interval.col("aucint.last.dose", - FUN="pk.calc.aucint.last", - values=c(FALSE, TRUE), - unit_type="auc", - 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"), - pptestcd_cdisc="AUCINTD", - pptest_cdisc="AUC from T1 to T2 Normalized by Dose") - -add.interval.col("aucint.all", - FUN="pk.calc.aucint.all", - values=c(FALSE, TRUE), - unit_type="auc", - 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), - pptestcd_cdisc="AUCINTA", - pptest_cdisc="AUCint (based on AUCall extrapolation)") - -add.interval.col("aucint.all.dose", - FUN="pk.calc.aucint.all", - values=c(FALSE, TRUE), - unit_type="auc", - 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"), - pptestcd_cdisc="AUCINTAD", - pptest_cdisc="AUCint (based on AUCall extrapolation, dose-aware)") - -add.interval.col("aucint.inf.obs", - FUN="pk.calc.aucint.inf.obs", - values=c(FALSE, TRUE), - unit_type="auc", - pretty_name="AUCint (based on AUCinf,obs 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), - depends=c("lambda.z", "clast.obs"), - pptestcd_cdisc="AUCINTIS", - pptest_cdisc="AUCint (based on AUCinf,obs extrapolation)") - -add.interval.col("aucint.inf.obs.dose", - FUN="pk.calc.aucint.inf.obs", - values=c(FALSE, TRUE), - unit_type="auc", - pretty_name="AUCint (based on AUCinf,obs 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"), - depends=c("lambda.z", "clast.obs"), - pptestcd_cdisc="AUCINTID", - pptest_cdisc="AUCint (based on AUCinf,obs extrapolation, dose-aware)") - -add.interval.col("aucint.inf.pred", - FUN="pk.calc.aucint.inf.pred", - values=c(FALSE, TRUE), - unit_type="auc", - pretty_name="AUCint (based on AUCinf,pred 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), - depends=c("lambda.z", "clast.pred"), - pptestcd_cdisc="AUCINTIP", - pptest_cdisc="AUCint (based on AUCinf,pred extrapolation)") - -add.interval.col("aucint.inf.pred.dose", - FUN="pk.calc.aucint.inf.pred", - values=c(FALSE, TRUE), - unit_type="auc", - pretty_name="AUCint (based on AUCinf,pred 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"), - depends=c("lambda.z", "clast.pred"), - pptestcd_cdisc="AUCINTPD", - pptest_cdisc="AUCint (based on AUCinf,pred extrapolation, dose-aware)") - -#' @describeIn pk.calc.auxcint Calculate AUMC over an interval -#' @export -pk.calc.aumcint <- function(conc, time, ..., options=list()) { - pk.calc.auxcint(conc = conc, time = time, ..., - options = options, - fun_linear = aumcintegrate_linear, - fun_log = aumcintegrate_log, - fun_inf = aumcintegrate_inf) -} - -#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for -#' AUMClast -#' @export -pk.calc.aumcint.last <- function(conc, time, start=NULL, end=NULL, time.dose, ..., options=list()) { - if (missing(time.dose)) - time.dose <- NULL - pk.calc.aumcint(conc=conc, time=time, - start=start, end=end, - options=options, - time.dose=time.dose, - ..., - auc.type="AUClast") -} - -#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for -#' AUMCall -#' @export -pk.calc.aumcint.all <- function(conc, time, start=NULL, end=NULL, time.dose, ..., options=list()) { - if (missing(time.dose)) - time.dose <- NULL - pk.calc.aumcint(conc=conc, time=time, - start=start, end=end, - options=options, - time.dose=time.dose, - ..., - auc.type="AUCall") -} - -#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for -#' AUMCinf.obs -#' @export -pk.calc.aumcint.inf.obs <- function(conc, time, start=NULL, end=NULL, time.dose, lambda.z, clast.obs, ..., options=list()) { - if (missing(time.dose)) - time.dose <- NULL - pk.calc.aumcint(conc=conc, time=time, - start=start, end=end, - time.dose=time.dose, - lambda.z=lambda.z, clast=clast.obs, - options=options, ..., - auc.type="AUCinf") -} - -#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for -#' AUMCinf.pred -#' @export -pk.calc.aumcint.inf.pred <- function(conc, time, start=NULL, end=NULL, time.dose, lambda.z, clast.pred, ..., options=list()) { - if (missing(time.dose)) - time.dose <- NULL - pk.calc.aumcint(conc=conc, time=time, - start=start, end=end, - time.dose=time.dose, - lambda.z=lambda.z, clast=clast.pred, - options=options, ..., - auc.type="AUCinf") -} - - -# aumcint.last (without dose awareness) -add.interval.col("aumcint.last", - FUN="pk.calc.aumcint.last", - values=c(FALSE, TRUE), - unit_type="aumc", - pretty_name="AUMCint (based on AUMClast extrapolation)", - desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with zeros (matching AUMClast)", - formalsmap=list(conc="conc.group", time="time.group", time.dose=NULL)) - -# aumcint.last.dose (WITH dose awareness) -add.interval.col("aumcint.last.dose", - FUN="pk.calc.aumcint.last", - values=c(FALSE, TRUE), - unit_type="aumc", - pretty_name="AUMCint (based on AUMClast extrapolation, dose-aware)", - desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with zeros (matching AUMClast) with dose-aware interpolation/extrapolation of concentrations", - formalsmap=list(conc="conc.group", time="time.group", time.dose="time.dose.group")) - -# aumcint.all (without dose awareness) -add.interval.col("aumcint.all", - FUN="pk.calc.aumcint.all", - values=c(FALSE, TRUE), - unit_type="aumc", - pretty_name="AUMCint (based on AUMCall extrapolation)", - desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with the triangle from Tlast to the next point and zero thereafter (matching AUMCall)", - formalsmap=list(conc="conc.group", time="time.group", time.dose=NULL)) - -# aumcint.all.dose (WITH dose awareness) -add.interval.col("aumcint.all.dose", - FUN="pk.calc.aumcint.all", - values=c(FALSE, TRUE), - unit_type="aumc", - pretty_name="AUMCint (based on AUMCall extrapolation, dose-aware)", - desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with the triangle from Tlast to the next point and zero thereafter (matching AUMCall) with dose-aware interpolation/extrapolation of concentrations", - formalsmap=list(conc="conc.group", time="time.group", time.dose="time.dose.group")) - -# aumcint.inf.obs (without dose awareness) -add.interval.col("aumcint.inf.obs", - FUN="pk.calc.aumcint.inf.obs", - values=c(FALSE, TRUE), - unit_type="aumc", - pretty_name="AUMCint (based on AUMCinf,obs extrapolation)", - desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with zeros (matching AUMClast)", - formalsmap=list(conc="conc.group", time="time.group", time.dose=NULL), - depends=c("lambda.z", "clast.obs")) - -# aumcint.inf.obs.dose (WITH dose awareness) -add.interval.col("aumcint.inf.obs.dose", - FUN="pk.calc.aumcint.inf.obs", - values=c(FALSE, TRUE), - unit_type="aumc", - pretty_name="AUMCint (based on AUMCinf,obs extrapolation, dose-aware)", - desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with zeros (matching AUMClast) 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")) - -# aumcint.inf.pred (without dose awareness) -add.interval.col("aumcint.inf.pred", - FUN="pk.calc.aumcint.inf.pred", - values=c(FALSE, TRUE), - unit_type="aumc", - pretty_name="AUMCint (based on AUMCinf,pred extrapolation)", - desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with the triangle from Tlast to the next point and zero thereafter (matching AUMCall)", - formalsmap=list(conc="conc.group", time="time.group", time.dose=NULL), - depends=c("lambda.z", "clast.pred")) - -# aumcint.inf.pred.dose (WITH dose awareness) -add.interval.col("aumcint.inf.pred.dose", - FUN="pk.calc.aumcint.inf.pred", - values=c(FALSE, TRUE), - unit_type="aumc", - pretty_name="AUMCint (based on AUMCinf,pred extrapolation, dose-aware)", - desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with the triangle from Tlast to the next point and zero thereafter (matching AUMCall) 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")) - -# ============================================================================= -# SET SUMMARY STATISTICS - Count (16) -# ============================================================================= -PKNCA.set.summary( - name= c( - # AUC related - "aucint.last", "aucint.last.dose", "aucint.all", "aucint.all.dose", - "aucint.inf.obs", "aucint.inf.obs.dose", "aucint.inf.pred", "aucint.inf.pred.dose", - - # AUMC related - "aumcint.last", "aumcint.last.dose", "aumcint.all", "aumcint.all.dose", - "aumcint.inf.obs", "aumcint.inf.obs.dose", "aumcint.inf.pred", "aumcint.inf.pred.dose" - ), - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv +#' Calculate AUXC (AUC or AUMC) over an interval with interpolation/extrapolation +#' +#' Calculates AUC or AUMC over a given interval, optionally interpolating or +#' extrapolating concentrations. +#' +#' @details +#' When `pk.calc.auxcint()` needs to extrapolate using `lambda.z` (in other +#' words, using the half-life), it will always extrapolate using the logarithmic +#' trapezoidal rule to align with using a half-life calculation for the +#' extrapolation. +#' +#' @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 `NULL`, [interp.extrap.conc()] will be used instead. +#' @param fun_linear,fun_log,fun_inf Integration functions for linear, +#' logarithmic, and infinite extrapolation methods. +#' @param ... Additional arguments passed to `pk.calc.auxc` and +#' `interp.extrap.conc` +#' +#' @return The AUXC for an interval of time as a number +#' +#' @family AUC calculations +#' @family AUMC calculations +#' @seealso [PKNCA.options()], [interp.extrap.conc.dose()] +#' @export +pk.calc.auxcint <- function(conc, time, + interval=NULL, start=NULL, end=NULL, + clast=pk.calc.clast.obs(conc, time), + lambda.z=NA, + time.dose=NULL, + route="extravascular", + duration.dose=0, + auc.type=c("AUClast", "AUCinf", "AUCall"), + options=list(), + method=NULL, + conc.blq=NULL, + conc.na=NULL, + check=TRUE, + fun_linear, + fun_log, + fun_inf, + ...) { + # Check inputs + auc.type <- match.arg(auc.type) + method <- PKNCA.choose.option(name="auc.method", value=method, options=options) + if (check) { + assert_conc_time(conc, time) + data <- + clean.conc.blq( + conc = conc, time = time, + conc.blq = conc.blq, conc.na = conc.na, options = options, + check = FALSE + ) + } else { + data <- data.frame(conc, time) + } + if (all(data$conc %in% 0)) { + return(structure(0, exclude = "DO NOT EXCLUDE")) + } + interval <- assert_intervaltime_single(interval = interval, start = start, end = end) + missing_times <- + if (is.infinite(interval[2])) { + setdiff(c(interval[1], time.dose), data$time) + } else { + setdiff(c(interval, time.dose), data$time) + } + # Handle the potential double-calculation (before/after tlast) with AUCinf/AUMCinf + conc_clast <- NULL + time_clast <- NULL + if (auc.type %in% "AUCinf") { + tlast <- pk.calc.tlast(conc=data$conc, time=data$time) + clast_obs <- pk.calc.clast.obs(conc=data$conc, time=data$time) + if (is.na(clast) && is.na(lambda.z)) { + # 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)) { + # nocov start + rlang::abort( + message = "Please report a bug. clast is NA and the half-life is not NA", + class = "pknca_error_internal_clast_na" + ) + # nocov end + } 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 + } + } + extrap_times <- numeric() + if (length(missing_times) > 0) { + if (is.null(time.dose)) { + missing_conc <- + interp.extrap.conc( + conc = data$conc, time = data$time, + time.out = missing_times, + method = method, + auc.type = auc.type, + clast = clast, + lambda.z = lambda.z, + options = options, + ... + ) + } else { + missing_conc <- + interp.extrap.conc.dose( + conc = data$conc, time = data$time, + time.out = missing_times, + method = method, + auc.type = auc.type, + clast = clast, lambda.z = lambda.z, + options = options, + # arguments specific to interp.extrap.conc.dose + time.dose = time.dose, + route.dose = route, + duration.dose = duration.dose, + out.after = FALSE, + ... + ) + } + new_data <- data.frame(conc=c(data$conc, conc_clast, missing_conc), + time=c(data$time, time_clast, missing_times)) + tlast <- pk.calc.tlast(conc = data$conc, time = data$time, check = FALSE) + extrap_times <- missing_times[missing_times > tlast] + new_data <- new_data[new_data$time >= interval[1] & + new_data$time <= interval[2],] + new_data <- new_data[order(new_data$time),] + conc_interp <- new_data$conc + time_interp <- new_data$time + if (any(mask_na_conc <- is.na(conc_interp))) { + missing_times <- time_interp[mask_na_conc] + warning_message <- + if (any(is.na(lambda.z))) { + paste("Some interpolated/extrapolated concentration values are missing", + "(may be due to interpolating or extrapolating over a dose with lambda.z=NA).", + "Time points with missing data are: ", + paste(missing_times, collapse=", ")) + } else { + paste("Some interpolated/extrapolated concentration values are missing", + "Time points with missing data are: ", + paste(missing_times, collapse=", ")) + } + rlang::warn( + message = warning_message, + class = "pknca_warning_missing_interpolated_concentrations" + ) + return(NA_real_) + } + } else { + mask_time <- data$time >= interval[1] & data$time <= interval[2] + conc_interp <- data$conc[mask_time] + time_interp <- data$time[mask_time] + } + + interval_method <- + choose_interval_method( + conc = conc_interp, + time = time_interp, + tlast = max(time_interp), + method = method, + auc.type = auc.type, + options = options + ) + if (is.finite(interval[2])) { + interval_method[length(interval_method)] <- "zero" + } + if (length(extrap_times) > 0) { + interval_method[which(time_interp == extrap_times) - 1] <- "log" + } + ret <- + auc_integrate( + conc = conc_interp, time = time_interp, + clast = clast, tlast = tlast, lambda.z = lambda.z, + interval_method = interval_method, + fun_linear = fun_linear, + fun_log = fun_log, + fun_inf = fun_inf + ) + # Add method details as an attribute + attr(ret, "method") <- paste0("AUC: ", method) + + ret +} + +#' @describeIn pk.calc.auxcint Calculate AUC over an interval +#' @export +pk.calc.aucint <- function(conc, time, ..., options=list()) { + pk.calc.auxcint( + conc = conc, time = time, ..., + options = options, + fun_linear = aucintegrate_linear, + fun_log = aucintegrate_log, + fun_inf = aucintegrate_inf + ) +} + +#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for +#' AUClast +#' @export +pk.calc.aucint.last <- function(conc, time, start=NULL, end=NULL, time.dose, ..., options=list()) { + if (missing(time.dose)) + time.dose <- NULL + pk.calc.aucint(conc=conc, time=time, + start=start, end=end, + options=options, + time.dose=time.dose, + ..., + auc.type="AUClast") +} +#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for +#' AUCall +#' @export +pk.calc.aucint.all <- function(conc, time, start=NULL, end=NULL, time.dose, ..., options=list()) { + if (missing(time.dose)) + time.dose <- NULL + pk.calc.aucint(conc=conc, time=time, + start=start, end=end, + options=options, + time.dose=time.dose, + ..., + auc.type="AUCall") +} +#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for +#' AUCinf.obs +#' @export +pk.calc.aucint.inf.obs <- function(conc, time, start=NULL, end=NULL, time.dose, lambda.z, clast.obs, ..., options=list()) { + if (missing(time.dose)) + time.dose <- NULL + pk.calc.aucint(conc=conc, time=time, + start=start, end=end, + time.dose=time.dose, + lambda.z=lambda.z, clast=clast.obs, + options=options, ..., + auc.type="AUCinf") +} +#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for +#' AUCinf.pred +#' @export +pk.calc.aucint.inf.pred <- function(conc, time, start=NULL, end=NULL, time.dose, lambda.z, clast.pred, ..., options=list()) { + if (missing(time.dose)) { + time.dose <- NULL + } + pk.calc.aucint(conc=conc, time=time, + start=start, end=end, + time.dose=time.dose, + lambda.z=lambda.z, clast=clast.pred, + options=options, ..., + auc.type="AUCinf") +} + +add.interval.col("aucint.last", + FUN="pk.calc.aucint.last", + values=c(FALSE, TRUE), + unit_type="auc", + 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), + pptestcd_cdisc="AUCINT", + pptest_cdisc="AUC from T1 to T2") + +add.interval.col("aucint.last.dose", + FUN="pk.calc.aucint.last", + values=c(FALSE, TRUE), + unit_type="auc", + 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"), + pptestcd_cdisc="AUCINTD", + pptest_cdisc="AUC from T1 to T2 Normalized by Dose") + +add.interval.col("aucint.all", + FUN="pk.calc.aucint.all", + values=c(FALSE, TRUE), + unit_type="auc", + 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), + pptestcd_cdisc="AUCINTA", + pptest_cdisc="AUCint (based on AUCall extrapolation)") + +add.interval.col("aucint.all.dose", + FUN="pk.calc.aucint.all", + values=c(FALSE, TRUE), + unit_type="auc", + 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"), + pptestcd_cdisc="AUCINTAD", + pptest_cdisc="AUCint (based on AUCall extrapolation, dose-aware)") + +add.interval.col("aucint.inf.obs", + FUN="pk.calc.aucint.inf.obs", + values=c(FALSE, TRUE), + unit_type="auc", + pretty_name="AUCint (based on AUCinf,obs 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), + depends=c("lambda.z", "clast.obs"), + pptestcd_cdisc="AUCINTIS", + pptest_cdisc="AUCint (based on AUCinf,obs extrapolation)") + +add.interval.col("aucint.inf.obs.dose", + FUN="pk.calc.aucint.inf.obs", + values=c(FALSE, TRUE), + unit_type="auc", + pretty_name="AUCint (based on AUCinf,obs 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"), + depends=c("lambda.z", "clast.obs"), + pptestcd_cdisc="AUCINTID", + pptest_cdisc="AUCint (based on AUCinf,obs extrapolation, dose-aware)") + +add.interval.col("aucint.inf.pred", + FUN="pk.calc.aucint.inf.pred", + values=c(FALSE, TRUE), + unit_type="auc", + pretty_name="AUCint (based on AUCinf,pred 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), + depends=c("lambda.z", "clast.pred"), + pptestcd_cdisc="AUCINTIP", + pptest_cdisc="AUCint (based on AUCinf,pred extrapolation)") + +add.interval.col("aucint.inf.pred.dose", + FUN="pk.calc.aucint.inf.pred", + values=c(FALSE, TRUE), + unit_type="auc", + pretty_name="AUCint (based on AUCinf,pred 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"), + depends=c("lambda.z", "clast.pred"), + pptestcd_cdisc="AUCINTPD", + pptest_cdisc="AUCint (based on AUCinf,pred extrapolation, dose-aware)") + + +#' @describeIn pk.calc.auxcint Calculate AUMC over an interval +#' @export +pk.calc.aumcint <- function(conc, time, ..., options=list()) { + pk.calc.auxcint( + conc = conc, time = time, ..., + options = options, + fun_linear = aumcintegrate_linear, + fun_log = aumcintegrate_log, + fun_inf = aumcintegrate_inf + ) +} + +#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for +#' AUMClast +#' @export +pk.calc.aumcint.last <- function(conc, time, start=NULL, end=NULL, time.dose, ..., options=list()) { + if (missing(time.dose)) + time.dose <- NULL + pk.calc.aumcint(conc=conc, time=time, + start=start, end=end, + options=options, + time.dose=time.dose, + ..., + auc.type="AUClast") +} + +#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for +#' AUMCall +#' @export +pk.calc.aumcint.all <- function(conc, time, start=NULL, end=NULL, time.dose, ..., options=list()) { + if (missing(time.dose)) + time.dose <- NULL + pk.calc.aumcint(conc=conc, time=time, + start=start, end=end, + options=options, + time.dose=time.dose, + ..., + auc.type="AUCall") +} + +#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for +#' AUMCinf.obs +#' @export +pk.calc.aumcint.inf.obs <- function(conc, time, start=NULL, end=NULL, time.dose, lambda.z, clast.obs, ..., options=list()) { + if (missing(time.dose)) + time.dose <- NULL + pk.calc.aumcint(conc=conc, time=time, + start=start, end=end, + time.dose=time.dose, + lambda.z=lambda.z, clast=clast.obs, + options=options, ..., + auc.type="AUCinf") +} + +#' @describeIn pk.calc.auxcint Interpolate or extrapolate concentrations for +#' AUMCinf.pred +#' @export +pk.calc.aumcint.inf.pred <- function(conc, time, start=NULL, end=NULL, time.dose, lambda.z, clast.pred, ..., options=list()) { + if (missing(time.dose)) + time.dose <- NULL + pk.calc.aumcint(conc=conc, time=time, + start=start, end=end, + time.dose=time.dose, + lambda.z=lambda.z, clast=clast.pred, + options=options, ..., + auc.type="AUCinf") +} + + +# aumcint.last (without dose awareness) +add.interval.col("aumcint.last", + FUN="pk.calc.aumcint.last", + values=c(FALSE, TRUE), + unit_type="aumc", + pretty_name="AUMCint (based on AUMClast extrapolation)", + desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with zeros (matching AUMClast)", + formalsmap=list(conc="conc.group", time="time.group", time.dose=NULL)) + +# aumcint.last.dose (WITH dose awareness) +add.interval.col("aumcint.last.dose", + FUN="pk.calc.aumcint.last", + values=c(FALSE, TRUE), + unit_type="aumc", + pretty_name="AUMCint (based on AUMClast extrapolation, dose-aware)", + desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with zeros (matching AUMClast) with dose-aware interpolation/extrapolation of concentrations", + formalsmap=list(conc="conc.group", time="time.group", time.dose="time.dose.group")) + +# aumcint.all (without dose awareness) +add.interval.col("aumcint.all", + FUN="pk.calc.aumcint.all", + values=c(FALSE, TRUE), + unit_type="aumc", + pretty_name="AUMCint (based on AUMCall extrapolation)", + desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with the triangle from Tlast to the next point and zero thereafter (matching AUMCall)", + formalsmap=list(conc="conc.group", time="time.group", time.dose=NULL)) + +# aumcint.all.dose (WITH dose awareness) +add.interval.col("aumcint.all.dose", + FUN="pk.calc.aumcint.all", + values=c(FALSE, TRUE), + unit_type="aumc", + pretty_name="AUMCint (based on AUMCall extrapolation, dose-aware)", + desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with the triangle from Tlast to the next point and zero thereafter (matching AUMCall) with dose-aware interpolation/extrapolation of concentrations", + formalsmap=list(conc="conc.group", time="time.group", time.dose="time.dose.group")) + +# aumcint.inf.obs (without dose awareness) +add.interval.col("aumcint.inf.obs", + FUN="pk.calc.aumcint.inf.obs", + values=c(FALSE, TRUE), + unit_type="aumc", + pretty_name="AUMCint (based on AUMCinf,obs extrapolation)", + desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with zeros (matching AUMClast)", + formalsmap=list(conc="conc.group", time="time.group", time.dose=NULL), + depends=c("lambda.z", "clast.obs")) + +# aumcint.inf.obs.dose (WITH dose awareness) +add.interval.col("aumcint.inf.obs.dose", + FUN="pk.calc.aumcint.inf.obs", + values=c(FALSE, TRUE), + unit_type="aumc", + pretty_name="AUMCint (based on AUMCinf,obs extrapolation, dose-aware)", + desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with zeros (matching AUMClast) 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")) + +# aumcint.inf.pred (without dose awareness) +add.interval.col("aumcint.inf.pred", + FUN="pk.calc.aumcint.inf.pred", + values=c(FALSE, TRUE), + unit_type="aumc", + pretty_name="AUMCint (based on AUMCinf,pred extrapolation)", + desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with the triangle from Tlast to the next point and zero thereafter (matching AUMCall)", + formalsmap=list(conc="conc.group", time="time.group", time.dose=NULL), + depends=c("lambda.z", "clast.pred")) + +# aumcint.inf.pred.dose (WITH dose awareness) +add.interval.col("aumcint.inf.pred.dose", + FUN="pk.calc.aumcint.inf.pred", + values=c(FALSE, TRUE), + unit_type="aumc", + pretty_name="AUMCint (based on AUMCinf,pred extrapolation, dose-aware)", + desc="The area under the moment curve in the interval extrapolating from Tlast to infinity with the triangle from Tlast to the next point and zero thereafter (matching AUMCall) 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")) + +# ============================================================================= +# SET SUMMARY STATISTICS - Count (16) +# ============================================================================= +PKNCA.set.summary( + name= c( + # AUC related + "aucint.last", "aucint.last.dose", "aucint.all", "aucint.all.dose", + "aucint.inf.obs", "aucint.inf.obs.dose", "aucint.inf.pred", "aucint.inf.pred.dose", + + # AUMC related + "aumcint.last", "aumcint.last.dose", "aumcint.all", "aumcint.all.dose", + "aumcint.inf.obs", "aumcint.inf.obs.dose", "aumcint.inf.pred", "aumcint.inf.pred.dose" + ), + 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.c0.R b/R/pk.calc.c0.R index 9679a46f..f53b1c66 100644 --- a/R/pk.calc.c0.R +++ b/R/pk.calc.c0.R @@ -1,148 +1,148 @@ -#' Estimate the concentration at dosing time for an IV bolus dose. -#' -#' @inheritParams assert_conc_time -#' @inheritParams clean.conc.blq -#' @param time.dose The time when dosing occurred -#' @param method The order of methods to test (see details) -#' @returns The estimated concentration at time 0. -#' -#' @family NCA parameters for concentrations during the intervals -#' @details Methods available for interpolation are below, and each -#' has its own specific function. -#' -#' \describe{ -#' \item{`c0`}{If the observed `conc` at `time.dose` is nonzero, return that. This method should usually be used first for single-dose IV bolus data in case nominal time zero is measured.} -#' \item{`logslope`}{Compute the semilog line between the first two measured times, and use that line to extrapolate backward to `time.dose`} -#' \item{`c1`}{Use the first point after `time.dose`} -#' \item{`cmin`}{Set c0 to cmin during the interval. This method should usually be used for multiple-dose oral data and IV infusion data.} -#' \item{`set0`}{Set c0 to zero (regardless of any other data). This method should usually be used first for single-dose oral data.} -#' } -#' @export -pk.calc.c0 <- function(conc, time, time.dose=0, - method=c("c0", "logslope", "c1", "cmin", "set0"), - check=TRUE) { - # Check the inputs - if (check) { - assert_conc_time(conc = conc, time = time) - } +#' Estimate the concentration at dosing time for an IV bolus dose. +#' +#' @inheritParams assert_conc_time +#' @inheritParams clean.conc.blq +#' @param time.dose The time when dosing occurred +#' @param method The order of methods to test (see details) +#' @returns The estimated concentration at time 0. +#' +#' @family NCA parameters for concentrations during the intervals +#' @details Methods available for interpolation are below, and each +#' has its own specific function. +#' +#' \describe{ +#' \item{`c0`}{If the observed `conc` at `time.dose` is nonzero, return that. This method should usually be used first for single-dose IV bolus data in case nominal time zero is measured.} +#' \item{`logslope`}{Compute the semilog line between the first two measured times, and use that line to extrapolate backward to `time.dose`} +#' \item{`c1`}{Use the first point after `time.dose`} +#' \item{`cmin`}{Set c0 to cmin during the interval. This method should usually be used for multiple-dose oral data and IV infusion data.} +#' \item{`set0`}{Set c0 to zero (regardless of any other data). This method should usually be used first for single-dose oral data.} +#' } +#' @export +pk.calc.c0 <- function(conc, time, time.dose=0, + method=c("c0", "logslope", "c1", "cmin", "set0"), + check=TRUE) { + # Check the inputs + if (check) { + assert_conc_time(conc = conc, time = time) + } checkmate::assert_number(time.dose, na.ok = TRUE, finite = FALSE) - if (is.na(time.dose)) { + if (is.na(time.dose)) { 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)) { + return(structure(NA_real_, exclude = "dose time is missing")) + } else if (time.dose > max(time)) { 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) - # Find the value - ret <- NA + return(structure(NA_real_, exclude = "dose time is after all available concentration data")) + } + method <- match.arg(method, several.ok=TRUE) + # Find the value + ret <- NA while (is.na(ret) && - length(method) > 0) { - current.method <- method[1] - method <- method[-1] - ret <- do.call( - paste("pk.calc.c0.method", current.method, sep="."), - args=list( - conc=conc, - time=time, - time.dose=time.dose, - check=FALSE - ) - ) - } - ret -} - -#' @describeIn pk.calc.c0 Semilog regress the first and second points -#' after time.dose. This method will return `NA` if the second -#' `conc` after `time.dose` is 0 or greater than the first. -pk.calc.c0.method.logslope <- function(conc, time, time.dose=0, - check=TRUE) { - if (check) { - assert_conc_time(conc = conc, time = time) - } - mask.positive.time <- (time > time.dose & - !(is.na(conc))) - positive.time <- time[mask.positive.time] - if (length(positive.time) < 2) - return(NA) - # If there is enough data, proceed to calculate - mask.1 <- time %in% positive.time[1] - mask.2 <- time %in% positive.time[2] - c1 <- conc[mask.1] - c2 <- conc[mask.2] - t1 <- time[mask.1] - t2 <- time[mask.2] - if (c2 < c1 && - c2 != 0) { - exp(log(c1) - (log(c2)-log(c1))/(t2-t1)*(t1 - time.dose)) - } else { - NA - } -} - -#' @describeIn pk.calc.c0 Use `C0` = `conc[time %in% time.dose]` if it is -#' nonzero. -pk.calc.c0.method.c0 <- function(conc, time, time.dose=0, check=TRUE) { - if (check) { - assert_conc_time(conc = conc, time = time) - } - # If there is a non-missing and nonzero concentration measurement - # at time.dose, that's our answer. - mask.dose <- (time %in% time.dose & - !(conc %in% c(NA, 0))) - if (any(mask.dose)) { - conc[mask.dose] - } else { - NA - } -} - -#' @describeIn pk.calc.c0 Use `C0` = `C1`. -pk.calc.c0.method.c1 <- function(conc, time, time.dose=0, check=TRUE) { - if (check) { - assert_conc_time(conc = conc, time = time) - } - mask.post.dose <- (time > time.dose & - !is.na(conc)) - if (any(mask.post.dose)) { - conc[mask.post.dose][1] - } else { - NA - } -} - -#' @describeIn pk.calc.c0 Use `C0` = 0 (typically used for single dose oral and -#' IV infusion) -pk.calc.c0.method.set0 <- function(conc, time, time.dose=0, check=TRUE) { - 0 -} - -#' @describeIn pk.calc.c0 Use `C0` = Cmin (typically used for multiple dose oral -#' and IV infusion but not IV bolus) -pk.calc.c0.method.cmin <- function(conc, time, time.dose=0, check=TRUE) { - pk.calc.cmin(conc, check=check) -} - -# Add the column to the interval specification -add.interval.col("c0", - FUN="pk.calc.c0", - values=c(FALSE, TRUE), - unit_type="conc", - pretty_name="C0", - desc="Initial concentration after an IV bolus", + length(method) > 0) { + current.method <- method[1] + method <- method[-1] + ret <- do.call( + paste("pk.calc.c0.method", current.method, sep="."), + args=list( + conc=conc, + time=time, + time.dose=time.dose, + check=FALSE + ) + ) + } + ret +} + +#' @describeIn pk.calc.c0 Semilog regress the first and second points +#' after time.dose. This method will return `NA` if the second +#' `conc` after `time.dose` is 0 or greater than the first. +pk.calc.c0.method.logslope <- function(conc, time, time.dose=0, + check=TRUE) { + if (check) { + assert_conc_time(conc = conc, time = time) + } + mask.positive.time <- (time > time.dose & + !(is.na(conc))) + positive.time <- time[mask.positive.time] + if (length(positive.time) < 2) + return(NA) + # If there is enough data, proceed to calculate + mask.1 <- time %in% positive.time[1] + mask.2 <- time %in% positive.time[2] + c1 <- conc[mask.1] + c2 <- conc[mask.2] + t1 <- time[mask.1] + t2 <- time[mask.2] + if (c2 < c1 && + c2 != 0) { + exp(log(c1) - (log(c2)-log(c1))/(t2-t1)*(t1 - time.dose)) + } else { + NA + } +} + +#' @describeIn pk.calc.c0 Use `C0` = `conc[time %in% time.dose]` if it is +#' nonzero. +pk.calc.c0.method.c0 <- function(conc, time, time.dose=0, check=TRUE) { + if (check) { + assert_conc_time(conc = conc, time = time) + } + # If there is a non-missing and nonzero concentration measurement + # at time.dose, that's our answer. + mask.dose <- (time %in% time.dose & + !(conc %in% c(NA, 0))) + if (any(mask.dose)) { + conc[mask.dose] + } else { + NA + } +} + +#' @describeIn pk.calc.c0 Use `C0` = `C1`. +pk.calc.c0.method.c1 <- function(conc, time, time.dose=0, check=TRUE) { + if (check) { + assert_conc_time(conc = conc, time = time) + } + mask.post.dose <- (time > time.dose & + !is.na(conc)) + if (any(mask.post.dose)) { + conc[mask.post.dose][1] + } else { + NA + } +} + +#' @describeIn pk.calc.c0 Use `C0` = 0 (typically used for single dose oral and +#' IV infusion) +pk.calc.c0.method.set0 <- function(conc, time, time.dose=0, check=TRUE) { + 0 +} + +#' @describeIn pk.calc.c0 Use `C0` = Cmin (typically used for multiple dose oral +#' and IV infusion but not IV bolus) +pk.calc.c0.method.cmin <- function(conc, time, time.dose=0, check=TRUE) { + pk.calc.cmin(conc, check=check) +} + +# Add the column to the interval specification +add.interval.col("c0", + FUN="pk.calc.c0", + values=c(FALSE, TRUE), + unit_type="conc", + pretty_name="C0", + desc="Initial concentration after an IV bolus", depends=NULL, pptestcd_cdisc="C0", pptest_cdisc="Initial Conc") -PKNCA.set.summary( - name="c0", - description="geometric mean and geometric coefficient of variation", - point=business.geomean, - spread=business.geocv -) +PKNCA.set.summary( + name="c0", + description="geometric mean and geometric coefficient of variation", + point=business.geomean, + spread=business.geocv +) diff --git a/R/time.above.R b/R/time.above.R index 7cd920a8..051ff386 100644 --- a/R/time.above.R +++ b/R/time.above.R @@ -1,104 +1,104 @@ -#' Determine time at or above a set value -#' -#' Interpolation is performed aligning with `PKNCA.options("auc.method")`. -#' Extrapolation outside of the measured times is not yet implemented. The -#' `method` may be changed by giving a named `method` argument, as well. -#' -#' For `'lin up/log down'`, if `clast` is above `conc_above` and there are -#' concentrations BLQ after that, linear down is used to extrapolate to the BLQ -#' concentration (equivalent to AUCall). -#' -#' @inheritParams pk.calc.auxc -#' @param conc_above The concentration to be above -#' @param ... Extra arguments. Currently, the only extra argument that is used -#' is `method` as described in the details section. -#' @returns the time above the given concentration -#' @export -pk.calc.time_above <- function(conc, time, - conc_above, - ..., - options=list(), - check=TRUE) { - arglist <- list(...) - method <- PKNCA.choose.option(name="auc.method", value=arglist$method, options=options) - if (missing(conc)) { +#' Determine time at or above a set value +#' +#' Interpolation is performed aligning with `PKNCA.options("auc.method")`. +#' Extrapolation outside of the measured times is not yet implemented. The +#' `method` may be changed by giving a named `method` argument, as well. +#' +#' For `'lin up/log down'`, if `clast` is above `conc_above` and there are +#' concentrations BLQ after that, linear down is used to extrapolate to the BLQ +#' concentration (equivalent to AUCall). +#' +#' @inheritParams pk.calc.auxc +#' @param conc_above The concentration to be above +#' @param ... Extra arguments. Currently, the only extra argument that is used +#' is `method` as described in the details section. +#' @returns the time above the given concentration +#' @export +pk.calc.time_above <- function(conc, time, + conc_above, + ..., + options=list(), + check=TRUE) { + arglist <- list(...) + method <- PKNCA.choose.option(name="auc.method", value=arglist$method, options=options) + if (missing(conc)) { rlang::abort( message = "conc must be given", class = "pknca_error_time_above_missing_conc" ) - } - if (missing(time)) { + } + if (missing(time)) { rlang::abort( message = "time must be given", class = "pknca_error_time_above_missing_time" ) - } + } checkmate::assert_number(conc_above, na.ok = FALSE) - if (check) { - assert_conc_time(conc = conc, time = time) - } - # Only keep evaluable rows - data <- data.frame(conc=conc, time=time)[!is.na(conc), , drop=FALSE] - # Determine intervals where both values are above, the first value is above, - # or the second value is above - data$above <- data$conc >= conc_above - mask_both <- data$above[-1] & data$above[-nrow(data)] - mask_first <- !data$above[-1] & data$above[-nrow(data)] - mask_second <- data$above[-1] & !data$above[-nrow(data)] - conc1 <- data$conc[-nrow(data)] - conc2 <- data$conc[-1] - time1 <- data$time[-nrow(data)] - time2 <- data$time[-1] - # Calculations - if (nrow(data) < 2) { - ret <- structure(NA_real_, exclude="Too few measured concentrations to assess time_above") - } else if (method %in% 'lin up/log down') { - linear_up <- conc2 > conc1 | conc2 == conc1 - linear_down <- conc2 == 0 - log_down <- !linear_down & conc2 > 0 - ret <- - sum((time2 - time1)[mask_both]) + - # log down - sum( - ((log(conc_above) - log(conc1))/(log(conc2) - log(conc1))*(time2 - time1))[mask_first & log_down] - ) + - # linear down - sum( - ((conc_above - conc1)/(conc2 - conc1)*(time2 - time1))[mask_first & linear_down] - ) + - # linear up - sum( - ((conc2 - conc_above)/(conc2 - conc1)*(time2 - time1))[mask_second & linear_up] - ) - } else if (method %in% 'linear') { - ret <- - sum((time2 - time1)[mask_both]) + - # linear down - sum( - ((conc_above - conc1)/(conc2 - conc1)*(time2 - time1))[mask_first] - ) + - # linear up - sum( - ((conc2 - conc_above)/(conc2 - conc1)*(time2 - time1))[mask_second] - ) - } else { - # Should be caught by the method assignment above - stop("Invalid 'method', please report this as a bug: ", method) # nocov - } - ret -} -# Add the column to the interval specification -add.interval.col("time_above", - FUN="pk.calc.time_above", - values=c(FALSE, TRUE), - unit_type="time", - pretty_name="Time above Concentration", + if (check) { + assert_conc_time(conc = conc, time = time) + } + # Only keep evaluable rows + data <- data.frame(conc=conc, time=time)[!is.na(conc), , drop=FALSE] + # Determine intervals where both values are above, the first value is above, + # or the second value is above + data$above <- data$conc >= conc_above + mask_both <- data$above[-1] & data$above[-nrow(data)] + mask_first <- !data$above[-1] & data$above[-nrow(data)] + mask_second <- data$above[-1] & !data$above[-nrow(data)] + conc1 <- data$conc[-nrow(data)] + conc2 <- data$conc[-1] + time1 <- data$time[-nrow(data)] + time2 <- data$time[-1] + # Calculations + if (nrow(data) < 2) { + ret <- structure(NA_real_, exclude="Too few measured concentrations to assess time_above") + } else if (method %in% 'lin up/log down') { + linear_up <- conc2 > conc1 | conc2 == conc1 + linear_down <- conc2 == 0 + log_down <- !linear_down & conc2 > 0 + ret <- + sum((time2 - time1)[mask_both]) + + # log down + sum( + ((log(conc_above) - log(conc1))/(log(conc2) - log(conc1))*(time2 - time1))[mask_first & log_down] + ) + + # linear down + sum( + ((conc_above - conc1)/(conc2 - conc1)*(time2 - time1))[mask_first & linear_down] + ) + + # linear up + sum( + ((conc2 - conc_above)/(conc2 - conc1)*(time2 - time1))[mask_second & linear_up] + ) + } else if (method %in% 'linear') { + ret <- + sum((time2 - time1)[mask_both]) + + # linear down + sum( + ((conc_above - conc1)/(conc2 - conc1)*(time2 - time1))[mask_first] + ) + + # linear up + sum( + ((conc2 - conc_above)/(conc2 - conc1)*(time2 - time1))[mask_second] + ) + } else { + # Should be caught by the method assignment above + stop("Invalid 'method', please report this as a bug: ", method) # nocov + } + ret +} +# Add the column to the interval specification +add.interval.col("time_above", + FUN="pk.calc.time_above", + values=c(FALSE, TRUE), + unit_type="time", + pretty_name="Time above Concentration", desc="Time above a given concentration", pptestcd_cdisc="TAT", pptest_cdisc="Time Above Threshold") -PKNCA.set.summary( - name="time_above", - description="arithmetic mean and standard deviation", - point=business.mean, - spread=business.sd -) +PKNCA.set.summary( + name="time_above", + description="arithmetic mean and standard deviation", + point=business.mean, + spread=business.sd +) From b11e388e8db6869ad7798ba82bb71fbf0fb85a3b Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Fri, 14 Aug 2026 05:59:28 -0400 Subject: [PATCH 6/9] Bracket multi-line nocov regions instead of marking single lines Expanding one-line stop() calls into multi-line rlang::abort() calls left `# nocov` on only some lines of each call, so the unmarked middle lines still counted toward coverage. Per the contributing guide, regions of three or more lines are bracketed with `# nocov start` / `# nocov end`; statements of one or two lines keep a trailing marker on each line. 35 sites across 14 files. Every converted region contains exactly one rlang::abort() or rlang::warn() call and nothing else. Also bracket the closure in zero_len_summary(), where a pre-existing pair of bare `#nocov` markers on the first and last line left the nine-line body counted. Co-Authored-By: Claude Opus 5 --- R/auc.R | 4 ++- R/auc_integrate.R | 8 +++-- R/check.intervals.R | 12 +++++-- R/class-general.R | 8 +++-- R/class-summary_PKNCAresults.R | 26 +++++++++----- R/cleaners.R | 14 +++++--- R/general.functions.R | 6 ++-- R/interpolate.conc.R | 66 ++++++++++++++++++++-------------- R/parse_formula_to_cols.R | 14 +++++--- R/pk.calc.all.R | 20 ++++++----- R/pk.calc.simple.R | 8 +++-- R/superposition.R | 4 ++- R/tss.R | 4 ++- R/tss.monoexponential.R | 10 ++++-- R/unit-support.R | 8 +++-- 15 files changed, 142 insertions(+), 70 deletions(-) diff --git a/R/auc.R b/R/auc.R index 30fe1af2..dd87009b 100644 --- a/R/auc.R +++ b/R/auc.R @@ -179,10 +179,12 @@ 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) + # nocov start rlang::abort( message = "Unknown error with NA tlast but non-BLQ concentrations", class = "pknca_error_internal_tlast" - ) # nocov + ) + # nocov end } else { interval_method <- choose_interval_method(conc = data$conc, time = data$time, tlast = tlast, method = method, auc.type = auc.type, options = options) ret <- diff --git a/R/auc_integrate.R b/R/auc_integrate.R index 50dc6b3f..58dc6d40 100644 --- a/R/auc_integrate.R +++ b/R/auc_integrate.R @@ -151,13 +151,15 @@ choose_interval_method <- function(conc, time, tlast, method, auc.type, options) ret[c(mask_linear, FALSE)] <- "linear" ret[c(mask_log, FALSE)] <- "log" } else { + # nocov start rlang::abort( message = sprintf( "Unknown integration method, please report a bug: %s", method ), class = "pknca_error_internal_unknown_integration_method" - ) # nocov + ) + # nocov end } ret[c(mask_zero, FALSE)] <- "zero" # What happens after tlast? @@ -211,13 +213,15 @@ 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") { + # nocov start rlang::abort( message = sprintf( "Invalid interval_method_extrap, please report a bug: %s", interval_method_extrap ), class = "pknca_error_internal_invalid_interval_method_extrap" - ) # nocov + ) + # nocov end } ret <- sum(ret) ret diff --git a/R/check.intervals.R b/R/check.intervals.R index 10f82673..637be736 100644 --- a/R/check.intervals.R +++ b/R/check.intervals.R @@ -53,10 +53,12 @@ check.interval.specification <- function(x) { } else { # It would probably take malicious code to get here (altering # the intervals without using add.interval.col + # nocov start rlang::abort( message = paste("Cannot assign default value for interval column", n), class = "pknca_error_interval_default_value" - ) # nocov + ) + # nocov end } } else { # Confirm the edits of the given columns @@ -81,10 +83,12 @@ check.interval.specification <- function(x) { } interval_cols[[n]]$values(x[[n]]) } else { + # nocov start rlang::abort( message = paste("Invalid 'values' for column specification", n, "(please report this as a bug)."), class = "pknca_error_interval_invalid_col_spec" - ) # nocov + ) + # nocov end } } } @@ -152,10 +156,12 @@ 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) + # nocov start rlang::abort( message = "Invalid interval definition with no function and multiple dependencies.", class = "pknca_error_interval_invalid_def" - ) # nocov + ) + # nocov end } } else { retfun <- x$FUN diff --git a/R/class-general.R b/R/class-general.R index fa5c4d54..6f2ec51a 100644 --- a/R/class-general.R +++ b/R/class-general.R @@ -274,10 +274,12 @@ 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 { + # nocov start rlang::abort( message = paste("Please report a bug. Unit setting for", col_units), class = "pknca_error_internal_unit_setting_bug" - ) # nocov + ) + # nocov end } } for (pref_units in names(all_units$pref)) { @@ -295,10 +297,12 @@ pknca_set_units <- function(object, units_orig = list(), units_pref = list()) { } object$units[[pref_units]] <- all_units$pref[[pref_units]] } else { + # nocov start rlang::abort( message = paste("Please report a bug. Preferred unit setting for", pref_units), class = "pknca_error_internal_pref_unit_setting_bug" - ) # nocov + ) + # nocov end } } diff --git a/R/class-summary_PKNCAresults.R b/R/class-summary_PKNCAresults.R index 1dc07b0b..fbb026f0 100644 --- a/R/class-summary_PKNCAresults.R +++ b/R/class-summary_PKNCAresults.R @@ -291,10 +291,12 @@ get_summary_PKNCAresults_count_N <- function(data, result_group, subject_col, su ret$N <- as.character(ret$N) if (anyNA(ret$N)) { + # nocov start 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 + message = "Please report a bug. If N is requested, but it is not provided, then it should be set to not calculated.", class = "pknca_error_internal_n_is_na" - ) # nocov + ) + # nocov end } } else { ret <- result_group @@ -392,11 +394,13 @@ summarize_PKNCAresults_group <- function(data, current_group, subject_col, resul current_data <- dplyr::inner_join(data, current_group, by = intersect(names(data), names(current_group))) if (nrow(current_data) == 0) { # I don't think that a user can get here + # nocov start rlang::warn( - message = "No results to summarize for result row, please report a bug", # nocov + message = "No results to summarize for result row, please report a bug", class = "pknca_warning_no_results_to_summarize" - ) # nocov - return(ret) # nocov + ) + return(ret) + # nocov end } current_interval <- dplyr::inner_join(intervals, current_group, by = intersect(names(intervals), names(current_group))) current_param_prep <- @@ -480,13 +484,15 @@ summarize_PKNCAresults_parameter <- function(data, parameter, subject_col, inclu current_summary_instructions <- PKNCA.set.summary()[[parameter]] if (is.null(current_summary_instructions)) { + # nocov start rlang::abort( message = sprintf( "No summary function is set for parameter %s. Please set it with PKNCA.set.summary and report this as a bug in PKNCA.", parameter ), class = "pknca_error_no_summary_function" - ) # nocov + ) + # nocov end } point <- current_summary_instructions$point(current_data[[number_col]]) @@ -618,26 +624,30 @@ roundingSummarize <- function(x, name) { ret <- roundingInstructions(x) } else if (is.list(roundingInstructions)) { if (length(roundingInstructions) != 1) { + # nocov start rlang::abort( message = sprintf( "Cannot interpret rounding instructions for %s (please report this as a bug)", name - ), # nocov + ), class = "pknca_error_internal_rounding_instructions" ) + # nocov end } if ("signif" == names(roundingInstructions)) { ret <- signifString(x, roundingInstructions$signif) } else if ("round" == names(roundingInstructions)) { ret <- roundString(x, roundingInstructions$round) } else { + # nocov start rlang::abort( message = sprintf( "Invalid rounding instruction list name for %s (please report this as a bug)", name - ), # nocov + ), class = "pknca_error_internal_invalid_rounding_name" ) + # nocov end } } if (!is.character(ret)) { diff --git a/R/cleaners.R b/R/cleaners.R index ef44792f..21d4a368 100644 --- a/R/cleaners.R +++ b/R/cleaners.R @@ -30,10 +30,12 @@ clean.conc.na <- function(conc, time, ..., } else { # This case should already have been captured by the PKNCA.options # call above. + # nocov start rlang::abort( - message = "Unknown how to handle conc.na", # nocov + message = "Unknown how to handle conc.na", class = "pknca_error_unknown_conc_na" ) + # nocov end } ret } @@ -135,10 +137,12 @@ clean.conc.blq <- function(conc, time, } else if (time_type == "after.tmax") { mask <- tmax <= ret$time & ret$conc %in% 0 } else { + # nocov start rlang::abort( - message = "There is a bug in cleaning the conc.blq with position names", # nocov + message = "There is a bug in cleaning the conc.blq with position names", class = "pknca_error_conc_blq_position_bug" ) + # nocov end } # Choose the rule to apply this_rule <- unname(conc.blq)[[i]] @@ -152,13 +156,15 @@ clean.conc.blq <- function(conc, time, } else { # This case should already have been captured by the PKNCA.options # call above. + # nocov start rlang::abort( message = sprintf( - "Unknown how to handle conc.blq rule %s", # nocov + "Unknown how to handle conc.blq rule %s", as.character(this_rule) ), class = "pknca_error_unknown_conc_blq_rule" - ) # nocov + ) + # nocov end } } } diff --git a/R/general.functions.R b/R/general.functions.R index 22129101..a3eb74cd 100644 --- a/R/general.functions.R +++ b/R/general.functions.R @@ -198,7 +198,8 @@ signifString.default <- function(x, digits=6, sci_range=6, sci_sep="e", si_range #' @return Either `zero_length` or `FUN(...)` #' @noRd zero_len_summary <- function(FUN) { - function(..., na.rm=FALSE, zero_length=NA) { #nocov + # nocov start + function(..., na.rm=FALSE, zero_length=NA) { x <- c(...) if (na.rm) { x <- stats::na.omit(x) @@ -208,7 +209,8 @@ zero_len_summary <- function(FUN) { } else { FUN(x) } - } #nocov + } + # nocov end } #' @describeIn zero_len_summary Find the maximum value with a different value if diff --git a/R/interpolate.conc.R b/R/interpolate.conc.R index 62c99989..43746068 100644 --- a/R/interpolate.conc.R +++ b/R/interpolate.conc.R @@ -117,10 +117,12 @@ 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)) { + # nocov start rlang::abort( - message = "Please report a bug: tlast is NA; cannot interpolate/extrapolate", # nocov + message = "Please report a bug: tlast is NA; cannot interpolate/extrapolate", class = "pknca_error_internal_tlast_na" - ) # nocov + ) + # nocov end } else if (is.na(time.out[i])) { rlang::warn( message = "An interpolation/extrapolation time is NA", @@ -235,10 +237,12 @@ interpolate.conc <- function(conc, time, time.out, } else if (interp_method == "zero") { 0 } else { + # nocov start rlang::abort( - message = "Please report a bug: invalid interp_method", # nocov + message = "Please report a bug: invalid interp_method", class = "pknca_error_internal_invalid_interp_method" ) + # nocov end } } ret @@ -329,10 +333,12 @@ extrapolate.conc <- function(conc, time, time.out, ) } } else { + # nocov start rlang::abort( - message = "Invalid auc.type caught too late (seeing this error indicates a software bug)", # nocov + message = "Invalid auc.type caught too late (seeing this error indicates a software bug)", class = "pknca_error_invalid_auc_type_late" ) + # nocov end } } ret @@ -446,13 +452,15 @@ interp.extrap.conc.dose <- function(conc, time, TRUE~"unknown") # should never happen if (any(mask_unknown <- data_all$event %in% "unknown")) { # All events should be accounted for already - rlang::abort( # nocov - message = sprintf( # nocov - "Unknown event in interp.extrap.conc.dose at time(s): %s (Please report this as a bug)", # nocov - paste(unique(data_all$time[mask_unknown]), collapse = ", ") # nocov - ), # nocov - class = "pknca_error_internal_unknown_event" # nocov - ) # nocov + # nocov start + rlang::abort( + message = sprintf( + "Unknown event in interp.extrap.conc.dose at time(s): %s (Please report this as a bug)", + paste(unique(data_all$time[mask_unknown]), collapse = ", ") + ), + class = "pknca_error_internal_unknown_event" + ) + # nocov end } # Remove "output_only" from event_before and event_after simple_locf <- function(x, missing_val) { @@ -497,13 +505,15 @@ interp.extrap.conc.dose <- function(conc, time, } if (any(mask_no_method <- is.na(data_all$method))) { # This should never happen, all eventualities should be covered - rlang::abort( # nocov - message = sprintf( # nocov - "No method for imputing concentration at time(s): %s", # nocov - paste(unique(data_all$time[mask_no_method]), collapse = ", ") # nocov - ), # nocov - class = "pknca_error_no_interp_method" # nocov - ) # nocov + # nocov start + rlang::abort( + message = sprintf( + "No method for imputing concentration at time(s): %s", + paste(unique(data_all$time[mask_no_method]), collapse = ", ") + ), + class = "pknca_error_no_interp_method" + ) + # nocov end } # Filter to the requested time points and output data_out <- data_all[data_all$out,,drop=FALSE] @@ -531,15 +541,17 @@ iecd_impossible_select <- function(x) { x$event_after %in% c("conc_dose_iv_bolus_after", "dose_iv_bolus_after")) } iecd_impossible_value <- function(data_all, current_idx, ...) { - 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_internal_impossible_event_combination" # nocov - ) # nocov + # nocov start + rlang::abort( + message = sprintf( + "Impossible combination requested for interp.extrap.conc.dose (please report this as a bug). event_before: %s, event: %s, event_after: %s", + data_all$event_before[current_idx], + data_all$event[current_idx], + data_all$event_after[current_idx] + ), + class = "pknca_error_internal_impossible_event_combination" + ) + # nocov end } # Observed concentration #### diff --git a/R/parse_formula_to_cols.R b/R/parse_formula_to_cols.R index 152b1eef..791b4963 100644 --- a/R/parse_formula_to_cols.R +++ b/R/parse_formula_to_cols.R @@ -25,10 +25,12 @@ findOperator <- function(x, op, side) { if (identical(x[[1]], op)) { # We found the operator if (length(x) == 1) { + # nocov start rlang::abort( - message = "call or formula with length 1 found after finding the operator, unknown how to proceed", # nocov + message = "call or formula with length 1 found after finding the operator, unknown how to proceed", class = "pknca_error_formula_length1_after_op" - ) # nocov + ) + # nocov end } else if (length(x) == 2) { # Unary operators have a right hand side only if (side == "left") { @@ -38,10 +40,12 @@ findOperator <- function(x, op, side) { } else if (side == "both") { return(x) } + # nocov start rlang::abort( - message = "Unknown side with a found unary operator", # nocov + message = "Unknown side with a found unary operator", class = "pknca_error_unknown_side_unary" ) + # nocov end } else if (length(x) == 3) { # Binary operator if (side == "left") { @@ -51,10 +55,12 @@ findOperator <- function(x, op, side) { } else if (side == "both") { return(x) } + # nocov start rlang::abort( - message = "Unknown side with a found binary operator", # nocov + message = "Unknown side with a found binary operator", class = "pknca_error_unknown_side_binary" ) + # nocov end } } else { # Go down the left then right side of the tree diff --git a/R/pk.calc.all.R b/R/pk.calc.all.R index 4f9c1ced..27ac753a 100644 --- a/R/pk.calc.all.R +++ b/R/pk.calc.all.R @@ -342,15 +342,17 @@ pk.nca.intervals <- function(data_conc, data_dose, data_intervals, sparse, tryCatch( do.call(pk.nca.interval, args), error = function(e) { - rlang::abort( # nocov - message = sprintf( # nocov + # nocov start + rlang::abort( + message = sprintf( "Please report a bug.\n%s: %s", error_preamble, e$message - ), # nocov - class = "pknca_error_interval_calculation", # nocov - parent = e # nocov - ) # nocov + ), + class = "pknca_error_interval_calculation", + parent = e + ) + # nocov end } ) } @@ -461,10 +463,12 @@ 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) { + # nocov start rlang::abort( - message = "Please report a bug. Length of dose should not be zero.", # nocov + message = "Please report a bug. Length of dose should not be zero.", class = "pknca_error_internal_dose_length_zero" - ) # nocov + ) + # nocov end } # Make sure that we calculate all of the dependencies. Do this in # reverse order for dependencies of dependencies. diff --git a/R/pk.calc.simple.R b/R/pk.calc.simple.R index cc15c20e..1d789010 100644 --- a/R/pk.calc.simple.R +++ b/R/pk.calc.simple.R @@ -1517,10 +1517,12 @@ pk.calc.ctrough <- function(conc, time, end) { } else { # This should be impossible as assert_conc_time should catch # duplicates. + # nocov start 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 + ) + # nocov end } } add.interval.col("ctrough", @@ -1548,10 +1550,12 @@ pk.calc.cstart <- function(conc, time, start) { } else { # This should be impossible as assert_conc_time should catch # duplicates. + # nocov start 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 + ) + # nocov end } } add.interval.col("cstart", diff --git a/R/superposition.R b/R/superposition.R index c7f2708a..b1f899d5 100644 --- a/R/superposition.R +++ b/R/superposition.R @@ -166,10 +166,12 @@ superposition.numeric <- function(conc, time, dose.input = NULL, dose.scaling <- dose.amount / dose.input if (length(dose.scaling) != length(dose.times)) { if (length(dose.scaling) != 1) + # nocov start rlang::abort( message = "bug in dose.amount, dose.times, and dose.input handling", class = "pknca_error_internal_dose_scaling" - ) # nocov + ) + # nocov end # it is a scalar and there is more than one dose dose.scaling <- rep(dose.scaling, length(dose.times)) } diff --git a/R/tss.R b/R/tss.R index c38e29cf..02044228 100644 --- a/R/tss.R +++ b/R/tss.R @@ -128,10 +128,12 @@ pk.tss <- function(..., if (identical(NA, ret)) { ret <- ret_monoexponential } else { + # nocov start rlang::abort( message = "Bug in pk.tss where ret is set to non-NA too early. Please report the bug with a reproducible example.", class = "pknca_error_internal_pk_tss_ret_non_na" - ) # nocov + ) + # nocov end } # 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 4a8f3432..f162a1f6 100644 --- a/R/tss.monoexponential.R +++ b/R/tss.monoexponential.R @@ -99,10 +99,12 @@ pk.tss.monoexponential <- function(..., } else if (!identical(NA, ret_individual)) { ret_individual } else { + # nocov start rlang::abort( message = "Error in selection of return values for pk.tss.monoexponential. This is likely a bug.", class = "pknca_error_internal_tss_return_selection" - ) # nocov + ) + # nocov end } ret } @@ -383,10 +385,12 @@ pk.tss.monoexponential.individual <- function(data, } else if ("subject" %in% names(data)) { dplyr::grouped_df(data, vars="subject") } else { - rlang::abort( # nocov + # nocov start + rlang::abort( message = "Please report a bug. Subject must be specified to have subject-level fitting", class = "pknca_error_internal_tss_no_subject_for_individual" - ) # nocov + ) + # nocov end } ret_sub <- dplyr::summarize( diff --git a/R/unit-support.R b/R/unit-support.R index e72e3edc..daa142b1 100644 --- a/R/unit-support.R +++ b/R/unit-support.R @@ -126,13 +126,15 @@ pknca_units_table.default <- function(concu, doseu, amountu, timeu, extra_cols <- setdiff(ret$PPTESTCD, names(get.interval.cols())) if (length(extra_cols) > 0) { + # nocov start rlang::abort( message = sprintf( "Please report a bug. Unknown NCA parameters have units defined: %s", paste(extra_cols, collapse = ", ") ), class = "pknca_error_internal_unknown_nca_units" - ) # nocov + ) + # nocov end } # Apply conversion factors @@ -150,10 +152,12 @@ pknca_units_table.default <- function(concu, doseu, amountu, timeu, class = "pknca_error_units_conversions_extra_cols" ) if (any(is.na(conversions$conversion_factor)) && !requireNamespace("units", quietly=TRUE)) { + # nocov start rlang::abort( message = "The units package is required for automatic unit conversion", class = "pknca_error_missing_units_package" - ) # nocov + ) + # nocov end } for (idx in which(is.na(conversions$conversion_factor))) { conversions$conversion_factor[idx] <- From 0e66a56c9773fcf285db6d3f0a59193a1e764da0 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Fri, 14 Aug 2026 07:48:52 -0400 Subject: [PATCH 7/9] Use literal condition classes and checkmate predicates in validate_cdisc_arg The class names were built with sprintf() from the argument name, so the six resulting classes could not be grepped for and only the three pptestcd_cdisc ones were ever evaluated -- a typo in the pptest_cdisc trio would have gone unnoticed. Three literal classes cover both arguments and are exercised by the existing tests. Replace the hand-rolled scalar and name checks with checkmate::test_string() and checkmate::test_names(), keeping rlang::abort() so each failure retains its class. Drop the redundant length(x) != 1 test, which identical(names(x), "route") already implies. Document the validation itself in NEWS: it is stricter than the previous character-or-list check and can reject input that add.interval.col() used to accept. Co-Authored-By: Claude Opus 5 --- NEWS.md | 8 ++++++++ R/001-add.interval.col.R | 16 +++++++--------- tests/testthat/test-001-add.interval.col.R | 20 ++++++++++---------- 3 files changed, 25 insertions(+), 19 deletions(-) diff --git a/NEWS.md b/NEWS.md index 32bea1a6..7b375922 100644 --- a/NEWS.md +++ b/NEWS.md @@ -32,6 +32,14 @@ the dosing including dose amount and route. relying on `%in%`'s implicit list coercion downstream instead of failing clearly. Passing a list now raises an error instead. +* `add.interval.col()` now validates the structure of `pptestcd_cdisc` and + `pptest_cdisc` rather than only checking that they are a character string or + a list. A character value must be length 1 and non-missing, and a list must + have exactly one element named `route` whose value is a named list. Values + that were previously accepted and would have produced incorrect CDISC output + (for example a multi-element character vector, or a list named something + other than `route`) now raise an error. + * Business functions (used for calculations of means, etc.) now return NA_real_ for empty inputs rather than giving an error (#559). diff --git a/R/001-add.interval.col.R b/R/001-add.interval.col.R index b6e13a48..5a121c4c 100644 --- a/R/001-add.interval.col.R +++ b/R/001-add.interval.col.R @@ -15,22 +15,20 @@ assign("interval.cols", list(), envir=.PKNCAEnv) #' @noRd validate_cdisc_arg <- function(x, arg_name) { if (is.character(x)) { - if (length(x) != 1 || is.na(x)) { + if (!checkmate::test_string(x, na.ok = FALSE)) { rlang::abort( message = sprintf( "`%s`, when a character string, must be length 1 and non-missing", arg_name ), - class = sprintf("pknca_error_%s_character_invalid", arg_name) + class = "pknca_error_cdisc_character_invalid" ) } } else if (is.list(x)) { - if (length(x) != 1 || - !identical(names(x), "route") || + # `identical(names(x), "route")` also confirms that x has length 1 + if (!identical(names(x), "route") || !is.list(x$route) || - is.null(names(x$route)) || - any(names(x$route) == "") || - anyNA(names(x$route))) { + !checkmate::test_names(names(x$route), type = "named")) { rlang::abort( message = sprintf( paste0( @@ -39,7 +37,7 @@ validate_cdisc_arg <- function(x, arg_name) { ), arg_name ), - class = sprintf("pknca_error_%s_route_mapping_invalid", arg_name) + class = "pknca_error_cdisc_route_mapping_invalid" ) } } else { @@ -48,7 +46,7 @@ validate_cdisc_arg <- function(x, arg_name) { "`%s` must be a character string or a list", arg_name ), - class = sprintf("pknca_error_%s_invalid_type", arg_name) + class = "pknca_error_cdisc_invalid_type" ) } } diff --git a/tests/testthat/test-001-add.interval.col.R b/tests/testthat/test-001-add.interval.col.R index 14613325..2e6d858f 100644 --- a/tests/testthat/test-001-add.interval.col.R +++ b/tests/testthat/test-001-add.interval.col.R @@ -230,7 +230,7 @@ test_that("add.interval.col rejects pptestcd_cdisc types", { pretty_name = "a", desc = "test", pptestcd_cdisc = 123 ), - class = "pknca_error_pptestcd_cdisc_invalid_type" + class = "pknca_error_cdisc_invalid_type" ) # invalid character values @@ -240,7 +240,7 @@ test_that("add.interval.col rejects pptestcd_cdisc types", { pretty_name = "a", desc = "test", pptestcd_cdisc = c("PCMAX", "PCMIN") ), - class = "pknca_error_pptestcd_cdisc_character_invalid" + class = "pknca_error_cdisc_character_invalid" ) expect_error( @@ -249,7 +249,7 @@ test_that("add.interval.col rejects pptestcd_cdisc types", { pretty_name = "a", desc = "test", pptestcd_cdisc = NA_character_ ), - class = "pknca_error_pptestcd_cdisc_character_invalid" + class = "pknca_error_cdisc_character_invalid" ) # invalid route mappings @@ -259,7 +259,7 @@ test_that("add.interval.col rejects pptestcd_cdisc types", { pretty_name = "a", desc = "test", pptestcd_cdisc = list(foo = "PCMAX") ), - class = "pknca_error_pptestcd_cdisc_route_mapping_invalid" + class = "pknca_error_cdisc_route_mapping_invalid" ) expect_error( @@ -268,7 +268,7 @@ test_that("add.interval.col rejects pptestcd_cdisc types", { pretty_name = "a", desc = "test", pptestcd_cdisc = list(route = "PCMAX") ), - class = "pknca_error_pptestcd_cdisc_route_mapping_invalid" + class = "pknca_error_cdisc_route_mapping_invalid" ) }) @@ -282,7 +282,7 @@ test_that("add.interval.col rejects pptest_cdisc types", { pretty_name = "a", desc = "test", pptest_cdisc = 123 ), - class = "pknca_error_pptest_cdisc_invalid_type" + class = "pknca_error_cdisc_invalid_type" ) # invalid character values @@ -292,7 +292,7 @@ test_that("add.interval.col rejects pptest_cdisc types", { pretty_name = "a", desc = "test", pptest_cdisc = c("PCMAX", "PCMIN") ), - class = "pknca_error_pptest_cdisc_character_invalid" + class = "pknca_error_cdisc_character_invalid" ) expect_error( @@ -301,7 +301,7 @@ test_that("add.interval.col rejects pptest_cdisc types", { pretty_name = "a", desc = "test", pptest_cdisc = NA_character_ ), - class = "pknca_error_pptest_cdisc_character_invalid" + class = "pknca_error_cdisc_character_invalid" ) # invalid route mappings @@ -311,7 +311,7 @@ test_that("add.interval.col rejects pptest_cdisc types", { pretty_name = "a", desc = "test", pptest_cdisc = list(foo = "PCMAX") ), - class = "pknca_error_pptest_cdisc_route_mapping_invalid" + class = "pknca_error_cdisc_route_mapping_invalid" ) expect_error( @@ -320,7 +320,7 @@ test_that("add.interval.col rejects pptest_cdisc types", { pretty_name = "a", desc = "test", pptest_cdisc = list(route = "PCMAX") ), - class = "pknca_error_pptest_cdisc_route_mapping_invalid" + class = "pknca_error_cdisc_route_mapping_invalid" ) }) From 274556e6bca1a75f0edfbc85473aa7c89d2618b7 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Sat, 15 Aug 2026 07:17:31 -0400 Subject: [PATCH 8/9] Apply PR review feedback across the package Condition signaling: - Drop the named `message =` argument from every rlang::abort/warn/inform call (301 sites); it is distinctly the first argument. - Condense 108 short calls onto one line so `# nocov` can be a trailing marker rather than a start/end bracket. - Give every condition class a distinct value (17 sites across 10 reused names), so callers such as ANCA or ruminate can capture a specific failure rather than a shared one. - Replace paste()/paste0() message assembly with sprintf templates (20 sites) so the message a user reports can be grepped for in the source, and hoist the branching message in choose_interval_method() out of the abort call. checkmate: - assert_unit_col() uses assert_names(must.include=) and assert_character() in place of two hand-rolled classed aborts. - add.interval.col() uses assert_list(names = "unique"); the empty-list conditional was dead because checkmate accepts a zero-length list. - choose_interval_method() folds the conc/time length check into the time assertion via len = length(conc). - pk_nca_result_to_df() reads warning_prep$message directly rather than through conditionMessage(). Formatting, limited to lines this PR introduced: - Restore `) {`, drop trailing whitespace, and put closing braces on their own line (80 lines). Lines unchanged from the base are untouched. - Remove the leftover `info` arguments from test-001-add.interval.col.R. Tests follow the renamed classes: the Tobit half-life cases now pin pknca_warning_halflife_too_few_points_tobit, and the assert_unit_col cases pin checkmate's messages. Co-Authored-By: Claude Opus 5 --- R/001-add.interval.col.R | 60 ++---- R/AIC.list.R | 2 +- R/PKNCA.options.R | 226 +++++++-------------- R/assertions.R | 89 ++------ R/auc.R | 29 ++- R/auc_integrate.R | 23 +-- R/aucint.R | 4 +- R/check.intervals.R | 47 ++--- R/choose.intervals.R | 18 +- R/class-PKNCAconc.R | 38 ++-- R/class-PKNCAdata.R | 25 +-- R/class-PKNCAdose.R | 38 ++-- R/class-PKNCAresults.R | 8 +- R/class-general.R | 45 ++-- R/class-summary_PKNCAresults.R | 22 +- R/cleaners.R | 11 +- R/exclude.R | 38 +--- R/exclude_nca.R | 9 +- R/general.functions.R | 12 +- R/half.life.R | 32 ++- R/impute.R | 2 +- R/interpolate.conc.R | 58 ++---- R/normalize.R | 10 +- R/parse_formula_to_cols.R | 25 +-- R/pk.calc.all.R | 68 +++---- R/pk.calc.c0.R | 12 +- R/pk.calc.simple.R | 24 +-- R/prepare_data.R | 20 +- R/provenance.R | 2 +- R/set_and_assert_intervals.R | 2 +- R/sparse.R | 22 +- R/superposition.R | 23 +-- R/time.above.R | 10 +- R/time_calc.R | 26 +-- R/tss.R | 12 +- R/tss.monoexponential.R | 25 +-- R/tss.stepwise.linear.R | 34 ++-- R/unit-support.R | 22 +- R/update.PKNCAresults.R | 12 +- tests/testthat/test-001-add.interval.col.R | 9 +- tests/testthat/test-assertions.R | 5 +- tests/testthat/test-class-PKNCAdose.R | 2 +- tests/testthat/test-half.life.R | 6 +- 43 files changed, 422 insertions(+), 785 deletions(-) diff --git a/R/001-add.interval.col.R b/R/001-add.interval.col.R index 5a121c4c..bb0de4da 100644 --- a/R/001-add.interval.col.R +++ b/R/001-add.interval.col.R @@ -17,7 +17,7 @@ validate_cdisc_arg <- function(x, arg_name) { if (is.character(x)) { if (!checkmate::test_string(x, na.ok = FALSE)) { rlang::abort( - message = sprintf( + sprintf( "`%s`, when a character string, must be length 1 and non-missing", arg_name ), @@ -30,11 +30,8 @@ validate_cdisc_arg <- function(x, arg_name) { !is.list(x$route) || !checkmate::test_names(names(x$route), type = "named")) { rlang::abort( - message = sprintf( - paste0( - "`%s`, when a list, must have exactly one named element, \"route\", ", - "whose value is itself a named list mapping route to value." - ), + sprintf( + "`%s`, when a list, must have exactly one named element, \"route\", whose value is itself a named list mapping route to value.", arg_name ), class = "pknca_error_cdisc_route_mapping_invalid" @@ -42,7 +39,7 @@ validate_cdisc_arg <- function(x, arg_name) { } } else { rlang::abort( - message = sprintf( + sprintf( "`%s` must be a character string or a list", arg_name ), @@ -162,18 +159,15 @@ add.interval.col <- function(name, 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) - + checkmate::assert_character(x = depends, null.ok = TRUE) + # `values` must be either a function (used to validate/coerce) or a vector # of allowed values -- both are acceptable, so just ensure it was supplied # and is one of those two forms. if (!is.function(values) && !is.vector(values)) { - rlang::abort( - message = "`values` must be a function or a vector of allowed values", - class = "pknca_error_values_invalid" - ) + rlang::abort("`values` must be a function or a vector of allowed values", class = "pknca_error_values_invalid") } - + unit_type <- match.arg( unit_type, @@ -189,51 +183,45 @@ add.interval.col <- function(name, "clearance", "renal_clearance", "renal_clearance_dosenorm" ) ) - + # Validate datatype (only "interval" is currently supported) datatype <- match.arg(datatype) checkmate::assert_choice(x = datatype, choices = "interval") - + # Validate formalsmap - checkmate::assert_list( - x = formalsmap, - names = if (length(formalsmap) > 0) "unique" else NULL - ) - + checkmate::assert_list(x = formalsmap, names = "unique") + # Validate formalsmap and function compatibility if (length(formalsmap) > 0) { # Ensure FUN exists if (is.na(FUN)) { - rlang::abort( - message = "`formalsmap` may not be provided when `FUN` is NA", - class = "pknca_error_formalsmap_with_na_fun" - ) + rlang::abort("`formalsmap` may not be provided when `FUN` is NA", class = "pknca_error_formalsmap_with_na_fun") } # Ensure formalsmap names are unique checkmate::assert_character(x = names(formalsmap), min.chars = 1, any.missing = FALSE) } - + # Ensure that the function exists if (!is.na(FUN)) { # Ensure that the function exists fun_obj <- utils::getAnywhere(FUN) if (length(fun_obj$objs) == 0) { rlang::abort( - message = sprintf( + 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( + sprintf( "All names in `formalsmap` must be arguments to the function '%s'. Invalid names: %s", FUN, paste(dQuote(invalid_formals), collapse = ", ") @@ -242,9 +230,9 @@ add.interval.col <- function(name, ) } } - + } - + # Default CDISC mappings to name/desc when not provided if (is.null(pptestcd_cdisc)) { pptestcd_cdisc <- name @@ -302,12 +290,8 @@ sort_interval_cols <- function() { missing_deps <- deps[!(deps %in% names(myorder))] if (length(missing_deps) > 0) { rlang::abort( - message = sprintf( - paste0( - "Invalid dependencies for interval column ", - "(please report this as a bug): %s ", - "The following dependencies are missing: %s" - ), + sprintf( + "Invalid dependencies for interval column (please report this as a bug): %s The following dependencies are missing: %s", names(myorder)[nextorder], paste(missing_deps, collapse = ", ") ), diff --git a/R/AIC.list.R b/R/AIC.list.R index 2976f073..f79777d1 100644 --- a/R/AIC.list.R +++ b/R/AIC.list.R @@ -27,7 +27,7 @@ AIC.list <- function(object, ..., assess.best=TRUE) { } else { # nocov start rlang::abort( - message = "Unknown way to get a data.frame without indentation set. This is likely a bug.", + "Unknown way to get a data.frame without indentation set. This is likely a bug.", class = "pknca_error_internal_unknown_dataframe_indentation" ) # nocov end diff --git a/R/PKNCA.options.R b/R/PKNCA.options.R index a303e143..095729b8 100644 --- a/R/PKNCA.options.R +++ b/R/PKNCA.options.R @@ -12,17 +12,14 @@ checkmate::assert_number(x, .var.name = "adj.r.squared.factor") if (x <= 0 || x >= 1) { rlang::abort( - message = "adj.r.squared.factor must be between 0 and 1, exclusive", + "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" - ) - } + + if (x > 0.01) { + rlang::warn("adj.r.squared.factor is usually <0.01", class = "pknca_warning_adj_r2_factor_large") + } x }, max.missing=function(x, default=FALSE, description=FALSE) { @@ -34,17 +31,11 @@ return(0.5) checkmate::assert_number(x, .var.name = "max.missing") if (x < 0 || x >= 1) { - rlang::abort( - message = "max.missing must be between 0 and 1", - class = "pknca_error_max.missing_out_of_bounds" - ) + rlang::abort("max.missing must be between 0 and 1", class = "pknca_error_max.missing_out_of_bounds") } if (x > 0.5) { - rlang::warn( - message = "max.missing is usually <= 0.5", - class = "pknca_warning_max_missing_large" - ) - } + rlang::warn("max.missing is usually <= 0.5", class = "pknca_warning_max_missing_large") + } x }, auc.method=function(x, default=FALSE, description=FALSE) { @@ -67,37 +58,22 @@ if (default) return("drop") if (is.na(x)) { - rlang::abort( - message = "conc.na must not be NA", - class = "pknca_error_conc_na_is_na" - ) + rlang::abort("conc.na must not be NA", class = "pknca_error_conc_na_is_na") } if (is.factor(x)) { - rlang::warn( - message = "conc.na may not be a factor; attempting conversion", - class = "pknca_warning_conc_na_factor" - ) + rlang::warn("conc.na may not be a factor; attempting conversion", class = "pknca_warning_conc_na_factor") x <- as.character(x) } if (tolower(x) %in% "drop") { x <- tolower(x) } else if (is.numeric(x)) { if (is.infinite(x)) { - rlang::abort( - message = "When a number, conc.na must be finite", - class = "pknca_error_conc_na_infinite" - ) + rlang::abort("When a number, conc.na must be finite", class = "pknca_error_conc_na_infinite") } else if (x < 0) { - rlang::warn( - message = "conc.na is usually not < 0", - class = "pknca_warning_conc_na_negative" - ) + rlang::warn("conc.na is usually not < 0", class = "pknca_warning_conc_na_negative") } } else { - rlang::abort( - message = "conc.na must either be a finite number or the text 'drop'", - class = "pknca_error_conc_na_invalid" - ) + rlang::abort("conc.na must either be a finite number or the text 'drop'", class = "pknca_error_conc_na_invalid") } x }, @@ -114,29 +90,20 @@ check.element <- function(x) { checkmate::assert_scalar(x, na.ok = FALSE) if (is.factor(x)) { - rlang::warn( - message = "conc.blq may not be a factor; attempting conversion", - class = "pknca_warning_conc_blq_factor" - ) + rlang::warn("conc.blq may not be a factor; attempting conversion", class = "pknca_warning_conc_blq_factor") x <- as.character(x) } if (tolower(x) %in% c("drop", "keep")) { x <- tolower(x) } else if (is.numeric(x)) { if (is.infinite(x)) { - rlang::abort( - message = "When a number, conc.blq must be finite", - class = "pknca_error_conc_blq_infinite" - ) + rlang::abort("When a number, conc.blq must be finite", class = "pknca_error_conc_blq_infinite") } else if (x < 0) { - rlang::warn( - message = "conc.blq is usually not < 0", - class = "pknca_warning_conc_blq_negative" - ) + rlang::warn("conc.blq is usually not < 0", class = "pknca_warning_conc_blq_negative") } } else { rlang::abort( - message = "conc.blq must either be a finite number or the text 'drop' or 'keep'", + "conc.blq must either be a finite number or the text 'drop' or 'keep'", class = "pknca_error_conc_blq_invalid" ) } @@ -145,30 +112,30 @@ if (is.list(x)) { tfirst_names <- c("first", "last", "middle") tmax_names <- c("before.tmax", "after.tmax") - + are.names.mixed <- any(names(x) %in% tfirst_names) & any(names(x) %in% tmax_names) 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){ + 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'.", + "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) 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'.", + "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) 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'.", + "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) rlang::abort( - message = "When given as a list, conc.blq should not have duplicated names", + "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. @@ -196,19 +163,16 @@ )) if (default) return(TRUE) - + checkmate::assert_scalar(x, na.ok = FALSE, .var.name = "first.tmax") - + if (!is.logical(x)) { x <- as.logical(x) if (is.na(x)) { - rlang::abort( - message = "Could not convert first.tmax to a logical value", - class = "pknca_error_first_tmax_not_logical" - ) + rlang::abort("Could not convert first.tmax to a logical value", class = "pknca_error_first_tmax_not_logical") } else { rlang::warn( - message = paste("Converting first.tmax to a logical value:", x), + sprintf("Converting first.tmax to a logical value: %s", x), class = "pknca_warning_first_tmax_converted" ) } @@ -228,13 +192,10 @@ if (!is.logical(x)) { x <- as.logical(x) if (is.na(x)) { - rlang::abort( - message = "Could not convert first.tmin to a logical value", - class = "pknca_error_first_tmin_not_logical" - ) + rlang::abort("Could not convert first.tmin to a logical value", class = "pknca_error_first_tmin_not_logical") } else { rlang::warn( - message = paste("Converting first.tmin to a logical value:", x), + sprintf("Converting first.tmin to a logical value: %s", x), class = "pknca_warning_first_tmin_converted" ) } @@ -253,18 +214,19 @@ x <- as.logical(x) if (is.na(x)) { rlang::abort( - message = "Could not convert allow.tmax.in.half.life to a logical value", + "Could not convert allow.tmax.in.half.life to a logical value", class = "pknca_error_allow_tmax_hl_not_logical" ) } else { rlang::warn( - message = paste("Converting allow.tmax.in.half.life to a logical value:", x), + sprintf("Converting allow.tmax.in.half.life to a logical value: %s", x), class = "pknca_warning_allow_tmax_hl_converted" - ) } + ) + } } x }, - + keep_interval_cols = function(x, default = FALSE, description = FALSE) { if (description) return("What additional columns from the intervals should be kept in the results?") @@ -273,18 +235,18 @@ checkmate::assert_names(x) x }, - + min.hl.points=function(x, default=FALSE, description=FALSE) { if (description) return("What is the minimum number of points required to calculate half-life?") if (default) return(3) 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) { rlang::warn( - message = "Non-integer given for min.hl.points; rounding to nearest integer", + "Non-integer given for min.hl.points; rounding to nearest integer", class = "pknca_warning_min_hl_points_noninteger" ) x <- round(x) @@ -298,15 +260,9 @@ return(2) checkmate::assert_number(x, na.ok = FALSE, .var.name = "min.span.ratio") if (x <= 0) - rlang::abort( - message = "min.span.ratio must be > 0", - class = "pknca_error_min_span_ratio_range" - ) + rlang::abort("min.span.ratio must be > 0", class = "pknca_error_min_span_ratio_range") if (x < 2) - rlang::warn( - message = "min.span.ratio is usually >= 2", - class = "pknca_warning_min_span_ratio_small" - ) + rlang::warn("min.span.ratio is usually >= 2", class = "pknca_warning_min_span_ratio_small") x }, max.aucinf.pext=function(x, default=FALSE, description=FALSE) { @@ -316,20 +272,14 @@ return(20) 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" - ) + rlang::abort("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" - ) + rlang::warn("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%", + "max.aucinf.pext is on the percent not ratio scale, value given is <1%", class = "pknca_warning_max_aucinf_pext_small" ) } @@ -342,21 +292,15 @@ return(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" - ) + rlang::abort("min.hl.r.squared must be between 0 and 1, exclusive", class = "pknca_error_min_hl_r2_out_of_bounds") + } + + if (x < 0.9) { + rlang::warn("min.hl.r.squared is usually >= 0.9", class = "pknca_warning_min_hl_r2_small") } - - if (x < 0.9){ - rlang::warn( - message = "min.hl.r.squared is usually >= 0.9", - class = "pknca_warning_min_hl_r2_small" - ) - } x }, - + progress = function(x, default = FALSE, description = FALSE) { if (description) return("A value to pass to purrr::pmap(.progress = ) to create a progress bar while running") @@ -365,7 +309,7 @@ } x }, - + tau.choices=function(x, default=FALSE, description=FALSE) { if (description) return(paste( @@ -377,21 +321,15 @@ if (default) return(NA) # 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" - ) + if (length(x) > 1 && anyNA(x)) { + rlang::abort("tau.choices may not include NA and be a vector", class = "pknca_error_tau_choices_na_in_vector") } - + # Only validate non-NA cases if (!identical(x, NA)) { checkmate::assert_numeric(x, .var.name = "tau.choices") if (!is.vector(x)) { - rlang::warn( - message = "tau.choices must be a vector, converting", - class = "pknca_warning_tau_choices_not_vector" - ) + rlang::warn("tau.choices must be a vector, converting", class = "pknca_warning_tau_choices_not_vector") x <- as.vector(x) } } @@ -423,7 +361,7 @@ checkmate::assert_logical(x, any.missing = FALSE, len = 1) x }, - + hl_method = function(x, default = FALSE, description = FALSE) { choices <- c("log-linear", "tobit") if (description) @@ -438,7 +376,7 @@ x <- match.arg(x, choices) x }, - + tobit_n_points_penalty = function(x, default = FALSE, description = FALSE) { if (description) return(paste( @@ -453,7 +391,7 @@ ) x }, - + tobit_optim_control = function(x, default = FALSE, description = FALSE) { if (description) return(paste( @@ -520,14 +458,11 @@ PKNCA.options <- function(..., default=FALSE, check=FALSE, name, value) { # like another argument. if (missing(name)) { if (!missing(value)) - rlang::abort( - message = "Cannot have a value without a name", - class = "pknca_error_value_without_name" - ) + rlang::abort("Cannot have a value without a name", class = "pknca_error_value_without_name") } else { if (name %in% names(args)) rlang::abort( - message = "Cannot give an option name both with the name argument and as a named argument.", + "Cannot give an option name both with the name argument and as a named argument.", class = "pknca_error_duplicate_option_name" ) if (!missing(value)) { @@ -536,17 +471,14 @@ PKNCA.options <- function(..., default=FALSE, check=FALSE, name, value) { args <- append(args, name) } } - if (default && check){ - rlang::abort( - message = "Cannot request both default and check", - class = "pknca_error_default_and_check" - ) + if (default && check) { + rlang::abort("Cannot request both default and check", class = "pknca_error_default_and_check") } - + if (default) { if (length(args) > 0) rlang::abort( - message = "Cannot set default and set new options at the same time.", + "Cannot set default and set new options at the same time.", class = "pknca_error_default_with_options" ) # Extract all the default values @@ -557,16 +489,13 @@ PKNCA.options <- function(..., default=FALSE, check=FALSE, name, value) { } else if (check) { # Check an option for accuracy, but don't set it if (length(args) != 1) { - rlang::abort( - message = "Must give exactly one option to check", - class = "pknca_error_check_not_scalar" - ) + rlang::abort("Must give exactly one option to check", class = "pknca_error_check_not_scalar") } n <- names(args) - if (!(n %in% names(.PKNCA.option.check))){ + if (!(n %in% names(.PKNCA.option.check))) { rlang::abort( - message = paste("Invalid setting for PKNCA:", n), - class = "pknca_error_invalid_option" + sprintf("Invalid setting for PKNCA: %s", n), + class = "pknca_error_invalid_option_check" ) } # Verify the option, and return the sanitized version @@ -575,9 +504,9 @@ PKNCA.options <- function(..., default=FALSE, check=FALSE, name, value) { if (is.null(names(args))) { # Confirm that the settings exist bad.args <- setdiff(unlist(args), names(current)) - if (length(bad.args) > 0){ + if (length(bad.args) > 0) { rlang::abort( - message = sprintf( + sprintf( "PKNCA.options does not have value(s) for %s.", paste(bad.args, collapse = ", ") ), @@ -598,10 +527,10 @@ 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))){ + if (!(n %in% names(.PKNCA.option.check))) { rlang::abort( - message = paste("Invalid setting for PKNCA:", n), - class = "pknca_error_invalid_option" + sprintf("Invalid setting for PKNCA: %s", n), + class = "pknca_error_invalid_option_set" ) } # Verify and set the option value @@ -684,7 +613,7 @@ PKNCA.set.summary <- function(name, description, point, spread, rounding=list(signif=3), reset=FALSE) { if (reset) { rlang::warn( - message = "`reset = TRUE` is not intended for general use, summary() may not work after resetting summary instructions", + "`reset = TRUE` is not intended for general use, summary() may not work after resetting summary instructions", class = "pknca_warning_summary_reset" ) current <- list() @@ -699,8 +628,8 @@ PKNCA.set.summary <- function(name, description, point, spread, # Confirm that the name exists if (!all(found_names <- name %in% names(get("interval.cols", envir=.PKNCAEnv)))) { rlang::abort( - message = paste( - "You must first define the parameter name with add.interval.col. Parameters not yet defined are:", + sprintf( + "You must first define the parameter name with add.interval.col. Parameters not yet defined are: %s", paste(name[!found_names], collapse = ", ") ), class = "pknca_error_undefined_parameter" @@ -733,7 +662,7 @@ PKNCA.set.summary <- function(name, description, point, spread, if (!(names(rounding) %in% c("signif", "round"))) { rlang::abort( - message = "When a list, rounding must have a name of either 'signif' or 'round'", + "When a list, rounding must have a name of either 'signif' or 'round'", class = "pknca_error_rounding_list_name" ) } @@ -745,10 +674,7 @@ PKNCA.set.summary <- function(name, description, point, spread, current[[current_name]]$rounding <- rounding } } else { - rlang::abort( - message = "rounding must be either a list or a function", - class = "pknca_error_rounding_invalid" - ) + rlang::abort("rounding must be either a list or a function", class = "pknca_error_rounding_invalid") } # Set the summary parameters assign("summary", current, envir=.PKNCAEnv) diff --git a/R/assertions.R b/R/assertions.R index 20347fe4..3df8118f 100644 --- a/R/assertions.R +++ b/R/assertions.R @@ -9,33 +9,27 @@ #' @keywords Internal assert_intervaltime_single <- function(interval = NULL, start = NULL, end = NULL) { 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" - ) + rlang::abort("One of `interval` or `start` and `end` must be given", class = "pknca_error_missing_interval") } - + if (xor(is.null(start), is.null(end))) { - rlang::abort( - message = "Both `start` and `end` or neither must be given", - class = "pknca_error_partial_interval" - ) + rlang::abort("Both `start` and `end` or neither must be given", class = "pknca_error_partial_interval") } if (!is.null(interval)) { checkmate::assert_numeric(x = interval, sorted = TRUE, unique = TRUE, any.missing = FALSE, len = 2) checkmate::assert_number(x = interval[1], na.ok = FALSE, finite = TRUE) } - + if (!is.null(start)) { # Check start and end checkmate::assert_number(start, na.ok = FALSE, finite = TRUE, null.ok = FALSE) checkmate::assert_number(end, na.ok = FALSE, finite = FALSE, lower = start, null.ok = FALSE) - + if (is.null(interval)) { interval <- c(start, end) } else if (start != interval[1]) { rlang::abort( - message = sprintf( + sprintf( "`start` must be the same as the first value in the interval if both are given: %s!=%s", start, interval[1] @@ -44,7 +38,7 @@ assert_intervaltime_single <- function(interval = NULL, start = NULL, end = NULL ) } else if (end != interval[2]) { rlang::abort( - message = sprintf( + sprintf( "`end` must be the same as the second value in the interval if both are given: %s!=%s", end, interval[2] @@ -53,7 +47,7 @@ assert_intervaltime_single <- function(interval = NULL, start = NULL, end = NULL ) } } - + interval } @@ -65,23 +59,14 @@ assert_intervaltime_single <- function(interval = NULL, start = NULL, end = NULL #' @rdname assert_conc_time assert_conc <- function(conc, any_missing_conc = TRUE) { if (length(conc) == 0) { - rlang::warn( - message = "No concentration data given", - class = "pknca_warning_no_concentration" - ) + rlang::warn("No concentration data given", class = "pknca_warning_no_concentration") } else { checkmate::assert_numeric(conc, finite = TRUE, any.missing = any_missing_conc) if (all(is.na(conc))) { - rlang::warn( - message = "All concentration data are missing", - class = "pknca_warning_all_concentration_missing" - ) + rlang::warn("All concentration data are missing", class = "pknca_warning_all_concentration_missing") } else if (any(!is.na(conc) & as.numeric(conc) < 0)) { # as.numeric(conc) is required for compatibility with units - rlang::warn( - message = "Negative concentrations found", - class = "pknca_warning_negative_concentration" - ) + rlang::warn("Negative concentrations found", class = "pknca_warning_negative_concentration") } } conc @@ -95,10 +80,7 @@ assert_conc <- function(conc, any_missing_conc = TRUE) { #' @rdname assert_conc_time assert_time <- function(time, sorted_time = TRUE) { if (length(time) == 0) { - rlang::warn( - message = "No time data given", - class = "pknca_warning_no_time" - ) + rlang::warn("No time data given", class = "pknca_warning_no_time") } else { checkmate::assert_numeric(time, any.missing = FALSE, sorted = sorted_time, unique = sorted_time) } @@ -164,7 +146,7 @@ assert_numeric_between <- function(x, any.missing = FALSE, null.ok = FALSE, lowe } if (length(msg) > 0) { rlang::abort( - message = paste(msg, collapse = "\n"), + paste(msg, collapse = "\n"), class = "pknca_error_numeric_between" ) } @@ -228,16 +210,10 @@ assert_aucmethod <- function(method = c("lin up/log down", "linear", "lin-log")) #' @returns The object assert_PKNCAdata <- function(object) { if (!inherits(object, "PKNCAdata")) { - rlang::abort( - message = "Must be a PKNCAdata object", - class = "pknca_error_not_PKNCAdata" - ) + rlang::abort("Must be a PKNCAdata object", class = "pknca_error_not_PKNCAdata") } if (nrow(object$intervals) == 0) { - rlang::warn( - message = "No intervals given; no calculations will be done.", - class = "pknca_warning_no_intervals" - ) + rlang::warn("No intervals given; no calculations will be done.", class = "pknca_warning_no_intervals") } object } @@ -247,10 +223,7 @@ assert_PKNCAdata <- function(object) { #' @export assert_PKNCAresults <- function(object) { if (!inherits(object, "PKNCAresults")) { - rlang::abort( - message = "Must be a PKNCAresults object", - class = "pknca_error_not_pkncaresults" - ) + rlang::abort("Must be a PKNCAresults object", class = "pknca_error_not_pkncaresults") } object } @@ -260,10 +233,7 @@ assert_PKNCAresults <- function(object) { #' @export assert_PKNCAconc <- function(object) { if (!inherits(object, "PKNCAconc")) { - rlang::abort( - message = "Must be a PKNCAconc object", - class = "pknca_error_not_concdata" - ) + rlang::abort("Must be a PKNCAconc object", class = "pknca_error_not_concdata") } object } @@ -273,10 +243,7 @@ assert_PKNCAconc <- function(object) { #' @export assert_PKNCAdose <- function(object) { if (!inherits(object, "PKNCAdose")) { - rlang::abort( - message = "Must be a PKNCAdose object", - class = "pknca_error_not_dosedata" - ) + rlang::abort("Must be a PKNCAdose object", class = "pknca_error_not_dosedata") } object } @@ -286,20 +253,8 @@ assert_PKNCAdose <- function(object) { assert_unit_col <- function(unit, 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" - ) - } + checkmate::assert_names(names(data), must.include = unit) + checkmate::assert_character(data[[unit]]) structure(unit, unit_type = "column") } @@ -311,7 +266,7 @@ assert_unit_value <- function(unit) { if (is.null(unit)) { return(unit) } - + checkmate::assert_character(unit, len = 1) structure(unit, unit_type = "value") @@ -335,7 +290,7 @@ assert_unit <- function(unit, data) { # Re-raise the unit_col error. That is better than unit_value since it is # stricter. rlang::abort( - message = unit_col, + unit_col, class = "pknca_error_invalid_unit" ) } diff --git a/R/auc.R b/R/auc.R index dd87009b..ac92ba4c 100644 --- a/R/auc.R +++ b/R/auc.R @@ -98,15 +98,15 @@ pk.calc.auxc <- function(conc, time, interval=c(0, Inf), # All the data were missing or 0 before excluding points return(structure(0, exclude="DO NOT EXCLUDE")) } - + auc.type <- match.arg(auc.type) interval <- assert_intervaltime_single(interval = interval) - + if (auc.type %in% "AUCinf" && is.finite(interval[2])) { rlang::warn( - message = "Requesting AUCinf when the end of the interval is not Inf", + "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 #### @@ -124,7 +124,7 @@ pk.calc.auxc <- function(conc, time, interval=c(0, Inf), } else if (interval_start > max(data$time)) { # Give this as a warning, but allow it to continue rlang::warn( - message = sprintf( + sprintf( "AUC start time (%g) is after the maximum observed time (%g)", interval_start, max(data$time) @@ -179,12 +179,7 @@ pk.calc.auxc <- function(conc, time, interval=c(0, Inf), # All concentrations are BLQ (note that this has to be checked # after full subsetting and interpolation to ensure that it is # still true) - # nocov start - rlang::abort( - message = "Unknown error with NA tlast but non-BLQ concentrations", - class = "pknca_error_internal_tlast" - ) - # nocov end + rlang::abort("Unknown error with NA tlast but non-BLQ concentrations", class = "pknca_error_internal_tlast") # nocov } else { interval_method <- choose_interval_method(conc = data$conc, time = data$time, tlast = tlast, method = method, auc.type = auc.type, options = options) ret <- @@ -220,7 +215,7 @@ pk.calc.auc <- function(conc, time, ..., options=list()) { pk.calc.auc.last <- function(conc, time, ..., options=list()) { if ("auc.type" %in% names(list(...))) rlang::abort( - message = "auc.type cannot be changed when calling pk.calc.auc.last, please use pk.calc.auc", + "auc.type cannot be changed when calling pk.calc.auc.last, please use pk.calc.auc", class = "pknca_error_auc_last_type_override" ) pk.calc.auc(conc=conc, time=time, ..., @@ -234,7 +229,7 @@ pk.calc.auc.last <- function(conc, time, ..., options=list()) { pk.calc.auc.inf <- function(conc, time, ..., options=list(), lambda.z) { if ("auc.type" %in% names(list(...))) rlang::abort( - message = "auc.type cannot be changed when calling pk.calc.auc.inf, please use pk.calc.auc", + "auc.type cannot be changed when calling pk.calc.auc.inf, please use pk.calc.auc", class = "pknca_error_auc_inf_type_override" ) pk.calc.auc(conc=conc, time=time, ..., @@ -266,7 +261,7 @@ pk.calc.auc.inf.pred <- function(conc, time, clast.pred, ..., options=list(), pk.calc.auc.all <- function(conc, time, ..., options=list()) { if ("auc.type" %in% names(list(...))) rlang::abort( - message = "auc.type cannot be changed when calling pk.calc.auc.all, please use pk.calc.auc", + "auc.type cannot be changed when calling pk.calc.auc.all, please use pk.calc.auc", class = "pknca_error_auc_all_type_override" ) pk.calc.auc(conc=conc, time=time, ..., options=options, @@ -290,7 +285,7 @@ pk.calc.aumc <- function(conc, time, ..., options=list()) { pk.calc.aumc.last <- function(conc, time, ..., options=list()) { if ("auc.type" %in% names(list(...))) rlang::abort( - message = "auc.type cannot be changed when calling pk.calc.aumc.last, please use pk.calc.aumc", + "auc.type cannot be changed when calling pk.calc.aumc.last, please use pk.calc.aumc", class = "pknca_error_aumc_last_type_override" ) pk.calc.aumc(conc=conc, time=time, ..., options=options, @@ -304,7 +299,7 @@ pk.calc.aumc.inf <- function(conc, time, ..., options=list(), lambda.z) { if ("auc.type" %in% names(list(...))) { rlang::abort( - message = "auc.type cannot be changed when calling pk.calc.aumc.inf, please use pk.calc.aumc", + "auc.type cannot be changed when calling pk.calc.aumc.inf, please use pk.calc.aumc", class = "pknca_error_aumc_inf_type_override" ) } @@ -334,7 +329,7 @@ pk.calc.aumc.inf.pred <- function(conc, time, clast.pred, ..., options=list(), pk.calc.aumc.all <- function(conc, time, ..., options=list()) { if ("auc.type" %in% names(list(...))) rlang::abort( - message = "auc.type cannot be changed when calling pk.calc.aumc.all, please use pk.calc.aumc", + "auc.type cannot be changed when calling pk.calc.aumc.all, please use pk.calc.aumc", class = "pknca_error_aumc_all_type_override" ) pk.calc.aumc(conc=conc, time=time, ..., options=options, diff --git a/R/auc_integrate.R b/R/auc_integrate.R index 58dc6d40..d056a483 100644 --- a/R/auc_integrate.R +++ b/R/auc_integrate.R @@ -86,8 +86,7 @@ extrapolate_conc_lambdaz <- function(clast, lambda.z, tlast, time_out) { choose_interval_method <- function(conc, time, tlast, method, auc.type, options) { # Input checking checkmate::assert_numeric(conc, any.missing = FALSE) - checkmate::assert_numeric(time, any.missing = FALSE) - checkmate::assert_numeric(conc, len = length(time)) + checkmate::assert_numeric(time, any.missing = FALSE, len = length(conc)) assert_aucmethod(method) checkmate::assert_choice(auc.type, choices = c("AUCinf", "AUClast", "AUCall")) @@ -117,16 +116,14 @@ choose_interval_method <- function(conc, time, tlast, method, auc.type, options) # return above, since tlast is NA when all concentrations are zero. idx_tlast <- which(time == tlast) if (length(idx_tlast) != 1) { + tlast_detail <- + if (length(idx_tlast) == 0) { + "tlast was not found in time (possible floating point issue)" + } else { + "tlast was found multiple times" + } rlang::abort( - message = sprintf( - "tlast (%s) must occur exactly once in time; %s", - tlast, - if (length(idx_tlast) == 0) { - "tlast was not found in time (possible floating point issue)" - } else { - "tlast was found multiple times" - } - ), + sprintf("tlast (%s) must occur exactly once in time; %s", tlast, tlast_detail), class = "pknca_error_tlast_not_unique" ) } @@ -153,7 +150,7 @@ choose_interval_method <- function(conc, time, tlast, method, auc.type, options) } else { # nocov start rlang::abort( - message = sprintf( + sprintf( "Unknown integration method, please report a bug: %s", method ), @@ -215,7 +212,7 @@ auc_integrate <- function(conc, time, clast, tlast, lambda.z, interval_method, f } else if (interval_method_extrap != "zero") { # nocov start rlang::abort( - message = sprintf( + sprintf( "Invalid interval_method_extrap, please report a bug: %s", interval_method_extrap ), diff --git a/R/aucint.R b/R/aucint.R index 0880f4e2..24b54f7a 100644 --- a/R/aucint.R +++ b/R/aucint.R @@ -84,7 +84,7 @@ pk.calc.auxcint <- function(conc, time, } else if (is.na(clast)) { # nocov start rlang::abort( - message = "Please report a bug. clast is NA and the half-life is not NA", + "Please report a bug. clast is NA and the half-life is not NA", class = "pknca_error_internal_clast_na" ) # nocov end @@ -148,7 +148,7 @@ pk.calc.auxcint <- function(conc, time, paste(missing_times, collapse=", ")) } rlang::warn( - message = warning_message, + warning_message, class = "pknca_warning_missing_interpolated_concentrations" ) return(NA_real_) diff --git a/R/check.intervals.R b/R/check.intervals.R index 637be736..d69bc1d5 100644 --- a/R/check.intervals.R +++ b/R/check.intervals.R @@ -21,22 +21,16 @@ 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. - rlang::warn( - message = "Interval specification must be a data.frame", - class = "pknca_warning_interval_not_df" - ) + rlang::warn("Interval specification must be a data.frame", class = "pknca_warning_interval_not_df") x <- as.data.frame(x, stringsAsFactors=FALSE) } if (nrow(x) == 0) { - rlang::abort( - message = "interval specification has no rows", - class = "pknca_error_interval_no_rows" - ) + rlang::abort("interval specification has no rows", class = "pknca_error_interval_no_rows") } # Confirm that the minimal columns (start and end) exist if (length(missing.required.cols <- setdiff(c("start", "end"), names(x))) > 0) { rlang::abort( - message = sprintf( + sprintf( "Column(s) %s missing from interval specification", paste0("'", missing.required.cols, "'", collapse = ", ") ), @@ -55,7 +49,7 @@ check.interval.specification <- function(x) { # the intervals without using add.interval.col # nocov start rlang::abort( - message = paste("Cannot assign default value for interval column", n), + sprintf("Cannot assign default value for interval column %s", n), class = "pknca_error_interval_default_value" ) # nocov end @@ -63,21 +57,21 @@ check.interval.specification <- function(x) { } else { # Confirm the edits of the given columns if (is.vector(interval_cols[[n]]$values)) { - if (!all(x[[n]] %in% interval_cols[[n]]$values)){ + if (!all(x[[n]] %in% interval_cols[[n]]$values)) { invalid_vals <- unique(setdiff(x[[n]], interval_cols[[n]]$values)) rlang::abort( - message = sprintf( + sprintf( "Invalid value(s) in column %s:%s", n, paste(invalid_vals, collapse = ", ") ), class = "pknca_error_interval_invalid_value" ) } - + } else if (is.function(interval_cols[[n]]$values)) { if (is.factor(x[[n]])) { rlang::abort( - message = sprintf("Interval column '%s' should not be a factor", n), + sprintf("Interval column '%s' should not be a factor", n), class = "pknca_error_interval_factor_col" ) } @@ -85,7 +79,7 @@ check.interval.specification <- function(x) { } else { # nocov start rlang::abort( - message = paste("Invalid 'values' for column specification", n, "(please report this as a bug)."), + sprintf("Invalid 'values' for column specification %s (please report this as a bug).", n), class = "pknca_error_interval_invalid_col_spec" ) # nocov end @@ -96,27 +90,18 @@ check.interval.specification <- function(x) { # start and end if (anyNA(x$start)) { rlang::abort( - message = "Interval specification may not have NA for the starting time", + "Interval specification may not have NA for the starting time", class = "pknca_error_interval_na_start" ) } if (anyNA(x$end)) { - rlang::abort( - message = "Interval specification may not have NA for the end time", - class = "pknca_error_interval_na_end" - ) + rlang::abort("Interval specification may not have NA for the end time", class = "pknca_error_interval_na_end") } if (any(is.infinite(x$start))) { - rlang::abort( - message = "start may not be infinite", - class = "pknca_error_interval_infinite_start" - ) + rlang::abort("start may not be infinite", class = "pknca_error_interval_infinite_start") } if (any(x$start >= x$end)) { - rlang::abort( - message = "start must be < end", - class = "pknca_error_interval_start_gte_end" - ) + rlang::abort("start must be < end", class = "pknca_error_interval_start_gte_end") } # Confirm that something is being calculated for each interval (and warn if not) mask_calculated <- rep(FALSE, nrow(x)) @@ -127,7 +112,7 @@ check.interval.specification <- function(x) { } if (any(!mask_calculated)) { rlang::warn( - message = sprintf( + sprintf( "Nothing to be calculated in interval specification number(s): %s", paste(seq_len(nrow(x))[!mask_calculated], collapse = ", ") ), @@ -158,7 +143,7 @@ get.parameter.deps_helper_funmap <- function(x, all_intervals) { # intervals without using add.interval.col) # nocov start rlang::abort( - message = "Invalid interval definition with no function and multiple dependencies.", + "Invalid interval definition with no function and multiple dependencies.", class = "pknca_error_interval_invalid_def" ) # nocov end @@ -224,7 +209,7 @@ get.parameter.deps <- function(x) { all_intervals <- get.interval.cols() if (!(x %in% names(all_intervals))) { rlang::abort( - message = "`x` must be the name of an NCA parameter listed by the function `get.interval.cols()`", + "`x` must be the name of an NCA parameter listed by the function `get.interval.cols()`", class = "pknca_error_invalid_parameter" ) } diff --git a/R/choose.intervals.R b/R/choose.intervals.R index 7fb458af..b1372e4e 100644 --- a/R/choose.intervals.R +++ b/R/choose.intervals.R @@ -31,20 +31,14 @@ choose.auc.intervals <- function(time.conc, time.dosing, single.dose.aucs=NULL) { # Check inputs single.dose.aucs <- PKNCA.choose.option(name="single.dose.aucs", value=single.dose.aucs, options=options) - if (anyNA(time.conc)){ - rlang::abort( - message = "time.conc may not have any NA values", - class = "pknca_error_timeconc_na" - ) + if (anyNA(time.conc)) { + rlang::abort("time.conc may not have any NA values", class = "pknca_error_timeconc_na") } - - if (anyNA(time.dosing)){ - rlang::abort( - message = "time.dosing may not have any NA values", - class = "pknca_error_timedosing_na" - ) + + if (anyNA(time.dosing)) { + rlang::abort("time.dosing may not have any NA values", class = "pknca_error_timedosing_na") } - + if (length(unique(time.dosing)) == 1) { # If it is single-dose data, use the time of dosing and then offset it by # the dosing time (allowing the case where dosing time is not 0). diff --git a/R/class-PKNCAconc.R b/R/class-PKNCAconc.R index 0ca48655..c4dd5ee2 100644 --- a/R/class-PKNCAconc.R +++ b/R/class-PKNCAconc.R @@ -81,17 +81,14 @@ 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) { - rlang::abort( - message = "data must have at least one row.", - class = "pknca_error_data_no_rows" - ) + rlang::abort("data must have at least one row.", class = "pknca_error_data_no_rows") } # Verify that all the variables in the formula are columns in the data. missing_vars <- setdiff(all.vars(formula), names(data)) if (length(missing_vars) > 0) { rlang::abort( - message = paste( - "All of the variables in the formula must be in the data. Missing:", + sprintf( + "All of the variables in the formula must be in the data. Missing: %s", paste(missing_vars, collapse = ", ") ), class = "pknca_error_formula_missing_vars" @@ -117,15 +114,12 @@ PKNCAconc.data.frame <- function(data, formula, subject, groups = parsed_form_groups ) if (length(parsed_form$concentration) != 1) { - rlang::abort( - message = "The left hand side of the formula must have exactly one variable", - class = "pknca_error_formula_lhs" - ) + rlang::abort("The left hand side of the formula must have exactly one variable", class = "pknca_error_conc_formula_lhs") } if (length(parsed_form$time) != 1) { rlang::abort( - message = "The right hand side of the formula (excluding groups) must have exactly one variable", - class = "pknca_error_formula_rhs" + "The right hand side of the formula (excluding groups) must have exactly one variable", + class = "pknca_error_conc_formula_rhs" ) } @@ -137,10 +131,7 @@ PKNCAconc.data.frame <- function(data, formula, subject, # character string. checkmate::assert_string(subject, null.ok = FALSE) if (!(subject %in% names(data))) - rlang::abort( - message = "The subject parameter must map to a name in the data", - class = "pknca_error_subject_not_in_data" - ) + rlang::abort("The subject parameter must map to a name in the data", class = "pknca_error_subject_not_in_data") } parsed_form$subject <- subject if (sparse) { @@ -182,10 +173,7 @@ PKNCAconc.data.frame <- function(data, formula, subject, } else { ret <- setAttributeColumn(ret, attr_name="volume", col_or_value=volume) if (!is.numeric(getAttributeColumn(ret, attr_name="volume")[[1]])) { - rlang::abort( - message = "Volume must be numeric", - class = "pknca_error_volume_not_numeric" - ) + rlang::abort("Volume must be numeric", class = "pknca_error_volume_not_numeric") } } if (missing(duration)) { @@ -285,13 +273,13 @@ 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))){ + if (any(!(level %in% grpnames))) { rlang::abort( - message = sprintf( + sprintf( "Not all levels are listed in the group names. Missing levels are: %s", paste(setdiff(level, grpnames), collapse = ", ") ), - class = "pknca_error_missing_group_levels" + class = "pknca_error_conc_missing_group_levels" ) } grpnames <- level @@ -348,8 +336,8 @@ setDuration.PKNCAconc <- function(object, duration, ...) { # It passes the test } else { rlang::abort( - message = "duration must be numeric without missing (NA) or infinite values, and all values must be >= 0", - class = "pknca_error_invalid_duration" + "duration must be numeric without missing (NA) or infinite values, and all values must be >= 0", + class = "pknca_error_conc_invalid_duration" ) } object diff --git a/R/class-PKNCAdata.R b/R/class-PKNCAdata.R index fb485a12..14d20408 100644 --- a/R/class-PKNCAdata.R +++ b/R/class-PKNCAdata.R @@ -57,7 +57,7 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., intervals, units, options=list()) { if (length(list(...))) { rlang::abort( - message = "Unknown argument provided to PKNCAdata. All arguments other than `data.conc` and `data.dose` must be named.", + "Unknown argument provided to PKNCAdata. All arguments other than `data.conc` and `data.dose` must be named.", class = "pknca_error_unknown_argument" ) } @@ -66,7 +66,7 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., if (inherits(data.conc, "PKNCAconc")) { if (!missing(formula.conc)) { rlang::warn( - message = "data.conc was given as a PKNCAconc object. Ignoring formula.conc", + "data.conc was given as a PKNCAconc object. Ignoring formula.conc", class = "pknca_warning_dataconc_formulaconc" ) } @@ -82,7 +82,7 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., } else if (inherits(data.dose, "PKNCAdose")) { if (!missing(formula.dose)) rlang::warn( - message = "data.dose was given as a PKNCAdose object. Ignoring formula.dose", + "data.dose was given as a PKNCAdose object. Ignoring formula.dose", class = "pknca_warning_dataconc_formuladose" ) ret$dose <- data.dose @@ -94,7 +94,7 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., x = options, names = if (length(options) > 0) "named" else NULL ) - + if (length(options) > 0) { checkmate::assert_named(options) for (n in names(options)) { @@ -110,16 +110,13 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., # Check the intervals 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" - ) + rlang::abort("If data.dose is not given, intervals must be given", class = "pknca_error_missing_intervals") } else if (missing(intervals)) { # Generate the intervals for each grouping of concentration and # dosing. if (length(ret$dose$columns$time) == 0) { rlang::abort( - message = "Dose times were not given, so intervals must be manually specified.", + "Dose times were not given, so intervals must be manually specified.", class = "pknca_error_missing_dose_times" ) } @@ -158,7 +155,7 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., n_conc_dose$data_intervals[[idx]] <- generated_intervals } else { rlang::warn( - message = sprintf( + sprintf( "%sNo intervals generated likely due to limited concentration data", warning_prefix ), @@ -167,7 +164,7 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., } } else { rlang::warn( - message = sprintf( + sprintf( "%sNo intervals generated due to no concentration data", warning_prefix ), @@ -194,15 +191,15 @@ PKNCAdata.default <- function(data.conc, data.dose, ..., } else { 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'", + "`units` data.frame must have at least names 'PPTESTCD' and 'PPORRESU'", class = "pknca_error_units_missing_cols" ) } - + checkmate::assert_data_frame(units, min.rows = 1) ret$units <- units diff --git a/R/class-PKNCAdose.R b/R/class-PKNCAdose.R index 9d926065..af7bf7d2 100644 --- a/R/class-PKNCAdose.R +++ b/R/class-PKNCAdose.R @@ -70,7 +70,7 @@ PKNCAdose.data.frame <- function(data, formula, route, rate, duration, if (!missing(time.nominal)) { if (!(time.nominal %in% names(data))) { rlang::abort( - message = "time.nominal, if given, must be a column name in the input data.", + "time.nominal, if given, must be a column name in the input data.", class = "pknca_error_timenominal_not_in_data" ) } @@ -78,10 +78,7 @@ PKNCAdose.data.frame <- function(data, formula, route, rate, duration, # 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) { - rlang::abort( - message = "formula for PKNCAdose may not include a slash", - class = "pknca_error_formula_slash" - ) + rlang::abort("formula for PKNCAdose may not include a slash", class = "pknca_error_formula_slash") } parsed_form_groups <- if (length(parsed_form_raw$groups) > 0) { @@ -103,35 +100,29 @@ PKNCAdose.data.frame <- function(data, formula, route, rate, duration, ) # Check for variable existence and length if (!(length(parsed_form$dose) %in% c(0, 1))) { - rlang::abort( - message = "The left side of the formula must have zero or one variable", - class = "pknca_error_formula_lhs" - ) + rlang::abort("The left side of the formula must have zero or one variable", class = "pknca_error_dose_formula_lhs") } else if (length(parsed_form$dose) == 1 && !(parsed_form$dose %in% names(data))) { # the "." is handled in parse_formula_to_cols rlang::abort( - message = "The left side formula must be a variable in the data, empty, or '.'.", + "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))) { rlang::abort( - message = "The right side of the formula (excluding groups) must have exactly one variable", - class = "pknca_error_formula_rhs" + "The right side of the formula (excluding groups) must have exactly one variable", + class = "pknca_error_dose_formula_rhs" ) } else if (length(parsed_form$time) == 1 && !(parsed_form$time %in% names(data))) { rlang::abort( - message = "The right side formula must be a variable in the data or '.'.", + "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))) { - rlang::abort( - message = "All of the variables in the groups must be in the data", - class = "pknca_error_groups_not_in_data" - ) + rlang::abort("All of the variables in the groups must be in the data", class = "pknca_error_groups_not_in_data") } ret <- list( @@ -153,7 +144,7 @@ PKNCAdose.data.frame <- function(data, formula, route, rate, duration, mask.indep <- is.na(getIndepVar.PKNCAdose(ret)) & !is_excluded if (any(mask.indep) && !all(is.na(getIndepVar.PKNCAdose(ret)[!is_excluded]))) { 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.", + "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" ) } @@ -213,7 +204,7 @@ setRoute.PKNCAdose <- function(object, route, ...) { if (!all(tolower(getAttributeColumn(object=object, attr_name="route")[[1]]) %in% c("extravascular", "intravascular"))) { rlang::abort( - message = "route must have values of either 'extravascular' or 'intravascular'. Please set to one of those values and retry.", + "route must have values of either 'extravascular' or 'intravascular'. Please set to one of those values and retry.", class = "pknca_error_invalid_route" ) } @@ -243,10 +234,7 @@ setDuration.PKNCAdose <- function(object, duration, rate, dose, ...) { message_if_default="Assuming instant dosing (duration=0)") } 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" - ) + rlang::abort("Both duration and rate cannot be given at the same time", class = "pknca_error_duration_and_rate") # TODO: A consistency check could be done, but that would get into # requiring near-equal checks for floating point error. } else if (!missing(duration)) { @@ -265,8 +253,8 @@ setDuration.PKNCAdose <- function(object, duration, rate, dose, ...) { # It passes } else { rlang::abort( - message = "duration must be numeric without missing (NA) or infinite values, and all values must be >= 0", - class = "pknca_error_invalid_duration" + "duration must be numeric without missing (NA) or infinite values, and all values must be >= 0", + class = "pknca_error_dose_invalid_duration" ) } object diff --git a/R/class-PKNCAresults.R b/R/class-PKNCAresults.R index d89de2ee..501510f8 100644 --- a/R/class-PKNCAresults.R +++ b/R/class-PKNCAresults.R @@ -63,7 +63,7 @@ as.data.frame.PKNCAresults <- function(x, ..., out_format = c('long', 'wide', 'c } # nocov end out_format <- match.arg(out_format) - + if (filter_requested) { intervals_long <- tidyr::pivot_longer( @@ -80,7 +80,7 @@ as.data.frame.PKNCAresults <- function(x, ..., out_format = c('long', 'wide', 'c by = intersect(names(ret), names(intervals_long_filtered)) ) } - + if (out_format %in% 'cdisc') { ret <- pknca_cdisc_translate(ret, x) } else if (out_format %in% 'wide') { @@ -382,11 +382,11 @@ getGroups.PKNCAresults <- function(object, level <- as.character(level) if (any(!(level %in% grpnames))) { rlang::abort( - message = sprintf( + sprintf( "Not all levels are listed in the group names. Missing levels are: %s", paste(setdiff(level, grpnames), collapse = ", ") ), - class = "pknca_error_missing_group_levels" + class = "pknca_error_results_missing_group_levels" ) } grpnames <- level diff --git a/R/class-general.R b/R/class-general.R index 6f2ec51a..a7d38834 100644 --- a/R/class-general.R +++ b/R/class-general.R @@ -48,7 +48,7 @@ getColumnValueOrNot <- function(data, value, prefix="X") { ret <- list(data=data, name=col.name) } else { rlang::abort( - message = "value was not a column name nor was it a scalar or a vector matching the length of the data.", + "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" ) } @@ -96,15 +96,12 @@ 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)) { - rlang::abort( - message = "attr_name must be a character scalar.", - class = "pknca_error_invalid_attr_name" - ) + rlang::abort("attr_name must be a character scalar.", class = "pknca_error_invalid_attr_name") } if (!missing(col_or_value) && any(!c(missing(col_name), missing(default_value)))) { rlang::abort( - message = "Cannot provide col_or_value and col_name or default_value", + "Cannot provide col_or_value and col_name or default_value", class = "pknca_error_conflicting_column_args" ) } @@ -121,15 +118,12 @@ setAttributeColumn <- function(object, attr_name, col_or_value, col_name, defaul col_name <- attr_name if (attr_name %in% names(object[[dataname]])) { rlang::inform( - message = paste0("Found column named ", attr_name, ", using it for the attribute of the same name."), + sprintf("Found column named %s, using it for the attribute of the same name.", attr_name), class = paste0("pknca_message_foundcolumn_", attr_name) ) } } else if (!is.character(col_name) || (length(col_name) != 1)) { - rlang::abort( - message = "col_name must be a character scalar.", - class = "pknca_error_invalid_col_name" - ) + rlang::abort("col_name must be a character scalar.", class = "pknca_error_invalid_col_name") } # Set the default value if (missing(default_value)) { @@ -140,17 +134,17 @@ setAttributeColumn <- function(object, attr_name, col_or_value, col_name, defaul # React to using the default value, if requested if (!missing(stop_if_default)) { rlang::abort( - message = stop_if_default, + stop_if_default, class = "pknca_error_used_default_value" ) } else if (!missing(warn_if_default)) { rlang::warn( - message = warn_if_default, + warn_if_default, class = "pknca_warning_used_default_value" ) } else if (!missing(message_if_default)) { rlang::inform( - message = message_if_default, + message_if_default, class = "pknca_message_used_default_value" ) } @@ -159,7 +153,7 @@ setAttributeColumn <- function(object, attr_name, col_or_value, col_name, defaul # Check that the default_value can work if (!(length(default_value) %in% c(1, nrow(object[[dataname]])))) { rlang::abort( - message = "default_value must be a scalar or the same length as the rows in the data.", + "default_value must be a scalar or the same length as the rows in the data.", class = "pknca_error_invalid_default_value" ) } @@ -182,10 +176,7 @@ 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")))) { - rlang::abort( - message = "warn_missing must have a valid value or be empty", - class = "pknca_error_invalid_warn_missing" - ) + rlang::abort("warn_missing must have a valid value or be empty", class = "pknca_error_invalid_warn_missing") } warn_missing <- warn_missing[warn_missing %in% c("attr", "column")] columns <- object$columns[[attr_name]] @@ -193,14 +184,14 @@ getAttributeColumn <- function(object, attr_name, warn_missing=c("attr", "column if (is.null(columns)) { if ("attr" %in% warn_missing) rlang::warn( - message = paste0(attr_name, " is not set."), + sprintf("%s is not set.", attr_name), class = "pknca_warning_attr_not_set" ) NULL } else if (length(missing_cols <- setdiff(columns, names(object[[dataname]])))) { if ("column" %in% warn_missing) rlang::warn( - message = paste("Columns", paste(missing_cols, collapse = ", "), "are not present."), + sprintf("Columns %s are not present.", paste(missing_cols, collapse = ", ")), class = "pknca_warning_cols_not_present" ) NULL @@ -232,10 +223,10 @@ duplicate_check <- function(object, data_type) { } if (any(mask_dup)) { rlang::abort( - message = paste0( - "Rows that are not unique per group and time (column names: ", + sprintf( + "Rows that are not unique per group and time (column names: %s) found within %s data. Row numbers: %s", paste(key_cols, collapse = ", "), - ") found within ", data_type, " data. Row numbers: ", + data_type, paste(which(mask_dup), collapse = ", ") ), class = "pknca_error_duplicate_rows" @@ -276,7 +267,7 @@ pknca_set_units <- function(object, units_orig = list(), units_pref = list()) { } else { # nocov start rlang::abort( - message = paste("Please report a bug. Unit setting for", col_units), + sprintf("Please report a bug. Unit setting for %s", col_units), class = "pknca_error_internal_unit_setting_bug" ) # nocov end @@ -291,7 +282,7 @@ pknca_set_units <- function(object, units_orig = list(), units_pref = list()) { original_unit_col <- gsub(x = pref_units, pattern = "_pref", replacement = "") if (!(original_unit_col %in% c(names(object$columns), names(object$units)))) { rlang::abort( - message = paste("Preferred units may not be set unless original units are set:", pref_units), + sprintf("Preferred units may not be set unless original units are set: %s", pref_units), class = "pknca_error_pref_units_without_orig" ) } @@ -299,7 +290,7 @@ pknca_set_units <- function(object, units_orig = list(), units_pref = list()) { } else { # nocov start rlang::abort( - message = paste("Please report a bug. Preferred unit setting for", pref_units), + sprintf("Please report a bug. Preferred unit setting for %s", pref_units), class = "pknca_error_internal_pref_unit_setting_bug" ) # nocov end diff --git a/R/class-summary_PKNCAresults.R b/R/class-summary_PKNCAresults.R index fbb026f0..00b61f89 100644 --- a/R/class-summary_PKNCAresults.R +++ b/R/class-summary_PKNCAresults.R @@ -110,9 +110,9 @@ summary.PKNCAresults <- function(object, ..., summarize_n <- has_subject_col } else if (summarize_n && !has_subject_col) { rlang::warn( - message = "summarize_n was requested, but no subject column exists", + "summarize_n was requested, but no subject column exists", class = "pknca_warning_summarize_n_no_subject" - ) + ) summarize_n <- FALSE } @@ -201,7 +201,7 @@ get_summary_PKNCAresults_drop_group <- function(object, drop_group) { all_group_cols <- getGroups(object) if (any(c("start", "end") %in% drop_group)) { rlang::warn( - message = "drop.group including start or end may result in incorrect groupings (such as inaccurate comparison of intervals). Drop these with care.", + "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" ) } @@ -293,7 +293,7 @@ get_summary_PKNCAresults_count_N <- function(data, result_group, subject_col, su if (anyNA(ret$N)) { # nocov start rlang::abort( - message = "Please report a bug. If N is requested, but it is not provided, then it should be set to not calculated.", + "Please report a bug. If N is requested, but it is not provided, then it should be set to not calculated.", class = "pknca_error_internal_n_is_na" ) # nocov end @@ -396,7 +396,7 @@ summarize_PKNCAresults_group <- function(data, current_group, subject_col, resul # I don't think that a user can get here # nocov start rlang::warn( - message = "No results to summarize for result row, please report a bug", + "No results to summarize for result row, please report a bug", class = "pknca_warning_no_results_to_summarize" ) return(ret) @@ -456,7 +456,7 @@ summarize_PKNCAresults_parameter <- function(data, parameter, subject_col, inclu units <- unique(current_data[[unit_col]]) if (length(units) > 1) { rlang::abort( - message = sprintf( + sprintf( "Multiple units cannot be summarized together. For %s, trying to combine: %s", parameter, paste(units, collapse = ", ") @@ -470,7 +470,7 @@ summarize_PKNCAresults_parameter <- function(data, parameter, subject_col, inclu N <- length(unique(current_data[[subject_col]])) if (any(duplicated(current_data[[subject_col]]))) { rlang::warn( - message = sprintf( + sprintf( "Some subjects may have more than one result for %s", parameter ), @@ -486,7 +486,7 @@ summarize_PKNCAresults_parameter <- function(data, parameter, subject_col, inclu if (is.null(current_summary_instructions)) { # nocov start rlang::abort( - message = sprintf( + sprintf( "No summary function is set for parameter %s. Please set it with PKNCA.set.summary and report this as a bug in PKNCA.", parameter ), @@ -612,7 +612,7 @@ roundingSummarize <- function(x, name) { summary_instructions <- PKNCA.set.summary() if (!(name %in% names(summary_instructions))) { rlang::abort( - message = sprintf( + sprintf( "%s is not in the summarization instructions from PKNCA.set.summary", name ), @@ -626,7 +626,7 @@ roundingSummarize <- function(x, name) { if (length(roundingInstructions) != 1) { # nocov start rlang::abort( - message = sprintf( + sprintf( "Cannot interpret rounding instructions for %s (please report this as a bug)", name ), @@ -641,7 +641,7 @@ roundingSummarize <- function(x, name) { } else { # nocov start rlang::abort( - message = sprintf( + sprintf( "Invalid rounding instruction list name for %s (please report this as a bug)", name ), diff --git a/R/cleaners.R b/R/cleaners.R index 21d4a368..fd7d7d4d 100644 --- a/R/cleaners.R +++ b/R/cleaners.R @@ -30,12 +30,7 @@ clean.conc.na <- function(conc, time, ..., } else { # This case should already have been captured by the PKNCA.options # call above. - # nocov start - rlang::abort( - message = "Unknown how to handle conc.na", - class = "pknca_error_unknown_conc_na" - ) - # nocov end + rlang::abort("Unknown how to handle conc.na", class = "pknca_error_unknown_conc_na") # nocov } ret } @@ -139,7 +134,7 @@ clean.conc.blq <- function(conc, time, } else { # nocov start rlang::abort( - message = "There is a bug in cleaning the conc.blq with position names", + "There is a bug in cleaning the conc.blq with position names", class = "pknca_error_conc_blq_position_bug" ) # nocov end @@ -158,7 +153,7 @@ clean.conc.blq <- function(conc, time, # call above. # nocov start rlang::abort( - message = sprintf( + sprintf( "Unknown how to handle conc.blq rule %s", as.character(this_rule) ), diff --git a/R/exclude.R b/R/exclude.R index de800930..e60e2702 100644 --- a/R/exclude.R +++ b/R/exclude.R @@ -73,31 +73,19 @@ exclude.default <- function(object, reason, mask, FUN) { mask <- !is.na(reason) } } else if (!xor(missing(mask), missing(FUN))) { - rlang::abort( - message = "Either mask or FUN must be given (but not both).", - class = "pknca_error_mask_or_fun" - ) + rlang::abort("Either mask or FUN must be given (but not both).", class = "pknca_error_mask_or_fun") } if (!(length(reason) %in% c(1, nrow(object[[dataname]])))) { - rlang::abort( - message = "reason must be a scalar or have the same length as the data.", - class = "pknca_error_reason_length" - ) + rlang::abort("reason must be a scalar or have the same length as the data.", class = "pknca_error_reason_length") } else if (!is.character(reason)) { - rlang::abort( - message = "reason must be a character vector.", - class = "pknca_error_reason_type" - ) + rlang::abort("reason must be a character vector.", class = "pknca_error_reason_type") } - + if (!("exclude" %in% names(object$columns))) { - rlang::abort( - message = "object must have an exclude column specified.", - class = "pknca_error_no_exclude_col" - ) + rlang::abort("object must have an exclude column specified.", class = "pknca_error_no_exclude_col") } else if (!(object$columns$exclude %in% names(object[[dataname]]))) { rlang::abort( - message = sprintf( + sprintf( "exclude column must exist in object[['%s']].", dataname ), @@ -110,10 +98,7 @@ exclude.default <- function(object, reason, mask, FUN) { # Find the original value of the 'exclude' column. orig <- object[[dataname]][[object$columns$exclude]] if (length(mask) != length(orig)) { - rlang::abort( - message = "mask must match the length of the data.", - class = "pknca_error_mask_length" - ) + rlang::abort("mask must match the length of the data.", class = "pknca_error_mask_length") } # No current value for exclude mask.none <- orig %in% c(NA, "") @@ -155,10 +140,7 @@ setExcludeColumn <- function(object, exclude = NULL, dataname = "data") { # If exclude is already in the object, then make sure it matches # (and do nothing). if (!(object$columns$exclude == exclude)) { - rlang::abort( - message = "exclude is already set for the object.", - class = "pknca_error_exclude_already_set" - ) + rlang::abort("exclude is already set for the object.", class = "pknca_error_exclude_already_set") } } else { # If exclude is not already in the object and it is given, then add @@ -176,7 +158,7 @@ setExcludeColumn <- function(object, exclude = NULL, dataname = "data") { object[[dataname]][[exclude]] <- rep(NA_character_, nrow(object[[dataname]])) } else if (!(exclude %in% names(object[[dataname]]))) { rlang::abort( - message = "exclude, if given, must be a column name in the input data.", + "exclude, if given, must be a column name in the input data.", class = "pknca_error_exclude_not_in_data" ) } else { @@ -187,7 +169,7 @@ setExcludeColumn <- function(object, exclude = NULL, dataname = "data") { object[[dataname]][[exclude]] <- rep(NA_character_, nrow(object[[dataname]])) } else if (!is.character(object[[dataname]][[exclude]])) { rlang::abort( - message = "exclude column must be character vector or something convertable to character without loss of information.", + "exclude column must be character vector or something convertable to character without loss of information.", class = "pknca_error_exclude_not_character" ) } diff --git a/R/exclude_nca.R b/R/exclude_nca.R index 5e696593..788382a9 100644 --- a/R/exclude_nca.R +++ b/R/exclude_nca.R @@ -220,10 +220,7 @@ exclude_nca_by_param <- function( checkmate::expect_number(max_thr, finite = TRUE, null.ok = TRUE) 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" - ) + rlang::abort("if both defined min_thr must be less than max_thr", class = "pknca_error_min_thr_gt_max_thr") } function(x, ...) { @@ -231,9 +228,9 @@ exclude_nca_by_param <- function( idx_param <- which(x$PPTESTCD == parameter) idx_aff_params <- which(x$PPTESTCD %in% affected_parameters) - if (length(idx_param) > 1){ + if (length(idx_param) > 1) { rlang::abort( - message = sprintf( + sprintf( "Should not see more than one %s (please report this as a bug)", parameter ), diff --git a/R/general.functions.R b/R/general.functions.R index a3eb74cd..1f6168e7 100644 --- a/R/general.functions.R +++ b/R/general.functions.R @@ -13,7 +13,7 @@ check.conversion <- function(x, FUN, ...) { # FIXME: It would be nice to have it give the function name as # part of the error rlang::abort( - message = sprintf("%g new NA value(s) created during conversion", new.na), + sprintf("%g new NA value(s) created during conversion", new.na), class = "pknca_error_new_na_conversion" ) ret @@ -81,10 +81,7 @@ roundString <- function(x, digits=0, sci_range=Inf, sci_sep="e", si_range) { } else if (length(x) == length(digits)) { mapply(roundString, x, digits=digits, sci_range=sci_range, sci_sep=sci_sep) } else { - rlang::abort( - message = "digits must either be a scalar or the same length as x", - class = "pknca_error_digits_length" - ) + rlang::abort("digits must either be a scalar or the same length as x", class = "pknca_error_digits_length") } } @@ -132,10 +129,7 @@ signifString.data.frame <- function(x, ...) { #' @export signifString.default <- function(x, digits=6, sci_range=6, sci_sep="e", si_range, ...) { if (length(list(...))) { - rlang::abort( - message = "Additional, unsupported arguments were passed", - class = "pknca_error_unsupported_args" - ) + rlang::abort("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 56a98e46..04f10862 100644 --- a/R/half.life.R +++ b/R/half.life.R @@ -156,10 +156,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, tobit_optim_control <- PKNCA.choose.option(name="tobit_optim_control", value=tobit_optim_control, options=options) if (is.null(lloq)) { - rlang::abort( - message = "lloq must be provided when hl_method is 'tobit'", - class = "pknca_error_lloq_required_tobit" - ) + rlang::abort("lloq must be provided when hl_method is 'tobit'", class = "pknca_error_lloq_required_tobit") } } @@ -283,7 +280,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, } } else { rlang::warn( - message = "No data to manually fit for half-life (all concentrations may be 0 or excluded)", + "No data to manually fit for half-life (all concentrations may be 0 or excluded)", class = "pknca_warning_no_halflife_data" ) ret <- structure( @@ -322,10 +319,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, mask_best <- half_lives_for_selection$lambda.z > 0 & if (min.hl.points == 2 && nrow(half_lives_for_selection) == 2) { - rlang::warn( - message = "2 points used for half-life calculation", - class = "pknca_warning_halflife_2points" - ) + rlang::warn("2 points used for half-life calculation", class = "pknca_warning_halflife_2points") TRUE } else { half_lives_for_selection$adj.r.squared > @@ -348,7 +342,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, min.hl.points, nrow(dfK) ) rlang::warn( - message = attr(ret, "exclude"), + attr(ret, "exclude"), class = "pknca_warning_halflife_too_few_points" ) } @@ -383,8 +377,8 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, } } else { rlang::warn( - message = "No data to manually fit for half-life (all concentrations may be 0 or excluded)", - class = "pknca_warning_no_halflife_data" + "No data to manually fit for half-life (all concentrations may be 0 or excluded)", + class = "pknca_warning_no_halflife_data_tobit" ) ret <- structure( ret, @@ -435,8 +429,8 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, min.hl.points, n_above_lloq ) rlang::warn( - message = attr(ret, "exclude"), - class = "pknca_warning_halflife_too_few_points" + attr(ret, "exclude"), + class = "pknca_warning_halflife_too_few_points_tobit" ) } } @@ -556,7 +550,7 @@ fit_half_life_tobit <- function(data, tlast, optim_control = list()) { # Guard: need at least 2 above-LLOQ points for initial parameter estimation if (length(above_lloq_log_conc) < 2) { rlang::warn( - message = "Too few above-LLOQ points for Tobit half-life initial parameter estimation", + "Too few above-LLOQ points for Tobit half-life initial parameter estimation", class = "pknca_warning_tobit_too_few_points" ) return(na_ret) @@ -565,7 +559,7 @@ fit_half_life_tobit <- function(data, tlast, optim_control = list()) { sd_above <- stats::sd(above_lloq_log_conc) if (!is.finite(sd_above) || sd_above == 0) { rlang::warn( - message = "No variability in above-LLOQ concentrations for Tobit half-life fit", + "No variability in above-LLOQ concentrations for Tobit half-life fit", class = "pknca_warning_tobit_no_variability" ) return(na_ret) @@ -595,9 +589,7 @@ fit_half_life_tobit <- function(data, tlast, optim_control = list()) { # code 0 = converged; any other code = failure if (fit$convergence != 0) { rlang::warn( - message = paste0( - "Tobit half-life optimization did not converge (code ", fit$convergence, ")" - ), + sprintf("Tobit half-life optimization did not converge (code %s)", fit$convergence), class = "pknca_warning_tobit_no_convergence" ) return(na_ret) @@ -873,7 +865,7 @@ get_halflife_points.PKNCAresults <- function(object) { ) if (any(!is.na(ret[ret_current$rowid]))) { rlang::abort( - message = sprintf( + sprintf( "More than one half-life calculation was attempted on the following rows: %s", paste(ret_current$rowid, collapse = ", ") ), diff --git a/R/impute.R b/R/impute.R index e29c8d1b..44364a59 100644 --- a/R/impute.R +++ b/R/impute.R @@ -127,7 +127,7 @@ PKNCA_impute_fun_list <- function(x) { } if (length(bad_fun) > 0) { rlang::abort( - message = sprintf( + sprintf( "The following imputation functions were not found: %s", paste(bad_fun, collapse = ", ") ), diff --git a/R/interpolate.conc.R b/R/interpolate.conc.R index 43746068..aea15f05 100644 --- a/R/interpolate.conc.R +++ b/R/interpolate.conc.R @@ -103,10 +103,7 @@ interp.extrap.conc <- function(conc, time, time.out, data <- data.frame(conc, time) } if (length(time.out) < 1) { - rlang::abort( - message = "time.out must be a vector with at least one element", - class = "pknca_error_timeout_empty" - ) + rlang::abort("time.out must be a vector with at least one element", class = "pknca_error_timeout_empty") } if (all(data$conc %in% 0)) { # tlast would be NA in this case, but if everything input is zero, then all @@ -119,15 +116,12 @@ interp.extrap.conc <- function(conc, time, time.out, if (is.na(tlast)) { # nocov start rlang::abort( - message = "Please report a bug: tlast is NA; cannot interpolate/extrapolate", + "Please report a bug: tlast is NA; cannot interpolate/extrapolate", class = "pknca_error_internal_tlast_na" ) # nocov end } else if (is.na(time.out[i])) { - rlang::warn( - message = "An interpolation/extrapolation time is NA", - class = "pknca_warning_timeout_na" - ) + rlang::warn("An interpolation/extrapolation time is NA", class = "pknca_warning_timeout_na") } else if (time.out[i] <= tlast) { ret[i] <- interpolate.conc( @@ -190,7 +184,7 @@ interpolate.conc <- function(conc, time, time.out, checkmate::assert_number(x=time.out, na.ok=FALSE) if (time.out > max(data$time)) { rlang::abort( - message = "`interpolate.conc()` does not extrapolate, use `interp.extrap.conc()`", + "`interpolate.conc()` does not extrapolate, use `interp.extrap.conc()`", class = "pknca_error_interpolate_beyond_maxtime" ) } @@ -203,9 +197,9 @@ interpolate.conc <- function(conc, time, time.out, ret <- 0 } else if (time.out > tlast) { rlang::abort( - message = "`interpolate.conc()` only works through Tlast, please use `interp.extrap.conc()` to combine both interpolation and extrapolation.", + "`interpolate.conc()` only works through Tlast, please use `interp.extrap.conc()` to combine both interpolation and extrapolation.", class = "pknca_error_interpolate_beyond_tlast" - ) + ) } else if (time.out %in% data$time) { # See if there is an exact time match and return that if it # exists. @@ -237,12 +231,7 @@ interpolate.conc <- function(conc, time, time.out, } else if (interp_method == "zero") { 0 } else { - # nocov start - rlang::abort( - message = "Please report a bug: invalid interp_method", - class = "pknca_error_internal_invalid_interp_method" - ) - # nocov end + rlang::abort("Please report a bug: invalid interp_method", class = "pknca_error_internal_invalid_interp_method") # nocov } } ret @@ -277,22 +266,16 @@ extrapolate.conc <- function(conc, time, time.out, } auc.type <- tolower(auc.type) if (!(auc.type %in% c("aucinf", "aucall", "auclast"))) - rlang::abort( - message = "`auc.type` must be one of 'AUCinf', 'AUClast', or 'AUCall'", - class = "pknca_error_invalid_auc_type" - ) + rlang::abort("`auc.type` must be one of 'AUCinf', 'AUClast', or 'AUCall'", class = "pknca_error_invalid_auc_type") if (length(time.out) != 1) - rlang::abort( - message = "Only one time.out value may be estimated at once.", - class = "pknca_error_timeout_length" - ) + rlang::abort("Only one time.out value may be estimated at once.", class = "pknca_error_timeout_length") tlast <- pk.calc.tlast(conc=data$conc, time=data$time, check=FALSE) if (is.na(tlast)) { # If there are no observed concentrations, return NA ret <- NA } else if (time.out <= tlast) { rlang::abort( - message = "extrapolate.conc can only work beyond Tlast, please use interp.extrap.conc to combine both interpolation and extrapolation.", + "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 { @@ -335,7 +318,7 @@ extrapolate.conc <- function(conc, time, time.out, } else { # nocov start rlang::abort( - message = "Invalid auc.type caught too late (seeing this error indicates a software bug)", + "Invalid auc.type caught too late (seeing this error indicates a software bug)", class = "pknca_error_invalid_auc_type_late" ) # nocov end @@ -385,25 +368,22 @@ interp.extrap.conc.dose <- function(conc, time, } if (!(all(route.dose %in% c("extravascular", "intravascular")))) { rlang::abort( - message = "route.dose must be either 'extravascular' or 'intravascular'", + "route.dose must be either 'extravascular' or 'intravascular'", class = "pknca_error_invalid_route_dose" ) } if (!(length(route.dose) %in% c(1, length(time.dose)))) { rlang::abort( - message = "route.dose must either be a scalar or the same length as time.dose", + "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)))) { - rlang::abort( - message = "duration.dose must be NA or a number.", - class = "pknca_error_invalid_duration_dose" - ) + rlang::abort("duration.dose must be NA or a number.", class = "pknca_error_invalid_duration_dose") } if (!(length(duration.dose) %in% c(1, length(time.dose)))) { rlang::abort( - message = "duration.dose must either be a scalar or the same length as time.dose", + "duration.dose must either be a scalar or the same length as time.dose", class = "pknca_error_duration_dose_length" ) } @@ -454,7 +434,7 @@ interp.extrap.conc.dose <- function(conc, time, # All events should be accounted for already # nocov start rlang::abort( - message = sprintf( + sprintf( "Unknown event in interp.extrap.conc.dose at time(s): %s (Please report this as a bug)", paste(unique(data_all$time[mask_unknown]), collapse = ", ") ), @@ -482,7 +462,7 @@ interp.extrap.conc.dose <- function(conc, time, if (any(mask)) { if ("warning" %in% names(interp.extrap.conc.dose.select[[nm]])) { rlang::warn( - message = sprintf( + sprintf( "%s: %d data points", interp.extrap.conc.dose.select[[nm]]$warning, sum(mask) @@ -507,7 +487,7 @@ interp.extrap.conc.dose <- function(conc, time, # This should never happen, all eventualities should be covered # nocov start rlang::abort( - message = sprintf( + sprintf( "No method for imputing concentration at time(s): %s", paste(unique(data_all$time[mask_no_method]), collapse = ", ") ), @@ -543,7 +523,7 @@ iecd_impossible_select <- function(x) { iecd_impossible_value <- function(data_all, current_idx, ...) { # nocov start rlang::abort( - message = sprintf( + sprintf( "Impossible combination requested for interp.extrap.conc.dose (please report this as a bug). event_before: %s, event: %s, event_after: %s", data_all$event_before[current_idx], data_all$event[current_idx], diff --git a/R/normalize.R b/R/normalize.R index 9d8a2f07..396585e5 100644 --- a/R/normalize.R +++ b/R/normalize.R @@ -39,7 +39,7 @@ normalize.data.frame <- function(object, norm_table, parameters, suffix) { sep = "\n" ) rlang::abort( - message = sprintf( + sprintf( "The normalization table contains groups not present in the data:\n%s", df_error_string ), @@ -50,7 +50,7 @@ normalize.data.frame <- function(object, norm_table, parameters, suffix) { # Check for duplicate groups if (any(duplicated(norm_table[, common_colnames, drop = FALSE]))) { rlang::abort( - message = "The normalization table contains duplicate groups.", + "The normalization table contains duplicate groups.", class = "pknca_error_norm_table_duplicate_groups" ) } @@ -59,7 +59,7 @@ normalize.data.frame <- function(object, norm_table, parameters, suffix) { # Ungrouped case if (nrow(norm_table) != 1) { rlang::abort( - message = "Normalization table must be a single row for ungrouped data.", + "Normalization table must be a single row for ungrouped data.", class = "pknca_error_norm_table_not_single_row" ) } @@ -118,7 +118,7 @@ normalize_by_col <- function(object, col, unit, parameters, suffix){ obj_conc_cols <- names(as.data.frame(as_PKNCAconc(object))) if (!col %in% obj_conc_cols) { rlang::abort( - message = sprintf( + sprintf( "Column %s not found in the PKNCAconc of the PKNCAresults object", col ), @@ -138,7 +138,7 @@ 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]))) { rlang::abort( - message = "There is at least one concentration group with multiple normalization values", + "There is at least one concentration group with multiple normalization values", class = "pknca_error_norm_multiple_values" ) } diff --git a/R/parse_formula_to_cols.R b/R/parse_formula_to_cols.R index 791b4963..41cab253 100644 --- a/R/parse_formula_to_cols.R +++ b/R/parse_formula_to_cols.R @@ -27,7 +27,7 @@ findOperator <- function(x, op, side) { if (length(x) == 1) { # nocov start rlang::abort( - message = "call or formula with length 1 found after finding the operator, unknown how to proceed", + "call or formula with length 1 found after finding the operator, unknown how to proceed", class = "pknca_error_formula_length1_after_op" ) # nocov end @@ -40,12 +40,7 @@ findOperator <- function(x, op, side) { } else if (side == "both") { return(x) } - # nocov start - rlang::abort( - message = "Unknown side with a found unary operator", - class = "pknca_error_unknown_side_unary" - ) - # nocov end + rlang::abort("Unknown side with a found unary operator", class = "pknca_error_unknown_side_unary") # nocov } else if (length(x) == 3) { # Binary operator if (side == "left") { @@ -55,18 +50,13 @@ findOperator <- function(x, op, side) { } else if (side == "both") { return(x) } - # nocov start - rlang::abort( - message = "Unknown side with a found binary operator", - class = "pknca_error_unknown_side_binary" - ) - # nocov end + rlang::abort("Unknown side with a found binary operator", class = "pknca_error_unknown_side_binary") # nocov } } else { # Go down the left then right side of the tree if (length(x) == 1) rlang::abort( - message = "call or formula with length 1 found without finding the operator, unknown how to proceed", + "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 @@ -79,7 +69,7 @@ findOperator <- function(x, op, side) { } else { # This should not happen-- find the class that the object is rlang::abort( - message = sprintf("Cannot handle class %s", paste(class(x), collapse = ", ")), + sprintf("Cannot handle class %s", paste(class(x), collapse = ", ")), class = "pknca_error_unhandled_class" ) } @@ -98,10 +88,7 @@ parse_formula_to_cols <- function(form) { form <- try({stats::as.formula(form)}, silent = TRUE) } if (!inherits(form, "formula")) { - rlang::abort( - message = "form must be a formula or coercable into one", - class = "pknca_error_form_not_formula" - ) + rlang::abort("form must be a formula or coercable into one", class = "pknca_error_form_not_formula") } rhs_raw <- findOperator(form, "~", "right") groups_raw <- findOperator(rhs_raw, "|", "right") diff --git a/R/pk.calc.all.R b/R/pk.calc.all.R index 27ac753a..bad5e0cb 100644 --- a/R/pk.calc.all.R +++ b/R/pk.calc.all.R @@ -20,12 +20,9 @@ pk.nca <- function(data, verbose=FALSE) { assert_PKNCAdata(data) results <- data.frame() if (nrow(data$intervals) > 0) { - if (verbose){ - rlang::inform( - message = "Setting up options", - class = "pknca_message_setup_options" - ) - } + if (verbose) { + rlang::inform("Setting up options", class = "pknca_message_setup_options") + } # Merge the options into the default options. tmp_options <- PKNCA.options() tmp_options[names(data$options)] <- data$options @@ -38,11 +35,8 @@ pk.nca <- function(data, verbose=FALSE) { drop=FALSE ] # Calculate the results - if (verbose){ - rlang::inform( - message = "Starting dense PK NCA calculations.", - class = "pknca_message_dense_pk_start" - ) + if (verbose) { + rlang::inform("Starting dense PK NCA calculations.", class = "pknca_message_dense_pk_start") } results_dense <- purrr::pmap( @@ -58,19 +52,13 @@ pk.nca <- function(data, verbose=FALSE) { sparse = FALSE, .progress = data$options$progress ) - if (verbose){ - rlang::inform( - message = "Combining completed dense PK calculation results.", - class = "pknca_message_dense_pk_combine" - ) + if (verbose) { + rlang::inform("Combining completed dense PK calculation results.", class = "pknca_message_dense_pk_combine") } results <- pk_nca_result_to_df(group_info, results_dense) if (is_sparse_pk(data)) { - if (verbose){ - rlang::inform( - message = "Starting sparse PK NCA calculations.", - class = "pknca_message_sparse_pk_start" - ) + if (verbose) { + rlang::inform("Starting sparse PK NCA calculations.", class = "pknca_message_sparse_pk_start") } results_sparse <- purrr::pmap( @@ -85,11 +73,8 @@ pk.nca <- function(data, verbose=FALSE) { verbose=verbose, sparse=TRUE ) - if (verbose){ - rlang::inform( - message = "Combining completed sparse PK calculation results.", - class = "pknca_message_sparse_pk_combine" - ) + if (verbose) { + rlang::inform("Combining completed sparse PK calculation results.", class = "pknca_message_sparse_pk_combine") } results <- dplyr::bind_rows( @@ -139,9 +124,9 @@ pk_nca_result_to_df <- function(group_info, result) { X=seq_along(warning_preamble), FUN=function(idx) { warning_prep <- ret_warnings$data_result[[idx]] - warning_prep$message <- paste(warning_preamble[idx], warning_prep$message, sep=": ") + warning_prep$message <- sprintf("%s: %s", warning_preamble[idx], warning_prep$message) rlang::warn( - message = conditionMessage(warning_prep), + warning_prep$message, class = c("pknca_warning_parameter_calculation", class(warning_prep)) ) } @@ -150,10 +135,7 @@ pk_nca_result_to_df <- function(group_info, result) { ret_nowarning <- ret[!mask_warning, ] # Generate the outputs if (nrow(ret_nowarning) == 0) { - rlang::warn( - message = "All results generated warnings or errors; no results generated", - class = "pknca_warning_no_results" - ) + rlang::warn("All results generated warnings or errors; no results generated", class = "pknca_warning_no_results") results <- data.frame() } else { results <- tidyr::unnest(ret_nowarning, cols="data_result") @@ -272,13 +254,13 @@ pk.nca.intervals <- function(data_conc, data_dose, data_intervals, sparse, ) if (nrow(conc_data_interval) == 0) { rlang::warn( - message = sprintf("%s: No data for interval", error_preamble), + sprintf("%s: No data for interval", error_preamble), class = "pknca_warning_no_data_for_interval" ) } else if (!has_calc_sparse_dense) { - if (verbose){ + if (verbose) { rlang::inform( - message = sprintf( + sprintf( "No %s calculations requested for an interval", if (sparse) "sparse" else "dense" ), @@ -329,10 +311,10 @@ pk.nca.intervals <- function(data_conc, data_dose, data_intervals, sparse, } if (uses_include_hl && uses_exclude_hl) { rlang::abort( - message = "Cannot both include and exclude half-life points for the same interval", + "Cannot both include and exclude half-life points for the same interval", class = "pknca_error_include_exclude_halflife" - ) - } + ) + } # Try the calculation if (use_debug) { # debugging mode does not need coverage @@ -344,7 +326,7 @@ pk.nca.intervals <- function(data_conc, data_dose, data_intervals, sparse, error = function(e) { # nocov start rlang::abort( - message = sprintf( + sprintf( "Please report a bug.\n%s: %s", error_preamble, e$message @@ -430,11 +412,11 @@ pk.nca.interval <- function(conc, time, volume, duration.conc, subject, sparse, interval, options=list()) { if (!checkmate::test_data_frame(interval, nrows = 1)) { rlang::abort( - message = "Please report a bug. Interval must be a one-row data.frame", + "Please report a bug. Interval must be a one-row data.frame", class = "pknca_error_internal_interval_not_one_row_df" ) } - + if (!all(is.na(impute_method))) { impute_funs <- PKNCA_impute_fun_list(impute_method) stopifnot(length(impute_funs) == 1) @@ -465,7 +447,7 @@ pk.nca.interval <- function(conc, time, volume, duration.conc, if (length(dose) == 0) { # nocov start rlang::abort( - message = "Please report a bug. Length of dose should not be zero.", + "Please report a bug. Length of dose should not be zero.", class = "pknca_error_internal_dose_length_zero" ) # nocov end @@ -561,7 +543,7 @@ pk.nca.interval <- function(conc, time, volume, duration.conc, sprintf("'%s' mapped to '%s'", arg_formal, arg_mapped) } rlang::abort( - message = sprintf( + sprintf( "Cannot find argument %s for NCA function '%s'", arg_text, all_intervals[[n]]$FUN ), # nocov end diff --git a/R/pk.calc.c0.R b/R/pk.calc.c0.R index f53b1c66..80006d0e 100644 --- a/R/pk.calc.c0.R +++ b/R/pk.calc.c0.R @@ -25,18 +25,12 @@ pk.calc.c0 <- function(conc, time, time.dose=0, if (check) { assert_conc_time(conc = conc, time = time) } - checkmate::assert_number(time.dose, na.ok = TRUE, finite = FALSE) + checkmate::assert_number(time.dose, na.ok = TRUE, finite = FALSE) if (is.na(time.dose)) { - rlang::warn( - message = "time.dose is NA", - class = "pknca_warning_timedose_na" - ) + rlang::warn("time.dose is NA", class = "pknca_warning_timedose_na") return(structure(NA_real_, exclude = "dose time is missing")) } else if (time.dose > max(time)) { - rlang::warn( - message = "time.dose is after all available data", - class = "pknca_warning_timedose_after_data" - ) + rlang::warn("time.dose is after all available data", class = "pknca_warning_timedose_after_data") return(structure(NA_real_, exclude = "dose time is after all available concentration data")) } method <- match.arg(method, several.ok=TRUE) diff --git a/R/pk.calc.simple.R b/R/pk.calc.simple.R index 1d789010..66cec918 100644 --- a/R/pk.calc.simple.R +++ b/R/pk.calc.simple.R @@ -9,10 +9,7 @@ #' @export adj.r.squared <- function(r.sq, n) { if (n <= 2) { - rlang::warn( - message = "n must be > 2 for adj.r.squared", - class = "pknca_warning_adjr2_2points" - ) + rlang::warn("n must be > 2 for adj.r.squared", class = "pknca_warning_adjr2_2points") structure(NA_real_, exclude="n must be > 2") } else { 1-(1-r.sq)*(n-1)/(n-2) @@ -382,7 +379,7 @@ pk.calc.aucpext <- function(auclast, aucinf) { } else if ((!scalar_auclast && !scalar_aucinf) && length(auclast) != length(aucinf)) { rlang::abort( - message = "auclast and aucinf must either be a scalar or the same length.", + "auclast and aucinf must either be a scalar or the same length.", class = "pknca_error_auclast_aucinf_length" ) } @@ -400,12 +397,12 @@ pk.calc.aucpext <- function(auclast, aucinf) { mask_calc <- !mask_na & !(aucinf %in% 0) if (any(mask_greater)) rlang::warn( - message = "aucpext is typically only calculated when aucinf is greater than auclast.", + "aucpext is typically only calculated when aucinf is greater than auclast.", class = "pknca_warning_aucpext_aucinf_le_auclast" ) if (any(mask_negative)) rlang::warn( - message = "aucpext is typically only calculated when both aucinf and auclast are positive.", + "aucpext is typically only calculated when both aucinf and auclast are positive.", class = "pknca_warning_aucpext_aucinf_auclast_positive" ) ret[mask_calc] <- @@ -1074,10 +1071,7 @@ pk.calc.vz <- function(cl, lambda.z) { # likely errors here). if (!(length(cl) %in% c(1, length(lambda.z))) || !(length(lambda.z) %in% c(1, length(cl)))) - rlang::abort( - message = "'cl' and 'lambda.z' must be the same length", - class = "pknca_error_cl_lambdaz_length" - ) + rlang::abort("'cl' and 'lambda.z' must be the same length", class = "pknca_error_cl_lambdaz_length") cl/lambda.z } @@ -1519,8 +1513,8 @@ pk.calc.ctrough <- function(conc, time, end) { # duplicates. # nocov start 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" + "More than one time matches the starting time. Please report this as a bug with a reproducible example.", + class = "pknca_error_ctrough_multiple_start_times" ) # nocov end } @@ -1552,8 +1546,8 @@ pk.calc.cstart <- function(conc, time, start) { # duplicates. # nocov start 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" + "More than one time matches the starting time. Please report this as a bug with a reproducible example.", + class = "pknca_error_cstart_multiple_start_times" ) # nocov end } diff --git a/R/prepare_data.R b/R/prepare_data.R index 3f412975..022578ea 100644 --- a/R/prepare_data.R +++ b/R/prepare_data.R @@ -16,7 +16,7 @@ full_join_PKNCAconc_PKNCAdose <- function(o_conc, o_dose, extra_cols_conc = char checkmate::assert_class(o_conc, "PKNCAconc") if (identical(o_dose, NA)) { rlang::inform( - message = "No dose information provided, calculations requiring dose will return NA.", + "No dose information provided, calculations requiring dose will return NA.", class = "pknca_message_missing_dose" ) n_dose <- tibble::tibble(data_dose=list(NA)) @@ -211,7 +211,7 @@ prepare_PKNCAdose <- function(.dat, sparse, subject_col) { "Not all subjects have the same dosing information." } rlang::abort( - message = sprintf( + sprintf( "With sparse PK, all subjects in a group must have the same dosing information.\n%s", msg_error ), @@ -288,7 +288,7 @@ check_reserved_column_names <- function(x) { "and retry." ) rlang::abort( - message = msg, + msg, class = "pknca_error_reserved_column_names" ) } @@ -315,7 +315,7 @@ standardize_column_names <- function(x, cols, group_cols=NULL, insert_if_missing mask_overlap_colnames <- group_cols %in% names(cols) if (any(mask_overlap_colvalues)) { rlang::abort( - message = sprintf( + sprintf( "group_cols must not overlap with other column names. Change the name of the following groups: %s", paste(group_cols[mask_overlap_colvalues], collapse = ", ") ), @@ -324,7 +324,7 @@ standardize_column_names <- function(x, cols, group_cols=NULL, insert_if_missing } if (any(mask_overlap_colnames)) { rlang::abort( - message = sprintf( + sprintf( "group_cols must not overlap with standardized column names. Change the name of the following groups: %s", paste(group_cols[mask_overlap_colnames], collapse = ", ") ), @@ -356,15 +356,9 @@ restore_group_col_names <- function(x, group_cols=NULL) { } new_group_cols <- paste0("group", seq_along(group_cols)) if (!all(new_group_cols %in% names(x))) - rlang::abort( - message = "missing intermediate group_cols names", - class = "pknca_error_missing_group_cols" - ) + rlang::abort("missing intermediate group_cols names", class = "pknca_error_missing_group_cols") if (!all(names(x)[names(x) %in% new_group_cols] == new_group_cols)) - rlang::abort( - message = "Intermediate group_cols are out of order", - class = "pknca_error_group_cols_order" - ) + rlang::abort("Intermediate group_cols are out of order", class = "pknca_error_group_cols_order") names(x)[names(x) %in% new_group_cols] <- group_cols x } diff --git a/R/provenance.R b/R/provenance.R index 7b0db510..9e0ea1a8 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -24,7 +24,7 @@ addProvenance <- function(object, replace=FALSE) { digest::digest(as.character(object), serialize=FALSE) } else { rlang::abort( - message = "object already has provenance and the option to replace it was not selected.", + "object already has provenance and the option to replace it was not selected.", class = "pknca_error_provenance_already_exists" ) } diff --git a/R/set_and_assert_intervals.R b/R/set_and_assert_intervals.R index 70728f69..a2529245 100644 --- a/R/set_and_assert_intervals.R +++ b/R/set_and_assert_intervals.R @@ -51,7 +51,7 @@ assert_intervals <- function(intervals, data) { if (length(invalid_columns) > 0) { rlang::abort( - message = sprintf( + sprintf( "The following columns in 'intervals' are not allowed: %s", paste(invalid_columns, collapse = ", ") ), diff --git a/R/sparse.R b/R/sparse.R index 71d83f2a..a3d66f8e 100644 --- a/R/sparse.R +++ b/R/sparse.R @@ -47,11 +47,11 @@ sparse_pk_attribute <- function(sparse_pk, ...) { if (is.null(names(args))) { vapply(X=sparse_pk, FUN="[[", args[[1]], FUN.VALUE = 1) } else { - if (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", + "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] @@ -133,7 +133,7 @@ sparse_mean <- function(sparse_pk, sparse_mean_method=c("arithmetic mean, <=50% # do nothing } else { rlang::abort( - message = sprintf( + sprintf( "Invalid sparse_mean_method: %s", sparse_mean_method ), @@ -191,7 +191,7 @@ var_sparse_auc <- function(sparse_pk) { sum(weights^4 * diag(covariance)^2/(n^2*(n-1))) if (sum(covariance[lower.tri(covariance)] != 0) > 0) { rlang::warn( - message = "Cannot yet calculate sparse degrees of freedom for multiple samples per subject", + "Cannot yet calculate sparse degrees of freedom for multiple samples per subject", class = "pknca_warning_sparse_df_multi" ) df <- NA_real_ @@ -322,7 +322,7 @@ pk.calc.sparse_auc <- function(conc, time, subject, # enabled here in the future), but only "linear" is currently allowed. if (!identical(method, "linear")) { rlang::abort( - message = 'Sparse AUC calculation only supports `method = "linear"`.', + 'Sparse AUC calculation only supports `method = "linear"`.', class = "pknca_error_sparse_auc_method" ) } @@ -358,7 +358,7 @@ pk.calc.sparse_auc <- function(conc, time, subject, pk.calc.sparse_auclast <- function(conc, time, subject, ..., options=list()) { if ("auc.type" %in% names(list(...))) { rlang::abort( - message = "auc.type cannot be changed when calling pk.calc.sparse_auclast, please use pk.calc.sparse_auc", + "auc.type cannot be changed when calling pk.calc.sparse_auclast, please use pk.calc.sparse_auc", class = "pknca_error_sparse_auclast_change_auclast" ) } @@ -498,8 +498,8 @@ var_sparse_aumc <- function(sparse_pk) { if (sum(covariance[lower.tri(covariance)] != 0) > 0) { rlang::warn( - message = "Cannot yet calculate sparse degrees of freedom for multiple samples per subject", - class = "pknca_warning_sparse_df_multi" + "Cannot yet calculate sparse degrees of freedom for multiple samples per subject", + class = "pknca_warning_sparse_aumc_df_multi" ) df <- NA_real_ } @@ -541,7 +541,7 @@ pk.calc.sparse_aumc <- function(conc, time, subject, # Sparse AUMC is only defined for linear interpolation (see pk.calc.sparse_auc). if (!identical(method, "linear")) { rlang::abort( - message = 'Sparse AUMC calculation only supports `method = "linear"`.', + 'Sparse AUMC calculation only supports `method = "linear"`.', class = "pknca_error_sparse_aumc_method" ) } @@ -583,7 +583,7 @@ pk.calc.sparse_aumc <- function(conc, time, subject, pk.calc.sparse_aumclast <- function(conc, time, subject, ..., options = list()) { if ("auc.type" %in% names(list(...))) { rlang::abort( - message = "auc.type cannot be changed when calling pk.calc.sparse_aumclast, please use pk.calc.sparse_aumc", + "auc.type cannot be changed when calling pk.calc.sparse_aumclast, please use pk.calc.sparse_aumc", class = "pknca_error_sparse_aumclast_change_auc_type" ) } diff --git a/R/superposition.R b/R/superposition.R index b1f899d5..88b81852 100644 --- a/R/superposition.R +++ b/R/superposition.R @@ -81,7 +81,7 @@ superposition.numeric <- function(conc, time, dose.input = NULL, if (check.blq) { if (!(conc[1] %in% 0)) { rlang::abort( - message = "The first concentration must be 0 (and not NA). To change this set check.blq=FALSE.", + "The first concentration must be 0 (and not NA). To change this set check.blq=FALSE.", class = "pknca_error_superposition_blq" ) } @@ -93,14 +93,14 @@ superposition.numeric <- function(conc, time, dose.input = NULL, if (!missing(dose.amount)) { if (missing(dose.input)) { rlang::abort( - message = "must give dose.input to give dose.amount", + "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)))) rlang::abort( - message = "dose.amount must either be a scalar or match the length of dose.times", + "dose.amount must either be a scalar or match the length of dose.times", class = "pknca_error_superposition_dose_amount_length" ) } @@ -131,24 +131,21 @@ superposition.numeric <- function(conc, time, dose.input = NULL, if (length(additional.times) > 0) { if (any(is.na(additional.times))) { rlang::abort( - message = "No additional.times may be NA (to not include any additional.times, enter c() as the function argument)", + "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" ) } - checkmate::assert_numeric(additional.times, lower = 0, upper = tau) + checkmate::assert_numeric(additional.times, lower = 0, upper = tau) } # 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.", + "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" - ) + if (steady.state.tol > 0.01) { + rlang::warn("steady.state.tol is usually <= 0.01", class = "pknca_warning_superposition_steady_state_tol_large") } # We get all or none of lambda.z, clast, and tlast has.lambda.z <- !missing(lambda.z) @@ -157,7 +154,7 @@ superposition.numeric <- function(conc, time, dose.input = NULL, 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", + "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 @@ -168,7 +165,7 @@ superposition.numeric <- function(conc, time, dose.input = NULL, if (length(dose.scaling) != 1) # nocov start rlang::abort( - message = "bug in dose.amount, dose.times, and dose.input handling", + "bug in dose.amount, dose.times, and dose.input handling", class = "pknca_error_internal_dose_scaling" ) # nocov end diff --git a/R/time.above.R b/R/time.above.R index 051ff386..b3b168f6 100644 --- a/R/time.above.R +++ b/R/time.above.R @@ -22,16 +22,10 @@ pk.calc.time_above <- function(conc, time, arglist <- list(...) method <- PKNCA.choose.option(name="auc.method", value=arglist$method, options=options) if (missing(conc)) { - rlang::abort( - message = "conc must be given", - class = "pknca_error_time_above_missing_conc" - ) + rlang::abort("conc must be given", class = "pknca_error_time_above_missing_conc") } if (missing(time)) { - rlang::abort( - message = "time must be given", - class = "pknca_error_time_above_missing_time" - ) + rlang::abort("time must be given", class = "pknca_error_time_above_missing_time") } checkmate::assert_number(conc_above, na.ok = FALSE) if (check) { diff --git a/R/time_calc.R b/R/time_calc.R index 6e2c32e2..379891ed 100644 --- a/R/time_calc.R +++ b/R/time_calc.R @@ -23,20 +23,14 @@ 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) { - rlang::warn( - message = "No events provided", - class = "pknca_warning_time_calc_no_events" - ) + rlang::warn("No events provided", class = "pknca_warning_time_calc_no_events") time_event <- NA_real_ } else if (any(order(stats::na.omit(time_event)) != seq_along(stats::na.omit(time_event)))) { - rlang::abort( - message = "`time_event` must be sorted.", - class = "pknca_error_time_calc_unsorted" - ) + rlang::abort("`time_event` must be sorted.", class = "pknca_error_time_calc_unsorted") } if (!is.numeric(time_obs)) { rlang::abort( - message = "Both `time_event` and `time_obs` must be the same class (numeric).", + "Both `time_event` and `time_obs` must be the same class (numeric).", class = "pknca_error_time_calc_class_mismatch_numeric" ) } @@ -79,14 +73,11 @@ 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)) { - rlang::abort( - message = "`units` must be provided.", - class = "pknca_error_time_calc_missing_units" - ) + rlang::abort("`units` must be provided.", class = "pknca_error_time_calc_posixt_missing_units") } if (!("POSIXt" %in% class(time_obs))) { rlang::abort( - message = "Both `time_event` and `time_obs` must be the same class (POSIXt).", + "Both `time_event` and `time_obs` must be the same class (POSIXt).", class = "pknca_error_time_calc_class_mismatch_posix" ) } @@ -101,14 +92,11 @@ 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)) { - rlang::abort( - message = "`units` must be provided.", - class = "pknca_error_time_calc_missing_units" - ) + rlang::abort("`units` must be provided.", class = "pknca_error_time_calc_difftime_missing_units") } if (!("difftime" %in% class(time_obs))) { rlang::abort( - message = "Both `time_event` and `time_obs` must be the same class (difftime).", + "Both `time_event` and `time_obs` must be the same class (difftime).", class = "pknca_error_time_calc_class_mismatch_difftime" ) } diff --git a/R/tss.R b/R/tss.R index 02044228..8fc392ca 100644 --- a/R/tss.R +++ b/R/tss.R @@ -25,16 +25,10 @@ pk.tss.data.prep <- function(conc, time, subject, treatment, assert_conc_time(conc = conc, time = time, sorted_time = sorted_time) } if (!missing(subject.dosing) && missing(subject)) { - rlang::abort( - message = "Cannot give subject.dosing without subject", - class = "pknca_error_tss_subject_dosing_without_subject" - ) + rlang::abort("Cannot give subject.dosing without subject", class = "pknca_error_tss_subject_dosing_without_subject") } if (anyNA(time.dosing)) { - rlang::abort( - message = "time.dosing may not contain any NA values", - class = "pknca_error_tss_time_dosing_na" - ) + rlang::abort("time.dosing may not contain any NA values", class = "pknca_error_tss_time_dosing_na") } if (!missing(subject)) { if (!missing(treatment)) { @@ -130,7 +124,7 @@ pk.tss <- function(..., } else { # nocov start rlang::abort( - message = "Bug in pk.tss where ret is set to non-NA too early. Please report the bug with a reproducible example.", + "Bug in pk.tss where ret is set to non-NA too early. Please report the bug with a reproducible example.", class = "pknca_error_internal_pk_tss_ret_non_na" ) # nocov end diff --git a/R/tss.monoexponential.R b/R/tss.monoexponential.R index f162a1f6..6b932dd2 100644 --- a/R/tss.monoexponential.R +++ b/R/tss.monoexponential.R @@ -39,24 +39,15 @@ pk.tss.monoexponential <- function(..., # Check inputs modeldata <- pk.tss.data.prep(..., check=check) if (length(tss.fraction) > 1) { - rlang::warn( - message = "Only first value of tss.fraction is being used", - class = "pknca_warning_tss_fraction_multiple" - ) + rlang::warn("Only first value of tss.fraction is being used", class = "pknca_warning_tss_fraction_multiple") tss.fraction <- tss.fraction[1] } checkmate::assert_number(tss.fraction, na.ok = FALSE) if (tss.fraction <= 0 || tss.fraction >= 1) { - rlang::abort( - message = "tss.fraction must be between 0 and 1, exclusive", - class = "pknca_error_tss_fraction_range" - ) + rlang::abort("tss.fraction must be between 0 and 1, exclusive", class = "pknca_error_tss_fraction_range") } else if (tss.fraction < 0.8) { - rlang::warn( - message = "tss.fraction is usually >= 0.8", - class = "pknca_warning_tss_fraction_small" - ) + rlang::warn("tss.fraction is usually >= 0.8", class = "pknca_warning_tss_fraction_small") } # Note that this will by default choose "population" if nothing is # requested. @@ -64,7 +55,7 @@ pk.tss.monoexponential <- function(..., if (!("subject" %in% names(modeldata))) { if (any(c("population", "popind", "individual") %in% output)) { rlang::warn( - message = "Cannot give 'population', 'popind', or 'individual' output without multiple subjects of data", + "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")) @@ -101,7 +92,7 @@ pk.tss.monoexponential <- function(..., } else { # nocov start rlang::abort( - message = "Error in selection of return values for pk.tss.monoexponential. This is likely a bug.", + "Error in selection of return values for pk.tss.monoexponential. This is likely a bug.", class = "pknca_error_internal_tss_return_selection" ) # nocov end @@ -252,7 +243,7 @@ pk.tss.monoexponential.population <- function(data, 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", + "No population model for monoexponential Tss converged, no results given", class = "pknca_warning_tss_population_no_convergence" ) ret <- @@ -286,7 +277,7 @@ pk.tss.monoexponential.population <- function(data, ) } else if ("popind" %in% output) { rlang::warn( - message = "tss.monoexponential.popind was requested, but the best model did not include a random effect for tss. Set to NA.", + "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 <- @@ -387,7 +378,7 @@ pk.tss.monoexponential.individual <- function(data, } else { # nocov start rlang::abort( - message = "Please report a bug. Subject must be specified to have subject-level fitting", + "Please report a bug. Subject must be specified to have subject-level fitting", class = "pknca_error_internal_tss_no_subject_for_individual" ) # nocov end diff --git a/R/tss.stepwise.linear.R b/R/tss.stepwise.linear.R index cbf24a81..86df9735 100644 --- a/R/tss.stepwise.linear.R +++ b/R/tss.stepwise.linear.R @@ -28,38 +28,30 @@ pk.tss.stepwise.linear <- function(..., # Check inputs modeldata <- pk.tss.data.prep(..., check=check) if (!length(min.points) == 1) { - rlang::warn( - message = "Only first value of min.points is used", - class = "pknca_warning_min_points_length" - ) + rlang::warn("Only first value of min.points is used", class = "pknca_warning_min_points_length") min.points <- min.points[1] } - + checkmate::assert_number(min.points, lower = 3) - + if (!length(level) == 1) { - rlang::warn( - message = "Only first value of level is being used", - class = "pknca_warning_tss_level_multiple" - ) + rlang::warn("Only first value of level is being used", class = "pknca_warning_tss_level_multiple") level <- level[1] } - + checkmate::assert_numeric(level, any.missing = FALSE) - - if (level <= 0 || level >= 1){ - rlang::abort( - message = "level must be between 0 and 1, exclusive", - class = "pknca_error_tss_level_range" - ) } - + + if (level <= 0 || level >= 1) { + rlang::abort("level must be between 0 and 1, exclusive", class = "pknca_error_tss_level_range") + } + # Confirm that we may have sufficient data to complete the # modeling. Because of the variety of methods used for estimating # time to steady-state, assurance that we have enough data is more # simply determined by model convergence. if (length(unique(modeldata$time)) < min.points) { rlang::warn( - message = "After removing non-dosing time points, insufficient data remains for tss calculation", + "After removing non-dosing time points, insufficient data remains for tss calculation", class = "pknca_warning_tss_insufficient_data" ) return(NA) @@ -76,7 +68,7 @@ pk.tss.stepwise.linear <- function(..., (length(remaining.time) >= min.points)) { if (verbose) { rlang::inform( - message = paste("Trying", min(remaining.time, na.rm = TRUE)), + sprintf("Trying %s", min(remaining.time, na.rm = TRUE)), class = "pknca_message_tss_trying_time" ) } @@ -104,7 +96,7 @@ pk.tss.stepwise.linear <- function(..., } if (verbose) { rlang::inform( - message = sprintf( + sprintf( "Current interval %g [%g, %g]", current.interval[2], current.interval[1], diff --git a/R/unit-support.R b/R/unit-support.R index daa142b1..d29664cd 100644 --- a/R/unit-support.R +++ b/R/unit-support.R @@ -114,7 +114,7 @@ pknca_units_table.default <- function(concu, doseu, amountu, timeu, mask_pref <- conversions_pref$PPORRESU %in% conversions$PPORRESU[idx] if (!any(mask_pref)) { rlang::abort( - message = "Cannot find PPORRESU match between conversions and preferred unit conversions. Check PPORRESU values in 'conversions' argument.", + "Cannot find PPORRESU match between conversions and preferred unit conversions. Check PPORRESU values in 'conversions' argument.", class = "pknca_error_units_pporresu_no_match" ) } @@ -128,7 +128,7 @@ pknca_units_table.default <- function(concu, doseu, amountu, timeu, if (length(extra_cols) > 0) { # nocov start rlang::abort( - message = sprintf( + sprintf( "Please report a bug. Unknown NCA parameters have units defined: %s", paste(extra_cols, collapse = ", ") ), @@ -141,20 +141,20 @@ pknca_units_table.default <- function(concu, doseu, amountu, timeu, if (nrow(conversions) > 0) { if (any(duplicated(conversions$PPORRESU))) rlang::abort( - message = "conversions$PPORRESU must not have duplicated values", + "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) 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'", + "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)) { # nocov start rlang::abort( - message = "The units package is required for automatic unit conversion", + "The units package is required for automatic unit conversion", class = "pknca_error_missing_units_package" ) # nocov end @@ -174,7 +174,7 @@ pknca_units_table.default <- function(concu, doseu, amountu, timeu, unexpected_conversions <- setdiff(conversions$PPORRESU, ret$PPORRESU) if (length(unexpected_conversions) > 0) { rlang::warn( - message = sprintf( + sprintf( "The following unit conversions were supplied but do not match any units to convert: %s", paste0("'", unexpected_conversions, "'", collapse = ", ") ), @@ -273,7 +273,7 @@ pknca_units_table.PKNCAdata <- function(concu, ..., conversions = data.frame()) } ) rlang::abort( - message = sprintf( + sprintf( "Units should be uniform at least across concentration groups. Review the units for the next group(s):\n%s", paste(mismatching_units_groups_msg, collapse = "\n") ), @@ -375,7 +375,7 @@ useless <- function(x) { return(TRUE) } else if (length(x) > 1) { rlang::abort( - message = sprintf( + sprintf( "Only one unit may be provided at a time: %s", paste(x, collapse = ", ") ), @@ -592,7 +592,7 @@ pknca_find_units_param <- function(unit_type) { } if (length(ret) == 0) { rlang::abort( - message = sprintf( + sprintf( "No parameters found for unit_type=%s", unit_type ), @@ -637,12 +637,12 @@ pknca_unit_conversion <- function(result, units, allow_partial_missing_units = F ) if (allow_partial_missing_units) { rlang::warn( - message = msg_missing, + msg_missing, class = "pknca_warning_units_partial_missing" ) } else { rlang::abort( - message = sprintf( + sprintf( "%s\nThis error can be converted to a warning using `PKNCA.options(allow_partial_missing_units = TRUE)`", msg_missing ), diff --git a/R/update.PKNCAresults.R b/R/update.PKNCAresults.R index df958c3f..863a9162 100644 --- a/R/update.PKNCAresults.R +++ b/R/update.PKNCAresults.R @@ -24,15 +24,12 @@ update.PKNCAresults <- function(object, data, ...) { data$options <- PKNCA.options() } if (identical(as_PKNCAdata(object), data)) { - rlang::inform( - message = "No changes detected in data", - class = "pknca_message_no_changes" - ) + rlang::inform("No changes detected in data", class = "pknca_message_no_changes") return(object) } if (!identical(strip_source_data(as_PKNCAdata(object)), strip_source_data(data))) { rlang::warn( - message = "Full recalculation: changes detected in data other than source concentration or dose data", + "Full recalculation: changes detected in data other than source concentration or dose data", class = "pknca_warning_full_recalculation" ) return(pk.nca(data)) @@ -75,10 +72,7 @@ strip_source_data <- function(data) { #' @noRd find_changed_group <- function(old, 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" - ) + rlang::abort("old and new must be the same class", class = "pknca_error_find_changed_group_class_mismatch") if (inherits(old, "PKNCAdata")) { # Find subjects that changed (for PKNCAdata by going into conc and dose) list( diff --git a/tests/testthat/test-001-add.interval.col.R b/tests/testthat/test-001-add.interval.col.R index 2e6d858f..88334d0e 100644 --- a/tests/testthat/test-001-add.interval.col.R +++ b/tests/testthat/test-001-add.interval.col.R @@ -157,8 +157,7 @@ test_that("add.interval.col", { datatype="interval", pptestcd_cdisc="a", pptest_cdisc="test addition" - ), - info="interval column assignment works with FUN=NA" + ) ) expect_equal( { @@ -177,8 +176,7 @@ test_that("add.interval.col", { datatype="interval", pptestcd_cdisc="a", pptest_cdisc="test addition" - ), - info="interval column assignment works with FUN=a character string" + ) ) expect_equal( { @@ -197,8 +195,7 @@ test_that("add.interval.col", { datatype="interval", pptestcd_cdisc="a", pptest_cdisc="test addition" - ), - info="interval column assignment works with FUN=NA" + ) ) }) diff --git a/tests/testthat/test-assertions.R b/tests/testthat/test-assertions.R index c94c700b..e4016303 100644 --- a/tests/testthat/test-assertions.R +++ b/tests/testthat/test-assertions.R @@ -170,13 +170,12 @@ test_that("assert_unit_col", { ) expect_error( assert_unit_col(unit = "D", data = d), - regexp = "`unit` (D) must be a column name in the data", + regexp = "Names must include the elements {'D'}", fixed = TRUE ) expect_error( assert_unit_col(unit = "A", data = d), - regexp = "`unit` (A) must contain character data", - fixed = TRUE + regexp = "Must be of type 'character'" ) }) diff --git a/tests/testthat/test-class-PKNCAdose.R b/tests/testthat/test-class-PKNCAdose.R index 43b99c51..a335d5ee 100644 --- a/tests/testthat/test-class-PKNCAdose.R +++ b/tests/testthat/test-class-PKNCAdose.R @@ -472,7 +472,7 @@ test_that("setDuration", { regexp="duration must be numeric without missing (NA) or infinite values, and all values must be >= 0", fixed=TRUE, info="Cannot give both duration as non-numeric", - class = "pknca_error_invalid_duration"), + class = "pknca_error_dose_invalid_duration"), class = "pknca_message_foundcolumn_duration" ) diff --git a/tests/testthat/test-half.life.R b/tests/testthat/test-half.life.R index e5ed00ea..afdb8874 100644 --- a/tests/testthat/test-half.life.R +++ b/tests/testthat/test-half.life.R @@ -708,7 +708,7 @@ test_that("pk.calc.half.life hl_method='tobit' warns with too few above-LLOQ poi allow.tmax.in.half.life = TRUE, min.hl.points = 3 ), - class = "pknca_warning_halflife_too_few_points" + class = "pknca_warning_halflife_too_few_points_tobit" ) expect_true(is.na(result$lambda.z)) }) @@ -862,11 +862,11 @@ test_that("pk.calc.half.life tobit uses allow.tmax.in.half.life=FALSE", { time <- 0:3 lloq <- 0.1 # FALSE (strict >): keep time > 1 → only conc=1 at time 2 is above-LLOQ - # → 1 point < min.hl.points=2 → pknca_warning_halflife_too_few_points warning + # → 1 point < min.hl.points=2 → pknca_warning_halflife_too_few_points_tobit warning expect_warning( pk.calc.half.life(conc, time, lloq = lloq, hl_method = "tobit", allow.tmax.in.half.life = FALSE, min.hl.points = 2), - class = "pknca_warning_halflife_too_few_points" + class = "pknca_warning_halflife_too_few_points_tobit" ) # TRUE (>=): keep time >= 1 → conc=2 and conc=1 both above-LLOQ # → 2 points meets min.hl.points=2 → fitting succeeds From 6b142ef3fbf36a0ed6bc74661092c103e30922de Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Sun, 16 Aug 2026 21:54:16 -0400 Subject: [PATCH 9/9] Collapse multi-line rlang conditions onto single lines Extends the earlier pass, which only recognized a call whose message was a string literal. A message that is a variable or a nested sprintf() is now flattened too, which is what left calls such as rlang::abort(unit_col, class = ...) spread over four lines. A call inside a `# nocov start` / `# nocov end` bracket is allowed a longer line, since collapsing it also removes the two marker lines and leaves a trailing `# nocov`; the limit is 175 characters there and 120 elsewhere. 44 calls collapsed and nocov brackets drop from 42 to 12. Whitespace is only collapsed outside string literals, so no message text changes. The 12 remaining brackets are not single calls (.onLoad, the lifecycle shims, a closure), wrap two statements, or would exceed 180 characters on one line. Co-Authored-By: Claude Opus 5 --- R/AIC.list.R | 7 +------ R/PKNCA.options.R | 10 ++-------- R/assertions.R | 10 ++-------- R/auc_integrate.R | 20 ++------------------ R/aucint.R | 12 ++---------- R/check.intervals.R | 21 +++------------------ R/class-general.R | 34 ++++++---------------------------- R/class-summary_PKNCAresults.R | 27 +++------------------------ R/cleaners.R | 17 ++--------------- R/half.life.R | 10 ++-------- R/interpolate.conc.R | 14 ++------------ R/parse_formula_to_cols.R | 7 +------ R/pk.calc.all.R | 29 ++++------------------------- R/pk.calc.simple.R | 14 ++------------ R/prepare_data.R | 5 +---- R/sparse.R | 10 ++-------- R/superposition.R | 7 +------ R/tss.R | 7 +------ R/tss.monoexponential.R | 14 ++------------ R/tss.stepwise.linear.R | 5 +---- R/unit-support.R | 12 ++---------- 21 files changed, 44 insertions(+), 248 deletions(-) diff --git a/R/AIC.list.R b/R/AIC.list.R index f79777d1..1f9ebda9 100644 --- a/R/AIC.list.R +++ b/R/AIC.list.R @@ -25,12 +25,7 @@ AIC.list <- function(object, ..., assess.best=TRUE) { if ("indentation" %in% names(ret)) { ret$indentation <- ret$indentation + 1 } else { - # nocov start - rlang::abort( - "Unknown way to get a data.frame without indentation set. This is likely a bug.", - class = "pknca_error_internal_unknown_dataframe_indentation" - ) - # nocov end + rlang::abort("Unknown way to get a data.frame without indentation set. This is likely a bug.", class = "pknca_error_internal_unknown_dataframe_indentation") # nocov } } } diff --git a/R/PKNCA.options.R b/R/PKNCA.options.R index 095729b8..edd6a012 100644 --- a/R/PKNCA.options.R +++ b/R/PKNCA.options.R @@ -493,10 +493,7 @@ PKNCA.options <- function(..., default=FALSE, check=FALSE, name, value) { } n <- names(args) if (!(n %in% names(.PKNCA.option.check))) { - rlang::abort( - sprintf("Invalid setting for PKNCA: %s", n), - class = "pknca_error_invalid_option_check" - ) + rlang::abort(sprintf("Invalid setting for PKNCA: %s", n), class = "pknca_error_invalid_option_check") } # Verify the option, and return the sanitized version return(.PKNCA.option.check[[n]](args[[n]])) @@ -528,10 +525,7 @@ PKNCA.options <- function(..., default=FALSE, check=FALSE, name, value) { # Verify values are viable and then set them. for (n in names(args)) { if (!(n %in% names(.PKNCA.option.check))) { - rlang::abort( - sprintf("Invalid setting for PKNCA: %s", n), - class = "pknca_error_invalid_option_set" - ) + rlang::abort(sprintf("Invalid setting for PKNCA: %s", n), class = "pknca_error_invalid_option_set") } # Verify and set the option value current[[n]] <- .PKNCA.option.check[[n]](args[[n]]) diff --git a/R/assertions.R b/R/assertions.R index 3df8118f..843afd5e 100644 --- a/R/assertions.R +++ b/R/assertions.R @@ -145,10 +145,7 @@ assert_numeric_between <- function(x, any.missing = FALSE, null.ok = FALSE, lowe ) } if (length(msg) > 0) { - rlang::abort( - paste(msg, collapse = "\n"), - class = "pknca_error_numeric_between" - ) + rlang::abort(paste(msg, collapse = "\n"), class = "pknca_error_numeric_between") } } x @@ -289,9 +286,6 @@ assert_unit <- function(unit, data) { } else { # Re-raise the unit_col error. That is better than unit_value since it is # stricter. - rlang::abort( - unit_col, - class = "pknca_error_invalid_unit" - ) + rlang::abort(unit_col, class = "pknca_error_invalid_unit") } } diff --git a/R/auc_integrate.R b/R/auc_integrate.R index d056a483..a780b30e 100644 --- a/R/auc_integrate.R +++ b/R/auc_integrate.R @@ -148,15 +148,7 @@ choose_interval_method <- function(conc, time, tlast, method, auc.type, options) ret[c(mask_linear, FALSE)] <- "linear" ret[c(mask_log, FALSE)] <- "log" } else { - # nocov start - rlang::abort( - sprintf( - "Unknown integration method, please report a bug: %s", - method - ), - class = "pknca_error_internal_unknown_integration_method" - ) - # nocov end + rlang::abort(sprintf("Unknown integration method, please report a bug: %s", method), class = "pknca_error_internal_unknown_integration_method") # nocov } ret[c(mask_zero, FALSE)] <- "zero" # What happens after tlast? @@ -210,15 +202,7 @@ auc_integrate <- function(conc, time, clast, tlast, lambda.z, interval_method, f # or clast,pred is passed in. ret[length(ret)+1] <- fun_inf(clast, tlast, lambda.z) } else if (interval_method_extrap != "zero") { - # nocov start - rlang::abort( - sprintf( - "Invalid interval_method_extrap, please report a bug: %s", - interval_method_extrap - ), - class = "pknca_error_internal_invalid_interval_method_extrap" - ) - # nocov end + rlang::abort(sprintf("Invalid interval_method_extrap, please report a bug: %s", interval_method_extrap), class = "pknca_error_internal_invalid_interval_method_extrap") # nocov } ret <- sum(ret) ret diff --git a/R/aucint.R b/R/aucint.R index 24b54f7a..f60cec3c 100644 --- a/R/aucint.R +++ b/R/aucint.R @@ -82,12 +82,7 @@ pk.calc.auxcint <- function(conc, time, # clast.pred is NA likely because the half-life was not calculable return(structure(NA_real_, exclude = "clast.pred is NA because the half-life is NA")) } else if (is.na(clast)) { - # nocov start - rlang::abort( - "Please report a bug. clast is NA and the half-life is not NA", - class = "pknca_error_internal_clast_na" - ) - # nocov end + rlang::abort("Please report a bug. clast is NA and the half-life is not NA", class = "pknca_error_internal_clast_na") # nocov } else if (clast != clast_obs && interval[2] > tlast) { # If using clast.pred, we need to doubly calculate at tlast. conc_clast <- clast @@ -147,10 +142,7 @@ pk.calc.auxcint <- function(conc, time, "Time points with missing data are: ", paste(missing_times, collapse=", ")) } - rlang::warn( - warning_message, - class = "pknca_warning_missing_interpolated_concentrations" - ) + rlang::warn(warning_message, class = "pknca_warning_missing_interpolated_concentrations") return(NA_real_) } } else { diff --git a/R/check.intervals.R b/R/check.intervals.R index d69bc1d5..cdccc8c0 100644 --- a/R/check.intervals.R +++ b/R/check.intervals.R @@ -47,12 +47,7 @@ check.interval.specification <- function(x) { } else { # It would probably take malicious code to get here (altering # the intervals without using add.interval.col - # nocov start - rlang::abort( - sprintf("Cannot assign default value for interval column %s", n), - class = "pknca_error_interval_default_value" - ) - # nocov end + rlang::abort(sprintf("Cannot assign default value for interval column %s", n), class = "pknca_error_interval_default_value") # nocov } } else { # Confirm the edits of the given columns @@ -77,12 +72,7 @@ check.interval.specification <- function(x) { } interval_cols[[n]]$values(x[[n]]) } else { - # nocov start - rlang::abort( - sprintf("Invalid 'values' for column specification %s (please report this as a bug).", n), - class = "pknca_error_interval_invalid_col_spec" - ) - # nocov end + rlang::abort(sprintf("Invalid 'values' for column specification %s (please report this as a bug).", n), class = "pknca_error_interval_invalid_col_spec") # nocov } } } @@ -141,12 +131,7 @@ get.parameter.deps_helper_funmap <- function(x, all_intervals) { # It would probably take malicious code to get here (an # example of malicious code could be altering the # intervals without using add.interval.col) - # nocov start - rlang::abort( - "Invalid interval definition with no function and multiple dependencies.", - class = "pknca_error_interval_invalid_def" - ) - # nocov end + rlang::abort("Invalid interval definition with no function and multiple dependencies.", class = "pknca_error_interval_invalid_def") # nocov } } else { retfun <- x$FUN diff --git a/R/class-general.R b/R/class-general.R index a7d38834..429fd126 100644 --- a/R/class-general.R +++ b/R/class-general.R @@ -133,20 +133,11 @@ 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)) { - rlang::abort( - stop_if_default, - class = "pknca_error_used_default_value" - ) + rlang::abort(stop_if_default, class = "pknca_error_used_default_value") } else if (!missing(warn_if_default)) { - rlang::warn( - warn_if_default, - class = "pknca_warning_used_default_value" - ) + rlang::warn(warn_if_default, class = "pknca_warning_used_default_value") } else if (!missing(message_if_default)) { - rlang::inform( - message_if_default, - class = "pknca_message_used_default_value" - ) + rlang::inform(message_if_default, class = "pknca_message_used_default_value") } } } @@ -183,10 +174,7 @@ getAttributeColumn <- function(object, attr_name, warn_missing=c("attr", "column dataname <- getDataName(object) if (is.null(columns)) { if ("attr" %in% warn_missing) - rlang::warn( - sprintf("%s is not set.", attr_name), - class = "pknca_warning_attr_not_set" - ) + rlang::warn(sprintf("%s is not set.", attr_name), class = "pknca_warning_attr_not_set") NULL } else if (length(missing_cols <- setdiff(columns, names(object[[dataname]])))) { if ("column" %in% warn_missing) @@ -265,12 +253,7 @@ pknca_set_units <- function(object, units_orig = list(), units_pref = list()) { } else if (current_unit_type %in% "value") { object$units[[col_units]] <- all_units$orig[[col_units]] } else { - # nocov start - rlang::abort( - sprintf("Please report a bug. Unit setting for %s", col_units), - class = "pknca_error_internal_unit_setting_bug" - ) - # nocov end + rlang::abort(sprintf("Please report a bug. Unit setting for %s", col_units), class = "pknca_error_internal_unit_setting_bug") # nocov } } for (pref_units in names(all_units$pref)) { @@ -288,12 +271,7 @@ pknca_set_units <- function(object, units_orig = list(), units_pref = list()) { } object$units[[pref_units]] <- all_units$pref[[pref_units]] } else { - # nocov start - rlang::abort( - sprintf("Please report a bug. Preferred unit setting for %s", pref_units), - class = "pknca_error_internal_pref_unit_setting_bug" - ) - # nocov end + rlang::abort(sprintf("Please report a bug. Preferred unit setting for %s", pref_units), class = "pknca_error_internal_pref_unit_setting_bug") # nocov } } diff --git a/R/class-summary_PKNCAresults.R b/R/class-summary_PKNCAresults.R index 00b61f89..7e56d485 100644 --- a/R/class-summary_PKNCAresults.R +++ b/R/class-summary_PKNCAresults.R @@ -291,12 +291,7 @@ get_summary_PKNCAresults_count_N <- function(data, result_group, subject_col, su ret$N <- as.character(ret$N) if (anyNA(ret$N)) { - # nocov start - rlang::abort( - "Please report a bug. If N is requested, but it is not provided, then it should be set to not calculated.", - class = "pknca_error_internal_n_is_na" - ) - # nocov end + rlang::abort("Please report a bug. If N is requested, but it is not provided, then it should be set to not calculated.", class = "pknca_error_internal_n_is_na") # nocov } } else { ret <- result_group @@ -624,30 +619,14 @@ roundingSummarize <- function(x, name) { ret <- roundingInstructions(x) } else if (is.list(roundingInstructions)) { if (length(roundingInstructions) != 1) { - # nocov start - rlang::abort( - sprintf( - "Cannot interpret rounding instructions for %s (please report this as a bug)", - name - ), - class = "pknca_error_internal_rounding_instructions" - ) - # nocov end + rlang::abort(sprintf("Cannot interpret rounding instructions for %s (please report this as a bug)", name), class = "pknca_error_internal_rounding_instructions") # nocov } if ("signif" == names(roundingInstructions)) { ret <- signifString(x, roundingInstructions$signif) } else if ("round" == names(roundingInstructions)) { ret <- roundString(x, roundingInstructions$round) } else { - # nocov start - rlang::abort( - sprintf( - "Invalid rounding instruction list name for %s (please report this as a bug)", - name - ), - class = "pknca_error_internal_invalid_rounding_name" - ) - # nocov end + rlang::abort(sprintf("Invalid rounding instruction list name for %s (please report this as a bug)", name), class = "pknca_error_internal_invalid_rounding_name") # nocov } } if (!is.character(ret)) { diff --git a/R/cleaners.R b/R/cleaners.R index fd7d7d4d..5683f99f 100644 --- a/R/cleaners.R +++ b/R/cleaners.R @@ -132,12 +132,7 @@ clean.conc.blq <- function(conc, time, } else if (time_type == "after.tmax") { mask <- tmax <= ret$time & ret$conc %in% 0 } else { - # nocov start - rlang::abort( - "There is a bug in cleaning the conc.blq with position names", - class = "pknca_error_conc_blq_position_bug" - ) - # nocov end + rlang::abort("There is a bug in cleaning the conc.blq with position names", class = "pknca_error_conc_blq_position_bug") # nocov } # Choose the rule to apply this_rule <- unname(conc.blq)[[i]] @@ -151,15 +146,7 @@ clean.conc.blq <- function(conc, time, } else { # This case should already have been captured by the PKNCA.options # call above. - # nocov start - rlang::abort( - sprintf( - "Unknown how to handle conc.blq rule %s", - as.character(this_rule) - ), - class = "pknca_error_unknown_conc_blq_rule" - ) - # nocov end + rlang::abort(sprintf("Unknown how to handle conc.blq rule %s", as.character(this_rule)), class = "pknca_error_unknown_conc_blq_rule") # nocov } } } diff --git a/R/half.life.R b/R/half.life.R index 04f10862..d0532585 100644 --- a/R/half.life.R +++ b/R/half.life.R @@ -341,10 +341,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, "Too few points for half-life calculation (min.hl.points=%g with only %g points)", min.hl.points, nrow(dfK) ) - rlang::warn( - attr(ret, "exclude"), - class = "pknca_warning_halflife_too_few_points" - ) + rlang::warn(attr(ret, "exclude"), class = "pknca_warning_halflife_too_few_points") } # ---- Tobit method ---- @@ -428,10 +425,7 @@ pk.calc.half.life <- function(conc, time, tmax, tlast, "Too few above-LLOQ points for Tobit half-life (min.hl.points=%g with only %g above-LLOQ points)", min.hl.points, n_above_lloq ) - rlang::warn( - attr(ret, "exclude"), - class = "pknca_warning_halflife_too_few_points_tobit" - ) + rlang::warn(attr(ret, "exclude"), class = "pknca_warning_halflife_too_few_points_tobit") } } diff --git a/R/interpolate.conc.R b/R/interpolate.conc.R index aea15f05..702549cc 100644 --- a/R/interpolate.conc.R +++ b/R/interpolate.conc.R @@ -114,12 +114,7 @@ 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)) { - # nocov start - rlang::abort( - "Please report a bug: tlast is NA; cannot interpolate/extrapolate", - class = "pknca_error_internal_tlast_na" - ) - # nocov end + rlang::abort("Please report a bug: tlast is NA; cannot interpolate/extrapolate", class = "pknca_error_internal_tlast_na") # nocov } else if (is.na(time.out[i])) { rlang::warn("An interpolation/extrapolation time is NA", class = "pknca_warning_timeout_na") } else if (time.out[i] <= tlast) { @@ -316,12 +311,7 @@ extrapolate.conc <- function(conc, time, time.out, ) } } else { - # nocov start - rlang::abort( - "Invalid auc.type caught too late (seeing this error indicates a software bug)", - class = "pknca_error_invalid_auc_type_late" - ) - # nocov end + rlang::abort("Invalid auc.type caught too late (seeing this error indicates a software bug)", class = "pknca_error_invalid_auc_type_late") # nocov } } ret diff --git a/R/parse_formula_to_cols.R b/R/parse_formula_to_cols.R index 41cab253..652a9eba 100644 --- a/R/parse_formula_to_cols.R +++ b/R/parse_formula_to_cols.R @@ -25,12 +25,7 @@ findOperator <- function(x, op, side) { if (identical(x[[1]], op)) { # We found the operator if (length(x) == 1) { - # nocov start - rlang::abort( - "call or formula with length 1 found after finding the operator, unknown how to proceed", - class = "pknca_error_formula_length1_after_op" - ) - # nocov end + rlang::abort("call or formula with length 1 found after finding the operator, unknown how to proceed", class = "pknca_error_formula_length1_after_op") # nocov } else if (length(x) == 2) { # Unary operators have a right hand side only if (side == "left") { diff --git a/R/pk.calc.all.R b/R/pk.calc.all.R index bad5e0cb..72e63a0a 100644 --- a/R/pk.calc.all.R +++ b/R/pk.calc.all.R @@ -125,10 +125,7 @@ pk_nca_result_to_df <- function(group_info, result) { FUN=function(idx) { warning_prep <- ret_warnings$data_result[[idx]] warning_prep$message <- sprintf("%s: %s", warning_preamble[idx], warning_prep$message) - rlang::warn( - warning_prep$message, - class = c("pknca_warning_parameter_calculation", class(warning_prep)) - ) + rlang::warn(warning_prep$message, class = c("pknca_warning_parameter_calculation", class(warning_prep))) } )) } @@ -253,10 +250,7 @@ pk.nca.intervals <- function(data_conc, data_dose, data_intervals, sparse, sep="=", collapse=", ") ) if (nrow(conc_data_interval) == 0) { - rlang::warn( - sprintf("%s: No data for interval", error_preamble), - class = "pknca_warning_no_data_for_interval" - ) + rlang::warn(sprintf("%s: No data for interval", error_preamble), class = "pknca_warning_no_data_for_interval") } else if (!has_calc_sparse_dense) { if (verbose) { rlang::inform( @@ -324,17 +318,7 @@ pk.nca.intervals <- function(data_conc, data_dose, data_intervals, sparse, tryCatch( do.call(pk.nca.interval, args), error = function(e) { - # nocov start - rlang::abort( - sprintf( - "Please report a bug.\n%s: %s", - error_preamble, - e$message - ), - class = "pknca_error_interval_calculation", - parent = e - ) - # nocov end + rlang::abort(sprintf("Please report a bug.\n%s: %s", error_preamble, e$message), class = "pknca_error_interval_calculation", parent = e) # nocov } ) } @@ -445,12 +429,7 @@ pk.nca.interval <- function(conc, time, volume, duration.conc, all_intervals <- get.interval.cols() # Set the dose to NA if its length is zero if (length(dose) == 0) { - # nocov start - rlang::abort( - "Please report a bug. Length of dose should not be zero.", - class = "pknca_error_internal_dose_length_zero" - ) - # nocov end + rlang::abort("Please report a bug. Length of dose should not be zero.", class = "pknca_error_internal_dose_length_zero") # nocov } # Make sure that we calculate all of the dependencies. Do this in # reverse order for dependencies of dependencies. diff --git a/R/pk.calc.simple.R b/R/pk.calc.simple.R index 66cec918..a0bfe61b 100644 --- a/R/pk.calc.simple.R +++ b/R/pk.calc.simple.R @@ -1511,12 +1511,7 @@ pk.calc.ctrough <- function(conc, time, end) { } else { # This should be impossible as assert_conc_time should catch # duplicates. - # nocov start - rlang::abort( - "More than one time matches the starting time. Please report this as a bug with a reproducible example.", - class = "pknca_error_ctrough_multiple_start_times" - ) - # nocov end + rlang::abort("More than one time matches the starting time. Please report this as a bug with a reproducible example.", class = "pknca_error_ctrough_multiple_start_times") # nocov } } add.interval.col("ctrough", @@ -1544,12 +1539,7 @@ pk.calc.cstart <- function(conc, time, start) { } else { # This should be impossible as assert_conc_time should catch # duplicates. - # nocov start - rlang::abort( - "More than one time matches the starting time. Please report this as a bug with a reproducible example.", - class = "pknca_error_cstart_multiple_start_times" - ) - # nocov end + rlang::abort("More than one time matches the starting time. Please report this as a bug with a reproducible example.", class = "pknca_error_cstart_multiple_start_times") # nocov } } add.interval.col("cstart", diff --git a/R/prepare_data.R b/R/prepare_data.R index 022578ea..58ef0be3 100644 --- a/R/prepare_data.R +++ b/R/prepare_data.R @@ -287,10 +287,7 @@ check_reserved_column_names <- function(x) { ngettext(length(overlap), msg1="name", msg2="names"), "and retry." ) - rlang::abort( - msg, - class = "pknca_error_reserved_column_names" - ) + rlang::abort(msg, class = "pknca_error_reserved_column_names") } } diff --git a/R/sparse.R b/R/sparse.R index a3d66f8e..49bff1f8 100644 --- a/R/sparse.R +++ b/R/sparse.R @@ -321,10 +321,7 @@ pk.calc.sparse_auc <- function(conc, time, subject, # argument so it is used consistently below (and so other methods could be # enabled here in the future), but only "linear" is currently allowed. if (!identical(method, "linear")) { - rlang::abort( - 'Sparse AUC calculation only supports `method = "linear"`.', - class = "pknca_error_sparse_auc_method" - ) + rlang::abort('Sparse AUC calculation only supports `method = "linear"`.', class = "pknca_error_sparse_auc_method") } sparse_pk <- as_sparse_pk(conc=conc, time=time, subject=subject) sparse_pk_wt <- sparse_auc_weight_linear(sparse_pk) @@ -540,10 +537,7 @@ pk.calc.sparse_aumc <- function(conc, time, subject, options = list()) { # Sparse AUMC is only defined for linear interpolation (see pk.calc.sparse_auc). if (!identical(method, "linear")) { - rlang::abort( - 'Sparse AUMC calculation only supports `method = "linear"`.', - class = "pknca_error_sparse_aumc_method" - ) + rlang::abort('Sparse AUMC calculation only supports `method = "linear"`.', class = "pknca_error_sparse_aumc_method") } # Create sparse_pk object from data sparse_pk <- as_sparse_pk(conc = conc, time = time, subject = subject) diff --git a/R/superposition.R b/R/superposition.R index 88b81852..32a1b96e 100644 --- a/R/superposition.R +++ b/R/superposition.R @@ -163,12 +163,7 @@ superposition.numeric <- function(conc, time, dose.input = NULL, dose.scaling <- dose.amount / dose.input if (length(dose.scaling) != length(dose.times)) { if (length(dose.scaling) != 1) - # nocov start - rlang::abort( - "bug in dose.amount, dose.times, and dose.input handling", - class = "pknca_error_internal_dose_scaling" - ) - # nocov end + rlang::abort("bug in dose.amount, dose.times, and dose.input handling", class = "pknca_error_internal_dose_scaling") # nocov # it is a scalar and there is more than one dose dose.scaling <- rep(dose.scaling, length(dose.times)) } diff --git a/R/tss.R b/R/tss.R index 8fc392ca..48816568 100644 --- a/R/tss.R +++ b/R/tss.R @@ -122,12 +122,7 @@ pk.tss <- function(..., if (identical(NA, ret)) { ret <- ret_monoexponential } else { - # nocov start - rlang::abort( - "Bug in pk.tss where ret is set to non-NA too early. Please report the bug with a reproducible example.", - class = "pknca_error_internal_pk_tss_ret_non_na" - ) - # nocov end + rlang::abort("Bug in pk.tss where ret is set to non-NA too early. Please report the bug with a reproducible example.", class = "pknca_error_internal_pk_tss_ret_non_na") # nocov } # Set check to FALSE if it has already been checked (so that it # doesn't happen again in stepwise.linear) diff --git a/R/tss.monoexponential.R b/R/tss.monoexponential.R index 6b932dd2..eccdaa20 100644 --- a/R/tss.monoexponential.R +++ b/R/tss.monoexponential.R @@ -90,12 +90,7 @@ pk.tss.monoexponential <- function(..., } else if (!identical(NA, ret_individual)) { ret_individual } else { - # nocov start - rlang::abort( - "Error in selection of return values for pk.tss.monoexponential. This is likely a bug.", - class = "pknca_error_internal_tss_return_selection" - ) - # nocov end + rlang::abort("Error in selection of return values for pk.tss.monoexponential. This is likely a bug.", class = "pknca_error_internal_tss_return_selection") # nocov } ret } @@ -376,12 +371,7 @@ pk.tss.monoexponential.individual <- function(data, } else if ("subject" %in% names(data)) { dplyr::grouped_df(data, vars="subject") } else { - # nocov start - rlang::abort( - "Please report a bug. Subject must be specified to have subject-level fitting", - class = "pknca_error_internal_tss_no_subject_for_individual" - ) - # nocov end + rlang::abort("Please report a bug. Subject must be specified to have subject-level fitting", class = "pknca_error_internal_tss_no_subject_for_individual") # nocov } ret_sub <- dplyr::summarize( diff --git a/R/tss.stepwise.linear.R b/R/tss.stepwise.linear.R index 86df9735..62d4cf9d 100644 --- a/R/tss.stepwise.linear.R +++ b/R/tss.stepwise.linear.R @@ -67,10 +67,7 @@ pk.tss.stepwise.linear <- function(..., while (is.na(ret) & (length(remaining.time) >= min.points)) { if (verbose) { - rlang::inform( - sprintf("Trying %s", min(remaining.time, na.rm = TRUE)), - class = "pknca_message_tss_trying_time" - ) + rlang::inform(sprintf("Trying %s", min(remaining.time, na.rm = TRUE)), class = "pknca_message_tss_trying_time") } try({ # Try to make the model diff --git a/R/unit-support.R b/R/unit-support.R index d29664cd..461fce8a 100644 --- a/R/unit-support.R +++ b/R/unit-support.R @@ -152,12 +152,7 @@ pknca_units_table.default <- function(concu, doseu, amountu, timeu, class = "pknca_error_units_conversions_extra_cols" ) if (any(is.na(conversions$conversion_factor)) && !requireNamespace("units", quietly=TRUE)) { - # nocov start - rlang::abort( - "The units package is required for automatic unit conversion", - class = "pknca_error_missing_units_package" - ) - # nocov end + rlang::abort("The units package is required for automatic unit conversion", class = "pknca_error_missing_units_package") # nocov } for (idx in which(is.na(conversions$conversion_factor))) { conversions$conversion_factor[idx] <- @@ -636,10 +631,7 @@ 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) { - rlang::warn( - msg_missing, - class = "pknca_warning_units_partial_missing" - ) + rlang::warn(msg_missing, class = "pknca_warning_units_partial_missing") } else { rlang::abort( sprintf(