R/repmatch.R
In divDyn/r_package: Diversity Dynamics using Fossil Sampling Data
Defines functions
is.vector.like
selcolDiffdat
selcolUnrolled
dfrm
mrm
vrm
repmatch
Documented in
repmatch
#' Replicate matching and merging
#'
#' This pseudo-generic function iterates a function on the subelements of a list of objects that have the same class and matching dimensions/names and reorganizes the result to match the structure of the replicates or a prototype template.
#'
#' The function is designed to unify/merge objects that result from the same function applied to different source data (e.g. the results of \code{subsample()}). In its current form, the function supports \code{vectors} (including one-dimensional \code{tables} and \code{arrays}), \code{matrix} and \code{data.frame} objects.
#' @return If \code{FUN} is a \code{function}, the output is \code{vector} for \code{vector}-like replicates, \code{matrix} when \code{x} is a \code{list} of \code{matrix} objects, and \code{data.frame}s for \code{data.frame} replicates. In case \code{FUN=NULL}: if \code{x} is a list of \code{vectors}, the function will return a \code{matrix}; an \code{array} is returned, if \code{x} is a \code{list} of \code{matrix} class obejcts; if \code{x} is a list of \code{data.frame} objects, the function returns a \code{data.frame}.
#' @param x (\code{list}): A \code{list} of replicates.
#' @param FUN (\code{function}): A function to merge with and to be applied to the values of identical positions in different replicates. This function must have a single output value, \code{vectors} are not allowed. The default \code{NULL} option returns an element-wise reorganization of the data.
#' @param proto (\code{same as x[[1]]}): The prototype for matching/merging. The prototype is used as a check (\code{"dim"}) or a template (\code{"name"}) during the matching process, depending on the used directive (\code{direct} argument). It is an object with the same class as the replicates, and have the same dimensions and/or overlapping names. If the \code{"name"} directive is used and a \code{prototype} is provided, the funtion will force the output to have the same structure as the prototype, by omitting unnecessary information and inserting missing values (\code{NAs}). The prototype is expected to be an object that has more or equal elements than the replicates, otherwise the call will result in a warning.
#' @param direct (\code{character}): Matching directive(s). Can either be dimension-based (\code{"dim"}) and/or name-based (\code{name}). Dimension-based directive matches the replicates if they have the same dimesions. The \code{"name"} directive requires named input (for \code{matrices} and \code{data.frames} \code{colnames} and \code{rownames} attributes). Replicates will be matched if the values have the same names. In case both directives are specified (default), dimension-based directive takes higher priority, if matching is unsuccessful with dimensions, names will be tried after.
#' @param ... arguments passed to \code{FUN}.
#,
#' @examples
#' # basic example
#' vect <- rnorm(100)
#' # make 50 replicates
#' repl <- rep(list(vect), 50)
#' repmatch(repl, FUN=mean, direct="dim")
#'
#' # named input
#' # two vectors
#' # a
#' a<- 1:10
#' names(a) <- letters[1:length(a)]
#' a[c(3,5,8)] <- NA
#' a <- a[!is.na(a)]
#'
#' #b
#' b<- 10:1
#' names(b) <- letters[length(b):1]
#' b[c(1, 3,6, length(b))]<- NA
#' b <- b[!is.na(b)]
#'
#' # list
#' x2 <- rep(c(list(a),list(b)), 3)
#'
#' # simple match - falling through "dim" to "name" directive
#' repmatch(x2, FUN=NULL)
#'
#' # prototyped
#' prot <- 1:10
#' names(prot) <-letters[1:10]
#'
#' repmatch(x2, FUN=mean, proto=prot, na.rm=TRUE)
#' @export
repmatch <- function(x, FUN=NULL, proto=NULL,direct=c("dim", "name"), ...){
# x should be a list
if(!is.list(x)) stop("'x' must be a list class object. ")
allClass<- sapply(x, function(y){
paste(class(y), collapse="_")
})
if(length(unique(allClass))!=1) stop("The replicates do not have the same class.")
# the class of the first element
cl<- class(x[[1]])
# vector-like output
res <- NULL
if(is.vector.like(x[[1]])) res <- vrm(x=x, FUN=FUN, proto=proto, direct=direct,...)
# matrix
if("matrix"%in%cl) res <- mrm(x=x, FUN=FUN, proto=proto, direct=direct,...)
# i.e.multivariate
if("data.frame"%in%cl) res <- dfrm(x=x, FUN=FUN, proto=proto, direct=direct, ...)
return(res)
}
# for vectors
vrm<-function(x, FUN=NULL, proto=NULL,direct=c("dim", "name"), ...){
# make sure that proto's class is the same as that of the other
if(!is.null(proto)){
if(!is.vector.like(proto)) stop("The prototype is not a vector.")
}
# assume no match will happen
match <- FALSE
# 1. first matching directive: the proto dimensions match those of all the replicates
# replicate lengths are the same
if("dim"%in%direct){
# get the length of all replicates
allLength <- unique(unlist(lapply(x, length)))
# only if there is only one length type
if(length(allLength)==1){
# simply calculate it
unrolled<-unlist(x)
mat <-matrix(unrolled, ncol=length(x))
if(!is.null(FUN)){
res <-apply(mat, 1, FUN,...)
}else{
res <- mat
}
# the proto is only used for checking
if(!is.null(proto)){
if(allLength==length(proto)){
match <- TRUE
}else{
match <- FALSE
}
}else{
match <- TRUE
}
}
}
# 2. directive: use the names of the vectors for matching - lengths do not need to be the same
if("name"%in%direct & !match){
# all replicates should have names - otherwise this won't work
repNames <- lapply(x, function(i){
is.null(names(i))
})
# check whether all replicates have names
if(sum(unlist(repNames))==0){
if(!is.null(FUN)){
# unfold the list
all <- unlist(x)
# some funcitons expect NAs and treat them differently
# append NAs to the set, if the names are incomplete
nameTab <- table(names(all))
# where this is the maximum potential amount,that means no NA should be added
bComplete <- nameTab==length(x)
append <- rep(NA, sum(!bComplete))
names(append) <- names(nameTab)[!bComplete]
# add to the rest
all<-c(all, append)
# calculate FUN for all levels
res <- tapply(INDEX=names(all), X=all,FUN=FUN,...)
# get rid of the dimesnsion crap of the tapply()
nameRes <- names(res)
dim(res) <- NULL
names(res) <-nameRes
# if there is a proto
if(!is.null(proto)){
# only apply if proto has names and
if(is.null(names(proto))) stop("Prototype provided, but it has no names for the name-directive!")
# compare the proto names with the replicates
nameMissing <- !names(res)%in%names(proto)
if(sum(nameMissing)==length(nameMissing)) stop("Prototype provided, but it has no shared names with the replicates!")
# warning if the names of the replicates are among the names of the proto
if(any(nameMissing)) warning("Replicates have names that the prototype doesn't have!")
# then force proto structure
res <- res[names(proto)]
# cover the ugly, potential NAs in the names
names(res) <- names(proto)
match <- TRUE
}else{
match <- TRUE
}
}else{
nameVect <- unlist(lapply(x, function(y){
names(y)
}))
# unique identities
newNames <- sort(unique(nameVect))
# the number of entrien in every element
noEntries <- sapply(x, length)
# the unfolded list
mess <- unlist(x)
# prototype check for output
if(!is.null(proto)){
# compare the proto names with the replicates
nameMissing <- !newNames%in%names(proto)
if(sum(nameMissing)==length(nameMissing)) stop("Prototype provided, but it has no shared names with the replicates!")
# warning if some of the names of the replicates are not among the names of the prototype
if(any(nameMissing)) warning("Replicates have names that the prototype doesn't have!")
# new names to be used
newNames<- names(proto)
# short mess - changed according to the prototype
bMessKeep <- names(mess)%in%newNames
mess <- mess[bMessKeep]
# no prototype - all entries should be there
}else{
bMessKeep<-rep(T, length(mess))
}
# final, desired structure
resIndex <- paste(rep(newNames, length(x)), rep(1:length(x),each=length(newNames)), sep="_")
# index
ind <- unlist(mapply(function(a, b){
rep(a, b)
}, 1:length(noEntries), noEntries))
# rewrite the names of the object
names(mess) <- paste(names(mess), ind[bMessKeep], sep="_")
# the final matrix
res<- matrix(mess[resIndex], ncol=length(x), byrow=FALSE)
rownames(res) <- newNames
match <- TRUE
}
}else{
stop("The 'name' directive is used, but at least one replicate has no names.")
}
}
# if still not found, report
if(!match & !is.null(proto)) stop("Could not match vector replicates with the prototype.")
if(!match & is.null(proto)) stop("Dimensions of vector replicates do not match.")
return(res)
}
# for matrices
mrm<-function(x, FUN=NULL, proto=NULL,direct=c("dim", "name"), ...){
# make sure that proto's class is the same as that of the other
if(!is.null(proto)){
if(!is.matrix(proto)) stop("The prototype is not a matrix.")
}
# assume no match will happen
match <- FALSE
# 1. first matching directive: the proto dimensions match those of all the replicates
# replicate lengths are the same
if("dim"%in%direct){
# get the length of all replicates
allDim <- t(sapply(x, dim))
dimGuide <- unique(unique(allDim))
# only if there is only one dimensiony type
if(nrow(dimGuide)==1){
# simply calculate it
unrolled<-unlist(x)
arr <-array(unrolled, dim=c(dimGuide[1,,drop=TRUE], length(x)))
if(!is.null(FUN)){
res <-apply(arr, c(1,2), FUN,...)
}else{
res <- arr
}
# the proto is only used for checking
if(!is.null(proto)){
if(sum(dimGuide==dim(proto))==length(dimGuide)){
match <- TRUE
}else{
match <- FALSE
}
}else{
match <- TRUE
}
}
}
# 2. directive: use the names of the vectors for matching - lengths do not need to be the same
if("name"%in%direct & !match){
# all replicates should have names - otherwise this won't work
repNames <- lapply(x, function(i){
is.null(colnames(i)) | is.null(rownames(i))
})
# check whether all replicates have names
if(sum(unlist(repNames))==0){
# get the rownames
allRowNames<- unique(unlist(lapply(x, function(i){
rownames(i)
})))
# get the colnames
allColNames<- unique(unlist(lapply(x, function(j){
colnames(j)
})))
# is there a prototype?
if(!is.null(proto)){
# is it useable?
if(is.null(rownames(proto)) | is.null(colnames(proto))) stop("Prototype provided, but it has no 'colnames' and 'rownames' to be used with the name directive.")
# overlap with the names of replicates?
if(sum(rownames(proto)%in%allRowNames)==0) stop("The prototype and the replicates do not share any element in their 'rownames' attribute.")
if(sum(colnames(proto)%in%allColNames)==0) stop("The prototype and the replicates do not share any element in their 'colnames' attribute.")
if(sum(allColNames%in%colnames(proto))!=length(allColNames)) warning("The replicates have 'colnames' entries that the prototype doiesn't have.")
if(sum(allRowNames%in%rownames(proto))!=length(allRowNames)) warning("The replicates have 'rownames' entries that the prototype doiesn't have.")
# the use the prototype's names for the output
allRowNames <- rownames(proto)
allColNames <- colnames(proto)
}
# create an array for holding the data
arr <- array(NA, dim=c(length(allRowNames), length(allColNames), length(x)))
dimnames(arr) <- list(allRowNames,allColNames,1:length(x))
# for starters, use a simple for loop to fill in the matrix
for(i in 1:length(x)){
cur <- x[[i]]
matchRow <- rownames(cur)[rownames(cur)%in%allRowNames]
matchCol <- colnames(cur)[colnames(cur)%in%allColNames]
arr[matchRow, matchCol,i] <- cur[matchRow, matchCol]
}
# then appply function if necessary
if(!is.null(FUN)){
res <-apply(arr, c(1,2), FUN,...)
}else{
res <- arr
}
match <- TRUE
}else{
stop("The 'name' directive is used, but at least one replicate has no names.")
}
}
# if still not found, report
if(!match & !is.null(proto)) stop("Could not match vector replicates with the prototype.")
if(!match & is.null(proto)) stop("Dimensions of vector replicates do not match.")
return(res)
}
# @param to (\code{character}) Argument of the \code{data.frame} matching method. Either \code{"num"}, \code{"log"} or \code{"char"}. This argument specifices which variable types the \code{FUN} will be applied to (to avoid problems with non-applicables, such \code{mean} to \code{character} \code{vectors}).
dfrm <- function(x, FUN=NULL, proto=NULL, direct=c("dim", "name"), to=c("num", "log"),...){
if(!is.null(proto)){
if(!class(proto)%in%"data.frame") stop("Prototype class is not data.frame!")
}
# assume a non-successful match
match <- FALSE
# 1.st directive: use the dimensions and types
if("dim"%in%direct){
# immediately check whether it is applicable or not - <make sure every rep has two dimensions!>
allDim <- t(sapply(x, dim))
dimGuide <- unique(unique(allDim))
# if all have just one dimension vector
if(nrow(dimGuide)==1){
dim(dimGuide) <- NULL
if(!is.null(proto)){
if(sum(dim(proto)==dimGuide)!=length(dimGuide)) stop("The dimensions of prototype doesn't match that of the replicates.")
}
# check the vector types in each column of every replicate
types<- t(sapply(x, function(i){
sapply(i,function(j){
if(is.numeric(j)) ret <- "num"
if(is.character(j)) ret <- "char"
if(is.logical(j)) ret <- "log"
if(is.factor(j)) ret <- "fac"
return(ret)
})
}))
# are they consistent?
typeGuide <- unique(types)
origColNames <- colnames(typeGuide)
# if the types also match
if(nrow(typeGuide)==1){
dim(typeGuide)<- NULL
if("fac"%in%typeGuide) stop("Factor variables are not supported, use 'character' instead.")
# at this point assume that the match succeeded
match <- TRUE
# is there a prototype - check whether it matches the replicates
if(!is.null(proto)){
# make sure that the prototype has the same types as the replicates
typeProto<- sapply(proto,function(j){
ret <- NA
if(is.numeric(j)) ret <- "num"
if(is.character(j)) ret <- "char"
if(is.logical(j)) ret <- "log"
if(is.factor(j)) ret <- "fac"
return(ret)
})
# and check whether they match
if(any(typeProto[origColNames]!=typeGuide)){
# match is unsuccesful, you have to use the name directive
match <- FALSE
}
#if there isn't, then use replicates' , it's cool
}
# continue if not directed otherwise
if(match){
# unroll the whole thing:
mess <- unlist(x)
# three index vectors to separate the numeric, character and logical entries
numInd <- which(typeGuide=="num")
charInd <- which(typeGuide=="char")
logInd <- which(typeGuide=="log")
# boolean index values for these types
bNum <-selcolUnrolled(colInd=numInd, nRow=dimGuide[1], nCol=dimGuide[2], nPlane=length(x))
bChar <-selcolUnrolled(colInd=charInd, nRow=dimGuide[1], nCol=dimGuide[2], nPlane=length(x))
bLog <-selcolUnrolled(colInd=logInd, nRow=dimGuide[1], nCol=dimGuide[2], nPlane=length(x))
#select the values and cast
numPart <- as.numeric(mess[bNum])
charPart <- as.character(mess[bChar])
logPart <- as.logical(mess[bLog])
# structure these to arrays
arNum <- array(numPart, dim=c(dimGuide[1],length(numInd), length(x)))
arChar <- array(charPart, dim=c(dimGuide[1],length(charInd), length(x)))
arLog <- array(logPart, dim=c(dimGuide[1],length(logInd), length(x)))
# regular function applied
if(!is.null(FUN)){
# and apply if asked for - default is not for characters!!!
if("num"%in%to){
resNum <- as.data.frame(apply(arNum, c(1,2), FUN,...))
}else{
resNum <- as.data.frame(matrix(as.numeric(NA), nrow=dimGuide[1], ncol=length(numInd)))
}
if("char"%in%to){
resChar <- as.data.frame(apply(arChar, c(1,2), FUN,...), stringsAsFactors=FALSE)
}else{
resChar <- as.data.frame(matrix(as.character(NA), nrow=dimGuide[1], ncol=length(charInd)), stringsAsFactors=FALSE)
}
if("log"%in%to){
resLog <- as.data.frame(apply(arLog, c(1,2), FUN,...))
}else{
resLog <- as.data.frame(matrix(as.logical(NA), nrow=dimGuide[1], ncol=length(logInd)))
}
# create an output dataframe
res<- cbind(resChar, resLog, resNum)
# since the dimensions did not change, you can just copy the row names
rownames(res) <- rownames(x[[1]])
# return variable-list construct!
}else{
# create a list for all Variables (columns)
# numeric first
numList <- list()
for(i in 1:length(numInd)){
numList[[i]]<- arNum[,i,]
rownames(numList[[i]]) <- rownames(x[[1]])
}
charList <- list()
for(i in 1:length(charInd)){
charList[[i]]<- arChar[,i,]
rownames(charList[[i]]) <- rownames(x[[1]])
}
logList <- list()
for(i in 1:length(logInd)){
logList[[i]]<- arLog[,i,]
rownames(logList[[i]]) <- rownames(x[[1]])
}
# concatenate
res <- c(charList, logList, numList)
}
# use previous indices to
origInd <- c(charInd, logInd, numInd)
resInd <- rep(NA, length(origInd))
resInd[origInd] <- 1:length(resInd)
# order the types correctly
res <- res[resInd]
# use the names of the first names
names(res) <- origColNames
}
}else{
# error:dimensions match but types do not -use names!!!
}
}
}
# 2.nd directive: use the names (rownames) to match
if("name"%in%direct & !match){
# get the dimensions
allDim <- t(sapply(x, dim)) # they can be different
# if there is a prototype
if(!is.null(proto)){
# check whether prototype has names
if(is.null(colnames(proto)) | is.null(rownames(proto))) stop("Prototype has no names, cannot be processed with names directive.")
}
# check whether everyhing has names
repNames <- lapply(x, function(i){
is.null(colnames(i)) | is.null(rownames(i))
})
# only if every replicate has both colnames and rownames
if(sum(unlist(repNames))==0){
# check the vector types in each column of every replicate
types<- lapply(x, function(i){
sapply(i,function(j){
if(is.numeric(j)) ret <- "num"
if(is.character(j)) ret <- "char"
if(is.logical(j)) ret <- "log"
if(is.factor(j)) ret <- "fac"
return(ret)
})
})
# unfold the types, just a vector of tpyes
names(types) <- NULL
messType <- unlist(types)
# check whether the same variable names have just one type!
typeMatch <- tapply(INDEX=names(messType), X=messType, FUN=function(i){
length(unique(i))==1
})
# all types match
if(!any(!typeMatch)){
# unfold the data
mess <- unlist(x)
# rownames of every data frame
na<-lapply(x, function(d){
rownames(d)
})
# create a unique ID for every entry entry
# if there is a function
if(!is.null(FUN)){
idList <- mapply(FUN=function(i,j){
# i<-na[[1]]
# j<-types[[1]]
rowID <-rep(i, length(j))
bothID<- paste(rowID, rep(names(j), each=length(i)), sep="_")
}, na, types)
# if there is NULL
}else{
idList <- mapply(FUN=function(i,j,k){
# i<-na[[1]]
# j<-types[[1]]
rowID <-rep(i, length(j))
planeID <- rep(k, length(rowID))
bothID<- paste(rowID, rep(names(j), each=length(i)),planeID, sep="_")
}, na, types, 1:length(x))
}
# the unique name of every entry
names(mess) <- unlist(idList)
# distribute data to numeric, logical and
numInd <- which(messType=="num")
charInd <- which(messType=="char")
logInd <- which(messType=="log")
# factor and others?
#how many entries are there in column
colGuide <- apply(allDim, 1, function(d){
rep(d[1], d[2])
})
if(is.list(colGuide)) colGuide <- unlist(colGuide)
if(is.matrix(colGuide)) dim(colGuide)<-NULL
bLog<-selcolDiffdat(colGuide, logInd)
bNum<-selcolDiffdat(colGuide, numInd)
bChar<-selcolDiffdat(colGuide, charInd)
# get the value specific parts and cast
messLog <-as.logical(mess[bLog])
messNum <- as.numeric(mess[bNum])
messChar <- as.character(mess[bChar])
# the averaging can be done with tapply so we need the names
nameLog <- names(mess)[bLog]
nameNum <- names(mess)[bNum]
nameChar <- names(mess)[bChar]
# there is a function to process the data
if(!is.null(FUN)){
# and apply if asked for - default is not for characters!!!
if("num"%in%to){
resNum <- tapply(INDEX=nameNum, X=messNum, FUN=FUN,...)
# omit stupid NaN
resNum[is.nan(resNum)] <- NA
}else{
uNumName <- sort(unique(nameNum))
resNum<- rep(as.numeric(NA), length(uNumName))
names(resNum) <- uNumName
}
if("char"%in%to){
resChar <- tapply(INDEX=nameChar, X=messChar, FUN=FUN,...)
}else{
uCharName <- sort(unique(nameChar))
resChar<- rep(as.character(NA), length(uCharName))
names(resChar) <- uCharName
}
if("log"%in%to){
resLog <- tapply(INDEX=nameLog, X=messLog, FUN=FUN,...)
resLog[is.nan(resLog)] <- NA
}else{
uLogName <- sort(unique(nameLog))
resLog<- rep(as.logical(NA), length(uLogName))
names(resLog) <- uLogName
}
# distribution output
}else{
names(messNum) <- nameNum
names(messLog) <- nameLog
names(messChar) <- nameChar
}
# final object structure
if(is.null(proto)){
# the final potential rownames
totRows <- sort(unique(unlist(na)))
# final potential variables
totNumCols <- unique(names(messType)[numInd])
totCharCols <- unique(names(messType)[charInd])
totLogCols <- unique(names(messType)[logInd])
}else{
# column and rownames of the prototype
totRows<- rownames(proto)
# types of the prototype
typeProto <- sapply(proto,function(j){
if(is.numeric(j)) ret <- "num"
if(is.character(j)) ret <- "char"
if(is.logical(j)) ret <- "log"
if(is.factor(j)) ret <- "fac"
return(ret)
})
totNumCols <- names(typeProto)[typeProto=="num"]
totCharCols <- names(typeProto)[typeProto=="char"]
totLogCols <- names(typeProto)[typeProto=="log"]
}
# for function output
if(!is.null(FUN)){
# potential identifiers
potNumNames <- paste(rep(totRows, length(totNumCols)), rep(totNumCols, each=length(totRows)),sep="_")
potCharNames <- paste(rep(totRows, length(totCharCols)), rep(totCharCols, each=length(totRows)),sep="_")
potLogNames <- paste(rep(totRows, length(totLogCols)), rep(totLogCols, each=length(totRows)),sep="_")
# reorder the result output for folding
resNumFold <- resNum[potNumNames]
resCharFold <- resChar[potCharNames]
resLogFold <- resLog[potLogNames]
# fold and make a data.frame
numMat <- as.data.frame(matrix(resNumFold, nrow=length(totRows), byrow=FALSE))
charMat <- as.data.frame(matrix(resCharFold, nrow=length(totRows), byrow=FALSE), stringsAsFactors=FALSE)
logMat <- as.data.frame(matrix(resLogFold, nrow=length(totRows), byrow=FALSE))
# assign the columns
colnames(numMat) <- totNumCols
colnames(charMat) <- totCharCols
colnames(logMat) <- totLogCols
# output and rownames
res <- cbind(numMat, charMat, logMat)
rownames(res) <- totRows
# dist output
}else{
# potential identifiers
potNumNamesPlane <- paste(rep(totRows, length(totNumCols)), rep(totNumCols, each=length(totRows)),sep="_")
potCharNamesPlane <- paste(rep(totRows, length(totCharCols)), rep(totCharCols, each=length(totRows)),sep="_")
potLogNamesPlane <- paste(rep(totRows, length(totLogCols)), rep(totLogCols, each=length(totRows)),sep="_")
# with the plane identifiers
potNumNames <- paste(rep(potNumNamesPlane, length(x)), rep(1:length(x), each=length(potNumNamesPlane)), sep="_")
potCharNames <- paste(rep(potCharNamesPlane, length(x)), rep(1:length(x), each=length(potCharNamesPlane)), sep="_")
potLogNames <- paste(rep(potLogNamesPlane, length(x)), rep(1:length(x), each=length(potLogNamesPlane)), sep="_")
# reorder input
resNumFold <- messNum[potNumNames]
resCharFold <- messChar[potCharNames]
resLogFold <- messLog[potLogNames]
# array representation
numArr<- array(resNumFold, dim=c(length(totRows), length(totNumCols), length(x)))
logArr<- array(resLogFold, dim=c(length(totRows), length(totLogCols), length(x)))
charArr<- array(resCharFold, dim=c(length(totRows), length(totCharCols), length(x)))
# make the variable specific data in a list
# slowest solution ever...
numList<-list()
if(length(totNumCols)>0){
for(i in 1:length(totNumCols)){
temp <- numArr[,i,]
rownames(temp) <- totRows
numList[[i]] <- temp
}
}
logList<-list()
if(length(totLogCols)>0){
for(i in 1:length(totLogCols)){
temp <- logArr[,i,]
rownames(temp) <- totRows
logList[[i]] <- temp
}
}
charList<-list()
if(length(totCharCols)>0){
for(i in 1:length(totCharCols)){
temp <- charArr[,i,]
rownames(temp) <- totRows
charList[[i]] <- temp
}
}
res<-c(numList,logList,charList)
names(res) <- c(totNumCols,totLogCols,totCharCols)
# if there is a prototype
if(!is.null(proto)){
res <- res[names(typeProto)]
names(res) <- names(typeProto)
}
}
} # else fail!
}else{
stop("matching failed.")
}
}
return(res)
}
###### utility functions
# select columns from an unrolled 3d array
selcolUnrolled <- function(colInd,nRow, nCol, nPlane){
#colInd <- numInd
#nRow <- dimGuide[1]
#nCol<- dimGuide[2]
#nPlane<- length(x)
# start with the numeric indices
totNum <- rep(FALSE, nRow*nCol*nPlane)
if(length(colInd)>0){
# for all iterations
for(i in 1:nPlane){
# for of the indices
for(j in 1:length(colInd)){
# all entries from the column
entries<- 1:nRow
# offset the columns
colOffset <- nRow*(colInd[j]-1)
# offset the tables: shift columns by this amount time the number entries in a column
iterOffset <- (i-1)*nCol*nRow
totNum[entries+colOffset+iterOffset] <- TRUE
}
}
}
return(totNum)
}
# select column from unrolled data.frames with
selcolDiffdat <- function(colGuide, colInd){
# logical vector for subsetting
bSubset <- rep(FALSE, sum(colGuide))
if(length(colInd)>0){
# for every relevant column
for(i in 1:length(colInd)){
if(colInd[i]==1){
offset<- 0
}else{
offset<- sum(colGuide[1:(colInd[i]-1)])
}
bSubset[(1:colGuide[colInd[i]])+offset] <- TRUE
}
}
return(bSubset)
}
is.vector.like <- function(x){
cl <- class(x)
if(
"numeric"%in%cl |
"integer"%in%cl |
"double"%in%cl |
"character"%in%cl |
"logical"%in%cl |
("table"%in%cl & length(dim(x))==1) |
("array"%in%cl & length(dim(x))==1)
) state <- TRUE else state <- FALSE
return(state)
}
divDyn/r_package documentation built on Sept. 11, 2022, 9:29 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions is.vector.like selcolDiffdat selcolUnrolled dfrm mrm vrm repmatch
Documented in repmatch
#' Replicate matching and merging
#'
#' This pseudo-generic function iterates a function on the subelements of a list of objects that have the same class and matching dimensions/names and reorganizes the result to match the structure of the replicates or a prototype template.
#'
#' The function is designed to unify/merge objects that result from the same function applied to different source data (e.g. the results of \code{subsample()}). In its current form, the function supports \code{vectors} (including one-dimensional \code{tables} and \code{arrays}), \code{matrix} and \code{data.frame} objects.
#' @return If \code{FUN} is a \code{function}, the output is \code{vector} for \code{vector}-like replicates, \code{matrix} when \code{x} is a \code{list} of \code{matrix} objects, and \code{data.frame}s for \code{data.frame} replicates. In case \code{FUN=NULL}: if \code{x} is a list of \code{vectors}, the function will return a \code{matrix}; an \code{array} is returned, if \code{x} is a \code{list} of \code{matrix} class obejcts; if \code{x} is a list of \code{data.frame} objects, the function returns a \code{data.frame}.
#' @param x (\code{list}): A \code{list} of replicates.
#' @param FUN (\code{function}): A function to merge with and to be applied to the values of identical positions in different replicates. This function must have a single output value, \code{vectors} are not allowed. The default \code{NULL} option returns an element-wise reorganization of the data.
#' @param proto (\code{same as x[[1]]}): The prototype for matching/merging. The prototype is used as a check (\code{"dim"}) or a template (\code{"name"}) during the matching process, depending on the used directive (\code{direct} argument). It is an object with the same class as the replicates, and have the same dimensions and/or overlapping names. If the \code{"name"} directive is used and a \code{prototype} is provided, the funtion will force the output to have the same structure as the prototype, by omitting unnecessary information and inserting missing values (\code{NAs}). The prototype is expected to be an object that has more or equal elements than the replicates, otherwise the call will result in a warning.
#' @param direct (\code{character}): Matching directive(s). Can either be dimension-based (\code{"dim"}) and/or name-based (\code{name}). Dimension-based directive matches the replicates if they have the same dimesions. The \code{"name"} directive requires named input (for \code{matrices} and \code{data.frames} \code{colnames} and \code{rownames} attributes). Replicates will be matched if the values have the same names. In case both directives are specified (default), dimension-based directive takes higher priority, if matching is unsuccessful with dimensions, names will be tried after.
#' @param ... arguments passed to \code{FUN}.
#,
#' @examples
#' # basic example
#' vect <- rnorm(100)
#' # make 50 replicates
#' repl <- rep(list(vect), 50)
#' repmatch(repl, FUN=mean, direct="dim")
#'
#' # named input
#' # two vectors
#' # a
#' a<- 1:10
#' names(a) <- letters[1:length(a)]
#' a[c(3,5,8)] <- NA
#' a <- a[!is.na(a)]
#'
#' #b
#' b<- 10:1
#' names(b) <- letters[length(b):1]
#' b[c(1, 3,6, length(b))]<- NA
#' b <- b[!is.na(b)]
#'
#' # list
#' x2 <- rep(c(list(a),list(b)), 3)
#'
#' # simple match - falling through "dim" to "name" directive
#' repmatch(x2, FUN=NULL)
#'
#' # prototyped
#' prot <- 1:10
#' names(prot) <-letters[1:10]
#'
#' repmatch(x2, FUN=mean, proto=prot, na.rm=TRUE)
#' @export
repmatch <- function(x, FUN=NULL, proto=NULL,direct=c("dim", "name"), ...){
# x should be a list
if(!is.list(x)) stop("'x' must be a list class object. ")
allClass<- sapply(x, function(y){
paste(class(y), collapse="_")
})
if(length(unique(allClass))!=1) stop("The replicates do not have the same class.")
# the class of the first element
cl<- class(x[[1]])
# vector-like output
res <- NULL
if(is.vector.like(x[[1]])) res <- vrm(x=x, FUN=FUN, proto=proto, direct=direct,...)
# matrix
if("matrix"%in%cl) res <- mrm(x=x, FUN=FUN, proto=proto, direct=direct,...)
# i.e.multivariate
if("data.frame"%in%cl) res <- dfrm(x=x, FUN=FUN, proto=proto, direct=direct, ...)
return(res)
}
# for vectors
vrm<-function(x, FUN=NULL, proto=NULL,direct=c("dim", "name"), ...){
# make sure that proto's class is the same as that of the other
if(!is.null(proto)){
if(!is.vector.like(proto)) stop("The prototype is not a vector.")
}
# assume no match will happen
match <- FALSE
# 1. first matching directive: the proto dimensions match those of all the replicates
# replicate lengths are the same
if("dim"%in%direct){
# get the length of all replicates
allLength <- unique(unlist(lapply(x, length)))
# only if there is only one length type
if(length(allLength)==1){
# simply calculate it
unrolled<-unlist(x)
mat <-matrix(unrolled, ncol=length(x))
if(!is.null(FUN)){
res <-apply(mat, 1, FUN,...)
}else{
res <- mat
}
# the proto is only used for checking
if(!is.null(proto)){
if(allLength==length(proto)){
match <- TRUE
}else{
match <- FALSE
}
}else{
match <- TRUE
}
}
}
# 2. directive: use the names of the vectors for matching - lengths do not need to be the same
if("name"%in%direct & !match){
# all replicates should have names - otherwise this won't work
repNames <- lapply(x, function(i){
is.null(names(i))
})
# check whether all replicates have names
if(sum(unlist(repNames))==0){
if(!is.null(FUN)){
# unfold the list
all <- unlist(x)
# some funcitons expect NAs and treat them differently
# append NAs to the set, if the names are incomplete
nameTab <- table(names(all))
# where this is the maximum potential amount,that means no NA should be added
bComplete <- nameTab==length(x)
append <- rep(NA, sum(!bComplete))
names(append) <- names(nameTab)[!bComplete]
# add to the rest
all<-c(all, append)
# calculate FUN for all levels
res <- tapply(INDEX=names(all), X=all,FUN=FUN,...)
# get rid of the dimesnsion crap of the tapply()
nameRes <- names(res)
dim(res) <- NULL
names(res) <-nameRes
# if there is a proto
if(!is.null(proto)){
# only apply if proto has names and
if(is.null(names(proto))) stop("Prototype provided, but it has no names for the name-directive!")
# compare the proto names with the replicates
nameMissing <- !names(res)%in%names(proto)
if(sum(nameMissing)==length(nameMissing)) stop("Prototype provided, but it has no shared names with the replicates!")
# warning if the names of the replicates are among the names of the proto
if(any(nameMissing)) warning("Replicates have names that the prototype doesn't have!")
# then force proto structure
res <- res[names(proto)]
# cover the ugly, potential NAs in the names
names(res) <- names(proto)
match <- TRUE
}else{
match <- TRUE
}
}else{
nameVect <- unlist(lapply(x, function(y){
names(y)
}))
# unique identities
newNames <- sort(unique(nameVect))
# the number of entrien in every element
noEntries <- sapply(x, length)
# the unfolded list
mess <- unlist(x)
# prototype check for output
if(!is.null(proto)){
# compare the proto names with the replicates
nameMissing <- !newNames%in%names(proto)
if(sum(nameMissing)==length(nameMissing)) stop("Prototype provided, but it has no shared names with the replicates!")
# warning if some of the names of the replicates are not among the names of the prototype
if(any(nameMissing)) warning("Replicates have names that the prototype doesn't have!")
# new names to be used
newNames<- names(proto)
# short mess - changed according to the prototype
bMessKeep <- names(mess)%in%newNames
mess <- mess[bMessKeep]
# no prototype - all entries should be there
}else{
bMessKeep<-rep(T, length(mess))
}
# final, desired structure
resIndex <- paste(rep(newNames, length(x)), rep(1:length(x),each=length(newNames)), sep="_")
# index
ind <- unlist(mapply(function(a, b){
rep(a, b)
}, 1:length(noEntries), noEntries))
# rewrite the names of the object
names(mess) <- paste(names(mess), ind[bMessKeep], sep="_")
# the final matrix
res<- matrix(mess[resIndex], ncol=length(x), byrow=FALSE)
rownames(res) <- newNames
match <- TRUE
}
}else{
stop("The 'name' directive is used, but at least one replicate has no names.")
}
}
# if still not found, report
if(!match & !is.null(proto)) stop("Could not match vector replicates with the prototype.")
if(!match & is.null(proto)) stop("Dimensions of vector replicates do not match.")
return(res)
}
# for matrices
mrm<-function(x, FUN=NULL, proto=NULL,direct=c("dim", "name"), ...){
# make sure that proto's class is the same as that of the other
if(!is.null(proto)){
if(!is.matrix(proto)) stop("The prototype is not a matrix.")
}
# assume no match will happen
match <- FALSE
# 1. first matching directive: the proto dimensions match those of all the replicates
# replicate lengths are the same
if("dim"%in%direct){
# get the length of all replicates
allDim <- t(sapply(x, dim))
dimGuide <- unique(unique(allDim))
# only if there is only one dimensiony type
if(nrow(dimGuide)==1){
# simply calculate it
unrolled<-unlist(x)
arr <-array(unrolled, dim=c(dimGuide[1,,drop=TRUE], length(x)))
if(!is.null(FUN)){
res <-apply(arr, c(1,2), FUN,...)
}else{
res <- arr
}
# the proto is only used for checking
if(!is.null(proto)){
if(sum(dimGuide==dim(proto))==length(dimGuide)){
match <- TRUE
}else{
match <- FALSE
}
}else{
match <- TRUE
}
}
}
# 2. directive: use the names of the vectors for matching - lengths do not need to be the same
if("name"%in%direct & !match){
# all replicates should have names - otherwise this won't work
repNames <- lapply(x, function(i){
is.null(colnames(i)) | is.null(rownames(i))
})
# check whether all replicates have names
if(sum(unlist(repNames))==0){
# get the rownames
allRowNames<- unique(unlist(lapply(x, function(i){
rownames(i)
})))
# get the colnames
allColNames<- unique(unlist(lapply(x, function(j){
colnames(j)
})))
# is there a prototype?
if(!is.null(proto)){
# is it useable?
if(is.null(rownames(proto)) | is.null(colnames(proto))) stop("Prototype provided, but it has no 'colnames' and 'rownames' to be used with the name directive.")
# overlap with the names of replicates?
if(sum(rownames(proto)%in%allRowNames)==0) stop("The prototype and the replicates do not share any element in their 'rownames' attribute.")
if(sum(colnames(proto)%in%allColNames)==0) stop("The prototype and the replicates do not share any element in their 'colnames' attribute.")
if(sum(allColNames%in%colnames(proto))!=length(allColNames)) warning("The replicates have 'colnames' entries that the prototype doiesn't have.")
if(sum(allRowNames%in%rownames(proto))!=length(allRowNames)) warning("The replicates have 'rownames' entries that the prototype doiesn't have.")
# the use the prototype's names for the output
allRowNames <- rownames(proto)
allColNames <- colnames(proto)
}
# create an array for holding the data
arr <- array(NA, dim=c(length(allRowNames), length(allColNames), length(x)))
dimnames(arr) <- list(allRowNames,allColNames,1:length(x))
# for starters, use a simple for loop to fill in the matrix
for(i in 1:length(x)){
cur <- x[[i]]
matchRow <- rownames(cur)[rownames(cur)%in%allRowNames]
matchCol <- colnames(cur)[colnames(cur)%in%allColNames]
arr[matchRow, matchCol,i] <- cur[matchRow, matchCol]
}
# then appply function if necessary
if(!is.null(FUN)){
res <-apply(arr, c(1,2), FUN,...)
}else{
res <- arr
}
match <- TRUE
}else{
stop("The 'name' directive is used, but at least one replicate has no names.")
}
}
# if still not found, report
if(!match & !is.null(proto)) stop("Could not match vector replicates with the prototype.")
if(!match & is.null(proto)) stop("Dimensions of vector replicates do not match.")
return(res)
}
# @param to (\code{character}) Argument of the \code{data.frame} matching method. Either \code{"num"}, \code{"log"} or \code{"char"}. This argument specifices which variable types the \code{FUN} will be applied to (to avoid problems with non-applicables, such \code{mean} to \code{character} \code{vectors}).
dfrm <- function(x, FUN=NULL, proto=NULL, direct=c("dim", "name"), to=c("num", "log"),...){
if(!is.null(proto)){
if(!class(proto)%in%"data.frame") stop("Prototype class is not data.frame!")
}
# assume a non-successful match
match <- FALSE
# 1.st directive: use the dimensions and types
if("dim"%in%direct){
# immediately check whether it is applicable or not - <make sure every rep has two dimensions!>
allDim <- t(sapply(x, dim))
dimGuide <- unique(unique(allDim))
# if all have just one dimension vector
if(nrow(dimGuide)==1){
dim(dimGuide) <- NULL
if(!is.null(proto)){
if(sum(dim(proto)==dimGuide)!=length(dimGuide)) stop("The dimensions of prototype doesn't match that of the replicates.")
}
# check the vector types in each column of every replicate
types<- t(sapply(x, function(i){
sapply(i,function(j){
if(is.numeric(j)) ret <- "num"
if(is.character(j)) ret <- "char"
if(is.logical(j)) ret <- "log"
if(is.factor(j)) ret <- "fac"
return(ret)
})
}))
# are they consistent?
typeGuide <- unique(types)
origColNames <- colnames(typeGuide)
# if the types also match
if(nrow(typeGuide)==1){
dim(typeGuide)<- NULL
if("fac"%in%typeGuide) stop("Factor variables are not supported, use 'character' instead.")
# at this point assume that the match succeeded
match <- TRUE
# is there a prototype - check whether it matches the replicates
if(!is.null(proto)){
# make sure that the prototype has the same types as the replicates
typeProto<- sapply(proto,function(j){
ret <- NA
if(is.numeric(j)) ret <- "num"
if(is.character(j)) ret <- "char"
if(is.logical(j)) ret <- "log"
if(is.factor(j)) ret <- "fac"
return(ret)
})
# and check whether they match
if(any(typeProto[origColNames]!=typeGuide)){
# match is unsuccesful, you have to use the name directive
match <- FALSE
}
#if there isn't, then use replicates' , it's cool
}
# continue if not directed otherwise
if(match){
# unroll the whole thing:
mess <- unlist(x)
# three index vectors to separate the numeric, character and logical entries
numInd <- which(typeGuide=="num")
charInd <- which(typeGuide=="char")
logInd <- which(typeGuide=="log")
# boolean index values for these types
bNum <-selcolUnrolled(colInd=numInd, nRow=dimGuide[1], nCol=dimGuide[2], nPlane=length(x))
bChar <-selcolUnrolled(colInd=charInd, nRow=dimGuide[1], nCol=dimGuide[2], nPlane=length(x))
bLog <-selcolUnrolled(colInd=logInd, nRow=dimGuide[1], nCol=dimGuide[2], nPlane=length(x))
#select the values and cast
numPart <- as.numeric(mess[bNum])
charPart <- as.character(mess[bChar])
logPart <- as.logical(mess[bLog])
# structure these to arrays
arNum <- array(numPart, dim=c(dimGuide[1],length(numInd), length(x)))
arChar <- array(charPart, dim=c(dimGuide[1],length(charInd), length(x)))
arLog <- array(logPart, dim=c(dimGuide[1],length(logInd), length(x)))
# regular function applied
if(!is.null(FUN)){
# and apply if asked for - default is not for characters!!!
if("num"%in%to){
resNum <- as.data.frame(apply(arNum, c(1,2), FUN,...))
}else{
resNum <- as.data.frame(matrix(as.numeric(NA), nrow=dimGuide[1], ncol=length(numInd)))
}
if("char"%in%to){
resChar <- as.data.frame(apply(arChar, c(1,2), FUN,...), stringsAsFactors=FALSE)
}else{
resChar <- as.data.frame(matrix(as.character(NA), nrow=dimGuide[1], ncol=length(charInd)), stringsAsFactors=FALSE)
}
if("log"%in%to){
resLog <- as.data.frame(apply(arLog, c(1,2), FUN,...))
}else{
resLog <- as.data.frame(matrix(as.logical(NA), nrow=dimGuide[1], ncol=length(logInd)))
}
# create an output dataframe
res<- cbind(resChar, resLog, resNum)
# since the dimensions did not change, you can just copy the row names
rownames(res) <- rownames(x[[1]])
# return variable-list construct!
}else{
# create a list for all Variables (columns)
# numeric first
numList <- list()
for(i in 1:length(numInd)){
numList[[i]]<- arNum[,i,]
rownames(numList[[i]]) <- rownames(x[[1]])
}
charList <- list()
for(i in 1:length(charInd)){
charList[[i]]<- arChar[,i,]
rownames(charList[[i]]) <- rownames(x[[1]])
}
logList <- list()
for(i in 1:length(logInd)){
logList[[i]]<- arLog[,i,]
rownames(logList[[i]]) <- rownames(x[[1]])
}
# concatenate
res <- c(charList, logList, numList)
}
# use previous indices to
origInd <- c(charInd, logInd, numInd)
resInd <- rep(NA, length(origInd))
resInd[origInd] <- 1:length(resInd)
# order the types correctly
res <- res[resInd]
# use the names of the first names
names(res) <- origColNames
}
}else{
# error:dimensions match but types do not -use names!!!
}
}
}
# 2.nd directive: use the names (rownames) to match
if("name"%in%direct & !match){
# get the dimensions
allDim <- t(sapply(x, dim)) # they can be different
# if there is a prototype
if(!is.null(proto)){
# check whether prototype has names
if(is.null(colnames(proto)) | is.null(rownames(proto))) stop("Prototype has no names, cannot be processed with names directive.")
}
# check whether everyhing has names
repNames <- lapply(x, function(i){
is.null(colnames(i)) | is.null(rownames(i))
})
# only if every replicate has both colnames and rownames
if(sum(unlist(repNames))==0){
# check the vector types in each column of every replicate
types<- lapply(x, function(i){
sapply(i,function(j){
if(is.numeric(j)) ret <- "num"
if(is.character(j)) ret <- "char"
if(is.logical(j)) ret <- "log"
if(is.factor(j)) ret <- "fac"
return(ret)
})
})
# unfold the types, just a vector of tpyes
names(types) <- NULL
messType <- unlist(types)
# check whether the same variable names have just one type!
typeMatch <- tapply(INDEX=names(messType), X=messType, FUN=function(i){
length(unique(i))==1
})
# all types match
if(!any(!typeMatch)){
# unfold the data
mess <- unlist(x)
# rownames of every data frame
na<-lapply(x, function(d){
rownames(d)
})
# create a unique ID for every entry entry
# if there is a function
if(!is.null(FUN)){
idList <- mapply(FUN=function(i,j){
# i<-na[[1]]
# j<-types[[1]]
rowID <-rep(i, length(j))
bothID<- paste(rowID, rep(names(j), each=length(i)), sep="_")
}, na, types)
# if there is NULL
}else{
idList <- mapply(FUN=function(i,j,k){
# i<-na[[1]]
# j<-types[[1]]
rowID <-rep(i, length(j))
planeID <- rep(k, length(rowID))
bothID<- paste(rowID, rep(names(j), each=length(i)),planeID, sep="_")
}, na, types, 1:length(x))
}
# the unique name of every entry
names(mess) <- unlist(idList)
# distribute data to numeric, logical and
numInd <- which(messType=="num")
charInd <- which(messType=="char")
logInd <- which(messType=="log")
# factor and others?
#how many entries are there in column
colGuide <- apply(allDim, 1, function(d){
rep(d[1], d[2])
})
if(is.list(colGuide)) colGuide <- unlist(colGuide)
if(is.matrix(colGuide)) dim(colGuide)<-NULL
bLog<-selcolDiffdat(colGuide, logInd)
bNum<-selcolDiffdat(colGuide, numInd)
bChar<-selcolDiffdat(colGuide, charInd)
# get the value specific parts and cast
messLog <-as.logical(mess[bLog])
messNum <- as.numeric(mess[bNum])
messChar <- as.character(mess[bChar])
# the averaging can be done with tapply so we need the names
nameLog <- names(mess)[bLog]
nameNum <- names(mess)[bNum]
nameChar <- names(mess)[bChar]
# there is a function to process the data
if(!is.null(FUN)){
# and apply if asked for - default is not for characters!!!
if("num"%in%to){
resNum <- tapply(INDEX=nameNum, X=messNum, FUN=FUN,...)
# omit stupid NaN
resNum[is.nan(resNum)] <- NA
}else{
uNumName <- sort(unique(nameNum))
resNum<- rep(as.numeric(NA), length(uNumName))
names(resNum) <- uNumName
}
if("char"%in%to){
resChar <- tapply(INDEX=nameChar, X=messChar, FUN=FUN,...)
}else{
uCharName <- sort(unique(nameChar))
resChar<- rep(as.character(NA), length(uCharName))
names(resChar) <- uCharName
}
if("log"%in%to){
resLog <- tapply(INDEX=nameLog, X=messLog, FUN=FUN,...)
resLog[is.nan(resLog)] <- NA
}else{
uLogName <- sort(unique(nameLog))
resLog<- rep(as.logical(NA), length(uLogName))
names(resLog) <- uLogName
}
# distribution output
}else{
names(messNum) <- nameNum
names(messLog) <- nameLog
names(messChar) <- nameChar
}
# final object structure
if(is.null(proto)){
# the final potential rownames
totRows <- sort(unique(unlist(na)))
# final potential variables
totNumCols <- unique(names(messType)[numInd])
totCharCols <- unique(names(messType)[charInd])
totLogCols <- unique(names(messType)[logInd])
}else{
# column and rownames of the prototype
totRows<- rownames(proto)
# types of the prototype
typeProto <- sapply(proto,function(j){
if(is.numeric(j)) ret <- "num"
if(is.character(j)) ret <- "char"
if(is.logical(j)) ret <- "log"
if(is.factor(j)) ret <- "fac"
return(ret)
})
totNumCols <- names(typeProto)[typeProto=="num"]
totCharCols <- names(typeProto)[typeProto=="char"]
totLogCols <- names(typeProto)[typeProto=="log"]
}
# for function output
if(!is.null(FUN)){
# potential identifiers
potNumNames <- paste(rep(totRows, length(totNumCols)), rep(totNumCols, each=length(totRows)),sep="_")
potCharNames <- paste(rep(totRows, length(totCharCols)), rep(totCharCols, each=length(totRows)),sep="_")
potLogNames <- paste(rep(totRows, length(totLogCols)), rep(totLogCols, each=length(totRows)),sep="_")
# reorder the result output for folding
resNumFold <- resNum[potNumNames]
resCharFold <- resChar[potCharNames]
resLogFold <- resLog[potLogNames]
# fold and make a data.frame
numMat <- as.data.frame(matrix(resNumFold, nrow=length(totRows), byrow=FALSE))
charMat <- as.data.frame(matrix(resCharFold, nrow=length(totRows), byrow=FALSE), stringsAsFactors=FALSE)
logMat <- as.data.frame(matrix(resLogFold, nrow=length(totRows), byrow=FALSE))
# assign the columns
colnames(numMat) <- totNumCols
colnames(charMat) <- totCharCols
colnames(logMat) <- totLogCols
# output and rownames
res <- cbind(numMat, charMat, logMat)
rownames(res) <- totRows
# dist output
}else{
# potential identifiers
potNumNamesPlane <- paste(rep(totRows, length(totNumCols)), rep(totNumCols, each=length(totRows)),sep="_")
potCharNamesPlane <- paste(rep(totRows, length(totCharCols)), rep(totCharCols, each=length(totRows)),sep="_")
potLogNamesPlane <- paste(rep(totRows, length(totLogCols)), rep(totLogCols, each=length(totRows)),sep="_")
# with the plane identifiers
potNumNames <- paste(rep(potNumNamesPlane, length(x)), rep(1:length(x), each=length(potNumNamesPlane)), sep="_")
potCharNames <- paste(rep(potCharNamesPlane, length(x)), rep(1:length(x), each=length(potCharNamesPlane)), sep="_")
potLogNames <- paste(rep(potLogNamesPlane, length(x)), rep(1:length(x), each=length(potLogNamesPlane)), sep="_")
# reorder input
resNumFold <- messNum[potNumNames]
resCharFold <- messChar[potCharNames]
resLogFold <- messLog[potLogNames]
# array representation
numArr<- array(resNumFold, dim=c(length(totRows), length(totNumCols), length(x)))
logArr<- array(resLogFold, dim=c(length(totRows), length(totLogCols), length(x)))
charArr<- array(resCharFold, dim=c(length(totRows), length(totCharCols), length(x)))
# make the variable specific data in a list
# slowest solution ever...
numList<-list()
if(length(totNumCols)>0){
for(i in 1:length(totNumCols)){
temp <- numArr[,i,]
rownames(temp) <- totRows
numList[[i]] <- temp
}
}
logList<-list()
if(length(totLogCols)>0){
for(i in 1:length(totLogCols)){
temp <- logArr[,i,]
rownames(temp) <- totRows
logList[[i]] <- temp
}
}
charList<-list()
if(length(totCharCols)>0){
for(i in 1:length(totCharCols)){
temp <- charArr[,i,]
rownames(temp) <- totRows
charList[[i]] <- temp
}
}
res<-c(numList,logList,charList)
names(res) <- c(totNumCols,totLogCols,totCharCols)
# if there is a prototype
if(!is.null(proto)){
res <- res[names(typeProto)]
names(res) <- names(typeProto)
}
}
} # else fail!
}else{
stop("matching failed.")
}
}
return(res)
}
###### utility functions
# select columns from an unrolled 3d array
selcolUnrolled <- function(colInd,nRow, nCol, nPlane){
#colInd <- numInd
#nRow <- dimGuide[1]
#nCol<- dimGuide[2]
#nPlane<- length(x)
# start with the numeric indices
totNum <- rep(FALSE, nRow*nCol*nPlane)
if(length(colInd)>0){
# for all iterations
for(i in 1:nPlane){
# for of the indices
for(j in 1:length(colInd)){
# all entries from the column
entries<- 1:nRow
# offset the columns
colOffset <- nRow*(colInd[j]-1)
# offset the tables: shift columns by this amount time the number entries in a column
iterOffset <- (i-1)*nCol*nRow
totNum[entries+colOffset+iterOffset] <- TRUE
}
}
}
return(totNum)
}
# select column from unrolled data.frames with
selcolDiffdat <- function(colGuide, colInd){
# logical vector for subsetting
bSubset <- rep(FALSE, sum(colGuide))
if(length(colInd)>0){
# for every relevant column
for(i in 1:length(colInd)){
if(colInd[i]==1){
offset<- 0
}else{
offset<- sum(colGuide[1:(colInd[i]-1)])
}
bSubset[(1:colGuide[colInd[i]])+offset] <- TRUE
}
}
return(bSubset)
}
is.vector.like <- function(x){
cl <- class(x)
if(
"numeric"%in%cl |
"integer"%in%cl |
"double"%in%cl |
"character"%in%cl |
"logical"%in%cl |
("table"%in%cl & length(dim(x))==1) |
("array"%in%cl & length(dim(x))==1)
) state <- TRUE else state <- FALSE
return(state)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.