HNSCC数据分析-GSE2379-GPL830-GPL91
五月份的学徒专注于GEO数据库里面的表达量芯片数据处理,主要的难点是表达量矩阵获取和探针的基因名字转换,合理的分组后就是标准的差异分析,富集分析。主要是参考我八年前的笔记:
数据集介绍
GEO链接:https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=GSE2379
芯片平台:https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=GPL91 [HG_U95A] Affymetrix Human Genome U95A Array
https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=GPL8300 [HG_U95Av2] Affymetrix Human Genome U95 Version 2 Array
样品列表:
GSM44794 VADS_0103_T_NM
GSM44799 VADS_01047_N
GSM44802 VADS_01047_T_E
GSM44806 VADS_0118_T_LR
GSM44809 VADS_0135_T_M
GSM44810 VADS_0165_T_M
GSM44811 VADS_0167_T_NM
GSM44812 VADS_0203_T_M
GSM44813 VADS_0215_T_M
GSM44814 VADS_0218_T_M
...
文章是:Identification of genes associated with tumorigenesis and metastatic potential of hypopharyngeal cancer by microarray analysis. Oncogene 2004 Apr 1;23(14):2484-98. PMID: 14676830 https://www.ncbi.nlm.nih.gov/pubmed/14676830
核心步骤
R包加载
rm(list = ls())
library(AnnoProbe)
library(GEOquery)
library(ggplot2)
library(ggstatsplot)
library(reshape2)
library(patchwork)
获取并且检查表达量矩阵
主要是得是否需要log
# 获取表达量矩阵
gse_number <- 'GSE2379'
gset <- geoChina(gse_number)
a=gset[[1]]
dat1=exprs(a)
dim(dat1)
a@annotation
b=gset[[2]]
dat2=exprs(b)
dim(dat2)
b@annotation
gpl_number = paste(a@annotation,b@annotation,sep = "_");gpl_number
dat1 = dat1[intersect(rownames(dat1),rownames(dat2)),]
dat2 = dat2[intersect(rownames(dat1),rownames(dat2)),]
dat = cbind(dat1,dat2)
# 检查,判断需不需要取log
dat[1:4,1:4]
dat = log2(dat)
boxplot(dat[,1:4],las=2)
library(limma)
dat=normalizeBetweenArrays(dat)
# 画图,使用ggplot需宽数据变长数据
class(dat)
data <- as.data.frame(dat)
data <- melt(data)
head(data)
title <- paste (gse_number, "/", gpl_number, sep ="")
p1 <- ggplot(data,aes(x=variable,y=value))+
geom_boxplot()+
theme_ggstatsplot()+
theme(panel.grid = element_blank(),
axis.text=element_text(size=10,face = 'bold'),
axis.text.x=element_text(angle=90),
plot.title = element_text(hjust = 0.5,size =15))+
xlab('')+
ylab('')+
ggtitle(title)
p1
可以看到,处理前后我们的表达量矩阵的表达量范围箱线图如下所示:
根据生物学背景及研究目的人为分组
library(stringr)
pd1=pData(a)
pd2=pData(b)
#通过查看说明书知道取对象a里的临床信息用pData
group_list1=ifelse(grepl('Normal',pd1$source_name_ch1),'control','HNSCC')
group_list2=ifelse(grepl('Normal',pd2$source_name_ch1),'control','HNSCC')
group_list = factor(c(group_list1,group_list2),levels = c('control','HNSCC'));table(group_list)
为了演示方便,我们这里仅仅是区分"HNSCC"和“control”。
probe_id 和symbol的转换至表达矩阵
获取芯片注释信息
代码如下:
gpl_number
ids1 = idmap("GPL8300")
ids2 = idmap("GPL91")
ids1 = ids1[ids1$probe_id == intersect(ids1[,1],ids2[,1]),]
ids2 = ids2[ids2$probe_id == intersect(ids1[,1],ids2[,1]),]
ids =ids1
#所以ids1和ids2用哪个都行
可以看到此芯片的探针与基因ID或者symbol的对应关系如下所示:
> head(ids)
probe_id symbol
50246 1000_at MAPK3
50247 1001_at TIE1
50248 1002_f_at CYP2C19
50249 1003_s_at CXCR5
50250 1004_at CXCR5
50251 1005_at DUSP1
探针基因ID对应以及去冗余
代码如下:
library(tidyr)
library(dplyr)
library(stringr)
#接下来,使探针与基因symbol一一对应
ids=as.data.frame(ids)
table(rownames(dat) %in% ids$probe_id)
dat=dat[rownames(dat) %in% ids$probe_id,]
ids=ids[match(rownames(dat),ids$probe_id),]
ids$probe_id=as.character(ids$probe_id)
rownames(dat)=ids$probe_id
ids=ids[ids$probe_id %in% rownames(dat),]
dat=dat[ids$probe_id,]
#下一步是:基因symbol去冗余-按照表达量最大值筛选
ids$median=apply(dat,1,median)
#ids新建median这一列,列名为median,同时对dat这个矩阵按行操作,取每一行的中位数,将结果给到median这一列的每一行
ids=ids[order(ids$symbol,ids$median,decreasing = T),]
#对ids$symbol按照ids$median中位数从大到小排列的顺序排序,将对应的行赋值为一个新的ids
ids=ids[!duplicated(ids$symbol),]#将symbol这一列取取出重复项,'!'为否,即取出不重复的项,去除重复的gene ,保留每个基因最大表达量结果s
#获得去冗余之后的dat/exp
dat=dat[ids$probe_id,] #新的ids取出probe_id这一列,将dat按照取出的这一列中的每一行组成一个新的dat
#把ids的symbol这一列中的每一行给dat作为dat的行名
rownames(dat)=ids$symbol
table(group_list)
最后得到了表达量矩阵如下所示:
> dat[1:4,1:4] #保留每个基因ID第一次出现的信息
GSM44794 GSM44806 GSM44810 GSM44811
ZZZ3 9.596521 8.811690 8.757934 9.441529
ZZEF1 8.961444 8.386062 9.018706 7.834171
ZYX 11.655007 11.279106 11.409222 11.224499
ZWINT 9.822704 10.807418 9.362317 10.333218
以及最简单的2分组,如下所示:
>table(group_list)
group_list
control HNSCC
4 34
保存为R数据文件:step1-output.Rdata
标准步骤之质控
得到标准的3张图,包括主成分分析,高变基因的表达量热图,样品相关性热图
## 下面是画PCA的必须操作,需要看说明书。
exp <- dat
exp=t(exp)#画PCA图时要求是行名时样本名,列名时探针名,因此此时需要转换
exp=as.data.frame(exp)#将matrix转换为data.frame
library("FactoMineR")#画主成分分析图需要加载这两个包
library("factoextra")
dat.pca <- PCA(exp , graph = FALSE)#现在exp最后一列是group_list,需要重新赋值给一个dat.pca,这个矩阵是不含有分组信息的
# 画图,主成分分析图p2
this_title <- paste0(gse_number,'_PCA')
p2 <- fviz_pca_ind(dat.pca,
geom.ind = "point", # show points only (nbut not "text")
col.ind = group_list, # color by groups
palette = "Dark2",
addEllipses = TRUE, # Concentration ellipses
legend.title = "Groups")+
ggtitle(this_title)+
theme_ggstatsplot()+
theme(plot.title = element_text(size=15,hjust = 0.5))
p2
# 下面是1000_sd热图
library(pheatmap)
cg=names(tail(sort(apply(dat,1,sd)),1000))#apply按行('1'是按行取,'2'是按列取)取每一行的方差,从小到大排序,取最大的1000个
n=t(scale(t(dat[cg,])))
n[n>2]=2
n[n< -2]= -2
n[1:4,1:4]
ac=data.frame(Group=group_list)
rownames(ac)=colnames(n)
# 画图,高变基因的表达量热图p3
p3 <- pheatmap::pheatmap(n,
show_colnames =F,
show_rownames = F,
main = gse_number,
annotation_col=ac,
breaks = seq(-3,3,length.out = 100))#因为已经手动设置了表达量最大值,所以,可以不用设置break
p3
# 画图,样品相关性热图p4
colD=data.frame(Group=group_list)
exprSet=t(exp)
rownames(colD)=colnames(exprSet)#问题-exprSet设置成转置后的exp
p4 <- pheatmap::pheatmap(cor(exprSet),#热图对样本-列 操作
annotation_col = colD,
show_rownames = F,
show_colnames = F,
main = gse_number
)
p4
出图如下:
标准步骤之limma差异分析
代码如下:
library(limma)
design=model.matrix(~factor( group_list ))
fit=lmFit(dat,design)
fit=eBayes(fit)
options(digits = 4) #设置全局的数字有效位数为4
deg = topTable(fit,coef=2,adjust='BH', n=Inf)
#非常重要的一步,记得检查差异分析是否正确
boxplot(dat[rownames(deg)[1],]~group_list )
deg[1,]
差异分析结果前10行如下所示:
> deg[1:10,]
logFC AveExpr t P.Value adj.P.Val B
MMP1 6.935 11.784 14.506 1.947e-17 1.669e-13 28.69
AGFG2 -3.247 6.510 -11.559 2.907e-14 1.245e-10 22.02
CAPN5 -3.768 6.238 -9.753 4.397e-12 1.142e-08 17.32
COL4A1 3.426 11.582 9.687 5.329e-12 1.142e-08 17.13
EMP1 -4.196 9.768 -9.221 2.090e-11 2.882e-08 15.84
PLAUR 3.486 11.456 9.215 2.126e-11 2.882e-08 15.82
ITGA1 2.976 8.334 9.180 2.354e-11 2.882e-08 15.73
PTPN14 2.542 7.672 9.106 2.937e-11 3.146e-08 15.52
LOXL2 3.081 8.678 8.639 1.197e-10 1.139e-07 14.18
MMP12 3.993 10.371 8.586 1.404e-10 1.180e-07 14.03
有了差异分析就可以进行标准的可视化,包括火山图和上下调的差异基因热图
nrDEG=deg
head(nrDEG)
attach(nrDEG)
plot(logFC,-log10(P.Value))#简单画图看一下
df=nrDEG
df$v= -log10(P.Value) #df新增加一列'v',作为新的绘图参数,值为-log10(P.Value)
#设定上下调基因
df$g=ifelse(df$P.Value>0.05,'stable',
ifelse( df$logFC >2,'up',
ifelse( df$logFC < -2,'down','stable') )
)
#统计上下调基因数量
table(df$g)
#给绘制火山图用的数据新增一列symbol
df$name=rownames(df)
head(df)
logFC_t = 2
#设置可循环使用的plot标题
this_tile <- paste0('Cutoff for logFC is ',round(logFC_t,3),
'\nThe number of up gene is ',nrow(df[df$g == 'up',]) ,
'\nThe number of down gene is ',nrow(df[df$g == 'down',])
)
#画图,火山图p5
p5 <- ggplot(data = df,
aes(x = logFC,
y = -log10(P.Value))) +
geom_point(alpha=0.6, size=1.5,
aes(color=g)) +
ylab("-log10(Pvalue)")+
scale_color_manual(values=c("#34bfb5", "#828586","#ff6633"))+
geom_vline(xintercept= 0,lty=4,col="grey",lwd=0.8) +
xlim(-3, 3)+
theme_classic()+
ggtitle(this_tile )+
theme(plot.title = element_text(size=12,hjust = 0.5),
legend.title = element_blank(),
)
p5
#热图
library(pheatmap)
x=deg$logFC
names(x)=rownames(deg)
cg=c(names(head(sort(x),100)),
names(tail(sort(x),100)))#对x进行从小到大排列,取前100及后100,并取其对应的探针名,作为向量赋值给cg
n=t(scale(t(dat[cg,])))
n[n>2]=2
n[n< -2]= -2
n[1:4,1:4]
pheatmap(n,show_colnames =F,show_rownames = F)
ac=data.frame(group=group_list)
rownames(ac)=colnames(n)
# 画图,上下调的差异基因热图p6
p6 <- pheatmap(n,show_colnames =F,
show_rownames = F,
cluster_cols = T,
main = gse_number,
annotation_col=ac)
p6
出图如下:
标准步骤之生物学功能数据库注释
我们这里不根据任何武断的阈值来区分统计学显著的上下调基因,而是直接根据基因的变化情况排序进行gsea分析,而且仅仅是展示kegg这个生物学功能数据库的注释情况!
gsea分析需要基因的ENTREZID,需要根据物种进行转换
# 加ENTREZID列,用于富集分析(symbol转entrezid,然后inner_join)
deg$symbol=rownames(deg)
library(org.Hs.eg.db)
library(clusterProfiler)
s2e <- bitr(deg$symbol,
fromType = "SYMBOL",
toType = "ENTREZID",
OrgDb = org.Hs.eg.db)#人
#bitr()用于SYMBOL转ENTREZID
#其他物种http://bioconductor.org/packages/release/BiocViews.html#___OrgDb
dim(deg)
dim(s2e)
setdiff(deg$symbol,s2e$SYMBOL)
DEG <- inner_join(deg,s2e,by=c("symbol"="SYMBOL"))
gsea富集
library(dplyr)
library(ggplot2)
geneList=DEG$logFC
names(geneList)=DEG$ENTREZID
geneList=sort(geneList,decreasing = T)
head(geneList)
library(clusterProfiler)
kk_gse <- gseKEGG(geneList = geneList,
organism = 'hsa',#按需替换
#nPerm = 1000,
minGSSize = 10,
pvalueCutoff = 0.9,
verbose = FALSE)
tmp=kk_gse@result
dim(tmp)
kk=DOSE::setReadable(kk_gse, OrgDb='org.Hs.eg.db',keyType='ENTREZID')#按需替换
#DOSE::setReadable():mapping geneID to gene Symbol
tmp=kk@result
dim(tmp)
pro='comp1'
write.csv(kk@result,paste0(pro,'_kegg.gsea.csv'))
save(kk,file = 'gsea_kk.Rdata')
富集可视化
上面的kk这个变量就存储了kegg这个生物学功能数据库的gsea分析结果,我们进行简单可视化,代码如下:
# 展现前6个上调通路和6个下调通路
down_k <- kk_gse[tail(order(kk_gse$enrichmentScore,decreasing = F)),];down_k$group=-1
up_k <- kk_gse[head(order(kk_gse$enrichmentScore,decreasing = F)),];up_k$group=1
dat=rbind(up_k,down_k)
colnames(dat)
dat$pvalue = -log10(dat$pvalue)
dat$pvalue=dat$pvalue*dat$group
dat=dat[order(dat$pvalue,decreasing = F),]
# gsea分析结果p7
p7<- ggplot(dat, aes(x=reorder(Description,order(pvalue, decreasing = F)), y=pvalue, fill=group)) +
geom_bar(stat="identity") +
scale_fill_gradient(low="#34bfb5",high="#ff6633",guide = FALSE) +
scale_x_discrete(name ="Pathway names") +
scale_y_continuous(name ="log10P-value") +
coord_flip() +
theme_ggstatsplot()+
theme(plot.title = element_text(size = 15,hjust = 0.5),
axis.text = element_text(size = 12,face = 'bold'),
panel.grid = element_blank())+
ggtitle("Pathway Enrichment")
p7
#具体看上面条形图里面的每个通路的gsea分布情况p8
library(enrichplot)
p8 <- gseaplot2(kk, geneSetID = rownames(down_k))+
gseaplot2(kk, geneSetID = rownames(up_k))
p8
出图如下:
如果你也有类似的数据分析需求,却苦于不会写代码,可以考虑找我们的工程师帮忙哦!
转录组产品线
明码标价之转录组常规测序服务(仅需799每个样品) 明码标价之普通转录组上游分析 明码标价之转录组下游分析仅需800元 明码标价之转录组测序数据的可变剪切 明码标价之RNA-Seq数据的内含子保留分析