Add tests

R/AllGenerics.R

@@ -51,6 +51,8 @@ setGeneric(
 #'
 #' Keeps rows/columns in an array-like object using a predicate function.
 #' @inheritParams detect
+#' @param verbose A [`logical`] scalar: should \R report extra information
+#'  on progress?
 #' @example inst/examples/ex-keep.R
 #' @author N. Frerebeau
 #' @docType methods

R/discard.R

@@ -11,11 +11,11 @@ setMethod(
   signature = c(x = "ANY"),
   definition = function(x, f, margin = 1, negate = FALSE, all = FALSE,
                         verbose = getOption("arkhe.verbose"), ...) {
-    i <- !detect(x, f = f, margin = margin, negate = negate, all = all, ...)
-    discard_message(x, keep = i, margin = margin, verbose = verbose)
-    if (any(margin == 1)) return(x[i, , drop = FALSE])
-    if (any(margin == 2)) return(x[, i, drop = FALSE])
-    x
+    i <- detect(x, f = f, margin = margin, negate = negate, all = all, ...)
+    discard_message(x, keep = !i, margin = margin, verbose = verbose)
+    if (any(margin == 1)) return(x[!i, , drop = FALSE])
+    if (any(margin == 2)) return(x[, !i, drop = FALSE])
+    i
   }
 )
 
@@ -58,8 +58,9 @@ setMethod(
 discard_message <- function(x, keep, margin,
                             verbose = getOption("arkhe.verbose")) {
   drop <- sum(!keep)
-  if (margin == 1) what <- ngettext(drop, "row", "rows")
-  if (margin == 2) what <- ngettext(drop, "column", "columns")
+  what <- ngettext(drop, "element", "elements")
+  if (any(margin == 1)) what <- ngettext(drop, "row", "rows")
+  if (any(margin == 2)) what <- ngettext(drop, "column", "columns")
 
   if (drop == 0) {
     msg <- sprintf("No %s to remove.", what)

R/keep.R

@@ -9,11 +9,13 @@ NULL
 setMethod(
   f = "keep",
   signature = c(x = "ANY"),
-  definition = function(x, f, margin = 1, negate = FALSE, all = FALSE, ...) {
+  definition = function(x, f, margin = 1, negate = FALSE, all = FALSE,
+                        verbose = getOption("arkhe.verbose"), ...) {
     i <- detect(x, f = f, margin = margin, negate = negate, all = all, ...)
+    discard_message(x, keep = i, margin = margin, verbose = verbose)
     if (any(margin == 1)) return(x[i, , drop = FALSE])
     if (any(margin == 2)) return(x[, i, drop = FALSE])
-    x
+    i
   }
 )
 
@@ -23,8 +25,9 @@ setMethod(
 setMethod(
   f = "keep_rows",
   signature = c(x = "ANY"),
-  definition = function(x, f, negate = FALSE, all = FALSE, ...) {
-    keep(x, f, margin = 1, negate = negate, all = all, ...)
+  definition = function(x, f, negate = FALSE, all = FALSE,
+                        verbose = getOption("arkhe.verbose"), ...) {
+    keep(x, f, margin = 1, negate = negate, all = all, verbose = verbose, ...)
   }
 )
 
@@ -34,7 +37,8 @@ setMethod(
 setMethod(
   f = "keep_cols",
   signature = c(x = "ANY"),
-  definition = function(x, f, negate = FALSE, all = FALSE, ...) {
-    keep(x, f, margin = 2, negate = negate, all = all, ...)
+  definition = function(x, f, negate = FALSE, all = FALSE,
+                        verbose = getOption("arkhe.verbose"), ...) {
+    keep(x, f, margin = 2, negate = negate, all = all, verbose = verbose, ...)
   }
 )

R/predicates.R

@@ -1,6 +1,10 @@
 # PREDICATES
 
 # Not exported =================================================================
+is_unique <- function(x, na.rm = FALSE) {
+  if (na.rm) x <- stats::na.omit(x)
+  length(unique(x)) <= 1
+}
 is_empty_string <- function(x, na.rm = FALSE) {
   assert_type(x, "character")
   if (na.rm) x <- stats::na.omit(x)

R/remove.R

@@ -53,27 +53,11 @@ setMethod(
 # Constant =====================================================================
 #' @export
 #' @rdname remove_constant
-#' @aliases remove_constant,data.frame-method
+#' @aliases remove_constant,ANY-method
 setMethod(
   f = "remove_constant",
-  signature = c(x = "data.frame"),
-  definition = function(x, na.rm = FALSE) {
-    all_unique <- function(x) {
-      if (na.rm) x <- stats::na.omit(x)
-      length(unique(x)) <= 1
-    }
-    discard(x, f = all_unique, margin = 2, all = FALSE)
-  }
-)
-
-#' @export
-#' @rdname remove_constant
-#' @aliases remove_constant,matrix-method
-setMethod(
-  f = "remove_constant",
-  signature = c(x = "matrix"),
+  signature = c(x = "ANY"),
   definition = function(x, na.rm = FALSE) {
-    x <- as.data.frame(x)
-    methods::callGeneric(x, na.rm = na.rm)
+    discard(x, f = function(x) { is_unique(x, na.rm) }, margin = 2, all = FALSE)
   }
 )

R/replace.R

@@ -88,13 +88,12 @@ setMethod(
   signature = c(x = "data.frame"),
   definition = function(x, value) {
     num <- vapply(X = x, FUN = is.numeric, FUN.VALUE = logical(1))
-    nozero <- vapply(
-      X = x[, num],
+    nozero <- lapply(
+      X = x[, num, drop = FALSE],
       FUN = function(x, value) {
         x[is_zero(x)] <- value
         x
       },
-      FUN.VALUE = numeric(nrow(x)),
       value = value
     )
     x[, num] <- nozero
@@ -123,13 +122,12 @@ setMethod(
   signature = c(x = "data.frame"),
   definition = function(x, value) {
     char <- vapply(X = x, FUN = is.character, FUN.VALUE = logical(1))
-    noblank <- vapply(
-      X = x[, char],
+    noblank <- lapply(
+      X = x[, char, drop = FALSE],
       FUN = function(x, value) {
         x[is_empty_string(x)] <- value
         x
       },
-      FUN.VALUE = character(nrow(x)),
       value = value
     )
     x[, char] <- noblank