".Assign"<-
function(x, value, frame)
.Internal(assign(x, value, frame), "S_assign")
".Begin.pic"<-
function()
.Internal(.Cur.picture(), "S_cur_pic" = , T, 1)
".C"<-
function(NAME, ..., NAOK = F)
.Internal(.C(NAME,
	...,
	NAOK), "S_interface" = , T, 2)
".Cur.pic"<-
function(picture)
.Internal(.Cur.picture(picture), "S_cur_pic" = )
".Dictionary"<-
function(names, where = paste(.Search.list[1], "/.dfile", sep = ""))
{
	n <- length(names)
	z <- .C("make_dict_file",
		as.character(where),
		names=as.character(names),
		pos=integer(n),
		code=integer(n),
		as.integer(n),
		F,
		NAOK = T)
	z[2:4]
}
".Fortran"<-
function(NAME, ...,NAOK = 0)
.Internal(.Fortran(NAME,
	...,
	NAOK), "S_interface" = , T, 1)
".Perm.assign"<-
function(x, value) {
warning(".Perm.assign is equivalent to assign(..,where=1), & will go away someday")
assign(x,value,w=1)
}



".System"<-
function(cmd)
invisible(unix(cmd, output = F))
".Uminus"<-
function(e1)
.Internal( - e1, "do_op" = , T, 6)
"Arg"<-
function(z)
{
	x <- z
	storage.mode(x) <- "double"
	.C("cx_arg",
		as.complex(z),
		as.integer(length(z)),
		x = x,
		NAOK = T)$x
}
"Conj"<-
function(z)
{
	mode(z) <- "complex"
	.C("cx_conj",
		z = z,
		as.integer(length(z)),
		NAOK = T)$z
}
"Device.Default"<-
function(name = "")
{
	par(xaxs = "r", yaxs = "r", tck = -0.02, mar = c(5.1, 4.1, 4.1, 2.1))
	.Internal(.Gr.Default(), "S_gr_set" = , T, 3)
	assign(".Device", name, frame = 0)
}
"Im"<-
function(z)
{
	x <- z
	storage.mode(x) <- "double"
	.C("cx_im",
		as.complex(z),
		as.integer(length(z)),
		x = x,
		NAOK = T)$x
}
"Method"<-
function(...)
.Internal(Method(...), "S_method", F, 2)
"Mod"<-
function(z)
{
	x <- z
	storage.mode(x) <- "double"
	.C("cx_mod",
		as.complex(z),
		as.integer(length(z)),
		x = x,
		NAOK = T)$x
}
"!"<-
function(e1).Internal(!e1, "do_op" = , T, 17)

"!="<-
function(e1, e2).Internal(e1!=e2, "do_op" = , T, 10)

"$"<-
function(x, ...)
.Internal(x[[...]], "S_extract" = , T, 7)

"%%"<-
function(e1, e2).Internal(e1 %% e2, "do_op" = , T, 3)

"%\\057%"<-
function(e1, e2).Internal(e1 %/% e2, "do_op" = , T, 2)

"%m%"<-
function(x, modearg){
	mode(x) <- modearg
	x
}

"%o%"<-
function(X, Y)
{
	if(is.array(X)){
		nx <- dim(X)
		nmx <- dimnames(X)
	} else {
		nx <- length(X)
		nmx <- list(names(X))
	}
	if(is.array(Y)){
		ny <- dim(Y)
		nmy <- dimnames(Y)
	} else {
		ny <- length(Y)
		nmy <- list(names(Y))
	}
	dims <- c(nx,ny); dnames <- c(nmx,nmy)
	a <-rep(X, length(Y))
	b <- matrix(Y, length(X), length(Y), byrow = T)
	array(a*b, dims, dnames)
}

"&"<-
function(e1, e2).Internal(e1 & e2, "do_op" = , T, 9)

"&&"<-
function(e1, e2).Internal(e1 && e2, "S_dummy" = , F, -27)

"*"<-
function(e1, e2).Internal(e1 * e2, "do_op" = , T, 4)

"**"<-
function(e1, e2).Internal(e1 ** e2, "do_op" = , T, 1)

"+"<-
function(e1, e2).Internal(e1 + e2, "do_op" = , T, 5)

"-"<-
function(e1, e2)
.Internal(e1 - e2, "do_op", T, 6)

":"<-
function(e1, e2).Internal(e1:e2, "S_colon" = , T, 0)

"<"<-
function(e1, e2).Internal(e1 < e2, "do_op" = , T, 11)

"<="<-
function(e1, e2).Internal(e1 <= e2, "do_op" = , T, 12)

"=="<-
function(e1, e2).Internal(e1 == e2, "do_op" = , T, 13)

">"<-
function(e1, e2).Internal(e1 > e2, "do_op" = , T, 14)

">="<-
function(e1, e2).Internal(e1 >= e2, "do_op" = , T, 15)

"["<-
function(x, ..., drop = T).Internal(x[..., drop], "S_extract", T, 1)

"[["<-
function(x, ..., drop = T).Internal(x[[..., drop]], "S_extract", T, 3)

"\\057"<-
function(e1, e2).Internal(e1/e2, "do_op" = , T, 7)

"^"<-
function(e1, e2).Internal(e1^e2, "do_op" = , T, 1)

"|"<-
function(e1, e2).Internal(e1 | e2, "do_op" = , T, 8)

"||"<-
function(e1, e2).Internal(e1 || e2, "S_dummy" = , F, -28)
"NextMethod"<-
function(...)
.Internal(UseMethod(...), "S_method", F, 1)
"<-"<-
function(expression,value)
{n <- sys.parent(); eval( substitute(expression <- value), n)}

"<<-"<-
function(expression,value)
{n <- sys.parent(); eval( substitute(expression <<- value), n)}

"[<-"<-
function(x, ..., value)
.Internal(x[...]  <-  value, "S_replace", T, 1)

"[[<-"<-
function(x, ..., value)
.Internal(x[[...]] <- value, "S_replace", T, 3)

"attr<-"<-
function(x, which, value)
.Internal(attr(x, which) <- value, "S_replace", T, 4)

"mode<-"<-
function(x, value)
.Internal(mode(x) <- value, "S_replace", T, 5)

"length<-"<-
function(x, value)
.Internal(length(x) <- value, "S_replace", T, 6)

"$<-"<-
function(x, name, value)
.Internal(x$name <- value, "S_replace", T, 7)

"names<-"<-
function(x, value)
.Internal(names(x) <- value, "S_replace", T, 8)

"dim<-"<-
function(x, value)
.Internal(dim(x) <- value, "S_replace", T, 10)

"dimnames<-"<-
function(x, value)
.Internal(dimnames(x) <- value, "S_replace", T, 11)

"tsp<-"<-
function(x, value)
.Internal(tsp(x) <- value, "S_replace", T, 12)

"levels<-"<-
function(x, value)
.Internal(levels(x) <- value, "S_replace", T, 13)

"attributes<-"<-
function(x, value)
.Internal(attributes(x) <- value, "S_replace", T, 14)

"storage.mode<-"<-
function(x, value)
.Internal(storage.mode(x) <- value, "S_replace", T, 15)
"Re"<-
function(z)
{
	x <- z
	storage.mode(x) <- "double"
	.C("cx_re",
		as.complex(z),
		as.integer(length(z)),
		x = x,
		NAOK = T)$x
}
"UseMethod"<-
function(...)
.Internal(UseMethod(...), "S_method", F, 0)
"abline"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(abline(...), abline = ))
}
"abs"<-
function(x).Internal(abs(x), "do_math" = , T, 101)
"acos"<-
function(x).Internal(acos(x), "do_math" = , T, 113)
"acosh"<-
function(x).Internal(acosh(x), "do_math" = , T, 126)
"again"<-
function(pattern, editor = F)
if(missing(pattern)) history(max = 1, editor = editor) else {
	if(is.name(substitute(pattern)))
		pattern <- substitute(pattern)
	history(c(pattern), max = 1, editor = editor)
}
"aggregate"<-
function(x, nf=1, fun = sum)
{
	x <- as.ts(x)
	t <- tsp(x)
	f <- t[3]
	if(nf > f)
		stop("cannot increase frequency")
	if(nf == f)
		return(x)
	if(f %% nf!=0)
		stop(paste("cannot change from frequency", f, "to frequency",
			nf))
	mult <- f/nf
	x <- window(x, start = ceiling(t[1]))
	length(x) <- length(x) %/% mult * mult	# even multiple
	x <- apply(matrix(x, nrow = mult), 2, fun)
	ts(x, start = ceiling(t[1]), frequency = nf)
}
"all"<-
function(...).Internal(all(...), "do_summary" = , T, 120)
"allocated"<-
function()
{
	map <- storage()
	ttt <- sys.calls()
	n <- length(ttt) - 1
	cname <- character(n)
	alloc <- numeric(n)
	for(i in 1:n) {
		el <- ttt[[i]]
		cname[i] <- if(mode(el) == "call")
			as.character(el[[1]])
		else paste("Frame", i)
		alloc[i] <- sum(map$allocated[map$frame == i])
	}
	names(alloc) <- cname
	alloc
}
"amatch"<-
function(definition, call)
.Internal(amatch(definition, call), "S_amatch" = , T, 0)


"any"<-
function(...).Internal(any(...), "do_summary" = , T, 119)
"aperm"<-
function(a, perm = NULL, reshape = T)
{
	d <- dim(a)
	dn <- dimnames(a)
	k <- length(d)
	if(missing(perm))
		perm <- k:1
	else if(any(sort(perm)!=1:k))
		stop("Illegal perm vector")
	z <- .C("gt",
		NAOK = T,
		a = as.vector(a),
		as.integer(switch(storage.mode(a),
			complex = 16,
			double = 8,
			4)),
		as.integer(d),
		as.integer(k),
		as.integer(perm - 1))$a
	if(reshape)
		d <- d[perm]
	dim(z) <- d
	if(reshape && length(dn) > 0)
		dimnames(z) <- dn[perm]
	names(z) <- NULL
	z
}
"append"<-
function(x,values,after=length(x)){
	len <- length(x)
	if(after<=0) c(values,x)
	else if(after>=len) c(x,values)
	else c(x[1:after],values,x[(after+1):len])
}
"apply"<-
function(X, MARGIN, FUN, ...)
{
	if(is.character(FUN))
		FUN <- get(FUN, mode = "function")
	else if(mode(FUN)!="function") {
		farg <- substitute(FUN)
		if(mode(farg) == "name")
			FUN <- get(farg, mode = "function")
		else stop(paste("\"", farg, "\" is not a function", sep = ""))
		
	}
	d <- dim(X)
	dn <- dimnames(X)
	if(!is.null(dn)) {
		dn <- dn[MARGIN]
		dimnames(X) <- NULL
	}
	newX <- aperm(X, c(seq(1, length(d))[ - MARGIN], MARGIN))
	subdim <- d[ - MARGIN]
	dim(newX) <- c(prod(subdim), prod(d[MARGIN]))
	ans <- vector("list", ncol(newX))
	if(length(subdim) > 1)
		for(i in 1:ncol(newX))
			ans[i] <- list(FUN(array(newX[, i], subdim), ...))
		
	else for(i in 1:ncol(newX))
			ans[i] <- list(FUN(newX[, i], ...))
	ret.list <- is.recursive(ans[[1]])
	first.length <- length(ans[[1]])
	if(!ret.list)
		for(i in 1:ncol(newX))
			if(length(ans[[i]])!=first.length) ret.list <- T
	ans.names <- names(ans[[1]])
	if(!ret.list)
		ans <- unlist(ans, recursive = F)
	if(length(MARGIN) == 1 && length(ans) == ncol(newX)) {
		if(length(dn[[1]]) > 0)
			names(ans) <- dn[[1]]
		return(ans)
	}
	else if(length(ans) == ncol(newX))
		return(array(ans, d[MARGIN], dn))
	else if(length(ans) %% ncol(newX) == 0) {
		if(is.null(dn))
			return(array(ans, c(length(ans)/ncol(newX), d[MARGIN])
				))
		else return(array(ans, c(length(ans)/ncol(newX), d[MARGIN]),
				c(list(ans.names), dn)))
	}
	else return(ans)
}
"approx"<-
function(...)
marks.xy("approx")
"args"<-
function(name = "help", call = T){
	if(!missing(name)) name <- substitute(name)	# name is not yet evaluated
	name <- paste("'",name,"'",sep="")
	if(call) unix(paste(c("$SHOME/cmd/call", name, .Search.list), collapse = " "), output=F)
	else unix(paste(c("$SHOME/cmd/help", name, .Search.list), collapse = " "), output=F)
	invisible()
}
"array"<-
function(data = NA, dim, dimnames = NULL)
{
	data <- as.vector(data)
	ll <- prod(dim)
	if(length(data) < ll) {
		old <- data
		data[1:ll] <- old
	}
	else if(length(data) > ll)
		length(data) <- ll
	dim(data) <- dim
	if(is.list(dimnames))
		if(length(dim)==1) names(data) <- dimnames[[1]]
		else dimnames(data) <- dimnames
	data
}
"arrows"<-
function(...).S(arrows(...), segments = )
"as.array"<-
function(x){
	if(!is.array(x)) dim(x) <- length(x)
	x
}
"as.call"<-
function(x)
if(mode(x) == "call(...)") as.call(x[[1]]) else .Internal(as.name(x), "As_vector"
	 = , T = T, 300)
"as.category"<-
function(x)
if(is.category(x)) x else category(x)
"as.matrix"<-
function(x)
{
	if(is.matrix(x))x
	else {
		dn <- names(x)
		array(x,c(length(x), 1),if(length(dn))list(dn,NULL) else NULL)
	}
}
"as.qr"<-
function(x)
if(is.qr(x)) x else qr(x)
"as.ts"<-
function(x){
	if(!is.ts(x)) {
		x <- as.vector(x)
		tsp(x) <- c(1.,length(x), 1)
	}
	x
}
"as.vector"<-
function(x, mode = "any")
.Internal(as.vector(x, mode), "As_vector" = ,	T, 1000)

"as.null"<-
function(x)
.Internal(as.null(x), "As_vector" = , T, 0)
"as.logical"<-
function(x)
.Internal(as.logical(x), "As_vector" = , T, 1)
"as.integer"<-
function(x)
.Internal(as.integer(x), "As_vector" = , T, 2)
"as.single"<-
function(x)
.Internal(as.single(x), "As_vector" = , T, 3)
"as.double"<-
function(x)
.Internal(as.double(x), "As_vector" = , T, 4)
"as.numeric"<-
function(x)
.Internal(as.numeric(x), "As_vector" = , T, 4)
"as.character"<-
function(x)
if(is.category(x))levels(x)[x] else
.Internal(as.character(x), "As_vector" = , T, 5)
"as.list"<-
function(x)
.Internal(as.list(x), "As_vector" = , T, 6)
"as.complex"<-
function(x)
.Internal(as.complex(x), "As_vector" = , T, 7)
"as.expression"<-
function(x)
.Internal(as.expression(x), "As_vector" = , T, 297)
"as.name"<-
function(x)
.Internal(as.name(x), "As_vector" = , T, 257)
"as.function"<-
function(x)
.Internal(as.function(x), "As_vector" = , T, 301)
"asin"<-
function(x).Internal(asin(x), "do_math" = , T, 112)
"asinh"<-
function(x).Internal(asinh(x), "do_math" = , T, 125)
"assign"<-
function(x, value, frame, where)
{
	if(missing(where)) {
		if(missing(frame))
			.Internal(assign(x, value), "S_assign")
		else .Internal(assign(x, value, frame), "S_assign")
	}
	else if(missing(frame))
		.Internal(assign(x, value, where), "S_put")
	else stop("Meaningless to give both frame and where arguments")
}
"atan"<-
function(x, y = NULL)
if(is.null(y)) .Internal(atan(x), "do_math" = , T, 111) else .Internal(atan(x,
	y), "do_math" = , T, 111)
"atanh"<-
function(x).Internal(atanh(x), "do_math" = , T, 127)
"attach"<-
function(file=NULL, pos = 2)
{
	old <- .Search.list
	if(is.null(file)) return(old)
	n <- length(.Search.list)
	if(pos <= 1) temp <- c(file, .Search.list)
	else if(pos > n) temp <- c(.Search.list, file)
	else temp <- c(.Search.list[1:(pos - 1)], file, .Search.list[pos:
		n])
	assign(".Search.list", temp, frame = 0)	# session dataset
	invisible(old)
}
"attr"<-
function(x, which).Internal(attr(x, which), "S_extract" = , T, 4)
"attributes"<-
function(x)
.Internal(attributes(x), "S_extract" = , T, 14)


"audit.file"<-
function()
.C("get_audit_file",
	character(1))[[1]]
