空间转录组共定位展示分析图
2023-07-20 本文已影响0人
单细胞空间交响乐
作者，Evil Genius
关于空间共定位（细胞和配受体）的展示方式已经提供了好几种了，列在下面，供大家参考
空间转录组细胞类型和配受体的空间定位图
空间细胞类型方向图
空间细胞类型密度分布图
空间转录组数据分析之近邻热图绘制
10X空间转录组绘图分析之体现两种细胞类型的空间位置
10X空间转录组时空基因细胞动态（共定位）绘图
这一篇我们来展示最后一种共定位的方式，如下图
同样的做法，我们可以展示细胞类型的共定位或者配受体的共定位，右图体现了共定位的趋势，我们来实现以下，我随便选了两种细胞类型，绘图结果如下;
当然了，随机选择的不太合适，绘图的时候同样需要多种颜色一起搭配，真正共定位效果强的绘图效果会非常好，我们来实现一下：
suppressMessages({
library(Seurat)
library(dplyr)
library(ggplot2)
})
cortex_sp = readRDS(spatial_rds)
一样的内容，如果展示细胞类型的空间共定位就需要包含单细胞空间联合的分析信息，然后提取有效信息。
decon_mtrx = t(cortex_sp@assays$predictions@data)
cell_types_all <- colnames(decon_mtrx)[which(colnames(decon_mtrx) != "max")]
decon_df <- decon_mtrx %>%
data.frame(check.names = F) %>%
tibble::rownames_to_column("barcodes")
#decon_df$barcodes = rownames(tmp)
cortex_sp@meta.data <- cortex_sp@meta.data %>%
tibble::rownames_to_column("barcodes") %>%
dplyr::left_join(decon_df, by = "barcodes") %>%
tibble::column_to_rownames("barcodes")
###plot dot
slice <- names(cortex_sp@images)[1]
metadata_ds <- data.frame(cortex_sp@meta.data)
colnames(metadata_ds) <- colnames(cortex_sp@meta.data)
cell_types_interest <- cell_types_all
metadata_ds <- metadata_ds %>% tibble::rownames_to_column("barcodeID") %>%
dplyr::mutate(rsum = base::rowSums(.[, cell_types_interest,
drop = FALSE])) %>% dplyr::filter(rsum != 0) %>%
dplyr::select("barcodeID") %>% dplyr::left_join(metadata_ds %>%
tibble::rownames_to_column("barcodeID"), by = "barcodeID") %>%
tibble::column_to_rownames("barcodeID")
spatial_coord <- data.frame(cortex_sp@images[[slice]]@coordinates) %>%
tibble::rownames_to_column("barcodeID") %>% dplyr::mutate(imagerow_scaled = imagerow *
cortex_sp@images[[slice]]@scale.factors$lowres, imagecol_scaled = imagecol *
cortex_sp@images[[slice]]@scale.factors$lowres) %>% dplyr::inner_join(metadata_ds %>%
tibble::rownames_to_column("barcodeID"), by = "barcodeID")
接下来我们绘图,相比于之前的图，这个图比较复杂
knn = 6
pair=c("IIa","IIb")
pt.size=2
alpha.min=0.1
max.cut=0.95
####选择两种细胞类型
LRpair = c('IIa','IIb')
location = spatial_coord[,c('imagerow','imagecol')]
topn=floor(0.2*dim(location)[1])
expr = spatial_coord[,LRpair]
ncell<-dim(expr)[1]
nnmatrix<-RANN::nn2(location,k=knn)$nn.idx
countsum<-Matrix::colSums(expr)
####normalize
expr<-Matrix::t(log(Matrix::t(expr)/countsum*median(countsum)+1))
ligand<-expr[,LRpair[1]]
receptor<-expr[,LRpair[2]]
LRexp<-rbind(ligand,receptor)
neighexp<-apply(nnmatrix,1,function(x){apply(LRexp[,x[2:knn]],1,max)})
LRadd<-pmax(LRexp[1,]*neighexp[2,],LRexp[2,]*neighexp[1,])
LRadd_max<-quantile(LRadd,probs=max.cut)
LRadd[LRadd>LRadd_max]<-LRadd_max
if(sum(ligand>0)>topn){n1<-order(ligand,sample(ncell,ncell),decreasing=T)[1:topn]}else{n1<-which(ligand>0)}
if(sum(receptor>0)>topn){n2<-order(receptor,sample(ncell,ncell),decreasing=T)[1:topn]}else{n2<-which(receptor>0)}
expcol<-rep(0,ncell)
expcol[n1]<-1
expcol[n2]<-2
expcol[intersect(n1,n2)]<-3
tmp<-data.frame(x=location[,1],y=location[,2],Exp=as.factor(expcol))
tmpLRadd<-data.frame(x=location[,1],y=location[,2],LR=LRadd)
alpha=(LRadd-min(LRadd))/(max(LRadd)-min(LRadd))*(1-alpha.min)+alpha.min
绘图
p1<-ggplot(tmp,aes(x=x,y=y,col=Exp))+geom_point(size=pt.size)+scale_color_manual(values=c("gray","red","green","blue"),labels=c("Bothlow","IIa_high","IIb_High","BothHigh"))+ggtitle(paste0(LRpair,collapse="_"))+xlab("")+ylab("")+theme(axis.line=element_blank(),axis.text.x=element_blank(),axis.text.y=element_blank(),axis.ticks.x=element_blank(),axis.ticks.y=element_blank()) + theme_minimal() + theme(axis.text = element_blank(),axis.title = element_blank(),panel.grid = element_blank())
p2<-ggplot(tmpLRadd,aes(x=x,y=y,col=LR))+geom_point(size=pt.size,alpha=alpha)+scale_color_gradient2(midpoint=quantile(LRadd,probs=0.5),low="gray",high="red",mid="gray")+xlab("")+ylab("")+theme(axis.line=element_blank(),axis.text.x=element_blank(),axis.text.y=element_blank(),axis.ticks.x=element_blank(),axis.ticks.y=element_blank())+labs(color="colocalization") + theme_minimal() + theme(axis.text = element_blank(),axis.title = element_blank(),panel.grid = element_blank())
p1+p2&scale_y_reverse()
