diff --git a/R/SCP-analysis.R b/R/SCP-analysis.R index 7150d39c..dc7bfc23 100644 --- a/R/SCP-analysis.R +++ b/R/SCP-analysis.R @@ -3996,6 +3996,8 @@ RunEnrichment <- function(srt = NULL, group_by = NULL, test.use = "wilcox", DE_t results <- results[!sapply(results, is.null)] results <- results[intersect(c(nm, paste0(nm, "_sim")), names(results))] enrichment <- do.call(rbind, lapply(results, function(x) x@result)) + enrichment[["Groups"]] <- factor(enrichment[["Groups"]], levels = levels(geneID_groups)) + enrichment[["Database"]] <- factor(enrichment[["Database"]], levels = unique(db)) rownames(enrichment) <- NULL time_end <- Sys.time() @@ -4293,6 +4295,8 @@ RunGSEA <- function(srt = NULL, group_by = NULL, test.use = "wilcox", DE_thresho results <- results[!sapply(results, is.null)] results <- results[intersect(c(nm, paste0(nm, "_sim")), names(results))] enrichment <- do.call(rbind, lapply(results, function(x) x@result)) + enrichment[["Groups"]] <- factor(enrichment[["Groups"]], levels = levels(geneID_groups)) + enrichment[["Database"]] <- factor(enrichment[["Database"]], levels = unique(db)) rownames(enrichment) <- NULL time_end <- Sys.time() diff --git a/R/SCP-app.R b/R/SCP-app.R index e8f165e8..ef92ec2a 100644 --- a/R/SCP-app.R +++ b/R/SCP-app.R @@ -595,7 +595,7 @@ RunSCExplorer <- function(base_dir = "SCExplorer", initial_raster = NULL, session_workers = 2, plotting_workers = 8, - create_script = FALSE, + create_script = TRUE, style_script = require("styler", quietly = TRUE), overwrite = FALSE) { check_R(c("rhdf5", "HDF5Array", "shiny@1.6.0", "ggplot2", "ragg", "htmlwidgets", "plotly", "bslib", "future", "promises", "BiocParallel")) diff --git a/R/SCP-plot.R b/R/SCP-plot.R index 57eb7c88..448c5faa 100644 --- a/R/SCP-plot.R +++ b/R/SCP-plot.R @@ -3547,8 +3547,8 @@ FeatureStatPlot <- function(srt, stat.by, group.by = NULL, split.by = NULL, bg.b calculate_coexp = FALSE, range = c(-Inf, Inf), same.y.lims = FALSE, y.min = NULL, y.max = NULL, y.trans = "identity", y.nbreaks = 5, sort = FALSE, stack = FALSE, flip = FALSE, - comparisons = NULL, ref_group = NULL, pairwise_method = "wilcox.test", - multiplegroup_comparisons = FALSE, multiple_method = "kruskal.test", + comparisons = NULL, ref_group = NULL, pairwise_method = "wilcox.test", pairwise_method_args = list(), + multiplegroup_comparisons = FALSE, multiple_method = "kruskal.test", multiple_method_args = list(), sig_label = c("p.signif", "p.format"), sig_labelsize = 3.5, aspect.ratio = NULL, title = NULL, subtitle = NULL, xlab = NULL, ylab = "Expression", legend.position = "right", legend.direction = "vertical", @@ -3601,8 +3601,8 @@ FeatureStatPlot <- function(srt, stat.by, group.by = NULL, split.by = NULL, bg.b calculate_coexp = calculate_coexp, range = range, same.y.lims = same.y.lims, y.min = y.min, y.max = y.max, y.trans = y.trans, y.nbreaks = y.nbreaks, sort = sort, stack = stack, flip = flip, - comparisons = comparisons, ref_group = ref_group, pairwise_method = pairwise_method, - multiplegroup_comparisons = multiplegroup_comparisons, multiple_method = multiple_method, + comparisons = comparisons, ref_group = ref_group, pairwise_method = pairwise_method, pairwise_method_args = pairwise_method_args, + multiplegroup_comparisons = multiplegroup_comparisons, multiple_method = multiple_method, multiple_method_args = multiple_method_args, sig_label = sig_label, sig_labelsize = sig_labelsize, aspect.ratio = aspect.ratio, title = title, subtitle = subtitle, xlab = xlab, ylab = ylab, legend.position = legend.position, legend.direction = legend.direction, @@ -3629,8 +3629,8 @@ FeatureStatPlot <- function(srt, stat.by, group.by = NULL, split.by = NULL, bg.b calculate_coexp = calculate_coexp, range = range, same.y.lims = same.y.lims, y.min = y.min, y.max = y.max, y.trans = y.trans, y.nbreaks = y.nbreaks, sort = sort, stack = stack, flip = flip, - comparisons = comparisons, ref_group = ref_group, pairwise_method = pairwise_method, - multiplegroup_comparisons = multiplegroup_comparisons, multiple_method = multiple_method, + comparisons = comparisons, ref_group = ref_group, pairwise_method = pairwise_method, pairwise_method_args = pairwise_method_args, + multiplegroup_comparisons = multiplegroup_comparisons, multiple_method = multiple_method, multiple_method_args = multiple_method_args, sig_label = sig_label, sig_labelsize = sig_labelsize, aspect.ratio = aspect.ratio, title = title, subtitle = subtitle, xlab = xlab, ylab = ylab, legend.position = legend.position, legend.direction = legend.direction, @@ -3753,8 +3753,8 @@ ExpressionStatPlot <- function(exp.data, meta.data, stat.by, group.by = NULL, sp calculate_coexp = FALSE, range = c(-Inf, Inf), same.y.lims = FALSE, y.min = NULL, y.max = NULL, y.trans = "identity", y.nbreaks = 5, sort = FALSE, stack = FALSE, flip = FALSE, - comparisons = NULL, ref_group = NULL, pairwise_method = "wilcox.test", - multiplegroup_comparisons = FALSE, multiple_method = "kruskal.test", + comparisons = NULL, ref_group = NULL, pairwise_method = "wilcox.test", pairwise_method_args = list(), + multiplegroup_comparisons = FALSE, multiple_method = "kruskal.test", multiple_method_args = list(), sig_label = c("p.signif", "p.format"), sig_labelsize = 3.5, aspect.ratio = NULL, title = NULL, subtitle = NULL, xlab = NULL, ylab = "Expression", legend.position = "right", legend.direction = "vertical", @@ -4218,6 +4218,7 @@ ExpressionStatPlot <- function(exp.data, meta.data, stat.by, group.by = NULL, sp border_layer <- geom_vline(xintercept = border_data[["xintercept"]], linetype = 2, alpha = 0.5) p <- p + border_layer } + y_min_use <- layer_scales(p)$y$range$range[1] } if (length(comparisons) > 0) { @@ -4226,8 +4227,10 @@ ExpressionStatPlot <- function(exp.data, meta.data, stat.by, group.by = NULL, sp if (any(rowSums(table(dat[["group.by"]], dat[["split.by"]]) >= 2) >= 3)) { message("Detected more than 2 groups. Use multiple_method for comparison") method <- multiple_method + method_args <- multiple_method_args } else { method <- pairwise_method + method_args <- pairwise_method_args } p <- p + ggpubr::stat_compare_means( data = dat[dat[["group.by"]] %in% group_use, , drop = FALSE], @@ -4238,9 +4241,9 @@ ExpressionStatPlot <- function(exp.data, meta.data, stat.by, group.by = NULL, sp step.increase = 0.1, tip.length = 0.03, vjust = 1, - method = method + method = method, + method.args = method_args, ) - y_max_use <- layer_scales(p)$y$range$range[2] } else { p <- p + ggpubr::stat_compare_means( @@ -4253,7 +4256,8 @@ ExpressionStatPlot <- function(exp.data, meta.data, stat.by, group.by = NULL, sp vjust = 0, comparisons = comparisons, ref.group = ref_group, - method = pairwise_method + method = pairwise_method, + method.args = pairwise_method_args, ) y_max_use <- layer_scales(p)$y$range$range[1] + (layer_scales(p)$y$range$range[2] - layer_scales(p)$y$range$range[1]) * 1.15 } @@ -4261,12 +4265,13 @@ ExpressionStatPlot <- function(exp.data, meta.data, stat.by, group.by = NULL, sp if (isTRUE(multiplegroup_comparisons)) { p <- p + ggpubr::stat_compare_means( aes(x = .data[["group.by"]], y = .data[["value"]], group = .data[["group.unique"]]), - method = multiple_method, label = sig_label, label.y = y_max_use, size = sig_labelsize, vjust = 1.2, - hjust = 0 + hjust = 0, + method = multiple_method, + method.args = multiple_method_args ) y_max_use <- layer_scales(p)$y$range$range[1] + (layer_scales(p)$y$range$range[2] - layer_scales(p)$y$range$range[1]) * 1.15 } @@ -4416,8 +4421,9 @@ ExpressionStatPlot <- function(exp.data, meta.data, stat.by, group.by = NULL, sp } if (isTRUE(stack)) { + digits <- max(gregexpr("\\.0+", as.character(y_max_use - y_min_use))[[1]][1], 1) p <- p + scale_y_continuous( - trans = y.trans, breaks = c(y_min_use, y_max_use), labels = c(round(y_min_use, 1), round(y_max_use, 1)) + trans = y.trans, breaks = c(y_min_use, y_max_use), labels = c(round(y_min_use, digits), round(y_max_use, digits)) ) } else { p <- p + scale_y_continuous(trans = y.trans, n.breaks = y.nbreaks) @@ -4444,6 +4450,7 @@ ExpressionStatPlot <- function(exp.data, meta.data, stat.by, group.by = NULL, sp ) } # plist[[paste0(f, ":", g, ":", paste0(single_group, collapse = ","), ":", paste0(sp, collapse = ","))]] <- p + return(p) }) return(plist) @@ -9363,9 +9370,8 @@ FeatureHeatmap <- function(srt, features = NULL, cells = NULL, group.by = NULL, cell_groups[[cell_group]] <- unlist(lapply(levels(srt@meta.data[[cell_group]]), function(x) { cells_sub <- colnames(srt@assays[[1]])[which(srt@meta.data[[cell_group]] == x)] cells_sub <- intersect(cells, cells_sub) - size <- ifelse(length(cells_sub) > max_cells, max_cells, length(cells_sub)) - cells_sample <- sample(cells_sub, size) - out <- setNames(rep(x, size), cells_sample) + cells_sample <- if (length(cells_sub) > max_cells) sample(cells_sub, max_cells) else cells_sub + out <- setNames(rep(x, length(cells_sample)), cells_sample) return(out) }), use.names = TRUE) levels <- levels(srt@meta.data[[cell_group]]) @@ -9380,9 +9386,8 @@ FeatureHeatmap <- function(srt, features = NULL, cells = NULL, group.by = NULL, cells_tmp <- NULL for (sp in levels(srt@meta.data[[split.by]])) { cells_sp <- cells_sub[srt@meta.data[cells_sub, split.by] == sp] - size <- ifelse(length(cells_sp) > max_cells, max_cells, length(cells_sp)) - cells_sample <- sample(cells_sp, size) - cells_tmp <- c(cells_tmp, setNames(rep(paste0(x, " : ", sp), size), cells_sample)) + cells_sample <- if (length(cells_sp) > max_cells) sample(cells_sp, max_cells) else cells_sp + cells_tmp <- c(cells_tmp, setNames(rep(paste0(x, " : ", sp), length(cells_sample)), cells_sample)) } size <- ifelse(length(cells_tmp) > max_cells, max_cells, length(cells_tmp)) out <- sample(cells_tmp, size) diff --git a/man/FeatureStatPlot.Rd b/man/FeatureStatPlot.Rd index 6fa4fcd9..a2f4a835 100644 --- a/man/FeatureStatPlot.Rd +++ b/man/FeatureStatPlot.Rd @@ -65,8 +65,10 @@ FeatureStatPlot( comparisons = NULL, ref_group = NULL, pairwise_method = "wilcox.test", + pairwise_method_args = list(), multiplegroup_comparisons = FALSE, multiple_method = "kruskal.test", + multiple_method_args = list(), sig_label = c("p.signif", "p.format"), sig_labelsize = 3.5, aspect.ratio = NULL, diff --git a/man/MergeRows.Rd b/man/MergeRows.Rd index af9d83ea..a7acbda5 100644 --- a/man/MergeRows.Rd +++ b/man/MergeRows.Rd @@ -14,3 +14,34 @@ MergeRows(x, groupings) \description{ MergeRows is a function that sum the values of rows based on specified groupings. } +\examples{ +library(Matrix) +ncells <- 3000 +nfeatures <- 1000 +expressed <- 500 +n <- ncells * expressed +dimnames <- list(paste0("feature", seq_len(nfeatures)), paste0("cell", seq_len(ncells))) + +sparse <- sparseMatrix( + i = sample(seq_len(nfeatures), size = n, replace = TRUE), + j = sample(seq_len(ncells), size = n, replace = TRUE), + x = sample(1:10, size = n, replace = TRUE), + dimnames = dimnames +) +dup_index <- sample(seq_len(nfeatures), size = 50) +rownames(sparse)[dup_index] <- paste0("duplicated", 1:10) +table(rownames(sparse)[dup_index]) + +dense <- matrix( + data = sample(1:10, size = nfeatures * ncells, replace = TRUE), + nrow = nfeatures, ncol = ncells, + dimnames = dimnames +) +dup_index <- sample(seq_len(nfeatures), size = 50) +rownames(dense)[dup_index] <- paste0("duplicated", 1:10) +table(rownames(dense)[dup_index]) + +system.time(MergeRows(dense, rownames(dense))) +system.time(MergeRows(sparse, rownames(sparse))) +system.time(aggregate(dense, by = list(rownames(dense)), FUN = sum)) +}