#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create:
#	#Makefile#
#	Add.rationalnum.q
#	Div.rationalnum.q
#	Makefile
#	Math.rationalnum.q
#	Minus.rationalnum.q
#	Mult.rationalnum.q
#	Other.Combined.q
#	README
#	Sub.mathgraph.q
#	Sub.queue.q
#	Sub.rationalnum.q
#	Sub.stack.q
#	Sub.verify.q
#	SubGets.mathgraph.q
#	SubGets.queue.q
#	SubGets.rationalnum.q
#	SubGets.stack.q
#	abs.rationalnum.q
#	adjamat.d
#	adjamat.mathgraph.q
#	adjamat.q
#	alldirected.d
#	alldirected.default.q
#	alldirected.mathgraph.q
#	alldirected.q
#	as.numeric.rationalnum.q
#	as.rationalnum.default.q
#	as.rationalnum.q
#	as.rationalnum.rationalnum.q
#	bind.array.d
#	bind.array.q
#	browser.default.q
#	build.mathgraph.d
#	build.mathgraph.q
#	c.mathgraph.q
#	c.rationalnum.q
#	commontail.d
#	commontail.q
#	continue.fraction.d
#	continue.fraction.q
#	delay.eval.d
#	delay.eval.q
#	diffmask.d
#	diffmask.q
#	diffsccs.d
#	diffsccs.q
#	digamma.c
#	digamma.d
#	digamma.q
#	exp.integral.d
#	exp.integral.q
#	expand.d
#	expand.default.q
#	expand.q
#	filetest.d
#	filetest.q
#	find.I.of.d
#	find.I.of.q
#	find.assign.d
#	find.assign.q
#	from.base10.q
#	genopt.control.d
#	genopt.control.q
#	genopt.d
#	genopt.q
#	getpath.adjamat.q
#	getpath.d
#	getpath.default.q
#	getpath.incidmat.q
#	getpath.mathgraph.q
#	getpath.q
#	global.vars.d
#	global.vars.q
#	great.common.div.d
#	great.common.div.q
#	ignore.error.d
#	ignore.error.q
#	incidmat.d
#	incidmat.mathgraph.q
#	incidmat.q
#	interlude.d
#	interlude.q
#	interpolator.lagrange.d
#	interpolator.lagrange.q
#	is.na.rationalnum.q
#	is.nan.rationalnum.q
#	jjtest1.c
#	jjtest2.f
#	jjtest3.c
#	jjtest4.f
#	justify.d
#	justify.q
#	length.mathgraph.q
#	length.rationalnum.q
#	lengthGets.rationalnum.q
#	line.integral.d
#	line.integral.q
#	loan.d
#	loan.q
#	mathgraph.d
#	mathgraph.q
#	names.mathgraph.d
#	names.mathgraph.q
#	names.rationalnum.q
#	namesGet.rationalnum.q
#	namesGets.mathgraph.q
#	numberbase.d
#	numberbase.default.q
#	numberbase.numberbase.q
#	numberbase.q
#	p.replace.d
#	p.unpaste.d
#	p.unpaste.q
#	perl.d
#	perl.q
#	plot.mathgraph.d
#	plot.mathgraph.q
#	poet.data.restore.d
#	poet.data.restore.q
#	poet.dyn.load.d
#	poet.dyn.load.q
#	poet.verif.Q
#	poet.verif.d
#	polygamma.c
#	polygamma.d
#	polygamma.q
#	portopt.control.d
#	portopt.control.q
#	portopt1.d
#	portopt1.q
#	portopt_one.c
#	portoptgen.ctemplate.Q
#	portoptgen.d
#	portoptgen.q
#	portoptgen.stemplate.q
#	print.mathgraph.d
#	print.mathgraph.q
#	print.numberbase.q
#	print.queue.q
#	print.rationalnum.q
#	print.stack.q
#	print.verify.d
#	print.verify.q
#	quad.form.d
#	quad.form.q
#	quad_form.c
#	queue.d
#	queue.q
#	rand_seq.c
#	rationalnum.d
#	rationalnum.q
#	reduce.default.q
#	reduce.q
#	reduce.rationalnum.q
#	sccs.d
#	sccs.q
#	soptions.d
#	soptions.q
#	sort.mathgraph.d
#	sort.mathgraph.q
#	stable.apply.d
#	stable.apply.q
#	stack.d
#	stack.q
#	substifile.d
#	substifile.q
#	summary.interlude.q
#	symbol.address.d
#	symbol.address.q
#	symsqrt.d
#	symsqrt.q
#	to.base10.d
#	to.base10.q
#	transcribe.d
#	transcribe.q
#	unabbrev.value.d
#	unabbrev.value.q
#	uninterlude.q
#	unique.mathgraph.d
#	unique.mathgraph.q
#	unique.rationalnum.q
#	update.loan.d
#	update.loan.q
#	valid.s.name.d
#	valid.s.name.q
#	verify.d
#	verify.default.q
#	verify.q
#	verify.verify.q
#	whence.d
#	whence.q
#	xerrsp.f
# This archive created: Sat May  9 07:21:09 1998
export PATH; PATH=/bin:/usr/bin:$PATH
if test -f '#Makefile#'
then
	echo shar: "will not over-write existing file '#Makefile#'"
else
cat << \SHAR_EOF > '#Makefile#'
 Makefile created by S-PLUS utility CHAPTER, SCCS id 3.17
# S-PLUS Version 3.1 Release 1 for Sun SPARC, SunOS 4.x : 1992 for SUN4

SHOME=/usr/lang/s3.1

WHICH_LOAD=static.load
# WHICH_LOAD=dyn.load

EXTRA_OBJ_FILES=
EXTRA_C_NAMES=
EXTRA_F_NAMES=

# This is a Makefile produced by the S-PLUS utility CHAPTER. It guides
# compilation of C, Ratfor and Fortran source code, loading of the resulting
# object code, and installation of functions and helpfiles.
# 
# Overview: 
# ========
# 
# You will need to attend to a few 'make' macro settings at the top of this
# file first.  See the Detailed Instructions below for these. Then, if you
# want to compile and load the default set of C and Fortran routines, type
# (1) 'make install' to install functions on .Data and thereby enable
# building of the default list of compiled routine names, then (2) 'make
# load' to compile the object code, build the set of names to load, and load
# this object code.  Other, secondary, 'make' targets are 'install.funs' and
# 'install.help' ('install' makes both of those), 'clean' (remove only
# intermediate object code) and 'virgin' (remove object code, the local
# standalone S-PLUS executable if you built it, and the directory
# .Data).
# 
# Detailed Instructions:
# =====================
# 
# 1. On the line near the top that starts with "SHOME=", change the
# directory pathname on the right of the equals sign to the pathname of the
# top S-PLUS directory on your machine; use Splus SHOME to get this
# pathname.
# 
# 2. Near the top, the macro WHICH_LOAD specifies whether 'make' targets
# 'load' and 'all' should make a standalone S-PLUS binary executable named
# "local.Sqpe" which includes the local C and Fortran code, or a
# dyn.loadable file "spodist_l.o" containing only this local code.  To
# make a complete standalone executable, WHICH_LOAD should be set to
# "static.load"; the only other possible value is "dyn.load".  Make sure a
# comment symbol (#) appears in front of the setting you DON'T want.
# The default has been set to "static.load".
# 
# Incidentally, you can always make targets 'static.load' or 'dyn.load'
# regardless of the value of WHICH_LOAD. The macro just specifies what the
# generic targets 'load' and 'all' should make.
# 
# 3. Near the top, the macro EXTRA_OBJ_FILES names object files (ending in
# ".o") which should be loaded in addition to those which are part of this
# chapter.  Add any additional object file names you want to load, separated
# by spaces, on the right hand side of the equals sign.  There MUST be
# corresponding C (".c"), Ratfor (".r") or Fortran (".f") files present in
# this directory.
# 
# If you add file names to EXTRA_OBJ_FILES, you must also add the names of
# the corresponding C functions or Fortran subroutines to the macros
# EXTRA_C_NAMES and EXTRA_F_NAMES respectively, underneath EXTRA_OBJ_FILES.
# The names added should be as they appear at the source-code level; do not
# add leading or trailing underscores unless these are present in the
# source-level name.
# 
# You won't generally need to change any more 'make' macros, or indeed
# anything else in this Makefile.
# 
# 4. The file spodist_i.c is a C language source file which will ensure
# that the make target 'load' will load C and Fortran routines referenced
# only through .C or .Fortran calls in S functions. If spodist_i.c does
# not exist, it will be made during 'make load' based on the objects in
# .Data. If spodist_i.c exists already and you have since added new C
# or Fortran routine names to EXTRA_C_NAMES and EXTRA_F_NAMES, you must
# remove spodist_i.c so that it will get remade using this new
# information. Do this now.
# 
# 5. Type 'make install.funs' to create the S functions on .Data.  This
# must precede 'make load' in Step 6. (You can install the helpfiles at
# this point as well by typing making 'install' instead of 'install.funs'.)
# 
# 6. Type 'make load'. This will build the list of routines to load, then
# compile the C, Ratfor and Fortran source files specified by this Makefile,
# and lastly load the routines named on the list into either a standalone
# S-PLUS executable or a dyn.loadable file.
# 
# 7. To remove unnecessary object files, type 'make clean'. This will not
# remove the dyn.loadable file spodist_l.o or the standalone local.Sqpe.
# To clean out everything including .Data and start over, use 'make
# virgin'.
# 
# 8. See the helpfile for the "library" function in S-PLUS for hints on
# how to install the new code as a library section.


# ========================= End instructions. =============================

default : all
include $(SHOME)/newfun/lib/S_makefile
chapters=../spodist
SRC= digamma.c jjtest1.c jjtest2.f jjtest3.c jjtest4.f polygamma.c portopt_one.c quad_form.c rand_seq.c xerrsp.f
OBJ= digamma.o jjtest1.o jjtest2.o jjtest3.o jjtest4.o polygamma.o portopt_one.o quad_form.o rand_seq.o xerrsp.o $(EXTRA_OBJ_FILES)
CFLAGS=
FFLAGS=
FUNS=force_ld.q Add.rationalnum.q Div.rationalnum.q Math.rationalnum.q Minus.rationalnum.q Mult.rationalnum.q Sub.mathgraph.q Sub.queue.q Sub.rationalnum.q Sub.stack.q SubGets.mathgraph.q SubGets.queue.q SubGets.rationalnum.q SubGets.stack.q abs.rationalnum.q adjamat.mathgraph.q adjamat.q alldirected.default.q alldirected.mathgraph.q alldirected.q as.numeric.rationalnum.q as.rationalnum.default.q as.rationalnum.q as.rationalnum.rationalnum.q bind.array.q browser.default.q build.mathgraph.q c.mathgraph.q c.rationalnum.q commontail.q continue.fraction.q delay.eval.q diffmask.q diffsccs.q digamma.q exp.integral.q expand.default.q expand.q filetest.q find.I.of.q find.assign.q from.base10.q genopt.control.q genopt.q getpath.adjamat.q getpath.default.q getpath.incidmat.q getpath.mathgraph.q getpath.q global.vars.q great.common.div.q ignore.error.q incidmat.mathgraph.q incidmat.q interlude.q interpolator.lagrange.q is.na.rationalnum.q is.nan.rationalnum.q justify.q length.mathgraph.q length.rationalnum.q lengthGets.rationalnum.q line.integral.q loan.q mathgraph.q names.mathgraph.q names.rationalnum.q namesGet.rationalnum.q namesGets.mathgraph.q numberbase.default.q numberbase.numberbase.q numberbase.q p.unpaste.q perl.q plot.mathgraph.q poet.dyn.load.q polygamma.q portopt.control.q portopt1.q portoptgen.q portoptgen.stemplate.q print.mathgraph.q print.numberbase.q print.queue.q print.rationalnum.q print.stack.q print.verify.q quad.form.q queue.q rationalnum.q reduce.default.q reduce.q reduce.rationalnum.q sccs.q soptions.q sort.mathgraph.q stable.apply.q stack.q substifile.q summary.interlude.q symbol.address.q symsqrt.q to.base10.q transcribe.q unabbrev.value.q uninterlude.q unique.mathgraph.q unique.rationalnum.q update.loan.q valid.s.name.q verify.default.q verify.q verify.verify.q whence.q
HELPS= adjamat.d alldirected.d bind.array.d build.mathgraph.d commontail.d continue.fraction.d delay.eval.d diffmask.d diffsccs.d digamma.d exp.integral.d expand.d filetest.d find.I.of.d find.assign.d genopt.control.d genopt.d getpath.d global.vars.d great.common.div.d ignore.error.d incidmat.d interlude.d interpolator.lagrange.d justify.d line.integral.d loan.d mathgraph.d names.mathgraph.d numberbase.d p.replace.d p.unpaste.d perl.d plot.mathgraph.d poet.dyn.load.d poet.verif.d polygamma.d portopt.control.d portopt1.d portoptgen.d print.mathgraph.d print.verify.d quad.form.d queue.d rationalnum.d sccs.d soptions.d sort.mathgraph.d stable.apply.d stack.d substifile.d symbol.address.d symsqrt.d to.base10.d transcribe.d unabbrev.value.d unique.mathgraph.d update.loan.d valid.s.name.d verify.d whence.d
FLAGS= poet.verif.Q portoptgen.ctemplate.Q

all load: $(WHICH_LOAD)

static.load: spodist.a
	Splus LOAD $(FLAGS) CHAPTERS='"$(chapters)"'

dyn.load spodist_l.o: spodist.a
	ld -r -o spodist_l.o spodist_i.o spodist.a $(FLAGS)
	@echo dynamically loadable file in spodist_l.o

spodist.a: spodist_i.o $(OBJ) 
	Splus LIBRARY spodist.a spodist_i.o $(OBJ)

spodist_i.c:
	-mkdir .Data
	Splus make.init spodist .Data

install : install.funs install.help

funs install.funs : $(FUNS) .Data
	Splus QINSTALL .Data $(FUNS)

force_ld.q :
	( echo "force.loading <- function(){" ;\
	set $(EXTRA_C_NAMES) terminator ;\
	while test $$1 != terminator ;\
	do \
		echo $$1 | sed 's:.*:.C("&"):' ;\
		shift ;\
	done ;\
	set $(EXTRA_F_NAMES) terminator ;\
	while test $$1 != terminator ;\
	do \
		echo $$1 | sed 's:.*:.Fortran("&"):' ;\
		shift ;\
	done ;\
	echo } \
	) > $@


# force_ld.q :
# 	echo "force.loading <- function(){ X\
# 		stop(\"should not be executed\") X\
# 		# Add .C and .Fortran calls here to force routines to  X\
# 		# be loaded. For example, .C(\"fun1\"), .Fortran(\"fun2\"). X\
# 	}" | tr X \\012  > $@

help install.help : $(HELPS) .Data/.Help
	Splus HINSTALL .Data/.Help $(HELPS)
	Splus help.findsum .Data

.Data :
	-mkdir $@
.Data/.Help : .Data
	-mkdir $@

virgin : clean virgin.std
# add additional cleanup rules/targets above here for target 'virgin'
clean :
	rm -f $(OBJ) spodist_i.o S_load_time.[oc] core
virgin.std :
	rm -rf .Data
	rm -f spodist.a local.Sqpe spodist_l.o spodist_i.c force_ld.q














































SHAR_EOF
fi
if test -f 'Add.rationalnum.q'
then
	echo shar: "will not over-write existing file 'Add.rationalnum.q'"
else
cat << \SHAR_EOF > 'Add.rationalnum.q'
"+.rationalnum"<-
function(e1, e2)
{
	if(missing(e2))
		return(e1)
	e1 <- as.rationalnum(e1)
	e2 <- as.rationalnum(e2)	
	# propagate names, let default ops do the details
	num1 <- e1$numerator
	names(num1) <- names(e1)
	den2 <- e2$denominator
	names(den2) <- names(e2)
	rationalnum(num1 * den2 + e2$numerator * e1$denominator, e1$denominator *
		den2)
}
SHAR_EOF
fi
if test -f 'Div.rationalnum.q'
then
	echo shar: "will not over-write existing file 'Div.rationalnum.q'"
else
cat << \SHAR_EOF > 'Div.rationalnum.q'
"/.rationalnum"<-
function(e1, e2)
{
	e1 <- as.rationalnum(e1)
	e2 <- as.rationalnum(e2)
	num1 <- e1$numerator
	names(num1) <- names(e1)
	den2 <- e2$denominator
	names(den2) <- names(e2)
	rationalnum(num1 * den2, e1$denominator * e2$numerator)
}
SHAR_EOF
fi
if test -f 'Makefile'
then
	echo shar: "will not over-write existing file 'Makefile'"
else
cat << \SHAR_EOF > 'Makefile'
# Makefile created by S-PLUS utility CHAPTER, version 3.25
# S-PLUS Version 3.4 Release 1 for Silicon Graphics Iris, IRIX 5.3 : 1996 
# and then modified to suit the occasion.

SHOME=Change.This.For.Your.Machine

WHICH_LOAD=static.load
# WHICH_LOAD=dyn.load
# WHICH_LOAD=dyn.load.shared

# 
# Instructions:
# =============
#
# This assumes that you have S-PLUS on Unix.  
# If you don't, you're on your own.
#
# The first thing is to fix up this file for your setup.  Instructions
# are given below.  Probably you only need to do number 1.
#
# After you make the adjustments to this Makefile, here are the steps to do:
#
# A: At the Unix prompt, type "make install".
#	This creates a .Data subdirectory in the current directory,
#	installs the S functions, installs the help files, and
#	installs the other S objects.
#
# B: If you have dyn.load or dyn.load2 in your version of S, then
#	do "Splus COMPILE *.c" to compile the C code that goes with
#	some of the functions.
#    If you can't dyn.load, then take other measures as you see fit.
#
# C: If the test in step B was true, go into S and assign the path
#	of the current directory to the name "Poet.Location".
#
# D: Now everything should work.  Test it with the S command:
#	print(verify(poet.verif), short=T)
#
#	If you don't have the C compiled and loadable, then you can do:
#	print(verify(poet.verif[-c(7:14,22,28)]), short=T)
#
#	If there are other problems with the test, you will need to
#	investigate.
#
#
# Changing the Makefile
# =====================
# 
# 1. On the line near the top that starts with "SHOME=", change the
# directory pathname on the right of the equals sign to the pathname of the
# top S-PLUS directory on your machine; use Splus SHOME to get this
# pathname.
# 
# 2. Near the top, the macro WHICH_LOAD specifies whether 'make' targets
# 'load' and 'all' should make
# (a) a standalone S-PLUS binary executable named
# "local.Sqpe" which includes the local C and Fortran code, or
# (b) a dyn.loadable file "spodist_l.o" containing only this local code, or
# (c) a shared library "spodist.so" containing this local code
# and loadable with the dyn.load.shared function (this is the only form
# of dynamic loading available on Splus 3.3 for the Iris and Dec Alpha).
# To make a complete standalone executable, WHICH_LOAD should be set to
# "static.load"; the other possible values are "dyn.load" and
# "dyn.load.shared".  Make sure a # comment symbol (#) appears in front
# of the setting you DON'T want.
# The default has been set to "static.load".
# 
# Incidentally, you can always make targets 'static.load', 'dyn.load',
# and 'dyn.load.shared' regardless of the value of WHICH_LOAD.
# The macro just specifies what the generic targets 'load' and 'all'
# should make.
# 
# 
# 4. The file spodist_i.c is a C language source file which will ensure
# that the make target 'load' will load C and Fortran routines referenced
# only through .C or .Fortran calls in S functions. If spodist_i.c does
# not exist, it will be made during 'make load' based on the objects in
# .Data. If spodist_i.c exists already and you have since added new C
# or Fortran routine names to EXTRA_C_NAMES and EXTRA_F_NAMES, you must
# remove spodist_i.c so that it will get remade using this new
# information. Do this now.
# 
# 6. Type 'make load'. This will build the list of routines to load, then
# compile the C, Ratfor and Fortran source files specified by this Makefile,
# and lastly load the routines named on the list into either a standalone
# S-PLUS executable or a dyn.loadable file or a shared library.
# 
# 7. To remove unnecessary object files, type 'make clean'. This will not
# remove the dyn.loadable file spodist_l.o, the shared library
# spodist.so, or the standalone local.Sqpe.  To clean out everything
# including .Data and start over, use 'make virgin'.
# 
# 8. See the helpfile for the "library" function in S-PLUS for hints on
# how to install the new code as a library section.


# ========================= End instructions. =============================

default : all
include $(SHOME)/newfun/lib/S_makefile
chapters=../spodist
SRC=
OBJ= $(EXTRA_OBJ_FILES)
CFLAGS=-O1 
FFLAGS=-O1 
FUNS=Add.rationalnum.q justify.q Div.rationalnum.q length.mathgraph.q \
Math.rationalnum.q length.rationalnum.q Minus.rationalnum.q \
lengthGets.rationalnum.q Mult.rationalnum.q line.integral.q Sub.mathgraph.q \
loan.q Sub.queue.q mathgraph.q Sub.rationalnum.q names.mathgraph.q \
Sub.stack.q names.rationalnum.q SubGets.mathgraph.q namesGet.rationalnum.q \
SubGets.queue.q namesGets.mathgraph.q SubGets.rationalnum.q \
numberbase.default.q SubGets.stack.q numberbase.numberbase.q \
abs.rationalnum.q numberbase.q adjamat.mathgraph.q p.unpaste.q \
adjamat.q perl.q alldirected.default.q plot.mathgraph.q \
alldirected.mathgraph.q poet.dyn.load.q alldirected.q polygamma.q \
as.numeric.rationalnum.q portopt.control.q as.rationalnum.default.q \
portopt1.q as.rationalnum.q portoptgen.q as.rationalnum.rationalnum.q \
portoptgen.stemplate.q bind.array.q print.mathgraph.q browser.default.q \
print.numberbase.q build.mathgraph.q print.queue.q c.mathgraph.q \
print.rationalnum.q c.rationalnum.q print.stack.q commontail.q \
print.verify.q continue.fraction.q quad.form.q delay.eval.q queue.q \
diffmask.q rationalnum.q diffsccs.q reduce.default.q digamma.q reduce.q \
exp.integral.q reduce.rationalnum.q expand.default.q sccs.q expand.q \
soptions.q filetest.q sort.mathgraph.q find.I.of.q stable.apply.q \
find.assign.q stack.q from.base10.q substifile.q genopt.control.q \
summary.interlude.q genopt.q symbol.address.q getpath.adjamat.q \
symsqrt.q getpath.default.q to.base10.q getpath.incidmat.q transcribe.q \
getpath.mathgraph.q unabbrev.value.q getpath.q uninterlude.q \
global.vars.q unique.mathgraph.q great.common.div.q unique.rationalnum.q \
ignore.error.q update.loan.q incidmat.mathgraph.q valid.s.name.q \
incidmat.q verify.default.q interlude.q verify.q interpolator.lagrange.q \
verify.verify.q is.na.rationalnum.q whence.q is.nan.rationalnum.q \
poet.data.restore.q Sub.verify.q
HELPS=adjamat.d incidmat.d print.verify.d alldirected.d interlude.d \
quad.form.d bind.array.d interpolator.lagrange.d  queue.d \
build.mathgraph.d justify.d rationalnum.d commontail.d line.integral.d \
sccs.d continue.fraction.d loan.d soptions.d delay.eval.d mathgraph.d \
sort.mathgraph.d diffmask.d names.mathgraph.d stable.apply.d \
diffsccs.d numberbase.d stack.d digamma.d p.replace.d substifile.d \
exp.integral.d p.unpaste.d symbol.address.d expand.d perl.d symsqrt.d \
filetest.d plot.mathgraph.d to.base10.d find.I.of.d poet.data.restore.d \
transcribe.d find.assign.d poet.dyn.load.d unabbrev.value.d \
genopt.control.d poet.verif.d unique.mathgraph.d genopt.d polygamma.d \
update.loan.d getpath.d portopt.control.d valid.s.name.d global.vars.d \
portopt1.d verify.d great.common.div.d portoptgen.d whence.d \
ignore.error.d print.mathgraph.d
DDOBJS=poet.verif.Q portoptgen.ctemplate.Q
FLAGS=
RM=-rm

all load: $(WHICH_LOAD)

static.load: spodist.a
	Splus LOAD $(FLAGS) CHAPTERS='"$(chapters)"'

dyn.load spodist_l.o: spodist.a
	ld -r -o spodist_l.o spodist_i.o spodist.a $(FLAGS)
	@echo dynamically loadable file in spodist_l.o

dyn.load.shared spodist.so: $(SRC)
	Splus SHLIB -o spodist.so $(SRC)

spodist.a: spodist_i.o $(OBJ) 
	Splus LIBRARY spodist.a spodist_i.o $(OBJ)

spodist_i.c:
	-mkdir .Data
	Splus make.init spodist .Data

install : install.funs install.help install.objs

funs install.funs : $(FUNS) .Data
	Splus QINSTALL .Data $(FUNS)

install.objs: install.funs
	echo "poet.data.restore(unix('ls $(DDOBJS)'))" | Splus

force_ld.q :
	( echo "force.loading <- function(){" ;\
	set $(EXTRA_C_NAMES) terminator ;\
	while test $$1 != terminator ;\
	do \
		echo $$1 | sed 's:.*:.C("&"):' ;\
		shift ;\
	done ;\
	set $(EXTRA_F_NAMES) terminator ;\
	while test $$1 != terminator ;\
	do \
		echo $$1 | sed 's:.*:.Fortran("&"):' ;\
		shift ;\
	done ;\
	echo } \
	) > $@


# force_ld.q :
# 	echo "force.loading <- function(){ X\
# 		stop(\"should not be executed\") X\
# 		# Add .C and .Fortran calls here to force routines to  X\
# 		# be loaded. For example, .C(\"fun1\"), .Fortran(\"fun2\"). X\
# 	}" | tr X \\012  > $@

help install.help : $(HELPS) .Data/.Help
	Splus HINSTALL .Data/.Help $(HELPS)
	Splus help.findsum .Data

.Data :
	-mkdir $@
.Data/.Help : .Data
	-mkdir $@

virgin : clean virgin.std
# add additional cleanup rules/targets above here for target 'virgin'
clean :
	$(RM) -f $(OBJ) spodist_i.o S_load_time.[oc] core
virgin.std :
	$(RM) -rf .Data
	$(RM) -f spodist.a local.Sqpe spodist_l.o spodist.so spodist_i.c force_ld.q
SHAR_EOF
fi
if test -f 'Math.rationalnum.q'
then
	echo shar: "will not over-write existing file 'Math.rationalnum.q'"
else
cat << \SHAR_EOF > 'Math.rationalnum.q'
"Math.rationalnum"<-
function(x, ...)
{
	warning("coercing rational numbers to numeric")
	x <- as.numeric(x)
	NextMethod(.Generic)
}
SHAR_EOF
fi
if test -f 'Minus.rationalnum.q'
then
	echo shar: "will not over-write existing file 'Minus.rationalnum.q'"
else
cat << \SHAR_EOF > 'Minus.rationalnum.q'
"-.rationalnum"<-
function(e1, e2)
{
	e1 <- as.rationalnum(e1)
	if(missing(e2)) {
		e1$numerator <-  - e1$numerator
		return(e1)
	}
	e1 + ( - e2)
}
SHAR_EOF
fi
if test -f 'Mult.rationalnum.q'
then
	echo shar: "will not over-write existing file 'Mult.rationalnum.q'"
else
cat << \SHAR_EOF > 'Mult.rationalnum.q'
"*.rationalnum"<-
function(e1, e2)
{
	e1 <- as.rationalnum(e1)
	e2 <- as.rationalnum(e2)
	num1 <- e1$numerator
	names(num1) <- names(e1)
	num2 <- e2$numerator
	names(num2) <- names(e2)
	rationalnum(num1 * num2, e1$denominator * e2$denominator)
}
SHAR_EOF
fi
if test -f 'Other.Combined.q'
then
	echo shar: "will not over-write existing file 'Other.Combined.q'"
