biopipen 0.34.0__py3-none-any.whl → 0.34.2__py3-none-any.whl

biopipen/scripts/scrna/MarkersFinder.R

@@ -1,6 +1,7 @@
 library(rlang)
 library(dplyr)
 library(Seurat)
+library(tidyseurat)
 library(plotthis)
 library(biopipen.utils)
 
@@ -13,9 +14,9 @@ joboutdir <- {{ job.outdir | r }}
 
 ncores <- {{ envs.ncores | int }}
 mutaters <- {{ envs.mutaters | r }}
-group.by <- {{ envs["group-by"] | r }}
-ident.1 <- {{ envs["ident-1"] | r }}
-ident.2 <- {{ envs["ident-2"] | r }}
+group_by <- {{ envs.group_by | default: envs["group-by"] | default: None | r }}
+ident_1 <- {{ envs.ident_1 | default: envs["ident-1"] | default: None | r }}
+ident_2 <- {{ envs.ident_2 | default: envs["ident-2"] | default: None | r }}
 each <- {{ envs.each | r }}
 dbs <- {{ envs.dbs | r }}
 sigmarkers <- {{ envs.sigmarkers | r }}
@@ -27,6 +28,8 @@ cache <- {{ envs.cache | r }}
 rest <- {{ envs.rest | r: todot="-" }}
 allmarker_plots_defaults <- {{ envs.allmarker_plots_defaults | r }}
 allmarker_plots <- {{ envs.allmarker_plots | r }}
+allenrich_plots_defaults <- {{ envs.allenrich_plots_defaults | r }}
+allenrich_plots <- {{ envs.allenrich_plots | r }}
 marker_plots_defaults <- {{ envs.marker_plots_defaults | r }}
 marker_plots <- {{ envs.marker_plots | r }}
 enrich_plots_defaults <- {{ envs.enrich_plots_defaults | r }}
