Merge pull request #95 from jmbarbone/85-hot

Adds `hold()` and `toss()`

Author: jmbarbone

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: fuj
 Type: Package
 Title: Functions and Utilities for Jordan
-Version: 0.2.2.9005
+Version: 0.2.2.9006
 Authors@R:
     person(
       given = "Jordan Mark",

NAMESPACE

@@ -29,6 +29,7 @@ export(exattr)
 export(file_path)
 export(flip)
 export(fp)
+export(hold)
 export(include)
 export(is_file_path)
 export(is_in)
@@ -64,6 +65,7 @@ export(subset1)
 export(subset2)
 export(subset3)
 export(subtract)
+export(toss)
 export(vap)
 export(vap2)
 export(vap2_chr)
@@ -91,6 +93,7 @@ export(vap_dttm)
 export(vap_int)
 export(vap_lgl)
 export(vap_raw)
+export(vap_vec)
 export(vapi)
 export(vapi_chr)
 export(vapi_cpl)

NEWS.md

@@ -7,6 +7,7 @@
 * `list0()`'s functionality to ignore empty inputs can be disabled if `options(fuj.list.active = FALSE)` before `{fuj}` is loaded [#91](https://github.com/jmbarbone/fuj/issues/91)
 * `set_file_ext()` and `file_ext<-()` added for controlling file extensions [#89](https://github.com/jmbarbone/fuj/issues/89)
 * `+` and `/` methods added for `file_path` classes, allowing path creation (e.g., `fp("folder") / "subfolder" / "file" + "extension"`) [#89](https://github.com/jmbarbone/fuj/issues/89)
+* `hold()` and `toss()` are added for retaining and removing values in a vectors [#85](https://github.com/jmbarbone/fuj/issues/85)
 
 ## Changes in `conditions` 
 
@@ -45,7 +46,9 @@ Arguments to `f())` can use any name.
 
 _Note_: `vapi()` uses either the index or names of `x` as the second argument to `f`.
 
-Each `vap` function comes with the following type variants:
+
+Each `vap` function comes with the following type variants.
+If you are not concerned about type safety, use`vap_vec()`.
 
   | Function   | Output Type    | Conversion
   |:-----------|----------------|----------------|

R/condition.R

@@ -93,7 +93,7 @@ new_condition <- function(
   }
 
   type <- as.character(type)
-  type <- match.arg(type)
+  type <- match.arg(type, c("condition", "error", "warning", "message"))
 
   if (!inherits(class, "AsIs")) {
     class <- vapply(

R/conditions.R

@@ -23,18 +23,18 @@ verbose_message <- function(message, call = NULL) {
 
 # errors ------------------------------------------------------------------
 
-input_error <- function(message = "invalid input") {
+input_error <- function(message = "invalid input", ...) {
   new_condition(
-    message = message,
+    message = c(message, ...),
     class = "input",
     type = "error",
     package = "fuj"
   )
 }
 
-value_error <- function(message = "invalid value") {
+value_error <- function(message = "invalid value", ...) {
   new_condition(
-    message = message,
+    message = c(message, ...),
     class = "value",
     type = "error",
     package = "fuj"

R/flip.R

@@ -43,7 +43,7 @@ flip.matrix <- function(
   ...
 ) {
   switch(
-    match.arg(by),
+    match.arg(by, c("rows", "columns")),
     rows = {
       rows <- nrow(x)
       dims <- dimnames(x)
@@ -87,7 +87,7 @@ flip.data.frame <- function(
   ...
 ) {
   switch(
-    match.arg(by),
+    match.arg(by, c("rows", "columns")),
     rows = {
       rows <- nrow(x)
 

R/hot.R

@@ -0,0 +1,79 @@
+#' Hold or Toss
+#'
+#' @param x A vector of values
+#' @param i An indication of which subset values to action.  This can be a
+#'   logical vector, an integer vector, or a function that takes `x` as an
+#'   argument and returns a logical or integer vector
+#' @param na How to handle `NA` values in when `p` is a logical vector, or a
+#'   function that returns a logical vector. [fuj::hold()] defaults to dropping
+#'   `NA` values, while [fuj::toss()] defaults to keeping `NA` values.  When `p`
+#'   is an integer vector, `NA` values are always dropped.
+#' @name hot
+#' @examples
+#' x <- c(1, NA, 3, 4, Inf, 6)
+#' twos <- function(x) x %% 2 == 0
+#' hold(x, twos) # 4, 6
+#' toss(x, twos) # 1, 3, NA, Inf
+#'
+#' hold(x, twos, na = "keep") # NA, 4, Inf, 6
+#' toss(x, twos, na = "drop") # 1, 3
+#'
+#' i <- c(1:3, NA)
+#' x <- letters[1:5]
+#' hold(x, i)
+#' toss(x, i)
+#'
+#' @returns
+#' - [fuj::hold()] **retains** values in `x` matched against `i`
+#' - [fuj::toss()] **removes** values in `x` matched against `i`
+NULL
+
+#' @rdname hot
+#' @export
+hold <- function(x, i, na = c("drop", "keep")) {
+  na <- match.arg(na, c("drop", "keep"))
+
+  if (inherits(i, "logical")) {
+    i[is.na(i)] <- na == "keep"
+    return(x[i])
+  }
+
+  if (integerish(i)) {
+    return(x[i[!is.na(i)]])
+  }
+
+  if (is.function(i)) {
+    return(hold(x, vap_vec(x, i), na = na))
+  }
+
+  stop(hot_input_error())
+}
+
+
+#' @rdname hot
+#' @export
+toss <- function(x, i, na = c("keep", "drop")) {
+  na <- match.arg(na, c("keep", "drop"))
+
+  if (is.logical(i)) {
+    i[is.na(i)] <- na == "drop"
+    return(x[!i])
+  }
+
+  if (integerish(i)) {
+    return(x[-i[!is.na(i)]])
+  }
+
+  if (is.function(i)) {
+    return(toss(x, vap_vec(x, i), na = na))
+  }
+
+  stop(hot_input_error())
+}
+
+hot_input_error <- function() {
+  input_error(
+    "i must be logical, integer, integer-like numeric, or function which",
+    " returns a logical, integer, or integer-like numeric"
+  )
+}

R/muffle.R

@@ -42,7 +42,7 @@ do_muffle <- function(
   classes,
   env = parent.frame()
 ) {
-  type <- match.arg(type)
+  type <- match.arg(type, c("muffle", "wuffle"))
 
   if (missing(fun)) {
     fun <- switch(type, muffle = suppressMessages, wuffle = suppressWarnings)

R/utils.R

@@ -9,3 +9,10 @@ pairlist_to_string <- function(pair) {
   vals <- as.character(pair)
   paste(nms, "=", vals, collapse = ", ")
 }
+
+integerish <- function(x) {
+  is.integer(x) ||
+    (is.numeric(x) &&
+      !any(is.infinite(x)) &&
+      all(x == as.integer(x), na.rm = TRUE))
+}

R/vap.R

@@ -148,6 +148,10 @@ vap_dates_ <- function(fun, type) {
 #'   in unexpected outputs. Likely, warnings or errors will be signaled
 #'   accordingly.
 #'
+#'   [vap_vec()] is a variant of [vap()] that returns a _flattened_ vector. This
+#'   has similar behavior as [base::sapply()], in that a `list` will be returned
+#'   if the [base::unlist()]'d output has multiple values in an element.
+#'
 #'   [with_vap_progress()] sets an option `vap.progress` to `TRUE` for the
 #'   duration of `expr`, which causes a progress bar to be displayed for any
 #'   `vap*` calls inside `expr`.
@@ -242,6 +246,20 @@ vapp <- function(p, f, ...) {
   set_vapp_names(out, p[[1L]])
 }
 
+#' @export
+#' @rdname vap
+# nolint next: object_usage_linter.
+vap_vec <- function(x, f, ...) {
+  delayedAssign("..call", sys.call())
+  x <- vap(x, f, ...)
+  y <- unlist(x, recursive = FALSE, use.names = FALSE)
+  if (length(x) == length(y)) {
+    set_vap_names(y, x)
+  } else {
+    x
+  }
+}
+
 # vap ---------------------------------------------------------------------
 
 #' @export