RXR-372: refactor calc_ibw()

R/calc_ibw.R

@@ -25,12 +25,15 @@
 #'   IBW (male) = 50 + (2.3 x height in inches over 5 feet)
 #'   IBW (female) = 45.5 + (2.3 x height in inches over 5 feet)
 #'
-#' @param age age in years, can be vector
-#' @param weight weight in kg, can be vector
-#' @param height height in cm, can be vector
-#' @param sex either `male` or `female`, can be vector
-#' @param method_children method to use for children >1 and <18 years. Choose from `standard`, `mclaren` (McLaren DS, Read WWC. Lancet. 1972;2:146-148.), `moore` (Moore DJ et al. Nutr Res. 1985;5:797-799), `bmi` (), `ada` (American Dietary Association)
-#' @param method_adults method to use for >=18 years. Choose from `devine` (default, Devine BJ. Drug Intell Clin Pharm. 1974;8:650-655).
+#' @param age age in years
+#' @param weight weight in kg
+#' @param height height in cm
+#' @param sex sex
+#' @param method_children method to use for children >1 and <18 years. Currently
+#'   `"standard"` is the only method that is supported.
+#' @param method_adults method to use for >=18 years. Currently `"devine"` is
+#'   the only method that is supported (Devine BJ. Drug Intell Clin Pharm.
+#'   1974;8:650-655).
 #' @param digits number of decimals (can be NULL to for no rounding)
 #' @examples
 #' calc_ibw(weight = 70, height = 170, age = 40, sex = "female")