@@ -59,6 +62,9 @@ if (!is.null(mutaters) && length(mutaters) > 0) {
 allmarker_plots <- lapply(allmarker_plots, function(x) {
     list_update(allmarker_plots_defaults, x)
 })
+allenrich_plots <- lapply(allenrich_plots, function(x) {
+    list_update(allenrich_plots_defaults, x)
+})
 marker_plots <- lapply(marker_plots, function(x) {
     list_update(marker_plots_defaults, x)
 })
@@ -70,9 +76,9 @@ overlaps <- lapply(overlaps, function(x) {
 })
 
 defaults <- list(
-    group.by = group.by,
-    ident.1 = ident.1,
-    ident.2 = ident.2,
+    group_by = group_by,
+    ident_1 = ident_1,
+    ident_2 = ident_2,
     dbs = dbs,
     sigmarkers = sigmarkers,
     enrich_style = enrich_style,
@@ -82,6 +88,8 @@ defaults <- list(
     subset = subset,
     allmarker_plots_defaults = allmarker_plots_defaults,
     allmarker_plots = allmarker_plots,
+    allenrich_plots_defaults = allenrich_plots_defaults,
+    allenrich_plots = allenrich_plots,
     marker_plots_defaults = marker_plots_defaults,
     marker_plots = marker_plots,
     enrich_plots_defaults = enrich_plots_defaults,
@@ -97,16 +105,19 @@ log$info("Expanding cases ...")
 post_casing <- function(name, case) {
     outcases <- list()
 
-    case$group.by <- case$group.by %||% "Identity"
+    case$group_by <- case$group_by %||% "Identity"
 
     if (is.null(case$each) || is.na(case$each) || nchar(case$each) == 0 || isFALSE(each)) {
         # single cases, no need to expand
-        if (length(case$ident.1) > 0 && length(case$overlaps) > 0) {
+        if (length(case$ident_1) > 0 && length(case$overlaps) > 0) {
             stop("Cannot perform 'overlaps' with a single comparison (ident-1 is set) in case '", name, "'")
         }
-        if (length(case$ident.1) > 0 && length(case$allmarker_plots) > 0) {
+        if (length(case$ident_1) > 0 && length(case$allmarker_plots) > 0) {
             stop("Cannot perform 'allmarker_plots' with a single comparison (ident-1 is set) in case '", name, "'")
         }
+        if (length(case$ident_1) > 0 && length(case$allenrich_plots) > 0) {
+            stop("Cannot perform 'allenrich_plots' with a single comparison (ident-1 is set) in case '", name, "'")
+        }
 
         case$allmarker_plots <- lapply(
             case$allmarker_plots,
@@ -114,6 +125,12 @@ post_casing <- function(name, case) {
         )
         case$allmarker_plots_defaults <- NULL
 
+        case$allenrich_plots <- lapply(
+            case$allenrich_plots,
+            function(x) { list_update(case$allenrich_plots_defaults, x) }
+        )
+        case$allenrich_plots_defaults <- NULL
+
         case$marker_plots <- lapply(
             case$marker_plots,
             function(x) { list_update(case$marker_plots_defaults, x) }
@@ -142,8 +159,8 @@ post_casing <- function(name, case) {
             srtobj@meta.data %>%
                 pull(case$each) %>% na.omit() %>% unique() %>% as.vector()
         }
-        if (length(case$overlaps) > 0 && is.null(case$ident.1)) {
-            stop("Cannot perform 'overlaps' analysis with 'each' and without 'ident.1' in case '", name, "'")
+        if (length(case$overlaps) > 0 && is.null(case$ident_1)) {
+            stop("Cannot perform 'overlaps' analysis with 'each' and without 'ident_1' in case '", name, "'")
         }
 
         if (length(cases) == 0 && name == "Marker Discovery") {
@@ -157,6 +174,7 @@ post_casing <- function(name, case) {
             newcase$original_case <- name
             newcase$each_name <- case$each
             newcase$each <- each
+            newcase$original_subset <- case$subset
 
             if (!is.null(case$subset)) {
                 newcase$subset <- paste0(case$subset, " & ", bQuote(case$each), " == '", each, "'")
@@ -179,20 +197,31 @@ post_casing <- function(name, case) {
             # Will be processed by the case itself, which collects the markers
             newcase$allmarker_plots <- NULL
             newcase$allmarker_plots_defaults <- NULL
+            newcase$allenrich_plots <- NULL
+            newcase$allenrich_plots_defaults <- NULL
             newcase$overlaps <- NULL
             newcase$overlaps_defaults <- NULL
 
             outcases[[newname]] <- newcase
         }
 
-        if (length(case$overlaps) > 0 || length(case$allmarker_plots) > 0) {
+        if (length(case$overlaps) > 0 || length(case$allmarker_plots) > 0 || length(case$allenrich_plots) > 0) {
             ovcase <- case
+
             ovcase$markers <- list()
             ovcase$allmarker_plots <- lapply(
                 ovcase$allmarker_plots,
                 function(x) { list_update(ovcase$allmarker_plots_defaults, x) }
             )
             ovcase$allmarker_plots_defaults <- NULL
+
+            ovcase$enriches <- list()
+            ovcase$allenrich_plots <- lapply(
+                ovcase$allenrich_plots,
+                function(x) { list_update(ovcase$allenrich_plots_defaults, x) }
+            )
+            ovcase$allenrich_plots_defaults <- NULL
+
             ovcase$overlaps <- lapply(
                 ovcase$overlaps,
                 function(x) { list_update(ovcase$overlaps_defaults, x) }
@@ -255,6 +284,32 @@ process_markers <- function(markers, info, case) {
 
     # Do enrichment analysis
     significant_markers <- unique(sigmarkers$gene)
+    empty <- if (case$enrich_style == "enrichr") {
+        data.frame(
+            Database = character(0),
+            Term = character(0),
+            Overlap = character(0),
+            P.value = numeric(0),
+            Adjusted.P.value = numeric(0),
+            Odds.Ratio = numeric(0),
+            Combined.Score = numeric(0),
+            Genes = character(0),
+            Rank = numeric(0)
+        )
+    } else {  # clusterProfiler
+        data.frame(
+            ID = character(0),
+            Description = character(0),
+            GeneRatio = character(0),
+            BgRatio = character(0),
+            Count = integer(0),
+            pvalue = numeric(0),
+            p.adjust = numeric(0),
+            qvalue = numeric(0),
+            geneID = character(0),
+            Database = character(0)
+        )
+    }
 
     if (length(significant_markers) < 5) {
         if (case$error) {
@@ -271,6 +326,7 @@ process_markers <- function(markers, info, case) {
                 ui = "tabs"
             )
         }
+        return(empty)
     } else {
         tryCatch({
             enrich <- RunEnrichment(
@@ -298,7 +354,9 @@ process_markers <- function(markers, info, case) {
 
                         p <- do_call(VizEnrichment, plotargs)
 
-                        attr(p, "height") <- attr(p, "height") / 1.5
+                        if (plotargs$plot_type == "bar") {
+                            attr(p, "height") <- attr(p, "height") / 1.5
+                        }
                         outprefix <- file.path(info$prefix, paste0("enrich.", slugify(db), ".", slugify(plotname)))
                         save_plot(p, outprefix, plotargs$devpars, formats = "png")
                         plots[[length(plots) + 1]] <- reporter$image(outprefix, c(), FALSE)
@@ -311,6 +369,7 @@ process_markers <- function(markers, info, case) {
                     )
                 }
             }
+            return(enrich)
         }, error = function(e) {
             if (case$error) {
                 stop("Error: ", e$message)
@@ -325,6 +384,7 @@ process_markers <- function(markers, info, case) {
                     ui = "tabs"
                 )
             }
+            return(empty)
         })
     }
 }
@@ -332,6 +392,7 @@ process_markers <- function(markers, info, case) {
 process_allmarkers <- function(markers, plotcases, casename, groupname) {
     name <- paste0(casename, "::", paste0(groupname, " (All Markers)"))
     info <- case_info(name, outdir, create = TRUE)
+
     for (plotname in names(plotcases)) {
         plotargs <- plotcases[[plotname]]
         plotargs$degs <- markers
@@ -348,8 +409,43 @@ process_allmarkers <- function(markers, plotcases, casename, groupname) {
     }
 }
 
+process_allenriches <- function(enriches, plotcases, casename, groupname) {
+    name <- paste0(casename, "::", paste0(groupname, " (All Enrichments)"))
+    info <- case_info(name, outdir, create = TRUE)
+    dbs <- unique(as.character(enriches$Database))
+
+    for (db in dbs) {
+        plots <- list()
+        for (plotname in names(plotcases)) {
+            plotargs <- plotcases[[plotname]]
+            plotargs <- extract_vars(plotargs, "devpars")
+            plotargs$data <- enriches[enriches$Database == db, , drop = FALSE]
+            if (plotargs$plot_type == "heatmap") {
+                plotargs$group_by <- groupname
+                plotargs$show_row_names = plotargs$show_row_names %||% TRUE
+                plotargs$show_column_names = plotargs$show_column_names %||% TRUE
+            }
+
+            p <- do_call(VizEnrichment, plotargs)
+
+            if (plotargs$plot_type == "bar") {
+                attr(p, "height") <- attr(p, "height") / 1.5
+            }
+            outprefix <- file.path(info$prefix, paste0("allenrich.", slugify(db), ".", slugify(plotname)))
+            save_plot(p, outprefix, devpars, formats = "png")
+            plots[[length(plots) + 1]] <- reporter$image(outprefix, c(), FALSE)
+        }
+        reporter$add2(
+            list(name = db, contents = plots),
+            hs = c(info$section, info$name),
+            hs2 = plotname,
+            ui = "tabs"
+        )
+    }
+}
+
 process_overlaps <- function(markers, ovcases, casename, groupname) {
-    name <- paste0(casename, "::", paste0(groupname, ": Overlaps"))
+    name <- paste0(casename, "::", paste0(groupname, " (Overlaps)"))
     info <- case_info(name, outdir, create = TRUE)
 
     for (plotname in names(ovcases)) {
@@ -415,53 +511,91 @@ run_case <- function(name) {
 
     case <- extract_vars(
         case,
-        "dbs", "sigmarkers", "allmarker_plots", "marker_plots", "enrich_plots", "overlaps",
-        "original_case", "markers", "each_name", "each", "enrich_style",
+        "dbs", "sigmarkers", "allmarker_plots", "allenrich_plots", "marker_plots", "enrich_plots",
+        "overlaps", "original_case", "markers", "enriches", "each_name", "each", "enrich_style", "original_subset",
         allow_nonexisting = TRUE
     )
-    if (!is.null(markers)) {  # It is the overlap/allmarker case
-        log$info("- Summarizing markers in subcases (by each: {each}) ...")
-        # handle the overlaps / allmarkers analysis here
-        if (!is.data.frame(markers)) {
-            markers <- do_call(rbind, lapply(names(markers), function(x) {
-                markers_df <- markers[[x]]
-                markers_df[[each]] <- x
-                markers_df
-            }))
-        }
-        # gene, p_val, avg_log2FC, pct.1, pct.2, p_val_adj, diff_pct, <each>
 
-        if (length(allmarker_plots) > 0) {
-            log$info("- Visualizing all markers together ...")
-            attr(markers, "object") <- srtobj
-            attr(markers, "group.by") <- each
-            attr(markers, "ident.1") <- NULL
-            attr(markers, "ident.2") <- NULL
-            process_allmarkers(markers, allmarker_plots, name, each)
+    if (!is.null(markers) || !is.null(enriches)) {
+        if (!is.null(markers)) {  # It is the overlap/allmarker case
+            log$info("- Summarizing markers in subcases (by each: {each}) ...")
+            # handle the overlaps / allmarkers analysis here
+            if (!is.data.frame(markers)) {
+                each_levels <- names(markers)
+                markers <- do_call(rbind, lapply(each_levels, function(x) {
+                    markers_df <- markers[[x]]
+                    if (nrow(markers_df) > 0) {
+                        markers_df[[each]] <- x
+                    } else {
+                        markers_df[[each]] <- character(0)  # Empty case
+                    }
+                    markers_df
+                }))
+                markers[[each]] <- factor(markers[[each]], levels = each_levels)
+            }
+            # gene, p_val, avg_log2FC, pct.1, pct.2, p_val_adj, diff_pct, <each>
+
+            if (length(allmarker_plots) > 0) {
+                log$info("- Visualizing all markers together ...")
+                if (is.null(original_subset)) {
+                    attr(markers, "object") <- srtobj
+                } else {
+                    attr(markers, "object") <- filter(srtobj, !!parse_expr(original_subset))
+                }
+                attr(markers, "group_by") <- each
+                attr(markers, "ident_1") <- NULL
+                attr(markers, "ident_2") <- NULL
+                process_allmarkers(markers, allmarker_plots, name, each)
+            }
+
+            if (length(overlaps) > 0) {
+                log$info("- Visualizing overlaps between subcases ...")
+                process_overlaps(markers, overlaps, name, each)
+            }
+
         }
 
-        if (length(overlaps) > 0) {
-            log$info("- Visualizing overlaps between subcases ...")
-            process_overlaps(markers, overlaps, name, each)
+        if (!is.null(enriches)) {
+            log$info("- Summarizing enrichments in subcases (by each: {each}) ...")
+            if (!is.data.frame(enriches)) {
+                each_levels <- names(enriches)
+                enriches <- do_call(rbind, lapply(each_levels, function(x) {
+                    enrich_df <- enriches[[x]]
+                    if (nrow(enrich_df) > 0) {
+                        enrich_df[[each]] <- x
+                    } else {
+                        enrich_df[[each]] <- character(0)  # Empty case
+                    }
+                    enrich_df
+                }))
+                enriches[[each]] <- factor(enriches[[each]], levels = each_levels)
+            }
+
+            if (length(allenrich_plots) > 0) {
+                log$info("- Visualizing all enrichments together ...")
+                process_allenriches(enriches, allenrich_plots, name, each)
+            }
         }
 
         return(invisible())
     }
+
     case$object <- srtobj
     markers <- do_call(RunSeuratDEAnalysis, case)
     case$object <- NULL
     gc()
 
-    if (is.null(case$ident.1)) {
-        all_idents <- unique(as.character(markers[[case$group.by]]))
+    if (is.null(case$ident_1)) {
+        all_idents <- unique(as.character(markers[[case$group_by]]))
+        enriches <- list()
         for (ident in all_idents) {
-            log$info("- {case$group.by}: {ident} ...")
-            ident_markers <- markers[markers[[case$group.by]] == ident, , drop = TRUE]
-            casename <- paste0(name, "::", paste0(case$group.by, ": ", ident))
+            log$info("- {case$group_by}: {ident} ...")
+            ident_markers <- markers[markers[[case$group_by]] == ident, , drop = TRUE]
+            casename <- paste0(name, "::", paste0(case$group_by, ": ", ident))
             info <- case_info(casename, outdir, create = TRUE)
 
-            attr(ident_markers, "ident.1") <- ident
-            process_markers(ident_markers, info = info, case = list(
+            attr(ident_markers, "ident_1") <- ident
+            enrich <- process_markers(ident_markers, info = info, case = list(
                 dbs = dbs,
                 sigmarkers = sigmarkers,
                 enrich_style = enrich_style,
@@ -470,32 +604,39 @@ run_case <- function(name) {
                 error = case$error,
                 ident = NULL
             ))
+            enriches[[ident]] <- enrich
         }
 
         if (length(allmarker_plots) > 0) {
             log$info("- Visualizing all markers together ...")
-            process_allmarkers(markers, allmarker_plots, name, case$group.by)
+            process_allmarkers(markers, allmarker_plots, name, case$group_by)
         }
 
         if (length(overlaps) > 0) {
             log$info("- Visualizing overlaps between subcases ...")
-            process_overlaps(markers, overlaps, name, case$group.by)
+            process_overlaps(markers, overlaps, name, case$group_by)
+        }
+
+        if (length(allenrich_plots) > 0) {
+            log$info("- Visualizing all enrichments together ...")
+            process_allenriches(enriches, allenrich_plots, name, case$group_by)
         }
     } else {
         info <- case_info(name, outdir, create = TRUE)
-        process_markers(markers, info = info, case = list(
+        enrich <- process_markers(markers, info = info, case = list(
             dbs = dbs,
             sigmarkers = sigmarkers,
             enrich_style = enrich_style,
             marker_plots = marker_plots,
             enrich_plots = enrich_plots,
             error = case$error,
-            ident = if (is.null(case$ident.2)) case$ident.1 else paste0(case$ident.1, " vs ", case$ident.2)
+            ident = if (is.null(case$ident_2)) case$ident_1 else paste0(case$ident_1, " vs ", case$ident_2)
         ))
 
-        if (!is.null(original_case)) {
+        if (!is.null(original_case) && !is.null(cases[[original_case]])) {
             markers[[each_name]] <- each
             cases[[original_case]]$markers[[each]] <<- markers
+            cases[[original_case]]$enriches[[each]] <<- enrich
         }
     }