"axes"<-
function(...){
	if(options("show")[[1]])invisible(.S(axes(...), axes = ))
	else {
		.Begin.pic()
		.Cur.pic(.S(axes(...), axes=))
	}
}
"axis"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(axis(...), axis = ))
}
"backsolve"<-
function(r, x, k = p)
{
	r <- as.matrix(r)
	storage.mode(r) <- "double"
	dr <- dim(r)
	p <- dr[2]
	if(dr[1]!=p) stop("r should be a square matrix")
	if(is.matrix(x)) {
		dx <- dim(x)
		if(dx[1]!=p) stop("x and r should have the same number of rows")
		q <- dx[2]
	}
	else {
		if(length(x)!=p) stop("Wrong number of elements in x")
		q <- 1
	}
	storage.mode(x) <- "double"
	z <- .Fortran("dbksl",
		r,
		as.integer(p),
		as.integer(k),
		x = x,
		as.integer(q),
		info = as.integer(0))
	if(z$info) stop(paste("Zero diagonal in column", z$info))
	z$x
}
"barplot"<-
function(...){
	if(options("show")[[1]])invisible(.S(barplot(...), barplot = ))
	else {
		.Begin.pic()
		.Cur.pic(.S(barplot(...), barplot=))
	}
}
"bind"<-
function(expr)
{
	warning("bind is broken; no optimization performed")
	expr
}
"blitid"<-
function(...)
marks.xy("blitid")
"box"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(box(...), box = ))
}
"boxplot"<-
function(...){
	if(options("show")[[1]])invisible(.S(boxplot(...), boxplot = ))
	else {
		.Begin.pic()
		.Cur.pic(.S(boxplot(...), boxplot=))
	}
}
"browser"<-
function(frame, catch = T, parent, message)
{
	brows.repl <- function(expr, frame)
	{
		newexpr <- substitute({
			NULL
			sys.frame()
		}
		)
		newexpr[[1]] <- expr
		eval(newexpr, frame)
	}
	if(!interactive())
		stop("browser must be used interactively")
	if(!exists("old.error", frame = sys.nframe())) {
		old.error <- options(error = NULL)
		on.exit(options(old.error))
	}
	nframe <- sys.parent(1)
	if(missing(frame)) {
		parent <- sys.parent(2)
		frame <- sys.frames()[[nframe]]
	}
	else if(mode(frame)!="list")
		stop("Argument to browser() should be a list")
	else if(missing(parent))
		parent <- sys.parent(1)
	if(!missing(message))
		cat(message, "\n")
	else if(missing(frame))
		cat("Browser called from:", deparse(sys.calls()[[nframe]]), "\n")
	else cat("Browser called on", deparse(substitute(frame)), "\n")
	choices <- names(frame)
	n <- length(frame)
	index <- seq(len = n)
	for(i in rev(index))
		if(mode(frame[[i]])!="argument") {
			n <- length(index) <- i
			break
		}
	if(catch)
		restart()
	show <- T
	repeat {
		if(show) {
			cat(
				"Type number, ?, or expression (0 or return(...) to exit)\n"
				)
			show <- F
		}
		i <- parse(prompt = "Selection: ", n = 1)[[1]]
		switch(mode(i),
			numeric = {
				if(i > 0 && i <= n) {
					cat(choices[i], ":\n", sep = "")
					if(mode(frame[[i]]) == "argument")
						cat(frame[[i]], "\n")
					else print(frame[[i]])
				}
				else if(i == 0)
					return()
				else show <- T
			}
			,
			"<-" = if(missing(frame)) eval(i, nframe) else {
				frame <- brows.repl(i, frame)
				choices <- names(frame)
				n <- length(choices)
				index <- seq(len = n)
			}
			,
			"return" = if(missing(frame)) return(eval(i[[1]], nframe))
				 else return(eval(i[[1]], frame, parent)),
			quit = return(),
			"?" = for(i in index)
				cat(i, ": ", choices[i], "\n", sep = ""),
			{
				assign(".Auto.print", T, frame = nframe)
				val <- if(missing(frame)) eval(i, nframe) else eval(
						i, frame, parent)
				if(get(".Auto.print", frame = nframe))
					print(val)
			}
			)
	}
}
"browser.trace"<-
function(call)
{
	trace.on(F)
	on.exit(trace.on(T))
	n <- sys.nframe()
	f <- sys.parent()
	expr <- substitute(call)[[3]]
	name <- as.character(expr[[1]])
	fun <- get(name, mode = "function")
	cat("On entry to", name, "frame", n, "\n")
	browser(amatch(fun, expr),parent=f)
	trace.on(T)
	x <- call
	trace.on(F)
	cat("On exit from", name, "frame", n, "\n")
	browser(if(is.list(x)) x else list(value = x), parent=f)
	x
}
"bxp"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(bxp(...), bxp = ))
}
"c"<-
function(..., recursive = F)
.Internal(list(..., recursive), "S_unlist", T, 1)
"call"<-
function(...)
.Internal(call(...), "S_list", T, 2)
"cancor"<-
function(x, y, xcenter, ycenter)
{
	x <- as.matrix(x)
	y <- as.matrix(y)
	dx <- dim(x)
	dy <- dim(y)
	n <- dx[1]
	if(n!=dy[1])
		stop("x and y must have same no. of rows")
	if(missing(xcenter) || (is.logical(xcenter) && xcenter
		)) {
		xcenter <- apply(x, 2, mean)
		x <- sweep(x, 2, xcenter)
	}
	else if(!missing(xcenter) && (!is.logical(xcenter))) 
		{
		xcenter <- rep(xcenter, length = dx[2])
		x <- sweep(x, 2, xcenter)
	}
	else xcenter <- numeric(dx[2])
	if(missing(ycenter) || (is.logical(ycenter) && ycenter
		)) {
		ycenter <- apply(y, 2, mean)
		y <- sweep(y, 2, ycenter)
	}
	else if(!missing(ycenter) && (!is.logical(ycenter))) 
		{
		ycenter <- rep(ycenter, length = dy[2])
		y <- sweep(y, 2, ycenter)
	}
	else ycenter <- numeric(dy[2])
	qx <- qr(x)
	qy <- qr(y)
	p <- qx$rank
	q <- qy$rank
	sp <- 1:p
	sq <- 1:q
	w <- qr.qy(qy, diag(1, n, q))
	w <- qr.qty(qx, w)[sp,  , drop = F]
	z <- svd(w, p, q)
	vx <- backsolve((qx$qr)[sp, sp, drop = F], z$u)
	vy <- backsolve((qy$qr)[sq, sq, drop = F], z$v)
	list(cor = z$d, xcoef = vx, ycoef = vy, xcenter = 
		xcenter, ycenter = ycenter)
}
"cat"<-
function(..., file = "", sep = " ", fill = F, labels = NULL,append=F).Internal(	cat(..., file, sep, fill, labels,append), "S_cat" = , T, 0)
"category"<-
function(x, levels = sort(unique(x)), labels = as.character(levels), ordered = 
	F)
{
	y <- match(x, levels)
	levels(y) <- labels
	if(ordered)
		attr(y, "ordered") <- TRUE
	y
}
"cbind"<-
function(...)
{
	nc <- 0
	nrow <- 0
	maxrows <- 0
	rownames <- NULL
	colnames <- list()
	alldata <- list(...)
	argnames <- names(alldata)
	if(is.null(argnames))
		argnames <- rep("", length(alldata))
	for(j in seq(alldata)) {
		thisname <- argnames[[j]]
		thisdata <- alldata[[j]]
		if(is.matrix(thisdata)) {
			d <- dim(thisdata)
			nc <- nc + d[2]
			if(nrow == 0)
				nrow <- d[1]
			else if(nrow!=d[1])
				stop(
					"number of rows of matrices and lengths of named vectors must match"
					)
			dn <- dimnames(thisdata)
			if(length(dn[[1]]) > 0)
				rownames <- dn[[1]]
			if(length(dn[[2]]) > 0)
				colnames[[j]] <- dn[[2]]
			else colnames[[j]] <- rep("", d[2])
		}
		else if(length(thisdata) > 0) {
			rowname <- names(thisdata)
			if(!is.null(rowname)) {
				if(nrow == 0)
					nrow <- length(rowname)
				else if(nrow!=length(rowname))
					stop(
						"number of rows of matrices and lengths of named vectors must match"
						)
				rownames <- rowname
			}
			nc <- nc + 1
			maxrows <- max(maxrows, length(thisdata))
			colnames[[j]] <- thisname
		}
	}
	colnames <- unlist(colnames, recursive = F)
	if(nrow == 0)
		nrow <- maxrows
	if(nrow == 0 || nc == 0)
		return(NULL)
	x <- matrix(nrow = nrow, ncol = nc)
	j <- 1
	for(i in alldata) {
		if(is.matrix(i)) {
			jj <- j + dim(i)[2]
			x[, j:(jj - 1)] <- i
			j <- jj
		}
		else if(length(i) > 0) {
			x[, j] <- i
			j <- j + 1
		}
	}
	dim(x) <- c(nrow, nc)
	if(all(colnames == ""))
		colnames <- NULL
	if(!(is.null(rownames) && is.null(colnames)))
		dimnames(x) <- list(rownames, colnames)
	x
}
"ceiling"<-
function(x).Internal(ceiling(x), "do_math" = , T, 103)
"chapter"<-
function(...)stop("Function not implemented")
"chol"<-
function(x, pivot = F)
{
	x <- as.matrix(x)
	storage.mode(x) <- "double"
	d <- dim(x)
	p <- d[1]
	if(p!=d[2]) stop(
		"Non-square matrix not allowed in choleski decompostion")
	if(pivot) {
		z <- .Fortran("chol",
			chol = x,
			as.integer(p),
			double(p),
			pivot = as.integer(rep(0, p)),
			as.integer(1),
			rank = as.integer(0))
		if(z$rank < 0) stop("Matrix must be symmetric")
		x <- z$chol
		attr(x, "pivot") <- z$pivot
		attr(x, "rank") <- z$rank
		x
	}
	else {
		z <- .Fortran("chol",
			chol = x,
			as.integer(p),
			double(p),
			as.integer(0),
			as.integer(0),
			rank = as.integer(0))
		if(z$rank < 0) stop("Matrix must be symmetric")
		if(z$rank < p) stop("Choleski decomposition not of full rank")
		z$chol
	}
}
"chull"<-
function(...)
marks.xy("chull")
"clorder"<-
function(...).S(clorder(...), clorder = )
"cmdscale"<-
function(...).S(cmdscale(...), cmdscale = )
"code"<-
function(x, levels = sort(unique(x)), labels = as.character(levels))
{
	y <- match(x, levels)
	levels(y) <- labels
	y
}
"coerce"<-
function(x, modearg){
	mode(x) <- modearg
	x
}
"col"<-
function(x)
{
	d <- dim(x)
	if(length(d)!=2)stop("x must be a matrix")
	storage.mode(x) <- "integer"
	x[] <- rep.int(1:d[2], rep.int(d[1], d[2]))
	x
}
"compare"<-
function(e1, e2)
.Internal(compare(e1, e2), "do_op", T, 18)
"complex"<-
function(length.d = 0, data = NULL, real = 0, imaginary = 0, modulus = 1,
	argument = 0)
{
	cartesian <- !(missing(real) & missing(imaginary))
	polar <- !(missing(modulus) & missing(argument))
	if(cartesian && polar)
		stop("Invalid use of cartesian and polar forms")
	if(cartesian)
		data <- real + imaginary * (1i)
	else if(polar)
		data <- modulus * (cos(argument) + sin(argument) * (1i))
	else if(missing(data))
		return(vector("complex", length.d))
	else data <- as.complex(data)
	if(missing(length.d))
		data
	else if(length.d!=length(data))
		rep(data, length = length.d)
	else data
}
"compname"<-
function(x).Internal(compname(x), "S_extract" = , T, 8)
"contour"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(contour(...), contour = ))
}
"cor"<-
function(...)
.S(cor(...), cor = )
"cos"<-
function(x).Internal(cos(x), "do_math" = , T, 110)
"cosh"<-
function(x).Internal(cosh(x), "do_math" = , T, 123)
"count.trace"<-
function(call)
{
	trace.on(F)
	on.exit(trace.on(T))
	this.call <- substitute(call)[[3]]	# call is mode "frame"
	fn <- as.character(this.call[[1]])
	ttt <- Trace.count[[match(fn, names(Trace.count), 0)]]	
	#	ttt <- Trace.count[[fn]]
	Trace.count[[fn]] <<- if(length(ttt) == 0)
		1
	else ttt + 1
	trace.on(T)
	x <- call
	trace.on(F)
	x
}
"crossprod"<-
function(x, y = x)
{
	xx <- as.matrix(x)
	yy <- as.matrix(y)
	dx <- dim(xx)
	dy <- dim(yy)
	if(dx[1]!=dy[1]) {
# should include tests for promotion the wrong way
		stop("Number of rows of x and y should be the same")
	}
	mx <- is.na(xx)
	my <- is.na(yy)
	if(mode(xx) == "complex" || mode(yy) == "complex") {
		mode(xx) <- "complex"
		mode(yy) <- "complex"
		z <- matrix(as.complex(NA), dx[2], dy[2])
		z <- .C("cx_mat_mul",
			t(xx),
			yy,
			z = z,
			dx[2],
			dy[2],
			dx[1],
			NAOK = T)$z
	}
	else {
		storage.mode(xx) <- "double"
		storage.mode(yy) <- "double"
		if(any(mx) || any(my)) {
			z <- matrix(as.double(NA), dx[2], dy[2])
			z <- .Fortran("matptm",
				xx,
				as.integer(dx),
				as.logical(mx),
				logical(dx[2]),
				yy,
				as.integer(dy),
				as.logical(my),
				logical(dy[2]),
				z = z,
				NAOK = T)$z
		}
		else {
			z <- matrix(0, dx[2], dy[2])
			z <- .Fortran("dmatpt",
				xx,
				as.integer(dx),
				yy,
				as.integer(dy),
				z = z)$z
		}
	}
	dnx <- dimnames(xx)
	dny <- dimnames(yy)
	if(!is.null(dnx) || !is.null(dny)) {
		dnz <- list(character(0), character(0))
		if(!is.null(dnx))
			dnz[1] <- dnx[2]
		if(!is.null(dny))
			dnz[2] <- dny[2]
		dimnames(z) <- dnz
	}
	z
}

"%c%"<-
function(x, y) crossprod(x,y)
"cstr"<-
function(...) list(...)
"cumsum"<-
function(x).Internal(cumsum(x), "do_math"=, T, 128)
"cut"<-
function(...).S(cut(...), cut = )
"cutree"<-
function(...).S(cutree(...), cutree = )
"cycle"<-
function(x)
{
	i <- tsp(as.ts(x))
	m <- as.integer((i[1] %% 1) * i[3] + 0.001)
	x <- (1:length(x) + m - 1) %% as.integer(i[3]) + 1
	tsp(x) <- i
	x
}
"data.dump"<-
function(names, file = "dumpdata")
.C("S_dump",
	file = as.character(file),
	as.character(names),
	as.integer(length(names)))$file
"data.restore"<-
function(file, print = F)
.C("S_restore",
	as.character(file),
	as.logical(print))[[1]]
"dataset"<-
function(x)
	exists(x)
"date"<-
function()unix("date")
"dbeta"<-
function(q, shape1, shape2)
	.S(dbeta(q, par1=shape1, par2=shape2), dnorm = )
"dcauchy"<-
function(q, location = 0, scale = 1)
	.S(dcauchy(q, par1=location, par2=scale), dnorm = )
"dchisq"<-
function(q, df)
	.S(dchisq(q, par1=df), dnorm = )
"debugger"<-
function(data = last.dump)
{
	choices <- names(data)
	repeat {
		i <- menu(choices, graphics = F)
		if(i > 0) {
			if(is.list(data[[i]]))
				browser(data[[i]], parent = if(i > 1) data[[
						i - 1]] else 1, message = 
					paste("Frame of", choices[i]))
			else stop(
					"No frames available: need options(error=dump.frames)"
					)
		}
		else break
	}
}
"define"<-
function(...)stop("Function not implemented")
"density"<-
function(...).S(density(...), density = )
"deparse"<-
function(expr, short = F)
	.Internal(deparse(expr, short), "S_deparse" )



"detach"<-
function(what=2){
	old <- .Search.list
	switch(mode(what),
		character = {
			subs <- match(what, .Search.list)
			if(is.na(subs)) stop(paste("Database", what, 
				"isn't being searched"))
			else subs <-  - subs
		}
		,
		logical = subs <- !what,
		subs <-  - what)
	assign(".Search.list",.Search.list[subs],frame=0)	# session dataset
	invisible(old)
}
"device.xy"<-
function(x, y)
.C("gr_transform",
	x = as.single(x),
	y = as.single(y),
	length(x),
	length(y),
	as.integer(0))[c("x", "y")]
"dexp"<-
function(q)
exp( - q)
"df"<-
function(q, df1, df2)
	.S(df(q, par1=df1, par2=df2), dnorm = )
"dgamma"<-
function(q, shape)
	.S(dgamma(q, par1=shape), dnorm = )
"dget"<-
function(fileinput)eval(parse(file = fileinput))
"diag"<-
function(x = 1, nrow.arg, ncol.arg = n)
{
	if(is.matrix(x) && nargs()==1)
		return(x[seq(1, min(dim(x)) * nrow(x), nrow(x) + 1)])
	if(missing(x)) n <- nrow.arg
	else if(length(x) == 1 && missing(nrow.arg) && missing(ncol.arg)) {
		n <- as.integer(x)
		x <- 1
	}
	else n <- length(x)
	if(!missing(nrow.arg)) n <- nrow.arg
	p <- ncol.arg
	m <- matrix(0, n, p)
	m[seq(1, min(n, p) * n, n + 1)] <- x
	m
}
"diff"<-
function(x, lag = 1, differences = 1)
{
	if(lag < 1 | differences < 1)
		stop("Bad value for lag or differences")
	if(lag * differences >= length(x))
		return(x[0])
	r <- x
	s <- 1:lag
	for(i in 1:differences)
		r <- r[-s] - r[-(length(r) + 1 - s)]
	tspx <- tsp(x)
	if(length(tspx) > 0)
		ts(as.vector(r), start = tspx[1] + (lag * differences)/tspx[
			3], frequency = tspx[3])
	else as.vector(r)
}
"dim"<-
function(x)
.Internal(dim(x), "S_extract" = , T, 10)


