add sc_geom_annot to add the annotation layer for external data

.github/workflows/rworkflows.yml

@@ -30,12 +30,12 @@ jobs:
         - os: macOS-latest
           bioc: release
           r: auto
-          cont: ~
+          cont: ghcr.io/bioconductor/bioconductor_docker:RELEASE_3_19
           rspm: ~
         - os: windows-latest
           bioc: release
           r: auto
-          cont: ~
+          cont: ghcr.io/bioconductor/bioconductor_docker:RELEASE_3_19 
           rspm: ~
     steps:
     - uses: neurogenomics/rworkflows@master

DESCRIPTION

@@ -23,7 +23,7 @@ Imports:
   RcppParallel,
   cli,
   dplyr,
-  ggfun,
+  ggfun (>= 0.1.5),
   ggplot2,
   grDevices,
   grid,

NAMESPACE

@@ -5,6 +5,8 @@ S3method(ggplot_add,dim_sub)
 S3method(ggplot_add,sc_dim_geom_ellipse)
 S3method(ggplot_add,sc_dim_geom_feature)
 S3method(ggplot_add,sc_dim_geom_label)
+S3method(ggplot_add,sc_geom_annot)
+export("%<+%")
 export(aes)
 export(draw_key_scattermore2)
 export(geom_scattermore2)
@@ -17,6 +19,7 @@ export(sc_dim_geom_sub)
 export(sc_dim_sub)
 export(sc_dot)
 export(sc_feature)
+export(sc_geom_annot)
 export(sc_geom_point)
 export(sc_spatial)
 export(sc_violin)
@@ -42,6 +45,7 @@ importFrom(SummarizedExperiment,assay)
 importFrom(SummarizedExperiment,assayNames)
 importFrom(SummarizedExperiment,colData)
 importFrom(cli,cli_abort)
+importFrom(ggfun,"%<+%")
 importFrom(ggfun,get_aes_var)
 importFrom(ggplot2,"%+replace%")
 importFrom(ggplot2,ScaleDiscreteIdentity)

R/extract_data.R