else
cat << \SHAR_EOF > 'Other.Combined.q'
"%e%"<-
function(x, y)
match(x, y, nomatch = 0) > 0
"browser.default"<-
function(frame, catch = T, parent, message = NULL, prompt = "b> ", readonly = F,
	...)
{
	if(!interactive()) {
# change to warning from stop in S-PLUS version
		warning("for interactive use")
		return(NULL)
	}
	if(!exists("old.error", frame = sys.nframe())) {
		old.error <- options(error = NULL, interrupt = NULL)
		on.exit(options(old.error))
	}
	nframe <- sys.parent(1)
	if(missing(parent))
		parent <- sys.parent(2)
	if(missing(frame))
		frame <- sys.parent(1)
	else if(is.numeric(frame)) {
		if(missing(message))
			message <- paste("browser: Frame", frame)
		if(missing(prompt))
			prompt <- paste("b(", frame, ")> ", sep = "")
	}
	if(is.numeric(frame)) {
		if(readonly)
			eval.frame <- new.frame(sys.frame(frame))
		else eval.frame <- frame
	}
	else eval.frame <- new.frame(frame)
	if(is.null(message)) {
		msg <- deparse(sys.call(nframe))
		if(length(msg) > 1)
			msg <- substring(paste(msg, collapse = " "), 1, 20)
		message <- paste("browser:", msg)
	}
	if(length(message))
		cat(message, "\n", file = "|stderr")
	choices <- names(sys.frame(eval.frame))	
	# SHOULD BE: choices <- frame.attr("names",eval.frame)
	n <- length(choices)
	index <- seq(len = n)
	for(i in rev(index))
		if(mode(frame[[i]]) != "argument") {
			n <- length(index) <- i
			break
		}
	if(catch)
		restart()
	repeat {
		i <- parse(prompt = prompt, n = 1)[[1]]
		switch(mode(i),
			numeric = {
				if(i > 0 && i <= n)
				  print(get(choices[i], frame = eval.frame))
				else if(i == 0)
				  return()
			}
			,
			"return" = return(eval(i[[1]], eval.frame, parent)),
			quit = return(),
			"?" = for(i in index)
				cat(i, ": ", choices[i], "\n", sep = "", file
				   = "|stderr"),
			"<-" = ,
			"<<-" = eval(i, eval.frame, parent),
			{
				assign(".Auto.print", T, frame = eval.frame)
				val <- eval(i, eval.frame, parent)
				if(get(".Auto.print", frame = eval.frame))
				  print(val)
			}
			)
	}
}
"cylinder"<-
function(r = ((2 * V)/pi/h)^0.5, h = (2 * V)/pi/r^2, V = 0.5 * pi * r^2 * h)
{
	if(nargs() != 2)
		stop("must give exactly two arguments")
	list(r = r, h = h, V = V)
}
"expand.twomat.reduced"<-
function(x)
{
	xn <- x$x
	yn <- x$y
	x$x <- get(xn["name"], where = xn["db"], immediate = T)
	x$y <- get(yn["name"], where = yn["db"], immediate = T)
	class(x) <- class(x)[-1]
	x
}
"fjjartshow2"<-
function(corners = 50, sieve = 10)
{
	repeat {
		switch(menu(c("(another) plot", "help on polygon"), title = 
				"type 0 to exit") + 1,
			break,
			{
				plot(1, type = "n", xlim = c(0, sieve), ylim = 
				  c(0, sieve), axes = F, ylab = "", xlab = "")
				polygon(sample(sieve, corners, replace = T), 
				  sample(sieve, corners, replace = T))
			}
			,
			help("polygon"))
	}
	invisible()
}
"fjjaugsym2"<-
function(a, b)
{
	da <- dim(a)
	db <- dim(b)
	newsize <- sum(db)
	ans <- array(NA, c(newsize, newsize))
	oseq <- 1:da[1]
	nseq <- 1:db[1] + da[1]
	ans[oseq, oseq] <- a
	part <- b %*% a
	ans[nseq, oseq] <- part
	part <- t(part)
	ans[oseq, nseq] <- part
	ans[nseq, nseq] <- b %*% part
	dna <- dimnames(a)[[1]]
	if(!length(dna))
		dna <- rep("", da[1])
	dnb <- dimnames(b)[[1]]
	if(!length(dnb))
		dnb <- rep("", db[1])
	newdn <- c(dna, dnb)
	if(sum(nchar(newdn)))
		dimnames(ans) <- list(newdn, newdn)
	ans
}
"fjjcheckdigam"<-
function()
{
	x <- c(1, 1.0549999999999999, 1.9650000000000001, 2, 56, 100)
	digx <- c(-0.57721566490152998, -0.4902094448, 0.39996053710000001, 
		0.42278433510000002, 4.0163965470000003, 4.6001618527000003)
	digamma(x) - digx
}
"fjjcheckdigamcom"<-
function()
{
	z <- c(2+10i, 1.3999999999999999+5.9000000000000004i, 
		1+8.4000000000000004i)
	digamz <- c(2.31332+1.4217900000000001i, 
		1.7853300000000001+1.4190700000000001i, 
		2.1294144191000002+1.5112699999999999i)
	digamma(z) - digamz
}
"fjjcheckexpint"<-
function(nterms)
{
	x <- c(1.95, 0.98999999999999999, 0.5, 0.01, 0.01, 0.01, 0.01, 1.01, 
		1.01, 1.01, 1.01, 1.01)
	n <- c(1, 1, 1, 3, 4, 10, 20, 2, 3, 4, 10, 20)
	enx <- c(0.052414380000000003, 0.223099826, 0.55977359500000001, 
		0.49027660000000001, 0.32838240000000002, 0.1098682, 0.052079, 
		0.1463199, 0.10821790000000001, 0.084973000000000007, 
		0.035992900000000001, 0.018153900000000001)
	if(missing(nterms))
		exp.integral(x, n) - enx
	else exp.integral(x, n, nterms = nterms) - enx
}
"fjjcheckexpintcomp"<-
function(nterms)
{
	z <- c(-2+0.20000000000000001i, 1i, 2.5+0.59999999999999998i)
	n <- rep(1, length(z))
	enzl <- c(-4.2192280000000002+0.63677899999999998i, 
		-0.33740399999999998+0.94608300000000001i, 
		0.96153200000000005+0.21821499999999999i)
	if(missing(nterms))
		exp.integral(z, n) + log(z) - enzl
	else exp.integral(z, n, nterms = nterms) + log(z) - enzl
}
"fjjchecknumberbase"<-
function(x, ...)
{
	xnb <- numberbase(x, ...)
	xbase <- attr(xnb, "base")
	xnb <- as.vector(xnb)
	for(i in 2:36) {
		this.nb <- numberbase(xnb, new = i, old = xbase)
		this.back <- numberbase(as.vector(this.nb), new = xbase, old = 
			i)
		if(any(this.back != xnb))
			stop(paste("bad conversion between bases", xbase, "and",
				i))
		else cat("bases", xbase, "and", i, "okay\n")
	}
}
"fjjcheckpolygam"<-
function(...)
{
	x <- c(1.095, 1.9199999999999999, 1.1100000000000001, 
		1.1100000000000001, 1.98, 1.98)
	n <- c(1, 1, 2, 3, 2, 3)
	pg <- c(1.4426631754999999, 0.67892312929999998, -1.8170975731000001, 
		4.3602088083000003, -0.4141726631, 0.51208911270000002)
	polygamma(x, n, ...) - pg
}
"fjjcheckrationalnum"<-
function(num = c( - Inf, -10, -7, -4, -2, -1, 0, 1, 2, 4, 7, 10, Inf, NA, 0/0), 
	den = num, test = T)
{
	anum <- expand.grid(num, den)
	ratnum <- rationalnum(anum[, 1], anum[, 2])
	if(test) {
		ans <- all.equal(anum[, 1]/anum[, 2], ratnum$num/ratnum$den)
		if(is.logical(ans) && ans) {
			cat("values okay, now checking NaN's\n")
			all.equal(is.nan(anum[, 1]/anum[, 2]), is.nan(ratnum))
		}
		else ans
	}
	else {
		attr(ratnum, "original") <- anum
		ratnum
	}
}
"fjjcheckratop"<-
function(op, r1, r2, test = T)
{
	unary <- missing(r2)
	n1 <- as.numeric(r1)
	if(unary) {
		ra <- eval(parse(text = paste(op, deparse(substitute(r1)))))
		na <- get(op)(n1)
	}
	else {
		n2 <- as.numeric(r2)
		ra <- eval(parse(text = paste(deparse(substitute(r1)), op, 
			deparse(substitute(r2)))))
		na <- get(op)(n1, n2)
	}
	if(test)
		all.equal(na, as.numeric(ra))
	else cbind(na, as.numeric(ra))
}
"fjjcomma"<-
function(x)
{
	format(x, big.mark = ",", scienti = F)
}
"fjjdigamdup"<-
function(z)
{
	Mod(0.5 * digamma(z) + 0.5 * digamma(z + 0.5) + log(2) - digamma(2 * z)
		)
}
"fjjdigamreflect"<-
function(z)
{
	Mod(digamma(z) + pi/tan(pi * z) - digamma(1 - z))
}
"fjjpolygammult"<-
function(x, n, mult = 2, ...)
{
	if(length(n) != 1 || length(mult) != 1)
		stop("bad input")
	partials <- polygamma(outer(x, (0:(mult - 1))/mult, "+"), n)
	partials <- partials %*% rep(mult^( - (n + 1)), mult)
	drop((polygamma(x * mult, n, ...) - partials)/abs(partials))
}
"fjjrand.seq"<-
function(threshold, mean = 0, sd = 1, increment = 1000, safety = 10000)
{
	if(!is.loaded(symbol.C("rand_seq_Sp")))
		poet.dyn.load("rand_seq.o")
	ans <- .C("rand_seq_Sp",
		parameters = as.double(c(threshold[1], mean[1], sd[1])),
		as.integer(c(increment[1], safety[1])),
		sequence = double(0),
		pointers = c(F, F, T))[c("sequence", "parameters")]
	names(ans$parameters) <- c("threshold", "mean", "stand dev")
	ans$call <- match.call()
	ans
}
"fjjrowmin"<-
function(xmat, new =  - Inf)
{
	rmin <- apply(xmat, 1, function(x)
	order(x)[1])
	xmat[cbind(1:nrow(xmat), rmin)] <- new
	xmat
}
"fjjsimbk"<-
function(n, dof, trials = 100)
{
	backup <- paste("sbk.BACKUP", unix("echo $$"), sep = ".")
	simbk.sub <- function(n, dof)
	{
		sum(rt(n, dof))
	}
	ans <- numeric(trials)
	attr(ans, "call") <- match.call()
	for(i in 1:trials) {
		ans[i] <- simbk.sub(n, dof)
		if(i %% 10 == 0)
			assign(backup, ans, where = 1, immediate = T)
	}
	ans
}
"fjjtwomat"<-
function(n, m, k)
{
	seed <- .Random.seed
	ans <- list(x = array(rnorm(n * m), c(n, m)), y = array(rnorm(m * k), c(
		m, k)))
	ans$seed <- seed
	class(ans) <- "twomat"
	ans
}
"p.replace"<-
function(x, old, new)
{
	if(length(old) != length(new))
		stop("old and new must be same length")
	x.ind <- match(x, old, nomatch = 0)
	x[as.logical(x.ind)] <- new[x.ind[x.ind != 0]]
	x
}
"reduce.twomat"<-
function(x, immediate = F)
{
# attempt to make unique name
	basename <- paste("rEdUtwomat", unix("echo $$"), sep = ".")	#
# ensure that it is unique
	xname <- paste(basename, "x", sep = ".")
	count <- 0
	bnchar <- nchar(basename)
	while(exists(xname, where = 1)) {
		count <- count + 1
		basename <- paste(substring(basename, 1, bnchar), count, sep = 
			".")
		xname <- paste(basename, "x", sep = ".")
	}
	yname <- paste(basename, "y", sep = ".")
	dbname <- search()[1]	# need absolute path
	if(AsciiToInt(dbname)[1] != 47) {
		dbname <- paste(unix("pwd"), dbname, sep = "/")
	}
	assign(xname, x$x, where = 1, immediate = immediate)
	assign(yname, x$y, where = 1, immediate = immediate)
	x$x <- c(name = xname, db = dbname)
	x$y <- c(name = yname, db = dbname)
	class(x) <- c("twomat.reduced", class(x))
	x
}
"rmatsqrt"<-
function(x)
{
	xc <- chol(x)
	x[] <- runif(dim(x)[1]^2)
	orthmat <- svd(x)$v
	orthmat %*% xc
}
"switch.chartest"<-
function(this.op)
{
	ans <- switch(this.op,
		a = {
			cat("doing a\n")
			1
		}
		,
		b = {
			cat("doing b\n")
			2
		}
		,
		{
			cat("doing other\n")
			3
		}
		)
	ans
}
"twice"<-
function(x)
{
	2 * x + dnorm(x - 2, sd = 1/sqrt(2 * pi)/5)/5
}
SHAR_EOF
fi
if test -f 'README'
then
	echo shar: "will not over-write existing file 'README'"
else
cat << \SHAR_EOF > 'README'
The accompanying software is copyright 1998 Patrick J. Burns.
It may be used freely, but not sold.  It may also be redistributed,
but not sold.

Instructions for installing the software are in the Makefile.

You will want to have "make" on your path, and it will be good to
have Perl on it also.

The installation procedure does not do anything with the
"Other.Combined.q" file.  This contains functions discussed in the
book which are of less interest.  If you want these functions, you
need to source this file yourself.  The functions that it contains
are:

> manifest.other
 [1] "%e%"                   "browser.default"       "cylinder"
 [4] "expand.twomat.reduced" "fjjartshow2"           "fjjaugsym2"
 [7] "fjjcheckdigam"         "fjjcheckdigamcom"      "fjjcheckexpint"
[10] "fjjcheckexpintcomp"    "fjjchecknumberbase"    "fjjcheckpolygam"
[13] "fjjcheckrationalnum"   "fjjcheckratop"         "fjjcomma"
[16] "fjjdigamdup"           "fjjdigamreflect"       "fjjpolygammult"
[19] "fjjrand.seq"           "fjjrowmin"             "fjjsimbk"
[22] "fjjtwomat"             "p.replace"             "reduce.twomat"
[25] "rmatsqrt"              "switch.chartest"       "twice"

SHAR_EOF
fi
if test -f 'Sub.mathgraph.q'
then
	echo shar: "will not over-write existing file 'Sub.mathgraph.q'"
else
cat << \SHAR_EOF > 'Sub.mathgraph.q'
"[.mathgraph"<-
function(x, i)
{
	cl <- class(x)
	x <- unclass(x)
	xdir <- attr(x, "directed")
	if(is.character(i))
		names(xdir) <- dimnames(x)[[1]]
	x <- x[i,  , drop = F]
	attr(x, "directed") <- xdir[i]
	class(x) <- cl
	x
}
SHAR_EOF
fi
if test -f 'Sub.queue.q'
then
	echo shar: "will not over-write existing file 'Sub.queue.q'"
else
cat << \SHAR_EOF > 'Sub.queue.q'
"[.queue"<-
function(x, i)
{
	if(!missing(i))
		stop("only empty subscripting allowed")
	xname <- deparse(substitute(x))
	size <- attr(x, "size")
	if(!size)
		return(NULL)
	ans <- unclass(x)[[1]]
	xname <- deparse(substitute(x))
	xloc <- whence(xname, offset = 1)
	if(size > 1) {
		xat <- attributes(x)
		x <- as.vector(x)
		sizeseq <- 1:(size - 1)
		x[sizeseq] <- x[sizeseq + 1]
		attributes(x) <- xat
	}
	attr(x, "size") <- size - 1
	if(xloc < 0)
		assign(xname, x, frame = abs(xloc))
	else assign(xname, x, where = min(xloc, 1))
	ans
}
SHAR_EOF
fi
if test -f 'Sub.rationalnum.q'
then
	echo shar: "will not over-write existing file 'Sub.rationalnum.q'"
else
cat << \SHAR_EOF > 'Sub.rationalnum.q'
"[.rationalnum"<-
function(x, i)
{
	if(is.character(i))
		i <- pmatch(i, x$names, dup = T)
	x$numerator <- x$numerator[i]
	x$denominator <- x$denominator[i]
	x$names <- x$names[i]
	x
}
SHAR_EOF
fi
if test -f 'Sub.stack.q'
then
	echo shar: "will not over-write existing file 'Sub.stack.q'"
else
cat << \SHAR_EOF > 'Sub.stack.q'
"[.stack"<-
function(x, i)
{
	if(!missing(i))
		stop("only empty subscripting allowed")
	xname <- deparse(substitute(x))
	size <- attr(x, "size")
	if(!size)
		return(NULL)
	ans <- unclass(x)[[size]]
	xname <- deparse(substitute(x))
	xloc <- whence(xname, offset = 1)
	attr(x, "size") <- size - 1
	if(xloc < 0)
		assign(xname, x, frame = abs(xloc))
	else assign(xname, x, where = min(xloc, 1))
	ans
}
SHAR_EOF
fi
if test -f 'Sub.verify.q'
then
	echo shar: "will not over-write existing file 'Sub.verify.q'"
else
cat << \SHAR_EOF > 'Sub.verify.q'
"[.verify"<-
function(x, i)
{
	xat <- attributes(x)
	xat$passed <- xat$passed[i]
	xat$commands <- xat$commands[i]
	x <- unclass(x)
	x <- x[i]
	xat$names <- names(x)
	attributes(x) <- xat
	x
}
SHAR_EOF
fi
if test -f 'SubGets.mathgraph.q'
then
	echo shar: "will not over-write existing file 'SubGets.mathgraph.q'"
else
cat << \SHAR_EOF > 'SubGets.mathgraph.q'
"[<-.mathgraph"<-
function(x, i, value)
{
	if(!inherits(value, "mathgraph"))
		stop("need mathgraph on right-hand side")
	cl <- class(x)
	x <- unclass(x)
	value <- unclass(value)
	ilen <- length(i)
	if(is.logical(i))
		ilen <- sum(rep(i, length = nrow(x)))
	if(nrow(value) != ilen)
		stop("replacement value not correct length")
	xdir <- attr(x, "directed")
	if(is.character(i))
		names(xdir) <- dimnames(x)[[1]]
	x[i,  ] <- value
	xdir[i] <- attr(value, "directed")
	attr(x, "directed") <- xdir
	class(x) <- cl
	x
}
SHAR_EOF
fi
if test -f 'SubGets.queue.q'
then
	echo shar: "will not over-write existing file 'SubGets.queue.q'"
else
cat << \SHAR_EOF > 'SubGets.queue.q'
"[<-.queue"<-
function(x, i, value)
{
	if(!missing(i))
		stop("only empty subscripting allowed")
	size <- attr(x, "size")
	if(size == length(x)) {
		update <- attr(x, "update")
		xat <- attributes(x)
		if(is.logical(update)) {
			if(update) {
				length(x) <- 2 * length(x)
			}
			else stop("queue overflow")
		}
		else {
			length(x) <- length(x) + update
		}
		attributes(x) <- xat	# length change destroys attributes
	}
	x[[size + 1]] <- value
	attr(x, "size") <- size + 1
	x
}
SHAR_EOF
fi
if test -f 'SubGets.rationalnum.q'
then
	echo shar: "will not over-write existing file 'SubGets.rationalnum.q'"
else
cat << \SHAR_EOF > 'SubGets.rationalnum.q'
"[<-.rationalnum"<-
function(x, i, value)
{
	value <- as.rationalnum(value)
	den <- x$denominator
	num <- x$numerator
	names(den) <- names(num) <- x$names
	den[i] <- value$denominator
	num[i] <- value$numerator
	x$denominator <- den
	x$numerator <- num
	x$names <- names(den)
	x
}
SHAR_EOF
fi
if test -f 'SubGets.stack.q'
then
	echo shar: "will not over-write existing file 'SubGets.stack.q'"
else
cat << \SHAR_EOF > 'SubGets.stack.q'
"[<-.stack"<-
function(x, i, value)
{
	if(!missing(i))
		stop("only empty subscripting allowed")
	size <- attr(x, "size")
	if(size == length(x)) {
		update <- attr(x, "update")
		xat <- attributes(x)
		if(is.logical(update)) {
			if(update) {
				length(x) <- 2 * length(x)
			}
			else stop("stack overflow")
		}
		else {
			length(x) <- length(x) + update
		}
		attributes(x) <- xat	# length change destroys attributes
	}
	x[[size + 1]] <- value
	attr(x, "size") <- size + 1
	x
}
SHAR_EOF
fi
if test -f 'abs.rationalnum.q'
then
	echo shar: "will not over-write existing file 'abs.rationalnum.q'"
else
cat << \SHAR_EOF > 'abs.rationalnum.q'
"abs.rationalnum"<-
function(x)
{
	x$numerator <- abs(x$numerator)
	x$denominator <- abs(x$denominator)
	x
}
SHAR_EOF
fi
if test -f 'adjamat.d'
then
	echo shar: "will not over-write existing file 'adjamat.d'"
else
cat << \SHAR_EOF > 'adjamat.d'
.BG
.FN adjamat
.FN adjamat.mathgraph
.TL
Adjacency Matrix of a Mathematical Graph
.DN
Returns an object of class `"adjamat"' which is the adjacency matrix of a graph.
.CS
adjamat.mathgraph(x, general=F)
.RA
.AG x
an object of class `"mathgraph"'.
.OA
.AG general
logical flag, if `TRUE', then multiple edges or arcs between the same nodes
are counted; otherwise, there is a `1' no matter how many edges or arcs 
there are.
.RT
an object of class `"adjamat"' which is a square matrix with as many rows and
columns as there are nodes.
The `i',`j' element is an indicator of an arc from node `i' to node `j'.
An undirected edge between nodes `i' and `j' contribute a `1' to both the
`i',`j' element and the `j',`i' element.
.DT
`adjamat' is a generic function with a method for class `"mathgraph"'.
.SH REFERENCES
Chachra, V., Ghare, P. M. and Moore, J. M. (1979).
.ul
Applications of Graph Theory Algorithms.
Elvesier North Holland, New York.
.SH BUGS
The `general' argument to `adjamat.mathgraph' is not functional.
.SA
`mathgraph', `incidmat', `getpath.adjamat'.
.EX
adjamat(mathgraph(~ 1:3 * 3:5, dir=T))
.KW math
.WR
SHAR_EOF
fi
if test -f 'adjamat.mathgraph.q'
then
	echo shar: "will not over-write existing file 'adjamat.mathgraph.q'"
else
cat << \SHAR_EOF > 'adjamat.mathgraph.q'
"adjamat.mathgraph"<-
function(x, general = F)
{
	x <- unclass(x)
	xdir <- attr(x, "directed")
	ischar <- is.character(x)
	if(ischar) {
		nnam <- unique(x)
		nnode <- length(nnam)
		has.names <- T
	}
	else {
		if(!is.numeric(x))
			stop("nodes must be character or numeric")
		nnode <- max(x)
		nnam <- paste("node", 1:nnode)
		has.names <- F
	}
	ans <- array(0, c(nnode, nnode), list(nnam, nnam))
	if(ischar) {
		dx <- dim(x)
		x <- match(x, nnam)
		dim(x) <- dx
	}
	ans[x] <- 1
	if(any(!xdir))
		ans[x[!xdir, 2:1]] <- 1
	if(general) {
		stop("general version not implemented")
	}
	attr(ans, "call") <- match.call()
	attr(ans, "has.names") <- has.names
	class(ans) <- "adjamat"
	ans
}
SHAR_EOF
fi
if test -f 'adjamat.q'
then
	echo shar: "will not over-write existing file 'adjamat.q'"
else
cat << \SHAR_EOF > 'adjamat.q'
"adjamat"<-
function(x, ...)
UseMethod("adjamat")
SHAR_EOF
fi
if test -f 'alldirected.d'
then
	echo shar: "will not over-write existing file 'alldirected.d'"
else
cat << \SHAR_EOF > 'alldirected.d'
.BG
.FN alldirected.mathgraph
.FN alldirected
.FN alldirected.default
.TL
Transform to Directed Graph
.DN
Returns a `"mathgraph"' object which has all edges directed.
.CS
alldirected.mathgraph(x)
.RA
.AG x
an object representing a mathematical graph.
.RT
a `"mathgraph"' object with any undirected edges in the input split into
two arcs.
.SA
`mathgraph'.
.EX
my.graph <- mathgraph(~ 1:3 / 2:4) # undirected graph with 3 edges
alldirected(my.graph) # directed graph with 6 arcs
.KW math
.WR
SHAR_EOF
fi
if test -f 'alldirected.default.q'
then
	echo shar: "will not over-write existing file 'alldirected.default.q'"
else
cat << \SHAR_EOF > 'alldirected.default.q'
"alldirected.default"<-
function(x, ...)
{
	stop("do not know how to handle")
}
SHAR_EOF
fi
if test -f 'alldirected.mathgraph.q'
then
	echo shar: "will not over-write existing file 'alldirected.mathgraph.q'"
else
cat << \SHAR_EOF > 'alldirected.mathgraph.q'
"alldirected.mathgraph"<-
function(x)
{
	dir <- attr(x, "directed")
	if(all(dir))
		return(x)
	x <- unclass(x)
	ans <- rbind(x, x[!dir, 2:1])
	attr(ans, "directed") <- rep(T, nrow(ans))
	class(ans) <- "mathgraph"
	ans
}
SHAR_EOF
fi
if test -f 'alldirected.q'
then
	echo shar: "will not over-write existing file 'alldirected.q'"
else
cat << \SHAR_EOF > 'alldirected.q'
"alldirected"<-
function(x, ...)
UseMethod("alldirected")
SHAR_EOF
fi
if test -f 'as.numeric.rationalnum.q'
then
	echo shar: "will not over-write existing file 'as.numeric.rationalnum.q'"
else
cat << \SHAR_EOF > 'as.numeric.rationalnum.q'
"as.numeric.rationalnum"<-
function(x)
{
	ans <- as.vector(x$numerator/x$denominator)
	names(ans) <- names(x)
	ans
}
SHAR_EOF
fi
if test -f 'as.rationalnum.default.q'
then
	echo shar: "will not over-write existing file 'as.rationalnum.default.q'"
else
cat << \SHAR_EOF > 'as.rationalnum.default.q'
"as.rationalnum.default"<-
function(x)
{
# following takes care of single NA's
	if(is.logical(x)) mode(x) <- "numeric"
	switch(mode(x),
		numeric = {
			ans <- x
			ans[] <- NA
			good <- !is.na(x)
			x <- x[good]
			ints <- x == ceiling(x)
			if(count <- sum(!ints))
				warning(paste(count, 
				  "NA(s) created coercing to rationalnum"))
			ans[good][ints] <- x[ints]
			rationalnum(ans, 1)
		}
		,
		stop(paste("can not coerce to rationalnum from mode", mode(x)))
			)
}
SHAR_EOF
fi
if test -f 'as.rationalnum.q'
then
	echo shar: "will not over-write existing file 'as.rationalnum.q'"
else
cat << \SHAR_EOF > 'as.rationalnum.q'
"as.rationalnum"<-
function(x, ...)
UseMethod("as.rationalnum")
SHAR_EOF
fi
if test -f 'as.rationalnum.rationalnum.q'
then
	echo shar: "will not over-write existing file 'as.rationalnum.rationalnum.q'"
else
cat << \SHAR_EOF > 'as.rationalnum.rationalnum.q'
"as.rationalnum.rationalnum"<-
function(x)
x
SHAR_EOF
fi
if test -f 'bind.array.d'
then
	echo shar: "will not over-write existing file 'bind.array.d'"
else
cat << \SHAR_EOF > 'bind.array.d'
.BG
.FN bind.array
.TL
Combine Two Arrays
.DN
Returns an array which is a combination of the two input arrays.
.CS
bind.array(x, y, margin)
.RA
.AG x
an array.
.AG y
an array that has dimensions the same as `x' except the `margin'
dimension may be different.
.AG margin
integer giving the dimension at which the combination occurs.
This may be one greater than the length of the dimensions of `x' and `y'.
.RT
an array that has the same size in all of the dimensions as the input arrays
except for the `margin' dimension.  
.SA
`cbind', `aperm'.
.EX
bind.array(arr1, arr2, 1) # size of first dimension increased
.KW array
.WR
SHAR_EOF
fi
if test -f 'bind.array.q'
then
	echo shar: "will not over-write existing file 'bind.array.q'"
else
cat << \SHAR_EOF > 'bind.array.q'
"bind.array"<-
function(x, y, margin)
{
	ldx <- length(dx <- dim(x))
	ldy <- length(dy <- dim(y))
	if(ldx != ldy)
		stop("length of dimensions not equal")
	margin <- round(margin)
	if(margin < 1)
		stop("bad value for margin")
	if(margin > ldx) {
		if(margin - ldx == 1) {
			dx <- c(dx, 1)
			ldx <- ldx + 1
			dy <- c(dy, 1)
			x <- array(x, dx, if(length(dimnames(x))) c(dimnames(x),
				  list(NULL)))
			y <- array(y, dy, if(length(dimnames(x))) c(dimnames(y),
				  list(NULL)))
		}
		else stop("bad value for margin")
	}
	if(any(dx[ - margin] != dy[ - margin]))
		stop("arrays not conformable")
	newdim <- dx
	newdim[margin] <- dx[margin] + dy[margin]
	newdimnames <- dimnames(x)
	newdimnames[[margin]] <- c(dimnames(x)[[margin]], dimnames(y)[[margin]]
		)
	ans <- array(x[1], newdim, newdimnames)
	cmd <- paste("ans[", paste(rep(",", margin - 1), collapse = " "), 
		"1:dx[margin]", paste(rep(",", ldx - margin), collapse = " "), 
		"] <- x")
	eval(parse(text = cmd))
	cmd <- paste("ans[", paste(rep(",", margin - 1), collapse = " "), 
		"dx[margin] + 1:dy[margin]", paste(rep(",", ldx - margin), 
		collapse = " "), "] <- y")
	eval(parse(text = cmd))
	ans
}
SHAR_EOF
fi
if test -f 'browser.default.q'
then
	echo shar: "will not over-write existing file 'browser.default.q'"
else
cat << \SHAR_EOF > 'browser.default.q'
"browser.default"<-
function(frame, catch = T, parent, message = NULL, prompt = "b> ", readonly = F,
	...)
{
	if(!interactive()) {
# change to warning from stop in S-PLUS version
		warning("for interactive use")
		return(NULL)
	}
	if(!exists("old.error", frame = sys.nframe())) {
		old.error <- options(error = NULL, interrupt = NULL)
		on.exit(options(old.error))
	}
	nframe <- sys.parent(1)
	if(missing(parent))
		parent <- sys.parent(2)
	if(missing(frame))
		frame <- sys.parent(1)
	else if(is.numeric(frame)) {
		if(missing(message))
			message <- paste("browser: Frame", frame)
		if(missing(prompt))
			prompt <- paste("b(", frame, ")> ", sep = "")
	}
	if(is.numeric(frame)) {
		if(readonly)
			eval.frame <- new.frame(sys.frame(frame))
		else eval.frame <- frame
	}
	else eval.frame <- new.frame(frame)
	if(is.null(message)) {
		msg <- deparse(sys.call(nframe))
		if(length(msg) > 1)
			msg <- substring(paste(msg, collapse = " "), 1, 20)
		message <- paste("browser:", msg)
	}
	if(length(message))
		cat(message, "\n", file = "|stderr")
	choices <- names(sys.frame(eval.frame))	
	# SHOULD BE: choices <- frame.attr("names",eval.frame)
	n <- length(choices)
	index <- seq(len = n)
	for(i in rev(index))
		if(mode(frame[[i]]) != "argument") {
			n <- length(index) <- i
			break
		}
	if(catch)
		restart()
	repeat {
		i <- parse(prompt = prompt, n = 1)[[1]]
		switch(mode(i),
			numeric = {
				if(i > 0 && i <= n)
				  print(get(choices[i], frame = eval.frame))
				else if(i == 0)
				  return()
			}
			,
			"return" = return(eval(i[[1]], eval.frame, parent)),
			quit = return(),
			"?" = for(i in index)
				cat(i, ": ", choices[i], "\n", sep = "", file
				   = "|stderr"),
			"<-" = ,
			"<<-" = eval(i, eval.frame, parent),
			{
				assign(".Auto.print", T, frame = eval.frame)
				val <- eval(i, eval.frame, parent)
				if(get(".Auto.print", frame = eval.frame))
				  print(val)
			}
			)
	}
}
SHAR_EOF
fi
if test -f 'build.mathgraph.d'
then
	echo shar: "will not over-write existing file 'build.mathgraph.d'"
else
cat << \SHAR_EOF > 'build.mathgraph.d'
.BG
.FN build.mathgraph
.TL
Internal Function for Mathematical Graphs
.DN
This is an internal function.
It is not meant for direct use.
.CS
build.mathgraph(formula)
.SA
`mathgraph'.
.WR
SHAR_EOF
fi
if test -f 'build.mathgraph.q'
then
	echo shar: "will not over-write existing file 'build.mathgraph.q'"
else
cat << \SHAR_EOF > 'build.mathgraph.q'
"build.mathgraph"<-
function(formula, data)
{
	cterm <- paste(collapse = "", deparse(formula[[2]]))
	eyes <- find.I.of(cterm)
	if(length(eyes)) {
# calls to I() need to be evaluated
		nI <- nrow(eyes)
		Inames <- paste("Build.mathgraphI", sys.nframe(), 1:nI, sep = 
			".")
		Iexpr <- substring(cterm, eyes[, 1] + 2, eyes[, 2] - 1)
		for(i in 1:nI) {
			this.val <- eval(parse(text = Iexpr[i]), data)
			assign(Inames[i], this.val, frame = 1)
		}
		eye.ext <- matrix(c(0, t(eyes), nchar(cterm) + 2), nrow = 2)
		allI.strings <- character(2 * nI + 1)
		allI.strings[2 * (1:nI)] <- Inames
		allI.strings[seq(1, 2 * nI + 1, by = 2)] <- substring(cterm, 
			eye.ext[1,  ] + 1, eye.ext[2,  ] - 1)
		cterm <- paste(allI.strings, collapse = "")
	}
	allterms <- p.unpaste(cterm, sep = "+")
	ans <- NULL
	adir <- logical(0)
	for(i in seq(along = allterms)) {
		raw <- allterms[[i]]
		this.parse <- parse(text = raw)
		if(length(this.parse[[1]]) == 1) {
			this.op <- " "
		}
		else {
			this.op <- as.character(this.parse[[1]][[1]])
		}
		switch(this.op,
			"/" = {
				e1 <- eval(this.parse[[1]][[2]], data)
				e2 <- eval(this.parse[[1]][[3]], data)
				this.ev <- cbind(e1, e2)
				ans <- rbind(ans, this.ev)
				adir <- c(adir, rep(NA, dim(this.ev)[1]))
			}
			,
			"*" = {
				e1 <- eval(this.parse[[1]][[2]], data)
				e2 <- eval(this.parse[[1]][[3]], data)
				e1 <- unique(e1)
				e2 <- unique(e2)
				le1 <- length(e1)
				le2 <- length(e2)
				e1 <- e1[rep(1:le1, le2)]
				e2 <- e2[rep(1:le2, rep(le1, le2))]
				this.ev <- cbind(e1, e2)
				ans <- rbind(ans, this.ev)
				adir <- c(adir, rep(NA, dim(this.ev)[1]))
			}
			,
			{
				this.ev <- eval(this.parse, data)
				if(inherits(this.ev, "mathgraph")) {
				  ans <- rbind(ans, this.ev)
				  adir <- c(adir, attr(this.ev, "directed"))
				}
				else stop(paste(
				    "do not know how to handle term:", raw))
			}
			)
	}
	attr(ans, "directed") <- adir
	ans
}
SHAR_EOF
fi
if test -f 'c.mathgraph.q'
then
	echo shar: "will not over-write existing file 'c.mathgraph.q'"
else
cat << \SHAR_EOF > 'c.mathgraph.q'
"c.mathgraph"<-
function(...)
{
	dots <- list(...)
	the.class <- commontail(lapply(dots, class))
	if(!match("mathgraph", the.class, nomatch = 0))
		stop("not all mathgraph objects")
	amat <- do.call("rbind", dots)
	adir <- unlist(lapply(dots, function(x)
	attr(x, "directed")))
	if(dim(amat)[1] != length(adir))
		stop("garbled object")
	attr(amat, "directed") <- adir
	class(amat) <- the.class
	amat
}
SHAR_EOF
fi
if test -f 'c.rationalnum.q'
then
	echo shar: "will not over-write existing file 'c.rationalnum.q'"
else
cat << \SHAR_EOF > 'c.rationalnum.q'
"c.rationalnum"<-
function(...)
{
	dots <- list(...)
	num <- den <- nam <- NULL
	has.names <- F
	for(i in seq(along = dots)) {
		this.rat <- as.rationalnum(dots[[i]])
		num <- c(num, this.rat$numerator)
		den <- c(den, this.rat$denominator)
		this.nam <- this.rat$names
		if(length(this.nam))
			has.names <- T
		else this.nam <- rep("", length(this.rat))
		nam <- c(nam, this.nam)
	}
	ans <- list(numerator = num, denominator = den)
	if(has.names)
		ans$names <- nam
	class(ans) <- "rationalnum"
	ans
}
SHAR_EOF
fi
if test -f 'commontail.d'
then
	echo shar: "will not over-write existing file 'commontail.d'"
else
cat << \SHAR_EOF > 'commontail.d'
.BG
.FN commontail
.TL
Common Strings in Tail
.DN
Takes a list of character vectors and returns the longest vector
of strings that is common to the ends of all of the components in the list.
.CS
commontail(x)
.RA
.AG x
list of character vectors.
.RT
a character vector containing the common elements of the tails
of all the components in `x'.
The result is `NULL' if there are no common elements.
.DT
This is useful to get the class that is common to a number of objects.
.SA
`inherits', `intersect'.
.EX
commontail(list(c("subA", "cls1"), c("subB", "subA", "cls1")))
commontail(list(c("subA", "cls2"), c("subB", "subA", "cls1")))
.KW programming
.WR
SHAR_EOF
fi
if test -f 'commontail.q'
then
	echo shar: "will not over-write existing file 'commontail.q'"