"dimnames"<-
function(x)
.Internal(dimnames(x), "S_extract" = , T, 11)


"discr"<-
function(...).S(discr(...), discr = )
"dist"<-
function(...).S(dist(...), dist = )
"dlnorm"<-
function(q, meanlog = 0, sdlog = 1)
	.S(dlnorm(q, par1=meanlog, par2=sdlog), dnorm = )
"dlogis"<-
function(q, location = 0, scale = 1)
	.S(dlogis(q, par1=location, par2=scale), dnorm = )
"dnorm"<-
function(q, mean = 0, sd = 1)
	.S(dnorm(q, par1=mean, par2=sd), dnorm = )
"do.call"<-
function(what, args)
{
	this.call <- c(as.name(what), args)
	mode(this.call) <- "call"
	eval(this.call, local = sys.parent(1))
}


"do.command"<-
function(command,input, output.to.S = T){
	if(!missing(input)){
		file <- tempfile("unix")
		on.exit(unlink(file))
		cat(input,file=file,sep="\n")
		command <- paste("<",file,command)
	}
	if(output.to.S) .Internal(do.command(command, T), "S_do_cmd" = ) else
	invisible(.Internal(do.command(command, F), "S_do_cmd" = ))
}


"dotchart"<-
function(data, labels, groups = NULL, gdata = NA, horizontal = T, pch = "o",
	xlab = "", lty = 2, lines = T, dotsize = 1.2, cex = par("cex"), ...)
{
	ndata <- length(data)
	if(missing(labels)) {
		if(!is.null(names(data)))
			labels <- names(data)
		else labels <- paste("#", seq(ndata))
	}
	else labels <- rep(labels, length = ndata)
	if(missing(groups)) {
		glabels <- NULL
		gdata <- NULL
	}
	else {
		glabels <- levels(groups)
		gdata <- rep(gdata, length = length(glabels))	
	# order according to group
		ord <- order(groups, seq(groups))
		groups <- groups[ord]
		data <- data[ord]
		labels <- labels[ord]
	}
	alldat <- c(data, gdata)
	alllab <- c(paste(labels, ""), paste(glabels, "   "))	
	# set up margins and user coordinates, draw box
	mxlab <- max(c(5, nchar(alllab)))
	tmai <- par("mai")
	tcex <- par("cex")
	on.exit(par(mai = tmai, cex = tcex))
	par(cex = cex)
	mxlab <- mxlab * par("cin")[1]	# adjust by char width
	if(horizontal) {
		par(mai = c(tmai[1], mxlab, tmai[3:4]))
		plot(alldat, seq(alldat), type = "n", ylab = "", axes = F,
			xlab = xlab, ...)
		logax <- par("xaxt") == "l"
	}
	else {
		par(mai = c(mxlab, tmai[2:4]))
		plot(seq(alldat), alldat, type = "n", xlab = "", axes = F,
			ylab = xlab, ...)
		logax <- par("yaxt") == "l"
	}
	tusr <- par("usr")
	if(logax) {
		if(horizontal)
			abline(v = 10^tusr[1:2], h = tusr[3:4])
		else abline(v = tusr[1:2], h = 10^tusr[3:4])
	}
	else abline(v = tusr[1:2], h = tusr[3:4])
	den <- ndata + 2 * length(glabels) + 1
	if(horizontal) {
		axis(1)
		delt <-  - (tusr[4] - tusr[3])/den
		ypos <- seq(tusr[4], by = delt, length = ndata)
	}
	else {
		axis(2)
		delt <- (tusr[2] - tusr[1])/den
		ypos <- seq(tusr[1], by = delt, length = ndata)
	}
	if(!missing(groups)) {
		ypos1 <- ypos + 2 * delt * cumsum(c(1, diff(groups) > 0))
		diff2 <- c(3 * delt, diff(ypos1))
		ypos2 <- ypos1[abs(diff2 - 3 * delt) < abs(0.001 * delt)] -
			delt
		ypos <- c(ypos1, ypos2) - delt
	}
#put on labels and data
	ypos <- ypos + delt
	nongrp <- 1:ndata
	if(horizontal) {
		if(lines)
			abline(h = ypos[!is.na(alldat)], lty = lty)
		points(alldat, ypos, pch = pch, cex = dotsize * cex)
		mtext(alllab[nongrp], 2, 0, at = ypos[nongrp], srt = 0, adj = 
			1, cex = cex)
		if(!missing(groups))
			mtext(alllab[ - nongrp], 2, 0, at = ypos[ - nongrp],
				srt = 0, adj = 1, cex = cex)
	}
	else {
		if(lines)
			abline(v = ypos[!is.na(alldat)], lty = lty)
		points(ypos, alldat, pch = pch, cex = dotsize * cex)
		mtext(alllab[nongrp], 1, 0, at = ypos[nongrp], srt = 90, adj
			 = 1, cex = cex)
		if(!missing(groups))
			mtext(alllab[ - nongrp], 1, 0, at = ypos[ - nongrp],
				srt = 90, adj = 1, cex = cex)
	}
	invisible()
}
"dput"<-
function(x, file = "")
invisible(.Internal(dput(x, file), "S_deparse" = , T, 1))
"drop"<-
function(x)
{
	n <- length(dim(x))
	if(n == 0)
		return(x)
	eval(parse(text = paste("x[", paste(rep(",", n - 1), collapse = ""),
		"]")))
}
"dt"<-
function(q, df)
	.S(dt(q, par1=df), dnorm = )
"dump"<-
function(list.OF.names, fileout = "dumpdata")
{
	if(!is.character(list.OF.names))
		stop("first argument to dump must be a character vector")
	on.exit(sink())
	sink(fileout)
	for(.x in list.OF.names) {
		cat(paste("\"", .x, "\"<-\n", sep = ""))
		dput(get(.x))
	}
	fileout
}
"dump.calls"<-
function()
{
	calls <- sys.calls()
	ncalls <- length(calls) - 1
	if(ncalls < 2 && mode(calls[[1]])!="call")
		return()
	n <- 1:ncalls
	result <- list("No Frame Available")[rep(1, ncalls)]
	allnames <- character(ncalls)
	for(i in n)
		allnames[i] <- paste(deparse(calls[[i]]), collapse = "\n")
	names(result) <- allnames
	last.dump <<- result
	cat("Dumped\n")
}
"dump.frames"<-
function()
{
	calls <- sys.calls()
	ncalls <- length(calls) - 1
	if(ncalls < 2 && mode(calls[[1]])!="call")
		return()
	n <- 1:ncalls
	result <- sys.frames()[n]
	allnames <- character(ncalls)
	for(i in n)
		allnames[i] <- paste(deparse(calls[[i]]), collapse = "\n")
	names(result) <- allnames
	last.dump <<- result
	cat("Dumped\n")
}
"dumpmacro"<-
function(name){
	gn <- get(name)
	cat(attr(gn,"args"),file="/tmp/dumped",sep="\n")
	args <- unix("sed 's/=$//' </tmp/dumped",output=T)
	ttt <- c(paste("fun.", name, "<-", sep = ""), paste(c("function(",
		paste(args, "=", attr(gn,"deflt"), ", "), "){"), collapse = ""),
		gn, "}")
	cat(ttt, file = "/tmp/dumped", sep = "\n")
	cat(file = "/tmp/sed", paste("/\\$", 1:length(args), "/s//", args,
		"/g\n", sep = ""))
	unix("cat $SHOME/cmd/macrofix.sed >>/tmp/sed",output=F)
	unix("sed -f /tmp/sed /tmp/dumped >/tmp/fixed",output=F)
}
"dunif"<-
function(q, min = 0, max = 1)
	.S(dunif(q, par1=min, par2=max), dnorm = )
"duplicated"<-
function(x).Internal(duplicated(x), "S_match" = , T, 1)
"dyn.load"<-
function(names, undefined = 0)
invisible(.Internal(dyn.load(names, undefined), "S_dynload"))
"ed"<-
function(data, file = tempfile("ed."), editor = "ed")
{
	drop <- missing(file)
	if(missing(data)) {
		if(!exists(".Last.file"))
			stop("Nothing available for re-editing")
		file <- .Last.file
		data <- .Last.ed
	}
	else if(mode(data) == "character")
		cat(data, file = file, sep = "\n")
	else if(is.atomic(data))
		cat(data, file = file, fill = T)
	else dput(data, file = file)
	on.exit({
		cat("Errors occurred; use ", editor, "() to re-edit this data\n",
			sep = "")
		if(!missing(data)) {
			assign(".Last.ed", data, frame = 0)
			assign(".Last.file", file, frame = 0)
		}
	}
	)
	unix(paste(editor, file), output = F)
	expr <- if(is.atomic(data)) {
		if(mode(data) == "character")
			unix(paste("cat", file))
		else scan(file, data[F])
	}
	else eval(parse(n = -1, file = file))
	if(drop) {
		unlink(file)
		if(missing(data)) {
			remove(".Last.ed", frame = 0)
			remove(".Last.file", frame = 0)
		}
	}
	on.exit()
	expr
}
"edit"<-
function(...)stop("Function not implemented")
"eigen"<-
function(x)
{
	x <- as.matrix(x)
	storage.mode(x) <- "double"
	dmx <- dim(x)
	p <- dmx[1]
	if(p!=dmx[2]) stop("Eigenvalues only defined for square matrices")
	z <- .Fortran("crs",
		x,
		as.integer(dmx),
		T,
		values = double(p),
		vectors = matrix(0.d+00, p, p),
		double(p),
		double(p),
		error.code = integer(1))
	if(z$error.code) stop(paste("Eigen algorithm returned error code",
		z$error.code))
	dmx <- p:1
	list(values = z$values[dmx], vectors = z$vectors[, dmx])
}
"encode"<-
function(...)paste(...)
"end"<-
function(x) {
	i <- tsp(as.ts(x))
	j <- trunc(i[2])
	c(j,trunc((i[2]-j)*i[3]+1.5))
}
"eval"<-
function(expression, local = TRUE,parent=NULL)
.Internal( eval(expression, local,parent), "S_dummy" = , T , -26)
"exists"<-
function(name, where = NULL, frame = NULL, mode = "any")
{
	if(is.null(where)) {
		if(is.null(frame)) .Internal(exists(name, mode),
			"S_get" = , T, 10)
		else .Internal(exists(name, mode, frame), "S_get"
			 = , T, 12)
	}
	else if(is.character(where)) .Internal(exists(name, mode,
		where), "S_get" = , T, 11)
	else {
		where <- as.integer(where)
		if(where < 0 || where > length(.Search.list))
			stop(paste("Invalid where argument:", where))
		else if(where==0) .Internal(exists(name, mode, 0), "S_get" = , T, 12)
		else .Internal(exists(name, mode, .Search.list[where]),
			"S_get" = , T, 11)
	}
}


"exp"<-
function(x).Internal(exp(x), "do_math" = , T, 108)
"expression"<-
function(...).Internal(expression(...), "S_dummy" = , F, -15)
"faces"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(faces(...), faces = ))
}
"fatal"<-
function(...)stop(...)
"fft"<-
function(z, inverse = F)
{
	d <- dim(z)
	n <- as.integer(length(z))
	z <- as.complex(z)
	inv <- as.integer(if(inverse) -1 else 1)
	if(is.null(d))
		return(.C("fft",
			z = z,
			n,
			n,
			n,
			inv)$z)
	prod <- 1
	for(i in 1:length(d)) {
		prod <- prod * d[i]
		z <- .C("fft",
			z = z,
			n,
			d[i],
			as.integer(prod),
			inv)$z
	}
	dim(z) <- d
	z
}
"floor"<-
function(x).Internal(floor(x), "do_math" = , T, 102)
"format"<-
function(x)
{
	z <- .C("pratom",
		list(as.vector(x)),
		value = list(character(length(x))),
		T)$value[[1]]
	attributes(z) <- attributes(x)
	z
}
"frame"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(frame(...), frame = ))
}
"frame.attr"<-
function(which)
.Internal(frame.attr(which), "S_dummy", T, -30)
"frame.attr<-"<-
function(which, new)
.Internal("frame.attr<-"(which, new), "S_dummy", T, -31)
"frame.attributes"<-
function()
.Internal(frame.attributes(), "S_dummy", T, -32)
"frequency"<-
function(x) tsp(as.ts(x))[3]
"gamma"<-
function(...).S(gamma(...), gamma = )
"get"<-
function(name, where, frame, mode = "any", inherit=F)
{
	if(missing(where)) {
		if(missing(frame))
			.Internal(get(name, mode, inherit), "S_get" = , T, 0)
		else .Internal(get(name, mode, frame), "S_get" = , T, 2)
	}
	else if(is.character(where))
		.Internal(get(name, mode, where), "S_get" = , T, 1)
	else {
		where <- as.integer(where)
		if(where < 0 || where > length(.Search.list))
			stop(paste("Invalid where argument:", where))
		else if(where == 0)
			.Internal(get(name, mode, 0), "S_get" = , T, 2)
		else .Internal(get(name, mode, .Search.list[where]), "S_get" = ,
				T, 1)
	}
}
"gr.display"<-
function(...)
.Internal(gr.display(...), "S_gr_disp" = , T, 0)
"gr.query"<-
function(...)
.Internal(.Query(...), "S_gr_set" = , T = T, 1)
"gr.specify"<-
function(...)
.Internal(.Specify(...), "S_gr_set" = , T = T, 0)
"graphics"<-
function(...)
{
	if(!exists(".Device"))
		stop("No graphics device specified yet")
	ttt <- options(show=F)
	on.exit(options(ttt))
	z <- list(...)
	mode(z) <- "graphics"
	z
}
"graphics.off"<-
function()
{
	if(exists(".Device", frame = 0)) remove(".Device", frame = 0)
	invisible(.C("gr_wrap"))
}
"grep"<-
function(pattern, text){
	if(length(pattern) > 1)
		pattern <- paste("(", pattern, ")", sep = "",collapse="|")
	command <- paste("egrep -n -e \"", pattern, "\" |sed 's/:.*//'",
		sep = "")
	as.numeric(unix(command, text))
}
"gs"<-
function(...)
qr(...)
"gtds"<-
function(...).S(gtds(...), gtds = )
"hat"<-
function(x, intercept = T)
{
	if(is.qr(x))
		d <- dim(x$qr)
	else {
		if(intercept)
			x <- cbind(1, x)
		d <- dim(x)
		x <- qr(x)
	}
	q <- qr.qy(x, diag(1, nrow = d[1], ncol = x$rank))
	ans <- numeric(d[1])
	for(i in seq(ans)) ans[i] <- sum(q[i,  ]^2)
	ans
}
"hclust"<-
function(...).S(hclust(...), hclust = )
"help"<-
function(name = "help", offline = F, call = F)
{
	if(!missing(name))
		name <- substitute(name)	# name is not yet evaluated
	if(is.language(name) && !is.name(name))
		name <- eval(name)
	if(name == "/" || name == "%/%")
		name <- "Arithmetic"
	name <- paste("'", name, "'", sep = "")
	if(offline && !call)
		name <- paste("OFFLINE", name)
	if(call)
		unix(paste(c("$SHOME/cmd/call", name, .Search.list), collapse
			 = " "), output = F)
	else unix(paste(c("$SHOME/cmd/help", name, .Search.list), collapse = 
			" "), output = F)
	invisible()
}
"hist"<-
function(x, nclass, breaks, plot = TRUE, probability = FALSE, ..., xlab = 
	deparse(substitute(x)))
{
	x <- x[!is.na(x)]
	if(missing(breaks)) {
		if(missing(nclass))
			nclass <- log(length(x), base = 2) + 1
		if(length(x) == 1)
			breaks <- x + c(-1, 1)
		else breaks <- pretty(x, nclass)
		if(any(as.single(x) <= breaks[1]))
			breaks <- c(breaks[1] - diff(breaks)[1], breaks)
	}
	bin <- cut(x, breaks)
	if(any(is.na(bin)))
		stop("breaks do not span the range of x")
	counts <- tabulate(bin, length(levels(bin)))
	if(probability) {
		binw <- diff(breaks)
		if(min(binw) <= 0)
			stop("zero width or inverted breaks")
		counts <- counts/sum(counts)/binw
	}
	if(plot)
		invisible(barplot(counts, width = breaks, histo = T, ...,
			xlab = xlab))
	else list(breaks = breaks, counts = counts)
}
"history"<-
function(pattern, max.expr = 10, evaluate = T, call, menu.ask = T, graphics = T,
	where = audit.file(), editor)
{
	if(where == "")
		stop("Cannot access audit file")
	assign("history", function(...)
	stop("Recursive  use of history() not allowed"), frame = 1)
	if(missing(pattern) && missing(call))
		pattern <- "."
	else if(!missing(call)) {
		if(is.name(substitute(call)))
			call <- substitute(call)
		pattern <- paste(call, "[(]", sep = "")
	}
	else if(is.name(substitute(pattern)))
		pattern <- substitute(pattern)
	pattern <- paste("'", pattern, "'", sep = "")
	if(!missing(where)) {
		if(is.numeric(where))
			where <- paste(.Search.list[where], "/.Audit", sep = "")
			
		else where <- paste(where, "/.Audit", sep = "")
	}
	lines <- unix(paste("$SHOME/cmd/history", max.expr, pattern, where))
	if((n <- length(lines)) < 1) {
		cat("No match\n")
		return(invisible(NULL))
	}
	breaks <- (1:n)[lines == "#~"]
	n <- length(breaks)
	if(n > 1) {
		answer <- character(n)
		start <- 1
		for(i in 1:n) {
			end <- breaks[i]
			answer[i] <- paste(lines[start:(end - 1)], collapse = "\n")
				
			start <- end + 1
		}
		if(menu.ask)
			answer <- answer[menu(answer, graphics)]
	}
	else answer <- lines[ - breaks[1]]
	n <- length(answer)
	if(!missing(editor)) {
		if(mode(editor) == "logical")
			editor <- if(editor) .Options$editor else function(x)
				x
		if(mode(editor) == "character")
			editor <- get(editor)
		if(mode(editor)!="function")
			editor <- function(x)
			x
		answer <- editor(answer)
	}
	else cat(answer, sep = "\n")
	if(evaluate && n > 0)
		eval(parse(text = answer, n = n), local = F)
	else if(n > 0)
		invisible(parse(text = answer, n = n))
}
"hp150"<-
function(ask = F, file = "")
{
	graphics.off()
	z <- .C("hp2623",
		as.logical(ask),
		as.character(file),
		as.integer(150))
	Device.Default("hp2623")
}
"hp2393"<-
function(ask = F, file = "")
{
	graphics.off()
	z <- .C("hp2623",
		as.logical(ask),
		as.character(file),
		as.integer(2628))
	Device.Default("hp2623")
}
"hp2397"<-
function(ask = F, file = "")
{
	graphics.off()
	z <- .C("hp2623",
		as.logical(ask),
		as.character(file),
		as.integer(2627))
	Device.Default("hp2623")
}
"hp2623"<-
function(ask = F, file = "")
{
	graphics.off()
	z <- .C("hp2623",
		as.logical(ask),
		as.character(file),
		as.integer(2623))
	Device.Default("hp2623")
}
"hp2627"<-
function(ask = F, file = "")
{
	graphics.off()
	z <- .C("hp2623",
		as.logical(ask),
		as.character(file),
		as.integer(2627))
	Device.Default("hp2623")
}
"hp2628"<-
function(ask = F, file = "")
{
	graphics.off()
	z <- .C("hp2623",
		as.logical(ask),
		as.character(file),
		as.integer(2628))
	Device.Default("hp2623")
}
"hp2648"<-
function(ask = F, file = "")
{
	graphics.off()
	z <- .C("hp2623",
		as.logical(ask),
		as.character(file),
		as.integer(2648))
	Device.Default("hp2623")
}
"hpgl"<-
function(width = 10, height = 7.25, ask = !auto, auto = F, color = 2, speed = 400,
	rotated = F, file = ""){
	graphics.off()
	.C("hpgl",
		as.single(width),
		as.single(height),
		as.integer(ask),
		as.logical(auto),
		as.integer(color),
		as.integer(speed/10),
		as.logical(rotated),
		as.character(file))
	Device.Default("hpgl")
}
"identify"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(identify(...), identify = ))
}
"ifelse"<-
function(test, yes, no)
{
	answer <- test
	test <- as.logical(test)
	na <- is.na(test)
	n <- length(answer)
	test[na] <- F
	answer[test] <- rep(yes, length = n)[test]
	test[na] <- T
	answer[!test] <- rep(no, length = n)[!test]
	answer
}
"index"<-
function(...)
.Internal(index(...), "S_list", T, 1)
"interactive"<-
function()
.C("interactive",
	ans = T)$ans
