.packageName <- "cwhtool"
setPowerPointStyle <- function() {
    NORMAL <- 1
    BOLD <- 2
    par(font=BOLD);
    par(font.axis=BOLD);
    par(font.lab=BOLD);
    par(font.main=BOLD);
    par(font.sub=NORMAL);
    par(cex=1.2);
    par(cex.axis=1.2);
    par(cex.lab=1.2);
    par(cex.main=1.4);
    par(cex.sub=1.2);
    par(col="black");
    par(col.axis="black");
    par(col.lab="black");
    par(col.main="black");
    par(col.sub="black");
    par(lwd=2);
    par(pch=1);
    par(ps=12);
    par(tmag=1.2);
    par(mar=c(4, 3, 3, 1) + 0.1);
    par(mgp=c(1.5, 0.2, 0));
    par(tcl=0.3);
}

cbind.colnames <- function(add,to=NULL,deparse.level = 1)  {
  if (is.null(add)) to
  else if (is.null(to)) {
    first <- get(add[1])
    to    <- cbind(first,deparse.level)
    mode(to)  <- mode(first)
    class(to) <- class(first)
    res <- cbind.colnames(add[-1],to,deparse.level)[,-2] # kill col 2=deparse ??
    dimnames(res)[[2]][1] <- add[1]
    res
  }
  else {
    res <- to;  dimn2 <- dimnames(to)[[2]]
    for (ii in add) {
      res   <- cbind.data.frame(res,get(ii),deparse.level = deparse.level)
      dimn2 <- c(dimn2,ii)
    }
    dimnames(res)[[2]] <- dimn2
    res
  }
}

clean.na <- function (x,margin,drop=FALSE)  {
  ## clean a matrix of all rows (margin=1) or columns (margin=2) with NA, 2000.02.23, C.Hoffmann
  ind <- apply(x,margin,function(xx) all(!is.na(xx)))
  if (margin == 1)   x[ind,,drop=drop]
  else x[,ind,drop=drop]
}

delayt <- function(sec){
  start <- Sys.time()
  kk <- 0
  while (Sys.time() - start <= sec) {kk <- kk+1}
  kk
}
eql <- function(x,y) {
  if (length(x)>length(y)) y <- rep(y,,length(x)) else x <- rep(x,,length(y))
  ifelse(is.na(x),is.na(y),ifelse(is.na(y),FALSE,x==y))
}
libs <- function (Lib)
{
    if (missing(Lib))
        print(.packages(all = TRUE), q = FALSE)
    else eval(parse(text = paste("library(help=",
as.character(substitute(Lib)),")")))
}
like <- function(X,...){ 
    l <- list(...)
    n <- max(sapply(l, length))
    X <- X[rep(as.numeric(NA),n),]
    row.names(X) <- seq(length=n)
    for (nm in names(l)) X[[nm]][] <- l[[nm]]
    X
}

ls.functions <- function()
{
   x <- eval.parent(quote(ls()))
   x[sapply(x, function(x) typeof(get(x)) == "closure")]
}
# Agustin Lobo <alobo@ija.csic.es> writes:
# 
# > I am now using a for loop and applying
# > union() to each pair of vectors, but is
# > there a faster way avoiding the for ?
# 
# Not faster, I think. Maybe neater, using something like
# 
# lapply(seq(along=l1), function(i)union(l1[[i]],l2[[i]]))
# 
# or (with napply from an earlier post of mine)
# 
# napply(l1,l2,FUN=union)
# 
# where
# 
napply <- function(..., FUN) {
   x <- list(...)
   lens <- sapply(x,length)
   len <- max(lens)
   if (any(lens != len)) x <- lapply(x, rep, length=len)
   tuples <- lapply(seq(length=len), function(i)lapply(x,"[", i))
   lapply(tuples, function(t)eval(as.call(c(FUN,t))))
}
numberof <- function(x,f) { 
  sum(rep(1,length(x))[f(x)])
}
progress.meter <- function(i) {
  if (i==0) cat("\n      0")
  else if (i %% 50 == 0) cat("\n",formatFix(i,0,6))
  else if (i %% 10 == 0) cat((i %/% 10) %% 10)
  else if (i %%  5 == 0) cat("+")
  else cat(".");
#  else cat(".");
  invisible(NULL)
}
remove.dup.rows <- function(dfr) {
  o <- do.call("order",dfr)
#  isdup <- do.call("cbind",lapply(dfr[o,],function(x) eql(x,c(x[-1],NA))))
#  all.dup <- apply(isdup, 1, all)
  all.dup <- do.call("pmin",lapply(dfr[o,],function(x) eql(x,c(x[-1],NA))))
  all.dup[o] <- all.dup 
  dfr[!all.dup,]
}

