.packageName <- "vcd"
Ord.plot <- function(obj, legend = TRUE, estimate = TRUE, tol = 0.1,
                     type = NULL, ylim = NULL, xlab = "Number of occurrences",
		     ylab = "Frequency ratio", main = "Ord plot", ...)
{
  if(is.vector(obj)) {
    obj <- table(obj)
  }
  if(is.table(obj)) {
    if(length(dim(obj)) > 1) stop ("obj must be a 1-way table")
    x <- as.vector(obj)
    count <- as.numeric(names(obj))
  } else {
    if(!(!is.null(ncol(obj)) && ncol(obj) == 2))
      stop("obj must be a 2-column matrix or data.frame")
    x <- as.vector(obj[,1])
    count <- as.vector(obj[,2])
  }

  y <- count * x/c(NA, x[-length(x)])
  fm <- lm(y ~ count)
  fmw <- lm(y ~ count, weights = sqrt(x - 1))
  fit1 <- predict(fm, data.frame(count))
  fit2 <- predict(fmw, data.frame(count))
  if(is.null(ylim)) ylim <- range(c(y, fit1, fit2), na.rm = TRUE)
  plot(y ~ count, ylim = ylim, xlab = xlab, ylab = ylab, main = main, ...)
  lines(count, fit1)
  lines(count, fit2, col = 2)
  RVAL <- coef(fmw)
  names(RVAL) <- c("Intercept", "Slope")
  if(legend)
  {
    legend.text <- c(paste("slope =", round(RVAL[2], digits = 3)),
                     paste("intercept =", round(RVAL[1], digits = 3)))
    if(estimate) {
      ordfit <- Ord.estimate(RVAL, type = type, tol = tol)
      legend.text <- c(legend.text, "", paste("type:", ordfit$type),
        paste("estimate:", names(ordfit$estimate),"=", round(ordfit$estimate, digits = 3)))
    }
    legend(min(count), ylim[2], legend.text, bty = "n")
  }
  invisible(RVAL)
}

Ord.estimate <- function(x, type = NULL, tol = 0.1)
{
  a <- x[1]
  b <- x[2]
  if(!is.null(type))
    type <- match.arg(type, c("poisson", "binomial", "nbinomial", "log-series"))
  else {
    if(abs(b) < tol) type <- "poisson"
    else if(b < (-1 * tol)) type <- "binomial"
    else if(a > (-1 * tol)) type <- "nbinomial"
    else if(abs(a + b) < 4*tol) type <- "log-series"
    else type <- "none"
  }

  switch(type,

  "poisson" = {
    par <- a
    names(par) <- "lambda"
    if(par < 0) warning("lambda not > 0")
  },
  "binomial" = {
    par <- b/(b - 1)
    names(par) <- "prob"
    if(abs(par - 0.5) > 0.5) warning("prob not in (0,1)")
  },
  "nbinomial" = {
    par <- 1 - b
    names(par) <- "prob"
    if(abs(par - 0.5) > 0.5) warning("prob not in (0,1)")
  },

  "log-series" = {
    par <- b
    names(par) <- "theta"
    if(par < 0) warning("theta not > 0")
  },
  "none" = {
    par <- NA
  })
  list(estimate = par, type = type)
}


"agreementplot" <- function (x, ...)
  UseMethod ("agreementplot")

"agreementplot.formula" <-
function (formula, data = NULL, ..., subset) 
{
    m <- match.call(expand.dots = FALSE)
    edata <- eval(m$data, parent.frame())
    if (inherits(edata, "ftable") || inherits(edata, "table")) {
        data <- as.table(data)
        varnames <- attr(terms(formula), "term.labels")
        if (all(varnames != ".")) 
            data <- margin.table(data, match(varnames, names(dimnames(data))))
        agreementplot(data, ...)
    }
    else {
        if (is.matrix(edata)) 
            m$data <- as.data.frame(data)
        m$... <- NULL
        m[[1]] <- as.name("model.frame")
        mf <- eval(m, parent.frame())
        if (length(formula) == 2) {
          by <- mf
          y <- NULL
        }
        else {
          i <- attr(attr(mf, "terms"), "response")
          by <- mf[-i]
          y <- mf[[i]]
        }
        by <- lapply(by, factor)
        x <- if (is.null(y)) 
          do.call("table", by)
        else if (NCOL(y) == 1) 
          tapply(y, by, sum)
        else {
          z <- lapply(as.data.frame(y), tapply, by, sum)
          array(unlist(z), dim = c(dim(z[[1]]), length(z)), dimnames = c(dimnames(z[[1]]), 
                                                              list(names(z))))
        }
        x[is.na(x)] <- 0
        agreementplot(x, ...)
    }
}

"agreementplot.default" <-
  function(x,
           reverse.y = TRUE,
           main = "Agreement Chart",
           weights = c(1, 1 - 1 / (ncol(x) - 1)^2),
           cex.main = 2,
           cex.lab = 1.5,
           xlab = names(dimnames(x))[2],
           ylab = names(dimnames(x))[1],
           ...)
{
  if (length(dim(x)) > 2)
    stop("Function implemented for two-way tables only!")
  if (ncol(x) != nrow(x))
    stop("Dimensions must have equal length!")

  nc <- ncol(x)
  
  ## compute relative frequencies
  n <- sum(x)
  colFreqs <- colSums(x) / n
  rowFreqs <- rowSums(x) / n

  ## margins, limits (hard-coded, argh!)
  bm <- 0.1
  lm <- 0.1
  tm <- 0.1
  rm <- 0.1

  xlim = c(0, 1 + lm + rm)
  ylim = c(0, 1 + tm + bm)

  ## init device
  opar <- par(usr = c(xlim, ylim), mar = c(0, 0, 0, 0))
  on.exit(par(opar))
  plot.new()
  plot.window(xlim = xlim, ylim = ylim, asp = 1)

  ## title
  text(x = lm + 1 / 2, y = ylim[2], labels = main, cex = cex.main)

  ## axis labels
  text(x = lm + 1 / 2, y = 0, labels = xlab, cex = cex.lab)
  text(x = 0, y = bm + 1 / 2, labels = ylab, cex = cex.lab, srt = 90)
  
  rect(lm, bm, lm + 1, bm + 1)

  xc <- c(0, cumsum(colFreqs))
  yc <- c(0, cumsum(rowFreqs))

  my.text <- function (y, ...)
    if (reverse.y)
      text(y, ...)
    else
      text(2 * bm + 1 - y, ...)

  my.rect <- function (xleft, ybottom, xright, ytop, ...)
    if (reverse.y)
      rect(lm + xleft, bm + ybottom, lm + xright, bm + ytop, ...)
    else
      rect(lm + xleft, 1 + tm - ybottom, lm + xright, 1 + tm - ytop, ...)
  
  A <- matrix(0, length(weights), nc)
  for (i in 1:nc) {
    ## x - axis
    text(x = lm + xc[i] + (xc[i+1] - xc[i]) / 2, y = bm - 0.04,
         labels = dimnames(x)[[2]][i], ...)

    ## y - axis
    my.text(y = bm + yc[i] + (yc[i+1] - yc[i]) / 2, x = lm - 0.03,
            labels = dimnames(x)[[1]][i], srt = 90, ...)
    
    ## expected rectangle
    my.rect(xc[i], yc[i], xc[i+1], yc[i+1])
    
    ## observed rectangle
    y0 <- c(0, cumsum(x[i,])) / sum(x[i,])
    x0 <- c(0, cumsum(x[,i])) / sum(x[,i])

    rec <- function (col, dens)
      my.rect(xc[i] + (xc[i+1] - xc[i]) * x0[lb],
              yc[i] + (yc[i+1] - yc[i]) * y0[lb],
              xc[i] + (xc[i+1] - xc[i]) * x0[tr],
              yc[i] + (yc[i+1] - yc[i]) * y0[tr],
#             col = gray(1-(weights[j])^2)
              col = col,
              density = dens,
              angle = 135
              )

    for (j in length(weights):1) {
      lb <- max(1, i - j + 1)
      tr <- 1 + min(nc, i + j - 1)
      A[j, i] <- sum(x[lb:(tr-1),i]) * sum(x[i, lb:(tr-1)])
      rec("white", NULL) ## erase background
      rec("black", if (weights[j] < 1) weights[j] * 20 else NULL)
    }

    ## correct A[j,i] -> not done by Friendly==Bug?
    for (j in length(weights):1) 
      if (j > 1) A[j, i] <- A[j, i] - A[j - 1, i]
  }
  if (reverse.y)
    lines(c(lm, bm + 1), c(lm, 1 + bm), col = "red", lty = "longdash")
  else
    lines(c(lm, bm + 1), c(lm + 1, bm), col = "red", lty = "longdash")
  
  ## Statistics - Returned invisibly
  ads <- crossprod(diag(x)) 
  ar  <- n * n * crossprod(colFreqs, rowFreqs)
  invisible(list(
                 Bangdiwala = ads / ar,
                 Bangdiwala.Weighted = (sum(weights * A)) /  ar,
                 weights = weights,
                 )
            )
}

Kappa <- function (x, weights = c("Equal-Spacing", "Fleiss-Cohen"), conf.level = 0.95)
{
  if (is.character(weights))
      weights = match.arg(weights)

  q <- qnorm((1 + conf.level) / 2)
  
  d  <- diag(x)
  n  <- sum(x)
  nc <- ncol(x)
  colFreqs <- colSums(x)/n
  rowFreqs <- rowSums(x)/n
  
  ## Kappa
  kappa <- function (po, pc)
    (po - pc) / (1 - pc)
  std  <- function (po, pc, W = 1)
    sqrt(sum(W * W * po * (1 - po)) / crossprod(1 - pc) / n)
    
  ## unweighted
  po <- sum(d) / n
  pc <- crossprod(colFreqs, rowFreqs)
  k <- kappa(po, pc)
  s <- std(po, pc)
  
  ## weighted 
  W <- if (is.matrix(weights))
    weights
  else if (weights == "Equal-Spacing")
    outer (1:nc, 1:nc, function(x, y) 1 - abs(x - y) / (nc - 1))
  else
    outer (1:nc, 1:nc, function(x, y) 1 - (abs(x - y) / (nc - 1))^2)
  pow <- sum(W * x) / n
  pcw <- sum(W * colFreqs %o% rowFreqs)
  kw <- kappa(pow, pcw)
  sw <- std(x / n, 1 - pcw, W)

  structure(
            list(Unweighted = c(
                   value = k,
                   ASE   = s,
                   lwr   = k - s * q,
                   upr   = k + s * q
                   ),
                 Weighted = c(
                   value = kw,
                   ASE   = sw,
                   lwr   = kw - sw * q,
                   upr   = kw + sw * q 
                   ),
                 Weights = W
                 ),
            class = "Kappa"
       )
}

