Some weekend experiments I made with R. No premature optimization here.

some_experiments.R

# Author: Kyle Andrews
# GPL3+ license applies.


#' parallel index map function for univariate data.
#' @param f Function -> Vector.
#' @param xs Vector.
#' @param ys Vector.
#' @param ... Extra arguments to f.
#' @examples
#' pimap(rep, 1:5, 1:5)
#' @export
pimap <- function(f, xs, ys, ...) {
  stopifnot(length(xs) == length(ys))
  unlist(
    lapply(seq_along(xs), function(i) {
      f(xs[i], ys[i], ...)
    }),
    recursive = FALSE,
    use.names = FALSE)
}


#' Vector variant of rep to handle the case where the number of reps
#' should change depending on k if k is a vector of the same length.
#' @param x Vector.
#' @param k Integer (Vector|Scalar) of repetitions.
#' @examples
#' vrep(1:5, 1:5)
#' @export Vector of length sum(k)
vrep <- function(x, k) {
  nk <- length(k)
  nx <- length(x)
  stopifnot(nk %in% c(1, nx))
  if(nk == 1) k <- rep(k, nx)
  pimap(rep, x, k)
}


#' Opposite of %in%
#' @export
`%excluding%` <- Negate(`%in%`)


#' An experimental function to exclude elements from a vector.
#' @param x Vector.
#' @param drop (Vector|Function).
#' @return Vector.
#' @examples
#' 1:10 %>% sans(seq(1, 10, 3))
#' 1:10 %>% sans(satisfies(is_above(4), is_even))
#' @export
sans <- function(x, drop) {
  if(is.function(drop)) {
    Filter(Negate(drop), x)
  } else if(is.numeric(x) && is.numeric(drop)) {
    x[as.numeric(x) %excluding% as.numeric(drop)]
  } else if(typeof(drop) == typeof(x)) {
    x[x %excluding% drop]
  } else {
    stop("Something is wrong! Check your inputs.")
  }
}


#' An experimental function to keep just some elements in a vector.
#' @param x Vector.
#' @param keep (Vector|Function).
#' @return Vector.
#' @examples
#' 1:10 %>% keep(seq(1, 10, 3))
#' 1:10 %>% keep(satisfies(is_above(4), is_even))
#' @export
just <- function(x, keep) {
  if(is.function(keep)) {
    Filter(keep, x)
  } else if(is.numeric(x) && is.numeric(keep)) {
    x[as.numeric(x) %in% as.numeric(keep)]
  } else if(typeof(keep) == typeof(x)) {
    x[x %in% keep]
  } else {
    stop("Something is wrong! Check your inputs.")
  }
}


#' unlist with better defaults for how I use it.
#' @param x Vector.
#' @param recursively Logical Scalar. Defaults to FALSE.
#' @param keep_names Logical Scalar. Defaults to FALSE.
#' @examples
#' flat(list(1:5, 6:10))
#' @export
flat <- function(x, recursively = FALSE, keep_names = FALSE) {
  unlist(x, recursive = recursively, use.names = keep_names)
}


#' My basic map implementation.
#' @param f Function.
#' @param xs Vector.
#' @param ... Extra arguments to f passed via lapply.
#' @export
map <- function(f, xs, ...) {
  lapply(xs, f, ...)
}

#' Test if which values are TRUE or FALSE.
#' @export
is_false <- function(x) x == FALSE


#' @rdname is_false
#' @export
is_true <- function(x) x == TRUE


#' Test whether the value is above, below, betwen or outside.
#' @export
is_below <- function(k) {
  function(x) {
    x < k
  }
}

less_than <- is_below


#' @rdname is_below
#' @export
is_above <- function(k) {
  function(x) {
    x > k
  }
}


greater_than <- is_above

#' @rdname is_below
#' @export
is_between <- function(l, h) {
  function(x) {
    x >= l & x <= h
  }
}

inside <- is_between

#' @rdname is_below
#' @export
is_outside <- function(l, h) {
  Negate(is_between(l, h))
}

outside <- is_outside

#' Check multiple predicate functions simultaneously.
#'
#' Return a function that checks if all the given predicate functions
#' return TRUE.
#' @param ... Function predicates.
#' @return Function predicate.
#' @examples
#' satisfies(is_even, is_above(5))(42)
#' 1:42 %>% .[satisfies(is_between(30, 50), is_even)(.)]
#' @export
satisfies <- function(...) {
  pfs <- list(...)
  if(!all(flat(map(is.function, pfs)))) {
    stop("Some list elements aren't functions!", pfs)
  }
  function(x) {
    res <- map(do.call, pfs, list(x))
    tlr <- turn(res)
    flat(map(all, tlr))
  }
}

#' Check whether the elements of the vector are equal.
#' @param x Vector.
#' @param ... Extra arguments for all.equal that we can usual ignore.
#' @examples
#' same(rep(1, 5))
#' same(LETTERS[1:3])
#' @export
same <- function(x, ...) {
  if(is.double(x)) {
    isTRUE(all.equal(min(x), max(x), ...))
  } else {
    length(unique(x)) == 1
  }
}


#' Parallel transpose map.
#'
#' Apply a function to a list of equal length vectors. I original
#' wrote this for satisfies, but didn't end up using it.
#' @param .f Function.
#' @param .xs List of equal length vectors.
#' @param ... Extra vectors to consider.
#' @return Vector.
ptmap <- function(.f, .xs, ...) {
  xs <- list(.xs, ...)
  n <- length(xs)
  nx <- flat(map(length, xs))
  stopifnot(same(nx))
  flat(map(.f, turn(xs)))
}


#' Turn a list on its side.
#'
#' Transpose a list composed of vectors of the same type and length.
#' @param xs List of Vectors[m by n]
#' @return List of Vectors[n by m]
#' @examples
#' turn(list(1:5, 1:5))
#' @export
turn <- function(xs) {
  ns <- flat(map(length, xs))
  n <- unique(ns)  # length of sublists
  m <- length(xs)
  stopifnot(length(n) == 1)
  js <- seq_along(xs) # sequence along lists
  ks <- seq.int(n)    # sequence along sublists
  w <- list()
  for(k in ks) {
    v <- rep(NA, m)
    for(j in js) {
      v[[j]] <- xs[[j]][[k]]
    }
    w[[k]] <- v
  }
  w
}


#' Combines multiple predicate functions and returns TRUE if any of
#' them matches.
#' @param ... Functions.
#' @return Function.
or <- function(...) {
  pfs <- list(...)
  if(!all(flat(map(is.function, pfs)))) {
    stop("Some list elements aren't functions!", pfs)
  }
  function(x) {
    res <- map(do.call, pfs, list(x))
    tlr <- turn(res)
    flat(map(any, tlr))
  }
}

Should add else statements to just and sans...