【生信技能树】R语言高级练习题

安装一些R包
数据包： ALL, CLL, pasilla, airway
软件包：limma，DESeq2，clusterProfiler
工具包：reshape2
绘图包：ggplot2
了解ExpressionSet对象，比如CLL包里面就有data(sCLLex) ，找到它包含的元素，提取其表达矩阵(使用exprs函数)，查看其大小
参考：https://github.com/bioconductor-china/basic/blob/master/ExpressionSet.md

library(CLL) 
?CLL 
data(sCLLex) 
sCLLex 
exprSet <- exprs(sCLLex) # 提取表达矩阵
dim(exprSet)            # 查看维度 [1] 12625    22
head(exprSet)
samples <- sampleNames(sCLLex) # 样本名
pdata <- pData(sCLLex)   # 查看分组信息
pdata
table(pdata$Disease)  # progres. 14   stable  8
group_list <- factor(pdata[,2])
#看看数据质量如何
par(cex = 0.7)
n.sample=ncol(exprSet)
if(n.sample>40) par(cex = 0.5)
cols <- rainbow(n.sample*1.2)
boxplot(exprSet, col = cols,main="expression value",las=2)

image.png

了解 str,head,help函数，作用于第二步提取到的表达矩阵

str(exprSet)
head(exprSet)

安装并了解 hgu95av2.db 包,看看 ls("package:hgu95av2.db") 后显示的那些变量

library(hgu95av2.db)
ls("package:hgu95av2.db")
columns(hgu95av2.db)

理解 head(toTable(hgu95av2SYMBOL)) 的用法，找到 TP53 基因对应的探针ID

head(toTable(hgu95av2SYMBOL))
ids <- toTable(hgu95av2SYMBOL)
# 方法1：
library(dplyr)
filter(ids, symbol=="TP53") #用dplyr包的筛选功能，找到 TP53 基因对应的探针ID
#方法2：
ids[grep("^TP53$", ids$symbol),]
#结果 1   1939_at   TP53 2 1974_s_at   TP53 3  31618_at   TP53

理解探针与基因的对应关系，总共多少个基因，基因最多对应多少个探针，是哪些基因，是不是因为这些基因很长，所以在其上面设计多个探针呢？

length(unique(ids$symbol))
unique(ids$symbol) %>% length() #查看总共基因数（注意unique的使用，为了避免重复基因出现）

tail(sort(table(ids$symbol)))
table(ids$symbol) %>% sort() %>% tail() #table将基因名字符量化为数字，sort从小到大排序，tail取最大6个

table(sort(table(ids$symbol)))
table(ids$symbol) %>%table() #table函数统计不同探针数量对应的基因数

第二步提取到的表达矩阵是12625个探针在22个样本的表达量矩阵，找到那些不在 hgu95av2.db 包收录的对应着SYMBOL的探针。
%in%%>%是管道符号，相当于linux的“|”; %in%表示两者求交集

table(rownames(exprSet)) %in% ids$probe_id
# %in% is a more intuitive interface as a binary operator, which returns a logical vector indicating if there is a match or not for its left operand.
n_exprSet <- exprSet[!(rownames(exprSet) %in% ids$probe_id),]
dim(n_exprSet)
# [1] 1165   22
View(n_exprSet)
# These probes are not in the package.
exprSet <- exprSet[rownames(exprSet) %in% ids$probe_id,]
dim(exprSet)
View(exprSet)
# These probes are in the package.

过滤表达矩阵，删除那1165个没有对应基因名字的探针。

exprSet <- exprSet[rownames(exprSet) %in% ids$probe_id, ]
dim(exprSet)
# [1] 11460    22
View(exprSet)
# These probes are in the package.

整合表达矩阵，多个探针对应一个基因的情况下，只保留在所有样本里面平均表达量最大的那个探针。

ids=ids[match(rownames(exprSet),ids$probe_id),] # 把
head(ids)
exprSet[1:5,1:5]
# 矩阵用by，向量用tapply
tmp = by(exprSet,ids$symbol,function(x) rownames(x)[which.max(rowMeans(x))] )
probes = as.character(tmp)
exprSet = exprSet[rownames(exprSet) %in% probes ,]
dim(exprSet)  # [1] 8584   22
View(head(exprSet))

把过滤后的表达矩阵更改行名为基因的symbol，因为这个时候探针和基因是一对一关系了

rownames(exprSet)=ids[match(rownames(exprSet),ids$probe_id),2]
exprSet[1:5,1:5]

library(reshape2)
exprSet_L=melt(exprSet)
colnames(exprSet_L)=c('probe','sample','value')
exprSet_L$group=rep(group_list,each=nrow(exprSet))
head(exprSet_L)
View(head(exprSet))

对第10步得到的表达矩阵进行探索，先画第一个样本的所有基因的表达量的boxplot,hist,density ，然后画所有样本的这些图

library(ggplot2)

# 箱线图
ggplot(data = exprSet_L) +
  geom_boxplot(mapping = aes(x=sample, y=value, color=group))+
  theme(axis.text.x = element_text(colour="grey20",size=5,angle=90,hjust=.5,vjust=.5,face="plain"))
