.packageName <- "Hmisc"
## $Id: AFirst.lib.s 225 2005-09-26 15:44:17Z dupontct $
under.unix <- !(version$os=='Microsoft Windows' ||
                version$os=='Win32' || version$os=='mingw32')

.R.   <- TRUE
.SV4. <- FALSE

.noGenenerics <- TRUE  # faster loading as new methods not used

if(!exists('existsFunction')) {
  existsFunction <- function(...) exists(..., mode='function')
}

.First.lib <- function(lib, pkg, ...)
{
  verbose <- .Options$Hverbose
  if(!length(verbose) || verbose)
    cat("Hmisc library by Frank E Harrell Jr\n\n",
        "Type library(help='Hmisc'), ?Overview, or ?Hmisc.Overview')\n",
        "to see overall documentation.\n\n",
        "NOTE:Hmisc no longer redefines [.factor to drop unused levels when\n",
        "subsetting.  To get the old behavior of Hmisc type dropUnusedLevels().\n",
        sep='')
  library.dynam("Hmisc", pkg, lib)
  invisible()
}
#Cs <- function(...)
#{
#  if(version$major > 4) as.character(sys.call()[-1]) else {
#	y <- ((sys.frame())[["..."]])[[1]][-1]
#	unlist(lapply(y, deparse))
#  }
#}  31Mar02

Cs <- function(...)
{
  if(.SV4. || .R.) as.character(sys.call())[-1]
  else {
    y <- ((sys.frame())[["..."]])[[1]][-1]
    unlist(lapply(y, deparse))
  }
}
## $Id: Misc.s 472 2007-04-03 14:56:56Z dupontct $
		
if(!exists("NROW", mode='function')) {
  NROW <- function(x)
    if (is.array(x) || is.data.frame(x)) nrow(x) else length(x)
}

if(!exists("NCOL", mode='function')) {
  NCOL <- function(x)
    if (is.array(x) && length(dim(x)) > 1 || is.data.frame(x)) ncol(x) else as.integer(1)
}

prn <- function(x, txt)
{
  calltext <- as.character(sys.call())[2]

  if(!missing(txt)) {
    if(nchar(txt) + nchar(calltext) +3 > .Options$width)
      calltext <- paste('\n\n  ',calltext,sep='')
    else
      txt <- paste(txt, '   ', sep='')
    cat('\n', txt, calltext, '\n\n', sep='') 
  }
  else cat('\n',calltext,'\n\n',sep='')
  invisible(print(x))
}

format.sep <- function(x, digits, ...)
{
  y <- character(length(x))
  for(i in 1:length(x))
    y[i] <- if(missing(digits)) format(x[i], ...)
            else format(x[i],digits=digits, ...)  ## 17Apr02

  names(y) <- names(x)  ## 17Apr02
  y
}

nomiss <- function(x)
{
  if(is.data.frame(x)) na.exclude(x)
  else if(is.matrix(x))
    x[!is.na(x %*% rep(1,ncol(x))),]
  else x[!is.na(x)]
}

fillin <- function(v, p)
{
  v.f <- ifelse(is.na(v),p,v)
  if(length(p)==1)
    label(v.f) <- paste(label(v),"with",sum(is.na(v)),
                        "NAs replaced with",format(p))
  else
    label(v.f) <- paste(label(v),"with",sum(is.na(v)),"NAs replaced")
  v.f
}

spearman <- function(x, y)
{
  x <- as.numeric(x)
  y <- as.numeric(y)  ## 17Jul97
  
  notna <- !is.na(x+y)	##exclude NAs
  if(sum(notna) < 3)
    c(rho=NA)
  else
    c(rho=cor(rank(x[notna]), rank(y[notna])))
}

plotCorrPrecision <- function(rho=c(0,0.5), n=seq(10,400,length=100),
                              conf.int=0.95)
{
  ## Thanks to Xin Wang for computations
  curves <- vector('list', length(rho))
  names(curves) <- paste('r',format(rho),sep='=')
  zcrit <- qnorm(1-(1-conf.int)/2)
  for(i in 1:length(rho)) {
    r <- rho[i]
    z <- .5*log((1+r)/(1-r))
    lo <- z - zcrit/sqrt(n-3)
    hi <- z + zcrit/sqrt(n-3)
    rlo <- (exp(2*lo)-1)/(exp(2*lo)+1)
    rhi <- (exp(2*hi)-1)/(exp(2*hi)+1)
    precision <- pmax(rhi-r, r-rlo)
    curves[[i]] <- list(N=n, Precision=precision)
  }
  labcurve(curves, pl=TRUE, xrestrict=quantile(n,c(.25,1)), offset=.025)
  invisible()
}

trap.rule <- function(x,y) sum(diff(x)*(y[-1]+y[-length(y)]))/2

uncbind <- function(x, prefix="", suffix="")
{
  nn <- dimnames(x)[[2]]
  warning("You are using uncbind.  This is a really bad idea. It will if you had any variables in the global environment named ", paste(prefix, nn, suffix, sep=""), " they are now over writen.\n\nYou have been warned.", immediate. = TRUE, )
  for(i in 1:ncol(x))
    if(.R.) {
      assign(paste(prefix,nn[i],suffix,sep=""), x[,i], pos=1)
    } else {
      assign(paste(prefix,nn[i],suffix,sep=""), x[,i], where=1)
    }
  invisible()
}

## Function to pick off ordinates of a step-function at user-chosen abscissas

stepfun.eval <- function(x, y, xout, type=c("left","right"))
{
  s <- !is.na(x+y)
  type <- match.arg(type)
  approx(x[s], y[s], xout=xout, method="constant", f=if(type=="left")0 else 1)$y
}

km.quick <- function(S, times, q)
{
  if(.R. && !existsFunction('survfit.km'))
    survfit.km <- getFromNamespace('survfit.km','survival')

  S <- S[!is.na(S),]
  n <- nrow(S)
  stratvar <- factor(rep(1,nrow(S)))
  f <- survfit.km(stratvar, S, se.fit=FALSE, conf.type='none')
  tt <- c(0, f$time)
  ss <- c(1, f$surv)
  if(missing(times))
    min(tt[ss <= q])
  else
    approx(tt, ss, xout=times, method='constant', f=0)$y
}

oPar <- function()
{
  ## Saves existing state of par() and makes changes suitable
  ## for restoring at the end of a high-level graphics functions
  oldpar <- par()
  oldpar$fin <- NULL
  oldpar$new <- FALSE
  invisible(oldpar)
}

setParNro <- function(pars)
{
  ## Sets non-read-only par parameters from the input list
  i <- names(pars) %nin%
    c('cin','cra','csi','cxy','din','xlog','ylog','gamma')
  invisible(par(pars[i]))
}

mgp.axis.labels <- function(value,type=c('xy','x','y','x and y'))
{
  type <- match.arg(type)
  if(missing(value)) {
    value <- .Options$mgp.axis.labels
    pr <- par(c('mgp','las'))
    mgp <- pr$mgp
    if(!length(value))
      value <- c(.7, .7)
    ##value <- c(mgp[2], if(pr$las==1) max(mgp[2],1.3) else mgp[2])
    return(switch(type, 
                  xy = value, 
                  x = c(mgp[1], value[1], mgp[3]),
                  y = c(mgp[1], value[2], mgp[3]),
                  'x and y' = list(x = c(mgp[1], value[1], mgp[3]),
                                   y = c(mgp[1], value[2], mgp[3]))))
  }
  
  if(value[1]=='default')
    value <- c(.7,.7)
  
  ##c(.6, if(par('las')==1) 1.3 else .6)
  options(mgp.axis.labels=value, TEMPORARY=FALSE)
  invisible()
}

mgp.axis <-
  function(side, at=NULL, ...,
           mgp=mgp.axis.labels(type=if(side==1 | side==3)'x' else 'y'),
           axistitle=NULL)
{
  ## Version of axis() that uses appropriate mgp from mgp.axis.labels and
  ## gets around bug in axis(2, ...) that causes it to assume las=1
  mfrow <- par('mfrow')          ## mfrow, tcl logic 28jan03
  nr <- mfrow[1]; nc <- mfrow[2]
  w <- list(side=side)
  w <- c(w, list(...))   ## 21apr03
  if(length(at))
    w$at <- at
  if(side==1 || side==3) {
    w$mgp <- mgp/nr
    if(.R.)
      w$tcl <- -0.4/nr
    if(side==1 && length(axistitle))
      title(xlab=axistitle, mgp=mgp/min(2.25,nr))
  } else {
    w$mgp <- mgp/nc
    if(.R.)
      w$tcl <- -0.4/nc
    las <- par('las')
    w$srt <- 90*(las==0)
    w$adj <- if(las==0)0.5
             else 1
    if(side==2 && length(axistitle))
      title(ylab=axistitle, mgp=mgp/min(2.25,nc))
  }
  do.call('axis', w)
  invisible()
}

trellis.strip.blank <- function()
{
  s.b <- trellis.par.get("strip.background")
  s.b$col <- 0
  trellis.par.set("strip.background", s.b)
  s.s <- trellis.par.get("strip.shingle")
  s.s$col <- 0
  trellis.par.set("strip.shingle", s.s)
  invisible()
}

lm.fit.qr.bare <- function(x, y, 
                           tolerance = NULL,
                           intercept=TRUE, xpxi=FALSE)
{
  if(!length(tolerance)) tolerance <- if(.R.)1e-7 else .Machine$single.eps

  if(intercept)
    x <- cbind(1,x)
  if(storage.mode(x) != "double")
    storage.mode(x) <- "double"
  if(storage.mode(y) != "double")
    storage.mode(y) <- "double"
  
  dx <- dim(x)
  dn <- dimnames(x)
  qty <- y
  n <- dx[1]
  n1 <- 1:n
  p <- dx[2]
  p1 <- 1:p
  dy <- c(n, 1)
  z <- if(!.R.)
         .Fortran("dqrls",
                  qr = x,
                  as.integer(dx),
                  pivot = as.integer(p1),
                  qraux = double(p),
                  y,
                  as.integer(dy),
                  coef = double(p),
                  residuals = y,
                  qt = qty,
                  tol = as.double(tolerance),
                  double(2 * p),
                  rank = as.integer(p))
       else
         .Fortran("dqrls", qr = x, n = as.integer(n), p = as.integer(p),
                  y = y, ny = as.integer(1),
                  tol = as.double(tolerance), coef = double(p),
                  residuals = y, effects = y, rank = integer(1),
                  pivot = as.integer(p1),
                  qraux = double(p), work = double(2 * p), PACKAGE = "base")

  coef <- z$coef
  if(length(dn[[2]]))
    names(coef) <- dn[[2]]
  
  res <- as.vector(z$residuals)
  sse <- sum(res^2)
  sst <- sum((y-mean(y))^2)

  res <- list(coefficients=coef, residuals=res, 
              rsquared=1-sse/sst, fitted.values=as.vector(y-res))
  if(xpxi) {
    if(.R.)
      xpxi <- chol2inv(z$qr)
    else {
      R <- (z$qr)[p1, , drop = FALSE]
      R[lower.tri(R)] <- 0
      rinv <- solve(R, diag(length(coef)))
      xpxi <- rinv %*% t(rinv)
    }
    res$xpxi <- xpxi
  }
  res
}

all.is.numeric <- function(x, what=c('test','vector'),
                           extras=c('.','NA'))
{
  what <- match.arg(what)
  old <- options(warn=-1)
  on.exit(options(old))
  ##.Options$warn <- -1  6Aug00
  x <- sub('[[:space:]]+$', '', x)
  x <- sub('^[[:space:]]+', '', x)
  xs <- x[x %nin% c('',extras)]
  isnum <- !any(is.na(as.numeric(xs)))
  if(what=='test')
    isnum
  else if(isnum)
    as.numeric(x)
  else x
}

Lag <- function(x, shift=1)
{
  ## Lags vector x shift observations, padding with NAs or blank strings
  ## on the left, preserving attributes of x

  # check to see if shift == 0
  if(shift == 0)
    return(x)

  # Create base vector use character to generate "" for mode "character"
  # Coerce base vector to be type of x
  xLen <- length(x)
  ret <- as.vector(character(xLen), mode=storage.mode(x))
  
  # set resp attributes equal to x attributes
  attrib <- attributes(x)

  if(!is.null(attrib$label))
    atr$label <- paste(attrib$label, 'lagged', shift, 'observations')

  if(xLen > shift){
    retrange = 1:shift
    ret[-retrange] <- x[1:(xLen - shift)]
  }
  
  attributes(ret) <- attrib
  return(ret)
}

xySortNoDupNoNA <- function(x, y)
{
  if(is.list(x)) {
    y <- x[[2]]; x <- x[[1]]
  }
  
  s <- !is.na(x + y)
  if(any(s)) {
    x <- x[s]; y <- y[s]
  }
  
  i <- order(x)
  x <- x[i]
  y <- y[i]
  i <- !duplicated(x)
  list(x=x[i], y=y[i])
}

## Lifted from rowsum in 4.5
rowsumFast <- function(x, group, reorder=FALSE)
{
  ## assumes x is a matrix
  ## by default, results are in order that unique group values
  ## encountered
  ## is fast and solves error that reorder= omitted from S+ 2000
  
  if(!is.numeric(x))
    stop("x must be numeric")
  
  dd <- dim(x)
  n <- dd[1]
  if(length(group) != n)
    stop("Incorrect length for 'group'")
  
  if(any(is.na(group)))
    stop("Missing values for 'group'")
  
  na.indicator <- max(1, x[!is.na(x)]) * n	#larger than any possible sum
  x[is.na(x)] <- na.indicator
  if(!is.numeric(group))
    group <- as.factor(group)
  
  storage.mode(x) <- "double"
  rowsumFun <- if(.R.) {
    'R_rowsum'
  } else {
    if(under.unix || version$major < 4 ||
       (version$major == 4 && version$minor < 7)) {
      "rowsum"
    } else {
      "S_rowsum"
    }
  }
  
  temp <- .C(rowsumFun, dd=as.integer(dd),
             as.double(na.indicator),
             x=x, as.double(group))

  new.n <- temp$dd[1]
  x <- temp$x[1:new.n,]
  if(reorder) {
    ugroup <- unique(group)
    dimnames(x) <- list(ugroup, dimnames(x)[[2]])
    x <- x[order(ugroup),  ]
  }
  ifelse(x == na.indicator, NA, x)
}

outerText <- function(string, y, setAside=string[1], side=4, space=1,
                      adj=1, cex=par('cex'))
{
  ## Use text() to put test strings in left or right margins
  ## Temporarily sets par(xpd=NA) if using R
  ## For adj=1 side=4, setAside is a character string used to determine
  ## the space to set aside for all strings
  ## space is the number of extra characters to leave to the left of
  ## the string(s) (adj=0) or to the right (adj=1)
  
  usr <- par('usr')
  xpd <- par('xpd')
  if(.R. && !is.na(xpd)) {
    on.exit(par(xpd=xpd))
    par(xpd=NA)
  }
  
  ie <- is.expression(string)  ## 1sep02
  if(ie)
    adj <- 0  ## adj=1 not work well for expressions in R
  
  if(side!=4)
    stop('only side=4 implemented')
  space <- substring('                    ',1,space)
  if(adj==0)
    text(usr[2], y,
         if(ie)
           string
         else
           paste(space,string,sep=''),
         adj=0)
  else {
    usr.space.needed <- strwidth(setAside, units='user', cex=cex)
    text(usr[2]+0.5*strwidth(space, units='user', cex=cex)+usr.space.needed,
         y, string, adj=1, cex=cex) # was usr[2]- 18jul02;added 0* 25jul02
    ## was 0*strwidth(space,...) 31jan03
  }
  invisible()
}

if(FALSE) {
  expandUsrCoord <- function()
  {
    ## Expands usr coordinates of current plot to entire figure region
    ## so that out of range plots may be plotted
    pr <- par()
    usr <- pr$usr
    p <- pr$plt
    invisible(pr)
  }
}

if(!.R.)
  strwidth <- function(string, units=c('user','figure','inches'),
                       cex=pr$cex)
{
  ## Computes width of a character string in user units or inches
  ## Approximates R strwidth function for S-Plus
  units <- match.arg(units)
  if(units=='figure') stop('units="figure" not yet implemented')
  n <- nchar(string)
  pr <- par()
  usr <- pr$usr
  cin <- pr$cin[1]
  n * cin * cex / ifelse(units=='inches',1,pr$uin[1])
}

if(!.R.)
  strheight <- function(string, units=c('user','figure','inches'),
                        cex=pr$cex)
{
  ## Computes height of a character string in user units or inches
  ## Approximates R strheight function for S-Plus
  units <- match.arg(units)
  if(units=='figure') stop('units="figure" not yet implemented')
  pr <- par()
  usr <- pr$usr
  cin <- pr$cin[2]
  cin * cex / ifelse(units=='inches',1,pr$uin[2])
}

## Author: Patrick Connolly <P.Connolly@hortresearch.co.nz>
## HortResearch
## Mt Albert
## Auckland, New Zealand

if(.R.) print.char.matrix <-
  function (x, file = "",
            col.name.align = "cen", col.txt.align = "right", 
            cell.align = "cen", hsep = "|", vsep = "-", csep = "+",
            row.names = TRUE, col.names = FALSE,
            append = FALSE, top.border = TRUE, left.border = TRUE, ...) 
{
### To print a data frame or matrix to a text file or screen
###   and having names line up with stacked cells
###
### First, add row names as first column (might be removed later)
  
  ndimn <- names(dimnames(x))  ## FEH
  rownames <- dimnames(x)[[1]]
  x <- cbind(rownames, x)
  names(dimnames(x)) <- ndimn  ## FEH
  cnam <- dimnames(x)[[2]]     ## FEH
  if(length(ndimn))
    cnam[1] <- ndimn[1]  ## FEH
  ##dimnames(x)[[1]] <- seq(nrow(x))  25Mar02 for R  FEH
  dimnames(x) <- list(as.character(seq(nrow(x))), cnam)
  names(dimnames(x)) <- ndimn  ## 26Mar02 FEH
###  Set up some padding functions:
###
  pad.left <- function(z, pads)
  {
    ## Pads spaces to left of text
    padding <- paste(rep(" ", pads), collapse = "")
    paste(padding, z, sep = "")
  }
  
  pad.mid <- function(z, pads)
  {
    ## Centres text in available space
    padding.right <- paste(rep(" ", pads%/%2), collapse = "")
    padding.left <- paste(rep(" ", pads - pads%/%2), collapse = "")
    paste(padding.left, z, padding.right, sep = "")
  }
  
  pad.right <- function(z, pads) {
    ## Pads spaces to right of text
    padding <- paste(rep(" ", pads), collapse = "")
    paste(z, padding, sep = "")
  }
  
  ##  (Padding happens on the opposite side to alignment)
  pad.types <- c("left", "mid", "right")
  names(pad.types) <- c("right", "cen", "left")
  pad.name <- pad.types[col.name.align]
  pad.txt <- pad.types[col.txt.align]
  pad.cell <- pad.types[cell.align]
  
  ## Padding character columns
  ##    Need columns with uniform number of characters
  pad.char.col.right <- function(y)
  {
    ## For aligning text to LHS of column
    col.width <- nchar(y)
    biggest <- max(col.width)
    smallest <- min(col.width)
    padding <- biggest - col.width
    out <- NULL
    for (i in seq(y))
      out[i] <- pad.right(y[i], pads = padding[i])
    out
  }
  
  pad.char.col.left <- function(y)
  {
    ## For aligning text to RHS of column
    col.width <- nchar(y)
    biggest <- max(col.width)
    smallest <- min(col.width)
    padding <- biggest - col.width
    out <- NULL
    for (i in seq(y))
      out[i] <- pad.left(y[i], pads = padding[i])
    out
  }
  
  pad.char.col.mid <- function(y) {
    ## For aligning text to centre of column
    col.width <- nchar(y)
    biggest <- max(col.width)
    smallest <- min(col.width)
    padding <- biggest - col.width
    out <- NULL
    for (i in seq(y))
      out[i] <- pad.mid(y[i], pads = padding[i])
    out
  }
  
  ## which functions to use this time.
  pad.name.fn <- get(paste("pad.", pad.name, sep = ""))
  pad.txt.fn <- get(paste("pad.char.col.", pad.txt, sep = ""))
  pad.cell.fn <- get(paste("pad.", pad.cell, sep = ""))
  
  ## Remove troublesome factors
  x <- as.data.frame(x)
  fac.col <- names(x)[sapply(x, is.factor)]
  for (i in fac.col)
    x[, i] <- I(as.character(x[, i]))
  ## ARE ANY LINE BREAKS IN ANY COLUMNS?
  break.list <- list()
  for (i in seq(nrow(x))) {
    x.i <- unlist(x[i, ])
    rows.i <- sapply(strsplit(unlist(x[i, ]), "\n"), length)
    rows.i[rows.i < 1] <- 1
    break.list[[i]] <- rows.i
  }
  break.row <- sapply(break.list, function(x) any(x > 1))
  names(break.row) <- seq(nrow(x))
  xx <- x
  if (any(break.row)) {
    ## add in extra row/s
    xx <- NULL
    reprow <- lapply(break.list, unique)
    for (k in seq(nrow(x))) {
      x.k <- unlist(x[k, ])
      x.k[x.k == ""] <- " "
      if (break.row[k]) {
        l.k <- strsplit(x.k, "\n")
        add.blanks <- max(break.list[[k]]) - break.list[[k]]
        names(l.k) <- names(add.blanks) <- seq(length(l.k))
        if (any(add.blanks > 0)) {
          for (kk in names(add.blanks[add.blanks > 0]))
            l.k[[kk]] <- c(l.k[[kk]], rep(" ", add.blanks[kk]))
        }
        l.k.df <- as.data.frame(l.k)
        names(l.k.df) <- names(x)
        xx <- rbind(xx, as.matrix(l.k.df))
      }
      else xx <- rbind(xx, x.k)
    }
    row.names(xx) <- paste(rep(row.names(x), sapply(reprow, 
                                                    max)),
                           unlist(reprow), sep = ".")
    
    ## Make an index for the rows to be printed
    rn <- row.names(xx)
    rnb <- strsplit(rn, "\\.")
    rpref <- as.numeric(factor(sapply(rnb, function(z) z[1])))
    ## was codes( ) 10oct03
  }
  else
    rpref <- seq(nrow(x))
  x <- as.data.frame(xx)
  
  ## Character columns need different treatment from numeric columns
  char.cols <- sapply(x, is.character)
  if (any(char.cols)) 
    x[char.cols] <- sapply(x[char.cols], pad.txt.fn)
  
  ## Change numeric columns into character
  if (any(!char.cols)) 
    x[!char.cols] <- sapply(x[!char.cols], format)
  
  ## now all character columns each of which is uniform element width
  ##
  ## Lining up names with their columns
  ## Sometimes the names of columns are wider than the columns they name, 
  ##  sometimes vice versa.

  names.width <- nchar(names(x))
  if (!col.names) 
    names.width <- rep(0, length(names.width))
  cell.width <- sapply(x, function(y) max(nchar(as.character(y))))

  ## (the width of the characters in the cells as distinct
  ##  from their names)  
  name.pads <- cell.width - names.width
  cell.pads <- -name.pads
  name.pads[name.pads < 0] <- 0
  cell.pads[cell.pads < 0] <- 0
  pad.names <- name.pads > 0
  pad.cells <- cell.pads > 0
  
  ## Pad out the column names if necessary:
  if (any(pad.names)) {
    stretch.names <- names(x)[pad.names]
    for (i in stretch.names) {
      names(x)[names(x) == i] <- pad.name.fn(i, name.pads[i])
    }
  }
  
  ## likewise for the cells and columns
  if (any(pad.cells)) {
    stretch.cells <- names(x)[pad.cells]
    for (j in stretch.cells) x[, j] <- pad.cell.fn(x[, j], 
                                                   cell.pads[j])
  }
  
  ## Remove row names if not required
  if (!row.names) 
    x <- x[-1]
  ## Put the column names on top of matrix
  if (col.names) 
    mat2 <- rbind(names(x), as.matrix(x))
  else
    mat2 <- as.matrix(x)
  
  mat.names.width <- nchar(mat2[1, ])
  ## character string to separate rows
  space.h <- ""
  for (k in seq(along=mat.names.width)) {  ## added along= FEH 26Mar02
    space.h <- c(space.h, rep(vsep, mat.names.width[k]), csep)
  }
  
  line.sep <- paste(c(ifelse(left.border, csep, ""), space.h), 
                    collapse = "")
  if (col.names) 
    rpref <- c(0, rpref, 0)
  else
    rpref <- c(rpref, 0)
  
  ## print to screen or file
  if (top.border) {
    write(line.sep, file = file, append = append)
    append <- TRUE
  }
  for (i in 1:nrow(mat2)) {
    if (left.border) 
      write(paste(paste(c("", mat2[i, ]), collapse = hsep), 
                  hsep, sep = ""), file = file, append = append)
    else
      write(paste(paste(mat2[i, ], collapse = hsep), hsep, 
                  sep = ""), file = file, append = append)
    append <- TRUE

    ## print separator if row prefix is not same as next one
    if (rpref[i] != rpref[i + 1]) 
      write(line.sep, file = file, append = TRUE)
  }
}

unPaste <- if(.R.) function(str, sep='/', extended=FALSE)
{
  w <- strsplit(str, sep, extended=extended)
  w <- matrix(unlist(w), ncol=length(str))
  nr <- nrow(w)
  ans <- vector('list', nr)
  for(j in 1:nr)
    ans[[j]] <- w[j,]
  ans
} else function(...) unpaste(...)

get2rowHeads <- if(.R.) function(str)
{
  w <- strsplit(str, '\n')
  ## strsplit returns character(0) when element=""  23may03
  list(sapply(w, function(x)if(length(x))    x[[1]] else ''),
       sapply(w, function(x)if(length(x) > 1)x[[2]] else ''))
} else function(str)
{
  ## make unpaste work when field does not contain \n by adding \n at end
  backn.loc <- regexpr('\n',str)
  if(all(backn.loc < 0)) return(list(str, rep('',length(str))))
  str <- ifelse(backn.loc > 0, str, paste(str,'\n',sep=''))
  unpaste(str, '\n')
}

if(!.R.) {
  subset <- function (x, ...) UseMethod("subset")
  subset.default <- function (x, subset, ...) 
    x[subset & !is.na(subset)]

  subset.data.frame <- function (x, subset, select, ...) 
  {
    if (missing(subset)) 
      r <- TRUE
    else {
      e <- substitute(subset)
      r <- eval(e, x, if(.R.)parent.frame() else sys.parent())
      r <- r & !is.na(r)
    }
    
    if (missing(select)) 
      vars <- TRUE
    else {
      nl <- as.list(1:ncol(x))
      names(nl) <- names(x)
      vars <- eval(substitute(select), nl,
                   if(.R.)parent.frame()
                   else sys.parent())
    }
    x[r, vars, drop = FALSE]
  }
  NULL
}

## Note: can't say f[vector of names] <- list(...) to update args
## In R you have to put ALL arguments in list(...) so sometimes we set
## unneeded ones to NULL.  Ignore this assignment in S
if(!.R.) {
  'formals<-' <- function(f, value)
  {
    nv <- names(value)
    if(any(nv %nin% names(f)))
      stop(paste('function does not have arguments',
                 paste(nv[nv %nin% names(f)],collapse=' '),
                 'to update'))
    
    for(a in nv) {
      v <- value[[a]]
      if(length(v))
        f[[a]] <- v
    }
    
    f
  }
  NULL
}

## Two lists of functions, one for primitives for S+ or R (either Trellis
## or low-level), one for R grid
## Note: rect is only defined in R, not S+
ordGridFun <- function(grid)
{
  if(!grid)
    list(lines    = function(...) lines(...),
         points   = function(..., size=NULL)
                    {
                      if(length(size))
                        warning('size not implemented yet')
                      points(...)
                    },
         text     = function(...) text(...),
         segments = function(...) segments(...),
         arrows   = if(.R.)
                      function(..., open, size)
                        arrows(..., length=size*.8)
                    else
                      function(...) arrows(...),
         rect     = function(...) rect(...),
         polygon  = function(...) polygon(...),
         abline   = function(...) abline(...),
         unit     = function(x, units='native')
                    {
                      if(units!='native')
                        stop('units="native" is only units implemented outside of grid')
                      x
                    },
         axis     = function(...) axis(...))
  else {
    require('grid') || stop('grid package not available')
    list(lines = function(x, y, ...)
         {
           if(is.list(x)) {
             y <- x[[2]]; x <- x[[1]]
           }
           llines(if(is.unit(x))
                    convertX(x, 'native', valueOnly=TRUE)
                  else x,
                  if(is.unit(y))
                    convertY(y, 'native', valueOnly=TRUE)
                  else y,
                  ...)
         },

         points = function(x, y, ...)
         {
           if(is.list(x)) {
             y <- x[[2]]; x <- x[[1]]
           }
           lpoints(if(is.unit(x))
                     convertX(x, 'native', valueOnly=TRUE)
                   else x,
                   if(is.unit(y))
                   convertY(y, 'native', valueOnly=TRUE)
                   else y,
                   ...)
         },

         text = function(x, y, ...)
         {
           if(is.list(x)) {
             y <- x[[2]]; x <- x[[1]]
           }
           ltext(if(is.unit(x))
                   convertX(x, 'native', valueOnly=TRUE)
                 else x,
                 if(is.unit(y))
                   convertY(y, 'native', valueOnly=TRUE)
                 else y,
                 ...)
         },

         segments = function(x0, y0, x1, y1, ...)
         {
           grid.segments(x0, y0, x1, y1, default.units='native',
                         gp=gpar(...))
         },
       
         arrows = function(...) larrows(...),

         rect = function(xleft, ybottom, xright, ytop, density, angle,
                         border, xpd, ...)
         {
           grid.rect(xleft, ybottom, width=xright-xleft,
                     height=ytop-ybottom, just='left',
                     default.units='native', gp=gpar(...))
         },
         polygon = function(x, y, col=par('col'), ...)
         grid.polygon(x, y, default.units='native', gp=gpar(fill=col,...)),
         abline=function(...) panel.abline(...),
         unit = function(x, units='native', ...) unit(x, units=units, ...),
       
         axis = function(side=1, at=NULL, labels, ticks=TRUE,
                         distn, line, pos, outer, ...)
         {
           if(!length(at))stop('not implemented for at= unspecified')
           if(side > 2) stop('not implemented for side=3 or 4')
           if(side==1) grid.xaxis(at=at, label=labels, ticks=ticks, gp=gpar(...))
           if(side==2) grid.yaxis(at=at, label=labels, ticks=ticks, gp=gpar(...))
         })
  }
}

parGrid <- function(grid=FALSE)
{
  pr <- par()
  cin <- pr$cin
  cex <- pr$cex
  lwd <- pr$lwd
  if(grid) {
    require('grid') || stop('grid package not available')
    ## cvp <- current.viewport()
    ## usr <- c(cvp$xscale, cvp$yscale)
    usr <- c(convertX(unit(0:1, "npc"), "native", valueOnly=TRUE),
             convertY(unit(0:1, "npc"), "native", valueOnly=TRUE))

    pin <- 
      c(convertWidth(unit(1, "npc"), "inches", valueOnly=TRUE),
        convertHeight(unit(1, "npc"), "inches", valueOnly=TRUE))

    uin <- 
      c(convertWidth(unit(1, "native"), "inches", valueOnly=TRUE),
        convertHeight(unit(1, "native"), "inches", valueOnly=TRUE))
    
  }
  else {
    usr <- pr$usr
    pin <- pr$pin
    uin <- c(pin[1]/(usr[2]-usr[1]), pin[2]/(usr[4]-usr[3]))
    ## 22Mar01 - R does not have par(uin)
  }
  list(usr=usr, pin=pin, uin=uin, cin=cin, cex=cex, lwd=lwd)
}

## Replaces R's xinch, yinch, extending them to grid
## Defines these for S-Plus
## These convert inches to data units
xInch <- function(x=1, warn.log=!grid, grid=FALSE)
{
  if (warn.log && par("xlog"))
    warning("x log scale:  xInch() is nonsense")
  pr <- parGrid(grid)
  x * diff(pr$usr[1:2])/pr$pin[1]
}

yInch <- function (y = 1, warn.log=!grid, grid=FALSE)
{
  if (warn.log && par("ylog"))
    warning("y log scale:  yInch is nonsense")
  pr <- parGrid(grid)
  y * diff(pr$usr[3:4])/pr$pin[2]
}

if(.R.) {
  na.include <- function(obj)
  {
    if(inherits(obj,'data.frame'))
      for(i in seq(along=obj))
        obj[[i]] <- na.include(obj[[i]])
    else {
      if(length(levels(obj)) && any(is.na(obj)))
        obj <- factor(obj,exclude=NULL)
    }
    obj
  }
  NULL
}

if(FALSE) {
  whichClosest <- function(x, w)
  {
    ## x: vector of reference values
    ## w: vector of values to find closest matches in x
    ## Returns: subscripts in x corresponding to w
    i <- order(x)
    x <- x[i]
    n <- length(x)
    br <- c(-1e30, x[-n]+diff(x)/2,1e30)
    m <- length(w)
    if(.R.)
      i[.C("bincode", as.double(w), m, as.double(br),
           length(br), code = integer(m), right = TRUE, 
           include = FALSE, NAOK = TRUE, DUP = FALSE, 
           PACKAGE = "base")$code]
    else
      if(.SV4.)
        i[.C("S_binning3", x=as.double(w), m, as.double(br),
             length(br), 0, 0, TRUE, TRUE)$x]
      else
        i[.C("S_binning2", x=as.double(w), m, as.double(br),
             length(br), 0, TRUE, TRUE)$x]
  }
  NULL
}

## Just as good, ties shuffled to end
## function(x, w) round(approx(x,1:length(x),xout=w,rule=2,ties='ordered')$y)
## Remove ties= for S-Plus.  Note: does not work when 2nd arg to
## approx is not uniformly spaced
## NO! ties='ordered' bombs in x not ordered
## Try
## approx(c(1,3,5,2,4,2,4),1:7,xout=c(1,3,5,2,4,2,4),rule=2,ties=function(x)x[1])
## NO: only works in general if both x and y are already ordered


## The following runs the same speed as the previous S version (in R anyway)
whichClosest <- function(x, w)
{
  ## x: vector of reference values
  ## w: vector of values for which to lookup closest matches in x
  ## Returns: subscripts in x corresponding to w
  ## Assumes no NAs in x or w
  if(.R.)
    .Fortran("wclosest",as.double(w),as.double(x),
             length(w),length(x),
             j=integer(length(w)),PACKAGE="Hmisc")$j
  else
    .Fortran("wclosest",as.double(w),as.double(x),length(w),length(x),
             j=integer(length(w)))$j
}

whichClosePW <- function(x, w, f=0.2) {
  lx <- length(x)
  lw <- length(w)
  if(.R.)
    .Fortran("wclosepw",as.double(w),as.double(x),
             as.double(runif(lw)),as.double(f),
             lw, lx, double(lx), j=integer(lw),
             PACKAGE="Hmisc")$j
  else
    .Fortran("wclosepw",as.double(w),as.double(x),
             as.double(runif(lw)),as.double(f),
             lw, lx, double(lx), j=integer(lw))$j
}              

if(FALSE) {
  sampWtdDist <- function(x, w)
  {
    ## x: vector of reference values
    ## w: vector of values to find closest matches in x
    ## Returns: subscripts in x corresponding to w

    ## 25% slower but simpler method:
    ## z <- abs(outer(w, x, "-"))
    ## s <- apply(z, 1, max)
    ## z <- (1 - sweep(z, 1, s, FUN='/')^3)^3
    ## sums <- apply(z, 1, sum)
    ## z <- sweep(z, 1, sums, FUN='/')

    lx <- length(x)
    lw <- length(w)
    z <- matrix(abs( rep( x , lw ) - rep( w, each = lx ) ),
                nrow=lw, ncol=lx, byrow=TRUE) ## Thanks: Chuck Berry
    ## s <- pmax( abs( w - min(x) ), abs( w - max(x) ) )  # to use max dist
    s <- rowSums(z)/lx/3   # use 1/3 mean dist for each row
    tricube <- function(u) (1 - pmin(u,1)^3)^3
    ## z <- (1 - (z/rep(s,length=lx*lw))^3)^3   # Thanks: Tim Hesterberg
    z <- tricube(z/s)   # Thanks: Tim Hesterberg
    sums <- rowSums(z)
    z <- z/sums 
    as.vector(rMultinom(z, 1))
  }
  NULL
}

approxExtrap <- function(x, y, xout, method='linear', n=50, rule=2,
                         f=0, ties='ordered', na.rm=FALSE)
{
  ## Linear interpolation using approx, with linear extrapolation
  ## beyond the data
  if(is.list(x)) {
    y <- x[[2]]; x <- x[[1]]
  }

  ## remove duplicates and order so can do linear extrapolation
  if(na.rm) {
    d <- !is.na(x+y)
    x <- x[d]; y <- y[d]
  }
  
  d <- !duplicated(x)
  x <- x[d]
  y <- y[d]
  d <- order(x)
  x <- x[d]
  y <- y[d]
  
  w <- if(.R.)
         approx(x, y, xout=xout, method=method, n=n,
                rule=2, f=f, ties=ties)$y
       else
         approx(x, y, xout=xout, method=method, n=n, rule=2, f=f)$y
  
  r <- range(x)
  d <- xout < r[1]
  if(any(is.na(d)))
    stop('NAs not allowed in xout')
  
  if(any(d))
    w[d] <- (y[2]-y[1])/(x[2]-x[1])*(xout[d]-x[1])+y[1]
  
  d <- xout > r[2]
  n <- length(y)
  if(any(d))
    w[d] <- (y[n]-y[n-1])/(x[n]-x[n-1])*(xout[d]-x[n-1])+y[n-1]
  
  list(x=xout, y=w)
}


inverseFunction <- function(x, y) {
  d <- diff(y)
  xd <- x[-1]
  dl <- c(NA, d[-length(d)])
  ic <- which(d>=0 & dl<0 | d>0 & dl<=0 | d<=0 & dl>0 | d<0 & dl>=0)
  nt <- length(ic)
  k <- nt + 1
  if(k==1) {
    h <- function(y, xx, yy, turns, what, coef)
      approx(yy, xx, xout=y, rule=2)$y
    formals(h) <- list(y=numeric(0), xx=x, yy=y, turns=numeric(0),
                       what=character(0), coef=numeric(0))
  return(h)
  }
  turns <- x[ic]
  turnse <- c(-Inf, turns, Inf)
  xrange <- yrange <- matrix(NA, nrow=k, ncol=2)
  for(j in 1:k) {
    l <- which(x >= turnse[j] & x <= turnse[j+1])
    xrange[j,] <- x[l[c(1,length(l))]]
    yrange[j,] <- y[l[c(1,length(l))]]
  }

  for(j in 1:length(ic)) {
    l <- (ic[j]-1):(ic[j]+1)
    turns[j] <- approxExtrap(d[l], xd[l], xout=0, na.rm=TRUE)$y
  }

  h <- function(y, xx, yy, turns, xrange, yrange, what, coef) {
    what <- match.arg(what)
    ## Find number of monotonic intervals containing a given y value
    ylo <- pmin(yrange[,1],yrange[,2])
    yhi <- pmax(yrange[,1],yrange[,2])
    n <- outer(y, ylo, function(a,b)a >= b) &
         outer(y, yhi, function(a,b)a <= b)
    ## Columns of n indicate whether or not y interval applies
    ni <- nrow(yrange)
    fi <- matrix(NA, nrow=length(y), ncol=ni)
    turnse <- c(-Inf, turns, Inf)
    for(i in 1:ni) {
      w <- n[,i]
      if(any(w)) {
        l <- xx >= turnse[i] & xx <= turnse[i+1]
        fi[w,i] <- approx(yy[l], xx[l], xout=y[w])$y
      }
    }
    noint <- !apply(n, 1, any)
    if(any(noint)) {
      ## Determine if y is closer to yy at extreme left or extreme right
      ## of an interval
      m <- length(yy)
      yl <- as.vector(yrange); xl <- as.vector(xrange)
      fi[noint,1] <- xl[whichClosest(yl, y[noint])]
    }
    if(what=='sample')
      apply(fi, 1, function(x) {
       z <- x[!is.na(x)]
       if(length(z)==1) z else if(length(z)==0) NA else sample(z, size=1)
       }) else fi
  }
  formals(h) <- list(y=numeric(0), xx=x, yy=y, turns=turns,
                     xrange=xrange, yrange=yrange,
                     what=c('all', 'sample'), coef=numeric(0))
  ## coef is there for compatibility with areg use
  h
}


if(!existsFunction('reorder.factor'))
  reorder.factor <- function(x, v, FUN = mean, ...)
    ordered(x, levels(x)[order(tapply(v, x, FUN, ...))])

Names2names <- function(x)
{
  if(is.list(x)) {
  }
  else {
    n <- names(attributes(x))
    if(any(n=='.Names'))
      names(attributes(x)) <- ifelse(n=='.Names','names',n)
  }
  x
}

if(!existsFunction('tempdir')) {
  tempdir <- function()
  {
    if(.R.) {
      if(under.unix)
        tmp <- sub("/[^/]*$","", tempfile())
      else
        tmp <- sub("\\[^\\]*$","", tempfile())
    }
    else {
      if(under.unix) {
        tmp <- getenv("S_TMPDIR")
        if(identical(tmp, "")) {
          warning("S_TMPDIR not set, using old Splus startup script?  Will use unsafe S_TMPDIR=/tmp.")
          tmp <- "/tmp"
        }
      }
      else
        tmp <- "/windows/temp" 
    }
    tmp
  }
}

##xedit <- function(file, header, title, delete.file=FALSE) {
## In R, use e.g. options(pager=xedit); page(x,'p')
##  sys(paste('xedit -title "', title, '" ', file, ' &',
##            sep=''))
##  invisible()
##}

if(FALSE) {
  gless <- function(x, ...)
  {
    ## Usage: gless(x) - uses print method for x, puts in window with
    ## gless using name of x as file name prefixed by ~, leaves window open
    nam <- substring(deparse(substitute(x)), 1, 40)
    file <- paste('/tmp/',nam,sep='~')  #tempfile('Rpage.')
    sink(file)
    ##  cat(nam,'\n' )
    ##  if(length(attr(x,'label')) && !inherits(x,'labelled'))
    ##    cat(attr(x,'label'),'\n')
    ##  cat('\n')
    print(x, ...)
    sink()
    sys(paste('gless --geometry=600x400 "',file,'" &',sep=''))
    ## gless does not have a title option
    invisible()
  }
  NULL
}

xless <-
  function(x, ..., title=substring(deparse(substitute(x)),1,40))
{
  ## Usage: xless(x) - uses print method for x, puts in persistent window with
  ## xless using name of x as title (unless title= is specified)
  if(under.unix) {
	file <- tempfile()
  	sink(file)
  	print(x, ...)
  	sink()
  	cmd <- paste('xless -title "',title,'" -geometry "90x40" "',
               file,'" &',sep='')
  	if(.R.)
    	system(cmd)
  	else
  		sys(cmd)
  } else page(x, method='print', title=title, ...)
invisible()
}

gView <- function(x, ...,
                  title=substring(deparse(substitute(x)),1,40),
                  nup=1, fancy=TRUE, fontsize=if(nup==1)9 else 8)
{
  ## Usage: gView(x) - uses print for x, converts to ps with enscript,
  ##        views with gv using name of x as title (unless time=specified)
  ##        nup = number of columns to print per page
  ##        fancy controls fancy headers when nup>1
  ##        fontsize default is 9 (8 if nup>1)
  file2 <- paste(tempdir(),title,sep='/')
  file <- tempfile()
  sink(file)
  print(x, ...)
  sink()
  cmd <- if(fancy) 'enscript -G'
         else 'enscript'
  
  cmd <- if(nup==1)
           paste(cmd, '-B -p')
         else
           paste(cmd, ' -',nup,' -r -j -p',sep='')
  
  font <- paste('Courier', fontsize, sep='')
  sys(paste(cmd, file2, '-f', font, '-t', title, '-b', title, file))
  sys(paste('gv', file2, '&'))
  invisible()
}

pasteFit <- function(x, sep=',', width=.Options$width)
{
  ## pastes as many elements of character vector x as will fit in a line
  ## of width 'width', starting new lines when needed
  ## result is the lines of pasted text
  m <- nchar(x)
  out <- character(0)
  cur <- ''
  n   <- 0
  for(i in 1:length(x)) {
    if(cur=='' | (m[i] + nchar(cur) <= width))
      cur <- paste(cur, x[i],
                   sep=if(cur=='')''
                       else sep)
    else {
      out <- c(out, cur)
      cur <- x[i]
    }
  }
  if(cur != '') out <- c(out, cur)
  out
}

## Determine if variable is a date, time, or date/time variable in R
## or S-Plus.  The following 2 functions are used by describe.vector
## timeUsed assumes is date/time combination variable and has no NAs
testDateTime <- function(x, what=c('either','both','timeVaries'))
{
  what <- match.arg(what)
  cl <- class(x)  # was oldClass 22jun03
  if(!length(cl))
    return(FALSE)

  dc <- if(.R.)
          c('Date', 'POSIXt','POSIXct','dates','times','chron')
        else
          c('timeDate','date','dates','times','chron')
  
  dtc <- if(.R.)
           c('POSIXt','POSIXct','chron')
         else
           c('timeDate','chron')
  
  switch(what,
         either = any(cl %in% dc),
         both   = any(cl %in% dtc),
         timeVaries = {
           if('chron' %in% cl || 'Date' %in% cl || !.R.) { 
             ## chron or S+ timeDate
             y <- as.numeric(x)
             length(unique(round(y - floor(y),13))) > 1
           }
           else if(.R.)
             length(unique(format(x,'%H%M%S'))) > 1
           else
             FALSE
         })
}

## Format date/time variable from either R or S+
## x = a numeric summary of the original variable (e.g., mean)
## at = attributes of original variable
formatDateTime <- function(x, at, roundDay=FALSE)
{
  cl <- at$class
  w <- if(any(cl %in% c('chron','dates','times'))){
         attributes(x) <- at
         fmt <- at$format
         if(roundDay) {
           if(length(fmt)==2 && is.character(fmt))
             format.dates(x, fmt[1])
           else
             format.dates(x)
         }
         else x
       } else if(.R.) {
         attributes(x) <- at
         if(roundDay && 'Date' %nin% at$class) 
           as.POSIXct(round(x, 'days'))
         else x
       } else
         timeDate(julian=if(roundDay)round(x)
                         else x)
  format(w)
}

## Note that expr may contain multiple expressions in { } but you
## cannot do assignments to objects this way
if(!.R.)
  evalq <- function(expr, envir, enclos)
             eval(substitute(expr), envir)

if(!.R.) {
  download.file <- function(url, destfile, quiet=FALSE, cacheOK=TRUE,
                            ...)
  {
    extra <- if (quiet) " --quiet"
             else ""
    if (!cacheOK)
      extra <- paste(extra, "--cache=off")
    sys(paste("wget", extra, url, "-O", destfile))
    invisible()
  }
  NULL
}

if(.R.) {
  getHdata <-
    function(file, what=c('data','contents','description','all'),
             where='http://biostat.mc.vanderbilt.edu/twiki/pub/Main/DataSets')
  {
    what <- match.arg(what)
    fn <- as.character(substitute(file))
    ads <-
      scan(paste(where,'Rcontents.txt',sep='/'),list(''),quiet=TRUE)[[1]]
    a <- unlist(strsplit(ads,'.sav'))
    if(missing(file))
      return(a)

    wds <- paste(substitute(file),'sav',sep='.')
    if(wds %nin% ads)
      stop(paste(wds,'is not on the web site.\nAvailable datasets:\n',
                 paste(a, collapse=' ')))
    if(what %in% c('contents','all')) {
      w <- paste('C',fn,'.html',sep='')
      browseURL(paste(where,w,sep='/'))
    }
    
    if(what %in% c('description','all')) {
      ades <- scan(paste(where,'Dcontents.txt',sep='/'),list(''),
                   quiet=TRUE)[[1]]
      i <- grep(paste(fn,'\\.',sep=''),ades)
      if(!length(i))
        warning(paste('No description file available for',fn))
      else {
        w <- ades[i[1]]
        browseURL(paste(where,w,sep='/'))
      }
    }
    
    if(what %nin% c('data','all'))
      return(invisible())
    
    f <- paste(where,wds,sep='/')
    tf <- tempfile()
    download.file(f, tf, mode='wb', quiet=TRUE)
    load(tf, .GlobalEnv)
    invisible()
  }
} else {
  getHdata <-
    function(file,
             where='http://biostat.mc.vanderbilt.edu/twiki/pub/Main/DataSets')
  {
    tf <- tempfile()
    download.file(paste(where,'Scontents.txt',sep='/'), tf, quiet=TRUE)
    ads <- scan(tf,list(''))[[1]]
    a <- sedit(ads,'.sdd','')
    if(missing(file))
      return(a)
    
    file <- as.character(substitute(file))
    wds <- paste(file,'sdd',sep='.')
    if(wds %nin% ads)
      stop(paste(wds,'is not on the web site.\nAvailable datasets:\n',
                 paste(a, collapse=' ')))

    f <- paste(where,wds,sep='/')
    tf <- tempfile()
    download.file(f, tf, quiet=TRUE)
    data.restore(tf)  # puts in search position 1
    if(.SV4.)
      assign(file, cleanup.import(get(file,where=1)), where=1)
    unlink(tf)
    invisible()
  }
}

hdquantile <- function(x, probs=seq(0, 1, 0.25), se=FALSE,
                       na.rm=FALSE, names=TRUE, weights=FALSE)
{
  if(na.rm) {
    na <- is.na(x)
    if(any(na))
      x <- x[!na]
  }
  
  x <- sort(x, na.last=TRUE)
  n <- length(x)
  if(n < 2)
    return(rep(NA, length(probs)))
  
  m  <- n + 1

  ps <- probs[probs > 0 & probs < 1]
  qs <- 1 - ps

  a <- outer((0:n)/n, ps,
             function(x,p,m) pbeta(x, p*m, (1-p)*m), m=m)
  w <- a[-1,] - a[-m,]

  r <- drop(x %*% w)
  rp <- range(probs)
  pp <- ps
  if(rp[1]==0) {
    r <- c(x[1], r); pp <- c(0,pp)
  }

  if(rp[2]==1) {
    r <- c(r, x[n]); pp <- c(pp,1)
  }
  
  r <- r[match(pp, probs)]

  if(names) names(r) <- format(probs)

if(weights)
  attr(r,'weights') <- structure(w, dimnames=list(NULL,format(ps)))

  if(!se)
    return(r)
  if(n < 3)
    stop('must have n >= 3 to get standard errors')

  l <- n - 1
  a <- outer((0:l)/l, ps,
             function(x,p,m) pbeta(x, p*m, (1-p)*m), m=m)
  w <- a[-1,] - a[-n,]

  storage.mode(x) <- 'double'
  storage.mode(w) <- 'double'

  nq <- length(ps)
  ## Get all n leave-out-one quantile estimates
  S <- matrix(.Fortran("jacklins", x, w, as.integer(n), as.integer(nq),
                       res=double(n*nq), PACKAGE='Hmisc')$res, ncol=nq)

  se <- l * sqrt(diag(var(S))/n)

  if(rp[1]==0)
    se <- c(NA, se)
  
  if(rp[2]==1)
    se <- c(se, NA)
  
  se <- se[match(pp,probs)]
  if(names)
    names(se) <- names(r)
  
  attr(r, 'se') <- se
  r
}

sepUnitsTrans <- function(x, 
                          conversion=c(day=1, month=365.25/12, year=365.25, week=7),
                          round=FALSE, digits=0)
{
  if(!any(is.present(x)))
    return(x)
  
  target <- names(conversion[conversion==1])
  if(!length(target))
    stop('must specify a target unit with conversion factor=1')
  
  lab <- attr(x,'label')
  x <- ifelse(is.present(x),casefold(as.character(x)),'')

  for(w in names(conversion)) {
    i <- grep(w, x)
    if(length(i)) x[i] <-
      as.character(as.numeric(gsub(paste(w,'s*',sep=''), '', x[i]))*
                   conversion[w])
  }

  i <- grep('[a-z]', x)
  if(any(i))
    warning(paste('variable contains units of measurement not in',
                  paste(names(conversion), collapse=','),':',
                  paste(unique(x[i]),collapse=' ')))
  
  x <- as.numeric(x)
  if(round)
    x <- round(x, digits)
  
  units(x) <- target
  if(length(lab))
    label(x) <- lab
  x
}

if(!.R.) dQuote <- function (x)
{
  if (length(x) == 0) 
    return(character())
  paste("\"", x, "\"", sep = "")
}

makeNames <- function(names, unique=FALSE, allow=NULL)
{
  ## Runs make.names with exceptions in vector allow
  ## By default, R 1.9 make.names is overridden to convert _ to . as
  ## with S-Plus and previous versions of R.  Specify allow='_' otherwise.
  if(!.R. & length(allow))
    stop('does not apply for S-Plus')
  n <- make.names(names, unique)
  if(!length(allow))
    n <- gsub('_', '.', n)
  n
}

Load <- function(object)
{
  nam <- deparse(substitute(object))
  path <- .Options$LoadPath
  if(length(path))
    path <- paste(path,'/',sep='')
  file <- paste(path, nam, '.rda', sep='')
  load(file, .GlobalEnv)
}

Save <- function(object, name=deparse(substitute(object)))
{
  path <- .Options$LoadPath
  if(length(path))
    path <- paste(path, '/', sep='')
  
  .FileName <- paste(path, name, '.rda', sep='')
  assign(name, object)
  eval(parse(text=paste('save(', name, ', file="',
                        .FileName, '", compress=TRUE)', sep='')))
}

getZip <- function(url, password=NULL) {
  ## Allows downloading and reading a .zip file containing one file
  ## File may be password protected.  Password will be requested unless given.
  ## Example: read.csv(getZip('http://biostat.mc.vanderbilt.edu/twiki/pub/Sandbox/WebHome/z.zip'))
  ## Password is 'foo'
  ## url may also be a local file
  ## Note: to make password-protected zip file z.zip, do zip -e z myfile
  if(toupper(substring(url, 1, 7)) == 'HTTP://') {
    f <- tempfile()
    download.file(url, f)
  } else f <- url
  cmd <- if(length(password))
    paste('unzip -p -P', password) else 'unzip -p'
  pipe(paste(cmd, f))
}

getLatestSource <- function(x=NULL, package='Hmisc',
                            recent=NULL, avail=FALSE,
                            type=c('svn','cvs')) {
  type <- match.arg(type)
  url <- switch(type,
                cvs=paste('http://biostat.mc.vanderbilt.edu/cgi-bin/cvsweb.cgi',
                  package, 'R/', sep='/'),
                svn=paste('http://biostat.mc.vanderbilt.edu/cgi-bin/viewvc.cgi',
                  package, 'trunk/R/', sep='/'))
  if(length(recent)) url <- paste(url, '?sortby=date#dirlist', sep='')
  
  w <- scan(url, what='',quiet=TRUE)
  i <- switch(type,
              cvs=grep('\\.s\\?rev=',w),
              svn=grep('\\.s\\?view=markup&amp;rev=', w))
  w <- w[i]
  
  files <- switch(type,
                  cvs=sub('href=\"\\(.*\\)\\?.*','\\1', w),
                  svn=sub('href=\".*/trunk/R/\\(.*\\)\\?.*','\\1', w))
  files <- sub('\\.s$','',files)
  ver <- switch(type,
                cvs=if(length(recent))
                sub('^.*rev=\\(.*\\);.*','\\1',w) else
                sub('\"$','',sub('^.*rev=','',w)),
                svn=if(length(recent))
                sub('^.*rev=\\(.*\\)&amp.*', '\\1', w) else
                sub('^.*rev=\\(.*\\)\"', '\\1', w))

  if(avail) return(data.frame(file=files, version=ver))

  if(length(recent)) x <- files[1:recent]
  if(length(x)==1 && x=='all') x <- files

  for(fun in x) {
    i <- which(files==fun)
    if(!length(i)) stop(paste('no file ', fun,' in ',package, sep=''))
    cat('Fetching', fun, 'version', ver[i],'\n')
    url <- switch(type,
                  cvs=paste('http://biostat.mc.vanderbilt.edu/cgi-bin/cvsweb.cgi/~checkout~/',package,'/R/',fun,'.s?rev=',ver[i],';content-type=text%2Fplain', sep=''),
                  svn=paste('http://biostat.mc.vanderbilt.edu/svn/R/',
                    package,'/trunk/R/', fun,'.s',sep=''))
    source(url)
  }
}
  
clowess <- function(x, y=NULL, iter=3, ...) {
  ## to get around bug in lowess with occasional wild values with iter>0
  r <- range(if(length(y)) y else x$y)
  f <- lowess(x, y, iter=iter, ...)
  if(iter != 0 && any(f$y < r[1] | f$y > r[2]))
    f <- lowess(x, y, iter=0)
  f
}

abs.error.pred <- function(fit, lp=NULL, y=NULL)
{
  if(!length(y))  y  <- fit$y
  if(!length(lp)) lp <- fit$fitted.values
  if(!length(lp)) lp <- fit$linear.predictors
  if(!(length(y) && length(lp)))
    stop('must specify lp and y or specify y=T in the fit')
  
  s <- is.na(y + lp)
  
  if(any(s)) {
    y  <- y[!s]
    lp <- lp[!s]
  }
  
  my    <- median(y)
  mlp   <- median(lp)
  meanr <- mean(  abs( lp - mlp))
  meant <- mean(  abs(  y - my ))
  meane <- mean(  abs( lp -  y ))
  medr  <- median(abs( lp - mlp))
  medt  <- median(abs(  y - my ))
  mede  <- median(abs( lp -  y ))

  differences <- cbind(c(meanr,meane,meant),
                       c(medr ,mede ,medt ) )

  dimnames(differences) <- list(c('|Yi hat - median(Y hat)|',
                                  '|Yi hat - Yi|',
                                  '|Yi - median(Y)|'),
                                c('Mean','Median'))
  
  ratios <- cbind(c(meanr/meant, meane/meant),
                  c( medr/ medt,  mede/ medt))
  dimnames(ratios) <- list(c('|Yi hat - median(Y hat)|/|Yi - median(Y)|',
                             '|Yi hat - Yi|/|Yi - median(Y)|'),
                           c('Mean','Median'))
  structure(list(differences=differences,ratios=ratios),class='abs.error.pred')
}

print.abs.error.pred <- function(x, ...)
{
  cat('\nMean/Median |Differences|\n\n')
  print(x$differences)
  cat('\n\nRatios of Mean/Median |Differences|\n\n')
  print(x$ratios)
  invisible()
}
# $Id: areg.s 472 2007-04-03 14:56:56Z dupontct $
areg <- function(x, y, xtype=NULL, ytype=NULL, nk=4,
                 B=0, na.rm=TRUE,
                 tolerance=NULL, crossval=NULL) {

  yname <- deparse(substitute(y))
  xname <- deparse(substitute(x))
  ism <- is.matrix(x)
  if(!ism) {
    x <- as.matrix(x)
    if(!length(colnames(x))) colnames(x) <- xname
  }
  if(na.rm) {
    omit <- is.na(x %*% rep(1,ncol(x))) | is.na(y)
    nmiss <- sum(omit)
    if(nmiss) {
      x <- x[!omit,,drop=FALSE]
      y <- y[!omit]
    }
  } else nmiss <- 0
    
  d <- dim(x)
  n <- d[1]; p <- d[2]
  xnam <- colnames(x)
  if(!length(xnam)) xnam <- paste('x',1:p,sep='')
  if(!length(ytype)) ytype <- 
    if(is.factor(y) || is.category(y) || is.character(y)) 'c' else
      if(nk==0 || (length(unique(y)) < 3)) 'l' else 's'
  if(nk==0 && ytype=='s') ytype <- 'l'

  if(!length(xtype)) xtype <- rep(if(nk==0)'l' else 's', p)
  xtype[nk==0 & xtype=='s'] <- 'l'
  names(xtype) <- xnam

  fcancor <- function(X, Y) {
    ## If canonical variate transformation of Y is descending in Y,
    ## negate all parameters
    f <- cancor(X, Y)
    f$r2 <- f$cor[1]^2
    n <- nrow(Y); if(!length(n)) n <- length(y)
    varconst <- sqrt(n-1)
    xcoef <- c(intercept = -sum(f$xcoef[, 1] * f$xcenter),
               f$xcoef[, 1]) * varconst
    ycoef <- c(intercept = -sum(f$ycoef[, 1] * f$ycenter),
               f$ycoef[, 1]) * varconst
    ty <- matxv(Y, ycoef)
    g <- lm.fit.qr.bare(Y,ty)
    if(g$coefficients[2] < 0) {
      xcoef <- -xcoef
      ycoef <- -ycoef
      ty    <- -ty
    }
    f$xcoef <- xcoef
    f$ycoef <- ycoef
    f$ty    <- ty
    f
  }

  need2getinv <- FALSE
  
  Y <- aregTran(y, ytype, nk, functions=TRUE)
  at <- attributes(Y)
  ytrans <- at$fun
  yinv   <- at$inversefun  ## NULL if type='s'; need coef
  yparms <- at$parms

  xdf <- ifelse(xtype=='l', 1, nk-1)
  j <- xtype=='c'
  if(any(j))
    xdf[j] <- apply(x[,j,drop=FALSE], 2,
                    function(z) length(unique(z)) - 1)
  names(xdf) <- xnam

  X <- matrix(NA, nrow=n, ncol=sum(xdf))
  xparms <- list()
  j <- 0
  xn <- character(0)
  for(i in 1:p) {
    w <- aregTran(x[,i], xtype[i], nk)
    xparms[[xnam[i]]] <- attr(w, 'parms')
    m <- ncol(w)
    xdf[i] <- m
    X[,(j+1):(j+m)] <- w
    j <- j + m
    xn <- c(xn, paste(xnam[i],1:m,sep=''))
  }
  ## See if rcpsline.eval could not get desired no. of knots due to ties
  if(ncol(X) > sum(xdf)) X <- X[,1:sum(xdf),drop=FALSE]

  covx <- covy <- r2opt <- r2boot <-
    madopt <- madboot <- medopt <- medboot <- NULL
  if(B > 0) {
    r <- 1 + sum(xdf)
    barx <- rep(0, r)
    vname <- c('Intercept',xn)
    covx <- matrix(0, nrow=r, ncol=r, dimnames=list(vname,vname))
    if(ytype != 'l') {
      r <- ncol(Y)+1
      bary <- rep(0, r)
      vname <- c('Intercept',paste(yname, 1:(r-1), sep=''))
      covy <- matrix(0, nrow=r, ncol=r, dimnames=list(vname,vname))
    }
  }
  if(ytype=='l') {
    f <- lm.fit.qr.bare(X, Y, tolerance=tolerance)
	xcof <- f$coefficients
	r2  <- f$rsquared
    cof <- 1
    ty  <- y
    ydf <- 1
    lp  <- f$fitted.values
    res <- f$residuals
    mad <- mean(abs(y-lp))
    med <- median(abs(y-lp))
    if(B > 0) {
      r2opt <- madopt <- medopt <- 0
      for(j in 1:B) {
        s <- sample(1:n, replace=TRUE)
        g <- lm.fit.qr.bare(X[s,,drop=FALSE], Y[s])
        b <- g$coefficients
        r2boot <- g$rsquared
        yhat <- matxv(X,b)
        r2orig <- cor(yhat, y)^2
        r2opt  <- r2opt + r2boot - r2orig
        er <- abs(Y[s] - g$fitted.values)
        madboot <- mean(er)
        medboot <- median(er)
        er <- abs(y - yhat)
        madorig <- mean(er)
        medorig <- median(er)
        madopt <- madopt + madboot - madorig
        barx <- barx + b
        b <- as.matrix(b)
        covx <- covx + b %*% t(b)
      }
      r2opt   <- r2opt/B
      r2boot  <- r2 - r2opt
      madopt  <- madopt/B
      madboot <- mad - madopt
      medopt  <- medopt/B
      medboot <- med - medopt
      barx <- as.matrix(barx/B)
      covx <- (covx - B * barx %*% t(barx))/(B-1)
    }
  } else {
    f <- fcancor(X, Y)
    r2 <- f$r2
    xcof <- f$xcoef
    cof  <- f$ycoef
    ty   <- f$ty
    ydf  <- length(cof) - 1
    lp   <- as.vector(matxv(X, xcof))
    res  <- as.vector(ty - lp)

    if(!length(yinv)) {
      ## spline transformation, need coef to get inverse y transform
      yy   <- seq(min(y), max(y), length=1000)
      tyy  <- ytrans(yy, coef=cof)
      yinv <- inverseFunction(yy, tyy)
      need2getinv <- TRUE
    }

    puy  <- yinv(lp, what='sample')
    if(length(y) != length(puy)) browser()
    mad  <- mean(abs(y-puy))
    med  <- median(abs(y-puy))
    
    if(B > 0) {
      r2opt <- madopt <- medopt <- 0
      for(j in 1:B) {
        s <- sample(1:n, replace=TRUE)
        f <- fcancor(X[s,,drop=FALSE],Y[s,,drop=FALSE])
        bx <- f$xcoef
        by <- f$ycoef
        r2boot <- f$r2
        xbeta <- matxv(X,bx)
        ybeta <- matxv(Y,by)
        r2orig <- cor(xbeta, ybeta)^2
        r2opt  <- r2opt + r2boot - r2orig
        puyall <- if(need2getinv) {
          tyyb  <- ytrans(yy, coef=by)  ## keeping constant knots
          yinvb <- inverseFunction(yy, tyyb)
          yinvb(xbeta, coef=by, what='sample')
        } else yinv(xbeta, coef=by)
        er <- abs(y[s] - puyall[s])
        madboot <- mean(er)
        medboot <- median(er)
        er <- abs(y - puyall)
        madorig <- mean(er)
        medorig <- median(er)
        madopt <- madopt + madboot - madorig
        medopt <- medopt + medboot - medorig
        barx <- barx + bx
        bx <- as.matrix(bx)
        covx <- covx + bx %*% t(bx)
        bary <- bary + by
        by <- as.matrix(by)
        covy <- covy + by %*% t(by)
      }
      r2opt   <- r2opt/B
      r2boot  <- r2 - r2opt
      madopt  <- madopt/B
      madboot <- mad - madopt
      medopt  <- medopt/B
      medboot <- med - medopt
      
      barx <- as.matrix(barx/B)
      bary <- as.matrix(bary/B)
      covx <- (covx - B * barx %*% t(barx))/(B-1)
      covy <- (covy - B * bary %*% t(bary))/(B-1)
    }
  }
  j <- 0
  beta <- xcof[-1]
  tx <- x
  xmeans <- list()
  for(i in 1:p) {
    m <- xdf[i]
    z <- matxv(X[,(j+1):(j+m),drop=FALSE], beta[(j+1):(j+m)])
    mz <- mean(z)
    xmeans[[xnam[i]]] <- mz
    tx[,i] <- z - mz
    j <- j + m
  }
  r2cv <- madcv <- medcv <- NULL
  if(length(crossval)) {
    s <- sample(1:crossval, n, replace=TRUE)
    r2cv <- madcv <- medcv <- 0
    for(j in 1:crossval) {
      g    <- fcancor(X[s!=j,,drop=FALSE], Y[s!=j,,drop=FALSE])
      bx   <- g$xcoef
      by   <- g$ycoef
      xbo  <- matxv(X[s==j,,drop=FALSE], bx)
      ybo  <- matxv(Y[s==j,,drop=FALSE], by)
      r2cv <- r2cv + cor(xbo, ybo)^2
      puy <- if(need2getinv) {
        tyyb  <- ytrans(yy, coef=by)  ## keeping constant knots
        yinvb <- inverseFunction(yy, tyyb)
        yinvb(xbo, coef=by, what='sample')
        } else yinv(xbo, coef=by)
      er   <- abs(y[s==j] - puy)
      madcv<- madcv + mean(er)
      medcv<- medcv + median(er)
    }
    r2cv  <- r2cv/crossval
    madcv <- madcv/crossval
    medcv <- medcv/crossval
  }
  structure(list(y=y, x=x, ty=ty, tx=tx,
                 rsquared=r2, rsquaredcv=r2cv, nk=nk, xdf=xdf, ydf=ydf,
                 xcoefficients=xcof, ycoefficients=cof,
                 xparms=xparms, yparms=yparms, xmeans=xmeans,
                 ytrans=ytrans, yinv=yinv,
                 linear.predictors=lp, residuals=res,
                 xtype=xtype, ytype=ytype, yname=yname,
                 r2boot=r2boot, r2opt=r2opt,
                 mad=mad, madboot=madboot, madopt=madopt,
                 med=med, medboot=medboot, medopt=medopt,
                 madcv=madcv, medcv=medcv,
                 xcov=covx, ycov=covy,
                 n=n, m=nmiss, B=B, crossval=crossval),
            class='areg')
}

aregTran <- function(z, type, nk = length(parms), parms = NULL,
                     functions = FALSE)
{
  if(type=='l' || (type=='s' && nk==0)) 
    return(if(functions)
           structure(as.matrix(z),
                     fun       =function(x,...)x,
                     inversefun=function(x,...)x) else as.matrix(z))

  if(type=='c') {
    n <- length(z)
    lp <- length(parms)
    ## Assume z is integer code if parms is given
    w <- if(lp) z else factor(z)
    x <- as.integer(w)
    if(!lp) parms <- 1:max(x)
    z <- matrix(0, nrow=n, ncol=length(parms)-1)
    z[cbind(1:n, x-1)] <- 1
    attr(z, 'parms') <- if(lp)parms else levels(w)
    if(functions) {
      attr(z, 'fun') <- function(x, parms, coef) {
        if(length(parms) > length(coef)) coef <- c(0,coef)
        coef[-1] <- coef[-1] + coef[1]
        names(coef) <- parms
        coef[x]
      }
      formals(attr(z, 'fun')) <- list(x=integer(0), parms=parms, coef=numeric(0))

      ## what is ignored; for compatibility with inverseFunction in Misc.s
      attr(z, 'inversefun') <- function(y, parms, coef, what=character(0)) {
        if(length(parms) > length(coef)) coef <- c(0, coef)
        isna <- is.na(y)
        y[isna] <- 0
        x <- parms[whichClosest(c(coef[1], coef[1] + coef[-1]), y)]
        x[isna] <- NA
        x
      }
      formals(attr(z, 'inversefun')) <- list(y=numeric(0), parms=parms,
                         coef=numeric(0), what=character(0))

    }
    z
  } else {
    z <- rcspline.eval(z, knots=parms, nk=nk, inclx=TRUE)
    knots <- attr(z, 'knots')
    attr(z,'parms') <- knots
    if(functions) attr(z, 'fun') <- rcsplineFunction(knots)
    ## inverse function created later when coefficients available
    z
  }
}

predict.areg <- function(object, x, type=c('lp','fitted'),
                         what=c('all','sample'), ...) {
  type <- match.arg(type)
  what <- match.arg(what)
  beta   <- object$xcoefficients
  xparms <- object$xparms
  xtype  <- object$xtype
  xdf    <- object$xdf
  ybeta  <- object$ycoefficients
  yinv   <- object$yinv
  x <- as.matrix(x)
  p <- length(xdf)
  X <- matrix(NA, nrow=nrow(x), ncol=sum(xdf))
  j <- 0
  xnam <- names(xtype)
  for(i in 1:p) {
    w <- aregTran(x[,i], xtype[i], parms=xparms[[xnam[i]]])
    m <- ncol(w)
    X[,(j+1):(j+m)] <- w
    j <- j + m
  }
  xb <- matxv(X, beta)
  if(type=='fitted') yinv(xb, what=what, coef=ybeta) else xb
}

print.areg <- function(x, digits=4, ...) {
  xdata <- x[c('n','m','nk','rsquared','xtype','xdf','ytype','ydf')]
  xinfo <- data.frame(type=xdata$xtype, d.f.=xdata$xdf,
                      row.names=names(xdata$xtype))
  cat('\nN:',xdata$n,'\t',xdata$m,
      ' observations with NAs deleted.\n')
  cat('R^2: ', round(xdata$rsquared,3),'\tnk: ',xdata$nk,
      '\tMean and Median |error|: ',format(x$mad, digits=digits),', ',
      format(x$med, digits=digits),'\n\n', sep='')
  if(length(x$r2boot)) {
    x1 <- format(c(x$r2opt,  x$madopt,  x$medopt),  digits=digits)
    x2 <- format(c(x$r2boot, x$madboot, x$medboot), digits=digits)
    n  <- c('R^2', 'Mean |error|', 'Median |error|')
    d  <- cbind('Bootstrap Estimates'=n, Optimism=x1, 'Optimism-corrected'=x2)
    row.names(d) <- rep('', 3)
    if(.R.) print(d, quote=FALSE, right=TRUE) else
     print(d, quote=FALSE)
  }
  if(length(x$crossval)) {
    x1 <- format(c(x$rsquaredcv, x$madcv, x$medcv), digits=digits)
    n  <- c('R^2', 'Mean |error|', 'Median |error|')
    d  <- cbind(n, x1)
    dimnames(d) <- list(rep('',3), 
      c(paste(x$crossval,'-fold Cross-validation',sep=''),
        'Estimate'))
    cat('\n')
    if(.R.) print(d, quote=FALSE, right=TRUE) else
     print(d, quote=FALSE)
  }
  cat('\n')
  print(xinfo)
  cat('\ny type:', xdata$ytype,'\td.f.:', xdata$ydf,'\n\n')
  invisible()
}

plot.areg <- function(x, whichx=1:ncol(x$x), ...) {
	plot(x$y, x$ty, xlab=x$yname,
         ylab=paste('Transformed',x$yname))
    r2 <- round(x$rsquared,3)
    if(.R.) title(sub=bquote(R^2==.(r2)), adj=0) else
     title(sub=paste('R^2=',r2),adj=0)
    xdata <- x$x
    cn <- colnames(xdata)
    for(i in whichx)
      plot(xdata[,i], x$tx[,i],
           xlab=cn[i], ylab=paste('Transformed', cn[i]), ...) 
    invisible()
}
# $Id: aregImpute.s 433 2007-02-09 23:28:35Z harrelfe $
aregImpute <- function(formula, data, subset, n.impute=5,
                       group=NULL, nk=3, tlinear=TRUE,
                       type=c('pmm','regression'),
                       match=c('weighted','closest'), fweighted=0.2,
                       curtail=TRUE,
                       boot.method=c('simple', 'approximate bayesian'),
                       burnin=3, x=FALSE,
                       pr=TRUE, plotTrans=FALSE,
                       tolerance=NULL, B=75)
{
  
  acall   <- match.call()
  type    <- match.arg(type)
  match   <- match.arg(match)
  boot.method <- match.arg(boot.method)

  if(!inherits(formula,'formula'))
    stop('formula must be a formula')
  
  nam <- var.inner(formula)

  m <- match.call(expand = FALSE)
  Terms <- terms(formula, specials='I')
  m$formula <- formula
  m$match <- m$fweighted <- m$curtail <- m$x <- m$n.impute <- m$nk <-
    m$tlinear <- m$burnin <- m$type <- m$group <- m$pr <-
      m$plotTrans <- m$tolerance <- m$boot.method <- m$B <- NULL
  m$na.action <- na.retain

  m[[1]] <- as.name("model.frame")
  z <- eval(m, sys.parent())
  p <- length(z)
  n <- nrow(z)
  rnam <- row.names(z)
  if(length(rnam)==0) rnam <- as.character(1:n)

  lgroup <- length(group)
  if(lgroup) {
    if(boot.method == 'approximate bayesian')
      stop('group not implemented for boot.method="approximate bayesian"')
    if(lgroup != n)
      stop('group should have length equal to number of observations')
    
    ngroup <- length(unique(group[!is.na(group)]))
  }

  linear <- nam[attr(Terms,'specials')$I]

  cat.levels <- vector('list',p)
  names(cat.levels) <- nam
  vtype <- rep('s', p); names(vtype) <- nam
  dof <- rep(NA, p); names(dof) <- nam
  na <- vector('list',p)
  names(na) <- nam
  nna <- integer(p); names(nna) <- nam

  xf <- matrix(as.double(1), nrow=n, ncol=p, dimnames=list(rnam,nam))
  imp <- vector('list',p)
  names(imp) <- nam
  if(lgroup) group.inds <- imp

  for(i in 1:p) {
    xi <- z[[i]]
    ni <- nam[i]
    nai <- is.na(xi)
    na[[i]] <- (1:n)[nai] 
    nna[i] <- nnai <- sum(nai)
    if(nnai > 0) imp[[ni]] <-  matrix(NA, nrow=nnai, ncol=n.impute,
                                      dimnames=list(rnam[nai],NULL))
    if(lgroup) {
      if(any(is.na(group[!nai])))
        stop('NAs not allowed in group')
      
      if(length(unique(group[!nai])) != ngroup)
        stop(paste('not all',ngroup,
                   'values of group are represented in\n',
                   'observations with non-missing values of',
                   ni))
      group.inds[[i]] <- split((1:n)[!nai], group[!nai])
    }
  
    iscat <- FALSE
    if(is.character(xi)) {
      xi <- as.factor(xi)
      lev <- levels(xi)
      iscat <- TRUE
    }
    else if(is.category(xi)) {
      lev <- levels(xi)
      iscat <- TRUE
    }
    if(iscat) {
      cat.levels[[ni]] <- lev
      xi <- as.integer(xi)
      vtype[ni] <- 'c'
    }
    else {
      u <- unique(xi[!nai])
      if(length(u) == 1)
        stop(paste(ni,'is constant'))
      else
        if((length(nk)==1 && nk==0) || length(u) == 2 || ni %in% linear)
          vtype[ni] <- 'l'
    }
    xf[,i] <- xi
    
    ## Initialize imputed values to random sample of non-missings
    if(nnai > 0) xf[nai,i] <-
      sample(xi[!nai], nnai, replace=nnai > (n-nnai))
  }
  z <- NULL
  wna <- (1:p)[nna > 0]

  
  ## xf = original data matrix (categorical var -> integer codes)
  ## with current imputations
  rsq <- double(length(wna));
  names(rsq) <- nam[wna]
  resampacc <- list()
  if(curtail) xrange <- apply(xf, 2, range)
  
  for(iter in 1:(burnin + n.impute)) {
    if(pr) cat('Iteration',iter,'\r')
    for(i in wna) {
      nai <- na[[i]]      ## subscripts of NAs on xf[i,]
      j <- (1:n)[-nai]    ## subscripts of non-NAs on xf[i,]
      npr <- length(j)
      ytype <- if(tlinear && vtype[i]=='s')'l' else vtype[i]
      
      if(iter==(burnin + n.impute) && length(nk) > 1) {
        rn <- c('Bootstrap bias-corrected R^2',
                '10-fold cross-validated  R^2',
                'Bootstrap bias-corrected mean   |error|',
                '10-fold cross-validated  mean   |error|',
                'Bootstrap bias-corrected median |error|',
                '10-fold cross-validated  median |error|')
        racc <- matrix(NA, nrow=6, ncol=length(nk),
                       dimnames=list(rn, paste('nk=',nk,sep='')))
        jj <- 0
        for(k in nk) {
          jj <- jj + 1
          f <- areg(xf[,-i,drop=FALSE], xf[,i],
                    xtype=vtype[-i], ytype=ytype,
                    nk=k, na.rm=FALSE,
                    tolerance=tolerance, B=B, crossval=10)
          w <- c(f$r2boot, f$rsquaredcv, f$madboot, f$madcv,
                 f$medboot, f$medcv)
          racc[,jj] <- w
        }
        resampacc[[nam[i]]] <- racc
      }

      if(lgroup) {        ## insure orig. no. obs from each level of group
        s <- rep(NA, npr)
        for(ji in 1:ngroup) {
          gi <- (group.inds[[i]])[[ji]]
          s[gi] <- sample(gi, length(gi), replace=TRUE)
        }
      }
      else { ## sample of non-NAs
        s <- sample(j, npr, replace=TRUE)
        if(boot.method == 'approximate bayesian')
          s <- sample(s, replace=TRUE)
      }
      nami <- nam[i]
      nm <- c(nami, nam[-i])

      X <- xf[,-i,drop=FALSE]

      f <- areg(X[s,], xf[s,i], xtype=vtype[-i], ytype=ytype,
                nk=min(nk), na.rm=FALSE, tolerance=tolerance)
      dof[names(f$xdf)] <- f$xdf
      dof[nami] <- f$ydf
      
      if(plotTrans) plot(f)
      
      rsq[nami] <- f$rsquared
      pti <- predict(f, X)  # predicted transformed xf[,i]
      
      if(type=='pmm') {
        if(ytype=='l') pti <- (pti - mean(pti))/sqrt(var(pti))
        whichclose <- if(match=='closest') {
          
          ## Jitter predicted transformed values for non-NAs to randomly
          ## break ties in matching with predictions for NAs in xf[,i]
          ## Becuase of normalization used by fitter, pti usually ranges
          ## from about -4 to 4
          pti[j] <- pti[j] + runif(npr,-.0001,.0001)
          
          ## For each orig. missing xf[,i] impute with non-missing xf[,i]
          ## that has closest predicted transformed value
          j[whichClosest(pti[j], pti[nai])]  ## see Misc.s
        }
        else
          j[whichClosePW(pti[j], pti[nai], f=fweighted)]
        impi <- xf[whichclose,i]
      } else {
        ## residuals off of transformed predicted values
        res <- f$residuals
        
        ## predicted transformed target var + random sample of res,
        ## for NAs
        r <- sample(res, length(nai),
                    replace=length(nai) > length(res))
        ptir <- pti[nai] + r
        
        ## predicted random draws on untransformed scale
        impi <- f$yinv(ptir, what='sample', coef=f$ycoefficients)
        if(curtail) impi <- pmin(pmax(impi, xrange[1,i]), xrange[2,i])
      }
      xf[nai,i] <- impi
      if(iter > burnin) imp[[nam[i]]][,iter-burnin] <- impi
    }
  }
  if(pr)
    cat('\n')

  if(!x)
    xf <- NULL
  
  structure(list(call=acall, formula=formula,
                 match=match, fweighted=fweighted,
                 n=n, p=p, na=na, nna=nna,
                 type=vtype, tlinear=tlinear, nk=min(nk),
                 cat.levels=cat.levels, df=dof,
                 n.impute=n.impute, imputed=imp, x=xf, rsq=rsq,
                 resampacc=resampacc),
            class='aregImpute')
}

print.aregImpute <- function(x, digits=3, ...)
{
  cat("\nMultiple Imputation using Bootstrap and PMM\n\n")
  dput(x$call)
  cat("\n")
  cat('tn:',x$n,'\tp:',x$p,
      '\tImputations:',x$n.impute,' \tnk:',x$nk,'\n')
  cat('\nNumber of NAs:\n'); print(x$nna); cat('\n')
  info <- data.frame(type=x$type, d.f.=x$df,
                     row.names=names(x$type))
  print(info)
  if(x$tlinear)
    cat('\nTransformation of Target Variables Forced to be Linear\n')
  
  cat('\nR-squares for Predicting Non-Missing Values for Each Variable\nUsing Last Imputations of Predictors\n')
  print(round(x$rsq, digits))

  racc <- x$resampacc
  if(length(racc)) {
    cat('\nResampling results for determining the complexity of imputation models\n\n')
    for(i in 1:length(racc)) {
      cat('Variable being imputed:', names(racc)[i], '\n')
      print(racc[[i]], digits=digits)
      cat('\n')
    }
    cat('\n')
  }
  invisible()
}

plot.aregImpute <- function(x, nclass=NULL, type=c('ecdf','hist'),
                            datadensity=c("hist","none","rug","density"),
                            diagnostics=FALSE, maxn=10, ...)
{
  type <- match.arg(type)
  datadensity <- match.arg(datadensity)
  i <- x$imputed
  catg <- x$categorical
  lev  <- x$cat.levels
  n.impute <- x$n.impute
  for(n in names(i)) {
    xi <- i[[n]]
    if(!length(xi))
      next
    
    if(diagnostics) {
      r <- range(xi)
      for(j in 1:min(maxn,nrow(xi))) {
        plot(1:n.impute, xi[j,], ylim=r, xlab='Imputation',
             ylab=paste("Imputations for Obs.",j,"of",n))
      }
    }
    
    ix <- as.vector(i[[n]])
    lab <- paste('Imputed',n)
    if(n %in% catg) {
      tab <- table(ix)
      mar <- par('mar')
      dotchart2(tab, lev[[n]], auxdata=tab, xlab='Frequency',
                ylab=lab)
      par(mar=mar)
    }
    else {
      if(type=='ecdf')
        Ecdf(ix, xlab=lab, datadensity=datadensity, subtitles=FALSE)
      else {
        if(length(nclass))
          hist(ix, xlab=n, nclass=nclass, main='')
        else
          hist(ix, xlab=lab, main='')
        scat1d(ix)
      }
    }
  }
  invisible()
}
as.data.frame.Surv <- function(x, ...)
{
  rown <- if(length(dx1 <- dimnames(x)[[1]]))
            dx1
          else 
            as.character(1:nrow(x))
  ## Added names= 18Sep01
  structure(list(x), class="data.frame", names=deparse(substitute(x)),
            row.names=rown)
}
biVar <- function(formula, statinfo, data=NULL, subset=NULL,
                  na.action=na.retain, exclude.imputed=TRUE, ...)
{
  call <- match.call()
  x <- do.call('model.frame',
               list(formula, data=data, subset=subset, na.action=na.action))
  nam <- names(x); yname <- nam[1]
  y <- x[[1]]
  x <- x[-1]
  m <- ncol(x)
  statnames <- statinfo$names
  stats <- matrix(NA, nrow=m, ncol=length(statnames),
                  dimnames=list(names(x), statnames))
  nmin <- statinfo$nmin
  fun  <- statinfo$fun
  
  N <- integer(m)
  yna <- if(is.matrix(y))is.na(y %*% rep(1,ncol(y))) else is.na(y)
  for(i in 1:m) {
    w <- x[[i]]
    j <- !(yna | is.na(w))
    if(exclude.imputed) j <- j & !(is.imputed(w) | is.imputed(y))
    yy <- if(is.matrix(y)) y[j,,drop=FALSE] else y[j]
    w <- w[j]
    N[i] <- length(w)
    stats[i,] <- if(N[i] >= nmin) fun(w, yy, ...) else
     rep(NA, length(statnames))
  }
  stats <- cbind(stats, n=N)
  structure(stats, class='biVar', yname=yname, statinfo=statinfo, call=call)
}

print.biVar <- function(x, ...) {
  info  <- attr(x, 'statinfo')
  yname <- attr(x, 'yname')
  cat('\n', info$title, '    Response variable:', yname, '\n\n', sep='')

  dig <- c(info$digits,0)
  for(i in 1:ncol(x))
    x[,i] <- round(x[,i],dig[i])
  
  attr(x,'yname') <- attr(x, 'statinfo') <- attr(x, 'call') <-
    oldClass(x) <- NULL
  print(x)
  invisible()
}


plot.biVar <- function(x,
                       what=info$defaultwhat,
                       sort.=TRUE,
                       main, xlab, ...) {

  yname <- attr(x, 'yname')
  info  <- attr(x, 'statinfo')
  aux   <- info$aux
  auxlabel <- info$auxlabel
  if(!length(auxlabel)) auxlabel <- aux
  
  i <- match(what, info$names)
  if(is.na(i)) stop(paste('what must be one of',
                          paste(info$names,collapse=' ')))
  if(missing(xlab))
    xlab <- if(.R.) info$rxlab[i] else info$xlab[i]
  if(missing(main)) main <-
    if(.R.) parse(text=paste(as.character(info$rmain),'~~~~Response:',
                    yname,sep='')) else
            paste(info$main,'    Response:', yname, sep='')

  if(.SV4.) x <- matrix(oldUnclass(x), nrow=nrow(x),
                        dimnames=dimnames(x))
  auxtitle <- 'N'; auxdata <- format(x[,'n'])
  if(length(aux)) {
    auxtitle <- paste('N', auxlabel, sep='  ')
    auxdata  <- paste(format(x[,'n']), format(x[,aux]))
  }
  stat <- x[,what]
  if(sort.) {
    i <- order(stat)
    stat <- stat[i]
    auxdata <- auxdata[i]
  }
  dotchart2(stat, auxdata=auxdata, reset.par=TRUE,
            xlab=xlab, auxtitle=auxtitle,
            main=main, ...)
  invisible()
}

chiSquare <- function(formula, data=NULL, subset=NULL, na.action=na.retain,
                      exclude.imputed=TRUE, ...) {
  
g <- function(x, y, minlev=0, g=3) {
  if(minlev) y <- combine.levels(y, minlev=minlev)
  if((is.character(x) || is.category(x)) && minlev)
      x <- combine.levels(x, minlev=minlev)
  if(is.numeric(x) && length(unique(x)) > g) x <- cut2(x, g=g)
  ct <- chisq.test(x, y)
  chisq <- ct$statistic
  df    <- ct$parameter
  pval  <- ct$p.value
  c(chisq, df, chisq-df, pval)
}

statinfo <- list(fun=g,
                 title='Pearson Chi-square Tests',
                 main='Pearson Chi-squared',
                 rmain=expression(Pearson~chi^2),
                 names=c('chisquare','df','chisquare-df','P'),
                 xlab=c('Chi-square','d.f.','Chi-square - d.f.','P-value'),
                 rxlab=expression(chi^2, d.f., chi^2 - d.f., P-value),
                 digits=c(2,0,2,4),
                 aux='df', nmin=2, defaultwhat='chisquare-df')

biVar(formula, statinfo=statinfo, data=data, subset=subset,
      na.action=na.action, exclude.imputed=TRUE, ...)
}

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

spearman2.default <- function(x, y, p=1, minlev=0,
                              na.rm=TRUE, exclude.imputed=na.rm, ...)
{
  if(p > 2)
    stop('p must be 1 or 2')
  
  
  y <- as.numeric(y)
  if(is.character(x))
    x <- factor(x)

  if(na.rm) {
    s <- !(is.na(x) | is.na(y))
    if(exclude.imputed) {
      im <- is.imputed(x) | is.imputed(y)
      s <- s & !im
    }
    x <- x[s]; y <- y[s]
  }
  n <- length(x)
  
  ## If number of non-NA values is less then 3 then return a NA
  ## value.
  if(n < 3)
    return(c(rho2=NA,F=NA,df1=0,df2=n,P=NA,n=n,'Adjusted rho2'=NA))

  ## Find the number of unique values in x
  u <- length(unique(x))

  ## If is a factor and unique values are greater then 2 then find the
  ## lm.fit.qr.bare without an intercept.
  if(is.category(x) && u > 2) {
    if(minlev > 0) {
      x <- combine.levels(x, minlev)
      if(length(levels(x))<2) {
        warning(paste('x did not have >= 2 categories with >=',
                      mlev,'of the observations'))
        return(c(rho2=NA,F=NA,df1=0,df2=n,P=NA,n=n,'Adjusted rho2'=NA))
      }
    }
    
    x <- model.matrix(~x, data=data.frame(x))
    p <- ncol(x)-1
    rsquare <- lm.fit.qr.bare(x, rank(y), intercept=FALSE)$rsquared
  } else {
    x <- as.numeric(x)
    if(u < 3)
      p <- 1
    
    x <- rank(x)
    rsquare <-
      if(p==1)
        cor(x, rank(y))^2
      else {
        x <- cbind(x, x^2)
        lm.fit.qr.bare(x, rank(y), intercept=TRUE)$rsquared
      }
  }
  
  df2 <- n-p-1
  fstat <- rsquare/p/((1-rsquare)/df2)
  pvalue <- 1-pf(fstat,p,df2)
  rsqa <- 1 - (1 - rsquare)*(n-1)/df2
  
  x <- c(rsquare,fstat,p,df2,pvalue,n,rsqa)
  names(x) <- c("rho2","F","df1","df2","P","n","Adjusted rho2")
  x
}

spearman2.formula <- function(formula, data=NULL, subset=NULL,
                              na.action=na.retain,
                              exclude.imputed=TRUE, ...)
{
  g <- function(x, y, p=1, minlev=0)
    spearman2(x, y, p=p, minlev=minlev, na.rm=FALSE)[-6]
    
statinfo <- list(fun=g,
                 title='Spearman rho^2',
                 main='Spearman rho^2',
                 rmain=expression(Spearman~rho^2),
                 names=c('rho2','F','df1','df2','P','Adjusted rho2'),
                 xlab=c('rho^2','F','df2','df2','P-value','Adjusted rho^2'),
                 rxlab=expression(rho^2, F, df1, df2, P-value, Adjusted~rho^2),
                 digits=c(3,2,0,0,4,3),
                 aux='df1', auxlabel='df', nmin=2, defaultwhat='Adjusted rho2')

biVar(formula, statinfo=statinfo, data=data, subset=subset,
      na.action=na.action, exclude.imputed=exclude.imputed, ...)
}
binconf <- function(x, n, alpha = 0.05,
                    method = c("wilson","exact","asymptotic","all"),
                    include.x = FALSE, include.n = FALSE, 
                    return.df = FALSE)
{
  ## ..modifications for printing and the addition of a 
  ##   method argument and the asymptotic interval
  ##   and to accept vector arguments were
  ##   made by Brad Biggerstaff on 10 June 1999

  method <- match.arg(method)
  bc <- function(x, n, alpha, method)
  {
    nu1 <- 2 * (n - x + 1)
    nu2 <- 2 * x
    ll <- if(x > 0)
            x/(x + qf(1 - alpha/2, nu1, nu2) * (n - x + 1))
          else
            0
    
    nu1p <- nu2 + 2
    nu2p <- nu1 - 2
    pp <- if(x < n)
            qf(1 - alpha/2, nu1p, nu2p)
          else
            1
    
    ul <- ((x + 1) * pp)/(n - x + (x + 1) * pp)
    zcrit <-  - qnorm(alpha/2)
    z2 <- zcrit * zcrit
    p <- x/n
    cl <- (p + z2/2/n + c(-1, 1) * zcrit *
           sqrt((p * (1 - p) + z2/4/n)/n))/(1 + z2/n)
    
    if(x == 1)
      cl[1] <-  - log(1 - alpha)/n
    
    if(x == (n - 1))
      cl[2] <- 1 + log(1 - alpha)/n
    
    asymp.lcl <- x/n - qnorm(1 - alpha/2) *
                 sqrt(((x/n) * (1 - x/n))/n)
    
    asymp.ucl <- x/n + qnorm(1 - alpha/2) * sqrt(((x/n) * (1 - x/n)
                                                  )/n)
    res <- rbind(c(ll, ul), cl, c(asymp.lcl, asymp.ucl))
    res <- cbind(rep(x/n, 3), res)
    
    ##dimnames(res) <- list(c("Exact", "Wilson", "Asymptotic"), c(
    ## "Point Estimate", "Lower", "Upper"))
    switch(method,
           wilson =     res[2,  ],
           exact =      res[1,  ],
           asymptotic = res[3,  ],
           all =        res,
           res)
  }

  if((length(x) != length(n)) & length(x) == 1)
    x <- rep(x, length(n))
  if((length(x) != length(n)) & length(n) == 1)
    n <- rep(n, length(x))
  if((length(x) > 1 | length(n) > 1) & method == "all") {
    method <- "wilson"
    warning("method=all will not work with vectors...setting method to wilson")
  }
  if(method == "all" & length(x) == 1 & length(n) == 1) {
    mat <- bc(x, n, alpha, method)
    dimnames(mat) <- list(c("Exact", "Wilson", "Asymptotic"),
                          c("PointEst", "Lower", "Upper"))
    if(include.n)
      mat <- cbind(N = n, mat)
    
    if(include.x)
      mat <- cbind(X = x, mat)
    
    if(return.df)
      mat <- as.data.frame(mat)
    
    return(mat)
  }
  
  mat <- matrix(ncol = 3, nrow = length(x))
  for(i in 1:length(x))
    mat[i,  ] <- bc(x[i], n[i], alpha = alpha, method = method)
  
  dimnames(mat) <- list(rep("", dim(mat)[1]),
                        c("PointEst", "Lower", "Upper"))
  if(include.n)
    mat <- cbind(N = n, mat)
  
  if(include.x)
    mat <- cbind(X = x, mat)

  if(return.df)
    mat <- as.data.frame(mat, row.names=NULL)
  
  mat
}
bootkm <- function(S, q=.5, B=500, times, pr=TRUE)
{
  if(.R. && !existsFunction('survfit.km'))
    survfit.km <- getFromNamespace('survfit.km','survival')
  
  tthere <- !missing(times)
  if(tthere && length(times)>1)
    stop('presently bootkm only works for a single time')
  
  S <- S[!is.na(S),]
  n <- nrow(S)
  stratvar <- factor(rep(1,nrow(S)))
  f <- survfit.km(stratvar, S)
  tt <- c(0, f$time)
  ss <- c(1, f$surv)
  if(!tthere) {
    if(ss[length(ss)] > q) 
      stop(paste('overall Kaplan-Meier estimate does not fall below',q))
    
  } else {
    if(tt[length(tt)] < times)
      stop(paste('overall Kaplan-Meier estimate not defined to time',times))
  }

  ests <- if(.R.)
            double(B)
          else
            single(B)

  for(i in 1:B) {
    if(pr && (i %% 10)==0)
      cat(i,'')
    
    f <- survfit.km(stratvar, S[sample(n,n,replace=TRUE),],
                    se.fit=FALSE, conf.type='none')
    tt <- c(0, f$time)
    ss <- c(1, f$surv)
    ests[i] <- if(tthere)
                 approx(tt, ss, xout=times, method='constant', f=0)$y
               else
                 min(tt[ss <= q])  #is NA if none
  }
  if(pr)
    cat('\n')
  
  ests
}
bpower <- function(p1, p2, odds.ratio, percent.reduction, n, n1, n2, 
                   alpha=.05)
{
  if(!missing(odds.ratio))
    p2 <- p1*odds.ratio/(1-p1+p1*odds.ratio)
  else if(!missing(percent.reduction))
    p2 <- p1*(1-percent.reduction/100)

  if(!missing(n)) {
    n1 <- n2 <- n/2
  }
  z <- qnorm(1-alpha/2)
  q1 <- 1-p1
  q2 <- 1-p2
  pm <- (n1*p1+n2*p2)/(n1+n2)
  ds <- z*sqrt((1/n1 + 1/n2)*pm*(1-pm))
  ex <- abs(p1-p2)
  sd <- sqrt(p1*q1/n1+p2*q2/n2)
  c(Power = 1-pnorm((ds-ex)/sd)+pnorm((-ds-ex)/sd) )
}


bsamsize <- function(p1, p2, fraction=.5, alpha=.05, power=.8)
{
  z.alpha <- qnorm(1-alpha/2)
  z.beta  <- qnorm(power)

  ratio <- (1-fraction)/fraction
  p <- fraction*p1+(1-fraction)*p2

  n1 <- (z.alpha * sqrt((ratio+1) * p * (1-p)) +
         z.beta * sqrt(ratio * p1 * (1-p1) + p2 * (1 - p2))
        )^2/ratio/((p1-p2)^2)
  
  n2 <- ratio*n1
  c(n1=n1, n2=n2)
}

ballocation <- function(p1, p2, n, alpha=.05)
{
  q1 <- 1-p1
  q2 <- 1-p2

  f.minvar.diff <- 1/(1+sqrt(p2*q2/(p1*q1)))
  f.minvar.ratio <- 1/(1+sqrt(p1*q2/p2/q1))

  z <- c(fraction.group1.min.var.diff=f.minvar.diff,
         fraction.group1.min.var.ratio=f.minvar.ratio,
         fraction.group1.min.var.logodds=1-f.minvar.diff)

  if(!missing(n)) {
    possf <- seq(.001,.999,length=1000)
    pow <- bpower(p1, p2, n1=n*possf, n2=n*(1-possf), alpha=alpha)
    ## fun <- function(f, n, p1, p2, alpha) bpower(p1, p2, n1=f*n, n2=(1-f)*n, alpha=alpha)
    ## f.maxpow <- optimize(fun, lower=.01, upper=.99, maximum=T,
    ##                      n=n, p1=p1, p2=p2, alpha=alpha)$maximum
    f <- possf[pow==max(pow)]
    f <- f[abs(f-.5)==min(abs(f-.5))]
    z <- c(z, fraction.group1.max.power=f[1])
  }
  z
}

bpower.sim <- function(p1, p2, odds.ratio, percent.reduction, n, n1, n2, 
                       alpha=.05, nsim=10000)
{
  if(!missing(odds.ratio))
    p2 <- p1*odds.ratio/(1-p1+p1*odds.ratio)
  else if(!missing(percent.reduction))
    p2 <- p1*(1-percent.reduction/100)

  if(!missing(n)) {
    n1 <- n2 <- round(n/2)
  }
  n <- n1+n2

  if(length(p1)+length(p2)+length(n1)+length(n2)+length(alpha)+length(nsim)!=6)
    stop('all arguments must have length 1')

  chi2 <- qchisq(1-alpha, 1)

  d1 <- rbinom(nsim, n1, p1)
  d2 <- rbinom(nsim, n2, p2)
  chisq <- n*(d1*(n2-d2)-(n1-d1)*d2)^2/(d1+d2)/(n-d1-d2)/n1/n2
  power <- mean(chisq>chi2)
  se <- sqrt(power*(1-power)/nsim)
  c(Power=power,Lower=power-1.96*se,Upper=power+1.96*se)
}
##Modified FEH 30Jun97 - delete missing data, names default to T,
## auto names for list argument, ylab default to "" instead of Percentiles
## names -> name, added srtx
bpplot <- function(..., name = TRUE,
                   main = "Box-Percentile Plot", 
                   xlab = "", ylab = "", srtx=0)
{
  all.x <- list(...)  ## FH 30Jun97
  nam <- character(0)   ## FH
  ## if(is.list(...)) {  ## FH
  if(is.list(all.x[[1]])) {
    all.x <- all.x[[1]]
    if(is.logical(name) && name) name <- names(...)   ## FH
  }
  
  n <- length(all.x)
  centers <- seq(from = 0, by = 1.2, length = n)
  ymax <- max(sapply(all.x, max, na.rm=TRUE))  ## na.rm=T FEH
  ymin <- min(sapply(all.x, min, na.rm=TRUE))
  xmax <- max(centers) + 0.5
  xmin <- -0.5
  plot(c(xmin, xmax), c(ymin, ymax), type = "n", main = main,
       xlab = '', ylab = ylab, xaxt = "n")
  for(i in 1:n) {
    plot.values <- bpx(all.x[[i]], centers[i])
    lines(plot.values$x1, plot.values$y1)
    lines(plot.values$x2, plot.values$y2)
    lines(plot.values$q1.x, plot.values$q1.y)
    lines(plot.values$q3.x, plot.values$q3.y)
    lines(plot.values$med.x, plot.values$med.y)
  }

  if(is.logical(name)) {
    if(name)
      mgp.axis(1, centers, 
               sapply(substitute(list(...)), deparse)[2:(n + 1)],
               srt=srtx,
               adj=if(srtx==0).5
                   else 1,
               axistitle=xlab)
  }
  else mgp.axis(1, centers, name, srt=srtx,
                adj=if(srtx==0).5
                    else 1,
                axistitle=xlab)
  
  invisible(centers)
}

bpx <- function(y, offset)
{
  y <- y[!is.na(y)]   ## FEH 30Jun97
  n <- length(y)
  delta <- 1/(n + 1)
  prob <- seq(delta, 1 - delta, delta)
  quan <- sort(y)
  med <- median(y)
  q1 <- median(y[y < med])
  q3 <- median(y[y > med])
  first.half.p <- prob[quan <= med]
  second.half.p <- 1 - prob[quan > med]
  plotx <- c(first.half.p, second.half.p)
  
  ## calculating the ends of the first quartile line

  qx <- approx(quan, plotx, xout = q1)$y
  q1.x <- c( - qx, qx) + offset

  ## calculating the ends of the third quartile line

  qx <- approx(quan, plotx, xout = q3)$y
  q3.x <- c( - qx, qx) + offset
  q1.y <- c(q1, q1)
  q3.y <- c(q3, q3)
  med.x <- c( - max(first.half.p), max(first.half.p)) + offset
  med.y <- c(med, med)
  return(list(x1 = ( - plotx) + offset, y1 = quan, x2 = plotx + offset,
              y2 = quan, q1.y = q1.y, q1.x = q1.x, q3.y = q3.y, q3.x = q3.x,
              med.y = med.y, med.x = med.x))
}
bystats <- function(y, ..., fun, nmiss, subset)
{
  ## Fri, 16 Sep 2005 - Shawn@ori.org removed left argument to
  ## interaction
  x <- interaction(..., drop=TRUE, sep=" ")
  l <- levels(x)
  if(any(is.na(x))) {
    l <- c(l, "NA")
    attr(x,"class") <- NULL
    x[is.na(x)] <- length(l)
    levels(x) <- l
    attr(x,'class') <- "factor"
  }
  
  y <- as.matrix(y)
  if(!missing(subset)) { 
    x <- x[subset]
    y <- y[subset,,drop=FALSE]
  }

  if(missing(fun)) {
    fun <- function(y) apply(y, 2, mean)
    
    r <- range(y, na.rm=TRUE)
    uy <- unique(y[!is.na(y)])  #fixed 1Jun95, 16Mar96
    funlab <- if(length(uy)==2 && r[1]==0 & r[2]==1)
                "Fraction"
              else
                "Mean"
  } else {
    funlab <- as.character(substitute(fun))
    funlab <- funlab[length(funlab)] #handles fun=function(x)mean(x)
    if(!.R. && length(chf <- as.character(fun[[2]]))>3 && chf[1]=="apply")
      funlab <- chf[4]
    ## The preceeding gets "median" from function(y) apply(y, 2, median)
    ## if(length(fun)==2 && length(fun[[2]])>1) funlab <- ""
  }
  lab <- as.character(sys.call())[-1]
  m <- (!missing(fun)) + (!missing(nmiss)) + (!missing(subset))
  lab <- lab[1:(length(lab)-m)]
  if(length(lab)>2)
    lab2 <- paste(lab[-1],collapse=", ")
  else
    lab2 <- lab[-1]
  heading <- if(funlab=="")
               paste(lab[1],"by",lab2)
             else
               paste(funlab,"of",lab[1],"by",lab2)

  nna <- !is.na(y %*% rep(1,ncol(y)))
  N <- sum(nna)
  stats <- fun(y[nna,,drop=FALSE])
  nstats <- length(stats)
  name.stats <- if(length(dn <- dimnames(stats))) 
                  as.vector(outer(dn[[1]],dn[[2]],
                                  FUN=function(a,b)paste(b, a)))
                else
                  names(stats)
  
  if(length(name.stats))
    funlab <- name.stats
  if(nstats>1 && length(name.stats)==0)
    funlab <- rep(" ", nstats)
  s <- matrix(NA, nrow=length(l) + 1, ncol=2 + nstats,
              dimnames=list(c(l, "ALL"),c("N", "Missing", funlab)))
  j <- 0
  for(i in l) {
    j <- j+1
    w <- y[x==i,,drop=FALSE]
    nna <- !is.na(w %*% rep(1,ncol(w)))
    n <- sum(nna)
    s[j,] <- c(n, nrow(w)-n, 
               if(n) fun(w[nna,,drop=FALSE])
               else rep(NA,nstats))
  }
  
  s[j+1,] <- c(N, nrow(y)-N, stats)
  if((!missing(nmiss) && !nmiss) || (missing(nmiss) && all(s[,"Missing"]==0)))
    s <- s[,-2]
  
  attr(s, "heading")    <- heading
  attr(s, "byvarnames") <- lab2
  attr(s,'class')       <- "bystats"
  s
}

print.bystats <- function(x, ...)
{
  cat("\n",attr(x,"heading"),"\n\n")
  attr(x,"heading") <- NULL
  attr(x,"byvarnames") <- NULL
  attr(x,'class') <- NULL
  invisible(print(x, ...))
}

latex.bystats <- function(object,
                          title=first.word(expr=substitute(object)),
                          caption=attr(object,"heading"),
                          rowlabel=attr(object,"byvarnames"), ...)
{
  dm <- dimnames(object)
  ##inn <- c("%","<=","<",">=",">","\\[")
  ##out <- c("\\\\%","$\\\\leq$","$<$","$\\\\geq$","$>$","\\\\verb|[|")
  ##dm[[1]] <- translate(dm[[1]],inn,out)
  ##dm[[2]] <- translate(dm[[2]],inn,out)
  inn <- c("%","<=","<",">=",">","[")
  out <- c("\\%","$\\leq$","$<$","$\\geq$","$>$","\\verb|[|")
  dimnames(object) <- dm
  caption <- sedit(caption, "cbind", "")
  latex(oldUnclass(object), title=title, caption=caption, rowlabel=rowlabel, 
        n.rgroup=c(nrow(object)-1,1), ...)
}

bystats2 <- function(y, v, h, fun, nmiss, subset)
{
  y <- as.matrix(y)
  if(!missing(subset)) {
    y <- y[subset,,drop=FALSE];
    v <- v[subset];
    h <- h[subset]
  }
  
  v <- factor(v, exclude=NULL)
  h <- factor(h, exclude=NULL)

  lv <- levels(v)
  lh <- levels(h)
  nv <- length(lv)
  nh <- length(lh)

  if(missing(fun)) {
    fun <- function(y) apply(y, 2, mean)
    r <- range(y, na.rm=TRUE)
    funlab <- if(length(r)==2 && r[1]==0 & r[2]==1) "Fraction"
              else "Mean"
  } else {
    funlab <- as.character(substitute(fun))
    funlab <- funlab[length(funlab)] #handles fun=function(x)mean(x)
    if(!.R. && length(chf <- as.character(fun[[2]]))>3 && chf[1]=="apply")
      funlab <- chf[4]
    ##The preceeding gets "median" from function(y) apply(y, 2, median)
  }
  lab <- as.character(sys.call())[-1]
  m <- (!missing(fun)) + (!missing(nmiss)) + (!missing(subset))
  lab <- lab[1:(length(lab)-m)]
  if(length(lab)>2)
    lab2 <- paste(lab[-1],collapse=", ")
  else
    lab2 <- lab[-1]
  
  heading <- if(funlab=="")
               paste(lab[1],"by",lab2)
             else
               paste(funlab,"of",lab[1],"by",lab2)

  nna <- !is.na(y %*% rep(1,ncol(y)))
  N <- sum(nna)
  stats <- fun(y[nna,,drop=FALSE])
  nstats <- length(stats)
  name.stats <- if(length(dn <- dimnames(stats))) 
                  as.vector(outer(dn[[1]],dn[[2]],FUN=function(a,b)paste(b,a)))
                else 
                  names(stats)
  
  if(length(name.stats))
    funlab <- name.stats
  
  if(nstats>1 && length(name.stats)==0)
    funlab <- rep(" ", nstats)
   
  s <- array(NA,dim=c(nv+1,nh+1,2+nstats),
             dimnames=list(c(lv,"ALL"), c(lh,"ALL"), c("N","Missing",funlab)))

  for(xv in c(lv,"ALL")) {
    for(xh in c(lh,"ALL")) {
      if(xv=="ALL" && xh=="ALL")
        st <- c(N, nrow(y)-N, stats)
      else {
        if(xv=="ALL")
          u <- h==xh
        else if(xh=="ALL")
          u <- v==xv
        else
          u <- h==xh & v==xv
        
        if(any(u)) {
          w <- y[u,,drop=FALSE]
          nna <- !is.na(w %*% rep(1,ncol(w)))
          n <- sum(nna)
          st <- c(n, nrow(w)-n, fun(w[nna,,drop=FALSE]))
        } else st <- c(0, n, rep(NA, length(stats)))
      }
      s[xv,xh,] <- st
    }
  }     

  if((!missing(nmiss) && !nmiss) ||
     (missing(nmiss) && all(s[,,"Missing"]==0)))
    s <- s[,,-2,drop=FALSE]
  
  attr(s, "heading")    <- heading
  attr(s, "byvarnames") <- lab[-1]
  attr(s,'class')       <- "bystats2"
  s
}

print.bystats2 <- function(x, abbreviate.dimnames=FALSE, 
                           prefix.width=max(nchar(dimnames(x)[[1]])),...)
{
  cat("\n",attr(x,"heading"),"\n\n")
  if(!exists("print.char.matrix")) {   # Vanilla S
    attr(x, "heading") <- attr(x, "byvarnames") <- attr(x, "class") <-
      NULL
    return(invisible(print(x)))
  }
  
  d <- dim(x)
  cstats <- array("", dim=d[1:3])

  header <- matrix(paste(dimnames(x)[[3]],collapse="\n"),1,1)
  print.char.matrix(header)

  for(k in 1:d[3])
    cstats[,,k] <- format(x[,,k])
  
  dimn <- dimnames(x)[1:2]
  names(dimn) <- attr(x,"byvarnames")
  cstats2 <- matrix("", nrow=d[1], ncol=d[2], dimnames=dimn)
  for(i in 1:d[1]) {
    for(j in 1:d[2]) {
      cstats2[i,j] <- paste(cstats[i,j,],collapse="\n")
    }
  }
  invisible(if(.R.)
              print.char.matrix(cstats2,...)
            else
              print.char.matrix(cstats2, prefix.width=prefix.width,
                                abbreviate.dimnames=abbreviate.dimnames,...))
}

latex.bystats2 <- function(object,
                           title=first.word(expr=substitute(object)),
                           caption=attr(object, "heading"),
                           rowlabel="", ...)
{
  dm <- dimnames(object)
  inn <- c("%", "<=", "<", ">=", ">", "[")
  out <- c("\\%", "$\\leq$","$<$", "$\\geq$","$>$", "\\verb|[|")
  dm[[1]] <- sedit(dm[[1]], inn, out)
  dm[[2]] <- sedit(dm[[2]],inn,out)
  dm[[3]] <- sedit(dm[[3]],inn,out)
  dimnames(object) <- dm
  caption <- sedit(caption, "cbind", "")
  d <- dim(object)
  dn <- rep(dimnames(object)[[3]], d[2])
  st <- matrix(NA, nrow=d[1], ncol=d[2]*d[3], 
               dimnames=list(dimnames(object)[[1]], dn))

  for(i in 1:d[1]) {
    l <- 0
    for(j in 1:d[2]) {
      for(k in 1:d[3]) {
        l <- l+1
        st[i,l] <- object[i,j,k]
      }
    }
  }

  latex(st, title=title, caption=caption, rowlabel=rowlabel,
        n.rgroup=c(nrow(st)-1,1), 
        cgroup=dimnames(object)[[2]], n.cgroup=rep(d[3],d[2]),...)
}
## tref     time at which mortalities estimated
## n1       total sample size, stratum 1
## n2       total sample size, stratum 2
## m1c      tref-year mortality, stratum 1 control
## m2c      "          "                 2  "
## r1       % reduction in m1c by intervention, stratum 1
## r2       % reduction in m2c by intervention, stratum 2
## accrual  duration of accrual period
## tmin     minimum follow-up time
## alpha    type I error
## pr       set to T to print intermediate results

ciapower <- function(tref,   
                     n1,     
                     n2,     
                     m1c,    
                     m2c,    
                     r1,     
                     r2,     
                     accrual,
                     tmin,   
                     alpha=.05,  
                     pr=TRUE)
{ 
  ## Find mortality in intervention groups
  if(m1c>1 | m2c>1)
    stop("m1c and m2c must be fractions")
  
  m1i <- (1-r1/100)*m1c
  m2i <- (1-r2/100)*m2c

  if(pr) {
    cat("\nAccrual duration:",accrual,"y  Minimum follow-up:",tmin,"y\n")
    cat("\nSample size Stratum 1:",n1,"  Stratum 2:",n2,"\n")
    cat("\nAlpha=",alpha,"\n")
    d <- list(c("Stratum 1","Stratum 2"), c("Control","Intervention"))
    m <- cbind(c(m1c,m2c),c(m1i,m2i))
    dimnames(m) <- d
    cat("\n",tref,"-year Mortalities\n",sep=""); print(m)
  }

  ## Find exponential hazards for all groups
  lam1c <- -logb(1-m1c)/tref
  lam2c <- -logb(1-m2c)/tref
  lam1i <- -logb(1-m1i)/tref
  lam2i <- -logb(1-m2i)/tref

  if(pr) {
    lam <- cbind(c(lam1c,lam2c),c(lam1i,lam2i))
    dimnames(lam) <- d
    cat("\nHazard Rates\n"); print(lam)
  }

  ## Find probability that a subject will have her event observed during
  ## the study, for all groups
  tmax <- tmin+accrual
  p1c <- 1-1/accrual/lam1c*(exp(-tmin*lam1c)-exp(-tmax*lam1c))
  p2c <- 1-1/accrual/lam2c*(exp(-tmin*lam2c)-exp(-tmax*lam2c))
  p1i <- 1-1/accrual/lam1i*(exp(-tmin*lam1i)-exp(-tmax*lam1i))
  p2i <- 1-1/accrual/lam2i*(exp(-tmin*lam2i)-exp(-tmax*lam2i))

  if(pr) {
    p <- cbind(c(p1c,p2c), c(p1i,p2i))
    dimnames(p) <- d
    cat("\nProbabilities of an Event During Study\n")
    print(p)
  }

  ##Find expected number of events, all groups
  m1c <- p1c*n1/2
  m2c <- p2c*n2/2
  m1i <- p1i*n1/2
  m2i <- p2i*n2/2

  if(pr) {
    m <- cbind(c(m1c,m2c), c(m1i,m2i))
    dimnames(m) <- d
    cat("\nExpected Number of Events\n")
    print(round(m,1))
  }

  ## Find expected value of observed log hazard ratio
  delta <- logb((lam1i/lam1c)/(lam2i/lam2c))
  if(pr)
    cat("\nRatio of hazard ratios:",format(exp(delta)),"\n")

  ## Find its variance
  v <- 1/m1c + 1/m2c + 1/m1i + 1/m2i
  sd <- sqrt(v)
  if(pr)
    cat("Standard deviation of log ratio of ratios:",format(sd),"\n")

  z <- -qnorm(alpha/2)
  ## if(pr) cat("\nCritical value:",format(z),"\n")

  c(Power = 1 - ( pnorm(z - abs(delta)/sd) - pnorm(-z - abs(delta)/sd) ) )
}
.ElmtCombine <- function(x, value, protect=FALSE, ...) {
  if(is.null(x)) {
    x <- vector()
  }

  if(is.null(value)) {
    value <- vector()
  }
  
  if((is.list(x) || is.vector(x)) &&
     (is.list(value) || is.vector(value))) {
    if(length(value)) {
      value.names <- names(value)
    } else {
      value.names <- vector()
    }
    
    if(length(x)) {
      x.names <- names(x)
    } else {
      x.names <- vector()
    }

    if(is.null(x.names) || is.null(value.names)) {
      stop("objects 'x' and 'value' must have names")
    }

    if(protect) {
      target <- value
      rep.vals <- x
      rep.names <- x.names
    } else {
      target <- x
      rep.vals <- value
      rep.names <- value.names
    }
        
    target[rep.names] <- rep.vals[rep.names]
    return(target)
  }
  stop("unable to combine these objects")
}

combine <- .ElmtCombine
'combine<-' <- as.function(c(formals(.ElmtCombine)[c('x','protect','...','value')],
                             body(.ElmtCombine)),
                           environment(.ElmtCombine))
if(!.R.) {
  "comment<-"  <- function(x, value)
  {
    if (inherits(value,"file"))
      attr(value,'class') <- c("comment.file", attr(value, 'class'))
    attr(x, "comment") <- value
    x
  }

  comment <- function(x)
  {
    lab <- attr(x, "comment")
    if (inherits(lab,"comment.file"))
      attr(lab,'class') <- attr(lab,'class')[attr(lab,'class') !=
                                             "comment.file"]
    
    lab
  }

  print.comment.file <- function(x, ...)
  {
    invisible(print(oldUnclass(x)))
  }
}
confbar <- function(at, est, se, width,
                    q=c(.7,.8,.9,.95,.99), 
                    col=if(.R.)
                          gray(c(0,.25,.5,.75,1))
                        else if(under.unix)
                          c(1,.8,.5,.2,.065)
                        else
                          c(1,4,3,2,5),
                    type=c("v","h"), labels=TRUE, ticks=FALSE,
                    cex=.5, side="l", lwd=5, clip=c(-1e30, 1e30),
                    fun=function(x)x, 
                    qfun=function(x)
                           ifelse(x==.5, qnorm(x),
                                  ifelse(x<.5,qnorm(x/2),qnorm((1+x)/2))))
{
  type <- match.arg(type)
  iusr <- if(type=="v")
            1:2
          else
            3:4
  
  if(missing(width))
    width <- diff(par("usr")[iusr])*.02
  
  if(side=="b")
    side <- "l"    #treat bottom as left
  
  if(length(q)!=length(col))
    stop("q and col must have same length")
  
  q <- c(1-rev(q), .5, q)
  ##qe <- seq(.01, .99, length=n)
  ##col <- seq(.8,.01, length=n/2)
  col <- c(rev(col), col)
  w <- width/2
  if(type=="v") {
    polyg <- function(a, b, col, clip)
    {
      b[b < clip[1] | b > clip[2]] <- NA
      polygon(a, b, col=col)
    }
    
    Lines <- function(a, b, lwd=1, clip)
    {
      b[b < clip[1] | b > clip[2]] <- NA
      lines(a, b, lwd=lwd)
    }
    
    Text  <- function(a, b, clip, ...)
    {
      b[b < clip[1] | b > clip[2]] <- NA
      text(a, b, ...)
    }
    
    srt <- 0
  } else {
    polyg <- function(a, b, col, clip)
    {
      b[b < clip[1] | b > clip[2]] <- NA
      polygon(b, a, col=col)
    }
    
    Lines <- function(a, b, lwd=1, clip)
    {
      b[b < clip[1] | b > clip[2]] <- NA
      lines(b, a, lwd=lwd)
    }
    
    Text  <- function(a, b, clip, ...)
    {
      b[b < clip[1] | b > clip[2]] <- NA
      text(b, a, ...)
    }
    
    srt   <- 45
  }
  for(i in 1:(length(q)-1))
    polyg(c(at-w,at+w,at+w,at-w),fun(est+se*qfun(c(q[i],q[i],q[i+1],q[i+1]))),
          col=col[i], clip=clip)
  
  a <- fun(est)
  z <- w*.24
  Lines(c(at-w-3.5*z, at+w+3.5*z), c(a,a), lwd=lwd, clip=clip)
  a <- fun(est+se*qfun(q))
  do <- TRUE
  if(labels || ticks)
    for(i in 1:length(q)) {
      b <- c(a[i], a[i])
      if(ticks) {
        Lines(c(at-w-z,at-w),b, clip=clip)
        Lines(c(at+w+z,at+w),b, clip=clip)
      }
      
      if(labels && do && q[i]!=.5) {
        if(side=="l")
          Text(at-w-2*z, a[i], format(max(1-q[i],q[i])), 
               cex=cex, adj=1, srt=srt, clip=clip)
        else
          Text(at+w+2*z, a[i], format(max(1-q[i],q[i])), 
               cex=cex, adj=0, srt=srt, clip=clip)
      }
      
      if(q[i]!=.5)
        do <- !do
    }
  
  names(a) <- format(q)
  invisible(a)
}
## tref        time at which mortalities estimated
## n           total sample size
## mc          tref-year mortality, control
## r           % reduction in m1c by intervention
## accrual     duration of accrual period
## tmin        minimum follow-up time
## noncomp.c   % non-compliant in control group (drop-ins)
## noncomp.i   % non-compliant in intervention group (non-adherers)
## alpha       type I error
## nc          Sample size for control (if not n/2)
## ni          Sample size for intervention (if not n/2)
## pr          set to T to print intermediate results
##
## non-compliance handled by an approximation of Eq. 5.4 of
## Lachin JM, Foulkes MA (1986): Evaluation of sample size and power for
## analyses of survival with allowance for nonuniform patient entry,
## losses to follow-up, noncompliance, and stratification.
## Here we're using log hazard ratio instead of their hazard difference

cpower <- function(tref,   
                   n,     
                   mc,
                   r,
                   accrual,
                   tmin,   
                   noncomp.c=0,
                   noncomp.i=0,
                   alpha=.05,  
                   nc, ni,
                   pr=TRUE)
{
  if(mc>1)
    stop("mc should be a fraction")

  ## Find mortality in intervention group
  mi <- (1-r/100)*mc

  if(missing(nc) | missing(ni)) {
    nc <- n/2; ni <- n/2
  } else n <- nc+ni

  if(pr) {
    cat("\nAccrual duration:",accrual,"y  Minimum follow-up:",tmin,"y\n")
    cat("\nTotal sample size:",n,"\n")
    cat("\nAlpha=",alpha,"\n")
    d <- c("Control","Intervention")
    m <- c(mc,mi)
    names(m) <- d
    cat("\n",tref,"-year Mortalities\n",sep=""); print(m)
  }

  ## Find exponential hazards for all groups
  lamc <- -logb(1-mc)/tref
  lami <- -logb(1-mi)/tref

  if(pr) {
    lam <- c(lamc,lami)
    names(lam) <- d
    cat("\nHazard Rates\n");
    print(lam)
  }

  ## Find probability that a subject will have her event observed during
  ## the study, for all groups
  tmax <- tmin+accrual
  pc <- if(accrual==0)
          1-exp(-lamc*tmin)
        else
          1-1/accrual/lamc*(exp(-tmin*lamc)-exp(-tmax*lamc))
  
  pi <- if(accrual==0)
          1-exp(-lami*tmin)
        else
          1-1/accrual/lami*(exp(-tmin*lami)-exp(-tmax*lami))

  if(pr) {
    p <- c(pc,pi)
    names(p) <- d
    cat("\nProbabilities of an Event During Study\n")
    print(p)
  }

  ## Find expected number of events, all groups
  mc <- pc*nc
  mi <- pi*ni

  if(pr) {
    m <- c(mc,mi)
    names(m) <- d
    cat("\nExpected Number of Events\n")
    print(round(m,1))
  }

  ## Find expected value of observed log hazard ratio
  delta <- logb(lami/lamc)
  if(pr)
    cat("\nHazard ratio:",format(exp(delta)),"\n")

  if(noncomp.c+noncomp.i>0) {
    if(pr)
      cat("\nDrop-in rate (controls):",noncomp.c,
          "%\nNon-adherence rate (intervention):",noncomp.i,"%\n",sep="")
    
    delta <- delta * (1 - (noncomp.c+noncomp.i)/100)
    if(pr)
      cat("Effective hazard ratio with non-compliance:",
          format(exp(delta)),"\n")
  }

  ## Find its variance
  v <- 1/mc + 1/mi
  
  ## Get same as /sasmacro/samsizc.sas if use 4/(mc+mi)

  sd <- sqrt(v)
  if(pr)
    cat("Standard deviation of log hazard ratio:",format(sd),"\n")

  z <- -qnorm(alpha/2)

  c(Power = 1 - (pnorm(z - abs(delta)/sd) - pnorm(-z - abs(delta)/sd)))
}
## $Id: curveRep.s 344 2006-10-20 22:32:24Z harrelfe $
curveRep <- function(x, y, id, kn=5, kxdist=5, k=5, p=5, force1=TRUE,
                     metric=c('euclidean','manhattan'),
                     smooth=FALSE, extrap=FALSE, pr=FALSE) {
  require(cluster)
  metric <- match.arg(metric)
  
  id <- as.character(id)
  omit <- is.na(x + y)
  missfreq <- NULL; nomit <- sum(omit)
  if(nomit) {
    m <- tapply(omit, id, sum)
    missfreq <- table(m)
    x <- x[!omit]; y <- y[!omit]; id <- id[!omit]
  }
  n <- length(x)
  ns <- table(id)
  nunique <- length(unique(ns))

  if(nunique==1 || nunique <= kn) ncuts <- c(sort(unique(ns)),Inf) else {
    grouped.n <- cut2(ns, g=kn)
    ncuts <- cut2(ns, g=kn, onlycuts=TRUE)
    if(force1 && ncuts[2] > 1 && min(ns)==1)
      ncuts <- sort(unique(c(1:2, ncuts)))
  }
  nlev <- length(ncuts)-1
  res <- vector('list', nlev)
  names(res) <- as.character(ncuts[-length(ncuts)])

  clust <- function(x, k)
    if(diff(range(x))==0 || NROW(x) < k+1) rep(1, NROW(x)) else
    clara(x, k, metric=metric)$clustering

  interp <- if(extrap)
    function(x, y=NULL, xout) approxExtrap(x, y, xout=xout)$y else
    function(x, y=NULL, xout) approx(x, y, xout=xout, rule=2)$y

  ## Cluster by sample size first
  if(pr) cat('Creating',nlev,'sample size groups\n\n')
  for(i in 1:nlev) {
    ## Get list of curve ids in this sample size group
    if(i==nlev) {
      below <- ns <= ncuts[i+1]
      brack <- ']'
    } else {
      below <- ns < ncuts[i+1]
      brack <- ')'
    }
    ids <- names(ns)[ns >= ncuts[i] & below]
    if(pr) cat('Processing sample size [',ncuts[i],',',ncuts[i+1],
               brack,' containing ', length(ids),' curves\n',sep='')
    if(length(ids) < kxdist) res[[i]] <- list(ids) else {
      ## Cluster by distribution of x within sample size group
      ## Summarize these ids by clustering on range of x,
      ## plus the largest gap if minimum sample size > 2
      ## Use only the x position is min sample size is 1
      s <- id %in% ids
      ssize <- min(tapply(x[s], id[s], function(w) length(unique(w))))
      z <- tapply((1:n)[s], id[s],
                  function(j) if(ssize==1) x[j][1] else
                  if(ssize==2) range(x[j]) else
                  c(range(x[j]),max(diff(sort(x[j])))))
      z <- matrix(unlist(z), nrow=length(z), byrow=TRUE)
      if(kxdist > nrow(z) - 1)
        stop('number of curves to cluster must be >= kxdist+1')
      distclusters <- clust(z, kxdist)
      if(pr) {
        cat(' Number of curves in each x-dist cluster:\n')
        print(table(distclusters))
      }
      resi <- list()
      ## Within x distribution and within sample size interval,
      ## cluster on linearly interpolated y at p equally spaced x points
      ## unless <2 unique x-points for some curve
      for(clus in 1:max(distclusters)) {
        idc <- ids[distclusters==clus]
        if(pr) cat(' Processing x-distribution group', clus,
                   'containing', length(idc),'curves\n')
        s <- id %in% idc
        ssize <- min(tapply(x[s], id[s], function(w) length(unique(w))))
        if(ssize > 1) {
          xrange <- range(x[s])
          xseq <- seq(xrange[1], xrange[2], length.out=p)
        }
        g <- if(ssize==1) function(j) c(mean(x[j]), mean(y[j])) else
         if(smooth && ssize > 2)
           function(j) interp(clowess(x[j],y[j]), xout=xseq) else
           function(j) interp(x[j], y[j], xout=xseq)
        
        z <- tapply((1:n)[s], id[s], g)
        z <- matrix(unlist(z), nrow=length(idc), byrow=TRUE)
        yclusters <- clust(z, min(k, max(length(idc)-2,1)))
        names(yclusters) <- idc
        resi[[clus]] <- yclusters
      }
      res[[i]] <- resi
    }
  }
  structure(list(res=res, ns=table(ns), nomit=nomit, missfreq=missfreq,
                 ncuts=ncuts, kn=kn, kxdist=kxdist, k=k, p=p,
                 smooth=smooth, x=x, y=y, id=id),
            class='curveRep')
}

print.curveRep <- function(x, ...) {
  sm <- if(x$smooth) 'smooth' else 'not smoothed'
  ncuts <- x$ncuts
  cat('kn:',x$kn, ' kxdist:',x$kxdist, ' k:',x$k,
      ' p:',x$p, ' ', sm, '\n\n', sep='')
  cat('Frequencies of number of non-missing values per curve:\n')
  print(x$ns)
  if(length(x$missfreq)) {
    cat(x$nomit, 'missing values excluded.\n\n')
    cat('\nFrequency of number of missing values per curve:\n')
    print(x$missfreq)
  }
  cat('\nSample size cuts:', paste(ncuts, collapse=' '),'\n')
  cat('Number of x distribution groups per sample size group:',
      paste(sapply(x$res, length), collapse=' '),'\n\n')
  res <- x$res
  ng <- length(res)
  for(i in 1:ng) {
    ngroup <- res[[i]]
    maxclus <- max(unlist(ngroup))
    w <- matrix(NA, nrow=maxclus, ncol=length(ngroup),
                dimnames=list(paste('Cluster',1:maxclus),
                  paste('x-Dist', 1:length(ngroup))))
    j <- 0
    for(xdistgroup in ngroup) {
      j <- j+1
      w[,j] <- tabulate(xdistgroup, nbins=maxclus)
    }
    brack <- if(i==ng) ']' else ')'
    z <- if(is.infinite(ncuts[i+1])) ncuts[i] else
    paste('[', ncuts[i], ',', ncuts[i+1], brack, sep='')
    cat('\nNumber of Curves for Sample Size ', z, '\n',sep='')
    print(w)
  }
  invisible()
}

plot.curveRep <- function(x, which=1:length(res),
                          method=c('all','lattice'),
                          m=NULL, probs=c(.5,.25,.75),
                          nx=NULL, fill=TRUE,
                          idcol=NULL, freq=NULL, plotfreq=FALSE,
                          xlim=range(x), ylim=range(y),
                          xlab='x', ylab='y', ...) {
  method <- match.arg(method)
  ncuts <- x$ncuts
  res <- x$res; id <- x$id; y <- x$y; k <- x$k; x <- x$x
  nng <- length(res)

  samp <- function(ids)
    if(!length(m) || is.character(m) ||
       length(ids) <= m) ids else sample(ids, m)
  if(is.character(m) &&
     (m != 'quantiles' || method != 'lattice'))
    stop('improper value of m')
  
  if(method=='lattice') {
    if(length(which) != 1)
      stop('must specify one n range to plot for method="lattice"')
    require(grid)
    require(lattice)
    nres <- names(res)
    nname <- if(length(nres)==1) NULL else
      if(nres[which]=='1' & nres[which+1]=='2') 'n=1' else {
        brack <- if(which==length(nres)) ']' else ')'
        z <- if(is.infinite(ncuts[which+1])) ncuts[which] else
        paste('[',ncuts[which],',',ncuts[which+1],brack,sep='')
        paste('n ',z, sep='')
      }
    
    res <- res[[which]]
    n <- length(x)
    X <- Y <- xdist <- cluster <- sizecluster <- numeric(n)
    curve <- character(n)
    if(length(freq)) {
      unique.cats <- unique(freq)
      Freqtab <- matrix(0, nrow=n, length(unique.cats),
                        dimnames=list(NULL, unique.cats))
    }
    st <- 1
    for(jx in 1:length(res)) {
      xgroup  <- res[[jx]]
      ids <- names(xgroup)
      for(jclus in 1:max(xgroup)) {
        all.ids.in.cluster <- ids[xgroup==jclus]
        if(length(freq)) {
          freqtab <- table(freq[all.ids.in.cluster])
          nfreqtab <- names(freqtab)
        }
        plotted.ids.in.cluster <- samp(all.ids.in.cluster)
        for(cur in plotted.ids.in.cluster) {
          s <- id %in% cur
          np <- sum(s)
          i <- order(x[s])
          en <- st+np-1
          if(en > n) stop('program logic error 1')
          X[st:en]       <- x[s][i]
          Y[st:en]       <- y[s][i]
          xdist[st:en]   <- jx
          cluster[st:en] <- jclus
          curve[st:en]   <- cur
          sizecluster[st:en] <- sum(xgroup==jclus)
          if(length(freq)) Freqtab[st:en, nfreqtab] <- rep(freqtab, each=np)
          st <- st+np
        }
      }
    }
    Y <- Y[1:en]; X <- X[1:en]
    distribution <- xdist[1:en]; cluster <- cluster[1:en]
    curve <- curve[1:en]; sizecluster <- sizecluster[1:en]
    if(length(freq)) Freqtab <- Freqtab[1:en,,drop=FALSE]
    textfun <- function(subscripts, groups=NULL) {
      if(!length(subscripts)) return()
      txt <- if(length(freq) && length(groups)) {
        tab <- Freqtab[subscripts[1],]
        if(plotfreq) {
          mx <- max(Freqtab, na.rm=TRUE)
          f <- mx/(.1*plotfreq)
          y <- 1
          fnam <- names(tab)
          long <- fnam[nchar(fnam)==max(nchar(fnam))][1]
          lx <- convertX(unit(1, 'strwidth', long), 'npc', valueOnly=TRUE)
          for(i in 1:length(tab)) {
            y <- y - .075
            grid.text(fnam[i], x=lx-.005, y=y+.025, just=c(1,.5),
                      gp=gpar(fontsize=7, col=gray(.4)))
            if(tab[i] > 0)
              grid.polygon(x=c(lx, lx+tab[i]/f, lx+tab[i]/f, lx, lx),
                           y=c(y, y, y+.05, y+.05, y), 
                           gp=gpar(fill=gray(.7), col=gray(.7)))
            if(tab[i]==mx)
              grid.text(mx, x=lx+mx/f + .01, y=y+.025,
                        just=c(0,.5), gp=gpar(fontsize=7, col=gray(.4)))
          }
          return()
        }
        txt <- paste(names(tab), tab, sep=':')
        paste(txt, collapse=';')
      } else {
        size <- sizecluster[subscripts[1]]
        paste('N=',size,sep='')
      }
      grid.text(txt, x=.005, y=.99, just=c(0,1),
                gp=gpar(fontsize=9, col=gray(.25)))
    }
    pan <- if(length(idcol))
      function(x, y, subscripts, groups, type, ...) {
        groups <- as.factor(groups)[subscripts]
        textfun(subscripts, groups)
        for(g in levels(groups)) {
          idx <- groups == g
          xx <- x[idx]; yy <- y[idx]; ccols <- idcol[g]
          if (any(idx)) { 
            switch(type, 
                   p = lpoints(xx, yy, col = ccols), 
                   l = llines(xx, yy, col = ccols), 
                   b = { lpoints(xx, yy, col = ccols) 
                         llines(xx, yy, col = ccols) }) 
          } 
        } 
      } else function(x, y, subscripts, groups, ...) {
        panel.superpose(x, y, subscripts, groups, ...)
        textfun(subscripts, groups)
      }
    if(is.character(m))
      print(xYplot(Y ~ X | distribution*cluster,
                   method='quantiles', probs=probs, nx=nx,
                   xlab=xlab, ylab=ylab,
                   xlim=xlim, ylim=ylim,
                   main=nname, as.table=TRUE,
                   panel=function(x, y, subscripts, ...) {
                     if(length(subscripts)) {
                       panel.xYplot(x, y, subscripts, ...)
                       textfun(subscripts)
                     }
                     })) else
    print(xyplot(Y ~ X | distribution*cluster, groups=curve,
                 xlab=xlab, ylab=ylab,
                 xlim=xlim, ylim=ylim,
                 type=if(nres[which]=='1')'b' else 'l',
                 main=nname, panel=pan, as.table=TRUE))
    return(invisible())
  }

  for(jn in which) {
    ngroup <- res[[jn]]
    for(jx in 1:length(ngroup)) {
      xgroup <- ngroup[[jx]]
      ids <- names(xgroup)
      for(jclus in 1:max(xgroup)) {
        rids <- ids[xgroup==jclus]
        nc <- length(rids)
        ids.in.cluster <- samp(rids)
        for(curve in 1:length(ids.in.cluster)) {
          s <- id %in% ids.in.cluster[curve]
          i <- order(x[s])
          type <- if(length(unique(x[s]))==1)'b' else 'l'
          if(curve==1) {
            plot(x[s][i], y[s][i], xlab=xlab, ylab=ylab,
                 type='n', xlim=xlim, ylim=ylim)
            brack <- if(jn==nng) ']' else ')'
            z <- if(is.infinite(ncuts[jn+1])) ncuts[jn] else
            paste('[', ncuts[jn],',',ncuts[jn+1],brack,sep='')
            title(paste('n ', z, ' x=',jx,
                        ' c=',jclus,' ',nc,' curves', sep=''), cex=.5)
          }
          lines(x[s][i], y[s][i], type=type,
                col=if(length(idcol))
                 idcol[ids.in.cluster[curve]] else curve)
        }
      }
      if(fill && max(xgroup) < k)
        for(i in 1:(k - max(xgroup)))
          plot(0, 0, type='n', axes=FALSE, xlab='', ylab='')
    }
  }
}

curveSmooth <- function(x, y, id, p=NULL, pr=TRUE) {
  omit <- is.na(x + y)
  if(any(omit)) {
    x <- x[!omit]; y <- y[!omit]; id <- id[!omit]
  }
  uid <- unique(id)
  m <- length(uid)
  pp <- length(p)
  if(pp) {
    X <- Y <- numeric(p*m)
    Id <- rep(id, length.out=p*m)
  }
  st <- 1
  en <- 0
  ncurve <- 0
  for(j in uid) {
    if(pr) {
      ncurve <- ncurve + 1
      if((ncurve %% 50) == 0) cat(ncurve,'')
    }
    s <- id==j
    xs <- x[s]
    ys <- y[s]
    if(length(unique(xs)) < 3) {
      if(pp) {
        en <- st + length(xs) - 1
        X[st:en] <- xs
        Y[st:en] <- ys
        Id[st:en] <- j
      }
    } else {
      if(pp) {
        uxs <- sort(unique(xs))
        xseq <- if(length(uxs) < p) uxs else
        seq(min(uxs), max(uxs), length.out=p)
        ye <- approx(clowess(xs, ys), xout=xseq)$y
        n <- length(xseq)
        en <- st + n - 1
        X[st:en] <- xseq
        Y[st:en] <- ye
        Id[st:en] <- j
      } else y[s] <- approx(clowess(xs, ys), xout=xs)$y
    }
    st <- en + 1
  }
  if(pr) cat('\n')
  if(pp) {
    X <- X[1:en]
    Y <- Y[1:en]
    Id <- Id[1:en]
    list(x=X, y=Y, id=Id)
  } else list(x=x, y=y, id=id)
}
# $Id: cut2.s 472 2007-04-03 14:56:56Z dupontct $
## Function like cut but left endpoints are inclusive and labels are of
## the form [lower, upper), except that last interval is [lower,upper].
## F. Harrell  3 Dec 90, modified 7 Mar 92, mod 30May95 (more efficient digits)
## Modified 2Jun95 (preserve label attribute)
## Modified 16Jun95 (categories with 1 unique value -> label=value, not interval)
## Modified 1Jul95 - if specified cuts, mindif would cause improper
##   categorization if a cut was close to but not equal an actual value

cut2 <- function(x, cuts, m=150, g, levels.mean=FALSE, digits, minmax=TRUE,
		 oneval=TRUE, onlycuts=FALSE)
{
  method <- 1 ## 20may02
  x.unique <- sort(unique(c(x[!is.na(x)],if(!missing(cuts))cuts)))
  min.dif <- min(diff(x.unique))/2
  min.dif.factor <- 1

  ## Make formatted values look good
  if(missing(digits))
    digits <- if(levels.mean) 5 else 3
  
  oldopt <- options(digits=digits)
  on.exit(options(oldopt))

  xlab <- attr(x, 'label')

  if(missing(cuts)) {
    nnm <- sum(!is.na(x))
    if(missing(g)) g <- max(1,floor(nnm/m))
    if(g < 1)
      stop('g must be >=1, m must be positive')

    options(digits=15)
    n <- table(x)
    xx <- as.double(names(n))
    options(digits=digits)
    cum <- cumsum(n)
    m <- length(xx)

    y <- as.integer(ifelse(is.na(x),NA,1))
    labs <- character(g)
    cuts <- approx(cum, xx, xout=(1:g)*nnm/g,
                   method='constant', rule=2, f=1)$y
    cuts[length(cuts)] <- max(xx)
    lower <- xx[1]
    upper <- 1e45
    up <- low <- double(g)
    i <- 0
    for(j in 1:g) {
      cj <- if(method==1 || j==1) cuts[j] else {
        if(i==0)
          stop('program logic error')
        s <- if(is.na(lower)) FALSE else xx >= lower
        cum.used <- if(all(s)) 0 else max(cum[!s])
        if(j==m) max(xx) else if(sum(s)<2) max(xx) else
        approx(cum[s]-cum.used, xx[s], xout=(nnm-cum.used)/(g-j+1),
               method='constant', rule=2, f=1)$y
      }
      
      if(cj==upper) next
      
      i <- i + 1
      upper <- cj
      y[x >= (lower-min.dif.factor*min.dif)]  <- i
      low[i] <- lower
      lower <- if(j==g) upper else min(xx[xx > upper])
      
      if(is.na(lower)) lower <- upper
      
      up[i]  <- lower
    }
    
    low  <- low[1:i]
    up   <- up[1:i]
    variation <- logical(i)
    for(ii in 1:i) {
      r <- range(x[y==ii], na.rm=TRUE)
      variation[ii] <- diff(r) > 0
    }
    if(onlycuts) return(unique(c(low, max(xx))))
    flow <- format(low)
    fup  <- format(up)
    bb   <- c(rep(')',i-1),']')
    labs <- ifelse(low==up | (oneval & !variation), flow,
                   paste('[',flow,',',fup,bb,sep=''))
    ss <- y==0 & !is.na(y)
    if(any(ss))
      stop(paste('categorization error in cut2.  Values of x not appearing in any interval:\n',
                 paste(format(x[ss],digits=12),collapse=' '),
                 '\nLower endpoints:',
                 paste(format(low,digits=12), collapse=' '),
                 '\nUpper endpoints:',
                 paste(format(up,digits=12),collapse=' ')))

    y <- structure(y, class='factor', levels=labs)
  } else {
    if(minmax) {
      r <- range(x, na.rm=TRUE)
      if(r[1]<cuts[1]) cuts <- c(r[1], cuts)
      if(r[2]>max(cuts)) cuts <- c(cuts, r[2])
    }
    
    l <- length(cuts)
    k2 <- cuts-min.dif
    k2[l] <- cuts[l]
    y <- cut(x, k2)
    
    if(!levels.mean) {
      brack <- rep(")",l-1)
      brack[l-1] <- "]"
      fmt <- format(cuts)
      ## If any interval has only one unique value, set label for
      ## that interval to that value and not to an interval
      labs <- paste("[",fmt[1:(l-1)],",",fmt[2:l],
                    brack,sep="")   
    
      if(oneval) {
        nu <- table(cut(x.unique,k2))
        
        if(length(nu)!=length(levels(y)))
          stop('program logic error')
        levels(y) <- ifelse(nu==1,c(fmt[1:(l-2)],fmt[l]),labs)
      } else
        levels(y) <- labs
    }
  }

  if(levels.mean) {
    means <- tapply(x, y, function(w)mean(w,na.rm=TRUE))
    levels(y) <- format(means)
  }
  attr(y,'class') <- "factor"
  if(length(xlab)) label(y) <- xlab
  y
}
## For every object in a data frame that has a 'label' attribute, make it
## class 'labelled'

data.frame.labelled <- function(object)
{
  for(n in names(object))
    if(length(attr(object[[n]],'label')))
      attr(object[[n]],'class') <- c('labelled',attr(object[[n]],'class'))

  object
}
dataRep <- function(formula, data, subset, na.action)
{
  call <- match.call()
  nact <- NULL
  y <- match.call(expand=FALSE)
  if(missing(na.action))
    y$na.action <- na.delete
  
  y[[1]] <- as.name("model.frame")
  
  ## See if Des argument exists in current model.frame.default
  if(length(model.frame.default$Des))
    y$Des  <- FALSE   #turn off Design
  
  X <- eval(y, sys.parent())
  nact <- attr(X,"na.action")
  n <- nrow(X)
  nam <- names(X)
  p <- length(nam)
  types <- character(p)
  parms <- character(p)
  pctl  <- vector('list',p)
  margfreq <- vector('list',p)
  Xu   <- vector('list',p)
  for(j in 1:p) {
    namj <- nam[j]
    xj <- X[[j]]
    if(is.character(xj))
      xj <- as.factor(xj)
    
    if(is.factor(xj)) {
      parms[[j]] <- paste(levels(xj),collapse=' ')
      types[j] <- 'exact categorical'
    } else if(inherits(xj,'roundN')) {
      atr <- attributes(xj)
      nam[j] <- atr$name
      types[j] <- 'round'
      parms[j] <- paste('to nearest',format(atr$tolerance))
      if(length(w <- atr$clip))
        parms[j] <- paste(parms[j],', clipped to [',
                          paste(format(w),collapse=','),']',sep='')
      
      pctl[[j]] <- atr$percentiles
    } else {
      types[j] <- 'exact numeric'
      parms[j] <- ''
      pctl[[j]] <- quantile(xj, seq(0,1,by=.01))
    }

    margfreq[[j]] <- table(xj)
    Xu[[j]] <- sort(unique(xj))
    X[[j]] <- xj
  }
  
  names(types) <- names(parms) <- names(pctl) <- names(margfreq) <- 
    names(Xu) <- nam
  
  Xu <- expand.grid(Xu)
  m <- nrow(Xu)
  count <- integer(m)
  for(i in 1:m) {
    matches <- rep(TRUE,n)
    for(j in 1:p)
      matches <- matches & (as.character(X[[j]]) ==
                            as.character(Xu[[j]][i]))
    
    count[i] <- sum(matches)
  }
  
  if(any(count==0)) {
    s     <- count > 0
    Xu    <- Xu[s,]
    count <- count[s]
    m     <- sum(s)
  }

  structure(list(call=call, formula=formula, n=n, names=nam, 
                 types=types, parms=parms, margfreq=margfreq,
                 percentiles=pctl, X=Xu, count=count, na.action=nact), 
            class='dataRep')
}

roundN <- function(x, tol=1, clip=NULL)
{
  pct <- quantile(x, seq(0,1,by=.01), na.rm=TRUE)
  name <- deparse(substitute(x))
  lab <- attr(x, 'label')
  if(!length(lab))
    lab <- name
  
  if(!missing(clip))
    x <- pmin(pmax(x,clip[1]),clip[2])
  
  structure(as.single(tol*round(x/tol)), tolerance=tol, clip=clip,
            percentiles=pct, name=name, label=lab, class='roundN')
}

if(.R.)
  as.data.frame.roundN <- as.data.frame.vector


'[.roundN' <- function(x, i, ...)
{
  atr <- attributes(x)
  x <- oldUnclass(x)[i]
  attributes(x) <- atr
  x
}


print.dataRep <- function(x, long=FALSE, ...)
{
  cat("\n")
  cat("Data Representativeness    n=",x$n,"\n\n", sep='')
  dput(x$call)
  cat("\n")
  if(length(z <- x$na.action))
    naprint(z)
  
  specs <- data.frame(Type=x$types, 
                      Parameters=x$parms,
                      row.names=x$names)
  
  cat('Specifications for Matching\n\n')
  print.data.frame(specs)
  X <- x$X
  if(long) {
    X$Frequency <- x$count
    cat('\nUnique Combinations of Descriptor Variables\n\n')
    print.data.frame(X)
  } else cat('\n',nrow(X),
             'unique combinations of variable values were found.\n\n')
  invisible()
}


predict.dataRep <- function(object, newdata, ...)
{
  n <- object$n
  count <- object$count
  if(missing(newdata))
    return(count)

  pctl     <- object$percentiles
  margfreq <- object$margfreq
  p        <- length(margfreq)
  m        <- nrow(newdata)
  nam      <- object$names
  types    <- object$types
  X        <- object$X

  ##Xn <- if(length(model.frame.default$Des))   3Aug02
  ##        model.frame(object$formula, newdata, na.action=na.keep, Des=FALSE) else
  Xn <- model.frame(object$formula, newdata, na.action=na.keep)
  names(Xn) <- nam

  worst.margfreq <- rep(1e8, m)
  pct <- matrix(NA, m, p, dimnames=list(row.names(Xn),nam))
  for(j in 1:p) {
    xj <- Xn[[j]]
    freq <- margfreq[[nam[j]]][as.character(xj)]
    freq[is.na(freq)] <- 0
    pct[,j] <- if(types[j]=='exact categorical')
                 100*freq/n
               else
                 approx(pctl[[nam[j]]], seq(0,100,by=1),
                        xout=newdata[[nam[j]]], rule=2)$y
    
    worst.margfreq <- pmin(worst.margfreq, freq)
  }

  cnt <- integer(m)
  for(i in 1:m) {
    matches <- rep(TRUE,nrow(X))
    for(j in 1:p) {
      matches <- matches & (as.character(X[[j]]) == as.character(Xn[[j]][i]))
    }
    
    s <- sum(matches)
    if(s > 1) 
      warning('more than one match to original data combinations')
    
    cnt[i] <- if(s)
                count[matches]
              else
                0
  }
  
  if(any(cnt > worst.margfreq))
    warning('program logic error')

  structure(list(count=cnt, percentiles=pct, worst.margfreq=worst.margfreq, 
                 newdata=newdata),	class='predict.dataRep')
}

print.predict.dataRep <- function(x, prdata=TRUE, prpct=TRUE, ...)
{
  if(prdata) {
    dat <- x$newdata
    dat$Frequency     <- x$count
    dat$Marginal.Freq <- x$worst.margfreq
    cat('\nDescriptor Variable Values, Estimated Frequency in Original Dataset,\nand Minimum Marginal Frequency for any Variable\n\n')
    print.data.frame(dat)
  } else {
    cat('\nFrequency in Original Dataset\n\n')
    print(x$count)
    cat('\nMinimum Marginal Frequency for any Variable\n\n')
    print(x$worst.margfreq)
  }
  
  if(prpct) {
    cat('\n\nPercentiles for Continuous Descriptor Variables,\nPercentage in Category for Categorical Variables\n\n')
    print(round(x$percentiles))
  }
  
  invisible()
}
yearDays <- function(time) {
  time <- as.POSIXlt(time)

  time$mon[] <- time$mday[] <- time$sec[] <- time$min <- time$hour <- 0
  time$year <- time$year + 1

  return(as.POSIXlt(as.POSIXct(time))$yday)
}

monthDays <- function(time) {
  time <- as.POSIXlt(time)
  time$mday[] <- time$sec[] <- time$min <- time$hour <- 0
  time$mon <- time$mon + 1

  return(as.POSIXlt(as.POSIXct(time))$mday)
}

round.POSIXt <- function(x, digits=c("secs", "mins", "hours", "days", "months", "years"))
  {
    ## this gets the default from the generic, as that has two args.
    if(is.numeric(digits) && digits == 0.0) digits <-"secs"
    units <- match.arg(digits)

    month.length <- monthDays(x)
    x <- as.POSIXlt(x)

    if(length(x$sec) > 0)
      switch(units,
             "secs"   = {x$sec <- x$sec + 0.5},
             "mins"   = {x$sec <- x$sec + 30},
             "hours"  = {x$sec <- 0; x$min <- x$min + 30},
             "days"   = {x$sec <- 0; x$min <- 0; x$hour <- x$hour + 12
                         isdst <- x$isdst <- -1},
             "months" = {x$sec <- 0; x$min <- 0; x$hour <- 0;
                         x$mday <- x$mday + trunc(monthDays(x)/2);
                         isdst <- x$isdst <- -1},
             "years"  = {x$sec <- 0; x$min <- 0; x$hour <- 0;
                         x$mday <- 0; x$mon <- x$mon + 6;
                         isdst <- x$isdst <- -1}
             )

    return(trunc(as.POSIXct(x), units=units))
  }

trunc.POSIXt <- function(x, units=c("secs", "mins", "hours", "days", "months", "years"), ...) {
    units <- match.arg(units)

    x <- as.POSIXlt(x)

    isdst <- x$isdst
    if(length(x$sec) > 0)
      switch(units,
             "secs" = {x$sec <- trunc(x$sec)},
             "mins" = {x$sec <- 0},
             "hours"= {x$sec <- 0; x$min <- 0},
             "days" = {x$sec <- 0; x$min <- 0; x$hour <- 0; isdst <- x$isdst <- -1},
             "months" = {
               x$sec <- 0
               x$min <- 0
               x$hour <- 0
               x$mday <- 1
               isdst <- x$isdst <- -1
             },
             "years" = {
               x$sec <- 0
               x$min <- 0
               x$hour <- 0
               x$mday <- 1
               x$mon <- 0
               isdst <- x$isdst <- -1
             }
             )

    x <- as.POSIXlt(as.POSIXct(x))
    if(isdst == -1) {
      x$isdst <- -1
    }
    return(x)
  }

ceil <- function(x, units, ...) {
  UseMethod('ceil', x)
}

ceil.default <- function(x, units, ...) {
  ceiling(x)
}

ceil.POSIXt <- function(x, units=c("secs", "mins", "hours", "days", "months", "years"), ...) {
  units <- match.arg(units)

  x <- as.POSIXlt(x)

  isdst <- x$isdst
  if(length(x$sec) > 0 && x != trunc.POSIXt(x, units=units)) {
    switch(units,
           "secs" = {
             x$sec <- ceiling(x$sec)
           },
           "mins" = {
             x$sec <- 0
             x$min <- x$min + 1
           },
           "hours"= {x$sec <- 0; x$min <- 0; x$hour <- x$hour + 1},
           "days" = {
             x$sec <- 0
             x$min <- 0
             x$hour <- 0
             x$mday <- x$mday + 1
             isdst <- x$isdst <- -1
           },
           "months" = {
             x$sec <- 0
             x$min <- 0
             x$hour <- 0
             x$mday <- 1
             x$mon <- x$mon + 1
             isdst <- x$isdst <- -1
           },
           "years" = {
             x$sec <- 0
             x$min <- 0
             x$hour <- 0
             x$mday <- 1
             x$mon <- 0
             x$year <- x$year + 1
             isdst <- x$isdst <- -1
           }
           )

    x <- as.POSIXlt(as.POSIXct(x))
    if(isdst == -1) {
      x$isdst <- -1
    }
  }    
  return(x)  
}
deff <- function(y, cluster)
{
  ss <- function(x)
  {
    n <- length(x)
    xbar <- sum(x)/n
    sum((x-xbar)^2)
  }

  if(!is.factor(cluster))
    cluster <- as.factor(cluster)
  
  cluster <- oldUnclass(cluster)
  s <- !is.na(cluster+y)
  y <- y[s]; cluster <- as.integer(cluster[s])
  n <- length(y)
  sst <- ss(y)
  sses <- tapply(y,cluster,ss)
  k  <- length(sses)
  R2 <- 1-sum(sses)/sst
  Fstat  <- R2*(n-k)/(1-R2)/k
  g  <- (Fstat-1)*k/n
  rho <- g/(1+g)
  ng <- table(cluster)
  B  <- sum(ng^2)/n
  deff <- 1+(B-1)*rho
  c(n=n, clusters=k, rho=rho, deff=deff)
}
## $Id: describe.s 443 2007-02-26 20:37:37Z harrelfe $
describe <- function(x, ...) UseMethod("describe")  #13Mar99


describe.default <- function(x, descript, ...)  #13Mar99
{
  if(missing(descript)) {
    descript <- deparse(substitute(x)) #13Mar99
  }

  if(is.matrix(x)) {
    describe.matrix(x, descript, ...)
  } else {
    describe.vector(x, descript, ...)  #13Mar99
  }
}


describe.vector <- function(x, descript, exclude.missing=TRUE, digits=4,
                            listunique=0, listnchar=12,
                            weights=NULL, normwt=FALSE, minlength=NULL, ...)
{
  oldopt <- options(digits=digits)
  on.exit(options(oldopt))
  
  if(length(weights)==0) {
    weights <- rep(1,length(x))
  }
  
  special.codes <- attr(x, "special.miss")$codes
  labx <- attr(x,"label")
  
  if(missing(descript)) {
    descript <- as.character(sys.call())[2]
  }

  if(length(labx) && labx!=descript) {
    descript <- paste(descript,":",labx)
  }

  un <- attr(x,"units")
  if(length(un) && un=='') {
    un <- NULL
  }

  fmt <- attr(x,'format')
  if(length(fmt) && (is.function(fmt) || fmt=='')) {
    fmt <- NULL
  }
  
  if(length(fmt) > 1) {
    fmt <- paste(as.character(fmt[[1]]),as.character(fmt[[2]]))
  }
  
  present <- if(all(is.na(x)))
    rep(FALSE,length(x))
  else if(is.character(x))
    (if(.R.)
     x!="" & x!=" " & !is.na(x)
    else
     x!="" & x!=" ")
  else
    !is.na(x)
  
  present <- present & !is.na(weights)
  
  if(length(weights) != length(x))
    stop('length of weights must equal length of x')

  if(normwt) {
    weights <- sum(present)*weights/sum(weights[present])
    n <- sum(present)
  } else {
    n <- sum(weights[present])
  }
  
  if(exclude.missing && n==0) {
    return(structure(NULL, class="describe"))
  }
  
  missing <- sum(weights[!present], na.rm=TRUE)
  atx <- attributes(x)
  atx$names <- atx$dimnames <- atx$dim <- atx$special.miss <- NULL  
  
  atx$class <- atx$class[atx$class!='special.miss']
  
  isdot <- testDateTime(x,'either') # is date or time var
  isdat <- testDateTime(x,'both')   # is date and time combo var

  x <- x[present,drop=FALSE]
  x.unique <- sort(unique(x))
  weights <- weights[present]

  n.unique <- length(x.unique)
  attributes(x) <- attributes(x.unique) <- atx

  isnum <- (is.numeric(x) || isdat) && !is.category(x)
  timeUsed <- isdat && testDateTime(x.unique, 'timeVaries')

  z <- list(descript=descript, units=un, format=fmt)

  counts <- c(n,missing)
  lab <- c("n","missing")

  if(length(special.codes)) {
    tabsc <- table(special.codes)
    counts <- c(counts, tabsc)
    lab <- c(lab, names(tabsc))
  }
  
  if(length(atx$imputed)) {
    counts <- c(counts, length(atx$imputed))
    lab <- c(lab, "imputed")
  }
  
  if(length(pd <- atx$partial.date)) {
    if((nn <- length(pd$month))>0) {
      counts <- c(counts, nn)
      lab <- c(lab,"missing month")
    }
    
    if((nn <- length(pd$day))>0) {
      counts <- c(counts, nn)
      lab <- c(lab,"missing day")
    }
    
    if((nn <- length(pd$both))>0) {
      counts <- c(counts, nn)
      lab <- c(lab,"missing month,day")
    }
  }

  if(length(atx$substi.source)) {
    tabss <- table(atx$substi.source)
    counts <- c(counts, tabss)
    lab <- c(lab, names(tabss))
  }

  counts <- c(counts,n.unique)
  lab <- c(lab,"unique")
  x.binary <- n.unique==2 && isnum && x.unique[1]==0 && x.unique[2]==1
  if(x.binary) {
    counts <- c(counts,sum(weights[x==1]))
    lab <- c(lab,"Sum")
  }
  
  if(isnum) {
    xnum <- if(.SV4.) as.numeric(x) else oldUnclass(x)
    
    if(isdot) {
      dd <- sum(weights*xnum)/sum(weights)
      fval <- formatDateTime(dd, atx, !timeUsed)
      counts <- c(counts, fval)
    } else {
      counts <- c(counts,format(sum(weights*x)/sum(weights),...))
    }
    
    lab <- c(lab,"Mean")
  } else if(n.unique==1) {
    counts <- c(counts, x.unique)
    lab <- c(lab, "value")
  }

  if(n.unique>=10 & isnum) {
    q <-
      if(any(weights != 1)) {
        wtd.quantile(xnum,weights,normwt=FALSE,na.rm=FALSE,  # 3Dec00
                     probs=c(.05,.1,.25,.5,.75,.90,.95))
      } else {
        quantile(xnum,c(.05,.1,.25,.5,.75,.90,.95),na.rm=FALSE)
      }
    ## Only reason to call quantile is that the two functions can give
    ## different results if there are ties, and users are used to quantile()
    fval <-
      if(isdot)
        formatDateTime(q, atx, !timeUsed)
      else
        format(q,...)
    
    counts <- c(counts, fval)
    lab <- c(lab,".05",".10",".25",".50",".75",".90",".95")
  }
  names(counts) <- lab
  z$counts <- counts

  counts <- NULL

  tableIgnoreCaseWhiteSpace <- function(x) {
    x <- gsub('\r',' ',x)
    x <- gsub('^[[:space:]]+','',gsub('[[:space:]]+$','', x))
    x <- gsub('[[:space:]]+',' ', x)
    y <- tolower(x)
    f <- table(y)
    names(f) <- x[match(names(f), y)]
    f
  }

  if(inherits(x,'mChoice')) z$mChoice <- summary(x, minlength=minlength) else {
    if(n.unique <= listunique && !isnum && !is.category(x) &&
       max(nchar(x)) > listnchar) counts <- tableIgnoreCaseWhiteSpace(x) else {
      if(n.unique>=20) {
        if(isnum) {
          r <- range(xnum)
          xg <- pmin(1 + floor((100 * (xnum - r[1]))/
                               (r[2] - r[1])), 100)
          z$intervalFreq <- list(range=as.single(r),
                                 count = as.integer(tabulate(xg)))
        }
        
        loandhi <- x.unique[c(1:5,(n.unique-4):n.unique)]
        fval <-
          if(isdot && (class(loandhi) %nin% 'timeDate')) {
            formatDateTime(oldUnclass(loandhi), at=atx, roundDay=!timeUsed)
          } else format(format(loandhi), ...)
        counts <- fval
        names(counts) <- c("L1","L2","L3","L4","L5","H5","H4","H3","H2","H1")
      }

      if(n.unique>1 && n.unique<20 && !x.binary) {
        tab <- wtd.table(if(isnum && isdat) format(x) else x,
                         weights, normwt=FALSE, na.rm=FALSE, type='table')

        pct <- round(100*tab/sum(tab))
        counts <- t(as.matrix(tab))
        counts <- rbind(counts, pct)
        dimnames(counts)[[1]]<- c("Frequency","%")
      }
    }
  }
  z$values <- counts
  structure(z, class="describe")
}


describe.matrix <- function(x, descript, exclude.missing=TRUE,
                            digits=4, ...)
{
  if(missing(descript))
    descript <- as.character(sys.call())[2]

  nam <- dimnames(x)[[2]]
  if(length(nam)==0)
    stop('matrix does not have column names')

  Z <- vector('list', length(nam))
  names(Z) <- nam

  d <- dim(x)
  missing.vars <- NULL
  for(i in 1:ncol(x)) {
    z <- describe.vector(x[,i],nam[i],exclude.missing=exclude.missing,
                         digits=digits,...)  #13Mar99
    Z[[i]] <- z
    if(exclude.missing && length(z)==0)
      missing.vars <- c(missing.vars,nam[i]) 
  }

  attr(Z, 'descript') <- descript
  attr(Z, 'dimensions') <- d
  attr(Z, 'missing.vars') <- missing.vars
  structure(Z, class="describe")
}


describe.data.frame <- function(x, descript, exclude.missing=TRUE,
                                digits=4, ...)
{
  if(missing(descript))
    descript <- as.character(sys.call())[2]

  nam <- names(x)
  Z <- list()
  nams <- character(0)

  i <- 0
  missing.vars <- NULL
  for(xx in x) {
    mat <- is.matrix(xx)
    i <- i+1
    z <-
      if(mat) 
        describe.matrix(xx,nam[i],exclude.missing=exclude.missing,
                        digits=digits,...)
      else	  
        describe.vector(xx,nam[i],exclude.missing=exclude.missing,
                        digits=digits,...)  #13Mar99
    
    all.missing <- length(z)==0
    if(exclude.missing && all.missing)
      missing.vars <- c(missing.vars, nam[i])
    else {
      Z <- c(Z, if(mat) z else list(z))
      nams <- c(nams, if(mat) names(z) else nam[i])
    }
  }
  names(Z) <- nams

  attr(Z, 'descript') <- descript
  attr(Z, 'dimensions') <- dim(x)
  attr(Z, 'missing.vars') <- missing.vars
  structure(Z, class="describe")
}


describe.formula <- function(x, descript, data, subset, na.action, 
                             digits=4, weights, ...)
{
  mf <- match.call(expand=FALSE)
  mf$formula <- x
  mf$x <- mf$descript <- mf$file <- mf$append <- mf$... <- mf$digits <- NULL
  if(missing(na.action))
    mf$na.action <- na.retain
  
  mf[[1]] <- as.name("model.frame")
  mf <- eval(mf, sys.parent())
  weights <- model.extract(mf, weights)
		
  if(missing(descript)) {
    ter <- attr(mf,"terms")
    d <- as.character(x)
    if(attr(ter,"response")==1)
      d <- c(d[2],d[1],d[-(1:2)])
    else
      d <- d[-1]
    d <- paste(d, collapse=" ")
    descript <- d
  }

  Z <- describe.data.frame(mf, descript, digits=digits, weights=weights, ...)
  if(length(z <- attr(mf,"na.action")))
    attr(Z,'naprint') <- naprint(z) 

  Z
}

na.retain <- function(d) d


print.describe <- function(x, condense=TRUE, ...)
{
  at <- attributes(x)
  if(length(at$dimensions)) {
    cat(at$descript,'\n\n',at$dimensions[2],' Variables     ',at$dimensions[1],
        ' Observations\n')
    
    if(length(at$naprint)) cat('\n',at$naprint,'\n')
    cat('---------------------------------------------------------------------------\n')
    for(z in x) {
      if(length(z)==0)
        next
      print.describe.single(z, condense=condense)
      cat('---------------------------------------------------------------------------\n')
    }
    if(length(at$missing.vars)) {
      cat('\nVariables with all observations missing:\n\n')
      print(at$missing.vars, quote=FALSE)
    }
  } else print.describe.single(x, condense=condense)
  
  invisible()
}

print.describe.single <- function(x, condense=TRUE, ...)
{
  wide <- .Options$width
  des <- x$descript
  if(length(x$units))
    des <- paste(des, ' [', x$units, ']', sep='')
  
  if(length(x$format))
    des <- paste(des, '  Format:', x$format, sep='')
  
  cat(des,'\n')
  print(x$counts, quote=FALSE)
  val <- x$values
  if(length(val)) {
    if(!is.matrix(val)) {
      if(length(val)!=10 || !all(names(val)==
                 c("L1","L2","L3","L4","L5","H5","H4","H3","H2","H1"))) {
        cat('\n')
        val <- paste(names(val),
                     ifelse(val > 1, paste(' (', val, ')', sep=''), ''),
                     sep='')
        cat(strwrap(val, exdent=4), sep='\n')
      } else {
        if(condense) {
          low <- paste('lowest :', paste(val[1:5],collapse=' '))
          hi  <- paste('highest:', paste(val[6:10],collapse=' '))
          cat('\n',low,sep='')
          if(nchar(low)+nchar(hi)+2>wide) cat('\n') else cat(', ')
          cat(hi,'\n')
        } else {
          cat('\n'); print(val, quote=FALSE)
        }
      }
    } else {
      lev <- dimnames(val)[[2]]
      if(condense && (mean(nchar(lev))>10 | length(lev) < 5)) {
        z <- ''; len <- 0; cat('\n')
        for(i in 1:length(lev)) {
          w <- paste(lev[i], ' (', val[1,i], ', ', val[2,i], '%)', sep='')
          l <- nchar(w)
          if(len + l + 2 > wide) {
            cat(z,'\n'); len <- 0; z <- ''
          }
          
          if(len==0) {
            z <- w; len <- l
          } else {
            z <- paste(z, ', ', w, sep=''); len <- len + l + 2
          }
        }
        
        cat(z, '\n')
      } else {
        cat('\n'); print(val, quote=FALSE)
      }
    }
  }
  if(length(x$mChoice)) {cat('\n'); print(x$mChoice, prlabel=FALSE)}
  
  invisible()
}


'[.describe' <- function(object, i, ...)
{
  at <- attributes(object)
  object <- '['(oldUnclass(object),i)
  structure(object, descript=at$descript,
            dimensions=c(at$dimensions[1], length(object)),
            class='describe')
}


latex.describe <-
  function(object, title=NULL, condense=TRUE,
           file=paste('describe',
             first.word(expr=attr(object, 'descript')),
             'tex', sep='.'),
           append=FALSE, size='small',
           tabular=TRUE, greek=TRUE, ...)
{
  at <- attributes(object)
  ct <- function(..., file, append=FALSE)
  {
    if(file=='')
      cat(...)
    else
      cat(..., file=file, append=append)
    
    invisible()
  }
  
  ct('\\begin{spacing}{0.7}\n', file=file, append=append)
  if(length(at$dimensions)) {
    ct('\\begin{center}\\textbf{', latexTranslate(at$descript), '\\\\',
       at$dimensions[2],'Variables~~~~~',at$dimensions[1],
       '~Observations}\\end{center}\n', file=file, append=TRUE)
    if(length(at$naprint))
      ct(at$naprint,'\\\\\n', file=file, append=TRUE)
    
    ct('\\vspace{-.5ex}\\hrule\\smallskip{\\',size,'\n',
       sep='', file=file, append=TRUE)
    vnames <- at$names
    i <- 0
    for(z in object) {
      i <- i + 1
      if(length(z)==0)
        next

      val <- z$values
      potentiallyLong <-
        length(val) && !is.matrix(val) &&
           length(val) != 10 || !all(names(val)==
                   c("L1","L2","L3","L4","L5","H5","H4","H3","H2","H1"))
      if(!potentiallyLong) cat('\\vbox{', file=file, append=TRUE)

      latex.describe.single(z, condense=condense, vname=vnames[i],
                            file=file, append=TRUE,
                            tabular=tabular, greek=greek)
      ct('\\vspace{-.5ex}\\hrule\\smallskip\n', file=file, append=TRUE)
      if(!potentiallyLong) cat('}\n', file=file, append=TRUE)
    }
    
    if(length(mv <- at$missing.vars)) {
      ct('\\smallskip\\noindent Variables with all observations missing:\\ \\smallskip\n',
         file=file, append=TRUE)
      mv <- latexTranslate(mv)
      mv <- paste('\\texttt{',mv,'}',sep='')
      mv <- paste(mv, collapse=', ')
      ct(mv, file=file, append=TRUE)
    }
    ct('}\\end{spacing}\n', file=file, append=TRUE)
  }
  else
    {
      val <- object$values
      potentiallyLong <-
        length(val) && !is.matrix(val) &&
        length(val) != 10 || !all(names(val)==
                c("L1","L2","L3","L4","L5","H5","H4","H3","H2","H1"))
      if(!potentiallyLong) cat('\\vbox{', file=file, append=TRUE)
      latex.describe.single(object,
                            vname=first.word(expr=at$descript),
                            condense=condense,
                            file=file, append=TRUE, size=size,
                            tabular=tabular)
      if(!potentiallyLong) cat('}\n', file=file, append=TRUE)
      ct('\\end{spacing}\n', file=file, append=TRUE)
    }

  structure(list(file=file,  style=c('setspace','relsize')),
            class='latex')
}


latex.describe.single <-
  function(object, title=NULL, condense=TRUE, vname,
           file, append=FALSE, size='small',
           tabular=TRUE, greek=TRUE, ...)
{
  ct <- function(..., file, append=FALSE)
    {
      if(file=='')
        cat(...)
      else
        cat(..., file=file, append=append)
      
      invisible()
    }
  
  oldw <- options(width=85)
  on.exit(options(oldw))
  
  wide <- switch(size,
                 normalsize=66,
                 small=73,
                 scriptsize=93,
                 73)

  intFreq <- object$intervalFreq

  ## Put graph on its own line if length of label > 3.5 inches
  ## For normalsize there are 66 characters per 4.8 in. standard width

  z   <- latexTranslate(object$descript, '&', '\\&', greek=greek)
  ## If any math mode ($ not preceeded by \) don't put label part in bold
  des <- if(!length(grep('[^\\]\\$', z)))
    paste('\\textbf{', z, '}', sep='')
  else {
    ## Get text before : (variable name)
    sp <- strsplit(z, ' : ')[[1]]
    vnm <- sp[1]
    rem <- paste(sp[-1], collapse=':')
    paste('\\textbf{', vnm, '}: ', rem, sep='')
  }
  
  if(length(object$units))
    des <- paste(des, '{\\smaller[1] [',
                 latexTranslate(object$units),']}', sep='')
  
  if(length(object$format))
    des <- paste(des, '{\\smaller~~Format:', latexTranslate(object$format),
                 '}', sep='')
  
  desbas <- paste(object$descript,
                  if(length(object$units))
                  paste(' [', object$units, ']', sep=''),
                  if(length(object$format))
                  paste('  Format:', object$format, sep=''))
  
  ct('\\noindent', des, sep='', file=file, append=append)
  if(length(intFreq)) {
    counts <- intFreq$count
    maxcounts <- max(counts)
    ## \mbox{~~~} makes \hfill work
    ct(if(nchar(desbas)/(wide/4.8) > (4.8-1.5))' \\\\ \\mbox{~~~} \n',
       '\\setlength{\\unitlength}{0.001in}\\hfill',
       '\\begin{picture}(1.5,.1)(1500,0)',
       '\\linethickness{0.6pt}\n', sep='', file=file, append=TRUE)
    for(i in (1:100)[counts > 0]) {
      ct('\\put(',round(1000*(i-1)*1.5/100),',0){\\line(0,1){',
         max(1,round(1000*counts[i]/maxcounts*.1)),'}}\n',
         sep='', file=file, append=TRUE)
    }
    
    ct('\\end{picture}\n', file=file, append=TRUE)
  } else ct('\n', file=file, append=TRUE)
  
  sz <- ''
  if(tabular) {
    ml <- nchar(paste(object$counts,collapse='  '))
    if(ml > 90)
      tabular <- FALSE
    else if(ml > 80)
      sz <- '[2]'
  }
  
  ct('\n{\\smaller', sz, '\n', sep='', file=file, append=TRUE)
  if(tabular) {
    ct('\\begin{tabular}{',
       paste(rep('r',length(object$counts)),collapse=''),'}\n',
       file=file, append=TRUE)
    ct(paste(names(object$counts), collapse='&'), '\\\\ \n',
       file=file, append=TRUE)
    ct(paste(object$counts, collapse='&'), '\\end{tabular}\n',
       file=file, append=TRUE)
  }
  
  if(file!='')
    sink(file, append=TRUE)

  verb <- 0
  if(!tabular) {
    cat('\\begin{verbatim}\n'); verb <- 1
    print(object$counts, quote=FALSE)
  }

  val <- object$values
  if(length(val)) {
    if(!is.matrix(val)) {
      if(length(val) != 10 || !all(names(val)==
                 c("L1","L2","L3","L4","L5","H5","H4","H3","H2","H1")))
        {
          if(verb) {cat('\\end{verbatim}\n'); verb <- 0}
          cat('\\\\ \\smallskip\n\n')
          val <- paste('{\\hangafter=1\\hangindent=3ex\\noindent ',
                       latexTranslate(names(val)),
                       ifelse(val > 1, paste(' (', val, ')', sep=''),''),
                       '\n\n}\n', sep='')
          cat(val, sep='\n')
          cat('\\smallskip\n')
        }
      else {
        if(condense) {
          low <- paste('lowest :', paste(val[1:5],collapse=' '))
          hi  <- paste('highest:', paste(val[6:10],collapse=' '))
          if(!verb) {cat('\\begin{verbatim}\n'); verb <- 1}
          cat('\n',low,sep='')
          if(nchar(low)+nchar(hi)+2 > wide) cat('\n') else cat(', ')
          cat(hi,'\n')
        } else {
          cat('\n'); print(val, quote=FALSE)
        }
      }
    } else {
      lev <- dimnames(val)[[2]]
      if(condense && (mean(nchar(lev))>10 | length(lev) < 5)) {
        if(!verb) {cat('\\begin{verbatim}\n'); verb <- 1}
        z <- ''; len <- 0; cat('\n')
        for(i in 1:length(lev)) {
          w <- paste(lev[i], ' (', val[1,i], ', ', val[2,i], '%)', sep='')
          l <- nchar(w)
          if(len + l + 2 > wide) {
            cat(z,'\n'); len <- 0; z <- ''
          }
          
          if(len==0) {
            z <- w; len <- l
          } else {
            z <- paste(z, ', ', w, sep=''); len <- len + l + 2
          }
        }
        
        cat(z, '\n')
      } else {
        cat('\n');
        if(!verb) {cat('\\begin{verbatim}\n'); verb <- 1}
        print(val, quote=FALSE)
      }
    }
  }
  if(length(object$mChoice)) {
    if(!verb) {cat('\\begin{verbatim}\n'); verb <- 1}
    print(object$mChoice, prlabel=FALSE)
  }
  
  if(verb) cat('\\end{verbatim}\n')
  cat('}\n')
  if(file!='')
    sink()
  
  invisible()
}


if(FALSE && .SV4.) {
  setMethod('latex', 'describe', latex.describe)
  remove('latex.describe')
}


dataDensityString <- function(x, nint=30)
{
  x <- as.numeric(x)
  x <- x[!is.na(x)]
  if(length(x) < 2) return('')
  r <- range(x)
  x <- floor(nint * (x-r[1])/(r[2]-r[1]))
  x <- pmin(tabulate(x), 37)
  paste(format(r[1]),' <',
        paste(substring(' 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ',
                        x+1,x+1), collapse=''),
        '> ',format(r[2]),sep='')
}


## Unused code from latex.describe.single
if(FALSE && length(intFreq))
{
  psthere <- TRUE
  psfile <- paste(psBase,vname,'.ps',sep='')
  x <- seq(intFreq$range[1], intFreq$range[2], length=100)
  counts <- intFreq$count
  oldopt <- options(warn=-1)
  if(under.unix)
    postscript(file = psfile, horizontal = FALSE,
               width = 1.5, height = .1, 
               maximize = TRUE,
               onefile = FALSE, print.it = FALSE)
  else
    postscript(file = psfile, horizontal = FALSE,
               width=1.5, height=.1)
  
  oldpar <- par(mar=rep(0,4),oma=rep(0,4))  # add mex=.5 to prevent
                                            # error msgs.  Need this
  
  ## in 2nd par call.
  on.exit(par(oldpar))
  options(oldopt)
  plot(x, freqFun(counts), type='n', axes=FALSE, xlab='', ylab='')
  j <- counts > 0
  segments(x[j], 0, x[j], freqFun(counts[j]))
  dev.off()
}


contents <- function(object, ...) UseMethod('contents')


contents.data.frame <- function(object, ...)
{
  dfname <- deparse(substitute(object))
  nam <- names(object)
  d <- dim(object)
  n <- length(nam)
  fl <- nas <- integer(n)
  cl <- sm <- lab <- un <- longlab <- character(n)
  Lev <- list()
  for(i in 1:n) {
    x <- object[[i]]
    at <- attributes(x)
    if(length(at$label))
      lab[i] <- at$label
    if(length(at$longlabel))
      longlab[i] <- at$longlabel
    
    if(length(at$units))
      un[i] <- at$units
    
    atl <- at$levels
    fl[i] <- length(atl)
    cli <- at$class[at$class %nin% c('labelled','factor')]
    if(length(cli))
      cl[i] <- cli[1]
    
    sm[i] <- storage.mode(x)
    nas[i] <- sum(is.na(x))
    if(length(atl))
    {
      if(length(Lev)) for(j in 1:length(Lev))
        {
          w <- Lev[[j]]
          if(!is.name(w) && is.logical(all.equal(w, atl)))
            {
              atl <- as.name(names(Lev)[j])
              break   
            }
        }
      Lev[[nam[i]]] <- atl
    }
  }
  
  w <- list(Labels=if(any(lab!=''))         lab,
            Units=if(any(un!=''))           un,
            Levels=if(any(fl>0))            fl,
            Class=if(any(cl!=''))           cl,
            Storage=                        sm,
            NAs=if(any(nas>0))              nas )
  
  if(.R.)
    w <- w[sapply(w, function(x)length(x)>0)]
  
  ## R does not remove NULL elements from a list
  structure(list(contents=data.frame(w, row.names=nam),
                 dim=d, maxnas=max(nas), dfname=dfname,
                 Levels=Lev,
                 longLabels=if(any(longlab!='')) structure(longlab, names=nam)),
            class='contents.data.frame')
}


print.contents.data.frame <-
  function(x, sort=c('none','names','labels','NAs'), prlevels=TRUE, ...)
{
  sort <- match.arg(sort)
  d <- x$dim
  maxnas <- x$maxnas
  cat('\nData frame:',x$dfname,'\t',d[1],' observations and ',d[2],
      ' variables    Maximum # NAs:',maxnas,'\n\n',sep='')
  cont <- x$contents
  nam <- row.names(cont)

  switch(sort,
         names={
           cont <- cont[order(nam),]
         },
         labels={
           if(length(cont$Labels)) 
             cont <-  cont[order(cont$Labels, nam),]
         },
         NAs={
           if(maxnas>0)
             cont <- cont[order(cont$NAs,nam),]
         })

  if(length(cont$Levels))
    cont$Levels <- ifelse(cont$Levels==0,'',format(cont$Levels))
  
  print(cont)

  if(prlevels && length(L <- x$Levels)) {
    cat('\n')
    nam <- names(L)
    w <- .Options$width-max(nchar(nam))-5
    reusingLevels <- sapply(L, is.name)
    fullLevels <- which(!reusingLevels)
    namf <- lin <- names(L[fullLevels])
    ## separate multiple lines per var with \n for print.char.matrix
    j <- 0
    for(i in fullLevels)
      {
        j <- j + 1
        varsUsingSame <- NULL
        if(sum(reusingLevels))
          {
            for(k in which(reusingLevels)) if(L[[k]] == nam[j]) 
              varsUsingSame <- c(varsUsingSame, nam[k])
            if(length(varsUsingSame))
              namf[j] <- paste(c(namf[j], varsUsingSame), collapse='\n')
          }
        lin[j] <- paste(pasteFit(L[[i]], width=w), collapse='\n')
      }
    if(.R.) {
      z <- cbind(Variable=namf, Levels=lin)
      print.char.matrix(z, col.txt.align='left', col.name.align='left',
                        row.names=TRUE, col.names=TRUE)
    } else print.char.matrix(matrix(lin,ncol=1,
                                    dimnames=list(nam,'Levels')))
  }
  
  longlab <- x$longLabels
  if(length(longlab)) {
    if(existsFunction('strwrap'))
      for(i in 1:length(longlab)) {
        if(longlab[i] != '')
          longlab[i] <- paste(strwrap(longlab[i],width=.85*.Options$width ),
                              collapse='\n')
      }
    i <- longlab != ''
    nam <- names(longlab)
    z <- cbind(Variable=nam[i], 'Long Label'=longlab[i])
    print.char.matrix(z, col.names=TRUE, row.names=FALSE,
                      cell.align='left')
  }
  
  invisible()
}


html.contents.data.frame <-
  function(object, sort=c('none','names','labels','NAs'), prlevels=TRUE,
           file=paste('contents',object$dfname,'html',sep='.'),
           levelType=c('list','table'),
           append=FALSE, ...)
{
  sort <- match.arg(sort)
  levelType <- match.arg(levelType)
  d <- object$dim
  maxnas <- object$maxnas
  cat('<hr><h2>Data frame:',object$dfname,
      '</h2>',d[1],
      ' observations and ',d[2],
      ' variables, maximum # NAs:',maxnas,'<hr>\n',sep='',
      file=file, append=append)
  cont <- object$contents
  nam <- row.names(cont)

  switch(sort,
         names={cont <- cont[order(nam),]},
         labels={
           if(length(cont$Labels)) 
             cont <-  cont[order(cont$Labels, nam),]
         },
         NAs={
           if(maxnas>0) cont <- cont[order(cont$NAs,nam),]
         })
  
  link <- matrix('', nrow=nrow(cont), ncol=1+ncol(cont),
                 dimnames=list(dimnames(cont)[[1]], c('Name', dimnames(cont)[[2]])))
  
  longlab <- object$longLabels
  if(length(longlab)) {
    longlab <- longlab[longlab!='']
    link[names(longlab),'Name'] <- paste('#longlab',names(longlab),sep='.')
  }
  
  L <- object$Levels
  Lnames <- names(L)
  if(length(cont$Levels)) {
    cont$Levels <- ifelse(cont$Levels==0, '', format(cont$Levels))
    namUsed     <- sapply(L, function(z) if(is.name(z)) as.character(z) else '')
    reusingLevels <- namUsed != ''
    fullLevels  <- which(!reusingLevels)
    namUsed     <- ifelse(reusingLevels, namUsed, Lnames)
    names(namUsed) <- Lnames
    link[,'Levels'] <- ifelse(cont$Levels=='', '', paste('#levels',namUsed[nam],sep='.'))
  }
  adj <- rep('l', length(cont))
  adj[names(cont) %in% c('NAs','Levels')] <- 'r'
  out <- html(cont, file=file, append=TRUE,
              link=link,
              col.just=adj, ...)
  
  cat('<hr>\n', file=file, append=TRUE)
  
  if(prlevels && length(L))
    {
      if(levelType=='list')
        {
          cat('<h2 align="center">Category Levels</h2>\n', file=file, append=TRUE)
          for(i in fullLevels) 
            {
              l <- L[[i]]
              nami <- Lnames[i]
              w <- nami
              if(sum(reusingLevels))
                for(k in which(reusingLevels))
                  if(L[[k]] == nami) w <- c(w, Lnames[k])
              cat('<a name="levels.',nami,'"><h3>',
                  paste(w, collapse=', '), '</h3>\n', sep='', 
                  file=file, append=TRUE)
              cat('<ul>\n', file=file, append=TRUE)
              for(k in l) cat('<li>', k, '</li>\n', sep='',
                              file=file, append=TRUE)
              cat('</ul>\n', file=file, append=TRUE)
            }
        }
      else
        {  
          ## Function to split a character vector x as evenly as
          ## possible into n elements, pasting multiple elements
          ## together when needed
          evenSplit <- function(x, n)
            {
              indent <- function(z) if(length(z)==1)z else
              c(z[1], paste('&nbsp&nbsp&nbsp',z[-1],sep=''))
              m <- length(x)
              if(m <= n) return(c(indent(x), rep('',n-m)))
              totalLength <- sum(nchar(x)) + (m-1)*3.5
              ## add indent, comma, space
              lineLength  <- ceiling(totalLength/n)
              y <- pasteFit(x, sep=', ', width=lineLength)
              m <- length(y)
              if(m > n) for(j in 1:10)
                {
                  lineLength <- round(lineLength*1.1)
                  y <- pasteFit(x, sep=', ', width=lineLength)
                  m <- length(y)
                  if(m <= n) break
                }
              ## Take evasive action if needed
              if(m==n) indent(y) else if(m < n)
                c(indent(y), rep('', n-m)) else 
              c(paste(x, collapse=', '), rep('',n-1))
            }
          nam <- names(L)
          v <- lab <- lev <- character(0)
          j <- 0
          for(i in fullLevels) 
            {
              j <- j + 1
              l <- L[[i]]
              nami <- nam[i]
              v <- c(v, nami)
              w <- nami
              if(sum(reusingLevels))
                for(k in which(reusingLevels)) if(L[[k]] == nam[i]) w <- c(w, nam[k])
              lab <- c(lab, evenSplit(w, length(l)))
              lev <- c(lev, l)
            }
          z <- cbind(Variable=lab, Levels=lev)
          out <- html(z, file=file, append=TRUE,
                      link=ifelse(lab=='','',paste('levels',v,sep='.')),
                      linkCol='Variable', linkType='name', ...)
          cat('<hr>\n',file=file,append=TRUE)
        }
    }

  i <- longlab != ''
  if(any(i)) {
    nam <- names(longlab)[i]
    names(longlab) <- NULL
    lab <- paste('longlab', nam, sep='.')
    z <- cbind(Variable=nam, 'Long Label'=longlab[i])
    out <- html(z, file=file, append=TRUE,
                link=lab, linkCol='Variable', linkType='name', ...)
    cat('<hr>\n', file=file, append=TRUE)
  }
  out
}


contents.list <- function(object, dslabels=NULL, ...)
{
  nam <- names(object)
  if(length(dslabels)) {
    dslabels <- dslabels[nam]
    names(dslabels) <- NULL
  }
  
  g <- function(w)
  {
    if(length(w)==0 || is.null(w))
      c(Obs=0, Var=if(is.null(w))
                     NA
                   else
                     length(w),
        Var.NA=NA)
    else
      c(Obs=length(w[[1]]), Var=length(w),
        Var.NA=sum(sapply(w, function(x) sum(is.present(x))==0)))
  }
  
  v <- t(sapply(object, g))
  structure(list(contents=if(length(dslabels))
                            data.frame(Label=dslabels,Obs=v[,'Obs'],
                                       Var=v[,'Var'],Var.NA=v[,'Var.NA'],
                                       row.names=nam)
                          else
                            data.frame(Obs=v[,'Obs'],Var=v[,'Var'],
                                       Var.NA=v[,'Var.NA'], row.names=nam)),
            class='contents.list')
}


print.contents.list <-
  function(x, sort=c('none','names','labels','NAs','vars'), ...)
{
  sort <- match.arg(sort)
  cont <- x$contents
  nam <- row.names(cont)

  cont <- cont[
               switch(sort,
                      none=1:length(nam),
                      names=order(nam),
                      vars=order(cont$Var),
                      labels=order(cont$Label, nam),
                      NAs=order(cont$Var.NA,nam)),]

  print(cont)
  invisible()
}
do <- function(condition, expressions, device=NULL, file, append=FALSE,
               multiplot=FALSE, ...)
{
  if(!condition)
    return(invisible())

  ## The following function is courtesy of Bill Dunlap, StatSci
  strip.comments <- function(expr)
  {
    if (mode(expr) == "comment.expression") {
      not.comment <- sapply(expr, function(ei)mode(ei)!="comment")
      if (sum(not.comment)!=1)
        stop("unexpected result: no non-comment in expression")
      else {
        Recall(expr[not.comment][[1]])
      }
    } else expr
  }

  condition <- as.character(substitute(condition))
  scondition <-
    if(under.unix)
      condition
    else
      substring(sedit(condition, '.', ''), 1,8)
  
  pcondition <-
    if(multiplot)
      substring(scondition,1,7)
    else
      scondition

  do.file <-
    if(missing(file)) {
      if(length(ds <- .Options$do.file)==0)
        ''
      else
        ds
    } else file

  do.prefix <- .Options$do.prefix

  if(do.file!='') {
    if(do.file=='condition') 
      sink(sink.file <- paste(if(length(do.prefix))
                              paste(do.prefix,if(under.unix)'.' else '/',sep=''), 
                              paste(scondition, 'lst',sep='.'), 
                              sep=''), append=append)
    else
      sink(sink.file <- paste(do.file, '.lst',sep=''), append=append)
  }

  if(missing(device))
    device <- .Options$do.device

  if(length(device)) {
    suffix <-
      if(device %in% c('postscript','ps','ps.slide'))
        'ps'
      else if(device %in% c('win.slide','win.printer'))
        'wmf'
      else
        'gr'
    
    file <- paste(if(length(do.prefix))
                    paste(do.prefix,
                          if(under.unix)
                            '.'
                          else
                            '/',
                          sep=''),
                  if(device!='ps.slide' && device!='win.slide')
                    paste(pcondition, suffix, sep='.')
                  else
                    pcondition,
                  sep='')
    
    if(multiplot) {
      if(under.unix)
        stop('multiplot=T not meaningful under UNIX')
      
      if(!(device %in% c('win.slide','win.printer')))
        stop('multiplot only meaningful for device=win.slide,win.printer')
      
      file <- paste(file,'#',sep='')
    }
    
    get(device)(file, ...)
  }

  do.echo <- .Options$do.echo
  if(length(do.echo)==0)
    do.echo <- TRUE

  do.comments <- .Options$do.comments
  if(length(do.comments)==0)
    do.comments <- FALSE

  invis.fctns <- c('plot','lines','points','abline','text','mtext','title',
                   'impute', 'survplot')
  
  ## generic functions whose body ends in UseMethod but are invisible
  ## this list should grow
  for(ex in substitute(expressions)) {
    lv <- eval(ex, local=1)
    exs <- strip.comments(ex)
    m <- mode(exs)
    if(m == 'name' ||
       (m=='call' &&
        (length(exs$pl)==0 ||
         (is.logical(exs$pl) && !exs$pl)))) {
      ## some functions called to plot (pl=T) - don't auto print results
      inv <-
        if(m != 'call')
          FALSE
        else  {
          ## see if expression is call to function
          ## with body ending in invisible()
	  ex1 <- as.character(exs[1])
	  inv <-
            if(any(ex1==invis.fctns))
              TRUE
            else if(exists(ex1, mode='function')) {
              f <- get(ex1, mode='function')
              f <- f[[length(f)]]
              f1 <- as.character(f)[1]
              if(f1=='invisible' || f1=='.Cur.pic')
                TRUE
              else {
                m <- mode(f)
                if(m=='{') {
                  f <- f[[length(f)]];
                  f1 <- as.character(f)[1]
                }
                
                f1=='invisible' || f1=='.Cur.pic'
              }
            } else FALSE
	}
      
      if(!inv) {
        if(do.echo) {
          cat('\n');
          dput(if(do.comments)
                 ex
               else
                 exs);
          cat('\n')
        }
        
        print(lv)
      }
    }
  }

  if(length(device))
    dev.off()

  if(do.file!='') {
    sink()
    cat('Print output ',
        if(append)
          'appended'
        else
          'written',
        ' to file "', sink.file, '".\n', sep='')
    
    all.files <- unique(c(.Options$.all.do.files, sink.file))
    options(.all.do.files=all.files, TEMPORARY=FALSE)
    if(under.unix) {
      pwd.home <- unix('pwd;echo $HOME')
      cat('$1', paste(paste(pwd.home[1],all.files,sep='/'), collapse=' '),' &\n',
          file=paste(pwd.home[2],'/.lst',sep=''))
      unix('chmod +x $HOME/.lst')
    }
  }

  invisible()
}
dot.chart<-function(z, major, minor, fun = mean, subset, pch=18, mkh=.035,
                    cex=.5, xlab = label(z), prt=TRUE, ...)
{
  count <- function(ww) sum(!is.na(ww))

  xl<-xlab
  
  ## Note: dotchart does not pass the following parameters to points and mtext
  oldpar<-par(mkh=mkh, cex=cex)
  if(!missing(subset)) {
    z <- z[subset]
    major <- major[subset]
    if(!missing(minor))
      minor <- minor[subset]
  }
  
  major<-as.category(major)
  if(missing(minor)) {
    tabl <- tapply(z, list(major), fun)
    tabln <- tapply(z, list(major), count)
    names(tabl) <- levels(major)
    names(tabln) <- levels(major)
    cmajor <- category(row(tabl), label=levels(major))
    dotchart(tabl, labels=levels(cmajor)[cmajor], xlab="", pch=pch,
             ...)
  } else {
    minor<-as.category(minor)
    tabl <- tapply(z, list(major, minor), fun)
    tabln <- tapply(z, list(major, minor), count)
    dimnames(tabl) <- list(levels(major),levels(minor))
    dimnames(tabln) <- list(levels(major),levels(minor))
    cminor <- category(col(tabl), label = levels(minor))
    cmajor <- category(row(tabl), label = levels(major))
    dotchart(tabl, labels = levels(cminor)[cminor], groups = cmajor, 
             xlab = "", pch=pch,  ...)
  }
  
  par(oldpar)
  if(xl!="" & xl!=" ")
    title(xlab=xl)

  if(prt) {
    print(xl,quote=FALSE)
    print(tabl,digits=4)
    print("------- n -------",quote=FALSE)
    print(tabln)
  }

  invisible()
}
Ecdf <- function(x, ...) UseMethod('Ecdf')


Ecdf.default <- function(x, what=c('F','1-F','f'), 
                         weights=rep(1,length(x)), normwt=FALSE,
                         xlab, ylab, q, pl=TRUE, add=FALSE, lty=1,
                         col=1, group=rep(1,length(x)), 
                         label.curves=TRUE, xlim, subtitles=TRUE, 
                         datadensity=c('none','rug','hist','density'), 
                         side=1, 
                         frac=switch(datadensity,
                                     none=NA,rug=.03,hist=.1,density=.1),
                         dens.opts=NULL, lwd=1, ...)
{
  datadensity <- match.arg(datadensity)
  colspec <- FALSE
  if(datadensity != 'none') {
    if(side %in% c(2,4))
      stop('side must be 1 or 3 when datadensity is specified')
    
    if('frac' %nin% names(dens.opts))
      dens.opts$frac <- frac
    
    if('side' %nin% names(dens.opts))
      dens.opts$side <- side
    
    if('col' %in%   names(dens.opts))
      colspec <- TRUE
  }

  if(missing(xlab)) {
    ##xlab <- attr(x,"label")  26sep02
    ##if(is.null(xlab) || xlab=="")xlab <- deparse(substitute(x))
    xlab <- label(x, units=TRUE, plot=TRUE, default=deparse(substitute(x)))
  }
  
  what <- match.arg(what)
  if(missing(ylab)) ylab <- switch(what,
                                   'F'='Proportion <= x',
                                   '1-F'='Proportion > x',
                                   'f'='Frequency <= x')
  
  group <- as.factor(group)
  if(length(x) != length(group))
    stop('length of x != length of group')

  nna <- !(is.na(x)|is.na(group)|is.na(weights))
  
  X <- x[nna]
  group <- group[nna]

  lev <- levels(group)
  nlev <- length(lev)
  curves <- vector('list',nlev)
  names(curves) <- lev

  lty <- rep(lty, length=nlev)
  col <- rep(col, length=nlev)
  lwd <- rep(lwd, length=nlev)

  if(missing(xlim))
    xlim <- range(X)

  n <-
    if(normwt)
      length(X)
    else
      sum(weights[nna])
  
  m <- (if(normwt)
          length(nna)
        else
          sum(weights, na.rm=TRUE)) - n
  
  weights <- weights[nna]

  for(i in 1:nlev) {
    s <- group == lev[i]
    x <- X[s]
    wt <- weights[s]
    xorig <- x

    z <- wtd.Ecdf(x, wt, type='i/n', normwt=normwt, na.rm=FALSE)
    x <- z$x; y <- z$ecdf
    switch(what,
           '1-F' = {y <- 1-y},
           'f'   = {y <- y * sum(wt)})

    if(pl) {
      if(i==1 && !add)
        plot(x, y, xlab=xlab, ylab=ylab, xlim=xlim, type='n', ...)
      
      lines(x,y, type="s", lty=lty[i], col=col[i], lwd=lwd[i])
      if(subtitles && i==1) {
        pm <- paste("n:",n," m:",m,sep="")
        title(sub=pm,adj=0,cex=.5)
      }

      if(!missing(q)) {
        if(what=='f') q <- q*y[length(y)] else if(what=='1-F') q <- 1-q
        q <- switch(what,
                    'f'   = q*sum(wt),
                    '1-F' = 1 - q,
                    'F'   = q)
        
        a <- par("usr")
        for(w in q) {
          quant <-
            if(what=='1-F')
              min(x[y<=w])
            else
              min(x[y>=w])
          
          lines(c(a[1],quant),c(w,w),lty=2,col=1)
          lines(c(quant,quant),c(w,a[3]),lty=2,col=col[i])
        }
      }
    }

    curves[[i]] <- list(x=x, y=y)
    if(datadensity!='none') {
      if(!colspec)
        dens.opts$col <- col[i]

      do.call(switch(datadensity, 
                     rug    ='scat1d', hist='histSpike',
                     density='histSpike'),
              c(list(x=xorig,add=TRUE),if(datadensity=='density')list(type='density'), dens.opts))
    }
  }

  if(nlev > 1 && (is.list(label.curves) || label.curves))
    labcurve(curves, type='s', lty=lty, col=col, opts=label.curves)

  invisible(structure(if(nlev==1)
                        list(x = x, y = y)
                      else
                        curves, 
                      N=list(n=n, m=m)))
}


Ecdf.data.frame <- function(x, group=rep(1,nrows), 
                            weights=rep(1,nrows), normwt=FALSE,
                            label.curves=TRUE, n.unique=10, na.big=FALSE, 
                            subtitles=TRUE,  vnames=c("labels","names"),
                            ...)
{
  vnames <- match.arg(vnames)
  mf <- par('mfrow')
  if(length(mf)==0)
    mf <- c(1,1)

  g <- function(v, n.unique)  ## 7sep02
  {
    if(is.character(v) || is.category(v))
      return(FALSE)
    
    length(unique(v[!is.na(v)])) >= n.unique
  }
  
  use <- sapply(x, g, n.unique=n.unique)
  automf <- FALSE  ## 22sep02
  if((la <- sum(use)) > 1 & max(mf)==1) {
    mf <-
      if(la<=4)
        c(2,2)
      else if(la<=6)
        c(2,3)
      else if(la<=9)
        c(3,3)
      else if(la<=12)
        c(3,4)
      else if(la<=16)
        c(4,4)
      else
        c(4,5)
    
    automf <- TRUE
  }
  
  oldmf <- par(mfrow=mf)
  on.exit(par(oldmf))
  
  nam <- names(x)
  nrows <- nrow(x)
  i <- 0
  j <- 0

  group <- as.factor(group)
  
  for(j in (1:length(x))[use]) {
    v <- x[[j]]
    i <- i+1
    ##lab <- attr(v,"label") 26sep02
    lab <-
      if(vnames=='names')
        nam[j]
      else
        label(v, units=TRUE, plot=TRUE, default=nam[j])
    
    z <- Ecdf(v, group=group, weights=weights, normwt=normwt, 
              xlab=lab, label.curves=label.curves, 
              subtitles=subtitles, ...)
    if(na.big) {
      m <- attr(z,'N')$m
      if(m > 0)
        mtext(paste(m,"NAs"),line=-2,cex=1)
    }
    
    if(automf && interactive() && 
       names(dev.list()) %nin% c('postscript','win.printer') &&
       (i %% prod(mf)==0)) {
      cat("click left mouse button to proceed\n")
      locator(1)
    }
  }
  
  invisible(ceiling(sum(use) / prod(mf)))
}


prepanel.Ecdf <- function(x, y, fun, ...)
{
  xlim <- range(x,na.rm=TRUE)
  ylim <- fun(c(0,1))
  if(any(is.infinite(ylim)))
    ylim <- fun(c(.001,.999))   # was inf 18Mar02
  
  list(xlim=xlim, ylim=ylim, dx=diff(xlim), dy=diff(ylim))
}


panel.Ecdf <- function(x, y, subscripts, groups=NULL, 
                       q=NULL, type='s',
                       method=c('i/n','(i-1)/(n-1)','i/(n+1)'), fun,
                       label.curves=TRUE, 
                       lwd = plot.line$lwd, 
                       lty = plot.line$lty,
                       pch = plot.symbol$pch, 
                       cex = plot.symbol$cex, 
                       font= plot.symbol$font, 
                       col = NULL, ...)
{
  ## y duplicates x in S-Plus
  method <- match.arg(method)
  if(length(groups))
    groups <- as.factor(groups)

  if(!.R.)
    llines <- lines
  
  if(.R.)
    type <- 's'   # lattice histogram sets to 'percent'

  ##g <- if(length(groups)) oldUnclass(groups[subscripts]) else NULL
  g <- oldUnclass(groups)[subscripts]
  ng <-
    if(length(groups))
      max(g, na.rm=TRUE)
    else
      1  ## na.rm 8Aug00

  plot.symbol <- trellis.par.get(if(ng>1)
                                   "superpose.symbol"
                                 else
                                   "plot.symbol")
  
  plot.line   <- trellis.par.get(if(ng>1)
                                   "superpose.line"
                                 else
                                   "plot.line")

  qrefs <- function(x, q, col, fun, llines, grid)
  {
    quant <- quantile(x, probs=q, na.rm=TRUE)  # 9Dec98
    a <- parGrid(grid)$usr
    for(i in 1:length(q)) {
      llines(c(a[1],quant[i]),fun(c(q[i],q[i])),lty=2,col=1)
      llines(c(quant[i],quant[i]),fun(c(q[i],a[3])),lty=2,col=col)
    }
  }

  ppanel <- function(x, y, type, cex, pch, font, lwd, lty, col, q, 
                     qrefs, ecdf.type, fun=fun, 
                     datadensity=c('none','rug','hist','density'), 
                     side=1, 
                     frac=switch(datadensity,
                                 none=NA,
                                 rug=.03,
                                 hist=.1,
                                 density=.1),
                     dens.opts=NULL, llines, ...)
  {
    ## y ignored
    z <- wtd.Ecdf(x, type=ecdf.type, na.rm=FALSE)
    
    ## For some reason S-Plus will not plot anything the following way
    ## when lwd is a variable
    ##llines(z$x, fun(z$ecdf), lwd = lwd, lty = lty, col = col,
    ##       type = type, ...)
    do.call('llines', list(z$x, fun(z$ecdf), lwd = lwd, lty = lty, col = col,
                           type = type, ...))
    if(length(q))
      qrefs(x, q, col, fun=fun, llines=llines, grid=.R.)
    
    datadensity <- match.arg(datadensity)
    if(datadensity != 'none') {
      if(side %in% c(2,4))
        stop('side must be 1 or 3 when datadensity is specified')
      
      if('frac' %nin% names(dens.opts))
        dens.opts$frac <- frac

      if('side' %nin% names(dens.opts))
        dens.opts$side <- side

      if('col'  %nin% names(dens.opts))
        dens.opts$col  <- col

      if('lwd'  %nin% names(dens.opts))
        dens.opts$lwd  <- lwd

      do.call(switch(datadensity, 
                     rug    ='scat1d',
                     hist='histSpike',
                     density='histSpike'),
              c(list(x=x,add=TRUE,grid=.R.),
                if(datadensity=='density')
                  list(type='density'),
                dens.opts))
    }
  }

  pspanel <- function(x, subscripts, groups, type, lwd, lty,
                      pch, cex, font, col, q, qrefs, 
                      ecdf.type, fun, llines, ...)
  {
    ## y ignored
    lev <- levels(groups)
    groups <- as.numeric(groups)[subscripts]
    N <- seq(along = groups)
    ##curves <- vector('list', length(lev))             ## 19Mar02
    curves <- list()  ## 31aug02
    ##names(curves) <- lev                              ## 19Mar02 31aug02
    
    ##for(i in sort(unique(groups))) {                  ## 19Mar02
    for(i in 1:length(lev)) {
      ##if(is.na(i)) next   ## 8Aug00                 ## 19Mar02
      which <- N[groups == i]	# j <- which[order(x[which])]	
      ## sort in x
      j <- which # no sorting
      if(any(j)) {  ## 31aug02 any
        z <- wtd.Ecdf(x[j], type=ecdf.type, na.rm=FALSE)
        do.call('llines',list(z$x, fun(z$ecdf),
                              col = col[i], lwd = lwd[i], lty = lty[i], 
                              type = type, ...))
        if(length(q)) qrefs(x[j], q, col[i], fun=fun, llines=llines,
                            grid=.R.)
        curves[[lev[i]]] <- list(x=z$x, y=fun(z$ecdf))  ## was [i] 31aug02
      }
    }
    
    curves
  }

  lty  <- rep(lty, length = ng)
  lwd  <- rep(lwd, length = ng)
  pch  <- rep(pch, length = ng)
  cex  <- rep(cex, length = ng)
  font <- rep(font,length = ng)
  if(!length(col))
    col <- plot.line$col

  col <- rep(col, length = ng)

  if(ng > 1) {
    levnum <- sort(unique(g))
    curves <- pspanel(x, subscripts, groups,    ## rm y 19Mar02
                      lwd=lwd, lty=lty, pch=pch, cex=cex, 
                      font=font, col=col, type=type, q=q, qrefs=qrefs, 
                      ecdf.type=method, fun=fun, llines=llines)
    if(!(is.logical(label.curves) && !label.curves)) {
      lc <-
        if(is.logical(label.curves))
          list(lwd=lwd, cex=cex[1])
        else
          c(list(lwd=lwd, cex=cex[1]), label.curves)
      ##curves <- vector('list',length(levnum)); names(curves) <- levels(groups
      ## 19Mar02
      ##i <- 0
      ##for(gg in levnum) {
      ##  i <- i+1
      ##  s <- g==gg
      ##  curves[[i]] <- list(x[s], y[s])
      ##}
      labcurve(curves, lty=lty[levnum], lwd=lwd[levnum], col=col[levnum], 
               opts=lc, grid=.R., ...)
    }
  } else ppanel(x,
                lwd=lwd, lty=lty, pch=pch, cex=cex, 
                font=font, col=col, type=type, q=q, qrefs=qrefs, 
                ecdf.type=method, fun=fun, llines=llines, ...) ## rm y 19Mar02 

  if(ng>1) { ##set up for key() if points plotted
    if(.R.) {
      Key <- function(x=0, y=1, lev, col, lty, lwd, ...)
      {
        oldpar <- par(usr=c(0,1,0,1),xpd=NA)
        
        ## Even though par('usr') shows 0,1,0,1 after lattice draws
        ## its plot, it still needs resetting
        on.exit(par(oldpar))
        if(is.list(x)) {
          y <- x[[2]]; x <- x[[1]]
        }

        if(!length(x))
          x <- 0

        if(!length(y))
          y <- 1  ## because of formals()

        rlegend(x, y, legend=lev, lty=lty, lwd=lwd, col=col)
        invisible()
      }
    } else {
      Key <- function(x=NULL, y=NULL, lev, col, lty, lwd, ...)
      {
        if(length(x)) {
          if(is.list(x)) {
            y <- x$y; x <- x$x
          }

          key(x=x, y=y, text=list(lev, col=col), 
              lines=list(col=col,lty=lty,lwd=lwd),
              transparent=TRUE, ...)
        } else key(text=list(lev, col=col), 
                   lines=list(col=col,lty=lty,lwd=lwd),transparent=TRUE, ...)
        invisible()
      }
    }
    
    formals(Key) <- list(x=NULL, y=NULL, lev=levels(groups), col=col,
                         lty=lty, lwd=lwd,...=NULL)
    storeTemp(Key)
  }
}


Ecdf.formula <- function(x, data = sys.frame(sys.parent()), 
                         groups = NULL, 
                         prepanel=prepanel.Ecdf, panel=panel.Ecdf, ..., 
                         xlab, ylab, fun=function(x)x, subset=TRUE)
{
  if(.R.) {
    require('grid')
    require('lattice')
    vars <- var.inner(x)
    xname <- vars[1]
    if(missing(xlab))
      xlab <- label(eval(parse(text=vars[1]), data),
                    units=TRUE, plot=TRUE, default=xname, grid=TRUE)
    ##xlab <- attr(eval(parse(text=vars[1]), data),'label') 26sep02
  } else {
    vars <- attr(terms.inner(x),'variables')
    xname <- as.character(vars[1])
    if(missing(xlab))
      xlab <- label(eval(vars[1], data), units=TRUE, plot=TRUE,
                    default=xname)
    ##xlab <- attr(eval(vars[1], data),'label') 26sep02
  }
  
  if(missing(ylab)) 
    ylab <-
      if(missing(fun))
        paste('Proportion <=',xname)
      else
        ''
  
  subset <- eval(substitute(subset), data)

  if(.R.)
    do.call("histogram",
            c(list(x, data=data, prepanel=prepanel, panel=panel,
                   ylab=ylab, xlab=xlab, fun=fun),
              ## was jyst groups=groups 31aug02
              if(!missing(groups))
                list(groups=eval(substitute(groups),data)),
              if(!missing(subset))
                list(subset=subset),
              list(...)))
  else  {
    prepanel$fun <- fun
    ## argument not transmitted for some reason
    setup.2d.trellis(x, data = data,
                     prepanel=prepanel, panel=panel,
                     xlab=xlab, ylab=ylab, fun=fun,
                     groups = eval(substitute(groups),  data),
                     ..., subset = subset)
  }
}
eip <- function(name)
{
  name <- as.character(substitute(name))
  f <- find(name)
  if(length(f)!=1)
    stop('object must exist in exactly one place')
  
  ##g <- if(under.unix) jove(get(name)) else edit(get(name))  16Apr02
  g <- edit(get(name))
  if(.R.)
    assign(name, g, pos=match(f,search()))
  else
    assign(name, g, where=f)
  
  cat('Object', name, 'stored in', f, '\n')
  invisible()
}
## From: geyer@galton.uchicago.edu
## Modified 11May91 FEH - added na.rm to range()
## Modified 12Jul91 FEH - added add=T and lty=1 parameters
## Modified 12Aug91 FEH - added explicit ylim parameter
## Modified 26Aug94 FEH - added explicit lwd parameter for segments()
## FEH 2Jul02 added horizontal charts with differences on 2nd axis

errbar <-
  function(x, y, yplus, yminus, cap=.015,
           xlab=as.character(substitute(x)),
           ylab=if(is.factor(x) || is.character(x)) ''
           else
           as.character(substitute(y)),
           add=FALSE, lty=1, ylim, lwd=1,
           Type=rep(1,length(y)), ... )
{
  if(missing(ylim))
    ylim <- range(y[Type==1], yplus[Type==1], yminus[Type==1],
                  na.rm=TRUE)
  
  if(is.factor(x) || is.character(x)) {
    x <- as.character(x)
    n <- length(x)
    t1 <- Type==1
    t2 <- Type==2
    n1 <- sum(t1)
    n2 <- sum(t2)
    
    omai <- par('mai')
    mai <- omai
    mai[2] <- max(strwidth(x, 'inches')) + .25 * .R.
    par(mai=mai)
    on.exit(par(mai=omai))
    plot(0,0,xlab=ylab,ylab='',xlim=ylim,ylim=c(1,n+1),axes=FALSE,...)
    axis(1)
    w <-
      if(any(t2))
        n1+(1:n2)+1
      else
        numeric(0)
    
    axis(2, at=c(1:n1,w), labels=c(x[t1],x[t2]), las=1,adj=1)
    points(y[t1], 1:n1, pch=16, ...)
    segments(yplus[t1], 1:n1, yminus[t1], 1:n1, ...)

    if(any(Type==2)) {
      abline(h=n1+1, lty=2, ...)
      offset <- mean(y[t1]) - mean(y[t2])
      if(min(yminus[t2]) < 0 & max(yplus[t2]) > 0)
        lines(c(0,0)+offset, c(n1+1,par('usr')[4]), lty=2, ...)
      
      points(y[t2] + offset, w, pch=16, ...)
      segments(yminus[t2]+offset, w, yplus[t2]+offset, w, ...)
      at <- pretty(range(y[t2],yplus[t2],yminus[t2]))
      axis(3, at=at+offset, label=format(round(at,6)))
    }
    
    return(invisible())
  }
  
  if(add) points(x, y, ...)
  else
    plot(x, y, ylim=ylim, xlab=xlab, ylab=ylab, ...)
  
  xcoord <- par()$usr[1:2]
  segments(x, yminus, x, yplus , lty=lty, lwd=lwd, ...)
  smidge <- cap * ( xcoord[2] - xcoord[1] ) / 2
  segments( x - smidge, yminus, x + smidge, yminus, lwd=lwd, ...)
  segments( x - smidge, yplus, x + smidge, yplus, lwd=lwd, ...)
  invisible()
}
## event.chart.q: eventchart program 1.0 (creates function event.chart)
##
## last edited: 9-27-97
## last edited: 10-20-98, add pty='m' for the default plotting;
##      one may change to pty='s' to get the 'square plot' for the Goldman's Event Chart                      
## FEH changes 9may02 for R

event.chart <-
  function(data, subset.r = 1:dim(data)[1], subset.c = 1:dim(data)[2], 

           sort.by = NA, sort.ascending = TRUE, 
           sort.na.last = TRUE, sort.after.subset = TRUE,
           y.var = NA, y.var.type = 'n', 
           y.jitter = FALSE, y.jitter.factor = 1,
           y.renum = FALSE, NA.rm = FALSE, x.reference = NA, 
           now = max(data[,subset.c], na.rm = TRUE),
           now.line = FALSE, now.line.lty = 2,
           now.line.lwd = 1, now.line.col = 1, pty='m',
           date.orig = c(1,1,1960), titl = 'Event Chart',

           y.idlabels = NA, y.axis = 'auto', 
           y.axis.custom.at = NA, y.axis.custom.labels = NA, 
           y.julian = FALSE, y.lim.extend = c(0,0),
           y.lab = ifelse(is.na(y.idlabels), '' , as.character(y.idlabels)), 

           x.axis.all = TRUE, x.axis = 'auto', 
           x.axis.custom.at = NA, x.axis.custom.labels = NA, 
           x.julian = FALSE, x.lim.extend = c(0,0), x.scale = 1,
           x.lab = ifelse(x.julian, 'Follow-up Time', 'Study Date'),

           line.by = NA, line.lty = 1, line.lwd = 1, line.col = 1,
           line.add = NA, line.add.lty = NA, 
           line.add.lwd = NA, line.add.col = NA, 
           point.pch = 1:length(subset.c),
           point.cex = rep(0.6,length(subset.c)),
           point.col = rep(1,length(subset.c)),

           legend.plot = FALSE, legend.location = 'o', legend.titl = titl, 
           legend.titl.cex = 3.0, legend.titl.line = 1.0, 
           legend.point.at = list(x = c(5,95), y = c(95,30)),
           legend.point.pch = point.pch,
           legend.point.text = ifelse(rep(is.data.frame(data),
                                          length(subset.c)),
                                      names(data[,subset.c]), subset.c), 
           legend.cex = 2.5, legend.bty = 'n',
           legend.line.at = list(x = c(5,95), y = c(20,5)),
           legend.line.text = names(table(as.character(data[,line.by]),
                                          exclude = c('','NA'))), 
           legend.line.lwd = line.lwd, legend.loc.num = 1, 

           ...)
{
  legnd <- function(..., pch)
  {
    if(missing(pch))
      legend(...)
    else if(.R.)
      legend(..., pch=pch)
    else
      legend(..., marks=pch)
  }
  
  if(.R.) {
    month.day.year <- function(jul, origin.)
    {
      if(missing(origin.) || is.null(origin.))
        if(is.null(origin. <- .Options$chron.origin))
          origin. <- c(month = 1, day = 1, year = 1960)
      
      if(all(origin. == 0))
        shift <- 0
      else
        shift <- julian(origin = origin.)
      
      ## relative origin
      ## "absolute" origin
      j <- jul + shift
      j <- j - 1721119
      y <- (4 * j - 1) %/% 146097
      j <- 4 * j - 1 - 146097 * y
      d <- j %/% 4
      j <- (4 * d + 3) %/% 1461
      d <- 4 * d + 3 - 1461 * j
      d <- (d + 4) %/% 4
      m <- (5 * d - 3) %/% 153
      d <- 5 * d - 3 - 153 * m
      d <- (d + 5) %/% 5
      y <- 100 * y + j
      y <- y + ifelse(m < 10, 0, 1)
      m <- m + ifelse(m < 10, 3, -9)
      list(month = m, day = d, year = y)
    }

    ## julian.r
    ## Convert between Julian and Calendar Dates
  
    julian <- function(m, d, y, origin.)
    {
      only.origin <- all(missing(m), missing(d), missing(y))
      if(only.origin)
        m <- d <- y <- NULL
      
      ## return days since origin
      if(missing(origin.)) if(is.null(origin. <- .Options$chron.origin))
        origin. <- c(month = 1, day = 1, year = 1960)
      
      nms <- names(d)
      max.len <- max(length(m), length(d), length(y))
    
      ## prepend new origin value and rep out to common max. length:
      m <- c(origin.[1], rep(m, length = max.len))
      d <- c(origin.[2], rep(d, length = max.len))
      y <- c(origin.[3], rep(y, length = max.len))
    
      ## code from julian date in the S book (p.269)
      y <- y + ifelse(m > 2, 0, -1)
      m <- m + ifelse(m > 2, -3, 9)
      c <- y %/% 100
      ya <- y - 100 * c
      out <- (146097 * c) %/% 4 + (1461 * ya) %/% 4 + (153 * m + 2) %/% 5 +
        d + 1721119
    
    ## now subtract the new origin from all dates
      if(!only.origin) {
        if(all(origin. == 0))
          out <- out[-1]
        else
          out <- out[-1] - out[1]
      }

      names(out) <- nms
      out
    }
  }

  ## stop function if unacceptable violations occur 
  ##   (other stops may occur later)
  if(!is.matrix(data) && !is.data.frame(data))
    stop("argument data must be a matrix or a data frame\n")
  
  ## added is.data.frame 9may02 FEH

  ## section 1: do necessary subsetting and sorting of data
  targodata <- apply(data[, subset.c, drop = FALSE], 2, as.numeric)
  
  ## targodata for target 'overall' data
  if(!is.na(x.reference))
    targodata <- apply(targodata - data[, x.reference], 2, as.numeric)

  ## start of sort routine
  if(!is.na(sort.by[1])) {	
    if(sort.after.subset == TRUE)
      data <- data[subset.r, ]

    m <- dim(data)[1]
    keys <- 1:m
    rotate <- m:1
    length.sort.by <- length(sort.by)
    asc <- rep(sort.ascending, length.sort.by)
    for (i in length.sort.by:1) {
      if(asc[i])
        keys[] <- keys[sort.list(data[, sort.by[[i]]][keys], 
                                 na.last = sort.na.last)]
      else
        keys[] <- keys[order(data[, sort.by[[i]]][keys],
                             rotate, na.last = sort.na.last)[rotate]]
    }

    data <- data[keys, ]

    if(sort.after.subset == FALSE) {
      subset.r <- (1:dim(data)[1])[subset.r]
      targdata <- apply(data[subset.r, subset.c, drop = FALSE], 2, as.numeric)
    } else if(sort.after.subset == TRUE) {
      targdata <- apply(data[, subset.c, drop = FALSE], 2, as.numeric)
      subset.ro <- (1:dim(data)[1])[subset.r]	
      subset.r <- seq(length(subset.ro))
    }
  } else if(is.na(sort.by[1])) {
    subset.r <- (1:dim(data)[1])[subset.r]
    targdata <- apply(data[subset.r, subset.c, drop = FALSE], 2, as.numeric)
  }
  
  ## end of sort routine

  ## start to deal with missing values and renumbering y-axis
  if(NA.rm == TRUE) {
    whotoplot <- subset.r[!(apply(is.na(targdata),1,all))]
    ## whotoplot is for use for data matrix(dataframe); 
    ##  essentially who will be plotted from data
    
    t.whotoplot <- seq(dim(targdata)[1])[!(apply(is.na(targdata),1,all))]
    ## t.whotoplot is for use for targdata matrix(dataframe);
    ##  essentially, who will be plotted from targdata
    
    if(y.renum == TRUE) {
      whattoplot <- seq(subset.r[!(apply(is.na(targdata),1,all))])
      ## whattoplot is what will be plotted on y-axis of event chart
    } else if(y.renum == FALSE) {
      if((!is.na(sort.by[1]) & sort.after.subset == FALSE) | (is.na(sort.by[1])))
        whattoplot <- subset.r[!(apply(is.na(targdata),1,all))]
      else if(!is.na(sort.by[1]) & sort.after.subset == TRUE)
        whattoplot <- subset.ro[!(apply(is.na(targdata),1,all))]
    }
  } else if(NA.rm == FALSE) {
    whotoplot <- subset.r
    t.whotoplot <- seq(dim(targdata)[1])
    if(y.renum == TRUE)
      whattoplot <- seq(subset.r)
    else if(y.renum == FALSE) {
      if((!is.na(sort.by[1]) & sort.after.subset == FALSE)  |  (is.na(sort.by[1])))
        whattoplot <- subset.r
      else if(!is.na(sort.by[1]) & sort.after.subset == TRUE)
        whattoplot <- subset.ro
    }
  }
  ## end of dealing with missing values and renumbering of y-axis


  ## section 2:  perform necessary manipulations using x.reference and y.var

  ## deal with re-referencing x-axis with x.reference
  if(!is.na(x.reference)) {
    targdata <- apply(targdata - data[subset.r, x.reference], 2, as.numeric)
    if(NA.rm == TRUE) {
      x.referencew <- data[whotoplot, x.reference]
      whotoplot <- whotoplot[!is.na(x.referencew)]
      t.whotoplot <- t.whotoplot[!is.na(x.referencew)]
      whattoplot.ref <- whattoplot[!is.na(x.referencew)]
      if(y.renum == FALSE) {
        if((!is.na(sort.by[1]) & sort.after.subset == FALSE) | (is.na(sort.by[1])))
          whattoplot <- seq(subset.r[1],
                            subset.r[1] + length(whattoplot.ref) - 1)
        else if(!is.na(sort.by[1]) & sort.after.subset == TRUE)
          whattoplot <- seq(subset.ro[1],
                            subset.ro[1] + length(whattoplot.ref) - 1)     
      } else if(y.renum == TRUE)
        whattoplot <- seq(length(whattoplot.ref))
    }
  }     	

  ## deal with using a data frame variable to place lines on y-axis
  if(!is.na(y.var)) {
    if(!is.na(sort.by[1]))
      stop("cannot use sort.by and y.var simultaneously\n")
    
    y.varw <- as.numeric(data[whotoplot, y.var])
    whotoplot <- whotoplot[!is.na(y.varw)]
    t.whotoplot <- t.whotoplot[!is.na(y.varw)]
    whattoplot <- y.varw[!is.na(y.varw)]
    if(y.jitter == TRUE) {
      range.data <- diff(range(whattoplot))
      range.unif <- y.jitter.factor * 
                    (range.data / (2 * (length(whattoplot) - 1)))
      whattoplot <- whattoplot + 
                    runif(length(whattoplot), -(range.unif), range.unif)
    }
  }

  sort.what <- sort(whattoplot)
  length.what <- length(whattoplot)	

  ## section 3:	perform all plotting	

  ## first, make sure length of point.pch, cex, col is same as subset.c

  len.c <- length(subset.c)

  if(length(point.pch) < len.c) {
    warning("length(point.pch) < length(subset.c)") 
    point.pch <- rep(point.pch, len.c)[1:len.c]
  }
  
  if(length(point.cex) < len.c) {
    warning("length(point.cex) < length(subset.c)") 
    point.cex <- rep(point.cex, len.c)[1:len.c]
  }

  if(length(point.col) < len.c) {
    warning("length(point.col) < length(subset.c)") 
    point.col <- rep(point.col, len.c)[1:len.c]
  }

  ## set default of par(new=F)
  par(new = FALSE)

  ## plot external legend (if requested)
  if(legend.plot == TRUE  && legend.location == 'o') {
    plot(1, 1, type = 'n', xlim = c(0,100), ylim = c(0,100),
         axes = FALSE, xlab = '', ylab = '')
    mtext(legend.titl, line = legend.titl.line, 
          outer = FALSE, cex = legend.titl.cex)
    legnd(legend.point.at[[1]], legend.point.at[[2]],
          leg = legend.point.text,
          pch = legend.point.pch, cex = legend.cex, # was marks= 9may02
          col = point.col, bty = legend.bty)
    if(!is.na(line.by)) {
      par(new = TRUE)
      legnd(legend.line.at[[1]], legend.line.at[[2]],
            leg = legend.line.text, cex = legend.cex,
            lty = line.lty, lwd = legend.line.lwd,
            col = line.col, bty = legend.bty)
    }
    
    invisible(if(.R.)
                par(ask=TRUE)
              else
                dev.ask(TRUE))  ## FEH 9may02
  }
				
  ## start creating objects to be used in determining plot region

  targdata <- targdata /  x.scale
  targodata <- targodata / x.scale 

  minvec <- apply(targdata[t.whotoplot,, drop = FALSE], 1, min, na.rm = TRUE)
  minotime <- ifelse(x.axis.all,
                     min(apply(targodata,1,min,na.rm = TRUE), na.rm = TRUE),
                     min(minvec, na.rm = TRUE))
  maxvec <- apply(targdata[t.whotoplot,, drop = FALSE], 1, max, na.rm = TRUE)
  maxotime <- ifelse(x.axis.all,
                     max(apply(targodata,1,max,na.rm = TRUE), na.rm = TRUE),
                     max(maxvec, na.rm = TRUE))

  ## determine par parameters and plot graphical region based 
  ##  on request of y.var and, subsequently, y.var.type and now.line

  y.axis.top <- sort.what[length.what] + y.lim.extend[2]
  y.axis.bottom <- sort.what[1] - y.lim.extend[1]
  x.axis.right <- maxotime + x.lim.extend[2]
  x.axis.left <- minotime - x.lim.extend[1]

  if(!is.na(y.var) & y.var.type == 'd') {
    oldpar <- par(omi = rep(0,4), lwd = .6, 
                  mgp = c(3.05,1.1,0), tck = -0.006, ...)
    ## set pty
    par(pty=pty)
    plot(whattoplot, type = 'n',
         xlim = c(x.axis.left, 
                  ifelse(now.line, (now - (min(data[, subset.c], na.rm=TRUE))) /
                         x.scale,
                         x.axis.right)),
         ylim=c(y.axis.bottom,
                ifelse(pty=='s',
                       now,
                       y.axis.top)),
         xlab = x.lab, ylab = y.lab, axes = FALSE)
    if(now.line == TRUE)
      abline(now, ((sort.what[1] - now) / 
                   (((now - min(data[, subset.c], na.rm=TRUE)) / x.scale) - minotime)),
             lty = now.line.lty, lwd = now.line.lwd, col = now.line.col)
  } else if(is.na(y.var)  |  (!is.na(y.var) & y.var.type == 'n')) {
    if(now.line == TRUE)
      stop("with now.line==T, y.var & y.var.type=='d' must be specified\n")
    
    oldpar <- par(omi = rep(0, 4), lwd = .6, 
                  mgp = c(2.8,1.1,0), tck = -0.006, ...)
    plot(whattoplot, type = 'n',
         xlim = c(x.axis.left, x.axis.right),
         ylim = c(y.axis.bottom - 1, y.axis.top + 1),
         xlab = x.lab, ylab = y.lab, axes = FALSE)
  }	
	
  ## plot y-axis labels

  if(!is.na(y.idlabels)) {
    if(!is.na(y.var)) {
      warning("y.idlabels not used when y.var has been specified\n")
      axis(side = 2)
    } else if(is.na(y.var))
      axis(side = 2, at = whattoplot,
           labels = as.vector(data[whotoplot, y.idlabels]))
  } else if(is.na(y.idlabels)) {
    if(y.axis == 'auto') {
      if(is.na(y.var)  |  (!is.na(y.var) & y.var.type == 'n'))
        axis(side = 2) 
      else if(!is.na(y.var) & y.var.type == 'd') {
        if(y.julian == FALSE) {
          y.axis.auto.now.bottom <- ifelse(now.line, sort.what[1],
                                           y.axis.bottom)        
          ## marked by JJL, disable square plot
          ##y.axis.auto.now.top <- ifelse(now.line, now, y.axis.top)
          y.axis.auto.now.top <- ifelse(now.line, y.axis.top, y.axis.top)
          y.axis.auto.at <- round(seq(y.axis.auto.now.bottom,
                                      y.axis.auto.now.top, length = 5))
          y.axis.auto.labels <-
            paste(month.day.year(y.axis.auto.at, origin=date.orig)$month,'/',
                  month.day.year(y.axis.auto.at, origin=date.orig)$day,'/',
                  substring(month.day.year(y.axis.auto.at,
                                           origin=date.orig)$year,3,4),
                  sep='')
          axis(side = 2, at = y.axis.auto.at, labels = y.axis.auto.labels)
        } else if(y.julian == TRUE)
          axis(side = 2)
      }
    } else if(y.axis == 'custom') {
      if(is.na(y.axis.custom.at[1]) || is.na(y.axis.custom.labels[1]))
        stop("with y.axis == 'custom', must specify y.axis.custom.at and y.axis.custom.labels\n")
      
      axis(side = 2, at = y.axis.custom.at, labels = y.axis.custom.labels)
    }
  }
	
  ## plot x-axis labels

  if(x.axis == 'auto') {
    if(x.julian == FALSE) {
      x.axis.auto.at <-
        round(seq(x.axis.left, x.axis.right, length = 5))
      x.axis.auto.labels <-
        paste(month.day.year(x.axis.auto.at, origin=date.orig)$month,'/',
              month.day.year(x.axis.auto.at, origin=date.orig)$day,'/',
              substring(month.day.year(x.axis.auto.at,
                                       origin=date.orig)$year,3,4),
              sep='')
      axis(side = 1, at = x.axis.auto.at, labels = x.axis.auto.labels)
    } else if(x.julian == TRUE)
      axis(side = 1)
  } else if(x.axis == 'custom') {
    if(is.na(x.axis.custom.at[1]) || is.na(x.axis.custom.labels[1]))
      stop("with x.axis = 'custom', user must specify x.axis.custom.at and x.axis.custom.labels\n")
    
    axis(side = 1, at = x.axis.custom.at, labels = x.axis.custom.labels)
  }
  
  if(!is.na(titl)) {
    title(titl)
  }

  ## plot lines and points
	
  if(!is.na(line.by)) {
    line.byw <- data[whotoplot, line.by]
    table.by <- table(as.character(line.byw), exclude = c('','NA'))
    names.by <- names(table.by)
    len.by <- length(table.by)
    if(length(line.lty) < len.by)
      warning("user provided length(line.lty) < num. of line.by categories")
    
    if(length(line.lwd) < len.by)
      warning("user provided length(line.lwd) < num. of line.by categories")
    
    if(length(line.col) < len.by)
      warning("user provided length(line.col) < num. of line.by categories")
    
    line.lty <- rep(line.lty, len=len.by)
    line.lwd <- rep(line.lwd, len=len.by)
    line.col <- rep(line.col, len=len.by)
    lbt.whotoplot <-
      (1:(length(t.whotoplot)))[as.character(line.byw) != '' &
                                as.character(line.byw) != 'NA']
    for(i in lbt.whotoplot) {
      lines(c(minvec[i], maxvec[i]), rep(whattoplot[i],2),
            lty=as.vector(line.lty[names.by==line.byw[i]]),
            lwd=as.vector(line.lwd[names.by==line.byw[i]]),
            col=as.vector(line.col[names.by==line.byw[i]]))
    }
  } else if(is.na(line.by)) {
    for(i in 1:length(t.whotoplot))
      lines(c(minvec[i], maxvec[i]), rep(whattoplot[i],2),
            lty=line.lty[1], lwd=line.lwd[1], col=line.col[1])
  }

  for(j in 1:dim(targdata)[2])
    points(as.vector(unlist(targdata[t.whotoplot,j])), whattoplot, 
           pch=point.pch[j], cex=point.cex[j],
           col=point.col[j])
  ## removed mkh=0 FEH 9may02

  ## add line.add segments (if requested)

  if(!is.na(as.vector(line.add)[1])) {
    if(any(is.na(line.add.lty))) 
      stop("line.add.lty can not have missing value(s) with non-missing line.add\n")
    
    if(any(is.na(line.add.lwd)))
      stop("line.add.lwd can not have missing value(s) with non-missing line.add\n")
    
    if(any(is.na(line.add.col)))
      stop("line.add.col can not have missing value(s) with non-missing line.add\n")
  
    line.add.m <- as.matrix(line.add)
    dim.m <- dim(line.add.m)

    if(dim.m[1] != 2)
      stop('line.add must be a matrix with two rows\n')
    
    if(length(line.add.lty)!=dim.m[2]) 
      stop("length of line.add.lty must be the same as number of columns in line.add\n")
    
    if(length(line.add.lwd)!=dim.m[2])
      stop("length of line.add.lwd must be the same as number of columns in line.add\n")
    
    if(length(line.add.col)!=dim.m[2])
      stop("length of line.add.col must be the same as number of columns in line.add\n")

     for(j in (1:dim.m[2])) {
       for(i in (1:length(t.whotoplot))) {
         add.var1 <- subset.c == line.add.m[1,j]
         if (any(add.var1)==FALSE)
           stop("variables chosen in line.add must also be in subset.c\n")
         
         add.var2 <- subset.c == line.add.m[2,j]
         if (any(add.var2)==FALSE)
           stop("variables chosen in line.add must also be in subset.c\n")
         
         segments(targdata[i, (1:len.c)[add.var1]], whattoplot[i], 
                  targdata[i, (1:len.c)[add.var2]], whattoplot[i],
                  lty = line.add.lty[j], lwd = line.add.lwd[j],
                  col = line.add.col[j])
       }
     }
  }

  ## plot internal legend (if requested)

  if(legend.plot == TRUE  &  legend.location != 'o') {
    if(legend.location == 'i') {
      legnd(legend.point.at[[1]], legend.point.at[[2]], 
            leg = legend.point.text,
            pch = legend.point.pch, cex = legend.cex,  # marks 9may02
            col = point.col, bty = legend.bty)
      if(!is.na(line.by))
        legnd(legend.line.at[[1]], legend.line.at[[2]],
              leg = legend.line.text, cex = legend.cex,
              lty = line.lty, lwd = legend.line.lwd,
              col = line.col, bty = legend.bty)
    } else if(legend.location == 'l') {
      cat('Please click at desired location to place legend for points.\n') 
      legnd(locator(legend.loc.num), leg = legend.point.text,
            pch = legend.point.pch, cex = legend.cex,  # marks 9may02
            col = point.col, bty = legend.bty)
      if(!is.na(line.by)) {
        cat('Please click at desired location to place legend for lines.\n')
        legnd(locator(legend.loc.num), leg = legend.line.text, 
              cex = legend.cex, lty = line.lty, 
              lwd = legend.line.lwd, col = line.col, bty = legend.bty)
      }
    }
  }
  
  ## add box to main plot and clean up
	
  invisible(box())
  invisible(if(.R.)
              par(ask=FALSE)
            else
              dev.ask(FALSE))  ## FEH 9may02
  
  par(oldpar)
}


## event.convert.s
## convert 2-column coded events to multiple event time for event.chart()
## input: a matrix or dataframe with at least 2 columns
##        by default, the first column contains the event time and
##                    the second column contains the k event codes (e.g. 1=dead, 0=censord)
## ouput: a matrix of k columns, each column contains the time of kth coded event
##        
event.convert <- function(data2, event.time = 1, event.code = 2)
{
  dim.d <- dim(data2)
  len.t <- length(event.time)
  if(len.t != length(event.code))
    stop("length of event.time and event.code must be the same")
  
  if(any(event.time > dim.d[2]))
    stop(paste("Column(s) in event.time cannot be greater than ", dim.d[2]))

  if(any(event.code > dim.d[2]))
    stop(paste("Column(s) in event.code cannot be greater than ",
    dim.d[2]))
  
  name.data <- names(data2)[event.time]
  if(is.null(name.data)) {
    name.data <- paste("V", event.time, sep = "")
  }
  
  n.level <- rep(NA, len.t)
  for(i in (1:len.t)) {
    n.level[i] <- length(table(data2[, event.code[i]]))
  }

  tot.col <- sum(n.level)
  data.out <- matrix(NA, dim.d[1], tot.col)
  name.col <- rep(NA, tot.col)
  n.col <- 1
  for(i in (1:len.t)) {
    tab.d <- table(data2[, event.code[i]])
    if(is.null(oldClass(data2[, event.code[i]])))
      level.value <- as.numeric(names(tab.d))
    else
      level.value <- names(tab.d)

    for(j in (1:length(tab.d))) {
      data.out[, n.col] <- rep(NA, dim.d[1])
      check <- data2[, event.code[i]] == level.value[j]
      check[is.na(check)] <- FALSE
      data.out[, n.col][data2[, event.code[i]] == level.value[j]] <-
        data2[, event.time[i]][check]
      name.col[n.col] <-
        paste(name.data[i], ".", names(tab.d)[j], sep = "")
      n.col <- n.col + 1
    }
  }
  dimnames(data.out) <- list(1:dim.d[1], name.col)
  return(as.matrix(data.out))
}
## event.history-sim-request.txt: s-plus code to make event history graphs
##   (for distribution, including SIM readers)
##   last edited: 09-28-01

## start event.history function 
## --> assume data is approporately pre-processed (e.g., smoothed) 
##     prior to function call


event.history <- function(data, survtime.col, surv.col, 
                          surv.ind = c(1,0), 
                          subset.rows = NULL, 
                          covtime.cols = NULL, cov.cols = NULL, 
                          num.colors = 1, cut.cov = NULL, colors = 1, 
                          cens.density = 10, mult.end.cens = 1.05,
                          cens.mark.right = FALSE, cens.mark = '-', 
                          cens.mark.ahead = .5, cens.mark.cutoff = -1e-8, cens.mark.cex = 1.0, 
                          x.lab = 'time under observation', 
                          y.lab = 'estimated survival probability', 
                          title = 'event history graph', 
                          ...)
{
  ## if covtime.cols was assigned a single zero, then
  ##  make it a one-column matrix of zeroes:
  if(is.null(covtime.cols))
    covtime.cols <- as.matrix(rep(0, dim(data)[1]))

  ## do necessary subsetting
  if(!is.null(subset.rows)) {
    data <- data[subset.rows,]
    surv.col  <- surv.col[subset.rows]
    survtime.col  <- survtime.col[subset.rows]
    covtime.cols <- covtime.cols[subset.rows,]
    if(!is.null(cov.cols))
      cov.cols  <- cov.cols[subset.rows,]
  }

  ## put in stops signifying 'illegal' data
  if(any(is.na(surv.col)))
    stop('cannot have NA entries in surv.col column \n')

  if(any(is.na(survtime.col)))
    stop('cannot have NA entries in survtime.col column \n')

  if(min(survtime.col) < 0)
    stop('survtime.col observations cannot be < 0 \n')

  if(min(covtime.cols, na.rm = TRUE) < 0)
    stop('covtime.cols observations cannot be < 0 \n')

  ## create color-covariate cutting based on subset data, as desired
  if(is.null(cov.cols))
    colors.cat <- matrix(1, nrow=dim(data)[1])
  else {
    if(is.null(cut.cov))
      colors.cat <- matrix(as.numeric(cut(cov.cols, breaks = num.colors)), 
                           ncol=dim(cov.cols)[2])
    else colors.cat <- matrix(as.numeric(cut(cov.cols, breaks = cut.cov)), 
                              ncol=dim(cov.cols)[2])
  }

  ## order the entire dataframe such that
  ##  time is in descending order and, when tied, then, 
  ##  survival comes before censoring 

  if(surv.ind[1] > surv.ind[2])
    data <- data[order(unlist(survtime.col), unlist(-surv.col)),]
  else if(surv.ind[1] < surv.ind[2])
    data <- data[order(unlist(survtime.col), unlist(surv.col)),]

  ## determine vector of upcoming consecutive censored objects if current is censored
  cens.consec.vec <- rep(NA, dim(data)[1])
  cnt <- 0
  for(i in dim(data)[1]:1) {
    if(surv.col[i] == surv.ind[1]) {
      cnt <- 0
      cens.consec.vec[i] <- 0
      next
    } else if(surv.col[i] == surv.ind[2]) {
      cnt <- cnt + 1
      cens.consec.vec[i] <- cnt - 1
    }
  }

  ## some pre-processing here before plotting:
  ## determine vector of upcoming events (possibly tied events) following
  ##  any censored time or string of consecutive censored times;
  ##  also, determine upcoming event times (or, by default,
  ##  5% beyond final censored time if no event times
  ##  eventually follow a censored time)
  ##  --> also, determine string size of censored obs followed by event(s)

  n <- dim(data)[1]
  cnt <- 0
  seq.events <- (1:n)[surv.col == surv.ind[1]]
  upcoming.events <- time.ahead <- string <- split <- rep(NA, dim(data)[1])
  table.temp <- table(survtime.col[surv.col == surv.ind[1]]) 

  for(i in 1:n) {
    if(surv.col[i] == surv.ind[2]) {
      if((n - cens.consec.vec[i]) > i) {
        cnt <- cnt + 1
        upcoming.events[i] <-
          table.temp[as.numeric(names(table.temp)) > survtime.col[i]][1]
        time.ahead[i] <-
          as.numeric(names(table.temp[as.numeric(names(table.temp)) > survtime.col[i]])[1])
    
        seq.event.after <- seq.events[seq.events > i][1]
        if(i == 1  | (cnt == i)) {
          string[i] <-
            table.temp[as.numeric(names(table.temp)) > survtime.col[i]][1] + 
              (seq.event.after - 1)
	} else {
          seq.event.before <- rev(seq.events[seq.events < i])[1]
          string[i] <- table.temp[as.numeric(names(table.temp)) > survtime.col[i]][1] +
                       (seq.event.after  - seq.event.before - 1)
        }
	
        split[i] <- cnt
        if(surv.col[i+1] == surv.ind[1])
          cnt <- 0
      } else if((n - cens.consec.vec[i]) <= i) {
	cnt <- cnt + 1
	time.ahead[i] <- survtime.col[n] * mult.end.cens
	split[i] <- cnt
	seq.event.before <- rev(seq.events[seq.events < i])[1]
	string[i] <- n - seq.event.before
      }
    ## end censored if statement
    } else if(surv.col[i] == surv.ind[1]) {
      if(i > 1) {
        if(surv.col[i-1] == surv.ind[2]) {
          split[i] <- split[i-1] + 1
          string[i] <- string[i-1]
        } else if((surv.col[i-1] == surv.ind[1]) &
                  (survtime.col[i-1] == survtime.col[i]) & 
                  !is.na(split[i-1])) {
          split[i] <- split[i-1] + 1
          string[i] <- string[i-1]
        }
      }
    }
    ## end event if statement
  }
  ## end pre-processing for loop
  

  ## set up plotting region, axis labels, title, etc.
  plot(x=c(0, max(survtime.col, na.rm=TRUE) * mult.end.cens), y=c(0,1), type='n', 
       xlab=x.lab, ylab=y.lab, main=title, ...)


  ## definitions needed in below for loop
  temp.prob.c <- temp.prob.e <- NA
  temp.prob.old <- 1
  temp.prob.e.old <- 1
  cens.cnt <- 0
  cumsum.e <- cumsum(surv.col)


  ## main function for loop to create plotting lines for each patient

  for(i in 1:n) {
    len.cov <- sum(!is.na(covtime.cols[i,])) 	## number of intervals to draw for patient i

    if(len.cov < 1)
      stop('can have only non-NA covariate observations in iteration', i, '\n')

    if(surv.col[i] == surv.ind[1]) { ## event
      temp.prob.e <- temp.prob.e.old * (n - i) / (n - i + 1)
      if(!is.na(split[i])) {
        upcoming.prob.e <- (n - (i + (string[i] - split[i]))) / 
                           (n + upcoming.event.old - (i + (string[i] - split[i]))) *
                           temp.prob.e.old
        temp.prob.plot <- temp.prob.e.old - 
                          ((temp.prob.e.old - upcoming.prob.e) *
                          split[i]/string[i])
      } else temp.prob.plot <- temp.prob.e

      ## perform plotting for uncensored obs i 	
      if(len.cov > 1) {
        for(j in (1:(len.cov - 1))) {
          color <- switch(colors.cat[i, j], colors[1], colors[2], colors[3], colors[4], colors[5],
                          colors[6], colors[7], colors[8], colors[9], colors[10],
                          colors[11], colors[12], colors[13], colors[14], colors[15],
                          colors[16], colors[17], colors[18], colors[19], colors[20])

          polygon(x=c(covtime.cols[i,j], covtime.cols[i,j+1], covtime.cols[i,j+1], covtime.cols[i,j]), 
		  y=c(temp.prob.plot, temp.prob.plot, temp.prob.old, temp.prob.old), col=color)
        }
      }
		
      color <- switch(colors.cat[i, len.cov], colors[1], colors[2], colors[3], colors[4], colors[5],
                      colors[6], colors[7], colors[8], colors[9], colors[10],
                      colors[11], colors[12], colors[13], colors[14], colors[15],
                      colors[16], colors[17], colors[18], colors[19], colors[20])
										
      polygon(x=c(covtime.cols[i,len.cov], survtime.col[i], survtime.col[i], covtime.cols[i,len.cov]), 
              y=c(temp.prob.plot, temp.prob.plot, temp.prob.old, temp.prob.old), col=color)

      if(!is.na(string[i]) & (split[i] < string[i])) 
        temp.prob.old <- temp.prob.plot
      else 
        temp.prob.e.old <- temp.prob.old <- temp.prob.plot	   	
    ## end event if statement for plotting
    } else if(surv.col[i] == surv.ind[2]) { ## censored
      if((n - cens.consec.vec[i]) > i) {
        upcoming.prob.c <- (n - (i + (string[i] - split[i]))) / 
                           (n + upcoming.events[i] - (i + (string[i] - split[i]))) *
                           temp.prob.e.old
        temp.prob.plot <- temp.prob.e.old - 
                          ((temp.prob.e.old - upcoming.prob.c) * split[i]/string[i]) 
        upcoming.event.old <- upcoming.events[i]
      } else if((n - cens.consec.vec[i]) <= i) {
        temp.prob.plot <- temp.prob.e.old - (temp.prob.e.old * split[i]/string[i])	
      }
	
      ## perform plotting for censored obs i 	
      if(len.cov > 1) {
        for(j in (1:(len.cov - 1))) {
          color <- switch(colors.cat[i, j], colors[1], colors[2], colors[3], colors[4], colors[5],
                          colors[6], colors[7], colors[8], colors[9], colors[10],
                          colors[11], colors[12], colors[13], colors[14], colors[15],
                          colors[16], colors[17], colors[18], colors[19], colors[20])
          polygon(x=c(covtime.cols[i,j], covtime.cols[i,j+1], covtime.cols[i,j+1], covtime.cols[i,j]), 
                  y=c(temp.prob.plot, temp.prob.plot, temp.prob.old, temp.prob.old), col=color)
        }
      }
	
      color <- switch(colors.cat[i, len.cov], colors[1], colors[2], colors[3], colors[4], colors[5],
                      colors[6], colors[7], colors[8], colors[9], colors[10],
                      colors[11], colors[12], colors[13], colors[14], colors[15],
                      colors[16], colors[17], colors[18], colors[19], colors[20])
      polygon(x=c(covtime.cols[i,len.cov], survtime.col[i], survtime.col[i], covtime.cols[i,len.cov]), 
              y=c(temp.prob.plot, temp.prob.plot, temp.prob.old, temp.prob.old), col=color)
      polygon(x=c(survtime.col[i], time.ahead[i], time.ahead[i], survtime.col[i]), 
              y=c(temp.prob.plot, temp.prob.plot, temp.prob.old, temp.prob.old), 
              density=cens.density, border=TRUE)	 

      ## Following was if(cens.mark.right == TRUE)  FEH 31jan03
      if(cens.mark.right & temp.prob.plot >= cens.mark.cutoff)
        text(x = time.ahead[i] + cens.mark.ahead, 
             y = temp.prob.old,  	
             labels = cens.mark, cex = cens.mark.cex) 
	
      temp.prob.c <- temp.prob.old <- temp.prob.plot
	    
      ## end censored if statement for plotting
    }
    ## end of function's major for loop
  }
  ## end of function itself
}
find.matches <- function(x, y, tol=rep(0,ncol(y)), scale=tol,
                         maxmatch=10)
{
  if(.R.) rep.int <- rep
  
  ##if(length(dim(x))==0) x <- matrix(x, nrow=1)  10may02
  if(!is.matrix(x))
    x <- as.matrix(x)
  
  n <- nrow(x)
  p <- ncol(x)
  if(!is.matrix(y))
    y <- as.matrix(y)  ## 10may02
  
  if(p != ncol(y))
    stop("number of columns of x and y must match")
  
  ny <- nrow(y)
  rown <- dimnames(x)[[1]]
  ry <- dimnames(y)[[1]]
  matches <- matrix(if(length(ry))
                      ""
                    else
                      0,
                    n, maxmatch,
                    dimnames=list(rown,
                                  paste("Match #",1:maxmatch,sep="")))
  
  distance <- matrix(NA, n, maxmatch,
                     dimnames=list(rown,
                                   paste("Distance #",1:maxmatch,sep="")))
  
  if(length(ry)==0)
    ry <- 1:ny

  scale <- ifelse(scale==0,1,tol)
  ones <- rep(1,p)
  mx <- 0
  for(i in 1:n) {
    dif <- abs(y - rep(x[i,], rep.int(ny,p)))
    toll <- rep(tol, rep.int(nrow(dif),p))
    which <- (1:ny)[((dif > toll) %*% ones)==0]
    lw <- length(which)
    if(lw) {
      scaled <- dif[which,,drop=FALSE]/rep(scale, rep.int(lw,p))
      dist <- (scaled^2) %*% ones
      lw <- min(lw,maxmatch)
      mx <- max(mx,lw)
      d <- order(dist)[1:lw]
      matches[i,1:lw] <- ry[which[d]]
      distance[i,1:lw] <- dist[d]
    }
  }
  
  structure(list(matches=matches[,1:mx], distance=distance[,1:mx]), 
            class="find.matches")
}


print.find.matches <- function(x, digits=.Options$digits, ...)
{
  cat("\nMatches:\n\n")
  print(x$matches, quote=FALSE)
  cat("\nDistances:\n\n")
  print(x$distance, digits=digits)
  invisible()
}


summary.find.matches <- function(object, ...)
{
  mat <- object$matches
  dist <- object$distance
  cat("Frequency table of number of matches found per observation\n\n")
  m <- (!is.na(dist)) %*% rep(1,ncol(mat))
  print(table(m))
  cat("\nMedian minimum distance by number of matches\n\n")
  print(tapply(dist[m>0,1], m[m>0], median))
  ta <- table(mat[m>0,1])
  ta <- ta[ta>1]
  if(length(ta)) {
    cat("\nObservations selected first more than once (with frequencies)\n\n")
    print(ta)
  } else cat("\nNo observations selected first more than once\n\n")
  
  invisible()
}


matchCases <- function(xcase,    ycase,    idcase=names(ycase),
                       xcontrol, ycontrol, idcontrol=names(ycontrol),
                       tol=NULL,
                       maxobs=max(length(ycase),length(ycontrol))*10,
                       maxmatch=20, which=c('closest','random'))
{
  if(!length(tol))
    stop('must specify tol')

  if((length(xcase)!=length(ycase)) || (length(xcontrol)!=length(ycontrol)))
    stop('lengths of xcase, ycase and of xcontrol, ycontrol must be same')

  which <- match.arg(which)
  
  ycase    <- as.matrix(ycase)
  ycontrol <- as.matrix(ycontrol)
  if(!length(idcase))
    idcase <- 1:length(ycase)
  
  if(!length(idcontrol))
    idcontrol <- 1:length(ycontrol)
  
  idcase    <- as.character(idcase)
  idcontrol <- as.character(idcontrol)
  
  j <- is.na(ycase %*% rep(1,ncol(ycase))) | is.na(xcase)
  if(any(j)) {
    warning(paste(sum(j),'cases removed due to NAs'))
    ycase <- ycase[!j,,drop=FALSE]
    xcase <- xcase[!j]
    idcase <- idcase[!j]
  }
  
  j <- is.na(ycontrol %*% rep(1,ncol(ycontrol))) | is.na(xcontrol)
  if(any(j)) {
    warning(paste(sum(j),'controls removed due to NAs'))
    ycontrol <- ycontrol[!j,,drop=FALSE]
    xcontrol <- xcontrol[!j]
    idcontrol <- idcontrol[!j]
  }

  idCase <- id <- character(maxobs)
  type   <- factor(rep(NA,maxobs), c('case','control'))
  x      <- numeric(maxobs)
  y      <- matrix(NA, ncol=ncol(ycase), nrow=maxobs)

  last <- 0
  ncase <- length(ycase)
  ncontrol <- length(ycontrol)
  matches  <- integer(ncase)
  for(i in 1:ncase) {
    s <- abs(xcontrol-xcase[i]) <= tol
    nmatch <- sum(s)
    if(nmatch > maxmatch) {
      s <- (1:ncontrol)[s]  ## next line was sample(j,...) 4jun02
      if(which=="random")
        s <- sample(s, maxmatch, replace=FALSE)
      else {
        errors <- abs(xcontrol[s]-xcase[i])
        serrors <- order(errors)
        s <- (s[serrors])[1:maxmatch]
      }
      
      nmatch <- maxmatch
    }
    
    matches[i] <- nmatch
    if(!nmatch)
      next
    
    end <- last + nmatch + 1
    if(end > maxobs)
      stop(paste('needed maxobs >',maxobs))

    start <- last+1
    last <- end
    idCase[start:end] <- rep(idcase[i], nmatch+1)
    type[start:end]   <- c('case',rep('control',nmatch))
    id[start:end]     <- c(idcase[i], idcontrol[s])
    x[start:end]      <- c(xcase[i], xcontrol[s])
    y[start:end,]     <- rbind(ycase[i,,drop=FALSE], ycontrol[s,,drop=FALSE])
  }

  cat('\nFrequencies of Number of Matched Controls per Case:\n\n')
  print(table(matches))
  cat('\n')
  structure(list(idcase=idCase[1:end], type=type[1:end],
                 id=id[1:end], x=x[1:end], y=drop(y[1:end,])),
            row.names=as.character(1:end),
            class='data.frame')
}
## Use R function for S-Plus, just changed to .Options
format.pval <- function (x, pv=x, digits = max(1, .Options$digits - 2),
                         eps = .Machine$double.eps, 
                         na.form = "NA", ...) {
  if ((has.na <- any(ina <- is.na(pv)))) 
    pv <- pv[!ina]
    
  r <- character(length(is0 <- pv < eps))
  if (any(!is0)) {
    rr <- pv <- pv[!is0]
    expo <- floor(log10(ifelse(pv > 0, pv, 1e-50)))
    fixp <- expo >= -3 | (expo == -4 & digits > 1)
    if (any(fixp)) 
      rr[fixp] <- format(round(pv[fixp], digits = digits),
                         ...)
    if (any(!fixp)) 
      rr[!fixp] <- format(round(pv[!fixp], digits = digits),
                          ...)
    r[!is0] <- rr
  }
    
  if (any(is0)) {
    digits <- max(1, digits - 2)
    if (any(!is0)) {
      nc <- max(nchar(rr))
      if (digits > 1 && digits + 6 > nc) 
        digits <- max(1, nc - 7)
      sep <- if (digits == 1 && nc <= 6) 
        ""
      else " "
    }
    else sep <- if(digits == 1) 
      ""
    else " "
    
    r[is0] <- paste("<", format(eps, digits = digits, ...), sep = sep)
  }
  if (has.na) {
    rok <- r
    r <- character(length(ina))
    r[!ina] <- rok
    r[ina] <- na.form
  }
  r
}
##Dan Heitjan  dheitjan@biostats.hmc.psu.edu

ftupwr <- function(p1,p2,bign,r,alpha)
{
  ## Compute the power of a two-sided level alpha test of the
  ## hypothesis that pi1=pi2, when pi1=p1, pi2=p2, and there are
  ## bign observations, bign/(1+r) in group 1 and r*bign/(1+r) in
  ## group 2.  This is based on the two-tailed test version of
  ## formula (6) in Fleiss, Tytun and Ury (1980 Bcs 36, 343--346).
  ## This may be used for del not too small (del>=0.1) and r not
  ## too big or small (0.33<=r<=3).
  ##   Daniel F. Heitjan, 30 April 1991
  mstar <- bign/(r+1)
  del <- abs(p2-p1)
  rp1 <- r+1
  zalp <- qnorm(1-alpha/2)
  pbar <- (p1+r*p2)/(1+r)
  qbar <- 1-pbar
  num <- (r*del^2*mstar-rp1*del)^0.5-zalp*(rp1*pbar*qbar)^0.5
  den <- (r*p1*(1-p1)+p2*(1-p2))^0.5
  zbet <- num/den
  pnorm(zbet)
}


ftuss <- function(p1,p2,r,alpha,beta)
{
  ## Compute the approximate sample size needed to have power 1-beta
  ## for detecting significance in a two-tailed level alpha test of
  ## the hypothesis that pi1=pi2, when pi1=p1, pi2=p2, and there
  ## are to be m in group 1 and rm in group 2.  The calculation is
  ## based on equations (3) and (4) of Fleiss, Tytun and Ury (1980
  ## Bcs 36, 343--346).  This is accurate to within 1% for
  ## moderately large values of del(p2-p1) (del>=0.1) and sample
  ## sizes that are not too disproportionate (0.5<=r<=2).
  ##   Daniel F. Heitjan, 30 April 1991
  zalp <- qnorm(1-alpha/2)
  zbet <- qnorm(1-beta)
  rp1 <- (r+1)
  pbar <- (p1+r*p2)/rp1
  qbar <- 1-pbar
  q1 <- 1-p1
  q2 <- 1-p2
  del <- abs(p2-p1)
  num <- (zalp*(rp1*pbar*qbar)^0.5+zbet*(r*p1*q1+p2*q2)^0.5)^2
  den <- r*del^2
  mp <- num/den
  m <- 0.25*mp*(1+(1+2*rp1/(r*mp*del))^0.5)^2
  list(n1=floor(m+1),n2=floor(m*r+1))
}
gbayes <- function(mean.prior, var.prior, m1, m2, stat, var.stat,
                   n1, n2, cut.prior, cut.prob.prior=.025)
{
  if(!missing(cut.prior)) 
    var.prior <- ((cut.prior - mean.prior)/qnorm(1 - cut.prob.prior))^2

  if(!is.function(var.stat)) {
    vs <- var.stat
    if(!missing(n1))
      stop('may not specify n1,n2 when var.stat is not a function')
  } else
    vs <- var.stat(m1,m2)

  var.post <- 1/(1/var.prior + 1/vs)
  mean.post <- (mean.prior/var.prior + stat/vs)*var.post
  result <- list(mean.prior=mean.prior, var.prior=var.prior, 
                 mean.post=mean.post,   var.post=var.post)

  if(!missing(n1)) {
    mean.pred <- mean.post
    var.pred <- var.post + var.stat(n1,n2)
    result$mean.pred <- mean.pred
    result$var.pred  <- var.pred
  }
  
  structure(result, class='gbayes')
}


plot.gbayes <- function(x, xlim, ylim, name.stat='z', ...)
{
  obj <- x
  pred <- length(obj$mean.pred)>0
  if(missing(xlim))
    xlim <- obj$mean.post + c(-6,6)*sqrt(obj$var.post)

  x <- seq(xlim[1], xlim[2], length=200)
  y1 <- dnorm(x,obj$mean.prior,sqrt(obj$var.prior))
  y2 <- dnorm(x,obj$mean.post, sqrt(obj$var.post))
  plot(x, y1, xlab=name.stat, ylab='Density',type='l',lty=1,
       ylim=if(missing(ylim))
              range(c(y1,y2))
            else
              ylim)
  
  curves <- vector('list',2+pred)
  names(curves) <- c('Prior','Posterior',
                     if(pred)'
                       Predictive')
  
  curves[[1]] <- list(x=x,y=y1)
  lines(x, y2, lty=2)
  curves[[2]] <- list(x=x,y=y2)
  if(pred) {
    y <- dnorm(x,obj$mean.pred,sqrt(obj$var.pred))
    lines(x, y, lty=3)
    curves[[3]] <- list(x=x,y=y)
  }
  
  labcurve(curves, ...)
  invisible()
}


gbayes2 <- function(sd, prior, delta.w=0, alpha=0.05,
                    upper=Inf, prior.aux=NULL)
{
  if(!is.function(prior))
    stop('prior must be a function')

  z <- qnorm(1-alpha/2)
  prod <- function(delta, prior, delta.w, sd, z, prior.aux)
  {
    (1 - pnorm((delta.w - delta)/sd + z)) *
      if(length(prior.aux))
        prior(delta, prior.aux)
      else
        prior(delta)
  }
  
  ww <-
    if(.R.)
      'value'
    else
      'integral'

  ip <- if(length(prior.aux))
    integrate(prior, -Inf, upper, prior.aux=prior.aux)[[ww]]
  else
    integrate(prior, -Inf, upper)[[ww]]
  
  if(abs(ip-1) > .01)
    warning(paste('integrate failed to obtain 1.0 for integral of prior.\nDivided posterior probability by the integral it did obtain (',
                  format(ip),').\nTry specifying upper=.',sep=''))
  integrate(prod, delta.w, upper,
            prior=prior, delta.w=delta.w, sd=sd, z=z,
            prior.aux=prior.aux)[[ww]]
}


## v = variance of Xn after future obs.
gbayesMixPredNoData <- function(mix=NA, d0=NA, v0=NA, d1=NA, v1=NA,
                                what=c('density','cdf'))
{
  what <- match.arg(what)
  g <- function(delta, v, mix, d0, v0, d1, v1, dist)
  {
    if(mix==1) {
      pv <- 1/(1/v0 + 1/v)
      dist(delta, d0, sqrt(pv))
    } else if(mix==0) {
      pv <- 1/(1/v1 + 1/v)
      dist(delta, d1, sqrt(pv))
    } else {
      pv0 <- 1/(1/v0 + 1/v)
      pv1 <- 1/(1/v1 + 1/v)
      mix*dist(delta, d0, sqrt(pv0)) +
        (1-mix)*dist(delta, d1, sqrt(pv1))
    }
  }

  ##g$mix <- mix; g$d0 <- d0; g$v0 <- v0; g$d1 <- d1; g$v1 <- v1 10may02
  ##g$dist <- switch(what, density=dnorm, cdf=pnorm)
  formals(g) <- list(delta=numeric(0), v=NA, mix=mix, d0=d0, v0=v0,
                     d1=d1, v1=v1, dist=NA)
  g
}


##mp <- function(d,mix,d0,v0,d1,v1,what=c('density','cdf')) {
##  what <- match.arg(what)
##  f <- switch(what, density=dnorm, cdf=pnorm)
##  plot(d,mix*f(d,d0,sqrt(v0))+(1-mix)*f(d,d1,sqrt(v1)),
##       type='l', lwd=3)
##  invisible()
##}


gbayesMixPost <- function(x=NA, v=NA, mix=1, d0=NA, v0=NA, d1=NA,
                          v1=NA, what=c('density','cdf'))
{
  what <- match.arg(what)
  g <- function(delta, x, v, mix=1, 
                d0, v0, d1, v1, dist)
  {
    if(mix==1) {
      pv <- 1/(1/v0 + 1/v)
      dist(delta, (d0/v0 + x/v)*pv, sqrt(pv))
    } else if(mix==0) {
      pv <- 1/(1/v1 + 1/v)
      dist(delta, (d1/v1 + x/v)*pv, sqrt(pv))
    } else {
      prior.odds <- mix/(1-mix)
      pv0 <- 1/(1/v0 + 1/v);
      pv1 <- 1/(1/v1 + 1/v)
      likelihood.ratio <- dnorm(x, d0, sqrt(v0))/
                          dnorm(x, d1, sqrt(v1))
      post.odds <- prior.odds * likelihood.ratio
      mixp <- post.odds/(1+post.odds)
      mixp*dist(delta, (d0/v0 + x/v)*pv0, sqrt(pv0)) +
        (1-mixp)*dist(delta, (d1/v1 + x/v)*pv1, sqrt(pv1))
    }
  }

  ##g$x <- x; g$v <- v; g$mix <- mix; g$d0 <- d0; g$v0 <- v0;
  ##g$d1 <- d1; g$v1 <- v1
  ##g$dist <- switch(what, density=dnorm, cdf=pnorm)  10may02
  formals(g) <- list(delta=numeric(0), x=x, v=v, mix=mix, d0=d0, v0=v0,
                     d1=d1, v1=v1,
                     dist=switch(what,
                                 density=dnorm,
                                 cdf=pnorm))
  
  g
}


gbayesMixPowerNP <- function(pcdf, delta, v, delta.w=0, mix, interval,
                             nsim=0, alpha=0.05)
{
  if(nsim==0) {
    ## Solve for statistic x such that the posterior cdf at
    ## (delta.w,x)=alpha/2
    g <- function(x, delta.w, v, alpha, pcdf, mix)
    {
      pcdf(delta.w, x, v, mix) - alpha/2
    }
    
    ##g$delta.w <- delta.w; g$v <- v; g$alpha <- alpha; g$pcdf <- pcdf
    ##g$mix <- if(missing(mix)) pcdf$mix else mix  10may02
    formals(g) <- list(x=numeric(0), delta.w=delta.w, v=v,
                       alpha=alpha, pcdf=pcdf,
                       mix=if(missing(mix))
                             (if(.R.)
                                as.list(pcdf)$mix
                              else
                                pcdf$mix)
                           else
                             mix)

    ##s <- seq(interval[1],interval[2],length=100)
    ##gs <- g(s)
    ##plot(s, gs, type='l')
    ##interval[2] <- min(s[sign(gs)!=sign(gs[1])])
    ##interval[1] <- max(s[s < interval[2] & sign(gs)==sign(gs[1])])
    ##interval[1] <- max(s[sign(gs)!=sign(gs[100])])
    ##interval[2] <- min(s[s > interval[1] & sign(gs)==sign(gs[100])])
    ##prn(interval)

    x <- uniroot(g, interval=interval)$root
    c('Critical value'=x, Power=1 - pnorm(x, delta, sqrt(v)))
  } else {
    x <- rnorm(nsim, delta, sqrt(v))
    probs <-
      if(missing(mix))
        pcdf(delta.w, x, v)
      else
        pcdf(delta.w, x, v, mix=mix)
    
    pow <- mean(probs <= alpha/2)
    se <- sqrt(pow*(1-pow)/nsim)
    c(Power=pow, 'Lower 0.95'=pow-1.96*se, 'Upper 0.95'=pow+1.96*se)
  }
}


gbayes1PowerNP <- function(d0, v0, delta, v, delta.w=0, alpha=0.05)
{
  pv <- 1/(1/v0 + 1/v)
  z <- qnorm(alpha/2)
  1 - pnorm(v*( (delta.w - sqrt(pv)*z)/pv - d0/v0 ), delta, sqrt(v))
}
###  These are function that are designed to compatibility with S-plus
###  for R internationalization.  They are named with a prefix of
###  "Splus".
###
###  These functions contain representations of sprintf, gettext,
###  gettextf, and ngettext


if(!exists("sprintf")) sprintf <- function(fmt, ...) {
  ldots <- list(...)

  text <- vector("character")
  vars <- vector("character")
  i <- 1; j <- 1;
  temp <- fmt
  while (nchar(temp)) {
    ne <- regexpr('(?<!%)%[^%]*?[dixXfeEgGs]', temp, perl=TRUE)
    if( ne < 0 ) {
      text[i] <- gsub('%%', '%', temp)
      temp <- ""
    } else {
      text[i] <- gsub('%%', '%', substr(temp, 0, ne-1))
      i <- i + 1
      vars[j] <- substr(temp, ne+1, ne+attr(ne, "match.length")-1)
      j <- j + 1
      temp <- substr(temp, ne+attr(ne, "match.length"), nchar(temp))
    }
  }

  output <- NULL
  j <- 1
  for( i in 1:(length(text) - 1)) {
    output <- paste(output, text[i], sep='')
    if(regexpr('^\\d+\\$', vars[i], perl=TRUE) > 0){
      arg <- sub('^(\\d+)\\$.*$', '\\1', vars[i], perl=TRUE)
      if(arg > 0 && arg < length(ldots)) {
        val <- as.integer(arg)
      }
      else
        stop("Error")
    }
    else {
      val <- j
      j <- j + 1
    }
    output <- paste(output, ldots[[val]], sep='')
  }
  return(paste(output, text[length(text)], sep=''))
}

if(!exists("gettext")) gettext <- function(..., domain=NULL)
    return(unlist(list(...)))


if(!exists("gettextf")) gettextf <- function(fmt, ..., domain=NULL) {
  return(sprintf(fmt, ...))
}

if(!exists("ngettext")) ngettext <- function(n, msg1, msg2, domain = NULL) {
  if(n == 1)
    return(msg1)
  return(msg2)
}
groupn <- function(x, y, m=150)
{
  s <- !is.na(x + y)
  x<-x[s]
  y<-y[s]
  i<-order(x)
  x<-x[i]
  y<-y[i]
  n<-length(x)
  if(n<m)
    stop("m<number of observations in groupn")
  
  start <- 1
  end <- m
  meanx <- NULL
  meany <- NULL
  while(end <= n) {
    meanx <- c(meanx,mean(x[start:end]))
    meany <- c(meany,mean(y[start:end]))
    start <- start+m
    end <- end+m
  }
  
  if(end > n) {
    meanx <- c(meanx,mean(x[n-m+1:n]))
    meany <- c(meany,mean(y[n-m+1:n]))
  }
  
  return(list(x=meanx,y=meany))
}
hist.data.frame <- function(x, n.unique=3, nclass="compute", na.big=FALSE,
                            rugs=FALSE, mtitl=FALSE, ...)
{
  oldmf  <- par('mfrow')
  oldoma <- par('oma')
  oldmar <- par('mar')  # resetting mfrow causes a new mar
  on.exit(par(mfrow=oldmf, oma=oldoma, mar=oldmar))
  mf <- oldmf
  if(length(mf)==0)
    mf <- c(1,1)

  automf <- FALSE  ## 22sep02
  if((la <- length(x))>1 & max(mf)==1) {
    mf <-
      if(la<=4)
        c(2,2)
      else if(la<=6)
        c(2,3)
      else if(la<=9)
        c(3,3)
      else if(la<=12)
        c(3,4)
      else if(la<=16)
        c(4,4)
      else
        c(4,5)
    
    automf <- TRUE
    par(mfrow=mf)
  }
  
  if(is.character(mtitl))
    par(oma=c(0,0,3,0))

  nam <- names(x)
  i <- 0
  j <- 0
  for(v in x) {
    j <- j+1
    type <-
      if(is.character(v) || is.factor(v))
        'cat'
      else if(inherits(v,'dates'))
        'date'
      else
        'none'
    
    lab <- attr(v,"label")
    lab <-
      if(length(lab) && nchar(lab) > 35)
        nam[j]
      else
        label(v, units=TRUE, plot=type!='cat', default=nam[j])
    
    if(type=='cat') {
      tab <- -sort(-table(v))
      dotchart2(tab, xlab=paste('Frequencies for', lab), reset.par=TRUE)
    } else {
      type <-
        if(inherits(v,'dates'))
          'date'
        else
          'none'
      
      if(type!='none')
        v <- oldUnclass(v)
      
      w <- v[!is.na(v)]
      n <- length(w)
      if(length(unique(w)) >= n.unique) {
        i <- i+1
        if(is.numeric(nclass))
          nc <- nclass else

        if(nclass=="compute")
          nc <- max(2,trunc(min(n/10,25*logb(n,10))/2))

        if(.R.) {
          if(nclass!="default")
            hist(v,nclass=nc, xlab=lab, axes=type!='date', main='')
          else
            hist(v,xlab=lab, axes=type!='date', main='')
        } else {
          if(nclass!="default")
            hist(v, nclass=nc, xlab=lab, style.bar='old',
                 axes=type!='date')
          else
            hist(v,xlab=lab,style.bar='old', axes=type!='date')
        }
        
        if(type=='date') {
          axis(2)
          r <- range(v, na.rm=TRUE)
          by <- round((r[2]-r[1])/(par('lab')[2] - 1))
          at <- seq(r[1], r[2], by=by)
          axis(1, at=at, labels=format(chron(at)))
        }
      
        m <- sum(is.na(v))
        pm <- paste("n:",n," m:",m,sep="")
        title(sub=pm,adj=0,cex=.5)
        if(na.big && m>0)
          mtext(paste(m,"NAs"),line=-2,cex=1)

        if(rugs)
          scat1d(v, ...)
        
        if(automf && interactive() &&
           names(dev.list())!='postscript' &&
           (i %% prod(mf)==0)) {
          if(is.character(mtitl))
            mtitle(mtitl)
          
          cat("click left mouse button to proceed\n")
          locator(1)
        } else if(is.character(mtitl) && i %% prod(mf)==1)
          mtitle(mtitl)
      }
    }
  }
  
  invisible(ceiling(i / prod(mf)))
}
"histbackback"<-
  function(x, y, brks = NULL, xlab = NULL, axes = TRUE, probability = FALSE, 
           xlim = NULL, ylab='',...)
{
  if(length(xlab))
    xlab <- rep(xlab, length = 2)
  
  if(is.list(x)) {
    namx <- names(x)  # FEH 5Jan99
    y <- x[[2]]   # was x$y  FEH
    if(!length(xlab)) {
      if(length(namx))
        xlab <- namx[1:2]
      else {   #FEH
        xlab <- deparse(substitute(x))
        xlab <- paste(xlab, c("x", "y"), sep = "$")
      }
    }

    x <- x[[1]]   # was x$x FEJ
  } else if(!length(xlab))
    xlab <- c(deparse(substitute(x)), deparse(substitute(y)))
  
  if(!length(brks))
    brks <- hist(c(x, y), plot = FALSE)$breaks

  if(.R.) {
    ll <- hist(x, breaks = brks, plot = FALSE)
    rr <- hist(y, breaks = brks, plot = FALSE)

    if(probability) {
      ll$counts <- ll$density
      rr$counts <- rr$density
    }
  } else {
    ll <- hist(x, breaks = brks, plot = FALSE, probability = probability)
    rr <- hist(y, breaks = brks, plot = FALSE, probability = probability)
  }

  if(length(xlim) == 2)
    xl <- xlim
  else {
    xl <- pretty(range(c( - ll$counts, rr$counts)))  ## 1Dec01
    xl <- c(xl[1],xl[length(xl)])
  }
      
  if(length(ll$counts) > 0) {
    if(.R.)
      barplot(-ll$counts, xlim=xl, space=0,
              horiz=TRUE, axes=FALSE, col=0, ...)
    else
      barplot( - ll$counts, brks, xlim = xl, histo = TRUE, horiz = TRUE, 
              axes = FALSE, ...)
    
    par(new = TRUE)
  }

  if(length(rr$counts) > 0) {
    if(.R.)
      barplot(rr$counts, xlim=xl, space=0,
              horiz=TRUE, axes=FALSE, col=0, ...)
    else
      barplot(rr$counts, brks, xlim = xl, histo = TRUE, horiz = TRUE, axes
              = FALSE, ...)
  }

  if(axes) {
    mgp.axis(1, at=pretty(xl), labels=format(abs(pretty(xl))))  ##FEH
    if(.R.) {
      del <- (brks[2]-brks[1] - (brks[3]-brks[2]))/2
      brks[1] <- brks[1] + del
      brks[-1] <- brks[-1] - del
      mgp.axis(2, at=0:(length(brks)-1),
               labels=formatC(brks, format='f', digits=.Options$digits))
    } else
      mgp.axis(2)
    
    title(xlab = xlab[1], adj = (-0.5 * xl[1])/( - xl[1] + xl[2]))
    title(xlab = xlab[2], adj = (-xl[1] + 0.5 * xl[2])/(-xl[1] + xl[2]))
    if(ylab!='')
      title(ylab=ylab)   # FEH
  }
  
  abline(v = 0)
  box()
  invisible(list(left = ll$counts, right = rr$counts, breaks = brks))
}
## Changes since sent to statlib: improved printing N matrix in print.hoeffd
hoeffd <- function(x, y)
{
  phoeffd <- function(d, n)
  {
    d <- as.matrix(d); n <- as.matrix(n)
    b <- d + 1/36/n
    z <- .5*(pi^4)*n*b
    zz <- as.vector(z)
    zz[is.na(zz)] <- 1e30   # so approx won't bark
 
    tabvals <- c(5297,4918,4565,4236,3930,
                 3648,3387,3146,2924,2719,2530,2355,
                 2194,2045,1908,1781,1663,1554,1453,
                 1359,1273,1192,1117,1047,0982,0921,
                 0864,0812,0762,0716,0673,0633,0595,
                 0560,0527,0496,0467,0440,0414,0390,
                 0368,0347,0327,0308,0291,0274,0259,
                 0244,0230,0217,0205,0194,0183,0173,
                 0163,0154,0145,0137,0130,0123,0116,
                 0110,0104,0098,0093,0087,0083,0078,
                 0074,0070,0066,0063,0059,0056,0053,
                 0050,0047,0045,0042,0025,0014,0008,
                 0005,0003,0002,0001)/10000

    P <- ifelse(z<1.1 | z>8.5, pmax(1e-8,pmin(1,exp(.3885037-1.164879*z))),
                matrix(approx(c(seq(1.1, 5,by=.05),
                                seq(5.5,8.5,by=.5)),
                              tabvals, zz)$y,
                       ncol=ncol(d)))

    dimnames(P) <- dimnames(d)
    P
  }
  
  if(!missing(y))
    x <- cbind(x, y)
  
  x[is.na(x)] <- 1e30
  storage.mode(x) <-
    if(.R.)
      "double"
    else
      "single"
  
  p <- as.integer(ncol(x))
  if(p<1)
    stop("must have >1 column")
  
  n <- as.integer(nrow(x))
  if(n<5)
    stop("must have >4 observations")

  h <-
    if(.R.)
      .Fortran("hoeffd", x, n, p, hmatrix=double(p*p), npair=integer(p*p),
               double(n), double(n),  double(n), double(n), double(n), 
               double(n), integer(n), PACKAGE="Hmisc")
    else
      .Fortran("hoeffd", x, n, p, hmatrix=single(p*p), npair=integer(p*p),
               single(n), single(n),  single(n), single(n), single(n), 
               single(n), integer(n))
  
  npair <- matrix(h$npair, ncol=p)
  h <- matrix(h$hmatrix, ncol=p)
  h[h>1e29] <- NA
  nam <- dimnames(x)[[2]]
  dimnames(h) <- list(nam, nam)
  dimnames(npair) <- list(nam, nam)
  P <- phoeffd(h, npair)
  diag(P) <- NA
  structure(list(D=30*h, n=npair, P=P), class="hoeffd")
}


print.hoeffd <- function(x, ...)
{
  cat("D\n")
  print(round(x$D,2))
  n <- x$n
  if(all(n==n[1,1]))
    cat("\nn=",n[1,1],"\n")
  else {
    cat("\nn\n")
    print(x$n)
  }
  
  cat("\nP\n")
  P <- x$P
  P <- ifelse(P<.0001,0,P)
  p <- format(round(P,4))
  p[is.na(P)] <- ""
  print(p, quote=FALSE)
  invisible()
}
impute <- function(x, ...) UseMethod("impute")


impute.default <- function(x, fun=median, ...)
{
  m <- is.na(x)
  k <- sum(m)
  if(k==0)
    return(x)

  nam <- names(x)
  if(!length(nam)) {
    nam <- as.character(1:length(x)); names(x) <- nam
  }

  if(!is.function(fun)) {
    fill <- fun
    if(is.character(fill) && length(fill)==1 && fill=="random")
      fill <- sample(x[!is.na(x)], sum(is.na(x)), replace=TRUE)
  } else if(is.factor(x)) {
    freq <- table(x)
    fill <- names(freq)[freq==max(freq)][1]   #take first if not unique
  } else
    fill <-
      if(missing(fun) && is.logical(x))
        (if(sum(x[!m]) >= sum(!m)/2)
           TRUE
         else
           FALSE)
      else
        fun(x[!m])
          
  ## median(logical vector) doesn't work - know trying to get median
  ## if fun is omitted.  Get mode.

  if(length(fill)>1 && length(fill)!=k)
    stop("length of vector of imputed values != no. NAs in x")

  ## lab <- label(x)
  ## if(is.null(lab) || lab=="") lab <- name
  ## lab <- paste(lab,"with",sum(m),"NAs imputed to",format(fill))
  ## attr(x, "label") <- lab
  if(is.factor(x)) {
    newlev <- sort(unique(fill))
    if(any(!(z <- newlev %in% levels(x)))) {
      xc <- as.character(x)
      xc[m] <- fill
      x <- factor(xc, c(levels(x), newlev[!z]))
    } else x[m] <- fill
  } else x[m] <- fill
  
  ## .SV4. x 2 5may03
  if(.SV4.)
    warning('impute class not added to object because of S-Plus 6 restrictions; will not print or subset imputation information')
  
  structure(x, imputed=(1:length(x))[m],
            class=c(if(!.SV4.)'impute',attr(x,'class')))
}


print.impute <- function(x, ...)
{
  i <- attr(x,"imputed")
  if(!length(i)) {
    print.default(x);
    return(invisible())
  }
  
  if(is.factor(x))
    w <- as.character(x)
  else
    w <- format(x)
  
  names(w) <- names(x)
  w[i] <- paste(w[i], "*", sep="")
  attr(w, "label") <- attr(w,"imputed") <- attr(w, "class") <- NULL
  print.default(w, quote=FALSE)
  invisible()
}


summary.impute <- function(object, ...)
{
  i <- attr(object, "imputed")
  oi <- object
  attr(oi,'class') <- attr(oi,'class')[attr(oi,'class')!="impute"]
  oi <- oi[i]
  if(all(oi==oi[1]))
    cat("\n",length(i),"values imputed to",
        if(is.numeric(oi))
          format(oi[1])
        else
          as.character(oi[1]),
        "\n\n")
  else {
    cat("\nImputed Values:\n\n")
    if(length(i)<20)
      print(oi)
    else
      print(describe(oi, descript=as.character(sys.call())[2]))
    
    cat("\n")
  }
  
  NextMethod("summary")
}


"[.impute" <- function(x, ..., drop=FALSE)
{
  ats <- attributes(x)
  ats$dimnames <- NULL
  ats$dim <- NULL
  ats$names <- NULL
  attr(x,'class') <- NULL
  y <- x[..., drop = drop]
  if(length(y)==0)
    return(y)
  
  k <- 1:length(x);
  names(k) <- names(x)
  k <- k[...]
  attributes(y) <- c(attributes(y), ats)
  imp <- attr(y, "imputed")
  attr(y, "imputed") <- j <- (1:length(k))[k %in% imp]
  if(length(j)==0) {
    cy <- attr(y,'class')[attr(y,'class')!='impute']
    y <- structure(y, imputed=NULL,
                   class=if(length(cy))
                           cy
                         else
                           NULL)
  }
  
  y
}


is.imputed <- function(x)
{
  w <- rep(FALSE, length(x))
  if(length(z <- attr(x,"imputed")))
    w[z] <- TRUE
  
  w
}


as.data.frame.impute <- function(x, row.names = NULL, optional = FALSE, ...)
{
  nrows <- length(x)
  if(!length(row.names)) {
    ## the next line is not needed for the 1993 version of data.class and is
    ## included for compatibility with 1992 version
    if(length(row.names <- names(x)) == nrows &&
                           !any(duplicated(row.names))) {
    } else if(optional)
      row.names <- character(nrows)
    else
      row.names <- as.character(1:nrows)
  }
  
  value <- list(x)
  if(!optional)
    names(value) <- deparse(substitute(x))[[1]]
  
  structure(value, row.names=row.names, class='data.frame')
}
"%nin%" <- function(a, b) ! (a %in% b)
"inc<-" <- function(x, value) {
  x + value
}

"dec<-" <- function(x, value) {
  x - value
}

is.present <- function(x)
{
  if(is.character(x))
    return(x!="")
  else
    return(!is.na(x))
}
james.stein <- function(y, group)
{
  s <- !(is.na(y)|is.na(group))
  y <- y[s];
  group <- as.character(group[s])
  ## as.char -> unused levels OK
  k <- length(unique(group))
  if(k<3)
    stop("must have >=3 groups")
  
  stats <- function(w) {
    bar <- mean(w)
    ss  <- sum((w-bar)^2)
    n <- length(w)
    ##if(n<2)
    ##  stop("a group has n<2")
    
    c(n=length(w), mean=bar, ss=ss, var=ss/n/(n-1))
  }

  Z <- stats(y)
  st <- tapply(y, group, FUN=stats)
  nams <- names(st)
  z <- matrix(unlist(st),ncol=4,byrow=TRUE)
  ssb <- stats(z[,2])["ss"]
  shrink <- 1 - (k-3)*z[,4]/ssb
  shrink[z[,1]==1] <- 0
  shrink <- pmin(pmax(shrink,0),1)
  list(n=z[,1], mean=z[,2], 
       shrunk.mean=structure(Z["mean"]*(1-shrink)+shrink*z[,2], names=nams),
       shrink=shrink)
}
## $Id: labcurve.s 208 2005-07-12 22:01:34Z dupontct $

labcurve <- function(curves, labels=names(curves), 
                     method=NULL, keys=NULL, keyloc=c('auto','none'),
                     type='l', step.type=c('left','right'),
                     xmethod=if(any(type=='s')) 'unique' else 'grid', 
                     offset=NULL,
                     xlim=NULL, tilt=FALSE, window=NULL,
                     npts=100, cex=NULL, 
                     adj='auto', angle.adj.auto=30, 
                     lty=pr$lty, lwd=pr$lwd, col.=pr$col,
                     transparent=TRUE, arrow.factor=1, 
                     point.inc=NULL, opts=NULL, key.opts=NULL, 
                     empty.method=c('area','maxdim'), 
                     numbins=25, 
                     pl=!missing(add), add=FALSE, 
                     ylim=NULL, xlab="", ylab="",
                     whichLabel=1:length(curves),
                     grid=FALSE, xrestrict=NULL, ...)
{
  if(grid && !.R.) {
    ##warning('specified grid=T under S-Plus, ignored')
    grid <- FALSE
  }

  if(.R. && pl && !add) {
    plot.new(); par(new=TRUE)  # enables strwidth etc.
  }
  
  ## added !add 11dec02

  if(.R.) {
    oxpd <- par('xpd')
    par(xpd=NA)
    on.exit(par(xpd=oxpd))
  }
  
  gfun <- ordGridFun(.R. && grid)    ## see Misc.s
  gun  <- gfun$unit

  diffu <- function(v) diff(oldUnclass(v))  # mainly for POSIXt 17jun02
  ## also look at difftime
  
  mcurves <- missing(curves)

  pr <- par(c('cex','col','lwd','lty'))

  if(!mcurves) {
    nc <- length(curves)
    type <- rep(type, length=nc)
    lty  <- rep(lty,  length=nc)
    lwd  <- rep(lwd,  length=nc)
    col. <- rep(col., length=nc)
    for(i in 1:nc) {
      z <- curves[[i]]
      if(pl && !add) {
        if(i==1) {
          xlm <- range(z[[1]],na.rm=TRUE)
          ylm <- range(z[[2]],na.rm=TRUE)
        } else {
          xlm <- range(xlm,z[[1]],na.rm=TRUE)
          ylm <- range(ylm,z[[2]],na.rm=TRUE)
        }
      }
      if(length(a <- z$type))
        type[i] <- a
      
      if(length(a <- z$lty))
        lty[i]  <- a
      
      if(length(a <- z$lwd))
        lwd[i]  <- a
      
      if(length(a <- z$col))
        col.[i] <- a
    }
  }

  ## Optionally bring arguments from opts as if they were listed outside opts
  ## This is used when opts is passed through to a function calling labcurve
  if(length(opts) && is.list(opts)) {
    names.opts <- names(opts)
    full.names <- c('labels','method','keys','keyloc','type','step.type',
                    'xmethod','offset','xlim','tilt','window','npts','cex',
                    'adj','angle.adj.auto','lty','lwd','col.','n.auto.keyloc',
                    'transparent','arrow.factor','point.inc','key.opts',
                    'empty.method','numbins','ylim','xlab','ylab')
    i <- charmatch(names.opts, full.names, -1)
    if(any(i < 1))
      stop(paste('Illegal elements in opts:',
                 paste(names.opts[i < 1], collapse=' ')))
    
    for(j in 1:length(opts)) assign(full.names[i[j]],opts[[j]],immediate=TRUE)
  }

  if(mcurves)
    nc <- length(labels)
  else if(!is.logical(labels) && nc != length(labels))
    stop('length of labels is not equal to # curves')  #28Nov99

  type <- rep(type, length=nc)
  lty  <- rep(lty,  length=nc)
  lwd  <- rep(lwd,  length=nc)
  col. <- rep(col., length=nc)

  if(pl) {
    if(mcurves)
      stop('curves must be given if pl=T')
    
    if(!add) {
      if(!length(xlim))
        xlim <- xlm
      
      if(!length(ylim))
        ylim <- ylm
      
      namcur <- names(curves[[1]])   #13Jul97
      if(!is.expression(xlab) && xlab=='' && length(namcur))
        xlab <- namcur[1]
      
      if(!is.expression(ylab) && ylab=='' && length(namcur))
        ylab <- namcur[2]
      
      if(grid) {
        stop("grid=TRUE when pl=TRUE is not yet implemented")
      } else
        plot(0, 0, xlim=xlim, ylim=ylim, xlab=xlab, ylab=ylab,
             type='n', xaxt='n')  ## xaxt 15jun02
      
      if(inherits(xlim,'POSIXt') || inherits(xlim,'POSIXct'))
        axis.POSIXct(1)
      else if(inherits(xlim,'Date'))
        axis.Date(1)
      else
        axis(1)  ## 15jun02 18sep02
            
      pr <- par(c('cex','col','lwd','lty'))
    }
    
    for(i in 1:nc) {
      z <- curves[[i]]
      gfun$lines(z[[1]], z[[2]], type=type[i], lty=lty[i],
                 lwd=lwd[i], col=col.[i])
    }
  }

  if(length(method) && method=='none')
    return(invisible()) # 29sep02

  pr <- parGrid(grid)  ## 20Mar02
  usr <- pr$usr; uin <- pr$uin
  
  is.keys    <- length(keys) > 0
  lines.keys <- length(keys)==1 && is.character(keys) && keys=='lines'

  if(!length(method)) {
    if(is.keys)
      method <-
        if(is.numeric(keys) || lines.keys)
	  'on top'
        else
          'offset'
    else
      method <- 'offset'
  }

  ## Expand abbreviations for method - couldn't use match.arg
  possible.methods <- c('offset','on top','arrow','mouse','locator')
  i <- charmatch(method, possible.methods, -1)
  if(i < 1)
    stop(paste('method must be one of ',
               paste(possible.methods,collapse=' ')))
  
  method <- possible.methods[i]
  
  if(!length(cex))
    cex <- pr$cex

  if(mcurves && method %nin% c('mouse','locator')) 
    stop('must specify curves unless method="mouse" or "locator"')

  if(!lines.keys && is.keys && length(keys) != nc) 
    stop('number of keys must = number of curves')

  if(method %in% c('mouse','locator')) {
    if(adj=='auto')
      adj <- .5
    
    xt <- yt <- numeric(nc)
    for(i in 1:nc) {
      if(i %in% whichLabel) {  ## 17sep02
        cat('\nPosition pointer to desired center of curve label and click for',
            labels[i],'\n')
        lab.pos <- locator(1)
        xt[i] <- lab.pos$x
        yt[i] <- lab.pos$y
        gfun$text(lab.pos, labels[i], cex=cex, adj=adj, col=col.[i],
                  ...)
      }
    }
    
    return(invisible(list(x=xt, y=yt, offset=0,
                          adj=adj, cex=cex, angle=0, col=col., lwd=lwd,
                          key.opts=key.opts, ...)))
  }

  if(is.character(keyloc))
    keyloc <- match.arg(keyloc)

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

  if(!length(offset))
    offset <-
      if(grid)
        unit(.75,"strheight","m")
      else
        strheight('m','user', cex)*.75

  if(!length(xlim))
    xlim <- usr[1:2]
  
  if(!length(ylim))
    ylim <- usr[3:4]

  ##  if(!length(point.inc)) point.inc <- diff(xlim)/5
  ## moved to be used only when needed 15jun02

  if(nc==1) {
    ci <- curves[[1]]
    xx <- ci[[1]]; yy <- ci[[2]]
    s <- is.finite(xx+yy)
    xx <- xx[s];  yy <- yy[s]
    imid <- trunc((length(xx)+1)/2)
    adj <- if(is.character(adj))0.5 else adj
    if(any(whichLabel==1))
      gfun$text(xt <- gun(xx[imid]),
                yt <- gun(yy[imid])+offset,
                labels, 
                cex=cex, adj=adj, col=col., ...)
    
    return(invisible(list(x=xt, y=yt, offset=offset,
                          adj=adj, cex=cex, col=col., lwd=lwd, angle=0, 
                          key.opts=key.opts, ...)))
  }
  
  if(xmethod %nin% c('grid','unique')) 
    stop('xmethod must be "grid" or "unique"')
  
  step.type <- match.arg(step.type)

  if(is.character(adj)) {
    adj.does.vary     <- TRUE
    adj.needs.to.vary <- TRUE
    adj <- rep(.5, nc)
  } else {
    adj.does.vary     <- length(adj) > 1
    adj.needs.to.vary <- FALSE
    adj <- rep(adj, length=nc)
  }

  if(xmethod=='grid') xs <- seq(xlim[1],xlim[2],length=npts) else {
    xs <- unlist(sapply(curves, function(z)z[[1]]))
    xs <- sort(unique(xs[!is.na(xs)]))
    xs <- xs[xs>=xlim[1] & xs<=xlim[2]]
  }

  ys <- matrix(NA, nrow=length(xs), ncol=nc)
  rng <- matrix(NA, nrow=2, ncol=nc)

  for(i in 1:nc) {
    ci <- curves[[i]]
    xx <- ci[[1]]; yy <- ci[[2]]
    s <- is.finite(xx+yy)
    xx <- xx[s]
    y <- approx(xx, yy[s], xout=xs,
                f=if(step.type=='left')
                    0
                  else
                    1,
                method=if(type[i]=='l')
                         "linear"
                       else
                         "constant")$y
    
    y <- pmax(pmin(y,usr[4]),usr[3])
    ## Where one curve is not defined, consider this gap to have an ordinate
    ## that is far from the other curves so labels where be placed where
    ## the other curves haven't started or after they've ended
    y[is.na(y)] <- 1e10
    ys[,i] <- y
    rxx <- range(xx) ## 12feb03 and next 5 lines
    if(length(xrestrict)) {
      rxx[1] <- max(rxx[1],xrestrict[1])
      rxx[2] <- min(rxx[2],xrestrict[2])
    }
    
    rng[,i] <- rxx
    ## Save real range of each x-vector so candidates for labeling
    ## will be where the curve really exists
  }

  if(method=='on top' && is.keys && is.numeric(keys)) {
    ## Draw periodic symbols
    sym <- function(curve, pch, inc, offset, type, step.type, col.,
                    grid, gfun)
    {
      x <- curve[[1]]; y <- curve[[2]]
      s <- is.finite(x+y)
      x <- x[s]; y <- y[s]
      if(length(x)<2)
        stop("when specifying numeric keys (pch) you must have >=2 data points")
      
      lim <- range(x)
      xx <-
        if(grid)
          convertX(gun(seq(lim[1],lim[2],by=inc) + offset),
                   'native', valueOnly=TRUE)
        else
          seq(lim[1], lim[2], by=inc) + offset
      
      if(length(xx)>1)
        xx <- xx[-1]
      
      xx <- xx[xx<=lim[2]]
      if(length(xx)==0) 
        warning('curve was too short to mark with a symbol.\nMay want to change point.inc or xmethod for labcurve')
      else {
        yy <- approx(x, y, xout=xx,
                     method=if(type=='l')
                              'linear'
                            else
                              'constant', 
                     f=if(step.type=='left')
                         0
                       else
                         1)$y
        
        gfun$points(xx, yy, pch=pch, col=col.)
      }
    }
    
    if(!length(point.inc))
      point.inc <- diffu(xlim)/5
    
    for(i in 1:nc)
      sym(curves[[i]], keys[i], point.inc, (i-1)*point.inc/nc,
          type[i], step.type, col.=col.[i], grid, gfun)
    
    xt <- yt <- NULL
  } else {
    xt <- yt <- direction <- numeric(nc)
    angle <- rep(0,nc)

    g <- function(x)
    {
      ## finds min(abs(x)) but keeps original sign
      ax <- abs(x)
      if(all(is.na(ax)))
        return(NA)   ## 29Jan02
      
      w <- min(ax, na.rm=TRUE)
      (x[ax==w])[1]   #use first occurrence
    }

    for(i in 1:nc) {
      yi <- ys[,i]
      yi[xs<rng[1,i] | xs>rng[2,i]] <- NA
      diffmat <- ys[,-i,drop=FALSE] - yi
      mindiff <- apply(diffmat, 1, g)
      z <- abs(mindiff)==max(abs(mindiff),na.rm=TRUE)
      maxid   <- min(c(1:length(mindiff))[z], na.rm=TRUE)
      xt[i] <- xs[maxid]
      yt[i] <- ys[maxid,i]
      if(!is.na(mindiff[maxid])) 
        direction[i] <- 1-2*(mindiff[maxid]>0)  ## if 16may03 + next if

      yto <- yt[i] + direction[i] *
             (if(grid)
                convertY(offset,'native',valueOnly=TRUE)
              else
                offset)
      
      if(!is.na(yto)) 
        if(yto >= usr[4] || yto <= usr[3])
          direction[i] <- -direction[i]

      ## Find slope of curve i at xt[i]
      if(tilt || adj.needs.to.vary) {
        angle[i] <-
          if(type[i]=='s')
            0
          else {
            ci <- curves[[i]]
            xx <- ci[[1]]; yy <- ci[[2]]
            s <- is.finite(xx+yy)
            w <-
              if(length(window))
                window
              else {
                nch <-
                  if(lines.keys) nchar(labels[i])
                  else if(is.keys)
                    1*is.numeric(keys) +
                      nchar(keys[i])*is.character(keys)
                  else
                    nchar(labels[i])
                
                w <-
                  if(grid)
                    nch*convertX(unit(.75,"strwidth","m"),
                                 'native',valueOnly=TRUE)
                  else
                    nch*strwidth('m','user',cex)
              }
            
            yy <- approx(xx[s], yy[s], xout=c(xt[i]-w/2,xt[i]+w/2),
                         rule=2)$y
            slope <- diff(yy)/w
            180*atan(slope*uin[2]/uin[1])/pi
          }
      }
      if(adj.needs.to.vary) {
        adj[i] <-
          if(type[i]=='s')
            1*(direction[i]<0)
          else {
            ## is.na(angle[i]) 16may03
            if(is.na(angle[i]) || abs(angle[i])<=angle.adj.auto)
              .5
            else if((direction[i]<0 && slope>0) || 
                    (direction[i]>0 && slope<0))
              0
            else
              1
          }
      }
    }

    if(!tilt)
      angle[] <- 0
    
    if(!lines.keys && method=='offset' && (!is.logical(labels) || labels)) {
      if(is.keys) {
        if(is.numeric(keys))
          for(i in 1:nc)
            gfun$points(xt[i], (gun(yt) + direction*offset)[i], 
                        pch=keys[i], col=col.[i])
        else if(i %in% whichLabel)    ## 17sep02
          gfun$text(xt, gun(yt) + direction*offset,
                    keys, cex=cex,  
                    adj=adj[1], col=col., ...)
      } else {
        if(tilt || adj.does.vary)
          for(i in whichLabel)   ## 17sep02
            gfun$text(xt[i], gun(yt[i])+direction[i]*offset, 
                      labels[i], cex=cex, srt=angle[i], 
                      adj=adj[i], col=col.[i],...)
        else
          gfun$text(xt, gun(yt)+direction*offset, labels, 
                    cex=cex, adj=adj[1], col=col., ...)
      }
    }
    retlist <- list(x=xt, y=yt, offset=direction*offset,
                    adj=adj, cex=cex, col=col., lwd=lwd, angle=if(tilt) angle, 
                    key.opts=key.opts, ...)
  }

  if(method %in% c('on top','arrow') && (!is.logical(labels) || labels)) {
    retlist <- list(x=xt, y=yt, offset=0, 
                    adj=.5, cex=cex, col=col., lwd=lwd, angle=0, 
                    key.opts=key.opts, ...)

    if(method == 'on top' && !lines.keys) {
      if(is.keys) {
        if(is.character(keys))
          gfun$text(xt, yt, keys, cex=cex, col=col., adj=.5, ...)
        ## numeric keys (periodic plotting symbols) already handled above
      } else
        gfun$text(xt, yt, labels, cex=cex, col=col., adj=.5, ...)
    } else if(method=='arrow') {
      ydelta <-
        if(grid)
          unit(1/17,'npc')
        else
          diffu(ylim)/17
      
      xdelta <-
        if(grid)
          unit(1/26,'npc')
        else
          diffu(xlim)/26
      
      lab.pos <- list(x=gun(xt) + xdelta*arrow.factor,
                      y=gun(yt) + ydelta*arrow.factor)

      gfun$arrows(gun(xt)+xdelta*.6*arrow.factor,
                  gun(yt)+ydelta*.6*arrow.factor,
                  xt,yt,open=TRUE,size=.06,col=col.)
      gfun$text(lab.pos, labels, cex=cex, col=col., ...)
    }
  }

  if(is.keys && (!is.character(keyloc) || keyloc!='none')) {
    ## Make legend
    s <- whichLabel   ## 17sep02
    if(is.character(keyloc) && keyloc=='auto') {
      ## Find emptiest spot for drawing legend by finding
      ## center of largest empty rectangle large enough to hold 
      ## this rectangle
      Xs <- rep(xs, nc)
      Ys <- as.vector(ys)
      putKeyEmpty(Xs, Ys,
                  labels=if(lines.keys || is.numeric(keys))
                           labels[s]
                         else
                           paste(keys,'    ',labels, sep='')[s],  # 27may02
                  
                  pch=if(is.numeric(keys))
                        keys[s],
                  
                  lty=lty[s], lwd=lwd[s], cex=cex, col=col.[s],
                  transparent=transparent, plot=TRUE,
                  key.opts=key.opts, xlim=xlim, ylim=ylim, grid=grid)
      ## added xlim 16Mar02
    } else putKey(keyloc,
                  labels=if(lines.keys || is.numeric(keys))
                           labels[s]
                         else
                           paste(keys,'    ',labels, sep='')[s],  # 27may02
                  
                  pch=if(is.numeric(keys))
                        keys[s],
                  
                  lty=lty[s], lwd=lwd[s], cex=cex, col=col.[s],
                  transparent=transparent, plot=TRUE,
                  key.opts=key.opts, grid=grid) # remove ylim 1Mar01
  }

  invisible(retlist)
}


## Version of legend for R that implements plot=FALSE, adds grid=TRUE
## Also defaults lty, lwd, pch to NULL and checks for length>0 rather
## than missing(), so it's easier to deal with non-applicable parameters
##
## rlegendg is better to use when grid is in effect.  In R 2.0, you
## can't use strwidth etc. after a lattice drawing has been rendered	
if(.R.) {
  rlegendg <- function(x, y, legend, col=pr$col[1], lty=NULL,
                       lwd=NULL, pch=NULL, cex=pr$cex[1], other=NULL)
  {
    pr <- par()
    if(is.list(x)) {
      y <- x[[2]];
      x <- x[[1]]
    }
    
    do.lines  <- (length(lty) && any(lty > 0)) || length(lwd)
    do.points <- length(pch)
    cmd <- NULL
    if(do.lines)
      cmd$lines <- list(col=col, lty=lty, lwd=lwd)
    
    if(do.points)
      cmd$points<- list(col=col, pch=pch, cex=cex)
    
    cmd$text <- list(lab=legend)
    if(length(other))
      cmd <- c(cmd, other)
    
    draw.key(cmd, draw=TRUE, vp=viewport(x=unit(x,'npc'),y=unit(y,'npc')))
    invisible()
  }

  rlegend <- function (x, y, legend, fill, col = "black", lty=NULL, lwd=NULL,
                       pch=NULL, angle = NULL,  
                       density = NULL, bty = "o", bg = par("bg"),
                       pt.bg = NA, cex = 1, 
                       xjust = 0, yjust = 1, x.intersp = 1, y.intersp= 1,
                       adj = 0, text.width = NULL,
                       merge = do.lines && has.pch, trace = FALSE, 
                       ncol = 1, horiz = FALSE, plot=TRUE, grid=FALSE,
                       ...)
  {
    gfun <- ordGridFun(grid)   ## see Misc.s

    if (is.list(x)) {
      if (!missing(y)) {
        if (!missing(legend)) 
          stop("`y' and `legend' when `x' is list (need no `y')")
        
        legend <- y
      }
      
      y <- x$y
      x <- x$x
    } else if (missing(y)) 
      stop("missing y")
    
    if (!is.numeric(x) || !is.numeric(y)) 
      stop("non-numeric coordinates")
    
    if ((nx <- length(x)) <= 0 || nx != length(y) || nx > 2) 
      stop("invalid coordinate lengths")
    
    xlog <- par("xlog")
    ylog <- par("ylog")
    rect2 <- function(left, top, dx, dy, ...)
    {
      r <- left + dx
      if (xlog) {
        left <- 10^left
        r <- 10^r
      }
      
      b <- top - dy
      if (ylog) {
        top <- 10^top
        b <- 10^b
      }
      
      gfun$rect(left, top, r, b, angle = angle, density = density, 
                ...)
    }
    
    segments2 <- function(x1, y1, dx, dy, ...)
    {
      x2 <- x1 + dx
      if (xlog) {
        x1 <- 10^x1
        x2 <- 10^x2
      }
      
      y2 <- y1 + dy
      if (ylog) {
        y1 <- 10^y1
        y2 <- 10^y2
      }
      
      gfun$segments(x1, y1, x2, y2, ...)
    }
    
    points2 <- function(x, y, ...)
    {
      if (xlog) 
        x <- 10^x
      
      if (ylog) 
        y <- 10^y
      
      gfun$points(x, y, ...)
    }
    
    text2 <- function(x, y, ...)
    {
      if (xlog) 
        x <- 10^x
      
      if (ylog) 
        y <- 10^y
      
      gfun$text(x, y, ...)
    }
    
    if (trace) 
      catn <- function(...) do.call("cat", c(lapply(list(...), 
                                                    formatC), list("\n")))
    pr  <- parGrid(grid)  ## 20Mar02 FEH
    cin <- pr$cin         ## FEH
    Cex <- (if(length(unique(cex)) > 1)
              mean(cex,na.rm=TRUE)
            else
              cex) * pr$cex   ## FEH
    
    if (!length(text.width)) ## FEH
      text.width <- max(strwidth(legend, u = "user", cex = cex))
    else if (!is.numeric(text.width) || text.width < 0) 
      stop("text.width must be numeric, >= 0")
    
    xc <- Cex * xInch(cin[1], warn.log = FALSE, grid=grid)  ## FEH in Misc.s
    yc <- Cex * yInch(cin[2], warn.log = FALSE, grid=grid)  ## FEH
    xchar <- xc
    yextra <- yc * (y.intersp - 1)
    ymax <- max(yc, strheight(legend, u = "user", cex = cex))
    ychar <- yextra + ymax
    if (trace) 
      catn("  xchar=", xchar, "; (yextra,ychar)=", c(yextra, ychar))
    
    if (!missing(fill)) {
      xbox <- xc * 0.8
      ybox <- yc * 0.5
      dx.fill <- xbox
    }
    
    do.lines <- (length(lty) && any(lty > 0)) || length(lwd)
    n.leg <- length(legend)
    n.legpercol <-
      if (horiz) {
        if (ncol != 1) 
          warning(paste("horizontal specification overrides: Number of columns :=", 
                        n.leg))
        
        ncol <- n.leg
        1
      } else
        ceiling(n.leg/ncol)
    
    if (has.pch <- length(pch)) {
      if (is.character(pch) && nchar(pch[1]) > 1) {
        if (length(pch) > 1) 
          warning("Not using pch[2..] since pch[1] has multiple chars")
        
        np <- nchar(pch[1])
        pch <- substr(rep(pch[1], np), 1:np, 1:np)
      }
      
      if (!merge) 
        dx.pch <- x.intersp/2 * xchar
    }
    
    x.off <-
      if (merge) 
        -0.7
      else
        0
    
    if (xlog) 
      x <- log10(x)
    
    if (ylog) 
      y <- log10(y)
    
    if (nx == 2) {
      x <- sort(x)
      y <- sort(y)
      left <- x[1]
      top <- y[2]
      w <- diff(x)
      h <- diff(y)
      w0 <- w/ncol
      x <- mean(x)
      y <- mean(y)
      if (missing(xjust)) 
        xjust <- 0.5
      
      if (missing(yjust)) 
        yjust <- 0.5
    } else {
      h <- n.legpercol * ychar + yc
      w0 <- text.width + (x.intersp + 1) * xchar
      if (!missing(fill)) 
        w0 <- w0 + dx.fill
      
      if (has.pch && !merge) 
        w0 <- w0 + dx.pch
      
      if (do.lines) 
        w0 <- w0 + (2 + x.off) * xchar
      
      w <- ncol * w0 + 0.5 * xchar
      left <- x - xjust * w
      top <- y + (1 - yjust) * h
    }
    
    if (bty != "n") {
      if (trace) 
        catn("  rect2(", left, ",", top, ", w=", w, ", h=", 
             h, "...)", sep = "")
      
      if(plot)
        rect2(left, top, dx = w, dy = h, col = bg)  ## FEH
    }
    
    xt <- left + xchar +
          (w0 * rep(0:(ncol - 1), rep(n.legpercol, ncol)))[1:n.leg]
    yt <- top - (rep(1:n.legpercol, ncol)[1:n.leg] - 1) * ychar - 
          0.5 * yextra - ymax
    if (!missing(fill)) {
      fill <- rep(fill, length.out = n.leg)
      if(plot)
        rect2(left = xt, top = yt + ybox/2, dx = xbox, dy = ybox, 
              col = fill)   ## FEH
      
      xt <- xt + dx.fill
    }
    
    if (has.pch || do.lines) 
      col <- rep(col, length.out = n.leg)
    
    if (do.lines) {
      seg.len <- 2
      ok.l <-
        if (!length(lty)) {
          lty <- 1
          TRUE
        } else
          lty > 0
      
      if (!length(lwd)) 
        lwd <- pr$lwd   ## FEH
      
      lty <- rep(lty, length.out = n.leg)
      lwd <- rep(lwd, length.out = n.leg)
      if (trace) 
        catn("  segments2(", xt[ok.l] + x.off * xchar, ",", 
             yt[ok.l], ", dx=", seg.len * xchar, ", dy=0, ...)", 
             sep = "")
      
      if(plot)
        segments2(xt[ok.l] + x.off * xchar, yt[ok.l], dx = seg.len * 
                  xchar, dy = 0, lty = lty[ok.l], lwd = lwd[ok.l], 
                  col = col[ok.l])   ## FEH
      
      xt <- xt + (seg.len + x.off) * xchar
    }
    
    if (has.pch) {
      pch <- rep(pch, length.out = n.leg)
      pt.bg <- rep(pt.bg, length.out = n.leg)
      ok <- is.character(pch) | pch >= 0
      x1 <- (if (merge) 
               xt - (seg.len/2) * xchar
             else
               xt)[ok]
      
      y1 <- yt[ok]
      if (trace) 
        catn("  points2(", x1, ",", y1, ", pch=", pch[ok], 
             "...)")
      
      if(plot)points2(x1, y1, pch = pch[ok], col = col[ok], cex = cex, 
                      bg = pt.bg[ok])  ## FEH
      
      if (!merge) 
        xt <- xt + dx.pch
    }
    
    xt <- xt + x.intersp * xchar
    if(plot)
      text2(xt, yt, labels = legend,
            adj = adj,
            cex = max(1,min(cex, na.rm=TRUE))) ## FEH
    
    invisible(list(rect = list(w = w, h = h, left = left, top = top), 
                   text = list(x = xt, y = yt)))
  }
  NULL
}


putKey <- function(z, labels, type=NULL,
                   pch=NULL, lty=NULL, lwd=NULL,
                   cex=par('cex'), col=rep(par('col'),nc),
                   transparent=TRUE, plot=TRUE, key.opts=NULL,
                   grid=FALSE)
{
  if(grid) {
    require('grid')
    require('lattice')  # use draw.key in lattice    29Jan02
  }
  
  if(!.R. && !existsFunction('key')) 
    stop('must do library(trellis) to access key() function')

  nc <- length(labels)
  if(!length(pch))
    pch <- rep(NA, nc)
  
  if(!length(lty))
    lty <- rep(NA, nc)
  
  if(!length(lwd))
    lwd <- rep(NA, nc)
  
  pp <- !is.na(pch)
  lp <- !is.na(lty) | !is.na(lwd)
  lwd <- ifelse(is.na(lwd), par('lwd'), lwd)
  
  if(!length(type)) type <- ifelse(!(pp | lp), 'n',
                                   ifelse(pp & lp, 'b',
                                          ifelse(pp, 'p', 'l')))
  
  pch <- ifelse(is.na(pch) & type!='p' & type!='b',
                if(.R.)
                  NA
                else
                  0,
                pch)  ## NA was 0 12dec02
  
  lty <- ifelse(is.na(lty) & type=='p',
                if(.R.)
                  NA
                else
                  1,
                lty)  ## NA was 1 12dec02
  
  lwd <- ifelse(is.na(lwd) & type=='p', 1, lwd)
  cex <- ifelse(is.na(cex) & type!='p' & type!='b', 1, cex)

  if(!.R. && any(is.na(pch)))
    stop("pch can not be NA for type='p' or 'b'") #12dec02
  
  if(!.R. && any(is.na(lty)))
    stop("lty can not be NA for type='l' or 'b'") #12dec02
  
  if(any(is.na(lwd)))
    stop("lwd can not be NA for type='l' or 'b'")
  
  if(any(is.na(cex)))
    stop("cex can not be NA for type='p' or 'b'")
  
  m <- list()
  m[[1]] <- as.name(if(grid)
                      'draw.key'
                    else if(.R.)
                      'rlegend'
                    else
                      'key')
  
  if(!grid) {
    m$x <- z[[1]]; m$y <- z[[2]]
  }

  if(.R.) {
    if(grid) {
      w <- list(text=list(labels, col=col))
      ##m$xjust <- m$yjust <- 0.5
      if(!(all(is.na(lty)) & all(is.na(lwd)))) {
        lns <- list()
        if(!all(is.na(lty)))
          lns$lty <- lty
        
        if(!all(is.na(lwd)))
          lns$lwd <- lwd
        
        lns$col <- col
        w$lines <- lns
      }
      
      if(!all(is.na(pch)))
        w$points <- list(pch=pch, col=col)
      
      ## was if(!all(is.na(pch)) && !all(pch==0)) w$points <- list(pch=pch, col=col) 12dec02
      ##    if(length(key.opts)) m[names(key.opts)] <- key.opts
      m$key <- w
      m$draw <- plot
      if(plot)
        m$vp <- viewport(x=unit(z[[1]], 'native'),
                         y=unit(z[[2]], 'native'))
      
      z <- eval(as.call(m))
      size <-
        if(plot)
          c(NA,NA)
        else 
          c(convertUnit(grobWidth(z), 'native', 'x', 'location', 'x',
                        'dimension', valueOnly=TRUE)[1],
            convertUnit(grobHeight(z), 'native', 'y', 'location', 'y',
                        'dimension', valueOnly=TRUE)[1])
      
      return(invisible(size))
    } else {
      m$legend <- labels
      m$xjust <- m$yjust <- .5
      m$plot <- plot
      m$col <- col
      m$cex <- cex
      if(!all(is.na(lty)))
        m$lty <- lty
      
      if(!all(is.na(lwd)))
        m$lwd <- lwd
      
      if(!all(is.na(pch)))
        m$pch <- pch
      
      ## was if(!all(is.na(pch)) && !all(pch==0)) m$pch <- pch 12dec02
      if(length(key.opts))
        m[names(key.opts)] <- key.opts
      
      w <- eval(as.call(m))$rect
      return(invisible(c(w$w[1], w$h[1])))
    }
  }
  
  m$transparent <- transparent
  m$corner <- c(.5,.5)
  m$plot   <- plot
  m$type   <- type

  if(!plot)
    labels <- substring(labels, 1, 10)
  
  ## key gets length wrong for long labels
  m$text <- list(labels, col=col)
  if(all(type=='p'))
    m$points <- list(pch=pch, cex=cex, col=col)
  else
    m$lines <-
      if(any(type!='l'))
        list(lty=lty, col=col, lwd=lwd, pch=pch, cex=cex)
      else
        list(lty=lty, col=col, lwd=lwd)
                                                 
  if(length(key.opts))
    m[names(key.opts)] <- key.opts
  
  invisible(eval(as.call(m)))  ## execute key(....)
}


putKeyEmpty <- function(x, y, labels, type=NULL,
                        pch=NULL, lty=NULL, lwd=NULL,
                        cex=par('cex'), col=rep(par('col'),nc),
                        transparent=TRUE, plot=TRUE, key.opts=NULL,
                        empty.method=c('area','maxdim'), 
                        numbins=25, 
                        xlim=pr$usr[1:2], ylim=pr$usr[3:4],
                        grid=FALSE)
{ 
  nc <- length(labels)
  empty.method <- match.arg(empty.method)

  pr <- parGrid(grid)
  uin <- pr$uin

  if(.R.)
    uin <- 1  ## already in x,y units
  
  z <- putKey(list(0, 0), labels, type, pch, lty, lwd, cex, col,
              transparent=transparent, plot=FALSE,
              key.opts=key.opts, grid=grid)/uin
  ## /uin converts to x,y units

  ## Find center of largest empty rectangle large enough to hold 
  ## this rectangle
  s  <- is.finite(x + y)
  if(length(xlim))
    s <- s & (x >= xlim[1] & x <= xlim[2])
  
  if(length(ylim))
    s <- s & (y >= ylim[1] & y <= ylim[2])
  
  x <- x[s]
  y <- y[s]
  keyloc <- largest.empty(x, y, xlim=xlim, ylim=ylim,
                          width=z[1], height=z[2],
                          method=empty.method, numbins=numbins, grid=grid)
  if(is.na(keyloc$x)) {
    cat('No empty area large enough for automatic key positioning.  Specify keyloc or cex.\n')
    cat('Width and height of key as computed by key(), in data units:',
        format(z),'\n')
    return(keyloc)
  } else if(plot) putKey(keyloc, labels, type,
                         pch, lty, lwd, cex, col, transparent, plot=TRUE,
                         key.opts=key.opts, grid=grid)
  
  invisible(keyloc)
}


largest.empty <- function(x, y, 
                          width, height, 
                          numbins=25,
                          method=c('area','maxdim'),
                          xlim=pr$usr[1:2], ylim=pr$usr[3:4],
                          pl=FALSE, grid=FALSE)
{
  method <- match.arg(method)
  pr <- parGrid(grid)
  
  itype  <- 1 * (method=='area') + 2 * (method=='maxdim')
  storage.mode(x) <- storage.mode(y) <- storage.mode(xlim) <-
    storage.mode(ylim) <- storage.mode(width) <-
      storage.mode(height) <- 'double'
  storage.mode(numbins) <- storage.mode(itype) <- 'integer'

  a <-
    if(.R.)
      .Fortran('largrec', x, y, length(x), 
               xlim, ylim, 
               width, height, numbins, itype,
               rx=double(2), ry=double(2), PACKAGE="Hmisc")
    else
      .Fortran('largrec', x, y, length(x), 
               xlim, ylim, 
               width, height, numbins, itype,
               rx=double(2), ry=double(2))
  
  x <- a$rx
  if(any(x > 1e29)) {
    warning('no empty rectangle was large enough')
    return(list(x=NA, y=NA))
  }
  
  y <- a$ry
  if(pl)
    ordGridFun(grid)$polygon(x[c(1,2,2,1)],y[c(1,1,2,2)], col=1+itype)
  
  list(x=mean(x), y=mean(y))
}


drawPlot <- function(..., xlim=c(0,1), ylim=c(0,1), xlab='', ylab='',
                     ticks=c('none','x','y','xy'),
                     key=FALSE, opts=NULL)
{

  Points <- function(label=' ', type=c('p','r'), n, pch=pch.to.use[1],
                     cex=par('cex'), rug=c('none','x','y','xy'),
                     ymean=NULL)
  {
    type <- match.arg(type)
    rug <- match.arg(rug)
    cat('\nClick mouse for each point',
        if(label!='')
          paste(' for group ',label),
        '.',
        if(missing(n))
          ' Right click when finished.',
        '\n',sep='')
    
    pts <-
      if(missing(n))
        locator(type='p',pch=pch,cex=cex)
      else
        locator(n, type='p', pch=pch, cex=cex)
    
    if(length(ymean))
      pts$y <- pts$y - mean(pts$y) + ymean  ## 26Jan01
    
    if(type=='p') 
      storeTemp(pch.to.use[pch.to.use != pch],'pch.to.use')
    else {
      scat1d(pts$x, side=1)
      pch <- NA
    }
    
    switch(rug,
           x = scat1d(pts$x, side=1),
           y = scat1d(pts$y, side=2),
           xy = {scat1d(pts$x, side=1); scat1d(pts$y, side=2)},
           none = )
           
    structure(list(points=pts, label=label, type=type,
                   pch=pch, cex=cex, rug=rug), class='Points')
  }

  Curve <- function(label=' ',
                    type=c('bezier','polygon','linear','pol','step','gauss'),
                    n=NULL, lty=1, lwd=par('lwd'), degree=2,
                    evaluation=100, ask=FALSE)
  {
    isfun <- is.function(type)
    if(!isfun)
      type <- match.arg(type)
    
    if(!isfun && !length(n) && type=='linear')
      n <- 2
    
    if(!isfun && type=='gauss')
      n <- 3
    
    xlim <- par('usr')[1:2]
    redraw <- TRUE
    
    if(isfun) {
      x <- seq(xlim[1], xlim[2], length=evaluation)
      pts <- list(x=as.single(x), y=as.single(type(x)))
      lines(pts, lty=lty, lwd=lwd)
    } else repeat {
      cat('\nClick mouse for each point',
          if(label!='')
            paste(' for group ',label),
          '.',
          if(!length(n))
            ' Right click when finished.',
          '\n', sep='')
      
      pts <-
        if(!length(n))
          locator(type='l', lty=lty, lwd=lwd)
        else
          locator(n, type='l', lty=lty, lwd=lwd)
      
      n <- length(pts$x)
      if(n < 2)
        stop('must click at least 2 points')
      
      if(n==2)
        type <- 'linear'

      if(type=='pol') {
        x <- matrix(NA, nrow=n, ncol=degree)
        for(i in 1:degree) x[,i] <- pts$x^i
        f <- lm.fit.qr.bare(x, pts$y)
        x <- matrix(NA, nrow=evaluation, ncol=degree)
        x[,1] <- seq(min(pts$x),max(pts$x), length=evaluation)
        if(degree > 1)
          for(i in 1:degree)
            x[,i] <- x[,1]^i
        
        cof <- f$coefficients
        y <- cof[1] + x %*% cof[-1]
        pts <- list(x=as.single(x[,1]), y=as.single(y))
        if(redraw)
          lines(pts, lty=lty, lwd=lwd)
      }

      if(type=='bezier') {
        pts <- bezier(pts, xlim=range(pts$x), evaluation=evaluation)
        if(redraw)
          lines(pts, lty=lty, lwd=lwd)
      }
      
      if(type=='gauss') {
        mu <- pts$x[2]
        delta <- diff(pts$x[-2])/2
        htavg <- sum(pts$y[-2])/2
        htmax <- pts$y[2]
        x <- seq(xlim[1], xlim[2], length=evaluation)
        b2 <- delta^2 / log(htmax/htavg)
        y <- htmax * exp(-(x-mu)^2/b2)
        i <- y > 1e-4
        pts <- list(x=as.single(x[i]), y=as.single(y[i]))
        lines(pts, lty=lty, lwd=lwd)
      }
      
      if(type=='step' && redraw)
        lines(pts, type='s', lty=lty, lwd=lwd)

      if(!ask)
        break
      
      if(readline('\nType y to accept, n to re-draw:')=='y')
        break
    }
    
    structure(list(points=pts, label=label, type=type, lty=lty,
                   lwd=lwd),  class='Curve')
  }

  Abline <- function(...)
  {
    abline(...)
    structure(list(...), class='Abline')
  }
  
  storeTemp(Points)
  storeTemp(Curve)
  storeTemp(Abline)
  
  storeTemp(c(1,2,3,4,16,17,5,6,15,18,19),'pch.to.use')

  ticks <- match.arg(ticks)
  if(missing(ticks)) {
    if(!missing(xlim))
      ticks <- 'x'
    
    if(!missing(ylim))
      ticks <- 'y'
    
    if(!missing(xlim) && !missing(ylim))
      ticks <- 'xy'
  }
  
  plot(xlim, ylim, xlim=xlim, ylim=ylim, xlab=xlab, ylab=ylab,
       type='n', axes=ticks=='xy')

  switch(ticks,
         none={
           axis(1, at=xlim, labels=FALSE)
           axis(2, at=ylim, labels=FALSE)
         },
         x={
           axis(1)
           axis(2, at=ylim, labels=FALSE)
         },
         y={
           axis(1, at=xlim, labels=FALSE)
           axis(2)
         },
         xy = )
  
  W <- list(...)
  m <- length(W)
  type <- label <- rep('', m)
  lty <- lwd <- pch <- cex <- rep(NA, m)
  curves <- vector('list', m)
  i <- 0
  for(j in 1:m) {
    w <- W[[j]]
    if(attr(w,'class')=='Abline')
      next
    
    i <- i + 1
    isfun <- is.function(w$type)
    curves[[i]] <-
      if(!key || isfun)
        w$points
      else switch(w$type,
                  step = approx(w$points,
                                xout=seq(min(w$points$x),max(w$points$x),length=50),
                                method='constant', f=0),
                  linear = approx(w$points,
                                  xout=seq(min(w$points$x),max(w$points$x),length=50)),
                  w$points)
    
    label[i] <- w$label
    type[i] <-
      if(isfun)
        'l'
      else switch(w$type,
                  p='p',
                  r='r',
                  step='s',
                  'l')
    
    if(type[i]=='p') {
      pch[i] <- w$pch
      cex[i] <- w$cex
    } else if(type[i] != 'r') {  ## if( ) 12dec02
      lty[i] <- w$lty
      lwd[i] <- w$lwd
    }
  }
  
  if(i < m) {
    curves <- curves[1:i]
    label  <- label[1:i]
    type   <- type[1:i]
    lty    <- lty[1:i]
    lwd    <- lwd[1:i]
    pch    <- pch[1:i]
    cex    <- cex[1:i]
  }
  
  keyloc <- NULL
  j <- type!='r'
  if(any(j)) {   ## 12dec02
    if(!key)
      labcurve(curves[j], labels=label[j], type=type[j],
               lty=lty[j], lwd=lwd[j], opts=opts)
    else {
      x <- unlist(lapply(curves, function(z)z$x))
      y <- unlist(lapply(curves, function(z)z$y))
      keyloc <- putKeyEmpty(x, y, labels=label[j], type=type[j],
                            pch=pch[j], lty=lty[j],
                            lwd=lwd[j], cex=cex[j])
    }
  }

  structure(list(W, xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim,
                 ticks=ticks, key=key, keyloc=keyloc, opts=opts),
            class='drawPlot')
}


bezier <- function(x, y, xlim, evaluation=100)
{
  if(missing(y)) {
    y <- x[[2]]
    x <- x[[1]]
  }
  
  n <- length(x)
  X <- Y <- single(evaluation)
  Z <- seq(0, 1, length=evaluation)
  X[1] <- x[1];
  X[evaluation] <- x[n]
  Y[1] <- y[1];
  Y[evaluation] <- y[n]
  for(i in 2:(evaluation-1)) {
    z <- Z[i]
    xz <- yz <- 0
    const <- (1 - z)^(n-1)
    for(j in 0:(n-1)) {
      xz <- xz + const*x[j+1]
      yz <- yz + const*y[j+1]
      const <- const* (n-1-j)/(j+1) * z/(1-z)
      if(is.na(const))
        prn(c(i,j,z))
    }
    
    X[i] <- xz; Y[i] <- yz
  }
  
  list(x=as.single(X), y=as.single(Y))
}


plot.drawPlot <- function(x, file, xlab, ylab, ticks,
                          key=x$key, keyloc=x$keyloc, ...)
{
  if(missing(xlab))
    xlab <- x$xlab
  
  if(missing(ylab))
    ylab <- x$ylab
  
  xlim <- x$xlim
  ylim <- x$ylim
  if(missing(ticks))
    ticks <- x$ticks
  
  if(!missing(file))
    setps(file, type='char', ...)

  plot(xlim, ylim, xlim=xlim, ylim=ylim, xlab=xlab, ylab=ylab,
       type='n', axes=ticks=='xy')
  switch(ticks,
         none={
           axis(1, at=xlim, labels=FALSE)
           axis(2, at=ylim, labels=FALSE)
         },
         x={
           axis(1)
           axis(2, at=ylim, labels=FALSE)
         },
         y={
           axis(1, at=xlim, labels=FALSE)
                 axis(2)
         },
         xy= )

  data <- x[[1]]
  m <- length(data)
  type <- label <- rep('', m)
  lty <- lwd <- pch <- cex <- rep(NA, m)
  curves <- vector('list', m)
  i <- 0
  for(j in 1:m) {
    w <- data[[j]]
    if(attr(w, 'class') == 'Abline') {
      do.call("abline", oldUnclass(w))
      next
    }
    
    i <- i + 1
    if(is.function(w$type))
      w$type <- 'l'
    
    curves[[i]] <-
      if(!key)
        w$points
      else switch(w$type,
                  step = approx(w$points,
                                xout=seq(min(w$points$x),max(w$points$x),length=50),
                                method='constant', f=0),
                  linear = approx(w$points,
                                  xout=seq(min(w$points$x),max(w$points$x),length=50)),
                  w$points)
    
    label[i] <- w$label
    switch(attr(w, 'class'),
           Points = {
             type[i] <- w$type
             pch[i] <- w$pch
             cex[i] <- w$cex
             switch(w$type,
                    p = points(w$points, cex=w$cex, pch=w$pch),
                    r = scat1d(w$points$x, side=1))
             switch(w$rug,
                    x = scat1d(w$points$x, side=1),
                    y = scat1d(w$points$y, side=2),
                    xy = {
                      scat1d(w$points$x, side=1)
                      scat1d(w$points$y, side=2)
                    },
                    none = )
           },
           Curve = {
             type[i] <-
               if(w$type=='step')
                 's'
               else
                 'l'
             
             lty[i] <- w$lty
             lwd[i] <- w$lwd
             lines(w$points, lty=w$lty, lwd=w$lwd, type=type[i])
           })
  }

  if(i < m) {
    curves <- curves[1:i]
    label  <- label[1:i]
    type   <- type[1:i]
    pch    <- pch[1:i]
    lty    <- lty[1:i]
    lwd    <- lwd[1:i]
    cex    <- cex[1:i]
  }
    
  if(key && !length(keyloc))
    stop('you may not specify key=T unless key=T was specified to drawPlot or keyloc is specified to plot')

  if(any(label!='')) {
    j <- type!='r'
    if(any(j)) {  ## 12dec02
      if(key) putKey(keyloc, labels=label[j],
                     type=type[j], pch=pch[j],
                     lty=lty[j], lwd=lwd[j], cex=cex[j])
      else
        labcurve(curves[j], type=type[j],
                 lty=lty[j], lwd=lwd[j], labels=label[j], opts=x$opts)
    }
  }
  
  if(!missing(file)) {
    dev.off()
    cat('\nCreated file ',file,'.ps\n',sep='')
  }
  
  invisible()
}
##"label<-"  <- function(x, value) {
##  attr(x, "label") <- value
##  x
##}

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

label.default <- function(x, units=FALSE, plot=FALSE, default=NULL,
                          grid=FALSE, ...)
{
  at <- attributes(x)
  lab <- at$label
  if(length(default) && (!length(lab) || lab==''))
    lab <- default
  
  un  <- at$units
  labelPlotmath(lab,
                if(units) un else NULL,
                plotmath=plot, grid=grid)
}


labelPlotmath <- function(label, units=NULL, plotmath=.R., grid=FALSE)
{
  if(!length(label)) label <- ''
  
  if(!length(units)) units <- ''
  
  g <-
    if(plotmath && .R.) function(x,y=NULL, xstyle=NULL, ystyle=NULL)
      {
        h <- function(w, style=NULL)
          if(length(style))
            paste(style,'(',w,')',sep='')
          else
            w
      
        if(!length(y))
          return(parse(text=h(plotmathTranslate(x),xstyle)))
      
        x <- paste('list(',h(plotmathTranslate(x),xstyle),',',
                   h(plotmathTranslate(y),ystyle),')',sep='')
        parse(text=x)
      } else function(x, y=NULL, ...) if(length(y)) paste(x,y) else x

  if(units=='') g(label)
  else if(label=='') g(units)
  else if(plotmath && .R.)
    g(label, units, ystyle='scriptstyle')
  else paste(label,' [',units,']',sep='')
}


plotmathTranslate <- function(x)
{
  if(length(grep('paste', x))) return(x)
  
  specials <- c(' ','%','_')
  spec <- FALSE
  for(s in specials)
    if(length(grep(s,x)))
      spec <- TRUE
  
  if(spec) x <- paste('paste("',x,'")',sep='')
  else if(substring(x,1,1)=='/') x <- paste('phantom()', x, sep='')
  x
}

"label<-" <- function(x, value) UseMethod("label<-")

##From Bill Dunlap, StatSci  15Mar95:
if(!.SV4.) "label<-.default" <- function(x, value)
  structure(x, label=value,
            class=c('labelled',
              attr(x,'class')[attr(x,'class')!='labelled'])) else
"label<-.default" <- function(x, value)
  {
    ## Splus 5.x, 6.x
    ##  oldClass(x) <- unique(c('labelled', oldClass(x),
    ##                          if(is.matrix(x))'matrix'))
    attr(x,'label') <- value
    x
  }

if(!.SV4.) "[.labelled"<- function(x, ...)
{
  tags <- valueTags(x)
  x <- NextMethod("[")
  valueTags(x) <- tags
  x
}

if(!.SV4.) "print.labelled"<- function(x, ...)
{
  x.orig <- x
  u <- attr(x,'units')
  if(length(u))
    attr(x,'units') <- NULL   # so won't print twice
  
  cat(attr(x, "label"),
      if(length(u))
        paste('[', u, ']', sep=''),
      "\n")
  
  attr(x, "label") <- NULL
  class(x) <-
    if(length(class(x))==1 && class(x)=='labelled')
      NULL
    else
      class(x)[class(x) != 'labelled']
  
  ## next line works around print bug
  if(!length(attr(x,'class')))
    attr(x,'class') <- NULL
  
  NextMethod("print")
  invisible(x.orig)
}


if(.R.) as.data.frame.labelled <- as.data.frame.vector

if(!.R. && version$major < 5) as.data.frame.labelled <- function(x, ...)
{
  y <- x
  cy <- attr(y,'class')
  cy <-
    if(length(cy)>1)
      cy[cy!='labelled']
    else
      NULL
  
  if(length(cy)==0)
    cy <- NULL  # handles wierd case e.g. class=rep('lab..',2)
  
  attr(y,'class') <- cy
  
  ## data.class(character(0) class) returns ''
  d <- data.class(y)
  methodname <- paste("as.data.frame", d, sep = '.')
  if(exists(methodname, mode = "function"))
    (get(methodname, mode = "function"))(x, ...)
  else {
    if(options()$check)
      warning(paste("no method for coercing",d,"to data.frame"))
    
    as.data.frame.AsIs(y, ...)
  }
}


Label <- function(object, ...) UseMethod("Label")


Label.data.frame <- function(object, file='', append=FALSE, ...)
{
  nn <- names(object)
  for(i in 1:length(nn)) {
    lab <- attr(object[[nn[i]]],'label')
    lab <- if(length(lab)==0) '' else lab
    cat("label(",nn[i],")\t<- '",lab,"'\n", 
        append=if(i==1)
        append
        else
        TRUE,
        file=file, sep='')
  }
  
  invisible()
}


reLabelled <- function(object)
{
  for(i in 1:length(object))
    {
      x <- object[[i]]
      lab <- attr(x, 'label')
      cl  <- oldClass(x)
      if(length(lab) && !any(cl=='labelled')) {
        oldClass(x) <- c('labelled',cl)
        object[[i]] <- x
      }
    }
  
  object
}


llist <- function(..., labels=TRUE)
{
  dotlist <- list(...)
  lname <- names(dotlist)
  name <- vname <- as.character(sys.call())[-1]
  for(i in 1:length(dotlist))
    {
      vname[i] <-
        if(length(lname) && lname[i]!='')
          lname[i]
        else
          name[i]
      
      ## R barked at setting vname[i] to NULL
      lab <- vname[i]
      if(labels)
        {
          lab <- attr(dotlist[[i]],'label')
          if(length(lab) == 0)
            lab <- vname[i]
        }
    
      label(dotlist[[i]]) <- lab
    }
  
  names(dotlist) <- vname[1:length(dotlist)]
  dotlist
}
##!!WRONG ARG x in !.SV4. def latex generic!
##Changed x to object inside latex() for !.SV4. (Thanks David Lovell)


##Thanks to David R. Lovell <David.Lovell@cmis.csiro.au> CSIRO
##for scientific=    8Feb2000

first.word <- function(x, i=1, expr=substitute(x))
{
  words <-
    if(!missing(x))
      as.character(x)[1]
    else
      as.character(unlist(expr))[1]
  
  ## Added !missing(x) as.char(x) 25May01
  ##	first.letters <- substring(words, 1, 1)
  ##	word.selector <- (match(first.letters, c(letters,LETTERS,"."), 0) > 0)
  ##	words <- words[word.selector][i]
  ##	if(!under.unix) {
  ##	  words <- sedit(words,'.','')
  ##	  words <- substring(words,1,8)
  ##	}
  ## 8Nov00 FEH:
  
  if(i > 1)
    stop('i > 1 not implemented')
  
  chars <- substring(words, 1:nchar(words), 1:nchar(words))
  legal.chars <- c(letters,LETTERS,'.',
                   '0','1','2','3','4','5','6','7','8','9')
  non.legal.chars <- (1:length(chars))[chars %nin% legal.chars]
  if(!any(non.legal.chars))
    return(words)
  
  if(non.legal.chars[1]==1)
    return(character(0))
  
  substring(words, 1, non.legal.chars[1]-1)
}


##1. if x is a data.frame, then do each component separately.
##2. if x is a matrix, but not a data.frame, make it a data.frame
##   with individual components for the columns.
##3. if a component x$x is a matrix, then do all columns the same.
##4. Use right justify by default for numeric columns.
##5. Use left justify for non-numeric columns.

## The following are made complicated by matrix components of data.frames:
##6. vector cdec must have number of items equal to number of columns
##   of input x.
##7. matrix dec must have number of columns equal to number of columns
##   of input x.
##8. scalar dec is expanded to a vector cdec with number of items equal
##   to number of columns of input x.
##9. vector rdec must have number of items equal to number of rows of input x.
##   rdec is expanded to matrix dec.
##10. col.just must have number of columns equal to number of columns
##    of output cx.

## Value:
## character matrix with character images of properly rounded x.
## matrix components of input x are now just sets of columns of character matrix.
## attr(,col.just) repeats input col.just when provided.
##	Otherwise, recommended justification for columns of output.
##	Default is "l" for characters and factors, "r" for numeric.
##	When dcolumn==T, numerics will have ".".


## FEH 21May96 - changed default for numeric.dollar to cdot
## FEH  5Jun96 - re-written to not rely on as.data.frame,
##               converted data frames to matrices the slow way
##               added matrix.sep 
##     12Aug99 - allowed # decimal places=NA (no rounding, just use format())
##    27May02 - added booktabs FEH
## 13Dec02 - added ctable   FEH
## arguments included check.names=TRUE 23jan03

format.df <- function(x,
                      digits, dec=NULL, rdec=NULL, cdec=NULL,
                      numeric.dollar=cdot, na.blank=FALSE,
                      na.dot=FALSE, blank.dot=FALSE, col.just=NULL,
                      cdot=FALSE, dcolumn=FALSE, matrix.sep=' ', scientific=c(-4,4),
                      math.row.names=FALSE, math.col.names=FALSE, ...)
{
  if(cdot && dcolumn)
    stop('cannot have both cdot=T and dcolumn=T')
  
  if(missing(digits))
    digits <- NULL
  
  if((!length(digits))+(!length(dec))+(!length(rdec))+(!length(cdec)) < 3)
    stop('only one of digits, dec, rdec, cdec may be given')
  
  ##if(length(digits)) .Options$digits    6Aug00 what was that?
  if(is.null(digits) && is.null(dec) && is.null(rdec) && is.null(cdec)) {
    digits <- 15
  }

  if(length(digits)) {
    oldopt <- options(digits=digits)
    on.exit(options(oldopt))
  }
  

  ## For now nsmall and scientific are ignored in R  25May01
  formt <-
    if(!.R.)
      format.default
    else function(x, decimal.mark='.', nsmall=0, scientific=c(-4,4), digits=NULL)
      {
        x <- format(x, nsmall=nsmall, decimal.mark=decimal.mark, digits=digits)
        if(decimal.mark!='.')
          x <- gsub('\\.',decimal.mark,x)
      
        x
      }
  
  dot <-
    if(cdot) {
      if(.R.)
        '\\\\cdotp\\\\!'
      else
        '\\cdotp\\!'
    }
    else
      '.'

  if(is.data.frame(x))
    x <- unclass(x)
  
  xtype <-
    if(is.list(x))
      1
    else if(length(dim(x)))
      2
    else
      3
  
  ##Following changed as above 10Mar01
  ##  atx <- attributes(x)
  ##  cl <- atx$class
  ##  if(length(cl) && (idf <- any(cl=='data.frame'))) 
  ##    attr(x,'class') <- cl[cl!='data.frame']
  ##  xtype <- if(is.list(x))1 else if(length(atx$dim))2 else 3
  
  ncx <-
    if(xtype==1)
      length(x)
    else if(xtype==2)
      ncol(x)
    else
      1
  
  nams <-
    if(xtype==1)
      names(x)
    else if(xtype==2)
      dimnames(x)[[2]]
    else
      ''
  
  ## Added Check to see that if the user passed col.just into format.df
  ## that the length of col.just if >= ncx 29apr05
  if(!missing(col.just) && (length(col.just) < ncx)) {
    stop('col.just needs the same number of elements as number of columns')
  }
  
  if(!length(nams))
    nams <- rep('', ncx)  ## 19apr03
  
  nrx <-
    if(xtype==1) {
      if(length(d <- dim(x[[1]])))
        d[1]
      else
        length(x[[1]])
    } else if(xtype==2)
      nrow(x)
    else
      length(x)
  
  rnam <-
    if(xtype==1)
      attr(x,'row.names')
    else if(xtype==2)
      dimnames(x)[[1]]
    else
      names(x)
  
  if(length(dec)+length(rdec)+length(cdec)==0)
    rtype <- 1
  
  if(length(rdec)) {
    rtype <- 2
    dec <- matrix(rdec, nrow=nrx, ncol=ncx)
  }
  
  if(length(dec)) {
    rtype <- 3
    if(length(dec)==1) cdec <- rep(dec, ncx)
  }
  
  if(length(cdec)) rtype <- 4
  
  cx <- NULL
  nam <- NULL
  cjust <- NULL
  
  if(blank.dot) sas.char <- function(x) {
    n.x <- nchar(x)
    blanks.x <-
      sapply(n.x, function(n.x.i) paste(rep(" ", n.x.i), collapse=""))
    ifelse(x == blanks.x, ".", x)
  }
  
  for(j in 1:ncx) {
    xj <-
      if(xtype==1)
        x[[j]]
      else if(xtype==2)
        x[,j]
      else
        x
    
    namj <- nams[j]
    if(math.col.names) {
      namj <- paste('$', namj, '$', sep='')
    }
    
    num <- is.numeric(xj) || all(is.na(xj)) ## 16sep03
    if(testDateTime(xj))
      num <- FALSE            ## 16sep03
    
    ## using xtype avoids things like as.matrix changing special characters 
    ncxj <- max(1,dim(xj)[2], na.rm=TRUE)
    ## Added na.rm=T 5Jan01: SV4 makes dim(xj)=single number if x is data.frame

    for(k in 1:ncxj) {
      xk <-
        if(ld <- length(dim(xj))==2)
          xj[,k]
        else
          xj
      
      ## Added ==2 5Jan01
      names(xk) <- NULL
      ## gets around bug in format.default when 
      ## nsmall is given and there are NAs
      
      namk <-
        if(ld) {
          dn <- dimnames(xj)[[2]][k]
          if(length(dn)==0)
            dn <- as.character(k)
          
          if(math.row.names) {
            paste('$', dn, '$', sep='')
          } else {
            dn
          }
        } else ''
      
      namk <- paste(namj,
                    if(namj!='' && namk!='')
                      matrix.sep
                    else '',
                    namk, sep='')
      
      if(num) {
        cj <-
          if(length(col.just))
            col.just[j]
          else 'r'
        
        if(rtype==1)
          cxk <- formt(xk, decimal.mark=dot, scientific=scientific, digits=digits)
        else if(rtype==3) {
          cxk <- character(nrx)  ## corrected 4Nov97 Eric Bissonette
          for(i in 1:nrx)
            cxk[i] <-
              if(is.na(dec[i,j]))
                formt(xk[i], decimal.mark=dot, scientific=scientific, digits=digits)
              else
                formt(round(xk[i], dec[i,j]), decimal.mark=dot,
                      digits=digits, nsmall=dec[i,j], scientific=scientific)
          ## 12Aug99
        } else if(rtype==4)  # 12Aug99
          cxk <-
            if(is.na(cdec[j]))
              formt(xk, decimal.mark=dot, scientific=scientific, digits=digits)
            else
              formt(round(xk, cdec[j]), decimal.mark=dot, nsmall=cdec[j],
                    digits=digits, scientific=scientific)
        
        if(na.blank)
          cxk[is.na(xk)] <- ''
        
        if(na.dot)
          cxk[is.na(xk)] <- '.'  # SAS-specific
        
        if(blank.dot)
          cxk <- sas.char(cxk)
        
        if(numeric.dollar)
          cxk <- paste("$",cxk,"$",sep="")
        
        ## These columns get real minus signs in LaTeX, not hyphens,
        ## but lose alignment unless their col.just="r"
        if(dcolumn | (length(col.just) && col.just[j]=='c')) {
          cxk <- sedit(cxk, " ", "~")
          if(dcolumn)
            cj <- "."
        } 
      } else {   #ended if(num)
        cj <-
          if(length(col.just))
            col.just[j]
          else 'l'
        
        cxk <- as.character(xk)
      }
      
      cx <- cbind(cx, cxk)
      nam <- c(nam, namk)
      cjust <- c(cjust, cj)
    }    #end for k
  }#end for j

  dimnames(cx) <- list(rnam, nam)
  attr(cx,"col.just") <- cjust
  cx
}


##first.hline.double added FEH 11Jun95
##Usage:
##	latex(x) # for x any S object

##Value is a file object of class=c("latex","file") which is
##automatically printed by print.latex(), which constructs a file objecT
##of class=c("dvi","file"), and automatically prints it using
##print.dvi().  print.latex() returns an invisible file object.


## dcolumn numeric.dollar cdot
##
## dc cd nd  format.df latex.default  # comment
## F  F  T	   $		     # LaTeX usage
## F  T  T   \cdot! $		     # LaTeX usage
## T  F  F   . ~	      .	    dcolumn  # LaTeX usage
## T  T  F   . ~	      \cdot dcolumn  # LaTeX usage
##        
## F  F  F    			     # non-TeX (hyphens in TeX)
##        
## F  T  F   \cdot!		     # TeX errors, hyphens
## T  F  T   . ~	   $  .	    dcolumn  # TeX errors
## T  T  T   . ~	   $  \cdot dcolumn  # TeX errors
latex.default <-
  function(object,
           title=first.word(deparse(substitute(object))),
           file=paste(title, ".tex", sep=""),
           append=FALSE, label=title,
           rowlabel=title, rowlabel.just="l", cgroup=NULL, n.cgroup=NULL,
           rgroup=NULL, n.rgroup=NULL,
           cgroupTexCmd="bfseries",
           rgroupTexCmd="bfseries",
           rownamesTexCmd=NULL, 
           colnamesTexCmd=NULL,
           cellTexCmds=NULL,
           rowname, cgroup.just=rep("c",length(n.cgroup)),
           colheads=dimnames(cx)[[2]],
           extracolheads=NULL, extracolsize='scriptsize',
           dcolumn=FALSE, numeric.dollar=!dcolumn, cdot=FALSE,
           longtable=FALSE, draft.longtable=TRUE, ctable=FALSE, booktabs=FALSE,
           table.env=TRUE, here=FALSE, lines.page=40,
           caption=NULL, caption.lot=NULL, caption.loc=c('top','bottom'),
           double.slash=FALSE,
           vbar=FALSE, collabel.just=rep("c",nc), na.blank=TRUE,
           insert.bottom=NULL, first.hline.double=!(booktabs | ctable),
           where='!tbp', size=NULL,
           center=c('center','centering','none'),
           landscape=FALSE,
           multicol=TRUE, ## to remove multicolumn if no need  SSJ 17nov03
           math.row.names=FALSE, math.col.names=FALSE,
           ...)      ## center MJ 08sep03
{
  center <- match.arg(center)
  caption.loc <- match.arg(caption.loc)
  cx <- format.df(object, dcolumn=dcolumn, na.blank=na.blank,
                  numeric.dollar=numeric.dollar, cdot=cdot,
                  math.row.names=math.row.names, math.col.names=math.col.names,
                  ...)
  ## removed check.names=FALSE from above 23jan03
  if (missing(rowname))
    rowname <- dimnames(cx)[[1]]
  
  col.just <- attr(cx,"col.just")
  nc <- ncol(cx)
  nr <- nrow(cx)

  if (length(cgroup)) {
    k <- length(cgroup)
    if(!length(n.cgroup))
      n.cgroup <- rep(nc/k, k)
    
    if(sum(n.cgroup)!=nc)
      stop("sum of n.cgroup must equal number of columns")
    
    if(length(n.cgroup)!=length(cgroup))
      stop("cgroup and n.cgroup must have same lengths")
  }

  if(!length(rowname))
    rgroup <- NULL
  
  if(!length(n.rgroup) && length(rgroup))
    n.rgroup <- rep(nr/length(rgroup), length(rgroup))
  
  if(length(n.rgroup) && sum(n.rgroup)!=nr)
    stop("sum of n.rgroup must equal number of rows in object")
  
  if(length(rgroup) && length(n.rgroup) && (length(rgroup)!=length(n.rgroup)))
    stop("lengths of rgroup and n.rgroup must match")
  
  if (length(rgroup) && rowlabel.just=="l")
    rowname <- paste("~~",rowname,sep="")

  sl <- ifelse(double.slash, "\\\\", "\\")
  eol <-
    if(ctable)
      paste(sl, 'NN', sep='')
    else
      paste(sl,sl,sep='')
  
  if(booktabs) {  # 27may02
    toprule    <- paste(sl,"toprule",sep="")
    midrule    <- paste(sl,"midrule",sep="")
    bottomrule <- paste(sl,"bottomrule",sep="")
  } else if(ctable) {   ## 13dec02
    toprule    <- paste(sl, 'FL', sep='')
    midrule    <- paste(sl, 'ML', sep='')
    bottomrule <- paste(sl, 'LL', sep='')
  } else {
    toprule <-
      if(first.hline.double)
        paste(sl,"hline",sl,"hline",sep="")
      else
        paste(sl,"hline",sep="")
    
    midrule <- bottomrule <- paste(sl,"hline",sep="")
  }


  ## ################ CELL AND ROWNAMES FORMATS ###################
  ## If no formats are specified for the rownames and cells there is
  ## nothing to do. If only one is specified then the other must
  ## faked. But rownamesTexCmd should only be faked if rownames is
  ## not NULL.

  ## Check to make sure the dimensions of the cell formats
  ## match the dimensions of the object to be formatted.
  if (!is.null(cellTexCmds) &
      !(all(dim(cx) == dim(cellTexCmds)) &
        length(dim(cx)) == length(dim(cellTexCmds)))) {
    msg <- "The dimensions of cellTexCmds must be:"
    msg1 <- paste(dim(cx), collapse=" x ")
    msg <- paste(msg, msg1)
    msg <- paste(msg, ", but you gave me: ")
    msg1 <- paste(dim(cellTexCmds), collapse=" x ")
    msg <- paste(msg, msg1, sep="")
    stop(msg)
  }
  
  ## If there are column groups, add a blank column
  ## of formats between the groups.
  if (length(cgroup) & !is.null(cellTexCmds)) {
    my.index <- cumsum(n.cgroup)
    new.index <- NULL
    new.col <- dim(cx)[2] + 1
    for (i in seq(along=my.index))
      new.index <- c(new.index, my.index[i], new.col)
    
    new.index <- new.index[-length(new.index)]
    cellTexCmds <- cbind(cellTexCmds, "")[, new.index]
  }

  if (!is.null(cellTexCmds) | !is.null(rownamesTexCmd)) {
    ## LaTeX commands have been specified for either the rownames or
    ## the cells.
    ## Fake rownamesTexCmd if it is NULL and if rowname exists.
    if (is.null(rownamesTexCmd) & !is.null(rowname))
      rownamesTexCmd <- rep("", nr)
    
    ## Fake cellTexCmds if it is NULL.
    if (is.null(cellTexCmds)) {
      cellTexCmds <- rep("", dim(cx)[1] * dim(cx)[2])
      dim(cellTexCmds) <- dim(cx)
    }
    
    ## Create a combined rowname and cell format object.
    rcellTexCmds <- cbind(rownamesTexCmd, cellTexCmds)
    thisDim <- dim(rcellTexCmds)
    ## Prefix the latex commands with slashes.
    rcellTexCmds <- paste(sl, rcellTexCmds, sep="")
    ## Remove slashes from elements where no format was specified.
    rcellTexCmds[rcellTexCmds == sl] <- ""
    ## Restore the dimensions of the matrix (paste loses them).
    dim(rcellTexCmds) <- thisDim
  } else {
    rcellTexCmds <- NULL
  }

  ## ############## END OF CELL AND ROWNAMES FORMATS ###############
  
  
  ##if (!vbar && length(cgroup)) {
  if (length(cgroup)) {
    last.col <- cumsum(n.cgroup)
    first.col <- c(1, 1+last.col[-length(last.col)])
    cgroup.cols <- cbind(first.col,last.col)
    col.subs <- list()	
    for (i in seq(along=first.col))
      col.subs[[i]] <- first.col[i]:last.col[i]
    
    cxi <- list()
    for (i in seq(along=col.subs))
      cxi[[i]] <- cx[,col.subs[[i]],drop=FALSE]
    
    cxx <- cxi[[1]]
    col.justxx <- col.just[col.subs[[1]]]
    collabel.justxx <- collabel.just[col.subs[[1]]]
    extracolheadsxx <- extracolheads[col.subs[[1]]]

    cgroupxx <- cgroup[1]
    n.cgroupxx <- n.cgroup[1]
    for (i in seq(along=col.subs)[-1]) {
      cxx <- cbind(cxx, "", cxi[[i]])  # was ""="" 23Feb01 "=" 2Apr02
      col.justxx <- c(col.justxx, "c", col.just[col.subs[[i]]])
      collabel.justxx <- c(collabel.justxx, "c",
                           collabel.just[col.subs[[i]]])
      cgroupxx <- c(cgroupxx, "", cgroup[i])
      n.cgroupxx <- c(n.cgroupxx, 1, n.cgroup[i])
      extracolheadsxx <- c(extracolheadsxx, "",
                                         extracolheads[col.subs[[i]]])
    }
    
    cgroup.colsxx <- cgroup.cols + 0:(nrow(cgroup.cols)-1)
    
    cx <- cxx
    col.just <- col.justxx
    collabel.just <- collabel.justxx
    n.cgroup <- n.cgroupxx
    cgroup.cols <- cgroup.colsxx[cgroup!="",,drop=FALSE]
    cgroup <- cgroupxx
    extracolheads <- extracolheadsxx
    nc <- ncol(cx)
  }

  cline <- NULL
  if (length(rowname)) {
    cx <- cbind(rowname, cx)
    dimnames(cx)[[2]][1] <- rowlabel
    col.just <- c(rowlabel.just, col.just)
    if(length(extracolheads))
      extracolheads <- c('', extracolheads)  ## 16jun03
    
    collabel.just <- c(rowlabel.just, collabel.just)
    if (!length(cgroup))
      n.cgroup <- c(1, nc)
    else {
      cgroup <- c(rowlabel, cgroup)
      dimnames(cx)[[2]][1] <- ""
      rlj <- ifelse(rowlabel.just=="l", "l", "c")
      cgroup.just <- c(rlj, cgroup.just)
      n.cgroup <- c(1, n.cgroup)
      cgroup.cols <- 1+cgroup.cols
      cline <- paste(sl, "cline{", cgroup.cols[,1],"-", cgroup.cols[,2], "}",
                     sep="", collapse=" ")
    }
    
    nc <- 1 + nc
  }

  vbar <- ifelse(vbar, "|", "")

  if(!append)
    cat("", file=file)	#start new file
  
  cat("%",deparse(sys.call()), "\n%\n", file=file, append=file!='')
  ## append= 19apr03 and other places
  ## Was as.character(as.name(match.call()))  15Sep00

  if(dcolumn) {
    decimal.point <- ifelse(cdot, paste(sl,"cdot",sep=""), ".")
    cat(sl,"newcolumntype{.}{D{.}{",decimal.point,"}{-1}}\n",
        sep="", file=file, append=file!='')  # was newcolumn 26Feb02
  }

  { # tabular.cols
    tabular.cols <- paste(vbar, col.just, sep="")
    if (!length(n.cgroup))
      tabular.cols <- c(tabular.cols, vbar)
    else {
      vv2 <- cumsum(n.cgroup)
      tabular.cols[vv2] <- paste(tabular.cols[vv2],vbar,sep="")
    }
    
    tabular.cols <- paste(tabular.cols, collapse="")
  }

  if(length(caption) && !ctable) {
    caption <- paste(sl,"caption",
                     if(length(caption.lot))
                       paste("[",caption.lot,"]",sep=""),
                     "{", caption,
                     if(!longtable)
                       paste(sl,"label{", label, "}",sep=""),
                     "}", sep="")
    
    table.env <- TRUE
  }

  if(ctable) {  ## 13dec02
    latex.begin <- c(if(length(size))
                       paste('{',sl,size,sep=''),
                     paste(sl, "ctable[", sep=''),
                     if(length(caption) && caption.loc=='bottom')
                       'botcap,',
                     if(length(caption))
                       paste('caption={',caption,'},',sep=''),
                     if(length(caption.lot))
                       paste('cap={',caption.lot,'},',sep=''),
                     paste('label=',label,',',sep=''),
                     if(!landscape)
                       paste('pos=',where,',',sep=''),
                     if(landscape)
                       'rotate',
                     paste(']{',tabular.cols, '}',sep=''),
                     if(length(insert.bottom))
                       paste('{',sl,'tnote[]{',sedit(insert.bottom,'\\\\',' '),
                             '}}',
                             sep='')
                     else '{}',
                     ## tnote does not allow \\ in its argument
                     paste('{', toprule, sep='')
                     )
    
    latex.end <- c('}',
                   if(length(size))
                     '}')
    
  } else if(!longtable) {
    latex.begin <- c(if(landscape)
                       paste(sl, "begin{landscape}",sep=""),
                     if(table.env)
                       paste(sl, "begin{table}",
                             if(here)
                               "[H]"
                             else
                               paste('[',where,']',sep=''),
                             "\n", sep=""),
                     if(length(size))
                       paste(sl,size,'\n',sep=''),
                     if(caption.loc=='top' && !missing(caption))
                       paste(caption, "\n"),              ## 3oct03
                     if(center == 'center')             ## MJ: 08sep03
                       paste(sl,"begin{center}\n", sep="")## MJ: 08sep03
                     else {
                       if (center == 'centering')  ## MJ: 08sep03
                         paste(sl,"centering\n", sep="")
                     }, ## MJ: 08sep03
                     paste(sl,"begin{tabular}{", tabular.cols, "}",
                           toprule, "\n", sep="")
                     ## 11Jun95   12jan03 "}" was "}{" WHY!
                     )
    
    latex.end <- c(paste(sl,"end{tabular}\n", sep = ""),
                   if(center == 'center')  ## MJ: 08sep03
                     paste(sl,"end{center}\n", sep=""), ## MJ: 08sep03
                   if(caption.loc=='bottom' && !missing(caption))
                     paste(caption,'\n'),   # 3oct03
                   if(length(insert.bottom))
                     insert.bottom,
                   if(table.env)
                     paste(sl, "end{table}\n", sep=""),
                   if(landscape)
                     paste(sl, "end{landscape}\n", sep="")
                   )
  } else {
    latex.begin <- c(paste(if (!draft.longtable)
                             paste(sl,"let",sl,"LTmulticolumn=",sl,"multicolumn", sep=""),
                           paste(sl,"setlongtables",sep=""),
                           if(landscape)
                             paste(sl, "begin{landscape}",sep=""),
                           if(length(size))
                             paste('{',sl,size,'\n',sep=''),
                           paste(sl,"begin{longtable}{", tabular.cols, "}",sep=""),
                           sep="\n"),
                     if(caption.loc=='top' && !missing(caption))
                       paste(caption, sl,sl,"\n", sep=""),
                     paste(toprule, "\n", sep="")    #11Jun95
                     )
    
    latex.end <- paste(if(caption.loc=='bottom' && !missing(caption))
                         paste(caption, sl,sl,"\n",sep=""),  ## 3oct03
                       paste(sl,"end{longtable}\n", sep=""),
                       if(length(size))
                         '}',
                       if(landscape)
                         paste(sl,"end{landscape}\n",sep="")
                       )
  }
  
  cat(latex.begin, file=file, append=file!='')

  if(length(cgroup)) {  # was !missing 5Oct00
    cvbar <- paste(cgroup.just, vbar, sep="")
    cvbar[1] <- paste(vbar, cvbar[1], sep="")
    cvbar[-length(cvbar)] <- paste(cvbar[-length(cvbar)], vbar, sep="")
    slmc <- paste(sl,"multicolumn{",sep="")
    ##labs <- paste(sl, "bf ", cgroup, sep="") 
    if (!is.null(cgroupTexCmd))
      labs <- paste(sl, cgroupTexCmd, " ", cgroup, sep="")
                                        # DRW 12apr05.
    
    if(multicol) ## SSJ 17nov03
      labs <- paste(slmc, n.cgroup, "}{", cvbar, "}{", labs, "}", sep="")

    cat(labs, file=file, sep="&\n", append=file!='')
    
    if (!length(cline)) {   # was is.length 2Apr02
      inr <- as.numeric(length(rowname))
      cline <- paste(sl,"cline{",1+inr,"-",nc,"}",sep="")
    }
    
    cat(eol, " ",cline,"\n", sep="",file=file, append=file!='')
    ## eol was sl, sl  13dec02
  }


  { # column labels
    cvbar <- paste(collabel.just, vbar, sep="")
    cvbar[1] <- paste(vbar, cvbar[1], sep="")
    if (length(n.cgroup)) {
      vv2 <- cumsum(n.cgroup[-length(n.cgroup)])
      cvbar[vv2] <- paste(cvbar[vv2],vbar,sep="")
    }
    slmc1 <- paste(sl, "multicolumn{1}{", sep="")
    ##labs <- dimnames(cx)[[2]]   ## 28apr03 and next 5  15jul03 next 2
    labs <- colheads
    if (!is.null(colnamesTexCmd))
      labs <- paste(sl, colnamesTexCmd, " ", labs, sep="")
                                        # DRW 12apr05.
    
    if(length(labs)) {
      if(!length(extracolheads)) {
        heads <- get2rowHeads(labs)
        labs <- heads[[1]]
        if(any(heads[[2]] != ''))
          extracolheads <- heads[[2]]
      }
      
      if(multicol) ## SSJ 17nov03
        labs <- paste(slmc1, cvbar, "}{", labs, "}", sep="")
      
      cat(labs, file=file, sep="&\n", append=file!='')

      if(length(extracolheads)) {
        extracolheads <- ifelse(extracolheads==''| extracolsize=='',
                                extracolheads,
                                paste('{',sl,extracolsize,' ',
                                      extracolheads,'}',sep=''))
        
        ## SSJ 17nov03 add | extracolsize=='' to avoid putting {\ } if you don't wont change size in second line title 
        if(multicol) ## SSJ 17nov03
          extracolheads <- ifelse(extracolheads=='',extracolheads,
                                  paste(slmc1,cvbar,'}{',extracolheads,'}',sep=''))
        else
          extracolheads <- ifelse(extracolheads=='',extracolheads,
                                  paste(extracolheads,sep=''))
        
        ##cat(eol," ", paste(c(if(length(rowname))'',extracolheads),collapse='&'),
        ##file=file, append=file!='') # 21jan03
        cat(eol," ", paste(extracolheads,collapse='&'),
            file=file, append=file!='') # 28apr03
      }
      
      if(ctable)
        cat(midrule, '\n', sep='', file=file, append=file!='')
      else
        cat(eol," ",midrule, "\n",sep="",file=file, append=file!='')
      ## eol was sl, sl  13dec02
    }
  }


  if(longtable) {
    if(missing(caption))
      cat(sl,"endhead\n",midrule,sl,"endfoot\n",sep="",
          file=file,append=file!='')
    else {
      cat(sl,"endfirsthead\n", sep="",file=file, append=file!='')
      cat(sl,"caption[]{\\em (continued)} ",sl,sl,"\n",
          sep="",file=file, append=file!='')
      cat(midrule, "\n", sep="",file=file, append=file!='')
      cat(labs, file=file, sep="&", append=file!='')
      cat(sl, sl, " ", midrule, "\n", sl, "endhead", midrule, "\n",
          sep="", file=file, append=file!='')
      if(length(insert.bottom)) {
        cat(sl, 'multicolumn{', nc, '}{l}{', sl, "parbox[t]", sl, 'LTcapwidth{',
            insert.bottom, '}}', sl, sl, '\n',
            sep="", file=file, append=file!='')
      }
    
      cat(sl,"endfoot\n", sep="",file=file, append=file!='')
      cat(sl,"label{", label, "}\n", sep="", file=file, append=file!='')
    }
  }

  { # individual lines, grouped if appropriate, longtable if appropriate
    if (length(n.rgroup)) {
      rg.end   <- cumsum(n.rgroup)
      rg.start <- rg.end-n.rgroup+1
      if(!length(rgroup)) {
        rgroup <- rep("",length(n.rgroup))
      } else {
        if (!is.null(rgroupTexCmd)) { # DRW 12apr05. This if block.
          rgroup <- paste("{",sl, rgroupTexCmd, " ", rgroup,"}",sep="") 
        } else {
          rgroup <- paste("{", rgroup,"}",sep="") 
        }
      }
      
      ##else rgroup <- paste("{",sl,"bf ",rgroup,"}",sep="") 
      seq.rgroup <- seq(along=n.rgroup)
    } else {
      seq.rgroup <- 1
      rg.end <- nr
      rg.start <- 1
    }

    linecnt <- 0
    for (j in seq.rgroup) {
      if (length(n.rgroup)) {
        if(longtable && linecnt>0 &&
           (linecnt+n.rgroup[j]+(n.rgroup[j]>1)) > lines.page) {
          cat(sl,"newpage\n", sep="",file=file, append=file!='')
          linecnt <- 0
        }
        
        cat(rgroup[j], rep("",nc-1), sep="&", file=file, append=file!='')
        cat(eol,"\n", sep="",file=file, append=file!='')
        ## eol was sl,sl 13dec02
        linecnt <- linecnt+1
      }

      ## Write the object (and it's formatting instructions)
      ## to the output.
      ## Loop through the rows of the object.
      for(i in rg.start[j]:rg.end[j]) {
        if (!length(n.rgroup)) {
          if(longtable && linecnt>0 && (linecnt+1 > lines.page)) {
            cat(sl,"newpage\n",sep="",file=file, append=file!='')
            linecnt <- 0						
          }
        }

        ## Loop through the columns of the object
        ## write each value (and it's format if there
        ## is one). 
        ## DRW 12apr05. This if/else block.
        if (!is.null(rcellTexCmds)) {
          num.cols <- ncol(cx)
          for (colNum in 1:num.cols) {
            cat(rcellTexCmds[i, colNum], " ", cx[i, colNum],
                file=file, append=file!='')
            if (colNum < num.cols)
              cat(" & ", file=file, append=file!='')
          }
        } else {
          ## Original code that writes object to output.
          cat(cx[i,], file=file, sep="&", append=file!='')
        }
        
        cat(if(!ctable || i < rg.end[j])
              eol,
            "\n", sep="",file=file, append=file!='')
        
        ## eol was sl,sl  added if( ) 13dec02
        linecnt <- linecnt+1
      }  ## End of for loop that writes the object.

      if(length(n.rgroup) > j)
        cat(midrule, "\n", sep = "", file=file, append=file!='')
      else
        cat(bottomrule, "\n", sep="",file=file, append=file!='')
    }
  }

  cat(latex.end, file=file, sep="\n", append=file!='')
  sty <- c("longtable"[longtable], "here"[here], "dcolumn"[dcolumn],
           "ctable"[ctable], "booktabs"[booktabs],
           if(landscape && !ctable) "lscape")
  
  structure(list(file=file, style=sty), class='latex')
}


## Re-written by Daniel Calvelo Aros <dcalvelo@minag.gob.pe> to not use
## S.sty  18Feb04
latex.function <- function(object,
                           title=first.word(deparse(substitute(object))),
                           file=paste(title, ".tex", sep=""),
                           append=FALSE, assignment=TRUE,
                           type=c('example','verbatim'), ...)
{
  type <- match.arg(type)
  type <- match.arg(type)
  fctxt <- format(object)
  if(assignment) fctxt[1] <- paste(title , '<-', fctxt[1]) 
  environment <- ifelse(type=='example', "alltt", "verbatim")
  preamble <- paste("\\begin{",environment,"}\n",sep="")
  cat(preamble, file=file, append=file!="")
  rxs <-
    if(type=='example')
      c("\t=>    ",
        "\\\\=>\\\\(\\\\backslash\\\\)",
        "([{}])=>\\\\\\1",
        "<-=>\\\\(\\\\leftarrow\\\\)",
        "#(.*?$)=>{\\\\rm\\\\scriptsize\\\\#\\1}"
        )
    else c("\t=>    ")
  
  substitute <- strsplit( rxs, "=>" )
  for(line in fctxt) {
    for( subst in substitute ) {
      line <- gsub( subst[1], subst[2], line, perl=TRUE )
    }
    
    line <- paste(line,"\n",sep="")
    cat(line, file=file, append=file!="")
  }
  
  postamble <- paste("\\end{",environment,"}\n", sep="")
  cat(postamble, file=file, append=file!='')

  structure(list(file=file, style=if(type=='example')'alltt'), class='latex')
}


latexVerbatim <- function(x,
                          title=first.word(deparse(substitute(x))),
                          file=paste(title, ".tex", sep=""),
                          append=FALSE, size=NULL, hspace=NULL,
                          width=.Options$width,
                          length=.Options$length, ...)
{
  if(!missing(width) || !missing(length)) {
    old <- options(width=width, length=length)
    on.exit(options(old))
  }

  sink(file, append=append)
  cat('\\setbox0=\\vbox{\n',
      if(length(size))
        c('\\',size,'\n'),
      '\\begin{verbatim}\n', sep='')
  
  print(x, ...)
  cat('\\end{verbatim}\n}\n',
      if(length(hspace))
        c('\\hspace{',hspace,'}'),
      '{\\makebox[\\textwidth]{\\box0}}\n', sep='')
  
  sink()
 
  structure(list(file=file, style=NULL), class='latex')
}

latex.list <- function(object,
                       title=first.word(deparse(substitute(object))),
                       file=paste(title, ".tex", sep=""), append=FALSE,
                       label,
                       caption, caption.lot,
                       caption.loc=c('top','bottom'),
                       ...)
{
  caption.loc <- match.arg(caption.loc)
  nx <-	names(object)
  if (!length(nx))
    nx <- paste(title, "[[", seq(along=object), "]]", sep="")
  
  tmp <- latex(object=object[[1]],
               caption=nx[1], label=nx[1], append=append, title=title,
               file=file, caption.lot=NULL,
               caption.loc=caption.loc, ...)
  
  tmp.sty <- tmp$style
  for (i in seq(along=object)[-1]) {
    tmp <- latex(object=object[[i]],
                 caption=nx[i], label=nx[i], append=file!='', title=title, file=file,
                 caption.lot=NULL, caption.loc=caption.loc, ...)
    
    tmp.sty <- c(tmp.sty, tmp$style)
  }
  
  sty <-
    if(length(tmp.sty))
      unique(tmp.sty)
    else
      NULL
  
  structure(list(file=file, style=sty), class='latex')
}


## Function to translate several expressions to LaTeX form, many of
## which require to be put in math mode.
## Arguments inn and out specify additional input and translated
## strings over the usual defaults.
## If pb=T, also translates [()] to math mode using \left, \right
## Assumes that input text always has matches, e.g. [) [] (] (), and
## that surrounding  by $$ is OK
## latexTranslate is used primarily by summary.formula
latexTranslate <- function(object, inn=NULL, out=NULL, pb=FALSE,
                           greek=FALSE, ...)
{
  text <- object
  
  inn <- c("|",  "%",  "#", "<=",     "<",  ">=",     ">",  "_", "\\243",
           inn, 
           if(pb)
             c("[","(","]",")"))

  out <- c("$|$","\\%","\\#", "$\\leq$","$<$","$\\geq$","$>$","\\_", "\\pounds",
           out, 
           if(pb)
             c("$\\left[","$\\left(","\\right]$","\\right)$"))

  text <- sedit(text, '$', 'DOLLARS', wild.literal=TRUE)   ##17Nov00
  text <- sedit(text, inn, out)

  ##See if string contains an ^ - superscript followed by a number
  ## (number condition added 31aug02)

  dig <- c('0','1','2','3','4','5','6','7','8','9')

  for(i in 1:length(text)) {
    lt <- nchar(text[i])
    x <- substring(text[i],1:lt,1:lt)
    j <- x=='^'
    if(any(j)) {
      is <- ((1:lt)[j])[1]  #get first ^
      remain <- x[-(1:is)]
      k <- remain %in% c(' ',',',')',']','\\','$')
      ## Following 3 lines 31aug02
      if(remain[1] %in% dig ||
         (length(remain) > 1 && remain[1]=='-' && remain[2] %in% dig))
        k[-1] <- k[-1] | remain[-1] %nin% dig
      
      ie <-
        if(any(k))
          is + ((1:length(remain))[k])[1]
        else
          length(x)+1
      
      ##See if math mode already turned on (odd number of $ to left of ^)
      dol <-
        if(sum(x[1:is]=='$') %% 2)
          ''
        else '$'
      
      substring2(text[i],is,ie-1) <- paste(dol,'^{',
                                           substring(text[i],is+1,ie-1),'}',
                                           dol,sep='')  # 25May01
    }
    
    if(greek) {
      gl <- Cs(alpha,beta,gamma,delta,epsilon,varepsilon,zeta,eta,theta,
               vartheta,iota,kappa,lambda,mu,nu,xi,pi,varpi,rho,varrho,
               sigma,varsigma,tau,upsilon,phi,carphi,chi,psi,omega,Gamma,
               Delta,Theta,Lambda,Xi,Pi,Sigma,Upsilon,Phi,Psi,Omega)
      for(w in gl)
        text[i] <- gsub(paste('\\b', w, '\\b', sep=''),
                        paste('$\\\\',w,'$',   sep=''),
                        text[i])
    }
  }
  
  sedit(text, 'DOLLARS', '\\$', wild.literal=TRUE)  ## 17Nov00
}


latex <- function(object,
                  title=first.word(deparse(substitute(object))),...)
{
  ## added title= 25May01
  if (!length(oldClass(object)))
    oldClass(object) <- data.class(object)
  
  UseMethod("latex")
}


optionsCmds <- function(pgm)
{
  optionName <- paste(pgm,'cmd',sep='')
  v <- .Options[[optionName]]
  if(pgm=='xdvi' && !under.unix && !length(v))
    v <- 'yap'  # MikTeX  7Feb03
  
  if(length(v) && v!='')
    pgm <- v
  
  pgm
}


dvi.latex <- function(object, prlog=FALSE,
                      nomargins=TRUE, width=5.5, height=7, ...)
{
  fi <- object$file;
  sty <- object$style

  if(length(sty))
    sty <- paste('\\usepackage{',sty,'}',sep='')
  
  if(nomargins)
    sty <-  c(sty,
              paste('\\usepackage[paperwidth=',width,
                    'in,paperheight=', height,
                    'in,noheadfoot,margin=0in]{geometry}',sep=''))
  
  ## pre <- tempfile(); post <- tempfile()  # 1dec03
  tmp <- tempfile()
  tmptex <- paste(tmp, 'tex', sep='.')
  infi <- readLines(fi, n=-1)       # Splus 7 doesn't default to read to EOF 3may05
  cat('\\documentclass{report}', sty,
      '\\begin{document}\\pagestyle{empty}', infi,
      '\\end{document}\n', file=tmptex, sep='\n')
  
  sc <-
    if(under.unix) {
      '&&'
    } else {
      '&'   # DOS command separator
    }
  
  sys(paste('cd',shQuote(tempdir()),sc,optionsCmds('latex'),
            '-interaction=scrollmode', shQuote(tmp)), output=FALSE)
  
  if(prlog)
    cat(scan(paste(tmp,'log',sep='.'),list(''),sep='\n')[[1]],
        sep='\n')
  
  fi <- paste(tmp,'dvi',sep='.')
  structure(list(file=fi), class='dvi')
}


if(.R. && FALSE) show <- function(object) UseMethod('show')


show.dvi <- function(object, width=5.5, height=7)
{
  viewer <- optionsCmds('xdvi')
  cmd <-
    if(viewer=='yap') {
      paste(viewer,object$file)
    }
    else {
      if(viewer=='kdvi') {
        paste(viewer,object$file,'&')
      }
      else {
        paste(viewer, ' -paper ',
              width,'x',height,'in -s 0 ',
              object$file,' &',sep='')
      }
    }
  
  sys(cmd)
  invisible()
}


## enhanced show.latex 22dec02 - special treatment of file==''
show.latex <- function(object)
{
  if(object$file=='') {
    if(length(object$style)) {
      latexStyles <-
        if(exists('latexStyles'))
          unique(c(latexStyles, object$style))
        else object$style
      
      storeTemp(latexStyles,'latexStyles')
    }
    
    return(invisible())
  }
  
  show.dvi(dvi.latex(object))
}


print.dvi <- function(x, ...) show.dvi(x)
print.latex <- function(x, ...) show.latex(x)
  
dvi         <- function(object, ...) UseMethod('dvi')
dvips       <- function(object, ...) UseMethod('dvips')
dvigv       <- function(object, ...) UseMethod('dvigv')
dvips.dvi   <- function(object, file, ...)
{
  cmd <-
    if(missing(file))
      paste(optionsCmds('dvips'), shQuote(object$file))
    else
      paste(optionsCmds('dvips'),'-o', file, shQuote(object$file))
  
  ## paste(optionsCmds('dvips'),'-f', object$file,' | lpr') else 5dec03
  ## 2 dQuote 26jan04
  invisible(sys(cmd))
}

dvigv.dvi   <- function(object, ...)
  invisible(sys(paste(optionsCmds('dvips'), '-f', object$file,
                      '| gv - &')))

## added ... to dvixx.dvi calls below 1dec03
dvips.latex <- function(object, ...) invisible(dvips.dvi(dvi.latex(object),...))
dvigv.latex <- function(object, ...) invisible(dvigv.dvi(dvi.latex(object),...))


html <- function(object, ...) UseMethod('html')


html.latex <- function(object, file, ...)
{
  fi  <- object$file
  sty <- object$style
  
  if(length(sty))
    sty <- paste('\\usepackage{',sty,'}',sep='')
  
  ## pre <- tempfile(); post <- tempfile()  1dec03
  tmp <- tempfile()
  tmptex <- paste(tmp,'tex',sep='.')  # 5dec03
  infi <- readLines(fi)
  cat('\\documentclass{report}', sty, '\\begin{document}', infi,
      '\\end{document}\n', file=tmptex, sep='\n')
  ##  if(under.unix)
  ##    sys(paste('cat',pre,fi,post,'>',paste(tmp,'tex',sep='.')))
  ##  else sys(paste('copy',pre,'+',fi,'+',post,paste(tmp,'tex',sep='.')))
  ## 17dec02
  ##  unlink(c(pre,post))
  sc <-
    if(under.unix)
      ';'
    else
      '&'  # 7feb03

  ## Create system call to hevea to convert temporary latex file to html.
  cmd <-
    if(missing(file)) {
      paste(optionsCmds('hevea'), shQuote(tmptex))
    } else {
      paste(optionsCmds('hevea'), '-o', file, shQuote(tmptex))
    }
    
  ## perform system call
  sys(cmd)
  ## 24nov03 dQuote

  ## Check to see if .html tag exist and add it if
  ## if does not
  if(missing(file)) {
    file <- paste(tmp,'html',sep='.')
  } else {
    if(!length(grep(".*\\.html", file))) {
      file <- paste(file, 'html', sep='.')
    }
  }
  
  structure(list(file=file), class='html')
}


html.data.frame <-
  function(object,
           file=paste(first.word(deparse(substitute(object))),
                      'html',sep='.'),
           append=FALSE, link=NULL, linkCol=1,
           linkType=c('href','name'), ...)
{
  linkType <- match.arg(linkType)
  
  x   <- format.df(object, ...)
  adj <- attr(x,'col.just')

  if(any(adj=='r'))
    for(i in seq(along=adj)[adj=='r'])
      x[,i] <- paste('<div align=right>',x[,i],'</div>',sep='')

  if(length(r <- dimnames(x)[[1]]))
    x <- cbind('Name'=r, x)
  
  cat('<TABLE BORDER>\n', file=file, append=append)
  cat('<tr>', paste('<td><h3>', dimnames(x)[[2]], '</h3></td>',sep=''), '</tr>\n',
      sep='', file=file, append=file!='')
  
  if(length(link)) {
    if(is.matrix(link)) 
      x[link!=''] <- paste('<a ',linkType,'="', link[link!=''],'">',
                           x[link!=''],'</a>',sep='') else
    x[,linkCol] <- ifelse(link=='',x[,linkCol],
                          paste('<a ',linkType,'="',link,'">',
                                x[,linkCol],'</a>',sep=''))
  }
  
  for(i in 1:nrow(x))
    cat('<tr>',paste('<td>',x[i,],'</td>',sep=''),'</tr>\n',
        sep='', file=file, append=file!='')

  cat('</TABLE>\n', file=file, append=file!='')
  structure(list(file=file), class='html')
}


html.default <- function(object,
                         file=paste(first.word(deparse(substitute(object))),
                                    'html',sep='.'),
                         append=FALSE,
                         link=NULL, linkCol=1, linkType=c('href','name'),
                         ...)
{
  html.data.frame(object, file=file, append=append, link=link,
                  linkCol=linkCol, linkType=linkType, ...)
}

show.html <- function(object)
{
  browser <- .Options$help.browser
  if(!length(browser))
    browser <- .Options$browser
  
  if(!length(browser))
    browser <- 'netscape'
  
  sys(paste(browser, object, if(under.unix) '&'))
  invisible()
}

print.html <- function(x, ...) show.html(x)

latexSN <- function(x) {
  x <- format(x)
  x <- sedit(x, c('e+00','e-0*',
                  'e-*',
                  'e+0*',
                  'e+*'),
             c('',
               '\\!\\times\\!10^{-*}','\\!\\times\\!10^{-*}',
               '\\!\\times\\!10^{*}','\\!\\times\\!10^{*}'))
  x
}
ldBands <- function(n=length(times), times=NULL,  alpha=.05,
                    sided=2, alphaLower=alpha/2, alphaUpper=alpha/2,
                    information=NULL,
                    spending=c('OBrien-Fleming','Pocock','alpha*t^phi',
                               'Hwang-Shih-DeCani'),
                    phi=1,
                    spending2=c('OBrien-Fleming','Pocock','alpha*t^phi',
                                'Hwang-Shih-DeCani'),
                    phi2=phi,
                    truncate=Inf, power=NULL, pr=TRUE)
{
  if(missing(n) && missing(times))
    stop('must specify n or times')
  
  if(!length(times))
    times <- seq(0,1,length=n+1)[-1]
  
  spending  <- match.arg(spending)
  spending2 <-
    if(missing(spending2))
      spending
    else
      match.arg(spending2)
  
  alpha <- alphaLower+alphaUpper
  if(length(power) && length(information))
    stop('information may not be specified when power is')
  
  sp <- c('OBrien-Fleming'=1,'Pocock'=2,'alpha*t^phi'=3,
          'Hwang-Shih-DeCani'=4)[spending]
  if(sided != 3) {
    spending2 <- spending; sp2 <- sp
  } else
    sp2 <- c('OBrien-Fleming'=1,'Pocock'=2,'alpha*t^phi'=3,
             'Hwang-Shih-DeCani'=4)[spending2]

  if(phi==0) {
    warning('phi may not be zero.  Set to 1')
    phi <- 1
  }
  
  if(length(times))
    times <- sort(times)
  
  if(length(information))
    information <- sort(information)

  fi <- tempfile()
  ## Note: times always has length>0 below
  ## When power is given, assumes spending function always determines
  ## bounds
  p <- if(under.unix) function(x) paste(x,'\\n',sep='',collapse='')
       else function(x) paste(x,'\n', sep='',collapse='')
  
  ## If running Linux/Unix can avoid creating an input file, just pipe
  ## echo output as stdin.  echo needs embedded '\n' hence output \\n
    
  w <- paste(if(under.unix)
               'echo -e "'
             else '',
             p(0),
             p(if(length(power))
                 2
               else 1),
             
             p(n),
             p(if(length(times))
                 c(0,paste(times,collapse=' '))
               else 1),
             p(if(length(power))
                 1
               else if(length(information))
                 c(1,paste(information,collapse=' '))
               else 0),
             
             p(alpha), p(sided),
             if(sided==3)
               p(alphaLower)
             else '',
             
             p(sp),
             if(sp %in% 3:4)
               p(phi)
             else '',
             
             if(sided==3)
               p(c(sp2,
                   if(sp2 %in% 3:4)
                     phi2
                   else NULL))
             else '',
             
             p(if(is.infinite(truncate))
                 0
               else c(1,truncate)),
             
             if(length(power))
               p(power)
             else '',
             
             p(0),p(0),
             if(under.unix)
               '"'
             else '',
             
             sep='')

  if(under.unix)
    sys(paste(w,'| ld98 >',fi))
  else {
    fin <- tempfile()
    cat(w, file=fin)
    sys(paste('ld98 <',fin,'>',fi))
    unlink(fin)
  }
  
  w <- if(.R.) scan(fi, what=list(z=''),sep='\n',quiet=TRUE)$z
       else scan(fi, what=list(z=''),sep='\n')$z
  
  if(pr)
    cat(w,sep='\n')
  
  unlink(fi)
  if(length(power)) {
    i <- grep('drift =',w)
    j <- substring.location(w[i], 'drift =')$last
    drift <- as.numeric(substring(w[i],j+1))
  } else drift <- NULL
  
  head <- grep(if(length(power))
                 'cum exit pr'
               else 'cum alpha',
               w)
  
  w <- w[(head+1):length(w)]
  tail <- grep(if(length(power))
                 'Would you like to start again'
               else 'Do you want to see a graph',
               w)
  
  w <- w[1:(tail-1)]
  z <- if(.R.) unPaste(w, ' +', extended=TRUE)
       else    unPaste(sedit(w,'  ',' '),' ')

  if(length(power)) {
    i <- 1   ## 19dec02
    tim        <- as.numeric(z[[i+2]])
    if(max(abs(tim-times)) > .01)
      stop('program logic error')
    
    low       <- as.numeric(z[[i+3]])
    hi        <- as.numeric(z[[i+4]])
    exit.prob <- as.numeric(z[[i+5]])
    cum.exit.prob <- as.numeric(z[[i+6]])
    data <- data.frame(time=times, lower=low,upper=hi,
                       exit.prob=exit.prob,cum.exit.prob=cum.exit.prob)
  } else {
    tim <- as.numeric(z[[2]])
    if(max(abs(tim-times)) > .01)
      stop('program logic error')
    
    i <- if(length(information))1
         else 0
    
    low       <- as.numeric(z[[3+i]])
    hi        <- as.numeric(z[[4+i]])
    alpha.inc <- as.numeric(z[[5+i]])
    cum.alpha <- as.numeric(z[[6+i]])
    data <- data.frame(time=times, lower=low,upper=hi,
                       alpha.inc=alpha.inc,cum.alpha=cum.alpha)
  }
  
  if(length(information))
    data$information <- information
  
  res <- structure(list(data=data, power=power, drift=drift,
                        type=if(length(power))
                          'power'
                        else 'boundaries',
                        
                        n=n, alpha=alpha, alphaLower=alphaLower,
                        alphaUpper=alphaUpper, sided=sided,
                        spending=spending, phi=phi,
                        spending2=spending2, phi2=phi2,
                        truncate=truncate),
                   class='ldBands')
  res
}


print.ldBands <- function(x, ...)
{
  if(x$sided < 3) {
    cat('alpha=',format(x$alpha),'\t',x$sided,
        '-sided  \tSpending function:',x$spending,sep='')
    if(x$spending=='alpha*t^phi')
      cat('\tExponent:',x$phi,sep='')
    
    if(x$spending=='Hwang-Shih-DeCani')
      cat('\tPhi:',x$phi,sep='')
  } else {
    cat('Lower bounds:\n\n')
    cat('alpha=',format(x$alphaLower),
        '\tSpending function:',x$spending,sep='')
    if(x$spending=='alpha*t^phi')
      cat('\tExponent:',x$phi,sep='')
    
    if(x$spending=='Hwang-Shih-DeCani')
      cat('\tPhi:',x$phi,sep='')
    
    cat('\n\nUpper bounds:\n\n')
    cat('alpha=',format(x$alphaUpper),
        '\tSpending function:',x$spending2,sep='')
    if(x$spending2=='alpha*t^phi')
      cat('\tExponent:',x$phi2,sep='')
    
    if(x$spending2=='Hwang-Shih-DeCani')
      cat('\tPhi:',x$phi2,sep='')
  }
  
  cat('\n\n')
  if(length(x$power))
    cat('Power:',x$power,'\tDrift:',x$drift,'\n\n')
  
  print(x$data)
  invisible()
}


plot.ldBands <- function(x, xlab='Time', ylab='Z', actual=NULL,
                         type='b', labels=NULL, ...)
{
  d <- x$data
  mfr <- par('mfrow')
  if(prod(mfr) != 1) {
    on.exit(par(mfrow=mfr))
    par(mfrow=c(2,1))
  }
  
  plot(d$time, d$lower, type=type, ylim=range(d$lower,d$upper),
       xlab=xlab, ylab=ylab, axes=length(labels)==0)
  if(length(labels)) {
    axis(2)
    if(length(labels) != length(d$time))
      stop('length of labels not equal to length of times generated by ldBands')
    axis(1, at=d$time, labels=labels)
  }
  
  lines(d$time, d$upper, type=type)
  if(length(actual))
    points(actual[[1]],actual[[2]], pch=16)
  
  if(x$type=='power')
    labcurve(list(Instant   =list(d$time,d$exit.prob),
                  Cumulative=list(d$time,d$cum.exit.prob)),
             lty=2:1, pl=TRUE, type=type,
             xlab=xlab, ylab='Exit Probability')
  
  invisible()
}


summary.ldBands <- function(object, stdiff=NULL, n=NULL,
                            p1=NULL, p2=NULL,
                            hr=NULL, events=NULL,
                            pbar=NULL, sd=NULL, ...)
{  
  if(length(pbar) + length(sd) == 0) {
    drift <- object$drift
    if(!length(drift))
      stop('did not specify power= to ldBands')

    if(length(p1))
      stdiff <- (p1-p2)/sqrt(p1*(1-p1)+p2*(1-p2))
    
    if(length(events))
      hr <- exp(2*drift/sqrt(events))
    
    if(length(hr))
      events <- 4*((drift/log(hr))^2)
  
    if(length(stdiff)+length(n)+length(events)==0)
      stop('must specify stdiff, n, hr, or events')

    if(length(stdiff))
      n <- (drift/stdiff)^2
    else if(length(n))
      stdiff <- drift/sqrt(n)
    
    structure(list(stdiff=stdiff, n=n, p1=p1, p2=p2, hr=hr, events=events,
                   drift=drift, power=object$power),
              class='summary.ldBands')
  } else {
    if(length(n) != nrow(object$data))
      stop('length of n must equal number of looks')
    d <- object$data
    d$n <- n
    if(length(pbar)) {
      sepdiff      <- sqrt(2*pbar*(1-pbar)/n)
      d$diff.lower <- d$lower*sepdiff
      d$diff.upper <- d$upper*sepdiff
      selogOR      <- sqrt(2/(pbar*(1-pbar)*n))
      d$or.lower   <- exp(d$lower*selogOR)
      d$or.upper   <- exp(d$upper*selogOR)
      object$data     <- d
      object
    } else {
      semeandiff   <- sd*sqrt(2/n)
      d$diff.lower <- d$lower*semeandiff
      d$diff.upper <- d$upper*semeandiff
      object$data     <- d
      object
    }
  }
}


print.summary.ldBands <- function(x, ...)
{
  cat('Drift:',x$drift,'\tPower:',x$power,sep='')
  if(length(x$p1))
    cat('\tp1:',x$p1,'\tp2:',x$p2,sep='')
  
  cat('\n\n')
  if(length(x$n))
    cat('Maximum sample size per treatment:', x$n,'\n',sep='')
  
  if(length(x$events))
    cat('Maximum number of events (both treatments combined):',
                           x$events,'\n',sep='')
  ## Thanks: marcel wolbers <marcel.wolbers@gmx.ch>
  if(length(x$stdiff))
    cat('Detectible standardized effect:\t', x$stdiff,'\n',sep='')
  if(length(x$hr))
    cat('Hazard ratio:\t',x$hr,'\n',sep='')
  
  invisible()
}
list.tree <- function(struct,depth=-1, numbers=FALSE, maxlen=22,
                      maxcomp=12, attr.print=TRUE, front="",
                      fill=". ", name.of, size=TRUE)
{ 
  if(depth==0)
    return()
  
  opts <- options(digits=5)
  on.exit(options(opts))
  if (missing(name.of))
    name.of <- deparse(substitute(struct))
  
  len <- length(struct)
  cat(front,name.of,"=",storage.mode(struct),len)
  if(size)
    cat(" (",object.size(struct)," bytes)",sep="")
  
  if(is.array(struct))
    cat("=",
        if(length(dimnames(struct)))
          "named", 
        "array",paste(dim(struct),collapse=" X "))
  
  if(is.ts(struct)) cat("= time series",tsp(struct)) 
  if(is.category(struct)) 
    cat("= category (",length(levels(struct))," levels)",sep="")
  
  if(length(attr(struct,'class'))>0)
    cat("(",attr(struct,'class'),")")
  
  if(is.atomic(struct) && !is.character(struct)&& len>0 && maxlen>0) {
    field <- "="
    for(i in 1:length(struct)) {
      field <- paste(field,format(as.vector(struct[i])))
      if(nchar(field)>maxlen-6) {
        field <- paste(field,"...");
        break
      }
    }
    
    cat(field,"\n",sep="")
  } else if(is.character(struct) && len>0 && maxlen>0) 
    cat("=",substring(struct[1:(last <- max(1,(1:len)
                                            [cumsum(nchar(struct)+1)<maxlen]))],1,maxlen),
        if(last<len)
          " ...","\n")
        else cat("\n")
  
  if (mode(struct)=="list" && len>0) {
    structnames <- names(struct)
    if(!length(structnames))
      structnames <- rep("",len)
    
    noname <- structnames==""
    structnames[noname] <- 
      paste("[[",(1:length(structnames))[noname],"]]",sep="")
    for (i in 1:min(length(structnames),maxcomp)) 
      if (mode(struct[[i]])=="argument" | mode(struct[[i]])=="unknown") 
        cat(front,fill," ",structnames[i]," = ",
            as.character(struct[[i]])[1],"\n",sep="")
      else 
        list.tree(struct[[i]],depth=depth-1,numbers,maxlen,maxcomp,
                  attr.print,
                  if(numbers)
                    paste(front,i,sep=".")
                  else paste(front,fill,sep=""),
                  
                  fill,structnames[i],size=FALSE)

    if(length(structnames)>maxcomp) 
      cat(front,fill," ...   and ",length(structnames)-maxcomp,
          " more\n",sep="")
  }
  
  attribs <- attributes(struct)
  attribnames <- names(attribs)
  if(length(attribnames)>0 && attr.print)
    for (i in (1:length(attribnames))
         [attribnames!="dim" & attribnames!="dimnames" & 
          attribnames!="levels" & attribnames!="class" &
          attribnames!="tsp" & 
          (attribnames!="names" | mode(struct)!="list")])
      list.tree(attribs[[i]],depth-1,numbers,maxlen,maxcomp,attr.print,
		if(numbers)
                  paste(front,i,sep="A")
                else paste(front,"A ",sep=""),
                
		fill,attribnames[i],size=FALSE)
  
  invisible()
}


##############################################################################
expr.tree <- function(struct,front="",fill=". ",name.of,numbers=FALSE,depth=-1,
                      show.comment=FALSE)
{ 
  if (missing(name.of))
    name.of <- deparse(substitute(struct))
  else if(is.atomic(struct) | is.name(struct))
    name.of <- paste(name.of,deparse(struct))
  
  cat(front,"",name.of,"=",mode(struct),length(struct),"\n")
  if(depth!=0 && is.recursive(struct) ) {
    structlength <- length(struct)
    structnames <- names(struct)
    if(length(structnames)==0)
      structnames <- rep("",structlength)
    if(structlength>0)
      for (i in 1:length(structnames)) {
        if((mode(struct[[i]])!="missing" || is.function(struct)) &&
           (mode(struct[[i]])!="comment" || show.comment))
          expr.tree(struct[[i]],
                    if(numbers)
                    paste(front,i,sep=".")
                    else paste(front,fill,sep=""),
                    
                    fill,structnames[i],numbers,"depth"=depth-1)
      }
  }
  
  invisible(character(0))
}
mApply <- function(X, INDEX, FUN, ..., simplify=TRUE, keepmatrix=FALSE) {
  ## Matrix tapply
  ## X: matrix with n rows; INDEX: vector or list of vectors of length n
  ## FUN: function to operate on submatrices of x by INDEX
  ## ...: arguments to FUN; simplify: see sapply
  ## Modification of code by Tony Plate <tplate@blackmesacapital.com> 10Oct02
  ## If FUN returns more than one number, mApply returns a matrix with
  ## rows corresponding to unique values of INDEX

  ## X should be either a Matrix or a Vector
  if((!is.matrix(X) && is.array(X)) || is.list(X)){
    if(is.data.frame(X))
      X <- as.matrix(X)
    else
      stop("X must either be a vector or a matrix")
  }

  km <- if(keepmatrix) function(x)x else function(x)drop(x)

  if(!is.matrix(X)) {  ## X is a vector
    r <- tapply(X, INDEX, FUN, ..., simplify=simplify)

    if(is.matrix(r))
      r <- km(t(r))

    else if(simplify && is.list(r))
      r <- km(matrix(unlist(r), nrow=length(r),
                       dimnames=list(names(r),names(r[[1]])), byrow=TRUE))
  }
  else {
    idx.list <- tapply(1:NROW(X), INDEX, c)
    r <- sapply(idx.list, function(idx,x,fun,...) fun(x[idx,,drop=FALSE],...),
                x=X, fun=FUN, ..., simplify=simplify)

    if(simplify)
      r <- km(t(r))
  }

  dn <- dimnames(r)
  lengthdn <- length(dn)
  if(lengthdn && !length(dn[[lengthdn]])) {
    fx <- FUN(X,...)
    dnl <- if(length(names(fx))) names(fx)
           else dimnames(fx)[[2]]

    dn[[lengthdn]] <- dnl
    dimnames(r) <- dn
  }

  if(simplify && is.list(r) && is.array(r)) {
    ll <- sapply(r, length)
    maxl <- max(ll)
    empty <- (1:length(ll))[ll==0]
    for(i in empty)
      r[[i]] <- rep(NA, maxl)

    ## unlist not keep place for NULL entries for nonexistent categories
    first.not.empty <- ((1:length(ll))[ll > 0])[1]
    nam <- names(r[[first.not.empty]])
    dr <- dim(r)
  
    r <- aperm(array(unlist(r), dim=c(maxl,dr),
                     dimnames=c(list(nam),dimnames(r))),
               c(1+seq(length(dr)), 1))
  }

  r
}

# $Id$
mChoice <- function(..., label='', sort.=TRUE,
                    sort.levels=c('original','alphabetic'),
                    add.none=FALSE, drop=TRUE)
{
  sort.levels <- match.arg(sort.levels)
  dotlist <- list(...)
  X <- matrix(as.character(unlist(dotlist)), ncol=length(dotlist))
  lev <- if(drop) unique(as.vector(X)) else
   unique(unlist(lapply(dotlist, function(x)levels(as.factor(x)))))
  if(sort.levels=='alphabetic') lev <- sort(lev)
  lev <- setdiff(lev,'')

  vcall <- as.character(sys.call())[-1]
  Y <- character(nrow(X))

  x <- matrix(match(X,lev), nrow=nrow(X))
  g <- function(w, sort.) {
    w <- w[!is.na(w)]
    if(!length(w)) return('')
    paste(if(sort.)sort(unique(w)) else unique(w), collapse=';')
  }
  Y <- apply(x, 1, g, sort.=sort.)

  if(add.none && any(Y=='') && 'none' %nin% lev) {
    lev <- c(lev, 'none')
    Y[Y==''] <- as.character(length(lev))
  }
  
  if(label == '')
    label <- attr(dotlist[[1]],'label')
  
  if(!length(label)) {
    label <- vcall[1]
    if(length(nn <- names(dotlist)[1]))
      label <- nn
  }
  
  structure(Y, label=label, levels=lev, class=c('mChoice','labelled'))
}

print.mChoice <- function(x, long=FALSE, ...) {
  if(long) print(format(x)) else {
    print(as.vector(x), quote=FALSE)
    cat('\nLevels:\n')
    print(attr(x,'levels'), quote=FALSE)
  }
  invisible()
}

format.mChoice <- function(x, minlength=NULL, sep=";", ...)
{
  lev <- attr(x, 'levels')
  if(length(minlength)) lev <- abbreviate(lev, minlength)
  w <- strsplit(x, ';')
  sapply(w, function(x, lev, sep)
         paste(lev[as.numeric(x)], collapse=sep), lev=lev, sep=sep)
}

'[.mChoice' <- function(x, ..., drop=FALSE) {
  if(drop) stop('drop=TRUE not implemented')
  atr <- attributes(x)
  atr$names <- NULL
  x <- NextMethod('[')
  combine(attributes(x)) <- atr
  x
}

as.double.mChoice <- function(x, drop=FALSE, ...) {
  lev <- attr(x,'levels')
  X <- matrix(0, nrow=length(x), ncol=length(lev),
              dimnames=list(names(x), lev))
  unused <- numeric(0)
  for(i in 1:length(lev)) {
    xi <- 1*inmChoice(x, i)
    if(sum(xi)==0) unused <- c(unused, i)
    X[,i] <- xi
  }
  if(drop && length(unused)) X <- X[,-unused,drop=FALSE]
  X
}

summary.mChoice <- function(object, ncombos=5, minlength=NULL, drop=TRUE, ...) {
  nunique <- length(unique(object))
  y <- gsub('[^;]', '', object)
  nchoices <- nchar(y)+1
  nchoices[object == ''] <- 0
  nchoices <- table(nchoices)
  
  X <- as.numeric(object, drop=drop)
  if(length(minlength)) dimnames(X)[[2]] <- abbreviate(dimnames(X)[[2]],minlength)
  crosstab <- crossprod(X)

  combos <- table(format(object, minlength))
  i <- order(-combos)
  combos <- combos[i[1:min(ncombos,length(combos))]]
  
  structure(list(nunique=nunique, nchoices=nchoices,
                 crosstab=crosstab, combos=combos,
                 label=label(object)),
            class='summary.mChoice')
}

print.summary.mChoice <- function(x, prlabel=TRUE, ...) {
  if(prlabel) cat(x$label, '   ', x$nunique, ' unique combinations\n', sep='')
  cat('Frequencies of Numbers of Choices Per Observation\n\n')
  print(x$nchoices)
  crosstab <-format(x$crosstab)
  crosstab[lower.tri(crosstab)] <- ''
  cat('\nPairwise Frequencies (Diagonal Contains Marginal Frequencies)\n')
  print(crosstab, quote=FALSE)
  s <- if(length(x$combos)==x$nunique) 'Frequencies of All Combinations' else
   paste('Frequencies of Top', length(x$combos), 'Combinations')
  cat('\n', s, '\n')
  print(x$combos)
  invisible()
}

inmChoice <- function(x, values) {
  lev <- attr(x, 'levels')
  if(is.character(values)) {
    v <- match(values, lev)
    if(any(is.na(v))) stop(paste('values not in levels:',
                                 paste(values[is.na(v)],collapse=';')))
    values <- v
  }
  x <- paste(';', unclass(x), ';', sep='')
  values <- paste(';', values, ';', sep='')
  res <- rep(FALSE, length(x))
  for(j in 1:length(values)) {
    i <- grep(values[j], x)
    if(length(i)) res[i] <- TRUE
  }
  res
}

is.mChoice <- function(x) inherits(x, 'mChoice')
makeNstr <- function(char, len) {
  mapply(function(char, len) {
    if(is.na(len)) {
      '\n'
    } else if(len == 0) {
      ''
    } else {
      paste(rep.int(x=char, times=len), collapse='')
    }
  }, char, len, USE.NAMES=FALSE)
}
mask<- function(a)
{
  ##determine which bits are on in a vector of status bytes
  if(a>=.Machine$integer.max)
    stop("Value > integer.max")
  
  a <- as.integer(a) 
  as.logical((rep(a, 8)%/%rep(2^(0:7), rep(length(a),8)))%%2)
}

##  Rick Becker
##  Improved by Peter Melewski 14Apr02

## Multiply matrix by a vector
## vector can be same length as # columns in a, or can be longer,
## in which case b[kint] is added to a * b[s:length(b)], s=length(b)-ncol(a)+1
## F. Harrell 17 Oct90
## Mod         5 Jul91 - is.vector -> !is.matrix
##            16 Oct91 - as.matrix -> matrix(,nrow=1)
##            29 Oct91 - allow b to be arbitrarily longer than ncol(a), use b(1)
##            13 Nov91 - matrix(,nrow=1) -> matrix(,ncol=1)
##            14 Nov91 - changed to nrow=1 if length(b)>1, ncol=1 otherwise
##            25 Mar93 - changed to use %*%
##            13 Sep93 - added kint parameter

matxv <- function(a, b, kint=1)
{
  if(!is.matrix(a)) {
    if(length(b)==1)
      a <- matrix(a, ncol=1) 
    else
      a <- matrix(a, nrow=1)
  }

  nc <- dim(a)[2]
  lb <- length(b)
  if(lb<nc)
    stop(paste("columns in a (",nc,") must be <= length of b (",
               length(b),")",sep=""))

  if(nc==lb)
    drop(a %*% b)
  else
    drop(b[kint] + (a %*% b[(lb-nc+1):lb]))
}

##storage.mode(a) <- "single"
##storage.mode(b) <- "double"
##
##library.dynam(section="local", file="matxv.o")
##
##.Fortran("matxv",a,b,d[1],d[2],length(b),c=single(d[1]), NAOK=T,
##	specialsok=T)$c


## $Id$
mdb.get <- function(file, tables=NULL, lowernames=FALSE, allow=NULL,
                    dateformat='%m/%d/%y', ...)
{
  rettab <- length(tables) && is.logical(tables)
  if(rettab) tables <- NULL
  if(!length(tables))
    tables <- system(paste('mdb-tables -1', file), intern=TRUE)
  if(rettab) return(tables)

  f <- tempfile()
  D <- vector('list', length(tables))
  names(D) <- tables

  for(tab in tables) {
    s <- system(paste('mdb-schema -T', shQuote(tab), file), intern=TRUE)
    start <- grep('^ \\($', s) + 1
    end   <- grep('^\\);$', s) - 1
    s <- s[start:end]
    s <- strsplit(s, '\t')
    vnames <- sapply(s, function(x)x[2])
    vnames <- makeNames(vnames, unique=TRUE, allow=allow)
    if(lowernames) vnames <- casefold(vnames)
    types  <- sapply(s, function(x)x[length(x)])
    datetime <- vnames[grep('DateTime', s)]
    system(paste('mdb-export', file, shQuote(tab), '>', f))
    d <- csv.get(f, datetimevars=datetime,
                 lowernames=lowernames, allow=allow,
                 dateformat=dateformat, ...)
    if(length(tables) == 1) return(d)
    else D[[tab]] <- d
  }
  D
}
if(!.R.) mem <- function()
{
  cat("Memory used:  Current=",memory.size(),
      " Maximum=",memory.size(TRUE),"\n")
  invisible()
}
minor.tick <- function(nx=2, ny=2, tick.ratio=.5)
{
  ax <- function(w, n, tick.ratio)
  {
    range <- par("usr")[if(w=="x") 1:2
                        else 3:4]
    
    tick.pos <-
      if(w=="x")
        par("xaxp")
      else par("yaxp")

    ## Solve for first and last minor tick mark positions that are on the graph

    distance.between.minor <- (tick.pos[2]-tick.pos[1])/tick.pos[3]/n
    possible.minors <- tick.pos[1]-(0:100)*distance.between.minor  #1:100 13may02
    low.minor <- min(possible.minors[possible.minors>=range[1]])
    if(is.na(low.minor)) low.minor <- tick.pos[1]
    possible.minors <- tick.pos[2]+(0:100)*distance.between.minor  #1:100 13may02
    hi.minor <- max(possible.minors[possible.minors<=range[2]])
    if(is.na(hi.minor))
      hi.minor <- tick.pos[2]

    if(.R.)
      axis(if(w=="x") 1
           else 2,
           seq(low.minor,hi.minor,by=distance.between.minor),
           labels=FALSE, tcl=par('tcl')*tick.ratio)
    else
      axis(if(w=="x") 1
           else 2,
           seq(low.minor,hi.minor,by=distance.between.minor),
           labels=FALSE, tck=par('tck')*tick.ratio)
  }

  if(nx>1)
    ax("x", nx, tick.ratio=tick.ratio)
  
  if(ny>1)
    ax("y", ny, tick.ratio=tick.ratio)

  invisible()
}
## $Id: model.frame.default.s 208 2005-07-12 22:01:34Z dupontct $

dropUnusedLevels <- function()
{
  sf <- function(x, i, drop=TRUE)
  {
    ## Jens Oehlschlaegel generalized to handle drop 12Oct97
    atx <- attributes(x)
    nam <- atx$names
    atx$levels <- atx$names <- NULL
    if(missing(i))
      i <- TRUE  ## 4nov02
    
    y <- as.integer(x)[i]     ## 4nov02
    ln <- length(nam)
    nam <-
      if(ln) nam[i]
      else NULL  ## 4nov02
    
    opt <- .Options$drop.factor.levels
    if(!length(opt))
      opt <- .Options$drop.unused.levels
    
    ## !missing(drop) added 31jul02
    if(drop && (!missing(drop) || (length(opt)==0 || opt))) {
      oldClass(y) <- NULL
      j <- sort(unique(y))
      y[] <- match(y,j)
      levels(y) <- levels(x)[j]
    } else if(length(y))
      levels(y) <- levels(x)
    
    attributes(y) <- c(attributes(y), atx,
                       if(ln) list(names=nam))
    y
  }
  
  assign('[.factor', sf, '.GlobalEnv')
  cat("\nTo revert to the R standard [.factor use remove('[.factor',pos='.GlobalEnv'),\n",
      "or to get the default R behavior type options(drop.unused.levels=FALSE).\n")
  invisible()
}


## Replaced with one more like default R  3nov02
## With R 1.6 was getting error with ... arguments
if(FALSE) '[.factor' <- function (x, i, drop = TRUE)
{
  y <- NextMethod("[")
  class(y) <- class(x)
  attr(y, "contrasts") <- attr(x, "contrasts")
  attr(y, "levels") <- attr(x, "levels")
  opt <- .Options$drop.factor.levels
  if(!length(opt))
    opt <- .Options$drop.unused.levels
  
  if(drop && (!missing(drop) || (length(opt)==0 || opt)))
    reFactor(y)
  else y
}


##For compatibility with SV4
if(!exists('oldUnclass'))
  oldUnclass  <- unclass

if(!exists('oldClass'))
  oldClass    <- class

if(!exists('oldClass<-'))
  'oldClass<-' <- function(x, value)
{
  class(x) <- value
  x
}

if(!exists('logb'))
  logb <- log

if(!exists('getFunction')) getFunction <- function(...)
  get(..., mode='function')

if(!exists('is.category'))
  is.category <- function(x) length(attr(x,'levels')) > 0 && mode(x)=='numeric'
## R doesn't have this

if(!exists('as.category'))
  as.category <- function(x)
{
  x <- as.factor(x)
  class(x) <- NULL
  x
}


termsDrop <- function(object, drop, data)
{
  trm <- terms(object, data=data)
  if(is.numeric(drop)) {
    vars <- attr(trm, 'term.labels')
    if(any(drop > length(vars)))
      stop('subscript out of range')
    
    drop <- vars[drop]
  }
  form <- update(trm,
                 as.formula(paste('~ . ',
                                  paste('-',drop,collapse=''))))
  terms(form, data=data)
}


untangle.specials <- function (tt, special, order = 1)
{
  ## From survival5
  spc <- attr(tt, "specials")[[special]]
  if (length(spc) == 0)
    return(list(vars = character(0), terms = numeric(0)))
  
  facs <- attr(tt, "factor")
  fname <- dimnames(facs)
  ff <- apply(facs[spc, , drop = FALSE], 2, sum)
  list(vars = (fname[[1]])[spc],
       terms = seq(ff)[ff & match(attr(tt,"order"),
                                  order, nomatch = 0)])
}


var.inner <- function(formula)
{
  if(!inherits(formula,"formula"))
    formula <- attr(formula,"formula")
  
  if(!length(formula))
    stop('no formula object found')
  
  if(length(formula) > 2)
    formula[[2]] <- NULL  # remove response variable
  
  av <- all.vars(formula)
  ## Thanks to Thomas Lumley <tlumley@u.washington.edu> 28Jul01 :
  unique(sapply(attr(terms(formula),"term.labels"),
                function(term,av)
                  av[match(all.vars(parse(text=term)),av)][1],
                  av=av))
}
## Thanks for Rick Becker for suggestions
mtitle <-
  function(main,ll,lc,
           lr=if(.R.) format(Sys.time(),'%d%b%y')
              else if(under.unix)unix("date '+%d%h%y'")
              else date(), 
           cex.m=1.75, cex.l=.5, ...)
{
  out <- any(par()$oma!=0)
  g <-
    if(out) function(...) mtext(..., outer=TRUE)
    else  function(z, adj, cex, side, ...) 
      if(missing(side))
        title(z, adj=adj, cex=cex)
      else
	title(sub=z, adj=adj, cex=cex)
  
  if(!missing(main))
    g(main,cex=cex.m,adj=.5)
  
  if(!missing(lc))
    g(lc,side=1,adj=.5,cex=cex.l,...)
  
  if(!missing(ll))
    g(ll,side=1,adj=0,cex=cex.l,...)
  
  if(lr!="")
    g(lr,side=1,adj=1,cex=cex.l,...)
  
  invisible()
}
if(!.R.) {
  mulbar.chart<-function(z, x, y, fun = mean, marginals=TRUE, subset, prt=TRUE,
                         zlab = label(z), xlab=label(x), ylab=if(!missing(y))label(y), 
                         varwidth=TRUE, overall, ...)
  {
    xl<-xlab
    yl<-ylab
    zl<-zlab
    if(!missing(subset)) {
      x <- x[subset]
      if(!missing(y)) y <- y[subset]
      z <- z[subset]
    }
    
    x<-as.category(x)
    count <- function(ww) sum(!is.na(ww))
    
    oldpar <- par(mar=c(7,4,3,2)+.1)
    if(marginals)
      ntext <- "n="
    else ntext <- "Maximum n="
    
    if(missing(y)){
      tabln <- tapply(z, list(x), count)
      tabl <- tapply(z, list(x), fun)
      nmin <- min(tabln)
      nmax <- max(tabln)
      cx <- category(row(tabl), label=levels(x))
      if(marginals) {
        tabln <- c(tabln, 1)
        tabl  <- c(tabl,
                   if(missing(overall)) fun(z)
                   else overall)
        
        levels(cx) <- c(levels(cx),"All")
      }
      
      names(tabl) <- levels(cx)
      names(tabln) <- levels(cx)
      if(varwidth)
        barplot(tabl, tabln, names=levels(cx), xlab=xl, main=zl)
      else barplot(tabl, names=levels(cx), xlab=xl, main=zl)
      
      mtext(paste("n=",count(z)," (",nmin,"-",nmax,")",sep=""),
            side=1,line=5,adj=0)
      
      if(varwidth)
        mtext("Width proportional to sample size",side=1,line=6,adj=0)
    } else {
      y<-as.category(y)
      tabl <- tapply(z, list(y,x), fun)
      tabln <- tapply(z, list(y,x), count)
      nmin <- min(tabln)
      cy <- category(row(tabl), label = levels(y))
      cx <- category(col(tabl), label = levels(x))
      if(marginals) {
        tabl <- cbind(tabl, tapply(z, list(y), fun))
        tabl <- rbind(tabl, c(tapply(z, list(x), fun), 
                              if(missing(overall)) fun(z)
                              else overall))
        
        tabln <- cbind(tabln, tapply(z, list(y), count))
        tabln <- rbind(tabln,c(tapply(z, list(x), count), 1))
        levels(cx) <- c(levels(cx),"All")
        levels(cy) <- c(levels(cy),"All")	}
      dimnames(tabl) <- list(levels(cy),levels(cx))
      dimnames(tabln) <- list(levels(cy),levels(cx))
      if(varwidth)
	mulbar(tabln, tabl, collab=levels(cx), rowlab = levels(cy), 
               main=zl, ylab=yl, ...)
      else
	mulbar(1+0*tabl, tabl, collab=levels(cx), rowlab=levels(cy), main=zl,
               ylab=yl, ...)
      
      mtext(xl,side=1,line=3)
      if(varwidth)
	mtext("Width proportional to sample size",side=1,line=6,adj=0)
      
      mtext(paste("n=",count(z)," (",nmin,"-",max(tabln),")",
                  "   Height=",signif(as.single(min(tabl)),5),
                  "-",signif(as.single(max(tabl)),5),sep=""),
            side=1,line=5,adj=0)
    }
    
    par(oldpar)
    if(prt) {
      print(zl,quote=FALSE)
      print(tabl,digits=4)
      print("------- n -------",quote=FALSE)
      print(tabln)
    }
    
    invisible()
  }
  
  NULL
}
## Enhancement of na.omit  F. Harrell 20 Oct 91
## Allows an element of the data frame to be another data frame
## Note: S does not invoke na.action if only a data frame variable is missing!

na.delete <- function(frame)
{
  y.detail <- na.detail.response(frame)
  n <- length(frame)
  omit <- FALSE
  vars <- seq(length = n)
  nmiss <- rep(0,n)
  storage.mode(nmiss) <- "integer"
  for(j in vars) {
    x <- frame[[j]]
    if(is.data.frame(x))
      x <- as.matrix(x)
    
    oldClass(x) <- NULL	#so Surv object is.na ignored
    if(!is.atomic(x)) 
      stop("non-atomic, non-data frame variables not allowed")
    
    ## variables are assumed to be either some sort of matrix, numeric or cat'y
    isna <- is.na(x)	#Change from T. Therneau
    d <- dim(x)
    if(is.null(d) || length(d) != 2) {
      ##isna <- is.na(x)
      nmiss[j] <- sum(isna)
      omit <- omit | isna
    } else {
      ##isna <-is.na(x %*% rep(0,d[2]))
      isna <- (isna %*% rep(1,d[2])) > 0
      nmiss[j] <- sum(isna)
      omit <- omit | isna
    }
  }
  
  if(any(omit)) {
    rn <- row.names(frame)

    frame <- frame[!omit,,drop=FALSE]
    names(nmiss) <- names(frame)
    ## a %ia% b terms are included - delete them since main effects
    ## already counted  (next 2 stmts reinstated 27Oct93)

    i <- grep("%ia%", names(nmiss))
    if(length(i)>0)
      nmiss <- nmiss[-i]
    
    attr(frame,"nmiss") <- nmiss    # for backward compatibility
    temp <- seq(omit)[omit]
    names(temp) <- rn[omit]
    na.info <- list(nmiss=nmiss, omit=temp, 
                    na.detail.response=y.detail)
    
    oldClass(na.info) <- "delete"
    attr(frame, "na.action") <- na.info
  }
  
  frame
}


naprint.delete <- function(x, ...)
{
  if(length(g <- x$nmiss)) {
    cat("Frequencies of Missing Values Due to Each Variable\n")
    print(g)
    cat("\n")
  }
  
  if(length(g <- x$na.detail.response)) {
    cat("\nStatistics on Response by Missing/Non-Missing Status of Predictors\n\n")
    print(oldUnclass(g))
    cat("\n")		
  }
  
  invisible()
}
   

naresid.delete <- function(omit, x, ...)
{
  omit <- omit$omit
  ## 28Oct99:
  if(exists('naresid.omit'))
    naresid.omit(omit, x)
  else {
    if(.R. && !existsFunction('naresid.exclude'))
      naresid.exclude <- getFromNamespace('naresid.exclude','stats')
    
    naresid.exclude(omit, x)
  }
}


nafitted.delete <- function(obj, x)
{
  omit <- obj$omit
  if(exists('naresid.omit'))
    naresid.omit(omit, x)
  else
    naresid.exclude(omit, x)
}
na.detail.response <- function(mf)
{
  if(is.null(z <- .Options$na.detail.response) || !z)
    return(NULL)
  
  response <- model.extract(mf, response)
  if(is.null(response))
    return(NULL)
  
  if(!is.matrix(response))
    response <- as.matrix(response)
  
  GFUN <- options()$na.fun.response
  if(is.null(GFUN))
    GFUN <-  function(x, ...)
    {
      if(is.matrix(x)) x <- x[,ncol(x)]
      x <- x[!is.na(x)]
      c(N=length(x),Mean=mean(x))
    }
  else GFUN <- eval(as.name(GFUN), local=FALSE)
  
  w <- NULL; nam <- names(mf); wnam <- NULL
  N <- nrow(mf)
  p <- ncol(mf)
  omit <- rep(FALSE, N)
  for(i in 2:p) {
    x <- mf[,i]
    if(is.matrix(x))
      x <- x[,1]
    
    isna <- is.na(x)
    omit <- omit | isna
    nmiss <- sum(isna)
    if(nmiss) {
      w <- cbind(w, GFUN(response[isna,]))
      wnam <- c(wnam, paste(nam[i],"=NA",sep=""))
    }
    
    n <- N-nmiss
    if(n) {
      w <- cbind(w, GFUN(response[!isna,]))
      wnam <- c(wnam, paste(nam[i],"!=NA",sep=""))
    }
  }

  ## summarize responce for ANY x missing
  if(p>2) {
    nmiss <- sum(omit)
    if(nmiss) {
      w <- cbind(w, GFUN(response[omit,]))
      wnam <- c(wnam, "Any NA")
    }
    
    if(N-nmiss) {
      w <- cbind(w, GFUN(response[!omit,]))
      wnam <- c(wnam, "No NA")
    }
  }

  dimnames(w)[[2]] <- wnam
  w
}
na.keep <- function(mf)
{
  w <- na.detail.response(mf)
  if(length(w))
    oldClass(w) <- 'keep'  ## 9Apr02
  
  attr(mf, "na.action") <- w
  mf
}


naprint.keep <- function(x, ...)
{
  if(length(x)) {
    cat("\nStatistics on Response by Missing/Non-Missing Status of Predictors\n\n")
    print(oldUnclass(x))
    cat("\n")
  }
  
  invisible()
}


naresid.keep <- function(omit, x, ...) x
na.pattern<-function(x)
{
  if(is.list(x)) {
    k <- length(x)
    n <- length(x[[1]])
    x <- matrix(unlist(x), n, k)
  }
  
  n <- dim(x)[1]
  k <- dim(x)[2]
  y <- matrix(as.integer(is.na(x)), n, k)
  pattern <- y[, 1]
  for(i in 2:k) {
    pattern <- paste(pattern, y[, i], sep = "")
  }

  table(pattern)
}
## Werner, Martin and Tim have added several useful
## things. At the end of this e-mail there is our final result.
##
## As an example we reproduced a similar figure as Fig. 4.23 of Chambers et
## al. (1983) "Graphical Methods For Data Analysis":
##
## ii_3:4
## x <- matrix(aperm(iris[,ii,], perm =c(1,3,2)), ncol=2,
##             dimnames=list(dimnames(iris)[[1]],dimnames(iris)[[2]][ii]))
## xr <- round(2*x,1)/2
## nam <- dimnames(xr)[[2]]
## p.sunflowers(xr[,1],xr[,2], xlab=nam[1], ylab=nam[2], size= 1/16,
##              main="Iris data")
##
##
## Andreas Ruckstuhl <ruckstuhl@stat.math.ethz.ch>			
## Seminar fuer Statistik, SOL G5, ETH (Federal Institute of Technology)
## 8092 Zurich	SWITZERLAND  	phone: x-41-1-256-5319  fax: x-41-1-252-3410
##
##
##================================ S function ========================
##

if(!.R.) {
  p.sunflowers <- function(x, y, number, size = 0.125, add = FALSE,
                           pch = 16, ...)
  {
    ## Purpose: Produce a 'sunflower'-Plot
    ## -------------------------------------------------------------------------
    ## Arguments: x,y: coordinates;
    ##    number[i] = number of times for (x[i],y[i])  [may be 0]
    ##    size: in inches;  1 in := 2.54 cm
    ##    add : (logical) Should I add to a previous plot ?
    ##    further args: as for plot(..)
    ## -------------------------------------------------------------------------
    ## Authors: Andreas Ruckstuhl, Werner Stahel, Martin Maechler, Tim Hesterberg
    ## Date   : Aug 89 / Jan 93,   March 92,      Jan 93,          Jan 93
    ## Examples: p.sunflowers(x=sort(round(rnorm(100))), y= round(2*rnorm(100),0))
    ## ~~~~~~~~  p.sunflowers(rnorm(100),rnorm(100), number=rpois(n=100,lambda=2), 
    ##                        main="Sunflower plot")
    
    n <- length(x)
    if(length(y) != n)
      stop("x & y must have same length !")
    
    if(missing(number)) {
      orderxy <- order(x, y)
      x <- x[orderxy]
      y <- y[orderxy]
      first <- c(TRUE, (x[-1] != x[ - n]) | (y[-1] != y[ - n]))
      x <- x[first]
      y <- y[first]
      number <- diff(c((1:n)[first], n + 1))
    } else {
      if(length(number) != n)
        stop("number must have same length as x & y !")
      
      x <- x[number > 0]
      y <- y[number > 0]
      number <- number[number > 0]
    }

    n <- length(x)
    if(!add) {
      axislabels <- match(c("xlab", "ylab"), names(list(...)))
      if(!is.na(axislabels[1]))
        xlab <- list(...)[[axislabels[1]]]
      else xlab <- deparse(substitute(x))
      
      if(!is.na(axislabels[2]))
        ylab <- list(...)[[axislabels[2]]]
      else ylab <- deparse(substitute(y))

      plot(x, y, xlab = xlab, ylab = ylab, type = "n", ...)
    }

    nequ1 <- number == 1
    if(any(nequ1))
      points(x[nequ1], y[nequ1], pch = pch, csi = size * 1.25)

    if(any(!nequ1))
      points(x[!nequ1], y[!nequ1], pch = pch, csi = size * 0.8)

    i.multi <- (1:n)[number > 1]
    if(length(i.multi)) {
      ppin <- par()$pin
      pusr <- par()$usr
      xr <- (size * abs(pusr[2] - pusr[1]))/ppin[1]
      yr <- (size * abs(pusr[4] - pusr[3]))/ppin[2]
      i.rep <- rep(i.multi, number[number > 1])
      z <- NULL
      for(i in i.multi)
        z <- c(z, 1:number[i])

      deg <- (2 * pi * z)/number[i.rep]
      segments(x[i.rep], y[i.rep], x[i.rep] + xr * sin(deg), y[i.rep] +
               yr * cos(deg))
    }
    
    invisible()
  }
  
  NULL
}
if(FALSE) {
  panel.abwplot <- function(x, y, box.ratio = 1, means=TRUE,
                            font = box.dot$font, pch = box.dot$pch, 
                            cex = box.dot$cex, 
                            col = box.dot$col, ...)
  {
    ok <- !is.na(x) & !is.na(y)
    x <- x[ok]
    y <- y[ok]
    y.unique <- sort(unique(y))
    width <- box.ratio/(1 + box.ratio)
    w <- width/2
    lineopts <- trellis.par.get("box.rectangle")
    for(Y in y.unique) {
      X <- x[y == Y]
      q <- quantile(X, c(.01,.05,.1,.25,.75,.9,.95,.99,.5))
      median.value <- list(x = q[9], y = Y)
      z <- c(1, .01,
             2, .01,
             2, .05,
             3, .05,
             3, .10,
             4, .10,
             4, .25,
             5, .25,
             5, .10,
             6, .10,
             6, .05,
             7, .05,
             7, .01,
             8, .01,
             8,-.01,
             7,-.01,
             7,-.05,
             6,-.05,
             6,-.10,
             5,-.10,
             5,-.25,
             4,-.25,
             4,-.10,
             3,-.10,
             3,-.05,
             2,-.05,
             2,-.01,
             1,-.01,
             1, .01)
      box.dot <- trellis.par.get("box.dot")
      box.dot.par <- c(list(pch = pch, cex = cex, col = col, font = font), ...)
      do.call('lines',c(list(x=q[z[seq(1,length(z),by=2)]],
                             y=Y + 4*w*z[seq(2,length(z),by=2)]),lineopts))
      ##do.call('segments',c(list(x1=q[c(2:7)],y1=Y+rep(-w,6),
      ##                     x2=q[c(2:7)],y2=Y+rep(w,6)),
      ##                     lineopts))
      
      do.call("points", c(median.value, box.dot.par))
      if(means)
        do.call('lines',c(list(x=rep(mean(X),2),y=Y+c(-w,w)),
                          lineopts, lty=2))
    }
  }
  
  NULL
}
panel.bpplot <- function(x, y, box.ratio = 1, means=TRUE, qref=c(.5,.25,.75),
                         probs= c(.05,.125,.25,.375), nout=0,
                         datadensity=FALSE, scat1d.opts=NULL,
                         font = box.dot$font, pch = box.dot$pch, 
                         cex  = box.dot$cex, col = box.dot$col, ...)
{
  if(.R.) {
    require(lattice)
  }

  grid <- .R.
  if(grid) {
    lines <- llines;
    points <- lpoints;
    segments <- lsegments
  }

  y <- as.numeric(y)   ## 25nov02
  ok <- !is.na(x) & !is.na(y)
  x <- x[ok]
  y <- y[ok]
  y.unique <-  sort(unique(y))
  width <- box.ratio/(1 + box.ratio)
  w <- width/2
  probs2 <- sort(c(probs,1-probs))

  box.dot  <- trellis.par.get("box.dot")
  lineopts <- trellis.par.get("box.rectangle")
  box.dot.par <- c(list(pch = pch, cex = cex, col = col, font = font), ...)

  m  <- length(probs)
  m2 <- length(probs2)
  j <- c(1,sort(rep(2:m2,2)),-sort(-rep(1:(m2-1),2)))
  z <- c(sort(rep(probs,2)),-sort(-rep(probs[1:(m-1)],2)))
  z <- c(z, -z, probs[1])
  k <- max(z)
  k <-
    if(k > .48)
      .5
    else k
  
  if(length(qref)) {
    size.qref <- pmin(qref, 1-qref)
    size.qref[qref==.5] <- k
  }
  
  for(Y in y.unique) {
    X <- x[y == Y]
    if(!length(X))
      next   ## 25nov02
    
    q <- quantile(X, c(probs2,qref))
    if(length(qref)) 
      do.call('segments',c(list(q[-(1:m2)],      Y-w*size.qref/k,
                                q[-(1:m2)], 	 Y+w*size.qref/k),
                           lineopts))
    
    do.call('lines',c(list(x=q[j], y=Y + w*z/k), lineopts))
    if(means) {
      mean.value <- list(x=mean(X), y=Y)
      do.call('points', c(mean.value, box.dot.par))
    }

    if(datadensity)
      do.call('scat1d',c(list(x=X,y=Y,grid=grid), scat1d.opts))

    if(nout>0) {
      ii <- if(nout < 1) {
        ## Note - bug in quantile - endless loop if probs=c(.5,.5)
        if(nout==.5)
          stop('instead of nout=.5 use datadensity=T')

        cuts <- quantile(X, c(nout,1-nout))
        X < cuts[1] | X > cuts[2]
      } else {
        X <- sort(X)
        nx <- length(X)
        ll <- 1:nx
        (ll <= min(nout,nx/2)) | (ll >= max(nx-nout+1,nx/2))
      }
      
      if(sum(ii))
        do.call('scat1d',c(list(x=X[ii],y=Y,grid=grid), scat1d.opts))
    }
  }
}


# Given a matrix where rows are groups and columns have all the
# quantiles already computed, plus the Mean, draw a panel containing
# horizontal box-percentile plots like the default in panel.bpplot.  This is
# primarily for plot.summary.formula.reverse's continuous variable
# plots
bpplt <- function(stats, xlim, xlab='', box.ratio = 1, means=TRUE,
                  qref=c(.5,.25,.75), qomit=c(.025,.975),
                  pch=16, cex.labels=par('cex'),
                  cex.points=if(prototype)1
                             else .5,
                  grid=FALSE)
{
  prototype <- missing(stats)
  if(prototype) {
    x <- c(.025,.05,.125,.25,.375,.5,.625,.75,.875,.95,.975)
    stats <- matrix(x, nrow=1, dimnames=list('',format(x)))
    Means <- .56
  } else {
    Means <- stats[,'Mean']
    stats <- stats[,dimnames(stats)[[2]] %nin% c('Mean','SD'),drop=FALSE]
  }
  
  groups <- dimnames(stats)[[1]]
  qq <- as.numeric(dimnames(stats)[[2]])
  probs2 <- qq
  if(missing(xlim))
    xlim <- range(stats)
  
  i <- integer(0)
  for(a in c(.5,qomit))
    i <- c(i, (1:length(probs2))[abs(probs2-a)<.001])
  
  probs2 <- probs2[-i]
  probs  <- probs2[1:(floor(length(probs2)/2))]

  if(grid) {
    lines <- llines;
    points <- lpoints;
    segments <- lsegments
  }

  width <- box.ratio/(1 + box.ratio)
  w <- width/2

  m  <- length(probs)
  m2 <- length(probs2)
  j <- c(1,sort(rep(2:m2,2)),-sort(-rep(1:(m2-1),2)))
  z <- c(sort(rep(probs,2)),-sort(-rep(probs[1:(m-1)],2)))
  z <- c(z, -z, probs[1])
  k <- max(z)
  k <-
    if(k > .48)
      .5
    else k
  
  if(length(qref)) {
    size.qref <- pmin(qref, 1-qref)
    size.qref[qref==.5] <- k
  }

  if(.R.)
    plot.new()
  
  mai <- omai <- par('mai')
  on.exit(par(mai=omai))
  mxlab <- .3+max(strwidth(groups, units='inches',cex=cex.labels))
  ## was .2+max  31jan03
  mai[2] <- mxlab
  par(mai=mai, new=TRUE)
  
  plot(xlim, c(.5,length(groups)+.5), xlim=xlim, xlab='', ylab='',
       axes=FALSE, type='n')
  if(!prototype) {
    box()
    mgp.axis(1, axistitle=xlab)  ## 28jan03
  }
  
  if(.R.)
    mtext(paste(groups,''), 2, 0, at=length(groups):1,
          adj=1, las=1, cex=cex.labels)
  else
    mtext(paste(groups,''), 2, 0, at=length(groups):1,
          adj=1, srt=0, cex=cex.labels)

  y <- 0
  for(Y in length(groups):1) {
    y <- y + 1
    q <- stats[Y,match(c(probs2,qref),qq)]
    if(length(qref)) 
      do.call('segments',c(list(q[-(1:m2)],      y-w*size.qref/k,
                                q[-(1:m2)], 	 y+w*size.qref/k)))
    
    lines(q[j], y + w*z/k)
    if(means)
      points(Means[Y], y, pch=pch, cex=cex.points)
  }
  
  if(prototype) {
    mar <- par('mar')
    on.exit(par(mar=mar))
    par(mar=rep(.5,4))
    text(Means, 1.025+.02, 'Mean')
    for(a in c(.5,probs2)) {
      if(.R.)
        arrows(a, .6, a, .725, length=.1)
      else
        arrows(a, .6, a, .725, size=.1)
      
      f <- format(a)
      text(a, .575, format(a))
    }
    
    text(.5, .52, 'Quantiles')
    xd <- .004
    text(.485-xd, 1,
         if(.R.) expression(Median==Q[2])
         else 'Median = Q2',
         
         srt=90)
    
    text(.235-xd, 1,
         if(.R.) expression(Q[1])
         else 'Q1',
         
         srt=90)
    
    text(.735-xd, 1,
         if(.R.) expression(Q[3])
         else 'Q3',

         srt=90)
    
    lines(c(.375,.625), rep(1.3,2));
    text(.635, 1.3,  '1/4', adj=0, cex=.9)
    
    lines(c(.25, .75 ), rep(1.35,2));
    text(.76,  1.35, '1/2', adj=0, cex=.9)
    
    lines(c(.125,.875), rep(1.4,2));
    text(.885, 1.4,  '3/4', adj=0, cex=.9)
    
    lines(c(.05, .95),  rep(1.45,2));
    text(.96,  1.45, '9/10',adj=0, cex=.9)
    
    text(.68, 1.24, 'Fraction of Sample Covered', adj=0, srt=13, cex=.7)
  }
}
pc1 <- function(x, hi)
{
  p <- ncol(x)
  x <-  x[!is.na(x %*% rep(1,p)),]
  xo <- x
  for(i in 1:p) {
    y <- x[,i]
    x[,i] <- (y-mean(y))/sqrt(var(y))
  }
  
  g <- prcomp(x)
  cat("Fraction variance explained by PC1:",format(g$sdev[1]^2/sum(g$sdev^2)),
      "\n\n")
  pc1 <- g$x[,1]
  
  f <- lsfit(xo, pc1)
  
  if(!missing(hi)) {
    if(sum(f$coef[-1]<0) >= p/2)
      pc1 <- -pc1
    
    r <- range(pc1)
    pc1 <- hi*(pc1-r[1])/diff(r)
    f <- lsfit(xo, pc1)
  }
  
  cat("Coefficients to obtain PC1:\n\n")
  print(f$coef)
  attr(pc1,"coef") <- f$coef
  invisible(pc1)
}
plsmo <- function(x,y,method=c("lowess","supsmu","raw"),
                  xlab,ylab,add=FALSE,lty=1:nlev,col=par('col'),lwd=par('lwd'),
                  iter=if(length(unique(y))>2) 3
                       else 0,
                  bass=0, trim, fun, group=rep(1,length(x)), prefix, xlim, ylim, 
                  label.curves=TRUE, datadensity=FALSE, lines.=TRUE,
                  subset=TRUE, grid=FALSE, ...)
{
  gfun <- ordGridFun(grid)
  nam <- as.character(sys.call())[2:3]
  method <- match.arg(method)
  if(!missing(subset)) {  ## 20jul02
    x <- x[subset]
    y <- y[subset]
    group <- group[subset]
  }
    
  group <- as.factor(group)
  if(!missing(prefix))
    levels(group) <- paste(prefix,levels(group))
  
  group <- as.factor(group)
  nna <- !(is.na(x+y)|is.na(group))
  x <- x[nna]
  y <- y[nna]
  group <- group[nna]

  lev <- levels(group)
  nlev <- length(lev)
  curves <- vector('list',nlev)
  names(curves) <- lev

  xmin <- ymin <- 1e30; xmax <- ymax <- -1e30
  for(g in lev) {
    s <- group==g
    z <- switch(method, 
                lowess=lowess(x[s],y[s],iter=iter),
                supsmu=supsmu(x[s],y[s], bass=bass),
                raw=approx(x[s],y[s],xout=sort(unique(x[s]))))
    
    if(missing(trim))
      trim <-
        if(sum(s)>200)
          10/sum(s)
        else 0
    
    if(trim>0 && trim<1) {
      xq <- quantile(x[s],c(trim,1-trim))
      s <- z$x>=xq[1] & z$x<=xq[2]
      z <- list(x=z$x[s],y=z$y[s])
    }
    
    if(!missing(fun)) {
      yy <- fun(z$y)
      s <- !is.infinite(yy) & !is.na(yy)   ## was is.inf 11Apr02
      z <- list(x=z$x[s],y=yy[s])
    }

    curves[[g]] <- z
    xmin <- min(xmin, z$x); xmax <- max(xmax, z$x)
    ymin <- min(ymin, z$y); ymax <- max(ymax, z$y)
  }

  if(!add) {
    if(grid)
      stop('add=T not implemented under grid/lattice in R')
    
    ##if(missing(xlab)) xlab <- if(label(x)!='') label(x) else nam[1] 26sep02
    ##if(missing(ylab)) ylab <- if(label(y)!='') label(y) else nam[2]
    if(missing(xlab))
      xlab <- label(x, units=TRUE, plot=TRUE, default=nam[1])
    
    if(missing(ylab))
      ylab <- label(y, units=TRUE, plot=TRUE, default=nam[2])
    
    plot(xmin,ymin,
         xlim=if(missing(xlim)) c(xmin,xmax)
              else xlim,
         ylim=if(missing(ylim))c(ymin,ymax)
              else ylim,
         type='n', xlab=xlab, ylab=ylab)
  }
  
  lty <- rep(lty, length=nlev)
  col <- rep(col, length=nlev)
  if(missing(lwd) &&
     is.list(label.curves) &&
     length(label.curves$lwd))
    lwd <- label.curves$lwd  # 20Feb00
  
  lwd <- rep(lwd, length=nlev)

  if(lines.)
    for(i in 1:nlev)
      gfun$lines(curves[[i]], lty=lty[i], col=col[i], lwd=lwd[i])  # 20Feb00

  if(datadensity) {
    for(i in 1:nlev) {
      s <- group==lev[i]
      x1 <- x[s]
      y.x1 <- approx(curves[[i]], xout=x1)$y
      scat1d(x1, y=y.x1, col=col[i], grid=grid, ...)
    }
  }

  if((is.list(label.curves) || label.curves) && 
     nlev>1 && (!missing(prefix) | !add | !missing(label.curves))) 
    labcurve(curves, lty=lty, col=col, opts=label.curves, grid=grid)
  
  invisible(curves)
}


panel.plsmo <- function(x, y, subscripts, groups=NULL, type='b', 
                        label.curves=TRUE,
                        lwd = superpose.line$lwd, 
                        lty = superpose.line$lty, 
                        pch = superpose.symbol$pch, 
                        cex = superpose.symbol$cex, 
                        font = superpose.symbol$font, 
                        col = NULL,...)
{
  superpose.symbol <- trellis.par.get("superpose.symbol")
  superpose.line <- trellis.par.get("superpose.line")
  if(length(groups))
    groups <- as.factor(groups)
  
  g <- oldUnclass(groups)[subscripts]
  ng <-
    if(length(groups))
      max(g)
    else 1
  
  lty  <- rep(lty, length = ng)
  lwd  <- rep(lwd, length = ng)
  pch  <- rep(pch, length = ng)
  cex  <- rep(cex, length = ng)
  font <- rep(font, length = ng)
  if(!length(col))
    col <-
      if(type=='p')
        superpose.symbol$col
      else
        superpose.line$col
  
  col <- rep(col, length = ng)
  lc <-
    if(is.logical(label.curves)) {
      if(label.curves)
        list(lwd=lwd, cex=cex[1])
      else FALSE
    } else c(list(lwd=lwd, cex=cex[1]), label.curves)
  
  if(type!='p') if(ng > 1)
    plsmo(x, y, group=groups[subscripts,drop=FALSE], 
          add=TRUE, lty=lty, col=col, label.curves=lc, grid=.R., ...)
  else
    plsmo(x, y, add=TRUE, lty=lty, col=col, label.curves=lc, grid=.R.,
          ...)

  if(type!='l') {
    if(ng > 1)
      panel.superpose(x, y, subscripts,
                      if(.R.)as.integer(groups)
                      else groups, 
                      lwd=lwd, lty=lty, pch=pch, cex=cex, 
                      font=font, col=col)
    else
      panel.xyplot(x, y, 
                   lwd=lwd, lty=lty, pch=pch, cex=cex, 
                   font=font, col=col)
    
    if(ng > 1) {
      Key <-
        if(.R.) function(x=NULL, y=NULL, lev, cex, col, font, pch)
        {
          oldpar <- par(usr=c(0,1,0,1),xpd=NA)
          on.exit(par(oldpar))
          if(is.list(x)) {
            y <- x[[2]];
            x <- x[[1]]
          }
            
          ## Even though par('usr') shows 0,1,0,1 after lattice draws
          ## its plot, it still needs resetting
          if(!length(x))
            x <- 0
            
          if(!length(y))
            y <- 1  ## because of formals()
            
          rlegend(x, y, legend=lev, cex=cex, col=col, pch=pch)
          invisible()
        }
        else function(x=NULL, y=NULL, lev, cex, col, font, pch, ...)
        {
          if(length(x)) {
            if(is.list(x)) {
              y <- x$y;
              x <- x$x
            }
            
            key(x=x, y=y, text=list(lev, col=col), 
                points=list(cex=cex,col=col,font=font,pch=pch),
                transparent=TRUE, ...) }
          else
            key(text=list(lev, col=col), 
                points=list(cex=cex,col=col,font=font,pch=pch),
                transparent=TRUE, ...)
            
          invisible()
        }
      
      formals(Key) <- list(x=NULL,y=NULL,lev=levels(groups), cex=cex,
                           col=col, font=font, pch=pch)
      storeTemp(Key)
    }
  }
}
popower <- function(p, odds.ratio, n, n1, n2, alpha=.05)
{
  if(missing(n))
    n <- n1+n2
  else {
    n1 <- n2 <- n/2
  }
  
  p <- p[!is.na(p)]
  if(abs(sum(p)-1)>.0001)
    stop('probabilities in p do not add up to 1')
  
  z <- qnorm(1-alpha/2)
  A <- n2/n1
  ps <- 1 - sum(p^3)
  V <- n1*n2*n/3/((n+1)^2)*ps
  power <- pnorm(abs(logb(odds.ratio))*sqrt(V) - z)
  eff <- ps/(1-1/n/n)
  structure(list(power=power, eff=eff), class='popower')
}


print.popower <- function(x, ...)
{
  cat('Power:',round(x$power,3),
      '\nEfficiency of design compared with continuous response:',
      round(x$eff,3),'\n\n')
  invisible()
}


posamsize <- function(p, odds.ratio, fraction=.5, 
                      alpha=.05, power=.8)
{
  p <- p[!is.na(p)]
  if(abs(sum(p)-1)>.0001)
    stop('probabilities in p do not add up to 1')

  A <- (1-fraction)/fraction
  log.or <- logb(odds.ratio)
  z.alpha <- qnorm(1-alpha/2)
  z.beta <- qnorm(power)
  ps <- 1 - sum(p^3)
  n <- 3*((A+1)^2)*(z.alpha+z.beta)^2/A/(log.or^2)/ps
  eff <- ps/(1-1/n/n)
  structure(list(n=n,eff=eff), class='posamsize')
}


print.posamsize <- function(x, ...)
{
  cat('Total sample size:',round(x$n,1),
      '\nEfficiency of design compared with continuous response:',
      round(x$eff,3),'\n\n')
  invisible()
}
if(!exists("string.bounding.box")) {
  string.bounding.box <- function(string, type=c("chars", "width")) {
    thisfun <- function(x, type) {
      height <- length(x)
      # get rid of ':' on last string 
      x[height] <- substr(x[height], start=1, stop=nchar(x[height], type='chars') - 1)

      c(height = height, width = max(nchar(x, type=type)))
    }

    mode(string) <- "character"

    type <- match.arg(type)

    ## Add remove '\n' if it is ends the string and add a ':' so that string split
    ## functions the way I want it to.
    string <- paste(string, ':', sep='')

    ans <- sapply(strsplit(string, '\n', fixed=TRUE), FUN=thisfun, type=type, USE.NAMES=FALSE)
    return(list(columns = ans[2,], rows = ans[1,]))
  }
}

equalBins <- function(widths, subwidths) {
  ## The length of widths and subwidths must be the same
  if(length(widths) != length(subwidths)) {
    stop("width and subwidth must be of the same length")
  }

  ## adjust width for column spacers
  widths <- widths - unlist(lapply(subwidths, length)) + 1
  unlist(mapply(function(width, subwidths) {
    if(sum(subwidths) < width) {
      div <- width %/% length(subwidths)
      mod <- width %% length(subwidths)
      c(rep.int(div + 1, mod), rep.int(div, length(subwidths) - mod))
    } else {
      subwidths
    }
  }, widths, subwidths, SIMPLIFY = FALSE))
}

stringDims <- function(string) {
  if(is.null(string)) {
    return(height = 0, width = 0)
  }
  
  dims <- dim(string)

  bbox <- string.bounding.box(string)
  height <- bbox$rows
  width <- bbox$columns

  if(any(dims)) {
    dim(height) <- dims
    dim(width) <- dims
  }
  
  list(height = height, width = width)
}

simplifyDims <- function(x) {
  if(any(sapply(x, FUN=is.matrix)))
    do.call(rbind, x)
  else
    do.call(c, x)
}

partition.vector <- function(x, sep, ...) {
  if(missing(sep)) {
    stop("sep is a required arg")
  }

  if(sum(sep) != length(x)) {
    stop("sep must sum to the number of columns in x")
  }

  split(x, rep(seq(along.with=sep), times=sep))
}


partition.matrix <- function(x, rowsep, colsep, ...) {  
  colmissing <- missing(colsep)
  rowmissing <- missing(rowsep)
  
  if(rowmissing && colmissing) {
    stop("Atleast one of rowsep or colsep args must be specified")
  }
  
  ## If length of group is equal to length of x assume that this is a
  ## a vector of group numbers
  if(!rowmissing) {
    if(sum(rowsep) != NROW(x)) {
      stop("rowsep must sum to the number of columns in x")
    }
    if(!is.numeric(rowsep)) {
      stop("the rowsep vector must be numeric")
    }
  }

  if(!colmissing) {
    if(sum(colsep) != NCOL(x)) {
      stop("colsep must sum to the number of rows in x")
    }
    if(!is.numeric(colsep)) {
      stop("the colsep vector must be numeric")
    }
  }

  ## Separate x into row chunks
  if(!rowmissing) {
    set <- lapply(split(seq(NROW(x)), rep(seq(along.with=rowsep), times=rowsep)), function(index) x[index,,drop=FALSE])
  } else {
    set <- NULL
  }

  if(!colmissing) {
    FUN <- function(x)
      lapply(split(seq(NCOL(x)), rep(seq(along.with=colsep), times=colsep)), function(index) x[,index,drop=FALSE])
    
    if(is.null(set)) {
      FUN(x)
    } else {
      lapply(set, FUN)
    }
  } else {
    set
  }
} 
  

print.char.list <- function(x, ..., hsep = c("|"), vsep = c("-"), csep = c("+"),
                            print.it = TRUE, rowname.halign = c("left", "centre", "right"),
                            rowname.valign = c("top", "centre", "bottom"),
                            colname.halign = c("centre", "left", "right"),
                            colname.valign = c("centre", "top", "bottom"),
                            text.halign = c("right", "centre", "left"),
                            text.valign = c("top", "centre", "bottom"), rowname.width,
                            rowname.height, min.colwidth = .Options$digits, max.rowheight = NULL,
                            abbreviate.dimnames = TRUE, page.width = .Options$width,
                            colname.width, colname.height, prefix.width,
                            superprefix.width = prefix.width) {

  vjustText <- function(char.matrix, fieldHeight, vjust = c("top", "center", "bottom")) {
    if(!is.matrix(char.matrix))
      stop("char.matrix must be of type matrix")

    d <- dim(char.matrix)

    vjust <- match.arg(vjust)

    if(! is.character(char.matrix))
      char.matrix <- as.character(char.matrix)

    # split the matrix strings up into multi lines.
    char.matrix <- ifelse(is.na(char.matrix), NA, string.break.line(char.matrix))

    # determine veritcal differentials
    vdiff <- fieldHeight - unlist(lapply(char.matrix, length))

    ans <- mapply(function(element, vdiff, target) {
      if(is.na(element) || vdiff == 0) {
        return(element)
      }
      
      if(vdiff < 0) {
        # Trim trailing extra lines
        lines <- rev(seq(along.with=element)[element != ''])
        if(lines[1] <= target) {
          return(element[1:target])
        }

        length(element) <- lines[1]

        element <- element[element != '']

        if(length(element) == target)
          return(element)
        
        vdiff <- target - length(element)
      }
      
      switch(vjust,
             top = c(element, character(vdiff)),
             bottom = c(character(vdiff), element),
             center = c(character(half <- vdiff%/%2), element, character(vdiff - half)))
     
    }, char.matrix, vdiff, fieldHeight, USE.NAMES=FALSE)
    matrix(unlist(ans), ncol=d[[2]])
  }

  hjustText <- function(char.matrix, fieldWidth, hjust=c("left","right","center")) {
    if(!is.matrix(char.matrix))
      stop("text must be of type matrix")

    d <- dim(char.matrix)
    
    
    hjust <- match.arg(hjust)

    ans <- mapply(function(column, target) {
      column <- unlist(column)
      column <- ifelse(is.na(column), NA, format(column, justify=hjust, width=target))

      column <- ifelse(is.na(column) || target - nchar(column, type="width"), column, strtrim(column, target))
    }, split(char.matrix, col(char.matrix)), fieldWidth, USE.NAMES=FALSE)
#    dim(ans) <- d
    ans
  }
    
  justText <- function(char.matrix, fieldWidth, fieldHeight, hjust=c("left","right","centre"),
                       vjust = c("top", "centre", "bottom"), trim=FALSE) {
    if(!is.matrix(char.matrix))
      stop("text must be of type matrix")

    ## Get the original dims of the matrix
    d <- dim(char.matrix)

    ## Determin the wanted justification.
    hjust <- match.arg(hjust)
    vjust <- match.arg(vjust)

    ## If this is a charater matrix then break in on the lines
    if(is.character(char.matrix)) {
      ## split the matrix strings up into multi lines.
      ans <- ifelse(is.na(char.matrix), NA, string.break.line(char.matrix))
    } else {
      ans <- char.matrix
    }

    ## format the text horizontaly.
    ans <- mapply(function(column, target) {
      fun <- function(x) ifelse(is.na(x), NA, format(x, justify=hjust, width=target))
      
      if(is.list(column)) {
        lapply(column, fun)
      } else {
        fun(column)
      }
    }, split(ans, col(char.matrix)), fieldWidth, USE.NAMES=FALSE)
    
    spacer <- makeNstr(' ', fieldWidth)
    ## Add extra rows to justify the text vericaly.
    ans <- mapply(function(row, target) {
      fun <- function(element, spacer) {
        vdiff <- target - length(element)
        if(is.na(element) || vdiff == 0) {
          return(element)
        }
      
        if(vdiff < 0) {
          ## Trim trailing extra lines
          lines <- rev(seq(along.with=element)[element != ''])
          if(lines[1] <= target) {
            return(element[1:target])
          }

          length(element) <- lines[1]
          
          element <- element[element != '']

          if(length(element) == target)
            return(element)
        
          vdiff <- target - length(element)
        }

        switch(vjust,
               top = c(element, rep(spacer, vdiff)),
               bottom = c(rep(spacer, vdiff), element),
               centre = c(rep(spacer, half <- vdiff%/%2), element, rep(spacer, vdiff - half)))
      }        

      mapply(fun, row, spacer, USE.NAMES=FALSE, SIMPLIFY=FALSE)
    }, split(ans, row(char.matrix)), fieldHeight, USE.NAMES=FALSE, SIMPLIFY=FALSE)
    matrix(unlist(unsplit(ans, row(char.matrix))), ncol=d[[2]])
  }

  printRow <- function(entries, widths, sep) {
    if(length(entries) != length(widths))
      stop("arguments must be the same length")

    first <- TRUE
    last <- TRUE
    env <- environment()
    nval <- ' '
    sep <- hsep

    out <- mapply(function(entry, width) {
      if(is.na(entry)) {
        if(is.null(last)) {
          out <- c(nval, makeNstr(nval, width))
        } else {
          out <- c(sep, makeNstr(nval, width))
          assign("last", NULL, envir=env)
        }
      }else{
        if(is.null(last)) {
          assign("last", TRUE, envir=env)
        }
        out <- c(sep, entry)
      }
      out
    }, entries, widths)
    paste(c(out, sep), collapse='')
  }

  printBars <- function(entries, blank, widths, hsep, csep, vsep) {
    bars <- character(length(entries) + 1)
    alt <- rep(c(1,2), length.out=length(widths))
#    blank <- c(list(rep(TRUE, length(widths))), blank)
    for(i in seq(along.with=entries)) {
      len <- length(entries[[i]])

      comp <- entries[[i]][-len]
      comp.last <- entries[[i]][len]
      
      bnk <- blank[[i]]
      bnk.last <- bnk[length(bnk)]
      
      dividers <- ifelse(comp & bnk, hsep, ifelse(bnk, ' ', ifelse(comp, csep, vsep)))
      dividers <- c(dividers, ifelse(bnk.last, hsep, csep))
      betweens <- c(makeNstr(ifelse(bnk, ' ', vsep), widths), '')

      bars[i] <- paste(dividers, betweens, sep='', collapse='')
    }
    dividers <- ifelse(entries[[length(entries)]], csep, vsep)
    betweens <- c(makeNstr(vsep, widths), '')
    bars[length(bars)] <- paste(dividers, betweens, sep='', collapse='')
    
    bars
  }
  

  rjustText <- function(text, fieldWidth, trim=FALSE) justText(text, fieldWidth, 'right', trim)
  ljustText <- function(text, fieldWidth, trim=FALSE) justText(text, fieldWidth, 'left', trim)
  centerText <- function(text, fieldWidth, trim=FALSE) justText(text, fieldWidth, 'center', trim)
    

  colnames <- NULL
  rownames <- NULL
  colDims  <- NULL
  rowDims  <- NULL
  supercols <- NULL
  superrows <- NULL
  supercolDims <- NULL
  superrowDims <- NULL
  colsets  <- NULL
  rowsets  <- NULL

  if(is.list(x)) {
    rownames <- lapply(x, function(x) {
      if(is.null(rownames <- dimnames(x)[[1]])) {
        rep(NA, NROW(x))
      } else {
        rownames
      }
    })

    rowsets <- unlist(lapply(rownames, length), use.names=FALSE)
    superrows <- names(rownames)
    rownames <- matrix(unlist(rownames, use.names=FALSE), ncol=1)

    if(all(is.na(rownames))) {
      rownames <- NULL
    }

    colnames <- lapply(x[[1]][1,], names)

    colsets   <- unlist(lapply(colnames, length), use.names=FALSE)
    supercols <- names(colnames)
    colnames  <- matrix(unlist(colnames, use.names=FALSE), nrow=1)

    if(all(is.na(colnames))) {
      colnames <- NULL
    }

    ## Convert to a matrix
    matrix <- do.call(rbind, x)
    matrix <- do.call(rbind, tapply(matrix, row(matrix), FUN='unlist'))

  } else {
    rownames <- dimnames(x)[[1]]
    colnames <- dimnames(x)[[2]]
    matrix <- x
  }
  
  ## get widths of each column in table.
  listDims <- stringDims(matrix(sapply(matrix, format),ncol=ncol(matrix)))

  ## find the widths and heights of the row names and col names
  ## if any elements do not have rownames the set them equal to 0
  if(length(colnames)) {
    colDims <- stringDims(colnames)
  } else {
    colDims <- list(height = integer(nrow(matrix)), width = integer(nrow(matrix)))
  }

  if(length(rownames)) {
    rowDims <- stringDims(rownames)
  } else {
    rowDims <- list(height = integer(ncol(matrix)), width = integer(ncol(matrix)))
  }
  
  ## calculate the superdim info
  ## do it for the supercols
  if(length(supercols)) {
    supercolDims <- stringDims(supercols)
  } else {
    supercolDims <- list(height = 0, width = 0)
  }

  ## do it for the superrows
  if(length(superrows)) {
    superrowDims <- stringDims(superrows)
  } else {
    superrowDims <- list(height = 0, width = 0)
  }

  ## Calculate the max column width
  if(!missing(colname.width)) {
    colwidth <- pmin(colDims$width, colnames.width)
    supercolwidth <- pmin(supercolDims$width, colnames.width*colsets)
  } else {
    colwidth <- colDims$width
    supercolwidth <- supercolDims$width
  }

  ## Calculate the max row hight
  if(!missing(rowname.height)) {
    rowheight <- pmin(rowDims$height, rownames.height)
    superrowheight <- pmin(superrowDims$height, rownames.height*rowsets)
  } else {
    rowheight <- rowDims$height
    superrowheight <- superrowDims$height
  }

  ## Find the overall height of the matrix
  height <- pmax(tapply(listDims$height, row(matrix), max), rowheight)
  height <- equalBins(superrowheight, partition.vector(height, rowsets))

  ## Find the overall width of the matrix
  width  <- pmax(tapply(listDims$width, col(matrix), max), colwidth)
  width  <- equalBins(supercolwidth, partition.vector(width, colsets))
                
  ## Calculate actual supercol widths that is the sum of the subcol or total lenght to supercol
  ## which ever is greater
  supercolwidth <- tapply(width, rep.int(seq(along.with=colsets), times=colsets), sum) + colsets - 1
  supercolheight <- max(superrowDims$height)
  colheight <- max(colDims$height)

  superrowheight <- tapply(height, rep.int(seq(along.with=rowsets), times=rowsets), sum)

  if(missing(prefix.width)) {
    if(!is.null(rownames)) {
      prefix.width <- max(max(na.rm = TRUE, as.integer(median(width)), max(rowDims$width)))
    } else {
      prefix.width <- 0
    }
  }

  if(missing(superprefix.width)) {
    if(!is.null(superrows)) {
      superprefix.width <- max(na.rm = TRUE, as.integer(median(width)), max(superrowDims$width))
    } else {
      superprefix.width <- 0
    }
  }

  header <- NULL
  headerwidth <- NULL
  rows <- NULL
  entries <- list()
  blanks <- list()

  
  ## Figure out the centering of the cells.
  rowNameHalign <- match.arg(rowname.halign)
  rowNameValign <- match.arg(rowname.valign)
  colNameHalign <- match.arg(colname.halign)
  colNameValign <- match.arg(colname.valign)
  cellHalign <- match.arg(text.halign)
  cellValign <- match.arg(text.valign)

  ## create the superrowname column
  superrow <- if(!is.null(superrows)) {
    superrows <- matrix(superrows, ncol=1)

    header <- NA
    headerwidth <- superprefix.width
    ## perform verical and horizontal centering.
    justText(superrows, superprefix.width, superrowheight,
             rowNameHalign, rowNameValign)
  }
  
  row <- if(!is.null(rownames)) {
    header <- cbind(header, NA)
    headerwidth <- c(headerwidth, prefix.width)
    justText(rownames, prefix.width, height, rowNameHalign, rowNameValign)
  }

  body <- cbind(superrow, row,
                justText(matrix, width, height, cellHalign, cellValign))

  width <- c(headerwidth, width)

  body <- split(body, row(body))
  
  ## Create the super column name row and the column name row
  if(!is.null(supercols)) {
    supercols <- matrix(supercols, nrow=1)
    
    supercolwidth <- c(headerwidth, supercolwidth)
    entry <- c(header, rep(seq(along.with=colsets), colsets), 0)
    entries <- c(entries, list(ifelse(is.na(entry), FALSE, !duplicated(entry))))

    blank <- ifelse(is.na(c(header, rep(supercols, colsets))), TRUE, FALSE)
    blanks <- c(blanks, list(blank))
    
    rows <- printRow(justText(cbind(header, supercols), supercolwidth, supercolheight,
                              colNameHalign, colNameValign), width=supercolwidth, sep=hsep)
  }

  if(!is.null(colnames)) {
    entry <- c(header, rep(seq(along.with=colnames), 1), 0)
    entries <- c(entries, list(ifelse(is.na(entry), FALSE, !duplicated(entry))))
    
    blank <- ifelse(is.na(c(header, colnames)), TRUE, FALSE)
    blanks <- c(blanks, list(blank))

    rows <- c(rows,
              printRow(justText(cbind(header, colnames), width, colheight,
                                colNameHalign, colNameValign), width=width, sep=hsep))
  }
  

  env <- environment()

  rows <- c(rows, unlist(lapply(split(body, rep(seq(along.with=rowsets), rowsets)), function(set) {
    index <- seq(along.with=set)

    mapply(FUN = function(line, index) {
      entry <- c(ifelse(is.na(line), NA, rep(seq(along.with=line), 1)), 0)
      entry <- ifelse(is.na(entry), FALSE, !duplicated(entry))
      
      assign('entries', c(entries, list(entry)), env)

      blank <- ifelse(is.na(line), FALSE, FALSE)
      if(index != 1) {
        blank[1] <- TRUE
      }
      
      assign('blanks', c(blanks, list(blank)), env)
      printRow(line, width=width, sep=hsep)
    }, set, index)
  }), use.names=FALSE))

  blanks[[1]] <- logical(length(width))
  entries <- lapply(entries, function(entry) {entry[1] <- TRUE; entry})

  bars <- printBars(entries, blanks, width, hsep=hsep, vsep=vsep, csep=csep)
  total <- paste(bars, c(rows, ""), sep='\n', collapse='\n')

  if(print.it) {
    cat(total)
    invisible(x)
  } else {
    total
  }
}

ps.slide <- function(file,
                     background=if(type!=2)"white"
                                else "navy blue", 
                     foreground=if(type==2)'yellow'
                                else (if(background=="white")"black"
                                      else "white"),
                     
                     font='Helvetica',
                     pointsize=c(24,28,14,14)[type], hor=type!=4, 
                     lwd=c(2,5,2,4)[type],
                     mgp=if(under.unix)
                           list(c(1.8,.4,0),c(1.5,.2,0),c(2,.4,0),c(1.5,.2,0))[[type]]
                         else
                           list(c(1.8,.5,0),c(1.5,.4,0),c(2,.5,0),c(1.5,.4,0))[[type]],
                     
                     mar=list(c(4,3,2,1)+.1,c(5,4,2.25,2)+.1,c(3,3,1,1)+.1,
                              c(5,4,2.25,2)+.1)[[type]],
                     pch=202, view=FALSE, pcx=FALSE, tiff=FALSE, close=view|pcx|tiff, bty="l", type=2,
                     height=switch(type,NULL,NULL,5,8), width=switch(type,NULL,NULL,7,7),
                     tck=if(type==3 || !under.unix) -.013
                         else par('tck'), 
                     las=if(type==3)1
                         else 0, 
                     eps=FALSE, ...)
{
  if(close) {
    graphics.off()
    file <- .Options$ps.slide.file
    if(view)
      unix(paste("ghostview ", file, ".ps &", sep=""), output=FALSE)
    
    if(pcx) {
      unix(paste("(gs -sDEVICE=pbm -sOutputFile=- -r75 -q - quit.ps < ",
                 file, ".ps | pnmflip -cw | ppmtopcx > ", file, ".pcx) &", sep=""),
           output=FALSE)
      cat("\nFile ", file, ".pcx being created \n", sep="")
      ##if(view) unix(paste("xli ", file, ".pcx &", sep=""), output=FALSE)
    }
    
    if(tiff) {
      unix(paste("(gs -sDEVICE=pbmraw -sOutputFile=- -r300 -q - quit.ps < ",
                 file, ".ps | pnmflip -cw | pnmtotiff > ", file, ".tiff) &",sep=""),
           output=FALSE)
      cat("\nFile ", file, ".tiff being created \n", sep="")
    }
    
    return(invisible())
  }

  if(is.logical(background) && background)
    background <- "navy blue"
  
  options(ps.slide.file=file, TEMPORARY=FALSE)
  if(!.R.) {
    cols <- ps.colors.rgb[c(foreground,background),]
    fonts <-
      if(under.unix)
        ps.options()$fonts
      else ps.fonts
    
    fonts[1] <- font
    if(font=='Times-Roman')
      fonts[5] <- 'Times-Bold'
    
    if(under.unix) {
      ps.options(colors=cols, background=2, fonts=fonts, pointsize=pointsize, ...)
      cat('\nIf using legend() be sure to add the arguments background=2, bty="n"\n')
  
      if(length(height) && length(width)) 
	postscript(paste(file,'.ps',sep=''),
                   hor=hor, height=height, width=width,
                   pointsize=.6*pointsize*max(width/(30*12/72.27),
                                              height/(30*12/72.27/((1+sqrt(5))/2))),
                   print.it=FALSE, onefile=!eps)
      else
        postscript(paste(file,".ps",sep=""), hor=hor, print.it=FALSE, onefile=!eps)
    } else {
      if(length(height) && length(width)) 
	postscript(paste(file,'.ps',sep=''),
                   hor=hor, height=height, width=width,
                   pointsize=.6*pointsize*max(width/(30*12/72.27),
                                              height/(30*12/72.27/((1+sqrt(5))/2))),
                   colors=cols, fonts=fonts, ...)
      else
	postscript(paste(file,'.ps',sep=''),
                   hor=hor, colors=cols, fonts=fonts, ...)
    }
  } else { # 10Apr01
    if(length(height) && length(width)) 
      postscript(paste(file,'.ps',sep=''),
                 hor=hor, height=height, width=width,
                 pointsize=.6*pointsize*max(width/(30*12/72.27),
                                            height/(30*12/72.27/((1+sqrt(5))/2))),
                 fg=foreground, bg=background, family=font, ...)
    else
      postscript(paste(file,'.ps',sep=''),
                 fg=foreground, bg=background, family=font, ...)
  }

  par(lwd=lwd, mgp=mgp, mar=mar, pch=pch, bty=bty, smo=0, tck=tck, las=las)
  ##mgp.axis.labels(c(mgp[2], if(las==1) 1.3 else mgp[2]))
  invisible()
}


if(!.R. && !under.unix) ps.colors.rgb <-
  structure(.Data = c(1, 0.972549019607843, 0.972549019607843, 0.96078431372549, 
                      0.96078431372549, 0.862745098039216, 1, 1, 0.992156862745098, 
                      0.992156862745098, 0.980392156862745, 0.980392156862745, 
                      0.980392156862745, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 
                      0.941176470588235, 0.96078431372549, 0.96078431372549, 
                      0.941176470588235, 0.941176470588235, 0.941176470588235, 
                      0.901960784313726, 1, 1, 1, 1, 1, 0, 0.184313725490196, 
                      0.184313725490196, 0.184313725490196, 0.184313725490196, 
                      0.411764705882353, 0.411764705882353, 0.411764705882353, 
                      0.411764705882353, 0.43921568627451, 0.43921568627451, 0.43921568627451,
                      0.43921568627451, 0.466666666666667, 0.466666666666667, 
                      0.466666666666667, 0.466666666666667, 0.752941176470588, 
                      0.752941176470588, 0.827450980392157, 0.827450980392157, 
                      0.827450980392157, 0.827450980392157, 0.0980392156862745, 
                      0.0980392156862745, 0, 0, 0, 0.392156862745098, 0.392156862745098, 
                      0.282352941176471, 0.282352941176471, 0.415686274509804, 
                      0.415686274509804, 0.482352941176471, 0.482352941176471, 
                      0.517647058823529, 0.517647058823529, 0, 0, 0.254901960784314, 
                      0.254901960784314, 0, 0.117647058823529, 0.117647058823529, 0, 0, 
                      0.529411764705882, 0.529411764705882, 0.529411764705882, 
                      0.529411764705882, 0.274509803921569, 0.274509803921569, 
                      0.690196078431373, 0.690196078431373, 0.67843137254902, 
                      0.67843137254902, 0.690196078431373, 0.690196078431373, 
                      0.686274509803922, 0.686274509803922, 0, 0, 0.282352941176471, 
                      0.282352941176471, 0.250980392156863, 0, 0.87843137254902, 
                      0.87843137254902, 0.372549019607843, 0.372549019607843, 0.4, 0.4, 
                      0.498039215686275, 0, 0, 0.333333333333333, 0.333333333333333, 
                      0.56078431372549, 0.56078431372549, 0.180392156862745, 
                      0.180392156862745, 0.235294117647059, 0.235294117647059, 
                      0.125490196078431, 0.125490196078431, 0.596078431372549, 
                      0.596078431372549, 0, 0, 0.486274509803922, 0.486274509803922, 0, 
                      0.498039215686275, 0, 0, 0.67843137254902, 0.67843137254902, 
                      0.196078431372549, 0.196078431372549, 0.603921568627451, 
                      0.603921568627451, 0.133333333333333, 0.133333333333333, 
                      0.419607843137255, 0.419607843137255, 0.741176470588235, 
                      0.741176470588235, 0.941176470588235, 0.933333333333333, 
                      0.933333333333333, 0.980392156862745, 0.980392156862745, 1, 1, 1, 1, 
                      0.933333333333333, 0.933333333333333, 0.854901960784314, 
                      0.72156862745098, 0.72156862745098, 0.737254901960784, 
                      0.737254901960784, 0.803921568627451, 0.803921568627451, 
                      0.545098039215686, 0.545098039215686, 0.627450980392157, 
                      0.803921568627451, 0.870588235294118, 0.96078431372549, 
                      0.96078431372549, 0.956862745098039, 0.956862745098039, 
                      0.823529411764706, 0.823529411764706, 0.698039215686274, 
                      0.647058823529412, 0.913725490196078, 0.913725490196078, 
                      0.980392156862745, 1, 1, 1, 1, 1, 1, 0.941176470588235, 
                      0.941176470588235, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0.858823529411765, 
                      0.858823529411765, 0.690196078431373, 0.780392156862745, 
                      0.780392156862745, 0.815686274509804, 0.815686274509804, 1, 
                      0.933333333333333, 0.866666666666667, 0.854901960784314, 
                      0.729411764705882, 0.729411764705882, 0.6, 0.6, 0.580392156862745, 
                      0.580392156862745, 0.541176470588235, 0.541176470588235, 
                      0.627450980392157, 0.576470588235294, 0.576470588235294, 
                      0.847058823529412, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 0.941176470588235, 0.87843137254902, 
                      0.756862745098039, 0.513725490196078, 1, 0.933333333333333, 
                      0.803921568627451, 0.545098039215686, 1, 0.933333333333333, 
                      0.803921568627451, 0.545098039215686, 0.941176470588235, 
                      0.87843137254902, 0.756862745098039, 0.513725490196078, 
                      0.513725490196078, 0.47843137254902, 0.411764705882353, 
                      0.27843137254902, 0.282352941176471, 0.262745098039216, 
                      0.227450980392157, 0.152941176470588, 0, 0, 0, 0, 0.117647058823529, 
                      0.109803921568627, 0.0941176470588235, 0.0627450980392157, 
                      0.388235294117647, 0.36078431372549, 0.309803921568627, 
                      0.211764705882353, 0, 0, 0, 0, 0.529411764705882, 0.494117647058824, 
                      0.423529411764706, 0.290196078431373, 0.690196078431373, 
                      0.643137254901961, 0.552941176470588, 0.376470588235294, 
                      0.776470588235294, 0.725490196078431, 0.623529411764706, 
                      0.423529411764706, 0.792156862745098, 0.737254901960784, 
                      0.635294117647059, 0.431372549019608, 0.749019607843137, 
                      0.698039215686274, 0.603921568627451, 0.407843137254902, 
                      0.87843137254902, 0.819607843137255, 0.705882352941177, 
                      0.47843137254902, 0.733333333333333, 0.682352941176471, 
                      0.588235294117647, 0.4, 0.596078431372549, 0.556862745098039, 
                      0.47843137254902, 0.325490196078431, 0, 0, 0, 0, 0, 0, 0, 0, 
                      0.592156862745098, 0.552941176470588, 0.474509803921569, 
                      0.32156862745098, 0.498039215686275, 0.462745098039216, 0.4, 
                      0.270588235294118, 0.756862745098039, 0.705882352941177, 
                      0.607843137254902, 0.411764705882353, 0.329411764705882, 
                      0.305882352941176, 0.262745098039216, 0.180392156862745, 
                      0.603921568627451, 0.564705882352941, 0.486274509803922, 
                      0.329411764705882, 0, 0, 0, 0, 0, 0, 0, 0, 0.498039215686275, 
                      0.462745098039216, 0.4, 0.270588235294118, 0.752941176470588, 
                      0.701960784313725, 0.603921568627451, 0.411764705882353, 
                      0.792156862745098, 0.737254901960784, 0.635294117647059, 
                      0.431372549019608, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 0.87843137254902, 0.819607843137255, 
                      0.705882352941177, 0.47843137254902, 0.749019607843137, 
                      0.698039215686274, 0.603921568627451, 0.407843137254902, 
                      0.607843137254902, 0.568627450980392, 0.490196078431373, 
                      0.333333333333333, 0.670588235294118, 0.623529411764706, 
                      0.537254901960784, 0.364705882352941, 1, 0.933333333333333, 
                      0.803921568627451, 0.545098039215686, 0, 0, 0.0117647058823529, 
                      0.0117647058823529, 0.0196078431372549, 0.0196078431372549, 
                      0.0313725490196078, 0.0313725490196078, 0.0392156862745098, 
                      0.0392156862745098, 0.0509803921568627, 0.0509803921568627, 
                      0.0588235294117647, 0.0588235294117647, 0.0705882352941176, 
                      0.0705882352941176, 0.0784313725490196, 0.0784313725490196, 
                      0.0901960784313725, 0.0901960784313725, 0.101960784313725, 
                      0.101960784313725, 0.109803921568627, 0.109803921568627, 
                      0.12156862745098, 0.12156862745098, 0.129411764705882, 
                      0.129411764705882, 0.141176470588235, 0.141176470588235, 
                      0.149019607843137, 0.149019607843137, 0.16078431372549, 
                      0.16078431372549, 0.168627450980392, 0.168627450980392, 
                      0.180392156862745, 0.180392156862745, 0.188235294117647, 
                      0.188235294117647, 0.2, 0.2, 0.211764705882353, 0.211764705882353, 
                      0.219607843137255, 0.219607843137255, 0.231372549019608, 
                      0.231372549019608, 0.23921568627451, 0.23921568627451, 
                      0.250980392156863, 0.250980392156863, 0.258823529411765, 
                      0.258823529411765, 0.270588235294118, 0.270588235294118, 
                      0.27843137254902, 0.27843137254902, 0.290196078431373, 
                      0.290196078431373, 0.301960784313725, 0.301960784313725, 
                      0.309803921568627, 0.309803921568627, 0.32156862745098, 
                      0.32156862745098, 0.329411764705882, 0.329411764705882, 
                      0.341176470588235, 0.341176470588235, 0.349019607843137, 
                      0.349019607843137, 0.36078431372549, 0.36078431372549, 
                      0.368627450980392, 0.368627450980392, 0.380392156862745, 
                      0.380392156862745, 0.388235294117647, 0.388235294117647, 0.4, 0.4, 
                      0.411764705882353, 0.411764705882353, 0.419607843137255, 
                      0.419607843137255, 0.431372549019608, 0.431372549019608, 
                      0.43921568627451, 0.43921568627451, 0.450980392156863, 
                      0.450980392156863, 0.458823529411765, 0.458823529411765, 
                      0.470588235294118, 0.470588235294118, 0.47843137254902, 
                      0.47843137254902, 0.490196078431373, 0.490196078431373, 
                      0.498039215686275, 0.498039215686275, 0.509803921568627, 
                      0.509803921568627, 0.52156862745098, 0.52156862745098, 
                      0.529411764705882, 0.529411764705882, 0.541176470588235, 
                      0.541176470588235, 0.549019607843137, 0.549019607843137, 
                      0.56078431372549, 0.56078431372549, 0.568627450980392, 
                      0.568627450980392, 0.580392156862745, 0.580392156862745, 
                      0.588235294117647, 0.588235294117647, 0.6, 0.6, 0.611764705882353, 
                      0.611764705882353, 0.619607843137255, 0.619607843137255, 
                      0.631372549019608, 0.631372549019608, 0.63921568627451, 
                      0.63921568627451, 0.650980392156863, 0.650980392156863, 
                      0.658823529411765, 0.658823529411765, 0.670588235294118, 
                      0.670588235294118, 0.67843137254902, 0.67843137254902, 
                      0.690196078431373, 0.690196078431373, 0.701960784313725, 
                      0.701960784313725, 0.709803921568627, 0.709803921568627, 
                      0.72156862745098, 0.72156862745098, 0.729411764705882, 
                      0.729411764705882, 0.741176470588235, 0.741176470588235, 
                      0.749019607843137, 0.749019607843137, 0.76078431372549, 
                      0.76078431372549, 0.768627450980392, 0.768627450980392, 
                      0.780392156862745, 0.780392156862745, 0.788235294117647, 
                      0.788235294117647, 0.8, 0.8, 0.811764705882353, 0.811764705882353, 
                      0.819607843137255, 0.819607843137255, 0.831372549019608, 
                      0.831372549019608, 0.83921568627451, 0.83921568627451, 
                      0.850980392156863, 0.850980392156863, 0.858823529411765, 
                      0.858823529411765, 0.870588235294118, 0.870588235294118, 
                      0.87843137254902, 0.87843137254902, 0.890196078431372, 
                      0.890196078431372, 0.898039215686275, 0.898039215686275, 
                      0.909803921568627, 0.909803921568627, 0.92156862745098, 
                      0.92156862745098, 0.929411764705882, 0.929411764705882, 
                      0.941176470588235, 0.941176470588235, 0.949019607843137, 
                      0.949019607843137, 0.96078431372549, 0.96078431372549, 
                      0.968627450980392, 0.968627450980392, 0.980392156862745, 
                      0.980392156862745, 0.988235294117647, 0.988235294117647, 1, 1, 
                      0.980392156862745, 0.972549019607843, 0.972549019607843, 
                      0.96078431372549, 0.96078431372549, 0.862745098039216, 
                      0.980392156862745, 0.980392156862745, 0.96078431372549, 
                      0.96078431372549, 0.941176470588235, 0.92156862745098, 0.92156862745098,
                      0.937254901960784, 0.937254901960784, 0.92156862745098, 
                      0.92156862745098, 0.894117647058824, 0.854901960784314, 
                      0.854901960784314, 0.870588235294118, 0.870588235294118, 
                      0.894117647058824, 0.972549019607843, 1, 0.980392156862745, 
                      0.980392156862745, 0.96078431372549, 1, 1, 1, 1, 0.972549019607843, 
                      0.972549019607843, 0.901960784313726, 0.941176470588235, 
                      0.941176470588235, 0.894117647058824, 0.894117647058824, 1, 0, 
                      0.309803921568627, 0.309803921568627, 0.309803921568627, 
                      0.309803921568627, 0.411764705882353, 0.411764705882353, 
                      0.411764705882353, 0.411764705882353, 0.501960784313725, 
                      0.501960784313725, 0.501960784313725, 0.501960784313725, 
                      0.533333333333333, 0.533333333333333, 0.533333333333333, 
                      0.533333333333333, 0.752941176470588, 0.752941176470588, 
                      0.827450980392157, 0.827450980392157, 0.827450980392157, 
                      0.827450980392157, 0.0980392156862745, 0.0980392156862745, 0, 0, 0, 
                      0.584313725490196, 0.584313725490196, 0.23921568627451, 
                      0.23921568627451, 0.352941176470588, 0.352941176470588, 
                      0.407843137254902, 0.407843137254902, 0.43921568627451, 
                      0.43921568627451, 0, 0, 0.411764705882353, 0.411764705882353, 0, 
                      0.564705882352941, 0.564705882352941, 0.749019607843137, 
                      0.749019607843137, 0.807843137254902, 0.807843137254902, 
                      0.807843137254902, 0.807843137254902, 0.509803921568627, 
                      0.509803921568627, 0.768627450980392, 0.768627450980392, 
                      0.847058823529412, 0.847058823529412, 0.87843137254902, 
                      0.87843137254902, 0.933333333333333, 0.933333333333333, 
                      0.807843137254902, 0.807843137254902, 0.819607843137255, 
                      0.819607843137255, 0.87843137254902, 1, 1, 1, 0.619607843137255, 
                      0.619607843137255, 0.803921568627451, 0.803921568627451, 1, 
                      0.392156862745098, 0.392156862745098, 0.419607843137255, 
                      0.419607843137255, 0.737254901960784, 0.737254901960784, 
                      0.545098039215686, 0.545098039215686, 0.701960784313725, 
                      0.701960784313725, 0.698039215686274, 0.698039215686274, 
                      0.984313725490196, 0.984313725490196, 1, 1, 0.988235294117647, 
                      0.988235294117647, 1, 1, 0.980392156862745, 0.980392156862745, 1, 1, 
                      0.803921568627451, 0.803921568627451, 0.803921568627451, 
                      0.803921568627451, 0.545098039215686, 0.545098039215686, 
                      0.556862745098039, 0.556862745098039, 0.717647058823529, 
                      0.717647058823529, 0.901960784313726, 0.909803921568627, 
                      0.909803921568627, 0.980392156862745, 0.980392156862745, 1, 1, 1, 
                      0.843137254901961, 0.866666666666667, 0.866666666666667, 
                      0.647058823529412, 0.525490196078431, 0.525490196078431, 
                      0.56078431372549, 0.56078431372549, 0.36078431372549, 0.36078431372549, 
                      0.270588235294118, 0.270588235294118, 0.32156862745098, 
                      0.52156862745098, 0.72156862745098, 0.96078431372549, 0.870588235294118,
                      0.643137254901961, 0.643137254901961, 0.705882352941177, 
                      0.411764705882353, 0.133333333333333, 0.164705882352941, 
                      0.588235294117647, 0.588235294117647, 0.501960784313725, 
                      0.627450980392157, 0.627450980392157, 0.647058823529412, 
                      0.549019607843137, 0.549019607843137, 0.498039215686275, 
                      0.501960784313725, 0.501960784313725, 0.388235294117647, 
                      0.270588235294118, 0.270588235294118, 0, 0.411764705882353, 
                      0.411764705882353, 0.0784313725490196, 0.0784313725490196, 
                      0.752941176470588, 0.713725490196078, 0.713725490196078, 
                      0.43921568627451, 0.43921568627451, 0.188235294117647, 
                      0.0823529411764706, 0.0823529411764706, 0.125490196078431, 
                      0.125490196078431, 0, 0.509803921568627, 0.627450980392157, 
                      0.43921568627451, 0.333333333333333, 0.333333333333333, 
                      0.196078431372549, 0.196078431372549, 0, 0, 0.168627450980392, 
                      0.168627450980392, 0.125490196078431, 0.43921568627451, 
                      0.43921568627451, 0.749019607843137, 0.980392156862745, 
                      0.913725490196078, 0.788235294117647, 0.537254901960784, 
                      0.96078431372549, 0.898039215686275, 0.772549019607843, 
                      0.525490196078431, 0.937254901960784, 0.874509803921569, 
                      0.752941176470588, 0.513725490196078, 0.894117647058824, 
                      0.835294117647059, 0.717647058823529, 0.490196078431373, 
                      0.854901960784314, 0.796078431372549, 0.686274509803922, 
                      0.466666666666667, 0.870588235294118, 0.811764705882353, 
                      0.701960784313725, 0.474509803921569, 0.980392156862745, 
                      0.913725490196078, 0.788235294117647, 0.537254901960784, 
                      0.972549019607843, 0.909803921568627, 0.784313725490196, 
                      0.533333333333333, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 0.941176470588235, 0.87843137254902, 
                      0.756862745098039, 0.513725490196078, 0.894117647058824, 
                      0.835294117647059, 0.717647058823529, 0.490196078431373, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 
                      0.435294117647059, 0.403921568627451, 0.349019607843137, 
                      0.235294117647059, 0.462745098039216, 0.431372549019608, 
                      0.372549019607843, 0.250980392156863, 0, 0, 0, 0, 0.564705882352941, 
                      0.525490196078431, 0.454901960784314, 0.305882352941176, 
                      0.72156862745098, 0.674509803921569, 0.580392156862745, 
                      0.392156862745098, 0.749019607843137, 0.698039215686274, 
                      0.603921568627451, 0.407843137254902, 0.807843137254902, 
                      0.752941176470588, 0.650980392156863, 0.43921568627451, 
                      0.886274509803922, 0.827450980392157, 0.713725490196078, 
                      0.482352941176471, 0.886274509803922, 0.827450980392157, 
                      0.713725490196078, 0.482352941176471, 0.882352941176471, 
                      0.823529411764706, 0.709803921568627, 0.482352941176471, 
                      0.937254901960784, 0.874509803921569, 0.752941176470588, 
                      0.513725490196078, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 0.96078431372549, 0.898039215686275, 
                      0.772549019607843, 0.525490196078431, 0.96078431372549, 
                      0.898039215686275, 0.772549019607843, 0.525490196078431, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 
                      0.964705882352941, 0.901960784313726, 0.776470588235294, 
                      0.525490196078431, 0.925490196078431, 0.862745098039216, 
                      0.745098039215686, 0.505882352941176, 1, 0.933333333333333, 
                      0.803921568627451, 0.545098039215686, 1, 0.933333333333333, 
                      0.803921568627451, 0.545098039215686, 0.843137254901961, 
                      0.788235294117647, 0.67843137254902, 0.458823529411765, 
                      0.756862745098039, 0.705882352941177, 0.607843137254902, 
                      0.411764705882353, 0.725490196078431, 0.67843137254902, 
                      0.584313725490196, 0.396078431372549, 0.756862745098039, 
                      0.705882352941177, 0.607843137254902, 0.411764705882353, 
                      0.415686274509804, 0.388235294117647, 0.333333333333333, 
                      0.227450980392157, 0.509803921568627, 0.474509803921569, 
                      0.407843137254902, 0.27843137254902, 0.827450980392157, 
                      0.772549019607843, 0.666666666666667, 0.450980392156863, 
                      0.905882352941176, 0.847058823529412, 0.729411764705882, 
                      0.494117647058824, 0.647058823529412, 0.603921568627451, 
                      0.52156862745098, 0.352941176470588, 0.498039215686275, 
                      0.462745098039216, 0.4, 0.270588235294118, 0.188235294117647, 
                      0.172549019607843, 0.149019607843137, 0.101960784313725, 
                      0.250980392156863, 0.231372549019608, 0.2, 0.137254901960784, 
                      0.549019607843137, 0.509803921568627, 0.43921568627451, 
                      0.298039215686275, 0.627450980392157, 0.584313725490196, 
                      0.505882352941176, 0.341176470588235, 0.647058823529412, 
                      0.603921568627451, 0.52156862745098, 0.352941176470588, 
                      0.498039215686275, 0.462745098039216, 0.4, 0.270588235294118, 
                      0.447058823529412, 0.415686274509804, 0.356862745098039, 
                      0.243137254901961, 0.388235294117647, 0.36078431372549, 
                      0.309803921568627, 0.211764705882353, 0.270588235294118, 
                      0.250980392156863, 0.215686274509804, 0.145098039215686, 0, 0, 0, 0, 
                      0.0784313725490196, 0.0705882352941176, 0.0627450980392157, 
                      0.0392156862745098, 0.431372549019608, 0.415686274509804, 
                      0.376470588235294, 0.227450980392157, 0.709803921568627, 
                      0.662745098039216, 0.568627450980392, 0.388235294117647, 
                      0.682352941176471, 0.635294117647059, 0.549019607843137, 
                      0.372549019607843, 0.509803921568627, 0.474509803921569, 
                      0.407843137254902, 0.27843137254902, 0.203921568627451, 
                      0.188235294117647, 0.16078431372549, 0.109803921568627, 
                      0.243137254901961, 0.227450980392157, 0.196078431372549, 
                      0.133333333333333, 0, 0, 0, 0, 0.513725490196078, 0.47843137254902, 
                      0.411764705882353, 0.27843137254902, 0.733333333333333, 
                      0.682352941176471, 0.588235294117647, 0.4, 0.4, 0.372549019607843, 
                      0.32156862745098, 0.215686274509804, 0.243137254901961, 
                      0.227450980392157, 0.196078431372549, 0.133333333333333, 
                      0.188235294117647, 0.172549019607843, 0.149019607843137, 
                      0.101960784313725, 0.509803921568627, 0.474509803921569, 
                      0.407843137254902, 0.27843137254902, 0.882352941176471, 
                      0.823529411764706, 0.709803921568627, 0.482352941176471, 0, 0, 
                      0.0117647058823529, 0.0117647058823529, 0.0196078431372549, 
                      0.0196078431372549, 0.0313725490196078, 0.0313725490196078, 
                      0.0392156862745098, 0.0392156862745098, 0.0509803921568627, 
                      0.0509803921568627, 0.0588235294117647, 0.0588235294117647, 
                      0.0705882352941176, 0.0705882352941176, 0.0784313725490196, 
                      0.0784313725490196, 0.0901960784313725, 0.0901960784313725, 
                      0.101960784313725, 0.101960784313725, 0.109803921568627, 
                      0.109803921568627, 0.12156862745098, 0.12156862745098, 
                      0.129411764705882, 0.129411764705882, 0.141176470588235, 
                      0.141176470588235, 0.149019607843137, 0.149019607843137, 
                      0.16078431372549, 0.16078431372549, 0.168627450980392, 
                      0.168627450980392, 0.180392156862745, 0.180392156862745, 
                      0.188235294117647, 0.188235294117647, 0.2, 0.2, 0.211764705882353, 
                      0.211764705882353, 0.219607843137255, 0.219607843137255, 
                      0.231372549019608, 0.231372549019608, 0.23921568627451, 
                      0.23921568627451, 0.250980392156863, 0.250980392156863, 
                      0.258823529411765, 0.258823529411765, 0.270588235294118, 
                      0.270588235294118, 0.27843137254902, 0.27843137254902, 
                      0.290196078431373, 0.290196078431373, 0.301960784313725, 
                      0.301960784313725, 0.309803921568627, 0.309803921568627, 
                      0.32156862745098, 0.32156862745098, 0.329411764705882, 
                      0.329411764705882, 0.341176470588235, 0.341176470588235, 
                      0.349019607843137, 0.349019607843137, 0.36078431372549, 
                      0.36078431372549, 0.368627450980392, 0.368627450980392, 
                      0.380392156862745, 0.380392156862745, 0.388235294117647, 
                      0.388235294117647, 0.4, 0.4, 0.411764705882353, 0.411764705882353, 
                      0.419607843137255, 0.419607843137255, 0.431372549019608, 
                      0.431372549019608, 0.43921568627451, 0.43921568627451, 
                      0.450980392156863, 0.450980392156863, 0.458823529411765, 
                      0.458823529411765, 0.470588235294118, 0.470588235294118, 
                      0.47843137254902, 0.47843137254902, 0.490196078431373, 
                      0.490196078431373, 0.498039215686275, 0.498039215686275, 
                      0.509803921568627, 0.509803921568627, 0.52156862745098, 
                      0.52156862745098, 0.529411764705882, 0.529411764705882, 
                      0.541176470588235, 0.541176470588235, 0.549019607843137, 
                      0.549019607843137, 0.56078431372549, 0.56078431372549, 
                      0.568627450980392, 0.568627450980392, 0.580392156862745, 
                      0.580392156862745, 0.588235294117647, 0.588235294117647, 0.6, 0.6, 
                      0.611764705882353, 0.611764705882353, 0.619607843137255, 
                      0.619607843137255, 0.631372549019608, 0.631372549019608, 
                      0.63921568627451, 0.63921568627451, 0.650980392156863, 
                      0.650980392156863, 0.658823529411765, 0.658823529411765, 
                      0.670588235294118, 0.670588235294118, 0.67843137254902, 
                      0.67843137254902, 0.690196078431373, 0.690196078431373, 
                      0.701960784313725, 0.701960784313725, 0.709803921568627, 
                      0.709803921568627, 0.72156862745098, 0.72156862745098, 
                      0.729411764705882, 0.729411764705882, 0.741176470588235, 
                      0.741176470588235, 0.749019607843137, 0.749019607843137, 
                      0.76078431372549, 0.76078431372549, 0.768627450980392, 
                      0.768627450980392, 0.780392156862745, 0.780392156862745, 
                      0.788235294117647, 0.788235294117647, 0.8, 0.8, 0.811764705882353, 
                      0.811764705882353, 0.819607843137255, 0.819607843137255, 
                      0.831372549019608, 0.831372549019608, 0.83921568627451, 
                      0.83921568627451, 0.850980392156863, 0.850980392156863, 
                      0.858823529411765, 0.858823529411765, 0.870588235294118, 
                      0.870588235294118, 0.87843137254902, 0.87843137254902, 
                      0.890196078431372, 0.890196078431372, 0.898039215686275, 
                      0.898039215686275, 0.909803921568627, 0.909803921568627, 
                      0.92156862745098, 0.92156862745098, 0.929411764705882, 
                      0.929411764705882, 0.941176470588235, 0.941176470588235, 
                      0.949019607843137, 0.949019607843137, 0.96078431372549, 
                      0.96078431372549, 0.968627450980392, 0.968627450980392, 
                      0.980392156862745, 0.980392156862745, 0.988235294117647, 
                      0.988235294117647, 1, 1, 0.980392156862745, 1, 1, 0.96078431372549, 
                      0.96078431372549, 0.862745098039216, 0.941176470588235, 
                      0.941176470588235, 0.901960784313726, 0.901960784313726, 
                      0.901960784313726, 0.843137254901961, 0.843137254901961, 
                      0.835294117647059, 0.835294117647059, 0.803921568627451, 
                      0.803921568627451, 0.768627450980392, 0.725490196078431, 
                      0.725490196078431, 0.67843137254902, 0.67843137254902, 
                      0.709803921568627, 0.862745098039216, 0.941176470588235, 
                      0.803921568627451, 0.803921568627451, 0.933333333333333, 
                      0.941176470588235, 0.980392156862745, 0.980392156862745, 1, 1, 1, 
                      0.980392156862745, 0.96078431372549, 0.96078431372549, 
                      0.882352941176471, 0.882352941176471, 1, 0, 0.309803921568627, 
                      0.309803921568627, 0.309803921568627, 0.309803921568627, 
                      0.411764705882353, 0.411764705882353, 0.411764705882353, 
                      0.411764705882353, 0.564705882352941, 0.564705882352941, 
                      0.564705882352941, 0.564705882352941, 0.6, 0.6, 0.6, 0.6, 
                      0.752941176470588, 0.752941176470588, 0.827450980392157, 
                      0.827450980392157, 0.827450980392157, 0.827450980392157, 
                      0.43921568627451, 0.43921568627451, 0.501960784313725, 
                      0.501960784313725, 0.501960784313725, 0.929411764705882, 
                      0.929411764705882, 0.545098039215686, 0.545098039215686, 
                      0.803921568627451, 0.803921568627451, 0.933333333333333, 
                      0.933333333333333, 1, 1, 0.803921568627451, 0.803921568627451, 
                      0.882352941176471, 0.882352941176471, 1, 1, 1, 1, 1, 0.92156862745098, 
                      0.92156862745098, 0.980392156862745, 0.980392156862745, 
                      0.705882352941177, 0.705882352941177, 0.870588235294118, 
                      0.870588235294118, 0.901960784313726, 0.901960784313726, 
                      0.901960784313726, 0.901960784313726, 0.933333333333333, 
                      0.933333333333333, 0.819607843137255, 0.819607843137255, 0.8, 0.8, 
                      0.815686274509804, 1, 1, 1, 0.627450980392157, 0.627450980392157, 
                      0.666666666666667, 0.666666666666667, 0.831372549019608, 0, 0, 
                      0.184313725490196, 0.184313725490196, 0.56078431372549, 
                      0.56078431372549, 0.341176470588235, 0.341176470588235, 
                      0.443137254901961, 0.443137254901961, 0.666666666666667, 
                      0.666666666666667, 0.596078431372549, 0.596078431372549, 
                      0.498039215686275, 0.498039215686275, 0, 0, 0, 0, 0.603921568627451, 
                      0.603921568627451, 0.184313725490196, 0.184313725490196, 
                      0.196078431372549, 0.196078431372549, 0.196078431372549, 
                      0.196078431372549, 0.133333333333333, 0.133333333333333, 
                      0.137254901960784, 0.137254901960784, 0.419607843137255, 
                      0.419607843137255, 0.549019607843137, 0.666666666666667, 
                      0.666666666666667, 0.823529411764706, 0.823529411764706, 
                      0.87843137254902, 0.87843137254902, 0, 0, 0.509803921568627, 
                      0.509803921568627, 0.125490196078431, 0.0431372549019608, 
                      0.0431372549019608, 0.56078431372549, 0.56078431372549, 
                      0.36078431372549, 0.36078431372549, 0.0745098039215686, 
                      0.0745098039215686, 0.176470588235294, 0.247058823529412, 
                      0.529411764705882, 0.862745098039216, 0.701960784313725, 
                      0.376470588235294, 0.376470588235294, 0.549019607843137, 
                      0.117647058823529, 0.133333333333333, 0.164705882352941, 
                      0.47843137254902, 0.47843137254902, 0.447058823529412, 0.47843137254902,
                      0.47843137254902, 0, 0, 0, 0.313725490196078, 0.501960784313725, 
                      0.501960784313725, 0.27843137254902, 0, 0, 0, 0.705882352941177, 
                      0.705882352941177, 0.576470588235294, 0.576470588235294, 
                      0.796078431372549, 0.756862745098039, 0.756862745098039, 
                      0.576470588235294, 0.576470588235294, 0.376470588235294, 
                      0.52156862745098, 0.52156862745098, 0.564705882352941, 
                      0.564705882352941, 1, 0.933333333333333, 0.866666666666667, 
                      0.83921568627451, 0.827450980392157, 0.827450980392157, 0.8, 0.8, 
                      0.827450980392157, 0.827450980392157, 0.886274509803922, 
                      0.886274509803922, 0.941176470588235, 0.858823529411765, 
                      0.858823529411765, 0.847058823529412, 0.980392156862745, 
                      0.913725490196078, 0.788235294117647, 0.537254901960784, 
                      0.933333333333333, 0.870588235294118, 0.749019607843137, 
                      0.509803921568627, 0.858823529411765, 0.8, 0.690196078431373, 
                      0.470588235294118, 0.768627450980392, 0.717647058823529, 
                      0.619607843137255, 0.419607843137255, 0.725490196078431, 
                      0.67843137254902, 0.584313725490196, 0.396078431372549, 
                      0.67843137254902, 0.631372549019608, 0.545098039215686, 
                      0.368627450980392, 0.803921568627451, 0.749019607843137, 
                      0.647058823529412, 0.43921568627451, 0.862745098039216, 
                      0.803921568627451, 0.694117647058824, 0.470588235294118, 
                      0.941176470588235, 0.87843137254902, 0.756862745098039, 
                      0.513725490196078, 0.941176470588235, 0.87843137254902, 
                      0.756862745098039, 0.513725490196078, 0.96078431372549, 
                      0.898039215686275, 0.772549019607843, 0.525490196078431, 
                      0.882352941176471, 0.823529411764706, 0.709803921568627, 
                      0.482352941176471, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 0.831372549019608, 0.776470588235294, 
                      0.666666666666667, 0.454901960784314, 0.756862745098039, 
                      0.705882352941177, 0.607843137254902, 0.411764705882353, 
                      0.623529411764706, 0.580392156862745, 0.501960784313725, 
                      0.341176470588235, 0.603921568627451, 0.564705882352941, 
                      0.486274509803922, 0.329411764705882, 0.498039215686275, 
                      0.462745098039216, 0.4, 0.270588235294118, 0, 0, 0, 0, 0, 0, 0, 0, 
                      0.243137254901961, 0.227450980392157, 0.196078431372549, 
                      0.133333333333333, 0.43921568627451, 0.407843137254902, 
                      0.352941176470588, 0.23921568627451, 0.56078431372549, 0.52156862745098,
                      0.450980392156863, 0.305882352941176, 0.545098039215686, 
                      0.509803921568627, 0.43921568627451, 0.298039215686275, 
                      0.87843137254902, 0.819607843137255, 0.705882352941177, 
                      0.47843137254902, 0, 0, 0, 0, 0, 0, 0, 0, 0.145098039215686, 
                      0.133333333333333, 0.113725490196078, 0.0784313725490196, 
                      0.0588235294117647, 0.0549019607843137, 0.0470588235294118, 
                      0.0313725490196078, 0.756862745098039, 0.705882352941177, 
                      0.607843137254902, 0.411764705882353, 0.415686274509804, 
                      0.388235294117647, 0.333333333333333, 0.227450980392157, 
                      0.27843137254902, 0.258823529411765, 0.223529411764706, 
                      0.149019607843137, 0.607843137254902, 0.568627450980392, 
                      0.490196078431373, 0.333333333333333, 0.729411764705882, 
                      0.682352941176471, 0.588235294117647, 0.4, 0.309803921568627, 
                      0.286274509803922, 0.247058823529412, 0.168627450980392, 
                      0.141176470588235, 0.129411764705882, 0.113725490196078, 
                      0.0745098039215686, 0.188235294117647, 0.172549019607843, 
                      0.149019607843137, 0.101960784313725, 0.250980392156863, 
                      0.231372549019608, 0.2, 0.137254901960784, 0.411764705882353, 
                      0.384313725490196, 0.329411764705882, 0.223529411764706, 
                      0.47843137254902, 0.447058823529412, 0.384313725490196, 
                      0.258823529411765, 0, 0, 0, 0, 0, 0, 0, 0, 0.337254901960784, 
                      0.313725490196078, 0.270588235294118, 0.184313725490196, 
                      0.27843137254902, 0.258823529411765, 0.223529411764706, 
                      0.149019607843137, 0, 0, 0, 0, 0, 0, 0, 0, 0.576470588235294, 
                      0.537254901960784, 0.462745098039216, 0.313725490196078, 
                      0.705882352941177, 0.654901960784314, 0.564705882352941, 
                      0.384313725490196, 0.772549019607843, 0.72156862745098, 
                      0.619607843137255, 0.423529411764706, 0.725490196078431, 
                      0.67843137254902, 0.584313725490196, 0.396078431372549, 
                      0.670588235294118, 0.623529411764706, 0.537254901960784, 
                      0.364705882352941, 0.701960784313725, 0.654901960784314, 
                      0.564705882352941, 0.384313725490196, 0.588235294117647, 
                      0.549019607843137, 0.470588235294118, 0.32156862745098, 1, 
                      0.933333333333333, 0.803921568627451, 0.545098039215686, 
                      0.980392156862745, 0.913725490196078, 0.788235294117647, 
                      0.537254901960784, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 1, 0.933333333333333, 0.803921568627451, 
                      0.545098039215686, 0, 0, 0.0117647058823529, 0.0117647058823529, 
                      0.0196078431372549, 0.0196078431372549, 0.0313725490196078, 
                      0.0313725490196078, 0.0392156862745098, 0.0392156862745098, 
                      0.0509803921568627, 0.0509803921568627, 0.0588235294117647, 
                      0.0588235294117647, 0.0705882352941176, 0.0705882352941176, 
                      0.0784313725490196, 0.0784313725490196, 0.0901960784313725, 
                      0.0901960784313725, 0.101960784313725, 0.101960784313725, 
                      0.109803921568627, 0.109803921568627, 0.12156862745098, 
                      0.12156862745098, 0.129411764705882, 0.129411764705882, 
                      0.141176470588235, 0.141176470588235, 0.149019607843137, 
                      0.149019607843137, 0.16078431372549, 0.16078431372549, 
                      0.168627450980392, 0.168627450980392, 0.180392156862745, 
                      0.180392156862745, 0.188235294117647, 0.188235294117647, 0.2, 0.2, 
                      0.211764705882353, 0.211764705882353, 0.219607843137255, 
                      0.219607843137255, 0.231372549019608, 0.231372549019608, 
                      0.23921568627451, 0.23921568627451, 0.250980392156863, 
                      0.250980392156863, 0.258823529411765, 0.258823529411765, 
                      0.270588235294118, 0.270588235294118, 0.27843137254902, 
                      0.27843137254902, 0.290196078431373, 0.290196078431373, 
                      0.301960784313725, 0.301960784313725, 0.309803921568627, 
                      0.309803921568627, 0.32156862745098, 0.32156862745098, 
                      0.329411764705882, 0.329411764705882, 0.341176470588235, 
                      0.341176470588235, 0.349019607843137, 0.349019607843137, 
                      0.36078431372549, 0.36078431372549, 0.368627450980392, 
                      0.368627450980392, 0.380392156862745, 0.380392156862745, 
                      0.388235294117647, 0.388235294117647, 0.4, 0.4, 0.411764705882353, 
                      0.411764705882353, 0.419607843137255, 0.419607843137255, 
                      0.431372549019608, 0.431372549019608, 0.43921568627451, 
                      0.43921568627451, 0.450980392156863, 0.450980392156863, 
                      0.458823529411765, 0.458823529411765, 0.470588235294118, 
                      0.470588235294118, 0.47843137254902, 0.47843137254902, 
                      0.490196078431373, 0.490196078431373, 0.498039215686275, 
                      0.498039215686275, 0.509803921568627, 0.509803921568627, 
                      0.52156862745098, 0.52156862745098, 0.529411764705882, 
                      0.529411764705882, 0.541176470588235, 0.541176470588235, 
                      0.549019607843137, 0.549019607843137, 0.56078431372549, 
                      0.56078431372549, 0.568627450980392, 0.568627450980392, 
                      0.580392156862745, 0.580392156862745, 0.588235294117647, 
                      0.588235294117647, 0.6, 0.6, 0.611764705882353, 0.611764705882353, 
                      0.619607843137255, 0.619607843137255, 0.631372549019608, 
                      0.631372549019608, 0.63921568627451, 0.63921568627451, 
                      0.650980392156863, 0.650980392156863, 0.658823529411765, 
                      0.658823529411765, 0.670588235294118, 0.670588235294118, 
                      0.67843137254902, 0.67843137254902, 0.690196078431373, 
                      0.690196078431373, 0.701960784313725, 0.701960784313725, 
                      0.709803921568627, 0.709803921568627, 0.72156862745098, 
                      0.72156862745098, 0.729411764705882, 0.729411764705882, 
                      0.741176470588235, 0.741176470588235, 0.749019607843137, 
                      0.749019607843137, 0.76078431372549, 0.76078431372549, 
                      0.768627450980392, 0.768627450980392, 0.780392156862745, 
                      0.780392156862745, 0.788235294117647, 0.788235294117647, 0.8, 0.8, 
                      0.811764705882353, 0.811764705882353, 0.819607843137255, 
                      0.819607843137255, 0.831372549019608, 0.831372549019608, 
                      0.83921568627451, 0.83921568627451, 0.850980392156863, 
                      0.850980392156863, 0.858823529411765, 0.858823529411765, 
                      0.870588235294118, 0.870588235294118, 0.87843137254902, 
                      0.87843137254902, 0.890196078431372, 0.890196078431372, 
                      0.898039215686275, 0.898039215686275, 0.909803921568627, 
                      0.909803921568627, 0.92156862745098, 0.92156862745098, 
                      0.929411764705882, 0.929411764705882, 0.941176470588235, 
                      0.941176470588235, 0.949019607843137, 0.949019607843137, 
                      0.96078431372549, 0.96078431372549, 0.968627450980392, 
                      0.968627450980392, 0.980392156862745, 0.980392156862745, 
                      0.988235294117647, 0.988235294117647, 1, 1), .Dim = c(738, 3), 
            .Dimnames = list(c("snow", "ghost white", "GhostWhite", "white smoke", 
                               "WhiteSmoke", "gainsboro", "floral white", "FloralWhite", "old lace", 
                               "OldLace", "linen", "antique white", "AntiqueWhite", "papaya whip", 
                               "PapayaWhip", "blanched almond", "BlanchedAlmond", "bisque", 
                               "peach puff", "PeachPuff", "navajo white", "NavajoWhite", "moccasin", 
                               "cornsilk", "ivory", "lemon chiffon", "LemonChiffon", "seashell", 
                               "honeydew", "mint cream", "MintCream", "azure", "alice blue", 
                               "AliceBlue", "lavender", "lavender blush", "LavenderBlush", 
                               "misty rose", "MistyRose", "white", "black", "dark slate gray", 
                               "DarkSlateGray", "dark slate grey", "DarkSlateGrey", "dim gray", 
                               "DimGray", "dim grey", "DimGrey", "slate gray", "SlateGray", 
                               "slate grey", "SlateGrey", "light slate gray", "LightSlateGray", 
                               "light slate grey", "LightSlateGrey", "gray", "grey", "light grey", 
                               "LightGrey", "light gray", "LightGray", "midnight blue", "MidnightBlue",
                               "navy", "navy blue", "NavyBlue", "cornflower blue", "CornflowerBlue", 
                               "dark slate blue", "DarkSlateBlue", "slate blue", "SlateBlue", 
                               "medium slate blue", "MediumSlateBlue", "light slate blue", 
                               "LightSlateBlue", "medium blue", "MediumBlue", "royal blue", 
                               "RoyalBlue", "blue", "dodger blue", "DodgerBlue", "deep sky blue", 
                               "DeepSkyBlue", "sky blue", "SkyBlue", "light sky blue", "LightSkyBlue", 
                               "steel blue", "SteelBlue", "light steel blue", "LightSteelBlue", 
                               "light blue", "LightBlue", "powder blue", "PowderBlue", 
                               "pale turquoise", "PaleTurquoise", "dark turquoise", "DarkTurquoise", 
                               "medium turquoise", "MediumTurquoise", "turquoise", "cyan", 
                               "light cyan", "LightCyan", "cadet blue", "CadetBlue", 
                               "medium aquamarine", "MediumAquamarine", "aquamarine", "dark green", 
                               "DarkGreen", "dark olive green", "DarkOliveGreen", "dark sea green", 
                               "DarkSeaGreen", "sea green", "SeaGreen", "medium sea green", 
                               "MediumSeaGreen", "light sea green", "LightSeaGreen", "pale green", 
                               "PaleGreen", "spring green", "SpringGreen", "lawn green", "LawnGreen", 
                               "green", "chartreuse", "medium spring green", "MediumSpringGreen", 
                               "green yellow", "GreenYellow", "lime green", "LimeGreen", 
                               "yellow green", "YellowGreen", "forest green", "ForestGreen", 
                               "olive drab", "OliveDrab", "dark khaki", "DarkKhaki", "khaki", 
                               "pale goldenrod", "PaleGoldenrod", "light goldenrod yellow", 
                               "LightGoldenrodYellow", "light yellow", "LightYellow", "yellow", "gold",
                               "light goldenrod", "LightGoldenrod", "goldenrod", "dark goldenrod", 
                               "DarkGoldenrod", "rosy brown", "RosyBrown", "indian red", "IndianRed", 
                               "saddle brown", "SaddleBrown", "sienna", "peru", "burlywood", "beige", 
                               "wheat", "sandy brown", "SandyBrown", "tan", "chocolate", "firebrick", 
                               "brown", "dark salmon", "DarkSalmon", "salmon", "light salmon", 
                               "LightSalmon", "orange", "dark orange", "DarkOrange", "coral", 
                               "light coral", "LightCoral", "tomato", "orange red", "OrangeRed", "red",
                               "hot pink", "HotPink", "deep pink", "DeepPink", "pink", "light pink", 
                               "LightPink", "pale violet red", "PaleVioletRed", "maroon", 
                               "medium violet red", "MediumVioletRed", "violet red", "VioletRed", 
                               "magenta", "violet", "plum", "orchid", "medium orchid", "MediumOrchid", 
                               "dark orchid", "DarkOrchid", "dark violet", "DarkViolet", "blue violet",
                               "BlueViolet", "purple", "medium purple", "MediumPurple", "thistle", 
                               "snow1", "snow2", "snow3", "snow4", "seashell1", "seashell2", 
                               "seashell3", "seashell4", "AntiqueWhite1", "AntiqueWhite2", 
                               "AntiqueWhite3", "AntiqueWhite4", "bisque1", "bisque2", "bisque3", 
                               "bisque4", "PeachPuff1", "PeachPuff2", "PeachPuff3", "PeachPuff4", 
                               "NavajoWhite1", "NavajoWhite2", "NavajoWhite3", "NavajoWhite4", 
                               "LemonChiffon1", "LemonChiffon2", "LemonChiffon3", "LemonChiffon4", 
                               "cornsilk1", "cornsilk2", "cornsilk3", "cornsilk4", "ivory1", "ivory2", 
                               "ivory3", "ivory4", "honeydew1", "honeydew2", "honeydew3", "honeydew4", 
                               "LavenderBlush1", "LavenderBlush2", "LavenderBlush3", "LavenderBlush4", 
                               "MistyRose1", "MistyRose2", "MistyRose3", "MistyRose4", "azure1", 
                               "azure2", "azure3", "azure4", "SlateBlue1", "SlateBlue2", "SlateBlue3", 
                               "SlateBlue4", "RoyalBlue1", "RoyalBlue2", "RoyalBlue3", "RoyalBlue4", 
                               "blue1", "blue2", "blue3", "blue4", "DodgerBlue1", "DodgerBlue2", 
                               "DodgerBlue3", "DodgerBlue4", "SteelBlue1", "SteelBlue2", "SteelBlue3", 
                               "SteelBlue4", "DeepSkyBlue1", "DeepSkyBlue2", "DeepSkyBlue3", 
                               "DeepSkyBlue4", "SkyBlue1", "SkyBlue2", "SkyBlue3", "SkyBlue4", 
                               "LightSkyBlue1", "LightSkyBlue2", "LightSkyBlue3", "LightSkyBlue4", 
                               "SlateGray1", "SlateGray2", "SlateGray3", "SlateGray4", 
                               "LightSteelBlue1", "LightSteelBlue2", "LightSteelBlue3", 
                               "LightSteelBlue4", "LightBlue1", "LightBlue2", "LightBlue3", 
                               "LightBlue4", "LightCyan1", "LightCyan2", "LightCyan3", "LightCyan4", 
                               "PaleTurquoise1", "PaleTurquoise2", "PaleTurquoise3", "PaleTurquoise4", 
                               "CadetBlue1", "CadetBlue2", "CadetBlue3", "CadetBlue4", "turquoise1", 
                               "turquoise2", "turquoise3", "turquoise4", "cyan1", "cyan2", "cyan3", 
                               "cyan4", "DarkSlateGray1", "DarkSlateGray2", "DarkSlateGray3", 
                               "DarkSlateGray4", "aquamarine1", "aquamarine2", "aquamarine3", 
                               "aquamarine4", "DarkSeaGreen1", "DarkSeaGreen2", "DarkSeaGreen3", 
                               "DarkSeaGreen4", "SeaGreen1", "SeaGreen2", "SeaGreen3", "SeaGreen4", 
                               "PaleGreen1", "PaleGreen2", "PaleGreen3", "PaleGreen4", "SpringGreen1", 
                               "SpringGreen2", "SpringGreen3", "SpringGreen4", "green1", "green2", 
                               "green3", "green4", "chartreuse1", "chartreuse2", "chartreuse3", 
                               "chartreuse4", "OliveDrab1", "OliveDrab2", "OliveDrab3", "OliveDrab4", 
                               "DarkOliveGreen1", "DarkOliveGreen2", "DarkOliveGreen3", 
                               "DarkOliveGreen4", "khaki1", "khaki2", "khaki3", "khaki4", 
                               "LightGoldenrod1", "LightGoldenrod2", "LightGoldenrod3", 
                               "LightGoldenrod4", "LightYellow1", "LightYellow2", "LightYellow3", 
                               "LightYellow4", "yellow1", "yellow2", "yellow3", "yellow4", "gold1", 
                               "gold2", "gold3", "gold4", "goldenrod1", "goldenrod2", "goldenrod3", 
                               "goldenrod4", "DarkGoldenrod1", "DarkGoldenrod2", "DarkGoldenrod3", 
                               "DarkGoldenrod4", "RosyBrown1", "RosyBrown2", "RosyBrown3", 
                               "RosyBrown4", "IndianRed1", "IndianRed2", "IndianRed3", "IndianRed4", 
                               "sienna1", "sienna2", "sienna3", "sienna4", "burlywood1", "burlywood2", 
                               "burlywood3", "burlywood4", "wheat1", "wheat2", "wheat3", "wheat4", 
                               "tan1", "tan2", "tan3", "tan4", "chocolate1", "chocolate2", 
                               "chocolate3", "chocolate4", "firebrick1", "firebrick2", "firebrick3", 
                               "firebrick4", "brown1", "brown2", "brown3", "brown4", "salmon1", 
                               "salmon2", "salmon3", "salmon4", "LightSalmon1", "LightSalmon2", 
                               "LightSalmon3", "LightSalmon4", "orange1", "orange2", "orange3", 
                               "orange4", "DarkOrange1", "DarkOrange2", "DarkOrange3", "DarkOrange4", 
                               "coral1", "coral2", "coral3", "coral4", "tomato1", "tomato2", "tomato3",
                               "tomato4", "OrangeRed1", "OrangeRed2", "OrangeRed3", "OrangeRed4", 
                               "red1", "red2", "red3", "red4", "DeepPink1", "DeepPink2", "DeepPink3", 
                               "DeepPink4", "HotPink1", "HotPink2", "HotPink3", "HotPink4", "pink1", 
                               "pink2", "pink3", "pink4", "LightPink1", "LightPink2", "LightPink3", 
                               "LightPink4", "PaleVioletRed1", "PaleVioletRed2", "PaleVioletRed3", 
                               "PaleVioletRed4", "maroon1", "maroon2", "maroon3", "maroon4", 
                               "VioletRed1", "VioletRed2", "VioletRed3", "VioletRed4", "magenta1", 
                               "magenta2", "magenta3", "magenta4", "orchid1", "orchid2", "orchid3", 
                               "orchid4", "plum1", "plum2", "plum3", "plum4", "MediumOrchid1", 
                               "MediumOrchid2", "MediumOrchid3", "MediumOrchid4", "DarkOrchid1", 
                               "DarkOrchid2", "DarkOrchid3", "DarkOrchid4", "purple1", "purple2", 
                               "purple3", "purple4", "MediumPurple1", "MediumPurple2", "MediumPurple3",
                               "MediumPurple4", "thistle1", "thistle2", "thistle3", "thistle4", 
                               "gray0", "grey0", "gray1", "grey1", "gray2", "grey2", "gray3", "grey3", 
                               "gray4", "grey4", "gray5", "grey5", "gray6", "grey6", "gray7", "grey7", 
                               "gray8", "grey8", "gray9", "grey9", "gray10", "grey10", "gray11", 
                               "grey11", "gray12", "grey12", "gray13", "grey13", "gray14", "grey14", 
                               "gray15", "grey15", "gray16", "grey16", "gray17", "grey17", "gray18", 
                               "grey18", "gray19", "grey19", "gray20", "grey20", "gray21", "grey21", 
                               "gray22", "grey22", "gray23", "grey23", "gray24", "grey24", "gray25", 
                               "grey25", "gray26", "grey26", "gray27", "grey27", "gray28", "grey28", 
                               "gray29", "grey29", "gray30", "grey30", "gray31", "grey31", "gray32", 
                               "grey32", "gray33", "grey33", "gray34", "grey34", "gray35", "grey35", 
                               "gray36", "grey36", "gray37", "grey37", "gray38", "grey38", "gray39", 
                               "grey39", "gray40", "grey40", "gray41", "grey41", "gray42", "grey42", 
                               "gray43", "grey43", "gray44", "grey44", "gray45", "grey45", "gray46", 
                               "grey46", "gray47", "grey47", "gray48", "grey48", "gray49", "grey49", 
                               "gray50", "grey50", "gray51", "grey51", "gray52", "grey52", "gray53", 
                               "grey53", "gray54", "grey54", "gray55", "grey55", "gray56", "grey56", 
                               "gray57", "grey57", "gray58", "grey58", "gray59", "grey59", "gray60", 
                               "grey60", "gray61", "grey61", "gray62", "grey62", "gray63", "grey63", 
                               "gray64", "grey64", "gray65", "grey65", "gray66", "grey66", "gray67", 
                               "grey67", "gray68", "grey68", "gray69", "grey69", "gray70", "grey70", 
                               "gray71", "grey71", "gray72", "grey72", "gray73", "grey73", "gray74", 
                               "grey74", "gray75", "grey75", "gray76", "grey76", "gray77", "grey77", 
                               "gray78", "grey78", "gray79", "grey79", "gray80", "grey80", "gray81", 
                               "grey81", "gray82", "grey82", "gray83", "grey83", "gray84", "grey84", 
                               "gray85", "grey85", "gray86", "grey86", "gray87", "grey87", "gray88", 
                               "grey88", "gray89", "grey89", "gray90", "grey90", "gray91", "grey91", 
                               "gray92", "grey92", "gray93", "grey93", "gray94", "grey94", "gray95", 
                               "grey95", "gray96", "grey96", "gray97", "grey97", "gray98", "grey98", 
                               "gray99", "grey99", "gray100", "grey100"), c("Red", "Green", "Blue")))

setps <- function(filename, w=0, h=3, pointsize=10, sublines=0, toplines=0,
                  type="symbol", lwd=2, font='Helvetica',
                  leftlines=0, las=1, 
                  trellis=!(missing(setTrellis.) & missing(strip.blank) &
                            missing(lty.dot.line) & missing(lwd.dot.line)), 
                  setTrellis.=TRUE, 
                  strip.blank = TRUE, lty.dot.line = 1, lwd.dot.line = 1,
                  seqno=NULL, color=FALSE)
{
  filebase <-
    if(type=='char')
      filename
    else as.character(substitute(filename))
  
  if(length(seqno))
    filebase <- paste(filebase,seqno,sep='')
  
  filename <- paste(filebase,'.ps',sep='')
  if(length(.Options$setpsPrefix))
    filename <- paste(.Options$setpsPrefix, filename, sep='')

  ## Changed after submission to s-news: pointsize=NULL
  ## Antonio likes the default
  ## ratio of width/height to be the "golden ratio", which is the default.
  ## I often prefer a smaller ratio of 1.4. If exactly one of (width, height)
  ## is zero, the "ratio" is used to replace it based on the one specified.
  ## For a single figure in the plot I usually use psfig(filename,height=3).
  ## For a single figure in the plot I usually use psfig(filename,height=3).
  ## The logic in psfig assumes that one figure is being drawn, i.e., that
  ## par(mfrow=c(1,1)) is in effect. It will work for multiple plots if you
  ## set pointsize to something like 9.
  ## sublines specifies the number of extra lines to leave at the bottom of
  ## the plot for subtitles.
  ##
  ##    I include an S function that sets the stage for EPS graphics
  ## generation that will be incorporated by TeX (LaTeX, etc.), and that
  ## does a little of what you want, by hand, not in the smart way you
  ## envision.
  ##   Note that this function intentionally disallows main titles, with
  ## the understanding that they will be part of the figure's caption,
  ## which TeX itself generates. You may like to use it as starting point
  ## to get something that suits your needs.
  ##
  ##   - Antonio Possolo
  ##
  ##        Applied Mathematics & Statistics
  ##        The Boeing Company
  ##                           antonio@atc.boeing.com
  ##
  ##
  ## Added else scale <-   FEH 8Sep92, also added arg "ratio",
  ## commented out warning message for omitting main title,
  ## added arg sublines, pointsize
  ## may want to specify pointsize=9 if multiple plots used
  ## added lwd FEH 27Oct92
  ## added toplines FEH 18Oct93
  ## override fonts spec to ps.options because of bug - FEH 21Apr94
  ## added bty="l" FEH 24Aug94
  ## added leftlines FEH 26Aug94
  ## added onefile 27Feb95
  ## maden font default to Helvetica 25Mar00
  ## Doug Bates just does this:
  ## a) use postscript(filename, height=xx, width=yy, pointsize=10)
  ## b) change the figure's region on the page by using
  ##    par (mar=c(3.5, 3.5, 1.5, 0.5))  ## for example and perhaps also
  ##    par (mgp=c(2.5, 0.5, 0))
  ## 
  ##  added color=FALSE 7feb03
  
  psfig <- function(file = "", width = 0, height = 0,
                    ratio= (1 + sqrt(5))/2, font = 'Helvetica', 
                    pointsize=NULL, sublines=0, 
                    toplines=0, leftlines=0, lwd=0.5, bty="l", onefile=FALSE, 
                    las=NULL, trellis=FALSE, color=FALSE)
  {

    ##	POSTSCRIPT FIGURE MAKER
    ##	for incorporation into TeX using PSFIG or BoxedEPSF.
    ##	The strategy is to create a pleasant aspect ratio, 
    ##	while minimizing white space around the figure.
    ##
    ## Aspect ratio is Golden Ratio
    ## Standard width is 30 picas = 30*12/(72.27) inches
    StandardWidth <- (30 * 12)/(72.27)
    StandardHeight <- StandardWidth/ratio
    StandardPointSize <- 9
    if ( width == 0 & height == 0 ) { 
      width <- StandardWidth
      height <- StandardHeight
      scale <- 1
    }
    
    if ( width > 0 & height == 0 ) { 
      height <- width/ratio
      scale <- width/StandardWidth
    }
    
    if ( width == 0 & height > 0 ) { 
      width <- height*ratio
      scale <- width/StandardWidth
    }
    else scale <- max(width/StandardWidth,height/StandardHeight)

    if(!length(pointsize)) pointsize <- round(scale * StandardPointSize)

    ##	FONTS & FONT SELECTION
    ##
    ##  1 Helvetica               19 Bookman-DemiItalic
    ##  2 Courier                 20 Bookman-Light
    ##  3 Times-Roman             21 Bookman-LightItalic
    ##  4 Helvetica-Oblique       22 Helvetica-Narrow
    ##  5 Helvetica-Bold          23 Helvetica-Narrow-Bold
    ##  6 Helvetica-BoldOblique   24 Helvetica-Narrow-BoldOblique
    ##  7 Courier-Oblique         25 Helvetica-Narrow-Oblique
    ##  8 Courier-Bold            26 NewCenturySchlbk-Roman
    ##  9 Courier-BoldOblique     27 NewCenturySchlbk-Bold
    ## 10 Times-Italic            28 NewCenturySchlbk-Italic
    ## 11 Times-Bold              29 NewCenturySchlbk-BoldItalic
    ## 12 Times-BoldItalic        30 Palatino-Roman
    ## 13 Symbol                  31 Palatino-Bold
    ## 14 AvantGarde-Book         32 Palatino-Italic
    ## 15 AvantGarde-BookOblique  33 Palatino-BoldItalic
    ## 16 AvantGarde-Demi         34 ZapfChancery-MediumItalic
    ## 17 AvantGarde-DemiOblique  35 ZapfDingbats
    ## 18 Bookman-Demi           

    if(!.R.) {
      ps.fonts <-
        if(under.unix)ps.options()$fonts
        else ps.fonts
      
      if(is.numeric(font)) {          # was is.number 10Apr01
        fontNumber <- font
        if(fontNumber < 1 | fontNumber > length(ps.fonts)) {
          fontNumber <- 1
          cat(paste("\tPSFIG WARNING: Font requested is not available\n",
                    "\t\tSubstituted by Helvetica\n"))
        }
      } else {
        fontName <- font
        fontNumber <- match(fontName, ps.fonts)
        if(is.na(fontNumber)) {
          fontNumber <- 1
          cat(paste("\tPSFIG WARNING: Font requested is not available\n",
                    "\t\tSubstituted by Helvetica\n"))
        }
      }
      
      if(under.unix) {
        ## do.call 21Oct99 - problem with lazy eval in unix
        if(trellis)
          do.call('trellis.device',
                  list(device='postscript', file=file,
                       horizontal = FALSE, width = width, height = height,
                       pointsize = pointsize, fonts=ps.fonts[fontNumber],
                       font = 1, maximize=TRUE, onefile=onefile,
                       print.it=FALSE, color=color))
        else
	  postscript(file = file, horizontal = FALSE, width = width, height = height,
                     pointsize = pointsize, fonts=ps.fonts[fontNumber], font = 1, 
                     maximize=TRUE, onefile=onefile, print.it=FALSE)	
        ## was font=fontNumber, fonts omitted - bug
      } else {
        if(trellis)
          do.call('trellis.device',
                  list(device='postscript',
                       file = file, horizontal = FALSE, width = width,
                       height = height,
                       pointsize = pointsize,
                       fonts=ps.fonts[fontNumber],
                       font = 1, color=color))
        else
	  postscript(file = file, horizontal = FALSE, width = width, height = height,
                     pointsize = pointsize, fonts=ps.fonts[fontNumber], font = 1)
      }

                                        
      ##	PLOT DESIGN
      ##	Lines are 1pt wide, which is half standard width
      ##	(LWD is interpreted in units of 1/36 inch
      ##	 LWD=0 yields the thinnest possible line on the device)
      ##	Axis labels closer to axes than default 
      ##	(MGP: margin line for the axis title, axis labels, 
      ##	 and axis line in units of MEX)
      ##	Margin widths narrower than default
      ##	(MAR: bottom, left, top, right)
      if(trellis)
        return(invisible())
    } else {                          # 10Apr01
      if(trellis) do.call('trellis.device',
                          list(device='postscript',
                               file = file, horizontal = FALSE,
                               width = width, height = height,
                               pointsize = pointsize,
                               family=font, color=color, paper='special',
                               bg=if(!color)'white'
                                  else NULL))
      else
        postscript(file = file, horizontal = FALSE, width = width, height = height,
                   pointsize = pointsize, family=font,
                   onefile=onefile, print.it=FALSE, paper='special')	
    }
    
    if(.R.)
      par(lwd=lwd, mgp=c(2.2,.45,0), tcl=-0.4,
          mar=c(3+sublines+.25*(sublines>0),3.5+leftlines,
                1+toplines,1)+.1, bty=bty)
    else
      par(lwd=lwd, mgp=c(2,.4,0),
          mar=c(3+sublines+.25*(sublines>0),3+leftlines,
                1+toplines, 1)+.1, bty=bty)
    ## was mgp=c(2, 0.5, 0) 11Jan01  c(2.5,.6,0) R c(2,.4,0) S+ 27jan03
    ##	SMO is number of rasters that the piecewise linear
    ##	approximation to a curve is allowed to differ from the exact
    ##	position of the curve.
    par(smo = 0)                      #	PLOTTING SYMBOL
    
    ##	PCH  selects plotting characters from Standard Encoding
    ##	(PostScript Language Reference Manual, p.252)
    ##	168 = currency
    ##	180 = centered period
    ##	183 = bullet (with a negative font parameter yields a circle
    par(pch = 1)                      # was 183 11Jan01
    
    ## MAIN TITLE not allowed: plot will be described in figure caption, 
    ##	handled by TeX itself.
    ##	cat(paste("\tPSFIG WARNING:", "Do not use high-level parameter MAIN\n",
    ##		"\t\tFigure caption should be created within LaTeX\n"))	#
    if(length(las))
      par(las=las)
    
    invisible()
  }

  psfig(filename, h=h, w=w, ratio=1.4, 
        pointsize=pointsize,sublines=sublines,toplines=toplines,
        lwd=lwd,font=font,leftlines=leftlines, las=las,
        trellis=trellis, color=color)   # color= 7feb03
          
  if(trellis && setTrellis.)
    setTrellis(strip.blank = strip.blank, 
               lty.dot.line = lty.dot.line, lwd.dot.line = lwd.dot.line)

  topdf <- function(filebase)
  {
    cmd <-
      if(under.unix)'gs'
      else 'gswin32c'
    
    cmd <-
      paste(cmd, ' -q -dNOPAUSE -dBATCH -sDEVICE #pdfwrite -sOutputFile#',
            filebase, '.pdf -c save pop -f ', filebase, '.ps', sep='')
    
    sys(cmd)
    invisible()
  }
  
  formals(topdf) <- list(filebase=filebase)
  storeTemp(topdf)
  invisible()
}


setpdf <- function(filename, w=0, h=4, pointsize=10, sublines=0, toplines=0,
                   type="symbol", lwd=1.5,
                   font=if(.R.)'Helvetica'
                        else 1,
                   ratio= if(.R.) 4/3
                          else (1 + sqrt(5))/2,
                   leftlines=0, las=1, bty='l', hor=FALSE,
                   trellis=!(missing(setTrellis.) & missing(strip.blank) &
                             missing(lty.dot.line) & missing(lwd.dot.line)), 
                   setTrellis.=TRUE, 
                   strip.blank = TRUE, lty.dot.line = 1, lwd.dot.line =1,
                   region=c(0, 0, h, w), color=FALSE, seqno=NULL, ...)
{
  if(type=="char")
    filename <- paste(filename,seqno,".pdf",sep="")
  else
    filename <- paste(substitute(filename),seqno,".pdf",sep="")
  
  if(length(.Options$setpdfPrefix))
    filename <- paste(.Options$setpdfPrefix, filename, sep='')

  if (w > 0 & h == 0)
    h <- w/ratio
  
  if (w == 0 & h > 0)
    w <- h*ratio
  
  if(.R.) {
    if(trellis)
      trellis.device('pdf', file=filename, width=w, height=h,
                     pointsize=pointsize, family=font,
                     color=color,onefile=FALSE,
                     bg=ifelse(color,NULL,'white'))
    else
      pdf(filename, width=w, height=h, pointsize=pointsize,
          family=font,onefile=FALSE)
  } else {
    if(trellis)
      trellis.device('pdf.graph', file=filename,
                     horizontal=hor, width=w, height=h,
                     pointsize=pointsize, font=font,
                     region=region,
                     color=color)
    else
      pdf.graph(filename, horizontal=hor, width=w, height=h,
                pointsize=pointsize, font=font, region=region,
                color=color)
  }

  if(!trellis) {
    if(.R.)
      par(lwd=lwd, mgp=c(2.2,.45,0), tcl=-0.4,
          mar=c(3+sublines+.25*(sublines>0),3.5+leftlines,
                1+toplines,1)+.1, bty=bty)
    else
      par(lwd=lwd, mgp=c(2,.4,0),
          mar=c(3+sublines+.25*(sublines>0),3+leftlines,
                1+toplines, 1)+.1, bty=bty)

    ## was mgp=c(2.5,.6,0) R c(2,.6,0) S+ 27jan03
    par(smo = 0)
  }
  
  if(length(las))
    par(las=las)
  
  if(trellis && setTrellis.)
    setTrellis(strip.blank = strip.blank, 
               lty.dot.line = lty.dot.line, lwd.dot.line = lwd.dot.line)
  invisible()
}


tex  <-  function(string, lref='c', psref='c', scale=1, srt=0) 
  paste('\\tex[',lref,'][',psref,'][',
        format(scale),'][',format(srt),']{',string,'}',sep='')

showPsfrag <- function(filename)
{
  file <- paste(as.character(substitute(filename)),'ps',sep='.')
  out <- "TEMPltx"
  cat('\\documentclass{article}',
      '\\usepackage{graphics}',
      '\\usepackage[scanall]{psfrag}',
      '\\begin{document}',
      paste('\\includegraphics{',file,'}',sep=''),
      '\\end{document}',sep='\n', file=paste(out,'tex',sep='.'))
  sys(paste('latex "\\scrollmode\\input" ',out,';dvips -o ',out,'.ps ',out,
            '; gv ',out,'.ps  &',
            sep=''))
  unlink(paste(out,c('tex','log','dvi','ps','aux','pfg'),sep='.'))
  invisible()
}
pstamp <- if(.R.) function(txt, pwd=FALSE, time.=TRUE)
{
  stamp <- function(string = Sys.time(), print = TRUE, plot = TRUE)
  {
    opar <- par(yaxt='s',xaxt='s',xpd=NA)
    on.exit(par(opar))
    plt <- par('plt')
    usr <- par('usr')

    ## when a logrithmic scale is in use (i.e. par('xlog') is true),
    ## then the x-limits would be 10^par('usr')[1:2].  Similarly for
    ## the y axis
    xcoord <- usr[2] + (usr[2] - usr[1])/(plt[2] - plt[1]) *
      (1-plt[2]) - .6*strwidth('m')
    ycoord <- usr[3] - diff(usr[3:4])/diff(plt[3:4])*(plt[3]) +
      0.6*strheight('m')
      
    if(par('xlog'))
      xcoord <- 10^(xcoord)
    if(par('ylog'))
      ycoord <- 10^(ycoord)

    ## Print the text on the current plot
    text(xcoord, ycoord, string, adj=1)
    invisible(string)
  }

  date.txt <- if(time.) format(Sys.time())
              else format(Sys.time(), '%Y-%m-%d')
  
  if(pwd)
    date.txt <- paste(getwd(), date.txt)

  oldpar <- par(mfrow=c(1,1), cex = 0.5)
  on.exit(par(oldpar))
  if(!missing(txt))
    date.txt <- paste(txt,'   ',date.txt, sep='')
  
  stamp(string=date.txt,print=FALSE,plot=TRUE)
  invisible()

} else function(txt, pwd=FALSE, time.=under.unix)
{

  date.txt <- if(time.) date() else {
    if(.SV4.)
      format(timeDate(date(), in.format='%w %m %d %H:%M:%S %Z %Y',
                      format='%Y-%m-%d'))
    else if(under.unix)
      unix('date +%Y-%m-%d')
    else
      stop('time.=T not supported')
  }
                 
  if(pwd)
    date.txt <- paste(getwd(), date.txt)
  
  oldpar <- par(mfrow = c(1,1), cex = 0.5)
  on.exit(par(oldpar))
  if(!missing(txt))
    date.txt <- paste(txt,'   ',date.txt, sep='')
  
  stamp(string=date.txt,print=FALSE,plot=TRUE)
  par(old)
  invisible()
}  
## Computes rank correlation measures between a variable X and a possibly
## censored variable Y, with event/censoring indicator EVENT
## Rank correlation is extension of Somers' Dxy = 2(Concordance Prob-.5)
## See Harrell et al JAMA 1984(?)
## Set outx=T to exclude ties in X from computations (-> Goodman-Kruskal
##  gamma-type rank correlation)

rcorr.cens <- function(x, S, outx=FALSE)
{
  if(!length(dim(S)))
    S <- cbind(S, rep(1, length(S)))
  
  y <- S[,1]
  event <- S[,2]
  if(length(y)!=length(x))
    stop("y must have same length as x")

  miss <- is.na(x) | is.na(y) | is.na(event)
  nmiss <- sum(miss)
  if(nmiss>0) {
    miss <- !miss
    x <- x[miss]
    y <- y[miss]
    event <- event[miss]
  }
  
  n <- length(x)
  ne <- sum(event)
  storage.mode(x) <- if(.R.) "double"
                     else "single"
  
  storage.mode(y) <- if(.R.) "double"
                     else "single"
  
  storage.mode(event) <- "logical"

  z <-
    if(.R.)
      .Fortran("cidxcn",x,y,event,length(x),nrel=double(1),nconc=double(1),
               nuncert=double(1),
               c.index=double(1),gamma=double(1),sd=double(1),as.logical(outx),
               PACKAGE="Hmisc")
    else
      .Fortran("cidxcn",x,y,event,length(x),nrel=double(1),nconc=double(1),
               nuncert=double(1),
               c.index=double(1),gamma=double(1),sd=double(1),as.logical(outx))
  
  r <- c(z$c.index,z$gamma,z$sd,n,nmiss,ne,z$nrel,z$nconc,z$nuncert)
  names(r) <- c("C Index","Dxy","S.D.","n","missing","uncensored",
                "Relevant Pairs",
                "Concordant","Uncertain")
  r
}
rcorr <- function(x, y, type=c("pearson","spearman"))
{
  type <- match.arg(type)

  if(!missing(y))
    x <- cbind(x, y)
  
  x[is.na(x)] <- 1e30
  storage.mode(x) <- if(.R.)"double"
                     else "single"
  
  p <- as.integer(ncol(x))
  if(p<1)
    stop("must have >1 column")
  
  n <- as.integer(nrow(x))
  if(n<5)
    stop("must have >4 observations")
  
  h <-
    if(.R.)
      .Fortran("rcorr", x, n, p, itype=as.integer(1+(type=="spearman")),
               hmatrix=double(p*p), npair=integer(p*p),
               double(n), double(n),  double(n), double(n),
               double(n), integer(n), PACKAGE="Hmisc")
    else
      .Fortran("rcorr", x, n, p, itype=as.integer(1+(type=="spearman")),
               hmatrix=single(p*p), npair=integer(p*p),
               single(n), single(n),  single(n), single(n),
               single(n), integer(n))
  
  npair <- matrix(h$npair, ncol=p)
  h <- matrix(h$hmatrix, ncol=p)
  h[h>1e29] <- NA
  nam <- dimnames(x)[[2]]
  dimnames(h) <- list(nam, nam)
  dimnames(npair) <- list(nam, nam)
  P <- matrix(2*(1-pt(abs(h)*sqrt(npair-2)/sqrt(1-h*h), npair-2)),ncol=p)
  P[abs(h)==1] <- 0
  diag(P) <- NA
  dimnames(P) <- list(nam,nam)
  structure(list(r=h, n=npair, P=P), class="rcorr")
}


print.rcorr <- function(x, ...)
{
  print(round(x$r,2))
  n <- x$n
  if(all(n==n[1,1]))
    cat("\nn=",n[1,1],"\n\n")
  else {
    cat("\nn\n")
    print(n)
  }
  
  cat("\nP\n")
  P <- x$P
  P <- ifelse(P<.0001,0,P)
  p <- format(round(P,4))
  p[is.na(P)] <- ""
  print(p, quote=FALSE)
  invisible()
}
## Computes rank correlation measures between a variable X and a possibly
## censored Surv variable Y
## Rank correlation is extension of Somers' Dxy = 2(Concordance Prob-.5)
## See Harrell et al JAMA 1984(?)
## Set outx=T to exclude ties in X from computations (-> Goodman-Kruskal
##  gamma-type rank correlation)
## No. This is the version extended to paired predictions
## method=1: concordance=delta x1 < delta x2
## method=2: concordance=x1 concordant and x2 discordant

rcorrp.cens <- function(x1, x2, S, outx=FALSE, method=1)
{
  if(!length(dim(S))) S <- cbind(S, rep(1, length(S)))
  y <- S[,1]
  event <- S[,2]

  if(length(x1)!=length(x2))
    stop("x1 and x3 must have same length")
  
  if(length(y)!=length(x1))
    stop("y must have same length as x")
  
  if(method!=1 & method!=2)
    stop("method must be 1 or 2")

  miss <- is.na(x1+x2+y+event)
  nmiss <- sum(miss)
  if(nmiss>0) {
    miss <- !miss
    x1 <- x1[miss]
    x2 <- x2[miss]
    y <- y[miss]
    event <- event[miss]
  }
  
  n <- length(x1)
  if(n<2)
    stop("<2 non-missing observations")
  
  ne <- sum(event)
  storage.mode(x1) <- if(.R.)"double"
                      else "single"
  
  storage.mode(x2) <- if(.R.)"double"
                      else "single"
  
  storage.mode(y) <- if(.R.)"double"
                     else "single"
  
  storage.mode(event) <- "logical"
  storage.mode(method) <- "integer"
  storage.mode(outx) <- "logical"

  z <-
    if(.R.)
      .Fortran("cidxcp",x1,x2,y,event,length(x1),method,outx,
               nrel=double(1),nuncert=double(1),
               c1=double(1),c2=double(1),gamma1=double(1),gamma2=double(1),
               gamma=double(1),sd=double(1),c12=double(1),c21=double(1),
               PACKAGE="Hmisc")
    else
      .Fortran("cidxcp",x1,x2,y,event,length(x1),method,outx,
               nrel=double(1),nuncert=double(1),
               c1=double(1),c2=double(1),gamma1=double(1),gamma2=double(1),
               gamma=double(1),sd=double(1),c12=double(1),c21=double(1))
  
  r <- c(z$gamma,z$sd,z$c12,z$c21,n,nmiss,ne,z$nrel,z$nuncert,z$c1,z$c2,
         z$gamma1,z$gamma2)
  names(r) <- c("Dxy","S.D.","x1 more concordant","x2 more concordant",
                "n","missing","uncensored",
                "Relevant Pairs","Uncertain","C X1","C X2","Dxy X1","Dxy X2")
  r
}
##rcspline.eval - function to create design matrix for restricted cubic
##	spline function of Stone & Koo, given an input vector and optionally
##	a vector of knots.  If knots are not given, knots are set using
##	default algorithm.  If the number of knots is not given, 5 are used.
##	Terms are normalized by (outer-inner knot)^2.
##	Can optionally return antiderivative of spline functions if
##	type="integral".
##	norm=0 : no normalization of constructed variables
##	norm=1 : divide by cube of difference in last 2 knots
##		 makes all variables unitless
##	norm=2 : (default) divide by square of difference in outer knots
##		 makes all variables in original units of x
##
##	Returns:
##		x - design matrix for derived spline variables
##		(includes original x in first column if inclx=T or 
##		 type="integral")
##		attribute knots - input or derived vector of knots
##	If knots.only=T, returns instead the vector of estimated or given
##	knots.
##	If rpm is not null, replaces missing x with rpm before evaluating
##	but after estimating knots.
##
##	F. Harrell 13 Feb 90
##       Modified   28 Mar 90 - improved default knot computation
##		   22 Aug 90 - put knots as attribute, return matrix
##		   20 Sep 90 - added knots.only argument
##		   16 Oct 90 - added rpm argument
##		   11 Dec 91 - added type argument
##		   27 Dec 91 - added norm argument
##		   26 Jun 93 - added evasive action if <3 knots

rcspline.eval <- function(x,knots=NULL,nk=5,inclx=FALSE,knots.only=FALSE,
                          type="ordinary",norm=2, rpm=NULL)
{
  if(!length(knots)) {
    xx <- x[!is.na(x)]
    n <- length(xx)
    if(n<6)
      stop('fewer than 6 non-missing observations with knots omitted')
    
    if(nk<3)
      stop('nk must be >= 3')
    
    outer <- .1
    if(nk>3)
      outer <- .05
    
    if(nk>6)
      outer <- .025
    
    knots <- quantile(xx,seq(outer,1.0-outer,length=nk))
    if(length(unique(knots))<3) {
      knots <- quantile(xx,seq(outer,1.0-outer,length=2*nk))
      if((nu <- length(unique(knots)))<3) {
        cat("Fewer than 3 unique knots.  Frequency table of variable:\n")
        print(table(xx))
        stop()
      }
      
      warning(paste("could not obtain",nk,"knots with default algorithm.\n",
                    "Used alternate algorithm to obtain",
                    nu,"knots"))

    }
    
    if(n<100) {
      xx <- sort(xx)
      knots[1]<-xx[5]
      knots[nk]<-xx[n-4]
    }
  }
  
  knots <- sort(unique(knots))
  nk <- length(knots)
  if(nk<3) {
    cat("fewer than 3 unique knots.  Frequency table of variable:\n")
    print(table(x))
    stop()
  }

  if(knots.only)
    return(knots)

  ##x <- as.matrix(x)     10Mar01
  ##storage.mode(x) <- "single"
  if(!is.null(rpm))
    x[is.na(x)] <- rpm
  
  xx <- matrix(1.1,length(x),nk-2)  # 10Mar01
  knot1 <- knots[1]
  knotnk <- knots[nk]
  knotnk1 <- knots[nk-1]
  if(norm==0)
    kd <- 1
  else if(norm==1)
    kd <- knotnk-knotnk1
  else
    kd <- (knotnk-knot1)^.66666666666666666666666

  if(type=="integral")
    power <- 4
  else power <- 3

  for(j in 1:(nk-2)) {
    xx[,j]<-pmax((x-knots[j])/kd,0)^power + 
      ((knotnk1-knots[j])*pmax((x-knotnk)/kd,0)^power -
       (knotnk-knots[j])*(pmax((x-knotnk1)/kd,0)^power))/
         (knotnk-knotnk1)
  }

  if(power==4)
    xx <- cbind(x, x*x/2, xx*kd/4)
  else if(inclx)
    xx <- cbind(x, xx)
  
  if(!.R.)
    storage.mode(xx) <- 'single'  # 10Mar01
  
  attr(xx,"knots") <- knots
  xx
}
##Mod rep(1,n)-> rep(1,length(xe)) 1 Jul 91
rcspline.plot <- function(x, y, model=c("logistic","cox","ols"), xrange,
                          event, nk=5, knots=NULL, show=c("xbeta", "prob"),
                          adj=NULL, xlab, ylab, ylim, plim=c(0,1),
                          plotcl=TRUE, showknots=TRUE, add=FALSE, subset,
                          lty=1, noprint=FALSE, m, smooth=FALSE, bass=1,
                          main="auto", statloc)
{
  model <- match.arg(model)
  show <- match.arg(show)
  
  if(!missing(event))
    model<-"cox"
  
  if(model=="cox" & missing(event))
    stop('event must be given for model="cox"')
  
  if(show=="prob" & !missing(adj))
    stop('show="prob" cannot be used with adj')
  
  if(show=="prob" & model!="logistic")
    stop('show="prob" can only be used with model="logistic"')
  
  if(length(x)!=length(y))
    stop('x and y must have the same length')
  
  if(!missing(event) && length(event)!=length(y))
    stop('y and event must have the same length')
  
  if(!missing(adj)) {
    if(!is.matrix(adj)) adj <- as.matrix(adj)
    if(dim(adj)[1]!=length(x))
      stop('x and adj must have the same length')
  }
  
  if(missing(xlab))
    xlab <- label(x)
  
  if(missing(ylab))
    ylab <- label(y)
  
  isna <- is.na(x) | is.na(y) 
  if(!missing(event))
    isna <- isna | is.na(event)
  
  nadj <- 0
  if(!missing(adj)) {
    nadj <- ncol(adj)
    isna <- isna | apply(is.na(adj),1,sum)>0
  }
  
  if(!missing(subset))
    isna <- isna | (!subset)
  
  x <- x[!isna]
  y <- y[!isna]
  if(!missing(event))
    event <- event[!isna]
  
  if(!missing(adj))
    adj <- adj[!isna,]
  
  n <- length(x)
  if(n<6)
    stop('fewer than 6 non-missing observations')
  
  if(missing(xrange)) {
    frac<-10./max(n,200)
    xrange<-quantile(x,c(frac,1.-frac))
  }
  
  if(missing(knots))
    xx <- rcspline.eval(x,nk=nk)
  else xx <- rcspline.eval(x,knots)
  
  knots <- attr(xx,"knots")
  nk <- length(knots)

  df1 <- nk-2
  if(model=="logistic") {
    requirePackage('Design')
    
    b <- lrm.fit(cbind(x,xx,adj),y)
    ##b <- glim(cbind(x,xx,adj),y,rep(1,n),error="binomial",
    ##link="logit")
    ##if(!noprint)glim.print(b)
    beta <- b$coef
    cov <- b$var
    ##model.lr <- b$deviance[1] - b$deviance[2]
    model.lr <- b$stats["Model L.R."]
    offset <- 1 	#to skip over intercept parameter
    ylabl <-
      if(show=="prob")
        "Probability"
      else "log Odds"
    
    sampled <- paste("Logistic Regression Model, n=",n," d=",sum(y),sep="")
  }
  
  if(model=="cox") {
    if(!existsFunction('coxph.fit'))
      coxph.fit <- getFromNamespace('coxph.fit','survival')
    ##11mar04
    
    ## added coxph.control around iter.max, eps  11mar04
    lllin <- coxph.fit(cbind(x,adj),cbind(y,event),strata=NULL,
                       offset=NULL, init=NULL, control=coxph.control(iter.max=10, eps=.0001), 
                       method="efron", rownames=NULL)$loglik[2]
    b <- coxph.fit(cbind(x,xx,adj),cbind(y,event),strata=NULL,
                   offset=NULL, init=NULL, control=coxph.control(iter.max=10, eps=.0001), 
                   method="efron", rownames=NULL)
    beta <- b$coef
    if(!noprint) {
      print(beta);
      print(b$loglik)
    }
    
    beta <- b$coef
    cov <- b$var
    model.lr<-2*(b$loglik[2]-b$loglik[1])
    offset <- 0
    ylabl <- "log Relative Hazard"
    sampled <- paste("Cox Regression Model, n=",n," events=",sum(event),
                     sep="")
  }
  
  if(model=="logistic"|model=="cox") {
    model.df <- nk-1+nadj
    model.aic <- model.lr-2.*model.df
    v <- solve(cov[(1+offset):(nk+offset-1),(1+offset):(nk+offset-1)])
    assoc.chi <- beta[(1+offset):(nk+offset-1)] %*% v %*%
      beta[(1+offset):(nk+offset-1)]
    assoc.df <- nk-1   #attr(v,"rank")
    assoc.p <- 1.-pchisq(assoc.chi,nk-1)
    v <- solve(cov[(2+offset):(nk+offset-1),(2+offset):(nk+offset-1)])
    linear.chi <- beta[(2+offset):(nk+offset-1)] %*% v %*%
      beta[(2+offset):(nk+offset-1)]
    linear.df <- nk-2   #attr(v,"rank")
    linear.p <- 1.-pchisq(linear.chi,linear.df)
    if(nadj>0) {
      ntot <- offset+nk-1+nadj
      v <- solve(cov[(nk+offset):ntot,(nk+offset):ntot])
      adj.chi <- beta[(nk+offset):ntot] %*% v %*%
        beta[(nk+offset):ntot]
      adj.df <- attr(v,"rank")
      adj.p <- 1.-pchisq(adj.chi,adj.df)
    } else {
      adj.chi <- 0
      adj.p <- 0
    }
  }

  ## Evaluate xbeta for expanded x at desired range
  xe <- seq(xrange[1],xrange[2],length=600)
  if(model=="cox")
    xx <- rcspline.eval(xe,knots,inclx=TRUE)
  else
    xx<- cbind(rep(1,length(xe)),rcspline.eval(xe,knots,inclx=TRUE))
  
  xbeta <- xx %*% beta[1:(nk-1+offset)]
  var <- drop(((xx %*% cov[1:(nk-1+offset),1:(nk-1+offset)])*xx) %*% 
              rep(1,ncol(xx)))
  lower <- xbeta-1.96*sqrt(var)
  upper <- xbeta+1.96*sqrt(var)
  if(show=="prob") {
    xbeta <- 1./(1.+exp(-xbeta))
    lower <- 1./(1.+exp(-lower))
    upper <- 1./(1.+exp(-upper))
  }
  
  xlim <- range(pretty(xe))
  if(missing(ylim))
    ylim <- range(pretty(xbeta))
  
  if(main=="auto") {
    if(show=="xbeta")
      main <- "Estimated Spline Transformation"
    else main <- "Spline Estimate of Prob{Y=1}"
  }
  
  if(!interactive() & missing(statloc))
    statloc<-"ll"
  
  if(!add) {
    oldmar<-par("mar")
    if(!missing(statloc) && statloc[1]=="ll")
      oldmar[1]<-11
    
    oldpar <- par(err=-1,mar=oldmar)
    plot(xe,xbeta,type="n",main=main,xlab=xlab,ylab=ylabl,
         xlim=xlim,ylim=ylim)
    lines(xe,xbeta,lty=lty)
    ltext<-function(z,line,label,cex=.8,adj=0)
    {
      zz<-z
      zz$y<-z$y-(line-1)*1.2*cex*par("csi")*(par("usr")[4]-par("usr")[3])/
        (par("fin")[2])   #was 1.85
      text(zz,label,cex=cex,adj=adj)
    }
    
    sl<-0
    if(missing(statloc)) {
      cat("Click left mouse button at upper left corner for statistics\n")
      z<-locator(1)
      statloc<-"l"
    } else if(statloc[1]!="none") {
      if(statloc[1]=="ll") {
        z<-list(x=par("usr")[1],y=par("usr")[3])
        sl<-3
      } else z<-list(x=statloc[1],y=statloc[2])
    }
    
    if(statloc[1]!="none" & (model=="logistic" | model=="cox"))	{
      rnd <- function(x,r=2) as.single(round(x,r))
      
      ltext(z,1+sl,sampled)
      ltext(z,2+sl,"    Statistic        X2  df")
      chistats<-format(as.single(round(c(model.lr,model.aic,
                                         assoc.chi,linear.chi,adj.chi),2)))
      pvals<-format(as.single(round(c(assoc.p,linear.p,adj.p),4)))
      ltext(z,3+sl,paste("Model        L.R. ",chistats[1],model.df,
                         " AIC=",chistats[2]))
      ltext(z,4+sl,paste("Association  Wald ",chistats[3],assoc.df,
                         " p= ",pvals[1]))
      ltext(z,5+sl,paste("Linearity    Wald ",chistats[4],linear.df,
                         " p= ",pvals[2]))
      if(nadj>0)ltext(z,6+sl,paste("Adjustment   Wald " ,chistats[5],
                                   adj.df," p= ",pvals[3]))}
  } else lines(xe,xbeta,lty=lty)
  
  if(plotcl) {
    lines(xe,lower,lty=2)
    lines(xe,upper,lty=2)	
  }

  if(showknots) {
    bot.arrow <- par("usr")[3]
    top.arrow <- bot.arrow+.05*(par("usr")[4]-par("usr")[3])
    for(i in 1:nk)
      if(.R.)
        arrows(knots[i],top.arrow,knots[i],bot.arrow,length=.1)
      else
        arrows(knots[i],top.arrow,knots[i],bot.arrow,rel=TRUE,size=.5)
  }
  
  if(model=="logistic" & nadj==0) {
    if(smooth) {
      z<-supsmu(x,y,bass=bass)
      if(show=="xbeta")
        z$y <- logb(z$y/(1.-z$y))
      
      points(z,cex=.4)
    }
    
    if(!missing(m)) {
      z<-groupn(x,y,m=m)
      if(show=="xbeta")
        z$y <- logb(z$y/(1.-z$y))
      
      points(z,pch=2,mkh=.05)}
  }
  
  if(!add)
    par(oldpar)
  
  invisible(list(knots=knots,x=xe,xbeta=xbeta,lower=lower,upper=upper))
}
rcspline.restate <- function(knots, coef, type=c("ordinary","integral"),
                             x="X", lx=nchar(x),norm=2, 
                             columns=65, before="& &", after="\\", 
                             begin="", nbegin=0,
                             digits=max(8,.Options$digits))
{
  type <- match.arg(type)
  k <- length(knots)
  if(k<3)
    stop("must have >=3 knots in a restricted cubic spline")
  
  p <- length(coef)
  if(p == k) {
    Intc <- coef[1]
    coef <- coef[-1]
    p <- p-1
  } else Intc <- 0
  
  if(k-1 != p)
    stop("coef must be of length # knots - 1")

  knotnk <- knots[k];
  knotnk1 <- knots[k-1];
  knot1 <- knots[1]
  
  if(norm==0)
    kd <- 1
  else if(norm==1)
    kd <- (knotnk-knotnk1)^3
  else
    kd <- (knotnk-knot1)^2
  
  coef[-1] <- coef[-1]/kd

  d <- c(0, knots-knotnk)[1:p]
  coefk <- sum(coef*d)/(knotnk-knotnk1)

  d <- c(0, knots-knotnk1)[1:p]
  coefk1 <- sum(coef*d)/(knotnk1-knotnk)

  if(is.null(names(coef)))
    names(coef) <- paste(x,1:length(coef),sep="")
  
  coef <- c(coef, coefk, coefk1)
  names(coef)[k] <- "1st restricted coef"
  names(coef)[k+1] <- "2nd restricted coef"

  if(type=="integral")
    coef <- c(.5*coef[1],.25*coef[-1])

  cof <- format.sep(coef, digits)
kn <- format.sep(-knots, digits)
  if(Intc!=0) {
    txt <- txt2 <- format.sep(Intc, digits)
    if(type=="integral") {
      txt <- paste(txt, "* x")
      txt2 <- paste(txt2, '*', x)
    }
    
    if(coef[1]>=0) {
      txt <- paste(txt, "+");
      txt2 <- paste(txt2, '+')
    }
  } else txt <- txt2 <- ""

  if(cof[1]!=0) {
    txt <- paste(txt, cof[1],
                 if(type=="ordinary")"* x"
                 else "* x^2",
                 sep="")
    
    txt2 <- paste(txt2, cof[1],
                  if(type=="ordinary") paste("*",x)
                  else paste("*",x,"^2"),
                  sep="")
  }
  
  for(i in 2:(p+2)) {
    nam <- paste("pmax(x",
                 if(knots[i-1]<0) "+"
                 else NULL, 
                 if(knots[i-1]!=0) kn[i-1]
                 else NULL,
                 ",0)^",
                 if(type=="ordinary")"3"
                 else "4",
                 sep="")
    
    nam2 <- paste("pmax(",x,
                  if(knots[i-1]<0) "+"
                  else NULL,
                  if(knots[i-1]!=0) kn[i-1]
                  else NULL,
                  ",0)^",
                  if(type=="ordinary")"3"
                  else "4",
                  sep="")
    
    z <- paste(if(coef[i]>0 & (i>2 | coef[1]!=0 | Intc!=0)) "+"
               else NULL,
               cof[i], "*", nam, sep="")
    
    z2 <- paste(if(coef[i]>0 & (i>2 | coef[1]!=0 | Intc!=0)) "+"
                else NULL,
		cof[i], "*", nam2, sep="")
    
    txt <- paste(txt , z,  sep="")
    txt2<- paste(txt2, z2, sep="")
  }

  ## func <- function(x) NULL
  ## func[[2]] <- parse(text=txt)[[1]]
  func <- parse(text=paste('function(x)', txt))  ## 11Apr02

  cof <- format.sep(coef, digits)
  kn <- format.sep(-knots, digits)

  lcof <- nchar(cof)
  ##cof <- sys('sed -e "s/e+00//" -e "s/e-0\\(.\\)/\\\\!\\\\times\\\\!10^{-\\1}/" 
  ##-e "s/e-\\(..\\)/\\\\!\\\\times\\\\!10^{-\\1}/" 
  ##-e "s/e+0\\(.\\)/\\\\!\\\\times\\\\!10^{\\1}/" 
  ##-e "s/e+\\(..\\)/\\\\!\\\\times\\\\!10^{\\1}/"', cof)
  cof <- sedit(cof, c('e+00','e-0*',                'e-*',
                      'e+0*',               'e+*'),
               c('',    '\\\\!\\times\\\\!10^{-*}','\\\\!\\times\\\\!10^{-*}',
                 '\\\\!\\times\\\\!10^{*}','\\\\!\\times\\\\!10^{*}'))
  
  cur <- begin; colcnt <- nbegin; tex <- NULL
  if(Intc!=0) {
    fint <- format.sep(Intc, digits)
    if(type=="integral") {
      fint <- paste(fint, x);
      colcnt <- colcnt+2
    }
    
    cur <- paste(cur, fint, sep="")
    colcnt <- colcnt + nchar(fint)
    if(coef[1]>0) {
      cur <- paste(cur, " + ", sep="");
      colcnt <- colcnt+3
    }
  }
  
  if(coef[1]!=0) {
    ##   sp <- if(length(grep("times",cof[1]))==0) "\\:" else NULL
    sp <- if(substring.location(cof[1],"times")$first > 0) "\\:"
          else NULL
    
    cur <- paste(cur, cof[1], sp, x,
                 if(type=="integral") "^2",
                 sep="")
    
    ##\:=medium space in LaTeX
    colcnt <- colcnt+lcof[1]+lx+(type=="integral")
  }

  tex.names <- character(p+2)
  size <- lx+lcof[-1]+nchar(kn)+3

  for(i in 2:(p+2)) {
    nam <- paste("(", x,
                 if(knots[i-1]<0) "+"
                 else NULL,
                 if(knots[i-1]!=0) kn[i-1]
                 else NULL, 
                 ")_{+}^{",
                 if(type=="ordinary")"3}"
                 else "4}",
                 sep="")
    
    q <- paste(if(coef[i]>0 & (i>2 | coef[1]!=0 | Intc!=0)) "+"
               else NULL,
               cof[i], nam, sep="")
    
    n <- size[i-1]
    if(colcnt+n > columns) {
      tex <- c(tex, cur)
      cur <- ""
      colcnt <- 0
    }
    
    cur <- paste(cur, q, sep="")
    colcnt <- colcnt+n
  }

  tex <- c(tex, cur)
  tex <- paste(before, tex, after)

  if(Intc!=0) coef <- c(Intercept=Intc, coef)

  attr(coef, "knots") <- knots
  attr(coef, "function") <- func
  attr(coef, "function.text") <- txt2
  ##attr(tex, "class")  <- "TeX"
  attr(coef, "latex")   <- tex
  names(colcnt) <- NULL
  attr(coef, "columns.used") <- colcnt
  
  coef
}

rcsplineFunction <- function(knots, coef=numeric(0), norm=2) {
  k <- length(knots)
  kd <- if(norm==0) 1 else if(norm==1) knots[k]-knots[k-1] else
    (knots[k]-knots[1])^.66666666666666666666666
  
  f <- function(x, knots, coef, kd) {
    k       <- length(knots)
    knotnk  <- knots[k]
    knotnk1 <- knots[k-1]
    knot1   <- knots[1]
    if(length(coef) < k) coef <- c(0, coef)
    y <- coef[1] + coef[2]*x
    for(j in 1:(k-2))
      y <- y + coef[j+2]*(pmax((x - knots[j])/kd, 0)^3 +
        ((knotnk1 - knots[j]) * pmax((x - knotnk)/kd, 0)^3 -
         (knotnk -  knots[j]) * (pmax((x - knotnk1)/kd, 0)^3))/
           (knotnk -  knotnk1))
    y
  }
  formals(f) <- list(x=numeric(0), knots=knots, coef=coef, kd=kd)
  f
}
reShape <- function(x, ..., id, colvar, base, reps,
                    times=1:reps, timevar='seqno', constant=NULL)
{
  if(!missing(base)) {
    if(!is.list(x))
      stop('x must be a list or data frame when base is given')
    
    repvars <- as.vector(outer(base,1:reps,paste,sep=''))
    nam <- names(x)
    nonrep <- nam[nam %nin% repvars]
    res <- vector('list', 1+length(nonrep)+length(base))
    names(res) <- c(timevar, nonrep, base)
    x1 <- x[[1]]
    n <- if(is.matrix(x1)) nrow(x1)
         else length(x1)
    
    res[[1]] <- rep(times[1:reps], n)

    for(i in nonrep) res[[i]] <- rep(x[[i]], rep(reps,n))

    ## Get indexes that will put unlist() in right order
    k <- as.vector(matrix(1:(reps*n), nrow=reps, byrow=TRUE))
    for(i in base) {
      bn <- paste(i, 1:reps, sep='')
      x1 <- x[[bn[1]]]
      at <- attributes(x1)
      at$names <- NULL
      x1 <- unlist(x[bn])[k]
      if(length(at)) attributes(x1) <- at
      res[[i]] <- x1
    }
    
    if(is.data.frame(x)) {
      rn <- attr(x,'row.names')
      ln <- length(rn)
      if(ln) {
        ## R calls data.frame even if specify structure, and R does
        ## not have dup.row.names argument to data.frame as does S+
        if(.R.)
          return(data.frame(res,
                            row.names=paste(rep(rn,rep(reps,ln)),
                                            rep(1:reps,n))))
        else
          return(structure(res, class='data.frame',
                           row.names=rep(rn,rep(reps,ln))))
      }
    }
    
    return(res)
  }
    
  if(is.matrix(x)) {
    y <- as.vector(x)
    v1 <- all.is.numeric(dimnames(x)[[1]][row(x)],'vector')
    v2 <- all.is.numeric(dimnames(x)[[2]][col(x)],'vector')
    w <- list(v1, v2, y)
    names(w) <- c('rowvar','colvar',as.character(substitute(x)))
    if(length(nd <- names(dimnames(x))))
      names(w)[1:2] <- nd
    
    w
  } else {
    listid <- is.list(id)
    i <- as.factor(if(listid) do.call('paste', c(id, sep='~'))
                   else id)
    
    colvar <- as.factor(colvar)
    m <- matrix(NA, nrow=length(levels(i)), ncol=length(levels(colvar)),
                dimnames=list(levels(i), levels(colvar)))
    dotlist <- list(...)
    if(!length(dotlist)) {
      m[cbind(i, colvar)] <- x
      if(listid) {
        j <- match(as.character(dimnames(m)[[1]]), as.character(i))
        if(length(constant))
          data.frame(id[j,,drop=FALSE], constant[j,,drop=FALSE], m)
        else data.frame(id[j,,drop=FALSE], m)
      } else m
      
    } else {
      res <- vector('list',nx <- 1+length(dotlist))
      names(res) <- (as.character(sys.call())[-1])[1:nx]
      nam2 <- names(sys.call()[-1])[1:nx]
      if(length(nam2))
        names(res) <- ifelse(nam2=='',names(res),nam2)
      
      w <- m;
      w[cbind(i, colvar)] <- x;
      res[[1]] <- w
      
      for(j in 2:nx) {
        w <- m;
        w[cbind(i, colvar)] <- dotlist[[j-1]]
        res[[j]] <- w
      }
      
      res
    }
  }
}
recode <- function(..., ret=c('numeric','factor'),
                   none=if(ret=='numeric')0 else 'none',na)
{
  ret <- match.arg(ret)
  w <- list(...)

  ## alternative form: recode(x, from, to), e.g. recode(x, c(1,3), c(0,1))
  if(!is.logical(w[[1]]) && length(w)==3) {
    z <- w[[3]][match(w[[1]],w[[2]])]
    if(!missing(none))
      z[if(is.numeric(none))is.na(z)
        else z==''] <- none
    
    return(z)
  }

  nam <- names(w)
  ##.Options$warn <- -1   6Aug00
  ##numnam <- as.numeric(nam)
  ##if(missing(ret)) ret <- if(any(is.na(numnam))) 'factor' else 'numeric'
  if(missing(ret))
    ret <- if(all.is.numeric(nam))'numeric'
           else 'factor'

  result <- rep(none, length(w[[1]]))

  for(i in 1:length(w))
    result[w[[i]]] <- if(ret=='numeric') numnam[i]
                      else nam[i]

  if(ret=='factor')
    result <- as.factor(result)
  
  if(!missing(na))
    result[is.na(na)] <- NA
  
  result
}
redun <- function(formula, data=NULL, subset=NULL,
                  r2=.9, type=c('ordinary','adjusted'),
                  nk=3, tlinear=TRUE, allcat=FALSE, minfreq=0, pr=FALSE, ...)
{
  acall   <- match.call()
  type    <- match.arg(type)

  if(!inherits(formula,'formula'))
    stop('formula must be a formula')

  a <- as.character(formula)
  if(length(a)==2 && a[1]=='~' && a[2]=='.' &&
     length(list(...))) data <- dataframeReduce(data, ...)

  Terms <- terms(formula, specials='I', data=data)
  m <- list(formula=formula, data=data, subset=subset, na.action=na.delete)
  data <- do.call('model.frame', m)
  nam <- names(data)
  linear <- nam[attr(Terms,'specials')$I]
  p <- length(data)
  n <- nrow(data)
  at <- attributes(data)
  na.action <- at$na.action
  if(pr) cat(n, 'observations used in analysis\n')

  cat.levels <- vector('list',p)
  names(cat.levels) <- nam
  vtype <- rep('s', p); names(vtype) <- nam
  enough <- rep(TRUE, p)

  for(i in 1:p)
    {
      xi  <- data[[i]]
      ni  <- nam[i]

      iscat <- FALSE
      if(is.character(xi))
        {
          xi    <- as.factor(xi)
          lev   <- levels(xi)
          iscat <- TRUE
        }
      else if(is.category(xi))
        {
          lev   <- levels(xi)
          iscat <- TRUE
        }
      if(iscat)
        {
          data[[i]] <- as.integer(xi)
          cat.levels[[ni]] <- lev
          vtype[ni] <- 'c'
          if(minfreq > 0 && sum(table(xi) >= minfreq) < 2) enough[i] <- FALSE
        }
      else
        {
          u <- unique(xi)
          if(length(u) == 1)
            {
              warning(paste(ni,'is constant'))
              enough[i] <- FALSE
            }
          if(minfreq > 0 && length(u)==2 && sum(table(xi) >= minfreq) < 2)
            enough[i] <- FALSE
          if(nk==0 || length(u) < 3 || ni %in% linear)
            vtype[ni] <- 'l'
        }
  }

  toofew <- nam[!enough]
  if(length(toofew))
    {
      p <- sum(enough)
      nam <- nam[enough]
      cat.levels <- cat.levels[enough]
      vtype <- vtype[enough]
      data  <- data[enough]
    }

  xdf <- ifelse(vtype=='l', 1, nk-1)
  j <- vtype=='c'
  if(any(j)) for(i in which(j)) xdf[i] <- length(cat.levels[[i]]) - 1
  names(xdf) <- nam

  orig.df <- sum(xdf)
  X <- matrix(NA, nrow=n, ncol=orig.df)
  st <- en <- integer(p)
  start <- 1
  for(i in 1:p)
    {
      xi <- data[[i]]
      x <- aregTran(xi, vtype[i], nk)
      st[i] <- start
      nc    <- ncol(x)
      xdf[i]<- nc
      end   <- start + nc - 1
      en[i] <- end
      if(end > orig.df) stop('program logic error')
      X[,start:end] <- x
      start <- end + 1
    }

  nc <- ncol(X)
  if(nc < orig.df) X <- X[, 1:nc, drop=FALSE]
  ## if couldn't derive the requested number of knots in splines
  
  fcan <- function(ix, iy, X, st, en, vtype, tlinear, type,
                   allcat, r2, minfreq)
    {
      ## Get all subscripts for variables in the right hand side
      k <- rep(FALSE, ncol(X))
      for(i in ix) k[st[i]:en[i]] <- TRUE
      ytype <- if(tlinear && vtype[iy]=='s')'l' else vtype[iy]
      Y <- if(ytype=='l') X[,st[iy],drop=FALSE] else
       X[,st[iy]:en[iy],drop=FALSE]
      d <- dim(Y); n <- d[1]; ny <- d[2]
      f <- cancor(X[,k,drop=FALSE], Y)
      R2 <- f$cor[1]^2
      if(type=='adjusted')
        {
          dof <- sum(k) + ny - 1
          R2 <- max(0, 1 - (1 - r2)*(n-1)/dof)
        }
    ## If variable to possibly remove is categorical with more than 2
    ## categories (more than one dummy variable) make sure ALL frequent
    ## categories are redundant (not just the linear combination of
    ## dummies) if allcat is TRUE.  Do this by substituting for R^2 the
    ## minimum R^2 over predicting each dummy variable.
    if(R2 > r2 && allcat && ytype=='c' && (en[iy] > st[iy]))
      {
        for(j in st[iy]:en[iy])
          {
            y <- X[,j,drop=FALSE]
            if(sum(y) >= minfreq && n-sum(y) >= minfreq)
              {
                f <- cancor(X[,k,drop=FALSE], y)
                R2c <- f$cor[1]^2
                if(type=='adjusted')
                  {
                    dof <- sum(k)
                    R2c <- max(0, 1 - (1 - R2c)*(n-1)/dof)
                  }
                R2 <- min(R2, R2c, na.rm=TRUE)
              }
          }
      }
      R2
    }

  In <- 1:p; Out <- integer(0)
  r2r <- numeric(0)
  r2l <- list()

  for(i in 1:p) {
    if(pr) cat('Step',i,'of a maximum of', p, '\r')
    ## For each variable currently on the right hand side ("In")
    ## find out how well it can be predicted from all the other "In" variables
    if(length(In) < 2) break
    Rsq <- In*0
    l <- 0
    for(j in In)
      {
        l <- l + 1
        k <- setdiff(In, j)
        Rsq[l] <- fcan(k, j, X, st, en, vtype, tlinear, type,
                       allcat, r2, minfreq)
      }
    if(i==1) {Rsq1 <- Rsq; names(Rsq1) <- nam[In]}
    if(max(Rsq) < r2) break
    removed   <- In[which.max(Rsq)]
    r2removed <- max(Rsq)
    ## Check that all variables already removed can be predicted
    ## adequately if new variable 'removed' is removed
    k <- setdiff(In, removed)
    r2later <- NULL
    if(length(Out))
      {
        r2later <- Out*0
        names(r2later) <- nam[Out]
        l <- 0
        for(j in Out)
          {
            l <- l+1
            r2later[l] <-
              fcan(k, j, X, st, en, vtype, tlinear, type, allcat, r2, minfreq)
          }
        if(min(r2later) < r2) break
      }
    Out <- c(Out, removed)
    In  <- setdiff(In, Out)
    r2r <- c(r2r, r2removed)
    if(length(r2later)) r2l[[i]] <- r2later
  }
  if(length(r2r)) names(r2r) <- nam[Out]
  if(length(r2l)) names(r2l) <- nam[Out]
  if(pr) cat('\n')
  
  structure(list(call=acall, formula=formula,
                 In=nam[In], Out=nam[Out], toofew=toofew,
                 rsquared=r2r, r2later=r2l, rsq1=Rsq1,
                 n=n, p=p, na.action=na.action,
                 vtype=vtype, tlinear=tlinear,
                 allcat=allcat, minfreq=minfreq, nk=nk, df=xdf,
                 cat.levels=cat.levels,
                 r2=r2, type=type),
            class='redun')
}

print.redun <- function(x, digits=3, long=TRUE, ...)
{
  cat("\nRedundancy Analysis\n\n")
  dput(x$call)
  cat("\n")
  cat('n:',x$n,'\tp:',x$p, '\tnk:',x$nk,'\n')
  cat('\nNumber of NAs:\t', length(x$na.action$omit), '\n')
  a <- x$na.action
  if(length(a)) naprint(a)
  
  if(x$tlinear)
    cat('\nTransformation of target variables forced to be linear\n')
  if(x$allcat)
    cat('\nAll levels of a categorical variable had to be redundant before the\nvariable was declared redundant\n')
  if(x$minfreq > 0)
    cat('\nMinimum category frequency required for retention of a binary or\ncategorical variable:', x$minfreq, '\n')
  if(length(x$toofew))
    {
      cat('\nBinary or categorical variables removed because of inadequate frequencies:\n\n')
      cat(x$toofew, '\n')
    }
  cat('\nR-squared cutoff:', x$r2, '\tType:', x$type,'\n')
  if(long)
    {
      cat('\nR^2 with which each variable can be predicted from all other variables:\n\n')
      print(round(x$rsq1, digits))
      if(x$allcat)
        cat('\n(For categorical variables the minimum R^2 for any sufficiently\nfrequent dummy variable is displayed)\n\n')
    }
  if(!length(x$Out))
    {
      cat('\nNo redundant variables\n\n')
      return(invisible())
    }
  cat('\nRendundant variables:\n\n')
  cat(x$Out)
  cat('\n\nPredicted from variables:\n\n')
  cat(x$In, '\n\n')
  w <- x$r2later
  vardel <- names(x$rsquared)
  if(!long)
    {
      print(data.frame('Variable Deleted'=vardel,
                       'R^2'=round(x$rsquared,digits),
                       row.names=NULL, check.names=FALSE))
      return(invisible())
    }
  later  <- rep('', length(vardel))
  i <- 0
  for(v in vardel)
    {
      i <- i + 1
      for(z in w)
        {
          if(length(z) && v %in% names(z))
            later[i] <- paste(later[i], round(z[v], digits), sep=' ')
        }
    }
  print(data.frame('Variable Deleted'=vardel,
                   'R^2'=round(x$rsquared,digits),
                   'R^2 after later deletions'=later,
                   row.names=NULL,
                   check.names=FALSE))
  invisible()
}

escapeBS <- function(string) {
  gsub('\\\\', '\\\\\\\\\\', string)
}

escapeRegex <- function(string) {
  gsub('([.|()\\^{}+$*?]|\\[|\\])', '\\\\\\1', string)
}
requirePackage <- function(package, character.only = FALSE, ...) {
  if (!character.only) {
    package <- as.character(substitute(package))
  }
  
  if(!require(package, character.only = TRUE, ...)) {
    stop('This function requires the', package,
         'package which does not exist on this machine')
  }
}
rm.boot <- function(time, y, id=seq(along=time), subset=TRUE,
                    plot.individual=FALSE,
                    bootstrap.type=c('x fixed','x random'),
                    nk=6, knots, B=500, smoother=supsmu, 
                    xlab, xlim, ylim=range(y), 
                    times=seq(min(time),max(time),length=100),
                    absorb.subject.effects=FALSE, rho=0,
                    cor.pattern=c('independent','estimate'), ncor=10000,
                    ...)
{
  bootstrap.type <- match.arg(bootstrap.type)
  absorb.subject.effects <- absorb.subject.effects & !missing(id)
  if(!is.function(cor.pattern))
    cor.pattern <- match.arg(cor.pattern)
  
  if(!(is.character(cor.pattern) && cor.pattern=='independent') && 
     rho!=0)
    stop("can't specify both cor.pattern='estimate' and rho")
  
  if(rho != 0)
    cor.pattern <- 'equal correlation'
  
  dodep <- rho !=0 || !is.character(cor.pattern) || cor.pattern=='estimate'

  ## X fixed also implies that subjects are fixed

  id <- as.character(id)
  ylab <- label(y)
  if(ylab=='')
    ylab <- 'y'
  
  if(missing(xlab)) {
    xlab <- units(time)
    if(xlab=='')
      xlab <- 'Time'
  }

  if(length(subset) > 1) {
    id <- id[subset];
    time <- time[subset]; y <- y[subset]
  }

  s <- is.na(time + y)
  if(any(s)) {
    s <- !s
    id <- id[s]
    time <- time[s]
    y <- y[s]
  }
  ## Need to order data so that a subject's records stay together
  ## Otherwise, the mean residuals at each time will not vary over resamples
  ## when bootstrap.type='x fixed'

  s <- order(id, time)
  id <- id[s];
  time <- time[s];
  y <- y[s]

  if(bootstrap.type=='x fixed' && diff(range(table(id))) != 0) 
    warning('To work properly with bootstrap.type="x fixed" all subjects must have the same # observations')

  n <- length(y)

  clusters <- unique(id)

  if(plot.individual) {
    ploti <- function(time, y, id, clusters, xlim, ylim, xlab, ylab, 
                      smoother, ...)
    {
      plot(0,0,xlim=range(pretty(range(time))),ylim=ylim,
           xlab=xlab, ylab=ylab, type='n')
      j <- 0
      for(i in clusters) {
        s <- id==i
        j <- j+1
        lines(smoother(time[s],y[s],...),lty=j)
      }
    }
    
    ploti(time, y, id, clusters, xlim, ylim, xlab, ylab, smoother, ...)
  }

  if(nk==0) knots <- double(0)
  if(missing(knots) && nk>0) {
    knots <- rcspline.eval(time,nk=nk,knots.only=TRUE)
    if(length(knots) != nk) {
      warning('could not obtain requested number of knots')
      nk <- length(knots) 
    }
  } else nk <- length(knots)
  
  p <- if(nk==0) 1
       else nk-1

  X.times <- if(nk==0) as.matrix(times)
             else rcspline.eval(times, knots, inclx=TRUE)

  X.Time <- if(nk==0) as.matrix(time)
            else rcspline.eval(time, knots, inclx=TRUE)
  
  X <- if(missing(id)) cbind(X.Time,1)
       else 
         model.matrix(~ X.Time+id-1,
                      data=list(X.Time=X.Time,id=as.factor(id)))
  
  ## was id=id 3Apr02   Thanks: Don MacQueen, for R

  f <- lm.fit.qr.bare(X, y, intercept=FALSE)
  res <- f$residuals
  sigma2 <- sum(res^2)/n

  if(absorb.subject.effects) {
    mean.intercept <- mean(c(0,f$coef[-(1:p)]))
    y <- y + mean.intercept - (f$coef[-(1:p)])[paste('id',id,sep='')]
    if(plot.individual) {
      ploti(time, y, id, clusters, xlim, ylim, xlab, ylab, smoother, ...)
      title('Raw Data Adjusted to Have a Common Intercept')
    }
  }

  if(is.character(cor.pattern) && cor.pattern=='estimate') {
    timediff <- product <- single(ncor)
    used <- 0
    i <- 0
    meanres <- tapply(res, time, mean)
    sdres   <- sqrt(tapply(res, time, var))
    if(any(is.na(sdres)))
      stop('one or more times occur in only one subject')

    for(wid in clusters) {
      s <- id==wid
      x <- time[s]
      cx <- as.character(x)
      r <- (res[s] - meanres[cx])/sdres[cx]
      if(any(is.na(r)))
        stop('program logic error')
      
      diffs <- outer(x, x, FUN=function(a,b)abs(a-b))
      prods <- outer(r, r, FUN='*')
      np <- length(prods)
      if(used + np > ncor) {
        cat('\nUsed only',i,'subjects in estimating covariance pattern.\nMay want to increase ncor.\n')
        break
      }
      
      i <- i+1
      timediff[(used+1):(used+np)] <- diffs
      product[(used+1):(used+np)]  <- prods
      used <- used+np
    }
    
    timediff <- timediff[1:used]; product <- product[1:used]
    product <- tapply(product, round(timediff,4), mean)
    timediff <- as.numeric(names(product))
    product[timediff==0] <- 1
    plot(timediff, product, xlab='Absolute Difference in Time',
	 ylab='Correlation', type='b')

    cor.pattern <- list(x=timediff, y=product)
  }

  ##Subject effects are at the end, using cell means model
  ##Take intercept as average of all subject effects
  cof <- function(fit,p)
  {
    ko <- fit$coef
    c(mean(ko[-(1:p)]), ko[1:p])
  }

  o.coef   <- cof(f,p)

  if(bootstrap.type=='x random') {
    orig.obsno <- split(1:n, id)
  } else {
    R    <- split(res, id)
    yhat <- if(!absorb.subject.effects) f$fitted.values
            else o.coef[1] + X.Time %*% o.coef[-1]
  }

  Coef <- matrix(NA, B+1, p+1)
  sse  <- loglik <- single(B+1)
  loglik.dep <- NULL

  Coef[1,]  <- o.coef
  sse[1]    <- sigma2*n
  loglik[1] <- n*logb(2*pi*sigma2) + n

  if(dodep) {
    loglik.dep <- loglik
    lldep <- function(time, id, sigma2, res, rho, cor.pattern)
    {
      ll <- 0
      for(subj in unique(id)) {
        s  <- id==subj
        x  <- time[s]
        y  <- res[s]
        p  <- sum(s)
        if(is.character(cor.pattern) && cor.pattern=='equal correlation')
          cov <- sigma2*(diag(rep(1-rho,p))+rho)
        else {
          cov <- if(is.function(cor.pattern)) 
                   outer(x, x, cor.pattern)*sigma2
                 else {
                   timediff <- outer(x, x, function(a,b)abs(a-b))
                   matrix(approx(cor.pattern, xout=timediff)$y, nrow=p)*sigma2
                 }
        }
        
        ## Following code taken from dmvnorm()
        eS <- eigen(cov, sym = TRUE)
	##  y <- y %*% (eS$vectors * rep(1/sqrt(eS$values), each = p)) 24Feb02
        y <- y %*% (eS$vectors * rep(1/sqrt(eS$values),
                                     rep(p,length(eS$values))))
        logl <- sum(y^2) + p*logb(2*pi) + logb(prod(eS$values))
        ll <- ll + logl
      }
      
      ll
    }
    
    loglik.dep[1] <- lldep(time, id, sigma2, res, rho, cor.pattern)
  }

  uneven    <- 0

  for(i in 1:B) {
    if(i %% 10 ==0)
      cat(i,'')
    
    pts <- sample(clusters, rep=TRUE)

    if(bootstrap.type=='x random') {
      obsn <- unlist(orig.obsno[pts])
      idb <- id[obsn]

      xt <- X.Time[obsn,,drop=FALSE]
      f.b <- lm.fit.qr.bare(if(absorb.subject.effects || missing(id)) 
                              cbind(xt,1)
                            else 
                              model.matrix(~xt+idb-1,
                                           data=list(xt=xt,idb=as.factor(idb))),
                            y[obsn], intercept=FALSE)
      
      ## was idb=idb 3Apr02
    } else {
      rr <- unlist(R[pts])
      lrr <- length(rr)
      uneven <- max(uneven, abs(lrr-n))
      if(lrr > n)
        rr <- rr[1:n]
      else if(lrr < n)
        rr <- c(rr, sample(rr, n-lrr, rep=TRUE))
      
      yb.e <- yhat + rr
      f.b <- if(absorb.subject.effects) 
               lm.fit.qr.bare(cbind(X.Time,1), yb.e,
                              intercept=FALSE)
             else
               lm.fit.qr.bare(X, yb.e, intercept=FALSE)
    }

    cofb <- cof(f.b, p)   #26Jun97

    pred <-
      if(bootstrap.type=='x fixed') {
        if(!absorb.subject.effects)
          X %*% f.b$coefficients
        else
          cofb[1] + X.Time %*% cofb[-1]
        
      } else cofb[1] + X.Time %*% cofb[-1]
    
    ## x random case may only work properly if absorb.subject.effects, as
    ## we have to ignore the original subject ids anyway (the bootstrap
    ## sample in general won't represent all subjects)
    Coef[i+1,]  <- cofb    #26Jun97
    sse[i+1]    <- sum((y-pred)^2)
    sigma2      <- sum(f.b$residuals^2)/length(f.b$residuals)
    loglik[i+1] <-  n*logb(2*pi*sigma2) + sse[i+1]/sigma2
    if(dodep)
      loglik.dep[i+1] <- lldep(time, id, sigma2, y-pred,
                               rho, cor.pattern)
  }
  
  if(uneven>0)
    warning(paste('Subjects had unequal number of records.\nMaximum discrepency between ',
                  'total number of bootstrap records sampled and original\nnumber of ',
                  'records (',n,') is ',uneven,'. Bootstrap estimates are approximate.',
                  sep=''))

  if(dodep) {
    srho <- spearman(loglik, loglik.dep)
    cat('\n\nSpearman rank correlation between',B+1,'log likelihoods ',
        'assuming independence and assuming dependence:',
        round(srho,3),'\n')
  }

  mode(Coef) <- 'single'
  mode(sse)  <- 'single'
  structure(list(Coef=Coef, sse=sse, loglik=loglik, loglik.dep=loglik.dep,
                 times=times, X.times=X.times,
                 xlab=xlab, ylab=ylab, ylim=ylim, 
                 bootstrap.type=bootstrap.type, fit=f, knots=knots, 
                 rho=rho, cor.pattern=cor.pattern), 
            class='rm.boot')
}


plot.rm.boot <-
  function(x, obj2, conf.int=.95,
           xlab=x$xlab, ylab=x$ylab, xlim, ylim=x$ylim,
           individual.boot=FALSE,
           pointwise.band=FALSE,
           curves.in.simultaneous.band=FALSE,
           col.pointwise.band=2,
           objective=c('-2 log L','sse','dep -2 log L'), 
           add=FALSE, ncurves,
           multi=FALSE, multi.method=c('color','density'),
           multi.conf=c(.05,.1,.2,.3,.4,.5,.6,.7,.8,.9,.95,.99),
           multi.density=c(-1,90,80,70,60,50,40,30,20,10, 7,4),
           multi.col =c( 1, 8,20, 5, 2, 7,15,13,10,11,9,14),
           subtitles=TRUE, ...)
{
  ##	2 was between 5 and 7, 17 was between 8 and 20

  obj <- x
  objective <- match.arg(objective)
  if(missing(objective))
    objective <- 
      if(obj$rho==0 && is.character(obj$cor.pattern))
        '-2 log L'
      else 'dep -2 log L'

  sse <- switch(objective, 
                sse            = obj$sse,
                '-2 log L'     = obj$loglik,
                'dep -2 log L' = obj$loglik.dep)

  B     <- length(sse)
  Coef  <- obj$Coef
  times <- obj$times

  if(!missing(obj2)) {
    if((length(times) != length(obj2$times)) || 
       (any(times != obj2$times, na.rm=TRUE)))
      stop('times vector must be identical for both rm.boot objects')
    
    times <- ifelse(is.na(times), NA, obj2$times)
    sse <- sse + obj2$sse
    if(missing(ylab))
      ylab <- paste(obj$ylab,'-',obj2$ylab) 
  }

  ## order from best -2 log likelihood or sum of squared errors to worst
  i <- order(sse)
  ## Select best confidence coefficient*B estimates
  conf <- if(multi) max(multi.conf)
          else conf.int
  
  i <- i[1:round(conf*B)]
  if(i[1] != 1)
    warning(past('design is imbalanced enough that best log likelihood or SSE was not\n',
                 'obtained from overall fit (objective=',format(sse[1]),') but from\n',
                 'a bootstrap fit (objective=',format(sse[i[1]]),
                 ')\nThis can also happen if the objective is not -2 log L',sep=''))

  ## Evaluate all fits on time grid and compute point by point max and min

  curves <- cbind(1,obj$X.times) %*% t(Coef)
  if(!missing(obj2)) {
    curves <- curves - cbind(1,obj2$X.times) %*% t(obj2$Coef)
    if(missing(ylim))
      ylim <- range(curves[,i])
  }			
  
  if(multi) {
    multi.method <- match.arg(multi.method)
    if(missing(xlim))
      plot(times, curves[,1], type='n',
           xlab=xlab, ylab=ylab, ylim=ylim)
    else
      plot(times, curves[,1], type='n',
	   xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim)
    
    title(paste('Simultaneous',min(multi.conf),'-',max(multi.conf),
		'Confidence Regions'))
    high.prev <- low.prev <- curves[,1]
    for(j in 1:length(multi.conf)) {
      ii <- i[1:round(multi.conf[j]*B)]
      high <- apply(curves[,ii], 1, max)
      low  <- apply(curves[,ii], 1, min)
      if(multi.method=='density') {
	polygon(c(times,rev(times)), c(high.prev,rev(high)), 
                density=multi.density[j])
	polygon(c(times,rev(times)), c(low.prev, rev(low)),  
                density=multi.density[j])
      } else {
	polygon(c(times,rev(times)), c(high.prev,rev(high)), 
                col=multi.col[j])
	polygon(c(times,rev(times)), c(low.prev, rev(low)),  
                col=multi.col[j])
      }
      
      high.prev <- high; low.prev <- low
    }
    
    lines(times, curves[,1], lwd=2, col=0)  ## point estimates in white
  } else {
    if(add)
      lines(times, curves[,1])
    else {
      if(missing(xlim))
        plot(times, curves[,1], type='l',
             xlab=xlab, ylab=ylab, ylim=ylim)
      else
	plot(times, curves[,1], type='l',
             xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim)
      
      title(paste('Simultaneous',conf.int,'Confidence Region'))
    }

    high <- apply(curves[,i], 1, max)
    low  <- apply(curves[,i], 1, min)
    lines(times, high, lty=2)
    lines(times, low,  lty=2)
  }
  
  result <- list(times=times, fitted=curves[,1], lower=low, upper=high)

  if(individual.boot || curves.in.simultaneous.band) {
    subs <- if(individual.boot) 1:B
            else i
    
    if(!missing(ncurves))
      subs <- sample(subs, ncurves)
    
    for(j in subs)
      lines(times, curves[,j], lty=2)
  }

  if(pointwise.band) {
    p <- apply(curves, 1, quantile, probs=c((1-conf.int)/2,1-(1-conf.int)/2))
    lines(times,p[1,],col=col.pointwise.band)
    lines(times,p[2,],col=col.pointwise.band)
    result <- c(result, list(pointwise.lower=p[1,], pointwise.upper=p[2,]))
  }
  
  if(!add && subtitles) {
    title(sub=obj$bootstrap.type,adj=1)
    title(sub=paste(B-1,'bootstrap repetitions'),adj=0)
  }

  invisible(result)
}
## Rick Chappell <> Asst. Professor, Depts. of Statistics and Human Oncology
## <> University of Wisconsin at Madison <> chappell@stat.wisc.edu
## (608) 263-5572 / 262-2733 <> take logs

samplesize.bin <- function(alpha, beta, pit, pic, rho=.5)
{

  ## alpha is the scalar ONE-SIDED test size, or two-sided size/2
  ## beta is a scalar or vector of powers
  ## pit is the hypothesized treatment probability of success
  ## pic is the hypothesized control probability of success
  ## returns required TOTAL sample size, using arcsin transformation
  ## rho is the proportion of the sample devoted to treated group (0 <rho < 1) 

  as <- function(x)
  {
    asin(sqrt(x))
  }
  
  invas <- function(x) {
    (sin(x))**2
  }

  Zalpha <- qnorm(1-alpha)
  Zbeta  <- qnorm(beta)
  n <- Zalpha + Zbeta
  n <- n/(as(pit) - as(pic))
  n <- (n**2)/(4*rho*(1-rho))
  round(n+.5,0)
}
## $Id: sas.get.s 477 2007-04-11 22:21:23Z harrelfe $
sas.get <- if(under.unix || .R.)
  function(library, member, variables = character(0), 
           ifs = character(0), 
           format.library = library, id, 
           dates. = c("sas","yymmdd","yearfrac","yearfrac2"), 
           keep.log = TRUE, log.file = "_temp_.log", 
           macro = sas.get.macro,
           data.frame.out = existsFunction("data.frame"), 
           clean.up = !.R.,
           quiet = FALSE, temp = tempfile("SaS"), 
           formats=TRUE, recode=formats, 
           special.miss=FALSE, sasprog="sas", as.is=.5, check.unique.id=TRUE,
           force.single=FALSE,
           where, uncompress=FALSE)
{
  if(.R. && force.single) stop('force.single does not work under R')
  dates. <- match.arg(dates.)

  fexists <- function(name) {
    w <- file.exists(name)
    attr(w, 'which') <- name[w]
    w
  }

  file.is.dir <- if(.R.) {
    function(name) {
      isdir <- file.info(name)$isdir
      isdir && !is.na(isdir)
    }
  } else {
    function(name) is.dir(name)
  }

  file.is.readable <- function(name)
    if(.R.)
      file.access(name,4)==0
    else access(name,4)==0

  fileShow <- if(.R.) function(x) file.show(x)
              else function(x) page(filename=x)

  if(recode) formats <- TRUE

  if(missing(formats) || formats) {
    ## *****  Next line begins mod from Mike Kattan edits 11 Sep 97
    ## Redone FEH 22Oct00
    no.format <- all(!fexists(paste(format.library,
                                    c('formats.sc2','formats.sct','formats.sct01','formats.sas7bcat'),
                                    sep='/')))
    if(no.format) {
      if((!missing(formats) && formats) || (!missing(recode) && recode))
        warning(paste(paste(format.library, 
                            "/formats.sc? or formats.sas7bcat",sep = ""), 
                      " not found. Formatting ignored. \n"))
      formats <- recode <- FALSE
    }
    ## ***** End Mike Kattan edits 11 Sep 97
  }
  
  ## 5 Changes here from Claudie Berger <claudie@osteo1.ri.mgh.mcgill.ca> 19feb00
  ## Allows work on sas v7.
  sasin   <- paste(temp, ".3.sas", sep = "")
  sasout1 <- paste(temp, ".1.sas", sep = "")
  sasout2 <- paste(temp, ".2.sas", sep = "")
  sasout3 <- paste(temp, ".4.sas", sep = "")
  sasout4 <- paste(temp, ".5.sas", sep = "")
  nvariables <- length(variables)
  if(nvariables>0) {
    if(any(jdup <- duplicated(variables)))
      stop(paste("duplicate variables requested: ", variables[jdup]))
  }
  
  varstring <- paste(variables, collapse = "\n ")
  ifs <- paste("'",paste(ifs, collapse = ";\n "),"'",sep="")
  if(length(sasin) != 1)
    stop("Illegal temporary file name")
  
  temp.files <- c(sasin, sasout1, sasout2, sasout3, sasout4)
  if(!keep.log)
    temp.files <- c(temp.files, log.file)
  
  if(clean.up)
    on.exit(unlink(temp.files))
  ##on.exit(sys(paste("rm -f", paste(temp.files, collapse = " "))))
  ##  4oct03
  
  if(missing(member))
    stop("SAS member name is required")
  
  if(missing(library))
    stop("SAS library name is required")
  
  cat(macro, sep="\n", file=sasin)

  sasds.suffix <- c('sd2','sd7','ssd01','ssd02','ssd03','ssd04','sas7bdat') 
  ## 22Oct00

  if(library == "") {
    if(uncompress) {  # 22Oct00
      unix.file <- paste(member, sasds.suffix, sep=".")
      if(any(fe <- fexists(paste(unix.file,".gz",sep=""))))
        sys(paste("gunzip ",attr(fe,'which'),'.gz',sep=''))
      else if(any(fe <- fexists(paste(unix.file,".Z",sep=""))))
        sys(paste("uncompress ",attr(fe,'which'),'.Z',sep=''))
    }

    cat("%sas_get(", member, ",\n",
        "  ", sasout1, ",\n",
        "  ", sasout2, ",\n",
        "  ", sasout3, ",\n",
        "  ", sasout4, ",\n",
        "  dates=", dates., ",\n",
        "  vars=",  varstring, ",\n",
        "  ifs=",   ifs, ",\n",
        "  formats=", as.integer(formats), "\n,",
        "  specmiss=", as.integer(special.miss), ");\n",
        file = sasin, append = TRUE, sep = "")
  } else {
    if(!file.is.dir(library))
      stop(paste(sep = "", "library, \"", library, 
                 "\", is not a directory"))
    
    unix.file <- paste(library, "/", member, ".", sasds.suffix,
                       sep='')
    ##23Nov00
    if(uncompress) {  #22Oct00
      if(any(fe <- fexists(paste(unix.file,".gz",sep=""))))
        sys(paste("gunzip ", attr(fe,'which'),'.gz',sep=''))
      else if(any(fe <- fexists(paste(unix.file,".Z",sep=""))))
        sys(paste("uncompress ",attr(fe,'which'),'.Z',sep=''))
    }
    
    if(!any(fe <- fexists(unix.file))) {
      stop(paste(sep = "", "Unix file, \"",
                 paste(unix.file,collapse=' '), 
                 "\", does not exist"))
    } else {
      file.name <- attr(fe,'which')
      if(!file.is.readable(file.name)) {
        stop(paste(sep = "", 
                   "You do not have read permission for Unix file, \"",
                   file.name, "\""))   # 22Oct00
      }
    }
    
    cat("libname temp '", library, "';\n", file = sasin, append = TRUE,
        sep = "")
    
    ## format.library should contain formats.sct containing user defined
    ## formats used by this dataset.  It must be present.
    cat("libname library '", format.library, "';\n", file = sasin,
        append = TRUE, sep = "")
    cat("%sas_get(temp.", member, ",\n",
        "  ", sasout1, ",\n",
        "  ", sasout2, ",\n",
        "  ", sasout3, ",\n",
        "  ", sasout4, ",\n",
        "  dates=", dates., ",\n",
        "  vars=",  varstring, ",\n",
        "  ifs=",   ifs, ",\n",
        "  formats=", as.integer(formats), "\n,",
        "  specmiss=", as.integer(special.miss), ");\n",
        file = sasin, append = TRUE, sep = "")
  }
  
  status <- sys(paste(shQuote(sasprog), shQuote(sasin), "-log", shQuote(log.file)), output=FALSE)
  ## 24nov03 added output=F
  if(status != 0) {
    if(!quiet && fexists(log.file)) fileShow(log.file)  ## 4oct03
    stop(paste("SAS job failed with status", status))
  }
										#
										# Read in the variable information
										#
  if(!(fexists(sasout1) && fexists(sasout2))) {
    if(!quiet)
      fileShow(log.file)  ## 4oct03
    
    stop("SAS output files not found")
  }
  
  vars <-
    if(.R.) scan(sasout1, list(name = "", type = 0, length = 0,
                               format = "", label = "", n = 0),
                 multi.line = FALSE, sep = "\022",
                 flush=TRUE, comment.char='', quote='')
    else
      scan(sasout1, list(name = "", type = 0, length = 0, format = "",
                         label = "", n = 0),
           multi.line = FALSE, flush=TRUE, sep = "\022")
  ## Thanks Don MacQueen for scan fix for R
  
  nvar <- length(vars$name)
  if(nvar == 0) {
    if(!quiet)
      fileShow(log.file)  ## 4oct03
    
    stop("First SAS output is empty")
  }
  
  nrow <- vars$n[1]	#n is the same for each variable
  
  ## Read the data in
  ##  We try to be clever about the variable type.  If SAS is character
  ##  use char of course.  If is numeric and length >4, use double.  If
  ##  numeric and length <4, use single.  We could also use the format to
  ##  choose further, if it consists of a number followed by a "."
  ##  can we safely assume integer.
  ##
  type <- ifelse(vars$type == 2, "character(nrow)", 
                 ifelse(force.single | (vars$length < 5 & !.R.),  ##28Mar01
                        "single(nrow)", "double(nrow)"))
  ##BILL: I corrected the macro so the following isn't needed:
  ## get rid of trailing blank on names
  ##	vars$name <- unix("sed 's/ $//'", vars$name)
  inlist <- paste("\"", vars$name, "\"=", type,
                  sep = "", collapse = ", ")
  
  inlist <- parse(text = paste("list(", inlist, ")"))
  ## Inlist would now be the size of the final data structure, if I had
  ## evaluated it.

  ## Read the data
  ds <-
    if(.R.) scan(sasout2, eval(inlist), sep = "\022", multi.line = FALSE,
                 flush=TRUE, comment.char='', quote='')
    else
      scan(sasout2, eval(inlist), sep = "\022", multi.line = FALSE,
           flush=TRUE)
  
  if(length(ds) < nvariables) {
    m <- variables[is.na(match(variables, names(ds)))]
    if(length(m) > 0) {
      warning(paste(length(m), 
                    "requested variables did not exist:", 
                    paste("\"", m, "\"", sep = "", collapse = " "), 
                    "\n\t(use sas.contents())"))
    }
  }

  format <- vars$format
  format[format=='$'] <- ' '    # 1Mar00
  label <- vars$label
  name <- vars$name
  esasout3 <- formats && fexists(sasout3)   #added formats && 1/20/93
  if(recode && !esasout3) recode <- FALSE
  FORMATS <- NULL

  if(formats && esasout3) {
    FORMATS <- dget(sasout3)
    if(length(FORMATS)==0) {
      FORMATS <- NULL;
      recode <- FALSE
    }	
  }
  
  smiss <- NULL
  if(special.miss && fexists(sasout4))
    smiss <-
      if(.R.) scan(sasout4, list(name="", code="", obs=integer(1)),
                   multi.line=FALSE, flush=TRUE, sep="\022",
                   comment.char='', quote='')
      else
        scan(sasout4, list(name="", code="", obs=integer(1)),
             multi.line=FALSE, flush=TRUE, sep="\022")
  
  sasdateform <- c("date","mmddyy","yymmdd","ddmmyy","yyq","monyy",
                   "julian","qtr","weekdate","weekdatx","weekday","month")
  dateform <- 	
    list(as.name("ddmmmyy"),"m/d/y","y/m/d","d/m/y",as.name("ddmmmyy"),
         "mon year",as.name("ddmmmyy"),"mon",as.name("ddmmmyy"),
         as.name("ddmmmyy"), as.name("ddmmmyy"),"m")
  
  sastimeform <- c("hhmm","hour","mmss","time")
  timeform <- c("h:m","h","m:s","h:m:s")
  sasdatetimeform <- c("datetime","tod")
  datetimeform <- list(list(as.name("ddmmmyy"),"h:m:s"), c("m/d/y"," "))
  z <- "%02d%b%Y"
  dateform4 <-
    c(z,"%02m/%02d/%Y","%Y/%02m/%02d","%02d/%02m/%Y", z,"%02m %Y",
      z,"%02m", z, z, z,"%02m")
  
  timeform4 <- c("%02H:%02M","%02H","%02M:%02S","%02H:%02M:%02S")
  datetimeform4 <- c("%02d%b%Y %02h:%02m:%02s","%02m/%02d/%Y")

  if(.R.) {   ## Don MacQueen
    days.to.adj <- as.numeric(difftime(ISOdate(1970,1,1,0,0,0) , 
                                       ISOdate(1960,1,1,0,0,0), 'days'))
    secs.to.adj <- days.to.adj*24*60*60
  }

  for(i in 1:nvar) {
    atr <- list()
    dsi <- ds[[i]]
    fname <- format[i]
    rec <- FALSE
    if(fname!=" ") {
      ff <- fname
      if(dates.=="sas" & (m <- match(fname,sasdateform,0)) >0) {
        ##look for partial dates
        dd <- dsi-floor(dsi)
        ddn <- !is.na(dd)
        if(any(ddn) && any(dd[ddn]!=0)) {
          ll <- 1:length(dd)
          atr$partial.date <- 
            list(month=ll[dd==.5],day=ll[dd==.25],both=ll[dd==.75])
          atr$imputed <- ll[dd!=0]
          dsi <- floor(dsi)
        }
        dsi <- importConvertDateTime(dsi, 'date', 'sas',
                                     form=if(.SV4.) dateform4[m]
                                          else dateform[m])
        
        if(length(atr$imputed)) 
          attr(dsi,'class') <- c("impute",attr(dsi,'class'))
        
        ff <- NULL
      } else {
        if((m <- match(fname,sastimeform,0)) >0) {
          dsi <- importConvertDateTime(dsi, 'time', 'sas', 
                                       form=if(.SV4.)timeform4[m]
                                            else timeform[m])
          ff <- NULL			
        } else if((m <- match(fname,sasdatetimeform,0))>0) {
          dsi <- importConvertDateTime(dsi, 'datetime', 'sas',
                                       form=if(.SV4.) datetimeform4[m]
                                            else datetimeform[m])
          
          ff <- NULL					
        }
      }

      atr$format <- ff
      if(recode & length(g <- FORMATS[[fname]])) {
        labs <- g$labels
        if(!is.logical(recode)) {
          labs <- if(recode==1) paste(g$values,":",labs,sep="")
                  else paste(labs,"(",g$values,")",sep="")
        }

	dsi <- factor(dsi, g$values, labs)
        atr$sas.codes <- g$values
        rec <- TRUE
      }   
    }

    if(data.frame.out && !rec && vars$type[i]==2 &&
       ((is.logical(as.is) && !as.is) || 
        (is.numeric(as.is) && length(unique(dsi)) < as.is*length(dsi))))
      dsi <- factor(dsi, exclude="") #exclude added 5Mar93
    
    ## For data frames, char. var usually factors
    if(label[i]!=" ")
      label(dsi) <- label[i]  #atr$label <- label[i]
    
    if(length(smiss$name)) {
      j <- smiss$name==name[i]
      if(any(j)) {
        atr$special.miss <- 
          list(codes=smiss$code[j],obs=smiss$obs[j])
        attr(dsi,'class') <- c("special.miss",attr(dsi,'class'))
      }
    }

    if(!is.null(atr))
      attributes(dsi) <- c(attributes(dsi),atr)

    if(missing(where))
      ds[[i]] <- dsi
    else
      assign(name[i], dsi, where=where)				
  }

  if(!missing(where))
    return(structure(where, class="where"))

  atr <- list()
  
  if(missing(id)) {
    if(data.frame.out)
      atr$row.names <- as.character(1:nrow)
  } else {
    idname <- id 
    jj <- match(idname, names(ds), 0)
    if(any(jj==0))
      stop(paste(
                 "id variable(s) not in dataset:",
                 paste(idname[jj==0],collapse=" ")))
    
    if(length(idname)==1) {
      id <- ds[[idname]] #Need since not use data.frame
    } else {		 
      id <- as.character(ds[[idname[1]]])
      for(jj in 2:length(idname))
        id <- paste(id, as.character(ds[[idname[jj]]]))
    }

    if(check.unique.id) {
      dup <- duplicated(id)
      if(any(dup))
        warning(paste("duplicate IDs:",
                      paste(id[dup], collapse=" ")))
    }

    if(data.frame.out)
      atr$row.names <- as.character(id)
    else atr$id <- id	
  }

  if(!is.null(FORMATS))
    atr$formats <- FORMATS

  if(data.frame.out)
    atr$class <- "data.frame"

  attributes(ds) <- c(attributes(ds),atr)
  ds
} else function(library=".", member, variables = character(0), 
                ifs = character(0), 
                format.library = library, id, sasout, 
                keep.log = TRUE, log.file = "_temp_.log", macro = sas.get.macro,
                clean.up = TRUE, formats=TRUE, recode=formats, 
                special.miss=FALSE, sasprog="sas", as.is=.5, check.unique.id=TRUE,
                force.single=FALSE, where, unzip=FALSE)
{
  if(force.single && .R.)
    stop('force.single does not work under R')
  
  if(recode)
    formats <- TRUE

  sasran <- !missing(sasout)

  if(sasran) {
    if(missing(library)+missing(member)+missing(variables)+
       missing(ifs)+missing(format.library)+missing(keep.log)+
       missing(log.file)+missing(formats)+
       missing(special.miss)+missing(sasprog)+
       missing(unzip) != 11)
      stop('when sasout is given you may not specify options telling SAS how to run')
    
    if(length(sasout)==1) {
      dos(paste('pkunzip', sasout), out=FALSE, translate=TRUE)
      sasout <- rep('', 4)
      filenames <- c('dict','data','formats','specmiss')
      for(i in 1:4) if(access(filenames[i],4)==0)
        sasout[i] <- filenames[i]

      if(any(sasout[1:2]==''))
        stop('no files named dict and data')

      on.exit(unlink(sasout[sasout!='']))
    }

    if(any(sasout[1:2]==''))
      stop('sasout[1] and sasout[2] must not be ""')

    j <- sasout[sasout!='']
    k <- access(j,4) < 0
    if(any(k))
      stop(paste('these files do not exist or you do not have read access:\n',paste(j[k],collapse='\n')))

    formats <- sasout[3]!='' && access(sasout[3])==0
    if(missing(recode))
      recode <- formats

    special.miss <- sasout[4]!='' && access(sasout[4])==0
  } else {
    ## *****  Next line begins mod from Mike Kattan edits 11 Sep 97
    ## Added 2 phrases for sas7bcat 9Oct00.  Changed FEH 22Oct00
    no.format <- all(access(paste(format.library,
                                  c('formats.sc2','formats.sct',
                                    'formats.sct01','formats.sas7bcat'),
                                  sep='//'),4) < 0)
    if(no.format) {
      if((!missing(formats) && formats) || (!missing(recode) && recode))
        warning(paste(paste(format.library, 
                            "/formats.sc? or formats.sas7bcat",sep = ""), 
                      " not found. Formatting ignored. \n"))

      formats <- recode <- FALSE
    }
    
    ## ***** End Mike Kattan edits 11 Sep 97
    ## 5 Changes here from Claudie Berger <claudie@osteo1.ri.mgh.mcgill.ca>
    ## 19feb00 (changed from unix version). Allows work on sas v7.

    sasout <- paste(tempfile(c('a','b','c','d','in')),'sas',sep='.')
    sasin  <- sasout[5]
    if(clean.up)
      on.exit(unlink(c(sasout,if(!keep.log)log.file)))

    if(missing(member))
      stop('must specify member')
    
    if(library != '.' && !is.dir(library))
      stop('library is not a valid directory name')

    nvariables <- length(variables)
    if(nvariables>0)	{
      if(any(jdup <- duplicated(variables)))
        stop(paste("duplicate variables requested: ", variables[jdup]))
				}
    varstring <- paste(variables, collapse = "\n ")
    ifs <- paste("'",paste(ifs, collapse = ";\n "),"'",sep="")

    cat(macro, sep="\n", file=sasin)
    if(unzip) {
      file <- paste(member,".zip",sep="")
      if(library != '.') file <- paste(library,'/',file,sep='')
      if(access(file)==0) dos(if(library=='.') paste("pkunzip",file)
                              else paste("pkunzip",file,library),
                              out=FALSE, translate=TRUE)
      else
        cat(file,'does not exist.  No unzipping attempted.\n')
    }

    file <- paste(member, 
                  c('sd2','sd7','ssd01','ssd02','ssd03','ssd04','sas7bdat'), sep='.')
    if(library != '.')
      file <- paste(library, '/', file, sep='')

    if(all(access(file,4) < 0)) 
      stop(paste('file',paste(file,collapse=' '),
                 'does not exist or you do not have read access'))	

    cat("libname temp '", library, "';\n", file = sasin, append = TRUE,
        sep = "")
    if(format.library != '.' && (!is.dir(format.library) || access(format.library,4)<0))
      stop('format.library does not exist or you do not have read access for it')

    ## format.library should contain formats.sct containing user defined
    ## formats used by this dataset.
    cat("libname library '", format.library, "';\n", file = sasin,
        append = TRUE, sep = "")
    cat("%sas_get(temp.", member, ",\n",
        "  ", sasout[1], ",\n",
        "  ", sasout[2], ",\n",
        "  ", sasout[3], ",\n",
        "  ", sasout[4], ",\n",
        "  dates=sas\n",
        "  vars=",  varstring, ",\n",
        "  ifs=",   ifs, ",\n",
        "  formats=", as.integer(formats), "\n,",
        "  specmiss=", as.integer(special.miss), ");\n",
        file = sasin, append = TRUE, sep = "")
    
    cat('Invoking SAS for Windows.  Click the SAS icon if you want to watch.\n')
    win3(paste(paste('"', sasprog, '"', sep=''), paste('"',sasin,'"', sep=''), "-log",
               paste('"',log.file,'"',sep=''), "-icon"))
    if(access(log.file) < 0) 
      stop(paste('SAS did not create log file',log.file,
                 '\nCheck that sas.exe is in your path.'))

    if(any(access(sasout[1:2]) < 0)) {
      cat('\nSAS did not run correctly to produce at least two ASCII files\n')
      cat('Make sure that sas.exe is in your path.\nPutting SAS log file in a window.\n')
      win3(paste('notepad',log.file), multi=TRUE)
      stop()
    }
  }


  ## Read in the variable information


  vars <-
    if(.R.) scan(sasout[1], list(name = "", type = 0, length = 0,
                                 format = "", label = "", n = 0),
                 multi.line = FALSE, flush=TRUE, sep = "\022",
                 comment.char='', quote='')
    else scan(sasout[1], list(name = "", type = 0, length = 0, format = "",
                              label = "", n = 0), multi.line = FALSE,
              flush=TRUE, sep = "\022")
  
  nvar <- length(vars$name)
  if(nvar == 0) {
    if(!sasran) {
      cat('\nError: first SAS output file is empty.  Putting log file in a window.\nMake sure that sas.exe is in the path')
      win3(paste('notepad',log.file), multi=TRUE)
      stop()
    }
    stop("First SAS output file is empty.  Make sure that sas.exe is in the path")
  }

  nrow <- vars$n[1]
  ##n is the same for each variable

  ## Read the data in
  ##  We try to be clever about the variable type.  If SAS is character
  ##  use char of course.  If is numeric and length >4, use double.  If
  ##  numeric and length <4, use single.  We could also use the format to
  ##  choose further, if it consists of a number followed by a "."
  ##  can we safely assume integer.

  type <- ifelse(vars$type == 2, "character(nrow)", 
                 ifelse(force.single | (vars$length < 5 & !.R.),   ## 28Mar01
                        "single(nrow)", "double(nrow)"))
  
  inlist <- paste("\"", vars$name, "\"=", type, sep = "", collapse = ", ")
  inlist <- parse(text = paste("list(", inlist, ")"))
  ## Inlist would now be the size of the final data structure, if I had
  ## evaluated it.
  
  ## Read the data
  ds <- scan(sasout[2], eval(inlist), sep = "\022", multi.line = FALSE,
             flush=TRUE)
  if(!sasran && (length(ds) < nvariables)) {
    m <- variables[is.na(match(variables, names(ds)))]
    if(length(m) > 0)
      warning(paste(length(m), 
                    "requested variables did not exist:",
                    paste("\"", m, "\"", sep = "", collapse = " ")))
  }
  
  format <- vars$format
  format[format=='$'] <- ' '    # 1Mar00

  label <- vars$label
  name <- vars$name

  FORMATS <- NULL
  formats <- formats && access(sasout[3])==0
  if(formats) {
    FORMATS <- dget(sasout[3])
    if(length(FORMATS)==0)
      formats <- FALSE
  }
  
  if(recode && !formats) recode <- FALSE

  smiss <- NULL
  if(special.miss && access(sasout[4])==0)
    smiss <- scan(sasout[4], 
                  list(name="", code="", obs=integer(1)),
                  multi.line=FALSE, flush=TRUE, sep="\022")

  sasdateform <- c("date","mmddyy","yymmdd","ddmmyy","yyq","monyy",
                   "julian","qtr","weekdate","weekdatx","weekday","month")
  dateform <- 	
    list(as.name("ddmmmyy"),"m/d/y","y/m/d","d/m/y",as.name("ddmmmyy"),
         "mon year",as.name("ddmmmyy"),"mon",as.name("ddmmmyy"),
         as.name("ddmmmyy"), as.name("ddmmmyy"),"m")
  
  sastimeform <- c("hhmm","hour","mmss","time")
  timeform <- c("h:m","h","m:s","h:m:s")
  sasdatetimeform <- c("datetime","tod")
  datetimeform <- list(list(as.name("ddmmmyy"),"h:m:s"), c("m/d/y"," "))

  z <- "%02d%b%Y"
  dateform4 <-
    c(z,"%02m/%02d/%Y","%Y/%02m/%02d","%02d/%02m/%Y", z,"%02m %Y",
      z,"%02m", z, z, z,"%02m")
  timeform4 <- c("%02H:%02M","%02H","%02M:%02S","%02H:%02M:%02S")
  datetimeform4 <- c("%02d%b%Y %02h:%02m:%02s","%02m/%02d/%Y")

  for(i in 1:nvar) {
    atr <- list()
    dsi <- ds[[i]]
    fname <- format[i]
    rec <- FALSE
    if(fname!=" ") {
      ff <- fname
      if((m <- match(fname,sasdateform,0)) >0) {
        ## look for partial dates
        dd <- dsi-floor(dsi)
        ddn <- !is.na(dd)
        if(any(ddn) && any(dd[ddn]!=0)) {
          ll <- 1:length(dd)
	  atr$partial.date <- 
            list(month=ll[dd==.5],day=ll[dd==.25],both=ll[dd==.75])
	  atr$imputed <- ll[dd!=0]
	  dsi <- floor(dsi)
        }

        dsi <-  importConvertDateTime(dsi, 'date', 'sas',
                                      form=if(.SV4.) dateform4[m]
                                           else dateform[m])
        
        if(length(atr$imputed)) 
          attr(dsi,'class') <- c("impute",attr(dsi,'class'))
        
        ff <- NULL
      } else if((m <- match(fname,sastimeform,0)) >0) {
        dsi <- importConvertDateTime(dsi, 'time', 'sas',
                                     form=if(.SV4.) timeform4[m]
                                     else timeform[m])

        ff <- NULL
      } else if((m <- match(fname,sasdatetimeform,0))>0) {
        dsi <- importConvertDateTime(dsi, 'datetime', 'sas',
                                     form=if(.SV4.)datetimeform4[m]
                                     else datetimeform[[m]])

	ff <- NULL
      }

      atr$format <- ff
      if(recode & length(g <- FORMATS[[fname]])) {
        labs <- g$labels
        if(!is.logical(recode)) {
          labs <- if(recode==1) paste(g$values,":",labs,sep="")
                  else paste(labs,"(",g$values,")",sep="")
        }

        dsi <- factor(dsi, g$values, labs)
        atr$sas.codes <- g$values
        rec <- TRUE
      }
      ## end if(fname!=' ')
    }

    if(!rec && vars$type[i]==2 &&
       ((is.logical(as.is) && !as.is) || 
        (is.numeric(as.is) &&
         length(unique(dsi)) < as.is*length(dsi))))
      dsi <- factor(dsi, exclude="")
    
    ## For data frames, char. var usually factors
    if(label[i]!=" ")
      label(dsi) <- label[i]
    
    if(length(smiss$name)) {
      j <- smiss$name==name[i]
      if(any(j)) {
        atr$special.miss <- 
          list(codes=smiss$code[j],obs=smiss$obs[j])
        attr(dsi,'class') <- c("special.miss",attr(dsi,'class'))
      }
    }

    if(!is.null(atr))
      attributes(dsi) <- c(attributes(dsi),atr)

    if(missing(where))
      ds[[i]] <- dsi
    else 
      assign(name[i], dsi, where=where)				
  }

  if(!missing(where))
    return(structure(where, class="where"))
  
  atr <- list()
  if(missing(id))
    atr$row.names <- as.character(1:nrow)
  else  {
    idname <- id 
    jj <- match(idname, names(ds), 0)
    if(any(jj==0))
      stop(paste("id variable(s) not in dataset:",
                 paste(idname[jj==0],collapse=" ")))
    
    if(length(idname)==1)
      id <- ds[[idname]] #Need since not use data.frame
    else {
      id <- as.character(ds[[idname[1]]])
      for(jj in 2:length(idname))
        id <- paste(id, as.character(ds[[idname[jj]]]))
    }
    
    if(check.unique.id) {
      dup <- duplicated(id)
      if(any(dup)) warning(paste("duplicate IDs:",
                                 paste(id[dup], collapse=" ")))
    }

    atr$row.names <- as.character(id)
  }

  if(length(FORMATS))
    atr$formats <- FORMATS
  
  atr$class <- "data.frame"
  attributes(ds) <- c(attributes(ds),atr)
  ds
}


importConvertDateTime <- 
  function(x, type=c('date','time','datetime'),
           input=c('sas','spss','dataload'), form)
{
  type <- match.arg(type)
  input <- match.arg(input)

  if(input != 'sas' && type != 'date')
    stop('only date variables are support for spss, dataload')
		
 if(.R.) {
    adjdays <- c(sas=3653, spss=141428, dataload=135080)[input]
   ## 1970-1-1 minus 1960-1-1, 1582-10-14, or 1600-3-1
   if(input=='spss') x <- x/86400

    switch(type,
           date = structure(x - adjdays, class='Date'),
           time = {
             ## Don MacQueen 3Apr02
             z <- structure(x, class=c('POSIXt','POSIXct'))
             f <- format(z, tz='GMT')
             z <- as.POSIXct(format(z, tz='GMT'), tz='')
             structure(z, class=c('timePOSIXt','POSIXt','POSIXct'))},
           datetime = {
             chron((x - adjdays*86400)/86400,
                   out.format=c(dates='day mon year', times='h:m:s'))})
  } else if(.SV4.) 
    switch(type,
           date     = timeDate(julian=x, format=form),
           time     = timeDate(ms=x*1000, format=form),
           datetime = timeDate(julian=x/86400, format=form))
  else
    switch(type,
           date = dates(x, out.format=form),
           time = chron(x/86400, out.format=form),
           datetime = chron(x/86400, out.format=form))
}


if(.R.) {  ## Don MacQueen 3Apr02
  ## slightly modified copy of format.POSIXct() from R base
  format.timePOSIXt <- function (x, format = "%H:%M:%S", tz = "",
                                 usetz = FALSE, ...)
  {
    if (!inherits(x, c("timePOSIXt","POSIXct"))) stop("wrong class")
    class(x) <- class(x)[-1]
    structure(format.POSIXlt(as.POSIXlt(x, tz), format, usetz, ...),
              names = names(x))
  }

  print.timePOSIXt <- function(x, ...) print(format(x, ...))
  NULL
}


##if(!.R.) {
## Output format routine needed by chron for usual SAS date format
ddmmmyy <- function(x)
{
  y <- month.day.year(trunc(oldUnclass(x)), attr(x,"origin"))
  yr <- y$year
  m <- c("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct",
         "Nov","Dec")[y$month]
  ifelse(yr<1900 | yr>=2000, paste(y$day,m,yr,sep=""),
         paste(y$day,m,yr-1900,sep=""))
}
#}


## Functions to handle special.miss class
is.special.miss <- function(x, code)
{
  sm <- attr(x, "special.miss")
  if(!length(sm))
    return(rep(FALSE, length(x)))
  
  if(missing(code)) {
    z <- rep(FALSE, length(x))
    z[sm$obs] <- TRUE
  } else {
    z <- rep(FALSE, length(x))
    z[sm$obs[sm$codes==code]] <- TRUE
  }
  
  z
}


"[.special.miss" <- function(x, ..., drop=FALSE)
{
  ats <- attributes(x)
  ats$dimnames <- NULL
  ats$dim <- NULL
  ats$names <- NULL
  attr(x,'class') <- NULL
  y <- x[..., drop = drop]
  if(length(y) == 0)
    return(y)
  
  k <- seq(along=x)
  names(k) <- names(x)
  k <- k[...]
  attributes(y) <- c(attributes(y), ats)
  smiss <- attr(y, "special.miss")
  codes <- rep("ZZ",length(x))
  codes[smiss$obs] <- smiss$codes
  codes <- codes[...]
  which <- codes!="ZZ"
  if(sum(which)) attr(y,"special.miss") <- 
    list(obs=seq(along=k)[codes!="ZZ"],codes=codes[codes!="ZZ"])
  else {
    attr(y,"special.miss") <- NULL
    attr(y,'class') <- attr(y,'class')[attr(y,'class') != "special.miss"]
    if(length(attr(y,'class'))==0)
      attr(y,'class') <- NULL
  }
  
  y
}


format.special.miss <- function(x, ...)
{
  w <-
    if(is.factor(x))
      as.character(x)
    else {
      cl <- attr(x,'class');
      cl <- cl[cl!="special.miss"]
      if(length(cl)) {
        attr(x,'class') <- cl;
        format(x, ...)
      } else format.default(x, ...)
    }
  
  sm <- attr(x, "special.miss")
  names(w) <- names(x)
  if(!length(sm))
    return(w)
  
  w[sm$obs] <- sm$codes
  attr(w,"label") <- attr(w,"special.miss") <- attr(w,"class") <- NULL
  w
}


print.special.miss <- function(x, ...)
{
  sm <- attr(x, "special.miss")
  if(!length(sm)) {
    print.default(x)
    return(invisible())
  }
  
  w <- format.special.miss(x)
  print.default(w, quote=FALSE)
  invisible()
}


sas.codes <- function(object) attr(object, "sas.codes")


code.levels <- function(object) {
  if(length(cod <- attr(object,"sas.codes"))) 
    levels(object) <- paste(cod,":",levels(object),sep="")
  
  object
}


as.data.frame.special.miss <- function(x, row.names = NULL, optional = FALSE, ...)
{
  nrows <- length(x)
  if(is.null(row.names)) {
    ## the next line is not needed for the 1993 version of data.class and is
    ## included for compatibility with 1992 version
    if(length(row.names <- names(x)) == nrows &&
       !any(duplicated(row.names))) {
    }
    else if(optional)
      row.names <- character(nrows)
    else row.names <- as.character(1:nrows)
  }

  value <- list(x)
  if(!optional)
    names(value) <- deparse(substitute(x))[[1]]

  structure(value, row.names=row.names, class='data.frame')
}


## val{nval}=compress(value)||"" was =value  23mar04
sas.get.macro <-
  c("/* Macro sas_get (modified by F. Harrell 30Jan90, Bill Dunlap Dec90, FH Mar92,",
    "\t\t\tFH Apr95 (extend LENGTH smiss))", 
    "    Sets up for conversion of SAS dataset to S dataset.", 
    "    Arguments:", "\tdataset - name of SAS dataset", 
    "\ttemp1\t- Name of temporary dataset to contain data dictionar (unquoted)",
    "\t\t  default=/tmp/file.1", 
    "\ttemp2\t- Name of temporary dataset to contain ASCII version of SAS", 
    "\t\t  dataset (unquoted)", "\t\t  default=/tmp/file.2", 
    "\ttemp3   - Name of temporary dataset to contain ASCII file with S", 
    "\t\t  program to store format values and labels", 
    "\ttemp4   - Name of temporary dataset to contain ASCII file with", 
    "\t\t  locations of special missing values", 
    "\tdates\t- SAS to store date variables in SAS format ( # days from 1/1/60)",
    "\t\t  (default)", 
    "\t\t- YEARFRAC to store as days from 1/1/1900, divided by 365.25", 
    "\t\t- YEARFRAC2 to store as year + fraction of current year", 
    "\t\t- YYMMDD to store as numeric YYMMDD", 
    "\tvars    - list of variable in dataset that you want returned to Splus",
    "                  (unquoted, separate variable names with spaces)  If empty,",
    "                  then return all variables.", 
    "        ifs     - sequence of SAS subsetting if statements, (unquoted,",
    "                  separated by semicolons).", 
    "\tformats - 0 (default) - do not create file on temp3 containing S", 
    "\t\t  statements to store format values and labels, 1 do create", 
    "\tspecmiss- 0 (default).  Set to 1 to write a data file on temp4 with",
    "\t\t  the fields: variable name, special missing value code,", 
    "\t\t  observation number", 
    "                                                                              */",
    "%macro sas_get(dataset,  temp1, temp2, temp3, temp4, dates=SAS, vars=, ifs=, ",
    "\tformats=0, specmiss=0);", 
    "OPTIONS NOFMTERR;",
    "%IF %QUOTE(&temp1)=  %THEN %LET temp1=/tmp/file.1;", 
    "%IF %QUOTE(&temp2)=  %THEN %LET temp2=/tmp/file.2;", 
    "%IF %QUOTE(&temp3)=  %THEN %LET temp3=/tmp/file.3;", 
    "%IF %QUOTE(&temp4)=  %THEN %LET temp4=/tmp/file.4;",
    ## Next line had %QUOTE(&ifs),1,\"'\"  31oct02
    "%LET dates=%UPCASE(&dates);", "%LET ifs=%SCAN(%QUOTE(&ifs),1,'');", 
    "%LET _s_=_sav_;", 
    "/* BILL: Can these 2 subsets be combined into one pass of the data? -Frank*/",
    "/* Subset by observation first */", "%IF %QUOTE(&ifs)^= %THEN %DO;", 
    " data _osub_ ;", "  set &dataset ;", "  &ifs ;", 
    " %LET dataset=_osub_ ;", " %END;", "/* Then subset by variable */", 
    "%IF &vars^= %THEN %DO;", " data _vsub_ ;", "  set &dataset ;", 
    "  keep &vars ;", " %LET dataset=_vsub_ ;", " %END;", 
    "proc contents data=&dataset out=&_s_(KEEP=name type length label format nobs ",
    " varnum) noprint; ", "%IF &formats=1 %THEN %DO;", 
    "   PROC FORMAT LIBRARY=LIBRARY CNTLOUT=f(KEEP=fmtname type start end label);",
    "   DATA f; SET f; RETAIN n 0; n+1; IF type=\"C\" THEN fmtname=\"$\"||fmtname;",
    "   PROC SORT DATA=f OUT=f(DROP=n); BY fmtname n; ", 
    "  *Sort by n instead of start for numerics so 13 sorts after 2;", 
    "  *Dont consider formats containing ANY range of values;", 
    "  *Dont consider formats that dont have at least one non-missing (if", 
    "   numeric) starting value.  This gets rid of formats that are used", 
    "   only to label special missing values;", 
    "   DATA f2; SET f; BY fmtname; RETAIN anyrange 0 anynmiss 0;", 
    "      IF FIRST.fmtname THEN DO;anyrange=0;anynmiss=0;END;", 
    "      IF start^=end THEN anyrange=1;", 
    "      IF TYPE=\"C\" THEN anynmiss=1; ", 
    "      ELSE IF (start+0)>. THEN anynmiss=1;", 
    "      IF LAST.fmtname & anynmiss & ^anyrange THEN OUTPUT; KEEP fmtname;",
    "   DATA f; MERGE f f2(IN=in2); BY fmtname; IF in2;", 
    "      IF TYPE=\"N\" THEN DO; IF (start+0)>.;  *S cannot handle special missings;",
    "         END;", "      RENAME fmtname=format start=value; DROP end;", 
    "   PROC SORT DATA=&_s_(KEEP=format) OUT=sform; BY format;", 
    "   DATA sform; SET sform; BY format; IF LAST.format;", 
    "   DATA f; MERGE sform(IN=in1) f(IN=in2); BY format; ", 
    "      IF in1 & in2;", 
    "   *This keeps formats ever used by any variable;", 
    "   DATA _NULL_; SET f END=_eof_; BY format;", 
    "      ARRAY val{*} $ 16 val1-val500; ARRAY lab{*} $ 40 lab1-lab500; ", 
    "      RETAIN done 0 nform 0 nval 0 val1-val500 \" \" lab1-lab500 \" \" bk -1; ",
    "      FILE \"&temp3\" LRECL=4096;", "      IF FIRST.format THEN DO;", 
    "         IF ^done THEN PUT 'list(' @@;  done=1;", 
    "         nform=nform+1; nval=0;", 
    "         format=TRANSLATE(format,\".abcdefghijklmnopqrstuvwxyz\",", 
    "                                 \"_ABCDEFGHIJKLMNOPQRSTUVWXYZ\");", 
    "          IF nform=1 THEN PUT '\"' format +bk '\"=list(' @@;", 
    "         ELSE PUT ', \"' format +bk '\"=list(' @@;", "         END;", 
    "      nval=nval+1; ", 
    "      IF nval>500 THEN DO; ERROR \">500 format values not allowed\";ABORT ABEND;",
    "         END;", '      val{nval}=compress(value)||""; lab{nval}=label; ', 
    "      IF LAST.format THEN DO;", "         PUT \"values=c(\" @@; ", 
    "         DO i=1 TO nval; IF i>1 THEN PUT \",\" @@;", 
    "            IF type=\"N\" THEN PUT val{i} +bk @@;", 
    "            ELSE PUT '\"' val{i} +bk '\"'  @@;", "            END;", 
    "         PUT \"),labels=c(\" @@;", 
    "         DO i=1 TO nval; IF i>1 THEN PUT \",\" @@;", 
    "            PUT '\"' lab{i} +bk '\"' @@;", "            END;", 
    "         PUT \"))\";", "         END;", 
    "      IF _eof_ THEN PUT \")\";", "   %END;", 
    "PROC SORT DATA=&_s_;BY varnum;", "data _null_;", " set &_s_ end=eof;", 
    " FILE \"&temp1\";  RETAIN _bk_ -1;", " if _n_ = 1 then do;", 
    "%IF &specmiss=0 %THEN %LET ofile=_NULL_; ", 
    "%ELSE %LET ofile=smiss(KEEP=vname val obs);", 
    "  put \"data &ofile; set &dataset end=eof;\";", 
    "  put '  file \"&temp2\" RECFM=D LRECL=4096;';", 
    "  put \"  retain __delim 18 _bk_ -1 obs 0; LENGTH _xx_ $ 20 obs 5;obs+1; \";",
    "%IF &specmiss=1 %THEN %DO;", 
    "  put \"LENGTH vname $ 8 val $ 1;\"; %END;", "  end;", 
    " IF type=2 THEN DO;", "  PUT 'FORMAT ' name ';' @;", 
    "  PUT 'IF ' name '=\" \" THEN PUT __delim IB1. @;';", 
    "/* $char added F.H. 24Mar92, dropped  +_bk_ before __delim */", 
    "/* $CHAR. removed FEH 2Aug92, added null FORMAT above, added back +_bk_ */",
    "  PUT 'ELSE PUT ' name '+_bk_ __delim IB1. @;';", "  END;", 
    " ELSE DO; ", "  PUT 'IF ' name '<=.Z THEN _xx_=\"NA\";' @;", 
    "  PUT 'ELSE _xx_=LEFT(PUT(' @;", "  format=UPCASE(format);", 
    "  IF format=\"DATE\"|format=\"MMDDYY\"|format=\"YYMMDD\"|",
    "format=\"DDMMYY\"|format=\"YYQ\"|format=\"MONYY\"|format=\"JULIAN\" THEN DO;",
    "   %IF &dates=SAS %THEN", "    PUT name \",BEST18.)\";", 
    "   %ELSE %IF &dates=YYMMDD %THEN", "    PUT name \",YYMMDD6.)\";", 
    "   %ELSE %IF &dates=YEARFRAC %THEN", 
    "    PUT \"(\" name \"-MDY(1,1,1900))/365.25,7.3)\";", 
    "   %ELSE %IF &dates=YEARFRAC2 %THEN %DO;", 
    "    PUT \"YEAR(\" name \")-1900+(\" name \"-MDY(1,1,YEAR(\" name \")))/\" @;",
    "    PUT \"(MDY(12,31,YEAR(\" name \"))-MDY(1,1,YEAR(\" name \"))+1),7.3)\";",
    "    %END;", "   ;", "   END;\t", 
    "  ELSE DO;PUT name \",BEST18.)\" @;END;", 
    "  PUT ');  PUT _xx_ +_bk_ __delim IB1. @;';  *Added +_bk_ 2Aug92;", 
    "%IF &specmiss=1 %THEN %DO;", 
    "  put 'IF .A<=' name '<=.Z THEN DO;",
    "   vname=\"' name +_bk_ '\"; val=put(' name ',1.); OUTPUT; END;';",
    "  %END;", "  END;", "if eof then PUT 'PUT; RUN;';", "run;", 
    "%include \"&temp1\";", "data _null_; set &_s_;", 
    " retain __delim 18 _bk_ -1; ", " file \"&temp1\" LRECL=4096;", 
    " name=TRANSLATE(name,\".abcdefghijklmnopqrstuvwxyz\",", 
    "\t\t     \"_ABCDEFGHIJKLMNOPQRSTUVWXYZ\");", 
    " format=TRANSLATE(format,\".abcdefghijklmnopqrstuvwxyz\",", 
    "                         \"_ABCDEFGHIJKLMNOPQRSTUVWXYZ\");", 
    " put name +_bk_ __delim IB1. type +_bk_ __delim IB1. length +_bk_ __delim IB1.",
    "  format +_bk_ __delim IB1. label +_bk_ __delim IB1. nobs +_bk_ __delim IB1.;",
    "run;", "%IF &specmiss=1 %THEN %DO;", 
    " PROC SORT DATA=smiss OUT=smiss;BY vname val obs;", 
    " DATA _NULL_; SET smiss;FILE \"&temp4\" RECFM=D LRECL=30;", 
    " RETAIN _bk_ -1 __delim 18;", 
    " vname=TRANSLATE(vname,\".abcdefghijklmnopqrstuvwxyz\",", 
    "\t\t       \"_ABCDEFGHIJKLMNOPQRSTUVWXYZ\");", 
    " PUT vname +_bk_ __delim IB1. val +_bk_ __delim IB1. obs +_bk_ __delim IB1.;",
    " RUN;", " %END;", "%mend sas_get;")

cleanup.import <-
  function(obj, labels=NULL, lowernames=FALSE, 
           force.single=TRUE, force.numeric=TRUE,
           rmnames=TRUE,
           big=1e20, sasdict, 
           pr=prod(dimobj) > 5e5,
           datevars=NULL, datetimevars=NULL,
           dateformat='%F', fixdates=c('none','year'),
           charfactor=FALSE)
{
  fixdates <- match.arg(fixdates)
  nam <- names(obj)
  dimobj <- dim(obj)
  nv <- length(nam)

  if(!missing(sasdict))
    {
      sasvname <- makeNames(sasdict$NAME)
      if(any(w <- nam %nin% sasvname))
        stop(paste('The following variables are not in sasdict:',
                   paste(nam[w],collapse=' ')))
      
      saslabel <- structure(as.character(sasdict$LABEL), 
                            names=as.character(sasvname))
      labels <- saslabel[nam]
      names(labels) <- NULL
    }
	
  if(length(labels) && length(labels) != dimobj[2])
    stop('length of labels does not match number of variables')

  if(lowernames)
    names(obj) <- casefold(nam)

  if(pr)
    cat(dimobj[2],'variables; Processing variable:')

  for(i in 1:dimobj[2])
    {
      if(pr) cat(i,'')

      x <- obj[[i]];
      modif <- FALSE
      if(length(dim(x)))
        next
      
      if(rmnames)
        {
          if(length(attr(x,'names')))
            {
              attr(x,'names') <- NULL
              modif <- TRUE
            } else if(length(attr(x,'.Names')))
              {
                attr(x,'.Names') <- NULL
                modif <- TRUE
              }
        }
      
      if(.R. && length(attr(x,'Csingle'))) {
        attr(x,'Csingle') <- NULL
        modif <- TRUE
      }
    
      ## The following is to fix imports of S+ transport format data
      ## that were created in SV3
      if(.SV4.)
        {
          cl <- oldClass(x)
          xlev <- length(attr(x, 'levels'))
          if(any(cl=='AsIs'))
            {
              modif <- TRUE
              cat('Removed AsIs class from variable\t\t', nam[i], '\n')
              oldClass(x) <- cl[cl != 'AsIs']
              cl <- cl[cl != 'AsIs']
            }
      if(any(cl=='labelled'))
        {
          modif <- TRUE
          ##For some strange reason if class=c('labelled','factor'),
          ##removing labelled class changes class to 'category'
          cl <- oldClass(x) <-
            if(length(cl)==1 ||
               (length(cl)==2 && cl[2]=='factor' &&
                !xlev)) NULL
            else
              cl[cl != 'labelled']
        
          cat('Removed labelled class from variable\t', nam[i], '\n')
        }
      
      if(any(cl=='factor') && !xlev)
        {
          modif <- TRUE
          oldClass(x) <- cl[cl != 'factor']
          cat('Removed factor class from variable having no levels\t',
              nam[i], '\n')
        }
        }

    if(length(c(datevars,datetimevars)) &&
       nam[i] %in% c(datevars,datetimevars) &&
       !all(is.na(x)))
      {
        if(!(is.factor(x) || is.character(x)))
          stop(paste('variable',nam[i],
                     'must be a factor or character variable for date conversion'))
        
        x <- as.character(x)
        ## trim leading and trailing white space
        x <- sub('^[[:space:]]+','',sub('[[:space:]]+$','', x))
        xt <- NULL
        if(nam[i] %in% datetimevars)
          {
            xt <- gsub('.* ([0-9][0-9]:[0-9][0-9]:[0-9][0-9])','\\1',x)
            xtnna <- setdiff(xt, c('',' ','00:00:00'))
            if(!length(xtnna)) xt <- NULL
            x <- gsub(' [0-9][0-9]:[0-9][0-9]:[0-9][0-9]','',x)
          }
        if(fixdates != 'none')
          {
            if(dateformat %nin% c('%F','%y-%m-%d','%m/%d/%y','%m/%d/%Y'))
              stop('fixdates only supported for dateformat %F %y-%m-%d %m/%d/%y %m/%d/%Y')

            x <- switch(dateformat,
                        '%F'      =gsub('^([0-9]{2})-([0-9]{1,2})-([0-9]{1,2})', '20\\1-\\2-\\3',x),
                        '%y-%m-%d'=gsub('^[0-9]{2}([0-9]{2})-([0-9]{1,2})-([0-9]{1,2})', '\\1-\\2-\\3',x),
                        '%m/%d/%y'=gsub('^([0-9]{1,2})/([0-9]{1,2})/[0-9]{2}([0-9]{2})', '\\1/\\2/\\3',x),
                        '%m/%d/%Y'=gsub('^([0-9]{1,2})/([0-9]{1,2})/([0-9]{2})$','\\1/\\2/20\\3',x))
          }
        x <- if(length(xt))
          {
            require('chron')
            cform <- if(dateformat=='%F') 'y-m-d'
            else gsub('%','',tolower(dateformat))
            chron(x, xt, format=c(dates=cform,times='h:m:s'))
          }
        else as.Date(x, format=dateformat)
        modif <- TRUE
      }

      if(length(labels))
        {
          label(x) <- labels[i]
          modif <- TRUE
        }

      if(force.numeric && length(lev <- levels(x)))
        {
          if(all.is.numeric(lev))
            {
              labx <- attr(x,'label')
              x <- as.numeric(as.character(x))
              label(x) <- labx
              modif <- TRUE
            }
        }

    if(storage.mode(x) == 'double')
      {
        xu <- oldUnclass(x)
        j <- is.infinite(xu) | is.nan(xu) | abs(xu) > big
        if(any(j,na.rm=TRUE))
          {
            x[j] <- NA
            modif <- TRUE
            if(pr)
              cat('\n')
            
            cat(sum(j,na.rm=TRUE),'infinite values set to NA for variable',
                nam[i],'\n')
          }
         
      isdate <- testDateTime(x)
        if(force.single && !isdate)
          {
            allna <- all(is.na(x))
            if(allna) {
              storage.mode(x) <- 'integer'
              modif <- TRUE
            }
        
            if(!allna)
              {
                notfractional <- !any(floor(x) != x, na.rm=TRUE)
                if(max(abs(x),na.rm=TRUE) <= (2^31-1) && notfractional)
                  {
                    storage.mode(x) <- 'integer'
                    modif <- TRUE
                  } else if(!.R.)
                    {
                      storage.mode(x) <- 'single'
                      modif <- TRUE
                    }
              }
          }
      }

    if(charfactor && is.character(x))
      {
        if(max(nchar(x)) >= 2 && (length(unique(x)) < .5*length(x)))
          {
            x <- factor(x)
            modif <- TRUE
          }
      }
    
      if(modif) obj[[i]] <- x
    NULL
    }

  if(pr) cat('\n')
  if(!missing(sasdict))
    {
      sasat <- sasdict[1,]
      attributes(obj) <- c(attributes(obj),
                           sasds=as.character(sasat$MEMNAME),
                           sasdslabel=as.character(sasat$MEMLABEL))
    }
  
  obj
}


if(FALSE) {
  ## Here's some code I had to run once to clean up a data frame with
  ## S-Plus 6 on Windows:

  w <- card1
  for(i in 1:length(w)) {
    at <- attributes(w[[i]])
    if(any(at$class == 'Design')) {
      at$class <- at$class[at$class != 'Design']
      attributes(w[[i]]) <- at
    }
    lab <- attr(w[[i]],'label')
    if(length(lab)) {
      names(lab) <- NULL
      attr(w[[i]],'label') <- lab
    }
  }
}

  

upData <- function(object, ...,
                   rename=NULL, drop=NULL,
                   labels=NULL, units=NULL, levels=NULL,
                   force.single=TRUE, lowernames=FALSE,
                   moveUnits=FALSE, charfactor=FALSE)
{
  n  <- nrow(object)
  if(!length(n)) {
    x <- object[[1]]
    d <- dim(x)
    n <- if(length(d)) d[1]
         else length(x)
  }
  
  rnames <- row.names(object)

  if(lowernames)
    names(object) <- casefold(names(object))
  no <- names(object)

  cat('Input object size:\t',object.size(object),'bytes;\t',
      length(no),'variables\n')

  ## The following keeps label(object[[n]]) <- 'label' from removing the
  ## 'labelled' class from objects with other classes
  ## if(.R.) object <- oldUnclass(object)

  if(.SV4.) for(i in 1:length(no)) {
    z <- object[[i]]
    cl <- oldClass(z)
    modif <- FALSE
    zlev <- length(attr(z, 'levels'))
    if(any(cl=='AsIs')) {
      modif <- TRUE
      cat('Removed AsIs class from variable\t\t', no[i], '\n')
      cl <- cl[cl != 'AsIs']
      oldClass(z) <- cl
    }
    
    if(any(cl=='labelled')) {
      ##For some strange reason if class=c('labelled','factor'),
      ##removing labelled class changes class to 'category'
      modif <- TRUE
      cl <- oldClass(z) <-
        if(length(cl)==1 ||
           (length(cl)==2 && cl[2]=='factor' && !zlev))
          NULL
        else
          cl[cl != 'labelled']

      oldClass(z) <- cl  # new
      cat('Removed labelled class from variable\t', no[i], '\n')
    }

    if(any(cl=='factor') && !zlev) {
      modif <- TRUE
      oldClass(z) <- cl[cl != 'factor']
      cat('Removed factor class from variable having no levels\t',
          no[i], '\n')
    }

    if(modif)  object[[i]] <- z
  }
  
  if(moveUnits)
    for(i in 1:length(no)) {
      z <- object[[i]]
      lab <- attr(z,'label')
      if(!length(lab) || length(attr(z,'units')))
        next

      paren <- length(grep('\\(.*\\)',lab))
      brack <- length(grep('\\[.*\\]',lab))
      if(paren+brack == 0)
        next

      cat('Label for',no[i],'changed from',lab,'to ')
      u <- if(paren)regexpr('\\(.*\\)',lab)
           else regexpr('\\[.*\\]',lab)

      len <- attr(u,'match.length')
      un <- substring(lab, u+1, u+len-2)
      lab <- substring(lab, 1, u-1)
      if(substring(lab, nchar(lab), nchar(lab)) == ' ')
        lab <- substring(lab, 1, nchar(lab)-1) # added 2nd char above 8jun03

      cat(lab,'\n\tunits set to ',un,'\n',sep='')
      attr(z,'label') <- lab
      attr(z,'units') <- un
      object[[i]] <- z
    }

  if(length(rename)) {
    nr <- names(rename)
    if(length(nr)==0 || any(nr==''))
      stop('the list or vector specified in rename must specify variable names')

    for(i in 1:length(rename)) {
      if(nr[i] %nin% no)
        stop(paste('unknown variable name:',nr[i]))

      cat('Renamed variable\t', nr[i], '\tto', rename[[i]], '\n')
    }

    no[match(nr, no)] <- unlist(rename)
    names(object) <- no
  }

  z <- substitute(list(...))

  if(length(z) > 1) {
    z <- z[-1]
    vn <- names(z)
    if(!length(vn) || any(vn==''))
      stop('variables must all have names')

    for(i in 1:length(z)) {
      v <- vn[i]
      if(v %in% no)
        cat('Modified variable\t',v,'\n')
      else {
        cat('Added variable\t\t', v,'\n')
        no <- c(no, v)
      }

      x <- eval(z[[i]], object)
      d <- dim(x)
      lx <- if(length(d))d[1]
            else length(x)

      if(lx != n) {
        if(lx == 1)
          warning(paste('length of ',v,
                        ' is 1; will replicate this value.',sep=''))
        else {
          f <- find(v)
          if(length(f))cat('Variable',v,'found in',
                           paste(f,collapse=' '),'\n')

          stop(paste('length of ',v,' (',lx, ')\n',
                     'does not match number of rows in object (',
                     n,')',sep=''))
        }
      }
      
      ## If x is factor and is all NA, user probably miscoded. Add
      ## msg.
      if(is.factor(x) && all(is.na(x)))
        warning(paste('Variable ',v,'is a factor with all values NA.\n',
                      'Check that the second argument to factor() matched the original levels.\n',
                      sep=''))

      object[[v]] <- x
    }
  }
  
  if(force.single) {
    sm <- sapply(object, storage.mode)
    if(any(sm=='double'))
      for(i in 1:length(sm)) {   # 28Mar01
        if(sm[i]=='double') {
          x <- object[[i]]
          if(testDateTime(x))
            next   ## 31aug02

          if(all(is.na(x)))
            storage.mode(object[[i]]) <- 'integer'
          else {
            notfractional <- !any(floor(x) != x, na.rm=TRUE)  ## 28Mar01
            ## max(abs()) 22apr03
            if(notfractional && max(abs(x),na.rm=TRUE) <= (2^31-1))
              storage.mode(object[[i]]) <- 'integer'
            else if(!.R.)
              storage.mode(object[[i]]) <- 'single'
          }
        }
      }
  }

  if(charfactor) {
    g <- function(z) {
      if(!is.character(z) || max(nchar(z)) < 2) return(FALSE)
      length(unique(z)) < .5*length(z)
    }
    mfact <- sapply(object, g)
    if(any(mfact))
      for(i in (1:length(mfact))[mfact]) object[[i]] <- factor(object[[i]])
  }
  
  if(length(drop)) {
    if(length(drop)==1)
      cat('Dropped variable\t',drop,'\n')
    else
      cat('Dropped variables\t',paste(drop,collapse=','),'\n')

    s <- drop %nin% no
    if(any(s))
      warning(paste('The following variables in drop= are not in object:',
                    paste(drop[s],collapse=' ')))

    no <- no[no %nin% drop]
    object <- object[no]
  }

  if(length(levels)) {
    if(!is.list(levels))
      stop('levels must be a list')

    nl <- names(levels)
    s <- nl %nin% no
    if(any(s)) {
      warning(paste('The following variables in levels= are not in object:',
                    paste(nl[s],collapse=' ')))
      nl <- nl[!s]
    }

    for(n in nl) {
      if(!is.factor(object[[n]]))
        object[[n]] <- as.factor(object[[n]])

      levels(object[[n]]) <- levels[[n]]
      ## levels[[nn]] will usually be a list; S+ invokes merge.levels
    }
  }

  if(length(labels)) {
    nl <- names(labels)
    if(!length(nl)) stop('elements of labels were unnamed')
    s <- nl %nin% no
    if(any(s)) {
      warning(paste('The following variables in labels= are not in object:',
                    paste(nl[s], collapse=' ')))
      nl <- nl[!s]
    }
    
    for(n in nl) {
      if(.SV4.)
        attr(object[[n]],'label') <- labels[[n]]
      else
        label(object[[n]]) <- labels[[n]]
    }
  }

  if(length(units)) {
    ##if(!is.list(units))stop('units must be a list')
    nu <- names(units)
    s <- nu %nin% no
    if(any(s)) {
      warning(paste('The following variables in units= are not in object:',
                    paste(nu[s], collapse=' ')))
      nu <- nu[!s]
    }
    for(n in nu)
      attr(object[[n]],'units') <- units[[n]]
  }

  cat('New object size:\t',object.size(object),'bytes;\t',
      length(no),'variables\n')
  ## if(.R.) object <- structure(object, class='data.frame', row.names=rnames)
  object
}

dataframeReduce <- function(data, fracmiss=1, maxlevels=NULL,
                            minprev=0, pr=TRUE)
  {
    g <- function(x, fracmiss, maxlevels, minprev)
      {
        if(is.matrix(x))
          {
            f <- mean(is.na(x %*% rep(1,ncol(x))))
            return(if(f > fracmiss)
                   paste('fraction missing>',fracmiss,sep='') else '')
          }
        h <- function(a, b)
          if(a=='') b else if(b=='') a else paste(a, b, sep=';')
        f <- mean(is.na(x))
        x <- x[!is.na(x)]
        n <- length(x)
        r <- if(f > fracmiss)
          paste('fraction missing>',fracmiss,sep='') else ''
        if(is.character(x)) x <- factor(x)
        if(length(maxlevels) && is.category(x) &&
           length(levels(x)) > maxlevels)
          return(h(r, paste('categories>',maxlevels,sep='')))
        s <- ''
        if(is.category(x) || length(unique(x))==2)
          {
            tab <- table(x)
            if((min(tab) / n) < minprev)
              {
                if(is.category(x))
                  {
                    x <- combine.levels(x, minlev=minprev)
                    s <- 'grouped categories'
                    if(length(levels(x)) < 2)
                      s <- paste('prevalence<', minprev, sep='')
                  }
                else s <- paste('prevalence<', minprev, sep='')
              }
          }
        h(r, s)
      }
    h <- sapply(data, g, fracmiss, maxlevels, minprev)
    if(all(h=='')) return(data)
    if(pr)
      {
        cat('\nVariables Removed or Modified\n\n')
        print(data.frame(Variable=names(data)[h!=''],
                         Reason=h[h!=''], row.names=NULL, check.names=FALSE))
        cat('\n')
      }
    s <- h=='grouped categories'
    if(any(s)) for(i in which(s))
      data[[i]] <- combine.levels(data[[i]], minlev=minprev)
    if(any(h != '' & !s)) data <- data[h=='' | s]
    data
  }

exportDataStripped <-
  if(.R.) function(data, ...) {
    stop('function not available for R')
  } else function(data, ...) {
    for(i in 1:length(data)) {
      atr <- attributes(data[[i]])
      if(any(names(atr) %in% c('label','imputed','format','units'))) {
        attr(data[[i]],'label') <- attr(data[[i]],'imputed') <-
          attr(data[[i]],'format') <- attr(data[[i]],'units') <-
            attr(data[[i]],'comment') <- NULL
      }
    }
    
    exportData(data, ...)
  }

if(.R.) {
  spss.get <- function(file, lowernames=FALSE,
                       datevars=NULL,
                       use.value.labels=TRUE,
                       to.data.frame=TRUE,
                       max.value.labels=Inf,
                       force.single=TRUE, allow=NULL, charfactor=FALSE)
  {
    require('foreign')
    if(length(grep('http://', file))) {
      tf <- tempfile()
      download.file(file, tf, mode='wb', quiet=TRUE)
      file <- tf
    }

    w <- read.spss(file, use.value.labels=use.value.labels,
                   to.data.frame=to.data.frame,
                   max.value.labels=max.value.labels)

    a   <- attributes(w)
    vl  <- a$variable.labels
    nam <- a$names
    nam <- makeNames(a$names, unique=TRUE, allow=allow)
    if(lowernames) nam <- casefold(nam)
    names(w) <- nam

    lnam <- names(vl)
    if(length(vl))
      for(i in 1:length(vl)) {
        n <- lnam[i]
        lab <- vl[i]
        if(lab != '' && lab != n) label(w[[i]]) <- lab
      }

    attr(w, 'variable.labels') <- NULL
    if(force.single || length(datevars) || charfactor)
      for(v in nam) {
        x <- w[[v]]
        changed <- FALSE
        if(v %in% datevars) {
          x <- importConvertDateTime(x, 'date', 'spss')
          changed <- TRUE
        } else if(all(is.na(x))) {
          storage.mode(x) <- 'integer'
          changed <- TRUE
        } else if(!(is.factor(x) || is.character(x))) {
          if(all(is.na(x))) {
            storage.mode(x) <- 'integer'
            changed <- TRUE
          } else if(max(abs(x),na.rm=TRUE) <= (2^31-1) &&
                    all(floor(x) == x, na.rm=TRUE)) {
            storage.mode(x) <- 'integer'
            changed <- TRUE
          }
        } else if(charfactor && is.character(x)) {
          if(max(nchar(x)) >= 2 && (length(unique(x)) < .5*length(x))) {
            x <- factor(x)
            changed <- TRUE
          }
        }

        if(changed) w[[v]] <- x
      }

    w
  }

  NULL
}

if(.R.) {               
  sasxport.get <- function(file, force.single=TRUE,
                           method=c('read.xport','dataload','csv'),
                           formats=NULL, allow=NULL, out=NULL,
                           keep=NULL, drop=NULL, as.is=0.5, FUN=NULL)
  {
    method <- match.arg(method)
    if(length(out) && method!='csv')
      stop('out only applies to method="csv"')

    if(method != 'csv')
      require('foreign') || stop('foreign package is not installed')

    rootsoftware <- if(method=='dataload')'dataload'
                    else 'sas'

    sasdateform <-
      toupper(c("date","mmddyy","yymmdd","ddmmyy","yyq","monyy",
                "julian","qtr","weekdate","weekdatx","weekday","month"))
    sastimeform     <- toupper(c("hhmm","hour","mmss","time"))
    sasdatetimeform <- toupper(c("datetime","tod"))

    if(length(grep('http://', file))) {
      tf <- tempfile()
      download.file(file, tf, mode='wb', quiet=TRUE)
      file <- tf
    }

    dsinfo <-
      if(method == 'csv') lookupSASContents(file)
      else lookup.xport(file)

    whichds <-
      if(length(keep))
        keep
      else
        setdiff(names(dsinfo), c(drop,'_CONTENTS_','_contents_'))
    
  ds <- switch(method,
               read.xport= read.xport(file),
               dataload  = read.xportDataload(file, whichds),
               csv       = if(!length(out))
                             readSAScsv(file, dsinfo, whichds))

    if(method=='read.xport' && (length(keep) | length(drop)))
      ds <- ds[whichds]
  
    ## PROC FORMAT CNTLOUT= dataset present?
    fds <- NULL
    if(!length(formats)) {
      fds <- sapply(dsinfo, function(x)
                    all(c('FMTNAME','START','END','MIN','MAX','FUZZ')
                        %in% x$name))
      fds <- names(fds)[fds]
      if(length(fds) > 1) {
        warning('transport file contains more than one PROC FORMAT CNTLOUT= dataset; using only the first')
        fds <- fds[1]
      }
    }
  
    finfo <- NULL
    if(length(formats) || length(fds)) {
      finfo <-
        if(length(formats))
          formats
        else if(length(out))
          readSAScsv(file, dsinfo, fds)
        else ds[[fds]]

      ## Remove leading $ from char format names
      ##  fmtname <- sub('^\\$','',as.character(finfo$FMTNAME))
      fmtname <- as.character(finfo$FMTNAME)
      finfo <- split(finfo[c('START','END','LABEL')], fmtname)
      finfo <- lapply(finfo,
                      function(f)
                      {
                        rb <- function(a)
                        {  # remove leading + trailing blanks
                          a <- sub('[[:space:]]+$', '', as.character(a))
                          sub('^[[:space:]]+', '', a)
                        }

                        st <- rb(f$START)
                        en <- rb(f$END)
                        lab <- rb(f$LABEL)
                        ##j <- is.na(st) | is.na(en)
                        ##  st %in% c('','.','NA') | en %in% c('','.','NA')
                        j <- is.na(st) | is.na(en) | st == '' | en == ''
                        if(any(j)) {
                          warning('NA in code in FORMAT definition; removed')
                          st <- st[!j]; en <- en[!j]; lab <- lab[!j]
                        }

                        if(!all(st==en))
                          return(NULL)

                        list(value = all.is.numeric(st, 'vector'),
                             label = lab)
                      })
    }

    ## Number of non-format datasets
    nods <- length(whichds)
    nds  <- nods - (length(formats) == 0 && length(finfo) > 0)
    which.regular <- setdiff(whichds, fds)
    dsn <- tolower(which.regular)
  
    if((nds > 1) && !length(out)) {
      res <- vector('list', nds)
      names(res) <- gsub('_','.',dsn)
    }

    if(length(FUN)) {
      funout <- vector('list', length(dsn))
      names(funout) <- gsub('_','.',dsn)
    }
    possiblyConvertChar <- (is.logical(as.is) && !as.is) ||
    (is.numeric(as.is) && as.is > 0)
    j <- 0
    for(k in which.regular) {
      j   <- j + 1
      cat('Processing SAS dataset', k, '\t ')
      w   <-
        if(length(out))
          readSAScsv(file, dsinfo, k)
        else if(nods==1)
          ds
        else ds[[k]]

      cat('.')
      if(!length(w)) {
        cat('Empty dataset', k, 'ignored\n')
        next
      }

      nam      <- tolower(makeNames(names(w), allow=allow))
      names(w) <- nam
      dinfo    <- dsinfo[[k]]
      fmt      <- sub('^\\$','',dinfo$format)
      lab      <- dinfo$label
      ndinfo   <- tolower(makeNames(dinfo$name, allow=allow))
      names(lab) <- names(fmt) <- ndinfo
      for(i in 1:length(w)) {
        changed <- FALSE
        x  <- w[[i]]
        fi <- fmt[nam[i]]; names(fi) <- NULL
        if(fi != '' && length(finfo) && (fi %in% names(finfo))) {
          f <- finfo[[fi]]
          if(length(f)) {  ## may be NULL because had a range in format
            x <- factor(x, f$value, f$label)
            attr(x, 'format') <- fi
            changed <- TRUE
          }
        }

        if(is.numeric(x)) {
          if(fi %in% sasdateform) {
            x <- importConvertDateTime(x, 'date', rootsoftware)
            changed <- TRUE
          } else if(fi %in% sastimeform) {
            x <- importConvertDateTime(x, 'time', rootsoftware)
            changed <- TRUE
          } else if(fi %in% sasdatetimeform) {
            x <- importConvertDateTime(x, 'datetime', rootsoftware)
            changed <- TRUE
          } else if(force.single) {
            if(all(is.na(x))) {
              storage.mode(x) <- 'integer'
              changed <- TRUE
            } else if(max(abs(x),na.rm=TRUE) <= (2^31-1) &&
                      all(floor(x) == x, na.rm=TRUE)) {
              storage.mode(x) <- 'integer'
              changed <- TRUE
            }
          }
        } else if(possiblyConvertChar && is.character(x)) {
          if((is.logical(as.is) && !as.is) || 
             (is.numeric(as.is) && length(unique(x)) < as.is*length(x))) {
            x <- factor(x, exclude='')
            changed <- TRUE
          }
        }

        lz <- lab[nam[i]]
        if(lz != '') {
          names(lz) <- NULL
          label(x)  <- lz
          changed   <- TRUE
        }
      
        if(changed)
          w[[i]] <- x
      }

      cat('.\n')
      if(length(out)) {
        nam <- gsub('_','.',dsn[j])
        assign(nam, w)
        ## ugly, but a way to get actual data frame name into first
        ## argument of save( )
        eval(parse(text=paste('save(',nam,', file="',
                              paste(out, '/', nam,'.rda',sep=''),
                              '", compress=TRUE)',sep='')))
        if(length(FUN) && length(w))
          funout[[nam]] <- FUN(w)

        remove(nam)
      } else if(nds > 1)
        res[[j]] <- w
    }

    if(length(out)) {
      names(dsinfo) <- gsub('_','.',tolower(names(dsinfo)))
      if(length(FUN))
        attr(dsinfo, 'FUN') <- funout

      invisible(dsinfo)
    } else if(nds > 1)
      res
    else w
  }

  ## Use dataload program to create a structure like read.xport does
  read.xportDataload <- function(file, dsnames) {
    outf <- substring(tempfile(tmpdir=''),2)
    file.copy(file, paste(tempdir(),outf,sep='/'))
    curwd <- getwd()
    on.exit(setwd(curwd))
    setwd(tempdir())
    n <- length(dsnames)
    w <- vector('list', n); names(w) <- dsnames
    for(a in dsnames) {
      status <- sys(paste('dataload', outf, 'zzzz.rda', a),
                    output=FALSE)
      if(status==0) {
        load('zzzz.rda')
        names(zzzz) <- makeNames(names(zzzz))
        w[[a]] <- zzzz
      }
    }

    w
  }

  ## Read _contents_.csv and store it like lookup.xport output
  lookupSASContents <- function(sasdir)
  {
    w <- read.csv(paste(sasdir,'_contents_.csv',sep='/'), as.is=TRUE)
    z <- tapply(w$NOBS, w$MEMNAME, function(x)x[1])
    if(any(z == 0)) {
      cat('\nDatasets with 0 observations ignored:\n')
      print(names(z)[z == 0], quote=FALSE)
      w <- subset(w, NOBS > 0)
    }

    w$TYPE <- ifelse(w$TYPE==1, 'numeric', 'character')
    names(w) <- tolower(names(w))
    unclass(split(subset(w,select=-c(memname,memlabel)), w$memname))
  }

  ## Read all SAS csv export files and store in a list
  readSAScsv <- function(sasdir, dsinfo, dsnames=names(dsinfo)) {
    sasnobs <- sapply(dsinfo, function(x)x$nobs[1])
    multi <- length(dsnames) > 1
    if(multi) {
      w <- vector('list', length(dsnames))
      names(w) <- dsnames
    }

    for(a in dsnames) {
      z <- read.csv(paste(sasdir,'/',a,'.csv', sep=''),
                    as.is=TRUE, blank.lines.skip=FALSE,
                    comment.char="")

      importedLength <- length(z[[1]])
      if(importedLength != sasnobs[a])
        cat('\nError: NOBS reported by SAS (',sasnobs[a],') for dataset ',
            a,' is not the same as imported length (', importedLength,
            ')\n', sep='')

      if(multi)
        w[[a]] <- z
    }

    if(multi)
      w
    else z
  }

  NULL
}


csv.get <- function(file, lowernames=FALSE, datevars=NULL, datetimevars=NULL,
                    dateformat='%F', fixdates=c('none','year'),
                    comment.char = "", autodates=TRUE, allow=NULL,
                    charfactor=FALSE,
                    sep=',', skip=0, vnames=NULL, labels=NULL, ...)
{
  fixdates <- match.arg(fixdates)
  if(length(vnames))
    vnames <- scan(file, what=character(0), skip=vnames-1, nlines=1,
                   sep=sep, quiet=TRUE)
  if(length(labels))
    labels <- scan(file, what=character(0), skip=labels-1, nlines=1,
                   sep=sep, quiet=TRUE)

  w <- if(length(vnames))
    read.csv(file, check.names=FALSE, comment.char=comment.char,
             header=FALSE, col.names=vnames, skip=skip, sep=sep, ...)
  else read.csv(file, check.names=FALSE, comment.char=comment.char,
                sep=sep, skip=skip, ...)
  n <- nam <- names(w)
  m <- makeNames(n, unique=TRUE, allow=allow)
  if(length(labels)) n <- labels
  if(lowernames)
    m <- casefold(m)
  
  changed <- any(m != nam)
  if(changed)
    names(w) <- m

  if(autodates) {
    tmp <- w
    names(tmp) <- NULL

    for(i in 1:length(tmp)) {
      if(! is.character(tmp[[1]]))
        next
    }
  }
  cleanup.import(w,
                 labels=if(length(labels))labels else if(changed)n else NULL,
                 datevars=datevars, datetimevars=datetimevars,
                 dateformat=dateformat,
                 fixdates=fixdates, charfactor=charfactor)
}


sasdsLabels <- function(file)
{
  w <- scan(file, sep='\n', what='', quiet=TRUE)
  i <- grep('Data Set Name:', w)
  if(!length(i))
    return(NULL)
  
  n <- tolower(sub('.*\\.([A-Z0-9\\_]*)[[:space:]]+.*','\\1',w[i]))
  w <- gsub('\t','',w)
  labs <- ifelse(nchar(w[i-1])==0,w[i-2],w[i-1])
  names(labs) <- n
  labs
}
## $Id: scat1d.s 208 2005-07-12 22:01:34Z dupontct $
## -*-S-*- Improvements due to Martin Maechler <maechler@stat.math.ethz.ch>

scat1d <- function(x, side=3, frac=.02, jitfrac=.008, tfrac, 
                   eps=ifelse(preserve,0,.001),
                   lwd=0.1, col=par('col'), y=NULL, curve=NULL,
                   bottom.align=FALSE, preserve=FALSE, fill=1/3, limit=TRUE, 
                   nhistSpike=2000, nint=100, 
                   type=c('proportion','count','density'),
                   grid=FALSE,
                   ...)
{
  type <- match.arg(type)
  if(length(x) >= nhistSpike)
    return(histSpike(x, side=side, type=type,
                     frac=2.5*frac, col=col, y=y, curve=curve,
                     bottom.align=if(type=='density') TRUE else bottom.align, 
                     add=TRUE, nint=nint, grid=grid, ...))

  gfun <- ordGridFun(grid)

  if(side==1 || side==3 || length(y) || length(curve)) {
    l <- 1:2;
    ax <- 1
  } else {
    l <- 3:4;
    ax <- 2
  }

  pr <- parGrid(grid)
  usr <- pr$usr; pin <- pr$pin; uin <- pr$uin

  u <- usr[l]
  u.opp <- usr[-l]
  w <- u[2]-u[1]
  ## Start JOA 12.8.97 : handle xy missings parallel
  if (length(y)>1){ ## length=1 special case needed for datadensity
    if (length(x)!=length(y))
      stop("y must have same length as x (or length(y)=1)")

    selector <- !(is.na(x)|is.na(y))
    x <- oldUnclass(x[selector])
    y <- oldUnclass(y[selector])
  } else x <- oldUnclass(x[!is.na(x)]) ## unclass 29Jul97
  ## Stop JOA 12.8.97
  
  if(length(curve))
    y <- approx(curve, xout=x, rule=2)$y   #31Dec98

  n <- length(x)
  if(missing(tfrac))
    tfrac <- if(n<125) 1
             else max(.1, 125/n)
  else if (tfrac < 0 || tfrac > 1)
    stop("must have  0 <= tfrac <= 1")

  ## Start JOA 19.8.97
  if(jitfrac>0 && any(duplicated( if(eps>0) round(x/w/eps) else x )))
    if (preserve)
      x <- jitter2(x, fill=fill, limit=limit, eps=w*eps)
    else
      ## Stop JOA 19.8.97
      x <- x + runif(n, -w*jitfrac, w*jitfrac)

  ##  h <- (u.opp[2]-u.opp[1])*frac*min(fin)/fin[-ax]
  h <- min(pin)*frac/uin[-ax]
  if(length(y)) {
    a <- y - h/2;
    b <- y + h/2
  } else {
    a <- if(side<3) u.opp[1]
         else u.opp[2]-h

    b <- if(side<3) u.opp[1]+h
    else u.opp[2]
  }
  
  if(tfrac<1) {
    l <- tfrac*(b-a)
    a <- a + runif(n)*(b-l-a)   ##runif(n, a, b-l) if frac>0
    b <- a+l
  }

  if(ax==1 && bottom.align) {
    a <- a + h/2;
    b <- b + h/2
  }

  if(ax==1)
    gfun$segments(x, a, x, b, lwd=lwd, xpd=frac<0, col=col)
  else
    gfun$segments(a, x, b, x, lwd=lwd, xpd=frac<0, col=col)

  invisible()
}


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

jitter2.default <- function(x, fill=1/3, limit=TRUE, eps=0,
                            presorted=FALSE, ...)
{ 
  x2 <- x[!is.na(x)]
  if (!presorted){
    o <- order(x2);
    x2 <- x2[o]
  }

  if (eps>0)
    r <- rle(round(x2/eps)*eps)
  else
    r <- rle(x2)

  if ( length(r$length)<2 || max(r$length)<2 )
    return(x)

  d <- abs(diff(r$values))
  d <- pmin( c(d[1],d), c(d,d[length(d)]) )
  who <- rep(r$lengths>1,r$lengths)
  d <- d[r$lengths>1]*fill/2
  if (is.logical(limit) && limit)
    limit <- min(d)

  if (limit)
    d <- pmin(d,limit)

  r$values <- r$values[r$lengths>1]-d
  r$lengths <- r$lengths[r$lengths>1]
  d <- d*2/(r$lengths-1)
  k <- length(r$lengths)
  n <- sum(who)
  val <- rep(r$values,r$lengths)
  add <- (0:(n-1))-rep(c(0,cumsum(r$lengths[-k])),r$lengths)
  add <- add[order(rep(1:k,r$lengths),runif(n))]
  add <- add * rep(d,r$lengths)
  val <- val + add
  x2[who] <- val
  if (!presorted)
    x2[o]<-x2

  x[!is.na(x)] <- x2
  x
}


jitter2.data.frame <- function(x, ...)
{
  as.data.frame(lapply(x,
                       function(z,...)
                       {
                         if (is.numeric(z))
                           jitter2.default(z,...)
                         else z
                       },
                       ...))
}


datadensity <- function(object, ...) {  ## 7Nov00
  if(!length(oldClass(object)))
    oldClass(object) <- data.class(object)

  UseMethod('datadensity')
}

datadensity.data.frame <-
  function(object, group,
           which=c('all','continuous','categorical'),
           method.cat=c('bar','freq'),
           col.group=1:10,
           n.unique=10, show.na=TRUE, nint=1, naxes,
           q, bottom.align=nint>1,
           cex.axis=sc(.5,.3), cex.var=sc(.8,.3),
           lmgp=NULL,   tck=sc(-.009,-.002),
           ranges=NULL, labels=NULL, ...)
{
  which <- match.arg(which)
  method.cat <- match.arg(method.cat)
  maxna <- 0
  mgroup <- missing(group)  # before R changes it

  z <-
    sapply(object,
           function(x, n.unique)
           {
             xp <- x[!is.na(x)] # 7jun03 and next;unique not handle empty factor var
             nu <- if(length(xp)) length(unique(xp))
                   else 0 # 18Oct01+next

             if(nu < 2)
               c(0,0)
             else
               c(type=if(is.category(x) || is.character(x) || nu < n.unique)
                        1
                      else 2,
                 na=sum(is.na(x)))
           },
           n.unique=n.unique)

  types <- c('nil','cat','cont')[z[1,]+1]  # was unlist(z[1,]) unlist(z[2,])
  numna <- z[2,]
  fnumna <- format(numna)
  maxna <- max(numna)

  w <- switch(which,
              all        = types != 'nil',   # 18Oct01
              continuous = types == 'cont',
              categorical= types == 'cat')

  if(missing(naxes)) naxes <- sum(w)

  ## Function to scale values such that when naxes<=3 get hi, >=50 get
  ## lo, otherwise linearly interpolate between 3 and 50
  sc <- function(hi,lo,naxes)
    approx(c(50,3),c(lo,hi),xout=naxes,rule=2)$y

  formals(sc) <- list(hi=NA,lo=NA,naxes=naxes)
  nams <- names(object)
  max.length.name <- max(nchar(nams))

  if(!length(lmgp))
    lmgp <-
      if(.R.)
        if(version$minor=='5.1')
          sc(-.2,-.625)
        else
          sc(0,0)
      else
        sc(.3,0)

  oldpar <- oPar()  # in Hmisc Misc.s
  mgp  <- c(0,lmgp,0)   # 18Oct01, for axis

  mai  <- oldpar$mai
  if(.R.) {
    plot.new();
    par(new=TRUE)
  } # enables strwidth

  mxlb <-  .1 + max(strwidth(nams, units='inches', cex=cex.var))
  mai[2] <- mxlb
  if(!show.na) maxna <- 0
  max.digits.na <- if(maxna==0) 0
                   else trunc(log10(maxna))+1

  if(maxna > 0)
    mai[4] <- .1 + strwidth('Missing',units='inches',cex=cex.var)

  par(mgp=mgp, mai=mai,tck=tck)
  on.exit(setParNro(oldpar))

  if(!mgroup)
    group <- as.factor(group)
  else {
    group <- factor(rep(1,length(object[[1]])))
    ngroup <- 0
  }

  ngroup <- length(levels(group))
  col.group <- rep(col.group, length=ngroup)

  y <- 0
  for(i in (1:length(nams))[w]) {
    if(y < 1) {
      plot(c(0,1),c(1,naxes),xlim=c(.02,.98),ylim=c(1,naxes),
           xlab='',ylab='',type='n',axes=FALSE)
      usr <- par('usr')
      y <- naxes + 1
      if(maxna > 0) {
        outerText('Missing',
                  y=naxes+strheight('Missing',units='user',cex=cex.var),
                  cex=cex.var)
      }

      charheight <- strheight('X',units='user',cex=.6)  ## par('cxy')[2]
    }

    y <- y - 1
    x <- object[[i]]
    if(types[i] == 'cont' ) {  ## continuous variable
      x <- oldUnclass(x)          ## 29Jul97 - handles dates
      isna <- is.na(x)
      nna  <- sum(isna)
      N <- length(x) - nna
      r <-
        if(length(ranges) && length(ranges[[nams[i]]]))
         ranges[[nams[i]]]
        else
          range(x, na.rm=TRUE)  ## 7Nov00

      p <- pretty(r,
                  if(nint==1)5
                  else nint)

      if(nint < 2)
        p <- c(p[1],p[length(p)]) ##bug in pretty for nint=1

      xmin <- p[1]
      xmax <- p[length(p)]
      if(.R.)
        cex <- par(cex=cex.axis)  # Bug in R: cex= ignored in
                                        # axis( )

      axis(side=1, at=(p-xmin)/(xmax-xmin), labels=format(p),
           pos=y, cex=cex.axis)   # 18Oct01

      if(.R.) par(cex=cex)
      if(mgroup)
        scat1d((x-xmin)/(xmax-xmin), y=y, bottom.align=bottom.align, 
               minf=.075, frac=sc(.02,.005), ...)
      else for(g in 1:ngroup) {
        j <- group==levels(group)[g]
        scat1d((x[j]-xmin)/(xmax-xmin), y=y, bottom.align=bottom.align,
               col=col.group[g], tfrac=if(N<125) 1 else max(.1, 125/N), 
               minf=.075, frac=sc(.02,.005), ...)
      }

      if(!missing(q)) {
        quant <- quantile(x, probs=q, na.rm=nna>0)
        points((quant-xmin)/(xmax-xmin),
               rep(y-.5*charheight,length(q)),
               pch=17, cex=.6)
      }
    } else {  ## character or categorical or discrete numeric
      if(is.character(x)) x <- as.factor(x)
      isna <- is.na(x)
      nna <- sum(isna)

      if(length(group) != length(x)) {  ## 7Nov00
        if(is.data.frame(object))
          stop('length of group must equal length of variables in data frame')

        group <- rep(1, length(x))
      }

      tab <- table(group,x)
      lev <- dimnames(tab)[[2]]
      nl  <- length(lev)
      if(is.numeric(x)) {
        xx <- as.numeric(lev)
        xx <- (xx-min(xx))/(max(xx)-min(xx))
      } else {
        if(sum(nchar(lev)) > 200) 
          lev <- substring(lev, 1, max(1, round(200/length(lev))))

        xx <- (0:(nl-1))/(nl-1)
      }

      if(.R.) {
        cex <- par(cex=cex.axis)
        axis(side=1, at=xx, labels=lev, pos=y, cex=cex.axis, tick=FALSE)
        par(cex=cex)
      } else axis(side=1, at=xx, labels=lev, pos=y, cex=cex.axis, ticks=FALSE)

      lines(c(0,1),c(y,y))
      maxfreq <- max(tab)
      for(g in if(ngroup==0) 1 else 1:ngroup) {
        tabg <- tab[g,]
        if(method.cat=='bar')
	  symbols(xx, y+.4*tabg/maxfreq/2, add=TRUE,
                  rectangles=cbind(.02, .4*tabg/maxfreq), inches=FALSE,
                  col=col.group[g])
	else text(xx, rep(y+.1,nl), format(tabg), cex=cex.axis*sqrt(tab/maxfreq),
                  adj=.5)
      }
    }

    mtext(if(length(labels))labels[i]
          else nams[i],   ## 14Dec01
          2, 0, at = y, srt = 0, cex = cex.var, adj = 1, las=1)
    ## las=1 for R 19Mar01 (also 3 lines down)

    if(show.na && nna > 0) {
      ##mtext(format(nna), 4, line = max.digits.na/3,
      ##at = y, srt = 0, adj = 1, cex = cex.var*.66667, las=1)
      outerText(fnumna[i], y, setAside='Missing', cex=cex.var)
    }
  }
  
  invisible()
}


histSpike <- function(x, side=1, nint=100, frac=.05, minf=NULL,
                      mult.width=1,
                      type=c('proportion','count','density'),
                      xlim=range(x),
                      ylim=c(0,max(f)), xlab=deparse(substitute(x)), 
                      ylab=switch(type,proportion='Proportion',
                                  count     ='Frequency',
                                  density   ='Density'),
                      y=NULL, curve=NULL, add=FALSE, 
                      bottom.align=type=='density', 
                      col=par('col'), lwd=par('lwd'), grid=FALSE, ...)
{
  type <- match.arg(type)
  if(!add && side!=1)
    stop('side must be 1 if add=F')

  if(add && type=='count')
    warning('type="count" is ignored if add=T')

  if(length(y) > 1) {   ## 12Sep00
    if(length(y) != length(x))
      stop('lengths of x and y must match')

    if(length(curve))
      warning('curve ignored when y specified')

    i <- !is.na(x+y)
    curve <- list(x=x[i], y=y[i])
  }

  if(length(curve) && !missing(bottom.align) && bottom.align)
    warning('bottom.align=T specified with curve or y; ignoring bottom.align')

  gfun <- ordGridFun(grid)
  x <- x[!is.na(x)]
  x <- x[x >= xlim[1] & x <= xlim[2]]

  if(type != 'density') {
    if(is.character(nint) || length(x) <= 10) {
      f <- table(x)
      x <- as.numeric(names(f))
    } else {
      ncut <- nint+1
      bins <- seq(xlim[1], xlim[2], length = ncut)
      delta <- (bins[2]-bins[1]) / 2
      f <-
        if(.SV4.)
          table(oldCut(x, c(bins[1]-delta,bins)))
        else
          table(cut(x, c(bins[1]-delta,bins)))

      x <- bins
      j <- f > 0
      x <- x[j]
      f <- f[j]
    }

    if(type=='proportion')
      f <- f / sum(f)
  } else {
    nbar <- logb(length(x), base = 2) + 1
    width <- diff(range(x))/nbar*.75*mult.width
    den <- density(x,width=width,n=200,from=xlim[1],to=xlim[2])
    x <- den$x
    f <- den$y
  }

  if(!add) {
    if(grid)
      stop('add=T not implemented for lattice')

    plot(0, 0, xlim=xlim, ylim=ylim, xlab=xlab, ylab=ylab, type='n')
  }
  ##if(type=='density') lines(x, f, col=col, lwd=lwd) else   12Sep00
  ##   segments(x, 0, x, f, col=col, lwd=lwd)
  ##return(invisible(xlim))
  ##}

  if(side==1 || side==3) {
    l <- 1:2;
    ax <- 1
  } else {
    l <- 3:4;
    ax <- 2
  }

  f <- f / max(f)
  if(length(minf))
    f <- pmax(f, minf)

  pr <- parGrid(grid)
  usr <- pr$usr;
  pin <- pr$pin;
  uin <- pr$uin

  u <- usr[l]
  u.opp <- usr[-l]

  h <- min(pin)*frac/uin[-ax] * f
  if(length(curve) || length(y)) {
    if(length(curve))
      y <- approx(curve, xout=x, rule=2)$y

    a <- y - h/2; b <- y + h/2
  } else {
    a <- if(side<3) u.opp[1]
         else u.opp[2]-h

    b <- if(side<3) u.opp[1]+h
         else u.opp[2]
  }

  if(ax==1 && bottom.align && type!='density') {
    a <- a + h/2;
    b <- b + h/2
  }

  if(type=='density') {
    lll <- gfun$lines
    ## Problem in S+ getting right value of lwd
    if(ax==1)
      do.call('lll',list(x,
                         if(side==1)b
                         else a,
                         lwd=lwd,  col=col))
    else
      do.call('lll',list(if(side==2)b
                         else a,
                         x, lwd=lwd, col=col))
  } else {
    lll <- gfun$segments
    if(ax==1)
      do.call('lll',list(x, a, x, b, lwd=lwd, xpd=frac<0, col=col))
    else
      do.call('lll',list(a, x, b, x, lwd=lwd, xpd=frac<0, col=col))
  }

  invisible(xlim)
}
score.binary <- function(..., fun=max, points=1:p, 
                         na.rm=funtext=='max', retfactor=TRUE)
{
  x <- list(...)
  p <- length(x)
  nam <- (as.character(sys.call())[-1])[1:p]
  x <- matrix(unlist(x), ncol=p)
  if(!missing(points)) {
    if(length(points)==1)
      points <- rep(points, p)
    if(length(points)!=p)
      stop('wrong length for points')
  }

  x <- x * rep(points, rep.int(nrow(x),p))
  funtext <- as.character(substitute(fun))
  if(funtext=='max' && !missing(points) && retfactor)
    warning('points do not matter for fun=max with retfactor=T\nas long as they are in ascending order')

  if(!missing(retfactor) && retfactor && funtext!='max')
    stop('retfactor=T only applies to fun=max')

  hasNaRm <- FALSE
  if(.R.) {
    if(any(names(as.list(args(fun)))=='na.rm'))
      hasNaRm <- TRUE
  } else fun$na.rm <- na.rm

  xna <- apply(x, 1, function(x) any(is.na(x)))
  x <- if(hasNaRm) apply(x, 1, fun, na.rm=na.rm) else apply(x, 1, fun)

  if(!na.rm)
    x[x==0 & xna] <- NA

  if(retfactor && funtext=='max') 
    factor(x, c(0,points), c("none",nam))
  else x
}
sedit <- function(text, from, to, test=NULL, wild.literal=FALSE)
{
  to <- rep(to, length=length(from))
  for(i in 1:length(text)) {
    s <- text[i]
    if(length(s))
      for(j in 1:length(from)) {
        old <- from[j]
        front <- back <- FALSE
        if(!wild.literal) {
          if(substring(old,1,1)=='^') {
            front <- TRUE;
            old <- substring(old,2)
          }

          if(substring(old,nchar(old))=='$') { 
            back <- TRUE; old <- substring(old, 1, nchar(old)-1)
          }
        }

        new <- to[j]

        lold <- nchar(old)
        if(lold > nchar(s))
          next

        ex.old <- substring(old, 1:lold, 1:lold)
        if(!wild.literal && any(ex.old=='*')) 
          s <- replace.substring.wild(s, old, new, test=test, front=front, back=back)
        else {
          l.s <- nchar(s)
          is <- 1:(l.s-lold+1)
          if(front)
            is <- 1

          ie <- is + lold - 1
          if(back)
            ie <- l.s

          ss <- substring(s, is, ie)
          k <- ss==old
          if(!any(k))
            next

          k <- is[k]
          substring2(s, k, k+lold-1) <- new
        }
      }

    text[i] <- s
  }

  text
}


substring.location <- function(text, string, restrict)
{
  if(length(text)>1)
    stop('only works with a single character string')
  
  l.text <- nchar(text)
  l.string <- nchar(string)
  if(l.string > l.text)
    return(list(first=0,last=0))
  
  if(l.string==l.text)
    return(if(text==string)
             list(first=1,last=l.text)
           else 
             list(first=0,last=0))

  is <- 1:(l.text-l.string+1)
  ss <- substring(text, is, is+l.string-1)
  k <- ss==string
  if(!any(k))
    return(list(first=0,last=0))
  
  k <- is[k]
  if(!missing(restrict))
    k <- k[k>=restrict[1] & k<=restrict[2]]
  
  if(length(k)==0)
    return(list(first=0,last=0))
  
  list(first=k, last=k+l.string-1)
}


## if(version$major < 5)  14Sep00
substring2 <- substring
'substring2<-' <- function(text, first, last=100000, value)
{
  if(is.character(first)) {
    if(!missing(last))
      stop('wrong # arguments')
    
    return(sedit(text, first, value))  ## value was setto 25May01
  }

  lf <- length(first)

  if(length(text)==1 && lf > 1) {
    if(missing(last))
      last <- nchar(text)

    last <- rep(last, length=lf)
    for(i in 1:lf) {
      text <- paste(if(first[i]>1) 
                      substring(text, 1, first[i]-1),
                    value,
                    substring(text, last[i]+1), sep='')

      if(i < lf) {
        j <- (i+1):lf
        w <- nchar(value) - (last[i]-first[i]+1)
        first[j] <- first[j] + w  
        last[j] <- last[j] +  w
      }
    }

    return(text)
  }
  text <- paste(ifelse(first>1,substring(text, 1, first-1),''), value,
                substring(text, last+1), sep='')
  text
}


if(!.R. && !exists('substring<-')) assign('substring<-',substring2)
#!R 25May01

replace.substring.wild <- function(text, old, new, test=NULL, 
                                   front=FALSE, back=FALSE)
{
  if(length(text)>1)
    stop('only works with a single character string')

  if(missing(front) && missing(back)) {
    if(substring(old,1,1)=='^') {
      front <- TRUE;
      old <- substring(old,2)
    }

    if(substring(old, nchar(old))=='$') {
      back <- TRUE
      old <- substring(old, 1, nchar(old)-1)
    }
  }
  if((front || back) && old!='*') 
    stop('front and back (^ and $) only work when the rest of old is *')

  star.old <- substring.location(old,'*')
  if(length(star.old$first)>1)
    stop('does not handle > 1 * in old')
  
  if(sum(star.old$first)==0)
    stop('no * in old')
  
  star.new <- substring.location(new,'*')
  if(length(star.new$first)>1)
    stop('cannot have > 1 * in new')

  if(old=='*' && (front | back)) {
    if(front && back)
      stop('may not specify both front and back (or ^ and $) with old=*')
    
    if(length(test)==0)
      stop('must specify test= with old=^* or *$')
    
    et <- nchar(text)
    if(front) {
      st <- rep(1, et);
      en <- et:1
    } else {
      st <- 1:et;
      en <- rep(et,et)
    }

    qual <- test(substring(text, st, en))
    if(!any(qual))
      return(text)
    
    st <- (st[qual])[1]
    en <- (en[qual])[1]
    text.before <- if(st==1)''
                   else substring(text, 1, st-1)
    
    text.after  <- if(en==et)''
                   else substring(text, en+1, et)
    
    text.star   <- substring(text, st, en)
    new.before.star <-
      if(star.new$first>1) 
        substring(new, 1, star.new$first-1)
      else ''

    new.after.star <- if(star.new$last==length(new))''
                      else substring(new, star.new$last+1)

    return(paste(text.before, new.before.star, text.star, new.after.star,
                 text.after, sep=''))
  }

  old.before.star <- if(star.old$first==1)''
                     else substring(old, 1, star.old$first-1)
  
  old.after.star  <- if(star.old$last==nchar(old))''
                     else substring(old, star.old$first+1)

  if(old.before.star=='')
    loc.before <- list(first=0, last=0)
  else {
    loc.before <- substring.location(text, old.before.star)
    loc.before <- list(first=loc.before$first[1], last=loc.before$last[1])
  }

  if(sum(loc.before$first+loc.before$last)==0)
    return(text)

  loc.after <- if(old.after.star=='') list(first=0, last=0)
               else {
                 la <- substring.location(text, old.after.star, 
                                          restrict=c(loc.before$last+1,1e10))
                 lastpos <- length(la$first)
                 la <- list(first=la$first[lastpos], last=la$last[lastpos])
                 if(la$first+la$last==0)
                   return(text)

                 la
               }

  loc.star <- list(first=loc.before$last+1, 
                   last=if(loc.after$first==0) nchar(text)
                        else loc.after$first-1)
  
  star.text <- substring(text, loc.star$first, loc.star$last)
  if(length(test) && !test(star.text))
    return(text)

  if(star.new$first==0)
    return(paste(if(loc.before$first>1)substring(text,1,loc.before$first-1),
                 new, sep=''))

  new.before.star <- if(star.new$first==1)''
                     else substring(new, 1, star.new$first-1)
  new.after.star  <- if(star.new$last==nchar(new)) ''
                     else substring(new, star.new$first+1)

  paste(if(loc.before$first>1)substring(text,1,loc.before$first-1),
        new.before.star,
        substring(text,loc.star$first,loc.star$last),
        new.after.star,
        if(loc.after$last<nchar(text) && loc.after$last>0) 
          substring(text,loc.after$last+1),
        sep='')
}


## Some functions useful as test= arguments to replace.substring.wild, sedit
numeric.string <- function(string)
{
  ##.Options$warn <- -1  6Aug00
  oldopt <- options(warn=-1)
  on.exit(options(oldopt))
  !is.na(as.numeric(string))
}


all.digits <- function(string)
{
  k <- length(string)
  result <- logical(k)
  for(i in 1:k) {
    st <- string[i]
    ls <- nchar(st)
    ex <- substring(st, 1:ls, 1:ls)
    result[i] <- all(match(ex,c('0','1','2','3','4','5','6','7','8','9'),nomatch=0)>0)
  }
  
  result
}
show.pch <- function(object=par('font'))
{
  plot(0,0,xlim=c(-1,11),ylim=c(0,26),type='n',axes=FALSE,xlab='',ylab='')
  j <- -1
  for(i in 0:253) {
    if(i %% 25==0) {
      j <- j+1;
      k <- 26
    }

    k <- k-1
    points(j, k, pch=i, font=object)
    text(j+.45, k, i)
  }

  invisible()
}


character.table <- function(font=1)
{
  ## Prints numeric equivalents to all latin characters
  ## Usage: graphsheet(orientation = "portrait")
  ##        character.table()
  ## Print the resulting graphsheet.  The printed version doesn't allways
  ## corresponds to the screen display.  The character on line "xy" and column "z"
  ## of the table has code "xyz".
  ## These codes can be used as any other characters. e.g.
  ##  title("\347\340 et \340")
  ## As the command line window of Splus can't print special characters
  ##  cat("\347\340 et \340")
  ## will not print the special characters, at least under 4.5 and under 2000.
  ##
  ## Author:
  ## Pierre Joyet / Aktuariat                  pierre.joyet@bluewin.ch

  v <- 40:377
  v <- v[v %% 100 < 80 & v %% 10 < 8]
  par(mar = c(5, 5, 4, 2) + 0.1)
  plot(0:7, seq(4, 31, length = 8), type = "n", axes = FALSE, xlab = "",
       ylab = "")
  k <- 1
  for(i in 4:31)
    for(j in 0:7) {
      text(j, 35 - i, eval(parse(text = paste("\"\\", v[k], "\"",
                                              sep = ""))), font = font)
      k <- k + 1
    }

  text(0:7, rep(33, 7), as.character(0:7), font = 3)
  text(rep(-1, 28), 31:4, as.character(c(4:7, 10:17, 20:27, 30:37)),
       font = 3)
  invisible()
}


show.col <- function(object=NULL)
{
  plot(0,0,xlim=c(-1,10),ylim=c(0,10),type='n',axes=FALSE,xlab='',ylab='')
  j <- -1
  for(i in 0:99) {
    if(i %% 10==0) {
      j <- j+1;
      k <- 10
    }

    k <- k-1
    points(j, k, pch=15, col=i, cex=3)
    text(j+.45, k, i)
  }

  invisible()
}
#FEH version of solve with argument tol passed to qr
#8 Apr 91

solvet <- function(a, b, tol=1e-9)
{
  if(!is.list(a))
    a <- qr(a, tol=tol)

  if(a$rank < ncol(a$qr))
    stop("apparently singular matrix")

  if(missing(b)) {
    b <- a$qr
    db <- dim(b)
    if(diff(db))
      stop("matrix inverse only for square matrices")

    b[] <- rep(c(1, rep(0, db[1])), length = prod(db))
  }

  qr.coef(a, b)
}
##S function somers2
##
##    Calculates concordance probability and Somers'  Dxy  rank  correlation
##    between  a  variable  X  (for  which  ties are counted) and a binary
##    variable Y (having values 0 and 1, for which ties are not  counted).
##    Uses short cut method based on average ranks in two groups.
## 
##    Usage:
## 
##         somers2(X,Y)
##
##    Returns vector whose elements are C Index, Dxy, n and missing, where
##    C Index is the concordance probability and Dxy=2(C Index-.5).
##
##    F. Harrell 28 Nov 90     6 Apr 98: added weights

somers2 <- function(x, y, weights=NULL, normwt=FALSE, na.rm=TRUE)
{
  if(length(y)!=length(x))stop("y must have same length as x")
  y <- as.integer(y)
  wtpres <- length(weights)
  if(wtpres && (wtpres != length(x)))
    stop('weights must have same length as x')

  if(na.rm) {
    miss <- if(wtpres) is.na(x + y + weights)
            else is.na(x + y)

    nmiss <- sum(miss)
    if(nmiss>0)	{
      miss <- !miss
      x <- x[miss]
      y <- y[miss]
      if(wtpres)
        weights <- weights[miss]
    }
  } else nmiss <- 0
		
  u <- sort(unique(y))
  if(any(y %nin% 0:1))
    stop('y must be binary')  ## 7dec02

  if(wtpres) {
    if(normwt)
      weights <- length(x)*weights/sum(weights)

    n <- sum(weights)
  } else n <- length(x)

  if(n<2)
    stop("must have >=2 non-missing observations")

  n1 <- if(wtpres)sum(weights[y==1])
        else sum(y==1)

  if(n1==0 || n1==n)
    return(c(C=NA,Dxy=NA,n=n,Missing=nmiss))  ## 7dec02

  ## added weights > 0 30Mar00
  mean.rank <-
    if(wtpres)
      mean(wtd.rank(x, weights, na.rm=FALSE)[weights > 0 & y==1])
    else 
      mean(rank(x)[y==1])

  c.index <- (mean.rank - (n1+1)/2)/(n-n1)
  dxy <- 2*(c.index-.5)
  r <- c(c.index, dxy, n, nmiss)
  names(r) <- c("C","Dxy","n","Missing")
  r
}


if(FALSE) rcorrs <- function(x, y, weights=rep(1,length(y)),
                             method=c('exact','bin'), nbin=1000,
                             na.rm=TRUE)
{
  ## Experimental function - probably don't need
  
  method <- match.arg(method)
  
  if(na.rm) {
    s <- !is.na(x + oldUnclass(y) + weights)
    x <- x[s]; y <- y[s]; weights <- weights[s]
  }
  
  n <- length(x)
  if(missing(method))
    method <- if(n < 1000) 'exact'
              else 'bin'

  y <- as.category(y);
  nly <- length(levels(y))
  if(method=='bin') {
    r <- range(x); d <- r[2] - r[1]
    x <- 1 + trunc((nbin-1)*(x - r[1])/d)
 
    xy <- y*nbin + x

    ## Code below is lifted from rowsum()
    storage.mode(weights) <- "double"
    temp <-
      if(.R.)
        .C('R_rowsum', dd=as.integer(dd),
           as.double(max(1,weights)*n),
           x=weights, as.double(xy), PACKAGE='base')
      else
        .C("S_rowsum",
           dd = as.integer(c(n,1)),
           as.double(max(1,weights)*n),
           x = weights,
           as.double(xy))   ## 3Jun01

    new.n <- temp$dd[1]
    weights <- temp$x[1:new.n]

    uxy <- unique(xy)
    x <- uxy %% nbin
    y <- (uxy - x)/nbin
    n <- length(x)
  }

  list(x=x, y=y, weights=weights)

  #storage.mode(x) <- "single"
  #storage.mode(y) <- "single"
  #storage.mode(event) <- "logical"

  ## wcidxy doesn't exist yet
  z <- .Fortran("wcidxy",as.single(x),as.single(y),as.integer(weights),as.integer(n),
                nrel=double(1),nconc=double(1),nuncert=double(1),
                c.index=double(1),gamma=double(1),sd=double(1),as.logical(outx))
  r <- c(z$c.index,z$gamma,z$sd,n,z$nrel,z$nconc,z$nuncert)
  names(r) <- c("C Index","Dxy","S.D.","n","missing","uncensored",
                "Relevant Pairs",	"Concordant","Uncertain")
  r
}
## Spearman correlation test (p=1) or Spearman test extended by adding
## rank(x)^2 to model (p=2)
## F Harrell  30Sep90

spearman.test <- function(x,y,p=1)
{
  x <- as.numeric(x);
  y <- as.numeric(y)  ## 17Jul97

  if(length(x)!=length(y))
    stop("length of x must = length of y")

  nomiss <- !is.na(x+y)
  n <- sum(nomiss)
  if(n<3)
    stop("fewer than 3 non-missing x-y pairs")

  if(!(p==1 | p==2))
    stop("p must be 1 or 2")

  x <- x[nomiss]
  x <- rank(x)
  y <- y[nomiss]
  y <- rank(y)
  sst <- sum((y-mean(y))^2)
  if(p==2)
    x <- cbind(x,x^2)

  sse <- sum((lsfit(x,y)$residuals)^2)
  rsquare <- 1-sse/sst
  df2 <- n-p-1
  fstat <- rsquare/p/((1-rsquare)/df2)
  pvalue <- 1-pf(fstat,p,df2)
  x <- c(rsquare,fstat,p,df2,pvalue,n)
  names(x) <- c("Rsquare","F","df1","df2","pvalue","n")
  x
}
spower <- function(rcontrol, rinterv, rcens, nc, ni,
                   test=logrank, nsim=500, alpha=.05, pr=TRUE)
{
  crit <- qchisq(1-alpha, 1)
  group <- c(rep(1,nc), rep(2,ni))
  nexceed <- 0

  for(i in 1:nsim) {
    if(pr && i %% 10 == 0)
      cat(i,'')

    yc <- rcontrol(nc)
    yi <- rinterv(ni)
    cens <- rcens(nc+ni)
    y <- c(yc, yi)
    S <- cbind(pmin(y,cens), 1*(y <= cens))
    nexceed <- nexceed + (test(S, group) > crit)
  }
  nexceed/nsim
}
  

Quantile2 <- function(scontrol, hratio, 
                      dropin=function(times)0, 
                      dropout=function(times)0,
                      m=7500, tmax, qtmax=.001, mplot=200, pr=TRUE,
                      ...)
{
  ## Solve for tmax such that scontrol(t)=qtmax
  dlist <- list(...)
  k <- length(dlist) && !is.null(dlist)
  f    <- if(k) function(x, scontrol, qt, ...) scontrol(x, ...) - qt
          else function(x, scontrol, qt) scontrol(x) - qt

  if(missing(tmax)) {
    if(k) tmax <- uniroot(f, c(0,1e9), scontrol=scontrol, qt=qtmax, ...)$root
    else tmax <- uniroot(f, c(0,1e9), scontrol=scontrol, qt=qtmax)$root
  }

  if(pr)
    cat('\nInterval of time for evaluating functions:[0,',
        format(tmax),']\n\n')

  ## Generate sequence of times to use in all approximations and sequence
  ## to use for plot method

  times <- seq(0, tmax, length=m)
  tim   <- seq(0, tmax, length=mplot)
  tinc  <- times[2]

  ## Approximate hazard function for control group
  sc <- scontrol(times, ...)    
  hc <- diff(-logb(sc))
  hc <- c(hc, hc[m-1])/tinc  ## to make length=m

  ## hazard function for intervention group
  hr <- rep(hratio(times), length=m)
  hi <- hc*hr

  ## hazard for control group with dropin
  di  <- rep(dropin(times),length=m)
  hc2 <- (1-di)*hc + di*hi

  ## hazard for intervention group with dropout
  do  <- rep(dropout(times),length=m)
  hi2 <- (1-do)*hi + do*hc

  ## survival for intervention group
  si  <- exp(-tinc*cumsum(hi))

  ## Compute contaminated survival function for control and intervention
  sc2 <- if(any(di>0))exp(-tinc*cumsum(hc2))
         else sc

  si2 <- exp(-tinc*cumsum(hi2))
  

  ## Store all functions evaluated at shorter times vector (tim), for
  ## plotting
  asing <- if(.R.)function(x)x
           else as.single

  sc.p  <- asing(approx(times, sc,  xout=tim)$y)
  hc.p  <- asing(approx(times, hc,  xout=tim)$y)
  sc2.p <- asing(approx(times, sc2, xout=tim)$y)
  hc2.p <- asing(approx(times, hc2, xout=tim)$y)
  
  si.p  <- asing(approx(times, si,  xout=tim)$y)
  hi.p  <- asing(approx(times, hi,  xout=tim)$y)
  si2.p <- asing(approx(times, si2, xout=tim)$y)
  hi2.p <- asing(approx(times, hi2, xout=tim)$y)

  dropin.p  <- asing(approx(times, di, xout=tim)$y)
  dropout.p <- asing(approx(times, do, xout=tim)$y)
  hratio.p  <- asing(approx(times, hr, xout=tim)$y)
  hratio2.p <- hi2.p/hc2.p

  tim       <- asing(tim)

  plot.info <- list("C Survival"                   =list(Time=tim,Survival=sc.p),
                    "I Survival"                   =list(Time=tim,Survival=si.p),
                    "C Survival w/Dropin"          =list(Time=tim,Survival=sc2.p),
                    "I Survival w/Dropout"         =list(Time=tim,Survival=si2.p),
                    "C Hazard"                     =list(Time=tim,Hazard=hc.p),
                    "I Hazard"                     =list(Time=tim,Hazard=hi.p),
                    "C Hazard w/Dropin"            =list(Time=tim,Hazard=hc2.p),
                    "I Hazard w/Dropout"           =list(Time=tim,Hazard=hi2.p),
                    "Dropin"                       =list(Time=tim,Probability=dropin.p),
                    "Dropout"                      =list(Time=tim,Probability=dropout.p),
                    "Hazard Ratio"                 =list(Time=tim,Ratio=hratio.p),
                    "Hazard Ratio w/Dropin+Dropout"=list(Time=tim,Ratio=hratio2.p))

  ## Create S-Plus functions for computing random failure times for
  ## control and intervention subject to dropin, dropout, and hratio

  r <- function(n, what=c('control','intervention'), 
                times, csurvival, isurvival)
  {
    what <- match.arg(what)
    approx(if(what=='control')csurvival
           else isurvival, 
           times, xout=runif(n), rule=2)$y
  }

  asing <- if(.R.)function(x)x
           else as.single

  formals(r) <- list(n=integer(0),
                     what=c('control','intervention'),
                     times=asing(times), csurvival=asing(sc2),
                     isurvival=asing(si2))

  structure(r, plot.info=plot.info, 
            dropin=any(di>0), dropout=any(do>0),
            class='Quantile2')
}


print.Quantile2 <- function(x, ...)
{
  attributes(x) <- NULL
  print(x)
  invisible()
}

plot.Quantile2 <- function(x, 
                           what=c('survival','hazard','both','drop','hratio',
                                  'all'), dropsep=FALSE,
                           lty=1:4, col=1, xlim, ylim=NULL, 
                           label.curves=NULL, ...)
{
  what <- match.arg(what)
  pi <- attr(x, 'plot.info')
  if(missing(xlim))
    xlim <- c(0,max(pi[[1]][[1]]))

  dropin  <- attr(x, 'dropin')
  dropout <- attr(x, 'dropout')
  i <- c(1,2,
         if(dropin)3,
         if(dropout)4)

  if(what %in% c('survival','both','all')) {
    if(dropsep && (dropin|dropout)) {
      labcurve(pi[1:2], pl=TRUE, lty=lty, col=col, xlim=xlim, ylim=ylim,
               opts=label.curves)
      labcurve(pi[i[-(1:2)]], pl=TRUE, lty=lty, col=col, xlim=xlim, ylim=ylim,
               opts=label.curves)
    } else
      labcurve(pi[i], pl=TRUE, lty=lty, col=col, xlim=xlim, ylim=ylim,
               opts=label.curves)
  }

  if(what %in% c('hazard','both','all')) {
    if(dropsep && (dropin|dropout)) {
      labcurve(pi[5:6], pl=TRUE, lty=lty, col=col, xlim=xlim, ylim=ylim,
               opts=label.curves)
      labcurve(pi[4+i[-(1:2)]], pl=TRUE, lty=lty, col=col, xlim=xlim, ylim=ylim,
               opts=label.curves)
    } else
      labcurve(pi[4+i], pl=TRUE, lty=lty, col=col, xlim=xlim, ylim=ylim,
               opts=label.curves)
  }
  
  if(what=='drop' || (what=='all' && (dropin | dropout))) {
    i <- c(if(dropin)9,
           if(dropout)10)

    if(length(i)==0)
      i <- 10

    labcurve(pi[i], pl=TRUE, lty=lty, col=col, xlim=xlim, ylim=ylim,
             opts=label.curves)
  }

  if(what %in% c('hratio','all')) {
    i <- c(11,
           if(dropin|dropout) 12)

    labcurve(pi[i], pl=TRUE, lty=lty, col=col, xlim=xlim, ylim=ylim,
             opts=label.curves)
  }

  invisible()
}

logrank <- function(S, group)
{
  y     <- S[,1]
  event <- S[,2]
  i     <- order(-y)
  y     <- y[i]
  event <- event[i]
  group <- group[i]
  x     <- cbind(group==1, group==2, (group==1)*event, (group==2)*event)
  s     <- rowsumFast(x, y, FALSE)
  nr1 <- cumsum(s[,1])
  nr2 <- cumsum(s[,2])
  d1  <- s[,3]
  d2  <- s[,4]
  rd  <- d1+d2
  rs  <- nr1+nr2-rd
  n   <- nr1+nr2
  oecum <- d1 - rd*nr1/n
  vcum  <- rd * rs * nr1 * nr2 / n / n / (n-1)
  sum(oecum)^2 / sum(vcum,na.rm=TRUE)
}


Weibull2 <- function(times, surv)
{
  z1 <- -logb(surv[1])
  z2 <- -logb(surv[2])
  t1 <- times[1]
  t2 <- times[2]
  gamma <- logb(z2/z1)/logb(t2/t1)
  alpha <- z1/(t1^gamma)
  
  g <- function(times, alpha, gamma)
  {
    exp(-alpha*(times^gamma))
  }

  formals(g) <- list(times=NULL, alpha=alpha, gamma=gamma)
  g
}


## Function to fit a Gompertz survival distribution to two points
## The function is S(t) = exp[-(1/b)exp(a+bt)]
## Returns a list with components a and b, and a function for
## generating S(t) for a vector of times
Gompertz2 <- function(times, surv)
{
  z1 <- logb(-logb(surv[1]))
  z2 <- logb(-logb(surv[2]))
  t1 <- times[1]
  t2 <- times[2]
  b  <- (z2-z1)/(t2-t1)
  a  <- z1 + logb(b)-b*t1
  
  g <- function(times, a, b) {
    exp(-exp(a+b*times)/b)
  }

  formals(g) <- list(times=NULL, a=a, b=b)
  g
}


Lognorm2 <- function(times, surv)
{
  z1 <- qnorm(1-surv[1])
  z2 <- qnorm(1-surv[2])
  sigma <- logb(times[2]/times[1])/(z2-z1)
  mu    <- logb(times[1]) - sigma*z1

  g <- function(times, mu, sigma) {
    1 - pnorm((logb(times)-mu)/sigma)
  }

  formals(g) <- list(times=NULL, mu=mu, sigma=sigma)
  g
}
##Function to source(x) if x is given, or source(last x given) otherwise
##Last x is stored in options() last.source.   x is unquoted with .s omitted.
##Author: Frank Harrell  19May91

src <- function(x) {
  if(!missing(x)) {
    y <- paste(as.character(substitute(x)),".s",sep="")
    options(last.source=y, TEMPORARY=FALSE)
  }
  else y <- options()$last.source

  if(is.null(y))
    stop("src not called with file name earlier")

  source(y)
  cat(y, "loaded\n")
  invisible()
}
if (.R.) {
  stata.get <- function(file, lowernames=FALSE,
                        convert.dates=TRUE, convert.factors=TRUE,
                        missing.type=FALSE, convert.underscore=TRUE,
                        warn.missing.labels=TRUE, force.single=TRUE,
                        allow=NULL, charfactor=FALSE, ...)
  {
    require('foreign')

    ## If file is a url download and set file = to temp file name
    if(length(grep('^http://', file))){
      tf <- tempfile()
      download.file(file, tf, mode='wb', quiet=TRUE)
      file <- tf
    }

    ## Read the stata file into w
    w <- read.dta(file, convert.dates=convert.dates,
                  convert.factors=convert.factors,
                  missing.type=missing.type,
                  convert.underscore=convert.underscore,
                  warn.missing.labels=warn.missing.labels, ...)

    ## extract attributes from w
    a <- attributes(w)

    ## Do translate attributes names into R names
    nam <- a$names
    nam <- makeNames(a$names, unique=TRUE, allow=allow)
    if(lowernames) nam <- casefold(nam)
    names(w) <- nam

    ## Translate var labels into Hmisc var lables
    vl  <- a$var.labels
    vl.len <- length(vl)
    label.table.len <- length(a$label.table)
    
    for(i in seq(along.with=w)) {
      if(a$formats[i] != '') {
        attr(w[[i]],'format') <- a$formats[i]
      }

      if(vl.len) {
        lab <- vl[i]
        
        if(lab != '') {
          label(w[[i]]) <- lab
        }
      }

      if(label.table.len) {
        attr(w[[i]], 'value.label.table') <- a$label.table[[i]]
      }
    }
    
    ## clear var.labels attribute
    attr(w, 'var.labels') <- NULL

    ## convert integer vars to mode integer
    for(v in nam) {
      x <- w[[v]]
      changed <- FALSE
      if(all(is.na(x))) {
        storage.mode(x) <- 'integer'
        changed <- TRUE
      }
      else if(!(is.factor(x) || is.character(x) || inherits(x, 'Date'))) {
        if(all(is.na(x))) {
          storage.mode(x) <- 'integer'
          changed <- TRUE
        }
        else if(force.single && max(abs(x), na.rm=TRUE) <= (2^31-1) &&
                all(floor(x) == x, na.rm=TRUE)) {
          storage.mode(x) <- 'integer'
          changed <- TRUE
        }
      } else if(charfactor && is.character(x)) {
        if(max(nchar(x)) >= 2 && (length(unique(x)) < .5*length(x))) {
          x <- factor(x)
          changed <- TRUE
        }
      }


      if(changed) w[[v]] <- x
    }

    stata.info <- a[c('datalabel','version','time.stamp','val.labels')]
    attributes(w) <- c(a[c('names','row.names','class')],
                       stata.info=list(stata.info))
    return(w)
  }
  NULL
}
##This has code from Bill Dunlap's "set.work" function
if(.R.) {
  store <- function(object, name=as.character(substitute(object)), 
                    where=if(under.unix || .SV4.)".Data"
                          else "_Data")
    stop('function not available for R')

  stores <- function(...) stop('function not available for R')
} else {
  store <- function(object, name=as.character(substitute(object)), 
                    where=if(under.unix || .SV4.)".Data" else "_Data")
  {
    if(missing(object)) {
      ##if(.R.) attach(NULL, name='.GlobalTemp', pos=1)
      temp <- if(under.unix) paste(".Data.temp",
                                   unix("echo $$"), sep="")
              else tempfile()

      sys(paste("mkdir",temp), minimized=FALSE)
      if(.SV4.) sys(paste('mkdir ',temp,
                          if(under.unix)'/'
                          else '\\',
                          '__Meta',sep=''))  ## 20jun02

      attach(temp, 1)
      options(.store.temp=temp, TEMPORARY=FALSE)
      l <- function()
      {
        detach(1, FALSE); 
        sys(paste(if(under.unix)"rm -r" else "deltree /Y",.Options$.store.temp),
            minimized=TRUE)
      }

      assign(".Last", l, where=1)
      return(invisible())
    }

    assign(name,object,where=where,immediate=TRUE)
    invisible()
  }

  stores <- function(...)
  {
    nams <- as.character(sys.call())[-1]
    dotlist <- list(...)
    for(i in 1:length(nams))
      assign(nams[i], dotlist[[i]],
             where=if(under.unix || .SV4.)".Data"
                   else "_Data",
             immediate=TRUE)

    invisible()
  }

  NULL
}


storeTemp <- if(.R.) function(object,
                              name=deparse(substitute(object)))
{
  pos <- match('.GlobalTemp', search())
  if(is.na(pos)) {
    attach(NULL,name='.GlobalTemp')
    pos <- match('.GlobalTemp', search())
  }
  assign(name, object, pos)
  invisible()
} else function(object, name=deparse(substitute(object)))
{
  assign(name, object, frame=0)
  invisible()
}
if(!exists("string.break.line", mode='function')) {
  string.break.line <- function(string) {
    if(! is.character(string)) {
      x <- as.character(string)
    }
    
    ifelse(string == '', '', strsplit(string, '\n', fixed=TRUE))
  }
}
if(!exists('strwrap')) {
  strwrap <- function (x, width = 0.9 * getOption("width"), indent = 0, exdent = 0,
                       prefix = "", simplify = TRUE) {
    indentString <- paste(rep.int(" ", indent), collapse = "")
    exdentString <- paste(rep.int(" ", exdent), collapse = "")
    y <- list()
    z <- lapply(strsplit(x, "\n[ \t\n]*\n"), strsplit, "[ \t\n]")
    for (i in seq(along = z)) {
      yi <- character(0)
      for (j in seq(along = z[[i]])) {
        words <- z[[i]][[j]]
        nc <- nchar(words, type = "w")
        if (any(is.na(nc))) {
          nc0 <- nchar(words)
          nc[is.na(nc)] <- nc0[is.na(nc)]
        }
        if (any(nc == 0)) {
          zLenInd <- which(nc == 0)
          zLenInd <- zLenInd[!(zLenInd %in% (grep("\\.$",
                                                  words) + 1))]
          if (length(zLenInd) > 0) {
            words <- words[-zLenInd]
            nc <- nc[-zLenInd]
          }
        }
        if (length(words) == 0) {
          yi <- c(yi, "", prefix)
          next
        }
        currentIndex <- 0
        lowerBlockIndex <- 1
        upperBlockIndex <- integer(0)
        lens <- cumsum(nc + 1)
        first <- TRUE
        maxLength <- width - nchar(prefix, type = "w") -
          indent
        while (length(lens) > 0) {
          k <- max(sum(lens <= maxLength), 1)
          if (first) {
            first <- FALSE
            maxLength <- maxLength + indent - exdent
          }
          currentIndex <- currentIndex + k
          if (nc[currentIndex] == 0)
            upperBlockIndex <- c(upperBlockIndex, currentIndex -
                                 1)
          else upperBlockIndex <- c(upperBlockIndex, currentIndex)
          if (length(lens) > k) {
            if (nc[currentIndex + 1] == 0) {
              currentIndex <- currentIndex + 1
              k <- k + 1
            }
            lowerBlockIndex <- c(lowerBlockIndex, currentIndex +
                                 1)
          }
          if (length(lens) > k)
            lens <- lens[-(1:k)] - lens[k]
          else lens <- NULL
        }
        nBlocks <- length(upperBlockIndex)
        s <- paste(prefix, c(indentString, rep.int(exdentString,
                                                   nBlocks - 1)), sep = "")
        for (k in (1:nBlocks)) s[k] <- paste(s[k], paste(words[lowerBlockIndex[k]:upperBlockIndex[k]],
                                                         collapse = " "), sep = "")
        yi <- c(yi, s, prefix)
      }
      y <- c(y, list(yi[-length(yi)]))
    }
    if (simplify)
      y <- unlist(y)
    y
  }
}
##Substitute y when element of x is missing
##also return an attribute "substi.source"=vector of var names and NAs
substi <- function(x,y,pr=TRUE)
{
  if(length(x)!=length(y))
    stop("lengths of x and y are different")

  nf <- is.category(x)+is.category(y)
  if(nf==1)
    stop("both x and y must be category variables if either is")

  isna <- is.na(x)
  vnames <- sys.call()[c(2,3)]
  if(pr) {
    cat("Variables:",vnames,"\n")
    cat("Used first  variable:",sum(!is.na(x)),"\n")
    cat("Used second variable:",sum(is.na(x) & !is.na(y)),"\n")
  }

  if(nf) {
    levs <- unique(c(levels(x),levels(y)))
    x <- as.character(x)
    y <- as.character(y)
    x[isna] <- y[isna]
    x <- factor(x,levs)
    y <- factor(y,levs)
  } else
    x[isna] <- y[isna]

  ss <- ifelse(isna & is.na(y),NA,ifelse(isna,2,1))
  attr(ss,"names") <- NULL
  ss <- factor(ss,labels=vnames)
  if(pr)
    cat("Obs:",sum(!is.na(x))," Obs missing:",sum(is.na(x)),"\n")

  attr(x,"substi.source") <- ss
  attr(x,'class') <- c("substi",attr(x,'class'))
  x
}


substi.source <- function(x) attr(x,"substi.source")


"[.substi" <- function(x, ...)
{
  ss <- attr(x,"substi.source")
  ats <- attributes(x)
  ats$dimnames <- ats$dim <- ats$names <- ats$substi.source <-
    attr(x,'class') <- NULL
  x <- (x)[...]
  attributes(x) <- ats
  attr(x,"substi.source") <- ss[...]
  x
}


print.substi <- function(x, ...)
{
  i <- oldUnclass(attr(x, "substi.source"))
  if(!length(i)) {
    print.default(x)
    return(invisible())
  }

  if(is.factor(x))
    w <- as.character(x)
  else w <- format(x)

  names(w) <- names(x)
  w[i==2] <- paste(w[i==2], "*", sep = "")
  attr(w, "label") <- attr(w, "substi.source") <- attr(w, "class") <- NULL
  print.default(w, quote = FALSE)
  invisible()
}


as.data.frame.substi <- function(x, row.names = NULL, optional = FALSE, ...)
{
  nrows <- length(x)
  if(!length(row.names)) {
    ## the next line is not needed for the 1993 version of data.class and is
    ## included for compatibility with 1992 version
    if(length(row.names <- names(x)) == nrows &&
       !any(duplicated(row.names))) {
    }
    else if(optional)
      row.names <- character(nrows)
    else row.names <- as.character(1:nrows)
  }

  value <- list(x)
  if(!optional)
    names(value) <- deparse(substitute(x))[[1]]

  structure(value, row.names=row.names, class='data.frame')
}
## $Id: summary.formula.s 528 2007-07-18 14:47:48Z dupontct $
##note: ars may always be T
summary.formula <-
  function(formula, data, subset, na.action, 
           fun=NULL,
           method=c('response','reverse','cross'),
           overall=method=='response'|method=='cross', 
           continuous=10, na.rm=TRUE, na.include=method!='reverse',
           g=4, 
           quant=c(.025,.05,.125,.25,.375,.5,.625,.75,.875,.95,.975),
           nmin=if(method=='reverse') 100
                else 0,
           test=FALSE,
           conTest=function(group,x) {
             st <- spearman2(group,x)
             list(P=st['P'], stat=st['F'],
                  df=st[c('df1','df2')],
                  testname=if(st['df1']==1)'Wilcoxon'
                           else 'Kruskal-Wallis',
                  statname='F', latexstat='F_{df}',
                  plotmathstat='F[df]')
           },
           catTest=function(tab) {
             st <-
               if(!is.matrix(tab) || nrow(tab) < 2 | ncol(tab) < 2)
                 list(p.value=NA, statistic=NA, parameter=NA)
               else
                 chisq.test(tab, correct=FALSE)

             list(P=st$p.value, stat=st$statistic,
                  df=st$parameter,
                  testname='Pearson', statname='Chi-square',
                  latexstat='\\chi^{2}_{df}',
                  plotmathstat='chi[df]^2')
           },
           ordTest=function(group, x) {
             requirePackage('Design')

             f <- lrm(x ~ group)$stats
             list(P=f['P'], stat=f['Model L.R.'], df=f['d.f.'],
                  testname='Proportional odds likelihood ratio',
                  statname='Chi-square',latexstat='\\chi^{2}_{df}',
                  plotmathstat='chi[df]^2')
           },
           ...)
{
  call <- match.call()
  missmethod <- missing(method)   ## needed for R  9jul02
  method <- match.arg(method)
    
  X <- match.call(expand=FALSE)
  X$fun <- X$method <- X$na.rm <- X$na.include <- X$g <- 
    X$overall <- X$continuous <- X$quant <- X$nmin <- X$test <-
      X$conTest <- X$catTest <- X$... <- NULL
  if(missing(na.action))
    X$na.action <- na.retain

  Terms <- if(missing(data)) terms(formula,'stratify')
           else terms(formula,'stratify',data=data)

  X$formula <- Terms
  X[[1]] <- as.name("model.frame")
    
  X <- eval(X, sys.parent())
  
  Terms <- attr(X,"terms")
  resp <- attr(Terms,"response")
    
  if(resp==0 && missmethod)
    method <- 'reverse'
  
  if(test && method!='reverse')
    stop('test=TRUE only allowed for method="reverse"')

  if(method!='reverse' && resp!=1) 
    stop("must have a variable on the left hand side of the formula")

  nact <- attr(X, "na.action")
  nvar <- ncol(X)-1
  strat <- attr(Terms,'specials')$stratify

  getlab <- function(x, default)
    {
      lab <- attr(x, 'label')
      if(!length(lab) || lab=='') default else lab
    }
  
  if(length(strat)) {
    if(method!='response') 
      stop('stratify only allowed for method="response"')

    temp <- untangle.specials(Terms,'stratify')
    strat.name <- if(.R.) var.inner(Terms)[temp$terms]
                  else attr(terms.inner(Terms),'term.labels')[temp$terms]
    strat <- if(length(temp$vars)==1) as.factor(X[[temp$vars]])
             else stratify(X[,temp$vars])

    strat.label <- getlab(X[,temp$vars[1]], strat.name)

    X[[temp$vars]] <- NULL   # remove strata factors
  } else {
    strat <- factor(rep('',nrow(X)))
    strat.name <- strat.label <- ''
  }

  nstrat <- length(levels(strat))
    
  if(resp>0) {
    Y <- X[[resp]]
    yname <- if(.R.) as.character(attr(Terms,'variables'))[2]
             else as.character(attr(Terms, "variables"))[1]  ## 25May01

    ylabel <- getlab(Y, yname)

    if(!is.matrix(Y))
      Y <- matrix(Y, dimnames=list(names(Y),yname))
  } else {
    yname <- ylabel <- NULL
  }
    
  if(method!='reverse') {
    if(!length(fun)) {   # was missing(fun) 25May01
      fun <- function(y) apply(y, 2, mean)

      uy <- unique(Y[!is.na(Y)])  # fixed 16Mar96
      r <- range(uy, na.rm=TRUE)
      funlab <- if(length(uy)==2 && r[1]==0 & r[2]==1) "Fraction"
                else "Mean"

      funlab <- paste(funlab, 'of', yname)
    } else if(is.character(fun) && fun=='%') {
      fun <- function(y)
      {
        stats <- 100*apply(y, 2, mean)
        names(stats) <- paste(dimnames(y)[[2]],'%')
        stats
      }

      funlab <- paste('% of', yname)
    }

    ## Compute number of descriptive statistics per cell
    s <-
      if(inherits(Y,'Surv'))
        as.vector((1 * is.na(unclass(Y))) %*% rep(1, ncol(Y)) > 0)
      else
        ((if(is.character(Y)) Y==''|Y=='NA'
          else is.na(Y)) %*%
         rep(1,ncol(Y))) > 0
    
    ## Was is.na.Surv, is.Surv 30May01
    stats <- if(length(dim(Y))) fun(Y[!s,,drop=FALSE])
             else fun(Y[!s])

    nstats <- length(stats)
    name.stats <-
      if(length(dn <- dimnames(stats))==2)
        as.vector(outer(dn[[1]],dn[[2]],FUN=function(a,b)paste(b,a)))
      else
        names(stats)

    if(length(fun)) {
      if(length(de <- deparse(fun)) == 2) {
        de <- as.list(fun)
        de <- as.character(de[[length(de)]])
        funlab <- if(de[1] == 'apply') de[length(de)]
                  else de[1]

        ## 2nd case is for simple function(x)mean(x) function
      } else funlab <- as.character(substitute(fun))
    }

    if(funlab[1]=='')
      funlab <- yname

    if(length(name.stats)==0) {
      name.stats <- if(nstats==1) yname
                    else paste(yname ,1:nstats,sep='')
    }
  }

  if(method=='response') {
    X[[resp]] <- NULL   # remove response var
    s <-
      if(!na.rm) FALSE
      else if(inherits(Y,'Surv'))
        as.vector((1 * is.na(unclass(Y))) %*% rep(1, ncol(Y)) > 0)
      else
        ((if(is.character(Y)) Y==''|Y=='NA'
          else is.na(Y)) %*% 
         rep(1,ncol(Y))) > 0

    ## was is.Surv(Y) ... is.na.Surv(Y)   25May01
    nmissy <- sum(s)
    if(nmissy) {
      X <- X[!s,,drop=FALSE]
      Y <- Y[!s,,drop=FALSE]
      strat <- strat[!s]
    }

    ##Compute total number of columns, counting n
    nc <- nstrat*(1+nstats)
    colname <- rep(c('N',name.stats),nstrat)
    rowname <- vname <- vlabel <- vunits <- res <- NULL
    dm <- dim(X)
    nx <- dm[2]
    n  <- dm[1]
    nlevels <- integer(nx)
    labels <- character(nx)
    units  <- labels  ## 28jan03

    i <- 0
    nams <- c(names(X), if(overall)'Overall')
    for(v in nams) {
      i <- i+1
      x <- if(v=='Overall') factor(rep('',n))
           else X[[v]]
      if(inherits(x,'mChoice')) x <- as.numeric(x)

      labels[i] <- getlab(x, nams[i])
      
      units[i]  <- if(length(l <- attr(x,'units'))) l
                   else ''

      if(!(ismc <- is.matrix(x))) {
        s <- is.na(x)
        if(!is.category(x)) {
          xu <- unique(x[!s]);
          lu <- length(xu)
          x <- if(lu < continuous) {
            r <- range(xu)
            if(lu==2 && r[1]==0 && r[2]==1) 
              factor(x,labels=c('No','Yes'))
            else
              factor(x)
          } else cut2(x, g=g, ...)
        }

        if(na.include && any(s)) {
          x <- na.include(x)
          if(.R.)
            levels(x)[is.na(levels(x))] <- 'NA'

          ## R 1.5 and later has NA as level not 'NA', satisfies is.na
        }

        xlev <- levels(x)
        if(nmin > 0) {
          nn <- table(x);
          xlev <- names(nn)[nn >= nmin]
        }
      } else {
        xlev <- dimnames(x)[[2]]
        if(!length(xlev))
          stop('matrix variables must have column dimnames')

        if(!is.logical(x)) {
          if(is.numeric(x))
            x <- x==1
          else {
            x <- structure(casefold(x),dim=dim(x))
            x <- x=='present' | x=='yes'
          }
        }

        if(nmin > 0) {
          nn <- apply(x, 2, sum, na.rm=TRUE)
          xlev <- xlev[nn >= nmin]
        }
      }

      nlevels[i] <- length(xlev)
      for(lx in xlev) {
        r <- NULL
        for(js in levels(strat)) {
          j <- if(ismc) strat==js  & x[,lx]
               else strat==js & x==lx

          if(!na.include)
            j[is.na(j)] <- FALSE

          nj <- sum(j)
          f <-
            if(nj) {
              statz <- unlist(fun(Y[j,,drop=FALSE]))
              ## 23apr03; had just let matrix replicate to fill
              ## Thanks: Derek Eder <derek.eder@neuro.gu.se>
              if(length(statz) != nstats)
                stop(paste('fun for stratum',lx,js,'did not return',
                           nstats, 'statistics'))

              matrix(statz, ncol=nstats, byrow=TRUE)
            } else rep(NA,nstats)

          r <- c(r, nj, f)
        }

        res <- rbind(res, r)
      }

      rowname <- c(rowname, xlev)
      bl <- rep('',length(xlev)-1)
      vname <- c(vname,v,bl)
      vlabel <- c(vlabel,labels[i],bl)
      vunits <- c(vunits,units[i],bl)
    }

    rowname[rowname=='NA'] <- 'Missing'
    dimnames(res) <- list(rowname,colname)
    at <- list(formula=formula, call=call, n=n, nmiss=nmissy, yname=yname, 
               ylabel=ylabel,
               ycolname=if(length(d<-dimnames(Y)[[2]]))d else yname,
               funlab=funlab,
               vname=vname, vlabel=vlabel, nlevels=nlevels,
               labels=labels, units=units, vunits=vunits,
               strat.name=strat.name, strat.label=strat.label,
               strat.levels=levels(strat))
    attributes(res) <- c(attributes(res), at)
    attr(res,'class') <- 'summary.formula.response'
    return(res)
  }

  if(method=='reverse') {
    if(resp) {
      group <- as.factor(X[[resp]])[,drop=TRUE]
      group.freq <- table(group)
      group.freq <- group.freq[group.freq>0]
      if(overall)
        group.freq <- c(group.freq, Combined=sum(group.freq))
    } else {
      group <- rep(0,nrow(X))
      group.freq <- NULL
    }

    nv <- ncol(X)-resp
      
    n <- integer(nv)
    type <- n
    nams <- names(X)
    comp <- dat <- vector("list",nv)
    names(comp) <- names(dat) <- if(resp)nams[-1]
                                 else nams

    labels <- Units <- vector("character",nv)
    if(test) {
      testresults <- vector('list', nv)
      names(testresults) <- names(comp)
    }
      
    for(i in 1:nv) {
      w <- X[[resp+i]]
      if(length(attr(w,"label")))
        labels[i] <- attr(w,"label")

      if(length(attr(w,'units')))
        Units[i]  <- attr(w,'units')

      if(!inherits(w,'mChoice')) {
          if(!is.factor(w) && length(unique(w[!is.na(w)])) < continuous) 
            w <- as.factor(w)
          s <- !is.na(w)
          if(na.include && !all(s) && length(levels(w))) {
            w <- na.include(w)
            if(.R.)
              levels(w)[is.na(levels(w))] <- 'NA'

            s <- rep(TRUE,length(s))
          }

          n[i] <- sum(s)
          w <- w[s]
          g <- group[s, drop=TRUE]
          if(is.factor(w)) {
            tab <- table(w, g)
            if(test) {
              if(is.ordered(w))
                testresults[[i]] <- ordTest(g, w)
              else
                testresults[[i]] <- catTest(tab)
            }

            if(nrow(tab)==1) {  # 7sep02
              b <- casefold(dimnames(tab)[[1]],upper=TRUE)
              pres <- c('1','Y','YES','PRESENT')
              abse <- c('0','N','NO', 'ABSENT')
              jj <- match(b, pres, nomatch=0)
              if(jj > 0)
                bc <- abse[jj]
              else {
                jj <- match(b, abse, nomatch=0)
                if(jj > 0) bc <- pres[jj]
              }

              if(jj) {
                tab <- rbind(tab, rep(0, ncol(tab)))
                dimnames(tab)[[1]][2] <- bc
              }
            }

            if(overall)
              tab <- cbind(tab, Combined=apply(tab,1,sum))

            comp[[i]] <- tab
            type[i] <- 1
          } else {
            sfn <- function(x, quant)
            {
              o <- options(digits=10)
              ## 2sep02 so won't lose precision in quantile names
              on.exit(options(o))
              c(quantile(x,quant), Mean=mean(x), SD=sqrt(var(x)))
            }

            qu <- tapply(w, g, sfn, simplify=TRUE, quant)
            ## Added simplify=TRUE to work with R 7Jun01
            if(test)
              testresults[[i]] <- conTest(g, w)

            if(overall)
              qu$Combined <- sfn(w, quant)

            comp[[i]] <- matrix(unlist(qu),ncol=length(quant)+2,byrow=TRUE,
                                dimnames=list(names(qu),
                                              c(format(quant),'Mean','SD')))
            if(any(group.freq <= nmin))
              dat[[i]] <-
                lapply(split(w,g),nmin=nmin,
                       function(x,nmin)
                         if(length(x) <= nmin)x
                         else NULL)

            type[i] <- 2
          }
        } else {
          w <- as.numeric(w)==1 ## multiple choice variables
          n[i] <- nrow(w)
          g    <- as.factor(group)
          ncat <- ncol(w)
          tab <- matrix(NA, nrow=ncat, ncol=length(levels(g)),
                        dimnames=list(dimnames(w)[[2]], levels(g)))
          if(test) {
            pval <- numeric(ncat)
            names(pval) <- dimnames(w)[[2]]
            d.f. <- stat <- pval
          }

          for(j in 1:ncat) {
            tab[j,] <- tapply(w[,j], g, sum, simplify=TRUE, na.rm=TRUE)
            if(test) {
              tabj <- rbind(table(g)-tab[j,],tab[j,])
              st <- catTest(tabj)
              pval[j] <- st$P
              stat[j] <- st$stat
              d.f.[j] <- st$df
            }
          }

          if(test)
            testresults[[i]] <- list(P=pval, stat=stat, df=d.f.,
                                     testname=st$testname,
                                     statname=st$statname,
                                     latexstat=st$latexstat,
                                     plotmathstat=st$plotmathstat)
                                   
          if(overall)
            tab <- cbind(tab, Combined=apply(tab,1,sum))

          comp[[i]] <- tab
          type[i]   <- 3
        }
      }
	  
    labels <- ifelse(nchar(labels), labels, names(comp))
    return(structure(list(stats=comp, type=type, 
                          group.name=if(resp)nams[1]
                                     else NULL,
                          group.label=ylabel,
                          group.freq=group.freq,
                          labels=labels, units=Units,
                          quant=quant, data=dat,
                          N=sum(!is.na(group)), n=n,
                          testresults=if(test)testresults
                                      else NULL,
                          call=call, formula=formula), 
                     class="summary.formula.reverse"))
  }
    
  if(method=='cross') {
    X[[resp]] <- NULL
    Levels <- vector("list",nvar)
    nams <- names(X)
    names(Levels) <- names(X)
    labels <- character(nvar)
    for(i in 1:nvar) {
      xi <- X[[i]]
      if(inherits(xi,'mChoice'))
        xi <- factor(format(xi))
      else if(is.matrix(xi) && ncol(xi) > 1) 
        stop('matrix variables not allowed for method="cross"')

      labels[i] <- getlab(xi, nams[i])

      if(is.factor(xi))
        xi <- xi[,drop=TRUE]

      if(!is.factor(xi) && length(unique(xi[!is.na(xi)]))>=continuous)
        xi <- cut2(xi, g=g, ...)
      X[[i]] <- na.include(as.factor(xi))
      if(.R.)
        levels(X[[i]])[is.na(levels(X[[i]]))] <- 'NA'
        
      Levels[[i]] <- c(levels(X[[i]]),if(overall)"ALL")
    }
    
    ##Make a data frame with all combinations of values (including those
    ##that don't exist in the data, since trellis needs them)

    df <- expand.grid(Levels)
    nl <- nrow(df)
    N  <- Missing <- integer(nl)
    na <- is.na(Y %*% rep(1,ncol(Y)))
    S  <- matrix(NA, nrow=nl, ncol=nstats, dimnames=list(NULL,name.stats))

    ## 23apr03
    chk <- function(z, nstats)
    {
      if(length(z) != nstats)
        stop(paste('fun did not return',nstats,
                   'statistics for a stratum'))

      z
    }

    if(nvar==1) {
      df1 <- as.character(df[[1]]); x1 <- X[[1]]
      for(i in 1:nl) {
        s <- df1[i]=='ALL' | x1==df1[i]
        w <- if(na.rm) s & !na else s
        N[i] <- sum(w)
        Missing[i] <- sum(na[s])
        S[i,] <- if(any(w))chk(fun(Y[w,,drop=FALSE]),nstats)
                 else rep(NA,nstats)
      }
    } else if(nvar==2) {
      df1 <- as.character(df[[1]]);
      df2 <- as.character(df[[2]])
      x1 <- X[[1]];
      x2 <- X[[2]]
      for(i in 1:nl) {
        s <- (df1[i]=='ALL' | x1==df1[i]) & (df2[i]=='ALL' | x2==df2[i])
        w <- if(na.rm) s & !na
             else s

        N[i] <- sum(w)
        Missing[i] <- sum(na[s])
        S[i,] <- if(any(w))chk(fun(Y[w,,drop=FALSE]),nstats)
                 else rep(NA,nstats)
      }
    } else if(nvar==3) {
      df1 <- as.character(df[[1]]);
      df2 <- as.character(df[[2]])
      df3 <- as.character(df[[3]])
      
      x1 <- X[[1]];
      x2 <- X[[2]];
      x3 <- X[[3]]

      for(i in 1:nl) {
        s <- (df1[i]=='ALL' | x1==df1[i]) & (df2[i]=='ALL' | x2==df2[i]) &
             (df3[i]=='ALL' | x3==df3[i])
        w <- if(na.rm) s & !na
             else s

        N[i] <- sum(w)
        Missing[i] <- sum(na[s])
        S[i,] <- if(any(w))chk(fun(Y[w,,drop=FALSE]),nstats)
                 else rep(NA,nstats)
      }  
    } else stop('no more than 3 independent variables allowed')
    
    lab <- names(df)
    lab2 <- if(length(lab)>1) paste(lab,collapse=", ")
            else lab

    heading <- paste(funlab,"by",lab2)
    ##if(length(name.stats)) yname <- funlab <- name.stats

    attr(S,"label") <- yname    #funlab
    df$S <- S
    df$N <- N
    df$Missing <- Missing
      
    a <- list(heading=heading,byvarnames=lab2,Levels=Levels,labels=labels,
              na.action=nact,formula=formula,call=call,yname=yname,ylabel=ylabel,
              class=c("summary.formula.cross","data.frame"))
    attributes(df) <- c(attributes(df), a)
    df
  }  
}


##The following makes formula(object) work (using especially for update())
formula.summary.formula.cross <- function(x, ...) attr(x,'formula')


na.retain <- function(d) d

print.summary.formula.response <- function(x, 
                                           vnames=c('labels','names'), prUnits=TRUE,
                                           abbreviate.dimnames=FALSE,
                                           prefix.width, min.colwidth,
                                           formatArgs=NULL, ...)
{
  stats <- x
  stats <- oldUnclass(stats)
  vnames <- match.arg(vnames)
  ul <- vnames=='labels'

  at <- attributes(stats)
  ns <- length(at$strat.levels)

  vlabels <- at$labels
  if(prUnits) {
    atu <- translate(at$units, '*',' ') ## 31jan03
    vlabels <- ifelse(atu=='',vlabels,   ## 28jan03
                      paste(vlabels,' [',atu,']',sep=''))
  }

  cat(at$ylabel,
      if(ns>1)
        paste(' by',
              if(ul) at$strat.label
              else at$strat.name),
      '    N=',at$n,
      if(at$nmiss) paste(', ',at$nmiss,' Missing',sep=''),
      '\n\n',sep='')

  d <- dim(stats)
  
  if(exists('print.char.matrix')) {
    nr <- length(at$nlevels)
    vlab <- if(ul) vlabels[vlabels!='']
            else at$vname[at$vname!='']

    z <- matrix('',nrow=nr,ncol=1+d[2],dimnames=list(vlab,NULL))
    dz <- dimnames(stats)[[1]]
    cstats <- matrix('',nrow=d[1],ncol=d[2])
    for(j in 1:d[2]) {
      ww <- c(list(stats[,j]), formatArgs)
      cstats[,j] <- do.call('format', ww)  # 10Feb00
      cstats[is.na(stats[,j]),j] <- ''
    }

    is <- 1
    for(i in 1:nr) {
      ie <- is+at$nlevels[i]-1
      z[i,1] <- paste(dz[is:ie],collapse='\n')
      for(j in 1:d[2]) z[i,j+1] <- paste(cstats[is:ie,j],collapse='\n')
      is <- ie+1
    }
    if(missing(prefix.width))
      prefix.width <- max(nchar(dimnames(z)[[1]]))
    
    if(missing(min.colwidth))
      min.colwidth <- 
        max(min(nchar(cstats)[nchar(cstats)>0]), min(nchar(dimnames(stats)[[2]])))

    z <- rbind(c('',dimnames(stats)[[2]]), z)
    if(.R.)
      print.char.matrix(z, col.names=FALSE, ...)
    else
      print.char.matrix(z,abbreviate.dimnames=abbreviate.dimnames,
                        prefix.width=prefix.width, 
                        min.colwidth=min.colwidth, ...)  

    return(invisible())
  } 

  dz <-
    if(length(at$strat.levels)==1)
      dimnames(stats)[[2]]
    else
      paste(rep(at$strat.levels,length=d[2]),dimnames(stats)[[2]],sep=":")
  
  z <- matrix('', ncol=d[2]+2, nrow=d[1],
              dimnames=list(rep('',d[1]),c('','',dz)))

  z[,1] <- if(ul) vlabels
           else at$vname

  z[,2] <- dimnames(stats)[[1]]
  for(i in 1:d[2]) {
    ww <- c(list(stats[,i]), formatArgs)  # 10Feb00
    z[,i+2] <- do.call('format', ww)
  }

  print(z, quote=FALSE)
  invisible()
}

latex.summary.formula.response <-
  function(object, 
           title=first.word(deparse(substitute(object))), caption,
           trios, vnames=c('labels','names'), prn=TRUE, prUnits=TRUE,
           rowlabel='', cdec=2,
           ncaption=TRUE, ...)
{
  stats <- object

  title <- title   # otherwise problem with lazy evaluation 25May01
  stats <- oldUnclass(stats)
  at <- attributes(stats)
  if(!prn)
    stats <- stats[,dimnames(stats)[[2]]!='N',drop=FALSE]

  vnames <- match.arg(vnames)
  ul <- vnames=='labels'
  ns <- length(at$strat.levels)
  nstat <- ncol(stats)/ns
  if(!missing(trios)) {
    if(is.logical(trios))
      trios <- at$ycolname

    ntrio <- length(trios)
    if(ntrio*3!=(nstat-1))   #allow for N
      stop('length of trios must be 1/3 the number of statistics computed')
  }

  if(missing(caption)) caption <- latexTranslate(at$ylabel)
  
  if(ns>1) caption <- paste(caption,' by', if(ul)at$strat.label else 
                            at$strat.name)
  if(ncaption)
    caption <- paste(caption,
                     '~~~~~N=',at$n,
                     if(at$nmiss) paste(',~',at$nmiss,' Missing',sep=''),
                     sep='')

  dm <- dimnames(stats)
  dm[[1]] <- latexTranslate(dm[[1]], greek=.R.)
  dm[[2]] <- latexTranslate(dm[[2]], greek=.R.)
  dimnames(stats) <- dm
  caption <- sedit(caption, "cbind", "")
  vn <- if(ul)at$vlabel
        else at$vname

  if(prUnits) {
    atvu <- translate(at$vunits, '*', ' ')
    vn <- ifelse(atvu=='', vn,
                 paste(vn,'~\\hfill\\tiny{', atvu, '}',sep=''))
  }

  vn <- latexTranslate(vn, greek=.R.)
  cdec <- rep(cdec,
              length=(if(missing(trios))nstat
                      else 1+(nstat-1)/3)-1)

  cdec <- rep(c(if(prn)0 else NULL,cdec), ns)

  if(missing(trios))
    cstats <- oldUnclass(stats)
  else {
    fmt <- function(z, cdec) ifelse(is.na(z), '', format(round(z,cdec)))
    cstats <- list()
    k <- m <- 0
    for(is in 1:ns) {
      k <- k+1;  m <- m+1
      cstats[[k]] <- stats[,m]   ## N, numeric mode
      for(j in 1:ntrio) {
        m <- m+1; k <- k+1
        cstats[[k]] <- paste('{\\scriptsize ',fmt(stats[,m],cdec[k]),'~}',
                             fmt(stats[,m+1],cdec[k]), ' {\\scriptsize ',
                             fmt(stats[,m+2],cdec[k]), '}',sep='')
        m <- m+2
      }
    }

    names(cstats) <- rep(c(if(prn)'N'
                           else NULL, trios), ns)
    
    attr(cstats, 'row.names') <- dm[[1]]
    attr(cstats,'class') <- 'data.frame'
    nstat <- 2  # for n.cgroup below
  }
  
  insert.bottom <-
    if(missing(trios))
      ''
    else 
      '\\noindent {\\scriptsize $a$\\ } $b$ {\\scriptsize $c$\\ } represent the lower quartile $a$, the median $b$, and the upper quartile $c$.'

  r <-
    if(ns>1) latex(cstats, title=title, caption=caption, rowlabel=rowlabel,
                   n.rgroup=at$nlevels, rgroup=vn[vn!=''],
                   n.cgroup=rep(nstat,ns), cgroup=at$strat.levels, cdec=cdec,
                   col.just=rep('c',ncol(cstats)),
                   rowname=dm[[1]], insert.bottom=insert.bottom, ...)
    else latex(cstats, title=title, caption=caption, rowlabel=rowlabel,
               n.rgroup=at$nlevels, rgroup=vn[vn!=''], cdec=cdec,
               col.just=rep('c',ncol(cstats)),
               rowname=dm[[1]], insert.bottom=insert.bottom, ...)

  r
}


plot.summary.formula.response <-
  function(x, which = 1,
           vnames = c('labels', 'names'), xlim, xlab,
           pch = c(16, 1, 2, 17, 15, 3, 4, 5, 0), superposeStrata = TRUE,
           dotfont=1, add=FALSE, reset.par=TRUE,
           main, subtitles=TRUE, ...)
{
  stats <- x
  stats  <- oldUnclass(stats)
  vnames <- match.arg(vnames)
  ul <- vnames=='labels'
  at <- attributes(stats)
  ns <- length(at$strat.levels)
  if(ns>1 && length(which)>1) 
    stop('cannot have a vector for which if > 1 strata present')

  if(ns < 2)
    superposeStrata <- FALSE

  vn <- if(ul) at$vlabel
        else at$vname

  Units <- at$vunits
  vn <- ifelse(Units=='', vn, paste(vn, ' [', Units, ']', sep=''))
  ## dotchart2 groups argument may not be an R plotmath expression
  vn <- vn[vn!='']
  d  <- dim(stats)
  n  <- d[1]
  nstat <- d[2]/ns
  vnd <- factor(rep(vn, at$nlevels))
  dn <- dimnames(stats)
  if(missing(xlim))
    xlim <- range(stats[,nstat*((1:ns)-1)+1+which],na.rm=TRUE)

  if(missing(main))
    main <- at$funlab

  nw      <- length(which)
  pch     <- rep(pch, length=if(superposeStrata)ns else nw)
  dotfont <- rep(dotfont, length=nw)
  opar <- if(.R.) par(no.readonly=TRUE)
          else par()

  if(reset.par)
    on.exit(par(opar))

  if(superposeStrata) Ns <- apply(stats[,nstat*((1:ns)-1)+1],1,sum)
  
  for(is in 1:ns) {
    for(w in 1:nw) {
      js <- nstat*(is-1)+1+which[w]
      z <- stats[,js]
      if(missing(xlab))
        xlab <- if(nw>1) dn[[2]][js]
                else at$ylabel

      dotchart2(z, groups=vnd, xlab=xlab, xlim=xlim,
                auxdata=if(superposeStrata) Ns
                        else stats[,js-which[w]],
                auxtitle='N', sort=FALSE,
                pch=pch[if(superposeStrata)is
                        else w], 
                dotfont=dotfont[w], 
                add=add | w>1 | (is > 1 && superposeStrata),
                reset.par=FALSE, ...)

      if(ns>1 && !superposeStrata)
        title(paste(paste(main,if(main!='')'   '),at$strat.levels[is]))
      else if(main!='') title(main)

      if(ns==1 && subtitles) {
        title(sub=paste('N=',at$n,sep=''),adj=0,cex=.6)
        if(at$nmiss>0)
          title(sub=paste('N missing=',at$nmiss,sep=''),cex=.6,adj=1)
      }
    }
  }

  if(superposeStrata) { ##set up for Key()
    Key <- if(.R.) function(x=NULL, y=NULL, lev, pch)
    {
      oldpar <- par(usr=c(0,1,0,1),xpd=NA)
      on.exit(par(oldpar))
      if(is.list(x)) {
        y <- x$y;
        x <- x$x
      }

      if(!length(x))
        x <- 0

      if(!length(y))
        y <- 1  ## because of formals()

      rlegend(x, y, legend=lev, pch=pch, ...)
      invisible()
    }
    else function(x=NULL, y=NULL, lev, pch, ...) {
      if(length(x)) {
        if(is.list(x)) {
          y <- x$y;
          x <- x$x
        }

        key(x=x, y=y, text=list(lev), 
            points=list(pch=pch),
            transparent=TRUE, ...)
      } else key(text=list(lev), 
                 points=list(pch=pch),transparent=TRUE, ...)
      
      invisible()
    }

    formals(Key) <- list(x=NULL,y=NULL,lev=at$strat.levels,
                         pch=pch)
    storeTemp(Key)
  }

  invisible()
}


plot.summary.formula.reverse <-
  function(x, vnames = c('labels', 'names'), what = c('proportion','%'),
           which = c('both', 'categorical', 'continuous'),
           xlim = if(what == 'proportion') c(0,1)
                  else c(0,100), 
           xlab = if(what == 'proportion') 'Proportion'
                  else 'Percentage', 
           pch = c(16, 1, 2, 17, 15, 3, 4, 5, 0), exclude1 = TRUE,
           dotfont = 1, main, subtitles = TRUE,
           prtest = c('P', 'stat', 'df', 'name'), pdig = 3, eps = 0.001,
           conType = c('dot', 'bp', 'raw'), cex.means = 0.5, ...)
{
  obj <- x
  vnames <- match.arg(vnames)
  what   <- match.arg(what)
  which  <- match.arg(which)
  conType <- match.arg(conType)
  
  ul <- vnames=='labels'

  if(is.logical(prtest) && !prtest) prtest <- 'none'
  test   <- obj$testresults
  if(!length(test)) prtest <- 'none'

  varNames <- names(obj$stats)
  vn <- if(ul) obj$labels
        else varNames
    
  Units <- obj$units
  
  nw     <- if(lg <- length(obj$group.freq)) lg
            else 1

  gnames <- names(obj$group.freq) 

  if(missing(main))
    main <- if(nw==1)''
  else 
    paste(if(what=='proportion')'Proportions'
          else 'Percentages','Stratified by',
          obj$group.label)

  pch     <- rep(pch, length=nw)
  dotfont <- rep(dotfont, length=nw)
  
  lab <- vnd <- z <- nmiss <- vnamd <- NULL
  type  <- obj$type; n <- obj$n

  opar <- par()
  on.exit(setParNro(opar))

  npages <- 0
  
  if(which != 'continuous' && any(type %in% c(1,3))) {
    ftstats <- NULL  
    for(i in (1:length(type))[type==1 | type==3]) {
      nam <- vn[i]
      tab <- obj$stats[[i]]
      if(nw==1)
        tab <- as.matrix(tab)

      nr <- nrow(tab)
      denom <- if(type[i]==1) apply(tab, 2, sum)
               else obj$group.freq

      y <- (if(what=='proportion') 1
            else 100) * sweep(tab, 2, denom, FUN='/')

      lev <- dimnames(y)[[1]]
      exc <- exclude1 && (nr==2)
      jstart <- if(exc) 2
                else 1

      ##  nn <- c(nn, n[i], rep(NA, if(exc) nr-2 else nr-1))
      ##  k <- 0

      rl <- casefold(lev)
      binary <- type[i]==1 && exc &&
                (all(rl %in% c("0","1"))|all(rl %in% c("false","true"))|
                 all(rl %in% c("absent","present")))

      for(j in jstart:nrow(y)) {
        if(nw==1)
          z <- rbind(z, y[j,])
        else {
          yj <- rep(NA, nw)
          names(yj) <- gnames
          yj[names(y[j,])] <- y[j,]
          z <- rbind(z, yj)
        }

        lab <- c(lab, if(binary) ''
                      else lev[j])

        vnd <- c(vnd, nam)
        vnamd <- c(vnamd, varNames[i])
      }

      if(any(prtest != 'none')) {
        fts <- formatTestStats(test[[varNames[i]]], type[i]==3,
                               if(type[i]==1)1
                               else 1:nr,
                               prtest=prtest,
                               plotmath=.R.,
                               pdig=pdig, eps=eps)

        ftstats <- c(ftstats, fts, 
                     if(type[i]==1 && nr-exc-1 > 0)
                       rep(if(.R.) expression('')
                           else '',
                           nr-exc-1))
      }
    }

    dimnames(z) <- list(lab, dimnames(z)[[2]])
    for(i in 1:nw) {
      zi <- z[,i]
      if(any(prtest == 'none') || i > 1)
        dotchart2(zi, groups=vnd, xlab=xlab, xlim=xlim, 
                  sort=FALSE, pch=pch[i],
                  dotfont=dotfont[i],
                  add=i>1, ...)
      else
        dotchart2(zi, groups=vnd, auxdata=ftstats,
                  xlab=xlab, xlim=xlim, sort=FALSE,
                  pch=pch[i], dotfont=dotfont[i],
                  add=i>1, ...)
    }

    if(main!='')
      title(main)

    npages <- npages + 1
    setParNro(opar)
    ## Dummy key if only one column, so won't use another Key from an
    ## earlier run
    if(nw < 2) {
      Key <- function(...)invisible(NULL)
      storeTemp(Key)
    } else { ##set up for key() if > 1 column
      Key <- if(.R.) function(x=NULL, y=NULL, lev, pch)
      {
        oldpar <- par(usr=c(0,1,0,1),xpd=NA)
        on.exit(par(oldpar))
        if(is.list(x)) {
          y <- x$y;
          x <- x$x
        }

        ## Even though par('usr') shows 0,1,0,1 after lattice draws
        ## its plot, it still needs resetting
        if(!length(x))
          x <- 0

        if(!length(y))
          y <- 1  ## because of formals()

        rlegend(x, y, legend=lev, pch=pch, ...)
        invisible()
      } else function(x=NULL, y=NULL, lev, pch, ...)
      {
        if(length(x)) {
          if(is.list(x)) {
            y <- x$y;
            x <- x$x
          }

          key(x=x, y=y, text=list(lev), 
              points=list(pch=pch),
              transparent=TRUE, ...)
        } else
          key(text=list(lev), 
              points=list(pch=pch),transparent=TRUE, ...)

        invisible()
      }

      formals(Key) <- list(x=NULL,y=NULL,lev=names(obj$group.freq),
                           pch=pch)
      storeTemp(Key)
    }
  }

  ncont <- sum(type==2)
  if(which != 'categorical' && ncont) {
    mf <- par('mfrow')
    if(length(mf)==0)
      mf <- c(1,1)

    if(ncont > 1 & max(mf)==1) {
      mf <- if(ncont <= 4)c(2,2)
            else if(ncont <= 6)c(2,3)
            else if(ncont <= 9)c(3,3)
            else c(4,3)

      ## if(ncont <= 12)c(4,3) else if(ncont <= 16) c(4,4) else c(5,4)
      nr <- mf[1]
      m  <- par('mar')
      par(mfrow=mf)
    }

    npages <- npages + ceiling(sum(type==2) / prod(mf))
    
    for(i in (1:length(type))[type==2]) {
      nam <- labelPlotmath(vn[i], Units[i])
      st <- obj$stats[[i]]
      if(nw==1)
        st <- as.matrix(st)

      if(conType=='dot') {
        quantile.columns <- dimnames(st)[[2]] %nin% c('Mean','SD')
        st <- st[,quantile.columns,drop=FALSE]
        xlim <- range(st)
        ns <- as.numeric(dimnames(st)[[2]])
        l  <- 1:length(ns)
        q1  <- l[abs(ns-.25) < .001]
        med <- l[abs(ns-.5)  < .001]
        q3  <- l[abs(ns-.75) < .001]
        st <- st[,c(q1,med,q3),drop=FALSE]

        for(j in 1:3) {
          stj <- st[,j]
          if(nw==1)
            names(stj) <- ''

          dotchart2(stj, xlab=nam, xlim=xlim, sort=FALSE,
                    pch=c(91,
                          if(FALSE)183
                          else 16,
                          93)[j],
                    dotfont=dotfont[1],
                    add=j > 1, ...)
        }
      } else if(conType=='bp')
        bpplt(st, xlab=nam, cex.points=cex.means)
      else
        stripChart(obj$data[[i]], xlab=nam)

      if(all(prtest != 'none')) {
        fts <- formatTestStats(test[[varNames[i]]], prtest=prtest,
                               plotmath=.R.,
                               pdig=pdig, eps=eps)
        title(fts, line=.5)  ## .5 ignored in S-Plus
      }
    }

    Key2 <- function(x=NULL, y=NULL, quant, ...)
    {
      quant <- format(quant)
      txt <- paste('(',quant[2],',',quant[3],',',quant[4], 
                   ') quantiles shown\nx-axes scaled to (',quant[1],',',
                   quant[5],') quantiles', sep='')
      if(length(x)) {
        if(is.list(x)) {
          y <- x$y;
          x <- x$x
        }

        text(x,y,txt, cex=.8, adj=0, ...)
      } else
        mtitle(lr=txt, cex.l=.8, line=1, ...)

      invisible()
    }

    formals(Key2) <- list(x=NULL,y=NULL,quant=obj$quant)
    storeTemp(Key2)
  }

  invisible(npages)
}


#This version of the stardard dotchart function allows a vector of values
#to be specified (typically cell sizes) that are written to the right
#or horizontal (only) dot charts.  New vectors and auxdata and auxgdata and
#a label for auxdata, auxtitle.
#Also added: sort. parameter, to allow suppression of rearrangements of data,
#and added the parameter `add'.  Reference lines are always drawn with lwd=1.
#There's also a new parameter, groupfont, which specifies a font number for
#group headings.
#cex.labels is a cex to be used only for category labels.  Default is cex.
#Added reset.par - set to T to reset par() after making plot.  You will
#need to set reset.par to T for the last call in a sequence.
dotchart2 <- 
  function(data, labels, groups = NULL, gdata = NA, horizontal = TRUE, 
           pch = 16, 
           xlab = "", ylab="", auxdata, auxgdata=NULL, auxtitle,
           lty = if(.R.)1 else 2,
           lines = TRUE, dotsize = .8, cex = par("cex"), 
           cex.labels = cex, cex.group.labels = cex.labels*1.25, sort.=TRUE, 
           add=FALSE, dotfont=par('font'),
           groupfont=2, reset.par=add, xaxis=TRUE,
           width.factor=1.1, lcolor=if(.R.) 'gray' else par('col'),
           ...)
{
  if(.R. && !add)
    {
      plot.new()   ## needed for strwidth
      par(new=TRUE)
    }

  ieaux <- if(missing(auxdata)) FALSE else is.expression(auxdata)
  
  mtextsrt <- function(..., srt=0)
    if(.R.) mtext(..., las=1) else mtext(..., srt=srt)

  ndata <- length(data)
  if(missing(labels))
    {
      if(!is.null(names(data)))
        labels <- names(data)
      else labels <- paste("#", seq(along = ndata))
    }
  else labels <- rep(as.character(labels), length = ndata)

  if(missing(groups))
    {
      glabels <- NULL
      gdata <- NULL
    } else
  {
    if(!sort.)
      {
        ##assume data sorted in groups, but re-number groups
        ##to be as if groups given in order 1,2,3,...
        ug <- unique(as.character(groups))
        groups <- factor(as.character(groups),levels=ug)
      }

    groups <- oldUnclass(groups)
    glabels <- levels(groups)
    gdata <- rep(gdata, length = length(glabels))	
    ord <- order(groups, seq(along = groups))
    groups <- groups[ord]
    data <- data[ord]
    labels <- labels[ord]
    if(!missing(auxdata)) auxdata <- auxdata[ord]  #FEH
  }

  alldat <- c(data, gdata)
  if(!missing(auxdata))
    {
      auxdata <- c(auxdata, auxgdata)
      if(!ieaux) auxdata <- format(auxdata)
    }
  
  alllab <- paste(c(labels, glabels),'')
  ## set up margins and user coordinates, draw box
  tcex <- par('cex')
  tmai <- par("mai")
  oldplt <- par("plt")
  if(reset.par)
    on.exit(par(mai = tmai, cex = tcex, usr = tusr))

  par(cex = cex)
  mxlab <- .1+max(strwidth(labels, units='inches',cex=cex.labels),
                  if(length(glabels))
                  strwidth(glabels,units='inches',cex=cex.group.labels))*
                    width.factor
  if(horizontal)
    {
      tmai2 <- tmai[3:4]
      if(!missing(auxdata))
        tmai2[2] <- .2+width.factor*
          max(strwidth(if(ieaux) auxdata else format(auxdata),
                       units='inches',cex=cex.labels))
      
      par(mai = c(tmai[1], mxlab, tmai2))
      if(!add)
        plot(alldat, seq(along = alldat), type = "n",
             ylab = '', axes = FALSE, xlab = '', ...)
      
      logax <- par("xaxt") == "l"
    }
  else
    {
      par(mai = c(mxlab, tmai[2:4]))
      if(!add)
        plot(seq(along = alldat), alldat, type = "n",
             xlab = "", axes = FALSE, ylab = '', ...)
      
      logax <- par("yaxt") == "l"
    }

  tusr <- par("usr")
  if(!add && logax)
    {
      if(horizontal)
        abline(v = 10^tusr[1:2], h = tusr[3:4])
      else abline(v = tusr[1:2], h = 10^tusr[3:4])
    }
  else if(!add) abline(v = tusr[1:2], h = tusr[3:4])

  den <- ndata + 2 * length(glabels) + 1
  if(horizontal)
    {
      if(!add && xaxis)
        mgp.axis(1, axistitle=xlab)

      delt <- ( - (tusr[4] - tusr[3]))/den
      ypos <- seq(tusr[4], by = delt, length = ndata)
  }
  else
    {
      if(!add)
        mgp.axis(2, axistitle=xlab)

      delt <- (tusr[2] - tusr[1])/den
      ypos <- seq(tusr[1], by = delt, length = ndata)
    }

  if(!missing(groups))
    {
      ypos1 <- ypos + 2 * delt * (if(length(groups)>1)
                                  cumsum(c(1, diff(groups) > 0))
      else 1)
      diff2 <- c(3 * delt, diff(ypos1))
      ypos2 <- ypos1[abs(diff2 - 3 * delt) < abs(0.001 * delt)] - 
        delt
      ypos <- c(ypos1, ypos2) - delt
    }

  ##put on labels and data
  ypos <- ypos + delt
  nongrp <- 1:ndata
  if(horizontal)
    {
      xmin <- par('usr')[1]
      if(!add && lines)
        abline(h = ypos[nongrp], lty = lty, lwd=1, col=lcolor)

      points(alldat, ypos, pch = pch, cex = dotsize * cex, font=dotfont)
      if(!add && !missing(auxdata))
        {
          faux <- if(ieaux) auxdata else paste(' ', format(auxdata), sep='')

          upedge <- par('usr')[4]
          outerText(faux, ypos[nongrp], adj=1, cex=cex.labels)
          if(!missing(auxtitle))
            {
              auxtitle <- paste(' ', auxtitle, sep='')
              outerText(auxtitle,
                        upedge+strheight(auxtitle,cex=cex.labels)/2,
                        adj=1, cex=cex.labels, setAside=faux[1])
            }
        }

      if(!add)
        {
          labng <- alllab[nongrp]
          ## Bug in sending character strings to mtext or text containing
          ## [ or ] - they don't right-justify in S+
          bracket <- substring(labng,1,1)=='[' |
          substring(labng,nchar(labng),nchar(labng))==']'
          yposng <- ypos[nongrp]
          s <- !bracket
          if(!is.na(any(s)) && any(s))
            mtextsrt(paste(labng[s],''), 2, 0, at=yposng[s],
                     srt=0, adj=1, cex=cex.labels)

          s <- bracket
          if(!is.na(any(s)) && any(s))
            {
              if(.R.)
                text(rep(par('usr')[1],sum(s)),
                     yposng[s], labng[s], adj=1,
                     cex=cex.labels, srt=0,xpd=NA)
              else if(.SV4. && under.unix)
                text(rep(par('usr')[1],sum(s)),
                     yposng[s], labng[s], adj=1,
                     cex=cex.labels, srt=0)
              else
                {
                  xmin <- par('usr')[1] -
                    max(nchar(labng[s]))*0.5*cex.labels*par('1em')[1]
                  text(rep(xmin,sum(s)), yposng[s], labng[s], adj=0,
                       cex=cex.labels, srt=0)
                }
            }
          
          if(!missing(groups))
            mtextsrt(paste(alllab[ - nongrp],''), 2, 0, at = ypos[ - nongrp], 
                     srt = 0, adj = 1, cex = cex.group.labels, font=groupfont)
        }
    }
  else
    {
      if(!add && lines)
        abline(v = ypos[nongrp], lty = lty, lwd=1, col=lcolor)

      points(ypos, alldat, pch = pch, cex = dotsize * cex, font=dotfont)
      if(!add) mtextsrt(alllab[nongrp], 1, 0,
                        at = ypos[nongrp], srt = 90, adj = 1,
                        cex = cex.labels)
      if(!add && !missing(groups))
        mtextsrt(alllab[ - nongrp], 1, 0, at = ypos[ - nongrp], 
                 srt = 90, adj = 1, cex = cex.group.labels, font=groupfont)
  }

  plt <- par("plt")
  if(horizontal) {
    frac <- (oldplt[2] - oldplt[1])/(oldplt[2] - plt[1])
    umin <- tusr[2] - (tusr[2] - tusr[1]) * frac
    tusr <- c(umin, tusr[2:4])
  }
  else
    {
      frac <- (oldplt[4] - oldplt[3])/(oldplt[4] - plt[3])
      umin <- tusr[4] - (tusr[4] - tusr[3]) * frac
      tusr <- c(tusr[1:2], umin, tusr[4])
    }

  invisible()
}


print.summary.formula.reverse <- 
  function(x, digits, prn=any(n != N), pctdig=0, 
           npct=c('numerator','both','denominator','none'),
           exclude1=TRUE, vnames=c("labels","names"), prUnits=TRUE,
           sep="/", abbreviate.dimnames=FALSE, 
           prefix.width=max(nchar(lab)), 
           min.colwidth, formatArgs=NULL,
           prtest=c('P','stat','df','name'), prmsd=FALSE, long=FALSE,
           pdig=3, eps=0.001, ...)
{
  npct   <- match.arg(npct)
  vnames <- match.arg(vnames)
  if(is.logical(prtest) && !prtest)
    prtest <- 'none'

  stats  <- x$stats
  nv     <- length(stats)
  cstats <- lab <- character(0)
  nn     <- integer(0)
  type   <- x$type
  n      <- x$n
  N      <- x$N
  nams   <- names(stats)
  labels <- x$labels
  Units  <- x$units
  test   <- x$testresults
  if(!length(test))
    prtest <- 'none'

  nw     <- if(lg <- length(x$group.freq)) lg
            else 1  #23Nov98

  gnames <- names(x$group.freq)

  if(!missing(digits)) {    #.Options$digits <- digits 6Aug00
    oldopt <- options(digits=digits)
    on.exit(options(oldopt))
  }


  cstats <- NULL
  for(i in 1:nv) {
    nn <- c(nn, n[i])
    nam <- if(vnames=="names") nams[i]
           else labels[i]

    if(prUnits && nchar(Units[i]))
      nam <- paste(nam,' [',translate(Units[i],'*',' '),']',sep='')

    tr <- if(length(test) && all(prtest!='none')) test[[nams[i]]]
          else NULL

    if(type[i]==1 || type[i]==3) {
      cs <- formatCats(stats[[i]], nam, tr, type[i],
                       if(length(x$group.freq)) x$group.freq else x$n[i],
                       npct, pctdig, exclude1, long, prtest,
                       pdig=pdig, eps=eps)
      nn <- c(nn, rep(NA, nrow(cs)-1))
    } else cs <- formatCons(stats[[i]], nam, tr, x$group.freq, prmsd,
                            sep, formatArgs, prtest,
                            pdig=pdig, eps=eps)

    cstats <- rbind(cstats, cs)
  }

  lab <- dimnames(cstats)[[1]]
  gl <- names(x$group.freq)
  gl <- if(length(gl)) paste(gl," \n(N=",x$group.freq,")",sep="")
        else ""

  if(length(test) && !all(prtest=='none'))
    gl <- c(gl,
            if(length(prtest)==1 && prtest!='stat')
              if(prtest=='P')'P-value'
              else prtest
            else '  Test\nStatistic')

  ##lab <- format(lab)   21Jan99
  nc <- nchar(cstats)
  spaces <- substring("                                                        ",
                      1, (max(nc)-nc+1)/2)   # center strings
  dc <- dim(cstats)
  cstats <- paste(spaces, cstats, sep="")
  dim(cstats) <- dc
  if(prn) {
    cnn <- format(nn)
    cnn[is.na(nn)] <- ''
    cstats <- cbind(cnn, cstats)
    gl <- c('N', gl)
  }

  cstats <- rbind(gl, cstats)
  dimnames(cstats) <- list(c('',lab), NULL)
    
  cat("\n\nDescriptive Statistics",
      if(length(x$group.label))
        paste(" by",x$group.label)
      else
        paste("  (N=",x$N,")",sep=""),"\n\n", sep="")

  if(exists("print.char.matrix")) {
    if(missing(min.colwidth))
      min.colwidth <- max(min(nchar(gl)),min(nc[nc>0]))

    if(.R.)
      print.char.matrix(cstats, col.names=FALSE,
                        col.txt.align='left', ...)
    else
      print.char.matrix(cstats, abbreviate.dimnames=abbreviate.dimnames,
                        prefix.width=prefix.width,
                        min.colwidth=min.colwidth, ...)
  } else

  print(cstats, quote=FALSE)
  invisible(cstats)
}

## Function to format subtable for categorical var, for method='reverse'
formatCats <- function(tab, nam, tr, type, group.freq,
                       npct, pctdig, exclude1, long, prtest,
                       latex=FALSE, testUsed=character(0),
                       npct.size='scriptsize', pdig=3, eps=.001,
                       footnoteTest=TRUE, dotchart=FALSE)
{
  gnames <- names(group.freq)
  nr <- nrow(tab)

  ## If there was a missing column of tab because e.g. the variable was
  ## always NA for one (or more) of the groups, add columns of NAs
  if(ncol(tab) < length(group.freq)) {
    tabfull <- matrix(NA,nrow=nr,ncol=length(group.freq),
                      dimnames=list(dimnames(tab)[[1]],gnames))
    tabfull[,dimnames(tab)[[2]]] <- tab
    tab <- tabfull
  }

  denom <- if(type==1) apply(tab, 2, sum)
           else group.freq

  pct <- 100*(if(ncol(tab) > 1)sweep(tab, 2, denom, FUN='/') else tab/denom)
  cpct <- paste(format(round(pct, pctdig)),
                if(latex)"\\%"
                else "%",
                sep="")

  denom.rep <- matrix(rep(format(denom),nr),nrow=nr,byrow=TRUE)
  if(npct!='none')
    cpct <- paste(cpct,
                  if(latex)
                    switch(npct,
                           numerator=paste('{\\',npct.size,' (',format(tab),')}',sep=''),
                           denominator=paste('{\\',npct.size,' of',denom.rep,'}'),
                           both=paste('{\\',npct.size,' $\\frac{',
                                      format(tab),'}{',denom.rep,
                                      '}$}',sep=''))
                  else
                  switch(npct,
                         numerator=paste('(',format(tab),')',sep=''),
                         denominator=paste('of',denom.rep),
                         both=paste(format(tab),'/',denom.rep,sep='')))
  
  if(latex)
    cpct <- sedit(cpct,' ','~')

  dim(cpct) <- dim(pct)
  dimnames(cpct) <- dimnames(pct)
  cpct[is.na(pct)] <- ""
  lev <- dimnames(pct)[[1]]
  exc <- exclude1 && (nr==2) && (type==1) # type==1 10jul02
  rl <- casefold(dimnames(pct)[[1]])
  binary <- type==1 && exc &&    ## 17Jan99
  (all(rl %in% c("0","1"))|all(rl %in% c("false","true"))|
   all(rl %in% c("absent","present")))
  if(binary) long <- FALSE
  jstart <- if(exc) 2
            else 1
  
  nw <- if(lg <- length(group.freq)) lg
        else 1

  lab <- if(binary) nam
         else if(long) c(nam, paste('   ',lev[jstart:nr]))
         else c(paste(nam,':',lev[jstart]),
                if(nr > jstart) paste('   ',lev[(jstart+1):nr]))
  
  cs <- matrix('', nrow=long+(if(exc)nr-1
                              else nr),
               ncol=nw + (length(tr) > 0),
               dimnames=list(lab, c(gnames,
                                    if(length(tr))''
                                    else NULL)))

  if(nw==1)
    cs[(long+1):nrow(cs),1] <- cpct[jstart:nr,]
  else
    cs[(long+1):nrow(cs),1:nw] <- cpct[jstart:nrow(cpct),gnames]

  if(latex && dotchart && ncol(pct) <= 3) {
    locs <- c(3,-3,5,-5,7,-7,9,-9)
    points <- c("\\circle*{4}","\\circle{4}","\\drawline(0,2)(-1.414213562,-1)(1.414213562,-1)(0,2)")
    
    point.loc <- sapply(jstart:nrow(pct),
                        function(i) {
                          paste(ifelse(is.na(pct[i,]), "",
                                       paste("\\put(", pct[i,], ",0){",points[1:ncol(pct)],"}",sep='')),
                                collapse='')
                        })

    error.loc <- character(nrow(tab) - exc)
    k <- 0
    for(i in jstart:ncol(tab)) {
      if(i > jstart) {
        p1prime <- (tab[,i] + 1)/(denom[i] + 2)
        d1 <- p1prime*(1-p1prime)/denom[i]
        for(j in jstart:(i-1)) {
          k <- k + 1
          p2prime <- (tab[,j] + 1)/(denom[j] + 2)
          error <- 196 * sqrt(d1 + p2prime * (1 - p2prime)/denom[j])
          bar <- ifelse(is.na(error), "",
                        paste("\\put(", (pct[,i] + pct[,j])/2 - error, ",",
                              locs[k],"){\\line(1,0){",error*2,"}}",
                              sep=''))
          error.loc <- paste(error.loc, bar, sep='')
        }
      }
    }

    scale <- character(nrow(tab) - exc)
    scale[1] <- "\\multiput(0,2)(25,0){5}{\\color[gray]{0.5}\\line(0,-1){4}}\\put(-5,0){\\makebox(0,0){\\tiny 0}}\\put(108,0){\\makebox(0,0){\\tiny 1}}"
                     
    cl <- paste("\\setlength\\unitlength{1in/100}\\begin{picture}(100,10)(0,-5)",
                scale,"\\put(0,0){\\color[gray]{0.5}\\line(1,0){100}}",
                point.loc, error.loc,
                "\\end{picture}", sep='')
    cs[(long+1):nrow(cs),ncol(cs)] <- cl
  }

  if(length(tr)) {
    ct <- formatTestStats(tr, type==3,
                          if(type==1)1
                          else 1:nr,
                          prtest, latex=latex, testUsed=testUsed,
                          pdig=pdig, eps=eps, footnoteTest=footnoteTest)

    if(length(ct)==1)
      cs[1,ncol(cs)] <- ct
    else
      cs[(long+1):nrow(cs),ncol(cs)] <- ct
  }

  cs
}


## Function to format subtable for continuous var, for method='reverse'
formatCons <- function(stats, nam, tr, group.freq, prmsd, sep='/',
                       formatArgs=NULL, prtest,
                       latex=FALSE, testUsed=character(0),
                       middle.bold=FALSE, outer.size=NULL, msdsize=NULL,
                       pdig=3, eps=.001, footnoteTest=TRUE)
{
  nw <- if(lg <- length(group.freq)) lg
        else 1

  ns <- dimnames(stats)[[2]]
  ns <- ifelse(ns %in% c('Mean','SD'), '-1', ns)
  ns <- as.numeric(ns)
  l  <- 1:length(ns)
  q1  <- l[abs(ns-.25) < .001]
  med <- l[abs(ns-.5) < .001]
  q3  <- l[abs(ns-.75) < .001]
  qu <- stats[,c(q1,med,q3),drop=FALSE]
  if(prmsd)
    qu <- cbind(qu,stats[,c('Mean','SD'),drop=FALSE])

  ww <- c(list(qu), formatArgs)
  cqu <- do.call('format', ww)
  cqu[is.na(qu)] <- ''
  if(latex) {
    st <- character(nrow(cqu))
    names(st) <- dimnames(qu)[[1]]   ## 31jul02
    bld <- if(middle.bold) '\\bf '
           else ''

    for(j in 1:nrow(cqu)) {
      st[j] <- paste("{\\",outer.size," ",cqu[j,1],
                     "~}{",bld,cqu[j,2],
                     " }{\\",outer.size," ",cqu[j,3],"} ",sep="")
      if(prmsd)
        st[j] <-
          if(length(msdsize))
            paste(st[j], '~{\\',msdsize,'(',cqu[j,4], '$\\pm$',
                  cqu[j,5],')}', sep='')
          else
            paste(st[j], '~(', cqu[j,4], '$\\pm$',
                  cqu[j,5],')', sep='')
    }
  }
  else st <-
    if(prmsd)
      apply(cqu, 1,
            function(x,sep) paste(x[1],sep,x[2],sep,x[3],'  ',
                                  x[4],'+/-',x[5],sep=''), sep=sep)
    else
      apply(cqu, 1, paste, collapse=sep)

  if(any(is.na(qu)))
    st <- ""

  if(nw==1)
    yj <- st
  else {
    yj <- rep('',nw)
    names(yj) <- names(group.freq)
    yj[names(st)] <- st
  }

  if(length(tr)) {
    ct <- formatTestStats(tr, prtest=prtest, latex=latex,
                          testUsed=testUsed, pdig=pdig, eps=eps,
                          footnoteTest=footnoteTest)
    yj <- c(yj, ct)
  }

  matrix(yj, nrow=1, dimnames=list(nam,names(yj)))
}


formatTestStats <- function(tr, multchoice=FALSE,
                            i=if(multchoice)NA
                              else 1,
                            prtest, latex=FALSE,
                            testUsed=character(0),
                            pdig=3, eps=.001,
                            plotmath=FALSE, footnoteTest=TRUE)
{
  ## tr=an element of testresults (created by summary.formula method='reverse')
  if(i > 1 && !multchoice)
    stop('logic error')
  
  pval     <- tr$P[i]
  teststat <- tr$stat[i]
  testname <- tr$testname

  if(any(is.na(pval)) || any(is.na(teststat))) {
    res <- rep('', length(pval))
    if(latex && length(testUsed))
      res <-
        if(footnoteTest)
          rep(paste('$^{',match(testname,testUsed),
                    '}$',sep=''), length(pval))
        else rep('', length(pval))

    return(res)
  }

  ## Note: multchoice tests always have only one type of d.f.
  deg <- if(multchoice)tr$df[i]
         else tr$df
  
  dof <- if(multchoice) as.character(deg)
         else paste(deg,collapse=',')
  
  statname <- if(latex) tr$latexstat
              else if(plotmath) tr$plotmathstat
              else tr$statname
  
  if(length(prtest)>1 && 'stat' %in% prtest && (latex || plotmath)) {
    ## replace "df" inside statname with actual d.f.
    if(length(grep('df',statname)))
      statname <- sedit(statname, 'df',
                        if(latex || length(deg)==1) dof
                        else paste('list(',dof,')', sep=''))
  }

  pval <- format.pval(pval,digits=pdig,eps=eps)
  plt <- substring(pval,1,1)=='<'

  if(latex) {
    if(length(prtest)==1) 
      paste('$',
            switch(prtest,
                   P=pval,
                   stat=format(round(teststat,2)),
                   df=dof, name=statname),
            if(footnoteTest && length(testUsed))
              paste('^{',match(testname,testUsed),
                    '}',sep=''),'$',sep='')
    else paste('$',
               if('stat' %in% prtest)
                 paste(statname,'=',format(round(teststat,2)),sep=''),
               if(all(c('stat','P') %in% prtest)) ',~',
### 21dec03        if('P' %in% prtest)paste('P',if(plt)'' else '=', pval,
###                                        sep=''),
               if('P' %in% prtest)paste('P',ifelse(plt,'','='), pval,
                                        sep=''),
               if(footnoteTest && length(testUsed))
                 paste('^{',match(testname,testUsed),
                       '}',sep=''),
               '$')
  } else if(plotmath) {
    if(length(prtest)==1)
      parse(text=switch(prtest,
### 21dec03             P=if(plt)paste('~P',pval,sep='') else
###                      paste('~P==',pval,sep=''),
                        P=ifelse(plt,paste('~P',pval,sep=''),
                                 paste('~P==',pval,sep='')),
                        stat=format(round(teststat,2)),
                        dof=format(dof),
                        name=statname))
    else
      parse(text=paste(if('stat' %in% prtest)
                         paste('~list(',statname,'==',
                               format(round(teststat,2)),sep=''),
                       if(all(c('stat','P') %in% prtest)) ', ',
### 21dec03   if('P' %in% prtest)paste(if(plt)'~P' else '~P==',pval,')',sep='')))
                       if('P' %in% prtest)paste(ifelse(plt,'~P','~P=='),pval,')',sep='')))
  } else {
    if(length(prtest)==1)
      switch(prtest,
             P=pval,
             stat=format(round(teststat,2)),
             df=dof, name=statname)
    else
      paste(if('stat' %in% prtest)
              paste(statname,'=',format(round(teststat,2)),sep=''),
            if('df' %in% prtest) paste('d.f.=',dof,sep=''),
### 21dec03      if('P' %in%  prtest)paste('P', if(plt)'' else '=', pval,
###                                         sep=''))
            if('P' %in%  prtest)paste('P', ifelse(plt,'','='), pval,
                                      sep=''))
  }
}


latex.summary.formula.reverse <- 
  function(object, title=first.word(deparse(substitute(object))),
           digits, prn = any(n!=N), pctdig=0, 
           npct=c('numerator','both','denominator','none'),
           npct.size='scriptsize', Nsize='scriptsize',
           exclude1=TRUE,  vnames=c("labels","names"), prUnits=TRUE,
           middle.bold=FALSE, outer.size="scriptsize",
           caption, rowlabel="",
           insert.bottom=TRUE, dcolumn=FALSE,
           prtest=c('P','stat','df','name'), prmsd=FALSE, msdsize=NULL,
           long=dotchart, pdig=3, eps=.001, auxCol=NULL, dotchart=FALSE, ...)
{
  x      <- object
  npct   <- match.arg(npct)
  vnames <- match.arg(vnames)
  if(is.logical(prtest) && !prtest)
    prtest <- 'none'

  stats  <- x$stats
  nv     <- length(stats)
  cstats <- lab <- character(0)
  nn     <- integer(0)
  type   <- x$type
  n      <- x$n
  N      <- x$N
  nams   <- names(stats)
  labels <- x$labels
  Units  <- x$units
  nw     <- if(lg <- length(x$group.freq)) lg
            else 1  #23Nov98
  gnames <- names(x$group.freq)
  test   <- x$testresults
  if(!length(test))
    prtest <- 'none'

  gt1.test <-
    if(all(prtest=='none'))
      FALSE
    else
      length(unique(sapply(test,function(a)a$testname))) > 1

  if(!missing(digits)) {   #.Options$digits <- digits 6Aug00
    oldopt <- options(digits=digits)
    on.exit(options(oldopt))
  }

  if(missing(caption))
    caption <- paste("Descriptive Statistics",
                     if(length(x$group.label))
                       paste(" by",x$group.label)
                     else
                       paste("  $(N=",x$N,")$",sep=""), sep="")
    
  bld <- if(middle.bold) '\\bf '
         else ''

  cstats <- NULL
  testUsed <- auxc <- character(0)

  for(i in 1:nv) {
    if(length(auxCol))
      auxc <- c(auxc, auxCol[[1]][i])

    nn <- c(nn, n[i])   ## 12aug02
    nam <- if(vnames=="names") nams[i]
           else labels[i]

    if(prUnits && nchar(Units[i]) > 0)
      nam <- paste(nam, '~\\hfill\\tiny{',translate(Units[i],'*',' '),'}',sep='')

    tr  <- if(length(test) && all(prtest!='none')) test[[nams[i]]]
           else NULL

    if(length(test) && all(prtest!='none'))
      testUsed <- unique(c(testUsed, tr$testname))

    if(type[i]==1 || type[i]==3) {
      cs <- formatCats(stats[[i]], nam, tr, type[i],
                       if(length(x$group.freq)) x$group.freq else x$n[i],
                       npct, pctdig, exclude1, long, prtest,
                       latex=TRUE, testUsed=testUsed,
                       npct.size=npct.size,
                       footnoteTest=gt1.test, dotchart=dotchart)
      nn <- c(nn, rep(NA, nrow(cs)-1))
    } else cs <- formatCons(stats[[i]], nam, tr, x$group.freq, prmsd,
                            prtest=prtest,
                            latex=TRUE, testUsed=testUsed,
                            middle.bold=middle.bold,
                            outer.size=outer.size, msdsize=msdsize,
                            pdig=pdig, eps=eps, footnoteTest=gt1.test)
                              
    cstats <- rbind(cstats, cs)
    if(length(auxc) && nrow(cstats) > 1)
      auxc <- c(auxc, rep(NA, nrow(cs)-1))
  }

  lab <- dimnames(cstats)[[1]]
  gl <- names(x$group.freq)
  ##gl <- if(length(gl)) paste(gl, " $(N=",x$group.freq,")$",sep="") else " "
  ## Thanks: Eran Bellin <ebellin@montefiore.org>   3Aug01
  if(!length(gl))
    gl <- " "

  lab <- sedit(lab,c(" ","&"),c("~","\\&"))  #was format(lab) 21Jan99
  lab <- latexTranslate(lab, greek=.R.)
  gl  <- latexTranslate(gl, greek=.R.)
  ## if(any(gl != " ")) gl <- paste(gl, " $(N=",x$group.freq,")$",sep="") # 3Aug01
  ## Added any( ) 26Mar02  21jan03
  extracolheads <-
    if(any(gl != " "))
      c(if(prn)'', paste('$N=',x$group.freq,'$',sep=''))
    else NULL # 21jan03

  if(length(test) && !all(prtest=='none')) {
    gl <- c(gl,
            if(length(prtest)==1 && prtest!='stat')
              if(prtest=='P') 'P-value'
              else prtest
            else 'Test Statistic')

    if(length(extracolheads)) extracolheads <- c(extracolheads,'') # 21jan03
  }

  dimnames(cstats) <- list(NULL,gl) 
  ## was dimnames(cstats) <- list(lab, gl) 12aug02
  cstats <- data.frame(cstats, check.names=FALSE)
  
  ## Added row.names=lab below 10jul02 - S+ was dropping dimnames[[1]]
  ##attr(cstats,'row.names') <- lab  12aug02
  col.just <- rep("c",length(gl))
  if(dcolumn && all(prtest!='none') &&
     gl[length(gl)] %in% c('P-value','Test Statistic'))
    col.just[length(col.just)] <- '.'

  if(prn) {
    cstats <- data.frame(N=nn, cstats, check.names=FALSE)
    col.just <- c("r",col.just)
  }

  if(!insert.bottom)
    legend <- NULL
  else {
    legend <- paste(if(any(type==2)) {
                      paste("\\noindent {\\",outer.size," $a$\\ }{",bld,"$b$\\ }{\\",
                            outer.size," $c$\\ } represent the lower quartile $a$, the median $b$, and the upper quartile $c$\\ for continuous variables.",
                            if(prmsd) '~~$x\\pm s$ represents $\\bar{X}\\pm 1$ SD.'
                            else '',
                            '\\\\', sep="")
                    } else NULL,
                    if(prn) '$N$\\ is the number of non--missing values.\\\\',
                    if(any(type==1) && npct=='numerator')
                      'Numbers after percents are frequencies.\\\\',
                    sep="\n")
    legend <- NULL
    if(any(type==2)) {
      legend <- paste("\\noindent {\\", outer.size, " $a$\\ }{", bld,
                      "$b$\\ }{\\", outer.size,
                      " $c$\\ } represent the lower quartile $a$, the median $b$, and the upper quartile $c$\\ for continuous variables.",
                      if(prmsd) '~~$x\\pm s$ represents $\\bar{X}\\pm 1$ SD.'
                      else '',
                      '\\\\\n', sep="")
    }
    
    if(prn) {
      legend <- paste(legend,
                      '$N$\\ is the number of non--missing values.\\\\\n',
                      sep='')
    }

    if(any(type==1) && npct=='numerator') {
      legend <- paste(legend,
                      'Numbers after percents are frequencies.\\\\\n',
                      sep='')
    }
      
    if(length(testUsed))
      legend <-paste(legend,
                     if(length(testUsed)==1)'\\noindent Test used:'
                     else '\\indent Tests used:',
                     if(length(testUsed)==1) paste(testUsed,'test')
                     else
                       paste(paste('$^{',1:length(testUsed),'}$',testUsed,
                                   ' test',sep=''),collapse='; '))

    ## added rowname=lab 12aug02  added '\n\n' 4mar03 for ctable=T
  }

  if(length(auxc)) {
    if(length(auxc) != nrow(cstats))
      stop(paste('length of auxCol (',length(auxCol[[1]]),
                 ') is not equal to number or variables in table (',
                 nv,').', sep=''))
    auxcc <- format(auxc)
    auxcc[is.na(auxc)] <- ''
    cstats <- cbind(auxcc, cstats)
    nax <- names(auxCol)
    heads <- get2rowHeads(nax)
    names(cstats)[1] <- heads[[1]]
    if(length(col.just)) col.just <- c('r', col.just)
    if(length(extracolheads)) extracolheads <- c(heads[2], extracolheads)
  }
  resp <- latex.default(cstats, title=title, caption=caption, rowlabel=rowlabel,
                        col.just=col.just, numeric.dollar=FALSE, 
                        insert.bottom=legend,  rowname=lab, dcolumn=dcolumn,
                        extracolheads=extracolheads, extracolsize=Nsize,
                        ...)

  if(dotchart) 
    resp$style <- unique(c(resp$style, 'calc', 'epic', 'color'))
  
  resp
}


print.summary.formula.cross <- function(x, twoway=nvar==2, 
                                        prnmiss=any(stats$Missing>0), prn=TRUE,
                                        abbreviate.dimnames=FALSE, 
                                        prefix.width=max(nchar(v)),
                                        min.colwidth, formatArgs=NULL,
                                        ...)
{
  stats <- x
  a <- attributes(stats)
  cat("\n",a$heading,"\n\n")
  attr(stats,'class') <- NULL
  ylab <- attr(stats$S,"label")
  nvar <- length(a$Levels)
  vnames <- names(a$Levels)
  nam <- c(vnames, if(prn)"N", if(prnmiss) "Missing", "S") #5Oct00
  stats <- stats[nam]
  S <- stats$S
  ars <- length(dim(S))
  attr(stats,"row.names") <- rep("",length(a$row.names))
  if(twoway && nvar==2 && exists("print.char.matrix")) {
    V <- stats[[vnames[1]]]
    H <- stats[[vnames[2]]]
    v <- levels(V)
    h <- levels(H)
    z <- dimnames(stats$S)[[2]]
    if(!length(z))
      z <- ylab

    z <- c(if(prn)"N",
           if(prnmiss)"Missing",
           z)  # 5Oct00
    
    header <- matrix(paste(z,collapse="\n"),1,1)
    if(.R.)
      print.char.matrix(header, col.names=FALSE)
    else
      print.char.matrix(header)

    d <- c(length(v),length(h),length(z))
    st <- array(NA, dim=d, dimnames=list(v,h,z))
    cstats <- array("", dim=d, dimnames=list(v,h,z))
    for(i in 1:length(V)) {
      j <- V==V[i,drop=FALSE] & H==H[i,drop=FALSE]
      st[V[i,drop=FALSE],H[i,drop=FALSE],] <-
        c(if(prn)stats$N[j],
          if(prnmiss)stats$Missing[j],
          if(ars)S[j,]
          else S[j])  # 5Oct00
    }

    for(k in 1:d[3]) {
      ww <- c(list(st[,,k]), formatArgs)  #10Feb00
      cstats[,,k] <- ifelse(is.na(st[,,k]),"",do.call('format',ww))
    }
    dimn <- dimnames(cstats)[1:2]
    names(dimn) <- vnames
    cstats2 <- matrix("", nrow=d[1], ncol=d[2], dimnames=dimn)
    for(i in 1:d[1]) {
      for(j in 1:d[2]) {
        cstats2[i,j] <- paste(cstats[i,j,], collapse="\n")
      }
    }
    if(missing(min.colwidth))
      min.colwidth <- 
        max(min(nchar(dimnames(cstats2)[[2]])), 
            min(nchar(cstats)[nchar(cstats)>0]))

    return(invisible(if(.R.)
                       print.char.matrix(cstats2,
                                         col.names=TRUE, ...)
                     else
                       print.char.matrix(cstats2,  prefix.width=prefix.width,
                                         abbreviate.dimnames=abbreviate.dimnames,
                                         min.colwidth=min.colwidth, ...)))

    ## was col.names=FALSE 26Mar02
  }

  ##print.char.matrix not present (old version of S-Plus)
  ##print.data.frame messes up matrix names (here prefixing by S)
  if(ars) {
    stats$S <- NULL
    snam <- dimnames(S)[[2]]
    for(i in 1:ncol(S))
      stats[[snam[i]]] <- S[,i]
    
  } else names(stats)[length(stats)] <- ylab

  stats <- as.data.frame(stats)
  invisible(print(stats, ...))
}


latex.summary.formula.cross <-
  function(object,
           title=first.word(deparse(substitute(object))),
           twoway=nvar==2,
           prnmiss=TRUE, prn=TRUE,
           caption=attr(object,"heading"), vnames=c('labels','names'),
           rowlabel="", ...)
{  
  stats <- object
  vnames <- match.arg(vnames)
  ul <- vnames=='labels'

  stats <- oldUnclass(stats)
  a <- attributes(stats)
  ylab <- attr(stats$S,"label")
  nvar <- length(a$Levels)
  nam <- c(names(a$Levels),
           if(prn)"N",
           if(prnmiss)"Missing",
           "S")
  
  ##Force lazy evaluation since stats about to change
  caption <- caption;
  title <- title
  stats <- stats[nam]
  S <- stats$S
  ars <- length(dim(S))
  inn <- c('cbind','c(','ALL',  'NA')
  out <- c('',     '(' ,'Total','Missing')
  caption <- latexTranslate(caption, inn, out, pb=TRUE, greek=.R.)

  if(twoway)
    rowlab <-
      if(ul)
        latexTranslate(a$labels[1],inn,out,pb=TRUE,greek=.R.)
      else 
        names(stats)[1]

  rvar <- stats[[1]]
  cvar <- stats[[2]]
  lev1 <- levels(rvar)
  lev2 <- levels(cvar)
  if(!twoway) {
    for(i in 1:nvar)
      stats[[i]] <- latexTranslate(as.character(stats[[i]]),inn,
                                   out,pb=TRUE,greek=.R.)

    ##Used to do this translating unconditionally   6Jun96

    if(ars) {
      stats$S <- NULL
      snam <- latexTranslate(dimnames(S)[[2]],inn,out,pb=TRUE,greek=.R.)
      for(i in 1:ncol(S))
        stats[[snam[i]]] <- S[,i]
    } else names(stats)[length(stats)] <- ylab

    stats <- structure(stats, row.names=rep("",length(stats$N)),
                       class="data.frame")
    if(hasArg(col.just)) {
      return(latex(stats, title=title, caption=caption, rowlabel=rowlabel, ...))
    } else return(latex(stats, title=title, caption=caption, rowlabel=rowlabel, 
                        col.just=c("l","l",rep("r",length(stats)-2)), ...))
  }

  ##Two-way
  S <- cbind(N=if(prn)stats$N,
             Missing=if(prnmiss && any(stats$Missing)) stats$Missing,  #5Oct00
             stats$S)
  
  nr <- length(lev1)
  nc <- length(lev2)
  ns <- ncol(S)
  snam <- dimnames(S)[[2]]
  snam <- latexTranslate(snam, inn, out, pb=TRUE,greek=.R.)
  dn <-
    if(ns > 1)
      rep(snam, nc)
    else
      latexTranslate(lev2,inn,out,pb=TRUE,greek=.R.) # 5Oct00

  st <- matrix(NA, nrow=nr, ncol=nc*ns, dimnames=list(NULL,dn))
  for(i in 1:nr) {
    l <- 0
    for(j in 1:nc) {
      w <- rvar==lev1[i] & cvar==lev2[j]
      if(any(w))
        for(k in 1:ns) {
          l <- l+1
          st[i,l] <- S[w,k]
        }
    }
  }

  latex(st, title=title, caption=caption, 
        rowlabel=if(rowlabel=='') rowlab else rowlabel,
        n.rgroup=c(nrow(st)-1,1),
        n.cgroup=if(ns>1) rep(ns,nc),  # ns>1 5Oct00
        cgroup  =if(ns>1) latexTranslate(lev2,inn,out,pb=TRUE,greek=.R.),
        check.names=FALSE,
        rowname=latexTranslate(lev1,inn,out,pb=TRUE,greek=.R.), ...)
}


##stratify is a modification of Therneau's survival4 strata function
##Saves label attributute and defaults shortlabel to T
stratify <- function(..., na.group = FALSE, shortlabel = TRUE)
{
  words <- as.list((match.call())[-1])
  if(!missing(na.group))
    words$na.group <- NULL

  if(!missing(shortlabel))
    words$shortlabel <- NULL

  allf <- list(...)
  
  if(length(allf) == 1 && is.list(ttt <- oldUnclass(allf[[1]]))) {
    allf <- ttt
    words <- names(ttt)
  }
  
  xlab <- sapply(allf, function(x){lab <- valueLabel(x); if(is.null(lab)) NA else lab})
  xname <- sapply(allf, function(x){name <- valueName(x); if(is.null(name)) NA else name})

  xname <- ifelse(is.na(xname), words, xname)
  xlab <- paste(ifelse(is.na(xlab), xname, xlab), collapse=' and ')
  
  xname <- paste(xname, collapse = ' and ')

  nterms <- length(allf)
  what <- allf[[1]]
  if(is.null(levels(what)))
    what <- factor(what)

  levs <- oldUnclass(what) - 1
  wlab <- levels(what)
  if(na.group && any(is.na(what))) {
    levs[is.na(levs)] <- length(wlab)
    wlab <- c(wlab, "NA")
  }

  if(shortlabel)
    labs <- wlab
  else labs <- paste(words[1], wlab, sep = "=")

  for(i in (1:nterms)[-1]) {
    what <- allf[[i]]
    if(is.null(levels(what)))
      what <- factor(what)

    wlab <- levels(what)
    wlev <- oldUnclass(what) - 1
    if(na.group && any(is.na(wlev))) {
      wlev[is.na(wlev)] <- length(wlab)
      wlab <- c(wlab, "NA")
    }

    if(!shortlabel)
      wlab <- format(paste(words[i], wlab, sep = "="))

    levs <- wlev + levs * (length(wlab))
    labs <- paste(rep(labs, rep(length(wlab), length(labs))),
                  rep(wlab, length(labs)), sep = ", ")
  }

  levs <- levs + 1
  ulevs <- sort(unique(levs[!is.na(levs)]))
  levs <- match(levs, ulevs)
  labs <- labs[ulevs]
  levels(levs) <- labs
  oldClass(levs) <- "factor"

  if(length(xlab))
    valueLabel(levs) <- xlab   #FEH 2Jun95

  if(length(xname))
    valueName(levs) <- xname
  
  levs
}


'[.summary.formula.response' <- function(x,i,j,drop=FALSE, ...)
{
  z <- x
  at <- attributes(z)
  at$dim <- at$dimnames <- NULL

  if(!missing(j)) {
    z <- oldUnclass(z)[,j,drop=FALSE]
    at$ycolname <- at$ycolname[j]
    attributes(z) <- c(attributes(z), at)
  }

  if(missing(i))
    return(z)

  if(is.character(i)) {
    vn <- at$vname[at$vname!='']
    k <- match(i, vn, nomatch=0)
    if(any(k==0))
      stop(paste('requested variables not in object:',
                 paste(i[k==0],collapse=' ')))

    i <- k
  }

  j <- integer(0)
  nl <- at$nlevels
  is <- 1
  for(m in 1:length(nl)) {
    ie <- is+nl[m]-1
    if(any(i==m))
      j <- c(j,is:ie)

    is <- ie+1
  }

  at$vname   <- at$vname[j]
  at$vlabel  <- at$vlabel[j]
  at$nlevels <- at$nlevels[i]
  at$labels  <- at$labels[i]

  z <- oldUnclass(z)[j,,drop=FALSE]
  attributes(z) <- c(attributes(z), at)
  z
}


cumcategory <- function(y)
{
  if(!is.category(y))
    y <- factor(y)  ## was as.category 26Mar02

  lev <- levels(y)
  y <- oldUnclass(y)
  Y <- matrix(NA, nrow=length(y), ncol=length(lev)-1,
              dimnames=list(NULL,paste('>=',lev[-1],sep='')))
  storage.mode(Y) <- 'integer'
  for(i in 2:length(lev))
    Y[,i-1] <- 1*(y >= i)

  Y
}


summarize <- function(X, by, FUN, ..., 
                      stat.name=deparse(substitute(X)), 
                      type=c('variables','matrix'), subset=TRUE)
{
  type <- match.arg(type)
  if(missing(stat.name) && length(stat.name)>1)
    stat.name <- 'X'

  if(!is.list(by)) {
    nameby <- deparse(substitute(by))
    bylabel <- label(by)
    by <- list(by[subset])
    names(by) <- if(length(nameby)==1) nameby
                 else 'by'
  } else {
    bylabel <- sapply(by, label)
    if(!missing(subset))
      by <- lapply(by, function(y, subset) y[subset],
                   subset=subset)
  }

  nby <- length(by)
  
  bylabel <- ifelse(bylabel=='', names(by), bylabel)
  typical.computation <- FUN(X, ...)
  nc <- length(typical.computation)
  xlabel <- deparse(substitute(X))
  if(length(xlabel)!=1)
    xlabel <- 'X'
  
  if(length(xlab <- attr(X,'label')))
    xlabel <- xlab

  if(!missing(subset))
    X <- if(is.matrix(X)) X[subset,,drop=FALSE]
         else X[subset]

  if(!.R.)  # 21Mar01: S-Plus converts factor to integer during paste
    for(i in 1:nby)
      if(is.category(by[[i]]))
        by[[i]] <- as.character(by[[i]])
  
  byc <- do.call('paste',c(by,sep='|'))

  ## split does not handle matrices
  ##  msplit <- function(x, group) {
  ##    if(is.matrix(x)) {
  ##      group <- as.factor(group)
  ##      l <- levels(group)
  ##      res <- vector('list', length(l))
  ##      names(res) <- l
  ##      for(j in l) res[[j]] <- x[group==j,,drop=FALSE]
  ##      res
  ##    } else split(x, group)
  ##  }
  ## Following was streamlined 10oct02 using the new mApply
  ##  if(nc==1) r <- sapply(msplit(X, byc), FUN, ..., simplify=TRUE) else {
  ##    r <- sapply(msplit(X, byc), FUN, ..., simplify=TRUE)
  ##    r <- matrix(unlist(r), nrow=nc, dimnames=dimnames(r))
  ## 2Mar00: added unlist because sapply was creating an array of
  ## lists in S+2000
  ##  }

  r <- mApply(X, byc, FUN, ..., keepmatrix=nc>1)
  rdimn <- dimnames(r)[[1]]
  if(.R.) {   # someday can use unpaste defined in Misc.s
    ans <- strsplit(if(nc==1) names(r) else rdimn,'\\|')

    ## strsplit returns list "transpose" of unpaste
    bb <- matrix(unlist(ans), nrow=nby)
    ans <- vector('list', nby)
    for(jj in 1:nby)
      ans[[jj]] <- bb[jj,]
  } else {
    ans <- if(nc==1)names(r) else rdimn
    
    if(nby==1)
      ans <- list(ans)
    else
      ans <- unPaste(ans, sep='|')
  }

  names(ans) <- names(by)
  if(nc>1 && (nc != ncol(r)))
    stop('program logic error')  # was nrow 10oct02
  
  snames <- names(typical.computation)
  if(!length(snames))
    snames <- paste(stat.name,1:nc,sep='')
  
  if(length(stat.name)==1)
    snames[1] <- stat.name
  else if(length(stat.name))
    snames <- stat.name
  
  oldopt <- options(warn=-1)
  on.exit(options(oldopt))
  notna <- rep(TRUE, length(ans[[1]]))
  for(i in 1:length(by)) {
    byi <- by[[i]]
    ansi <- ans[[i]]
    if(is.category(byi)) {
      if(!is.character(ansi))
        stop('program logic error:ansi not character')
      
      ansi <- factor(ansi, levels(byi))
    }
    else if(is.numeric(byi))
      ansi <- as.numeric(ansi)
    
    names(ansi) <- NULL
    label(ansi) <- bylabel[i]
    ans[[i]] <- ansi
    notna <- notna & !is.na(ansi)
  }

  if(type=='matrix' || nc==1) {
    ans[[stat.name]] <-
      if(nc==1)
        structure(r,names=NULL)
      else 
        structure(r, dimnames=list(NULL, snames), names=NULL)

    label(ans[[stat.name]]) <- xlabel
  } else {
    snames <- make.names(snames)
    for(i in 1:length(snames)) {
      ans[[snames[i]]] <- structure(r[,i], names=NULL)
      label(ans[[snames[i]]]) <- xlabel
    }
  }

  notna <- notna & !is.na(if(nc==1) r
                          else (r %*% rep(1,nc)))
  
  ans <- structure(ans, class='data.frame', 
                   row.names=1:length(ans[[1]]))
  ## removed [notna,] from end of above line; not sure why this was needed
  iorder <- do.call('order', structure(oldUnclass(ans)[1:nby],names=NULL))
  ## order can bomb if data frame given (preserves names)
  ans[iorder,]
}


##Following code is based on tapply instead
if(FALSE) {
  r <- as.array(tapply(x, by, FUN, ...))
  dn <- dimnames(r)
  wrn <- .Options$warn
  .Options$warn <- -1
  for(i in 1:length(by)) {
    byi <- by[[i]]
    if(is.numeric(byi) && !is.category(byi)) dn[[i]] <- as.numeric(dn[[i]])
  }
  .Options$warn <- wrn
  names(dn) <- names(by)
  ans <- expand.grid(dn)

  typical.computation <- FUN(x, ...)
  nc <- length(typical.computation)
  snames <- names(typical.computation)
  if(length(snames)) snames <- paste(stat.name, snames) else
  snames <- if(nc==1) stat.name else paste(stat.name,1:nc)
  for(i in 1:length(r)) if(!length(r[[i]]))r[[i]] <- rep(NA,nc)
  ## unlist will skip positions where calculations not done (NULLs)
  S <- matrix(unlist(r), ncol=length(snames), 
              dimnames=list(NULL,snames), byrow=TRUE)
  if(type=='matrix') {
    ans$S <- S
    if(stat.name != 'S') names(ans)[length(ans)] <- stat.name
  } else ans <- cbind(ans, S)
  ans
}

smean.cl.normal <- function(x, mult=qt((1+conf.int)/2,n-1),
                            conf.int=.95, na.rm=TRUE)
{
  if(na.rm) x <- x[!is.na(x)]
  n <- length(x)
  if(n < 2)
    return(c(Mean=mean(x),Lower=NA,Upper=NA))
  
  xbar <- sum(x)/n
  se <- sqrt(sum((x - xbar)^2) / n / (n-1))
  c(Mean=xbar, Lower=xbar - mult*se, Upper=xbar + mult*se)
}


smean.sd <- function(x, na.rm=TRUE)
{
  if(na.rm)
    x <- x[!is.na(x)]
  
  n <- length(x)
  if(n == 0)
    return(c(Mean=NA, SD=NA))
  
  xbar <- sum(x)/n
  sd <- sqrt(sum((x - xbar)^2)/(n-1))
  c(Mean=xbar, SD=sd)
}


smean.sdl <- function(x, mult=2, na.rm=TRUE)
{
  if(na.rm)
    x <- x[!is.na(x)]
  
  n <- length(x)
  if(n == 0)
    return(c(Mean=NA, Lower=NA, Upper=NA))
  
  xbar <- sum(x)/n
  sd <- sqrt(sum((x - xbar)^2)/(n-1))
  c(Mean=xbar, Lower=xbar - mult * sd, Upper=xbar + mult * sd)
}


#S-Plus gives a parse error for R's .Internal()
#Might try not using an else to see if S still parses
smean.cl.boot <- if(.R.) {
  eval(parse(text=paste(c('function(x, conf.int=.95, B=1000, na.rm=TRUE, reps=FALSE) {',
                          'if(na.rm) x <- x[!is.na(x)]',
                          'n <- length(x)',
                          'xbar <- mean(x)',
                          'if(n < 2) return(Mean=xbar, Lower=NA, Upper=NA)',
                          'z <- unlist(lapply(1:B, function(i,x,N)',
                          'sum(x[.Internal(sample(N, N, TRUE, NULL))]),',
                          'x=x, N=n)) / n',
                          'quant <- quantile(z, c((1-conf.int)/2,(1+conf.int)/2))',
                          'names(quant) <- NULL',
                          'res <- c(Mean=xbar, Lower=quant[1], Upper=quant[2])',
                          'if(reps) attr(res,"reps") <- z',
                          'res}'),
                        collapse='\n')))

} else function(x, conf.int=.95, B=1000, na.rm=TRUE, reps=FALSE)
{
  if(na.rm)
    x <- x[!is.na(x)]

  n <- length(x)
  xbar <- mean(x)
  if(n < 2)
    return(Mean=xbar, Lower=NA, Upper=NA)

  z <- unlist(lapply(1:B, function(i,x,N)
                     sum(x[.Internal(sample.index(N, N, TRUE),
                                     "S_sample",TRUE,0)]), x=x, N=n)) / n
  quant <- quantile(z, c((1-conf.int)/2,(1+conf.int)/2))
  names(quant) <- NULL
  res <- c(Mean=xbar, Lower=quant[1], Upper=quant[2])
  if(reps)
    attr(res, 'reps') <- z

  res
}


smedian.hilow <- function(x, conf.int=.95, na.rm=TRUE)
{
  quant <- quantile(x, probs=c(.5,(1-conf.int)/2,(1+conf.int)/2), na.rm=na.rm)
  names(quant) <- c('Median','Lower','Upper')
  quant
}


asNumericMatrix <- function(x)
{
  a <- attributes(x)
  k <- length(a$names)
  at <- vector('list', k); names(at) <- a$names
  for(i in 1:k) {
    xi <- x[[i]]
    ischar <- FALSE
    A <- attributes(xi)
    if(is.character(xi)) {
      ischar <- TRUE
      xi <- factor(xi)
      A <- c(A, attributes(xi))
      x[[i]] <- xi
    }
    A$dim <- A$names <- A$dimnames <- NULL
    A$ischar <- ischar
    at[[i]] <- A
  }
  assign('origAttributes', at, pos=if(.R.)'.GlobalEnv' else 1)
  matrix(unlist(x), ncol=k,
         dimnames=list(a$row.names, a$names))
}


matrix2dataFrame <- function(x, at=origAttributes, restoreAll=TRUE)
{
  d <- dimnames(x)
  k <- length(d[[2]])
  w <- vector('list',k)
  nam <- names(w) <- d[[2]]
  sm <- storage.mode(x)
  
  for(i in 1:k) {
    a <- at[[nam[i]]]
    isc <- a$ischar
    if(!length(a))
      next

    xi <- x[,i]
    names(xi) <- NULL
    if(restoreAll) {
      a$ischar <- NULL
      if(isc) {
        xi <- as.character(xi)
        a$levels <- NULL
        if(length(a$class)) a$class <- setdiff(a$class, 'factor')
      }
      attributes(xi) <- a
    } else {
      if(length(l   <- a$label))
        label(xi) <- l
      
      if(length(u   <- a$units))
        units(xi) <- u
      
      if(length(lev <- a$levels)) {
        xi <- factor(xi, 1:length(lev), lev)
        if(isc) xi <- as.character(xi)
      }
    }
    
    w[[i]] <- xi
  }
  rn <- d[[1]]
  if(!length(rn)) rn <- as.character(seq(along=xi))
  structure(w, class='data.frame', row.names=rn)
}


stripChart <- function(x, xlim, xlab='', pch=1,
                       cex.labels=par('cex'), cex.points=.5,
                       lcolor=if(.R.)'gray' else par('col'),
                       grid=FALSE)
{
  groups <- names(x)
  if(missing(xlim))
    xlim <- range(unlist(x),na.rm=TRUE)
  
  i <- integer(0)

  if(grid) {
    lines <- llines;
    points <- lpoints;
    segments <- lsegments
  }

  if(.R.)
    plot.new()
  
  mai <- omai <- par('mai')
  on.exit(par(mai=omai))
  mxlab <- .3+max(strwidth(groups, units='inches', cex=cex.labels))
  mai[2] <- mxlab
  par(mai=mai, new=TRUE)
  
  plot(xlim, c(.5,length(groups)+.5), xlim=xlim, xlab='', ylab='',
       axes=FALSE, type='n')
  box()
  mgp.axis(1, axistitle=xlab)

  if(.R.)
    mtext(paste(groups,''), 2, 0, at=length(groups):1,
          adj=1, las=1, cex=cex.labels)
  else
    mtext(paste(groups,''), 2, 0, at=length(groups):1,
          adj=1, srt=0, cex=cex.labels)

  y <- 0
  abline(h = 1:length(groups), lty = 1, lwd=1, col=lcolor)

  for(Y in length(groups):1) {
    y <- y + 1
    X <- x[[y]]
    if(length(X))
      points(X, rep(Y, length(X)), pch=pch)
  }
}
## marginals applies only to symbol="therm", orig.scale to symbol="circle"

symbol.freq <- function(x, y, symbol=c("thermometer","circle"), 
                        marginals=FALSE, orig.scale=FALSE,
                        inches=.25, width=.15, subset, srtx=0, ...)
{
  symbol <- match.arg(symbol)
  if(missing(subset))
    subset <- rep(TRUE, length(x))

  if(!is.logical(subset)) {
	s <- rep(FALSE,length(x))
	s[subset] <- FALSE
	subset <- s
  }

  xlab <- attr(x,'label')
  if(!length(xlab))
    xlab <- as.character(substitute(x))

  ylab <- attr(y,'label')
  if(!length(ylab))
    ylab <- as.character(substitute(y))
  
  s <- !(is.na(x) | is.na(y)) & subset
  x <- x[s]
  y <- y[s]
  f <- table(x, y)
  dx <- dimnames(f)[[1]]
  dy <- dimnames(f)[[2]]
  if(orig.scale)
    xp <- as.numeric(dimnames(f)[[1]])
  else
    xp <- 1:length(dimnames(f)[[1]])

  xp1 <- length(xp)+1
  if(orig.scale)
    yp <- as.numeric(dimnames(f)[[2]])
  else
    yp <- 1:length(dimnames(f)[[2]])
  
  yp1 <- length(yp)+1
  m <- nrow(f) * ncol(f)
  xx <- single(m)
  yy <- single(m)
  zz <- single(m)
  k <- 0
  for(i in 1:nrow(f)) {
    for(j in 1:ncol(f)) {
      k <- k + 1
      xx[k] <- xp[i]
      yy[k] <- yp[j]
      if(f[i, j] > 0)
        zz[k] <- f[i, j]
      else zz[k] <- NA
    }
  }

  maxn <- max(f)
  n <- 10^round(log10(maxn))
  if(marginals) {
    xx <- c(xx, rep(xp1, length(yp)))
    yy <- c(yy, yp)
    zz <- c(zz, table(y)/2)
    xx <- c(xx, xp)
    yy <- c(yy, rep(yp1, length(xp)))
    zz <- c(zz, table(x)/2)		
    xx <- c(xx, xp1)
    yy <- c(yy, yp1)
    zz <- c(zz, n)
  }

  if(symbol=="circle") {
    ##		zz <- inches*sqrt(zz/maxn)
    zz <- sqrt(zz)
    if(orig.scale)
      symbols(xx,yy,circles=zz,inches=inches,
              smo=.02,xlab=xlab,ylab=ylab,...)
    else
      symbols(xx,yy,circles=zz,inches=inches,smo=.02,
              xlab=xlab,ylab=ylab,axes=FALSE,...)

    title(sub=paste("n=",sum(s),sep=""),adj=0)
    if(marginals) {
      axis(1, at = 1:xp1, 
           label = c(dx, "All/2"), srt=srtx,
           adj=if(srtx>0)1
           else .5)
      
      axis(2, at = 1:yp1, 
           label = c(dy, "All/2"),adj=1)
    } else { #	if(!orig.scale) {
      axis(1, at=xp, label=dx, srt=srtx,
           adj=if(srtx>0)1
           else .5)
      
      axis(2, at=yp, label=dy)
    }

    return(invisible())
  }

  zz <- cbind(rep(width,length(zz)), inches*zz/maxn, rep(0,length(zz)))
  symbols(xx,yy,thermometers=zz,inches=FALSE,
          axes=FALSE,xlab=xlab,ylab=ylab,...) 
  title(sub=paste("n=",sum(s),sep=""),adj=0)
  if(marginals)	{
    text(xp1-width, yp1, n, adj=1, cex=.5)
    axis(1, at = 1:xp1, 
         label = c(dx, "All/2"), srt=srtx,
         adj=if(srtx>0)1
         else .5)
    
    axis(2, at = 1:yp1, 
         label = c(dy, "All/2"),adj=1)
    abline(h=yp1-.5, lty=2)
    abline(v=xp1-.5, lty=2)
  } else {
    axis(1, at=xp, label=dx, srt=srtx,
         adj=if(srtx>0)1
         else .5)
    
    axis(2, at=yp, label=dy)
    cat("click left mouse button to position legend\n")
    xy <- locator(1)
    symbols(xy$x, xy$y, thermometers=cbind(width,inches*n/maxn,0), 
            inches=FALSE,add=TRUE,xlab=xlab,ylab=ylab)
    text(xy$x-width, xy$y, n,adj=1,cex=.5)
  }

  box()
  invisible()
}
## Improvements by Sebastian Weber <Sebastian.Weber@aventis.com> 26Aug03

sys <- if(.R.) function(command, text=NULL, output=TRUE) {
  cmd <- if(length(text))
    paste(command,text)
  else
    command

  if(under.unix)
    system(cmd, intern=output)
  else
    shell(cmd, wait=TRUE, intern=output)
} else if(under.unix) function(..., minimized) unix(...) else function(...,minimized=FALSE) dos(..., minimized=minimized)
t.test.cluster <- function(y, cluster, group, conf.int=.95, ...)
{
  ## See:
  ## Donner A, Birkett N, Buck C, Am J Epi 114:906-914, 1981.
  ## Donner A, Klar N, J Clin Epi 49:435-439, 1996.
  ## Hsieh FY, Stat in Med 8:1195-1201, 1988.

  group <- as.factor(group)
  cluster <- as.factor(cluster)
  s <- !(is.na(y)|is.na(cluster)|is.na(group))
  y <- y[s];
  cluster <- cluster[s];
  group <- group[s]
  n <- length(y)

  if(n<2)
    stop("n<2")

  gr <- levels(group)
  if(length(gr)!=2)
    stop("must have exactly two treatment groups")

  n <- table(group)
  nc <- tapply(cluster, group, function(x)length(unique(x)))
  bar <- tapply(y, group, mean)

  u <- oldUnclass(group)
  y1 <- y[u==1];
  y2 <- y[u==2]
  
  c1 <- factor(cluster[u==1]);
  c2 <- factor(cluster[u==2]) #factor rids unused lev
  
  b1 <- tapply(y1, c1, mean);
  b2 <- tapply(y2, c2, mean)
  
  m1 <- table(c1);
  m2 <- table(c2)
  
  if(any(names(m1)!=names(b1)))
    stop("logic error 1")
  
  if(any(names(m2)!=names(b2)))
    stop("logic error 2")
  
  if(any(m2 < 2))
    stop(paste('The following clusters contain only one observation:',
               paste(names(m2[m2 < 2]), collapse=' ')))

  M1 <- mean(y1);
  M2 <- mean(y2)
  
  ssc1 <- sum(m1*((b1-M1)^2));
  ssc2 <- sum(m2*((b2-M2)^2))
  
  if(nc[1]!=length(m1))
    stop("logic error 3")
  
  if(nc[2]!=length(m2))
    stop("logic error 4")
  
  df.msc <- sum(nc)-2
  msc <- (ssc1+ssc2)/df.msc
  v1 <- tapply(y1,c1,var);
  v2 <- tapply(y2,c2,var)
  
  ssw1 <- sum((m1-1)*v1);
  ssw2 <- sum((m2-1)*v2)
  
  df.mse <- sum(n)-sum(nc)
  mse <- (ssw1+ssw2)/df.mse
  na <- (sum(n)-(sum(m1^2)/n[1]+sum(m2^2)/n[2]))/(sum(nc)-1)
  rho <- (msc-mse)/(msc+(na-1)*mse)
  r <- max(rho, 0)
  C1 <- sum(m1*(1+(m1-1)*r))/n[1]
  C2 <- sum(m2*(1+(m2-1)*r))/n[2]
  v <- mse*(C1/n[1]+C2/n[2])
  v.unadj <- mse*(1/n[1]+1/n[2])
  de <- v/v.unadj
  dif <- diff(bar)
  se <- sqrt(v)
  zcrit <- qnorm((1+conf.int)/2)
  cl <- c(dif-zcrit*se, dif+zcrit*se)
  z <- dif/se
  P <- 2*pnorm(-abs(z))

  
  stats <-
    matrix(NA, nrow=20, ncol=2,
           dimnames=list(c("N","Clusters","Mean",
                           "SS among clusters within groups",
                           "SS within clusters within groups",
                           "MS among clusters within groups","d.f.",
                           "MS within clusters within groups","d.f.",
                           "Na","Intracluster correlation",
                           "Variance Correction Factor","Variance of effect",
                           "Variance without cluster adjustment","Design Effect",
                           "Effect (Difference in Means)",
                           "S.E. of Effect",paste(format(conf.int),"Confidence limits"),
                           "Z Statistic","2-sided P Value"), gr))

  stats[1,] <- n
  stats[2,] <- nc
  stats[3,] <- bar
  stats[4,] <- c(ssc1, ssc2)
  stats[5,] <- c(ssw1, ssw2)
  stats[6,1] <- msc
  stats[7,1] <- df.msc
  stats[8,1] <- mse
  stats[9,1] <- df.mse
  stats[10,1] <- na
  stats[11,1] <- rho
  stats[12,] <- c(C1, C2)
  stats[13,1] <- v
  stats[14,1] <- v.unadj
  stats[15,1] <- de
  stats[16,1] <- dif
  stats[17,1] <- se
  stats[18,] <- cl
  stats[19,1] <- z
  stats[20,1] <- P

  attr(stats,'class') <- "t.test.cluster"
  stats  
}

print.t.test.cluster <- function(x, digits, ...)
{
  ##   if(!missing(digits)).Options$digits <- digits      6Aug00
  if(!missing(digits)) {
    oldopt <- options(digits=digits)
    on.exit(options(oldopt))
  }

  cstats <- t(apply(x,1,format))
  ##   cstats <- format(x)
  attr(cstats,'class') <- NULL
  cstats[is.na(x)] <- ""
  invisible(print(cstats, quote=FALSE))
}
# $Id: transace.s 506 2007-06-14 20:14:06Z dupontct $
transace <- function(x, monotonic=NULL, categorical=NULL, binary=NULL,
                     pl=TRUE)
{
  if(.R.)
    require('acepack')  # provides ace, avas

  nam <- dimnames(x)[[2]]
  omit <- is.na(x %*% rep(1,ncol(x)))
  omitted <- (1:nrow(x))[omit]
  if(length(omitted)) x <- x[!omit,]
  p <- ncol(x)
  xt <- x  # binary variables retain original coding
  if(!length(nam))
    stop("x must have column names")
  
  rsq <- rep(NA, p)
  names(rsq) <- nam


  for(i in (1:p)[!(nam %in% binary)]) {
    lab <- nam[-i]
    w <- 1:(p-1)
    im <- w[lab %in% monotonic]
    ic <- w[lab %in% categorical]
    if(nam[i] %in% monotonic)
      im <- c(0, im)

    if(nam[i] %in% categorical)
      ic <- c(0, ic)
    m <- 10*(length(im)>0)+(length(ic)>0)
    if(m==11)
      a <- ace(x[,-i], x[,i], mon=im, cat=ic)
    else if (m==10)
      a <- ace(x[,-i], x[,i], mon=im)
    else if(m==1)
      a <- ace(x[,-i], x[,i], cat=ic)
    else
      a <- ace(x[,-i], x[,i])

    xt[,i] <- a$ty
    rsq[i] <- a$rsq
    if(pl)
      plot(x[,i], xt[,i], xlab=nam[i], ylab=paste("Transformed",nam[i]))
  }

  cat("R-squared achieved in predicting each variable:\n\n")
  print(rsq)

  attr(xt, "rsq") <- rsq
  attr(xt, "omitted") <- omitted
  invisible(xt)
}


areg.boot <- function(x, data, weights, subset, na.action=na.delete,
                      B = 100, method=c('areg','avas'), nk=4, evaluation=100, 
                      valrsq=TRUE, probs=c(.25,.5,.75),
                      tolerance=NULL)
{
  acall   <- match.call()
  method  <- match.arg(method)
  if(.R. && method=='avas') require('acepack')

  if(!inherits(x,'formula')) stop('first argument must be a formula')

  m <- match.call(expand = FALSE)
  Terms <- terms(x, specials=c('I','monotone'))
  m$formula <- x
  m$x <- m$B <- m$method <- m$evaluation <- m$valrsq <- m$probs <- 
    m$nk <- m$tolerance <- NULL
  m$na.action <- na.action
  
  m[[1]] <- as.name("model.frame")
  x <- eval(m, sys.parent())

  nam <- names(x)
  ylab <- nam[1]
  nam <- nam[-1]

  k <- length(x)
  p <- k - 1
  nact <- attr(x,"na.action")
  
  default <- if(nk==0)'l' else 's'
  xtype <- rep(default, p); ytype <- default
  names(xtype) <- nam
  linear <- attr(Terms,'specials')$I
  if(length(linear)) {
    if(any(linear==1)) ytype <- 'l'
    if(any(linear>1 )) xtype[linear-1] <- 'l'
  }
  mono <- attr(Terms,'specials')$monotone
  if(length(mono)) {
    if(method=='avas' && any(mono==1))
      stop('y is always monotone with method="avas"')
    if(method=='areg') stop('monotone not implemented by areg')
    xtype[mono-1] <- 'm'
  }

  xbase <- 'x'
  weights <- model.extract(x, weights)
  cat.levels <- values <- vector('list',k)
  names(cat.levels) <- names(values) <- c(ylab,nam)

  for(j in 1:k) {
    typ <- ' '
    xj <- x[[j]]
    if(is.character(xj)) {
      xj <- as.factor(xj)
      cat.levels[[j]] <- lev <- levels(xj)
      x[[j]] <- as.integer(xj)
      typ <- 'c'
      values[[j]] <- 1:length(lev)
    } else if(is.category(xj)) {
      cat.levels[[j]] <- lev <- levels(xj)
      x[[j]] <- as.integer(xj)
      typ <- 'c'
      values[[j]] <- 1:length(lev)
      if(method=='avas' && j==1)
        stop('categorical y not allowed for method="avas"')
    } else {
      xj <- oldUnclass(xj) # 5Mar01
      xu <- sort(unique(xj))
      nu <- length(xu)
      if(nu < 3) typ <- 'l'
      values[[j]] <- if(nu <= length(probs)) xu else quantile(xj,probs)
    }
    if(typ != ' ') {
      if(j==1) ytype <- typ else xtype[j-1] <- typ
    }
  }

  y <- x[,1]
  x <- x[,-1,drop=FALSE]
  n <- length(y)

  if(length(weights)) stop('weights not implemented for areg') else
   weights <- rep(1,n)

  f <- if(method=='areg')
    areg(x, y, xtype=xtype, ytype=ytype,
         nk=nk, na.rm=FALSE, tolerance=tolerance) else {
    Avas <- function(x, y, xtype, ytype, weights) {
      p <- ncol(x)
      mono <- (0:(p-1))[xtype=='m']
      lin  <- c(0[ytype=='l'], (0:(p-1))[xtype=='l'])
      categ<- c(0[ytype=='c'], (0:(p-1))[xtype=='c'])
      if(.R.) avas(x, y, weights, cat=categ, mon=mono, lin=lin) else
       avas(x, y, weights, mon=mono, lin=lin, cat=categ)
    }
    Avas(x, y, xtype, ytype, weights)
  }
  rsquared.app <- f$rsquared

  f.orig <- lm.fit.qr.bare(f$tx, f$ty)
  coef.orig <- f.orig$coefficients
  names(coef.orig) <- cnam <- c('Intercept',nam)
  lp <- f$ty - f.orig$residuals

  trans <- cbind(f$ty,f$tx)
  Xo <- cbind(y, x)
  xlim <- apply(Xo, 2, range)
  xlim[,1] <- range(trans[,1])
  nam <- c(ylab, nam)
  fit <- vector('list',k)
  names(fit) <- nam
  neval <- rep(evaluation, k)
  for(i in 1:k) {
    iscat <- if(i==1) ytype=='c' else xtype[i-1]=='c'
    if(iscat) neval[i] <- xlim[2,i]
    ## Note: approx will return NAs even when rule=3 if x coordinate
    ## contains duplicates, so sort by x and remove dups (fctn in Misc.s)
    fit[[i]] <-
      if(i==1)
        approxExtrap(trans[,1],y,
                     xout=seq(xlim[1,i],xlim[2,i],length=neval[i]))
      else
        approxExtrap(Xo[,i], trans[,i],
                     xout=seq(xlim[1,i],xlim[2,i],length=neval[i]))
  }

  if(max(neval) > evaluation) 
    stop('evaluation must be >= # levels of categorical predictors')

  boot <- array(NA, c(evaluation,B,k), list(NULL,NULL,nam))
  coefs <- matrix(NA, nrow=B, ncol=k, dimnames=list(NULL,cnam))

  optimism <- 0

  nfail <- 0
  for(b in 1:B) {
    cat(b,'\r')
    s <- sample(n, n, rep = TRUE)
    g <- if(method=='areg')
      areg(x[s,,drop=FALSE], y[s], xtype=xtype, ytype=ytype, nk=nk,
           na.rm=FALSE, tolerance=tolerance) else
      Avas(x[s,,drop=FALSE], y[s], xtype=xtype, ytype=ytype,
           weights=weights[s])
    if(!all(is.finite(g$tx))) {
      nfail <- nfail + 1
      next
    }

    f.ols <- lm.fit.qr.bare(g$tx, g$ty)
    cof <- f.ols$coefficients
    coefs[b,] <- cof

    X <- Xo[s,]
    trans <- cbind(g$ty, g$tx)
    for(i in 1:k)
      boot[1:neval[i],b,i] <-
        if(i==1) approxExtrap(trans[,1],X[,1],
                              xout=seq(xlim[1,i],xlim[2,i],length=neval[i]))$y
        else
          approxExtrap(X[,i], trans[,i],
                       xout=seq(xlim[1,i],xlim[2,i],
                                length=neval[i]))$y

    if(valrsq) {
      rsq.boot <- f.ols$rsquared
      yxt.orig <- matrix(NA,nrow=n,ncol=k)
      for(i in 1:k)
        yxt.orig[,i] <- approxExtrap(X[,i],trans[,i],xout=Xo[,i])$y


      yt.hat <- cbind(1,yxt.orig[,-1]) %*% cof
      yt <- yxt.orig[,1]
      resid <- yt - yt.hat
      yt <- yt[!is.na(resid)]
      resid <- resid[!is.na(resid)]
      m <- length(resid)
      sst <- sum((yt - mean(yt))^2)
      sse <- sum(resid^2)
      rsquare <- 1 - sse/sst
      optimism <- optimism + rsq.boot - rsquare
    }
  }
  cat('\n')
  if(nfail > 0)
    warning(paste(method,'failed to converge in',
                  nfail,'resamples'))
  
  rsq.val <- if(valrsq) rsquared.app - optimism/(B-nfail)

  structure(list(call=acall, method=method, 
                 coefficients=coef.orig,
                 linear.predictors=if(.R.)lp else as.single(lp),
                 fitted.values=approxExtrap(fit[[1]],xout=lp)$y,
                 residuals=if(.R.)f.orig$residuals
                           else as.single(f.orig$residuals),
                 na.action=nact, fit=fit, n=n, nk=nk,
                 xtype=xtype, ytype=ytype,
                 xdf=f$xdf, ydf=f$ydf,
                 cat.levels=cat.levels, values=values,
                 rsquared.app=rsquared.app,rsquared.val=rsq.val,
                 boot=boot, coef.boot=coefs, nfail=nfail), class='areg.boot')
}


print.areg.boot <- function(x, ...)
{
  cat("\n")
  cat(x$method,"Additive Regression Model\n\n")
  dput(x$call)
  cat("\n")

  xinfo <- data.frame(type=x$xtype, row.names=names(x$xtype))
  if(length(x$xdf)) xinfo$d.f. <- x$xdf
  cat('\nPredictor Types\n\n')
  print(xinfo)
  cat('\ny type:', x$ytype)
  if(length(x$ydf)) cat('\td.f.:', x$ydf)
  cat('\n\n')

  if(length(x$nfail) && x$nfail > 0)
    cat('\n',x$method,' failed to converge in ',
        x$nfail,' resamples\n\n',sep='')

  if(length(z <- x$na.action)) naprint(z)

  cat('n=',x$n,'  p=',length(x$fit)-1,
      '\n\nApparent R2 on transformed Y scale:',round(x$rsquared.app,3))
  if(length(x$rsquared.val))
    cat('\nBootstrap validated R2            :',round(x$rsquared.val,3))

  cat('\n\nCoefficients of standardized transformations:\n\n')
  print(x$coefficients)
  res <- x$residuals
  rq <- c(quantile(res), mean(res), sqrt(var(res)))
  names(rq) <- c("Min", "1Q", "Median", "3Q", "Max", "Mean", "S.D.")
  cat("\n\nResiduals on transformed scale:\n\n")
  print(rq)
  cat('\n')
  invisible()
}


summary.areg.boot <- function(object, conf.int=.95, values, adj.to,
                              statistic='median',q=NULL, ...)
{
  scall   <- match.call()
  fit <- object$fit
  Boot <- object$boot
  Values <- object$values
  if(!missing(values)) Values[names(values)] <- values

  nfail <- object$nfail
  if(!length(nfail)) nfail <- 0
  
  res <- object$residuals
  
  Adj.to <- sapply(Values, function(y)median(1*y))
  names(Adj.to) <- names(Values)   # median adds .50% in R
  if(!missing(adj.to))
    Adj.to[names(adj.to)] <- adj.to

  zcrit <- qnorm((1+conf.int)/2)
  k <- length(fit)
  p <- k - 1
  B <- dim(Boot)[2]
  nam <- names(fit)
  coef.orig <- object$coefficients
  coefs <- object$coef.boot
  trans.orig.y <- fit[[1]]
  ytransseq <- trans.orig.y[[1]]

  ## The next 2 loops are required because it takes an extra step to compute 
  ## the linear predictor at all predictor adjust-to settings, not just jth
  ## Get predicted transformed y with all variables set to adj. values
  pred.ty.adj <- double(p)
  for(j in 2:k) {
    namj <- nam[j]
    trans.orig <- fit[[namj]]
    pred.ty.adj[j-1] <- coef.orig[j] *
      approxExtrap(trans.orig, xout=Adj.to[namj])$y
  }

  ## For each bootstrap rep compute term summarizing the contribution
  ## of the jth predictor, evaluated at the adj. value, to predicting
  ## the transformed y, using only transformations from that boot. rep.
  boot.adj <- matrix(NA, nrow=B, ncol=p)
  for(j in 2:k) {
    namj <- nam[j]
    adjj <- Adj.to[namj]
    bootj <- Boot[,,j]
    xt <- fit[[namj]]$x
    for(i in 1:B) {
      bootji <- bootj[,i]
      s <- !is.na(bootji)
      ## is.na added 3Apr01
      if(!is.na(coefs[i,j])) 
        boot.adj[i, j-1] <- coefs[i,j]*approxExtrap(xt[s], bootji[s],
                                                    xout=adjj)$y
    }
  }
  
  ## Now for each predictor compute differences in the chosen
  ## statistical parameter for the original scale of predicted y

  boot.y <- Boot[,,1]
  R <- vector('list',p)
  names(R) <- nam[-1]

  for(j in 2:k) {
    namj <- nam[j]
    xv <- Values[[namj]]
    trans.orig <- fit[[namj]]
    pred.term <- coef.orig[j]*approxExtrap(trans.orig, xout=xv)$y
    pred.ty <- coef.orig[1] + sum(pred.ty.adj[-(j-1)]) + pred.term
    ##	pred.y <- approx(trans.orig.y$y, trans.orig.y$x, xout=pred.ty,rule=3)$y
    pred.y <- smearingEst(pred.ty, trans.orig.y, res,
                          statistic=statistic, q=q)
    lab <- attr(pred.y,'label')
    diff.pred <- pred.y[-1] - pred.y[1]

    ## For the same variable (j) repeat this over bootstrap reps

    sumd <- sumd2 <- rep(0, length(xv)-1)
    bootj <- Boot[,,j]
    xt <- trans.orig$x
    b <- 0
    bmiss <- 0
    for(i in 1:B) {
      if(is.na(coefs[i,j]))
        next   ## From avas/ace failure

      bootji <- bootj[,i]
      s <- !is.na(bootji)
      pred.term <- coefs[i,j]*approxExtrap(xt[s],bootji[s], xout=xv)$y
      if(any(is.na(pred.term))) {
        bmiss <- bmiss+1
        next
      }
      pred.ty <- coefs[i,1] + sum(boot.adj[i,-(j-1)]) + pred.term
      s <- !is.na(boot.y[,i])
      pred.y <- smearingEst(pred.ty, list(x=ytransseq,y=boot.y[,i]), res,
                            statistic=statistic, q=q)
      if(any(is.na(pred.y))) {
        bmiss <- bmiss+1
        next
      }

      b <- b + 1
      dp <- pred.y[-1] - pred.y[1]
      sumd <- sumd + dp
      sumd2 <- sumd2 + dp*dp
    }

    if(b < B)
      warning(paste('For',bmiss,'bootstrap samples a predicted value for one of the settings for',namj,'\ncould not be computed.  These bootstrap samples ignored.\nConsider using less extreme predictor settings.\n'))

    sediff <- sqrt((sumd2 - sumd*sumd/b)/(b-1))
    r <- cbind(c(0,  diff.pred), c(NA, sediff),
               c(NA, diff.pred-zcrit*sediff),
               c(NA, diff.pred+zcrit*sediff),
               c(NA, diff.pred/sediff),
               c(NA, 2*(1-pnorm(abs(diff.pred/sediff)))))
    cl <- object$cat.levels[[namj]]
    dimnames(r) <- list(x=if(length(cl))cl
                          else format(xv),
                        c('Differences','S.E',paste('Lower',conf.int),
                          paste('Upper',conf.int),"Z","Pr(|Z|)"))

    R[[j-1]] <- r
  }

  if(nchar(lab) > 10)
    lab <- substring(lab, 1, 10)

  structure(list(call=scall, results=R, adj.to=Adj.to, label=lab,
                 B=B, nfail=nfail, bmiss=bmiss),
            class='summary.areg.boot')
}


print.summary.areg.boot <- function(x, ...)
{
  R <- x$results
  adj.to <- x$adj.to
  nam <- names(R)
  dput(x$call)

  cat('\nEstimates based on', x$B-x$nfail-x$bmiss, 'resamples\n\n')

  cat('\n\nValues to which predictors are set when estimating\neffects of other predictors:\n\n')
  print(adj.to)

  cat('\nEstimates of differences of effects on',x$label,'Y (from first X value),\nand bootstrap standard errors of these differences.\nSettings for X are shown as row headings.\n')
  for(j in 1:length(nam)) {
    cat('\n\nPredictor:',nam[j],'\n')
    print(R[[j]])
  }

  invisible()
}


plot.areg.boot <- function(x, ylim, boot=TRUE,
                           col.boot=2, lwd.boot=.15, conf.int=.95,
                           ...)
{
  fit <- x$fit
  Boot <- x$boot
  k <- length(fit)
  B <- dim(Boot)[2]
  nam <- names(fit)
  boot <- if(is.logical(boot)) (if(boot) B
                                else 0)
          else min(boot, B)
  
  mfr <- par('mfrow')
  if(!length(mfr) || max(mfr) == 1) {
    mf <-
      if(k<=2)c(1,2)
      else if(k<=4)c(2,2)
      else if(k<=6)c(2,3)
      else if(k<=9)c(3,3)
      else if(k<=12)c(3,4)
      else if(k<=16) c(4,4)
      else c(4,5)

    oldmfrow <- par(mfrow=mf,err=-1)
    on.exit(par(oldmfrow))
  }

  Levels <- x$cat.levels
  for(i in 1:k) {
    fiti <- fit[[i]]
    if(i==1)
      fiti <- list(x=fiti[[2]], y=fiti[[1]])

    xx <- fiti[[1]]
    y <- fiti[[2]]
    lx <- length(xx)
    booti <- Boot[,,i]
    yl <- if(!missing(ylim))
      ylim
    else {
      rbi <- quantile(booti,c(.01,.99),na.rm=TRUE)
      if(i==1)
        range(approxExtrap(fiti, xout=rbi)$y)
      else range(rbi)
    }

    levi <- Levels[[i]]
    plot(xx, y, ylim=yl,
         xlab=nam[i], ylab=paste('Transformed',nam[i]), type='n', lwd=3,
         axes=length(levi)==0)
    if(ll <- length(levi)) {
      mgp.axis(2, pretty(yl))
      mgp.axis(1, at=1:ll, labels=levi)
    }

    if(boot>0)
      for(j in 1:boot) {
        if(i==1) {
          if(any(is.na(booti[1:lx,j]))) next
          lines(xx, approxExtrap(fiti, xout=booti[1:lx,j])$y,
                col=col.boot, lwd=lwd.boot)
        }
        else
          lines(xx, booti[1:lx,j], col=col.boot, lwd=lwd.boot)
      }

    if(!(is.logical(conf.int) && !conf.int)) {
      quant <- apply(booti[1:lx,],1,quantile,
                     na.rm=TRUE,probs=c((1-conf.int)/2, (1+conf.int)/2))
      if(i==1) {
        lines(xx, approxExtrap(fiti, xout=quant[1,])$y, lwd=2)
        lines(xx, approxExtrap(fiti, xout=quant[2,])$y, lwd=2)
      } else {
        lines(xx, quant[1,], lwd=2)
        lines(xx, quant[2,], lwd=2)
      }
    }

    lines(xx, fiti[[2]], lwd=3)
  }

  invisible()
}


Function.areg.boot <-
  function(object, type=c('list','individual'),
           ytype=c('transformed','inverse'),
           prefix='.', suffix='', frame=0,
           where=1, ...)
{
  type <- match.arg(type)
  ytype <- match.arg(ytype)
  if(missing(type) && !(missing(prefix) & missing(suffix) &
                        missing(frame) & missing(where)))
    type <- 'individual'

  fit <- object$fit
  k <- length(fit)
  nam <- names(fit)
  g <- vector('list',k)
  xtype <- object$xtype
  typey <- object$ytype

  catl <- object$cat.levels
  names(g) <- nam
  for(i in 1:k) {
    typ <- if(i==1) typey else xtype[i-1]
    if(typ=='c') {
      if(i==1 && ytype=='inverse')
        stop('currently does not handle ytype="inverse" when y is categorical')

      h <- function(x, trantab)
      {
        if(is.category(x)) x <- as.character(x)
        trantab[x]
      }

      w <- fit[[i]]$y
      names(w) <- catl[[nam[i]]]
      formals(h) <- list(x=numeric(0), trantab=w)
    } else {
      h <- function(x, trantab)
      {
        s <- !is.na(x)
        res <- rep(NA, length(x))
        res[s] <- approxExtrap(trantab, xout=x[s])$y
        res
      }

      fiti <- fit[[i]]
      formals(h) <- list(x=numeric(0),
                         trantab=if(i==1 && ytype=='transformed')
                                   list(x=fiti[[2]],y=fiti[[1]])
                                 else fiti)
    }

    g[[i]] <- h
  }

  if(type=='list')
    return(g)

  fun.name <- paste(prefix, nam, suffix, sep='')
  for(i in 1:k)
    if(missing(where))
      assign(fun.name[i], g[[i]], frame=frame)
    else if(.R.)
      assign(fun.name[i], g[[i]], pos=where)
    else
      assign(fun.name[i], g[[i]], where=where)

  invisible(fun.name)
}


predict.areg.boot <-
  function(object, newdata, 
           statistic=c('lp','median','quantile','mean',
             'fitted','terms'), q=NULL, ...)
{
  if(!is.function(statistic))
    statistic <- match.arg(statistic)

  fit  <- object$fit
  fity <- fit[[1]]
  res  <- object$residuals
  if(missing(newdata)) {
    if(statistic=='terms')
      stop('statistic cannot be "terms" when newdata is omitted')

    lp <- object$linear.predictors
    y <- smearingEst(lp, fity, res, statistic=statistic, q=q)
    nac <- object$na.action
    return(if(length(nac)) nafitted(nac, y)
           else y)
  }
  
  cof <- object$coefficients
  Fun <- Function(object)
  nam <- names(fit)
  p <- length(nam)-1
  X <- matrix(NA, nrow=length(newdata[[1]]), ncol=p)
  for(i in 1:p) {
    nami <- nam[i+1]
    X[,i] <- Fun[[nami]](newdata[[nami]])
  }

  if(!is.function(statistic) && statistic=='terms')
    return(X)

  lp <- matxv(X, cof)
  smearingEst(lp, fity, res, statistic=statistic, q=q)
}


monotone <- if(!.SV4.)
  function(x) structure(x, class = unique(c("monotone",
                                            attr(x,'class')))) else
function(x) structure(x, class='monotone')
## SV4 can't handle multiple inheritance.  The above gets rid
## of e.g. "imputed" class

Mean <- function(object, ...) UseMethod("Mean")
Quantile <- function(object, ...) UseMethod("Quantile")


Mean.areg.boot <- function(object, evaluation=200, ...)
{
  r <- range(object$linear.predictors)
  lp <- seq(r[1], r[2], length=evaluation)
  res <- object$residuals
  ytrans <- object$fit[[1]]
  asing <- if(.R.) function(x)x else as.single

  if(length(lp)*length(res) < 100000)
    means <- asing(smearingEst(lp, ytrans, res, statistic='mean'))
  else {
    means <- if(.R.)double(evaluation)
             else single(evaluation)
    for(i in 1:evaluation)
      means[i] <- mean(approxExtrap(ytrans, xout=lp[i]+res)$y)
  }

  g <- function(lp, trantab) approxExtrap(trantab, xout=lp)$y

  formals(g) <- list(lp=numeric(0),
                     trantab=list(x=if(.R.)lp
                                    else asing(lp),
                                  y=means))
  g
}


Quantile.areg.boot <- function(object, q=.5, ...)
{
  if(length(q) != 1 || is.na(q))
    stop('q must be length 1 and not NA')
  
  g <- function(lp, trantab, residualQuantile)
    approxExtrap(trantab, xout=lp+residualQuantile)$y

  formals(g) <- list(lp=numeric(0), trantab=object$fit[[1]],
                     residualQuantile <- quantile(object$residuals, q))
  g
}


smearingEst <- function(transEst, inverseTrans, res,
                        statistic=c('median','quantile','mean','fitted','lp'),
                        q=NULL)
{
  if(is.function(statistic))
    label <- deparse(substitute(statistic))
  else {
    statistic <- match.arg(statistic)
    switch(statistic,
           median = {statistic <- 'quantile'; q <- .5; label <- 'Median'},
           quantile = {
             if(!length(q))
               stop('q must be given for statistic="quantile"');
             
             label <- paste(format(q),'quantile')
           },
           mean = {
             statistic <- mean;
             label <- 'Mean'
           },
           fitted = {
             label <- 'Inverse Transformation'
           },
           lp = {
             label <- 'Transformed'
           })
  }
  y <- if(is.function(statistic)) {
    if(is.list(inverseTrans))
      apply(outer(transEst, res,
                  function(a, b, ytab) approxExtrap(ytab, xout=a+b)$y,
                   inverseTrans), 1, statistic) else
    apply(outer(transEst, res, function(a, b, invfun)invfun(a+b),
                inverseTrans), 1, statistic)
  } else switch(statistic,
                lp = transEst,
                fitted = if(is.list(inverseTrans))
                approxExtrap(
                             inverseTrans,
                             xout=transEst)$y else
                           inverseTrans(transEst),
                quantile = if(is.list(inverseTrans))
                approxExtrap(
                             inverseTrans,
                             xout=transEst+quantile(res,q))$y else
                inverseTrans(transEst+quantile(res,q)))
  structure(y, class='labelled', label=label)
}
## $Id: transcan.s 346 2006-10-23 18:15:45Z dupontct $

transcan <-
  function(x, method=c("canonical","pc"),
           categorical=NULL, asis=NULL, nk, 
           imputed=FALSE, n.impute, 
           boot.method=c('approximate bayesian', 'simple'),
           trantab=FALSE, transformed=FALSE,
           impcat=c("score","multinom","rpart","tree"),
           mincut=40,
           inverse=c('linearInterp','sample'), tolInverse=.05,
           pr=TRUE, pl=TRUE, allpl=FALSE, show.na=TRUE,
           imputed.actual=c('none','datadensity','hist','qq','ecdf'),
           iter.max=50, eps=.1, curtail=TRUE, 
           imp.con=FALSE, shrink=FALSE, init.cat="mode",
           nres=if(boot.method=='simple')200 else 400,
           data, subset, na.action, treeinfo=FALSE,
           rhsImp=c('mean','random'),
           details.impcat='', ...)
{
  ##This is a non-.Internal version of the approx function.  The
  ##S-Plus version of approx sometimes bombs with a bus error.

  asing <- if(.R.) function(x)x else as.single
  
  if(version$major < 4 && !.R.)
    approx <- function(x, y, xout, method = "linear", n = 50, rule =
                       1, f = 0){
      nx <- length(x)
      if(any(is.na(x)) || any(is.na(y)))
        stop("Missing values not allowed")
      
      if(nx != length(y))
        stop("Lengths of x and y must match")
      
      if(nx < 2)
        stop("need at least 2 points")
      
      i <- order(x)
      x <- x[i]
      y <- y[i]
      if(missing(xout))
        xout <- seq(x[1], x[nx], length = n)
      else n <- length(xout)

      methods <- c("linear", "constant")
      if(!(imeth <- pmatch(method, methods, nomatch = 0)))
        stop("method must be \"linear\" or \"constant\"")
      
      method <- methods[imeth]
      if(method == "linear") {
        f <- -1
      }
      else if(method == "constant") {
        if(f < 0 || f > 1)
          stop("f must be in [0,1]")
      }

      val <-  .Fortran("approx",
                       x = as.single(x),
                       y = as.single(y),
                       nx = as.integer(nx),
                       xout = as.single(xout),
                       m = as.integer(n),
                       rule = as.integer(rule),
                       f = as.single(f),
                       yout = single(n),
                       iscr = single(n))[c("xout", "yout")]
      names(val) <- c("x", "y")
      val
    }

  call        <- match.call()
  method      <- match.arg(method)
  impcat      <- match.arg(impcat)
  boot.method <- match.arg(boot.method)
  imputed.actual <- match.arg(imputed.actual)
  inverse     <- match.arg(inverse)
  rhsImp      <- match.arg(rhsImp)

  if(missing(n.impute))
    n.impute <- 0
  
  if(n.impute > 0) {
    imputed <- TRUE
    if(impcat %in% c('rpart','tree'))
      stop('n.impute not supported for impcat="tree" or "rpart"')
    
    warning('transcan provides only an approximation to true multiple imputation.\nA better approximation is provided by the aregImpute function.\nThe MICE and other S libraries provide imputations from Bayesian posterior distributions.')
  }

  if(imputed.actual!='none')
    imputed <- TRUE

  if(impcat=='multinom') {
    if(.R.)
      require('nnet')
    else if(!existsFunction('multinom'))
      require(nnet)
  }

  if(.R. & missing(data))
    stop('Must specify data= when using R')

  formula <- nact <- NULL

  if(inherits(x,"formula")) {
    formula <- x
    y <- match.call(expand=FALSE)
    y$x <- y$method <- y$categorical <- y$asis <- y$nk <- y$imputed <- 
      y$trantab <- y$impcat <- y$mincut <- y$pr <- y$pl <- y$allpl <- y$show.na <-
        y$iter.max <- y$eps <- y$curtail <- y$imp.con <- y$shrink <-
          y$init.cat <- y$n.impute <- y$... <- y$nres <- y$boot.method <-
            y$transformed <- y$treeinfo <- y$imputed.actual <-
              y$inverse <- y$tolInverse <- y$details.impcat <-
                y$rhsImp <- NULL
    y$formula <- x
  
    if(missing(na.action))
      y$na.action <- na.retain

    y[[1]] <- as.name("model.frame")
    y <- eval(y, sys.parent())
    nact <- attr(y,"na.action")
    d <- dim(y)

    # Error if user is trying to use a non-allowed formula
    if(length(attr(y, "terms")) > 2)
      stop('transcan does not support a left hand side variable in the formula')


    nam <- if(.R.)var.inner(attr(y, "terms"))
           else attr(terms.inner(terms(y)),'term.labels')

    # Error if user has passed an invalid formula
    if(length(nam) != d[2])
      stop(paste('Formula', formula,
                 'does not have a dominant inner variable.'))
    
    if(!length(asis)) {
      Terms <- terms(formula, specials='I')
      asis <- nam[attr(Terms,'specials')$I]
      ## terms.inner will cause I() wrapper to be ignored
    }

    x <- matrix(NA,nrow=d[1],ncol=d[2],
                dimnames=list(attr(y,"row.names"),nam))
    for(i in 1:d[2]) {
      w <- y[[i]]
      if(is.character(w))
        w <- factor(w)

      if(is.factor(w)) { 
        x[,i] <- oldUnclass(w)
        categorical <- c(categorical, nam[i])
      } else {
        x[,i] <- w
        nu <- length(unique(w[!is.na(w)]))
        if(nu<2)
          stop(paste("variable",nam[i],"has only one value"))
        
        if(nu==2)
          asis <- c(asis, nam[i])
        else if(nu==3) categorical <- c(categorical, nam[i])
      }
    }
  }

  nam <- dimnames(x)[[2]]
  rnam <- dimnames(x)[[1]]
  if(length(rnam)==0)
    rnam <- as.character(1:nrow(x))
  
  p <- ncol(x)
  if(is.null(nam))
    stop("x must have column names")

  n <- nrow(x)
  if(missing(nk))
    nk <- 3*(n<30)+4*(n>=30 & n<100)+5*(n>=100)

  ## Compute constant to multiply canonical variates by to get a variance of 1.0
  varconst <- sqrt(n-1)

  if(length(categorical)) { 
    if(length(categorical)==1 && categorical=="*")
      categorical <- nam

    ## oldopts <- options(c('na.action','contrasts'))
    ## R does not allow multiple options to be spec.
    oldopts <- options()
    ##  names(oldopts) <- c('na.action','contrasts') #windows can mess this up
    if(impcat %nin% c('rpart','tree')) {
      options(contrasts=c("contr.treatment","contr.poly"))
      on.exit(options(oldopts))
    }
  }

  if(length(asis)==1 && asis=="*")
    asis <- nam

  R <- parms <- coef <- fill.con <- Imputed <- Trantab <- vector("list",p)
  fillin <- rep(NA,p);
  names(fillin) <- nam
  scale <- rep(1,p);
  names(scale) <- nam;
  
  names(Trantab) <- nam
  nparm <- shr <- fillin
  if(n.impute > 0) {
    Resid <- vector("list",p)
    names(Resid) <- nam
  } else Resid <- NULL

  datad <- list();
  datad.ranges <- list()

  ## For canonical-variate expansions (standardized), use scale of 1
  xcoef <- matrix(NA, nrow=p, ncol=p+1, dimnames=list(nam,c("intercept",nam)))
  usefill <- 1*(is.logical(imp.con) && imp.con)+2*(is.numeric(imp.con))
  if(usefill==2 && length(imp.con)!=p)
    stop("length of imp.con != ncol(x)")

  for(i in 1:p) {
    lab <- nam[i]
    y <- x[,i]
    na <- is.na(y)
    w <- y[!na]
    if(imputed && n.impute==0)
      Imputed[[i]] <- if(.R.)double(sum(na))
                      else single(sum(na))

    if(lab %in% asis) {
      fillin[i] <- if(usefill==2) imp.con[i]
                   else median(w)

      scale[i] <- mean(abs(w-fillin[i]))
      if(is.na(fillin[i]))
        stop(paste("fillin value for",lab,"is NA"))

      coef[[i]] <- c(0,1)
      nparm[i] <- 1
    } else {
      if(lab %in% categorical) {
        w <- table(y)
        z <- as.numeric(names(w))
        if(usefill==2) fillin[i] <- imp.con[i]
        else fillin[i] <- z[w==max(w)][1] #most freq. category

        assign("Y", as.factor(y), 1)
        opold <- options(na.action="na.retain")
        w <- model.matrix(~Y) # uses contr.treatment (reference cell coding)
        options(na.action=opold[[1]]) #for some reason Windows needs opt name
        r <- attr(w,"contrasts")[[1]]
        attr(r,"codes") <- z
        parms[[i]] <- r
        R[[i]] <- w[,-1,drop=FALSE]   #kill intercept column
        nparm[i] <- length(z)-1
        if(usefill>0) {
          fill.con[[i]] <- w[y==imp.con[i],-1,drop=FALSE][1,,drop=FALSE]
          ##select first hit
          if(length(fill.con[[i]])==0)
            stop("imp.con has a code not in the data for a categorical var")
        }
      } else {
        fillin[i] <- if(usefill==2) imp.con[i]
                     else median(y[!is.na(y)])
        
        R[[i]] <- rcspline.eval(y, nk=nk, inclx=TRUE)
        parms[[i]] <- attr(R[[i]], "knots")
        if(usefill>0)
          fill.con[[i]] <- 
            rcspline.eval(fillin[i], parms[[i]], inclx=TRUE)

        nparm[i] <- length(parms[[i]])-1
      }
    }
  }

  xt <- x
  if(init.cat %in% c("mode","random")) for(i in (1:p)[nam %in% categorical])
    xt[,i] <-
      if(init.cat=="mode") {
        if(is.na(fillin[i]))
          stop(paste("fillin value for",nam[i],"is NA"))

        xt[,i]==fillin[i]
      } else runif(n)

  p1 <- p-1
  R2 <- R2.adj <- if(.R.)double(p)
                  else single(p);

  r2 <- r2.adj <- NA
  Details.impcat <- NULL

  last.iter <- FALSE
  cat("Convergence criterion:")

  milab <- as.character(1:n.impute)

  predSamp <- function(res, yhat, rnam, allowed.range, n.impute,
                       boot.method)
  {
    m <- length(yhat)
    yhat <- matrix(rep(yhat, n.impute), ncol=n.impute,
                   dimnames=list(rnam, as.character(1:n.impute)))
    errors <- if(boot.method=='simple')
      sample(res, m*n.impute, replace=TRUE)
    else {
      ## From Jeff Longmate (jlongmat@coh.org):
      n <- length(res)
      i <- ceiling(runif(n*n.impute, 0, n))
      j <- ceiling(runif(m*n.impute, 0, n)) +
        rep((0:(n.impute-1))*n, rep(m, n.impute))
      res[i[j]]
    }

    structure(pmax(pmin(yhat + errors, allowed.range[2]), allowed.range[1]),
              names=NULL)
  }

  anyVarNA <- rep(FALSE, n)

  for(iter in 1:iter.max) {
    dmax <- 0
    if(last.iter) xtl <- xt
    for(i in 1:p) {
      lab <- nam[i]
      catg <- lab %in% categorical
      xx <- xt[,-i,drop=FALSE]
      k.other <- sum(pmax(nparm[-i]-1,0))/(p-1)+p-1  #effective d.f.
      if(iter==1) {
        for(j in 1:p1) {
          if(any(z <- is.na(xx[,j])))	{
            l <- (nam[-i])[j]
            if(is.na(fillin[l]))
              stop(paste("variable",l,"has fillin value of NA"))

            xx[z,j] <- fillin[l]
          }
        }
      }

      if(method=="pc") {
        z <- xx
        for(k in 1:p1) {
          y <- z[,k];
          z[,k] <- (y-mean(y))/sqrt(var(y))
        }

        P <- prcomp(z)$x[,1]   # 1st prin. comp.
      }

      j <- is.na(x[,i])
      anyVarNA[j] <- TRUE
      if(lab %in% asis) {
        y <- x[!j, i]
        f <- lm.fit.qr.bare(xx[!j,,drop=FALSE], y)
        newy <- x[,i]
        names(newy) <- NULL
        xcof <- f$coef
        r2 <- f$rsquared
        nn <- length(y)
        r2.adj <- max(0,1-(1-r2)*(nn-1)/(nn-k.other-1))
        if(shrink) {
          ybar <- mean(y)
          shr[i] <- h <- (nn-k.other-1)*r2/(nn-1)/r2.adj
          xcof <- c(ybar*(1-h)+h*xcof[1],h*xcof[-1])
        }

        if(any(j))
          newy[j] <-
            if(usefill>0) fillin[i]
            else cbind(1,xx[j,,drop=FALSE]) %*% xcof

        res <- f$residuals
        
        if(last.iter) {
          ybar <- mean(y)
          if(imputed & any(j)) {
            r <- range(newy[!j])
            Imputed[[i]] <-
              if(n.impute==0)structure(pmax(pmin(newy[j],r[2]),r[1]),
                                       names=rnam[j])
              else
                predSamp(res, newy[j], rnam[j], r, n.impute, boot.method)

            NULL
          }

          xcoef[i, c("intercept",nam[-i])] <- xcof
          if(trantab) {
            rr <- range(y);
            Trantab[[i]] <- list(x=rr, y=rr);
            NULL
          }

          if(n.impute > 0)
            Resid[[i]] <- 
              if(length(res) <= nres) asing(res)
              else asing(sample(res, nres))

          ## was f$residuals 3 times
        }
      } else {
        f <- cancor(xx[!j,,drop=FALSE], R[[i]][!j,,drop=FALSE])
        r2 <- f$cor[1]^2
        xcof <- c(intercept=-sum(f$xcoef[,1] * f$xcenter),
                  f$xcoef[,1])*varconst
        cof <-
          if(method=="canonical") 
            c(intercept=-sum(f$ycoef[,1] * f$ycenter), 
              f$ycoef[,1])*varconst
          else {
            g <- lm.fit.qr.bare(R[[i]][!j,,drop=FALSE], P[!j])
            g$coef
          }

        newy <- drop(cbind(1,R[[i]]) %*% cof)
        if((n.impute > 0 && last.iter) || rhsImp=='random') 
          res <-
            if(method=='canonical') 
              newy[!j] - cbind(1,xx[!j,,drop=FALSE]) %*% xcof
            else g$residuals

        
        if(n.impute > 0 && last.iter) {
          Resid[[i]] <-
            if(length(res) <= nres) asing(res)
            else asing(sample(res, nres))
        }

        nn <- n - sum(j)
        k <- nparm[i]-1+k.other
        r2.adj <- max(0,1-(1-r2)*(nn-1)/(nn-k-1))
        if(shrink) {
          shr[i] <- h <- (nn-k-1)*r2/(nn-1)/r2.adj
          xcof <- h*xcof   #mean of can var=0
        }

        if(any(j)) newy[j] <- 
          if(usefill>0) drop(cbind(1,fill.con[[i]]) %*% cof)
          else drop(cbind(1,xx[j,,drop=FALSE]) %*% xcof)

        if(last.iter) {
          coef[[i]] <- cof
          xcoef[i,c("intercept",nam[-i])] <- xcof
          if(trantab || (any(j) && catg &&
                         impcat %in% c("score","multinom"))) {
            xa <- x[!j, i]
            ya <- newy[!j]
            tab <- table(paste(as.character(xa),
                               as.character(ya),sep=';'))
            vals <- names(tab)
            uvals <- unPaste(vals, ';')
            names(tab) <- NULL
            Trantab[[i]] <- 
              list(x=uvals[[1]], y=uvals[[2]], frequency=tab)
            NULL
          }

          if(imputed & any(j)) {
            if(catg) {
              if(usefill>0)
                pred <- rep(fillin[i], sum(j))
              else {
                if(impcat %in% c('rpart','tree')) {
                  y <- as.factor(x[,i])
                  zdf <- list(xx=xx, y=y)
                  f <-
                    if(impcat=='tree')
                      tree(y ~ xx,
                           control=tree.control(nobs=sum(!is.na(y)),
                                                mincut=mincut),
                           data=zdf, subset=!is.na(y))
                    else rpart(y ~ xx,
                               control=rpart.control(minsplit=mincut), data=zdf)

                  ## won't work because rpart will not allow matrix x
                  pred <-
                    (t(apply(-predict(f,zdf)[j,,drop=FALSE],1,order)))[,1]
                  if(treeinfo) {
                    cat('\nProbabilities of Category Membership and Category Selected for',lab,'\n\n')
                    print(cbind(round(predict(f,zdf)[j,,drop=FALSE],3),
                                Mode=pred))
                  }

                  ## Gets level number of most probable category
                } else if(impcat=='score') {
                  ##Get category code with score closest to pred. score
                  ti <- Trantab[[i]]
                  if(n.impute==0) {
                    ##ww <- apply(outer(newy[j], ti$y,
                    ##function(x,y)abs(x-y)),1,order)[1,]
                    ww <- order(ti$y)[round(approx(sort(ti$y),
                                                   1:length(ti$y),
                                                   xout=newy[j], rule=2)$y)]

                    ## Thanks from Alan Zaslavsky <zaslavsk@hcp.med.harvard.edu>:
                    ## "The idea is to interpolate (after arranging in order) and then round the
                    ## index, since the fractional part of the index represents the relative 
                    ## distance from the two adjacent values."
                    
                    ##pred <- round(approx(ti$y, ti$x, xout=newy[j], rule=2)$y)
                    pred <- ti$x[ww]
                  } else {
                    sval <- predSamp(0*res, newy[j], rnam[j], c(-Inf,Inf),
                                     n.impute, boot.method)
                    ww <- order(ti$y)[round(approx(sort(ti$y),
                                                   1:length(ti$y),
                                                   xout=sval,
                                                   rule=2)$y)]
                    pred <- matrix(ti$x[ww], ncol=n.impute,
                                   dimnames=list(rnam[j],milab))
                    names(pred) <- NULL
                    if(lab==details.impcat)
                      Details.impcat <-
                        list(pred.trans.na=sval,imputed=pred,
                             pred.trans.nona=cbind(1,xx[!j,]) %*%	xcof,
                             obs=x[!j,i],trantab=ti)
                  }
                } else {
                  ## Multinomial logit
                  zdf <- list(y=as.factor(x[!j,i]),
                              xx=xx[!j,,drop=FALSE])
                  f <- multinom(y ~ xx, data=zdf,
                                trace=FALSE, maxit=200)
                  ncat <- length(levels(zdf$y))
                  ## bug in predict.multinom when predictor is a matrix
                  cf <- coef(f)
                  zdf <- cbind(1,xx[j,,drop=FALSE]) %*%
                    (if(is.matrix(cf)) t(cf) else as.matrix(cf))
                  pred <- exp(cbind(0,zdf))/
                    (1 + apply(exp(zdf),1,sum))
                  dimnames(pred)[[2]] <- as.character(1:ncat)
                  pred <-
                    if(n.impute==0) (t(apply(-pred,1,order)))[,1] 
                    else rMultinom(pred, n.impute)
                }
              }

              if(n.impute==0)
                names(pred) <- rnam[j]

              Imputed[[i]] <- pred
              NULL
            } else {
              if(n.impute==0) {
                if(usefill>0)
                  Im <- rep(fillin[i], sum(j))
                else
                  Im <- invertTabulated(x[!j,i], newy[!j], aty=newy[j],
                                        name=nam[i], inverse=inverse,
                                        tolInverse=tolInverse)

                names(Im) <- rnam[j]
                Imputed[[i]] <- Im
                NULL
              } else {
                
                sval <- predSamp(res, newy[j], rnam[j], c(-Inf,Inf),
                                 n.impute, boot.method)

                sval.orig <- matrix(invertTabulated(x[!j,i], newy[!j],
                                                    aty=sval,
                                                    name=nam[i],
                                                    inverse=inverse,
                                                    tolInverse=tolInverse),
                                    ncol=n.impute,
                                    dimnames=list(rnam[j],milab))

                names(sval.orig) <- NULL
                Imputed[[i]] <- sval.orig
                NULL
              }
            }
          }   ##end imputed
        }       ##end last.iter
      }         ##end non-asis

      if(curtail && any(j)) {
        r <- range(newy[!j])
        newy[j] <- pmax(pmin(newy[j],r[2]),r[1])
      }

      if(iter>1) {
        jj <- if(rhsImp=='mean')TRUE
              else TRUE

        dmax <- max(dmax, min(max(abs(xt[jj,i]-newy[jj]),na.rm=TRUE),
                              max(abs(-xt[jj,i]-newy[jj]),na.rm=TRUE))/scale[i])
        ##Allows for arbitrary flips (negation) of current transformation
      }

      if(rhsImp=='random')
        newy[j] <- newy[j] + sample(res, sum(j), replace=TRUE)
    
      if(last.iter) xtl[,i] <- newy
      else xt[,i] <- newy

      ##don't update working transformations
      ##during last iteration since recomputing x-coefficients
      ##on the basis of current transformations, which may flip rapidly
	
      if((pl & last.iter) | allpl) {
        xti <- if(last.iter) xtl[,i]
               else xt[,i]

        plot(x[,i], xti, xlab=lab,ylab=paste("Transformed",lab))
        title(sub=paste("R2=",format(round(r2,2)),sep=""),cex=.4,adj=0)
        if(any(j))
          title(sub=paste(sum(j),"missing"),cex=.4,adj=1)

        if(show.na && any(j)) {
          scat1d(xti[j], 4, ...)
          if(imputed && last.iter)
            scat1d(as.numeric(Imputed[[i]]), 3, ...)
        }
      }


      if(last.iter && imputed.actual!='none' && any(j)) {
        v1n <- nam[i]; v2n <- paste('Imputed',v1n)
        datad[[v1n]] <- x[!j,i]
        datad[[v2n]] <- Imputed[[i]]
        datad.ranges[[v1n]] <- datad.ranges[[v2n]] <-
          range(c(x[!j,i], Imputed[[i]]), na.rm=TRUE)
      }
    
      R2[i] <- r2; R2.adj[i] <- r2.adj
	
    }   #end i

    if(iter>1)
      cat(format(round(dmax,3)),"")

    if(iter %% 10 == 0)
      cat("\n")

    niter <- iter
    if(last.iter)
      break

    last.iter <- (iter==(iter.max-1)) || (iter>1 && dmax<eps) ||
                 (rhsImp=='random' && iter==5)
  }        #end iter

  cat("\n")

  if(iter.max>3 & niter==iter.max & dmax>=eps)
    stop(paste("no convergence in",iter.max,"iterations"))

  ## Use xtl instead of xt, otherwise transformed variables will not
  ## match ones from predict() or Function() since coefficients have
  ## been updated

  if(rhsImp=='mean')
    cat("Convergence in",niter,"iterations\n")

  if(imputed.actual=='datadensity') {
    lab <- names(datad)
    datadensity.data.frame(datad, ranges=datad.ranges,
                           labels=ifelse((1:length(lab)) %% 2, lab,'Imputed'))
  } else if(imputed.actual !='none') {
    namdd <- names(datad)
    for(i in seq(1,length(datad),by=2)) {
      if(imputed.actual=='hist')
        histbackback(datad[i:(i+1)])
      else {
        v1 <- datad[[i]]; v2 <- datad[[i+1]]
        n1 <- namdd[i]; n2 <- namdd[i+1]
        if(imputed.actual=='ecdf' && is.numeric(datad[[i]]))
          Ecdf(c(v1,v2), xlab=n1,
               group=c(rep('actual',length(v1)),
                       rep('imputed',length(v2))))
        else {
          qqplot(v1, v2, xlab=n1, ylab=n2)
          abline(a=0, b=1, lty=2)
        }
      }
    }
  }

  names(R2) <- nam

  if(pr) {
    cat("R-squared achieved in predicting each variable:\n\n")
    print(round(R2, 3))
  }
  names(R2.adj) <- nam

  if(pr) {
    cat("\nAdjusted R-squared:\n\n")
    print(round(R2.adj, 3))
  }

  if(shrink) {
    names(shr) <- nam
    if(pr) {
      cat("\nShrinkage factors:\n\n")
      print(round(shr,3))
    }
  } else shr <- NULL

  names(parms) <- names(coef) <- nam
  r <- apply(xtl, 2, range)
  dimnames(r) <- list(c("low","high"), nam)

  if(imputed) {
    names(Imputed) <- nam
  } else Imputed <- NULL

  structure(list(call=call, formula=formula, niter=niter, imp.con=usefill>0,
                 n.impute=n.impute, residuals=Resid, rsq=R2, rsq.adj=R2.adj, 
                 shrinkage=shr,
                 inverse=inverse, tolInverse=tolInverse,
                 categorical=categorical, asis=asis, parms=parms, coef=coef,
                 xcoef=xcoef, fillin=fillin, scale=scale, ranges=r,
                 transformed=if(transformed)xtl,
                 trantab=if(trantab)Trantab, imputed=Imputed, na.action=nact,
                 rhsImp=rhsImp, details.impcat=Details.impcat),
            class='transcan')
}


summary.transcan <- function(object, long=FALSE, ...)
{
  ## Check for old style object
  if(!is.list(object))
    object <- attributes(object)

  dput(object$call);
  cat("\n")
  if(length(nact <- object$na.action))
    naprint(nact)

  cat("Iterations:",object$niter,"\n\n")
  cat("R-squared achieved in predicting each variable:\n\n")
  print(round(object$rsq,3))
  cat("\nAdjusted R-squared:\n\n")
  print(round(object$rsq.adj,3))
  if(length(shr <- object$shrink)) {
    cat("\nShrinkage factors:\n\n")
    print(round(shr,3))
  }

  cat("\nCoefficients of canonical variates for predicting each (row) variable\n\n")
  xcoef <- object$xcoef[,-1]
  g <- format(round(xcoef,2))
  g[is.na(xcoef)] <- ""
  print(g, quote=FALSE)

  imp <- object$imputed
  if(length(imp)) {
    nimp <- TRUE
    for(nn in names(imp)) {
      if(length(z <- imp[[nn]])) {
        if(nimp & !long)
          cat("\nSummary of imputed values\n\n");

        nimp <- FALSE
        if(long) {
          cat("\nImputed values for",nn,"\n\n");
          print(z)
        }

        print(describe(as.vector(z), nn))
      }
    }	
  }
  if(object$imp.con) 
    cat("\nImputed values set to these constants:\n\n")
  else cat("\nStarting estimates for imputed values:\n\n")

  print(object$fillin)
  
  invisible()
}


print.transcan <- function(x, long=FALSE, ...)
{
  ## Check for old style
  if(!is.list(x)) {
    trans <- x
    cal   <- attr(x, 'call')
  } else {
    trans <- x$transformed
    cal   <- x$call
  }
  
  dput(cal); cat("\n")
  if(length(trans)) {
    if(long) print(oldUnclass(x))
    else print.default(trans)
  }

  invisible()
}

impute.transcan <-
  function(x, var, imputation,
           name=as.character(substitute(var)),
           where.in, data, where.out=1, frame.out,
           list.out=FALSE,
           pr=TRUE, check=TRUE, ...)
{
  if(!missing(imputation) && length(imputation)>1)
    stop('imputation must be a single number')
  
  ## Check for old style
  imp <- if(is.list(x)) x$imputed
         else attr(x, 'imputed')
  
  if(is.null(imp)) { 
    if(missing(var) && missing(name)) 
      stop('imputed=TRUE was not specified to transcan')
    
    warning("imputed was not specified to transcan")
    return(if(!missing(var))var)
  }

  if(missing(var) && missing(name)) {
    nams   <- names(imp)
    if(list.out) {
      outlist <- vector('list', length(nams))
      names(outlist) <- nams
    }
    if(missing(data)) {
      if(missing(where.in))
        where.in <- find(nams[1])[1]

      var1   <- get(nams[1],where.in)
    } else {
      if(any(ni <- nams %nin% names(data)))
        stop(paste('variable',paste(nams[ni],collapse=','),
                   'not in data'))
      var1 <- data[[nams[1]]]
    }

    namvar <- names(var1)
    if(!length(namvar) && !missing(data))
      namvar <- row.names(data)

    if(check && length(namvar)==0)
      warning(paste('variable',nams[1],
                    'does not have a names() attribute\nand data does not have row.names. Assuming row names are integers.'))

    nimp <- integer(length(nams));
    names(nimp) <- nams
    
    for(nam in nams) {
      i <- imp[[nam]]
      if(!length(i)) {
        if(list.out) outlist[[nam]] <-
          if(missing(data)) get(nam, where.in) else data[[nam]]

        next
      }

      d <- dim(i)
      obsImputed <- if(length(d)) dimnames(i)[[1]] else names(i)
      ## i[,imputation] drops names if only one obs. imputed
      if(!missing(imputation)) {
        if(!length(d)) 
          stop('imputation can only be given when transcan used n.impute')

        if(imputation < 1 || imputation > d[2])
          stop(paste('imputation must be between 1 and',d[2]))

        i <- i[,imputation]
      } else if(length(d)) 
        stop('imputation must be specified when transcan used n.impute')

      v <- if(missing(data)) get(nam, where.in)
           else data[[nam]]

      ## Below was names(i) instead of match(...)
      if(length(namvar)) {
        sub <- match(obsImputed, namvar, nomatch=0)
        i <- i[sub > 0]
        sub <- sub[sub > 0]
      } else {
        if(!all.is.numeric(obsImputed))
          stop(paste('names attribute of ',nam,
                     ' is not all numeric\n',
                     'and original observations did not have names',sep=''))

        sub <- as.integer(obsImputed)
      }
      if(check)
        if((missing(imputation) || imputation==1) &&
           !all(is.na(v[sub])))
          stop(paste('variable',nam,
                     'does not have same missing values as were present when transcan was run'))
      v[sub] <- if(is.factor(v)) levels(v)[as.integer(i)] else i
      ## Note: if v was empty before, new v would have arbitrary length
      ## Avoid problem by requiring all variables to be in data
      attr(v,'imputed') <- sub
      if(!.SV4.)
        attr(v,'class') <- c('impute', attr(v,'class'))

      nimp[nam] <- length(i)
      if(list.out)
        outlist[[nam]] <- v
      else {
        if(.R.)
          assign(nam, v, env=.GlobalEnv)
        else {
          if(missing(frame.out))
            assign(nam, v, where=where.out)
          else
            assign(nam, v, frame=frame.out)
        }
      }
    }

    if(pr) {
      cat('\n\nImputed missing values with the following frequencies\n',
          'and stored them in variables with their original names:\n\n')
      print(nimp[nimp>0])
    }

    if(list.out) {
      z <- sapply(outlist,length)
      if(diff(range(z)) > 0) {
        cat('\n\nLengths of variable vectors:\n\n')
        print(z)
        stop('inconsistant naming of observations led to differing length vectors')
      }
      return(outlist)
    }
    
    return(invisible(nimp))
  }
  
  impval <- imp[[name]]
  if(name %nin% names(imp))
    warning(paste('Variable',name,
                  'was not specified to transcan or had no NAs'))

  if(!length(impval))
    return(var)
  
  d <- dim(impval)

  if(!missing(imputation)) {
    if(!length(d)) 
      stop('imputation can only be given when transcan used n.impute')

    if(imputation < 1 || imputation > d[2])
      stop(paste('imputation must be between 1 and',d[2]))

    impval <- impval[,imputation]
  } else if(length(d)) 
    stop('imputation must be specified when transcan used n.impute')

  namvar <- names(var)

  if(!length(namvar)) {
    if(missing(data))
      stop(paste('variable',name,
                 'does not have a names() attribute\nand data= was not given.\nAssuming identifiers stored by transcan are integer subscripts'))
    else
      namvar <- row.names(data)

    if(!length(namvar))
      stop(paste('variable',name,
                 'does not have a names() attribute\nand data has no row.names'))
  }
  
  if(length(namvar)) {
    sub <- match(names(impval), namvar, nomatch=0)
    impval <- impval[sub > 0]
    sub <- sub[sub > 0]
  } else {
    if(!all.is.numeric(names(impval)))
      stop(paste('names attribute of ',name,
                 ' is not all numeric\n',
                 'and original observations did not have names',sep=''))

    sub <- as.integer(names(impval))
  }

  ##Now take into account fact that transcan may have been
  ##run on a superset of current data frame
  
  m <- length(sub)
  if(check)
    if(missing(imputation) || imputation==1)
      if(m!=sum(is.na(var)))
        warning("number of NAs in var != number of imputed values from transcan.")

  if(m==0)
    return(var)
  var[sub] <- if(is.factor(var)) levels(var)[as.integer(impval)]
              else impval

  attr(var,'imputed') <- sub
  attr(var,'class') <- c("impute", attr(var,'class'))
  var
}

"[.transcan" <- function(x, rows=1:d[1], cols=1:d[2], drop=TRUE)
{
  ## Check for old style object
  if(is.list(x)) {
    if(length(x$imputed) && sum(sapply(x$imputed,length))) {
      d <- dim(x$transformed)
      original.rownames <- dimnames(x$transformed)[[1]]
      subset.rownames   <- original.rownames[rows]
      for(v in names(x$imputed)) {
        z <- x$imputed[[v]]
        if(length(z)) {
          use <- names(z) %in% subset.rownames
          x$imputed[[v]] <- z[use]
        }
      }
    }
    x$transformed <- x$transformed[rows,cols, drop=drop]
    return(x)
  }

  ats <- attributes(x)
  ats$dimnames <- ats$dim <- ats$names <- NULL
  attr(x, 'class') <- NULL
  y <- x[..., drop = drop]
  attributes(y) <- c(attributes(y), ats)
  if(is.null(dim(y))) {
    aty <- attributes(y)
    aty$call <- aty$iter <- aty$rsq <- aty$parms <- aty$coef <- 
      aty$xcoef <- aty$rsq.adj <- aty$shrink <-
        aty$fillin <- aty$imputed <- aty$class <- aty$ranges <- 
          aty$imp.con <- aty$scale <- aty$categorical <- aty$asis <-
            aty$trantab <- NULL
    attributes(y) <- aty
    if(is.character(z <- list(...)[[1]]))
      attr(y,"label") <- paste("Transformed",z)
    ##May someday have to use label(y) <- for this ?
  }

  y
}


predict.transcan <- function(object, newdata=NULL, iter.max=50, eps=.01, 
                             curtail=TRUE, type=c("transformed","original"),
                             inverse, tolInverse, check=FALSE, ...)
{
  type <- match.arg(type)
  
  if(!is.list(object)) object <- attributes(object)
  parms  <- object$parms
  coef   <- object$coef
  xcoef  <- object$xcoef
  fillin <- object$fillin
  ranges <- object$ranges
  scale  <- object$scale
  imp.con<- object$imp.con
  rhsImp <- object$rhsImp
  trantab<- object$trantab
  categorical <- object$categorical
  formula <- object$formula

  inverse <- if(missing(inverse)) object$inverse
  
  if(!length(inverse)) inverse <- 'linearInterp'
  tolInverse <- if(missing(tolInverse)) object$tolInverse
  
  if(!length(tolInverse)) tolInverse <- 0.05

  if(type=="original" & is.null(trantab))
    stop('type="trantab" and trantab=TRUE not specified to transcan')

  if(length(formula)) {
    oldop <- options(na.action="na.retain")
    y <- model.frame(formula, data=newdata)

    options(oldop)
    d <- dim(y)
    p <- d[2]
    newdata <- matrix(NA, nrow=d[1], ncol=p,
                      dimnames=list(attr(y,"row.names"), names(y)))
    for(i in 1:p) {
      w <- y[[i]]
      if(is.character(w)) {
        warning("character predictor present.  Depending on levels being same as in original fit,\nthat all levels are present in the data, and that levels were in alphabetical order")
        w <- factor(w)
      }

      newdata[,i] <- oldUnclass(w)
    }
  } else {
    if(is.null(newdata))
      stop("newdata must be given (unless formula was given to transcan)")

    p <- ncol(newdata)
  }
  if(!is.matrix(newdata)) {
    if(is.null(names(newdata)))
      names(newdata) <- dimnames(object)[[2]]

    newdata <- t(as.matrix(newdata))
  }

  if(imp.con || !any(is.na(newdata)))
    iter.max <- 1  

  ##only 1 iteration needed if no NAs   (imp.con)
  xt <- newdata
  nam <- dimnames(ranges)[[2]]
  if(ncol(ranges)!=p)
    stop("wrong number of columns in newdata")

  if(is.null(dimnames(xt)[[2]]))
    dimnames(xt) <- list(dimnames(xt)[[1]],nam)
  else if(check && any(dimnames(newdata)[[2]]!=nam))
    warning("column names in newdata do not match column names in object")

  if(length(dimnames(xt)[[1]])==0)
    dimnames(xt) <- list(as.character(1:nrow(xt)),
                         dimnames(xt)[[2]])

  for(iter in 1:iter.max) {
    dmax <- 0
    for(i in 1:p) {
      lab <- nam[i]
      j <- is.na(newdata[,i])
      prm <- parms[[lab]]
      if(length(prm)==0) {
        newy <- newdata[,i]
        if(any(j))newy[j] <- if(iter==1) fillin[i] else
        drop(cbind(1,xt[j,-i,drop=FALSE]) %*% xcoef[i,-i-1])
      } else {
        if(is.matrix(prm)) {
          lev <- attr(prm, "codes")
          consec.lev <- match(newdata[,i], lev)  #may give NAs - OK for next line
          R <- prm[consec.lev,, drop=FALSE]
          if(iter==1 && any(match(newdata[!j,i], lev, 0)==0))
            stop("codes for categorical variable not in original list")
        } else R <- rcspline.eval(newdata[,i], prm, inclx=TRUE)

        newy <- drop(cbind(1,R) %*% coef[[i]])
        if(any(j))
          newy[j] <-
            if(iter==1) 0
            else
              drop(cbind(1, xt[j,-i,drop=FALSE]) %*%xcoef[i, -i-1])
      }

      if(curtail) newy <- pmax(pmin(newy,ranges[2,i]),ranges[1,i])
      if(iter>1) dmax <- max(dmax, min(max(abs(xt[,i]-newy),na.rm=TRUE),
                                       max(abs(-xt[,i]-newy),na.rm=TRUE))/scale[i])
      xt[,i] <- newy
    }	#end i

    niter <- iter
    if(niter>1 && dmax<eps)
      break

    if(rhsImp=='random' && niter>4)
      break
  }	#end iter

  if(rhsImp=='mean') {
    if(iter.max>3 & niter==iter.max)
      stop(paste("no convergence in",iter.max,"iterations"))
    cat("Convergence in",niter,"iterations\n")
  }

  if(type=="transformed")
    return(xt)

  for(i in 1:p) {
    ft <- trantab[[i]]
    j <- is.na(newdata[,i])
    if(any(j)) {
      newdata[j,i] <-
        if(imp.con) fillin[i]
        else {
          ww <- invertTabulated(ft, aty=xt[j,i], name=nam[i],
                                inverse=inverse, tolInverse=tolInverse)
          if(nam[i] %in% categorical)
            ww <- round(ww)

          ww
        }
    }
  }

  newdata
}


Function <- function(object, ...) UseMethod("Function")


Function.transcan <- function(object, prefix=".", suffix="", where=1, ...)
{
  at <- if(is.list(object)) object
        else attributes(object)

  Nam <- names(at$coef)
  p <- length(Nam)
  categorical <- at$categorical
  asis        <- at$asis
  coef        <- at$coef
  parms       <- at$parms
  fnames      <- character(p)

  for(i in 1:p)	{
    nam <- Nam[i]
    cof <- coef[[nam]]
    if(nam %in% asis)
      f <- function(x) x
    else if(nam %in% categorical) {
      codes <- attr(parms[[nam]], "codes")
      g <- "{x <- oldUnclass(x);"
      cof[-1] <- cof[-1] + cof[1]  #convert from ref cell to cell means model
      for(j in 1:length(codes))	{
	if(j>1 && cof[j]>0) g <- paste(g,"+")
	g <- paste(g, format(cof[j]), "*(x==",format(codes[j]),")",sep="")
      }

      g <- paste(g, "}", sep="")
      f <- function(x) NULL
      f[[2]] <- parse(text=g)[[1]]
    } else f <- attr(rcspline.restate(parms[[nam]], cof), "function")
 
    fun.name <- paste(prefix,nam,suffix,sep="")
    cat("Function for transforming",nam,"stored as",fun.name,"\n")
    assign(fun.name, f, where=where)
    fnames[i] <- fun.name
  }

  invisible(fnames)
}


na.retain <- function(mf) mf


plot.transcan <- function(x, ...)
{
  ## check for old style object
  if(!is.list(x))
    x <- attributes(x)

  trantab <- x$trantab
  imputed <- x$imputed
  if(length(trantab)==0)
    stop('you did not specify trantab=TRUE to transcan()')

  p   <- length(trantab)
  nam <- names(trantab)
  for(w in nam) {
    z <- trantab[[w]]
    plot(z, xlab=w, ylab=paste('Transformed',w))
    title(sub=paste('R2=',format(round(x$rsq[w],2)),sep=''),cex=.4,adj=0)
    if(length(imputed)) {
      m <- imputed[[w]]
      if(L <- length(m)) {
        title(sub=paste(L,'missing'),cex=.4,adj=1)
        m.trans <- approx(z, xout=m, rule=2)$y
        scat1d(m, 3, ...)
        scat1d(m.trans, 4, ...)
      }
    }
  }
}


fit.mult.impute <- function(formula, fitter, xtrans, data,
                            n.impute=xtrans$n.impute, fit.reps=FALSE, derived,
                            pr=TRUE, subset, ...)
{
  using.Design <- FALSE
  fits <- if(fit.reps)vector('list',n.impute)
  used.mice <- any(oldClass(xtrans)=='mids')
  if(used.mice && missing(n.impute)) n.impute <- xtrans$m
  
  for(i in 1:n.impute) {
    if(used.mice)
      completed.data <- complete(xtrans, i)
    else {
      completed.data <- data
      imputed.data <-
        impute.transcan(xtrans, imputation=i, data=data,
                        list.out=TRUE, pr=FALSE, check=FALSE)
      ## impute.transcan works for aregImpute
      completed.data[names(imputed.data)] <- imputed.data
    }

    if(!missing(derived)) {
      stop('derived variables in fit.mult.imputed not yet implemented')
      eval(derived, completed.data)
    }

    if(using.Design) options(Design.attr=da)
    f <- if(missing(subset)) fitter(formula, data=completed.data, ...)
         else fitter(formula, data=completed.data[subset,], ...)
    
    # For some reason passing subset= causes model.frame bomb in R
    if(fit.reps)
      fits[[i]] <- f

    cof <- f$coef
    v <- Varcov(f, regcoef.only=FALSE)
    ## From Rainer Dyckerhoff to work correctly with models that have
    ## a scale parameter (e.g. psm).  Check whether length of the
    ## coefficient vector is different from the the number of rows of
    ## the covariance matrix. If so, the model contains scale
    ## parameters that are not fixed at some value and we have to 
    ## append the scale parameters to the coefficient vector.
    nvar0 <- length(cof)
    nvar <- nrow(v)
    if(nvar > nvar0) {
      cof <- c(cof, log(f$scale))
      names(cof) <- c(names(f$coef),
                      if((nvar - nvar0) == 1) "Log(scale)"
                      else names(f$scale))
    }

    if(i==1) {
      vavg <- 0*v
      p <- length(cof)
      bar <- rep(0, p)
      vname <- names(cof)
      cov <- matrix(0, nrow=p, ncol=p, dimnames=list(vname,vname))

      if(inherits(f,'Design')) {
        using.Design <- TRUE
        da <- f$Design
        if(!length(da)) da <- getOldDesign(f)
      } else warning('Not using a Design fitting function; summary(fit) will use\nstandard errors, t, P from last imputation only.  Use Varcov(fit) to get the\ncorrect covariance matrix, sqrt(diag(Varcov(fit))) to get s.e.\n\n')
    }

    vavg <- vavg + v
    bar <- bar + cof
    cof <- as.matrix(cof)
    cov <- cov + cof %*% t(cof)
  }

  vavg <- vavg / n.impute    ## matrix \bar{U} in Rubin's notation
  bar <- bar/n.impute
  bar <- as.matrix(bar)
  ## Matrix B in Rubin's notation:
  cov <- (cov - n.impute * bar %*% t(bar))/(n.impute-1)
  U <- diag(vavg);
  B <- diag(cov)  ## save the diagonals of U and B

  cov <- vavg + (n.impute+1)/n.impute * cov  ## final covariance matrix

  r <- diag(cov) / diag(vavg)
  names(r) <- vname
  tau  <- (1 + 1/n.impute)*B/U
  missingInfo <- tau/(1+tau)
  dfmi <- (n.impute-1)*((1 + 1/tau)^2)
  if(pr) {
    cat('\nVariance Inflation Factors Due to Imputation:\n\n')
    print(round(r,2))
    cat('\nRate of Missing Information:\n\n')
    print(round(missingInfo,2))
    cat('\nd.f. for t-distribution for Tests of Single Coefficients:\n\n')
    print(round(dfmi,2))
  }
  
  f$coefficients <- drop(bar)
  f$var <- cov
  f$variance.inflation.impute <- r
  f$missingInfo <- missingInfo
  f$dfmi <- dfmi
  f$fits <- fits
  f$formula <- formula
  if(using.Design) options(Design.attr=NULL)

  f
}


Varcov.fit.mult.impute <- function(object, ...) object$var


##The following needed if Design is not in effect, to make anova work
Varcov <- function(object, ...) UseMethod("Varcov")


Varcov.default <- function(object, regcoef.only=FALSE, ...)
{
  vc <- object$Varcov
  if(length(vc)) {
    if(regcoef.only)
      return(object$var)
    else
      return(vc(object,which='var'))
  }

  cov <- object$var
  if(is.null(cov))
    stop("object does not have variance-covariance matrix")

  if(regcoef.only) {
    p <- length(object$coef)
    cov <- cov[1:p, 1:p, drop=FALSE]
  }

  cov
}


Varcov.lm <- function(object, ...)
{
  cof <- object$coefficients
  if(.R.) {
    Qr <- object$qr
    cov <- chol2inv(Qr$qr)
  } else {
    rinv <- solve(object$R, diag(length(cof)))
    cov <- rinv %*% t(rinv)
  }
  
  cov <- sum(object$residuals^2)*cov/object$df.residual
  nm  <- names(cof)
  dimnames(cov) <- list(nm, nm)
  cov
}


Varcov.glm <- function(object, ...)
{
  if(length(object$var))
    return(object$var)  ## for glmD

  s <- summary.glm(object)
  s$cov.unscaled * s$dispersion
}


Varcov.multinom <- function(object, ...) vcov(object)

invertTabulated <- function(x, y, freq=rep(1,length(x)),
                            aty, name='value',
                            inverse=c('linearInterp','sample'),
                            tolInverse=0.05, rule=2)
{
  inverse <- match.arg(inverse)
  if(is.list(x)) {
    freq <- x[[3]]
    y <- x[[2]]
    x <- x[[1]]
  }
  
  if(inverse=='linearInterp')
    return(approx(y, x, xout=aty, rule=rule)$y)

  del <- diff(range(y, na.rm=TRUE))
  m <- length(aty)
  yinv <- if(.R.)double(m)
          else single(m)
  
  cant <- if(.R.)double(0)
          else single(0)

  for(i in 1:m) {
    a <- aty[i]
    s <- abs(y-a) < (tolInverse * del)
    nclose <- sum(s)
    if(nclose < 2) {
      if(nclose==0)
        cant <- c(cant, a)

      xest <- approx(y, x, xout=a, rule=rule)$y
      ## If a outside range of y, approx(rule=2) will return min or max
      ## x.  There may be many x's with y values near this extreme x.
      ## Take a random draw from them.
      a <- approx(x, y, xout=xest, rule=rule)$y
      s <- abs(y - a) < (tolInverse * del)
      nclose <- sum(s)
      if(nclose > 1) {
        maxdist <- max((y[s] - a)^2)
        wt <- if(maxdist==0) freq[s]
              else (1 - ((y[s] - a)^2) / maxdist) * freq[s]

        if(all(wt==0))
          wt <- freq[s]  # y[s] all the same

        if(any(wt==0))
          wt[wt==0] <- min(wt[wt>0])/2

        xest <- x[s][sample(nclose, 1, replace=FALSE,  prob=wt/sum(wt))]
      }
    } else {
      maxdist <- max((y[s] - a)^2)
      wt <- if(maxdist==0) freq[s]
            else (1 - ((y[s] - a)^2) / maxdist) * freq[s]

      if(all(wt==0))
        wt <- freq[s]  # y[s] all the same

      if(any(wt==0))
        wt[wt==0] <- min(wt[wt>0])/2
      
      xest <- x[s][sample(nclose, 1, replace=FALSE,  prob=wt/sum(wt))]
      ## sample(x[s],...) fails if x[s] is scalar; thanks: Bill Dunlap
    }
    yinv[i] <- xest
  }
  
  if(length(cant))
    warning(paste('No actual ',name, ' has y value within ',
                  format(tolInverse),
                  '* range(y) (',format(del),
                  ') of the following y values:',
                  paste(format(sort(unique(cant))),collapse=' '),
                  '.\nConsider increasing tolInverse. ',
                  'Used linear interpolation instead.',sep=''))
  
  yinv
}


## Trick taken from MICE impute.polyreg
rMultinom <- function(probs, m)
{
  d <- dim(probs)
  n <- d[1]
  k <- d[2]
  lev <- dimnames(probs)[[2]]
  if(!length(lev))
    lev <- 1:k

  ran <- matrix(lev[1], ncol=m, nrow=n)
  z <- apply(probs, 1, sum)
  if(any(abs(z-1) > .00001))
     stop('error in multinom: probabilities do not sum to 1')

  for(i in 1:m) {
    un <- rep(runif(n), rep(k,n))
    ran[,i] <- lev[1 + apply(un > apply(probs,1,cumsum),2,sum)]
  }

  ran
}
translate <- if(!.R. && !under.unix) 
  function(text, old, new, multichar) {
    if(!missing(multichar) && !multichar)
      stop('multichar=F not implemented for this operating system')
    sedit(text, old, new)
  } else if(FALSE && .R.) function(text, old, new, multichar=FALSE) {
    if(multichar) stop('multichar=T not implemented under R')
    k <- chartr(old, new, text)
    if(is.matrix(text)) k <- matrix(k, nrow=nrow(text))
    k
  } else
  function(text, old, new, multichar=FALSE) {
    if(length(old)>1 || (nchar(old)!=nchar(new))) multichar <- TRUE
    if(length(old)>1 && (length(new)>1 & length(new)!=length(old)))
      stop("old and new must have same lengths or new must have 1 element")

    if(.R. && !multichar) k <- chartr(old, new, text)  ## 27aug03
    else {
      if(multichar) command <- paste("sed",paste('-e "s/',old,"/",new,'/g"',
                                                 sep="", collapse=" "))
      else command <- paste("tr \"", old, "\" \"", new, "\"", sep="")
      ##    k <- sys(command, text)  replace with next 2 27aug03
      ## Thanks:   <Sebastian.Weber@aventis.com>
      k <- unlist(lapply(text, function(x, command) {
        sys(paste("echo \"", x, "\" | ", command, sep="")) },
                         command=command))  #  command= 22feb04
      ## added command 26jan04; thanks:<Willi.Weber@aventis.com>
    }
    if(is.matrix(text)) k <- matrix(k, nrow=nrow(text))
    k
  }
if(.R.) units <- function(x,...)  UseMethod("units")

"units<-.default"  <- function(x, value)
{
  attr(x, "units") <- value
  x
}

units.default <- function(x, none='', ...)
{
  lab <- attr(x, "units")
  if(is.null(lab))
    lab <- attr(attr(x,'tspar'),'units')

  if(is.null(lab))
    lab <- none

  lab
}
## $Id: valueTags.s 258 2006-04-17 14:17:06Z dupontct $

valueTags <- function(x) {
  list(unit = valueUnit(x), label = valueLabel(x),
       name = valueName(x))
}

"valueTags<-" <- function(x, value) {
  tagged <- FALSE

  if(!is.list(value))
    stop("list must be a named list of valueTags")

  if(!is.null(value$unit)) {
    tagged <- TRUE
    valueUnit(x) <- value$unit
  }

  if(!is.null(value$label)) {
    tagged <- TRUE
    valueLabel(x) <- value$label
  }

  if(!is.null(value$name)) {
    tagged <- TRUE
    valueName(x) <- value$name
  }

  if(tagged)
    oldClass(x) <- c('labelled', oldClass(x)[oldClass(x) != 'labelled'])

  return(x)
}

valueLabel <- function(x)
  attr(x, 'label')

"valueLabel<-" <- function(x, value) {
  if(!is.character(value) || length(value) != 1)
    stop("value label must be a character vector of length 1")
  
  attr(x, 'label') <- value

  oldClass(x) <- c('labelled', oldClass(x)[oldClass(x) != 'labelled'])

  return(x)
}

valueUnit <- function(x)
  attr(x, 'units')

"valueUnit<-" <- function(x, value) {
  if(!is.character(value) || length(value) != 1)
    stop("value unit must be a character vector of length 1")

  attr(x, 'units') <- value

  oldClass(x) <- c('labelled', oldClass(x)[oldClass(x) != 'labelled'])

  return(x)
}

valueName <- function(x)
  attr(x, 'valueName')

"valueName<-" <- function(x, value) {
  if(!is.character(value) || length(value) != 1)
    stop("value name must be a character vector of length 1")

  attr(x, 'valueName') <- value

  oldClass(x) <- c('labelled', oldClass(x)[oldClass(x) != 'labelled'])

  return(x)
}
varclus <-
  function(x,
           similarity=c("spearman","pearson","hoeffding",
                        "bothpos","ccbothpos"), 
           type=c("data.matrix","similarity.matrix"),
           method=if(.R.)"complete"
                  else "compact",
           data=NULL, subset=NULL, na.action=na.retain, ...)
{
  call <- match.call()
  type <- match.arg(type)
  if(type!="similarity.matrix") similarity <- match.arg(similarity)

  nact <- NULL

  if(inherits(x,"formula"))
    {
      form <- x
      oldops <- options(contrasts=c("contr.treatment","contr.poly"))
      if(length(list(...))) data <- dataframeReduce(data, ...)
      x <- list(formula=form, data=data, na.action=na.action, subset=subset)
      x <- do.call('model.frame', x)
      nam <- names(x)
      nv <- length(x)
      Terms <- attr(x,'terms')
      
      nact <- attr(x,"na.action")
      x <- model.matrix(Terms, x)
      if(dimnames(x)[[2]][1]=='(Intercept)') x <- x[,-1]
      form <- TRUE
      options(oldops)
      type <- "data.matrix"
    }
  else form <- FALSE

  n <- NULL
  if(mode(x)!="numeric") stop("x matrix must be numeric")

  if(type=="data.matrix")
    { ## assume not a correlation matrix
      if(similarity %in% c("bothpos","ccbothpos"))
        {
          isthere <- 1*(!is.na(x))
          x[is.na(x)] <- 0
          x[x > 0] <- 1
          n <- crossprod(isthere)
          x <- crossprod(x)/n
          if(similarity=='ccbothpos')
            {
              cc <- diag(x) %*% t(diag(x))
              cc[row(cc)==col(cc)] <- 0
              x <- x - cc
            }
    }
      else if(similarity=="hoeffding")
        {
          D <- hoeffd(x); x <- D$D; n <- D$n 
    }
      else
        {
          D <- rcorr(x, type=similarity)
          x <- (D$r)^2
          n <- D$n
        }
  }
  else if(diff(dim(x))!=0) 
    stop("x must be square to be a similarity matrix")
  
  if(any(is.na(x)))
    {
      cat("Part of the similarity matrix could not be computed:\n")
      x[x<.01] <- 0
      print(x, digits=2)
      stop()
    }

  if(similarity=='ccbothpos') w <- NULL
  else
    w <-
      if(.R.) hclust(as.dist(1-x), method=method)
      else hclust(sim=x, method=method)
  
  structure(list(call=call, sim=x, n=n, hclust=w, similarity=similarity,
                 method=method, na.action=nact),class="varclus")
}


print.varclus <- function(x, abbrev=FALSE, ...)
{
  dput(x$call); cat("\n")
  if(length(x$na.action))
    naprint(x$na.action)
  s <- c(hoeffding="30 * Hoeffding D",spearman="Spearman rho^2",
         pearson="Pearson r^2",bothpos="Proportion",
         ccbothpos="Chance-Corrected Proportion")[x$similarity]
  cat("\nSimilarity matrix (",s,")\n\n",sep="")
  k <- x$sim
  lab <- dimnames(k)[[2]]
  if(abbrev)
    lab <- abbreviate(lab)

  dimnames(k) <- list(lab,lab)
  print.default(round(k, 2))
  n <- x$n
  if(length(n))
    {
      if(length(n)==1)
        cat("\nNo. of observations used=", n,"\n\n")
      else {
        cat("\nNo. of observations used for each pair:\n\n")
        dimnames(n) <- list(lab,lab)
        print(n)
      }
    }

  cat("\nhclust results (method=",x$method,")\n\n",sep="")
  print(x$hclust)
  invisible()
}

plot.varclus <- function(x, ylab, abbrev=FALSE, legend.=FALSE, loc, maxlen=20,
                         labels=NULL, ...)
{
  if(missing(ylab))
    {
      s <- c(hoeffding="30 * Hoeffding D",
             spearman=if(.R.)expression(paste(Spearman,~rho^2))
             else "Spearman rho^2",
             pearson=if(.R.)expression(paste(Pearson,~r^2))
             else "Pearson r^2",
             bothpos="Proportion",
             ccbothpos="Chance-Corrected Proportion")[x$similarity]
      if((is.expression(s) && as.character(s)=='NULL') ||
         (!is.expression(s) && (is.na(s) || s=='')))
        s <- x$similarity
      ylab <- if(.R.) s else paste("Similarity (",s,")",sep="")
    }
  
  if(legend.) abbrev <- TRUE

  if(!length(labels)) labels <- dimnames(x$sim)[[2]]

  olabels <- labels
  if(abbrev) labels <- abbreviate(labels)

  if(!length(x$hclust))
    stop('clustering was not done on similarity="ccbothpos"')

  p <- if(.R.)
    {
      plot(x$hclust, labels=labels, ann=FALSE, axes=FALSE, ...)
      ya <- pretty(range(1-x$hclust$height))
      axis(2, at=1-ya, labels=format(ya))
      title(ylab=ylab)
  }
  else plclust(x$hclust, labels=labels, ylab=ylab, ...)

  s <- labels != olabels
  if(legend. && any(s))
    {
      if(missing(loc))
        {
          cat("Click mouse at upper left corner of legend\n")
          loc <- locator(1)
        }

      olabels <- ifelse(nchar(olabels)>maxlen, substring(olabels,1,maxlen),
                        olabels)
      text(loc, paste(paste(labels[s],":",olabels[s],"\n"),
                      collapse=""), adj=0)
    }

  invisible(p)
}


na.retain <- function(mf) mf


naclus <- function(df, method=if(.R.)"complete" else "compact")
{
  ismiss <- function(x) if(is.character(x))x=='' else is.na(x) 

  na <- sapply(df, ismiss)*1

  n <- nrow(na)
  sim <- crossprod(na)/n
  res <- varclus(sim, type="similarity.matrix", similarity="Fraction Missing",
                 method=method)
  na.per.obs <- apply(na, 1, sum)
  nc <- ncol(na)
  mean.na <- rep(NA, nc)
  names(mean.na) <- dimnames(na)[[2]]
  for(i in 1:nc)
    {
      y <- na[,i]==1
      if(any(y)) mean.na[i] <- mean(na.per.obs[y]) - 1
      NULL
    }

  res$na.per.obs <- na.per.obs
  res$mean.na    <- mean.na
  res
}


naplot <- function(obj, which=c('all','na per var','na per obs','mean na',
                                'na per var vs mean na'),
                   ...)
{
  which <- match.arg(which)
  tab <- table(obj$na.per.obs)
  na.per.var <- diag(obj$sim)
  names(na.per.var) <- dimnames(obj$sim)[[2]]
  mean.na <- obj$mean.na

  if(which %in% c('all','na per var'))
    dotchart(sort(na.per.var), xlab='Fraction of NAs', 
             main='Fraction of NAs in each Variable', ...)

  if(which %in% c('all','na per obs'))
    dotchart2(tab, auxdata=tab, reset.par=TRUE,
              xlab='Frequency', 
              main='Number of Missing Variables Per Observation', ...)

  if(which %in% c('all','mean na'))
    dotchart(sort(mean.na), 
             xlab='Mean Number of NAs',
             main='Mean Number of Other Variables Missing for\nObservations where Indicated Variable is NA',
             ...)

  if(which %in% c('all','na per var vs mean na'))
    {
      if(.R.)
        {
          xpd <- par('xpd')
          par(xpd=NA)
          on.exit(par(xpd=xpd))
        }

      plot(na.per.var, mean.na, xlab='Fraction of NAs for Single Variable',
           ylab='Mean # Other Variables Missing', type='p')
      usr <- par('usr')
      eps <- .015*diff(usr[1:2]);
      epsy <- .015*diff(usr[3:4])
    
      s <- (1:length(na.per.var))[!is.na(mean.na)]
      taken.care.of <- NULL
      for(i in s)
        {
          if(i %in% taken.care.of)
            next

          w <- s[s > i & abs(na.per.var[s]-na.per.var[i]) < eps &
                 abs(mean.na[s]-mean.na[i]) < epsy]
          if(any(w))
            {
              taken.care.of <- c(taken.care.of, w)
              text(na.per.var[i]+eps, mean.na[i],
                   paste(names(na.per.var[c(i,w)]),collapse='\n'),adj=0)
            }
          else text(na.per.var[i]+eps, mean.na[i], names(na.per.var)[i], adj=0)
        }
    }
  
  invisible(tab)
}


combine.levels <- function(x, minlev=.05)
{
  x <- as.factor(x)
  lev <- levels(x)
  f <- table(x)/sum(!is.na(x))
  i <- f < minlev
  si <- sum(i)
  if(si==0) return(x)

  if(.R.)
    {
      comb <- if(si==1) names(sort(f))[1:2]
      else names(f)[i]
    
      keepsep <- setdiff(names(f), comb)
      names(keepsep) <- keepsep
      w <- c(list(OTHER=comb), keepsep)
      levels(x) <- w
    }
  else levels(x) <-
    if(si==1) list(OTHER=names(sort(f))[1:2])
    else list(OTHER=names(f)[i])
  x
}


plotMultSim <- function(s, x=1:dim(s)[3],
                        slim=range(pretty(c(0,max(s,na.rm=TRUE)))),
                        slimds=FALSE,
                        add=FALSE, lty=par('lty'), col=par('col'),
                        lwd=par('lwd'), vname=NULL, h=.5, w=.75,
                        u=.05, labelx=TRUE, xspace=.35)
{
  if(!length(vname))
    vname <- dimnames(s)[[1]]
  p <- dim(s)[1]
  if(length(vname) != p) stop('wrong length for vname')
  
  if(p != dim(s)[2])
    stop('similarity matrix not square')
  
  if(length(x) != dim(s)[3])
    stop('length of x differs from extent of 3rd dimension of s')

  if(!add)
    {
      plot(c(-xspace,p+.5),c(.5,p+.25), type='n', axes=FALSE, xlab='',ylab='')
      if(labelx)
        text(1:p, rep(.6,p), vname, adj=.5)

      text(rep(.5,p), 1:p, vname, adj=1)
    }

  scaleit <- function(x, xlim, lim) lim[1] +
    (x-xlim[1])/diff(xlim) * diff(lim)

  if(slimds)
    {
      slim.diag <- -1e10
      for(k in 1:length(x))
        {
          sk <- s[,,k]
          r <- max(diag(sk))
          slim.diag <- max(slim.diag, r)
        }

      slim.diag <- range(pretty(c(0,slim.diag)))
      slim.offdiag <- slim.diag - diff(slim.diag)/2
    }
  
  rx  <- range(x)
  rxe <- c(rx[1]-u*diff(rx), rx[2]+u*diff(rx))

  for(i in 1:p)
    {
      for(j in 1:p)
        {
          if((i==j) && all(s[i,j,]==1))
            next
          
          sl <- if(slimds) if(i==j) slim.diag
          else slim.offdiag
          else slim
          
          sle <- c(sl[1]-u*diff(sl), sl[2]+u*diff(sl))

          if(!add)
            {
              lines(c(i-w/2,i+w/2,i+w/2,
                      i-w/2,i-w/2),
                    c(j-h/2,j-h/2,j+h/2,
                      j+h/2,j-h/2), col=if(.R.)gray(.5) else .5, lwd=.65)
              xc <- rep(i-w/2-u/3,2)
              yc <- scaleit(sl, sle, c(j-h/2,j+h/2))
              if(i==1 && j<=2)
          {
            text(xc, yc,
                 format(sl,digits=2), adj=1, cex=.7)
            segments(rep(xc+u/8,2),yc,
                     rep(xc+u/3,2),yc)
          }
            }
          lines(scaleit(x, rxe, c(i-w/2,i+w/2)),
                scaleit(s[i,j,], sle, c(j-h/2,j+h/2)),
                lty=lty, lwd=lwd, col=col)
          if(!add && slimds && (i!=j))
            lines(c(i-w/2,i+w/2),
                  rep(scaleit(0, sle, c(j-h/2,j+h/2)),2),
                  col=if(.R.)gray(.5) else .5)
        }
    }
  
  invisible(slim)
}
wtd.mean <- function(x, weights=NULL, normwt='ignored', na.rm=TRUE)
{
  if(!length(weights)) return(mean(x, na.rm=na.rm))
  if(na.rm) {
    s <- !is.na(x + weights)
    x <- x[s]
    weights <- weights[s]
  }

  sum(weights*x)/sum(weights)
}


wtd.var <- function(x, weights=NULL, normwt=FALSE, na.rm=TRUE)
{
  if(!length(weights)) {
    if(na.rm) x <- x[!is.na(x)]
    return(var(x))
  }

  if(na.rm) {
    s <- !is.na(x + weights)
    x <- x[s]
    weights <- weights[s]
  }

  if(normwt)
    weights <- weights*length(x)/sum(weights)

  xbar <- sum(weights*x)/sum(weights)
  sum(weights*((x - xbar)^2)) / (sum(weights) - 1)
}


wtd.quantile <- function(x, weights=NULL, probs=c(0, .25, .5, .75, 1), 
                         type=c('quantile','(i-1)/(n-1)','i/(n+1)','i/n'), 
                         normwt=FALSE, na.rm=TRUE)
{
  if(!length(weights))
    return(quantile(x, probs=probs, na.rm=na.rm))

  type <- match.arg(type)
  if(any(probs < 0 | probs > 1))
    stop("Probabilities must be between 0 and 1 inclusive")

  nams <- paste(format(round(probs * 100, if(length(probs) > 1) 
                             2 - log10(diff(range(probs))) else 2)), 
                "%", sep = "")

  if(type=='quantile') {
    w <- wtd.table(x, weights, na.rm=na.rm, normwt=normwt, type='list')
    x     <- w$x
    wts   <- w$sum.of.weights
    n     <- sum(wts)
    order <- 1 + (n - 1) * probs
    low   <- pmax(floor(order), 1)
    high  <- pmin(low + 1, n)
    order <- order %% 1
    ## Find low and high order statistics
    ## These are minimum values of x such that the cum. freqs >= c(low,high)
    allq <- approx(cumsum(wts), x, xout=c(low,high), 
                   method='constant', f=1, rule=2)$y
    k <- length(probs)
    quantiles <- (1 - order)*allq[1:k] + order*allq[-(1:k)]
    names(quantiles) <- nams
    return(quantiles)
  } 
  w <- wtd.Ecdf(x, weights, na.rm=na.rm, type=type, normwt=normwt)
  structure(approx(w$ecdf, w$x, xout=probs, rule=2)$y, 
            names=nams)
}


wtd.Ecdf <- function(x, weights=NULL, 
                     type=c('i/n','(i-1)/(n-1)','i/(n+1)'), 
                     normwt=FALSE, na.rm=TRUE)
{
  type <- match.arg(type)
  switch(type,
         '(i-1)/(n-1)'={a <- b <- -1},
         'i/(n+1)'    ={a <- 0; b <- 1},
         'i/n'        ={a <- b <- 0})

  if(!length(weights)) {
    ##.Options$digits <- 7  ## to get good resolution for names(table(x))6Aug00
    oldopt <- options(digits=7)
    on.exit(options(oldopt))
    cumu <- table(x)    ## R does not give names for cumsum
    isdate <- testDateTime(x)  ## 31aug02
    ax <- attributes(x)
    ax$names <- NULL
    x <- as.numeric(names(cumu))
    if(isdate) attributes(x) <- c(attributes(x),ax)
    cumu <- cumsum(cumu)
    cdf <- (cumu + a)/(cumu[length(cumu)] + b)
    if(cdf[1]>0) {
      x <- c(x[1], x);
      cdf <- c(0,cdf)
    }

    return(list(x = x, ecdf=cdf))
  }

  w <- wtd.table(x, weights, normwt=normwt, na.rm=na.rm)
  cumu <- cumsum(w$sum.of.weights)
  cdf <- (cumu + a)/(cumu[length(cumu)] + b)
  list(x = c(if(cdf[1]>0) w$x[1], w$x), ecdf=c(if(cdf[1]>0)0, cdf))
}


wtd.table <- function(x, weights=NULL, type=c('list','table'), 
                      normwt=FALSE, na.rm=TRUE)
{
  type <- match.arg(type)
  if(!length(weights))
    weights <- rep(1, length(x))

  isdate <- testDateTime(x)  ## 31aug02 + next 2
  ax <- attributes(x)
  ax$names <- NULL
  x <- if(is.character(x)) as.category(x)
       else oldUnclass(x)

  lev <- levels(x)
  if(na.rm) {
    s <- !is.na(x + weights)
    x <- x[s,drop=FALSE]    ## drop is for factor class
    weights <- weights[s]
  }

  n <- length(x)
  if(normwt)
    weights <- weights*length(x)/sum(weights)

  i <- order(x)  # R does not preserve levels here
  x <- x[i]; weights <- weights[i]

  if(any(diff(x)==0)) {  ## slightly faster than any(duplicated(xo))
    weights <- tapply(weights, x, sum)
    if(length(lev)) {    ## 3apr03
      levused <- lev[sort(unique(x))]  ## 7sep02
      ## Next 3 lines 21apr03
      if((length(weights) > length(levused)) &&
         any(is.na(weights)))
        weights <- weights[!is.na(weights)]

      if(length(weights) != length(levused))
        stop('program logic error')

      names(weights) <- levused   # 10Apr01  length 16May01
    }

    if(!length(names(weights)))
      stop('program logic error')  # 16May01

    if(type=='table')
      return(weights)

    x <- all.is.numeric(names(weights),'vector')
    if(isdate)
      attributes(x) <- c(attributes(x),ax)   ## 31aug02

    names(weights) <- NULL
    return(list(x=x, sum.of.weights=weights))
  }

  xx <- x  ## 31aug02
  if(isdate)
    attributes(xx) <- c(attributes(xx),ax)

  if(type=='list')
    list(x=if(length(lev))lev[x]
           else xx, 
         sum.of.weights=weights)
  else {
    names(weights) <- if(length(lev)) lev[x]
                      else xx
    weights
  }
}


wtd.rank <- function(x, weights=NULL, normwt=FALSE, na.rm=TRUE)
{
  if(!length(weights))
    return(rank(x),na.last=if(na.rm)NA else TRUE)

  tab <- wtd.table(x, weights, normwt=normwt, na.rm=na.rm)
  
  freqs <- tab$sum.of.weights
  ## rank of x = # <= x - .5 (# = x, minus 1)
  r <- cumsum(freqs) - .5*(freqs-1)
  ## Now r gives ranks for all unique x values.  Do table look-up
  ## to spread these ranks around for all x values.  r is in order of x
  approx(tab$x, r, xout=x)$y
}


wtd.loess.noiter <- function(x, y, weights=rep(1,n), robust=rep(1,n), 
                             span=2/3, degree=1, cell=.13333, 
                             type=c('all','ordered all','evaluate'), 
                             evaluation=100, na.rm=TRUE)
{
  type <- match.arg(type)
  n <- length(y)
  if(na.rm) {
    s <- !is.na(x+y+weights)
    x <- x[s]; y <- y[s]; weights <- weights[s]; n <- length(y)
  }

  robust <- weights * robust
  max.kd <- max(200, n)
  y <-
    if(.R.) .C("loess_raw",
               as.double(y),
               as.double(x),
               as.double(weights),
               as.double(robust),
               as.integer(1),
               as.integer(n),
               as.double(span),
               as.integer(degree),
               as.integer(1),
               as.integer(2),
               as.integer(0),
               as.double(cell),
               as.character('interpolate/none'),
               fitted.values = double(n),
               parameter = integer(7),
               a = integer(max.kd),
               xi = double(max.kd),
               vert = double(2),
               vval = double(2 * max.kd),
               diagonal = double(n),
               trace.hat = double(1),
               one.delta = double(1),
               two.delta = double(1),
               as.integer(FALSE))$fitted.values
    else .C("loess_raw",
            specialsok = TRUE,
            as.double(y),
            as.double(x),
            as.double(weights),
            as.double(robust),
            as.integer(1),
            as.integer(n),
            as.double(span),
            as.integer(degree),
            as.integer(1),
            as.integer(2),
            as.integer(0),
            as.double(cell),
            as.character('interpolate/none'),
            fitted.values = double(n),
            parameter = integer(7),
            a = integer(max.kd),
            xi = double(max.kd),
            vert = double(2),
            vval = double(2 * max.kd),
            diagonal = double(n),
            trace.hat = double(1),
            one.delta = double(1),
            two.delta = double(1),
            as.integer(FALSE))$fitted.values

  switch(type,
         all=list(x=x, y=y),
         'ordered all'={
           i <- order(x);
           list(x=x[i],y=y[i])
         },
         evaluate={
           r <- range(x, na.rm=na.rm)
           approx(x, y, xout=seq(r[1], r[2], length=evaluation))
         })
}


num.denom.setup <- function(num, denom)
{
  n <- length(num)
  if(length(denom) != n)
    stop('lengths of num and denom must match')
  
  s <- (1:n)[!is.na(num + denom) & denom != 0]
  num <- num[s];
  denom <- denom[s]
  
  subs <- s[num > 0]
  y <- rep(1, length(subs))
  wt <- num[num > 0]
  other <- denom - num
  subs <- c(subs, s[other > 0])
  wt <- c(wt, other[other > 0])
  y <- c(y, rep(0, sum(other>0)))
  list(subs=subs, weights=wt, y=y)
}
Cbind <- function(...)
{    # See llist function with Hmisc label function
  dotlist <- list(...)
  if(is.matrix(dotlist[[1]])) {
    y <- dotlist[[1]]
    ynam <- dimnames(y)[[2]]
    if(!length(ynam))
      stop('when first argument is a matrix it must have column dimnames')
    
    other <- y[,-1,drop= FALSE]
    return(structure(y[,1], class='Cbind', label=ynam[1], other=other))
  }

  lname <- names(dotlist)
  name <- vname <- as.character(sys.call())[-1]
  for(i in 1:length(dotlist)) {
    vname[i] <- if(length(lname)) lname[i] else ''
    ## Added length() and '' 12Jun01, remove length(vname[i])==0 below
    if(vname[i]=='') vname[i] <- name[i]
  }

  lab <- attr(y <- dotlist[[1]],'label')
  if(!length(lab)) lab <- vname[1]
  if(!is.matrix(other <- dotlist[[2]]) || ncol(other)<2) {  #9Jan98
    other <- as.matrix(as.data.frame(dotlist))[,-1,drop= FALSE]
    dimnames(other)[[2]] <- vname[-1]
  }

  structure(y, class='Cbind', label=lab, other=other)
}

if(.R.) as.numeric.Cbind <- as.double.Cbind <- function(x, ...) x
# Keeps xyplot from stripping off "other" attribute in as.numeric


#c.Cbind <- function(...) {
#  res <- oth <- numeric(0)
#  for(a in list(...)) {
#    lab <- attr(a,'label')
#    res <- c(res, oldUnclass(a))
#    oth <- rbind(oth, attr(a,'other'))
#  }
#  structure(res, class='Cbind', label=lab, other=oth)
#}


'[.Cbind' <- function(x, ...)
{
  structure(oldUnclass(x)[...], class='Cbind',
            label=attr(x,'label'),
            other=attr(x,'other')[...,,drop= FALSE])
}


prepanel.xYplot <- function(x, y, ...)
{
  xlim <- range(x, na.rm=TRUE)
  ylim <- range(y, attr(y,'other'), na.rm=TRUE)
  list(xlim=xlim, ylim=ylim, dx=diff(xlim), dy=diff(ylim))
}


## MB add method="filled bands" 
## MB use col.fill to specify colors for filling bands
panel.xYplot <-
  function(x, y, subscripts, groups = NULL, 
           type = if(is.function(method) || method == "quantiles") "b"
                  else "p", 
           method = c("bars", "bands", "upper bars", "lower bars", 
                      "alt bars", "quantiles", "filled bands"), 
           methodArgs = NULL, label.curves = TRUE, abline, 
           probs = c(0.5, 0.25, 0.75), nx=NULL, cap = 0.015, lty.bar = 1, 
           lwd = plot.line$lwd, lty = plot.line$lty, 
           pch = plot.symbol$pch, cex = plot.symbol$cex, 
           font = plot.symbol$font, col = NULL, 
           lwd.bands = NULL, lty.bands = NULL, col.bands = NULL, 
           minor.ticks = NULL, col.fill = NULL,
           size=NULL, rangeCex=c(.5,3), ...)
{
  if(missing(method) || !is.function(method))
    method <- match.arg(method)   # was just missing() 26Nov01

  type <- type   # evaluate type before method changes 9May01
  sizeVaries <- length(size) && length(unique(size)) > 1
  if(length(groups))
    groups <- as.factor(groups)

  g <- as.integer(groups)[subscripts]
  ng <- if(length(groups)) max(g)
        else 1

  plot.symbol <- trellis.par.get(if(ng > 1) "superpose.symbol"
                                 else "plot.symbol")

  plot.line <- trellis.par.get(if(ng > 1) "superpose.line"
                               else "plot.line")

  lty <- rep(lty, length = ng)
  lwd <- rep(lwd, length = ng)
  if(length(rangeCex) != 1)
    pch <- rep(pch, length = ng)

  if(!sizeVaries)
    cex <- rep(cex, length = ng)

  font <- rep(font, length = ng)
  if(!length(col))
    col <- if(type == "p") plot.symbol$col
           else plot.line$col

  col <- rep(col, length = ng)
  pchVaries <- FALSE
  ## Thanks to Deepayan Sarkar for the following size code
  if(sizeVaries) {
    if(length(rangeCex) > 1)
      srng <- range(size, na.rm=TRUE)

    size <- size[subscripts]
    if(length(rangeCex)==1) {
      pch <- as.character(size)
      cex <- rangeCex
      sizeVaries <- FALSE
      pchVaries  <- TRUE
    } else {
      cex <- rangeCex[1] + diff(rangeCex)*(size - srng[1])/diff(srng)
      sKey <- function(x=0, y=1, cexObserved, cexCurtailed, col, pch,
                       other)
      {
        if(!length(x))
          x <- 0.05

        if(!length(y))
          y <- 0.95  ## because of formals()

        ## had to multiply cex by 1.4 when using rlegend instead of rlegendg
        rlegendg(x, y, legend=format(cexObserved), cex=cexCurtailed,
                 col=col, pch=pch, other=other)
        invisible()
      }

      formals(sKey) <- list(x=NULL, y=NULL, cexObserved=srng,
                            cexCurtailed=rangeCex,
                            col=col[1], pch=pch, other=NULL)
      storeTemp(sKey)
    }
  }

  other <- attr(y, "other")
  if(length(other)) {
    nother <- ncol(other)
    if(nother == 1) {
      lower <- y - other
      upper <- y + other
    }
    else {
      lower <- other[, 1]
      upper <- other[, 2]
    }
  }
  else nother <- 0

  y <- oldUnclass(y)
  levnum <- if(length(groups)) sort(unique(g))
            else 1

  if(is.function(method) || method == "quantiles") {
    ## 2Mar00
    if(!is.function(method)) {
      method <- quantile  # above: methodArgs=NULL
      if(!length(methodArgs))
        methodArgs <- list(probs = probs)
    }

    if(length(methodArgs))
      methodArgs$na.rm <- TRUE
    else methodArgs <- list(na.rm = TRUE)

    if(ng == 1) {
      if(!length(nx)) nx <- min(length(x)/4, 40)    
      ## Next 2 lines 2Mar00
      xg <-
        if(nx)
          as.numeric(as.character(cut2(x, m = nx,
                                     levels.mean = TRUE)))
        else x

      dsum <- do.call("summarize",
                      c(list(y, llist(xg = xg), method, type = "matrix", 
                             stat.name = "Z"), methodArgs))
    }
    else {
      xg <- x
      if(missing(nx) || nx)
        for(gg in levnum) {
          ## 2Mar00
          w <- g == gg
          if(missing(nx))
            nx <- min(sum(w)/4, 40)
          xg[w] <-
            as.numeric(as.character(cut2(xg[w], m = nx,
                                         levels.mean = TRUE)))
        }

      dsum <- do.call("summarize",
                      c(list(y, by = llist(g, xg),
                             method, type = "matrix", stat.name = "Z"), 
                        methodArgs))
      g <- dsum$g
      groups <- factor(g, 1:length(levels(groups)),
                       levels(groups))
      subscripts <- TRUE     ## 6Dec00
    }

    x <- dsum$xg
    y <- dsum$Z[, 1, drop = TRUE]
    other <- dsum$Z[, -1, drop=FALSE]
    nother <- 2
    method <- "bands"
  }

  ## MB 04/17/01 default colors for filled bands
  ## 'pastel' colors matching superpose.line$col
  plot.fill <- c(9, 10, 11, 12, 13, 15, 7) 
  ##The following is a fix of panel.xyplot to work for type='b'
  ppanel <- function(x, y, type, cex, pch, font, lwd, lty, col, ...)
  {
    ##      if(type == "l")   9May01
    gfun <- ordGridFun(.R.)
    if(type != 'p')
      gfun$lines(x, y, lwd = lwd, lty = lty, col = col, ...)
    
    ##rm type=type 9May01
    
    if(type !='l') gfun$points(x=x, y=y,
                               ## size=if(.R.)unit(cex*2.5,"mm") else NULL,
                               pch = pch, font = font,
                               cex = cex, col = col, 
                               type = type, lwd=lwd, lty=lty, ...)
  }

  ##The following is a fix for panel.superpose for type='b' 
  pspanel <- function(x, y, subscripts, groups, type, lwd, lty, 
                      pch, cex, font, col, sizeVaries, pchVaries, ...)
  {
    gfun <- ordGridFun(.R.)
    
    groups <- as.numeric(groups)[subscripts]
    N <- seq(along = groups)
    for(i in sort(unique(groups))) {
      which <- N[groups == i]	# j <- which[order(x[which])]	
										# sort in x
      j <- which	# no sorting
      if(type != "p")
        gfun$lines(x[j], y[j],
                   col = col[i], lwd = lwd[i], lty = lty[i], 
                   ...)  # remove type=type[i] 9May01

      if(type !='l')
        gfun$points(x[j], y[j],
                    ## size=if(.R.) unit(cex[i]*2.5, 'mm') else NULL,
                    col = col[i],
                    pch = pch[if(pchVaries)j
                              else i], 
                    cex = cex[if(sizeVaries)j
                              else i],
                    font = font[i], lty=lty[i], lwd=lwd[i], ...)

      ## S-Plus version used type=type[i]; was type=type for points()
    }
  }
  
  ## 14Apr2001 MB changes: set colors for method = "filled bands"
  if(!length(col.fill))
    col.fill <- plot.fill
  col.fill <- rep(col.fill, length = ng)       
  ## end MB

  if(ng > 1) {
    ## MB 14Apr2001: if method == "filled bands"
    ## have to plot filled bands first, otherwise lines/symbols
    ## would be hidden by the filled band
    if(method == "filled bands") {
      gfun <- ordGridFun(.R.)
      for(gg in levnum) {
        s <- g == gg
        gfun$polygon(x = c(x[s], rev(x[s])),
                     y = c(lower[s], rev(upper[s])), col =  col.fill[gg])
      }
    }  ## end MB

    pspanel(x, y, subscripts, groups, lwd = lwd, lty = 
            lty, pch = pch, cex = cex, font = font, col
            = col, type = type, sizeVaries=sizeVaries, pchVaries=pchVaries)
    if(type != "p" && !(is.logical(label.curves) && !
                        label.curves)) {
      lc <- if(is.logical(label.curves)) list(lwd  = lwd, cex = cex[1])
            else c(list(lwd = lwd, cex = cex[1]), label.curves)
      
      curves <- vector("list", length(levnum))
      names(curves) <- levels(groups)[levnum]  # added levnum 24Oct01
      i <- 0
      for(gg in levnum) {
        i <- i + 1
        s <- g == gg
        curves[[i]] <- list(x[s], y[s])
      }

      labcurve(curves, lty = lty[levnum], lwd = lwd[levnum],
               col = col[levnum], opts = lc, grid=TRUE, ...)
    }
  }

  ## MB 14Apr2001: if method == "filled bands"
  ## plot filled bands first, otherwise lines/symbols
  ## would be hidden by the filled band
  else {
    if(method == "filled bands") {
      if(.R.)
        grid.polygon(x = c(x, rev(x)), y = c(lower, rev(upper)),
                     gp=gpar(fill = col.fill),
                     default.units='native')
      else
        polygon(x = c(x, rev(x)), y = c(lower, rev(upper)), col = col.fill)
    } ## end MB

    ppanel(x, y, lwd = lwd, lty = lty, pch = pch, cex = cex,
           font = font, col = col, type = type)
  } 
  ## 14Apr2001 MB
  ## final change for filled bands: just skip the rest
  ## if method = filled bands, remaining columns of other are ignored
  
  if(nother && method != "filled bands") {
    if(method == "bands") {
      dob <- function(a, def, ng, j)
      {
        if(!length(a))
          return(def)

        if(!is.list(a))
          a <- list(a)

        a <- rep(a, length = ng)
        sapply(a, function(b, j)
               b[j], j = j)
      }
      for(j in 1:ncol(other)) {
        if(ng == 1)
          ppanel(x, other[, j], 
                 lwd = dob(lwd.bands, lwd, ng, j),
                 lty = dob(lty.bands, lty, ng, j), 
                 col = dob(col.bands, col, ng, j), 
                 pch = pch, cex = cex, font = 
                 font, type = "l")
        else pspanel(x, other[, j], 
                     subscripts, groups, 
                     lwd = dob(lwd.bands, lwd, ng, j),
                     lty = dob(lty.bands, lty, ng, j), 
                     col = dob(col.bands, col, ng, j), 
                     pch = pch, cex = cex, font = 
                     font, type = "l", 
                     sizeVaries=sizeVaries, pchVaries=pchVaries)
      }
    } else {
      errbr <- function(x, y, lower, upper, cap, 
                        lty, lwd, col, connect)
      {
        gfun    <- ordGridFun(.R.) ## see Misc.s
        segmnts <- gfun$segments
        gun     <- gfun$unit
          
        smidge <- 0.5 * cap *
          (if(.R.)unit(1,'npc') else diff(par("usr" )[1:2]))

        switch(connect,
               all = {
                 segmnts(x, lower, x, upper,
                         lty = lty, lwd = lwd, col = col)
                 segmnts(gun(x)-smidge, lower,
                         gun(x)+smidge, lower,
                         lwd = lwd, lty = 1, col = col)
                 segmnts(gun(x)-smidge, upper,
                         gun(x)+smidge, upper,
                         lwd = lwd, lty = 1, col = col)
               },
               upper = {
                 segmnts(x, y, x, upper, lty = lty, lwd = lwd, col = col)
                 segmnts(gun(x)-smidge,  upper,
                         gun(x)+smidge,  upper,
                         lwd = lwd, lty = 1, col = col)
               },
               lower = {
                 segmnts(x, y, x, lower, lty = lty, lwd = lwd, col = col)
                 segmnts(gun(x)-smidge,  lower,
                         gun(x)+smidge,  lower,
                         lwd = lwd, lty = 1, col = col)
               })
      }

      if(ng == 1)
        errbr(x, y, lower, upper, cap, 
              lty.bar, lwd, col, switch(method,
                                        bars = "all",
                                        "upper bars" = "upper",
                                        "lower bars" = "lower",
                                        "alt bars" = "lower"))
      else {
        if(method == "alt bars")
          medy <- median(y, na.rm = TRUE)
        for(gg in levnum) {
          s <- g == gg
          connect <- switch(method,
                            bars = "all",
                            "upper bars" = "upper",
                            "lower bars" = "lower",
                            "alt bars" = if(median(y[s], 
                                                   na.rm = TRUE) > medy) "upper"
                                         else "lower")

          errbr(x[s], y[s], lower = lower[s],
                upper = upper[s], cap, lty.bar, 
                lwd[gg], col[gg], connect)
        }
      }
    }
  }

  if(length(minor.ticks)) {
    minor.at <-
      if(is.list(minor.ticks)) minor.ticks$at
      else minor.ticks

    minor.labs <-
      if(is.list(minor.ticks) && length(minor.ticks$labels))
        minor.ticks$labels
      else FALSE

    gfun$axis(side = 1, at = minor.at, labels = FALSE,
              tck = par("tck") * 0.5, outer = TRUE, cex = par("cex") * 
              0.5)

    if(!is.logical(minor.labs))
      gfun$axis(side = 1, at = minor.at, labels = 
                minor.labs, tck = 0, cex = par("cex") * 0.5, line = 1.25)
  }
  ##  if(type != "l" && ng > 1) {

  if(ng > 1) {
    ##set up for key() if points plotted
    if(.R.) {
      Key <- function(x=0, y=1, lev, cex, col, font, pch, other)
      {
        ## Even though par('usr') shows 0,1,0,1 after lattice draws
        ## its plot, it still needs resetting
        if(!length(x)) x <- 0.05
        if(!length(y)) y <- 0.95  ## because of formals()
        rlegendg(x, y, legend=lev, cex=cex, col=col, pch=pch, other=other)
        invisible()
      }
    } else {
      Key <- function(x=NULL, y=NULL, lev, cex, col, font, pch, other)
      {
	## other currently ignored for S-Plus
        if(length(x)) {
          if(is.list(x)) {
            y <- x$y
            x <- x$x
          }

          key(x = x, y = y, text = list(lev, col = col),
              points = list(cex = cex, col = col, font = font,
                            pch = pch), transparent = TRUE)
        } else key(text = list(lev, col = col),
                   points  = list(cex = cex, col = col,
                                  font = font, pch = pch),
                   transparent = TRUE)

        invisible()
      }
    }

    formals(Key) <- list(x=NULL,y=NULL,lev=levels(groups),
                         cex=if(sizeVaries) 1 else cex,
                         col=col, font=font, pch=pch, other=NULL)
    storeTemp(Key)
  }

  if(!missing(abline))
    do.call("panel.abline", abline)

  if(type == "l" && ng > 1) {
    ## Set up for legend (key() or rlegendg()) if lines drawn
    if(.R.) {
      Key <- function(x=0, y=1, lev, cex, col, lty, lwd, other)
      {
        ## Even though par('usr') shows 0,1,0,1 after lattice draws
        ## its plot, it still needs resetting
        if(!length(x))
          x <- 0.05

        if(!length(y))
          y <- 0.95  ## because of formals()

        rlegendg(x, y, legend=lev, cex=cex, col=col, lty=lty, lwd=lwd,
                 other=other)
        invisible()
      }
    } else {
      Key <- function(x=NULL, y=NULL, lev, col, lty, lwd, other)
      {
	## other currently ignored for S-Plus
        if(length(x)) {
          if(is.list(x)) {
            y <- x$y
            x <- x$x
          }

          key(x = x, y = y,
              text = list(lev, col = col),
              lines = list(col = col, lty = lty, lwd = lwd),
              transparent  = TRUE)
        }
        else key(text = list(lev, col = col),
                 lines = list(col = col, lty = lty, lwd = lwd),
                 transparent = TRUE)
        invisible()
      }
    }

    formals(Key) <- list(x=NULL,y=NULL,lev=levels(groups), col=col,
                         lty=lty, lwd=lwd, other=NULL)
    storeTemp(Key)
  }
}


xYplot <- if(.R.)
  function (formula, data=sys.frame(sys.parent()),
            groups, subset,
            xlab=NULL, ylab=NULL, ylim=NULL,
            panel=panel.xYplot, prepanel=prepanel.xYplot,
            scales=NULL, minor.ticks=NULL, ...)
{
  require('grid')
  require('lattice')
  yvname <- as.character(formula[2])  # tried deparse
  y <- eval(parse(text=yvname), data)
  if(!length(ylab)) ylab <- label(y, units=TRUE, plot=TRUE,
                                  default=yvname, grid=TRUE)

  ##    ylab <- attr(y, 'label')  26sep02
  ##    if(!length(ylab)) ylab <- yvname
  ##  }

  if(!length(ylim)) {
    yother <- attr(y,'other')
    if(length(yother)) ylim <- range(y, yother, na.rm=TRUE)
  }

  xvname <- formula[[3]]
  if(length(xvname)>1 && as.character(xvname[[1]])=='|') 
    xvname <- xvname[[2]]  # ignore conditioning var

  xv <- eval(xvname, data)
  if(!length(xlab))
    xlab <- label(xv, units=TRUE, plot=TRUE,
                  default=as.character(xvname),
                  grid=TRUE)

  if(!length(scales$x)) {
    if(length(maj <- attr(xv,'scales.major')))
      scales$x <- maj
  }

  if(!length(minor.ticks)) {
    if(length(minor <- attr(xv,'scales.minor')))
      minor.ticks <- minor
  }

  if(!missing(groups))
    groups <- eval(substitute(groups),data)
  
  if(!missing(subset))
    subset <- eval(substitute(subset),data)

  ## Note: c(list(something), NULL) = list(something)
  ## The following was c(list(formula=formula,...,panel=panel),if()c(),...)
  ## 28aug02
  do.call("xyplot", c(list(x = formula, data=data, prepanel=prepanel,
                           panel=panel),
                      if(length(ylab))list(ylab=ylab),
                      if(length(ylim))list(ylim=ylim),
                      if(length(xlab))list(xlab=xlab),
                      if(length(scales))list(scales=scales),
                      if(length(minor.ticks))list(minor.ticks=minor.ticks),
                      if(!missing(groups))list(groups=groups),
                      if(!missing(subset))list(subset=subset),
                      list(...)))
} else function(formula, data = sys.parent(1), 
                groups = NULL, 
                prepanel=prepanel.xYplot, panel='panel.xYplot',
                scales=NULL, ...,
                xlab=NULL, ylab=NULL,
                subset=TRUE, minor.ticks=NULL)
{
  subset <- eval(substitute(subset), data)
  yvname <- deparse(formula[[2]])
  if(!length(ylab))
    ylab <- label(eval(formula[[2]],data),
                  units=TRUE, plot=TRUE, default=yvname)
  ##    ylab <- attr(eval(formula[[2]], data), 'label')  26sep02
  ##    if(!length(ylab)) ylab <- yvname
  ##  }
                
  xv <- formula[[3]]  ## 8Dec00
  if(length(xv)>1 && as.character(xv[[1]])=='|') 
    xv <- xv[[2]]  # ignore conditioning var

  xvname <- deparse(xv)
  xv <- eval(xv, data)
  if(!length(xlab))
    xlab <- label(xv, units=TRUE, plot=TRUE, default=xvname)
  ##    xlab <- attr(xv, 'label') 26sep02
  ##    if(!length(xlab)) xlab <- xvname
  ##  }

  if(!length(scales$x)) {
    if(length(maj <- attr(xv,'scales.major')))
      scales$x <- maj
  }
  if(!length(minor.ticks)) {
    if(length(minor <- attr(xv,'scales.minor')))
      minor.ticks <- minor
  }
  
  setup.2d.trellis(formula, data = data,
                   prepanel=prepanel, panel=panel,
                   groups = eval(substitute(groups),  data), ...,
                   xlab=xlab, ylab=ylab,
                   subset = subset, scales=scales, minor.ticks=minor.ticks)
}


## Only change from default is replacement of x with oldUnclass(x)
if(!.R.)
  shingle <- function(x, intervals = sort(unique(oldUnclass(x))))
{
  if(is.vector(intervals))
    intervals <- cbind(intervals, intervals)
  
  dimnames(intervals) <- NULL
  attr(x, 'intervals') <- intervals
  class(x) <- 'shingle'   ## 6Aug00 to be like 5.x shingle
  x
}

prepanel.Dotplot <- function(x, y, ...)
{
  xlim <- range(x, attr(x,'other'), na.rm=TRUE)
  ylim <- range(as.numeric(y), na.rm=TRUE)  ## as.numeric 25nov02
  list(xlim=xlim, ylim=ylim) #, dx=diff(xlim), dy=diff(ylim))
}

panel.Dotplot <- function(x, y, groups = NULL,
                          pch  = dot.symbol$pch, 
                          col  = dot.symbol$col, cex = dot.symbol$cex, 
                          font = dot.symbol$font, abline, ...)
{
  gfun <- ordGridFun(.R.) ## see Misc.s
  segmnts <- gfun$segments
  y <- as.numeric(y)      ## 7dec02

  gp <- length(groups)
  dot.symbol <- trellis.par.get(if(gp)'superpose.symbol'
                                else 'dot.symbol')
  
  dot.line   <- trellis.par.get('dot.line')
  plot.line  <- trellis.par.get(if(gp)'superpose.line'
                                else 'plot.line')

  gfun$abline(h = unique(y), lwd=dot.line$lwd, lty=dot.line$lty, 
              col=dot.line$col)
  if(!missing(abline))
    do.call("panel.abline", abline)

  other <- attr(x,'other')
  x <- oldUnclass(x)
  attr(x,'other') <- NULL
  if(length(other)) {
    nc <- ncol(other)
    segmnts(other[,1], y, other[,nc], y, lwd=plot.line$lwd[1],
            lty=plot.line$lty[1], col=plot.line$col[1])
    if(nc==4) {
      segmnts(other[,2], y, other[,3], y, lwd=2*plot.line$lwd[1],
              lty=plot.line$lty[1], col=plot.line$col[1])
      gfun$points(other[,2], y, pch=3, cex=cex, col=col, font=font)
      gfun$points(other[,3], y, pch=3, cex=cex, col=col, font=font)
    }

    ## as.numeric( ) 1 and 6 lines below 23Apr02
    if(gp) panel.superpose(x, y, groups=as.numeric(groups), pch=pch,
                           col=col, cex=cex, font=font, ...)
    else
      gfun$points(x, y, pch=pch[1], cex=cex, col=col, font=font)
  } else {
    if(gp) 
      panel.superpose(x, y, groups=as.numeric(groups),
                      pch=pch, col=col, cex=cex,
                      font=font, ...)
    else
      panel.dotplot(x, y, pch=pch, col=col, cex=cex, font=font, ...)
  }
  if(gp) {
    if(.R.) Key <- function(x=0, y=1, lev, cex, col, font, pch, other)
    {
      if(!length(x)) x <- 0.05
      if(!length(y)) y <- 0.95  ## because of formals()
      rlegendg(x, y, legend=lev, cex=cex, col=col, pch=pch, other=other)
      invisible()
    } else Key <- function(x=NULL, y=NULL, lev, cex, col, font, pch,
                           other)
    { 
      ## other currently ignored for S-Plus
      if(length(x)) {
        if(is.list(x)) {
          y <- x$y;
          x <- x$x
        }

        key(x=x, y=y, text=list(lev, col=col), 
            points=list(cex=cex,col=col,font=font,pch=pch),
            transparent=TRUE)  #, ...)
      } else key(text=list(lev, col=col), 
                 points=list(cex=cex,col=col,font=font,pch=pch),
                 transparent=TRUE)  #, ...)

      invisible()
    }

    lev <- levels(as.factor(groups))
    ng <- length(lev)
    formals(Key) <- list(x=NULL,y=NULL,lev=lev,
                         cex=cex[1:ng], col=col[1:ng],
                         font=font[1:ng], pch=pch[1:ng], other=NULL)
    storeTemp(Key)
  }
}


Dotplot <-
  if(.R.) function (formula, data=sys.frame(sys.parent()),
                    groups, subset,
                    xlab=NULL, ylab=NULL, ylim=NULL,
                    panel=panel.Dotplot, prepanel=prepanel.Dotplot,
                    scales=NULL, xscale=NULL, ...)
{
  require('grid')
  require('lattice')
  yvname <- as.character(formula[2])  # tried deparse
  yv <- eval(parse(text=yvname), data)
  if(!length(ylab))
    ylab <- label(yv, units=TRUE, plot=TRUE,
                  default=yvname, grid=TRUE)
##    ylab <- attr(yv, 'label') 26sep02
##    if(!length(ylab)) ylab <- yvname
##  }

  if(!length(ylim)) {
    yother <- attr(yv,'other')
    if(length(yother))
      ylim <- range(yv, yother, na.rm=TRUE)
  }

  if(is.character(yv)) yv <- factor(yv)
  if(!length(scales) && is.factor(yv))
    scales <- list(y=list(at=1:length(levels(yv)),labels=levels(yv)))
  if(length(xscale)) scales$x <- xscale
  
  xvname <- formula[[3]]
  if(length(xvname)>1 && as.character(xvname[[1]])=='|') 
    xvname <- xvname[[2]]  # ignore conditioning var
  xv <- eval(xvname, data)
  if(!length(xlab)) xlab <- label(xv, units=TRUE, plot=TRUE,
                                  default=as.character(xvname), grid=TRUE)
  ##    xlab <- attr(xv, 'label')  26sep02
  ##    if(!length(xlab)) xlab <- as.character(xvname)
  ##  }

  if(!missing(groups))
    groups <- eval(substitute(groups),data)
  
  if(!missing(subset))
    subset <- eval(substitute(subset),data)
  
  dul <- options(drop.unused.levels=FALSE)   ## 25nov02, for empty cells
  on.exit(options(dul))                      ## across some panels
  
  do.call("xyplot", c(list(x = formula, data=data, prepanel=prepanel,
                           panel=panel),
                      if(length(ylab))list(ylab=ylab),  ## was c(ylab=)
                      if(length(ylim))list(ylim=ylim),  ## 28aug02
                      if(length(xlab))list(xlab=xlab),
                      if(!missing(groups))list(groups=groups),
                      if(!missing(subset))list(subset=subset),
                      if(length(scales))list(scales=scales),
                      list(...)))
} else function(formula, data = sys.parent(1), 
                prepanel=prepanel.Dotplot, panel = 'panel.Dotplot', 
                xlab = NULL, scales = NULL, ylim = NULL, groups = NULL, 
                ..., subset = TRUE)
{
  sub.formula <- substitute(formula)
  formula <- eval(sub.formula, data)
  if(missing(xlab)) {
    xv <- formula[[3]]
    if(length(xv)>1 && as.character(xv[[1]])=='|') 
      xv <- xv[[2]]  # ignore conditioning var

    ## xlab <- attr(eval(xv, data), 'label') 26sep02
    xlab <- label(eval(xv,data), units=TRUE, plot=TRUE,
                  default=if(is.numeric(formula))
                  deparse(sub.formula) else '') 
  }

  ##if(is.null(xlab) && is.numeric(formula))  26sep02
  ##xlab <- deparse(sub.formula)
  subset <- eval(substitute(subset), data)
  groups <- eval(substitute(groups), data)

  dul <- options(drop.unused.levels=FALSE)   ## 25nov02, for empty cells
  on.exit(options(dul))

  data <- setup.1d.trellis(formula, data = data, panel=panel,
                           prepanel = prepanel, 
                           xlab = xlab, 
                           groups = groups, ..., subset = subset)
  if(!is.null(scales))
    data$scales <- add.scale.trellis(scales, data$scales)

  if(is.null(scale$y$limits) && is.null(ylim))
    data$scales$y$limits <- data$ylim + c(-0.75, 0.75)

  data
}


setTrellis <- function(strip.blank=TRUE, lty.dot.line=2,
                       lwd.dot.line=1)
{
  if(strip.blank) trellis.strip.blank()   # in Hmisc Misc.s
  dot.line <- trellis.par.get('dot.line')
  dot.line$lwd <- lwd.dot.line
  dot.line$lty <- lty.dot.line
  trellis.par.set('dot.line',dot.line)
  invisible()
}


numericScale <- function(x, label=NULL, skip.weekends= FALSE, ...)
{
  td <- inherits(x,'timeDate')
  if(td) {
    u <- axis.time(range(x,na.rm=TRUE),
                   skip.weekends=skip.weekends, ...)$grid
    major  <- list(at=as.numeric(u$major.grid$x),
                   labels=format(u$major.grid$x))
    minor  <- list(at=as.numeric(u$minor$x),
                   labels=format(u$minor$x))
  }

  xn <- as.numeric(x)

  attr(xn,'label') <- if(length(label)) label
                      else deparse(substitute(x))

  if(td) {
    attr(xn,'scales.major') <- major
    attr(xn,'scales.minor') <- minor
  }

  xn
}

## See proc.scale.trellis, render.trellis, axis.trellis for details of
## how scale is used
## Author: Frank Harrell 24 Jun 91
xy.group <- function(x,y,m=150,g,fun=mean,result="list")
{
  k <- !is.na(x+y)
  if(sum(k)<2)
    stop("fewer than 2 non-missing x and y")

  x <- x[k]
  y <- y[k]
  if(missing(m))
    q <- cut2(x,g=g,levels.mean=TRUE,digits=7)
  else
    q <- cut2(x,m=m,levels.mean=TRUE,digits=7)

  n <- table(q)
  x.mean <- as.single(levels(q))
  y.fun <- as.vector(tapply(y, q, fun))
  if(result=="matrix")	{
    z <- cbind(table(q),x.mean,y.fun)
    dimnames(z) <- list(levels(q), c("n","x","y"))
  } else z <- list(x=x.mean,y=y.fun)
  z
}
## Function to use the mouse to zoom in on plots.
## Author: Bill Dunlap <bill@STAT.WASHINGTON.EDU>
zoom<-function(fun=usa,...)
{
  on.exit(par(oldpar))
  oldpar<-par(err=-1)
  fun(...)
  while(TRUE) {
    cat("Click mouse over corners of zoom area: ")
    p<-locator(n=2)
    if(is.null(p$x) || length(p$x)!=2)
      break

    xlim<-range(p$x)
    ylim<-range(p$y)
    cat("xlim=",xlim,"ylim=",ylim,"\n")
    fun(...,xlim=xlim,ylim=ylim)
  }

  cat("Bye!\n")
}
