R/components-clust.R

In rickhelmus/patRoon: Workflows for Mass-Spectrometry Based Non-Target Analysis

#' @include main.R
#' @include components.R
NULL

genClustComponents <- function(cutClusters, gInfo)
{
    clinds <- seq_along(unique(cutClusters))
    comps <- lapply(clinds, function(ci)
    {
        gNames <- rownames(gInfo)[cutClusters == ci]
        return(data.table(group = gNames, ret = gInfo[gNames, "rts"], mz = gInfo[gNames, "mzs"],
                          intensity = 1))
    })
    names(comps) <- paste0("CMP", seq_along(clinds))
    return(comps)
}

genClustComponentInfo <- function(cutClusters)
{
    clinds <- seq_along(unique(cutClusters))
    return(data.table(name = paste0("CMP", seq_along(clinds)),
                      size = sapply(clinds, function(ci) sum(cutClusters == ci))))
}

verifyCompNotAltered <- function(obj)
{
    if (obj@altered)
        stop("Cannot perform this operation as this components object was altered after its creation", call. = FALSE)
}

#' Base class for components that are based on hierarchical clustered data.
#'
#' This base class is derived from \code{\link{components}} and is used to store components resulting from hierarchical
#' clustering information, for instance, generated by \code{\link{generateComponentsIntClust}} and
#' \code{\link{generateComponentsSpecClust}}.
#'
#' @slot distm Distance matrix that was used for clustering (obtained with \code{\link{daisy}}).
#' @slot clust Object returned by \code{\link{hclust}}.
#' @slot cutClusters A \code{list} with assigned clusters (same format as what \code{\link{cutree}} returns).
#' @slot gInfo The \code{\link{groupInfo}} of the feature groups object that was used.
#' @slot properties A list containing general properties and parameters used for clustering.
#' @slot altered Set to \code{TRUE} if the object was altered (\emph{e.g.} filtered) after its creation.
#'
#' @param x,obj A \code{componentsClust} (derived) object.
#' @param \dots Further options passed to \code{\link{plot.dendrogram}} (\code{plot}) or \code{\link[graphics]{plot}}
#'   (\code{plotSilhouettes}).
#'
#' @references \insertRef{Scholle2018}{patRoon}
#'
#' @seealso \code{\link{components}} and \code{\link{generateComponents}}
#'
#' @template components_noint
#' @template components-altered-note
#' 
#' @templateVar class componentsClust
#' @template class-hierarchy
#' 
#' @export
componentsClust <- setClass("componentsClust",
                            slots = c(distm = "dist", clust = "hclust",
                                      cutClusters = "numeric", gInfo = "data.frame", properties = "list",
                                      altered = "logical"),
                            contains = c("components", "VIRTUAL"))

setMethod("initialize", "componentsClust", function(.Object, distm, method, gInfo, properties,
                                                    maxTreeHeight, deepSplit, minModuleSize, ...)
{
    properties <- c(properties, list(method = method))

    if (is.null(distm))
    {
        # empty object
        return(callNextMethod(.Object, components = list(), componentInfo = data.table(),
                              clust = structure(list(), class = "hclust"), cutClusters = numeric(),
                              distm = structure(list(), class = "dist"), gInfo = gInfo,
                              properties = c(properties, list(method = method)), ...))
    }

    cat("Hierarchical clustering... ")
    clust <- fastcluster::hclust(distm, method)
    cat("Done!\n")
    
    cutClusters <- doDynamicTreeCut(clust, maxTreeHeight, deepSplit, minModuleSize)
    
    comps <- genClustComponents(cutClusters, gInfo)
    cInfo <- genClustComponentInfo(cutClusters)
    
    return(callNextMethod(.Object, components = comps, componentInfo = cInfo,
                          clust = clust, cutClusters = cutClusters, distm = distm, gInfo = gInfo,
                          properties = properties, altered = FALSE, ...))
})

#' @rdname componentsClust-class
#' @export
setMethod("delete", "componentsClust", function(obj, ...)
{
    old <- obj
    obj <- callNextMethod()
    
    if (length(old) > length(obj))
        altered <- TRUE
    
    return(obj)
})