print.Kappa <- function (x, ...) {
  tab <- rbind(x$Unweighted, x$Weighted)
  rownames(tab) <- names(x)[1:2]
  print(tab)
  invisible(x)
}

summary.Kappa <- function (object, ...)
  structure(object, class = "summary.Kappa")

print.summary.Kappa <- function (x, ...) {
  print.Kappa(x)
  cat("\nWeights:\n")
  print(x$Weights)
  invisible(x)
}

expected <- function(x, frequency = c("absolute","relative")) {
  if (!is.array(x))
    stop("Need array of absolute frequencies!")
  frequency <- match.arg(frequency)

  n <- sum(x)
  x <- x / n
  d <- length(dim(x))
  tab <- apply(x, 1, sum)
  for (i in 2:d)
    tab <- tab %o% apply(x, i, sum)
  if (frequency == "relative") tab else tab * n
}

mar.table <- function(x) {
  if(!is.matrix(x))
    stop("Function only defined for m x n - tables.")
  tab <- rbind(cbind(x, TOTAL = rowSums(x)), TOTAL = c(colSums(x), sum(x)))
  names(dimnames(tab)) <- names(dimnames(x))
  tab
}

summary.table <- function(object,
                    margins = TRUE,
                    percentages = FALSE,
                    conditionals = c("none", "row", "column"),
                    ...
                    )
{
  ret <- list()
  ret$chisq <- base::summary.table(object, ...)
  
  if(is.matrix(object)) {
    
    conditionals <- match.arg(conditionals)
  
    tab <- array(0, c(dim(object) + margins, 1 + percentages + (conditionals != "none")))

    ## frequencies
    tab[,,1] <- if(margins) mar.table(object) else object

    ## percentages
    if(percentages) {
      tmp <- prop.table(object)
      tab[,,2] <- 100 * if(margins) mar.table(tmp) else tmp
    }

    ## conditional distributions
    if(conditionals != "none") {
      tmp <- prop.table(object, margin = 1 + (conditionals == "column"))
      tab[,,2 + percentages] <- 100 * if(margins) mar.table(tmp) else tmp
    }

    ## dimnames
    dimnames(tab) <- c(dimnames(if(margins) mar.table(object) else object),
                       list(c("freq",
                              if(percentages) "%",
                              switch(conditionals, row = "row%", column = "col%")
                              )
                            )
                       )

    ## patch row% / col% margins
    if(conditionals == "row") 
      tab[dim(tab)[1],,2 + percentages] <- NA
    
    if(conditionals == "column")
      tab[,dim(tab)[2],2 + percentages] <- NA
    
    ret$table <- tab
  }    

  class(ret) <- "summary.table"
  ret
}

print.summary.table <- 
function (x, digits = max(1, getOption("digits") - 3), ...) 
{
  if (!is.null(x$table))
    if(dim(x$table)[3] == 1)
      print(x$table[,,1], digits = digits)
    else
      print(ftable(aperm(x$table, c(1,3,2))), 2, digits = digits)
  
  cat("\n")
  
  if (!is.null(x$chisq))
    base::print.summary.table(x$chisq, digits, ...)
  invisible(x)
}

assoc.stats <- function(x) {
  if(!is.matrix(x))
    stop("Function only defined for m x n - tables.")
  require(MASS)
  
  tab    <- summary(loglm(~1+2, x))$tests
  phi    <- sqrt(tab[2,1] / sum(x))
  cont   <- sqrt(phi^2 / (1 + phi^2))
  cramer <- sqrt(phi^2 / min(dim(x) - 1))
  structure(
            list(table = x,
                 chisq.tests = tab,
                 phi = phi,
                 contingency = cont,
                 cramer = cramer),
            class = "assoc.stats"
            )
}

print.assoc.stats <- function(x,
                              digits = 3,
                              ...)
{
  print(x$chisq.tests, digits = 5)
  cat("\n")
  cat("Phi-Coefficient   :", round(x$phi,    digits = digits), "\n")
  cat("Contingency Coeff.:", round(x$cont,   digits = digits), "\n")
  cat("Cramer's V        :", round(x$cramer, digits = digits), "\n")
  invisible(x)
}

summary.assoc.stats <- function(object, percentage = FALSE, ...) {
  tab <- summary(object$table, percentage = percentage, ...)
  tab$chisq <- NULL
  structure(list(summary = tab,
                 object  = object),
            class   = "summary.assoc.stats"
            )
}

print.summary.assoc.stats <- function(x, ...) {
  cat("\n")
  print(x$summary)
  print(x$object)
  cat("\n")
  invisible(x)
}

woolf.test <- function(x) {
  DNAME <- deparse(substitute(x))
  x <- x + 1 / 2
  k <- dim(x)[3]
  or <- apply(x, 3, function(x) (x[1,1] * x[2,2]) / (x[1,2] * x[2,1]))
  w <-  apply(x, 3, function(x) 1 / sum(1 / x))
  o <- log(or)
  e <- weighted.mean(log(or), w)
  STATISTIC <- sum(w * (o - e)^2)
  PARAMETER <- k - 1
  PVAL <- 1 - pchisq(STATISTIC, PARAMETER)
  METHOD <- "Woolf-test on Homogeneity of Odds Ratios (no 3-Way assoc.)"
  names(STATISTIC) <- "X-squared"
  names(PARAMETER) <- "df"
  structure(list(statistic = STATISTIC, parameter = PARAMETER, 
                 p.value = PVAL, method = METHOD, data.name = DNAME, observed = o, 
                 expected = e), class = "htest")
}




