Update is_invariant() to accept more inputs

- default method replaces character
- New list & data.frame methods
- Tests added

Tests: PASS

NAMESPACE

@@ -17,7 +17,9 @@ S3method(extract_pmid,pmc_search)
 S3method(html_col_sort,data.frame)
 S3method(html_col_sort,default)
 S3method(identify_obsolete,doid_edit)
-S3method(is_invariant,character)
+S3method(is_invariant,data.frame)
+S3method(is_invariant,default)
+S3method(is_invariant,list)
 S3method(is_invariant,numeric)
 S3method(print,get_url_names)
 S3method(print,oieb)

NEWS.md

@@ -1,5 +1,11 @@
 # DO.utils (development version)
 
+## General
+
+## Updated
+* `is_invariant()` no works for more than just character & numeric vectors, with new `list` and `data.frame` methods and a `default` method that should be able to handle more cases (and replaces the `character` method).
+
+
 ## DO Management & Analysis
 
 ### Updated

R/predicates.R

@@ -1,33 +1,61 @@
-#' Test if Vector is Invariant
+#' Test if an Object is Invariant
 #'
-#' Test if a vector is invariant (_i.e._ all values are equal, within a given
+#' Test if an object is invariant (_i.e._ all values are equal, within a given
 #' tolerance for numeric vectors).
 #'
-#' @param x vector to be tested
+#' @param x object to be tested
 #' @param na.rm logical indicating whether to exclude NA values
-#' @param tol double, tolerance to use (for numeric vectors)
 #' @param ... unused; for extensibility
 #'
 #' @family value predicates
 #' @family predicates
 #' @export
