"make.ftp" <- 
function(fun = T, data = T, world = T)
{
	if(fun) {
		dump(dump.fun.list, "dump.fun.S")
	}
	if(data) {
		dump(dump.data.list, "dump.data.S")
	}
	if(world) {
		# dump world data set separately beacsue it is so big
		dump("world.dat", "dump.world.S")
	}
	invisible()
}

"make.qfiles" <- 
function(names = dump.fun.list)
{
	for(fun in names) {
		dump(fun, paste("funs/", fun, ".q", sep = ""))
		cat(fun, " ", fill = T)
	}
	cat(" all done!", fill = T)
}

"make.surface" <- 
function(x, y, FUN, ...)
{
	if(is.numeric(FUN)) {
		cat("Assuming that the x and y values are irregular the function\nvalues on a grid will be computed by interpolation",
			fill = T)
		return(interp(x, y, FUN, ...))
	}
	if(!is.function(FUN) & !is.character(FUN)) {
		stop("the equation must either be an S function or\na formula in quotes"
			)
	}
	if(is.character(FUN)) {
		xs <- as.character(substitute(x))
		ys <- as.character(substitute(y))
		fc <- paste(xs, ",", ys)
		cat(xs, ys, fill = T)
		new.fun <- #		print(new.fun)
		eval(parse(text = paste("function(", fc, ",...){", FUN, "}")))
	}
	else {
		new.fun <- FUN
	}
	cat("Evaluating the formula on the grid formed from x and y", fill = T)
	list(x = x, y = y, z = outer(x, y, FUN = new.fun, ...), FUN = new.fun)
}

"masked.men" <- 
function(dir = 1., ignore = NA)
{
	cat("Checking data sets to see if any have the same name as S data sets",
		fill = T)
	# Some data sets should be ignored because they should be kept in users
	# directory
	#
	hold <- masked(dir)
	if(is.null(hold))
		hold <- NA
	if(!is.na(ignore[1.]) & !is.na(hold[1.])) {
		hold <- hold[is.na(match(hold, ignore))]
		if(length(hold) == 0.)
			hold <- NA
	}
	if(!is.na(hold[1.])) {
		cat("The following data sets match names used by S", fill = T)
		cat(hold, fill = T)
		cat(" to avoid confusion you might copy these datasets to \nanother name and delete the old version",
			fill = T)
	}
	invisible()
}

"mean.machine" <- 
function(y, group)
{
	if(missing(group))
		return(rep(mean(y), length(y)))
	lm(y ~ as.character(group))$fitted.values
}

"means" <- 
function(y, ..., dec = 3.)
{
	####  dec controls number of decimal places
	temp <- list(...)
	locall <- sys.call()
	nvar <- ####  one-way means
	length(temp)
	cat(" ", fill = T)
	for(k in 1.:nvar) {
		cat("Mean of Y variable", locall[2.], "by X variable", locall[
			k + 2.], fill = T)
		cat(" ", fill = T)
		ord <- order(temp[[k]])
		temp.ord <- temp[[k]][ord]
		y.ord <- y[ord]
		print(round(stats(y.ord, by = temp.ord, no.print = T)[1.:3.,
			], dec))
		cat("******************************", fill = T)
	}
	cat("Note: in the following, if sample sizes are not equal\n")
	####  two-way means
	cat("row and col means will not be the average of cell means.\n\n")
	if(nvar > 2.)
		for(k in 1.:(nvar - 1.)) {
			for(j in (k + 1.):nvar) {
				cat("Mean of Y Variable", locall[2.], 
					"by X variables", locall[k + 2.], "and",
					locall[j + 2.], fill = T)
				cat(" ", fill = T)
				print(means.2way(y, temp[[k]], temp[[j]]),
					dec = dec)
				cat("******************************", fill = T)
			}
		}
	else cat("Mean of Y variable", locall[2.], "by X variables", locall[
			3.], "and", locall[4.], fill = T)
	if(nvar == 2.)
		means.2way(y, temp[[1.]], temp[[2.]], dec = dec)
}

"means.2way" <- 
function(y, a, b, dec = 3.)
{
	ord <- order(a, b)
	a <- a[ord]
	b <- b[ord]
	y <- y[ord]
	rlab <- unique(a)
	rlab <- as.character(rlab)
	clab <- unique(b)
	clab <- as.character(clab)
	temp <- stats(y, by = paste(a, b), no.print = T)
	temp2 <- temp[2.,  ]
	temp3 <- matrix(temp2, ncol = length(clab), nrow = length(rlab), byrow
		 = T)
	temp3 <- cbind(temp3, stats(y, by = a, no.print = T)[2.,  ])
	temp3 <- rbind(temp3, c(stats(y, by = b, no.print = T)[2.,  ], mean(
		y)))
	dimnames(temp3) <- list(c(rlab, "Col Mean"), c(clab, "Row Mean"))
	round(temp3, dec)
}

"message" <- 
function(txt)
{
	tf <- tempfile()
	write(txt, file = tf, ncol = 1.)
	unix(paste("cat ", tf), output = F)
	invisible()
}