barplot.default <-
function(height, width = 1, space = NULL, names.arg = NULL,
         legend.text = NULL, beside = FALSE, horiz = FALSE,
         density = NULL, angle = 45,
         col = heat.colors(NR), border = par("fg"),
         main = NULL, sub = NULL, xlab = NULL, ylab = NULL,
         xlim = NULL, ylim = NULL, xpd = TRUE,
         axes = TRUE, axisnames = TRUE,
         cex.axis = par("cex.axis"), cex.names = par("cex.axis"),
         inside = TRUE, plot = TRUE, shift = 0, ...)
{
    if (!missing(inside)) .NotYetUsed("inside", error = FALSE)
    if (!missing(border)) .NotYetUsed("border", error = FALSE)

    if (missing(space))
	space <- if (is.matrix(height) && beside) c(0, 1) else 0.2
    space <- space * mean(width)

    if (plot && axisnames && missing(names.arg))
	names.arg <-
	    if(is.matrix(height)) colnames(height) else names(height)

    if (is.vector(height)) {
	height <- cbind(height)
	beside <- TRUE
    } else if (is.array(height) && (length(dim(height)) == 1)) {
	height <- rbind(height)
	beside <- TRUE
    } else if (!is.matrix(height))
	stop("`height' must be a vector or a matrix")

    if(is.logical(legend.text)) {
        if(legend.text && is.matrix(height))
            legend.text <- rownames(height)
        else
            legend.text <- NULL
    }

    NR <- nrow(height)
    NC <- ncol(height)
    if(length(shift) == 1)
      shift <- rep(shift, NR)
    else if(length(shift) != NR)
      stop("incorrect number of shifts")

    if (beside) {
	if (length(space) == 2)
	    space <- rep(c(space[2], rep(space[1], NR - 1)), NC)
	width <- rep(width, length = NR * NC)
    } else {
	width <- rep(width, length = NC)
	height <- rbind(0, apply(height, 2, cumsum))
    }
    delta <- width / 2
    w.r <- cumsum(space + width)
    w.m <- w.r - delta
    w.l <- w.m - delta
    if (horiz) {
	if (missing(xlim)) xlim <- range(-0.01 * height + shift, height + shift, na.rm=TRUE)
	if (missing(ylim)) ylim <- c(min(w.l + shift), max(w.r + shift))
    } else {
	if (missing(xlim)) xlim <- c(min(w.l), max(w.r))
	if (missing(ylim)) ylim <- range(-0.01 * height + shift, height + shift, na.rm=TRUE)
    }
    if (beside)
	w.m <- matrix(w.m, nc = NC)
    if(plot) { ##-------- Plotting :
	opar <-
	    if (horiz)	par(xaxs = "i", xpd = xpd)
	    else	par(yaxs = "i", xpd = xpd)
	on.exit(par(opar))

	plot.new()
	plot.window(xlim, ylim, log = "", ...)
        # Beware : angle and density are passed using R scoping rules
	xyrect <- function(x1,y1, x2,y2, horizontal = TRUE, ...) {
	    if(horizontal)
		rect(x1,y1, x2,y2, angle = angle, density = density, ...)
	    else
		rect(y1,x1, y2,x2, angle = angle, density = density, ...)
	}
	if (beside)
          xyrect(0 + shift, w.l, c(height) + shift, w.r, horizontal=horiz, col = col)
	else {
	    for (i in 1:NC) {
		xyrect(height[1:NR, i] + shift[i], w.l[i],
		       height[-1, i] + shift[i], w.r[i],
		       horizontal=horiz, col = col)
	    }
	}
	if (axisnames && !is.null(names.arg)) { # specified or from {col}names
	    at.l <- if (length(names.arg) != length(w.m)) {
		if (length(names.arg) == NC) # i.e. beside (!)
		    colMeans(w.m)
		else
		    stop("incorrect number of names")
	    } else w.m
	    axis(if(horiz) 2 else 1, at = at.l,
                 labels = names.arg, lty = 0, cex.axis = cex.names, ...)
	}
	if(!is.null(legend.text)) {
	    legend.col <- rep(col, length = length(legend.text))
	    if((horiz & beside) || (!horiz & !beside)){
		legend.text <- rev(legend.text)
		legend.col <- rev(legend.col)
                density <- rev(density)
                angle <- rev(angle)
	    }
	    xy <- par("usr")
	    legend(xy[2] - xinch(0.1), xy[4] - yinch(0.1),
		   legend = legend.text, angle = angle, density = density,
                   fill = legend.col, xjust = 1, yjust = 1)
	}
	title(main = main, sub = sub, xlab = xlab, ylab = ylab, ...)
	if(axes) axis(if(horiz) 1 else 2, cex.axis = cex.axis, ...)
	invisible(w.m)
    } else w.m
}
distplot <- function(obj, type = c("poisson", "binomial", "nbinomial"),
                     size = NULL, lambda = NULL, legend = TRUE, ylim = NULL,
                     line.col = 2, conf.int = TRUE, conf.level = 0.95, main = NULL,
		     xlab = "Number of occurrences", ylab = "Distribution metameter", ...)
{
  if(is.vector(obj)) {
  obj <- table(obj)
  }
  if(is.table(obj)) {
    if(length(dim(obj)) > 1) stop ("obj must be a 1-way table")
    freq <- as.vector(obj)
    count <- as.numeric(names(obj))
  } else {
    if(!(!is.null(ncol(obj)) && ncol(obj) == 2))
      stop("obj must be a 2-column matrix or data.frame")
    freq <- as.vector(obj[,1])
    count <- as.vector(obj[,2])
  }

  myindex <- (1:length(freq))[freq > 0]
  mycount <- count[myindex]
  myfreq <- freq[myindex]

  switch(match.arg(type),

  "poisson" = {
    par.ml <- goodfit(obj, type = type)$par$lambda

    phi <- function(nk, k, N, size = NULL)
      ifelse(nk > 0, lgamma(k + 1) + log(nk/N), NA)
    y <- phi(myfreq, mycount, sum(freq))
    if(!is.null(lambda)) y <- y + lambda - mycount * log(lambda)
    fm <- lm(y ~ mycount)
    par.estim <- exp(coef(fm)[2])
    names(par.estim) <- "lambda"
    if(!is.null(lambda)) par.estim <- par.estim * lambda
    legend.text <- paste("exp(slope) =", round(par.estim, digits = 3))
    if(is.null(main)) main <- "Poissoness plot"
  },

  "binomial" = {
    if(is.null(size)) {
      size <- max(count)
      warning("size was not given, taken as maximum count")
    }
    par.ml <- goodfit(obj, type = type, par = list(size = size))$par$prob

    phi <- function(nk, k, N, size)
      log(nk) - log(N * choose(size, k))
    y <- phi(myfreq, mycount, sum(freq), size = size)
    fm <- lm(y ~ mycount)
    par.estim <- exp(coef(fm)[2])
    par.estim <- par.estim / (1 + par.estim)
    names(par.estim) <- "prob"
    legend.text <- paste("inv.logit(slope) =", round(par.estim, digits = 3))
    if(is.null(main)) main <- "Binomialness plot"
  },

  "nbinomial" = {
    par.ml <- goodfit(obj, type = type)$par
    size <- par.ml$size
    par.ml <- par.ml$prob
    phi <- function(nk, k, N, size)
      log(nk) - log(N * choose(size + k - 1, k))
    y <- phi(myfreq, mycount, sum(freq), size = size)
    fm <- lm(y ~ mycount)
    par.estim <- 1 - exp(coef(fm)[2])
    names(par.estim) <- "prob"
    legend.text <- paste("1-exp(slope) =", round(par.estim, digits = 3))
    if(is.null(main)) main <- "Negative binomialness plot"
  })

  yhat <- ifelse(myfreq > 1.5, myfreq - 0.67, 1/exp(1))
  yhat <- phi(yhat, mycount, sum(freq), size = size)
  if(!is.null(lambda)) yhat <- yhat + lambda - mycount * log(lambda)

  phat <- myfreq / sum(myfreq)
  ci.width <- qnorm(1-(1 - conf.level)/2) *
              sqrt(1-phat)/sqrt(myfreq - (0.25 * phat + 0.47)*sqrt(myfreq))

  RVAL <- cbind(count, freq, NA, NA, NA, NA, NA)
  RVAL[myindex,3:7] <- cbind(y,yhat,ci.width, yhat-ci.width, yhat + ci.width)
  RVAL <- as.data.frame(RVAL)
  names(RVAL) <- c("Counts", "Freq", "Metameter", "CI.center",
                   "CI.width", "CI.lower", "CI.upper")

  if(is.null(ylim)) ylim <- range(RVAL[,c(3,6,7)], na.rm = TRUE)
  plot(Metameter ~ Counts, ylim = ylim, data = RVAL,
       xlab = xlab, ylab = ylab, main = main, ...)
  abline(fm, col = line.col)

  if(conf.int) {
    points(CI.center ~ Counts, data = RVAL, pch = 19, cex = 0.6)
    arrows(RVAL[,1], RVAL[,6], RVAL[,1], RVAL[,7], length = 0, lty = 3)
  }

  if(legend) {
    mymin <- which.min(RVAL[,5])
    leg.x <- RVAL[mymin,1]
    if(RVAL[mymin,6] - ylim[1] > ylim[2] - RVAL[mymin,7])
      leg.y <- ylim[1] + 0.7 * (RVAL[mymin,6] - ylim[1])
    else leg.y <- ylim[2]

    legend.text <- c(paste("slope =", round(coef(fm)[2], digits = 3)),
                     paste("intercept =", round(coef(fm)[1], digits = 3)),
		     "", paste(names(par.estim),": ML =", round(par.ml, digits=3)),
		     legend.text)
    legend(leg.x, leg.y, legend.text, bty = "n")
  }
  invisible(RVAL)
}
"fourfoldplot" <-
function(x, color = c("#99CCFF","#6699CC","#FF5050","#6060A0", "#FF0000", "#000080"),
         conf.level = 0.95,
         std = c("margins", "ind.max", "all.max"), margin = c(1, 2),
         space = 0.2, main = NULL, mfrow = NULL, mfcol = NULL, extended = TRUE,
         ticks = 0.2, p.adjust.method = p.adjust.methods)
{
    ## Code for producing fourfold displays.
    ## Reference:
    ##   Friendly, M. (1994).
    ##   A fourfold display for 2 by 2 by \eqn{k} tables.
    ##   Technical Report 217, York University, Psychology Department.
    ##   http://www.math.yorku.ca/SCS/Papers/4fold/4fold.ps.gz
    ##
    ## Implementation notes:
    ##
    ##   We need plots with aspect ratio FIXED to 1 and glued together.
    ##   Hence, even if k > 1 we prefer keeping everything in one plot
    ##   region rather than using a multiple figure layout.
    ##   Each 2 by 2 pie is is drawn into a square with x/y coordinates
    ##   between -1 and 1, with row and column labels in [-1-space, -1]
    ##   and [1, 1+space], respectively.  If k > 1, strata labels are in
    ##   an area with y coordinates in [1+space, 1+(1+gamma)*space],
    ##   where currently gamma=1.25.  The pies are arranged in an nr by
    ##   nc layout, with horizontal and vertical distances between them
    ##   set to space.
    ##
    ##   The drawing code first computes the complete are of the form
    ##     [0, totalWidth] x [0, totalHeight]
    ##   needed and sets the world coordinates using plot.window().
    ##   Then, the strata are looped over, and the corresponding pies
    ##   added by filling rows or columns of the layout as specified by
    ##   the mfrow or mfcol arguments.  The world coordinates are reset
    ##   in each step by shifting the origin so that we can always plot
    ##   as detailed above.

    if(!is.array(x))
        stop("x must be an array")
    if(length(dim(x)) == 2) {
        x <- if(is.null(dimnames(x)))
            array(x, c(dim(x), 1))
        else
            array(x, c(dim(x), 1), c(dimnames(x), list(NULL)))
    }
    if(length(dim(x)) != 3)
        stop("x must be 2- or 3-dimensional")
    if(any(dim(x)[1:2] != 2))
        stop("table for each stratum must be 2 by 2")
    dnx <- dimnames(x)
    if(is.null(dnx))
        dnx <- vector("list", 3)
    for(i in which(sapply(dnx, is.null)))
        dnx[[i]] <- LETTERS[seq(length = dim(x)[i])]
    if(is.null(names(dnx)))
        i <- 1 : 3
    else
        i <- which(is.null(names(dnx)))
    if(any(i))
        names(dnx)[i] <- c("Row", "Col", "Strata")[i]
    dimnames(x) <- dnx
    k <- dim(x)[3]

    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")
    if(conf.level == 0)
        conf.level <- FALSE

    std <- match.arg(std)

    findTableWithOAM <- function(or, tab) {
        ## Find a 2x2 table with given odds ratio `or' and the margins
        ## of a given 2x2 table `tab'.
        m <- rowSums(tab)[1]
        n <- rowSums(tab)[2]
        t <- colSums(tab)[1]
        if(or == 1)
            x <- t * n / (m + n)
        else if(or == Inf)
            x <- max(0, t - m)
        else {
            A <- or - 1
            B <- or * (m - t) + (n + t)
            C <- - t * n
            x <- (- B + sqrt(B ^ 2 - 4 * A * C)) / (2 * A)
        }
        matrix(c(t - x, x, m - t + x, n - x), nr = 2)
    }

    drawPie <- function(r, from, to, n = 500, color = NA) {
        p <- 2 * pi * seq(from, to, length = n) / 360
        x <- c(cos(p), 0) * r
        y <- c(sin(p), 0) * r
        polygon(x, y, col = color)
        invisible(NULL)
    }

    stdize <- function(tab, std, x) {
        ## Standardize the 2 x 2 table `tab'.
        if(std == "margins") {
            if(all(sort(margin) == c(1, 2))) {
                ## standardize to equal row and col margins
                u <- sqrt(odds(tab)$or)
                u <- u / (1 + u)
                y <- matrix(c(u, 1 - u, 1 - u, u), nr = 2)
            }
            else if(margin %in% c(1, 2))
                y <- prop.table(tab, margin)
            else
                stop("incorrect margin specification")
        }
        else if(std == "ind.max")
            y <- tab / max(tab)
        else if(std == "all.max")
            y <- tab / max(x)
        y
    }

    odds <- function(x) {
        ## Given a 2 x 2 or 2 x 2 x k table `x', return a list with
        ## components `or' and `se' giving the odds ratios and standard
        ## deviations of the log odds ratios.
        if(length(dim(x)) == 2) {
            dim(x) <- c(dim(x), 1)
            k <- 1
        }
        else
            k <- dim(x)[3]
        or <- double(k)
        se <- double(k)
        for(i in 1 : k) {
            f <- x[ , , i]
            if(any(f == 0))
                f <- f + 0.5
            or[i] <- (f[1, 1] * f[2, 2]) / (f[1, 2] * f[2, 1])
            se[i] <- sqrt(sum(1 / f))
        }
        list(or = or, se = se)
    }

    gamma <- 1.25                       # Scale factor for strata labels
    debug <- FALSE                      # Visualize the geometry.
                                        # Not settable by user!
    angle.f <- c( 90, 180,  0, 270)     # `f' for `from'
    angle.t <- c(180, 270, 90, 360)     # `t' for `to'

    opar <- par(mar = c(0, 0, ifelse(is.null(main), 0, 2.5), 0))
    on.exit(par(opar))

    byrow <- FALSE
    if(!is.null(mfrow)) {
        nr <- mfrow[1]
        nc <- mfrow[2]
    }
    else if(!is.null(mfcol)) {
        nr <- mfcol[1]
        nc <- mfcol[2]
        byrow <- TRUE
    }
    else {
        nr <- ceiling(sqrt(k))
        nc <- ceiling(k / nr)
    }
    if(nr * nc < k)
        stop("incorrect geometry specification")
    if(byrow)
        indexMatrix <- expand.grid(1 : nc, 1 : nr)[, c(2, 1)]
    else
        indexMatrix <- expand.grid(1 : nr, 1 : nc)

    totalWidth <- nc * 2 * (1 + space) + (nc - 1) * space
    totalHeight <- if(k == 1)
        2 * (1 + space)
    else
        nr * (2 + (2 + gamma) * space) + (nr - 1) * space
    xlim <- c(0, totalWidth)
    ylim <- c(0, totalHeight)

    plot.new()
    plot.window(xlim = xlim, ylim = ylim, asp = 1)

    o <- odds(x)

    ## perform logoddsratio-test for each stratum (H0: lor = 0) and adjust p-values
    if(is.numeric(conf.level) && extended)
      p.lor.test <- p.adjust(sapply(1 : k, function(i) {
                               u <- abs(log(o$or[i])) / o$se[i]
                               2 * (1 - pnorm(u))
                             }),
                             method = p.adjust.method
                             )
    
    scale <- space / (2 * strheight("Ag"))
    v <- 0.95 - max(strwidth(as.character(c(x)), cex = scale)) / 2

    for(i in 1 : k) {

        tab <- x[ , , i]

        fit <- stdize(tab, std, x)

        xInd <- indexMatrix[i, 2]
        xOrig <- 2 * xInd - 1 + (3 * xInd - 2) * space
        yInd <- indexMatrix[i, 1]
        yOrig <- if(k == 1)
            (1 + space)
        else
            (totalHeight
             - (2 * yInd - 1 + ((3 + gamma) * yInd - 2) * space))
        plot.window(xlim - xOrig, ylim - yOrig, asp = 1)

        if(debug) {
            abline(h = -1 - space)
            abline(h =  1 + space)
            abline(h =  1 + (1 + gamma) * space)
            abline(v = -1 - space)
            abline(v =  1 + space)
        }

        ## drawLabels()
        u <- 1 + space / 2
        adjCorr <- 0.2
        text(0, u,
             paste(names(dimnames(x))[1],
                   dimnames(x)[[1]][1],
                   sep = ": "),
             adj = c(0.5, 0.5 - adjCorr),
             cex = scale)
        text(-u, 0,
             paste(names(dimnames(x))[2],
                   dimnames(x)[[2]][1],
                   sep = ": "),
             adj = c(0.5, 0.5 - adjCorr),
             cex = scale,
             srt = 90)
        text(0, -u,
             paste(names(dimnames(x))[1],
                   dimnames(x)[[1]][2],
                   sep = ": "),
             adj = c(0.5, 0.5 + adjCorr),
             cex = scale)
        text(u, 0,
             paste(names(dimnames(x))[2],
                   dimnames(x)[[2]][2],
                   sep = ": "),
             adj = c(0.5, 0.5 + adjCorr),
             cex = scale,
             srt = 90)
        if(k > 1) {
            text(0, 1 + (1 + gamma / 2) * space,
                 paste(names(dimnames(x))[3],
                       dimnames(x)[[3]][i],
                       sep = ": "),
                 cex = gamma * scale)
        }

        ## drawFrequencies()
        
        ### in extended plots, emphasize charts with significant logoddsratios
        emphasize <- if(extended && is.numeric(conf.level))
          2 * extended * (1 + (p.lor.test[i] < 1 - conf.level))
        else 0
        
        d <- odds(tab)$or
        drawPie(sqrt(fit[1,1]),  90, 180, col = color[1 + (d > 1) + emphasize])
        drawPie(sqrt(fit[2,1]), 180, 270, col = color[2 - (d > 1) + emphasize])
        drawPie(sqrt(fit[1,2]),   0,  90, col = color[2 - (d > 1) + emphasize])
        drawPie(sqrt(fit[2,2]), 270, 360, col = color[1 + (d > 1) + emphasize])
        u <- 1 - space / 2
        text(c(-v, -v,  v,  v),
             c( u, -u,  u, -u),
             as.character(c(tab)),
             cex = scale)

        ## draw ticks
        if(extended && ticks)
          if(d > 1) {
            lines(c(sqrt(fit[1,1])           * cos(3*pi/4),
                    (sqrt(fit[1,1]) + ticks) * cos(3*pi/4)),
                  c(sqrt(fit[1,1])           * sin(3*pi/4),
                    (sqrt(fit[1,1]) + ticks) * sin(3*pi/4)), lwd = 1)
            lines(c(sqrt(fit[2,2])           * cos(-pi/4),
                    (sqrt(fit[2,2]) + ticks) * cos(-pi/4)),
                  c(sqrt(fit[2,2])           * sin(-pi/4),
                    (sqrt(fit[2,2]) + ticks) * sin(-pi/4)), lwd = 1)
          } else {
            lines(c(sqrt(fit[1,2])           * cos(pi/4),
                    (sqrt(fit[1,2]) + ticks) * cos(pi/4)),
                  c(sqrt(fit[1,2])           * sin(pi/4),
                    (sqrt(fit[1,2]) + ticks) * sin(pi/4)), lwd = 1)
            lines(c(sqrt(fit[2,1])           * cos(-3*pi/4),
                    (sqrt(fit[2,1]) + ticks) * cos(-3*pi/4)),
                  c(sqrt(fit[2,1])           * sin(-3*pi/4),
                    (sqrt(fit[2,1]) + ticks) * sin(-3*pi/4)), lwd = 1)
          }
        
        ## drawConfBands()
        if(is.numeric(conf.level)) {
            or <- o$or[i]
            se <- o$se[i]
            ## lower
            theta <- or * exp(qnorm((1 - conf.level) / 2) * se)
            tau <- findTableWithOAM(theta, tab)
            r <- sqrt(c(stdize(tau, std, x)))
            for(j in 1 : 4)
                drawPie(r[j], angle.f[j], angle.t[j])
            ## upper
            theta <- or * exp(qnorm((1 + conf.level) / 2) * se)
            tau <- findTableWithOAM(theta, tab)
            r <- sqrt(c(stdize(tau, std, x)))
            for(j in 1 : 4)
                drawPie(r[j], angle.f[j], angle.t[j])
        }

        ## drawBoxes()
        polygon(c(-1,  1, 1, -1),
                c(-1, -1, 1,  1))
        lines(c(-1, 1), c(0, 0))
        for(j in seq(from = -0.8, to = 0.8, by = 0.2))
            lines(c(j, j), c(-0.02, 0.02))
        for(j in seq(from = -0.9, to = 0.9, by = 0.2))
            lines(c(j, j), c(-0.01, 0.01))
        lines(c(0, 0), c(-1, 1))
        for(j in seq(from = -0.8, to = 0.8, by = 0.2))
            lines(c(-0.02, 0.02), c(j, j))
        for(j in seq(from = -0.9, to = 0.9, by = 0.2))
            lines(c(-0.01, 0.01), c(j, j))

    }

    if(!is.null(main))
        mtext(main, cex = 1.5, adj = 0.5)

    return(invisible())
}
goodfit <- function(obj, type = c("poisson", "binomial", "nbinomial"),
                    method = c("ML", "MinChisq"), par = NULL)
{
    if(is.vector(obj)) {
      obj <- table(obj)
    }
    if(is.table(obj)) {
      if(length(dim(obj)) > 1) stop ("obj must be a 1-way table")
      freq <- as.vector(obj)
      count <- as.numeric(names(obj))
    } else {
      if(!(!is.null(ncol(obj)) && ncol(obj) == 2))
        stop("obj must be a 2-column matrix or data.frame")
      freq <- as.vector(obj[,1])
      count <- as.vector(obj[,2])
    }

    ## eliminate zero frequencies
    count <- count[!(freq < 1)]
    freq <- freq[!(freq < 1)]
    n <- length(count)
    df <- n - 1

    type <- match.arg(type)
    method <- match.arg(method)

    switch(type,

    "poisson" = {

      if(!is.null(par)) {
        if(!is.list(par)) stop("`par' must be a named list")
        if(!(names(par) == "lambda")) stop("`par' must specify `lambda'")
	par <- par$lambda
	method <- "fixed"
      }
      else if(method == "ML") {
        df <- df - 1
	par <- weighted.mean(count,freq)
      }
      else if(method == "MinChisq") {
        df <- df - 1

	chi2 <- function(x)
        {
	  p.hat <- diff(c(0, ppois(count[-n], lambda = x), 1))
	  expected <- sum(freq) * p.hat
          sum((freq - expected)^2/expected)
        }

	par <- optimize(chi2, range(count))$minimum
      }
      par <- list(lambda = par)
      p.hat <- dpois(count, lambda = par$lambda)
    },

    "binomial" = {
      size <- par$size
      if(is.null(size)) {
        size <- max(count)
        warning("size was not given, taken as maximum count")
      }

      if(!is.null(par$prob)) {
        if(!is.list(par)) stop("`par' must be a named list and specify `prob'")
	par <- par$prob
	method <- "fixed"
      }
      else if(method == "ML") {
        df <- df - 1
	par <- weighted.mean(count/size, freq)
      }
      else if(method == "MinChisq") {
        df <- df - 1

	chi2 <- function(x)
        {
	  p.hat <- diff(c(0, pbinom(count[-n], prob = x, size = size), 1))
          expected <- sum(freq) * p.hat
          sum((freq - expected)^2/expected)
        }

	par <- optimize(chi2, c(0,1))$minimum
      }
      par <- list(prob = par, size = size)
      p.hat <- dbinom(count, prob = par$prob, size = par$size)
    },


    "nbinomial" = {

      if(!is.null(par)) {
        if(!is.list(par)) stop("`par' must be a named list")
        if(is.character(all.equal(sum(match(names(par), c("size", "prob"))), 3))) stop("`par' must specify `prob' and `size'")
	method <- "fixed"
	par <- c(par$size, par$prob)
      }
      else if(method == "ML") {
        df <- df - 2

	require(package = MASS)
        par <- fitdistr(rep(count, freq), "negative binomial")$estimate
        par <- par[1]/c(1, sum(par))
     }
     else if(method == "MinChisq") {
       df <- df - 2

	## MM
	xbar <- weighted.mean(count,freq)
	s2 <- var(rep(count,freq))
	p <- xbar / s2
	size <- xbar^2/(s2 - xbar)
        par1 <- c(size, p)

	## minChisq
        chi2 <- function(x)
        {
	  p.hat <- diff(c(0, pnbinom(count[-n], size = x[1], prob = x[2]), 1))
          expected <- sum(freq) * p.hat
          sum((freq - expected)^2/expected)
        }

	par <- optim(par1, chi2)$par
      }
      par <- list(size = par[1], prob = par[2])
      p.hat <- dnbinom(count, size = par$size, prob = par$prob)
    })

    expected <- sum(freq) * p.hat

    RVAL <- list(observed = freq,
                 count = count, fitted = expected,
		 type = type, method = method, df = df,
		 par = par)
    class(RVAL) <- "goodfit"
    RVAL
}

