.validatePipelineDef <- function(object){
e <- c()
if( !is.list(object@functions) ||
!all(vapply(object@functions, is.function, logical(1))) )
e <- c("`functions` should be a (named) list of functions!")
if(!all(vapply( object@functions, FUN.VALUE=logical(1),
FUN=function(x) "x" %in% names(formals(x)))))
e <- c(e, "Each function should at least take the argument `x`.")
isf <- function(x) is.null(x) || is.function(x)
if( !is.list(object@aggregation) ||
!all(vapply(object@aggregation, isf, logical(1))) )
stop("`aggregation` should be a list of functions and/or NULL slots!")
if( !is.list(object@evaluation) ||
!all(vapply(object@evaluation, isf, logical(1))) )
stop("`evaluation` should be a list of functions and/or NULL slots!")
if(!all(names(object@descriptions)==names(object@functions)))
e <- c(e, "descriptions do not match functions.")
if(!all(names(object@evaluation)==names(object@functions)))
e <- c(e, "evaluation do not match functions.")
if(!all(names(object@aggregation)==names(object@functions)))
e <- c(e, "aggregation do not match functions.")
args <- unlist( lapply( object@functions,
FUN=function(x){ setdiff(names(formals(x)), "x") }) )
if(any(duplicated(args))) e <- c(e, paste("Some arguments (beside `x`) is",
"used in more than one step, which is not currently supported."))
if(length( wa <- setdiff(names(object@defaultArguments),args) )>0)
e <- c(e, paste("The following default arguments are not in the pipeline's
functions:", paste(wa, collapse=", ")))
if(length(e) == 0) TRUE else e
}
#' @import methods
#' @exportClass PipelineDefinition
setClass( "PipelineDefinition",
slots=representation( functions="list", descriptions="list",
evaluation="list", aggregation="list",
initiation="function",
defaultArguments="list", misc="list" ),
prototype=prototype( functions=list(), descriptions=list(),
evaluation=list(), aggregation=list(),
initiation=identity,
defaultArguments=list(), misc=list() ),
validity=.validatePipelineDef )
#' PipelineDefinition
#'
#' Creates on object of class `PipelineDefinition` containing step functions,
#' as well as optionally step evaluation and aggregation functions.
#'
#' @param functions A list of functions for each step
#' @param descriptions A list of descriptions for each step
#' @param evaluation A list of optional evaluation functions for each step
#' @param aggregation A list of optional aggregation functions for each step
#' @param initiation A function ran when initiating a dataset
#' @param defaultArguments A lsit of optional default arguments
#' @param misc A list of whatever.
#' @param verbose Whether to output additional warnings (default TRUE).
#'
#' @return An object of class `PipelineDefinition`, with the slots functions,
#' descriptions, evaluation, aggregation, defaultArguments, and misc.
#'
#' @aliases PipelineDefinition-class
#' @seealso \code{\link{PipelineDefinition-methods}},
#' \code{\link{addPipelineStep}}. For an example pipeline, see
#' \code{\link{scrna_pipeline}}.
#' @export
#' @examples
#' PipelineDefinition(
#' list( step1=function(x, meth1){ get(meth1)(x) },
#' step2=function(x, meth2){ get(meth2)(x) } )
#' )
PipelineDefinition <- function( functions, descriptions=NULL, evaluation=NULL,
aggregation=NULL, initiation=identity,
defaultArguments=list(),
misc=list(), verbose=TRUE ){
if(!is.list(functions) || !all(vapply(functions, is.function, logical(1))))
stop("`functions` should be a (named) list of functions!")
n <- names(functions)
if(is.null(n))
n <- names(functions) <- paste0("step",seq_len(length(functions)))
descriptions <- .checkInputList(descriptions, functions, FALSE)
evaluation <- .checkInputList(evaluation, functions)
aggregation2 <- .checkInputList(aggregation, functions)
names(aggregation2)<-names(evaluation)<-names(descriptions)<-names(functions)
for(f in names(aggregation2)){
if(is.null(aggregation2[[f]]) && !is.null(evaluation[[f]]) &&
!(f %in% names(aggregation)))
aggregation2[[f]] <- defaultStepAggregation
}
if(is.null(misc)) misc <- list()
x <- new("PipelineDefinition", functions=functions,descriptions=descriptions,
evaluation=evaluation, aggregation=aggregation2,
initiation=initiation, defaultArguments=defaultArguments, misc=misc)
w <- which( !vapply(x@aggregation, is.null, logical(1)) &
vapply(x@evaluation, is.null, logical(1)) )
if(verbose && length(w)>0){
warning(paste("An aggregation is defined for some steps that do not have",
"a defined evaluation function: ",
paste(names(x@functions)[w], collapse=", "),
"It is possible that evaluation is performed by the step's",
"function itself.") )
}
x
}
.checkInputList <- function( x, fns, containsFns=TRUE,
name=deparse(substitute(x)) ){
name <- paste0("`",name,"`")
if(!is.null(x)){
if(length(x)!=length(fns)){
if(is.null(names(x)))
stop("If ", name, " does not have the same length as the number of ",
"steps, its slots should be named.")
if(length(unknown <- setdiff(names(x),names(fns)))>0)
stop("Some elements of ",name," (",paste(unknown,collapse=", "),")",
"are unknown.")
x <- lapply(names(fns), FUN=function(f){
if(is.null(x[[f]])) return(NULL)
x[[f]]
})
names(x) <- names(fns)
}
if( !is.null(names(x)) ){
if(!all(names(x)==names(fns)) )
stop("The names of ",name," should match those of `functions`")
}
}else{
x <- lapply(fns,FUN=function(x) NULL)
}
if(containsFns &&
!all(vapply(x, FUN=function(x) is.null(x) || is.function(x), logical(1))))
stop(name," should be a list of functions")
x
}
#' Methods for \code{\link{PipelineDefinition}} class
#' @name PipelineDefinition-methods
#' @rdname PipelineDefinition-methods
#' @aliases PipelineDefinition-method
#' @seealso \code{\link{PipelineDefinition}}, \code{\link{addPipelineStep}}
#' @param object An object of class \code{\link{PipelineDefinition}}
#' @return Depends on the method.
#' @examples
#' pd <- mockPipeline()
#' length(pd)
#' names(pd)
#' pd$step1
#' pd[2:1]
NULL
#' @rdname PipelineDefinition-methods
#' @importMethodsFrom methods show
#' @importFrom knitr opts_current
setMethod("show", signature("PipelineDefinition"), function(object){
# colors and bold are going to trigger errors when rendered in a knit, so
# we disable them when rendering
isKnit <- tryCatch( isTRUE(getOption('knitr.in.progress')) ||
length(knitr::opts_current$get())>0,
error=function(e) FALSE)
fns <- unlist(lapply(names(object@functions), FUN=function(x){
x2 <- x
if(!isKnit) x2 <- paste0("\033[1m",x,"\033[22m")
y <- lapply( names(formals(object@functions[[x]])), FUN=function(n){
if(!is.null(def <- object@defaultArguments[[n]]))
n <- paste0(n,"=",deparse(def,100,FALSE))
n
})
y <- paste0(" - ", x2, "(", paste(unlist(y), collapse=", "), ")")
if(!is.null(object@evaluation[[x]]) || !is.null(object@aggregation[[x]]))
y <- paste0(y, ifelse(isKnit, " * ", " \033[34m*\033[39m "))
if(!is.null(object@descriptions[[x]])){
x2 <- object@descriptions[[x]]
if(!isKnit) x2 <- paste0("\033[3m",x2,"\033[23m")
y <- paste(y, x2, sep="\n")
}
y
}))
cat("A PipelineDefinition object with the following steps:\n")
cat(paste(fns,collapse="\n"))
cat("\n")
})
#' get names of PipelineDefinition steps
#' @rdname PipelineDefinition-methods
#' @param x An object of class \code{\link{PipelineDefinition}}
setMethod("names", signature("PipelineDefinition"), function(x){
names(x@functions)
})
#' set names of PipelineDefinition steps
#' @rdname PipelineDefinition-methods
#' @param value Replacement values
setMethod("names<-", signature("PipelineDefinition"), function(x, value){
if(any(duplicated(value))) stop("Some step names are duplicated!")
names(x@functions) <- value
names(x@evaluation) <- value
names(x@aggregation) <- value
names(x@descriptions) <- value
validObject(x)
x
})
#' @rdname PipelineDefinition-methods
#' @param name The step name
setMethod("$", signature("PipelineDefinition"), function(x, name){
x@functions[[name]]
})
#' @rdname PipelineDefinition-methods
setMethod("length", signature("PipelineDefinition"), function(x){
length(x@functions)
})
#' @rdname PipelineDefinition-methods
#' @param i The index(es) of the steps
setMethod("[",signature("PipelineDefinition"), function(x, i){
new("PipelineDefinition", functions=x@functions[i],
descriptions=x@descriptions[i], evaluation=x@evaluation[i],
aggregation=x@aggregation[i], misc=x@misc)
})
#' @rdname PipelineDefinition-methods
setMethod("as.list",signature("PipelineDefinition"), function(x){
x@functions
})
#' @exportMethod arguments
#' @rdname PipelineDefinition-methods
setGeneric("arguments", function(object) args(object))
#' @rdname PipelineDefinition-methods
setMethod("arguments",signature("PipelineDefinition"), function(object){
lapply(object@functions, FUN=function(x){ setdiff(names(formals(x)), "x") })
})
#' @rdname PipelineDefinition-methods
#' @exportMethod defaultArguments
setGeneric("defaultArguments", function(object) NULL)
#' @exportMethod defaultArguments<-
#' @rdname PipelineDefinition-methods
setGeneric("defaultArguments<-", function(object, value) NULL)
#' @rdname PipelineDefinition-methods
setMethod("defaultArguments",signature("PipelineDefinition"), function(object){
object@defaultArguments
})
#' @rdname PipelineDefinition-methods
setMethod( "defaultArguments<-",signature("PipelineDefinition"),
function(object, value){
object@defaultArguments <- value
validObject(object)
object
})
#' @exportMethod stepFn
#' @rdname PipelineDefinition-methods
setGeneric("stepFn", function(object, step=NULL, type) standardGeneric("stepFn"))
#' @param step The name of the step for which to set or get the function
#' @param type The type of function to set/get, either `functions`,
#' `evaluation`, `aggregation`, `descriptions`, or `initiation` (will parse
#' partial matches)
#' @rdname PipelineDefinition-methods
setMethod("stepFn", signature("PipelineDefinition"),
function(object, step=NULL, type){
ft <- c("functions","evaluation","aggregation","descriptions","initiation")
type <- match.arg( type, ft )
if(is.null(step)) return(slot(object, type))
step <- match.arg(step, names(object))
slot(object, type)[[step]]
})
#' @exportMethod stepFn<-
#' @rdname PipelineDefinition-methods
setGeneric( "stepFn<-",
function(object, step, type, value) standardGeneric("stepFn<-") )
#' @rdname PipelineDefinition-methods
setMethod( "stepFn<-", signature("PipelineDefinition"),
function(object, step, type, value){
ft <- c("functions","evaluation","aggregation","descriptions","initiation")
type <- match.arg(type, ft)
if(type!="descriptions" && !is.null(value) && !is.function(value))
stop("Replacement value should be a function.")
if(type=="initiation"){
slot(object, type) <- value
}else{
step <- match.arg(step, names(object))
slot(object, type)[[step]] <- value
}
if(type=="evaluation" && !is.null(value)){
# also add the default aggregation:
if(is.null(slot(object, "aggregation")[[step]]))
slot(object, "aggregation")[[step]] <- defaultStepAggregation
}
object
})
#' addPipelineStep
#'
#' Add a step to an existing \code{\link{PipelineDefinition}}
#'
#' @param object A \code{\link{PipelineDefinition}}
#' @param name The name of the step to add
#' @param after The name of the step after which to add the new step. If NULL,
#' will add the step at the beginning of the pipeline.
#' @param slots A optional named list with slots to fill for that step (i.e.
#' `functions`, `evaluation`, `aggregation`, `descriptions` - will be parsed)
#'
#' @return A \code{\link{PipelineDefinition}}
#' @seealso \code{\link{PipelineDefinition}},
#' \code{\link{PipelineDefinition-methods}}
#' @importFrom methods is slot
#' @export
#'
#' @examples
#' pd <- mockPipeline()
#' pd
#' pd <- addPipelineStep(pd, name="newstep", after="step1",
#' slots=list(description="Step that does nothing..."))
#' pd
addPipelineStep <- function(object, name, after=NULL, slots=list()){
if(!is(object, "PipelineDefinition"))
stop("object should be a PipelineDefinition")
if(name %in% names(object)) stop("There is already a step with that name!")
if(!is.null(after) && !(after %in% names(object)))
stop("`after` should either be null or the name of a step.")
n <- c("functions","evaluation","aggregation","descriptions")
if(length(slots)>0)
names(slots) <- vapply( names(slots), choices=n, FUN=match.arg,
FUN.VALUE=character(1) )
if(!all(names(slots) %in% n))
stop(paste("fns should be a function or a list",
"with one or more of the following names:\n", paste(n,collapse=", ")))
if(is.null(after)){
i1 <- vector("integer")
i2 <- seq_along(names(object))
}else{
w <- which(names(object)==after)
i1 <- seq_len(w)
i2 <- seq.int(from=w+1, to=length(object))
if(w==length(object)) i2 <- vector("integer")
}
ll <- list(NULL)
names(ll) <- name
for(f in n) slot(object,f) <- c(slot(object,f)[i1], ll, slot(object,f)[i2])
for(f in names(slots)) stepFn(object, name, f) <- slots[[f]]
if(is.null(stepFn(object, name, "functions")))
stepFn(object, name, "functions") <- identity
validObject(object)
object
}
#' mockPipeline
#'
#' A mock `PipelineDefinition` for use in examples.
#'
#' @return a `PipelineDefinition`
#' @export
#'
#' @examples
#' mockPipeline()
mockPipeline <- function(){
PipelineDefinition(
list( step1=function(x, meth1){ get(meth1)(x) },
step2=function(x, meth2){ get(meth2)(x) } ),
evaluation=list( step2=function(x) c(mean=mean(x), max=max(x)) ),
descriptions=list( step1="This steps applies meth1 to x.",
step2="This steps applies meth2 to x."),
defaultArguments=list(meth1=c("log","sqrt"), meth2="cumsum")
)
}
