refactor and deprecate object lookup scheme

rnabioco · Jan 26, 2024 · c19731f · c19731f
1 parent 4034d7d
commit c19731f
Show file tree

Hide file tree

Showing 31 changed files with 153 additions and 204 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -45,11 +45,11 @@ export(get_ucsc_reference)
 export(get_vargenes)
 export(gmt_to_list)
 export(insert_meta_object)
-export(is_pkg_available)
 export(make_comb_ref)
 export(marker_select)
 export(matrixize_markers)
 export(object_data)
+export(object_loc_lookup)
 export(object_ref)
 export(overcluster)
 export(overcluster_test)
@@ -108,4 +108,5 @@ importFrom(stats,p.adjust)
 importFrom(stats,prcomp)
 importFrom(stats,quantile)
 importFrom(tidyr,gather)
+importFrom(utils,packageVersion)
 importFrom(utils,read.csv)
diff --git a/R/data.R b/R/data.R
@@ -55,12 +55,6 @@
 #' @source \url{https://satijalab.org/seurat/v3.0/multimodal_vignette.html#identify-differentially-expressed-proteins-between-clusters}
 "cbmc_m"
 
-#' lookup table for single cell object structures
-#'
-#' @family data
-#' @source  various packages
-"object_loc_lookup"
-
 #' table of references stored in clustifyrdata
 #'
 #' @family data

diff --git a/R/object_access.R b/R/object_access.R
@@ -55,18 +55,19 @@ sce_pbmc <- function() {
 }
 
 pbmc_example_data <- function() {
-  mat <- pbmc_matrix_small
-  md <- pbmc_meta
+  mat <- clustifyr::pbmc_matrix_small
+  md <- clustifyr::pbmc_meta
   umap_cols <- c("UMAP_1", "UMAP_2")
-  umap <- as.matrix(pbmc_meta[, umap_cols])
-  md <- pbmc_meta[, setdiff(colnames(pbmc_meta), umap_cols)]
-  vargenes <- pbmc_vargenes
+  umap <- as.matrix(md[, umap_cols])
+  md <- md[, setdiff(colnames(md), umap_cols)]
+  vargenes <- clustifyr::pbmc_vargenes
 
   list(mat = mat,
        metadata = md,
        umap = umap,
        vargenes = vargenes)
 }
+
 #' Function to access object data
 #' @return expression matrix, with genes as row names,
 #' and cell types as column names
@@ -82,8 +83,9 @@ object_data <- function(object, ...) {
 #'   set to 0 to use all variable genes (generally not recommended)
 #' @param ... additional arguments
 #' @examples
+#' so <- so_pbmc()
 #' mat <- object_data(
-#'     object = s_small3,
+#'     object = so,
 #'     slot = "data"
 #' )
 #' mat[1:3, 1:3]
@@ -113,8 +115,9 @@ object_data.Seurat <- function(object,
     }
 }
 
