#' INTERNAL FUNCTION: Apply a function with list output over data subsets and structure output into various matrices.
#'
#' @param data Data frame
#' @param by Separate vector or Variable in data (name or number) defining the subsets (strata)
#' @param Fun Function to be applied on data subsets
#' @param copyVar Variables from input data to be directly copied to output
#' @param byName Name to be used in output of variable defining subsets
#' @param byNameDefault Name to be used when byName=NULL and when name cannot be taken from input variable
#' @param multiUnlist When TRUE output elements "multi*" are split as separate elements.
#' @param FunTotal A function to be applied on output element "aggregates" so that output element "total" is produced
#' @param FunMultiTotal A function to be applied on output element "multiAggregates" so that output element "multiTotal" is produced
#' @param ... Further arguments passed to Fun
#'
#' @return Output is a list with elements:
#' \item{micro}{Matrix with as many rows as data - composed of vector output.}
#' \item{aggregates}{Matrix with as many rows as the number of subsets - composed of scalar output.}
#' \item{total}{Result of FunTotal (typically a matrix with a single row).}
#' \item{multiMicro}{List of matrices with as many rows as data - composed of matrix output.}
#' \item{multiAggregates}{List of matrices with as many rows as the number of subsets - composed of single row matrix output.}
#' \item{multiTotal}{Result of FunMultiTotal (typically list of matrices with a single row).}
#' \item{other}{List of output that did not fit into other elements.}
#' Empty elements are removed from output. Elements may also be changed due to multiUnlist.
#' @export
#'
#' @examples
#' FunFun = function(data,x){
#' list(max=max(data[,x]),plus100=data[,x]+100,range=t(range(data[,x])),
#' xsqrtx5=cbind(data[,x],sqrt(data[,x]),5),onefive=t(1:5))}
#' z = data.frame(x=(1:10)^2,k=c(1,2,2,3,3,3,4,4,4,4),six=rep(6,10))
#' FunFun(z,"x")
#' StrataApply(z,"k",FunFun,copyVar="six",x="x")
#' StrataApply(z,"k",FunFun,copyVar="six",x="x",multiUnlist=TRUE)
StrataApply <- function(data,by,Fun,copyVar=NULL,byName=NULL,byNameDefault="strata",
multiUnlist=FALSE, FunTotal=NULL,FunMultiTotal=NULL,
...){
stringsAsFactors <- FALSE
default_stringsAsFactors <- getOption("stringsAsFactors", default = FALSE) #default.stringsAsFactors()
if (default_stringsAsFactors) {
options(stringsAsFactors = stringsAsFactors)
}
noEmpty=TRUE # Not input parameter since NULL will anyway be removed
n = NROW(data)
if(length(by)!=n){
if(length(by)!=1) stop("by must be a vector of length NROW(data) or a variable name/number")
if(is.null(byName)) byName = names(data[1,by,drop=FALSE])
by = data[,by]
}
if(is.null(byName)) byName = byNameDefault
uniqueBy = unique(by)
nBy = length(uniqueBy)
dupby = duplicated(by)
#print(by)
if(!any(dupby)){
warning("Only unique elements in by")
byi = uniqueBy[1]
}
else
byi = (by[dupby])[1] # Ensure more that a single element
indbyi = match(byi,uniqueBy)
rbyi = by==byi
a = Fun(data[rbyi, ],...)
###a$m = matrix(rnorm(16),4,4) ###############################
variables = names(a)
nVar = length(variables)
nCOL <- sapply(a, NCOL)
nROW <- sapply(a, NROW)
#empty <- (nCOL*nROW)==0
scalar <- (nCOL*nROW)==1 # x
micro <- (nCOL*nROW)==sum(rbyi) & pmin(nCOL,nROW)==1 # y
multi <- nROW==1 & nCOL>1
micro <- micro & !multi # definition conflict ...
multiMicro <- nROW==sum(rbyi) & nCOL>1
other <- !(scalar|micro|multi|multiMicro)
#return(list(empty=empty,scalar=scalar,micro=micro,other=other))
#if(any(empty)) warning(paste("Empty output ignored:", names(a)[empty]))
#if(any(other)) warning(paste("Other output ignored:", names(a)[empty])) # Change later
ind = rep(1,n)
ind[rbyi] = seq_len(sum(rbyi))
#return(a)
x = cbind(uniqueBy,data.frame(a[scalar])[rep(1,nBy), ,drop=FALSE])
y = cbind(data[,copyVar],by,data.frame(a[micro])[ind, ,drop=FALSE])
names(x)[1]=byName
names(y)[seq_len(length(copyVar))] = names(data[1,copyVar,drop=FALSE])
names(y)[length(copyVar) +1]=byName
rownames(x) = NULL
rownames(y) = NULL
nMulti = sum(multi)
nMultiMicro = sum(multiMicro)
indMulti = seq_len(nVar)[multi]
indMultiMicro = seq_len(nVar)[multiMicro]
z =vector("list", nMulti)
m =vector("list", nMultiMicro)
names(z) = variables[multi]
names(m) = variables[multiMicro]
for(i in seq_len(nMulti)){
z[[i]] = a[[indMulti[i]]][rep(1,nBy), ,drop=FALSE]
rownames(z[[i]]) = NULL
}
for(i in seq_len(nMultiMicro)){
m[[i]] = a[[indMultiMicro[i]]][ind, ,drop=FALSE]
rownames(m[[i]]) = NULL
}
if(sum(other)>0){
w =vector("list", nBy)
w[[indbyi]] = a[other]
names(w) = uniqueBy
}
else w = NULL
for(byi in uniqueBy[-indbyi]){ #indbyi] already calculated
rbyi = by==byi
k = match(byi,uniqueBy)
a = Fun(data[rbyi, ],...)
####a$m = matrix(rnorm(16),4,4) ###############################
x[k,variables[scalar]] = a[scalar]
y[rbyi,variables[micro]] = a[micro]
for(i in seq_len(nMulti)){
z[[i]][k, ] = a[[indMulti[i]]]
}
for(i in seq_len(nMultiMicro)){
m[[i]][rbyi, ] = a[[indMultiMicro[i]]]
}
if(!is.null(w)) w[[k]] = a[other]
}
if(!is.null(FunTotal)) total = FunTotal(x)
else total=NULL
if(!is.null(FunMultiTotal)) multiTotal = FunMultiTotal(z)
else multiTotal=NULL
out=NULL
if(!noEmpty | length(y)) out$micro=y
if(!noEmpty | length(x)) out$aggregates=x
if(!noEmpty | length(total)) out$total=total
if(!multiUnlist & (!noEmpty | length(m))) out$multiMicro=m
if(!multiUnlist & (!noEmpty | length(z))) out$multiAggregates=z
if((!multiUnlist | !is.list(multiTotal))& (!noEmpty | length(multiTotal))) out$multiTotal=multiTotal
if(!noEmpty | length(w)) out$other=w
if(multiUnlist){
if(!is.list(multiTotal)) multiTotal=NULL
out=c(out,m,z,multiTotal)
}
if (default_stringsAsFactors) {
options(stringsAsFactors = default_stringsAsFactors)
}
return(out)
#tot=NULL
#list(micro=y,aggregates=x,total=total,multiMicro=m,multiAggregates=z,multiTotal=multiTotal,other=w)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.