.packageName <- "gtools"
# $Id: RSCompat.S,v 1.9 2005/06/09 14:20:28 nj7w Exp $
#
# $Log: RSCompat.S,v $
# Revision 1.9  2005/06/09 14:20:28  nj7w
# Updating the version number, and various help files to synchronize splitting of gregmisc bundle in 4 individual components.
#
# Revision 1.1.1.1  2005/05/25 22:17:28  nj7w
# Initial submision as individual package
#
# Revision 1.8  2003/04/04 13:58:59  warnes
#
# - Replace 'T' with 'TRUE'
#
# Revision 1.7  2003/03/07 15:48:35  warnes
#
# - Minor changes to code to allow the package to be provided as an
#   S-Plus chapter.
#
# Revision 1.6  2003/01/02 15:42:00  warnes
# - Add nlevels function.
#
# Revision 1.5  2002/03/20 03:44:32  warneg
# - Added definition of is.R function.
#
# - Added boxplot.formula
#
# Revision 1.4  2002/02/05 02:20:07  warneg
#
# - Fix typo that caused code meant to run only under S-Plus to run
#   under R, causing problems.
#
# Revision 1.3  2001/12/19 22:45:44  warneg
# - Added code for %in%.
#
# Revision 1.2  2001/09/18 14:15:44  warneg
#
# Release 0.3.2
#
# Revision 1.1  2001/09/01 19:19:13  warneg
#
# Initial checkin.
#
#
# Code necessary for contrast.lm, boxplot.n to work in S-Plus
 