"interp"<-
function(...).S(interp(...), interp = )
"invisible"<-
function(x = NULL)
{
	assign(".Auto.print", F, frame = sys.parent(2))
	x
}
"is.array"<-
function(x)
length(dim(x)) > 0


"is.atomic"<-
function(x).Internal(is.atomic(x), "S_dtype" = , T, 0)


"is.call"<-
function(x)
mode(x) == "call" || mode(x) == "call(...)"
"is.category"<-
function(x)
length(levels(x)) > 0
"is.language"<-
function(x).Internal(is.language(x), "S_dtype" = , T, 1)


"is.matrix"<-
function(x)
length(dim(x)) == 2


"is.na"<-
function(x).Internal(is.na(x), "S_na_funs" = , T, 0)
"is.qr"<-
function(x)
is.list(x) && !is.null(x$qr) && !is.null(x$qraux)
"is.recursive"<-
function(x).Internal(is.recursive(x), "S_dtype" = , T, 2)


"is.ts"<-
function(x) length(tsp(x))>0
"is.vector"<-
function(x, mode = "any")
.Internal(is.vector(x, mode), "Is_vector" = ,	T, 1000)
"is.null"<-
function(x)
.Internal(is.null(x), "Is_vector" = , T, 0)
"is.logical"<-
function(x)
.Internal(is.logical(x), "Is_vector" = , T, 1)
"is.integer"<-
function(x)
.Internal(is.integer(x), "Is_vector" = , T, 2)
"is.single"<-
function(x)
.Internal(is.single(x), "Is_vector" = , T, 3)
"is.double"<-
function(x)
.Internal(is.double(x), "Is_vector" = , T, 4)
"is.numeric"<-
function(x)
is.double(x)||is.single(x)||is.integer(x)
"is.character"<-
function(x)
.Internal(is.character(x), "Is_vector" = , T, 5)
"is.list"<-
function(x)
.Internal(is.list(x), "Is_vector" = , T, 6)
"is.complex"<-
function(x)
.Internal(is.complex(x), "Is_vector" = , T, 7)
"is.expression"<-
function(x)
.Internal(is.expression(x), "Is_vector" = , T, 297)
"is.name"<-
function(x)
.Internal(is.name(x), "Is_vector" = , T, 257)
"is.function"<-
function(x)
.Internal(is.function(x), "Is_vector" =, T, 301)
"l1fit"<-
function(...).S(l1fit(...), l1fit = )
"labclust"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(marks.xy("labclust"))
}
"lag"<-
function(x, k = 1)
{
	x <- as.ts(x)
	t <- tsp(x)
	tsp(x) <- t - (k/t[3]) * c(1, 1, 0)
	x
}
"lapply"<-
function(X, FUN, ...)
{
	if(is.character(FUN))
		FUN <- get(FUN, mode = "function")
	else if(mode(FUN)!="function") {
		farg <- substitute(FUN)
		if(mode(farg)=="name") FUN <- get(farg, mode = "function")
		else stop(paste("\"", farg, "\" is not a function",
			sep = ""))
	}
	answer <- X
	for(i in seq(along = X))
		answer[[i]] <- FUN(answer[[i]], ...)
	answer
}
"leaps"<-
function(...).S(leaps(...), leaps = )
"legend"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(legend(...), legend = ))
}
"len"<-
function(x).Internal(len(x), "S_extract" = , T, 6)
"length"<-
function(x)
.Internal(length(x), "S_extract" = , T, 6)


"levels"<-
function(x)
.Internal(levels(x), "S_extract" = , T, 13)


"lgamma"<-
function(...).S(lgamma(...), gamma = )
"library"<-
function(section = NULL, first = F, help = NULL)
{
	if(!exists("lib.loc", frame = 0))
		assign("lib.loc", unix("echo $SHOME/library"), frame = 0)
	if(missing(section) && missing(help))
		unix(paste("cat ", lib.loc, "/", "README*", sep = ""), out = F)
		
	else if(!missing(help))
		unix(paste("cat ", lib.loc, "/", substitute(help), "/README",
			sep = ""), out = F)
	else {
		name <- paste(lib.loc, "/", substitute(section), "/.Data",
			sep = "")
		if(match(name, .Search.list, nomatch = F))
			detach(name)
		if(unix(paste("test -d", name), out = F))
			stop(paste("Section", substitute(section), 
				"is not available"))
		attach(name, pos = if(first)
			2
		else 100)
	}
	invisible()
}
"library.dynam"<-
function(section, file)
{
	name <- paste(section, ".", file, sep = "")
	if(exists(name, frame = 0))
		return()
	if(!exists("lib.loc", frame = 0))
		assign("lib.loc", unix("echo $SHOME/library"), frame = 0)
	dyn.load(paste(lib.loc, "/", section, "/", file, sep = ""))
	assign(name, 1, frame = 0)
}
"lines"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(marks.xy("lines"))
}
"list"<-
function(...)
.Internal(list(...), "S_list", T, 1)
"locator"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(rdpen(...), rdpen = ))
}
"log"<-
function(x, base = 2.71828182845905d+00)
{
	y <- .Internal(log(x), "do_math" = , T, 106)
	if(missing(base)) y
	else y/.Internal(log(base), "do_math" = , T, 106)
}
"log10"<-
function(x).Internal(log10(x), "do_math" = , T, 107)
"loglin"<-
function(...).S(loglin(...), loglin = )
"logo"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(logo(...), logo = ))
}
"lowess"<-
function(...)
marks.xy("lowess")
"ls"<-
function(pattern = "", pos = 1)
{
	if(pos == 0) {
		if(pattern!="")
			warning("Patterns ignored in ls(pos=0)")
		return(sort(names(sys.frame0())))
	}
	cmd <- paste("cd ", .Search.list[pos], "; ls 2>/dev/null")
	if(pattern!="")
		cmd <- paste(cmd, "-d", pattern)
	unix(cmd)
}
"ls.keep"<-
function()
sort(.Internal(ls.hash(), "S_ls_hash" = , T, 1))
"ls.summary"<-
function(lsfit)
{
	row.sum <- function(mat, nr)
	{
		rsum <- numeric(nr)
		for(i in 1:nr)
			rsum[i] <- sum(mat[i,  ])
		rsum
	}
	wt <- lsfit$wt
	resid <- as.matrix(lsfit$residuals)
	dy <- dim(resid)
	ynames <- dimnames(resid)[[2]]
	n <- dy[1]
	ny <- dy[2]
	if(!is.null(wt)) {
		resid <- resid * wt^0.5
		excl <- wt == 0
		if(any(excl))
			warning("Zero weights in lsfit; std.dev will be wrong"
				)
	}
	p <- lsfit$qr$rank
	rinv <- diag(p)
	cnames <- dimnames(lsfit$qr$qr)[[2]]
	if(!is.null(cnames)) {
		if(p < length(cnames))
			cnames <- cnames[1:p]
		dimnames(rinv) <- list(cnames, cnames)
	}
	hat <- apply(qr.qy(lsfit$qr, diag(1, nrow = n, ncol = p))^2, 1, sum)
	stddev <- numeric(ny)
	if(length(ynames))
		names(stddev) <- ynames
	stdres <- studres <- resid
	if(n > p) {
		for(j in 1:ny) {
			rr <- resid[, j]
			stddev[j] <- sqrt(sum(rr^2)/(n - p))
			sr <- rr/(sqrt(1 - hat) * stddev[j])
			studres[, j] <- (sr * stddev[j])/sqrt(((n - p) * 
				stddev[j]^2 - rr^2/(1 - hat))/(n - p - 1))
			stdres[, j] <- sr
		}
	}
	else stddev[] <- stdres[] <- studres[] <- NA
	rinv <- backsolve(lsfit$qr$qr[1:p, 1:p], rinv)
	rowlen <- row.sum(rinv^2, p)^0.5
	if(length(cnames) > 0)
		names(rowlen) <- cnames
	correl <- rinv * array(1/rowlen, c(p, p))
	correl <- correl %*% t(correl)
	list(std.dev = stddev, hat = hat, std.res = stdres, stud.res = studres,
		correlation = correl, std.err = rowlen %o% stddev, 
		cov.unscaled = rinv %*% t(rinv))
}
"lsfit"<-
function(x, y, wt, intercept = T, tolerance = 1e-07, yname = NULL)
{
	if(!is.matrix(x))
		x _ array(x,c(length(x),1),list(names(x),"X"))
	storage.mode(x) <- "double"
	if(is.matrix(y)){
		y.matrix <- TRUE
		dy <- dim(y)
		q <- dy[2]
		yn <- dimnames(y)[[2]]
		if(is.null(yn)) {
			yn <- if(is.null(yname)) paste("Y", 1:q, sep = "")
				else yname
			length(yn) <- q
		}
	}
	else  {
		if(y.matrix <- !missing(yname)) {
			yn <-  yname[1]
			y <- matrix(y,ncol=1)
		}
		dy <- c(length(y),1)
		q <- 1
	}
	storage.mode(y) <- "double"
	dx <- dim(x)
	n <- dx[1]
	dn <- dimnames(x)
	xn <- dn[[2]]
	if(n!=dy[1]) stop("Number of observations in x and y not equal")
	if(intercept){
		dx <- dx + c(0, 1)
		if(length(xn))xn <- c("Intercept", xn)
		x <- array(c(rep(1, n), x), dx,dimnames=list(dn[[1]],xn))
	}
	if(!missing(wt)){
		wt <- as.double(wt)
		if(length(wt)!=n) 
			stop("Weight vector has wrong number of observations")
		if(any(wt<0)) stop("Weights must be non-negative")
		wt.factor <- wt^.5
		wt.zero <- wt.factor==0
		x0 <- x[wt.zero,]
		y0 <- if(y.matrix)y[wt.zero,,drop=F] else y[wt.zero]
		x <- x*wt.factor
		y <- y*wt.factor
		inv.wt.factor <- 1/ifelse(wt.zero,1,wt.factor)
	}
	p <- dx[2]
	z <- .Fortran("dqrls",
		qr = x,
		as.integer(dx),
		pivot = as.integer(1:p),
		qraux = double(p),
		y,
		as.integer(dy),
		coef = double(p * q),
		residuals = y,
		qt = y,
		tol = as.double(tolerance),
		double(p),
		rank = as.integer(p))
	if(z$rank < p)warning("solution was less than full rank (see `pivot' component)")
	if(z$rank < p && length(xn)) {
		xn <- xn[z$pivot]
		dimnames(z$qr)[[2]] <- xn
	}
	if(y.matrix){
		b <- matrix(z$coef, p, q)
		dimnames(b) <- list(xn, yn)
		z$coef <- b
	}
	else if(length(xn))names(z$coef)<-xn
	if(!missing(wt)){
		z$residuals <- z$residuals*inv.wt.factor
		z$wt <- wt
		if(any(wt.zero)) {
			if(y.matrix)z$residuals[wt.zero,] <- y0-x0%*%z$coef
			else z$residuals[wt.zero] <- y0-x0%*%z$coef
		}
	}
	qr <- z[c("qt", "qr", "qraux", "rank", "pivot", "tol")]
	z <- z[match(c("coef","residuals","wt"),names(z),0)]
	z$intercept <- intercept
	z$qr <- qr
	z
}
"macro"<-
function(...){
	.S(qpemacro(...), qpemacro= )
	source(".S.macro.out")
}
"marks.xy"<-
function(name, sname = name, evaluate = T)
{
	caller <- sys.parent(2)
	plot.call <- sys.calls()[[sys.parent(1)]]
	args <- amatch(function(x, y, ...)
	{
	}
	, plot.call)
	default <- attr(args, "missing")
	if(default[1])
		stop("no x or y data")
	xexpr <- args$x
	if(is.language(xexpr))
		xexpr <- xexpr[[1]]
	x <- eval(xexpr, caller)
	other <- args$...[[1]]
	y <- NULL
	if(is.list(x)) {
		if(any(is.na(match(c("x", "y"), names(x)))))
			stop("cannot find x and y in list")
		y <- x$y
		x <- x$x
	}
	else if(is.complex(x)) {
		y <- Im(x)
		x <- Re(x)
	}
	else if(is.matrix(x) && ncol(x) == 2) {
		y <- x[, 2]
		x <- x[, 1]
	}
	else if(default[2]) {
		y <- x
		x <- time(x)
	}
	if(length(x) == 0)
		stop("zero length x data")
	if(is.null(y)) {
		yexpr <- args$y
		if(is.language(yexpr))
			yexpr <- yexpr[[1]]
		y <- eval(yexpr, caller)
	}
	else {
		other <- amatch(function(x, ...)
		{
		}
		, plot.call)[[2]][[1]]
	}
	if(length(y) == 0)
		stop("zero length y data")
	name <- as.name(name)
	z <- list(name, x = x, y = y)
	if(length(other) > 1)
		z <- c(z, other[-1])
	mode(z) <- "call"
	zz <- vector("S.call", 2)
	zz[[1]] <- z
	zz[[2]] <- sname
	if(evaluate)
		eval(zz, caller)
	else zz
}
"match"<-
function(x, table, nomatch = NA)
.Internal(match(x, table, nomatch), "S_match" = , T, 0)
"matlines"<-
function(...).S(matlines(...), matplot = )
"%*%"<-
function(x, y)
{
	ldx <- length(dim(x))
	ldy <- length(dim(y))
	if(ldx!=2 && ldy!=2) {
		dim(x) <- c(1, length(x))
		dim(y) <- c(length(y), 1)
	}
	else if(ldx!=2)
		if(length(x) == nrow(y))
			dim(x) <- c(1, length(x))
		else dim(x) <- c(length(x), 1)
	else if(ldy!=2)
		if(length(y) == ncol(x))
			dim(y) <- c(length(y), 1)
		else dim(y) <- c(1, length(y))
	dx <- dim(x)
	dy <- dim(y)
	if(dx[2]!=dy[1])
		stop(
			"Number of columns of x should be the same as number of rows of y"
			)
	mx <- is.na(x)
	my <- is.na(y)
	if(mode(x) == "complex" || mode(y) == "complex") {
		mode(x) <- "complex"
		mode(y) <- "complex"
		z <- matrix(as.complex(NA), dx[1], dy[2])
		z <- .C("cx_mat_mul",
			x,
			y,
			z = z,
			dx[1],
			dy[2],
			dx[2],
			NAOK = T)$z
	}
	else {
		storage.mode(x) <- "double"
		storage.mode(y) <- "double"
		if(any(mx) || any(my)) {
			z <- matrix(as.double(NA), dx[1], dy[2])
			z <- .Fortran("matpm",
				x,
				as.integer(dx),
				as.logical(mx),
				logical(dx[1]),
				y,
				as.integer(dy),
				as.logical(my),
				logical(dy[2]),
				z = z,
				NAOK = T)$z
		}
		else {
			z <- matrix(0, dx[1], dy[2])
			z <- .Fortran("dmatp",
				x,
				as.integer(dx),
				y,
				as.integer(dy),
				z = z)$z
		}
	}
	dnx <- dimnames(x)
	dny <- dimnames(y)
	if(!is.null(dnx) || !is.null(dny)) {
		dnz <- list(NULL, NULL)
		if(!is.null(dnx))
			dnz[1] <- dnx[1]
		if(!is.null(dny))
			dnz[2] <- dny[2]
		dimnames(z) <- dnz
	}
	z
}
"matplot"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(matplot(...), matplot = ))
}
"matpoints"<-
function(...).S(matpoints(...), matplot = )
"matrix"<-
function(data = NA, nrow = 1, ncol = 1, byrow = F, dimnames = NULL)
{
	if(missing(nrow))
		nrow <- ceiling(length(data)/ncol)
	else if(missing(ncol))
		ncol <- ceiling(length(data)/nrow)
	dim <- c(nrow, ncol)
	if(length(dim)!=2)
		stop("nrow and ncol should each be of length 1")
	if(byrow)
		t(array(data, dim[2:1], rev(dimnames)))
	else array(data, dim, dimnames)
}
"max"<-
function(...).Internal(max(...), "do_summary" = , T, 114)
"mean"<-
function(x, trim)
{
	if(missing(trim))
		sum(as.double(x))/length(x)
	else .S(mean(x, trim), mean = )
}
"median"<-
function(x)
{
	if(any(is.na(x)))
		return(NA)
	x <- sort(x)
	len <- length(x)
	i <- trunc((len + 1)/2)
	(x[i] + x[(len - i) + 1])/2
}
"medit"<-
function(...)stop("Function not implemented")
"memory.size"<-
function()
.C("mem_size",
	s = integer(1))$s