print.goodfit <- function(x, ...)
{
    cat(paste("\nObserved and fitted values for", x$type, "distribution\n"))
    if(x$method == "fixed")
      cat("with fixed parameters \n\n")
    else
      cat(paste("with paramaters estimated by `", x$method, "' \n\n", sep = ""))
    RVAL <- cbind(x$count, x$observed, x$fitted)
    colnames(RVAL) <- c("count", "observed", "fitted")
    rownames(RVAL) <- rep("", nrow(RVAL))
    print(RVAL)
    invisible(x)
}

summary.goodfit <- function(object, ...)
{
    df <- object$df
    obsrvd <- object$observed
    count <- object$count
    expctd <- fitted(object)

    G2 <- sum(obsrvd * log(obsrvd/expctd)) * 2

    n <- length(obsrvd)
    switch(object$type,
    "poisson" = { pfun <- "ppois" },
    "binomial" = { pfun <- "pbinom" },
    "nbinomial" = { pfun <- "pnbinom" })
    p.hat <- diff(c(0, do.call(pfun, c(list(q = count[-n]), object$par)), 1))
    expctd <- p.hat * sum(obsrvd)
    X2 <- sum((obsrvd - expctd)^2/expctd)

    names(G2) <- "Likelihood Ratio"
    names(X2) <- "Pearson"
    if(any(expctd) < 5 & object$method != "ML") warning("Chi-squared approximation may be incorrect")

    switch(object$method,
    "ML" = { RVAL <- G2 },
    "MinChisq" = { RVAL <- X2 },
    "fixed" = { RVAL <- c(X2, G2) })

    RVAL <- cbind(RVAL, df, pchisq(RVAL, df = df, lower = FALSE))
    colnames(RVAL) <- c("X^2", "df", "P(> X^2)")

    cat(paste("\n\t Goodness-of-fit test for", object$type, "distribution\n\n"))
    print(RVAL)
    invisible(RVAL)
}

