biopipen 0.25.4__py3-none-any.whl → 0.26.1__py3-none-any.whl

biopipen/scripts/scrna/SeuratClusterStats-stats.R

@@ -1,4 +1,5 @@
 # Loaded variables: srtfile, outdir, srtobj
+library(circlize)
 
 stats_defaults = {{envs.stats_defaults | r: todot="-"}}
 stats = {{envs.stats | r: todot="-", skip=1}}
@@ -12,6 +13,7 @@ do_one_stats = function(name) {
     case = list_update(stats_defaults, stats[[name]])
     case$devpars = list_update(stats_defaults$devpars, case$devpars)
     case$pie_devpars = list_update(stats_defaults$pie_devpars, case$pie_devpars)
+    case$circos_devpars = list_update(stats_defaults$circos_devpars, case$circos_devpars)
     if (isTRUE(case$pie) && !is.null(case$group.by)) {
         stop(paste0(name, ": pie charts are not supported for group-by"))
     }
@@ -27,6 +29,7 @@ do_one_stats = function(name) {
 
     figfile = file.path(odir, paste0(slugify(name), ".bar.png"))
     piefile = file.path(odir, paste0(slugify(name), ".pie.png"))
+    circosfile = file.path(odir, paste0(slugify(name), ".circos.png"))
     samtablefile = file.path(odir, paste0(slugify(name), ".bysample.txt"))
     tablefile = file.path(odir, paste0(slugify(name), ".txt"))
 
@@ -172,6 +175,40 @@ do_one_stats = function(name) {
             ui = "tabs"
         )
     }
+
+    if (isTRUE(case$circos)) {
+        if (isTRUE(case$transpose)) {
+            circos_df <- plot_df %>%
+                select(from=!!sym(case$ident), to=!!sym(case$group.by), value=.n)
+        } else {
+            circos_df <- plot_df %>%
+                select(from=!!sym(case$group.by), to=!!sym(case$ident), value=.n)
+        }
+
+        png(
+            circosfile,
+            width=case$circos_devpars$width,
+            height=case$circos_devpars$height,
+            res=case$circos_devpars$res
+        )
+        circos.clear()
+        chordDiagram(
+            circos_df,
+            direction = 1,
+            direction.type = c("diffHeight", "arrows"),
+            link.arr.type = "big.arrow"
+        )
+        dev.off()
+
+        add_report(
+            list(
+                name = "Circos plot",
+                contents = list(list(kind = "image", src = circosfile))
+            ),
+            h1 = name,
+            ui = "tabs"
+        )
+    }
 }
 
 sapply(names(stats), do_one_stats)

biopipen/scripts/scrna/TopExpressingGenes.R

@@ -20,6 +20,7 @@ prefix_each <- {{ envs.prefix_each | r }}
 section <- {{ envs.section | r }}
 dbs <- {{ envs.dbs | r }}
 n <- {{ envs.n | r }}
+sset <- {{ envs.subset | r }}
 cases <- {{ envs.cases | r: todot = "-" }}  # nolint
 
 set.seed(8525)
@@ -43,7 +44,8 @@ if (is.null(cases) || length(cases) == 0) {
             prefix_each = prefix_each,
             section = section,
             dbs = dbs,
-            n = n
+            n = n,
+            subset = sset
         )
     )
 } else {
@@ -56,7 +58,8 @@ if (is.null(cases) || length(cases) == 0) {
             prefix_each = prefix_each,
             section = section,
             dbs = dbs,
-            n = n
+            n = n,
+            subset = sset
         )
     })
 }