else
cat << \SHAR_EOF > 'commontail.q'
"commontail"<-
function(x)
{
	the.lens <- unlist(lapply(x, length))
	min.len <- min(the.lens)
	if(min.len == 0)
		return(NULL)
	ans <- NULL
	x <- lapply(x, rev)
	for(i in 1:min.len) {
		this.ans <- unique(unlist(lapply(x, function(y, i)
		y[i], i = i)))
		if(length(this.ans) == 1) {
			ans <- c(this.ans, ans)
		}
		else {
			break
		}
	}
	ans
}
SHAR_EOF
fi
if test -f 'continue.fraction.d'
then
	echo shar: "will not over-write existing file 'continue.fraction.d'"
else
cat << \SHAR_EOF > 'continue.fraction.d'
.BG
.FN continue.fraction
.TL
Continued Fractions
.DN
Takes two similar matrices representing the numerators and denominators
of the continued fractions.
.CS
continue.fraction(num, den)
.RA
.AG num
numeric or complex matrix of numerators.  
Each column contains the numerators for one number.
.AG den
numeric or complex matrix of denominators.
This must have the same dimensions as `num'.
.RT
a vector as long as the number of columns in the input.
.DT
Continued fractions are sometimes a convenient mechanism for approximating
functions.
.SH REFERENCES
Abramowitz, M. and Stegun, I. (1972).
.ul
Handbook of Mathematical Functions.
Dover, New York.
.PP
Wall, H. S. (1948).
.ul
Analytic theory of continued fractions.
Van Nostrand, New York.
.SA
`interpolator.lagrange'.
.EX
# function to (poorly) approximate log of 1 + z
function(z)
{
        top <- outer(c(1, 1, 1, 4, 4, 9), as.vector(z), "*")
        bottom <- array(1:6, c(6, length(z)))
        ans <- continue.fraction(top, bottom)
        attributes(ans) <- attributes(z)
        ans
}
.KW math
.WR
SHAR_EOF
fi
if test -f 'continue.fraction.q'
then
	echo shar: "will not over-write existing file 'continue.fraction.q'"
else
cat << \SHAR_EOF > 'continue.fraction.q'
"continue.fraction"<-
function(num, den)
{
	num <- as.matrix(num)
	den <- as.matrix(den)
	if(any(dim(num) != dim(den)))
		stop("num and den do not match")
	n <- nrow(num)
	if(n < 3)
		stop("not enough terms")
	bottom <- den[n,  ]
	for(i in n:2) {
		bottom <- den[i - 1,  ] + num[i,  ]/bottom
	}
	num[1,  ]/bottom
}
SHAR_EOF
fi
if test -f 'delay.eval.d'
then
	echo shar: "will not over-write existing file 'delay.eval.d'"
else
cat << \SHAR_EOF > 'delay.eval.d'
.BG
.FN delay.eval
.TL
Evaluate in a Later Frame
.DN
Returns the value of `expr' as evaluated in the frame requested.
.CS
delay.eval(expr, frames=1)
.RA
.AG expr
an S expression.
.OA
.AG frames
the number of frames the evaluation is moved.
.RT
the value of `expr'.
.SE
the side effects of `expr'.
.SA
`sys.parent', `eval', `substitute'.
.EX
> fjj1
function(x = 0, number = 1)
{
        n <- length(x)
        rep(x, length = number)
}
> fjj1(1:3, delay.eval(n^2))
[1] 1 2 3 1 2 3 1 2 3
> fjj2
function(number = 1)
fjj1(1:3, number = number)
> fjj2(delay.eval(n*4, 2))
 [1] 1 2 3 1 2 3 1 2 3 1 2 3
.KW programming
.WR
SHAR_EOF
fi
if test -f 'delay.eval.q'
then
	echo shar: "will not over-write existing file 'delay.eval.q'"
else
cat << \SHAR_EOF > 'delay.eval.q'
"delay.eval"<-
function(expr, frames = 1)
{
	eval(substitute(expr), local = sys.parent() + frames)
}
SHAR_EOF
fi
if test -f 'diffmask.d'
then
	echo shar: "will not over-write existing file 'diffmask.d'"
else
cat << \SHAR_EOF > 'diffmask.d'
.BG
.FN diffmask
.TL
Compare Masked Objects
.DN
Takes the name of an object that appears in more than one location,
and shows the differences between the two objects.
.CS
diffmask(x, old=<<see below>>, new=<<see below>>)
.RA
.AG x
name or character string of a name of an object.
.OA
.AG old
integer or character string.
If an integer, then a location on the search list where the object appears.
If character, the path to a directory where the object  appears -- this
need not be on the search list.
The default is the second location on the search list where the
object is seen.
.AG new
integer or character string.
If an integer, then a location on the search list where the object appears.
If character, the path to a directory where the object  appears -- this
need not be on the search list.
The default is the first location on the search list where the
object is seen.
.RT
the status of the Unix diff command (invisible).
.SE
the differences are printed to standard-out.
.SA
masked.
.EX
diffmask(browser.default)
diffmask(fjj, "../not_on_search/.Data")
.KW programming
.WR
SHAR_EOF
fi
if test -f 'diffmask.q'
then
	echo shar: "will not over-write existing file 'diffmask.q'"
else
cat << \SHAR_EOF > 'diffmask.q'
"diffmask"<-
function(x, old = loc[2], new = loc[1])
{
	if(!is.character(x) || length(x) > 1)
		x <- deparse(substitute(x))
	loc <- find(x, num = T)
	if(any(is.na(c(old, new))))
		stop("need two locations for object")
	if(is.numeric(old))
		oldlab <- old
	else oldlab <- "old"
	if(is.numeric(new))
		newlab <- new
	else newlab <- "new"
	filenames <- tempfile(paste("database", c(oldlab, newlab), "", sep = 
		"."))
	on.exit(unlink(filenames))
	dput(get(x, where = old), filenames[1])
	dput(get(x, where = new), filenames[2])
	unix(paste("diff -c ", filenames[1], filenames[2]), out = F)
}
SHAR_EOF
fi
if test -f 'diffsccs.d'
then
	echo shar: "will not over-write existing file 'diffsccs.d'"
else
cat << \SHAR_EOF > 'diffsccs.d'
.BG
.FN diffsccs
.TL
Difference Current Object with Saved Version
.DN
Prints the context difference between the current state of an object and
the .q or .Q file by the same name.
.CS
diffsccs(x, xname=x)
.RA
.AG x
a single name or character string of the name of the object of interest.
.OA
.AG xname
character string giving the base name of the file.
This is useful for objects that have strange characters in their name.
.SE
the context difference of the representation of the current object with
the last saved version of the object.
.PP
An error occurs if `x' is not found or if the appropriate file saving
`x' is not found.
.DT
The name of the file is expected to end in `.q' if the object is a function,
and end in `.Q' otherwise.
.PP
The \fIUNIX Power Tools\fP book has a good but brief introduction to SCCS.
You can get more information from your Unix documentation.
.PP
Actually this function is somewhat misnamed since it doesn't really involve
SCCS at all.
.SH REFERENCES
Peek, J., T. O'Reilly, M. Loukides (1993).
.ul
Unix Power Tools.
O'Reilly and Associates; Sebastopol, CA.
.SA
`sccs'.
.EX
sccs(myfun) # put myfun under control

diffsccs(myfun) # see changes, if any, from when sccs done

diffsccs("+.myclass", "Add.myclass")
.WR
SHAR_EOF
fi
if test -f 'diffsccs.q'
then
	echo shar: "will not over-write existing file 'diffsccs.q'"
else
cat << \SHAR_EOF > 'diffsccs.q'
"diffsccs"<-
function(x, xname = x)
{
	if(is.character(x)) {
		if(length(x) > 1)
			stop("only one at a time")
	}
	else x <- deparse(substitute(x))
	do.dd <- !is.function(get(x))
	xfile <- tempfile("dumpsccs")
	on.exit(unlink(xfile))
	if(do.dd) {
		data.dump(x, xfile)
		suffix <- ".Q"
	}
	else {
		dump(x, xfile)
		suffix <- ".q"
	}
	cmd <- paste("diff -c ", xname, suffix, " ", xfile, sep = "")
	invisible(unix(cmd, out = F))
}
SHAR_EOF
fi
if test -f 'digamma.c'
then
	echo shar: "will not over-write existing file 'digamma.c'"
else
cat << \SHAR_EOF > 'digamma.c'
#include <math.h>
#include <S.h>


void
digamma_real_Sp(x, n)
long *n;
double *x;
{
        long i;
	double digamma_real_pos();

        for(i=0; i < *n; i++) {
                if(is_na(x + i, DOUBLE)) ;
                else if(x[i] <= 0.0) na_set3(x + i, DOUBLE, Is_NaN);
                else if(is_inf(x + i, DOUBLE)) inf_set(x + i, DOUBLE, 1);
                else x[i] = digamma_real_pos(x[i]);
        }
}


static double stirling[] = {
		-8.333333333333333e-02,  8.333333333333333e-03,
               	-3.968253968253968e-03,  4.166666666666667e-03,
                -7.575757575757576e-03,  2.109279609279609e-02,
                -8.333333333333334e-02,  4.432598039215686e-01,
                -3.053954330270120e+00,  2.645621212121212e+01,
                -2.814601449275362e+02,  3.607510546398047e+03
};


static double
digamma_real_pos(x)
double x;
{
        long i;
        double lower, upper, euler_one, ans, x_inv, x_pow;

        lower = 1.0e-8;
        upper = 19.5;
        /* euler = -.577215664901532860606512; */
        euler_one = .422784335098467139393488;

	/* expects x to be positive and finite - NO CHECKS HERE */
        if(x < lower) {
                ans = - 1.0 / x - 1.0 / (1.0 + x) + euler_one;
		return(ans);
	}

	ans = 0.0;
	while(x < upper) {
		ans = ans - 1.0 / x;
                x = x + 1.0;
        }

        x_inv = 1.0 / x;
        ans = ans + log(x) - .5 * x_inv;

        x_inv = x_inv * x_inv;
        x_pow = x_inv;

        for(i=0; i < 12; i++) {
                ans = ans + stirling[i] * x_pow;
                x_pow = x_pow * x_inv;
        }
        return(ans);
}


void
digamma_complex_Sp(z, n, ans)
long *n;
complex z[], ans[];
/* the usual shortcut of *z for z[] is not a good idea here */
{
        long j, i;
        double upper;
        complex z_inv, z_pow;
	complex mult_complex(), inverse_complex();

        upper = 19.5;

	for(j=0; j < *n; j++) {
		if(is_na(z + j, COMPLEX)) {
			continue;
		}
		if(is_inf(z + j, COMPLEX)) {
			na_set3(ans + j, COMPLEX, Is_NaN);
			continue;
		}
		ans[j].re = 0.0; ans[j].im = 0.0;
		while(z[j].re < upper) {
        		z_inv = inverse_complex(z[j]);
			ans[j].re = ans[j].re - z_inv.re;
			ans[j].im = ans[j].im - z_inv.im;
                	z[j].re = z[j].re + 1.0;
        	}

        	z_inv = inverse_complex(z[j]);
        	ans[j].re = ans[j].re - .5 * z_inv.re;
        	ans[j].im = ans[j].im - .5 * z_inv.im;

        	z_inv = mult_complex(z_inv, z_inv);
        	z_pow = z_inv;

        	for(i=0; i < 12; i++) {
                	ans[j].re = ans[j].re + stirling[i] * z_pow.re;
                	ans[j].im = ans[j].im + stirling[i] * z_pow.im;
                	z_pow = mult_complex(z_pow, z_inv);
        	}
		/* ans still needs log(z) added to it */
	}
}


static complex
mult_complex(x, y)
complex x, y;
{
	complex ans;

	ans.re = x.re * y.re - x.im * y.im;
	ans.im = x.im * y.re + x.re * y.im;
	return(ans);
}


static complex
inverse_complex(x)
complex x;
{
	complex ans;
	double den;

	den = x.im * x.im + x.re * x.re;
	
	ans.re = x.re / den;
	ans.im = - x.im / den;
	return(ans);
}
SHAR_EOF
fi
if test -f 'digamma.d'
then
	echo shar: "will not over-write existing file 'digamma.d'"
else
cat << \SHAR_EOF > 'digamma.d'
.BG
.FN digamma
.TL
Digamma Function
.DN
Returns the digamma function (derivative of log gamma) of
a numeric or complex vector.
.CS
digamma(x)
.RA
.AG x
numeric or complex vector.
.NA
.RT
the first derivative of the log gamma function of the input.  
A missing value is returned for negative numeric values; use complex
numbers to get the proper answer for these values.
.SH REFERENCES
Abramowitz, M. and Stegun, I. (1972).
.ul
Handbook of Mathematical Functions.
Dover, New York.
.SH BUGS
The approximation is of variable quality.
.SA
`polygamma', `gamma'.
.EX
digamma(1:10)
as.numeric(digamma(as.complex(c(-.5, -.6, -.7))))
.KW math
.KW complex
.WR
SHAR_EOF
fi
if test -f 'digamma.q'
then
	echo shar: "will not over-write existing file 'digamma.q'"
else
cat << \SHAR_EOF > 'digamma.q'
"digamma"<-
function(x)
{
	if(!is.loaded(symbol.C("digamma_real_Sp")))
		poet.dyn.load("digamma.o")
	if(is.complex(x)) {
		n <- length(x)
		if(!n)
			return(x)
		ans <- .C("digamma_complex_Sp",
			NAOK = T,
			specialsok = T,
			z = as.complex(x),
			as.integer(n),
			ans.almost = complex(n))
		ans <- ans$ans.almost + log(ans$z)
		attributes(ans) <- attributes(x)
		ans
	}
	else {
		storage.mode(x) <- "double"
		.C("digamma_real_Sp",
			NAOK = T,
			specialsok = T,
			x,
			as.integer(length(x)))[[1]]
	}
}
SHAR_EOF
fi
if test -f 'exp.integral.d'
then
	echo shar: "will not over-write existing file 'exp.integral.d'"
else
cat << \SHAR_EOF > 'exp.integral.d'
.BG
.FN exp.integral
.TL
Exponential Integral Function
.DN
Returns values of the exponential integral.
.CS
exp.integral(x, n, nterms=100)
.RA
.AG x
numeric or complex object.
.NA
.AG n
numeric vector giving the order of the function.
This must either be a single number or have length equal to that of `x'.
.NA
.OA
.AG nterms
integer giving the number of terms in the continued fraction approximation.
.RT
an object like `x' containing the value of the exponential integral function.
.SH REFERENCES
Abramowitz, M. and Stegun, I. (1972).
.ul
Handbook of Mathematical Functions.
Dover, New York.
.SH BUGS
The quality of the approximation is unknown, but not always good.
.PP
Numeric answers are given for  negative real numbers.
.SA
`continue.fraction'.
.EX
exp.integral(1:9, 2)
exp.integral(complex(re=1:9, im=1:9), 2)
exp.integral(1:9, rep(1:3, 3))
.KW math
.WR
SHAR_EOF
fi
if test -f 'exp.integral.q'
then
	echo shar: "will not over-write existing file 'exp.integral.q'"
else
cat << \SHAR_EOF > 'exp.integral.q'
"exp.integral"<-
function(x, n, nterms = 100)
{
	if(!length(x))
		return(x)
	xatt <- attributes(x)
	x <- as.vector(x)
	outlen <- length(x)
	if(length(n) == 1)
		n <- rep(n, outlen)
	else if(length(n) != outlen)
		stop("n must be one long or the length of x")
	n <- round(n)
	tseq <- 0:(nterms - 1)
	num <-  - outer(tseq - 1, n, "+") * tseq
	num[1,  ] <- 1
	den <- outer(2 * tseq, x + n, "+")
	ans <- exp( - x) * continue.fraction(num, den)
	attributes(ans) <- xatt
	ans
}
SHAR_EOF
fi
if test -f 'expand.d'
then
	echo shar: "will not over-write existing file 'expand.d'"
else
cat << \SHAR_EOF > 'expand.d'
.BG
.FN expand
.FN expand.default
.FN reduce
.FN reduce.default
.TL
Reduce or Expand a Reduced Object
.DN
Generic functions meant to perform space-saving operations.
.CS
reduce(x, ...)
expand(x, ...)
.RA
.AG x
an S object.
.RT
the reduced or expanded version of x.
.DT
Although other uses are possible, my vision is that reduce makes an
object smaller in some reversible manner and adds a class to the result.
The expand function can take the reduced object, recover the stripped
information, and remove the extra class.
.EX
# The function is currently defined as
function(x, ...)
UseMethod("expand")
.WR
SHAR_EOF
fi
if test -f 'expand.default.q'
then
	echo shar: "will not over-write existing file 'expand.default.q'"
else
cat << \SHAR_EOF > 'expand.default.q'
"expand.default"<-
function(x, ...)
x
SHAR_EOF
fi
if test -f 'expand.q'
then
	echo shar: "will not over-write existing file 'expand.q'"
else
cat << \SHAR_EOF > 'expand.q'
"expand"<-
function(x, ...)
UseMethod("expand")
SHAR_EOF
fi
if test -f 'filetest.d'
then
	echo shar: "will not over-write existing file 'filetest.d'"
else
cat << \SHAR_EOF > 'filetest.d'
.BG
.FN filetest
.TL
Test Existence and Other Attributes of a File
.DN
Returns a logical vector giving the results of the tests on the file.
.CS
filetest(filename, directory=F, read=F, write=F, execute=F,
	size=F)
.RA
.AG filename
a character string of the name of the file of interest.
.OA
.AG directory
logical flag; if `TRUE', then test if the file is a directory.
.AG read
logical flag; if `TRUE', then test if the file is readable.
.AG write
logical flag; if `TRUE', then test if the file is writeable.
.AG execute
logical flag; if `TRUE', then test if the file is executable.
.AG size
logical flag; if `TRUE', then test if the file has size greater than zero.
.RT
a logical vector, the first element is `TRUE' if the file exists.
Values for the other possible tests are `NA' if the test was not performed.
.SA
`unix'.
.EX
filetest("jjtest1.c")
filetest("SCCS", dir=T)["dir"]
.KW file
.WR
SHAR_EOF
fi
if test -f 'filetest.q'
then
	echo shar: "will not over-write existing file 'filetest.q'"
else
cat << \SHAR_EOF > 'filetest.q'
"filetest"<-
function(filename, directory = F, read = F, write = F, execute = F, size = F)
{
	fbe <- unix(paste("test -f", filename, "-o -d", filename), out = F) == 
		0
	extras <- c(directory, read, write, execute, size)
	ans <- c(exists = fbe, directory = NA, read = NA, write = NA, execute
		 = NA, size = NA)
	if(!fbe || !any(extras))
		return(ans)
	cmds <- paste(c("test -d", "test -r", "test -w", "test -x", "test -s"), 
		filename)
	for(i in seq(along = extras)) {
		if(!extras[i])
			next
		ans[i + 1] <- unix(cmds[i], out = F) == 0
	}
	ans
}
SHAR_EOF
fi
if test -f 'find.I.of.d'
then
	echo shar: "will not over-write existing file 'find.I.of.d'"
else
cat << \SHAR_EOF > 'find.I.of.d'
.BG
.FN find.I.of
.TL
Find limits of I() in a String
.DN
Returns either NULL or a two-column matrix where each row gives the
first and last character of a call to I.
.CS
find.I.of(string, nesting.ok=F)
.RA
.AG string
a single character string.
.OA
.AG nesting.ok
logical value: if TRUE, then all occurrences are given.
If FALSE, then calls to I within other calls to it are ignored.
.RT
a numeric matrix with two columns, or NULL.
Each row represents one call to I.
The first column is the number of the character within the string that
starts the call (i.e., the "I").
The second column is the number of the character within the string that
ends the call (the ")").
.DT
This is used by mathgraph functions, and is not meant for direct use.
.SH BUGS
Parentheses inside quotes in the call to I will confuse it.
.PP
One or more spaces after the "I" will cause the call to be unrecognized.
However, if the string is parsed and then deparsed, the space will go away.
.SA
build.mathgraph.
.EX
find.I.of("~ x + I(x^2)")
find.I.of("~ x + I(x^2 + I(y^3))")
find.I.of("~ x + I(x^2 + I(y^3))", T)
.KW character
.WR
SHAR_EOF
fi
if test -f 'find.I.of.q'
then
	echo shar: "will not over-write existing file 'find.I.of.q'"
else
cat << \SHAR_EOF > 'find.I.of.q'
"find.I.of"<-
function(string, nesting.ok = F)
{
	string.code <- AsciiToInt(string)
	if(!any(eyes <- string.code == AsciiToInt("I")))
		return(NULL)
	open.par <- AsciiToInt("(")
	close.par <- AsciiToInt(")")
	opens <- string.code == open.par
	Istart <- eyes & c(opens[-1], F)
	if(!any(Istart))
		return(NULL)
	closes <- string.code == close.par
	counts <- cumsum(opens - closes)
	Istart.num <- seq(along = Istart)[Istart]
	ans <- array(0, c(length(Istart.num), 2))
	for(i in 1:length(Istart.num)) {
		loci <- Istart.num[i]
		this.lev <- counts[-1: - loci] == counts[loci]
		if(!any(this.lev))
			stop("no closing parenthesis for I")
		ans[i,  ] <- c(0, min(seq(along = this.lev)[this.lev])) + loci
	}
	if(!nesting.ok && nrow(ans) > 1) {
		ans <- ans[c(T, diff(ans[, 2]) > 0),  , drop = F]
	}
	ans
}
SHAR_EOF
fi
if test -f 'find.assign.d'
then
	echo shar: "will not over-write existing file 'find.assign.d'"
else
cat << \SHAR_EOF > 'find.assign.d'
.BG
.FN find.assign
.TL
Names Assigned
.DN
Takes a language object and returns (most of) the names that are assigned to.
This is primarily a servant of `global.vars'.
.CS
find.assign(line)
.RA
.AG line
language object.
.RT
a character string of the names that are assigned in the input `line'.
.SH BUGS
Not all assignments are caught.
For instance, a statement like `(n <- length(x)) == 5' will hide the
assignment to `n' from `find.assign'.
The examples section shows another case.
.SA
`global.vars'.
.EX
> fjj.fa[[c(1,2)]]
x[2] <- y <- 98
> find.assign(fjj.fa[[c(1,2)]])
character(0)
> fjj.fa[[c(1,2,2)]]
y <- 98
> find.assign(fjj.fa[[c(1,2,2)]])
[1] "y" 
.KW programming
.WR
SHAR_EOF
fi
if test -f 'find.assign.q'
then
	echo shar: "will not over-write existing file 'find.assign.q'"
else
cat << \SHAR_EOF > 'find.assign.q'
"find.assign"<-
function(line)
{
	switch(mode(line),
		"<-" = ,
		"<<-" = {
			ans <- line[[1]]
			if(mode(ans) == "call")
				return(character(0))
			else if(mode(line[[2]]) == "function") {
				this.fun <- line[[2]]
				return(c(ans, names(this.fun)[ - length(
				  this.fun)], Recall(this.fun[[length(this.fun)
				  ]])))
			}
			else if(mode(line[[2]]) == "<-" || mode(line[[2]]) == 
				"<<-") {
				return(c(ans, Recall(line[[2]])))
			}
			else return(as.character(ans))
		}
		,
		comment.expression = return(Recall(line[[1]])),
		"{" = {
			ans <- character(0)
			for(i in 1:length(line)) {
				ans <- c(ans, Recall(line[[i]]))
			}
			return(ans)
		}
		,
		"if" = return(c(Recall(line[[1]]), Recall(line[[2]]), Recall(
			line[[3]]))),
		"while" = {
			return(c(Recall(line[[1]]), Recall(line[[2]])))
		}
		,
		"for" = {
			loopv <- substring(deparse(line)[1], 5)
			loopv <- substring(loopv, 1, match(32, AsciiToInt(loopv
				)) - 1)
			return(c(loopv, Recall(line[[3]])))
		}
		,
		"repeat" = return(Recall(line[[1]])),
		call = {
			cnam <- as.character(line[[1]])
			switch(cnam,
				assign = return(line[[2]]),
				switch = {
				  ans <- character(0)
				  for(i in 2:length(line)) {
				    ans <- c(ans, Recall(line[[i]]))
				  }
				  return(ans)
				}
				,
				return(character(0)))
		}
		)
}
SHAR_EOF
fi
if test -f 'from.base10.q'
then
	echo shar: "will not over-write existing file 'from.base10.q'"
else
cat << \SHAR_EOF > 'from.base10.q'
"from.base10"<-
function(raw, newbase)
{
	from.base10.sub <- function(raw, newbase)
	{
		zero <- raw == 0
		if(all(zero))
			return(character(0))
		ans <- character(length(raw))
		this.digit <- raw[!zero] %% newbase
		if(newbase > 10)
			this.digit <- c(0:9, letters)[this.digit + 1]
		ans[!zero] <- paste(Recall(raw[!zero] %/% newbase, newbase), 
			this.digit, sep = "")
		ans
	}
# start of main function
	if(length(newbase) != 1 || newbase > 36.5 || newbase < 1.5 || abs(round(
		newbase) - newbase) > .Machine$double.eps)
		stop("need single integer between 2 and 36 as base")
	raw <- as.numeric(raw)
	wna <- which.na(raw)
	if(length(wna)) {
		realraw <- raw
		raw <- raw[ - wna]
	}
	if(any(abs(round(raw) - raw) > .Machine$double.eps))
		warning("only integers handled - rounding")
	raw <- round(raw)
	ans <- from.base10.sub(abs(raw), newbase)
	ans[nchar(ans) == 0] <- "0"
	ans[raw < 0] <- paste("-", ans[raw < 0], sep = "")
	if(length(wna)) {
		realans <- character(length(realraw))
		realans[wna] <- "NA"
		realans[ - wna] <- ans
		ans <- realans
		raw <- realraw
	}
	attr(ans, "value") <- raw
	attr(ans, "base") <- newbase
	class(ans) <- "numberbase"
	ans
}
SHAR_EOF
fi
if test -f 'genopt.control.d'
then
	echo shar: "will not over-write existing file 'genopt.control.d'"
else
cat << \SHAR_EOF > 'genopt.control.d'
.BG
.FN genopt.control
.TL
Control Variables for genopt
.DN
Returns a list that controls the behavior of the `genopt' function.
.CS
genopt.control(births=100, n.jitters=3, trace=T, eps=0.1,
	prob=0.3, scale.min=1e-12, maxeval=Inf)
.OA
.AG births
the maximum number of births to perform.
.AG n.jitters
the number of times to jitter a successful birth.
.AG trace
logical flag: if `TRUE', then the progress of the algorithm is reported.
.AG eps
the default value for the elements of the `scale' argument to `genopt'.
.AG prob
the probability of an element of the child coming from the first parent.
.AG scale.min
number that keeps the scale away from 0.
.AG maxeval
the (approximate) maximum number of function evaluations.
.RT
a list with the following components:
.RC icontrol
the integer-valued variables.
.RC dcontrol
the real-valued variables.
.SA
`genopt'.
.EX
jjgo.control <- genopt.control(birth=800, n.jit=5)

genopt(fjj, control=jjgo.control)
.KW optimize
.WR
SHAR_EOF
fi
if test -f 'genopt.control.q'
then
	echo shar: "will not over-write existing file 'genopt.control.q'"
else
cat << \SHAR_EOF > 'genopt.control.q'
"genopt.control"<-
function(births = 100, random.n = 0, jitters.n = 3, trace = T, eps = 
	0.10000000000000001, prob = 0.29999999999999999, scale.min = 
	9.9999999999999998e-13, maxeval = Inf)
{
	dcon <- c(eps = eps, prob = prob, scale.min = scale.min)
	icon <- c(births = births, random.n = random.n, jitters.n = jitters.n, 
		trace = trace, maxeval = maxeval)
	list(icontrol = icon, dcontrol = dcon)
}
SHAR_EOF
fi
if test -f 'genopt.d'
then
	echo shar: "will not over-write existing file 'genopt.d'"
else
cat << \SHAR_EOF > 'genopt.d'
.BG
.FN genopt
.TL
Minimiation of a Function via a Genetic Algorithm
.DN
Returns a population of solutions that improves upon the input population.
.CS
genopt(fun, population, lower=-Inf, upper=Inf,
	scale=dcontrol["eps"], add.args=NULL,
	control=genopt.control(...), ...)
.RA
.AG fun
a function or a character string naming a function.
.AG population
either a matrix of solutions (each column is a parameter vector),
or a list which is the output of a previous call to `genopt'.
.OA
.AG lower
vector of lower bounds for the parameters.
This is replicated to be the proper length.
.AG upper
vector of upper bounds for the parameters.
This is replicated to be the proper length.
.AG scale
vector of scales for the jittering.
This is replicated to be the proper length.
.AG add.args
list of additional arguments to give to the function.
.AG control
a list like the output of `genopt.control'.
.AG ...
control arguments may be given individually.
.RT
a list with the following components:
.RC population
a matrix with the best solution in the first column.
.RC objective
vector of objectives corresponding to the `population' component.
.RC funevals
the number of function evaluations used.
If the input `population' is a list from a previous call to `genopt',
then this reflects the total number of evaluations.
.RC call
an image of the call that created the object.
.SE
The `.Random.seed' object in the working directory is created or changed.
.DT
~explain details here.
.SH REFERENCES
Goldberg, D. E. (1989).
.ul
Genetic Algorithms in Search, Optimization and Machine Learning.
Addison-Wesley; Reading, Mass.
.SA
`genopt.control', `nlminb'.
.EX
genopt(function(x) sum(x^2), matrix(rnorm(100),5))

genopt(function(x) sum(x^2), matrix(rnorm(100),5),
	birth=500)

genopt(function(x) sum(x^2), matrix(rnorm(100,4),5),
	lower=1)
.KW optimize
.WR
SHAR_EOF
fi
if test -f 'genopt.q'
then
	echo shar: "will not over-write existing file 'genopt.q'"
