R/replace_along.R

In avidclam/amxtra: Useful R helper functions

#' Replace Values in a Vector if condition apply
#'
#' Replaces the values in `x` with indices determined by `condition` by those given in `values`.
#'
#' @note Usage of `values` here differs from that in the base `replace`.
#' In `replace` elements of `x` matching index are replaced by elements of `values`
#' starting with the first on: `x[idx] <- values`.
#' In `replace_along` _corresponding_ elements of the `values` vector are copied:
#' `x[idx] <- values[idx]`.
#' @note If `values` is NULL, corresponding elements of x are dropped
#' @note `x` is unchanged: remember to assign the result
#'
#' @param x base vector, elements of which are to be replaced
#' @param values vector of replacement variables or scalar, reused
#' @param condition action depends on the type:
#' - logical or numeric --- condition is an index vector
#' - character --- condition is a vector of regex patterns; replace if any pattern matches
#' - expression --- evaluated first, then used according to type
#' - other --- invoked as a function, then result used as a index vector
#' @param y vector tested for condition
#'
#' @return Vector `x` with the values replaced according to `condition`
#'
#' @examples
#' # Replace summer months
#' replace_along(month.name, 6:8, "-")
#'
#' # Replace missing values
#' x <- c("one", NA, "three")
#' replace_along(x, is.na, "-")
#'
#' # Replace month name with abbreviation if name ends with "ry" or "er"
#' replace_along(month.name, c("ry$", "er$"), month.abb)
#'
#' # Generate random pluses and minuses
#' replace_along("+", rnorm(20) < 0, "-")
#'
#' # Replace month name with abbreviation if a name is longer than 5 characters.
#' # All variants below achieve the same result.
#' replace_along(month.name, nchar(month.name) > 5, month.abb)
#' replace_along(month.name, expression(nchar(x) > 5), month.abb)
#' replace_along(month.name, expression(y > 5), month.abb, nchar(month.name))
#' replace_along(month.name, function(n) n > 5, month.abb, nchar(month.name))
#'
#' @export
replace_along <- function(x, condition, values, y = x) {
  if (length(condition) == 0) return(x)
  if (is.expression(condition))
    condition <- eval(condition, envir = list(x = x, y = y, values = values))
  if (is.list(condition)) condition <- unlist(condition)
  idx <- switch(typeof(condition),
                "logical" = condition,
                "double" = condition,
                "integer" = condition,
                "character" = !is.na(which_pattern(y, condition)),
                tryCatch({
                  if (is.list(y)) sapply(y, condition, simplify = TRUE)
                  else do.call(condition, list(y))
                }, error = function(e) {warning(e); NA})
  )
  idx[is.na(idx)] <- FALSE
  length.out <- max(length(x), length(values), length(idx))
  if (is.numeric(condition)) length.out <- max(length.out, condition)
  if (!is.null(x)) x <- rep(x,    length.out = length.out)
  if (!is.null(idx)) idx <- rep(idx,  length.out = length.out)
  if (is.null(values)) {
    if (is.numeric(idx)) x[-idx] else x[!idx]
  } else {
    values <- rep(values, length.out = length.out)
    x[idx] <- values[idx]
    x
  }
}