Merge pull request #17 from JoFrhwld/14-refactor-helper-functions

14 refactor helper functions
JoFrhwld · Sep 27, 2023 · b5afbfe · b5afbfe
2 parents 7d45673 + e82c366
commit b5afbfe
Show file tree

Hide file tree

Showing 3 changed files with 129 additions and 102 deletions.
diff --git a/R/data_checks.R b/R/data_checks.R
@@ -0,0 +1,123 @@
+# functions for checking and pre-processing input data
+
+# check that an input variable is numeric
+check_dim_class <- function(x, varname){
+  if(!is.numeric(x)){
+    cli::cli_abort(
+      c("All dimensions must be numeric",
+        "i" = "{.var {varname}} has class {.cls {class(x)}}.")
+    )
+  }
+}
+
+# check that x and y inputs have the same length
+check_dim_size <- function(x, y, xname, yname){
+  if(length(x) != length(y)){
+    xlen = length(x)
+    ylen = length(y)
+    cli::cli_abort(
+      c("Data dimensions must have the same length",
+        "i" = "{.var {xname}} has {xlen} value{?s}.",
+        "i" = "{.var {yname}} has {ylen} value{?s}.")
+    )
+  }
+}
+
+# check for minumum argument size
+check_min_size <- function(x, varname, min_size = 1){
+  if(length(x) < min_size){
+    cli::cli_abort(
+      c("{.var {varname}} must have at least {.val {min_size}} value{?s}.",
+        "i" = "{.var {varname}} has {.val {length(x)}} value{?s}")
+    )
+  }
+}
+
+# check the probabilities
+check_probs <- function(probs) {
+
+  check_dim_class(probs, "probs")
+  check_min_size(probs, "probs", min_size = 1)
+
+  if (!all(is.finite(probs))) {
+    non_finites <- unique(probs[which(!is.finite(probs))])
+    cli::cli_abort(
+      c("All {.var probs} must be finite.",
+        "i" = "{.var probs} included values of {.val {non_finites}}")
+    )
+  }
+
+  if (any(probs <= 0 | probs >= 1)) {
+    n_less <- sum(probs <= 0)
+    n_greater <- sum(probs >= 1)
+    cli::cli_abort(
+      c("All {.var probs} must be greater than 0 and less than 1.",
+        "i" = "{.var probs} contained {n_less} value{?s} <= 0.",
+        "i" = "{.var probs} contained {n_greater} value{?s} >= 1")
+    )
+  }
+
+}
+
+
+# drop na values from input dimensions
+na_filter <- function(...){
+
+  dots <- rlang::dots_list(...)
+  dots_name <- names(dots)
+
+  na_vec <- purrr::map(dots, purrr::negate(is.finite))
+
+  output <- list(
+    filtered = FALSE,
+    values = dots,
+    total  = purrr::map(na_vec, sum)
+  )
+
+
+  if(purrr::reduce(na_vec, any)){
+    na_loc <- purrr::reduce(na_vec, `|`)
+    new_values <- purrr::map(dots, \(x)x[!na_loc])
+    output$filtered <- TRUE
+    output$values <- new_values
+  }
+
+  return(output)
+
+}
+
+
+process_data <- function(x, xname, y, yname, probs){
+
+  check_dim_class(x, xname)
+  check_dim_class(y, yname)
+  check_dim_size(x, y, xname, yname)
+  check_probs(probs)
+
+  na_filtered <- na_filter(x = x, y = y)
+
+  if(na_filtered$filtered){
+    x <- na_filtered$values$x
+    y <- na_filtered$values$y
+
+    x_total <- na_filtered$total$x
+    y_total <- na_filtered$total$y
+    cli::cli_warn(
+      c("Missing and non-finite values dropped",
+        "i" = "{x_total} missing or non-finite value{?s} in {xname}",
+        "i" = "{y_total} missing or non-finite value{?s} in {yname}"
+      )
+    )
+  }
+
+  return(
+    list(
+      x = x,
+      y = y,
+      probs = probs,
+      xname = xname,
+      yname = yname
+    )
+  )
+
+}
diff --git a/R/density_area.R b/R/density_area.R
@@ -97,34 +97,19 @@ density_polygons <- function(x,
   xname <- deparse(substitute(x))
   yname <- deparse(substitute(y))
 
+  processed_data <- process_data(x=x,
+                                 xname = xname,
+                                 y=y,
+                                 yname = yname,
+                                 probs)
 
-  check_dim_class(x, xname)
-  check_dim_class(y, yname)
-  check_dim_size(x, y, xname, yname)
-  check_probs(probs)
+  list2env(processed_data, envir = environment())
 
   nameswap <- c("x", "y")
   names(nameswap) <- vctrs::vec_as_names(c(xname, yname),
                                          repair = "unique",
                                          quiet = TRUE)
 
-  na_filtered <- na_filter(x = x, y = y)
-
-  if(na_filtered$filtered){
-    x = na_filtered$values$x
-    y = na_filtered$values$y
-
-    x_total <- na_filtered$total$x
-    y_total <- na_filtered$total$y
-    cli::cli_warn(
-      c("Missing values dropped",
-        "i" = "{x_total} missing value{?s} in {xname}",
-        "i" = "{y_total} missing value{?s} in {yname}"
-      )
-    )
-  }
-
-
   isolines <- get_isolines_safely(x=x, y=y, probs=probs, ...)
 
   isolines |>

diff --git a/R/helper_funs.R b/R/helper_funs.R
@@ -22,84 +22,3 @@ xyz_to_isolines <- function(data, breaks) {
     levels = breaks[-length(breaks)]
   )
 }