else
cat << \SHAR_EOF > 'genopt.q'
"genopt"<-
function(fun, population, lower =  - Inf, upper = Inf, scale = dcontrol["eps"], 
	add.args = NULL, control = genopt.control(...), ...)
{
	random.seed <- .Random.seed
	if(is.character(fun))
		fun <- get(fun, mode = "function")
	fun.args <- c(list(NULL), add.args)
	go.rectify <- function(pars, lower, upper)
	{
		pars[pars < lower] <- lower[pars < lower]
		pars[pars > upper] <- upper[pars > upper]
		pars
	}
	if(is.list(population)) {
		objective <- population$objective
		funevals <- population$funevals
		population <- population$population
		popsize <- ncol(population)
		if(is.null(popsize) || length(objective) != popsize)
			stop("bad input population")
		if(!is.numeric(funevals) || is.na(funevals)) {
			funevals <- 0
			warning("funevals starting at 0")
		}
	}
	else {
		if(!is.matrix(population))
			stop("bad input population")
		popsize <- ncol(population)
		objective <- numeric(popsize)
		npar <- nrow(population)
		lower <- rep(lower, length = npar)
		upper <- rep(upper, length = npar)
		if(any(upper < lower))
			stop("upper element smaller than lower")
		for(i in 1:popsize) {
			population[, i] <- fun.args[[1]] <- go.rectify(
				population[, i], lower, upper)
			objective[i] <- do.call("fun", fun.args)
		}
		funevals <- popsize
	}
	icontrol <- control$icontrol
	dcontrol <- control$dcontrol
	trace <- icontrol["trace"]
	minobj <- min(objective)
	npar <- nrow(population)
	if(trace) {
		cat("objectives go from", format(minobj), "to", format(max(
			objective)), "\n")
	}
	if(icontrol["random.n"]) {
		par.range <- apply(population, 1, range)
		par.range[2, par.range[2,  ] == par.range[1,  ]] <- par.range[2,
			par.range[2,  ] == par.range[1,  ]] + dcontrol[
			"scale.min"]
		maxobj <- max(objective)
		for(i in 1:icontrol["random.n"]) {
			fun.args[[1]] <- runif(npar, par.range[1,  ], par.range[
				2,  ])
			this.obj <- do.call("fun", fun.args)
			if(this.obj < maxobj) {
				maxind <- order(objective)[popsize]
				population[, maxind] <- fun.args[[1]]
				objective[maxind] <- this.obj
				maxobj <- max(objective)
			}
		}
		if(trace) {
			cat("objectives go from", format(minobj), "to", format(
				maxobj), "\n")
		}
	}
	njit <- icontrol["jitters.n"]
	lower <- rep(lower, length = npar)
	upper <- rep(upper, length = npar)
	if(any(upper < lower))
		stop("upper element smaller than lower")
	scale[scale < dcontrol["scale.min"]] <- dcontrol["scale.min"]
	scale <- rep(scale, length = npar)
	prob <- dcontrol["prob"]
	prob <- c(prob, 1 - prob)
	maxeval <- icontrol["maxeval"]
	for(i in 1:icontrol["births"]) {
		if(funevals >= maxeval)
			break
		parents <- sample(popsize, 2)
		child <- population[, parents[1]]
		cloc <- sample(c(T, F), npar, rep = T, prob = prob)
		if(all(cloc))
			cloc[sample(npar, 1)] <- F
		else if(all(!cloc))
			cloc[sample(npar, 1)] <- T
		child[cloc] <- population[cloc, parents[2]]
		fun.args[[1]] <- child
		child.obj <- do.call("fun", fun.args)
		funevals <- funevals + 1
		parent.obj <- objective[parents]
		survive <- child.obj < max(parent.obj)
		if(trace) {
			cat(i, "parents:", parent.obj, "child:", format(
				child.obj), if(survive) "(improve)", "\n")
		}
		if(survive || (child.obj == parent.obj[1] && child.obj == 
			parent.obj[2])) {
			if(parent.obj[1] > parent.obj[2])
				out <- parents[1]
			else out <- parents[2]
			population[, out] <- child
			objective[out] <- child.obj
			if(trace && child.obj < minobj) {
				minobj <- child.obj
				cat("new minimum\n")
			}
			for(i in seq(length = njit)) {
				fun.args[[1]] <- jchild <- go.rectify(rnorm(
				  npar, child, scale), lower, upper)
				jchild.obj <- do.call("fun", fun.args)
				funevals <- funevals + 1
				if(jchild.obj < child.obj) {
				  child <- population[, out] <- jchild
				  child.obj <- objective[out] <- jchild.obj
				  if(trace) {
				    cat("jitter successsful:", format(
				      jchild.obj), "\n")
				    if(jchild.obj < minobj) {
				      cat("new minimum\n")
				      minobj <- jchild.obj
				    }
				  }
				}
			}
		}
	}
	ord <- order(objective)
	list(population = population[, ord], objective = objective[ord], 
		funevals = funevals, random.seed = random.seed, call = 
		match.call())
}
SHAR_EOF
fi
if test -f 'getpath.adjamat.q'
then
	echo shar: "will not over-write existing file 'getpath.adjamat.q'"
else
cat << \SHAR_EOF > 'getpath.adjamat.q'
"getpath.adjamat"<-
function(x, start, end)
{
	if(start == end) {
# distinguish this from no path possible
		return(mathgraph())
	}
	has.names <- attr(x, "has.names")
	if(has.names)
		node.names <- dimnames(x)[[1]]
	else node.names <- NULL
	if(is.character(c(end, start))) {
		start <- match(start, node.names, nomatch = NA)
		end <- match(end, node.names, nomatch = NA)
		bad.in <- c("start", "end")[is.na(c(start, end))]
		if(length(bad.in))
			stop(paste(paste(bad.in, collapse = " and "), 
				"not right"))
	}
	tset <- start
	prev <- 0
	unchecked <- T
	nseq <- 1:dim(x)[1]
	repeat {
		this.index <- (1:length(unchecked))[unchecked][1]
		newn <- nseq[x[tset[this.index],  ] > 0]
		newn <- setdiff(newn, tset)
		unchecked[this.index] <- F
		if(n <- length(newn)) {
			if(match(end, newn, nomatch = 0)) {
				tset <- c(tset[!unchecked], end)
				prev <- c(prev[!unchecked], tset[this.index])
				pseq <- 1:length(tset)
				path <- this.index <- length(tset)
				this.node <- end
				while(prev[this.index] != start) {
				  this.index <- pseq[tset == prev[this.index]]
				  path <- c(this.index, path)
				}
				if(has.names) {
				  return(mathgraph( ~ node.names[prev[path]]/
				    node.names[tset[path]], dir = T))
				}
				else {
				  return(mathgraph( ~ prev[path]/tset[path], 
				    dir = T))
				}
			}
			tset <- c(tset, newn)
			prev <- c(prev, rep(tset[this.index], n))
			unchecked <- c(unchecked, rep(T, n))
		}
		if(!any(unchecked))
			return(NULL)
	}
}
SHAR_EOF
fi
if test -f 'getpath.d'
then
	echo shar: "will not over-write existing file 'getpath.d'"
else
cat << \SHAR_EOF > 'getpath.d'
.BG
.FN getpath
.FN getpath.incidmat
.FN getpath.mathgraph
.FN getpath.adjamat
.FN getpath.default
.TL
Find a Path in a Mathematical Graph
.DN
Returns a path, if it exists, from the start to the end.
.CS
getpath(x, start, end)
.RA
.AG x
an object representing a mathematical graph.
.AG start
character string or integer giving the starting node.
.AG end
character string or integer giving the ending node.
.RT
usually, a `"mathgraph"' object containing the edges within the path; this
may be an empty mathgraph if `start' and `end' are equal.
The exception is: `NULL' if no path exists.
.DT
`getpath' is a generic function with methods for 
`"mathgraph"', `"incidmat"' and `"adjamat"'.
The default method converts `x' to class `"incidmat"'.
.PP
`getpath.adjamat' is an implementation of algorithm 2.2 in Chachra, Ghare and
Moore (1979) and `getpath.incidmat' is an implementation of their algorithm
2.3.
.PP
The distinction between non-existent paths and paths of length zero
may be useful in some situations.
.SH REFERENCES
Chachra, V., Ghare, P. M. and Moore, J. M. (1979).
.ul
Applications of Graph Theory Algorithms.
Elvesier North Holland, New York.
.SA
`mathgraph', `incidmat', `adjamat'.
.EX
getpath(mathgraph(~ 1:3 / 3:5), 1, 5) # returns a path
getpath(mathgraph(~ 1:3 / 3:5), 1, 4) # no path, returns NULL
getpath(mathgraph(~ 1:3 / 3:5), 1, 1) # returns mathgraph()
.KW math
.WR
SHAR_EOF
fi
if test -f 'getpath.default.q'
then
	echo shar: "will not over-write existing file 'getpath.default.q'"
else
cat << \SHAR_EOF > 'getpath.default.q'
"getpath.default"<-
function(x, start, end)
{
	getpath(incidmat(x), start, end)
}
SHAR_EOF
fi
if test -f 'getpath.incidmat.q'
then
	echo shar: "will not over-write existing file 'getpath.incidmat.q'"
else
cat << \SHAR_EOF > 'getpath.incidmat.q'
"getpath.incidmat"<-
function(x, start, end)
{
	if(start == end)
		return(mathgraph())
	x <- unclass(x)
	dircheck <- rep(1, dim(x)[1]) %*% x
	if(any(dircheck))
		stop("need matrix for directed graph")
	has.names <- attr(x, "has.names")
	if(has.names["edges"])
		enames <- dimnames(x)[[2]]
	else enames <- NULL
	if(has.names["nodes"])
		node.names <- dimnames(x)[[1]]
	else node.names <- NULL
	if(is.character(c(end, start))) {
		start <- match(start, node.names, nomatch = NA)
		end <- match(end, node.names, nomatch = NA)
		bad.in <- c("start", "end")[is.na(c(start, end))]
		if(length(bad.in))
			stop(paste(paste(bad.in, collapse = " and "), 
				"not right"))
	}
	tset <- start
	prev <- 0
	edges <- 0
	unchecked <- T
	nseq <- 1:dim(x)[1]
	eseq <- 1:dim(x)[2]
	repeat {
		this.index <- (1:length(unchecked))[unchecked][1]
		newe <- eseq[x[tset[this.index],  ] > 0.5]
		if(length(newe)) {
			newn <- row(x[, newe, drop = F])[as.vector(x[, newe] < 
				-0.5
				)]
			newt <- !duplicated(newn)
			newn <- newn[newt]
			newe <- newe[newt]
			newt <- match(newn, tset, nomatch = 0) == 0
			newn <- newn[newt]
			newe <- newe[newt]
		}
		else newn <- NULL
		unchecked[this.index] <- F
		if(n <- length(newn)) {
			if(endind <- match(end, newn, nomatch = 0)) {
# have a path
				tset <- c(tset[!unchecked], end)
				prev <- c(prev[!unchecked], tset[this.index])
				edges <- c(edges[!unchecked], newe[endind])
				pseq <- 1:length(tset)
				path <- this.index <- length(tset)
				this.node <- end
				while(prev[this.index] != start) {
				  this.index <- pseq[tset == prev[this.index]]
				  path <- c(this.index, path)
				}
				if(has.names["nodes"]) {
				  ans <- mathgraph( ~ node.names[prev[path]]/
				    node.names[tset[path]], dir = T)
				}
				else {
				  ans <- mathgraph( ~ prev[path]/tset[path], 
				    dir = T)
				}
				if(has.names["edges"]) {
				  names(ans) <- enames[edges[path]]
				}
				return(ans)
			}
			tset <- c(tset, newn)
			edges <- c(edges, newe)
			prev <- c(prev, rep(tset[this.index], n))
			unchecked <- c(unchecked, rep(T, n))
		}
		if(!any(unchecked))
			return(NULL)
	}
}
SHAR_EOF
fi
if test -f 'getpath.mathgraph.q'
then
	echo shar: "will not over-write existing file 'getpath.mathgraph.q'"
else
cat << \SHAR_EOF > 'getpath.mathgraph.q'
"getpath.mathgraph"<-
function(x, start, end, all = F)
{
	if(start == end)
		return(mathgraph())
	getpath(incidmat(x), start, end)
}
SHAR_EOF
fi
if test -f 'getpath.q'
then
	echo shar: "will not over-write existing file 'getpath.q'"
else
cat << \SHAR_EOF > 'getpath.q'
"getpath"<-
function(x, start, end, ...)
UseMethod("getpath")
SHAR_EOF
fi
if test -f 'global.vars.d'
then
	echo shar: "will not over-write existing file 'global.vars.d'"
else
cat << \SHAR_EOF > 'global.vars.d'
.BG
.FN global.vars
.TL
Global Variables in a Function
.DN
Returns a character vector of (suspected) global variables used in
the input function.
.CS
global.vars(fun)
.RA
.AG fun
a function.
.RT
a character vector.
.DT
This is useful to test if any objects are accidentally used
in a function that are neither arguments nor created within the function.
.SH BUGS
The names of functions used in calls to `apply' and the like will
be returned.
.PP
This function uses `find.assign' which is not perfect.
.SA
`find.assign'.
.EX
global.vars(function(xmat) nrow(x))

global.vars(seq)
global.vars(platform)
global.vars(get("+"))
.KW programming
.WR
SHAR_EOF
fi
if test -f 'global.vars.q'
then
	echo shar: "will not over-write existing file 'global.vars.q'"
else
cat << \SHAR_EOF > 'global.vars.q'
"global.vars"<-
function(fun)
{
	if(is.character(fun))
		fun <- get(fun)
	fnam <- names(fun)
	fnam <- fnam[ - length(fnam)]
	allv <- all.vars(fun, uniq = T)
	allv <- allv[!match(allv, c("NA", "T", "F", "Inf", "NULL", ".Internal", 
		fnam), nomatch = 0)]
	body <- fun[[length(fun)]]
	if(mode(body) == "{") {
		anam <- character(0)
		for(i in 1:length(body)) {
			anam <- c(anam, find.assign(body[[i]]))
		}
	}
	else anam <- character(0)
	if(length(anam))
		allv <- allv[ - match(anam, allv, nomatch = 0)]
	allv
}
SHAR_EOF
fi
if test -f 'great.common.div.d'
then
	echo shar: "will not over-write existing file 'great.common.div.d'"
else
cat << \SHAR_EOF > 'great.common.div.d'
.BG
.FN great.common.div
.TL
Greatest Common Divisor
.DN
Returns an integer vector of the greatest common divisor of each
pair of elements of the inputs.
.CS
great.common.div(x, y)
.RA
.AG x
vector of integers.
.AG y
vector of integers the same length as `x'.
.RT
vector of integers giving the greatest common divisor for the 
corresponding elements of `x' and `y'.
.DT
Euclid's algorithm is used.
.SH REFERENCES
Knuth, D. (1981)
.ul
Seminumerical Algorithms.
2nd edition.
Addison-Wesley, Reading, Mass.
.SH BUGS
This does not follow the convention with 0 that Knuth suggests.
.PP
Inputs that are slightly away from an integer result in an answer of 0.
.SA
`rationalnum'.
.EX
great.common.div(1:100, rep(12, 100))
.KW math
.WR
SHAR_EOF
fi
if test -f 'great.common.div.q'
then
	echo shar: "will not over-write existing file 'great.common.div.q'"
else
cat << \SHAR_EOF > 'great.common.div.q'
"great.common.div"<-
function(x, y)
{
	if(length(x) != (n <- length(y)))
		stop("x and y different lengths")
	out <- !is.finite(x) | !is.finite(y)
	x <- round(x)
	y <- round(y)
	okay <- y != 0
	okay[out] <- F
	ans <- z <- x
	while(any(okay)) {
		z[okay] <- x[okay] %% y[okay]
		zz <- z == 0 | is.na(z)
		ans[zz] <- y[zz]
		okay <- okay & !zz
		x[okay] <- y[okay]
		y[okay] <- z[okay]
	}
	ans <- abs(as.integer(ans))
	ans[out] <- NA
	ans
}
SHAR_EOF
fi
if test -f 'ignore.error.d'
then
	echo shar: "will not over-write existing file 'ignore.error.d'"
else
cat << \SHAR_EOF > 'ignore.error.d'
.BG
.FN ignore.error
.TL
Return a Value Upon an Error
.DN
Returns `value' when an error occurs in `call', and ignores the error
(except that the error message is still printed).
.CS
ignore.error(call, value=NULL)
.RA
.AG call
the S expression to be evaluated.
.OA
.AG value
value to be returned if an error occurs when `call' is evaluated.
.RT
if no error occurs, then the return value of `call'.
Otherwise, the input or default `value' is returned.
.SE
error actions will occur, and error messages will be printed, even though
calculation continues.
.DT
You may want to set the `"error"' option to `NULL' if you expect numerous
errors.
.SA
`options', `restart'.
.EX
jja <- array(0, c(3,2)); jjm <- matrix(c(1,3,0,0),2)
for(i in 1:3) {
        jjm[2,2] <- 1/(i-2)
        jja[i,  ] <- ignore.error(eigen(jjm)$val, NA)
}
jja
.KW programming
.WR
SHAR_EOF
fi
if test -f 'ignore.error.q'
then
	echo shar: "will not over-write existing file 'ignore.error.q'"
else
cat << \SHAR_EOF > 'ignore.error.q'
"ignore.error"<-
function(call, value = NULL)
{
	nframe <- sys.nframe()
	flag <- paste("flag.ignorE.error", nframe, sep = ".")
	if(exists(flag, frame = 1) && get(flag, frame = 1)) {
		assign(flag, F, frame = 1)
		cat("(ignored)\n", file = "|stderr")
		return(value)
	}
	else assign(flag, T, frame = 1)
	restart(T)
	ans <- eval(call, nframe - 1)
	assign(flag, F, frame = 1)
	ans
}
SHAR_EOF
fi
if test -f 'incidmat.d'
then
	echo shar: "will not over-write existing file 'incidmat.d'"
else
cat << \SHAR_EOF > 'incidmat.d'
.BG
.FN incidmat
.FN incidmat.mathgraph
.TL
Incidence Matrix for a Mathematical Graph
.DN
Returns an object of class `"incidmat"' which is a matrix indicating
the start and end node for each edge in the graph.
.CS
incidmat.mathgraph(x, expand=T, general=F)
.RA
.AG x
object representing a mathematical graph.
.OA
.AG expand
logical flag: if `TRUE', then undirected edges are represented by two columns
in the output.  
If `FALSE', then both non-zero elements of an undirected edge are positive.
.AG general
logical flag: if `TRUE', then there is a non-zero entry in a column
representing a loop.
.RT
an object of class `"incidmat"' which is a matrix with rows representing
nodes and columns representing edges.
Generally speaking, there is a `1' in the location where an edge begins
and a `-1' in the location where it ends.
.DT
The `incidmat' function is generic, with a method for class `"mathgraph"'.
.SH REFERENCES
Chachra, V., Ghare, P. M. and Moore, J. M. (1979).
.ul
Applications of Graph Theory Algorithms.
Elvesier North Holland, New York.
.SA
`adjamat', `mathgraph', `getpath.incidmat'.
.EX
incidmat(mathgraph(~ 1:3 / 3:5, dir=T))
incidmat(mathgraph(~ 1:3 / 3:5, dir=F))
incidmat(mathgraph(~ 1:3 / 3:5, dir=F), ex=F)
.WR
SHAR_EOF
fi
if test -f 'incidmat.mathgraph.q'
then
	echo shar: "will not over-write existing file 'incidmat.mathgraph.q'"
else
cat << \SHAR_EOF > 'incidmat.mathgraph.q'
"incidmat.mathgraph"<-
function(x, expand = T, general = F)
{
	x <- unclass(x)
	xdir <- attr(x, "directed")
	nedge <- dim(x)[1]
	eseq <- 1:nedge
	cnam <- dimnames(x)[[1]]
	has.names <- c(nodes = is.character(x), edges = T)
	if(!length(cnam)) {
		has.names["edges"] <- F
		cnam <- paste(ifelse(xdir, "arc", "edge"), eseq)
	}
	ischar <- is.character(x)
	if(ischar) {
		nnam <- unique(x)
		nnode <- length(nnam)
		dx <- dim(x)
		x <- match(x, nnam)
		dim(x) <- dx
	}
	else {
		if(!is.numeric(x))
			stop("nodes must be character or numeric")
		nnode <- max(x)
		nnam <- paste("node", 1:nnode)
	}
	loops <- x[, 1] == x[, 2]
	if(expand && !all(xdir)) {
		cnam <- rep(cnam, 2 - xdir)
		ans <- array(0, c(nnode, length(cnam)), list(nnam, cnam))
		reseq <- match(eseq, rep(eseq, 2 - xdir))
		ans[cbind(x[, 2], reseq)] <- -1
		ans[cbind(x[, 1], reseq)] <- 1
		ans[cbind(x[!xdir, 1], reseq[!xdir] + 1)] <- -1
		ans[cbind(x[!xdir, 2], reseq[!xdir] + 1)] <- 1
		if(any(loops)) {
			rloops <- rep(loops, 2 - xdir)
			loop.node <- rep(x[loops, 1], 2 - xdir[loops])
			if(general) {
				ans[cbind(loop.node, seq(along = rloops)[rloops
				  ])] <- 1
			}
			else {
				ans[, rloops] <- 0
			}
		}
	}
	else {
		ans <- array(0, c(nnode, nedge), list(nnam, cnam))
		ans[cbind(x[, 1], eseq)] <- 1
		ans[cbind(x[, 2], eseq)] <- ifelse(xdir, -1, 1)
		if(any(loops)) {
			if(general) {
				ans[cbind(x[loops, 1], eseq[loops])] <- 2 - 
				  xdir[loops]
			}
			else {
				ans[, loops] <- 0
			}
		}
	}
	attr(ans, "has.names") <- has.names
	attr(ans, "call") <- match.call()
	class(ans) <- "incidmat"
	ans
}
SHAR_EOF
fi
if test -f 'incidmat.q'
then
	echo shar: "will not over-write existing file 'incidmat.q'"
else
cat << \SHAR_EOF > 'incidmat.q'
"incidmat"<-
function(x, ...)
UseMethod("incidmat")
SHAR_EOF
fi
if test -f 'interlude.d'
then
	echo shar: "will not over-write existing file 'interlude.d'"
else
cat << \SHAR_EOF > 'interlude.d'
.BG
.FN interlude
.FN uninterlude
.FN summary.interlude
.TL
Time Profile of Functions
.DN
Keeps track of the time used and the number of calls to specified functions.
.CS
interlude(x)
uninterlude(x)
summary.interlude()
.RA
.AG x
vector of character strings naming the functions to be profiled.
This is an optional argument for `uninterlude', the default is to remove
all functions being profiled.
If only one function is given, it need not be quoted.
.RT
`summary.interlude' returns a matrix with rows representing the functions
currently being profiled, and columns that are the total time used, the
number of calls and the mean time per call.
.PP
`uninterlude' invisibly returns a character vector of the functions
removed from profiling.
.SE
`interlude' creates new versions of the functions to be profiled on the
session database (database 0), and creates an object there called
`.Interlude' that keeps track of the data.
.PP
`uninterlude' removes the specified functions from being profiled.
.DT
If you profile both a function and functions that it calls, then you
may need to be a little skeptical of the time for the top function 
since its time includes time that the profiling uses up.
This should not be a problem unless not much time is used--the profiling
takes quite a small amount of time.
If you are only interested in the number of function calls, then there
is no problem at all.
.PP
This set of functions uses the same mechanism that `trace' uses.
.SH WARNING
You probably do not want to edit a function that is currently being
profiled, since you will end up with the profiling garbage mixed in
with your definition.
.SH BUGS
This will typically not work on functions that use `on.exit'.
If the function has any calls that are `on.exit()', then there is
no way to make it work (automatically, that is).
Other calls to `on.exit' need to have `add=T' added.
.SA
`trace', `on.exit', `unix.time'.
.EX
fjj <- function(x) sum((x-1)^2) 
interlude("fjj")
nlminb(1:9, fjj)
summary.interlude() # see time taken
uninterlude() # turn off profiling
.KW programming
.WR
SHAR_EOF
fi
if test -f 'interlude.q'
then
	echo shar: "will not over-write existing file 'interlude.q'"
else
cat << \SHAR_EOF > 'interlude.q'
"interlude"<-
function(x)
{
	if(!is.character(x))
		x <- deparse(substitute(x))
	if(exists(".Interlude", where = 0))
		ilist <- get(".Interlude", where = 0)
	else {
		ilist <- list(0)
		class(ilist) <- "interlude"
	}
	onelist <- list(total.time = rep(0, 5), ncalls = 0)
	iexpr <- expression(NULL, on.exit({
		.interludE.final <- proc.time()
		if(length(.interludE.init) == 3)
			.interludE.init <- c(.interludE.init, 0, 0)
		if(length(.interludE.final) == 3)
			.interludE.final <- c(.interludE.final, 0, 0)
		.interludE.list <- get(".Interlude", where = 0)
		.interludE.thisl <- .interludE.list[[.interludE.name]]
		.interludE.thisl$total.time <- .interludE.thisl$total.time + (
			.interludE.final - .interludE.init)
		.interludE.thisl$ncalls <- .interludE.thisl$ncalls + 1
		.interludE.list[[.interludE.name]] <- .interludE.thisl
		assign(".Interlude", .interludE.list, where = 0)
	}
	), .interludE.init <- proc.time(), NULL)
	mode(iexpr) <- "{"
	lenex <- length(iexpr)
	makefun <- rep(T, length(x))
	names(makefun) <- x
	if(length(old <- intersect(names(ilist), x)))
		makefun[old] <- F
	for(i in x) {
		ilist[[i]] <- onelist
		if(makefun[i]) {
			thisfun <- get(i)
			thisn <- length(thisfun)
			thisbody <- iexpr
			thisbody[[1]] <- substitute(.interludE.name <- iname, 
				list(iname = i))
			thisbody[[lenex]] <- thisfun[[thisn]]
			thisfun[[thisn]] <- thisbody
			assign(i, thisfun, where = 0)
		}
	}
	assign(".Interlude", ilist, where = 0)
}
SHAR_EOF
fi
if test -f 'interpolator.lagrange.d'
then
	echo shar: "will not over-write existing file 'interpolator.lagrange.d'"
else
cat << \SHAR_EOF > 'interpolator.lagrange.d'
.BG
.FN interpolator.lagrange
.TL
Create Lagrange Interpolation Function
.DN
Takes a vector of domain values and a vector of corresponding function
values and returns a function that produces the Lagrange interpolation
for values in the range of x given these values.
.CS
interpolator.lagrange(x, y)
.RA
.AG x
numeric vector of values in the domain of the function of interest.
.AG y
numeric vector of function values at `x'.
.RT
a function of one variable 
which returns an approximation to the mathematical function.
.DT
This function provides an example of how to have a function create
functions.  The S-PLUS help file for `call' contains another example.
.SH REFERENCES
Abramowitz, M. and Stegun, I. (1972).
.ul
Handbook of Mathematical Functions.
Dover, New York.
.SA
`approx', `substitute', `call', `parse', `expression'.
.EX
jjx <- seq(0, pi/2, length=5)
sin.approx <- interpolator.lagrange(jjx, sin(jjx))
# sin.approx is now a function that approximates the sine function
# within the interval 0 to pi/2
sin.approx(.5)

jjss <- sin.approx(seq(0, pi/2, length=100))

# plot the error from linear and Lagrange interpolation 
matplot(jjxx, cbind(approx(jjx, sin(jjx), jjxx)$y, jjss)
	- sin(jjxx), type="l")
.KW math
.KW programming
.WR
SHAR_EOF
fi
if test -f 'interpolator.lagrange.q'
then
	echo shar: "will not over-write existing file 'interpolator.lagrange.q'"
else
cat << \SHAR_EOF > 'interpolator.lagrange.q'
"interpolator.lagrange"<-
function(x, y)
{
	if(length(x) != length(y))
		stop("x and y must be the same length")
	ans <- function(z)
	{
	}
	body <- expression(zlen <- length(z), NULL, NULL, z[zout] <- NA, NULL, 
		tabz <- array(rep(z, rep(ilen, zlen)), c(ilen, zlen)), NULL, 
		tab <- aperm(tab, c(1, 3, 2)), tab[row(tab) == col(tab)] <- 1, 
		num <- apply(tab, c(1, 3), prod), ans <- rep(1, ilen) %*% (
		y.den * num), attributes(ans) <- attributes(z), ans)
	mode(body) <- "{"
	body[[2]] <- substitute(ilen <- length.x, list(length.x = length(x)))
	body[[3]] <- substitute(zout <- (z < minx | z > maxx), list(minx = min(
		x), maxx = max(x)))
	tab <- outer(x, x, "-")
	diag(tab) <- 1
	den <- apply(tab, 1, prod)
	body[[5]] <- call("assign", "y.den", y/den)
	body[[7]] <- substitute(tab <- outer(tabz, x, "-"), list(x = x))
	ans[[length(ans)]] <- body
	test <- all.equal(ans(x), y)
	if(!is.logical(test) || !test)
		stop("function didn't build correctly")
	ans
}
SHAR_EOF
fi
if test -f 'is.na.rationalnum.q'
then
	echo shar: "will not over-write existing file 'is.na.rationalnum.q'"
else
cat << \SHAR_EOF > 'is.na.rationalnum.q'
"is.na.rationalnum"<-
function(x)
{
	is.na(x$numerator) | is.na(x$denominator) | is.nan(x)
}
SHAR_EOF
fi
if test -f 'is.nan.rationalnum.q'
then
	echo shar: "will not over-write existing file 'is.nan.rationalnum.q'"
else
cat << \SHAR_EOF > 'is.nan.rationalnum.q'
"is.nan.rationalnum"<-
function(x)
{
	ans <- x$numerator == 0 & x$denominator == 0
	ans[is.na(ans)] <- F
	names(ans) <- x$names
	ans
}
SHAR_EOF
fi
if test -f 'jjtest1.c'
then
	echo shar: "will not over-write existing file 'jjtest1.c'"
else
cat << \SHAR_EOF > 'jjtest1.c'

double
jjtest1(pars, n)
long *n;
double *pars;
{
	long i;
	double dif, ans=0.0;
	static double data[6] = { 3.4, 6.3, 9.2, -.7, 2.1, 8.8};

	for(i=0; i < 3; i++) {
		dif = data[i] - pars[0];
		ans = ans + dif * dif;
	}
	for(i=3; i < 6; i++) {
		dif = data[i] - pars[1];
		ans = ans + dif * dif;
	}
	return(ans);
}
SHAR_EOF
fi
if test -f 'jjtest2.f'
then
	echo shar: "will not over-write existing file 'jjtest2.f'"
else
cat << \SHAR_EOF > 'jjtest2.f'

	function jjtest2(pars, n)
	implicit none
	integer n
	double precision pars(n)
	integer i
	double precision dif, jjtest2, tdat(6)
	tdat(1) = 3.4
	tdat(2) = 6.3
	tdat(3) = 9.2
	tdat(4) = -.7
	tdat(5) = 2.1
	tdat(6) = 8.8
	
	jjtest2 = 0.0

	do 10 i=1, 3
		dif = tdat(i) - pars(1)
		jjtest2 = jjtest2 + dif * dif
   10	continue
	do 20 i=4, 6
		dif = tdat(i) - pars(2)
		jjtest2 = jjtest2 + dif * dif
   20	continue
	return
	end
SHAR_EOF
fi
if test -f 'jjtest3.c'
then
	echo shar: "will not over-write existing file 'jjtest3.c'"
else
cat << \SHAR_EOF > 'jjtest3.c'
#include <S.h>

double
jjtest3(pars, n, lengs, data)
long n, *lengs;
double *pars, *data;
{
	long i, j, count=0, top_count=0;
	double dif, ans=0.0;

	for(i=0; i < n; i++) {
		top_count += lengs[i];
		for(j=count; j < top_count; j++) {
			dif = data[j] - pars[i];
			ans = ans + dif * dif;
		}
		count = top_count;
	}
	return(ans);
}
SHAR_EOF
fi
if test -f 'jjtest4.f'
then
	echo shar: "will not over-write existing file 'jjtest4.f'"
else
cat << \SHAR_EOF > 'jjtest4.f'

	function jjtest4(pars, n, data)
	implicit none
	integer n(2)
	double precision pars(2), data(n(1)+n(2))
	integer i
	double precision dif, jjtest4
	
	jjtest4 = 0.0

	do 10 i=1, n(1)
		dif = data(i) - pars(1)
		jjtest4 = jjtest4 + dif * dif
   10	continue
	do 20 i=1, n(2)
		dif = data(n(1) + i) - pars(2)
		jjtest4 = jjtest4 + dif * dif
   20	continue
	return
	end
SHAR_EOF
fi
if test -f 'justify.d'
then
	echo shar: "will not over-write existing file 'justify.d'"
else
cat << \SHAR_EOF > 'justify.d'
.BG
.FN justify
.TL
Justify Elements of a Vector
.DN
Returns a vector like the input, but each string may have added blank
spaces at the start and/or end.
.CS
justify(x, type="r")
.RA
.AG x
a character vector.
.OA
.AG type
a string giving the type of justification.
This may be an abbreviation of one of "right", "left", "center".
.RT
a character vector like x, except all elements have the same number
of characters, and the text is lined up along one edge, or centered.
.SA
format, substring, paste.
.EX
as.matrix(justify(dimnames(freeny.x)[[2]], "r"))
as.matrix(justify(dimnames(freeny.x)[[2]], "l"))
as.matrix(justify(dimnames(freeny.x)[[2]], "c"))
.KW character
.WR
SHAR_EOF
fi
if test -f 'justify.q'
then
	echo shar: "will not over-write existing file 'justify.q'"
