.packageName <- "gdata"
Args <- function(name, sort.args=FALSE)
{
  a <- formals(get(as.character(substitute(name)), pos=1))
  if(is.null(a))
    return(NULL)
  arg.labels <- names(a)
  arg.values <- as.character(a)
  char <- sapply(a, is.character)
  arg.values[char] <- paste("\"", arg.values[char], "\"", sep="")

  if(sort.args)
  {
    ord <- order(arg.labels)
    if(any(arg.labels == "..."))
      ord <- c(ord[-which(arg.labels[ord]=="...")],
               which(arg.labels=="..."))
    arg.labels <- arg.labels[ord]
    arg.values <- arg.values[ord]
  }

  output <- data.frame(value=I(arg.values), row.names=arg.labels)
  print(output, right=FALSE)

  invisible(output)
}

ConvertMedUnits <- function(x, measurement, abbreviation,
                            to=c("Conventional","SI","US"),
                            exact=!missing(abbreviation))
  {
    data(MedUnits,package='gdata')
    to=match.arg(to)
    if(!missing(measurement) && missing(abbreviation))
      {
        if(exact)
          matchUnits <- MedUnits[tolower(MedUnits$Measurement)==
                                 tolower(measurement),]
        else
          matchUnits <- MedUnits[grep(measurement, MedUnits$Measurement,
                                  ignore.case=TRUE),]
      }
    else if(missing(measurement) && !missing(abbreviation))
      {
        if(exact)
          matchUnits <- MedUnits[tolower(MedUnits$Abbreviation)==
                                 tolower(abbreviation),]
    else
      matchUnits <- MedUnits[grep(match, MedUnits$Abbrevation,
                                  ignore.case=TRUE),]
      }
    else # both missing or both specified
      stop("One of `measurement' or `abbreviation' must be specified.")


    if(nrow(matchUnits)>1)
      stop(
           paste("More than one matching row.  Please use 'exact=TRUE' ",
                 "and supply one of these matching strings:",
                 paste('\t"',matchUnits$Measurement, '"', sep='', collapse="\n\t"),
                 sep="\n\t"))
   else if (nrow(matchUnits)<1)
     stop("No match")

    if (to %in% c("Convetional", "US"))
      {
        retval <- x / matchUnits$Conversion
        attr(retval,"units") <- matchUnits$ConventionalUnits
      }
    else
      {
        retval <- x * matchUnits$Conversion
        attr(retval,"units") <- matchUnits$SIUnits
      }
    retval
  }
      
    

    
    
# $Id: aggregate.table.R,v 1.5 2005/06/09 14:20:24 nj7w Exp $

aggregate.table <- function(x, by1, by2, FUN=mean, ... )
  {
    if(!is.factor(by1)) by1 <- as.factor(by1)
    if(!is.factor(by2)) by2 <- as.factor(by2)

    ag <- aggregate(x, by=list(by1,by2), FUN=FUN, ... )
    tab <- matrix( nrow=nlevels(by1), ncol=nlevels(by2) )
    dimnames(tab) <- list(levels(by1),levels(by2))

    for(i in 1:nrow(ag))
      tab[ as.character(ag[i,1]), as.character(ag[i,2]) ] <- ag[i,3]
    tab
  }
# $Id: combine.R,v 1.4 2005/06/09 14:20:24 nj7w Exp $

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

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

      }

    namelist  <- factor(rep(names, len), levels=names)

    return( data.frame( data, source=namelist) )
  }
drop.levels <- function(x, reorder = TRUE, ...) {
 as.data.frame(lapply(x, function(xi) {
    if(is.factor(xi)) {
      xi <- factor(xi)
      if(reorder)
        xi <- reorder(xi, ...)
    }
    xi
  }))
}
# $Id: elem.R,v 1.7 2005/06/09 14:20:24 nj7w Exp $

elem <- function(object=1, unit=c("KB","MB","bytes"), digits=0,
                 dimensions=FALSE)
{
  .Deprecated("ll", package="gdata")
  ll(pos=object, unit=unit, digits=digits, dimensions=dimensions)
}

# $Id: env.R,v 1.9 2005/06/09 14:20:24 nj7w Exp $