"mklevel" <- 
function(x, y, z, p = c(0.10000000000000001, 0.25, 0.5, 0.75, 
	0.90000000000000002))
{
	p <- 1. - p
	n <- length(x)
	qx <- c(x[2.] - x[1.], x[3.:n] - x[2.:(n - 1.)], x[n] - x[n - 1.])/
		2.
	n <- length(y)
	qy <- c(y[2.] - y[1.], y[3.:n] - y[2.:(n - 1.)], y[n] - y[n - 1.])/
		2.
	qxy <- outer(qx, qy)
	it <- order(z)
	temp <- z[it] * qxy[it]
	temp <- cumsum(temp)/sum(temp)
	z <- z[it]
	levels <- rep(NA, length(p))
	for(k in 1.:length(p)) {
		levels[k] <- min(z[(temp > p[k])])
	}
	list(p = 1. - p, levels = levels)
}

"mplot" <- 
function(y, ..., both = F)
{
	temp <- list(...)
	locall <- # to get variable names
	sys.call()
	locall <- as.character(locall)
	nvar <- length(temp)
	if(nvar == 2.)
		set.panel(2., 1.)
	else if(nvar == 3.)
		set.panel(3., 1.)
	else set.panel(3., 2.)
	if(nvar > 2.)
		for(k in 1.:(nvar - 1.)) {
			for(j in (k + 1.):nvar) {
				interaction.plot(temp[[k]], temp[[j]], y, xlab
					 = locall[k + 2.], trace.label = locall[
					j + 2.], ylab = locall[2.])
				title("Mean of Y for values of X1 (x axis) and \n X2 (diff. line types)"
					)
			}
		}
	else interaction.plot(temp[[1.]], temp[[2.]], y, xlab = locall[3.],
			trace.label = locall[4.], ylab = locall[2.])
	title("Mean of Y for values of X1 (x axis) and \n X2 (diff. line types)"
		)
	if(both)
		interaction.plot(temp[[2.]], temp[[1.]], y, xlab = locall[
			4.], trace.label = locall[3.], ylab = locall[2.])
	if(both)
		title("Mean of Y for values of X2 (x axis) and \n X1 (diff. line types)"
			)
}

"nplot" <- 
function(x, ylab = "Quantiles of Standard Normal", xlab = deparse(substitute(
	x)), full = T, ...)
{
	out <- is.na(x)
	if(any(out)) {
		x <- x[!out]
	}
	n <- length(x)
	if(full) {
		y <- qnorm((rank(x) - 0.5)/n)
	}
	else {
		x <- abs(x)
		y <- qhnorm((rank(x) - 0.5)/n)
	}
	plot(x, y, xlab = xlab, ylab = ylab, ...)
	if(is.null(names(x)))
		names(x) <- format(1.:length(x))
	text(x, y, names(x), adj = 0.)
}

"pbinom" <- 
function(q, N, p)
{
	size <- N
	prob <- p
	p <- .Internal(pbinom(q, par1 = size, par2 = prob), "S_pfuns", T, 14)
	if(!is.null(Names <- names(q)))
		names(p) <- rep(Names, length = length(p))
	p
}

"pexp" <- 
function(x, gamma = 1., beta = 1.)
{
	if(missing(gamma)) {
		gamma <- beta
	}
	1. - exp( - x/gamma)
}

"pgam" <- 
function(x, alpha, beta = 1.)
{
	pgamma(x/beta, alpha)
}

"plot.window" <- 
function(screen.name)
{
	plt <- T
	look <- getenv("DISPLAY")
	if((look == "") & missing(screen.name)) {
		cat("You can not do graphics from a terminal \nwindow ", fill
			 = T)
		plt <- F
	}
	if(plt) {
		# begin setup for open look window 
		cat(" Trying to open a motif style plot window on your screen ...",
			fill = T)
		if(missing(screen.name))
			screen.name <- look
		cat("S thinks that the name of your screen is", screen.name,
			fill = T)
		motif(c(.motif.options, paste("-d ", screen.name)))
		vu(c(".CE", "S Lab Graphics Window"))
	}
	plt
	invisible()
}

"pico" <- 
function(data, file)
{
	if(missing(data))
		ed(editor = "pico")
	else if(missing(file))
		ed(data, editor = "pico")
	else ed(data, file, editor = "pico")
}

"poker" <- 
function(draw = 5., hand = 1.)
{
	if(draw * hand > 52.)
		stop("too many hands for a 52 card deck")
	temp <- cards[rperm(1.:52.)[1.:(draw * hand)]]
	if(hand > 1.) {
		#		dimnames(temp) <- list(c(outer("hand", format(1:hand), paste), NULL)
		temp <- matrix(temp, ncol = draw, nrow = hand)
	}
	temp
}

"power.exp" <- 
function(beta, n, beta.zero = 1., prob = 0.050000000000000003)
{
	# find the cutoff for rejection region:
	alpha <- n
	# use c to evaluate the power curve
	c <- qgam(1. - prob, alpha, beta.zero)
	power <- 1. - # return the power curve
	pgam(c/beta, alpha)
	# for more detailed output one could return a list of 
	# several vectors: 
	# list( x= beta, y=power, c= c)  
	power
}

"power.exp.2" <- 
function(beta, n, beta.zero = 1., prob = 0.050000000000000003)
{
	# find the cutoffs for rejection region:
	alpha <- n
	c1 <- qgam(prob/2., alpha, beta.zero)
	# use c1 and c2 to evaluate the power curve
	c2 <- qgam(1. - prob/2., alpha, beta.zero)
	# return the power curve
	power <- 1. - pgam(c2/beta, alpha) + pgam(c1/beta, alpha)
	#                                    
	# for more detailed output one could return a list of 
	# several vectors: 
	# list( x= beta, y=power, c= c(c1,c2))  
	power
}