
boxplot.n  <- function( ..., top=F, shrink=1.0, textcolor=NULL )
  {
    box <- match.call()           # get call
    box$top  <- box$shrink  <- box$textcolor  <- NULL
    box[[1]]  <- as.name("boxplot")
    box <- eval(box, parent.frame())

    if(top)
      {
        where  <- par("usr")[4]
        adj  <- c(0.5,1)
      }
    else
      {
        where  <- par("usr")[3]
        adj  <- c(0.5,0)
      }
    cex <- par("cex")
    par(cex=shrink*cex)
    text( x=1:length(box$n), y=where, labels=paste("n=",box$n,sep=""), adj=adj,
         col=textcolor)
    par(cex=cex)

    invisible(box)
  }
ci  <-  function(x,...) UseMethod("ci")

ci.summary.lm  <-  function(x,confidence=0.95,alpha=1-confidence) {
  est  <-  coef(x)[,1] ;
  ci.low  <- est + qt(alpha/2, x$df[2]) * coef(x)[,2] ;
  ci.high <- est - qt(alpha/2, x$df[2]) * coef(x)[,2] ;
  retval  <- cbind(Estimate=est,
                   "CI lower"=ci.low,
                   "CI upper"=ci.high,
                   "Std. Error"= coef(x)[,2],
                   "p-value" = coef(x)[,4])
  rownames(retval)  <-  rownames(coef(x))
  retval
}

ci.lm  <-  function(x,...)
{
  x  <-  summary(x)
  return(ci.summary.lm(x))
}

concat  <-  function(..., names=NULL)
  {
    tmp  <-  list(...)
    if(is.null(names)) names  <- names(tmp)
    if(is.null(names)) names  <- sapply( as.list(match.call()), deparse)[-1]

    if( any(
            sapply(tmp, is.matrix)
            |
            sapply(tmp, is.data.frame) ) )
      { 
        len  <-  sapply(tmp, function(x) c(dim(x),1)[1] )
        len[is.null(len)]  <-  1
        data <-  rbind( ... )
      }
    else
      {
        len  <- sapply(tmp,length)
        data  <-  unlist(tmp)
        
      }

    namelist  <- factor(rep(names, len), levels=names)
        
    return( data.frame( data, source=namelist) )
  }

plotCI <- function (x, y = NULL,
                    uiw, liw = uiw,   # bar widths  -OR-
                    ui, li, # bar ends
                    err='y', # bar direction, 'y' or 'x'
                    col=par("col"),
                    ylim=NULL,
                    xlim=NULL,
                    barcol=col,
                    sfrac = 0.01,
                    gap=1,
                    lwd=par("lwd"),
                    lty=par("lty"),
                    labels=FALSE,
                    add=FALSE,
                    xlab,
                    ylab,
                    ...
                    )
{
  if (is.list(x)) { 
    y <- x$y 
    x <- x$x 
  }

  if(missing(xlab))
    xlab <- deparse(substitute(x))
  
  if(missing(ylab))
    {
      if(is.null(y))
        {
          xlab  <- ""
          ylab <- deparse(substitute(x))
        }
      else
        ylab <- deparse(substitute(y))
    }

  if (is.null(y)) { 
    if (is.null(x)) 
      stop("both x and y NULL") 
    y <- as.numeric(x) 
    x <- seq(along = x) 
  }

  
  if(err=="y")
    z  <- y
  else
    z  <- x
  
  if(missing(ui))
    ui <- z + uiw
  if(missing(li)) 
    li <- z - liw
   
  if(err=="y" & is.null(ylim))
    {
      ylim <- range(c(y, ui, li), na.rm=TRUE)
    }
  else if(err=="x" & is.null(xlim))
    {
      xlim <- range(c(x, ui, li), na.rm=TRUE)
    }

    
  if(!add)
    {
      if(missing(labels) || labels==F )
        plot(x, y, ylim = ylim, xlim=xlim, col=col,
             xlab=xlab, ylab=ylab, ...)
      else
        {
          plot(x, y, ylim = ylim, xlim=xlim, col=col, type="n",
               xlab=xlab, ylab=ylab,  ...)
          text(x, y, label=labels, col=col )
        }
    }

 
  if(err=="y")
    {
      if(gap!=FALSE)
        gap <- strheight("O") * gap
      smidge <- par("fin")[1] * sfrac

      # draw upper bar
      if(!is.null(li))
          arrows(x , li, x, pmax(y-gap,li), col=barcol, lwd=lwd,
                 lty=lty, angle=90, length=smidge, code=1)
      # draw lower bar
      if(!is.null(ui))
          arrows(x , ui, x, pmin(y+gap,ui), col=barcol,
                 lwd=lwd, lty=lty, angle=90, length=smidge, code=1)
    }
  else
    {
      if(gap!=FALSE)
        gap <- strwidth("O") * gap
      smidge <- par("fin")[2] * sfrac

      # draw left bar
      if(li!=NULL)
        arrows(li, y, pmax(x-gap,li), y, col=col, lwd=lwd, lty=slty,
               angle=90, length=smidge, code=1)
      if(ui!=NULL)
        arrows(ui, y, pmin(x+gap,ui), y, col=col, lwd=lwd, lty=slty,
               angle=90, length=smidge, code=1)
      
    }
      
    

invisible(list(x = x, y = y)) 
} 
# Plot means with confidence intervals for groups defined by right
# side of formulae
#
# example:
#

