.packageName <- "combinat"
"combn"<-
function(x, m, fun = NULL, simplify = TRUE, ...)
{
#       DATE WRITTEN: 14 April 1994          LAST REVISED:  10 July 1995
#       AUTHOR:  Scott Chasalow
#
#       DESCRIPTION:
#             Generate all combinations of the elements of x taken m at a time. 
#             If x is a positive integer,  returns all combinations
#             of the elements of seq(x) taken m at a time.
#             If argument "fun" is not null,  applies a function given
#             by the argument to each point.  If simplify is FALSE,  returns 
#             a list; else returns a vector or an array.  "..." are passed 
#             unchanged to function given by argument fun,  if any.
#       REFERENCE:
#             Nijenhuis, A. and Wilf, H.S. (1978) Combinatorial Algorithms for 
#             Computers and Calculators.  NY:  Academic Press.
#       EXAMPLES:
#             > combn(letters[1:4], 2)
#             > combn(10, 5, min)  # minimum value in each combination
#             Different way of encoding points:
#             > combn(c(1,1,1,1,2,2,2,3,3,4), 3, tabulate, nbins = 4)
#             Compute support points and (scaled) probabilities for a
#             Multivariate-Hypergeometric(n = 3, N = c(4,3,2,1)) p.f.:
#             > table.mat(t(combn(c(1,1,1,1,2,2,2,3,3,4), 3, tabulate,nbins=4)))
#
	if(length(m) > 1) {
		warning(paste("Argument m has", length(m), 
			"elements: only the first used"))
		m <- m[1]
	}
	if(m < 0)
		stop("m < 0")
	if(m == 0)
		return(if(simplify) vector(mode(x), 0) else list())
	if(is.numeric(x) && length(x) == 1 && x > 0 && trunc(x) == x)
		x <- seq(x)
	n <- length(x)
	if(n < m)
		stop("n < m")
	e <- 0
	h <- m
	a <- 1:m
	nofun <- is.null(fun)
	count <- nCm(n, m, 0.10000000000000002)
	out <- vector("list", count)
	out[[1]] <- if(nofun) x[a] else fun(x[a], ...)
	if(simplify) {
		dim.use <- NULL
		if(nofun) {
			if(count > 1)
				dim.use <- c(m, count)
		}
		else {
			out1 <- out[[1]]
			d <- dim(out1)
			if(count > 1) {
				if(length(d) > 1)
				  dim.use <- c(d, count)
				else if(length(out1) > 1)
				  dim.use <- c(length(out1), count)
			}
			else if(length(d) > 1)
				dim.use <- d
		}
	}
	i <- 2
	nmmp1 <- n - m + 1
	mp1 <- m + 1
	while(a[1] != nmmp1) {
		if(e < n - h) {
			h <- 1
			e <- a[m]
			j <- 1
		}
		else {
			h <- h + 1
			e <- a[mp1 - h]
			j <- 1:h
		}
		a[m - h + j] <- e + j
		out[[i]] <- if(nofun) x[a] else fun(x[a], ...)
		i <- i + 1
	}
	if(simplify) {
		if(is.null(dim.use))
			out <- unlist(out)
		else out <- array(unlist(out), dim.use)
	}
	out
}


"combn2"<-
function(x, n)
{
#   DATE WRITTEN:  14 April 1994           LAST REVISED:  14 April 1994
#   AUTHOR:  Scott D. Chasalow
#
#   DESCRIPTION:
#         Generate all combinations of the elements of x taken two at a time. 
#         If x is missing,  generate all combinations of 1:n taken two
#         at a time (that is,  the indices of x that would give all 
#         combinations of the elements of x if x with length n had been given).
#         Exactly one of arguments "x" and "n" should be given.
#
	if(!missing(x)) {
		if(!missing(n))
			warning(paste("Only one of arguments x and n allowed;", 
				"argument n was ignored"))
		n <- length(x)
	}
	else if(missing(n))
		stop("Arguments \"x\" and \"n\" both missing")
	if(length(n) > 1) {
		warning(paste("Argument n has", length(n), 
			"elements: only the first used"))
		n <- n[1]
	}
	if(n == 0)
		return(NULL)
	rmat <- array(seq(length = n), c(n, n))	# row(matrix(0,n,n))
	cmat <- t(rmat)	# col(matrix(0,n,n))
	lower.t <- rmat > cmat	# lower.tri(matrix(0,n,n))
	i1 <- cmat[lower.t]
	i2 <- rmat[lower.t]
	if(missing(x))
		cbind(i1, i2)
	else cbind(x[i1], x[i2])
}

