單細胞轉錄組學習筆記-14-學習scRNAseq這個R包

劉小澤寫于19.8.8-第三單元前四講：學習scRNAseq這個R包
筆記目的：根據生信技能樹的單細胞轉錄組課程探索smart-seq2技術相關的分析技術
課程鏈接在：http://jm.grazy.cn/index/mulitcourse/detail.html?cid=53

前言

內容在：https://github.com/jmzeng1314/scRNA_smart_seq2/blob/master/scRNA/study_scRNAseq.html

要使用scRNAseq這個R包，首先要對它進行了解，包中內置了Pollen et al. 2014 的數據集（https://www.nature.com/articles/nbt.2967），到19年8月為止，已經有446引用量了。只不過原文完整的數據是 23730 features， 301 samples，這個包中只選取了4種細胞類型：pluripotent stem cells 分化而成的 neural progenitor cells (NPC，神經前體細胞) ，還有 GW16（radial glia，放射狀膠質細胞） 、GW21（newborn neuron，新生兒神經元） 、GW21+3(maturing neuron，成熟神經元) ，它們的關系如下圖（NPC和其他三類存在較大差別）：

要想知道數據怎么處理的，可以看：https://hemberg-lab.github.io/scRNA.seq.datasets/human/tissues/

簡單看看文章怎么說

文章題目是：Low-coverage single-cell mRNA sequencing reveals cellular heterogeneity and activated signaling pathways in developing cerebral cortex

粗略看一下，不要求全文通讀。作者利用低覆蓋度單細胞轉錄組測序，揭示了大腦皮層發育過程的細胞異質性和激活的信號通路

研究背景

大規模的單細胞表達譜測序具有鑒定罕見細胞類型和發育關系的潛力，但需要有效地細胞捕獲和mRNA測序方法。目前使用cell barcoding技術可以實現極低深度的并行測序，但是這種低深度測序有沒有什么弊端還不知道。

文章使用了11個細胞群體的301個細胞進行了低深度測序(大約每個細胞測50000條reads)，發現這種方法也可以和高深度一樣進行細胞類型鑒定和biomarker鑒定。

材料方法

結論一：低覆蓋度和高覆蓋度的測序結果沒太大區別

論點一：利用低覆蓋度得到的spike-in含量和它們已知的濃度相關性很高(r = 0，968)，當每次反應有32拷貝以上的spike-in時，所有的spike-in在所有樣本中都能檢測出，并且差異不大

論點二：利用高覆蓋度檢測到的大部分基因，在低覆蓋度方法中也能檢測到

論點三：只在高覆蓋度方法中檢測到的基因，98%不是高表達(TPM>100)，大多數(63%)是低表達(1<TPM<10)

論點四：對于不同來源的的301個細胞，低覆蓋度和高覆蓋度得到的不同基因表達量估值的平均相關性為0.91

疑問一：但是呢，利用低覆蓋度方法測序得到的低表達量基因(1<TPM<10)，它和高覆蓋度的相關性掉到了0.25，也就是說，在檢測低表達基因方面，低覆蓋度方法還是有局限性的

論點五： 雖然有局限，但是就取樣技術來說，使用微流控(Microfluidic)獲得的10個K562細胞和使用流式細胞術(flow cytometry)得到的一大群細胞，它們得到的表達量相關性很強(r = 0.955)

結論二: 低覆蓋度測序也能區分不同細胞類型

論點一： 先利用PCA看看細胞分群的效果

論點二：看看不同分組的基因表達情況

論點三： 低覆蓋度和高覆蓋度得到的細胞分布很相似，而且PCA得到的貢獻最大的500個基因中，有78%是在低覆蓋度和高覆蓋度中都存在的

然后主要看這個包中的數據

第一次見不會怎么辦？看幫助文檔和Bioconductor相關包的教程

# 先看幫助文檔
library(scRNAseq)
?scRNAseq
# 其中包含了三種數據集：fluidigm、th2、allen，我們用到的是第一個fluidigm
# The dataset fluidigm contains 65 cells from Pollen et al. (2014), each sequenced at high and low coverage (SRA: SRP041736).

也就是說，雖然原文總共做了301個樣本，但這里一共有130個樣本文庫(高覆蓋度、低覆蓋度各65個)