@@ -45,75 +48,95 @@ calc_ibw <- function (
   method_adults = "devine",
   digits = NULL
 ) {
-  available_methods_children <- c("standard") # c("moore", "mclaren", "bmi", "ada")
-  method_children <- tolower(method_children)
-  if(!(method_children %in% available_methods_children)) {
-    stop("Specified method for children not available.")
-  }
-  available_methods_adults <- c("devine")
-  method_adults <- tolower(method_adults)
-  if(!(method_adults %in% available_methods_adults)) {
-    stop("Specified method for adults not available.")
-  }
+  method_children <- match.arg(method_children)
+  method_adults <- match.arg(method_adults)
   if(is.null(age)) {
     stop("Age not specified!")
   }
-  if(length(weight > 1)) {
-    if(length(height) != length(weight)) {
-      message("Height and weight do not have same vector lenght, using only first height.")
-      height <- rep(height[1], length(weight))
-    }
-    if(length(age) != length(weight)) {
-      message("Age and weight do not have same vector lenght, using only first age.")
-      age <- rep(age[1], length(weight))
-    }
-    if(length(sex) != length(weight)) {
-      message("Sex and weight do not have same vector lenght, using only first sex.")
-      sex <- rep(sex[1], length(weight))
-    }
-  }
+  stopifnot(
+    length(age) == 1,
+    length(height) <= 1, # these are not always
+    length(weight) <= 1, # required, so may be
+    length(sex) <= 1     # NULL or length 1
+  )
 
   ## babies
-  ibw <- rep(0, length(weight))
-  if(any(age < 1)) {
+  if (age < 1) {
     if (is.null(weight)) {
       stop("Actual body weight is used as IBW for children < 1yr. Please supply a weight value.")
     }
     message("Note: using actual body weight as IBW for children < 1yr.")
-    ibw[age < 1] <- weight[age < 1]
+    return(weight)
   }
 
-  ## children
-  ht <- cm2inch(height)
-  if(any(age >= 1 & age < 18)) {
-    if(method_children == "standard") {
-      if(any(is.null(height) || is.null(age) || is.null(sex))) {
-        ibw[age >= 1 & age < 18 & (is.null(height) || is.null(age) || is.null(sex))] <- NA
-        message("Height, age and sex are required!")
-      }
-      ibw[age >= 1 & age < 18 & ht < 5*12] <- (height[age >= 1 & age < 18 & ht < 5*12]^2 * 1.65)/1000
-      ibw[age >= 1 & age < 18 & ht >= 5*12] <-
-        (39   + 2.27 * (ht[age >= 1 & age < 18 & ht >= 5*12]-(5*12))) * (sex[age >= 1 & age < 18 & ht >= 5*12]=="male") +
-        (42.2 + 2.27 * (ht[age >= 1 & age < 18 & ht >= 5*12]-(5*12))) * (sex[age >= 1 & age < 18 & ht >= 5*12]=="female")
-    }
+  if (age >= 1 & age < 18) {
+    ibw <- switch(
+      method_children,
+      "standard" = ibw_standard(age = age, height = height, sex = sex)
+    )
+  } else {
+    ibw <- switch(
+      method_adults,
+      "devine" = ibw_devine(age = age, height = height, sex = sex)
+    )
   }
 
-  ## adults
-  if(any(age >= 18)) {
-    if(method_adults == "devine") {
-      if(any(is.null(height) || is.null(sex))) {
-        ibw[age >= 18 & (is.null(height) || is.null(sex))] <- NA
-        message("Height and sex are required to calculate!")
-      }
-      ibw[age >= 18] <-
-        (50 + (2.3 * (ht[age >= 18]-(5*12)))) * (sex[age >= 18] == "male") +
-        (45.5 + (2.3 * (ht[age >= 18]-(5*12)))) * (sex[age >= 18] == "female")
-    }
+  if (!is.null(digits)) {
+    ibw <- round(ibw, digits = digits)
   }
 
-  if(!is.null(digits)) {
-    ibw <- round(ibw, digits=digits)
+  return(ibw)
+}
+
+#' Calculate IBW using "standard" equation
+#'
+#' @inheritParams calc_ibw
+ibw_standard <- function(age, height = NULL, sex = NULL) {
+  if (is.null(age) || age >= 18 || age < 1) {
+    stop("Age must be >=1 and <18")
+  }
+  if (is.null(height) || is.na(height)) {
+    message("Height is required to calculate IBW")
+    return(NA)
+  }
+  height_in <- cm2inch(height)
+  if (height_in < 5 * 12) {
+    return((height^2 * 1.65) / 1000)
   }
+  if (is.null(sex) || is.na(sex) || !sex %in% c("male", "female")) {
+    message("The `standard` method for calculating IBW requires sex to be 'male' or 'female' for children 5 feet tall or taller.")
+    return(NA)
+  }
+  base_value <- switch(
+    sex,
+    "male" = 39,
+    "female" = 42.2
+  )
+  height_inches_over_5_feet <- height_in - (5 * 12)
+  base_value + (2.27 * height_inches_over_5_feet)
+}
 
-  return(ibw)
+#' Calculate IBW using "devine" equation
+#'
+#' @inheritParams calc_ibw
+ibw_devine <- function(age, height = NULL, sex = NULL) {
+  if (age < 18) {
+    stop("Age must be >= 18 for the Devine equation")
+  }
+  if (is.null(height) || is.na(height)) {
+    message("Height is required to calculate IBW")
+    return(NA)
+  }
+  if (is.null(sex) || is.na(sex) || !sex %in% c("male", "female")) {
+    message("The `devine` method for calculating IBW requires sex to be 'male' or 'female'.")
+    return(NA)
+  }
+  base_value <- switch(
+    sex,
+    "male" = 50,
+    "female" = 45.5
+  )
+  height_in <- cm2inch(height)
+  height_inches_over_5_feet <- height_in - (5 * 12)
+  base_value + (2.3 * height_inches_over_5_feet)
 }

tests/testthat/test_calc_ibw.R

@@ -1,4 +1,4 @@
-test_that("IBW errors when no height specified", {
+test_that("IBW errors when no age specified", {
   expect_error(calc_ibw(weight = 80))
   expect_error(calc_ibw(weight = NULL))
 })
@@ -11,3 +11,92 @@ test_that("IBW calculation works", {
 test_that("calc_ibw() throws error if weight is missing but needed", {
   expect_error(calc_ibw(age = 0.03, height = 40))
 })
+
+test_that("calc_ibw() errors if method doesn't match allowed", {
+  expect_error(calc_ibw(method_children = "foo"))
+  expect_error(calc_ibw(method_adults = "foo"))
+})
+
+test_that("calc_ibw errors if passed a vector", {
+  expect_error(
+    calc_ibw(age = c(10, 20), sex = c("male", "female"), height = 100, 130)
+  )
+})
+
+test_that("calc_ibw() uses weight when age < 1", {
+  expect_equal(
+    expect_message(calc_ibw(age = 0.5, weight = 7)),
+    7
+  )
+})
+
+test_that("calc_ibw() can round output", {
+  expect_equal(
+    calc_ibw(age = 40, height = 180, sex = "female", digits = 1),
+    70.5
+  )
+})
+
+test_that("ibw_standard only supports children and requires age", {
+  expect_error(ibw_standard(age = 25))
+  expect_error(ibw_standard(age = NULL))
+})
+
+test_that("ibw_standard returns NA and message if missing data", {
+  res1 <- expect_message(ibw_standard(age = 10, height = NA))
+  res2 <- expect_message(ibw_standard(age = 10, height = NULL))
+  expect_true(is.na(res1))
+  expect_true(is.na(res2))
+
+  res3 <- expect_message(ibw_standard(age = 17, height = 165))
+  res4 <- expect_message(
+    ibw_standard(age = 17, height = 165, sex = "unknown")
+  )
+  expect_true(is.na(res3))
+  expect_true(is.na(res4))
+})
+
+test_that("ibw_standard doesn't require sex if height < 5ft", {
+  expect_equal(ibw_standard(age = 14, height = 150), 37.125)
+})
+
+test_that("ibw_standard calculates correct IBW", {
+  expect_equal(
+    ibw_standard(age = 15, height = 160, sex = "female"),
+    48.992126
+  )
+  expect_equal(
+    ibw_standard(age = 15, height = 160, sex = "male"),
+    45.792126
+  )
+})
+
+test_that("ibw_devine only supports adults and requires age", {
+  expect_error(ibw_devine(age = 15))
+  expect_error(ibw_devine(age = NULL))
+})
+
+test_that("ibw_devine returns NA and message if missing data", {
+  res1 <- expect_message(ibw_devine(age = 20, height = NA))
+  res2 <- expect_message(ibw_devine(age = 20, height = NULL))
+  expect_true(is.na(res1))
+  expect_true(is.na(res2))
+
+  res3 <- expect_message(ibw_devine(age = 30, height = 165))
+  res4 <- expect_message(
+    ibw_devine(age = 30, height = 165, sex = "unknown")
+  )
+  expect_true(is.na(res3))
+  expect_true(is.na(res4))
+})
+
+test_that("ibw_devine calculates correct IBW", {
+  expect_equal(
+    ibw_devine(age = 20, height = 160, sex = "female"),
+    52.381890
+  )
+  expect_equal(
+    ibw_devine(age = 20, height = 160, sex = "male"),
+    56.881890
+  )
+})