plot.goodfit <- function(x, ...)
{
  rootogram(x, ...)
}

fitted.goodfit <- function(object, ...)
{
  object$fitted
}

predict.goodfit <- function(object, newcount = NULL, type = c("response", "prob"), ...)
{
  if(is.null(newcount)) newcount <- object$count
  type <- match.arg(type)

  switch(object$type,
  "poisson" = { densfun <- "dpois" },
  "binomial" = { densfun <- "dbinom" },
  "nbinomial" = { densfun <- "dnbinom" })

  RVAL <- do.call(densfun, c(list(x = newcount), object$par))
  if(type == "response") RVAL <- RVAL * sum(object$observed)
  return(RVAL)
}

mosaicpairs <- function(x, ...) UseMethod("mosaicpairs")

"mosaicpairs.formula" <-
function(formula, data = NULL, ...,
         main = deparse(substitute(data)), subset)
{
    m <- match.call(expand.dots = FALSE)
    edata <- eval(m$data, parent.frame())
    if(inherits(edata, "ftable")
       || inherits(edata, "table")
       || length(dim(edata)) > 2) {
        dat <- as.table(data)
        varnames <- attr(terms(formula), "term.labels")
        if(all(varnames != "."))
            ind <- match(varnames, names(dimnames(dat)))
            if (any(is.na(ind)))
              stop(paste("Can't find", paste(varnames[is.na(ind)], collapse=" / "), "in", main))
        mosaicpairs(dat, main = main, ...)
    }
    else {
        if(is.matrix(edata))
            m$data <- as.data.frame(data)
        m$... <- NULL
        m[[1]] <- as.name("model.frame")
        mf <- eval(m, parent.frame())
        mosaicpairs(table(mf), main = main, ...)
    }
}

"mosaicpairs.default" <-
  function(x, main = deparse(substitute(x)), xlab = NULL, ylab = NULL, labels, ...,
           type = c("pairwise", "total", "conditional", "joint"),
           shade = TRUE, oma = NULL, cex.labels = NULL, label.pos = 0.5,
	   font.labels = 1, gap = 1)
  {


    type <- match.arg(type)
    nc<-length(dim(x))
    index<-1:length(dim(x))
    if (nc < 2)
      stop("dimensions less than 2 in the argument to mosaicpairs")

    if (missing(labels)) {
      labels <-  names(dimnames(x))
      if (is.null(labels))
        labels <- paste("var", 1:nc)
    }
    if (is.null(oma)) {
      oma <- c(4, 4, 4, 4)
      if (!is.null(main))
        oma[3] <- 6
    }

    opar <- par(mfrow = c(nc, nc), mar = rep(gap/2, 4),oma=oma)
    on.exit(par(opar))

    for (i in 1:nc)
      for (j in 1:nc) {mfg <- par("mfg")
                       if (i == j) {

                         plot(1,type = "n",axes = FALSE, xlab = "", ylab = "");
                         par(usr = c(0, 1, 0, 1))
                         if (is.null(cex.labels)) {
                           l.wid <- strwidth(labels, "user")
                           cex.labels <- max(0.8, min(2, 0.9/max(l.wid)))
                         }
                         text(0.5, label.pos, labels[i], cex = cex.labels, font = font.labels);
                         box();
                       }
                       else

                         {
                           switch(type,
                                  pairwise = mosaicplot(margin.table(x, c(j,i)),
                                    main = NULL,
                                    shade=shade, clegend=FALSE, xlab="", ylab="", cex.axis=1 ),
                                  total = mosaicplot(x, shade = shade, clegend = FALSE,
                                    main = NULL,
                                    xlab="", ylab="", cex.axis=1),
                                  conditional = mosaicplot(margin.table(x,
                                    c(j, i, index[!index %in% c(j, i)])), shade=shade,
                                    margin=list(c(j, index[!index %in% c(j, i)]),
                                      c(i, index[!index %in% c(j, i)])),
                                    main = NULL,
                                    clegend=FALSE, xlab="", ylab="", cex.axis=1.2),
                                  joint = mosaicplot(margin.table(x,
                                    c(j, i, index[!index %in% c(j, i)])), shade=shade,
                                    margin=list(c(j, i), c(index[!index %in% c(j, i)])),
                                    main = NULL,
                                    clegend=FALSE, xlab="", ylab="", cex.axis=1.2)
                                  )

                         }
                     }

 if (!is.null(main))
        mtext(main, 3, 3, TRUE, 0.5, cex = 2)
    invisible(NULL)

  }
## Original code copyright (C) 1998 John W. Emerson

mosaicplot <- function(x, ...) UseMethod("mosaicplot")

### Changes by MM:
## - NULL instead of NA for default arguments, etc  [R / S convention]
## - plotting at end; cosmetic; warn about unused ... since we really don't..
## - mosaic.cell():  ...(?)
### Changes by KH:
##   Shading of boxes to visualize deviations from independence by
##   displaying sign and magnitude of the standardized residuals.
### Changes by W. Fischer and U. Ligges:
## - Deparsing x in for main title. New arguments: sub, las, cex.axis
## - made to work by BDR