env <- function(unit=c("KB","MB","bytes"), digits=0)
{
  get.object.size <- function(object.name, pos)
  {
    object <- get(object.name, pos=pos)
    size <- try(object.size(object), silent=TRUE)
    if(class(size) == "try-error")
      size <- 0
    return(size)
  }

  get.environment.size <- function(pos)
  {
    if(search()[pos]=="Autoloads" || length(ls(pos,all=TRUE))==0)
      size <- 0
    else
      size <- sum(sapply(ls(pos,all=TRUE), get.object.size, pos=pos))
    return(size)
  }

  get.environment.nobjects <- function(pos)
  {
    nobjects <- length(ls(pos,all=TRUE))
    return(nobjects)
  }

  unit <- match.arg(unit)
  denominator <- switch(unit, "KB"=1024, "MB"=1024^2, 1)
  size.vector <- sapply(seq(along=search()), get.environment.size)
  size.vector <- round(size.vector/denominator, digits)
  nobjects.vector <- sapply(seq(along=search()), get.environment.nobjects)
  env.frame <- data.frame(search(), nobjects.vector, size.vector)
  names(env.frame) <- c("Environment", "Objects", unit)

  print(env.frame, right=FALSE)
  invisible(env.frame)
}

# $Id: frameApply.R,v 1.2 2005/06/09 14:20:24 nj7w Exp $
#
frameApply <- function(x, by = NULL, on = by[1], fun = function(xi) c(Count = nrow(xi)) , subset = TRUE, simplify = TRUE, byvar.sep = "\\$\\@\\$", ...) {
  subset <- eval(substitute(subset), x, parent.frame())                               
  x <- x[subset, , drop = FALSE]
  if(!is.null(by)) {
    x[by] <- drop.levels(x[by])
    for(i in seq(along = by))
           if(length(grep(byvar.sep, as.character(x[[by[i]]])))) stop("Choose a different value for byvar.sep.")
    byvars <- unique(x[by])
    BYVAR <- do.call("paste", c(as.list(x[by]), sep = byvar.sep))
    byvars <- byvars[order(unique(BYVAR)), , drop = FALSE]
    splx <- split(x[on], BYVAR) 
    splres <- lapply(splx, fun, ...)
    if(!simplify) out <- list(by = byvars, result = splres)
    else {
      i <- 1 ; nres <- length(splres)
      while(inherits(splres[[i]], "try-error") & i < nres) i <- i + 1
      nms <- names(splres[[i]])
      # nms <- lapply(splres, function(xi) {
      #   if(inherits(xi, "try-error")) return(NULL)
      #   else names(xi)
      # })
      # nms <- do.call("rbind", nms)[1, ]
      splres <- lapply(splres, function(xi) {
        if(inherits(xi, "try-error")) {
          return(rep(NA, length(nms)))
        }
        else xi
        })
      res <- do.call("rbind", splres)
      res <- as.data.frame(res)
      names(res) <- nms
      if(length(intersect(names(byvars), names(res))))
        stop("Names of \"by\" variables are also used as names of result elements. Not allowed.\n")
      out <- data.frame(byvars, res)
    }
  }
  else {
    out <- fun(x[on])
    if(simplify) out <- as.data.frame(as.list(out))
  }
  out
}
# $Id: interleave.R,v 1.7 2005/12/08 20:18:15 warnes Exp $

interleave <- function(..., append.source=TRUE, sep=": ", drop=FALSE)
  {
    sources <- list(...)

    sources[sapply(sources, is.null)] <- NULL

    sources <- lapply(sources, function(x)
                      if(is.matrix(x) || is.data.frame(x))
                      x else t(x) )

    nrows <- sapply( sources, nrow )
    mrows <- max(nrows)
    if(any(nrows!=mrows & nrows!=1 ))
      stop("Arguments have differening numbers of rows.")

    sources <- lapply(sources, function(x)
                      if(nrow(x)==1) x[rep(1,mrows),,drop=drop] else x )

    tmp <- do.call("rbind",sources)

    nsources <- length(sources)
    indexes <- outer( ( 0:(nsources-1) ) * mrows , 1:mrows, "+" )

    retval <- tmp[indexes,,drop=drop]

    if(append.source && !is.null(names(sources) ))
      if(!is.null(row.names(tmp)) )
        row.names(retval) <- paste(format(row.names(retval)),
                                   format(names(sources)),
                                   sep=sep)
      else
        row.names(retval) <- rep(names(sources), mrows)

    retval
  }
is.what <- function(object, verbose=FALSE)
{
  do.test <- function(test, object)
  {
    result <- try(get(test)(object), silent=TRUE)
    if(!is.logical(result) || length(result)!=1)
      result <- NULL
    return(result)
  }

  ## Get all names starting with "is."
  is.names <- unlist(sapply(search(), function(name) ls(name,pattern="^is\\.")))

  ## Narrow to functions
  is.functions <- is.names[sapply(is.names, function(x) is.function(get(x)))]

  tests <- sort(unique(is.functions))
  results <- suppressWarnings(unlist(sapply(tests, do.test, object=object)))

  if(verbose)
  {
    results <- as.character(results)
    results[results=="TRUE"] <- "T"
    results[results=="FALSE"] <- "."
    output <- data.frame(is=results)
  }
  else
  {
    output <- names(results)[results]
  }

  return(output)
}

