.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 625 2005-06-09 14:20:30Z nj7w $

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 625 2005-06-09 14:20:30Z nj7w $

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) )
  }
## combineLevels.R
###------------------------------------------------------------------------
## What: Joint levels of given factors
## $Id: combineLevels.R,v 1.1 2006/04/08 01:58:36 ggorjan Exp $
## Time-stamp: <2006-04-08 03:57:53 ggorjan>
###------------------------------------------------------------------------

combineLevels <- function(x, apply=TRUE, drop=FALSE)
{
  if (!is.factor(x)) {
    if (sum(!(c("data.frame", "list") %in% class(x))) == 2)
      stop(paste(sQuote("x"), "must be a", dQuote("data.frame"), "or a", dQuote("list")))
    if (any(!(unlist((lapply(x, is.factor))))))
      stop(paste("only", dQuote("factors"), "are supported"))
    if (drop) x <- lapply(x, factor)
    levs <- sort(unique(unlist(lapply(x, levels))))
    if (!apply) return(levs)
    return(lapply(x, "levels<-", mapFactor(levs, codes=FALSE)))
  }
  if (drop) x <- factor(x)
  if (!apply) return(levels(x))
  return(x)
}

###------------------------------------------------------------------------
## combineLevels.R ends here

drop.levels  <- function(x, reorder=TRUE, ...)
  UseMethod("drop.levels")

drop.levels.default <- function(x, reorder=TRUE, ...)
  return(x)

drop.levels.factor <- function(x, reorder=TRUE, ...)
{
  x <- factor(x)
  if(reorder) x <- reorder(x, ...)
  return(x)
}

drop.levels.list <- function(x, reorder=TRUE, ...)
{
  return(lapply(x, drop.levels, reorder=reorder, ...))
}

drop.levels.data.frame <- function(x, reorder=TRUE, ...)
{
  x[] <- drop.levels.list(x, reorder=reorder, ...)
  return(x)
}
# $Id: elem.R 625 2005-06-09 14:20:30Z nj7w $

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 625 2005-06-09 14:20:30Z nj7w $

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 625 2005-06-09 14:20:30Z nj7w $
#
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 789 2005-12-08 20:18:15Z warnes $

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 625 2005-06-09 14:20:30Z nj7w $

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)
}

## mapFactor.R
###------------------------------------------------------------------------
## What: Get a map of levels in a factor
## $Id: mapFactor.R,v 1.1 2006/03/29 13:47:15 ggorjan Exp ggorjan $
## Time-stamp: <2006-04-06 01:35:30 ggorjan>
###------------------------------------------------------------------------

mapFactor <- function(x, codes=TRUE, sort=TRUE, drop=FALSE, ...)
{
  ## --- Check ---
  msg <- "x must be a factor or character"
  if (!is.factor(x)) {
    if (!is.character(x)) stop(msg)
  }

  ## --- Create a map ---
  if (is.factor(x)) { # factor
    if (drop) x <- factor(x)
    nlevs <- nlevels(x)
    levs <- levels(x)
    if (sort) levs <- sort(levs, ...)
  } else {            # character
    levs <- unique(x)
    if (sort) levs <- sort(levs, ...)
    nlevs <- length(levs)
  }
  tmp <- vector("list", nlevs)
  names(tmp) <- levs
  if (codes) {
    tmp[1:nlevs] <- 1:nlevs
  } else {
    tmp[1:nlevs] <- levs
  }
  return(tmp)
}

###------------------------------------------------------------------------
## mapFactor.R ends here
# $Id: matchcols.R 625 2005-06-09 14:20:30Z nj7w $
# 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 625 2005-06-09 14:20:30Z nj7w $

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 625 2005-06-09 14:20:30Z nj7w $

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 625 2005-06-09 14:20:30Z nj7w $

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 625 2005-06-09 14:20:30Z nj7w $

# 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)

  }




## The S/R 'sample' function behaves differently if it is passed a
## sampling vector of length 1 than if it is passed a
## vector of length greater than 1.  For the 1-element
## case it samples from the list 1:x, instead of from the contents
## of x.  This function remove the special case: it always samples from
## the provided argument, no matter the length.
resample <- function(x, size, replace = FALSE, prob = NULL)
  {
    if(length(x)<1)
      if(!missing(size) && size>0)
        stop("Requested sample of size ", size, " from list of length 0")
      else
        x[FALSE]
    else if(length(x)==1)
      {
        if(missing(size) || size==1)
          x
        else if(size>=1 && replace==TRUE)
          rep(x, size)
        else if(size < 1)
          x[FALSE]
        else
          stop("Cannot cannot take a sample larger than the population",
               " when 'replace = FALSE'")
      }
    else
      sample(x, size, replace, prob)
  }
# $Id: trim.R 973 2006-08-02 19:04:55Z warnes $

trim <- function(s)
  UseMethod("trim", s)

trim.default <- function(s)
  return(s)

trim.character <- function(s)
{
  s <- sub(pattern="^ +", replacement="", x=s)
  s <- sub(pattern=" +$", replacement="", x=s)
  return(s)
}

trim.factor <- function(s)
{
  levels(s) <- trim(levels(s))
  return(s)
}

trim.list <- function(s)
  return(lapply(s, trim))

trim.data.frame <- function(s)
{
  s[] <- trim.list(s)
  return(s)
}
# $Id: unmatrix.R 625 2005-06-09 14:20:30Z nj7w $

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
  }

