Komintasavalta
10-28-2021, 01:04 PM
The plots posted in this thread don't take FST into account, so many north Caucasisans plot further right on PC1 than Chuvashes. But if you multiply the matrix of admixture percentages with an MDS matrix of the FST matrix, then Chuvashes plot much further east on PC1:
https://i.ibb.co/QjZ4p9c/2.png
Or here's K15 updated along with some of my new averages:
https://i.ibb.co/fkYdwx5/1.png
library(tidyverse)
library(ggforce)
t=read.csv("https://pastebin.com/raw/hDBUcTL8",row.names=1,check.names=F) # K13 original
A=function(x)unlist(strsplit(x," "))
pick=A("Adygei Ashkenazi Austrian Balkar Belorussian Bulgarian Central_Greek Chechen Chuvash Croatian Danish East_Finnish East_German East_Sicilian Erzya Estonian Estonian_Polish Finnish French French_Basque Greek Greek_Thessaly Hungarian Irish Italian_Abruzzo Italian_Jewish Kabardin Kargopol_Russian Kumyk Lezgin Lithuanian Mari Moldavian Nogay North_Dutch North_German North_Italian North_Ossetian North_Swedish Norwegian Orcadian Ossetian Polish Portuguese Romanian Russian_Smolensk Sardinian Serbian South_Dutch South_Italian South_Polish Southeast_English Southwest_English Southwest_Finnish Southwest_French Southwest_Russian Spanish_Andalucia Spanish_Aragon Spanish_Cantabria Spanish_Castilla_La_Mancha Spanish_Castilla_Y_Leon Spanish_Cataluna Spanish_Extremadura Spanish_Galicia Spanish_Murcia Spanish_Valencia Swedish Tabassaran Tatar Tuscan Ukrainian Ukrainian_Belgorod Ukrainian_Lviv West_German West_Norwegian West_Scottish West_Sicilian")
t=t[pick,]
fst=as.matrix(as.dist(read.csv(text=",,,,,,,,,,,,,,
0.015,,,,,,,,,,,,,,
0.02,0.022,,,,,,,,,,,,,
0.02,0.022,0.024,,,,,,,,,,,,
0.029,0.028,0.037,0.038,,,,,,,,,,,
0.027,0.026,0.033,0.031,0.035,,,,,,,,,,
0.026,0.024,0.034,0.032,0.027,0.019,,,,,,,,,
0.053,0.05,0.059,0.058,0.051,0.046,0.038,,,,,,,,
0.06,0.062,0.064,0.056,0.075,0.053,0.055,0.078,,,, ,,,
0.112,0.114,0.115,0.102,0.123,0.109,0.11,0.127,0.0 75,,,,,,
0.111,0.113,0.114,0.1,0.125,0.11,0.112,0.13,0.083, 0.056,,,,,
0.138,0.141,0.141,0.128,0.156,0.14,0.143,0.161,0.1 2,0.113,0.107,,,,
0.178,0.179,0.181,0.173,0.188,0.176,0.174,0.19,0.1 45,0.166,0.178,0.217,,,
0.109,0.108,0.114,0.108,0.112,0.103,0.094,0.106,0. 102,0.137,0.144,0.178,0.195,,
0.144,0.144,0.148,0.142,0.149,0.139,0.132,0.139,0. 131,0.164,0.171,0.204,0.219,0.042,",head=F)))/1000
t2=as.matrix(t)%*%cmdscale(fst,ncol(fst)-1)
p0=prcomp(t2)
pct=paste0(colnames(p0$x)," (",sprintf("%.1f",100*p0$sdev/sum(p0$sdev)),"%)")
p=as.data.frame(p0$x)
p[,1]=-p[,1]
p=p/sd(p[,1])
p$pop=as.factor(cutree(hclust(dist(t2)),16))
set.seed(1)
hue=seq(0,360,length.out=nlevels(p$pop)+1)%>%head(-1)%>%sample()
pal1=hcl(hue,100,55)
i=1
xpc=sym(paste0("PC",i))
ypc=sym(paste0("PC",i+1))
seg=lapply(1:3,function(j)apply(as.matrix(dist(t)) ,1,function(x)unlist(p[names(sort(x)[j]),c(i,i+1)],use.names=F))%>%t%>%cbind(p[,c(i,i+1)]))%>%do.call(rbind,.)%>%setNames(paste0("V",1:4))
ggplot(p,aes(!!xpc,!!ypc))+
geom_segment(data=seg,aes(x=V1,y=V2,xend=V3,yend=V 4),color="gray50",size=.1)+
ggforce::geom_mark_hull(aes(group=pop),color=pal1[p$pop],fill=pal1[p$pop],concavity=100,radius=unit(.15,"cm"),expand=unit(.15,"cm"),alpha=.2,size=.15)+
geom_point(aes(x=!!xpc,y=!!ypc),color=pal1[p$pop],size=.3)+
geom_text(aes(x=!!xpc,y=!!ypc,label=rownames(p)),c olor=pal1[p$pop],size=2,vjust=-.6)+
labs(x=pct[i],y=pct[i+1])+
scale_x_continuous(breaks=seq(-10,10,.5),expand=expansion(.06))+
scale_y_continuous(breaks=seq(-10,10,.5),expand=expansion(.03))+
theme(
axis.ticks=element_blank(),
axis.ticks.length=unit(0,"pt"),
axis.text.y=element_text(angle=90,vjust=1,hjust=.5 ),
axis.text=element_text(color="black",size=6),
axis.title=element_text(color="black",size=8),
legend.position="none",
panel.background=element_rect(fill="white"),
plot.background=element_rect(fill="white",color=NA),
panel.border=element_rect(color="gray80",fill=NA,size=.4),
panel.grid.minor=element_blank(),
panel.grid.major=element_line(color="gray90",size=.2)
)
ggsave(paste0(i,".png"),width=7,height=7)
Powered by vBulletin® Version 4.2.3 Copyright © 2025 vBulletin Solutions, Inc. All rights reserved.