"menu"<-
function(choices,graphics=T){
	if(!interactive())
		stop("menu must be used interactively")
	.Internal(menu(choices,graphics), "S_menu" = )
}
"message"<-
function(...)cat(..., "\n")
"min"<-
function(...).Internal(min(...), "do_summary" = , T, 115)
"missing"<-
function(name).Internal(missing(name), "S_dummy" = , F, -14)
"mode"<-
function(x)
.Internal(mode(x), "S_extract" = , T, 5)


"monthplot"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(monthplot(...), monthplot = ))
}
"mstr"<-
function(x, ...){
	temp <- list(...)
	x[names(temp)] <- temp
	x
}
"mstree"<-
function(...).S(mstree(...), mstree = )
"mtext"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(mtext(...), mtext = ))
}
"mulbar"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(mulbar(...), mulbar = ))
}
"mux"<-
function(ask = F, load = F, file = "")
{
	graphics.off()
	z <- .C("tty5620",
		as.logical(ask),
		as.logical(load),
		"echo 'use tty5620() or tty630() to load'",
		"Sterm.XXXX",
		as.character(file))
	Device.Default("tty5620")
}
"na"<-
function(x)is.na(x)
"names"<-
function(x)
.Internal(names(x), "S_extract" = , T, 8)


"napsack"<-
function(...).S(napsack(...), napsack = )
"nargs"<-
function().Internal(nargs(), "S_dummy" = , T, -16)
"nchar"<-
function(x).Internal(nchar(x), "S_dummy" = , T, -13)
"ncol"<-
function(x) dim(x)[2]
"ncomp"<-
function(a){
	if(is.list(a)) length(a)
	else 1
}
"nper"<-
function(x) tsp(as.ts(x))[3]
"nrow"<-
function(x) dim(x)[1]
"object.size"<-
function(object)
.Internal(object.size(object), "S_obj_size")
"odometer"<-
function(current, radix)
{
	if(any(c(current, radix) < 0))
		stop("arguments must be non-negative")
	lc <- length(current)
	if(length(radix)!=lc)
		radix <- rep(radix, length = lc)
	radix <- radix - 1
	for(i in 1:lc) {
		if((ii <- current[i]) < radix[i]) {
			current[i] <- ii + 1
			return(current)
		}
		else current[i] <- 0
	}
	current
}
"on.exit"<-
function(expression)
{
	if(nargs()) .Internal(on.exit(expression), "S_dummy" = , F = F, -20)
	else .Internal(on.exit(), "S_dummy" = , F = F, -20)
}
"option"<-
function(...)
{
	if(nargs() == 0) return(.Options)
	current <- .Options
	temp <- list(...)
	if(length(temp) == 1 && is.null(names(temp))){
		arg <- temp[[1]]
		switch(mode(arg),"list"=temp <- arg,
		"character" =  return(.Options[arg]),
		stop(paste("invalid argument:",arg)))
	}
	if(length(temp) == 0) return()
	n <- names(temp)
	if(is.null(n)) stop("options must be given by name")
	changed <- current[n]
	current[n] <- temp
	assign(".Options", current, frame = 0)
	invisible(changed)
}
"options"<-
function(...)
{
	if(nargs() == 0) return(.Options)
	current <- .Options
	temp <- list(...)
	if(length(temp) == 1 && is.null(names(temp))){
		arg <- temp[[1]]
		switch(mode(arg),"list"=temp <- arg,
		"character" =  return(.Options[arg]),
		stop(paste("invalid argument:",arg)))
	}
	if(length(temp) == 0) return()
	n <- names(temp)
	if(is.null(n)) stop("options must be given by name")
	changed <- current[n]
	current[n] <- temp
	assign(".Options", current, frame = 0)
	invisible(changed)
}
"order"<-
function(...)
{
	p <- nargs()
	if(p == 1)
		return(sort.list(...))
	z <- list(...)
	n <- numeric(p)
	for(i in 1:p)
		n[i] <- length(z[[i]])
	m <- max(n)
	keys <- 1:m
	for(i in p:1) {
		x <- if(n[i] < m) rep(z[[i]], length = m) else z[[i]]
		keys <- keys[sort.list(x[keys])]
	}
	keys
}
"outer"<-
function(X, Y, FUN = "*", ...)
{
	if(is.character(FUN))
		FUN <- get(FUN)
	if(is.array(X)){
		nx <- dim(X)
		nmx <- dimnames(X)
	} else {
		nx <- length(X)
		nmx <- list(names(X))
	}
	if(is.array(Y)){
		ny <- dim(Y)
		nmy <- dimnames(Y)
	} else {
		ny <- length(Y)
		nmy <- list(names(Y))
	}
	dims <- c(nx, ny)
	a <- matrix(X, length(X), length(Y))
	b <- matrix(Y, length(X), length(Y), byrow = T)
	ans <- FUN(a, b, ...)
	dim(ans) <- dims
	dn <- c(nmx, nmy)
	if(length(dn) == length(dims))
		dimnames(ans) <- dn
	ans
}
"pairs"<-
function(x, labels = dimnames(as.matrix(x))[[2]], ...)
{
	.Begin.pic()
	if(is.null(labels))
		.Cur.pic(.S(pairs(x, ...), pairs = ))
	else .Cur.pic(.S(pairs(x, labels, ...), pairs = ))
}
"par"<-
function(...)
{
	if(nargs() == 0) return( .S(query(gr.pars)) )
	temp <- list(...)
	if(is.null(names(temp))){
		arg <- temp[[1]]
		switch(mode(arg),
		"list" = temp <- arg,
		"character" = return(.S(query(...))),
		stop(paste("invalid argument:",arg)))
	}
	if(length(temp) == 0) return()
	n <- names(temp)
	if(is.null(n)) stop("parameters must be given by name")
	current <- .S(query(c("cex",n)))[-1] # force return of list
	# par has troubles with lenght 1 lists, so add innocuous parm
	if(length(temp) == 1) temp <- c(list(blk=" "),temp)
	.Begin.pic()
	.Cur.pic(.S(par(temp)))
	invisible(current)
}
"pardump"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(pardump(...), pardump = ))
}
"parse"<-
function(file = "", n = NULL,
	text = NULL, prompt = NULL,white=F)
	.Internal(parse(file,n, text,  prompt,white), "S_parse" )
"paste"<-
function(..., sep = " ", collapse = NULL).Internal(paste(..., sep, collapse),
	"S_paste" = , T, 0)


"pbeta"<-
function(x, shape1, shape2)
	.S(pbeta(x, par1=shape1, par2=shape2), pnorm = )
"pcauchy"<-
function(x, location = 0, scale = 1)
	.S(pcauchy(x, par1=location, par2=scale), pnorm = )
"pchisq"<-
function(x, df)
	.S(pchisq(x, par1=df), pnorm = )
"persp"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(persp(...), persp = ))
}
"pexp"<-
function(q)
1 - pmin(1, exp( - q))
"pf"<-
function(x, df1, df2)
	.S(pf(x, par1=df1, par2=df2), pnorm = )
"pgamma"<-
function(x, shape)
	.S(pgamma(x, par1=shape), pnorm = )
"pic"<-
function(file = "", command = "(echo .sp1i;pic)|troff|lp")
{
	graphics.off()
	if(file!="") {
		where <- file
		how <- 0
	}
	else {
		where <- command
		how <- 1
	}
	z <- .C("pic",
		as.character(where),
		as.integer(how),
		as.character(file))
	Device.Default("pic")
}
"pie"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(pie(...), pie = ))
}
"plclust"<-
function(..., plot = T)
{
	.Begin.pic()
	.Cur.pic(coords <- .S(plclust(..., plot = plot), "plclust"))
	names(coords)[1:2] <- c("x", "y")
	if(plot)
		invisible(coords)
	else coords
}
"plnorm"<-
function(x, meanlog = 0, sdlog = 1)
	.S(plnorm(x, par1=meanlog, par2=sdlog), pnorm = )
"plogis"<-
function(x, location = 0, scale = 1)
	.S(plogis(x, par1=location, par2=scale), pnorm = )
"plot"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(plot.xy("plot"))
}
"plot.xy"<-
function(name, evaluate = T)
{
	caller <- sys.parent(2)
	plot.call <- sys.calls()[[sys.parent(1)]]
	args <- amatch(function(x, y, ..., xlab, ylab)
	{
	}
	, plot.call)
	default <- attr(args, "missing")
	if(default[1])
		stop("no data for x or y")
	xexpr <- args$x
# will be mode argument or a constant
	if(is.language(xexpr))
		xexpr <- xexpr[[1]]
	x <- eval(xexpr, caller)
	xexpr <- deparse(xexpr)
	if(is.list(x)) {
		if(any(is.na(match(c("x", "y"), names(x)))))
			stop("Cannot find x and y in list")
		y <- x$y
		x <- x$x
		if(default[4])
			xlab <- paste(xexpr, "$x", sep = "")
		else xlab <- eval(args$xlab[[1]], caller)
		if(default[5])
			ylab <- paste(xexpr, "$y", sep = "")
		else ylab <- eval(args$ylab[[1]], caller)
	}
	else if(is.complex(x)) {
		y <- Im(x)
		if(default[4])
			xlab <- paste("Re(", xexpr, ")", sep = "")
			
		else xlab <- eval(args$xlab[[1]], caller)
		if(default[5])
			ylab <- paste("Im(", xexpr, ")", sep = "")
			
		else ylab <- eval(args$ylab[[1]], caller)
		x <- Re(x)
	}
	else if((is.matrix(x) && ncol(x) == 2) && default[2]) {
		collabs <- dimnames(x)[[2]]
		n <- length(collabs)
		y <- x[, 2]
		x <- x[, 1]
		if(!default[4])
			xlab <- eval(args$xlab[[1]], caller)
		else if(n)
			xlab <- collabs[1]
		else xlab <- paste(xexpr, "[,1]", sep = "")
		if(!default[5])
			ylab <- eval(args$ylab[[1]], caller)
		else if(n)
			ylab <- collabs[2]
		else ylab <- paste(xexpr, "[,2]", sep = "")
	}
	else {
		if(default[2]) {
			if(default[4])
				xlab <- "Time"
			else xlab <- eval(args$xlab[[1]], caller)
			y <- x
			x <- time(x)
			if(default[5])
				ylab <- xexpr
			else ylab <- eval(args$ylab[[1]], caller)
		}
		else {
			if(default[4])
				xlab <- xexpr
			else xlab <- eval(args$xlab[[1]], caller)
			yexpr <- args$y
			if(is.language(yexpr))
				yexpr <- yexpr[[1]]
			if(default[5])
				ylab <- deparse(yexpr)
			else ylab <- eval(args$ylab[[1]], caller)
			y <- eval(yexpr, caller)
		}
	}
	name <- as.name(name)
	z <- list(name, x = x, y = y, xlab = xlab, ylab = ylab)
	other <- args$...[[1]]
	if(length(other) > 1)
		z <- c(z, other[-1])
	mode(z) <- "call"
	zz <- vector("S.call", 2)
	zz[[1]] <- z
	zz[[2]] <- name
	if(evaluate)
		eval(zz, caller)
	else zz
}
"plotfit"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(plotfit(...), plotfit = ))
}
"pmax"<-
function(...)
{
	all <- list(...)
	m <- all[[1]]
	for(el in all[-1]) {
		if(length(el) > length(m))
			m <- rep(m, length = length(el))
		else if(length(m) > length(el))
			el <- rep(el, length = length(m))
		l <- el > m
                l[is.na(el)] <- T
                l[is.na(m)] <- F
		m[l] <- el[l]
	}
	m
}
"pmin"<-
function(...)
{
	all <- list(...)
	m <- all[[1]]
	for(el in all[-1]) {
		if(length(el) > length(m))
			m <- rep(m, length = length(el))
		else if(length(m) > length(el))
			el <- rep(el, length = length(m))
		l <- el < m
                l[is.na(el)] <- T
                l[is.na(m)] <- F
		m[l] <- el[l]
	}
	m
}
"pnorm"<-
function(x, mean = 0, sd = 1)
	.S(pnorm(x, par1=mean, par2=sd), pnorm = )
"points"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(marks.xy("points", "lines"))
}
"polygon"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(marks.xy("polygon"))
}
"postscript"<-
function(file = "", command = "lp", horizontal = F, width = 0, height = 0,
	rasters = 300, pointsize = 14, font = 1, preamble = ps.preamble,
	fonts = ps.fonts, colors = ps.colors, region = ps.region)
{
	graphics.off()	# wrap-up for any existing graphics driver
	if(file!="") {
		where <- file
		how <- 0
	}
	else {
		where <- command
		how <- 1
	}
	d <- dim(colors)
	if(!is.null(d)) {
		if(d[2] == 4) {
			color.number <- trunc(colors[, 1])
			if(min(color.number) < 1)
				stop("color numbers must be at least 1")
			colors.new <- matrix(0, max(color.number), 3)
			colors.new[color.number,  ] <- colors[, -1]
			colors <- colors.new
		}
		else if(d[2] == 2) {
			color.number <- trunc(colors[, 1])
			if(min(color.number) < 1)
				stop("color numbers must be at least 1")
			colors.new <- rep(0, max(color.number))
			colors.new[color.number] <- colors[, 2]
			colors <- colors.new
		}
		else if(d[2]!=3)
			stop(
				"illegal color specification: need vector or 2-, 3- or 4-column matrix"
				)
	}
	z <- .C("postscript",
		as.character(where),
		as.integer(how),
		as.integer(horizontal),
		as.single(width),
		as.single(height),
		as.single(region),
		as.integer(rasters),
		as.single(pointsize),
		as.integer(font),
		as.character(fonts),
		as.integer(length(fonts)),
		as.integer(is.null(d)),
		as.single(colors),
		as.integer(if(is.null(d)) length(colors) else nrow(colors)),

			as.character(preamble),
		as.integer(length(preamble)))
	Device.Default("postscript")
	invisible(z[[1]])
}
"ppoints"<-
function(n,a=NULL){
	if(length(n)>1) n <- length(n)
	if(n<1) return(integer(0))
	if(is.null(a)) a <- if(n>10) .5 else .375
	if(a<0 || a>1) stop("a must be between 0 and 1")
	(seq(n)-a)/(n+1-2*a)
	}