@@ -144,7 +147,7 @@ casename_info <- function(casename, create = FALSE) {
 }
 
 do_enrich <- function(expr, odir) {
-    log_info("  Saving expressions ...")
+    log_debug("  Saving expressions ...")
     expr <- expr %>% as.data.frame()
     colnames(expr) <- c("Expression")
     expr <- expr %>% rownames_to_column("Gene") %>% select(Gene, Expression)
@@ -165,7 +168,7 @@ do_enrich <- function(expr, odir) {
         quote = FALSE
     )
 
-    log_info("  Running enrichment ...")
+    log_debug("  Running enrichment ...")
     enriched <- enrichr(head(expr$Gene, n), dbs)  # nolint
     for (db in dbs) {
         write.table(
@@ -178,7 +181,7 @@ do_enrich <- function(expr, odir) {
         )
 
         if (nrow(enriched[[db]]) == 0) {
-            log_info(paste0("  No enriched terms for ", db))
+            log_warn(paste0("  No enriched terms for ", db))
             next
         }
 
@@ -199,15 +202,24 @@ do_case <- function(casename) {
     case <- cases[[casename]]
     info <- casename_info(casename, create = TRUE)
 
-    log_info("  Calculating average expression ...")
-    assay <- DefaultAssay(srtobj)
+    log_debug("  Calculating average expression ...")
+    if (!is.null(case$subset)) {
+        tryCatch({
+            sobj <- subset(srtobj, !!parse_expr(case$subset))
+        }, error = function(e) {
+            log_warn("  No cells found for the subset, skipping ...")
+        })
+    } else {
+        sobj <- srtobj
+    }
+    assay <- DefaultAssay(sobj)
     avgexpr <- AverageExpression(
-        srtobj,
+        sobj,
         group.by = case$group.by,
         assays = assay
     )[[assay]]
     # https://github.com/satijalab/seurat/issues/7893
-    colnames(avgexpr) <- as.character(unique(srtobj@meta.data[[case$group.by]]))
+    colnames(avgexpr) <- as.character(unique(sobj@meta.data[[case$group.by]]))
     avgexpr <- avgexpr[, case$ident, drop = FALSE]
     avgexpr <- avgexpr[order(-avgexpr), , drop = FALSE]
 
@@ -217,7 +229,7 @@ do_case <- function(casename) {
 }
 
 add_case_report <- function(info) {
-    log_info("  Adding case report ...")
+    log_debug("  Adding case report ...")
     h1 = ifelse(
         info$section == "DEFAULT",
         info$case,
@@ -237,30 +249,43 @@ add_case_report <- function(info) {
         ifelse(single_section, "#", info$case)
     )
 
-    add_report(
-        list(
-            kind = "descr",
-            content = paste0("Top ", n, " expressing genes")
-        ),
-        list(
-            kind = "table",
-            src = file.path(info$casedir, "exprn.txt")
-        ),
-        h1 = h1,
-        h2 = ifelse(h2 == "#", "Top Expressing Genes", h2),
-        h3 = ifelse(h2 == "#", "#", "Top Expressing Genes")
-    )
+    if (!is.null(info$error)) {
+        add_report(
+            list(
+                kind = "descr",
+                content = paste0("Top ", n, " expressing genes")
+            ),
+            list(kind = "error", content = info$error),
+            h1 = h1,
+            h2 = ifelse(h2 == "#", "Top Expressing Genes", h2),
+            h3 = ifelse(h2 == "#", "#", "Top Expressing Genes")
+        )
+    } else {
+        add_report(
+            list(
+                kind = "descr",
+                content = paste0("Top ", n, " expressing genes")
+            ),
+            list(
+                kind = "table",
+                src = file.path(info$casedir, "exprn.txt")
+            ),
+            h1 = h1,
+            h2 = ifelse(h2 == "#", "Top Expressing Genes", h2),
+            h3 = ifelse(h2 == "#", "#", "Top Expressing Genes")
+        )
 
-    add_report(
-        list(
-            kind = "descr",
-            content = paste0("Enrichment analysis for the top ", n, " expressing genes")
-        ),
-        list(kind = "enrichr", dir = info$casedir),
-        h1 = h1,
-        h2 = ifelse(h2 == "#", "Enrichment Analysis", h2),
-        h3 = ifelse(h2 == "#", "#", "Enrichment Analysis")
-    )
+        add_report(
+            list(
+                kind = "descr",
+                content = paste0("Enrichment analysis for the top ", n, " expressing genes")
+            ),
+            list(kind = "enrichr", dir = info$casedir),
+            h1 = h1,
+            h2 = ifelse(h2 == "#", "Enrichment Analysis", h2),
+            h3 = ifelse(h2 == "#", "#", "Enrichment Analysis")
+        )
+    }
 }
 
 sapply(sort(names(cases)), do_case)

biopipen/scripts/snp/PlinkSimulation.py

@@ -0,0 +1,88 @@
+from pathlib import Path
+from biopipen.utils.misc import logger, run_command, dict_to_cli_args
+
+nsnps = {{in.nsnps | repr}}  # pyright: ignore
+ncases = {{in.ncases | repr}}  # pyright: ignore
+nctrls = {{in.nctrls | repr}}  # pyright: ignore
+outdir = {{out.outdir | repr}}  # pyright: ignore
+gtmatfile = {{out.gtmat | repr}}  # pyright: ignore
+plink = {{envs.plink | repr}}  # pyright: ignore
+seed = {{envs.seed | repr}}  # pyright: ignore
+label = {{envs.label | repr}}  # pyright: ignore
+prevalence = {{envs.prevalence | repr}}  # pyright: ignore
+minfreq = {{envs.minfreq | repr}}  # pyright: ignore
+maxfreq = {{envs.maxfreq | repr}}  # pyright: ignore
+hetodds = {{envs.hetodds | repr}}  # pyright: ignore
+homodds = {{envs.homodds | repr}}  # pyright: ignore
+missing = {{envs.missing | repr}}  # pyright: ignore
+args = {{envs.args | repr}}  # pyright: ignore
+transpose_gtmat = {{envs.transpose_gtmat | repr}}  # pyright: ignore
+sample_prefix = {{envs.sample_prefix | repr}}  # pyright: ignore
+
+logger.info("Generating parameters file")
+params_file = Path(outdir) / "params.txt"
+params_file.write_text(
+    f"{nsnps}\t{label}\t{minfreq}\t{maxfreq}\t{hetodds}\t{homodds}\n"
+)
+
+if seed is not None:
+    args["seed"] = seed
+
+args["simulate"] = params_file
+args["out"] = Path(outdir) / "sim_snps"
+args["simulate-ncases"] = ncases
+args["simulate-ncontrols"] = nctrls
+args["simulate-prevalence"] = prevalence
+args["simulate-missing"] = missing
+
+cmd = [plink] + dict_to_cli_args(args)
+
+logger.info("Running PLINK simulation ...")
+run_command(cmd, fg=True)
+
+# Transpose the genotype matrix
+# CHR	SNP	(C)M	POS	COUNTED	ALT	per0_per0	per1_per1	per2_per2
+# 1	SNP_0	0	1	D	d	1	0	1
+# 1	SNP_1	0	2	d	D	0	1	0
+# 1	SNP_2	0	3	d	D	0	0	0
+# 1	SNP_3	0	4	d	D	0	0	0
+# 1	SNP_4	0	5	D	d	1	2	1
+cmd = [
+    plink,
+    "--recode",
+    "A" if transpose_gtmat else "A-transpose",
+    "tab",
+    "--bfile",
+    args["out"],
+    "--out",
+    gtmatfile + ".plink.recoded",
+]
+logger.info("Recoding into genotype matrix ...")
+run_command(cmd, fg=True)
+
+logger.info("Saving genotype matrix ...")
+## transpose_gtmat = False
+# SNP_COUNTED	per0_per0	per1_per1	per2_per2
+# SNP_0_D	1	0	1
+# SNP_1_d	0	1	0
+# SNP_2_d	0	0	0
+# SNP_3_d	0	0	0
+# SNP_4_D	1	2	1
+## transpose_gtmat = True
+# FID_IID SNP_0_D SNP_1_D SNP_2_D
+# per0_per0 0 1 1
+# per1_per1 0 2 0
+# per2_per2 0 0 0
+# per3_per3 1 1 0
+# per4_per4 0 0 0
+if transpose_gtmat:
+    cmd = f"cut -f1,2,7- {gtmatfile}.plink.recoded.raw | sed 's/\\t/_/'"
+else:
+    cmd = f"cut -f2,5,7- {gtmatfile}.plink.recoded.traw | sed 's/\\t/_/'"
+
+if sample_prefix:
+    cmd = f"{cmd} | sed 's/per[0-9]\\+_per/{sample_prefix}/g'"
+
+cmd = f"{cmd} > {gtmatfile}"
+
+run_command(cmd, fg=True)

biopipen/scripts/stats/ChowTest.R

@@ -0,0 +1,119 @@
+source("{{biopipen_dir}}/utils/misc.R")
+
+library(rlang)
+library(dplyr)
+
+infile <- {{in.infile | r}}
+groupfile <- {{in.groupfile | r}}
+fmlfile <- {{in.fmlfile | r}}
+outfile <- {{out.outfile | r}}
+padj <- {{envs.padj | r}}
+transpose_input <- {{envs.transpose_input | r}}
+transpose_group <- {{envs.transpose_group | r}}
+
+log_info("Reading input files ...")
+indata <- read.table(infile, header = TRUE, sep = "\t", row.names = 1)
+if (transpose_input) {
+	indata <- t(indata)
+}
+groupdata <- read.table(groupfile, header = TRUE, sep = "\t", row.names = 1)
+if (transpose_group) {
+	groupdata <- t(groupdata)
+}
+fmldata <- read.table(fmlfile, header = TRUE, sep = "\t", row.names = NULL)
+colnames(fmldata)[1:2] <- c("Group", "Formula")
+
+chow.test <- function(fml, grouping) {
+    formula <- as.formula(fml)
+    pooled_lm <- tryCatch(lm(formula, data = indata), error = function(e) NULL)
+    if (is.null(pooled_lm)) {
+        return(list(
+            pooled.lm  = NA,
+            group.lms  = NULL,
+            Fstat      = NA,
+            group      = grouping,
+            pooled.ssr = NA,
+            group.ssr  = NA,
+            Pval       = NA
+        ))
+    }
+
+    splitdata <- split(indata, groupdata[rownames(indata), grouping])
+    group_lms <- lapply(names(splitdata), function(g) {
+        tryCatch(lm(formula, data = splitdata[[g]]), error = function(e) NULL)
+    })
+	names(group_lms) <- names(splitdata)
+
+    fmvars     <- all.vars(formula)
+	pooled.ssr <- sum(pooled_lm$residuals ^ 2)
+	subssr     <- ifelse(any(is.null(group_lms)), NA, sum(sapply(group_lms, function(x) sum(x$residuals ^ 2))))
+	ngroups    <- length(splitdata)
+	K          <- ifelse(fmvars[2] == ".", ncol(indata), length(fmvars))
+	J          <- (ngroups - 1) * K
+	DF         <- nrow(indata) - ngroups * K
+	FS         <- (pooled.ssr - subssr) * DF / subssr / J
+	list(
+		pooled.lm  = pooled_lm,
+		group.lms  = group_lms,
+		Fstat      = FS,
+		group      = grouping,
+		pooled.ssr = pooled.ssr,
+		group.ssr  = subssr,
+		Pval       = pf(FS, J, DF, lower.tail = FALSE)
+	)
+}
+
+formatlm <- function(m) {
+	if (class(m) == 'lm') {
+		coeff <- as.list(m$coefficients)
+		vars <- all.vars(m$terms)
+		terms <- unlist(sapply(na.omit(c(vars[2:length(vars)], '(Intercept)', 'N')), function(x) {
+			ce <- coeff[[x]] %||% coeff[[bQuote(x)]]
+			if (x == 'N') {
+				paste0('N=', nrow(m$model))
+			} else if (is.null(ce)) {
+				NULL
+			} else {
+				l <- ifelse(x == '(Intercept)', '_', x)
+				paste0(l, '=', round(ce, 3))
+			}
+		}))
+		paste(terms[!is.null(terms)], collapse = ', ')
+	} else {
+		paste(sapply(names(m), function(x) {
+			paste0(x, ': ', formatlm(m[[x]]))
+		}), collapse = ' // ')
+	}
+}
+
+log_info("Running Chow tests ...")
+ncases <- nrow(fmldata)
+results <- do_call(rbind, lapply(
+    seq_len(ncases),
+    function(i) {
+		fmlrow <- fmldata[i, , drop=TRUE]
+        if (i %% 100 == 0) {
+            log_info("- {i} / {ncases} ...")
+        }
+        log_debug("  Running Chow test for formula: {fmlrow$Formula} (grouping = {fmlrow$Group})")
+
+        res <- chow.test(fmlrow$Formula, fmlrow$Group)
+		fmlrow$Pooled <- formatlm(res$pooled.lm)
+		fmlrow$Groups <- formatlm(res$group.lms)
+		fmlrow$SSR <- res$group.ssr
+		fmlrow$SumSSR <- res$pooled.ssr
+		fmlrow$Fstat <- res$Fstat
+		fmlrow$Pval <- res$Pval
+		fmlrow
+    }
+)) %>% as.data.frame()
+
+if (padj != "none") {
+    log_info("Adjusting p-values ...")
+    results$Padj <- p.adjust(results$Pval, method = padj)
+}
+
+log_info("Writing output ...")
+# unimplemented type 'list' in 'EncodeElement'
+results <- apply(results, 2, as.character)
+write.table(results, file = outfile, sep = "\t", quote = FALSE, row.names = FALSE)

biopipen/scripts/stats/DiffCoexpr.R

@@ -0,0 +1,150 @@
+source("{{biopipen_dir}}/utils/misc.R")
+library(dcanr)
+library(scuttle)
+library(doRNG)
+library(doParallel)
+library(snpStats)
+library(rlang)
+library(dplyr)
+
+infile <- {{in.infile | r}}
+groupfile <- {{in.groupfile | r}}
+outfile <- {{out.outfile | r}}
+method <- {{envs.method | r}}
+beta <- {{envs.beta | r}}
+padj <- {{envs.padj | r}}
+perm_batch <- {{envs.perm_batch | r}}
+seed <- {{envs.seed | r}}
+ncores <- {{envs.ncores | r}}
+transpose_input <- {{envs.transpose_input | r}}
+transpose_group <- {{envs.transpose_group | r}}
+
+log_info("Setting seed and parallel backend ...")
+set.seed(seed)
+registerDoParallel(cores = ncores)
+registerDoRNG(seed)
+
+log_info("Reading input files ...")
+indata <- read.table(infile, header = TRUE, row.names = 1, sep = "\t", check.names = FALSE)
+if (transpose_input) {
+    indata <- t(indata)
+}
+gdata <- read.table(groupfile, header = TRUE, row.names = 1, sep = "\t", check.names = FALSE)
+if (transpose_group) {
+    gdata <- t(gdata)
+}
+ngroups <- ncol(gdata)
+
+sign2 <- function(x) sign(x) * x^2
+mat2vec <- dcanr:::mat2vec
+
+diffcoex_score <- function(group) {
+
+    gvals <- unique(gdata[, group, drop = TRUE])
+    if (length(gvals) < 2) {
+        log_warn("  Less than 2 groups in the input. Skipping ...")
+        return(NULL)
+    }
+    rs <- lapply(gvals, function(gval) {
+        samples <- rownames(gdata[gdata[[group]] == gval, , drop = FALSE])
+        expr <- indata[samples, , drop = FALSE]
+        if (length(samples) < 3) {
+            log_warn("  Less than 3 samples in one of the groups. Skipping ...")
+            return(NULL)
+        }
+        cor.pairs(as.matrix(expr), cor.method = method)
+    })
+    rs[sapply(rs, is.null)] <- NULL
+    if (length(rs) < 2) {
+        log_warn("  Less than 2 groups with at least 3 samples. Skipping ...")
+        return(NULL)
+    }
+    N <- length(rs)
+    C0 <- lapply(rs, sign2)
+    C0 <- Reduce(`+`, C0) / N
+    D <- lapply(rs, function(r) abs(sign2(r) - C0))
+    D <- Reduce(`+`, D) / 2 / (N - 1)
+    D <- sqrt(D)
+    D <- D^beta
+    T_ovlap <- D %*% D + ncol(D) * D  #calc topological ovlap
+
+    mins = matrix(rep(rowSums(D), ncol(D)), nrow = ncol(D))
+    mins = pmin(mins, matrix(rep(colSums(D), each = ncol(D)), nrow = ncol(D)))
+    T_ovlap = 1 - (T_ovlap/(mins + 1 - D))
+
+    diag(T_ovlap) = 1
+
+    #add run parameters as attributes
+    attributes(T_ovlap) = c(
+        attributes(T_ovlap),
+        'method' = method,
+        'beta' = beta,
+        'call' = match.call()
+    )
+
+    return(1 - T_ovlap)
+}
+
+
+perm_test <- function(dcscores, group, B = perm_batch) {
+    obs = mat2vec(dcscores)
+
+    #package requirements
+    pckgs = c('dcanr')
+
+    #perform permutation
+    pvals = foreach(
+        b = seq_len(B),
+        .combine = function(...) {mapply(sum, ...)},
+        .multicombine = TRUE,
+        .inorder = FALSE,
+        .packages = pckgs
+    ) %dorng% {
+        #shuffle condition and recalculate scores
+        env = new.env()
+        assign('group', group, envir = env)
+        permsc = eval(attr(dcscores, 'call'), envir = env)
+        permsc = mat2vec(permsc)
+
+        #count elements greater than obs
+        permsc = abs(permsc)
+        permsc = permsc[!(is.na(permsc) || is.infinite(permsc))]
+        permcounts = vapply(abs(obs), function(x) sum(permsc > x), 0)
+        return(c(permcounts, length(permsc)))
+    }
+
+    #p-values
+    N <- pvals[length(pvals)]
+    pvals <- pvals[-(length(pvals))] / N
+    # attributes(pvals) = attributes(obs)
+    # pvals = dcanr:::vec2mat(pvals)
+    # attr(pvals, 'dc.test') = 'permutation'
+    # return(pvals)
+    # Format into Group,Feature1,Feature2,Pval
+    feature_pairs <- as.data.frame(t(combn(attr(obs, 'feature.names'), 2)))
+    colnames(feature_pairs) <- c('Feature1', 'Feature2')
+    feature_pairs$Group <- group
+    feature_pairs$Pval <- pvals
+    feature_pairs[, c('Group', 'Feature1', 'Feature2', 'Pval'), drop = FALSE]
+}
+
+do_one_group <- function(i) {
+    group <- colnames(gdata)[i]
+    log_info("- Processing group {i}/{ngroups}: {group} ...")
+    log_info("  Calculating differential co-expression scores ...")
+    dcscores <- diffcoex_score(group)
+
+    if (!is.null(dcscores)) {
+        log_info("  Calculating p-values ...")
+        perm_test(dcscores, group)
+    }
+}
+
+trios <- do_call(rbind, lapply(seq_len(ngroups), do_one_group))
+if (padj != "none") {
+    log_info("Correcting p-values ...")
+    trios$Padj <- p.adjust(trios$Pval, method = padj)
+}
+
+log_info("Writing output ...")
+write.table(trios, file = outfile, sep = "\t", quote = FALSE, row.names = FALSE)