+#' @importFrom utils packageVersion
 is_seurat_v5 <- function() {
-  packageVersion("SeuratObject") >= '5.0.0'
+  utils::packageVersion("SeuratObject") >= '5.0.0'
 }
 
 extract_v5_matrix <- function(x, ...) {
@@ -167,8 +170,9 @@ get_seurat_matrix <- function(x, warn = TRUE) {
 #' @param ... additional arguments
 #' @importFrom SingleCellExperiment logcounts colData
 #' @examples
+#' sce <- sce_pbmc()
 #' mat <- object_data(
-#'     object = sce_small,
+#'     object = sce,
 #'     slot = "data"
 #' )
 #' mat[1:3, 1:3]
@@ -180,6 +184,8 @@ object_data.SingleCellExperiment <- function(object,
         return(SingleCellExperiment::logcounts(object))
     } else if (slot == "meta.data") {
         return(as.data.frame(SingleCellExperiment::colData(object)))
+    } else {
+        stop(slot, " access method not implemented")
     }
 }
 
@@ -196,9 +202,10 @@ write_meta <- function(object, ...) {
 #' @param meta new metadata dataframe
 #' @param ... additional arguments
 #' @examples
+#' so <- so_pbmc()
 #' obj <- write_meta(
-#'     object = s_small3,
-#'     meta = seurat_meta(s_small3)
+#'     object = so,
+#'     meta = seurat_meta(so)
 #' )
 #' @export
 write_meta.Seurat <- function(object,
@@ -218,9 +225,10 @@ write_meta.Seurat <- function(object,
 #' @importFrom S4Vectors DataFrame
 #' @importFrom SummarizedExperiment colData<-
 #' @examples
+#' sce <- sce_pbmc()
 #' obj <- write_meta(
-#'     object = sce_small,
-#'     meta = object_data(sce_small, "meta.data")
+#'     object = sce,
+#'     meta = object_data(sce, "meta.data")
 #' )
 #' @export
 write_meta.SingleCellExperiment <- function(object,
@@ -234,7 +242,8 @@ write_meta.SingleCellExperiment <- function(object,
 #' @return reference expression matrix, with genes as row names,
 #' and cell types as column names
 #' @examples 
-#' ref <- seurat_ref(s_small3, cluster_col = "RNA_snn_res.1")
+#' so <- so_pbmc()
+#' ref <- seurat_ref(so, cluster_col = "seurat_clusters")
 #' @export
 seurat_ref <- function(seurat_object, ...) {
     UseMethod("seurat_ref", seurat_object)
@@ -304,7 +313,8 @@ seurat_ref.Seurat <- function(seurat_object,
 #' Function to convert labelled seurat object to fully prepared metadata
 #' @return dataframe of metadata, including dimension reduction plotting info
 #' @examples
-#' m <- seurat_meta(s_small3)
+#' so <- so_pbmc()
+#' m <- seurat_meta(so)
 #' @export
 seurat_meta <- function(seurat_object, ...) {
     UseMethod("seurat_meta", seurat_object)
@@ -368,9 +378,10 @@ object_ref <- function(input, ...) {
 #' averaging will be done on unlogged data
 #' @param ... additional arguments
 #' @examples
+#' so <- so_pbmc()
 #' object_ref(
-#'     s_small3,
-#'     cluster_col = "RNA_snn_res.1"
+#'     so,
+#'     cluster_col = "seurat_clusters"
 #' )
 #' @export
 object_ref.default <- function(input,

diff --git a/R/utils.R b/R/utils.R
@@ -1,7 +1,7 @@
 #' Check package is installed
 #' @param pkg package to query
 #' @return logical(1) indicating if package is available.
-#' @export 
+#' @noRd
 is_pkg_available <- function(pkg, 
                              action = c("none", "message", "warn", "error"),
                              msg = "") {
@@ -750,16 +750,17 @@ gene_pct_markerm <- function(matrix,
 #'
 #' @examples
 #'
-#' # Seurat3
+#' # Seurat
+#' so <- so_pbmc()
 #' clustify_nudge(
-#'     input = s_small3,
+#'     input = so,
 #'     ref_mat = cbmc_ref,
 #'     marker = cbmc_m,
-#'     cluster_col = "RNA_snn_res.1",
+#'     cluster_col = "seurat_clusters",
 #'     threshold = 0.8,
 #'     obj_out = FALSE,
 #'     mode = "pct",
-#'     dr = "tsne"
+#'     dr = "umap"
 #' )
 #'
 #' # Matrix
@@ -1039,19 +1040,77 @@ clustify_nudge.Seurat <- function(input,
         input
     }
 }
+#' lookup table for single cell object structures
+#' @importFrom SummarizedExperiment colData<-
+#' @export
+object_loc_lookup <- function() {
+  l <- list()
+
+  l$SingleCellExperiment <- c(
+    expr = function(x) object_data(x, "data"),
+    meta = function(x) object_data(x, "meta.data"),
+    add_meta = function(x, md) { 
+      colData(x) <- md
+      x},
+    var = NULL,
+    col = "cell_type1"
+  )
+
+  l$Seurat <- c(
+    expr = function(x) object_data(x, "data"),
+    meta = function(x) object_data(x, "meta.data"),
+    add_meta = function(x, md) { 
+      x@meta.data <- md
+      x},
+    var = function(x) object_data(x, "var.genes"),
+    col = "RNA_snn_res.1"
+  )
+
+  l$URD <- c(
+    expr = function(x) x@logupx.data,
+    meta = function(x) x@meta,
+    add_meta = function(x, md) { 
+      x@meta <- md
+      x},
+    var = function(x) x@var.genes,
+    col = "cluster"
+  )
+
+  l$FunctionalSingleCellExperiment <- c(
+    expr = function(x) x@ExperimentList$rnaseq@assays$data$logcounts,
+    meta = function(x) x@ExperimentList$rnaseq@colData,
+    add_meta = function(x, md) { 
+      x@ExperimentList$rnaseq@colData <- md
+      x},
+    var = NULL,
+    col = "leiden_cluster"
+  )
+
+  l$CellDataSet <- c(
+    expr = function(x) do.call(function(x) {row.names(x) <- x@featureData@data$gene_short_name; return(x)}, list(x@assayData$exprs)),
+    meta = function(x) as.data.frame(x@phenoData@data),
+    add_meta = function(x, md) { 
+      x@phenoData@data <- md
+      x},
+    var = function(x) as.character(x@featureData@data$gene_short_name[x@featureData@data$use_for_ordering == T]),
+    col = "Main_Cluster"
+  )
+  l
+}
 
 #' more flexible parsing of single cell objects
 #'
 #' @param input input object
 #' @param type look up predefined slots/loc
-#' @param expr_loc expression matrix location
-#' @param meta_loc metadata location
-#' @param var_loc variable genes location
+#' @param expr_loc function that extracts expression matrix 
+#' @param meta_loc function that extracts metadata 
+#' @param var_loc function that extracts variable genes 
 #' @param cluster_col column of clustering from metadata
-#' @param lookuptable if not supplied, will look in built-in table for object parsing
+#' @param lookuptable if not supplied, will use object_loc_lookup() for parsing. 
 #' @return list of expression, metadata, vargenes, cluster_col info from object
 #' @examples
-#' obj <- parse_loc_object(s_small3)
+#' so <- so_pbmc() 
+#' obj <- parse_loc_object(so)
 #' length(obj)
 #' @export
 parse_loc_object <- function(input,
@@ -1061,19 +1120,25 @@ parse_loc_object <- function(input,
     var_loc = NULL,
     cluster_col = NULL,
     lookuptable = NULL) {
+    if(!type %in% c("SingleCellExperiment", "Seurat")) {
+      warning("Support for ", type, " objects is deprecated ",
+              "and will be removed from clustifyr in the next version")
+    }
+
     if (is.null(lookuptable)) {
-        object_loc_lookup1 <- clustifyr::object_loc_lookup
+        lookup <- object_loc_lookup()
     } else {
-        object_loc_lookup1 <- lookuptable
+        warning("Support for supplying custom objects is deprecated ",
+                "and will be removed from clustifyr in the next version")
+        lookup <- lookuptable
     }
 
-    if (length(intersect(type, colnames(object_loc_lookup1))) > 0) {
-        type <- intersect(type, colnames(object_loc_lookup1))[1]
+    if (type %in% names(lookup)) {
         parsed <- list(
-            eval(parse(text = object_loc_lookup1[[type]][1])),
-            as.data.frame(eval(parse(text = object_loc_lookup1[[type]][2]))),
-            eval(parse(text = object_loc_lookup1[[type]][3])),
-            object_loc_lookup1[[type]][4]
+            expr = lookup[[type]]$expr(input),
+            meta = as.data.frame(lookup[[type]]$meta(input)),
+            var = lookup[[type]]$var(input),
+            col = lookup[[type]]$col
         )
     } else {
         parsed <- list(NULL, NULL, NULL, NULL)
@@ -1082,18 +1147,15 @@ parse_loc_object <- function(input,
     names(parsed) <- c("expr", "meta", "var", "col")
 
     if (!(is.null(expr_loc))) {
-        parsed[["expr"]] <- eval(parse(text = paste0("input", expr_loc)))
+        parsed[["expr"]] <- expr_loc(input)
     }
 
     if (!(is.null(meta_loc))) {
-        parsed[["meta"]] <-
-            as.data.frame(eval(parse(text = paste0(
-                "input", meta_loc
-            ))))
+        parsed[["meta"]] <- as.data.frame(meta_loc(input))
     }
 
     if (!(is.null(var_loc))) {
-        parsed[["var"]] <- eval(parse(text = paste0("input", var_loc)))
+        parsed[["var"]] <- var_loc(input)
     }
 
     if (!(is.null(cluster_col))) {
@@ -1113,26 +1175,24 @@ parse_loc_object <- function(input,
 #' will look in built-in table for object parsing
 #' @return new object with new metadata inserted
 #' @examples
-#' \dontrun{
-#' insert_meta_object(s_small3, seurat_meta(s_small3, dr = "tsne"))
-#' }
+#' so <- so_pbmc()
+#' insert_meta_object(so, seurat_meta(so, dr = "umap"))
 #' @export
 insert_meta_object <- function(input,
     new_meta,
     type = class(input),
     meta_loc = NULL,
     lookuptable = NULL) {
     if (is.null(lookuptable)) {
-        object_loc_lookup1 <- clustifyr::object_loc_lookup
+        lookup <- object_loc_lookup()
     } else {
-        object_loc_lookup1 <- lookuptable
+        lookup <- lookuptable
     }
 
-    if (!type %in% colnames(object_loc_lookup1)) {
+    if (!type %in% names(lookup)) {
         stop("unrecognized object type", call. = FALSE)
     } else {
-        text1 <- paste0(object_loc_lookup1[[type]][2], " <- ", "new_meta")
-        eval(parse(text = text1))
+        input <- lookup[[type]]$add_meta(input, new_meta)
         return(input)
     }
 }

diff --git a/data-raw/object_loc_lookup.R b/data-raw/object_loc_lookup.R
@@ -1,38 +1,5 @@
 library(usethis)
 
-object_loc_lookup$SingleCellExperiment <- c(
-    expr = "input@assays$data$logcounts",
-    meta = "as.data.frame(input@colData)",
-    var = NULL,
-    col = "cell_type1"
-)
 
-object_loc_lookup$URD <- c(
-    expr = "[email protected]",
-    meta = "input@meta",
-    var = "[email protected]",
-    col = "cluster"
-)
-
-object_loc_lookup$FunctionalSingleCellExperiment <- c(
-    expr = "input@ExperimentList$rnaseq@assays$data$logcounts",
-    meta = "input@ExperimentList$rnaseq@colData",
-    var = NULL,
-    col = "leiden_cluster"
-)
-
-object_loc_lookup$Seurat <- c(
-    expr = "input@assays$RNA@data",
-    meta = "[email protected]",
-    var = "input@[email protected]",
-    col = "RNA_snn_res.1"
-)
-
-object_loc_lookup$CellDataSet <- c(
-    expr = "do.call(function(x) {row.names(x) <- input@featureData@data$gene_short_name; return(x)}, list(input@assayData$exprs))",
-    meta = "as.data.frame(input@phenoData@data)",
-    var = "as.character(input@featureData@data$gene_short_name[input@featureData@data$use_for_ordering == T])",
-    col = "Main_Cluster"
-)
 
 usethis::use_data(object_loc_lookup, compress = "xz", overwrite = TRUE)