ansari.test <- function(x, y, alternative = "two.sided", exact = NULL) {

    CHOICES <- c("two.sided", "less", "greater")
    alternative <- CHOICES[pmatch(alternative, CHOICES)]
    if (length(alternative) > 1 || is.na(alternative)) 
        stop("alternative must be \"two.sided\", \"less\" or \"greater\"")

    DNAME <- paste(deparse(substitute(x)), "and", deparse(substitute(y)))

    x <- x[complete.cases(x)]
    y <- y[complete.cases(y)]
    m <- length(x)
    if (m < 1)
        stop("not enough x observations")
    n <- length(y)
    if (n < 1)
        stop("not enough y observations")
    N <- m + n

    r <- rank(c(x, y))
    STATISTIC <- sum(pmin(r, N - r + 1)[seq(along = x)])
    TIES <- (length(r) != length(unique(r)))

    if (is.null(exact))
        exact <- ((m < 50) && (n < 50))

    if (exact && !TIES) {
        pansari <- function(q, m, n) {
            .C("pansari",
               as.integer(length(q)),
               p = as.double(q),
               as.integer(m),
               as.integer(n))$p
        }
        PVAL <-
            switch(alternative,
                   "two.sided" = {
                       if (STATISTIC > ((m + 1)^2 %/% 4
                                        + ((m * n) %/% 2) / 2))
                           p <- 1 - pansari(STATISTIC - 1, m, n)
                       else
                           p <- pansari(STATISTIC, m, n)
                       min(2 * p, 1)
                   },
                   "greater" = 1 - pansari(STATISTIC - 1, m, n),
                   "less" = pansari(STATISTIC, m, n))
    } else {
        EVEN <- ((N %% 2) == 0)
        z <- if (EVEN)
            STATISTIC - m * (N + 2) / 4
        else
            STATISTIC - m * (N + 1)^2 / (4 * N)
        if (!TIES) {
            SIGMA <- if (EVEN)
                sqrt((m * n * (N + 2) * (N - 2)) / (48 * (N - 1)))
            else
                sqrt((m * n * (N + 1) * (3 + N^2)) / (48 * N^2))
        } else {
            r <- rle(sort(pmin(r, N - r + 1)))
            SIGMA <- if (EVEN)
                sqrt(m * n * (16 * sum(r$l * r$v^2) - N * (N + 2)^2)
                     / (16 * N * (N - 1)))
            else
                sqrt(m * n * (16 * N * sum(r$l * r$v^2) - (N + 1)^4)
                     / (16 * N^2 * (N - 1)))
        }
        p <- pnorm(z / SIGMA)
        PVAL <- switch(alternative,
                       "two.sided" = 2 * min(p, 1 - p),
                       "greater" = 1 - p,
                       "less" = p)
        if (exact && TIES)
            warning("Cannot compute exact p-value with ties")
    }

    names(STATISTIC) <- "AB"
    RVAL <- list(statistic = STATISTIC,
                 p.value = PVAL,
                 alternative = alternative,
                 method = "Ansari-Bradley test",
                 data.name = DNAME)
    class(RVAL) <- "htest"
    return(RVAL)
}
bartlett.test <- function(x, g) {
    LM <- FALSE
    if (is.list(x)) {
        if (length(x) < 2)
            stop("x must be a list with at least 2 elements")
        DNAME <- deparse(substitute(x))
        if (all(sapply(x, function(obj) inherits(obj, "lm"))))
            LM <- TRUE
        else
            x <- lapply(x, function(x) x <- x[is.finite(x)])
        k <- length(x)
    }
    else {
        if (length(x) != length(g))
            stop("x and g must have the same length")
        DNAME <- paste(deparse(substitute(x)), "and",
                       deparse(substitute(g)))
        OK <- complete.cases(x, g)
        x <- x[OK]
        g <- as.factor(g[OK])
        k <- nlevels(g)
        if (k < 2)
            stop("all observations are in the same group")
        x <- split(x, g)
    }

    if (LM) {
        n <- sapply(x, function(obj) obj$df.resid)
        v <- sapply(x, function(obj) sum(obj$residuals^2))
    } else {
        n <- sapply(x, "length") - 1
        if (any(n <= 0))
            stop("there must be at least 2 observations in each group")
        v <- sapply(x, "var")
    }

    n.total <- sum(n)
    v.total <- sum(n * v) / n.total
    STATISTIC <- ((n.total * log(v.total) - sum(n * log(v))) /
                  (1 + (sum(1 / n) - 1 / n.total) / (3 * (k - 1))))
    names(STATISTIC) <- "Bartlett's K-square"
    PARAMETER <- k - 1
    names(PARAMETER) <- "df"
  
    RVAL <- list(statistic = STATISTIC,
                 parameter = PARAMETER,
                 p.value = 1 - pchisq(STATISTIC, PARAMETER),
                 data.name = DNAME,
                 method = "Bartlett test for homogeneity of variances")
    class(RVAL) <- "htest"
    return(RVAL)
}
binom.test <- function(x, n, p = 0.5, alternative = "two.sided") {
    if ((length(n) > 1) || is.na(n) || (n < 1) || (n != round(n)))
        stop("n must be a positive integer")
    if ((length(x) > 1) || is.na(x) ||
        (x < 0) || (x > n) || (x != round(x)))
        stop("x must be an integer between 0 and n")
    if (!missing(p) && (length(p) > 1 || is.na(p) || p < 0 || p > 1))
        stop ("p must be a single number between 0 and 1")

    CHOICES <- c("two.sided", "less", "greater")
    alternative <- CHOICES[pmatch(alternative, CHOICES)]
    if (length(alternative) > 1 || is.na(alternative))
        stop ("alternative must be \"two.sided\", \"less\" or \"greater\"")

    DNAME <- paste(deparse(substitute(x)), "and", deparse(substitute(n)))

    PVAL <- switch(alternative,
                   less = pbinom(x, n, p),
                   greater = 1 - pbinom(x - 1, n, p),
                   two.sided = {
                       if (p == 0)
                           (x == 0)
                       else if (p == 1)
                           (x == n)
                       else {
                           d <- dbinom(x, n, p)
                           if (x / n < p) {
                               i <- seq(from = x + 1, to = n)
                               y <- sum(dbinom(i, n, p) <= d)
                               pbinom(x, n, p) +
                                   (1 - pbinom(n - y, n, p))
                           } else {
                               i <- seq(from = 0, to = x - 1)
                               y <- sum(dbinom(i, n, p) <= d)
                               pbinom(y - 1, n, p) +
                                   (1 - pbinom(x - 1, n, p))
                           }
                       }
                   })
  
    names(x) <- "number of successes"	# or simply "x" ??
    names(n) <- "number of trials"	# or simply "n" ??
    names(p) <- "probability of success"# or simply "p" ??

    structure(list(statistic = x,
                   parameter = n,
                   p.value = PVAL,
                   null.value = p,
                   alternative = alternative,
                   method = "Exact binomial test",
                   data.name = DNAME),
              class = "htest")
}
cor.test <- function(x, y, alternative = "two.sided", method = "pearson",
                     exact = NULL) 
{
    CHOICES <- c("two.sided", "less", "greater")
    alternative <- CHOICES[pmatch(alternative, CHOICES)]
    if (length(alternative) > 1 || is.na(alternative)) 
        stop("alternative must be \"two.sided\", \"less\" or \"greater\"")

    CHOICES <- c("pearson", "kendall", "spearman")
    method <- CHOICES[pmatch(method, CHOICES)]
    if (length(method) > 1 || is.na(method)) 
        stop("method must be \"pearson\", \"kendall\" or \"spearman\"")

    DNAME <- paste(deparse(substitute(x)), "and",
                   deparse(substitute(y)))
    
    if (length (x) != length (y))
        stop ("x and y must have the same length")
    OK <- complete.cases(x, y)
    x <- x[OK]
    y <- y[OK]
    n <- length(x)

    PVAL <- NULL
    NVAL <- 0

    if (method == "pearson") {
        if (n < 3)
            stop("not enough finite observations")
        method <- "Pearson's product-moment correlation"
        names(NVAL) <- "correlation"
        r <- cor(x, y)
        ESTIMATE <- r
        names(ESTIMATE) <- "cor"
        PARAMETER <- n - 2
        names(PARAMETER) <- "df"
        STATISTIC <- sqrt(PARAMETER) * r / sqrt(1 - r^2)
        names(STATISTIC) <- "t"
        p <- pt(STATISTIC, PARAMETER)
    }
    else {
        if (n < 2)
            stop("not enough finite observations")
        PARAMETER <- NULL
        if (method == "kendall") {
            method <- "Kendall's rank correlation tau"
            names(NVAL) <- "tau"
            TIES <- (min(length(unique(x)), length(unique(y))) < n)
            x <- rank(x)
            y <- rank(y)
            ESTIMATE <- .C("kendall_tau",
                           as.integer(length(x)),
                           as.double(x),
                           as.double(y),
                           tau = as.double(0))$tau
            names(ESTIMATE) <- "tau"
            if (is.null(exact))
                exact <- (n < 50)
            if (exact && !TIES) {
                q <- as.integer((ESTIMATE + 1) * n * (n - 1) / 4)
                pkendall <- function(q, n) {
                    .C("pkendall",
                       as.integer(length(q)),
                       p = as.double(q),
                       as.integer(n))$p
                }
                PVAL <- switch(alternative,
                               "two.sided" = {
                                   if (q > n * (n - 1) / 4)
                                       p <- 1 - pkendall(q - 1, n)
                                   else
                                       p <- pkendall(q, n)
                                   min(2 * p, 1)
                               },
                               "greater" = 1 - pkendall(q - 1, n),
                               "less" = pkendall(q, n))
                STATISTIC <- structure(q, names = "T")
            } else {
                STATISTIC <- ESTIMATE /
                    sqrt((4 * n + 10) / (9 * n * (n-1)))
                names(STATISTIC) <- "z"
                p <- pnorm(STATISTIC)
                if (exact && TIES)
                    warning("Cannot compute exact p-value with ties")
            }
        } else {
            method <- "Spearman's rank correlation rho"
            names(NVAL) <- "rho"
            ESTIMATE <- cor(rank(x), rank(y))
            names(ESTIMATE) <- "rho"
            STATISTIC <- sqrt(n-1) * (ESTIMATE - 6 / (n^3 - n))
            names(STATISTIC) <- "z"
            p <- pnorm(STATISTIC)
        }
    }

    if (is.null(PVAL))
        PVAL <- switch(alternative,
                       "less" = p,
                       "greater" = 1 - p,
                       "two.sided" = 2 * min(p, 1 - p))

    structure(list(statistic = STATISTIC,
                   parameter = PARAMETER,
                   p.value = PVAL,
                   estimate = ESTIMATE,
                   null.value = NVAL,
                   alternative = alternative,
                   method = method,
                   data.name = DNAME),
              class = "htest")
}
fisher.test <- function(x, y = NULL, alternative = "two.sided",
                        workspace = 200000, hybrid = FALSE) {
    DNAME <- deparse(substitute(x))

    if (is.data.frame(x))
        x <- as.matrix(x)
    if (is.matrix(x)) {
        if (any(dim(x) < 2))
            stop("x must have at least 2 rows and columns")
        if (any(x < 0) || any(is.na(x))) 
            stop("all entries of x must be nonnegative and finite")
    }
    else {
        if (is.null(y)) 
            stop("if x is not a matrix, y must be given")
        if (length(x) != length(y)) 
            stop("x and y must have the same length")
        DNAME <- paste(DNAME, "and", deparse(substitute(y)))
        OK <- complete.cases(x, y)
        x <- as.factor(x[OK])
        y <- as.factor(y[OK])
        if ((nlevels(x) < 2) || (nlevels(y) < 2)) 
            stop("x and y must have at least 2 levels")
        x <- table(x, y)
    }

    CHOICES <- c("two.sided", "less", "greater")
    alternative <- CHOICES[pmatch(alternative, CHOICES)]
    if (length(alternative) > 1 || is.na(alternative)) 
        stop("alternative must be \"two.sided\", \"less\" or \"greater\"")
    
    nr <- nrow(x)
    nc <- ncol(x)

    if ((nr == 2) && (nc == 2) && (alternative != "two.sided")) {
        m <- sum(x[, 1])
        n <- sum(x[, 2])
        k <- sum(x[1, ])
        x <- x[1, 1]
        PVAL <- switch(alternative,
                       less = phyper(x, m, n, k),
                       greater = 1 - phyper(x - 1, m, n, k))
    } else {
        if (hybrid) {
            warning("p-values may be incorrect")
            PVAL <- .C("fexact",
                       as.integer(nr),
                       as.integer(nc),
                       as.double(x),
                       as.integer(nr),
                       as.double(5),
                       as.double(80),
                       as.double(1),
                       as.double(0),
                       p = as.double(0),
                       as.integer(workspace))$p
        } else
            PVAL <- .C("fexact",
                       as.integer(nr),
                       as.integer(nc),
                       as.double(x),
                       as.integer(nr),
                       as.double(-1),
                       as.double(100),
                       as.double(0),
                       as.double(0),
                       p = as.double(0),
                       as.integer(workspace))$p
    }

    structure(list(p.value = PVAL,
                   alternative = alternative,
                   method = "Fisher's Exact Test for Count Data",
                   data.name = DNAME),
              class = "htest")
}
friedman.test <- function(y, groups, blocks) {
    DNAME <- deparse(substitute(y))
    if (is.matrix(y)) {
        groups <- as.factor(c(col(y)))
        blocks <- as.factor(c(row(y)))
    }
    else {
        if (any(is.na(groups)) || any(is.na(blocks)))
            stop("NA's are not allowed in groups or blocks")
        if (any(diff(c(length(y), length(groups), length(blocks)))))
            stop("y, groups and blocks must have the same length")
        DNAME <- paste(DNAME, ", ", deparse(substitute(groups)),
                       " and ", deparse(substitute(blocks)), sep = "")
        if (any(table(groups, blocks) != 1))
            stop("Not an unreplicated complete block design")
        groups <- as.factor(groups)
        blocks <- as.factor(blocks)
    }

    k <- nlevels(groups)
    y <- matrix(unlist(split(y, blocks)), ncol = k, byrow = TRUE)
    y <- y[complete.cases(y), ]
    n <- nrow(y)
    r <- t(apply(y, 1, rank))
    TIES <- tapply(r, row(r), table)
    STATISTIC <- ((12 * sum((apply(r, 2, sum) - n * (k + 1) / 2)^2)) /
                  (n * k * (k + 1)
                   - (sum(unlist(lapply(TIES, function (u) {u^3 - u}))) /
                      (k - 1))))
    PARAMETER <- k - 1
    names(STATISTIC) <- "Friedman chi-square"
    names(PARAMETER) <- "df"

    structure(list(statistic = STATISTIC,
                   parameter = PARAMETER,
                   p.value = 1 - pchisq(STATISTIC, PARAMETER),
                   method = "Friedman rank sum test",
                   data.name = DNAME),
              class = "htest")
}
kruskal.test <- function(x, g) {
    if (is.list(x)) {
        if (length(x) < 2)
            stop("x must be a list with at least 2 elements")
        DNAME <- deparse(substitute(x))
        x <- lapply(x, function(u) u <- u[complete.cases(u)])
        k <- length(x)
        l <- sapply(x, "length")
        if (any(l == 0))
            stop("all groups must contain data")
        g <- as.factor(rep(1 : k, l))
        x <- unlist(x)
    }
    else {
        if (length(x) != length(g))
            stop("x and g must have the same length")
        DNAME <- paste(deparse(substitute(x)), "and",
                       deparse(substitute(g)))
        OK <- complete.cases(x, g)
        x <- x[OK]
        g <- g[OK]
        if (!all(is.finite(g)))
            stop("all group levels must be finite")
        g <- as.factor(g)
        k <- nlevels(g)
        if (k < 2)
            stop("all observations are in the same group")
    }

    n <- length(x)
    if (n < 2)
        stop("not enough observations")
    r <- rank(x)
    TIES <- table(x)
    STATISTIC <- sum(tapply(r, g, "sum")^2 / tapply(r, g, "length"))
    STATISTIC <- ((12 * STATISTIC / (n * (n + 1)) - 3 * (n + 1)) /
                  (1 - sum(TIES^3 - TIES) / (n^3 - n)))
    names(STATISTIC) <- "Kruskal-Wallis chi-square"
    PARAMETER <- k - 1
    names(PARAMETER) <- "df"

    RVAL <- list(statistic = STATISTIC,
                 parameter = PARAMETER,
                 p.value = 1 - pchisq(STATISTIC, PARAMETER),
                 method = "Kruskal-Wallis rank sum test",
                 data.name = DNAME)
    class(RVAL) <- "htest"
    return(RVAL)
}
ks.test <- function(x, y, ..., alternative = "two.sided")
{
    CHOICES <- c("two.sided", "less", "greater")
    alternative <- CHOICES[pmatch(alternative, CHOICES)]
    if (length(alternative) > 1 || is.na(alternative)) 
        stop("alternative must be \"two.sided\", \"less\" or \"greater\"")

    DNAME <- deparse(substitute(x))      
    x <- x[!is.na(x)]
    n <- length(x)
    if (n < 1)
        stop("Not enough x data")

    if (is.numeric(y)) {
        DNAME <- paste(DNAME, "and", deparse(substitute(y)))
        y <- y[!is.na(y)]
        n.x <- n
        n.y <- length(y)
        if (n.y < 1)
            stop("Not enough y data")
        METHOD <- "Two-sample Kolmogorov-Smirnov test"
        n <- n.x * n.y / (n.x + n.y)
        w <- c(x, y)
        z <- cumsum(ifelse(order(w) <= n.x, 1 / n.x, - 1 / n.y))
        if (length(unique(w)) < (n.x + n.y)) {
            warning("cannot compute correct p-values with ties")
            z <- z[c(which(diff(sort(w)) != 0), n.x + n.y)]
            print(z)
        }
        STATISTIC <- switch(alternative,
                            "two.sided" = max(abs(z)),
                            "greater" = max(z),
                            "less" = - min(z))
    }
    else {
        if (is.character(y))
            y <- get(y, mode="function")
        if (mode(y) != "function")
            stop("y must be numeric or a string naming a valid function")
        METHOD <- "One-sample Kolmogorov-Smirnov test"
        n <- length(x)
        x <- y(sort(x), ...) - (0 : (n-1)) / n
        STATISTIC <- switch(alternative,
                            "two.sided" = max(abs(c(x, x-1/n))),
                            "greater" = max(c(x, x-1/n)),
                            "less" = - min(c(x, x-1/n)))
    }

    names(STATISTIC) <- switch(alternative,
                               "two.sided" = "D",
                               "greater" = "D^+",
                               "less" = "D^-")
    PVAL <- ifelse(alternative == "two.sided",
                   1 - pks(sqrt(n) * STATISTIC),
                   exp(- 2 * n * STATISTIC^2))
    
    RVAL <- list(statistic = STATISTIC,
                 p.value = PVAL,
                 alternative = alternative,
                 method = METHOD,
                 data.name = DNAME)
    class(RVAL) <- "htest"
    return(RVAL)
}
mantelhaen.test <- function(x, y = NULL, z = NULL, correct = TRUE)
{
    DNAME <- deparse(substitute(x))
    if (is.array(x)) {
        if (length(dim(x)) == 3) {
            if (any(is.na(x)))
                stop("NAs are not allowed")
            if (dim(x)[1:2] != c(2, 2))
                stop("table for each stratum must be 2 by 2")
        }
        else
            stop("x must be a 3-dimensional array")
    }
    else {
        if (is.null(y))
            stop("If x is not an array, y must be given")
        if (is.null(z))
            stop("If x is not an array, z must be given")
        if (any(diff(c(length(x), length(y), length(z)))))
            stop("x, y, and z must have the same length")
        DNAME <- paste(DNAME, "and", deparse(substitute(y)), "and",
                       deparse(substitute(z)))
        OK <- complete.cases(x, y, z)
        x <- as.factor(x[OK])
        y <- as.factor(y[OK])
        if ((nlevels(x) != 2) || (nlevels(y) != 2))
            stop("x and y must be dichotomous")
        else
            x <- table(x, y, z[OK])
    }

    s.x <- apply(x, c(1, 3), sum)
    s.y <- apply(x, c(2, 3), sum)
    n <- apply(x, 3, sum)
    if (any(n < 2))
        stop("sample size in each stratum must be > 1")
    DELTA <- abs(sum(x[1, 1, ] - s.x[1, ] * s.y[1, ] / n))
    YATES <- ifelse(correct && (DELTA >= .5), .5, 0)
    STATISTIC <- ((DELTA - YATES)^2 /
                  sum(apply(rbind(s.x, s.y), 2, prod)
                      / (n^2 * (n - 1))))
    PARAMETER <- 1
    names(STATISTIC) <- "Mantel-Haenszel X-square"
    names(PARAMETER) <- "df"
    
    RVAL <- list(statistic = STATISTIC,
                 parameter = PARAMETER,
                 p.value = 1 - pchisq(STATISTIC, PARAMETER),
                 method = paste("Mantel-Haenszel chi-square test",
                 ifelse(YATES, "with", "without"),
                 "continuity correction"),
                 data.name = DNAME)
    class(RVAL) <- "htest"
    return(RVAL)
}
mcnemar.test <- function(x, y = NULL, correct = TRUE)
{
    if (is.matrix(x)) {
        r <- nrow(x)
        if ((r < 2) || (ncol (x) != r))
            stop("x must be square with at least two rows and columns")
        if (any(x < 0) || any(is.na(x)))
            stop("all entries of x must be nonnegative and finite")
        DNAME <- deparse(substitute(x))
    }
    else {
        if (is.null(y))
            stop("if x is not a matrix, y must be given")
        if (length(x) != length(y))
            stop("x and y must have the same length")
        DNAME <- paste(deparse(substitute(x)), "and",
                       deparse(substitute(y)))
        OK <- complete.cases(x, y)
        x <- as.factor(x[OK])
        y <- as.factor(y[OK])
        r <- nlevels(x)
        if ((r < 2) || (nlevels(y) != r))
            stop("x and y must have the same number of levels (minimum 2)")
        x <- table(x, y)
    }

    PARAMETER <- r * (r-1) / 2
    names(PARAMETER) <- "df"
    METHOD <- "McNemar's Chi-square test"

    if (correct && (r == 2) && any(x - t(x))) {
        y <- (abs(x - t(x)) - 1)
        METHOD <- paste(METHOD, "with continuity correction")
    }
    else
        y <- x - t(x)
    x <- x + t(x)
    
    STATISTIC <- sum(y[upper.tri(x)]^2 / x[upper.tri(x)])
    names(STATISTIC) <- "McNemar's chi-square"
    PVAL <- 1 - pchisq(STATISTIC, PARAMETER)  
    
    RVAL <- list(statistic = STATISTIC,
                 parameter = PARAMETER,
                 p.value = PVAL,
                 method = METHOD,
                 data.name = DNAME)
    class(RVAL) <- "htest"
    return(RVAL)
}
mood.test <- function(x, y, alternative = "two.sided") {
    CHOICES <- c("two.sided", "less", "greater")
    alternative <- CHOICES[pmatch(alternative, CHOICES)]
    if (length(alternative) > 1 || is.na(alternative)) 
        stop("alternative must be \"two.sided\", \"less\" or \"greater\"")
    DNAME <- paste(deparse(substitute(x)), "and", deparse(substitute(y)))

    x <- x[is.finite(x)]
    y <- y[is.finite(y)]
    m <- length(x)
    n <- length(y)
    if ((s <- m + n) < 3)
        stop("not enough observations")
    r <- rank(c(x, y))
    z <- ((sum((r[seq(along = x)] - (s + 1) / 2)^2) - m * (s^2 - 1) / 12)
          / sqrt(m * n * (s + 1) * (s + 2) * (s - 2) / 180))
    p <- pnorm(z)
    PVAL <- switch(alternative,
                   "less" = p,
                   "greater" = 1 - p,
                   "two.sided" = 2 * min(p, 1 - p))
    
    structure(list(statistic = structure(z, names = "Z"),
                   p.value = PVAL,
                   alternative = alternative,
                   method = "Mood two-sample test of scale",
                   data.name = DNAME),
              class = "htest")
}
pks <- function(x, tol = 10^(-6)) {
    if (is.numeric(x))
        x <- as.vector(x)
    else
        stop("Argument x must be numeric")

    PKS <- rep(0, length(x))
    PKS[is.na(x)] <- NA
    IND <- which(!is.na(x) & (x > 0))
    if (length(IND) > 0) {
        k <- 1 : ceiling(sqrt(-log(tol)/2) / min(x[IND]))
        y <- outer(x[IND]^2, k,
                   function (t, k) { (-1)^k * exp(-2 * t * k^2) })
        PKS[IND] <- 1 + 2 * apply(y, 1, "sum")
    }
    return(PKS)
}
shapiro.test <- function(x) {
    DNAME <- deparse(substitute(x))
    x <- sort(x[complete.cases(x)])
    n <- length(x)
    if ((n < 3) || (n > 5000))
        stop("sample size must be between 3 and 5000")
    n2 <- floor(n / 2)
    sw <- .Fortran("swilk",
                   as.logical(FALSE),
                   as.single(x),
                   as.integer(n),
                   as.integer(n),
                   as.integer(n2),
                   single(n2),
                   w = single(1),
                   pw = single(1),
                   ifault = integer(1))
    if (sw$ifault != 0)
        stop("this should not happen")
    STATISTIC <- sw$w
    names(STATISTIC) <- "W"
    RVAL <- list(statistic = STATISTIC,
                 p.value = sw$pw,
                 method = "Shapiro-Wilk normality test",
                 data.name = DNAME)
    class(RVAL) <- "htest"
    return(RVAL)
}
var.test <- function(x, y, ratio = 1, alternative = "two.sided",
		     conf.level = 0.95)  
{
    if (!((length(ratio) == 1) && is.finite(ratio) && (ratio > 0)))
        stop("ratio must be a single positive number")
  
    alternative <- char.expand(alternative,
                               c("two.sided", "less", "greater"))
    if ((length(alternative) > 1) || is.na(alternative)) 
        stop("alternative must be \"two.sided\", \"less\" or \"greater\"")

    if (!((length(conf.level) == 1) && is.finite(conf.level) &&
          (conf.level > 0) && (conf.level < 1)))
        stop("conf.level must be a single number between 0 and 1")

    DNAME <- paste(deparse(substitute(x)), "and", deparse(substitute(y)))

    if (inherits(x, "lm") && inherits(y, "lm")) {
        DF.x <- x$df.resid
        DF.y <- y$df.resid
        V.x <- sum(x$residuals^2) / DF.x      
        V.y <- sum(y$residuals^2) / DF.y
    } else {
        x <- x[is.finite(x)]
        DF.x <- length(x) - 1
        if (DF.x < 1) 
            stop("not enough x observations")
        y <- y[is.finite(y)]
        DF.y <- length(y) - 1
        if (DF.y < 1) 
            stop("not enough y observations")
        V.x <- var(x)
        V.y <- var(y)
    }
    ESTIMATE <- V.x / V.y
    STATISTIC <- ESTIMATE / ratio
    PARAMETER <- c(DF.x, DF.y)
    
    PVAL <- pf(STATISTIC, DF.x, DF.y)
    if (alternative == "two.sided") {
        PVAL <- 2 * min(PVAL, 1 - PVAL)
        BETA <- (1 - conf.level) / 2
        CINT <- c(ESTIMATE / qf(1 - BETA, DF.x, DF.y),
                  ESTIMATE / qf(BETA, DF.x, DF.y))
    }
    else if (alternative == "greater") {
        PVAL <- 1 - PVAL
        CINT <- c(ESTIMATE / qf(conf.level, DF.x, DF.y), Inf)
    }
    else
        CINT <- c(0, ESTIMATE / qf(1 - conf.level, DF.x, DF.y))
    names(STATISTIC) <- "F"
    names(PARAMETER) <- c("num df", "denom df")
    names(ESTIMATE) <- names(ratio) <- "ratio of variances"
    attr(CINT, "conf.level") <- conf.level
    RVAL <- list(statistic = STATISTIC,
                 parameter = PARAMETER,
                 p.value = PVAL,
                 conf.int = CINT,
                 estimate = ESTIMATE,
                 null.value = ratio,
                 alternative = alternative,
                 method = "F test to compare two variances",
                 data.name = DNAME)
    attr(RVAL, "class") <- "htest"
    return(RVAL)
}
wilcox.test <- function(x, y = NULL, alternative = "two.sided", mu = 0,
			paired = FALSE, exact = NULL, correct = TRUE) 
{
    CHOICES <- c("two.sided", "less", "greater")
    alternative <- CHOICES[pmatch(alternative, CHOICES)]
    if (length(alternative) > 1 || is.na(alternative)) 
        stop("alternative must be \"two.sided\", \"less\" or \"greater\"")

    if (!missing(mu) && ((length(mu) > 1) || !is.finite(mu)))
        stop("mu must be a single number")

    if (!is.null(y)) {
        DNAME <- paste(deparse(substitute(x)), "and",
                       deparse(substitute(y)))
        if (paired) {
            if (length(x) != length(y))
                stop("x and y must have the same length")
            OK <- complete.cases(x, y)
            x <- x[OK] - y[OK]
            y <- NULL
        }
        else {
            x <- x[is.finite(x)]
            y <- y[is.finite(y)]
        }
    } else {
        DNAME <- deparse(substitute(x))
        if (paired)
            stop("y missing for paired test")
        x <- x[is.finite(x)]
    }

    if (length(x) < 1)
        stop("not enough x observations")

    PARAMETER <- NULL
    CORRECTION <- 0

    if (is.null(y)) {
        METHOD <- "Wilcoxon signed rank test"
        x <- x - mu
        ZEROES <- any(x == 0)
        if (ZEROES)
            x <- x[x != 0]
        n <- length(x)
        if (is.null(exact))
            exact <- (n < 50)
        r <- rank(abs(x))
        STATISTIC <- sum(r[x > 0])
        names(STATISTIC) <- "V"
        TIES <- (length(r) != length(unique(r)))
        if (exact && !TIES && !ZEROES) {
            PVAL <-
                switch(alternative,
                       "two.sided" = {
                           if (STATISTIC > (n * (n + 1) / 4))
                               p <- 1 - psignrank(STATISTIC - 1, n)
                           else
                               p <- psignrank(STATISTIC, n)
                           min(2 * p, 1)
                       },
                       "greater" = 1 - psignrank(STATISTIC - 1, n),
                       "less" = psignrank(STATISTIC, n))
        } else {
            NTIES <- table(r)
            z <- STATISTIC - n * (n + 1) / 4
            SIGMA <- sqrt(n * (n + 1) * (2 * n + 1) / 24 -
                          sum(NTIES^3 - NTIES) / 48)
            if (correct) {
                CORRECTION <- switch(alternative,
                                     "two.sided" = sign(z) * 0.5,
                                     "greater" = 0.5,
                                     "less" = -0.5)
                METHOD <- paste(METHOD, "with continuity correction")
            }
            PVAL <- pnorm((z - CORRECTION) / SIGMA)
            if (alternative == "two.sided")
                PVAL <- 2 * min(PVAL, 1 - PVAL)
            if (alternative == "greater")
                PVAL <- 1 - PVAL
            if (exact && TIES)
                warning("Cannot compute exact p-value with ties")
            if (exact && ZEROES)
                warning("Cannot compute exact p-value with zeroes")
        }
    } else {
        if (length(y) < 1)
            stop("not enough y observations")
        METHOD <- "Wilcoxon rank sum test"
        r <- rank(c(x - mu, y))
        n.x <- length(x)
        n.y <- length(y)
        if (is.null(exact))
            exact <- (n.x < 50) && (n.y < 50)
        STATISTIC <- sum(r[seq(along = x)]) - n.x * (n.x + 1) / 2
        ## Contrary to BB, we use the symmetric definition
        names(STATISTIC) <- "W"
        TIES <- (length(r) != length(unique(r)))
        if (exact && !TIES) {
            PVAL <-
                switch(alternative,
                       "two.sided" = {
                           if (STATISTIC > (n.x * n.y / 2))
                               p <- 1 - pwilcox(STATISTIC - 1, n.x, n.y)
                           else
                               p <- pwilcox(STATISTIC, n.x, n.y)
                           min(2 * p, 1)
                       },
                       "greater" = 1 - pwilcox(STATISTIC - 1, n.x, n.y),
                       "less" = pwilcox(STATISTIC, n.x, n.y))
        } else {
            NTIES <- table(r)
            z <- STATISTIC - n.x * n.y / 2
            SIGMA <- sqrt((n.x * n.y / 12) *
                          ((n.x + n.y + 1)
                           - sum(NTIES^3 - NTIES)
                           / ((n.x + n.y) * (n.x + n.y -1))))
            if (correct) {
                CORRECTION <- switch(alternative,
                                     "two.sided" = sign(z) * 0.5,
                                     "greater" = 0.5,
                                     "less" = -0.5)
                METHOD <- paste(METHOD, "with continuity correction")
            }
            PVAL <- pnorm((z - CORRECTION) / SIGMA)
            if (alternative == "two.sided")
                PVAL <- 2 * min(PVAL, 1 - PVAL)
            if (alternative == "greater")
                PVAL <- 1 - PVAL
            if (exact && TIES)
                warning("Cannot compute exact p-value with ties")
        }
    }
    
    NVAL <- mu
    names(NVAL) <- "mu"
    
    RVAL <- list(statistic = STATISTIC,
                 parameter = PARAMETER,
                 p.value = PVAL,
                 null.value = NVAL,
                 alternative = alternative,
                 method = METHOD,
                 data.name = DNAME)
    class(RVAL) <- "htest"
    return(RVAL)
}
.First.lib <- function(lib, pkg)
    library.dynam("ctest", pkg, lib)
