cluster: fixes (microbiome#477)

Daenarys8 · Mar 5, 2024 · 6a356cd · 6a356cd
1 parent 5f18f82
commit 6a356cd
Show file tree

Hide file tree

Showing 6 changed files with 229 additions and 166 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: mia
 Type: Package
-Version: 1.11.6
+Version: 1.11.7
 Authors@R:
     c(person(given = "Felix G.M.", family = "Ernst", role = c("aut"),
              email = "[email protected]",

diff --git a/NEWS b/NEWS
@@ -101,3 +101,4 @@ Changes in version 1.11.x
 + splitOn: update rowTree fix
 + perSampleDominantFeatures: add new arguments (n, other.name, complete)
 + loadFromMetaphlan: support "taxonomy" column for specifying taxonomy
++ cluster: Overwrite old results instead of failing
diff --git a/R/cluster.R b/R/cluster.R
@@ -57,107 +57,58 @@ NULL
 #' @rdname cluster
 #' @export
 setGeneric("cluster", signature = c("x"),
-           function(x, BLUSPARAM, assay.type = assay_name, 
-                    assay_name = "counts", MARGIN = "features", full = FALSE, 
-                    name = "clusters", clust.col = "clusters", ...)
-               standardGeneric("cluster"))
+    function(
+            x, BLUSPARAM, assay.type = assay_name, 
+            assay_name = "counts", MARGIN = "features", full = FALSE, 
+            name = "clusters", clust.col = "clusters", ...)
+    standardGeneric("cluster"))
 
 #' @rdname cluster
 #' @export
 #' @importFrom bluster clusterRows
 setMethod("cluster", signature = c(x = "SummarizedExperiment"),
-          function(x, BLUSPARAM, assay.type = assay_name, 
-                   assay_name = "counts", MARGIN = "features", full = FALSE, 
-                   name = "clusters", clust.col = "clusters", ...) {
+    function(
+            x, BLUSPARAM, assay.type = assay_name, 
+            assay_name = "counts", MARGIN = "features", full = FALSE, 
+            name = "clusters", clust.col = "clusters", ...) {
+        .require_package("bluster")
         # Checking parameters
-        MARGIN <- .check_margin(MARGIN)
-        se_altexp <- .get_altExp(x, ...)
-        se <- se_altexp$se
-        # If there wasn't an altExp in the SE (or if the name was wrong), altexp 
-        # is set to NULL, if it exists altexp contains the name of the altExp
-        altexp <- se_altexp$altexp
-        .check_data_name(se, clust.col, MARGIN)
+        MARGIN <- .check_MARGIN(MARGIN)
+        se <- .check_and_get_altExp(x, ...)
         .check_assay_present(assay.type, se)
-
-        if (full) {
-            .check_name(se, name)
+        if( !.is_a_string(name) ){
+            stop("'name' must be a non-empty single character value.",
+                call. = FALSE)
+        }
+        if( !.is_a_string(clust.col) ){
+            stop("'clust.col' must be a non-empty single character value.",
+                call. = FALSE)
+        }
+        if( !.is_a_bool(full) ){
+            stop("'full' must be TRUE or FALSE.", call. = FALSE)
         }
+        #
+        # Get assay
         mat <- assay(se, assay.type)
-
         # Transpose if clustering on the columns
         if(MARGIN == 2){
             mat <- t(mat)
         }
-
+        # Get clusters
         result <- clusterRows(mat, BLUSPARAM, full)
-        # Getting the clusters and setting metadata
+        # If user has specified full=TRUE, result includes additional info
+        # that will be stored to metadata.
         if (full) {
             clusters <- result$clusters
-            metadata(se)[[name]] <- result$objects
+            x <- .add_values_to_metadata(x, name, result$objects, ...)
         } else {
             clusters <- result
         }
-
-        # Setting clusters in the object
-        if (MARGIN == 1) {
-            rowData(se)[[clust.col]] <- clusters
-        } else {
-            colData(se)[[clust.col]] <- clusters
-        }
-
-        # If there was an altexp, update it in the mainExp
-        if (!is.null(altexp)) {
-            altExp(x, altexp) <- se
-        } else {
-            x <- se
-        }
-
-        x
+        # Setting clusters in the object. The adding function requires data as
+        # list
+        clusters <- list(clusters)
+        x <- .add_values_to_colData(
+            x, clusters, clust.col, MARGIN = MARGIN, colname = "clust.col", ...)
+        return(x)
     }
 )
-
-.get_altExp <- function(x, ...) {
-    altexppos <- which(...names() == "altexp")
-    if (length(altexppos) == 0) {
-        altexp <- NULL
-    } else {
-        altexp <- ...elt(altexppos)
-    }
-    se <- .check_and_get_altExp(x, altexp)
-    list(se = se, altexp = altexp)
-}
-
-.check_margin <- function(MARGIN) {
-    if (.is_non_empty_string(MARGIN)) {
-        MARGIN <- tolower(MARGIN)
-    }
-    if (length(MARGIN) != 1L 
-        || !(MARGIN %in% c(1, 2, "features", "samples", "columns", 
-                           "col", "row", "rows", "cols"))) {
-        stop("'MARGIN' must equal to either 1, 2, 'features', 'samples', 'columns', 'col', 'row', 'rows', or 'cols'.",
-             call. = FALSE)
-    }
-    MARGIN <- ifelse(MARGIN %in% c("samples", "columns", "col", 2, "cols"), 
-                     2, 1)
-    MARGIN
-}
-
-.check_name <- function(x, name) {
-    if (name %in% names(metadata(x))) {
-        stop("The 'name' must not exist in the metadata of the object.", call. = FALSE)
-    }
-}
-
-.check_data_name <- function(x, clust.col, MARGIN) {
-    if (MARGIN == 1) {
-        if (clust.col %in% names(rowData(x))) {
-            stop("The 'clust.col' parameter must not exist in the names of the rowData of the object.", 
-                 call. = FALSE)
-        }
-    } else {
-        if (clust.col %in% names(colData(x))) {
-            stop("The 'clust.col' parameter must not exist in the names of the colData of the object.", 
-                 call. = FALSE)
-        }
-    }
-}
diff --git a/R/getExperimentCrossAssociation.R b/R/getExperimentCrossAssociation.R
@@ -638,27 +638,6 @@ setMethod("getExperimentCrossCorrelation", signature = c(x = "ANY"),
              call. = FALSE)
     }
 }
-############################# .check_and_get_altExp ############################
-# This function checks if altexp is specified. If so, then it returns alternative
-# experiment from altExp.
-
-# Input: (Tree)SE
-# Output: (Tree)SE
-.check_and_get_altExp <- function(tse, altexp){
-    # Get the variable names
-    altExp_name <- deparse(substitute(altexp))
-    exp_num <- substr(altExp_name, nchar(altExp_name), nchar(altExp_name))
-    tse_name <- paste0("experiment ", exp_num)
-
-    # If altexp is specified, check and get it. Otherwise return the original object
-    if( !is.null(altexp) ){
-        # Check altexp
-        .check_altExp_present(altexp, tse, altExp_name, tse_name)
-        # Get altExp and return it
-        tse <- altExp(tse, altexp)
-    }
-    return(tse)
-}
 ###################### .check_and_subset_colData_variables #####################
 # This function checks if columns can be found from colData. Additionally, 
 # integers are converted into numeric and factors to character.