Merge pull request #7 from cantinilab/dev_SeuratV5

Dev seurat v5

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: HuMMuS
 Title: Heterogeneous Multilayer Network for Multi-Omics Single-Cell Data
-Version: 0.0.1
+Version: 0.0.2
 Authors@R: person(given = "Rémi",
     family = "Trimbour",
     email = "[email protected]",

NAMESPACE

@@ -1,5 +1,14 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("[[",Hummus_Object)
+S3method(DefaultAssay,Hummus_Object)
+S3method(VariableFeatures,Hummus_Object)
+export("DefaultAssay<-")
+export("VariableFeatures<-")
+export(DefaultAssay)
+export(Hummus_Object)
+export(Initiate_Hummus_Object)
+export(VariableFeatures)
 export(add_network)
 export(aggregate_matrix)
 export(bipartite_peaks2genes)
@@ -19,13 +28,12 @@ export(format_multiplex_names)
 export(get_genome_annotations)
 export(get_tf2motifs)
 export(get_tfs)
-export(hummus_object)
 export(peaks_in_regulatory_elements)
 export(run_cicero_wrapper)
 export(save_multilayer)
 export(store_network)
+exportClasses(Hummus_Object)
 exportClasses(bipartite)
-exportClasses(hummus_object)
 exportClasses(motifs_db)
 exportClasses(multilayer)
 exportClasses(multiplex)

R/explore_network.R

@@ -1,6 +1,6 @@
 #' Format multiplex names for python hummuspy package config functions
 #'
-#' @param hummus_object A hummus object
+#' @param hummus_object A HuMMuS_Object
 #' @param multiplex_names A vector of multiplex names considered. It must be
 #' a subset of the names of the multiplexes in the hummus object.
 #'
@@ -25,7 +25,7 @@ format_multiplex_names <- function(
   # bipartites_list <- hummus_object@bipartites
 
   #} else
-  if (inherits(hummus_object, "hummus_object")) {
+  if (inherits(hummus_object, "Hummus_Object")) {
     multiplex_list <- hummus_object@multilayer@multiplex
   } else {
     stop("Object is not a multilayer nor an hummus object.")
@@ -93,7 +93,7 @@ format_bipartites_names <- function(
     #bipartites_list <- hummus_object@bipartites
 
   #} else
-  if (inherits(hummus_object, "hummus_object")) {
+  if (inherits(hummus_object, "Hummus_Object")) {
     bipartites_list <- hummus_object@multilayer@bipartites
   } else {
     stop("Object is not a multilayer nor an hummus object.")

R/hummus_objet.R

@@ -144,32 +144,276 @@ setMethod("show", "multilayer",
   })
 
 
-#' The hummus_object class
+#' The Hummus_Object class
 #'
-#' The hummus_object object is an extended \code{Seurat} object
+#' The Hummus_Object object is an extended \code{Seurat} object
 #' for the storage and analysis of a heterogeneous multilayer network
 #'
 #' @slot multilayer (multilayer) - Multilayer object
 #' @slot motifs_db (motifs_db) - Motifs database
 #' @slot assay (list) - List of assays
 #'
-#' @name hummus_object-class
-#' @rdname hummus_object-class
-#' @exportClass hummus_object
+#' @name Hummus_Object-class
+#' @rdname Hummus_Object-class
+#' @exportClass Hummus_Object
 #' @export
 #'
-#' @examples hummus_object <- hummus_object(seurat_object)
-#'
-hummus_object <- setClass(
-    Class = "hummus_object",
-    contains = "Seurat",
+Hummus_Object <- setClass(
+    Class = "Hummus_Object",
     slots = list(
+        "assays" = "list",
+        "active.assay" = "character",
         "multilayer" = "multilayer",
         "motifs_db" = "motifs_db"
     )
 )
 
-setMethod("show", "hummus_object",
+
+#' @title Initiate a hummus object
+#' 
+#' @description Initiate a hummus object
+#' 
+#' @param seurat_assays A Seurat object or a list of Seurat assays
+#' @param active.assay The name of the active assay. Default: NULL
+#' @param multilayer A multilayer object. Default: NULL
+#' @param motifs_db A motifs_db object. Default: NULL
+#' @return A hummus object
+#' @export
+#' 
+#' @examples seurat_object <- Seurat::CreateSeuratObject(counts = matrix(rnorm(1000), nrow = 100, ncol = 10))
+#'          hummus <- InitiateHummus_Object(seurat_object)
+#'          hummus
+Initiate_Hummus_Object <- function(
+  seurat_assays,
+  active.assay = NULL,
+  multilayer = NULL,
+  motifs_db = NULL) {
+
+  # Check if seurat_assays is a Seurat object or a list of Seurat assays
+  if (inherits(seurat_assays, "Seurat")) {
+    assays <- seurat_assays@assays
+    # setup active assay name
+    active.assay <- seurat_assays@active.assay
+  } else if (inherits(seurat_assays, "list")) {
+    assays <- seurat_assays
+    # setup active assay name
+    if (is.null(active.assay)) {
+      active.assay <- names(x = assays)[1]
+    } else if (!(active.assay %in% names(x = assays))) {
+      stop("active.assay must be a valid assay name.")
+    } else {
+      active.assay <- active.assay
+    }
+  } else {
+    stop("seurat_assays must be a Seurat object or a list of Seurat assays.")
+  }
+
+  # Check if multilayer is a multilayer object or NULL
+  if (!inherits(multilayer, "multilayer")) {
+    if (!is.null(multilayer)) {
+      stop("multilayer must be a multilayer object or NULL.")
+    } else {
+      multilayer <- new("multilayer")
+    }
+  }
+
+  # Check if motifs_db is a motifs_db object or NULL
+  if (!inherits(motifs_db, "motifs_db")) {
+    if (!is.null(motifs_db)) {
+      stop("motifs_db must be a motifs_db object or NULL.")
+    } else {
+      motifs_db <- new("motifs_db")
+    }
+  }
+
+  object <- new(
+    Class = "Hummus_Object",
+    assays = assays,
+    active.assay = active.assay,
+    multilayer = multilayer,
+    motifs_db = motifs_db
+  )
+
+  return(object)
+}
+
+
+#' @title Get Default assays of Hummus_Object (based on Seurat)
+#' @name DefaultAssay
+#' @export
+#'
+#' @examples
+#' # Get current default assay
+#' DefaultAssay(object = pbmc_small)
+#'
+DefaultAssay.Hummus_Object <- function(object, ...) {
+  SeuratObject::CheckDots(...)
+  default <- slot(object = object, name = 'active.assay')
+  if (!length(x = default)) {
+    default <- NULL
+  }
+  return(default)
+}
+
+#' Default Assay
+#'
+#' Get and set the default assay
+#'
+#' @param object An object
+#'
+#' @return \code{DefaultAssay}: The name of the default assay
+#'
+#' @rdname DefaultAssay
+#' @export DefaultAssay
+#'
+#' @concept data-access
+#'
+DefaultAssay <- function(object, ...) {
+  UseMethod(generic = 'DefaultAssay', object = object)
+}
+
+#' @param value Name of assay to set as default
+#'
+#' @return \code{DefaultAssay<-}: An object with the default assay updated
+#'
+#' @rdname DefaultAssay
+#' @export DefaultAssay<-
+#'
+"DefaultAssay<-" <- function(object, ..., value) {
+  UseMethod(generic = 'DefaultAssay<-', object = object)
+}
+
+
+#' @title Variable features of assays in Hummus_Object (based on Seurat)
+#' @name VariableFeatures
+#' @export
+#'
+VariableFeatures.Hummus_Object <- function(
+  object,
+  method = NULL,
+  assay = NULL,
+  nfeatures = NULL,
+  layer = NA,
+  simplify = TRUE,
+  selection.method = lifecycle::deprecated(),
+  ...
+) {
+  SeuratObject::CheckDots(...)
+  if (lifecycle::is_present(arg = selection.method)) {
+    SeuratObject.Deprecate(
+      when = '5.0.0',
+      what = 'VariableFeatures(selection.method = )',
+      with = 'VariableFeatures(method = )'
+    )
+    method <- selection.method
+  }
+  assay <- assay %||% SeuratObject::DefaultAssay(object = object)
+  return(SeuratObject::VariableFeatures(
+    object = object[[assay]],
+    method = method,
+    nfeatures = nfeatures,
+    layer = layer,
+    simplify = simplify,
+    ...
+  ))
+}
+#' @return \code{VariableFeatures}: a vector of the variable features
+#'
+#' @rdname VariableFeatures
+#' @export VariableFeatures
+#'
+#'
+VariableFeatures <- function(object, method = NULL, ...) {
+  UseMethod(generic = 'VariableFeatures', object = object)
+}
+
+#' @param value A character vector of variable features
+#'
+#' @rdname VariableFeatures
+#' @export VariableFeatures<-
+#'
+"VariableFeatures<-" <- function(object, ..., value) {
+  UseMethod(generic = 'VariableFeatures<-', object = object)
+}
+
+
+#' @title Access assays in Hummus_Object (based on Seurat)
+#' @method [[ Hummus_Object
+#' @name [[<-,Hummus_Object
+#' @export
+#' @aliases [[<-.Hummus_Object \S4method{[[<-}{Hummus_Object,character,missing,Assay}
+#' 
+"[[.Hummus_Object" <- function(x, i = missing_arg(), ..., drop = FALSE, na.rm = FALSE) {
+  md <- slot(object = x, name = 'assays')
+  if (rlang::is_missing(x = i)) {
+    return(md)
+  } else if (is.null(x = i)) {
+    return(NULL)
+  } else if (!length(x = i)) {
+    return(data.frame(row.names = row.names(x = md)))
+  }
+  # Correct invalid `i`
+  meta.cols <- names(x = md)
+  if (rlang::is_bare_integerish(x = i)) {
+    if (all(i > length(x = meta.cols))) {
+      abort(message = paste(
+        "Invalid integer indexing:",
+        "all integers greater than the number of meta columns"
+      ))
+    }
+    i <- meta.cols[as.integer(x = i[i <= length(x = meta.cols)])]
+  }
+  if (!is.character(x = i)) {
+    abort(message = "'i' must be a character vector")
+  }
+  # Determine if we're pulling cell-level meta data
+  # or a sub-object
+  slot.use <- if (length(x = i) == 1L) {
+    SeuratObject::.FindObject(object = x, name = i)
+  } else {
+    NULL
+  }
+  # Pull cell-level meta data
+  if (is.null(x = slot.use)) {
+    i <- tryCatch(
+      expr = arg_match(arg = i, values = meta.cols, multiple = TRUE),
+      error = function(e) {
+        #error message that indicates which colnames not found
+        abort(
+          message = paste(
+            paste(sQuote(x = setdiff(x = i, y = meta.cols)), collapse = ', '),
+            "not found in this HuMMuS object\n",
+            e$body
+          ),
+          call = rlang::caller_env(n = 4L)
+        )
+      }
+    )
+    # Pull the cell-level meta data
+    data.return <- md[, i, drop = FALSE, ...]
+    # If requested, remove NAs
+    if (isTRUE(x = na.rm)) {
+      idx.na <- apply(X = is.na(x = data.return), MARGIN = 1L, FUN = all)
+      data.return <- data.return[!idx.na, , drop = FALSE]
+    } else {
+      idx.na <- rep_len(x = FALSE, length.out = ncol(x = x))
+    }
+    # If requested, coerce to a vector
+    if (isTRUE(x = drop)) {
+      data.return <- unlist(x = data.return, use.names = FALSE)
+      names(x = data.return) <- rep.int(
+        x = colnames(x = x)[!idx.na],
+        times = length(x = i)
+      )
+    }
+    return(data.return)
+  }
+  # Pull a sub-object
+  return(slot(object = x, name = slot.use)[[i]])
+}
+
+
+setMethod("show", "Hummus_Object",
   function(object) {
     #object <- SeuratObject::UpdateSlots(object = object)
     assays <- SeuratObject::.FilterObjects(object = object,
@@ -252,7 +496,7 @@ setMethod("show", "hummus_object",
 
 #' @title Save multilayer object files in a hierarchical structure on disk
 #'
-#' @description Save multilayer files from a hummus_object
+#' @description Save multilayer files from a Hummus_Object
 #' in a hierarchical structure on disk, inside a folder specified through
 #'  folder_name
 #'
@@ -363,7 +607,7 @@ add_network <- function(
     }
     # Get working multiplex
     multiplex <- object@multiplex[[multiplex_name]]
-  } else if (inherits(object, "hummus_object")) {
+  } else if (inherits(object, "Hummus_Object")) {
     # Check if multiplex_name is NULL
     if (is.null(multiplex_name)) {
       stop("You need to specify the multiplex name.")
@@ -380,7 +624,7 @@ add_network <- function(
     multiplex <- object@multilayer@multiplex[[multiplex_name]]
 
   } else {
-    stop("Object is not a multiplex, a multilayer nor an hummus object.")
+    stop("Object is not a multiplex, a multilayer nor an hummus object.: ", class(object))
   }
 
   # Check if network name already exists in the multiplex
@@ -409,7 +653,7 @@ add_network <- function(
   } else if (inherits(object, "multilayer")) {
     object@multiplex[[multiplex_name]] <- multiplex
     return(object)
-  } else if (inherits(object, "hummus_object")) {
+  } else if (inherits(object, "Hummus_Object")) {
     object@multilayer@multiplex[[multiplex_name]] <- multiplex
     return(object)
   }