mosaicplot.default <-
function(x, main = deparse(substitute(x)), sub = NULL, xlab = NULL,
         ylab = NULL, sort = NULL, off = NULL, dir = NULL,
         color = FALSE, shade = !(is.null(residuals) && is.null(margin)), margin = NULL,
         cex.axis = 0.66, las = par("las"), clegend = TRUE, 
         type = c("pearson", "deviance", "FT"), residuals = NULL, ...)
{
    mosaic.cell <- function(X, x1, y1, x2, y2, srt.x, srt.y,
            adj.x, adj.y, off, dir, color, lablevx, lablevy,
            maxdim, currlev, label)
    {
        ## Recursive function doing `the job'
        ##
        ## explicitly relying on (1,1000)^2 user coordinates.
        p <- ncol(X) - 2
        if (dir[1] == "v") {            # split here on the X-axis.
            xdim <- maxdim[1]
            XP <- rep(0, xdim)
            for (i in 1:xdim) {
                XP[i] <- sum(X[X[,1]==i,p]) / sum(X[,p])
            }
            white <- off[1] * (x2 - x1) / max(1, xdim-1)
            x.l <- x1
            x.r <- x1 + (1 - off[1]) * XP[1] * (x2 - x1)
            if (xdim > 1) {
                for (i in 2:xdim) {
                    x.l <- c(x.l, x.r[i-1] + white)
                    x.r <- c(x.r, x.r[i-1] + white +
                             (1 - off[1]) * XP[i] * (x2 - x1))
                }
            }
            if (lablevx > 0) {
                this.lab <-
                    if (is.null(label[[1]][1])) {
                        paste(rep(as.character(currlev),
                                  length(currlev)),
                              as.character(1:xdim), sep=".")
                    } else label[[1]]
                text(x= x.l + (x.r - x.l) / 2,
                     y= 965 + 22 * (lablevx - 1),
                     srt=srt.x, adj=adj.x, cex=cex.axis, this.lab)
            }
            if (p > 2) {                # recursive call.
                for (i in 1:xdim) {
                    if (XP[i] > 0) {
                        Recall(X[X[,1]==i, 2:(p+2) , drop=FALSE],
                               x.l[i], y1, x.r[i], y2,
                               srt.x, srt.y, adj.x, adj.y,
                               off[-1], dir[-1], color,
                               lablevx-1, (i==1)*lablevy,
                               maxdim[-1], currlev+1, label[2:p])
                    } else {
                        segments(rep(x.l[i],3), y1+(y2-y1)*c(0,2,4)/5,
                                 rep(x.l[i],3), y1+(y2-y1)*c(1,3,5)/5)
                    }
                }
            } else { # ncol(X) <= 1 : final split polygon and segments.
                for (i in 1:xdim) {
                    if (XP[i] > 0) {
                        polygon(c(x.l[i], x.r[i], x.r[i], x.l[i]),
                                c(y1, y1, y2, y2),
                                lty = if(shade[1]) X[i, p+1] else 1,
                                col = color[if(shade[1]) X[i, p+2] else i])
                        ## <KH 2000-08-29>
                        ## Is this really needed?
                        ## segments(c(rep(x.l[i],3),x.r[i]),
                        ##          c(y1,y1,y2,y2),
                        ##          c(x.r[i],x.l[i],x.r[i],x.r[i]),
                        ##          c(y1,y2,y2,y1))
                        ## </KH>
                    } else {
                        segments(rep(x.l[i],3), y1+(y2-y1)*c(0,2,4)/5,
                                 rep(x.l[i],3), y1+(y2-y1)*c(1,3,5)/5)
                    }
                }
            }
        } else { ## dir[1] - "horizontal" : split here on the Y-axis.
            ydim <- maxdim[1]
            YP <- rep(0, ydim)
            for (j in 1:ydim) {
                YP[j] <- sum(X[X[,1]==j,p]) / sum(X[,p])
            }
            white <- off[1] * (y2 - y1) / (max(1, ydim - 1))
            y.b <- y2 - (1 - off[1]) * YP[1] * (y2 - y1)
            y.t <- y2
            if (ydim > 1) {
                for (j in 2:ydim) {
                    y.b <- c(y.b, y.b[j-1] - white -
                             (1 - off[1]) * YP[j] * (y2 - y1))
                    y.t <- c(y.t, y.b[j-1] - white)
                }
            }
            if (lablevy > 0) {
                this.lab <-
                    if (is.null(label[[1]][1])) {
                        paste(rep(as.character(currlev),
                                  length(currlev)),
                              as.character(1:ydim), sep=".")
                    } else label[[1]]
                text(x= 35 - 20 * (lablevy - 1),
                     y= y.b + (y.t - y.b) / 2,
                     srt=srt.y, adj=adj.y, cex=cex.axis, this.lab)
            }
            if (p > 2) {                # recursive call.
                for (j in 1:ydim) {
                    if (YP[j] > 0) {
                        Recall(X[X[,1]==j, 2:(p+2) , drop=FALSE],
                               x1, y.b[j], x2, y.t[j],
                               srt.x, srt.y, adj.x, adj.y,
                               off[-1], dir[-1], color,
                               (j==1)*lablevx, lablevy-1,
                               maxdim[-1], currlev+1, label[2:p])
                    } else {
                        segments(x1+(x2-x1)*c(0,2,4)/5, rep(y.b[j],3),
                                 x1+(x2-x1)*c(1,3,5)/5, rep(y.b[j],3))
                    }
                }
            } else { # ncol(X) <= 1: final split polygon and segments.
                for (j in 1:ydim) {
                    if (YP[j] > 0) {
                        polygon(c(x1,x2,x2,x1),
                                c(y.b[j],y.b[j],y.t[j],y.t[j]),
                                lty = if(shade[1]) X[j, p+1] else 1,
                                col = color[if(shade[1]) X[j, p+2] else j])
                        ## <KH 2000-08-29>
                        ## Is this really needed?
                        ## segments(c(x1,x1,x1,x2),
                        ##          c(y.b[j],y.b[j],y.t[j],y.t[j]),
                        ##          c(x2,x1,x2,x2),
                        ##          c(y.b[j],y.t[j],y.t[j],y.b[j]))
                        ## </KH>
                    } else {
                        segments(x1+(x2-x1)*c(0,2,4)/5, rep(y.b[j],3),
                                 x1+(x2-x1)*c(1,3,5)/5, rep(y.b[j],3))
                    }
                }
            }
        }
    }

    ##-- Begin main function

    ## Calculate string rotation for different settings of las:
    srt.x <- if(las > 1) 90 else 0
    srt.y <- if(las == 0 || las == 3) 90 else 0

    if(is.null(dim(x)))
        x <- as.array(x)
    else if(is.data.frame(x))
        x <- data.matrix(x)
    dimd <- length(dx <- dim(x))
    if(dimd == 0 || any(dx == 0))
        stop("`x' must not have 0 dimensionality")
    if(length(list(...)))
        warning("extra argument(s) `", names(list(...)), "'  disregarded..")
    ##-- Set up `Ind' matrix : to contain indices and data
    Ind <- 1:dx[1]
    if(dimd > 1) {
        Ind <- rep(Ind, prod(dx[2:dimd]))
        for (i in 2:dimd) {
            Ind <- cbind(Ind,
                         c(matrix(1:dx[i], byrow=TRUE,
                                  nr = prod(dx[1:(i-1)]),
                                  nc = prod(dx[i:dimd]))))
        }
    }
    Ind <- cbind(Ind, c(x))
    ## Ok, now the columns of `Ind' are the cell indices (which could
    ## also have been created by `expand.grid()' and the corresponding
    ## cell counts.  We add two more columns for dealing with *EXTENDED*
    ## mosaic plots which are produced unless `shade' is FALSE, which
    ## currently is the default.  These columns have NAs for the simple
    ## case.  Otherwise, they specify the line type (1 for positive and
    ## 2 for negative residuals) and color (by giving the index in the
    ## color vector which ranges from the ``most negative'' to the
    ## ``most positive'' residuals.
    if(is.logical(shade) && !shade) {
        Ind <- cbind(Ind, NA, NA)
    }
    else {
        if(is.logical(shade))
            shade <- c(2, 4)
        else if(any(shade <= 0) || length(shade) > 5)
            stop("invalid shade specification")
        shade <- sort(shade)
        breaks <- c(-Inf, - rev(shade), 0, shade, Inf)
        color <- c(hsv(0,               # red
                       s = seq(1, to = 0, length = length(shade) + 1)),
                   hsv(4/6,             # blue
                       s = seq(0, to = 1, length = length(shade) + 1)))

        ## <EXPERIMENTAL>
        ## Fit the loglinear model.        
        if(inherits(margin, "formula")) {
            require(MASS)
            E <- fitted(loglm(margin, x, fitted = TRUE))
        }
        else {
            if(is.null(margin))
                margin <- as.list(1:dimd)
            E <- loglin(x, margin, fit = TRUE, print = FALSE)$fit
        }
        ## Compute the residuals.
        type <- match.arg(type)
        if(is.null(residuals))
            residuals <-
                switch(type,
                       pearson = (x - E) / sqrt(E),
                       deviance = {
                           tmp <-
                               2 * (x * log(ifelse(x==0, 1, x/E)) - (x-E))
                           tmp <- sqrt(pmax(tmp, 0))
                           ifelse(x > E, tmp, -tmp)
                       },
                       FT = sqrt(x) + sqrt(x + 1) - sqrt(4 * E + 1))
        ## </EXPERIMENTAL>        
        
        ## And add the information to the data matrix.
        Ind <- cbind(Ind,
                     c(1 + (residuals < 0)),
                     as.numeric(cut(residuals, breaks)))
    }

    ## The next four may all be NULL:
    label <- dimnames(x)
    nam.dn <- names(label)
    if(is.null(xlab)) xlab <- nam.dn[1]
    if(is.null(ylab)) ylab <- nam.dn[2]

    if (is.null(off) || length(off) != dimd) { # Initialize spacing.
        off <- rep(10, length=dimd)
    }
    if (is.null(dir) || length(dir) != dimd) {# Initialize directions
        dir <- rep(c("v","h"), length=dimd)
    }
    if (!is.null(sort)) {
        if(length(sort) != dimd)
            stop("length(sort) doesn't conform to dim(x)")
        ## Sort columns.
        Ind[,1:dimd] <- Ind[,sort]
        off <- off[sort]
        dir <- dir[sort]
        label <- label[sort]
    }

    ncolors <- length(tabulate(Ind[,dimd]))
    if(!shade && ((is.null(color) || length(color) != ncolors))) {
        color <-
            if (is.logical(color) && color[1])
                heat.colors(ncolors)
            else if (is.null(color) || (is.logical(color) && !color[1]))
                rep(0, ncolors)
            else ## recycle
                rep(color, length = ncolors)
    }

    ##-- Plotting
    plot.new()
    if(!is.logical(clegend))
      stop("clegend must be logical")
    if(!shade || !clegend) {
        opar <- par(usr = c(1, 1000, 1, 1000), mgp = c(1, 1, 0))
        on.exit(par(opar))
    }
    else {
        ## This code is extremely ugly, and certainly can be improved.
        ## In the case of extended displays, we also need to provide a
        ## legend for the shading and outline patterns.  The code works
        ## o.k. with integer breaks in `shade'; rounding to two 2 digits
        ## will not be good enough if `shade' has length 5.
        pin <- par("pin")
        rtxt <- "Standardized\nResiduals:"
        ## Compute cex so that the rotated legend text does not take up
        ## more than 1/12 of the of the plot region horizontally and not
        ## more than 1/4 vertically.
        rtxtCex <- min(1,
                       pin[1] / (strheight(rtxt, units = "inches") * 12),
                       pin[2] / (strwidth (rtxt, units = "inches") / 4))
        rtxtWidth <- 0.1                # unconditionally ..
        ## We put the legend to the right of the third axis.
        opar <- par(usr = c(1, 1000 * (1.1 + rtxtWidth), 1, 1000),
                    mgp = c(1, 1, 0))
        on.exit(par(opar))
        rtxtHeight <-
            strwidth(rtxt, units = "i", cex = rtxtCex) / pin[2]
        text(1000 * (1.05 + 0.5 * rtxtWidth), 0, labels = rtxt,
             adj = c(0, 0.25), srt = 90, cex = rtxtCex)
        ## `len' is the number of positive or negative intervals of
        ## residuals (so overall, there are `2 * len')
        len <- length(shade) + 1
        ## `bh' is the height of each box in the legend (including the
        ## separating whitespace
        bh <- 0.95 * (0.95 - rtxtHeight) / (2 * len)
        x.l <- 1000 * 1.05
        x.r <- 1000 * (1.05 + 0.7 * rtxtWidth)
        y.t <- 1000 * rev(seq(from = 0.95, by = - bh, length = 2 * len))
        y.b <- y.t - 1000 * 0.8 * bh
        ltype <- c(rep(2, len), rep(1, len))
        for(i in 1 : (2 * len)) {
            polygon(c(x.l, x.r, x.r, x.l),
                    c(y.b[i], y.b[i], y.t[i], y.t[i]),
                    col = color[i],
                    lty = ltype[i])
        }
        brks <- round(breaks, 2)
        y.m <- y.b + 1000 * 0.4 * bh
        text(1000 * (1.05 + rtxtWidth), y.m,
             c(paste("<", brks[2], sep = ""),
               paste(brks[2 : (2 * len - 1)],
                     brks[3 : (2 * len)],
                     sep = ":"),
               paste(">", brks[2 * len], sep = "")),
             srt = 90, cex = cex.axis)
    }

    if (!is.null(main) || !is.null(xlab) || !is.null(ylab) || !is.null(sub))
        title(main, sub = sub, xlab = xlab, ylab = ylab)
    adj.x <- adj.y <- 0.5
    x1 <- 50; y1 <- 5; x2 <- 950; y2 <- 950
    maxlen.xlabel <- maxlen.ylabel <- 35
    ## Calculations required for 'las' related string rotation
    ## and adjustment
    if(srt.x == 90){
        maxlen.xlabel <-
            max(strwidth(label[[dimd + 1 - match('v', rev(dir))]],
                cex = cex.axis))
        adj.x <- 1
        y2 <- y2 - maxlen.xlabel
    }
    if(srt.y == 0){
        maxlen.ylabel <-
            max(strwidth(label[[match('h', dir)]],
                cex = cex.axis))
        adj.y <- 0
        x1 <- x1 + maxlen.ylabel
    }

    mosaic.cell(Ind, x1 = x1, y1 = y1, x2 = x2, y2 = y2,
                srt.x = srt.x, srt.y = srt.y, adj.x = adj.x,
                adj.y = adj.y, off = off / 100, dir = dir,
                color = color, lablevx = 2, lablevy = 2,
                maxdim = apply(as.matrix(Ind[,1:dimd]), 2, max),
                currlev = 1, label = label)
}