具體數據的處理可以看這個R包的Bioconductor詳細文檔：https://bioconductor.org/packages/release/data/experiment/vignettes/scRNAseq/inst/doc/scRNAseq.html

其中介紹了另外兩個數據集的來歷，瀏覽一下：

  • The dataset th2 contains 96 T helper cells from (Mahata et al. 2014) (ArrayExpress: E-MTAB-2512).
  • The dataset allen contains 379 cells from the mouse visual cortex. This is a subset of the data published in (Tasic et al. 2016) (SRA: SRP061902).

還介紹了數據的預處理：

直接看看數據應該怎么獲取？

這個包中的數據都是以SummarizedExperiment對象形式存放的，那么什么是SummarizedExperiment對象？

使用?assay得到的幫助結果：

The SummarizedExperiment class is a matrix-like container where rows represent features of interest (e.g. genes, transcripts, exons, etc...) and columns represent samples (with sample data summarized as a DataFrame).

以第一個數據fluidigm為例進行讀取：

library(scRNAseq)
data(fluidigm)

> fluidigm
class: SummarizedExperiment 
dim: 26255 130 
metadata(3): sample_info clusters which_qc
assays(4): tophat_counts cufflinks_fpkm rsem_counts rsem_tpm
rownames(26255): A1BG A1BG-AS1 ... ZZEF1 ZZZ3
rowData names(0):
colnames(130): SRR1275356 SRR1274090 ... SRR1275366 SRR1275261
colData names(28): NREADS NALIGNED ... Cluster1 Cluster2

下面就是對這個對象的探索了：

# 例如要提取基因表達量的信息，就用assay函數(注意上面??assays那一行，其中包含了4個結果：tophat_counts、 cufflinks_fpkm、rsem_counts、rsem_tpm)
names(assays(fluidigm))
## [1] "tophat_counts"  "cufflinks_fpkm" "rsem_counts"    "rsem_tpm"

# 默認訪問第一個，也就是原始的表達量tophat_counts
head(assay(fluidigm)[,1:3])
##          SRR1275356 SRR1274090 SRR1275251
## A1BG              0          0          0
## A1BG-AS1          0          0          0
## A1CF              0          0          0
## A2M               0          0          0
## A2M-AS1           0          0          0
## A2ML1             0          0          0

# 如果要得到RPKM值，可以使用assay：
head(assay(fluidigm, 2)[,1:3])
##          SRR1275356 SRR1274090 SRR1275251
## A1BG              0  0.0000000          0
## A1BG-AS1          0  0.3256690          0
## A1CF              0  0.0687904          0
## A2M               0  0.0000000          0
## A2M-AS1           0  0.0000000          0
## A2ML1             0  1.3115300          0

# 或者使用assays
head(assays(fluidigm)$cufflinks_fpkm)

看完表達矩陣，少不了的是樣本的注釋信息，這些就存放在了：colData中

# 包含了太多的信息，如果你直接使用colData(fluidigm)，會得到眼花繚亂的結果
# 于是可以先大體看看有哪些類
names(metadata(fluidigm))
## [1] "sample_info" "clusters"    "which_qc"

# 然后假如我們想看QC相關的信息(也是最常用的)
metadata(fluidigm)$which_qc
##  [1] "NREADS"                       "NALIGNED"                    
##  [3] "RALIGN"                       "TOTAL_DUP"                   
##  [5] "PRIMER"                       "INSERT_SZ"                   
##  [7] "INSERT_SZ_STD"                "COMPLEXITY"                  
##  [9] "NDUPR"                        "PCT_RIBOSOMAL_BASES"         
## [11] "PCT_CODING_BASES"             "PCT_UTR_BASES"               
## [13] "PCT_INTRONIC_BASES"           "PCT_INTERGENIC_BASES"        
## [15] "PCT_MRNA_BASES"               "MEDIAN_CV_COVERAGE"          
## [17] "MEDIAN_5PRIME_BIAS"           "MEDIAN_3PRIME_BIAS"          
## [19] "MEDIAN_5PRIME_TO_3PRIME_BIAS"

# 因此我們想獲得樣本QC信息，就可以
sample_qc <- as.data.frame(colData(fluidigm)[metadata(fluidigm)$which_qc])

