"dpoisson" <- 
function(x, lambda = 1.)
{
	if(!all((x - round(x)) == 0.))
		stop(" density must be evaluted at integers")
	lp <- log(lambda) * x - lgamma(x + 1.) - lambda
	ifelse(lp <= -30., 0., exp(lp))
}

"dtri" <- 
function(x, a = 0., b = a + 2.)
{
	x <- (x - a)/(b - a)
	# zero out density beyond range of support.
	temp <- (2. * ifelse(x < 0.5, x, 1. - x))/(b - a)
	ifelse(temp < 0., 0., temp)
}

"dweib" <- 
function(x, alpha = 1., beta = 1.)
{
	if(alpha < 0.)
		stop(" Sorry you don't have a density if alpha is \nless than 0 !"
			)
	x <- x/beta
	(alpha/beta) * (x^(alpha - 1.)) * exp( - x^alpha)
}

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

"ex" <- 
function(fun)
{
	temp <- substitute(fun)
	message(get(paste(temp, ".ex", sep = "")))
	invisible()
}

"export" <- 
structure(.Data = 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 {
		dname <- as.character(substitute(data))
		assign(dname, data, where = pos)
		cmd.chmod <- paste("chmod og+r", search()[pos], "/", dname,
			sep = "")
		unix(cmd.chmod)
		cat(dname, "has been added to the class directory", fill = T)
		message(attr(export, "text"))
		cat("synchronize(", pos, ")", fill = T)
	}
}
, text = c("If students are already in an S session to", 
	"update their search lists have them type:"))

"extra" <- 
function(pos = 1.)
{
	temp <- ls(pos = pos)
	temp2 <- match(temp, c(dump.fun.list, dump.data.list))
	temp[is.na(temp2)]
}

"freq" <- 
function(x)
{
	table(category(x))
}

"hplot" <- 
function(x, nclass, breaks, limits = c(min(x), max(x)), plot = TRUE, 
	probability = TRUE, ..., xlab = deparse(substitute(x)))
{
	x <- x[!is.na(x)]
	if(length(x) == 1.)
		stop("data has only one value!")
	if(missing(breaks)) {
		if(missing(nclass))
			nclass <- round(logb(length(x), base = 2.) + 1.)
		breaks <- seq(limits[1.], limits[2.],  , nclass + 1.)
	}
	# Count x values at the first break point as being in the bin
	bin <- cut(x, breaks)
	bin[x == breaks[1.]] <- 1.
	if(any(is.na(bin)))
		warning("Some of the data values fall outside the\nrange of the\nnhistogram bins"
			)
	bin <- bin[!is.na(bin)]
	counts <- tabulate(bin, length(breaks) - 1.)
	if(probability) {
		mar.sav <- par()$mar
		par(mar = c(mar.sav[1.:3.], 5.))
		binw <- diff(breaks)
		if(min(binw) <= 0.)
			stop("zero width or inverted breaks")
		norm <- sum(counts) * binw
		counts <- counts/norm
	}
	if(plot)
		invisible(barplot(counts, width = breaks, histo = T, ..., xlab
			 = xlab))
	else list(breaks = breaks, counts = counts)
	if(probability) {
		lab <- pretty(c(0., counts * mean(norm)))
		axis(4., lab/mean(norm), lab)
		mtext("Number of Observations", 4., 3.)
	}
	invisible()
}

"lab4.demo" <- 
function(n, nclass = 8.)
{
	old.par <- # save old graphics parameters 
	par()
	par(err = -1.)
	# set up panel of 4X3
	set.panel(4., 3.)
	x <- # sequence of x values for evaluating normal
	seq(-3., 3.,  , 150.)
	y <- # calcualte theoretical normal density
	dnorm(x)
	for(k in 1.:12.) {
		#   loop through 12 data sets 
		data <- # generate sample 
		rnorm(n)
		# plot hplotogram 
		hplot(data, nclass = nclass, limits = c(-3., 3.))
		# add lines for normal density
		lines(x, y)
		# show mean 
		points(mean(data), 0., pch = "x", cex = 1.5)
		if(k == 1.) {
			title(paste("Standard normal,", n, "observations"),
				cex = 0.5)
		}
	}
	# reset the graphics parameters to their original values
	par(old.par)
	invisible()
}

"lab5.dist" <- 
function(x)
{
	get(paste(".xx", "x", sep = ""))(x)
}

"like.surface" <- 
function(a, b, FUN, pr = c(0.5, 0.75, 0.90000000000000002, 0.94999999999999996,
	0.98999999999999999))
{
	if(missing(b) | is.function(b)) {
		one.d <- T
		pars <- matrix(a, ncol = 1.)
		N <- length(a)
		if(is.function(b))
			FUN <- b
	}
	else {
		one.d <- F
		ma <- length(a)
		mb <- length(b)
		pars <- cbind(rep(a, mb), rep(b, rep(ma, mb)))
		N <- mb * ma
	}
	z <- rep(NA, N)
	cat("looping to", N, fill = T)
	for(k in 1.:N) {
		z[k] <- FUN(c(pars[k,  ]))
		if(k/10. == floor(k)/10.)
			cat(k, " ")
	}
	cat("done", fill = T)
	if(one.d) {
		return(x = a, y = z)
	}
	else {
		levels <- max(z) - qchisq(pr, 2.)/2.
		mle <- c(pars[z == max(z), 1.], pars[z == max(z), 2.])
		return(x = a, y = b, z = matrix(z, ncol = mb, nrow = ma), 
			levels, mle, pr)
	}
}

"llike.cauchy" <- 
function(theta)
{
	-1. * sum(log(1. + ((data.cauchy - theta[1.])/theta[2.])^2.)) - length(
		data.cauchy) * log(theta[2.] * pi)
}

"llike.dexp" <- 
function(theta)
{
	(-1. * sum(abs(data.dexp - theta[1.])))/theta[2.] - length(data.dexp) *
		log(2. * theta[2.])
}

"llike.gamma" <- 
function(theta)
{
	x1 <-  - sum(data.gamma)/theta[2.] - length(data.gamma) * theta[1.] *
		log(theta[2.])
	x2 <-  - length(data.gamma) * lgamma(theta[1.]) + (theta[1.] - 1.) *
		sum(log(data.gamma))
	x1 + x2
}

"llike.gamma.1" <- 
function(theta)
{
 - sum(data.gamma)
 - length(data.gamma) * lgamma(theta[1.]) + (theta[1.] - 1.) * sum(log(
		data.gamma))
}

"lplot" <- 
function(x, y, labels = "*", srt = 0., tcex = 0.69999999999999996, ...)
{
	# first coerce factor objects to be just character vectors
	if(is.factor(x)) x <- as.character(x)
	# if y is missing do something reasonable with the x object
	#      
	if(!missing(y)) {
		if(is.factor(y))
			y <- as.character(y)
	}
	if(missing(y)) {
		if(is.data.frame(x)) {
			temp <- rep(names(x), rep(nrow(x), ncol(x)))
			y <- c(unlist(x))
			x <- temp
		}
		if(is.matrix(x)) {
			temp <- rep(dimnames(x)[[2.]], rep(nrow(x), ncol(x)))
			y <- c(x)
			x <- temp
		}
		if(data.class(x) == "numeric") {
			y <- x
			if(is.null(names(y)))
				x <- format(1.:length(y))
			else x <- names(y)
		}
	}
	# coerce labels to be character
	if(is.character(x) & is.character(y)) # 
		stop(" Both x and y can not be character vectors!")
	if(is.factor(labels))
		labels <- as.character(labels)
	# switch if x is character 
	if(!is.character(labels)) labels <- format(labels)
	# switch if y is character
	if(is.character(x)) {
		level <- unique(x)
		if(length(level) > 10.)
			srt <- 90.
		xr <- match(x, level, nomatch = NA)
		xlim <- c(min(xr) - 1., max(xr) + 1.)
		plot(xr, y, type = "n", xaxt = "n", xlab = "", xlim = xlim,
			...)
		axis(1., unique(xr), level, ticks = F, srt = srt)
		text(xr, y, labels, cex = tcex)
		invisible()
		return()
	}
	if(is.character(y)) {
		level <- unique(y)
		if(length(level) > 10.)
			srt <- 90.
		else srt <- 0.
		yr <- match(y, level, nomatch = NA)
		ylim <- c(min(yr) - 1., max(yr) + 1.)
		plot(x, yr, type = "n", yaxt = "n", ylab = "", ylim = ylim,
			...)
		axis(2., unique(yr), level, ticks = F, srt = srt)
		text(x, yr, labels, cex = tcex)
		invisible()
		return()
	}
	plot(x, y, type = "n", ...)
	text(x, y, labels, cex = tcex)
	invisible()
}

"lplot.ex" <- 
c("                                                    ", 
	"****************************************************", 
	"                                                    ", 
	"lplot(x,y)   label plot, plots y (vert. axis) against", 
	"             x (horiz. axis), x or y may be a  ", 
	"             character variable. (plot(x,y) will not", 
	"             work unless x and y are numeric)      ", 
	"                                                    ", 
	"lplot(x,y,z)   puts labels in z on points (x,y)   ", 
	"                                                    ", 
	"See Also: plot, bplot (boxplot), hplot (histogram), ", 
	"mplot (means plot), lines, points       ", 
	"                                                    ", 
	"****************************************************")

"ls.class" <- 
function()
{
	print(dump.data.list, quote = F)
	invisible()
}