├── .DS_Store ├── DESCRIPTION ├── DIALOGUE.Rproj ├── Data └── test.example.rds ├── Images ├── DIALOGUE_overview.png ├── Livnat_dialogue_rev3-02.png ├── MCP1.png ├── UC_barplot.png ├── UC_plot.png └── UC_violins.png ├── LICENSE ├── NAMESPACE ├── R ├── .Rhistory ├── DIALOGUE.cell.type.R ├── DIALOGUE.main.R ├── DIALOGUE.plot.R ├── DIALOGUE.util.R └── DIALOGUE_SeuratExample.R ├── README.html ├── README.md ├── Scripts └── DLG_repro_SMI.R └── man ├── .DS_Store ├── DIALOGUE.plot.Rd ├── DIALOGUE.run.Rd ├── DIALOGUE_SeuratExample.Rd ├── DIALOGUE_make.cell.type.seurat.Rd ├── DLG.get.param.Rd ├── add.n.of.samples.Rd ├── call.plot.Rd ├── call.plot.multilabels.Rd ├── call.plot.plus.Rd ├── cap.mat.Rd ├── cell.type-class.Rd ├── center.matrix.Rd ├── get.strsplit.Rd └── make.cell.type.Rd /.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/livnatje/DIALOGUE/9c146ccf28d7706aaa60d00947a9126b4e75fd69/.DS_Store -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: DIALOGUE 2 | Title: DIALOGUE is a dimensionality reduction algorithm that uses cross-cell-type associations to identify multicellular programs and map the cell transcriptome as a function of its environment. 3 | Version: 1.0 4 | Authors@R: 5 | person(given = "Livnat", 6 | family = "Jerby-Arnon", 7 | role = c("aut", "cre"), 8 | email = "livnat.jerby@gmail.com", 9 | comment = c(ORCID = "0000-0002-4037-386X")) 10 | Description: Given single-cell data that was obtained across different spatial locations or samples, DIALOGUE treats different types of cells from the same micro/microenvironment or sample as different representations of the same entity. It first uses penalized matrix decomposition to preform penalized canonical variates analysis (CVA) on the average cell-type-specific expression of each niches/samples and identify the initial multicellular programs. Each multicellular program is composed of co-regulated cell-type-specific programs that are defined as a sparse linear combination of genes (Fig. 1a, Methods). It then preforms multilevel (hierarchical) modeling to prune and refines the programs based on the underlining distribution of cell states across and within niches/samples (instead of using only the averages), while controlling for potential confounders. 11 | License: Free to use! Please cite our paper (Jerby-Arnon and Regev, 2020) 12 | Encoding: UTF-8 13 | LazyData: true 14 | RoxygenNote: 7.2.3 15 | Depends: lme4, lmerTest, PMA, plyr, matrixStats, psych, stringi, RColorBrewer, unikn, reshape2, ggplot2, ppcor, Hmisc, grid, beanplot, UpSetR 16 | -------------------------------------------------------------------------------- /DIALOGUE.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | Encoding: UTF-8 9 | 10 | AutoAppendNewline: Yes 11 | StripTrailingWhitespace: Yes 12 | LineEndingConversion: Posix 13 | 14 | BuildType: Package 15 | PackageUseDevtools: Yes 16 | PackageInstallArgs: --no-multiarch --with-keep.source 17 | PackageRoxygenize: rd,collate,namespace 18 | -------------------------------------------------------------------------------- /Data/test.example.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/livnatje/DIALOGUE/9c146ccf28d7706aaa60d00947a9126b4e75fd69/Data/test.example.rds -------------------------------------------------------------------------------- /Images/DIALOGUE_overview.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/livnatje/DIALOGUE/9c146ccf28d7706aaa60d00947a9126b4e75fd69/Images/DIALOGUE_overview.png -------------------------------------------------------------------------------- /Images/Livnat_dialogue_rev3-02.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/livnatje/DIALOGUE/9c146ccf28d7706aaa60d00947a9126b4e75fd69/Images/Livnat_dialogue_rev3-02.png -------------------------------------------------------------------------------- /Images/MCP1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/livnatje/DIALOGUE/9c146ccf28d7706aaa60d00947a9126b4e75fd69/Images/MCP1.png -------------------------------------------------------------------------------- /Images/UC_barplot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/livnatje/DIALOGUE/9c146ccf28d7706aaa60d00947a9126b4e75fd69/Images/UC_barplot.png -------------------------------------------------------------------------------- /Images/UC_plot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/livnatje/DIALOGUE/9c146ccf28d7706aaa60d00947a9126b4e75fd69/Images/UC_plot.png -------------------------------------------------------------------------------- /Images/UC_violins.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/livnatje/DIALOGUE/9c146ccf28d7706aaa60d00947a9126b4e75fd69/Images/UC_violins.png -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | DIALOGUE is released under the following BSD 3-Clause License: 2 | 3 | Copyright (c) 2020 The Broad Institute, Inc. All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 8 | 9 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 10 | 11 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 14 | 15 | 16 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(DIALOGUE.plot) 4 | export(DIALOGUE.run) 5 | export(DIALOGUE_SeuratExample) 6 | export(DIALOGUE_make.cell.type.seurat) 7 | export(DLG.get.param) 8 | export(add.n.of.samples) 9 | export(call.plot) 10 | export(call.plot.multilabels) 11 | export(call.plot.plus) 12 | export(cap.mat) 13 | export(cell.type) 14 | export(center.matrix) 15 | export(get.strsplit) 16 | export(make.cell.type) 17 | exportClasses(cell.type) 18 | -------------------------------------------------------------------------------- /R/.Rhistory: -------------------------------------------------------------------------------- 1 | read.csv("/Volumes/Resource1/scRNA_data/BulkData/HGSC_TGCA/icgc-dataset-1643507265966/donor.tsv") 2 | library(keras) 3 | # Then, use the install_tensorflow() function to install TensorFlow. 4 | library(tensorflow) 5 | # install_tensorflow(envname = "r-reticulate") 6 | install_tensorflow(method = "virtualenv",envname = "lab_python3_env") 7 | # You can confirm that the installation succeeded with: 8 | library(tensorflow) 9 | tf$constant("Hello Tensorflow!") 10 | ?virtualenv_create 11 | library(reticulate) 12 | virtualenv_install(envname = "lab_python3_env") 13 | virtualenv_exists(envname = "lab_python3_env") 14 | virtualenv_python(envname = "lab_python3_env") 15 | library(keras) 16 | # You can confirm that the installation succeeded with: 17 | library(tensorflow) 18 | tf$constant("Hello Tensorflow!") 19 | install_tensorflow(envname = "r-reticulate") 20 | tf$constant("Hello Tensorflow!") 21 | install.packages("tensorflow") 22 | install.packages("tensorflow") 23 | install.packages("tensorflow") 24 | install.packages("tensorflow") 25 | install.packages("tensorflow") 26 | library(reticulate) 27 | path_to_python <- "/usr/local/bin/python3.9" 28 | virtualenv_create("r-reticulate", python = path_to_python) 29 | library(tensorflow) 30 | install_tensorflow(envname = "r-reticulate") 31 | library(tensorflow) 32 | tf$constant("Hello Tensorflow!") 33 | use_virtualenv("r-reticulate") 34 | use_virtualenv("lab_python3_env") 35 | library(tensorflow) 36 | tf$constant("Hello Tensorflow!") 37 | install_tensorflow(method = "virtualenv",envname = "lab_python3_env") 38 | use_virtualenv("lab_python3_env") 39 | tf$constant("Hello Tensorflow!") 40 | # install the development version of packages, in case the 41 | # issue is already fixed but not on CRAN yet. 42 | install.packages("remotes") 43 | sprintf("rstudio/%s", c("reticulate", "tensorflow", "keras")) 44 | remotes::install_github(sprintf("rstudio/%s", c("reticulate", "tensorflow", "keras"))) 45 | reticulate::miniconda_uninstall() # start with a blank slate 46 | Sys.getenv() 47 | Sys.getenv(R_REMOTES_NO_ERRORS_FROM_WARNINGS) 48 | Sys.getenv("R_REMOTES_NO_ERRORS_FROM_WARNINGS") 49 | Sys.setenv(R_REMOTES_NO_ERRORS_FROM_WARNINGS="true") 50 | v<-readRDS("/Volumes/Resource1/PerturbSeq/Results/perturbDEGs_HGSC_S1_1to1.rds") 51 | r<-readRDS("/Volumes/ljerby/PerturbSeq/Data/R_data/perturbSeq1_TyknuNK_1to1_processed.rds") 52 | typeof(r$sgRNA) 53 | table(r$sgRNA$num_features) 54 | table(r$labels) 55 | r2<-readRDS("/Volumes/ljerby/PerturbSeq/Data/R_data/perturbSeq1_TyknuNK_25to1.rds") 56 | table(r2$labels) 57 | table(r2$labels,r2$sgRNA[,"num_features"]) 58 | r<-readRDS("/Volumes/Resource2/HGSC/Data/R_data/SMI_panel.rds") 59 | r<-readRDS("/Volumes/Resource2/HGSC/Data/R_data/SMI_HGSC_wFrames5K_wSubtypes.rds") 60 | summary(r) 61 | r 62 | r<-readRDS("/Volumes/Resource2/HGSC/Data/R_data/SMI_HGSC_wFrames5K.rds") 63 | libs4HGSC<-c("beanplot","cowplot","Seurat","EBImage","survival","rms","mixtools","MASS","ggplot2", 64 | "nnet","ppcor","ROCR","tsne","gplots","ggpubr","EnhancedVolcano","plyr","reshape2","plotrix","stats", "Matrix", 65 | "Rtsne","lmerTest","devtools","gplots","heatmap3","e1071","openxlsx","RColorBrewer","heatmap3","UpSetR") 66 | for(x in libs4HGSC){ 67 | print(x) 68 | library(package = x) 69 | } 70 | library(x) 71 | library(x,character.only = T) 72 | for(x in libs4HGSC){ 73 | library(x,character.only = T) 74 | } 75 | laply(libs4HGSC,function(x) library(x,character.only = T)) 76 | v<-laply(libs4HGSC,function(x) library(x,character.only = T)) 77 | v 78 | libs4HGSC<-c("beanplot","cowplot","Seurat","EBImage","survival","rms","mixtools","MASS","ggplot2", 79 | "nnet","ppcor","ROCR","tsne","gplots","ggpubr","EnhancedVolcano","plyr","reshape2","plotrix","stats", "Matrix", 80 | "Rtsne","lmerTest","devtools","gplots","heatmap3","e1071","openxlsx","RColorBrewer","heatmap3","UpSetR") 81 | attach("mtcars") 82 | source_url("https://raw.githubusercontent.com/obigriffith/biostar-tutorials/master/Heatmaps/heatmap.3.R") 83 | v<-laply(libs4HGSC,function(x) library(x,character.only = T)) 84 | v<-lapply(libs4HGSC,function(x) library(x,character.only = T)) 85 | attach("mtcars") 86 | source_url("https://raw.githubusercontent.com/obigriffith/biostar-tutorials/master/Heatmaps/heatmap.3.R") 87 | attach("mtcars") 88 | libs4HGSC<-c("beanplot","cowplot","Seurat","EBImage","survival","rms","mixtools","MASS","ggplot2","mtcars", 89 | "nnet","ppcor","ROCR","tsne","gplots","ggpubr","EnhancedVolcano","plyr","reshape2","plotrix","stats", "Matrix", 90 | "Rtsne","lmerTest","devtools","gplots","heatmap3","e1071","openxlsx","RColorBrewer","heatmap3","UpSetR") 91 | v<-lapply(libs4HGSC,function(x) library(x,character.only = T)) 92 | source("~/Desktop/GitHub/HGSC_SpatialPerturbational/Code/HGSCgit_main.R") 93 | source("~/Desktop/GitHub/HGSC_SpatialPerturbational/Code/HGSCgit_main.R") 94 | rm(list=ls()) 95 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE",force = T) 96 | library(DIALOGUE) 97 | DIALOGUE::DIALOGUE.run 98 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE",force = T) 99 | library(DIALOGUE) 100 | DIALOGUE::DIALOGUE.run 101 | library(DIALOGUE) 102 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE",force = T) 103 | library(DIALOGUE) 104 | rm(list=setdiff(ls(),"rA")) 105 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE",force = T) 106 | library(DIALOGUE) 107 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE",force = T) 108 | library(DIALOGUE) 109 | DIALOGUE::DIALOGUE.run 110 | DIALOGUE.run 111 | source("~/Desktop/R_code/2_backup/V3/MS_Dialogue/DIALOGUE_reproduce_2023.R") 112 | results.dir <- "~/Desktop/SMI/" 113 | cell.types<-c("fibroblast","macrophage","T.CD4") 114 | rA<-readRDS("~/Desktop/R_code/6_Github/DIALOGUE/Data/DLG_SMI.input.rds") 115 | param<-list(seed1 = 1234,averaging.function = colMeans,center.flag = T,extra.sparse = F, 116 | conf = c("cellQ"),covar = c("cellQ"),#c("cellQ","tme.qc"), 117 | results.dir = results.dir) 118 | rA1<-lapply(rA, function(r) {r@extra.scores$XAv<-NULL;return(r)}) 119 | param<-list(seed1 = 1234,averaging.function = colMeans,center.flag = T,extra.sparse = F, 120 | conf = c("cellQ"),covar = c("cellQ"),# ,"tme.qc" 121 | results.dir = "~/Desktop/DLG/") 122 | R1<-DIALOGUE::DIALOGUE.run(rA = rA1,main = "SMI.recomp50",k = 3, 123 | results.dir = param$results.dir, 124 | plot.flag = F,conf = param$conf,n.genes = 50, 125 | covar = param$conf,averaging.function = param$averaging.function, 126 | center.flag = param$center.flag,PMD2 = F,find.genes = T, 127 | extra.sparse = param$extra.sparse,spatial.flag = T) 128 | X<-read.xlsx("~/Downloads/41587_2022_1288_MOESM2_ESM.xlsx",startRow = 2,sheet = 3) 129 | library(DIALOGUE) 130 | source("~/Desktop/R_code/6_Github/JerbyLab/JerbyLab_package.R") 131 | X<-read.xlsx("~/Downloads/41587_2022_1288_MOESM2_ESM.xlsx",startRow = 2,sheet = 3) 132 | sig1<-split(X$Genes[X$MCP=="MCP1"],X$Cell.type[X$MCP=="MCP1"]) 133 | sig2<-split(X$Genes[X$MCP=="MCP2"],X$Cell.type[X$MCP=="MCP2"]) 134 | sig3<-split(X$Genes[X$MCP=="MCP3"],X$Cell.type[X$MCP=="MCP3"]) 135 | X<-read.xlsx("~/Downloads/41587_2022_1288_MOESM2_ESM.xlsx",startRow = 2,sheet = 3) 136 | library(openxlsx) 137 | X<-read.xlsx("~/Downloads/41587_2022_1288_MOESM2_ESM.xlsx",startRow = 2,sheet = 3) 138 | sig1<-split(X$Genes[X$MCP=="MCP1"],X$Cell.type[X$MCP=="MCP1"]) 139 | sig2<-split(X$Genes[X$MCP=="MCP2"],X$Cell.type[X$MCP=="MCP2"]) 140 | sig3<-split(X$Genes[X$MCP=="MCP3"],X$Cell.type[X$MCP=="MCP3"]) 141 | summary(R1$MCPs$MCP1) 142 | summary(sig1) 143 | sig.comp(sig1,R1$MCPs2$MCP1) 144 | sig.comp(sig1,R1$MCPs$MCP1) 145 | sig.comp(sig1,R1$MCPs.full$MCP1) 146 | sig.comp(sig1,R1$MCPs$MCP1) 147 | sig.comp(sig2,R1$MCPs$MCP2) 148 | sig.comp(sig3,R1$MCPs$MCP3) 149 | sig.comp(sig1,R1$MCPs$MCP1) 150 | sig.comp(sig2,R1$MCPs$MCP2) 151 | sig.comp(sig3,R1$MCPs$MCP3) 152 | R1$param 153 | R1$param$n.genes 154 | R<-readRDS("~/Desktop/DLG/DLG.full.output_SMI.recomp50.rds") 155 | summary(R) 156 | View(R$cca$ws$fibroblast) 157 | R0<-readRDS("~/Desktop/R_code/6_Github/DIALOGUE/Data/DLG.full.output_SMI.final.rds") 158 | View(R0$cca$ws$fibroblast) 159 | View(R1$scores$fibroblast) 160 | View(R0$scores$fibroblast) 161 | View(R0$cca.scores) 162 | names(R) 163 | names(R0) 164 | laply(names(R),function(x) identical(R[[x]],R0[[x]])) 165 | names(R)[laply(names(R),function(x) identical(R[[x]],R0[[x]]))] 166 | names(R)[!laply(names(R),function(x) identical(R[[x]],R0[[x]]))] 167 | Routput<-R1 168 | R1<-R0 169 | sig.comp(sig1,R1$MCPs2$MCP1) 170 | sig.comp(sig2,R1$MCPs2$MCP2) 171 | sig.comp(sig3,R1$MCPs2$MCP3) 172 | names(R)[!laply(names(R),function(x) identical(R[[x]],R0[[x]]))] 173 | names(R)[laply(names(R),function(x) identical(R[[x]],R0[[x]]))] 174 | summary(R$cca.sig) 175 | summary(R$cca.sig$fibroblast) 176 | R$covar 177 | R1$covar 178 | R0$covar 179 | Routput$covar 180 | names(R)[laply(names(R),function(x) identical(R[[x]],R0[[x]]))] 181 | names(R)[!laply(names(R),function(x) identical(R[[x]],R0[[x]]))] 182 | param<-list(seed1 = 1234,averaging.function = colMeans,center.flag = T,extra.sparse = F, 183 | conf = c("cellQ"),covar = c("cellQ","tme.qc"), 184 | results.dir = "~/Desktop/DLG/") 185 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_install.R") 186 | source("~/Desktop/GitHub/DIALOGUE/R/DIALOGUE.cell.type.R") 187 | source("~/Desktop/GitHub/DIALOGUE/R/DIALOGUE.util.R") 188 | source("~/Desktop/GitHub/DIALOGUE/R/DIALOGUE.plot.R") 189 | source("~/Desktop/R_code/6_Github/DIALOGUE/DIALOGUE.main_Github_param_08062023.R") 190 | file.edit("~/Desktop/R_code/6_Github/DIALOGUE/DIALOGUE.main_Github_param_08062023.R") 191 | rA<-readRDS(file = DLG.get.file("Data/DLG.input_LungCancer.SMI.rds")) 192 | param<-DLG.get.param(k = 3,seed1 = 1234, 193 | frm = "y ~ (1 | fov:slides) + (1 | slides) + x + cellQ + tme.qc", 194 | averaging.function = colMeans, 195 | center.flag = T,extra.sparse = F, 196 | conf = c("cellQ"),covar = c("cellQ","tme.qc"), 197 | results.dir = "/Volumes/Resource2/DIALOGUE/Reproduce2023/", 198 | plot.flag = F,n.genes = 50, 199 | PMD2 = F,spatial.flag = T) 200 | debugSource("~/Desktop/R_code/6_Github/DIALOGUE/DIALOGUE.main_Github_param_08062023.R") 201 | param$single.BH 202 | param<-DLG.get.param(k = 3,seed1 = 1234, 203 | frm = "y ~ (1 | fov:slides) + (1 | slides) + x + cellQ + tme.qc", 204 | averaging.function = colMeans, 205 | center.flag = T,extra.sparse = F,single.BH = T, 206 | conf = c("cellQ"),covar = c("cellQ","tme.qc"), 207 | results.dir = "/Volumes/Resource2/DIALOGUE/Reproduce2023/", 208 | plot.flag = F,n.genes = 50, 209 | PMD2 = F,spatial.flag = T) 210 | param$frm <- "y ~ (1 | slides) + x + cellQ + tme.qc" 211 | R<-DIALOGUE.run(rA = rA,main = "SMI_slides",param = param) 212 | library(DIALOGUE) 213 | source("~/Desktop/R_code/6_Github/DIALOGUE/DIALOGUE.main_Github_param_08062023.R") 214 | param$frm <- "y ~ (1 | slides) + x + cellQ + tme.qc" 215 | param 216 | R<-DIALOGUE.run(rA = rA,main = "SMI_slides",param = param) 217 | R<-readRDS("/Volumes/Resource2/DIALOGUE/Reproduce2023/DLG.full.output_SMI_slides.rds") 218 | R1<-R 219 | library(openxlsx) 220 | X<-read.xlsx("~/Downloads/41587_2022_1288_MOESM2_ESM.xlsx",startRow = 2,sheet = 3) 221 | sig1<-split(X$Genes[X$MCP=="MCP1"],X$Cell.type[X$MCP=="MCP1"]) 222 | sig2<-split(X$Genes[X$MCP=="MCP2"],X$Cell.type[X$MCP=="MCP2"]) 223 | sig3<-split(X$Genes[X$MCP=="MCP3"],X$Cell.type[X$MCP=="MCP3"]) 224 | summary(R1$MCPs$MCP1) 225 | summary(sig1) 226 | sig.comp(sig1,R1$MCPs2$MCP1) 227 | source("~/Desktop/R_code/6_Github/JerbyLab/JerbyLab_package.R") 228 | sig.comp(sig1,R1$MCPs2$MCP1) 229 | sig.comp(sig1,R1$MCPs$MCP1) 230 | R<-readRDS("/Volumes/Resource2/DIALOGUE/Reproduce2023/DLG.full.output_SMI_fovs.rds") 231 | sig.comp(sig1,R1$MCPs$MCP1) 232 | R<-readRDS("/Volumes/Resource2/DIALOGUE/Reproduce2023/DLG.full.output_SMI_slides.rds") 233 | sig.comp(sig1,R1$MCPs$MCP1) 234 | R1<-readRDS("/Volumes/Resource2/DIALOGUE/Reproduce2023/DLG.full.output_SMI_slides.rds") 235 | R2<-readRDS("/Volumes/Resource2/DIALOGUE/Reproduce2023/DLG.full.output_SMI_fovs.rds") 236 | sig.comp(sig1,R1$MCPs$MCP1) 237 | sig.comp(R2$MCPs$MCP1,R1$MCPs$MCP1) 238 | R3<-readRDS("/Volumes/Resource2/DIALOGUE/Reproduce2023/DLG.full.output_SMI.recompFrm.rds") 239 | sig.comp(sig1,R3$MCPs$MCP1) 240 | R3<-readRDS("/Volumes/Resource2/DIALOGUE/Reproduce2023/DLG.full.output_SMI.recompFrm1.rds") 241 | sig.comp(sig1,R3$MCPs$MCP1) 242 | R3<-readRDS("/Volumes/Resource2/DIALOGUE/Reproduce2023/DLG.full.output_SMI.recompFrm2.rds") 243 | sig.comp(sig1,R3$MCPs$MCP1) 244 | R3<-readRDS("/Volumes/Resource2/DIALOGUE/Reproduce2023/DLG.full.output_SMI.recompFrm.rds") 245 | sig.comp(sig1,R3$MCPs$MCP1) 246 | sig.comp(sig2,R3$MCPs$MCP2) 247 | R<-R3 248 | X1<-R$gene.pval$fibroblast 249 | View(X1) 250 | setdiff(sig2$fibroblast.down,R$MCPs$MCP2$fibroblast.down) 251 | setdiff(R$MCPs$MCP2$fibroblast.down,sig2$fibroblast.down) 252 | X1<-X1[X1$programF=="MCP2.down"] 253 | X1<-X1[X1$programF=="MCP2.down",] 254 | View(X1[paste0("MCP2.down_",setdiff(R$MCPs$MCP2$fibroblast.down,sig2$fibroblast.down)),]) 255 | R$frm 256 | R$cca.gene.cor$fibroblast["CCL5",] 257 | R$cca.gene.cor$fibroblast$R["CCL5",] 258 | R$cca.gene.cor$fibroblast$P["CCL5",] 259 | rm(list=ls()) 260 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE") 261 | library(DIALOGUE) 262 | rA<-readRDS(file = DLG.get.file("Data/DLG.input_LungCancer.SMI.rds")) 263 | library(DIALOGUE) 264 | DIALOGUE::DLG.get.param 265 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_install.R") 266 | rA<-readRDS(file = DLG.get.file("Data/DLG.input_LungCancer.SMI.rds")) 267 | param<-DLG.get.param(k = 3,seed1 = 1234, 268 | frm = "y ~ (1 | fov:slides) + (1 | slides) + x + cellQ + tme.qc", 269 | averaging.function = colMeans, 270 | center.flag = T,extra.sparse = F, 271 | conf = c("cellQ"),covar = c("cellQ","tme.qc"), 272 | results.dir = DLG.get.file("/Results/"), 273 | plot.flag = F,n.genes = 50, 274 | PMD2 = F,spatial.flag = T) 275 | R<-DIALOGUE.run(rA = rA1,main = "SMI",param = param) 276 | R<-DIALOGUE.run(rA = rA,main = "SMI",param = param) 277 | rA<-DLG_add.XAv(rA) 278 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 279 | rA<-DLG_add.XAv(rA) 280 | source("~/Desktop/GitHub/DIALOGUE/R/DIALOGUE.util.R") 281 | rA<-DLG_add.XAv(rA) 282 | saveRDS(rA,DLG.get.file("Data/DLG.input_LungCancer.SMI.rds")) 283 | rm(list=setdiff(ls(),"rA")) 284 | library(DIALOGUE) 285 | param<-DLG.get.param(k = 3,seed1 = 1234, 286 | frm = "y ~ (1 | fov:slides) + (1 | slides) + x + cellQ + tme.qc", 287 | averaging.function = colMeans, 288 | center.flag = T,extra.sparse = F, 289 | conf = c("cellQ"),covar = c("cellQ","tme.qc"), 290 | results.dir = DLG.get.file("/Results/"), 291 | plot.flag = F,n.genes = 50, 292 | PMD2 = F,spatial.flag = T) 293 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_install.R") 294 | param<-DLG.get.param(k = 3,seed1 = 1234, 295 | frm = "y ~ (1 | fov:slides) + (1 | slides) + x + cellQ + tme.qc", 296 | averaging.function = colMeans, 297 | center.flag = T,extra.sparse = F, 298 | conf = c("cellQ"),covar = c("cellQ","tme.qc"), 299 | results.dir = DLG.get.file("/Results/"), 300 | plot.flag = F,n.genes = 50, 301 | PMD2 = F,spatial.flag = T) 302 | R<-DIALOGUE.run(rA = rA,main = "SMI",param = param) 303 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 304 | R<-DIALOGUE.run(rA = rA,main = "LungCancer.SMI",param = param) 305 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE",force = T) 306 | library(DIALOGUE) 307 | # Run a toy example 308 | rA<-readRDS(system.file("Data", "test.example.rds", package = "DIALOGUE")) 309 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_install.R") 310 | param<-DLG.get.param(k = 2,results.dir = DLG.get.file("/Results/"), 311 | conf = "cellQ",pheno = "pathology") 312 | param<-DLG.get.param(k = 2,results.dir = DLG.get.file("/Results/"), 313 | conf = "cellQ",pheno = "pathology") 314 | R<-DIALOGUE.run(rA = rA,main = "toyExample",param = param,plot.flag = T) 315 | file.exists(param$results.dir) 316 | R<-DIALOGUE.run(rA = rA,main = "toyExample",param = param,plot.flag = T) 317 | library(UpSetR) 318 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE") 319 | library(DIALOGUE) 320 | DIALOGUE::DIALOGUE.run 321 | DIALOGUE.run 322 | upset(fromList(sig[5:8]), order.by = "freq") 323 | ?upset 324 | # Run a toy example 325 | rA<-readRDS(system.file("Data", "test.example.rds", package = "DIALOGUE")) 326 | param<-DLG.get.param(k = 2,results.dir = DLG.get.file("/Results/"), 327 | conf = "cellQ",pheno = "pathology") 328 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_install.R") 329 | param<-DLG.get.param(k = 2,results.dir = DLG.get.file("/Results/"), 330 | conf = "cellQ",pheno = "pathology") 331 | assertthat::assert_that(file.exists(param$results.dir)) 332 | R<-DIALOGUE.run(rA = rA,main = "toyExample",param = param,plot.flag = T) 333 | R<-DIALOGUE.run(rA = rA,main = "toyExample",param = param,plot.flag = F) 334 | DIALOGUE.run 335 | DIALOGUE.plot(R, results.dir = param$results.dir, pheno = param$pheno) 336 | R$MCPs$MCP1 337 | R$MCPs$MCP2 338 | R$MCPs$MCP3 339 | laply(R$MCPs,is.null) 340 | summary(R$MCPs) 341 | summary(R$MCPs$MCP1) 342 | summary(unlist(R$MCPs,recursive = F)) 343 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE") 344 | library(DIALOGUE) 345 | DIALOGUE::DIALOGUE.run 346 | DIALOGUE.run 347 | # Run a toy example 348 | rA<-readRDS(system.file("Data", "test.example.rds", package = "DIALOGUE")) 349 | param<-DLG.get.param(k = 2,results.dir = DLG.get.file("/Results/"), 350 | conf = "cellQ",pheno = "pathology",n.genes = 100) 351 | assertthat::assert_that(file.exists(param$results.dir)) 352 | param<-DLG.get.param(k = 2,results.dir = DLG.get.file("/Results/"), 353 | conf = "cellQ",pheno = "pathology",n.genes = 100) 354 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_install.R") 355 | param<-DLG.get.param(k = 2,results.dir = DLG.get.file("/Results/"), 356 | conf = "cellQ",pheno = "pathology",n.genes = 100) 357 | assertthat::assert_that(file.exists(param$results.dir)) 358 | R<-DIALOGUE.run(rA = rA,main = "toyExample",param = param,plot.flag = T) 359 | R<-readRDS("/Volumes/Resource2/DIALOGUE_GitHub/Results/DLG.output_toyExample.rds") 360 | DIALOGUE.plot(R, results.dir = param$results.dir, pheno = param$pheno) 361 | debugSource("~/Desktop/GitHub/DIALOGUE/R/DIALOGUE.plot.R") 362 | p<-lapply(names(R$MCPs[laply(R$MCPs,!is.null)]), function(x){ 363 | sig<-R$MCPs[[x]] 364 | names(sig)<-paste(x,names(sig),sep = ".") 365 | p1<-list(upset(fromList(sig[grepl("up",names(sig))]), order.by = "freq"), 366 | upset(fromList(sig[grepl("down",names(sig))]), order.by = "freq")) 367 | return(p1) 368 | }) 369 | names(R$MCPs[laply(R$MCPs,!is.null)]) 370 | laply(R$MCPs,!is.null) 371 | laply(R$MCPs,is.null) 372 | source("~/Desktop/GitHub/DIALOGUE/R/DIALOGUE.plot.R") 373 | DIALOGUE.plot(R, results.dir = param$results.dir, pheno = param$pheno) 374 | p<-lapply(names(R$MCPs[!laply(R$MCPs,is.null)]), function(x){ 375 | sig<-R$MCPs[[x]] 376 | names(sig)<-paste(x,names(sig),sep = ".") 377 | p1<-list(upset(fromList(sig[grepl("up",names(sig))]), order.by = "freq"), 378 | upset(fromList(sig[grepl("down",names(sig))]), order.by = "freq")) 379 | return(p1) 380 | }) 381 | print(p) 382 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE") 383 | source("~/Desktop/GitHub/DIALOGUE/R/DIALOGUE.plot.R") 384 | library(DIALOGUE) 385 | # Run a toy example 386 | rA<-readRDS(system.file("Data", "test.example.rds", package = "DIALOGUE")) 387 | param<-DLG.get.param(k = 2,results.dir = DLG.get.file("/Results/"), 388 | conf = "cellQ",pheno = "pathology",n.genes = 100) 389 | assertthat::assert_that(file.exists(param$results.dir)) 390 | R<-DIALOGUE.run(rA = rA,main = "toyExample",param = param,plot.flag = T) 391 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_install.R") 392 | param<-DLG.get.param(k = 2,results.dir = DLG.get.file("/Results/"), 393 | conf = "cellQ",pheno = "pathology",n.genes = 100) 394 | param 395 | param$n.genes 396 | assertthat::assert_that(file.exists(param$results.dir)) 397 | R<-DIALOGUE.run(rA = rA,main = "toyExample",param = param,plot.flag = T) 398 | R<-DIALOGUE.run(rA = rA,main = "toyExample",param = param,plot.flag = T) 399 | summary(unlist(R$MCPs,recursive = F)) 400 | R$MCPs$MCP1$A.down 401 | print(round(R$phenoZ,2)) 402 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE") 403 | rA$A@metadata 404 | head(rA$A@metadata) 405 | head(rA$A@metadata[,-1]) 406 | head(rA$A@metadata[,c("cellQ","gender","location","pathology")]) 407 | system.file("Data", "test.example.rds", package = "DIALOGUE") 408 | ?system.file 409 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 410 | library(DIALOGUE) 411 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 412 | rA<-readRDS(file = DLG.get.file("Data/DLG.input_LungCancer.SMI.rds")) 413 | param<-DLG.get.param(k = 3,seed1 = 1234, 414 | frm = "y ~ (1 | fov:slides) + (1 | slides) + x + cellQ + tme.qc", 415 | averaging.function = colMeans, 416 | center.flag = T,extra.sparse = F, 417 | conf = c("cellQ"),covar = c("cellQ","tme.qc"), 418 | results.dir = DLG.get.file("/Results/"), 419 | plot.flag = F,n.genes = 50, 420 | PMD2 = F,spatial.flag = T) 421 | R<-DIALOGUE.run(rA = rA,main = "LungCancer.SMI",param = param) 422 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 423 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 424 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 425 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 426 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 427 | tictoc::tic() 428 | param<-DLG.get.param(k = 3,seed1 = 1234, 429 | frm = "y ~ (1 | fov:slides) + (1 | slides) + x + cellQ + tme.qc", 430 | averaging.function = colMeans, 431 | center.flag = T,extra.sparse = F, 432 | conf = c("cellQ"),covar = c("cellQ","tme.qc"), 433 | results.dir = DLG.get.file("/Results/"), 434 | plot.flag = F,n.genes = 50, 435 | PMD2 = F,spatial.flag = T) 436 | R<-DIALOGUE.run(rA = rA,main = "LungCancer.SMI",param = param) 437 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE") 438 | library(DIALOGUE) 439 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 440 | rA<-readRDS(file = DLG.get.file("Data/DLG.input_LungCancer.SMI.rds")) 441 | R<-readRDS(DLG.get.file("Results/DIALOGUE1_LungCancer.SMI.rds")) 442 | R$scores<-lapply(R$cell.types,function(x) cbind.data.frame(R$cca.scores[[x]],rA[[x]]@metadata)) 443 | names(R$scores)<-R$cell.types 444 | print("Reproducing Figure 3 from (Jerby and Regev, NBT 2022).") 445 | p1<-DLG_LungCancer.SMI.subplots(R,slide1 = 'Lung13',n.plots = 4,q1 = 0.9,MCPs = 1:2,D = -1, 446 | fileName = DLG.get.file("/Figures/Figure3_Lung13.pdf")) 447 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 448 | p1<-DLG_LungCancer.SMI.subplots(R,slide1 = 'Lung13',n.plots = 4,q1 = 0.9,MCPs = 1:2,D = -1, 449 | fileName = DLG.get.file("/Figures/Figure3_Lung13.pdf")) 450 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 451 | p1<-DLG_LungCancer.SMI.subplots(R,slide1 = 'Lung13',n.plots = 4,q1 = 0.9,MCPs = 1:2,D = -1, 452 | fileName = DLG.get.file("/Figures/Figure3_Lung13.pdf")) 453 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 454 | source("~/Desktop/R_code/6_Github/DIALOGUE/DLG_repro_2023_SMI.R") 455 | p1<-DLG_LungCancer.SMI.subplots(R,slide1 = 'Lung13',n.plots = 4,q1 = 0.9,MCPs = 1:2,D = -1, 456 | fileName = DLG.get.file("/Figures/Figure3_Lung13.pdf")) 457 | add.n.of.samples<-function(l,n.flag = T,sep = " "){ 458 | num.samples<-table(l) 459 | idx<-match(l,names(num.samples)) 460 | if(n.flag){ 461 | l<-paste0(l,sep,"(n = ",num.samples[idx],")") 462 | }else{ 463 | l<-paste0(l,sep,"(",num.samples[idx],")") 464 | } 465 | return(l) 466 | } 467 | p1<-DLG_LungCancer.SMI.subplots(R,slide1 = 'Lung13',n.plots = 4,q1 = 0.9,MCPs = 1:2,D = -1, 468 | fileName = DLG.get.file("/Figures/Figure3_Lung13.pdf")) 469 | get.strsplit<-function(v,sep,idx){ 470 | v<-as.character(v) 471 | vi<-laply(strsplit(v,split = sep,fixed = T),function(x) x[idx]) 472 | return(vi) 473 | } 474 | p1<-DLG_LungCancer.SMI.subplots(R,slide1 = 'Lung13',n.plots = 4,q1 = 0.9,MCPs = 1:2,D = -1, 475 | fileName = DLG.get.file("/Figures/Figure3_Lung13.pdf")) 476 | p1<-DLG_LungCancer.SMI.subplots(R,slide1 = 'Lung13',n.plots = 4,q1 = 0.9,MCPs = 1:2,D = -1, 477 | fileName = DLG.get.file("/Figures/Figure3_Lung13.pdf")) 478 | cap.mat<-function(M,cap = 0.01,MARGIN = 1){ 479 | Z<-apply(M,MARGIN = MARGIN,function(x){ 480 | q9<-quantile(x,1-cap) 481 | q1<-quantile(x,cap) 482 | x[x>q9]<-q9;x[xp.anova)," of ",length(p)," features.")) 150 | if(sum(p(0.05/nrow(r@tpm))]<-0 239 | R$cca.sig[[x]]<-get.top.cor(C1,q = param$n.genes,min.ci = 0.05) 240 | R$cca.redun.cor[[x]]<-cor(r@scores[,1:param$k]) 241 | R$samples.cells[[x]]<-r@samples 242 | } 243 | if(param$bypass.emp){R$emp.p1<-emp.p1} 244 | saveRDS(R,file = paste0(param$results.dir,"/",R$name,".rds")) 245 | dir.create(paste0(param$results.dir,"/DIALOGUE2_",main)) 246 | return(R) 247 | } 248 | 249 | DIALOGUE1.PMD<-function(X,k,PMD2 = F,extra.sparse = F,seed1 = 1234){ 250 | set.seed(seed1) 251 | if(extra.sparse){ 252 | perm.out <- MultiCCA.permute(X,type=rep("standard",length(X)),trace = F) 253 | }else{ 254 | perm.out <- MultiCCA.permute(X,type=rep("standard",length(X)),trace = F,penalties = sqrt(ncol(X[[1]]))/2) 255 | } 256 | out <- MultiCCA(X, type=rep("standard",length(X)), 257 | penalty=perm.out$bestpenalties,niter = 100, 258 | ncomponents=k, ws=perm.out$ws.init,trace = F) 259 | names(out$ws)<-names(X) 260 | m<-laply(out$ws,function(x) colSums(x!=0)) 261 | colnames(m)<-paste0("MCP",1:ncol(m)) 262 | rownames(m)<-names(X) 263 | for(i in names(X)){ 264 | colnames(out$ws[[i]])<-paste0("MCP",1:k) 265 | rownames(out$ws[[i]])<-colnames(X[[i]]) 266 | } 267 | if(!PMD2){return(out)} 268 | 269 | print("PMD #1");print("Number of features");print(m); 270 | set.seed(seed1) 271 | perm.out <- MultiCCA.permute(X,type=rep("standard",length(X)),trace = F,penalties = perm.out$penalties[,4:10]) 272 | out <- MultiCCA(X, type=rep("standard",length(X)), 273 | penalty=perm.out$bestpenalties,niter = 100, 274 | ncomponents=k, ws=perm.out$ws.init,trace = F) 275 | m<-laply(out$ws,function(x) colSums(x!=0));rownames(m)<-names(X) 276 | print("PMD #2");print("Number of features");print(m) 277 | return(out) 278 | } 279 | 280 | DIALOGUE1.PMD.empirical<-function(X,k,seed = 1234,n1 = 20,extra.sparse = F,full.output = F){ 281 | if(n1>1){ 282 | cca.cor<-lapply(1:k, function(x) NULL) 283 | v<-DIALOGUE1.PMD.empirical(X,k,seed = 0,n1 = 1,extra.sparse = extra.sparse) 284 | cca.cor<-lapply(1:k, function(x) rbind(cca.cor[[x]],v[x,])) 285 | for(x in 2:n1){ 286 | v<-DIALOGUE1.PMD.empirical(X,k,seed = sample(1:10000,1),n1 = 1,extra.sparse = extra.sparse) 287 | cca.cor<-lapply(1:k, function(x) rbind(cca.cor[[x]],v[x,])) 288 | } 289 | names(cca.cor)<-paste0("MCP",1:k) 290 | P<-laply(cca.cor,function(m){ 291 | p<-ranksum.test.mat(as.matrix(t(m)),c(T,rep(F,nrow(m)-1)))[,"more"] 292 | return(p)}) 293 | if(is.null(dim(P))){P<-as.matrix(P)} 294 | rownames(P)<-names(cca.cor) 295 | return(P) 296 | } 297 | if(seed>0){ 298 | set.seed(seed) 299 | X<-lapply(X,function(X1){ 300 | X2<-apply(X1,2,function(x) sample(x,length(x))) 301 | rownames(X2)<-rownames(X1) 302 | return(X2)}) 303 | } 304 | if(extra.sparse){ 305 | perm.out <- MultiCCA.permute(X,type=rep("standard",length(X)),trace = F) 306 | }else{ 307 | perm.out <- MultiCCA.permute(X,type=rep("standard",length(X)),trace = F,penalties = sqrt(ncol(X[[1]]))/2) 308 | } 309 | out <- MultiCCA(X, type=rep("standard",length(X)), 310 | penalty=perm.out$bestpenalties,niter = 100, 311 | ncomponents=k, ws=perm.out$ws.init,trace = F) 312 | names(out$ws)<-names(X) 313 | for(i in names(X)){ 314 | colnames(out$ws[[i]])<-paste0("MCP",1:ncol(out$ws[[i]])) 315 | rownames(out$ws[[i]])<-colnames(X[[i]]) 316 | } 317 | Y<-lapply(names(X), function(i) X[[i]]%*%out$ws[[i]]) 318 | names(Y)<-names(X) 319 | pairs1<-t(combn(names(X),2)) 320 | cca.cor<-apply(pairs1,1,function(x) diag(cor(Y[[x[1]]],Y[[x[2]]]))) 321 | colnames(cca.cor)<-paste(pairs1[,1],pairs1[,2],sep = "_") 322 | if(full.output){ 323 | out$Y<-Y 324 | out$cor<-cca.cor 325 | return(out) 326 | } 327 | return(cca.cor) 328 | } 329 | 330 | DIALOGUE1.PMD.pairwise<-function(X,k,specific.pair){ 331 | out<-DIALOGUE1.PMD.empirical(X = X,k = k,n1 = 1,full.output = T,seed = 0) 332 | X1<-X[specific.pair] 333 | x1<-specific.pair[1] 334 | x2<-specific.pair[2] 335 | out1<-DIALOGUE1.PMD.empirical(X = X1,k = k,n1 = 1,full.output = T,seed = 0) 336 | c1<-spearman.cor(out$Y[[x1]],out1$Y[[x1]],method = "pearson") 337 | c2<-spearman.cor(out$Y[[x2]],out1$Y[[x2]],method = "pearson") 338 | c1$padj<-p.adjust.mat(c1$p) 339 | c2$padj<-p.adjust.mat(c2$p) 340 | B<-c1$padj<0.05&c2$padj<0.05&abs(c1$cor)>0.3&abs(c2$cor)>0.3 341 | m<-laply(1:ncol(c1$cor),function(i){ 342 | x<-c1$cor[,i] 343 | idx<-which(abs(x)==max(abs(x))) 344 | return(c(c1$cor[idx,i],c2$cor[idx,i],c1$padj[idx,i],c2$padj[idx,i])) 345 | }) 346 | rownames(m)<-colnames(c1$cor) 347 | colnames(m)<-c("R1","R2","P1","P2") 348 | b<-colSums(B)==0 349 | if(!any(b)){ 350 | print(paste("No unique programs specific to",specific.pair[1],"and",specific.pair[2])) 351 | rslts<-list(cor = m,message = "No programs") 352 | return(rslts) 353 | }else{ 354 | print(paste("Identified",sum(b),"unique programs for",specific.pair[1],"and",specific.pair[2])) 355 | } 356 | out1$mcp.comp<-m 357 | out1$ws[[x1]]<-out1$ws[[x1]][,b] 358 | out1$ws[[x2]]<-out1$ws[[x2]][,b] 359 | out1$message<-paste(sum(b),"programs.") 360 | return(out1) 361 | } 362 | 363 | DIALOGUE2<-function(rA,main,results.dir = "~/Desktop/DIALOGUE.results/"){ 364 | print("#************DIALOGUE Step II: HLM ************#") 365 | cell.types<-names(rA) 366 | if(missing(main)){main<-paste0(cell.types,collapse = "_")} 367 | file1<-paste0(results.dir,"/DIALOGUE1_",main,".rds") 368 | file2<-paste0(results.dir,"/DIALOGUE2_",main,".rds") 369 | 370 | R<-readRDS(file1) 371 | if(is.null(R$param$frm)){ 372 | R$frm<-paste0("y ~ (1 | samples) + x + ",paste(R$covar,collapse = " + ")) 373 | }else{ 374 | R$frm<-R$param$frm 375 | print("Using input formula.") 376 | } 377 | print(R$frm) 378 | 379 | k2<-ncol(R$cca$ws[[1]]) 380 | pairs1<-t(combn(cell.types,2)) 381 | sig<-R$cca.sig 382 | 383 | f<-function(i){ 384 | x1<-pairs1[i,1];x2<-pairs1[i,2] 385 | print(paste("#************DIALOGUE Step II (multilevel modeling):",x1,"vs.",x2,"************#")) 386 | p<-paste0(x1,".vs.",x2) 387 | rslts<-DIALOGUE2.pair(R,rA[[x1]],rA[[x2]],cell.types,results.dir) 388 | return(rslts) 389 | } 390 | 391 | if(R$param$parallel.vs){ 392 | R1<-mclapply(1:nrow(pairs1),f) 393 | names(R1)<-paste(pairs1[,1],pairs1[,2],sep = ".vs.") 394 | R<-c(R,R1) 395 | }else{ 396 | for(i in 1:nrow(pairs1)){ 397 | x1<-pairs1[i,1];x2<-pairs1[i,2] 398 | print(paste("#************DIALOGUE Step II (multilevel modeling):",x1,"vs.",x2,"************#")) 399 | R[[paste0(x1,".vs.",x2)]]<-DIALOGUE2.pair(R,rA[[x1]],rA[[x2]],cell.types,results.dir) 400 | } 401 | } 402 | 403 | R$name<-paste0("DIALOGUE2_",main) 404 | saveRDS(R,file = file2) 405 | return(R) 406 | } 407 | 408 | DIALOGUE2.pair<-function(R,r1,r2,cell.types,results.dir){ 409 | x1<-r1@name;x2<-r2@name 410 | MCP.names<-names(R$MCP.cell.types)[laply(R$MCP.cell.types,function(x) sum(is.element(c(x1,x2),x))==2)] 411 | if(is.null(MCP.names)|length(MCP.names)==0){ 412 | print("No MCPs identified for these cell types.") 413 | return(NULL) 414 | } 415 | print(paste(length(MCP.names),"MCPs identified for these cell types.")) 416 | main<-gsub("DIALOGUE1_","",R$name) 417 | 418 | saveFile<-paste0(results.dir,"/DIALOGUE2_",main,"/",x1,".vs.",x2,".rds") 419 | if(file.exists(saveFile)){ 420 | return(readRDS(saveFile)) 421 | } 422 | sig1<-R$cca.sig[[x1]] 423 | sig2<-R$cca.sig[[x2]] 424 | idx<-intersect(get.abundant(r1@samples),get.abundant(r2@samples)) 425 | r1<-set.cell.type(r1,is.element(r1@samples,idx)) 426 | r2<-set.cell.type(r2,is.element(r2@samples,idx)) 427 | r1@scores<-R$cca.scores[[x1]][r1@cells,] 428 | r2@scores<-R$cca.scores[[x2]][r2@cells,] 429 | r<-DLG.get.OE(r1,r2,sig1,sig2,compute.scores = F);r1<-r$r1;r2<-r$r2 430 | r1@tme<-r2@tpmAv[,as.character(r1@samples)] 431 | r2@tme<-r1@tpmAv[,as.character(r2@samples)] 432 | 433 | r1@tme.qc<-as.matrix(r2@qcAv)[as.character(r1@samples),2] 434 | r2@tme.qc<-as.matrix(r1@qcAv)[as.character(r2@samples),2] 435 | 436 | r1a<-cell.type.2.list(r1) 437 | r2a<-cell.type.2.list(r2) 438 | 439 | # r1a<-set.list(r1a,sample.per.label(r1a$samples,50),sampleName = paste0(r1a$name,"_A")) 440 | # r2a<-set.list(r2a,sample.per.label(r2a$samples,50),sampleName = paste0(r2a$name,"_A")) 441 | 442 | f1<-function(sig1,sig2,x){ 443 | p1<-DIALOGUE2.mixed.effects(r2a,x,sig1,R$frm) 444 | p2<-DIALOGUE2.mixed.effects(r1a,x,sig2,R$frm) 445 | sig1f<-intersect.list1(get.top.cor(p1[!is.na(p1$Z),],q = 100,idx = "Z",min.ci = 1),r1@genes) 446 | sig2f<-intersect.list1(get.top.cor(p2[!is.na(p2$Z),],q = 100,idx = "Z",min.ci = 1),r2@genes) 447 | names(sig1f)<-gsub("Z.",paste0(x,"."),names(sig1f)) 448 | names(sig2f)<-gsub("Z.",paste0(x,"."),names(sig2f)) 449 | p1$program<-x;p2$program<-x 450 | p1$genes<-rownames(p1);p2$genes<-rownames(p2) 451 | results<-list(p1 = p1,p2 = p2,sig1f = sig1f,sig2f = sig2f) 452 | return(results) 453 | } 454 | 455 | R1<-lapply(MCP.names,function(x){f1(sig1,sig2,x)}) 456 | names(R1)<-MCP.names 457 | R1$p1<-NULL;R1$p2<-NULL 458 | for(x in MCP.names){ 459 | R1$p1<-rbind(R1$p1,R1[[x]]$p1) 460 | R1$p2<-rbind(R1$p2,R1[[x]]$p2) 461 | } 462 | R1$sig1<-lapply(R[MCP.names], function(x) x$sig1f) 463 | R1$sig2<-lapply(R[MCP.names], function(x) x$sig2f) 464 | R1$name<-paste0(x1,".vs.",x2) 465 | saveRDS(R1,file = saveFile) 466 | return(R1) 467 | } 468 | 469 | DIALOGUE2.mixed.effects<-function(r1,x,sig2,frm = "y ~ (1 | samples) + x + cellQ"){ 470 | # r1 was a cell.type S4 that was converted to a list. 471 | genes<-unlist(sig2[paste0(x,c(".up",".down"))]) 472 | b<-is.element(genes,rownames(r1$tme)) 473 | p<-apply.formula.HLM(r1,r1$scores[,x], 474 | X = r1$tme[genes[b],], 475 | MARGIN = 1,formula = frm) 476 | p$pval<-p.adjust(p$P,method = "BH") 477 | p$up<-is.element(rownames(p),sig2[[paste0(x,".up")]]) 478 | if(all(b)){return(p)} 479 | P<-get.mat(genes,colnames(p)) 480 | P[b,]<-as.matrix(p) 481 | rownames(P)<-gsub(".","-",rownames(P),fixed = T) 482 | P<-as.data.frame(P) 483 | return(P) 484 | } 485 | 486 | DIALOGUE3<-function(rA,main,results.dir = "~/Desktop/DIALOGUE.results/"){ 487 | print("#************Finalizing the scores************#") 488 | cell.types<-names(rA) 489 | if(missing(main)){main<-paste0(cell.types,collapse = "_")} 490 | print(paste0(results.dir,"/DIALOGUE2_",main,".rds")) 491 | R<-readRDS(paste0(results.dir,"/DIALOGUE2_",main,".rds")) 492 | R$gene.pval<-lapply(R$cell.types, function(x){DLG.multi.get.gene.pval(x,R)}) 493 | names(R$gene.pval)<-R$cell.types 494 | 495 | rA<-lapply(rA,function(r){ 496 | r<-DLG.find.scoring(r,R) 497 | return(r) 498 | }) 499 | names(rA)<-cell.types 500 | R$pref<-list() 501 | idx<-unique(get.strsplit(names(R$sig[[1]]),".",1)) 502 | pairs1<-t(combn(cell.types,2)) 503 | 504 | for(i in 1:nrow(pairs1)){ 505 | x1<-pairs1[i,1];x2<-pairs1[i,2] 506 | x<-paste0(x1,".vs.",x2) 507 | r1<-rA[[x1]];r2<-rA[[x2]] 508 | r<-DLG.get.OE(r1,r2,plot.flag = F,compute.scores = F) 509 | r1<-r$r1;r2<-r$r2 510 | idx<-intersect(get.abundant(r1@samples),get.abundant(r2@samples)) 511 | R$pref[[x]]<-cbind.data.frame(R = diag(cor(r1@scoresAv[idx,],r2@scoresAv[idx,])), 512 | hlm = DLG.hlm.pval(r1,r2,formula = R$frm)) 513 | } 514 | 515 | R$gene.pval<-lapply(rA,function(r1) r1@gene.pval) 516 | R$sig1<-lapply(rA,function(r1) r1@sig$sig1) 517 | R$sig2<-lapply(rA,function(r1) r1@sig$sig2) 518 | R$scores<-lapply(rA,function(r1){ 519 | X<-cbind.data.frame(r1@scores,samples = r1@samples, 520 | cells = r1@cells, cell.type = r1@name, 521 | r1@metadata) 522 | return(X)}) 523 | names(R$gene.pval)<-cell.types 524 | names(R$sig1)<-cell.types 525 | names(R$sig2)<-cell.types 526 | names(R$scores)<-cell.types 527 | 528 | R$name<-paste0("DLG.output_",main) 529 | R$MCPs.full<-sig2MCP(R$sig1) 530 | R$MCPs<-sig2MCP(R$sig2) 531 | 532 | R$cca.fit<-laply(R$cell.types,function(x) diag(cor(R$cca.scores[[x]],R$scores[[x]][,1:R$k["DIALOGUE"]]))) 533 | rownames(R$cca.fit)<-R$cell.types 534 | 535 | fileName<-paste0(results.dir,"DLG.full.output_",main,".rds") 536 | 537 | if(!is.null(R$param$pheno)){R$phenoZ<-DIALOGUE.pheno(R,pheno = R$param$pheno)} 538 | if(R$param$full.version){saveRDS(R,file = fileName)} 539 | 540 | R1<-R[intersect(names(R),c("cell.types","scores","gene.pval","param","MCP.cell.types","MCPs","MCPs.full", 541 | "emp.p","pref","k","name","phenoZ",results.dir))] 542 | fileName<-paste0(results.dir,"DLG.output_",main,".rds") 543 | saveRDS(R1,file = fileName) 544 | 545 | if(!R$param$full.version){ 546 | file.remove(paste0(results.dir,"DIALOGUE1_",main,".rds")) 547 | file.remove(paste0(results.dir,"DIALOGUE2_",main,".rds")) 548 | unlink(paste0(results.dir,"DIALOGUE2_",main,"/"),recursive = T) 549 | } 550 | return(R1) 551 | } 552 | 553 | DLG.get.OE<-function(r1,r2,sig1,sig2,plot.flag = F,compute.scores = T){ 554 | if(compute.scores){ 555 | r1@scores<-get.OE(r1,sig1,semi.flag = T) 556 | r2@scores<-get.OE(r2,sig2,semi.flag = T) 557 | } 558 | r1@scoresAv<-average.mat.rows(r1@scores,r1@samples,f = colMedians) 559 | r2@scoresAv<-average.mat.rows(r2@scores,r2@samples,f = colMedians) 560 | r1@tme.OE<-r2@scoresAv[match(r1@samples,rownames(r2@scoresAv)),] 561 | r2@tme.OE<-r1@scoresAv[match(r2@samples,rownames(r1@scoresAv)),] 562 | r<-list(r1 = r1,r2= r2) 563 | if(!plot.flag){return(r)} 564 | # r$cor<-DLG.cor.plot(r1,r2,sd.flag = F,q1 = 1/3,q2 = 2/3) 565 | DLG.cor.plot(r1,r2,sd.flag = F,q1 = 1/3,q2 = 2/3) 566 | return(r) 567 | } 568 | 569 | DLG.fix.sig.names<-function(sig){ 570 | b<-!get.abundant(get.strsplit(names(sig),".",1),boolean.flag = T) 571 | names(sig)[b]<-get.strsplit(names(sig[b]),".",1) 572 | return(sig) 573 | } 574 | 575 | DLG.multi.get.gene.pval<-function(cell.type,R){ 576 | b<-grepl("vs.",names(R)) 577 | pairs1<-get.strsplit(names(R),".vs.",1:2) 578 | b1<-b&is.element(pairs1[,1],cell.type) 579 | b2<-b&is.element(pairs1[,2],cell.type) 580 | if((sum(b1)+sum(b2))==0){return(NULL)} 581 | f1<-function(m1,pi = "p1"){ 582 | x<-m1[[pi]] 583 | rownames(x)<-paste0(x$program,ifelse(x$up,".up_",".down_"),x$genes) 584 | return(x) 585 | } 586 | m<-c(lapply(R[b1],f1),lapply(R[b2],function(m1) f1(m1,"p2"))) 587 | g<-unique(unlist(lapply(m,rownames))) 588 | p<-get.strsplit(g,"_",1:2) 589 | colnames(p)<-c("programF","genes") 590 | rownames(p)<-g 591 | p<-cbind.data.frame(p,program = get.strsplit(g,".",1), 592 | up = grepl("up",g)) 593 | names(m)<-gsub(paste0(cell.type,".vs."),"",names(m)) 594 | names(m)<-gsub(paste0(".vs.",cell.type),"",names(m)) 595 | for(i in names(m)){ 596 | x<-m[[i]] 597 | g1<-paste0(x$program,ifelse(x$up,".up_",".down_"),x$genes) 598 | idx<-match(g,g1) 599 | p[,i]<-x$Z[idx] 600 | } 601 | 602 | # AD was without adjustments 603 | p.up<-p.adjust.mat.per.label(get.pval.from.zscores(p[,5:ncol(p)]),p$programF) 604 | p.down<-p.adjust.mat.per.label(get.pval.from.zscores(-p[,5:ncol(p)]),p$programF) 605 | 606 | p.ub<-0.1 607 | if(!is.matrix(p.up)){p.up<-as.matrix(p.up);p.down<-as.matrix(p.down)} 608 | m<-cbind.data.frame(p[,c(names(m),"programF","genes")], 609 | p.up = fisher.combine(p.up), 610 | p.down = fisher.combine(p.down), 611 | n.up = rowSums(p.up0|(m1$n.up>=lb&m1$p.up<1e-3)|(m1$n.down>=lb&m1$p.down<1e-3),] 676 | m2<-m2[m2$Nf==1&(m2$p.up<0.05|m2$p.down<0.05),] 677 | r1@sig<-list(sig1 = split(m1$genes,m1$programF),sig2 = split(m2$genes,m2$programF)) 678 | return(r1) 679 | } 680 | 681 | DLG.initialize<-function(r1,R){ 682 | gene.pval<-R$gene.pval[[r1@name]] 683 | WS<-R$cca$ws[[r1@name]] 684 | r1@extra.scores$cca0<-r1@X[,rownames(WS)]%*%WS 685 | conf.m<-r1@metadata[,is.element(colnames(r1@metadata),R$conf)] 686 | r1@extra.scores$cca<-t(get.residuals(t(r1@extra.scores$cca0),conf.m)) 687 | r1@scores<-r1@extra.scores$cca 688 | r1@scoresAv<-average.mat.rows(r1@scores,r1@samples) 689 | r1@gene.pval<-NULL 690 | r1@sig<-NULL 691 | return(r1) 692 | } 693 | 694 | DLG.iterative.nnls<-function(X,y,gene.pval){ 695 | set.seed(1234) 696 | f.rank<-gene.pval$Nf 697 | y1<-y;y.fit<-rep(0,length(y)) 698 | v<-list() 699 | gene.pval$coef<-0 700 | idx<-sort(unique(f.rank),decreasing = T) 701 | idx<-idx[idx>=(1/3)] 702 | for(n1 in idx){ 703 | b1<-f.rank==n1 704 | if(sum(b1,na.rm = T)<5){next()} 705 | X1<-X[,b1] 706 | main<-paste0("N",n1) 707 | v[[main]]<-nnls::nnls(X1,y) 708 | y<-v[[main]]$residuals 709 | y.fit<-y.fit+v[[main]]$fitted 710 | gene.pval$coef[b1]<-v[[main]]$x 711 | if(length(unique(y.fit))>10 & cor(y1,y.fit)>0.95){ 712 | # cor.plot(y.fit,y1,main = paste("NNLS fitting",n1)) 713 | return(gene.pval) 714 | } 715 | } 716 | if(sum(f.rank1){ 732 | par(mfrow=c(2,2),oma = c(0, 0, 2, 0)) 733 | lapply(idx, function(x){ 734 | DLG.cor.plot(r1,r2,x,q1 = q1,q2 = q2,sd.flag = sd.flag) 735 | return(x) 736 | }) 737 | return() 738 | } 739 | idx1<-intersect(rownames(r1@scoresAv),rownames(r2@scoresAv)) 740 | x<-r1@scoresAv[idx1,idx] 741 | y<-r2@scoresAv[idx1,idx] 742 | # pheno<-is.element(rownames(r1@scoresAv),r1@samples[r1@pat1]) 743 | x0<-laply(idx1,function(x) quantile(r1@scores[r1@samples==x,idx],q1)) 744 | x1<-laply(idx1,function(x) quantile(r1@scores[r1@samples==x,idx],q2)) 745 | y0<-laply(idx1,function(x) quantile(r2@scores[r2@samples==x,idx],q1)) 746 | y1<-laply(idx1,function(x) quantile(r2@scores[r2@samples==x,idx],q2)) 747 | if(sd.flag){ 748 | xd<-laply(idx1,function(x) sd(r1@scores[r1@samples==x,idx]))/2 749 | yd<-laply(idx1,function(x) sd(r2@scores[r2@samples==x,idx]))/2 750 | x0<-x-(xd);x1<-x+(xd) 751 | y0<-y-(yd);y1<-y+(yd) 752 | } 753 | cor.plot(x,y,main = paste("Program",idx),cex = 1, 754 | xlim = c(min(c(x,x0)),max(c(x,x1))), 755 | ylim = c(min(c(y,y0)),max(c(y,y1)))) 756 | for(i in 1:length(x)){ 757 | # col<-ifelse(pheno[i],"red","grey") 758 | col<-"grey" 759 | arrows(x0=x0[i], y0=y[i], x1=x1[i], y1=y[i], code=3, col=col, lwd=2,angle=0,length = 0) 760 | arrows(x0=x[i], y0=y0[i], x1=x[i], y1=y1[i], code=3, col=col, lwd=2,angle=0,length = 0) 761 | } 762 | # points(x,y,col = ifelse(pheno,"red","black"),pch = 16,xlim = c(min(x0),max(x1)),ylim = c(min(y0),max(y1))) 763 | points(x,y,col = "black",pch = 16,xlim = c(min(x0),max(x1)),ylim = c(min(y0),max(y1))) 764 | return(spearman.cor(x,y)) 765 | 766 | } 767 | 768 | DLG.hlm.pval<-function(r1,r2,formula = "y ~ (1 | samples) + x + cellQ"){ 769 | idx<-c("samples","scores","tme.OE",intersect(slotNames(r1),setdiff(gsub(" ","",get.strsplit(formula,"+ ",1:10)),NA))) 770 | r1<-cell.type.2.list(r1,idx = idx) 771 | r2<-cell.type.2.list(r2,idx = idx) 772 | f<-function(x){ 773 | p<-c(p1 = formula.HLM(r1,y = r1$scores[,x],x = r1$tme.OE[,x],formula = formula), 774 | p2 = formula.HLM(r2,y = r2$scores[,x],x = r2$tme.OE[,x],formula = formula)) 775 | return(p) 776 | } 777 | idx<-unique(get.strsplit(colnames(r1$scores),".",1)) 778 | m<-laply(idx,f)[,c(2,4)] 779 | rownames(m)<-idx 780 | return(m) 781 | } 782 | 783 | DLG.plot1<-function(R,i,mark.samples = NULL,d = 1){ 784 | R$cell.types<-names(R$cca.scores) 785 | k<-ncol(R$cca.scores[[1]]) 786 | R$scoresAv<-lapply(R$cell.types,function(x){ 787 | m<-R$cca.scores[[x]] 788 | X<-average.mat.rows(as.matrix(m[,1:k]),R$samples.cells[[x]],f = colMedians) 789 | return(X) 790 | }) 791 | idx<-unlist(lapply(R$scoresAv, function(m) rownames(m))) 792 | idx<-get.abundant(idx,length(R$cell.types)) 793 | R$scoresAv<-lapply(R$scoresAv,function(m) m[idx,]) 794 | col<-rep("black",length(idx)) 795 | col[is.element(idx,mark.samples)]<-"red" 796 | pch<-ifelse(any(col=="red"),21,16) 797 | f<-function(i){ 798 | m1<-t(laply(R$scoresAv,function(m) m[,i]))*d 799 | rownames(m1)<-idx;colnames(m1)<-R$cell.types 800 | pairs.panels(m1,hist.col = "grey",breaks = 50,bg = col,pch = pch,ellipses = F,smooth = T,lm = T,stars = T) 801 | title(i) 802 | return(m1) 803 | } 804 | idx1<-paste0("MCP",1:R$k["DIALOGUE"]) 805 | if(!missing(i)){m1<-f(i);return(cor(m1))} 806 | m<-lapply(idx1, f) 807 | } 808 | 809 | DLG.add.metadata<-function(R,rA){ 810 | if(missing(rA)){ 811 | R$metadata<-lapply(R$cell.types,function(x) R$scores[[x]][,(R$k[1]+1):ncol(R$scores[[x]])]) 812 | names(R$metadata)<-R$cell.types 813 | return(R) 814 | } 815 | 816 | R$metadata<-lapply(rA,function(r1){ 817 | X<-cbind.data.frame(samples = r1@samples, 818 | cells = r1@cells, 819 | cell.type = r1@name, 820 | r1@metadata) 821 | return(X)}) 822 | names(R$metadata)<-R$cell.types 823 | return(R) 824 | } 825 | 826 | sig2MCP<-function(R.sig,k = 5){ 827 | sig1<-unlist(R.sig,recursive = F) 828 | sig1<-c(sig1[grepl("up",names(sig1))],sig1[grepl("down",names(sig1))]) 829 | MCPs<-lapply(1:k,function(x){ 830 | idx<-paste0("MCP",x,".") 831 | sig1<-sig1[grepl(idx,names(sig1))] 832 | names(sig1)<-gsub(idx,"",names(sig1)) 833 | if(length(unique(get.strsplit(names(sig1),".",1)))<2){ 834 | print(paste0("Removing MCP",x)) 835 | return(NULL) 836 | } 837 | return(sig1) 838 | }) 839 | names(MCPs)<-paste0("MCP",1:k) 840 | return(MCPs) 841 | } 842 | 843 | DIALOGUE.identify.cell.types<-function(R){ 844 | if(!is.null(R$param$MCP.cell.types)){ 845 | print("Using pre-defined cell types.") 846 | return(R$param$MCP.cell.types) 847 | } 848 | 849 | if(length(R$cell.types)==2){ 850 | MCP.cell.types<-lapply(R$emp.p, function(x){ 851 | if(x<0.1){return(R$cell.types)} 852 | return(NULL) 853 | }) 854 | names(MCP.cell.types)<-rownames(R$emp.p) 855 | return(MCP.cell.types) 856 | } 857 | emp.p<-R$emp.p 858 | emp.p2<-R$emp.p 859 | colnames(emp.p2)<-paste(get.strsplit(colnames(emp.p),"_",2), 860 | get.strsplit(colnames(emp.p),"_",1),sep = "_") 861 | emp.p<-cbind(emp.p,emp.p2) 862 | MCP.cell.types<-list() 863 | for(x in paste0("MCP",1:nrow(emp.p))){ 864 | cell.types<-R$cell.types 865 | p1<-generic.vector2mat(emp.p[x,]) 866 | diag(p1)<-0.05 867 | lb<-min(rowSums(p1<0.1)) 868 | while(lb1] 90 | genes<-unique(sort(unlist(R$MCPs))) 91 | f<-function(sig1,d = 1){ 92 | if(d==1){ 93 | b<-!grepl(".down",names(sig1)) 94 | }else{ 95 | b<-grepl(".down",names(sig1)) 96 | } 97 | if(!any(b)){return(rep("",length(genes)))} 98 | sig1<-sig1[b] 99 | names(sig1)<-gsub(".up","",names(sig1)) 100 | names(sig1)<-gsub(".down","",names(sig1)) 101 | v<-list.2.ids(genes,sig1) 102 | return(c(v)) 103 | } 104 | if(length(R$MCPs)>1){ 105 | m1<-t(laply(R$MCPs,f)) 106 | m2<-t(laply(R$MCPs,function(x) f(x,-1))) 107 | colnames(m1)<-paste0(names(R$MCPs),".up") 108 | colnames(m2)<-paste0(names(R$MCPs),".down") 109 | m<-cbind(m1,m2) 110 | }else{ 111 | m<-cbind(f(R$MCPs[[1]]),f(R$MCPs[[1]],d = -1)) 112 | colnames(m)<-paste0(names(R$MCPs),c(".up",".down")) 113 | } 114 | 115 | idx<-R$cell.types 116 | idxA<-idx 117 | for(i in 2:length(idx)){ 118 | idxA<-c(idxA,apply(combn(idx,i),2,function(x) paste(x,collapse = "&"))) 119 | } 120 | idxA 121 | m1<-laply(idxA,function(x) colSums(m==x)) 122 | rownames(m1)<-idxA 123 | b<-stri_count(str = rownames(m1),regex = "&")>1 124 | m2<-rbind(m1[!b,],colSums(subset.matrix(m1,b))) 125 | rownames(m2)[nrow(m2)]<-"> 2 cell types" 126 | if(all(m2["> 2 cell types",]==0)){m2<-m2[1:(nrow(m2)-1),]} 127 | m1<-melt(m2) 128 | colnames(m1)<-c("col","x","y") 129 | p<-ggplot(data=m1, aes(x=x, y=y, fill=col))+geom_bar(stat="identity")+ 130 | labs(fill = "Cell type(s)", x = "Program", y = "No. of genes") 131 | p<-p+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank(), 132 | panel.background = element_blank(), axis.line = element_line(colour = "black")) 133 | p<-p+theme(text = element_text(size=12),axis.text.x = element_text(angle=45, hjust=1)) 134 | multiplot.util(list(NULL,p,NULL),cols = 1,nplots = 3) 135 | return(m2) 136 | } 137 | 138 | DIALOGUE.upset<-function(R){ 139 | p<-lapply(names(R$MCPs[!laply(R$MCPs,is.null)]), function(x){ 140 | sig<-R$MCPs[[x]] 141 | names(sig)<-paste(x,names(sig),sep = ".") 142 | p1<-list(upset(fromList(sig[grepl("up",names(sig))]), order.by = "freq"), 143 | upset(fromList(sig[grepl("down",names(sig))]), order.by = "freq")) 144 | return(p1) 145 | }) 146 | print(p) 147 | return(p) 148 | 149 | } 150 | 151 | DIALOGUE.violin.pheno<-function(R,pheno = "pathology",MCPs,selected.samples,d = 1){ 152 | k<-R$k["DIALOGUE"] 153 | X<-NULL 154 | for(x in R$scores){ 155 | x[,1:k]<-cap.mat(center.matrix(x[,1:k],dim = 2,sd.flag = T),cap = 0.01,MARGIN = 2) 156 | X<-rbind(X,x) 157 | X<-X[!is.na(X[,pheno]),] 158 | } 159 | if(!is.element("id",colnames(X))){X$id<-X$cell.type} 160 | # if(is.logical(X[,pheno])){X[,pheno]<-ifelse(X[,pheno],"Disease","Control")} 161 | if(!missing(selected.samples)){X<-X[is.element(X$samples,selected.samples),]} 162 | 163 | par(mfrow=c(1,1),oma = c(5, 0, 0, 7)) 164 | f<-function(x){ 165 | b<-is.element(X$cell.type,R$MCP.cell.types[[x]]) 166 | violin.split(scores = d*X[b,x],treatment = X[b,pheno], 167 | conditions = X$id[b],xlab = "", 168 | main = paste0(x," (",pheno,")")) 169 | return(x) 170 | } 171 | if(missing(MCPs)){MCPs<-paste0("MCP",1:k)} 172 | laply(MCPs,f) 173 | return() 174 | 175 | } 176 | 177 | multiplot.util<-function(plotlist,nplots = 4,cols = 2){ 178 | flag<-F 179 | while(!is.null(plotlist)&!flag){ 180 | print(multiplot(plotlist = plotlist[1:min(nplots,length(plotlist))],cols = cols)) 181 | flag<-(min(nplots,length(plotlist))+1)>length(plotlist) 182 | plotlist<-plotlist[(min(nplots,length(plotlist))+1):length(plotlist)] 183 | } 184 | } 185 | 186 | list.2.ids<-function(ids,l,single.flag = F){ 187 | if(length(l)==1){ 188 | m<-ifelse(is.element(ids,l[[1]]),names(l),"") 189 | return(m) 190 | } 191 | B<-t(laply(l,function(x) is.element(ids,x))) 192 | colnames(B)<-names(l) 193 | m<-get.mat(ids,"Anno") 194 | m[]<-"ID" 195 | for(i in names(l)){ 196 | m[B[,i]]<-paste(m[B[,i]],i,sep = "&") 197 | } 198 | m<-gsub("ID&","",m) 199 | m<-gsub("ID","",m) 200 | if(single.flag){ 201 | m<-cbind(m,get.strsplit(m,"&",1)) 202 | m[m[,1]=="",2]<-"" 203 | } 204 | return(m) 205 | } 206 | 207 | get.mat<-function(m.rows,m.cols,data = NA){ 208 | m<-matrix(data = data, nrow = length(m.rows),ncol = length(m.cols), 209 | dimnames = list(m.rows,m.cols)) 210 | return(m) 211 | } 212 | 213 | multiplot<-function(..., plotlist=NULL, file, cols=1, layout=NULL) { 214 | # Make a list from the ... arguments and plotlist 215 | plots <- c(list(...), plotlist) 216 | numPlots = length(plots) 217 | 218 | # If layout is NULL, then use 'cols' to determine layout 219 | if (is.null(layout)) { 220 | # Make the panel 221 | # ncol: Number of columns of plots 222 | # nrow: Number of rows needed, calculated from # of cols 223 | layout <- matrix(seq(1, cols * ceiling(numPlots/cols)), 224 | ncol = cols, nrow = ceiling(numPlots/cols)) 225 | } 226 | 227 | if (numPlots==1) { 228 | print(plots[[1]]) 229 | 230 | } else { 231 | # Set up the page 232 | grid.newpage() 233 | pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout)))) 234 | 235 | # Make each plot, in the correct location 236 | for (i in 1:numPlots) { 237 | # Get the i,j matrix positions of the regions that contain this subplot 238 | matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE)) 239 | 240 | print(plots[[i]], vp = viewport(layout.pos.row = matchidx$row, 241 | layout.pos.col = matchidx$col)) 242 | } 243 | } 244 | } 245 | 246 | violin.split<-function(scores, treatment, conditions, main = "", 247 | xlab = "Sample",ylab = "Scores",legend.flag = T,show.pval = T){ 248 | # require(beanplot) 249 | if(length(unique(conditions))==1){ 250 | p<-t.test.mat(m = rbind(scores,scores),b = treatment == sort(treatment,decreasing = T)[1])[1,1] 251 | }else{ 252 | p<-t.test.groups(x = rbind(scores,scores),b = treatment == sort(treatment,decreasing = T)[1],g = conditions)[1,] 253 | p<-p[sort(names(p))] 254 | } 255 | p[p<(-30)]<-(-30);p[p>30]<-30 256 | if(show.pval){ 257 | conditions<-paste0(conditions,"\n",laply(10^-abs(p[conditions]),my.format.pval)) 258 | } 259 | treatment<-as.factor(treatment) 260 | beanplot(scores ~ treatment*conditions, ll = 0.0,las = 2, 261 | main = main, side = "both", xlab=xlab,ylab = ylab, 262 | col = list(c("lightblue", "black"),"gray"), 263 | axes=T,cex.main = 1) 264 | if(legend.flag){ 265 | legend("bottomright", fill = c("lightblue","gray"), 266 | legend = levels(treatment), box.lty=0) 267 | } 268 | return(p) 269 | } 270 | 271 | -------------------------------------------------------------------------------- /R/DIALOGUE.util.R: -------------------------------------------------------------------------------- 1 | average.mat.rows<-function(m,ids,f = colMeans){ 2 | ids.u<-sort(get.abundant(ids)) 3 | m1<-laply(ids.u,function(x){return(f(m[is.element(ids,x),]))}) 4 | rownames(m1)<-ids.u 5 | colnames(m1)<-colnames(m) 6 | 7 | ids.u1<-setdiff(unique(ids),ids.u) 8 | if(length(ids.u1)==0){return(m1)} 9 | b<-is.element(ids,ids.u1) 10 | m0<-m[b,] 11 | if(sum(b)==1){m0<-t(as.matrix(m0))} 12 | rownames(m0)<-ids[b] 13 | 14 | m2<-rbind(m1,m0) 15 | m2<-m2[sort(rownames(m2)),] 16 | return(m2) 17 | } 18 | 19 | center.large.matrix<-function(m,sd.flag,v = NULL){ 20 | if(is.null(v)){ 21 | v<-rowMeans(m,na.rm = T) 22 | } 23 | if(!sd.flag){ 24 | for(i in 1:nrow(m)){ 25 | m[i,]<-m[i,]-v[i] 26 | } 27 | }else{ 28 | for(i in 1:nrow(m)){ 29 | x<-m[i,] 30 | m[i,]<-(x-v[i])/sd(x,na.rm = T) 31 | } 32 | } 33 | return(m) 34 | } 35 | 36 | get.abundant<-function(v,abn.c = 2,boolean.flag = F,top,decreasing = T){ 37 | m<-as.matrix(table(v)) 38 | m<-as.matrix(m[order(m,decreasing = decreasing),]) 39 | if(!missing(top)){ 40 | abn.c<-m[top] 41 | } 42 | m<-m[m>=abn.c,] 43 | abn.names<-names(m) 44 | if(boolean.flag){ 45 | b<-is.element(v,abn.names) 46 | return(b) 47 | } 48 | return(abn.names) 49 | } 50 | 51 | #' center.matrix 52 | #' @export 53 | center.matrix<-function(m,dim = 1,sd.flag = F){ 54 | if(dim == 1){ 55 | zscores<-sweep(m,1,rowMeans(m,na.rm = T),FUN = '-') 56 | }else{ 57 | zscores<-sweep(m,2,colMeans(m,na.rm = T),FUN = '-') 58 | } 59 | if(sd.flag){ 60 | zscores<-sweep(zscores,dim,apply(m,dim,function(x) (sd(x,na.rm = T))),FUN = '/') 61 | } 62 | return(zscores) 63 | } 64 | 65 | #' cap.mat 66 | #' @export 67 | cap.mat<-function(M,cap = 0.01,MARGIN = 1){ 68 | Z<-apply(M,MARGIN = MARGIN,function(x){ 69 | q9<-quantile(x,1-cap) 70 | q1<-quantile(x,cap) 71 | x[x>q9]<-q9;x[x0 186 | b2<-rowSums(p.adjust.mat(de2[,1:2],method = "BH")<0.1,na.rm = T)>0 187 | table(b1,b2) 188 | b<-b1|b2 189 | de.ttest<-cbind.data.frame(sample = de1[,"zscores"],cell = de2[,"zscores"])[b,] 190 | Y<-Y[b,] 191 | } 192 | m<-t(apply(Y,MARGIN = MARGIN,function(y){formula.HLM(y,X,r,formula = formula)})) 193 | }else{ 194 | m<-t(apply(X,MARGIN = MARGIN,function(x){formula.HLM(Y,x,r,formula = formula)})) 195 | } 196 | colnames(m)<-c("Estimate","P") 197 | m<-cbind.data.frame(Z = get.cor.zscores(m[,"Estimate"],m[,"P"]),m) 198 | if(ttest.flag){ 199 | m<-cbind.data.frame(m,ttest = de.ttest) 200 | } 201 | return(m) 202 | } 203 | 204 | formula.HLM<-function(y,x,r0, formula = "y ~ (1 | samples) + x",val = ifelse(is.numeric(x),"","TRUE"),return.all = F){ 205 | r0$x<-x;r0$y<-y 206 | f<-function(r0){ 207 | M1 <- with(r0, lmer (formula = formula)) 208 | if(return.all){ 209 | c1<-summary(M1)$coef[,c("Estimate","Pr(>|t|)")] 210 | }else{ 211 | c1<-summary(M1)$coef[paste0("x",val),] 212 | idx<-match(c("Estimate","Pr(>|t|)"),names(c1)) 213 | c1<-c1[idx] 214 | } 215 | return(c1) 216 | } 217 | c1<-tryCatch({f(r0)}, 218 | error = function(err){return(c(NA,NA))}) 219 | return(c1) 220 | } 221 | 222 | get.cor.zscores<-function(c,p){ 223 | v<-cbind(get.onesided.p.value(c,p),get.onesided.p.value(-c,p)) 224 | z<-get.p.zscores(v) 225 | return(z) 226 | } 227 | 228 | get.onesided.p.value<-function(c,p){ 229 | p[p==0] = min(p[p>0],na.rm = T) 230 | p.one.side <- p 231 | p.one.side[] <- NA 232 | b<-c>0&!is.na(c) 233 | p.one.side[b]=p[b]/2 234 | b<-c<=0&!is.na(c) 235 | p.one.side[b]=1-(p[b]/2) 236 | return(p.one.side) 237 | } 238 | 239 | get.p.zscores<-function(p){ 240 | b<-p[,1]>0.5 241 | b[is.na(b)]<-F 242 | zscores<-(-log10(p[,1])) 243 | zscores[b]<-log10(p[b,2]) 244 | # signficiant in p[,1] will be positive 245 | # signficiant in p[,2] will be negative 246 | return(zscores) 247 | } 248 | 249 | intersect.list1<-function(l,g,n1=0,HG.universe = NULL,prf = ""){ 250 | l1<-lapply(l, function(x) intersect(x,g)) 251 | l1<-l1[laply(l1,length)>n1] 252 | if(prf!=""){ 253 | names(l1)<-paste(prf,names(l1),sep = ".") 254 | } 255 | if(!is.null(HG.universe)){ 256 | p<-GO.enrichment.lapply(l[names(l1)],genes = HG.universe,list(g)) 257 | names(l1)<-paste(names(l1),format(p,scientific = T,digits= 3),sep = "P = ") 258 | } 259 | return(l1) 260 | } 261 | 262 | fisher.combine<-function(p){ 263 | p.f<-apply(p,1,get.fisher.p.value) 264 | return(p.f) 265 | } 266 | 267 | get.fisher.p.value<-function(p){ 268 | p<-p[!is.na(p)] 269 | if(length(p)==1){ 270 | p.fisher=p 271 | }else{ 272 | p.fisher<- 1 - pchisq(-2*sum(log(p),na.rm = T), 2*sum(!is.na(p))) 273 | } 274 | return(p.fisher) 275 | } 276 | 277 | get.pval.from.zscores<-function(z){ 278 | p<-10^(-abs(z)) 279 | b<-z<0&!is.na(z) 280 | p[b]<-1-p[b] 281 | return(p) 282 | } 283 | 284 | cor.plot<-function(x,y = NULL,main = '',ylab = '', xlab = '',regression.flag = F,cex = 0.3, 285 | xlim = NULL,ylim = NULL){ 286 | if(is.null(y)){ 287 | v<-colnames(x) 288 | xlab<-v[1];ylab<-v[2] 289 | y<-x[,2];x<-x[,1] 290 | } 291 | v<-spearman.cor(x,y) 292 | main <- paste(main,"\nR =",format(v[1],digits = 2),"P =",format(v[2],scientific = T,digits = 2)) 293 | plot(x,y,main = main, xlab = xlab, ylab = ylab,cex = cex,pch=16,xlim = xlim,ylim = ylim) 294 | b<-!is.na(x)&!is.na(y) 295 | v<-lowess(x[b],y[b]) 296 | lines(v,col = "red") 297 | if(!regression.flag){return()} 298 | y.d<-y-v$y[match(x,v$x)] 299 | y.sd<-sd(y.d,na.rm = T) 300 | y.av<-mean(y.d,na.rm = T) 301 | labels<-matrix(data = "Moderate",nrow = length(y)) 302 | labels[y.d>(y.av+y.sd)]<-"High" 303 | labels[y.d<(y.av-y.sd)]<-"Low" 304 | my.plot(x,y,labels = labels,main = main,xlab = xlab,ylab = ylab) 305 | lines(v) 306 | return(y.d) 307 | } 308 | 309 | spearman.cor<-function(v1,v2 = NULL,method = 'spearman',use = "pairwise.complete.obs", 310 | match.flag = F,alternative = "two.sided",upper.tri.flag = F){ 311 | if(is.null(v2)){ 312 | v2<-v1 313 | } 314 | if(!is.matrix(v1)){v1<-as.matrix(v1)} 315 | if(!is.matrix(v2)){v2<-as.matrix(v2)} 316 | if(match.flag){ 317 | n=ncol(v1) 318 | if(is.null(colnames(v1))){colnames(v1)<-1:ncol(v1)} 319 | results<-get.mat(m.cols = c("R","P"),m.rows = colnames(v1)) 320 | for(i in 1:ncol(v1)){ 321 | c.i <- cor.test(v1[,i],v2[,i],method = method,use = use, alternative = alternative) 322 | results[i,1] <- c.i$estimate 323 | results[i,2] <- c.i$p.value 324 | } 325 | }else{ 326 | n1=ncol(v1) 327 | m<-matrix(nrow = n1,ncol = ncol(v2)) 328 | rownames(m)<-colnames(v1) 329 | colnames(m)<-colnames(v2) 330 | results<-list(cor = m, p = m) 331 | for(i in 1:n1){ 332 | f<-function(x){ 333 | c.i<-cor.test(v1[,i],x,method = method,use = use, alternative = alternative); 334 | c(c.i$estimate,c.i$p.value)} 335 | c.i <- apply(v2,2,f) 336 | results$cor[i,] <- c.i[1,] 337 | results$p[i,] <- c.i[2,] 338 | } 339 | if(ncol(v2)==1){ 340 | results<-cbind(results$cor,results$p) 341 | colnames(results)<-c('R','P') 342 | } 343 | } 344 | if(upper.tri.flag){ 345 | results$up <- cbind(results$cor[upper.tri(results$cor)], 346 | results$p[upper.tri(results$p)]) 347 | } 348 | return(results) 349 | } 350 | 351 | colMedians<-function(m){ 352 | m<-apply(m,2,function(x) median(x,na.rm = T)) 353 | return(m) 354 | } 355 | 356 | t.test.mat<-function(m,b,two.sided=F,rankf = F,fold.changeF = F){ 357 | if(length(b)!=ncol(m)){ 358 | print("Error. Inconsistent no. of samples.") 359 | return() 360 | } 361 | if(sum(b)<2||sum(!b)<2){ 362 | return(get.mat(rownames(m),c('more','less',"zscores"))) 363 | } 364 | if(two.sided){ 365 | p<-as.matrix(apply(m,1,function(x) t.test(x[b],x[!b])$p.value)) 366 | }else{ 367 | p<-t(apply(m,1,function(x) c(t.test(x[b],x[!b],alternative = 'greater')$p.value, 368 | t.test(x[b],x[!b],alternative = 'less')$p.value))) 369 | colnames(p)<-c('more','less') 370 | p<-cbind(p,get.p.zscores(p)) 371 | colnames(p)[3]<-"zscores" 372 | } 373 | if(rankf){ 374 | p<-cbind(p,rank(p[,1]),rank(p[,2])) 375 | colnames(p)[4:5]<-c("rank.more","rank.less") 376 | } 377 | if(fold.changeF){ 378 | p<-cbind.data.frame(p,pos.mean = rowMeans(m[,b]),neg.mean = rowMeans(m[,!b])) 379 | p$logFC<-log2(p$pos.mean/p$neg.mean) 380 | } 381 | 382 | return(p) 383 | } 384 | 385 | p.adjust.mat<-function(m,method = "BH"){ 386 | if(ncol(m)<2|is.null(ncol(m))){return(p.adjust(x,method = method))} 387 | P<-apply(m,2,function(x) p.adjust(x,method = method)) 388 | return(P) 389 | } 390 | 391 | my.match<-function(v1,v2){ 392 | v1<-casefold(my.gsub(pattern = c('_',"-",'.'," ",":"),replacement = '',x = v1)) 393 | v2<-casefold(my.gsub(pattern = c('_',"-",'.'," ",":"),replacement = '',x = v2)) 394 | idx<-match(v1,v2) 395 | return(idx) 396 | } 397 | 398 | my.gsub<-function(pattern,replacement = '',x){ 399 | for(i in 1:length(pattern)){ 400 | x<-gsub(pattern = pattern[i],replacement = replacement ,x = x,fixed = T) 401 | } 402 | return(x) 403 | } 404 | 405 | apply.anova <- function(X,y,MARGIN = 2){ 406 | y <- as.factor(y) 407 | f<-function(x){ 408 | a<-aov(x ~ y) 409 | p.anova <- unlist(summary(a))['Pr(>F)1'] 410 | return(p.anova) 411 | } 412 | P<-apply(X,MARGIN = MARGIN,FUN = f) 413 | return(P) 414 | } 415 | 416 | ranksum.test.mat<-function(m,b,zscores.flag = T,two.sided=F){ 417 | if(two.sided){ 418 | p<-as.matrix(apply(m,1,function(x) ranksum.test(x[b],x[!b]))) 419 | }else{ 420 | p<-t(apply(m,1,function(x) c(ranksum.test(x[b],x[!b],alternative = 'greater'), 421 | ranksum.test(x[b],x[!b],alternative = 'less')))) 422 | colnames(p)<-c('more','less') 423 | if(zscores.flag){ 424 | p<-cbind(p,get.p.zscores(p)) 425 | colnames(p)[3]<-"zscores" 426 | } 427 | } 428 | return(p) 429 | } 430 | 431 | ranksum.test<-function(v1,v2,alternative="two.sided"){ 432 | p=NA 433 | if (sum(!is.na(v1))==0|sum(!is.na(v2))==0){ 434 | return(p) 435 | }else{ 436 | p<-wilcox.test(v1,v2,alternative = alternative)$p.value 437 | } 438 | return(p) 439 | } 440 | 441 | get.p.zscores<-function(p){ 442 | b<-p[,1]>0.5 443 | b[is.na(b)]<-F 444 | zscores<-(-log10(p[,1])) 445 | zscores[b]<-log10(p[b,2]) 446 | # signficiant in p[,1] will be positive 447 | # signficiant in p[,2] will be negative 448 | return(zscores) 449 | } 450 | 451 | t.test.groups<-function(x,b,g,min.n = 1,cut.off = NULL){ 452 | x<-as.matrix(x) 453 | gu<-intersect(get.abundant(g[!b],min.n),get.abundant(g[b],min.n)) 454 | if(is.null(rownames(x))){ 455 | rownames(x)<-1:nrow(x) 456 | } 457 | v<-get.mat(rownames(x),gu) 458 | for (i in 1:length(gu)){ 459 | b.g<-is.element(g,gu[i]); 460 | v[,i]<-t.test.mat(x[,b.g],b[b.g])[,3] 461 | } 462 | if(!is.null(cut.off)){ 463 | v<-cbind.data.frame(Z.up = rowSums(v>3),Z.down = rowSums(v<(-3)),v) 464 | } 465 | return(v) 466 | } 467 | 468 | get.abundant<-function(v,abn.c = 2,boolean.flag = F,top,decreasing = T){ 469 | m<-as.matrix(table(v)) 470 | m<-as.matrix(m[order(m,decreasing = decreasing),]) 471 | if(!missing(top)){ 472 | abn.c<-m[top] 473 | } 474 | m<-m[m>=abn.c,] 475 | abn.names<-names(m) 476 | if(boolean.flag){ 477 | b<-is.element(v,abn.names) 478 | return(b) 479 | } 480 | return(abn.names) 481 | } 482 | 483 | get.mat<-function(m.rows,m.cols,data = NA){ 484 | m<-matrix(data = data, nrow = length(m.rows),ncol = length(m.cols), 485 | dimnames = list(m.rows,m.cols)) 486 | return(m) 487 | } 488 | 489 | my.format.pval<-function(p,prnt.flag = F,d = "="){ 490 | if(length(p)>1){ 491 | P<-laply(p,my.format.pval) 492 | P<-gsub("P = ","",P) 493 | # P<-paste0("P",1:length(P)," = ",P) 494 | P<-paste("P =",paste(P,collapse = ", ")) 495 | return(P) 496 | } 497 | if(abs(p)>1){ 498 | p<-10^(-abs(p)) 499 | } 500 | if(p>0.05){p<-paste("P",d,round(p,3));return(p)} 501 | p<-gsub("e","*10",paste("P",d,format(p,scientific = T,digits= 3))) 502 | p<-gsub("-0","-",p) 503 | if(prnt.flag){ 504 | p<-paste0("(",p,")") 505 | } 506 | return(p) 507 | } 508 | 509 | apply.formula.all.HLM<-function(r,X,Y,MARGIN = 1,formula = "y ~ (1 | samples) + x",ttest.flag = F){ 510 | if(is.matrix(Y)){ 511 | m<-t(apply(Y,MARGIN = MARGIN,function(y){ 512 | P<-formula.HLM(y,X,r,formula = formula,return.all = T) 513 | Z<-get.cor.zscores(P[,"Estimate"],P[,"Pr(>|t|)"]) 514 | return(Z) 515 | })) 516 | }else{ 517 | m<-t(apply(X,MARGIN = MARGIN,function(x){ 518 | P<-formula.HLM(Y,x,r,formula = formula,return.all = T) 519 | Z<-get.cor.zscores(P[,"Estimate"],P[,"Pr(>|t|)"]) 520 | return(Z) 521 | })) 522 | } 523 | return(m) 524 | } 525 | 526 | pcor.mat<-function(v1,v2,v3, method = 'spearman',use = "pairwise.complete.obs",alternative = "two.sided"){ 527 | f<-function(x1,x2,x3){ 528 | c.i<-tryCatch(pcor.test(x1,x2,x3,method = method), 529 | error = function(err){return(NA)}) 530 | if(is.list(c.i)){return(c(c.i$estimate,c.i$p.value))} 531 | return(c(NA,NA)) 532 | } 533 | 534 | f<-function(x1,x2,x3){ 535 | c.i<-pcor.test(x1,x2,x3,method = method) 536 | return(c(c.i$estimate,c.i$p.value)) 537 | } 538 | 539 | P<-get.mat(colnames(v1),colnames(v2));R<-P 540 | for(x in 1:ncol(v2)){ 541 | x2<-v2[,x] 542 | c1<-apply(v1,2,function(x1) f(x1,x2,v3)) 543 | R[,x]<-c1[1,] 544 | P[,x]<-c1[2,] 545 | } 546 | padj<-p.adjust.mat(P,method = "BH") 547 | rslts<-list(R = R,P = P,padj = padj) 548 | return(rslts) 549 | } 550 | 551 | p.adjust.mat.per.label<-function(p,v){ 552 | p1<-get.mat(rownames(p),colnames(p),data = NA) 553 | for(x in unique(v)){ 554 | b<-is.element(v,x) 555 | if(is.null(ncol(p1))||ncol(p1)<2){ 556 | p1[b]<-p.adjust(p[b]) 557 | }else{ 558 | p1[b,]<-p.adjust.mat(p[b,]) 559 | } 560 | 561 | } 562 | return(p1) 563 | } 564 | 565 | generic.vector2mat<-function(v,rn = get.strsplit(names(v),"_",1),cn = get.strsplit(names(v),"_",2)){ 566 | rnu <- sort(unique(rn)) 567 | cnu <- sort(unique(cn)) 568 | m<-get.mat(data = NA,m.rows = rnu,m.cols = cnu) 569 | for(x in rnu){ 570 | v1<-v[rn==x] 571 | cn1 <- cn[rn==x] 572 | idx<-match(cnu,cn1) 573 | m[x,]<-v1[idx] 574 | } 575 | return(m) 576 | } 577 | 578 | #' call.plot.plus 579 | #' @export 580 | call.plot.plus<-function(x, y = NULL,labels,b.top,red.top = F,regression.flag = F,my.col = NULL,set.flag = F,cor.flag = F, 581 | pch=16,cex=0.3,main="",ylab = "tSNE2",xlab = "tSNE1", cex.axis = 0.6, 582 | add.N = F,grey.zeros = F,legend.flag = T){ 583 | 584 | regl<-call.plot(x = x,y = y,labels,regression.flag,my.col = my.col, 585 | set.flag = set.flag,cor.flag = cor.flag, 586 | pch = pch,cex = cex,main = main,ylab = ylab,xlab = xlab, 587 | cex.axis = cex.axis, 588 | add.N = add.N,legend.flag = legend.flag) 589 | if(is.null(y)){ 590 | v<-colnames(x) 591 | if(xlab==""){xlab<-v[1]} 592 | if(ylab==""){ylab<-v[2]} 593 | y<-x[,2];x<-x[,1] 594 | } 595 | if(red.top){ 596 | points(x[b.top],y[b.top],cex = cex,col = "red",pch = 1) 597 | }else{ 598 | if(is.null(my.col)){ 599 | if(grey.zeros){ 600 | my.col<-rep("grey",length(labels)) 601 | my.col[labels>0]<-labels.2.colors(labels[labels>0]) 602 | }else{ 603 | my.col <- labels.2.colors(labels) 604 | } 605 | } 606 | points(x[b.top],y[b.top],cex = cex,col = my.col[b.top],pch = 16) 607 | } 608 | return(regl) 609 | 610 | } 611 | #' call.plot 612 | #' @export 613 | call.plot<-function(x, y = NULL,labels,regression.flag = F,my.col = NULL,set.flag = F,cor.flag = F,legend.flag = T, 614 | pch=16,cex=0.5,main="",ylab = "UMAP2",xlab = "UMAP1", cex.axis = 0.6,add.N = F,cex.main = 1, 615 | color.spec = "hsv"){ 616 | main<-capitalize(main) 617 | if(add.N&length(unique(labels))<30){ 618 | labels<-add.n.of.samples(labels) 619 | } 620 | if(set.flag){ 621 | par(mar=c(8, 7, 4.1, 12.1), xpd=TRUE) 622 | } 623 | if(is.null(my.col)){ 624 | my.col<-labels.2.colors(labels,color.spec = color.spec) 625 | } 626 | if(is.null(y)){ 627 | if(missing(xlab)){xlab<-colnames(x)[1]} 628 | if(missing(ylab)){ylab<-colnames(x)[2]} 629 | y<-x[,2];x<-x[,1] 630 | } 631 | 632 | if(cor.flag){ 633 | xy.cor<-spearman.cor(y,x) 634 | main <- paste(main, "\nR =",format(xy.cor[1],digits = 2),"P =",format(xy.cor[2],scientific = T,digits = 2)) 635 | } 636 | plot(x,y,col=my.col,pch=pch,cex=cex,main=main,ylab=ylab,xlab = xlab,cex.axis = cex.axis,cex.main = cex.main) 637 | 638 | labels<-gsub(" ","_",labels) 639 | l<-(max(x,na.rm = T)-min(x,na.rm = T))/20 640 | if(length(unique(labels))<30&legend.flag){ 641 | if(length(pch)==length(labels)){ 642 | map<-unique(paste(labels,my.col,pch)) 643 | labels.n<-as.matrix(table(labels)) 644 | idx<-match(get.strsplit(map,' ',1),names(labels.n)) 645 | map[,1]<-paste0(map[,1]," (N = ",m[idx],")") 646 | print(as.integer(get.strsplit(map,' ',3))) 647 | legend(x = max(x,na.rm = T)+l, 648 | y = max(y,na.rm = T), 649 | legend = get.strsplit(map,' ',1), 650 | col = get.strsplit(map,' ',2), 651 | inset=c(-0.5,0), 652 | bty = "n",lty= NA, lwd = 0,cex = 0.7,pch = pch) 653 | }else{ 654 | map<-unique(paste(labels,my.col,pch)) 655 | legend(x = max(x,na.rm = T)+l, 656 | y = max(y,na.rm = T),inset = c(-0.5,0), 657 | legend = gsub("_"," ",get.strsplit(map,' ',1)), 658 | col = get.strsplit(map,' ',2),xpd = T, 659 | bty = "n",lty= NA, lwd = 0,cex = 0.7,pch = pch) 660 | } 661 | 662 | } 663 | if(regression.flag ==1){ 664 | b<-!is.na(x)&!is.na(y) 665 | v<-lowess(x[b],y[b]) 666 | lines(v) 667 | return(v) 668 | } 669 | if(regression.flag ==2){ 670 | b<-!is.na(x)&!is.na(y) 671 | ulabels<-unique(labels) 672 | for(i in ulabels){ 673 | bi<-b&labels==i 674 | v<-lowess(x[bi],y[bi]) 675 | lines(v) 676 | } 677 | 678 | } 679 | 680 | 681 | } 682 | 683 | 684 | #' add.n.of.samples 685 | #' @export 686 | add.n.of.samples<-function(l,n.flag = T,sep = " "){ 687 | num.samples<-table(l) 688 | idx<-match(l,names(num.samples)) 689 | if(n.flag){ 690 | l<-paste0(l,sep,"(n = ",num.samples[idx],")") 691 | }else{ 692 | l<-paste0(l,sep,"(",num.samples[idx],")") 693 | } 694 | return(l) 695 | } 696 | 697 | 698 | #' call.plot.multilabels 699 | #' @export 700 | call.plot.multilabels<-function(X,labels,main = NULL,xlab = "UMAP1",ylab="UMAP2",add.N = F, 701 | pch = 16, cex = 0.3, cex.axis = 0.6,set.flag = F){ 702 | laply(1:ncol(labels),function(i){ 703 | call.plot(X,labels = labels[,i], 704 | main = ifelse(is.null(main),colnames(labels)[i], 705 | paste(main,colnames(labels)[i],sep = ":")), 706 | xlab = xlab,ylab = ylab,pch = pch,cex.axis = cex.axis,cex = cex, 707 | set.flag = set.flag,add.N = add.N) 708 | return(i)}) 709 | } 710 | 711 | #' labels.2.colors 712 | #' @export 713 | labels.2.colors<-function(x.class,x,color.spec = "hsv"){ 714 | palette("default") 715 | call_col<-plotrix::color.scale(x.class,c(0,10),0.8,0.8,color.spec = color.spec) 716 | if(!missing(x)){names(call_col)<-x} 717 | return(call_col) 718 | } 719 | 720 | #' setdiff.lists.by.idx 721 | #' @export 722 | setdiff.lists.by.idx<-function(l1,l2){ 723 | L<-lapply(1:length(l1), function(x) setdiff(l1[[x]],l2[[x]])) 724 | names(L)<-names(l1) 725 | return(L) 726 | } 727 | 728 | 729 | 730 | -------------------------------------------------------------------------------- /R/DIALOGUE_SeuratExample.R: -------------------------------------------------------------------------------- 1 | #' DIALOGUE_SeuratExample 2 | #' 3 | #' Using Seurat objects as input for DIALOGUE 4 | #' @param results.dir path to the directory for saving the output. 5 | #' 6 | #' @examples 7 | #' # Run DIALOGUE with simulated PBMC data 8 | #' R<-DIALOGUE_SeuratExample(results.dir = "DIALOGUE.output") 9 | #' 10 | #' @export 11 | 12 | DIALOGUE_SeuratExample<-function(results.dir){ 13 | set.seed(123) 14 | # Simulating data based on Seurat object of PBMCs 15 | obj<-DIALOGUE_example.initialize(installation.flag = F) 16 | obj@meta.data$samples <- sample(c(paste0("sample",1:16)), size = ncol(pbmc3k), replace =TRUE) 17 | obj@meta.data$cell.subtypes<-obj@meta.data$seurat_annotations 18 | 19 | b1<-is.element(obj@meta.data$cell.subtypes,c("Naive CD4 T","CD14+ Mono")) 20 | b2<-is.element(obj@meta.data$cell.subtypes,c("Memory CD4 T","FCGR3A+ Mono")) 21 | b3<-is.element(obj@meta.data$cell.subtypes,c("CD8 T","DC")) 22 | b4<-is.element(obj@meta.data$cell.subtypes,c("NK","B")) 23 | obj@meta.data$samples[b1] <- sample(c(paste0("sample",1:5)), size = sum(b1), replace =TRUE) 24 | obj@meta.data$samples[b2] <- sample(c(paste0("sample",6:10)), size = sum(b2), replace =TRUE) 25 | obj@meta.data$samples[b3] <- sample(c(paste0("sample",11:12)), size = sum(b3), replace =TRUE) 26 | obj@meta.data$samples[b4] <- sample(c(paste0("sample",13:16)), size = sum(b4), replace =TRUE) 27 | 28 | r1<- DIALOGUE_make.cell.type.seurat(obj, cell.subtypes = c("Naive CD4 T","Memory CD4 T","CD8 T","NK"), name = "A") 29 | r2<- DIALOGUE_make.cell.type.seurat(obj, cell.subtypes = c("CD14+ Mono","FCGR3A+ Mono","DC","B"), name = "B") 30 | 31 | rA<- list(A = r1,B = r2) 32 | 33 | R <- DIALOGUE.run(rA = rA, # list of cell.type objects 34 | main = "ToyExample", 35 | param = DLG.get.param(k = 2, # number of MCPs to identify 36 | results.dir = results.dir, 37 | spatial.flag = F,plot.flag = T, 38 | conf = "cellQ")) 39 | 40 | par(mfrow=c(1,2),oma = c(8, 1, 0, 5),xpd = T) 41 | # MCP1 marks CD8 T cells and DCs 42 | boxplot(-R$scores$A$MCP1~R$scores$A$cell.subtypes,xlab = "",ylab = "MCP1",las=2) 43 | boxplot(-R$scores$B$MCP1~R$scores$B$cell.subtypes,xlab = "",ylab = "MCP1",las=2) 44 | return(R) 45 | 46 | } 47 | 48 | DIALOGUE_example.initialize<-function(installation.flag){ 49 | if(installation.flag){ 50 | devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE") 51 | devtools::install_github('satijalab/seurat-data') 52 | } 53 | library(DIALOGUE) 54 | library(SeuratData) 55 | library(Seurat) 56 | InstallData("pbmc3k") 57 | data("pbmc3k") 58 | return(pbmc3k) 59 | } 60 | 61 | #' DIALOGUE_make.cell.type.seurat 62 | #' 63 | #' Using Seurat objects as input for DIALOGUE make.cell.type function 64 | #' @param obj Seurat object 65 | #' @param cell.subtypes the cell type or subtype to be use. Make sure the obj metadata includes a column of "cell.subtypes" 66 | #' @param name the name to be used in the DIALOGUE run to refer to this cell type. 67 | #' 68 | #' @examples 69 | #' # Run DIALOGUE with simulated PBMC data 70 | #' r1<-DIALOGUE_make.cell.type.seurat(obj, cell.subtypes = "CD8.T.cell", name = "CD8.T.cell") 71 | #' r1<- DIALOGUE_make.cell.type.seurat(obj, cell.subtypes = c("Naive CD4 T","Memory CD4 T","CD8 T"), name = "T.cell") 72 | #' r2<- DIALOGUE_make.cell.type.seurat(obj, cell.subtypes = c("CD14+ Mono","FCGR3A+ Mono","DC"), name = "Myeloid") 73 | #' rA<- list(A = r1,B = r2) 74 | #' R <- DIALOGUE.run(rA = rA, main = "ToyExample",k = 2, results.dir = "DIALOGUE.output",spatial.flag = F,plot.flag = T,conf = "cellQ") 75 | #' 76 | #' @export 77 | 78 | DIALOGUE_make.cell.type.seurat<- function(obj, cell.subtypes, name){ 79 | # Given a Seurat object with "cell.subtypes" and "samples" information provided in the meta.data field 80 | 81 | if(is.null(obj@meta.data$cell.subtypes)){return("Cell subtypes information is missing")} 82 | if(is.null(obj@meta.data$samples)){return("Sample information is missing")} 83 | 84 | sub_obj<- subset(x = obj,cells = rownames(obj@meta.data)[is.element(obj@meta.data$cell.subtypes,cell.subtypes)]) 85 | sub_obj<- NormalizeData(sub_obj,normalization.method = "LogNormalize", scale.factor = 100000) 86 | sub_obj<-FindVariableFeatures(sub_obj,selection.method = "vst", nfeatures = 2000) 87 | sub_obj<-ScaleData(sub_obj) 88 | sub_obj<-RunPCA(sub_obj,npcs = 30) 89 | 90 | tpm<- as.matrix(sub_obj@assays$RNA@data) 91 | 92 | X<- sub_obj@reductions$pca@cell.embeddings 93 | assertthat::are_equal(rownames(X),colnames(tpm)) 94 | n_cells<- ncol(tpm) 95 | samples<- sub_obj@meta.data$samples 96 | n_count<- as.vector(scale(log(sub_obj@meta.data$nCount_RNA))) 97 | metadata<- data.frame(nFeatures = sub_obj@meta.data$nFeature_RNA, 98 | samples = samples, 99 | cell.subtypes = as.character(sub_obj@meta.data$cell.subtypes)) 100 | r<-make.cell.type(name = name ,tpm,samples,X,metadata, cellQ = n_count) 101 | return(r) 102 | } 103 | 104 | 105 | 106 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # **Welcome to the DIALOGUE!** 2 | 3 | DIALOGUE is a dimensionality reduction method that uses cross-cell-type associations to identify multicellular programs (MCPs) and map the cell transcriptome as a function of its environment. Given single-cell data, it combines penalized matrix decomposition with multilevel modeling to identify generalizable MCPs and examines their association with specific phenotypes of interest. 4 | 5 | 6 | 7 | # **Quick start** 8 | 9 | To install DIALOGUE you can either use [```devtools::install_github(repo = "https://github.com/livnatje/DIALOGUE")```](https://www.rdocumentation.org/packages/devtools/versions/1.13.6/topics/install_github) or just download its R package and use ```devtools::install("DIALOGUE")``` 10 | 11 | The **input** consistes of single-cell transcriptomes of different cell types, usually together with a more compact representation (e.g., PCs). The **output** will be multicellular programs (MCPs) of co-regulated genes across the different cell types, their expression across the cells, and association with specific phenotype(s) of interest. Each MCP consists of multiple cell-type-specific gene subsets. 12 | 13 | For specific cell-cell "interactions" you can run the pairwise version, using the data of two cell types of interest as input. DIALOGUE can also identify MCPs that span multiple cell types (see Jerby-Arnon & Regev Nature Biotechnology 2022). 14 | 15 | See the [tutorial](https://github.com/livnatje/DIALOGUE/wiki/Tutorial) for more details. 16 | 17 | ### **Requirements** 18 | 19 | * R (tested in R version 3.4.0). 20 | * R libraries: lme4, lmerTest, PMA, plyr, matrixStats, psych, stringi, RColorBrewer, unikn, reshape2, ggplot2, grid, beanplot, parallel 21 | 22 | # Citation 23 | 24 | [Jerby-Arnon & Regev. DIALOGUE maps multicellular programs in tissue from single-cell or spatial transcriptomics data. _**Nature Biotechnology**_ 2022](https://www.nature.com/articles/s41587-022-01288-0). 25 | 26 | # Seminar 27 | Want to hear more about DIALOGUE and other approaches to study multicellular biology? Checkout our [seminar at 28 | BCH Digital Science TV](https://www.youtube.com/watch?v=iBtzD0rKSdM&list=PLZH5lNty_E1pHu2cQY83tDYDCyhJFOd7a&index=2&t=2964s) 29 | -------------------------------------------------------------------------------- /Scripts/DLG_repro_SMI.R: -------------------------------------------------------------------------------- 1 | # Reproduce the results and plots for SMI lung cancer data. 2 | 3 | DLG.get.file<-function(file1){ 4 | workdir<-"change.to.your.work.directory" 5 | return(paste0(workdir,file1)) 6 | } 7 | 8 | DLG.set.wd<-function(){ 9 | dir.create(DLG.get.file("Results/")) 10 | dir.create(DLG.get.file("Tables/")) 11 | dir.create(DLG.get.file("Data/")) 12 | dir.create(DLG.get.file("Figures/")) 13 | return() 14 | } 15 | 16 | DLG_LungCancer.SMI_run<-function(){ 17 | rA<-readRDS(file = DLG.get.file("Data/DLG.input_LungCancer.SMI.rds")) 18 | param<-DLG.get.param(k = 3,seed1 = 1234, 19 | frm = "y ~ (1 | fov:slides) + (1 | slides) + x + cellQ + tme.qc", 20 | averaging.function = colMeans, 21 | center.flag = T,extra.sparse = F, 22 | conf = c("cellQ"),covar = c("cellQ","tme.qc"), 23 | results.dir = DLG.get.file("/Results/"), 24 | plot.flag = F,n.genes = 50, 25 | PMD2 = F,spatial.flag = T) 26 | R<-DIALOGUE.run(rA = rA,main = "LungCancer.SMI",param = param) 27 | DLG_LungCancer.SMI_TableS1C(R) 28 | DLG_LungCancer.SMI_Figure3(rA = rA) 29 | return(R) 30 | } 31 | 32 | DLG_LungCancer.SMI_TableS1C<-function(R){ 33 | sig1<-R$MCPs$MCP1 34 | sig2<-R$MCPs$MCP2 35 | sig3<-R$MCPs$MCP3 36 | sig2<-setdiff.lists.by.idx(sig2[c(4:6,1:3)],sig1)[c(4:6,1:3)] 37 | sig3<-setdiff.lists.by.idx(sig3,sig1) 38 | X<-rbind(cbind(melt(sig1),MCP = "MCP1"), 39 | cbind(melt(sig2),MCP = "MCP2"), 40 | cbind(melt(sig3),MCP = "MCP3")) 41 | colnames(X)<-c("Genes","Compartment","MCP") 42 | write.csv(X,file = DLG.get.file("Tables/TableS1C.csv"),row.names = F) 43 | } 44 | 45 | DLG_LungCancer.SMI_Figure3<-function(rA,R){ 46 | if(missing(rA)){ 47 | rA<-readRDS(file = DLG.get.file("Data/DLG.input_LungCancer.SMI.rds")) 48 | } 49 | if(missing(R)){ 50 | R<-readRDS(DLG.get.file("Results/DIALOGUE1_LungCancer.SMI.rds")) 51 | } 52 | 53 | R$scores<-lapply(R$cell.types,function(x) cbind.data.frame(R$cca.scores[[x]],rA[[x]]@metadata)) 54 | names(R$scores)<-R$cell.types 55 | 56 | print("Reproducing Figure 3 from (Jerby and Regev, NBT 2022).") 57 | p1<-DLG_LungCancer.SMI.subplots(R,slide1 = 'Lung13',n.plots = 4,q1 = 0.9,MCPs = 1:2,both.sides = T, 58 | fileName = DLG.get.file("/Figures/Figure3_Lung13.pdf")) 59 | p2<-DLG_LungCancer.SMI.subplots(R,slide1 = 'Lung9_Rep1',n.plots = 4,q1 = 0.9,MCPs = 1:2,both.sides = F, 60 | fileName = DLG.get.file("/Figures/Figure3_Lung9_Rep1.pdf")) 61 | return(list(p1,p2)) 62 | } 63 | 64 | DLG_LungCancer.SMI.subplots<-function(R,slide1 = "Lung5_Rep3",cex = 0.3,n.plots = 1,both.sides = F, 65 | fileName,q1 = 0.8,MCPs = seq(R$k[1],1,-1),r1){ 66 | if(!missing(fileName)){pdf(fileName)} 67 | if(n.plots == 4){par(mfrow=c(2,2),oma = c(0, 0, 0, 0),xpd = F)} 68 | 69 | b<-lapply(R$scores,function(X) return(X$slides==slide1)) 70 | scores<-lapply(names(R$scores), function(x) {return(R$scores[[x]][b[[x]],])}) 71 | names(scores)<-names(R$scores) 72 | scoresB.up<-lapply(scores, function(X) apply(X[,1:R$k[1]],2,function(x){return(x>quantile(x,q1))})) 73 | scoresB.down<-lapply(scores, function(X) apply(X[,1:R$k[1]],2,function(x){return(x