Closes #2571 transform_range: implement transform_range()

.lintr

@@ -3,7 +3,7 @@ linters: linters_with_defaults(
     object_usage_linter=NULL,
     cyclocomp_linter(complexity_limit = 22),
     indentation_linter=NULL,
-    undesirable_function_linter = undesirable_function_linter()
+    undesirable_function_linter = undesirable_function_linter(symbol_is_undesirable = FALSE)
   )
 exclusions: list(
     "R/data.R" = Inf,

NAMESPACE

@@ -155,6 +155,7 @@ export(restrict_derivation)
 export(set_admiral_options)
 export(signal_duplicate_records)
 export(slice_derivation)
+export(transform_range)
 export(use_ad_template)
 export(yn_to_numeric)
 import(admiraldev)
@@ -166,6 +167,7 @@ importFrom(cli,cli_text)
 importFrom(cli,cli_warn)
 importFrom(dplyr,across)
 importFrom(dplyr,arrange)
+importFrom(dplyr,between)
 importFrom(dplyr,bind_cols)
 importFrom(dplyr,bind_rows)
 importFrom(dplyr,case_when)

NEWS.md

@@ -6,6 +6,8 @@
 `AVALCATx` & `AVALCAxN`. (#2480)
 - New function `derive_vars_crit_flag()` for deriving criterion flag variables
 (`CRITy`, `CRITyFL`, `CRITyFLN`). (#2468)
+- New function `transform_scale()`  to transform values from a source range to a
+target range. (#2571)
 - Replace use of `data("sdtm")` with `sdtm <- pharmaverse::sdtm` in templates and vignettes. (#2498)
 
 - Remove `dthcaus_source()` calls in `ADSL` template because they are deprecated. (#2517)

R/admiral-package.R

@@ -2,11 +2,11 @@
 #' @family internal
 #' @import admiraldev
 #' @importFrom cli cli_abort ansi_collapse cli_div cli_inform cli_text cli_warn
-#' @importFrom dplyr across arrange bind_cols bind_rows case_when coalesce
-#'             desc distinct ends_with everything filter first full_join
-#'             group_by group_by_at if_else mutate n n_distinct na_if pull
-#'             rename rename_with row_number select semi_join slice starts_with
-#'             summarise summarise_all tibble tribble ungroup union lag
+#' @importFrom dplyr across arrange between bind_cols bind_rows case_when
+#'   coalesce desc distinct ends_with everything filter first full_join group_by
+#'   group_by_at if_else mutate n n_distinct na_if pull rename rename_with
+#'   row_number select semi_join slice starts_with summarise summarise_all
+#'   tibble tribble ungroup union lag
 #' @importFrom hms as_hms
 #' @importFrom lifecycle deprecate_warn deprecate_stop deprecated
 #' @importFrom lubridate %--% as_datetime ceiling_date date days duration

R/compute_scale.R

@@ -74,8 +74,8 @@ compute_scale <- function(source,
                           flip_direction = FALSE,
                           min_n = 1) {
   # Function argument checks
-  assert_numeric_vector(source) # nolint: undesirable_function_linter
-  assert_numeric_vector(source_range, optional = TRUE)
+  assert_numeric_vector(source)
+  assert_numeric_vector(source_range, length = 2, optional = TRUE)
   if (!is.null(target_range) && is.null(source_range)) {
     cli_abort(
       c("Argument {.arg source_range} is missing with no default
@@ -84,7 +84,7 @@ compute_scale <- function(source,
       )
     )
   }
-  assert_numeric_vector(target_range, optional = TRUE)
+  assert_numeric_vector(target_range, length = 2, optional = TRUE)
   if (!is.null(source_range) && is.null(target_range)) {
     cli_abort(
       c("Argument {.arg target_range} is missing with no default
@@ -97,19 +97,16 @@ compute_scale <- function(source,
   assert_integer_scalar(min_n, subset = "positive")
 
   # Computation
-  if (sum(!is.na(source)) >= min_n) { # nolint: undesirable_function_linter
-    target <- mean(source, na.rm = TRUE) # nolint: undesirable_function_linter
+  if (sum(!is.na(source)) >= min_n) {
+    target <- mean(source, na.rm = TRUE)
 
     if (!is.null(source_range) && !is.null(target_range)) {
-      scale_constant <- min(target_range) - min(source_range)
-      scale_coefficient <- (max(target_range) - min(target_range)) /
-        (max(source_range) - min(source_range))
-
-      target <- (target + scale_constant) * scale_coefficient
-
-      if (flip_direction == TRUE) {
-        target <- max(target_range) - target
-      }
+      target <- transform_range(
+        target,
+        source_range = source_range,
+        target_range = target_range,
+        flip_direction = flip_direction
+      )
     }
   } else {
     target <- NA

R/transform_range.R

@@ -0,0 +1,114 @@
+#' Transform Range
+#'
+#' Transforms results from the source range to the target range. For example,
+#' for transforming source values 1, 2, 3, 4, 5 to 0, 25, 50, 75, 100.
+#'
+#' @param source A vector of values to be transformed
+#'
+#'   A numeric vector is expected.
+#'
+#' @param source_range The permitted source range
+#'
+#'   A numeric vector containing two elements is expected, representing the
+#'   lower and upper bounds of the permitted source range.
+#'
+#' @param target_range The target range
+#'
+#'   A numeric vector containing two elements is expected, representing the
+#'   lower and upper bounds of the target range.
+#'
+#' @param flip_direction Flip direction of the range?
+#'
+#'   The transformed values will be reversed within the target range, e.g.
+#'   within the range 0 to 100, 25 would be reversed to 75.
+#'
+#'   *Permitted Values*: `TRUE`, `FALSE`
+#'
+#' @param outside_range Handling of values outside the source range
+#'
+#'   Values outside the source range (`source_range`) are transformed to `NA`.
+#'
+#'   If `"warning"` or `"error"` is specified, a warning or error is issued if
+#'   `source` includes any values outside the source range.
+#'
+#'   *Permitted Values*: `"NA"`, `"warning"`, `"error"`
+#'
+#' @details Returns the values of `source` linearly transformed from the source
+#'   range (`source_range`) to the target range (`target_range`). Values outside
+#'   the source range are set to `NA`.
+#'
+#' @return The source linearly transformed to the target range
+#'
+#' @keywords com_bds_findings
+#'
+#' @family com_bds_findings
+#'
+#' @export
+#'
+#' @examples
+#' transform_range(
+#'   source = c(1, 4, 3, 6, 5),
+#'   source_range = c(1, 5),
+#'   target_range = c(0, 100)
+#' )
+#'
+#' transform_range(
+#'   source = c(1, 4, 3, 6, 5),
+#'   source_range = c(1, 5),
+#'   target_range = c(0, 100),
+#'   flip_direction = TRUE
+#' )
+transform_range <- function(source,
+                            source_range,
+                            target_range,
+                            flip_direction = FALSE,
+                            outside_range = "NA") {
+  # Function argument checks
+  assert_numeric_vector(source)
+  assert_numeric_vector(source_range, length = 2)
+  assert_numeric_vector(target_range, length = 2)
+  assert_logical_scalar(flip_direction)
+  assert_character_scalar(outside_range, values = c("NA", "error", "warning"))
+
+  outsider <- !(between(source, source_range[[1]], source_range[[2]]) | is.na(source))
+  if (any(outsider)) {
+    outside_index <- which(outsider)
+    outside_value <- source[outsider]
+    source <- if_else(outsider, NA, source)
+    msg <- c(
+      paste(
+        "{.arg source} contains values outside the range of {.val {source_range[[1]]}}",
+        "to {.val {source_range[[2]]}}:"
+      ),
+      paste0("source[[", outside_index, "]] = {.val {", outside_value, "}}")
+    )
+    if (outside_range == "warning") {
+      cli_warn(
+        msg,
+        class = c("outside_source_range", "assert-admiral"),
+        outside_index = outside_index,
+        outside_value = outside_value
+      )
+    } else if (outside_range == "error") {
+      cli_abort(
+        msg,
+        class = c("outside_source_range", "assert-admiral"),
+        outside_index = outside_index,
+        outside_value = outside_value
+      )
+    }
+  }
+
+  # Computation
+  range_constant <- min(target_range) - min(source_range)
+  range_coefficient <- (max(target_range) - min(target_range)) /
+    (max(source_range) - min(source_range))
+
+  target <- (source + range_constant) * range_coefficient
+
+  if (flip_direction == TRUE) {
+    target <- max(target_range) - target
+  }
+
+  target
+}