探索完，開始基本操作

# 我們要對RSEM得到的count值進行操作，之所以使用floor函數，是因為這個RSEM矩陣存在小數點。猜測：因為RSEM計算表達量是考慮了reads比對到不同基因的情況，這樣的話就不能直接判斷這個reads到底屬于哪個基因，于是就用帶小數的expected count(也就是真實值)表示。其實我們使用的時候，是需要變成整數（raw count）的，于是簡單使用了floor向下取整
mtx <- floor(assay(fluidigm,3))

> mtx[1:3,1:3]
         SRR1275356 SRR1274090 SRR1275251
A1BG              0          0          0
A1BG-AS1          0          0          0
A1CF              0          0          0
> dim(mtx)
[1] 26255   130
看表型信息并過濾

想法是：對每個QC指標都做個箱線圖，這些指標會以向量的形式保存，然后一個一個循環操作，那么會向量循環就用lapply

# 目前QC指標都存在：colnames(sample_qc)中，一共19個；使用更容易調參數的ggboxplot
library(ggpubr)
box <- lapply(colnames(sample_qc),function(i) {
  dat <-  sample_qc[,i,drop=F] 
  dat$all_cells="all_cells"
  ggboxplot(dat,x=dat[,2],y=i,
            xlab=F,add = "jitter")
})
plot_grid(plotlist=box, ncol=5 )

然后利用表型信息對樣本進行過濾：

# 從QC數據中挑選一些指標，作為過濾條件
choose_anno <-  colnames(sample_qc[,c(1:9,11:16,18,19)])

# 下面就是將一個個的QC條件進行細胞的過濾，如果細胞滿足設定的QC過濾條件，就為1；否則為0；并且用cbind按列組合在一起
filter <- lapply(choose_anno,function(i) {
  # 寫循環時可以先用一個值作為測試：例如 i=choose_anno[1]
  dat <-  sample_qc[,i]  
  dat <- abs(log10(dat))
  fivenum(dat)
  (up <- mean(dat)+2*sd(dat))
  (down <- mean(dat)- 2*sd(dat) ) 
  valid <- ifelse(dat > down & dat < up, 1,0 ) 
})
filter <- do.call(cbind,filter)

# 得到了列為QC，行為細胞的過濾結果，那么就將QC條件全部為1的細胞挑出來(也就是找全部為1的行)
choosed_cells <- apply(filter,1,function(x) all(x==1))

# 進行對比：原來的細胞
> table(colData(fluidigm)$Biological_Condition)

  GW16   GW21 GW21+3    NPC 
    52     16     32     30 
# 過濾后的細胞
> table(colData(fluidigm)[choosed_cells,]$Biological_Condition)

  GW16   GW21 GW21+3    NPC 
    36     11     23     29

# 將表達矩陣進行過濾
mtx <- mtx[,choosed_cells]
> dim(mtx)
[1] 26255    99
看基因表達信息
> fivenum(apply(mtx,1,function(x) sum(x>0) ))
     A1CF     OR8G1 LINC01003    MRPS36     YWHAZ 
        0         0         4        26        99 
# 看到至少有25%的基因表達量為0.那么具體有多少個呢？可以看看：
choosed_genes=apply(mtx,1,function(x) sum(x>0) )>0
> table(choosed_genes)

FALSE  TRUE 
 9496 16759 
# 看到有9000多個基因在所有細胞中都沒有表達量(可能原因：原文分析的確實是2w多個基因，但他是在300多個細胞中分析的，我們這個包里過濾后只剩下99個細胞，所以存在很多基因不在這部分細胞中表達，因此需要去掉)
boxplot(apply(mtx,1,function(x) sum(x>0) ))
              
# 最后根據基因表達量對矩陣進行過濾
mtx <- mtx[choosed_genes,]

從下面這個箱線圖中也可以看到，很少有基因在99個過濾后的細胞中都有表達，大部分基因還是在部分細胞中表達量為0 (這也是單細胞一個很特殊的現象：dropout情況，意思就是真實情況下基因是有表達量的，但技術問題沒有檢測到)

