R/4-conjoin.R

In exprso: Rapid Deployment of Machine Learning Algorithms

###########################################################
### Define generic functions

#' Combine \code{exprso} Objects
#'
#' \code{conjoin} combines two or more \code{exprso} objects based on their class.
#'
#' When applied to two or more \code{ExprsArray} objects, this function returns one
#'  \code{ExprsArray} object as output. This only works on \code{ExprsArray} objects
#'  that have not undergone feature selection. Any missing annotations in \code{@annot}
#'  will get replaced with \code{NA} values. Note that all combined \code{ExprsArray}
#'  objects must initially have had the same features in the same order.
#'
#' When applied to two or more \code{ExprsModel} objects, this function returns one
#'  \code{ExprsEnsemble} object as output. In this way, this function works similar to
#'  the \code{\link{buildEnsemble}} method for \code{ExprsModel} objects.
#'
#' When applied to two or more \code{ExprsPipeline} objects, this function returns one
#'  \code{ExprsPipeline} object as output. To keep track of which \code{ExprsPipeline}
#'  objects contributed initially to the resultant object, the source gets flagged in
#'  the \code{summary} slot. For each \code{ExprsPipeline} object, if the \code{summary}
#'  lacks a \code{boot} column, all \code{summary} entries will receive one unique ID.
#'  However, if the \code{summary} contains a \code{boot} column (e.g., as generated by
#'  \code{\link{plMonteCarlo}}), all models belonging to each bootstrap will receive
#'  one unique ID. Afterwards, the old \code{boot} columns will get renamed to \code{unboot}
#'  while the newly assigned unique IDs become the new \code{boot} column. This
#'  complicated indexing system treats all models derived from one unique cut to a
#'  training set as if they had belonged to the same "pseudo-bootstrap". These "pseudo-bootstraps"
#'  will get handled like true bootstraps downstream by functions built around
#'  \code{\link{pipeFilter}} and \code{\link{buildEnsemble}}.
#'
#' When applied to two or more \code{ExprsEnsemble} objects, this function returns one
#'  \code{ExprsEnsemble} object as output. The resultant object contains all models
#'  found within each of the supplied \code{ExprsEnsemble} objects.
#'
#' @param object An \code{ExprsArray}, \code{ExprsModel}, \code{ExprsPipeline}, or
#'  \code{ExprsEnsemble} object.
#' @param ... Two or more objects of the same class.
#' @return An \code{ExprsArray}, \code{ExprsModel}, \code{ExprsPipeline}, or
#'  \code{ExprsEnsemble} object.
#' @export
setGeneric("conjoin",
           function(object, ...) standardGeneric("conjoin")
)

###########################################################
### Conjoin

#' @describeIn conjoin Method to join \code{ExprsArray} objects.
#' @export
setMethod("conjoin", "ExprsArray",
          function(object, ...){

            # Prepare list of ExprsArray objects
            args <- list(...)
            index <- unlist(lapply(args, function(arg) inherits(arg, "ExprsArray")))
            args <- append(list(object), args[index])

            if(!length(args) > 1 | any(!sapply(args, function(e) identical(class(e), class(object))))){

              stop("User must provide additional ExprsArray objects of the same class!")
            }

            if(any(!sapply(args, function(e) is.null(e@preFilter) | is.null(e@reductionModel)))){

              stop("This function is not equipped to handle objects that have undergone feature selection!")
            }

            # Prepare single matrix for @exprs and @annot each
            exprs <- as.matrix(do.call(cbind, lapply(args, function(a) a@exprs)))
            annot <- do.call(plyr::rbind.fill, lapply(args, function(a) a@annot))
            rownames(annot) <- unlist(lapply(args, function(a) rownames(a@annot)))

            # Return single ExprsArray object
            new(class(object), exprs = exprs, annot = annot, preFilter = NULL, reductionModel = NULL)
          }
)

#' @describeIn conjoin Method to join \code{ExprsModel} objects.
#' @export
setMethod("conjoin", "ExprsModel",
          function(object, ...){

            # Prepare list of ExprsModel objects
            args <- list(...)
            index <- unlist(lapply(args, function(arg) inherits(arg, "ExprsModel")))
            machs <- append(object, args[index])

            # Return single ExprsEnsemble object
            new("ExprsEnsemble", machs = machs)
          }
)

#' @describeIn conjoin Method to join \code{ExprsPipeline} objects.
#' @export
setMethod("conjoin", "ExprsPipeline",
          function(object, ...){

            # Prepare list of ExprsPipeline objects
            args <- list(...)
            index <- unlist(lapply(args, function(arg) class(arg) == "ExprsPipeline"))
            args.summary <- append(list(object@summary), lapply(args[index], function(pl) pl@summary))
            args.machs <- append(list(object@machs), lapply(args[index], function(pl) pl@machs))

            # Initialize the conjoin boot counter
            b <- 1

            # Apply conjoin boot counter to each ExprsPipeline object
            pls <- lapply(args.summary,
                          function(pl){

                            # Initialize the conjoin boot container
                            pl <- cbind("join" = 0, pl)

                            if(!"boot" %in% colnames(pl)){

                              # Add conjoin boot counter
                              pl$join <- b
                              b <<- b + 1

                            }else{

                              # For each boot in $boot
                              for(i in 1:length(unique(pl$boot))){

                                # Change each unique boot to conjoin boot counter
                                pl$join[pl$boot == i] <- b
                                b <<- b + 1
                              }

                              # Rename $boot to $unboot
                              colnames(pl)[colnames(pl) == "boot"] <- "unboot"
                            }

                            # Rename $join to $boot
                            colnames(pl)[colnames(pl) == "join"] <- "boot"

                            return(pl)
                          }
            )

            # Return single ExprsPipeline object
            new("ExprsPipeline", summary = do.call(plyr::rbind.fill, pls), machs = unlist(args.machs))
          }
)

#' @describeIn conjoin Method to join \code{ExprsEnsemble} objects.
#' @export
setMethod("conjoin", "ExprsEnsemble",
          function(object, ...){

            # Prepare list of ExprsEnsemble objects
            args <- list(...)
            index <- unlist(lapply(args, function(arg) class(arg) == "ExprsEnsemble"))
            machs <- unlist(append(list(object@machs), lapply(args[index], function(pl) pl@machs)))

            # Return single ExprsEnsemble object
            new("ExprsEnsemble", machs = machs)
          }
)