#' @describeIn componentsClust Accessor method to the \code{clust} slot, which was generated by \code{\link{hclust}}.
#' @export
setMethod("clusters", "componentsClust", function(obj) obj@clust)

#' @describeIn componentsClust Accessor method to the \code{cutClusters} slot. Returns a vector with cluster membership
#'   for each candidate (format as \code{\link{cutree}}).
#' @export
setMethod("cutClusters", "componentsClust", function(obj) obj@cutClusters)

#' @describeIn componentsClust Returns a list with properties on how the
#'   clustering was performed.
#' @export
setMethod("clusterProperties", "componentsClust", function(obj) obj@properties)

#' @describeIn componentsClust Manually (re-)cut the dendrogram.
#' @param k,h Desired number of clusters or tree height to be used for cutting the dendrogram, respectively. One or the
#'   other must be specified. Analogous to \code{\link{cutree}}.
#' @export
setMethod("treeCut", "componentsClust", function(obj, k = NULL, h = NULL)
{
    verifyCompNotAltered(obj)
    
    if (is.null(k) && is.null(h))
        stop("Either k or h should be specified")
    
    ac <- checkmate::makeAssertCollection()
    checkmate::assertCount(k, positive = TRUE, null.ok = TRUE, add = ac)
    checkmate::assertNumber(h, lower = 0, finite = TRUE, null.ok = TRUE, add = ac)
    checkmate::reportAssertions(ac)
    
    obj@cutClusters <- cutree(obj@clust, k, h)
    
    obj@components <- genClustComponents(obj@cutClusters, obj@gInfo)
    obj@componentInfo <- genClustComponentInfo(obj@cutClusters)
    
    return(obj)
})

#' @describeIn componentsClust Automatically (re-)cut the dendrogram using the \code{\link{cutreeDynamicTree}} function
#'   from \pkg{\link{dynamicTreeCut}}.
#'
#' @template dynamictreecut
#'
#' @export
setMethod("treeCutDynamic", "componentsClust", function(obj, maxTreeHeight, deepSplit,
                                                        minModuleSize)
{
    verifyCompNotAltered(obj)
    
    ac <- checkmate::makeAssertCollection()
    assertDynamicTreeCutArgs(maxTreeHeight, deepSplit, minModuleSize, ac)
    checkmate::reportAssertions(ac)
    
    obj@cutClusters <- doDynamicTreeCut(obj@clust, maxTreeHeight,
                                        deepSplit, minModuleSize)
    
    obj@components <- genClustComponents(obj@cutClusters, obj@gInfo)
    obj@componentInfo <- genClustComponentInfo(obj@cutClusters)
    
    return(obj)
})

#' @describeIn componentsClust generates a dendrogram from a given cluster object and optionally highlights resulting
#'   branches when the cluster is cut.
#' @param numericLabels Set to \code{TRUE} to label with numeric indices instead of (long) feature group names.
#' @templateVar withoutDots TRUE
#' @template plot_clust
#' @export
setMethod("plot", c(x = "componentsClust", y = "missing"), function(x, pal = "Paired", numericLabels = TRUE,
                                                                    colourBranches = length(x) < 50,
                                                                    showLegend = length(x) < 20, ...)
{
    verifyCompNotAltered(x)
    
    checkmate::assertString(pal, min.chars = 1)
    dendro <- as.dendrogram(x@clust)
    if (numericLabels)
        dendextend::labels(dendro) <- as.character(seq_along(x@cutClusters))
    plotDendroWithClusters(dendro, x@cutClusters, pal, colourBranches, showLegend, ...)
    invisible(NULL)
})

setMethod("plotHash", "componentsClust", function(x, ...)
{
    makeHash(x@clust, x@cutClusters, ...)
})

#' @templateVar class componentsClust
#' @template plotsil
#' @export
setMethod("plotSilhouettes", "componentsClust", function(obj, kSeq, pch = 16, type = "b", ...)
{
    verifyCompNotAltered(obj)
    
    checkmate::assertIntegerish(kSeq, lower = 2, any.missing = FALSE)
    doPlotSilhouettes(obj@clust, obj@distm, kSeq, pch, type, ...)
    invisible(NULL)
})