看細胞間基因表達量相關性
# 都要基于CPM標準化數值，并做一個備份
mtx <- log2(edgeR::cpm(mtx) + 1)
mtx[1:4, 1:4]
mtx_back <- mtx

# 對相關性進行初步的可視化
exprSet <- mtx_back
> dim(exprSet)
[1] 16759    99

pheatmap::pheatmap(cor(exprSet))
# 注意：cor函數計算的是列與列間的相關系數

需要加上分組的信息：

# 使用細胞過濾后的分組信息(GW16：36  GW21：11  GW21+3：23  NPC：29）         
group_list <- colData(fluidigm)[choosed_cells,]$Biological_Condition
tmp <- data.frame(g = group_list)
rownames(tmp) <-  colnames(exprSet)
# 組內相似性高于組間，并且看到NPC組和其他組差異更大
pheatmap::pheatmap(cor(exprSet), annotation_col = tmp)
好，接著設置閾值對表達矩陣過濾
# 這一次設置閾值為5，表示至少要滿足基因在5個細胞中的表達量都大于1
exprSet = exprSet[apply(exprSet, 1, function(x) sum(x > 1) > 5), ]
> dim(exprSet)
[1] 11337    99
過濾完，按照mad統計方法取前500個表達量變化最大的基因
# 絕對中位差來估計方差,先計算出數據與它們的中位數之間的偏差，然后這些偏差的絕對值的中位數就是mad
exprSet <-  exprSet[names(sort(apply(exprSet, 1, mad), decreasing = T)[1:500]), ]
> dim(exprSet)
[1] 500  99

# 對組間差異最大的基因再進行相關性分析
M <-cor(log2(exprSet + 1))
tmp <- data.frame(g = group_list)
rownames(tmp) <-  colnames(M)
pheatmap::pheatmap(M, annotation_col = tmp)

小結：NPC跟另外的GW細胞群可以區分的很好，但是GW本身的3個小群體并沒有那么好的區分度。后來簡單選取mad前500的基因重新計算，也沒有改善；另外可以看到每個細胞測了兩次(圖中對角線中有紅色和橙色，表示兩次不同深度)

表達矩陣簡單的層次聚類

mtx <- mtx_back
hc <- hclust(dist(t(mtx))) # dist以行為輸入
plot(hc,labels = FALSE)

clus <-  cutree(hc, 4) #對hclust()函數的聚類結果進行剪枝，即選擇輸出指定類別數的系譜聚類結果。
group_list <-  as.factor(clus) ##轉換為因子屬性
> table(group_list) ##統計頻數
group_list
 1  2  3  4 
29 25 39  6 

filtered_anno <- colData(fluidigm)[choosed_cells,]$Biological_Condition

> table(group_list,filtered_anno)   
          filtered_anno
group_list GW16 GW21 GW21+3 NPC
         1    0    0      0  29
         2   20    3      2   0
         3   15    8     16   0
         4    1    0      5   0
# 結果看到：NPC、GW21+3這兩個利用普通的層次聚類還是可以區分開，但是GW16、GW21就不太能區分了

最常規的PCA降維結果

算法很多，比如：主成分分析PCA、多維縮放(MDS)、線性判別分析(LDA)、等度量映射(Isomap)、局部線性嵌入(LLE)、t-SNE、Deep Autoencoder Networks
以下會采用PCA 和 t-SNE

mtx <- mtx_back
mtx <- t(mtx) # PCA也是對行操作：需要先轉置一下，讓行為樣本
mtx <- as.data.frame(mtx)
plate <- filtered_anno # 這里定義分組信息
mtx <-  cbind(mtx, plate) # 添加分組信息

> mtx[1:4, 1:4]
           A1BG A1BG-AS1      A2M A2M-AS1
SRR1274090    0        0 0.000000       0
SRR1275287    0        0 4.216768       0
SRR1275364    0        0 0.000000       0
SRR1275269    0        0 3.552694       0
> table(mtx$plate)

  GW16   GW21 GW21+3    NPC 
    36     11     23     29 

# 進行PCA操作(實際是降維，映射到二維坐標)
mtx.pca <- PCA(mtx[, -ncol(mtx)], graph = FALSE)

> head(mtx.pca$var$coord) ## 每個主成分的基因重要性占比
               Dim.1       Dim.2       Dim.3        Dim.4         Dim.5
