ltla / bluster Goto Github PK

#' A two-step approach of clustering a sample subset of observations
#' followed by classification of remaining observations (e.g. using knn1).
#'
#' For large datasets, we can cluster on a subset using an initial
#' technique (e.g., using HclustParam) and then classify the remaining
#' observations based on this clustering using a classifier (e.g., and
#' by default, knn1).
#'
#' @param initialTechnique A \linkS4class{BlusterParam} object specifying an initial clustering.
#' @param initialSample A integer vector specifying the sample on which to conduct initial clustering. A single value is taken as size of random sample.  0L, the default, takes the root of n.
#' @param classifier A classifier function such as the default, knn1 (required to have same signature as knn1).
#' @inheritParams clusterRows
#' @param BLUSPARAM A \linkS4class{KmeansParam} object.
#' @param full Logical scalar indicating whether the initial clustering results should be returned.
#' 
#' @details
#'
#' Here, the idea is to allow using an expensive algorithm to
#' establish a training set of clusters on a subset of the data,
#' followed by a less expensive algorithm to classify the remaining
#' unclustered observations.
#' 
#' The default choice is to use default hierarchical clustering for
#' the initialTechnique, with initialSample being the root of the
#' number of observations to be used and knn1 as the classifier.
#'
#' @return 
#' The \code{postClassifyParam} constructor will return a \linkS4class{postClassifyParam} object with the specified parameters.
#'
#' The \code{clusterRows} method will return a factor of length equal to \code{nrow(x)} containing the cluster assignments.
#' If \code{full=TRUE}, a list is returned with a \code{clusters} factor and an \code{objects} list containing:
#' \itemize{
#' \item \code{initialCluster}, the result of initial clustering.
#' \item \code{initialSample}, the integer vector indexing rows of x which were initially clustered.
#' }
#'
#' @author Malcolm Cook
#' @examples
#' m <- matrix(runif(100000), ncol=10)
#' stuff <- clusterRows(m, postClassifyParam())
#' table(stuff)
#'
#' @name postClassifyParam-class
#' @aliases
#' show,postClassifyParam-method
NULL

#' @export
#' @rdname postClassifyParam-class
setClass("postClassifyParam", contains="BlusterParam", slots=c(initialTechnique="BlusterParam", initialSample="integer",classifier="function"))

#' @export
#' @rdname postClassifyParam-class
postClassifyParam <- function(initialTechnique=HclustParam(), initialSample=0L,classifier=class::knn1) {
    new("postClassifyParam", initialTechnique=initialTechnique, initialSample=initialSample,classifier=classifier)
}

#' @export
#' @importFrom utils capture.output
setMethod("show", "postClassifyParam", function(object) {
    callNextMethod()
    cat("initialTechnique:\n")
    fout <- capture.output(show(object@initialTechnique))
    cat(paste0("  ", paste(fout, collapse="\n  "), "\n"))
    cat("initialSample:\n")
    sout <- capture.output(show(object@initialSample))
    cat("classifier:\n")
    sout <- capture.output(show(object@classifier))
    cat(paste0("  ", paste(sout, collapse="\n  "), "\n"))
})

#' @export
#' @rdname postClassifyParam-
setMethod("clusterRows", c("ANY", "postClassifyParam"), function(x, BLUSPARAM, full=FALSE) {
  n<-nrow(x)
  clusters<-rep(NA,n) # allocate results vector.
  initialSample<-BLUSPARAM@initialSample
  if(identical(0L,initialSample)) initialSample<-as.integer(floor(sqrt(n)))
  stopifnot(is.integer(initialSample))
  if(1L==length(initialSample)) initialSample<-sample(n,initialSample)
  initialCluster<-clusterRows(x[initialSample,], BLUSPARAM@initialTechnique, full=TRUE)
  clusters[initialSample]<- initialCluster$clusters
  clusters[-initialSample]<- BLUSPARAM@classifier(x[initialSample,],x[-initialSample,],clusters[initialSample])
  clusters <- factor(clusters)
  if (!full) {
    clusters
  } else {
    list(clusters=clusters
         ,objects=list(initialCluster=initialCluster,initialSample=initialSample)
         )
  }
})

microbenchmark::microbenchmark(
    scran::clusterCells(
        uncorrected_sce,
        use.dimred = "PCA",
        BLUSPARAM = bluster::SNNGraphParam(
            k = 25L, type = "rank"
        )
    ),
    scran::clusterCells(
        uncorrected_sce,
        use.dimred = "PCA",
        BLUSPARAM = bluster::SNNGraphParam(
            k = 25L,
            BNPARAM = BiocNeighbors::AnnoyParam()
        )
    ),
    scran::clusterCells(
        uncorrected_sce,
        use.dimred = "PCA",
        BLUSPARAM = bluster::SNNGraphParam(
            k = 25L, type = "jaccard", cluster.fun = "louvain"
        )
    ),
    scran::clusterCells(
        uncorrected_sce,
        use.dimred = "PCA",
        BLUSPARAM = bluster::SNNGraphParam(
            k = 25L, type = "jaccard", cluster.fun = "louvain",
            BNPARAM = BiocNeighbors::AnnoyParam()
        )
    ),
    {
        seurat_nei <- FindNeighbors(
            seurat_obj,
            dims = 1:50,
            k.param = 25L
        )
        seurat_nei <- FindClusters(seurat_nei, resolution = 1)
    },
    times = 1L
)

                                                               expr
                                                                    scran::clusterCells(uncorrected_sce, use.dimred = "PCA", BLUSPARAM = bluster::SNNGraphParam(k = 25L,      type = "rank"))
                                            scran::clusterCells(uncorrected_sce, use.dimred = "PCA", BLUSPARAM = bluster::SNNGraphParam(k = 25L,      BNPARAM = BiocNeighbors::AnnoyParam()))
                                        scran::clusterCells(uncorrected_sce, use.dimred = "PCA", BLUSPARAM = bluster::SNNGraphParam(k = 25L,      type = "jaccard", cluster.fun = "louvain"))
 scran::clusterCells(uncorrected_sce, use.dimred = "PCA", BLUSPARAM = bluster::SNNGraphParam(k = 25L,      type = "jaccard", cluster.fun = "louvain", BNPARAM = BiocNeighbors::AnnoyParam()))
                                                       {     seurat_nei <- FindNeighbors(seurat_obj, dims = 1:50, k.param = 25L)     seurat_nei <- FindClusters(seurat_nei, resolution = 1) }
        min         lq       mean     median
 2519.89881 2519.89881 2519.89881 2519.89881
 2402.44808 2402.44808 2402.44808 2402.44808
   59.89610   59.89610   59.89610   59.89610
   66.01533   66.01533   66.01533   66.01533
   39.35732   39.35732   39.35732   39.35732
         uq        max neval
 2519.89881 2519.89881     1
 2402.44808 2402.44808     1
   59.89610   59.89610     1
   66.01533   66.01533     1
   39.35732   39.35732     1