-
-check_dim_class <- function(x, varname){
-  if(!is.numeric(x)){
-    cli::cli_abort(
-      c("All dimensions must be numeric",
-        "i" = "{.var {varname}} has class {.cls {class(x)}}.")
-    )
-  }
-}
-
-check_dim_size <- function(x, y, xname, yname){
-  if(length(x) != length(y)){
-    xlen = length(x)
-    ylen = length(y)
-    cli::cli_abort(
-      c("Data dimensions must have the same length",
-        "i" = "{.var {xname}} has {xlen} value{?s}.",
-        "i" = "{.var {yname}} has {ylen} value{?s}.")
-    )
-  }
-}
-
-check_probs <- function(probs) {
-  if (!is.numeric(probs)) {
-    cli::cli_abort(
-      c("{.var probs} must be numeric",
-        "i" = "{.var probs} has class {.cls {class(probs)}}")
-    )
-  }
-
-  if (!all(is.finite(probs))) {
-    non_finites <- unique(probs[which(!is.finite(probs))])
-    cli::cli_abort(
-      c("All {.var probs} must be finite.",
-        "i" = "{.var probs} included values of {.val {non_finites}}")
-    )
-  }
-
-  if (any(probs <= 0)) {
-    n_less <- sum(probs <= 0)
-    cli::cli_abort(
-      c("All {.var probs} must be greater than 0.",
-        "i" = "{.var probs} contained {n_less} value{?s} <= 0.")
-    )
-  }
-
-  if (any(probs >= 1)) {
-    n_greater <- sum(probs >= 1)
-    cli::cli_abort(
-      c("All {.var probs} must be less than 1.",
-        "i" = "{.var probs} contained {n_greater} value{?s} >= 1")
-    )
-  }
-}
-
-na_filter <- function(...){
-
-  dots <- rlang::dots_list(...)
-  dots_name <- names(dots)
-
-  na_vec <- purrr::map(dots, is.na)
-
-  if(purrr::reduce(na_vec, any)){
-    na_loc <- purrr::reduce(na_vec, `|`)
-    new_values <- purrr::map(dots, \(x)x[!na_loc])
-    output <- list(
-      filtered = TRUE,
-      values = new_values,
-      total  = purrr::map(na_vec, sum)
-    )
-  }else{
-    output <- list(
-      filtered = FALSE,
-      values = dots,
-      total  = purrr::map(na_vec, sum)
-    )
-  }
-
-  return(output)
-
-}