mosaicplot.formula <-
function(formula, data = NULL, ...,
         main = deparse(substitute(data)), subset)
{
    m <- match.call(expand.dots = FALSE)
    edata <- eval(m$data, parent.frame())
    if(inherits(edata, "ftable")
       || inherits(edata, "table")
       || length(dim(edata)) > 2) {
        dat <- as.table(data)
        varnames <- attr(terms(formula), "term.labels")
        if(all(varnames != ".")) {
            ind <- match(varnames, names(dimnames(dat)))
            if (any(is.na(ind)))
              stop(paste("Can't find", paste(varnames[is.na(ind)], collapse=" / "), "in", main))
            dat <- margin.table(dat, ind)
          }
        mosaicplot(dat, main = main, ...)
    }
    else {
        if(is.matrix(edata))
            m$data <- as.data.frame(data)
        m$... <- NULL
        m[[1]] <- as.name("model.frame")
        mf <- eval(m, parent.frame())
        mosaicplot(table(mf), main = main, ...)
    }
}
"oddsratio" <-
function (x, stratum = NULL, log = TRUE, conf.level = 0.95) {
  l <- length(dim(x))
  if (l > 2 && is.null(stratum))
    stratum <- 3:l
  if (l - length(stratum) > 2)
    stop("All but 2 dimensions must be specified as strata.")
  if (l == 2 && dim(x) != c(2,2))
    stop("Not a 2 x 2 - table.")
  if (!is.null(stratum) && dim(x)[-stratum] != c(2,2))
    stop("Need strata of 2 x 2 - tables.")
 
  lor <- function (y) {
    y <- y + 0.5 
    or <- y[1,1] * y[2,2] / y[1,2] / y[2,1]
    if (log) log(or) else or
  }

  ase <- function(y) sqrt(sum(1/(y + 0.5)))

  if(is.null(stratum)) {
    LOR <- lor(x)
    ASE <- ase(x)
  } else {
    LOR <- apply(x, stratum, lor)
    ASE <- apply(x, stratum, ase)
  }

  I <- ASE * qnorm((1 + conf.level) / 2)
  Z <- LOR / ASE
  
  structure(LOR,
            ASE = if(log) ASE,
            lwr = if(log) LOR - I else exp(log(LOR) - I),
            upr = if(log) LOR + I else exp(log(LOR) + I),
            Z   = if(log) Z,
            P   = if(log) 1 - pnorm(abs(Z)),
            log = log,
            class = "oddsratio"
            )}

"print.oddsratio" <-
function(x, ...) {
  if (length(dim(x)) > 1)
    print(cbind(unclass(x)))
  else
    print(c(x))
  invisible(x)
}

"summary.oddsratio" <-
function(object, ...) {
  if(!is.null(dim(object)))
    ret <- object
  else {
    ret <- cbind(object,
          ASE = attr(object, "ASE"),
          Z   = attr(object, "Z"),
          P   = attr(object, "P"),
          lwr = attr(object, "lwr"),
          upr = attr(object, "upr")
          )
    colnames(ret)[1] <- if(attr(object, "log")) "Log Odds Ratio" else "Odds Ratio"
  }
  
  class(ret) <- "summary.oddsratio"
  ret
}


"print.summary.oddsratio" <-
function(x, ...) {
  if(!is.null(attr(x, "log"))) {
    cat("\n")
    cat(if(attr(x, "log")) "Log Odds Ratio(s):" else "Odds Ratio(s):", "\n\n")
    print.oddsratio(x)
    cat("\nAsymptotic Standard Error(s):\n\n")
    print(attr(x, "ASE"))
    cat("\n")
  } else print(unclass(x))
  invisible(x)
}

"plot.oddsratio" <-
function(x,
         confidence = TRUE,
         type = "o",
         ylab = NULL,
         xlab = "Strata",
         whiskers = 0.1,
         ...)
{
  if (length(dim(x)) > 1)
    stop ("Plot function works only on vectors.")
  
  yrange <- range(x)
  
  if(confidence) {
    lwr <- attr(x, "lwr")
    upr <- attr(x, "upr")
    yrange[1] <- trunc(min(yrange[1], min(lwr)))
    yrange[2] <- ceiling(max(yrange[2], max(upr)))
  }

  plot(unclass(x),
       xlab = xlab,
       ylab = if(!is.null(ylab)) ylab else if(attr(x, "log")) "Log Odds Ratio" else "Odds Ratio",
       type = type,
       xaxt = "n",
       ylim = yrange,
       ...)
  axis (1, at = 1:length(x), names(x))

  if (confidence)
    for (i in 1:length(x)) {
      lines(c(i, i), c(lwr[i], upr[i]))
      lines(c(i - whiskers/2, i + whiskers/2), c(lwr[i], lwr[i]))
      lines(c(i - whiskers/2, i + whiskers/2), c(upr[i], upr[i]))
    }
}









rootogram <- function(x, ...)
{
  UseMethod("rootogram")
}

rootogram.goodfit <- function(x, ...)
{
  rootogram.default(x$observed, x$fitted, names = x$count, ...)
}

rootogram.default <- function(x, fitted, names = NULL, scale = c("sqrt", "raw"),
                              type = c("hanging", "standing", "deviation"),
			      bar.col = grey(0.7), line.col = 2,
			      xlab = NULL, ylab = NULL, ylim = NULL, ...)
{
   if(is.null(names)) names <- names(x)
   if(is.table(x)) {
     if(length(dim(x)) > 1) stop ("x must be a 1-way table")
     x <- as.vector(x)
   }
   obs <- x
   fit <- fitted
   if(is.null(xlab)) {xlab <-  "Number of Occurrences"}

   if(match.arg(scale) == "sqrt") {
     obs <- sqrt(obs)
     fit <- sqrt(fit)
     if(is.null(ylab)) {ylab <- "sqrt(Frequency)"}
   } else {
     if(is.null(ylab)) {ylab <- "Frequency"} }


   switch(match.arg(type),

   "hanging" = {
     if(is.null(ylim)) {ylim <- range(-0.1 * c(fit-obs,fit),
                        c(fit-obs,fit)) + c(0, 0.1)}
     dummy <- barplot(obs, names = names, col = bar.col, beside = FALSE,
             xlab = xlab, ylab = ylab, shift = fit - obs, ylim = ylim, ...)
     lines(dummy, fit, col = line.col, type = "b", pch = 19)
     abline(h = 0)
   },

   "standing" = {
     if(is.null(ylim)) {ylim <- range(-0.01 * c(obs,fit), c(obs,fit)) }
     dummy <- barplot(obs, names = names, col = bar.col,
                      xlab = xlab, ylab = ylab, ylim = ylim, ...)
     lines(dummy, fit, col = line.col, type = "b", pch = 19)
   },

   "deviation" = {
     if(is.null(ylim)) {ylim <- range(-0.1 * c(fit-obs,fit),
                        c(fit-obs,fit)) + c(0, 0.1)}
     dummy <- barplot(fit - obs, names = names, col = bar.col,
                      xlab = xlab, ylab = ylab, ylim = ylim, ...)
     lines(dummy, fit, col = line.col, type = "b", pch = 19)
   })
}

"sieveplot" <- function (x, ...)
  UseMethod ("sieveplot")