if(!exists("is.R") || !is.R() )
  {
    is.R <- function() FALSE 
    
    getOption <- function(...) options(...)
    
    if(!exists("parent.frame")) parent.frame <- sys.parent
    
    colnames <- function (x, do.NULL = TRUE, prefix = "col") 
      {
        dn <- dimnames(x)
        if (!is.null(dn[[2]])) 
          dn[[2]]
        else {
          if (do.NULL) 
            NULL
          else paste(prefix, seq(length = NCOL(x)), sep = "")
        }
      }
    
    rownames <- function (x, do.NULL = TRUE, prefix = "row") 
      {
        dn <- dimnames(x)
        if (!is.null(dn[[1]])) 
          dn[[1]]
        else {
          if (do.NULL) 
            NULL
          else paste(prefix, seq(length = NROW(x)), sep = "")
        }
      }
    
    "rownames<-" <- function (x, value) 
      {
        dn <- dimnames(x)
        ndn <- names(dn)
        dn <- list(value, if (!is.null(dn)) dn[[2]])
        names(dn) <- ndn
        dimnames(x) <- dn
        x
      }
    
    "colnames<-" <- function (x, value) 
      {
       dn <- dimnames(x)
       ndn <- names(dn)
       dn <- list(if (!is.null(dn)) dn[[1]], value)
       names(dn) <- ndn
       dimnames(x) <- dn
       x
     }
    
   # from the MASS library by Venables & Ripley 
    ginv <- function (X, tol = sqrt(.Machine$double.eps))
      {
        if (length(dim(X)) > 2 || !(is.numeric(X) || is.complex(X)))
          stop("X must be a numeric or complex matrix")
        if (!is.matrix(X))
          X <- as.matrix(X)
        Xsvd <- svd(X)
        if (is.complex(X))
          Xsvd$u <- Conj(Xsvd$u)
        Positive <- Xsvd$d > max(tol * Xsvd$d[1], 0)
        if (all(Positive)) Xsvd$v %*% (1/Xsvd$d * t(Xsvd$u))
        else if (!any(Positive)) array(0, dim(X)[2:1])
        else Xsvd$v[, Positive] %*% ((1/Xsvd$d[Positive]) * t(Xsvd$u[, Positive]))
      }
    
    
    "format.pval" <- 
      function (pv, digits = max(1, getOption("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(pv))
            fixp <- expo >= -3 | (expo == -4 & digits > 1)
            if (any(fixp)) 
              rr[fixp] <- format(pv[fixp], dig = digits)
            if (any(!fixp)) 
              rr[!fixp] <- format(pv[!fixp], dig = 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
        }
    
    "%in%" <- function (x, table)  match(x, table, nomatch = 0) > 0
 
    strwidth   <-  function(...)
      {
        par("cin")[1] / par("fin")[1] * (par("usr")[2] - par("usr")[1])
      }
    
    strheight <-  function(...)
      {
        par("cin")[2] / par("fin")[2] * (par("usr")[4] - par("usr")[3])
      }
    
    boxplot.formula <- function(x, data = sys.parent(), ..., ask = TRUE)
      {
        if(!inherits(x, "formula"))
          x <- as.formula(x)
        
        mf <- model.frame(x, data, na.action = function(z) 	z)
        if(length(names(mf)) > 2) 
          stop("boxplot.formula only accepts models with 1 predictor")
        
        resp <- attr(attr(mf, "terms"), "response")
        class(mf) <- NULL
        y <- mf[[resp]]
        x <- mf[[-resp]]
        xlab <- names(mf)[-resp]
        ylab <- names(mf)[resp]
	
        boxplot(split(y, x), xlab = xlab, ylab = ylab, ...) 
      }

    nlevels <- function(x) length(levels(x))

    NULL
    
  }
addLast <- function( fun )
  {
    if (!is.function(fun)) stop("fun must be a function")
    if(!exists(".Last", env=.GlobalEnv))
      assign(".Last", fun, env=.GlobalEnv)
    else
      {
        Last <- get(".Last", env=.GlobalEnv)
        newfun <- function(...)
          {
            fun()
            Last()
          }
        assign(".Last", newfun, env=.GlobalEnv)
      }
  }
## useful function, raises an error if the FLAG expression is FALSE
assert <- function( FLAG )
  {
    if(!all(FLAG))
      stop("Failed Assertion") 
  }
# $Id: combinations.R,v 1.7 2005/06/09 14:20:28 nj7w Exp $
#

##
## From email by Brian D Ripley <ripley@stats.ox.ac.uk> to r-help
## dated Tue, 14 Dec 1999 11:14:04 +0000 (GMT) in response to
## Alex Ahgarin <datamanagement@email.com>.  Original version was
## named "subsets" and was Written by Bill Venables.  
##

combinations <- function(n, r, v = 1:n, set = TRUE, repeats.allowed=FALSE)
{
  if(mode(n) != "numeric" || length(n) != 1 
     || n < 1 || (n %% 1) != 0) stop("bad value of n") 
  if(mode(r) != "numeric" || length(r) != 1 
     || r < 1 || (r %% 1) != 0) stop("bad value of r") 
  if(!is.atomic(v) || length(v) < n) 
    stop("v is either non-atomic or too short")
  if( (r > n) & repeats.allowed==FALSE)
    stop("r > n and repeats.allowed=FALSE")
  if(set) {
    v <- unique(sort(v))
    if (length(v) < n) stop("too few different elements")
  }
  v0 <- vector(mode(v), 0)
  ## Inner workhorse
  if(repeats.allowed)
    sub <- function(n, r, v)
      { 
        if(r == 0) v0 else
        if(r == 1) matrix(v, n, 1) else
        if(n == 1) matrix(v, 1, r) else
        rbind( cbind(v[1], Recall(n, r-1, v)),
              Recall(n-1, r, v[-1]))
      }
  else
    sub <- function(n, r, v)
      { 
        if(r == 0) v0 else
        if(r == 1) matrix(v, n, 1) else
        if(r == n) matrix(v, 1, n) else
        rbind(cbind(v[1], Recall(n-1, r-1, v[-1])),
              Recall(n-1, r, v[-1]))
      }
  sub(n, r, v[1:n])
}

##
## Original version by Bill Venables and cited by by Matthew
## Wiener (mcw@ln.nimh.nih.gov) in an email to R-help dated
## Tue, 14 Dec 1999 09:11:32 -0500 (EST) in response to
## Alex Ahgarin <datamanagement@email.com>
##
##


permutations <- function(n, r, v = 1:n, set = TRUE, repeats.allowed=FALSE)
{
  if(mode(n) != "numeric" || length(n) != 1 
     || n < 1 || (n %% 1) != 0) stop("bad value of n") 
  if(mode(r) != "numeric" || length(r) != 1 
     || r < 1 || (r %% 1) != 0) stop("bad value of r") 
  if(!is.atomic(v) || length(v) < n) 
    stop("v is either non-atomic or too short")
  if( (r > n) ) #& repeats.allowed==FALSE)
    stop("r > n") # and repeats.allowed=FALSE")
  if(set) {
    v <- unique(sort(v))
    if (length(v) < n) stop("too few different elements")
  }
  v0 <- vector(mode(v), 0)
  ## Inner workhorse
  if(repeats.allowed)
    sub <- function(n, r, v)
      {
        if(r==1) matrix(v,n,1) else
        if(n==1) matrix(v,1,r) else
        {
          inner  <-  Recall(n, r-1, v)
          cbind( rep( v, rep(nrow(inner),n)  ),
                 matrix( t(inner), ncol=ncol(inner), nrow=nrow(inner) * n ,
                        byrow=TRUE )
                )
        }
      }
  else
    sub <- function(n, r, v)
      {
        if(r==1) matrix(v,n,1) else
        if(n==1) matrix(v,1,r) else
        {
        X  <-  NULL
        for(i in 1:n)
          X  <-  rbind( X, cbind( v[i], Recall(n-1, r - 1, v[-i])))
        X
        }
      }

  sub(n, r, v[1:n])
}
## Code from
##
## @Article{Rnews:Lumley:2001,
##  author       = {Thomas Lumley},
##  title	       = {Programmer's Niche: Macros in {R}},
##  journal      = {R News},
##  year	       = 2001,
##  volume       = 1,
##  number       = 3,
##  pages	       = {11--13},
##  month	       = {September},
##  url	       = {http://CRAN.R-project.org/doc/Rnews/}
##}
defmacro <- function(..., expr) #, DOTS=FALSE)
{
  expr <- substitute(expr)
  a <- substitute(list(...))[-1]

  ## process the argument list
  nn <- names(a)
  if (is.null(nn))
    nn <- rep("", length(a))
  for(i in 1:length(a))
    {
      if (nn[i] == "")
        {
          nn[i] <- paste(a[[i]])
          msg <- paste(a[[i]], "not supplied")
          a[[i]] <- substitute(stop(foo),
                               list(foo = msg))
        }
      if (nn[i] == "DOTS")
        {
          nn[i] <- "..."
          a[[i]] <- formals(function(...){})[[1]]
        }
    }
  names(a) <- nn
  a <- as.list(a)

  ## this is where the work is done
  ff <- eval(substitute(
                        function()
                        {
                          tmp <- substitute(body)
                          eval(tmp, parent.frame())
                        },
                        list(body = expr)))
  
  ## add the argument list
  formals(ff) <- a
  
  ## create a fake source attribute
  mm <- match.call()
  mm$expr <- NULL
  mm[[1]] <- as.name("macro")
  attr(ff, "source") <- c(deparse(mm),
                          deparse(expr))
  
  ## return the 'macro'
  ff
}

# $Id: dirichlet.R,v 1.4 2005/06/09 14:20:28 nj7w Exp $

# Posted by Ben Bolker to R-News on Fri Dec 15 2000
# http://www.r-project.org/nocvs/mail/r-help/2000/3865.html
#
# Some code (originally contributed by Ian Wilson
# <i.wilson@maths.abdn.ac.uk>


#  functions for the "Dirichlet function", the multidimensional
#  generalization of the beta distribution: it's the Bayesian
#  canonical # distribution for the parameter estimates of a
#  multinomial distribution.

# "pdirichlet" and "qdirichlet" (distribution function and quantiles)
# would be more difficult because you'd first have to decide how to
# define the distribution function for a multivariate distribution
# ... I'm sure this could be done but I don't know how



ddirichlet<-function(x,alpha)
## probability density for the Dirichlet function, where x=vector of
## probabilities
## and (alpha-1)=vector of observed samples of each type
## ddirichlet(c(p,1-p),c(x1,x2)) == dbeta(p,x1,x2)
{

  dirichlet1 <- function(x, alpha)
    {
      logD <- sum(lgamma(alpha)) - lgamma(sum(alpha))
      s<-sum((alpha-1)*log(x))
      exp(sum(s)-logD)

    }

  # make sure x is a matrix
  if(!is.matrix(x))
    if(is.data.frame(x))
      x <- as.matrix(x)
    else
      x <- t(x)

  if(!is.matrix(alpha))
    alpha <- matrix( alpha, ncol=length(alpha), nrow=nrow(x), byrow=TRUE)

  if( any(dim(x) != dim(alpha)) )
    stop("Mismatch between dimensions of 'x' and 'alpha'.")

  pd <- vector(length=nrow(x))
  for(i in 1:nrow(x))
    pd[i] <- dirichlet1(x[i,],alpha[i,])

  # Enforce 0 <= x[i,j] <= 1, sum(x[i,]) = 1
  pd[ apply( x, 1, function(z) any( z <0 | z > 1)) ] <- 0
  pd[ apply( x, 1, function(z) all.equal(sum( z ),1) !=TRUE) ] <- 0
  pd
}


rdirichlet<-function(n,alpha)
## generate n random deviates from the Dirichlet function with shape
## parameters alpha
{
    l<-length(alpha);
    x<-matrix(rgamma(l*n,alpha),ncol=l,byrow=TRUE);
    sm<-x%*%rep(1,l);
    x/as.vector(sm);
}

# $Id: foldchange.R,v 1.3 2005/06/09 14:20:29 nj7w Exp $

foldchange <- function(num,denom)
  {
    ifelse(num >= denom, num/denom, -denom/num)
  }


# Compute foldchange from log-ratio values
logratio2foldchange <- function(logratio, base=2)
  {
    retval <- base^(logratio)
    retval <- ifelse(retval < 1, -1/retval, retval)
    retval
  }

# vice versa
foldchange2logratio <- function(foldchange, base=2)
  {
    retval <- ifelse( foldchange<0, 1/-foldchange, foldchange)
    retval <- log(retval,base)
    retval
  }

# $Id: invalid.R,v 1.4 2005/06/09 14:20:29 nj7w Exp $

invalid <- function(x)
  {
    if( missing(x) || is.null(x) || length(x)==0 )
      return(TRUE)
    if(is.list(x))
      return(all(sapply(x,invalid)))
    else if(is.vector(x))
      return(all(is.na(x)))
    else
      return(FALSE)
  }
# $Id: logit.R,v 1.2 2005/06/09 14:20:29 nj7w Exp $

logit <- function(x, min=0, max=1)
  {
    p <- (x-min)/(max-min)
    log(p/(1-p))
  }

inv.logit <- function(x, min=0, max=1)
  {
    p <- exp(x)/(1+exp(x))
    p <- ifelse( is.na(p) & !is.na(x), 1, p ) # fix problems with +Inf
    p * (max-min) + min
  }
                 
# $Id: mixedsort.R,v 1.10 2005/06/13 17:08:41 nj7w Exp $

mixedsort <- function(x) x[mixedorder(x)]

mixedorder <- function(x)
  {
    # - Split each each character string into an vector of strings and
    #   numbers
    # - Separately rank numbers and strings
    # - Combine orders so that strings follow numbers

    delim="\\$\\@\\$"

    numeric <- function(x)
      {
        optwarn = options("warn")
        on.exit( options(optwarn) )
        options(warn=-1)
        as.numeric(x)
      }

    nonnumeric <- function(x)
      {
        optwarn = options("warn")
        on.exit( options(optwarn) )
        options(warn=-1)

        ifelse(is.na(as.numeric(x)), toupper(x), NA)
      }


    x <- as.character(x)

    which.nas <- which(is.na(x))
    which.blanks <- which(x=="")

    if(length(which.blanks) >0)
    x[ which.blanks ] <- -Inf
    if(length(which.nas) >0)
    x[ which.nas ] <- Inf

    ####
    # - Convert each character string into an vector containing single
    #   character and  numeric values.
    ####

    # find and mark numbers in the form of +1.23e+45.67
    delimited <- gsub("([+-]{0,1}[0-9\.]+([eE][\+\-]{0,1}[0-9\.]+){0,1})",
                      paste(delim,"\\1",delim,sep=""), x)

    # separate out numbers
    step1 <- strsplit(delimited, delim)

    # remove empty elements
    step1 <- lapply( step1, function(x) x[x>""] )

    # create numeric version of data
    step1.numeric <- lapply( step1, numeric )

    # create non-numeric version of data
    step1.character <- lapply( step1, nonnumeric )

    # now transpose so that 1st vector contains 1st element from each
    # original string
    maxelem <- max(sapply(step1, length))

    step1.numeric.t <- lapply(1:maxelem,
                              function(i)
                                 sapply(step1.numeric,
                                        function(x)x[i])
                              )

    step1.character.t <- lapply(1:maxelem,
                              function(i)
                                 sapply(step1.character,
                                        function(x)x[i])
                              )

    # now order them
    rank.numeric   <- sapply(step1.numeric.t,rank)
    rank.character <- sapply(step1.character.t,
                             function(x) as.numeric(factor(x)))

    # and merge
    rank.numeric[!is.na(rank.character)] <- 0  # mask off string values

    rank.character <- t(
                        t(rank.character) +
                        apply(matrix(rank.numeric),2,max,na.rm=TRUE)
                        )
    
    rank.overall <- ifelse(is.na(rank.character),rank.numeric,rank.character)

    order.frame <- as.data.frame(rank.overall)
    if(length(which.nas) > 0)
      order.frame[which.nas,] <- Inf
    retval <- do.call("order",order.frame)

    return(retval)
  }


# $Id: oddeven.R,v 1.3 2005/06/09 14:20:29 nj7w Exp $

# detect odd/even integers
odd <- function(x) x!=as.integer(x/2)*2
even <- function(x) x==as.integer(x/2)*2
# $Id: permute.R,v 1.3 2005/06/09 14:20:29 nj7w Exp $

permute <- function(x) sample( x, size=length(x), replace=FALSE )
# $Id: quantcut.R,v 1.4 2005/06/09 14:20:29 nj7w Exp $

quantcut <- function(x, q=seq(0,1,by=0.25), na.rm=TRUE, ... )
  {
    quant <- quantile(x, q, na.rm=na.rm)
    dups <- duplicated(quant)
    if(any(dups))
      {
        flag <- x %in% unique(quant[dups])
        retval <- ifelse(flag,
                         paste("[",
                               as.character(x),
                               "]",
                               sep=''),
                         NA)
        uniqs <- unique(quant)

        # move cut points over a bit...
        reposition <- function(cut)
                           {
                             flag <- x>=cut
                             if(sum(flag)==0)
                               return(cut)
                             else
                               return(min(x[flag], na.rm=na.rm))
                           }
        
        newquant <- sapply(uniqs, reposition)
        retval[!flag] <- as.character(cut(x[!flag],
                                          breaks=newquant,
                                          include.lowest=TRUE,...))
        
        levs <- unique(retval[order(x)]) # ensure factor levels are
                                         # properly ordered
        retval <- factor(retval, levels=levs)

        ## determine open/closed interval ends
        mkpairs <- function(x) # make table of lower, upper
          sapply(x,
                 function(y) if(length(y)==2) y[c(2,2)] else y[2:3]
                 )
        pairs <- mkpairs(strsplit(levs, '[^0-9+\\.\\-]+', extended=TRUE))
        rownames(pairs) <- c("lower.bound","upper.bound")
        colnames(pairs) <- levs
        
        closed.lower <- rep(F,ncol(pairs)) # default lower is open
        closed.upper <- rep(T,ncol(pairs)) # default upper is closed
        closed.lower[1] <- TRUE             # lowest interval is always closed

        for(i in 2:ncol(pairs))            # open lower interval if above singlet
          if(pairs[1,i]==pairs[1,i-1] && pairs[1,i]==pairs[2,i-1])
            closed.lower[i] <- FALSE
        
        for(i in 1:(ncol(pairs)-1))        # open upper inteval if below singlet
          if(pairs[2,i]==pairs[1,i+1] && pairs[2,i]==pairs[2,i+1])
            closed.upper[i] <- FALSE

        levs <- ifelse(pairs[1,]==pairs[2,],
                       pairs[1,],
                       paste(ifelse(closed.lower,"[","("),
                             pairs[1,],
                             ",",
                             pairs[2,],
                             ifelse(closed.upper,"]",")"),
                             sep='')
                       )
        levels(retval) <- levs
      }
    else
      retval <- cut( x, quant, include.lowest=TRUE,  ... )
    return(retval)
  }
# $Id: running.R,v 1.12 2005/06/09 14:20:29 nj7w Exp $

"running" <- function(X, Y=NULL,
                      fun=mean,
                      width=min(length(X), 20),
                      allow.fewer=FALSE, pad=FALSE,
                      align=c("right", "center", "left"),
                      simplify=TRUE,
                      by,  # added a parameter
                      ...)
{
  align=match.arg(align)

  n <- length(X)

  if (align=="left")
    {
      from  <-  1:n
      to    <-  pmin( (1:n)+width-1, n)
    }
  else if (align=="right")
    {
      from  <-  pmax( (1:n)-width+1, 1)
      to    <-  1:n
    }
  else #align=="center"
    {
      from <-  pmax((2-width):n,1)
      to   <-  pmin(1:(n+width-1),n)
      if(!odd(width)) stop("width must be odd for center alignment")

    }

  elements  <- apply(cbind(from, to), 1, function(x) seq(x[1], x[2]) )

  if(is.matrix(elements))
    elements <- as.data.frame(elements) # ensure its a list!

  names(elements) <- paste(from,to,sep=':')

  if(!allow.fewer)
    {
      len <- sapply(elements, length)
      skip <- (len < width)
    }
  else
    {
      skip <- 0
    }


  run.elements  <- elements[!skip]

  if(!invalid(by))
    run.elements <- run.elements[seq(from=1, to=length(run.elements),
                                     by=by)]


  if(is.null(Y))  # univariate
    {
      funct <- function(which,what,fun,...) fun(what[which],...)

      if(simplify)
        Xvar <- sapply(run.elements, funct, what=X, fun=fun, ...)
      else
        Xvar <- lapply(run.elements, funct, what=X, fun=fun, ...)
    }
  else # bivariate
    {
      funct <- function(which,XX,YY,fun,...) fun(XX[which],YY[which], ...)

      if(simplify)
        Xvar <- sapply(run.elements, funct, XX=X, YY=Y, fun=fun, ...)
      else
        Xvar <- lapply(run.elements, funct, XX=X, YY=Y, fun=fun, ...)
    }


  if(allow.fewer || !pad)
      return(Xvar)

  if(simplify)
    if(is.matrix(Xvar))
      {
        wholemat <- matrix( new(class(Xvar[1,1]), NA),
                           ncol=length(to), nrow=nrow(Xvar) )
        colnames(wholemat) <- paste(from,to,sep=':')
        wholemat[,-skip] <- Xvar
        Xvar <- wholemat
      }
    else
      {
        wholelist <- rep(new(class(Xvar[1]),NA),length(from))
        names(wholelist) <-  names(elements)
        wholelist[ names(Xvar) ] <- Xvar
        Xvar <- wholelist
      }

  return(Xvar)
}

# $Id: scat.R,v 1.2 2005/06/09 14:20:29 nj7w Exp $

# cat to stdout and immediately flush
scat <- function(...)
  {
    DEBUG <- options()$DEBUG
    if( !is.null(DEBUG) && DEBUG)
      {
        cat("### ", file=stderr())
        cat(..., file=stderr())
        cat(" ###\n", file=stderr())
        flush(stderr())
      }
    invisible(NULL)
  }
setTCPNoDelay <- function( socket, value=TRUE )
  {
    if(!any(c("socket","sockconn") %in% class(socket)))
      stop("socket must be a socket object")

    buffer <- paste(rep(" ", 1000), sep='', collapse='')

    conn <- getConnection(socket[1])
    
    retval <- .C("R_setTCPNoDelay",
                 socket=as.integer(socket[1]),
                 flag=as.integer(value),
                 status=integer(1),
                 status.str=as.character(buffer),
                 status.len=as.integer(nchar(buffer)),
                 package="gtools"
                 )

    if(retval$status != 0)
      stop( retval$status.str )
    else
      invisible(retval$status.str)
  }

strmacro <- function(..., expr, strexpr)
{
  if(!missing(expr))
    strexpr <- deparse(substitute(expr))
  
  a <- substitute(list(...))[-1]

  nn <- names(a)
  if (is.null(nn))
    nn <- rep("", length(a))
  for(i in 1:length(a))
    {
      if (nn[i] == "")
        {
          nn[i] <- paste(a[[i]])
          msg <- paste(a[[i]], "not supplied")
          a[[i]] <- substitute(stop(foo),
                               list(foo = msg))
        }
      else
        {
          a[[i]] <- a[[i]]
        }
      #if (nn[i] == "DOTS")
      #  {
      #    nn[i] <- "..."
      #    a[[i]] <- formals(function(...){})[[1]]
      #  }
    }
  names(a) <- nn
  a <- as.list(a)

  ## this is where the work is done
  ff <- 
    function(...)
      {
        ## build replacement list
        reptab <- a # copy defaults first
        reptab$"..." <- NULL
        #reptab$DOTS <- ""
        
        args <- match.call(expand.dots=TRUE)[-1]
        #print(args)
                          
        for(item in names(args))
          ##if(item %in% names(reptab))
          reptab[[item]] <- args[[item]]
        ##else
        ##  {
        ##    browser()
        ##    oldval <- reptab[["DOTS"]]
        ##    addval <- paste(item, "=", args[[item]])
        ##    if(oldval>"")
        ##      newval <- paste(c(oldval, addval), collapse=", ")
        ##    else
        ##      newval <- addval
        ##    reptab[["DOTS"]] <- newval
        ##  }
        
        #print(reptab)
        
        ## do the replacements
        body <- strexpr
        for(i in 1:length(reptab))
          {
            pattern <- paste("\\b",
                             names(reptab)[i],
                             "\\b",sep='')
            
            value <- reptab[[i]]
            if(missing(value))
              value <- ""
            
            body <- gsub(pattern,
                         value,
                         body,
                         extended=TRUE)
          }

        #print(body)
        
        fun <- parse(text=body)
        eval(fun, parent.frame())

        
      }
  
  
  
  ## add the argument list
  formals(ff) <- a
  
  ## create a fake source attribute
  mm <- match.call()
  mm$expr <- NULL
  mm[[1]] <- as.name("macro")
  attr(ff, "source") <- c(deparse(mm), strexpr)
  
  ## return the 'macro'
  ff
}