# data  <-  data.frame(y=rnorm(100), x=factor(rep(c("A","C","F","Z"),25)))

# means.plot( y ~ x, data=data, connect=F )


plotmeans  <- function (formula, data = NULL, subset, na.action,
                         bars=T, p=0.95,
                         xlab=names(mf)[2], ylab=names(mf)[1],
                         mean.labels=F, ci.label=F, n.label=T,
                         digits=getOption("digits"), col="black",
                         barwidth=1,
                         barcol="blue",
                         connect=T,
                         ccol=col,
                         legends=names(means),
                         ...)
{
    if (missing(formula) || (length(formula) != 3)) 
        stop("formula missing or incorrect")
    if (missing(na.action)) 
        na.action <- getOption("na.action")
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, parent.frame()))) 
        m$data <- as.data.frame(data)
    m$... <- m$bars <- m$barcol <- m$p   <- NULL
    m$xlab <- m$ylab  <-  NULL
    m$col  <- m$barwidth  <- NULL
    m$digits  <- m$mean.labels  <- m$ci.label  <- m$n.label <- NULL
    m$connect  <- m$ccol  <-  m$legends <- m$labels<- NULL
    m[[1]] <- as.name("model.frame")
    mf <- eval(m, parent.frame())
    response <- attr(attr(mf, "terms"), "response")
    means  <-  sapply(split(mf[[response]], mf[[-response]]), mean, na.rm=T)
    xlim  <-  c(0.5, length(means)+0.5)
    
    if(!bars)
      {
        plot( means, ..., col=col, xlim=xlim)
      }
    else
      {
    vars <- sapply(split(mf[[response]], mf[[-response]]), var, na.rm=T)
    ns   <- sapply( sapply(split(mf[[response]], mf[[-response]]), na.omit,
                           simplify=F), length )
    ci.width  <- qnorm( (1+p)/2 ) * sqrt(vars/(ns-1) )
#    ci.lower  <- means - qnorm( (1+p)/2 ) * sqrt(vars/(ns-1) )    
#    ci.upper  <- means + qnorm( (1+p)/2 ) * sqrt(vars/(ns-1) )
#    error.bar( x=1:length(means), y=means, lower=ci.lower, upper=ci.upper,
#              incr=F, xaxt="n" )

    if(length(mean.labels)==1 && mean.labels==T)
      mean.labels  <-  format( round(means, digits=digits ))
    else if (mean.labels==F)
      mean.lable  <- NULL

    plotCI(x=1:length(means), y=means, uiw=ci.width, xaxt="n",
           xlab=xlab, ylab=ylab, labels=mean.labels, col=col, xlim=xlim,
           lwd=barwidth, barcol=barcol, ... )
    axis(1, at = 1:length(means), labels = legends)
    
    if(ci.label)
      {
        ci.lower <- means-ci.width
        ci.upper <- means+ci.width 
        labels.lower <- paste( " \n", format(round(ci.lower, digits=digits)),
                              sep="")
        labels.upper <- paste( format(round(ci.upper, digits=digits)), "\n ",
                              sep="")

        text(x=1:length(means),y=ci.lower, labels=labels.lower, col=col)
        text(x=1:length(means),y=ci.upper, labels=labels.upper, col=col)
      }
    
  }
    
    
    if(n.label)
      text(x=1:length(means),y=par("usr")[3],
           labels=paste("n=",ns,"\n",sep=""))
    
    if(connect!=F)
      {
        if(is.list(connect))
          {
            if(length(ccol)==1)
              ccol  <-  rep(ccol, length(connect) )
            
            for(which in 1:length(connect))
              lines(x=connect[[which]],y=means[connect[[which]]],col=ccol[which])
          }
        else  
          lines(means, ..., col=ccol)
      }
    

    
}

