Skip to content

Instantly share code, notes, and snippets.

@wdkrnls
Last active February 6, 2017 02:07
Show Gist options
  • Save wdkrnls/d46d9f8da79354241eebd6f4caf2e762 to your computer and use it in GitHub Desktop.
Save wdkrnls/d46d9f8da79354241eebd6f4caf2e762 to your computer and use it in GitHub Desktop.
Some weekend experiments I made with R. No premature optimization here.
# 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))
}
}
@wdkrnls
Copy link
Author

wdkrnls commented Feb 6, 2017

Should add else statements to just and sans...

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment