"make.dump.files" <- 
function(NF = 5., ND = 4.)
{
	slab.version[4.] <<- stamp()
	N <- length(dump.fun.list)
	if(NF > 1.) {
		m <- floor(N/NF)
		nn <- (0.:(NF - 1.)) * m + 1.
		n1 <- nn
		n2 <- c(nn[-1.] - 1., N)
	}
	else {
		n1 <- 1.
		n2 <- N
	}
	for(k in 1.:NF) {
		rg <- n1[k]:n2[k]
		dump(dump.fun.list[rg], paste("dfun", k, ".q", sep = ""))
		cat(dump.fun.list[rg], fill = T)
	}
	N <- length(dump.data.list)
	if(ND > 1.) {
		m <- floor(N/ND)
		nn <- (0.:(ND - 1.)) * m + 1.
		n1 <- nn
		n2 <- c(nn[-1.] - 1., N)
	}
	else {
		n1 <- 1.
		n2 <- N
	}
	for(k in 1.:ND) {
		rg <- n1[k]:n2[k]
		dump(dump.data.list[rg], paste("ddata", k, ".q", sep = ""))
		cat(dump.data.list[rg], fill = T)
	}
	invisible()
}

"predict.new" <- 
function(obj, ...)
{
	xnew <- list(...)
	if(length(xnew) == 1.) {
		xnew <- xnew[[1.]]
	}
	xnew <- data.frame(xnew)
	hold <- predict(obj, xnew, se = T)
	hold$se.single <- sqrt(hold$se.fit^2. + hold$residual.scale^2.)
	data.frame(xnew, hold)
}

".motif.options" <- 
c("-geometry +0+0", "-xrm 'sgraphMotif*canvas.width:500'", 
	"-xrm 'sgraphMotif*canvas.height:718'", 
	"-xrm 'sgraphMotif*printorientation*state: 1'", 
	"-xrm 'sgraphMotif*colors:   black  white'", 
	"-xrm  'sgraphMotif*printOrientLandscape.set : False'", 
	" -xrm 'sgraphMotif*printOrientPortrait.set : True'", "")

".xxx" <- 
function(x)
{
	(pnorm(x, mean = 1., sd = 0.5) * 0.29999999999999999 + pnorm(x, mean = 
		4., sd = 1.2))/1.3
}

"F.table" <- 
function(alpha, n1, n2)
{
	qf(1. - alpha, n1, n2)
}

"area.curve" <- 
function(x, y, a = NA, b = NA, N = 200., ...)
{
	ind <- order(x)
	x <- x[ind]
	y <- y[ind]
	xs <- seq(min(x), max(x),  , N)
	#ys <- spreg(x, y, 0, xgrid = xs)$predicted[, 2]
	ys <- spline.interp(x, y, xgrid = xs)$y
	#points(x, y, pch = "o")
	plot(xs, ys, type = "l", main = " Density function", xlab = "X", ylab
		 = "Y", ...)
	lines(c(xs[1.], xs[1.]), c(min(ys), ys[1.]))
	lines(c(xs[N], xs[N]), c(min(ys), ys[N]))
	lines(c(xs[1.], xs[N]), c(min(ys), min(ys)))
	if(is.na(a)) {
		cat(" Using the mouse locate two points on the X-axis to define\nthe area. Click on the left button to record each of your choices.",
			fill = T)
		x1 <- locator(1.)$x
		#		lines(c(x1, x1), c(min(y), spreg(x, y, 0, xgrid = x1)$predicted[
		#			1, 2]))
		xline(x1)
		x2 <- locator(1.)$x
		#lines(c(x2, x2), c(min(y), spreg(x, y, 0, xgrid = x2)$predicted[ 1, 2]))
		#lines(spreg(x, y, 0, xgrid = x2)$predicted)
		xline(x2)
		cat("Identified X values are", x1, "and", x2, fill = T)
	}
	else {
		x1 <- a
		x2 <- b
	}
	if(x1 > x2) {
		tmp <- x1
		x1 <- x2
		x2 <- tmp
	}
	ax <- seq(x1, x2,  , N)
	ay <- spline.interp(x, y, xgrid = ax)$y
	polygon(c(ax[1.], ax, ax[N]), c(min(ys), ay, min(ys)), density = 8.)
	area <- ay[1.] * 0.5 + sum(ay[2.:(N - 1.)]) + 0.5 * ay[N]
	area <- (area * (x2 - x1))/N
	cat(" Calculated area: ", area, fill = T)
	area
}