A1BG      0.19046450  0.09601240 -0.17840553 -0.001507970 -0.0006057691
A1BG-AS1 -0.02510451  0.29821319  0.03571804  0.020001929 -0.0105727109
A2M       0.03403042  0.25458727  0.24264958  0.228512329  0.5414019044
A2M-AS1   0.23140893  0.02900348 -0.07952678  0.356461354  0.1283450099
A2ML1    -0.15776536  0.13831288  0.10065788  0.004060288 -0.0353422367
A2MP1    -0.04068586 -0.05584736 -0.02857416  0.018287992  0.0069603680
> head(mtx.pca$ind$coord) ## 每個細胞的前5個主成分取值。
                Dim.1      Dim.2      Dim.3      Dim.4      Dim.5
SRR1274090  40.251912 -13.231641 -12.358891 -20.038100 -12.704947
SRR1275287   1.196637  15.386256  30.566235  14.262858  -4.852418
SRR1275364 -34.731051 -14.782146  -7.716928   7.046918   1.951473
SRR1275269  21.760471   3.307309  17.985263 -18.382512   9.270646
SRR1275263  -3.313968 -15.856721   8.929275 -36.358830  20.275875
SRR1274117  59.378486  16.453551  -5.098901  56.245455  19.257598

PCA函數返回的結果如下：現在細胞在行，基因在列，所以細胞是ind，基因是var

# 進行PCA可視化
fviz_pca_ind(
  mtx.pca,
  #repel =T,
  geom.ind = "point",
  # show points only (nbut not "text")
  col.ind = mtx$plate,
  # color by groups
  #palette = c("#00AFBB", "#E7B800"),
  addEllipses = TRUE,
  # Concentration ellipses
  legend.title = "Groups"
)

小結：NPC跟另外的GW細胞群可以區分的很好，但是GW本身的3個小群體并沒有那么好的區分度

進階一點的tSNE降維

這里先選取PCA后的主成分，然進行tSNE；其實還可以選取變化高的基因，顯著差異基因等等

# 選取前面PCA分析的5個主成分。
tsne_mtx <- mtx.pca$ind$coord
# Set a seed if you want reproducible results
set.seed(42)
library(Rtsne) 
# 如果使用原始表達矩陣進行 tSNE耗時會很久
# 如果出現Remove duplicates before running TSNE 則check_duplicated = FALSE
# tsne_out <- Rtsne(dat_matrix,pca=FALSE,perplexity=30,theta=0.0, check_duplicates = FALSE) 

# Run TSNE
tsne_out <- Rtsne(tsne_mtx,perplexity=10)
plate <- filtered_anno # 這里定義分組信息
plot(tsne_out$Y,col= rainbow(4)[as.numeric(as.factor(plate))], pch=19)

降維后呢？

降維和聚類不是一回事，各有各的算法、參數，比如降維我們常用PCA、tsne，聚類就有kmeans、dbscan

> # 前面我們的層次聚類是針對全部表達矩陣，tsne選取前面PCA分析的5個主成分，因此為了節省計算量，選取tsne_out$Y這個結果
> head(tsne_out$Y)
          [,1]        [,2]
[1,]  4.855236 -26.9704714
[2,]  0.179925  -0.5475169
[3,]  6.256713  24.9241040
[4,]  2.471635 -20.2250523
[5,]  2.615960 -12.6056267
[6,] -2.384375 -22.3821087

opt_tsne=tsne_out$Y

> table(kmeans(opt_tsne,centers = 4)$clust)

 1  2  3  4 
31 24 24 20 

plot(opt_tsne,  col=kmeans(opt_tsne,centers = 4)$clust, pch=19, xlab="tSNE dim 1", ylab="tSNE dim 2")

# 換一種dbscan
library(dbscan)
plot(opt_tsne,  col=dbscan(opt_tsne,eps=3.1)$cluster, pch=19, xlab="tSNE dim 1", ylab="tSNE dim 2")

> table(dbscan(opt_tsne,eps=3.1)$cluster)

 0  1  2  3  4 
 2 22 38 31  6

進行一個比較：

