Instantly share code, notes, and snippets.

# wdkrnls/some_experiments.R

Last active February 6, 2017 02:07
Show Gist options
• Save wdkrnls/d46d9f8da79354241eebd6f4caf2e762 to your computer and use it in GitHub Desktop.
Some weekend experiments I made with R. No premature optimization here.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode characters
 # 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 commented Feb 6, 2017

Should add else statements to just and sans...