.packageName <- "hierfstat"
boot.vc<-function(levels = levels, loci = loci, diploid = TRUE,nboot=1000,quant=c(0.025,0.5,0.975))
{
gf<-function(dat,num,den){sum(dat[num])/sum(dat[den])}
nloc<-dim(loci)[2]
if (nloc<5) {stop("Not enough loci to bootstrap. Exiting")}
x<-varcomp.glob(levels=levels,loci=loci,diploid=diploid)
x.loc<-data.frame(x$loc)
nlev<-dim(x.loc)[2]
names(x.loc)<-names(x$overall)
mat.boot<-data.frame(matrix(rep(0,nboot*nlev),ncol=nlev))
for (i in 1:nboot) {
mat.boot[i,]<-apply(x.loc[sample(nloc,replace=TRUE),],2,sum)
}
nam<-vector(length=nlev+1)
nam[-1]<-names(x.loc)
nam[1]<-"Total"
names(mat.boot)<-names(x.loc)
mat.res<-data.frame(matrix(rep(0,nboot*(nlev*(nlev+1)/2)),nrow=nboot))
names.res<-vector(length=nlev*(nlev+1)/2)
mat.res[,1]<-apply(mat.boot,1,sum)
acc<-0
for (i in 1:(nlev-1)){
acc<-acc+1
mat.res[,acc]<-apply(mat.boot[,c(i:nlev)],1,sum)/nloc
names.res[acc]<-paste("H-",nam[i],sep="")
for(j in i:(nlev-1)){
acc<-acc+1
mat.res[,acc]<-apply(mat.boot,1,gf,num=i:j,den=i:nlev)
names.res[acc]<-paste("F-",nam[j+1],"/",nam[i],sep="")
}
}
acc<-acc+1
mat.res[,acc]<-mat.boot[,nlev]/nloc
names.res[acc]<-"Hobs"
names(mat.res)<-names.res
return(list(boot=mat.boot,res=mat.res,ci=apply(mat.res,2,quantile,quant)))
}
"g.stats" <-
function (data, diploid = TRUE) 
{
    y <- data[, 2]
    x <- data[, 1]
    dum <- !is.na(y)
    if (diploid) {
        y <- genot2al(y[dum])
        x <- rep(x[dum], 2)
    }
    else {
        x <- x[dum]
        y <- y[dum]
    }
    obs <- table(x, y)
    nt <- sum(obs)
    s.r <- apply(obs, 1, sum)
    s.c <- apply(obs, 2, sum)
    expe <- s.r %*% t(s.c)/nt
    x.squared <- sum((obs - expe)^2/expe, na.rm = TRUE)
    g.stats <- 2 * sum(obs * log(obs/expe), na.rm = TRUE)
    list(obs = obs, expe = expe, x.squared = x.squared, g.stats = g.stats)
}
"g.stats.glob" <-
function (data, diploid = TRUE) 
{
    dum <- (1:dim(data)[1])[complete.cases(data[, -1])]
    nl <- dim(data)[2] - 1
    g.stats.l <- vector(length = nl)
    g.stats <- 0
    for (i in 1:nl) {
        if (diploid) {
            y <- genot2al(data[dum, (i + 1)])
            x <- rep(data[dum, 1], 2)
        }
        else {
            x <- data[dum, 1]
            y <- data[dum, i + 1]
        }
        obs <- table(x, y)
        nt <- sum(obs)
        s.r <- apply(obs, 1, sum)
        s.c <- apply(obs, 2, sum)
        expe <- s.r %*% t(s.c)/nt
        g.stats.l[i] <- 2 * sum(obs * log(obs/expe), na.rm = TRUE)
    }
    g.stats <- sum(g.stats.l)
    list(g.stats.l = g.stats.l, g.stats = g.stats)
}
"genot2al" <-
function (y) 
{
    if (max(y, na.rm = TRUE) <= 100) {
        modulo <- 10
    }
    else {
        if (max(y, na.rm = TRUE) <= 10000) {
            modulo <- 100
        }
        else modulo <- 1000
    }
    al1 <- y%/%modulo
    al2 <- y%%modulo
    y.al <- c(al1, al2)
    return(y.al)
}
"prepdata" <-
function (data) 
{
    nbl <- dim(data)[2]
    names.data <- names(data)
    x <- matrix(rep(0, dim(data)[1] * dim(data)[2]), ncol = dim(data)[2])
    for (i in nbl:2) {
        dumtext <- parse(text = paste("table(", paste("data[,", 
            i:2, "],", sep = "", collapse = ""), "data[,1])", 
            sep = "", collapse = ""))
        dum <- unlist(as.vector(eval(dumtext)))
        dum1 <- dum[dum > 0]
        x[, i] <- rep(1:length(dum1), dum1)
    }
    dum <- unlist(as.vector(table(data[, 1])))
    dum1 <- dum[dum > 0]
    x[, 1] <- rep(1:length(dum1), dum1)
    x <- data.frame(x)
    names(x) <- names.data
    return(x)
}
"read.fstat.data" <-
function (filename, nloc, na.s = "0") 
{
    lnames <- as.vector(read.table(filename, skip = 1, nrows = nloc)[, 
        1])
    lnames <- c("Pop", lnames)
    dat <- read.table(filename, skip = nloc + 1, na.strings = na.s)
    names(dat) <- lnames
    return(dat)
}
"varcomp" <-
function (data, diploid = TRUE) 
{
    vcomp <- function(y1) {
        ss <- vector(length = nblevels)
        for (i in 1:nblevels) ss[i] <- sum(tapply(y1, ndata[, 
            i], sum)^2/table(ndata[, i]))
        temp1 <- c(sum(y1)^2/length(y1), ss)
        vec.c.ss <- temp1[2:length(temp1)] - temp1[1:(length(temp1) - 
            1)]
        meansq <- vec.c.ss/dfreed
        vc <- solve(k, meansq)
        return(vc)
    }
    nbf <- dim(data)[2] - 1
    x <- NULL
    if (nbf > 1) 
        for (i in 1:(nbf - 1)) x <- paste(x, paste("data[,", 
            i, "],", sep = "", collapse = ""))
    no <- eval(parse(text = paste("order(", x, "data[,", nbf, 
        "])")))
    data <- data[no, ]
    y <- data[, dim(data)[2]]
    dum <- !is.na(y)
    expl <- prepdata(cbind(data[dum, -dim(data)[2]], 1:dim(data[dum, 
        ])[1]))
    if (diploid) {
        expl <- rbind(expl, expl)
        ny <- genot2al(y[dum])
        al <- 1:length(ny)
        ndata <- data.frame(expl, al, ny)
    }
    else {
        ndata <- data.frame(expl, y[dum])
    }
    rm(y)
    y <- ndata[, dim(ndata)[2]]
    nblevels <- dim(ndata)[2] - 1
    names.al <- names(table(y))
    y <- as.numeric(y)
    id.al <- as.numeric(names(table(y)))
    nal <- length(id.al)
    resp <- as.numeric(y == id.al[1])
    for (i in 2:nal) resp <- cbind(resp, as.numeric(y == id.al[i]))
    n <- vector(length = (nblevels))
    for (i in 1:nblevels) n[i] <- max(ndata[, i])
    n <- c(1, n)
    dfreed <- n[2:(nblevels + 1)] - n[1:nblevels]
    k <- matrix(rep(0, (nblevels)^2), ncol = (nblevels))
    x <- rep(1, length(ndata[, 1]))
    for (i in 1:nblevels) x <- cbind(x, ndata[, i])
    dum <- list()
    temp <- rep(1, length(y))
    for (i in 1:nblevels) dum[[i]] <- tapply(temp, x[, i], sum)
    dum[[(nblevels + 1)]] <- temp
    for (i in 2:nblevels) {
        for (j in i:nblevels) {
            temp <- length(table(x[, (i - 1)]))
            thisdum <- vector(length = 0)
            for (jj in 1:temp) thisdum <- c(thisdum, as.vector(rep(dum[[i - 
                1]][jj], length(table(x[, j][x[, (i - 1)] == 
                jj])))))
            a <- sum(dum[[j]]^2/thisdum)
            temp <- length(table(x[, i]))
            thisdum <- vector(length = 0)
            for (jj in 1:temp) thisdum <- c(thisdum, as.vector(rep(dum[[i]][jj], 
                length(table(x[, j][x[, i] == jj])))))
            b <- sum(dum[[j]]^2/thisdum)
            k[(i - 1), (j - 1)] <- (b - a)/dfreed[(i - 1)]
        }
    }
    k[, (nblevels)] <- 1
    res <- apply(resp, 2, vcomp)
    res <- data.frame(res)
    names(res) <- names.al
    res <- t(res)
    tot <- apply(res, 2, sum)
    f <- matrix(rep(0, (nblevels - 1)^2), ncol = (nblevels - 
        1))
    for (i in 1:(nblevels - 1)) {
        for (j in i:(nblevels - 1)) {
            f[i, j] <- sum(tot[i:j])/sum(tot[i:nblevels])
        }
    }
    return(list(df = dfreed, k = k, res = res, overall = tot, 
        F = f))
}
"varcomp.glob" <-
function (levels = levels, loci = loci, diploid = TRUE) 
{
    lnames <- names(loci)
    if (is.null(dim(levels))) {
        fnames <- "Pop"
    }
    else fnames <- names(levels)
    if (diploid) {
        fnames <- c(fnames, "Ind")
    }
    res <- varcomp(cbind(levels, loci[, 1]),diploid)$overall
    nloc <- dim(loci)[2]
    for (i in 2:nloc) res <- rbind(res, varcomp(cbind(levels, 
        loci[, i]),diploid)$overall)
    tot <- apply(res, 2, sum, na.rm = TRUE)
    nblevels <- length(tot)
    f <- matrix(rep(0, (nblevels - 1)^2), ncol = (nblevels - 
        1))
    for (i in 1:(nblevels - 1)) {
        for (j in i:(nblevels - 1)) {
            f[i, j] <- sum(tot[i:j])/sum(tot[i:nblevels])
        }
    }
    fnames
    row.names(res) <- lnames
    names(tot) <- c(fnames, "Error")
    tf <- t(f)
    row.names(tf) <- fnames
    f <- t(tf)
    row.names(f) <- c("Total", fnames[-length(fnames)])
    return(list(loc = res, overall = tot, F = f))
}
"samp.between" <-
function (lev) 
{
    y <- 1:length(lev)
    nlev <- nlevels(factor(lev))
    nl <- 1:nlev
    x <- list()
    for (i in 1:nlev) x[[i]] <- y[lev == i]
    dum <- sample(nl)
    return(unlist(x[dum]))
}
"samp.between.within" <-
function (inner.lev, outer.lev) 
{
    y <- 1:length(inner.lev)
    nlev.o <- nlevels(factor(outer.lev))
    z <- NULL
    for (j in 1:nlev.o) {
        lev.i <- as.integer(levels(factor(inner.lev[outer.lev == 
            j])))
        x <- list()
        if (length(lev.i) == 1) {
            z[[j]] <- y[inner.lev == lev.i]
        }
        else {
            for (i in 1:length(lev.i)) x[[i]] <- y[inner.lev == 
                lev.i[i]]
            dum <- sample(1:length(lev.i))
            z[[j]] <- unlist(x[dum])
        }
    }
    return(unlist(z))
}
"samp.within" <-
function (lev) 
{
    y <- 1:length(lev)
    nlev <- nlevels(factor(lev))
    nl <- as.integer(factor(lev))
    x <- list()
    for (i in 1:nlev) if (length(y[nl==i])>1) x[[i]] <- sample(y[nl == i]) else x[[i]]<-y[nl==i]
    return(unlist(x))
}
"test.between" <-
function (data = data, test.lev, rand.unit, nperm = 100, ...) 
{
    get.g <- function(x, data, ...) {
        g.stats.glob(data.frame(x, data), ...)$g.stats
    }
    test.lev<-as.integer(factor(test.lev))
    rand.unit<-as.integer(factor(paste(test.lev,"X",rand.unit,sep="")))
    x<-order(test.lev,rand.unit)
    data<-data.frame(data[x,])
    test.lev<-test.lev[x]
    rand.unit<-rand.unit[x]
#    runit<-paste(test.lev,rand.unit,sep="")
#    runit<-rep(1:dim(table(runit)),c(table(runit)))
#    nobs <- length(runit)
    perm.stat <- vector(length = nperm)
    perm.stat[nperm] <- get.g(test.lev, data, ...)
    for (i in 1:(nperm - 1)) {
        perm.stat[i] <- get.g(test.lev, data[samp.between(rand.unit), 
            ], ...)
    }
    list(g.star = perm.stat, p.val = sum(perm.stat >= perm.stat[nperm])/nperm)
}
"test.between.within" <-
function (data = data, within, test.lev, rand.unit, nperm = 100, 
    ...) 
{
    get.g <- function(x, data, ...) {
        g.stats.glob(data.frame(x, data), ...)$g.stats
    }
    within<-as.integer(factor(within))
    test.lev<-as.integer(factor(paste(within,"X",test.lev,sep="")))
    rand.unit<-as.integer(factor(paste(within,"X",test.lev,"Y",rand.unit,sep="")))
    x<-order(within,test.lev,rand.unit)
    data<-data.frame(data[x,])
    within<-within[x]
    test.lev<-test.lev[x]
    rand.unit<-rand.unit[x]
#    tlev<-paste(within,test.lev,sep="")#
#    runit<-paste(tlev,rand.unit,sep="")#
#    tlev<-rep(1:dim(table(tlev)),c(table(tlev)))
#    runit<-rep(1:dim(table(runit)),c(table(runit)))
#    nobs <- length(test.lev)
    perm.stat <- vector(length = nperm)
    perm.stat[nperm] <- get.g(test.lev, data, ...)
    for (i in 1:(nperm - 1)) {
        perm.stat[i] <- get.g(test.lev, data[samp.between.within(inner.lev = rand.unit, 
            outer.lev = within), ], ...)
    }
    list(g.star = perm.stat, p.val = sum(perm.stat >= perm.stat[nperm])/nperm)
}
"test.g" <-
function (data = data, level, nperm = 100, ...) 
{
    get.g <- function(x, data, ...) {
        g.stats.glob(data.frame(x, data), ...)$g.stats
    }
#    nobs <- length(level)
    perm.stat <- vector(length = nperm)
    perm.stat[nperm] <- get.g(level, data, ...)
    for (i in 1:(nperm - 1)) {
        perm.stat[i] <- get.g(sample(level), data[, ], ...)
    }
    list(g.star = perm.stat, p.val = sum(perm.stat >= perm.stat[nperm])/nperm)
}
"test.within" <-
function (data = data, within, test.lev, nperm = 100, ...) 
{
    get.g <- function(x, data, ...) {
        g.stats.glob(data.frame(x, data), ...)$g.stats
    }
    within<-as.integer(factor(within))
    test.lev<-as.integer(factor(paste(within,"X",test.lev,sep="")))
    x<-order(within,test.lev)
    data<-data.frame(data[x,])
    within<-within[x]
    test.lev<-test.lev[x]
#    tlev<-paste(within,test.lev,sep="")
#    tlev<-rep(1:dim(table(tlev)),c(table(tlev)))
#    nobs <- length(test.lev)
    perm.stat <- vector(length = nperm)
    perm.stat[nperm] <- get.g(test.lev, data, ...)
    for (i in 1:(nperm - 1)) {
        perm.stat[i] <- get.g(test.lev, data[samp.within(within), 
            ], ...)
    }
    list(g.star = perm.stat, p.val = sum(perm.stat >= perm.stat[nperm])/nperm)
}
