From 6e64612aad3192f48b9878e6ac4815213f6b19ca Mon Sep 17 00:00:00 2001 From: Zewen Kelvin Tuong Date: Fri, 6 Dec 2024 15:26:57 +1000 Subject: [PATCH] Update workflow and formatting (#121) * update description * ok let's go * test windows too * Update r.yml * Update r.yml * Update r.yml * Update r.yml --- .github/workflows/r.yml | 81 +- .github/workflows/vignette.yml | 37 +- DESCRIPTION | 7 +- R/combine_cpdb.R | 20 +- R/correlationSpot.R | 15 +- R/data.R | 2 +- R/geneDotPlot.R | 290 ++++-- R/init_ktplots.R | 6 +- R/ktplots.R | 2 +- R/misc.R | 67 +- R/plot_cpdb.R | 1444 +++++++++++++-------------- R/plot_cpdb2.R | 144 +-- R/plot_cpdb3.R | 133 ++- R/plot_cpdb4.R | 121 ++- R/plot_cpdb_heatmap.R | 170 ++-- man/combine_cpdb.Rd | 7 - man/geneDotPlot.Rd | 2 +- man/plot_cpdb.Rd | 3 + man/plot_cpdb_heatmap.Rd | 3 + tests/testthat/test_dotplot.R | 50 +- tests/testthat/test_miscellaneous.R | 2 +- vignettes/vignette.rmd | 107 +- vignettes/vignette_v5.rmd | 196 ++-- 23 files changed, 1537 insertions(+), 1372 deletions(-) diff --git a/.github/workflows/r.yml b/.github/workflows/r.yml index 0c620531..3a714edb 100644 --- a/.github/workflows/r.yml +++ b/.github/workflows/r.yml @@ -7,10 +7,6 @@ on: push: branches: - "master" - - "*" - -env: - cache-version: "cache-v1" jobs: build: @@ -18,76 +14,43 @@ jobs: max-parallel: 5 matrix: config: - - { r-version: release, os: ubuntu-latest } - - { r-version: release, os: macos-latest } + - { os: ubuntu-latest } + - { os: windows-latest } + - { os: macos-latest } runs-on: ${{ matrix.config.os }} env: - R_REMOTES_NO_ERRORS_FROM_WARNINGS: true - NOT_CRAN: true - TZ: UTC - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes steps: - - uses: actions/checkout@v2 - - uses: actions/setup-node@v2 + - uses: actions/checkout@v4 - - name: Install ubuntu system dependencies - if: matrix.config.os == 'ubuntu-latest' - run: | - sudo apt-get install git libcurl4-openssl-dev libssl-dev libicu-dev libxml2-dev make pandoc libgit2-dev libharfbuzz-dev libfribidi-dev libglpk-dev - - name: Install macOS system dependencies - if: matrix.config.os == 'macos-latest' - run: | - brew install cairo pkg-config autoconf automake libtool - - - name: Set up R - uses: r-lib/actions/setup-r@v2 + - uses: r-lib/actions/setup-r@v2 + id: install-r with: - r-version: ${{ matrix.config.r-version}} - - - name: Setup r-lib/remotes - run: | - install.packages(c("remotes", "devtools")) - shell: Rscript {0} + use-public-rspm: true - - id: bioc - name: Check bioc version - run: | - echo "##[set-output name=mainbiocversion;]$(Rscript -e 'cat(unlist(tools:::.BioC_version_associated_with_R_version()))' | awk '{print $1}')" - echo "##[set-output name=subbiocversion;]$(Rscript -e 'cat(unlist(tools:::.BioC_version_associated_with_R_version()))' | awk '{print $2}')" - echo "##[set-output name=biocversion;]$(Rscript -e 'cat(as.character(tools:::.BioC_version_associated_with_R_version()))' | awk '{print $1}')" - shell: bash -l {0} + - uses: r-lib/actions/setup-pandoc@v2 - - name: Cache ubuntu R packages - if: "!contains(github.event.head_commit.message, '/nocache') && matrix.config.os == 'ubuntu-latest'" - uses: actions/cache@v2 + - name: Cache R packages + uses: actions/cache@v4 with: path: /home/runner/work/_temp/Library - key: ${{ env.cache-version }}-${{ matrix.config.os }}-biocversion-RELEASE_${{ steps.bioc.outputs.mainbiocversion}}_${{ steps.bioc.outputs.subbiocversion}}-r-${{ matrix.config.r-version}}-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ env.cache-version }}-${{ matrix.config.os }}-biocversion-RELEASE_${{ steps.bioc.outputs.mainbiocversion}}_${{ steps.bioc.outputs.subbiocversion}}-r-${{ matrix.config.r-version}}- + key: ${{ runner.OS }}-R-${{ steps.install-r.outputs.installed-r-version }}-cache-${{ hashFiles('.github/depends.Rds') }} + restore-keys: | + ${{ runner.OS }}-R-${{ steps.install-r.outputs.installed-r-version }}-cache- - - name: Cache macOS R packages - if: "!contains(github.event.head_commit.message, '/nocache') && matrix.config.os != 'ubuntu-latest'" - uses: actions/cache@v2 + - name: Install and check + uses: r-lib/actions/setup-r-dependencies@v2 with: - path: ${{ env.R_LIBS_USER }} - key: ${{ env.cache-version }}-${{ matrix.config.os }}-biocversion-RELEASE_${{ steps.bioc.outputs.mainbiocversion}}_${{ steps.bioc.outputs.subbiocversion}}-r-${{ matrix.config.r-version}}-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ env.cache-version }}-${{ matrix.config.os }}-biocversion-RELEASE_${{ steps.bioc.outputs.mainbiocversion}}_${{ steps.bioc.outputs.subbiocversion}}-r-${{ matrix.config.r-version}}- - - - name: Install dependencies - run: | - install.packages(c("rcmdcheck", "covr")) - remotes::install_deps(dependencies = TRUE) - shell: Rscript {0} - - - name: Check - run: | - Rscript -e 'rcmdcheck::rcmdcheck(args = "--no-manual", error_on = "error")' - shell: bash -l {0} + extra-packages: | + any::rcmdcheck + covr + pkgdown + needs: check - name: Test coverage - if: github.actor == 'zktuong' + if: github.actor == 'zktuong' && matrix.config.os == 'ubuntu-latest' run: | Rscript -e 'covr::codecov(token = "${{ secrets.CODECOV_TOKEN }}")' shell: bash -l {0} diff --git a/.github/workflows/vignette.yml b/.github/workflows/vignette.yml index b2c463f2..1ef83455 100644 --- a/.github/workflows/vignette.yml +++ b/.github/workflows/vignette.yml @@ -21,41 +21,26 @@ jobs: env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-r@v2 id: install-r + with: + use-public-rspm: true - uses: r-lib/actions/setup-pandoc@v2 - - id: bioc - name: Check bioc version - run: | - echo "##[set-output name=mainbiocversion;]$(Rscript -e 'cat(unlist(tools:::.BioC_version_associated_with_R_version()))' | awk '{print $1}')" - echo "##[set-output name=subbiocversion;]$(Rscript -e 'cat(unlist(tools:::.BioC_version_associated_with_R_version()))' | awk '{print $2}')" - echo "##[set-output name=biocversion;]$(Rscript -e 'cat(as.character(tools:::.BioC_version_associated_with_R_version()))' | awk '{print $1}')" - shell: bash -l {0} - - - name: Install pak and query dependencies - run: | - install.packages("pak", repos = "https://r-lib.github.io/p/pak/dev/") - saveRDS(pak::pkg_deps("local::.", dependencies = TRUE), ".github/r-depends.rds") - shell: Rscript {0} - - name: Cache R packages - uses: actions/cache@v2 + uses: actions/cache@v4 with: - path: | - ${{ env.R_LIBS_USER }} - !${{ env.R_LIBS_USER }}/pak - key: ${{ env.cache-version }}-${{ matrix.config.os }}-biocversion-RELEASE_${{ steps.bioc.outputs.mainbiocversion}}_${{ steps.bioc.outputs.subbiocversion}}-r-${{ matrix.config.r-version}}-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ env.cache-version }}-${{ matrix.config.os }}-biocversion-RELEASE_${{ steps.bioc.outputs.mainbiocversion}}_${{ steps.bioc.outputs.subbiocversion}}-r-${{ matrix.config.r-version}}- + path: /home/runner/work/_temp/Library + key: ${{ runner.OS }}-R-${{ steps.install-r.outputs.installed-r-version }}-cache-${{ hashFiles('.github/depends.Rds') }} + restore-keys: | + ${{ runner.OS }}-R-${{ steps.install-r.outputs.installed-r-version }}-cache- - - name: Install dependencies - run: | - pak::local_install_dev_deps(upgrade = TRUE, dependencies = c("all", "Config/Needs/website")) - pak::pkg_install("pkgdown") - shell: Rscript {0} + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: pkgdown - name: Install package run: R CMD INSTALL . diff --git a/DESCRIPTION b/DESCRIPTION index 15a0aebd..617a2d66 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -27,9 +27,10 @@ Suggests: scater, testthat, covr, - plyr -LazyData: true -RoxygenNote: 7.2.3 + plyr, + styler +LazyData: false +RoxygenNote: 7.3.2 Collate: 'combine_cpdb.R' 'correlationSpot.R' diff --git a/R/combine_cpdb.R b/R/combine_cpdb.R index 1116bdc0..958c5120 100644 --- a/R/combine_cpdb.R +++ b/R/combine_cpdb.R @@ -4,20 +4,18 @@ #' @return combine results from multiple cellphonedb runs. #' @import dplyr #' @import purrr -#' @examples -#' \donttest{ -#' combine_cpdb(means, means2, means3) -#' combine_cpdb(pvals, pvals2, pvals3) -#' combine_cpdb(decon, decon2, decon3) -#' } #' @export combine_cpdb <- function(...) { output <- list(...) - anames <- c("id_cp_interaction", "interacting_pair", "partner_a", "partner_b", + anames <- c( + "id_cp_interaction", "interacting_pair", "partner_a", "partner_b", "gene_a", "gene_b", "secreted", "receptor_a", "receptor_b", "annotation_strategy", - "is_integrin") - bnames <- c("gene_name", "uniprot", "is_complex", "protein_name", "complex_name", - "id_cp_interaction") + "is_integrin" + ) + bnames <- c( + "gene_name", "uniprot", "is_complex", "protein_name", "complex_name", + "id_cp_interaction" + ) if (all(colnames(output[[1]])[1:11] == anames)) { out <- output %>% reduce(full_join, by = anames) @@ -26,4 +24,4 @@ combine_cpdb <- function(...) { reduce(full_join, by = bnames) } return(out) -} \ No newline at end of file +} diff --git a/R/correlationSpot.R b/R/correlationSpot.R index 10ca3dba..f21458f9 100644 --- a/R/correlationSpot.R +++ b/R/correlationSpot.R @@ -20,10 +20,15 @@ #' @return SpatialFeaturePlot #' @export -correlationSpot <- function(st, genes = NULL, celltypes = NULL, geneset = NULL, mode = c("high", - "low", "both"), cutoff = 0.5, standardize = TRUE, dims = 1:30, k.params = 10, - resolution = 1, rna_slot = "SCT", label_slot = "predictions", by = c("image", - "expression"), average_by_cluster = FALSE, ...) { +correlationSpot <- function( + st, genes = NULL, celltypes = NULL, geneset = NULL, mode = c( + "high", + "low", "both" + ), cutoff = 0.5, standardize = TRUE, dims = 1:30, k.params = 10, + resolution = 1, rna_slot = "SCT", label_slot = "predictions", by = c( + "image", + "expression" + ), average_by_cluster = FALSE, ...) { requireNamespace("Seurat") requireNamespace("FNN") @@ -213,4 +218,4 @@ correlationSpot <- function(st, genes = NULL, celltypes = NULL, geneset = NULL, g <- Seurat::SpatialFeaturePlot(st, features = "correlation", ...) return(g) -} \ No newline at end of file +} diff --git a/R/data.R b/R/data.R index ec28c8ec..9f569165 100644 --- a/R/data.R +++ b/R/data.R @@ -157,4 +157,4 @@ #' interaction_scores_v5 - Dataframe of CellPhoneDB output interaction_scores.txt file #' @rdname kidneyimmune #' @docType data -"interaction_scores_v5" \ No newline at end of file +"interaction_scores_v5" diff --git a/R/geneDotPlot.R b/R/geneDotPlot.R index 243afa8e..16f1168b 100644 --- a/R/geneDotPlot.R +++ b/R/geneDotPlot.R @@ -21,7 +21,7 @@ #' @examples #' \donttest{ #' data(kidneyimmune) -#' geneDotPlot(kidneyimmune, genes = c('CD68', 'CD80', 'CD86', 'CD74', 'CD2', 'CD5'), celltype_key = 'celltype', splitby_key = 'Project', standard_scale = TRUE) + theme(strip.text.x = element_text(angle = 45, hjust = 0)) +#' geneDotPlot(kidneyimmune, genes = c("CD68", "CD80", "CD86", "CD74", "CD2", "CD5"), celltype_key = "celltype", splitby_key = "Project", standard_scale = TRUE) + theme(strip.text.x = element_text(angle = 45, hjust = 0)) #' } #' @import dplyr #' @import gtools @@ -30,13 +30,15 @@ #' @import reshape2 #' @import RColorBrewer #' @export -geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.threshold = 0.05, +geneDotPlot <- function( + scdata, celltype_key, genes, splitby_key = NULL, pct.threshold = 0.05, scale = NULL, standard_scale = NULL, keepLevels = TRUE, save.plot = FALSE, h = 5, w = 5, filepath = NULL, filename = NULL, heat_cols = NULL, col_limits = NULL, fill = FALSE, outline_col = "black", outline_size = 0.2) { if (class(scdata) %in% c("SingleCellExperiment", "SummarizedExperiment")) { cat("data provided is a SingleCellExperiment/SummarizedExperiment object", - sep = "\n") + sep = "\n" + ) cat("extracting expression matrix", sep = "\n") requireNamespace("SummarizedExperiment") exp_mat <- SummarizedExperiment::assay(scdata) @@ -54,15 +56,20 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr metadata <- scdata@meta.data } - cat(paste0("attempting to subset the expression matrix to the ", length(genes), - " genes provided"), sep = "\n") + cat(paste0( + "attempting to subset the expression matrix to the ", length(genes), + " genes provided" + ), sep = "\n") # expr_mat_filtered <- exp_mat[row.names(exp_mat) %in% genes, ] exp_mat <- # as.matrix(exp_mat) - expr_mat_filtered <- exp_mat[match(rev(genes), row.names(exp_mat))[!is.na(match(rev(genes), - row.names(exp_mat)))], , drop = FALSE] + expr_mat_filtered <- exp_mat[match(rev(genes), row.names(exp_mat))[!is.na(match( + rev(genes), + row.names(exp_mat) + ))], , drop = FALSE] cat(paste0("found ", dim(expr_mat_filtered)[1], " genes in the expression matrix", - sep = "\n")) + sep = "\n" + )) if (!is.null(splitby_key)) { labels <- paste0(as.character(metadata[[splitby_key]]), "_", as.character(metadata[[celltype_key]])) @@ -74,12 +81,15 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr cat("preparing the final dataframe ...", sep = "\n") quick_prep <- function(expr, label, groups. = NULL, scale. = scale, meta = metadata, - id = celltype_key, standard_scale. = standard_scale) { + id = celltype_key, standard_scale. = standard_scale) { expr.df <- tryCatch(data.frame(label = label, t(as.matrix(expr)), check.names = FALSE), error = function(e) { - data.frame(label = label, t(Matrix::Matrix(expr, sparse = FALSE)), - check.names = FALSE) - }) + data.frame( + label = label, t(Matrix::Matrix(expr, sparse = FALSE)), + check.names = FALSE + ) + } + ) meanExpr <- split(expr.df, expr.df$label) meanExpr <- lapply(meanExpr, function(x) { @@ -104,9 +114,9 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr if (length(scale.) < 1) { if (length(standard_scale.) > 0) { if (standard_scale.) { - meanExpr <- meanExpr_ + meanExpr <- meanExpr_ } else { - meanExpr <- meanExpr + meanExpr <- meanExpr } } else { meanExpr <- scale(meanExpr) @@ -114,13 +124,13 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr } else { if (scale.) { if (length(standard_scale.) > 0) { - if (standard_scale.) { - meanExpr <- meanExpr_ - } else { - meanExpr <- scale(meanExpr) - } + if (standard_scale.) { + meanExpr <- meanExpr_ + } else { + meanExpr <- scale(meanExpr) + } } else { - meanExpr <- scale(meanExpr) + meanExpr <- scale(meanExpr) } } else { meanExpr <- meanExpr @@ -143,7 +153,7 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr names(pct) <- levels(label) pct <- do.call(rbind, pct) - final.pct <- pct/cellNumbers + final.pct <- pct / cellNumbers meltedMeanExpr <- reshape2::melt(meanExpr) meltedfinal.pct <- reshape2::melt(final.pct) @@ -151,17 +161,13 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr if (!is.null(groups)) { meltedMeanExpr$Var3 <- gsub(".*_", "", meltedMeanExpr$Var1) meltedfinal.pct$Var3 <- gsub(".*_", "", meltedfinal.pct$Var1) - meltedfinal.pct <- meltedfinal.pct[order(meltedfinal.pct$Var3, meltedfinal.pct$Var2), - ] - meltedMeanExpr <- meltedMeanExpr[order(meltedMeanExpr$Var3, meltedMeanExpr$Var2), - ] + meltedfinal.pct <- meltedfinal.pct[order(meltedfinal.pct$Var3, meltedfinal.pct$Var2), ] + meltedMeanExpr <- meltedMeanExpr[order(meltedMeanExpr$Var3, meltedMeanExpr$Var2), ] meltedfinal.pct <- meltedfinal.pct[, -4] meltedMeanExpr <- meltedMeanExpr[, -4] } else { - meltedfinal.pct <- meltedfinal.pct[order(meltedfinal.pct$Var1, meltedfinal.pct$Var2), - ] - meltedMeanExpr <- meltedMeanExpr[order(meltedMeanExpr$Var1, meltedMeanExpr$Var2), - ] + meltedfinal.pct <- meltedfinal.pct[order(meltedfinal.pct$Var1, meltedfinal.pct$Var2), ] + meltedMeanExpr <- meltedMeanExpr[order(meltedMeanExpr$Var1, meltedMeanExpr$Var2), ] } df <- cbind(meltedMeanExpr, meltedfinal.pct$value) @@ -198,8 +204,10 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr } if (!is.null(pct.threshold)) { - cat(paste0("setting minimum percentage of cells expressing gene to be ", - pct.threshold * 100, "% of cluster/cell-type"), sep = "\n") + cat(paste0( + "setting minimum percentage of cells expressing gene to be ", + pct.threshold * 100, "% of cluster/cell-type" + ), sep = "\n") filter <- split(plot.df, plot.df$gene) remove.genes <- lapply(filter, function(x) { @@ -243,8 +251,8 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr # subset the plotting objects doplot <- function(obj, group. = NULL, file_name = filename, file_path = filepath, - dim_w = w, dim_h = h, limits. = col_limits, do.plot = save.plot, scale. = scale, - standard_scale. = standard_scale) { + dim_w = w, dim_h = h, limits. = col_limits, do.plot = save.plot, scale. = scale, + standard_scale. = standard_scale) { requireNamespace("scales") if (is.null(group.)) { if ((length(scale.) > 0 && scale.) | (length(scale.) < 1 && length(standard_scale.) < @@ -254,13 +262,21 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr g <- ggplot(obj, aes(x = 0, y = gene, size = pct, colour = mean)) } g <- g + geom_point(pch = 16, na.rm = TRUE) + scale_y_discrete(position = "left") + - scale_x_discrete(position = "bottom") + scale_colour_gradientn(colors = heat_cols, - limits = limits., na.value = "grey90", oob = scales::squish) + scale_radius(range = c(0, - 4), limits = c(0, 1)) + theme_bw() + theme(axis.text.x = element_text(angle = 90, - hjust = 1), axis.title.x = element_blank(), axis.ticks = element_blank(), - axis.title.y = element_blank(), axis.line = element_blank(), panel.grid.major = element_blank(), - panel.grid.minor = element_blank(), panel.border = element_blank(), - strip.background = element_blank()) + facet_grid(~cell_type) + scale_x_discrete(position = "bottom") + scale_colour_gradientn( + colors = heat_cols, + limits = limits., na.value = "grey90", oob = scales::squish + ) + scale_radius(range = c( + 0, + 4 + ), limits = c(0, 1)) + theme_bw() + theme( + axis.text.x = element_text( + angle = 90, + hjust = 1 + ), axis.title.x = element_blank(), axis.ticks = element_blank(), + axis.title.y = element_blank(), axis.line = element_blank(), panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), panel.border = element_blank(), + strip.background = element_blank() + ) + facet_grid(~cell_type) } else { if ((length(scale.) > 0 && scale.) | (length(scale.) < 1 && length(standard_scale.) < 1) | (length(standard_scale.) > 0 && standard_scale.)) { @@ -270,50 +286,75 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr } g <- g + geom_point(pch = 16, na.rm = TRUE) + scale_y_discrete(position = "left") + - scale_x_discrete(position = "bottom") + scale_colour_gradientn(colors = heat_cols, - limits = limits., na.value = "grey90", oob = scales::squish) + scale_radius(range = c(0, - 4), limits = c(0, 1)) + theme_bw() + theme(axis.text.x = element_text(angle = 90, - hjust = 1), axis.title.x = element_blank(), axis.ticks = element_blank(), - axis.title.y = element_blank(), axis.line = element_blank(), panel.grid.major = element_blank(), - panel.grid.minor = element_blank(), panel.border = element_blank(), - strip.background = element_blank()) + facet_grid(~cell_type) + scale_x_discrete(position = "bottom") + scale_colour_gradientn( + colors = heat_cols, + limits = limits., na.value = "grey90", oob = scales::squish + ) + scale_radius(range = c( + 0, + 4 + ), limits = c(0, 1)) + theme_bw() + theme( + axis.text.x = element_text( + angle = 90, + hjust = 1 + ), axis.title.x = element_blank(), axis.ticks = element_blank(), + axis.title.y = element_blank(), axis.line = element_blank(), panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), panel.border = element_blank(), + strip.background = element_blank() + ) + facet_grid(~cell_type) } if (do.plot) { if (is.null(file_name) && is.null(file_path)) { out_path <- "./geneDotPlot.df" warning("no file name provided. saving plot to ", getwd(), "/geneDotPlot.pdf") - ggsave("./geneDotPlot.pdf", plot = g, width = dim_w, height = dim_h, - device = "pdf", useDingbats = FALSE) + ggsave("./geneDotPlot.pdf", + plot = g, width = dim_w, height = dim_h, + device = "pdf", useDingbats = FALSE + ) } else if (!is.null(file_name) && is.null(file_path)) { cat(paste0("saving plot to ", file_name), sep = "\n") - tryCatch(ggsave(file_name, plot = g, width = dim_w, height = dim_h, - device = "pdf", useDingbats = FALSE), error = function(e) { - ggsave("./geneDotPlot.df", plot = g, width = dim_w, height = dim_h, - device = "pdf", useDingbats = FALSE) - warning("file name provided is not suitable. saving as geneDotPlot.pdf") + tryCatch(ggsave(file_name, + plot = g, width = dim_w, height = dim_h, + device = "pdf", useDingbats = FALSE + ), error = function(e) { + ggsave("./geneDotPlot.df", + plot = g, width = dim_w, height = dim_h, + device = "pdf", useDingbats = FALSE + ) + warning("file name provided is not suitable. saving as geneDotPlot.pdf") }) } else if (is.null(file_name) && !is.null(file_path)) { cat(paste0("saving plot to ", file_path), sep = "\n") if (grepl(".pdf", file_path)) { - ggsave(file_path, plot = g, width = dim_w, height = dim_h, device = "pdf", - useDingbats = FALSE) + ggsave(file_path, + plot = g, width = dim_w, height = dim_h, device = "pdf", + useDingbats = FALSE + ) } else { - dir.create(file_path, recursive = TRUE) - ggsave(paste0(file_path, "/geneDotPlot.df"), plot = g, width = dim_w, - height = dim_h, device = "pdf", useDingbats = FALSE) - warning(paste0("file path provided is not suitable. saving as ", - file_path, "/geneDotPlot.pdf")) + dir.create(file_path, recursive = TRUE) + ggsave(paste0(file_path, "/geneDotPlot.df"), + plot = g, width = dim_w, + height = dim_h, device = "pdf", useDingbats = FALSE + ) + warning(paste0( + "file path provided is not suitable. saving as ", + file_path, "/geneDotPlot.pdf" + )) } } else if (!is.null(file_name) && !is.null(file_path)) { cat(paste0("saving plot to ", paste0(file_path, "/", file_name)), - sep = "\n") + sep = "\n" + ) dir.create(file_path, recursive = TRUE) - tryCatch(ggsave(paste0(file_path, "/", file_name), plot = g, width = dim_w, - height = dim_h, device = "pdf", useDingbats = FALSE), error = function(e) { - ggsave("./geneDotPlot.df", plot = g, width = dim_w, height = dim_h, - device = "pdf", useDingbats = FALSE) - warning("file path provided is not suitable. saving as geneDotPlot.pdf") + tryCatch(ggsave(paste0(file_path, "/", file_name), + plot = g, width = dim_w, + height = dim_h, device = "pdf", useDingbats = FALSE + ), error = function(e) { + ggsave("./geneDotPlot.df", + plot = g, width = dim_w, height = dim_h, + device = "pdf", useDingbats = FALSE + ) + warning("file path provided is not suitable. saving as geneDotPlot.pdf") }) } } @@ -321,8 +362,8 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr } fillplot <- function(obj, group. = NULL, file_name = filename, file_path = filepath, - dim_w = w, dim_h = h, limits. = col_limits, do.plot = save.plot, scale. = scale, - standard_scale. = standard_scale, outline_col. = outline_col, outline_size. = outline_size) { + dim_w = w, dim_h = h, limits. = col_limits, do.plot = save.plot, scale. = scale, + standard_scale. = standard_scale, outline_col. = outline_col, outline_size. = outline_size) { requireNamespace("scales") if (is.null(group.)) { if ((length(scale.) > 0 && scale.) | (length(scale.) < 1 && length(standard_scale.) < @@ -333,13 +374,19 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr } g <- g + geom_point(pch = 21, color = outline_col., stroke = outline_size.) + scale_y_discrete(position = "left") + scale_x_discrete(position = "bottom") + - scale_fill_gradientn(colors = heat_cols, limits = limits., na.value = "grey90", - oob = scales::squish) + scale_radius(range = c(0, 4), limits = c(0, - 1)) + theme_bw() + theme(axis.text.x = element_text(angle = 90, hjust = 1), - axis.title.x = element_blank(), axis.ticks = element_blank(), axis.title.y = element_blank(), - axis.line = element_blank(), panel.grid.major = element_blank(), - panel.grid.minor = element_blank(), panel.border = element_blank(), - strip.background = element_blank()) + facet_grid(~cell_type) + scale_fill_gradientn( + colors = heat_cols, limits = limits., na.value = "grey90", + oob = scales::squish + ) + scale_radius(range = c(0, 4), limits = c( + 0, + 1 + )) + theme_bw() + theme( + axis.text.x = element_text(angle = 90, hjust = 1), + axis.title.x = element_blank(), axis.ticks = element_blank(), axis.title.y = element_blank(), + axis.line = element_blank(), panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), panel.border = element_blank(), + strip.background = element_blank() + ) + facet_grid(~cell_type) } else { if ((length(scale.) > 0 && scale.) | (length(scale.) < 1 && length(standard_scale.) < 1) | (length(standard_scale.) > 0 && standard_scale.)) { @@ -349,64 +396,91 @@ geneDotPlot <- function(scdata, celltype_key, genes, splitby_key = NULL, pct.thr } g <- g + geom_point(pch = 21, color = outline_col., stroke = outline_size.) + scale_y_discrete(position = "left") + scale_x_discrete(position = "bottom") + - scale_fill_gradientn(colors = heat_cols, limits = limits., na.value = "grey90", - oob = scales::squish) + scale_radius(range = c(0, 4), limits = c(0, - 1)) + theme_bw() + theme(axis.text.x = element_text(angle = 90, hjust = 1), - axis.title.x = element_blank(), axis.ticks = element_blank(), axis.title.y = element_blank(), - axis.line = element_blank(), panel.grid.major = element_blank(), - panel.grid.minor = element_blank(), panel.border = element_blank(), - strip.background = element_blank()) + facet_grid(~cell_type) + scale_fill_gradientn( + colors = heat_cols, limits = limits., na.value = "grey90", + oob = scales::squish + ) + scale_radius(range = c(0, 4), limits = c( + 0, + 1 + )) + theme_bw() + theme( + axis.text.x = element_text(angle = 90, hjust = 1), + axis.title.x = element_blank(), axis.ticks = element_blank(), axis.title.y = element_blank(), + axis.line = element_blank(), panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), panel.border = element_blank(), + strip.background = element_blank() + ) + facet_grid(~cell_type) } if (do.plot) { if (is.null(file_name) && is.null(file_path)) { out_path <- "./geneDotPlot.df" warning("no file name provided. saving plot to ", getwd(), "/geneDotPlot.pdf") - ggsave("./geneDotPlot.pdf", plot = g, width = dim_w, height = dim_h, - device = "pdf", useDingbats = FALSE) + ggsave("./geneDotPlot.pdf", + plot = g, width = dim_w, height = dim_h, + device = "pdf", useDingbats = FALSE + ) } else if (!is.null(file_name) && is.null(file_path)) { cat(paste0("saving plot to ", file_name), sep = "\n") - tryCatch(ggsave(file_name, plot = g, width = dim_w, height = dim_h, - device = "pdf", useDingbats = FALSE), error = function(e) { - ggsave("./geneDotPlot.df", plot = g, width = dim_w, height = dim_h, - device = "pdf", useDingbats = FALSE) - warning("file name provided is not suitable. saving as geneDotPlot.pdf") + tryCatch(ggsave(file_name, + plot = g, width = dim_w, height = dim_h, + device = "pdf", useDingbats = FALSE + ), error = function(e) { + ggsave("./geneDotPlot.df", + plot = g, width = dim_w, height = dim_h, + device = "pdf", useDingbats = FALSE + ) + warning("file name provided is not suitable. saving as geneDotPlot.pdf") }) } else if (is.null(file_name) && !is.null(file_path)) { cat(paste0("saving plot to ", file_path), sep = "\n") if (grepl(".pdf", file_path)) { - ggsave(file_path, plot = g, width = dim_w, height = dim_h, device = "pdf", - useDingbats = FALSE) + ggsave(file_path, + plot = g, width = dim_w, height = dim_h, device = "pdf", + useDingbats = FALSE + ) } else { - dir.create(file_path, recursive = TRUE) - ggsave(paste0(file_path, "/geneDotPlot.df"), plot = g, width = dim_w, - height = dim_h, device = "pdf", useDingbats = FALSE) - warning(paste0("file path provided is not suitable. saving as ", - file_path, "/geneDotPlot.pdf")) + dir.create(file_path, recursive = TRUE) + ggsave(paste0(file_path, "/geneDotPlot.df"), + plot = g, width = dim_w, + height = dim_h, device = "pdf", useDingbats = FALSE + ) + warning(paste0( + "file path provided is not suitable. saving as ", + file_path, "/geneDotPlot.pdf" + )) } } else if (!is.null(file_name) && !is.null(file_path)) { cat(paste0("saving plot to ", paste0(file_path, "/", file_name)), - sep = "\n") + sep = "\n" + ) dir.create(file_path, recursive = TRUE) - tryCatch(ggsave(paste0(file_path, "/", file_name), plot = g, width = dim_w, - height = dim_h, device = "pdf", useDingbats = FALSE), error = function(e) { - ggsave("./geneDotPlot.df", plot = g, width = dim_w, height = dim_h, - device = "pdf", useDingbats = FALSE) - warning("file path provided is not suitable. saving as geneDotPlot.pdf") + tryCatch(ggsave(paste0(file_path, "/", file_name), + plot = g, width = dim_w, + height = dim_h, device = "pdf", useDingbats = FALSE + ), error = function(e) { + ggsave("./geneDotPlot.df", + plot = g, width = dim_w, height = dim_h, + device = "pdf", useDingbats = FALSE + ) + warning("file path provided is not suitable. saving as geneDotPlot.pdf") }) } } return(g) } if (fill) { - gg <- fillplot(plot.df.final, splitby_key, file_name = filename, file_path = filepath, + gg <- fillplot(plot.df.final, splitby_key, + file_name = filename, file_path = filepath, dim_w = w, dim_h = h, limits. = col_limits, do.plot = save.plot, scale. = scale, - standard_scale. = standard_scale, outline_col. = outline_col, outline_size. = outline_size) + standard_scale. = standard_scale, outline_col. = outline_col, outline_size. = outline_size + ) } else { - gg <- doplot(plot.df.final, splitby_key, file_name = filename, file_path = filepath, + gg <- doplot(plot.df.final, splitby_key, + file_name = filename, file_path = filepath, dim_w = w, dim_h = h, limits. = col_limits, do.plot = save.plot, scale. = scale, - standard_scale. = standard_scale) + standard_scale. = standard_scale + ) } gg return(gg) -} \ No newline at end of file +} diff --git a/R/init_ktplots.R b/R/init_ktplots.R index 880ae048..864b14d6 100644 --- a/R/init_ktplots.R +++ b/R/init_ktplots.R @@ -10,6 +10,8 @@ #' @export init_ktplots <- function() { requireNamespace("devtools") + requireNamespace("styler") + styler::style_pkg(".", style = styler::tidyverse_style, indent_by = 4) devtools::document() setwd("..") devtools::install("ktplots", dependencies = FALSE) @@ -19,10 +21,12 @@ init_ktplots <- function() { #' @export init <- function(package, dependencies = FALSE) { + requireNamespace("styler") setwd(paste0("~/Documents/GitHub/", package)) + styler::style_pkg(".", style = styler::tidyverse_style, indent_by = 4) requireNamespace("devtools") devtools::document() setwd("..") devtools::install(package, dependencies = dependencies) setwd(package) -} \ No newline at end of file +} diff --git a/R/ktplots.R b/R/ktplots.R index c1c0bd8e..caec0b48 100644 --- a/R/ktplots.R +++ b/R/ktplots.R @@ -12,4 +12,4 @@ ktplots <- function() { requireNamespace("ktplots") requireNamespace("roxygen2") init_ktplots() -} \ No newline at end of file +} diff --git a/R/misc.R b/R/misc.R index c6b41028..b1b5673b 100644 --- a/R/misc.R +++ b/R/misc.R @@ -8,7 +8,7 @@ #' x <- range01(runif(100)) #' @export range01 <- function(x) { - (x - min(x))/(max(x) - min(x)) + (x - min(x)) / (max(x) - min(x)) } @@ -23,8 +23,11 @@ range01 <- function(x) { #' } #' @export "%nin%" <- function(x, y) { - if (!is.null(x)) - x else y + if (!is.null(x)) { + x + } else { + y + } } #' @import dplyr @@ -37,11 +40,17 @@ range01 <- function(x) { #' g + small_legend() #' } #' @export -small_legend <- function(fontsize = 5, keysize = 0.1, marginsize = c(-0.1, 0, 0, - 0), ...) { - small_legend_theme <- theme(legend.title = element_text(size = fontsize), legend.text = element_text(size = fontsize), +small_legend <- function(fontsize = 5, keysize = 0.1, marginsize = c( + -0.1, 0, 0, + 0 + ), ...) { + small_legend_theme <- theme( + legend.title = element_text(size = fontsize), legend.text = element_text(size = fontsize), legend.key.size = unit(keysize, "lines"), legend.margin = margin(marginsize[1], - marginsize[2], marginsize[3], marginsize[4], unit = "cm"), ...) + marginsize[2], marginsize[3], marginsize[4], + unit = "cm" + ), ... + ) return(small_legend_theme) } @@ -54,8 +63,10 @@ small_legend <- function(fontsize = 5, keysize = 0.1, marginsize = c(-0.1, 0, 0, #' } #' @export small_guide <- function(guidesize = 1, ...) { - small_guide <- guides(shape = guide_legend(override.aes = list(size = guidesize)), - color = guide_legend(override.aes = list(size = guidesize)), ...) + small_guide <- guides( + shape = guide_legend(override.aes = list(size = guidesize)), + color = guide_legend(override.aes = list(size = guidesize)), ... + ) return(small_guide) } @@ -69,10 +80,12 @@ small_guide <- function(guidesize = 1, ...) { #' } #' @export small_axis <- function(fontsize = 4, linethickness = 0.1, ...) { - axis <- theme(text = element_text(size = fontsize), axis.text = element_text(size = fontsize), + axis <- theme( + text = element_text(size = fontsize), axis.text = element_text(size = fontsize), axis.text.x = element_text(size = fontsize), axis.text.y = element_text(size = fontsize), axis.line = element_line(linewidth = linethickness), axis.ticks = element_line(linewidth = linethickness), - ...) + ... + ) return(axis) } @@ -85,8 +98,10 @@ small_axis <- function(fontsize = 4, linethickness = 0.1, ...) { #' } #' @export small_grid <- function(linethickness = 0.1, panelthickness = 0.3, ...) { - grid <- theme(panel.grid = element_line(linewidth = linethickness), panel.border = element_rect(linewidth = panelthickness), - ...) + grid <- theme( + panel.grid = element_line(linewidth = linethickness), panel.border = element_rect(linewidth = panelthickness), + ... + ) return(grid) } @@ -99,8 +114,10 @@ small_grid <- function(linethickness = 0.1, panelthickness = 0.3, ...) { #' } #' @export topright_legend <- function(legendmargin = margin(6, 6, 6, 6), ...) { - legend <- theme(legend.position = c(0.99, 0.99), legend.justification = c("right", - "top"), legend.box.just = "right", legend.margin = legendmargin, ...) + legend <- theme(legend.position = c(0.99, 0.99), legend.justification = c( + "right", + "top" + ), legend.box.just = "right", legend.margin = legendmargin, ...) return(legend) } @@ -113,8 +130,10 @@ topright_legend <- function(legendmargin = margin(6, 6, 6, 6), ...) { #' } #' @export topleft_legend <- function(legendmargin = margin(6, 6, 6, 6), ...) { - legend <- theme(legend.position = c(0.01, 0.99), legend.justification = c("left", - "top"), legend.box.just = "left", legend.margin = legendmargin, ...) + legend <- theme(legend.position = c(0.01, 0.99), legend.justification = c( + "left", + "top" + ), legend.box.just = "left", legend.margin = legendmargin, ...) return(legend) } @@ -127,8 +146,10 @@ topleft_legend <- function(legendmargin = margin(6, 6, 6, 6), ...) { #' } #' @export bottomleft_legend <- function(legendmargin = margin(6, 6, 6, 6), ...) { - legend <- theme(legend.position = c(0.01, 0.01), legend.justification = c("left", - "bottom"), legend.box.just = "left", legend.margin = legendmargin, ...) + legend <- theme(legend.position = c(0.01, 0.01), legend.justification = c( + "left", + "bottom" + ), legend.box.just = "left", legend.margin = legendmargin, ...) return(legend) } @@ -141,7 +162,9 @@ bottomleft_legend <- function(legendmargin = margin(6, 6, 6, 6), ...) { #' } #' @export bottomright_legend <- function(legendmargin = margin(6, 6, 6, 6), ...) { - legend <- theme(legend.position = c(0.99, 0.01), legend.justification = c("right", - "bottom"), legend.box.just = "left", legend.margin = legendmargin, ...) + legend <- theme(legend.position = c(0.99, 0.01), legend.justification = c( + "right", + "bottom" + ), legend.box.just = "left", legend.margin = legendmargin, ...) return(legend) -} \ No newline at end of file +} diff --git a/R/plot_cpdb.R b/R/plot_cpdb.R index 6ab6fdc4..9be2a522 100644 --- a/R/plot_cpdb.R +++ b/R/plot_cpdb.R @@ -58,771 +58,771 @@ plot_cpdb <- function( scale_alpha_by_cellsign = FALSE, filter_by_cellsign = FALSE, title = "", keep_id_cp_interaction = FALSE, result_precision = 3, ...) { - requireNamespace("SingleCellExperiment") - requireNamespace("grDevices") - if (is.null(special_character_regex_pattern)) { - special_character_regex_pattern <- DEFAULT_SPEC_PAT - } - if (class(scdata) %in% c("SingleCellExperiment", "SummarizedExperiment")) { - metadata <- SingleCellExperiment::colData(scdata) - } else if (class(scdata) == "Seurat") { - metadata <- scdata@meta.data - } - means_mat <- .prep_table(means) - pvals_mat <- .prep_table(pvals) - col_start <- ifelse(colnames(pvals_mat)[DEFAULT_CLASS_COL] == "classification", - DEFAULT_V5_COL_START, DEFAULT_COL_START - ) - if (!identical(dim(pvals_mat), dim(means_mat))) { - tmp_pvals_mat <- data.frame(matrix(NA, nrow = nrow(means_mat), ncol = ncol(means_mat))) - rownames(tmp_pvals_mat) <- rownames(means_mat) - colnames(tmp_pvals_mat) <- colnames(means_mat) + requireNamespace("SingleCellExperiment") + requireNamespace("grDevices") + if (is.null(special_character_regex_pattern)) { + special_character_regex_pattern <- DEFAULT_SPEC_PAT + } + if (class(scdata) %in% c("SingleCellExperiment", "SummarizedExperiment")) { + metadata <- SingleCellExperiment::colData(scdata) + } else if (class(scdata) == "Seurat") { + metadata <- scdata@meta.data + } + means_mat <- .prep_table(means) + pvals_mat <- .prep_table(pvals) + col_start <- ifelse(colnames(pvals_mat)[DEFAULT_CLASS_COL] == "classification", + DEFAULT_V5_COL_START, DEFAULT_COL_START + ) + if (!identical(dim(pvals_mat), dim(means_mat))) { + tmp_pvals_mat <- data.frame(matrix(NA, nrow = nrow(means_mat), ncol = ncol(means_mat))) + rownames(tmp_pvals_mat) <- rownames(means_mat) + colnames(tmp_pvals_mat) <- colnames(means_mat) + + # Copy the values from means_mat to tmp_pvals_mat + tmp_pvals_mat[, 1:(col_start - 1)] <- means_mat[, 1:(col_start - 1)] + tmp_pvals_mat[rownames(pvals_mat), colnames(pvals_mat)] <- pvals_mat - # Copy the values from means_mat to tmp_pvals_mat - tmp_pvals_mat[, 1:(col_start - 1)] <- means_mat[, 1:(col_start - 1)] - tmp_pvals_mat[rownames(pvals_mat), colnames(pvals_mat)] <- pvals_mat + if (degs_analysis) { + tmp_pvals_mat[is.na(tmp_pvals_mat)] <- 0 + } else { + tmp_pvals_mat[is.na(tmp_pvals_mat)] <- 1 + } + pvals_mat <- tmp_pvals_mat + } + if (!is.null(interaction_scores)) { + interaction_scores_mat <- .prep_table(interaction_scores) + } else if (!is.null(cellsign)) { + cellsign_mat <- .prep_table(cellsign) + } if (degs_analysis) { - tmp_pvals_mat[is.na(tmp_pvals_mat)] <- 0 - } else { - tmp_pvals_mat[is.na(tmp_pvals_mat)] <- 1 + pvals_mat[, col_start:ncol(pvals_mat)] <- 1 - pvals_mat[, col_start:ncol(pvals_mat)] } - - pvals_mat <- tmp_pvals_mat - } - if (!is.null(interaction_scores)) { - interaction_scores_mat <- .prep_table(interaction_scores) - } else if (!is.null(cellsign)) { - cellsign_mat <- .prep_table(cellsign) - } - if (degs_analysis) { - pvals_mat[, col_start:ncol(pvals_mat)] <- 1 - pvals_mat[, col_start:ncol(pvals_mat)] - } - # ok front load a 'dictionary' here. - if (col_start == DEFAULT_V5_COL_START) { - v5tmp <- reshape2::melt(means_mat, id.vars = colnames(means_mat)[1:col_start]) - row.names(v5tmp) <- paste0(v5tmp$id_cp_interaction, SPECIAL_SEP, gsub( - "_", - "-", v5tmp$interacting_pair - ), SPECIAL_SEP, v5tmp$variable) - v5tmp <- v5tmp[, c("is_integrin", "directionality", "classification")] - } - cell_type1 <- .sub_pattern(cell_type = cell_type1, pattern = special_character_regex_pattern) - cell_type2 <- .sub_pattern(cell_type = cell_type2, pattern = special_character_regex_pattern) - query_list <- .prep_query_group( - data = means_mat, genes = genes, gene_family = gene_family, - custom_gene_family = custom_gene_family - ) - query <- query_list[["query"]] - query_group <- query_list[["query_group"]] - # prepare the cell_type query - if (!is.null(splitby_key)) { - labels <- paste0(metadata[[splitby_key]], "_", metadata[[celltype_key]]) - if (is.factor(metadata[[splitby_key]]) & is.factor(metadata[[celltype_key]])) { - labels <- factor(labels, levels = paste0( - levels(metadata[[splitby_key]]), - "_", rep(levels(metadata[[celltype_key]]), each = length(levels(metadata[[splitby_key]]))) - )) + # ok front load a 'dictionary' here. + if (col_start == DEFAULT_V5_COL_START) { + v5tmp <- reshape2::melt(means_mat, id.vars = colnames(means_mat)[1:col_start]) + row.names(v5tmp) <- paste0(v5tmp$id_cp_interaction, SPECIAL_SEP, gsub( + "_", + "-", v5tmp$interacting_pair + ), SPECIAL_SEP, v5tmp$variable) + v5tmp <- v5tmp[, c("is_integrin", "directionality", "classification")] + } + cell_type1 <- .sub_pattern(cell_type = cell_type1, pattern = special_character_regex_pattern) + cell_type2 <- .sub_pattern(cell_type = cell_type2, pattern = special_character_regex_pattern) + query_list <- .prep_query_group( + data = means_mat, genes = genes, gene_family = gene_family, + custom_gene_family = custom_gene_family + ) + query <- query_list[["query"]] + query_group <- query_list[["query_group"]] + # prepare the cell_type query + if (!is.null(splitby_key)) { + labels <- paste0(metadata[[splitby_key]], "_", metadata[[celltype_key]]) + if (is.factor(metadata[[splitby_key]]) & is.factor(metadata[[celltype_key]])) { + labels <- factor(labels, levels = paste0( + levels(metadata[[splitby_key]]), + "_", rep(levels(metadata[[celltype_key]]), each = length(levels(metadata[[splitby_key]]))) + )) + } else { + labels <- factor(labels) + } + labels <- levels(labels) + groups <- factor(metadata[[splitby_key]]) + groups <- levels(groups) + if (length(groups) > 0) { + # the purpose for this step is to allow for special characters to be used + # in the celltype grepping + if (length(groups) > 1) { + labels2 <- gsub( + paste0(paste0(groups, "_"), collapse = "|"), "", + labels + ) + } else { + labels2 <- gsub(paste0(groups, "_"), "", labels) + } + # this returns the indices from the labels + ct1 <- grep(cell_type1, labels2, ...) + ct2 <- grep(cell_type2, labels2, ...) + c_type1 <- as.list(labels[ct1]) + c_type2 <- as.list(labels[ct2]) + c_type1 <- lapply(c_type1, .sub_pattern, pattern = special_character_regex_pattern) + c_type2 <- lapply(c_type2, .sub_pattern, pattern = special_character_regex_pattern) + grp <- as.list(groups) + celltype <- list() + for (i in 1:length(c_type1)) { + celltype[[i]] <- .create_celltype_query( + ctype1 = c_type1[[i]], ctype2 = c_type2, + sep = DEFAULT_SEP + ) + celltype[[i]] <- lapply(grp, .keep_interested_groups, + ct = celltype[[i]], + sep = DEFAULT_SEP + ) + } + for (i in 1:length(celltype)) { + celltype[[i]] <- celltype[[i]][-which(celltype[[i]] == "")] + } + celltype <- lapply(celltype, unlist) + if (any(unlist(lapply(celltype, is.null)))) { + rm <- which(unlist(lapply(celltype, is.null))) + celltype <- celltype[-rm] + } + cell_type <- do.call(paste0, list(celltype, collapse = "|")) + } else { + labels <- metadata[[celltype_key]] + labels <- factor(labels) + labels <- levels(labels) + c_type1 <- as.list(grep(cell_type1, labels, value = TRUE, ...)) + c_type2 <- as.list(grep(cell_type2, labels, value = TRUE, ...)) + c_type1 <- lapply(c_type1, .sub_pattern, pattern = special_character_regex_pattern) + c_type2 <- lapply(c_type2, .sub_pattern, pattern = special_character_regex_pattern) + celltype <- list() + for (i in 1:length(c_type1)) { + celltype[[i]] <- .create_celltype_query( + ctype1 = c_type1[[i]], ctype2 = c_type2, + sep = DEFAULT_SEP + ) + } + cell_type <- do.call(paste0, list(celltype, collapse = "|")) + } } else { - labels <- factor(labels) + labels <- metadata[[celltype_key]] + labels <- factor(labels) + labels <- levels(labels) + c_type1 <- as.list(grep(cell_type1, labels, value = TRUE)) + c_type2 <- as.list(grep(cell_type2, labels, value = TRUE)) + c_type1 <- lapply(c_type1, .sub_pattern, pattern = special_character_regex_pattern) + c_type2 <- lapply(c_type2, .sub_pattern, pattern = special_character_regex_pattern) + celltype <- list() + for (i in 1:length(c_type1)) { + celltype[[i]] <- .create_celltype_query( + ctype1 = c_type1[[i]], ctype2 = c_type2, + sep = DEFAULT_SEP + ) + } + cell_type <- do.call(paste0, list(celltype, collapse = "|")) } - labels <- levels(labels) - groups <- factor(metadata[[splitby_key]]) - groups <- levels(groups) - if (length(groups) > 0) { - # the purpose for this step is to allow for special characters to be used - # in the celltype grepping - if (length(groups) > 1) { - labels2 <- gsub( - paste0(paste0(groups, "_"), collapse = "|"), "", - labels - ) - } else { - labels2 <- gsub(paste0(groups, "_"), "", labels) - } - # this returns the indices from the labels - ct1 <- grep(cell_type1, labels2, ...) - ct2 <- grep(cell_type2, labels2, ...) - c_type1 <- as.list(labels[ct1]) - c_type2 <- as.list(labels[ct2]) - c_type1 <- lapply(c_type1, .sub_pattern, pattern = special_character_regex_pattern) - c_type2 <- lapply(c_type2, .sub_pattern, pattern = special_character_regex_pattern) - grp <- as.list(groups) - celltype <- list() - for (i in 1:length(c_type1)) { - celltype[[i]] <- .create_celltype_query( - ctype1 = c_type1[[i]], ctype2 = c_type2, - sep = DEFAULT_SEP + if (!is.null(gene_family) & is.null(genes)) { + if (length(gene_family) == 1) { + means_mat <- .prep_data_querygroup_celltype1( + .data = means_mat, .query_group = query_group, + .gene_family = gene_family, .cell_type = cell_type, .celltype = celltype, + ... + ) + pvals_mat <- .prep_data_querygroup_celltype1( + .data = pvals_mat, .query_group = query_group, + .gene_family = gene_family, .cell_type = cell_type, .celltype = celltype, + ... + ) + if (!is.null(interaction_scores)) { + interaction_scores_mat <- .prep_data_querygroup_celltype1( + .data = interaction_scores_mat, + .query_group = query_group, .gene_family = gene_family, .cell_type = cell_type, + .celltype = celltype, ... + ) + } else if (!is.null(cellsign)) { + cellsign_mat <- .prep_data_querygroup_celltype1( + .data = cellsign_mat, + .query_group = query_group, .gene_family = gene_family, .cell_type = cell_type, + .celltype = celltype, ... + ) + } + } else if (length(gene_family) > 1) { + means_mat <- .prep_data_querygroup_celltype2( + .data = means_mat, .query_group = query_group, + .gene_family = gene_family, .cell_type = cell_type, .celltype = celltype, + ... + ) + pvals_mat <- .prep_data_querygroup_celltype2( + .data = pvals_mat, .query_group = query_group, + .gene_family = gene_family, .cell_type = cell_type, .celltype = celltype, + ... + ) + if (!is.null(interaction_scores)) { + interaction_scores_mat <- .prep_data_querygroup_celltype2( + .data = interaction_scores_mat, + .query_group = query_group, .gene_family = gene_family, .cell_type = cell_type, + .celltype = celltype, ... + ) + } else if (!is.null(cellsign)) { + cellsign_mat <- .prep_data_querygroup_celltype2( + .data = cellsign_mat, + .query_group = query_group, .gene_family = gene_family, .cell_type = cell_type, + .celltype = celltype, ... + ) + } + } + } else if (is.null(gene_family) & !is.null(genes) | is.null(gene_family) & is.null(genes)) { + means_mat <- .prep_data_query_celltype( + .data = means_mat, .query = query, + .cell_type = cell_type, .celltype = celltype, ... ) - celltype[[i]] <- lapply(grp, .keep_interested_groups, - ct = celltype[[i]], - sep = DEFAULT_SEP + pvals_mat <- .prep_data_query_celltype( + .data = pvals_mat, .query = query, + .cell_type = cell_type, .celltype = celltype, ... ) - } - for (i in 1:length(celltype)) { - celltype[[i]] <- celltype[[i]][-which(celltype[[i]] == "")] - } - celltype <- lapply(celltype, unlist) - if (any(unlist(lapply(celltype, is.null)))) { - rm <- which(unlist(lapply(celltype, is.null))) - celltype <- celltype[-rm] - } - cell_type <- do.call(paste0, list(celltype, collapse = "|")) + if (!is.null(interaction_scores)) { + interaction_scores_mat <- .prep_data_query_celltype( + .data = interaction_scores_mat, + .query = query, .cell_type = cell_type, .celltype = celltype, ... + ) + } else if (!is.null(cellsign)) { + cellsign_mat <- cellsign_mat[, col_start:ncol(cellsign_mat)] # too difficult to code is properly? + } + # } else if (!is.null(cellsign)) { cellsign_mat <- + # .prep_data_query_celltype( .data = cellsign_mat, .query = query, + # .cell_type = cell_type, .celltype = celltype, ... ) } + } + + # rearrange the columns so that it interleaves the two groups + if (!is.null(splitby_key)) { + if (length(groups) > 0) { + grp <- as.list(groups) + group_i <- lapply(grp, function(g) { + gx <- grep(g, colnames(means_mat), ...) + return(gx) + }) + group_id <- do.call(c, group_i) + means_mat <- means_mat[, as.vector(group_id), drop = FALSE] + if (dim(pvals_mat)[2] > 0) { + pvals_mat <- pvals_mat[, as.vector(group_id), drop = FALSE] + } else { + stop("No significant hits.") + } + } + } + if (keep_significant_only) { + if (dim(pvals_mat)[2] == 0) { + stop("No significant hits.") + } + } + if (cluster_rows) { + if (nrow(means_mat) > 2) { + requireNamespace("stats") + d <- stats::dist(as.data.frame(means_mat)) + h <- stats::hclust(d) + means_mat <- means_mat[h$order, , drop = FALSE] + } + } + # scaling + if (standard_scale) { + means_mat2 <- apply(means_mat, 1, range01) + means_mat2 <- t(means_mat2) } else { - labels <- metadata[[celltype_key]] - labels <- factor(labels) - labels <- levels(labels) - c_type1 <- as.list(grep(cell_type1, labels, value = TRUE, ...)) - c_type2 <- as.list(grep(cell_type2, labels, value = TRUE, ...)) - c_type1 <- lapply(c_type1, .sub_pattern, pattern = special_character_regex_pattern) - c_type2 <- lapply(c_type2, .sub_pattern, pattern = special_character_regex_pattern) - celltype <- list() - for (i in 1:length(c_type1)) { - celltype[[i]] <- .create_celltype_query( - ctype1 = c_type1[[i]], ctype2 = c_type2, - sep = DEFAULT_SEP - ) - } - cell_type <- do.call(paste0, list(celltype, collapse = "|")) + means_mat2 <- means_mat } - } else { - labels <- metadata[[celltype_key]] - labels <- factor(labels) - labels <- levels(labels) - c_type1 <- as.list(grep(cell_type1, labels, value = TRUE)) - c_type2 <- as.list(grep(cell_type2, labels, value = TRUE)) - c_type1 <- lapply(c_type1, .sub_pattern, pattern = special_character_regex_pattern) - c_type2 <- lapply(c_type2, .sub_pattern, pattern = special_character_regex_pattern) - celltype <- list() - for (i in 1:length(c_type1)) { - celltype[[i]] <- .create_celltype_query( - ctype1 = c_type1[[i]], ctype2 = c_type2, - sep = DEFAULT_SEP - ) + # remove rows that are entirely 0 + whichempty <- which(rowSums(means_mat2) == 0) + if (length(whichempty) > 0) { + means_mat2 <- means_mat2[whichempty, , drop = FALSE] } - cell_type <- do.call(paste0, list(celltype, collapse = "|")) - } - if (!is.null(gene_family) & is.null(genes)) { - if (length(gene_family) == 1) { - means_mat <- .prep_data_querygroup_celltype1( - .data = means_mat, .query_group = query_group, - .gene_family = gene_family, .cell_type = cell_type, .celltype = celltype, - ... - ) - pvals_mat <- .prep_data_querygroup_celltype1( - .data = pvals_mat, .query_group = query_group, - .gene_family = gene_family, .cell_type = cell_type, .celltype = celltype, - ... - ) - if (!is.null(interaction_scores)) { - interaction_scores_mat <- .prep_data_querygroup_celltype1( - .data = interaction_scores_mat, - .query_group = query_group, .gene_family = gene_family, .cell_type = cell_type, - .celltype = celltype, ... - ) - } else if (!is.null(cellsign)) { - cellsign_mat <- .prep_data_querygroup_celltype1( - .data = cellsign_mat, - .query_group = query_group, .gene_family = gene_family, .cell_type = cell_type, - .celltype = celltype, ... - ) - } - } else if (length(gene_family) > 1) { - means_mat <- .prep_data_querygroup_celltype2( - .data = means_mat, .query_group = query_group, - .gene_family = gene_family, .cell_type = cell_type, .celltype = celltype, - ... - ) - pvals_mat <- .prep_data_querygroup_celltype2( - .data = pvals_mat, .query_group = query_group, - .gene_family = gene_family, .cell_type = cell_type, .celltype = celltype, - ... - ) - if (!is.null(interaction_scores)) { - interaction_scores_mat <- .prep_data_querygroup_celltype2( - .data = interaction_scores_mat, - .query_group = query_group, .gene_family = gene_family, .cell_type = cell_type, - .celltype = celltype, ... - ) - } else if (!is.null(cellsign)) { - cellsign_mat <- .prep_data_querygroup_celltype2( - .data = cellsign_mat, - .query_group = query_group, .gene_family = gene_family, .cell_type = cell_type, - .celltype = celltype, ... - ) - } + means_mat2 <- as.matrix(means_mat2) + requireNamespace("reshape2") + if (standard_scale) { + df_means <- reshape2::melt(means_mat2, value.name = "scaled_means") + } else { + df_means <- reshape2::melt(means_mat2, value.name = "means") } - } else if (is.null(gene_family) & !is.null(genes) | is.null(gene_family) & is.null(genes)) { - means_mat <- .prep_data_query_celltype( - .data = means_mat, .query = query, - .cell_type = cell_type, .celltype = celltype, ... - ) - pvals_mat <- .prep_data_query_celltype( - .data = pvals_mat, .query = query, - .cell_type = cell_type, .celltype = celltype, ... - ) + pvals_mat2 <- as.matrix(pvals_mat) + df_pvals <- reshape2::melt(pvals_mat2, value.name = "pvals") if (!is.null(interaction_scores)) { - interaction_scores_mat <- .prep_data_query_celltype( - .data = interaction_scores_mat, - .query = query, .cell_type = cell_type, .celltype = celltype, ... - ) + interaction_scores_mat2 <- as.matrix(interaction_scores_mat) + df_interaction_scores <- reshape2::melt(interaction_scores_mat2, value.name = "interaction_scores") } else if (!is.null(cellsign)) { - cellsign_mat <- cellsign_mat[, col_start:ncol(cellsign_mat)] # too difficult to code is properly? - } - # } else if (!is.null(cellsign)) { cellsign_mat <- - # .prep_data_query_celltype( .data = cellsign_mat, .query = query, - # .cell_type = cell_type, .celltype = celltype, ... ) } - } - - # rearrange the columns so that it interleaves the two groups - if (!is.null(splitby_key)) { - if (length(groups) > 0) { - grp <- as.list(groups) - group_i <- lapply(grp, function(g) { - gx <- grep(g, colnames(means_mat), ...) - return(gx) - }) - group_id <- do.call(c, group_i) - means_mat <- means_mat[, as.vector(group_id), drop = FALSE] - if (dim(pvals_mat)[2] > 0) { - pvals_mat <- pvals_mat[, as.vector(group_id), drop = FALSE] - } else { - stop("No significant hits.") - } + cellsign_mat2 <- as.matrix(cellsign_mat) + df_cellsign <- reshape2::melt(cellsign_mat2, value.name = "cellsign") } - } - if (keep_significant_only) { - if (dim(pvals_mat)[2] == 0) { - stop("No significant hits.") + # use dplyr left_join to combine df_means and the pvals column in df_pvals. + # df_means and df_pvals should have the same Var1 and Var2. non-mathc should + # fill with NA. + df <- dplyr::left_join(df_means, df_pvals, by = c("Var1", "Var2")) + if (!is.null(interaction_scores)) { + df <- dplyr::left_join(df, df_interaction_scores, by = c("Var1", "Var2")) + } else if (!is.null(cellsign)) { + df <- dplyr::left_join(df, df_cellsign, by = c("Var1", "Var2")) } - } - if (cluster_rows) { - if (nrow(means_mat) > 2) { - requireNamespace("stats") - d <- stats::dist(as.data.frame(means_mat)) - h <- stats::hclust(d) - means_mat <- means_mat[h$order, , drop = FALSE] + xp <- which(df$pvals == 1) + if (length(xp) > 0) { + df$pvals[which(df$pvals == 1)] <- NA } - } - # scaling - if (standard_scale) { - means_mat2 <- apply(means_mat, 1, range01) - means_mat2 <- t(means_mat2) - } else { - means_mat2 <- means_mat - } - # remove rows that are entirely 0 - whichempty <- which(rowSums(means_mat2) == 0) - if (length(whichempty) > 0) { - means_mat2 <- means_mat2[whichempty, , drop = FALSE] - } - means_mat2 <- as.matrix(means_mat2) - requireNamespace("reshape2") - if (standard_scale) { - df_means <- reshape2::melt(means_mat2, value.name = "scaled_means") - } else { - df_means <- reshape2::melt(means_mat2, value.name = "means") - } - pvals_mat2 <- as.matrix(pvals_mat) - df_pvals <- reshape2::melt(pvals_mat2, value.name = "pvals") - if (!is.null(interaction_scores)) { - interaction_scores_mat2 <- as.matrix(interaction_scores_mat) - df_interaction_scores <- reshape2::melt(interaction_scores_mat2, value.name = "interaction_scores") - } else if (!is.null(cellsign)) { - cellsign_mat2 <- as.matrix(cellsign_mat) - df_cellsign <- reshape2::melt(cellsign_mat2, value.name = "cellsign") - } - # use dplyr left_join to combine df_means and the pvals column in df_pvals. - # df_means and df_pvals should have the same Var1 and Var2. non-mathc should - # fill with NA. - df <- dplyr::left_join(df_means, df_pvals, by = c("Var1", "Var2")) - if (!is.null(interaction_scores)) { - df <- dplyr::left_join(df, df_interaction_scores, by = c("Var1", "Var2")) - } else if (!is.null(cellsign)) { - df <- dplyr::left_join(df, df_cellsign, by = c("Var1", "Var2")) - } - xp <- which(df$pvals == 1) - if (length(xp) > 0) { - df$pvals[which(df$pvals == 1)] <- NA - } - if (keep_significant_only) { - # keep the entire row/ all the comparisons - df_ <- split(df, as.character(df$Var1)) - anysig <- lapply(df_, function(x) { - keep <- any(x$pvals < 0.05) - return(keep) - }) - df_ <- df_[which(unlist(anysig) == TRUE)] - names(df_) <- NULL - df <- do.call(rbind, df_) - } - df$pvals[which(df$pvals == 0)] <- 10^-result_precision - df$pvals[which(df$pvals >= 0.05)] <- NA - if (!is.null(splitby_key)) { - if (length(groups) > 0) { - grp <- as.list(groups) - grp2 <- lapply(grp, function(i) { - x <- paste0(i, "_") - return(x) - }) - searchterm <- do.call(paste, list(grp2, collapse = "|")) - df$group <- gsub(searchterm, "", df$Var2) + if (keep_significant_only) { + # keep the entire row/ all the comparisons + df_ <- split(df, as.character(df$Var1)) + anysig <- lapply(df_, function(x) { + keep <- any(x$pvals < 0.05) + return(keep) + }) + df_ <- df_[which(unlist(anysig) == TRUE)] + names(df_) <- NULL + df <- do.call(rbind, df_) } - } else { - df$group <- df$Var2 - } - if (keep_significant_only) { - if (standard_scale) { - if (length(df$scaled_means) == 0) { - stop("No significant genes found and plotting will not proceed.") - } + df$pvals[which(df$pvals == 0)] <- 10^-result_precision + df$pvals[which(df$pvals >= 0.05)] <- NA + if (!is.null(splitby_key)) { + if (length(groups) > 0) { + grp <- as.list(groups) + grp2 <- lapply(grp, function(i) { + x <- paste0(i, "_") + return(x) + }) + searchterm <- do.call(paste, list(grp2, collapse = "|")) + df$group <- gsub(searchterm, "", df$Var2) + } } else { - if (length(df$means) == 0) { - stop("No significant genes found and plotting will not proceed.") - } + df$group <- df$Var2 } - } - row.names(df) <- paste0( - df$Var1, paste0(rep(DEFAULT_SEP, 3), collapse = ""), - df$Var2 - ) - df$Var2 <- gsub(DEFAULT_SEP, "-", df$Var2) - final_levels <- unique(df$Var2) - df$Var2 <- factor(df$Var2, unique(df$Var2)) - df$x_means_ <- df[, colnames(df_means)[3]] - df$x_means_[df[, colnames(df)[4]] < 0.05] <- NA - df$x_stroke <- df$x_means_ - df$x_stroke[!is.na(df$x_stroke)] <- 0 - df$x_stroke[is.na(df$x_stroke)] <- 2 - if (!is.null(exclude_interactions)) { - df <- df[!df$Var1 %in% c(exclude_interactions), ] - } - if (!is.null(interaction_scores)) { - df$x_means_[which(df$interaction_scores < 0)] <- NA - } else if (!is.null(cellsign)) { - df$cellsign[which(df$cellsign < 1)] <- 0.5 - } - df$significant <- ifelse(df$pvals < 0.05, "yes", NA) - if (all(is.na(df$significant))) { - df$significant <- "no" - highlight_col <- "#ffffff" - } - if (default_style) { - df$significant[is.na(df$significant)] <- "no" - } - if (col_start == DEFAULT_V5_COL_START) { - requireNamespace("tibble") - df <- dplyr::left_join(df %>% - tibble::rownames_to_column(), v5tmp %>% - tibble::rownames_to_column(), by = "rowname") - row.names(df) <- df$rowname - } - - if (return_table) { - return(df) - } else { - # change the label of Var1 - if (keep_id_cp_interaction) { - df$Var1 <- gsub(SPECIAL_SEP, "_", df$Var1) - } else { - df$Var1 <- gsub(paste0(".*", SPECIAL_SEP), "", df$Var1) + if (keep_significant_only) { + if (standard_scale) { + if (length(df$scaled_means) == 0) { + stop("No significant genes found and plotting will not proceed.") + } + } else { + if (length(df$means) == 0) { + stop("No significant genes found and plotting will not proceed.") + } + } + } + row.names(df) <- paste0( + df$Var1, paste0(rep(DEFAULT_SEP, 3), collapse = ""), + df$Var2 + ) + df$Var2 <- gsub(DEFAULT_SEP, "-", df$Var2) + final_levels <- unique(df$Var2) + df$Var2 <- factor(df$Var2, unique(df$Var2)) + df$x_means_ <- df[, colnames(df_means)[3]] + df$x_means_[df[, colnames(df)[4]] < 0.05] <- NA + df$x_stroke <- df$x_means_ + df$x_stroke[!is.na(df$x_stroke)] <- 0 + df$x_stroke[is.na(df$x_stroke)] <- 2 + if (!is.null(exclude_interactions)) { + df <- df[!df$Var1 %in% c(exclude_interactions), ] } if (!is.null(interaction_scores)) { - requireNamespace("dplyr") - df <- df %>% - dplyr::filter(interaction_scores >= min_interaction_score) - if (scale_alpha_by_interaction_scores == TRUE) { - if (default_style) { - if (standard_scale) { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = scaled_means, size = scaled_means, alpha = interaction_scores - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = means, size = means, alpha = interaction_scores - )) - } + df$x_means_[which(df$interaction_scores < 0)] <- NA + } else if (!is.null(cellsign)) { + df$cellsign[which(df$cellsign < 1)] <- 0.5 + } + df$significant <- ifelse(df$pvals < 0.05, "yes", NA) + if (all(is.na(df$significant))) { + df$significant <- "no" + highlight_col <- "#ffffff" + } + if (default_style) { + df$significant[is.na(df$significant)] <- "no" + } + if (col_start == DEFAULT_V5_COL_START) { + requireNamespace("tibble") + df <- dplyr::left_join(df %>% + tibble::rownames_to_column(), v5tmp %>% + tibble::rownames_to_column(), by = "rowname") + row.names(df) <- df$rowname + } + + if (return_table) { + return(df) + } else { + # change the label of Var1 + if (keep_id_cp_interaction) { + df$Var1 <- gsub(SPECIAL_SEP, "_", df$Var1) } else { - if (all(df$significant == "no")) { - if (standard_scale) { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = scaled_means, size = scaled_means, alpha = interaction_scores - )) + df$Var1 <- gsub(paste0(".*", SPECIAL_SEP), "", df$Var1) + } + if (!is.null(interaction_scores)) { + requireNamespace("dplyr") + df <- df %>% + dplyr::filter(interaction_scores >= min_interaction_score) + if (scale_alpha_by_interaction_scores == TRUE) { + if (default_style) { + if (standard_scale) { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = scaled_means, size = scaled_means, alpha = interaction_scores + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = means, size = means, alpha = interaction_scores + )) + } + } else { + if (all(df$significant == "no")) { + if (standard_scale) { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = scaled_means, size = scaled_means, alpha = interaction_scores + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = means, size = means, alpha = interaction_scores + )) + } + default_style <- TRUE + } else { + highlight_col <- "#FFFFFF" # enforce this + if (standard_scale) { + if (!is.null(highlight_size)) { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = scaled_means, size = scaled_means, stroke = highlight_size, + alpha = interaction_scores + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = scaled_means, size = scaled_means, stroke = x_stroke, + alpha = interaction_scores + )) + } + } else { + if (!is.null(highlight_size)) { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = means, size = means, stroke = highlight_size, + alpha = interaction_scores + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = means, size = means, stroke = x_stroke, alpha = interaction_scores + )) + } + } + } + } } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = means, size = means, alpha = interaction_scores - )) + if (default_style) { + if (standard_scale) { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = scaled_means, size = scaled_means + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = means, size = means + )) + } + } else { + if (all(df$significant == "no")) { + if (standard_scale) { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = scaled_means, size = scaled_means + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = means, size = means + )) + } + default_style <- TRUE + } else { + highlight_col <- "#FFFFFF" # enforce this + if (standard_scale) { + if (!is.null(highlight_size)) { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = scaled_means, size = scaled_means, stroke = highlight_size + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = scaled_means, size = scaled_means, stroke = x_stroke + )) + } + } else { + if (!is.null(highlight_size)) { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = means, size = means, stroke = highlight_size + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = means, size = means, stroke = x_stroke + )) + } + } + } + } } - default_style <- TRUE - } else { - highlight_col <- "#FFFFFF" # enforce this - if (standard_scale) { - if (!is.null(highlight_size)) { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = scaled_means, size = scaled_means, stroke = highlight_size, - alpha = interaction_scores - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = scaled_means, size = scaled_means, stroke = x_stroke, - alpha = interaction_scores - )) - } - } else { - if (!is.null(highlight_size)) { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = means, size = means, stroke = highlight_size, - alpha = interaction_scores - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = means, size = means, stroke = x_stroke, alpha = interaction_scores - )) - } + } else if (!is.null(cellsign)) { + if (filter_by_cellsign == TRUE) { + requireNamespace("dplyr") + df <- df %>% + dplyr::filter(!is.na(cellsign)) + df <- df %>% + dplyr::group_by(Var1) %>% + dplyr::filter(dplyr::n_distinct(significant) > 1) %>% + as.data.frame() } - } - } - } else { - if (default_style) { - if (standard_scale) { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = scaled_means, size = scaled_means - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = means, size = means - )) - } - } else { - if (all(df$significant == "no")) { - if (standard_scale) { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = scaled_means, size = scaled_means - )) + if (scale_alpha_by_cellsign == TRUE) { + if (default_style) { + if (standard_scale) { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = scaled_means, size = scaled_means, alpha = cellsign + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = means, size = means, alpha = cellsign + )) + } + } else { + if (all(df$significant == "no")) { + if (standard_scale) { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = scaled_means, size = scaled_means, alpha = cellsign + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = means, size = means, alpha = cellsign + )) + } + default_style <- TRUE + } else { + highlight_col <- "#FFFFFF" # enforce this + if (standard_scale) { + if (!is.null(highlight_size)) { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = scaled_means, size = scaled_means, stroke = highlight_size, + alpha = cellsign + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = scaled_means, size = scaled_means, stroke = x_stroke, + alpha = cellsign + )) + } + } else { + if (!is.null(highlight_size)) { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = means, size = means, stroke = highlight_size, + alpha = cellsign + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = means, size = means, stroke = x_stroke, alpha = cellsign + )) + } + } + } + } } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = means, size = means - )) + if (default_style) { + if (standard_scale) { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = scaled_means, size = scaled_means + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = means, size = means + )) + } + } else { + if (all(df$significant == "no")) { + if (standard_scale) { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = scaled_means, size = scaled_means + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = means, size = means + )) + } + default_style <- TRUE + } else { + highlight_col <- "#FFFFFF" # enforce this + if (standard_scale) { + if (!is.null(highlight_size)) { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = scaled_means, size = scaled_means, stroke = highlight_size + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = scaled_means, size = scaled_means, stroke = x_stroke + )) + } + } else { + if (!is.null(highlight_size)) { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = means, size = means, stroke = highlight_size + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = means, size = means, stroke = x_stroke + )) + } + } + } + } } - default_style <- TRUE - } else { - highlight_col <- "#FFFFFF" # enforce this - if (standard_scale) { - if (!is.null(highlight_size)) { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = scaled_means, size = scaled_means, stroke = highlight_size - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = scaled_means, size = scaled_means, stroke = x_stroke - )) - } + } else { + if (default_style) { + if (standard_scale) { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, fill = scaled_means, + size = scaled_means + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, fill = means, + size = means + )) + } } else { - if (!is.null(highlight_size)) { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = means, size = means, stroke = highlight_size - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = means, size = means, stroke = x_stroke - )) - } + if (all(df$significant == "no")) { + if (standard_scale) { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = scaled_means, size = scaled_means + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, color = significant, + fill = means, size = means + )) + } + default_style <- TRUE + } else { + highlight_col <- "#FFFFFF" # enforce this + if (standard_scale) { + if (!is.null(highlight_size)) { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = scaled_means, size = scaled_means, stroke = highlight_size + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = scaled_means, size = scaled_means, stroke = x_stroke + )) + } + } else { + if (!is.null(highlight_size)) { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = means, size = means, stroke = highlight_size + )) + } else { + g <- ggplot(df, aes( + x = Var2, y = Var1, fill = significant, + colour = means, size = means, stroke = x_stroke + )) + } + } + } } - } } - } - } else if (!is.null(cellsign)) { - if (filter_by_cellsign == TRUE) { - requireNamespace("dplyr") - df <- df %>% - dplyr::filter(!is.na(cellsign)) - df <- df %>% - dplyr::group_by(Var1) %>% - dplyr::filter(dplyr::n_distinct(significant) > 1) %>% - as.data.frame() - } - if (scale_alpha_by_cellsign == TRUE) { + g <- g + geom_point(pch = 21, na.rm = TRUE) + theme_bw() + theme( + axis.text.x = element_text( + angle = 45, + hjust = 0, color = "#000000" + ), axis.text.y = element_text(color = "#000000"), + axis.title.x = element_blank(), axis.title.y = element_blank(), legend.direction = "vertical", + legend.box = "horizontal" + ) + scale_x_discrete(position = "top") + scale_radius(range = c( + 0, + max_size + )) + scale_linewidth(range = c(0, max_highlight_size)) if (default_style) { - if (standard_scale) { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = scaled_means, size = scaled_means, alpha = cellsign - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = means, size = means, alpha = cellsign - )) - } - } else { - if (all(df$significant == "no")) { - if (standard_scale) { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = scaled_means, size = scaled_means, alpha = cellsign - )) + g <- g + scale_colour_manual( + values = c(yes = highlight_col, no = "#ffffff"), + na.value = NA, na.translate = FALSE + ) + guides( + fill = guide_colourbar( + barwidth = 4, + label = TRUE, ticks = TRUE, draw.ulim = TRUE, draw.llim = TRUE, order = 1 + ), + size = guide_legend(reverse = TRUE, order = 2), stroke = guide_legend( + reverse = TRUE, + order = 3 + ) + ) + if (length(col_option) == 1) { + g <- g + scale_fill_gradientn(colors = (grDevices::colorRampPalette(c( + "white", + col_option + )))(100), na.value = "white") } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = means, size = means, alpha = cellsign - )) + g <- g + scale_fill_gradientn( + colors = c("white", (grDevices::colorRampPalette(col_option))(99)), + na.value = "white" + ) } - default_style <- TRUE - } else { - highlight_col <- "#FFFFFF" # enforce this - if (standard_scale) { - if (!is.null(highlight_size)) { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = scaled_means, size = scaled_means, stroke = highlight_size, - alpha = cellsign - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = scaled_means, size = scaled_means, stroke = x_stroke, - alpha = cellsign - )) - } - } else { - if (!is.null(highlight_size)) { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = means, size = means, stroke = highlight_size, - alpha = cellsign - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = means, size = means, stroke = x_stroke, alpha = cellsign - )) - } - } - } - } - } else { - if (default_style) { - if (standard_scale) { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = scaled_means, size = scaled_means - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = means, size = means - )) - } } else { - if (all(df$significant == "no")) { + g <- g + scale_fill_manual( + values = highlight_col, na.value = "#ffffff", + na.translate = TRUE + ) + guides( + colour = guide_colourbar( + barwidth = 4, + label = TRUE, ticks = TRUE, draw.ulim = TRUE, draw.llim = TRUE, order = 1 + ), + size = guide_legend(reverse = TRUE, order = 2), stroke = guide_legend( + reverse = TRUE, + order = 3 + ) + ) + df2 <- df if (standard_scale) { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = scaled_means, size = scaled_means - )) + df2$scaled_means[df$pvals < 0.05] <- NA + g <- g + geom_point(aes( + x = Var2, y = Var1, colour = scaled_means, + size = scaled_means + ), data = df2, inherit.aes = FALSE, na.rm = TRUE) } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = means, size = means - )) + df2$means[df$pvals < 0.05] <- NA + g <- g + geom_point(aes(x = Var2, y = Var1, colour = means, size = means), + data = df2, inherit.aes = FALSE, na.rm = TRUE + ) } - default_style <- TRUE - } else { - highlight_col <- "#FFFFFF" # enforce this - if (standard_scale) { - if (!is.null(highlight_size)) { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = scaled_means, size = scaled_means, stroke = highlight_size - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = scaled_means, size = scaled_means, stroke = x_stroke - )) - } + if (length(col_option) == 1) { + g <- g + scale_colour_gradientn(colors = (grDevices::colorRampPalette(c( + "white", + col_option + )))(100), na.value = "white") } else { - if (!is.null(highlight_size)) { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = means, size = means, stroke = highlight_size - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = means, size = means, stroke = x_stroke - )) - } + g <- g + scale_colour_gradientn( + colors = c("white", (grDevices::colorRampPalette(col_option))(99)), + na.value = "white" + ) } - } } - } - } else { - if (default_style) { - if (standard_scale) { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, fill = scaled_means, - size = scaled_means - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, fill = means, - size = means - )) + if (!is.null(interaction_scores) & (scale_alpha_by_interaction_scores == + TRUE)) { + g <- g + scale_alpha_continuous(breaks = c(0, 25, 50, 75, 100)) } - } else { - if (all(df$significant == "no")) { - if (standard_scale) { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = scaled_means, size = scaled_means - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, color = significant, - fill = means, size = means - )) - } - default_style <- TRUE - } else { - highlight_col <- "#FFFFFF" # enforce this - if (standard_scale) { - if (!is.null(highlight_size)) { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = scaled_means, size = scaled_means, stroke = highlight_size - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = scaled_means, size = scaled_means, stroke = x_stroke - )) - } - } else { - if (!is.null(highlight_size)) { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = means, size = means, stroke = highlight_size - )) - } else { - g <- ggplot(df, aes( - x = Var2, y = Var1, fill = significant, - colour = means, size = means, stroke = x_stroke - )) + if (!is.null(cellsign) & (scale_alpha_by_cellsign == TRUE)) { + g <- g + scale_alpha_continuous(breaks = c(0, 1)) + } + if (!is.null(highlight_size)) { + g <- g + guides(stroke = "none") + } + if (title != "") { + g <- g + ggtitle(title) + } else if (!is.null(gene_family) & is.null(genes)) { + if (length(gene_family) > 1) { + gene_family <- paste(gene_family, collapse = ", ") } - } + g <- g + ggtitle(gene_family) } - } - } - g <- g + geom_point(pch = 21, na.rm = TRUE) + theme_bw() + theme( - axis.text.x = element_text( - angle = 45, - hjust = 0, color = "#000000" - ), axis.text.y = element_text(color = "#000000"), - axis.title.x = element_blank(), axis.title.y = element_blank(), legend.direction = "vertical", - legend.box = "horizontal" - ) + scale_x_discrete(position = "top") + scale_radius(range = c( - 0, - max_size - )) + scale_linewidth(range = c(0, max_highlight_size)) - if (default_style) { - g <- g + scale_colour_manual( - values = c(yes = highlight_col, no = "#ffffff"), - na.value = NA, na.translate = FALSE - ) + guides( - fill = guide_colourbar( - barwidth = 4, - label = TRUE, ticks = TRUE, draw.ulim = TRUE, draw.llim = TRUE, order = 1 - ), - size = guide_legend(reverse = TRUE, order = 2), stroke = guide_legend( - reverse = TRUE, - order = 3 - ) - ) - if (length(col_option) == 1) { - g <- g + scale_fill_gradientn(colors = (grDevices::colorRampPalette(c( - "white", - col_option - )))(100), na.value = "white") - } else { - g <- g + scale_fill_gradientn( - colors = c("white", (grDevices::colorRampPalette(col_option))(99)), - na.value = "white" - ) - } - } else { - g <- g + scale_fill_manual( - values = highlight_col, na.value = "#ffffff", - na.translate = TRUE - ) + guides( - colour = guide_colourbar( - barwidth = 4, - label = TRUE, ticks = TRUE, draw.ulim = TRUE, draw.llim = TRUE, order = 1 - ), - size = guide_legend(reverse = TRUE, order = 2), stroke = guide_legend( - reverse = TRUE, - order = 3 - ) - ) - df2 <- df - if (standard_scale) { - df2$scaled_means[df$pvals < 0.05] <- NA - g <- g + geom_point(aes( - x = Var2, y = Var1, colour = scaled_means, - size = scaled_means - ), data = df2, inherit.aes = FALSE, na.rm = TRUE) - } else { - df2$means[df$pvals < 0.05] <- NA - g <- g + geom_point(aes(x = Var2, y = Var1, colour = means, size = means), - data = df2, inherit.aes = FALSE, na.rm = TRUE - ) - } - if (length(col_option) == 1) { - g <- g + scale_colour_gradientn(colors = (grDevices::colorRampPalette(c( - "white", - col_option - )))(100), na.value = "white") - } else { - g <- g + scale_colour_gradientn( - colors = c("white", (grDevices::colorRampPalette(col_option))(99)), - na.value = "white" - ) - } - } - if (!is.null(interaction_scores) & (scale_alpha_by_interaction_scores == - TRUE)) { - g <- g + scale_alpha_continuous(breaks = c(0, 25, 50, 75, 100)) - } - if (!is.null(cellsign) & (scale_alpha_by_cellsign == TRUE)) { - g <- g + scale_alpha_continuous(breaks = c(0, 1)) - } - if (!is.null(highlight_size)) { - g <- g + guides(stroke = "none") - } - if (title != "") { - g <- g + ggtitle(title) - } else if (!is.null(gene_family) & is.null(genes)) { - if (length(gene_family) > 1) { - gene_family <- paste(gene_family, collapse = ", ") - } - g <- g + ggtitle(gene_family) + return(g) } - return(g) - } } diff --git a/R/plot_cpdb2.R b/R/plot_cpdb2.R index 5eb2a998..e79a03cb 100644 --- a/R/plot_cpdb2.R +++ b/R/plot_cpdb2.R @@ -32,7 +32,8 @@ #' @import ggrepel #' @export -plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pvals, +plot_cpdb2 <- function( + scdata, cell_type1, cell_type2, celltype_key, means, pvals, deconvoluted, keep_significant_only = TRUE, splitby_key = NULL, standard_scale = TRUE, gene_symbol_mapping = NULL, frac = 0.1, remove_self = TRUE, desiredInteractions = NULL, interaction_grouping = NULL, edge_group_colors = NULL, node_group_colors = NULL, @@ -40,10 +41,12 @@ plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval if (class(scdata) == "Seurat") { stop("Sorry not supported. Please use a SingleCellExperiment object.") } - lr_interactions <- plot_cpdb(scdata = scdata, cell_type1 = cell_type1, cell_type2 = cell_type2, + lr_interactions <- plot_cpdb( + scdata = scdata, cell_type1 = cell_type1, cell_type2 = cell_type2, celltype_key = celltype_key, splitby_key = splitby_key, means = means, pvals = pvals, keep_significant_only = keep_significant_only, standard_scale = standard_scale, - return_table = TRUE, degs_analysis = degs_analysis, ...) + return_table = TRUE, degs_analysis = degs_analysis, ... + ) requireNamespace("SummarizedExperiment") requireNamespace("SingleCellExperiment") means_col <- grep("scaled_means|means", names(lr_interactions), value = TRUE)[1] @@ -51,35 +54,46 @@ plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval if (any(lr_interactions[, means_col] > 0)) { if (any(is.na(lr_interactions[, means_col]))) { lr_interactions <- lr_interactions[lr_interactions[, means_col] > - 0 & !is.na(lr_interactions[, means_col]), ] + 0 & !is.na(lr_interactions[, means_col]), ] } else { lr_interactions <- lr_interactions[lr_interactions[, means_col] > - 0, ] + 0, ] } } } - subset_clusters <- unique(unlist(lapply(as.character(lr_interactions$group), - strsplit, DEFAULT_SEP))) + subset_clusters <- unique(unlist(lapply( + as.character(lr_interactions$group), + strsplit, DEFAULT_SEP + ))) sce_subset <- scdata[, SummarizedExperiment::colData(scdata)[, celltype_key] %in% subset_clusters] - interactions <- means[, c("id_cp_interaction", "interacting_pair", "gene_a", - "gene_b", "partner_a", "partner_b", "receptor_a", "receptor_b")] - interactions$use_interaction_name <- paste0(interactions$id_cp_interaction, SPECIAL_SEP, - interactions$interacting_pair) + interactions <- means[, c( + "id_cp_interaction", "interacting_pair", "gene_a", + "gene_b", "partner_a", "partner_b", "receptor_a", "receptor_b" + )] + interactions$use_interaction_name <- paste0( + interactions$id_cp_interaction, SPECIAL_SEP, + interactions$interacting_pair + ) interactions$converted <- gsub("_", "-", interactions$use_interaction_name) interactions$use_interaction_name <- interactions$interacting_pair - interactions_subset <- interactions[interactions$converted %in% lr_interactions$Var1, - ] - tm0 <- do.call(c, lapply(as.list(interactions_subset$use_interaction_name), strsplit, - "_")) + interactions_subset <- interactions[interactions$converted %in% lr_interactions$Var1, ] + tm0 <- do.call(c, lapply( + as.list(interactions_subset$use_interaction_name), strsplit, + "_" + )) if (any(lapply(tm0, length) > 2)) { complex_id <- which(lapply(tm0, length) > 2) interactions_subset_ <- interactions_subset[complex_id, ] simple_1 <- interactions_subset_$interacting_pair[grep("complex:", interactions_subset_$partner_b)] - partner_1 <- gsub("complex:", "", interactions_subset_$partner_b[grep("complex:", - interactions_subset_$partner_b)]) - partner_2 <- gsub("complex:", "", interactions_subset_$partner_a[grep("complex:", - interactions_subset_$partner_a)]) + partner_1 <- gsub("complex:", "", interactions_subset_$partner_b[grep( + "complex:", + interactions_subset_$partner_b + )]) + partner_2 <- gsub("complex:", "", interactions_subset_$partner_a[grep( + "complex:", + interactions_subset_$partner_a + )]) simple_2 <- interactions_subset_$interacting_pair[grep("complex:", interactions_subset_$partner_a)] for (i in seq_along(simple_1)) { simple_1[i] <- gsub(paste0(partner_1[i], "_|_", partner_1[i]), "", simple_1[i]) @@ -92,23 +106,29 @@ plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval for (i in seq_along(complex_id)) { tm0[[complex_id[i]]] <- tmplist[[i]] } - tm0 <- data.frame(t(matrix(unlist(tm0), 2, length(unlist(tm0))/2))) + tm0 <- data.frame(t(matrix(unlist(tm0), 2, length(unlist(tm0)) / 2))) colnames(tm0) <- c("id_a", "id_b") interactions_subset <- cbind(interactions_subset, tm0) - dictionary <- interactions_subset[, c("id_cp_interaction", "gene_a", "gene_b", - "partner_a", "partner_b", "id_a", "id_b", "receptor_a", "receptor_b")] + dictionary <- interactions_subset[, c( + "id_cp_interaction", "gene_a", "gene_b", + "partner_a", "partner_b", "id_a", "id_b", "receptor_a", "receptor_b" + )] } else { - tm0 <- data.frame(t(matrix(unlist(tm0), 2, length(unlist(tm0))/2))) + tm0 <- data.frame(t(matrix(unlist(tm0), 2, length(unlist(tm0)) / 2))) colnames(tm0) <- c("id_a", "id_b") tm0$id_a <- gsub(paste0(".*", SPECIAL_SEP), "", tm0$id_a) interactions_subset <- cbind(interactions_subset, tm0) - dictionary <- interactions_subset[, c("id_cp_interaction", "gene_a", "gene_b", - "partner_a", "partner_b", "id_a", "id_b", "receptor_a", "receptor_b")] + dictionary <- interactions_subset[, c( + "id_cp_interaction", "gene_a", "gene_b", + "partner_a", "partner_b", "id_a", "id_b", "receptor_a", "receptor_b" + )] } if (!is.null(interaction_grouping)) { if ((class(interaction_grouping) == "data.frame")) { - interactions_subset$group <- interaction_grouping[, 2][match(interactions_subset$interacting_pair, - interaction_grouping[, 1])] + interactions_subset$group <- interaction_grouping[, 2][match( + interactions_subset$interacting_pair, + interaction_grouping[, 1] + )] } } # extract all the possible genes. @@ -135,9 +155,9 @@ plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval for (n in names(sce_list)) { for (x in unique(meta[, celltype_key])) { sce_list[[n]][[x]] <- sce_subset_tmp[, meta[, celltype_key] == x & - meta[, splitby_key] == n] + meta[, splitby_key] == n] sce_list_alt[[n]][[x]] <- sce_subset[, meta[, celltype_key] == x & - meta[, splitby_key] == n] + meta[, splitby_key] == n] } } sce_list2 <- lapply(sce_list, function(y) { @@ -182,8 +202,7 @@ plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval } rownames(sce_list2) <- humanreadablename rownames(sce_list3) <- humanreadablename - decon_subset <- deconvoluted[deconvoluted$complex_name %in% .findComplex(interactions_subset), - ] + decon_subset <- deconvoluted[deconvoluted$complex_name %in% .findComplex(interactions_subset), ] if (nrow(decon_subset) > 0) { # although multiple rows are returned, really it's the same value for # the same complex @@ -197,14 +216,14 @@ plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval decon_subset_fraction <- lapply(decon_subset, function(x) { x <- unique(x$gene_name) test <- lapply(sce_list_alt, function(y) { - return(lapply(y, .cellTypeFraction_complex, genes = z, gene_symbol_mapping = gene_symbol_mapping)) + return(lapply(y, .cellTypeFraction_complex, genes = z, gene_symbol_mapping = gene_symbol_mapping)) }) return(test) }) decon_subset_fraction <- lapply(decon_subset_fraction, function(x) { y <- lapply(x, function(z) do.call(cbind, z)) for (i in 1:length(y)) { - colnames(y[[i]]) <- paste0(names(y[i]), "_", colnames(y[[i]])) + colnames(y[[i]]) <- paste0(names(y[i]), "_", colnames(y[[i]])) } y <- do.call(cbind, y) return(y) @@ -213,7 +232,7 @@ plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval decon_subset_fraction <- lapply(decon_subset, function(x) { z <- unique(x$gene_name) test <- lapply(sce_list_alt, function(y) { - return(.cellTypeFraction_complex(y, genes = z, gene_symbol_mapping = gene_symbol_mapping)) + return(.cellTypeFraction_complex(y, genes = z, gene_symbol_mapping = gene_symbol_mapping)) }) return(do.call(cbind, test)) }) @@ -233,8 +252,10 @@ plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval # make a big fat edgelist if (!is.null(desiredInteractions)) { if (class(desiredInteractions) == "list") { - desiredInteractions_ <- c(desiredInteractions, lapply(desiredInteractions, - rev)) + desiredInteractions_ <- c(desiredInteractions, lapply( + desiredInteractions, + rev + )) cell_type_grid <- as.data.frame(do.call(rbind, desiredInteractions_)) } else if ((class(desiredInteractions) == "data.frame")) { cell_type_grid <- desiredInteractions @@ -265,19 +286,23 @@ plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval dfx <- list() if (!is.null(splitby_key)) { for (i in unique(meta[, splitby_key])) { - dfx[[i]] <- .generateDf(ligand = ligand, sep = DEFAULT_SEP, receptor = receptor, + dfx[[i]] <- .generateDf( + ligand = ligand, sep = DEFAULT_SEP, receptor = receptor, receptor_a = receptor_a, receptor_b = receptor_b, pair = pair, converted_pair = converted_pair, producers = producers, receivers = receivers, cell_type_means = expr_df, cell_type_fractions = fraction_df, sce = sce_subset, sce_alt = sce_list_alt, - gsm = gene_symbol_mapping, splitted = i) + gsm = gene_symbol_mapping, splitted = i + ) dfx[[i]] <- dfx[[i]][dfx[[i]]$barcode %in% barcodes, ] } } else { - dfx[[1]] <- .generateDf(ligand = ligand, sep = DEFAULT_SEP, receptor = receptor, + dfx[[1]] <- .generateDf( + ligand = ligand, sep = DEFAULT_SEP, receptor = receptor, receptor_a = receptor_a, receptor_b = receptor_b, pair = pair, converted_pair = converted_pair, producers = producers, receivers = receivers, cell_type_means = expr_df, cell_type_fractions = fraction_df, sce = sce_subset, sce_alt = sce_list_alt, - gsm = gene_symbol_mapping) + gsm = gene_symbol_mapping + ) dfx[[1]] <- dfx[[1]][dfx[[1]]$barcode %in% barcodes, ] } if (return_df) { @@ -286,7 +311,7 @@ plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval # set the bundled connections df0 <- lapply(dfx, function(x) { x[x$producer_fraction >= frac | x$receiver_fraction >= frac, ] - }) # save this for later + }) # save this for later # now construct the hierachy gl <- list() if (!is.null(interaction_grouping)) { @@ -299,31 +324,36 @@ plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval for (i in 1:length(dfx)) { if (!is.null(splitby_key)) { if (nrow(dfx[[i]]) > 0 & nrow(df0[[i]]) > 0) { - gl[[i]] <- .constructGraph(input_group = names(dfx)[i], sep = DEFAULT_SEP, - el = dfx[[i]], el0 = df0[[i]], unique_id = cells_test, interactions_df = interactions_subset, - plot_cpdb_out = lr_interactions, celltype_key = celltype_key, - meta = meta, edge_group = edge_group, edge_group_colors = edge_group_colors, - node_group_color = node_group_colors, plot_score_as_thickness = plot_score_as_thickness) + gl[[i]] <- .constructGraph( + input_group = names(dfx)[i], sep = DEFAULT_SEP, + el = dfx[[i]], el0 = df0[[i]], unique_id = cells_test, interactions_df = interactions_subset, + plot_cpdb_out = lr_interactions, celltype_key = celltype_key, + meta = meta, edge_group = edge_group, edge_group_colors = edge_group_colors, + node_group_color = node_group_colors, plot_score_as_thickness = plot_score_as_thickness + ) } else { - gl[[i]] <- NA - cantplot <- c(cantplot, names(dfx)[i]) + gl[[i]] <- NA + cantplot <- c(cantplot, names(dfx)[i]) } } else { if (nrow(dfx[[i]]) > 0 & nrow(df0[[i]]) > 0) { - gl[[i]] <- .constructGraph(input_group = NULL, sep = DEFAULT_SEP, - el = dfx[[i]], el0 = df0[[i]], unique_id = cells_test, interactions_df = interactions_subset, - plot_cpdb_out = lr_interactions, celltype_key = celltype_key, - meta = meta, edge_group = edge_group, edge_group_colors = edge_group_colors, - node_group_color = node_group_colors, plot_score_as_thickness = plot_score_as_thickness) + gl[[i]] <- .constructGraph( + input_group = NULL, sep = DEFAULT_SEP, + el = dfx[[i]], el0 = df0[[i]], unique_id = cells_test, interactions_df = interactions_subset, + plot_cpdb_out = lr_interactions, celltype_key = celltype_key, + meta = meta, edge_group = edge_group, edge_group_colors = edge_group_colors, + node_group_color = node_group_colors, plot_score_as_thickness = plot_score_as_thickness + ) } else { - gl[[i]] <- NA - noplot <- TRUE + gl[[i]] <- NA + noplot <- TRUE } } } if (length(cantplot) > 0) { cat("The following groups in splitby_key cannot be plotted due to missing/no significant interactions/celltypes", - sep = "\n") + sep = "\n" + ) cat(cantplot, sep = "\n") } if (noplot) { @@ -335,4 +365,4 @@ plot_cpdb2 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval return(gl[[1]]) } } -} \ No newline at end of file +} diff --git a/R/plot_cpdb3.R b/R/plot_cpdb3.R index c03010be..54b1b0fc 100644 --- a/R/plot_cpdb3.R +++ b/R/plot_cpdb3.R @@ -33,7 +33,8 @@ #' @importFrom grDevices recordPlot #' @export -plot_cpdb3 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pvals, +plot_cpdb3 <- function( + scdata, cell_type1, cell_type2, celltype_key, means, pvals, deconvoluted, keep_significant_only = TRUE, splitby_key = NULL, standard_scale = TRUE, gene_symbol_mapping = NULL, frac = 0.1, remove_self = TRUE, desiredInteractions = NULL, degs_analysis = FALSE, directional = 1, alpha = 0.5, edge_colors = NULL, grid_colors = NULL, @@ -41,10 +42,12 @@ plot_cpdb3 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval if (class(scdata) == "Seurat") { stop("Sorry not supported. Please use a SingleCellExperiment object.") } - lr_interactions <- plot_cpdb(scdata = scdata, cell_type1 = cell_type1, cell_type2 = cell_type2, + lr_interactions <- plot_cpdb( + scdata = scdata, cell_type1 = cell_type1, cell_type2 = cell_type2, celltype_key = celltype_key, splitby_key = splitby_key, means = means, pvals = pvals, keep_significant_only = keep_significant_only, standard_scale = standard_scale, - return_table = TRUE, degs_analysis = degs_analysis, ...) + return_table = TRUE, degs_analysis = degs_analysis, ... + ) requireNamespace("SummarizedExperiment") requireNamespace("SingleCellExperiment") means_col <- grep("scaled_means|means", names(lr_interactions), value = TRUE)[1] @@ -52,34 +55,45 @@ plot_cpdb3 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval if (any(lr_interactions[, means_col] > 0)) { if (any(is.na(lr_interactions[, means_col]))) { lr_interactions <- lr_interactions[lr_interactions[, means_col] > - 0 & !is.na(lr_interactions[, means_col]), ] + 0 & !is.na(lr_interactions[, means_col]), ] } else { lr_interactions <- lr_interactions[lr_interactions[, means_col] > - 0, ] + 0, ] } } } - subset_clusters <- unique(unlist(lapply(as.character(lr_interactions$group), - strsplit, DEFAULT_SEP))) + subset_clusters <- unique(unlist(lapply( + as.character(lr_interactions$group), + strsplit, DEFAULT_SEP + ))) sce_subset <- scdata[, SummarizedExperiment::colData(scdata)[, celltype_key] %in% subset_clusters] - interactions <- means[, c("id_cp_interaction", "interacting_pair", "gene_a", - "gene_b", "partner_a", "partner_b", "receptor_a", "receptor_b")] - interactions$use_interaction_name <- paste0(interactions$id_cp_interaction, SPECIAL_SEP, - interactions$interacting_pair) + interactions <- means[, c( + "id_cp_interaction", "interacting_pair", "gene_a", + "gene_b", "partner_a", "partner_b", "receptor_a", "receptor_b" + )] + interactions$use_interaction_name <- paste0( + interactions$id_cp_interaction, SPECIAL_SEP, + interactions$interacting_pair + ) interactions$converted <- gsub("_", "-", interactions$use_interaction_name) - interactions_subset <- interactions[interactions$converted %in% lr_interactions$Var1, - ] - tm0 <- do.call(c, lapply(as.list(interactions_subset$use_interaction_name), strsplit, - "_")) + interactions_subset <- interactions[interactions$converted %in% lr_interactions$Var1, ] + tm0 <- do.call(c, lapply( + as.list(interactions_subset$use_interaction_name), strsplit, + "_" + )) if (any(lapply(tm0, length) > 2)) { complex_id <- which(lapply(tm0, length) > 2) interactions_subset_ <- interactions_subset[complex_id, ] simple_1 <- interactions_subset_$interacting_pair[grep("complex:", interactions_subset_$partner_b)] - partner_1 <- gsub("complex:", "", interactions_subset_$partner_b[grep("complex:", - interactions_subset_$partner_b)]) - partner_2 <- gsub("complex:", "", interactions_subset_$partner_a[grep("complex:", - interactions_subset_$partner_a)]) + partner_1 <- gsub("complex:", "", interactions_subset_$partner_b[grep( + "complex:", + interactions_subset_$partner_b + )]) + partner_2 <- gsub("complex:", "", interactions_subset_$partner_a[grep( + "complex:", + interactions_subset_$partner_a + )]) simple_2 <- interactions_subset_$interacting_pair[grep("complex:", interactions_subset_$partner_a)] for (i in seq_along(simple_1)) { simple_1[i] <- gsub(paste0(partner_1[i], "_|_", partner_1[i]), "", simple_1[i]) @@ -92,18 +106,22 @@ plot_cpdb3 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval for (i in seq_along(complex_id)) { tm0[[complex_id[i]]] <- tmplist[[i]] } - tm0 <- data.frame(t(matrix(unlist(tm0), 2, length(unlist(tm0))/2))) + tm0 <- data.frame(t(matrix(unlist(tm0), 2, length(unlist(tm0)) / 2))) colnames(tm0) <- c("id_a", "id_b") interactions_subset <- cbind(interactions_subset, tm0) - dictionary <- interactions_subset[, c("id_cp_interaction", "gene_a", "gene_b", - "partner_a", "partner_b", "id_a", "id_b", "receptor_a", "receptor_b")] + dictionary <- interactions_subset[, c( + "id_cp_interaction", "gene_a", "gene_b", + "partner_a", "partner_b", "id_a", "id_b", "receptor_a", "receptor_b" + )] } else { - tm0 <- data.frame(t(matrix(unlist(tm0), 2, length(unlist(tm0))/2))) + tm0 <- data.frame(t(matrix(unlist(tm0), 2, length(unlist(tm0)) / 2))) colnames(tm0) <- c("id_a", "id_b") tm0$id_a <- gsub(paste0(".*", SPECIAL_SEP), "", tm0$id_a) interactions_subset <- cbind(interactions_subset, tm0) - dictionary <- interactions_subset[, c("id_cp_interaction", "gene_a", "gene_b", - "partner_a", "partner_b", "id_a", "id_b", "receptor_a", "receptor_b")] + dictionary <- interactions_subset[, c( + "id_cp_interaction", "gene_a", "gene_b", + "partner_a", "partner_b", "id_a", "id_b", "receptor_a", "receptor_b" + )] } # extract all the possible genes. geneid <- unique(c(interactions_subset$id_a, interactions_subset$id_b)) @@ -126,9 +144,9 @@ plot_cpdb3 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval for (n in names(sce_list)) { for (x in unique(meta[, celltype_key])) { sce_list[[n]][[x]] <- sce_subset_tmp[, meta[, celltype_key] == x & - meta[, splitby_key] == n] + meta[, splitby_key] == n] sce_list_alt[[n]][[x]] <- sce_subset[, meta[, celltype_key] == x & - meta[, splitby_key] == n] + meta[, splitby_key] == n] } } sce_list2 <- lapply(sce_list, function(y) { @@ -173,8 +191,7 @@ plot_cpdb3 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval } rownames(sce_list2) <- humanreadablename rownames(sce_list3) <- humanreadablename - decon_subset <- deconvoluted[deconvoluted$complex_name %in% .findComplex(interactions_subset), - ] + decon_subset <- deconvoluted[deconvoluted$complex_name %in% .findComplex(interactions_subset), ] if (nrow(decon_subset) > 0) { # although multiple rows are returned, really it's the same value for # the same complex @@ -188,14 +205,14 @@ plot_cpdb3 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval decon_subset_fraction <- lapply(decon_subset, function(x) { z <- unique(x$gene_name) test <- lapply(sce_list_alt, function(y) { - return(lapply(y, .cellTypeFraction_complex, genes = z, gene_symbol_mapping = gene_symbol_mapping)) + return(lapply(y, .cellTypeFraction_complex, genes = z, gene_symbol_mapping = gene_symbol_mapping)) }) return(test) }) decon_subset_fraction <- lapply(decon_subset_fraction, function(x) { y <- lapply(x, function(z) do.call(cbind, z)) for (i in 1:length(y)) { - colnames(y[[i]]) <- paste0(names(y[i]), "_", colnames(y[[i]])) + colnames(y[[i]]) <- paste0(names(y[i]), "_", colnames(y[[i]])) } y <- do.call(cbind, y) return(y) @@ -204,7 +221,7 @@ plot_cpdb3 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval decon_subset_fraction <- lapply(decon_subset, function(x) { z <- unique(x$gene_name) test <- lapply(sce_list_alt, function(y) { - return(.cellTypeFraction_complex(y, genes = z, gene_symbol_mapping = gene_symbol_mapping)) + return(.cellTypeFraction_complex(y, genes = z, gene_symbol_mapping = gene_symbol_mapping)) }) return(do.call(cbind, test)) }) @@ -224,8 +241,10 @@ plot_cpdb3 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval # make a big fat edgelist if (!is.null(desiredInteractions)) { if (class(desiredInteractions) == "list") { - desiredInteractions_ <- c(desiredInteractions, lapply(desiredInteractions, - rev)) + desiredInteractions_ <- c(desiredInteractions, lapply( + desiredInteractions, + rev + )) cell_type_grid <- as.data.frame(do.call(rbind, desiredInteractions_)) } else if ((class(desiredInteractions) == "data.frame")) { cell_type_grid <- desiredInteractions @@ -255,42 +274,54 @@ plot_cpdb3 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval dfx <- list() if (!is.null(splitby_key)) { for (i in unique(meta[, splitby_key])) { - dfx[[i]] <- .generateDf(ligand = ligand, sep = DEFAULT_SEP, receptor = receptor, + dfx[[i]] <- .generateDf( + ligand = ligand, sep = DEFAULT_SEP, receptor = receptor, receptor_a = receptor_a, receptor_b = receptor_b, pair = pair, converted_pair = converted_pair, producers = producers, receivers = receivers, cell_type_means = expr_df, cell_type_fractions = fraction_df, sce = sce_subset, sce_alt = sce_list_alt, - gsm = gene_symbol_mapping, splitted = i) + gsm = gene_symbol_mapping, splitted = i + ) dfx[[i]] <- dfx[[i]][dfx[[i]]$barcode %in% barcodes, ] } } else { - dfx[[1]] <- .generateDf(ligand = ligand, sep = DEFAULT_SEP, receptor = receptor, + dfx[[1]] <- .generateDf( + ligand = ligand, sep = DEFAULT_SEP, receptor = receptor, receptor_a = receptor_a, receptor_b = receptor_b, pair = pair, converted_pair = converted_pair, producers = producers, receivers = receivers, cell_type_means = expr_df, cell_type_fractions = fraction_df, sce = sce_subset, sce_alt = sce_list_alt, - gsm = gene_symbol_mapping) + gsm = gene_symbol_mapping + ) dfx[[1]] <- dfx[[1]][dfx[[1]]$barcode %in% barcodes, ] } gl <- list() if (length(show_legend) > 1) { for (i in 1:length(dfx)) { - gl[[i]] <- tryCatch(.chord_diagram3(tmp_df = dfx[[i]], lr_interaction = lr_interactions, - scaled = standard_scale, sep = DEFAULT_SEP, alpha = alpha, directional = directional, - show_legend = show_legend[i], edge_cols = edge_colors, grid_cols = grid_colors, - legend.pos.x = legend.pos.x, legend.pos.y = legend.pos.y, title = names(dfx)[i]), + gl[[i]] <- tryCatch( + .chord_diagram3( + tmp_df = dfx[[i]], lr_interaction = lr_interactions, + scaled = standard_scale, sep = DEFAULT_SEP, alpha = alpha, directional = directional, + show_legend = show_legend[i], edge_cols = edge_colors, grid_cols = grid_colors, + legend.pos.x = legend.pos.x, legend.pos.y = legend.pos.y, title = names(dfx)[i] + ), error = function(e) { - return(NA) - }) + return(NA) + } + ) } } else { for (i in 1:length(dfx)) { - gl[[i]] <- tryCatch(.chord_diagram3(tmp_dfx = dfx[[i]], lr_interaction = lr_interactions, - scaled = standard_scale, sep = DEFAULT_SEP, alpha = alpha, directional = directional, - show_legend = show_legend, edge_cols = edge_colors, grid_cols = grid_colors, - legend.pos.x = legend.pos.x, legend.pos.y = legend.pos.y, title = names(dfx)[i]), + gl[[i]] <- tryCatch( + .chord_diagram3( + tmp_dfx = dfx[[i]], lr_interaction = lr_interactions, + scaled = standard_scale, sep = DEFAULT_SEP, alpha = alpha, directional = directional, + show_legend = show_legend, edge_cols = edge_colors, grid_cols = grid_colors, + legend.pos.x = legend.pos.x, legend.pos.y = legend.pos.y, title = names(dfx)[i] + ), error = function(e) { - return(NA) - }) + return(NA) + } + ) } } if (length(gl) > 1) { @@ -298,4 +329,4 @@ plot_cpdb3 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval } else { return(gl[[1]]) } -} \ No newline at end of file +} diff --git a/R/plot_cpdb4.R b/R/plot_cpdb4.R index a3c9fc5d..8b97f732 100644 --- a/R/plot_cpdb4.R +++ b/R/plot_cpdb4.R @@ -35,7 +35,8 @@ #' @importFrom grDevices recordPlot #' @export -plot_cpdb4 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pvals, +plot_cpdb4 <- function( + scdata, cell_type1, cell_type2, celltype_key, means, pvals, deconvoluted, interaction, keep_significant_only = TRUE, splitby_key = NULL, standard_scale = TRUE, gene_symbol_mapping = NULL, frac = 0.1, remove_self = TRUE, desiredInteractions = NULL, degs_analysis = FALSE, directional = 1, alpha = 0.5, @@ -48,18 +49,24 @@ plot_cpdb4 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval if (class(scdata) == "Seurat") { stop("Sorry not supported. Please use a SingleCellExperiment object.") } - lr_interactions <- plot_cpdb(scdata = scdata, cell_type1 = ".", cell_type2 = ".", + lr_interactions <- plot_cpdb( + scdata = scdata, cell_type1 = ".", cell_type2 = ".", celltype_key = celltype_key, splitby_key = splitby_key, means = means, pvals = pvals, keep_significant_only = keep_significant_only, standard_scale = standard_scale, - return_table = TRUE, degs_analysis = degs_analysis, ...) + return_table = TRUE, degs_analysis = degs_analysis, ... + ) lr_interactions <- lr_interactions[gsub(paste0(".*", SPECIAL_SEP), "", lr_interactions$Var1) %in% genesx, ] - lr_interactions <- cbind(lr_interactions, do.call(rbind, strsplit(as.character(lr_interactions$group), - ">@<"))) + lr_interactions <- cbind(lr_interactions, do.call(rbind, strsplit( + as.character(lr_interactions$group), + ">@<" + ))) vals1 <- grep(paste0(c(cell_type1, cell_type2), collapse = "|"), lr_interactions$`1`, - value = TRUE) + value = TRUE + ) vals2 <- grep(paste0(c(cell_type1, cell_type2), collapse = "|"), lr_interactions$`2`, - value = TRUE) + value = TRUE + ) vals <- unique(c(vals1, vals2)) lr_interactions[!((lr_interactions$`1` %in% vals) & (lr_interactions$`2` %in% vals)), 3] <- 0 @@ -67,27 +74,38 @@ plot_cpdb4 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval vals)), 4] <- NA requireNamespace("SummarizedExperiment") requireNamespace("SingleCellExperiment") - subset_clusters <- unique(unlist(lapply(as.character(lr_interactions$group), - strsplit, DEFAULT_SEP))) + subset_clusters <- unique(unlist(lapply( + as.character(lr_interactions$group), + strsplit, DEFAULT_SEP + ))) sce_subset <- scdata[, SummarizedExperiment::colData(scdata)[, celltype_key] %in% subset_clusters] - interactions <- means[, c("id_cp_interaction", "interacting_pair", "gene_a", - "gene_b", "partner_a", "partner_b", "receptor_a", "receptor_b")] - interactions$use_interaction_name <- paste0(interactions$id_cp_interaction, SPECIAL_SEP, - interactions$interacting_pair) + interactions <- means[, c( + "id_cp_interaction", "interacting_pair", "gene_a", + "gene_b", "partner_a", "partner_b", "receptor_a", "receptor_b" + )] + interactions$use_interaction_name <- paste0( + interactions$id_cp_interaction, SPECIAL_SEP, + interactions$interacting_pair + ) interactions$converted <- gsub("_", "-", interactions$use_interaction_name) - interactions_subset <- interactions[interactions$converted %in% lr_interactions$Var1, - ] - tm0 <- do.call(c, lapply(as.list(interactions_subset$use_interaction_name), strsplit, - "_")) + interactions_subset <- interactions[interactions$converted %in% lr_interactions$Var1, ] + tm0 <- do.call(c, lapply( + as.list(interactions_subset$use_interaction_name), strsplit, + "_" + )) if (any(lapply(tm0, length) > 2)) { complex_id <- which(lapply(tm0, length) > 2) interactions_subset_ <- interactions_subset[complex_id, ] simple_1 <- interactions_subset_$interacting_pair[grep("complex:", interactions_subset_$partner_b)] - partner_1 <- gsub("complex:", "", interactions_subset_$partner_b[grep("complex:", - interactions_subset_$partner_b)]) - partner_2 <- gsub("complex:", "", interactions_subset_$partner_a[grep("complex:", - interactions_subset_$partner_a)]) + partner_1 <- gsub("complex:", "", interactions_subset_$partner_b[grep( + "complex:", + interactions_subset_$partner_b + )]) + partner_2 <- gsub("complex:", "", interactions_subset_$partner_a[grep( + "complex:", + interactions_subset_$partner_a + )]) simple_2 <- interactions_subset_$interacting_pair[grep("complex:", interactions_subset_$partner_a)] for (i in seq_along(simple_1)) { simple_1[i] <- gsub(paste0(partner_1[i], "_|_", partner_1[i]), "", simple_1[i]) @@ -100,18 +118,22 @@ plot_cpdb4 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval for (i in seq_along(complex_id)) { tm0[[complex_id[i]]] <- tmplist[[i]] } - tm0 <- data.frame(t(matrix(unlist(tm0), 2, length(unlist(tm0))/2))) + tm0 <- data.frame(t(matrix(unlist(tm0), 2, length(unlist(tm0)) / 2))) colnames(tm0) <- c("id_a", "id_b") interactions_subset <- cbind(interactions_subset, tm0) - dictionary <- interactions_subset[, c("id_cp_interaction", "gene_a", "gene_b", - "partner_a", "partner_b", "id_a", "id_b", "receptor_a", "receptor_b")] + dictionary <- interactions_subset[, c( + "id_cp_interaction", "gene_a", "gene_b", + "partner_a", "partner_b", "id_a", "id_b", "receptor_a", "receptor_b" + )] } else { - tm0 <- data.frame(t(matrix(unlist(tm0), 2, length(unlist(tm0))/2))) + tm0 <- data.frame(t(matrix(unlist(tm0), 2, length(unlist(tm0)) / 2))) colnames(tm0) <- c("id_a", "id_b") tm0$id_a <- gsub(paste0(".*", SPECIAL_SEP), "", tm0$id_a) interactions_subset <- cbind(interactions_subset, tm0) - dictionary <- interactions_subset[, c("id_cp_interaction", "gene_a", "gene_b", - "partner_a", "partner_b", "id_a", "id_b", "receptor_a", "receptor_b")] + dictionary <- interactions_subset[, c( + "id_cp_interaction", "gene_a", "gene_b", + "partner_a", "partner_b", "id_a", "id_b", "receptor_a", "receptor_b" + )] } # extract all the possible genes. geneid <- unique(c(interactions_subset$id_a, interactions_subset$id_b)) @@ -134,9 +156,9 @@ plot_cpdb4 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval for (n in names(sce_list)) { for (x in unique(meta[, celltype_key])) { sce_list[[n]][[x]] <- sce_subset_tmp[, meta[, celltype_key] == x & - meta[, splitby_key] == n] + meta[, splitby_key] == n] sce_list_alt[[n]][[x]] <- sce_subset[, meta[, celltype_key] == x & - meta[, splitby_key] == n] + meta[, splitby_key] == n] } } sce_list2 <- lapply(sce_list, function(y) { @@ -181,8 +203,7 @@ plot_cpdb4 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval } rownames(sce_list2) <- humanreadablename rownames(sce_list3) <- humanreadablename - decon_subset <- deconvoluted[deconvoluted$complex_name %in% .findComplex(interactions_subset), - ] + decon_subset <- deconvoluted[deconvoluted$complex_name %in% .findComplex(interactions_subset), ] if (nrow(decon_subset) > 0) { # although multiple rows are returned, really it's the same value for # the same complex @@ -196,14 +217,14 @@ plot_cpdb4 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval decon_subset_fraction <- lapply(decon_subset, function(x) { z <- unique(x$gene_name) test <- lapply(sce_list_alt, function(y) { - return(lapply(y, .cellTypeFraction_complex, genes = z, gene_symbol_mapping = gene_symbol_mapping)) + return(lapply(y, .cellTypeFraction_complex, genes = z, gene_symbol_mapping = gene_symbol_mapping)) }) return(test) }) decon_subset_fraction <- lapply(decon_subset_fraction, function(x) { y <- lapply(x, function(z) do.call(cbind, z)) for (i in 1:length(y)) { - colnames(y[[i]]) <- paste0(names(y[i]), "_", colnames(y[[i]])) + colnames(y[[i]]) <- paste0(names(y[i]), "_", colnames(y[[i]])) } y <- do.call(cbind, y) return(y) @@ -212,7 +233,7 @@ plot_cpdb4 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval decon_subset_fraction <- lapply(decon_subset, function(x) { z <- unique(x$gene_name) test <- lapply(sce_list_alt, function(y) { - return(.cellTypeFraction_complex(y, genes = z, gene_symbol_mapping = gene_symbol_mapping)) + return(.cellTypeFraction_complex(y, genes = z, gene_symbol_mapping = gene_symbol_mapping)) }) return(do.call(cbind, test)) }) @@ -232,8 +253,10 @@ plot_cpdb4 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval # make a big fat edgelist if (!is.null(desiredInteractions)) { if (class(desiredInteractions) == "list") { - desiredInteractions_ <- c(desiredInteractions, lapply(desiredInteractions, - rev)) + desiredInteractions_ <- c(desiredInteractions, lapply( + desiredInteractions, + rev + )) cell_type_grid <- as.data.frame(do.call(rbind, desiredInteractions_)) } else if ((class(desiredInteractions) == "data.frame")) { cell_type_grid <- desiredInteractions @@ -263,40 +286,48 @@ plot_cpdb4 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval dfx <- list() if (!is.null(splitby_key)) { for (i in unique(meta[, splitby_key])) { - dfx[[i]] <- .generateDf(ligand = ligand, sep = DEFAULT_SEP, receptor = receptor, + dfx[[i]] <- .generateDf( + ligand = ligand, sep = DEFAULT_SEP, receptor = receptor, receptor_a = receptor_a, receptor_b = receptor_b, pair = pair, converted_pair = converted_pair, producers = producers, receivers = receivers, cell_type_means = expr_df, cell_type_fractions = fraction_df, sce = sce_subset, sce_alt = sce_list_alt, - gsm = gene_symbol_mapping, splitted = i) + gsm = gene_symbol_mapping, splitted = i + ) dfx[[i]] <- dfx[[i]][dfx[[i]]$barcode %in% barcodes, ] } } else { - dfx[[1]] <- .generateDf(ligand = ligand, sep = DEFAULT_SEP, receptor = receptor, + dfx[[1]] <- .generateDf( + ligand = ligand, sep = DEFAULT_SEP, receptor = receptor, receptor_a = receptor_a, receptor_b = receptor_b, pair = pair, converted_pair = converted_pair, producers = producers, receivers = receivers, cell_type_means = expr_df, cell_type_fractions = fraction_df, sce = sce_subset, sce_alt = sce_list_alt, - gsm = gene_symbol_mapping) + gsm = gene_symbol_mapping + ) dfx[[1]] <- dfx[[1]][dfx[[1]]$barcode %in% barcodes, ] } gl <- list() if (length(show_legend) > 1) { for (i in 1:length(dfx)) { - gl[[i]] <- tryCatch(.chord_diagram4(tmp_dfx = dfx[[i]], lr_interactions = lr_interactions, + gl[[i]] <- tryCatch(.chord_diagram4( + tmp_dfx = dfx[[i]], lr_interactions = lr_interactions, scaled = standard_scale, sep = DEFAULT_SEP, alpha = alpha, directional = directional, show_legend = show_legend[i], edge_cols = edge_colors, grid_cols = grid_colors, legend.pos.x = legend.pos.x, legend.pos.y = legend.pos.y, title = names(dfx)[i], - grid_scale = grid_scale), error = function(e) { + grid_scale = grid_scale + ), error = function(e) { return(NA) }) } } else { for (i in 1:length(dfx)) { - gl[[i]] <- tryCatch(.chord_diagram4(tmp_dfx = dfx[[i]], lr_interactions = lr_interactions, + gl[[i]] <- tryCatch(.chord_diagram4( + tmp_dfx = dfx[[i]], lr_interactions = lr_interactions, scaled = standard_scale, sep = DEFAULT_SEP, alpha = alpha, directional = directional, show_legend = show_legend, edge_cols = edge_colors, grid_cols = grid_colors, legend.pos.x = legend.pos.x, legend.pos.y = legend.pos.y, title = names(dfx)[i], - grid_scale = grid_scale), error = function(e) { + grid_scale = grid_scale + ), error = function(e) { return(NA) }) } @@ -307,4 +338,4 @@ plot_cpdb4 <- function(scdata, cell_type1, cell_type2, celltype_key, means, pval } else { return(gl[[1]]) } -} \ No newline at end of file +} diff --git a/R/plot_cpdb_heatmap.R b/R/plot_cpdb_heatmap.R index ab6fee5f..6502d0c5 100644 --- a/R/plot_cpdb_heatmap.R +++ b/R/plot_cpdb_heatmap.R @@ -35,92 +35,98 @@ #' @include utils.R #' @export -plot_cpdb_heatmap <- function(pvals, cell_types = NULL, degs_analysis = FALSE, log1p_transform = FALSE, - show_rownames = TRUE, show_colnames = TRUE, scale = "none", cluster_cols = TRUE, - cluster_rows = TRUE, border_color = "white", fontsize_row = 11, fontsize_col = 11, - family = "Arial", main = "", treeheight_col = 0, treeheight_row = 0, low_col = "dodgerblue4", - mid_col = "peachpuff", high_col = "deeppink4", alpha = 0.05, return_tables = FALSE, - symmetrical = TRUE, default_sep = "\\|", ...) { - requireNamespace("reshape2") - requireNamespace("grDevices") - all_intr <- pvals - col_start <- ifelse(colnames(all_intr)[DEFAULT_CLASS_COL] == "classification", - DEFAULT_V5_COL_START, DEFAULT_COL_START) - intr_pairs <- all_intr$interacting_pair - all_intr <- t(all_intr[, -c(1:col_start - 1)]) - colnames(all_intr) <- intr_pairs - if (is.null(cell_types)) { - cell_types <- sort(unique(unlist(strsplit(colnames(pvals)[col_start:ncol(pvals)], - paste0("\\", DEFAULT_CPDB_SEP))))) - } - cell_types_comb <- apply(expand.grid(cell_types, cell_types), 1, function(z) { - paste(z, collapse = "|") - }) - cell_types_keep <- row.names(all_intr)[row.names(all_intr) %in% cell_types_comb] - empty_celltypes <- setdiff(cell_types_comb, cell_types_keep) - all_intr <- all_intr[row.names(all_intr) %in% cell_types_keep, ] - if (length(empty_celltypes) > 0) { - tmp_ <- matrix(0, nrow = length(empty_celltypes), ncol = ncol(all_intr)) - colnames(tmp_) <- colnames(all_intr) - rownames(tmp_) <- empty_celltypes +plot_cpdb_heatmap <- function( + pvals, cell_types = NULL, degs_analysis = FALSE, log1p_transform = FALSE, + show_rownames = TRUE, show_colnames = TRUE, scale = "none", cluster_cols = TRUE, + cluster_rows = TRUE, border_color = "white", fontsize_row = 11, fontsize_col = 11, + family = "Arial", main = "", treeheight_col = 0, treeheight_row = 0, low_col = "dodgerblue4", + mid_col = "peachpuff", high_col = "deeppink4", alpha = 0.05, return_tables = FALSE, + symmetrical = TRUE, default_sep = "\\|", ...) { + requireNamespace("reshape2") + requireNamespace("grDevices") + all_intr <- pvals + col_start <- ifelse(colnames(all_intr)[DEFAULT_CLASS_COL] == "classification", + DEFAULT_V5_COL_START, DEFAULT_COL_START + ) + intr_pairs <- all_intr$interacting_pair + all_intr <- t(all_intr[, -c(1:col_start - 1)]) + colnames(all_intr) <- intr_pairs + if (is.null(cell_types)) { + cell_types <- sort(unique(unlist(strsplit( + colnames(pvals)[col_start:ncol(pvals)], + paste0("\\", DEFAULT_CPDB_SEP) + )))) + } + cell_types_comb <- apply(expand.grid(cell_types, cell_types), 1, function(z) { + paste(z, collapse = "|") + }) + cell_types_keep <- row.names(all_intr)[row.names(all_intr) %in% cell_types_comb] + empty_celltypes <- setdiff(cell_types_comb, cell_types_keep) + all_intr <- all_intr[row.names(all_intr) %in% cell_types_keep, ] + if (length(empty_celltypes) > 0) { + tmp_ <- matrix(0, nrow = length(empty_celltypes), ncol = ncol(all_intr)) + colnames(tmp_) <- colnames(all_intr) + rownames(tmp_) <- empty_celltypes + if (!degs_analysis) { + tmp_ <- tmp_ + 1 + } + tmp_ <- as.data.frame(tmp_) + all_intr <- as.matrix(rbind(all_intr, tmp_)) + } + all_count <- reshape2::melt(all_intr) if (!degs_analysis) { - tmp_ <- tmp_ + 1 + all_count$significant <- all_count$value < alpha + } else { + all_count$significant <- all_count$value == 1 } - tmp_ <- as.data.frame(tmp_) - all_intr <- as.matrix(rbind(all_intr, tmp_)) - } - all_count <- reshape2::melt(all_intr) - if (!degs_analysis) { - all_count$significant <- all_count$value < alpha - } else { - all_count$significant <- all_count$value == 1 - } - count1x <- all_count %>% - group_by(Var1) %>% - summarise(COUNT = sum(significant)) %>% - as.data.frame() - tmp <- lapply(count1x[, 1], function(x) strsplit(as.character(x), default_sep)) - tmp <- lapply(tmp, function(x) x[[1]]) - tmp <- as.data.frame(do.call(rbind, tmp)) - colnames(tmp) <- c("SOURCE", "TARGET") - count1x <- as.data.frame(cbind(count1x, tmp)) - all_count <- count1x[, c("SOURCE", "TARGET", "COUNT")] + count1x <- all_count %>% + group_by(Var1) %>% + summarise(COUNT = sum(significant)) %>% + as.data.frame() + tmp <- lapply(count1x[, 1], function(x) strsplit(as.character(x), default_sep)) + tmp <- lapply(tmp, function(x) x[[1]]) + tmp <- as.data.frame(do.call(rbind, tmp)) + colnames(tmp) <- c("SOURCE", "TARGET") + count1x <- as.data.frame(cbind(count1x, tmp)) + all_count <- count1x[, c("SOURCE", "TARGET", "COUNT")] - if (any(all_count$COUNT) > 0) { - count_mat <- reshape2::acast(SOURCE ~ TARGET, data = all_count, value.var = "COUNT") - count_mat[is.na(count_mat)] <- 0 - col.heatmap <- (grDevices::colorRampPalette(c(low_col, mid_col, high_col)))(1000) - if (symmetrical) { - dcm <- diag(count_mat) - count_mat <- count_mat + t(count_mat) - diag(count_mat) <- dcm - } + if (any(all_count$COUNT) > 0) { + count_mat <- reshape2::acast(SOURCE ~ TARGET, data = all_count, value.var = "COUNT") + count_mat[is.na(count_mat)] <- 0 + col.heatmap <- (grDevices::colorRampPalette(c(low_col, mid_col, high_col)))(1000) + if (symmetrical) { + dcm <- diag(count_mat) + count_mat <- count_mat + t(count_mat) + diag(count_mat) <- dcm + } - if (log1p_transform == TRUE) { - count_mat <- log1p(count_mat) - } + if (log1p_transform == TRUE) { + count_mat <- log1p(count_mat) + } - p <- pheatmap(count_mat, show_rownames = show_rownames, show_colnames = show_colnames, - scale = scale, cluster_cols = cluster_cols, border_color = border_color, - cluster_rows = cluster_rows, fontsize_row = fontsize_row, fontsize_col = fontsize_col, - main = main, treeheight_row = treeheight_row, family = family, color = col.heatmap, - treeheight_col = treeheight_col, ...) - if (return_tables) { - if (symmetrical) { - all_sum <- rowSums(count_mat) - all_sum <- data.frame(all_sum) - return(list(count_network = count_mat, interaction_count = all_sum)) - } else { - count_mat <- t(count_mat) # so that the table output is the same layout as the plot - row_sum <- rowSums(count_mat) - col_sum <- colSums(count_mat) - all_sum <- data.frame(row_sum, col_sum) - return(list(count_network = count_mat, interaction_count = all_sum)) - } + p <- pheatmap(count_mat, + show_rownames = show_rownames, show_colnames = show_colnames, + scale = scale, cluster_cols = cluster_cols, border_color = border_color, + cluster_rows = cluster_rows, fontsize_row = fontsize_row, fontsize_col = fontsize_col, + main = main, treeheight_row = treeheight_row, family = family, color = col.heatmap, + treeheight_col = treeheight_col, ... + ) + if (return_tables) { + if (symmetrical) { + all_sum <- rowSums(count_mat) + all_sum <- data.frame(all_sum) + return(list(count_network = count_mat, interaction_count = all_sum)) + } else { + count_mat <- t(count_mat) # so that the table output is the same layout as the plot + row_sum <- rowSums(count_mat) + col_sum <- colSums(count_mat) + all_sum <- data.frame(row_sum, col_sum) + return(list(count_network = count_mat, interaction_count = all_sum)) + } + } else { + return(p) + } } else { - return(p) + stop("There are no significant results using p-value of: ", alpha, call. = FALSE) } - } else { - stop("There are no significant results using p-value of: ", alpha, call. = FALSE) - } -} \ No newline at end of file +} diff --git a/man/combine_cpdb.Rd b/man/combine_cpdb.Rd index b3251d77..ff5b3cd5 100644 --- a/man/combine_cpdb.Rd +++ b/man/combine_cpdb.Rd @@ -15,10 +15,3 @@ combine results from multiple cellphonedb runs. \description{ combine multiple results from cellphonedb. } -\examples{ -\donttest{ -combine_cpdb(means, means2, means3) -combine_cpdb(pvals, pvals2, pvals3) -combine_cpdb(decon, decon2, decon3) -} -} diff --git a/man/geneDotPlot.Rd b/man/geneDotPlot.Rd index c5b48c7b..4a03b5e1 100644 --- a/man/geneDotPlot.Rd +++ b/man/geneDotPlot.Rd @@ -69,6 +69,6 @@ Plotting genes as dotplot \examples{ \donttest{ data(kidneyimmune) -geneDotPlot(kidneyimmune, genes = c('CD68', 'CD80', 'CD86', 'CD74', 'CD2', 'CD5'), celltype_key = 'celltype', splitby_key = 'Project', standard_scale = TRUE) + theme(strip.text.x = element_text(angle = 45, hjust = 0)) +geneDotPlot(kidneyimmune, genes = c("CD68", "CD80", "CD86", "CD74", "CD2", "CD5"), celltype_key = "celltype", splitby_key = "Project", standard_scale = TRUE) + theme(strip.text.x = element_text(angle = 45, hjust = 0)) } } diff --git a/man/plot_cpdb.Rd b/man/plot_cpdb.Rd index 95c4080b..fdca23bf 100644 --- a/man/plot_cpdb.Rd +++ b/man/plot_cpdb.Rd @@ -36,6 +36,7 @@ plot_cpdb( filter_by_cellsign = FALSE, title = "", keep_id_cp_interaction = FALSE, + result_precision = 3, ... ) } @@ -100,6 +101,8 @@ plot_cpdb( \item{keep_id_cp_interaction}{Whether or not to keep the id_cp_interaction in the plot.} +\item{result_precision}{Sets integer value for decimal points of p_value, default to 3} + \item{...}{passes arguments to grep for cell_type1 and cell_type2.} } \value{ diff --git a/man/plot_cpdb_heatmap.Rd b/man/plot_cpdb_heatmap.Rd index e918d0d5..7fba9510 100644 --- a/man/plot_cpdb_heatmap.Rd +++ b/man/plot_cpdb_heatmap.Rd @@ -27,6 +27,7 @@ plot_cpdb_heatmap( alpha = 0.05, return_tables = FALSE, symmetrical = TRUE, + default_sep = "\\\\|", ... ) } @@ -75,6 +76,8 @@ plot_cpdb_heatmap( \item{symmetrical}{whether or not to return as symmetrical matrix} +\item{default_sep}{the default separator used when CellPhoneDB was run.} + \item{...}{passed to pheatmap::pheatmap.} } \value{ diff --git a/tests/testthat/test_dotplot.R b/tests/testthat/test_dotplot.R index 3f8276d0..e3570af5 100644 --- a/tests/testthat/test_dotplot.R +++ b/tests/testthat/test_dotplot.R @@ -1,43 +1,61 @@ data(kidneyimmune) test_that("geneDotPlot works", { - p <- geneDotPlot(kidneyimmune, genes = c("CD68", "CD80", "CD86", "CD74", "CD2", - "CD5"), celltype_key = "celltype", splitby_key = "Project", standard_scale = TRUE) + + p <- geneDotPlot(kidneyimmune, genes = c( + "CD68", "CD80", "CD86", "CD74", "CD2", + "CD5" + ), celltype_key = "celltype", splitby_key = "Project", standard_scale = TRUE) + theme(strip.text.x = element_text(angle = 45, hjust = 0)) expect_true(is.ggplot(p)) }) test_that("test fill works", { - p <- geneDotPlot(kidneyimmune, genes = c("CD68", "CD80", "CD86", "CD74", "CD2", - "CD5"), celltype_key = "celltype", splitby_key = "Project", standard_scale = TRUE, - fill = TRUE) + theme(strip.text.x = element_text(angle = 45, hjust = 0)) + p <- geneDotPlot(kidneyimmune, + genes = c( + "CD68", "CD80", "CD86", "CD74", "CD2", + "CD5" + ), celltype_key = "celltype", splitby_key = "Project", standard_scale = TRUE, + fill = TRUE + ) + theme(strip.text.x = element_text(angle = 45, hjust = 0)) expect_true(is.ggplot(p)) }) test_that("test no split", { - p <- geneDotPlot(kidneyimmune, genes = c("CD68", "CD80", "CD86", "CD74", "CD2", - "CD5"), celltype_key = "celltype", standard_scale = TRUE, fill = TRUE) + + p <- geneDotPlot(kidneyimmune, genes = c( + "CD68", "CD80", "CD86", "CD74", "CD2", + "CD5" + ), celltype_key = "celltype", standard_scale = TRUE, fill = TRUE) + theme(strip.text.x = element_text(angle = 45, hjust = 0)) expect_true(is.ggplot(p)) }) test_that("test no scale1", { - p <- geneDotPlot(kidneyimmune, genes = c("CD68", "CD80", "CD86", "CD74", "CD2", - "CD5"), celltype_key = "celltype", standard_scale = FALSE, fill = TRUE) + + p <- geneDotPlot(kidneyimmune, genes = c( + "CD68", "CD80", "CD86", "CD74", "CD2", + "CD5" + ), celltype_key = "celltype", standard_scale = FALSE, fill = TRUE) + theme(strip.text.x = element_text(angle = 45, hjust = 0)) expect_true(is.ggplot(p)) }) test_that("test no scale2", { - p <- geneDotPlot(kidneyimmune, genes = c("CD68", "CD80", "CD86", "CD74", "CD2", - "CD5"), celltype_key = "celltype", scale = FALSE, standard_scale = FALSE, - fill = TRUE) + theme(strip.text.x = element_text(angle = 45, hjust = 0)) + p <- geneDotPlot(kidneyimmune, + genes = c( + "CD68", "CD80", "CD86", "CD74", "CD2", + "CD5" + ), celltype_key = "celltype", scale = FALSE, standard_scale = FALSE, + fill = TRUE + ) + theme(strip.text.x = element_text(angle = 45, hjust = 0)) expect_true(is.ggplot(p)) }) test_that("test scale3", { - p <- geneDotPlot(kidneyimmune, genes = c("CD68", "CD80", "CD86", "CD74", "CD2", - "CD5"), celltype_key = "celltype") + theme(strip.text.x = element_text(angle = 45, - hjust = 0)) + p <- geneDotPlot(kidneyimmune, genes = c( + "CD68", "CD80", "CD86", "CD74", "CD2", + "CD5" + ), celltype_key = "celltype") + theme(strip.text.x = element_text( + angle = 45, + hjust = 0 + )) expect_true(is.ggplot(p)) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_miscellaneous.R b/tests/testthat/test_miscellaneous.R index b2b801ca..2e741a3f 100644 --- a/tests/testthat/test_miscellaneous.R +++ b/tests/testthat/test_miscellaneous.R @@ -24,4 +24,4 @@ test_that("miscellaneous works4", { test_that("miscellaneous works5", { g5 <- g + topright_legend() expect_true(is.ggplot(g5)) -}) \ No newline at end of file +}) diff --git a/vignettes/vignette.rmd b/vignettes/vignette.rmd index 4e7d272b..babbfbb6 100644 --- a/vignettes/vignette.rmd +++ b/vignettes/vignette.rmd @@ -82,7 +82,7 @@ plot_cpdb_heatmap(pvals = rel_int_degs, cellheight = 10, cellwidth = 10, degs_an You can also specify specific celltypes to plot. ```{r, message = FALSE, warning = FALSE} -plot_cpdb_heatmap(pvals=pvals_stat, cell_types=c("NK cell", "pDC", "B cell", "CD8T cell"), cellheight = 10, cellwidth = 10) +plot_cpdb_heatmap(pvals = pvals_stat, cell_types = c("NK cell", "pDC", "B cell", "CD8T cell"), cellheight = 10, cellwidth = 10) ``` The current heatmap is directional (check `count_network` and `interaction_edges` for more details in `return_tables = True`). @@ -111,43 +111,43 @@ A -> B is 9 interactions A simple usage of `plot_cpdb` is as follows: ```{r, message = FALSE, warning = FALSE, fig.width = 10, fig.height = 4} plot_cpdb( - scdata=kidneyimmune, - cell_type1="B cell", - cell_type2=".", # this means all cell-types - celltype_key="celltype", - means=means_stat, - pvals=pvals_stat, - genes=c("PTPRC", "TNFSF13"), - title="interacting interactions!", + scdata = kidneyimmune, + cell_type1 = "B cell", + cell_type2 = ".", # this means all cell-types + celltype_key = "celltype", + means = means_stat, + pvals = pvals_stat, + genes = c("PTPRC", "TNFSF13"), + title = "interacting interactions!", ) ``` You can keep the original `id_cp_interaction` value in the name too. ```{r, message = FALSE, warning = FALSE, fig.width = 12, fig.height = 4} plot_cpdb( - scdata=kidneyimmune, - cell_type1="B cell", - cell_type2=".", # this means all cell-types - celltype_key="celltype", - means=means_stat, - pvals=pvals_stat, - genes=c("PTPRC", "TNFSF13"), - title="interacting interactions!", - keep_id_cp_interaction=TRUE, + scdata = kidneyimmune, + cell_type1 = "B cell", + cell_type2 = ".", # this means all cell-types + celltype_key = "celltype", + means = means_stat, + pvals = pvals_stat, + genes = c("PTPRC", "TNFSF13"), + title = "interacting interactions!", + keep_id_cp_interaction = TRUE, ) ``` ```{r, message = FALSE, warning = FALSE, fig.width = 10, fig.height = 4} plot_cpdb( - scdata=kidneyimmune, - cell_type1="B cell", - cell_type2=".", # this means all cell-types - celltype_key="celltype", - means=means_degs, - pvals=rel_int_degs, - degs_analysis=TRUE, - genes=c("PTPRC", "TNFSF13"), - title="interacting interactions!", + scdata = kidneyimmune, + cell_type1 = "B cell", + cell_type2 = ".", # this means all cell-types + celltype_key = "celltype", + means = means_degs, + pvals = rel_int_degs, + degs_analysis = TRUE, + genes = c("PTPRC", "TNFSF13"), + title = "interacting interactions!", ) ``` @@ -155,25 +155,25 @@ Or don't specify either and it will try to plot all significant interactions. ```{r, message = FALSE, warning = FALSE, fig.width = 10, fig.height = 10} plot_cpdb( - scdata=kidneyimmune, - cell_type1="B cell", - cell_type2=".", - celltype_key="celltype", - means=means_stat, - pvals=pvals_stat, + scdata = kidneyimmune, + cell_type1 = "B cell", + cell_type2 = ".", + celltype_key = "celltype", + means = means_stat, + pvals = pvals_stat, ) ``` ```{r, message = FALSE, warning = FALSE, fig.width = 10, fig.height = 10} plot_cpdb( - scdata=kidneyimmune, - cell_type1="B cell", - cell_type2=".", # this means all cell-types - celltype_key="celltype", - means=means_degs, - pvals=rel_int_degs, - degs_analysis=TRUE, - title="interacting interactions!", + scdata = kidneyimmune, + cell_type1 = "B cell", + cell_type2 = ".", # this means all cell-types + celltype_key = "celltype", + means = means_degs, + pvals = rel_int_degs, + degs_analysis = TRUE, + title = "interacting interactions!", ) ``` @@ -181,21 +181,21 @@ You can also try an alternative visualisation inspired by how `squidpy` displays ```{r, message = FALSE, warning = FALSE, fig.width = 10, fig.height = 3} plot_cpdb( - scdata=kidneyimmune, - cell_type1="B cell", - cell_type2=".", - celltype_key="celltype", - means=means_stat, - pvals=pvals_stat, - genes=c("PTPRC", "CD40", "CLEC2D"), - default_style=FALSE + scdata = kidneyimmune, + cell_type1 = "B cell", + cell_type2 = ".", + celltype_key = "celltype", + means = means_stat, + pvals = pvals_stat, + genes = c("PTPRC", "CD40", "CLEC2D"), + default_style = FALSE ) ``` you can also toggle options to `splitby_key` and `gene_family`: ```{r, message = FALSE, warning = FALSE, fig.width = 10, fig.height = 6} -data(cpdb_output) # this is a different dataset where the "Experiment" was appended to the "celltype" +data(cpdb_output) # this is a different dataset where the "Experiment" was appended to the "celltype" plot_cpdb( scdata = kidneyimmune, @@ -232,7 +232,7 @@ And also provide custom families as a `data.frame`. ```{r, message = FALSE, warning = FALSE, fig.width = 10, fig.height = 6} df <- data.frame(set1 = c("CCR6", "CCL20", "CXCL10", "CCR3", "TNFRSF13C"), set2 = c("CCL5", "CCR4", "PTPRC", "CD40", "CLEC2D")) plot_cpdb( - scdata=kidneyimmune, + scdata = kidneyimmune, cell_type1 = "B cell", cell_type2 = "CD4T cell", celltype_key = "celltype", @@ -246,10 +246,7 @@ plot_cpdb( ### combine_cpdb -For the `splitby_key` option to work, the annotation in the meta file must be defined in the following format: -```{r, eval = FALSE} -{splitby_key}_{celltype_key} -``` +For the `splitby_key` option to work, the annotation in the meta file must be defined in the following format: `{splitby_key}_{celltype_key}` so to set up an example vector, it would be something like: ```{r, eval = FALSE} diff --git a/vignettes/vignette_v5.rmd b/vignettes/vignette_v5.rmd index d0f624c9..d9ea58c5 100644 --- a/vignettes/vignette_v5.rmd +++ b/vignettes/vignette_v5.rmd @@ -47,23 +47,23 @@ knitr::opts_chunk$set( library(ktplots) data(cpdb_output_v5) -plot_cpdb_heatmap(pvals=relevant_interactions_v5, degs_analysis=TRUE, title="Sum of significant interactions") +plot_cpdb_heatmap(pvals = relevant_interactions_v5, degs_analysis = TRUE, title = "Sum of significant interactions") ``` ```{r, message = FALSE, warning = FALSE, fig.height=3, fig.width=10} plot_cpdb( - scdata=sce_v5, - cell_type1="PV MYH11|PV STEAP4|PV MMPP11", - cell_type2="EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", - means=means_v5, - pvals=relevant_interactions_v5, - celltype_key="cell_labels", - genes=c("TGFB2", "CSF1R"), - title="Interactions between PV and trophoblast ", - max_size=6, - highlight_size=0.75, - degs_analysis=TRUE, - standard_scale=TRUE + scdata = sce_v5, + cell_type1 = "PV MYH11|PV STEAP4|PV MMPP11", + cell_type2 = "EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", + means = means_v5, + pvals = relevant_interactions_v5, + celltype_key = "cell_labels", + genes = c("TGFB2", "CSF1R"), + title = "Interactions between PV and trophoblast ", + max_size = 6, + highlight_size = 0.75, + degs_analysis = TRUE, + standard_scale = TRUE ) ``` @@ -73,20 +73,20 @@ Let's start with interaction scores. If a dataframe corresponding to the `intera ```{r, message = FALSE, warning = FALSE, fig.height=3, fig.width=12} plot_cpdb( - scdata=sce_v5, - cell_type1="PV MYH11|PV STEAP4|PV MMPP11", - cell_type2="EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", - means=means_v5, - pvals=relevant_interactions_v5, - celltype_key="cell_labels", - genes=c("TGFB2", "CSF1R"), - title="Interactions between PV and trophoblast ", - max_size=6, - highlight_size=0.75, - degs_analysis=TRUE, - standard_scale=TRUE, - interaction_scores=interaction_scores_v5, - scale_alpha_by_interaction_scores=TRUE + scdata = sce_v5, + cell_type1 = "PV MYH11|PV STEAP4|PV MMPP11", + cell_type2 = "EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", + means = means_v5, + pvals = relevant_interactions_v5, + celltype_key = "cell_labels", + genes = c("TGFB2", "CSF1R"), + title = "Interactions between PV and trophoblast ", + max_size = 6, + highlight_size = 0.75, + degs_analysis = TRUE, + standard_scale = TRUE, + interaction_scores = interaction_scores_v5, + scale_alpha_by_interaction_scores = TRUE ) ``` @@ -94,20 +94,20 @@ You can also specify a minimum interaction score to keep, removing all interacti ```{r, message = FALSE, warning = FALSE, fig.height=3, fig.width=8} plot_cpdb( - scdata=sce_v5, - cell_type1="PV MYH11|PV STEAP4|PV MMPP11", - cell_type2="EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", - means=means_v5, - pvals=relevant_interactions_v5, - celltype_key="cell_labels", - genes=c("TGFB2", "CSF1R"), - title="Interactions between\nPV and trophoblast ", - max_size=6, - highlight_size=0.75, - degs_analysis=TRUE, - standard_scale=TRUE, - interaction_scores=interaction_scores_v5, - min_interaction_score=20 + scdata = sce_v5, + cell_type1 = "PV MYH11|PV STEAP4|PV MMPP11", + cell_type2 = "EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", + means = means_v5, + pvals = relevant_interactions_v5, + celltype_key = "cell_labels", + genes = c("TGFB2", "CSF1R"), + title = "Interactions between\nPV and trophoblast ", + max_size = 6, + highlight_size = 0.75, + degs_analysis = TRUE, + standard_scale = TRUE, + interaction_scores = interaction_scores_v5, + min_interaction_score = 20 ) ``` @@ -115,21 +115,21 @@ or specify both to have the alpha transparency shown too. ```{r, message = FALSE, warning = FALSE, fig.height=3, fig.width=10} plot_cpdb( - scdata=sce_v5, - cell_type1="PV MYH11|PV STEAP4|PV MMPP11", - cell_type2="EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", - means=means_v5, - pvals=relevant_interactions_v5, - celltype_key="cell_labels", - genes=c("TGFB2", "CSF1R"), - title="Interactions between\nPV and trophoblast ", - max_size=6, - highlight_size=0.75, - degs_analysis=TRUE, - standard_scale=TRUE, - interaction_scores=interaction_scores_v5, - scale_alpha_by_interaction_scores=TRUE, - min_interaction_score=20 + scdata = sce_v5, + cell_type1 = "PV MYH11|PV STEAP4|PV MMPP11", + cell_type2 = "EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", + means = means_v5, + pvals = relevant_interactions_v5, + celltype_key = "cell_labels", + genes = c("TGFB2", "CSF1R"), + title = "Interactions between\nPV and trophoblast ", + max_size = 6, + highlight_size = 0.75, + degs_analysis = TRUE, + standard_scale = TRUE, + interaction_scores = interaction_scores_v5, + scale_alpha_by_interaction_scores = TRUE, + min_interaction_score = 20 ) ``` @@ -139,19 +139,19 @@ If a dataframe corresponding to the `cellsign` file is provided, you can toggle ```{r, message = FALSE, warning = FALSE, fig.height=4, fig.width=8} plot_cpdb( - scdata=sce_v5, - cell_type1="PV MYH11", - cell_type2="EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", - means=means_v5, - pvals=relevant_interactions_v5, - celltype_key="cell_labels", - title="Interactions between\nPV and trophoblast with\ndownstream significance", - max_size=6, - highlight_size=0.75, - degs_analysis=TRUE, - standard_scale=TRUE, - cellsign=cellsign_v5, - filter_by_cellsign=TRUE + scdata = sce_v5, + cell_type1 = "PV MYH11", + cell_type2 = "EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", + means = means_v5, + pvals = relevant_interactions_v5, + celltype_key = "cell_labels", + title = "Interactions between\nPV and trophoblast with\ndownstream significance", + max_size = 6, + highlight_size = 0.75, + degs_analysis = TRUE, + standard_scale = TRUE, + cellsign = cellsign_v5, + filter_by_cellsign = TRUE ) ``` @@ -159,20 +159,20 @@ and also scale the alpha value (50% for 0 and 100% for 1). ```{r, message = FALSE, warning = FALSE, fig.height=4, fig.width=8} plot_cpdb( - scdata=sce_v5, - cell_type1="PV MYH11", - cell_type2="EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", - means=means_v5, - pvals=relevant_interactions_v5, - celltype_key="cell_labels", - title="Interactions between\nPV and trophoblast with\ndownstream significance", - max_size=6, - highlight_size=0.75, - degs_analysis=TRUE, - standard_scale=TRUE, - cellsign=cellsign_v5, - filter_by_cellsign=TRUE, - scale_alpha_by_cellsign=TRUE + scdata = sce_v5, + cell_type1 = "PV MYH11", + cell_type2 = "EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", + means = means_v5, + pvals = relevant_interactions_v5, + celltype_key = "cell_labels", + title = "Interactions between\nPV and trophoblast with\ndownstream significance", + max_size = 6, + highlight_size = 0.75, + degs_analysis = TRUE, + standard_scale = TRUE, + cellsign = cellsign_v5, + filter_by_cellsign = TRUE, + scale_alpha_by_cellsign = TRUE ) ``` @@ -183,25 +183,25 @@ From now on, `is_integrin`, `directionality` and `classification` are transferre ```{r, message = FALSE, warning = FALSE, fig.height=3, fig.width=20} library(ggplot2) p <- plot_cpdb( - scdata = sce_v5, - cell_type1 = "PV MYH11|PV STEAP4|PV MMPP11", - cell_type2 = "EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", - means = means_v5, - pvals = relevant_interactions_v5, - celltype_key = "cell_labels", - genes = c("TGFB2", "CSF1R", "COL1A1"), - max_size = 6, - highlight_size = 0.75, - degs_analysis = TRUE, - standard_scale = TRUE, - interaction_scores = interaction_scores_v5 - # return_table = TRUE - ) + scdata = sce_v5, + cell_type1 = "PV MYH11|PV STEAP4|PV MMPP11", + cell_type2 = "EVT_1|EVT_2|GC|iEVT|eEVT|VCT_CCC", + means = means_v5, + pvals = relevant_interactions_v5, + celltype_key = "cell_labels", + genes = c("TGFB2", "CSF1R", "COL1A1"), + max_size = 6, + highlight_size = 0.75, + degs_analysis = TRUE, + standard_scale = TRUE, + interaction_scores = interaction_scores_v5 + # return_table = TRUE +) p + facet_wrap(~classification, ncol = 3) ``` ```{r, message = FALSE, warning = FALSE, fig.height=3, fig.width=20} -p + facet_wrap(~classification + is_integrin, ncol = 3) +p + facet_wrap(~ classification + is_integrin, ncol = 3) ``` ```{r, message = FALSE, warning = FALSE, fig.height=3, fig.width=20}