# SIA_cluster.R
# [arthurp] 22-07-2019
# R version: R-3.5.3
# optiSel version: 2.0.2
# Dataset: thai_pedigrees.csv (Dec. 2018)
# anonymised, recoded breed information to use EMS codes
#
# Performs hierarchical (UPGMA) and model-based Cluster analysis 
# of Siamese cat population, represented by parents of kittens, 
# born in 1998 or 1999.
#
# Output: 
# SIA_UPGMA_cluster.rpt (Table 2, left) 
# UPGMA_clust_SIA_9899.csv Distribution of individuals over the
# clusters. Less informative when anonymous data are used
# SIA_MB_cluster.rpt (Table 2, right) 
# MB_clust_SIA_9899.csv Distribution of individuals over the
# clusters. Less informative when anonymous data are used
#
# Plots Figure 5B and 7B: Selection of optimal number of clusters.  
# These figures are left out from the main text.
#
getwd()
library(optiSel)
library(cluster)
library(fpc)
library(NbClust)
library(mclust)
outfile1<-"SIA_UPGMA_cluster.rpt"
outfile2<-"UPGMA_clust_SIA_9899.csv"
outfile3<-"SIA_MB_cluster.rpt"
outfile4<-"MB_clust_SIA_9899.csv"
all <- read.csv("thai_pedigrees.csv",na.strings="", header=TRUE)
ped<-data.frame(all$Indiv, all$Sire, all$Dam, all$Sex, all$Breed, all$Born)
colnames(ped) <- c("Indiv","Sire", "Dam", "Sex", "Breed", "Born")
Pedig<-prePed(ped, lastNative=1940)
Pedig$NC<-pedBreedComp(Pedig, thisBreed="SIA")$native
# Select parents of current ageGroup
isSIA<-Pedig$Breed == "SIA" & !is.na(Pedig$Breed)
ageGroup<-Pedig$Born %in% (1998:1999)
keep<-unlist(Pedig[ageGroup, c("Sire", "Dam")])
keep<-intersect(keep, Pedig[isSIA, "Indiv"])
use<-Pedig$Indiv %in% keep
# use and keep have now 467 TRUE entries.
Summary<-summary(Pedig, keep.only=keep)
# de-select individuals with short pedigrees
Summary<-subset(Summary, Summary$equiGen>=3)
use<-Pedig$Indiv %in% Summary$Indiv
# use has now 462 TRUE entries
cont<-agecont(Pedig, use, maxAge=8)
Phen<-Pedig[use, ]
#
pKin<-pedIBD(Pedig, keep.only=Phen$Indiv)
pKinatN<-pedIBDatN(Pedig, thisBreed="SIA", keep.only=Phen$Indiv, nGen=6)
natNe<-attributes(pKinatN)$nativeNe
# Set cont=NULL explicitly to discrete generations
Phen$Born<-1
cand<-candes(phen=Phen, pKin=pKin, pKinatN=pKinatN, cont=NULL)
#
sex_tbl<-table(Phen$Sex)
Nm<-as.integer(sex_tbl[2])
Nf<-as.integer(sex_tbl[1])
Ne<-as.integer(4*Nm*Nf/(Nm+Nf))
# Alternatively, calculate Neff according to Cervantes et al. (2011)
# This does not work because of historic ingression
id<-Phen$Indiv
g<-Summary[id, "equiGen"]
N<-length(g)
n<-(matrix(g,N,N, byrow=TRUE) + matrix(g,N,N, byrow=FALSE))/2
deltaC<-1-(1-pKin[id, id])^(1/n)
Neff<-round(1/(2*mean(deltaC)), 1)
ECG<-round(mean(Summary$equiGen), 1)
# L is generation time
L<-1/(4*cont$male[1])+1/(4*cont$female[1])
#
mk<-round(rowMeans(pKin, na.rm=TRUE, dims=1), 3)
avg_mk<-round(mean(mk), 2)
F<-round(2*diag(pKin)-1.00, 3)
avg_F<-round(mean(F), 2)
#
ub.pKin<-cand$mean$pKin + (1-cand$mean$pKin)*(1/(2*Ne*L))
ub.pKinatN<-cand$mean$pKinatN + (1-cand$mean$pKinatN)*(1/(2*Ne*L))
lb.NC<-cand$mean$NC
# Optimization for two cases
# -Minimize kinship
# -Minimize kinship at native alleles and minimize influence of
# migrants by setting the mean native contribution as lower boundary. 
con<-list(ub.pKin=ub.pKin)
Offspring<-opticont("min.pKin", cand, con, solver="slsqp", trace=FALSE)
con<-list(ub.pKin=ub.pKin, ub.pKinatN=ub.pKinatN, lb.NC=lb.NC)
Offspring2<-opticont("min.pKinatN", cand, con, solver="slsqp", trace=FALSE)
rbind(cand$mean, Offspring$mean, Offspring2$mean)
avg_mkatN<-round(cand$mean$pKinatN, 2)
FGE<-round((1/(2*avg_mk)), 1)
NGE<-round((1/(2*avg_mkatN)), 1)
Noc<-round((1/(2*Offspring$mean$pKin)), 1)
NocatN<-round((1/(2*Offspring2$mean$pKinatN)), 1)
valid<-Offspring2$info$valid
#
# cl<-0 as placeholder for overall results in UPGMA and 
# model-based report file
cl<-0
Nc<-Nm+Nf
cat( "Cluster N ECG Ne Neff natNe avg_mk avg_F FGE Noc NGE NocatN valid\n", file=outfile1, append=TRUE )
result<-rbind( c( cl, Nc, ECG, Ne, Neff, natNe, avg_mk, avg_F, FGE, Noc, NGE, NocatN, valid ) )
cat( result, file=outfile1, append=TRUE )
cat("\n\n", file=outfile1, append=TRUE )
cat( "Cluster N ECG Ne Neff natNe avg_mk avg_F FGE Noc NGE NocatN valid\n", file=outfile3, append=TRUE )
cat( result, file=outfile3, append=TRUE )
cat("\n\n", file=outfile3, append=TRUE )
#
# Hierarchical cluster analysis using UPGMA method
# Scale the inputs to mean=0 and var=1. However, mk and F are probabilities
# hence already scaled/normalized between 0 and 1
#
input<-cbind(mk, F)
# 
# Use unscaled data
max.nc=16
res_ccc<-NbClust(data=input, distance="euclidean", min.nc=2, max.nc=max.nc, method="average", index="ccc")
res_pst2<-NbClust(data=input, distance="euclidean", min.nc=2, max.nc=max.nc, method="average", index="pseudot2")
res_psF<-NbClust(data=input, distance="euclidean", min.nc=2, max.nc=max.nc, method="average", index="ch")
#
par(mfrow=c(3,1))
par(oma = c(5, 4, 4, 4)) # make room (i.e. the 4's) for the overall x and y axis titles
par(mar = c(2, 2, 0, 0)) # make the plots be closer together
plot(c(2:max.nc),res_ccc$All.index, type="b", lwd=1.5, xlab = '', ylab = '', xaxt = 'n', las = 1, ylim = c(-5, 20), cex=1.5, cex.axis=1.5, font=2)
lines(c(4, 4), c(-6,9), type="l", lwd=1.5)
lines(c(7, 7), c(-6,14), type="l", lwd=1.5)
# lines(c(8, 8), c(-6,11), type="l", lwd=1.5)
# text(15, 12, "A", cex=2.0, pos=4, col="black")
plot(c(2:max.nc),res_psF$All.index, type="b", lwd=1.5, xlab = '', ylab = '', xaxt = 'n', las = 1, ylim = c(0, 700), cex=1.5, cex.axis=1.5, font=2)
lines(c(4, 4), c(-20,350), type="l", lwd=1.5)
lines(c(7, 7), c(-20,420), type="l", lwd=1.5)
# lines(c(8, 8), c(-20,430), type="l", lwd=1.5)
lines(c(4, 4), c(450,720), type="l", lwd=1.5)
lines(c(7, 7), c(540,720), type="l", lwd=1.5)
# lines(c(8, 8), c(560,720), type="l", lwd=1.5)
# lines(c(10, 10), c(730,820), type="l", lwd=1.5)
plot(c(2:max.nc),res_pst2$All.index, type="b", lwd=1.5, xlab = '', ylab = '', las = 1, ylim = c(0, 800), cex=1.5, cex.axis=1.5,font=2, font.lab=2)
lines(c(4, 4), c(80,820), type="l", lwd=1.5)
lines(c(7, 7), c(80,820), type="l", lwd=1.5)
# lines(c(8, 8), c(100,820), type="l", lwd=1.5)
#
# print the overall labels
mtext('Nr. of clusters', side = 1, outer = TRUE, line = 1, font=2)
mtext(expression(bold(paste("     Pseudo t"^"2", "        Pseudo F             CCC"))), side = 2, outer = TRUE, line = 2, font=2)
#
# SIA: Strongest peaks at 4 and 7 clusters. 
# With 7 clusters, the 7th cluster has only 2 members
d<-dist(input, method="euclidean")
H.fit <-hclust(d, method="average")
nc_final<-7
groups<-cutree(H.fit, k=nc_final)
table(groups)
# groups
# 1   2   3   4   5   6   7 
# 5 177  22 209  35  12   2 
#
# Analyse each cluster separately. Skip cluster 7
# (not enough members/no males)
nc_final<-6
cat( "Indiv, equiGen, fullGen, maxGen, PCI, Inbreeding, cluster, Sex, mk\n", file=outfile2, append=TRUE )
for(cl in 1:nc_final) {
  gr<-unlist(attributes(groups[groups==cl]))
  gr<-as.character(gr)
  Nc<-length(gr)
  Summary<-summary(Pedig, keep.only=Pedig$Indiv %in% gr)
  Summary$cluster<-cl
  Summary$Sex<-Pedig$Sex[Pedig$Indiv %in% gr]
  #
  use1<-Pedig$Indiv %in% gr
  use1<-use1 & Summary$equiGen>=3
  cont1<-agecont(Pedig, use1, maxAge=8)
  Phen1<-Pedig[use1, ]
  #
  pKin1<-pedIBD(Pedig, keep.only=Phen1$Indiv)
  pKinatN1<-pedIBDatN(Pedig, thisBreed="SIA", keep.only=Phen1$Indiv, nGen=6)
  natNe<-attributes(pKinatN1)$nativeNe
  Phen1$Born<-1
  cand1<-candes(phen=Phen1, pKin=pKin1, pKinatN=pKinatN1, cont=NULL)
  #
  sex_tbl<-table(Phen1$Sex)
  Nm<-as.integer(sex_tbl[2])
  Nf<-as.integer(sex_tbl[1])
  Ne<-as.integer(4*Nm*Nf/(Nm+Nf))
  # Alternatively, calculate Neff according to Cervantes et al. (2011)
  # This does not work because of historic ingression
  id<-Phen1$Indiv
  g<-Summary[id, "equiGen"]
  N<-length(g)
  n<-(matrix(g,N,N, byrow=TRUE) + matrix(g,N,N, byrow=FALSE))/2
  deltaC<-1-(1-pKin1[id, id])^(1/n)
  Neff<-round(1/(2*mean(deltaC)), 1)
  ECG<-round(mean(Summary$equiGen), 1)
  # L is generation time
  L<-1/(4*cont1$male[1])+1/(4*cont1$female[1])
  #
  mk<-round(rowMeans(pKin1, na.rm=TRUE, dims=1), 3)
  avg_mk<-round(mean(mk), 2)
  F<-round(2*diag(pKin1)-1.00, 3)
  avg_F<-round(mean(F), 2)
  #
  ub.pKin<-cand1$mean$pKin + (1-cand1$mean$pKin)*(1/(2*Ne*L))
  ub.pKinatN<-cand1$mean$pKinatN + (1-cand1$mean$pKinatN)*(1/(2*Ne*L))
  lb.NC<-cand1$mean$NC
  # Optimization for two cases
  # -Minimize kinship
  # -Minimize kinship at native alleles and minimize influence of
  # migrants by setting the mean native contribution as lower boundary. 
  con<-list(ub.pKin=ub.pKin)
  Offspring<-opticont("min.pKin", cand1, con, solver="slsqp", trace=FALSE)
  con<-list(ub.pKin=ub.pKin, ub.pKinatN=ub.pKinatN, lb.NC=lb.NC)
  Offspring2<-opticont("min.pKinatN", cand1, con, solver="slsqp", trace=FALSE)
  rbind(cand1$mean, Offspring$mean, Offspring2$mean)
  avg_mkatN<-round(cand1$mean$pKinatN, 2)
  FGE<-round((1/(2*avg_mk)), 1)
  NGE<-round((1/(2*avg_mkatN)), 1)
  Noc<-round((1/(2*Offspring$mean$pKin)), 1)
  NocatN<-round((1/(2*Offspring2$mean$pKinatN)), 1)
  valid<-Offspring2$info$valid
  #
  result<-rbind( c( cl, Nc, ECG, Ne, Neff, natNe, avg_mk, avg_F, FGE, Noc, NGE, NocatN, valid ) )
  cat( result, file=outfile1, append=TRUE )
  cat("\n", file=outfile1, append=TRUE )
  Summary$mk<-mk
  write.table(Summary, file=outfile2, sep=",", row.names=FALSE, col.names=FALSE, append=TRUE, quote=FALSE)
}
cat("\n", file=outfile1, append=TRUE )
#
# Explore Model-based clustering
#
BIC<-mclustBIC(input)
summary(BIC)
# Best BIC values:
#             VEV,6       VVV,6      VEE,9
# BIC      4121.841 4116.017249 4102.83346
# BIC diff    0.000   -5.823366  -19.00716
modl<-Mclust(input, G=6, x=BIC)
summary(modl, parameters=TRUE)
# ----------------------------------------------------
#  Gaussian finite mixture model fitted by EM algorithm 
# ----------------------------------------------------
# Mclust VEV (ellipsoidal, equal shape) model with 6 components: 
# 
# log-likelihood   n df      BIC      ICL
#       2152.954 462 30 4121.841 3913.464
#
# Clustering table:
#   1   2   3   4   5   6 
#  39 112 127  50  62  72 
#
# Mixing probabilities:
#         1         2         3         4         5         6 
# 0.1061757 0.2437805 0.2388504 0.1242555 0.1487566 0.1381813 
# 
# Means:
#         [,1]       [,2]       [,3]      [,4]       [,5]       [,6]
# mk 0.0542495 0.05994105 0.09810249 0.1018381 0.07464336 0.07140390
# F  0.1906052 0.05696548 0.13610290 0.1823116 0.12389009 0.08551682
#
# This becomes Figure 5B
#
par(mfrow=c(1,1))
nclust<-c(1:9)
plot(nclust, BIC[, 2], type="n", xlim=c(0.0, 10.0), ylim=c(3000, 4200), xlab="Nr. of clusters", ylab="BIC", font=2, font.lab=2 )
lines(nclust, BIC[, 2], type="l", col="black", lwd=1.5 )
lines(nclust, BIC[, 5], type="l", col="black", lwd=1.5 )
lines(nclust, BIC[, 8], type="l", col="black", lwd=1.5 )
lines(nclust, BIC[, 10], type="l", col="black", lwd=1.5 )
lines(nclust, BIC[, 12], type="l", col="black", lwd=1.5 )
lines(nclust, BIC[, 14], type="l", col="black", lwd=1.5 )
lines(nclust, BIC[, 2], type="p", pch=17, col="black", lwd=1.5 )
lines(nclust, BIC[, 5], type="p", pch=5, col="black", lwd=1.5 )
lines(nclust, BIC[, 8], type="p", pch=8, col="black", lwd=1.5 )
lines(nclust, BIC[, 10], type="p", pch=10, col="black", lwd=1.5 )
lines(nclust, BIC[, 12], type="p", pch=12, col="black", lwd=1.5 )
lines(nclust, BIC[, 14], type="p", pch=16, col="black", lwd=1.5 )
# text(8.5, 2100, "B", cex=2.0, pos=4, col="black")
legend(8, 3700, legend=c("VVI", "EVI", "EVE", "VVE", "VEV","VVV"),pch=c(17, 5, 8, 10, 12, 16))
# print the overall labels
mtext('Nr. of clusters', side = 1, outer = TRUE, line = 1, font=2)
mtext('BIC', side = 2, outer = TRUE, line = 2, font=2)
#
# Treat clusters as separate sub-populations and calculate 
# intra-cluster mk and F
#
cat( "Indiv, equiGen, fullGen, maxGen, PCI, Inbreeding, cluster, Sex, mk\n", file=outfile4, append=TRUE )
nc_final<-modl$G
for(cl in 1:nc_final) {
  gr<-unlist(attributes(modl$classification[modl$classification==cl]))
  gr<-as.character(gr)
  Nc<-length(gr)
  Summary<-summary(Pedig, keep.only=Pedig$Indiv %in% gr)
  Summary$cluster<-cl
  Summary$Sex<-Pedig$Sex[Pedig$Indiv %in% gr]
  #
  use1<-Pedig$Indiv %in% gr
  use1<-use1 & Summary$equiGen>=3
  cont1<-agecont(Pedig, use1, maxAge=8)
  Phen1<-Pedig[use1, ]
  #
  pKin1<-pedIBD(Pedig, keep.only=Phen1$Indiv)
  pKinatN1<-pedIBDatN(Pedig, thisBreed="SIA", keep.only=Phen1$Indiv, nGen=6)
  natNe<-attributes(pKinatN1)$nativeNe
  Phen1$Born<-1
  cand1<-candes(phen=Phen1, pKin=pKin1, pKinatN=pKinatN1, cont=NULL)
  #
  sex_tbl<-table(Phen1$Sex)
  Nm<-as.integer(sex_tbl[2])
  Nf<-as.integer(sex_tbl[1])
  Ne<-as.integer(4*Nm*Nf/(Nm+Nf))
  # Alternatively, calculate Neff according to Cervantes et al. (2011)
  # This does not work because of historic ingression
  id<-Phen1$Indiv
  g<-Summary[id, "equiGen"]
  N<-length(g)
  n<-(matrix(g,N,N, byrow=TRUE) + matrix(g,N,N, byrow=FALSE))/2
  deltaC<-1-(1-pKin1[id, id])^(1/n)
  Neff<-round(1/(2*mean(deltaC)), 1)
  ECG<-round(mean(Summary$equiGen), 1)
  # L is generation time
  L<-1/(4*cont1$male[1])+1/(4*cont1$female[1])
  #
  mk<-round(rowMeans(pKin1, na.rm=TRUE, dims=1), 3)
  avg_mk<-round(mean(mk), 2)
  F<-round(2*diag(pKin1)-1.00, 3)
  avg_F<-round(mean(F), 2)
  #
  ub.pKin<-cand1$mean$pKin + (1-cand1$mean$pKin)*(1/(2*Ne*L))
  ub.pKinatN<-cand1$mean$pKinatN + (1-cand1$mean$pKinatN)*(1/(2*Ne*L))
  lb.NC<-cand1$mean$NC
  # Optimization for two cases
  # -Minimize kinship
  # -Minimize kinship at native alleles and minimize influence of
  # migrants by setting the mean native contribution as lower boundary. 
  con<-list(ub.pKin=ub.pKin)
  Offspring<-opticont("min.pKin", cand1, con, solver="slsqp", trace=FALSE)
  con<-list(ub.pKin=ub.pKin, ub.pKinatN=ub.pKinatN, lb.NC=lb.NC)
  Offspring2<-opticont("min.pKinatN", cand1, con, solver="slsqp", trace=FALSE)
  rbind(cand1$mean, Offspring$mean, Offspring2$mean)
  avg_mkatN<-round(cand1$mean$pKinatN, 2)
  FGE<-round((1/(2*avg_mk)), 1)
  NGE<-round((1/(2*avg_mkatN)), 1)
  Noc<-round((1/(2*Offspring$mean$pKin)), 1)
  NocatN<-round((1/(2*Offspring2$mean$pKinatN)), 1)
  valid<-Offspring2$info$valid
  #
  result<-rbind( c( cl, Nc, ECG, Ne, Neff, natNe, avg_mk, avg_F, FGE, Noc, NGE, NocatN, valid ) )
  cat( result, file=outfile3, append=TRUE )
  cat("\n", file=outfile3, append=TRUE )
  Summary$mk<-rowMeans(pKin1, na.rm=TRUE)
  write.table(Summary, file=outfile4, sep=",", row.names=FALSE, col.names=FALSE, append=TRUE, quote=FALSE)
}
cat("\n", file=outfile3, append=TRUE )
#