"attach.slab" <- 
function()
{
	attach("/ncsu/S-Mode/slab2.0/.Data")
	cat("SLab functions and datasets have been added", fill = T)
	invisible()
}

"bplot" <- 
function(x, ..., xpos = NA, width, label, by, srt = 0., add = F, space = 0.25,
	sort.names = T, xlab = "", ylab = "")
{
	# Draws Horizontal Boxplots. Andreas Krause, Dec 1991.
	# Doug Nychka April 28, 1992
	if(is.matrix(x)) data <- data.frame(x)
	if(data.class(x) == "numeric")
		data <- list(x, ...)
	if(is.list(x))
		data <- x
	# at this point the data should be in list form regradless of how the
	# pieces were originally passed
	if(!missing(by)) data <- cat.to.list(unlist(data), by)
	quant <- c(0.050000000000000003, 0.25, 0.5, 0.75, 0.94999999999999996)
	cols <- length(data)
	range.data <- range(as.numeric(unlist(data)), na.rm = T)
	if(is.na(xpos)) {
		xpos <- 1.:cols
	}
	if(missing(width)) {
		width <- min(diff(sort(xpos))) * space
		if(cols == 1.)
			width <- space
	}
	if(length(width) == 1.)
		width <- rep(width, cols)
	if(!add) {
		plot(range(c(xpos - (0.5 * width)/space, xpos + (0.5 * width)/
			space)), range.data, type = "n", xaxt = "n", ylab = 
			ylab, xlab = xlab)
	}
	for(i in 1.:cols) {
		temp <- data[[i]]
		temp <- temp[!is.na(temp)]
		bb <- quantile(temp, quant)
		#  i - 0.5
		mid <- xpos[i]
		low <- mid - width[i] * 0.5
		high <- mid + width[i] * 0.5
		if(length(temp) > 5.) {
			y <- c(bb[1.], bb[1.], NA, bb[1.], bb[2.], NA, bb[
				2.], bb[2.], bb[4.])
			x <- c(high, low, NA, mid, mid, NA, high, low, low)
			y <- c(y, bb[4.], bb[2.], bb[3.], bb[3.], NA, bb[4.],
				bb[5.], bb[5.], bb[5.])
			x <- c(x, high, high, high, low, NA, mid, mid, high,
				low)
			lines(x, y)
		}
		if(length(temp) > 5.) {
			outlier <- temp[(temp < bb[1.]) | (temp > bb[5.])]
		}
		else outlier <- temp
		olen <- length(outlier)
		if(olen > 0.)
			points(rep(mid, olen), outlier)
	}
	if(missing(label)) {
		if(is.null(names(data)))
			label <- format(1.:cols)
		else label <- names(data)
	}
	if(length(label) > 10.)
		srt <- 90.
	axis(1., xpos, label, tick = F, srt = srt)
}

"cat.to.list" <- 
function(x, a)
{
	a <- as.character(a)
	label <- unique(a)
	out <- as.list(1.:length(label))
	names(out) <- label
	for(k in 1.:length(label)) {
		out[[k]] <- x[label[k] == a]
	}
	out
}

"count" <- 
function(x)
{
	length(x[x == T])
}

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

