adding check_factor_has_levels() check

ddsjoberg · Sep 13, 2024 · 44f0878 · 44f0878
1 parent 8fa5ae5
commit 44f0878
Show file tree

Hide file tree

Showing 3 changed files with 47 additions and 1 deletion.
diff --git a/R/standalone-checks.R b/R/standalone-checks.R
@@ -543,6 +543,33 @@ check_no_na_factor_levels <- function(x,
   invisible(x)
 }
 
+#' Check for levels attribute exists for factor
+#'
+#' @param x (`data.frame`)\cr
+#'   a data frame
+#' @inheritParams check_class
+#' @keywords internal
+#' @noRd
+check_factor_has_levels <- function(x,
+                                    message =
+                                      "Factors with empty {.val levels} attribute are not allowed,
+                                       which was identified in column {.val {variable}}.",
+                                    arg_name = rlang::caller_arg(x),
+                                    class = "na_factor_levels",
+                                    call = get_cli_abort_call(),
+                                    envir = rlang::current_env()) {
+  check_data_frame(x, arg_name = arg_name, class = class, call = call, envir = envir)
+
+  for (variable in names(x)) {
+    if (is.factor(x[[variable]]) && rlang::is_empty(levels(x[[variable]]))) {
+      cli::cli_abort(message = message, class = c(class, "standalone-checks"), call = call, .envir = envir)
+    }
+  }
+
+  invisible(x)
+}
+
+
 #' Check is Numeric
 #'
 #' @inheritParams check_class

diff --git a/tests/testthat/_snaps/standalone-checks.md b/tests/testthat/_snaps/standalone-checks.md
@@ -127,6 +127,14 @@
       Error in `myfunc()`:
       ! Factors with NA levels are not allowed, which are present in column "Species".
 
+---
+
+    Code
+      myfunc(my_iris)
+    Condition
+      Error in `myfunc()`:
+      ! Factors with empty "levels" attribute are not allowed, which was identified in column "bad_fct_col".
+
 ---
 
     Code

diff --git a/tests/testthat/test-standalone-checks.R b/tests/testthat/test-standalone-checks.R
@@ -215,7 +215,7 @@ test_that("check functions work", {
   expect_snapshot(myfunc(pi), error = TRUE)
 
   # check_no_na_factor_levels()
-  myfunc <- function(x){
+  myfunc <- function(x) {
     set_cli_abort_call()
     check_no_na_factor_levels(x)
   }
@@ -226,6 +226,17 @@ test_that("check functions work", {
   expect_silent(myfunc(iris))
   expect_snapshot(myfunc(my_iris), error = TRUE)
 
+  # check_factor_has_levels()
+  myfunc <- function(x) {
+    set_cli_abort_call()
+    check_factor_has_levels(x)
+  }
+  my_iris <- iris
+  my_iris$bad_fct_col <- factor(NA)
+
+  expect_silent(myfunc(iris))
+  expect_snapshot(myfunc(my_iris), error = TRUE)
+
   # check_numeric()
   myfunc <- function(x) {
     set_cli_abort_call()