#! /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=<>, new=<>) .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 #include 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 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 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 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 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=<>, ...) .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 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