├── .Rbuildignore
├── .Rhistory
├── .gitignore
├── DESCRIPTION
├── Mixscale.Rproj
├── NAMESPACE
├── R
├── .Rhistory
├── decomposition.R
├── enrichment_test.R
├── get_fold_change.R
├── glm_gp_disp_only.R
├── perturbation_scoring.R
├── scoring_de.R
└── visualization.R
├── README.md
├── docs
├── index.html
└── old
│ ├── New_Vignette_2024Jan.Rmd
│ ├── index copy 2.Rmd
│ ├── index copy 2.html
│ ├── index copy 3.html
│ ├── index copy.Rmd
│ ├── index copy.html
│ ├── index.Rmd
│ └── index.html
└── man
├── DE_heatmap.Rd
├── DEenrich.Rd
├── DEenrich_DotPlot.Rd
├── DEhclust.Rd
├── DEmultiCCA.Rd
├── FoldChange_new.Rd
├── Mixscale_DoHeatmap.Rd
├── Mixscale_RidgePlot.Rd
├── Mixscale_ScatterPlot.Rd
├── PCApermtest.Rd
├── RunMixscale.Rd
├── Run_wmvRegDE.Rd
├── fisher_enrich_test.Rd
├── get_DE_mat.Rd
├── get_fc.Rd
├── get_sig_genes.Rd
├── get_sig_genes_DEhclust.Rd
├── get_sig_genes_DEmultiCCA.Rd
├── glm_gp_disp_only.Rd
├── glm_gp_disp_only_impl.Rd
├── prune_DE_mat.Rd
├── rbo.Rd
└── rbo_enrich_test.Rd
/.Rbuildignore:
--------------------------------------------------------------------------------
1 | ^.*\.Rproj$
2 | ^\.Rproj\.user$
3 |
--------------------------------------------------------------------------------
/.Rhistory:
--------------------------------------------------------------------------------
1 | library(roxygen2); # Read in the roxygen2 R package
2 | roxygenise();
3 | roxygenise()
4 | roxygenise()
5 | ?ScoringDE
6 | ?PRTBScoring
7 | ?FoldChange_new
8 | ?get_fc
9 | ?get_idx
10 | q()
11 | library(roxygen2)
12 | library(devtools)
13 | roxygenise()
14 | roxygenise()
15 | roxygenise()
16 | roxygenise()
17 | ?PCApermtest
18 | roxygenise()
19 | ?DE_heatmap
20 | roxygenise()
21 | ?DE_heatmap
22 | ?PCApermtest
23 | ?DE_heatmap
24 | roxygenise()
25 | ?PCApermtest
26 | library(roxygen2); # Read in the roxygen2 R package
27 | roxygenise();
28 | library(roxygen2)
29 | roxygenise()
30 | q()
31 | library(roxygen2)
32 | roxygenise()
33 | roxygenise()
34 | library(roxygen2)
35 | roxygenise()
36 | library(roxygen2)
37 | roxygenise()
38 | library(roxygen2)
39 | roxygenise()
40 | install.packages("protoclust")
41 | install.packages("protoclust")
42 | library(PRTBScoring)
43 | library(roxygen2)
44 | roxygenise()
45 | library(roxygen2)
46 | roxygenise()
47 | roxygenise()
48 | library(roxygen2)
49 | roxygenise()
50 | roxygenise()
51 | roxygenise()
52 | library(roxygen2)
53 | roxygenise()
54 | roxygenise()
55 | library(roxygen2)
56 | roxygenise()
57 | library(roxygen2)
58 | roxygenise()
59 | library(roxygen2)
60 | roxygenise()
61 | roxygenise()
62 | library(roxygen2)
63 | roxygenise()
64 | library(roxygen2)
65 | roxygenise()
66 | library(roxygen2)
67 | roxygenise()
68 | roxygenise()
69 | library(roxygen2)
70 | roxygenise()
71 | roxygenise()
72 | library(roxygen2)
73 | roxygenise()
74 | library(roxygen2)
75 | roxygenise()
76 | roxygenise()
77 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | .DS_Store
2 | .Rproj.user
3 |
--------------------------------------------------------------------------------
/DESCRIPTION:
--------------------------------------------------------------------------------
1 | Package: Mixscale
2 | Type: Package
3 | Title: Quantify the perturbation heterogeneity in Perturb-seq
4 | Version: 0.3.0
5 | RoxygenNote: 7.2.3
6 | Collate:
7 | 'decomposition.R'
8 | 'enrichment_test.R'
9 | 'get_fold_change.R'
10 | 'glm_gp_disp_only.R'
11 | 'perturbation_scoring.R'
12 | 'scoring_de.R'
13 | 'visualization.R'
14 |
--------------------------------------------------------------------------------
/Mixscale.Rproj:
--------------------------------------------------------------------------------
1 | Version: 1.0
2 |
3 | RestoreWorkspace: Default
4 | SaveWorkspace: Default
5 | AlwaysSaveHistory: Default
6 |
7 | EnableCodeIndexing: Yes
8 | UseSpacesForTab: Yes
9 | NumSpacesForTab: 4
10 | Encoding: UTF-8
11 |
12 | RnwWeave: Sweave
13 | LaTeX: pdfLaTeX
14 |
15 | BuildType: Package
16 | PackageUseDevtools: Yes
17 | PackageInstallArgs: --no-multiarch --with-keep.source
18 |
--------------------------------------------------------------------------------
/NAMESPACE:
--------------------------------------------------------------------------------
1 | # Generated by roxygen2: do not edit by hand
2 |
3 | export(DE_heatmap)
4 | export(DEenrich)
5 | export(DEenrich_DotPlot)
6 | export(DEhclust)
7 | export(DEmultiCCA)
8 | export(FoldChange_new)
9 | export(Mixscale_DoHeatmap)
10 | export(Mixscale_RidgePlot)
11 | export(Mixscale_ScatterPlot)
12 | export(PCApermtest)
13 | export(RunMixscale)
14 | export(Run_wmvRegDE)
15 | export(fisher_enrich_test)
16 | export(get_DE_mat)
17 | export(get_fc)
18 | export(get_sig_genes)
19 | export(get_sig_genes_DEhclust)
20 | export(get_sig_genes_DEmultiCCA)
21 | export(prune_DE_mat)
22 | export(rbo)
23 | export(rbo_enrich_test)
24 | import(Seurat)
25 | import(SeuratObject)
26 | import(ggplot2)
27 | import(ggridges)
28 | import(glmGamPoi)
29 | importFrom(Matrix,rowMeans)
30 | importFrom(Matrix,rowSums)
31 | importFrom(PMA,MultiCCA)
32 | importFrom(RColorBrewer,brewer.pal)
33 | importFrom(gplots,heatmap.2)
34 | importFrom(protoclust,protoclust)
35 | importFrom(protoclust,protocut)
36 |
--------------------------------------------------------------------------------
/R/.Rhistory:
--------------------------------------------------------------------------------
1 | nt.class.name = "NT",
2 | min.de.genes = 5,
3 | split.by = "cell_type",
4 | logfc.threshold = 0.2,
5 | de.assay = "RNA",
6 | max.de.genes = 100,
7 | prtb.type = "P",
8 | new.class.name = "mixscape_v1",
9 | fine.mode = F,
10 | harmonize = T,
11 | seed = 1)
12 | load_all("/Users/uqljian5/Documents/github_repo/Perturbation_Scoring")
13 | # 3. Perturbation scoring for each cell
14 | seurat_obj = PRTBScoring(
15 | object = seurat_obj,
16 | assay = "PRTB",
17 | slot = "scale.data",
18 | labels = "gene",
19 | nt.class.name = "NT",
20 | min.de.genes = 5,
21 | split.by = "cell_type",
22 | logfc.threshold = 0.2,
23 | de.assay = "RNA",
24 | max.de.genes = 100,
25 | prtb.type = "P",
26 | new.class.name = "mixscape_v1",
27 | fine.mode = F,
28 | harmonize = T,
29 | seed = 1)
30 | # 4. Perform scoring-based DE test using the scores
31 | de_res = scoringDE(object = seurat_obj, assay = "RNA", slot = "counts",
32 | labels = "gene")
33 | load_all("/Users/uqljian5/Documents/github_repo/Perturbation_Scoring")
34 | # 4. Perform scoring-based DE test using the scores
35 | de_res = scoringDE(object = seurat_obj, assay = "RNA", slot = "counts",
36 | PRTB_list = c("RFX5", "ZC3H3", "IFNGR1", "IFNGR2",
37 | "IRF1", "IRF2", "JUN", "MAFF",
38 | "PARP12", "TRAFD1",
39 | "JAK1", "JAK2",
40 | "STAT1", "SP100"),
41 | labels = "gene")
42 | str(de_res)
43 | # and re-arrange the DE results into Z-score matrices
44 | DEG_mat = get_DE_mat(de_res)
45 | DEG_mat = prune_DE_mat(de_res)
46 | DEG_mat = prune_DE_mat(DEG_mat)
47 | str(DEG_mat)
48 | # and re-arrange the DE results into Z-score matrices
49 | DEG_mat = get_DE_mat(de_res)
50 | DEG_mat = prune_DE_mat(DEG_mat, mask_target = T, min_sig_DEG = 3)
51 | str(DEG_mat)
52 | head(DEG_mat$A549)
53 | #########
54 | # 5.1 within-prtb
55 | celltype_list = names(DEG_mat)
56 | PRTB_list = colnames(DEG_mat[[1]])
57 | gene_ID = rownames(DEG_mat[[1]])
58 | #####
59 | for(i in 1:length(PRTB_list)){
60 | PRTB = PRTB_list[i]
61 | tmp=list()
62 | for(CELLTYPE in celltype_list){
63 | tmp[[CELLTYPE]] = DEG_mat[[CELLTYPE]][, PRTB]
64 | }
65 | tmp = Reduce(cbind, tmp)
66 | colnames(tmp) = celltype_list
67 | rownames(tmp) = gene_ID
68 | # run Permutation test and extract gene signatures
69 | res = PCApermtest(mat = tmp, row_filtering_pval = 0.05, k = 1)
70 | sig_genes = get_sig_genes(perm_obj = res, k = 1, collapse = T)
71 | # plot Z-score heatmap for the gene signatures
72 | DE_heatmap(obj = res, sig_genes = sig_genes, type = "standard", direction = "both", top_n = 30,
73 | output_path = "/Users/uqljian5/Desktop/test_multiCCA/level1/",
74 | prefix = PRTB)
75 | }
76 | names(DEG_mat)
77 | #####
78 | for(i in 1:length(PRTB_list)){
79 | PRTB = PRTB_list[i]
80 | tmp=list()
81 | for(CELLTYPE in celltype_list){
82 | if(PRTB %in% colnames(DEG_mat[[CELLTYPE]])){
83 | tmp[[CELLTYPE]] = DEG_mat[[CELLTYPE]][, PRTB]
84 | }
85 | }
86 | tmp = Reduce(cbind, tmp)
87 | colnames(tmp) = celltype_list
88 | rownames(tmp) = gene_ID
89 | # run Permutation test and extract gene signatures
90 | res = PCApermtest(mat = tmp, row_filtering_pval = 0.05, k = 1)
91 | sig_genes = get_sig_genes(perm_obj = res, k = 1, collapse = T)
92 | # plot Z-score heatmap for the gene signatures
93 | DE_heatmap(obj = res, sig_genes = sig_genes, type = "standard", direction = "both", top_n = 30,
94 | output_path = "/Users/uqljian5/Desktop/test_multiCCA/level1/",
95 | prefix = PRTB)
96 | }
97 | colnames(DEG_mat[[CELLTYPE]])
98 | PRTB
99 | PRTB %in% colnames(DEG_mat[[CELLTYPE]])
100 | head(tmp)
101 | # and re-arrange the DE results into Z-score matrices
102 | DEG_mat = get_DE_mat(de_res)
103 | DEG_mat_main = DEG_mat
104 | #########
105 | # 5.1 within-prtb
106 | DEG_mat = prune_DE_mat(DEG_mat_main, mask_target = T, min_sig_DEG = 0)
107 | celltype_list = names(DEG_mat)
108 | PRTB_list = colnames(DEG_mat[[1]])
109 | gene_ID = rownames(DEG_mat[[1]])
110 | #####
111 | for(i in 1:length(PRTB_list)){
112 | PRTB = PRTB_list[i]
113 | tmp=list()
114 | for(CELLTYPE in celltype_list){
115 | if(PRTB %in% colnames(DEG_mat[[CELLTYPE]])){
116 | tmp[[CELLTYPE]] = DEG_mat[[CELLTYPE]][, PRTB]
117 | }
118 | }
119 | tmp = Reduce(cbind, tmp)
120 | colnames(tmp) = celltype_list
121 | rownames(tmp) = gene_ID
122 | # run Permutation test and extract gene signatures
123 | res = PCApermtest(mat = tmp, row_filtering_pval = 0.05, k = 1)
124 | sig_genes = get_sig_genes(perm_obj = res, k = 1, collapse = T)
125 | # plot Z-score heatmap for the gene signatures
126 | DE_heatmap(obj = res, sig_genes = sig_genes, type = "standard", direction = "both", top_n = 30,
127 | output_path = "/Users/uqljian5/Desktop/test_multiCCA/level1/",
128 | prefix = PRTB)
129 | }
130 | #########
131 | # 5.2 within-celltype
132 | DEG_mat = prune_DE_mat(DEG_mat_main, mask_target = T, min_sig_DEG = 3)
133 | celltype_list = names(DEG_mat)
134 | PRTB_list = colnames(DEG_mat[[1]])
135 | gene_ID = rownames(DEG_mat[[1]])
136 | for(i in 1:length(celltype_list)){
137 | CELLTYPE = celltype_list[i]
138 | tmp=DEG_mat[[CELLTYPE]]
139 | # run Permutation test and extract gene signatures
140 | res = DEhclust(mat = tmp)
141 | sig_genes = get_sig_genes_DEhclust(obj = res)
142 | # plot Z-score heatmap for the gene signatures
143 | DE_heatmap(obj = res, sig_genes = sig_genes, type = "hclust", direction = "both", top_n = 30,
144 | output_path = "/Users/uqljian5/Desktop/test_multiCCA/level2/",
145 | prefix = CELLTYPE)
146 | }
147 | #########
148 | # 5.3 MultiCCA analysis
149 | DEG_mat = prune_DE_mat(DEG_mat_main, mask_target = T, min_sig_DEG = 3, center = T)
150 | celltype_list = names(DEG_mat)
151 | PRTB_list = colnames(DEG_mat[[1]])
152 | gene_ID = rownames(DEG_mat[[1]])
153 | # run Permutation test and extract gene signatures
154 | res = DEmultiCCA(DEG_mat, cor_coef_thres = 0.6, max_k = 3)
155 | str(DEG_mat)
156 | # run Permutation test and extract gene signatures
157 | res = DEmultiCCA(mat_list = DEG_mat, cor_coef_thres = 0.8, max_k = 3)
158 | str(res)
159 | str(DEG_mat)
160 | #########
161 | # 5.3 MultiCCA analysis
162 | DEG_mat = prune_DE_mat(DEG_mat_main, mask_target = T, min_sig_DEG = 1, center = T)
163 | celltype_list = names(DEG_mat)
164 | PRTB_list = colnames(DEG_mat[[1]])
165 | gene_ID = rownames(DEG_mat[[1]])
166 | # run Permutation test and extract gene signatures
167 | res = DEmultiCCA(mat_list = DEG_mat, cor_coef_thres = 0.6, max_k = 3)
168 | sig_genes = get_sig_genes_DEmultiCCA(res)
169 | str(sig_genes)
170 | str(res)
171 | # run Permutation test and extract gene signatures
172 | res = DEmultiCCA(mat_list = DEG_mat, cor_coef_thres = 0.8, max_k = 3)
173 | str(res)
174 | sig_genes = get_sig_genes_DEmultiCCA(res)
175 | # visualization.
176 | DE_heatmap(obj = res, sig_genes = sig_genes,
177 | type = "multiCCA", direction = "both",
178 | top_n = 30, labRow = T, output_path = "/Users/uqljian5/Desktop/test_multiCCA/level3/",
179 | prefix = "IFNG")
180 | # run Permutation test and extract gene signatures
181 | res = DEmultiCCA(mat_list = DEG_mat, cor_coef_thres = 0.6, max_k = 3, standardize = T)
182 | sig_genes = get_sig_genes_DEmultiCCA(res)
183 | # visualization.
184 | DE_heatmap(obj = res, sig_genes = sig_genes,
185 | type = "multiCCA", direction = "both",
186 | top_n = 30, labRow = T, output_path = "/Users/uqljian5/Desktop/test_multiCCA/level3/",
187 | prefix = "IFNG")
188 | # visualization.
189 | DE_heatmap(obj = res, sig_genes = sig_genes,
190 | type = "multiCCA", direction = "both",
191 | top_n = 30, labRow = T, output_path = "/Users/uqljian5/Desktop/test_multiCCA/level3/",
192 | prefix = "IFNG")
193 | # run Permutation test and extract gene signatures
194 | res = DEmultiCCA(mat_list = DEG_mat, cor_coef_thres = 0.8, max_k = 3, standardize = T)
195 | sig_genes = get_sig_genes_DEmultiCCA(res)
196 | # visualization.
197 | DE_heatmap(obj = res, sig_genes = sig_genes,
198 | type = "multiCCA", direction = "both",
199 | top_n = 30, labRow = T, output_path = "/Users/uqljian5/Desktop/test_multiCCA/level3/",
200 | prefix = "IFNG")
201 | DEG_mat = prune_DE_mat(DEG_mat_main, mask_target = T, min_sig_DEG = 0)
202 | celltype_list = names(DEG_mat)
203 | PRTB_list = colnames(DEG_mat[[1]])
204 | gene_ID = rownames(DEG_mat[[1]])
205 | PRTB = PRTB_list[i]
206 | tmp=list()
207 | for(CELLTYPE in celltype_list){
208 | if(PRTB %in% colnames(DEG_mat[[CELLTYPE]])){
209 | tmp[[CELLTYPE]] = DEG_mat[[CELLTYPE]][, PRTB]
210 | }
211 | }
212 | tmp = Reduce(cbind, tmp)
213 | colnames(tmp) = celltype_list
214 | rownames(tmp) = gene_ID
215 | # run Permutation test and extract gene signatures
216 | res = PCApermtest(mat = tmp, row_filtering_pval = 0.05, k = 1)
217 | sig_genes = get_sig_genes(perm_obj = res, k = 1, collapse = T)
218 | str(sig_genes)
219 | PRTB
220 | #########
221 | # 5.2 within-celltype
222 | DEG_mat = prune_DE_mat(DEG_mat_main, mask_target = T, min_sig_DEG = 3)
223 | celltype_list = names(DEG_mat)
224 | PRTB_list = colnames(DEG_mat[[1]])
225 | gene_ID = rownames(DEG_mat[[1]])
226 | CELLTYPE = celltype_list[i]
227 | tmp=DEG_mat[[CELLTYPE]]
228 | # run Permutation test and extract gene signatures
229 | res = DEhclust(mat = tmp)
230 | sig_genes = get_sig_genes_DEhclust(obj = res)
231 | str(sig_genes)
232 | names(sig_genes)
233 | #########
234 | # 5.3 MultiCCA analysis
235 | DEG_mat = prune_DE_mat(DEG_mat_main, mask_target = T, min_sig_DEG = 1, center = T)
236 | celltype_list = names(DEG_mat)
237 | PRTB_list = colnames(DEG_mat[[1]])
238 | gene_ID = rownames(DEG_mat[[1]])
239 | # run Permutation test and extract gene signatures
240 | res = DEmultiCCA(mat_list = DEG_mat, cor_coef_thres = 0.8, max_k = 3, standardize = T)
241 | sig_genes = get_sig_genes_DEmultiCCA(res)
242 | str(sig_genes)
243 | names(sig_genes)
244 | ##################################
245 | # Decomposition
246 | go_db = list()
247 | #########
248 | # 5.1 within-prtb
249 | DEG_mat = prune_DE_mat(DEG_mat_main, mask_target = T, min_sig_DEG = 0)
250 | celltype_list = names(DEG_mat)
251 | PRTB_list = colnames(DEG_mat[[1]])
252 | gene_ID = rownames(DEG_mat[[1]])
253 | #####
254 | for(i in 1:length(PRTB_list)){
255 | PRTB = PRTB_list[i]
256 | tmp=list()
257 | for(CELLTYPE in celltype_list){
258 | if(PRTB %in% colnames(DEG_mat[[CELLTYPE]])){
259 | tmp[[CELLTYPE]] = DEG_mat[[CELLTYPE]][, PRTB]
260 | }
261 | }
262 | tmp = Reduce(cbind, tmp)
263 | colnames(tmp) = celltype_list
264 | rownames(tmp) = gene_ID
265 | # run Permutation test and extract gene signatures
266 | res = PCApermtest(mat = tmp, row_filtering_pval = 0.05, k = 1)
267 | sig_genes = get_sig_genes(perm_obj = res, k = 1, collapse = T)
268 | # plot Z-score heatmap for the gene signatures
269 | DE_heatmap(obj = res, sig_genes = sig_genes, type = "standard", direction = "both", top_n = 30,
270 | output_path = "/Users/uqljian5/Desktop/test_multiCCA/level1/",
271 | prefix = PRTB)
272 | # store the gene signatures to the go-term repo
273 | if(length(sig_genes$upDEGs) >= 10){
274 | go_db[[paste0(PRTB, "_upDEGs")]] = sig_genes$upDEGs
275 | }
276 | if(length(sig_genes$downDEGs) >= 10){
277 | go_db[[paste0(PRTB, "_downDEGs")]] = sig_genes$downDEGs
278 | }
279 | }
280 | #########
281 | # 5.2 within-celltype
282 | DEG_mat = prune_DE_mat(DEG_mat_main, mask_target = T, min_sig_DEG = 3)
283 | celltype_list = names(DEG_mat)
284 | PRTB_list = colnames(DEG_mat[[1]])
285 | gene_ID = rownames(DEG_mat[[1]])
286 | for(i in 1:length(celltype_list)){
287 | CELLTYPE = celltype_list[i]
288 | tmp=DEG_mat[[CELLTYPE]]
289 | # run Permutation test and extract gene signatures
290 | res = DEhclust(mat = tmp)
291 | sig_genes = get_sig_genes_DEhclust(obj = res)
292 | # plot Z-score heatmap for the gene signatures
293 | DE_heatmap(obj = res, sig_genes = sig_genes, type = "hclust", direction = "both", top_n = 30,
294 | output_path = "/Users/uqljian5/Desktop/test_multiCCA/level2/",
295 | prefix = CELLTYPE)
296 | # store the gene signatures to the go-term repo
297 | for(CLUSTER in names(sig_genes)){
298 | if(length(sig_genes[[CLUSTER]]$sig_genes$upDEGs) >= 10){
299 | go_db[[paste0(CELLTYPE, "_", CLUSTER, "_upDEGs")]] = sig_genes[[CLUSTER]]$sig_genes$upDEGs
300 | }
301 | if(length(sig_genes[[CLUSTER]]$sig_genes$downDEGs) >= 10){
302 | go_db[[paste0(CELLTYPE, "_", CLUSTER,"_downDEGs")]] = sig_genes[[CLUSTER]]$sig_genes$downDEGs
303 | }
304 | }
305 | }
306 | #########
307 | # 5.3 MultiCCA analysis
308 | DEG_mat = prune_DE_mat(DEG_mat_main, mask_target = T, min_sig_DEG = 1, center = T)
309 | celltype_list = names(DEG_mat)
310 | PRTB_list = colnames(DEG_mat[[1]])
311 | gene_ID = rownames(DEG_mat[[1]])
312 | # run Permutation test and extract gene signatures
313 | res = DEmultiCCA(mat_list = DEG_mat, cor_coef_thres = 0.8, max_k = 3, standardize = T)
314 | sig_genes = get_sig_genes_DEmultiCCA(res)
315 | # visualization.
316 | DE_heatmap(obj = res, sig_genes = sig_genes,
317 | type = "multiCCA", direction = "both",
318 | top_n = 30, labRow = T, output_path = "/Users/uqljian5/Desktop/test_multiCCA/level3/",
319 | prefix = "IFNG")
320 | # store the gene signatures to the go-term repo
321 | for(PROGRAM in names(sig_genes)){
322 | if(length(sig_genes[[PROGRAM]]$sig_genes$upDEGs) >= 10){
323 | go_db[[paste0("IFNG_", PROGRAM, "_upDEGs")]] = sig_genes[[PROGRAM]]$sig_genes$upDEGs
324 | }
325 | if(length(sig_genes[[PROGRAM]]$sig_genes$downDEGs) >= 10){
326 | go_db[[paste0("IFNG_", PROGRAM, "_downDEGs")]] = sig_genes[[PROGRAM]]$sig_genes$downDEGs
327 | }
328 | }
329 | str(go_db)
330 | head(seurat_obj)
331 | ##########
332 | # 6.1 DE tests
333 | seurat_obj$Condition = paste0(seurat_obj$cell_type, "_", seurat_obj$gene)
334 | Idents(seurat_obj) = "Condition"
335 | table(seurat_obj$Condition)
336 | new_DE_test = FindMarkers(seurat_obj, ident.1 = "A549_NT", ident.2 = "A549_IFNGR2")
337 | seurat_obj
338 | new_DE_test = FindMarkers(seurat_obj, ident.1 = "A549_NT", ident.2 = "A549_IFNGR2",
339 | slot = "data", logfc.threshold = 0)
340 | head(new_DE_test)
341 | # get the background gene list
342 | background = rownames(new_DE_test)
343 | # get the significant down-reg genes (the input list )
344 | input_list = rownames(new_DE_test[new_DE_test$p_val_adj <= 0.05 & new_DE_test$avg_log2FC > 0, ])
345 | # get the significant down-reg genes (the input list )
346 | input_list = rownames(new_DE_test[new_DE_test$p_val_adj <= 0.05 & new_DE_test$avg_log2FC > 0.2, ])
347 | # get the significant down-reg genes (the input list )
348 | input_list = rownames(new_DE_test[new_DE_test$p_val_adj <= 0.05 & new_DE_test$avg_log2FC > 0.2, ])
349 | # 6.2 Conventional test (Fisher's exact test)
350 | fisher_enrich_res = fisher_enrich_test(input_list = input_list,
351 | background = background,
352 | go_term_db = go_db)
353 | head(fisher_enrich_res)
354 | fisher_enrich_res = fisher_enrich_res[order(fisher_enrich_res$Pval), ]
355 | head(fisher_enrich_res)
356 | head(fisher_enrich_res, 20)
357 | # 6.3 Rank biased overlap based test
358 | # RBO test does NOT require pre-select DEGs based on P-value or log-fold-change
359 | input_list2 = rownames(new_DE_test[new_DE_test$avg_log2FC > 0, ])
360 | head(new_DE_test[new_DE_test$avg_log2FC > 0, ], 30)
361 | # 6.3 Rank biased overlap based test
362 | # RBO test does NOT require pre-select DEGs based on P-value or log-fold-change
363 | input_list2 = rownames(new_DE_test[new_DE_test$avg_log2FC > 0, ])
364 | rbo_enrich_res = rbo_enrich_test(input_list = input_list2,
365 | go_term_db = go_db,
366 | p = 0.99)
367 | head(input_list2)
368 | length(input_list2)
369 | rbo_enrich_res = rbo_enrich_test(input_list = input_list2,
370 | go_term_db = go_db,
371 | p = 0.99,
372 | side = "bottom")
373 | rbo_enrich_res = rbo_enrich_test(input_list = input_list2,
374 | go_term_db = go_db,
375 | p = 0.99,
376 | k = 300,
377 | side = "bottom")
378 | load_all("/Users/uqljian5/Documents/github_repo/Perturbation_Scoring")
379 | rbo_enrich_res = rbo_enrich_test(input_list = input_list2,
380 | go_term_db = go_db,
381 | p = 0.99,
382 | k = 300,
383 | side = "bottom")
384 | head(input_list2)
385 | str(go_db)
386 | go_term_db = go_db
387 | class(go_term_db[[1]]) == "list"
388 | rbo_enrich_res = rbo_enrich_test(input_list = input_list2,
389 | go_term_db = go_db,
390 | p = 0.99,
391 | k = 300,
392 | side = "bottom")
393 | rbo
394 | input_list,
395 | input_list
396 | go_term_db
397 | p
398 | input_list
399 | go_term_db
400 | p = 0.99
401 | n_iter = 500
402 | k=300
403 | side= "bottom"
404 | mid = NULL
405 | uneven.lengths = TRUE
406 | empirical_test = FALSE
407 | seed = 131415926
408 | if(length(input_list) < 5){
409 | print("The length of the input list is less than 5, stopping analysis...")
410 | return(NULL)
411 | }
412 | # 0. each vector in the go_term_db is assumed to be an ordered vector of characters (gene names).
413 | # we need to convert each vector in to a named vector of number (number being the rank of each gene).
414 | go_term_db2 = lapply(X = go_term_db,
415 | FUN = function(x) {
416 | if(side == "bottom") tmp = 1:length(x)
417 | else if (side == "top") tmp = length(x):1
418 | names(tmp) = x
419 | return(tmp)
420 | })
421 | str(go_term_db2 )
422 | # 1. calculate the true RBO for the input_list and all the GO terms
423 | rbo_real = sapply(X = go_term_db2,
424 | FUN = rbo,
425 | list2 = input_list,
426 | p = p,
427 | k = k,
428 | side = side,
429 | mid = mid,
430 | uneven.lengths = uneven.lengths)
431 | head(input_list)
432 | load_all("/Users/uqljian5/Documents/github_repo/Perturbation_Scoring")
433 | rbo_enrich_res = rbo_enrich_test(input_list = input_list2,
434 | go_term_db = go_db,
435 | p = 0.99,
436 | k = 100,
437 | side = "bottom")
438 | head(rbo_enrich_res)
439 | rbo_enrich_res = rbo_enrich_res[order(rbo_enrich_res$RBO, decreasing = T), ]
440 | head(rbo_enrich_res, 20)
441 | rbo_enrich_res = rbo_enrich_test(input_list = input_list2,
442 | go_term_db = go_db,
443 | p = 0.98,
444 | k = 100,
445 | side = "bottom")
446 | rbo_enrich_res = rbo_enrich_res[order(rbo_enrich_res$RBO, decreasing = T), ]
447 | head(rbo_enrich_res)
448 | options(Seurat.object.assay.version = 'v3')
449 | library(Seurat)
450 | library(ggridges)
451 | library(stringr)
452 | library(Mixscale)
453 | library(ggplot2)
454 | seurat_obj = readRDS("/Users/uqljian5/Desktop/Lab_stuffs_NYGC/Paper_information_gathering/results/GSE132080/seurat_obj_GSE132080_QCed_2023Aug10.rds")
455 | seurat_obj
456 | gv.list = Tool(seurat_obj, slot = "RunMixscape")
457 | gv.list = Tool(seurat_obj, slot = "PRTBScoring")
458 | str(gv.list)
459 | load_all("/Users/uqljian5/Documents/github_repo/Mixscale")
460 | devtools::load_all("/Users/uqljian5/Documents/github_repo/Mixscale/")
461 | seurat_obj
462 | obj2 = RunMixscale(
463 | object = seurat_obj,
464 | assay = "PRTB",
465 | slot = "scale.data",
466 | labels = "gene",
467 | nt.class.name = "neg",
468 | min.de.genes = 5,
469 | logfc.threshold = 0.2,
470 | de.assay = "RNA",
471 | max.de.genes = 100,
472 | fine.mode = F)
473 | devtools::load_all("/Users/uqljian5/Documents/github_repo/Mixscale/")
474 | obj2 = RunMixscale(
475 | object = seurat_obj,
476 | assay = "PRTB",
477 | slot = "scale.data",
478 | labels = "gene",
479 | nt.class.name = "neg",
480 | min.de.genes = 5,
481 | logfc.threshold = 0.2,
482 | de.assay = "RNA",
483 | max.de.genes = 100,
484 | fine.mode = F)
485 | devtools::load_all("/Users/uqljian5/Documents/github_repo/Mixscale/")
486 | obj2 = RunMixscale(
487 | object = seurat_obj,
488 | assay = "PRTB",
489 | slot = "scale.data",
490 | labels = "gene",
491 | nt.class.name = "neg",
492 | min.de.genes = 5,
493 | logfc.threshold = 0.2,
494 | de.assay = "RNA",
495 | max.de.genes = 100,
496 | fine.mode = F)
497 | devtools::load_all("/Users/uqljian5/Documents/github_repo/Mixscale/")
498 | obj2 = RunMixscale(
499 | object = seurat_obj,
500 | assay = "PRTB",
501 | slot = "scale.data",
502 | labels = "gene",
503 | nt.class.name = "neg",
504 | min.de.genes = 5,
505 | logfc.threshold = 0.2,
506 | de.assay = "RNA",
507 | max.de.genes = 100,
508 | fine.mode = F)
509 | head(obj2)
510 | plot(obj2$pvec, obj2$weight)
511 | rm(list=ls())
512 | gc()
513 |
--------------------------------------------------------------------------------
/R/enrichment_test.R:
--------------------------------------------------------------------------------
1 | #'
2 | NULL
3 |
4 | #' Wrapper function for DE and enrichment test
5 | #'
6 | #' This function provides a wrapper of Seurat::FindMarkers() and Mixscale::fisher_enrich_test().
7 | #' Users can input a Seurat object they want to investigate and a list of gene sets they want to
8 | #' test against, and the wrapper will perform DE tests + Fisher's enrichment test across all the
9 | #' available cell types. It will then return a list of data frames, containing gene set enrichment
10 | #' results for each cell type.
11 | #'
12 | #' @export
13 | #' @param object a seurat object to perform the DE test and the enrichment test
14 | #' @param plist the pathway gene lists to test the DE genes against
15 | #' @param split.by Regroup cells into a different identity class prior to performing differential expression.
16 | #' Default is NULL (so all cells be used simultaneously).
17 | #' @param slct.ct Subset a particular identity class prior to regrouping. Only relevant if group.by is set.
18 | #' @param ident.1 Identity class to define markers for; pass an object of class phylo or 'clustertree' to find markers for a node in a cluster tree; passing 'clustertree' requires BuildClusterTree to have been run
19 | #' @param ident.2 A second identity class for comparison; if NULL, use all other cells for comparison; if an object of class phylo or 'clustertree' is passed to ident.1, must pass a node to find markers for
20 | #' @return a list of data frames containing the gene set enrichment results for each group in "group.by"
21 | #'
22 |
23 | DEenrich <- function(object,
24 | plist = NULL,
25 | ident = NULL,
26 | ident.1 = NULL,
27 | ident.2 = NULL,
28 | split.by = NULL,
29 | slct.ct = NULL,
30 | direction = c("up", "down", "both"),
31 | logfc.threshold = 0.25,
32 | p.val.cutoff = 0.05,
33 | min.pct = 0.1,
34 | assay = NULL,
35 | ...){
36 |
37 | slct_celltype = sort(unique(object[[split.by]][, 1]))
38 | if(!is.null(split.by) & is.null(slct_celltype)){
39 | stop("Please check if your split.by is correctly specified.")
40 | }
41 |
42 | if(!is.null(slct.ct)){
43 | slct_celltype = intersect(slct_celltype, slct.ct)
44 | }
45 | if(length(slct_celltype) == 0){
46 | slct_celltype = "con1"
47 | }
48 |
49 | enrich_list = list()
50 | for(CELLTYPE in slct_celltype){
51 | if(!is.null(ident)){
52 | Idents(object) = ident
53 | }
54 | #
55 | if(is.null(split.by)){
56 | object[["new_ident"]] = paste0("con1", "_", Idents(object))
57 | } else {
58 | object[["new_ident"]] = paste0(object[[split.by]][,1], "_", Idents(object))
59 | }
60 | ident.1.tmp = paste0(CELLTYPE, "_", ident.1)
61 | ident.2.tmp = paste0(CELLTYPE, "_", ident.2)
62 |
63 | # run DE
64 | Idents(object) = "new_ident"
65 | DE_res = FindMarkers(object,
66 | ident.1 = ident.1.tmp,
67 | ident.2 = ident.2.tmp,
68 | min.pct = min.pct,
69 | logfc.threshold = 0,
70 | ...)
71 |
72 | # get the top DEGs separately for up and down regulated genes
73 | upDEG = rownames(DE_res[DE_res$p_val_adj <= p.val.cutoff & DE_res$avg_log2FC > logfc.threshold, ])
74 | downDEG = rownames(DE_res[DE_res$p_val_adj <= p.val.cutoff & DE_res$avg_log2FC < -logfc.threshold, ])
75 | background = rownames(DE_res) # the background gene list
76 |
77 | # run enrichment test for the DEGs
78 | if(length(downDEG) < 5 | direction == "up"){
79 | enrich_res_down = NULL
80 | } else {
81 | enrich_res_down = fisher_enrich_test(input_list = downDEG,
82 | background = background,
83 | go_term_db = plist)
84 | enrich_res_down$num_DEG = length(downDEG)
85 | enrich_res_down$direction_DEG = "downDEG"
86 | enrich_res_down = enrich_res_down[order(enrich_res_down$Pval), ]
87 | enrich_res_down$slct.ct = CELLTYPE
88 | }
89 |
90 | #
91 | if(length(upDEG) < 5 | direction == "down"){
92 | enrich_res_up = NULL
93 | } else {
94 | enrich_res_up = fisher_enrich_test(input_list = upDEG,
95 | background = background,
96 | go_term_db = plist)
97 | enrich_res_up$num_DEG = length(upDEG)
98 | enrich_res_up$direction_DEG = "upDEG"
99 | enrich_res_up = enrich_res_up[order(enrich_res_up$Pval), ]
100 | enrich_res_up$slct.ct = CELLTYPE
101 | }
102 |
103 | # save the results to the list
104 | enrich_list[[CELLTYPE]] = rbind(enrich_res_up, enrich_res_down)
105 | }
106 |
107 | if(length(enrich_list) == 1){
108 | return(enrich_list[[1]])
109 | } else {
110 | return(enrich_list)
111 | }
112 | }
113 |
114 |
115 |
116 | #' Rank biased overlap
117 | #'
118 | #' A function for a new gene-set enrichment test based on the
119 | #' RBO (rank biased overlap) calculation with extropolation (Webber et al., 2010).
120 | #' The core functions of rbo() calculation was modified from the "gespeR" package (original author: Fabian Schmich).
121 | #' We modified it to accomodate our package and data type. We also developed a permutation scheme for
122 | #' RBO to allow for p-value calculations.
123 | #'
124 | #' @author Fabian Schmich ("gespeR" package)
125 | #' @export
126 | #'
127 | #' @param list1 List 1
128 | #' @param list2 List 2
129 | #' @param p Weighting parameter in [0, 1]. High p implies strong emphasis on top ranked elements
130 | #' @param k Evaluation depth for extrapolation
131 | #' @param side Evaluate similarity between the top or the bottom of the ranked lists
132 | #' @param mid Set the mid point to for example only consider positive or negative scores
133 | #' @param uneven.lengths Indicator if lists have uneven lengths
134 | #' @return a scaler value measuring the rank biased overlap (rbo)
135 | #'
136 |
137 | rbo <- function(list1, list2, p, k=floor(max(length(list1), length(list2))/2), side=c("top", "bottom"), mid = NULL, uneven.lengths = TRUE) {
138 | side <- match.arg(side)
139 | if (!is.numeric(list1) | !is.numeric(list2))
140 | stop("Input vectors are not numeric.")
141 | if (is.null(names(list1)) | is.null(names(list2)))
142 | stop("Input vectors are not named.")
143 | ids <- switch(side,
144 | "top"=list(list1=.select.ids(list1, "top", mid), list2=.select.ids(list2, "top", mid)),
145 | "bottom"=list(list1=.select.ids(list1, "bottom", mid), list2=.select.ids(list2, "bottom", mid))
146 | )
147 | min(1, .rbo.ext(ids$list1, ids$list2, p, k, uneven.lengths = uneven.lengths))
148 | }
149 |
150 |
151 | # rbo2 <- function(list1, list2, p, k=floor(max(length(list1), length(list2))/2), side=c("top", "bottom"), mid = NULL, uneven.lengths = TRUE) {
152 | # side <- match.arg(side)
153 | # if (!is.numeric(list1) | !is.numeric(list2))
154 | # stop("Input vectors are not numeric.")
155 | # if (is.null(names(list1)) | is.null(names(list2)))
156 | # stop("Input vectors are not named.")
157 | # ids <- switch(side,
158 | # "top"=list(list1=.select.ids(list1, "top", mid), list2=.select.ids(list2, "top", mid)),
159 | # "bottom"=list(list1=.select.ids(list1, "bottom", mid), list2=.select.ids(list2, "bottom", mid))
160 | # )
161 | # min(1, rbo_ext(ids$list1, ids$list2, p, k, uneven_lengths = uneven.lengths))
162 | # }
163 |
164 |
165 | #' Select top or bottom names of ranked vector
166 | #'
167 | #' @author Fabian Schmich ("gespeR" package)
168 | #' @noRd
169 | #'
170 | #' @param x The ranked list
171 | #' @param side The side to be evaluated ("top" or "bottom" of ranked list)
172 | #' @param mid The mid point to split a list, e.g. to split between positive and negative values choose mid=0
173 | #' @return A vector of selected identifiers
174 | .select.ids <- function(x, side=c("top", "bottom"), mid=NULL) {
175 | side <- match.arg(side)
176 | if (side == "top") {
177 | x <- sort(x, decreasing=TRUE)
178 | if (is.null(mid))
179 | return(names(x))
180 | else
181 | return(names(x)[which(x > mid)])
182 | } else if (side == "bottom") {
183 | x <- sort(x, decreasing=FALSE)
184 | if (is.null(mid))
185 | return(names(x))
186 | else
187 | return(names(x)[which(x < mid)])
188 | }
189 | }
190 |
191 |
192 | #' Rank biased overlap formula based on (32) from "A Similarity Measure for Indefinite Rankings" (Webber et al.)
193 | #'
194 | #' @author Fabian Schmich ("gespeR" package)
195 | #' @noRd
196 | #'
197 | #' @param x List 1
198 | #' @param y List 2
199 | #' @param p The weighting parameter in [0, 1]. High p implies strong emphasis on top ranked elements
200 | #' @param k The evaluation depth
201 | #' @param uneven.lengths Indicator if lists have uneven lengths
202 | #' @return The rank biased overlap between x and y
203 | .rbo.ext <- function(x, y, p, k, uneven.lengths = TRUE) {
204 | if (length(x) <= length(y)) {
205 | S <- x
206 | L <- y
207 | } else {
208 | S <- y
209 | L <- x
210 | }
211 | l <- min(k, length(L))
212 | s <- min(k, length(S))
213 |
214 | if (uneven.lengths) {
215 | Xd <- sapply(1:l, function(i) length(intersect(S[1:i], L[1:i])))
216 | ((1-p) / p) *
217 | ((sum(Xd[seq(1, l)] / seq(1, l) * p^seq(1, l))) +
218 | (sum(Xd[s] * (seq(s+1, l) - s) / (s * seq(s+1, l)) * p^seq(s+1, l)))) +
219 | ((Xd[l] - Xd[s]) / l + (Xd[s] / s)) * p^l
220 | } else {
221 | #stopifnot(l == s)
222 | k <- min(s, k)
223 | Xd <- sapply(1:k, function(i) length(intersect(x[1:i], y[1:i])))
224 | Xk <- Xd[k]
225 | (Xk / k) * p^k + (((1-p)/p) * sum((Xd / seq(1,k)) * p^seq(1,k)))
226 | }
227 | }
228 |
229 |
230 | #' Rank biased overlap (RBO) based enrichment test
231 | #'
232 | #' To perform enrichment test based on rank biased overlap and permutation.
233 | #'
234 | #' @export
235 | #'
236 | #' @param input_list input gene list from user (a named vector)
237 | #' @param go_term_db a list object of multiple gene-ontology (GO) terms to run enrichment test against
238 | #' @param p Weighting parameter in [0, 1]. High p implies strong emphasis on top ranked elements
239 | #' @param n_iter the number of iteration to perform the permutation to obtain the P-values of the enrichment test
240 | #' @param k Evaluation depth for extrapolation
241 | #' @param side Evaluate similarity between the top or the bottom of the ranked lists
242 | #' @param mid Set the mid point to for example only consider positive or negative scores
243 | #' @param uneven.lengths Indicator if lists have uneven lengths
244 | #' @param empirical_test a boolen value to tell the function is an empirical test should be performed. If TRUE,
245 | #' the exact empirical proportion of the permutated elements that are greater than the true RBO
246 | #' is returned as the p-value (high accuracy usually requires a large n_iter, e.g., 1000). If FALSE, then a standard
247 | #' Z-score test is applied to the RBO based on the mean and standard deviation of all the permuated elements (less accurate
248 | #' but more efficient. A small n_iter is usually enough (e.g., 100 or 200) to get good approximation compared to
249 | #' the true empirical test).
250 | #'
251 | #' @return a data.frame consists of rbo measurement between the inptu gene list and all the GO terms,
252 | #' as well as the P-values based on permutation. Please note that the P-values indicate whether the rank of the input gene
253 | #' list and the GO-term gene set are consistent or not. It does NOT indicate if RBO is significantly different from 0.
254 | #'
255 |
256 | rbo_enrich_test <- function(input_list,
257 | go_term_db,
258 | p,
259 | n_iter = 500,
260 | k=300,
261 | side=c("top", "bottom"),
262 | mid = NULL,
263 | uneven.lengths = TRUE,
264 | empirical_test = FALSE,
265 | seed = 131415926) {
266 | if(length(input_list) < 5){
267 | print("The length of the input list is less than 5, stopping analysis...")
268 | return(NULL)
269 | }
270 |
271 | # 0. each vector in the go_term_db is assumed to be an ordered vector of characters (gene names).
272 | # we need to convert each vector in to a named vector of number (number being the rank of each gene).
273 | go_term_db2 = lapply(X = go_term_db,
274 | FUN = function(x) {
275 | if(side == "bottom") tmp = 1:length(x)
276 | else if (side == "top") tmp = length(x):1
277 | names(tmp) = x
278 | return(tmp)
279 | })
280 |
281 | # create a rank vector from input_list
282 | ori_input_list = input_list
283 | if(side == "bottom"){
284 | input_list = 1:length(ori_input_list)
285 | names(input_list) = ori_input_list
286 | } else if (side == "top") {
287 | input_list = length(ori_input_list):1
288 | names(input_list) = ori_input_list
289 | }
290 |
291 | # 1. calculate the true RBO for the input_list and all the GO terms
292 | rbo_real = sapply(X = go_term_db2,
293 | FUN = rbo,
294 | list2 = input_list,
295 | p = p,
296 | k = k,
297 | side = side,
298 | mid = mid,
299 | uneven.lengths = uneven.lengths)
300 |
301 | # 2. now we need to proceed to the permutation tests
302 | set.seed(seed)
303 |
304 | # Shuffle the input_list for n_iter times (shuffled matrix has n_iter columns)
305 | max_d = ifelse(k >= length(input_list), yes = length(input_list), no = k)
306 | shuffled_matrix <- replicate(n_iter, sample(input_list[1:max_d]))
307 | rownames(shuffled_matrix) = names(input_list[1:max_d])
308 |
309 | # Function to calculate rbo for each go_term against the shuffled matrix
310 | calculate_rbo <- function(go_term) {
311 | apply(shuffled_matrix,
312 | MARGIN = 2,
313 | FUN = rbo,
314 | list2 = go_term,
315 | p = p,
316 | k = k,
317 | side = side,
318 | mid = mid,
319 | uneven.lengths = uneven.lengths)
320 | }
321 |
322 | # Apply the function to each go_term in go_term_db2
323 | list_perm_vector <- lapply(go_term_db2, calculate_rbo)
324 |
325 | # now calculate the P-values based on empirical_test
326 | if(empirical_test == TRUE){
327 | calculate_proportion <- function(element, list_vec) {
328 | mean(list_vec > element)
329 | }
330 | p_values <- mapply(calculate_proportion, rbo_real, list_perm_vector)
331 | } else if (empirical_test == FALSE){
332 | calculate_proportion <- function(element, list_vec) {
333 | pnorm(q = element,
334 | mean = mean(list_vec),
335 | sd = sd(list_vec),
336 | lower.tail = F)
337 | }
338 | p_values <- mapply(calculate_proportion, rbo_real, list_perm_vector)
339 | }
340 |
341 | # merge the results into one data.frame
342 | res_dat = data.frame(GO_term = names(rbo_real),
343 | RBO = rbo_real,
344 | Pval = p_values,
345 | n_GO_term = sapply(X = go_term_db2, FUN = length),
346 | n_intersect = sapply(X = go_term_db, FUN = function(x, y) length(intersect(x, y)), y = names(input_list)))
347 | #
348 | res_dat$Pval[res_dat$n_intersect <= 1 | res_dat$RBO <= 0.01 ] = 1
349 | rownames(res_dat) = NULL
350 | return(res_dat)
351 | }
352 |
353 |
354 | #' get the weight of each depth till 'd' given a weight parameter 'p'
355 | #' @noRd
356 | #' @return a numeric vector of the weights from rank depth 1 to d.
357 | gs_seq = function(d, p){
358 | gs = function(d, p){
359 | (1-p)*p^(d-1)
360 | }
361 | return(gs(1:d, p))
362 | }
363 |
364 |
365 |
366 | #' Standard Fisher's exact test for enrichment analysis
367 | #'
368 | #' This function will perform the strandard Fisher's exact test between the input gene
369 | #' list and a series of gene-ontology gene sets (adopted from DAVID GO analysis).
370 | #'
371 | #' @export
372 | #'
373 | #' @param input_list the input gene list
374 | #' @param background the background gene list (usually the expressed genes where the
375 | #' input gene list is generate from, ).
376 | #' @param go_term_db a list of gene-lists (GO term). It should be a list contain multiple named vector,
377 | #' and each vector should be a vector of multiple marker/signature genes for some biological pathway/process.
378 | #' @param list_gene A Boolen value to indicate if the overlapping genes between the input gene list and
379 | #' the GO-term should be output as well.
380 | #' @param EASE A Boolen value to indicate if the EASE correction should be applied (see
381 | #' https://david.ncifcrf.gov/helps/functional_annotation.html). This is useful to mitigate the
382 | #' small-sample inflation when the input gene list is short (e.g., < 10).
383 | #'
384 | #' @return a data frame contains the enrichment test results. Each row contains the P-value and enrichment odds
385 | #' ratio calculated from a Fisher's exact test for one GO-term in the go_term_db.
386 |
387 | fisher_enrich_test = function(input_list = NULL,
388 | background = NULL,
389 | go_term_db = NULL,
390 | list_gene = F,
391 | EASE = F){
392 | PT = length(background)
393 |
394 | # if go_term_db is a list of lists, Reduce it down to a list of vector (remove all the intermediate layers)
395 | while(class(go_term_db[[1]]) == "list"){
396 | go_term_db = Reduce(c, go_term_db)
397 | }
398 |
399 | if(list_gene == F){
400 | dat = matrix(nrow = length(go_term_db), ncol = 6)
401 | i = 1
402 | for(GO_TERM in names(go_term_db)){
403 | PH = length(intersect(go_term_db[[GO_TERM]], background))
404 | LT = length(input_list)
405 |
406 | # LH_list = intersect(input_list, go_term_db[[GO_TERM]])
407 | LH = length(intersect(input_list, go_term_db[[GO_TERM]]))
408 |
409 | # the Fisher exact test with EASE correction
410 | dat2 = matrix(data = c(LH-1, PH-LH+1, LT-LH, PT-LT-(PH-LH)), byrow = T, ncol = 2)
411 | # print(dat2)
412 | if(LH < 1 | EASE == T){
413 | dat2 = matrix(data = c(LH, PH-LH, LT-LH, PT-LT-(PH-LH)), byrow = T, ncol = 2)
414 | }
415 | #
416 | res = fisher.test(dat2, alternative = "greater")
417 | #
418 | dat[i, 1] = GO_TERM
419 | dat[i, 2] = res$estimate
420 | dat[i, 3] = res$p.value
421 | dat[i, 4] = -log(res$p.value)*res$estimate
422 | dat[i, 5] = LH
423 | dat[i, 6] = PH
424 | #
425 | i = i + 1
426 | }
427 | dat = as.data.frame(dat)
428 | dat = dat[complete.cases(dat), ]
429 | names(dat) = c("GO_term", "OR", "Pval", "combined_score", "num_LH", "num_PH")
430 |
431 | } else {
432 | dat = matrix(nrow = length(go_term_db), ncol = 7)
433 | i = 1
434 | for(GO_TERM in names(go_term_db)){
435 | PH = length(intersect(go_term_db[[GO_TERM]], background))
436 | LT = length(input_list)
437 |
438 | LH_list = intersect(input_list, go_term_db[[GO_TERM]])
439 | LH = length(LH_list)
440 |
441 | # the Fisher exact test with EASE correction
442 | dat2 = matrix(data = c(LH-1, PH-LH+1, LT-LH, PT-LT-(PH-LH)), byrow = T, ncol = 2)
443 | # print(dat2)
444 | if(LH < 1){
445 | dat2 = matrix(data = c(LH, PH-LH, LT-LH, PT-LT-(PH-LH)), byrow = T, ncol = 2)
446 | }
447 | #
448 | res = fisher.test(dat2, alternative = "greater")
449 | #
450 | dat[i, 1] = GO_TERM
451 | dat[i, 2] = res$estimate
452 | dat[i, 3] = res$p.value
453 | dat[i, 4] = -log(res$p.value)*res$estimate
454 | dat[i, 5] = LH
455 | dat[i, 6] = PH
456 | dat[i, 7] = paste0(LH_list, collapse = ";")
457 |
458 | #
459 | i = i + 1
460 | }
461 | dat = as.data.frame(dat)
462 | dat = dat[complete.cases(dat), ]
463 | names(dat) = c("GO_term", "OR", "Pval", "combined_score", "num_LH", "num_PH", "overlap_gene")
464 |
465 | }
466 |
467 | dat$OR = as.numeric(dat$OR)
468 | dat$Pval = as.numeric(dat$Pval)
469 | dat$num_LH = as.integer(dat$num_LH)
470 | dat$num_PH = as.integer(dat$num_PH)
471 | dat$n_GO_term = sapply(X = go_term_db, FUN = length)
472 |
473 | return(dat)
474 | }
475 |
476 |
477 |
478 |
479 |
480 |
481 |
482 |
483 |
484 |
485 |
486 |
487 |
488 |
489 |
490 |
491 |
492 |
--------------------------------------------------------------------------------
/R/get_fold_change.R:
--------------------------------------------------------------------------------
1 | #'
2 | NULL
3 |
4 |
5 | #' Calculate log-fold-change given a vector of gene expression and the indices of perturbed cells and non-target cells
6 | #'
7 | #' Function to calculate log-fold-change for pooled CRISPR screen datasets.
8 | #' It is just a simple function to calculate the log-fold-change. Users can customise the min.cells,
9 | #' minimal expression threshold, pseudo-count (the small value added to the expression level to avoid log(0)),
10 | #' minimal percentage of cells expression the genes, and the base of the log.
11 | #'
12 | #' @param gene_exp a vector of the gene expression levels
13 | #' @param idx_P a vector of index for the perturbed cells in the gene_exp
14 | #' @param idx_NT a vector of index for the non-target cells (controls) in the gene_exp
15 | #' @param min.cells the minimal number of cells that expresses the gene; if lower than this value, the
16 | #' fold-change will be returned as NA. Default is 3.
17 | #' @param thresh.min the minimal value of expression; any expression value lower than this will be
18 | #' considered as 0. Default is 0.
19 | #' @param pseudocount.use the small value that will be added to the log-transformation to avoid log(0).
20 | #' For example, if a mean expression value is x, the final log-
21 | #' @param min.pct the minimal proportion of cells in either groups that expresses the gene
22 | #' @param base the base for log()
23 | #' @param norm.method the normalization method for the input gene_exp. Default is 'raw', which means
24 | #' the original count value without normalization. The other supported values are 'log.norm', "scale.data".
25 | #' The mean.fxn() will change accordingly.
26 | #' @return Returns a single value of the log-fold-change of the input gene.
27 | #' @export
28 | #' @concept perturbation_scoring
29 |
30 | get_fc = function(gene_exp = NULL, idx_P = NULL, idx_NT = NULL,
31 | min.cells = 3,
32 | thresh.min = 0,
33 | pseudocount.use = 1,
34 | min.pct = 0.1,
35 | base = 2,
36 | norm.method = 'raw'
37 | ){
38 | # the exp_vec should have been std
39 |
40 | # flag 1: do minimum cell check
41 | if (sum(gene_exp[idx_P] > 0) < min.cells &&
42 | sum(gene_exp[idx_NT] > 0) < min.cells) {
43 | return(NA)
44 | }
45 |
46 | # flag 2: do variance check (not 0)
47 | if (var(gene_exp) == 0) {
48 | return(NA)
49 | }
50 |
51 | # flag 3: min.pct check
52 | # calculate fraction of cell with expression > 0
53 | pct.1 <- round(
54 | x = sum(x = gene_exp[idx_NT] > thresh.min) /
55 | length(x = gene_exp[idx_NT]),
56 | digits = 3
57 | )
58 | pct.2 <- round(
59 | x = sum(x = gene_exp[idx_P] > thresh.min) /
60 | length(x = gene_exp[idx_P]),
61 | digits = 3
62 | )
63 |
64 | if (pct.1 < min.pct & pct.2 < min.pct) {
65 | return(NA)
66 | }
67 |
68 | # set the mean.fxn() function according to norm.method
69 | default.mean.fxn <- function(x) {
70 | return(log(x = mean(x = x) + pseudocount.use, base = base))
71 | }
72 | mean.fxn <- switch(
73 | EXPR = norm.method,
74 | 'log.norm' = function(x) {
75 | return(log(x = mean(x = expm1(x = x)) + pseudocount.use, base = base))
76 | },
77 | 'scale.data' = mean,
78 | default.mean.fxn
79 | )
80 |
81 | # flag 4: minimum fold change check
82 | # log(x = mean(x = x) + pseudocount.use, base = base)
83 | data.1 <- mean.fxn(gene_exp[idx_NT])
84 | data.2 <- mean.fxn(gene_exp[idx_P])
85 | fc <- - data.1 + data.2
86 | return(fc)
87 |
88 | }
89 |
90 |
91 |
92 | # a function to do the filtering for all the genens
93 | get_idx = function(gene_exp = NULL, idx_P = NULL, idx_NT = NULL,
94 | min.cells = 3, # the minimum cell threshold to perform DE
95 | thresh.min = 0, # the minimum expression level
96 | pseudocount.use = 1,
97 | min.pct = 0.1,
98 | logfc.threshold = 0.1,
99 | base = 2,
100 | norm.method = 'raw'
101 | ){
102 |
103 | fc <- get_fc(gene_exp = gene_exp, idx_P = idx_P, idx_NT = idx_NT,
104 | min.cells = min.cells,
105 | thresh.min = thresh.min,
106 | pseudocount.use = pseudocount.use,
107 | min.pct = min.pct,
108 | base = base,
109 | norm.method = norm.method
110 | )
111 |
112 | if (fc < logfc.threshold){
113 | return(FALSE)
114 | }
115 |
116 | return(TRUE)
117 | }
118 |
119 |
120 | #' Calculate log-fold-change given a vector of gene expression and the indices of perturbed cells and non-target cells
121 | #'
122 | #' Function to calculate log-fold-change for pooled CRISPR screen datasets.
123 | #' It is just a simple function to calculate the log-fold-change. Users can customise the min.cells,
124 | #' minimal expression threshold, pseudo-count (the small value added to the expression level to avoid log(0)),
125 | #' minimal percentage of cells expression the genes, and the base of the log.
126 | #'
127 | #' @inheritParams Seurat::FoldChange
128 | #' @importFrom Matrix rowSums
129 | #' @return Returns a single value of the log-fold-change of the input gene.
130 | #' @export
131 | #' @concept perturbation_scoring
132 | FoldChange_new <- function(
133 | object,
134 | cells.1,
135 | cells.2,
136 | mean.fxn,
137 | fc.name,
138 | features = NULL,
139 | ...
140 | ) {
141 | features <- features %||% rownames(x = object)
142 |
143 | # Calculate percent expressed
144 | thresh.min <- 0
145 |
146 | min.cell.1 = Matrix::rowSums(x = object[features, cells.1, drop = FALSE] > thresh.min)
147 | min.cell.2 = Matrix::rowSums(x = object[features, cells.2, drop = FALSE] > thresh.min)
148 |
149 | pct.1 <- round(
150 | x = Matrix::rowSums(x = object[features, cells.1, drop = FALSE] > thresh.min) /
151 | length(x = cells.1),
152 | digits = 3
153 | )
154 | pct.2 <- round(
155 | x = Matrix::rowSums(x = object[features, cells.2, drop = FALSE] > thresh.min) /
156 | length(x = cells.2),
157 | digits = 3
158 | )
159 | # Calculate fold change
160 | data.1 <- mean.fxn(object[features, cells.1, drop = FALSE])
161 | data.2 <- mean.fxn(object[features, cells.2, drop = FALSE])
162 | fc <- (data.1 - data.2)
163 | fc.results <- as.data.frame(x = cbind(fc, pct.1, pct.2, min.cell.1, min.cell.2))
164 | colnames(fc.results) <- c(fc.name, "pct.1", "pct.2", "min.cell.1", "min.cell.2")
165 | return(fc.results)
166 | }
167 |
168 |
169 |
170 |
171 |
--------------------------------------------------------------------------------
/R/glm_gp_disp_only.R:
--------------------------------------------------------------------------------
1 | #'
2 | NULL
3 |
4 |
5 | #' Internal Function to Fit a Gamma-Poisson GLM
6 | #'
7 | #' @import glmGamPoi
8 | #' @inheritParams glmGamPoi::glm_gp
9 | #' @inheritParams glmGamPoi::overdispersion_mle
10 | #' @param Y any matrix-like object (e.g. `matrix()`, `DelayedArray()`, `HDF5Matrix()`) with
11 | #' one column per sample and row per gene.
12 | #'
13 | #' @return a list with four elements
14 | #' * `Beta` the coefficient matrix
15 | #' * `overdispersion` the vector with the estimated overdispersions
16 | #' * `Mu` a matrix with the corresponding means for each gene
17 | #' and sample
18 | #' * `size_factors` a vector with the size factor for each
19 | #' sample
20 | #' * `ridge_penalty` a vector with the ridge penalty
21 | #'
22 | #' @seealso [glm_gp()] and [overdispersion_mle()]
23 | #' @keywords internal
24 | glm_gp_disp_only_impl <- function(Y, model_matrix,
25 | offset = 0,
26 | size_factors = c("normed_sum", "deconvolution", "poscounts", "ratio"),
27 | overdispersion = TRUE,
28 | overdispersion_shrinkage = TRUE,
29 | ridge_penalty = 0,
30 | do_cox_reid_adjustment = TRUE,
31 | subsample = FALSE,
32 | verbose = FALSE){
33 | if(is.vector(Y)){
34 | Y <- matrix(Y, nrow = 1)
35 | }
36 | # Error conditions
37 | stopifnot(is.matrix(Y) || is(Y, "DelayedArray"))
38 | stopifnot(is.matrix(model_matrix) && nrow(model_matrix) == ncol(Y))
39 | glmGamPoi:::validate_Y_matrix(Y)
40 | subsample <- glmGamPoi:::handle_subsample_parameter(Y, subsample)
41 | ridge_penalty <- glmGamPoi:::handle_ridge_penalty_parameter(ridge_penalty, model_matrix, verbose = verbose)
42 |
43 | # Combine offset and size factor
44 | off_and_sf <- glmGamPoi:::combine_size_factors_and_offset(offset, size_factors, Y, verbose = verbose)
45 | offset_matrix <- off_and_sf$offset_matrix
46 | size_factors <- off_and_sf$size_factors
47 |
48 | # Check if there distinct groups in model matrix
49 | # returns NULL if there would be more groups than columns
50 | # only_intercept_model <- ncol(model_matrix) == 1 && all(model_matrix == 1)
51 | groups <- glmGamPoi:::get_groups_for_model_matrix(model_matrix)
52 | if(! is.null(groups) && any(ridge_penalty > 1e-10)){
53 | # Cannot apply ridge penalty in group-wise optimization
54 | groups <- NULL
55 | }
56 |
57 | # If no overdispersion, make rough first estimate
58 | if(isTRUE(overdispersion)){
59 | if(verbose){ message("Make initial dispersion estimate") }
60 | disp_init <- glmGamPoi:::estimate_dispersions_roughly(Y, model_matrix, offset_matrix = offset_matrix)
61 | }else if(isFALSE(overdispersion)){
62 | disp_init <- rep(0, times = nrow(Y))
63 | }else if(is.character(overdispersion) && overdispersion == "global"){
64 | if(verbose){ message("Make initial dispersion estimate") }
65 | disp_init <- glmGamPoi:::estimate_dispersions_roughly(Y, model_matrix, offset_matrix = offset_matrix)
66 | disp_init <- rep(median(disp_init), nrow(Y))
67 | }else{
68 | stopifnot(is.numeric(overdispersion) && (length(overdispersion) == 1 || length(overdispersion) == nrow(Y)))
69 | if(length(overdispersion) == 1){
70 | disp_init <- rep(overdispersion, times = nrow(Y))
71 | }else{
72 | disp_init <- overdispersion
73 | }
74 | }
75 |
76 |
77 | # Estimate the betas
78 | if(! is.null(groups)){
79 | if(verbose){ message("Make initial beta estimate") }
80 | beta_group_init <- glmGamPoi:::estimate_betas_roughly_group_wise(Y, offset_matrix, groups)
81 | if(verbose){ message("Estimate beta") }
82 | beta_res <- glmGamPoi:::estimate_betas_group_wise(Y, offset_matrix = offset_matrix,
83 | dispersions = disp_init, beta_group_init = beta_group_init,
84 | groups = groups, model_matrix = model_matrix)
85 | }else{
86 | # Init beta with reasonable values
87 | if(verbose){ message("Make initial beta estimate") }
88 | beta_init <- glmGamPoi:::estimate_betas_roughly(Y, model_matrix, offset_matrix = offset_matrix, ridge_penalty = ridge_penalty)
89 | if(verbose){ message("Estimate beta") }
90 | beta_res <- glmGamPoi:::estimate_betas_fisher_scoring(Y, model_matrix = model_matrix, offset_matrix = offset_matrix,
91 | dispersions = disp_init, beta_mat_init = beta_init, ridge_penalty = ridge_penalty)
92 | }
93 | Beta <- beta_res$Beta
94 |
95 | # Calculate corresponding predictions
96 | # Mu <- exp(Beta %*% t(model_matrix) + offset_matrix)
97 | Mu <- glmGamPoi:::calculate_mu(Beta, model_matrix, offset_matrix)
98 |
99 | # Make estimate of over-disperion
100 | if(isTRUE(overdispersion) || (is.character(overdispersion) && overdispersion == "global")){
101 | if(verbose){ message("Estimate dispersion") }
102 | if(isTRUE(overdispersion)){
103 | disp_est <- overdispersion_mle(Y, Mu, model_matrix = model_matrix,
104 | do_cox_reid_adjustment = do_cox_reid_adjustment,
105 | subsample = subsample, verbose = verbose)$estimate
106 | }else if(is.character(overdispersion) && overdispersion == "global"){
107 | disp_est <- overdispersion_mle(Y, Mu, model_matrix = model_matrix,
108 | do_cox_reid_adjustment = do_cox_reid_adjustment,
109 | global_estimate = TRUE,
110 | subsample = subsample, verbose = verbose)$estimate
111 | disp_est <- rep(disp_est, times = nrow(Y))
112 | }
113 |
114 | if(isTRUE(overdispersion_shrinkage)){
115 | dispersion_shrinkage <- overdispersion_shrinkage(disp_est, gene_means = DelayedMatrixStats::rowMeans2(Mu),
116 | df = subsample - ncol(model_matrix),
117 | ql_disp_trend = length(disp_est) >= 100,
118 | npoints = max(0.1 * length(disp_est), 100),
119 | verbose = verbose)
120 | disp_latest <- dispersion_shrinkage$dispersion_trend
121 | }else{
122 | dispersion_shrinkage <- NULL
123 | disp_latest <- disp_est
124 | }
125 |
126 | # Estimate the betas again (only necessary if disp_est has changed)
127 | # if(verbose){ message("Estimate beta again") }
128 | # if(! is.null(groups)){
129 | # beta_res <- estimate_betas_group_wise(Y, offset_matrix = offset_matrix,
130 | # dispersions = disp_latest, beta_mat_init = Beta,
131 | # groups = groups, model_matrix = model_matrix)
132 | # }else{
133 | # beta_res <- estimate_betas_fisher_scoring(Y, model_matrix = model_matrix, offset_matrix = offset_matrix,
134 | # dispersions = disp_latest, beta_mat_init = Beta, ridge_penalty = ridge_penalty)
135 | # }
136 | # Beta <- beta_res$Beta
137 | #
138 | # # Calculate corresponding predictions
139 | # Mu <- calculate_mu(Beta, model_matrix, offset_matrix)
140 | }else if(isTRUE(overdispersion_shrinkage) || is.numeric(overdispersion_shrinkage)){
141 | # Given predefined disp_est shrink them
142 | disp_est <- disp_init
143 | dispersion_shrinkage <- overdispersion_shrinkage(disp_est, gene_means = DelayedMatrixStats::rowMeans2(Mu),
144 | df = subsample - ncol(model_matrix),
145 | disp_trend = overdispersion_shrinkage, verbose = verbose)
146 | disp_latest <- dispersion_shrinkage$dispersion_trend
147 | # if(verbose){ message("Estimate beta again") }
148 | # if(! is.null(groups)){
149 | # beta_res <- estimate_betas_group_wise(Y, offset_matrix = offset_matrix,
150 | # dispersions = disp_latest, beta_mat_init = Beta,
151 | # groups = groups, model_matrix = model_matrix)
152 | # }else{
153 | # beta_res <- estimate_betas_fisher_scoring(Y, model_matrix = model_matrix, offset_matrix = offset_matrix,
154 | # dispersions = disp_latest, beta_mat_init = Beta, ridge_penalty = ridge_penalty)
155 | # }
156 | # Beta <- beta_res$Beta
157 | # # Calculate corresponding predictions
158 | # Mu <- calculate_mu(Beta, model_matrix, offset_matrix)
159 | }else{
160 | # Use disp_init, because it is already in vector shape
161 | disp_est <- disp_init
162 | dispersion_shrinkage <- NULL
163 | }
164 |
165 |
166 | # Return everything
167 | list(Beta = Beta,
168 | overdispersions = disp_est,
169 | overdispersion_shrinkage_list = dispersion_shrinkage)
170 | }
171 |
172 |
173 |
174 | #' Internal Function to Fit a Gamma-Poisson GLM
175 | #' @import glmGamPoi
176 | #' @inheritParams glmGamPoi::glm_gp
177 | #' @inheritParams glmGamPoi::overdispersion_mle
178 | #' @import glmGamPoi
179 | #'
180 | #' @param Y any matrix-like object (e.g. `matrix()`, `DelayedArray()`, `HDF5Matrix()`) with
181 | #' one column per sample and row per gene.
182 | #'
183 | #' @return a list with four elements
184 | #' * `Beta` the coefficient matrix
185 | #' * `overdispersion` the vector with the estimated overdispersions
186 | #' * `Mu` a matrix with the corresponding means for each gene
187 | #' and sample
188 | #' * `size_factors` a vector with the size factor for each
189 | #' sample
190 | #' * `ridge_penalty` a vector with the ridge penalty
191 | #'
192 | #' @seealso [glm_gp()] and [overdispersion_mle()]
193 | #' @keywords internal
194 | glm_gp_disp_only <- function(data,
195 | design = ~ 1,
196 | col_data = NULL,
197 | reference_level = NULL,
198 | offset = 0,
199 | size_factors = c("normed_sum", "deconvolution", "poscounts", "ratio"),
200 | overdispersion = TRUE,
201 | overdispersion_shrinkage = TRUE,
202 | ridge_penalty = 0,
203 | do_cox_reid_adjustment = TRUE,
204 | subsample = FALSE,
205 | on_disk = NULL,
206 | use_assay = NULL,
207 | verbose = FALSE){
208 |
209 | # Validate `data`
210 | if(inherits(data, "formula")){
211 | if(length(design) != 2 || design != ~ 1){
212 | stop("If the first argument is already a formula, the second argument must not be set. Please call this function like this:\n",
213 | "'glm_gp(data = mat, design = ~ a + b + c, ...)'", call. = FALSE)
214 | }
215 | extr <- glmGamPoi:::extract_data_from_formula(data, col_data, parent.frame())
216 | data <- extr$data
217 | design <- extr$design
218 | }
219 | if(is.vector(data)){
220 | data <- matrix(data, nrow = 1)
221 | }
222 | data_mat <- glmGamPoi:::handle_data_parameter(data, on_disk = F)
223 |
224 | # Convert the formula to a model_matrix
225 | col_data <- glmGamPoi:::get_col_data(data, col_data)
226 | des <- glmGamPoi:::handle_design_parameter(design, data, col_data, reference_level)
227 |
228 | # Call glm_gp_impl()
229 | res <- glm_gp_disp_only_impl(data_mat,
230 | model_matrix = des$model_matrix,
231 | offset = offset,
232 | size_factors = size_factors,
233 | overdispersion = overdispersion,
234 | overdispersion_shrinkage = overdispersion_shrinkage,
235 | ridge_penalty = ridge_penalty,
236 | do_cox_reid_adjustment = do_cox_reid_adjustment,
237 | subsample = subsample,
238 | verbose = verbose)
239 | # Make sure that the output is nice and beautiful
240 | names(res$overdispersions) <- rownames(data)
241 |
242 | class(res) <- "glmGamPoi"
243 | res
244 | }
245 |
246 |
247 |
248 |
249 |
250 |
--------------------------------------------------------------------------------
/R/perturbation_scoring.R:
--------------------------------------------------------------------------------
1 | #'
2 | NULL
3 |
4 |
5 | #' Mixscale scoring for perturbations
6 | #'
7 | #' Function to calculate perturbation scores for perturbed and non-perturbed gRNA expressing cells.
8 | #' The perturbation score reflects the perturbation strength of each cells (inherited from the RunMixscape()
9 | #' function). It is calculated by using the large-effect DE genes from raw DE tests between the
10 | #' perturbed and non-perturbed gRNA expressing cells.
11 | #'
12 | #' @export
13 | #'
14 | #' @inheritParams Seurat::RunMixscape
15 | #' @import Seurat
16 | #'
17 | #' @param object An object of class Seurat.
18 | #' @param assay Assay to use for mixscape classification.
19 | #' @param slot Assay data slot to use.
20 | #' @param labels metadata column with target gene labels.
21 | #' @param nt.class.name Classification name of non-targeting gRNA cells.
22 | #' @param new.class.name Name of mixscale scores to be stored in
23 | #' metadata.
24 | #' @param min.de.genes Required number of genes that are differentially
25 | #' expressed for method to separate perturbed and non-perturbed cells.
26 | #' @param min.cells Minimum number of cells in target gene class. If fewer than
27 | #' this many cells are assigned to a target gene class during classification,
28 | #' all are assigned NP.
29 | #' @param de.assay Assay to use when performing differential expression analysis.
30 | #' Usually RNA.
31 | #' @param logfc.threshold the log-fold-change threshold to select the large-effect
32 | #' DE genes. Only DE genes with log-fold-change larger than this value will be
33 | #' selected. Default is 0.25.
34 | #' @param verbose Display messages
35 | #' @param split.by metadata column with experimental condition/cell type
36 | #' classification information. This is meant to be used to account for cases a
37 | #' perturbation is condition/cell type -specific.
38 | #' @param fine.mode When this is equal to TRUE, DE genes for each target gene
39 | #' class will be calculated for each gRNA separately and pooled into one DE list
40 | #' for calculating the perturbation score of every cell and their subsequent
41 | #' classification.
42 | #' @param fine.mode.labels metadata column with gRNA ID labels.
43 | #' @param DE.gene specify a list of user-defined large-effect DE genes to calculate the perturbation score.
44 | #' @param max.de.genes the maximum number of top large-effect DE genes to calculate the perturbation score. Default is 100.
45 | #' @param harmonize a boolen value to specify whether a harmonization of the cell-type proportion between the NT cells and
46 | #' the perturbed cells should be performed prior to the DE test. If fine.mode is TRUE, this harmonization step will be
47 | #' performed for each fine.mode gRNA. Default is FALSE.
48 | #' @param min_prop_ntgd a minimal threshold to remove cells if any cell type has a proportion less than this value. It will
49 | #' only be used when harmonize is TRUE. Default is 0.1.
50 | #' @param pval.cutoff specify the DE test p-value cutoff (after Bonferroni correction) to select top large-effect DE genes.
51 | #' Default is 0.05.
52 | #'
53 | #' @return Returns a Seurat object containing the perturbation scores. It is stored in the Tool Data of the object, also
54 | #' the standardized scores are stored in the meta.data (column is specified by new.class.name).
55 | #' @concept perturbation_scoring
56 |
57 | RunMixscale = function (object, assay = "PRTB", slot = "scale.data", labels = "gene",
58 | nt.class.name = "NT",
59 | new.class.name = "mixscale_score",
60 | min.de.genes = 5, min.cells = 5, de.assay = "RNA", logfc.threshold = 0.25,
61 | verbose = FALSE, split.by = NULL, fine.mode = FALSE,
62 | fine.mode.labels = "guide_ID",
63 | DE.gene = NULL,
64 | max.de.genes = 100, harmonize = F,
65 | min_prop_ntgd = 0.1, pval.cutoff = 0.05,
66 | seed = 10282021)
67 | {
68 | message("Calculating Mixscale scores ...")
69 |
70 | assay <- assay %||% DefaultAssay(object = object)
71 | if (!assay %in% names(object@assays)){
72 | stop(paste0("The 'assay' being specified does not exist! Please check. Have you run CalcPerturbSig() yet?"))
73 | }
74 |
75 | if (is.null(x = labels)) {
76 | stop("Please specify target gene class metadata name")
77 | }
78 |
79 | if (min.de.genes <= 1) {
80 | warning("The min.de.genes should be larger than 1!")
81 | }
82 |
83 | prtb_markers <- list()
84 | prtb_markers2 <- list()
85 | object[[new.class.name]] <- object[[labels]]
86 | object[[new.class.name]][, 1] <- as.character(x = object[[new.class.name]][,
87 | 1])
88 | gv.list <- list()
89 | if (is.null(x = split.by)) {
90 | split.by <- splits <- "con1"
91 | } else {
92 | splits <- as.character(x = unique(x = object[[split.by]][,
93 | 1]))
94 | }
95 | cells.s.list <- list()
96 |
97 | #
98 | Idents(object = object) <- "con1"
99 | cells.s <- WhichCells(object = object, idents = "con1")
100 | # cells.s.list[[s]] <- cells.s
101 | genes <- setdiff(x = unique(x = object[[labels]][cells.s,
102 | 1]), y = nt.class.name)
103 | #
104 | for (gene in genes) {
105 | Idents(object = object) <- labels
106 |
107 | if (isTRUE(x = verbose)) {
108 | message("Processing ", gene)
109 | }
110 | orig.guide.cells <- intersect(x = WhichCells(object = object,
111 | idents = gene), y = cells.s)
112 | nt.cells <- intersect(x = WhichCells(object = object,
113 | idents = nt.class.name), y = cells.s)
114 |
115 | #############################################
116 |
117 | if (isTRUE(x = fine.mode)) {
118 | guides <- setdiff(x = unique(x = object[[fine.mode.labels]][orig.guide.cells,
119 | 1]), y = nt.class.name)
120 | all.de.genes <- c()
121 | for (gd in guides) {
122 | gd.cells <- rownames(x = object[[]][orig.guide.cells,
123 | ])[which(x = object[[]][orig.guide.cells,
124 | fine.mode.labels] == gd)]
125 | # we will need to extract the NT cells based on each celltype and do harmonization based on cell comp in PRTB cells
126 | if(harmonize == T & length(split.by) > 1){
127 | # this is a flag to indicate if the harmonization process is okay (selected_Cell >= 50% of total cell)
128 | flag_good_harm = F
129 | # the initial list of split-groups
130 | splits_list = splits
131 |
132 | while(flag_good_harm == F){
133 | # get the cell label splitted by splits
134 | cells.s.list.gd = list()
135 | cells.s.list.ntgd = list()
136 | Idents(object = object) <- split.by
137 |
138 | for (s in splits_list) {
139 | cells.s.list.gd[[s]] <- intersect(gd.cells, WhichCells(object = object, idents = s))
140 | cells.s.list.ntgd[[s]] <- intersect(nt.cells, WhichCells(object = object, idents = s))
141 | }
142 |
143 | # calculate the desired number of nt cells in each splits;
144 | length.gd = sapply(X = cells.s.list.gd, FUN = length)
145 | length.ntgd = sapply(X = cells.s.list.ntgd, FUN = length)
146 |
147 | prop.gd = length.gd/sum(length.gd, na.rm = T)
148 | # prop.ntgd = length.ntgd/sum(length.ntgd, na.rm = T)
149 | sum.desire.length.ntgd = floor(min(length.ntgd/prop.gd, na.rm = T))
150 | if(sum.desire.length.ntgd > sum(length.ntgd, na.rm = T)){
151 | stop("The sum.desire.length.ntgd is greater than the total number of NT cells. Need to check!")
152 | }
153 |
154 | if(sum.desire.length.ntgd >= min_prop_ntgd*sum(length.ntgd, na.rm = T) ){
155 | flag_good_harm = T
156 | } else {
157 | message(paste("Removing cell from ", splits_list[which.min(length.ntgd)], "due to 50% check during harmonization step."))
158 | splits_list = splits_list[-which.min(length.ntgd)]
159 | }
160 | }
161 |
162 | # calculate the final number of NT cells to extract from splits_list
163 | desire.length.ntgd = floor(sum.desire.length.ntgd*prop.gd)
164 |
165 | # start to subsample the nt cells based on the desire length:
166 | sub.cells.s.list.ntgd = list()
167 | for (s in splits_list) {
168 | set.seed(seed = seed)
169 | sub.cells.s.list.ntgd[[s]] <- sample(x = cells.s.list.ntgd[[s]], size = desire.length.ntgd[s])
170 | }
171 |
172 | # collapse the list into a single vectors of sub-sampled NT cells
173 | sub.ntgd.cells = Reduce(c, sub.cells.s.list.ntgd)
174 | rm(cells.s.list.gd, cells.s.list.ntgd, length.gd, length.ntgd, prop.gd, sum.desire.length.ntgd, desire.length.ntgd, sub.cells.s.list.ntgd)
175 | if(verbose){
176 | message("Done with harmonizing the cell composition in NT cells (fine mode).")
177 | }
178 |
179 | Idents(object = object) <- labels
180 | } else {
181 | sub.ntgd.cells = nt.cells
182 | }
183 |
184 | # run DE
185 | if(!is.null(DE.gene) ){
186 | if(!is.null(DE.gene[[gene]]) | length(DE.gene[[gene]]) != 0){
187 | all.de.genes = DE.gene[[gene]]
188 | } else {
189 | all.de.genes = character()
190 | warning(paste("No de.genes are provided for PRTB:", gene, ". Pls check!"))
191 | }
192 | } else {
193 | # run DE
194 | de.genes <- Seurat:::TopDEGenesMixscape(object = object,
195 | ident.1 = gd.cells, ident.2 = sub.ntgd.cells, de.assay = de.assay,
196 | logfc.threshold = logfc.threshold, labels = fine.mode.labels,
197 | verbose = verbose, pval.cutoff = pval.cutoff)
198 | all.de.genes <- c(all.de.genes, de.genes)
199 | }
200 | }
201 | all.de.genes <- unique(all.de.genes)
202 | } else {
203 | # we will need to extract the NT cells based on each celltype and do harmonization based on cell comp in PRTB cells
204 | if(harmonize == T & length(split.by) > 1){
205 | # this is a flag to indicate if the harmonization process is okay (selected_Cell >= 50% of total cell)
206 | flag_good_harm = F
207 | # the initial list of split-groups
208 | splits_list = splits
209 |
210 | while(flag_good_harm == F){
211 | # get the cell label splitted by splits
212 | cells.s.list.gene = list()
213 | cells.s.list.nt = list()
214 | Idents(object = object) <- split.by
215 |
216 | for (s in splits_list) {
217 | cells.s.list.gene[[s]] <- intersect(orig.guide.cells, WhichCells(object = object, idents = s))
218 | cells.s.list.nt[[s]] <- intersect(nt.cells, WhichCells(object = object, idents = s))
219 | }
220 |
221 | # calculate the desired number of nt cells in each splits;
222 | length.gene = sapply(X = cells.s.list.gene, FUN = length)
223 | length.nt = sapply(X = cells.s.list.nt, FUN = length)
224 |
225 | prop.gene = length.gene/sum(length.gene, na.rm = T)
226 | # prop.nt = length.nt/sum(length.nt, na.rm = T)
227 | sum.desire.length.nt = floor(min(length.nt/prop.gene, na.rm = T))
228 | if(sum.desire.length.nt > sum(length.nt, na.rm = T)){
229 | stop("The sum.desire.length.nt is greater than the total number of NT cells. Need to check!")
230 | }
231 | #
232 | if(sum.desire.length.nt >= min_prop_ntgd*sum(length.nt, na.rm = T) ){
233 | flag_good_harm = T
234 | } else {
235 | message(paste("Removing cell from ", splits_list[which.min(length.nt)], "due to 50% check during harmonization step."))
236 | splits_list = splits_list[-which.min(length.nt)]
237 | }
238 | }
239 |
240 | ###
241 | desire.length.nt = floor(sum.desire.length.nt*prop.gene)
242 |
243 | # start to subsample the nt cells based on the desire length:
244 | sub.cells.s.list.nt = list()
245 | for (s in splits_list) {
246 | set.seed(seed = seed)
247 | sub.cells.s.list.nt[[s]] <- sample(x = cells.s.list.nt[[s]], size = desire.length.nt[s])
248 | }
249 |
250 | # collapse the list into a single vectors of sub-sampled NT cells
251 | sub.nt.cells = Reduce(c, sub.cells.s.list.nt)
252 | rm(cells.s.list.gene, cells.s.list.nt, length.gene, length.nt, prop.gene, sum.desire.length.nt, desire.length.nt, sub.cells.s.list.nt)
253 | if(verbose){
254 | message("Done with harmonizing the cell composition in NT cells.")
255 | }
256 |
257 | Idents(object = object) <- labels
258 | } else {
259 | sub.nt.cells = nt.cells
260 | }
261 | # run DE
262 | if(!is.null(DE.gene) ){
263 | if(!is.null(DE.gene[[gene]]) | length(DE.gene[[gene]]) != 0){
264 | all.de.genes = DE.gene[[gene]]
265 | } else {
266 | all.de.genes = character()
267 | message(paste("No de.genes are provided for PRTB:", gene, ". Pls check!"))
268 | }
269 | } else {
270 | all.de.genes <- Seurat:::TopDEGenesMixscape(object = object,
271 | ident.1 = orig.guide.cells, ident.2 = sub.nt.cells,
272 | de.assay = de.assay, logfc.threshold = logfc.threshold,
273 | labels = labels, verbose = verbose, pval.cutoff = pval.cutoff)
274 | }
275 |
276 |
277 | }
278 | # print(gene)
279 | # print(all.de.genes)
280 |
281 | # only keep the top max.de.genes as the de.genes for PRTB score calculation
282 | if(!is.null(max.de.genes) ){
283 | if(length(all.de.genes) <= max.de.genes){
284 | if(verbose){
285 | message(paste("The number of de.genes (", length(all.de.genes), ") is less than max.de.genes (", max.de.genes, ")."))
286 | }
287 | } else {
288 | if(verbose){
289 | message(paste("The number of de.genes (", length(all.de.genes), ") is larger than max.de.genes (", max.de.genes, ").",
290 | "Restricting to top", max.de.genes, "genes..."))
291 | }
292 | all.de.genes = all.de.genes[1:max.de.genes]
293 | }
294 | }
295 |
296 | # use user-defined DE.gene list
297 | # if(!is.null(DE.gene) ){
298 | # all.de.genes = DE.gene
299 | # }
300 |
301 | for (s in splits) {
302 | Idents(object = object) <- split.by
303 | cells.s.list[[s]] <- WhichCells(object = object, idents = s)
304 |
305 | prtb_markers[[s]][[gene]] <- all.de.genes
306 | prtb_markers2[[s]][[gene]] <- all.de.genes
307 | if (length(x = all.de.genes) < min.de.genes) {
308 | prtb_markers[[s]][[gene]] <- character()
309 | }
310 |
311 | }
312 | if(verbose){
313 | message(paste0("Done with extracting top DE genes for ", gene))
314 | }
315 | }
316 |
317 | all_markers <- unique(x = unlist(x = prtb_markers))
318 | missing_genes <- all_markers[!all_markers %in% rownames(x = object[[assay]])]
319 | # print(missing_genes)
320 | object <- Seurat:::GetMissingPerturb(object = object, assay = assay,
321 | features = missing_genes, verbose = verbose)
322 |
323 | if(verbose){
324 | message("Done with getting Missing PRTB")
325 | }
326 |
327 | for (s in splits) {
328 | # print(splits)
329 | cells.s <- cells.s.list[[s]]
330 | genes <- setdiff(x = unique(x = object[[labels]][cells.s,
331 | 1]), y = nt.class.name)
332 | for (gene in genes) {
333 | Idents(object = object) <- labels
334 | post.prob <- 0
335 | orig.guide.cells <- intersect(x = WhichCells(object = object,
336 | idents = gene), y = cells.s)
337 | nt.cells <- intersect(x = WhichCells(object = object,
338 | idents = nt.class.name), y = cells.s)
339 | all.cells <- c(orig.guide.cells, nt.cells)
340 | if (length(x = prtb_markers[[s]][[gene]]) == 0) {
341 | if (verbose) {
342 | message(" Fewer than ", min.de.genes, " DE genes for ",
343 | gene, ". Assigning cells as NP.")
344 | }
345 | object[[new.class.name]][orig.guide.cells, 1] <- paste0(gene, " NP")
346 | }
347 | else {
348 | if (verbose) {
349 | message(" ", gene)
350 | }
351 | de.genes <- prtb_markers[[s]][[gene]]
352 | dat <- GetAssayData(object = object[[assay]],
353 | slot = "data")[de.genes, all.cells, drop = FALSE]
354 | if (slot == "scale.data") {
355 | dat <- ScaleData(object = dat, features = de.genes,
356 | verbose = FALSE)
357 | }
358 |
359 | # the first step to calculate the overall PRTB score
360 | if(verbose){
361 | cat(paste0("Calculating the overall PRTB score...\n"))
362 | }
363 | Idents(object = object) <- new.class.name
364 | guide.cells <- intersect(x = WhichCells(object = object,
365 | idents = gene), y = cells.s)
366 | vec <- matrixStats::rowMeans2(x = dat[, guide.cells, drop = FALSE]) -
367 | matrixStats::rowMeans2(x = dat[, nt.cells, drop = FALSE])
368 |
369 | # save the mat and vec to easily calculate the weights by rowSums
370 | pvec_mat = sweep(t(dat), MARGIN=2, vec, `*`)
371 | vec_mat = vec * vec
372 | names(vec_mat) = colnames(pvec_mat)
373 |
374 | # the weights
375 | pvec = matrixStats::rowSums2(pvec_mat)/sum(vec_mat)
376 | names(pvec) = rownames(pvec_mat)
377 |
378 | # create a list to store the PRTB score
379 | gv <- as.data.frame(x = pvec)
380 | gv[, "gene"] <- nt.class.name
381 | gv[intersect(x = rownames(x = gv), y = guide.cells),
382 | "gene"] <- gene
383 | gv.list[[gene]][[s]] <- gv
384 |
385 | # the LOOv2 weights
386 | # for(omit_gene in de.genes){
387 | # if(verbose){
388 | # cat(paste0("Calculating the LOO PRTB score by using rowSums2 for ", omit_gene, " in subset ", s, "...\n"))
389 | # }
390 | # remain_gene = de.genes[which(de.genes != omit_gene)]
391 | # pvec2 <- rowSums2(pvec_mat[, remain_gene, drop = F])/sum(vec_mat[remain_gene])
392 | # # save the LOO weights
393 | # gv.list[[gene]][[s]][, omit_gene] <- pvec2
394 | # }
395 |
396 | # 2023 July 03: substitute the above loop with the following matrix manipulation for speed.
397 | omit_mat <- outer(de.genes, de.genes, `!=`)
398 |
399 | # Function to calculate pvec2
400 | calc_pvec2 <- function(include_gene) {
401 | pvec2 <- matrixStats::rowSums2(pvec_mat[, include_gene, drop = F])/sum(vec_mat[include_gene])
402 | return(pvec2)
403 | }
404 |
405 | # Apply the function to each column of omit_mat
406 | gv.list[[gene]][[s]][, de.genes] <- apply(omit_mat, 2, calc_pvec2)
407 |
408 |
409 | # the second step to calculate the leave-one-out (LOO) PRTB score
410 | if(verbose){
411 | message(paste0("Done calculating LOO PRTB score for ", length(de.genes), " genes in ", s, "...\n"))
412 | }
413 |
414 | }
415 |
416 | }
417 | if(verbose){
418 | message(paste0("Done with calculating scores for ", s))
419 | }
420 | }
421 | SeuratObject::Tool(object = object) <- gv.list
422 |
423 | # check if gv.list is empty.
424 | if(length(gv.list) == 0){
425 | warning("Failed to calculate Mixscale scores for any group. \nThis is probably due to insufficient response to perturbation.\nYou may consider lowering the logfc.threshold or min.de.genes when running this function.")
426 | }
427 |
428 | # added Jan 16: calculate the standardized scores and append them to the meta-data
429 | # get the list of PRTBs
430 | wt_PRTB_list = sort(names(gv.list))
431 | all_PRTB_list = sort(unique(object[[labels]][,1]))
432 | all_PRTB_list = all_PRTB_list[all_PRTB_list != nt.class.name]
433 | wt_PRTB_list = wt_PRTB_list[wt_PRTB_list %in% all_PRTB_list]
434 |
435 | #
436 | mat_B = data.frame(cell_label = colnames(object),
437 | gene = object[[labels]][,1] )
438 |
439 | #
440 | all_score = data.frame() # to store the scores from each PRTB
441 | for(PRTB in all_PRTB_list){
442 | mat_A = data.frame()
443 | # check if the scores are calculated successful for this PRTB
444 | if(PRTB %in% wt_PRTB_list){
445 | celltype_list = names(gv.list[[PRTB]])
446 | for(celltype in celltype_list){
447 | # print(gv.list[[PRTB]][[celltype]])
448 | tmp = gv.list[[PRTB]][[celltype]][, c("pvec", "gene"), drop = FALSE]
449 |
450 | # get the idx for NT cells and PRTBed cells
451 | idx_NT = which(tmp$gene == nt.class.name)
452 | idx_gene = which(tmp$gene == PRTB)
453 |
454 | # 1. calculate the overall weights
455 | # calculate the mean and sd of the PRTB score for the NT cells
456 | mean_NT = mean(tmp$pvec[idx_NT], na.rm = T)
457 | sd_NT = sd(tmp$pvec[idx_NT], na.rm = T)
458 | # standardize the PRTB scores for the PRTBed cells based on the mean and SD from those of the NT cells
459 | std_weight_gene = (tmp$pvec[idx_gene] - mean_NT)/sd_NT
460 | # convert those negative standardised PRTB score to 0
461 | # std_weight_gene[which(std_weight_gene < 0)] = 0
462 |
463 | # create a new column called "weight" in the tmp dataframe.
464 | tmp$weight = 0
465 | tmp$weight[idx_gene] = std_weight_gene
466 |
467 | tmp$cell_label = row.names(tmp)
468 | tmp = tmp[, c("cell_label", "gene", "pvec", "weight")]
469 |
470 | mat_A = rbind(mat_A, tmp)
471 | rm(tmp)
472 | }
473 | } else {
474 | # celltype_list = names(gv.list[[1]])
475 | #
476 | tmp = mat_B[mat_B$gene %in% c(PRTB, nt.class.name), ]
477 | tmp$weight = 0
478 | tmp[tmp$gene == PRTB, "weight"] = 1
479 | tmp$pvec = tmp$weight
480 | #
481 | tmp = tmp[, c("cell_label", "gene", "pvec", "weight")]
482 | mat_A = tmp
483 | rm(tmp)
484 | }
485 | all_score = rbind(all_score, mat_A)
486 | }
487 |
488 | # some final editing
489 | all_score = all_score[!duplicated(all_score$cell_label), ]
490 | rownames(all_score) = all_score$cell_label
491 | all_score = all_score[, "weight", drop = FALSE]
492 | names(all_score) = new.class.name
493 | #
494 | object[[new.class.name]] = NULL
495 |
496 | # add the standardized scores to the meta-data
497 | object = AddMetaData(object, metadata = all_score)
498 |
499 | return(object)
500 | }
501 |
502 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # Mixscale
2 | Mixscale is an R package designed to analyze CRISPR interference (CRISPRi) based Perturb-seq data. It can quantify the heterogeneity of perturbation strength in each cell and improve the statistical power when doing differential expression (DE) analysis. It also provides functions for downstream analyses including decomposition, permutation test, gene set enrichment test, etc. A brief vignette is available at https://satijalab.github.io/Mixscale/.
3 |
4 | ## Dependencies
5 | This package depends on several other R packages:
6 | ```
7 | install.packages("Seurat")
8 | install.packages("PMA")
9 | install.packages("protoclust")
10 | BiocManager::install("glmGamPoi")
11 | ```
12 |
13 | ## Installation
14 | You can easily install the package by the following command:
15 | ```
16 | devtools::install_github("satijalab/Mixscale")
17 | ```
18 |
19 | ## Other resources
20 | * Our preprint is available at https://www.biorxiv.org/content/10.1101/2024.01.29.576933v2.
21 | * If you want to access the data generated in our paper (including the processed scRNA-seq data and the pathway gene signatures), you can download them at https://doi.org/10.5281/zenodo.14518762.
22 | * Raw fastq files are available at the Gene Expression Omnibus (GEO) under the accession code [GSE281048](https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=GSE281048).
23 |
24 |
--------------------------------------------------------------------------------
/docs/old/New_Vignette_2024Jan.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Using Mixscale for Perturb-seq data"
3 | author: "Longda Jiang"
4 | date: "2024-01-09"
5 | output: html_document
6 | ---
7 |
8 | ```{r setup, include=FALSE}
9 | knitr::opts_chunk$set(echo = TRUE)
10 | ```
11 |
12 | ## Introduction
13 |
14 | In this tutorial, we will describe an R package "Mixscale" for analyzing Perturb-seq data. Mixscale contains functions designed to tackle the following tasks:\
15 | 1. calculate 'Mixscale scores' for cells that receives the same perturbation to quantify the heterogeneity in perturbation strength \
16 | 2. perform a scoring-based weighted differential expression (DE) tests to identify DE genes for each perturbation \
17 | 3. perform different levels of decomposition analysis to identify correlated perturbations and group them into a program \
18 | 4. perform a PCA-based permutation test to extract shared genes for the perturbation programs (program gene signature) \
19 | 5. identify shared and unique signature between two relevant programs \
20 | 6. perform gene set enrichment tests using the program signature for new datasets \
21 | 7. perform module score analyses using the program signature to quantify the program activity in new datasets \
22 | \
23 | The tutorial is divided into two sections. The first section will describe task 1 to 5 using a public Perturb-seq dataset from the Weissman Lab ([Jost et al 2020](https://www.nature.com/articles/s41587-019-0387-5)), which can be downloaded from [GSE132080](https://0-www-ncbi-nlm-nih-gov.brum.beds.ac.uk/geo/query/acc.cgi?acc=GSE132080). The second section will describe task 6 and 7 using the pathway gene lists generated from our study (available at [Zenodo](not_inserted_yet)) and an interferon-beta stimulated human PBMCs dataset (ifnb) from [Kang et al 2017](https://www.nature.com/articles/nbt.4042). This ifnb dataset is available via the SeuratData package (see section 2 below).
24 |
25 |
26 | ### load the packages
27 | ```{r load_package, message=FALSE, warning=FALSE}
28 | options(Seurat.object.assay.version = 'v3')
29 |
30 | library(Seurat)
31 | library(ggridges)
32 | library(stringr)
33 | library(Mixscale)
34 | ```
35 |
36 | ## Section 1.
37 | In this section we will focus on how to use Mixscale to analyze Perturb-seq data.
38 |
39 | ### 0. load the demo data
40 | The demo dataset from [Jost et al 2020](https://www.nature.com/articles/s41587-019-0387-5) contains CRISPRi Perturb-seq data targeting 25 key genes involved in essential cell biological processes. We will load in the count matrix to create a Seurat object and append the provided meta data to it. \
41 | One special feature of this dataset is that, for each perturbation target gene, there are five different gRNAs designed to target it. One of the gRNA has the perfectly matched sequence for the target region (labelled with "_00"), while the others contain 1~3 nucleotide mismatches so that their perturbation stength is "titrated". We will treat the cells that have the same target gene as the same group in our downstream analyses.
42 |
43 | ```{r load_data, message=FALSE, warning=FALSE, cache=TRUE}
44 | # load the count matrix
45 | ct_mat = ReadMtx(mtx = "/Users/uqljian5/Desktop/Lab_stuffs_NYGC/Paper_information_gathering/results/GSE132080/GSE132080_10X_matrix.mtx",
46 | cells = "/Users/uqljian5/Desktop/Lab_stuffs_NYGC/Paper_information_gathering/results/GSE132080/GSE132080_10X_barcodes.tsv",
47 | features = "/Users/uqljian5/Desktop/Lab_stuffs_NYGC/Paper_information_gathering/results/GSE132080/GSE132080_10X_genes.tsv")
48 | # load the meta_data
49 | meta_data = read.csv("/Users/uqljian5/Desktop/Lab_stuffs_NYGC/Paper_information_gathering/results/GSE132080/GSE132080_cell_identities.csv")
50 | rownames(meta_data) = meta_data$cell_barcode
51 |
52 | # create a seurat object
53 | seurat_obj = CreateSeuratObject(counts = ct_mat, meta.data = meta_data)
54 | rm(ct_mat, meta_data)
55 |
56 | # retrieve the guide information for each cell
57 | txt = seurat_obj$guide_identity
58 | txt2 = str_extract(txt, "^[^_]+")
59 | txt3 = gsub(pattern = "^[^_]+_", replacement = "", txt)
60 | seurat_obj[['gene']] = txt2
61 | seurat_obj[['gRNA_name']] = txt3
62 |
63 | # remove ambiguous cells
64 | seurat_obj = subset(seurat_obj, subset = number_of_cells == 1) # 19594 cells remain
65 | seurat_obj = subset(seurat_obj, subset = guide_identity != '*') # 19587 cells remain
66 |
67 | seurat_obj
68 | ```
69 |
70 | ### 1. Pre-processing and calculating the Mixscale score
71 | We will first run standard pre-processing (normalization, find variable features, etc) for the dataset. Then, we will follow the standard [Mixscape analysis](https://satijalab.org/seurat/articles/mixscape_vignette) to calculate local perturbation signatures that mitigate confounding effects. Briefly speaking, for each cell we will search for its 20 nearest neighbors from the non-targeted (NT) cells, and then remove all technical variation so that perturbation-specific effect can be revealed.
72 |
73 | ```{r standard_process, echo=TRUE, message=FALSE, warning=FALSE, cache=TRUE}
74 | # standard pre-processing
75 | seurat_obj = NormalizeData(seurat_obj)
76 | seurat_obj = FindVariableFeatures(seurat_obj)
77 | seurat_obj = ScaleData(seurat_obj)
78 | seurat_obj = RunPCA(seurat_obj)
79 |
80 | # calculate Perturbation signatures
81 | seurat_obj <- CalcPerturbSig(
82 | object = seurat_obj,
83 | assay = "RNA",
84 | slot = "data",
85 | gd.class ="gene",
86 | nt.cell.class = "neg",
87 | reduction = "pca",
88 | ndims = 40,
89 | num.neighbors = 20,
90 | new.assay.name = "PRTB")
91 |
92 | ```
93 |
94 | Now we will calculate the Mixscale scores for each cell within each perturbation group.
95 | ```{r scoring, echo=TRUE, message=FALSE, warning=FALSE, cache=TRUE}
96 | # Mixscale
97 | seurat_obj = RunMixscale(
98 | object = seurat_obj,
99 | assay = "PRTB",
100 | slot = "scale.data",
101 | labels = "gene",
102 | nt.class.name = "neg",
103 | min.de.genes = 5,
104 | logfc.threshold = 0.2,
105 | de.assay = "RNA",
106 | max.de.genes = 100,
107 | prtb.type = "P", new.class.name = "mixscale_id", fine.mode = F)
108 |
109 | ```
110 |
111 |
112 | ### 2. Visualizations for the scores
113 | We will now use some plotting functions to explore the perturbation scores that we just calculated.
114 |
115 | ```{r, echo=TRUE, message=FALSE, warning=FALSE, cache=TRUE}
116 | # a. Check the distribution of the scores for the first 10 perturbations
117 | Mixscale_RidgePlot(object = seurat_obj,
118 | nt.class.name = "neg",
119 | PRTB = unique(seurat_obj$gene)[unique(seurat_obj$gene) != "neg"][1:10],
120 | facet_wrap = "gene", facet_scale = "fixed")
121 |
122 | # b. Check if the scores correlate with the expression level of the target gene itself
123 | Mixscale_ScatterPlot(object = seurat_obj, nt.class.name = "neg",
124 | PRTB = unique(seurat_obj$gene)[unique(seurat_obj$gene) != "neg"][1:10],
125 | facet_wrap = "gene", facet_scale = "free_y", nbin = 10)
126 | ```
127 |
128 | ### 3. Differential expression (DE) analysis
129 | After calculating the scores, we can use the scores to enhance the statistical power of DE analysis by using them as a "weights" in the regression model. Briefly speaking, instead of coding the NT cells as 0 and the targeted cells as 1, we used the standardized scores to code the targeted cells in the regression, so that cells with stronger perturbation strength will have higher "weights" and vice versa.
130 |
131 | ```{r, echo=TRUE, message=FALSE, warning=FALSE, cache=FALSE}
132 | # run score-based weighted DE test for 12 selected perturbations. It will return a list of data frames (one for each perturbation)
133 | de_res = Run_wtDE(object = seurat_obj, assay = "RNA", slot = "counts",
134 | labels = "gene", nt.class.name = "neg",
135 | logfc.threshold = 0.1)
136 |
137 | # have a quick look at the DE results
138 | head(de_res[[1]])
139 |
140 | ```
141 |
142 | We can now explore the top DE genes for each perturbations using the customized DoHeatmap function, where cells are ordered by Mixscale scores.
143 |
144 | ```{r, echo=TRUE, message=FALSE, warning=FALSE, cache=FALSE}
145 | # heatmap for the top DE genes
146 | Mixscale_DoHeatmap(object = seurat_obj, PRTB = "POLR2H",
147 | slct_condition = "con1",
148 | nt.class.name = "neg",
149 | labels = "gene",
150 | slct_features = rownames(de_res[["POLR2H"]][order(de_res[["POLR2H"]]$p_weight), ])[1:20]) + NoLegend()
151 |
152 | # similar heatmap for the top DE genes, but this time the cells are divided based on gRNA identity using slct_ident
153 | Mixscale_DoHeatmap(object = seurat_obj, PRTB = "GATA1",
154 | slct_condition = "con1",
155 | nt.class.name = "neg",
156 | labels = "gene",
157 | slct_features = rownames(de_res[["GATA1"]][order(de_res[["GATA1"]]$p_weight), ])[1:20],
158 | slct_ident = "gRNA_name") + NoLegend()
159 | ```
160 |
161 | ### 5. Decomposition analyses to identify correlated perturbations
162 | #### 5.1 Hierarchical clustering
163 | In this section we will perform mainly two types of decomposition analyses for our DE results. The first is a hierarchical clustering analysis based on ([MinMax](https://www.sciencedirect.com/science/article/abs/pii/S0031320314000338)). We will apply it to the DE Z-score matrix of our DE results.
164 |
165 | ```{r, echo=TRUE, message=FALSE, warning=FALSE, cache=FALSE}
166 | # get the Z-score matrix (a list of matrices will be returned, with each matrix correspond to a cell type)
167 | # as for the selection of rows (features), we will use the union set of the top 100 DE genes from each column
168 | DEG_mat_main = get_DE_mat(de_res, p_threshold = 0.05/30000, fc_threshold = 0.2, num_top_DEG = 100)
169 |
170 | # slightly clean up the matrices by removing columns with not enough significant DEGs and replace all the NAs with 0
171 | DEG_mat = prune_DE_mat(DEG_mat_main, mask_target = T, min_sig_DEG = 5)
172 |
173 | # an empty list to store all the gene sets (a repository of gene sets)
174 | go_db = list()
175 |
176 | # get the cell type (in this example there is only one cell type)
177 | celltype_list = names(DEG_mat)
178 |
179 | # loop through all the cell types to perform Minmax hierarchical clustering
180 | for(i in 1:length(celltype_list)){
181 | CELLTYPE = celltype_list[i]
182 | tmp=DEG_mat[[CELLTYPE]]
183 |
184 | # run hierarchical clustering using Minmax. Other standard hclust methods are also supported.
185 | # dist_thres defines the height (= 1 - dist_thres) that is used to cut the hclust tree.
186 | # a lower value indicates a more stringent threshold to define clusters.
187 | res = DEhclust(mat = tmp, cor_method = "pearson", hclust_method = "minmax", dist_thres = 0.4)
188 |
189 | # get_sig_genes_DEhclust() is a wrapper function for PCApermtest() and get_sig_genes(), which will
190 | # perform a PCA-based permutation test and extract the top shared DE genes across the perturbations
191 | # in the same cluster
192 | sig_genes = get_sig_genes_DEhclust(obj = res, row_filtering_pval = 0.05)
193 |
194 | # store the extracted top genes as the cluster signature into go_db
195 | for(CLUSTER in names(sig_genes)){
196 | if(length(sig_genes[[CLUSTER]]$sig_genes$upDEGs) >= 10){
197 | go_db[[paste0(CELLTYPE, "_", CLUSTER, "_upDEGs")]] = sig_genes[[CLUSTER]]$sig_genes$upDEGs
198 | }
199 | if(length(sig_genes[[CLUSTER]]$sig_genes$downDEGs) >= 10){
200 | go_db[[paste0(CELLTYPE, "_", CLUSTER,"_downDEGs")]] = sig_genes[[CLUSTER]]$sig_genes$downDEGs
201 | }
202 | }
203 |
204 | }
205 |
206 | # check the clustering results
207 | res$cluster_assignment
208 |
209 | # generate a correlation matrix plot based on the clustering results
210 | col3 = rev(brewer.pal(11,"RdBu"))
211 | heatmap.2(cor(tmp),
212 | Rowv = as.dendrogram(res$hclust),
213 | Colv = as.dendrogram(res$hclust),
214 | dendrogram = "none",
215 | col = col3)
216 | ```
217 |
218 | we can also use the following function to generate Z-score heatmap for each perturbation cluster and save them to a user defined directory
219 | ```{r, echo=TRUE, message=FALSE, warning=FALSE, cache=FALSE, eval=FALSE}
220 | DE_heatmap(obj = res, sig_genes = sig_genes, type = "hclust", direction = "both", top_n = 30,
221 | output_path = "output_path/",
222 | prefix = CELLTYPE)
223 | ```
224 |
225 | #### 5.2 MultiCCA analysis
226 | In our [paper](not_insert_yet), we introduced a novel approach for identifying correlated perturbations both within and between various matrices. This method is applicable when DE Z-scores are organized into a list of Z-score matrices, with each matrix corresponding to a cell type. This is especially useful when multiple cell types/lines are used in a Perturb-seq experiment. The demo dataset only contains one cell type, so we will randomly divide the Z-score matrix above into a list of 3 matrices, and use them to test our MultiCCA method.
227 |
228 | ```{r, echo=TRUE, message=FALSE, warning=FALSE, cache=FALSE}
229 | # first we randomly divide the DEG_mat_main into a list of 3 matrices
230 | set.seed(100)
231 | DEG_mat_main2 = list(type1 = DEG_mat_main[, c(1, sample(2:26)[1:8])],
232 | type2 = DEG_mat_main[, c(1, sample(2:26)[9:16])],
233 | type2 = DEG_mat_main[, c(1, sample(2:26)[17:25])] )
234 |
235 | # clean up the matrices
236 | DEG_mat = prune_DE_mat(DEG_mat_main2, min_sig_DEG = 5, center = T)
237 |
238 | # run MultiCCA
239 | res = DEmultiCCA(mat_list = DEG_mat, cor_coef_thres = 0.8, mean_cor_thres = 0.2, max_k = 3, standardize = F)
240 |
241 | # get_sig_genes_DEmultiCCA is a wrapper function for PCApermtest() and get_sig_genes() for DEmultiCCA object.
242 | sig_genes = get_sig_genes_DEmultiCCA(res, row_filtering_pval = 0.05)
243 |
244 | # store the gene signatures to the go-term repo
245 | for(PROGRAM in names(sig_genes)){
246 | if(length(sig_genes[[PROGRAM]]$sig_genes$upDEGs) >= 10){
247 | go_db[[paste0("MultiCCA_", PROGRAM, "_upDEGs")]] = sig_genes[[PROGRAM]]$sig_genes$upDEGs
248 | }
249 | if(length(sig_genes[[PROGRAM]]$sig_genes$downDEGs) >= 10){
250 | go_db[[paste0("MultiCCA_", PROGRAM, "_downDEGs")]] = sig_genes[[PROGRAM]]$sig_genes$downDEGs
251 | }
252 | }
253 |
254 | ```
255 |
256 | Again, we can use the following function to generate Z-score heatmap for each perturbation program and save them to a user defined directory
257 | ```{r, echo=TRUE, message=FALSE, warning=FALSE, cache=FALSE, eval=FALSE}
258 | DE_heatmap(obj = res, sig_genes = sig_genes,
259 | type = "multiCCA", direction = "both",
260 | top_n = 30, labRow = T,
261 | output_path = "output_path/",
262 | prefix = "MultiCCA")
263 | ```
264 |
265 |
266 |
267 |
268 |
269 |
270 |
271 |
272 |
--------------------------------------------------------------------------------
/docs/old/index copy 2.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Merged_Vignette_2024Jan16"
3 | author: "Longda Jiang"
4 | date: "2024-01-16"
5 | output: html_document
6 | ---
7 |
8 |
9 | ```{r setup, include=FALSE}
10 | knitr::opts_chunk$set(echo = TRUE)
11 | ```
12 |
13 | ## Introduction
14 |
15 | In this tutorial, we will describe an R package "Mixscale" for analyzing Perturb-seq data. Mixscale contains functions designed to tackle the following tasks:\
16 | 1. calculate 'Mixscale scores' for cells that receives the same perturbation to quantify the heterogeneity in perturbation strength \
17 | 2. perform a scoring-based weighted differential expression (DE) tests to identify DE genes for each perturbation \
18 | 3. perform different levels of decomposition analysis to identify correlated perturbations and group them into a program \
19 | 4. perform a PCA-based permutation test to extract shared genes for the perturbation programs (program gene signature) \
20 | 5. identify shared and unique signature between two relevant programs \
21 | 6. perform gene set enrichment tests using the program signature for new datasets \
22 | 7. perform module score analyses using the program signature to quantify the program activity in new datasets \
23 | \
24 | The tutorial is divided into two sections. The first section will describe task 1 to 5 using a public Perturb-seq dataset from the Weissman Lab ([Jost et al 2020](https://www.nature.com/articles/s41587-019-0387-5)), which can be downloaded from [GSE132080](https://0-www-ncbi-nlm-nih-gov.brum.beds.ac.uk/geo/query/acc.cgi?acc=GSE132080). The second section will describe task 6 and 7 using the pathway gene lists generated from our study (available at [Zenodo](not_inserted_yet)) and an interferon-beta stimulated human PBMCs dataset (ifnb) from [Kang et al 2017](https://www.nature.com/articles/nbt.4042). This ifnb dataset is available via the SeuratData package (see section 2 below).
25 |
26 |
27 | ### load the packages
28 | ```{r load_package, message=FALSE, warning=FALSE}
29 | options(Seurat.object.assay.version = 'v3')
30 |
31 | library(Seurat)
32 | library(ggridges)
33 | library(stringr)
34 | library(Mixscale)
35 | library(ggplot2)
36 | ```
37 |
38 | ## Section A.
39 | In this section we will focus on how to use Mixscale to analyze Perturb-seq data.
40 |
41 | ### 0. Description of the demo data
42 | The demo dataset from [Jost et al 2020](https://www.nature.com/articles/s41587-019-0387-5) contains CRISPRi Perturb-seq data targeting 25 key genes involved in essential cell biological processes. We will load in the count matrix to create a Seurat object and append the provided meta data to it. \
43 | One special feature of this dataset is that, for each perturbation target gene, there are five different gRNAs designed to target it. One of the gRNA has the perfectly matched sequence for the target region (labelled with "_00"), while the others contain 1~3 nucleotide mismatches so that their perturbation stength is "titrated". We will treat the cells that have the same target gene as the same group in our downstream analyses.
44 |
45 | ```{r load_data, message=FALSE, warning=FALSE, cache=FALSE, echo=FALSE}
46 | # load in the count matrix downloaded from GSE132080
47 | ct_mat = ReadMtx(mtx = "/Users/uqljian5/Desktop/Lab_stuffs_NYGC/Paper_information_gathering/results/GSE132080/GSE132080_10X_matrix.mtx",
48 | cells = "/Users/uqljian5/Desktop/Lab_stuffs_NYGC/Paper_information_gathering/results/GSE132080/GSE132080_10X_barcodes.tsv",
49 | features = "/Users/uqljian5/Desktop/Lab_stuffs_NYGC/Paper_information_gathering/results/GSE132080/GSE132080_10X_genes.tsv")
50 | # load the meta_data
51 | meta_data = read.csv("/Users/uqljian5/Desktop/Lab_stuffs_NYGC/Paper_information_gathering/results/GSE132080/GSE132080_cell_identities.csv")
52 | rownames(meta_data) = meta_data$cell_barcode
53 |
54 | # create a seurat object
55 | seurat_obj = CreateSeuratObject(counts = ct_mat, meta.data = meta_data)
56 | rm(ct_mat, meta_data)
57 |
58 | # retrieve the guide information for each cell
59 | txt = seurat_obj$guide_identity
60 | txt2 = str_extract(txt, "^[^_]+")
61 | txt3 = gsub(pattern = "^[^_]+_", replacement = "", txt)
62 | seurat_obj[['gene']] = txt2
63 | seurat_obj[['gRNA_name']] = txt3
64 | seurat_obj[['cell_type']] = "K562"
65 | rm(txt, txt2, txt3)
66 |
67 | # remove ambiguous cells
68 | seurat_obj = subset(seurat_obj, subset = number_of_cells == 1) # 19594 cells remain
69 | seurat_obj = subset(seurat_obj, subset = guide_identity != '*') # 19587 cells remain
70 |
71 | ```
72 |
73 |
74 | **Click here to see how to generate the Seurat object**
75 | ```{r load_data2, message=FALSE, warning=FALSE, cache=FALSE, eval=FALSE}
76 | # load in the count matrix downloaded from GSE132080
77 | ct_mat = ReadMtx(mtx = "GSE132080/GSE132080_10X_matrix.mtx",
78 | cells = "GSE132080/GSE132080_10X_barcodes.tsv",
79 | features = "GSE132080/GSE132080_10X_genes.tsv")
80 | # load the meta_data
81 | meta_data = read.csv("GSE132080/GSE132080_cell_identities.csv")
82 | rownames(meta_data) = meta_data$cell_barcode
83 |
84 | # create a seurat object
85 | seurat_obj = CreateSeuratObject(counts = ct_mat, meta.data = meta_data)
86 | rm(ct_mat, meta_data)
87 |
88 | # retrieve the guide information for each cell
89 | txt = seurat_obj$guide_identity
90 | txt2 = str_extract(txt, "^[^_]+")
91 | txt3 = gsub(pattern = "^[^_]+_", replacement = "", txt)
92 | seurat_obj[['gene']] = txt2
93 | seurat_obj[['gRNA_name']] = txt3
94 | seurat_obj[['cell_type']] = "K562"
95 | rm(txt, txt2, txt3)
96 |
97 | # remove ambiguous cells
98 | seurat_obj = subset(seurat_obj, subset = number_of_cells == 1) # 19594 cells remain
99 | seurat_obj = subset(seurat_obj, subset = guide_identity != '*') # 19587 cells remain
100 |
101 | ```
102 | **Click here to see how to generate the Seurat object**
75 | ```{r load_data2, message=FALSE, warning=FALSE, cache=FALSE, eval=FALSE}
76 | # load in the count matrix downloaded from GSE132080
77 | ct_mat = ReadMtx(mtx = "GSE132080/GSE132080_10X_matrix.mtx",
78 | cells = "GSE132080/GSE132080_10X_barcodes.tsv",
79 | features = "GSE132080/GSE132080_10X_genes.tsv")
80 | # load the meta_data
81 | meta_data = read.csv("GSE132080/GSE132080_cell_identities.csv")
82 | rownames(meta_data) = meta_data$cell_barcode
83 |
84 | # create a seurat object
85 | seurat_obj = CreateSeuratObject(counts = ct_mat, meta.data = meta_data)
86 | rm(ct_mat, meta_data)
87 |
88 | # retrieve the guide information for each cell
89 | txt = seurat_obj$guide_identity
90 | txt2 = str_extract(txt, "^[^_]+")
91 | txt3 = gsub(pattern = "^[^_]+_", replacement = "", txt)
92 | seurat_obj[['gene']] = txt2
93 | seurat_obj[['gRNA_name']] = txt3
94 | seurat_obj[['cell_type']] = "K562"
95 | rm(txt, txt2, txt3)
96 |
97 | # remove ambiguous cells
98 | seurat_obj = subset(seurat_obj, subset = number_of_cells == 1) # 19594 cells remain
99 | seurat_obj = subset(seurat_obj, subset = guide_identity != '*') # 19587 cells remain
100 |
101 | ```
102 |