Code:
library(pheatmap)
library(colorspace)
t=read.table(text=";Body length;Cephalic index;Facial Index;Concave nose %;Convex nose %;Eye color;Hair color
West Estonian type (Estonians);172.14;80.7;89.7;17;10;0.48;2.53
East Estonian type (Estonians);170.61;81.5;88.2;12;16;0.42;2.54
Curonian type (Latvians);171.82;80.4;89.1;12;12;0.43;2.91
Semigallian-Vidzeme type (Latvians);170;81.8;88;8;16;0.44;2.81
Latgalian type (Latvians);170.33;82;88.6;8;16;0.46;2.72
Neman type (Lithuanians);168.72;82.5;88.2;9;12;0.51;2.86
Valdai type (Lithuanians);167.79;82.1;89;8;11;0.51;2.88
Valdai type (Belarusians);167.93;82.04;88.67;10;NA;0.61;3.30
East Polesian type (Belarusians);167.19;83.3;88.1;7;32;0.52;2.97
West Polesian type (Belarusians);166.92;83.3;89;3;24;0.54;3.05
White Sea - Baltic type (Vepsians and Karelians);165.96;82.2;89.4;24;11;0.45;2.38
Erzya;167.69;79.6;90.6;10;12;0.7;2.92
Moksha;165.95;78.7;90.3;8;8;0.76;3.22
Mezen - Pechora type (Northern and North-Western Komi);165.23;79.33;87.7;21;7;0.62;2.73
Vychegda type (Western, Eastern and Southern Komi);163.83;81.94;88.2;22;6;0.57;2.72
Kama type (Komi Permyaks);163.32;82.17;88.5;16;13;0.72;3.25
Volga-Kama type (Udmurts, Mari and Chuvashs);163.06;81.8;89.4;10;12;1.09;3.43
Steppe type (Mishar Tatars);164.77;79.8;89.7;11;15;0.95;3.82
Volga-Kama-Steppe type (Tatars and Bashkirs);166.1;81.3;88.8;13;17;0.9;3.71
West High Volga type (Russians);167.27;81.3;90.58;12;16;0.51;2.74
East High Volga type (Russians);166.31;80.98;91.27;7;15;0.54;2.72
High Oka type (Russians);166.23;81.32;89.25;8;18;0.56;2.89
Desna-Seym type (Russians);167.4;81.68;87.05;16;17;0.67;2.87
Lower Oka - Don - Sura type (Russians);167;79.85;89.71;10;15;0.62;2.84
Lower Oka type (Russians);166.48;79.69;90.26;5;17;0.57;2.79
Don-Khopyor type (Russians);167.4;80.01;89.16;14;14;0.67;2.88
West Valdai type (Russians);167.65;82.38;87.38;11;16;0.59;2.75
East Valdai type (Russians);167.34;82.76;90.04;10;16;0.48;2.64
Ilmen type (Russians);168.08;81.54;90.5;12;16;0.59;2.53
Belozersk-Vetluga type (Russians);166.23;82.61;89.62;7;19;0.65;2.64
Central type (Russians);167.81;81.7;89.34;6;18;0.72;2.74
Klyazma type (Russians);168.41;82.1;90.32;9;16;0.67;2.76
North Dvina type (Russians);165.93;81.4;89.33;15;15;0.54;2.48
Vyatka-Kama type (Russians);167.3;82.04;90.36;11;19;0.69;2.59
East Polesian type (Ukrainians);168.26;83.58;87.44;4;7;0.71;3.16
West Polesian type (Ukrainians);167.89;83.71;86.59;7;13;0.68;3.27
Dnieper type (Ukrainians);169.47;83.07;87.83;10;10;0.7;3.35
Lower Dnieper type (Ukrainians);168.62;82.46;88.29;12;14;0.73;3.37
High Dnieper type (Ukrainians);166.75;84.35;88.87;8;14;0.68;3.41
Transcarpathian subtype of Carpathian type (Ukrainians);166.72;84.51;88.01;7;19;0.82;3.41
Bukovina subtype of Carpathian type (Ukrainians);168.2;84.75;88.9;8;24;0.84;3.44",r=1,sep=";",h=T,check=F)
t=scale(t)
t2=t
t2[is.na(t2)]=2.8
p=prcomp(t2)$x
hc=hclust(dist(t2))
hc=reorder(hc,p[,1])
pheatmap::pheatmap(
t,
filename="1.png",
clustering_callback=function(...)hc,
cluster_cols=F,
legend=F,
cellwidth=18,
cellheight=18,
fontsize=10,
treeheight_row=100,
border_color=NA,
display_numbers=T,
number_format="%.1f",
fontsize_number=8,
number_color="black",
breaks=seq(-2.5,2.5,5/256),
colorRampPalette(colorspace::hex(HSV(c(210,210,210,210,0,0,0),c(.7,.6,.3,0,.3,.6,.7),c(.7,1,1,1,1,1,.7))))(256)
)
Here's also a biplot of the populations, where each population is connected with a line to its two closest neighbors:
Code:
library(tidyverse)
library(colorspace)
library(ggforce)
t=read.table("ta/russki",r=1,sep=";",h=T,check=F)
t[is.na(t)]=2.8
t=scale(t)
p=prcomp(t)
p2=as.data.frame(p$x)
p2[,2]=-p2[,2]
pct=paste0(colnames(p$x)," (",sprintf("%.1f",p$sdev/sum(p$sdev)*100),"%)")
k=cutree(hclust(dist(t)),12)
load=p$rotation
mult=apply(p2,2,max)/apply(load,2,max)
p2$k=k
mult[2]=-mult[2]
set.seed(0)
hue=seq(0,360,length.out=length(unique(k))+1)%>%head(-1)%>%sample()
pal1=hex(HSV(hue,.6,1))
pal2=hex(HSV(hue,.3,1))
dist=as.data.frame(as.matrix(dist(as.matrix(t))))
i=1
nneigh=2
seg=lapply(1:nneigh+1,function(j)apply(dist,1,function(x)unlist(p2[names(sort(x)[j]),c(i,i+1)],use.names=F))%>%t%>%cbind(p2[,c(i,i+1)]))%>%do.call(rbind,.)%>%setNames(paste0("V",1:4))
xpc=sym(paste0("PC",i))
ypc=sym(paste0("PC",i+1))
ggplot(p2,aes(!!xpc,!!ypc))+
ggforce::geom_mark_hull(aes(group=k),color=pal2[as.factor(k)],fill=pal1[as.factor(k)],concavity=1000,radius=unit(.15,"cm"),expand=unit(.15,"cm"),alpha=.2,size=.15)+
geom_segment(data=seg,aes(x=V1,y=V2,xend=V3,yend=V4),color="gray10",size=.2)+
geom_segment(data=as.data.frame(load),aes(x=0,y=0,xend=mult[i]*load[,i],yend=mult[i+1]*load[,i+1]),arrow=arrow(length=unit(.3,"lines")),color="gray90",size=.4)+
annotate("text",x=unname(mult[i]*load[,i]),y=unname(mult[i+1]*load[,i+1]),label=rownames(load),size=2.5,vjust=ifelse(load[,i+1]>0,-.5,1.4),color="gray90")+
geom_point(aes(x=!!xpc,y=!!ypc),color=pal2[as.factor(k)],size=.3)+
geom_text(aes(x=!!xpc,y=!!ypc,label=rownames(p2)),color=pal2[as.factor(k)],size=2,vjust=-.7)+
labs(x=pct[i],y=pct[i+1])+
scale_x_continuous(breaks=seq(-10,10,1),expand=expansion(mult=.14))+
scale_y_continuous(breaks=seq(-10,10,1))+
theme(
axis.text=element_text(color="gray90",size=6),
axis.text.y=element_text(angle=90,vjust=1,hjust=.5),
axis.ticks=element_blank(),
axis.ticks.length=unit(0,"pt"),
axis.title=element_text(color="gray90",size=8),
legend.position="none",
panel.background=element_rect(fill="gray30",color=NA),
panel.border=element_rect(color="gray40",fill=NA,size=.4),
panel.grid=element_blank(),
plot.background=element_rect(fill="gray30",color=NA),
plot.title=element_text(size=10,color="gray90")
)
ggsave(paste0("1.png"),width=7,height=7)
Bookmarks