# 比較兩個聚類算法區別
> table(kmeans(opt_tsne,centers = 4)$clust,dbscan(opt_tsne,eps=3.1)$cluster)
   
     0  1  2  3  4
  1  0  0 38  0  6
  2  0  0  0 16  0
  3  0  0  0 15  0
  4  2 22  0  0  0

下面使用M3Drop包處理單細胞數據

第一步 構建對象

## 重新加載數據
rm(list=ls())
data(fluidigm)
# names(assays(fluidigm))
counts <- floor(assay(fluidigm, 3))
dim(counts)

## 過濾
sample_qc <- as.data.frame(colData(fluidigm)[metadata(fluidigm)$which_qc])
choose_anno <-  colnames(sample_qc[,c(1:9,11:16,18,19)])
filter <- lapply(choose_anno,function(i) {
  # i=choose_anno[1]
  dat <-  sample_qc[,i]  
  dat <- abs(log10(dat))
  fivenum(dat)
  (up <- mean(dat)+2*sd(dat))
  (down <- mean(dat)- 2*sd(dat) ) 
  valid <- ifelse(dat > down & dat < up, 1,0 ) 
})

filter <- do.call(cbind,filter)
choosed_cells <- apply(filter,1,function(x) all(x==1))

counts <- counts[,choosed_cells]

## 開始M3Drop分析
library(M3Drop) 
Normalized_data <- M3DropCleanData(counts, 
                                   labels = colData(fluidigm)[choosed_cells,]$Biological_Condition, 
                                   is.counts=TRUE, min_detected_genes=2000)

> dim(Normalized_data$data)
[1] 13405    97
                       
## 檢查
> str(Normalized_data) #只返回了一個list，而不是S4對象
List of 2
 $ data  : num [1:13405, 1:97] 0 0 0 0 0 0 0 0 0 0 ...
  ..- attr(*, "dimnames")=List of 2
  .. ..$ : chr [1:13405] "A1BG" "A2M" "A2ML1" "AAAS" ...
  .. ..$ : chr [1:97] "SRR1274090" "SRR1275287" "SRR1275364" "SRR1275269" ...
 $ labels: chr [1:97] "NPC" "GW21+3" "GW16" "GW21" ...

第二步 表達矩陣檢驗--Michaelis-Menten算法

具體的算法可以不用了解太深

fits <- M3DropDropoutModels(Normalized_data$data)

## 查看檢驗的結果
## Sum absolute residuals
data.frame(MM=fits$MMFit$SAr, Logistic=fits$LogiFit$SAr,
           DoubleExpo=fits$ExpoFit$SAr) 
#    MM Logistic DoubleExpo
1 1651     1646       4033


## Sum absolute residuals
data.frame(MM=fits$MMFit$SAr, Logistic=fits$LogiFit$SAr,
           DoubleExpo=fits$ExpoFit$SAr) 
#   MM Logistic DoubleExpo
1 403      345       1962

第三步 找差異基因

這里需要注意：如果提示找不到M3DropDifferentialExpression這個函數，那么可能由于安裝的M3Drop包版本是舊版，新版對應的函數是：M3DropFeatureSelection

DE_genes <-  M3DropFeatureSelection(Normalized_data$data, 
                                         mt_method="fdr", mt_threshold=0.01)
> dim(DE_genes)
[1] 182   4
> head(DE_genes)
           Gene effect.size      p.value      q.value
IGFBPL1 IGFBPL1    13.94805 1.790836e-21 4.801233e-18
DLK1       DLK1    11.66363 1.104816e-22 4.936685e-19
BCAT1     BCAT1    10.97600 6.335191e-31 8.492323e-27
CA12       CA12    10.94265 1.020863e-08 3.110152e-06
ZNF30     ZNF30    10.78263 2.503772e-06 3.813985e-04
FOS         FOS    10.01977 1.389763e-12 9.314889e-10

第四步 差異基因畫熱圖

# 就是看一下差異基因在不同細胞類型的表達分布
par(mar=c(1,1,1,1)) 
heat_out <- M3DropExpressionHeatmap(DE_genes$Gene, Normalized_data$data, 
                                    cell_labels = Normalized_data$labels)

第五步 重新聚類，找marker