"dmnom"<-
function(x, size = sum(x), prob = stop("no prob arg"))
{
#       DATE WRITTEN: 22 May 1995           LAST REVISED:  22 May 1995
#       AUTHOR:  Scott Chasalow
#
	p <- max(length(x), length(prob))
	x <- rep(x, length = p)
	prob <- rep(prob, length = p)
	prob <- prob/sum(prob)
	if(sum(x) != size)
		0
	else exp(logfact(size) + sum(x * log(prob) - logfact(x)))
}

"fact"<-
function(x)
gamma(x + 1)

"hcube"<-
function(x, scale, translation)
{
#   DATE WRITTEN:  24 April 1995          LAST REVISED:  1 May 1995
#   AUTHOR:  Scott D. Chasalow
#
#   DESCRIPTION:
#         Generate all points on a hypercuboid lattice. 
#         Argument x is an integer vector giving the extent of each dimension; 
#         the number of dimensions is length(x).  
#         Argument scale is a vector of real numbers giving an amount by which 
#         to multiply the points in each dimension;  it will be replicated as 
#         necessary to have the same length as x.
#         Argument translate is a vector of real numbers giving an amount to 
#         translate (from the "origin", rep(1,length(x))) the points in each 
#         dimension;  it will be replicated as necessary to have the same 
#         length as x.  To use rep(0,length(x)) as the origin,  use 
#         translation = -1.  Scaling,  if any,  is done BEFORE translation.
#
#   VALUE:
#         A prod(x) by length(x) numeric matrix;  element (i,j) gives the 
#         location of point i in the jth dimension.  The first column 
#         (dimension) varies most rapidly.
#
#   SEE ALSO:
#         fac.design,  expand.grid
#
	ncols <- length(x)
	nrows <- prod(x)
	cp <- c(1, cumprod(x)[ - ncols])
	out <- lapply(as.list(1:length(x)), function(i, a, b, nr)
	rep(rep(1:a[i], rep(b[i], a[i])), length = nr), a = x, b = cp, nr = 
		nrows)
	out <- array(unlist(out), c(nrows, ncols))
	if(!missing(scale)) {
		scale <- rep(scale, length = ncols)
		out <- sweep(out, 2, scale, FUN = "*")
	}
	if(!missing(translation)) {
		translation <- rep(translation, length = ncols)
		out <- sweep(out, 2, translation, FUN = "+")
	}
	out
}

"logfact"<-
function(x)
lgamma(x + 1)

"nCm"<-
function(n, m, tol = 9.9999999999999984e-009)
{
#  DATE WRITTEN:  7 June 1995               LAST REVISED:  10 July 1995
#  AUTHOR:  Scott Chasalow
#
#  DESCRIPTION: 
#        Compute the binomial coefficient ("n choose m"),  where n is any 
#        real number and m is any integer.  Arguments n and m may be vectors;
#        they will be replicated as necessary to have the same length.
#
#        Argument tol controls rounding of results to integers.  If the
#        difference between a value and its nearest integer is less than tol,  
#        the value returned will be rounded to its nearest integer.  To turn
#        off rounding, use tol = 0.  Values of tol greater than the default
#        should be used only with great caution, unless you are certain only
#        integer values should be returned.
#
#  REFERENCE: 
#        Feller (1968) An Introduction to Probability Theory and Its 
#        Applications, Volume I, 3rd Edition, pp 50, 63.
#
	len <- max(length(n), length(m))
	out <- numeric(len)
	n <- rep(n, length = len)
	m <- rep(m, length = len)
	mint <- (trunc(m) == m)
	out[!mint] <- NA
	out[m == 0] <- 1	# out[mint & (m < 0 | (m > 0 & n == 0))] <-  0
	whichm <- (mint & m > 0)
	whichn <- (n < 0)
	which <- (whichm & whichn)
	if(any(which)) {
		nnow <- n[which]
		mnow <- m[which]
		out[which] <- ((-1)^mnow) * Recall(mnow - nnow - 1, mnow)
	}
	whichn <- (n > 0)
	nint <- (trunc(n) == n)
	which <- (whichm & whichn & !nint & n < m)
	if(any(which)) {
		nnow <- n[which]
		mnow <- m[which]
		foo <- function(j, nn, mm)
		{
			n <- nn[j]
			m <- mm[j]
			iseq <- seq(n - m + 1, n)
			negs <- sum(iseq < 0)
			((-1)^negs) * exp(sum(log(abs(iseq))) - lgamma(m + 1))
		}
		out[which] <- unlist(lapply(seq(along = nnow), foo, nn = nnow, 
			mm = mnow))
	}
	which <- (whichm & whichn & n >= m)
	nnow <- n[which]
	mnow <- m[which]
	out[which] <- exp(lgamma(nnow + 1) - lgamma(mnow + 1) - lgamma(nnow - 
		mnow + 1))
	nna <- !is.na(out)
	outnow <- out[nna]
	rout <- round(outnow)
	smalldif <- abs(rout - outnow) < tol
	outnow[smalldif] <- rout[smalldif]
	out[nna] <- outnow
	out
}