else
cat << \SHAR_EOF > 'justify.q'
"justify"<-
function(x, type = "r")
{
	type <- unabbrev.value(type, c("right", "center", "left"))
	x <- as.character(x)
	ncx <- nchar(x)
	blanks <- paste(rep(" ", max(ncx)), collapse = "")
	blanks <- substring(blanks, 1, max(ncx) - ncx)
	switch(type,
		right = paste(blanks, x, sep = ""),
		left = paste(x, blanks, sep = ""),
		center = {
			blank.half <- nchar(blanks) %/% 2
			paste(substring(blanks, 1, blank.half), x, substring(
				blanks, blank.half + 1), sep = "")
		}
		)
}
SHAR_EOF
fi
if test -f 'length.mathgraph.q'
then
	echo shar: "will not over-write existing file 'length.mathgraph.q'"
else
cat << \SHAR_EOF > 'length.mathgraph.q'
"length.mathgraph"<-
function(x)
{
	x <- unclass(x)
	if(length(x))
		dim(x)[1]
	else 0
}
SHAR_EOF
fi
if test -f 'length.rationalnum.q'
then
	echo shar: "will not over-write existing file 'length.rationalnum.q'"
else
cat << \SHAR_EOF > 'length.rationalnum.q'
"length.rationalnum"<-
function(x)
length(x$numerator)
SHAR_EOF
fi
if test -f 'lengthGets.rationalnum.q'
then
	echo shar: "will not over-write existing file 'lengthGets.rationalnum.q'"
else
cat << \SHAR_EOF > 'lengthGets.rationalnum.q'
"length<-.rationalnum"<-
function(x, value)
{
	length(x$numerator) <- value
	length(x$denominator) <- value
	if(length(x$names))
		length(x$names) <- value
	x
}
SHAR_EOF
fi
if test -f 'line.integral.d'
then
	echo shar: "will not over-write existing file 'line.integral.d'"
else
cat << \SHAR_EOF > 'line.integral.d'
.BG
.FN line.integral
.TL
Real or Complex Numerical Integration
.DN
Integrates the function along a line or a series of lines in the complex
plane.
.CS
line.integral(FUN, POINTS, EVALS=100, METHOD="simpson", ...)
.RA
.AG FUN
function or the name of a function.
This must be vectorized in the argument that is being integrated.
.AG POINTS
the corners of the contour of integration.
.OA
.AG EVALS
the number of points at which to evaluate the function on each segment
of the contour.
.AG METHOD
character string that partially matches `"simpson"' or `"trapezoid"'.
.AG ...
additional arguments to `FUN' may be given.
.RT
the approximation to the integral.
.DT
If you want a closed contour, then the last point should be the same
as the first point.
.SH REFERENCES
Press, W.H., Teukolsky, S.A., Vetterling, W.T., Flannery, B.P. (1992).
.ul
Numerical Recipes in C, Second Edition.
Cambridge University Press, Cambridge.
.SA
`integrate'.
.EX
line.integral(function(z) 1/z, complex(re=c(1,1,-1,-1,1),
	im=c(-1,1,1,-1,-1))) # should be pi * 2i

fjje2 <- function(x, y) exp(.01*x^2 - x*y)
line.integral(fjje2, c(-10,5), y=5)
line.integral(fjje2, c(-10,5), x=5)
.KW math
.WR
SHAR_EOF
fi
if test -f 'line.integral.q'
then
	echo shar: "will not over-write existing file 'line.integral.q'"
else
cat << \SHAR_EOF > 'line.integral.q'
"line.integral"<-
function(FUN, POINTS, EVALS = 100, METHOD = "simpson", ...)
{
	METHOD <- unabbrev.value(METHOD, c("trapezoid", "simpson"))
	n <- length(POINTS)
	if(n < 2)
		stop("POINTS must have length at least 2")
	switch(METHOD,
		simpson = {
# want odd number of evaluation points
			if(EVALS %% 2 == 0) EVALS <- EVALS + 1
		}
		)
	if(is.character(FUN))
		FUN <- get(FUN, mode = "function")
	ans <- 0
	for(i in 2:n) {
		this.seq <- seq(POINTS[i - 1], POINTS[i], length = EVALS)
		this.ans <- FUN(this.seq, ...)
		if(length(this.ans) != EVALS)
			stop("FUN not properly vectorized")
		ans <- ans + switch(METHOD,
			trapezoid = {
				(sum(this.ans) - 0.5 * sum(this.ans[c(1, EVALS)
				  ])) * (this.seq[2] - this.seq[1])
			}
			,
			simpson = {
				sum(this.ans * c(1, rep(c(4, 2), length = EVALS -
				  2), 1))/3 * (this.seq[2] - this.seq[1])
			}
			)
	}
	ans
}
SHAR_EOF
fi
if test -f 'loan.d'
then
	echo shar: "will not over-write existing file 'loan.d'"
else
cat << \SHAR_EOF > 'loan.d'
.BG
.FN loan
.TL
Create Loan Object
.DN
Returns an object of class loan that inherits from data.frame.
.CS
loan(amount, rate, month, year)
.RA
.AG amount
number giving the amount that the loan is for.
.AG rate
annual rate of the loan (actually 12 times the monthly rate).
.AG month
number for or start of the month name in which the loan starts.
.AG year
number giving the year in which the loan starts.
.RT
an object of class loan which inherits from data.frame.
There is a single row which is the time of the start of the loan.
The columns are the month, year, principal, interest and payment.
There are two special attributes:
.RC rate
the interest rate for the loan.
.RC last.date
in this case the date of the loan, but in general the last time a
payment was made.
.DT
This merely initializes the loan object, the method for the update
generic function performs the real work.
.SA
update.loan, data.frame.
.EX
jjcar.loan <- loan(8000, .08, "May", 1998)
jjcar.loan <- update(jjcar.loan, rep(234, 3))
jjcar.loan
.WR
SHAR_EOF
fi
if test -f 'loan.q'
then
	echo shar: "will not over-write existing file 'loan.q'"
else
cat << \SHAR_EOF > 'loan.q'
"loan"<-
function(amount, rate, month, year)
{
	names(month.name) <- month.name
	ans <- data.frame(month = month.name[month], year = year, principal = 
		amount, interest = as.double(NA), payment = as.double(NA))
	attr(ans, "rate") <- rate
	if(is.character(month))
		month <- pmatch(month, month.name)
	attr(ans, "last.date") <- c(month = month, year = year)
	class(ans) <- c("loan", "data.frame")
	ans
}
SHAR_EOF
fi
if test -f 'mathgraph.d'
then
	echo shar: "will not over-write existing file 'mathgraph.d'"