"pr.data.list"<-
function(x)
{
	rows <- 1:length(x)
	labels <- names(x)
	if(is.null(labels))
		labels <- paste("[[", rows, ",]]", sep = "")
	for(i in rows) {
		xi <- x[[i]]
		cat(labels[i], "\n")
		if(is.atomic(xi))
			print(xi)
		else {
			clab <- names(xi)
			if(is.null(clab))
				clab <- paste("[[,", seq(along = xi), "]]",
					sep = "")
			for(j in 1:length(xi)) {
				xij <- xi[[j]]
				if(is.numeric(xij))
					xij <- format(xij)
				else if(is.character(xij))
					xij <- paste("\"", xij, "\"", sep = "")
					
				cat("  ", clab[j], "= ")
				cat(xij, sep = ", ", fill = T)
			}
		}
		cat("\n")
	}
}
"prarray"<-
function(x, quote = T)
{
	d <- dim(x)
	ndim <- length(d)
	dn <- dimnames(x)
	if(ndim == 1)
		prmatrix(matrix(x, 1, dimnames = list("", if(is.null(dn)) 
				character(0) else dn[[1]])), quote = quote)
		
	else if(ndim == 2)
		prmatrix(x, quote = quote)
	else {
		if(length(dn) < ndim)
			dn <- vector("list", ndim)
		for(i in 3:ndim)
			if(length(dn[[i]]) < d[i]) dn[[i]] <- paste(1:d[i])
		xm <- array(x[1], d[1:2])
		dimnames(xm) <- dn[1:2]
		d <- d[-(1:2)]
		nm <- length(xm)
		which <- 1:nm
		dn <- dn[-(1:2)]
		ndim <- ndim - 2
		counter <- rep(0, length(d))
		for(i in 1:(length(x)/nm)) {
			cat("\n, , ")
			for(j in 1:ndim)
				cat(dn[[j]][counter[j] + 1], if(j < ndim) ", "
					 else "\n", sep = "")
			xm[1:nm] <- x[which]
			prmatrix(xm, quote = quote)
			counter <- odometer(counter, d)
			which <- which + nm
		}
	}
	invisible(x)
}
"pratom"<-
function(x, quote=T)
{
	if(length(x) == 0)
		cat(mode(x), "(0)\n", sep = "")
	else .C("pratom",
			list(x),
			list(character(0)),
			as.logical(quote))
	invisible(x)
}
"prcomp"<-
function(...).S(prcomp(...), prcomp = )
"prefix"<-
function(...)stop("Function not implemented")
"pretty"<-
function(...).S(pretty(...), pretty = )
"print"<-
function(x, digits, quote = T, prefix = "")
{
	UseMethod()
	if(!missing(digits)) {
		if((length(digits)!=1 || digits < 1) || digits > 20)
			stop("Bad value for digits argument")
		d <- options(digits = digits)
		on.exit(options(d))
	}
	a <- attributes(x)
	if(!is.null(a$class) && exists(printer <- paste("pr.", a$class, sep = 
		""), mode = "function"))
		get(printer)(x)
	else if(length(a) - (is.recursive(x) && length(names(x))) > 0)
		prstructure(x, a, quote = quote, prefix = prefix)
	else switch(mode(x),
			numeric = ,
			logical = ,
			complex = ,
			character = pratom(x, quote),
			list = prlist(x, quote = quote, prefix = prefix),
			graphics = gr.display(x),
			dput(x))
	invisible(x)
}
"print.compiled"<-
function(x, file = "")invisible(.Internal(print.compiled(x, file), "S_deparse" = ,	T, 2))
"printer"<-
function(width = 80, height = 64, file = "", command = "")
{
	graphics.off()
	how <- 0
	if(command!="") {
		how <- 1
		file <- command
	}
	z <- .C("printer",
		as.integer(width),
		as.integer(height),
		as.character(file),
		as.integer(how))
	par(bty = "c", las = 1)
	Device.Default("printer")
}
"prlist"<-
function(l, quote = T, prefix = "")
{
	if(length(l) == 0)
		cat("list()\n")
	n <- names(l)
	if(is.null(n))
		n <- rep("", length(l))
	for(i in seq(along = l)) {
		this <- if(n[i] == "")
			paste(prefix, "[[", i, "]]", sep = "")
		else {
			nn <- .C("names_unlex",
				ans = n[i],
				as.integer(1))$ans
			paste(prefix, "$", nn, sep = "")
		}
		cat(this, ":\n", sep = "")
		print(l[[i]], quote = quote, prefix = this)
		cat("\n")
	}
	invisible(l)
}
"prmatrix"<-
function(x, rowlab = character(0), collab = character(0), quote = T)
{
	d <- dim(x)
	dnames <- dimnames(x)
	if(is.null(dnames))
		dnames <- list(rowlab, collab)
	else {
		if(!missing(rowlab))
			dnames[[1]] <- rowlab
		if(!missing(collab))
			dnames[[2]] <- collab
	}
	if(length(dnames[[1]]) == 0)
		dnames[[1]] <- paste("[", 1:d[1], ",]", sep = "")
	if(length(dnames[[2]]) == 0)
		dnames[[2]] <- paste("[,", 1:d[2], "]", sep = "")
	.C("prmatrix",
		list(x),
		as.character(dnames[[1]]),
		as.character(dnames[[2]]),
		as.logical(quote))
	invisible(x)
}
"proc.time"<-
function().Internal(proc.time(), "S_clock" = , T, 0)
"prod"<-
function(...).Internal(prod(...), "do_summary" = , T, 117)
"prompt"<-
function(name, filename = paste(name, ".d", sep = ""))
{
	name <- as.character(substitute(name))
	fn <- get(name)
	if(!is.function(fn)) {
		file <- c(".BG D", paste(".FN", name), ".TL", 
			"~1-line descr of data object", ".PP", 
			"~~Describe it here", ".KW dataset", ".WR")
	}
	else {
		n <- length(fn) - 1
		if(n > 0) {
			s <- 1:n
			args <- fn[s]
			arg.names <- names(args)
		}
		else s <- integer(0)
		file <- c(".BG", paste(".FN", name), ".TL", 
			"~function to do ???", ".CS")
		call <- paste(name, "(", sep = "")
		for(i in s) {
			if(mode(args[[i]]) == "missing")
				call <- paste(call, arg.names[i], sep = "")
				
			else call <- paste(call, arg.names[i], "=", deparse(
					args[[i]]), sep = "")
			if(i!=n)
				call <- paste(call, ", ", sep = "")
		}
		file <- c(file, paste(call, ")", sep = ""))
		for(i in s)
			file <- c(file, paste(".AG", arg.names[i]), paste(
				"~Describe", arg.names[i], "here"))
		file <- c(file, ".RT", "~Describe the value returned", ".EX",
			"# The function is currently defined as", deparse(
			fn), ".KW ~keyword", ".WR")
	}
	cat(file, file = filename, sep = "\n")
}
"prstructure"<-
function(x, a = attributes(x), quote = T, prefix = "")
{
	n <- length(dim(x))
	nn <- names(a)
	ate <- character(0)
	if(!is.atomic(x)) {
		print(as.vector(x), quote = quote, prefix = prefix)
		ate <- "names"
	}
	else if(n > 0) {
		if(n == 2)
			prmatrix(x, quote = quote)
		else prarray(x, quote = quote)
		ate <- c("dim", "dimnames")
		if(n == 1)
			ate <- c(ate, "names")
	}
	else if(length(tsp(x))) {
		prts(x, quote = quote)
		ate <- "tsp"
	}
	else if(length(names(x))) {
		prmatrix(matrix(x, 1, dimnames = list("", names(x))), quote
			 = quote)
		ate <- "names"
	}
	else print(as.vector(x), quote = quote)
	ii <- !match(nn, ate, nomatch = F)
	nn <- nn[ii]
	a <- a[ii]
	for(i in seq(nn)) {
		this <- paste("attr(", prefix, ", \"", nn[i], "\")", sep = 
			"")
		cat(this, ":\n", sep = "")
		print(a[[i]], quote = quote, prefix = this)
	}
	invisible(x)
}
"prts"<-
function(x, quote = T)
{
	.C("prts",
		list(x),
		as.logical(quote))
	invisible(x)
}
"pt"<-
function(x, df)
	.S(pt(x, par1=df), pnorm = )
"punif"<-
function(x, min = 0, max = 1)
	.S(punif(x, par1=min, par2=max), pnorm = )
"q"<-
function()
invisible(vector("quit"))
"qbeta"<-
function(x, shape1, shape2)
	.S(qbeta(x, par1=shape1, par2=shape2), qnorm = )
"qcauchy"<-
function(x, location = 0, scale = 1)
	.S(qcauchy(x, par1=location, par2=scale), qnorm = )
"qchisq"<-
function(x, df)
	.S(qchisq(x, par1=df), qnorm = )
"qexp"<-
function(p)
 - log(1 - ifelse(p < 0 | p >= 1, NA, p))
"qf"<-
function(x, df1, df2)
	.S(qf(x, par1=df1, par2=df2), qnorm = )
"qgamma"<-
function(x, shape)
	.S(qgamma(x, par1=shape), qnorm = )
"qlnorm"<-
function(x, meanlog = 0, sdlog = 1)
	.S(qlnorm(x, par1=meanlog, par2=sdlog), qnorm = )
"qlogis"<-
function(x, location = 0, scale = 1)
	.S(qlogis(x, par1=location, par2=scale), qnorm = )
"qnorm"<-
function(x, mean = 0, sd = 1)
	.S(qnorm(x, par1=mean, par2=sd), qnorm = )
"qqnorm"<-
function(x, datax = FALSE, plot.it = TRUE, xlab = 
	"Quantiles of Standard Normal", ylab = deparse(substitute(x)), ...)
{
	out <- is.na(x)
	if(any(out)) {
		xx <- x
		x <- x[!out]
	}
	y <- qnorm(ppoints(length(x)))[order(order(x))]
	if(any(out)) {
		yy <- y
		x <- y <- xx
		y[!out] <- yy
	}
	if(plot.it)
		if(datax)
			plot(x = x, y = y, xlab = ylab, ylab = xlab, ...)
			
		else plot(x = y, y = x, xlab = xlab, ylab = ylab, ...)
	invisible(if(datax) list(x = x, y = y) else list(x = y, y = x))
}
"qqplot"<-
function(x, y, plot.it = TRUE, xlab = deparse(substitute(x)), ylab = deparse(
	substitute(y)), ...)
{
	x <- sort(x)
	y <- sort(y)
	if(length(x) > length(y))
		x <- approx(1:length(x), x, n = length(y))$y
	if(length(y) > length(x))
		y <- approx(1:length(y), y, n = length(x))$y
	if(plot.it)
		plot(x, y, xlab = xlab, ylab = ylab, ...)
	invisible(list(x = x, y = y))
}
"qr"<-
function(x, tol = 1e-07)
{
	x <- as.matrix(x)
	storage.mode(x) <- "double"
	dx <- dim(x)
	dn <- dimnames(x)
	p <- dx[2]
	z <- .Fortran("dqr",
		qr = x,
		as.integer(dx),
		pivot = as.integer(1:p),
		qraux = double(p),
		as.double(tol),
		double(p),
		rank = as.integer(p))[c("qr", "qraux", "rank", "pivot")]
	if(z$rank < p && length(dn[[2]])) {
		pivot <- z$pivot
		qr <- z$qr
		dn[[2]] <- dn[[2]][pivot]
		dimnames(qr) <- dn
		z$qr <- qr
	}
	z
}
"qr.coef"<-
function(qr, y)
{
	if(!is.qr(qr))
		stop("First argument should be a qr object")
	qrqr <- qr$qr
	xcolnames <- dimnames(qrqr)[[2]]
	qra <- qr$qraux
	rank <- qr$rank
	dq <- dim(qrqr)
	if(is.matrix(y)) {
		dy <- dim(y)
		colnames <- dimnames(y)[[2]]
		coef <- matrix(0, dq[2], dy[2])
		if(!(is.null(xcolnames) && is.null(colnames)))
			dimnames(coef) <- list(xcolnames, colnames)
	}
	else {
		dy <- c(length(y), 1)
		coef <- double(dq[2])
		names(coef) <- xcolnames
	}
	if(dy[1]!=dq[1])
		stop("y and qr$qr should have same number of rows")
	storage.mode(y) <- "double"
	.Fortran("dqrsl1",
		qrqr,
		as.integer(dq),
		as.double(qra),
		as.integer(rank),
		y,
		as.integer(dy[2]),
		qy = y,
		coef = coef,
		as.integer(100),
		as.integer(1))$coef
}
"qr.fitted"<-
function(qr, y, start, end = qr$rank)
{
	qrqr <- qr$qr
	if(is.null(qrqr)) stop("First argument should be a qr object")
	qra <- qr$qraux
	dq <- dim(qrqr)
	if(is.matrix(y)) dy <- dim(y)
	else dy <- c(length(y),1)
	if(dy[1]!=dq[1]) stop("y and qr$qr should have same number of rows")
	storage.mode(y) <- "double"
	if(!(missing(start) || start<2))
		y <- .Fortran("dqrsl1",
		qrqr,
		as.integer(dq),
		qra,
		as.integer(start-1),
		y,
		as.integer(dy[2]),
		qy = y,
		resid = y,
		as.integer(10),
		as.integer(1))$resid

	.Fortran("dqrsl1",
		qrqr,
		as.integer(dq),
		qra,
		as.integer(end),
		y,
		as.integer(dy[2]),
		qy = y,
		f = y,
		as.integer(1),
		as.integer(1))$f
}
"qr.qty"<-
function(qr, y)
{
	qrqr <- qr$qr
	if(is.null(qrqr)) stop("First argument should be a qr object")
	qra <- qr$qraux
	rank <- qr$rank
	dq <- dim(qrqr)
	if(is.matrix(y)) dy <- dim(y)
	else dy <- c(length(y),1)
	if(dy[1]!=dq[1]) stop("y and qr$qr should have same number of rows")
	storage.mode(y) <- "double"
	.Fortran("dqrsl1",
		qrqr,
		as.integer(dq),
		qra,
		as.integer(rank),
		y,
		as.integer(dy[2]),
		qy = y,
		0.,
		as.integer(1000),
		as.integer(1))$qy
}
"qr.qy"<-
function(qr, y)
{
	qrqr <- qr$qr
	if(is.null(qrqr)) stop("First argument should be a qr object")
	qra <- qr$qraux
	rank <- qr$rank
	dq <- dim(qrqr)
	if(is.matrix(y)) dy <- dim(y)
	else dy <- c(length(y),1)
	if(dy[1]!=dq[1]) stop("y and qr$qr should have same number of rows")
	storage.mode(y) <- "double"
	.Fortran("dqrsl1",
		qrqr,
		as.integer(dq),
		qra,
		rank,
		y,
		as.integer(dy[2]),
		qy = y,
		0.,
		as.integer(10000),
		1)$qy
}
"qr.resid"<-
function(qr, y, end = qr$rank)
{
	qrqr <- qr$qr
	if(is.null(qrqr)) stop("First argument should be a qr object")
	qra <- qr$qraux
	dq <- dim(qrqr)
	if(is.matrix(y)) dy <- dim(y)
	else dy <- c(length(y),1)
	if(dy[1]!=dq[1]) stop("y and qr$qr should have same number of rows")
	storage.mode(y) <- "double"
	.Fortran("dqrsl1",
		qrqr,
		as.integer(dq),
		qra,
		as.integer(end),
		y,
		as.integer(dy[2]),
		qy = y,
		resid = y,
		as.integer(10),
		as.integer(1))$resid
}
"qt"<-
function(x, df)
	.S(qt(x, par1=df), qnorm = )
"quantile"<-
function(...).S(quantile(...), quantile = )
"query"<-
function(...)
.S(query(...), query = )

"quickvu"<-
function(...).S(quickvu(...), quickvu = )
"qunif"<-
function(x, min = 0, max = 1)
	.S(qunif(x, par1=min, par2=max), qnorm = )
"range"<-
function(...).Internal(range(...), "do_summary" = , T, 118)
"rank"<-
function(x){
	ranks <- sort.list(sort.list(x))
	for(i in unique(x[duplicated(x)])){
		which <- x == i
		ranks[which] <- mean(ranks[which])
	}
	ranks
}
"rbeta"<-
function(n, ...)qbeta(runif(n), ...)
"rbind"<-
function(...)
{
	nr <- 0
	ncol <- 0
	maxcols <- 0
	rownames <- list()
	colnames <- NULL
	alldata <- list(...)
	argnames <- names(alldata)
	if(is.null(argnames))
		argnames <- rep("", length(alldata))
	for(j in seq(alldata)) {
		thisname <- argnames[[j]]
		thisdata <- alldata[[j]]
		if(is.matrix(thisdata)) {
			d <- dim(thisdata)
			nr <- nr + d[1]
			if(ncol == 0)
				ncol <- d[2]
			else if(ncol!=d[2])
				stop(
					"number of columns of matrices and lengths named vectors must match"
					)
			dn <- dimnames(thisdata)
			if(length(dn[[1]]) > 0)
				rownames[[j]] <- dn[[1]]
			else rownames[[j]] <- rep("", d[1])
			if(length(dn[[2]]) > 0)
				colnames <- dn[[2]]
		}
		else if(length(thisdata) > 0) {
			colname <- names(thisdata)
			if(!is.null(colname)) {
				if(ncol == 0)
					ncol <- length(colname)
				else if(ncol!=length(colname))
					stop(
						"number of columns of matrices and lengths named vectors must match"
						)
				colnames <- colname
			}
			nr <- nr + 1
			maxcols <- max(maxcols, length(thisdata))
			rownames[[j]] <- thisname
		}
	}
	rownames <- unlist(rownames, recursive = F)
	if(ncol == 0)
		ncol <- maxcols
	if(ncol == 0 || nr == 0)
		return(NULL)
	x <- matrix(nrow = nr, ncol = ncol)
	j <- 1
	for(i in alldata) {
		if(is.matrix(i)) {
			jj <- j + dim(i)[1]
			x[j:(jj - 1),  ] <- i
			j <- jj
		}
		else if(length(i) > 0) {
			x[j,  ] <- i
			j <- j + 1
		}
	}
	if(all(rownames == ""))
		rownames <- NULL
	if(!(is.null(rownames) && is.null(colnames)))
		dimnames(x) <- list(rownames, colnames)
	x
}
"rbiwt"<-
function(...).S(rbiwt(...), rbiwt = )
"rcauchy"<-
function(n, ...)qcauchy(runif(n), ...)
"rchisq"<-
function(n, ...)qchisq(runif(n), ...)
"rdpen"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(rdpen(...), rdpen = ))
}
"read"<-
function(file = "", length.arg, mode = "numeric", print = T)
{
	value <- if(missing(length.arg))scan(file,vector(mode,0))
		else scan(file,vector(mode,0),length.arg)
	if(print)cat("Read",length(value),"items\n")
	value
}
"readline"<-
function()
unix("read h; echo $h")