"demo.density.2d" <- 
function(den)
{
	split.screen(c(2., 2.))
	screen(1.)
	#	contour(den)
	persp(den, cex = 0.5, xlab = "X", ylab = "Y", zlab = "density")
	title(" 2D density function", cex = 0.80000000000000004)
	#contour(den, levels = den$levels, labex = 0, xlab = "X", ylab = "Y")
	screen(2.)
	contour(den, nint = 7., labex = 0.10000000000000001, xlab = "X", ylab
		 = "Y")
	nx <- length(den$x)
	ny <- length(den$y)
	dx <- den$x[2.] - den$x[1.]
	dy <- den$y[2.] - den$y[1.]
	xmar <- den$z %*% rep(1., ny)
	ymar <- t(den$z) %*% rep(1., nx)
	ymar <- ymar/(sum(ymar) * dy)
	xmar <- xmar/(sum(xmar) * dx)
	screen(3.)
	plot(den$y, ymar, type = "l", xlab = "y", ylab = "f(y)")
	title(" Marginal density for the Y variable", cex = 0.5)
	#	print(diag(1/xmar, nrow = length(xmar), ncol = length(ymar)))
	screen(4.)
	yc <- (t(den$z) %*% diag(1./xmar, nrow = length(xmar), ncol = length(
		ymar)))/dy
	cat(range(den$y), range(yc), fill = T)
	plot(range(den$y), range(yc), type = "n", xlab = "y", ylab = "f(y|X)")
	title(" Conditional density of Y given X", cex = 0.5)
	cat(" Click  with left button on the X-axis of the contour plot to select slices",
		fill = T)
	hold <- list(y = -999.)
	cat(" Use the middle button to exit", fill = T)
	for(k in 1.:100.) {
		screen(2., new = F)
		hold <- NULL
		hold <- locator(1.)
		if(is.null(hold$x)) {
			break
		}
		xline(hold$x)
		x <- hold$x
		indx <- order(abs(x - den$x))[1.]
		screen(4., new = F)
		y.g.x <- yc[, indx]
		lines(den$y, y.g.x, type = "l")
		text(den$y[max(y.g.x) == y.g.x], max(y.g.x) * 1.05, paste(
			"X=", format(signif(x, digits = 2.))), cex = 0.5)
	}
	close.screen(all = T)
	invisible()
}

"demo.gamma" <- 
function()
{
	set.panel(2., 2.)
	cat("Some examples of the gamma family", fill = T)
	cat("Scale parameter has been chosen so that the distributions", fill
		 = T)
	cat(" have a variance of one", fill = T)
	alpha <- seq(1., 10.,  , 15.)
	beta <- 1./sqrt(alpha)
	x <- seq(0.01, 6.,  , 40.)
	z <- matrix(NA, ncol = 15., nrow = 40.)
	pz <- matrix(NA, ncol = 15., nrow = 40.)
	for(k in 1.:15.) {
		z[, k] <- dgam(x, alpha = alpha[k], beta = beta[k])
		pz[, k] <- pgam(x, alpha = alpha[k], beta = beta[k])
	}
	matplot(x, z, type = "l", xlab = "x", ylab = "density")
	title("Some examples of the Gamma family\ndensity functions", cex = 
		0.59999999999999998)
	persp(x, alpha, z, xlab = "x", zlab = "Density", ylab = "Alpha", cex = 
		0.5)
	#contour(x, alpha, z, nlevels = 12, labex = 0, xlab = "x", ylab = 
	#	"shape parameter alpha")
	title("Perspective view with shape parameter", cex = 
		0.59999999999999998)
	matplot(x, pz, type = "l", xlab = "x", ylab = "distribution\nfunction")
	title(" Distribution functions", cex = 0.59999999999999998)
	image(x, alpha, z, xlab = "x", ylab = "Alpha")
	lines(alpha * beta, alpha)
	lines((alpha - 1.) * beta, alpha, lty = 3.)
	title("Contour plot of surface\nLines indicate expected values and modes",
		cex = 0.59999999999999998)
}

