diff --git a/COPYRIGHTS b/COPYRIGHTS index 1cca4fb100c..4c1b59c9c5b 100644 --- a/COPYRIGHTS +++ b/COPYRIGHTS @@ -16,6 +16,10 @@ afm/* Copyright (c) 1984 Adobe Systems Incorporated. +src/library/base/R/mosaicplot.R + + Copyright (C) 1998 John W. Emerson + src/library/base/R/aov.R src/library/base/R/biplot.R src/library/base/R/contr.poly.R diff --git a/INSTALL b/INSTALL index dc33e29210e..51d822396b4 100644 --- a/INSTALL +++ b/INSTALL @@ -72,7 +72,7 @@ This will install to the following directories: $prefix/bin (some) executables $prefix/man/man1 man pages - $prefix/lib/R all the rest (libraries, online help + $prefix/share/R all the rest (libraries, online help system, ...) where prefix is determined during configuration (typically /usr/local) @@ -93,6 +93,14 @@ and so on, as described further above. This has the advantage of always keeping your source tree `clean'. +USING MAKE + +To compile R, you currently most likely need GNU make. (To be more +precise, you need a version of make which accepts shell wildcards in +dependencies.) On Solaris 2.6 in particular, you need a version of +GNU make different from 3.77 (the current one); 3.76.1 works fine. + + USING FORTRAN To compile R, you need a FORTRAN compiler or f2c, the FORTRAN-to-C @@ -105,20 +113,6 @@ compiler is in a non-standard location, you should set the enviroment vaiable PATH accordingly before running configure. -TWO-LEVEL MAKE - -If you don't need to supply any special arguments to "configure", you -can actually build R simply by typing "make", which will automatically -run "configure" if the configuration files are absent. Since the build -process depends on the results of "configure", the top-level Makefile -does little more than passing control to Makefile.2nd after ensuring -that "configure" has been run. - -This has the curious, but harmless, consequence that "make distclean" -and the like may run "configure" and remove the configuration files a -moment later. This looks odd, but is fairly hard to avoid. - - NEW PLATFORMS (Standards Hah!) There are a number of sources of problems when installing R on a new diff --git a/Makeconf.in b/Makeconf.in index 6f940f9644b..9862d46ccc6 100644 --- a/Makeconf.in +++ b/Makeconf.in @@ -50,4 +50,4 @@ datadir = @datadir@ libdir = @libdir@ mandir = @mandir@ -rhome = @datadir@/R +rhome = @libdir@/R diff --git a/Makefile.in b/Makefile.in index 31d0f39e603..47eb5af4c5d 100644 --- a/Makefile.in +++ b/Makefile.in @@ -26,19 +26,13 @@ Makefile: cd $(top_builddir) \ && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status -R: stamp-R -stamp-R: $(top_builddir)/src/include/Platform.h \ - $(top_srcdir)/src/*/*.[chfy] \ - $(top_srcdir)/src/library/*/R/*.R \ - $(top_srcdir)/src/library/*/src/*.[chf] - @rm -f $@ +R: @for d in afm demos doc etc src; do \ - (cd $$d && $(MAKE) R); \ + (cd $${d} && $(MAKE) R) || exit 1; \ done @if [ ! -f src/library/stamp-docs ]; then \ echo "You should \`make docs' now ..."; \ fi - @touch $@ $(top_builddir)/src/include/Platform.h: $(srcdir)/date-stamp $(top_srcdir)/configure --srcdir $(top_srcdir) @@ -49,11 +43,11 @@ FORCE: install: all installdirs @for d in afm demos doc etc; do \ - (cd $$d && $(MAKE) $@); \ + (cd $${d} && $(MAKE) $@) || exit 1; \ done @(cd $(srcdir); \ for f in COPYING COPYRIGHTS MIRROR-SITES RESOURCES; do \ - $(INSTALL_DATA) $$f $(rhome); \ + $(INSTALL_DATA) $${f} $(rhome); \ done) @echo "Installing executables ..." @$(INSTALL_PROGRAM) bin/R.binary $(rhome)/bin @@ -61,14 +55,14 @@ install: all installdirs @cat bin/R | sed "s@RHOME=.*@RHOME=$(rhome)@" > $(bindir)/R @chmod 755 $(bindir)/R $(rhome)/bin @for f in `ls bin/* | grep -v '^R\|R.binary'`; do \ - $(INSTALL) $$f $(rhome)/bin; \ + $(INSTALL) $${f} $(rhome)/bin; \ done @for f in Rd2txt Rdconv Rdindex Sd2Rd; do \ - $(INSTALL) bin/$$f $(bindir); \ + $(INSTALL) bin/$${f} $(bindir); \ done @echo "Installing headers ..." @for f in include/*.h; do \ - $(INSTALL_DATA) $$f $(rhome)/include; \ + $(INSTALL_DATA) $${f} $(rhome)/include; \ done @echo "Installing library ..." @cd library; $(TAR) cf - [a-z]* | (cd $(rhome)/library; tar xf -) @@ -86,7 +80,7 @@ install-strip: uninstall: @echo "Uninstalling library ..." @(cd $(rhome)/library; \ - for p in base eda modreg mva stepfun; do rm -rf $$p; done) + for p in base eda modreg mva stepfun; do rm -rf $${p}; done) @echo " Rebuilding help index ..." @(cd $(rhome)/library; cat */TITLE > LibIndex 2> /dev/null) @echo " Rebuilding HTML index ..." @@ -96,21 +90,21 @@ uninstall: @echo "Uninstalling executables ..." @rm -rf $(rhome)/bin @for f in R Rd2txt Rdconv Rdindex Sd2Rd; do \ - rm -f $(bindir)/$$f; \ + rm -f $(bindir)/$${f}; \ done @for f in COPYING COPYRIGHTS MIRROR-SITES RESOURCES; do \ - rm -f $(rhome)/$$f; \ + rm -f $(rhome)/$${f}; \ done @for d in afm demos doc etc; do \ - (cd $$d && $(MAKE) $@); \ + (cd $${d} && $(MAKE) $@); \ done mostlyclean: clean clean: @for d in $(SUBDIRS); do \ - (cd $$d && $(MAKE) $@); \ + (cd $${d} && $(MAKE) $@); \ done - @rm -f stamp-R + distclean: clean @for d in $(SUBDIRS); do \ (cd $${d} && $(MAKE) $@); \ diff --git a/NEWS b/NEWS index 8ac8f0551d8..5460f38671e 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,89 @@ + CHANGES IN R VERSION 0.63.1 + +NEW FEATURES + + o new function mosaicplot(). + + o xy.coords(.) has a "recycle = FALSE" argument, used in text(). + + o RNGtype() allows to choose different Random Number Generators. + __EXPERIMENTAL__ + + o print.default(.) now also works with a `right = TRUE' argument. + {{ print.matrix(.) is bound to become deprecated... }} + + o new help page `Memory' on the usage of command line options + --vsize and --nsize. Error message if R runs out of memory + points to help(Memory). + + o rowsum() and improved na.omit() added from survival4 + + o backsolve(.) has new arguments "upper.tri = TRUE, transpose = FALSE" + + o hist() has new "right = TRUE" argument; + "right = FALSE" gives [a,b) intervals + + o help() has "htmlhelp" argument, allowing to suppress htmlhelp after + help.start(). This is desired for ESS. + + o quantile(.) has an "names = TRUE" argument for speed. + It is much better documented now. + + +BUG FIXES + + o build-help --dosnames should now also work for text help, + latex and examples. + + o seq() should work better now (fuzz-factor 1e-7 inserted) + + o multiple arguments to return caused value to be a pairlist + + o data.frame choked on long names from deparse() + + o data.edit now works (dataedit doesn't need pairlist()s anymore) + + o as.pairlist(NULL) is ok + + o ts(1:5, start=2, end=4) now work. Further plot(ts(..), ts(..)) + + o eigen() returns $vectors in any case [S compat]. + + o apply(cbind(1,1:9, 2, quantile) doesn't drop quantile names anymore + + o array(1, dim=(1:3)[c(F,F,F)]) is now valid == array(1,NULL) == c(1); + the same for array(a,d, list()) + + o fix problem with step() and offsets + + o drop attributes on matrix subsetting + + o kappa(.) now works [dtrco now in load table (ROUTINES)]. + + o pmin() and pmax() now preserve attributes. + + o handle null models arising in drop1(), step, etc. + + o partial matching problem with $ indexing + + o matplot(.) works with lwd (vectors) + + o par("cex.axis") now has the desired effect... + + o which(.) now omits NAs in its argument. + + o rbind.data.frame caused character-to-factor coercion a bit too often + + o couple of messups in dotplot + + o z[[1]] <- ~x probl fixed as suggested by J.Lindsey + + o do_modelframe could lose contrast attributes + + o "make check" needed standardisation of locale + + o unlist(...,recursive=F) got names wrong + CHANGES IN R VERSION 0.63 NEW FEATURES @@ -8,7 +94,7 @@ NEW FEATURES o new .Platform variable for better modularizing platform dependence. __This_is_"beta"_and_bound_to_be_changed___ - o new arguments to colnames(..) and + o new arguments to colnames(..) and rownames(x, do.NULL = TRUE, prefix = "row"). _ o par(bty = "]") for _| box(.) in plots. @@ -111,12 +197,12 @@ NEW FEATURES and is subject to internal and interface changes. o gctorture() for torturing the garbage collector to reveal - memory protection bugs. (Call GC on every memory allocation). + memory protection bugs. (Call GC on every memory allocation). - o B. Ripley's aov code (and more) has been added. This includes: + o B. Ripley's aov code (and more) has been added. This includes: - aov() now handles models with Error terms, multiple - responses. + responses. - proj(), model.tables(), se.contrast(), replications(), eff.aovlist() are implemented for aov fits, and where @@ -129,7 +215,7 @@ NEW FEATURES - summary() and deviance() -- mlm methods. - - kappa() for estimating condition numbers) + - kappa() for estimating condition numbers) - labels() to find a suitable set of labels from an object @@ -137,12 +223,12 @@ NEW FEATURES - anova(), plot(), summary() and deviance() methods for mlm fits - o eval() semantics changed when envir= is a list. A 3rd argument is + o eval() semantics changed when envir= is a list. A 3rd argument is now allowed, specifying the enclosure (i.e. where R looks for - variables *not* found in envir=) it defaults to the calling + variables *not* found in envir=) it defaults to the calling environment (was .GlobalEnv). Note that when used inside a function, - it is often desirable to set the enclosure to the parent - environment instead. [ eval(e, data, sys.frame(sys.parent())) ] + it is often desirable to set the enclosure to the parent + environment instead. [ eval(e, data, sys.frame(sys.parent())) ] BUG FIXES diff --git a/PLATFORMS b/PLATFORMS index 75d3f2c5523..5ba1354f4b8 100644 --- a/PLATFORMS +++ b/PLATFORMS @@ -17,7 +17,7 @@ our installation procedures. sparc-sun-solaris2.5.1 gcc / g77 " gcc / f77 " cc / f77 - + sparc-sun-solaris2.6 gcc / f77 OLD (pre 0.62 systems) diff --git a/configure b/configure index cbf8daf98ba..0f6c8f8caa3 100755 --- a/configure +++ b/configure @@ -17,8 +17,12 @@ ac_help="$ac_help --with-g77 use g77 to compile FORTRAN subroutines" ac_help="$ac_help --with-f77 use f77 to compile FORTRAN subroutines" +ac_help="$ac_help + --enable-libmoto use libmoto math library (if available)" ac_help="$ac_help --enable-blas use BLAS library (if available)" +ac_help="$ac_help + --enable-blas_risc use RISC Optimized BLAS library (if available)" ac_help="$ac_help --enable-dxml use DXML library (if available)" ac_help="$ac_help @@ -666,6 +670,18 @@ fi ## Here we should maybe check that only one of the above options for ## dealing with FORTRAN were specified. +# Check whether --enable-libmoto or --disable-libmoto was given. +if test "${enable_libmoto+set}" = set; then + enableval="$enable_libmoto" + if test "${enableval}"=no; + then use_libmoto=false; + else use_libmoto=true; + fi +else + use_libmoto=true +fi + + # Check whether --enable-blas or --disable-blas was given. if test "${enable_blas+set}" = set; then enableval="$enable_blas" @@ -678,6 +694,18 @@ else fi +# Check whether --enable-blas_risc or --disable-blas_risc was given. +if test "${enable_blas_risc+set}" = set; then + enableval="$enable_blas_risc" + if test "${enableval}" = no; + then use_blas_risc=false; + else use_blas_risc=true; + fi +else + use_blas_risc=true +fi + + # Check whether --enable-dxml or --disable-dxml was given. if test "${enable_dxml+set}" = set; then enableval="$enable_dxml" @@ -715,7 +743,7 @@ fi # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # ./install, which can be erroneously created by make from ./install.sh. echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 -echo "configure:719: checking for a BSD compatible install" >&5 +echo "configure:747: checking for a BSD compatible install" >&5 if test -z "$INSTALL"; then if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -770,9 +798,14 @@ case ${INSTALL} in *install-sh*) INSTALL="\$\(top_srcdir\)/${INSTALL}" ;; esac +## Osman says that this is necessary. +case ${host} in + *hpux*) + INSTALL="\$\(top_srcdir\)/${INSTALL}" ;; +esac echo $ac_n "checking whether ln -s works""... $ac_c" 1>&6 -echo "configure:776: checking whether ln -s works" >&5 +echo "configure:809: checking whether ln -s works" >&5 if eval "test \"`echo '$''{'ac_cv_prog_LN_S'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -795,7 +828,7 @@ fi # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:799: checking for $ac_word" >&5 +echo "configure:832: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -826,7 +859,7 @@ do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:830: checking for $ac_word" >&5 +echo "configure:863: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_prog_YACC'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -859,7 +892,7 @@ test -n "$YACC" || YACC="yacc" # Extract the first word of "ar", so it can be a program name with args. set dummy ar; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:863: checking for $ac_word" >&5 +echo "configure:896: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_prog_AR'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -887,7 +920,7 @@ fi # Extract the first word of "ratfor", so it can be a program name with args. set dummy ratfor; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:891: checking for $ac_word" >&5 +echo "configure:924: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_prog_RATFOR'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -916,7 +949,7 @@ fi # Extract the first word of "latex", so it can be a program name with args. set dummy latex; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:920: checking for $ac_word" >&5 +echo "configure:953: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_path_LATEX'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -948,7 +981,7 @@ fi # Extract the first word of "dvips", so it can be a program name with args. set dummy dvips; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:952: checking for $ac_word" >&5 +echo "configure:985: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_path_DVIPS'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -980,7 +1013,7 @@ fi # Extract the first word of "makeindex", so it can be a program name with args. set dummy makeindex; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:984: checking for $ac_word" >&5 +echo "configure:1017: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_path_MAKEINDEX'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -1020,7 +1053,7 @@ MAKE=${MAKE-make} # Extract the first word of "perl", so it can be a program name with args. set dummy perl; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1024: checking for $ac_word" >&5 +echo "configure:1057: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_path_PERL'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -1050,7 +1083,7 @@ fi if test -n "${PERL}"; then echo $ac_n "checking whether perl is perl 5""... $ac_c" 1>&6 -echo "configure:1054: checking whether perl is perl 5" >&5 +echo "configure:1087: checking whether perl is perl 5" >&5 perl_version=`${PERL} -v | sed -n 's/^.*perl.*version \(.\).*/\1/p'` if test ${perl_version} -ge 5 then @@ -1080,7 +1113,7 @@ then # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1084: checking for $ac_word" >&5 +echo "configure:1117: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -1109,7 +1142,7 @@ if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1113: checking for $ac_word" >&5 +echo "configure:1146: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -1157,7 +1190,7 @@ fi fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1161: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1194: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c # CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. @@ -1167,11 +1200,11 @@ ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS cross_compiling=$ac_cv_prog_cc_cross cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1208: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1191,12 +1224,12 @@ if test $ac_cv_prog_cc_works = no; then { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1195: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1228: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1200: checking whether we are using GNU C" >&5 +echo "configure:1233: checking whether we are using GNU C" >&5 if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -1205,7 +1238,7 @@ else yes; #endif EOF -if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1209: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1242: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1220,7 +1253,7 @@ if test $ac_cv_prog_gcc = yes; then ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1224: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1257: checking whether ${CC-cc} accepts -g" >&5 if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -1251,7 +1284,7 @@ else # Extract the first word of "${CC}", so it can be a program name with args. set dummy ${CC}; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1255: checking for $ac_word" >&5 +echo "configure:1288: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -1312,7 +1345,7 @@ fi # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1316: checking for $ac_word" >&5 +echo "configure:1349: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -1376,7 +1409,7 @@ do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1380: checking for $ac_word" >&5 +echo "configure:1413: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_path_F77'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -1424,7 +1457,7 @@ do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1428: checking for $ac_word" >&5 +echo "configure:1461: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_prog_F2C'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -1464,7 +1497,7 @@ if test -n "${F77}"; then FC=${F77} LDCMD=${LDCMD-${FC}} echo $ac_n "checking for underscore after Fortran symbols""... $ac_c" 1>&6 -echo "configure:1468: checking for underscore after Fortran symbols" >&5 +echo "configure:1501: checking for underscore after Fortran symbols" >&5 cat > conftestf.f <&5; (eval $ac_compile) 2>&5; }; then + if { (eval echo configure:1564: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then $AR $ARFLAGS $R_conflib conftest.$R_obj_ext 1>&5 if test -n "$RANLIB"; then $RANLIB $R_conflib 1>&5 @@ -1541,7 +1574,7 @@ EOF EOF echo $ac_n "checking for f_open in -lf2c""... $ac_c" 1>&6 -echo "configure:1545: checking for f_open in -lf2c" >&5 +echo "configure:1578: checking for f_open in -lf2c" >&5 ac_lib_var=`echo f2c'_'f_open | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -1549,7 +1582,7 @@ else ac_save_LIBS="$LIBS" LIBS="-lf2c -L. -lconflib -lm $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1597: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -1583,7 +1616,7 @@ fi if test -z "${FLIBS}"; then echo $ac_n "checking for d_sin in -lF77""... $ac_c" 1>&6 -echo "configure:1587: checking for d_sin in -lF77" >&5 +echo "configure:1620: checking for d_sin in -lF77" >&5 ac_lib_var=`echo F77'_'d_sin | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -1591,7 +1624,7 @@ else ac_save_LIBS="$LIBS" LIBS="-lF77 -lm $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1639: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -1625,7 +1658,7 @@ fi if test -n "${FLIBS}"; then echo $ac_n "checking for f_rew in -lI77""... $ac_c" 1>&6 -echo "configure:1629: checking for f_rew in -lI77" >&5 +echo "configure:1662: checking for f_rew in -lI77" >&5 ac_lib_var=`echo I77'_'f_rew | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -1633,7 +1666,7 @@ else ac_save_LIBS="$LIBS" LIBS="-lI77 -lF77 $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1681: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -1716,7 +1749,7 @@ done export LD_LIBRARY_PATH echo $ac_n "checking for sin in -lm""... $ac_c" 1>&6 -echo "configure:1720: checking for sin in -lm" >&5 +echo "configure:1753: checking for sin in -lm" >&5 ac_lib_var=`echo m'_'sin | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -1724,7 +1757,7 @@ else ac_save_LIBS="$LIBS" LIBS="-lm $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1772: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -1762,8 +1795,57 @@ else echo "$ac_t""no" 1>&6 fi +if ${use_libmoto}; then + echo $ac_n "checking for sin in -lmoto""... $ac_c" 1>&6 +echo "configure:1801: checking for sin in -lmoto" >&5 +ac_lib_var=`echo moto'_'sin | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lmoto $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_lib=HAVE_LIB`echo moto | sed -e 's/[^a-zA-Z0-9_]/_/g' \ + -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'` + cat >> confdefs.h <&6 +fi + +fi echo $ac_n "checking for main in -lncurses""... $ac_c" 1>&6 -echo "configure:1767: checking for main in -lncurses" >&5 +echo "configure:1849: checking for main in -lncurses" >&5 ac_lib_var=`echo ncurses'_'main | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -1771,14 +1853,14 @@ else ac_save_LIBS="$LIBS" LIBS="-lncurses $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1864: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -1804,7 +1886,7 @@ EOF else echo "$ac_t""no" 1>&6 echo $ac_n "checking for main in -ltermcap""... $ac_c" 1>&6 -echo "configure:1808: checking for main in -ltermcap" >&5 +echo "configure:1890: checking for main in -ltermcap" >&5 ac_lib_var=`echo termcap'_'main | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -1812,14 +1894,14 @@ else ac_save_LIBS="$LIBS" LIBS="-ltermcap $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1905: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -1845,7 +1927,7 @@ EOF else echo "$ac_t""no" 1>&6 echo $ac_n "checking for main in -ltermlib""... $ac_c" 1>&6 -echo "configure:1849: checking for main in -ltermlib" >&5 +echo "configure:1931: checking for main in -ltermlib" >&5 ac_lib_var=`echo termlib'_'main | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -1853,14 +1935,14 @@ else ac_save_LIBS="$LIBS" LIBS="-ltermlib $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1946: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -1893,7 +1975,7 @@ fi fi echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6 -echo "configure:1897: checking for dlopen in -ldl" >&5 +echo "configure:1979: checking for dlopen in -ldl" >&5 ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -1901,7 +1983,7 @@ else ac_save_LIBS="$LIBS" LIBS="-ldl $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1998: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -1941,7 +2023,7 @@ fi echo $ac_n "checking for main in -lhdf5""... $ac_c" 1>&6 -echo "configure:1945: checking for main in -lhdf5" >&5 +echo "configure:2027: checking for main in -lhdf5" >&5 ac_lib_var=`echo hdf5'_'main | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -1949,14 +2031,14 @@ else ac_save_LIBS="$LIBS" LIBS="-lhdf5 $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2042: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -1984,7 +2066,7 @@ else fi echo $ac_n "checking for main in -lz""... $ac_c" 1>&6 -echo "configure:1988: checking for main in -lz" >&5 +echo "configure:2070: checking for main in -lz" >&5 ac_lib_var=`echo z'_'main | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -1992,14 +2074,14 @@ else ac_save_LIBS="$LIBS" LIBS="-lz $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2085: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -2030,7 +2112,7 @@ fi BLAS="blas.o" if ${use_dxml}; then echo $ac_n "checking for main in -ldxml""... $ac_c" 1>&6 -echo "configure:2034: checking for main in -ldxml" >&5 +echo "configure:2116: checking for main in -ldxml" >&5 ac_lib_var=`echo dxml'_'main | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -2038,14 +2120,14 @@ else ac_save_LIBS="$LIBS" LIBS="-ldxml $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2131: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -2063,9 +2145,12 @@ if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then FLIBS="-ldxml ${FLIBS}" BLAS="" else echo "$ac_t""no" 1>&6 -if ${use_blas}; then - echo $ac_n "checking for main in -lblas""... $ac_c" 1>&6 -echo "configure:2069: checking for main in -lblas" >&5 +fi + +fi +if test -n "${BLAS}" && ${use_blas}; then + echo $ac_n "checking for main in -lblas""... $ac_c" 1>&6 +echo "configure:2154: checking for main in -lblas" >&5 ac_lib_var=`echo blas'_'main | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -2073,14 +2158,14 @@ else ac_save_LIBS="$LIBS" LIBS="-lblas $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2169: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -2095,13 +2180,48 @@ LIBS="$ac_save_LIBS" fi if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then echo "$ac_t""yes" 1>&6 - FLIBS="-lblas ${FLIBS}" BLAS="" + FLIBS="-lblas ${FLIBS}" BLAS="" + if ${use_blas_risc}; then + echo $ac_n "checking for main in -lblas_risc""... $ac_c" 1>&6 +echo "configure:2187: checking for main in -lblas_risc" >&5 +ac_lib_var=`echo blas_risc'_'main | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lblas_risc -lblas -lf2c $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + FLIBS="-lblas_risc ${FLIBS}" else echo "$ac_t""no" 1>&6 fi - fi - + fi + +else + echo "$ac_t""no" 1>&6 fi fi @@ -2116,7 +2236,7 @@ done if ${use_readline}; then echo $ac_n "checking for rl_callback_read_char in -lreadline""... $ac_c" 1>&6 -echo "configure:2120: checking for rl_callback_read_char in -lreadline" >&5 +echo "configure:2240: checking for rl_callback_read_char in -lreadline" >&5 ac_lib_var=`echo readline'_'rl_callback_read_char | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -2124,7 +2244,7 @@ else ac_save_LIBS="$LIBS" LIBS="-lreadline $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2259: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -2167,7 +2287,7 @@ fi ### Library functions. echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 -echo "configure:2171: checking how to run the C preprocessor" >&5 +echo "configure:2291: checking how to run the C preprocessor" >&5 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= @@ -2182,13 +2302,13 @@ else # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2192: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2312: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -2199,13 +2319,13 @@ else rm -rf conftest* CPP="${CC-cc} -E -traditional-cpp" cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2209: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2329: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -2228,12 +2348,12 @@ fi echo "$ac_t""$CPP" 1>&6 echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 -echo "configure:2232: checking for ANSI C header files" >&5 +echo "configure:2352: checking for ANSI C header files" >&5 if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #include @@ -2241,7 +2361,7 @@ else #include EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2245: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2365: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2258,7 +2378,7 @@ rm -f conftest* if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -2276,7 +2396,7 @@ fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -2297,7 +2417,7 @@ if test "$cross_compiling" = yes; then : else cat > conftest.$ac_ext < #define ISLOWER(c) ('a' <= (c) && (c) <= 'z') @@ -2308,7 +2428,7 @@ if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); exit (0); } EOF -if { (eval echo configure:2312: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null +if { (eval echo configure:2432: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null then : else @@ -2332,12 +2452,12 @@ EOF fi echo $ac_n "checking for pid_t""... $ac_c" 1>&6 -echo "configure:2336: checking for pid_t" >&5 +echo "configure:2456: checking for pid_t" >&5 if eval "test \"`echo '$''{'ac_cv_type_pid_t'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #if STDC_HEADERS @@ -2366,17 +2486,17 @@ fi ac_safe=`echo "vfork.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for vfork.h""... $ac_c" 1>&6 -echo "configure:2370: checking for vfork.h" >&5 +echo "configure:2490: checking for vfork.h" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2380: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2500: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2401,18 +2521,18 @@ else fi echo $ac_n "checking for working vfork""... $ac_c" 1>&6 -echo "configure:2405: checking for working vfork" >&5 +echo "configure:2525: checking for working vfork" >&5 if eval "test \"`echo '$''{'ac_cv_func_vfork_works'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else if test "$cross_compiling" = yes; then echo $ac_n "checking for vfork""... $ac_c" 1>&6 -echo "configure:2411: checking for vfork" >&5 +echo "configure:2531: checking for vfork" >&5 if eval "test \"`echo '$''{'ac_cv_func_vfork'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2559: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_vfork=yes" else @@ -2456,7 +2576,7 @@ fi else cat > conftest.$ac_ext < @@ -2551,7 +2671,7 @@ main() { } } EOF -if { (eval echo configure:2555: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null +if { (eval echo configure:2675: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null then ac_cv_func_vfork_works=yes else @@ -2574,12 +2694,12 @@ EOF fi echo $ac_n "checking for vprintf""... $ac_c" 1>&6 -echo "configure:2578: checking for vprintf" >&5 +echo "configure:2698: checking for vprintf" >&5 if eval "test \"`echo '$''{'ac_cv_func_vprintf'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2726: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_vprintf=yes" else @@ -2626,12 +2746,12 @@ fi if test "$ac_cv_func_vprintf" != yes; then echo $ac_n "checking for _doprnt""... $ac_c" 1>&6 -echo "configure:2630: checking for _doprnt" >&5 +echo "configure:2750: checking for _doprnt" >&5 if eval "test \"`echo '$''{'ac_cv_func__doprnt'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2778: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func__doprnt=yes" else @@ -2682,12 +2802,12 @@ for ac_func in acosh asinh atanh bcopy finite isnan matherr memcpy \ memmove regcomp rint strcoll strtod strtol system times do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:2686: checking for $ac_func" >&5 +echo "configure:2806: checking for $ac_func" >&5 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2834: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -2738,12 +2858,12 @@ done ### Header files echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 -echo "configure:2742: checking for ANSI C header files" >&5 +echo "configure:2862: checking for ANSI C header files" >&5 if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #include @@ -2751,7 +2871,7 @@ else #include EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2755: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2875: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2768,7 +2888,7 @@ rm -f conftest* if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -2786,7 +2906,7 @@ fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -2807,7 +2927,7 @@ if test "$cross_compiling" = yes; then : else cat > conftest.$ac_ext < #define ISLOWER(c) ('a' <= (c) && (c) <= 'z') @@ -2818,7 +2938,7 @@ if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); exit (0); } EOF -if { (eval echo configure:2822: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null +if { (eval echo configure:2942: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null then : else @@ -2846,17 +2966,17 @@ for ac_hdr in dl.h dlfcn.h elf.h locale.h readline/history.h \ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2850: checking for $ac_hdr" >&5 +echo "configure:2970: checking for $ac_hdr" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2860: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2980: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2886,12 +3006,12 @@ done ### Typedefs echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6 -echo "configure:2890: checking return type of signal handlers" >&5 +echo "configure:3010: checking return type of signal handlers" >&5 if eval "test \"`echo '$''{'ac_cv_type_signal'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #include @@ -2908,7 +3028,7 @@ int main() { int i; ; return 0; } EOF -if { (eval echo configure:2912: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3032: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_type_signal=void else @@ -2930,12 +3050,12 @@ EOF ### Compiler characteristics. echo $ac_n "checking for working const""... $ac_c" 1>&6 -echo "configure:2934: checking for working const" >&5 +echo "configure:3054: checking for working const" >&5 if eval "test \"`echo '$''{'ac_cv_c_const'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3108: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_const=yes else @@ -3004,7 +3124,56 @@ EOF fi +echo $ac_n "checking size of long""... $ac_c" 1>&6 +echo "configure:3129: checking size of long" >&5 +if eval "test \"`echo '$''{'ac_cv_sizeof_long'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test "$cross_compiling" = yes; then + ac_cv_sizeof_long=4 +else + cat > conftest.$ac_ext < +main() +{ + FILE *f=fopen("conftestval", "w"); + if (!f) exit(1); + fprintf(f, "%d\n", sizeof(long)); + exit(0); +} +EOF +if { (eval echo configure:3148: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null +then + ac_cv_sizeof_long=`cat conftestval` +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + ac_cv_sizeof_long=0 +fi +rm -fr conftest* +fi +fi +echo "$ac_t""$ac_cv_sizeof_long" 1>&6 +cat >> confdefs.h <> confdefs.h <<\EOF +#define LONG_32_BITS 1 +EOF + +fi + ## Check for nasty OSF sprintf bug # AC_MSG_CHECKING(for osf sprintf bug) @@ -3052,7 +3221,7 @@ SHLIBEXT=so # Extract the first word of "xmkmf", so it can be a program name with args. set dummy xmkmf; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:3056: checking for $ac_word" >&5 +echo "configure:3225: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_prog_XMKMF'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else @@ -3079,7 +3248,7 @@ fi if test -n "${XMKMF}"; then echo $ac_n "checking how to make shared libraries""... $ac_c" 1>&6 -echo "configure:3083: checking how to make shared libraries" >&5 +echo "configure:3252: checking how to make shared libraries" >&5 # mv ${srcdir}/Makefile ${srcdir}/Makefile-SAFE echo > Imakefile xmkmf > /dev/null @@ -3175,7 +3344,7 @@ esac # Uses ac_ vars as temps to allow command line to override cache and checks. # --without-x overrides everything else, but does not touch the cache. echo $ac_n "checking for X""... $ac_c" 1>&6 -echo "configure:3179: checking for X" >&5 +echo "configure:3348: checking for X" >&5 # Check whether --with-x or --without-x was given. if test "${with_x+set}" = set; then @@ -3237,12 +3406,12 @@ if test "$ac_x_includes" = NO; then # First, try using that file with no special directory specified. cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:3246: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:3415: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -3311,14 +3480,14 @@ if test "$ac_x_libraries" = NO; then ac_save_LIBS="$LIBS" LIBS="-l$x_direct_test_library $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3491: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* LIBS="$ac_save_LIBS" # We can link X programs with no special library path. @@ -3424,17 +3593,17 @@ else case "`(uname -sr) 2>/dev/null`" in "SunOS 5"*) echo $ac_n "checking whether -R must be followed by a space""... $ac_c" 1>&6 -echo "configure:3428: checking whether -R must be followed by a space" >&5 +echo "configure:3597: checking whether -R must be followed by a space" >&5 ac_xsave_LIBS="$LIBS"; LIBS="$LIBS -R$x_libraries" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3607: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_nospace=yes else @@ -3450,14 +3619,14 @@ rm -f conftest* else LIBS="$ac_xsave_LIBS -R $x_libraries" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3630: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_space=yes else @@ -3489,7 +3658,7 @@ rm -f conftest* # libraries were built with DECnet support. And karl@cs.umb.edu says # the Alpha needs dnet_stub (dnet does not exist). echo $ac_n "checking for dnet_ntoa in -ldnet""... $ac_c" 1>&6 -echo "configure:3493: checking for dnet_ntoa in -ldnet" >&5 +echo "configure:3662: checking for dnet_ntoa in -ldnet" >&5 ac_lib_var=`echo dnet'_'dnet_ntoa | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -3497,7 +3666,7 @@ else ac_save_LIBS="$LIBS" LIBS="-ldnet $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3681: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3530,7 +3699,7 @@ fi if test $ac_cv_lib_dnet_dnet_ntoa = no; then echo $ac_n "checking for dnet_ntoa in -ldnet_stub""... $ac_c" 1>&6 -echo "configure:3534: checking for dnet_ntoa in -ldnet_stub" >&5 +echo "configure:3703: checking for dnet_ntoa in -ldnet_stub" >&5 ac_lib_var=`echo dnet_stub'_'dnet_ntoa | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -3538,7 +3707,7 @@ else ac_save_LIBS="$LIBS" LIBS="-ldnet_stub $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3722: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3578,12 +3747,12 @@ fi # The nsl library prevents programs from opening the X display # on Irix 5.2, according to dickey@clark.net. echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6 -echo "configure:3582: checking for gethostbyname" >&5 +echo "configure:3751: checking for gethostbyname" >&5 if eval "test \"`echo '$''{'ac_cv_func_gethostbyname'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3779: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_gethostbyname=yes" else @@ -3627,7 +3796,7 @@ fi if test $ac_cv_func_gethostbyname = no; then echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6 -echo "configure:3631: checking for gethostbyname in -lnsl" >&5 +echo "configure:3800: checking for gethostbyname in -lnsl" >&5 ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -3635,7 +3804,7 @@ else ac_save_LIBS="$LIBS" LIBS="-lnsl $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3819: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3676,12 +3845,12 @@ fi # -lsocket must be given before -lnsl if both are needed. # We assume that if connect needs -lnsl, so does gethostbyname. echo $ac_n "checking for connect""... $ac_c" 1>&6 -echo "configure:3680: checking for connect" >&5 +echo "configure:3849: checking for connect" >&5 if eval "test \"`echo '$''{'ac_cv_func_connect'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3877: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_connect=yes" else @@ -3725,7 +3894,7 @@ fi if test $ac_cv_func_connect = no; then echo $ac_n "checking for connect in -lsocket""... $ac_c" 1>&6 -echo "configure:3729: checking for connect in -lsocket" >&5 +echo "configure:3898: checking for connect in -lsocket" >&5 ac_lib_var=`echo socket'_'connect | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -3733,7 +3902,7 @@ else ac_save_LIBS="$LIBS" LIBS="-lsocket $X_EXTRA_LIBS $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3917: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3768,12 +3937,12 @@ fi # gomez@mi.uni-erlangen.de says -lposix is necessary on A/UX. echo $ac_n "checking for remove""... $ac_c" 1>&6 -echo "configure:3772: checking for remove" >&5 +echo "configure:3941: checking for remove" >&5 if eval "test \"`echo '$''{'ac_cv_func_remove'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3969: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_remove=yes" else @@ -3817,7 +3986,7 @@ fi if test $ac_cv_func_remove = no; then echo $ac_n "checking for remove in -lposix""... $ac_c" 1>&6 -echo "configure:3821: checking for remove in -lposix" >&5 +echo "configure:3990: checking for remove in -lposix" >&5 ac_lib_var=`echo posix'_'remove | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -3825,7 +3994,7 @@ else ac_save_LIBS="$LIBS" LIBS="-lposix $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4009: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3860,12 +4029,12 @@ fi # BSDI BSD/OS 2.1 needs -lipc for XOpenDisplay. echo $ac_n "checking for shmat""... $ac_c" 1>&6 -echo "configure:3864: checking for shmat" >&5 +echo "configure:4033: checking for shmat" >&5 if eval "test \"`echo '$''{'ac_cv_func_shmat'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4061: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_shmat=yes" else @@ -3909,7 +4078,7 @@ fi if test $ac_cv_func_shmat = no; then echo $ac_n "checking for shmat in -lipc""... $ac_c" 1>&6 -echo "configure:3913: checking for shmat in -lipc" >&5 +echo "configure:4082: checking for shmat in -lipc" >&5 ac_lib_var=`echo ipc'_'shmat | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -3917,7 +4086,7 @@ else ac_save_LIBS="$LIBS" LIBS="-lipc $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4101: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3961,7 +4130,7 @@ fi # libraries we check for below, so use a different variable. # --interran@uluru.Stanford.EDU, kb@cs.umb.edu. echo $ac_n "checking for IceConnectionNumber in -lICE""... $ac_c" 1>&6 -echo "configure:3965: checking for IceConnectionNumber in -lICE" >&5 +echo "configure:4134: checking for IceConnectionNumber in -lICE" >&5 ac_lib_var=`echo ICE'_'IceConnectionNumber | sed 'y%./+-%__p_%'` if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 @@ -3969,7 +4138,7 @@ else ac_save_LIBS="$LIBS" LIBS="-lICE $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4153: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4021,7 +4190,7 @@ do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:4025: checking for $ac_word" >&5 +echo "configure:4194: checking for $ac_word" >&5 if eval "test \"`echo '$''{'ac_cv_prog_R_PRINTCMD'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else diff --git a/configure.in b/configure.in index df0461bff04..4c92c8eb362 100644 --- a/configure.in +++ b/configure.in @@ -94,6 +94,14 @@ AC_ARG_WITH(f77, ## Here we should maybe check that only one of the above options for ## dealing with FORTRAN were specified. +AC_ARG_ENABLE(libmoto, + [ --enable-libmoto use libmoto math library (if available)], + [ if test "${enableval}"=no; + then use_libmoto=false; + else use_libmoto=true; + fi], + use_libmoto=true) + AC_ARG_ENABLE(blas, [ --enable-blas use BLAS library (if available)], [if test "${enableval}" = no; @@ -102,6 +110,14 @@ AC_ARG_ENABLE(blas, fi], use_blas=true) +AC_ARG_ENABLE(blas_risc, + [ --enable-blas_risc use RISC Optimized BLAS library (if available)], + [ if test "${enableval}" = no; + then use_blas_risc=false; + else use_blas_risc=true; + fi], + use_blas_risc=true) + AC_ARG_ENABLE(dxml, [ --enable-dxml use DXML library (if available)], [if test "${enableval}" = no; @@ -127,6 +143,11 @@ case ${INSTALL} in *install-sh*) INSTALL="\$\(top_srcdir\)/${INSTALL}" ;; esac +## Osman says that this is necessary. +case ${host} in + *hpux*) + INSTALL="\$\(top_srcdir\)/${INSTALL}" ;; +esac AC_PROG_LN_S AC_PROG_RANLIB @@ -396,6 +417,9 @@ done export LD_LIBRARY_PATH AC_CHECK_LIB(m, sin) +if ${use_libmoto}; then + AC_CHECK_LIB(moto, sin) +fi AC_CHECK_LIB(ncurses, main,, AC_CHECK_LIB(termcap, main,, AC_CHECK_LIB(termlib, main) @@ -407,11 +431,16 @@ AC_CHECK_LIB(z, main) BLAS="blas.o" if ${use_dxml}; then - AC_CHECK_LIB(dxml, main, FLIBS="-ldxml ${FLIBS}" BLAS="", - if ${use_blas}; then - AC_CHECK_LIB(blas, main, FLIBS="-lblas ${FLIBS}" BLAS="") - fi - ) + AC_CHECK_LIB(dxml, main, FLIBS="-ldxml ${FLIBS}" BLAS="") +fi +if test -n "${BLAS}" && ${use_blas}; then + AC_CHECK_LIB(blas, main, + [ FLIBS="-lblas ${FLIBS}" BLAS="" + if ${use_blas_risc}; then + AC_CHECK_LIB(blas_risc, main, + FLIBS="-lblas_risc ${FLIBS}", ,-lblas -lf2c) + fi + ]) fi AC_SUBST(BLAS) for arg in ${LIBS}; do @@ -446,7 +475,15 @@ AC_TYPE_SIGNAL ### Compiler characteristics. AC_C_CONST - +AC_CHECK_SIZEOF(long, 4) +SIZEOF_LONG=`grep SIZEOF_LONG confdefs.h | sed 's/.* //'` +if test ${SIZEOF_LONG} -lt 4; then + echo "Size of long must be at least 32 bits" + exit 32 +elif test ${SIZEOF_LONG} -eq 4; then + AC_DEFINE(LONG_32_BITS) +fi + ## Check for nasty OSF sprintf bug # AC_MSG_CHECKING(for osf sprintf bug) diff --git a/demos/dynload/README b/demos/dynload/README index be73fb8669f..361c088659c 100644 --- a/demos/dynload/README +++ b/demos/dynload/README @@ -1,8 +1,8 @@ - Run-Time Linking and Call_S +Run-Time Linking and Call_S Here is a small example which shows how to use the dyn.load interface and call_S. It is a modified version of the program given in the first S book on pages 205-211. Run-time linking of object code is one of the least portable aspects -of R. It is set up in a completely ad-hoc way bu autoconfigure. +of R. It is set up in a completely ad-hoc way by autoconfigure. diff --git a/demos/dynload/zero.R b/demos/dynload/zero.R index fe77d347278..0f93c04e25c 100644 --- a/demos/dynload/zero.R +++ b/demos/dynload/zero.R @@ -1,15 +1,15 @@ - # Notes: +## Notes: ## - # 1. Because of the difference in scoping rules between R and S - # it is not necessary (and indeed an error) to assign the function - # in frame 1. The function f.check can see the function f because - # it exists in the environment where f is defined. +## 1. Because of the difference in scoping rules between R and S it is +## not necessary (and indeed an error) to assign the function in +## frame 1. The function f.check can see the function f because it +## exists in the environment where f is defined. ## - # 2. It is also not necessary (although permissible) to wrap a - # "list" around the function f.check in the .C call. R passes - # such functions through to the underlying C code in "undigested" - # form. Corresponding, the underlying C code does not need to - # extract the function from the passed "list". +## 2. It is also not necessary (although permissible) to wrap a "list" +## around the function f.check in the .C call. R passes such +## functions through to the underlying C code in "undigested" form. +## Correspondingly, the underlying C code does not need to extract +## the function from the passed "list". dyn.load("zero.so") ##-- you may need to change this to @@ -17,7 +17,7 @@ dyn.load("zero.so") ##-- substituting the proper path for , ## unless you are executing R from the directory containing zero.so -zero <- function(f, guesses, tol=1e-7) { +zero <- function(f, guesses, tol = 1e-7) { f.check <- function(x) { x <- f(x) if(!is.numeric(x)) stop("Need a numeric result") @@ -25,19 +25,12 @@ zero <- function(f, guesses, tol=1e-7) { } z <- .C("zero_find", f.check, - ans=as.double(guesses), + ans = as.double(guesses), as.double(tol)) z$ans[1] } -cube1 <- function(x) (x^2+1)*(x-1.5) -x0 <- zero(cube1, c(0,5)) +cube1 <- function(x) (x^2 + 1) * (x - 1.5) +x0 <- zero(cube1, c(0, 5)) print(x0) -print(x0,15) - - - - - - - +print(x0, 15) diff --git a/demos/dynload/zero.c b/demos/dynload/zero.c index 5ddbb96ae44..14763703278 100644 --- a/demos/dynload/zero.c +++ b/demos/dynload/zero.c @@ -1,49 +1,53 @@ -#include +#include static void *func; static double zfun(double z) { - void *args[1], *values[1]; - double zz[1], *result; - char *mode[1]; long length[1]; + void *args[1]; + char *mode[1], *values[1]; + long length[1]; + double zz[1], *result; - mode[0] = "double"; length[0] = 1; - args[0] = (void*)(zz); zz[0] = z; - - call_S(func, 1L, args, mode, length, 0L, 1L, values); - - result = (double*)values[0]; - return result[0]; + mode[0] = "double"; length[0] = 1; + args[0] = (void*)(zz); zz[0] = z; + + call_S(func, 1L, args, mode, length, 0L, 1L, values); + + result = (double*)values[0]; + return result[0]; } static double zero_approx(double(*f)(), double x0, double x1, double tol) { - double f0, f1, fc, xc; - f0 = zfun(x0); - f1 = zfun(x1); - if(f0 == 0.0) return x0; - if(f1 == 0.0) return x1; - if(f0*f1 > 0.0) error("x[0] and x[1] have the same sign\n"); - if(tol <= 0.0) error("non-positive tol value\n"); - for(;;) { - xc = 0.5*(x0+x1); - if(fabs(x0-x1) < tol) return xc; - fc = zfun(xc); - if(fc == 0) return xc; - if(f0*fc > 0.0) { - x0 = xc; - f0 = fc; - } - else { - x1 = xc; - f1 = fc; - } + double f0, f1, fc, xc; + f0 = zfun(x0); + f1 = zfun(x1); + if(f0 == 0.0) return x0; + if(f1 == 0.0) return x1; + if(f0*f1 > 0.0) + error("x[0] and x[1] have the same sign\n"); + if(tol <= 0.0) + error("non-positive tol value\n"); + for(;;) { + xc = 0.5*(x0+x1); + if(fabs(x0-x1) < tol) return xc; + fc = zfun(xc); + if(fc == 0) return xc; + if(f0*fc > 0.0) { + x0 = xc; + f0 = fc; + } + else { + x1 = xc; + f1 = fc; } + } } -zero_find(void *f, double *x, double *tol) +void zero_find(void *f, double *x, double *tol) { - func = f; - x[0] = zero_approx(zfun, x[0], x[1], tol[0]); + func = f; + x[0] = zero_approx(zfun, x[0], x[1], tol[0]); + return; } diff --git a/demos/language/recursion.R b/demos/language/recursion.R index 1bd4358a235..87685657211 100644 --- a/demos/language/recursion.R +++ b/demos/language/recursion.R @@ -1,6 +1,6 @@ -#### -*- R -*- - # Adaptive integration: Venables and Ripley pp. 105-110 - # This is the basic integrator. + +## Adaptive integration: Venables and Ripley pp. 105-110 +## This is the basic integrator. area <- function(f, a, b, ..., fa = f(a, ...), fb = f(b, ...), limit = 10, eps = 1.e-5) @@ -23,7 +23,7 @@ area <- function(f, a, b, ..., fa = f(a, ...), fb = f(b, ...), limit } - # The function to be integrated +## The function to be integrated fbeta <- function(x, alpha, beta) { @@ -31,33 +31,33 @@ fbeta <- function(x, alpha, beta) } - # Compute the approximate integral, the exact integral and the error +## Compute the approximate integral, the exact integral and the error b0 <- area(fbeta, 0, 1, alpha=3.5, beta=1.5) b1 <- exp(lgamma(3.5) + lgamma(1.5) - lgamma(5)) c(b0, b1, b0-b1) - # Modify the function so that it records where it was evaluated +## Modify the function so that it records where it was evaluated fbeta.tmp <- function (x, alpha, beta) { - val <- c(val, x) + val <<- c(val, x) x^(alpha - 1) * (1 - x)^(beta - 1) } - # Recompute and plot the evaluation points. +## Recompute and plot the evaluation points. val <- NULL b0 <- area(fbeta.tmp, 0, 1, alpha=3.5, beta=1.5) plot(val, fbeta(val, 3.5, 1.5), pch=0) - # Better programming style -- renaming the function will have no effect. - # The use of "Recall" as in V+R is VERY black magic. You can get the - # same effect transparently by supplying a wrapper function. - # This is the approved Abelson+Sussman method. +## Better programming style -- renaming the function will have no effect. +## The use of "Recall" as in V+R is VERY black magic. You can get the +## same effect transparently by supplying a wrapper function. +## This is the approved Abelson+Sussman method. area <- function(f, a, b, ..., limit=10, eps=1e-5) { area2 <- function(f, a, b, ..., fa = f(a, ...), fb = f(b, ...), diff --git a/demos/language/scoping.R b/demos/language/scoping.R index 1e266ebcfab..f5fda274c72 100644 --- a/demos/language/scoping.R +++ b/demos/language/scoping.R @@ -1,19 +1,19 @@ -###-*- R -*- - # Here is a little example which shows a fundamental difference between - # R and S. It is a little example from Abelson and Sussman which models - # the way in which bank accounts work. It shows how R functions can - # encapsulate state information. + +## Here is a little example which shows a fundamental difference between +## R and S. It is a little example from Abelson and Sussman which models +## the way in which bank accounts work. It shows how R functions can +## encapsulate state information. ## - # When invoked, "open.account" defines and returns three functions - # in a list. Because the variable "total" exists in the environment - # where these functions are defined they have access to its value. - # This is even true when "open.account" has returned. The only way - # to access the value of "total" is through the accessor functions - # withdraw, deposit and balance. Separate accounts maintain their - # own balances. +## When invoked, "open.account" defines and returns three functions +## in a list. Because the variable "total" exists in the environment +## where these functions are defined they have access to its value. +## This is even true when "open.account" has returned. The only way +## to access the value of "total" is through the accessor functions +## withdraw, deposit and balance. Separate accounts maintain their +## own balances. ## - # This is a very nifty way of creating "closures" and a little thought - # will show you that there are many ways of using this in statistics. +## This is a very nifty way of creating "closures" and a little thought +## will show you that there are many ways of using this in statistics. open.account <- function(total) { @@ -21,13 +21,13 @@ open.account <- function(total) { deposit = function(amount) { if(amount <= 0) stop("Deposits must be positive!\n") - total <- total + amount + total <<- total + amount cat(amount,"deposited. Your balance is", total, "\n\n") }, withdraw = function(amount) { if(amount > total) stop("You don't have that much money!\n") - total <- total - amount + total <<- total - amount cat(amount,"withdrawn. Your balance is", total, "\n\n") }, balance = function() { diff --git a/doc/KEYWORDS b/doc/KEYWORDS index b772ad9ac52..f3a35fc81d5 100644 --- a/doc/KEYWORDS +++ b/doc/KEYWORDS @@ -2,72 +2,74 @@ GROUPED Keywords ---------------- Graphics - aplot & Add to Existing Plot / internal plot. - dplot & Computations Related to Plotting - hplot & High-Level Plots - iplot & Interacting with Plots - color & Color, Palettes etc. - dynamic & Dynamic Graphics - device & Graphical Devices 7 + aplot & Add to Existing Plot / internal plot. + dplot & Computations Related to Plotting + hplot & High-Level Plots + iplot & Interacting with Plots + color & Color, Palettes etc. + dynamic & Dynamic Graphics + device & Graphical Devices 7 Basics - sysdata & Basic System Variables [!= S] - datasets & Datasets available by data(.) [!= S] - data & Environments, Scoping, Packages [~= S] - manip & Data Manipulation - attribute & Data Attributes - classes & Data Types (not OO) - & character & Character Data Operations - & complex & Complex Numbers - & category & Categorical Data - & NA & Missing Values [!= S] - list & Lists 11 + sysdata & Basic System Variables [!= S] + datasets & Datasets available by data(.) [!= S] + data & Environments, Scoping, Packages [~= S] + manip & Data Manipulation + attribute & Data Attributes + classes & Data Types (not OO) + & character & Character Data Operations + & complex & Complex Numbers + & category & Categorical Data + & NA & Missing Values [!= S] + list & Lists 11 Mathematics - array & Matrices and Arrays + array & Matrices and Arrays & algebra & Linear Algebra - arith & Basic Arithmetic and Sorting [!= S] - math & Mathematical Calculus etc. [!= S] - logic & Logical Operators - optimize & Optimization 6 + arith & Basic Arithmetic and Sorting [!= S] + math & Mathematical Calculus etc. [!= S] + logic & Logical Operators + optimize & Optimization 6 + symbolmath & "Symbolic Math", as polynomials, fractions + Programming, Input/Ouput, and Miscellaneous - programming & Programming - & interface & Interfaces to Other Languages - iteration & Looping and Iteration - methods & Methods and Generic Functions - print & Printing - file & Input/Output--Files - error & Error Handling 7 + programming & Programming + & interface& Interfaces to Other Languages + iteration & Looping and Iteration + methods & Methods and Generic Functions + print & Printing + file & Input/Output--Files + error & Error Handling 7 - environment & Session Environment - utilities & Utilities - misc & Miscellaneous - documentation & Documentation 4 + environment & Session Environment + utilities & Utilities + misc & Miscellaneous + documentation & Documentation 4 Statistics - distribution & Probability Distributions and Random Numbers - univar & simple univariate statistics [!= S] - htest & Statistical Inference - models & Statistical Models - & regression & Regression - & & nonlinear& Non-linear Regression (only?) - robust & Robust/Resistant Techniques - design & Designed Experiments - multivariate & Multivariate Techniques - ts & Time Series - survival & Survival Analysis 11 + distribution & Probability Distributions and Random Numbers + univar & simple univariate statistics [!= S] + htest & Statistical Inference + models & Statistical Models + & regression& Regression + & &nonlinear& Non-linear Regression (only?) + robust & Robust/Resistant Techniques + design & Designed Experiments + multivariate & Multivariate Techniques + ts & Time Series + survival & Survival Analysis 11 - [actually, `survival4' rather than `survival', - but do we want 'survival5' later ?] + [actually, `survival4' rather than `survival', + but do we want 'survival5' later ?] - nonparametric & Nonparametric Statistics [w/o 'smooth'] - smooth & Curve (and Surface) Smoothing - cluster & Clustering - loess & Loess Objects - tree & Regression and Classification Trees 5 + nonparametric & Nonparametric Statistics [w/o 'smooth'] + smooth & Curve (and Surface) Smoothing + cluster & Clustering + loess & Loess Objects + tree & Regression and Classification Trees 5 ---- 51 diff --git a/doc/manual/Rd.sty b/doc/manual/Rd.sty index 2de8b728513..8dfa81758c8 100644 --- a/doc/manual/Rd.sty +++ b/doc/manual/Rd.sty @@ -137,3 +137,6 @@ \newcommand{\url}[1]{\textsf{#1}} \newcommand{\link}[1]{#1\index{#1}} \newcommand{\email}[1]{$\langle${#1}$\rangle$} + +\InputIfFileExists{Rd.cfg}{% + \typeout{Reading personal defaults ...}}{} diff --git a/doc/manual/Rd2dvi.tex b/doc/manual/Rd2dvi.tex new file mode 100644 index 00000000000..cb4d7bee985 --- /dev/null +++ b/doc/manual/Rd2dvi.tex @@ -0,0 +1,12 @@ +%--- This is used for the ${RHOME}/etc/Rd2dvi command : +\documentclass[a4paper]{book} +\usepackage{Rd2} +\usepackage{makeidx} + +\makeindex + +\begin{document} +\section*{\R\ documentation --- \today} +\input{Rd2} +\printindex +\end{document} diff --git a/doc/manual/writing-Rd.tex b/doc/manual/writing-Rd.tex index f08195f30e6..0c52a4a9fb5 100644 --- a/doc/manual/writing-Rd.tex +++ b/doc/manual/writing-Rd.tex @@ -1,4 +1,3 @@ -\newcommand*{\RHOMEdir}[1]{\file{\$RHOME/#1}} \newcommand{\pkg}[1]{{\textbf{#1}}} \newcommand{\var}[1]{{{\normalfont\textit{#1}}}} \newcommand{\COMMENT}[1]{% @@ -17,33 +16,37 @@ \section{The Documentation Source Tree} The help files containing detailed documentation for (potentially) all -\R{} functions are in the directories \RHOMEdir{src/library/$\ast$/man} -where `$\ast$' stands for \pkg{base} where all the standard functions -are and for ``proper'' libraries such as \pkg{mva} and \pkg{eda}. - -This directory, \RHOMEdir{doc/manual}, contains code for running the -translated help files through \LaTeX{} and further documents pertaining to \R. +\R{} objects are in the \file{src/library/$\ast$/man} subdirectories of +the R source tree, where `$\ast$' stands for \pkg{base} where all the +standard objects are, and for ``proper'' libraries such as \pkg{eda} and +\pkg{mva}. The \file{doc/manual} subdirectory contains code for running +the translated help files through \LaTeX{} and further documents +pertaining to \R. \section{Documentation Format}\label{sec:doc-format} -The help files are written in a form and syntax --- closely resembling -\TeX{} and \LaTeX{} --- which can be processed into a variety of formats, -including \LaTeX, [TN]roff, and \HTML. The translation is carried -out by the \textsc{perl} script \file{Rdconv} in \RHOMEdir{etc/}. - -The basic layout of a raw documentation file is as follows. For a given -function \code{do.this}, use the \R{} command \code{prompt(do.this)} to -produce the file \file{do.this.Rd}. +The help files are written in a form and syntax---closely resembling +\TeX{} and \LaTeX{}---which can be processed into a variety of formats, +including \LaTeX, [TN]roff, and \HTML. The translation is carried out +by the \textsc{perl} script \file{Rdconv} in \file{\$RHOME/bin}. -%%-- Not anymore! (yes ?) -Note that each file should contain at least one -\CMDv{alias}{name} line. +For a given R function \code{myfunction}, use the \R{} command +\code{prompt(myfunction)} to produce the file \file{myfunction.Rd}. The +basic layout of a raw documentation file is as follows (note that each +file should contain at least one \CMDv{alias}{name} line). \begin{quote} \CMDv{name}{myfunction} - \COMMENT{1st argument of old TITLE(. @@ .)} \\ + \COMMENT{\var{myfunction} is the basename of the file.} + + \CMDv{alias}{myfunction} + \COMMENT{Need one \CMDb{alias}{}\ for each topic explained} \\ + \CMDv{alias}{more\_aliases\_1} + \COMMENT{in this help page.} \\ + \CMDv{alias}{more\_aliases\_2} \nlInd + {etc.} + \CMDv{title}{Description} - \COMMENT{2nd argument of old TITLE(. @@ .)} \CMD{usage}\LB \\ \var{myfunction}(\dots) @@ -52,58 +55,53 @@ \section{Documentation Format}\label{sec:doc-format} typewriter font.} \RB - \CMDv{alias}{myfunction} \\ - \CMDv{alias}{more\_aliases\_1} - \COMMENT{Need one \CMDb{alias}{}\ for each topic explained} \\ - \CMDv{alias}{more\_aliases\_2} - \COMMENT{in this help page in addition to \var{myfunction}.} \nlInd - {etc.} - \CMD{arguments}\LB \nlInd - \var{Some optional text \emph{before} the optional list} \nlInd + \var{Some optional text \emph{before} the optional list.} \nlInd \CMDv{item}{arg1}\LB\var{Description of arg1.}\RB \nlInd \CMDv{item}{arg2}\LB\var{Description of arg2.}\RB \nlIInd \textrm{etc.} \nlInd \var{Some optional text \emph{after} the list.} \\ \RB - \CMD{description}\LB\var{A short description of what the function(s) do(es) - \nlInd (\small{one paragraph, a few lines only}).}\RB + \CMD{description}\LB + \EXPLAIN{A short description of what the function(s) do(es) + (one paragraph, a few lines only).}\RB \CMD{details}\LB \EXPLAIN{A detailed if possible precise description of - the functionality provided. Sometimes, precise \CMDb{references}{.} + the functionality provided. Sometimes, precise \CMDb{references}{} can be given instead.}\RB - \CMD{value}\LB\var{A description of the value returned by the function.} - - \Ind If a list with multiple values is returned, you can use \nlInd - \CMDv{item}{comp1}\LB\var{Description of result component `comp1'}\RB - \nlInd - \CMDv{item}{comp2}\LB\var{Description of result component `comp2'}\RB - \nlInd etc.\\ + \CMD{value}\LB\var{A description of the value returned by the + function.} + \EXPLAIN{If a list with multiple values is returned, you can use + \\*[2mm]\strut\quad + \CMDv{item}{comp1}\LB\var{Description of result component `comp1'}\RB + \nlInd + \CMDv{item}{comp2}\LB\var{Description of result component `comp2'}\RB + \\*[2mm] + etc.} \RB \CMD{references}\LB - \EXPLAIN{Section of references to the literature; use \CMDb{url}{.} + \EXPLAIN{Section of references to the literature; use \CMDb{url}{} for web pointers. \ \ Optional as well as all the following sections.} \RB - \CMDv{section}{name}\LB\var{text \dots\dots}\RB - - \Ind and maybe more \CMD{section\LB..\RB} environments + \CMDv{section}{name}\LB\var{text}\RB - \CMDv{note}{Some note you want to have pointed out \dots.} + \Ind and maybe more \CMD{section\LB~\RB} environments - \CMD{author}\LB - \EXPLAIN{Whoever you are (if you are not one of R \& R). Use \CMDb{email}{}{} - without extra delimiters (``\texttt{(.)}'' or ``$<.>$'') or - \CMDb{url}{xxx:..}}\RB + \CMDv{note}{Some note you want to have pointed out.} + + \CMD{author}\LB \EXPLAIN{Who you are. Use \CMDb{email}{}{} without + extra delimiters (`\texttt{(~)}' or `\texttt{<~>}') or + \CMDb{url}{}.}\RB \CMD{seealso}\LB - \EXPLAIN{Pointers to related \R{} functions, using \CMDb{link}{.}, - usually in the form of \CMDb{code}{\CMDb{link}{.}}} + \EXPLAIN{Pointers to related \R{} functions, using \CMDb{link}{}, + usually in the form of \CMDb{code}{\CMDb{link}{}}} \RB \CMD{examples}\LB @@ -113,21 +111,21 @@ \section{Documentation Format}\label{sec:doc-format} \textbf{Use examples which are \emph{directly} executable!} \end{center} Use random number generators (e.g., \code{x <- rnorm(100)}), or a - standard dataset loadable via \code{data(\dots)} (see \code{data()} - for info) to define data!} - - \EXPLAIN{\CMDv{dontrun}{commands that should only be shown, but - not run through \R}.} - - \EXPLAIN{\CMD{testonly}\LB\var{for extra commands \emph{testing} \R{} - functionality. These will be run (by ``\texttt{make check}'') but not - shown in the help outputs}\RB.} - \RB + standard dataset loadable via \code{data(\dots)} (see + \code{data()} for info) to define data! + + \medskip {\CMDv{dontrun}{commands that should only be shown, but + not run through \R}.} + + \medskip {\CMD{testonly}\LB\var{for extra commands \emph{testing} + \R{} functionality. These will be run (by ``\texttt{make + check}'') but not shown in the help outputs}\RB.}} + \RB \CMDv{keyword}{key\_1} \COMMENT{Use at least one keyword out of the list} \\ \CMDv{keyword}{key\_2} - \COMMENT{in \RHOMEdir{doc/KEYWORDS}} + \COMMENT{in \file{\$RHOME/doc/KEYWORDS}} \end{quote} \section{Sectioning} @@ -135,9 +133,8 @@ \section{Sectioning} To begin a new paragraph or leave a blank in an example, just insert an empty line (as in (La)\TeX). To break a line, use \CMD{cr}. -In addition to the predefined sections (such as -\CMDb{description}{..}, \CMDb{value}{..}, etc.), you can -``define'' arbitrary ones by +In addition to the predefined sections (such as \CMDb{description}{}, +\CMDb{value}{}, etc.), you can ``define'' arbitrary ones by \CMDv{section}{section\_title}\LB\ldots\RB. E.g., \begin{quote} \begin{alltt} @@ -146,55 +143,56 @@ \section{Sectioning} \end{quote} Note that the additonal named sections are always inserted at fixed positions in the output (before \CMD{note}, \CMD{seealso} and the -examples), no matter where in the input they appear. +examples), no matter where they appear in the input. \section{Marking Text} The following logical markup commands are available for indicating specific kinds of text. \begin{quote} - \begin{tabular}{ll} - \CMDv{bold}{word} & set \emph{word} in \textbf{bold} font if possible\\ - \CMDv{emph}{word} - & emphasize \emph{word} using \var{italic} font if possible\\ - \CMDv{code}{word} - &to indicate pieces of code, using \texttt{typewriter} font if possible\\ - \CMDv{file}{word} & for file names\\ - \CMDv{email}{word} & for email addresses\\ - \CMDv{url}{word} & for URLs + \begin{tabular}{@{}ll} + \CMDv{bold}{word} & set \emph{word} in \textbf{bold} font if + possible \\ + \CMDv{emph}{word} & emphasize \emph{word} using \var{italic} font if + possible \\ + \CMDv{code}{word} & for pieces of code, using \texttt{typewriter} + font if possible \\ + \CMDv{file}{word} & for file names \\ + \CMDv{email}{word} & for email addresses \\ + \CMDv{url}{word} & for URLs \end{tabular} \end{quote} The first two, \CMD{bold} and \CMD{emph}, should be used in plain text for emphasis. -Fragments of \R{} code, including the names of \R{} objects, should be marked -using \CMD{code}. Only backslashes and percent signs need to be escaped -inside \CMD{code}. +Fragments of \R{} code, including the names of \R{} objects, should be +marked using \CMD{code}. Only backslashes and percent signs need to be +escaped inside \CMD{code}. Finally, \CMDb{link}{foo} (usually in the combination -\CMDb{code}{\CMDb{link}{foo}}) produces a hyperlink to the -help page for function \texttt{foo}. One main usage of \CMD{link} is in -the \CMD{seealso} section of the help page, see~\ref{sec:doc-format}, -above. (Currently, this only affects the creation of the \HTML{} pages -used, e.g., by \code{help.start()}.) +\CMDb{code}{\CMDb{link}{foo}}) produces a hyperlink to the help page for +function \texttt{foo}. One main usage of \CMD{link} is in the +\CMD{seealso} section of the help page, see~\ref{sec:doc-format}, above. +(Currently, this only affects the creation of the \HTML{} pages used, +e.g., by \code{help.start()}.) \section{Mathematics} Mathematical formula are something we want ``perfectly'' for printed -documentation (i.e. for the conversion to \LaTeX{} and PostScript +documentation (i.e., for the conversion to \LaTeX{} and PostScript subsequently) and still want something useful for ASCII and \HTML{} online help. -To this end, the two commands -\CMDv{eqn}{latex}\LB\var{ascii}\RB{} and -\CMDv{deqn}{latex}\LB\var{ascii}\RB{} are used. -Where \CMD{eqn} is used for ``inline'' formula (corresponding to (La)\TeX's +To this end, the two commands \CMDv{eqn}{latex}\LB\var{ascii}\RB{} and +\CMDv{deqn}{latex}\LB\var{ascii}\RB{} are used. Where \CMD{eqn} is used +for ``inline'' formula (corresponding to (La)\TeX's \texttt{\$\ldots\$}), \CMD{deqn} gives ``displayed equations'' ({\`a} la \LaTeX's \texttt{displaymath} environment, or \TeX's \texttt{\$\$\ldots\$\$}). -Both commands can also be used as \CMD{eqn\LB\var{latexascii}\RB} -(only \emph{one} arg.) which then is used for both \var{latex} and \var{ascii}. +Both commands can also be used as \CMD{eqn\LB\var{latexascii}\RB} (only +\emph{one} arg.) which then is used for both \var{latex} and +\var{ascii}. The following example is from the \texttt{Poisson} help page: \begin{quote} @@ -211,43 +209,46 @@ \section{Mathematics} \end{quote} where, for the \HTML{} and the ``direct'' (man-like) on-line help becomes +\begin{quote} \begin{verbatim} - p(x) = lambda^x exp(-lambda)/x! + p(x) = lambda^x exp(-lambda)/x! - for x = 0, 1, 2, .... +for x = 0, 1, 2, .... \end{verbatim} +\end{quote} -For historic reasons mostly, the TeX/LaTeX commands \CMD{alpha}, +For historic reasons mostly, the \TeX/\LaTeX{} commands \CMD{alpha}, \CMD{Alpha}, \CMD{beta}, \CMD{Gamma}, \CMD{epsilon}, \CMD{lambda}, \CMD{mu}, \CMD{pi}, \CMD{sigma}, \CMD{left(} and \CMD{right)} exist. These can be used directly, without using the \CMD{eqn} diversion. \section{Miscellaneous} -Use \CMD{R} for the \R{} system itself (you don't need extra `\{\}' or `\bsl'). -Use \CMD{dots} for the dots in function argument list ``\texttt{...}'', -and \CMD{ldots} for $\ldots$ (ellipsis dots). +Use \CMD{R} for the \R{} system itself (you don't need extra `\verb+{}+' +or `\verb+\+'). Use \CMD{dots} for the dots in function argument list +`\texttt{...}', and \CMD{ldots} for `$\ldots$' (ellipsis dots). -After a \texttt{\%}, you can put your own comments regarding the help +After a `\texttt{\%}', you can put your own comments regarding the help text. This will be completely disregarded, normally. Therefore, you can -also use it to make part of the `help' invisible. +also use it to make part of the ``help'' invisible. \paragraph{Escaping Special Characters.} -You can produce a backslash (`\bsl') by escaping it by another + +You can produce a backslash (`\verb+\+') by escaping it by another backslash. (Note that \CMD{cr} is used for generating line breaks.) -The `comment' and `control' characters `\texttt{\%}' and `\bsl' +The ``comment'' and ``control'' characters `\texttt{\%}' and `\verb+\+' \emph{always} need to be escaped. Inside the verbatim-like commands (\CMD{code} and \CMD{examples}), no other characters are special. -In ``regular'' text (no verbatim, no \CMD{eqn}, \ldots), you currently must -escape all \LaTeX{} special characters, i.e., -besides `\%', `\{', and `\}', the four specials -\ \$, \ \&, \ \# and \ \_ \ are simply produced by preceding with a -`\bsl'. -Further, `` $\hat{}$ '' by \verb|\eqn{\hat{}}{^}|, and - `` $\tilde{}$ '' by \verb|\eqn{\tilde{}}{~}|. -Also \ $<$\ , \ $>$ \ and \ $|$ \ \ must only be used in math mode, i.e. within \CMD{[d]eqn}. +In ``regular'' text (no verbatim, no \CMD{eqn}, \ldots), you currently +must escape all \LaTeX{} special characters, i.e., besides +`\texttt{\%}', `\verb+{+', and `\verb+}+', the four specials +`\texttt{\$}', `\texttt{\&}', `\texttt{\#}', and `\texttt{\_}' are +simply produced by preceding with a `\verb+\+'. Further, `\verb+^+' by +\verb|\eqn{\hat{}}{^}|, and `\verb|~|' by \verb|\eqn{\tilde{}}{~}|. +Also, `\verb|<|', `\verb|>|', and `\verb+|+' must only be used in math +mode, i.e., within \CMD{eqn} or \CMD{deqn}. %%% Local Variables: %%% mode: latex diff --git a/etc/Makeconf.in b/etc/Makeconf.in index 874716f89ca..b76c50053b3 100644 --- a/etc/Makeconf.in +++ b/etc/Makeconf.in @@ -8,12 +8,13 @@ CPICFLAGS = @CPICFLAGS@ CPPFLAGS = -I$(RHOME)/include FC = @FC@ FFLAGS = @FFLAGS@ +FLIBS = @FLIBS@ FPICFLAGS = @FPICFLAGS@ F2C = @F2C@ F2CFLAGS = @F2CFLAGS@ SHLIBEXT = @SHLIBEXT@ SHLIBLD = @SHLIBLD@ -SHLIBLDFLAGS = @SHLIBLDFLAGS@ @FLIBS@ +SHLIBLDFLAGS = @SHLIBLDFLAGS@ .SUFFIXES: .SUFFIXES: .c .f .o @@ -21,3 +22,6 @@ SHLIBLDFLAGS = @SHLIBLDFLAGS@ @FLIBS@ .c.o: $(CC) $(CFLAGS) $(CPICFLAGS) $(CPPFLAGS) -c $< -o $@ @f77_rules_frag_etc@ + +$(SHLIB): $(OBJS) + $(SHLIBLD) $(SHLIBLDFLAGS) -o $@ $(OBJS) $(FLIBS) diff --git a/etc/Rdconvlib.pl b/etc/Rdconvlib.pl index 5bf5b46f68e..c81ff27384d 100644 --- a/etc/Rdconvlib.pl +++ b/etc/Rdconvlib.pl @@ -24,7 +24,7 @@ ## New: \verbatim{}: like \examples{}, but can appear 0-n times [MM]. ## --- =========== -## Original idead: Can have *SEVERAL* verbatim codeblocks which should +## Original idea: Can have *SEVERAL* verbatim codeblocks which should ## appear (almost) WHERE they were initially !! ## BUT, this is not really possible: ## we collect the block into a hash array and don't even remember @@ -127,9 +127,16 @@ sub Rdconv { # Rdconv(foobar.Rd, type, debug, filename) get_blocks($complete_text); - get_sections($complete_text) - if $type =~ /html/i || $type =~ /nroff/i || - $type =~ /Sd/ || $type =~ /tex/i; + if($type =~ /html/i || $type =~ /nroff/i || + $type =~ /Sd/ || $type =~ /tex/i) { + + get_sections($complete_text); + + } elsif($type =~ /example/i ) { + ; + } else { + warn "\n** Rdconv --type '..' : no valid type specified\n"; + } rdoc2html($htmlfile) if $type =~ /html/i; rdoc2nroff($nrofffile) if $type =~ /nroff/i; @@ -783,9 +790,9 @@ sub rdoc2nroff { # (filename); 0 for STDOUT } -# Convert a Rdoc text string to nroff -# $_[0]: text to be converted -# $_[1]: (optional) indentation of paragraphs. default = $INDENT +### Convert a Rdoc text string to nroff +### $_[0]: text to be converted +### $_[1]: (optional) indentation of paragraphs. default = $INDENT sub text2nroff { @@ -799,6 +806,9 @@ sub text2nroff { $text =~ s/^\.|([\n\(])\./$1\\\&./g; + ## TABs are just whitespace + $text =~ s/\t/ /g; + ## tables are pre-processed by the tbl(1) command, so this has to ## be done first $text = nroff_tables($text); @@ -1220,13 +1230,14 @@ sub Sd_print_sections { sub rdoc2ex { # (filename) + local($tit = $blocks{"title"}); + if($_[0]!= -1) { if($_[0]) { open Exout, "> $_[0]"; } else { open Exout, "| cat"; } } - ##--- Here, I should also put everything which belongs to - ##--- ./massage-Examples ---- depending on 'name' !!! + $tit =~ s/\s+/ /g; print Exout "###--- >>> `"; print Exout $blocks{"name"}; - print Exout "' <<<----- "; print Exout $blocks{"title"}; + print Exout "' <<<----- "; print Exout $tit; print Exout "\n\n"; if(@aliases) { foreach (@aliases) { diff --git a/src/Makefile.in b/src/Makefile.in index a0394465106..1d4a0a67f08 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -15,14 +15,15 @@ DISTFILES = Makefile.in SUBDIRS = include appl nmath unix main scripts library -TARGETS = all install install-strip uninstall mostlyclean clean \ - TAGS info dvi dist check R docs - -$(TARGETS):: - @for d in $(SUBDIRS); do (cd $$d && $(MAKE) $@); done +all install install-strip TAGS info dvi dist check R docs:: + @for d in $(SUBDIRS); do \ + (cd $${d} && $(MAKE) $@) || exit 1; \ + done +uninstall mostlyclean clean:: + @for d in $(SUBDIRS); do (cd $${d} && $(MAKE) $@); done distclean: - @for d in $(SUBDIRS); do (cd $$d && $(MAKE) $@); done + @for d in $(SUBDIRS); do (cd $${d} && $(MAKE) $@); done @rm -f Makefile maintainer-clean: distclean diff --git a/src/appl/Makefile.in b/src/appl/Makefile.in index a3b527ded90..9bc5e6da744 100644 --- a/src/appl/Makefile.in +++ b/src/appl/Makefile.in @@ -14,6 +14,13 @@ distdir = $(top_builddir)/$(PACKAGE)-$(VERSION)/$(subdir) DISTFILES = $(shell cd $(srcdir); \ ls COPYRIGHT COPYRIGHT.ftn Makefile.in ROUTINES *.[cfh]) +## All functions/subroutines that are to be called via +## .Fortran +## or .C +## +## should also have an entry in ./ROUTINES in order to be ``pre-dyn.loaded''; +## see ../src/unix/dynload.c. + OBJS = \ approx.o \ bakslv.o \ @@ -46,6 +53,7 @@ OBJS = \ massdist.o \ pretty.o \ pythag.o \ + rowsum.o \ splines.o \ stem.o \ strsignif.o \ diff --git a/src/appl/ROUTINES b/src/appl/ROUTINES index bccaad75cef..0c1a3d08b95 100755 --- a/src/appl/ROUTINES +++ b/src/appl/ROUTINES @@ -25,6 +25,7 @@ F77_SUBROUTINE(dqrsl) F77_SUBROUTINE(dqrxb) F77_SUBROUTINE(dsvdc) F77_SUBROUTINE(dtrsl) +F77_SUBROUTINE(dtrco) C_FUNCTION(fft_factor) C_FUNCTION(fft_work) F77_SUBROUTINE(fdhess) @@ -35,6 +36,7 @@ C_FUNCTION(massdist) F77_SUBROUTINE(optif9) C_FUNCTION(pretty) F77_SUBROUTINE(rg) +C_FUNCTION(rowsum) F77_SUBROUTINE(zeroin) F77_SUBROUTINE(rs) C_FUNCTION(spline_coef) diff --git a/src/appl/bakslv.c b/src/appl/bakslv.c index 3906826d7e1..8d82dd38429 100644 --- a/src/appl/bakslv.c +++ b/src/appl/bakslv.c @@ -37,14 +37,13 @@ void bakslv(double *t, int *ldt, int *n, * or * t' * x = b [ t' := transpose(t) ] - * where t is a triangular matrix of order n. here trans(t) - * denotes the transpose of the matrix t. the subroutine - * handles the multiple right-hand side case. it is really - * just a wrapper for the linpack subroutine dtrsl. + * where t is a triangular matrix of order n. + * The subroutine handles the multiple right-hand side case. + * It is really just a wrapper for the linpack subroutine dtrsl. * on entry - * t double (ldt,n). + * t double (ldt,n'). n' >= n (below) * t[] contains the coefficient matrix of the system * to be solved. only the elements above or below * the diagonal are referenced. @@ -53,7 +52,7 @@ void bakslv(double *t, int *ldt, int *n, * n int; n is the order of the system. n <= min(ldt,ldb) - * b double (ldb,nb) + * b double (ldb,nb'). nb' >= nb (below) * b[] contains the right hand side(s) of the system. * ldb int; ldb is the leading dimension of the array b. diff --git a/src/appl/binning.c b/src/appl/binning.c index 579b19bda49..865ff29d223 100644 --- a/src/appl/binning.c +++ b/src/appl/binning.c @@ -29,25 +29,26 @@ */ void bincode(double *x, int *pn, double *breaks, int *pnb, int *code, - int *include_border, int *naok) + int *right, int *include_border, int *naok) { int i, lo, hi; - int n, nb1, new; + int n, nb1, new, lft; n = *pn; nb1 = *pnb - 1; + lft = !(*right); for(i=0 ; i= 2) { new = (hi+lo)/2; - if(x[i] >= breaks[new]) + if(x[i] > breaks[new] || (lft && x[i] == breaks[new])) lo = new; else hi = new; @@ -58,42 +59,47 @@ void bincode(double *x, int *pn, double *breaks, int *pnb, int *code, error("NA's in .C(\"bincode\",... NAOK=FALSE)\n"); } -void bincode2(double *x, int *pn, double *breaks, int *pnb, int *code, - int *include_border, int *naok) +/* bincount is called by hist(.) [only] + * + * bincount *counts* like bincode2, i.e. half open intervals defined as (a,b] + */ + +void bincount(double *x, int *pn, double *breaks, int *pnb, int *count, + int *right, int *include_border, int *naok) { int i, lo, hi; - int n, nb1, new; + int n, nb1, new, lft; n = *pn; nb1 = *pnb - 1; + lft = !(*right); + + for(i=0; i= 2) { new = (hi+lo)/2; - if(x[i] > breaks[new]) + if(x[i] > breaks[new] || (lft && x[i] == breaks[new])) lo = new; else hi = new; } - code[i] = lo+1; + count[lo] += 1; } } else if (! *naok) - error("NA's in .C(\"bincode\",... NAOK=FALSE)\n"); + error("NA's in .C(\"bincount\",... NAOK=FALSE)\n"); } -/* bincount is called by hist(.) [only] - * - * bincount *counts* like bincode2, i.e. half open intervals defined as (a,b] - */ -void bincount(double *x, int *pn, double *breaks, int *pnb, int *count, +/*-- UNUSED, but still in ./ROUTINES --- eliminate both at once ! */ +void bincode2(double *x, int *pn, double *breaks, int *pnb, int *code, int *include_border, int *naok) { int i, lo, hi; @@ -102,25 +108,25 @@ void bincount(double *x, int *pn, double *breaks, int *pnb, int *count, n = *pn; nb1 = *pnb - 1; - for(i=0; i= 2) { new = (hi+lo)/2; - if(x[i] > breaks[new]) + if(x[i] > breaks[new]) + /* == */ lo = new; else hi = new; } - count[lo] += 1; + code[i] = lo+1; } } else if (! *naok) - error("NA's in .C(\"bincode\",... NAOK=FALSE)\n"); + error("NA's in .C(\"bincode2\",... NAOK=FALSE)\n"); } diff --git a/src/appl/rowsum.c b/src/appl/rowsum.c new file mode 100644 index 00000000000..3013cc81e1c --- /dev/null +++ b/src/appl/rowsum.c @@ -0,0 +1,62 @@ +/* +** SCCS @(#)rowsum.c 4.2 06/30/93 +** +** Add up data along rows +** +** Input +** dim: integer vector, the #rows and #columns of the matrix +** na_x: the value that marks NA's in the X matrix +** x : matrix of data (remember, S uses column major order!) +** group: the group to which each row belongs +** +** Output: +** dd[0]: the number of unique groups found +** x : rows 1 to dd[0] contain the sums. +*/ + +void rowsum(dim, na_x, x, group) +long *dim; +double *na_x; +double *x, + *group; + { + register int i,j, k; + int nrow, + ncol; + int newrow; + int isna; + double tgrp, + sum; + double dummy; + double na; + + nrow = dim[0]; + ncol = dim[1]; + na = *na_x; + + dummy =0; + for (i=0; i dummy) { + tgrp = group[i]; + for (j=0; j +# define MATHLIB_ERROR(fmt,x) { printf(fmt,x); exit(1) } +# define MATHLIB_WARNING(fmt,x) printf(fmt,x) +# define MATHLIB_WARNING2(fmt,x,x2) printf(fmt,x,x2) +# define MATHLIB_WARNING3(fmt,x,x2,x3) printf(fmt,x,x2,x3) +# define MATHLIB_WARNING4(fmt,x,x2,x3,x4) printf(fmt,x,x2,x3,x4) +#endif #define ME_NONE 0 #define ME_DOMAIN 1 @@ -113,16 +131,13 @@ extern double m_tiny; /* Name Hiding to Avoid Clashes with Fortran */ #ifdef HIDE_NAMES -#define d1mach c_d1mach -#define i1mach c_i1mach +# define d1mach c_d1mach +# define i1mach c_i1mach #endif #define rround fround #define prec fprec #define trunc ftrunc -/* NO! fsign(.) has 2 arguments; sign(.) has 1.. - #define sign fsign -*/ /* Machine Characteristics */ @@ -135,13 +150,13 @@ int i1mach_(int*); int imax2(int, int); int imin2(int, int); -double sign(double); double fmax2(double, double); double fmin2(double, double); double fmod(double, double); double fprec(double, double); double fround(double, double); double ftrunc(double); +double sign(double); double fsign(double, double); double fsquare(double); double fcube(double); diff --git a/src/include/Platform.h.in b/src/include/Platform.h.in index 7a4be03c228..042405eb694 100644 --- a/src/include/Platform.h.in +++ b/src/include/Platform.h.in @@ -3,6 +3,10 @@ #define Unix +/* (Long) Integers */ + +#undef LONG_32_BITS + /* Floating Point Arithmetic */ #undef HAVE_MATHERR /* System V */ #undef HAVE_ISNAN /* IEEE Arith indicator */ diff --git a/src/include/README b/src/include/README index 43895035eef..b942be1c8ef 100644 --- a/src/include/README +++ b/src/include/README @@ -45,6 +45,8 @@ ii) Mathlib.h -> Arith.h -> Platform.h + -> Random.h + -> Error.h (_iff_ Mathlib in R) S_compat.h -> S.h -> Platform.h , Error.h , Memory.h diff --git a/src/include/Random.h b/src/include/Random.h new file mode 100644 index 00000000000..c944e3a2cb1 --- /dev/null +++ b/src/include/Random.h @@ -0,0 +1,38 @@ +/* Is basically only used by ../main/random.c & ../nmath/sunif.c + */ +#ifndef RANDOM_H +#define RANDOM_H + +typedef unsigned long Int32;/* how is this done on 64-bit archtictures? */ + +typedef enum { + WICHMANN_HILL, + MARSAGLIA_MULTICARRY, + SUPER_DUPER, + RAND, + MERSENNE_TWISTER, +} RNGtype; + +typedef struct { + RNGtype kind; /* above enum: 0,1,2... */ + char *name; /* print name */ + int is_seeded; /* False(0), True(1) */ + int n_seed; /* length of seed vector */ + Int32 i1_seed; + Int32 *i_seed; +} RNGTAB; +#define i2_seed i_seed[0] +#define i3_seed i_seed[1] + +/* .Random.seed == (RNGkind, i1_seed, i_seed[0],i_seed[1],..,i_seed[n_seed-2]) + * i2_seed i3_seed + */ +void MaybeAllocSeeds(RNGtype); +void Randomize(RNGtype); +void FixupSeeds(RNGtype); +void RNG_Init(RNGtype kind, long seed); + +extern RNGTAB RNG_Table[]; +extern RNGtype RNG_kind; + +#endif diff --git a/src/include/Utils.h b/src/include/Utils.h index a3dd678853e..ec89155c49f 100644 --- a/src/include/Utils.h +++ b/src/include/Utils.h @@ -26,10 +26,11 @@ #include "Complex.h" void isort(int*, int); -void rsort(double *, int); +void rsort(double*, int); void csort(complex*, int); -void iFind(int *, int, int); -void rFind(double *, int, int); +void revsort(double*, int*, int);/* reverse; sort i[] alongside */ +void iFind(int*, int, int); +void rFind(double*, int, int); void cFind(complex*, int, int); int IndexWidth(int); diff --git a/src/library/Makefile.in b/src/library/Makefile.in index 11c309a7069..6b245dacfdb 100644 --- a/src/library/Makefile.in +++ b/src/library/Makefile.in @@ -26,7 +26,7 @@ Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status R: @$(MKINSTALLDIRS) $(top_builddir)/library @for pkg in $(PKGS) profile; do \ - (cd $${pkg} && $(MAKE)); \ + (cd $${pkg} && $(MAKE)) || exit 1; \ done docs: stamp-docs diff --git a/src/library/base/R/C.R b/src/library/base/R/C.R index 3f9cec47070..133dbfebb38 100644 --- a/src/library/base/R/C.R +++ b/src/library/base/R/C.R @@ -1,26 +1,26 @@ #### copyright (C) 1998 B. D. Ripley C <- function(object, contr, how.many) { - if(!nlevels(object)) stop("object not interpretable as a factor") - if(!missing(contr) && is.name(Xcontr <- substitute(contr))) - contr <- switch(as.character(Xcontr), - poly = "contr.poly", - helmert = "contr.helmert", - sum = "contr.sum", - treatment = "contr.treatment", - contr - ) - if(missing(contr)) { - oc <- options("contrasts")$contrasts - if(length(oc) < 2) # should not happen - contr <- if(is.ordered(object)) contr.poly else contr.treatment - else contr <- oc[1 + is.ordered(object)] - } - if(missing(how.many)) contrasts(object) <- contr - else { - if(is.character(contr)) contr <- get(contr, mode = "function") - if(is.function(contr)) contr <- contr(nlevels(object)) - contrasts(object, how.many) <- contr - } - object + if(!nlevels(object)) stop("object not interpretable as a factor") + if(!missing(contr) && is.name(Xcontr <- substitute(contr))) + contr <- switch(as.character(Xcontr), + poly = "contr.poly", + helmert = "contr.helmert", + sum = "contr.sum", + treatment = "contr.treatment", + contr + ) + if(missing(contr)) { + oc <- options("contrasts")$contrasts + if(length(oc) < 2) # should not happen + contr <- if(is.ordered(object)) contr.poly else contr.treatment + else contr <- oc[1 + is.ordered(object)] + } + if(missing(how.many)) contrasts(object) <- contr + else { + if(is.character(contr)) contr <- get(contr, mode = "function") + if(is.function(contr)) contr <- contr(nlevels(object)) + contrasts(object, how.many) <- contr + } + object } diff --git a/src/library/base/R/RNG.R b/src/library/base/R/RNG.R new file mode 100644 index 00000000000..04f85fcc5d8 --- /dev/null +++ b/src/library/base/R/RNG.R @@ -0,0 +1,23 @@ +## Random Number Generator[s] + +## The available kinds are in +## ../../../include/Random.h and ../../../nmath/sunif.c [RNG_Table] +RNGkind <- function(kind = NULL) +{ + kinds <- c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper", + ## NOT yet: "Mersenne-Twister", + ##BUG "Rand" + ) + do.set <- length(kind) > 0 + if(do.set) { + if(!is.character(kind) || length(kind) > 1) + stop("'kind' must be a character of length 1 (RNG to be used).") + if(is.na(i.knd <- pmatch(kind, kinds) - 1)) + stop(paste("'",kind,"' is not a valid abbrevation of an RNG", + sep="")) + } else i.knd <- NULL + + r <- kinds[1 + .Internal(RNGkind(i.knd))] + if(do.set) invisible(r) else r +} + diff --git a/src/library/base/R/add.R b/src/library/base/R/add.R index 234edd8e43f..196c9bb4257 100644 --- a/src/library/base/R/add.R +++ b/src/library/base/R/add.R @@ -1,657 +1,658 @@ #### copyright (C) 1998 B. D. Ripley add1 <- function(object, ...) UseMethod("add1") -add1.default <- - function(object, scope, scale = 0, test=c("none", "Chisq"), - k = 2, trace = FALSE, ...) +add1.default <- function(object, scope, scale = 0, test=c("none", "Chisq"), + k = 2, trace = FALSE, ...) { - if(missing(scope) || is.null(scope)) stop("no terms in scope") - if(!is.character(scope)) - scope <- add.scope(object, update.formula(object, scope)) - if(!length(scope)) - stop("no terms in scope for adding to object") - ns <- length(scope) - ans <- matrix(nrow = ns + 1, ncol = 2) - dimnames(ans) <- list(c("", scope), c("df", "AIC")) - ans[1, ] <- extractAIC(object, scale, k = k, ...) - for(i in seq(ns)) { - tt <- scope[i] - if(trace > 1) cat("trying +", tt, "\n") - nfit <- update(object, as.formula(paste("~ . +", tt))) - ans[i+1, ] <- extractAIC(nfit, scale, k = k, ...) - } - dfs <- ans[,1] - ans[1,1] - dfs[1] <- NA - aod <- data.frame(Df = dfs, AIC = ans[,2]) - test <- match.arg(test) - if(test == "Chisq") { - dev <- ans[,2] - k*ans[, 1] - dev <- dev[1] - dev; dev[1] <- NA - nas <- !is.na(dev) - P <- dev - P[nas] <- 1 - pchisq(dev[nas], dfs[nas]) - aod[, c("LRT", "Pr(Chi)")] <- list(dev, P) - } - head <- c("Single term additions", "\nModel:", - deparse(as.vector(formula(object)))) - if(scale > 0) - head <- c(head, paste("\nscale: ", format(scale), "\n")) - class(aod) <- c("anova", "data.frame") - attr(aod, "heading") <- head - aod + if(missing(scope) || is.null(scope)) stop("no terms in scope") + if(!is.character(scope)) + scope <- add.scope(object, update.formula(object, scope)) + if(!length(scope)) + stop("no terms in scope for adding to object") + ns <- length(scope) + ans <- matrix(nrow = ns + 1, ncol = 2) + dimnames(ans) <- list(c("", scope), c("df", "AIC")) + ans[1, ] <- extractAIC(object, scale, k = k, ...) + for(i in seq(ns)) { + tt <- scope[i] + if(trace > 1) cat("trying +", tt, "\n") + nfit <- update(object, as.formula(paste("~ . +", tt))) + ans[i+1, ] <- extractAIC(nfit, scale, k = k, ...) + } + dfs <- ans[,1] - ans[1,1] + dfs[1] <- NA + aod <- data.frame(Df = dfs, AIC = ans[,2]) + test <- match.arg(test) + if(test == "Chisq") { + dev <- ans[,2] - k*ans[, 1] + dev <- dev[1] - dev; dev[1] <- NA + nas <- !is.na(dev) + P <- dev + P[nas] <- 1 - pchisq(dev[nas], dfs[nas]) + aod[, c("LRT", "Pr(Chi)")] <- list(dev, P) + } + head <- c("Single term additions", "\nModel:", + deparse(as.vector(formula(object))), + if(scale > 0) paste("\nscale: ", format(scale), "\n")) + class(aod) <- c("anova", "data.frame") + attr(aod, "heading") <- head + aod } -add1.lm <- - function(object, scope, scale = 0, test=c("none", "Chisq", "F"), - x = NULL, k = 2,...) +add1.lm <- function(object, scope, scale = 0, test=c("none", "Chisq", "F"), + x = NULL, k = 2,...) { - Fstat <- function(table, RSS, rdf) { - dev <- table$"Sum of Sq" - df <- table$Df - rms <- (RSS - dev)/(rdf - df) - Fs <- (dev/df)/rms - Fs[df < .Machine$double.eps] <- NA - P <- Fs - nnas <- !is.na(Fs) - P[nnas] <- 1 - pf(Fs[nnas], df[nnas], rdf - df[nnas]) - list(Fs, P) - } + Fstat <- function(table, RSS, rdf) { + dev <- table$"Sum of Sq" + df <- table$Df + rms <- (RSS - dev)/(rdf - df) + Fs <- (dev/df)/rms + Fs[df < .Machine$double.eps] <- NA + P <- Fs + nnas <- !is.na(Fs) + P[nnas] <- 1 - pf(Fs[nnas], df[nnas], rdf - df[nnas]) + list(Fs=Fs, P=P) + } - if(missing(scope) || is.null(scope)) stop("no terms in scope") - if(!is.character(scope)) - scope <- add.scope(object, update.formula(object, scope)) - if(!length(scope)) - stop("no terms in scope for adding to object") - oTerms <- attr(object$terms, "term.labels") - int <- attr(object$terms, "intercept") - ns <- length(scope) - y <- object$residuals + predict(object) - dfs <- numeric(ns+1) - RSS <- numeric(ns+1) - names(dfs) <- names(RSS) <- c("", scope) - dfs[1] <- object$rank - RSS[1] <- deviance.lm(object) - add.rhs <- paste(scope, collapse = "+") - add.rhs <- eval(parse(text = paste("~ . +", add.rhs))) - new.form <- update.formula(object, add.rhs) - Terms <- terms(new.form) - if(is.null(x)) { - fc <- object$call - fc$formula <- Terms - fob <- list(call = fc) - class(fob) <- class(object) - m <- model.frame(fob, xlev = object$xlevels) - x <- model.matrix(Terms, m, contrasts = object$contrasts) - } - n <- nrow(x) - Terms <- attr(Terms, "term.labels") - asgn <- attr(x, "assign") - ousex <- match(asgn, match(oTerms, Terms), 0) > 0 - if(int) ousex[1] <- TRUE - iswt <- !is.null(wt <- object$weights) - for(tt in scope) { - usex <- match(asgn, match(tt, Terms), 0) > 0 - X <- x[, usex|ousex, drop = FALSE] - z <- if(iswt) lm.wfit(X, y, wt) else lm.fit(X, y) - dfs[tt] <- z$rank - RSS[tt] <- deviance.lm(z) - } - if(scale > 0) aic <- RSS/scale - n + k*dfs - else aic <- n * log(RSS/n) + k*dfs - dfs <- dfs - dfs[1] - dfs[1] <- NA - aod <- data.frame(Df = dfs, "Sum of Sq" = c(NA, RSS[1] - RSS[-1]), - RSS = RSS, AIC = aic, row.names = names(dfs), - check.names = FALSE) - if(scale > 0) names(aod) <- c("Df", "Sum of Sq", "RSS", "Cp") - test <- match.arg(test) - if(test == "Chisq") { - dev <- aod$"Sum of Sq" - nas <- !is.na(dev) - dev[nas] <- 1 - pchisq(dev[nas]/scale, aod$Df[nas]) - aod[, "Pr(Chi)"] <- dev - } else if(test == "F") { - rdf <- object$df.resid - aod[, c("F Value", "Pr(F)")] <- Fstat(aod, aod$RSS[1], rdf) - } - head <- c("Single term additions", "\nModel:", - deparse(as.vector(formula(object)))) - if(scale > 0) - head <- c(head, paste("\nscale: ", format(scale), "\n")) - class(aod) <- c("anova", "data.frame") - attr(aod, "heading") <- head - aod + if(missing(scope) || is.null(scope)) stop("no terms in scope") + if(!is.character(scope)) + scope <- add.scope(object, update.formula(object, scope)) + if(!length(scope)) + stop("no terms in scope for adding to object") + oTerms <- attr(object$terms, "term.labels") + int <- attr(object$terms, "intercept") + ns <- length(scope) + y <- object$residuals + predict(object) + dfs <- numeric(ns+1) + RSS <- numeric(ns+1) + names(dfs) <- names(RSS) <- c("", scope) + dfs[1] <- object$rank + RSS[1] <- deviance.lm(object) + add.rhs <- paste(scope, collapse = "+") + add.rhs <- eval(parse(text = paste("~ . +", add.rhs))) + new.form <- update.formula(object, add.rhs) + Terms <- terms(new.form) + if(is.null(x)) { + fc <- object$call + fc$formula <- Terms + fob <- list(call = fc) + class(fob) <- class(object) + m <- model.frame(fob, xlev = object$xlevels) + x <- model.matrix(Terms, m, contrasts = object$contrasts) + } + n <- nrow(x) + Terms <- attr(Terms, "term.labels") + asgn <- attr(x, "assign") + ousex <- match(asgn, match(oTerms, Terms), 0) > 0 + if(int) ousex[1] <- TRUE + iswt <- !is.null(wt <- object$weights) + for(tt in scope) { + usex <- match(asgn, match(tt, Terms), 0) > 0 + X <- x[, usex|ousex, drop = FALSE] + z <- if(iswt) lm.wfit(X, y, wt) else lm.fit(X, y) + dfs[tt] <- z$rank + RSS[tt] <- deviance.lm(z) + } + if(scale > 0) aic <- RSS/scale - n + k*dfs + else aic <- n * log(RSS/n) + k*dfs + dfs <- dfs - dfs[1] + dfs[1] <- NA + aod <- data.frame(Df = dfs, "Sum of Sq" = c(NA, RSS[1] - RSS[-1]), + RSS = RSS, AIC = aic, + row.names = names(dfs), check.names = FALSE) + if(scale > 0) names(aod) <- c("Df", "Sum of Sq", "RSS", "Cp") + test <- match.arg(test) + if(test == "Chisq") { + dev <- aod$"Sum of Sq" + nas <- !is.na(dev) + dev[nas] <- 1 - pchisq(dev[nas]/scale, aod$Df[nas]) + aod[, "Pr(Chi)"] <- dev + } else if(test == "F") { + rdf <- object$df.resid + aod[, c("F value", "Pr(F)")] <- Fstat(aod, aod$RSS[1], rdf) + } + head <- c("Single term additions", "\nModel:", + deparse(as.vector(formula(object))), + if(scale > 0) paste("\nscale: ", format(scale), "\n")) + class(aod) <- c("anova", "data.frame") + attr(aod, "heading") <- head + aod } -add1.glm <- - function(object, scope, scale = 0, test=c("none", "Chisq"), - x = NULL, k = 2, ...) +add1.glm <- function(object, scope, scale = 0, test=c("none", "Chisq"), + x = NULL, k = 2, ...) { - if(!is.character(scope)) - scope <- add.scope(object, update.formula(object, scope)) - if(!length(scope)) - stop("no terms in scope for adding to object") - oTerms <- attr(object$terms, "term.labels") - int <- attr(object$terms, "intercept") - ns <- length(scope) - dfs <- dev <- numeric(ns+1) - names(dfs) <- names(dev) <- c("", scope) - dfs[1] <- object$rank - dev[1] <- object$deviance - add.rhs <- paste(scope, collapse = "+") - add.rhs <- eval(parse(text = paste("~ . +", add.rhs))) - new.form <- update.formula(object, add.rhs) - Terms <- terms(new.form) - if(is.null(x)) { - fc <- object$call - fc$formula <- Terms - fob <- list(call = fc) - class(fob) <- class(object) - m <- model.frame(fob, xlev = object$xlevels) - x <- model.matrix(Terms, m, contrasts = object$contrasts) - } - n <- nrow(x) - y <- object$y - if(is.null(y)) y <- model.response(model.frame(object), "numeric") - wt <- model.weights(model.frame(object)) - if(is.null(wt)) wt <- rep(1, n) - Terms <- attr(Terms, "term.labels") - asgn <- attr(x, "assign") - ousex <- match(asgn, match(oTerms, Terms), 0) > 0 - if(int) ousex[1] <- TRUE - for(tt in scope) { - usex <- match(asgn, match(tt, Terms), 0) > 0 - X <- x[, usex|ousex, drop = FALSE] - z <- glm.fit(X, y, wt, offset=object$offset, - family=object$family, control=object$control) - dfs[tt] <- z$rank - dev[tt] <- z$deviance - } - if (is.null(scale) || scale == 0) - dispersion <- summary(object, dispersion = NULL)$dispersion - else dispersion <- scale - if(object$family$family == "gaussian") { - if(scale > 0) loglik <- dev/scale - n - else loglik <- n * log(dev/n) - } else loglik <- dev/dispersion - aic <- loglik + k * dfs - dfs <- dfs - dfs[1] - dfs[1] <- NA - aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic, - row.names = names(dfs), check.names = FALSE) - test <- match.arg(test) - if(test == "Chisq") { - dev <- loglik[1] - loglik - dev[1] <- NA - aod[, "LRT"] <- dev - nas <- !is.na(dev) - dev[nas] <- 1 - pchisq(dev[nas]/dispersion, aod$Df[nas]) - aod[, "Pr(Chi)"] <- dev - } - head <- c("Single term additions", "\nModel:", - deparse(as.vector(formula(object)))) - if(scale > 0) - head <- c(head, paste("\nscale: ", format(scale), "\n")) - class(aod) <- c("anova", "data.frame") - attr(aod, "heading") <- head - aod + if(!is.character(scope)) + scope <- add.scope(object, update.formula(object, scope)) + if(!length(scope)) + stop("no terms in scope for adding to object") + oTerms <- attr(object$terms, "term.labels") + int <- attr(object$terms, "intercept") + ns <- length(scope) + dfs <- dev <- numeric(ns+1) + names(dfs) <- names(dev) <- c("", scope) + dfs[1] <- object$rank + dev[1] <- object$deviance + add.rhs <- paste(scope, collapse = "+") + add.rhs <- eval(parse(text = paste("~ . +", add.rhs))) + new.form <- update.formula(object, add.rhs) + Terms <- terms(new.form) + if(is.null(x)) { + fc <- object$call + fc$formula <- Terms + fob <- list(call = fc) + class(fob) <- class(object) + m <- model.frame(fob, xlev = object$xlevels) + x <- model.matrix(Terms, m, contrasts = object$contrasts) + } + n <- nrow(x) + y <- object$y + if(is.null(y)) y <- model.response(model.frame(object), "numeric") + wt <- model.weights(model.frame(object)) + if(is.null(wt)) wt <- rep(1, n) + Terms <- attr(Terms, "term.labels") + asgn <- attr(x, "assign") + ousex <- match(asgn, match(oTerms, Terms), 0) > 0 + if(int) ousex[1] <- TRUE + for(tt in scope) { + usex <- match(asgn, match(tt, Terms), 0) > 0 + X <- x[, usex|ousex, drop = FALSE] + z <- glm.fit(X, y, wt, offset=object$offset, + family=object$family, control=object$control) + dfs[tt] <- z$rank + dev[tt] <- z$deviance + } + if (is.null(scale) || scale == 0) + dispersion <- summary(object, dispersion = NULL)$dispersion + else dispersion <- scale + if(object$family$family == "gaussian") { + if(scale > 0) loglik <- dev/scale - n + else loglik <- n * log(dev/n) + } else loglik <- dev/dispersion + aic <- loglik + k * dfs + dfs <- dfs - dfs[1] + dfs[1] <- NA + aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic, + row.names = names(dfs), check.names = FALSE) + test <- match.arg(test) + if(test == "Chisq") { + dev <- loglik[1] - loglik + dev[1] <- NA + aod[, "LRT"] <- dev + nas <- !is.na(dev) + dev[nas] <- 1 - pchisq(dev[nas]/dispersion, aod$Df[nas]) + aod[, "Pr(Chi)"] <- dev + } + head <- c("Single term additions", "\nModel:", + deparse(as.vector(formula(object))), + if(scale > 0) paste("\nscale: ", format(scale), "\n")) + class(aod) <- c("anova", "data.frame") + attr(aod, "heading") <- head + aod } add1.mlm <- function(...) - stop("no add1 method implemented for mlm models") + stop("no add1 method implemented for mlm models") drop1 <- function(object, ...) UseMethod("drop1") -drop1.default <- - function(object, scope, scale = 0, test=c("none", "Chisq"), - k = 2, trace = FALSE, ...) +drop1.default <- function(object, scope, scale = 0, test=c("none", "Chisq"), + k = 2, trace = FALSE, ...) { - tl <- attr(object$terms, "term.labels") - if(missing(scope)) scope <- drop.scope(object) - else { - if(!is.character(scope)) - scope <- attr(terms(update.formula(object, scope)), "term.labels") - if(!all(match(scope, tl, FALSE))) - stop("scope is not a subset of term labels") - } - ns <- length(scope) - ans <- matrix(nrow = ns + 1, ncol = 2) - dimnames(ans) <- list(c("", scope), c("df", "AIC")) - ans[1, ] <- extractAIC(object, scale, k = k, ...) - for(i in seq(ns)) { - tt <- scope[i] - if(trace > 1) cat("trying -", tt, "\n") - nfit <- update(object, as.formula(paste("~ . -", tt))) - ans[i+1, ] <- extractAIC(nfit, scale, k = k, ...) - } - dfs <- ans[1,1] - ans[,1] - dfs[1] <- NA - aod <- data.frame(Df = dfs, AIC = ans[,2]) - head <- c("Single term deletions", "\nModel:", - deparse(as.vector(formula(object)))) - if(test == "Chisq") { - dev <- ans[, 2] - k*ans[, 1] - dev <- dev - dev[1] ; dev[1] <- NA - nas <- !is.na(dev) - P <- dev - P[nas] <- 1 - pchisq(dev[nas], dfs[nas]) - aod[, c("LRT", "Pr(Chi)")] <- list(dev, P) - } - if(scale > 0) - head <- c(head, paste("\nscale: ", format(scale), "\n")) - class(aod) <- c("anova", "data.frame") - attr(aod, "heading") <- head - aod + tl <- attr(object$terms, "term.labels") + if(missing(scope)) scope <- drop.scope(object) + else { + if(!is.character(scope)) + scope <- attr(terms(update.formula(object, scope)), "term.labels") + if(!all(match(scope, tl, FALSE))) + stop("scope is not a subset of term labels") + } + ns <- length(scope) + ans <- matrix(nrow = ns + 1, ncol = 2) + dimnames(ans) <- list(c("", scope), c("df", "AIC")) + ans[1, ] <- extractAIC(object, scale, k = k, ...) + for(i in seq(ns)) { + tt <- scope[i] + if(trace > 1) cat("trying -", tt, "\n") + nfit <- update(object, as.formula(paste("~ . -", tt))) + ans[i+1, ] <- extractAIC(nfit, scale, k = k, ...) + } + dfs <- ans[1,1] - ans[,1] + dfs[1] <- NA + aod <- data.frame(Df = dfs, AIC = ans[,2]) + if(test == "Chisq") { + dev <- ans[, 2] - k*ans[, 1] + dev <- dev - dev[1] ; dev[1] <- NA + nas <- !is.na(dev) + P <- dev + P[nas] <- 1 - pchisq(dev[nas], dfs[nas]) + aod[, c("LRT", "Pr(Chi)")] <- list(dev, P) + } + head <- c("Single term deletions", "\nModel:", + deparse(as.vector(formula(object))), + if(scale > 0) paste("\nscale: ", format(scale), "\n")) + class(aod) <- c("anova", "data.frame") + attr(aod, "heading") <- head + aod } drop1.lm <- function(object, scope, scale = 0, all.cols = TRUE, - test=c("none", "Chisq", "F"), k = 2, ...) + test=c("none", "Chisq", "F"), k = 2, ...) { - setdiff <- function(x, y) - if(length(x) == 0 || length(y) == 0) x else x[match(x, y, 0) == 0] + setdiff <- function(x, y) + if(length(x) == 0 || length(y) == 0) x else x[match(x, y, 0) == 0] - x <- model.matrix(object) - iswt <- !is.null(wt <- object$weights) - n <- nrow(x) - asgn <- attr(x, "assign") - tl <- attr(object$terms, "term.labels") - if(missing(scope)) scope <- drop.scope(object) - else { - if(!is.character(scope)) - scope <- attr(terms(update.formula(object, scope)), "term.labels") - if(!all(match(scope, tl, FALSE))) - stop("scope is not a subset of term labels") - } - ndrop <- match(scope, tl) - ns <- length(scope) - rdf <- object$df.resid - chisq <- deviance.lm(object) - dfs <- numeric(ns) - RSS <- numeric(ns) - y <- object$residuals + predict(object) - rank <- object$rank - for(i in 1:ns) { - ii <- seq(along=asgn)[asgn == ndrop[i]] - if(all.cols) jj <- setdiff(seq(ncol(x)), ii) - else jj <- setdiff(na.coef, ii) - z <- if(iswt) lm.wfit(x[, jj, drop = FALSE], y, wt) - else lm.fit(x[, jj, drop = FALSE], y) - dfs[i] <- z$rank - RSS[i] <- deviance.lm(z) - } - scope <- c("", scope) - dfs <- c(object$rank, dfs) - RSS <- c(chisq, RSS) - if(scale > 0) aic <- RSS/scale - n + k*dfs - else aic <- n * log(RSS/n) + k*dfs - dfs <- dfs[1] - dfs - dfs[1] <- NA - aod <- data.frame(Df = dfs, "Sum of Sq" = c(NA, RSS[-1] - RSS[1]), - RSS = RSS, AIC = aic, row.names = scope, - check.names = FALSE) - if(scale > 0) names(aod) <- c("Df", "Sum of Sq", "RSS", "Cp") - test <- match.arg(test) - if(test == "Chisq") { - dev <- aod$"Sum of Sq" - nas <- !is.na(dev) - dev[nas] <- 1 - pchisq(dev[nas]/scale, aod$Df[nas]) - aod[, "Pr(Chi)"] <- dev - } else if(test == "F") { - dev <- aod$"Sum of Sq" - dfs <- aod$Df + x <- model.matrix(object) + iswt <- !is.null(wt <- object$weights) + n <- nrow(x) + asgn <- attr(x, "assign") + tl <- attr(object$terms, "term.labels") + if(missing(scope)) scope <- drop.scope(object) + else { + if(!is.character(scope)) + scope <- attr(terms(update.formula(object, scope)), "term.labels") + if(!all(match(scope, tl, FALSE))) + stop("scope is not a subset of term labels") + } + ndrop <- match(scope, tl) + ns <- length(scope) rdf <- object$df.resid - rms <- aod$RSS[1]/rdf - Fs <- (dev/dfs)/rms - Fs[dfs < 1e-4] <- NA - P <- Fs - nas <- !is.na(Fs) - P[nas] <- 1 - pf(Fs[nas], dfs[nas], rdf) - aod[, c("F Value", "Pr(F)")] <- list(Fs, P) - } - head <- c("Single term deletions", "\nModel:", - deparse(as.vector(formula(object)))) - if(scale > 0) - head <- c(head, paste("\nscale: ", format(scale), "\n")) - class(aod) <- c("anova", "data.frame") - attr(aod, "heading") <- head - aod + chisq <- deviance.lm(object) + dfs <- numeric(ns) + RSS <- numeric(ns) + y <- object$residuals + predict(object) + rank <- object$rank + for(i in 1:ns) { + ii <- seq(along=asgn)[asgn == ndrop[i]] + if(all.cols) jj <- setdiff(seq(ncol(x)), ii) + else jj <- setdiff(na.coef, ii) + z <- if(iswt) lm.wfit(x[, jj, drop = FALSE], y, wt) + else lm.fit(x[, jj, drop = FALSE], y) + dfs[i] <- z$rank + RSS[i] <- deviance.lm(z) + } + scope <- c("", scope) + dfs <- c(object$rank, dfs) + RSS <- c(chisq, RSS) + if(scale > 0) aic <- RSS/scale - n + k*dfs + else aic <- n * log(RSS/n) + k*dfs + dfs <- dfs[1] - dfs + dfs[1] <- NA + aod <- data.frame(Df = dfs, "Sum of Sq" = c(NA, RSS[-1] - RSS[1]), + RSS = RSS, AIC = aic, + row.names = scope, check.names = FALSE) + if(scale > 0) names(aod) <- c("Df", "Sum of Sq", "RSS", "Cp") + test <- match.arg(test) + if(test == "Chisq") { + dev <- aod$"Sum of Sq" + nas <- !is.na(dev) + dev[nas] <- 1 - pchisq(dev[nas]/scale, aod$Df[nas]) + aod[, "Pr(Chi)"] <- dev + } else if(test == "F") { + dev <- aod$"Sum of Sq" + dfs <- aod$Df + rdf <- object$df.resid + rms <- aod$RSS[1]/rdf + Fs <- (dev/dfs)/rms + Fs[dfs < 1e-4] <- NA + P <- Fs + nas <- !is.na(Fs) + P[nas] <- 1 - pf(Fs[nas], dfs[nas], rdf) + aod[, c("F value", "Pr(F)")] <- list(Fs, P) + } + head <- c("Single term deletions", "\nModel:", + deparse(as.vector(formula(object))), + if(scale > 0) paste("\nscale: ", format(scale), "\n")) + class(aod) <- c("anova", "data.frame") + attr(aod, "heading") <- head + aod } drop1.mlm <- function(object, ...) - stop("drop1 not implemented for mlm models") + stop("drop1 not implemented for mlm models") -drop1.glm <- - function(object, scope, scale = 0, test=c("none", "Chisq"), k = 2, ...) +drop1.glm <- function(object, scope, scale = 0, test=c("none", "Chisq"), + k = 2, ...) { - setdiff <- function(x, y) - if(length(x) == 0 || length(y) == 0) x else x[match(x, y, 0) == 0] + setdiff <- function(x, y) + if(length(x) == 0 || length(y) == 0) x else x[match(x, y, 0) == 0] - x <- model.matrix(object) - iswt <- !is.null(wt <- object$weights) - n <- nrow(x) - asgn <- attr(x, "assign") - tl <- attr(object$terms, "term.labels") - if(missing(scope)) scope <- drop.scope(object) - else { - if(!is.character(scope)) - scope <- attr(terms(update.formula(object, scope)), "term.labels") - if(!all(match(scope, tl, FALSE))) - stop("scope is not a subset of term labels") - } - ndrop <- match(scope, tl) - ns <- length(scope) - rdf <- object$df.resid - chisq <- object$deviance - dfs <- numeric(ns) - dev <- numeric(ns) - y <- object$y - if(is.null(y)) y <- model.response(model.frame(object), "numeric") - na.coef <- (1:length(object$coefficients))[!is.na(object$coefficients)] - wt <- model.weights(model.frame(object)) - if(is.null(wt)) wt <- rep(1, n) - rank <- object$rank - for(i in 1:ns) { - ii <- seq(along=asgn)[asgn == ndrop[i]] - jj <- setdiff(seq(ncol(x)), ii) - z <- glm.fit(x[, jj, drop = FALSE], y, wt, offset=object$offset, - family=object$family, control=object$control) - dfs[i] <- z$rank - dev[i] <- z$deviance - } - scope <- c("", scope) - dfs <- c(object$rank, dfs) - dev <- c(chisq, dev) - if (is.null(scale) || scale == 0) - dispersion <- summary(object, dispersion = NULL)$dispersion - else dispersion <- scale - if(object$family$family == "gaussian") { - if(scale > 0) loglik <- dev/scale - n - else loglik <- n * log(dev/n) - } else loglik <- dev/dispersion - aic <- loglik + k * dfs - dfs <- dfs[1] - dfs - dfs[1] <- NA - aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic, - row.names = scope, check.names = FALSE) - test <- match.arg(test) - if(test == "Chisq") { - dev <- loglik - loglik[1] - dev[1] <- NA - nas <- !is.na(dev) - aod[, "LRT"] <- dev - dev[nas] <- 1 - pchisq(dev[nas]/dispersion, aod$Df[nas]) - aod[, "Pr(Chi)"] <- dev - } - head <- c("Single term deletions", "\nModel:", - deparse(as.vector(formula(object)))) - if(scale > 0) - head <- c(head, paste("\nscale: ", format(scale), "\n")) - class(aod) <- c("anova", "data.frame") - attr(aod, "heading") <- head - aod + x <- model.matrix(object) + iswt <- !is.null(wt <- object$weights) + n <- nrow(x) + asgn <- attr(x, "assign") + tl <- attr(object$terms, "term.labels") + if(missing(scope)) scope <- drop.scope(object) + else { + if(!is.character(scope)) + scope <- attr(terms(update.formula(object, scope)), "term.labels") + if(!all(match(scope, tl, FALSE))) + stop("scope is not a subset of term labels") + } + ndrop <- match(scope, tl) + ns <- length(scope) + rdf <- object$df.resid + chisq <- object$deviance + dfs <- numeric(ns) + dev <- numeric(ns) + y <- object$y + if(is.null(y)) y <- model.response(model.frame(object), "numeric") + na.coef <- (1:length(object$coefficients))[!is.na(object$coefficients)] + wt <- model.weights(model.frame(object)) + if(is.null(wt)) wt <- rep(1, n) + rank <- object$rank + for(i in 1:ns) { + ii <- seq(along=asgn)[asgn == ndrop[i]] + jj <- setdiff(seq(ncol(x)), ii) + z <- glm.fit(x[, jj, drop = FALSE], y, wt, offset=object$offset, + family=object$family, control=object$control) + dfs[i] <- z$rank + dev[i] <- z$deviance + } + scope <- c("", scope) + dfs <- c(object$rank, dfs) + dev <- c(chisq, dev) + if (is.null(scale) || scale == 0) + dispersion <- summary(object, dispersion = NULL)$dispersion + else dispersion <- scale + if(object$family$family == "gaussian") { + if(scale > 0) loglik <- dev/scale - n + else loglik <- n * log(dev/n) + } else loglik <- dev/dispersion + aic <- loglik + k * dfs + dfs <- dfs[1] - dfs + dfs[1] <- NA + aod <- data.frame(Df = dfs, Deviance = dev, AIC = aic, + row.names = scope, check.names = FALSE) + test <- match.arg(test) + if(test == "Chisq") { + dev <- loglik - loglik[1] + dev[1] <- NA + nas <- !is.na(dev) + aod[, "LRT"] <- dev + dev[nas] <- 1 - pchisq(dev[nas]/dispersion, aod$Df[nas]) + aod[, "Pr(Chi)"] <- dev + } + head <- c("Single term deletions", "\nModel:", + deparse(as.vector(formula(object))), + if(scale > 0) paste("\nscale: ", format(scale), "\n")) + class(aod) <- c("anova", "data.frame") + attr(aod, "heading") <- head + aod } add.scope <- function(terms1, terms2) { - terms1 <- terms(as.formula(terms1)) - terms2 <- terms(as.formula(terms2)) - factor.scope(attr(terms1, "factor"), list(add = attr(terms2, "factor")))$add + terms1 <- terms(as.formula(terms1)) + terms2 <- terms(as.formula(terms2)) + factor.scope(attr(terms1, "factor"), + list(add = attr(terms2, "factor")))$add } drop.scope <- function(terms1, terms2) { - terms1 <- terms(as.formula(terms1)) - f2 <- if(missing(terms2)) numeric(0) - else attr(terms(as.formula(terms2)), "factor") - factor.scope(attr(terms1, "factor"), list(drop = f2))$drop + terms1 <- terms(as.formula(terms1)) + f2 <- if(missing(terms2)) numeric(0) + else attr(terms(as.formula(terms2)), "factor") + factor.scope(attr(terms1, "factor"), list(drop = f2))$drop } factor.scope <- function(factor, scope) { - drop <- scope$drop - add <- scope$add + drop <- scope$drop + add <- scope$add - if(length(factor) && !is.null(drop)) {# have base model - nmdrop <- colnames(drop) - facs <- factor - if(length(drop)) { - nmfac <- colnames(factor) - where <- match(nmdrop, nmfac, 0) - if(any(!where)) stop("lower scope is not included in model") - nmdrop <- nmfac[-where] - facs <- factor[, -where, drop = FALSE] - } else nmdrop <- colnames(factor) - if(ncol(facs) > 1) { - # now check no interactions will be left without margins. - keep <- rep(TRUE, ncol(facs)) - f <- crossprod(facs > 0) - for(i in seq(keep)) keep[i] <- max(f[i, - i]) != f[i, i] - nmdrop <- nmdrop[keep] - } - } else nmdrop <- character(0) + if(length(factor) && !is.null(drop)) {# have base model + nmdrop <- colnames(drop) + facs <- factor + if(length(drop)) { + nmfac <- colnames(factor) + where <- match(nmdrop, nmfac, 0) + if(any(!where)) stop("lower scope is not included in model") + nmdrop <- nmfac[-where] + facs <- factor[, -where, drop = FALSE] + } else nmdrop <- colnames(factor) + if(ncol(facs) > 1) { + # now check no interactions will be left without margins. + keep <- rep(TRUE, ncol(facs)) + f <- crossprod(facs > 0) + for(i in seq(keep)) keep[i] <- max(f[i, - i]) != f[i, i] + nmdrop <- nmdrop[keep] + } + } else nmdrop <- character(0) - if(is.null(add)) nmadd <- character(0) - else { - nmfac <- colnames(factor) - nmadd <- colnames(add) - if(!is.null(nmfac)) { - where <- match(nmfac, nmadd, 0) - if(any(!where)) stop("upper scope does not include model") - nmadd <- nmadd[-where] - add <- add[, -where, drop = FALSE] + if(is.null(add)) nmadd <- character(0) + else { + nmfac <- colnames(factor) + nmadd <- colnames(add) + if(!is.null(nmfac)) { + where <- match(nmfac, nmadd, 0) + if(any(!where)) stop("upper scope does not include model") + nmadd <- nmadd[-where] + add <- add[, -where, drop = FALSE] + } + if(ncol(add) > 1) { + # now check marginality: + keep <- rep(TRUE, ncol(add)) + f <- crossprod(add > 0) + for(i in seq(keep)) keep[-i] <- keep[-i] & (f[i, -i] < f[i, i]) + nmadd <- nmadd[keep] + } } - if(ncol(add) > 1) { - # now check marginality: - keep <- rep(TRUE, ncol(add)) - f <- crossprod(add > 0) - for(i in seq(keep)) keep[-i] <- keep[-i] & (f[i, -i] < f[i, i]) - nmadd <- nmadd[keep] - } - } - list(drop = nmdrop, add = nmadd) + list(drop = nmdrop, add = nmadd) } -step <- - function(object, scope, scale = 0, - direction = c("both", "backward", "forward"), - trace = 1, keep = NULL, steps = 1000, k = 2, ...) +step <- function(object, scope, scale = 0, + direction = c("both", "backward", "forward"), + trace = 1, keep = NULL, steps = 1000, k = 2, ...) { - fixFormulaObject <- function(object) { - tmp <- attr(terms(object), "term.labels") - formula(paste(deparse(formula(object)[[2]]), "~", - paste(tmp, collapse=" + "))) - } + fixFormulaObject <- function(object) { + tt <- terms(object) + tmp <- attr(tt, "term.labels") + if (!attr(tt, "intercept")) + tmp <- c(tmp, "0") + if (!length(tmp)) + tmp <- "1" + tmp <- paste(deparse(formula(object)[[2]]), "~", + paste(tmp, collapse = " + ")) + if (length(offset <- attr(tt, "offset"))) + tmp <- paste(tmp, deparse(attr(tt, "variables")[offset + 1]), + sep = " + ") + formula(tmp) + } - cut.string <- function(string) - { - if(length(string) > 1) - string[-1] <- paste("\n", string[-1], sep = "") - string - } - re.arrange <- function(keep) - { - namr <- names(k1 <- keep[[1]]) - namc <- names(keep) - nc <- length(keep) - nr <- length(k1) - array(unlist(keep, recursive = FALSE), c(nr, nc), list(namr, namc)) - } + cut.string <- function(string) + { + if(length(string) > 1) + string[-1] <- paste("\n", string[-1], sep = "") + string + } + re.arrange <- function(keep) + { + namr <- names(k1 <- keep[[1]]) + namc <- names(keep) + nc <- length(keep) + nr <- length(k1) + array(unlist(keep, recursive = FALSE), c(nr, nc), list(namr, namc)) + } - step.results <- function(models, fit, object, usingCp=FALSE) - { - change <- sapply(models, "[[", "change") - rd <- sapply(models, "[[", "deviance") - dd <- c(NA, diff(rd)) - rdf <- sapply(models, "[[", "df.resid") - ddf <- c(NA, diff(rdf)) - AIC <- sapply(models, "[[", "AIC") - heading <- c("Stepwise Model Path \nAnalysis of Deviance Table", - "\nInitial Model:", deparse(as.vector(formula(object))), - "\nFinal Model:", deparse(as.vector(formula(fit))), - "\n") - aod <- - if(usingCp) - data.frame(Step = change, Df = ddf, Deviance = dd, - "Resid. Df" = rdf, "Resid. Dev" = rd, - Cp = AIC, check.names = FALSE) - else data.frame(Step = change, Df = ddf, Deviance = dd, - "Resid. Df" = rdf, "Resid. Dev" = rd, - AIC = AIC, check.names = FALSE) - attr(aod, "heading") <- heading - attr(aod, "class") <- "data.frame" - #attr(aod, "class") <- c("anova", "data.frame") - fit$anova <- aod - fit - } + step.results <- function(models, fit, object, usingCp=FALSE) + { + change <- sapply(models, "[[", "change") + rd <- sapply(models, "[[", "deviance") + dd <- c(NA, diff(rd)) + rdf <- sapply(models, "[[", "df.resid") + ddf <- c(NA, diff(rdf)) + AIC <- sapply(models, "[[", "AIC") + heading <- c("Stepwise Model Path \nAnalysis of Deviance Table", + "\nInitial Model:", deparse(as.vector(formula(object))), + "\nFinal Model:", deparse(as.vector(formula(fit))), + "\n") + aod <- data.frame(Step = I(change), Df = ddf, Deviance = dd, + "Resid. Df" = rdf, "Resid. Dev" = rd, AIC = AIC, + check.names = FALSE) + if(usingCp) { + cn <- colnames(aod); cn[cn == "AIC"] <- "Cp"; colnames(aod) <- cn + } + attr(aod, "heading") <- heading + ##stop gap attr(aod, "class") <- c("anova", "data.frame") + fit$anova <- aod + fit + } - # need to fix up . in formulae in R - object$formula <- fixFormulaObject(object) - Terms <- object$formula - object$call$formula <- object$formula - attributes(Terms) <- attributes(object$terms) - object$terms <- Terms - if(missing(direction)) direction <- "both" - else direction <- match.arg(direction) - backward <- direction == "both" | direction == "backward" - forward <- direction == "both" | direction == "forward" - if(missing(scope)) { - fdrop <- numeric(0) - fadd <- NULL - } else { - if(is.list(scope)) { - fdrop <- if(!is.null(fdrop <- scope$lower)) - attr(terms(update.formula(object, fdrop)), "factors") - else numeric(0) - fadd <- if(!is.null(fadd <- scope$upper)) - attr(terms(update.formula(object, fadd)), "factors") + ## need to fix up . in formulae in R + object$formula <- fixFormulaObject(object) + Terms <- object$formula + object$call$formula <- object$formula + attributes(Terms) <- attributes(object$terms) + object$terms <- Terms + if(missing(direction)) direction <- "both" + else direction <- match.arg(direction) + backward <- direction == "both" | direction == "backward" + forward <- direction == "both" | direction == "forward" + if(missing(scope)) { + fdrop <- numeric(0) + fadd <- NULL } else { - fadd <- if(!is.null(fadd <- scope)) - attr(terms(update.formula(object, scope)), "factors") - fdrop <- numeric(0) + if(is.list(scope)) { + fdrop <- if(!is.null(fdrop <- scope$lower)) + attr(terms(update.formula(object, fdrop)), "factors") + else numeric(0) + fadd <- if(!is.null(fadd <- scope$upper)) + attr(terms(update.formula(object, fadd)), "factors") + } else { + fadd <- if(!is.null(fadd <- scope)) + attr(terms(update.formula(object, scope)), "factors") + fdrop <- numeric(0) + } } - } - if(is.null(fadd)) { - backward <- TRUE - forward <- FALSE - } - models <- vector("list", steps) - if(!is.null(keep)) { - keep.list <- vector("list", steps) - nv <- 1 - } - n <- length(object$residuals) - fit <- object - bAIC <- extractAIC(fit, scale, k = k, ...) - edf <- bAIC[1] - bAIC <- bAIC[2] - nm <- 1 - Terms <- fit$terms - if(trace) - cat("Start: AIC=", format(round(bAIC, 2)), "\n", - cut.string(deparse(as.vector(formula(fit)))), "\n\n") - - models[[nm]] <- list(deviance = deviance(fit), df.resid = n - edf, - change = "", AIC = bAIC) - if(!is.null(keep)) keep.list[[nm]] <- keep(fit, bAIC) - while(steps > 0) { - steps <- steps - 1 - AIC <- bAIC - bfit <- fit - ffac <- attr(Terms, "factors") - scope <- factor.scope(ffac, list(add = fadd, drop = fdrop)) - aod <- NULL - change <- NULL - if(backward && length(scope$drop)) { - aod <- drop1(fit, scope$drop, scale = scale, trace = trace, k = k, ...) - rn <- row.names(aod) - row.names(aod) <- c(rn[1], paste("-", rn[-1], sep=" ")) - # drop all zero df terms first. - if(any(aod$Df == 0, na.rm=TRUE)) { - zdf <- aod$Df == 0 & !is.na(aod$Df) - change <- paste(rownames(aod)[zdf]) - } + if(is.null(fadd)) { + backward <- TRUE + forward <- FALSE } - if(is.null(change)) { - if(forward && length(scope$add)) { - aodf <- add1(fit, scope$add, scale = scale, trace = trace, k = k, ...) - rn <- row.names(aodf) - row.names(aodf) <- c(rn[1], paste("+", rn[-1], sep=" ")) - if(is.null(aod)) aod <- aodf - else aod <- rbind(aod, aodf[-1, , drop = FALSE]) - } - attr(aod, "heading") <- NULL - # need to remove any terms with zero df from consideration - nzdf <- aod$Df != 0 | is.na(aod$Df) - aod <- aod[nzdf, ] - if(is.null(aod) || ncol(aod) == 0) break - nc <- match(c("Cp", "AIC"), names(aod)) - nc <- nc[!is.na(nc)][1] - o <- order(aod[, nc]) - if(trace) print(aod[o, ]) - if(o[1] == 1) break - change <- rownames(aod)[o[1]] + models <- vector("list", steps) + if(!is.null(keep)) { + keep.list <- vector("list", steps) + nv <- 1 } - usingCp <- match("Cp", names(aod), 0) > 0 - fit <- update(fit, paste("~ .", change)) - fit$formula <- fixFormulaObject(fit) - Terms <- fit$formula - attributes(Terms) <- attributes(fit$terms) - fit$terms <- Terms + n <- length(object$residuals) + fit <- object bAIC <- extractAIC(fit, scale, k = k, ...) edf <- bAIC[1] bAIC <- bAIC[2] + nm <- 1 + Terms <- fit$terms if(trace) - cat("\nStep: AIC=", format(round(bAIC, 2)), "\n", - cut.string(deparse(as.vector(formula(fit)))), "\n\n") - if(bAIC >= AIC) break - nm <- nm + 1 - edf <- models[[nm]] <- - list(deviance = deviance(fit), df.resid = n - edf, - change = change, AIC = bAIC) + cat("Start: AIC=", format(round(bAIC, 2)), "\n", + cut.string(deparse(as.vector(formula(fit)))), "\n\n") + + models[[nm]] <- list(deviance = deviance(fit), df.resid = n - edf, + change = "", AIC = bAIC) if(!is.null(keep)) keep.list[[nm]] <- keep(fit, bAIC) - } - if(!is.null(keep)) fit$keep <- re.arrange(keep.list[seq(nm)]) - step.results(models = models[seq(nm)], fit, object, usingCp) + usingCp <- FALSE + while(steps > 0) { + steps <- steps - 1 + AIC <- bAIC + bfit <- fit + ffac <- attr(Terms, "factors") + scope <- factor.scope(ffac, list(add = fadd, drop = fdrop)) + aod <- NULL + change <- NULL + if(backward && length(scope$drop)) { + aod <- drop1(fit, scope$drop, scale = scale, + trace = trace, k = k, ...) + rn <- row.names(aod) + row.names(aod) <- c(rn[1], paste("-", rn[-1], sep=" ")) + ## drop all zero df terms first. + if(any(aod$Df == 0, na.rm=TRUE)) { + zdf <- aod$Df == 0 & !is.na(aod$Df) + change <- paste(rownames(aod)[zdf]) + } + } + if(is.null(change)) { + if(forward && length(scope$add)) { + aodf <- add1(fit, scope$add, scale = scale, + trace = trace, k = k, ...) + rn <- row.names(aodf) + row.names(aodf) <- c(rn[1], paste("+", rn[-1], sep=" ")) + aod <- + if(is.null(aod)) aodf + else rbind(aod, aodf[-1, , drop = FALSE]) + } + attr(aod, "heading") <- NULL + # need to remove any terms with zero df from consideration + nzdf <- if( !is.null(aod$Df) ) + aod$Df != 0 | is.na(aod$Df) + aod <- aod[nzdf, ] + if(is.null(aod) || ncol(aod) == 0) break + nc <- match(c("Cp", "AIC"), names(aod)) + nc <- nc[!is.na(nc)][1] + o <- order(aod[, nc]) + if(trace) print(aod[o, ]) + if(o[1] == 1) break + change <- rownames(aod)[o[1]] + } + usingCp <- match("Cp", names(aod), 0) > 0 + fit <- update(fit, paste("~ .", change)) + fit$formula <- fixFormulaObject(fit) + Terms <- fit$formula + attributes(Terms) <- attributes(fit$terms) + fit$terms <- Terms + bAIC <- extractAIC(fit, scale, k = k, ...) + edf <- bAIC[1] + bAIC <- bAIC[2] + if(trace) + cat("\nStep: AIC=", format(round(bAIC, 2)), "\n", + cut.string(deparse(as.vector(formula(fit)))), "\n\n") + if(bAIC >= AIC) break + nm <- nm + 1 + edf <- models[[nm]] <- + list(deviance = deviance(fit), df.resid = n - edf, + change = change, AIC = bAIC) + if(!is.null(keep)) keep.list[[nm]] <- keep(fit, bAIC) + } + if(!is.null(keep)) fit$keep <- re.arrange(keep.list[seq(nm)]) + step.results(models = models[seq(nm)], fit, object, usingCp) } extractAIC <- function(fit, scale, k = 2, ...) UseMethod("extractAIC") extractAIC.coxph <- function(fit, scale, k = 2, ...) { - edf <- length(fit$coef) - c(edf, -2 * fit$loglik[2] + k * edf) + edf <- length(fit$coef) + c(edf, -2 * fit$loglik[2] + k * edf) } extractAIC.survreg <- function(fit, scale, k = 2, ...) { - n <- length(fit$residuals) - edf <- n - fit$df.residual - c(edf, -2 * fit$loglik[2] + k * edf) + n <- length(fit$residuals) + edf <- n - fit$df.residual + c(edf, -2 * fit$loglik[2] + k * edf) } extractAIC.glm <- function(fit, scale = 0, k = 2, ...) { - n <- length(fit$residuals) - edf <- n - fit$df.residual - dev <- fit$deviance - if(scale > 0) dev <- dev/scale - if(scale == 0 && fit$family$family == "Gaussian") dev <- n * log(dev/n) - c(edf, dev + k * edf) + n <- length(fit$residuals) + edf <- n - fit$df.residual + dev <- fit$deviance + if(scale > 0) dev <- dev/scale + if(scale == 0 && fit$family$family == "Gaussian") dev <- n * log(dev/n) + c(edf, dev + k * edf) } -extractAIC.aov <- extractAIC.lm <- function(fit, scale = 0, k = 2, ...) { - n <- length(fit$residuals) - edf <- n - fit$df.residual - RSS <- deviance.lm(fit) - dev <- if(scale > 0) RSS/scale - n else n * log(RSS/n) - c(edf, dev + k * edf) + n <- length(fit$residuals) + edf <- n - fit$df.residual + RSS <- deviance.lm(fit) + dev <- if(scale > 0) RSS/scale - n else n * log(RSS/n) + c(edf, dev + k * edf) } +extractAIC.aov <- .Alias(extractAIC.lm) extractAIC.negbin <- function(fit, scale, k = 2, ...) { - n <- length(fit$residuals) - edf <- n - fit$df.residual - c(edf, -fit$twologlik + k * edf) + n <- length(fit$residuals) + edf <- n - fit$df.residual + c(edf, -fit$twologlik + k * edf) } diff --git a/src/library/base/R/aov.R b/src/library/base/R/aov.R index 65d1de07485..9670b80f6e4 100644 --- a/src/library/base/R/aov.R +++ b/src/library/base/R/aov.R @@ -260,7 +260,7 @@ summary.aov <- function(object, intercept = FALSE, keep.zero.df = TRUE, ...) TT <- ms/ms[nt] TP <- 1 - pf(TT, df, rdf) TT[nt] <- TP[nt] <- NA - x$"F Value" <- TT + x$"F value" <- TT x$"Pr(>F)" <- TP ## 'nterms' ~= 'Residuals' have no P-value } diff --git a/src/library/base/R/apply.R b/src/library/base/R/apply.R index 9805ec77c33..b6fd42f46ac 100644 --- a/src/library/base/R/apply.R +++ b/src/library/base/R/apply.R @@ -1,5 +1,4 @@ -apply <- - function(X, MARGIN, FUN, ...) +apply <- function(X, MARGIN, FUN, ...) { ## Ensure that FUN is a function @@ -16,9 +15,9 @@ apply <- d <- dim(X) dl <- length(d) - ds <- 1:dl if(dl == 0) stop("dim(X) must have a positive length") + ds <- 1:dl if(length(class(X)) > 0) X <- if(dl == 2) as.matrix(X) else as.array(X) dn <- dimnames(X) @@ -26,10 +25,10 @@ apply <- ## Extract the margins and associated dimnames s.call <- ds[-MARGIN] - s.ans <- ds[MARGIN] + s.ans <- ds[MARGIN] d.call <- d[-MARGIN] - d.ans <- d[MARGIN] - dn.call <- dn[-MARGIN] + d.ans <- d[MARGIN] + dn.call<- dn[-MARGIN] dn.ans <- dn[MARGIN] ## dimnames(X) <- NULL @@ -49,21 +48,16 @@ apply <- ans.length <- length(ans[[1]]) if(!ans.list) ans.list <- any(unlist(lapply(ans, length)) != ans.length) - if(!ans.list) - ans <- unlist(ans, recursive = FALSE) - if(length(MARGIN) == 1 && length(ans) == d2) { - if(length(dn.ans[[1]]) > 0) - names(ans) <- dn.ans[[1]] - else names(ans) <- NULL + len.a <- if(ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE)) + if(length(MARGIN) == 1 && len.a == d2) { + names(ans) <- if(length(dn.ans[[1]]) > 0) dn.ans[[1]] # else NULL return(ans) } - else if(length(ans) == d2) + if(len.a == d2) return(array(ans, d.ans, dn.ans)) - else if(length(ans) > 0 && length(ans) %% d2 == 0) { - if(is.null(dn.ans)) - return(array(ans, c(length(ans)/d2, d[MARGIN]))) - else return(array(ans, c(length(ans)/d2, d.ans), - c(list(ans.names), dn.ans))) - } - else return(ans) + if(len.a > 0 && len.a %% d2 == 0) + return(array(ans, c(len.a %/% d2, d.ans), + dimnames = if(is.null(dn.ans)) list(ans.names,NULL) + else c(list(ans.names), dn.ans))) + return(ans) } diff --git a/src/library/base/R/array.R b/src/library/base/R/array.R index 8034c60818b..230be481a9a 100644 --- a/src/library/base/R/array.R +++ b/src/library/base/R/array.R @@ -8,8 +8,9 @@ array <- function(data = NA, dim = length(data), dimnames = NULL) if( length(data) != vl ) data <- data[1:vl] } - dim(data) <- dim - if(is.list(dimnames)) + if(length(dim)) + dim(data) <- dim + if(is.list(dimnames) && length(dimnames)) dimnames(data) <- dimnames data } diff --git a/src/library/base/R/backsolve.R b/src/library/base/R/backsolve.R index 12f8ae35e8a..b8e829e6af3 100644 --- a/src/library/base/R/backsolve.R +++ b/src/library/base/R/backsolve.R @@ -1,20 +1,27 @@ -backsolve <- function(r, x, k=ncol(r)) +forwardsolve <- function(l, x, k=ncol(l)) backsolve(l,x,k, upper.tri = FALSE) + +backsolve <- function(r, x, k=ncol(r), + upper.tri = TRUE, transpose = FALSE) { r <- as.matrix(r)# nr x k + storage.mode(r) <- "double" x <- as.matrix(x)# k x nb + storage.mode(x) <- "double" + k <- as.integer(k) if(k <= 0 || nrow(x) != k) stop("invalid parameters in backsolve") nb <- ncol(x) + upper.tri <- as.logical(upper.tri) + transpose <- as.logical(transpose) + job <- as.integer((upper.tri) + 10*(transpose)) z <- .C("bakslv", - t = as.double(r), - ldt= nrow(r), - n = k, - b = as.double(x), - ldb= k, - nb = nb, + t = r, ldt= nrow(r), n = k, + b = x, ldb= k, nb = nb, x = matrix(0, k, nb), - job= as.integer(1), + job= job, info= integer(1), - DUP= FALSE) - if(z$info != 0) stop("singular matrix in backsolve") + DUP= FALSE)[c("x","info")] + if(z$info != 0) + stop(paste("singular matrix in backsolve. First zero in diagonal [", + z$info,"].",sep="")) z$x } diff --git a/src/library/base/R/cut.R b/src/library/base/R/cut.R index f494e86d924..e372022a368 100644 --- a/src/library/base/R/cut.R +++ b/src/library/base/R/cut.R @@ -14,6 +14,7 @@ cut.default <- function (x, breaks, labels=NULL, include.lowest = FALSE, rx[2] + dx/1000, len=nb) } else nb <- length(breaks <- sort(breaks)) if (any(duplicated(breaks))) stop("cut: breaks are not unique") + codes.only <- FALSE if (is.null(labels)) {#- try to construct nice ones .. for(dig in dig.lab:12) { ch.br <- formatC(breaks, dig=dig, wid=1) @@ -24,15 +25,19 @@ cut.default <- function (x, breaks, labels=NULL, include.lowest = FALSE, ch.br[-nb], ",", ch.br[-1], if(right)"]" else ")", sep='') else paste("Range", 1:(nb - 1),sep="_") - } else if (length(labels) != nb-1) - stop("labels/breaks length conflict") - code <- .C(if(right) "bincode2" else "bincode", - as.double(x), - length(x), - as.double(breaks), - nb, - code= integer(length(x)), + } else if (is.logical(labels) && !labels) + codes.only <- TRUE + else if (length(labels) != nb-1) + stop("labels/breaks length conflict") + code <- .C("bincode", + x = as.double(x), + n = length(x), + breaks = as.double(breaks), + nb, + code= integer(length(x)), + right= as.logical(right), include= as.logical(include.lowest), - NAOK= TRUE) $code - factor(code, seq(labels), labels) + NAOK= TRUE, DUP = FALSE) $code + if(codes.only) code + else factor(code, seq(labels), labels) } diff --git a/src/library/base/R/data.R b/src/library/base/R/data.R new file mode 100644 index 00000000000..c966f7ed349 --- /dev/null +++ b/src/library/base/R/data.R @@ -0,0 +1,49 @@ +## Was in system.unix.R -- now system-independent +## thanks to Guido's .Platform$show.data(.) idea. +data <- function(..., list = character(0), package =c(.packages(), .Autoloaded), + lib.loc = .lib.loc, verbose = .Options$verbose) +{ + names <- c(as.character(substitute(list(...))[-1]), list) + if (!missing(package)) + if (is.name(y <- substitute(package)))# && !is.character(package)) + package <- as.character(y) + found <- FALSE + fsep <- .Platform$file.sep + if (length(names) == 0) ## give `index' of all possible data sets + .Platform$ show.data(package,lib.loc,fsep) + else for (name in names) { + dn <- paste("data", name, sep = fsep) + files <- system.file(paste(dn, ".*", sep = ""), package, lib.loc) + found <- FALSE + if (files != "") { + subpre <- paste(".*", fsep, sep="") + for (file in files) { + if(verbose) + cat("name=",name,":\t file= ...",fsep, + sub(subpre,"",file),"::\t", sep="") + if (found) break + found <- TRUE + ext <- sub(".*\\.", "", file) + ## make sure the match is really for `name.ext' + if (sub(subpre, "", file) != paste(name, ".", ext, sep = "")) + found <- FALSE + else + switch(ext, + "R" =, "r" = source(file), + "RData" =, "rdata" =, "rda" = load(file), + "TXT" =, "txt" =, "tab" = + assign(name, read.table(file, header= TRUE), + env = .GlobalEnv), + "CSV" =, "csv" = + assign(name, read.table(file, header= TRUE, sep=";"), + env = .GlobalEnv), + ## otherwise + found <- FALSE) + if (verbose) cat(if(!found) "*NOT* ", "found\n") + } + } + if (!found) + warning(paste("Data set `", name, "' not found", sep = "")) + } + invisible(names) +} diff --git a/src/library/base/R/dataframe.R b/src/library/base/R/dataframe.R index f5821a15c7e..a2fb651bca4 100644 --- a/src/library/base/R/dataframe.R +++ b/src/library/base/R/dataframe.R @@ -231,7 +231,7 @@ data.frame <- function(..., row.names = NULL, check.rows = FALSE, check.names = else vnames[[i]] <- paste(vnames[[i]], namesi, sep=".") } else if(length(namesi) > 0) vnames[[i]] <- namesi - else if(no.vn[[i]]) vnames[[i]] <- deparse(object[[i]]) + else if(no.vn[[i]]) vnames[[i]] <- deparse(object[[i]])[1] nrows[[i]] <- length(rowsi) if(missing(row.names) && rowsi[[1]]!="") row.names <- data.row.names(row.names, rowsi, i) @@ -724,7 +724,8 @@ rbind.data.frame <- function(..., deparse.level = 1) } for(j in 1:nvar) { xj <- value[[j]] - if(!has.dim[j] && (is.character(xj) || is.logical(xj))) + if(!has.dim[j] && !inherits(xj, "AsIs") && + (is.character(xj) || is.logical(xj))) value[[j]] <- factor(xj) } rlabs <- unlist(rlabs) diff --git a/src/library/base/R/de.R b/src/library/base/R/de.R index c9422547b26..ba32724cd0c 100644 --- a/src/library/base/R/de.R +++ b/src/library/base/R/de.R @@ -57,21 +57,22 @@ de.setup <- function(ilist, list.names, incols) i <- i+1 } } - else stop("wrong argument to dataentry") + else stop("de.setup: wrong argument to dataentry") } names(ivec) <- inames return(ivec) } -## take the data in inlist and restore it to the format described by ncols and coltypes - de.restore <- function(inlist, ncols, coltypes, argnames, args) { - rlist <- vector("list", length=length(ncols)) - rnames <- vector("character", length=length(ncols)) + ## take the data in inlist and restore it + ## to the format described by ncols and coltypes + p <- length(ncols) + rlist <- vector("list", length=p) + rnames <- vector("character", length=p) j <- 1 lnames <- names(inlist) - for( i in 1:length(ncols) ) { + if(p) for(i in 1:p) { if(coltypes[i]==2) { tlen <- length(inlist[[j]]) x <- matrix(0, nrow=tlen, ncol=ncols[i]) @@ -116,21 +117,18 @@ de.restore <- function(inlist, ncols, coltypes, argnames, args) return(rlist) } -de <- function(..., Modes=NULL, Names=NULL) +de <- function(..., Modes=list(), Names=NULL) { sdata <- list(...) snames <- as.character(substitute(list(...))[-1]) if( is.null(sdata) ) { if( is.null(Names) ) { - if( !is.null(Modes) ) { - odata <- vector("list", length=length(Modes)) - } - else odata <- vector("list", length=1) + odata <- vector("list", length=max(1,length(Modes))) } else { - if( (length(Names) != length(Modes)) && !is.null(Modes) ) { + if( (length(Names) != length(Modes)) && length(Modes) ) { warning("modes argument ignored") - Modes <- NULL + Modes <- list() } odata <- vector("list", length=length(Names)) names(odata) <- Names @@ -143,21 +141,23 @@ de <- function(..., Modes=NULL, Names=NULL) coltypes <- ncols[, 2] ncols <- ncols[, 1] odata <- de.setup(sdata, snames, ncols) - if( !is.null(Names) ) + if(length(Names)) if( length(Names) != length(odata) ) warning("names argument ignored") else names(odata) <- Names - if( !is.null(Modes) ) - if( length(Modes) != length(odata) ) { + if(length(Modes)) + if(length(Modes) != length(odata)) { warning("modes argument ignored") - Modes <- NULL + Modes <- list() } } - rdata <- dataentry(odata, Modes) - t1 <- length(rdata)==sum(ncols) - if( t1 && any(coltypes!=1) ) - rdata <- de.restore(rdata, ncols, coltypes, snames, sdata) - else if( any(coltypes!=1) ) warning("could not restore data types properly") + rdata <- dataentry(odata, as.list(Modes)) + + if(any(coltypes != 1)) { + if(length(rdata) == sum(ncols)) + rdata <- de.restore(rdata, ncols, coltypes, snames, sdata) + else warning("could not restore data types properly") + } return(rdata) } @@ -165,9 +165,11 @@ data.entry <- function(..., Modes=NULL, Names=NULL) { tmp1 <- de(..., Modes=Modes, Names=Names) j <- 1 - for(i in names(tmp1) ) { + nn <- names(tmp1) + for(i in nn) { assign(i, tmp1[[j]], env=.GlobalEnv) j <- j+1 } - invisible(NULL) + if(j==1) warning("not assigned anything!") + invisible(nn) } diff --git a/src/library/base/R/dotplot.R b/src/library/base/R/dotplot.R index 87d1f4e8bd7..b95b9d44318 100644 --- a/src/library/base/R/dotplot.R +++ b/src/library/base/R/dotplot.R @@ -54,7 +54,7 @@ o <- rev(order(as.numeric(groups))) x <- x[o] groups <- groups[o] - offset <- cumsum(c(0, diff(as.numeric(groups)[o]) != 0)) + offset <- cumsum(c(0, diff(as.numeric(groups)) != 0)) y <- 1:n + 2 * offset ylim <- range(0, y + 2) } @@ -73,7 +73,7 @@ abline(h = y, lty = "dotted", col = lcolor) points(x, y, pch = pch, col = color, bg = bg) if (!is.null(groups)) { - gpos <- rev(cumsum(tapply(groups, groups, length) + 2) - 1) + gpos <- rev(cumsum(rev(tapply(groups, groups, length)) + 2) - 1) ginch <- max(strwidth(glabels, "inch"), na.rm = TRUE) goffset <- (max(linch+0.2, ginch, na.rm = TRUE) + 0.1)/lheight for(i in 1:nlevels(groups)) diff --git a/src/library/base/R/dummy.coef.R b/src/library/base/R/dummy.coef.R index bcc4cc35680..3ef6bc37dcc 100644 --- a/src/library/base/R/dummy.coef.R +++ b/src/library/base/R/dummy.coef.R @@ -3,172 +3,173 @@ dummy.coef <- function(object, ...) UseMethod("dummy.coef") dummy.coef.lm <- function(object, use.na=FALSE) { - Terms <- terms(object) - tl <- attr(Terms, "term.labels") - int <- attr(Terms, "intercept") - facs <- attr(Terms, "factors")[-1, , drop=FALSE] - vars <- rownames(facs) - xl <- object$xlevels - if(!length(xl)) { # no factors in model - return(as.list(coef(object))) - } - nxl <- rep(1, length(vars)) - names(nxl) <- vars - tmp <- unlist(lapply(xl, length)) - nxl[names(tmp)] <- tmp - lterms <- apply(facs, 2, function(x) prod(nxl[x > 0])) - nl <- sum(lterms) - args <- vector("list", length(vars)) - names(args) <- vars - for(i in vars) args[[i]] <- if(nxl[[i]] == 1) rep(1, nl) - else factor(rep(xl[[i]][1], nl), levels = xl[[i]]) - dummy <- do.call("data.frame", args) - pos <- 0 - rn <- rep(tl, lterms) - rnn <- rep("", nl) - for(j in tl) { - i <- vars[facs[, j] > 0] - ifac <- i[nxl[i] > 1] - if(length(ifac) == 0) { # quantitative factor - rnn[pos+1] <- j - } else if(length(ifac) == 1) { # main effect - dummy[ pos+1:lterms[j], ifac ] <- xl[[ifac]] - rnn[ pos+1:lterms[j] ] <- as.character(xl[[ifac]]) - } else { # interaction - tmp <- expand.grid(xl[ifac]) - dummy[ pos+1:lterms[j], ifac ] <- tmp - rnn[ pos+1:lterms[j] ] <- - apply(as.matrix(tmp), 1, function(x) paste(x, collapse=":")) + Terms <- terms(object) + tl <- attr(Terms, "term.labels") + int <- attr(Terms, "intercept") + facs <- attr(Terms, "factors")[-1, , drop=FALSE] + vars <- rownames(facs) + xl <- object$xlevels + if(!length(xl)) { # no factors in model + return(as.list(coef(object))) } - pos <- pos + lterms[j] - } - mm <- model.matrix(delete.response(Terms), dummy, object$contrasts, xl) - coef <- object$coef - if(!use.na) coef[is.na(coef)] <- 0 - asgn <- attr(mm,"assign") - res <- vector("list", length(tl)) - names(res) <- tl - for(j in seq(along=tl)) { - keep <- asgn == j - ans <- drop(mm[rn == tl[j], keep, drop=FALSE] %*% coef[keep]) - names(ans) <- rnn[rn == tl[j]] - res[[j]] <- ans - } - if(int > 0) { - res <- c(list(coef[int]), res) - names(res)[1] <- "(Intercept)" - } - class(res) <- "dummy.coef" - res + nxl <- rep(1, length(vars)) + names(nxl) <- vars + tmp <- unlist(lapply(xl, length)) + nxl[names(tmp)] <- tmp + lterms <- apply(facs, 2, function(x) prod(nxl[x > 0])) + nl <- sum(lterms) + args <- vector("list", length(vars)) + names(args) <- vars + for(i in vars) + args[[i]] <- if(nxl[[i]] == 1) rep(1, nl) + else factor(rep(xl[[i]][1], nl), levels = xl[[i]]) + dummy <- do.call("data.frame", args) + pos <- 0 + rn <- rep(tl, lterms) + rnn <- rep("", nl) + for(j in tl) { + i <- vars[facs[, j] > 0] + ifac <- i[nxl[i] > 1] + if(length(ifac) == 0) { # quantitative factor + rnn[pos+1] <- j + } else if(length(ifac) == 1) { # main effect + dummy[ pos+1:lterms[j], ifac ] <- xl[[ifac]] + rnn[ pos+1:lterms[j] ] <- as.character(xl[[ifac]]) + } else { # interaction + tmp <- expand.grid(xl[ifac]) + dummy[ pos+1:lterms[j], ifac ] <- tmp + rnn[ pos+1:lterms[j] ] <- + apply(as.matrix(tmp), 1, function(x) paste(x, collapse=":")) + } + pos <- pos + lterms[j] + } + mm <- model.matrix(delete.response(Terms), dummy, object$contrasts, xl) + coef <- object$coef + if(!use.na) coef[is.na(coef)] <- 0 + asgn <- attr(mm,"assign") + res <- vector("list", length(tl)) + names(res) <- tl + for(j in seq(along=tl)) { + keep <- asgn == j + ans <- drop(mm[rn == tl[j], keep, drop=FALSE] %*% coef[keep]) + names(ans) <- rnn[rn == tl[j]] + res[[j]] <- ans + } + if(int > 0) { + res <- c(list(coef[int]), res) + names(res)[1] <- "(Intercept)" + } + class(res) <- "dummy.coef" + res } dummy.coef.aovlist <- function(object, use.na = FALSE) { - Terms <- terms(object, specials="Error") - err <- attr(Terms,"specials")$Error - 1 - tl <- attr(Terms, "term.labels")[-err] - int <- attr(Terms, "intercept") - facs <- attr(Terms, "factors")[-c(1,1+err), -err, drop=FALSE] - vars <- rownames(facs) - xl <- attr(object, "xlevels") - if(!length(xl)) { # no factors in model - return(as.list(coef(object))) - } - nxl <- rep(1, length(vars)) - names(nxl) <- vars - tmp <- unlist(lapply(xl, length)) - nxl[names(tmp)] <- tmp - lterms <- apply(facs, 2, function(x) prod(nxl[x > 0])) - nl <- sum(lterms) - args <- vector("list", length(vars)) - names(args) <- vars - for(i in vars) args[[i]] <- if(nxl[[i]] == 1) rep(1, nl) - else factor(rep(xl[[i]][1], nl), levels = xl[[i]]) - dummy <- do.call("data.frame", args) - pos <- 0 - rn <- rep(tl, lterms) - rnn <- rep("", nl) - for(j in tl) { - i <- vars[facs[, j] > 0] - ifac <- i[nxl[i] > 1] - if(length(ifac) == 0) { # quantitative factor - rnn[pos + 1] <- j - } else if(length(ifac) == 1) { # main effect - dummy[ pos+1:lterms[j], ifac ] <- xl[[ifac]] - rnn[ pos+1:lterms[j] ] <- as.character(xl[[ifac]]) - } else { # interaction - tmp <- expand.grid(xl[ifac]) - dummy[ pos+1:lterms[j], ifac ] <- tmp - rnn[ pos+1:lterms[j] ] <- - apply(as.matrix(tmp), 1, function(x) paste(x, collapse=":")) + Terms <- terms(object, specials="Error") + err <- attr(Terms,"specials")$Error - 1 + tl <- attr(Terms, "term.labels")[-err] + int <- attr(Terms, "intercept") + facs <- attr(Terms, "factors")[-c(1,1+err), -err, drop=FALSE] + vars <- rownames(facs) + xl <- attr(object, "xlevels") + if(!length(xl)) { # no factors in model + return(as.list(coef(object))) } - pos <- pos + lterms[j] - } - form <- paste("~", paste(tl, collapse = " + ")) - if (!int) form <- paste(form, "- 1") - mm <- model.matrix(terms(formula(form)), dummy, - attr(object, "contrasts"), xl) - res <- vector("list", length(object)) - names(res) <- names(object) - tl <- c("(Intercept)", tl) - allasgn <- attr(mm, "assign") - for(i in names(object)) { - coef <- object[[i]]$coef - if(!use.na) coef[is.na(coef)] <- 0 - asgn <- object[[i]]$assign - uasgn <- unique(asgn) - tll <- tl[1 + uasgn] - mod <- vector("list", length(tll)) - names(mod) <- tll - for(j in uasgn) { - if(j == 0) { - ans <- structure(coef[asgn == j], names="(Intercept)") - } else { - ans <- drop(mm[rn == tl[1+j], allasgn == j, drop=FALSE] %*% - coef[asgn == j]) - names(ans) <- rnn[rn == tl[1+j]] - } - mod[[tl[1+j]]] <- ans + nxl <- rep(1, length(vars)) + names(nxl) <- vars + tmp <- unlist(lapply(xl, length)) + nxl[names(tmp)] <- tmp + lterms <- apply(facs, 2, function(x) prod(nxl[x > 0])) + nl <- sum(lterms) + args <- vector("list", length(vars)) + names(args) <- vars + for(i in vars) + args[[i]] <- if(nxl[[i]] == 1) rep(1, nl) + else factor(rep(xl[[i]][1], nl), levels = xl[[i]]) + dummy <- do.call("data.frame", args) + pos <- 0 + rn <- rep(tl, lterms) + rnn <- rep("", nl) + for(j in tl) { + i <- vars[facs[, j] > 0] + ifac <- i[nxl[i] > 1] + if(length(ifac) == 0) { # quantitative factor + rnn[pos + 1] <- j + } else if(length(ifac) == 1) { # main effect + dummy[ pos+1:lterms[j], ifac ] <- xl[[ifac]] + rnn[ pos+1:lterms[j] ] <- as.character(xl[[ifac]]) + } else { # interaction + tmp <- expand.grid(xl[ifac]) + dummy[ pos+1:lterms[j], ifac ] <- tmp + rnn[ pos+1:lterms[j] ] <- + apply(as.matrix(tmp), 1, function(x) paste(x, collapse=":")) + } + pos <- pos + lterms[j] + } + form <- paste("~", paste(tl, collapse = " + ")) + if (!int) form <- paste(form, "- 1") + mm <- model.matrix(terms(formula(form)), dummy, + attr(object, "contrasts"), xl) + res <- vector("list", length(object)) + names(res) <- names(object) + tl <- c("(Intercept)", tl) + allasgn <- attr(mm, "assign") + for(i in names(object)) { + coef <- object[[i]]$coef + if(!use.na) coef[is.na(coef)] <- 0 + asgn <- object[[i]]$assign + uasgn <- unique(asgn) + tll <- tl[1 + uasgn] + mod <- vector("list", length(tll)) + names(mod) <- tll + for(j in uasgn) { + if(j == 0) { + ans <- structure(coef[asgn == j], names="(Intercept)") + } else { + ans <- drop(mm[rn == tl[1+j], allasgn == j, drop=FALSE] %*% + coef[asgn == j]) + names(ans) <- rnn[rn == tl[1+j]] + } + mod[[tl[1+j]]] <- ans + } + res[[i]] <- mod } - res[[i]] <- mod - } - class(res) <- "dummy.coef.list" - res + class(res) <- "dummy.coef.list" + res } print.dummy.coef <- function(x, ..., title) { - terms <- names(x) - n <- length(x) - nm <- max(sapply(x, length)) - ans <- matrix("", 2*n, nm) - rn <- rep("", 2*n) - line <- 0 - for (j in seq(n)) { - this <- x[[j]] - n1 <- length(this) - if(n1 > 1) { - line <- line + 2 - ans[line-1, 1:n1] <- names(this) - ans[line, 1:n1] <- format(this, ...) - rn[line-1] <- paste(terms[j], ": ", sep="") - } else { - line <- line + 1 - ans[line, 1:n1] <- format(this, ...) - rn[line] <- paste(terms[j], ": ", sep="") - } - } - rownames(ans) <- rn - colnames(ans) <- rep("", nm) - if(missing(title)) cat("Full coefficients are\n") - else cat(title, "\n") - print.matrix(ans[1:line, , drop=FALSE], quote=FALSE, right=TRUE) - invisible(x) + terms <- names(x) + n <- length(x) + nm <- max(sapply(x, length)) + ans <- matrix("", 2*n, nm) + rn <- rep("", 2*n) + line <- 0 + for (j in seq(n)) { + this <- x[[j]] + n1 <- length(this) + if(n1 > 1) { + line <- line + 2 + ans[line-1, 1:n1] <- names(this) + ans[line, 1:n1] <- format(this, ...) + rn[line-1] <- paste(terms[j], ": ", sep="") + } else { + line <- line + 1 + ans[line, 1:n1] <- format(this, ...) + rn[line] <- paste(terms[j], ": ", sep="") + } + } + rownames(ans) <- rn + colnames(ans) <- rep("", nm) + cat(if(missing(title)) "Full coefficients are" else title, "\n") + print.matrix(ans[1:line, , drop=FALSE], quote=FALSE, right=TRUE) + invisible(x) } print.dummy.coef.list <- function(x, ...) { - for(strata in names(x)) - print.dummy.coef(x[[strata]], ..., title=paste("\n Error:", strata)) - invisible(x) + for(strata in names(x)) + print.dummy.coef(x[[strata]], ..., title=paste("\n Error:", strata)) + invisible(x) } diff --git a/src/library/base/R/eigen.R b/src/library/base/R/eigen.R index a487d9ea589..f1089698baa 100644 --- a/src/library/base/R/eigen.R +++ b/src/library/base/R/eigen.R @@ -1,4 +1,4 @@ -eigen <- function (x, symmetric, only.values=FALSE) +eigen <- function(x, symmetric, only.values=FALSE) { x <- as.matrix(x) n <- nrow(x) @@ -21,8 +21,7 @@ eigen <- function (x, symmetric, only.values=FALSE) if(complex.x) { xr <- Re(x) xi <- Im(x) - z <- .Fortran( - "ch", + z <- .Fortran("ch", n, n, xr, @@ -42,8 +41,7 @@ eigen <- function (x, symmetric, only.values=FALSE) im=z$ivectors), nc=n) } else { - z <- .Fortran( - "rs", + z <- .Fortran("rs", n, n, x, @@ -62,8 +60,7 @@ eigen <- function (x, symmetric, only.values=FALSE) if(complex.x) { xr <- Re(x) xi <- Im(x) - z <- .Fortran( - "cg", + z <- .Fortran("cg", n, n, xr, @@ -85,8 +82,7 @@ eigen <- function (x, symmetric, only.values=FALSE) im=z$ivectors), nc=n) } else { - z <- .Fortran( - "rg", + z <- .Fortran("rg", n, n, x, @@ -112,10 +108,6 @@ eigen <- function (x, symmetric, only.values=FALSE) } ord <- rev(order(Mod(z$values))) } - z$values <- z$values[ord] - if(!only.values) { - z$vectors <- z$vectors[,ord] - z[c("values", "vectors")] - } - else z["values"] + list(values = z$values[ord], + vectors = if(!only.values) z$vectors[,ord]) } diff --git a/src/library/base/R/glm.R b/src/library/base/R/glm.R index b2453a872c9..6578e0a7b93 100644 --- a/src/library/base/R/glm.R +++ b/src/library/base/R/glm.R @@ -104,6 +104,12 @@ glm.fit <- conv <- FALSE nobs <- NROW(y) nvars <- NCOL(x) + if (nvars == 0) { + ## oops, you'd want glm.fit.null, then + cc <- match.call() + cc[[1]] <- as.name("glm.fit.null") + return(eval(cc, sys.frame(sys.parent()))) + } ## define weights and offset if needed if (is.null(weights)) weights <- rep(1, nobs) diff --git a/src/library/base/R/glmnull.R b/src/library/base/R/glmnull.R index 23be1ea3b61..49564505f7b 100644 --- a/src/library/base/R/glmnull.R +++ b/src/library/base/R/glmnull.R @@ -101,7 +101,7 @@ summary.glm.null <- function (object, dispersion = NULL, correlation = TRUE, } glm.fit.null <- function (x, y, weights = rep(1, nobs), start = NULL, offset = rep(0, nobs), family = gaussian(), - control = glm.control(), intercept = NULL) + control = glm.control(), intercept = FALSE) { if(intercept) stop("null models have no intercept") ynames <- names(y) diff --git a/src/library/base/R/hist.R b/src/library/base/R/hist.R index 634f2787dea..b10839eb625 100644 --- a/src/library/base/R/hist.R +++ b/src/library/base/R/hist.R @@ -1,8 +1,8 @@ hist <- function(x, ...) UseMethod("hist") hist.default <- - function (x, breaks, freq = NULL, probability = !freq, include.lowest = TRUE, - col = NULL, border = par("fg"), + function (x, breaks, freq= NULL, probability = !freq, include.lowest= TRUE, + right=TRUE, col = NULL, border = par("fg"), main = paste("Histogram of" , deparse(substitute(x))), xlim = range(breaks), ylim = range(y, 0), xlab = deparse(substitute(x)), ylab, @@ -27,14 +27,17 @@ hist.default <- }) } nB <- length(breaks) + storage.mode(x) <- "double" + storage.mode(breaks) <- "double" counts <- .C("bincount", - as.double(x), + x, n, - as.double(breaks), + breaks, nB, counts = integer(nB - 1), + right = as.logical(right), include= as.logical(include.lowest), - NAOK = FALSE) $counts + NAOK = FALSE, DUP = FALSE) $counts if (any(counts < 0)) stop("negative `counts'. Internal Error in C-code for \"bincount\"") if (sum(counts) < n) @@ -54,6 +57,8 @@ hist.default <- intensities <- counts/(n*h) mids <- 0.5 * (breaks[-1] + breaks[-nB]) y <- if (freq) counts else intensities + r <- list(breaks = breaks, counts = counts, + intensities = intensities, mids = mids) if (plot) { plot.new() plot.window(xlim, ylim, "") #-> ylim's default from 'y' @@ -72,7 +77,7 @@ hist.default <- text(mids, y, labels = if(freq) counts else round(intensities,3), adj = c(0.5, -0.5)) + invisible(r) } - invisible(list(breaks = breaks, counts = counts, - intensities = intensities, mids = mids)) + else r } diff --git a/src/library/base/R/kappa.R b/src/library/base/R/kappa.R index 87c250473d1..1e08c0e3489 100644 --- a/src/library/base/R/kappa.R +++ b/src/library/base/R/kappa.R @@ -3,40 +3,40 @@ kappa <- function(z, ...) UseMethod("kappa") kappa.lm <- function(z, ...) { - kappa.qr(z$qr, ...) + kappa.qr(z$qr, ...) } kappa.default <- function(z, exact = FALSE, ...) { - z <- as.matrix(z) - if(exact) { - s <- svd(z, nu=0, nv=0)$d - max(s)/min(s[s > 0]) - } else if(is.qr(z)) kappa.qr(z) - else if(nrow(z) < ncol(z)) kappa.qr(qr(t(z))) else kappa.qr(qr(z)) + z <- as.matrix(z) + if(exact) { + s <- svd(z, nu=0, nv=0)$d + max(s)/min(s[s > 0]) + } else if(is.qr(z)) kappa.qr(z) + else if(nrow(z) < ncol(z)) kappa.qr(qr(t(z))) + else kappa.qr(qr(z)) } kappa.qr <- function(z, ...) { - qr <- z$qr - R <- qr[1:min(dim(qr)), , drop = FALSE] - R[lower.tri(R)] <- 0 - kappa.tri(R, ...) + qr <- z$qr + R <- qr[1:min(dim(qr)), , drop = FALSE] + R[lower.tri(R)] <- 0 + kappa.tri(R, ...) } kappa.tri <- function(z, exact = FALSE, ...) { - if(exact) kappa.default(z) - else { - p <- nrow(z) - if(p != ncol(z)) stop("matrix should be square") - ans <- .Fortran("dtrco", - as.double(z), - as.integer(p), - as.integer(p), - k = double(1), - double(p), - as.integer(1)) - 1/ans$k - } + if(exact) kappa.default(z) + else { + p <- nrow(z) + if(p != ncol(z)) stop("matrix should be square") + 1 / .Fortran("dtrco", + as.double(z), + p, + p, + k = double(1), + double(p), + as.integer(1)) $ k + } } diff --git a/src/library/base/R/labels.R b/src/library/base/R/labels.R index 0d1774353bb..93d535a81bf 100644 --- a/src/library/base/R/labels.R +++ b/src/library/base/R/labels.R @@ -3,23 +3,23 @@ labels <- function(object, ...) UseMethod("labels") labels.default <- function(object, ...) { - if(length(d <- dim(object))) { # array or data frame - nt <- dimnames(object) - if(is.null(nt)) nt <- vector("list", length(d)) - for(i in 1:length(d)) - if(!length(nt[[i]])) nt[[i]] <- as.character(seq(length = d[i])) - } else { - nt <- names(object) - if(!length(nt)) nt <- as.character(seq(along = object)) - } - nt + if(length(d <- dim(object))) { # array or data frame + nt <- dimnames(object) + if(is.null(nt)) nt <- vector("list", length(d)) + for(i in 1:length(d)) + if(!length(nt[[i]])) nt[[i]] <- as.character(seq(length = d[i])) + } else { + nt <- names(object) + if(!length(nt)) nt <- as.character(seq(along = object)) + } + nt } labels.terms <- function(object, ...) attr(object, "term.labels") labels.lm <- function(object, ...) { - tl <- attr(object$terms, "term.labels") - asgn <- object$asgn[object$qr$pivot[1:object$rank]] - tl[unique(asgn)] + tl <- attr(object$terms, "term.labels") + asgn <- object$asgn[object$qr$pivot[1:object$rank]] + tl[unique(asgn)] } diff --git a/src/library/base/R/library.R b/src/library/base/R/library.R index 72ef0d30ef5..f1d0e39b1cc 100644 --- a/src/library/base/R/library.R +++ b/src/library/base/R/library.R @@ -79,8 +79,19 @@ library <- function (name, help, lib.loc = .lib.loc, character.only = FALSE, help, "'", sep = "")) else .Platform$ show.file(file) - } else { - .Platform$ show.libraries(lib.loc, fsep = fsep) + } else { ## library(): + for (lib in lib.loc) { + cat(paste("\nPackages in library `", lib,"':\n\n", sep = "")) + a <- .packages(all.available = TRUE, lib.loc=lib) + for (i in a) { + title <- system.file("TITLE",i,lib) + if (title != "") + .Platform$ show.file(title) + else + cat(i,"\n") + } + } + return(invisible(a)) } if (logical.return) TRUE @@ -96,9 +107,10 @@ library.dynam <- if(missing(chname) || (LEN <- nchar(chname)) == 0) return(.Dyn.libs) fsep <- .Platform$file.sep - if (substr(chname, LEN - 2, LEN) == file.ext) { - chname <- substr(chname, 1, LEN - 3) - } + nc.ext <- nchar(file.ext) + if (substr(chname, LEN - nc.ext+1, LEN) == file.ext) + chname <- substr(chname, 1, LEN - nc.ext) + if (is.na(match(chname, .Dyn.libs))) { file <- system.file(paste("libs", fsep, chname, file.ext, sep = ""), package, lib.loc) @@ -143,7 +155,18 @@ provide <- function(name) { } } -.packages <- function() { +.packages <- function(all.available = FALSE, lib.loc = .lib.loc) { + if(all.available) { + fsep <- .Platform$ file.sep + a <- strsplit(system.file("*","",lib.loc), fsep) + ans <- character(0) + for (i in a) { + name <- i[length(i)] + pkg <- system.file(paste("R",name, sep=fsep), name, lib.loc) + if (pkg != "") ans <- c(ans,name) + } + return(ans) + } ## else s <- search() return(invisible(substring(s[substr(s, 1, 8) == "package:"], 9))) } diff --git a/src/library/base/R/lm.R b/src/library/base/R/lm.R index 2dd58bb3132..0e6a732ce18 100644 --- a/src/library/base/R/lm.R +++ b/src/library/base/R/lm.R @@ -63,6 +63,12 @@ lm.fit <- function (x, y, method = "qr", tol = 1e-07, ...) { if(is.null(n <- nrow(x))) stop("'x' must be a matrix") p <- ncol(x) + if (p == 0) { + ## oops, null model + cc <- match.call() + cc[[1]] <- as.name("lm.fit.null") + return(eval(cc, sys.frame(sys.parent()))) + } ny <- NCOL(y) ## treat one-col matrix as vector if ( is.matrix(y) && ny == 1 ) y <- drop(y) @@ -137,6 +143,12 @@ lm.wfit <- function (x, y, w, method = "qr", tol = 1e-7, ...) y <- if (ny > 1) y[ ok, , drop = FALSE] else y[ok] } p <- ncol(x) + if (p == 0) { + ## oops, null model + cc <- match.call() + cc[[1]] <- as.name("lm.wfit.null") + return(eval(cc, sys.frame(sys.parent()))) + } storage.mode(y) <- "double" wts <- sqrt(w) z <- .Fortran("dqrls", diff --git a/src/library/base/R/lmnull.R b/src/library/base/R/lmnull.R index f19a8a921a4..5c6defa37a4 100644 --- a/src/library/base/R/lmnull.R +++ b/src/library/base/R/lmnull.R @@ -89,3 +89,18 @@ summary.lm.null <- function (z, correlation = FALSE) class(ans) <- "summary.lm.null" ans } + +### The next two are used by lm.fit when it detects a null design +### matrix. A bit of a kludge, but it makes drop1 and friends work +### with no-intercept models + +lm.fit.null <- +function (x, y, method = "qr", tol = 1e-07, ...) +list(coefficients = numeric(0), residuals = y, fitted.values = 0 * + y, weights = NULL, rank = 0, df.residual = length(y)) + + +lm.wfit.null <- +function (x, y, w, method = "qr", tol = 1e-07, ...) +list(coefficients = numeric(0), residuals = y, fitted.values = 0 * + y, weights = w, rank = 0, df.residual = length(y)) diff --git a/src/library/base/R/mahalanobis.R b/src/library/base/R/mahalanobis.R index 96e6d282800..0b0e5971235 100644 --- a/src/library/base/R/mahalanobis.R +++ b/src/library/base/R/mahalanobis.R @@ -2,9 +2,16 @@ mahalanobis <- function(x, center, cov, inverted=FALSE) { x <- if(is.vector(x)) matrix(x, ncol=length(x)) else as.matrix(x) x <- sweep(x, 2, center)# = (x - center) + + ## The following would be considerably faster for small nrow(x) and + ## slower otherwise; probably always faster if the two t(.) weren't needed: + ## + ## retval <- apply(x * if(inverted) x%*%cov else t(solve(cov,t(x))), + ## 1, sum) if(!inverted) cov <- solve(cov) retval <- apply((x%*%cov) * x, 1, sum) + ##- names(retval) <- rownames(x) retval } diff --git a/src/library/base/R/matplot.R b/src/library/base/R/matplot.R index 5657ef36d3c..4384447c852 100644 --- a/src/library/base/R/matplot.R +++ b/src/library/base/R/matplot.R @@ -1,12 +1,14 @@ ## Author: Martin Maechler, Date: 27 Jun 97 -matpoints <- function(x, y, lty=1:5, pch=NULL, col=1:6, ...) - matplot(x=x, y=y, type = 'p', lty=lty, pch=pch, col=col, add=TRUE, ...) -matlines <- function(x, y, lty=1:5, pch=NULL, col=1:6, ...) - matplot(x=x, y=y, type = 'l', lty=lty, pch=pch, col=col, add=TRUE, ...) +matpoints <- function(x, y, lty=1:5, lwd = 1, pch=NULL, col=1:6, ...) + matplot(x=x, y=y, type = 'p', lty=lty, lwd=lwd, pch=pch, col=col, + add=TRUE, ...) +matlines <- function(x, y, lty=1:5, lwd = 1, pch=NULL, col=1:6, ...) + matplot(x=x, y=y, type = 'l', lty=lty, lwd=lwd, pch=pch, col=col, + add=TRUE, ...) matplot <- function(x, y, type="p", - lty=1:5, pch=NULL, col=1:6, + lty = 1:5, lwd = 1, pch=NULL, col=1:6, xlab=NULL, ylab=NULL, xlim=NULL, ylim=NULL, ..., add= FALSE, verbose = .Options$verbose) { @@ -57,6 +59,7 @@ matplot <- function(x, y, type="p", ylim <- if (is.null(ylim)) range(xy$y, finite = TRUE) else ylim if(length(type)< k) type<- rep(type,length= k) if(length(lty) < k) lty <- rep(lty, length= k) + if(length(lwd) < k) lwd <- rep(lwd, length= k) if(length(pch) < k) pch <- rep(pch, length= k) if(length(col) < k) col <- rep(col, length= k) ii <- 1:k @@ -64,12 +67,13 @@ matplot <- function(x, y, type="p", ii <- ii[-1] plot(x[,1],y[,1], type=type[1], xlab=xlab, ylab=ylab, xlim = xlim, ylim = ylim, - lty=lty[1], pch=pch[1], col=col[1], ...) + lty=lty[1], lwd=lwd[1], pch=pch[1], col=col[1], ...) } for (i in ii) { tp <- type[i] if(tp=='l' || tp=='b'|| tp=='o'|| tp=='h') - lines(x[,i],y[,i], type=tp, lty=lty[i],pch=pch[i],col=col[i]) + lines(x[,i],y[,i], type=tp, + lty=lty[i], lwd=lwd[i],pch=pch[i],col=col[i]) if(do.points && tp=='p') points(x[,i],y[,i], pch=pch[i], col=col[i]) } diff --git a/src/library/base/R/mlm.R b/src/library/base/R/mlm.R index 038a4477c74..4158141e308 100644 --- a/src/library/base/R/mlm.R +++ b/src/library/base/R/mlm.R @@ -1,42 +1,43 @@ #### copyright (C) 1998 B. D. Ripley summary.mlm <- function(object, ...) { - coef <- coef(object) - ny <- ncol(coef) - if(is.null(ny)) return(NextMethod("summary")) - effects <- object$effects - resid <- residuals(object) - fitted <- fitted(object) - ynames <- colnames(coef) - if(is.null(ynames)) { - lhs <- object$terms[[2]] - if(mode(lhs) == "call" && lhs[[1]] == "cbind") - ynames <- as.character(lhs)[-1] - else ynames <- paste("Y", seq(ny), sep = "") - } - value <- vector("list", ny) - names(value) <- paste("Response", ynames) - cl <- class(object) - class(object) <- cl[match("mlm", cl):length(cl)][-1] - for(i in seq(ny)) { - object$coefficients <- coef[, i] - object$residuals <- resid[, i] - object$fitted.values <- fitted[, i] - object$effects <- effects[, i] - object$call$formula[[2]] <- object$terms[[2]] <- as.name(ynames[i]) - value[[i]] <- summary(object, ...) - } - class(value) <- "listof" - value + coef <- coef(object) + ny <- ncol(coef) + if(is.null(ny)) return(NextMethod("summary")) + effects <- object$effects + resid <- residuals(object) + fitted <- fitted(object) + ynames <- colnames(coef) + if(is.null(ynames)) { + lhs <- object$terms[[2]] + if(mode(lhs) == "call" && lhs[[1]] == "cbind") + ynames <- as.character(lhs)[-1] + else ynames <- paste("Y", seq(ny), sep = "") + } + value <- vector("list", ny) + names(value) <- paste("Response", ynames) + cl <- class(object) + class(object) <- cl[match("mlm", cl):length(cl)][-1] + for(i in seq(ny)) { + object$coefficients <- coef[, i] + object$residuals <- resid[, i] + object$fitted.values <- fitted[, i] + object$effects <- effects[, i] + object$call$formula[[2]] <- object$terms[[2]] <- as.name(ynames[i]) + value[[i]] <- summary(object, ...) + } + class(value) <- "listof" + value } anova.mlm <- function(...) stop("no anova method implemented for mlm models") deviance.mlm <- function(object, ...) { - if(is.null(w <- object$weights)) res <- object$residuals^2 - else res <- w * object$residuals^2 - drop(rep(1, nrow(res)) %*% res) + res <- + if(is.null(w <- object$weights)) object$residuals^2 + else w * object$residuals^2 + drop(rep(1, nrow(res)) %*% res) } -plot.mlm <- function (...) .NotYetImplemented() +plot.mlm <- function (...) .NotYetImplemented() diff --git a/src/library/base/R/model.tables.R b/src/library/base/R/model.tables.R index 3e5f05ac4c1..529c95f6c49 100644 --- a/src/library/base/R/model.tables.R +++ b/src/library/base/R/model.tables.R @@ -3,444 +3,442 @@ model.tables <- function(x, ...) UseMethod("model.tables") model.tables.aov <- function(x, type = "effects", se = FALSE, cterms) { - if(inherits(x, "maov")) - stop("model.tables is not implemented for multiple responses") - type <- match.arg(type, c("effects", "means", "residuals")) - if(type == "residuals") stop(paste("type", type, "not implemented yet")) - prjs <- proj(x, unweighted.scale = TRUE) - mf <- model.frame(x) - factors <- attr(prjs, "factors") - dn.proj <- as.list(names(factors)) - m.factors <- factors - names(m.factors) <- names(dn.proj) <- names(factors) - t.factor <- attr(prjs, "t.factor") - vars <- colnames(t.factor) - which <- match(vars, names(dn.proj)) - which <- which[!is.na(which)] - dn.proj <- dn.proj[which] - m.factors <- m.factors[which] - #with cterms, can specify subset of tables by name - if(!missing(cterms)) { - if(any(is.na(match(cterms, names(factors))))) - stop("cterms parameter must match terms in model object") - dn.proj <- dn.proj[cterms] - m.factors <- m.factors[cterms] - } - if(type == "means") { - dn.proj <- - lapply(dn.proj, - function(x, mat, vn) - c("(Intercept)", - vn[(t(mat) %*% (as.logical(mat[, x]) - 1)) == 0]), - t.factor, vars) - } - tables <- make.tables.aovproj(dn.proj, m.factors, prjs, mf) + if(inherits(x, "maov")) + stop("model.tables is not implemented for multiple responses") + type <- match.arg(type, c("effects", "means", "residuals")) + if(type == "residuals") stop(paste("type", type, "not implemented yet")) + prjs <- proj(x, unweighted.scale = TRUE) + mf <- model.frame(x) + factors <- attr(prjs, "factors") + dn.proj <- as.list(names(factors)) + m.factors <- factors + names(m.factors) <- names(dn.proj) <- names(factors) + t.factor <- attr(prjs, "t.factor") + vars <- colnames(t.factor) + which <- match(vars, names(dn.proj)) + which <- which[!is.na(which)] + dn.proj <- dn.proj[which] + m.factors <- m.factors[which] + ## with cterms, can specify subset of tables by name + if(!missing(cterms)) { + if(any(is.na(match(cterms, names(factors))))) + stop("cterms parameter must match terms in model object") + dn.proj <- dn.proj[cterms] + m.factors <- m.factors[cterms] + } + if(type == "means") { + dn.proj <- + lapply(dn.proj, + function(x, mat, vn) + c("(Intercept)", + vn[(t(mat) %*% (as.logical(mat[, x]) - 1)) == 0]), + t.factor, vars) + } + tables <- make.tables.aovproj(dn.proj, m.factors, prjs, mf) - n <- replications(paste("~", paste(names(tables), collapse = "+")), - data = mf) - if(se) - if(is.list(n)) { - cat("Design is unbalanced - use se.contrasts for se's\n") - se <- FALSE - } else se.tables <- se.aov(x, n, type = type) - if(type == "means") { - gmtable <- mean(prjs[,"(Intercept)"]) - class(gmtable) <- "mtable" - tables <- c("Grand mean" = gmtable, tables) - } - result <- list(tables = tables, n = n) - if(se) result$se <- se.tables - attr(result, "type") <- type - class(result) <- c("tables.aov", "list.of") - result + n <- replications(paste("~", paste(names(tables), collapse = "+")), + data = mf) + if(se) + if(is.list(n)) { + cat("Design is unbalanced - use se.contrasts for se's\n") + se <- FALSE + } else se.tables <- se.aov(x, n, type = type) + if(type == "means") { + gmtable <- mean(prjs[,"(Intercept)"]) + class(gmtable) <- "mtable" + tables <- c("Grand mean" = gmtable, tables) + } + result <- list(tables = tables, n = n) + if(se) result$se <- se.tables + attr(result, "type") <- type + class(result) <- c("tables.aov", "list.of") + result } se.aov <- function(object, n, type = "means") { - #for balanced designs only - rdf <- object$df.resid - rse <- sqrt(sum(object$residuals^2)/rdf) - if(type == "effects") result <- rse/sqrt(n) - if(type == "means") - result <- - lapply(n, function(x, d) - { - nn <- unique(x) - nn <- nn[!is.na(nn)] - mat <- outer(nn, nn, function(x, y) 1/x + 1/y) - dimnames(mat) <- list(paste(nn), paste(nn)) - d * sqrt(mat) - } , d=rse) - attr(result, "type") <- type - class(result) <- "mtable" - result + ## for balanced designs only + rdf <- object$df.resid + rse <- sqrt(sum(object$residuals^2)/rdf) + if(type == "effects") result <- rse/sqrt(n) + if(type == "means") + result <- + lapply(n, + function(x, d) { + nn <- unique(x) + nn <- nn[!is.na(nn)] + mat <- outer(nn, nn, function(x, y) 1/x + 1/y) + dimnames(mat) <- list(paste(nn), paste(nn)) + d * sqrt(mat) + }, d=rse) + attr(result, "type") <- type + class(result) <- "mtable" + result } model.tables.aovlist <- function(x, type = "effects", se = FALSE, ...) { - type <- match.arg(type, c("effects", "means", "residuals")) - if(type == "residuals") stop(paste("type", type, "not implemented yet")) - prjs <- proj(x, unweighted.scale = TRUE) - mf <- model.frame.aovlist(x) - factors <- lapply(prjs, attr, "factors") - dn.proj <- unlist(lapply(factors, names), recursive = FALSE) - m.factors <- unlist(factors, recursive = FALSE) - dn.strata <- rep(names(factors), unlist(lapply(factors, length))) - names(dn.strata) <- names(m.factors) <- names(dn.proj) <- unlist(dn.proj) - t.factor <- attr(prjs, "t.factor") - efficiency <- FALSE - if(type == "effects" || type == "means") { - if(any(duplicated(nms <- names(dn.proj)[names(dn.proj) != "Residuals"]))) { - efficiency <- eff.aovlist(x) - #Elect to use the effects from the lowest stratum: usually expect this - #to be highest efficiency - eff.used <- apply(efficiency, 2, function(x, ind = seq(length(x))) - { - temp <- (x > 0) - if(sum(temp) == 1) temp - else max(ind[temp]) == ind - } - ) + type <- match.arg(type, c("effects", "means", "residuals")) + if(type == "residuals") stop(paste("type", type, "not implemented yet")) + prjs <- proj(x, unweighted.scale = TRUE) + mf <- model.frame.aovlist(x) + factors <- lapply(prjs, attr, "factors") + dn.proj <- unlist(lapply(factors, names), recursive = FALSE) + m.factors <- unlist(factors, recursive = FALSE) + dn.strata <- rep(names(factors), unlist(lapply(factors, length))) + names(dn.strata) <- names(m.factors) <- names(dn.proj) <- unlist(dn.proj) + t.factor <- attr(prjs, "t.factor") + efficiency <- FALSE + if(type == "effects" || type == "means") { + if(any(duplicated(nms <- names(dn.proj)[names(dn.proj)!= "Residuals"]))) { + efficiency <- eff.aovlist(x) + ## Elect to use the effects from the lowest stratum: + ## usually expect this to be highest efficiency + eff.used <- apply(efficiency, 2, + function(x, ind = seq(length(x))) { + temp <- (x > 0) + if(sum(temp) == 1) temp + else max(ind[temp]) == ind + }) + } } - } - if(any(efficiency)) { - which <- match(outer(rownames(efficiency), - colnames(efficiency), paste)[eff.used], - paste(dn.strata, dn.proj)) - efficiency <- efficiency[eff.used] - } else which <- match(colnames(t.factor), names(dn.proj)) - which <- which[!is.na(which)] - dn.proj <- dn.proj[which] - dn.strata <- dn.strata[which] - m.factors <- m.factors[which] - if(type == "means") { - t.factor <- t.factor[, names(dn.proj), drop = FALSE] - dn.proj <- - lapply(dn.proj, - function(x, mat, vn) - vn[(t(mat) %*% (as.logical(mat[, x]) - 1)) == 0], - t.factor, colnames(t.factor)) - } - tables <- if(any(efficiency)) { - names(efficiency) <- names(dn.proj) - make.tables.aovprojlist(dn.proj, dn.strata, m.factors, prjs, mf, - efficiency) + which <- match(outer(rownames(efficiency), + colnames(efficiency), paste)[eff.used], + paste(dn.strata, dn.proj)) + efficiency <- efficiency[eff.used] + } else which <- match(colnames(t.factor), names(dn.proj)) + which <- which[!is.na(which)] + dn.proj <- dn.proj[which] + dn.strata <- dn.strata[which] + m.factors <- m.factors[which] + if(type == "means") { + t.factor <- t.factor[, names(dn.proj), drop = FALSE] + dn.proj <- + lapply(dn.proj, + function(x, mat, vn) + vn[(t(mat) %*% (as.logical(mat[, x]) - 1)) == 0], + t.factor, colnames(t.factor)) } - else make.tables.aovprojlist(dn.proj, dn.strata, m.factors, prjs, mf) - if(type == "means") { - gmtable <- mean(prjs[["(Intercept)"]]) - class(gmtable) <- "mtable" - tables <- lapply(tables, "+", gmtable) - tables <- c("Grand mean" = gmtable, tables) - } - n <- replications(attr(x, "call"), data = mf) - if(se) - if(type == "effects" && is.list(n)) { - cat("Standard error information not returned as design is unbalanced. \nStandard errors can be obtained through se.contrast.\n") - se <- FALSE - } else if(type != "effects") { - warning(paste("SEs for type ", type, " are not yet implemented")) - se <- FALSE - } else { - se.tables <- se.aovlist(x, dn.proj, dn.strata, factors, mf, - efficiency, n, type = type) + tables <- + if(any(efficiency)) { + names(efficiency) <- names(dn.proj) + make.tables.aovprojlist(dn.proj, dn.strata, m.factors, prjs, mf, + efficiency) + } + else make.tables.aovprojlist(dn.proj, dn.strata, m.factors, prjs, mf) + if(type == "means") { + gmtable <- mean(prjs[["(Intercept)"]]) + class(gmtable) <- "mtable" + tables <- lapply(tables, "+", gmtable) + tables <- c("Grand mean" = gmtable, tables) } - result <- list(tables = tables, n = n) - if(se) result <- append(result, list(se = se.tables)) - attr(result, "type") <- type - class(result) <- c("tables.aov", "list.of") - result + n <- replications(attr(x, "call"), data = mf) + if(se) + if(type == "effects" && is.list(n)) { + cat("Standard error information not returned as design is unbalanced. \nStandard errors can be obtained through se.contrast.\n") + se <- FALSE + } else if(type != "effects") { + warning(paste("SEs for type ", type, " are not yet implemented")) + se <- FALSE + } else { + se.tables <- se.aovlist(x, dn.proj, dn.strata, factors, mf, + efficiency, n, type = type) + } + result <- list(tables = tables, n = n) + if(se) result <- append(result, list(se = se.tables)) + attr(result, "type") <- type + class(result) <- c("tables.aov", "list.of") + result } -se.aovlist <- - function(object, dn.proj, dn.strata, factors, mf, efficiency, n, - type = "diff.means", ...) +se.aovlist <- function(object, dn.proj, dn.strata, factors, mf, efficiency, n, + type = "diff.means", ...) { - if(type != "effects") - stop(paste("SEs for type ", type, " are not yet implemented")) - RSS <- sapply(object, function(x) sum(x$residuals^2)/x$df.resid) - res <- vector(length = length(n), mode = "list") - names(res) <- names(n) - for(i in names(n)) { - sse <- RSS[[dn.strata[dn.proj[[i]]]]] - if(any(efficiency)) - sse <- sse/efficiency[i] - res[[i]] <- as.vector(sqrt(sse/n[i])) - class(res[[i]]) <- "mtable" - } - attr(res, "type") <- type - res + if(type != "effects") + stop(paste("SEs for type ", type, " are not yet implemented")) + RSS <- sapply(object, function(x) sum(x$residuals^2)/x$df.resid) + res <- vector(length = length(n), mode = "list") + names(res) <- names(n) + for(i in names(n)) { + sse <- RSS[[dn.strata[dn.proj[[i]]]]] + if(any(efficiency)) + sse <- sse/efficiency[i] + res[[i]] <- as.vector(sqrt(sse/n[i])) + class(res[[i]]) <- "mtable" + } + attr(res, "type") <- type + res } make.tables.aovproj <- - function(proj.cols, mf.cols, prjs, mf, fun = "mean", prt = FALSE, ...) + function(proj.cols, mf.cols, prjs, mf, fun = "mean", prt = FALSE, ...) { - tables <- vector(mode = "list", length = length(proj.cols)) - names(tables) <- names(proj.cols) - for(i in seq(length(tables))) { - terms <- proj.cols[[i]] - if(length(terms) == 1) data <- prjs[, terms] - else data <- prjs[, terms] %*% as.matrix(rep(1, length(terms))) - tables[[i]] <- tapply(data, mf[mf.cols[[i]]], get(fun)) - class(tables[[i]]) <- "mtable" - if(prt) print(tables[i], ..., quote = FALSE) - } - tables + tables <- vector(mode = "list", length = length(proj.cols)) + names(tables) <- names(proj.cols) + for(i in seq(length(tables))) { + terms <- proj.cols[[i]] + data <- + if(length(terms) == 1) prjs[, terms] + else prjs[, terms] %*% as.matrix(rep(1, length(terms))) + tables[[i]] <- tapply(data, mf[mf.cols[[i]]], get(fun)) + class(tables[[i]]) <- "mtable" + if(prt) print(tables[i], ..., quote = FALSE) + } + tables } make.tables.aovprojlist <- - function(proj.cols, strata.cols, model.cols, projections, model, eff, - fun = "mean", prt = FALSE, ...) + function(proj.cols, strata.cols, model.cols, projections, model, eff, + fun = "mean", prt = FALSE, ...) { - tables <- vector(mode = "list", length = length(proj.cols)) - names(tables) <- names(proj.cols) - if(!missing(eff)) { - for(i in seq(length(tables))) { - terms <- proj.cols[[i]] - if(all(is.na(eff.i <- match(terms, names(eff))))) - eff.i <- rep(1, length(terms)) - if(length(terms) == 1) - data <- projections[[strata.cols[i]]][, terms]/ eff[eff.i] - else { - if(length(strata <- unique(strata.cols[terms])) == 1) - data <- projections[[strata]][, terms] %*% as.matrix(1/eff[eff.i]) - else { - mat <- NULL - for(j in strata) { - mat <- cbind(mat, projections[[j]][, terms[! is.na(match(terms, - names(strata.cols)[strata.cols == j]))]]) - } - data <- mat %*% as.matrix(1/eff[eff.i]) - } - } - tables[[i]] <- tapply(data, model[model.cols[[i]]], get(fun)) - attr(tables[[i]], "strata") <- strata.cols[i] - class(tables[[i]]) <- "mtable" - if(prt) print(tables[i], ..., quote = FALSE) + tables <- vector(mode = "list", length = length(proj.cols)) + names(tables) <- names(proj.cols) + if(!missing(eff)) { + for(i in seq(length(tables))) { + terms <- proj.cols[[i]] + if(all(is.na(eff.i <- match(terms, names(eff))))) + eff.i <- rep(1, length(terms)) + if(length(terms) == 1) + data <- projections[[strata.cols[i]]][, terms]/ eff[eff.i] + else { + if(length(strata <- unique(strata.cols[terms])) == 1) + data <- projections[[strata]][, terms] %*% + as.matrix(1/eff[eff.i]) + else { + mat <- NULL + for(j in strata) { + mat <- cbind(mat, projections[[j]][, terms[!is.na(match(terms, + names(strata.cols)[strata.cols == j]))]]) + } + data <- mat %*% as.matrix(1/eff[eff.i]) + } + } + tables[[i]] <- tapply(data, model[model.cols[[i]]], get(fun)) + attr(tables[[i]], "strata") <- strata.cols[i] + class(tables[[i]]) <- "mtable" + if(prt) print(tables[i], ..., quote = FALSE) + } + } else for(i in seq(length(tables))) { + terms <- proj.cols[[i]] + if(length(terms) == 1) data <- projections[[strata.cols[i]]][, terms] + else { + if(length(strata <- unique(strata.cols[terms])) == 1) + data <- projections[[strata]][, terms] %*% + as.matrix(rep(1, length(terms))) + else { + mat <- NULL + for(j in strata) { + mat <- cbind(mat, projections[[j]][, terms[!is.na(match(terms, + names(strata.cols)[strata.cols == j]))]]) + } + data <- mat %*% as.matrix(rep(1, length(terms))) + } + } + tables[[i]] <- tapply(data, model[model.cols[[i]]], get(fun)) + attr(tables[[i]], "strata") <- strata.cols[i] + class(tables[[i]]) <- "mtable" + if(prt) print(tables[i], ..., quote = FALSE) } - } else for(i in seq(length(tables))) { - terms <- proj.cols[[i]] - if(length(terms) == 1) data <- projections[[strata.cols[i]]][, terms] - else { - if(length(strata <- unique(strata.cols[terms])) == 1) - data <- projections[[strata]][, terms] %*% - as.matrix(rep(1, length(terms))) - else { - mat <- NULL - for(j in strata) { - mat <- cbind(mat, projections[[j]][, terms[!is.na(match(terms, - names(strata.cols)[strata.cols == j]))]]) - } - data <- mat %*% as.matrix(rep(1, length(terms))) - } - } - tables[[i]] <- tapply(data, model[model.cols[[i]]], get(fun)) - attr(tables[[i]], "strata") <- strata.cols[i] - class(tables[[i]]) <- "mtable" - if(prt) print(tables[i], ..., quote = FALSE) - } - tables + tables } replications <- function(formula, data = NULL, na.action = na.fail) { - if(missing(data) && inherits(formula, "data.frame")) { - data <- formula - formula <- ~ . - } - if(!inherits(formula, "terms")) { - formula <- as.formula(formula) - if(length(formula) < 3) { - f <- y ~ x - f[[3]] <- formula[[2]] - formula <- f + if(missing(data) && inherits(formula, "data.frame")) { + data <- formula + formula <- ~ . + } + if(!inherits(formula, "terms")) { + formula <- as.formula(formula) + if(length(formula) < 3) { + f <- y ~ x + f[[3]] <- formula[[2]] + formula <- f + } + formula <- terms(formula, data = data) + } + if(missing(na.action) && !is.null(tj <- attr(data, "na.action"))) + na.action <- tj + f <- attr(formula, "factors") + o <- attr(formula, "order") + labels <- attr(formula, "term.labels") + vars <- as.character(attr(formula, "variables"))[-1] + if(is.null(data)) { + v <- c(as.name("data.frame"), attr(formula, "variables")) + data <- eval(as.call(v), sys.frame(sys.parent())) } - formula <- terms(formula, data = data) - } - if(missing(na.action) && !is.null(tj <- attr(data, "na.action"))) - na.action <- tj - f <- attr(formula, "factors") - o <- attr(formula, "order") - labels <- attr(formula, "term.labels") - vars <- as.character(attr(formula, "variables"))[-1] - if(is.null(data)) { - v <- c(as.name("data.frame"), attr(formula, "variables")) - data <- eval(as.call(v), sys.frame(sys.parent())) - } - if(!is.function(na.action)) stop("na.action must be a function") - data <- na.action(data) - class(data) <- NULL - n <- length(o) - z <- vector("list", n) - names(z) <- labels - dummy <- numeric(length(attr(data, "row.names"))) - notfactor <- !sapply(data, function(x) inherits(x, "factor")) - balance <- TRUE - for(i in seq(length = n)) { - l <- labels[i] - if(o[i] < 1 || substring(l, 1, 5) == "Error") { z[[l]] <- NULL; next } - select <- vars[f[, i] > 0] - if(any(nn <- notfactor[select])) { - warning(paste("non-factors ignored:", paste(names(nn), collapse = ", "))) - next + if(!is.function(na.action)) stop("na.action must be a function") + data <- na.action(data) + class(data) <- NULL + n <- length(o) + z <- vector("list", n) + names(z) <- labels + dummy <- numeric(length(attr(data, "row.names"))) + notfactor <- !sapply(data, function(x) inherits(x, "factor")) + balance <- TRUE + for(i in seq(length = n)) { + l <- labels[i] + if(o[i] < 1 || substring(l, 1, 5) == "Error") { z[[l]] <- NULL; next } + select <- vars[f[, i] > 0] + if(any(nn <- notfactor[select])) { + warning(paste("non-factors ignored:", + paste(names(nn), collapse = ", "))) + next + } + if(length(select) > 0) + tble <- tapply(dummy, unclass(data[select]), length) + nrep <- unique(tble) + if(length(nrep) > 1) { + balance <- FALSE + tble[is.na(tble)] <- 0 + z[[l]] <- tble + } else z[[l]] <- as.vector(nrep) } - if(length(select) > 0) tble <- tapply(dummy, unclass(data[select]), length) - nrep <- unique(tble) - if(length(nrep) > 1) { - balance <- FALSE - tble[is.na(tble)] <- 0 - z[[l]] <- tble - } else z[[l]] <- as.vector(nrep) - } - if(balance) unlist(z) else z + if(balance) unlist(z) else z } print.tables.aov <- function(x, digits = 4, ...) { - tables.aov <- x$tables - n.aov <- x$n - se.aov <- if(se <- !is.na(match("se", names(x)))) x$se - type <- attr(x, "type") - switch(type, - effects = cat("Tables of effects\n"), - means = cat("Tables of means\n"), - residuals = if(length(tables.aov) > 1) cat( - "Table of residuals from each stratum\n")) - if(!is.na(ii <- match("Grand mean", names(tables.aov)))) { - cat("Grand mean\n") - gmtable <- tables.aov[[ii]] - print.mtable(gmtable, digits = digits, ...) - } - for(i in names(tables.aov)) { - if(i == "Grand mean") next - table <- tables.aov[[i]] - cat("\n", i, "\n") - if(!is.list(n.aov)) - print.mtable(table, digits = digits, ...) - else { - n <- n.aov[[i]] - if(length(dim(table)) < 2) { - table <- rbind(table, n) - rownames(table) <- c("", "rep") - print(table, digits = digits, ...) - } else { - ctable <- array(c(table, n), dim = c(dim(table), 2)) - dim.t <- dim(ctable) - d <- length(dim.t) - ctable <- aperm(ctable, c(1, d, 2:(d - 1))) - dim(ctable) <- c(dim.t[1] * dim.t[d], dim.t[-c(1, d)]) - dimnames(ctable) <- - append(list(format(c(rownames(table), rep("rep", dim.t[1])))), - dimnames(table)[-1]) - ctable <- eval(parse(text = paste( - "ctable[as.numeric(t(matrix(seq(nrow(ctable)),ncol=2)))", paste(rep(", ", d - 2), collapse = " "), "]"))) - names(dimnames(ctable)) <- names(dimnames(table)) - class(ctable) <- "mtable" - print.mtable(ctable, digits = digits, ...) - } + tables.aov <- x$tables + n.aov <- x$n + se.aov <- if(se <- !is.na(match("se", names(x)))) x$se + type <- attr(x, "type") + switch(type, + effects = cat("Tables of effects\n"), + means = cat("Tables of means\n"), + residuals = if(length(tables.aov) > 1) cat( + "Table of residuals from each stratum\n")) + if(!is.na(ii <- match("Grand mean", names(tables.aov)))) { + cat("Grand mean\n") + gmtable <- tables.aov[[ii]] + print.mtable(gmtable, digits = digits, ...) } - } - if(se) { - if(type == "residuals") rn <- "df" else rn <- "replic." - switch(attr(se.aov, "type"), - effects = cat("\nStandard errors of effects\n"), - means = cat("\nStandard errors for differences of means\n"), - residuals = cat("\nStandard errors of residuals\n")) - if(length(unlist(se.aov)) == length(se.aov)) { - # the simplest case: single replication, unique se - # kludge for NA's - n.aov <- n.aov[!is.na(n.aov)] - se.aov <- unlist(se.aov) - cn <- names(se.aov) - se.aov <- rbind(format(se.aov, digits = digits), format(n.aov)) - dimnames(se.aov) <- list(c(" ", rn), cn) - print.matrix(se.aov, quote=FALSE, right=TRUE, ...) - } else for(i in names(se.aov)) { - se <- se.aov[[i]] - if(length(se) == 1) { - #single se - se <- rbind(se, n.aov[i]) - dimnames(se) <- list(c(i, rn), "") - print(se, digits = digits, ...) - } else { - # different se - dimnames(se)[[1]] <- "" - cat("\n", i, "\n") - cat("When comparing means with same levels of:\n") - print(se, digits, ...) - cat("replic.", n.aov[i], "\n") - } + for(i in names(tables.aov)) { + if(i == "Grand mean") next + table <- tables.aov[[i]] + cat("\n", i, "\n") + if(!is.list(n.aov)) + print.mtable(table, digits = digits, ...) + else { + n <- n.aov[[i]] + if(length(dim(table)) < 2) { + table <- rbind(table, n) + rownames(table) <- c("", "rep") + print(table, digits = digits, ...) + } else { + ctable <- array(c(table, n), dim = c(dim(table), 2)) + dim.t <- dim(ctable) + d <- length(dim.t) + ctable <- aperm(ctable, c(1, d, 2:(d - 1))) + dim(ctable) <- c(dim.t[1] * dim.t[d], dim.t[-c(1, d)]) + dimnames(ctable) <- + append(list(format(c(rownames(table), rep("rep", dim.t[1])))), + dimnames(table)[-1]) + ctable <- eval(parse(text = paste( + "ctable[as.numeric(t(matrix(seq(nrow(ctable)),ncol=2)))", paste(rep(", ", d - 2), collapse = " "), "]"))) + names(dimnames(ctable)) <- names(dimnames(table)) + class(ctable) <- "mtable" + print.mtable(ctable, digits = digits, ...) + } + } } - } - invisible(NULL) + if(se) { + if(type == "residuals") rn <- "df" else rn <- "replic." + switch(attr(se.aov, "type"), + effects = cat("\nStandard errors of effects\n"), + means = cat("\nStandard errors for differences of means\n"), + residuals = cat("\nStandard errors of residuals\n")) + if(length(unlist(se.aov)) == length(se.aov)) { + ## the simplest case: single replication, unique se + # kludge for NA's + n.aov <- n.aov[!is.na(n.aov)] + se.aov <- unlist(se.aov) + cn <- names(se.aov) + se.aov <- rbind(format(se.aov, digits = digits), format(n.aov)) + dimnames(se.aov) <- list(c(" ", rn), cn) + print.matrix(se.aov, quote=FALSE, right=TRUE, ...) + } else for(i in names(se.aov)) { + se <- se.aov[[i]] + if(length(se) == 1) { ## single se + se <- rbind(se, n.aov[i]) + dimnames(se) <- list(c(i, rn), "") + print(se, digits = digits, ...) + } else { ## different se + dimnames(se)[[1]] <- "" + cat("\n", i, "\n") + cat("When comparing means with same levels of:\n") + print(se, digits, ...) + cat("replic.", n.aov[i], "\n") + } + } + } + invisible(x) } eff.aovlist <- function(aovlist) { - Terms <- terms(aovlist) - if(names(aovlist)[[1]] == "(Intercept)") aovlist <- aovlist[-1] - pure.error.strata <- sapply(aovlist, function(x) is.null(x$qr)) - aovlist <- aovlist[!pure.error.strata] - proj.len <- - lapply(aovlist, function(x) - { - asgn <- x$assign[x$qr$pivot[1:x$rank]] - sp <- split(seq(along=asgn), attr(terms(x), "term.labels")[asgn]) - sapply(sp, function(x, y) sum(y[x]), y=diag(x$qr$qr)^2) - }) - x.len <- - lapply(aovlist, function(x) - { - X <- as.matrix(qr.X(x$qr)^2) - asgn <- x$assign[x$qr$pivot[1:x$rank]] - sp <- split(seq(along=asgn), attr(terms(x), "term.labels")[asgn]) - sapply(sp, function(x, y) sum(y[,x, drop = FALSE]), y=X) - }) - t.labs <- attr(Terms, "term.labels") - s.labs <- names(aovlist) - eff <- matrix(0, ncol = length(t.labs), nrow = length(s.labs), - dimnames = list(s.labs, t.labs)) - ind <- NULL - for(i in names(proj.len)) - ind <- - rbind(ind, cbind(match(i, s.labs), match(names(proj.len[[i]]), t.labs))) - eff[ind] <- unlist(x.len) - x.len <- t(eff) %*% rep(1, length(s.labs)) - eff[ind] <- unlist(proj.len) - eff <- sweep(eff, 2, x.len, "/") - eff[, x.len != 0, drop = FALSE] + Terms <- terms(aovlist) + if(names(aovlist)[[1]] == "(Intercept)") aovlist <- aovlist[-1] + pure.error.strata <- sapply(aovlist, function(x) is.null(x$qr)) + aovlist <- aovlist[!pure.error.strata] + proj.len <- + lapply(aovlist, function(x) + { + asgn <- x$assign[x$qr$pivot[1:x$rank]] + sp <- split(seq(along=asgn), attr(terms(x), "term.labels")[asgn]) + sapply(sp, function(x, y) sum(y[x]), y=diag(x$qr$qr)^2) + }) + x.len <- + lapply(aovlist, function(x) { + X <- as.matrix(qr.X(x$qr)^2) + asgn <- x$assign[x$qr$pivot[1:x$rank]] + sp <- split(seq(along=asgn), attr(terms(x), "term.labels")[asgn]) + sapply(sp, function(x, y) sum(y[,x, drop = FALSE]), y=X) + }) + t.labs <- attr(Terms, "term.labels") + s.labs <- names(aovlist) + eff <- matrix(0, ncol = length(t.labs), nrow = length(s.labs), + dimnames = list(s.labs, t.labs)) + ind <- NULL + for(i in names(proj.len)) + ind <- rbind(ind, cbind(match(i, s.labs), + match(names(proj.len[[i]]), t.labs))) + eff[ind] <- unlist(x.len) + x.len <- t(eff) %*% rep(1, length(s.labs)) + eff[ind] <- unlist(proj.len) + eff <- sweep(eff, 2, x.len, "/") + eff[, x.len != 0, drop = FALSE] } -model.frame.aovlist <- - function(formula, data = NULL, ...) +model.frame.aovlist <- function(formula, data = NULL, ...) { - # formula is an aovlist object - call <- match.call() - oc <- attr(formula, "call") - Terms <- attr(formula, "terms") - rm(formula) - indError <- attr(Terms, "specials")$Error - errorterm <- attr(Terms, "variables")[[1 + indError]] - form <- update.formula(Terms, paste(". ~ .-", deparse(errorterm), - "+", deparse(errorterm[[2]]))) - nargs <- as.list(call) - oargs <- as.list(oc) - nargs <- nargs[match(c("data", "na.action", "subset"), names(nargs), 0)] - args <- oargs[match(c("data", "na.action", "subset"), names(oargs), 0)] - args[names(nargs)] <- nargs - args$formula <- form - do.call("model.frame", args) + ## formula is an aovlist object + call <- match.call() + oc <- attr(formula, "call") + Terms <- attr(formula, "terms") + rm(formula) + indError <- attr(Terms, "specials")$Error + errorterm <- attr(Terms, "variables")[[1 + indError]] + form <- update.formula(Terms, paste(". ~ .-", deparse(errorterm), + "+", deparse(errorterm[[2]]))) + nargs <- as.list(call) + oargs <- as.list(oc) + nargs <- nargs[match(c("data", "na.action", "subset"), names(nargs), 0)] + args <- oargs[match(c("data", "na.action", "subset"), names(oargs), 0)] + args[names(nargs)] <- nargs + args$formula <- form + do.call("model.frame", args) } -print.mtable <- - function(x, ..., digits = .Options$digits, quote = FALSE, right = FALSE) +print.mtable <- + function(x, ..., digits = .Options$digits, quote = FALSE, right = FALSE) { - { + xxx <- x xx <- attr(x, "Notes") nn <- names(dimnames(x)) a.ind <- match(names(a <- attributes(x)), c("dim", "dimnames", "names")) @@ -448,19 +446,20 @@ print.mtable <- class(x) <- attributes(x) <- NULL attributes(x) <- a if(length(nn) > 1) - cat(paste("Dim ",paste(seq(length(nn)), "=", nn, collapse = ", "), "\n")) + cat(paste("Dim ",paste(seq(length(nn)), "=", nn, collapse= ", "),"\n")) if(length(x) == 1 && is.null(names(x)) && is.null(dimnames(x))) - names(x) <- rep("", length(x)) + names(x) <- rep("", length(x)) if(length(dim(x)) && is.numeric(x)) { - xna <- is.na(x) - x <- format(zapsmall(x, digits)) - x[xna] <- " " + xna <- is.na(x) + x <- format(zapsmall(x, digits)) + x[xna] <- " " } - print(x, quote = quote, right = right) + print(x, quote = quote, right = right, ...) if(length(xx)) { - cat("\nNotes:\n") - print(xx) + cat("\nNotes:\n") + print(xx) } - } - invisible(NULL) + invisible(xxx) } + + diff --git a/src/library/base/R/models.R b/src/library/base/R/models.R index 566651ba8d6..47b275e7b6d 100644 --- a/src/library/base/R/models.R +++ b/src/library/base/R/models.R @@ -148,13 +148,34 @@ na.fail <- function(frame) if(all(ok)) frame else stop("missing values in data frame"); } -na.omit <- function(frame) -{ - ok <- complete.cases(frame) - if (all(ok)) - frame - else frame[ok, ] -} +na.omit <- function(frame) { + n <- length(frame) + omit <- FALSE + vars <- seq(length = n) + for(j in vars) { + x <- frame[[j]] + if(!is.atomic(x)) next + # variables are assumed to be either some sort of matrix, numeric or cat'y + x <- is.na(x) + d <- dim(x) + if(is.null(d) || length(d) != 2) + omit <- omit | x + else { + for(ii in 1:d[2]) + omit <- omit | x[, ii] + } + } + xx <- frame[!omit, , drop = F] + if (any(omit)) { + temp <- seq(omit)[omit] + names(temp) <- row.names(frame)[omit] + attr(temp, 'class') <- 'omit' + attr(xx, "na.action") <- temp + } + xx + } + + ##-- used nowhere (0.62) ##- model.data.frame <- function(...) { diff --git a/src/library/base/R/mosaicplot.R b/src/library/base/R/mosaicplot.R new file mode 100644 index 00000000000..e28999ec97b --- /dev/null +++ b/src/library/base/R/mosaicplot.R @@ -0,0 +1,170 @@ +## Copyright (C) 1998 John W. Emerson + +mosaicplot <- function(X, main = NA, sort = NA, off = NA, dir = NA, + color = FALSE) { + + mosaic.cell <- function(X, x1, y1, x2, y2, off, dir, color, lablevx, + lablevy, maxdim, currlev, label) { + + if (dir[1] == "v") { # split here on the X-axis. + xdim <- maxdim[1] + XP <- rep(0, xdim) + for (i in 1:xdim) { + XP[i] <- sum(X[X[,1]==i,ncol(X)]) / sum(X[,ncol(X)]) + } + white <- off[1] * (x2 - x1) / (max(1, xdim-1)) + x.l <- x1 + x.r <- x1 + (1 - off[1]) * XP[1] * (x2 - x1) + if (xdim > 1) { + for (i in 2:xdim) { + x.l <- c(x.l, x.r[i-1] + white) + x.r <- c(x.r, x.r[i-1] + white + + (1 - off[1]) * XP[i] * (x2 - x1)) + } + } + if (lablevx > 0) { + if (is.na(label[[1]][1])) { + this.lab <- paste(rep(as.character(currlev), + length(currlev)), + as.character(1:xdim), sep=".") + } else { this.lab <- label[[1]] } + text(x=(x.l + (x.r - x.l) / 2), + y=(965 + 22 * (lablevx - 1)), + srt=0,adj=.5, cex=.5, this.lab) + } + if (ncol(X) > 2) { # recursive call. + for (i in 1:xdim) { + if (XP[i] > 0) { + mosaic.cell(as.matrix(X[X[,1]==i,2:ncol(X)]), + x.l[i], y1, x.r[i], y2, + off[2:length(off)], + dir[2:length(dir)], + color, lablevx-1, (i==1)*lablevy, + maxdim[2:length(maxdim)], + currlev+1, label[2:ncol(X)]) + } else { + segments(rep(x.l[i],3), y1+(y2-y1)*c(0,2,4)/5, + rep(x.l[i],3), y1+(y2-y1)*c(1,3,5)/5) + } + } + } else { + for (i in 1:xdim) { + if (XP[i] > 0) { + polygon(c(x.l[i], x.r[i], x.r[i], x.l[i]), + c(y1, y1, y2, y2), col=color[i]) + segments(c(rep(x.l[i],3),x.r[i]), + c(y1,y1,y2,y2), + c(x.r[i],x.l[i],x.r[i],x.r[i]), + c(y1,y2,y2,y1)) + } else { + segments(rep(x.l[i],3), y1+(y2-y1)*c(0,2,4)/5, + rep(x.l[i],3), y1+(y2-y1)*c(1,3,5)/5) + } + } + } + } else { # split here on the Y-axis. + ydim <- maxdim[1] + YP <- rep(0, ydim) + for (j in 1:ydim) { + YP[j] <- sum(X[X[,1]==j,ncol(X)]) / sum(X[,ncol(X)]) + } + white <- off[1] * (y2 - y1) / (max(1, ydim - 1)) + y.b <- y2 - (1 - off[1]) * YP[1] * (y2 - y1) + y.t <- y2 + if (ydim > 1) { + for (j in 2:ydim) { + y.b <- c(y.b, y.b[j-1] - white - + (1 - off[1]) * YP[j] * (y2 - y1)) + y.t <- c(y.t, y.b[j-1] - white) + } + } + if (lablevy > 0) { + if (is.na(label[[1]][1])) { + this.lab <- paste(rep(as.character(currlev), + length(currlev)), + as.character(1:ydim), sep=".") + } else { this.lab <- label[[1]] } + text(x=(35 - 20 * (lablevy - 1)), + y=(y.b + (y.t - y.b) / 2), + srt=90, adj=.5, cex=.5, this.lab) + } + if (ncol(X) > 2) { # recursive call. + for (j in 1:ydim) { + if (YP[j] > 0) { + mosaic.cell(as.matrix(X[X[,1]==j,2:ncol(X)]), + x1, y.b[j], x2, y.t[j], + off[2:length(off)], + dir[2:length(dir)], color, + (j==1)*lablevx, lablevy-1, + maxdim[2:length(maxdim)], + currlev+1, label[2:ncol(X)]) + } else { + segments(x1+(x2-x1)*c(0,2,4)/5, rep(y.b[j],3), + x1+(x2-x1)*c(1,3,5)/5, rep(y.b[j],3)) + } + } + } else{ # final split polygon and segments. + for (j in 1:ydim) { + if (YP[j] > 0) { + polygon(c(x1,x2,x2,x1), + c(y.b[j],y.b[j],y.t[j],y.t[j]), + col=color[j]) + segments(c(x1,x1,x1,x2), + c(y.b[j],y.b[j],y.t[j],y.t[j]), + c(x2,x1,x2,x2), + c(y.b[j],y.t[j],y.t[j],y.b[j])) + } else { + segments(x1+(x2-x1)*c(0,2,4)/5, rep(y.b[j],3), + x1+(x2-x1)*c(1,3,5)/5, rep(y.b[j],3)) + } + } + } + } + } + + frame() + opar <- par(usr = c(1,1000,1,1000)) + on.exit(par(opar)) + if (is.vector(X)) { X <- array(X) } + dimd <- length(dim(X)) + if (!is.null(dimnames(X))) { label <- dimnames(X) } else { label <- NA } + if (dimd>1) { + Ind <- rep(1:(dim(X)[1]), prod(dim(X)[2:dimd])) + for (i in 2:dimd) { + Ind <- cbind(Ind, + c(matrix(1:(dim(X)[i]), byrow=TRUE, + prod(dim(X)[1:(i-1)]), + prod(dim(X)[i:dimd])))) + } + } else { + Ind <- 1:(dim(X)[1]) + } + Ind <- cbind(Ind, c(X)) + if (!is.na(main)) { title(main) } # Make the title. + if ((is.na(off[1]))||(length(off)!=dimd)) { # Initialize spacing. + off <- rep(10,50)[1:dimd] + } + if (is.na(dir[1])||(length(dir)!=dimd)) { # Initialize directions. + dir <- rep(c("v","h"),50)[1:dimd] + } + if ((!is.na(sort[1]))&&(length(sort)==dimd)) { # Sort columns. + Ind <- Ind[,c(sort,dimd+1)] + off <- off[sort] + dir <- dir[sort] + label <- label[sort] + } + ncolors <- length(tabulate(Ind[,dimd])) + if (is.na(color[1])) { + color <- rep(0, ncolors) + } else { + if (length(color) != ncolors) { + if (!color[1]) { color <- rep(0, ncolors) } + else { color <- 2:(ncolors+1) } + } + } + + mosaic.cell(Ind, 50, 5, 950, 950, + off/100, dir, color, 2, 2, apply(as.matrix(Ind[,1:dimd]), 2, max), + 1, label) + +} diff --git a/src/library/base/R/plot.R b/src/library/base/R/plot.R index 91e5637c1ae..d2dfecafa31 100644 --- a/src/library/base/R/plot.R +++ b/src/library/base/R/plot.R @@ -1,4 +1,4 @@ -xy.coords <- function(x, y, xlab=NULL, ylab=NULL, log = NULL) +xy.coords <- function(x, y, xlab=NULL, ylab=NULL, log=NULL, recycle = FALSE) { if(is.null(y)) { ylab <- xlab @@ -57,7 +57,16 @@ xy.coords <- function(x, y, xlab=NULL, ylab=NULL, log = NULL) } } - if(length(x) != length(y)) stop("x and y lengths differ") + if(length(x) != length(y)) { + if(recycle) { + if((nx <- length(x)) < (ny <- length(y))) + x <- rep(x, length= ny) + else + y <- rep(y, length= nx) + } + else + stop("x and y lengths differ") + } if(length(log) && log != "") { log <- strsplit(log, NULL)[[1]] diff --git a/src/library/base/R/pmax.R b/src/library/base/R/pmax.R index cc5b2564d51..ff705ba18db 100644 --- a/src/library/base/R/pmax.R +++ b/src/library/base/R/pmax.R @@ -1,5 +1,4 @@ -pmax <- - function (..., na.rm = FALSE) +pmax <- function (..., na.rm = FALSE) { elts <- list(...) maxmm <- as.vector(elts[[1]]) @@ -13,5 +12,6 @@ pmax <- if (!na.rm) work[,1][nas[,1]+nas[,2] > 0] <- NA maxmm <- work[,1] } + attributes(maxmm) <- attributes(elts[[1]]) maxmm } diff --git a/src/library/base/R/pmin.R b/src/library/base/R/pmin.R index 2d14286d6e1..81ff14901be 100644 --- a/src/library/base/R/pmin.R +++ b/src/library/base/R/pmin.R @@ -1,5 +1,4 @@ -pmin <- - function (..., na.rm = FALSE) +pmin <- function (..., na.rm = FALSE) { elts <- list(...) minmm <- as.vector(elts[[1]]) @@ -13,5 +12,6 @@ pmin <- if (!na.rm) work[,1][nas[,1]+nas[,2] > 0] <- NA minmm <- work[,1] } + attributes(minmm) <- attributes(elts[[1]]) minmm } diff --git a/src/library/base/R/print.R b/src/library/base/R/print.R index 2ecb46097dc..15a7767d127 100644 --- a/src/library/base/R/print.R +++ b/src/library/base/R/print.R @@ -2,8 +2,9 @@ print <- function(x, ...)UseMethod("print") ##- Need '...' such that it can be called as NextMethod("print", ...): print.default <- - function(x,digits=NULL,quote=TRUE,na.print=NULL,print.gap=NULL, ...) - .Internal(print.default(x,digits,quote,na.print,print.gap)) + function(x,digits=NULL,quote=TRUE,na.print=NULL,print.gap=NULL,right=FALSE, + ...) + .Internal(print.default(x,digits,quote,na.print,print.gap,right)) print.atomic <- function(x,quote=TRUE,...) print.default(x,quote=quote) @@ -125,7 +126,7 @@ print.coefmat <- Signif <- symnum(pv, corr = FALSE, na = FALSE, cutpoints = c(0, .001,.01,.05, .1, 1), symbols = c("***","**","*","."," ")) - Cf <- cbind(Cf, Signif) + Cf <- cbind(Cf, format.char(Signif)) #format.ch: right=TRUE } } else signif.stars <- FALSE } else signif.stars <- FALSE diff --git a/src/library/base/R/proj.R b/src/library/base/R/proj.R index 53554e6b743..b93d15f55ac 100644 --- a/src/library/base/R/proj.R +++ b/src/library/base/R/proj.R @@ -1,188 +1,189 @@ #### copyright (C) 1998 B. D. Ripley proj <- function(object, ...) UseMethod("proj") -proj.default <- -function(object, onedf = TRUE, ...) +proj.default <- function(object, onedf = TRUE, ...) { - if(!is.qr(object$qr)) - stop("Argument does not include a qr component") - if(is.null(object$effects)) - stop("Argument does not include an effects component") - RB <- c(object$effects[seq(object$rank)], - rep(0, nrow(object$qr$qr) - object$rank)) - prj <- as.matrix(qr.Q(object$qr, Dvec = RB)) - DN <- dimnames(object$qr$qr) - dimnames(prj) <- list(DN[[1]], DN[[2]][seq(ncol(prj))]) - prj + if(!is.qr(object$qr)) + stop("Argument does not include a qr component") + if(is.null(object$effects)) + stop("Argument does not include an effects component") + RB <- c(object$effects[seq(object$rank)], + rep(0, nrow(object$qr$qr) - object$rank)) + prj <- as.matrix(qr.Q(object$qr, Dvec = RB)) + DN <- dimnames(object$qr$qr) + dimnames(prj) <- list(DN[[1]], DN[[2]][seq(ncol(prj))]) + prj } -proj.lm <- -function(object, onedf = FALSE, unweighted.scale = FALSE) +proj.lm <- function(object, onedf = FALSE, unweighted.scale = FALSE) { - if(inherits(object, "mlm")) - stop("proj is not implemented for mlm fits") - rank <- object$rank - if(rank > 0) { - prj <- proj.default(object, onedf = TRUE)[, 1:rank, drop = FALSE] - if(onedf) { - df <- rep(1, rank) - result <- prj + if(inherits(object, "mlm")) + stop("proj is not implemented for mlm fits") + rank <- object$rank + if(rank > 0) { + prj <- proj.default(object, onedf = TRUE)[, 1:rank, drop = FALSE] + if(onedf) { + df <- rep(1, rank) + result <- prj + } else { + asgn <- object$assign[object$qr$pivot[1:object$rank]] + uasgn <- unique(asgn) + nmeffect <- c("(Intercept)", + attr(object$terms, "term.labels"))[1 + uasgn] + nterms <- length(uasgn) + df <- vector("numeric", nterms) + result <- matrix(0, length(object$residuals), nterms) + dimnames(result) <- list(rownames(object$fitted.values), nmeffect) + for(i in seq(along=uasgn)) { + select <- (asgn == uasgn[i]) + df[i] <- sum(select) + result[, i] <- prj[, select, drop = FALSE] %*% rep(1, df[i]) + } + } } else { - asgn <- object$assign[object$qr$pivot[1:object$rank]] - uasgn <- unique(asgn) - nmeffect <- c("(Intercept)", attr(object$terms, "term.labels"))[1 + uasgn] - nterms <- length(uasgn) - df <- vector("numeric", nterms) - result <- matrix(0, length(object$residuals), nterms) - dimnames(result) <- list(rownames(object$fitted.values), nmeffect) - for(i in seq(along=uasgn)) { - select <- (asgn == uasgn[i]) - df[i] <- sum(select) - result[, i] <- prj[, select, drop = FALSE] %*% rep(1, df[i]) - } + result <- NULL + df <- NULL } - } else { - result <- NULL - df <- NULL - } - if(!is.null(wt <- object$weights) && unweighted.scale) - result <- result/sqrt(wt) - use.wt <- !is.null(wt) && !unweighted.scale - if(object$df.residual > 0) { - if(!is.matrix(result)) { - if(use.wt) result <- object$residuals * sqrt(wt) - else result <- object$residuals - result <- matrix(result, length(result), 1, dimnames - = list(names(result), "Residuals")) - } else { - dn <- dimnames(result) - d <- dim(result) - result <- c(result, if(use.wt) object$residuals * sqrt(wt) - else object$residuals) - dim(result) <- d + c(0, 1) - dn[[1]] <- names(object$residuals) - names(result) <- NULL - dn[[2]] <- c(dn[[2]], "Residuals") - dimnames(result) <- dn + if(!is.null(wt <- object$weights) && unweighted.scale) + result <- result/sqrt(wt) + use.wt <- !is.null(wt) && !unweighted.scale + if(object$df.residual > 0) { + if(!is.matrix(result)) { + if(use.wt) result <- object$residuals * sqrt(wt) + else result <- object$residuals + result <- matrix(result, length(result), 1, dimnames + = list(names(result), "Residuals")) + } else { + dn <- dimnames(result) + d <- dim(result) + result <- c(result, if(use.wt) object$residuals * sqrt(wt) + else object$residuals) + dim(result) <- d + c(0, 1) + dn[[1]] <- names(object$residuals) + names(result) <- NULL + dn[[2]] <- c(dn[[2]], "Residuals") + dimnames(result) <- dn + } + df <- c(df, object$df.residual) } - df <- c(df, object$df.residual) - } - names(df) <- colnames(result) - attr(result, "df") <- df - attr(result, "formula") <- object$call$formula - attr(result, "onedf") <- onedf - if(!is.null(wt)) attr(result, "unweighted.scale") <- unweighted.scale - result + names(df) <- colnames(result) + attr(result, "df") <- df + attr(result, "formula") <- object$call$formula + attr(result, "onedf") <- onedf + if(!is.null(wt)) attr(result, "unweighted.scale") <- unweighted.scale + result } -proj.aov <- -function(object, onedf = FALSE, unweighted.scale = FALSE) +proj.aov <- function(object, onedf = FALSE, unweighted.scale = FALSE) { - if(inherits(object, "maov")) - stop("proj is not implemented for multiple responses") - factors.aov <- function(pnames, tfactor) - { - if(!is.na(int <- match("(Intercept)", pnames))) - pnames <- pnames[ - int] - tnames <- lapply(colnames(tfactor), function(x, mat) - rownames(mat)[mat[, x] > 0], tfactor) - names(tnames) <- colnames(tfactor) - if(!is.na(match("Residuals", pnames))) { - enames <- c(rownames(tfactor)[as.logical(tfactor %*% - rep(1, ncol(tfactor)))], "Within") - tnames <- append(tnames, list(Residuals = enames)) + if(inherits(object, "maov")) + stop("proj is not implemented for multiple responses") + factors.aov <- function(pnames, tfactor) + { + if(!is.na(int <- match("(Intercept)", pnames))) + pnames <- pnames[ - int] + tnames <- lapply(colnames(tfactor), function(x, mat) + rownames(mat)[mat[, x] > 0], tfactor) + names(tnames) <- colnames(tfactor) + if(!is.na(match("Residuals", pnames))) { + enames <- c(rownames(tfactor) + [as.logical(tfactor %*% rep(1, ncol(tfactor)))], + "Within") + tnames <- append(tnames, list(Residuals = enames)) + } + result <- tnames[match(pnames, names(tnames))] + if(!is.na(int)) result <- c("(Intercept)" = "(Intercept)", result) + ## should reorder result, but probably OK + result } - result <- tnames[match(pnames, names(tnames))] - if(!is.na(int)) result <- c("(Intercept)" = "(Intercept)", result) - #should reorder result, but probably OK - result - } - projections <- NextMethod("proj") - t.factor <- attr(terms(object), "factor") - attr(projections, "factors") <- - factors.aov(colnames(projections), t.factor) - attr(projections, "call") <- object$call - attr(projections, "t.factor") <- t.factor - class(projections) <- "aovproj" - projections + projections <- NextMethod("proj") + t.factor <- attr(terms(object), "factor") + attr(projections, "factors") <- + factors.aov(colnames(projections), t.factor) + attr(projections, "call") <- object$call + attr(projections, "t.factor") <- t.factor + class(projections) <- "aovproj" + projections } -proj.aovlist <- -function(object, onedf = FALSE, unweighted.scale = FALSE) +proj.aovlist <- function(object, onedf = FALSE, unweighted.scale = FALSE) { - attr.xdim <- function(x) - { - # all attributes except names, dim and dimnames - atrf <- attributes(x) - atrf[is.na(match(names(atrf), c("names", "dim", "dimnames")))] - } - "attr.assign<-" <- function(x, value) - { - # assign to x all attributes in attr.x -# attributes(x)[names(value)] <- value not allowed in R - for(nm in names(value)) attr(x, nm) <- value[nm] - x - } - factors.aovlist <- function(pnames, tfactor, strata = FALSE, efactor = FALSE) - { - if(!is.na(int <- match("(Intercept)", pnames))) pnames <- pnames[-int] - tnames <- apply(tfactor, 2, function(x, nms) - nms[as.logical(x)], rownames(tfactor)) - if(!missing(efactor)) { - enames <- NULL - if(!is.na(err <- match(strata, colnames(efactor)))) - enames <- (rownames(efactor))[as.logical(efactor[, err])] - else if(strata == "Within") - enames <- c(rownames(efactor)[as.logical(efactor %*% rep(1, ncol(efactor)))], "Within") - if(!is.null(enames)) - tnames <- append(tnames, list(Residuals = enames)) + attr.xdim <- function(x) + { + ## all attributes except names, dim and dimnames + atrf <- attributes(x) + atrf[is.na(match(names(atrf), c("names", "dim", "dimnames")))] + } + "attr.assign<-" <- function(x, value) + { + ## assign to x all attributes in attr.x + ## attributes(x)[names(value)] <- value not allowed in R + for(nm in names(value)) attr(x, nm) <- value[nm] + x + } + factors.aovlist <- function(pnames, tfactor, + strata = FALSE, efactor = FALSE) + { + if(!is.na(int <- match("(Intercept)", pnames))) pnames <- pnames[-int] + tnames <- apply(tfactor, 2, function(x, nms) + nms[as.logical(x)], rownames(tfactor)) + if(!missing(efactor)) { + enames <- NULL + if(!is.na(err <- match(strata, colnames(efactor)))) + enames <- (rownames(efactor))[as.logical(efactor[, err])] + else if(strata == "Within") + enames <- c(rownames(efactor) + [as.logical(efactor %*% rep(1, ncol(efactor)))], + "Within") + if(!is.null(enames)) + tnames <- append(tnames, list(Residuals = enames)) + } + result <- tnames[match(pnames, names(tnames))] + if(!is.na(int)) + result <- c("(Intercept)" = "(Intercept)", result) + ##should reorder result, but probably OK + result + } + if(unweighted.scale && is.null(attr(object, "weights"))) + unweighted.scale <- FALSE + err.qr <- attr(object, "error.qr") + Terms <- terms(object, "Error") + t.factor <- attr(Terms, "factor") + i <- attr(Terms, "specials")$Error + t <- attr(Terms, "variables")[[1 + i]] + error <- Terms + error[[3]] <- t[[2]] + e.factor <- attr(terms(as.formula(error)), "factor") + n <- nrow(err.qr$qr) + n.object <- length(object) + result <- vector("list", n.object) + names(result) <- names(object) + D1 <- rownames(err.qr$qr) + if(unweighted.scale) wt <- attr(object, "weights") + for(i in names(object)) { + prj <- proj.lm(object[[i]], onedf = onedf) + if(unweighted.scale) prj <- prj/sqrt(wt) + result.i <- matrix(0, n, ncol(prj), dimnames = list(D1, colnames(prj))) + select <- rownames(object[[i]]$qr$qr) + result.i[select, ] <- prj + result[[i]] <- as.matrix(qr.qy(err.qr, result.i)) + attr.assign(result[[i]]) <- attr.xdim(prj) + D2i <- colnames(prj) + dimnames(result[[i]]) <- list(D1, D2i) + attr(result[[i]], "factors") <- + factors.aovlist(D2i, t.factor, strata = i, efactor = e.factor) } - result <- tnames[match(pnames, names(tnames))] - if(!is.na(int)) - result <- c("(Intercept)" = "(Intercept)", result) - #should reorder result, but probably OK + attr(result, "call") <- attr(object, "call") + attr(result, "e.factor") <- e.factor + attr(result, "t.factor") <- t.factor + class(result) <- c("aovprojlist", "listof") result - } - if(unweighted.scale && is.null(attr(object, "weights"))) - unweighted.scale <- FALSE - err.qr <- attr(object, "error.qr") - Terms <- terms(object, "Error") - t.factor <- attr(Terms, "factor") - i <- attr(Terms, "specials")$Error - t <- attr(Terms, "variables")[[1 + i]] - error <- Terms - error[[3]] <- t[[2]] - e.factor <- attr(terms(as.formula(error)), "factor") - n <- nrow(err.qr$qr) - n.object <- length(object) - result <- vector("list", n.object) - names(result) <- names(object) - D1 <- rownames(err.qr$qr) - if(unweighted.scale) wt <- attr(object, "weights") - for(i in names(object)) { - prj <- proj.lm(object[[i]], onedf = onedf) - if(unweighted.scale) prj <- prj/sqrt(wt) - result.i <- matrix(0, n, ncol(prj), dimnames = list(D1, colnames(prj))) - select <- rownames(object[[i]]$qr$qr) - result.i[select, ] <- prj - result[[i]] <- as.matrix(qr.qy(err.qr, result.i)) - attr.assign(result[[i]]) <- attr.xdim(prj) - D2i <- colnames(prj) - dimnames(result[[i]]) <- list(D1, D2i) - attr(result[[i]], "factors") <- - factors.aovlist(D2i, t.factor, strata = i, efactor = e.factor) - } - attr(result, "call") <- attr(object, "call") - attr(result, "e.factor") <- e.factor - attr(result, "t.factor") <- t.factor - class(result) <- c("aovprojlist", "listof") - result } terms.aovlist <- function(x, ...) { - x <- attr(x, "terms") - terms(x, ...) + x <- attr(x, "terms") + terms(x, ...) } diff --git a/src/library/base/R/prompt.R b/src/library/base/R/prompt.R index 4ed79df2989..bc96cf7e2fc 100644 --- a/src/library/base/R/prompt.R +++ b/src/library/base/R/prompt.R @@ -6,15 +6,20 @@ prompt.default <- function(object, filename = paste0(name, ".Rd"), force.function = FALSE) { paste0 <- function(...) paste(..., sep = "") - is.missing.arg <- function(arg) typeof(arg) == "symbol" && deparse(arg) == "" + is.missing.arg <- function(arg) + typeof(arg) == "symbol" && deparse(arg) == "" name <- substitute(object) if(is.language(name) && !is.name(name)) name <- eval(name) name <- as.character(name) fn <- get(name) - ##-- 'file' [character(NN)] will contain the lines to be put in the Rdoc file + ## `file' [character(NN)] will contain the lines to be put in the + ## Rdoc file file <- paste0("\\name{", name, "}") if(is.function(fn) || force.function) { - file <- c(file, "\\title{ ~~function to do ... ~~}") + file <- c(file, + paste0("\\alias{", name, "}"), + "%- Also NEED an `\\alias' for EACH other topic documented here.", + "\\title{ ~~function to do ... ~~}") s <- seq(length = n <- length(argls <- formals(fn))) if(n > 0) { arg.names <- arg.n <- names(argls) @@ -29,11 +34,7 @@ prompt.default <- if(i != n) call <- paste0(call, ", ") } file <- c(file, "\\usage{", paste0(call, ")"), "}", - "%- maybe also `usage' for other functions documented here.", - paste0("\\alias{", name, "}"), - "%- Also NEED an `\\alias' for EACH other function documented here." - ) - + "%- maybe also `usage' for other objects documented here.") if(length(s)) file <- c(file, "\\arguments{", paste0(" \\item{", arg.n, "}{", @@ -57,7 +58,7 @@ prompt.default <- "}", "\\references{ ~put references to the literature/web site here ~ }", - "\\author{ ~~if you are not one of R & R ..~~ }", + "\\author{ ~~who you are~~ }", "\\note{ ~~further notes~~ }", "", " ~Make other sections like WARNING with \\section{WARNING }{....} ~", @@ -77,7 +78,7 @@ prompt.default <- file <- c(file,"\\non_function{}", paste("\\title{ ~~data-name / kind ... }"), "\\description{", - "~~ a precise description of what the function does. ~~", + "~~ a precise description of what the object does. ~~", "}") } cat(file, file = filename, sep = "\n") diff --git a/src/library/base/R/quantile.R b/src/library/base/R/quantile.R index 4b9c5e48f14..7eb37e67902 100644 --- a/src/library/base/R/quantile.R +++ b/src/library/base/R/quantile.R @@ -1,30 +1,37 @@ quantile <- function(x, ...) UseMethod("quantile") -quantile.default <- - function (x, probs = seq(0, 1, 0.25), na.rm = FALSE) { - if (na.rm) - x <- x[!is.na(x)] - else if (any(is.na(x))) - stop("Missing values and NaN's not allowed if `na.rm' is FALSE") - n <- length(x) - if (any(probs < 0 | probs > 1)) - stop("probs outside [0,1]") - if (n > 0) { - index <- 1 + (n - 1) * probs - lo <- floor(index) - hi <- ceiling(index) - x <- sort(x, partial = unique(c(lo, hi))) - i <- (index > lo) - qs <- x[lo] - qs[i] <- qs[i] + (x[hi[i]] - x[lo[i]]) * (index[i] - lo[i]) - } else { - qs <- rep(as.numeric(NA), length(probs)) - } - names(qs) <- paste(formatC(100 * probs, format = "fg", wid = 1, - dig = max(2,.Options$digits)), - "%", sep = "") - qs +quantile.default <- function(x, probs = seq(0, 1, 0.25), na.rm = FALSE, + names = TRUE) +{ + if (na.rm) + x <- x[!is.na(x)] + else if (any(is.na(x))) + stop("Missing values and NaN's not allowed if `na.rm' is FALSE") + if (any(probs < 0 | probs > 1)) + stop("probs outside [0,1]") + n <- length(x) + np <- length(probs) + if (n > 0) { + index <- 1 + (n - 1) * probs + lo <- floor(index) + hi <- ceiling(index) + x <- sort(x, partial = unique(c(lo, hi))) + i <- index > lo + qs <- x[lo] + qs[i] <- qs[i] + (x[hi[i]] - x[lo[i]]) * (index[i] - lo[i]) + } else { + qs <- rep(as.numeric(NA), np) } + if(names) { + dig <- max(2, .Options$digits) + names(qs) <- paste(## formatC is slow for long probs + if(np < 100) + formatC(100*probs, format="fg", wid = 1, dig=dig) + else format(100 * probs, trim=TRUE, dig=dig), + "%", sep = "") + } + qs +} IQR <- function (x, na.rm = FALSE) as.vector(diff(quantile(as.numeric(x), c(0.25, 0.75), na.rm=na.rm))) diff --git a/src/library/base/R/rowsum.R b/src/library/base/R/rowsum.R new file mode 100644 index 00000000000..ec593d8ed68 --- /dev/null +++ b/src/library/base/R/rowsum.R @@ -0,0 +1,32 @@ +rowsum <- function(x, group, reorder=T) { + if (!is.numeric(x)) stop("x must be numeric") + if (is.matrix(x)) dd <- dim(x) + else dd <- c(length(x), 1) + n <- dd[1] + + if (length(group) !=n) stop("Incorrect length for 'group'") + if (any(is.na(group))) stop("Missing values for 'group'") + na.indicator <- max(1,x[!is.na(x)]) * n #larger than any possible sum + x[is.na(x)] <- na.indicator + + if (!is.numeric(group)) group <- as.factor(group) + storage.mode(x) <- 'double' + temp <- .C("rowsum", dd= as.integer(dd), + as.double(na.indicator), + x = x, + as.double(group)) + new.n <- temp$dd[1] + ugroup <- unique(group) + if (is.matrix(x)){ + new.x <- temp$x[1:new.n,] + dimnames(new.x) <- list(ugroup, dimnames(x)[[2]]) + if (reorder) new.x <- new.x[order(ugroup), ] + } + else { + new.x <- temp$x[1:new.n] + names(new.x) <- ugroup + if (reorder) new.x <- new.x[order(ugroup)] + } + + ifelse(new.x ==na.indicator, NA, new.x) + } diff --git a/src/library/base/R/scan.R b/src/library/base/R/scan.R index c7a3af1e9fb..08687b174eb 100644 --- a/src/library/base/R/scan.R +++ b/src/library/base/R/scan.R @@ -5,9 +5,9 @@ scan <- na.strings<-c(na.strings,"") if(!missing(n)) { if(missing(nmax)) - nmax <- n/length(what) + nmax <- n / pmax(length(what), 1) else - stop("Either specify 'nmax' or 'n', but not both.") + stop("Either specify `nmax' or `n', but not both.") } .Internal(scan(file, what, nmax, sep, skip, nlines, na.strings,flush,strip.white, quiet)) diff --git a/src/library/base/R/seq.R b/src/library/base/R/seq.R index fdd80e4d3e8..b045c63e24b 100644 --- a/src/library/base/R/seq.R +++ b/src/library/base/R/seq.R @@ -31,14 +31,7 @@ seq.default <- function(from = 1, to = 1, by = ((to - from)/(length.out - 1)), dd <- abs(del)/max(abs(to), abs(from)) if (dd < sqrt(.Machine$double.eps)) return(from) - eps <- .Machine$double.eps * max(1, 1/dd) - n <- as.integer(n * (1 + eps)) - if(eps*2*n >= 1) - warning(paste("seq.default(f,t,by): n=",n, - ": possibly imprecise intervals")) - if(by>0) while(from+ n*by > to) n <- n - 1 - else while(from+ n*by < to) n <- n - 1 - + n <- as.integer(n + 1e-7) from + (0:n) * by } else if(length.out < 0) diff --git a/src/library/base/R/source.R b/src/library/base/R/source.R index 9dac3254ce4..20432717f3a 100644 --- a/src/library/base/R/source.R +++ b/src/library/base/R/source.R @@ -1,15 +1,15 @@ source <- function(file, local=FALSE, echo = verbose, print.eval=echo, - verbose= .Options$verbose, prompt.echo = .Options$prompt, - max.deparse.length=150) + verbose= .Options$verbose, prompt.echo = .Options$prompt, + max.deparse.length=150) { envir <- if (local) sys.frame(sys.parent()) else .GlobalEnv if(!missing(echo)) { - if(!is.logical(echo)) stop("echo must be logical") - if(!echo && verbose) { - warning("verbose is TRUE, echo not; ... coercing 'echo <- TRUE'") - echo <- TRUE - } + if(!is.logical(echo)) stop("echo must be logical") + if(!echo && verbose) { + warning("verbose is TRUE, echo not; ... coercing 'echo <- TRUE'") + echo <- TRUE + } } if(verbose) { cat("'envir' chosen:"); print(envir) } Ne <- length(exprs <- parse(n = -1, file = file)) @@ -18,10 +18,10 @@ source <- if (Ne == 0) return(invisible()) ass1 <- expression(y <- x)[[1]][[1]] #-- ass1 : the '<-' symbol/name if(echo) { - ## Reg.exps for string delimiter/ NO-string-del / odd-number-of-str.del - ## needed, when truncating below - sd <- "\""; nos <- "[^\"]*" - oddsd <- paste("^",nos,sd,"(",nos,sd,nos,sd,")*",nos,"$", sep="") + ## Reg.exps for string delimiter/ NO-string-del / odd-number-of-str.del + ## needed, when truncating below + sd <- "\""; nos <- "[^\"]*" + oddsd <- paste("^",nos,sd,"(",nos,sd,nos,sd,")*",nos,"$", sep="") } for (i in 1:Ne) { if(verbose) @@ -32,12 +32,12 @@ source <- 12, 1e6)# drop "expression(" nd <- nchar(dep) -1 # -1: drop ")" do.trunc <- nd > max.deparse.length - dep <- substr(dep, 1, if(do.trunc)max.deparse.length else nd) - cat("\n", prompt.echo, dep, - if(do.trunc) - paste(if(length(grep(sd,dep)) && length(grep(oddsd,dep))) - " ...\" ..." else " ....", "[TRUNCATED] "), - "\n", sep="") + dep <- substr(dep, 1, if(do.trunc)max.deparse.length else nd) + cat("\n", prompt.echo, dep, + if(do.trunc) + paste(if(length(grep(sd,dep)) && length(grep(oddsd,dep))) + " ...\" ..." else " ....", "[TRUNCATED] "), + "\n", sep="") } yy <- eval(ei, envir) i.symbol <- mode(ei[[1]]) == "name" @@ -70,14 +70,15 @@ sys.source <- function (file) demo <- function(topic, device = x11, directory.sep = "/") { - Topics <-cbind(graphics = c("graphics","graphics.R", "G"), - image = c("graphics","image.R", "G"), - lm.glm = c("models", "lm+glm.R", "G"), - glm.vr = c("models", "glm-v+r.R", ""), - nlm = c("nlm", "valley.R", ""), - recursion= c("language","recursion.R", "G"), - scoping = c("language","scoping.R", ""), - is.things= c("language","is-things.R", "") + Topics <-cbind(graphics = c("graphics", "graphics.R", "G"), + image = c("graphics", "image.R", "G"), + lm.glm = c("models", "lm+glm.R", "G"), + glm.vr = c("models", "glm-v+r.R", ""), + nlm = c("nlm", "valley.R", ""), + recursion = c("language", "recursion.R", "G"), + scoping = c("language", "scoping.R", ""), + is.things = c("language", "is-things.R", ""), + dyn.load = c("dynload", "zero.R", "") ) dimnames(Topics)[[1]] <- c("dir", "file", "flag") topic.names <- dimnames(Topics)[[2]] @@ -104,27 +105,35 @@ demo <- function(topic, device = x11, directory.sep = "/") "demos", Topics["dir", i.top], Topics["file", i.top], sep= directory.sep), - echo = TRUE, max.deparse.length=10000) + echo = TRUE, max.deparse.length=250) } } example <- function(topic, package= .packages(), lib.loc = .lib.loc, - echo = TRUE, verbose = .Options$verbose, - prompt.echo = paste(abbreviate(topic, 6),"> ", sep=""), - directory.sep = "/") + echo = TRUE, verbose = .Options$verbose, + prompt.echo = paste(abbreviate(topic, 6),"> ", sep=""), + directory.sep = "/") { topic <- substitute(topic) - if (!is.character(topic)) topic <- deparse(topic)[1] - - for (lib in lib.loc) - for (pkg in package) { - file <- system.file(paste("R-ex",directory.sep,topic,".R", sep=""), - pkg = pkg, lib = lib) + if(!is.character(topic)) topic <- deparse(topic)[1] + file <- "" + for(lib in lib.loc) + for(pkg in package) { + AnIndexF <- system.file(paste("help","AnIndex",sep=directory.sep), + pkg, lib) + if(AnIndexF != "") { + AnIndex <- scan(AnIndexF,what=c("c","c"),quiet=TRUE) + i <- match(topic,AnIndex[seq(1,length(AnIndex),2)],-1) + if(i != -1) + file <- system.file(paste("R-ex",directory.sep,AnIndex[2*i], + ".R", sep=""), + pkg = pkg, lib = lib) + } if(file != "") break } if(file == "") stop(paste("Couldn't find '", topic, "' example", sep="")) if(pkg != "base") library(pkg, lib = lib, character.only = TRUE) source(file, echo = echo, prompt.echo = prompt.echo, - verbose = verbose, max.deparse.length=10000) + verbose = verbose, max.deparse.length=250) } diff --git a/src/library/base/R/symnum.R b/src/library/base/R/symnum.R index a5c923859bc..3d149f7e8b0 100644 --- a/src/library/base/R/symnum.R +++ b/src/library/base/R/symnum.R @@ -6,7 +6,7 @@ symnum <- function(x, cutpoints = c( .3, .6, .8, .9, .95), lower.triangular = corr & is.matrix(x), diag.lower.tri = corr & !is.null(show.max)) { - ## Martin Maechler, 21 Jan 94; Dedicated to Benjamin Schaad, born that day + ## Martin Maechler, 21 Jan 1994; Dedicated to Benjamin Schaad, born that day ##--------------- Argument checking ----------------------------- eval(corr) @@ -37,12 +37,7 @@ symnum <- function(x, cutpoints = c( .3, .6, .8, .9, .95), stop(paste("number of cutpoints must be ONE", if(corr)"LESS" else "MORE", "than number of symbols")) - ##: Scor <- as.character(cut(x, breaks= cutpoints, labels= symbols)) - ##:-- more efficiently, using the function from within cut : - iS <- - .C("bincode2", x= as.double(x), length(x), - as.double(cutpoints), as.integer(ns+1), - code= integer(length(x)), include = TRUE, NAOK = TRUE)$code + iS <- cut(x, breaks=cutpoints, include.lowest=TRUE, labels= FALSE) if(any(ii <- is.na(iS))) { ##-- can get 0, if x[i]== minc --- only case ? iS[which(ii)[abs(x[ii] - minc) < eps]] <- 1 #-> symbol[1] diff --git a/src/library/base/R/system.unix.R b/src/library/base/R/system.unix.R index b8ff01718d1..3184d802b75 100644 --- a/src/library/base/R/system.unix.R +++ b/src/library/base/R/system.unix.R @@ -6,21 +6,17 @@ append.file = function(f1,f2) {# append to 'f1' the file 'f2': system(paste("cat", f2, ">>", f1), trash.errors= TRUE) }, - show.libraries = function(lib.loc, fsep) { - # result of library() - file <- tempfile("R.") - on.exit(unlink(file)) - first <- TRUE - for (lib in lib.loc) { - cat(paste(ifelse(first, "", "\n"), "Packages in library `", - lib, "':\n\n", sep = ""), file = file, - append = TRUE) - .Platform$ append.file(file, - paste(lib, "LibIndex", sep = fsep)) - if(first)first <- FALSE - } - .Platform$ show.file(file) - }, + show.data = function(package,lib.loc,fsep) { + ## give `index' of all possible data sets + for (lib in lib.loc) + for (pkg in package) { + INDEX <- system.file(paste("data", "index.doc", sep = fsep), + pkg, lib) + if (INDEX != "") { + cat(paste("\n\nData sets in package `", pkg, "':\n\n", + sep = fsep)) + .Platform$ show.file(INDEX) + }}}, ) bug.report <- function(send=TRUE, method=.Options$mailer) @@ -77,70 +73,6 @@ bug.report <- function(send=TRUE, method=.Options$mailer) } } - -data <- function(..., list = character(0), package =c(.packages(), .Autoloaded), - lib.loc = .lib.loc, verbose = .Options$verbose) { - names <- c(as.character(substitute(list(...))[-1]), list) - if (!missing(package)) - if (is.name(y <- substitute(package)))# && !is.character(package)) - package <- as.character(y) - found <- FALSE - fsep <- .Platform$file.sep - if (length(names) == 0) { ## give `index' of all possible data sets - file <- tempfile("Rdata.") - on.exit(unlink(file)) - for (lib in lib.loc) - for (pkg in package) { - INDEX <- system.file(paste("data", "index.doc", sep = fsep), - pkg, lib) - if (INDEX != "") { - cat(paste(ifelse(found, "\n", ""), - "Data sets in package `", pkg, "':\n\n", sep=""), - file = file, append = TRUE) - .Platform$ append.file(file, INDEX) - if(!found) found <- TRUE - } - } - if (found) - .Platform$ show.file(file) - } - else for (name in names) { - dn <- paste("data", name, sep = fsep) - files <- system.file(paste(dn, ".*", sep = ""), package, lib.loc) - found <- FALSE - if (files != "") { - subpre <- paste(".*", fsep, sep="") - for (file in files) { - if(verbose) - cat("name=",name,":\t file= ...",fsep, - sub(subpre,"",file),"::\t", sep="") - if (found) break - found <- TRUE - ext <- sub(".*\\.", "", file) - ## make sure the match is really for `name.ext' - if (sub(subpre, "", file) != paste(name, ".", ext, sep = "")) - found <- FALSE - else - switch(ext, - "R" =, "r" = source(file), - "RData" =, "rdata" =, "rda" = load(file), - "TXT" =, "txt" =, "tab" = - assign(name, read.table(file, header= TRUE), - env = .GlobalEnv), - "CSV" =, "csv" = - assign(name, read.table(file, header= TRUE, sep=";"), - env = .GlobalEnv), - ## otherwise - found <- FALSE) - if (verbose) cat(if(!found) "*NOT* ", "found\n") - } - } - if (!found) - warning(paste("Data set `", name, "' not found", sep = "")) - } - invisible(names) -} - date <- function() { system("date", intern = TRUE) } getenv <- function(x) { @@ -158,7 +90,8 @@ getenv <- function(x) { } help <- function(topic, offline = FALSE, package = c(.packages(), .Autoloaded), - lib.loc = .lib.loc, verbose = .Options$verbose) { + lib.loc = .lib.loc, verbose = .Options$verbose, + htmlhelp = .Options$htmlhelp) { if (!missing(package)) if (is.name(y <- substitute(package)))# && !is.character(package)) package <- as.character(y) @@ -194,7 +127,7 @@ help <- function(topic, offline = FALSE, package = c(.packages(), .Autoloaded), cat ("\t\t\t\t\t\tHelp file name `", sub(".*/", "", file), ".Rd'\n", sep = "") if (!offline) { - if(!is.null(.Options$htmlhelp) && .Options$htmlhelp){ + if(!is.null(htmlhelp) && htmlhelp){ file <- gsub(paste("/help/", topic, sep=""), paste("/html/", topic, sep=""), file) @@ -267,23 +200,6 @@ system.file <- function(file = "", pkg = .packages(), lib = .lib.loc) { system(paste("${RHOME}/bin/filename", FILES), intern = TRUE) } -system.time <- function(expr) { - ## Purpose: Return CPU (and other) times that `expr' used .. - ## Argument expr: `any' valid R expression - loc.frame <- sys.frame(sys.parent(1)) - on.exit(cat("Timing stopped at:", proc.time() - time, "\n")) - expr <- substitute(expr) - time <- proc.time() - eval(expr, envir = loc.frame) - new.time <- proc.time() - on.exit() - if(length(new.time) == 3) new.time <- c(new.time, 0, 0) - if(length(time) == 3) time <- c( time, 0, 0) - new.time - time -} - -unix.time <- .Alias(system.time) - tempfile <- function(pattern = "file") { system(paste("for p in", paste(pattern, collapse = " "), ";", "do echo /tmp/$p$$; done"), diff --git a/src/library/base/R/system.win.R b/src/library/base/R/system.win.R index c47dd9efc13..2507f4ec56f 100644 --- a/src/library/base/R/system.win.R +++ b/src/library/base/R/system.win.R @@ -2,32 +2,28 @@ list(OS.type = "Windows", file.sep = "\\\\", dynlib.ext = ".dll", - show.file = function(file) .NotYetImplemented(), - append.file = function(f1,f2) .NotYetImplemented(), # concat(f1,f2) - show.libraries = function(lib.loc, fsep) .NotYetImplemented(), + ## The next few are from Guido's: + show.file = function(filename) { + a <- scan(filename,what="c",sep="\n",quiet=TRUE) + for (i in 1:length(a)) + cat(a[i],"\n")}, + append.file = function(f1,f2) {# append to 'f1' the file 'f2': + a <- scan(f1, what = "c", sep = "\n", quiet = TRUE) + for (i in 1:length(a)) cat(a[i], "\n",file=f2,append=TRUE) + }, + show.data = function(package,lib.loc,fsep) { + ## give `index' of all possible data sets + for (lib in lib.loc) + for (pkg in package) { + INDEX <- system.file(paste("data", "index.doc", sep = fsep), + pkg, lib) + if (INDEX != "") { + cat(paste("\n\nData sets in package `", pkg, "':\n\n", + sep = fsep)) + .Platform$ show.file(INDEX) + }}}, ) -data <- function(..., list = character(0), package = .packages(), - lib.loc = .lib.loc) { - ## FIXME add support for package and lib.loc args - names <- c(as.character(substitute(list(...))[-1]), list) - if (length(names) == 0) { - datafile<-system.file("data","index.doc") - if( datafile == "" ) - stop("no index file for data") - xx<-scan(datafile,skip=3,what="",sep="\t") - cat(" R DATA SETS \n") - cat(t(matrix(xx[!is.na(xx)],nc=2,byrow=TRUE)),sep=c("\t\t","\n")) - } - else - for (name in names) { - file <- system.file("data", name) - if(file == "") stop(paste("no data set called", name)) - else source(file) - } - invisible(names) -} - getenv <- function(names) .Internal(getenv(names)) help <- function(topic, package = .packages(), lib.loc = .lib.loc) { @@ -39,28 +35,6 @@ library <- function(name, help, lib.loc = .lib.loc, .NotYetImplemented() } -library.dynam <- function(chname, package = .packages(), lib.loc = .lib.loc) { - ## FIXME (this is == Unix with changes - ## ----- 1) .dll instead of .so 2) "\\" for "/" - if (!exists(".Dyn.libs")) - assign(".Dyn.libs", character(0), envir = .AutoloadEnv) - if(missing(chname) || (LEN <- nchar(chname)) == 0) - return(.Dyn.libs) - if (substr(chname, LEN - 3, LEN) == ".dll") { - chname <- substr(chname, 1, LEN - 4) - } - if (is.na(match(chname, .Dyn.libs))) { - file <- system.file(paste("libs", "\\", chname, ".", "dll", sep = ""), - package, lib.loc) - if (file == "") { - stop(paste("dynamic library `", chname, "' not found", sep = "")) - } - .Internal(dyn.load(file)) - assign(".Dyn.libs", c(.Dyn.libs, chname), envir = .AutoloadEnv) - } - invisible(.Dyn.libs) -} - system <- function(call, intern = FALSE) .Internal(system(call, intern)) diff --git a/src/library/base/R/text.R b/src/library/base/R/text.R index 85fc97738d1..094bf9c5734 100644 --- a/src/library/base/R/text.R +++ b/src/library/base/R/text.R @@ -8,5 +8,6 @@ text.default <- function(x, y = NULL, labels = seq(along = x), adj = if (!missing(y) && (is.character(y) || is.expression(y))) { labels <- y; y <- NULL } - .Internal(text(xy.coords(x,y), as.char.or.expr(labels), adj, ...)) + .Internal(text(xy.coords(x,y, recycle=TRUE), + as.char.or.expr(labels), adj, ...)) } diff --git a/src/library/base/R/time.R b/src/library/base/R/time.R new file mode 100644 index 00000000000..7e4246bced4 --- /dev/null +++ b/src/library/base/R/time.R @@ -0,0 +1,14 @@ +system.time <- function(expr) { + loc.frame <- sys.frame(sys.parent(1)) + on.exit(cat("Timing stopped at:", proc.time() - time, "\n")) + expr <- substitute(expr) + time <- proc.time() + eval(expr, envir = loc.frame) + new.time <- proc.time() + on.exit() + if(length(new.time) == 3) new.time <- c(new.time, 0, 0) + if(length(time) == 3) time <- c( time, 0, 0) + new.time - time +} + +unix.time <- .Alias(system.time) diff --git a/src/library/base/R/ts.R b/src/library/base/R/ts.R index ee770c52f65..820fe6ca350 100644 --- a/src/library/base/R/ts.R +++ b/src/library/base/R/ts.R @@ -26,7 +26,7 @@ ts <- function(data=NA, start=1, end=numeric(0), frequency=1, deltat=1, } if(missing(frequency)) frequency <- 1/deltat - if(missing(deltat)) deltat <- 1/deltat + else if(missing(deltat)) deltat <- 1/frequency if(frequency > 1 && abs(frequency - round(frequency)) < ts.eps) frequency <- round(frequency) @@ -50,10 +50,10 @@ ts <- function(data=NA, start=1, end=numeric(0), frequency=1, deltat=1, data <- if(nseries == 1) { if(ndata < nobs) rep(data, length=nobs) - else if(nobs > ndata) data[1:nobs] + else if(ndata > nobs) data[1:nobs] } else { if(ndata < nobs) data[rep(1:ndata, length=nobs)] - else if(nobs > ndata) data[1:nobs,] + else if(ndata > nobs) data[1:nobs,] } attr(data, "tsp") <- c(start, end, frequency)#-- order is fix ! attr(data, "class") <- "ts" @@ -67,7 +67,7 @@ tsp <- function(x) attr(x, "tsp") cl <- class(x) attr(x,"tsp") <- value class(x) <- - if (is.null(value) && inherits(x,"ts")) cl["ts" != cl] else c("ts",cl) + if (is.null(value) && inherits(x,"ts")) cl["ts" != cl] else c("ts",cl) x } @@ -155,12 +155,33 @@ print.ts <- function(x, calendar, ...) } plot.ts <- - function (x, type="l", xlim=NULL, ylim=NULL, xlab = "Time", ylab, log="", - col=par("col"), bg=NA, pch=par("pch"), lty=par("lty"), - axes = TRUE, frame.plot = axes, ann = par("ann"), main = NULL, ...) + function (x, y=NULL, type="l", xlim=NULL, ylim=NULL, xlab = "Time", ylab, + log="", col=par("col"), bg=NA, pch=par("pch"), cex=par("cex"), + lty=par("lty"), lwd=par("lwd"), axes = TRUE, + frame.plot = axes, ann = par("ann"), main = NULL, ...) { - if(missing(ylab)) ylab <- deparse(substitute(x)) + xlabel <- if (!missing(x)) deparse(substitute(x)) else NULL + ylabel <- if (!missing(y)) deparse(substitute(y)) else NULL x <- as.ts(x) + if(!is.null(y)) { + ## want ("scatter") plot of y ~ x + y <- as.ts(y) + xy <- xy.coords(x, y, xlabel, ylabel, log) + xlab <- xy$xlab + ylab <- if (missing(ylab)) xy$ylab else ylab + xlim <- if (is.null(xlim)) range(xy$x, finite=TRUE) else xlim + ylim <- if (is.null(ylim)) range(xy$y, finite=TRUE) else ylim + plot.default(xy, type = "n", + xlab=xlab, ylab = ylab, xlim=xlim, ylim=ylim, + log=log, col=col,bg=bg,pch=pch,axes=axes, + frame.plot=frame.plot,ann=ann, main=main, ...) + text(xy, labels = + if(all(tsp(x)==tsp(y))) formatC(time(x),wid=1) else seq(along=x), + col=col, cex=cex) + lines(xy, col=col, lty=lty, lwd=lwd) + return(invisible()) + } + if(missing(ylab)) ylab <- xlabel time.x <- time(x) if(is.null(xlim)) xlim <- range(time.x) if(is.null(ylim)) ylim <- range(x, finite=TRUE) @@ -171,12 +192,13 @@ plot.ts <- lines.default(time.x, x[,i], col=col[(i-1)%%length(col) + 1], lty=lty[(i-1)%%length(lty) + 1], + lwd=lwd[(i-1)%%length(lwd) + 1], bg = bg[(i-1)%%length(bg) + 1], pch=pch[(i-1)%%length(pch) + 1], type=type) } else { - lines.default(time.x, x, col=col[1], bg=bg, lty=lty[1], + lines.default(time.x, x, col=col[1], bg=bg, lty=lty[1], lwd=lwd[1], pch=pch[1], type=type) } if (ann) diff --git a/src/library/base/R/which.R b/src/library/base/R/which.R index f4457cddd48..38614d5e9bb 100644 --- a/src/library/base/R/which.R +++ b/src/library/base/R/which.R @@ -4,7 +4,7 @@ which <- function(logic, arr.ind = FALSE) stop("argument to \"which\" is not logical") if(0 == (n <- length(logic))) return(integer(0)) - wh <- (1:n)[logic] + wh <- (1:n)[logic & !is.na(logic)] if ((m <- length(wh)) > 0) { dl <- dim(logic) if (is.null(dl) || !arr.ind) { diff --git a/src/library/base/man/Bessel.Rd b/src/library/base/man/Bessel.Rd index 63678c1fb59..65f21bc5e1e 100644 --- a/src/library/base/man/Bessel.Rd +++ b/src/library/base/man/Bessel.Rd @@ -1,5 +1,6 @@ \name{Bessel} \title{Bessel Functions} +\alias{bessel} \alias{besselI} \alias{besselJ} \alias{besselK} @@ -14,14 +15,16 @@ gammaCody(x) } \description{Bessel Functions of integer and fractional order, of first and second kind, \eqn{J_{\nu}}{J(nu)} and \eqn{Y_{\nu}}{Y(nu)}, and - Modified Bessel functions \eqn{I_{\nu}}{I(nu)} and \eqn{K_{\nu}}{K(nu)}. + Modified Bessel functions (of first and third kind), + \eqn{I_{\nu}}{I(nu)} and \eqn{K_{\nu}}{K(nu)}. \code{gammaCody} is the \eqn{(\Gamma)} Function as from the Specfun package and originally used in the Bessel code. } \arguments{ \item{x}{numeric, \eqn{\ge 0}{>= 0}.} - \item{nu}{numeric, \eqn{\ge 0}{>= 0}. The \emph{order} of the + \item{nu}{numeric; \eqn{\ge 0}{>= 0} unless in \code{besselK} which + is symmetric in \code{nu}. The \emph{order} of the corresponding Bessel function.} \item{expon.scaled}{logical; if \code{TRUE}, the results are exponentially scaled in order to avoid overflow @@ -29,7 +32,8 @@ gammaCody(x) respectively.} } \value{ - + numeric of the same length of \code{x} with the (scaled, if + \code{expon.scale=T}) values of the corresponding Bessel function. } \details{ The underlying code for these functions stem from \emph{Netlib}, diff --git a/src/library/base/man/Foreign.Rd b/src/library/base/man/Foreign.Rd index 806b2db4bc8..aa2c736964e 100644 --- a/src/library/base/man/Foreign.Rd +++ b/src/library/base/man/Foreign.Rd @@ -16,9 +16,11 @@ \item{DUP}{if \code{TRUE} then arguments are ``duplicated'' before their address is passed to C or Fortran.} } -\value{ +\description{ The functions \code{.C} and \code{.Fortran} can be used to make calls to C and Fortran code. +} +\value{ The functions return a list similar to the \code{\dots} list of arguments passed in, but reflecting any changes made by the C or Fortran code. @@ -26,7 +28,33 @@ changes made by the C or Fortran code. These calls are typically made in conjunction with \code{\link{dyn.load}} which links DLLs to \R. } -\seealso{ -\code{\link{dyn.load}}. +%%-- This note by Thomas Lumley, (minimally edited by MM): +\note{\emph{\code{DUP=FALSE} is dangerous.} + +There are two important dangers with \code{DUP=FALSE}. The first is that +garbage collection may move the object, resulting in the pointers +pointing nowhere useful and causing hard-to-reproduce bugs. + +The second is that if you pass a formal parameter of the calling +function to \code{.C}/\code{.Fortran} with \code{DUP=FALSE}, it may not +necessarily be copied. You may be able to change not only the local +variable but the variable one level up. This will also be very hard to +trace. + +1. If your C/Fortran routine calls back any \R function including +\code{S_alloc}/\code{R_alloc} then do not use \code{DUP=FALSE}. Do not +even think about it. Calling almost any \R function could trigger +garbage collection. + +2. If you don't trigger garbage collection it is safe and useful to set +\code{DUP=FALSE} if you don't change any of the variables that might be +affected, e.g., + +\code{.C("Cfunction", input=x, output=numeric(10))}. + +In this case the output variable didn't exist before the call so it can't +cause trouble. If the input variable is not changed in \code{Cfunction} you are +safe. } +\seealso{\code{\link{dyn.load}}.} \keyword{programming} diff --git a/src/library/base/man/Memory.Rd b/src/library/base/man/Memory.Rd new file mode 100644 index 00000000000..d0ffa20eb87 --- /dev/null +++ b/src/library/base/man/Memory.Rd @@ -0,0 +1,64 @@ +\name{Memory} +\title{Memory Available for Data Storage} +\usage{ +R --vsize v --nsize n +} +\arguments{ + \item{v}{Use \code{v} megabytes of heap memory} + \item{n}{Use \code{n} cons cells.} +} +\description{ + Use command line options to set the memory available for \R. +} +\details{ + \R (currently) uses a static memory model. This means that when it + starts up, it asks the operating system to reserve a fixed amount of + memory for it. The size of this chunk cannot be changed + subsequently. Hence, it can happen that not enough memory was + allocated, e.g., when trying to read large data sets into R. + + In these cases, you should restart \R (after saving your current + workspace) with more memory available, using the command line + options \code{--nsize} and \code{--vsize}. To understand these + options, one needs to know that R maintains separate areas for fixed + and variable sized objects. The first of these is allocated as an + array of ``cons cells'' (Lisp programmers will know what they are, + others may think of them as the building blocks of the language + itself, parse trees, etc.), and the second are thrown on a + ``heap''. The \code{--nsize} option can be used to specify the + number of cons cells (each occupying 16 bytes) which \R is to use + (the default is 200000), and the \code{--vsize} option to specify + the size of the vector heap in million bytes (the default is + 2). Only integers are allowed for both options. + + E.g., to read in a table of 5000 observations on 40 numeric + variables, \code{R --vsize 6} should do. + + Note that the information on where to find vectors and strings on + the heap is stored using cons cells. Thus, it may also be necessary + to allocate more space for cons cells in order to perform + computations with very ``large'' variable-size objects. + + You can find out the current memory consumption (the proportion of + heap and cons cells used) by typing \code{\link{gc}()} at the \R + prompt. This may help you in finding out whether to increase + \code{--vsize} or \code{--nsize}. Note that following + \code{\link{gcinfo}(TRUE)}, automatic garbage collection always + prints memory use statistics. + + \R will tell you whether you ran out of cons or heap memory. + + When using \code{\link{read.table}}, the memory requirements are in + fact higher than anticipated, because the file is first read in as + one long string which is then split again. Use \code{\link{scan}} if + possible in case you run out of memory when reading in a large table. +} +\seealso{ + \code{\link{gc}} for information on the garbage collector. +} +\examples{ +# Start R with 15MB of heap memory and 1 million cons cells +\dontrun{ +R --vsize 15 --nsize 1000000 +} +} diff --git a/src/library/base/man/Random.Rd b/src/library/base/man/Random.Rd index 20bbed4ba6b..463bd6db214 100644 --- a/src/library/base/man/Random.Rd +++ b/src/library/base/man/Random.Rd @@ -1,24 +1,99 @@ \name{Random} \title{Random Number Generation} \usage{ -.Random.seed <- c(n1, n2, n3) +.Random.seed <- c(rng.kind, n1, n2, \dots) +save.seed <- .Random.seed + +RNGkind(kind=NULL) } \alias{.Random.seed} +\alias{RNG} +\alias{RNGkind} \description{ - \code{.Random.seed} is an integer vector of length 3, containing the - ``seed'' for all random number generation in \R. The Wichmann-Hill - generator is used which has a cycle length of 6.9536e12 (= - \code{prod(p-1)/4} where \code{p} is the length 3 vector of primes, - below), see p.123 of Applied Statistics (1984) vol.33 which corrects - the original article. + \code{.Random.seed} is an integer vector, containing the + random number generator (RNG) \bold{state} for random number generation in \R. + + \code{RNGkind} is a more friendly interface to query or set the kind + of RNG in use. +} +\arguments{ + \item{kind}{character or \code{NULL}. If \code{kind} is a character + string, set \R's RNG to the kind desired, if it's \code{NULL}, + return the currently used RNG.} + \item{rng.kind}{integer code in \code{0:k} for the above \code{kind}.} + \item{n1,n2,\dots}{integers.} +} +\details{ + +Currently available RNG kinds + + \itemize{ + \item "Wichmann-Hill": \code{.Random.seed[1] == 0} + + The seed, \code{.Random.seed[-1] == r[1:3]} is an integer vector of + length 3, where each \code{r[i]} is in \code{1:p[i]}, where + \code{p} is the length 3 vector of primes, + \code{p = (30269, 30307, 30323)}. + The Wichmann-Hill generator has a cycle length of + 6.9536e12 (= \code{prod(p-1)/4} ), see p.123 of + Applied Statistics (1984) vol.33 which corrects the original article. + + \item "Marsaglia-Multicarry": \code{.Random.seed[1] == 1} + + A \emph{multiply-with-carry} RNG is used, as recommended by + George Marsaglia in his post to the mailing list + \file{sci.stat.math} on September 29, 1997. It has a period of + \eqn{> 2^60} and has passed all tests (according to Marsaglia). + + \item "Super-Duper": \code{.Random.seed[1] == 2} + + Marsaglia's famous Super-Duper from the 70's. This is the original + version which does \emph{not} pass the MTUPLE test of the Diehard + battery. + It has a period of \eqn{\approx 4.6\times 10^{18}}{4.6*10^18}. + + We use the implementation as by Reeds et al. (1982-'83), with the + additional non-0 seed measure (see note below). + + The two seeds are the Tausworthe and Congruence long integers, + respectively. + A one-to-one mapping to S's \code{.Random.seed[1:12]} is possible + but hasn't been done yet. + +%%BUG 'stack ...' \item "Rand": \code{.Random.seed[1] == 3} +%%BUG 'stack ...' +%%BUG 'stack ...' This is the cheap Unix built-in generator which is not at all +%%BUG 'stack ...' recommended for simulation. Further, you can only set, but never +%%BUG 'stack ...' retrieve the internal seed used. Therefore, the value of +%%BUG 'stack ...' \code{.Random.seed} is of no relevance (but you can set it!). + + % NOT YET: + % \item "Mersenne-Twister": \code{.Random.seed[1] == 4} + } + + --- --- to be expanded --- --- + + ((Planned additions are + "Mersenne-Twister", + "Knuth-TAOCP" (from TAOCP, Vol.2, 3rd ed.,1997), + "Ecuyer-...", + "Eichenauer-...")) + + \bold{Note}: If any of \code{.Random.seed[i]} (\eqn{i>1}) is set to + \code{0}, it will be substituted with \code{1}, in the next call to a + random number generator, such as \code{\link{runif}}. } \value{ - \code{.Random.seed == r[1:3]}, where \code{r[i]} is in \code{1:p[i]}, - and \code{p = (30269, 30307, 30323)}. + \code{.Random.seed} is an \code{\link{integer}} vector whose first + element \emph{codes} the kind of RNG and therefore is in \code{0:k} + where {k+1} is the number of available RNGs. + \cr + In the underlying C, \code{.Random.seed[-1]} is used as \code{unsigned long} + (32 bits at least); in \R, whose \code{integer}s are C's \code{long}, + \code{.Random.seed[i]} can therefore be negative for \eqn{i > 1}. - \emph{Note}: If any of \code{.Random.seed[i]} is set to \code{0}, it - will be substituted with \code{1}, in the next call to a random number - generator, such as \code{\link{runif}}. + \code{RNGkind} returns the RNG in use \emph{before} the call, invisibly + if \code{kind} isn't \code{NULL}. } \references{ B.A. Wichmann and I. D. Hill (1982). @@ -28,30 +103,52 @@ A. De Matteis and S. Pagnutti (1993). \emph{Long-range Correlation Analysis of the Wichmann-Hill Random - Number Generator}, Statist. Comput., \bold{3}, 67-70. + Number Generator}, Statist. Comput., \bold{3}, 67-70. + + Marsaglia, G. (1997). \emph{A random number generator for C}. Discussion + paper, posting on usenet newsgroup \code{sci.stat.math}. + + Marsaglia, G. and Zaman, A. (1994). \emph{Some portable very-long-period + random number generators}. Computers in Physics, \bold{8}, 117-121. } \note{ Initially, there is no seed; a new one is created, using ``Randomize''. Hence, student exercises will each have different simulation results, by default. } -\seealso{ - \code{\link{runif}}, \code{\link{rnorm}}, \ldots. -} +\author{of RNGkind: Martin Maechler} + +\seealso{\code{\link{runif}}, \code{\link{rnorm}}, \ldots.} +% this is ./Uniform.Rd \examples{ runif(1); .Random.seed; runif(1); .Random.seed ## If there is no seed, a ``random'' new one is created: rm(.Random.seed); runif(1); .Random.seed +RNGkind("Wich")# (partial string matching on 'kind') p.WH <- c(30269, 30307, 30323) a.WH <- c( 171, 172, 170) -R.seed <- function(i.seed = .Random.seed) (a.WH * i.seed) \%\% p.WH +next.WHseed <- function(i.seed = .Random.seed[-1]) (a.WH * i.seed) \%\% p.WH my.runif1 <- function(i.seed = .Random.seed) - { ns <- R.seed(i.seed); sum(ns / p.WH) \%\% 1 } + { ns <- next.WHseed(i.seed[-1]); sum(ns / p.WH) \%\% 1 } -## This shows how `runif(.)' works, just using R functions : +## This shows how `runif(.)' works for Wichmann-Hill, using only R functions: rs <- .Random.seed -R.seed(rs); u <- runif(1); .Random.seed; c(u, my.runif1(rs)) +(WHs <- next.WHseed(rs[-1])) +u <- runif(1) +all(next.WHseed(rs[-1]) == .Random.seed[-1]) +u == my.runif1(rs) + + +## ---- +.Random.seed +ok <- RNGkind() +RNGkind("Super")#matches "Super-Duper" +RNGkind() +.Random.seed # new, corresponding to Super-Duper + +## Reset: +RNGkind(ok) } \keyword{distribution} \keyword{sysdata} diff --git a/src/library/base/man/acid.Rd b/src/library/base/man/acid.Rd index 99bc401b07a..5434067f546 100644 --- a/src/library/base/man/acid.Rd +++ b/src/library/base/man/acid.Rd @@ -4,22 +4,18 @@ \alias{acid} \format{A data frame with 6 observations on 2 variables. \tabular{rlll}{ - [,1] \tab carb \tab numeric \tab Carbohydrate (ml) \cr + [,1] \tab carb\tab numeric \tab Carbohydrate (ml) \cr [,2] \tab opt \tab numeric \tab Optical Density \cr } - } \source{Bennett, N. A. and N. L. Franklin (1954). Statistical analysis in -Chemistry and the Chemical Industry. New York: Wiley - + Chemistry and the Chemical Industry. New York: Wiley } -\description{These data are from an chemical experiment to prepare a standard curve -for the determination of formaldehyde by the addition of chromatropic -acid and concentrated sulpuric acid and the reading of the resulting -purple color on a spectophotometer. - +\description{These data are from a chemical experiment to prepare a + standard curve for the determination of formaldehyde by the addition + of chromatropic acid and concentrated sulpuric acid and the reading + of the resulting purple color on a spectophotometer. } \references{McNeil, D. R. (1977). Interactive Data Analysis. New York: Wiley. - } \keyword{datasets} diff --git a/src/library/base/man/add1.Rd b/src/library/base/man/add1.Rd index 7fb52462539..ad3da7daced 100644 --- a/src/library/base/man/add1.Rd +++ b/src/library/base/man/add1.Rd @@ -4,21 +4,21 @@ \name{add1} \title{Add or Drop All Possible Single Terms to a Model} \usage{ -add1(object, scope, ...) +add1(object, scope, \dots) add1.default(object, scope, scale = 0, test=c("none", "Chisq"), - k = 2, trace = FALSE, ...) + k = 2, trace = FALSE, \dots) add1.lm(object, scope, scale = 0, test=c("none", "Chisq", "F"), - x = NULL, k = 2, ...) + x = NULL, k = 2, \dots) add1.glm(object, scope, scale = 0, x = NULL, test=c("none", "Chisq"), - k = 2, ...) + k = 2, \dots) -drop1(object, scope, ...) +drop1(object, scope, \dots) drop1.default(object, scope, scale = 0, test=c("none", "Chisq"), - k = 2, trace = FALSE, ...) + k = 2, trace = FALSE, \dots) drop1.lm(object, scope, scale = 0, all.cols = TRUE, - test=c("none", "Chisq", "F"),k = 2, ...) + test=c("none", "Chisq", "F"),k = 2, \dots) drop1.glm(object, scope, scale = 0, test=c("none", "Chisq"), - k = 2, ...) + k = 2, \dots) } \alias{add1} \alias{add1.default} @@ -33,16 +33,16 @@ drop1.glm(object, scope, scale = 0, test=c("none", "Chisq"), \item{scope}{a formula giving the terms to be considered for adding or dropping.} \item{scale}{an estimate of the residual mean square to be used in - computing Cp. Ignored if 0 or \code{NULL}.} + computing Cp. Ignored if \code{0} or \code{NULL}.} \item{test}{should the results include a test statistic relative to the - original model? The F test is only appropriate for \code{lm} and - \code{aov} models. The Chisq test can be an exact test (\code{lm} - models with known scale) or a likelihood-ratio test depending + original model? The F test is only appropriate for \code{\link{lm}} and + \code{\link{aov}} models. The \eqn{\chi^2}{Chisq} test can be an exact test + (\code{lm} models with known scale) or a likelihood-ratio test depending on the method.} - \item{k}{The penalty constant in AIC/Cp.} - \item{TRACE}{If true, print out progress reports.} + \item{k}{the penalty constant in AIC/Cp.} + \item{trace}{if \code{TRUE}, print out progress reports.} \item{x}{a model matrix containing columns for the fitted model and all - terms in the upper scope. Useful if \code{add1} is to be called + terms in the upper scope. Useful if \code{add1} is to be called repeatedly.} \item{all.cols}{(Provided for compatibility with S.) Logical to specify whether all columns of the design matrix should be used. If @@ -60,29 +60,33 @@ drop1.glm(object, scope, scale = 0, test=c("none", "Chisq"), to be added or dropped: all main effects contained in a second-order interaction must remain, and so on. - The methods for \code{lm} and \code{glm} are more efficient in that - they do not recompute the model matrix and call the \code{fit} methods - directly. + The methods for \code{\link{lm}} and \code{\link{glm}} are more + efficient in that they do not recompute the model matrix and call the + \code{fit} methods directly. The default output table gives AIC, defined as minus twice log - likelihood plus 2p where p is the rank of the model (the number of - effective parameters). This is only defined up to an additive - constant (like log-likelhoods). For linear Guassian models with fixed - scale, the constant is chosen to give Mallows' Cp, RSS/scale + 2p - n. - Where Cp is used, the column is labelled as Cp rather than AIC. + likelihood plus \eqn{2p} where \eqn{p} is the rank of the model (the + number of effective parameters). This is only defined up to an + additive constant (like log-likelhoods). For linear Guassian models + with fixed scale, the constant is chosen to give Mallows' Cp, + \eqn{RSS/scale + 2p - n}. Where Cp is used, the column is labelled as + Cp rather than AIC. } \value{ An object of class \code{"anova"} summarizing the differences in fit between the models. } \author{B.D. Ripley} -\note{These are not fully equivalent to the functions in S. There is no -\code{keep} argument, and the methods used are not quite so -computationally efficient. - -Their authors' definitions of Mallows' Cp and Akaike's AIC are used, not -those of the authors of the models chapter of S. +\note{These are not fully equivalent to the functions in S. There is no + \code{keep} argument, and the methods used are not quite so + computationally efficient. + + Their authors' definitions of Mallows' Cp and Akaike's AIC are used, not + those of the authors of the models chapter of S. } - \seealso{\code{\link{aov}}, \code{\link{lm}}} +\examples{ +example(step)#-> swiss +(alm1 <- add1(lm1, ~ I(Education^2) + .^2)) +} \keyword{models} diff --git a/src/library/base/man/apply.Rd b/src/library/base/man/apply.Rd index d66cc245fac..ad82fd66262 100644 --- a/src/library/base/man/apply.Rd +++ b/src/library/base/man/apply.Rd @@ -42,6 +42,23 @@ apply(x, 2, sort) ma <- matrix(c(1:4, 1, 6:8), nr = 2) ma apply(ma, 1, table) #--> a list of length 2 +apply(ma, 1, quantile)# 5 x n matrix with rownames + +all(dim(ma) == dim(apply(ma, 1:2, sum)))## apply BUG [R <= 0.63.0] + +\testonly{ + apply(x, 2, summary) # 6 x n matrix + apply(x, 1, quantile)# 5 x n matrix + + d.arr <- 2:5 + arr <- array(1:prod(d.arr), d.arr, + list(NULL,letters[1:d.arr[2]],NULL,paste("V",4+1:d.arr[4],sep=""))) + all(apply(arr, 1:2, sum) == t(apply(arr, 2:1, sum))) + + marg <- list(1:2, 2:3, c(2,4), c(1,3), 2:4, 1:3, 1:4) + for(m in marg) print(apply(arr, print(m), sum)) + for(m in marg) print(dim(apply(arr, print(m), quantile)) == c(5,d.arr[m])) +} } \keyword{iteration} \keyword{array} diff --git a/src/library/base/man/backsolve.Rd b/src/library/base/man/backsolve.Rd index 7965d5eb83f..00ce2a8452e 100644 --- a/src/library/base/man/backsolve.Rd +++ b/src/library/base/man/backsolve.Rd @@ -1,14 +1,20 @@ \name{backsolve} -\title{Solve an Upper Triangular System} +\title{Solve an Upper or Lower Triangular System} \usage{ -backsolve(r, x, k=ncol(r)) +backsolve(r, x, k=ncol(r), upper.tri = TRUE, transpose = FALSE) } \alias{backsolve} \arguments{ -\item{r}{an upper triangular matrix giving the coefficients for -the system to be solved. Values below the diagonal are ignored.} + % Name 'r' is not really make sense for upper.tri = FALSE + % Name 'x' is also a misnomer, should rather be 'b'. -- is this S ?? +\item{r}{an upper (or lower) triangular matrix giving the coefficients for +the system to be solved. Values below (above) the diagonal are ignored.} \item{x}{a matrix whose columns give ``right-hand sides'' for the equations.} -\item{k}{The number or columns of \code{r} and rows of \code{x} to use.} +\item{k}{The number of columns of \code{r} and rows of \code{x} to use.} +\item{upper.tri}{logical; if \code{TRUE} (default), the \emph{upper} + \emph{tri}angular part of \code{r} is used. Otherwise, the lower one.} +\item{transpose}{logical; if \code{TRUE}, solve \eqn{r' * y = x} for + \eqn{y}, i.e., \code{t(r) \%*\% y == x}. } \value{ The solution of the triangular system. The result will be a @@ -30,6 +36,10 @@ r <- rbind(c(1,2,3), c(0,0,2)) ( y <- backsolve(r, x <- c(8,4,2)) ) # -1 3 1 r \%*\% y # == x = (8,4,2) +c( y2 <- backsolve(r, x, transpose = TRUE)) # 8 -12 -5 +all(t(r) \%*\% y2 == x)# exactly on Linux (Pentium) +all(y == backsolve(t(r), x, upper = FALSE, transpose = TRUE)) +all(y2 == backsolve(t(r), x, upper = FALSE, transpose = FALSE)) } \keyword{algebra} \keyword{array} diff --git a/src/library/base/man/bug.report.Rd b/src/library/base/man/bug.report.Rd new file mode 100644 index 00000000000..33d5207b811 --- /dev/null +++ b/src/library/base/man/bug.report.Rd @@ -0,0 +1,109 @@ +\name{bug.report} +\title{Send a bug report} +\usage{ +bug.report(send=TRUE, method=.Options$mailer) +} +%- maybe also `usage' for other functions documented here. +\alias{bug.report} +%- Also NEED an `\alias' for EACH other function documented here. +\arguments{ + \item{send}{Mail the report when it is done?} + \item{method}{name of program to mail the report with} +} +\description{ + Invokes an editor to write a bug report and optionally mail it to + the R-bugs list at \code{r-bugs@biostat.ku.dk}. +} + +\value{ +nothing useful +} +\section{When is there a bug?}{ + If R executes an illegal instruction, or dies with an operating +system error message that indicates a problem in the program (as +opposed to something like "disk full"), then it is certainly a bug. + + Taking forever to complete a command can be a bug, but you must +make certain that it was really R's fault. Some commands simply take +a long time. If the input was such that you KNOW it should have been +processed quickly, report a bug. If you don't know whether the +command should take a long time, find out by looking in the manual or +by asking for assistance. + + If a command you are familiar with causes an R error message in a +case where its usual definition ought to be reasonable, it is probably a +bug. If a command does the wrong thing, that is a bug. But be sure you +know for certain what it ought to have done. If you aren't familiar +with the command, or don't know for certain how the command is supposed +to work, then it might actually be working right. Rather than jumping +to conclusions, show the problem to someone who knows for certain. + + Finally, a command's intended definition may not be best for +statistical analysis. This is a very important sort of problem, but +it is also a matter of judgment. Also, it is easy to come to such a +conclusion out of ignorance of some of the existing features. It is +probably best not to complain about such a problem until you have +checked the documentation in the usual ways, feel confident that you +understand it, and know for certain that what you want is not +available. If you are not sure what the command is supposed to do +after a careful reading of the manual this indicates a bug in the +manual. The manual's job is to make everything clear. It is just as +important to report documentation bugs as program bugs. However, we know +that the introductory documentation is seriously inadequate, so you don't +need to report this. + + If the online argument list of a function disagrees with the +manual, one of them must be wrong, so report the bug. +} +\section{How to report a bug}{ + When you decide that there is a bug, it is important to report it and +to report it in a way which is useful. What is most useful is an exact +description of what commands you type, from when you start R until the +problem happens. Always include the version of R, machine, and +operating system that you are using; type `version' in R to print this. + + The most important principle in reporting a bug is to report FACTS, +not hypotheses or categorizations. It is always easier to report the +facts, but people seem to prefer to strain to posit explanations and +report them instead. If the explanations are based on guesses about +how R is implemented, they will be useless; we will have to try to +figure out what the facts must have been to lead to such speculations. +Sometimes this is impossible. But in any case, it is unnecessary work +for us. + +For example, suppose that on a data set which you know to be quite large +the commmand + \code{data.frame(x,y,z,monday,tuesday)} +never returns. Do not report that \code{data.frame()} fails for large data sets. +Perhaps it fails when a variable name is a day of the week. If this is so +then when we got your report we would try out the \code{data.frame()} command on +a large data set, probably with no day of the week variable name, and not +see any problem. There is no way in the world that we could guess that we +should try a day of the week variable name. + + Or perhaps the command fails because the last command you used was a \code{[} +method that had a bug causing R's internal data structures to be +corrupted and making the \code{data.frame()} command fail from then on. This is +why we need to know what other commands you have typed (or read from your +startup file). + +It is very useful to try and find simple examples that produce apparently +the same bug, and somewhat useful to find simple examples that might be +expected to produce the bug but actually do not. If you want to debug the +problem and find exactly what caused it, that is wonderful. You should +still report the facts as well as any explanations or solutions. + +Invoking R with the \code{--vanilla} option may help in isolating a bug. This +ensures that the site profile and saved data files are not read. + +On some systems a bug report can be generated using the \code{bug.report()} +function. This automatically includes the version information and sends +the bug to the correct address. Alternatively the bug report can be +emailed to \code{r-bugs@biostat.ku.dk} or submitted to the Web page at +\url{http://r-bugs.biostat.ku.dk/R} +} +\seealso{R FAQ} +\author{Adapted from the Emacs manual} + +\keyword{utilities } +\keyword{error} diff --git a/src/library/base/man/chickwts.Rd b/src/library/base/man/chickwts.Rd index b0e58558037..28a0b5e053a 100644 --- a/src/library/base/man/chickwts.Rd +++ b/src/library/base/man/chickwts.Rd @@ -8,13 +8,13 @@ [2,] \tab feed \tab factor \tab Feed type } } -\source{Anonymous (1948). Biometrika, p214. - -} \description{An experiment was conducted to measure and compare the +\source{Anonymous (1948). Biometrika, p.214. +} +\description{An experiment was conducted to measure and compare the effectiveness of various feed supplements on the growth rate of chickens. Newly hatched chicks were randomly allocated into six groups, - and each group was given a different feed supplement. There weights in - grams after six weeks are given below (along with feed types). + and each group was given a different feed supplement. Their weights in + grams after six weeks are given along with feed types. } \references{McNeil, D. R. (1977). Interactive Data Analysis. New York: Wiley. } diff --git a/src/library/base/man/chisq.test.Rd b/src/library/base/man/chisq.test.Rd index a4761966a01..62dd44be3d1 100644 --- a/src/library/base/man/chisq.test.Rd +++ b/src/library/base/man/chisq.test.Rd @@ -1,47 +1,49 @@ \name{chisq.test} +\alias{chisq.test} \title{Pearson's Chi-square Test for Count Data} \usage{ chisq.test(x, y = NULL, correct = TRUE, p = rep(1/length(x), length(x))) } -\alias{chisq.test} \arguments{ - \item{x}{a vector or matrix.} - \item{y}{a vector; ignored if \code{x} is a matrix.} - \item{correct}{a logical indicating whether to apply continuity - correction when computing the test statistic.} + \item{x}{a vector or matrix.} + \item{y}{a vector; ignored if \code{x} is a matrix.} + \item{correct}{a logical indicating whether to apply continuity + correction when computing the test statistic.} } \description{ - \code{chisq.test} performs chi-square tests on contingency tables. - - If \code{x} is a matrix with one row or column, or if \code{x} is a - vector and \code{y} is not given, \code{x} is treated as a - one-dimensional contingency table. In this case, the hypothesis - tested is whether the population probabilities equal those in - \code{p}, or are all equal if \code{p} is not given. + \code{chisq.test} performs chi-square tests on contingency tables. +} +\details{ + If \code{x} is a matrix with one row or column, or if \code{x} is a + vector and \code{y} is not given, \code{x} is treated as a + one-dimensional contingency table. In this case, the hypothesis + tested is whether the population probabilities equal those in + \code{p}, or are all equal if \code{p} is not given. - If \code{x} is a matrix with at least two rows and columns, it is - taken as a two-dimensional contingency table, and hence its entries - should be nonnegative integers. Otherwise, \code{x} and \code{y} must - be vectors or factors of the same length; incomplete cases are - removed, the objects are coerced into factor objects, and the - contingency table is computed from these. Then, Pearson's chi-square - test of the null that the joint distribution of the cell counts in a - 2-dimensional contigency table is the product of the row and column - marginals is performed. Continuity correction is only used in the - 2-by-2 case if \code{correct} is \code{TRUE}. + If \code{x} is a matrix with at least two rows and columns, it is + taken as a two-dimensional contingency table, and hence its entries + should be nonnegative integers. Otherwise, \code{x} and \code{y} + must be vectors or factors of the same length; incomplete cases are + removed, the objects are coerced into factor objects, and the + contingency table is computed from these. Then, Pearson's + chi-square test of the null that the joint distribution of the cell + counts in a 2-dimensional contigency table is the product of the row + and column marginals is performed. Continuity correction is only + used in the 2-by-2 case if \code{correct} is \code{TRUE}. } \value{ - A list with class \code{"htest"} containing the following components: - \item{statistic}{the value the chi-square test statistic.} - \item{parameter}{the degrees of freedom of the approximate chi-square - distribution of the test statistic.} - \item{p.value}{the p-value for the test.} - \item{method}{a character string indicating the type of test - performed, and whether continuity correction was used.} - \item{data.name}{a character string giving the name(s) of the data.} - \item{observed}{the observed counts.} - \item{expected}{the expected counts under the null hypothesis.} + A list with class \code{"htest"} containing the following + components: + \item{statistic}{the value the chi-square test statistic.} + \item{parameter}{the degrees of freedom of the approximate + chi-square distribution of the test statistic.} + \item{p.value}{the p-value for the test.} + \item{method}{a character string indicating the type of test + performed, and whether continuity correction was used.} + \item{data.name}{a character string giving the name(s) of the data.} + \item{observed}{the observed counts.} + \item{expected}{the expected counts under the null hypothesis.} } \examples{ data(insects) # Not really a good example diff --git a/src/library/base/man/consume.Rd b/src/library/base/man/consume.Rd index fb5e7a5485a..00f1f1ac477 100644 --- a/src/library/base/man/consume.Rd +++ b/src/library/base/man/consume.Rd @@ -3,19 +3,20 @@ \usage{data(consume)} \alias{consume} \format{A matrix with 5 rows and 5 columns. - } \source{The World Almanac and Book of Facts, 1962, page 756. - } \description{This data set consists of United States personal expenditures (in billions of dollars) in the categories; food and tobacco, household operation, medical and health, personal care, and private education for the years 1940, 1945, 1950, and 1960. - } \references{Tukey, J. W. (1977). Exploratory Data Analysis. Addison-Wesley. McNeil, D. R. (1977). Interactive Data Analysis. Wiley. - +} +\examples{ +data(consume); consume +require(eda) +medpolish(log10(consume)) } \keyword{datasets} diff --git a/src/library/base/man/contributors.Rd b/src/library/base/man/contributors.Rd index 58c5f313521..7f452f48e06 100644 --- a/src/library/base/man/contributors.Rd +++ b/src/library/base/man/contributors.Rd @@ -32,7 +32,7 @@ In addition, a large group of individuals has contributed to \R by donating code, bug reports and documentation, notably - Valerio Aimalea, + Valerio Aimale, Ben Bolker, Goran Brostrom, Paul Gilbert, @@ -47,6 +47,7 @@ Martyn Plummer, Brian Ripley, Bill Simpson, + Terry Therneau, Bill Venables, and Andreas Weingessel. diff --git a/src/library/base/man/cut.Rd b/src/library/base/man/cut.Rd index 87ee80792ba..bc4ddf3da32 100644 --- a/src/library/base/man/cut.Rd +++ b/src/library/base/man/cut.Rd @@ -11,8 +11,10 @@ cut.default(x, breaks, labels = NULL, \item{x}{a numeric vector which is to be converted to a factor by cutting.} \item{break}{either a vector of cut points or number giving the number of intervals which \code{x} is to be cut into.} -\item{labels}{labels for the levels of the resulting category. By default - labels are constructed using \code{"(a,b]"} interval notation.}. +\item{labels}{labels for the levels of the resulting category. By default, + labels are constructed using \code{"(a,b]"} interval notation. If + \code{labels = FALSE}, simple integer codes are returned instead of + a factor.}. \item{include.lowest}{logical, indicating if an `x[i]' equal to the lowest (or highest, for \code{right = FALSE}) `breaks' value should be included.} @@ -21,13 +23,18 @@ cut.default(x, breaks, labels = NULL, \item{dig.lab}{integer which is used when labels are not given. It determines the number of digits used in formatting the break numbers.} } -\value{ +\description{ \code{cut} divides the range of \code{x} into intervals and codes the values in \code{x} according to which interval they fall. The leftmost interval corresponds to level one, the next leftmost to level two and so on. - +} +\value{ +A \code{\link{factor}} is returned, unless \code{labels = FALSE} which +results in the mere integer level codes. +} +\details{ If a \code{labels} parameter is specified, its values are used to name the factor levels. If none is specified, the factor level labels are constructed as \code{"(b1, b2]"}, \code{"(b2, b3]"} @@ -36,11 +43,20 @@ etc. for \code{right=TRUE} and as \code{"[b1, b2)"}, \ldots if In this case, \code{dig.lab} indicates how many digits should be used in formatting the numbers \code{b1}, \code{b2}, \ldots. } +\note{ +Instead of \code{table(cut(x, br))}, \code{hist(x, br, plot = FALSE)} is +more efficient and less memory hungry. +} \seealso{ \code{\link{split}} for splitting a variable according to a group factor; \code{\link{factor}}, \code{\link{tabulate}}, \code{\link{table}}. } \examples{ +Z <- rnorm(10000) +table(cut(Z, br = -6:6)) +system.time(print(sum(table(cut(Z, br = -6:6, labels=FALSE))))) +system.time(print(sum( hist (Z, br = -6:6, plot=FALSE)$counts))) + cut(rep(1,5),4)#-- dummy tx0 <- c(9, 4, 6, 5, 3, 10, 5, 3, 5) x <- rep(0:8, tx0) @@ -56,6 +72,7 @@ table(cxl <- cut(x, br = 2*(0:4), right = F)) which(is.na(cx)); x[is.na(cx)] #-- the first 9 values 0 which(is.na(cxl)); x[is.na(cxl)] #-- the last 5 values 8 + ## Label construction: y <- rnorm(100) table(cut(y, breaks = pi/3*(-3:3))) diff --git a/src/library/base/man/drop.Rd b/src/library/base/man/drop.Rd index 0f0e32bb2d0..e02da1b0392 100644 --- a/src/library/base/man/drop.Rd +++ b/src/library/base/man/drop.Rd @@ -14,4 +14,8 @@ is adjusted and returned with \code{x}. Array subsetting typically performs this reduction, but sometimes it is useful to invoke \code{drop} directly. } +\seealso{\code{\link{drop1}} which is used for dropping terms in models.} +\examples{ +dim(drop(array(1:12, dim=c(1,3,1,1,2,1,2))))# = 3 2 2 +} \keyword{array} diff --git a/src/library/base/man/eigen.Rd b/src/library/base/man/eigen.Rd index cccaea7253d..ab5e733c535 100644 --- a/src/library/base/man/eigen.Rd +++ b/src/library/base/man/eigen.Rd @@ -20,9 +20,11 @@ This function provides an interface to the EISPACK routines \value{ The spectral decomposition of \code{x} is returned as components of a list. -\item{values}{a vector containing the eigenvalues of \code{x}, sorted +\item{values}{a vector containing the \eqn{p} eigenvalues of \code{x}, sorted \emph{decreasingly}, according to \code{Mod(values)} if they are complex.} -\item{vectors}{a matrix whose columns contain the eigenvectors of \code{x}.} +\item{vectors}{a \eqn{p\times p}{p * p} matrix whose columns contain the + eigenvectors of \code{x}, or \code{NULL} if \code{only.values} is + \code{TRUE}.} } \references{ Smith, B. T, J. M. Boyle, J. J. Dongarra, B. S. Garbow, Y. Ikebe, diff --git a/src/library/base/man/help.Rd b/src/library/base/man/help.Rd index 3338c09976f..8f5d3b652fb 100644 --- a/src/library/base/man/help.Rd +++ b/src/library/base/man/help.Rd @@ -2,7 +2,8 @@ \title{Documentation} \usage{ help(topic, offline = FALSE, package = c(.packages(), .Autoloaded), - lib.loc = .lib.loc) + lib.loc = .lib.loc, verbose = .Options$verbose, + htmlhelp = .Options$htmlhelp) ?topic } \alias{help} @@ -18,6 +19,10 @@ help(topic, offline = FALSE, package = c(.packages(), .Autoloaded), are used.} \item{lib.loc}{A character vector of directory names of \R libraries. Defaults to all libraries currently known.} + \item{verbose}{logical; if \code{TRUE}, the file name is reported.} + \item{htmlhelp}{logical (or \code{NULL}). If \code{TRUE} (is the + default after \code{\link{help.start}} has been called), the help + will not be shown on the console, but via the html browser.} } \description{ These functions provide access to documentation. diff --git a/src/library/base/man/hist.Rd b/src/library/base/man/hist.Rd index f31990bce3b..b648f996977 100644 --- a/src/library/base/man/hist.Rd +++ b/src/library/base/man/hist.Rd @@ -3,7 +3,8 @@ \usage{ hist(x, \dots) hist.default(x, breaks, freq = NULL, probability = !freq, - include.lowest = TRUE, col = NULL, border = par("fg"), + include.lowest = TRUE, right = TRUE, + col = NULL, border = par("fg"), main = paste("Histogram of" , deparse(substitute(x))), xlim = range(breaks), ylim = range(counts, 0), xlab = deparse(substitute(x)), ylab, @@ -24,7 +25,10 @@ or a vector giving the breakpoints between histogram cells.} equidistant.} \item{probability}{an \emph{alias} for \code{!freq}, for S compatibility.} \item{include.lowest}{logical; if \code{TRUE}, - an `x[i]' equal to the `breaks' value will be included in the first bar.} + an `x[i]' equal to the `breaks' value will be included in the first + (or last, for \code{right = FALSE}) bar.} +\item{right}{logical; if \code{TRUE}, the histograms cells are + right-closed (left open) intervals.} \item{col}{a colour to be used to fill the bars. The default of \code{NULL} yields unfilled bars.} \item{border}{the color of the border around the bars.} @@ -37,12 +41,17 @@ or a vector giving the breakpoints between histogram cells.} \item{\dots}{further graphical parameters to \code{title} and \code{axis}.} } \description{ -The generic function \code{hist} computes and plots a histogram of the -given data values. -The histogram cells are intervals of the form +The generic function \code{hist} computes and plots (if \code{plot=T}) a +histogram of the given data values. +} +\details{ +If \code{right = TRUE} (default), the histogram cells are intervals of the form \code{(a,b]}, i.e. they include their right-hand endpoint, but not their left one, with the exception of the first cell when \code{include.lowest} is \code{TRUE}. + +For \code{right = FALSE}, the intervals are of the form \code{[a,b)}, +and \code{include.lowest} really has the meaning of ``\emph{include highest}''. } \value{ a list with components diff --git a/src/library/base/man/infert.Rd b/src/library/base/man/infert.Rd index 04cd234190e..5bdb4986964 100644 --- a/src/library/base/man/infert.Rd +++ b/src/library/base/man/infert.Rd @@ -4,39 +4,44 @@ \alias{infert} \format{ \tabular{rll}{ - 1. \tab Education \tab 0 = 0-5 years \cr - \tab \tab 1 = 6-11 years \cr - \tab \tab 2 = 12+ years \cr - 2. \tab age \tab age in years of case \cr - 3. \tab parity \tab count \cr - 4. \tab number of prior \tab 0 = 0 \cr - \tab \tab induced abortions 1 = 1 \cr - \tab \tab 2 = 2 or more \cr - 5. \tab case status \tab 1 = case \cr - \tab \tab 0 = control \cr - 6. \tab number of prior \tab 0 = 0 \cr - \tab \tab spontaneous abortions 1 = 1 \cr - \tab \tab 2 = 2 or more \cr - 7. \tab matched set number \tab 1-83 \cr - 8. \tab stratum number \tab 1-63 \cr + 1. \tab Education \tab 0 = 0-5 years \cr + \tab \tab 1 = 6-11 years \cr + \tab \tab 2 = 12+ years \cr + 2. \tab age \tab age in years of case \cr + 3. \tab parity \tab count \cr + 4. \tab number of prior \tab 0 = 0 \cr + \tab induced abortions \tab 1 = 1 \cr + \tab \tab 2 = 2 or more \cr + 5. \tab case status\tab 1 = case \cr + \tab \tab 0 = control \cr + 6. \tab number of prior \tab 0 = 0 \cr + \tab spontaneous abortions \tab 1 = 1 \cr + \tab \tab 2 = 2 or more \cr + 7. \tab matched set number \tab 1-83 \cr + 8. \tab stratum number \tab 1-63 \cr } } -\source{Trichopoulos et al. (1976) Br. J. of Obst. and Gynaec. vol.83, +\source{Trichopoulos et al. (1976) Br. J. of Obst. and Gynaec. vol.83, pp. 645-650.} -\description{This is a matched case-control study dating from before the availability of conditional logistic regression.} +\description{This is a matched case-control study dating from before the + availability of conditional logistic regression.} \note{One case with two prior spontaneous abortions and two prior induced -abortions is omitted.} + abortions is omitted.} \examples{ -model1<-glm(case~spontaneous+induced,data=infert,family=binomial()) +data(infert) +model1 <- glm(case ~ spontaneous+induced, data=infert,family=binomial()) summary(model1) -## adjusted for other potential confounders -model2<-glm(case~age+parity+education+spontaneous+induced,data=infert,family=binomial()) +## adjusted for other potential confounders: +summary(model2 <- glm(case ~ age+parity+education+spontaneous+induced, + data=infert,family=binomial())) ## Really should be analysed by conditional logistic regression -## which is equivalent to a Cox model +## which is equivalent to a Cox model : if(require(survival4)){ -faketime<-rep(42,nrow(infert)) -model3<-coxph(Surv(faketime,case)~spontaneous+induced+strata(stratum), - data=infert,method="exact") -summary(model3) + faketime <- rep(42,nrow(infert)) + model3 <- coxph(Surv(faketime,case)~spontaneous+induced+strata(stratum), + data=infert,method="exact") + summary(model3) + detach()# survival4 (conflicts) +} } \keyword{datasets} diff --git a/src/library/base/man/kappa.Rd b/src/library/base/man/kappa.Rd index 52f8754b62c..46caa345c88 100644 --- a/src/library/base/man/kappa.Rd +++ b/src/library/base/man/kappa.Rd @@ -4,33 +4,47 @@ \name{kappa} \title{Estimate the Condition Number of a Matrix, QR Decomposition or Fit} \usage{ -kappa(z, ...) -kappa.lm(z, ...) +kappa(z, \dots) +kappa.lm(z, \dots) kappa.default(z, exact = FALSE) } \alias{kappa} \alias{kappa.lm} \alias{kappa.default} \arguments{ - \item{z}{A matrix or a \code{qr} decomposition or a fit from a class + \item{z}{A matrix or a the result of \code{\link{qr}} or a fit from a class inheriting from \code{"lm"}.} \item{exact}{Should the result be exact?} } \description{ - An estimate of the condition number of a matrix or of the R matrix of a - QR decomposition, perhaps of a linear fit. The condition number is + An estimate of the condition number of a matrix or of the \eqn{R} matrix of a + \eqn{QR} decomposition, perhaps of a linear fit. The condition number is defined as the ratio of the largest to the smallest \emph{non-zero} singular value of the matrix. } \details{ If \code{exact = FALSE} (the default) the condition number is estimated by a cheap approximation. Following S, this uses the LINPACK routine - \code{dtrco.f}. However, in \R (or S) the exact calculation is also + \file{dtrco.f}. However, in \R (or S) the exact calculation is also likely to be quick enough. } \value{ - An estimate of the condition number. + The condition number, \eqn{kappa}, or an approximation if + \code{exact=FALSE}. } \author{B.D. Ripley} +\seealso{\code{\link{svd}} for the singular value decomposition and + \code{\link{qr}} for the \eqn{QR} one. +} +\examples{ +kappa(x1 <- cbind(1,1:10))# 15.71 +kappa(x1, exact=T) # 13.68 +kappa(x2 <- cbind(x1,2:11))# high! [x2 is singular!] +hilbert <- function(n) { i <- 1:n; 1 / outer(i - 1, i, "+") } +sv9 <- svd(h9 <- hilbert(9))$ d +kappa(h9)# pretty high! +kappa(h9, exact=TRUE) == max(sv9) / min(sv9) +kappa(h9, exact=TRUE) / kappa(h9) # .677 (i.e. rel.error = 32\%) +} \keyword{math} diff --git a/src/library/base/man/library.Rd b/src/library/base/man/library.Rd index 46b4f516e1a..5e5e3ec7056 100644 --- a/src/library/base/man/library.Rd +++ b/src/library/base/man/library.Rd @@ -9,7 +9,7 @@ provide(name) .First.lib(libname, pkgname) -.packages() +.packages(all.available = FALSE, lib.loc = .lib.loc) .lib.loc .Library .Provided @@ -39,10 +39,21 @@ provide(name) \item{quietly}{a logical. If \code{TRUE}, a warning will not be printed if the package cannot be found.} \item{libname}{a character string giving the library directory where - the package was found.} + the package was found.} \item{pkgname}{a character string giving the name of the package.} + \item{all.available}{logical; if \code{TRUE} return \code{character} + vector of all available packages in \code{lib.loc}.} } \description{ + \code{library(name)} and \code{require(name)} both load the package + named \code{name}. \code{provide} allows code to register services that + it provides. + + \code{.First.lib()} is called when a package is loaded by \code{library()}. + \code{.packages()} and the \code{.xxx} variables return information about + package availability. +} +\details{ \code{library(name)} and \code{require(name)} both load the package with name \code{name}. \code{require} is designed for use inside other functions; it returns \code{FALSE} and optionally gives a @@ -64,13 +75,16 @@ provide(name) \code{require(splines)} rather than \code{library(splines)} to load the spline package only if their functionality is not already available. - If \code{library} is called with no argument, it gives a list of all - available packages. \code{library(help = name)} prints information on + If \code{library} is called with no \code{name} or \code{help} + argument, it gives a list of all available packages in \code{lib.loc} + and invisibly returns their names (same as \code{.packages(all=T)}). + + \code{library(help = name)} prints information on the package \code{name}, typically by listing the most important user level objects it contains. \code{.First.lib()} is called when a package is loaded by - \code{library()}. It is called with two arguments, the name of the + \code{library(.)}. It is called with two arguments, the name of the library tree where the package was found (i.e., the corresponding element of \code{lib.loc}), and the name of the package (in that order). It is a good place to put calls to \code{library.dynam()} @@ -82,7 +96,9 @@ provide(name) environment in which the package is stored. \code{.packages()} returns the ``base names'' of the currently attached - packages \emph{invisibly}. + packages \emph{invisibly} whereas \code{.packages(all.available =TRUE)} + gives \emph{all} packages available in the library location path + \code{lib.loc}. \code{.Autoloaded} contains the ``base names'' of the packages for which autoloading has been promised. @@ -163,11 +179,13 @@ provide(name) not used by any package, and still experimental. } \value{ - \code{library} returns the list of loaded packages (or \code{TRUE} if - \code{logical.return} is \code{TRUE}). + \code{library} returns the list of loaded (or available) packages (or + \code{TRUE} if \code{logical.return} is \code{TRUE}). \code{require} returns a logical indicating whether the required package is available. } +\author{R core; Guido Masarotto for the \code{all.available=TRUE} + part of \code{.packages}.} \seealso{ \code{\link{attach}}, \code{\link{detach}}, \code{\link{search}}, \code{\link{objects}}, \code{\link{autoload}}, @@ -177,6 +195,7 @@ provide(name) } \examples{ ( .packages() ) # maybe just "base" +.packages(all = TRUE) # return all available as char.vector library() # list all available packages library(lib = .Library) # list all packages in the default library library(help = eda) # documentation on package "eda" diff --git a/src/library/base/man/list.Rd b/src/library/base/man/list.Rd index a5d41d63ad4..65e1e35278e 100644 --- a/src/library/base/man/list.Rd +++ b/src/library/base/man/list.Rd @@ -73,6 +73,7 @@ is.null(pairlist()) !is.list(NULL) is.pairlist(pairlist()) is.null(as.pairlist(list())) +is.null(as.pairlist(NULL)) } \keyword{list} \keyword{manip} diff --git a/src/library/base/man/mahalanobis.Rd b/src/library/base/man/mahalanobis.Rd index 7c28a99a44e..e89b21a5285 100644 --- a/src/library/base/man/mahalanobis.Rd +++ b/src/library/base/man/mahalanobis.Rd @@ -33,6 +33,10 @@ all(mahalanobis(x, 0, diag(ncol(x))) == apply(x*x, 1,sum)) ##- Here, D^2 = usual Euclidean distances Sx <- cov(x) D2 <- mahalanobis(x, apply(x,2,mean), Sx) -plot(density(D2)) +plot(density(D2, bw=.5), main="Mahalanobis distances, n=100, p=3"); rug(D2) +qqplot(qchisq(ppoints(100), df=3), D2, + main = expression("Q-Q plot of Mahalanobis" * ~D^2 * + " vs. quantiles of" * ~ chi[3]^2)) +abline(0,1,col='gray') } \keyword{multivariate} diff --git a/src/library/base/man/matplot.Rd b/src/library/base/man/matplot.Rd index bdbdd5a18f7..da3d3afd430 100644 --- a/src/library/base/man/matplot.Rd +++ b/src/library/base/man/matplot.Rd @@ -1,11 +1,11 @@ \name{matplot} \title{Plot Columns of Matrices} \usage{ -matplot(x, y, type = "p", lty = 1:5, pch = NULL, col = 1:6, +matplot(x, y, type = "p", lty = 1:5, lwd = 1, pch = NULL, col = 1:6, xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL, ..., add = FALSE) -matpoints(x, y, lty = 1:5, pch = NULL, col = 1:6) -matlines(x, y, lty = 1:5, pch = NULL, col = 1:6) +matpoints(x, y, lty = 1:5, lwd = 1, pch = NULL, col = 1:6) +matlines(x, y, lty = 1:5, lwd = 1, pch = NULL, col = 1:6) } \alias{matplot} \alias{matpoints} @@ -22,7 +22,7 @@ matlines(x, y, lty = 1:5, pch = NULL, col = 1:6) defines the first plot, the second character the second, etc. Characters in \code{type} are cycled through; e.g., \code{"pl"} alternately plots points and lines.} - \item{lty}{vector of line types. + \item{lty,lwd}{vector of line types and widths. The first element is for the first column, the second element for the second column, etc., even if lines are not plotted for all columns. Line types will be used cyclically until all plots are diff --git a/src/library/base/man/matrix.Rd b/src/library/base/man/matrix.Rd index fc48db10944..5715ffcf58f 100644 --- a/src/library/base/man/matrix.Rd +++ b/src/library/base/man/matrix.Rd @@ -25,12 +25,14 @@ is.matrix(x) function is generic with a default and a \code{\link{data.frame}} method. \code{is.matrix} returns \code{TRUE} if \code{x} is a matrix (i.e., it - has a \code{\link{dim}} attribute of length 2) and \code{FALSE} otherwise. + \emph{not} a \code{\link{data.frame}} and has a \code{\link{dim}} + attribute of length 2) and \code{FALSE} otherwise. } \seealso{\code{\link{data.matrix}}.} \examples{ is.matrix(as.matrix(1:10)) data(warpbreaks) +!is.matrix(warpbreaks)# data.frame, NOT matrix! str(warpbreaks) str(as.matrix(warpbreaks))#using as.matrix.data.frame(.) method } diff --git a/src/library/base/man/median.Rd b/src/library/base/man/median.Rd index 0efeaaf2e1c..1c948cdf534 100644 --- a/src/library/base/man/median.Rd +++ b/src/library/base/man/median.Rd @@ -10,5 +10,10 @@ computes the sample median of the vector of values given as its argument. If \code{na.rm} is \code{TRUE} then \code{NA} values are deleted before computation proceeds. } +\seealso{\code{\link{quantile}} for general quantiles.} +\examples{ +median(1:4)# = 2.5 [even number] +median(c(1:3,100,1000))# = 3 [odd, robust] +} \keyword{univar} \keyword{robust} diff --git a/src/library/base/man/mosaicplot.Rd b/src/library/base/man/mosaicplot.Rd new file mode 100644 index 00000000000..8c26c1f0abd --- /dev/null +++ b/src/library/base/man/mosaicplot.Rd @@ -0,0 +1,55 @@ +\name{mosaicplot} +\alias{mosaicplot} +\title{Mosaic Plots} +\usage{ +mosaicplot(x, main = NA, sort = NA, off = NA, dir = NA, color = FALSE) +} +\arguments{ + \item{x}{a contingency table, with optional category labels + specified in the \code{dimnames(x)} attribute. The table is + best created by the \code{table()} command, which produces an + object of type array.} + \item{main}{character string for the mosaic title.} + \item{sort}{vector ordering of the variables, containing a + permutation of the integers \code{1:length(dim(x))} (the + default).} + \item{off}{vector of offsets to determine percentage spacing at each + level of the mosaic (appropriate values are between 0 and 20, + and the default is 10 at each level). There should be one + offset for each dimension of the contingency table.} + \item{dir}{vector of split directions (\code{"v"} for vertical and + \code{"h"} for horizontal) for each level of the mosaic, one + direction for each dimension of the contingency table. The + default consists of alternating directions, beginning with a + vertical split.} + \item{color}{(\code{TRUE} or vector of integer colors) for color + shading or (\code{FALSE}, the default) for empty boxes with no + shading.} +} +\description{Plots a mosaic on the current graphics device.} +\details{ + See Emerson (1998) for more information and a case study with + television viewer data from Nielsen Media Research. +} +\author{ + S-PLUS original by John Emerson \email{emerson@stat.yale.edu}. + Slightly modified for R by KH. +} +\references{ + John W. Emerson (1998). + Mosaic displays in S-PLUS: a general implementation and a case + study. + \emph{Statistical Computing and Graphics Newsletter}, \bold{9}, 1, + 17--23. + + The home page of Michael Friendly + (\url{http://hotspur.psych.yorku.ca/SCS/friendly.html}) provides + information on various aspects of graphical methods for analyzing + categorical data, including mosaic plots. +} +\examples{ +Y <- table(trunc(3*runif(1000)), trunc(3*runif(1000)), + trunc(5*runif(1000))-10, trunc(3*runif(1000))) +dimnames(Y)[[2]] <- c("Cat", "Dog", "Horse") +mosaicplot(Y, main = "Sample Mosaic", color = TRUE) +} diff --git a/src/library/base/man/pictex.Rd b/src/library/base/man/pictex.Rd index 88f8a2216d1..5a238ddac93 100644 --- a/src/library/base/man/pictex.Rd +++ b/src/library/base/man/pictex.Rd @@ -31,7 +31,7 @@ pictex(file = "Rplots.tex", width = 5, height = 4, debug = FALSE, Reading, MA: Addison-Wesley. } \author{ - This driver was provided by Valerio Aimalea + This driver was provided by Valerio Aimale \email{valerio@svpop.com.dist.unige.it} of the Department of Internal Medicine, University of Genoa, Italy. } diff --git a/src/library/base/man/prop.test.Rd b/src/library/base/man/prop.test.Rd index edc69d724d2..7f142a12c29 100644 --- a/src/library/base/man/prop.test.Rd +++ b/src/library/base/man/prop.test.Rd @@ -6,91 +6,95 @@ prop.test(x, n = NULL, p = NULL, alternative = "two.sided", } \alias{prop.test} \arguments{ - \item{x}{a vector of counts of successes or a matrix with 2 columns - giving the counts of successes and failures, respectively.} - \item{n}{a vector of counts of trials; ignored if \code{x} is a matrix.} - \item{p}{a vector of probabilities of success. The length of \code{p} - must be the same as the number of groups specified by \code{x}, and - its elements must be greater than 0 and less than 1.} - \item{alternative}{indicates the alternative hypothesis and must be - one of \code{"two.sided"}, \code{"greater"} or \code{"less"}. You - can specify just the initial letter. Only used for testing the null - that a single proportion equals a given value, or that two - proportions are equal; ignored otherwise.} - \item{conf.level}{confidence level of the returned confidence - interval. Must be a single number between 0 and 1. Only used when - testing the null that a single proportion equals a given value, or - that two proportions are equal; ignored otherwise.} - \item{correct}{a logical indicating whether Yates' continuity - correction should be applied.} + \item{x}{a vector of counts of successes or a matrix with 2 columns + giving the counts of successes and failures, respectively.} + \item{n}{a vector of counts of trials; ignored if \code{x} is a + matrix.} + \item{p}{a vector of probabilities of success. The length of + \code{p} must be the same as the number of groups specified by + \code{x}, and its elements must be greater than 0 and less than + 1.} + \item{alternative}{indicates the alternative hypothesis and must be + one of \code{"two.sided"}, \code{"greater"} or \code{"less"}. + You can specify just the initial letter. Only used for testing + the null that a single proportion equals a given value, or that + two proportions are equal; ignored otherwise.} + \item{conf.level}{confidence level of the returned confidence + interval. Must be a single number between 0 and 1. Only used + when testing the null that a single proportion equals a given + value, or that two proportions are equal; ignored otherwise.} + \item{correct}{a logical indicating whether Yates' continuity + correction should be applied.} } \description{ - \code{prop.test} can be used for testing the null that the proportions - (probabilities of success) in several groups are the same, or that - they equal certain given values. - - Only groups with finite numbers of successes and failures are used. - Counts of successes and failures must be nonnegative and hence not - greater than the corresponding numbers of trials which must be - positive. All finite counts should be integers. + \code{prop.test} can be used for testing the null that the + proportions (probabilities of success) in several groups are the + same, or that they equal certain given values. +} +\details{ + Only groups with finite numbers of successes and failures are used. + Counts of successes and failures must be nonnegative and hence not + greater than the corresponding numbers of trials which must be + positive. All finite counts should be integers. - If \code{p} is \code{NULL} and there is more than one group, the null - tested is that the proportions in each group are the same. If there - are two groups, the alternatives are that the probability of success - in the first group is less than, not equal to, or greater than the - probability of success in the second group, as specified by - \code{alternative}. A confidence interval for the difference of - proportions with confidence level as specified by \code{conf.level} - and clipped to \eqn{[-1,1]} is returned. Continuity correction is - used only if it does not exceed the difference of the sample - proportions in absolute value. Otherwise, if there are more than 2 - groups, the alternative is always \code{"two.sided"}, the returned - confidence interval is \code{NULL}, and continuity correction is never - used. + If \code{p} is \code{NULL} and there is more than one group, the + null tested is that the proportions in each group are the same. If + there are two groups, the alternatives are that the probability of + success in the first group is less than, not equal to, or greater + than the probability of success in the second group, as specified by + \code{alternative}. A confidence interval for the difference of + proportions with confidence level as specified by \code{conf.level} + and clipped to \eqn{[-1,1]} is returned. Continuity correction is + used only if it does not exceed the difference of the sample + proportions in absolute value. Otherwise, if there are more than 2 + groups, the alternative is always \code{"two.sided"}, the returned + confidence interval is \code{NULL}, and continuity correction is + never used. - If there is only one group, then the null tested is that the - underlying probability of success is \code{p}, or .5 if \code{p} is - not given. The alternative is that the probability of success if less - than, not equal to, or greater than \code{p} or 0.5, respectively, as - specified by \code{alternative}. A confidence interval for the - underlying proportion with confidence level as specified by - \code{conf.level} and clipped to \eqn{[0,1]} is returned. Continuity - correction is used only if it does not exceed the difference between - sample and null proportions in absolute value. + If there is only one group, then the null tested is that the + underlying probability of success is \code{p}, or .5 if \code{p} is + not given. The alternative is that the probability of success if + less than, not equal to, or greater than \code{p} or 0.5, + respectively, as specified by \code{alternative}. A confidence + interval for the underlying proportion with confidence level as + specified by \code{conf.level} and clipped to \eqn{[0,1]} is + returned. Continuity correction is used only if it does not exceed + the difference between sample and null proportions in absolute + value. - Finally, if \code{p} is given and there are more than 2 groups, the - null tested is that the underlying probabilities of success are those - given by \code{p}. The alternative is always \code{"two.sided"}, the - returned confidence interval is \code{NULL}, and continuity correction - is never used. + Finally, if \code{p} is given and there are more than 2 groups, the + null tested is that the underlying probabilities of success are + those given by \code{p}. The alternative is always + \code{"two.sided"}, the returned confidence interval is \code{NULL}, + and continuity correction is never used. } \value{ - A list with class \code{"htest"} containing the following components: - \item{statistic}{the value of Pearson's chi-square test statistic.} - \item{parameter}{the degrees of freedom of the approximate chi-square - distribution of the test statistic.} - \item{p.value}{the p-value of the test.} - \item{estimate}{a vector with the sample proportions \code{x/n}.} - \item{conf.int}{a confidence interval for the true proportion if there - is one group, or for the difference in proportions if there are 2 - groups and \code{p} is not given, or \code{NULL} otherwise. In the - cases where it is not \code{NULL}, the returned confidence interval - has an asymptotic confidence level as specified by - \code{conf.level}, and is appropriate to the specified alternative - hypothesis.} - \item{null.value}{the value of \code{p} if specified by the null, or - \code{NULL} otherwise.} - \item{alternative}{a character string describing the alternative.} - \item{method}{a character string indicating the method used, and - whether Yates' continuity correction was applied.} - \item{data.name}{a character string giving the names of the data.} + A list with class \code{"htest"} containing the following + components: + \item{statistic}{the value of Pearson's chi-square test statistic.} + \item{parameter}{the degrees of freedom of the approximate + chi-square distribution of the test statistic.} + \item{p.value}{the p-value of the test.} + \item{estimate}{a vector with the sample proportions \code{x/n}.} + \item{conf.int}{a confidence interval for the true proportion if + there is one group, or for the difference in proportions if + there are 2 groups and \code{p} is not given, or \code{NULL} + otherwise. In the cases where it is not \code{NULL}, the + returned confidence interval has an asymptotic confidence level + as specified by \code{conf.level}, and is appropriate to the + specified alternative hypothesis.} + \item{null.value}{the value of \code{p} if specified by the null, or + \code{NULL} otherwise.} + \item{alternative}{a character string describing the alternative.} + \item{method}{a character string indicating the method used, and + whether Yates' continuity correction was applied.} + \item{data.name}{a character string giving the names of the data.} } \examples{ -heads <- rbinom(1, size=100, pr = .5) -prop.test(heads, 100)# continuity correction: Here TRUE by default +heads <- rbinom(1, size=100, pr = .5) +prop.test(heads, 100) # continuity correction TRUE by default prop.test(heads, 100, correct = FALSE) - ## Data from Fleiss (1981), p. 139. ## H0: The null hypothesis is that the four populations from which ## the patients were drawn have the same true proportion of smokers. diff --git a/src/library/base/man/quantile.Rd b/src/library/base/man/quantile.Rd index 57e37421511..18d60a2da50 100644 --- a/src/library/base/man/quantile.Rd +++ b/src/library/base/man/quantile.Rd @@ -1,7 +1,7 @@ \name{quantile} \title{Sample Quantiles} \usage{ -quantile(x, probs=seq(0, 1, 0.25), na.rm=FALSE) +quantile(x, probs=seq(0, 1, 0.25), na.rm=FALSE, names = TRUE) } \alias{quantile} \alias{quantile.default} @@ -11,8 +11,31 @@ corresponding to the given probabilities. The smallest observation corresponds to a probability of 0 and the largest to a probability of 1. } +\details{ +A vector of length \code{length(probs)} is returned; +if \code{names = TRUE}, it has a \code{\link{names}} attribute. + +\code{quantile(x,p)} as a function of \code{p} linearly interpolates +the points ( (i-1)/(n-1), ox[i] ), where +\code{ox <- order(x)} (the ``order statistics'') and \code{n <- length(x)}. + +This gives \code{quantile(x, p) == (1-f)*ox[i] + f*ox[i+1]}, where +\code{r <- 1 + (n-1)*p}, \code{i <- floor(r)}, \code{f <- r - i} +\emph{and} \code{ox[n+1] := ox[n]}. +} \examples{ -quantile(x <- rnorm(1000))# Extremes & Quartiles by default +quantile(x <- rnorm(1001))# Extremes & Quartiles by default quantile(x, probs=c(.1,.5,1,2,5,10,50)/100) + +n <- length(x) ## the following is exact, because 1/(1001-1) is exact: +all(abs(sort(x) == quantile(x, probs = ((1:n)-1)/(n-1), names=F)))# TRUE + +n <- 777 +ox <- sort(x <- round(rnorm(n),1))# round() produces ties +ox <- c(ox, ox[n]) #- such that ox[n+1] := ox[n] +p <- c(0,1,runif(100)) +i <- floor(r <- 1 + (n-1)*p) +f <- r - i +all(abs(quantile(x,p) - ((1-f)*ox[i] + f*ox[i+1])) < 20*.Machine$double.eps) } \keyword{univar} diff --git a/src/library/base/man/rowsum.Rd b/src/library/base/man/rowsum.Rd new file mode 100644 index 00000000000..a07da0c3794 --- /dev/null +++ b/src/library/base/man/rowsum.Rd @@ -0,0 +1,49 @@ +\name{rowsum} +\title{ +Give row sums of a matrix, based on a grouping variable. +} +\alias{rowsum} +\usage{ +rowsum(x, group, reorder=T) +} +\arguments{ +\item{x}{ + a matrix or vector of numeric data. Missing values are allowed. +} +\item{group}{ + a vector giving the grouping, with one element per row of \code{x}. +Missing values are not allowed. +} +\item{reorder}{ +if True, then the result will be in order of sort(unique(group)), +if False, it will be in the order that rows were encountered (and +may run faster for large matrices). +The default is to reorder the data, so as to agree with tapply (see +example below). +}} +\value{ +a matrix containing the sums. There will be one row per unique value +of \code{group}. +} +\author{Terry Therneau} +\seealso{ +\code{\link{tapply}} +} +\examples{ +x <- matrix(runif(100), ncol=5) +group <- sample(1:8, 20, T) +xsum <- rowsum(x, group) + + +#same result another way, slower, and temp may be much larger than x +temp <- model.matrix( ~a -1, data.frame(a=as.factor(group))) +xsum2<- t(temp) \%*\% x + + +#same as last one, but really slow +xsum3 <- tapply(x, list(group[row(x)], col(x)), sum) + + +} +\keyword{manip} +% Converted by Sd2Rd version 0.2-a3. diff --git a/src/library/base/man/step.Rd b/src/library/base/man/step.Rd index b4d6a41b072..f712488868d 100644 --- a/src/library/base/man/step.Rd +++ b/src/library/base/man/step.Rd @@ -13,43 +13,35 @@ step(object, scope, scale=0, direction=c("both", "backward", "forward"), \arguments{ \item{object}{ an object representing a model of an appropriate class. - This is used as the initial model in the stepwise search. -} + This is used as the initial model in the stepwise search.} \item{scope}{ - defines the range of models examined in the stepwise search. -} + defines the range of models examined in the stepwise search.} \item{scale}{ used in the definition of the AIC statistic for selecting the models, - currently only for \code{lm}, \code{aov} and \code{glm} models. -} + currently only for \code{\link{lm}}, \code{\link{aov}} and + \code{\link{glm}} models.} \item{direction}{ the mode of stepwise search, can be one of \code{"both"}, \code{"backward"}, or \code{"forward"}, with a default of \code{"both"}. If the \code{scope} argument is missing, - the default for \code{direction} is \code{"backward"}. -} + the default for \code{direction} is \code{"backward"}.} \item{trace}{ - if positive, information is printed during the running of \code{step}. -} + if positive, information is printed during the running of \code{step}.} \item{keep}{ a filter function whose input is a fitted model object and the associated \code{AIC} statistic, and whose output is arbitrary. Typically \code{keep} will select a subset of the components of - the object and return them. The default is not to keep anything. -} + the object and return them. The default is not to keep anything.} \item{steps}{ the maximum number of steps to be considered. The default is 1000 (essentially as many as required). It is typically used to stop the - process early. -} + process early.} \item{k}{ the multiple of the number of degrees of freedom used for the penalty. Only \code{k=2} gives the genuine AIC: \code{k = log(n)} is sometimes - referred to as BIC or SBC. + referred to as BIC or SBC.} +\item{\dots}{any additional arguments to \code{\link{extractAIC}}.} } -\item{...}{ - any additional arguments to \code{extractAIC}. -}} \value{ the stepwise-selected model is returned, with up to two additional components. There is an \code{"anova"} component corresponding to the @@ -61,15 +53,15 @@ step(object, scope, scale=0, direction=c("both", "backward", "forward"), (thus excluding \code{lm}, \code{aov} and \code{survreg} fits, for example). } \description{ - \code{step} used \code{add1} and \code{drop1} repeatedly; it will work - for any method for which they work, and that is determined by having a - valid method for \code{extractAIC}. When the additive constant can be - chosen so that AIC is equal to Mallows' Cp this is done and the - tables are labelled appropriately. + \code{step} uses \code{\link{add1}} and \code{\link{drop1}} + repeatedly; it will work for any method for which they work, and that + is determined by having a valid method for \code{\link{extractAIC}}. + When the additive constant can be chosen so that AIC is equal to + Mallows' Cp, this is done and the tables are labelled appropriately. - There is a potential problem in using \code{glm} fits with a variable + There is a potential problem in using \code{\link{glm}} fits with a variable \code{scale}, as in that case the deviance is not simply related to the - maximized log-likelihood. The function \code{extractAIC.glm} makes the + maximized log-likelihood. The function \code{\link{extractAIC.glm}} makes the appropriate adjustment for a \code{gaussian} family, but may need to be amended for other cases. (The \code{binomial} and \code{poisson} families have fixed \code{scale} by default and do not correspond @@ -81,4 +73,14 @@ step(object, scope, scale=0, direction=c("both", "backward", "forward"), \code{\link{add1}}, \code{\link{drop1}} } \author{B.D. Ripley} +\examples{ +example(lm) +step(lm.D9) + +data(swiss) +summary(lm1 <- lm(Fertility ~ ., data = swiss)) +slm1 <- step(lm1) +summary(slm1) +slm1 $ anova +} \keyword{models} diff --git a/src/library/base/man/system.time.Rd b/src/library/base/man/system.time.Rd index ffe1816e11e..d6a573c22f4 100644 --- a/src/library/base/man/system.time.Rd +++ b/src/library/base/man/system.time.Rd @@ -9,10 +9,12 @@ unix.time(expr) \arguments{ \item{expr}{Valid \R expression to be ``timed''} } -\description{ +\description{Return CPU (and other) times that \code{expr} used. +} +\details{ \code{system.time} calls the builtin \code{\link{proc.time}}, - evaluates \code{expr}, and the calls \code{proc.time} once more, - returning the difference to between the \code{proc.time} calls. + evaluates \code{expr}, and then calls \code{proc.time} once more, + returning the difference between the two \code{proc.time} calls. The values returned by the \code{proc.time} are (currently) those returned by the C library function \code{times}(3v). diff --git a/src/library/base/man/t.test.Rd b/src/library/base/man/t.test.Rd index 3329baa43f2..fb1c0af6cf6 100644 --- a/src/library/base/man/t.test.Rd +++ b/src/library/base/man/t.test.Rd @@ -1,56 +1,61 @@ \name{t.test} +\alias{t.test} \title{Student's t-Test} \usage{ t.test(x, y = NULL, alternative = "two.sided", mu = 0, paired = FALSE, var.equal = FALSE, conf.level = 0.95) } -\alias{t.test} \arguments{ - \item{x}{a numeric vector of data values.} - \item{y}{an optional numeric vector data values.} - \item{alternative}{must be one of \code{"two.sided"}, \code{"greater"} - or \code{"less"}. You can specify just the initial letter. This - parameter indicates the alternative hypothesis.} - \item{mu}{a number indicating the true value of the mean (or - difference in means if you are performing a two sample test).} - \item{paired}{a logical indicating whether you want a paired t-test.} - \item{var.equal}{a logical variable indicating whether to treat the - two variances as being equal. If \code{TRUE} then the pooled - variance is used to estimate the variance otherwise the Welch - approximation to the degrees of freedom is used.} - \item{conf.level}{confidence level of the interval.} + \item{x}{a numeric vector of data values.} + \item{y}{an optional numeric vector data values.} + \item{alternative}{must be one of \code{"two.sided"}, + \code{"greater"} or \code{"less"}. You can specify just the + initial letter. This parameter indicates the alternative + hypothesis.} + \item{mu}{a number indicating the true value of the mean (or + difference in means if you are performing a two sample test).} + \item{paired}{a logical indicating whether you want a paired + t-test.} + \item{var.equal}{a logical variable indicating whether to treat the + two variances as being equal. If \code{TRUE} then the pooled + variance is used to estimate the variance otherwise the Welch + approximation to the degrees of freedom is used.} + \item{conf.level}{confidence level of the interval.} } \description{ - t.test performs one and two sample t-tests on vectors of data. - If \code{paired} is \code{TRUE} then both \code{x} and \code{y} must - be specified and they must be the same length. - Missing values are removed (in pairs if \code{paired} is - \code{TRUE}). If \code{var.equal} is \code{TRUE} then the pooled - estimate of the variance is used. If \code{var.equal} is \code{FALSE} - then the variance is estimated separately for both groups and the - Welch modification to the degrees of freedom is used. + t.test performs one and two sample t-tests on vectors of data. +} +\details{ + If \code{paired} is \code{TRUE} then both \code{x} and \code{y} must + be specified and they must be the same length. Missing values are + removed (in pairs if \code{paired} is \code{TRUE}). If + \code{var.equal} is \code{TRUE} then the pooled estimate of the + variance is used. If \code{var.equal} is \code{FALSE} then the + variance is estimated separately for both groups and the Welch + modification to the degrees of freedom is used. } \value{ - A list with class \code{"htest"} containing the following components: - \item{statistic}{the value of the t-statistic.} - \item{parameters}{the degrees of freedom for the t-statistic.} - \item{p.value}{the p-value for the test.} - \item{conf.int}{a confidence interval for the mean appropriate to the - specified alternative hypothesis.} - \item{estimate}{the estimated mean or difference in means depending on - whether it was a one-sample test or a two-sample test.} - \item{null.value}{the specified hypothesized value of the mean or mean - difference depending on whether it was a one-sample test or a - two-sample test.} - \item{alternative}{a character string describing the alternative - hypothesis.} - \item{method}{a character string indicating what type of t-test was - performed.} - \item{data.name}{a character string giving the name(s) of the data.} + A list with class \code{"htest"} containing the following + components: + \item{statistic}{the value of the t-statistic.} + \item{parameters}{the degrees of freedom for the t-statistic.} + \item{p.value}{the p-value for the test.} + \item{conf.int}{a confidence interval for the mean appropriate to + the specified alternative hypothesis.} + \item{estimate}{the estimated mean or difference in means depending + on whether it was a one-sample test or a two-sample test.} + \item{null.value}{the specified hypothesized value of the mean or + mean difference depending on whether it was a one-sample test or + a two-sample test.} + \item{alternative}{a character string describing the alternative + hypothesis.} + \item{method}{a character string indicating what type of t-test was + performed.} + \item{data.name}{a character string giving the name(s) of the data.} } \seealso{\code{\link{prop.test}} \examples{ -t.test(1:10,y=c(7:20)) # P = .00001855 -t.test(1:10,y=c(7:20, 200))# P = .1245 -- NOT significant anymore +t.test(1:10,y=c(7:20)) # P = .00001855 +t.test(1:10,y=c(7:20, 200)) # P = .1245 -- NOT significant anymore } \keyword{htest} diff --git a/src/library/base/man/text.Rd b/src/library/base/man/text.Rd index 0b61c6e7494..625742f7d01 100644 --- a/src/library/base/man/text.Rd +++ b/src/library/base/man/text.Rd @@ -8,7 +8,8 @@ text.default (x, y = NULL, labels = seq(along = x), adj = NULL, \dots) \alias{text.default} \arguments{ \item{x, y}{numeric vectors of coordinates where the text - \code{labels} should be written.} + \code{labels} should be written. If the length of \code{x} and + \code{y} differs, the shorter one is recycled.} \item{labels}{character or expression with the \emph{text} to be written.} \item{adj}{character or expression with the \emph{text} to be diff --git a/src/library/base/man/ts.Rd b/src/library/base/man/ts.Rd index e730e081c15..0c49e42d848 100644 --- a/src/library/base/man/ts.Rd +++ b/src/library/base/man/ts.Rd @@ -66,5 +66,13 @@ print( ts(1:10, freq = 7, start = c(12, 2)), calendar = TRUE) # print.ts(.) gnp <- ts(cumsum(1 + round(rnorm(100), 2)), start = c(1954, 7), frequency = 12) plot(gnp) # using `plot.ts' for time-series plot +\testonly{ +ts(1:5, start=2, end=4) # truncate +ts(1:5, start=3, end=17)# repeat +} +## A phase plot: +data(nhtemp) +plot(nhtemp, c(nhtemp[-1],NA), cex = .8, col="blue", + main="Lag plot of New Haven temperatures") } \keyword{ts} diff --git a/src/library/base/man/which.Rd b/src/library/base/man/which.Rd index 3d0cb4cd764..0fcc617682c 100644 --- a/src/library/base/man/which.Rd +++ b/src/library/base/man/which.Rd @@ -5,7 +5,7 @@ which(x, arr.ind = FALSE) } \alias{which} \arguments{ - \item{x}{a logical vector or array.} + \item{x}{a logical vector or array. \code{\link{NA}}s are allowed an omitted.} \item{arr.ind}{logical; should \bold{arr}ay \bold{ind}ices be returned when \code{x} is an array?} } @@ -29,6 +29,7 @@ which(x, arr.ind = FALSE) \seealso{\code{\link{Logic}}} \examples{ which(LETTERS == "R") +which(c(T,F,T,NA,F,F,T))#> 1 3 7 which((1:12)\%\%2 == 0) # which are even? str(which(1:10 > 3, arr.ind=TRUE)) diff --git a/src/library/base/man/xy.coords.Rd b/src/library/base/man/xy.coords.Rd index d8ed0ae3726..3acc9136be1 100644 --- a/src/library/base/man/xy.coords.Rd +++ b/src/library/base/man/xy.coords.Rd @@ -1,7 +1,7 @@ \name{xy.coords} \title{Extracting Plotting Structures} \usage{ -xy.coords(x, y, xlab=NULL, ylab=NULL) +xy.coords(x, y, xlab=NULL, ylab=NULL, log=NULL, recycle = FALSE) } \alias{xy.coords} \arguments{ @@ -20,6 +20,11 @@ is assumed to contain the x values and the second the y values; in any other case, the argument is coerced to a vector and the values plotted against their indices.} \item{xlab,ylab}{names for the x and y variables to be extracted.} +\item{log}{character, \code{"x"}, \code{"y"} or both, as for + \code{\link{plot}}. Sets negative values to \code{\link{NA}} and + gives a warning.} +\item{recycle}{logical; if \code{TRUE}, recyle (\code{\link{rep}}) the shorter + of \code{x} or \code{y} if their lengths differ.} } \description{ \code{xy.coords} is used by many function to obtain @@ -41,5 +46,9 @@ A list with the components xy.coords(fft(c(1:10)), NULL) data(cars) ; attach(cars) xy.coords(dist ~ speed, NULL)$xlab # = "speed" + +str(xy.coords(1:3, 1:2, recycle=TRUE)) +str(xy.coords(-2:10,NULL, log="y")) +##> warning: 3 y values <=0 omitted .. } \keyword{dplot} diff --git a/src/library/eda/Makefile.in b/src/library/eda/Makefile.in index 98b898021e8..95416c578d0 100644 --- a/src/library/eda/Makefile.in +++ b/src/library/eda/Makefile.in @@ -30,13 +30,15 @@ all: $(INSTALL_DATA) `ls $(srcdir)/data/[a-z]*` \ $(top_builddir)/library/base/data; \ fi - @if test -d src; then cd src; $(MAKE); cd ..; fi + @if test -d src; then \ + (cd src && $(MAKE)) || exit 1; \ + fi mostlyclean: clean clean: - @if test -d src; then cd src; $(MAKE) $@; cd ..; fi + @if test -d src; then (cd src && $(MAKE) $@); fi distclean: - @if test -d src; then cd src; $(MAKE) $@; cd ..; fi + @if test -d src; then (cd src && $(MAKE) $@); fi @rm -f Makefile maintainer-clean: distclean diff --git a/src/library/eda/R/medpolish.R b/src/library/eda/R/medpolish.R index 162575d6161..bfe25a722e1 100644 --- a/src/library/eda/R/medpolish.R +++ b/src/library/eda/R/medpolish.R @@ -36,14 +36,15 @@ medpolish <- function (x, eps=0.01, maxiter=10, trace.iter = TRUE) ans } -print.medpolish <- function(x) { +print.medpolish <- function(x, digits=.Options$digits, ...) +{ cat("\nMedian Polish Results (Dataset: \"", x$name, "\")\n", sep="") cat("\nOverall:", x$overall, "\n\nRow Effects:\n") - print(x$row) + print(x$row, digits=digits, ...) cat("\nColumn Effects:\n") - print(x$col) + print(x$col, digits=digits, ...) cat("\nResiduals:\n") - print(x$residuals) + print(x$residuals, digits=max(2, digits-2), ...) cat("\n") invisible(x) } diff --git a/src/library/eda/R/zzz.R b/src/library/eda/R/zzz.R index 877af8c5e4e..bde9a7aaf5f 100644 --- a/src/library/eda/R/zzz.R +++ b/src/library/eda/R/zzz.R @@ -1,2 +1,4 @@ -library.dynam("eda.so") -provide(eda) +.First.lib <- function(lib, pkg) { + library.dynam("eda", pkg, lib) + provide(eda) +} diff --git a/src/library/modreg/Makefile.in b/src/library/modreg/Makefile.in index f2770d8c58f..a1065645c53 100644 --- a/src/library/modreg/Makefile.in +++ b/src/library/modreg/Makefile.in @@ -30,13 +30,15 @@ all: $(INSTALL_DATA) `ls $(srcdir)/data/[a-z]*` \ $(top_builddir)/library/base/data; \ fi - @if test -d src; then cd src; $(MAKE); cd ..; fi + @if test -d src; then \ + (cd src && $(MAKE)) || exit 1; \ + fi mostlyclean: clean clean: - @if test -d src; then cd src; $(MAKE) $@; cd ..; fi + @if test -d src; then (cd src && $(MAKE) $@); fi distclean: - @if test -d src; then cd src; $(MAKE) $@; cd ..; fi + @if test -d src; then (cd src && $(MAKE) $@); fi @rm -f Makefile maintainer-clean: distclean diff --git a/src/library/modreg/src/qsbart.f b/src/library/modreg/src/qsbart.f index 6f8b420096c..d19433f8b74 100644 --- a/src/library/modreg/src/qsbart.f +++ b/src/library/modreg/src/qsbart.f @@ -1,14 +1,14 @@ subroutine qsbart(penalt,dofoff,xs,ys,ws,n,knot,nk,coef,sz,lev, -& crit,iparms,spar,parms,isetup,scrtch,ld4,ldnk,ier) + &crit,iparms,spar,parms,isetup,scrtch,ld4,ldnk,ier) implicit double precision(a-h,o-z) integer n,nk,isetup,iparms(2),ld4,ldnk,ier double precision penalt,dofoff,xs(n),ys(n),ws(n),knot(nk+4),coef( -& nk),sz(n),lev(n),crit,spar,parms(3),scrtch(1) + &nk),sz(n),lev(n),crit,spar,parms(3),scrtch(1) call sbart(penalt,dofoff,xs,ys,ws,n,knot,nk,coef,sz,lev,crit, -& iparms(1),spar,iparms(2),parms(1),parms(2),parms(3),isetup,scrtch( -& 1),scrtch(nk+1),scrtch(2*nk+1),scrtch(3*nk+1),scrtch(4*nk+1), -& scrtch(5*nk+1),scrtch(6*nk+1),scrtch(7*nk+1),scrtch(8*nk+1), -& scrtch(9*nk+1),scrtch(9*nk+ld4*nk+1),scrtch(9*nk+2*ld4*nk+1),ld4, -& ldnk,ier) + &iparms(1),spar,iparms(2),parms(1),parms(2),parms(3),isetup,scrtch( + &1),scrtch(nk+1),scrtch(2*nk+1),scrtch(3*nk+1),scrtch(4*nk+1), + &scrtch(5*nk+1),scrtch(6*nk+1),scrtch(7*nk+1),scrtch(8*nk+1), + &scrtch(9*nk+1),scrtch(9*nk+ld4*nk+1),scrtch(9*nk+2*ld4*nk+1),ld4, + &ldnk,ier) return end diff --git a/src/library/modreg/src/sbart.f b/src/library/modreg/src/sbart.f index c6a684e9262..b774e18e267 100644 --- a/src/library/modreg/src/sbart.f +++ b/src/library/modreg/src/sbart.f @@ -1,14 +1,14 @@ subroutine sbart(penalt,dofoff,xs,ys,ws,n,knot,nk,coef,sz,lev, -& crit,icrit,spar,ispar,lspar,uspar,tol,isetup,xwy,hs0,hs1,hs2,hs3, -& sg0,sg1,sg2,sg3,abd,p1ip,p2ip,ld4,ldnk,ier) + &crit,icrit,spar,ispar,lspar,uspar,tol,isetup,xwy,hs0,hs1,hs2,hs3, + &sg0,sg1,sg2,sg3,abd,p1ip,p2ip,ld4,ldnk,ier) implicit double precision(a-h,o-z) integer n,nk,isetup,icrit,ispar,ld4,ldnk,ier double precision penalt,dofoff,xs(n),ys(n),ws(n),knot(nk+4),coef( -& nk),sz(n),lev(n),crit,spar,lspar,uspar,tol,xwy(nk),hs0(nk),hs1(nk) -& ,hs2(nk),hs3(nk), sg0(nk),sg1(nk),sg2(nk),sg3(nk),abd(ld4,nk), -& p1ip(ld4,nk),p2ip(ldnk,nk) + &nk),sz(n),lev(n),crit,spar,lspar,uspar,tol,xwy(nk),hs0(nk),hs1(nk) + &,hs2(nk),hs3(nk), sg0(nk),sg1(nk),sg2(nk),sg3(nk),abd(ld4,nk), + &p1ip(ld4,nk),p2ip(ldnk,nk) double precisiont1,t2,ratio, a,b,c,d,e,eps,xm,p,q,r,tol1,tol2,u,v, -& w, fu,fv,fw,fx,x,ax,bx + &w, fu,fv,fw,fx,x,ax,bx common /XXXsbart/q integer i i=1 @@ -35,8 +35,8 @@ subroutine sbart(penalt,dofoff,xs,ys,ws,n,knot,nk,coef,sz,lev, 23005 continue if(.not.(ispar.eq.1))goto 23011 call sslvrg(penalt,dofoff,xs,ys,ws,n,knot,nk,coef,sz,lev,crit, -& icrit,spar,ratio,xwy,hs0,hs1,hs2,hs3,sg0,sg1,sg2,sg3,abd,p1ip, -& p2ip,ld4,ldnk,ier) + &icrit,spar,ratio,xwy,hs0,hs1,hs2,hs3,sg0,sg1,sg2,sg3,abd,p1ip, + &p2ip,ld4,ldnk,ier) return 23011 continue ax=lspar @@ -58,8 +58,8 @@ subroutine sbart(penalt,dofoff,xs,ys,ws,n,knot,nk,coef,sz,lev, e = 0.0 spar = x call sslvrg(penalt,dofoff,xs,ys,ws,n,knot,nk,coef,sz,lev,crit, -& icrit,spar,ratio,xwy,hs0,hs1,hs2,hs3,sg0,sg1,sg2,sg3,abd,p1ip, -& p2ip,ld4,ldnk,ier) + &icrit,spar,ratio,xwy,hs0,hs1,hs2,hs3,sg0,sg1,sg2,sg3,abd,p1ip, + &p2ip,ld4,ldnk,ier) fx = crit fv = fx fw = fx @@ -116,8 +116,8 @@ subroutine sbart(penalt,dofoff,xs,ys,ws,n,knot,nk,coef,sz,lev, 23037 continue spar = u call sslvrg(penalt,dofoff,xs,ys,ws,n,knot,nk,coef,sz,lev,crit, -& icrit,spar,ratio,xwy,hs0,hs1,hs2,hs3,sg0,sg1,sg2,sg3,abd,p1ip, -& p2ip,ld4,ldnk,ier) + &icrit,spar,ratio,xwy,hs0,hs1,hs2,hs3,sg0,sg1,sg2,sg3,abd,p1ip, + &p2ip,ld4,ldnk,ier) fu = crit c c update a, b, v, w, and x diff --git a/src/library/modreg/src/sgram.f b/src/library/modreg/src/sgram.f index d387d79ca75..fe89f18e8bd 100644 --- a/src/library/modreg/src/sgram.f +++ b/src/library/modreg/src/sgram.f @@ -2,7 +2,7 @@ subroutine sgram(sg0,sg1,sg2,sg3,tb,nb) implicit double precision(a-h,o-z) integer nb,ileft,ilo,mflag,i,ii,jj double precision sg0(nb),sg1(nb),sg2(nb),sg3(nb),tb(nb+4),vnikx(4, -& 3),work(16),yw1(4),yw2(4),wpt + &3),work(16),yw1(4),yw2(4),wpt lentb=nb+4 do 23000 i=1,nb sg0(i)=0. @@ -26,21 +26,21 @@ subroutine sgram(sg0,sg1,sg2,sg3,tb,nb) do 23010 ii=1,4 jj=ii sg0(ileft-4+ii) = sg0(ileft-4+ii) +wpt* (yw1(ii)*yw1(jj) + (yw2( -& ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) + &ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) jj=ii+1 if(.not.(jj.le.4))goto 23012 sg1(ileft+ii-4) = sg1(ileft+ii-4) +wpt* (yw1(ii)*yw1(jj) + (yw2( -& ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) + &ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) 23012 continue jj=ii+2 if(.not.(jj.le.4))goto 23014 sg2(ileft+ii-4) = sg2(ileft+ii-4) +wpt* (yw1(ii)*yw1(jj) + (yw2( -& ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) + &ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) 23014 continue jj=ii+3 if(.not.(jj.le.4))goto 23016 sg3(ileft+ii-4) = sg3(ileft+ii-4) +wpt* (yw1(ii)*yw1(jj) + (yw2( -& ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) + &ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) 23016 continue 23010 continue goto 23009 @@ -49,16 +49,16 @@ subroutine sgram(sg0,sg1,sg2,sg3,tb,nb) do 23020 ii=1,3 jj=ii sg0(ileft-3+ii) = sg0(ileft-3+ii) +wpt* (yw1(ii)*yw1(jj) + (yw2( -& ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) + &ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) jj=ii+1 if(.not.(jj.le.3))goto 23022 sg1(ileft+ii-3) = sg1(ileft+ii-3) +wpt* (yw1(ii)*yw1(jj) + (yw2( -& ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) + &ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) 23022 continue jj=ii+2 if(.not.(jj.le.3))goto 23024 sg2(ileft+ii-3) = sg2(ileft+ii-3) +wpt* (yw1(ii)*yw1(jj) + (yw2( -& ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) + &ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) 23024 continue 23020 continue goto 23019 @@ -67,11 +67,11 @@ subroutine sgram(sg0,sg1,sg2,sg3,tb,nb) do 23028 ii=1,2 jj=ii sg0(ileft-2+ii) = sg0(ileft-2+ii) +wpt* (yw1(ii)*yw1(jj) + (yw2( -& ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) + &ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) jj=ii+1 if(.not.(jj.le.2))goto 23030 sg1(ileft+ii-2) = sg1(ileft+ii-2) +wpt* (yw1(ii)*yw1(jj) + (yw2( -& ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) + &ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) 23030 continue 23028 continue goto 23027 @@ -80,7 +80,7 @@ subroutine sgram(sg0,sg1,sg2,sg3,tb,nb) do 23034 ii=1,1 jj=ii sg0(ileft-1+ii) = sg0(ileft-1+ii) +wpt* (yw1(ii)*yw1(jj) + (yw2( -& ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) + &ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 +yw2(ii)*yw2(jj)*.3330 ) 23034 continue 23032 continue 23027 continue diff --git a/src/library/modreg/src/sinerp.f b/src/library/modreg/src/sinerp.f index d2b12059eff..a918b449f97 100644 --- a/src/library/modreg/src/sinerp.f +++ b/src/library/modreg/src/sinerp.f @@ -2,7 +2,7 @@ subroutine sinerp(abd,ld4,nk,p1ip,p2ip,ldnk,flag) implicit double precision(a-h,o-z) integerflag,ld4,nk,ldnk,i,j,k double precision abd(ld4,nk),p1ip(ld4,nk),p2ip(ldnk,nk),wjm3(3), -& wjm2(2),wjm1(1),c0,c1,c2,c3 + &wjm2(2),wjm1(1),c0,c1,c2,c3 wjm3(1)=0e0 wjm3(2)=0e0 wjm3(1)=0e0 @@ -42,7 +42,7 @@ subroutine sinerp(abd,ld4,nk,p1ip,p2ip,ldnk,flag) p1ip(2,j) = 0e0- (c1*wjm3(2)+c2*wjm2(1)+c3*wjm2(2)) p1ip(3,j) = 0e0- (c1*wjm3(3)+c2*wjm2(2)+c3*wjm1(1)) p1ip(4,j) = c0**2 +c1**2*wjm3(1)+2.*c1*c2*wjm3(2)+2.*c1*c3*wjm3(3) -& +c2**2*wjm2(1)+2.*c2*c3*wjm2(2) +c3**2*wjm1(1) + & +c2**2*wjm2(1)+2.*c2*c3*wjm2(2) +c3**2*wjm1(1) wjm3(1)=wjm2(1) wjm3(2)=wjm2(2) wjm3(3)=p1ip(2,j) @@ -71,7 +71,7 @@ subroutine sinerp(abd,ld4,nk,p1ip,p2ip,ldnk,flag) c2 = abd(2,k+2)*c0 c3 = abd(3,k+1)*c0 p2ip(k,j) = 0e0- ( c1*p2ip(k+3,j) +c2*p2ip(k+2,j) +c3*p2ip(k+1,j) -& ) + &) k=k-1 goto 23019 23021 continue diff --git a/src/library/modreg/src/sslvrg.f b/src/library/modreg/src/sslvrg.f index 0c8825434e1..f57cd2d5767 100644 --- a/src/library/modreg/src/sslvrg.f +++ b/src/library/modreg/src/sslvrg.f @@ -1,13 +1,13 @@ subroutine sslvrg(penalt,dofoff,x,y,w,n,knot,nk,coef,sz,lev,crit, -& icrit,spar,ratio,xwy,hs0,hs1,hs2,hs3,sg0,sg1,sg2,sg3,abd,p1ip, -& p2ip,ld4,ldnk,info) + &icrit,spar,ratio,xwy,hs0,hs1,hs2,hs3,sg0,sg1,sg2,sg3,abd,p1ip, + &p2ip,ld4,ldnk,info) implicit double precision(a-h,o-z) integer n,nk,icrit,ld4,ldnk,i,icoef,ileft,ilo,info,j,mflag double precision penalt,dofoff,x(n),y(n),w(n),knot(nk+4),coef(nk), -& sz(n),lev(n),crit,ratio,spar,xwy(nk),hs0(nk),hs1(nk),hs2(nk),hs3( -& nk), sg0(nk),sg1(nk),sg2(nk),sg3(nk),abd(ld4,nk),p1ip(ld4,nk), -& p2ip(ldnk,nk),lambda,b0,b1,b2,b3,eps,vnikx(4,1),work(16),xv, -& bvalue,rss,df + &sz(n),lev(n),crit,ratio,spar,xwy(nk),hs0(nk),hs1(nk),hs2(nk),hs3( + &nk), sg0(nk),sg1(nk),sg2(nk),sg3(nk),abd(ld4,nk),p1ip(ld4,nk), + &p2ip(ldnk,nk),lambda,b0,b1,b2,b3,eps,vnikx(4,1),work(16),xv, + &bvalue,rss,df lenkno=nk+4 ilo = 1 eps = .1e-10 @@ -59,9 +59,9 @@ subroutine sslvrg(penalt,dofoff,x,y,w,n,knot,nk,coef,sz,lev,crit, b2=vnikx(3,1) b3=vnikx(4,1) lev(i) = (p1ip(4,j)*b0**2 + 2.*p1ip(3,j)*b0*b1 +2.*p1ip(2,j)*b0* -& b2 + 2.*p1ip(1,j)*b0*b3 +p1ip(4,j+1)*b1**2 + 2.*p1ip(3,j+1)*b1*b2 -& +2.*p1ip(2,j+1)*b1*b3 +p1ip(4,j+2)*b2**2 + 2.*p1ip(3,j+2)*b2*b3 + -& p1ip(4,j+3)*b3**2 )*w(i)**2 + &b2 + 2.*p1ip(1,j)*b0*b3 +p1ip(4,j+1)*b1**2 + 2.*p1ip(3,j+1)*b1*b2 + &+2.*p1ip(2,j+1)*b1*b3 +p1ip(4,j+2)*b2**2 + 2.*p1ip(3,j+2)*b2*b3 + + &p1ip(4,j+3)*b3**2 )*w(i)**2 23016 continue if(.not.(icrit.eq.1))goto 23022 rss = 0e0 diff --git a/src/library/modreg/src/stxwx.f b/src/library/modreg/src/stxwx.f index cae59ac6790..df9692c17a6 100644 --- a/src/library/modreg/src/stxwx.f +++ b/src/library/modreg/src/stxwx.f @@ -2,7 +2,7 @@ subroutine stxwx(x,z,w,k,xknot,n,y,hs0,hs1,hs2,hs3) implicit double precision(a-h,o-z) integer k,n,j,i,ilo,ileft,mflag double precision z(k),w(k),x(k),xknot(n+4),y(n),hs0(n),hs1(n),hs2( -& n),hs3(n),eps,vnikx(4,1),work(16) + &n),hs3(n),eps,vnikx(4,1),work(16) lenxk=n+4 do 23000 i=1,n y(i)=0e0 diff --git a/src/library/mva/Makefile.in b/src/library/mva/Makefile.in index a1f5ea11db7..13c43954552 100644 --- a/src/library/mva/Makefile.in +++ b/src/library/mva/Makefile.in @@ -30,13 +30,15 @@ all: $(INSTALL_DATA) `ls $(srcdir)/data/[a-z]*` \ $(top_builddir)/library/base/data; \ fi - @if test -d src; then cd src; $(MAKE); cd ..; fi + @if test -d src; then \ + (cd src && $(MAKE)) || exit 1; \ + fi mostlyclean: clean clean: - @if test -d src; then cd src; $(MAKE) $@; cd ..; fi + @if test -d src; then (cd src && $(MAKE) $@); fi distclean: - @if test -d src; then cd src; $(MAKE) $@; cd ..; fi + @if test -d src; then (cd src && $(MAKE) $@); fi @rm -f Makefile maintainer-clean: distclean diff --git a/src/library/mva/R/zzz.R b/src/library/mva/R/zzz.R index 41c72595335..1357044221f 100644 --- a/src/library/mva/R/zzz.R +++ b/src/library/mva/R/zzz.R @@ -1,2 +1,4 @@ -library.dynam("mva.so") -provide(mva) +.First.lib <- function(lib, pkg) { + library.dynam("mva", pkg, lib) + provide(mva) +} diff --git a/src/main/Makefile.in b/src/main/Makefile.in index 3478f10dea7..1f9a5b54c61 100644 --- a/src/main/Makefile.in +++ b/src/main/Makefile.in @@ -74,7 +74,9 @@ par.o: $(top_srcdir)/src/include/Graphics.h plot.o: $(top_srcdir)/src/include/Graphics.h arithmetic.o: $(top_srcdir)/src/include/Mathlib.h -random.o: $(top_srcdir)/src/include/Mathlib.h +format.o: $(top_srcdir)/src/include/Mathlib.h +random.o: $(top_srcdir)/src/include/Mathlib.h \ + $(top_srcdir)/src/include/Random.h deparse.o: names.h names.o: names.h diff --git a/src/main/attrib.c b/src/main/attrib.c index 6d4a13803be..f6f34c992d8 100644 --- a/src/main/attrib.c +++ b/src/main/attrib.c @@ -624,7 +624,7 @@ SEXP do_attributesgets(SEXP call, SEXP op, SEXP args, SEXP env) for (i = 0; i < nattrs; i++) { if (STRING(names)[i] == R_NilValue || CHAR(STRING(names)[i])[0] == '\0') { - error("all attributes must have names\n"); + errorcall(call, "all attributes must have names [%d]\n",i); } if (!strcmp(CHAR(STRING(names)[i]), "dim")) setAttrib(object, R_DimSymbol, VECTOR(attrs)[i]); diff --git a/src/main/bind.c b/src/main/bind.c index 788f5cdd8e5..86a455002e6 100644 --- a/src/main/bind.c +++ b/src/main/bind.c @@ -1,3 +1,6 @@ +#define TRYIT +/* +*/ /* * R : A Computer Language for Statistical Data Analysis * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka @@ -773,21 +776,21 @@ SEXP do_unlist(SEXP call, SEXP op, SEXP args, SEXP env) if (!recurse) { if (TYPEOF(args) == VECSXP) { SEXP names = getAttrib(args, R_NamesSymbol); + ans_nnames = 0; + seqno = 0; + firstpos = 0; + count = 0; for (i = 0; i < n; i++) { - ans_nnames = 0; - seqno = 0; - firstpos = 0; - count = 0; NewExtractNames(VECTOR(args)[i], R_NilValue, ItemName(names, i), recurse); } } else if (TYPEOF(args) == LISTSXP) { + ans_nnames = 0; + seqno = 0; + firstpos = 0; + count = 0; while (args != R_NilValue) { - ans_nnames = 0; - seqno = 0; - firstpos = 0; - count = 0; NewExtractNames(CAR(args), R_NilValue, TAG(args), recurse); args = CDR(args); @@ -801,7 +804,7 @@ SEXP do_unlist(SEXP call, SEXP op, SEXP args, SEXP env) firstpos = 0; count = 0; NewExtractNames(args, R_NilValue, R_NilValue, recurse); -#ifdef TRY +#ifdef TRYIT } #endif setAttrib(ans, R_NamesSymbol, ans_names); diff --git a/src/main/character.c b/src/main/character.c index e7adb6fa124..d6a81f7b2c6 100644 --- a/src/main/character.c +++ b/src/main/character.c @@ -165,6 +165,8 @@ SEXP do_strsplit(SEXP call, SEXP op, SEXP args, SEXP env) /* results are unique (duplicated names are removed prior to entry). */ /* names, minlength, use.classes, dot */ +#define LASTCHAR(i) (!isspace(buff1[i-1]) && (!buff1[i+1] || isspace(buff1[i+1]))) + static SEXP stripchars(SEXP inchar, int minlen) { int i, j, nspace = 0, upper; @@ -187,9 +189,14 @@ static SEXP stripchars(SEXP inchar, int minlen) if (strlen(buff1) < minlen) goto donesc; - for (i = upper; i > 0; i--) { + for (i = upper, j = 1; i > 0; i--) { if (isspace(buff1[i])) + if (j) + buff1[i] = '\0' ; + else nspace++; + else + j = 0; /*strcpy(buff1[i],buff1[i+1]);*/ if (strlen(buff1) - nspace <= minlen) goto donesc; @@ -200,7 +207,7 @@ static SEXP stripchars(SEXP inchar, int minlen) for (i = upper; i > 0; i--) { if ((buff1[i] == 'a' || buff1[i] == 'e' || buff1[i] == 'i' || buff1[i] == 'o' || buff1[i] == 'u')) { - if (!(isspace(buff1[i - 1]) && isspace(buff1[i + 1]))) + if (LASTCHAR(i)) strcpy(&buff1[i], &buff1[i + 1]); } if (strlen(buff1) - nspace <= minlen) @@ -211,7 +218,7 @@ static SEXP stripchars(SEXP inchar, int minlen) for (i = upper; i >= 0; i--) { if (islower(buff1[i])) { - if (!(isspace(buff1[i - 1]) && isspace(buff1[i + 1]))) + if (LASTCHAR(i)) strcpy(&buff1[i], &buff1[i + 1]); } if (strlen(buff1) - nspace <= minlen) @@ -220,9 +227,9 @@ static SEXP stripchars(SEXP inchar, int minlen) /* all else has failed so we use brute force */ - upper = strlen(buff1); + upper = strlen(buff1) - 1; for (i = upper; i > 0; i--) { - if (!(isspace(buff1[i - 1]) && isspace(buff1[i + 1]))) + if (LASTCHAR(i) && !isspace(buff1[i])) strcpy(&buff1[i], &buff1[i + 1]); if (strlen(buff1) - nspace <= minlen) goto donesc; diff --git a/src/main/coerce.c b/src/main/coerce.c index c027128cabc..0851d4013f7 100644 --- a/src/main/coerce.c +++ b/src/main/coerce.c @@ -652,6 +652,7 @@ static SEXP coercePairList(SEXP v, SEXPTYPE type) int i, n=0; SEXP rval= R_NilValue, vp, names; + if(type == LISTSXP) return v;/* IS pairlist */ names = v; if (type == EXPRSXP) { PROTECT(rval = allocVector(type, 1)); @@ -894,6 +895,7 @@ static SEXP asFunction(SEXP x) static SEXP ascommon(SEXP call, SEXP u, int type) { + /* coerce 'u' to 'type' : */ SEXP v; #ifdef OLD if (type == SYMSXP) { diff --git a/src/main/eval.c b/src/main/eval.c index ed7a9dc2ae7..f7d3d5e21a5 100644 --- a/src/main/eval.c +++ b/src/main/eval.c @@ -601,7 +601,7 @@ SEXP do_return(SEXP call, SEXP op, SEXP args, SEXP rho) v = CAR(vals); break; default: - v = vals; + v = PairToVectorList(vals); break; } if (R_BrowseLevel) diff --git a/src/main/graphics.c b/src/main/graphics.c index e1b4d9a5200..993b10e2f0d 100644 --- a/src/main/graphics.c +++ b/src/main/graphics.c @@ -1747,7 +1747,7 @@ void GScale(double min, double max, int axis, DevDesc *dd) min, max, axis, log); if(!FINITE(min)) min = - .45 * DBL_MAX; if(!FINITE(max)) max = + .45 * DBL_MAX; - /* max - min is now finite */ + /* max - min is now finite */ } if(min == max) { if(min == 0) { @@ -2738,7 +2738,9 @@ void GPretty(double *lo, double *up, int *ndiv) double dx, cell, unit, base, U; int ns, nu, nd0; short i_small; - double x1,x2;/* for checking only */ +#ifdef DEBUG_PLOT + double x1,x2; +#endif if(*ndiv <= 0) error("invalid axis extents [GPretty(.,.,n=%d)\n", *ndiv); @@ -3107,33 +3109,31 @@ void GMtext(char *str, int side, double line, int outer, double at, int las, double angle, xadj, yadj; int coords; - angle = xadj = yadj = 0;/* to keep -Wall happy */ - coords = 0; /* to keep -Wall happy */ + angle = xadj = yadj = 0.;/* to keep -Wall happy */ + coords = 0;/* -Wall */ + + xadj = dd->gp.adj;/* ALL cases */ if(outer) { switch(side) { case 1: /* line = line+1; */ angle = 0; - xadj = dd->gp.adj; yadj = 0; coords = OMA1; break; case 2: angle = 90; - xadj = dd->gp.adj; yadj = 0; coords = OMA2; break; case 3: angle = 0; - xadj = dd->gp.adj; yadj = 0; coords = OMA3; break; case 4: /* line = line+1; */ angle = 90; - xadj = dd->gp.adj; yadj = 0; coords = OMA4; break; @@ -3147,20 +3147,18 @@ void GMtext(char *str, int side, double line, int outer, double at, int las, at = at + GConvertXUnits(dd->gp.yLineBias, LINES, USER, dd); line = line - dd->gp.yLineBias; angle = 90; - xadj = dd->gp.adj; yadj = 0.5; } else { line = line + 1 - dd->gp.yLineBias; angle = 0; - xadj = dd->gp.adj; yadj = 0; } coords = MAR1; break; case 2: if(las == 1 || las == 2) { - at = at /* + GConvertYUnits(dd->gp.yLineBias, LINES, USER, dd)*/; + at = at/* + GConvertYUnits(dd->gp.yLineBias, LINES, USER, dd)*/; line = line + dd->gp.yLineBias; angle = 0; xadj = dd->gp.adj; @@ -3169,7 +3167,6 @@ void GMtext(char *str, int side, double line, int outer, double at, int las, else { line = line + dd->gp.yLineBias; angle = 90; - xadj = dd->gp.adj; yadj = 0; } coords = MAR2; @@ -3179,13 +3176,11 @@ void GMtext(char *str, int side, double line, int outer, double at, int las, at = at - GConvertXUnits(dd->gp.yLineBias, LINES, USER, dd); line = line + dd->gp.yLineBias; angle = 90; - xadj = dd->gp.adj; yadj = 0.5; } else { line = line + dd->gp.yLineBias; angle = 0; - xadj = dd->gp.adj; yadj = 0; } coords = MAR3; @@ -3195,13 +3190,11 @@ void GMtext(char *str, int side, double line, int outer, double at, int las, at = at + GConvertYUnits(dd->gp.yLineBias, LINES, USER, dd); line = line + dd->gp.yLineBias; angle = 0; - xadj = 0; yadj = 0.5; } else { line = line + 1 - dd->gp.yLineBias; angle = 90; - xadj = dd->gp.adj; yadj = 0; } coords = MAR4; diff --git a/src/main/memory.c b/src/main/memory.c index 712fe920625..3b8dc31037e 100644 --- a/src/main/memory.c +++ b/src/main/memory.c @@ -122,7 +122,7 @@ SEXP do_gc(SEXP call, SEXP op, SEXP args, SEXP rho) void mem_err_heap(long size) { - error("heap memory (%ld Kb) exhausted [needed %ld Kb more]\n", + error("heap memory (%ld Kb) exhausted [needed %ld Kb more]\n See \"help(Memory)\" on how to increase the heap size.\n", (R_VSize * sizeof(VECREC))/1024, (size * sizeof(VECREC))/1024); } @@ -130,7 +130,7 @@ void mem_err_heap(long size) void mem_err_cons() { - error("cons memory (%ld cells) exhausted\n", R_NSize); + error("cons memory (%ld cells) exhausted\n See \"help(Memory)\" on how to increase the number of cons cells.\n", R_NSize); } #ifdef Macintosh diff --git a/src/main/model.c b/src/main/model.c index 8b79bddfb17..bfb5db21b95 100644 --- a/src/main/model.c +++ b/src/main/model.c @@ -1321,6 +1321,10 @@ SEXP do_modelframe(SEXP call, SEXP op, SEXP args, SEXP rho) PROTECT(na_action); PROTECT(tmp = lang2(na_action, data)); ans = eval(tmp, rho); + if (!isNewList(ans) || length(ans) != length(data)) + errorcall(call, "invalid result from na.action\n"); + for ( i = length(ans) ; i-- ; ) + ATTRIB(VECTOR(ans)[i]) = ATTRIB(VECTOR(data)[i]); UNPROTECT(2); } else ans = data; diff --git a/src/main/names.c b/src/main/names.c index a906c8cef63..d935d15e238 100644 --- a/src/main/names.c +++ b/src/main/names.c @@ -373,6 +373,8 @@ FUNTAB R_FunTab[] = {"sample", do_sample, 0, 11, 4, PP_FUNCALL}, +{"RNGkind", do_RNGkind, 0, 11, 1, PP_FUNCALL}, + /* Data Summaries */ {"sum", do_summary, 0, 11, -1, PP_FUNCALL}, @@ -481,8 +483,7 @@ FUNTAB R_FunTab[] = {"interactive", do_interactive, 0, 0, 0, PP_FUNCALL}, {"readline", do_readln, 0, 11, 0, PP_FUNCALL}, {"menu", do_menu, 0, 11, 1, PP_FUNCALL}, -{"print.default",do_printdefault,0, 111, 5, PP_FUNCALL}, -{"print.atomic",do_printdefault,0, 111, 5, PP_FUNCALL}, +{"print.default",do_printdefault,0, 111, 6, PP_FUNCALL}, {"print.matrix",do_printmatrix, 0, 111, 5, PP_FUNCALL}, {"invisible", do_invisible, 0, 101, 1, PP_FUNCALL}, {"gc", do_gc, 0, 11, 1, PP_FUNCALL}, diff --git a/src/main/names.h b/src/main/names.h index 94d56672587..e2a547b5555 100644 --- a/src/main/names.h +++ b/src/main/names.h @@ -244,6 +244,7 @@ SEXP do_replay(SEXP, SEXP, SEXP, SEXP); SEXP do_restoreb(SEXP, SEXP, SEXP, SEXP); SEXP do_return(SEXP, SEXP, SEXP, SEXP); SEXP do_rgb(SEXP, SEXP, SEXP, SEXP); +SEXP do_RNGkind(SEXP, SEXP, SEXP, SEXP); SEXP do_round(SEXP, SEXP, SEXP, SEXP); SEXP do_rownames(SEXP, SEXP, SEXP, SEXP); SEXP do_rowscols(SEXP, SEXP, SEXP, SEXP); diff --git a/src/main/plot.c b/src/main/plot.c index 11085f7dadf..d46c2db5cf4 100644 --- a/src/main/plot.c +++ b/src/main/plot.c @@ -753,7 +753,7 @@ SEXP do_axis(SEXP call, SEXP op, SEXP args, SEXP env) dd->gp.xpd = 1; dd->gp.adj = 0.5; dd->gp.font = dd->gp.fontaxis; - dd->gp.cex = dd->gp.cex * dd->gp.cexbase; + dd->gp.cex = dd->gp.cexbase * dd->gp.cexaxis; col = dd->gp.col; fg = dd->gp.fg; @@ -1595,8 +1595,7 @@ SEXP do_text(SEXP call, SEXP op, SEXP args, SEXP env) else dd->gp.col = dd->dp.col; if(ncex && FINITE(REAL(cex)[i%ncex])) - dd->gp.cex = dd->gp.cexbase * - REAL(cex)[i % ncex]; + dd->gp.cex = dd->gp.cexbase * REAL(cex)[i % ncex]; else dd->gp.cex = dd->gp.cexbase; if (nfont && INTEGER(font)[i % nfont] != NA_INTEGER) diff --git a/src/main/print.c b/src/main/print.c index 406a5f6d9dd..24e606ec53b 100644 --- a/src/main/print.c +++ b/src/main/print.c @@ -20,6 +20,25 @@ * print.default() -> do_printdefault & its sub-functions. * do_printmatrix, do_sink, do_invisible * + * do_printdefault + * -> PrintDefaults + * -> CustomPrintValue + * -> PrintValueRec + * -> __ITSELF__ (recursion) + * -> PrintGenericVector -> PrintValueRec (recursion) + * -> PrintList -> PrintValueRec (recursion) + * -> printAttributes -> PrintValueRec (recursion) + * -> PrintExpression + * -> printVector >>>>> ./printvector.c + * -> printNamedVector >>>>> ./printvector.c + * -> printMatrix >>>>> ./printarray.c + * -> printArray >>>>> ./printarray.c + * + * do_printmatrix + * -> PrintDefaults + * -> printMatrix >>>>> ./printarray.c + * + * * See ./printutils.c for general remarks on Printing * and the Encode.. utils. * @@ -40,6 +59,7 @@ int R_print_width; SEXP print_na_string; int print_na_width; int print_quote; +int print_right; int print_digits; int print_gap; @@ -52,6 +72,7 @@ void PrintDefaults(SEXP rho) print_na_string = NA_STRING; print_na_width = strlen(CHAR(print_na_string)); print_quote = 1; + print_right = 0; print_digits = GetOptionDigits(rho); print_gap = 1; R_print_width = GetOptionWidth(rho); @@ -90,7 +111,7 @@ SEXP do_invisible(SEXP call, SEXP op, SEXP args, SEXP rho) SEXP do_printmatrix(SEXP call, SEXP op, SEXP args, SEXP rho) { - int quote, right; + int quote; SEXP a, x, rowlab, collab; #ifdef OLD SEXP oldnames; @@ -102,7 +123,7 @@ SEXP do_printmatrix(SEXP call, SEXP op, SEXP args, SEXP rho) rowlab = CAR(a); a = CDR(a); collab = CAR(a); a = CDR(a); quote = asInteger(CAR(a)); a = CDR(a); - right = asInteger(CAR(a)); + print_right = asInteger(CAR(a)); #ifdef OLD PROTECT(oldnames = getAttrib(x, R_DimNamesSymbol)); /* fix up the dimnames */ @@ -123,22 +144,24 @@ SEXP do_printmatrix(SEXP call, SEXP op, SEXP args, SEXP rho) if (length(rowlab) == 0) rowlab = R_NilValue; if (length(collab) == 0) collab = R_NilValue; #endif - printMatrix(x, 0, getAttrib(x, R_DimSymbol), quote, right, rowlab, collab); + printMatrix(x, 0, getAttrib(x, R_DimSymbol), quote, print_right, rowlab, collab); #ifdef OLD setAttrib(x, R_DimNamesSymbol, oldnames); UNPROTECT(1); #endif return x; -} +}/* do_printmatrix */ /* .Internal(print.default(x, digits, quote, na.print, print.gap)) */ -/* Should now also dispatch to e.g., print.matrix(..) */ -/* The 'digits' must be "stored" here, since print.matrix */ -/* (aka prmatrix) does NOT accept a digits argument ... */ +SEXP do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho){ + +/* FIXME: + * Should now also dispatch to e.g., print.matrix(..) + * The 'digits' must be "stored" here, since print.matrix + * (aka prmatrix) does NOT accept a digits argument ... + */ -SEXP do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho) -{ SEXP x, naprint; checkArity(op, args); PrintDefaults(rho); @@ -173,10 +196,16 @@ SEXP do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho) if (print_gap == NA_INTEGER || print_gap < 1 || print_gap > 10) errorcall(call, "invalid gap parameter\n"); } + args = CDR(args); + + print_right = asLogical(CAR(args)); + if(print_right == NA_LOGICAL) + errorcall(call, "invalid right parameter\n"); + args = CDR(args); CustomPrintValue(x, rho); return x; -} +}/* do_printdefault */ /* FIXME : We need a general mechanism for "rendering" symbols. */ @@ -227,7 +256,7 @@ static void PrintGenericVector(SEXP s, SEXP env) if (LENGTH(dims) == 2) { SEXP rl, cl; GetMatrixDimnames(s, &rl, &cl); - printMatrix(t, 0, dims, 0, 0, rl, cl); + printMatrix(t, 0, dims, print_quote, print_right, rl, cl); } else { names = GetArrayDimnames(s); @@ -332,7 +361,7 @@ static void printList(SEXP s, SEXP env) if (LENGTH(dims) == 2) { SEXP rl, cl; GetMatrixDimnames(s, &rl, &cl); - printMatrix(t, 0, dims, 0, 0, rl, cl); + printMatrix(t, 0, dims, print_quote, print_right, rl, cl); } else { dimnames = getAttrib(s, R_DimNamesSymbol); @@ -397,9 +426,10 @@ static void PrintExpression(SEXP s) } -/* PrintValueRec - recursively print an SEXP */ -/* This is the "dispatching" function for print.default() */ +/* PrintValueRec -- recursively print an SEXP + * This is the "dispatching" function for print.default() + */ void PrintValueRec(SEXP s,SEXP env) { int i; @@ -466,7 +496,7 @@ void PrintValueRec(SEXP s,SEXP env) else if (LENGTH(t) == 2) { SEXP rl, cl; GetMatrixDimnames(s, &rl, &cl); - printMatrix(s, 0, t, print_quote, 0, rl, cl); + printMatrix(s, 0, t, print_quote, print_right, rl, cl); } else { SEXP dimnames; diff --git a/src/main/printarray.c b/src/main/printarray.c index f8f32f03703..21ba0afdab3 100644 --- a/src/main/printarray.c +++ b/src/main/printarray.c @@ -245,8 +245,8 @@ static void printComplexMatrix(SEXP sx, int offset, int r, int c, Rprintf("%s", EncodeReal(NA_REAL, w[j], 0, 0)); else Rprintf("%s", EncodeComplex(x[i + j * r], - wr[j] + PRINT_GAP, dr[j], er[j], - wi[j], dr[j], er[j])); + wr[j] + PRINT_GAP, dr[j], er[j], + wi[j], dr[j], er[j])); } } Rprintf("\n"); @@ -308,7 +308,7 @@ static void printStringMatrix(SEXP sx, int offset, int r, int c, } void printMatrix(SEXP x, int offset, SEXP dim, int quote, int right, - SEXP rl, SEXP cl) + SEXP rl, SEXP cl) { int r, c; @@ -336,6 +336,7 @@ void printMatrix(SEXP x, int offset, SEXP dim, int quote, int right, static void printArrayGeneral(SEXP x, SEXP dim, int quote, SEXP dimnames) { +/* == printArray(.) */ SEXP ii, nn, dn; int i, j, k, l, b, nb, ndim; int nr, nc; diff --git a/src/main/random.c b/src/main/random.c index 131c957d750..9b9bd9b6dcd 100644 --- a/src/main/random.c +++ b/src/main/random.c @@ -21,56 +21,138 @@ #include "Defn.h" #include "Mathlib.h" -extern int ix_seed; -extern int iy_seed; -extern int iz_seed; - -static int naflag = 0; - -static void Randomize() -{ - srand((int)time(NULL)); - ix_seed = abs(rand() % 30269); - iy_seed = abs(rand() % 30307); - iz_seed = abs(rand() % 30323); -} +/* .Random.seed == (RNGkind, i1_seed, i_seed[0],i_seed[1],..,i_seed[n_seed-2]) + * i2_seed i3_seed + * or == (RNGkind) [--> Randomize that one !] + */ -static void GetSeeds() +static void GetRNGstate() { + /* Get .Random.seed into proper variables */ + int len_seed, j, seed_off; SEXP seeds; + len_seed = RNG_Table[RNG_kind].n_seed; + seeds = findVar(R_SeedsSymbol, R_GlobalEnv); if (seeds == R_UnboundValue) { - Randomize(); + Randomize(RNG_kind); } else { if (seeds == R_MissingArg) error(".Random.seed is a missing argument with no default\n"); - if (!isVector(seeds) || LENGTH(seeds) < 3) - error("missing or invalid random number seeds\n"); + if (!isVector(seeds)) + error(".Random.seed is not a vector\n"); + seed_off = 0; + if(LENGTH(seeds)!= 1 && LENGTH(seeds) < len_seed + 1) { + if(LENGTH(seeds) == RNG_Table[WICHMANN_HILL].n_seed) { + /* BACKWARDS COMPATIBILITY: */ + seed_off = 1; + warning("Wrong length .Random.seed; forgot initial RNGkind? set to Wichmann-Hill\n"); + /* compatibility mode */ + RNG_kind = WICHMANN_HILL; + } else { + error(".Random.seed has wrong length.\n"); + } + } seeds = coerceVector(seeds, INTSXP); - ix_seed = INTEGER(seeds)[0]; if (!ix_seed) ix_seed++; - iy_seed = INTEGER(seeds)[1]; if (!iy_seed) iy_seed++; - iz_seed = INTEGER(seeds)[2]; if (!iz_seed) iz_seed++; + if(!seed_off) RNG_kind = INTEGER(seeds)[0]; + + switch(RNG_kind) { + case WICHMANN_HILL: + case MARSAGLIA_MULTICARRY: + case SUPER_DUPER: + case RAND: + break; + case MERSENNE_TWISTER: + error("'Mersenne-Twister' not yet implemented\n"); break; + default: + error(".Random.seed[1] is NOT a valid RNG kind (code)\n"); + } + if(LENGTH(seeds) == 1) + Randomize(RNG_kind); + else { + RNG_Table[RNG_kind].i1_seed = INTEGER(seeds)[1- seed_off]; + for(j=2; j <= len_seed; j++) + RNG_Table[RNG_kind].i_seed[j-2] = INTEGER(seeds)[j - seed_off]; + FixupSeeds(RNG_kind); + } } } -static void PutSeeds() +static void PutRNGstate() { + int len_seed, j; SEXP seeds; - PROTECT(seeds = allocVector(INTSXP, 3)); - INTEGER(seeds)[0] = ix_seed; - INTEGER(seeds)[1] = iy_seed; - INTEGER(seeds)[2] = iz_seed; + len_seed = RNG_Table[RNG_kind].n_seed; + + PROTECT(seeds = allocVector(INTSXP, len_seed + 1)); + + INTEGER(seeds)[0] = RNG_kind; + INTEGER(seeds)[1] = RNG_Table[RNG_kind].i1_seed; + for(j=2; j <= len_seed; j++) + INTEGER(seeds)[j] = RNG_Table[RNG_kind].i_seed[j-2]; + setVar(R_SeedsSymbol, seeds, R_GlobalEnv); UNPROTECT(1); } +static void RNGkind(RNGtype newkind) +{ +/* Choose a new kind of RNG. + * Initialize its seed by calling the old RNG's sunif() + */ + GetRNGstate(); + + RNG_Init(newkind, sunif() * UINT_MAX); + + switch(newkind) { + case WICHMANN_HILL: + case MARSAGLIA_MULTICARRY: + case SUPER_DUPER: + break; + case RAND: + error("RNGkind: \"Rand\" not yet available (BUG)!\n"); + srand((unsigned int)sunif()*UINT_MAX); + break; + case MERSENNE_TWISTER: + /* ... */ + error("RNGkind: \"Mersenne-Twister\" not yet available!\n"); + break; + default: + error("RNGkind: unimplemented RNG kind %d\n", newkind); + } + RNG_kind = newkind; + + PutRNGstate(); +} + +SEXP do_RNGkind (SEXP call, SEXP op, SEXP args, SEXP env) +{ + SEXP r; + RNGtype kind, oldkind; + + checkArity(op,args); + oldkind = RNG_kind; + r = CAR(args); + if(length(r)) { /* set a new RNG kind */ + kind = asInteger(r); + RNGkind(kind); + } + r = allocVector(INTSXP, 1); + INTEGER(r)[0] = oldkind; + return r; +} + +/*------ Part without RNGkind dependency ------------------------*/ + +static int naflag = 0; + static void invalid(SEXP call) { errorcall(call, "invalid arguments\n"); } -static void random1(double (*f) (), double * a, int na, double * x, int n) +static void random1(double (*f) (), double *a, int na, double *x, int n) { double ai; int i; @@ -120,7 +202,7 @@ SEXP do_random1(SEXP call, SEXP op, SEXP args, SEXP rho) else { PROTECT(a = coerceVector(CADR(args), REALSXP)); naflag = 0; - GetSeeds(); + GetRNGstate(); switch (PRIMVAL(op)) { RAND1(0, rchisq); RAND1(1, rexp); @@ -134,15 +216,15 @@ SEXP do_random1(SEXP call, SEXP op, SEXP args, SEXP rho) if (naflag) warning("NAs produced in function \"%s\"\n", PRIMNAME(op)); - PutSeeds(); + PutRNGstate(); UNPROTECT(1); } UNPROTECT(1); return x; } -static void random2(double (*f) (), double * a, int na, double * b, int nb, - double * x, int n) +static void random2(double (*f) (), double *a, int na, double *b, int nb, + double *x, int n) { double ai, bi; int i; errno = 0; @@ -195,7 +277,7 @@ SEXP do_random2(SEXP call, SEXP op, SEXP args, SEXP rho) PROTECT(a = coerceVector(CADR(args), REALSXP)); PROTECT(b = coerceVector(CADDR(args), REALSXP)); naflag = 0; - GetSeeds(); + GetRNGstate(); switch (PRIMVAL(op)) { RAND2(0, rbeta); RAND2(1, rbinom); @@ -215,15 +297,15 @@ SEXP do_random2(SEXP call, SEXP op, SEXP args, SEXP rho) if (naflag) warning("NAs produced in function \"%s\"\n", PRIMNAME(op)); - PutSeeds(); + PutRNGstate(); UNPROTECT(2); } UNPROTECT(1); return x; } -static void random3(double (*f) (), double * a, int na, double * b, int nb, - double * c, int nc, double * x, int n) +static void random3(double (*f) (), double *a, int na, double *b, int nb, + double *c, int nc, double *x, int n) { double ai, bi, ci; int i; @@ -284,7 +366,7 @@ SEXP do_random3(SEXP call, SEXP op, SEXP args, SEXP rho) PROTECT(b = coerceVector(b, REALSXP)); PROTECT(c = coerceVector(c, REALSXP)); naflag = 0; - GetSeeds(); + GetRNGstate(); switch (PRIMVAL(op)) { RAND3(0, rhyper); default: @@ -293,7 +375,7 @@ SEXP do_random3(SEXP call, SEXP op, SEXP args, SEXP rho) if (naflag) warning("NAs produced in function \"%s\"\n", PRIMNAME(op)); - PutSeeds(); + PutRNGstate(); UNPROTECT(3); } UNPROTECT(1); @@ -310,53 +392,6 @@ SEXP do_random3(SEXP call, SEXP op, SEXP args, SEXP rho) * "with replacement" case. */ -/* Sort into descending order (heapsort) */ - -static void revsort(int n, double *ra, int *rb) -{ - int l, j, ir, i; - double rra; - int rrb; - - ra--; rb--; - - l = (n >> 1) + 1; - ir = n; - - for (;;) { - if (l > 1) { - l = l - 1; - rra = ra[l]; - rrb = rb[l]; - } - else { - rra = ra[ir]; - rrb = rb[ir]; - ra[ir] = ra[1]; - rb[ir] = rb[1]; - if (--ir == 1) { - ra[1] = rra; - rb[1] = rrb; - return; - } - } - i = l; - j = l << 1; - while (j <= ir) { - if (j < ir && ra[j] > ra[j + 1]) ++j; - if (rra > ra[j]) { - ra[i] = ra[j]; - rb[i] = rb[j]; - j += (i = j); - } - else - j = ir + 1; - } - ra[i] = rra; - rb[i] = rrb; - } -} - /* Unequal probability sampling; with-replacement case */ static void ProbSampleReplace(int n, double *p, int *perm, int nans, int *ans) @@ -370,11 +405,11 @@ static void ProbSampleReplace(int n, double *p, int *perm, int nans, int *ans) perm[i] = i + 1; /* sort the probabilities into descending order */ - revsort(n, p, perm); + revsort(p, perm, n); /* compute cumulative probabilities */ for (i = 1 ; i < n; i++) - p[i] = p[i - 1] + p[i]; + p[i] += p[i - 1]; /* compute the sample */ for (i = 0; i < nans; i++) { @@ -401,7 +436,7 @@ static void ProbSampleNoReplace(int n, double *p, int *perm, /* Sort probabilities into descending order */ /* Order element identities in parallel */ - revsort(n, p, perm); + revsort(p, perm, n); /* Compute the sample */ totalmass = 1; @@ -466,7 +501,7 @@ static void FixupProb(SEXP call, double *p, int n, int k, int replace) sum += p[i]; } if (npos == 0 || (!replace && k > npos)) - errorcall(call, "insufficient positive probabilies\n"); + errorcall(call, "insufficient positive probabilities\n"); for (i = 0; i < n; i++) p[i] = p[i] / sum; } @@ -488,7 +523,7 @@ SEXP do_sample(SEXP call, SEXP op, SEXP args, SEXP rho) errorcall(call, "invalid second argument\n"); if (!replace && k > n) errorcall(call, "can't take a sample larger than the population\n when replace = FALSE\n"); - GetSeeds(); + GetRNGstate(); PROTECT(y = allocVector(INTSXP, k)); if (!isNull(prob)) { prob = coerceVector(prob, REALSXP); @@ -511,7 +546,7 @@ SEXP do_sample(SEXP call, SEXP op, SEXP args, SEXP rho) SampleNoReplace(k, n, INTEGER(y), INTEGER(x)); } } - PutSeeds(); + PutRNGstate(); UNPROTECT(1); return y; } @@ -524,22 +559,11 @@ SEXP do_sample(SEXP call, SEXP op, SEXP args, SEXP rho) void seed_in(long *ignored) { - GetSeeds(); + GetRNGstate(); } void seed_out(long *ignored) { - PutSeeds(); -} - -/* -double unif_rand(void) -{ - sunif(); -} - -double norm_rand(void) -{ - snorm(); + PutRNGstate(); } -*/ +/* unif_rand == sunif , norm_rand == snorm via 'define' in Mathlib.h */ diff --git a/src/main/sort.c b/src/main/sort.c index e595a511e1c..1f7f9028a3b 100644 --- a/src/main/sort.c +++ b/src/main/sort.c @@ -176,6 +176,56 @@ void ssort(SEXP *x, int n) } while (h != 1); } +void revsort(double *a, int *ib, int n) +{ +/* Sort a[] into descending order by "heapsort"; + * sort ib[] alongside; + * if initially, ib[] = 1...n, it will contain the permutation finally + */ + + int l, j, ir, i; + double ra; + int ii; + + a--; ib--; + + l = (n >> 1) + 1; + ir = n; + + for (;;) { + if (l > 1) { + l = l - 1; + ra = a[l]; + ii = ib[l]; + } + else { + ra = a[ir]; + ii = ib[ir]; + a[ir] = a[1]; + ib[ir] = ib[1]; + if (--ir == 1) { + a[1] = ra; + ib[1] = ii; + return; + } + } + i = l; + j = l << 1; + while (j <= ir) { + if (j < ir && a[j] > a[j + 1]) ++j; + if (ra > a[j]) { + a[i] = a[j]; + ib[i] = ib[j]; + j += (i = j); + } + else + j = ir + 1; + } + a[i] = ra; + ib[i] = ii; + } +} + void sortVector(SEXP s) { int n; diff --git a/src/main/subassign.c b/src/main/subassign.c index d091ddc3e21..09bc8b0f89c 100644 --- a/src/main/subassign.c +++ b/src/main/subassign.c @@ -200,6 +200,7 @@ static void SubassignTypeFix(SEXP *x, SEXP *y, *x = coerceVector(*x, STRSXP); break; + case 1906: /* vector <- language */ case 1910: /* vector <- logical */ case 1913: /* vector <- integer */ case 1914: /* vector <- real */ diff --git a/src/main/subset.c b/src/main/subset.c index 722dfde9b2c..2ee67ccf2ec 100644 --- a/src/main/subset.c +++ b/src/main/subset.c @@ -270,7 +270,8 @@ SEXP MatrixSubset(SEXP x, SEXP s, SEXP call, int drop) UNPROTECT(1); } } - copyMostAttrib(x, result); + /* Probably should not do this: + copyMostAttrib(x, result); */ if (drop) DropDims(result); UNPROTECT(3); @@ -736,14 +737,12 @@ SEXP do_subset3(SEXP call, SEXP op, SEXP args, SEXP env) return y; break; case PARTIAL_MATCH: - if (havematch) - return R_NilValue; - havematch = 1; + havematch++; xmatch = y; break; } } - if (havematch) { + if (havematch == 1) { y = CAR(xmatch); NAMED(y) = NAMED(x); return y; @@ -764,14 +763,12 @@ SEXP do_subset3(SEXP call, SEXP op, SEXP args, SEXP env) return y; break; case PARTIAL_MATCH: - if(havematch) - return R_NilValue; - havematch = 1; + havematch++; imatch = i; break; } } - if(havematch) { + if(havematch ==1) { y = VECTOR(x)[imatch]; NAMED(y) = NAMED(x); return y; diff --git a/src/main/version.c b/src/main/version.c index 217a1ed9018..04a6ca671d1 100644 --- a/src/main/version.c +++ b/src/main/version.c @@ -34,7 +34,8 @@ void PrintGreeting(void) Rprintf("Type\t\"demo()\" for some demos," " \"help()\" for on-line help, or\n\t\"help.start()\"" - " for a HTML browser interface to help.\n\n"); + " for a HTML browser interface to help.\n"); + Rprintf("Type\t\"q()\" to quit R.\n\n"); } SEXP do_version(SEXP call, SEXP op, SEXP args, SEXP env) diff --git a/src/nmath/Makefile.in b/src/nmath/Makefile.in index 448939e4453..fbc5a76ef37 100644 --- a/src/nmath/Makefile.in +++ b/src/nmath/Makefile.in @@ -59,6 +59,7 @@ $(LIB): $(OBJS) $(RANLIB) $(LIB) $(OBJS): $(top_srcdir)/src/include/Mathlib.h +sunif.o: $(top_srcdir)/src/include/Random.h mostlyclean: clean clean: diff --git a/src/nmath/bessel_i.c b/src/nmath/bessel_i.c index 0be6a880e9f..31aa7269f03 100644 --- a/src/nmath/bessel_i.c +++ b/src/nmath/bessel_i.c @@ -24,7 +24,6 @@ * ------------------------------=#---- Martin Maechler, ETH Zurich */ #include "Mathlib.h" -#include "Error.h" static double exparg = 709.;/* maximal x for UNscaled answer, see below */ @@ -42,12 +41,13 @@ double bessel_i(double x, double alpha, double expo) bi = (double *) calloc(nb, sizeof(double)); I_bessel(&x, &alpha, &nb, &ize, bi, &ncalc); if(ncalc != nb) {/* error input */ - if(ncalc < 0) - warning("bessel_i(%g): ncalc (=%d) != nb (=%d); alpha=%g.%s\n", - x, ncalc, nb, alpha," Arg. out of range?"); - else - warning("bessel_i(%g,nu=%g): precision lost in result\n", - x, alpha+nb-1); + if(ncalc < 0) + MATHLIB_WARNING4("bessel_i(%g): ncalc (=%d) != nb (=%d); alpha=%g." + " Arg. out of range?\n", + x, ncalc, nb, alpha); + else + MATHLIB_WARNING2("bessel_i(%g,nu=%g): precision lost in result\n", + x, alpha+nb-1); } x = bi[nb-1]; free(bi); diff --git a/src/nmath/bessel_j.c b/src/nmath/bessel_j.c index a650ab1fc91..b70770aaadc 100644 --- a/src/nmath/bessel_j.c +++ b/src/nmath/bessel_j.c @@ -24,7 +24,6 @@ * ------------------------------=#---- Martin Maechler, ETH Zurich */ #include "Mathlib.h" -#include "Error.h" double bessel_j(double x, double alpha) { @@ -44,11 +43,11 @@ double bessel_j(double x, double alpha) J_bessel(&x, &alpha, &nb, bj, &ncalc); if(ncalc != nb) {/* error input */ if(ncalc < 0) - warning("bessel_j(%g): ncalc (=%d) != nb (=%d); alpha=%g.%s\n", - x, ncalc, nb, alpha," Arg. out of range?"); + MATHLIB_WARNING4("bessel_j(%g): ncalc (=%d) != nb (=%d); alpha=%g. Arg. out of range?\n", + x, ncalc, nb, alpha); else - warning("bessel_j(%g,nu=%g): precision lost in result\n", - x, alpha+nb-1); + MATHLIB_WARNING2("bessel_j(%g,nu=%g): precision lost in result\n", + x, alpha+nb-1); } x = bj[nb-1]; free(bj); diff --git a/src/nmath/bessel_k.c b/src/nmath/bessel_k.c index 2653f90f00a..99873ae6b7d 100644 --- a/src/nmath/bessel_k.c +++ b/src/nmath/bessel_k.c @@ -24,7 +24,6 @@ * ------------------------------=#---- Martin Maechler, ETH Zurich */ #include "Mathlib.h" -#include "Error.h" static double xmax = 705.342;/* maximal x for UNscaled answer, see below */ @@ -37,17 +36,17 @@ double bessel_k(double x, double alpha, double expo) if (ISNAN(x) || ISNAN(alpha)) return x + alpha; #endif ize = (long)expo; - nb = 1+ (long)floor(alpha);/* nb-1 <= alpha < nb */ + nb = 1+ (long)floor(fabs(alpha));/* nb-1 <= alpha < nb */ alpha -= (nb-1); bk = (double *) calloc(nb, sizeof(double)); K_bessel(&x, &alpha, &nb, &ize, bk, &ncalc); if(ncalc != nb) {/* error input */ if(ncalc < 0) - warning("bessel_k(%g): ncalc (=%d) != nb (=%d); alpha=%g.%s\n", - x, ncalc, nb, alpha," Arg. out of range?"); + MATHLIB_WARNING4("bessel_k(%g): ncalc (=%d) != nb (=%d); alpha=%g. Arg. out of range?\n", + x, ncalc, nb, alpha); else - warning("bessel_k(%g,nu=%g): precision lost in result\n", - x, alpha+nb-1); + MATHLIB_WARNING2("bessel_k(%g,nu=%g): precision lost in result\n", + x, alpha+nb-1); } x = bk[nb-1]; free(bk); @@ -60,7 +59,7 @@ void K_bessel(double *x, double *alpha, long *nb, /*------------------------------------------------------------------- This routine calculates modified Bessel functions - of the second kind, K_(N+ALPHA) (X), for non-negative + of the third kind, K_(N+ALPHA) (X), for non-negative argument X, and non-negative order N+ALPHA, with or without exponential scaling. diff --git a/src/nmath/bessel_y.c b/src/nmath/bessel_y.c index 63fd8d5c534..ae33f57208f 100644 --- a/src/nmath/bessel_y.c +++ b/src/nmath/bessel_y.c @@ -24,7 +24,6 @@ * ------------------------------=#---- Martin Maechler, ETH Zurich */ #include "Mathlib.h" -#include "Error.h" double bessel_y(double x, double alpha) { @@ -42,11 +41,11 @@ double bessel_y(double x, double alpha) if(ncalc == -1) return ML_POSINF; else if(ncalc < -1) - warning("bessel_y(%g): ncalc (=%d) != nb (=%d); alpha=%g.%s\n", - x, ncalc, nb, alpha," Arg. out of range?"); + MATHLIB_WARNING4("bessel_y(%g): ncalc (=%d) != nb (=%d); alpha=%g. Arg. out of range?\n", + x, ncalc, nb, alpha); else /* ncalc >= 0 */ - warning("bessel_y(%g,nu=%g): precision lost in result\n", - x, alpha+nb-1); + MATHLIB_WARNING2("bessel_y(%g,nu=%g): precision lost in result\n", + x, alpha+nb-1); } x = by[nb-1]; free(by); diff --git a/src/nmath/dsignrank.c b/src/nmath/dsignrank.c index 4c235c1f654..c90ab26996f 100644 --- a/src/nmath/dsignrank.c +++ b/src/nmath/dsignrank.c @@ -27,7 +27,6 @@ */ #include "Mathlib.h" -#include "Error.h" static double *w[SIGNRANK_NMAX]; @@ -65,7 +64,7 @@ double dsignrank(double x, double n) { ML_ERROR(ME_DOMAIN); return ML_NAN; } else if (n >= SIGNRANK_NMAX) { - warning("n should be less than %d\n", SIGNRANK_NMAX); + MATHLIB_WARNING("n should be less than %d\n", SIGNRANK_NMAX); return ML_NAN; } x = floor(x + 0.5); diff --git a/src/nmath/dwilcox.c b/src/nmath/dwilcox.c index 7c2ad2e3a51..a515fdec262 100644 --- a/src/nmath/dwilcox.c +++ b/src/nmath/dwilcox.c @@ -27,7 +27,6 @@ */ #include "Mathlib.h" -#include "Error.h" static double *w[WILCOX_MMAX][WILCOX_NMAX]; @@ -72,11 +71,11 @@ double dwilcox(double x, double m, double n) { return ML_NAN; } if (m >= WILCOX_MMAX) { - warning("m should be less than %d\n", WILCOX_MMAX); + MATHLIB_WARNING("m should be less than %d\n", WILCOX_MMAX); return ML_NAN; } if (n >= WILCOX_NMAX) { - warning("n should be less than %d\n", WILCOX_NMAX); + MATHLIB_WARNING("n should be less than %d\n", WILCOX_NMAX); return ML_NAN; } x = floor(x + 0.5); diff --git a/src/nmath/lgamma.c b/src/nmath/lgamma.c index e1d43e534ec..8637bf1e67c 100644 --- a/src/nmath/lgamma.c +++ b/src/nmath/lgamma.c @@ -39,7 +39,6 @@ */ #include "Mathlib.h" -#include "Error.h" int signgam; @@ -85,7 +84,7 @@ double lgammafn(double x) if (sinpiy == 0) { /* Negative integer argument === Now UNNECESSARY: caught above */ - warning(" **this should NEVER happen! *** [lgamma.c: Neg.int]\n"); + MATHLIB_WARNING(" ** should NEVER happen! *** [lgamma.c: Neg.int, y=%g]\n",y); ML_ERROR(ME_DOMAIN); return ML_NAN; } diff --git a/src/nmath/pnchisq.c b/src/nmath/pnchisq.c index fb575ac2367..64579112fd3 100644 --- a/src/nmath/pnchisq.c +++ b/src/nmath/pnchisq.c @@ -8,17 +8,16 @@ #include "Mathlib.h" -/*----------- DEBUGGING -------------*/ -/* #define DEBUG_pnch - * rather use make CFLAGS='-DDEBUG_pnch -g -I/usr/local/include -I../include' +/*----------- DEBUGGING ------------- + * + * make CFLAGS='-DDEBUG_pnch -g -I/usr/local/include -I../include' * -- Feb.1, 1998 (R 0.62 alpha); M.Maechler: still have - - INFINITE loop \ - - bad precision / in some cases - + - INFINITE loop \ + - bad precision / in some cases */ #ifdef DEBUG_pnch -#include "PrtUtil.h" +# include "PrtUtil.h" #endif double pnchisq(double x, double f, double theta) diff --git a/src/nmath/polygamma.c b/src/nmath/polygamma.c index 72b58317b51..af4b99560d1 100644 --- a/src/nmath/polygamma.c +++ b/src/nmath/polygamma.c @@ -20,7 +20,7 @@ * * #include "Mathlib.h" * void dpsifn(double x, int n, int kode, int m, - * double *ans, int *nz, int *ierr) + * double *ans, int *nz, int *ierr) * double digamma(double x); * double trigamma(double x) * double tetragamma(double x) @@ -35,26 +35,26 @@ * * Definition 1 * - * psi(x) = d/dx (ln(gamma(x)), the first derivative of - * the log gamma function. + * psi(x) = d/dx (ln(gamma(x)), the first derivative of + * the log gamma function. * * Definition 2 - * k k - * psi(k,x) = d /dx (psi(x)), the k-th derivative - * of psi(x). + * k k + * psi(k,x) = d /dx (psi(x)), the k-th derivative + * of psi(x). * * * "dpsifn" computes a sequence of scaled derivatives of * the psi function; i.e. for fixed x and m it computes * the m-member sequence * - * ((-1)**(k+1)/gamma(k+1))*psi(k,x) - * for k = n,...,n+m-1 + * ((-1)**(k+1)/gamma(k+1))*psi(k,x) + * for k = n,...,n+m-1 * * where psi(k,x) is as defined above. For kode=1, dpsifn * returns the scaled derivatives as described. kode=2 is * operative only when k=0 and in that case dpsifn returns - * -psi(x) + ln(x). That is, the logarithmic behavior for + * -psi(x) + ln(x). That is, the logarithmic behavior for * large x is removed when kode=2 and k=0. When sums or * differences of psi functions are computed the logarithmic * terms can be combined analytically and computed separately @@ -64,39 +64,39 @@ * * INPUT * - * x - argument, x > 0. + * x - argument, x > 0. * - * n - first member of the sequence, 0 <= n <= 100 - * n == 0 gives ans(1) = -psi(x) for kode=1 - * -psi(x)+ln(x) for kode=2 + * n - first member of the sequence, 0 <= n <= 100 + * n == 0 gives ans(1) = -psi(x) for kode=1 + * -psi(x)+ln(x) for kode=2 * - * kode - selection parameter - * kode == 1 returns scaled derivatives of the - * psi function. - * kode == 2 returns scaled derivatives of the - * psi function except when n=0. In this case, - * ans(1) = -psi(x) + ln(x) is returned. + * kode - selection parameter + * kode == 1 returns scaled derivatives of the + * psi function. + * kode == 2 returns scaled derivatives of the + * psi function except when n=0. In this case, + * ans(1) = -psi(x) + ln(x) is returned. * - * m - number of members of the sequence, m >= 1 + * m - number of members of the sequence, m >= 1 * * OUTPUT * - * ans - a vector of length at least m whose first m - * components contain the sequence of derivatives - * scaled according to kode. + * ans - a vector of length at least m whose first m + * components contain the sequence of derivatives + * scaled according to kode. * - * nz - underflow flag - * nz == 0, a normal return - * nz != 0, underflow, last nz components of ans are - * set to zero, ans(m-k+1)=0.0, k=1,...,nz + * nz - underflow flag + * nz == 0, a normal return + * nz != 0, underflow, last nz components of ans are + * set to zero, ans(m-k+1)=0.0, k=1,...,nz * - * ierr - error flag - * ierr=0, a normal return, computation completed - * ierr=1, input error, no computation - * ierr=2, overflow, x too small or n+m-1 too - * large or both - * ierr=3, error, n too large. dimensioned - * array trmr(nmax) is not large enough for n + * ierr - error flag + * ierr=0, a normal return, computation completed + * ierr=1, input error, no computation + * ierr=2, overflow, x too small or n+m-1 too + * large or both + * ierr=3, error, n too large. dimensioned + * array trmr(nmax) is not large enough for n * * The nominal computational accuracy is the maximum of unit * roundoff (d1mach(4)) and 1e-18 since critical constants @@ -106,11 +106,11 @@ * for large x >= xmin followed by backward recursion on a two * term recursion relation * - * w(x+1) + x**(-n-1) = w(x). + * w(x+1) + x**(-n-1) = w(x). * * this is supplemented by a series * - * sum( (x+k)**(-n-1) , k=0,1,2,... ) + * sum( (x+k)**(-n-1) , k=0,1,2,... ) * * which converges rapidly for large n. both xmin and the * number of terms of the series are calculated from the unit @@ -290,7 +290,7 @@ void dpsifn(double x, int n, int kode, int m, double *ans, int *nz, int *ierr) if (mm!=1) { - /* generate higher derivatives, j > n */ + /* generate higher derivatives, j > n */ tol = wdtol / 5.0; for(j=2 ; j<=mm ; j++) { @@ -477,26 +477,3 @@ double pentagamma(double x) } return 6.0 * ans; } - -#undef TESTING - -#ifdef TESTING -main() -{ - int n, kode, m, nz, ierr; - double x, ans[10]; - - n = 0; - m = 3; - kode = 1; - for(;;) { - scanf("%lf",&x); - dpsifn(x, n, kode, m, ans, &nz, &ierr); - printf("%g ", x); - printf("%g ", ans[0]); - printf("%g ", ans[1]); - printf("%g ", ans[2]); - printf("\n"); - } -} -#endif diff --git a/src/nmath/psignrank.c b/src/nmath/psignrank.c index d9533b4681f..9c9e08af23d 100644 --- a/src/nmath/psignrank.c +++ b/src/nmath/psignrank.c @@ -27,7 +27,6 @@ */ #include "Mathlib.h" -#include "Error.h" double psignrank(double x, double n) { int i; @@ -46,7 +45,7 @@ double psignrank(double x, double n) { ML_ERROR(ME_DOMAIN); return ML_NAN; } else if (n >= SIGNRANK_NMAX) { - warning("n should be less than %d\n", SIGNRANK_NMAX); + MATHLIB_WARNING("n should be less than %d\n", SIGNRANK_NMAX); return ML_NAN; } x = floor(x + 0.5); diff --git a/src/nmath/pwilcox.c b/src/nmath/pwilcox.c index 07032ec72d3..39e5ff392e8 100644 --- a/src/nmath/pwilcox.c +++ b/src/nmath/pwilcox.c @@ -27,7 +27,6 @@ */ #include "Mathlib.h" -#include "Error.h" double pwilcox(double x, double m, double n) { int i; @@ -48,11 +47,11 @@ double pwilcox(double x, double m, double n) { return ML_NAN; } if (m >= WILCOX_MMAX) { - warning("m should be less than %d\n", WILCOX_MMAX); + MATHLIB_WARNING("m should be less than %d\n", WILCOX_MMAX); return ML_NAN; } if (n >= WILCOX_NMAX) { - warning("n should be less than %d\n", WILCOX_NMAX); + MATHLIB_WARNING("n should be less than %d\n", WILCOX_NMAX); return ML_NAN; } x = floor(x + 0.5); diff --git a/src/nmath/qsignrank.c b/src/nmath/qsignrank.c index d258cf7e03b..599fd0b1e4d 100644 --- a/src/nmath/qsignrank.c +++ b/src/nmath/qsignrank.c @@ -27,7 +27,6 @@ */ #include "Mathlib.h" -#include "Error.h" double qsignrank(double x, double n) { @@ -47,7 +46,7 @@ double qsignrank(double x, double n) ML_ERROR(ME_DOMAIN); return ML_NAN; } else if (n >= SIGNRANK_NMAX) { - warning("n should be less than %d\n", SIGNRANK_NMAX); + MATHLIB_WARNING("n should be less than %d\n", SIGNRANK_NMAX); return ML_NAN; } diff --git a/src/nmath/qwilcox.c b/src/nmath/qwilcox.c index 33c4a6bb188..09dac79e0f8 100644 --- a/src/nmath/qwilcox.c +++ b/src/nmath/qwilcox.c @@ -27,7 +27,6 @@ */ #include "Mathlib.h" -#include "Error.h" double qwilcox(double x, double m, double n) { @@ -48,10 +47,10 @@ double qwilcox(double x, double m, double n) ML_ERROR(ME_DOMAIN); return ML_NAN; } else if (m >= WILCOX_MMAX) { - warning("m should be less than %d\n", WILCOX_MMAX); + MATHLIB_WARNING("m should be less than %d\n", WILCOX_MMAX); return ML_NAN; } else if (n >= WILCOX_NMAX) { - warning("n should be less than %d\n", WILCOX_NMAX); + MATHLIB_WARNING("n should be less than %d\n", WILCOX_NMAX); return ML_NAN; } diff --git a/src/nmath/rhyper.c b/src/nmath/rhyper.c index 08dd95b69df..7a6245ca9a0 100644 --- a/src/nmath/rhyper.c +++ b/src/nmath/rhyper.c @@ -35,7 +35,6 @@ * Journal of Statistical Computation and Simulation 22, 127-145. */ -#include "PrtUtil.h" #include "Mathlib.h" /* afc(i) := ln( i! ) [logarithm of the factorial i. @@ -60,7 +59,7 @@ static double afc(int i) { double di, value; if (i < 0) { - REprintf("rhyper.c: afc(i), i=%d < 0 -- SHOULD NOT HAPPEN!\n",i); + MATHLIB_WARNING("rhyper.c: afc(i), i=%d < 0 -- SHOULD NOT HAPPEN!\n",i); return -1;/* unreached (Wall) */ } else if (i <= 7) { value = al[i + 1]; diff --git a/src/nmath/sunif.c b/src/nmath/sunif.c index 4cc0e944928..d1ed21d20cb 100644 --- a/src/nmath/sunif.c +++ b/src/nmath/sunif.c @@ -33,25 +33,185 @@ * Applied Statistics, 31, 188. */ -#include "Mathlib.h" +#include "Mathlib.h"/*-> ../include/Random.h */ +#include /* for Randomize() */ -#define WICHMANN_HILL +/* ---------------- + * New Scheme: Allow CHOICE of Random Number Generator [RNG] + * + * For R, the setup here must be compatible with + * GetSeeds(), SetSeeds(), SetRNG() from ../main/random.c + * + */ + +Int32 dummy[3]; + +RNGTAB RNG_Table[] = +{ +/* kind name is_seeded seed-length i1_s, *seed-vec */ + { 0, "Wichmann-Hill", 0, 3, 123, dummy}, + { 1, "Marsaglia-MultiCarry",0, 2, 123, dummy}, + { 2, "Super-Duper", 0, 2, 123, dummy}, + { 3, "Mersenne-Twister", 0, 1+624, 123, dummy}, + { 4, "Rand", 0, 2, -1, dummy}, +}; + +RNGtype RNG_kind = WICHMANN_HILL; + +/* SEED vector: Assume 32 __or more__ bits + + * The first few are `unrolled' for speed + * Here, use maximal seed length from above; + * + */ + +/*unsigned long int i1_seed, i2_seed, i_seed[1+624 - 2]; + */ + +#define d2_32 4294967296./* = (double) */ +#define i2_32m1 2.328306437080797e-10/* = 1/(2^32 - 1) */ -#ifdef WICHMANN_HILL +/* do32bits(): Zero bits higher than 32 + * ---------- + * & 037.. really does nothing when long=32bits, + * however does every compiler optimize this? -- optimize ourselves! + */ +#ifdef LONG_32_BITS +# define do32bits(N) (N) +#else +# define do32bits(N) ((N) & 037777777777) +#endif -int ix_seed = 123; -int iy_seed = 1234; -int iz_seed = 12345; +#define I1 RNG_Table[RNG_kind].i1_seed +#define I2 RNG_Table[RNG_kind].i2_seed +#define I3 RNG_Table[RNG_kind].i3_seed +#define ISd RNG_Table[RNG_kind].i_seed double sunif(void) { - double value; + double value; + + switch(RNG_kind) { + + case WICHMANN_HILL: + I1 = I1 * 171 % 30269; + I2 = I2 * 172 % 30307; + I3 = I3 * 170 % 30323; + value = + I1 / 30269.0 + + I2 / 30307.0 + + I3 / 30323.0; + return value - (int) value;/* in [0,1) */ + + case MARSAGLIA_MULTICARRY:/* 0177777(octal) == 65535(decimal)*/ + /* The following also works when 'usigned long' is > 32 bits : */ + I1= 36969*(I1 & 0177777) + (I1>>16); + I2= 18000*(I2 & 0177777) + (I2>>16); + return (do32bits(I1 << 16)^(I2 & 0177777)) + * i2_32m1;/* in [0,1) */ + + case SUPER_DUPER: + + /* This is Reeds et al (1984) implementation; + * modified using __unsigned__ seeds instead of signed ones + */ + I1 ^= ((I1 >> 15) & 0377777);/* Tausworthe */ + I1 ^= do32bits(I1 << 17); +#ifdef LONG_32_BITS + I2 *= 69069; /* Congruential */ +#else + I2 = do32bits(69069 * I2); +#endif + return (I1^I2) * i2_32m1;/* in [0,1) */ + + case RAND: + /* Use ANSI C_INTERNAL (with which you can only SET a seed, + but not get the current)*/ + + return rand()/(.1 + RAND_MAX);/* in [0,1) */ - ix_seed = ix_seed * 171 % 30269; - iy_seed = iy_seed * 172 % 30307; - iz_seed = iz_seed * 170 % 30323; - value = ix_seed / 30269.0 + iy_seed / 30307.0 + iz_seed / 30323.0; - return value - (int) value; + case MERSENNE_TWISTER: + + return 0.5;/*PLACE HOLDER*/ + + default:/* can never happen (enum type)*/ return -1.; + } +} + +/*--- This are called from ../main/random.c : ---------*/ + +void FixupSeeds(RNGtype kind) +{ +/* Depending on RNG, set 0 values to non-0, etc. */ + + int j; + RNGtype tkind; + + /* Set 0 to 1 : */ + if(!RNG_Table[kind].i1_seed) RNG_Table[kind].i1_seed++; + for(j=0; j <= RNG_Table[kind].n_seed - 2; j++) + if(!RNG_Table[kind].i_seed[j]) RNG_Table[kind].i_seed[j]++; + + switch(kind) { + case WICHMANN_HILL: + if(RNG_Table[kind].i1_seed >= 30269 || + RNG_Table[kind].i2_seed >= 30307 || + RNG_Table[kind].i3_seed >= 30323 ) {/*.Random.seed was screwed up */ + /* do 1 iteration */ + tkind = RNG_kind; RNG_kind = WICHMANN_HILL; + sunif(); + RNG_kind = tkind; + } + return; + case MARSAGLIA_MULTICARRY: + return; + case SUPER_DUPER: + /* I2 = Congruential: must be ODD */ + RNG_Table[kind].i2_seed |= 1; + break; + + case RAND:/* no read-access to seed */ + + case MERSENNE_TWISTER: + + break; + } } +void MaybeAllocSeeds(RNGtype kind) +{ + if(! RNG_Table[kind].is_seeded) { /* allocate ! */ +#ifdef DEBUG + MATHLIB_WARNING2("Allocating seed (length %d) for RNG kind '%d'\n", + RNG_Table[kind].n_seed - 1, kind); #endif + RNG_Table[kind].i_seed = (Int32 *) + calloc((size_t)RNG_Table[kind].n_seed - 1, + sizeof(Int32)); + RNG_Table[kind].is_seeded = 1; + } +} + +void RNG_Init(RNGtype kind, long seed) +{ + int j; + + RNG_Table[kind].i1_seed = seed; + for(j=0; j < RNG_Table[RNG_kind].n_seed - 1; j++) { + seed = (69069 * seed) & 0xffffffff; + RNG_Table[kind].i_seed[j] = seed; + } + FixupSeeds(kind); +} + +void Randomize(RNGtype kind) +{ +/* Only called by GetRNGstate(), when there's no .Random.seed */ + + MaybeAllocSeeds(kind); + + srand((int)time(NULL)); + + RNG_Init(kind, (long) rand() | 01/* odd */); +} + diff --git a/src/scripts/COMPILE.in b/src/scripts/COMPILE.in index 31638ae8c2e..a9ce745bda4 100644 --- a/src/scripts/COMPILE.in +++ b/src/scripts/COMPILE.in @@ -7,11 +7,18 @@ MAKE=${MAKE-@MAKE@} MAKEOPTS= -for i in $*; do +if test -r Makefile; then + MAKEFILES="-f ${RHOME}/etc/Makeconf -f Makefile" +else + MAKEFILES="-f ${RHOME}/etc/Makeconf" +fi + +OBJS= + +for i in ${*}; do case ${i} in - *.[cfr]) - obj=`echo $i|sed 's/\.[^\.][^\.]*$/.o/'` - ${MAKE} -f ${RHOME}/etc/Makeconf ${MAKEOPTS} ${obj} + *.[cf]) + OBJS="${OBJS} `echo ${i} | sed 's/\.[^\.][^\.]*$/.o/'`" ;; -D*|*=*) MAKEOPTS="${MAKEOPTS} ${i}" @@ -23,6 +30,8 @@ for i in $*; do esac done +${MAKE} ${MAKEFILES} ${MAKEOPTS} ${OBJS} + ### Local Variables: *** ### mode: sh *** ### sh-indent: 2 *** diff --git a/src/scripts/INSTALL.in b/src/scripts/INSTALL.in index 51fe0342af0..0425007e5ea 100644 --- a/src/scripts/INSTALL.in +++ b/src/scripts/INSTALL.in @@ -6,7 +6,7 @@ # @configure_input@ -VERSION="0.1-1" +VERSION="0.1-3" USAGE_MSG="Usage: R INSTALL [options] [-l lib] pkg_1 ... pkg_n" DEBUG=false @@ -15,6 +15,7 @@ BUILD_HTML=true BUILD_LATEX=true BUILD_HELP=true BUILD_HELP_OPTS= +BUILD_EXAMPLE=true SHLIB_OPTS= INSTALL='@INSTALL@' @@ -45,13 +46,15 @@ while test -n "${1}"; do --debug) DEBUG=true; SHLIB_OPTS="${SHLIB_OPTS} --debug" ;; --no-docs) - BUILD_TEXT=false; BUILD_HTML=false; BUILD_LATEX=false ;; + BUILD_TEXT=false;BUILD_HTML=false;BUILD_LATEX=false;BUILD_EXAMPLE=false ;; --no-text) BUILD_TEXT=false ;; --no-html) BUILD_HTML=false ;; --no-latex) BUILD_LATEX=false ;; + --no-example) + BUILD_EXAMPLE=false ;; -l) lib=${2}; shift ;; *) @@ -86,6 +89,9 @@ fi if ${BUILD_LATEX}; then BUILD_HELP_OPTS="${BUILD_HELP_OPTS} --latex" fi +if ${BUILD_EXAMPLE}; then + BUILD_HELP_OPTS="${BUILD_HELP_OPTS} --example" +fi if test -z "${BUILD_HELP_OPTS}"; then BUILD_HELP=false elif ${DEBUG}; then @@ -106,11 +112,11 @@ for pkg in ${PKGS}; do if test -f src/Makefile; then (cd src; ${MAKE} -f ${RHOME}/etc/Makeconf -f Makefile \ - && cp *.so ${lib}/${pkg}/libs) + && cp *.@SHLIBEXT@ ${lib}/${pkg}/libs) else (cd src; sh ${RHOME}/bin/SHLIB ${SHLIB_OPTS} \ - -o ${lib}/${pkg}/libs/${pkg}.so *.[cf]) + -o ${lib}/${pkg}/libs/${pkg}.@SHLIBEXT@ *.[cf]) fi || { echo "ERROR: Compilation failed for package \`${pkg}'" exit 4 diff --git a/src/scripts/Rd2dvi b/src/scripts/Rd2dvi index c6fcf149964..a7c56d01790 100755 --- a/src/scripts/Rd2dvi +++ b/src/scripts/Rd2dvi @@ -12,27 +12,29 @@ D2L="${Pwd}/Rdconv -t latex" # call_dir=`pwd` -if [ -f Rd0.tex ] +if [ -f Rd2.tex ] then - echo "'Rd0.tex' already exists -- renaming it to Rd0.tex.Older" + echo "'Rd2.tex' already exists -- renaming it to Rd2.tex.Older" echo " -------- " - mv Rd0.tex Rd0.tex.Older + mv Rd2.tex Rd2.tex.Older fi -$D2L $@ > Rd0.tex +$D2L $@ > Rd2.tex echo "MANTEXDIR= '$MANTEXDIR'" -if [ ! -f Man0.tex ]; then ln -s ${MANTEXDIR}/Man0.tex . ; fi +if [ ! -f Rd2dvi.tex ]; then ln -s ${MANTEXDIR}/Rd2dvi.tex . ; fi if [ ! -f Rd.sty ]; then - sed 's/markright{#1}/markboth{#1}{#1}/' ${MANTEXDIR}/Rd.sty > Rd0.sty + sed 's/markright{#1}/markboth{#1}{#1}/' ${MANTEXDIR}/Rd.sty > Rd2.sty fi #exit #--------------------- -latex Man0 -makeindex Man0 -latex Man0 +latex Rd2dvi +if [ -x `/usr/bin/which makeindex` ] +then makeindex Rd2dvi + latex Rd2dvi +fi if [ -x `/usr/bin/which xdvi` ] -then xdvi Man0 & +then xdvi Rd2dvi & fi echo '' echo 'Rd2dvi: You may want to clean up by' -echo ' rm Man0.* Rd0.sty Rd0.tex' +echo ' rm -f Rd2dvi.* Rd2.sty Rd2.tex*' echo '' diff --git a/src/scripts/Rdconv.in b/src/scripts/Rdconv.in index 8a67ce279fb..6728afcfa7e 100644 --- a/src/scripts/Rdconv.in +++ b/src/scripts/Rdconv.in @@ -64,12 +64,11 @@ else { + sub usage { print "Rdconv\n"; print "Usage: Rdconv [--debug/-d] [--help/-h]"; - print " [--type/-t html|nroff|Sd|latex|examp] file\n\n"; - + print " [--type/-t html|nroff|Sd|latex|example] file\n\n"; exit 0; } - diff --git a/src/scripts/SHLIB.in b/src/scripts/SHLIB.in index 59091e3d961..f41828fbd55 100644 --- a/src/scripts/SHLIB.in +++ b/src/scripts/SHLIB.in @@ -4,15 +4,18 @@ # @configure_input@ -VERSION="0.1-1" +VERSION="0.1-2" USAGE_MSG="Usage: R SHLIB [-o lib] obj_1 ... obj_n" +lib= OBJS= DEBUG=false MAKE=${MAKE-@MAKE@} while test -n "${1}"; do - # if ${DEBUG}; then echo "$0 -- DEBUG: arg = '${1}'"; fi + if ${DEBUG}; then + echo "$0 -- DEBUG: arg = \`${1}'"; + fi case ${1} in -h|--help|-\?) echo "${USAGE_MSG}"; exit 0 ;; @@ -22,25 +25,17 @@ while test -n "${1}"; do DEBUG=true ;; -o) lib=${2}; shift ;; - *) - if [ x$lib = x ]; then - lib=`echo ${1}|sed 's/\.[^\.][^\.]*$/.@SHLIBEXT@/'` - else - OBJS="${OBJS} `echo ${1}|sed 's/\.[^\.][^\.]*$/.o/'`" + *.?) + if test -z "${lib}"; then + lib="`echo ${1} | sed 's/\.[^\.][^\.]*$/.@SHLIBEXT@/'`" fi + OBJS="${OBJS} `echo ${1} | sed 's/\.[^\.][^\.]*$/.o/'`" ;; esac shift done -${MAKE} -f ${RHOME}/etc/Makeconf ${OBJS} - -if ${DEBUG}; then - echo "$0 -- DEBUG: Before Linking '${lib}'.." - set -x -fi - -@SHLIBLD@ @SHLIBLDFLAGS@ -o ${lib} ${OBJS} @FLIBS@ +${MAKE} -f ${RHOME}/etc/Makeconf SHLIB="${lib}" OBJS="${OBJS}" ### Local Variables: *** ### mode: sh *** diff --git a/src/scripts/build-help.in b/src/scripts/build-help.in index e7299714e32..ba6ca179b9d 100644 --- a/src/scripts/build-help.in +++ b/src/scripts/build-help.in @@ -111,12 +111,13 @@ foreach $manfile (@mandir) { $textflag = $htmlflag = $latexflag = $exampleflag = ""; if($opt_nroff){ - $destfile = "$dest/help/$manfilebase"; + my $targetfile = $anindex{$manfilebase}; + $destfile = "$dest/help/$targetfile"; if(fileolder($destfile, $manage)) { $textflag = "text"; open(nroffout, "| tbl | nroff -ms 2> /dev/null | " . " ${RHOME}/bin/help.pretty > '$destfile'"); - Rdconv($manfile, "nroff", "", -1);# maybe $opt_debug + Rdconv($manfile, "nroff", "", -1); } } @@ -126,22 +127,24 @@ foreach $manfile (@mandir) { if(fileolder($destfile,$manage)) { $htmlflag = "html"; print "\t$destfile" if $opt_debug; - Rdconv($manfile, "html", "", "$destfile");# "": maybe $opt_debug + Rdconv($manfile, "html", "", "$destfile"); } } if($opt_latex){ - $destfile = "$latex_d/$manfilebase.tex"; + my $targetfile = $anindex{$manfilebase}; + $destfile = "$dest/latex/$targetfile.tex"; if(fileolder($destfile,$manage)) { $latexflag = "latex"; - Rdconv($manfile, "latex", "", "$destfile");# maybe $opt_debug + Rdconv($manfile, "latex", "", "$destfile"); } } if($opt_example){ - $destfile = "$Rex_d/$manfilebase.R"; + my $targetfile = $anindex{$manfilebase}; + $destfile = "$dest/R-ex/$targetfile.R"; if(fileolder($destfile,$manage)) { $exampleflag = "example"; - Rdconv($manfile, "example", "", "$destfile");# maybe $opt_debug + Rdconv($manfile, "example", "", "$destfile"); } } diff --git a/src/scripts/check b/src/scripts/check index 24980e0748b..d21109782a0 100755 --- a/src/scripts/check +++ b/src/scripts/check @@ -1,13 +1,11 @@ #!/bin/sh -# ${RHOME}/bin/INSTALL for checking installed add-on packages -# Usage: -# R CMD check [options] [-l lib] pkg_1 ... pkg_n - +# ${RHOME}/bin/check for checking installed add-on packages +USAGE_MSG="Usage: R CMD check [options] [-l lib] pkg_1 ... pkg_n" VERSION="0.1-0" -USAGE_MSG="Usage: R CMD check [-l lib] pkg_1 ... pkg_n" OPTS= PKGS= +DEBUG=false lib=${RHOME}/library while test -n "${1}"; do @@ -20,11 +18,12 @@ while test -n "${1}"; do DEBUG=true; OPTS="${OPTS} --debug" ;; -l) lib=${2}; shift ;; - *) + *) PKGS="${PKGS} ${1}" ;; esac shift done +if ${DEBUG}; then set -x; fi if test -z "${PKGS}"; then echo "${USAGE_MSG}" @@ -39,7 +38,12 @@ else fi for pkg in ${PKGS}; do - cd ${pkg} + if test -d $pkg; then + cd ${pkg} + else + echo "WARNING: No subdirectory ${pkg} in "`pwd`' ... skipping' + break + fi pkg=`basename ${pkg}` echo "Checking package \`${pkg}' ..." @@ -69,4 +73,4 @@ for pkg in ${PKGS}; do echo " ERROR" fi -done +done diff --git a/src/scripts/massage-Examples b/src/scripts/massage-Examples index a939e949e55..d686bad337f 100755 --- a/src/scripts/massage-Examples +++ b/src/scripts/massage-Examples @@ -37,7 +37,7 @@ do bf=`basename $file .R` if [ -n "`grep '_ Examples _' $file`" ] then - echo '.Random.seed <- rep(7654,3); rm(list = ls())' + echo '.Random.seed <- c(0,rep(7654,3)); rm(list = ls())' else if [ "$USER" = maechler ];then ## Remind certain people to upgrade the online help diff --git a/src/unix/dataentry.c b/src/unix/dataentry.c index 31cdff1f0d1..14e6516b066 100644 --- a/src/unix/dataentry.c +++ b/src/unix/dataentry.c @@ -84,11 +84,12 @@ SEXP do_dataentry(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP tvec2, tvec, colmodes, indata; SEXPTYPE type; - int i, j,len, nprotect = 0; + int i, j,len, nprotect; RCNTXT cntxt; - PROTECT(indata = CAR(args)); nprotect++; - PROTECT(colmodes = CADR(args)); nprotect++; + nprotect = 0;/* count the PROTECT()s */ + PROTECT(indata = VectorToPairList(CAR(args))); nprotect++; + PROTECT(colmodes = VectorToPairList(CADR(args))); nprotect++; if (!isList(indata) || !isList(colmodes)) errorcall(call, "invalid argument\n"); @@ -118,8 +119,6 @@ SEXP do_dataentry(SEXP call, SEXP op, SEXP args, SEXP rho) hwidth = 30; #endif - - /* setup inputlist */ if (indata != R_NilValue) { @@ -213,7 +212,7 @@ SEXP do_dataentry(SEXP call, SEXP op, SEXP args, SEXP rho) } UNPROTECT(nprotect); - return inputlist; + return PairToVectorList(inputlist); } /* Event Loop Functions */ diff --git a/src/unix/dynload.c b/src/unix/dynload.c index 15795c3e5f7..c81c77f0b75 100644 --- a/src/unix/dynload.c +++ b/src/unix/dynload.c @@ -67,8 +67,8 @@ typedef int (*DL_FUNC)(); typedef struct { - char *name; - DL_FUNC func; + char *name; + DL_FUNC func; } CFunTabEntry; #include "FFDecl.h" @@ -80,7 +80,7 @@ typedef struct { static CFunTabEntry CFunTab[] = { #include "FFTab.h" - {NULL, NULL} + {NULL, NULL} }; /* The following code loads in a compatibility module written by Luke @@ -108,7 +108,7 @@ static void *dlhandle; void InitFunctionHashing() { #ifdef DL_SEARCH_PROG - dlhandle = dlopen(0, RTLD_LAZY); + dlhandle = dlopen(0, RTLD_LAZY); #endif } @@ -118,8 +118,8 @@ void InitFunctionHashing() static int CountDLL = 0; static struct { - char *path; - void *handle; + char *path; + void *handle; } LoadedDLL[MAX_NUM_DLLS]; @@ -129,23 +129,23 @@ LoadedDLL[MAX_NUM_DLLS]; static int DeleteDLL(char *path) { - int i, loc; - for(i=0 ; i0 ; i--) { - LoadedDLL[i].path = LoadedDLL[i-1].path; - LoadedDLL[i].handle = LoadedDLL[i-1].handle; - } - LoadedDLL[0].path = dpath; - LoadedDLL[0].handle = handle; - CountDLL++; - return 1; + void *handle; + char *dpath; + int i; + if(CountDLL == MAX_NUM_DLLS) + return 0; + handle = dlopen(path, RTLD_LAZY); + if(handle == NULL) + return 0; + dpath = malloc(strlen(path)+1); + if(dpath == NULL) { + dlclose(handle); + return 0; + } + strcpy(dpath, path); + for(i=CountDLL ; i>0 ; i--) { + LoadedDLL[i].path = LoadedDLL[i-1].path; + LoadedDLL[i].handle = LoadedDLL[i-1].handle; + } + LoadedDLL[0].path = dpath; + LoadedDLL[0].handle = handle; + CountDLL++; + return 1; } - /* R_FindSymbol checks whether one of the libraries */ /* that have been loaded contains the symbol name and */ /* returns a pointer to that symbol upon success. */ @@ -188,14 +187,14 @@ static int AddDLL(char *path) DL_FUNC R_FindSymbol(char const *name) { - char buf[MAXIDSIZE+1]; - DL_FUNC fcnptr; - int i; - + char buf[MAXIDSIZE+1]; + DL_FUNC fcnptr; + int i; + #ifdef HAVE_NO_SYMBOL_UNDERSCORE - sprintf(buf, "%s", name); + sprintf(buf, "%s", name); #else - sprintf(buf, "_%s", name); + sprintf(buf, "_%s", name); #endif /* The following is not legal ANSI C. */ @@ -204,24 +203,26 @@ DL_FUNC R_FindSymbol(char const *name) /* function pointers _are_ the same size and _can_ */ /* be cast without loss of information. */ - for (i=0 ; i $@ %-Ex.R: $(top_builddir)/library/%/R-ex/*.R @if [ -f $@.bak ]; then mv $@.bak $@.bakk ; fi @if [ -f $@ ]; then mv $@ $@.bak ; fi @echo "Massaging examples into $@ ..." - -@$(top_builddir)/bin/massage-Examples $* \ + @$(top_builddir)/bin/massage-Examples $* \ $(top_builddir)/library/$*/R-ex/*.R > $@ -$(top_builddir)/stamp-R: - -(cd $(top_builddir) && $(MAKE) R) +../stamp-R: + (cd .. && $(MAKE) stamp-R) $(top_builddir)/src/library/stamp-help: (cd $(top_builddir)/src/library \ && $(MAKE) PKGS="$(Pkgs)" stamp-help) diff --git a/tests/Makefile.in b/tests/Makefile.in index 4f5cbee51b6..f110c96eb1d 100644 --- a/tests/Makefile.in +++ b/tests/Makefile.in @@ -18,7 +18,7 @@ SUBDIRS = Examples ## FIXME RHOME= .. -R = $(RHOME)/bin/R --vanilla +R = LC_ALL=C $(RHOME)/bin/R --vanilla Ex = ./Examples @@ -27,7 +27,7 @@ TESTsrc = simple-true.R simple-tests.R d-p-q-r-tests.R \ TESTout = $(TESTsrc:.R=.Rout) -%.Rout: %.R $(top_builddir)/stamp-R +%.Rout: %.R stamp-R @(SRCDIR=$(srcdir); export SRCDIR; \ echo "$(R) < $< > $@"; \ $(R) < $< > $@) @@ -36,14 +36,16 @@ TESTout = $(TESTsrc:.R=.Rout) test-All: test-Examples $(TESTout) test-Examples: - -(cd $(Ex); $(MAKE) $@) + @cd $(Ex) && $(MAKE) $@ -$(top_builddir)/stamp-R: - -(cd $(top_builddir) && $(MAKE) R) +stamp-R:: $(top_builddir)/bin/R.binary $(top_builddir)/library/base/R/base + @cd $(top_builddir) && $(MAKE) R + @touch $@ mostlyclean: clean clean: -(cd $(Ex); $(MAKE) $@) + rm -f stamp-R distclean: clean @rm -f $(TESTout) -(cd $(Ex); $(MAKE) $@) diff --git a/tests/Rdiff b/tests/Rdiff index 12dd91c69de..6d370d6720e 100755 --- a/tests/Rdiff +++ b/tests/Rdiff @@ -4,7 +4,7 @@ f1=$1 f2=$2 #$perlne="'print if /^Version|^Number of.*:/'" #perl -ne "$perlne" $f1 .... -egrepv='(^Version|^Number of.*:' +egrepv='(^Version|^Number of.*:|^Type' if test -n "`grep primitive-funs $f1`" then egrepv=$egrepv'|^\[1\] [19][0-9][0-9])' else egrepv=$egrepv')' diff --git a/tests/d-p-q-r-tests.R b/tests/d-p-q-r-tests.R index 0a1f2174021..5b13883b5af 100644 --- a/tests/d-p-q-r-tests.R +++ b/tests/d-p-q-r-tests.R @@ -7,7 +7,7 @@ source(paste(getenv("SRCDIR"),"all.equal.R", sep="/")) -if(!interactive()) .Random.seed <- rep(7654, 3) +if(!interactive()) .Random.seed <- c(0,rep(7654, 3)) ##--- Cumulative Poisson '==' Cumulative Chi^2 : ##--- Abramowitz & Stegun, p.941 : 26.4.21 (26.4.2) @@ -28,12 +28,12 @@ for(n in rbinom(n1, size = 2*n0, p = .4)) { for(p in c(0,1,rbeta(n2, 2,4))) { cat(".") for(k in rbinom(n3, size = n, prob = runif(1))) { - ## For X ~ Bin(n,p), compute 1 - P[X > k] = P[X <= k] in two ways : + ## For X ~ Bin(n,p), compute 1 - P[X > k] = P[X <= k] in two ways: tst <- all.equal(if(k==n || p==0) 1 else - pf((k+1)/(n-k)*(1-p)/p, df1= 2*(n-k), df2 = 2*(k+1)), + pf((k+1)/(n-k)*(1-p)/p, df1=2*(n-k), df2=2*(k+1)), sum(dbinom(0:k, size = n, prob = p))) if(!(is.logical(tst) && tst)) - cat("n=", n,"; p =", format(p),". k =",k, " --> tst=", tst,"\n") + cat("n=", n,"; p =",format(p),". k =",k, " --> tst=",tst,"\n") } } cat("\n") diff --git a/tests/d-p-q-r-tests.Rout.save b/tests/d-p-q-r-tests.Rout.save index e76a4f43f24..4fdc8e790ea 100644 --- a/tests/d-p-q-r-tests.Rout.save +++ b/tests/d-p-q-r-tests.Rout.save @@ -1,6 +1,6 @@ R : Copyright 1998, The R Development Core Team -Version 0.63.0 Unstable (June 23, 1998) +Version 0.63.1 In progress (December 1, 1998) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. @@ -11,46 +11,47 @@ Type "?contributors" for a list. Type "demo()" for some demos, "help()" for on-line help, or "help.start()" for a HTML browser interface to help. +Type "q()" to quit R. > #### d|ensity -> #### p|robability (cumulative) +> #### p|robability (cumulative) > #### q|uantile -> #### r|andom number generation +> #### r|andom number generation > #### -> #### Functions for ``d/p/q/r'' +> #### Functions for ``d/p/q/r'' > > source(paste(getenv("SRCDIR"),"all.equal.R", sep="/")) > -> if(!interactive()) .Random.seed <- rep(7654, 3) +> if(!interactive()) .Random.seed <- c(0,rep(7654, 3)) > > ##--- Cumulative Poisson '==' Cumulative Chi^2 : > ##--- Abramowitz & Stegun, p.941 : 26.4.21 (26.4.2) > n1 <- 20; n2 <- 16 > for(lambda in rexp(n1)) -+ for(k in rpois(n2, lambda)) { -+ tst <- all.equal(1 - pchisq(2*lambda, 2*(k+1)), -+ sum(dpois(0:k, lambda=lambda))) -+ if(!(is.logical(tst) && tst)) -+ cat("lambda=", format(lambda),". k =",k, " --> tst=", tst,"\n") -+ } ++ for(k in rpois(n2, lambda)) { ++ tst <- all.equal(1 - pchisq(2*lambda, 2*(k+1)), ++ sum(dpois(0:k, lambda=lambda))) ++ if(!(is.logical(tst) && tst)) ++ cat("lambda=", format(lambda),". k =",k, " --> tst=", tst,"\n") ++ } > > ##--- Cumulative Binomial '==' Cumulative F : > ##--- Abramowitz & Stegun, p.945-6; 26.5.24 AND 26.5.28 : > n0 <- 50; n1 <- 16; n2 <- 20; n3 <- 8 > for(n in rbinom(n1, size = 2*n0, p = .4)) { -+ cat("n=",n,": ") -+ for(p in c(0,1,rbeta(n2, 2,4))) { -+ cat(".") -+ for(k in rbinom(n3, size = n, prob = runif(1))) { -+ ## For X ~ Bin(n,p), compute 1 - P[X > k] = P[X <= k] in two ways : -+ tst <- all.equal(if(k==n || p==0) 1 else -+ pf((k+1)/(n-k)*(1-p)/p, df1= 2*(n-k), df2 = 2*(k+1)), -+ sum(dbinom(0:k, size = n, prob = p))) -+ if(!(is.logical(tst) && tst)) -+ cat("n=", n,"; p =", format(p),". k =",k, " --> tst=", tst,"\n") ++ cat("n=",n,": ") ++ for(p in c(0,1,rbeta(n2, 2,4))) { ++ cat(".") ++ for(k in rbinom(n3, size = n, prob = runif(1))) { ++ ## For X ~ Bin(n,p), compute 1 - P[X > k] = P[X <= k] in two ways: ++ tst <- all.equal(if(k==n || p==0) 1 else ++ pf((k+1)/(n-k)*(1-p)/p, df1=2*(n-k), df2=2*(k+1)), ++ sum(dbinom(0:k, size = n, prob = p))) ++ if(!(is.logical(tst) && tst)) ++ cat("n=", n,"; p =",format(p),". k =",k, " --> tst=",tst,"\n") ++ } + } -+ } -+ cat("\n") ++ cat("\n") + } n= 46 : ...................... n= 42 : ...................... diff --git a/tests/simple-tests.R b/tests/simple-tests.R index 3f2c376fbea..6d5a18c33d8 100644 --- a/tests/simple-tests.R +++ b/tests/simple-tests.R @@ -19,7 +19,7 @@ abs(Im(asin(sin(1i))) - 1) < 2*Meps ##P (1 - Im(sin(asin(Ii))))/Meps ##P (1 - Im(cos(acos(Ii))))/Meps -.Random.seed <- c(629, 6137, 22167) # want reproducible output +.Random.seed <- c(0, 629, 6137, 22167) # want reproducible output Isi <- Im(sin(asin(1i + rnorm(100)))) all(abs(Isi-1) < 100* Meps) ##P table(2*abs(Isi-1) / Meps) diff --git a/tests/simple-tests.Rout.save b/tests/simple-tests.Rout.save index cb2f61bc6bd..d71a60c404b 100644 --- a/tests/simple-tests.Rout.save +++ b/tests/simple-tests.Rout.save @@ -41,7 +41,7 @@ Type "demo()" for some demos, "help()" for on-line help, or > ##P (1 - Im(sin(asin(Ii))))/Meps > ##P (1 - Im(cos(acos(Ii))))/Meps > -> .Random.seed <- c(629, 6137, 22167) # want reproducible output +> .Random.seed <- c(0, 629, 6137, 22167) # want reproducible output > Isi <- Im(sin(asin(1i + rnorm(100)))) > all(abs(Isi-1) < 100* Meps) [1] TRUE diff --git a/tests/simple-true.R b/tests/simple-true.R index ba69973db0e..d0cdd8b84c8 100644 --- a/tests/simple-true.R +++ b/tests/simple-true.R @@ -1,4 +1,3 @@ -##-*- R -*- ##-- These should all return 'TRUE' all(1:12 == cumsum(rep(1,12))) diff --git a/tests/simple-true.Rout.save b/tests/simple-true.Rout.save index 84c7dcc49d3..27662e80622 100644 --- a/tests/simple-true.Rout.save +++ b/tests/simple-true.Rout.save @@ -11,8 +11,8 @@ Type "?contributors" for a list. Type "demo()" for some demos, "help()" for on-line help, or "help.start()" for a HTML browser interface to help. +Type "q()" to quit R. -> ##-*- R -*- > ##-- These should all return 'TRUE' > > all(1:12 == cumsum(rep(1,12)))