"reg"<-
function(...).S(reg(...), reg = )
"regprt"<-
function(...)invisible(.S(regprt(...), regprt = ))
"regress"<-
function(..., print = T){
	r <- reg(...)
	if(print) {
		regprt(r)
		return(invisible(r))
	}
	else return(r)
}
"regsum"<-
function(...).S(regsum(...), regsum = )
"reload"<-
function()
warning("reload is currently inoperative")
"remove"<-
function(list, frame, where)
{
	if(missing(where)) {
		if(missing(frame)) .Internal(remove(list), "S_remove" = , T = T,
			0)
		else .Internal(remove(list, frame), "S_remove" = , T = T, 1)
	}
	else .Internal(remove(list, where), "S_remove" = , T = T, 2)
}
"rep"<-
function(x, times, length.out)
{
	if(missing(length.out))
		if(length(x) > 0)
			switch(storage.mode(x),
				integer = rep.int(x, times),
				x[rep.int(1:length(x), times)])
		else x
	else if(length(x) > 0)
		rep(x, ceiling(length.out/length(x)))[1:length.out]
	else rep(NA, length.out)
}
"rep.int"<-
function(x, times)
.Internal(rep.int(x, times), "S_rep" = , T, 0)
"replace"<-
function(x,list,values){
	x[list]<-values
	x
}
"restart"<-
function(on = TRUE)
.Internal(restart(on), "S_dummy" = , T, -7)


"restore"<-
function(file)
invisible(unix(paste("(echo 'options(keep=\"\")';cat", file,")|S NEW"), out = F))
"rev"<-
function(x)
if(length(x)) x[length(x):1] else x
"rexp"<-
function(n)
 - log(runif(n))
"rf"<-
function(n, ...)qf(runif(n), ...)
"rgamma"<-
function(n, ...)qgamma(runif(n), ...)
"rlnorm"<-
function(n, ...)qlnorm(runif(n), ...)
"rlogis"<-
function(n, ...)qlogis(runif(n), ...)
"rm"<-
function(..., list)
{
	if(missing(list))
		.Internal(rm(...), "S_dummy" = , F, -29)
	else .Internal(remove(list), "S_remove" = , T, 0)
}
"rnorm"<-
function(n, mean = 0, sd = 1)
.Internal(rnorm(n, mean, sd), "S_ranfuns" = , T, 1)
"round"<-
function(x, digits = 0).Internal(round(x, digits), "do_math" = , T, 105)
"row"<-
function(x)
{
	d <- dim(x)
	if(length(d)!=2)stop("x must be a matrix")
	storage.mode(x) <- "integer"
	x[] <- 1:d[1]
	x
}
"rreg"<-
function(...).S(rreg(...), rreg = )
"rstab"<-
function(n, index, skewness = 0)
{
	if(length(n) > 1) n <- length(n)
	.Fortran("stable",
		r = single(n),
		as.integer(n),
		as.single(index),
		as.single(skewness),
		as.single(runif(n)),
 		as.single(- log(runif(n))))$r
}
"rt"<-
function(n, ...)qt(runif(n), ...)
"runif"<-
function(n, min = 0, max = 1)
.Internal(runif(n, min, max), "S_ranfuns" = , T, 41)
"sabl"<-
function(...).S(sabl(...), sabl = )
"sablplot"<-
function(y, title = "")
{
	cnamy <- names(y)
	if(any(cnamy == "calendar")) {
		yuse <- list(trend = y$trend, seasonal = y$seasonal, calendar
			 = y$calendar, irregular = y$irregular)
		ydata <- y$trend + y$seasonal + y$calendar + y$irregular
		lbl <- "Corrected"
	}
	else {
		yuse <- list(trend = y$trend, seasonal = y$seasonal, irregular
			 = y$irregular)
		ydata <- y$trend + y$seasonal + y$irregular
		lbl <- "Data"
	}
	if(any(cnamy == "transformed"))
		yuse <- c(list(transformed = y$transformed), yuse)
	else if(any(cnamy == "y"))
		yuse <- c(list(transformed = y$y), yuse)
	else yuse <- c(list(transformed = ydata), yuse)
	oldpars <- par(mar = c(0.7, 5, 0.1, 0.5), oma = c(2, 0, 3.5, 0), mgp = c(1.5,
		0.5, 0), xaxs = "i", bty = "c", xpd = T, cex = 0.75)
	par(mfrow = c(length(yuse), 1))
	yrang <- lapply(yuse, range)
	barz <- 0.5 * min(sapply(yrang, diff))
	cen <- sapply(yrang, mean)
	tgo <- tsp(y$trend)[1]	# not start(x)
	tslast <- tsp(y$trend)[2]	# not end(x)
	ncyc <- frequency(y$trend)
	tsdel <- 1/ncyc
	xp1 <- tslast + c(3, 2, 2) * tsdel
	xp2 <- tslast + c(3, 4, 4) * tsdel
	yp1 <- c(1, 1, -1) * barz
	yp2 <- c(-1, 1, -1) * barz
	curr <- y$trend
	curr <- ts(c(curr[1], curr, curr[1:4]), start = tgo - tsdel, frequency
		 = ncyc)
	tsplot(curr, type = "n", axes = F)	# set up x axis
	par(xaxs = "d")	# and lock it in
	doplot <- substitute(function(which, ylab, middle, type)
	{
		tsplot(window(yuse[[which]], end = tslast, start = tgo), type
			 = type, ylab = ylab, axes = F)
		axis(2)
		axis(1, labels = F)
		box(1)
		segments(xp1, yp1 + middle, xp2, yp2 + middle)
	}
	)
	doplot(1, lbl, cen[1], "l")
	doplot(2, "Trend", cen[2], "l")
	doplot(3, "Seasonal", cen[3], "h")
	if(length(yuse) > 4)
		doplot(4, "Calendar", cen[4], "h")
	doplot(length(yuse), "Irregular", cen[length(cen)], "h")
	axis(1, outer = T, line = -0.4, ticks = F)	# label bottommost x axis
	if(!missing(title))
		mtext(side = 3, line = 1.5, cex = 1.5, outer = TRUE, title)
	if(any(cnamy == "power") && y$power!=1)
		mtext(side = 3, line = 0, outer = TRUE, cex = 0.75, paste(
			"Transformation power was", y$power))
	par(mfg = c(1, 1, 1, 1), new = F)
	par(oldpars)
	invisible()
}
"sample"<-
function(x, size = NULL, replace = F){
	n <- length(x)
	do.index <- n == 1 && x >= 0
	if(do.index) n <- x
	if(missing(size)) size <- n
	if(replace) index <- floor(runif(size) * n)+1
	else if(size/n > 0.75) index <- sort.list(runif(n))[1:size]
	else index <- .Internal(sample.index(size, n), "S_sample" = , T,
		0)
	if(do.index) index
	else x[index]
}
"sapply"<-
function(X, FUN, ...)
{
	if(is.character(FUN))
		FUN <- get(FUN, mode = "function")
	else if(mode(FUN)!="function") {
		farg <- substitute(FUN)
		if(mode(farg)=="name") FUN <- get(farg, mode = "function")
		else stop(paste("\"", farg, "\" is not a function",
			sep = ""))
	}
	answer <- X
	all.same <- NULL
	n <- length(X)
	for(i in seq(length = n)) {
		ans <- FUN(answer[[i]], ...)
		answer[[i]] <- ans
		all.same <- range(c(all.same, length(ans)))
	}
	if(all.same[1] == all.same[2])
		if(all.same[1] == 1)
			return(unlist(answer, recursive = F))
		else return(matrix(unlist(answer, recursive = F), ncol = n))
		
	else return(answer)
}
"save"<-
function(...){
	a <- list(...)
	n <- compname(a)
	for(i in 1:length(a)) assign(n[i], a[[i]], where=1)
}
"scale"<-
function(x, center, scale)
{
	x <- as.matrix(x)
	if(missing(center) || (is.logical(center) && center))
		center <- apply(x, 2, function(x)
		mean(x[!is.na(x)]))
	if(is.logical(center) && !center)
		center <- rep(0, ncol(x))
	if(length(center)!=ncol(x))
		stop("length of center must match number of columns of x")
	x <- x - matrix(center, nrow(x), ncol(x), byrow = T)
	mean.sq <- function(x)
	{
		x <- x[!is.na(x)]
		sum(x^2)/max(1, length(x) - 1)
	}
	if(missing(scale) || (is.logical(scale) && scale))
		scale <- sqrt(apply(x, 2, mean.sq))
	if(is.logical(scale) && !scale)
		scale <- rep(1, ncol(x))
	if(length(scale)!=ncol(x))
		stop("length of scale must match number of columns of x")
	x/matrix(scale, nrow(x), ncol(x), byrow = T)
}
"scan"<-
function(file="", what = double(0), n = -1, sep = "", multi.line = F, flush = F, append=F)
.Internal(scan(file, what, n,sep,multi.line, flush,append), "S_scan" = , T, 0)
"scan.list"<-
function(file = "", what, nmax = 10000, sep = "", record.sep = "\n", 
	label.field = "", row.names = "")
{
	on.exit({
		.C("unset_source")
		if(ttt!="")
			unlink(ttt)
	}
	)
	if(sep!="") {
		ttt <- tempfile("scan")
		if(file == "") {
			pgm <- if(interactive()) paste("awk \"-F", sep, 
					"\" 'BEGIN {nitem = 1; ttt=\"", ttt,
					
					"\"; printf(\"%d: \",nitem) > \"/dev/tty\"}\n/./ { for(i=1;i<=NF-1;i++) printf(\"%s, \",$i) > ttt\n\tif(NF>0)printf(\"%s\\n\",$NF) > ttt\n\tnitem += NF\n\tprintf(\"%d: \",nitem) > \"/dev/tty\"\n\t}\n/^$/ {exit }'",
					sep = "") else paste("awk \"-F", sep,
					"\" 'BEGIN{ ttt =\"", ttt, 
					"\"}\n/./ { for(i=1;i<=NF-1;i++) printf(\"%s, \",$i) > ttt\n\tif(NF>0)printf(\"%s\\n\",$NF) > ttt\n\t}'",
					sep = "")
		}
		else pgm <- paste("sed 's/", sep, "/, /g' <", file, " >", ttt,
				sep = "")
		unix(pgm, output = F)
		file <- ttt
	}
	else if(file == "") {
		file <- ttt <- tempfile("scan")
		pgm <- paste("awk \"-F:\" 'BEGIN{ ttt =\"", ttt, 
			"\"; printf(\"D>: \") > \"/dev/tty\"}\n/./ { for(i=1;i<=NF-1;i++) printf(\"%s, \",$i) > ttt\n\tif(NF>0)printf(\"%s\\n\",$NF) > ttt\n\tprintf(\"D>: \") > \"/dev/tty\"\n\t}\n/^$/ {exit}'",
			sep = "")
		unix(pgm, output = F)
	}
	.C("set_source",
		as.character(file))
	if(missing(what))
		what <- list(numeric(0))
	else if(!is.list(what))
		what <- list(what)
	if(!missing(row.names))
		label.field <- row.names
	nr <- 0
	npattern <- length(what)
	if(record.sep == "\n")
		record.sep <- NULL
	rows <- names(what)
	if(is.null(rows))
		rows <- character(length(what))
	value <- what
	while(nr < nmax) {
		record <- get.record(record.sep, what[[nr %% npattern + 1]],
			label.field)
		rec.name <- names(record)
		record <- record[[1]]
		if(mode(record) == "end.of.file")
			break
		nr <- nr + 1
		if(is.null(names(record)))
			record <- unlist(record)
		if(is.character(rec.name) && nchar(rec.name))
			rows[nr] <- rec.name
		value[[nr]] <- record
	}
	length(value) <- length(rows) <- nr
	names(value) <- rows
	attr(value, "class") <- "data.list"
	value
}
"scatmat"<-
function(...)
invisible(.S(scatmat(...), "scatmat"))
"search"<-
function(which = 2)return(.Search.list)
"segments"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(segments(...), segments = ))
}
"seq"<-
function(from = 1, to = 1, by = ((to - from)/(length.out - 1)), length.out = 
	NULL, along.with = NULL)
{
	if(!missing(along.with))
		length.out <- length(along.with)
	if(nargs() == 1 && !missing(from)) {
		if(mode(from) == "numeric" && length(from) == 1)
			1:from
		else seq(along.with = from)
	}
	else if(is.null(length.out))
		if(missing(by))
			from:to
		else {
			n <- (to - from)/by
			if(n < 0)
				stop("Wrong sign in by= argument")
			from + (0:n) * by
		}
	else if(length.out < 0)
		stop("Length cannot be negative")
	else if(length.out == 0)
		numeric(0)
	else if(missing(by)) {
		if(from == to || length.out < 2)
			by <- 1
		if(missing(to))
			to <- from + length.out - 1
		if(missing(from))
			from <- to - length.out + 1
		if(length.out > 2)
			c(from, from + (1:(length.out - 2)) * by, to)
		else c(from, to)[1:length.out]
	}
	else if(missing(to))
		from + (0:(length.out - 1)) * by
	else if(missing(from))
		to - ((length.out - 1):0) * by
	else stop("Too many arguments")
}
"set.seed"<-
function(i)
{
	.C("setseed",
		as.integer(i))
	invisible()
}
"show"<-
function(){
	if(exists(".Device") && .Device=="printer")
		.Fortran("zhookz",
			as.integer(1),
			single(1),
			as.integer(0),
			single(1),
			as.integer(0))
	invisible()
}
"signif"<-
function(x, digits = 6)
.Internal(signif(x, digits), "do_math" = , T, 130)
"sin"<-
function(x).Internal(sin(x), "do_math" = , T, 109)
"sinh"<-
function(x).Internal(sinh(x), "do_math" = , T, 122)
"sink"<-
function(file = "", command = "", append = F)
{
	iscommand <- file == "" && command!=""
	.C("S_sink",
		if(iscommand) command else file,
		as.logical(iscommand),
		as.logical(append))
	invisible(NULL)
}
"smatrix"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(smatrix(...), smatrix = ))
}
"smooth"<-
function(...).S(smooth(...), smooth = )
"solve"<-
function(a, b)
{
	if(!is.list(a))
		a <- qr(a)
	if(a$rank < ncol(a$qr))
		stop("apparently singular matrix")
	if(missing(b)) {
		b <- a$qr
		db <- dim(b)
		if(diff(db))
			stop("matrix inverse only for square matrices")
		b[] <- rep(c(1, rep(0, db[1])), length = prod(db))
	}
	qr.coef(a, b)
}
"sort"<-
function(x)
{
	x <- x[!is.na(x)]
	x[sort.list(x)]
}
"sort.list"<-
function(x).Internal(sort.list(x), "S_sort_list" = , T, 0)
"source"<-
function(file, local = F) {
	exprs <- parse(n = -1, file = file)
	echo <-.Options$echo
	prompt <-.Options$prompt
	for(i in exprs) {
	if(echo){ cat(prompt); dput(i)}
	yy <- eval(i, local)
	}
	invisible(yy)
}
"spin"<-
function(...)
.S(spin(...), "spin")
"spline"<-
function(...)
marks.xy("spline")
"split"<-
function(data, group)
{
	s <- .S(split(data, group), "split")
	if(mode(s)!="list") {
		s <- list(s)
		l <- levels(group)
		if(is.null(l))
			names(s) <- as.character(group[1])
		else names(s) <- l
	}
	n <- names(data)
	if(!is.null(n)) {
		sn <- .S(split(n, group), "split")
		if(mode(sn)!="list")
			sn <- list(sn)
		for(i in seq(along = s))
			names(s[[i]]) <- sn[[i]]
	}
	s
}
"sqrt"<-
function(x)x^0.5
"stamp"<-
function(string = date(), print = T, plot = T)
{
	if(print)
		cat(string, fill = T)
	if(plot && exists(".Device")) {
		p <- par("plt")
		u <- par("usr")
		em <- par("1em")
		text(u[2] + (u[2] - u[1])/(p[2] - p[1]) * (1 - p[2]) - 0.6 *
			em[1], u[3] - (u[4] - u[3])/(p[4] - p[3]) * p[3] + 0.6 *
			em[2], string, adj = 1)
	}
	.C("stamp_audit",
		as.character(string))
	invisible(string)
}
"stars"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(stars(...), stars = ))
}
"starsymb"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(starsymb(...), xstarsymb = ))
}
"start"<-
function(x) {
	i <- tsp(as.ts(x))
	j <- trunc(i[1])
	c(j,trunc((i[1]-j)*i[3]+1.5))
}
"std.trace"<-
function(call)
{
	trace.on(F)
	on.exit(trace.on(T))
	n <- sys.nframe()
	cat("Entering frame", n, substitute(call), "\n")
	trace.on(T)
	x <- call
	trace.on(F)
	cat("Frame", n, "value:", deparse(x, short = 40), "\n")
	x
}
"stem"<-
function(...).S(stem(...), stem = )
"stop"<-
function(message = NULL).Internal(stop(message), "S_dummy" = , T, -11)
"storage"<-
function().Internal(storage(), "S_storage" = , T, 0)
"storage.mode"<-
function(x)
.Internal(storage.mode(x), "S_extract" = , T, 15)
"structure"<-
function(.Data = NULL, ...)
{
	s <- .Data
	a <- list(...)
	for(i in names(a))
		attr(s, i) <- a[[i]]
	s
}
"substitute"<-
function(expr,frame)
.Internal(substitute(expr,frame), "S_dummy" = , F, -18)


