diff --git a/R/data_checks.R b/R/data_checks.R new file mode 100644 index 0000000..47fe193 --- /dev/null +++ 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 index 06dd792..19bdd2b 100644 --- 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 index 8dd71f9..80f7ce4 100644 --- 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) - -}