diff --git a/NAMESPACE b/NAMESPACE index ced3370..9d54558 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,7 +3,6 @@ export(derive_param_waisthgt) export(derive_param_waisthip) importFrom(admiral,derive_param_computed) -importFrom(admiraldev,"%notin%") importFrom(admiraldev,assert_character_scalar) importFrom(admiraldev,assert_character_vector) importFrom(admiraldev,assert_data_frame) @@ -12,6 +11,7 @@ importFrom(admiraldev,assert_filter_cond) importFrom(admiraldev,assert_logical_scalar) importFrom(admiraldev,assert_numeric_vector) importFrom(admiraldev,assert_param_does_not_exist) +importFrom(admiraldev,assert_unit) importFrom(admiraldev,assert_vars) importFrom(admiraldev,assert_varval_list) importFrom(admiraldev,expect_dfs_equal) @@ -71,7 +71,6 @@ importFrom(lubridate,ymd) importFrom(lubridate,ymd_hms) importFrom(magrittr,"%>%") importFrom(purrr,discard_at) -importFrom(rlang,"%||%") importFrom(rlang,":=") importFrom(rlang,.data) importFrom(rlang,abort) diff --git a/R/admiralmetabolic-package.R b/R/admiralmetabolic-package.R index 5b35a9e..6ade8b8 100644 --- a/R/admiralmetabolic-package.R +++ b/R/admiralmetabolic-package.R @@ -1,9 +1,9 @@ #' @keywords internal #' @family internal -#' @importFrom admiraldev %notin% assert_numeric_vector assert_character_scalar -#' assert_logical_scalar assert_data_frame assert_vars assert_varval_list -#' assert_filter_cond assert_param_does_not_exist assert_expr expect_dfs_equal -#' assert_character_vector +#' @importFrom admiraldev assert_numeric_vector assert_character_scalar assert_logical_scalar +#' assert_data_frame assert_vars assert_varval_list assert_filter_cond +#' assert_param_does_not_exist assert_expr expect_dfs_equal assert_character_vector +#' assert_unit #' @importFrom admiral derive_param_computed #' @importFrom cli cli_abort cli_alert_info #' @importFrom dplyr arrange bind_rows case_when desc ends_with filter full_join group_by @@ -12,7 +12,7 @@ #' summarise_at summarise coalesce bind_cols na_if tibble tribble #' @importFrom magrittr %>% #' @importFrom purrr discard_at -#' @importFrom rlang := %||% abort arg_match as_function as_string call2 caller_env +#' @importFrom rlang := abort arg_match as_function as_string call2 caller_env #' call_name current_env .data enexpr enexprs enquo eval_bare eval_tidy expr #' exprs expr_interp expr_label f_lhs f_rhs inform #' is_bare_formula is_call is_character is_formula is_integerish diff --git a/R/assertions.R b/R/assertions.R deleted file mode 100644 index 024c635..0000000 --- a/R/assertions.R +++ /dev/null @@ -1,63 +0,0 @@ -#' Asserts That a Parameter is Provided in One of the Expected Units -#' -#' @description -#' `r lifecycle::badge("deprecated")` -#' -#' This function is to be *deprecated*. Please use `admiraldev::assert_unit()` instead -#' once https://github.com/pharmaverse/admiraldev/issues/468 is closed. -#' -#' @inherit admiraldev::assert_unit -#' -#' @seealso [admiraldev::assert_unit] -#' -#' @examples -#' # See examples of `admiraldev::assert_unit` -#' -#' @family internal deprecated -#' @keywords internal deprecated -assert_unit <- function(dataset, - param, - required_unit, - get_unit_expr, - arg_name = rlang::caller_arg(required_unit), - message = NULL, - class = "assert_unit", - call = parent.frame()) { - assert_data_frame(dataset, required_vars = exprs(PARAMCD)) - assert_character_scalar(param) - assert_character_vector(required_unit) - get_unit_expr <- enexpr(get_unit_expr) - - units <- dataset %>% - mutate(tmp_unit = !!get_unit_expr) %>% - filter(PARAMCD == param & !is.na(.data$tmp_unit)) %>% - pull(.data$tmp_unit) %>% - unique() - - if (length(units) != 1L) { - message <- - message %||% - "Multiple units {.val {units}} found for {.val {param}}. Please review and update the units." - - cli_abort( - message = message, - call = call, - class = c(class, "assert-admiraldev") - ) - } - - if (tolower(units) %notin% tolower(required_unit)) { - message <- - message %||% - "It is expected that {.val {param}} has unit of {.or {required_unit}}. - In the input dataset the unit is {.val {units}}." - - cli_abort( - message = message, - call = call, - class = c(class, "assert-admiraldev") - ) - } - - invisible(dataset) -} diff --git a/R/derive_advs_params.R b/R/derive_advs_params.R index 2651c28..b86850c 100644 --- a/R/derive_advs_params.R +++ b/R/derive_advs_params.R @@ -161,7 +161,8 @@ derive_param_waisthip <- function(dataset, denominator_code = hipcir_code, by_vars = by_vars, set_values_to = set_values_to, - get_unit_expr = !!get_unit_expr + get_unit_expr = !!get_unit_expr, + unit_conversion = TRUE ) } @@ -373,7 +374,8 @@ derive_param_waisthgt <- function(dataset, constant_numerator = FALSE, constant_denominator = !is.null(constant_by_vars), constant_by_vars = constant_by_vars, - get_unit_expr = !!get_unit_expr + get_unit_expr = !!get_unit_expr, + unit_conversion = TRUE ) } @@ -465,6 +467,12 @@ derive_param_waisthgt <- function(dataset, #' #' *Permitted Values:* A variable of the input dataset or a function call #' +#' @param unit_conversion Enable/Disable unit conversion +#' +#' Unit conversion is disabled by default. Ignored if `get_unit_expr` is `NULL`. +#' +#' *Permitted Values:* logical scalar +#' #' @inheritParams admiral::derive_param_computed #' #' @details @@ -486,7 +494,8 @@ derive_param_ratio <- function(dataset, constant_denominator = FALSE, filter = NULL, constant_by_vars = NULL, - get_unit_expr = NULL) { + get_unit_expr = NULL, + unit_conversion = FALSE) { assert_vars(by_vars) assert_data_frame(dataset, required_vars = exprs(!!!by_vars, PARAMCD, AVAL)) assert_character_scalar(numerator_code) @@ -498,6 +507,7 @@ derive_param_ratio <- function(dataset, filter <- assert_filter_cond(enexpr(filter), optional = TRUE) assert_vars(constant_by_vars, optional = TRUE) get_unit_expr <- assert_expr(enexpr(get_unit_expr), optional = TRUE) + assert_logical_scalar(unit_conversion) if (constant_numerator && constant_denominator) { cli_abort( @@ -514,7 +524,7 @@ derive_param_ratio <- function(dataset, ### If `get_unit_expr` provided then check units and enable units conversion ---- - if (!missing(get_unit_expr) && !is.null(get_unit_expr)) { + if (unit_conversion && !missing(get_unit_expr) && !is.null(get_unit_expr)) { # If the input parameters are measured in different units # but are convertible from one to another (and this kind of conversion supported) # then modify the formula in order to perform units conversion on the fly @@ -531,19 +541,18 @@ derive_param_ratio <- function(dataset, param_units[[numerator_code]] ) - if (!is.na(conv_factor)) { - ratio_formula <- expr( - !!sym(paste0("AVAL.", numerator_code)) / ( - !!sym(paste0("AVAL.", denominator_code)) * !!conv_factor - ) + # Adjust formula + ratio_formula <- expr( + !!sym(paste0("AVAL.", numerator_code)) / ( + !!sym(paste0("AVAL.", denominator_code)) * !!conv_factor ) + ) - cli_alert_info( - "ALERT: Unit conversion performed for {.val {denominator_code}}. Values converted from - {.val {param_units[[denominator_code]]}} to {.val {param_units[[numerator_code]]}}.", - wrap = TRUE - ) - } + cli_alert_info( + "ALERT: Unit conversion performed for {.val {denominator_code}}. Values converted from + {.val {param_units[[denominator_code]]}} to {.val {param_units[[numerator_code]]}}.", + wrap = TRUE + ) } } @@ -591,7 +600,7 @@ NULL #> NULL #' @description `get_conv_factor()` extracts a conversion factor for a pair of units. -#' Returns `NA` if units are not supported/convertible. +#' Fails with error if units are not supported/convertible. #' #' @rdname unit-conversion #' @keywords internal @@ -599,18 +608,25 @@ get_conv_factor <- function(from_unit, to_unit) { # Get all conversion factors supported conv_factors_all <- get_conv_factors_all() - # Return conversion factor if units are supported and convertible + # Look up for a conversion factor if units are supported and convertible + conv_factor <- NULL + for (unit_category in names(conv_factors_all)) { if (all(c(from_unit, to_unit) %in% names(conv_factors_all[[unit_category]]))) { - return( - conv_factors_all[[unit_category]][[from_unit]] / - conv_factors_all[[unit_category]][[to_unit]] - ) + conv_factor <- conv_factors_all[[unit_category]][[from_unit]] / + conv_factors_all[[unit_category]][[to_unit]] } } - # If units are not supported/convertible - return(NA_real_) + # Fail if conversion for the provided units is not supported + if (is.null(conv_factor)) { + cli_abort( + "Conversion for a pair of units {.val {c(from_unit, to_unit)}} is not supported." + ) + } + + # Return conversion factor + conv_factor } #' @description `get_conv_factors_all()` returns all conversion factors supported. diff --git a/man/assert_unit.Rd b/man/assert_unit.Rd deleted file mode 100644 index a8d7981..0000000 --- a/man/assert_unit.Rd +++ /dev/null @@ -1,69 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/assertions.R -\name{assert_unit} -\alias{assert_unit} -\title{Asserts That a Parameter is Provided in One of the Expected Units} -\usage{ -assert_unit( - dataset, - param, - required_unit, - get_unit_expr, - arg_name = rlang::caller_arg(required_unit), - message = NULL, - class = "assert_unit", - call = parent.frame() -) -} -\arguments{ -\item{dataset}{A \code{data.frame}} - -\item{param}{Parameter code of the parameter to check} - -\item{required_unit}{Expected unit} - -\item{get_unit_expr}{Expression used to provide the unit of \code{param}} - -\item{arg_name}{string indicating the label/symbol of the object being checked.} - -\item{message}{string passed to \code{cli::cli_abort(message)}. -When \code{NULL}, default messaging is used (see examples for default messages). -\code{"{arg_name}"} can be used in messaging.} - -\item{class}{Subclass of the condition.} - -\item{call}{The execution environment of a currently running -function, e.g. \code{call = caller_env()}. The corresponding function -call is retrieved and mentioned in error messages as the source -of the error. - -You only need to supply \code{call} when throwing a condition from a -helper function which wouldn't be relevant to mention in the -message. - -Can also be \code{NULL} or a \link[rlang:topic-defuse]{defused function call} to -respectively not display any call or hard-code a code to display. - -For more information about error calls, see \ifelse{html}{\link[rlang:topic-error-call]{Including function calls in error messages}}{\link[rlang:topic-error-call]{Including function calls in error messages}}.} -} -\value{ -The function throws an error if the unit variable differs from the -unit for any observation of the parameter in the input dataset. Otherwise, the -dataset is returned invisibly. -} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} - -This function is to be \emph{deprecated}. Please use \code{admiraldev::assert_unit()} instead -once https://github.com/pharmaverse/admiraldev/issues/468 is closed. -} -\examples{ -# See examples of `admiraldev::assert_unit` - -} -\seealso{ -\link[admiraldev:assert_unit]{admiraldev::assert_unit} -} -\concept{internal deprecated} -\keyword{deprecated} -\keyword{internal} diff --git a/man/derive_param_ratio.Rd b/man/derive_param_ratio.Rd index 2461f86..be9fb32 100644 --- a/man/derive_param_ratio.Rd +++ b/man/derive_param_ratio.Rd @@ -14,7 +14,8 @@ derive_param_ratio( constant_denominator = FALSE, filter = NULL, constant_by_vars = NULL, - get_unit_expr = NULL + get_unit_expr = NULL, + unit_conversion = FALSE ) } \arguments{ @@ -113,6 +114,12 @@ conversion will be performed in order to uniform the values before calculating t \if{html}{\out{
}}\emph{ft} is defined as 30.48 cm \emph{Permitted Values:} A variable of the input dataset or a function call} + +\item{unit_conversion}{Enable/Disable unit conversion + +Unit conversion is disabled by default. Ignored if \code{get_unit_expr} is \code{NULL}. + +\emph{Permitted Values:} logical scalar} } \value{ The input dataset with the new parameter added. Note, a variable will only diff --git a/man/unit-conversion.Rd b/man/unit-conversion.Rd index 8210026..1a37131 100644 --- a/man/unit-conversion.Rd +++ b/man/unit-conversion.Rd @@ -12,7 +12,7 @@ get_conv_factors_all() } \description{ \code{get_conv_factor()} extracts a conversion factor for a pair of units. -Returns \code{NA} if units are not supported/convertible. +Fails with error if units are not supported/convertible. \code{get_conv_factors_all()} returns all conversion factors supported. diff --git a/tests/testthat/test-derive_param_ratio.R b/tests/testthat/test-derive_param_ratio.R index 9acb368..a1bd8be 100644 --- a/tests/testthat/test-derive_param_ratio.R +++ b/tests/testthat/test-derive_param_ratio.R @@ -175,7 +175,8 @@ test_that( PARAMCD = "WAISTHIP", PARAM = "Waist to Hip Ratio" ), - get_unit_expr = admiral::extract_unit(PARAM) + get_unit_expr = admiral::extract_unit(PARAM), + unit_conversion = TRUE ) %>% filter(PARAMCD == "WAISTHIP") diff --git a/tests/testthat/test-get_conv_factor.R b/tests/testthat/test-get_conv_factor.R index cc5474d..0f04b9a 100644 --- a/tests/testthat/test-get_conv_factor.R +++ b/tests/testthat/test-get_conv_factor.R @@ -13,8 +13,7 @@ test_that("get_conv_factor Test 2: Indirect conversion factor for length (via cm }) test_that("get_conv_factor Test 3: Inconvertible units", { - expect_equal( - get_conv_factor("cm", "kg"), - NA_real_ + expect_error( + get_conv_factor("cm", "kg") ) })