"subtree"<-
function(...).S(subtree(...), subtree = )
"sum"<-
function(...).Internal(sum(...), "do_summary" = , T, 116)
"sun"<-
function(ask = F, color = F, display = "")
{
	graphics.off()
	z <- .C("csun",
		as.logical(ask),
		as.logical(color),
		as.character(display))
	Device.Default("sun")
}
"svd"<-
function(x, nu = min(n, p), nv = min(n,p))
{
	x <- as.matrix(x)
	storage.mode(x) <- "double"
	dmx <- dim(x)
	n <- dmx[1]
	p <- dmx[2]
	mm <- min(n + 1, p)
	mn <- min(dmx)
	code <- (if(nv) 1
	else 0) + 10 * (if(nu == 0) 0
	else if(nu == mn) 2
	else if(nu == n) 1
	else stop(
		"Invalid value for nu (must be 0, number of rows, or number of cols)"
		))
	u <- if(nu) matrix(0, n, nu)
	else 0
	v <- if(nv) matrix(0, p, p)
	else 0
	z <- .Fortran("dsvdc1",
		x,
		as.integer(dmx),
		as.integer(code),
		double(n),
		double(p),
		d = double(mm),
		u = u,
		v = v,
		errorcode = integer(1))
	if(z$errorcode) stop(paste("Numerical error (code", z$errorcode, 
		") in algorithm"))
	length(z$d) <- mn
	if(nv && nv<p) z$v <- z$v[,seq(nv)]
	z[c("d", if(nv) "v"
	else NULL, if(nu) "u"
	else NULL)]
}
"sweep"<-
function(A, MARGIN, STATS, FUN = "-"){
	if(is.character(FUN)) FUN <- get(FUN)
	d <- dim(A)
	perm <- c(MARGIN, seq(along=d)[ - MARGIN])
	FUN(A, aperm(array(STATS,d[perm]),order(perm)))
}
"switch"<-
function(EXPRESSION, ...)
.Internal(switch(EXPRESSION,
	...), "S_switch", F, -9)
"symbols"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(symbols(...), symbols = ))
}
"synchronize"<-
function(reset = F, assign = T, data = T)
.Internal(synchronize(reset, assign, data), "S_sync", T, 0)
"sys"<-
function(list = "")for(i in list) unix(i,output=F)
"sys.call"<-
function(i = 1){
	ttt <- sys.calls()
	ttt[[length(ttt) - i]]
}
"sys.calls"<-
function()
.Internal(sys.calls(), "S_debug" = , T, 6)
"sys.frame"<-
function().Internal(sys.frame(), "S_debug" = , T, 10)
"sys.frame0"<-
function()
.Internal(sys.frame0(), "S_frame0")
"sys.frames"<-
function().Internal(sys.frames(), "S_debug" = , T, 1)
"sys.function"<-
function(...)
.Internal(sys.parent(...), "S_debug", T, 11)
"sys.nframe"<-
function()
.Internal(sys.nframe(), "S_debug" = , T = T, 9)
"sys.on.exit"<-
function().Internal(sys.on.exit(), "S_debug" = , T, 2)
"sys.parent"<-
function(n = 1).Internal(sys.parent(n), "S_debug" = , T, 8)


"sys.parents"<-
function().Internal(sys.parents(), "S_debug" = , T, 8)


"sys.status"<-
function().Internal(sys.status(), "S_debug" = , T, 0)


"sys.trace" <-
function().Internal(sys.trace(),"S_trace",T,2)
"t"<-
function(a)
{
	a <- as.array(a)
	d <- dim(a)
	dn <- dimnames(a)
	k <- length(d)
	z <- .C("gt",
		NAOK = T,
		a,
		as.integer(switch(storage.mode(a),
			complex = 16,
			double = 8,
			4)),
		as.integer(d),
		as.integer(k),
		as.integer(k:1 - 1))
	if(length(dn) > 0)
		return(array(z[[1]], rev(d), rev(dn)))
	else return(array(z[[1]], rev(d)))
}
"table"<-
function(...)
{
	if(nargs() == 0)
		stop("No arguments")
	bin <- 0
	lens <- NULL
	dims <- numeric(0)
	pd <- 1
	dn <- list()
	args <- list(...)
	for(i in args) {
		if(is.null(lens))
			lens <- length(i)
		if(length(i)!=lens)
			stop("All arguments must have the same length")
		cat <- as.category(i)
		l <- levels(cat)
		dims <- c(dims, length(l))
		dn <- c(dn, list(l))
		bin <- bin + pd * (cat - 1)
		pd <- pd * length(l)
	}
	names(dn) <- names(args)
	bin <- bin[!is.na(bin)]
	array(tabulate(bin + 1, pd), dims, dn)
}
"tabulate"<-
function(bin, nbins)
.C("tabulate",
	ans = integer(nbins),
	as.integer(bin) - as.integer(1),
	length(bin))$ans
"tan"<-
function(x).Internal(tan(x), "do_math" = , T, 121)
"tanh"<-
function(x).Internal(tanh(x), "do_math" = , T, 124)
"tapply"<-
function(X, indices, FUN = NULL, ...)
{
	dim <- NULL
	if(!is.list(indices))
		indices <- list(indices)
	len.data <- length(X)
	all.indices <- rep(0, len.data)
	dim <- NULL
	labs <- NULL
	for(i in rev(indices)) {
		if(length(i)!=len.data)
			stop("Data and all indices must have same length")
		i <- as.category(i)
		lab <- levels(i)
		labs <- c(list(lab), labs)
		all.indices <- all.indices * length(lab) + (i - 1)	
	# zero-origin
		dim <- c(length(lab), dim)
	}
	all.indices <- all.indices + 1	# one-origin
	if(missing(FUN))
		return(all.indices)
	if(is.character(FUN))
		FUN <- get(FUN, mode = "function")
	else if(mode(FUN)!="function") {
		farg <- substitute(FUN)
		if(mode(farg)=="name") FUN <- get(farg, mode = "function")
		else stop(paste("\"", farg, "\" is not a function",
			sep = ""))
	}
	ans <- rep(NA, length = prod(dim))
	first <- T
	for(i in unique(all.indices)) {
		temp <- FUN(X[all.indices == i], ...)
		if(first && length(temp) > 1) {
			first <- FALSE
			j <- is.na(ans)
			mode(ans) <- "list"
			ans[j] <- list(NULL)
		}
		ans[[i]] <- temp
	}
	dim(ans) <- dim
	dimnames(ans) <- labs
	return(ans)
}
"tek4014"<-
function(ask = F, file = "")
{
	graphics.off()
	z <- .C("tek4014",
		as.logical(ask),
		as.character(file))
	Device.Default("tek4014")
}
"tek4105"<-
function(ask = F, file = "")
{
	graphics.off()
	z <- .C("tek4105",
		as.logical(ask),
		as.character(file))
	Device.Default("tek4105")
}
"tempfile"<-
function(pattern = "file")unix(paste("echo /tmp/", pattern, "$$", sep = ""))
"text"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(marks.xy("text"))
}
"time"<-
function(x) {
	i <- tsp(as.ts(x))
	x <- seq(from=i[1],to=i[2],len=length(x))
	tsp(x) <- i
	x
}
"title"<-
function(...){
	if(options("show")[[1]])invisible(.S(title(...), title = ))
	else {
		.Begin.pic()
		.Cur.pic(.S(title(...), title=))
	}
}
"tprint"<-
function(x)
{
	print(x, quote = F)
	invisible()
}
"trace"<-
function(what, tracer = "std.trace")
{
	trace.on(F)
	if(mode(what) == "function")
		what <- as.character(substitute(what))
	else what <- as.character(what)
	for(traced in what) .Internal(trace(traced, tracer), "S_trace" = )
	trace.on(T)
}
"trace.on" <-
function( on = T )
	.Internal(trace.on(on),"S_dummy",T,12);
"traceback"<-
function(data = last.dump)
{
	calls <- names(data)
	for(i in 1:length(calls)) cat(i, ": ", calls[i], "\n", sep = "")
}
"trunc"<-
function(x).Internal(trunc(x), "do_math" = , T, 104)
"ts"<-
function(data = NA, start = 1, frequency = 1, end = NULL)
{
	x <- as.vector(data)
	if(length(start) > 1) {
		if(length(start)!=2) stop("start vector too long")
		if(start[2]>frequency) stop("start incompatible with frequency")
		start <- start[1] + (start[2] - 1)/frequency
		}
	if(length(end) > 1){
		if(length(end)!=2) stop("end vector too long")
		if(end[2]>frequency) stop("end incompatible with frequency")
		end <- end[1] + (end[2] - 1)/frequency
		}
	if(missing(end))
		end <- start + (length(data) - 1)/frequency
	else if(missing(start))
		start <- end - (length(data) - 1)/frequency
	ndata <- trunc((end - start) * frequency + 1.01)
	if(ndata > length(x)) {
		if((ndata %% length(x)) > 0.001) warning(
			"Data for ts() is not an integral number of periods")
		x <- rep(x, length = ndata)
	}
	else if(ndata < length(x)) {
		warning("Extra data in ts() ignored")
		length(x) <- ndata
	}
	tsp(x) <- c(start, end, frequency)
	x
}


"tslines"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(tslines(...), tslines = ))
}
"tsmatrix"<-
function(...).S(tsmatrix(...), tsmatrix = )
"tsp"<-
function(x)
.Internal(tsp(x), "S_extract" = , T, 12)


"tsplot"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(tsplot(...), tsplot = ))
}
"tspoints"<-
function(...).S(tspoints(...), tslines = )
"tty5620"<-
function(ask = T, load = T, file = "")
{
	graphics.off()
	cat(
		"When the icon changes, use button 3 to designate rectangle for graphics\n"
		)
	z <- .C("tty5620",
		as.logical(ask),
		as.logical(load),
		"/usr/jerq/bin/32ld",
		"Sterm.5620",
		as.character(file))
	Device.Default("tty5620")
}
"tty630"<-
function(ask = F, load = T, file = "")
{
	graphics.off()
	cat(
		"When the icon changes, use button 3 to create a rectangle for graphics\n"
		)
	z <- .C("tty5620",
		as.logical(ask),
		as.logical(load),
		"/usr/630/bin/dmdld",
		"Sterm.630",
		as.character(file))
	Device.Default("tty630")
}
"twoway"<-
function(...).S(twoway(...), twoway = )
"uniq"<-
function(x)x[!duplicated(x)]
"unique"<-
function(x)x[!duplicated(x)]
"unix"<-
function(command,input, output.to.S = T){
	if(!missing(input)){
		file <- tempfile("unix")
		on.exit(unlink(file))
		cat(input,file=file,sep="\n")
		command <- paste("<",file,command)
	}
	if(output.to.S) .Internal(unix(command, T), "S_system" = , T, 0) else
	invisible(.Internal(unix(command, F), "S_system" = , T, 0))
}
"unix.time"<-
function(expr)
{
	l <- sys.parent(1)
	if(l==1)l <- F
	on.exit(cat("Timing stopped at:", proc.time() - time, "\n"))
	time <- proc.time()
	eval(expr, local = l)
	new.time <- proc.time()
	on.exit()
	if(length(new.time) == 3) new.time <- c(new.time,0,0)
	if(length(time) == 3) time <- c(time, 0, 0)
	new.time - time
}
"unlink"<-
function(x)
unix(paste("rm", paste(x, collapse = " ")), output = F)
"unlist"<-
function(..., recursive = T)
.Internal(list(..., recursive), "S_unlist", T, 2)
"untrace"<-
function(fun)
{
	if(missing(fun)) {
		.Internal(untrace(), "S_trace" = , T, 1)
		return(invisible())
	}
	if(mode(fun) == "function")
		what <- as.character(substitute(fun))
	else what <- as.character(fun)
	for(traced in what) .Internal(untrace(traced), "S_trace" = , T, 1)
	invisible()
}
"usa"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(usa(...), usa = ))
}
"var"<-
function(x, y = x)
{
	mat <- is.matrix(x)
	if(mat) n <- dim(x)[1]
	else n <- length(x)
	xm <- as.double(rep(1, n))
	dim(xm) <- c(n, 1)
	z <- (.Fortran("dqr",
		qr = xm,
		as.integer(c(n, 1)),
		pivot = as.integer(1),
		qraux = as.double(0.d+00),
		as.double(1.d-07),
		as.double(0.d+00),
		rank = as.integer(1)))[c("qr", "qraux", "rank", "pivot")]
	x <- qr.resid(z, x)
	if(nargs() == 2) {
		y <- qr.resid(z, y)
		z <- x %c% y
	}
	else z <- crossprod(x)
	(if(mat) z
	else as.vector(z))/(n - 1)
}
"vector"<-
function(mode = "logical", length = 0)
.Internal(vector(mode, length), "S_new_vector" = , T, 0)
"logical"<-
function(length=0)
.Internal(logical(length), "S_new_vector" = , T, 1)
"integer"<-
function(length=0)
.Internal(integer(length), "S_new_vector" = , T, 2)
"single"<-
function(length=0)
.Internal(single(length), "S_new_vector" = , T, 3)
"double"<-
function(length=0)
.Internal(double(length), "S_new_vector" = , T, 4)
"numeric"<-
function(length=0)
.Internal(numeric(length), "S_new_vector" = , T, 4)
"character"<-
function(length=0)
.Internal(character(length), "S_new_vector" = , T, 5)
"vi"<-
function(data, file)
{
	if(missing(data)) ed(editor = "vi")
	else if(missing(file)) ed(data, editor = "vi")
	else ed(data, file, editor = "vi")
}
"vu"<-
function(...)
{
	.Begin.pic()
	.Cur.pic(.S(vu(...), vu = ))
}
"warning"<-
function(message = NULL).Internal(warning(message), "S_dummy" = , T,	-10)
"warnings"<-
function()
{
	stuff <- last.warning
	n <- names(stuff)
	cat("Warning messages --\n")
	for(i in 1:length(n)) {
		cat(i, ": ", n[i], sep = "")
		if(length(stuff[[i]])) cat(", in", stuff[[i]])
		cat("\n")
	}
}


"window"<-
function(x, start = NULL, end = NULL)
{
	x <- as.ts(x)
	tsp.x <- tsp(x)
	freq <- tsp.x[3]
	if(missing(start))
		start <- tsp.x[1]
	else start <- switch(length(start),
			start,
			start[1] + (start[2] - 1)/freq,
			stop("Bad value for start"))
	if(missing(end))
		end <- tsp.x[2]
	else end <- switch(length(end),
			end,
			end[1] + (end[2] - 1)/freq,
			stop("Bad value for end"))
	if(start < tsp.x[1]) {
		start <- tsp.x[1]
		warning("start value not changed")
	}
	if(end > tsp.x[2]) {
		end <- tsp.x[2]
		warning("end value not changed")
	}
	if(start > end)
		stop("start cannot be after end")
	x <- x[trunc((start - tsp.x[1]) * freq + 1.5):trunc((end - tsp.x[1]) * freq + 1.5)]
	tsp(x) <- c(start, end, freq)
	x
}
"world.xy"<-
function(x, y)
.C("gr_transform",
	x = as.single(x),
	y = as.single(y),
	as.integer(length(x)),
	as.integer(length(y)),
	as.integer(1))[c("x", "y")]
"write"<-
function(x, file = "data", ncolumns = if(is.character(x)) 1 else 5,
	append=FALSE){
	extra <- length(x) %% ncolumns
	if(extra > 0) x <- c(x, rep(0, ncolumns - extra))
	xx <- matrix(x, nrow = ncolumns)
	nc <- ncol(xx)
	limit <- if(extra > 0) nc - 1 else nc
	for(i in seq(len=limit)) cat(xx[, i], file = file, append=i>1||append , "\n")
	if(extra > 0) cat(xx[, nc][1:extra], file = file, append=limit>0||append, "\n")
	invisible()
}
"x11"<-
function(ask = F, geometry = "", reverse = -1, display = "", close = F)
{
	graphics.off()
	z <- .C("x11",
		as.integer(ask),
		as.character(geometry),
		as.integer(reverse),
		as.character(display),
		as.integer(close))
	Device.Default("x11")
}
"xor"<-
function(x,y) (x|y) & !(x&y)
"xysort"<-
function(...)
marks.xy("xysort")