# 小提琴图  
ggplot(data = exprSet_L)+ 
  geom_violin(mapping = aes(x=sample, y=value, fill=group))+
  theme(axis.text.x=element_text(size=rel(0.5), angle=90))
# 密度图
ggplot(data =exprSet_L)+
  geom_density(mapping = aes(value,col=group))
# 直方图 （分面）
ggplot(data=exprSet_L)+
  geom_histogram(mapping=aes(value,fill=group),bins = 200)+
  facet_wrap(~sample, nrow = 4)
# 多参数绘图
ggplot(exprSet_L,aes(x=sample,y=value,fill=group))+
  geom_boxplot()+
  stat_summary(fun.y="mean",geom="point",shape=23,size=3,fill="#FFFACD")+
  theme_set(theme_set(theme_bw(base_size=10)))+
  theme(text=element_text(face='bold'),axis.text.x=element_text(angle=30,hjust=1),axis.title=element_blank())

image.png

理解统计学指标mean,median,max,min,sd,var,mad并计算出每个基因在所有样本的这些统计学指标，最后按照mad值排序，取top 50 mad值的基因，得到列表

g_mean <- tail(sort(apply(exprSet,1,mean)),50)
g_mean
g_median <- tail(sort(apply(exprSet,1,median)),50)
g_median
g_max <- tail(sort(apply(exprSet,1,max)),50)
g_max
g_min <- tail(sort(apply(exprSet,1,min)),50)
g_min
g_sd <- tail(sort(apply(exprSet,1,sd)),50)
g_sd
g_var <- tail(sort(apply(exprSet,1,var)),50)
g_var
g_mad <- tail(sort(apply(exprSet,1,mad)),50)
g_mad
names(g_mad)

.根据第12步骤得到top 50 mad值的基因列表来取表达矩阵的子集，并且热图可视化子表达矩阵。试试看其它5种热图的包的不同效果。

# ggplot2
library(ggplot2)
choose_matrix_m <- melt(choose_matrix)
ggplot(choose_matrix_m, aes(x= Var2, y = Var1))+
  geom_tile(aes(fill=value))+
  scale_fill_gradient(low = "white", high = "red")+
  theme(axis.text.x=element_text(size=rel(0.9), angle=90),
        axis.text.y =element_text(size=rel(0.8)))
# pheatmap
library(pheatmap)
pheatmap(choose_matrix)
# pheatmap.2
library(gplots)
heatmap.2 (choose_matrix)
# heatmap
choose_matrix <- t(scale(t(choose_matrix)))
rc <- rainbow(nrow(choose_matrix), start = 0, end = .3)
cc <- rainbow(ncol(choose_matrix), start = 0, end = .3)

heatmap(choose_matrix, 
        col = cm.colors(256),
        RowSideColors = rc, ColSideColors = cc,
        margins = c(6, 5),
        xlab = "samples", ylab = "genes", 
        main = "heatmap", 
        scale = "column"
)
#
library("lattice")
levelplot(t(choose_matrix),aspect="fill")

image.png

如果有报错invalid graphics state 就需要关闭一下画板dev.off()

取不同统计学指标mean,median,max,mean,sd,var,mad的各top50基因列表，使用UpSetR包来看他们之间的overlap情况。

library(UpSetR)
g_all <- unique(c(names(g_mean),names(g_median),names(g_max),names(g_min),
                  names(g_sd),names(g_var),names(g_mad) ))
dat=data.frame(g_all=g_all,
               g_mean=ifelse(g_all %in% names(g_mean) ,1,0),
               g_median=ifelse(g_all %in% names(g_median) ,1,0),
               g_max=ifelse(g_all %in% names(g_max) ,1,0),
               g_min=ifelse(g_all %in% names(g_min) ,1,0),
               g_sd=ifelse(g_all %in% names(g_sd) ,1,0),
               g_var=ifelse(g_all %in% names(g_var) ,1,0),
               g_mad=ifelse(g_all %in% names(g_mad) ,1,0)
)
upset(dat,nsets = 7)

image.png

在第二步的基础上面提取CLL包里面的data(sCLLex) 数据对象的样本的表型数据

library(CLL)
data(sCLLex)
pdata <- pData(sCLLex)
group_list <- as.character(pdata[,2])
group_list

对所有样本的表达矩阵进行聚类并且绘图，然后添加样本的临床表型数据信息(更改样本名)

## hclust
colnames(exprSet)=paste(group_list,1:22,sep='')
# Define nodePar
nodePar <- list(lab.cex = 0.6, pch = c(NA, 19),
                cex = 0.7, col = "blue")
hc=hclust(dist(t(exprSet)))
par(mar=c(5,5,5,10))
plot(as.dendrogram(hc), nodePar = nodePar, horiz = TRUE)

image.png

对所有样本的表达矩阵进行PCA分析并且绘图，同样要添加表型信息

# install.packages("ggfortify")
library(ggfortify)
exprSet <- exprs(sCLLex)
df <- as.data.frame(t(exprSet))
df$group <- group_list
# autoplot uses ggplot2 to draw a particular plot for an object of a particular class in a single command.
autoplot(prcomp(df[,1:(ncol(df)-1)]), data=df, colour = 'group')

