added the parameter "columns" to remove_constant

R/remove_empties.R

@@ -80,30 +80,41 @@ remove_empty <- function(dat, which = c("rows", "cols"), quiet=TRUE) {
 #' @seealso \code{\link[=remove_empty]{remove_empty()}} for removing empty
 #'   columns or rows.
 #' @export
-remove_constant <- function(dat, na.rm = FALSE, quiet=TRUE) {
-  mask <-
-    sapply(
-      X=seq_len(ncol(dat)),
-      FUN=function(idx) {
-        column_to_test <-
-          if (is.matrix(dat)) {
-            dat[, idx]
-          } else {
-            dat[[idx]]
-          }
-        length(unique(
-          if (na.rm) {
-            stats::na.omit(column_to_test)
-          } else {
-            column_to_test
-          }
-        )) <= 1 # the < is in case all values are NA with na.rm=TRUE
+remove_constant <- function (dat, na.rm = FALSE, quiet = TRUE, columns = c())
+{
+  mask <- sapply(
+    X = seq_len(ncol(dat)),
+    FUN = function(idx) {
+      column_to_test <- if (is.matrix(dat)) {
+        dat[, idx]
       }
-    )
+      else {
+        dat[[idx]]
+      }
+      length(unique(if (na.rm) {
+        stats::na.omit(column_to_test)
+      } else {
+        column_to_test
+      })) <= 1
+    }
+  )
   if (!quiet) {
-    remove_message(dat=dat, mask_keep=!mask, which="columns", reason="constant")
+    remove_message(
+      dat = dat,
+      mask_keep = !mask,
+      which = "columns",
+      reason = "constant"
+    )
+  }
+  if (length(columns) == 0) {
+    dat[, !mask, drop = FALSE]  
+  } else if (is.character(columns)) {
+    dat[, !mask | (!names(dat) %in% columns), drop = FALSE]
+  } else if (is.numeric(columns)) {
+    dat[, !mask | (!seq_len(ncol(dat)) %in% columns), drop = FALSE]
+  } else {
+    stop("xxx")
   }
-  dat[ , !mask, drop=FALSE]
 }
 
 

tests/testthat/test-remove-empties.R

@@ -110,8 +110,25 @@ test_that("remove_constant", {
     tibble(B=c(NA, 1, 2)),
     info="tibbles are correctly handled"
   )
+
+  expect_equal(
+    remove_constant2(data.frame(A=c(1, 1), B=c(2, 2)), columns = c("A")),
+    data.frame(B=c(2, 2)),
+    info="Only columns specified in the argument are checked."
+  )
+  expect_equal(
+    remove_constant2(data.frame(A=c(1, 1), B=c(2, 2)), columns = c(1)),
+    data.frame(B=c(2, 2)),
+    info="Only columns specified in the argument are checked."
+  )
+  expect_equal(
+    remove_constant2(data.frame(A=c(1, 1), B=c(2, 2)), columns = 1),
+    data.frame(B=c(2, 2)),
+    info="Only columns specified in the argument are checked."
+  )
 })
 
+
 test_that("Messages are accurate with remove_empty and remove_constant", {
   expect_message(
     remove_empty(data.frame(A=NA, B=1), which="cols", quiet=FALSE),
@@ -157,4 +174,4 @@ test_that("Messages are accurate with remove_empty and remove_constant", {
     fixed=TRUE,
     info="No empty columns to remove"
   )
-})
+})