.packageName <- "Biodem"
"Fst" <- function(rval,N){
  k<-N/sum(N)
  Fst.val<-k%*%diag(rval)
}
"col.sto" <- function(x){
  y<-apply(x,2,sum)
  x1<-t(t(x)/y)
  x1
}
hedrick <- function(x){
  somme <- colSums(x)
  M <- matrix(data=0,nrow=length(somme),ncol=length(somme))
  rownames(M) <- dimnames(x)[[2]]
  colnames(M) <- dimnames(x)[[2]]
  for(i in 1:length(somme)){
    for(j in 1:length(somme)){
      M[i,j] <- (sum((x[,i]/somme[i])*(x[,j]/somme[j])))/
        (0.5*(sum((x[,i]/somme[i])^2+(x[,j]/somme[j])^2)))
    }
  }
  M
}


lasker <- function(x){
  somme <- colSums(x)
  M <- matrix(data=0,nrow=length(somme),ncol=length(somme))
  rownames(M) <- dimnames(x)[[2]]
  colnames(M) <- dimnames(x)[[2]]
  for(i in 1:length(somme)){
    for(j in 1:length(somme)){
      M[i,j] <- (sum(x[,i]*x[,j]))/(2*(somme[i]*somme[j]))
    }
  }
  M
}

mal.cond <- function(PHI,N){
  k<-N/sum(N) ## the relative population of each k populaion on the total population of the area in study
  rmu<-PHI%*%k ## k is a list, corced to vertical vector. Here I calculate the row wheight phi mean
  mu<-k%*%rmu ## k is now coerced to a linear vector. Here I calculated the overall mean phi
  az<-matrix(rep(rmu,length(rmu)),ncol=length(rmu))
  ax<-az+t(az)
  mu<-as.numeric(mu)
  r.mat<-(PHI+mu-ax)/(1-mu)
}
mal.eq <- function(S,P,N){
  phi<-diag(0/N)
  Pt<-t(P)
  x<-0
  repeat{
    x<-x+1
    S1<-mtx.exp(S,x)
    P1<-mtx.exp(P,x)
    Pt1<-mtx.exp(Pt,x)
    D<-(1-phi)/(2*N)
    D<-diag(D)
    D<-diag(D) ## everything till here is similar to a normal phi calculation
    toll<-phi ## I use toll as a comparison mark. toll is phi a n-1 cycles
    toll1<-signif(toll,6) ## optional. I set the number of significant digits to 6
    phi<-phi+(S1%*%Pt1%*%D%*%P1%*%S1) ## that's phi at n cycles
    phi1<-signif(phi,6) ## optional. As for toll
    if (identical(toll1,phi1)){ ## logical condition. If toll (that is, phi for n-1) and phi are identical
      return(x-1) ## return the value of n-1
      break ## and stop, because the Malecot model has reached its asymptot
    }
  }
}
mal.phi <- function(S,P,N,n){
  if (n < 1){
    return("Number of cycles too low!!!")
  }
  phi<-diag(0/N) ## creating the first phi matrix
  Pt<-t(P)
  x<-0 ## needed for a correct counting cycle
  for (i in 1:n){
    x<-x+1 ## start the counting cycle
    S1<-mtx.exp(S,x) ## powering S
    P1<-mtx.exp(P,x) ## powering P
    Pt1<-mtx.exp(Pt,x) ## powering the transpose of P
    D<-(1-phi)/(2*N) ## calculating the diagonal of the D matrix
    D<-diag(D) ## extracting the diagonal of the above
    D<-diag(D) ## creating the REAL D matix, which is a diagonal matrix
    phi<-phi+(S1%*%Pt1%*%D%*%P1%*%S1) ## Malecot model
  }
}
mar.iso=function(x){
  Pt=rep(0,dim(x)[3])
  Pr=rep(0,dim(x)[3])
  for(i in 1:dim(x)[3]){
    Pt[i]=(sum(diag(x[,,i])))/sum(x[,,i])
    Pr[i]=(sum(rowSums(x[,,i])* colSums(x[,,i])))/
      ((sum(rowSums(x[,,i])))*(sum(colSums(x[,,i]))))
  }
  pop=dimnames(x)[[3]]
  data.frame(pop,Pt,Pr)
}
"mtx.exp" <- function(X,n){
## Function to calculate the n-th power of a matrix X
  if(n != round(n)) {
    n <- round(n)
    warning("rounding exponent `n' to", n)
  }
  phi <- diag(nrow = nrow(X))
  pot <- X # the first power of the matrix.
  while (n > 0)
    {
      if (n %% 2)
        phi <- phi %*% pot
      n <- n %/% 2
      pot <- pot %*% pot
    }
  return(phi)
}
r.pairs = function(x){
  RP = rep(0,dim(x)[3])
  RPr = rep(0,dim(x)[3])
  perc.diff = rep(0,dim(x)[3])
  for (i in 1:dim(x)[3]){
    RP[i] = (sum(x[,,i]*(x[,,i]-1)))/(sum(x[,,i])*(sum(x[,,i])-1))
    RPr[i] = (((1/(sum(x[,,i])*(sum(x[,,i])-1)))
               *sum((rowSums(x[,,i]))^2))-(1/(sum(x[,,i])-1)))*
                 (((1/(sum(x[,,i])*(sum(x[,,i])-1)))
                   *sum((colSums(x[,,i]))^2))-(1/(sum(x[,,i])-1)))
    perc.diff[i] = ((RP[i]-RPr[i])/RPr[i])
  }
 pop = dimnames(x)[[3]]
  data.frame(pop,RP,RPr,perc.diff)
}
rel.cond <- function(x,R,method="A"){
  metodi <- c("A","B")
  method <- pmatch(method, metodi)
  if (is.na(method))
    stop("not valid method")
  if (method==1){
    x1 <- (x-R)/(4-R)
    x1
  }
  else{
    x1 <- (x-R)/(4*(1-R))
    x1
  }
}
rel.phi <- function(x,R,method="A"){
  metodi <- c("A","B")
  method <- pmatch(method, metodi)
  if (is.na(method))
    stop("not valid method")
  if (method==1){
    x1 <- x/4
    x1
  }
  else{
    x1 <- x/4+(3*R*((x-R))/(16*(1-R)))
    x1
  }
}
rri <- function(x){
  somme <- colSums(x)
  x1 <- uri(x)
  dg <- diag(x1)
  conta <- matrix(0, nrow = nrow(x1), ncol = ncol(x1))
  preI1 <- rep(0, length(dg))
  for(i in 1:length(dg)){
    preI1[i] <- (dg[i]*somme[i]*(somme[i]-1))
    I1 <- sum(preI1)
  }
  ## print(I1)

  for(i in 1:nrow(x1)){
    for(j in 1:ncol(x1)){
      if(i!=j)
        conta[i,j]<- (x1[i,j]*somme[i]*somme[j])
      else
        conta[i,j]=0}
    conta
  }
  preI2 <- rowSums(conta)
  I2 <- sum(preI2)
  ## print(I2)

  R <- (I1 + I2)/(sum(somme) * (sum(somme)-1))
  ## print(R)
}
sur.freq = function(x,pop,mal.sur,fem.sur,freq.table="total"){
  attach(x)
  pop = factor(pop)
  sur.lev = union(levels(mal.sur),levels(fem.sur))
  mal.sur = factor(mal.sur,levels=sur.lev)
  fem.sur = factor(fem.sur,levels=sur.lev)
  tables = c("males","females","total","marriages")
  freq.table = pmatch(freq.table,tables)
  if (is.na(freq.table)) 
    stop("this one does not exist!")
  if (freq.table==1)
    tab=table(mal.sur,pop)
 if (freq.table==2)
   tab=table(fem.sur,pop)
 if (freq.table==3){
   tot.sur = data.frame(c(as.character(mal.sur),as.character(fem.sur)),rep(pop,2))
   names(tot.sur) = NULL
   names(tot.sur) = c("surname","pop")
   tab = table(tot.sur$surname,tot.sur$pop)
 }
  if (freq.table==4)
    tab = table(mal.sur,fem.sur,pop)
  detach(x)
  tab
}
sur.inbr = function(x,method="B"){
  metodi = c("A","B")
  method = pmatch(method, metodi)
  if (is.na(method)) 
    stop("not valid method")
  if (method==1){
    Ft = x$Pt/4
    Fr = x$Pr/4
    Fn = (x$Pt-x$Pr)/(4-x$Pr)
    data.frame(x$pop,Ft,Fr,Fn)
  }
  else{
    Ft = x$Pt/4+(3*x$Pr*(x$Pt-x$Pr))/(16*(1-x$Pr))
    Fr = x$Pr/4
   Fn = (x$Pt-x$Pr)/(4*(1-x$Pr))
    data.frame(x$pop,Ft,Fr,Fn)
  }
}
"sym.P" <- function(x){
  alpha<-x[upper.tri(x)]
  x1<-t(x)
  beta<-x1[upper.tri(x1)]
  gamma<-(alpha+beta)/2
  x[upper.tri(x)]<-gamma
  x2<-t(x)
  x[lower.tri(x)]<-x2[lower.tri(x2)]
  x
}
uri <- function(x){
  somme <- colSums(x)
  M <- matrix(data=0,nrow=length(somme),ncol=length(somme))
  for(i in 1:length(somme)){
    for(j in 1:length(somme)){
      if(i==j)
        M[i,j] <- (sum(x[,i]*(x[,i]-1)))/(somme[i]*(somme[i]-1))
      else
        M[i,j] <- (sum(x[,i]*x[,j]))/(somme[i]*somme[j])
    }
  }
  M
}