"nsimplex"<-
function(p, n)
{
# DATE WRITTEN:  24 Dec 1997 		 LAST REVISED:  24 Dec 1997
# AUTHOR:  Scott D. Chasalow  (Scott.Chasalow@users.pv.wau.nl)
#
# DESCRIPTION:
#       Computes the number of points on a {p, n}-simplex lattice; that is, the
#	number of p-part compositions of n. This gives the number of points in
#	the support space of a Multinomial(n, q) distribution, where
#	p == length(q).
#
#	Arguments p and n are replicated as necessary to have the length of the
#	longer of them.
#
# REQUIRED ARGUMENTS:
#	p	vector of (usually non-negative) integers
#	n	vector of (usually non-negative) integers
# 
	mlen <- max(length(p), length(n))
	p <- rep(p, length = mlen)
	n <- rep(n, length = mlen)
	out <- nCm(n + p - 1, n)
	out[p < 0] <- 0
	out
}

"permn"<-
function(x, fun = NULL, ...)
{
# DATE WRITTEN: 23 Dec 1997          LAST REVISED:  23 Dec 1997
# AUTHOR:  Scott D. Chasalow (Scott.Chasalow@users.pv.wau.nl)
#
# DESCRIPTION:
#             Generates all permutations of the elements of x, in a minimal-
#	change order. If x is a	positive integer,  returns all permutations
#	of the elements of seq(x). If argument "fun" is not null,  applies
#	a function given by the argument to each point. "..." are passed
#	unchanged to the function given by argument fun, if any.
#
#	Returns a list; each component is either a permutation, or the
#	results of applying fun to a permutation.
#
# REFERENCE:
#	Reingold, E.M., Nievergelt, J., Deo, N. (1977) Combinatorial
#	Algorithms: Theory and Practice. NJ: Prentice-Hall. pg. 170.
#
# SEE ALSO:
#	sample, fact, combn, hcube, xsimplex
#
# EXAMPLE:
#	# Convert output to a matrix of dim c(6, 720)
#	t(array(unlist(permn(6)), dim = c(6, gamma(7))))
#
#	# A check that every element occurs the same number of times in each
#	# position
#	apply(t(array(unlist(permn(6)), dim = c(6, gamma(7)))), 2, tabulate, 
#		nbins = 6)
#
#	# Apply, on the fly, the diff function to every permutation
#	t(array(unlist(permn(6, diff)), dim = c(5, gamma(7))))
#
	if(is.numeric(x) && length(x) == 1 && x > 0 && trunc(x) == x) x <- seq(
			x)
	n <- length(x)
	nofun <- is.null(fun)
	out <- vector("list", gamma(n + 1))
	p <- ip <- seqn <- 1:n
	d <- rep(-1, n)
	d[1] <- 0
	m <- n + 1
	p <- c(m, p, m)
	i <- 1
	use <-  - c(1, n + 2)
	while(m != 1) {
		out[[i]] <- if(nofun) x[p[use]] else fun(x[p[use]], ...)
		i <- i + 1
		m <- n
		chk <- (p[ip + d + 1] > seqn)
		m <- max(seqn[!chk])
		if(m < n)
			d[(m + 1):n] <-  - d[(m + 1):n]
		index1 <- ip[m] + 1
		index2 <- p[index1] <- p[index1 + d[m]]
		p[index1 + d[m]] <- m
		tmp <- ip[index2]
		ip[index2] <- ip[m]
		ip[m] <- tmp
	}
	out
}

"rmultinomial"<-
function(n, p, rows = max(c(length(n), nrow(p))))
{
# 19 Feb 1997 (John Wallace, 17 Feb 1997 S-news)
# Generate random samples from multinomial distributions, where both n
# and p may vary among distributions
#
# Modified by Scott Chasalow
#
	rmultinomial.1 <- function(n, p)
	{
		k <- length(p)
		tabulate(sample(k, n, replace = TRUE, prob = p), nbins = k)
	}
	#assign("rmultinomial.1", rmultinomial.1)#, frame = 1)
	n <- rep(n, length = rows)
	p <- p[rep(1:nrow(p), length = rows),  , drop = FALSE]
	#assign("n", n)#, frame = 1)
	#assign("p", p)#, frame = 1)
	t(apply(matrix(1:rows, ncol = 1), 1, function(i)
	rmultinomial.1(n[i], p[i,  ])))
}