@@ -0,0 +1,105 @@
+##' @importFrom methods as
+##' @importFrom SingleCellExperiment reducedDims reducedDimNames
+##' @importFrom SummarizedExperiment assay colData assayNames
+##' @importFrom cli cli_abort
+.extract_sce_data <- function(object, features = NULL, dims = c(1, 2),
+                              reduction = NULL, cells = NULL, slot = 1,
+                              plot.pie = FALSE, density=FALSE, grid.n = 400,
+                              joint = FALSE, joint.fun = prod, sp.coords=NULL){
+    if (!is.null(cells)){
+        object <- object[, cells]
+    }
+
+    xx <- colData(object) |> as.data.frame(check.names=FALSE) |> suppressWarnings()
+    reduced.dat <- NULL
+    if (!is.null(dims)){
+        if (length(reducedDimNames(object)) == 0){
+            cli::cli_abort(c("The {.cls {class(object)}} didn't contain the results of reduction."))
+        }
+        if (is.null(reduction)){
+            reduction <- 1
+        }
+        reduced.dat <- reducedDims(object)[[reduction]][,dims] |>
+            as.data.frame(check.names = FALSE)
+        xx <- cbind(reduced.dat, xx)
+    }
+
+    if (!is.null(features)){
+        if (slot == 'data'){
+            if ('logcounts' %in% assayNames(object)){
+                slot <- 'logcounts'
+            }else{
+                slot <- 1
+            }
+        }
+
+        tmp <- assay(object, slot)
+        tmp <- tmp[features, ,drop=FALSE]
+
+        if (density && !is.null(reduced.dat) && !plot.pie){
+          tmp <- .buildWkde(w = tmp, coords = reduced.dat, n = grid.n,
+                            joint = joint, joint.fun = joint.fun)
+        }else if (density && !is.null(sp.coords) && !plot.pie){
+          tmp <- .buildWkde(w = tmp, coords = sp.coords, n = grid.n,
+                            joint = joint, joint.fun = joint.fun)
+        }else{
+          tmp <- tmp |>
+                 as('matrix') |>
+                 t() |>
+                 as.data.frame(check.names=FALSE)
+        }
+        xx <- cbind(xx, tmp)
+    }
+    xx <- cbind(data.frame(.BarcodeID=rownames(xx)), xx)
+    return(xx)
+}	
+
+get_dim_data <- function(object, features = NULL,
+                    dims=c(1,2), reduction=NULL,
+                    cells=NULL, slot = "data",
+                    plot.pie=FALSE, density = FALSE,
+                    grid.n = 400, joint = FALSE,
+                    joint.fun = prod, sp.coords = NULL
+                    ) {
+    rlang::check_installed('SeuratObject', 'for the internal function `get_dim_data()`.')
+    reduced.dat <- NULL
+
+    if (is.null(cells)) {
+        cells <- colnames(object)
+    }
+    #xx <- data.frame(ident=SeuratObject::Idents(object)[cells])
+    xx <- cbind(data.frame(ident = SeuratObject::Idents(object)[cells]), [email protected][cells,,drop=FALSE])
+
+    if (!is.null(dims)) {
+        if (is.null(reduction)) {
+            reduction <- SeuratObject::DefaultDimReduc(object)
+        }
+        dims <- paste0(SeuratObject::Key(object = object[[reduction]]), dims)
+        reduced.dat <- as.data.frame(SeuratObject::Embeddings(object[[reduction]])[cells, dims])
+    }
+
+    if (!is.null(features)){
+        if (is.numeric(features)){
+            features <- features[features <= nrow(object)]
+            features <- rownames(object)[features]
+        }
+        tmp <- SeuratObject::FetchData(object, vars = features, cells = cells, slot = slot)
+        if (density && !is.null(reduced.dat) && !plot.pie){
+            tmp <- .buildWkde(t(tmp), reduced.dat, grid.n, joint, joint.fun)
+            xx <- cbind(reduced.dat, xx, tmp)
+        }else if(density && !is.null(sp.coords) && !plot.pie){
+            tmp <- .buildWkde(t(tmp), sp.coords, grid.n, joint, joint.fun)
+            xx <- cbind(xx, tmp)
+        }else if (!is.null(reduced.dat) && !density){
+            xx <- cbind(reduced.dat, xx, tmp)
+        }else{
+            xx <- cbind(xx, tmp)
+        }
+    }else{
+        if (!is.null(reduced.dat)){
+            xx <- cbind(reduced.dat, xx)
+        }
+    }
+    xx <- cbind(data.frame(.BarcodeID=rownames(xx)), xx)
+    return(xx)
+}

R/internals.R

@@ -23,6 +23,7 @@
    p <- p$data |> dplyr::group_split(.data$features) |>
            lapply(function(i){
               p$data <- i
+              p <- .add_class(p, "ggsc")
               return(p)
             })
 

R/re-export.R

@@ -10,3 +10,7 @@ ggplot2::aes
 ##' @importFrom ggplot2 theme
 ##' @export
 ggplot2::theme
+
+##' @importFrom ggfun %<+%
+##' @export
+ggfun::`%<+%`

R/sc-dim-utilities.R

@@ -42,11 +42,11 @@ sc_dim_count <- function(sc_dim_plot) {
     y <- setNames(dd$label, dd$colour)
   } else {
     d2 <- unique(x[, c("colour", "group")])
-    y <- setNames(d2$group -1, d2$colour)
+    y <- setNames(d2$group, d2$colour)
   }
 
   d <- as.data.frame(sort(table(x$colour)))
-  d$group <- y[as.character(d$Var1)]
+  d$group <- y[as.character(d$Var1)] |> as.factor()
 
   rlang::check_installed("forcats", "for sc_dim_count()")
 
@@ -123,17 +123,16 @@ ggplot_add.sc_dim_geom_feature <- function(object, plot, object_name){
                                dims = object$dims, 
                                features = object$features)
     }
-    d <- as_tibble(d, rownames='.ID.NAME')
+    #d <- as_tibble(d, rownames='.ID.NAME')
 
     d <- tidyr::pivot_longer(
            d, 
            seq(ncol(d) - length(object$features) + 1, ncol(d)), 
            names_to = "features"
          ) |> 
          dplyr::select(-c(2, 3, 4)) |>