"sieveplot.formula" <-
function (formula, data = NULL, ..., subset) 
{
    m <- match.call(expand.dots = FALSE)
    edata <- eval(m$data, parent.frame())
    if (inherits(edata, "ftable") || inherits(edata, "table")) {
        data <- as.table(data)
        varnames <- attr(terms(formula), "term.labels")
        if (all(varnames != ".")) 
            data <- margin.table(data, match(varnames, names(dimnames(data))))
        sieveplot(data, ...)
    }
    else {
        if (is.matrix(edata)) 
            m$data <- as.data.frame(data)
        m$... <- NULL
        m[[1]] <- as.name("model.frame")
        mf <- eval(m, parent.frame())
        if (length(formula) == 2) {
          by <- mf
          y <- NULL
        }
        else {
          i <- attr(attr(mf, "terms"), "response")
          by <- mf[-i]
          y <- mf[[i]]
        }
        by <- lapply(by, factor)
        x <- if (is.null(y)) 
          do.call("table", by)
        else if (NCOL(y) == 1) 
          tapply(y, by, sum)
        else {
          z <- lapply(as.data.frame(y), tapply, by, sum)
          array(unlist(z), dim = c(dim(z[[1]]), length(z)), dimnames = c(dimnames(z[[1]]), 
                                                              list(names(z))))
        }
        x[is.na(x)] <- 0

        sieveplot(x, ...)
      }
}

"sieveplot.default" <-
  function(x,
           reverse.y = TRUE,
           type = c("sieve","expected"),
           main = NULL,
           values = c("none", "cells", "margins", "both"),
           frequencies = c("absolute", "relative"),
           sieve.colors = c("red","blue"),
           sieve.lty = c("longdash", "solid"),
           exp.color = "gray",
           exp.lty = "dotted",
           margin = 0.01,
           cex.main = 2,
           cex.lab = 1.5,
           xlab = names(dimnames(x))[2],
           ylab = names(dimnames(x))[1],
           ...)
{
  ## parameter handling
  if (length(dim(x)) > 2)
    stop ("Function only implemented for two-way tables")
  
  type <- match.arg(type)
  values <- match.arg(values)
  frequencies <- match.arg(frequencies)
  if (is.null(main))
      main <- if (type == "sieve") "Sieve diagram" else "Expected frequencies"

  nc   <- ncol(x)
  nr   <- nrow(x)
  if (reverse.y) x <- x[nr:1,]

  ## compute relative frequencies
  n <- sum(x)
  colFreqs <- colSums(x) / n
  rowFreqs <- rowSums(x) / n

  ## expected values
  ex <- rowFreqs %o% colFreqs * n

  ## signs of deviations
  sgn <- ex - x < 0

  # margins, limits (hard-coded, argh!)
  bm <- 0.1
  lm <- 0.1
  tm <- 0.1 + 0.05 * values %in%  c("margins", "both")
  rm <- 0.1

  xlim <- c(0, 1 + (nc - 1) * margin + lm + rm)
  ylim <- c(0, 1 + (nr - 1) * margin + tm + bm)

  ## box coordinates for expected areas
  x1 <- lm + c(0, cumsum(colFreqs + margin)[-nc])
  x2 <- x1 + colFreqs
  xmid <- (x1 + x2) / 2
  
  y2 <- bm + 1 + (nr - 1) * margin - c(0, cumsum(rowFreqs + margin)[-nr]) 
  y1 <- y2 - rowFreqs
  ymid <- (y1 + y2) / 2

  ## setup device
  opar <- par(mar = c(0, 0, 0, 0))
  on.exit(par(opar))
  plot.new()
  par(usr = c(xlim, ylim))
  plot.window(xlim = xlim, ylim = ylim, asp = 1)
  
  ## title
  text(x = lm + (1 + (nc - 1) * margin) / 2, y = ylim[2], labels = main, cex = cex.main)

  ## axis labels
  text(x = lm + (1 + (nc - 1) * margin) / 2, y = 0, labels = xlab, cex = cex.lab)
  text(x = 0, y = bm + (1 + (nr - 1) * margin) / 2, labels = ylab, cex = cex.lab, srt = 90)
  
  ## boxes
  for (i in 1:nr)
    for (j in 1:nc) {
      
      ## WRITE LABELS

      if (j == 1) { ## y-axis
        text(x = lm - 0.03, y = ymid[i], labels = dimnames(x)[[1]][i], srt = 90, ...)
        ## optionally, write marginal frequencies
        if (values %in%  c("margins", "both"))
          text(x = 1 + nc * margin + lm + 0.03, y = ymid[i], font = 2,
               labels = if (frequencies == "relative") round(rowFreqs[i], 2)
                        else round(rowFreqs[i] * n, 1), srt = 90, ...)
      }
      if (i == 1) { ## x-axis
        text(y = bm - 0.03 + values %in% c("margins", "both") * (1 + nr * margin + 0.04),
             x = xmid[j], labels = dimnames(x)[[2]][j], ...)
        ## optionally, write marginal frequencies
        if (values %in%  c("margins","both"))
          text(pos = 1, x = xmid[j], y = bm - 0.01, font = 2,
               labels = if (frequencies == "relative") round(colFreqs[j], 2)
                        else round(colFreqs[j] * n, 1), ...)
      }

      ## DRAW GRID

      square.side <- sqrt(colFreqs[j] * rowFreqs[i] / if (type == "sieve") x[i, j] else ex[i, j])
      dev <- sgn[i, j] + 1
      line.color <- if (type == "sieve") sieve.colors[dev] else exp.color
      line.type  <- if (type == "sieve") sieve.lty[dev] else exp.lty
      for (ii in seq(0, rowFreqs[i], by = square.side))
        lines(c(x1[j], x2[j]), c(y1[i], y1[i]) + ii,
              col = line.color, lty = line.type
              )
      for (jj in seq(0, colFreqs[j], by = square.side))
        lines(c(x1[j], x1[j]) + jj, c(y1[i], y2[i]),
              col = line.color, lty = line.type
              )
        
      ## OPTIONALLY, WRITE CELL FREQUENCIES

      if (values %in% c("cells", "both"))
          text(xmid[j], ymid[i],
               if (frequencies == "relative")
                 round((if (type == "sieve") x[i, j] else ex[i, j]) / n, 2)
               else
                 round((if (type == "sieve") x[i, j] else ex[i, j]), 1),
               font = 2, ...
               )

      ## BORDER

      rect(x1[j], y1[i], x2[j], y2[i], ...)
    }
}




"ternaryplot" <-
function (x,
          scale = 1,
          dimnames = NULL,
          dimnames.position = c("corner", "edge", "none"),
          dimnames.color = "black",
          id = NULL,
          id.color = "black",
          coordinates = FALSE,
          grid = TRUE,
          grid.color = "gray",
          labels = c("inside", "outside", "none"),
          labels.color = "darkgray",
          border = "black",
          bg = "white",
          pch = 19,
          cex = 1,
          prop.size = FALSE,
          col = "red",
          main = "ternary plot",
          ...)
{
  ## parameter handling
  labels <- match.arg(labels)
  if (grid == TRUE) grid <- "dotted"

  if (coordinates)
    id <- paste("(",round(x[,1] * scale, 1),",",
                    round(x[,2] * scale, 1),",",
                    round(x[,3] * scale, 1),")", sep="")

  dimnames.position <- match.arg(dimnames.position)
  if(is.null(dimnames) && dimnames.position != "none")
    dimnames <- colnames(x)

  if(is.logical(prop.size) && prop.size) prop.size <- 3
  
  ## some error handling
  if(ncol(x) != 3)
    stop("Need a matrix with 3 columns")
  if(any(x) < 0) stop("X must be non-negative")
  s <- rowSums(x)
  if(any(s <= 0)) stop("each row of X must have a positive sum")

  ## rescaling
#  if(max(abs(s - 1)) > 1e-6) {
#    warning("row(s) of X will be rescaled")
    x <- x / s
#  }
  
  ## prepare plot
  top <- sqrt(3) / 2
  par(plt = c(0.06, 0.94, 0.15, 0.87))
  plot.new()
  xlim <- c(-0.03, 1.03)
  ylim <- c(0, top)
  par(usr = c(xlim, ylim),
      oma = c(0, 0, 1, 0)
      )
  plot.window(xlim = xlim, ylim = ylim, asp = 1)
  eps <- 0.01

  ## coordinates of point P(a,b,c): xp = b + c/2, yp = c * sqrt(3)/2

  ## triangle
  polygon(c(0, 0.5, 1), c(0, top, 0), col = bg, xpd = NA, border = border, ...)

  ## title, labeling
  title(main, outer = TRUE, line = -1)
  if (dimnames.position == "corner") {
    axis(1, at = c(-0.03, 1.03), labels = dimnames[1:2], tick = FALSE, font = 2)
    axis(3, at = 0.5, labels = dimnames[3], tick = FALSE, font = 2)
  }
  if (dimnames.position == "edge") {
    shift <- eps * if (labels == "outside") 8 else 0
    text (0.25 - 2 * eps - shift, 0.5 * top + shift, dimnames[2], srt = 60, col = dimnames.color)
    text (0.75 + 3 * eps + shift, 0.5 * top + shift, dimnames[1], srt = -60, col = dimnames.color)
    text (0.5, 0, dimnames[3], pos = 1, offset = 0.5 + 30 * shift, xpd = NA, col = dimnames.color)
  }

  ## grid
  if (is.character(grid))
    for (i in 1:4 * 0.2) {
      ## a - axis
      lines (c(1 - i , (1 - i) / 2), c(0, 1 - i) * top, lty = grid, col = grid.color)
      ## b - axis
      lines (c(1 - i , 1 - i + i / 2), c(0, i) * top, lty = grid, col = grid.color)
      ## c - axis
      lines (c(i/2, 1 - i + i/2), c(i, i) * top, lty = grid, col = grid.color)

      ## grid labels
      if (labels == "inside") {
        text ((1 - i) * 3 / 4 - eps, (1 - i) / 2 * top, i * scale,
              col = labels.color, srt = 120)
        text (1 - i + i / 4 + eps, i / 2 * top - eps, (1 - i) * scale,
              col = labels.color, srt = -120)
        text (0.5, i * top + eps, i * scale, col = labels.color)
      } 
      if (labels == "outside") {
        text ((1 - i) / 2 - 6 * eps, (1 - i) * top, (1 - i) * scale, col = labels.color)
        text (1 - (1 - i) / 2 + 3 * eps, (1 - i) * top + 5 * eps, i * scale,
              srt = -120, col = labels.color)
        text (i + eps, 0, (1 - i) * scale, pos = 1, offset = 1.5,
              srt = 120, xpd = NA, col = labels.color)
      }
    }
  

  ## plot points
  xp <- x[,2] + x[,3] / 2
  yp <- x[,3] * top
  points(xp, yp, pch = pch, col = col,
         cex = if(prop.size) prop.size * (s / max(s)) else cex, ...)

  ## plot 
  if (!is.null(id))
    text (xp, yp, as.character(id), pos = 1, offset = 0.5 * cex, col = id.color)
}


