.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)
    rows<-complete.cases(x.loc)
    if(sum(rows)<5){
	stop("Not enough polymorphic loci to bootstrap. Exiting")
    }
    nloc<-sum(rows)
    x.loc<-x.loc[rows,]
    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 = round(mat.boot,digits=4), res = round(mat.res,digits=4), ci = round(apply(mat.res, 2, quantile, quant),digits=4)))
}

"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
            d1<-y%/%modulo
            d2<-y%%modulo
            if (min(d1,na.rm=TRUE)>9 & max(d2,na.rm=TRUE)<10) modulo<-1000
         }
        else modulo <- 1000
    }
    al1 <- y%/%modulo
    al2 <- y%%modulo
    y.al <- c(al1, al2)
    return(y.al)
}
"prepdata" <-
function (data) 
{
#remove calls to names.data, apparently does not do anything
    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)
}