-         dplyr::left_join(plot$data[,seq_len(3)] |>
-                          tibble::as_tibble(rownames='.ID.NAME'), 
-                          by='.ID.NAME'
+         dplyr::left_join(plot$data[,seq_len(3)],
+                          by='.BarcodeID'
          )
     if (is.numeric(object$features)){
         object$features <- rownames(object$data)[object$features]
@@ -180,11 +179,11 @@ sc_dim_geom_label <- function(geom = ggplot2::geom_text, ...) {
 ##' @method ggplot_add sc_dim_geom_label
 ##' @export
 ggplot_add.sc_dim_geom_label <- function(object, plot, object_name) {
-    dims <- names(plot$data)[seq_len(2)]
+    dims <- names(plot$data)[seq_len(3)]
     lab.text <- plot$labels$colour
     if (is.null(object$data)) {
         object$data <- dplyr::group_by(plot$data, !!rlang::sym(lab.text)) |> 
-            dplyr::summarize(x=mean(get(dims[1])), y=mean(get(dims[2])))
+            dplyr::summarize(x=mean(get(dims[2])), y=mean(get(dims[3])))
     }
 
     geom <- object$geom
@@ -235,10 +234,10 @@ sc_dim_geom_ellipse <- function(mapping = NULL, level = 0.95, ...) {
 ##' @importFrom ggplot2 stat_ellipse
 ##' @export
 ggplot_add.sc_dim_geom_ellipse <- function(object, plot, object_name) {
-    dims <- names(plot$data)[seq_len(2)]
+    dims <- names(plot$data)[seq_len(3)]
     lab.text <- plot$labels$colour
-    default_mapping <- aes(x = .data[[dims[1]]], 
-                           y = .data[[dims[2]]], 
+    default_mapping <- aes(x = .data[[dims[2]]], 
+                           y = .data[[dims[3]]], 
                            group = !!rlang::sym(lab.text))
     if (is.null(object$mapping)) {
         mapping <- default_mapping
@@ -271,7 +270,7 @@ ggplot_add.sc_dim_geom_ellipse <- function(object, plot, object_name) {
 ##' colLabels(sce) <- clusters
 ##' sce <- runUMAP(sce, assay.type = 'logcounts')
 ##' p1 <- sc_dim(sce, reduction = 'UMAP')
-##' f1 <- p1 + sc_dim_geom_sub(subset = c(1, 2), .column = 'label')
+##' f1 <- p1 + sc_dim_geom_sub(subset = c(1, 2), .column = 'label', bg_colour='black')
 sc_dim_geom_sub <- function(mapping = NULL, subset, .column = "ident", ...) {
   structure(list(mapping = mapping, 
         subset = subset, 

R/sc-dim.R

@@ -83,6 +83,7 @@ setMethod("sc_dim",
     mapping <- .check_aes_mapping(object, mapping, data = d, prefix = 'ident')
 
     p <- sc_dim_internal(d, mapping, ...)
+    p <- .add_class(p, "ggsc")
     return(p)
 })
 
@@ -106,126 +107,19 @@ setMethod('sc_dim', 'SingleCellExperiment',
     mapping <- .check_aes_mapping(object, mapping, data = d, prefix = 'label')
 
     p <- sc_dim_internal(d, mapping, ...)
+    p <- .add_class(p, "ggsc")
     return(p)
 
 })
 
-##' @importFrom methods as
-##' @importFrom SingleCellExperiment reducedDims reducedDimNames
-##' @importFrom SummarizedExperiment assay colData assayNames
-##' @importFrom cli cli_abort
-.extract_sce_data <- function(object, features = NULL, dims = c(1, 2), 
-                              reduction = NULL, cells = NULL, slot = 1, 
-                              plot.pie = FALSE, density=FALSE, grid.n = 400, 
-                              joint = FALSE, joint.fun = prod, sp.coords=NULL){
-    if (!is.null(cells)){
-        object <- object[, cells]
-    }
-
-    xx <- colData(object) |> data.frame()
-    reduced.dat <- NULL
-    if (!is.null(dims)){
-        if (length(reducedDimNames(object)) == 0){
-            cli::cli_abort(c("The {.cls {class(object)}} didn't contain the results of reduction."))
-        }
-        if (is.null(reduction)){
-            reduction <- 1
-        }
-        reduced.dat <- reducedDims(object)[[reduction]][,dims] |> 
-            as.data.frame(check.names = FALSE)
-        xx <- merge(reduced.dat, xx, by = 0)
-        rownames(xx) <- xx$Row.names
-        xx$Row.names <- NULL
-    }
-
-    if (!is.null(features)){
-        if (slot == 'data'){
-            if ('logcounts' %in% assayNames(object)){
-                slot <- 'logcounts'
-            }else{
-                slot <- 1
-            }
-        }
-
-        tmp <- assay(object, slot)
-        tmp <- tmp[features, ,drop=FALSE] 
-
-        if (density && !is.null(reduced.dat) && !plot.pie){
-          tmp <- .buildWkde(w = tmp, coords = reduced.dat, n = grid.n, 
-                            joint = joint, joint.fun = joint.fun) 
-        }else if (density && !is.null(sp.coords) && !plot.pie){
-          tmp <- .buildWkde(w = tmp, coords = sp.coords, n = grid.n,
-                            joint = joint, joint.fun = joint.fun)
-        }else{
-          tmp <- tmp |> 
-                 as('matrix') |> 
-                 t() |> 
-                 as.data.frame(check.names=FALSE)
-        }
-
-        xx <- merge(xx, tmp, by = 0)
-        rownames(xx) <- xx$Row.names
-        xx$Row.names <- NULL
-    }
-    return(xx)
-}
-
 ##' @importFrom tidydr theme_dr
 sc_dim_internal <- function(data, mapping, geom = sc_geom_point, ...) {
-    dims <- names(data)[seq_len(2)]
-    p <- ggplot(data, aes(.data[[dims[1]]], .data[[dims[2]]])) 
-    p + geom(mapping, ...) +
-        theme_dr()
+    dims <- names(data)[seq_len(3)]
+    p <- ggplot(data, aes(.data[[dims[2]]], .data[[dims[3]]]))
+    params <- list(...)
+    params$mapping <- mapping
+    layers <- do.call(geom, params)
+    p <- p + layers + theme_dr()
+    return(p)
 } 
 
-get_dim_data <- function(object, features = NULL, 
-                    dims=c(1,2), reduction=NULL, 
-                    cells=NULL, slot = "data", 
-                    plot.pie=FALSE, density = FALSE, 
-                    grid.n = 400, joint = FALSE, 
-                    joint.fun = prod, sp.coords = NULL
-                    ) {
-    rlang::check_installed('SeuratObject', 'for the internal function `get_dim_data()`.')
-    reduced.dat <- NULL
-
-    if (is.null(cells)) {
-        cells <- colnames(object)
-    }
-    #xx <- data.frame(ident=SeuratObject::Idents(object)[cells])
-    xx <- cbind(data.frame(ident = SeuratObject::Idents(object)[cells]), [email protected][cells,,drop=FALSE])
-
-    if (!is.null(dims)) {
-        if (is.null(reduction)) {
-            reduction <- SeuratObject::DefaultDimReduc(object)
-        }
-        dims <- paste0(SeuratObject::Key(object = object[[reduction]]), dims)
-        reduced.dat <- as.data.frame(SeuratObject::Embeddings(object[[reduction]])[cells, dims])
-    }
-
-    if (!is.null(features)){
-        if (is.numeric(features)){
-            features <- features[features <= nrow(object)]
-            features <- rownames(object)[features]
-        }
-        tmp <- SeuratObject::FetchData(object, vars = features, cells = cells, slot = slot)
-        if (density && !is.null(reduced.dat) && !plot.pie){
-            tmp <- .buildWkde(t(tmp), reduced.dat, grid.n, joint, joint.fun)
-            xx <- cbind(reduced.dat, xx, tmp)
-        }else if(density && !is.null(sp.coords) && !plot.pie){
-            tmp <- .buildWkde(t(tmp), sp.coords, grid.n, joint, joint.fun)
-            xx <- cbind(xx, tmp)
-        }else if (!is.null(reduced.dat) && !density){
-            xx <- cbind(reduced.dat, xx, tmp)
-        }else{
-            xx <- cbind(xx, tmp)
-        }
-    }else{
-        if (!is.null(reduced.dat)){
-            xx <- cbind(reduced.dat, xx)
-        }
-    }
-
-    return(xx)
-}
-
-