-is_invariant <- function(x, na.rm = FALSE, ...) {
+is_invariant <- function(x, ...) {
     UseMethod("is_invariant")
 }
 
 #' @export
 #' @rdname is_invariant
-is_invariant.character <- function(x, na.rm = FALSE, ...) {
-    dplyr::n_distinct(x, na.rm = na.rm) == 1
+is_invariant.default <- function(x, na.rm = FALSE, ...) {
+    if (isTRUE(na.rm)) {
+        x <- stats::na.omit(x)
+    }
+    length(unique(x)) == 1
 }
 
 #' @export
 #' @rdname is_invariant
+#' @param tol double, tolerance to use (for numeric vectors)
 is_invariant.numeric <- function(x, na.rm = FALSE,
                                  tol = sqrt(.Machine$double.eps), ...) {
+    if (isFALSE(na.rm)) {
+        na_n <- sum(is.na(x))
+        if (na_n == length(x)) return(TRUE)
+        if (na_n > 0) return(FALSE)
+    }
+
     diff(range(x, na.rm = na.rm)) < tol
 }
 
+#' @export
+#' @rdname is_invariant
+#' @param incl_nm Whether top-level names should be included in determining if a
+#' list is invariant (default: `TRUE`).
+is_invariant.list <- function(x, incl_nm = TRUE, ...) {
+    nm <- names(x)
+    if (isFALSE(incl_nm) || is.null(nm)) {
+        return(length(unique(x)) == 1)
+    }
+
+    length(unique(x)) == 1 && length(unique(nm)) == 1
+}
+
+#' @export
+#' @rdname is_invariant
+is_invariant.data.frame <- function(x, ...) {
+    nrow(unique(x)) == 1
+}
+
 
 #' Character value predicates
 #'

tests/testthat/test-predicates.R

@@ -28,6 +28,112 @@ test_that("is_valid_doid works", {
 })
 
 
+# is_invariant() tests ----------------------------------------------------
+
+test_that("is_invariant() default method works (chr, lgl)", {
+    .chr <- letters[1:2]
+    .chr_invar <- c("a", "a")
+
+    expect_false(is_invariant(.chr))
+    expect_true(is_invariant(.chr_invar))
+
+    .chr_na <- c("a", NA_character_)
+
+    expect_false(is_invariant(.chr_na))
+    expect_true(is_invariant(.chr_na, na.rm = TRUE))
+
+    .lgl <- c(T, F)
+    .lgl_invar <- rep(T, 2)
+
+    expect_false(is_invariant(.lgl))
+    expect_true(is_invariant(.lgl_invar))
+
+    .lgl_na <- c(T, NA_character_)
+
+    expect_false(is_invariant(.lgl_na))
+    expect_true(is_invariant(.lgl_na, na.rm = TRUE))
+})
+
+test_that("is_invariant() list method works", {
+    ##### simple lists #####
+    .l <- list(1, 2)
+    .l_invar <- list("a", "a")
+    expect_false(is_invariant(.l))
+    expect_true(is_invariant(.l_invar))
+
+    # with names
+    .l_nm <- list(a = 1, b = 2)
+    .l_nm_only <- list(a = 1, b = 1)
+    .l_nm_invar <- list(a = 1, a = 1)
+    expect_false(is_invariant(.l_nm))
+    expect_false(is_invariant(.l_nm_only))
+    expect_true(is_invariant(.l_nm_only, incl_nm = FALSE))
+    expect_true(is_invariant(.l_nm_invar))
+
+    ##### 2-level lists ##### fully unnamed
+    .ll <- list(list(1), list(2))
+    .ll_invar <- list(list(1), list(1))
+    expect_false(is_invariant(.ll))
+    expect_true(is_invariant(.ll_invar))
+
+    # with names at lvl 2
+    .ll_nm <- list(list(a = 1), list(b = 1))
+    .ll_nm_invar <- list(list(a = 1), list(a = 1))
+    expect_false(is_invariant(.ll_nm))
+    expect_false(is_invariant(.ll_nm, incl_nm = FALSE))
+    expect_true(is_invariant(.ll_nm_invar))
+
+    # with names at lvl 1
+    .l_nm_l <- list(a = list(1), b = list(2))
+    .l_nm_only_l <- list(a = list(1), b = list(1))
+    .l_nm_l_invar <- list(a = list(1), a = list(1))
+    expect_false(is_invariant(.l_nm_l))
+    expect_false(is_invariant(.l_nm_only_l))
+    expect_true(is_invariant(.l_nm_only_l, incl_nm = FALSE))
+    expect_true(is_invariant(.l_nm_l_invar))
+
+    # with names at both lvls
+    .l_nm_l_nm <- list(a = list(x = 1), b = list(y = 2))
+    .l_nm_l_nm_only <- list(a = list(x = 1), a = list(y = 1))
+    .l_nm_only_l_nm <- list(a = list(x = 1), b = list(x = 1))
+    .l_nm_l_nm_invar <- list(a = list(x = 1), a = list(x = 1))
+    expect_false(is_invariant(.l_nm_l_nm))
+    expect_false(is_invariant(.l_nm_l_nm_only))
+    expect_false(is_invariant(.l_nm_only_l_nm))
+    expect_true(is_invariant(.l_nm_only_l_nm, incl_nm = FALSE))
+    expect_true(is_invariant(.l_nm_l_invar))
+})
+
+test_that("is_invariant() data.frame method works", {
+    df <- datasets::mtcars[1:2, ]
+    df_invar <- df
+    df_invar[2, ] <- df_invar[1, ]
+
+    expect_false(is_invariant(df))
+    expect_true(is_invariant(df_invar))
+})
+
+test_that("is_invariant() numeric method works", {
+    .int <- 1:2
+    .int_invar <- rep(1, 2)
+
+    expect_false(is_invariant(.int))
+    expect_true(is_invariant(.int_invar))
+
+    .int_na <- c(1, NA)
+
+    expect_false(is_invariant(.int_na))
+    expect_true(is_invariant(.int_na, na.rm = TRUE))
+
+    .num <- c(1, 1 + sqrt(.Machine$double.eps))
+    .num_invar <- c(1, 1 + sqrt(.Machine$double.eps) - 1e-14)
+
+    expect_false(is_invariant(.num))
+    expect_true(is_invariant(.num_invar))
+    expect_true(is_invariant(.num, tol = sqrt(.Machine$double.eps) + 1e-14))
+})
+
+
 # is_curie() tests --------------------------------------------------------
 
 test_that("is_curie(def = 'obo') works", {