同樣的，如果函數M3DropGetHeatmapCellClusters找不到，就替換成M3DropGetHeatmapClusters，因為作者時刻在改函數名字，有困難找：https://bioconductor.org/packages/release/bioc/vignettes/M3Drop/inst/doc/M3Drop_Vignette.R

# 重新聚類
cell_populations <- M3DropGetHeatmapClusters(heat_out, k=4)
# 重聚類得到的和自帶的表型數據比較
> table(cell_populations,Normalized_data$labels)
                
cell_populations GW16 GW21 GW21+3 NPC
               1    0    0      0  29
               2   14    8     19   0
               3    4    1      2   0
               4   16    2      2   0

# 找marker
library("ROCR") 
marker_genes <- M3DropGetMarkers(Normalized_data$data, cell_populations)

第六步 可以看每個分類的marker基因

# 比如想看新得到的第4組的marker基因
> head(marker_genes[marker_genes$Group==4,],10) 
             AUC Group         pval
ADGRV1 0.9707792     4 1.831217e-11
TFAP2C 0.9451299     4 1.885637e-11
EGR1   0.9409091     4 1.159852e-09
PLCE1  0.9233766     4 7.676760e-11
FOS    0.9058442     4 1.806229e-08
SLC1A3 0.9048701     4 1.542660e-09
AASS   0.9032468     4 3.136961e-08
ITGB8  0.8886364     4 8.823909e-08
BCAN   0.8844156     4 1.513264e-12
NFIA   0.8831169     4 7.724889e-08

# 或者想知道某個marker基因的分配位置
> marker_genes[rownames(marker_genes)=="FOS",] 
          AUC Group         pval
FOS 0.9058442     4 1.806229e-08

當然，可以挑選一些marker基因進行作圖

# 挑選的代碼
choosed_marker_genes=as.character(unlist(lapply(split(marker_genes,marker_genes$Group), function(x) (rownames(head(x,20))))))

# 看不懂？沒關系，可以拆解~
# 其中最核心的是split(marker_genes,marker_genes$Group)，它返回什么東西，用str()查看就對了
> str(split(marker_genes,marker_genes$Group))
List of 4
 $ 1:'data.frame':  5370 obs. of  3 variables:
  ..$ AUC  : num [1:5370] 1 0.998 0.998 0.997 0.993 ...
  ..$ Group: chr [1:5370] "1" "1" "1" "1" ...
  ..$ pval : num [1:5370] 8.68e-22 1.20e-17 1.04e-14 1.18e-14 1.81e-14 ...
 $ 2:'data.frame':  1844 obs. of  3 variables:
  ..$ AUC  : num [1:1844] 0.99 0.936 0.933 0.927 0.927 ...
  ..$ Group: chr [1:1844] "2" "2" "2" "2" ...
# 還有兩段省略............

# 不難看出，它的作用是根據分組信息（marker_genes$Group），將marker_genes分成了4個部分，共同組成一個列表。現在我們可以最粗略地選出每個分組中的前20基因(當然，后續可以自定義，根據AUC和P值來挑選)
# 對列表循環用lapply，要做的事情就是挑出前20=》rownames(head(x,20))
                                                