image.png

根据表达矩阵及样本分组信息进行批量T检验，得到检验结果表格

## t.test
dat = exprSet
group_list=as.factor(group_list)
group1 = which(group_list == levels(group_list)[1])
group2 = which(group_list == levels(group_list)[2])
dat1 = dat[, group1]
dat2 = dat[, group2]
dat = cbind(dat1, dat2)
pvals = apply(exprSet, 1, function(x){
  t.test(as.numeric(x)~group_list)$p.value
})
p.adj = p.adjust(pvals, method = "BH")
avg_1 = rowMeans(dat1)
avg_2 = rowMeans(dat2)
log2FC = avg_2-avg_1
DEG_t.test = cbind(avg_1, avg_2, log2FC, pvals, p.adj)
DEG_t.test=DEG_t.test[order(DEG_t.test[,4]),]
DEG_t.test=as.data.frame(DEG_t.test)
head(DEG_t.test)

使用limma包对表达矩阵及样本分组信息进行差异分析，得到差异分析表格，重点看logFC和P值，画个火山图(就是logFC和-log10(P值)的散点图)

# DEG by limma
suppressMessages(library(limma))
design <- model.matrix(~0+factor(group_list))
colnames(design)=levels(factor(group_list))
rownames(design)=colnames(exprSet)
design
contrast.matrix<-makeContrasts(paste0(unique(group_list),collapse = "-"),levels = design)
contrast.matrix
##这个矩阵声明，我们要把progres.组跟stable进行差异分析比较
##step1
fit <- lmFit(exprSet,design)
##step2
fit2 <- contrasts.fit(fit, contrast.matrix) ##这一步很重要，大家可以自行看看效果
fit2 <- eBayes(fit2) ## default no trend !!!
##eBayes() with trend=TRUE
##step3
tempOutput = topTable(fit2, coef=1, n=Inf)
nrDEG = na.omit(tempOutput)
#write.csv(nrDEG2,"limma_notrend.results.csv",quote = F)
head(nrDEG)

## volcano plot
DEG=nrDEG
logFC_cutoff <- with(DEG,mean(abs( logFC)) + 2*sd(abs( logFC)) )
DEG$change = as.factor(ifelse(DEG$P.Value < 0.05 & abs(DEG$logFC) > logFC_cutoff,
                              ifelse(DEG$logFC > logFC_cutoff ,'UP','DOWN'),'NOT')
)
this_tile <- paste0('Cutoff for logFC is ',round(logFC_cutoff,3),
                    '\nThe number of up gene is ',nrow(DEG[DEG$change =='UP',]) ,
                    '\nThe number of down gene is ',nrow(DEG[DEG$change =='DOWN',])
)

g = ggplot(data=DEG, aes(x=logFC, y=-log10(P.Value), color=change)) +
  geom_point(alpha=0.4, size=1.75) +
  theme_set(theme_set(theme_bw(base_size=20)))+
  xlab("log2 fold change") + ylab("-log10 p-value") +
  ggtitle( this_tile ) + theme(plot.title = element_text(size=15,hjust = 0.5))+
  scale_colour_manual(values = c('blue','black','red')) ## corresponding to the levels(res$change)
print(g)

image.png

对T检验结果的P值和limma包差异分析的P值画散点图，看看哪些基因相差很大

### different P values
head(nrDEG)
head(DEG_t.test)
DEG_t.test=DEG_t.test[rownames(nrDEG),]
plot(DEG_t.test[,3],nrDEG[,1])
plot(DEG_t.test[,4],nrDEG[,4])
plot(-log10(DEG_t.test[,4]),-log10(nrDEG[,4]))

image.png

rownames(exprSet)=ids[match(rownames(exprSet),ids$probe_id),2]
exprSet[1:5,1:5]
exprSet['GAPDH',]
exprSet['ACTB',]
exprSet['DLEU1',]
library(ggplot2)
library(ggpubr)
my_comparisons <- list(
  c("stable", "progres.")
)
dat=data.frame(group=group_list,
               sampleID= names(exprSet['DLEU1',]),
               values= as.numeric(exprSet['DLEU1',]))
ggboxplot(
  dat, x = "group", y = "values",
  color = "group",
  add = "jitter"
)+
  stat_compare_means(comparisons = my_comparisons, method = "t.test")

image.png

library(pheatmap)
choose_gene=head(rownames(nrDEG),25)
choose_matrix=exprSet[choose_gene,]
choose_matrix=t(scale(t(choose_matrix)))
pheatmap(choose_matrix)

image.png

## heatmap
library(pheatmap)
choose_gene <- head(rownames(nrDEG),25)
choose_matrix <- exprSet[choose_gene,]
choose_matrix <- t(scale(t(choose_matrix)))
pheatmap(choose_matrix)

image.png

这里的表达矩阵exprSet时第17部重新抽取的

【生信技能树】R语言高级练习题

你可能感兴趣的:(【生信技能树】R语言高级练习题)