.Rhistory

cbind(c(1,2),'a')
class(cbind(list(1,2,3),list('a')))
cbind(list(1,2,3),list('a'))
cbind(cbind(list(1,2,3),list('a')),'a')
cbind(cbind(cbind(list(1,2,3),list('a')),'a'),data.frame(c(1,2)))
buffer<-function(...,size=0,fill=NA,align='left')
{
input<-c(...)
if(align=='left')
result<-c(input,rep(fill,(max(0,size-len(input)))))
else
result<-c(rep(fill,(max(0,size-len(input)))),input)
return(result)
}
cbind(data.frame(c(1,2,3),data.frame(c(1,2))))
cbind(as.list(data.frame(c(1,2,3)),data.frame(c(1,2))))
cbind(as.list(data.frame(c(1,2,3)),as.list(data.frame(c(1,2)))))
vectorize<-function(fun,type=1)
{
function(...)
{
cols<-list(...)
cols<-lapply(cols,function (x) lapply(as.data.frame(x),identity))
cols<-cbind(cols)
print(cols)
if(type==3)
type=c(1,2)
if(type!=4)
apply(cols,type,function (x) Reduce(fun,unlist(x)))
else
Reduce(fun,unlist(cols))
}
}
vectorize(`+`)(c(1,2,3),list(1,2,3),cbind(c(1,2)))
vectorize(`+`)(c(1,2,3),list(1,2,3),cbind(c(1,2),'a'))
vectorize<-function(fun,type=1)
{
function(...)
{
cols<-list(...)
cols<-lapply(cols,function (x) lapply(as.data.frame(x),identity))
print(cols)
cols<-cbind(cols)
print(cols)
if(type==3)
type=c(1,2)
if(type!=4)
apply(cols,type,function (x) Reduce(fun,unlist(x)))
else
Reduce(fun,unlist(cols))
}
}
vectorize(`+`)(c(1,2,3),list(1,2,3),cbind(c(1,2),'a'))
vectorize<-function(fun,type=1)
{
function(...)
{
cols<-list(...)
cols<-unlist(lapply(cols,function (x) lapply(as.data.frame(x),identity)),recursive=FALSE)
print(cols)
cols<-cbind(cols)
print(cols)
if(type==3)
type=c(1,2)
if(type!=4)
apply(cols,type,function (x) Reduce(fun,unlist(x)))
else
Reduce(fun,unlist(cols))
}
}
vectorize(`+`)(c(1,2,3),list(1,2,3),cbind(c(1,2),'a'))
df<-data.frame(a=c(1,2,3),b=c(1,2,3))
df
lapply(df,identity)
lapply(list(c(1,2,3)),identity)
unlist(df)
unlist(lapply(df,identity))
cbind(lapply(list(c(1,2,3)),identity),lapply(df,identity))
lapply(c(1,2,3),identity)
cbind(list(1,2),lapply(df,identity))
lapply(df,identity)[1]
lapply(df,identity)[[1]]
lapply(cbind(c(1,2),c(1,2)),identity)
data.frame(list(1,2,3))
data.frame(unlist(1,2,3))
unlist(df)
unlist(df,recursive=FALSE)
cbind(c(1,2,3),list(1,2,3),cbind(c(1,2)))
cbind(c(1,2,3),list(1,2,3),unlsit(cbind(c(1,2))))
cbind(c(1,2,3),list(1,2,3),unlist(cbind(c(1,2))))
as.list(df)
as.list(c(1,2,3))
cbind(as.list(c(1,2,3))as.list(list(1,2,3))
cbind(as.list(c(1,2,3))as.list(list(1,2,3)))
cbind(as.list(c(1,2,3)),as.list(list(1,2,3)))
cbind(as.list(c(1,2,3)),as.list(list(1,2,3)),as.list(c(1,2)))
cbind(as.list(c(1,2,3)),as.list(list(1,2,3)),as.list(c(1,2)),as.list(df))
as.list(df)
unlist(as.list(df),recursive=FALSE)
as.list(df)
cbind(list(c(1,2,3),c(1,2,3),c(1,2,3)))
library(hordr)
vectorize(`+`)(c(1,2,3),list(1,2,3),cbind(c(1,2,3)))
vectorize<-function(fun,type=1)
{
function(...)
{
cols<-cbind.fill(...)
if(type==3)
type=c(1,2)
if(type!=4)
apply(cols,type,function (x) Reduce(fun,unlist(x)))
else
Reduce(fun,unlist(cols))
}
}
vectorize(`+`)(c(1,2,3),list(1,2,3),cbind(c(1,2,3)))
#' Higher order functions and function wrappers to empower and simplify common operations.
#'
#' Hordr adds features, generalizes, and fills in gaps in standards R operations to add power and flexibility.
#' @name hordr
#' @docType package
NULL
#' Robust alternative to Vectorize function that accepts any function with two
#' or more arguments.
#'
#' Returns a function that will work an arbitrary number of vectors, lists or
#' data frames, though output may be unpredicatable in unusual applications The
#' results are also intended to be more intuitive than \code{\link{Vectorize}}.
#'
#' @param fun a two or more argument function
#' @param type 1 forces a row-wise evaluation, even on atomic vectors
#' @export
#' @examples
#' vectorize(`+`)(c(1,2,3))
#' vectorize(sum)(c(1,2,3),c(1,2,3))
#' # Compare these results to Vectorize, which does not vectorize sum at all.
#' Vectorize(sum)(c(1,2,3),c(1,2,3))
#' # Across data frame columns.
#' df<-data.frame(a=c(1,2,3),b=c(1,2,3))
#' vectorize(sum)(df$a,df$b)
#' # Once again, Vectorize gives a different result
#' Vectorize(sum)(df$a,df$b)
#' # Any combination of vectors, lists, matrices, or data frames an be used.
#' vectorize(`+`)(c(1,2,3),list(1,2,3),cbind(c(1,2,3)))
vectorize<-function(fun,type=1)
{
function(...)
{
cols<-cbind.fill(...)
if(type==3)
type=c(1,2)
if(type!=4)
apply(cols,type,function (x) Reduce(fun,unlist(x)))
else
Reduce(fun,unlist(cols))
}
}
#' Robust alternative to \code{\link{cbind} that fills missing values and works
#' on arbitrary data types.
#'
#' Combines any number of R objects into a single matrix, with each input
#' corresponding to the greater of 1 or ncol.  \code{cbind} has counterintuitive
#' results when working with lists, cannot handle certain inputs of differing
#' length, and does not allow the fill to be specified.
#'
#' @param ... any number of R data objects
#' @param fill
#' @export
#' @examples
#' cbind.fill(c(1,2,3),list(1,2,3),cbind(c(1,2,3)))
#' cbind.fill(c(1,2,3),list(1,2,3),cbind(c('a','b')),'a',df)
#' cbind.fill(c(1,2,3),list(1,2,3),cbind(c('a','b')),'a',df,fill=NA)
cbind.fill<-function(...,fill=NULL)
{
inputs<-list(...)
maxlength<-max(unlist(lapply(inputs,len)))
bufferedInputs<-lapply(inputs,buffer,length.out=maxlength,fill,restoreClass=FALSE)
return(Reduce(cbind,bufferedInputs))
}
#'Allows row indexing without knowledge of dimensionality.
#'
#'@export
rows <- function(data,rownums)
{
#result<-data[rownums]
if(is.null(dim(data)))
{
result<-data[rownums]
}
else
{
result<-data[rownums,]
}
#result<-ifelse(is.null(dim(data)),data[c(rownums)],data[c(rownums),])
return(result)
}
#'Allows finding the 'length' without knowledge of dimensionality.
#'
#'@param data any \code{R} object
#'@export
#'
len <- function(data)
{
result<-ifelse(is.null(nrow(data)),length(data),nrow(data))
return(result)
}
# buffer<-function(...,size=0,fill=NA,align='left')
# {
#   input<-c(...)
#   if(align=='left')
#     result<-c(input,rep(fill,(max(0,size-len(input)))))
#   else
#     result<-c(rep(fill,(max(0,size-len(input)))),input)
#   return(result)
# }
#'Pads an object to a desired length, either with replicates of itself or another repeated object.
#'
#'@param x an R object
#'@param length.out the desired length of the final output
#'@export
#'@examples
#'buffer(c(1,2,3),20)
#'buffer(matrix(c(1,2,3,4),nrow=2),20)
#'buffer(list(1,2,3),20)
buffer<-function(x,length.out=len(x),fill=NULL,restoreClass=TRUE)
{
xclass<-class(x)
input<-data.frame(cbind(x))
results<-sapply(input,rep_len,length.out=length.out)
if(length.out>len(x) && !is.null(fill))
{
results<-t(results)
results[(length(unlist(x))+1):length(unlist(results))]<-fill
results<-t(results)
}
if(restoreClass)
if(xclass=='data.frame')
results<-as.data.frame(results)
else
results<-as(results,xclass)
return(results)
}
#' A more versatile form of the T-SQL \code{coalesce()} function.
#'
#' Little more than a wrapper for \code{\link{vectorize}}, allows for duplication of SQL coalesce functionality, certain types of if-else statements, and \code{\link{apply}}/\code{\link{Reduce}} combinations.
#'
#' @param ... an arbitrary number of \code{R} objects
#' @param fun a two argument function that returns an atomic value
#' @export
#' @examples
#' coalesce(c(NA,1,2))
#' coalesce(c(NA,1,2),c(3,4,NA))
#' df<-data.frame(a=c(NA,2,3),b=c(1,2,NA))
#' coalesce(df$a,df$b)
#' # Or even just:
#' coalesce(df)
coalesce<-function(...,fun=(function (x,y) if(!is.na(x)) x else y))
{
FUN=match.fun(fun)
vectorize(FUN)(...)
}
#'A more versatile form of the T-SQL \code{count()} function.
#'
#'Implementation of T-SQL \code{count} and Excel \code{COUNTIF} functions.  Shows the total number of elements in any number of data objects altogether or that match a condition.
#'
#'@param ... an arbitrary number of \code{R} objects
#'@param condition a 1 argument condition
#'@export
#'@examples
#'count(c(NA,1,2))
#'count(c(NA,1,2),is.na)
#'count(c(NA,1,2),list('A',4),cbind(1,2,3))
#'count(c(NA,1,2),list('A',4),cbind(1,2,3),condition=is.character)
count<-function(...,condition=(function (x) TRUE))
{
data<-c(...)
result<-sum(sapply(data, function (x) if(condition(x)) 1 else 0))
return(result)
}
#'Applies a function to a rolling window along any data object.
#'
#'Similar but not identical to \code{\link{rollapply}} in package {\code\link{zoo}}, with the advantage that it works on any type of data structure (vector, list, matrix, etc) instead of requiring a \code{\link{zoo}} object.
#'
#'@param fun the function to evaluate
#'@param ... all other arguments to be passed to fun
#'@export
#'@examples
#'rollApply(1:100,sum,minimum=2,window=2)
#'rollApply(1:100,mean,minimum=30,window=30,align='right')
rollApply <- function(data,fun,window=len(data),minimum=1,align='left')
{
if(minimum>len(data))
return()
FUN=match.fun(fun)
if (align=='left')
result<-sapply(1:(len(data)-minimum+1),function (x) FUN(rows(data,x:(min(len(data),(x+window-1))))))
if (align=='right')
result<-sapply(minimum:len(data),function (x) FUN(rows(data,max(1,x-window+1):x)))
return(result)
}
rowApply<-function(data,fun)
{
vapply(1:len(data),function (x) fun(rows(data,x)))
}
#'Wraps a function to only display it's results when matching a specific condition.
#'
#'Implementation of T-SQL \code{count} and Excel \code{COUNTIF} functions.  Shows the total number of elements in any number of data objects altogether or that match a condition.
#'
#'@param condition
#'@param fun
#'@param ...
#'@export
#'@examples
#'count(c(NA,1,2))
#'count(c(NA,1,2),is.na)
#'count(c(NA,1,2),list('A',4),cbind(1,2,3))
#'count(c(NA,1,2),list('A',4),cbind(1,2,3),condition=is.character)
alert<-function(condition)
{
function(fun)
{
function(...)
{
results<-fun(...)
if(condition(results))
{
results
}
}
}
}
#'An alternative to \code{\link{system.time}} that prints the times to the screen while returning the result of the original operation.
#'
#'This process time utility can be wrapped around any normal function with no effect other than printing the process time to the screen.  This allows visual feedback on timing without otherwise interrupting the operation of the function.
#'
#'@param fun the function to evaluate
#'@param ... all other arguments to be passed to fun
#'@export
#'@examples
#'results<-time (vectorize(sum))(rep.int(x=5,times=1000000))
#'results
time<-function(fun)
{
function(...)
{
ptm<-proc.time()
results<-fun(...)
print(proc.time()-ptm)
return(results)
}
}
#'A wrapper that will add a progress bar to many higher order functions.
#'
#'This process time utility can be wrapped around any normal function with no effect other than printing the process time to the screen.  This allows visual feedback on timing without otherwise interrupting the operation of the function.
#'
#'@param fun the function to evaluate
#'@param ... all other arguments to be passed to fun
#'@export
#'@examples
#'results<-pb(lapply)(sqrt,rep.int(x=5,times=100000))
#'results<-pb(Reduce)('+',sqrt(c(1:100000)))
pb<-function(fun)
{
function(f,data,...)
{
env <- environment()
pb_Total <- len(data)
counter <- 0
pb <- txtProgressBar(min = 0, max = pb_Total, style = 3)
FUN<-match.fun(f)
wrapper <- function(...){
curVal <- get("counter", envir = env)
assign("counter", curVal +1 ,envir=env)
setTxtProgressBar(get("pb", envir=env), curVal +1)
FUN(...)
}
if(any(grepl('f',names(formals(fun)))))
arg<-'f'
if(any(grep('FUN',names(formals(fun)))))
arg<-'FUN'
ptm<-proc.time()
call<-parse(text=paste("fun(",arg,'=wrapper,','data)'))
res <- eval(call)
print(proc.time()-ptm)
close(pb)
res
}
}
Curry <- function(FUN,...) {
.orig = list(...);
function(...) do.call(FUN,c(.orig,list(...)))
}
Compose <- function(...) {
fs <- list(...)
function(...) Reduce(function(x, f) f(x),
fs,
...)
}
#Funcall and iterate can be called by example(Reduce)
Funcall <- function(f, ...)
{
f(...)
}
## Compute log(exp(acos(cos(0))
#Reduce(Funcall, list(log, exp, acos, cos), 0, right = TRUE)
#This is probably obsoleted by proper use of do.call:
#Reduce(function (fun,x) do.call(fun,list(x)), list(log, exp, acos, cos), 5, right = TRUE)
## n-fold iterate of a function, functional style:
Iterate <- function(f, n = 1) function(x) Reduce(Funcall, rep.int(list(f), n), x, right = TRUE)
#> Iterate (function (x) x^2,n=3)(2)
#[1] 256
vectorize(`+`)(c(1,2,3),list(1,2,3),cbind(c(1,2,3)))
vectorize(`+`)(c(1,2,3),list(1,2,3),cbind(c(1,2)))
Vectorize(sum)(c(1,2,3),c(1,2,3))
count(c(NA,1,2),list('A',4),cbind(1,2,3),condition=is.character)
ddply
library(plyr)
count
ddply(cbind(c(1,2,3),c('A',2,'B')))
ddply(cbind(c(1,2,3),c('A',2,'B')),.fun=count)
ddply(cbind(c(1,2,3),c('A',2,'B')),,.fun=count)
library(rowr)
results<-cbind.fill(c(1,2,3),list(1,2,3),cbind(c('a','b')),'a',df,fill=NA)
results
buffer
library(rowr)
rowApply
rowApply(list(1,2,3))
rowApply(list(1,2,3),force)
vapply
?vapply
rowApply(list(1,2,3),force,list(1,2,3))
rowApply(list(1,2,3),force,FUN.VALUE=list(1,2,3))
rowApply<-function(data,fun)
{
vapply(1:len(data),function (x) fun(rows(data,x)),data)
}
rowApply(list(1,2,3),force)
rows(list(1,2,3),1)
rowApply<-function(data,fun)
{
sapply(1:len(data),function (x) fun(rows(data,x)))
}
rowApply(list(1,2,3),force)
rowApply(c(1,2,3),force)
df
rowApply(df,force)
class(rowApply(df,force))
rowApply(df,force)
as2
library(rowr)
as2
as.data.frame(rowApply(df,force))
rowApply<-function(data,fun)
{
lapply(1:len(data),function (x) fun(rows(data,x)))
}
rowApply(df,force)
as.data.frame(rowApply(df,force))
rowApply<-function(data,fun)
{
apply(1:len(data),1,function (x) fun(rows(data,x)))
}
rowApply(df,force)
rowApply<-function(data,fun)
{
lapply(1:len(data),function (x) fun(rows(data,x)))
}
rowApply(df,force)
as.matrix(rowApply(df,force))
rowApply(df,sum)
as.data.frame(rowApply(df,sum))
rowApply<-function(data,fun)
{
sapply(1:len(data),function (x) fun(rows(data,x)))
}
rowApply(df,sum)
rowApply(list(1,2,3),sum)
rowApply(list(1,2,3),fun=sum)
rows(list(1,2,3),1)
rowApply<-function(data,fun)
{
sapply(1:len(data),function (x) fun(rows(data,x)))
}
rows(list(1,2,3),1)
rows(list(1,2,3),1)
rowApply(list(1,2,3),fun=sum)
(function (data) sapply(1:len(data),function (x) fun(rows(data,x))))(list(1,2,3))
(function (data) sapply(1:len(data),function (x) sum(rows(data,x))))(list(1,2,3))
rows
rowApply(list(1,2,3),fun=force)
rowApply(list(1,2,3),fun=function (x) unlist(sum(x)))
rowApply(list(1,2,3),fun=function (x) sum(unlist(x)))
rowApply<-function(data,fun)
{
sapply(1:len(data),function (x) fun(unlist(rows(data,x),recursive=FALSE)))
}
rowApply(list(1,2,3),fun=function (x) sum(unlist(x)))
rowApply(list(1,2,3),fun=sum)
rowApply(df, sum)
rollApply <- function(data,fun,window=len(data),minimum=1,align='left')
{
if(minimum>len(data))
return()
FUN=match.fun(fun)
if (align=='left')
result<-rowApply(1:(len(data)-minimum+1),function (x) FUN(rows(data,x:(min(len(data),(x+window-1))))))
if (align=='right')
result<-rowApply(minimum:len(data),function (x) FUN(rows(data,max(1,x-window+1):x)))
return(result)
}