# 接下來作圖就容易了
par(mar=c(1,1,1,1)) 
heat_out <- M3DropExpressionHeatmap(choosed_marker_genes, Normalized_data$data, cell_labels =  cell_populations)
最后編輯于 ：
?著作權歸作者所有,轉載或內容合作請聯系作者
平臺聲明：文章內容（如有圖片或視頻亦包括在內）由作者上傳并發布，文章內容僅代表作者本人觀點，簡書系信息發布平臺，僅提供信息存儲服務。
  • 人面猴
    序言：七十年代末，一起剝皮案震驚了整個濱河市，隨后出現的幾起案子，更是在濱河造成了極大的恐慌，老刑警劉巖，帶你破解...
    沈念sama閱讀 228,606評論 6贊 533
  • 死咒
    序言：濱河連續發生了三起死亡事件，死亡現場離奇詭異，居然都是意外死亡，警方通過查閱死者的電腦和手機，發現死者居然都...
    沈念sama閱讀 98,582評論 3贊 418
  • 救了他兩次的神仙讓他今天三更去死
    文/潘曉璐 我一進店門，熙熙樓的掌柜王于貴愁眉苦臉地迎上來，“玉大人，你說我怎么就攤上這事。” “怎么了？”我有些...
    開封第一講書人閱讀 176,540評論 0贊 376
  • 道士緝兇錄：失蹤的賣姜人
    文/不壞的土叔 我叫張陵，是天一觀的道長。 經常有香客問我，道長，這世上最難降的妖魔是什么？ 我笑而不...
    開封第一講書人閱讀 63,028評論 1贊 314
  • ?港島之戀（遺憾婚禮）
    正文 為了忘掉前任，我火速辦了婚禮，結果婚禮上，老公的妹妹穿的比我還像新娘。我一直安慰自己，他們只是感情好，可當我...
    茶點故事閱讀 71,801評論 6贊 410
  • 惡毒庶女頂嫁案：這布局不是一般人想出來的
    文/花漫 我一把揭開白布。 她就那樣靜靜地躺著，像睡著了一般。 火紅的嫁衣襯著肌膚如雪。 梳的紋絲不亂的頭發上，一...
    開封第一講書人閱讀 55,223評論 1贊 324
  • 城市分裂傳說
    那天，我揣著相機與錄音，去河邊找鬼。 笑死，一個胖子當著我的面吹牛，可吹牛的內容都是我干的。 我是一名探鬼主播，決...
    沈念sama閱讀 43,294評論 3贊 442
  • 雙鴛鴦連環套：你想象不到人心有多黑
    文/蒼蘭香墨 我猛地睜開眼，長吁一口氣：“原來是場噩夢啊……” “哼！你這毒婦竟也來了？” 一聲冷哼從身側響起，我...
    開封第一講書人閱讀 42,442評論 0贊 289
  • 萬榮殺人案實錄
    序言：老撾萬榮一對情侶失蹤，失蹤者是張志新（化名）和其女友劉穎，沒想到半個月后，有當地人在樹林里發現了一具尸體，經...
    沈念sama閱讀 48,976評論 1贊 335
  • ?護林員之死
    正文 獨居荒郊野嶺守林人離奇死亡，尸身上長有42處帶血的膿包…… 初始之章·張勛 以下內容為張勛視角 年9月15日...
    茶點故事閱讀 40,800評論 3贊 354
  • ?白月光啟示錄
    正文 我和宋清朗相戀三年，在試婚紗的時候發現自己被綠了。 大學時的朋友給我發了我未婚夫和他白月光在一起吃飯的照片。...
    茶點故事閱讀 42,996評論 1贊 369
  • 活死人
    序言：一個原本活蹦亂跳的男人離奇死亡，死狀恐怖，靈堂內的尸體忽然破棺而出，到底是詐尸還是另有隱情，我是刑警寧澤，帶...
    沈念sama閱讀 38,543評論 5贊 360
  • ?日本核電站爆炸內幕
    正文 年R本政府宣布，位于F島的核電站，受9級特大地震影響，放射性物質發生泄漏。R本人自食惡果不足惜，卻給世界環境...
    茶點故事閱讀 44,233評論 3贊 347
  • 男人毒藥：我在死后第九天來索命
    文/蒙蒙 一、第九天 我趴在偏房一處隱蔽的房頂上張望。 院中可真熱鬧，春花似錦、人聲如沸。這莊子的主人今日做“春日...
    開封第一講書人閱讀 34,662評論 0贊 26
  • 一樁弒父案，背后竟有這般陰謀
    文/蒼蘭香墨 我抬頭看了看天上的太陽。三九已至，卻和暖如春，著一層夾襖步出監牢的瞬間，已是汗流浹背。 一陣腳步聲響...
    開封第一講書人閱讀 35,926評論 1贊 286
  • 情欲美人皮
    我被黑心中介騙來泰國打工， 沒想到剛下飛機就差點兒被人妖公主榨干…… 1. 我叫王不留，地道東北人。 一個月前我還...
    沈念sama閱讀 51,702評論 3贊 392
  • 代替公主和親
    正文 我出身青樓，卻偏偏與公主長得像，于是被迫代替她去往敵國和親。 傳聞我的和親對象是個殘疾皇子，可洞房花燭夜當晚...
    茶點故事閱讀 47,991評論 2贊 374