else
cat << \SHAR_EOF > 'mathgraph.d'
.BG
.FN mathgraph
.FN [.mathgraph
.FN [<-.mathgraph
.FN length.mathgraph
.FN c.mathgraph
.TL
Create Mathematical Graph
.DN
Create an object of class `"mathgraph"' which represents a mathematical
graph.
.CS
mathgraph(formula, directed=F, data=sys.parent())
.RA
.AG formula
a formula containing just the right-side.
Special operators in the formula are `+' which separates terms, `/' which
puts an edge between corresponding elements of the two vectors on which
it is operating, and `*' which puts an edge between every pair of elements
in the two vectors on which it is operating.
.OA
.AG directed
logical flag: if `TRUE', then all edges that are created are directed,
otherwise they are undirected.
.AG data
the frame in which to find objects referenced in the formula.
This can be either the number of a memory frame, or a list or data frame
containing the data.
.RT
an object of class `mathgraph' which is a two-column matrix of nodes
along with an additional attribute called `"directed"' which is a logical
vector stating whether or not each edge is directed.
An edge (row of the matrix) that is directed goes from the node in the first
column to the node in the second column.
.DT
Mathematical graphs consist of a set of nodes (vertices) and edges.
Edges go between two nodes.
An edge that is directed is often called an arc.
.PP
Terms in the formula (delimited by +)
may be either calls to `*' or `/', or objects that
are already of class `"mathgraph"'.
.PP
Two other representations of graphs are adjacency matrices and incidence
matrices.
The functions to convert `"mathgraph"' objects to these are `adjamat' and
`incidmat', respectively.
Most algorithms for mathematical graphs are in terms of incidence matrices
or adjacency matrices.
.PP
The generic functions that have a method for class `"mathgraph"' include:
`[', `c', `length', `names', `plot', `print', `unique'.
.SH REFERENCES
Chachra, V., Ghare, P. M. and Moore, J. M. (1979).
.ul
Applications of Graph Theory Algorithms.
Elvesier North Holland, New York.
.SA
`adjamat', `incidmat', `getpath'.
.EX
mathgraph(~ 1:3 / 2:4) # graph with 3 edges
mathgraph(~ 1:3 * 2:4) # graph with 9 edges

mathgraph(~ 1:3 / 2:4, dir=T) # directed graph with 3 edges

# graph with some edges directed, some not
mathgraph(~ 1:3 * 2:4 + mathgraph(~ c(3,1) / c(2,4), dir=T))
.KW math
.WR
SHAR_EOF
fi
if test -f 'mathgraph.q'
then
	echo shar: "will not over-write existing file 'mathgraph.q'"
else
cat << \SHAR_EOF > 'mathgraph.q'
"mathgraph"<-
function(formula, directed = F, data = sys.parent())
{
	if(missing(formula)) {
		ans <- NULL
	}
	else {
		ans <- build.mathgraph(formula, data = data)
		adir <- attr(ans, "directed")
		adir[is.na(adir)] <- directed
		attr(ans, "directed") <- adir
	}
	class(ans) <- "mathgraph"
	ans
}
SHAR_EOF
fi
if test -f 'names.mathgraph.d'
then
	echo shar: "will not over-write existing file 'names.mathgraph.d'"
else
cat << \SHAR_EOF > 'names.mathgraph.d'
.BG
.FN names.mathgraph
.FN names<-.mathgraph
.TL
Edge Names in a Mathematical Graph
.DN
Sets or returns the names (corresponding to the edges) of a mathematical
graph represented by a mathgraph object.
.CS
names.mathgraph(x)
names.mathgraph(x) <- value
.RA
.AG x
an object inheriting from mathgraph.
.AG value
a character vector that is the same length as x.
.RT
character vector of the names.
.SE
in the assignment form, the names are created or changed.
.SA
mathgraph.
.EX
jjm <- mathgraph(~ 1:3 * 2:4)
jjm
names(jjm) <- letters[1:9]
jjm
names(jjm)
.KW math
.WR
SHAR_EOF
fi
if test -f 'names.mathgraph.q'
then
	echo shar: "will not over-write existing file 'names.mathgraph.q'"
else
cat << \SHAR_EOF > 'names.mathgraph.q'
"names.mathgraph"<-
function(x)
{
	dimnames(unclass(x))[[1]]
}
SHAR_EOF
fi
if test -f 'names.rationalnum.q'
then
	echo shar: "will not over-write existing file 'names.rationalnum.q'"
else
cat << \SHAR_EOF > 'names.rationalnum.q'
"names.rationalnum"<-
function(x)
x$names
SHAR_EOF
fi
if test -f 'namesGet.rationalnum.q'
then
	echo shar: "will not over-write existing file 'namesGet.rationalnum.q'"
else
cat << \SHAR_EOF > 'namesGet.rationalnum.q'
"names<-.rationalnum"<-
function(x, value)
{
	value <- as.character(value)
	if(length(value) != length(x))
		stop("bad length for names")
	x$names <- value
	x
}
SHAR_EOF
fi
if test -f 'namesGets.mathgraph.q'
then
	echo shar: "will not over-write existing file 'namesGets.mathgraph.q'"
else
cat << \SHAR_EOF > 'namesGets.mathgraph.q'
"names<-.mathgraph"<-
function(x, value)
{
	cl <- class(x)
	x <- unclass(x)
	dimnames(x)[[1]] <- value
	class(x) <- cl
	x
}
SHAR_EOF
fi
if test -f 'numberbase.d'
then
	echo shar: "will not over-write existing file 'numberbase.d'"
else
cat << \SHAR_EOF > 'numberbase.d'
.BG
.FN numberbase
.FN numberbase.default
.FN numberbase.numberbase
.FN print.numberbase
.TL
Transform Number Base
.DN
Creates an object that gives the representation of integers in an alternative
base.
.CS
numberbase.default(x, newbase=10, oldbase=10)
numberbase.numberbase(x, newbase=10)
.RA
.AG x
a vector of integers.
This can be either a numeric vector or a vector of character strings.
.OA
.AG newbase
single integer giving the base that is desired.
This must be between 2 and 36, inclusive.
.AG oldbase
single integer giving the base that the input is in.
This must be between 2 and 36, inclusive.
.RT
an object of class `"numberbase"' which is a vector of character strings
along with the attribute `"value"' which is a numeric vector of the value
of the numbers.
.DT
There is a `print' method for the `"numberbase"' class of objects.
.SH BUGS
Only integers are allowed. 
Missing values and special values are not handled.
.PP
No mathematical operations are implemented.
.SA
`format'.
.EX
numberbase(1:10, 2) # get base 2 representation
numberbase(1:20, 16) # get base 16 representation
numberbase("1001101101", old=2) # base 2 to base 10
numberbase("1001101101", 8, 2) # base 8 from base 2
.KW math
.WR
SHAR_EOF
fi
if test -f 'numberbase.default.q'
then
	echo shar: "will not over-write existing file 'numberbase.default.q'"
else
cat << \SHAR_EOF > 'numberbase.default.q'
"numberbase.default"<-
function(x, newbase = 10, oldbase = 10)
{
	ans <- to.base10(x, oldbase)
	if(newbase != 10)
		ans <- numberbase(ans, newbase)
	ans
}
SHAR_EOF
fi
if test -f 'numberbase.numberbase.q'
then
	echo shar: "will not over-write existing file 'numberbase.numberbase.q'"
else
cat << \SHAR_EOF > 'numberbase.numberbase.q'
"numberbase.numberbase"<-
function(x, newbase = 10)
{
	from.base10(attr(x, "value"), newbase)
}
SHAR_EOF
fi
if test -f 'numberbase.q'
then
	echo shar: "will not over-write existing file 'numberbase.q'"
else
cat << \SHAR_EOF > 'numberbase.q'
"numberbase"<-
function(x, ...)
UseMethod("numberbase")
SHAR_EOF
fi
if test -f 'p.replace.d'
then
	echo shar: "will not over-write existing file 'p.replace.d'"
else
cat << \SHAR_EOF > 'p.replace.d'
.BG
.FN p.replace
.TL
Substitute Values
.DN
Returns an object like the input x with some of the values changed.
.CS
p.replace(x, old, new)
.RA
.AG x
an atomic object.
.AG old
vector of values that may appear in x that are to be replaced.
.AG new
vector of values the same length as old containing the new elements.
.RT
an object like the input x, but possibly  with some elements changed.
Wherever the i-th element of old appears in x, the result will contain the
i-th element of new.
.SA
match.
.EX
p.replace(c("x", "r", "dog", "a"), letters, LETTERS)
p.replace(c("x", "r", "dog", "a"), "dog", "cat")
.KW character
.WR
SHAR_EOF
fi
if test -f 'p.unpaste.d'
then
	echo shar: "will not over-write existing file 'p.unpaste.d'"
else
cat << \SHAR_EOF > 'p.unpaste.d'
.BG
.FN p.unpaste
.TL
Alternative Unpaste Function
.DN
Returns a list that is the portions of x delimited by sep.
.CS
p.unpaste(x, sep)
.RA
.AG x
a character string.
.AG sep
a character string containing a single character.
.RT
a list that is one longer than the number of occurrences of sep in x,
where each component is the characters between the occurrences of sep.
.DT
This provides an alternative to the S-PLUS unpaste function if that is
not available to you.
It does not have all of the functionality of unpaste, but enough
to satisfy the needs of the poetry collection of functions.
Neither are as general as they should be, but p.unpaste is following
the structure laid down by unpaste.
.SA
unpaste.
.EX
p.unpaste("x + y", "+")
.KW character
.WR
SHAR_EOF
fi
if test -f 'p.unpaste.q'
then
	echo shar: "will not over-write existing file 'p.unpaste.q'"
else
cat << \SHAR_EOF > 'p.unpaste.q'
"p.unpaste"<-
function(x, sep)
{
	if(length(x) > 1 || !is.character(x))
		stop("x is not right")
	if(nchar(sep) != 1)
		stop("sep is not right")
	scode <- AsciiToInt(sep)
	xcode <- AsciiToInt(x)
	brk <- (1:length(xcode))[xcode == scode]
	if(length(brk)) {
		as.list(substring(x, c(1, brk + 1), c(brk - 1, nchar(x))))
	}
	else list(x)
}
SHAR_EOF
fi
if test -f 'perl.d'
then
	echo shar: "will not over-write existing file 'perl.d'"
else
cat << \SHAR_EOF > 'perl.d'
.BG
.FN perl
.TL
Use a Perl Script
.DN
Creates a perl script and runs it.
The script loops over each element of the input `x'.
.CS
perl(x, cmd, preface="", print=T, trace=F)
.RA
.AG x
an S object, typically a vector of character strings.
.AG cmd
character string(s) which gives the Perl command within the loop.
At each iteration of the loop, the corresponding element of `x' is put
into the `$_' Perl object.
.OA
.AG preface
vector of character strings of Perl commands to be performed before 
entering the loop.
.AG print
logical flag: if `TRUE', then the `$_' object is printed at the end of
each iteration through the loop.
If `FALSE', then there needs to be a `print' command within `cmd'.
.AG trace
logical flag: if `TRUE', then the Perl script that is run is printed.
This is handy for debugging.
.RT
a vector of character strings with as many elements as there were lines
output by Perl.
If the length of this is equal to the length of the input `x', then it
has the attributes that `x' has.
.SE
if `trace' is `TRUE', then the Perl script is printed to standard out.
.DT
S is weak in functionality to process character data; Perl is exceedingly
good at it.  
This is a simple interface to Perl.
It expects that some operation is to be performed on each element of the
input vector.
.PP
An alternative is to use awk, sed and other Unix tools.
.SH WARNING
Note that to get a backslash to Perl, you need to put two backslashes in
the S character string.
.SH REFERENCES
Schwartz, R. L. (1993). 
.ul
Learning Perl.
O'Reilly and Associates, Sebastopol CA.
.PP
Wall, L. and Schwartz, R. L. (1991). 
.ul
Programming perl.
O'Reilly and Associates, Sebastopol, CA.
.SA
`unix', `transcribe', `substifile'.
.EX
# simple substitution
perl(state.name, "s/New/Old/ ;") 

# count the lower case letters in state names:
as.numeric(perl(state.name, "$cnt = tr/a-z//; print $cnt;",
	preface='$\e\e="\en";', print=F))

# another way to do the same thing:
as.numeric(perl(state.name,
	'$cnt = tr/a-z//; print ($cnt, "\en");', print=F))
.KW interface
.KW character
.WR
SHAR_EOF
fi
if test -f 'perl.q'
then
	echo shar: "will not over-write existing file 'perl.q'"
else
cat << \SHAR_EOF > 'perl.q'
"perl"<-
function(x, cmd, preface = "", print = T, trace = F)
{
	ploc <- tempfile("sperl")
	on.exit(unlink(ploc))
	perl.pre <- c("#!/usr/bin/perl", preface, "while(<>) {")
	if(print)
		perl.post <- c(";\tprint $_ ;", "}")
	else perl.post <- c(";", "}")
	cat(file = ploc, c(perl.pre, cmd, perl.post), sep = "\n")
	if(trace) {
		foo <- unix(paste("cat", ploc), out = F)
	}
	ans <- unix(paste("perl", ploc), x)
	if(length(ans) == length(x))
		attributes(ans) <- attributes(x)
	ans
}
SHAR_EOF
fi
if test -f 'plot.mathgraph.d'
then
	echo shar: "will not over-write existing file 'plot.mathgraph.d'"
else
cat << \SHAR_EOF > 'plot.mathgraph.d'
.BG
.FN plot.mathgraph
.TL
Plot a Mathematical Graph
.DN
Very crude plotting method for `mathgraph' class.
.CS
plot.mathgraph(x, ...)
.RA
.AG x
an object that inherits from `mathgraph'.
.OA
.AG ...
graphics parameters may be given.
.SE
a representation of the mathematical graph is produced on
the current graphics device.
.SH BUGS
Needs to be smarter, and allow the user some control.
.SA
`mathgraph', `plot'.
.EX
plot(mathgraph(~ 1:3 * 2:4))
.KW hplot
.KW math
.WR
SHAR_EOF
fi
if test -f 'plot.mathgraph.q'
then
	echo shar: "will not over-write existing file 'plot.mathgraph.q'"
else
cat << \SHAR_EOF > 'plot.mathgraph.q'
"plot.mathgraph"<-
function(x, ...)
{
	x <- unclass(x)
	xdir <- attr(x, "directed")
	if(ischar <- is.character(x)) {
		node.names <- unique(x)
		maxx <- length(node.names)
		dx <- dim(x)
		x <- match(x, node.names)
		dim(x) <- dx
	}
	else {
		maxx <- max(x)
		node.names <- as.character(1:maxx)
	}
	px <- cos((2 * 0:(maxx - 1) * pi)/maxx)
	py <- sin((2 * 0:(maxx - 1) * pi)/maxx)
	plot(px, py, axes = F, xlab = "", ylab = "", xlim = c(-1.04, 1.04), 
		ylim = c(-1.04, 1.04), ...)
	box()
	px <- 0.97999999999999998 * px
	py <- 0.97999999999999998 * py
	if(!all(xdir))
		segments(px[x[!xdir, 1]], py[x[!xdir, 1]], px[x[!xdir, 2]], py[
			x[!xdir, 2]])
	if(any(xdir))
		arrows(px[x[xdir, 1]], py[x[xdir, 1]], px[x[xdir, 2]], py[x[
			xdir, 2]])
	text(px * 1.0700000000000001, py * 1.0700000000000001, node.names)
	invisible()
}
SHAR_EOF
fi
if test -f 'poet.data.restore.d'
then
	echo shar: "will not over-write existing file 'poet.data.restore.d'"
else
cat << \SHAR_EOF > 'poet.data.restore.d'
.BG
.FN poet.data.restore
.TL
Load S Objects
.DN
Vectorized form of data.restore with the default input being any
files that end in ".Q".
.CS
poet.data.restore(x=unix("ls *.Q"))
.OA
.AG x
character vector of filenames containing representations of S objects
created by data.dump.
.SE
the objects are put on the working database.
.DT
Used as a kludge because `CHAPTER' does not support this functionality.
.SA
`data.dump', `data.restore', `CHAPTER'.
.EX
poet.data.restore()

poet.data.restore(c("my.obj.qq", "my.other.obj.Q"))
.WR
SHAR_EOF
fi
if test -f 'poet.data.restore.q'
then
	echo shar: "will not over-write existing file 'poet.data.restore.q'"
else
cat << \SHAR_EOF > 'poet.data.restore.q'
"poet.data.restore"<-
function(x = unix("ls *.Q"))
{
	for(i in x)
		data.restore(i)
	invisible()
}
SHAR_EOF
fi
if test -f 'poet.dyn.load.d'
then
	echo shar: "will not over-write existing file 'poet.dyn.load.d'"
else
cat << \SHAR_EOF > 'poet.dyn.load.d'
.BG
.FN poet.dyn.load
.TL
Load Code from S Poetry
.DN
Loads object files for the "poetry" functions.
This depends on Poet.Location being set to the string describing
the directory where the files live. 
.CS
poet.dyn.load(fname)
.RA
.AG fname
name of the file being loaded.
.SE
the code is dynamically loaded into the S session.
.DT
This is a means of indirection to make it easier to load the code.
It also uses dyn.load2 if dyn.load is unavailable.
.SA
dyn.load, dyn.load2.
.KW programming
.WR
SHAR_EOF
fi
if test -f 'poet.dyn.load.q'
then
	echo shar: "will not over-write existing file 'poet.dyn.load.q'"
else
cat << \SHAR_EOF > 'poet.dyn.load.q'
"poet.dyn.load"<-
function(fname)
{
	if(!exists("Poet.Location"))
		stop("set Poet.Location to poetry directory")
	real.loc <- paste(Poet.Location, fname, sep = "/")
	if(exists("dyn.load"))
		ans <- dyn.load(real.loc)
	else ans <- dyn.load2(real.loc)
	invisible(ans)
}
SHAR_EOF
fi
if test -f 'poet.verif.Q'
then
	echo shar: "will not over-write existing file 'poet.verif.Q'"
else
cat << \SHAR_EOF > 'poet.verif.Q'
poet.verif
structure
6
.Data
list
30
transcribe
character
1
state_name
loan
structure
5
.Data
list
5
month
structure
4
.Data
integer
1
1
.Label
character
1
February
.Names
character
1
February
class
character
1
factor
year
numeric
1
1997
principal
numeric
1
2000
interest
numeric
1
N
payment
numeric
1
N
row.names
character
1
1
class
character
2
loan
data.frame
rate
numeric
1
0.080000000000000002
last.date
structure
2
.Data
numeric
2
2
1997
.Names
character
2
month
year
update.loan
structure
5
.Data
list
5
month
structure
3
.Data
integer
6
1
5
2
6
4
3
.Label
character
6
February
April
July
June
March
May
class
character
1
factor
year
numeric
6
1997
1997
1997
1997
1997
1997
principal
numeric
6
2000
1913.3299999999999
1826.0899999999999
1738.26
1649.8499999999999
1560.8499999999999
interest
numeric
6
N
13.33
12.76
12.17
11.59
11
payment
numeric
6
N
100
100
100
100
100
row.names
character
6
1
2
3
4
5
6
rate
numeric
1
0.080000000000000002
last.date
structure
2
.Data
numeric
2
7
1997
.Names
character
2
month
year
class
character
2
loan
data.frame
numbase
structure
4
.Data
character
19
-1001
-1000
-111
-110
-101
-100
-11
-10
-1
0
1
10
11
100
101
110
111
1000
1001
value
numeric
19
-9
-8
-7
-6
-5
-4
-3
-2
-1
0
1
2
3
4
5
6
7
8
9
base
numeric
1
2
class
character
1
numberbase
ratnum
structure
2
.Data
list
3
numerator
numeric
256
1
3
1
1
0
-1
-1
-3
-1
-7
-5
J
I
N
0
102339
4
1
2
1
0
-1
-2
-1
-4
-7
-10
J
I
N
0
68226
2
3
1
1
0
-1
-1
-3
-2
-7
-5
J
I
N
0
102339
4
3
2
1
0
-1
-2
-3
-4
-7
-10
J
I
N
0
204678
J
J
J
J
0
I
I
I
I
I
I
I
J
N
0
J
-4
-3
-2
-1
0
1
2
3
4
7
10
I
J
N
0
-204678
-2
-3
-1
-1
0
1
1
3
2
7
5
I
J
N
0
-102339
-4
-1
-2
-1
0
1
2
1
4
7
10
I
J
N
0
-68226
-1
-3
-1
-1
0
1
1
3
1
7
5
I
J
N
0
-102339
-4
-3
-2
-1
0
1
2
3
4
1
10
I
J
N
0
-204678
-2
-3
-1
-1
0
1
1
3
2
7
1
I
J
N
0
-102339
0
0
0
0
0
0
0
0
0
0
0
0
0
N
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
N
0
0
N
N
N
N
N
N
N
N
N
N
N
N
N
N
0
N
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
2
1
1
1
0
-1
-1
-1
-2
-7
-5
J
I
N
0
1
denominator
numeric
256
1
4
2
4
1
4
2
4
1
4
2
1
1
-4
0
2
3
1
3
3
1
3
3
1
3
3
3
1
1
-3
0
1
1
2
1
2
1
2
1
2
1
2
1
1
1
-2
0
1
1
1
1
1
1
1
1
1
1
1
1
1
1
-1
0
1
1
1
1
1
0
1
1
1
1
1
1
1
1
0
0
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
0
1
1
2
1
2
1
2
1
2
1
2
1
1
1
2
0
1
3
1
3
3
1
3
3
1
3
3
3
1
1
3
0
1
1
4
2
4
1
4
2
4
1
4
2
1
1
4
0
2
7
7
7
7
1
7
7
7
7
1
7
1
1
7
0
7
5
10
5
10
1
10
5
10
5
10
1
1
1
10
0
5
1
1
1
1
1
1
1
1
1
1
1
0
0
I
0
1
1
1
1
1
1
1
1
1
1
1
1
0
0
J
0
1
N
N
N
N
N
N
N
N
N
N
N
N
N
N
0
N
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
102339
68226
102339
204678
1
204678
102339
68226
102339
204678
102339
1
1
-204678
0
1
names
NULL
0
class
character
1
rationalnum
ratnum.op
structure
2
.Data
list
3
numerator
numeric
256
-1
-3
-1
-1
0
1
1
3
1
7
5
0
0
N
0
-102339
-4
-1
-2
-1
0
1
2
1
4
7
10
0
0
N
0
-68226
-2
-3
-1
-1
0
1
1
3
2
7
5
0
0
N
0
-102339
-4
-3
-2
-1
0
1
2
3
4
7
10
0
0
N
0
-204678
0
0
0
0
0
0
0
0
0
0
0
0
0
N
0
0
4
3
2
1
0
-1
-2
-3
-4
-7
-10
0
0
N
0
204678
2
3
1
1
0
-1
-1
-3
-2
-7
-5
0
0
N
0
102339
4
1
2
1
0
-1
-2
-1
-4
-7
-10
0
0
N
0
68226
1
3
1
1
0
-1
-1
-3
-1
-7
-5
0
0
N
0
102339
4
3
2
1
0
-1
-2
-3
-4
-1
-10
0
0
N
0
204678
2
3
1
1
0
-1
-1
-3
-2
-7
-1
0
0
N
0
102339
0
0
0
0
0
0
0
0
0
0
0
0
0
N
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
N
0
0
N
N
N
N
N
N
N
N
N
N
N
N
N
N
0
N
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
-2
-1
-1
-1
0
1
1
1
2
7
5
0
0
N
0
-1
denominator
numeric
256
1
4
2
4
1
4
2
4
1
4
2
0
0
16
0
2
3
1
3
3
1
3
3
1
3
3
3
0
0
9
0
1
1
2
1
2
1
2
1
2
1
2
1
0
0
4
0
1
1
1
1
1
1
1
1
1
1
1
1
0
0
1
0
1
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
1
1
1
1
1
1
1
1
1
1
1
0
0
1
0
1
1
2
1
2
1
2
1
2
1
2
1
0
0
4
0
1
3
1
3
3
1
3
3
1
3
3
3
0
0
9
0
1
1
4
2
4
1
4
2
4
1
4
2
0
0
16
0
2
7
7
7
7
1
7
7
7
7
1
7
0
0
49
0
7
5
10
5
10
1
10
5
10
5
10
1
0
0
100
0
5
1
1
1
1
1
1
1
1
1
1
1
0
0
I
0
1
1
1
1
1
1
1
1
1
1
1
1
0
0
I
0
1
N
N
N
N
N
N
N
N
N
N
N
N
N
N
0
N
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
102339
68226
102339
204678
1
204678
102339
68226
102339
204678
102339
0
0
41893083684
0
1
names
NULL
0
class
character
1
rationalnum
pg1
numeric
10
1.6449340668482257
0.64493406684822674
0.39493406684822646
0.28382295573711541
0.22132295573711536
0.18132295573711538
0.15354517795933759
0.13313701469403141
0.11751201469403141
0.10516633568168572
pg2
numeric
5
0.090846661274546187
-0.0082474668724106439
0.0014964646384826319
-0.00040701383274912027
0.00014750202708135431
pg3
numeric
6
1.4426631756090933
0.67892312933076082
-1.8170975709318957
4.3602088081680561
-0.41417266097382943
0.51208911260958723
digam1
numeric
6
-0.57721566490153331
-0.49020944481574552
0.39996053710254542
0.42278433509846636
4.0163965470245557
4.6001618527380881
digam2
complex
3
2.3133202537704225+1.4217864258047976i
1.7853323061533368+1.4190687834027196i
2.1294144190770634+1.5112725172710872i
digam3
complex
4
M
M
N
M
digam4
numeric
13
M
M
M
-0.57721566490153331
0.42278433509846636
0.92278433509846713
1.2561176684318007
1.5061176684318007
1.7061176684318005
1.8727843350984672
2.0156414779556098
2.1406414779556098
2.2517525890667209
digam5
complex
22
2.9529117664482678+1.7016530986344329i
2.8937059621194541+1.6539587199572896i
2.8335017946308962+1.6002080915007788i
2.7729143704671935+1.5395463267948968i
2.712845515192714+1.4710913120456341i
2.6545588592686444+1.394016051232895i
2.5997397258759998+1.3076859835623753i
2.5505036650829576+1.2118585858084743i
2.5093018494929575+1.1069280257423928i
2.4786743644605211+0.99415315206846633i
2.4608476585184631+0.87575930905134503i
2.4572646233490234+0.75479920317212434i
2.4682243868084655+0.63474115710283274i
2.492803548683554+0.51890095987542184i
2.5290991869585886+0.40993385571577945i
2.5746703324318121+0.3095627428000276i
2.6269879686496487+0.21857682611377419i
2.6837588586149228+0.13701360964160383i
2.7430880289822115+0.064404678263574738i
2.80351332832746+0i
2.8639655279759055-0.057065351817848178i
2.9236980301556854-0.10766417795298501i
expint1
numeric
12
0.052414379567998659
0.2230998257901772
0.55977359477318533
0.4902412690556332
0.32838141206122989
0.10986822627358106
0.052078954179335141
0.14631993953908845
0.10821792031852201
0.08497296001660537
0.035992911114848272
0.018153926322928095
expint2
complex
3
-5.2753994969837334-2.3198198648583874i
-0.33740392289792343-0.6247132564279686i
0.017239911464455721-0.017330252005105733i
mathgra
structure
5
.Data
character
20
Alaska
Arizona
Arkansas
Alabama
Alabama
Alabama
California
Colorado
California
Colorado
Connecticut
Delaware
Florida
Colorado
Connecticut
Delaware
Hawaii
Hawaii
Idaho
Idaho
.Dim
integer
2
10
2
.Dimnames
list
2

character
0

character
2
e1
e2
directed
logical
10
0
0
0
0
0
0
0
0
0
0
class
character
1
mathgraph
getpath
structure
5
.Data
character
8
Alaska
Connecticut
Alabama
Colorado
Connecticut
Alabama
Colorado
Idaho
.Dim
integer
2
4
2
.Dimnames
list
2

character
0

character
2
e1
e2
directed
logical
4
1
1
1
1
class
character
1
mathgraph
line.int
complex
1
1.4802973661668768e-16+6.283185307174513i
lagrange
function
2
z
missing
0

{
13

<-
2

name
1
zlen

call
2

name
1
length

name
1
z

<-
2

name
1
ilen

integer
1
8

<-
2

name
1
zout

(
2

name
1
(

call
3

name
1
|

call
3

name
1
<

name
1
z

numeric
1
0.050000000000000003

call
3

name
1
>

name
1
z

numeric
1
0.40000000000000002

<-
2

call
3

name
1
[

name
1
z

name
1
zout

name
1
NA

call
3

name
1
assign

character
1
y.den

numeric
8
-12709.005301724135
178372.75037413437
-806054.49631090718
1801866.9822993111
-2269705.9664092129
1649793.3312513249
-648939.54636519914
107376.05555254885

<-
2

name
1
tabz

call
3

name
1
array

call
3

name
1
rep

name
1
z

call
3

name
1
rep

name
1
ilen

name
1
zlen

call
3

name
1
c

name
1
ilen

name
1
zlen

<-
2

name
1
tab

call
4

name
1
outer

name
1
tabz

numeric
8
0.050000000000000003
0.10000000000000001
0.14999999999999999
0.20000000000000001
0.25
0.29999999999999999
0.34999999999999998
0.40000000000000002

character
1
-

<-
2

name
1
tab

call
3

name
1
aperm

name
1
tab

call
4

name
1
c

numeric
1
1

numeric
1
3

numeric
1
2

<-
2

call
3

name
1
[

name
1
tab

call
3

name
1
==

call
2

name
1
row

name
1
tab

call
2

name
1
col

name
1
tab

numeric
1
1

<-
2

name
1
num

call
4

name
1
apply

name
1
tab

call
3

name
1
c

numeric
1
1

numeric
1
3

name
1
prod

<-
2

name
1
ans

call
3

name
1
%*%

call
3

name
1
rep

numeric
1
1

name
1
ilen

(
2

name
1
(

call
3

name
1
*

name
1
y.den

name
1
num

<-
2

call
2

name
1
attributes

name
1
ans

call
2

name
1
attributes

name
1
z

name
1
ans
global.var
character
1
x
sym.addr
logical
1
1
symsqrt
structure
2
.Data
numeric
16
0.2733936736158713
-0.11011028436697221
0.098244443828899922
0.054768873262206523
-0.11011028436697221
0.063309939369292773
-0.033432933964061336
-0.023105664580385592
0.098244443828899908
-0.033432933964061336
0.057958903764165418
0.019431726322060961
0.054768873262206523
-0.023105664580385592
0.019431726322060961
0.015800767304921241
.Dim
integer
2
4
4
stack.init
structure
4
.Data
list
64

numeric
1
1

character
1
cat

complex
1
4+7i

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0
class
character
1
stack
size
integer
1
3
update
logical
1
1
stack.pop
complex
1
4+7i
que.init
structure
4
.Data
list
64

numeric
1
1

character
1
cat

complex
1
4+7i

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0

NULL
0
class
character
1
queue
size
integer
1
3
update
logical
1
1
que.pop
numeric
1
1
quad.form
numeric
4
0.44951256031862141
4.5880962912308911
13.060088895358806
25.865490372702361
bind.array
structure
3
.Data
numeric
312
8.79636
8.7923600000000004
8.7913700000000006
8.8148599999999995
8.8130100000000002
8.9075100000000003
8.9367300000000007
8.9616100000000003
8.9604400000000002
9.00868
9.0304900000000004
9.0690600000000003
9.0587099999999996
9.1069800000000001
9.1268499999999992
9.1709599999999991
9.1866500000000002
9.2382299999999997
9.2648700000000002
9.2843599999999995
9.3137799999999995
9.3502499999999991
9.3583499999999997
9.3976699999999997
9.4215
9.4422300000000003
9.4872099999999993
9.5237400000000001
9.5397999999999996
9.5812299999999997
9.6004799999999992
9.6449599999999993
9.6439000000000004
9.6940500000000007
9.699580000000001
9.6868300000000005
9.7177399999999992
9.7492400000000004
9.7753599999999992
4.7099700000000002
4.7021699999999997
4.6894400000000003
4.6855799999999999
4.6401899999999996
4.6255300000000004
4.61991
4.6165399999999996
4.6140699999999999
4.6076600000000001
4.6022699999999999
4.5895999999999999
4.57592
4.5866100000000003
4.5799700000000003
4.5717600000000003
4.5610400000000002
4.5490599999999999
4.5395700000000003
4.5101800000000001
4.50352
4.4935999999999998
4.4650499999999997
4.4492399999999996
4.4396599999999999
4.4202500000000002
4.4105999999999996
4.4115099999999998
4.3981000000000003
4.3851300000000002
4.3731999999999998
4.3277000000000001
4.3202299999999996
4.3090900000000003
4.3090900000000003
4.3055199999999996
4.2962699999999998
4.2783899999999999
4.2778900000000002
5.8211000000000004
5.8255800000000004
5.8311200000000003
5.8404600000000002
5.8503600000000002
5.8646399999999996
5.8776900000000003
5.8976300000000004
5.9257400000000002
5.9423199999999996
5.9536499999999997
5.9611999999999998
5.9780499999999996
6.0037700000000003
6.0282900000000001
6.0347499999999998
6.0390600000000001
6.0504600000000002
6.0556299999999998
6.0609299999999999
6.0710300000000004
6.0801800000000004
6.0885800000000003
6.1019899999999998
6.1120700000000001
6.1159600000000003
6.1212900000000001
6.1219999999999999
6.1311900000000001
6.1470500000000001
6.1533600000000002
6.1562700000000001
6.1627400000000003
6.1736899999999997
6.1613499999999997
6.1823100000000002
6.1876800000000003
6.1937699999999998
6.2003000000000004
12.969900000000001
12.9733
12.977399999999999
12.980600000000001
12.9831
12.9854
12.99
12.994300000000001
12.9992
13.003299999999999
13.0099
13.0159
13.0212
13.0265
13.0351
13.042899999999999
13.0497
13.055099999999999
13.0634
13.0693
13.073700000000001
13.077
13.084899999999999
13.091799999999999
13.095000000000001
13.0984
13.1089
13.116899999999999
13.122199999999999
13.1266
13.1356
13.141500000000001
13.144399999999999
13.145899999999999
13.151999999999999
13.1593
13.1579
13.1625
13.166399999999999
8.79636
8.7923600000000004
8.7913700000000006
8.8148599999999995
8.8130100000000002
8.9075100000000003
8.9367300000000007
8.9616100000000003
8.9604400000000002
9.00868
9.0304900000000004
9.0690600000000003
9.0587099999999996
9.1069800000000001
9.1268499999999992
9.1709599999999991
9.1866500000000002
9.2382299999999997
9.2648700000000002
9.2843599999999995
9.3137799999999995
9.3502499999999991
9.3583499999999997
9.3976699999999997
9.4215
9.4422300000000003
9.4872099999999993
9.5237400000000001
9.5397999999999996
9.5812299999999997
9.6004799999999992
9.6449599999999993
9.6439000000000004
9.6940500000000007
9.699580000000001
9.6868300000000005
9.7177399999999992
9.7492400000000004
9.7753599999999992
4.7099700000000002
4.7021699999999997
4.6894400000000003
4.6855799999999999
4.6401899999999996
4.6255300000000004
4.61991
4.6165399999999996
4.6140699999999999
4.6076600000000001
4.6022699999999999
4.5895999999999999
4.57592
4.5866100000000003
4.5799700000000003
4.5717600000000003
4.5610400000000002
4.5490599999999999
4.5395700000000003
4.5101800000000001
4.50352
4.4935999999999998
4.4650499999999997
4.4492399999999996
4.4396599999999999
4.4202500000000002
4.4105999999999996
4.4115099999999998
4.3981000000000003
4.3851300000000002
4.3731999999999998
4.3277000000000001
4.3202299999999996
4.3090900000000003
4.3090900000000003
4.3055199999999996
4.2962699999999998
4.2783899999999999
4.2778900000000002
5.8211000000000004
5.8255800000000004
5.8311200000000003
5.8404600000000002
5.8503600000000002
5.8646399999999996
5.8776900000000003
5.8976300000000004
5.9257400000000002
5.9423199999999996
5.9536499999999997
5.9611999999999998
5.9780499999999996
6.0037700000000003
6.0282900000000001
6.0347499999999998
6.0390600000000001
6.0504600000000002
6.0556299999999998
6.0609299999999999
6.0710300000000004
6.0801800000000004
6.0885800000000003
6.1019899999999998
6.1120700000000001
6.1159600000000003
6.1212900000000001
6.1219999999999999
6.1311900000000001
6.1470500000000001
6.1533600000000002
6.1562700000000001
6.1627400000000003
6.1736899999999997
6.1613499999999997
6.1823100000000002
6.1876800000000003
6.1937699999999998
6.2003000000000004
12.969900000000001
12.9733
12.977399999999999
12.980600000000001
12.9831
12.9854
12.99
12.994300000000001
12.9992
13.003299999999999
13.0099
13.0159
13.0212
13.0265
13.0351
13.042899999999999
13.0497
13.055099999999999
13.0634
13.0693
13.073700000000001
13.077
13.084899999999999
13.091799999999999
13.095000000000001
13.0984
13.1089
13.116899999999999
13.122199999999999
13.1266
13.1356
13.141500000000001
13.144399999999999
13.145899999999999
13.151999999999999
13.1593
13.1579
13.1625
13.166399999999999
.Dim
integer
3
39
4
2
.Dimnames
list
3

character
0

character
4
lag quarterly revenue
price index
income level
market potential

character
0
twice.2
numeric
1
4
data
list
1
variousnum
numeric
16
-4
-3
-2
-1
0
1
2
3
4
7
10
I
J
N
M
-204678
commands
structure
2
.Data
character
30
transcribe(\"state.name\",\".\",\"_\")
loan(2000, .08, 2, 1997)
update(Test.loan, rep(100, 5))
numberbase(-9:9,2,10)
rationalnum(variousnum, rep(variousnum, rep(16, 16)))
Test.ratnum - 2 * Test.ratnum
polygamma(1:10, \"trig\")
polygamma(11.5, 1:5)
polygamma(c(1.095, 1.92, 1.11, 1.11, 1.98, 1.98), c(1,1,2, 3, 2, 3))
digamma(c(1, 1.055, 1.965, 2, 56, 100))
digamma(c(2+10i, 1.4+5.9i, 1+8.4i))
digamma(as.complex(c(Inf, -Inf, NA, 0/0)))
digamma(-2:10)
digamma(complex(re=-2:19, im=19:-2))
exp.integral(c(1.95, 0.99, 0.5, 0.01, 0.01, 0.01, 0.01, 1.01, 1.01, 1.01, 1.01, 1.01), c(1, 1, 1, 3, 4, 10, 20, 2, 3, 4, 10, 20))
exp.integral(c(-2+0.2i, 1i, 2.5+0.6i), 1)
mathgraph(~ state.name[2:4]/state.name[7:9] + state.name[1]/state.name[6:8] + state.name[5:6]*state.name[11:12])
getpath(Test.mathgra,  state.name[2], state.name[12])
line.integral(function(z) 1/z, complex(re=c(1,1,-1,-1,1), im=c(-1,1,1,-1,-1)))
interpolator.lagrange((1:8)/20, tan((1:8)/20))
global.vars(function(xmat) {a <- x^2; (a+5)*x; a})
symbol.address(symbol.C(\"polygamma_Sp\")) > 0
symsqrt(var(freeny.x))
stack(init=list(1,\"cat\", 4+7i))
Test.stack.init[]
queue(init=list(1,\"cat\", 4+7i))
Test.que.init[]
quad.form(var(freeny.x), matrix(1:16,4))
bind.array(freeny.x, freeny.x, 3)
2 * 2
.Names
character
30
transcribe
loan
update.loan
numbase
ratnum
ratnum.op
pg1
pg2
pg3
digam1
digam2
digam3
digam4
digam5
expint1
expint2
mathgra
getpath
line.int
lagrange
global.var
sym.addr
symsqrt
stack.init
stack.pop
que.init
que.pop
quad.form
bind.array
twice.2
passed
structure
2
.Data
logical
30
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
N
.Names
character
30
transcribe
loan
update.loan
numbase
ratnum
ratnum.op
pg1
pg2
pg3
digam1
digam2
digam3
digam4
digam5
expint1
expint2
mathgra
getpath
line.int
lagrange
global.var
sym.addr
symsqrt
stack.init
stack.pop
que.init
que.pop
quad.form
bind.array
twice.2
specifics
list
3
version
structure
2
.Data
list
9
platform
character
1
SUN4
arch
character
1
Sun SPARC
os
character
1
SunOS 4.x
system
character
1
Sun SPARC, SunOS 4.x
status
character
1
Release
status.rev
numeric
1
1
major
numeric
1
3
minor
numeric
1
1
year
integer
1
1992
class
character
1
Sversion
machine
character
1
thelma
date
character
1
Wed May  6 14:24:43 PDT 1998
class
character
1
verify
SHAR_EOF
fi
if test -f 'poet.verif.d'
then
	echo shar: "will not over-write existing file 'poet.verif.d'"
else
cat << \SHAR_EOF > 'poet.verif.d'
.BG D
.FN poet.verif
.TL
Test Suite for S Poetry Functions
.PP
This is an object of class verify that tests the functions from
S Poetry.
.PP
The most likely thing not to work is the dynamic loading.
In order for this to work, you need to have the associated C code
compiled for your machine, you need to have the Poet.Location object
set to a character string giving the directory where the object
files are found, and you need to have dyn.load or dyn.load2 in your
version of S.
There are ways around the last two conditions, but not the first.
.SA
verify, print.verify.
.EX
print(verify(poet.verif), short=T)
.KW sysdata
.WR
SHAR_EOF
fi
if test -f 'polygamma.c'
then
	echo shar: "will not over-write existing file 'polygamma.c'"
else
cat << \SHAR_EOF > 'polygamma.c'
#include <math.h>


void
polygamma_Sp(x, len, n, low, high, terms, nfact)
long *len, *n, *terms;
double *x, *low, *high, *nfact;
{
	long i;
	double polygamma();

	for(i=0; i < *len; i++) {
		x[i] = polygamma(x[i], n[i], low[i], high[i],
			terms[i], nfact[i]);
	}
}


/* Bernoulli numbers of even order from 2 to 60 */
static double
bernou[30] = {1.0/6.0, -1.0/30.0, 1.0/42.0, -1.0/30.0, 5.0/66.0,
	-691.0/2730.0, 7.0/6.0, -3617.0/510.0, 43867.0/798.0,
	-174611.0/330.0, 854513.0/138.0, -236364091.0/2730.0,
	8553103.0/6.0, -23749461029.0/870.0, 8615841276005.0/14322.0,
	-7709321041217.0/510.0, 2577687858367.0/6.0,
	-1.371165521e13, 4.883323190e14, -1.929657934e16,
	8.416930476e17, -4.033807185e19, 2.115074864e21,
	-1.208662652e23, 7.500866746e24, -5.038778101e26,
	3.652877648e28, -2.849876930e30, 2.386542750e32,
	-2.139994926e34};


static double
polygamma(x, n, low, high, terms, nfact)
long n, terms;
double x, low, high, nfact;
{
	/* 
	 * polygamma function of a real positive x
	 * no checks are made here on the suitability 
	 * of arguments
	 */

	long i;
	double asign, ans = 0.0, nd = (double) n, nexp, ser = 0.0;
	double t0, x2_inv;

	asign = (n % 2) ? 1.0 : -1.0;

	if(x < low) {
		return(asign * nfact / nd * pow(x, - nd) *
			(1.0 + nd * .5 / x));
	}

	nexp = - nd - 1.0;
	while(x < high) {
		ans = ans + asign * nfact * pow(x, nexp);
		x = x + 1.0;
	}

	t0 = nfact / nd * pow(x, - nd);
	ser = t0 * ( 1.0 + nd * .5 / x); 
	x2_inv = pow(x, -2.0);
	for(i=0; i < terms; i++) {
		if(n ==1) {
			t0 = t0 * x2_inv;
		} else {
			t0 = (2.0 * i + nd + 3.0) / (2.0 * i + 4.0) *
				(2.0 * i + nd + 2.0) / (2.0 * i + 3.0) *
				t0 * x2_inv;
		}
		ser = ser + bernou[i] * t0;
	}

	ans = ans + asign * ser;
	return(ans);
}
SHAR_EOF
fi
if test -f 'polygamma.d'
then
	echo shar: "will not over-write existing file 'polygamma.d'"
else
cat << \SHAR_EOF > 'polygamma.d'
.BG
.FN polygamma
.TL
Polygamma Functions
.DN
Returns polygamma functions (second and higher derivatives of the
logarithm of the gamma function) for positive real values.
.CS
polygamma(x, n, low=0.0001, high=100, terms=5)
.RA
.AG x
vector of positive numeric values.
Missing values are allowed.
.AG n
vector of positive integers or character strings
describing which polygamma to compute.
If integer, then this should be the order of the derivative of the psi
function (which is the first derivative of the log of the gamma).
If character, then each string should (partially) match one of
`"trigamma"', `"tetragamma"', `"pentagamma"', `"hexagamma"'.
The value `"trigamma"' is equivalent to `1', etc. 
.OA
.AG low
value below which a simple approximation is used.
.AG high
the smallest value allowed in the asymptotic approximation.
.AG terms
the number of terms to use in the asymptotic approximation.
.RT
a numeric object with length equal to the longest length of the inputs.
If it is the same length as `x', then it will have the attributes that `x' has.
.DT
The input values `x', `n', `low', `high', `terms' are replicated to be the
length of the longest of these.  
Thus you can do such things as get several different derivatives for one
value, get approximations for one function value using different limits, etc.
.PP
The algorithm divides the positive numbers into three classes.  A simple
approximation is used for numbers that are less than `low'.
For numbers greater than or equal to `high', an asymptotic approximation
is used with `terms' terms.
For numbers greater than or equal to `low' but less than `high', then a
recurrence formula is used to express the function of interest in terms of
the function at a value larger than or equal to `high'.
.PP
It appears that increasing the number of terms used is less influential on
the accuracy of the approximation than the values of `high' and `low'.
.SH REFERENCES
Abramowitz, M. and Stegun, I. (1972).
.ul
Handbook of Mathematical Functions.
Dover, New York.
.SA
`digamma', `gamma'.
.EX
polygamma(seq(1,2, by=.1), 1)
polygamma(seq(1,2, by=.1), "trigamma") # same as above

print(as.matrix(polygamma(1.39, 2, high=c(10,50,100,500,1000))),
	digits=16) # investigate quality of approximation

polygamma(1.5, 1:6) # several functions at one value
.KW math
.WR
SHAR_EOF
fi
if test -f 'polygamma.q'
then
	echo shar: "will not over-write existing file 'polygamma.q'"
else
cat << \SHAR_EOF > 'polygamma.q'
"polygamma"<-
function(x, n, low = 0.0001, high = 100, terms = 5)
{
	if(!length(x))
		return(x)
	if(is.character(n)) {
		n <- pmatch(n, c("trigamma", "tetragamma", "pentagamma", 
			"hexagamma"), dup = T)
		if(any(is.na(n)))
			stop("unknown or ambiguous name")
	}
	else {
		n <- round(n)
		if(any(n < 1))
			stop("n must be a positive integer")
	}
	terms[terms > 30] <- 30
	xatt <- attributes(x)
	x <- as.numeric(x)
	if(any(x <= 0, na.rm = T))
		stop("only positive values allowed")
	alldat <- cbind(x = x, n = n, low = low, high = high, terms = terms)
	xna <- is.na(alldat[, "x"])
	alldat[xna, "x"] <- 0.5 * alldat[xna, "low"]
	if(!is.loaded(symbol.C("polygamma_Sp")))
		poet.dyn.load("polygamma.o")
	ans <- .C("polygamma_Sp",
		as.double(alldat[, "x"]),
		as.integer(dim(alldat)[1]),
		as.integer(alldat[, "n"]),
		as.double(alldat[, "low"]),
		as.double(alldat[, "high"]),
		as.integer(alldat[, "terms"]),
		as.double(gamma(alldat[, "n"] + 1)))[[1]]
	ans[xna] <- NA
	if(length(ans) == length(x))
		attributes(ans) <- xatt
	ans
}
SHAR_EOF
fi
if test -f 'portopt.control.d'
then
	echo shar: "will not over-write existing file 'portopt.control.d'"
else
cat << \SHAR_EOF > 'portopt.control.d'
.BG
.FN portopt.control
.TL
Control Arguments for PORT Optimization Functions
.DN
Returns a list containing values that control the behavior of the PORT
optimization algorithm.
.CS
portopt.control(eval.max=5000, iter.max=150, abs.tol=NA,
	rel.tol=NA, x.tol=NA, step.min=NA, step.max=NA,
	sing.step=NA, sing.tol=NA, scale.tol=NA, scale.mod=NA,
	scale.fac=NA, diff.grad=NA, trace=T)
.OA
.AG trace
logical flag: if `TRUE', then the progress of the optimization is printed.
.PP
see `nlminb.control' for the meaning of the other arguments.
.RT
a list with the following components:
.RC icontrol
the integer (and logical) values.
.RC dcontrol
the double precision values.
.SA
`portopt1', `nlminb.control'.
.EX
my.po.con <- portopt.control(trace=F, iter.max=500, 
	eval.max=100000)

portopt1(jjadd, rep(0,8), control=my.po.con)
portopt1(jjadd, rep(0,8), trace=F, iter.max=500,
	eval.max=100000) # same thing
.KW optimize
.WR
SHAR_EOF
fi
if test -f 'portopt.control.q'
then
	echo shar: "will not over-write existing file 'portopt.control.q'"
else
cat << \SHAR_EOF > 'portopt.control.q'
"portopt.control"<-
function(eval.max = 5000, iter.max = 150, abs.tol = NA, rel.tol = NA, x.tol = 
	NA, step.min = NA, step.max = NA, sing.step = NA, sing.tol = NA, 
	scale.tol = NA, scale.mod = NA, scale.fac = NA, diff.grad = NA, trace
	 = T)
{
	icontrol <- c(npar = NA, eval.max = eval.max, iter.max = iter.max, 
		trace = trace)
	dcontrol <- c(abs.tol = abs.tol, rel.tol = rel.tol, x.tol = x.tol, 
		step.min = step.min, step.max = step.max, sing.step = sing.step,
		sing.tol = sing.tol, scale.tol = scale.tol, scale.mod = 
		scale.mod, scale.fac = scale.fac, diff.grad = diff.grad)
	list(icontrol = icontrol, dcontrol = dcontrol)
}
SHAR_EOF
fi
if test -f 'portopt1.d'
then
	echo shar: "will not over-write existing file 'portopt1.d'"
else
cat << \SHAR_EOF > 'portopt1.d'
.BG
.FN portopt1
.TL
Minimize Simple C Function with PORT
.DN
Takes the address of a C function and minimizes the function.
.CS
portopt1(fun.address, start, lower= - Inf, upper=Inf,
	scale=1, control=portopt.control(...), ...)
.RA
.AG fun.address
integer which is the address of a C function that returns a double and
has two arguments, the parameter vector and a pointer to
the length of the vector.
.AG start
numeric vector that is the starting point of the optimization (and
determines the number of parameters).
Missing values are not accepted.
.OA
.AG lower
the lower bound for each parameter.
This can be a single number (in which case it is replicated), or else
it must be the same length as `start'.
.AG upper
the upper bound for each parameter.
This can be a single number (in which case it is replicated), or else
it must be the same length as `start'.
.AG scale
scaling vector within the optimizer.
This can be a single number (in which case it is replicated), or else
it must be the same length as `start'.
Getting this right can greatly speed convergence.
.AG control
list like the output of `portopt.control'.
.AG ...
individual control arguments may be given.
.RT
a list with the following components:
.RC parameters
the vector of parameters at the finish of the optimization.
.RC objective
the objective achieved.
.RC limits
matrix which is the actual constraints used.
.RC convergence
character string giving the final state of the optimizer.
.SH REFERENCES
Gay, D. M. (1990). 
"Usage Summary for Selected Optimization Routines".
Computing Science Technical Report 153,
ATT Bell Laboratories.
.SA
`portoptgen', `nlminb', `symbol.address'.
.EX
portopt1(symbol.address(symbol.C("jjtest1")),
	c(0,0))
portopt1(symbol.address(symbol.C("jjtest1")),
	c(0,0), upper=5)
.KW optimize
.WR
SHAR_EOF
fi
if test -f 'portopt1.q'
then
	echo shar: "will not over-write existing file 'portopt1.q'"
else
cat << \SHAR_EOF > 'portopt1.q'
"portopt1"<-
function(fun.address, start, lower =  - Inf, upper = Inf, scale = 1, control = 
	portopt.control(...), ...)
{
	if(fun.address == 0)
		stop("symbol not loaded")
	p <- length(start)
	if(length(scale) != 1 && length(scale) != p)
		stop("bad length for 'scale' argument")
	if(any(scale) <= 0)
		stop("nonpositive scale vector")
	scale <- rep(scale, length = p)
	if((length(lower) != 1 && length(lower) != p) || (length(upper) != 1 && 
		length(upper) != p))
		stop("bad length for lower or upper")
	big <- 1e+30
	lower[lower <  - big] <-  - big
	upper[upper > big] <- big
	lower <- rep(lower, length = p)
	upper <- rep(upper, length = p)
	if(any(lower > upper))
		stop("box constraints are infeasible")
	liv <- 59 + p
	lv <- 77 + (p * (p + 23))/2
	init <- .Fortran("divset",
		as.integer(2),
		iv = integer(liv),
		as.integer(liv),
		as.integer(lv),
		v = double(lv))[c("iv", "v")]
	if(init$iv[1] != 12)
		stop("abnormal return from divset")
	icontrol <- control$icontrol
	icontrol["npar"] <- p
	init$iv[17:18] <- icontrol[c("eval.max", "iter.max")]
	dnam <- c("abs.tol", "rel.tol", "x.tol", "step.min", "step.max", 
		"sing.step", "sing.tol", "scale.tol", "scale.mod", "scale.fac", 
		"diff.grad")
	dcvec <- control$dcontrol[dnam]
	dmiss <- is.na(dcvec)
	init$v[c(31:37, 39:42)[!dmiss]] <- dcvec[!dmiss]
	names(upper) <- names(start)
	limits <- rbind(lower = lower, upper = upper)
	storage.mode(limits) <- "double"
	if(!is.loaded(symbol.C("portopt_one_Sp")))
		poet.dyn.load("portopt_one.o")
	ans <- .C("portopt_one_Sp",
		as.integer(liv),
		as.integer(lv),
		iv = as.integer(init$iv),
		v = as.double(init$v),
		as.integer(icontrol),
		objective = double(1),
		limits = limits,
		scale = as.double(scale),
		as.integer(fun.address),
		parameters = as.double(start))[c("parameters", "objective", 
		"iv", "limits")]
	msg <- switch(ans$iv[1] - 2,
		"X convergence",
		"relative function convergence",
		"both X and relative function convergence",
		"absolute function convergence",
		"singular convergence",
		"false convergence",
		"function evaluation limit reached",
		"iteration limit reached",
		stop("invalid output code 11"),
		stop("invalid output code 12"),
		stop("invalid output code 13"),
		stop("LIV is too small"),
		stop("LV is too small"),
		stop("invalid output code 17"),
		stop("negative component in scale vector"),
		stop("cannot complete optimization"))
	ans$convergence <- msg
	ans$iv <- NULL
	ans$call <- match.call()
	ans
}
SHAR_EOF
fi
if test -f 'portopt_one.c'
then
	echo shar: "will not over-write existing file 'portopt_one.c'"
else
cat << \SHAR_EOF > 'portopt_one.c'
#include <S.h>

void
portopt_one_Sp(liv, lv, iv, v, icontrol, objective, limits, 
	scale, f_addr, par)
long *liv, *lv, *iv, *icontrol;
double *v, *objective, *limits, *scale, *par;
double (**f_addr)();
{
	long i, iter_max = iv[17], trace = icontrol[3], iternum=-1;
	long *npar = icontrol;

	if(iter_max) {
		F77_CALL(mnb0)(npar, par, scale, limits,
			objective, liv, iv, lv, v);
		*objective = (**f_addr)(par, npar);
		if(is_na(objective, DOUBLE) ||
				is_inf(objective, DOUBLE)) {
			iv[1] = 1;
		}
		while(iv[0] < 3 && iternum < iter_max) {
			if(iv[30] != iternum) {
				iternum = iv[30];
				if(trace) {
				   printf("iter: %d  objective: %g\n",
						iternum, *objective);
				   fflush(stdout);
				}
			}
			F77_CALL(mnb0)(npar, par, scale, limits,
				objective, liv, iv, lv, v);
			*objective = (**f_addr)(par, npar);
			if(is_na(objective, DOUBLE) ||
					is_inf(objective, DOUBLE)) {
				iv[1] = 1;
			}
		}
	}
	*objective = (**f_addr)(par, npar);
}

SHAR_EOF
fi
if test -f 'portoptgen.ctemplate.Q'
then
	echo shar: "will not over-write existing file 'portoptgen.ctemplate.Q'"
else
cat << \SHAR_EOF > 'portoptgen.ctemplate.Q'
portoptgen.ctemplate
character
40
#include <S.h>
void
port_opt_cFsUF_Sp(liv, lv, iv, v, icontrol, objective, limits, scale, 
cFaRGS
)
long *liv, *lv, *iv, *icontrol;
double *v, *objective, *limits, *scale;
cFdEC
{
\tlong i, iter_max = iv[17], trace = icontrol[3], iternum=-1;
\tlong *npar = icontrol;
\textern double cFfUNDEC();
\tif(iter_max) {
\t\tF77_CALL(mnb0)(npar, cFpAR, scale, limits,
\t\t\tobjective, liv, iv, lv, v);
\t\t*objective = cFcALL
\t\tif(is_na(objective, DOUBLE) ||
\t\t\t\tis_inf(objective, DOUBLE)) {
\t\t\tiv[1] = 1;
\t\t}
\t\twhile(iv[0] < 3 && iternum < iter_max) {
\t\t\tif(iv[30] != iternum) {
\t\t\t\titernum = iv[30];
\t\t\t\tif(trace) {
\t\t\t\t   printf(\"iter: %d  objective: %g\\n\",
\t\t\t\t\t\titernum, *objective);
\t\t\t\t   fflush(stdout);
\t\t\t\t}
\t\t\t}
\t\t\tF77_CALL(mnb0)(npar, cFpAR, scale, limits,
\t\t\t\tobjective, liv, iv, lv, v);
\t\t\t*objective = cFcALL
\t\t\tif(is_na(objective, DOUBLE) ||
\t\t\t\t\tis_inf(objective, DOUBLE)) {
\t\t\t\tiv[1] = 1;
\t\t\t}
\t\t}
\t}
\t*objective = cFcALL
}
SHAR_EOF
fi
if test -f 'portoptgen.d'
then
	echo shar: "will not over-write existing file 'portoptgen.d'"
else
cat << \SHAR_EOF > 'portoptgen.d'
.BG
.FN portoptgen
.FN portoptgen.ctemplate
.FN portoptgen.stemplate
.TL
Create Function to Minimize a Function
.DN
Creates a file of C code and returns a function that together minimize a 
function written in C or Fortran.
.CS
portoptgen(cfun, args, make=F, nonpointers=F, parameter=1, 
	fortran=F)
.RA
.AG cfun
character string giving the name of the C or Fortran function to be
minimized.
.AG args
character vector, each element corresponds to the corresponding argument
of `cfun'.
The values give the declaration of the argument, and any names are
used as the argument names in the S and C code.
.OA
.AG make
character or logical vector.
If character, the elements should match the names of the `args' argument.
If logical, it is replicated to the length of `args'.
Arguments selected are not arguments to the S function returned, but
rather are to be made within the function.
.AG nonpointers
character or logical vector.
If character, the elements should match the names of the `args' argument.
If logical, it is replicated to the length of `args'.
Arguments selected are passed into `cfun' by value rather than as pointers.
This is ignored if `fortran' is `TRUE'.
.AG parameter
character or numeric value indicating which argument is the one
over which optimization is to occur.
.AG fortran
logical flag; if `TRUE', then `cfun' is assumed to be a Fortran function.
Otherwise, `cfun' is treated as a C function.
.RT
a function that will optimize `cfun' after only minimal modification.
.SE
a file of C code is created or modified.
.DT
You can do the same thing by writing an S function that calls `cfun',
then use `nlminb', however, that will be much slower.
.PP
Here are the steps of what you need to do -- the order is logical, but not 
strict.
1) Compile the code for `cfun'.
2) Run `portoptgen', assigning the value to some name.
3) Compile the C code that `portoptgen' created -- the name of the
file is printed.
4) Fix up the S function returned by `portoptgen', the comments at
the beginning state what there is to do.
5) Load the code for `cfun' into S.
6) Load the C code created by `portoptgen' into S.
7) Minimize away.
.PP
The function that `portoptgen' creates is very similar to `portopt1'.
In particular, its arguments except for the ones from `cfun' are
also arguments to `portopt1'.
It uses the `portopt.control' function for passing in control values.
.PP
`portoptgen' uses the two S objects `portoptgen.ctemplate' and
`portoptgen.stemplate'.
.SH WARNING
The function that is being optimized needs to return a double precision
number -- this can't be checked by `portoptgen'.
.SA
`portopt.control', `portopt1', `nlminb'.
.EX
fjjtest3min <- portoptgen("jjtest3", c(x="double", n="long",
	lengs="integer", data="double"), make="n",
	nonpointer="n")