# $Id: keep.R,v 1.5 2005/06/09 14:20:24 nj7w Exp $

keep <- function(..., list=character(0), sure=FALSE)
{
  if(missing(...) && missing(list))
    stop("Keep something, or use rm(list=ls()) to clear workspace.")
  names <- as.character(substitute(list(...)))[-1]
  list <- c(list, names)
  keep.elements <- match(list, ls(1))

  if(sure == FALSE)
    return(ls(1)[-keep.elements])
  else
    rm(list=ls(1)[-keep.elements], pos=1)
}

ll <- function(pos=1, unit=c("KB","MB","bytes"), digits=0, dimensions=FALSE,
               function.dim="", sort.elements=FALSE, ...)
{
  get.object.classname <- function(object.name, pos)
  {
    object <- get(object.name, pos=pos)
    classname <- class(object)[1]
    return(classname)
  }

  get.object.dimensions <- function(object.name, pos)
  {
    object <- get(object.name, pos=pos)
    if(class(object)[1] == "function")
      dimensions <- function.dim
    else if(!is.null(dim(object)))
      dimensions <- paste(dim(object), collapse=" x ")
    else
      dimensions <- length(object)
    return(dimensions)
  }

  get.object.size <- function(object.name, pos)
  {
    object <- get(object.name, pos=pos)
    size <- try(object.size(object), silent=TRUE)
    if(class(size) == "try-error")
      size <- 0
    return(size)
  }

  unit <- match.arg(unit)
  denominator <- switch(unit, "KB"=1024, "MB"=1024^2, 1)

  if(is.character(pos))  # pos is an environment name
    pos <- match(pos, search())
  if(is.list(pos))  # pos is a list-like object
  {
    if(length(pos) == 0)
      return(data.frame())
    attach(pos, pos=2, warn.conflicts=FALSE)
    original.rank <- rank(names(pos))
    was.list <- TRUE
    pos <- 2
  }
  else
  {
    was.list <- FALSE
  }
  if(length(ls(pos,...)) == 0)  # pos is an empty environment
  {
    object.frame <- data.frame()
  }
  else if(search()[pos] == "Autoloads")  # pos is the autoload environment
  {
    object.frame <- data.frame(rep("function",length(ls(pos,...))),
                      rep(0,length(ls(pos,...))), row.names=ls(pos,...))
    if(dimensions)
    {
      object.frame <- cbind(object.frame, rep(function.dim,nrow(object.frame)))
      names(object.frame) <- c("Class", unit, "Dimensions")
    }
    else
      names(object.frame) <- c("Class", unit)
  }
  else
  {
    class.vector <- sapply(ls(pos,...), get.object.classname, pos=pos)
    size.vector <- sapply(ls(pos,...), get.object.size, pos=pos)
    size.vector <- round(size.vector/denominator, digits)
    object.frame <- data.frame(class.vector=class.vector,
                      size.vector=size.vector, row.names=names(size.vector))
    names(object.frame) <- c("Class", unit)
    if(dimensions)
      object.frame <- cbind(object.frame, Dim=sapply(ls(pos,...),
                        get.object.dimensions, pos=pos))
  }
  if(was.list)
  {
    detach(pos=2)
    if(!sort.elements)
      object.frame <- object.frame[original.rank, ]
  }

  return(object.frame)
}

# $Id: matchcols.R,v 1.4 2005/06/09 14:20:24 nj7w Exp $
# select the columns which match/don't match a set of include/omit patterns.

matchcols <- function(object, with, without, method=c("and","or"), ...)
  {
    method <- match.arg(method)
    cols <- colnames(object)

    # include columns matching 'with' pattern(s)
    if(method=="and")
      for(i in 1:length(with))
        {
          if(length(cols)>0)
            cols <- grep(with[i], cols, value=TRUE, ...)
        }
    else
      if(!missing(with))
        if(length(cols)>0)
          cols <- sapply( with, grep, x=cols, value=TRUE, ...)

    # exclude columns matching 'without' pattern(s)
    if(!missing(without))
      for(i in 1:length(without))
        if(length(cols)>0)
          {
            omit <- grep(without[i], cols, ...)
            if(length(omit)>0)
              cols <- cols[-omit]
          }

    cols
  }
# $Id: nobs.R,v 1.6 2005/06/09 14:20:24 nj7w Exp $

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

nobs.default <- function(x, ...) sum( !is.na(x) )

nobs.data.frame <- function(x, ...)
  sapply(x, nobs.default)

nobs.lm <- function(x, ...)
  nobs.default(x$residuals)
