Merge pull request #19 from JoFrhwld/12-tidy-up-argument-passage

12 tidy up argument passage

R/data_checks.R

@@ -23,7 +23,7 @@ check_dim_size <- function(x, y, xname, yname){
   }
 }
 
-# check for minumum argument size
+# check for minimum argument size
 check_min_size <- function(x, varname, min_size = 1){
   if(length(x) < min_size){
     cli::cli_abort(
@@ -33,19 +33,34 @@ check_min_size <- function(x, varname, min_size = 1){
   }
 }
 
-# check the probabilities
-check_probs <- function(probs) {
+# check for maximum argument size
+check_max_size <- function(x, varname, max_size = 1){
+  if(length(x) > max_size){
+    cli::cli_abort(
+      c("{.var {varname}} must have no more than {.val {max_size}} value{?s}.",
+        "i" = "{.var {varname}} has {.val {length(x)}} value{?s}")
+    )
+  }
+}
 
-  check_dim_class(probs, "probs")
-  check_min_size(probs, "probs", min_size = 1)
+# check finite
 
-  if (!all(is.finite(probs))) {
-    non_finites <- unique(probs[which(!is.finite(probs))])
+check_finite <- function(x, varname){
+  if(!all(is.finite(x))){
+    non_finites <- unique(x[which(!is.finite(x))])
     cli::cli_abort(
-      c("All {.var probs} must be finite.",
-        "i" = "{.var probs} included values of {.val {non_finites}}")
+      c("All values of {.var {varname}} must be finite.",
+        "i" = "{.var {varname}} included values of {.val {non_finites}}")
     )
   }
+}
+
+# check the probabilities
+check_probs <- function(probs) {
+
+  check_dim_class(probs, "probs")
+  check_min_size(probs, "probs", min_size = 1)
+  check_finite(probs, "probs")
 
   if (any(probs <= 0 | probs >= 1)) {
     n_less <- sum(probs <= 0)
@@ -121,3 +136,72 @@ process_data <- function(x, xname, y, yname, probs){
   )
 
 }
+
+# process ranges
+
+expand_range <- function(x, mult = 0.25){
+  data_range <- range(x)
+  range_diff <- diff(data_range)
+  out_range <- ((range_diff * mult) * c(-1, 1)) + data_range
+  return(out_range)
+}
+
+process_ranges <- function(x, y, rangex, rangey, range_mult){
+  is_def <- c(!is.null(rangex), !is.null(rangey))
+  mult_def <- !is.null(range_mult)
+
+  if(xor(is_def[1], is_def[2])){
+    range_names = c("rangex", "rangey")
+    cli::cli_warn(
+      c("{.var {range_names[is_def]}} was defined but {.var {range_names[!is_def]}} was not.")
+    )
+  }
+
+  if(all(is_def) & mult_def){
+    cli::cli_warn(
+      c("{.var rangey}, {.var rangey}, and {.var range_mult} all defined.",
+        "i" = "{.var range_mult} will be disregarded.")
+    )
+  }
+
+  if(!all(is_def) & mult_def){
+    check_finite(range_mult, "range_mult")
+    check_max_size(range_mult, "range_mult", max_size = 1)
+    check_min_size(range_mult, "range_mult", min_size = 1)
+  }
+
+  if(!is.null(rangex)){
+    check_finite(rangex, "rangex")
+    check_min_size(rangex,"rangex", min_size = 2)
+    check_max_size(rangex, "rangex", max_size = 2)
+  }
+
+  if(!is.null(rangey)){
+    check_finite(rangey, "rangey")
+    check_min_size(rangey, "rangey", min_size = 2)
+    check_max_size(rangey, "rangey", max_size = 2)
+  }
+
+  if(!any(c(is_def, mult_def))){
+    cli::cli_abort(
+      c("None of {.var rangex}, {.var rangey}, or {.var range_mult} defined.",
+        "i" = "The range across dimensions for estimating the probability polygons must be defined.")
+    )
+  }
+
+  output <- list()
+  if(!is.null(rangex)){
+    output$rangex <- rangex
+  }else{
+    output$rangex <- expand_range(x, mult = range_mult)
+  }
+
+  if(!is.null(rangey)){
+    output$rangey <- rangey
+  }else{
+    output$rangey <- expand_range(y, mult = range_mult)
+  }
+
+  return(output)
+
+}

R/density_area.R

@@ -1,18 +1,11 @@
-expand_range <- function(x, mult = 0.25, ...){
-  data_range <- range(x)
-  range_diff <- diff(data_range)
-  out_range <- ((range_diff * mult) * c(-1, 1)) + data_range
-  return(out_range)
-}
-
 get_isolines<- function(x,
                          y,
                          probs = 0.5,
-                         range_mult = 0.25,
+                         rangex,
+                         rangey,
                          ...) {
-  rangex = expand_range(x, range_mult)
-  rangey = expand_range(y, range_mult)
 
+  dots <- rlang::dots_list(...)
   tibble::tibble(x = x,
                  y = y) |>
     ggdensity::get_hdr(probs = probs,
@@ -75,11 +68,21 @@ get_isolines_safely <- function(...){
 #' @param as_sf Should the returned values be [sf::sf]? Defaults to `FALSE`.
 #' @param as_list Should the returned value be a list? Defaults to `TRUE` to
 #' work well with tidyverse list columns
+#' @param range_mult A multiplier to the range of `x` and `y` across which the
+#' probability density will be estimated.
+#' @param rangex,rangey Custom ranges across `x` and `y` ranges across which the
+#' probability density will be estimated.
 #' @param ... Additional arguments to be passed to [ggdensity::get_hdr()]
 #'
 #' @returns A list of data frames, if `as_list=TRUE`, or just a data frame,
 #' if `as_list=FALSE`
 #'
+#' @details
+#' If both `rangex` and `rangey` are defined, `range_mult` will be disregarded.
+#' If only one or the other of `rangex` and `rangey` are defined, `range_mult`
+#' will be used to produce the range of the undefined one.
+#'
+#'
 #' @example inst/examples/density_polygon_example.R
 #'
 #' @importFrom dplyr .data
@@ -92,11 +95,25 @@ density_polygons <- function(x,
                              probs = 0.5,
                              as_sf = FALSE,
                              as_list = TRUE,
+                             range_mult = 0.25,
+                             rangex = NULL,
+                             rangey = NULL,
                              ...) {
 
+  dots <- rlang::dots_list(...)
+
+  ### Capture variable names for name swap
+
   xname <- deparse(substitute(x))
   yname <- deparse(substitute(y))
 
+  nameswap <- c("x", "y")
+  names(nameswap) <- vctrs::vec_as_names(c(xname, yname),
+                                         repair = "unique",
+                                         quiet = TRUE)
+
+  ### process data
+
   processed_data <- process_data(x=x,
                                  xname = xname,
                                  y=y,
@@ -105,12 +122,22 @@ density_polygons <- function(x,
 
   list2env(processed_data, envir = environment())
 
-  nameswap <- c("x", "y")
-  names(nameswap) <- vctrs::vec_as_names(c(xname, yname),
-                                         repair = "unique",
-                                         quiet = TRUE)
+  ### process ranges
 
-  isolines <- get_isolines_safely(x=x, y=y, probs=probs, ...)
+  processed_ranges <- process_ranges(x = x,
+                                     y = y,
+                                     rangex = rangex,
+                                     rangey = rangey,
+                                     range_mult = range_mult)
+
+  list2env(processed_ranges, envir = environment())
+
+  isolines <- get_isolines_safely(x=x,
+                                  y=y,
+                                  probs=probs,
+                                  rangex = rangex,
+                                  rangey = rangey,
+                                  ...)
 
   isolines |>
     dplyr::mutate(
@@ -179,8 +206,17 @@ density_polygons <- function(x,
 #' @param as_sf Should the returned values be [sf::sf]? Defaults to `FALSE`.
 #' @param as_list Should the returned value be a list? Defaults to `TRUE` to
 #' work well with tidyverse list columns
+#' @param range_mult A multiplier to the range of `x` and `y` across which the
+#' probability density will be estimated.
+#' @param rangex,rangey Custom ranges across `x` and `y` ranges across which the
+#' probability density will be estimated.
 #' @param ... Additional arguments to be passed to [ggdensity::get_hdr()]
 #'
+#' @details
+#' If both `rangex` and `rangey` are defined, `range_mult` will be disregarded.
+#' If only one or the other of `rangex` and `rangey` are defined, `range_mult`
+#' will be used to produce the range of the undefined one.
+#'
 #' @example inst/examples/density_area_example.R
 #'
 #' @importFrom dplyr .data
@@ -192,13 +228,19 @@ density_area <- function(x,
                          probs = 0.5,
                          as_sf = F,
                          as_list = T,
+                         range_mult = 0.25,
+                         rangex = NULL,
+                         rangey = NULL,
                          ...) {
   density_polygons(
     x = x,
     y = y,
     probs = probs,
     as_sf = T,
     as_list = F,
+    range_mult = range_mult,
+    rangex = rangex,
+    rangey = rangey,
     ...
   ) ->
     iso_poly_sf

tests/testthat/test-test_range.R

@@ -0,0 +1,39 @@
+set.seed(10)
+alpha = rnorm(100)
+beta = rnorm(100)
+
+test_that("warnings for redundant range settings", {
+  expect_warning(
+    density_polygons(alpha, beta, rangex = c(0, 1), rangey = c(0, 1), range_mult = 0.5)
+  )
+  expect_warning(
+    density_area(alpha, beta, rangex = c(0, 1), rangey = c(0, 1), range_mult = 0.5)
+  )
+})
+
+test_that("warnings for only one defined range", {
+  expect_warning(
+    density_polygons(alpha, beta, rangex = c(-2,2))
+  )
+
+  expect_warning(
+    density_polygons(alpha, beta, rangey = c(-2,2))
+  )
+
+  expect_warning(
+    density_area(alpha, beta, rangex = c(-2,2))
+  )
+
+  expect_warning(
+    density_area(alpha, beta, rangey = c(-2,2))
+  )
+
+})
+
+test_that("errors for invalid ranges", {
+  expect_error(
+    density_polygons(alpha, beta, rangex = 1, rangey = c(-2, 2), range_mult = NULL)
+  )
+
+})
+

usethis_hist.R

@@ -82,6 +82,8 @@ usethis::use_test("multi_polygon")
 usethis::use_test("expand_range")
 usethis::use_test("test_rename")
 
+usethis::use_test("test_range")
+
 
 # Github ----
 usethis::use_github_action(name = "check-standard")