# fix up fjjtest3min with dyn.loading and "n" variable
!Splus COMPILE jjtest3.c
!Splus COMPILE port_opt_jjtest3.c
fjjtest3(c(2,4,2), len=c(20,30,20), data=mydata)
.KW optimize
.WR
SHAR_EOF
fi
if test -f 'portoptgen.q'
then
	echo shar: "will not over-write existing file 'portoptgen.q'"
else
cat << \SHAR_EOF > 'portoptgen.q'
"portoptgen"<-
function(cfun, args, make = F, nonpointers = F, parameter = 1, fortran = F)
{
	if(!is.character(cfun) || length(cfun) > 1)
		stop("cfun must be a single string")
	if(fortran)
		nonpointers <- F
	bnam <- paste("v", 1:length(args), sep = "")
	if(!length(anam <- names(args)))
		names(args) <- bnam
	else {
		nonam <- nchar(anam) == 0
		names(args)[nonam] <- bnam[nonam]
	}
	if(any(is.na(match(args, c("double", "single", "float", "integer", 
		"long", "character", "char", "complex"), nomatch = NA))))
		stop("bad type in 'args' argument")
	cargs <- args
	cam <- match(cargs, c("single", "integer", "character"), nomatch = 0)
	if(any(cam)) {
		cargs[cam == 1] <- "float"
		cargs[cam == 2] <- "long"
		cargs[cam == 3] <- "char"
	}
	names(cargs) <- transcribe(names(cargs), ".", "_")
	if(any(duplicated(names(cargs))))
		stop("duplicated names in arguments")
	c.outnames <- c("lv", "liv", "v", "iv", "icontrol", "objective", 
		"scale", "limits")
	if(sum(match(names(cargs), c.outnames, nomatch = 0)))
		stop(paste("Can't have C argument names in:", paste(c.outnames, 
			collapse = ", ")))
	sargs <- cargs
	sam <- match(sargs, c("float", "long", "char"), nomatch = 0)
	sargs[sam == 1] <- "single"
	sargs[sam == 2] <- "integer"
	sargs[sam == 3] <- "character"
	names(sargs) <- transcribe(names(sargs), "_", ".")
	arglen <- length(args)
	switch(mode(make),
		logical = {
			make <- rep(make, length = arglen)
		}
		,
		character = {
			maknam <- make
			make <- rep(F, arglen)
			names(make) <- names(args)
			make[maknam] <- T
			if(length(make) != arglen)
				stop("bad input for make")
		}
		,
		stop("invalid input for make"))
	names(make) <- names(sargs)
	if(is.numeric(parameter))
		parameter <- names(sargs)[parameter]
	else if(!match(parameter, names(sargs), nomatch = 0)) {
		par.m <- match(parameter, names(args), nomatch = NA)
		if(is.na(par.m))
			stop("bad value for 'parameter' argument")
		parameter <- names(sargs)[par.m]
	}
	if(sargs[parameter] != "double")
		stop("parameters need to be double precision")
	if(make[parameter])
		stop("parameter must be passed in, not made")
	switch(mode(nonpointers),
		logical = {
			nonpointers <- rep(nonpointers, length = arglen)
		}
		,
		character = {
			pointnam <- nonpointers
			nonpointers <- rep(F, arglen)
			names(nonpointers) <- names(args)
			nonpointers[pointnam] <- T
			if(length(nonpointers) != arglen)
				stop("bad input for nonpointers")
		}
		,
		stop("invalid input for nonpointers"))	#
#
# create and modify file of C code
#
	cfile.name <- paste("port_opt_", cfun, ".c", sep = "")
	cfile.test <- filetest(cfile.name, dir = T, wr = T, r = T)
	if(cfile.test["exists"]) {
		if(cfile.test["dir"])
			stop(paste(cfile.name, "is a directory"))
		if(!cfile.test["wr"])
			stop(paste(cfile.name, "is unwriteable"))
		if(!cfile.test["read"])
			stop(paste(cfile.name, "is unreadable"))
		cat("Overwriting file", cfile.name, "\n")
	}
	else {
		cat("Creating file", cfile.name, "\n")
	}
	cfun.args <- paste(names(cargs), collapse = ", ")
	cfun.dec <- paste(cargs, " *", names(cargs), ";", sep = "", collapse = 
		"\n")
	if(fortran)
		cfun.cn <- paste("F77_CALL(", cfun, ")", sep = "")
	else cfun.cn <- cfun
	cfun.call <- paste(cfun.cn, "(", paste(ifelse(nonpointers, "*", ""), 
		names(cargs), sep = "", collapse = ", "), ");", sep = "")
	cfun.par <- names(cargs)[match(parameter, names(sargs))]
	cat(portoptgen.ctemplate, file = cfile.name, sep = "\n")
	substifile(cfile.name, "cFaRGS", cfun.args)
	substifile(cfile.name, "cFdEC", cfun.dec)
	substifile(cfile.name, "cFcALL", cfun.call)
	substifile(cfile.name, "cFpAR", cfun.par)
	substifile(cfile.name, "cFfUNDEC", cfun.cn)
	substifile(cfile.name, "cFsUF", cfun)	#
#
# get S function right
#
	new.sargs <- names(sargs)[!make]
	ans <- portoptgen.stemplate
	ans.len <- length(ans)
	ans[[c(ans.len, 1, 2, 2)]] <- as.name(parameter)
	the.comm <- c(paste("# need to ensure that", cfun, 
		"is loaded, possibly with"), paste("# if(!is.loaded(symbol.", 
		if(fortran) "For" else "C", "('", cfun, "')))", sep = ""), 
		paste("#     dyn.load('", cfun, ".o')", sep = ""), "# ", paste(
		"# need to ensure that port_opt_", cfun, 
		"_Sp is loaded, possibly with", sep = ""), paste(
		"# if(!is.loaded(symbol.C('port_opt_", cfun, "_Sp')))", sep = 
		""), paste("#     dyn.load('", substring(cfile.name, 1, nchar(
		cfile.name) - 1), "o')", sep = ""))
	if(any(make)) {
		the.comm <- c(the.comm, "# ", paste("# need to fix up", names(
			make)[make]))
	}
	the.comm <- eval(parse(text = c("function() {", the.comm, "}")))
	ans[[ans.len]] <- c(the.comm[[1]], ans[[ans.len]])
	new.fun <- vector("function", length(new.sargs) + 1)
	names(new.fun) <- c(new.sargs, "")
	ans <- c(new.fun[ - length(new.fun)], ans)
	the.dotC <- expression(ans <- .C("portopt_one_Sp",
		as.integer(liv),
		as.integer(lv),
		iv = as.integer(init$iv),
		v = as.double(init$v),
		as.integer(icontrol),
		objective = double(1),
		limits = limits,
		scale = as.double(scale))[c("parameters", "objective", "iv", 
		"limits")])
	new.dotC <- as.call(parse(text = paste("foo(", paste(names(sargs), "=", 
		ifelse(make, paste("stop('fix up", names(sargs), "')"), paste(
		"as.", sargs, "(", names(sargs), ")", sep = "")), collapse = 
		", "), ")")))
	names(new.dotC[[1]])[match(parameter, names(new.dotC[[1]]))] <- 
		"parameters"
	the.dotC[[c(1, 2, 2)]] <- c(the.dotC[[c(1, 2, 2)]], new.dotC[[1]][-1])
	the.dotC[[c(1, 2, 2, 2)]] <- paste("port_opt_", cfun, "_Sp", sep = "")
	ans.len <- length(ans)
	dotC.num <- match("the..C.call", as.character(ans[[length(ans)]]))
	ans[[c(ans.len, dotC.num)]] <- the.dotC[[1]]
	ans
}
SHAR_EOF
fi
if test -f 'portoptgen.stemplate.q'
then
	echo shar: "will not over-write existing file 'portoptgen.stemplate.q'"
else
cat << \SHAR_EOF > 'portoptgen.stemplate.q'
"portoptgen.stemplate"<-
function(lower =  - Inf, upper = Inf, scale = 1, control = portopt.control(...),
	...)
{
	p <- length(This.Should.Be.Gone)
	if(length(scale) != 1 && length(scale) != p)
		stop("bad length for 'scale' argument")
	if(any(scale) <= 0)
		stop("nonpositive scale vector")
	scale <- rep(scale, length = p)
	if((length(lower) != 1 && length(lower) != p) || (length(upper) != 1 && 
		length(upper) != p))
		stop("bad length for lower or upper")
	big <- 1e+30
	lower[lower <  - big] <-  - big
	upper[upper > big] <- big
	lower <- rep(lower, length = p)
	upper <- rep(upper, length = p)
	if(any(lower > upper))
		stop("box constraints are infeasible")
	liv <- 59 + p
	lv <- 77 + (p * (p + 23))/2
	init <- .Fortran("divset",
		as.integer(2),
		iv = integer(liv),
		as.integer(liv),
		as.integer(lv),
		v = double(lv))[c("iv", "v")]
	if(init$iv[1] != 12)
		stop("abnormal return from divset")
	icontrol <- control$icontrol
	icontrol["npar"] <- p
	init$iv[17:18] <- icontrol[c("eval.max", "iter.max")]
	dnam <- c("abs.tol", "rel.tol", "x.tol", "step.min", "step.max", 
		"sing.step", "sing.tol", "scale.tol", "scale.mod", "scale.fac", 
		"diff.grad")
	dcvec <- control$dcontrol[dnam]
	dmiss <- is.na(dcvec)
	init$v[c(31:37, 39:42)[!dmiss]] <- dcvec[!dmiss]
	limits <- rbind(lower = lower, upper = upper)
	storage.mode(limits) <- "double"
	the..C.call
	msg <- switch(ans$iv[1] - 2,
		"X convergence",
		"relative function convergence",
		"both X and relative function convergence",
		"absolute function convergence",
		"singular convergence",
		"false convergence",
		"function evaluation limit reached",
		"iteration limit reached",
		stop("invalid output code 11"),
		stop("invalid output code 12"),
		stop("invalid output code 13"),
		stop("LIV is too small"),
		stop("LV is too small"),
		stop("invalid output code 17"),
		stop("negative component in scale vector"),
		stop("cannot complete optimization"))
	ans$convergence <- msg
	ans$iv <- NULL
	ans$call <- match.call()
	ans
}
SHAR_EOF
fi
if test -f 'print.mathgraph.d'
then
	echo shar: "will not over-write existing file 'print.mathgraph.d'"
else
cat << \SHAR_EOF > 'print.mathgraph.d'
.BG
.FN print.mathgraph
.TL
Print a Mathematical Graph
.DN
Prints a representation of the graph.
.CS
print.mathgraph(x, prefix.node=<<see below>>, ...)
.RA
.AG x
an object inheriting from mathgraph which represents a  mathematical graph.
.OA
.AG prefix.node
a string to put in front of each node named.
The default is an empty string if the nodes are character and the
string "node" if they are not.
.AG ...
other arguments to print may be given, but are not used.
.RT
the input x is returned invisibly.
.SE
the object is printed.
A double arrow between nodes means an undirected edge, while a single
arrow means a directed edge.
.SA
mathgraph, names.mathgraph.
.EX
mathgraph(~ 1:3 / 2:4)
mathgraph(~ 1:3 / 2:4, dir=T)
jjm <- mathgraph(~ state.name[1:3] * state.name[2:4])
jjm
names(jjm) <- letters[1:9]
jjm
.KW math
.WR
SHAR_EOF
fi
if test -f 'print.mathgraph.q'
then
	echo shar: "will not over-write existing file 'print.mathgraph.q'"
else
cat << \SHAR_EOF > 'print.mathgraph.q'
"print.mathgraph"<-
function(x, prefix.node = if(is.character(xu)) "" else "node", ...)
{
	if(length(unclass(x))) {
		xu <- unclass(x)
		if(length(the.nams <- names(x))) {
			the.nams <- paste(justify(the.nams, "r"), " ", sep = ""
				)
		}
		else {
			the.nams <- paste("[", format(1:length(x)), "] ", sep
				 = "")
		}
		out <- paste(the.nams, prefix.node, xu[, 1], ifelse(attr(x, 
			"directed"), " ->", "<->"), prefix.node, xu[, 2])
		cat(out, sep = "\n")
		cat("\nclass:", class(x), "\n")
	}
	else {
		cat("mathgraph()\n")
	}
	invisible(x)
}
SHAR_EOF
fi
if test -f 'print.numberbase.q'
then
	echo shar: "will not over-write existing file 'print.numberbase.q'"
else
cat << \SHAR_EOF > 'print.numberbase.q'
"print.numberbase"<-
function(x, ...)
{
	xv <- as.vector(x)
	names(xv) <- names(x)
	print(xv, quote = F)
	cat(paste("(base ", attr(x, "base"), ")\n", sep = ""))
	invisible(x)
}
SHAR_EOF
fi
if test -f 'print.queue.q'
then
	echo shar: "will not over-write existing file 'print.queue.q'"
else
cat << \SHAR_EOF > 'print.queue.q'
"print.queue"<-
function(x, ...)
{
	size <- attr(x, "size")
	if(size)
		print(unclass(x)[1:size], ...)
	else cat("(empty queue)\n")
	cat("Class:", class(x), "\n")
	invisible(x)
}
SHAR_EOF
fi
if test -f 'print.rationalnum.q'
then
	echo shar: "will not over-write existing file 'print.rationalnum.q'"
else
cat << \SHAR_EOF > 'print.rationalnum.q'
"print.rationalnum"<-
function(x, ...)
{
	out <- paste(x$numerator, "/", x$denominator, sep = "")
	names(out) <- x$names
	xna <- is.na(x$numerator) | is.na(x$denominator)
	d1 <- x$denominator == 1 & !xna
	out[d1] <- x$numerator[d1]
	out[xna] <- "NA"
	dz <- x$denominator == 0 & !xna
	nz <- x$numerator == 0 & !xna
	out[nz & !dz] <- "0"
	out[nz & dz] <- "NA"
	out[x$numerator < 0 & dz] <- "-Inf"
	out[x$numerator > 0 & dz] <- "Inf"
	print(out, quote = F, ...)
	invisible(x)
}
SHAR_EOF
fi
if test -f 'print.stack.q'
then
	echo shar: "will not over-write existing file 'print.stack.q'"
else
cat << \SHAR_EOF > 'print.stack.q'
"print.stack"<-
function(x, ...)
{
	size <- attr(x, "size")
	if(size)
		print(unclass(x)[1:size], ...)
	else cat("(empty stack)\n")
	cat("Class:", class(x), "\n")
	invisible(x)
}
SHAR_EOF
fi
if test -f 'print.verify.d'
then
	echo shar: "will not over-write existing file 'print.verify.d'"
else
cat << \SHAR_EOF > 'print.verify.d'
.BG
.FN print.verify
.TL
Print Verify Object
.DN
Prints an object of class `verify'.
.CS
print.verify(x, short=F, ...)
.RA
.AG x
an object of class `verify'.
.OA
.AG short
logical value; if `TRUE', then the character strings of commands
are not printed.
.AG ...
additional arguments to `print.default' may be given.
.RT
`x' (returned invisibly).
.SE
a representation of the object is printed.
.SA
`verify'.
.EX
verify(c("sin(1:9)", "2 * 2"))
.KW programming
.WR
SHAR_EOF
fi
if test -f 'print.verify.q'
then
	echo shar: "will not over-write existing file 'print.verify.q'"
else
cat << \SHAR_EOF > 'print.verify.q'
"print.verify"<-
function(x, short = F, ...)
{
	cat("Passed:\n")
	print(attr(x, "passed"), ...)
	if(!short) {
		cat("Commands:\n")
		print(attr(x, "commands"), ...)
	}
	cat("Names of data:", names(attr(x, "data")), "\n")
	cat("Specifics:\nversion: ")
	specs <- attr(x, "specifics")
	print(specs$version)
	cat("Machine:", specs$machine, "\nDate:", specs$date, "\n")
	invisible(x)
}
SHAR_EOF
fi
if test -f 'quad.form.d'
then
	echo shar: "will not over-write existing file 'quad.form.d'"
else
cat << \SHAR_EOF > 'quad.form.d'
.BG
.FN quad.form
.TL
Quadratic Forms
.DN
Returns the value of one or more quadratic forms with a single matrix.
.CS
quad.form(qmat, x)
.RA
.AG qmat
square matrix.
Missing values are not accepted.
.AG x
vector or matrix.
If a matrix, then the quadratic form is found for each column.
Missing values are not accepted.
.RT
a numeric vector with as many elements as columns in `x'.
.DT
The i-th element of the answer is equivalent to `x[,i] %*% qmat %*% x[,i]'.
.SA
`%*%', `crossprod'.
.EX
quad.form(matrix(1:16, 4), 1:4)
quad.form(matrix(1:16, 4), cbind(1:4, 3))
.KW matrix
.WR
SHAR_EOF
fi
if test -f 'quad.form.q'
then
	echo shar: "will not over-write existing file 'quad.form.q'"
else
cat << \SHAR_EOF > 'quad.form.q'
"quad.form"<-
function(qmat, x)
{
	dq <- dim(qmat)
	dx <- dim(as.matrix(x))
	if(length(dq) != 2 || dq[1] != dq[2])
		stop("qmat must be a square matrix")
	if(dx[1] != dq[2])
		stop("qmat and x do not match")
	if(!is.loaded(symbol.C("quad_form_Sp")))
		poet.dyn.load("quad_form.o")
	.C("quad_form_Sp",
		as.double(qmat),
		as.double(x),
		as.integer(dx),
		double(dx[2]))[[4]]
}
SHAR_EOF
fi
if test -f 'quad_form.c'
then
	echo shar: "will not over-write existing file 'quad_form.c'"
else
cat << \SHAR_EOF > 'quad_form.c'

static double
quad_form(double *Q, double *x, long n)
{
	long i, j, ij;
	double ans = 0.0;

	for(i=0; i < n; i++) {
		for(j=0, ij = i * n; j < n; j++, ij++) {
			ans = ans + x[i] * Q[ij] * x[j];
		}
	}
	return(ans);
}


void
quad_form_Sp(double *Q, double *x, long *xdim, double *ans)
{
	long i, ii, n;
	double quad_form(double*, double*, long);

	n = xdim[0];

	for(i=0, ii=0; i < xdim[1]; i++, ii += n) {
		ans[i] = quad_form(Q, x + ii, n);
	}
}
SHAR_EOF
fi
if test -f 'queue.d'
then
	echo shar: "will not over-write existing file 'queue.d'"
