biopipen 0.21.0__py3-none-any.whl → 0.34.26__py3-none-any.whl

biopipen/scripts/scrna/MetaMarkers.R

@@ -1,5 +1,5 @@
-source("{{biopipen_dir}}/utils/misc.R")
-source("{{biopipen_dir}}/utils/mutate_helpers.R")
+{{ biopipen_dir | joinpaths: "utils", "misc.R" | source_r }}
+{{ biopipen_dir | joinpaths: "utils", "mutate_helpers.R" | source_r }}
 
 library(rlang)
 library(dplyr)
@@ -15,13 +15,15 @@ library(tidyseurat)
 
 setEnrichrSite("Enrichr")
 
-srtfile <- {{ in.srtobj | quote }}
-outdir <- {{ out.outdir | quote }}
+srtfile <- {{ in.srtobj | r }}
+outdir <- {{ out.outdir | r }}
+joboutdir <- {{ job.outdir | r }}
 ncores <- {{ envs.ncores | int }}
 mutaters <- {{ envs.mutaters | r }}
 idents <- {{ envs.idents | r }}
 group_by <- {{ envs["group-by"] | r }}
 each <- {{ envs.each | r }}
+subset <- {{ envs.subset | r }}
 prefix_each <- {{ envs.prefix_each | r }}
 p_adjust <- {{ envs.p_adjust | r }}
 section <- {{ envs.section | r }}
@@ -32,65 +34,72 @@ cases <- {{ envs.cases | r: todot = "-" }}
 
 set.seed(8525)
 
-print("- Reading Seurat object ...")
+log_info("- Reading Seurat object ...")
 srtobj <- readRDS(srtfile)
+if (DefaultAssay(srtobj) == "SCT" && !"PrepSCTFindMarkers" %in% names(srtobj@commands)) {
+    log_warn("- SCTransform used but PrepSCTFindMarkers not applied, running ...")
 
-print("- Mutate meta data if needed ...")
+    srtobj <- PrepSCTFindMarkers(srtobj)
+    # compose a new SeuratCommand to record it to srtobj@commands
+    commands <- names(pbmc_small@commands)
+    scommand <- pbmc_small@commands[[commands[length(commands)]]]
+    scommand@name <- "PrepSCTFindMarkers"
+    scommand@time.stamp <- Sys.time()
+    scommand@assay.used <- "SCT"
+    scommand@call.string <- "PrepSCTFindMarkers(object = srtobj)"
+    scommand@params <- list()
+    srtobj@commands$PrepSCTFindMarkers <- scommand
+}
+
+log_info("- Mutate meta data if needed ...")
 if (!is.null(mutaters) && length(mutaters)) {
     srtobj@meta.data <- srtobj@meta.data %>% mutate(!!!lapply(mutaters, parse_expr))
 }
 
-print("- Expanding cases ...")
-if (is.null(cases) || length(cases) == 0) {
-    cases <- list(
-        DEFAULT = list(
-            idents = idents,
-            group_by = group_by,
-            each = each,
-            prefix_each = prefix_each,
-            p_adjust = p_adjust,
-            section = section,
-            dbs = dbs,
-            sigmarkers = sigmarkers,
-            method = method
-        )
-    )
-} else {
-    for (name in names(cases)) {
-        case <- list_setdefault(
-            cases[[name]],
-            idents = idents,
-            group_by = group_by,
-            each = each,
-            prefix_each = prefix_each,
-            p_adjust = p_adjust,
-            section = section,
-            dbs = dbs,
-            sigmarkers = sigmarkers,
-            method = method
-        )
-        cases[[name]] <- case
-    }
-}
+defaults <- list(
+    idents = idents,
+    group_by = group_by,
+    each = each,
+    prefix_each = prefix_each,
+    p_adjust = p_adjust,
+    subset = subset,
+    section = section,
+    dbs = dbs,
+    sigmarkers = sigmarkers,
+    method = method
+)
 