##  i.e. sort the dataframe, figure out which rows have all values
##  identical to their successor. This gives logical vector, but in the
##  order of the sorted values, so reorder it. Finally select nondups. As
##  a "bonus feature", I think this will also remove any row containing all
##  NA's... 
##  
##  A major stumbling block is that you'll want two NAs to compare equal,
##  hence the eql() function.
##  
##  Actually, I think you can do away with the isdup array and do
##  
##  all.dup <- do.call("pmin",lapply(dfr[o,],function(x)eql(x,c(x[-1],NA))))
##  
##  and there may be further cleanups possible.
##  
##  One dirty trick which is much quicker but not quite as reliable is
##   
##  dfr[!duplicated(do.call("paste",dfr)),]
##  
##  (watch out for character strings with embedded spaces and underflowing
##  differences in numeric data!)
##  
"select.range" <- function (groupvec, min, max, data) {
  if (nargs() > 3) {
    min.cond <- groupvec >= min
    max.cond <- groupvec < max
    cond <- min.cond & max.cond
#    selected <- na.remove(ifelse(cond, data, NA))
#    invisible(selected)
    data[cond]
  }
  else cat("Usage: select.range(groupvec,min,max,datavec)\n")
}
"tri" <- function(a, f, m, symb = 2, grid = FALSE, ...)
{
	ta <- paste(substitute(a))
	tf <- paste(substitute(f))
	tm <- paste(substitute(m))
	
	tot <- 100/(a + f + m)
	b <- f * tot
	y <- b * .878
	x <- m * tot + b/2
	par(pty = "s")
	oldcol <- par("col")
	plot(x, y, axes = FALSE, xlab = "", ylab = "", xlim = c(-10, 110), ylim
		 = c(-10, 110), type = "n", ...)
        points(x,y,pch=symb)
	par(col = oldcol)
	trigrid(grid)
	text(-5, -5, ta)
	text(105, -5, tm)
	text(50, 93, tf)
	par(pty = "m")
	invisible()
}

"trigrid" <- function(grid = FALSE)
{
	lines(c(0, 50, 100, 0), c(0, 87.8, 0, 0))	#draw frame
	if(!grid) {
		for(i in 1:4 * 20) {
			lines(c(i, i - 1), c(0, 2 * .878))	#side a-c (base)
			lines(c(i, i + 1), c(0, 2 * .878))
			T.j <- i/2	#side a-b (left)
			lines(c(T.j, T.j + 2), c(i * .878, i * .878))
			lines(c(T.j, T.j + 1), c(i * .878, (i - 2) * .878))
			T.j <- 100 - i/2	#side b-c (right)
			lines(c(T.j, T.j - 2), c(i * .878, i * .878))
			lines(c(T.j, T.j - 1), c(i * .878, (i - 2) * .878))
		}
	}
	else {
		for(i in 1:4 * 20) {
# draw dotted grid
			lines(c(i, i/2), c(0, i * .878), lty = 4, col = 3)	#
			lines(c(i, (50 + i/2)), c(0, .878 * (100 - i)), lty = 4,
				col = 3)	# /
			lines(c(i/2, (100 - i/2)), c(i * .878, i * .878), lty
				 = 4, col = 3)	# -
		}
		par(lty = 1, col = 1)
	}
}
waitReturn <- function(ask=TRUE) {
  if (ask & interactive() & sink.number()==0) readline("\nType  <Return>\t to continue : ")
  invisible()
}
.First.lib <- function(lib, pkg) {
  require("cwhstring")
}