else
cat << \SHAR_EOF > 'queue.d'
.BG
.FN queue
.FN print.queue
.FN [.queue
.FN [<-.queue
.TL
Queue
.DN
Creates a queue, which is an object of class `"queue"'.
.CS
queue(length.=64, initial=NULL, update=T)
.OA
.AG length.
the initial length of the list which is to contain the items in the queue.
.AG initial
list (or vector) containing the items that initially appear in the queue.
The first item is at the front of the queue.
.AG update
logical or numeric value.
if `FALSE', then the queue is not allowed to grow beyond the initial length.
If `TRUE', then the queue doubles in length if it needs to grow.
If numeric, then the queue grows by this many components when it grows.
.RT
an object of class `"queue"' which is a list (of length `length.') that
has the following attributes:
.RC size
the number of items currently in the queue.
.RC update
the input value of `update'.
.DT
Values are pushed onto a queue by using the assignment form of subscripting
with empty brackets.
A value is popped from the queue by using empty subscripts.
Other forms of subscripting with single brackets are not allowed, but
subscripting with double brackets can be performed.
.PP
There is a `print' method for class `"queue"'.
.SH WARNING
The extraction form of subscripting has the side effect that the queue
is changed -- this is outside the S convention.
.PP
Because side effects are unconventional with queues, you need to be cautious
when using them.
It is probably best to have all operations on a queue occur in one location.
.SA
`stack'.
.EX
jjq <- queue(init=list(1:3))
jjq[] <- 4 # push value of 4 onto queue
jjq[] # pop value of 1:3 from queue

jjq <- queue(32, update=F)
.KW programming
.WR
SHAR_EOF
fi
if test -f 'queue.q'
then
	echo shar: "will not over-write existing file 'queue.q'"
else
cat << \SHAR_EOF > 'queue.q'
"queue"<-
function(length. = 64, initial = NULL, update = T)
{
	ans <- vector("list", length.)
	if(size <- length(initial)) {
		if(size > length. && is.logical(update) && !update)
			stop("queue overflow")
		ans[1:size] <- initial
	}
	atl <- list(class = "queue", size = size, update = update)
	attributes(ans) <- atl
	ans
}
SHAR_EOF
fi
if test -f 'rand_seq.c'
then
	echo shar: "will not over-write existing file 'rand_seq.c'"
else
cat << \SHAR_EOF > 'rand_seq.c'
#include <S.h>

void
rand_seq_Sp(pars, ipars, ans, alen)
long *ipars, *alen;
double *pars, **ans;
{
	long count=0, curlen, incr=ipars[0], safety=ipars[1];
	double threshold=pars[0], rmn=pars[1], rsd=pars[2];
	double this_rand;

	*ans = (double *)S_alloc(incr, sizeof(double));
	curlen = incr;

	seed_in((long *) NULL);
	
	while(1) {
		this_rand = norm_rand() * rsd + rmn;
		if(count >= curlen) {
			S_realloc(*ans, curlen + incr, curlen, 
				sizeof(double));
			curlen += incr;
		}
		(*ans)[count++] = this_rand;
		if(this_rand > threshold) break;
		if(count >= safety) {
			PROBLEM "reached maximum length, exiting"
				WARNING(NULL_ENTRY);
			break;
		}
	}
	seed_out((long *) NULL);
	*alen = count;
}

SHAR_EOF
fi
if test -f 'rationalnum.d'
then
	echo shar: "will not over-write existing file 'rationalnum.d'"
else
cat << \SHAR_EOF > 'rationalnum.d'
.BG
.FN rationalnum
.FN +.rationalnum
.FN -.rationalnum
.FN *.rationalnum
.FN [.rationalnum
.FN [<-.rationalnum
.FN Math.rationalnum
.FN abs.rationalnum
.FN c.rationalnum
.FN length.rationalnum
.FN length<-.rationalnum
.FN names.rationalnum
.FN names<-.rationalnum
.FN is.na.rationalnum
.FN is.nan.rationalnum
.FN print.rationalnum
.FN reduce.rationalnum
.FN unique.rationalnum
.FN as.numeric.rationalnum
.FN as.rationalnum
.FN as.rationalnum.default
.FN as.rationalnum.rationalnum
.TL
Rational Numbers
.DN
Suite of functions for creating and working with rational numbers.
.CS
rationalnum(numerator, denominator)
.RA
.AG numerator
vector of integers.
.NA
.AG denominator
vector of integers.
.NA
.RT
an object of class `rationalnum'.
This is a list with components numerator, denominator and names.
.DT
There are arithmetic operators, subscripting, coercion, etc.
Generic functions for which there are methods include:
`c', `length', `names', `is.na', `is.nan', `unique'.
.PP
The `reduce.rationalnum' function does the work of putting the fractions
into lowest terms.
.SH BUGS
values of `numerator' and `denominator' that are not integer are rounded
silently.
.PP
The rules for coercion could use substantial improvement.
.PP
Overflow can occur with not even a warning.
.SA
`great.common.div'.
.EX
jjr <- rationalnum(1:6, 12)
jjr + 2/jjr
c(jjr, -jjr)
.KW math
.WR
SHAR_EOF
fi
if test -f 'rationalnum.q'
then
	echo shar: "will not over-write existing file 'rationalnum.q'"
else
cat << \SHAR_EOF > 'rationalnum.q'
"rationalnum"<-
function(numerator, denominator)
{
	n <- max(ln <- length(numerator), ld <- length(denominator))
	if(ln != n)
		numerator <- rep(numerator, length = n)
	if(ld != n)
		denominator <- rep(denominator, length = n)
	anam <- names(numerator)
	if(!length(anam))
		anam <- names(denominator)
	ans <- list(numerator = numerator, denominator = denominator, names = 
		anam)
	class(ans) <- "rationalnum"
	reduce.rationalnum(ans)
}
SHAR_EOF
fi
if test -f 'reduce.default.q'
then
	echo shar: "will not over-write existing file 'reduce.default.q'"
else
cat << \SHAR_EOF > 'reduce.default.q'
"reduce.default"<-
function(x, ...)
x
SHAR_EOF
fi
if test -f 'reduce.q'
then
	echo shar: "will not over-write existing file 'reduce.q'"
else
cat << \SHAR_EOF > 'reduce.q'
"reduce"<-
function(x, ...)
UseMethod("reduce")
SHAR_EOF
fi
if test -f 'reduce.rationalnum.q'
then
	echo shar: "will not over-write existing file 'reduce.rationalnum.q'"
else
cat << \SHAR_EOF > 'reduce.rationalnum.q'
"reduce.rationalnum"<-
function(x)
{
	signnz <- function(x)
	{
		x <- sign(x)
		x[x == 0] <- 1
		x
	}
# start of main function
	num <- round(x$numerator)
	den <- round(x$denominator)
	nans <- ((num == 0 & den == 0) | (is.inf(num) & is.inf(den)))
	nans[is.na(nans)] <- F
	nans[is.nan(num) | is.nan(den)] <- T
	nas <- (is.na(num) | is.na(den)) & !nans
	infs <- ((is.inf(num) & !is.inf(den)) | (num != 0 & den == 0)) & !nas & 
		!
		nans
	zeros <- is.inf(den) & !nans & !nas
	out <- nas | nans | infs | zeros
	fact <- great.common.div(num[!out], den[!out])
	x$numerator[!out] <- as.integer(num[!out]/fact * signnz(den[!out]))
	x$denominator[!out] <- as.integer(abs(den[!out]/fact))
	x$numerator[nans] <- x$denominator[nans] <- as.integer(0)
	x$numerator[infs] <- (Inf * signnz(den[infs]) * signnz(num[infs]))
	x$denominator[infs | zeros] <- 1
	x$numerator[zeros] <- 0
	x$numerator[nas] <- NA
	x
}
SHAR_EOF
fi
if test -f 'sccs.d'
then
	echo shar: "will not over-write existing file 'sccs.d'"
else
cat << \SHAR_EOF > 'sccs.d'
.BG
.FN sccs
.TL
Source Control for S Objects
.DN
Creates or updates a file that represents the object, and this file is
put under SCCS control.
.CS
sccs(x, xname=x, new=!length(unix(paste("ls", xfile), out = T)),
	already.out=F)
.RA
.AG x
a name or a character string of the name of an object.
.OA
.AG xname
character string to use as the basename for the file.
This is useful when the function contains characters that are undesirable
in filenames.
In particular, this is good for arithmetic operators.
.AG new
logical flag: if `TRUE', then it is assumed that the SCCS file does not
exist.
.AG already.out
logical flag: if `TRUE', then it is assumed that the SCCS file has been
checked out already.
.RT
character string of the name of the file (returned invisibly).
.SE
updates or creates the file and updates or creates the corresponding SCCS
file.
.PP
If a corresponding ".d" file is not found, a warning is given that asks
if a help file was written.  It does not check to see if help is available.
The test is merely heuristic.
.DT
When the object is a function, then `dump' is used to create the file
and the suffix on the file name is `"q"'. 
Otherwise, `data.dump' is used and the suffix is `"Q"'.
.PP
The only time that it is necessary to specify `new' is when the file
already exists, but is not under SCCS control.
Using `already.out' can at most avoid a warning message.
.PP
The \fIUNIX Power Tools\fP book has a good but brief introduction to SCCS.
You can get more information from the man page for SCCS.
.SH REFERENCES
Peek, J., T. O'Reilly, M. Loukides (1993).
.ul
Unix Power Tools.
O'Reilly and Associates; Sebastopol, CA.
.SH BUGS
When you are putting an object of mode `character' under control, you
must quote the name of the object.
If you don't, then it will try to put the contents of the object under
control.
.SA
`diffsccs'.
.EX
sccs(myfun) # put under control

# at some later time
diffsccs(myfun) # see if updated since sccs used
fix(myfun) # change function
sccs(myfun) # control new version

sccs("+.myclass", "Add.myclass")
.KW programming
.WR
SHAR_EOF
fi
if test -f 'sccs.q'
then
	echo shar: "will not over-write existing file 'sccs.q'"
else
cat << \SHAR_EOF > 'sccs.q'
"sccs"<-
function(x, xname = x, new = !length(unix(paste("ls", xfile), out = T)), 
	already.out = F)
{
	ok.dump <- function(x, xfile, do.dd)
	{
		if(do.dd) {
			data.dump(x, xfile)
		}
		else {
			dump(x, xfile)
		}
	}
# start of main function
	if(is.character(x)) {
		if(length(x) > 1)
			stop("only one at a time")
	}
	else x <- deparse(substitute(x))
	do.dd <- !is.function(get(x))
	if(do.dd) {
		xfile <- paste(xname, "Q", sep = ".")
	}
	else {
		xfile <- paste(xname, "q", sep = ".")
	}
	if(new) {
		ok.dump(x, xfile, do.dd)
		unix(paste("sccs create", xfile), out = F)
		unix(paste("rm ,", xfile, sep = ""), out = F)
	}
	else {
		if(!already.out)
			unix(paste("sccs edit", xfile), out = F)
		ok.dump(x, xfile, do.dd)
		unix(paste("sccs delget", xfile), out = F)
	}
	hcom <- paste("test -f ", xname, ".d", sep = "")
	if(unix(hcom, out = F))
		warning(paste("file ", xname, 
			".d not found, have you written a help file?", sep = ""
			))
	invisible(xfile)
}
SHAR_EOF
fi
if test -f 'soptions.d'
then
	echo shar: "will not over-write existing file 'soptions.d'"
else
cat << \SHAR_EOF > 'soptions.d'
.BG
.FN soptions
.TL
Safe Options
.DN
Does the same thing as `options', but produces a warning if you are
adding an option that does not exist.
.CS
soptions(...)
.OA
.AG ...
same as `options'.
.RT
same as `options'.
.SE
same as `options'.
.SA
`options'.
.EX
soptions(warning=2)
# produces a warning (assuming a good value of the warn option)
# that "warning" is a new option, so the user can realize that
# the option is really named "warn"
.KW environment
.WR
SHAR_EOF
fi
if test -f 'soptions.q'
then
	echo shar: "will not over-write existing file 'soptions.q'"
else
cat << \SHAR_EOF > 'soptions.q'
"soptions"<-
function(...)
{
	in.names <- names(list(...))
	oldnames <- names(options())
	newnames <- in.names[!match(in.names, oldnames, nomatch = 0)]
	if(length(newnames)) {
		warning(paste("new options added: ", paste(newnames, collapse
			 = ", ")))
	}
	ans <- options(...)
	if(.Auto.print)
		ans
	else invisible(ans)
}
SHAR_EOF
fi
if test -f 'sort.mathgraph.d'
then
	echo shar: "will not over-write existing file 'sort.mathgraph.d'"
else
cat << \SHAR_EOF > 'sort.mathgraph.d'
.BG
.FN sort.mathgraph
.TL
Sort a Mathematical Graph
.DN
Sorts nodes within undirected edges and/or edges by nodes.
.CS
sort.mathgraph(x, nodes=T, edges=T)
.RA
.AG x
an object that inherits from `mathgraph'.
.OA
.AG nodes
logical value; if TRUE, then the nodes within undirected edges are sorted.
.AG edges
logical value; if TRUE, then the edges are sorted by the first node with
ties broken by the second node.
.RT
an object that represents the same graph as the input, but with
some rearrangement.
.SA
`mathgraph'.
.EX
jjmg <- mathgraph(~ 4:2 * 1:3 + 3:5 / 1:3)
sort.mathgraph(jjmg)
sort.mathgraph(jjmg, node=F)
sort.mathgraph(jjmg, edge=F)
.KW math
.WR
SHAR_EOF
fi
if test -f 'sort.mathgraph.q'
then
	echo shar: "will not over-write existing file 'sort.mathgraph.q'"
else
cat << \SHAR_EOF > 'sort.mathgraph.q'
"sort.mathgraph"<-
function(x, nodes = T, edges = T)
{
	dir <- attr(x, "directed")
	cl <- class(x)
	x <- unclass(x)
	if(nodes && !all(dir)) {
		x[!dir,  ] <- stable.apply(x[!dir,  , drop = F], 1, sort)
	}
	if(edges) {
		ord <- order(x[, 1], x[, 2])
		x <- x[ord,  ]
		attr(x, "directed") <- dir[ord]
	}
	class(x) <- cl
	x
}
SHAR_EOF
fi
if test -f 'stable.apply.d'
then
	echo shar: "will not over-write existing file 'stable.apply.d'"
else
cat << \SHAR_EOF > 'stable.apply.d'
.BG
.FN stable.apply
.TL
Apply with Stable Dimensions
.DN
Does the same thing as `apply' except that when the function returns a 
vector, the dimensions are put back the way they started.
.CS
stable.apply(X, MARGIN, FUN, ...)
.RA
.AG X
same as in `apply'.
.AG MARGIN
same as in `apply'.
.AG FUN
same as in `apply'.
.OA
.AG ...
same as in `apply'.
.RT
when `FUN' returns a scalar or when `MARGIN' has a length that is not one
less than the number of dimensions in `X', then the same as `apply'.
.PP
Otherwise, an array similar to the result of `apply', but with the dimensions
permuted to correspond to the dimensions of `X'.
.SA
`apply', `aperm'.
.EX
stable.apply(freeny.x, 1, sort)
# compare to:
apply(freeny.x, 1, sort)
.KW array
.WR
SHAR_EOF
fi
if test -f 'stable.apply.q'
then
	echo shar: "will not over-write existing file 'stable.apply.q'"
else
cat << \SHAR_EOF > 'stable.apply.q'
"stable.apply"<-
function(X, MARGIN, FUN, ...)
{
	ldx <- length(dim(X))
	if(length(MARGIN) != ldx - 1) {
		warning("stability not performed")
		return(apply(X, MARGIN, FUN, ...))
	}
	ans <- apply(X, MARGIN, FUN, ...)
	if(length(dim(ans)) != ldx)
		ans
	else aperm(ans, order(c((1:ldx)[ - MARGIN], MARGIN)))
}
SHAR_EOF
fi
if test -f 'stack.d'
then
	echo shar: "will not over-write existing file 'stack.d'"
else
cat << \SHAR_EOF > 'stack.d'
.BG
.FN stack
.FN print.stack
.FN [.stack
.FN [<-.stack
.TL
Stack
.DN
Creates a stack, which is an object of class `"stack"'.
.CS
stack(length.=64, initial=NULL, update=T)
.OA
.AG length.
the initial length of the list which is to contain the items in the stack.
.AG initial
list (or vector) containing the items that initially appear in the stack.
The last item is at the top of the stack.
.AG update
logical or numeric value.
if `FALSE', then the stack is not allowed to grow beyond the initial length.
If `TRUE', then the stack doubles in length if it needs to grow.
If numeric, then the stack grows by this many components when it grows.
.RT
an object of class `"stack"' which is a list (of length `length.') that
has the following attributes:
.RC size
the number of items currently in the stack.
.RC update
the input value of `update'.
.DT
Values are pushed onto a stack by using the assignment form of subscripting
with empty brackets.
A value is popped from the stack by using empty subscripts.
Other forms of subscripting with single brackets are not allowed, but
subscripting with double brackets can be performed.
.PP
There is a `print' method for class `"stack"'.
.SH WARNING
The extraction form of subscripting has the side effect that the stack
is changed -- this is outside the S convention.
.PP
Because side effects are unconventional with stacks, you need to be cautious
when using them.
It is probably best to have all operations on a stack occur in one location.
.SA
`queue'.
.EX
jjs <- stack(init=1:3)
jjs[] # pop value of 3 from stack
jjs[] <- 4 # push value of 4 onto stack

jjs <- stack(32, update=F)
.KW programming
.WR
SHAR_EOF
fi
if test -f 'stack.q'
then
	echo shar: "will not over-write existing file 'stack.q'"
else
cat << \SHAR_EOF > 'stack.q'
"stack"<-
function(length. = 64, initial = NULL, update = T)
{
	ans <- vector("list", length.)
	if(size <- length(initial)) {
		if(size > length. && is.logical(update) && !update)
			stop("stack overflow")
		ans[1:size] <- initial
	}
	atl <- list(class = "stack", size = size, update = update)
	attributes(ans) <- atl
	ans
}
SHAR_EOF
fi
if test -f 'substifile.d'
then
	echo shar: "will not over-write existing file 'substifile.d'"
else
cat << \SHAR_EOF > 'substifile.d'
.BG
.FN substifile
.TL
Make Substitutions in a File
.DN
Changes the files by substituting the `new' string for the `old' string.
.CS
substifile(filenames, old, new, sep="/", backup=".jj")
.RA
.AG filenames
a vector containing the names of files to be changed.
.AG old
string to be taken out of the files.
.AG new
string to be substituted in where `old' occurs.
.OA
.AG sep
a single character used to delimit the `old' and `new' strings in the
Perl command.
.AG backup
a string used as the suffix added to make a backup copy of the files.
If the empty string, then no backup files are made.
.RT
the exit status of the Perl program.
Zero means success.
.SE
the files are (presumably) changed, and if `backup' is not the empty string,
then backup files with the original contents are created.
.DT
The actual work is performed by Perl.
.SH REFERENCES
Wall, L. and Schwartz, R. L. (1991). 
.ul
Programming perl.
O'Reilly and Associates, Sebastopol, CA.
.SA
`perl', `transcribe'.
.EX
substifile("myfile", "UNIX", "Unix")
# myfile changed, original version in myfile.jj

substifile(c("myfile", "myfile2"), "1/2", "a half",
	sep="#", backup="") # don't make backups
.KW character
.WR
SHAR_EOF
fi
if test -f 'substifile.q'
then
	echo shar: "will not over-write existing file 'substifile.q'"
else
cat << \SHAR_EOF > 'substifile.q'
"substifile"<-
function(filenames, old, new, sep = "/", backup = ".jj")
{
	if(length(old) != 1 || length(new) != 1)
		stop("old and new must be single strings")
	if(nchar(sep) != 1)
		stop("sep needs to be a single character")
	if(any(AsciiToInt(sep) == AsciiToInt(c(old, new))))
		stop("sep character in old or new")
	cmd <- paste("perl -p -i", backup, " -e \"s", sep, old, sep, new, sep, 
		" ;\" ", paste(filenames, collapse = " "), sep = "")
	unix(cmd, out = F)
}
SHAR_EOF
fi
if test -f 'summary.interlude.q'
then
	echo shar: "will not over-write existing file 'summary.interlude.q'"
else
cat << \SHAR_EOF > 'summary.interlude.q'
"summary.interlude"<-
function(object = get(".Interlude", where = 0))
{
	object <- unclass(object)
	onam <- names(object)
	onam <- onam[nchar(onam) > 0]
	if(!length(onam))
		return(NULL)
	ans <- array(NA, c(length(onam), 3), list(onam, c("total.time", 
		"number.calls", "mean.time")))
	object <- object[onam]
	ans[, "total.time"] <- unlist(lapply(object, function(x)
	sum(x$total.time[-3])))
	ans[, "number.calls"] <- unlist(lapply(object, function(x)
	x$ncalls))
	ans[, "mean.time"] <- ans[, "total.time"]/ans[, "number.calls"]
	ans
}
SHAR_EOF
fi
if test -f 'symbol.address.d'
then
	echo shar: "will not over-write existing file 'symbol.address.d'"
else
cat << \SHAR_EOF > 'symbol.address.d'
.BG
.FN symbol.address
.TL
Addresses of Symbols
.DN
Returns the addresses of the input symbols.
.CS
symbol.address(symbol)
.RA
.AG symbol
vector of character strings that are symbols for routines.
.RT
a vector of integers that are the addresses of the symbols.
Zero means that the symbol is not loaded in the current session of S.
.SA
`is.loaded', `symbol.C', `symbol.For'.
.EX
> symbol.address(symbol.C(c("jjtest1", "not_there")))
[1] 3768320       0
.KW interface
.WR
SHAR_EOF
fi
if test -f 'symbol.address.q'
then
	echo shar: "will not over-write existing file 'symbol.address.q'"
else
cat << \SHAR_EOF > 'symbol.address.q'
"symbol.address"<-
function(symbol)
{
	symbol <- as.character(symbol)
	.C("S_get_entries",
		symbol,
		integer(length(symbol)),
		length(symbol))[[2]]
}
SHAR_EOF
fi
if test -f 'symsqrt.d'
then
	echo shar: "will not over-write existing file 'symsqrt.d'"
else
cat << \SHAR_EOF > 'symsqrt.d'
.BG
.FN symsqrt
.TL
Symmetric Square Root of a Matrix
.DN
Returns the symmetric square root (or its inverse) of a symmetric 
positive-definite matrix.
.CS
symsqrt(x, inverse=F, tol=1e-10)
.RA
.AG x
numeric matrix.
Missing values are not accepted.
.OA
.AG inverse
logical value; if TRUE, then the inverse square root is returned.
.AG tol
number which is used as the tolerance to check for the symmetry of x.
.RT
a matrix the same size as x which is its square root or inverse square root.
.DT
There is a whole group of square roots of a symmetric positive-definite
matrix.
The Choleski decomposition is another square root.
.SA
chol.
.EX
symsqrt(var(freeny.x))
symsqrt(var(freeny.x), inv=T)
.KW matrix
.WR
SHAR_EOF
fi
if test -f 'symsqrt.q'
then
	echo shar: "will not over-write existing file 'symsqrt.q'"
else
cat << \SHAR_EOF > 'symsqrt.q'
"symsqrt"<-
function(x, inverse = F, tol = 1e-10)
{
	dx <- dim(x)
	if(dx[1] != dx[2])
		stop("need square matrix")
	if(any(abs(x - t(x)) > tol * max(abs(x))))
		stop("need symmetric matrix")
	xeig <- eigen(x, sym = T)
	if(inverse)
		xeig$vectors %*% (xeig$values^-0.5 * t(xeig$vectors))
	else xeig$vectors %*% (xeig$values^0.5 * t(xeig$vectors))
}
SHAR_EOF
fi
if test -f 'to.base10.d'
then
	echo shar: "will not over-write existing file 'to.base10.d'"
else
cat << \SHAR_EOF > 'to.base10.d'
.BG
.FN to.base10
.FN from.base10
.TL
Transform Number Base
.DN
Subsidiary functions to `numberbase' not meant for direct use.
.CS
to.base10(raw, oldbase)
from.base10(raw, newbase)
.SA
`numberbase'.
.WR
SHAR_EOF
fi
if test -f 'to.base10.q'
then
	echo shar: "will not over-write existing file 'to.base10.q'"
else
cat << \SHAR_EOF > 'to.base10.q'
"to.base10"<-
function(raw, oldbase)
{
	to.base10.sub <- function(raw, mult, digested, oldbase)
	{
		ncr <- nchar(raw)
		this.raw <- substring(raw, ncr, ncr)
		this.raw <- match(this.raw, c(0:9, letters, "-")) - 1
		digested <- ifelse(this.raw == 36,  - digested, digested + 
			this.raw * mult)
		bad <- this.raw >= oldbase & this.raw < 36
		digested[bad] <- NA
		list(raw = substring(raw, 1, ncr - 1), digested = digested)
	}
# start of main function
	if(is.numeric(raw)) {
		if(any(abs(round(raw) - raw) > .Machine$double.eps)) {
			warning("rounding non-integers")
		}
		raw <- as.character(round(raw))
	}
	else if(!is.character(raw))
		stop(paste("can not handle data of mode", mode(raw)))
	raw <- transcribe(raw, "A-Z", "a-z")
	multiple <- 1
	todo <- nchar(raw) > 0
	digested <- rep(0, length(raw))
	while(any(todo)) {
		current <- to.base10.sub(raw = raw[todo], mult = multiple, 
			digested = digested[todo], oldbase)
		multiple <- multiple * oldbase
		digested[todo] <- current$digested
		raw[todo] <- current$raw
		todo <- nchar(raw) > 0
	}
	ans <- as.character(digested)
	attr(ans, "value") <- digested
	attr(ans, "base") <- 10
	class(ans) <- "numberbase"
	ans
}
SHAR_EOF
fi
if test -f 'transcribe.d'
then
	echo shar: "will not over-write existing file 'transcribe.d'"
else
cat << \SHAR_EOF > 'transcribe.d'
.BG
.FN transcribe
.TL
Change Characters
.DN
Returns an object like the input, but with some sequence presumably changed.
.CS
transcribe(x, old, new="", complement=F, delete=F, squash=F, sep="/")
.RA
.AG x
character object.
.AG old
string of characters that are to be replaced.
.OA
.AG new
string of characters that are substituted for the corresponding
character in `old'.
This is logically replicated to have as many characters as `old'
unless `delete' is `TRUE'.
.AG complement
logical flag; if `TRUE', then the string of characters that are to be
replaced becomes all of the characters except those in `old'.
.AG delete
logical flag; if `TRUE', then characters found in `old' that do not have
a corresponding character in `new' will be deleted.
.AG squash
logical flag; if `TRUE', then sequences of characters that were
transcribed to the same character are squashed down to only one
instance of the character.
.AG sep
the character to use as the separator between `old' and `new' in the
Perl command.
Set this to some character when "/" is one of the characters you are
trying to work with.
.RT
an object like the input `x' except that some characters are changed.
.DT
This uses Perl to do the actual work.
.PP
Note that when `complement' is `TRUE', that the newline character gets
pasted onto the end of `old'.
If this were not done, then the marker for the end of the string would
get translated which means that Perl would print no lines which means
that S would get no data.
Similarly, you probably do not want to include newlines in `new'.
.SA
`perl', `substring', `abbreviate', `nchar'.
.EX
transcribe(state.name, "A-Z", "a-z") # make all lower case
transcribe("state_name", "_", ".") # change to S-style name
transcribe(state.name, "aeiou", delete=T) # delete vowels
transcribe(transcribe(state.name, "aeiou", delete=T),
	"a-z", "a-z", squa=T) # abbreviate
transcribe(state.name, "aeiou", "_", comp=T) # all but vowels to _
transcribe(state.name, "aeiou", delete=T, comp=T) # only vowels
.KW character
.WR
SHAR_EOF
fi
if test -f 'transcribe.q'
then
	echo shar: "will not over-write existing file 'transcribe.q'"
else
cat << \SHAR_EOF > 'transcribe.q'
"transcribe"<-
function(x, old, new = "", complement = F, delete = F, squash = F, sep = "/")
{
	flags <- paste(c("c", "d", "s")[c(complement, delete, squash)], 
		collapse = "")
	if(complement)
		old <- paste(old, "\\n", sep = "")
	ptext <- paste("tr", sep, old, sep, new, sep, flags, " ;", sep = "")
	if(length(ptext) != 1)
		stop("old and new must each be single strings")
	perl(x, ptext)
}
SHAR_EOF
fi
if test -f 'unabbrev.value.d'
then
	echo shar: "will not over-write existing file 'unabbrev.value.d'"
else
cat << \SHAR_EOF > 'unabbrev.value.d'
.BG
.FN unabbrev.value
.TL
Unabbreviate a String Given the Choices
.DN
Returns the string among `choices' that is the unabbreviated form of `x'.
If a good match is not found, an error occurs which appears to come from
the parent.
.CS
unabbrev.value(x, choices)
.RA
.AG x
a character string.
.AG choices
a character vector.
.RT
the element of `choices' for which `x' is an abbreviation.
.SE
if an error occurs (either because `x' is not a single character string,
or because `x' is not an unambiguous abbreviation of an element of
`choices'), then the error comes from the function calling `unabbrev.value'.
.SA
`match.arg'.
.EX
> fjj
function(xcat)
{
        unabbrev.value(xcat, c("munchkin", "stevie"))
}
> fjj("stev")
[1] "stevie"
> fjj("m")
[1] "munchkin"
> fjj("har")
Error in fjj("tuf"):  unknown or ambiguous choice for xcat
Dumped 
.KW programming
.WR
SHAR_EOF
fi
if test -f 'unabbrev.value.q'
then
	echo shar: "will not over-write existing file 'unabbrev.value.q'"
else
cat << \SHAR_EOF > 'unabbrev.value.q'
"unabbrev.value"<-
function(x, choices)
{
	err <- F
	if(!is.character(x) || length(x) != 1) {
		err <- T
		emsg <- paste("need single character string for", deparse(
			substitute(x)))
	}
	else {
		xnum <- pmatch(x, choices, nomatch = 0)
		if(xnum == 0) {
			err <- T
			emsg <- paste("unknown or ambiguous choice for ", 
				deparse(substitute(x)), ": ", x, sep = "")
		}
	}
	if(err) {
		eval(call("stop", emsg), local = sys.parent())
	}
	else choices[xnum]
}
SHAR_EOF
fi
if test -f 'uninterlude.q'
then
	echo shar: "will not over-write existing file 'uninterlude.q'"
else
cat << \SHAR_EOF > 'uninterlude.q'
"uninterlude"<-
function(x = names(get(".Interlude", where = 0)))
{
	if(!is.character(x))
		x <- deparse(substitute(x))
	ilist <- get(".Interlude", where = 0)
	if(missing(x))
		x <- x[nchar(x) > 0]
	remove(x, where = 0)
	okay <- !match(names(ilist), x, nomatch = 0)
	okay[nchar(names(ilist)) == 0] <- T
	ilist <- ilist[okay]
	class(ilist) <- "interlude"
	assign(".Interlude", ilist, where = 0)
	invisible(x)
}
SHAR_EOF
fi
if test -f 'unique.mathgraph.d'
then
	echo shar: "will not over-write existing file 'unique.mathgraph.d'"
else
cat << \SHAR_EOF > 'unique.mathgraph.d'
.BG
.FN unique.mathgraph
.TL
Unique Edges of a Mathematical Graph
.DN
Returns a mathgraph object that may have fewer edges than the input.
.CS
unique.mathgraph(x)
.RA
.AG x
an object that inherits from mathgraph.
.RT
an object that is the same class as the input x, but redundant edges
are removed.
.SA
mathgraph
.EX
unique(mathgraph(~ 1:2*2:3 + 1/3))
.WR
SHAR_EOF
fi
if test -f 'unique.mathgraph.q'
then
	echo shar: "will not over-write existing file 'unique.mathgraph.q'"
else
cat << \SHAR_EOF > 'unique.mathgraph.q'
"unique.mathgraph"<-
function(x)
{
	dir <- attr(x, "directed")
	cl <- class(x)
	x <- unclass(x)
	xwork <- x
	if(!all(dir)) {
# worry about order of nodes in undirected edges
		xwork[!dir,  ] <- stable.apply(x[!dir,  , drop = F], 1, sort)
	}
	xdup <- duplicated(paste(xwork[, 1], xwork[, 2], dir))
	x <- x[!xdup,  , drop = F]
	dir <- dir[!xdup]
	attr(x, "directed") <- dir
	class(x) <- cl
	x
}
SHAR_EOF
fi
if test -f 'unique.rationalnum.q'
then
	echo shar: "will not over-write existing file 'unique.rationalnum.q'"
else
cat << \SHAR_EOF > 'unique.rationalnum.q'
"unique.rationalnum"<-
function(x)
{
	xchar <- paste(x$numerator, "/", x$denominator)
	x$names <- NULL
	x[!duplicated(xchar)]
}
SHAR_EOF
fi
if test -f 'update.loan.d'
then
	echo shar: "will not over-write existing file 'update.loan.d'"
else
cat << \SHAR_EOF > 'update.loan.d'
.BG
.FN update.loan
.TL
Put Payments into Loan Object
.DN
Takes a loan object and a vector of payments, and returns a loan
object with the payments included.
.CS
update.loan(object, payment)
.RA
.AG object
object of class loan.
.AG payment
numeric vector of payments to be made to the loan.
.RT
a loan object with the initial rows equal to those in the input, 
and a new row for each element of payment.
.SA
loan.
.EX
jjcar.loan <- loan(8000, .08, "May", 1998)
jjcar.loan <- update(jjcar.loan, rep(234, 3))
jjcar.loan
jjcar.loan <- update(jjcar.loan, c(218, 245))
jjcar.loan
.WR
SHAR_EOF
fi
if test -f 'update.loan.q'
then
	echo shar: "will not over-write existing file 'update.loan.q'"
else
cat << \SHAR_EOF > 'update.loan.q'
"update.loan"<-
function(object, payment)
{
	last.date <- attr(object, "last.date")
	rate <- attr(object, "rate")
	npay <- length(payment)
	new.month <- last.date["month"] + 1:npay
	new.year <- (new.month - 1) %/% 12 + last.date["year"]
	new.month <- (new.month - 1) %% 12 + 1
	last.prin <- object[nrow(object), "principal"]
	new.prin <- new.inter <- numeric(npay)
	for(i in 1:npay) {
		new.inter[i] <- this.inter <- round((last.prin * rate)/12, 2)
		new.prin[i] <- last.prin <- last.prin + this.inter - payment[i]
	}
	ans <- rbind(object, data.frame(month = month.name[new.month], year = 
		new.year, principal = new.prin, interest = new.inter, payment
		 = payment))
	attr(ans, "last.date") <- c(month = new.month[npay], year = new.year[
		npay])
	attr(ans, "rate") <- rate
	ans
}
SHAR_EOF
fi
if test -f 'valid.s.name.d'
then
	echo shar: "will not over-write existing file 'valid.s.name.d'"
else
cat << \SHAR_EOF > 'valid.s.name.d'
.BG
.FN valid.s.name
.TL
Test if Valid S Name
.DN
Returns a logical vector as long as the input that states if each
string is a valid name in the S language.
.CS
valid.s.name(x)
.RA
.AG x
character vector.
.RT
logical vector the same length as x.
Values are TRUE if the corresponding string of the input follows the
rules for an object name in S.
.DT
Objects in S may -- and many do -- have names that are not "valid",
but special measures need to be taken then.
.SH BUGS
No account is taken of reserved words.
.SA
get, as.name.
.EX
valid.s.name(c("dim", "dim<-", ".3e5", ".e35"))
.KW programming
.WR
SHAR_EOF
fi
if test -f 'valid.s.name.q'
then
	echo shar: "will not over-write existing file 'valid.s.name.q'"
else
cat << \SHAR_EOF > 'valid.s.name.q'
"valid.s.name"<-
function(x)
{
	xnum <- lapply(x, AsciiToInt)
	the.table <- c(48:57, 46, 65:90, 97:122)
	xmatch <- lapply(xnum, match, table = the.table, nomatch = 0)
	good <- unlist(lapply(xmatch, function(z)
	all(z > 10)))
	bad <- unlist(lapply(xmatch, function(z)
	any(z == 0) || all(z < 11) || !length(z)))
	ans <- rep(NA, length(x))
	ans[good] <- T
	ans[bad] <- F
	ugly <- !good & !bad
	if(any(ugly)) {
		xug <- unlist(lapply(xmatch[ugly], function(z)
		z[z != 11][1] > 11))
		ans[ugly][xug] <- T
		ans[ugly][!xug] <- F
	}
	names(ans) <- names(x)
	ans
}
SHAR_EOF
fi
if test -f 'verify.d'
then
	echo shar: "will not over-write existing file 'verify.d'"
else
cat << \SHAR_EOF > 'verify.d'
.BG
.FN verify
.FN [.verify
.FN verify.default
.FN verify.verify
.TL
Test Suite
.DN
Creates or uses an object of class `"verify"' to check returned values
of commands.
.CS
verify(x, ...)
verify.default(x, data=list())
verify.verify(x)
.RA
.AG x
either a vector of character strings that are commands to be tested, or
an object of class `"verify"'.
If a character vector is given, it is often useful if it has names that
summarize the commands.
.OA
.AG data
a named list of data to use in the commands.
.RT
an object of class `"verify"' that is a list of the results of the commands.
In addition to `class' and possibly `names', it has the following attributes:
.RC data
the input or default value of `data'.
.RC passed
a logical vector, or a list that is the result of `all.equal' on the
new versus original results for each command.
.RC random.seed
the random seed needed to reproduce results that depend on the random
number generator.
.RC specifics
a list providing the details of how and when the object was created.
.SE
if any of the commands require random numbers, then `.Random.seed' is
created or changed in the current directory.
.DT
The commands may include the output from previous commands in the
object.
The result of the first command is available as `Test.' plus the name
of the test.  
The index number is used if there are not names.
.PP
This is valuable to insure that changes in the code, the S version,
the operating system or hardware does not change (substantially) the
results of the tested commands.
.PP
There is a `print' method for the `"verify"' class of objects.
There is also a method for `['.
.SA
`print.verify', `all.equal'.
.EX
jjverif <- verify(c(sin="sin(x)", ran="runif(9)"), list(x=1:4))

jjverif2 <- verify(jjverif)
print(jjverif2)

jjverif3 <- verify(c(sin="sin(x)", ran="runif(9)",
	more="outer(Test.sin, Test.ran)"), list(x=1:4))
print(jjverif3, short=T)

print(verify(poet.verif[-28]), short=T)
.KW programming
.WR
SHAR_EOF
fi
if test -f 'verify.default.q'
then
	echo shar: "will not over-write existing file 'verify.default.q'"
else
cat << \SHAR_EOF > 'verify.default.q'
"verify.default"<-
function(x, data = list())
{
	if(!is.character(x))
		stop("x should be a character vector of commands")
	random.seed <- .Random.seed
	n <- length(x)
	ans <- vector("list", n)
	tnam <- xnam <- names(x)
	if(!length(tnam))
		tnam <- 1:n
	for(i in 1:n) {
		if(length(data)) {
			ans[[i]] <- eval(parse(text = x[i]), data)
		}
		else {
			ans[[i]] <- eval(parse(text = x[i]))
		}
		data[[paste("Test", tnam[i], sep = ".")]] <- ans[[i]]
	}
	if(all(random.seed == .Random.seed))
		random.seed <- NULL
	passed <- rep(NA, n)
	names(passed) <- xnam
	length(data) <- length(data) - n
	specifics <- list(version = version, machine = unix("hostname"), date
		 = date())
	attributes(ans) <- list(names = xnam, data = data, commands = x, passed
		 = passed, random.seed = random.seed, specifics = specifics, 
		class = "verify")
	ans
}
SHAR_EOF
fi
if test -f 'verify.q'
then
	echo shar: "will not over-write existing file 'verify.q'"
else
cat << \SHAR_EOF > 'verify.q'
"verify"<-
function(x, ...)
UseMethod("verify")
SHAR_EOF
fi
if test -f 'verify.verify.q'
then
	echo shar: "will not over-write existing file 'verify.verify.q'"
else
cat << \SHAR_EOF > 'verify.verify.q'
"verify.verify"<-
function(x)
{
	commands <- attr(x, "commands")
	random.seed <- attr(x, "random.seed")
	if(length(random.seed)) {
		old.seed <- .Random.seed
		on.exit(.Random.seed <<- old.seed)
		.Random.seed <<- random.seed
	}
	n <- length(x)
	data <- attr(x, "data")
	passed <- ans <- vector("list", n)
	tnam <- xnam <- names(x)
	if(!length(tnam))
		tnam <- 1:n
	for(i in 1:n) {
		if(length(data)) {
			ans[[i]] <- eval(parse(text = commands[i]), data)
		}
		else {
			ans[[i]] <- eval(parse(text = commands[i]))
		}
		passed[[i]] <- all.equal(x[[i]], ans[[i]])
		data[[paste("Test", tnam[i], sep = ".")]] <- ans[[i]]
	}
	if(all(unlist(lapply(passed, mode)) == "logical"))
		passed <- unlist(passed)
	names(passed) <- xnam
	length(data) <- length(data) - n
	specifics <- list(version = if(exists("version")) version else NULL, 
		machine = unix("hostname"), date = date())
	attributes(ans) <- list(names = xnam, data = data, commands = commands, 
		passed = passed, random.seed = random.seed, specifics = 
		specifics, class = "verify")
	ans
}
SHAR_EOF
fi
if test -f 'whence.d'
then
	echo shar: "will not over-write existing file 'whence.d'"
else
cat << \SHAR_EOF > 'whence.d'
.BG
.FN whence
.TL
Location of an Object
.DN
Returns a number indicating the first location where an object is found.
.CS
whence(x, mode.="any", offset=0)
.RA
.AG x
a single character string of the name of the object.
.OA
.AG mode.
a character string giving the mode of interest.
.AG offset
the number of frames that `whence' is nested below the frame to look in.
.RT
a single number.
A negative number means that the object is found in frame absolute
value of the number;
zero means it is in database 0;
a positive number means it is found in that location in the search list;
an `NA' means that no suitable object was found.
.DT
This searches the same locations as the standard search that S carries
out for objects.
.SA
`find', `exists', `get'.
.EX
whence("freeny.x")
whence("freeny.x", "function")
whence("whence", "function")
.KW programming
.WR
SHAR_EOF
fi
if test -f 'whence.q'
then
	echo shar: "will not over-write existing file 'whence.q'"
else
cat << \SHAR_EOF > 'whence.q'
"whence"<-
function(x, mode. = "any", offset = 0)
{
	if(!is.character(x) || length(x) != 1)
		stop("need single character string for x")
	parent <- sys.parent() - offset
	if(exists(x, mode = mode., frame = parent))
		return( - parent)
	if(exists(x, mode = mode., frame = 1))
		return(-1)
	if(exists(x, mode = mode., frame = 0))
		return(0)
	find(x, mode = mode., numeric = T)[1]
}
SHAR_EOF
fi
if test -f 'xerrsp.f'
then
	echo shar: "will not over-write existing file 'xerrsp.f'"
else
cat << \SHAR_EOF > 'xerrsp.f'
	subroutine xerrsp(x, n)
	implicit none
	integer n
	double precision x(n)
	integer i, m99l, m2l
	character*100 m99, m2
	real xe

	call dblepr('x values are', -1, x, n)
	
	m99 = "x value is negative"
	m99l = len(m99)
	m2 = "r1 is more than 2"
	m2l = len(m2)

	do i=1, n
	   if(x(i) .lt. 0.0) then
	      call xerror(m99, m99l, 99, 1)
	   endif
	   if(x(i) .gt. 2.0) then
	      xe = x(i)
	      call xerrwv(m2, m2l, 2, 1, 0, 0, 0, 1, xe, 0.0)
	   endif
	end do
	return
	end
SHAR_EOF
fi
exit 0
#	End of shell archive