-newcases <- list()
-for (name in names(cases)) {
-    case <- cases[[name]]
-    if (is.null(case$each)) {
-        newcases[[paste0(case$section, ":", name)]] <- case
+expand_each <- function(name, case) {
+    outcases <- list()
+    if (is.null(case$each) || nchar(case$each) == 0) {
+        if (is.null(case$section) || case$section == "DEFAULT") {
+            outcases[[name]] <- case
+        } else {
+            outcases[[paste0(case$section, "::", name)]] <- case
+        }
     } else {
-        eachs <- srtobj@meta.data %>% pull(case$each) %>% unique() %>% na.omit()
+        if (!is.null(case$section) && case$section != "DEFAULT") {
+            log_warn("  Ignoring `section` in case `{name}` when `each` is set.")
+            case$section <- NULL
+        }
+        if (is.null(case$subset)) {
+            eachs <- srtobj@meta.data %>%
+                pull(case$each) %>% unique() %>% na.omit() %>% as.vector()
+        } else {
+            eachs <- srtobj@meta.data %>% filter(!!parse_expr(case$subset)) %>%
+                pull(case$each) %>% unique() %>% na.omit()
+        }
         for (each in eachs) {
-            by = make.names(paste0(".", name, "_", case$each, "_", each))
+            by = make.names(paste0("..", name, "_", case$each, "_", each))
             idents <- case$idents
             if (is.null(idents) || length(idents) == 0) {
-                srtobj@meta.data = srtobj@meta.data %>%
+                srtobj@meta.data <<- srtobj@meta.data %>%
                     mutate(
                         !!sym(by) := if_else(!!sym(case$each) == each, !!sym(case$group_by), NA)
                     )
                 idents <- srtobj@meta.data %>% pull(case$group_by) %>% unique() %>% na.omit()
             } else {
-                srtobj@meta.data = srtobj@meta.data %>%
+                srtobj@meta.data <<- srtobj@meta.data %>%
                     mutate(
                         !!sym(by) := if_else(
                             !!sym(case$each) == each & !!sym(case$group_by) %in% case$idents,
@@ -100,158 +109,253 @@ for (name in names(cases)) {
                     )
             }
 
-            key <- paste0(case$each, ":", each)
-            if (name != "DEFAULT") {
-                key <- paste0(key, " - ", name)
+            if (isTRUE(case$prefix_each)) {
+                key <- paste0(name, "::", case$each, " - ", each)
+            } else {
+                key <- paste0(name, "::", each)
             }
-            newcases[[key]] <- case
-            newcases[[key]]$group_by <- by
-            newcases[[key]]$idents <- idents
+            outcases[[key]] <- case
+            outcases[[key]]$section <- name
+            outcases[[key]]$group_by <- by
         }
     }
+    outcases
 }
-cases <- newcases
 
+log_info("- Expanding cases ...")
+cases <- expand_cases(cases, defaults, expand_each)
 
 # Do enrichment analysis for a case using Enrichr
 # Args:
 #   case: case name
 #   markers: markers dataframe
 #   sig: The expression to filter significant markers
-do_enrich <- function(case, markers, sig) {
-    print(paste("  Running enrichment for case:", case))
-    parts <- strsplit(case, ":")[[1]]
-    sec <- parts[1]
-    case <- paste0(parts[-1], collapse = ":")
-    casedir <- file.path(outdir, sec, case)
-    dir.create(casedir, showWarnings = FALSE, recursive = TRUE)
+do_enrich <- function(info, markers, sig) {
+    log_info("  Running enrichment for case: {info$casename}")
     if (nrow(markers) == 0) {
-        print(paste("  No markers found for case:", case))
-        cat("No markers found.", file = file.path(casedir, "error.txt"))
-        return()
+        msg <- paste0("No markers found for case: ", info$casename)
+        return(msg)
     }
     markers_sig <- markers %>% filter(!!parse_expr(sig))
     if (nrow(markers_sig) == 0) {
-        print(paste("  No significant markers found for case:", case))
-        cat("No significant markers.", file = file.path(casedir, "error.txt"))
-        return()
+        msg <- paste0("No significant markers found for case: ", info$casename)
+        return(msg)
     }
     write.table(
         markers_sig,
-        file.path(casedir, "markers.txt"),
+        file.path(info$casedir, "markers.txt"),
         sep = "\t",
         row.names = FALSE,
         col.names = TRUE,
         quote = FALSE
     )
+
     if (nrow(markers_sig) < 5) {
-        for (db in dbs) {
-            write.table(
-                data.frame(Warning = "Not enough significant markers."),
-                file.path(casedir, paste0("Enrichr-", db, ".txt")),
-                sep = "\t",
-                row.names = FALSE,
-                col.names = TRUE,
-                quote = FALSE
-            )
-            png(
-                file.path(casedir, paste0("Enrichr-", db, ".png")),
-                res = 100, height = 200, width = 1000
-            )
-            print(
-                ggplot() +
-                    annotate(
-                        "text",
-                        x = 1,
-                        y = 1,
-                        label = "Not enough significant markers."
-                    ) +
-                    theme_classic()
-            )
-            dev.off()
-        }
-    } else {
-        enriched <- enrichr(markers_sig$gene, dbs)
-        for (db in dbs) {
-            write.table(
-                enriched[[db]],
-                file.path(casedir, paste0("Enrichr-", db, ".txt")),
-                sep = "\t",
-                row.names = FALSE,
-                col.names = TRUE,
-                quote = FALSE
-            )
-            png(
-                file.path(casedir, paste0("Enrichr-", db, ".png")),
-                res = 100, height = 1000, width = 1000
-            )
-            print(plotEnrich(enriched[[db]], showTerms = 20, title = db))
-            dev.off()
+        msg <- paste0("Too few significant markers found for case: ", info$casename)
+        return(msg)
+    }
+
+    enriched <- enrichr(markers_sig$gene, dbs)
+    for (db in dbs) {
+        write.table(
+            enriched[[db]],
+            file.path(info$casedir, paste0("Enrichr-", db, ".txt")),
+            sep = "\t",
+            row.names = FALSE,
+            col.names = TRUE,
+            quote = FALSE
+        )
+
+        if (nrow(enriched[[db]]) == 0) {
+            log_info(paste0("  No enriched terms for ", db))
+            next
         }
+
+        p <- plotEnrich(enriched[[db]], showTerms = 20, title = db) +
+            theme_prism()
+
+        plotfile <- file.path(info$casedir, paste0("Enrichr-", db, ".png"))
+        png(plotfile, res = 100, height = 600, width = 800)
+        print(p)
+        dev.off()
+
+        plotfile_pdf <- gsub(".png$", ".pdf", plotfile)
+        pdf(plotfile_pdf, height = 6, width = 8)
+        print(p)
+        dev.off()
     }
 }
 
+ensure_sobj <- function(expr, allow_empty) {
+    tryCatch({ expr }, error = function(e) {
+        if (allow_empty) {
+            log_warn("  Ignoring this case: {e$message}")
+            return(NULL)
+        } else {
+            stop(e)
+        }
+    })
+}
 
 do_case <- function(casename) {
-    cat(paste("- Dealing with case:", casename, "...\n"))
+    log_info("- Dealing with case: {casename} ...")
+    info <- casename_info(casename, cases, outdir, create = TRUE)
     case <- cases[[casename]]
-    sobj <- srtobj %>% filter(!is.na(!!sym(case$group_by)))
-    df <- GetAssayData(sobj, slot = "data", assay = "RNA")
-    genes <- rownames(df)
-    # rows: cells, cols: genes
-    df <- cbind(as.data.frame(scale(Matrix::t(df))), sobj@meta.data[, case$group_by])
-    colnames(df)[ncol(df)] <- "GROUP"
+    allow_empty = startsWith(case$group_by, "..")
 
-    cat(paste("  Running tests for case...\n"))
-    test_result <- mclapply(genes, function(gene) {
-        fm <- as.formula(paste(bQuote(gene), "~ GROUP"))
-        res <- tryCatch({
-            if (case$method == "anova") {
-                r <- summary(aov(fm, data = df))[[1]]
-                data.frame(
-                    statistic = r[1, "F value"],
-                    p.value = r[1, "Pr(>F)"],
-                    sumsq = r[1, "Sum Sq"],
-                    meansq = r[1, "Mean Sq"]
-                )
+    if (sum(!is.na(srtobj@meta.data[[case$group_by]])) == 0) {
+        msg = "Not enough cells to run tests."
+    } else {
+        sobj <- ensure_sobj({ srtobj %>% filter(!is.na(!!sym(case$group_by))) }, allow_empty)
+        if (is.null(sobj)) { return() }
+        if (!is.null(case$subset)) {
+            sobj <- ensure_sobj({ sobj %>% filter(!!parse_expr(case$subset)) }, allow_empty)
+            if (is.null(sobj)) { return() }
+        }
+        df <- tryCatch({
+                GetAssayData(sobj, layer = "data")
+            }, error = function(e) {
+                log_warn("  Error when fetching assay data: {e}")
+                NULL
+            })
+        if (is.null(df)) {
+            msg <- "No markers found. May be due to too few cells or features."
+        } else {
+            df <- df[
+                apply(df, 1, function(x) !all(is.na(x)) && !all(x == x[1])), ,
+                drop = FALSE
+            ]
+            genes <- rownames(df)
+            # rows: cells, cols: genes
+            df <- cbind(as.data.frame(scale(Matrix::t(df))), sobj@meta.data[, case$group_by])
+            colnames(df)[ncol(df)] <- "GROUP"
+
+            log_info("  Running tests for case...")
+            warn_count <- 0
+            test_result <- mclapply(genes, function(gene) {
+                fm <- as.formula(paste(bQuote(gene), "~ GROUP"))
+                res <- tryCatch({
+                    if (case$method == "anova") {
+                        r <- summary(aov(fm, data = df))[[1]]
+                        data.frame(
+                            statistic = r[1, "F value"],
+                            p.value = r[1, "Pr(>F)"],
+                            sumsq = r[1, "Sum Sq"],
+                            meansq = r[1, "Mean Sq"]
+                        )
+                    } else {
+                        r <- kruskal.test(fm, data = df)
+                        data.frame(statistic = r$statistic, p.value = r$p.value)
+                    }
+                }, error = function(e) {
+                    warn_count <<- warn_count + 1
+                    if (warn_count < 10) {
+                        log_warn("  Error when testing gene: {gene}")
+                        log_warn("  {e}")
+                    } else if (warn_count == 10) {
+                        log_warn("  Too many errors, will not print more.")
+                    }
+                    NULL
+                })
+                if (is.null(res)) {
+                    return(NULL)
+                }
+                res$gene <- gene
+                res$method <- case$method
+                rownames(res) <- NULL
+                res
+            }, mc.cores = ncores)
+            markers <- do_call(rbind, test_result)
+            if (is.null(markers)) {
+                msg <- "No markers found. May be due to too few cells."
             } else {
-                r <- kruskal.test(fm, data = df)
-                data.frame(statistic = r$statistic, p.value = r$p.value)
+                markers$p_adjust <- p.adjust(markers$p.value, method = case$p_adjust)
+                markers <- markers %>% arrange(p_adjust)
+
+                msg <- do_enrich(info, markers, case$sigmarkers)
             }
-        }, error = function(e) NULL)
-        if (is.null(res)) {
-            return(NULL)
         }
-        res$gene <- gene
-        res$method <- case$method
-        rownames(res) <- NULL
-        res
-    }, mc.cores = ncores)
-    markers <- do_call(rbind, test_result)
-    markers$p_adjust <- p.adjust(markers$p.value, method = case$p_adjust)
-    markers <- markers %>% arrange(p_adjust)
-    do_enrich(casename, markers, case$sigmarkers)
+    }
+    if (is.null(msg)) {
+        log_info("  Plotting top 10 genes ...")
+        markers <- markers %>% head(10)
+        plotdir <- file.path(info$casedir, "expr_plots")
+        dir.create(plotdir, showWarnings = FALSE, recursive = TRUE)
 
-    print(paste("  Plotting top 10 genes ...\n"))
-    markers <- markers %>% head(10)
-    parts <- strsplit(casename, ":")[[1]]
-    sec <- parts[1]
-    casename <- paste0(parts[-1], collapse = ":")
-    plotdir <- file.path(outdir, sec, casename, "plots")
-    dir.create(plotdir, showWarnings = FALSE, recursive = TRUE)
+        # Plot the top 10 genes in each group with violin plots
+        geneplots <- list()
+        for (gene in markers$gene) {
+            outfile <- file.path(plotdir, paste0(slugify(gene), ".png"))
+            p <- ggplot(df, aes_string(x="GROUP", y=bQuote(gene), fill="GROUP")) +
+                geom_violin(alpha = .8) +
+                geom_boxplot(width=0.1, fill="white") +
+                theme_prism() +
+                ylab(paste0("Expression of ", gene))
+            png(outfile, res = 100, height = 600, width = 800)
+            print(p)
+            dev.off()
 
-    # Plot the top 10 genes in each group with violin plots
-    for (gene in markers$gene) {
-        outfile = file.path(plotdir, paste0(gene, ".png"))
-        p = ggplot(df, aes_string(x="GROUP", y=bQuote(gene), fill="GROUP")) +
-            geom_violin(alpha = .8) +
-            geom_boxplot(width=0.1, fill="white") +
-            theme_prism() +
-            ylab(paste0("Expression of ", gene))
-        png(outfile, res = 100, height = 800, width = 1000)
-        print(p)
-        dev.off()
+            outfile_pdf <- gsub(".png$", ".pdf", outfile)
+            pdf(outfile_pdf, height = 6, width = 8)
+            print(p)
+            dev.off()
+
+            geneplots[[length(geneplots) + 1]] <- list(
+                kind = "table_image",
+                src = outfile,
+                download = outfile_pdf,
+                name = gene
+            )
+        }
+
+        add_report(
+            list(
+                kind = "descr",
+                content = paste0(
+                    "Top 100 genes selected by ",
+                    "<code>", case$method, "</code> across ",
+                    "<code>", case$group_by, "</code> and filtered by ",
+                    "<code>", html_escape(case$sigmarkers), "</code>"
+                )
+            ),
+            h1 = info$h1,
+            h2 = ifelse(info$h2 == "#", "Meta-Markers", info$h2),
+            h3 = ifelse(info$h2 == "#", "#", "Meta-Markers")
+        )
+        add_report(
+            list(
+                name = "Meta-Markers",
+                contents = list(list(
+                    kind = "table",
+                    src = file.path(info$casedir, "markers.txt"),
+                    data = list(nrows = 100)
+                ))
+            ),
+            list(
+                name = "Volin Plots (Top 10)",
+                ui = "table_of_images:4",
+                contents = geneplots
+            ),
+            h1 = info$h1,
+            h2 = ifelse(info$h2 == "#", "Meta-Markers", info$h2),
+            h3 = ifelse(info$h2 == "#", "#", "Meta-Markers"),
+            ui = "tabs"
+        )
+        add_report(
+            list(kind = "enrichr", dir = info$casedir),
+            h1 = info$h1,
+            h2 = ifelse(info$h2 == "#", "Enrichment Analysis", info$h2),
+            h3 = ifelse(info$h2 == "#", "#", "Enrichment Analysis")
+        )
+    } else {
+        log_warn("  {msg}")
+        add_report(
+            list(kind = "error", content = msg),
+            h1 = info$h1,
+            h2 = info$h2
+        )
     }
 }
 
 sapply(sort(names(cases)), do_case)
+save_report(joboutdir)

biopipen/scripts/scrna/ModuleScoreCalculator.R

@@ -1,15 +1,19 @@
-source("{{biopipen_dir}}/utils/misc.R")
-library(Seurat)
+library(rlang)
 library(dplyr)
+library(Seurat)
+library(biopipen.utils)
 
 sobjfile <- {{in.srtobj | r}}
 outfile <- {{out.rdsfile | r}}
 defaults <- {{envs.defaults | r}}
 modules <- {{envs.modules | r}}
+post_mutaters <- {{envs.post_mutaters | r}}
+
+log <- get_logger()
 
 # load seurat object
-print("Loading Seurat object ...")
-sobj <- readRDS(sobjfile)
+log$info("Loading Seurat object ...")
+sobj <- read_obj(sobjfile)
 
 aggs <- list(
     mean = mean,
@@ -27,7 +31,6 @@ for (key in names(modules)) {
     }
 
     module <- list_update(defaults, modules[[key]])
-    module$object <- sobj
     if (is.null(module$features) || length(module$features) == 0) {
         stop(paste0("Module '", key, "' has no features"))
     }
@@ -36,21 +39,67 @@ for (key in names(modules)) {
     agg <- aggs[[module$agg]]
     module$keep <- NULL
     module$agg <- NULL
-    print(paste0("Calculating module '", key, "' ..."))
+    log$info("Calculating module '{key}' ...")
     is_cc <- FALSE
-    if (module$features == "cc.genes") {
+    if (!is.null(module$kind) && module$kind %in% c("diffmap", "diffusion_map")) {
+        library(destiny)
+        features <- module$features
+        if (is.null(features)) { features <- 2 }
+        if (is.null(module$verbose)) { module$verbose <- TRUE }
+        module$features <- NULL
+        module$kind <- NULL
+
+        if (!is.null(module$n_pcs)) {
+            log$info("- Using cell embeddings from PCA reduction ...")
+            module$data <- Embeddings(sobj, reduction = "pca")
+            if (module$n_pcs > ncol(module$data)) {
+                log$warn("- `n_pcs` ({module$n_pcs}) is larger than the number of PCs, using all {ncol(module$data)} PCs ...")
+            }
+            module$data <- module$data[, 1:min(module$n_pcs, ncol(module$data))]
+            module$n_pcs <- NULL
+        } else {
+            log$info("- Using assay data ...")
+            module$data <- GetAssayData(sobj, layer = "data")
+        }
+
+        log$info("- Calculating diffusion map ...")
+        dm <- do_call(DiffusionMap, module)
+        ev <- eigenvectors(dm)
+
+        log$info("- Creating DimReduc object ...")
+        sobj[[key]] <- CreateDimReducObject(
+            embeddings = data.matrix(as.data.frame(ev[, 1:features])),
+            key = paste0(key, "_")
+        )
+
+        # add to meta.data
+        log$info("- Adding to meta.data ...")
+        sobj <- AddMetaData(
+            sobj,
+            sobj[[key]]@cell.embeddings,
+            col.name = colnames(sobj[[key]]@cell.embeddings)
+        )
+
+        next
+    }
+
+    module$object <- sobj
+    if (length(module$features) == 1 && module$features == "cc.genes") {
         is_cc <- TRUE
         module$features <- NULL
         module$s.features <- cc.genes$s.genes
         module$g2m.features <- cc.genes$g2m.genes
-    } else if (module$features == "cc.genes.updated.2019") {
+    } else if (length(module$features) == 1 && module$features == "cc.genes.updated.2019") {
         is_cc <- TRUE
         module$features <- NULL
         module$s.features <- cc.genes.updated.2019$s.genes
         module$g2m.features <- cc.genes.updated.2019$g2m.genes
     } else {
         module$name <- key
-        module$features <- trimws(strsplit(module$features, ",")[[1]])
+        if (length(module$features) == 1) {
+            module$features <- trimws(strsplit(module$features, ",")[[1]])
+        }
+        module$features <- list(module$features)
     }
     if (isTRUE(is_cc)) {
         sobj <- do_call(CellCycleScoring, module)
@@ -87,6 +136,12 @@ for (key in names(modules)) {
     }
 }
 
+if (!is.null(post_mutaters) && length(post_mutaters) > 0) {
+    log$info("Applying post mutaters ...")
+    sobj@meta.data <- sobj@meta.data %>%
+        mutate(!!!lapply(post_mutaters, parse_expr))
+}
+
 # save seurat object
-print("Saving Seurat object ...")
-saveRDS(sobj, outfile)
+log$info("Saving Seurat object ...")
+save_obj(sobj, outfile)