# $Id: read.xls.R,v 1.8 2005/06/09 14:20:24 nj7w Exp $

read.xls <- function(xls, sheet = 1, verbose=FALSE, ..., perl="perl")
  {

  # Creating a temporary function to quote the string
    dQuote.ascii <- function(x) paste('"',x,'"',sep='')

  ###
  # directories
  package.dir <- .path.package('gdata')
  perl.dir <- file.path(package.dir,'perl')
  #
  ###

  ###
  # files

  xls <- dQuote.ascii(xls) # dQuote.ascii in case of spaces in path
  xls2csv <- file.path(perl.dir,'xls2csv.pl')
  csv <- paste(tempfile(), "csv", sep = ".")
  #
  ###

  ###
  # execution command
  cmd <- paste(perl, xls2csv, xls, dQuote.ascii(csv), sheet, sep=" ")
  #
  ###

  ###
  # do the translation
  if(verbose)  cat("Executing ", cmd, "... \n")
  #
  results <- system(cmd, intern=!verbose)
  #
  if (verbose) cat("done.\n")
  #
  ###

  # prepare for cleanup now, in case of error reading file
  on.exit(file.remove(csv))  
  
  # now read the csv file
  out <- read.csv(csv, ...)

  # clean up
  file.remove(csv)
  
  return(out)
}
# $Id: rename.vars.R,v 1.7 2005/06/09 14:20:24 nj7w Exp $

rename.vars <- function(data,from='',to='',info=TRUE) {

   dsn <- deparse(substitute(data))
   dfn <- names(data)

   if ( length(from) != length(to)) {
     cat('--------- from and to not same length ---------\n')
     stop()
   }

   if (length(dfn) < length(to)) {
     cat('--------- too many new names ---------\n')
     stop()
   }

   chng <- match(from,dfn)

   frm.in <- from %in% dfn
   if (!all(frm.in) ) {
     cat('---------- some of the from names not found in',dsn,'\n')
     stop()
   }

   if (length(to) != length(unique(to))) {
     cat('---------- New names not unique\n')
     stop()
   }

   dfn.new <- dfn
   dfn.new[chng] <- to
   if (info) cat('\nChanging in',dsn)
   tmp <- rbind(from,to)
   dimnames(tmp)[[1]] <- c('From:','To:')
   dimnames(tmp)[[2]] <- rep('',length(from))
   if (info)
     {
       print(tmp,quote=FALSE)
       cat("\n")
     }
   names(data) <- dfn.new
   data
}


# GRW 2004-04-01
remove.vars <- function( data, names, info=TRUE)
  {
    for( i in names )
      {
        if(info)
          cat("Removing variable '", i, "'\n", sep="")
        data[[i]] <- NULL
      }
    data
  }
# $Id: reorder.R,v 1.7 2005/06/09 14:20:24 nj7w Exp $

# Reorder the levels of a factor.

reorder.factor <- function(x,
                           order,
                           X,
                           FUN,
                           sort=mixedsort,
                           make.ordered = is.ordered(x),
                           ... )
  {
    constructor <- if (make.ordered) ordered else factor

    if (!missing(order))
      {
        if (is.numeric(order))
          order = levels(x)[order]
        else
          order = order
      }
    else if (!missing(FUN))
      order = names(sort(tapply(X, x, FUN, ...)))
    else
      order = sort(levels(x))

    constructor( x, levels=order)

  }




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

trim <- function(s)
  {
    s <- sub("^ +","",s)
    s <- sub(" +$","",s)
    s
  }
# $Id: unmatrix.R,v 1.3 2005/06/09 14:20:24 nj7w Exp $

unmatrix <- function(x, byrow=FALSE)
  {
    rnames <- rownames(x)
    cnames <- colnames(x)
    if(is.null(rnames)) rnames <- paste("r",1:nrow(x),sep='')
    if(is.null(cnames)) cnames <- paste("c",1:ncol(x),sep='')
    nmat <- outer( rnames, cnames, paste, sep=":" )
    
    if(byrow)
      {
        vlist <- c(t(x))
        names(vlist) <- c(t(nmat))
      }
    else
      {
        vlist <- c(x)
        names(vlist) <- c(nmat)
      }

    return(vlist)
  }
upperTriangle <- function(x, diag=FALSE)
  {
    x[upper.tri(x, diag=diag)]
  }

"upperTriangle<-" <- function(x, diag=FALSE, value)
  {
    x[upper.tri(x, diag=diag)] <- value
    x
  }

lowerTriangle <- function(x, diag=FALSE)
  {
    x[lower.tri(x, diag=diag)]
  }

"lowerTriangle<-" <- function(x, diag=FALSE, value)
  {
    x[lower.tri(x, diag=diag)] <- value
    x
  }