"rmultz2"<-
function(n, p, draws = length(n))
{
# 19 Feb 1997: From s-news 14 Feb 1997, Alan Zaslavsky
# 11 Mar 1997: Modified by Scott D. Chasalow
#
# Generate random samples from a multinomial(n, p) distn: varying n, 
# fixed p case.
#
	n <- rep(n, length = draws)
	lenp <- length(p)
	tab <- tabulate(sample(lenp, sum(n), TRUE, p) + lenp * rep(1:draws - 1, n),
		nbins = draws * lenp)
	dim(tab) <- c(lenp, draws)
	tab
}

"x2u"<-
function(x, labels = seq(along = x))
{
#  DATE WRITTEN:  21 January 1994       LAST REVISED:  21 January 1994
#  AUTHOR:  Scott Chasalow
#
#  DESCRIPTION:
#        Convert an x-encoded simplex-lattice point to a u-encoded
#        simplex-lattice point  (equivalently,  "untabulate" bin counts)
#
#  USAGE:
#        x2u(x)
#
#  ARGUMENTS:
#  x:    A numeric vector.  x[i] is interpreted as the count in bin i.
#  labels:  A vector.  Interpreted as the bin labels;  default value is
#        seq(along = x), which causes return of a u-encoded simplex-lattice 
#        point.  Other values of labels cause return of the result of 
#        subscripting labels with the u-encoded simplex-lattice point that 
#        would have been obtained if the default value of labels were used.
#
#        Arguments x and labels must be of equal length.
#
#  VALUE:
#        rep(labels, x), a vector of length sum(x).  If labels = seq(along = x)
#        (the default),  value is the u-encoded translation of the simplex 
#        lattice point, x.  Equivalently,  value gives the bin numbers, 
#        in lexicographic order,  for the objects represented by the counts in 
#        x.  For other values of argument "labels", value gives the bin labels 
#        for the objects represented by the counts in x (equivalent to 
#        labels[x2u(x)]).
#
#  SEE ALSO:
#        tabulate,  rep
#
	if(length(labels) != length(x)) stop(
			"Arguments x and labels not of equal length")
	rep(labels, x)
}

"xsimplex"<-
function(p, n, fun = NULL, simplify = TRUE, ...)
{
#       DATE WRITTEN: 11 February 1992          LAST REVISED:  10 July 1995
#       AUTHOR:  Scott Chasalow
#
#       DESCRIPTION:
#             Generates all points on a {p,n} simplex lattice (i.e. a p-part 
#             composition of n).  Each point is represented as x, a 
#             p-dimensional vector of nonnegative integers that sum to n.
#             If argument "fun" is not null,  applies a function given
#             by the argument to each point.  If simplify is FALSE,  returns 
#             a list; else returns a vector or an array.  "..." are passed 
#             unchanged to function given by argument fun,  if any.
#       EXAMPLE:
#             Compute Multinomial(n = 4, pi = rep(1/3, 3)) p.f.:
#             xsimplex(3, 4, dmnom, prob=1/3) 
#
	if(p < 1 || n < 0) return(if(simplify) numeric(0) else list())
	p1 <- p - 1
	x <- numeric(p)
	x[1] <- n
	nofun <- is.null(fun)
	out <- if(nofun) x else fun(x, ...)
	if(p == 1 || n == 0) {
		return(if(simplify) out else list(out))
	}
	count <- nCm(n + p - 1, n)
	if(simplify) {
		dim.use <- NULL
		if(nofun) {
			if(count > 1)
				dim.use <- c(p, count)
		}
		else {
			d <- dim(out)
			if(count > 1) {
				if(length(d) > 1)
				  dim.use <- c(d, count)
				else if(length(out) > 1)
				  dim.use <- c(length(out), count)
			}
			else if(length(d) > 1)
				dim.use <- d
		}
	}
	out <- vector("list", count)
	target <- 1
	i <- 0
	while(1) {
		i <- i + 1
		out[[i]] <- if(nofun) x else fun(x, ...)
		x[target] <- x[target] - 1
		if(target < p1) {
			target <- target + 1
			x[target] <- 1 + x[p]
			x[p] <- 0
		}
		else {
			x[p] <- x[p] + 1
			while(x[target] == 0) {
				target <- target - 1
				if(target == 0) {
				  i <- i + 1
				  out[[i]] <- if(nofun) x else fun(x, ...)
				  if(simplify) {
				    if(is.null(dim.use))
				      out <- unlist(out)
				    else out <- array(unlist(out), dim.use)
				  }
				  return(out)
				}
			}
		}
	}
}