"deport" <- 
function(data)
{
	pos <- NA
	for(k in 1.:length(search())) {
		if(exists("slab.datasets.version", k)) {
			pos <- k
			break
		}
	}
	if(is.na(pos)) {
		stop("Can not find the S lab data sets directory")
	}
	else {
		remove(as.character(substitute(data)), where = pos)
	}
}

"describe" <- 
function(x)
{
	lab <- c("N", "mean", "Std.Dev.", "min", "Q1", "median", "Q3", "max",
		"missing values")
	if(missing(x)) {
		return(lab)
	}
	temp <- rep(0., length(lab))
	xt <- x[!is.na(x)]
	n <- length(xt)
	if(!is.numeric(xt) || all(is.na(x))) {
		return(c(n, NA, NA, rep(NA, 5.), length(x) - length(xt)))
	}
	if(n < 4.) {
		xt <- sort(xt)
		if(n == 1.) {
			return(c(n, xt[1.], NA, rep(xt[1.], 5.), length(x) -
				length(xt)))
		}
		if(n == 2.) {
			return(c(n, mean(xt), sqrt(var(xt)), c(xt[1.], xt[
				1.], mean(xt), xt[2.], xt[2.]), length(x) -
				length(xt)))
		}
		if(n == 3.) {
			return(c(n, mean(xt), sqrt(var(xt)), c(xt[1.], xt[
				1.], xt[2.], xt[3.], xt[3.]), length(x) - 
				length(xt)))
		}
	}
	else {
		return(c(length(xt), mean(xt), sqrt(var(xt)), min(xt), quantile(
			xt, c(0.25, 0.5, 0.75)), max(xt), length(x) - length(
			xt)))
	}
}

"dexp" <- 
function(x, gamma = 1., beta = 1.)
{
	if(missing(gamma)) {
		gamma <- beta
	}
	ifelse(x >= 0., (1./gamma) * exp( - x/gamma), 0.)
}

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

"disk.quota" <- 
function(threshhold = 250.)
{
	# user file space
	unix(" du  -s | awk '{ print $1}' > .size")
	size <- scan(".size")
	cat("You have used up a total of ", size, "Kb of file space", fill = T)
	# S file space
	if(size > threshhold) {
		cat(" \n", fill = T)
		cat("If you use more file space than your quota S will not work!",
			fill = T)
		cat("At least make sure all of your graphics files have been deleted",
			fill = T)
		cat("To do this, use the command:   ! rm ps.*    in S", fill = 
			T)
	}
	unix(" du -s .Data | awk '{ print $1}' > .size")
	size <- scan(".size")
	cat("The amount of file space taken up by your S  datasets is ", size,
		"Kb", fill = T)
	if(size > threshhold * 0.5) {
		cat(" \n", fill = T)
		cat("I would recommend deleting some of your larger, old  data sets\nusing the S function rm. For example, if zork is a data set\n   rm(zork)\nwill remove it.",
			fill = T)
		cat("\nTo list all of your data sets use: ls()", fill = T)
		cat("To list your data sets along with their sizes use:  ! ls -l .Data",
			fill = T)
	}
	invisible()
}

"dnorm.2d" <- 
function(x, y, rho = 0., mean = c(0., 0.), sd = c(1., 1.), p = c(0.5, 0.75,
	0.90000000000000002))
{
	xt <- (x - mean[1.])/sd[1.]
	yt <- (y - mean[2.])/sd[2.]
	g <- 1. - rho^2.
	temp <- function(x, y, rho)
	{
		g <- 1. - rho^2.
		exp( - (x^2. - 2. * rho * x * y + y^2.)/(2. * g))/(2. * pi *
			sqrt(g))
	}
	z <- outer(xt, yt, FUN = temp, rho = rho)/(sd[1.] * sd[2.])
	temp <- mklevel(x, y, z, p)
	list(x = x, y = y, z = z, levels = temp$levels, p = temp$p)
}