[r-cran-geepack] 01/17: Imported Upstream version 1.2-0
Andreas Tille
tille at debian.org
Fri Dec 16 15:38:39 UTC 2016
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-geepack.
commit 805aa674f5b7a516d379204c38dd9b2238a41375
Author: Andreas Tille <tille at debian.org>
Date: Fri Dec 16 13:35:55 2016 +0100
Imported Upstream version 1.2-0
---
ChangeLog | 217 ++++++++++++++
DESCRIPTION | 15 +
MD5 | 84 ++++++
NAMESPACE | 20 ++
R/fixed2Zcor.R | 27 ++
R/geeglm-anova.R | 349 ++++++++++++++++++++++
R/geeglm.R | 544 +++++++++++++++++++++++++++++++++
R/geese.R | 233 +++++++++++++++
R/internal.R | 54 ++++
R/ordgee.R | 163 ++++++++++
R/rrr.R | 56 ++++
R/summary.R | 114 +++++++
R/zzz.R | 3 +
build/vignette.rds | Bin 0 -> 265 bytes
data/dietox.txt.gz | Bin 0 -> 8528 bytes
data/koch.txt.gz | Bin 0 -> 966 bytes
data/ohio.txt.gz | Bin 0 -> 4924 bytes
data/respdis.txt.gz | Bin 0 -> 429 bytes
data/respiratory.txt.gz | Bin 0 -> 1345 bytes
data/seizure.txt.gz | Bin 0 -> 467 bytes
data/sitka89.txt.gz | Bin 0 -> 2545 bytes
data/spruce.txt.gz | Bin 0 -> 4639 bytes
inst/CITATION | 44 +++
inst/doc/geepack-manual.R | 98 ++++++
inst/doc/geepack-manual.Rnw | 196 ++++++++++++
inst/doc/geepack-manual.pdf | Bin 0 -> 107634 bytes
inst/include/famstr.h | 141 +++++++++
inst/include/gee2.h | 82 +++++
inst/include/geese.h | 8 +
inst/include/geesubs.h | 251 ++++++++++++++++
inst/include/inter.h | 42 +++
inst/include/ordgee.h | 113 +++++++
inst/include/param.h | 108 +++++++
inst/include/tnt/cholesky.h | 96 ++++++
inst/include/tnt/cmat.h | 605 +++++++++++++++++++++++++++++++++++++
inst/include/tnt/fcscmat.h | 165 +++++++++++
inst/include/tnt/fmat.h | 577 +++++++++++++++++++++++++++++++++++
inst/include/tnt/fortran.h | 67 +++++
inst/include/tnt/fspvec.h | 168 +++++++++++
inst/include/tnt/index.h | 83 ++++++
inst/include/tnt/lapack.h | 193 ++++++++++++
inst/include/tnt/lu.h | 204 +++++++++++++
inst/include/tnt/qr.h | 229 ++++++++++++++
inst/include/tnt/region1d.h | 371 +++++++++++++++++++++++
inst/include/tnt/region2d.h | 467 +++++++++++++++++++++++++++++
inst/include/tnt/stopwatch.h | 83 ++++++
inst/include/tnt/subscript.h | 58 ++++
inst/include/tnt/tnt.h | 90 ++++++
inst/include/tnt/tntmath.h | 85 ++++++
inst/include/tnt/tntreqs.h | 70 +++++
inst/include/tnt/transv.h | 160 ++++++++++
inst/include/tnt/triang.h | 638 +++++++++++++++++++++++++++++++++++++++
inst/include/tnt/trisolve.h | 184 ++++++++++++
inst/include/tnt/vec.h | 403 +++++++++++++++++++++++++
inst/include/tnt/vecadaptor.h | 289 ++++++++++++++++++
inst/include/tnt/version.h | 20 ++
inst/include/tntsupp.h | 556 ++++++++++++++++++++++++++++++++++
inst/include/utils.h | 64 ++++
man/DATA-dietox.Rd | 44 +++
man/DATA-koch.Rd | 33 +++
man/DATA-ohio.Rd | 34 +++
man/DATA-respdis.Rd | 44 +++
man/DATA-respiratory.Rd | 40 +++
man/DATA-seizure.Rd | 77 +++++
man/DATA-sitka89.Rd | 35 +++
man/DATA-spruce.Rd | 45 +++
man/SHDgeese-internal.Rd | 24 ++
man/compCoef.Rd | 71 +++++
man/fixed2Zcor.Rd | 82 +++++
man/geeglm.Rd | 109 +++++++
man/geese-internal.Rd | 17 ++
man/geese.Rd | 254 ++++++++++++++++
man/geese.control.Rd | 41 +++
man/genZcor.Rd | 70 +++++
man/ordgee.Rd | 117 ++++++++
man/relRisk.Rd | 83 ++++++
src/Makevars | 1 +
src/famstr.cc | 390 ++++++++++++++++++++++++
src/gee2.cc | 506 +++++++++++++++++++++++++++++++
src/geesubs.cc | 550 ++++++++++++++++++++++++++++++++++
src/inter.cc | 178 +++++++++++
src/ordgee.cc | 676 ++++++++++++++++++++++++++++++++++++++++++
src/param.cc | 64 ++++
src/utils.cc | 215 ++++++++++++++
vignettes/geepack-manual.Rnw | 196 ++++++++++++
85 files changed, 12883 insertions(+)
diff --git a/ChangeLog b/ChangeLog
new file mode 100755
index 0000000..3e7da90
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,217 @@
+2014-09-13 Søren Højsgaard <sorenh at math.aau.dk>
+
+ * Maintainer of geepack is now Søren Højsgaard
+
+ * Location of vignette fixed
+
+ * Version 1.2-0 uploaded
+
+2012-01-27 Jun Yan <jun.yan at uconn.edu>
+
+ * Commented out #undef NDEBUG in geesubs.cc.
+ * Added a VecPrint function in utils.cc to print DVector;
+ this replaces usage of cerr.
+
+2012-01-09 Jun Yan <jun.yan at uconn.edu>
+
+ * Thank Jeffrey Horner <jeffrey.horner at vanderbilt.edu>
+ and Cole Beck <cole.beck at vanderbilt.edu> for fixing the
+ undefined symbol error (see 2011-11-14 entry:
+ _Z5ValidIiEN3TNT6VectorIT_EERS3_RNS1_IiEE).
+ The template function "Valid" (in original geesubs.cc)
+ should actually be in the header file.
+ This may fix the compilation error on ubuntu 11.10 too.
+
+2011-11-21 Jun Yan <jun.yan at uconn.edu>
+
+ * Added an example to function relRisk.
+
+2011-11-21 Jun Yan <jun.yan at uconn.edu>
+
+ * Added an example to function compCoef.
+
+ * Changed the JSS paper year from 2005 to 2006 in CITATION.
+
+2011-11-16 Jun Yan <jun.yan at uconn.edu>
+
+ * Added function relRisk for relative risk regression
+ --- regression for binary response with log link.
+
+ * Added function relRisk for relative risk regression
+ --- regression for binary response with log link.
+
+ * Added function compCoef for comparing coefficients
+ of the same sets of covariates between nested models.
+ This implements the method of Yan, Aseltine, and Harel
+ (2011, JEBS); for independent data, the method reduces
+ to Allison (1995, American Journal of Sociology).
+
+ * Fixed a bug in c++ code in constructing the working
+ covariance structure using the regression model of scale.
+ Simulation tests show improved efficiency in mean parameter
+ estimation when scale regression is present.
+
+2011-11-15 Soren Hojsgaard <sorenh at mail.dk>
+
+ * Dependence on the doBy package has been removed.
+
+2011-11-14 Jun Yan <jun.yan at uconn.edu>
+
+ * Added NAMESPACE for to comply with the requirement of R-2.14.0.
+
+ * Removed the "assert" lines in utils.cc in order not to crash R,
+ which is quite rude practice. A "-DNDEBUG" has been added to the
+ cppflags in Makevars for a better solution. Due to many asserts
+ in tnt, we cannot get rid of the NOTE message completely:
+ Found ‘_ZSt4cerr’, possibly from ‘std::cerr’ (C++)
+ Found ‘__assert_fail’, possibly from ‘assert’ (C)
+
+ * Added quote in statements like
+ extract(m, "response") to get rid of NOTE:
+ geese: no visible binding for global variable ‘response’
+
+ * Added a line of
+ #undef NDEBUG
+ to the beginning of geesubs.cc; thank Brian Ripley for the NMU.
+ Still unclear why the error without this line:
+ undefined symbol: _Z5ValidIiEN3TNT6VectorIT_EERS3_RNS1_IiEE
+
+
+2011-02-23 Søren Højsgaard <sorenh at agrsci.dk>
+
+ * In geeglm is checked if the model matrix is rank deficient; if
+ so then geeglm exits. Thanks to Jason D Thorpe for pointing this out.
+
+ * Bug in anova fixed. Thanks to Stefan Boehringer for pointing
+ this out.
+
+ * Version 1.0-18 uploaded.
+
+
+2010-01-26 Søren Højsgaard <sorenh at agrsci.dk>
+
+ * fixed2Zcor function has been added. This function makes it
+ easier to work with a fixed correlation matrix (in particular when
+ cluster sizes are not equal).
+
+ * A vignette on models with unequal cluster size, fixed
+ correlation matrices etc. has been added.
+
+ * Version 1.0-17 uploaded
+
+2008-12-08 Søren Højsgaard <sorenh at agrsci.dk>
+
+ * Bugfix in 1.0.15 caused problem in binomial case using
+ cbind(pos,neg). Thanks to Tobias Verbeke. Fixed now.
+
+ * Bugfix in 1.0.15 caused problem when using variables derived
+ from gam package call to geeglm. Thanks to Eric Rexstad. Fixed now.
+
+ * Using scale.fix argument gave problem in geeglm. Thanks to
+ Tobias Verbeke. Fixed now.
+
+ * Fitting large data set with binomial model and 3 measurements
+ per unit using unstructured correlation crashes R. Thanks to
+ Tobias Verbeke. Problem has *NOT* been solved but a remark has
+ been added to doc file.
+
+ * Version 1.0-16 uploaded
+
+2008-12-01 Søren Højsgaard <sorenh at agrsci.dk>
+
+ * When a factor has unused levels, the underlying C code
+ fails. This is now catured in geeglm. Thanks to Janet Young
+
+ * tests directory added to package
+
+ * Version 1.0-15 uploaded
+
+2007-07-13 Søren Højsgaard <sorenh at agrsci.dk>
+
+ * Smaller 'standardization' changes implemented. Thanks to Achim
+
+ * Version 1.0-14 uploaded
+
+2007-03-21 Søren Højsgaard <sorenh at agrsci.dk>
+
+ * A remark on fixed correlation structures has been added to the
+ geeglm.Rd doc file.
+
+ * A Wishlist file has been added
+
+ * Version 1.0-13 uploaded
+
+2007-03-21 Søren Højsgaard <sorenh at agrsci.dk>
+
+ * Bug in geeglm fixed so that it now works with a fixed
+ correlation structure. Thanks to Ulrich Halekoh for the fix.
+
+
+2006-02-13 Jun Yan <jyan at stat.uiowa.edu>
+
+ * Bug in genZcor and genZodds fixed.
+ Thanks to Chongzhi Di <cdi at jhsph.edu>.
+ Previously, the matrice generated by genZcor/genZodds are
+ wrong when the number of unique waves is greater than or
+ equal to 10.
+
+2006-01-24 Søren Højsgaard <sorenh at agrsci.dk>
+
+ * Bug in anova.geeglm fixed (showed up when there was only one
+ term on the right hand side of ~).
+
+ * geeglm only works on complete data. This has been pointed out in
+ the man pages. (At some point of time, a proper na.action should be
+ taken).
+
+ * All datasets are saved as .txt files (previously some were saved
+ as .rda files but that caused problems in building the package on
+ windows xp).
+
+2005-08-13 Jun Yan <jyan at stat.uiowa.edu>
+
+ * The working correlation structure can now be "fixed".
+
+
+2005-06-13 Søren Højsgaard <sorenh at agrsci.dk>
+
+ * Søren Højsgaard has modified the geeglm function so that it can
+ take the 'waves' argument which is used for explicitely specifying
+ the ordering of repeated measurements on the same unit. geeglm can
+ also take the 'zcor' argument for a user defined working
+ correlation structure.
+
+ * A documentation file for the genZcor
+ function has been added.
+
+ * All data sets provided are now saved as
+ text files.
+
+ * ordgee has been modified to check if the response variable is an
+ ordered factor.
+
+ * geeglm can now take the argument std.err which specifies the
+ type of variance estimate to be calculated.
+
+2005-05-11 Søren Højsgaard <sorenh at agrsci.dk>
+
+ * Søren Højsgaard has modified the anova function to make it
+ calculate the correct degrees of freedom.
+
+
+2005-04-11 Jun Yan <jyan at stat.uiowa.edu>
+
+ * Søren Højsgaard made some minor changes to geeglm -
+ basically, that geese.control did not work. Now it does.
+
+
+2005-02-09 Jun Yan <jyan at stat.uiowa.edu>
+
+ * Søren Højsgaard joined the development with geeglm, which
+ "works like" glm and returns an object which is similar to
+ a glm object. Residuals and predicted values can be extracted
+ using the generic functions as with a glm object.
+
+ * An important feature of geeglm, is that an anova method
+ exists for these models.
+
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100755
index 0000000..89b2148
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,15 @@
+Package: geepack
+Version: 1.2-0
+Title: Generalized Estimating Equation Package
+Author: S�ren H�jsgaard, <sorenh at math.aau.dk>, Ulrich Halekoh <Ulrich.Halekoh at agrsci.dk>, Jun Yan <jun.yan at uconn.edu>,
+Maintainer: S�ren H�jsgaard <sorenh at math.aau.dk>
+Description: Generalized estimating equations solver for parameters in
+ mean, scale, and correlation structures, through mean link,
+ scale link, and correlation link. Can also handle clustered
+ categorical responses.
+Encoding: latin1
+License: GPL (>= 3)
+Packaged: 2014-09-13 05:14:48 UTC; sorenh
+NeedsCompilation: yes
+Repository: CRAN
+Date/Publication: 2014-09-13 08:22:14
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..978b0f2
--- /dev/null
+++ b/MD5
@@ -0,0 +1,84 @@
+706152b8be6d8b2ca3a5ebdc9fcd8c1e *ChangeLog
+639690685bcc0878aaf422c56f09301b *DESCRIPTION
+419277c04635cf139654cefe064406fc *NAMESPACE
+96a6f5b5b46df0f9d3ac6bbc3327eada *R/fixed2Zcor.R
+59e982dac0a9e5004b8290399c2a5e6d *R/geeglm-anova.R
+e075605e7afd684200939ab63ae6be13 *R/geeglm.R
+b94677c4ba59797bb1c64a93764f6bb4 *R/geese.R
+a5e17a48d8e1196aa1967d5758168a0e *R/internal.R
+5d7cd7bfb2a2135f7364dda2382de8f1 *R/ordgee.R
+acf18753c22de2282b9a8357b7c06688 *R/rrr.R
+8abbb54ea36f442f6bd9e47e89f4818b *R/summary.R
+4b5e3c63a382021749596cb59f04c62d *R/zzz.R
+856de2c2b229d8ff55254176b0f52123 *build/vignette.rds
+8ef0a085392c2a6431f2f8713c60e5b5 *data/dietox.txt.gz
+249971f8780df82504f54fd2b7d62252 *data/koch.txt.gz
+c0e0807be2abed83152006db8dcbac5e *data/ohio.txt.gz
+135f7ab23560843a9c980976a27474f0 *data/respdis.txt.gz
+7462d979b12761e97e5bec4cfa5273a3 *data/respiratory.txt.gz
+d1e03752404477a70ed20c18d257e2d8 *data/seizure.txt.gz
+9cb003db408b585e3cb11806f35919a7 *data/sitka89.txt.gz
+73402330ab3f5a9b06fdf6343631e87d *data/spruce.txt.gz
+22d3dc7ffaa61d9124aa62db9bfe582f *inst/CITATION
+c01cea3c88238c320844d0d7649fc72f *inst/doc/geepack-manual.R
+3be52b7e7574dc6e40ca55938a8b3069 *inst/doc/geepack-manual.Rnw
+3a0bccf41d745a5d12f34922d6a87379 *inst/doc/geepack-manual.pdf
+eea5c9a7a285257434fb725257ff3b9d *inst/include/famstr.h
+aa8c2c4defc681b6cc57b2f9d8bdf03b *inst/include/gee2.h
+e8d36304622f6f1f68c574712205bc5d *inst/include/geese.h
+3f2e8af2c1525fb2d75c1edba70454aa *inst/include/geesubs.h
+151dd77b6836f73b5fecce50696993fa *inst/include/inter.h
+5f87133114c23dbb0d7a3b386398d950 *inst/include/ordgee.h
+9dc8477a0757b19fdedc684c190f41bd *inst/include/param.h
+b3184852ad60355ddb93aa6088ef8dec *inst/include/tnt/cholesky.h
+44325cd2b27ac5c1f62c46b52beda7ca *inst/include/tnt/cmat.h
+b907fba24d98fe784c2aca8ba2560bf3 *inst/include/tnt/fcscmat.h
+93b348566b39218cc319030f4795e92e *inst/include/tnt/fmat.h
+425fea9a2a5c1cc90d52bd82d647c05e *inst/include/tnt/fortran.h
+fd23423fcafc9674976f83a3298d7d4c *inst/include/tnt/fspvec.h
+e1242d98de4641c4ea81eaaa4307407c *inst/include/tnt/index.h
+6d65338ae44dc7ba0ba2d2cb50dc446f *inst/include/tnt/lapack.h
+d6a1e7c72db91aabe9a70c48db6328f9 *inst/include/tnt/lu.h
+fc22a29247a50662cbf783f3d2f97c56 *inst/include/tnt/qr.h
+e23b5474a726eeca9771728bc526361b *inst/include/tnt/region1d.h
+d33aaf94a11f3eb04e224cf44d82e393 *inst/include/tnt/region2d.h
+eb5a346a4fcc85c57261df368a1f7f14 *inst/include/tnt/stopwatch.h
+8a5d0a1047ec4a6b3c4ca01f066ca9eb *inst/include/tnt/subscript.h
+786cbeafa43084b1ea4011f8ad5857b4 *inst/include/tnt/tnt.h
+e32f54666091ddaa4a725307e0b1d927 *inst/include/tnt/tntmath.h
+0b59b342920f4a04000b127f6e1e717d *inst/include/tnt/tntreqs.h
+84820dab16539eca614056afec760cf9 *inst/include/tnt/transv.h
+788148ad7103eca77f409145f9179455 *inst/include/tnt/triang.h
+e7b1ca55079198e0f607290bd695879c *inst/include/tnt/trisolve.h
+439dca5c34a0ff0487203cc0942b8299 *inst/include/tnt/vec.h
+9272e420c6830350556d1fc75ef8842d *inst/include/tnt/vecadaptor.h
+eaf9aba61829cfec165700e58b1b797a *inst/include/tnt/version.h
+63306aaab6fa232e638cc6fb41c10ae6 *inst/include/tntsupp.h
+792414dedc27451611050b16a5873cae *inst/include/utils.h
+80a6c7f5d8e2838ccfd860229b06e4d1 *man/DATA-dietox.Rd
+c38dbc5ef12ef64c2cf49b182b7a4d8a *man/DATA-koch.Rd
+1f752daf599bbdee98251e10168d7d21 *man/DATA-ohio.Rd
+4c816dc2b88d5d72132bfeb54c6409c2 *man/DATA-respdis.Rd
+2cc5aa1fe60a52165a62c84ab35e5707 *man/DATA-respiratory.Rd
+e27a475274ea0a06fa8b09c5de50c2f6 *man/DATA-seizure.Rd
+522ccfa5e3391f24554cf5b292a0dc67 *man/DATA-sitka89.Rd
+c36faf58200d1c7f9bcf4d6fb2fb6273 *man/DATA-spruce.Rd
+f5eb9c0b968c541dedd31c4fd440125e *man/SHDgeese-internal.Rd
+98ef5da28dd7104a90ad29c2ad0838f2 *man/compCoef.Rd
+8a21cebc69dedc7951b8f5267feef640 *man/fixed2Zcor.Rd
+42421a2c802e169b2162a8a61151ed90 *man/geeglm.Rd
+fc96c21e1b768ed26b82a12b1a80b10a *man/geese-internal.Rd
+380385b1f9e0dc1ced2542f83bf6b086 *man/geese.Rd
+7d7f5ba24d1c68f055eac8ae028b02ee *man/geese.control.Rd
+382e1e89608e8f86a90186c62306d6d0 *man/genZcor.Rd
+25ef8f9ca91a04270a892c3006c40a42 *man/ordgee.Rd
+54b06bbedd91bf0aa774ee7e05a435fc *man/relRisk.Rd
+8bb53f14cf0f67b02bdd966aadb484a2 *src/Makevars
+a67713e7bd2af24366a6de5161d60e16 *src/famstr.cc
+96ddcb6778b6c316ddf5b9e27d4fcab4 *src/gee2.cc
+a03f71117e827c1b67df1c8d0b2ebc50 *src/geesubs.cc
+e592864c942de117c0afb78b01d28019 *src/inter.cc
+a00d55d44890eb2796f6e01d2c778516 *src/ordgee.cc
+cc4f054a5e831b0dccda7ffe2398143b *src/param.cc
+5f2f46506fe7fdeb7dc87ae35c53e4a2 *src/utils.cc
+3be52b7e7574dc6e40ca55938a8b3069 *vignettes/geepack-manual.Rnw
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100755
index 0000000..4ca095a
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,20 @@
+useDynLib(geepack)
+
+
+# maintained by Soren
+export(geeglm, fixed2Zcor, anovageePrim2)
+S3method(anova, geeglm)
+S3method(print, geeglm)
+S3method(residuals, geeglm)
+S3method(summary, geeglm)
+S3method(print, summary.geeglm)
+
+
+# maintained by Jun
+export(geese, geese.fit, ordgee, geese.control)
+export(genZcor, genZodds)
+export(relRisk)
+export(compCoef)
+S3method(print, geese)
+S3method(summary, geese)
+S3method(print, summary.geese)
diff --git a/R/fixed2Zcor.R b/R/fixed2Zcor.R
new file mode 100755
index 0000000..1b7d9fd
--- /dev/null
+++ b/R/fixed2Zcor.R
@@ -0,0 +1,27 @@
+##
+## Generate zcor vector from
+## 1) fixed correlation matrix
+## 2) id information
+## 3) waves information
+
+## The zcor-vector contrains entries only for clusters
+## of size larger than 1
+
+fixed2Zcor <- function(cor.fixed, id, waves){
+ zcor<-NULL
+ cnt <- 1
+ uniq.id <- unique(id)
+ for (ii in uniq.id){
+ cwaves <- waves[id==ii]
+ if (length(cwaves)>1) {
+ for (kk in 1: (length(cwaves)-1)) {
+ for (mm in (kk+1) : length(cwaves)) {
+ vvv <- cor.fixed[cwaves[mm],cwaves[kk]]
+ zcor<-c(zcor,vvv)
+
+ }
+ }
+ }
+ }
+ zcor
+}
\ No newline at end of file
diff --git a/R/geeglm-anova.R b/R/geeglm-anova.R
new file mode 100755
index 0000000..b89ec9c
--- /dev/null
+++ b/R/geeglm-anova.R
@@ -0,0 +1,349 @@
+anovageePrim2 <- function(m1, m2,...){
+
+ mm1 <- model.matrix(m1)
+ mm2 <- model.matrix(m2)
+
+ P1 <- mm1 %*% solve(t(mm1)%*%mm1) %*% t(mm1)
+ P2 <- mm2 %*% solve(t(mm2)%*%mm2) %*% t(mm2)
+ e2 <- mm2 - P1 %*% mm2
+ e1 <- mm1 - P2 %*% mm1
+
+ m2inm1 <- all(apply(e2,2,var) < 1e-10)
+ m1inm2 <- all(apply(e1,2,var) < 1e-10)
+
+ if (!any(c(m2inm1,m1inm2)))
+ cat("Models not nested\n")
+ else
+ if (all(c(m2inm1,m1inm2)))
+ cat("Models are identical\n")
+ else {
+ if (m1inm2){
+ tmp <- m1
+ m1 <- m2
+ m2 <- tmp
+ }
+ ## Now mm2 < mm1
+ mm1 <- model.matrix(m1)
+ mm2 <- model.matrix(m2)
+
+ ## What is this? I wonder
+ mf1 <- paste(paste(formula(m1))[c(2,1,3)],collapse=" ")
+ mf2 <- paste(paste(formula(m2))[c(2,1,3)],collapse=" ")
+
+ ## Reparametrize the model
+ mm <- cbind(mm2,mm1)
+ qmm <- qr(mm)
+ qmmq <- qr.Q(qmm)
+ nymm1 <- as.data.frame(qmmq[,1:qmm$rank])
+ colnames(nymm1) <- paste("parm",1:ncol(nymm1),sep=".")
+ nymm2 <- nymm1[,1:ncol(mm2),drop=FALSE]
+
+ formula1 <- formula(paste(formula(m1)[[2]],formula(m1)[[1]],
+ paste(c("-1",colnames(nymm1)),collapse="+"),collapse=""))
+
+ m1call <- m1$call
+
+ ## BUGFIX provided by Stefan Boehringer
+ ##nymm1[,paste(formula(m1call)[[2]])] <- m1$y
+ nymm1[, paste(formula(m1)[[2]])] <- m1$y
+
+ nymm1[,paste(m1call$id)] <- m1$id
+ m1call$offset <- m1$offset
+ m1call$weights <- m1$weights
+ m1call$formula <- formula1
+ m1call$data <- nymm1
+ m1ny <- eval(m1call)
+
+ ## Calculate wald statistic
+ beta <- coef(m1ny)
+ vbeta <- summary(m1ny)$cov.unscaled
+ df<- dim(mm1)[2]-dim(mm2)[2]
+ rbeta<-rep(1,length(beta))
+ rbeta[1:df]<-0
+ beta0<-rev(rbeta)
+ zeroidx <- beta0==0
+ X2<-t(beta[zeroidx])%*% solve(vbeta[zeroidx,zeroidx,drop=FALSE])%*%beta[zeroidx]
+
+
+ ## Make table with results
+ topnote <- paste("Model 1", mf1,"\nModel 2", mf2)
+ title <- "Analysis of 'Wald statistic' Table\n"
+ table <- data.frame(Df=df, X2=X2,p=1-pchisq(X2,df))
+ dimnames(table) <- list("1", c("Df", "X2", "P(>|Chi|)"))
+ val <- structure(table, heading = c(title,topnote), class = c("anova",
+ "data.frame"))
+ return(val)
+ }
+}
+
+anova.geeglmlist <-
+ function (object, ..., dispersion = NULL, test = NULL)
+{
+ responses <- as.character(lapply(object, function(x) {
+ deparse(formula(x)[[2]])
+ }))
+ sameresp <- responses == responses[1]
+ if (!all(sameresp)) {
+ object <- object[sameresp]
+ warning("Models with response ", deparse(responses[!sameresp]),
+ " removed because response differs from ", "model 1")
+ }
+
+ ns <- sapply(object, function(x) length(x$residuals))
+ if (any(ns != ns[1]))
+ stop("models were not all fitted to the same size of dataset")
+
+ objects <- list(object,...)
+ m1 <- objects[[1]][[1]]
+ if (length(objects[[1]])>1)
+ m2 <- objects[[1]][[2]]
+ else
+ m2 <- NULL
+
+ value <- anovageePrim2(m1,m2)
+ return(value)
+}
+
+
+anova.geeglm<-function (object, ..., dispersion = NULL, test = NULL)
+{
+ dotargs <- list(...)
+ named <- if (is.null(names(dotargs)))
+ rep(FALSE, length(dotargs))
+ else (names(dotargs) != "")
+ if (any(named))
+ warning("The following arguments to anova.glm(..) are invalid and dropped: ",
+ paste(deparse(dotargs[named]), collapse = ", "))
+ dotargs <- dotargs[!named]
+ is.glm <- unlist(lapply(dotargs, function(x) inherits(x, "glm")))
+ dotargs <- dotargs[is.glm]
+ if (length(dotargs) > 0)
+ return(anova.geeglmlist(c(list(object), dotargs), dispersion = dispersion,
+ test = test))
+
+ varlist <- attr(object$terms, "variables")
+ ##print(varlist)
+ x <- if (n <- match("x", names(object), 0))
+ object[[n]]
+ else model.matrix(object)
+
+ varseq <- attr(x, "assign")
+
+ nvars <- max(0, varseq)
+ betaList <- vbetaList <- NULL
+
+ if (nvars > 1) {
+ method <- object$method
+ if (!is.function(method))
+ method <- get(method, mode = "function", envir = parent.frame())
+ for (i in 1:(nvars - 1)) {
+ eprint("calling fit....")
+ ##print(length(object$y))
+ fit <- method(x = x[, varseq <= i, drop = FALSE],
+ y = object$y, weights = object$prior.weights,
+ corstr = object$corstr,
+ start = object$start, offset = object$offset, id=object$id,
+ family = object$family, control = object$control)
+
+ betaList <- c(betaList,list(fit$beta))
+ vbetaList <- c(vbetaList,list(fit$vbeta))
+ }
+ }
+
+ betaList <- c(betaList, list( object$geese$beta ))
+ vbetaList <- c(vbetaList, list( object$geese$vbeta ))
+
+ hasIntercept <- (length(grep("(Intercept)",names(betaList[[1]])))!=0)
+ dimVec <- unlist(lapply(betaList,length))
+
+ if (hasIntercept){
+ dfVec <- dimVec[1]-1
+ } else {
+ dfVec <- dimVec[1]
+ }
+
+ if (length(dimVec)>1){
+ for (i in 2:length(dimVec))
+ dfVec <- c(dfVec,dimVec[i]-dimVec[i-1])
+ }
+
+ ##print(dfVec)
+ X2Vec <- NULL
+ ## Calculate Wald statistics
+ for (i in 1:length(dfVec)){
+ beta <- betaList[[i]]
+ vbeta <- vbetaList[[i]]
+ beta0 <- rep(1,length(beta))
+ beta0[1:dfVec[i]] <- 0
+ beta0 <- rev(beta0)
+ zeroidx <- beta0==0
+ X2 <- t(beta[zeroidx])%*%solve(vbeta[zeroidx,zeroidx,drop=FALSE])%*%beta[zeroidx]
+ X2Vec <- c(X2Vec,X2)
+ }
+
+ resdf <- dfVec
+ resdev <- X2Vec
+ table <- data.frame(resdf, resdev, 1-pchisq(resdev,resdf))
+
+ tl <- attr(object$terms, "term.labels")
+
+ #print(table)
+ if (length(tl) == 0)
+ table <- table[1, , drop = FALSE]
+
+ dimnames(table) <- list(c(tl), c("Df", "X2", "P(>|Chi|)"))
+
+ title <- paste("Analysis of 'Wald statistic' Table", "\nModel: ",
+ object$family$family, ", link: ", object$family$link,
+ "\nResponse: ", as.character(varlist[-1])[1],
+ "\nTerms added sequentially (first to last)\n",
+ sep = "")
+
+ structure(table, heading = title, class = c("anova", "data.frame"))
+}
+
+
+
+
+
+# anova.geeglm <- function(object, ...){
+# anovaPgee (object, ...)
+# }
+
+
+# anovaPgee <- function(object, ...){
+# #cat("anova.gee\n")
+# m1 <- object
+# objects <- list(object,...)
+# if (length(objects)>1)
+# m2 <- objects[[2]]
+# else
+# m2 <- NULL
+
+# if (is.null(m2)){
+# term <- attr(object$terms,"term.labels")
+# resp <- paste(formula(object))[2]
+# rhs <- lapply(1:length(term), function(i) paste(term[1:i],collapse=" + "))
+# print(rhs)
+
+# model.list <- c(paste(resp,"~ 1"), paste(resp,"~", rhs))
+
+
+# value <- NULL
+# for (i in 2:length(model.list)){
+# if (i==2){
+# mf1 <- model.list[i-1]
+# mf2 <- model.list[i]
+# ##print(mf1); print(mf2)
+
+# #print(mf1)
+# #print(object)
+
+# m1 <- update(object,formula=as.formula(mf1))
+# m2 <- update(object,formula=as.formula(mf2))
+# } else {
+# m1 <- m2
+
+# m2 <- update(object,formula=as.formula(model.list[i]))
+# ##print(formula(m1)[1:3]); print(formula(m2)[1:3])
+# }
+# value <- rbind(value,anovageePrim(m1,m2))
+# }
+# rownames(value) <- term
+# attr(value,"model1") <- NULL
+# attr(value,"model2") <- NULL
+# } else {
+# value <- anovageePrim(object,m2)
+# }
+# value[,3] <- round(value[,3],5)
+# return(value)
+# }
+
+
+# anovageePrim <- function(m1, m2,...){
+# mm1 <- model.matrix(m1)
+# mm2 <- model.matrix(m2)
+# P1 <- mm1 %*% solve(t(mm1)%*%mm1) %*% t(mm1)
+# P2 <- mm2 %*% solve(t(mm2)%*%mm2) %*% t(mm2)
+# e2 <- mm2 - P1 %*% mm2
+# e1 <- mm1 - P2 %*% mm1
+
+# #print(mm1[c(1:5,100:105),]); print(mm2[c(1:5,100:105),])
+# m2inm1 <- all(apply(e2,2,var) < 1e-10)
+# m1inm2 <- all(apply(e1,2,var) < 1e-10)
+
+# #print(apply(e2,2,var))
+# #print(apply(e1,2,var))
+# #print(m2inm1)
+# #print(m1inm2)
+# if (!any(c(m2inm1,m1inm2)))
+# cat("Models not nested\n")
+# else
+# if (all(c(m2inm1,m1inm2)))
+# cat("Models are identical\n")
+# else {
+# if (m1inm2){
+# tmp <- m1
+# m1 <- m2
+# m2 <- tmp
+# }
+
+# mm1 <- model.matrix(m1)
+# mm2 <- model.matrix(m2)
+
+# mf1 <- paste(paste(formula(m1))[c(2,1,3)],collapse=" ")
+# mf2 <- paste(paste(formula(m2))[c(2,1,3)],collapse=" ")
+
+# mm <- cbind(mm2,mm1)
+# qmm <- qr(mm)
+# qmmq <- qr.Q(qmm)
+# nymm1 <- as.data.frame(qmmq[,1:qmm$rank])
+# colnames(nymm1) <- paste("parm",1:ncol(nymm1),sep=".")
+# nymm2 <- nymm1[,1:ncol(mm2),drop=FALSE]
+
+# dimDiff <- ncol(nymm1)-ncol(nymm2)
+
+# D <- diag(dimDiff)
+# L <- cbind(matrix(0,ncol=ncol(nymm2),nrow=nrow(D)),D)
+
+# formula1 <- formula(paste(formula(m1)[[2]],formula(m1)[[1]],
+# paste(c("-1",colnames(nymm1)),collapse="+"),collapse=""))
+
+
+
+# m1call <- m1$call
+# #print(formula(m1call)[[2]])
+# #print(nymm1[1:10,])
+# #print(paste(m1call$formula[[2]]))
+# #nymm1[,paste(m1call$formula[[2]])] <- m1$y
+# nymm1[,paste(formula(m1call)[[2]])] <- m1$y
+# nymm1[,paste(m1call$id)] <- m1$id
+# m1call$offset <- m1$offset
+# m1call$weights <- m1$weights
+# m1call$formula <- formula1
+
+# m1call$data <- nymm1
+# m1ny <- eval(m1call)
+# #print(class(m1ny))
+
+# val <- esticon(m1ny,L,joint.test=TRUE)
+
+# rownames(val)<-""
+# class(val) <- c("anova.gee","data.frame")
+# attr(val,"model1") <- mf1
+# attr(val,"model2") <- mf2
+# return(val)
+# }
+# }
+
+# print.anova.geeglm <- function(x,...){
+# cat("Analysis table for GEE models\n\n")
+# if (!is.null(attr(x,"model1"))){
+# cat("Model 1: "); cat(attr(x,"model1"), "\n")
+# cat("Model 2: "); cat(attr(x,"model2"), "\n\n")
+# }
+# print.data.frame(x)
+
+# }
+
+
diff --git a/R/geeglm.R b/R/geeglm.R
new file mode 100755
index 0000000..8ea0838
--- /dev/null
+++ b/R/geeglm.R
@@ -0,0 +1,544 @@
+
+eprint <- function(x){
+ #print(x)
+}
+
+geeglm<- function (formula, family = gaussian, data = parent.frame(),
+ weights, subset, na.action, start = NULL, etastart, mustart,
+ offset, control = geese.control(...), method = "glm.fit",
+ x = FALSE, y = TRUE, contrasts = NULL, id, waves = NULL,
+ zcor = NULL, corstr = "independence", scale.fix = FALSE,
+ scale.value = 1, std.err = "san.se", ...)
+{
+
+
+
+ STDERRS <- c("san.se", "jack", "j1s", "fij")
+ stderrv <- pmatch(std.err, STDERRS, -1)
+ std.err <- STDERRS[stderrv]
+ jackB <- j1sB <- fijB <- FALSE
+ if (std.err == "jack")
+ jackB <- TRUE
+ if (std.err == "j1s")
+ j1sB <- TRUE
+ if (std.err == "fij")
+ fijB <- TRUE
+ control$jack <- as.integer(jackB)
+ control$j1s <- as.integer(j1sB)
+ control$fij <- as.integer(fijB)
+ CORSTRS <- c("independence", "exchangeable", "ar1", "unstructured",
+ "userdefined","fixed")
+ if (corstr=="fixed" && is.null(zcor)){
+ stop("When corstr is 'fixed' then 'zcor' must be given\n")
+ }
+ eprint("SHDgeese.fit - corstr")
+ corstrv <- pmatch(corstr, CORSTRS, -1)
+ corstr <- CORSTRS[corstrv]
+ eprint("geeglm is called")
+
+
+ call <- match.call(expand.dots = TRUE)
+ glmcall <- call
+ glmcall$id <- glmcall$jack <- glmcall$control <- glmcall$corstr <-
+ glmcall$waves <- glmcall$zcor <- glmcall$std.err <-
+ glmcall$scale.fix <- glmcall$scale.value <- NULL
+ glmcall[[1]] <- as.name("glm")
+ glmFit <- eval(glmcall, parent.frame())
+ mf <- call
+ mf[[1]] <- as.name("model.frame")
+
+ modelmat <- model.matrix(glmFit)
+ qqrr <- qr(modelmat)
+ if (qqrr$rank < ncol(modelmat)){
+ print(head(modelmat))
+ stop("Model matrix is rank deficient; geeglm can not proceed\n")
+ }
+
+
+
+
+
+
+
+
+
+ mftmp <- mf
+ mftmp$family <- mftmp$corstr <- mftmp$control <- mftmp$zcor <- mftmp$std.err <- NULL
+
+ mftmp$scale.fix <- NULL
+ mf <- eval(mftmp, parent.frame())
+
+ id <- model.extract(mf, id)
+
+ if (is.null(id))
+ stop("id variable not found.")
+ waves <- model.extract(mf, waves)
+ if (!is.null(waves))
+ waves <- as.factor(waves)
+ mt <- attr(mf, "terms")
+ Y <- model.response(mf, "numeric")
+ X <- if (!is.empty.model(mt))
+ model.matrix(mt, mf, contrasts)
+ else matrix(, NROW(Y), 0)
+
+
+ ## Check that factors in model do not have unused levels in data
+ ## (otherwise R crashes).
+ vars <- all.vars(formula)
+ stopIt <- FALSE
+ for(ii in seq_along(vars)){
+ vv <- vars[ii]
+ if(!is.na(match(vv,names(mf))) && is.factor(mf[,vv])){
+ if (length(unique(mf[,vv])) != length(levels(mf[,vv]))){
+ cat("Factors not allowed to have unused levels...\n")
+ cat(" Levels of factor",vv,":", paste(levels(mf[,vv]),sep=' '),"\n")
+ cat(" Used levels of factor",vv,":", paste(unique(mf[,vv]),sep=' '),"\n")
+ stopIt <- TRUE
+ }
+ }
+ }
+ if (stopIt)
+ stop("Can not continue...\n")
+
+
+
+
+ N <- NROW(Y)
+ yy <- Y
+ xx <- X
+ soffset <- rep(0, N)
+ mnames <- c("", "formula", "data", "offset", "weights", "subset",
+ "na.action")
+ cnames <- names(call)
+ cnames <- cnames[match(mnames, cnames, 0)]
+ mcall <- call[cnames]
+ mcall$drop.unused.levels <- TRUE
+ mcall[[1]] <- as.name("model.frame")
+ mcall$formula <- formula
+ sformula <- ~1
+ mcall$formula[3] <- switch(match(length(sformula), c(0, 2,
+ 3)), 1, sformula[2], sformula[3])
+ m <- eval(mcall, parent.frame())
+ terms <- attr(m, "terms")
+ zsca <- model.matrix(terms, m, contrasts)
+ colnames(zsca) <- c("(Intercept)")
+ w <- model.weights(mf)
+ if (is.null(w))
+ w <- rep(1, N)
+ offset <- model.offset(mf)
+ if (is.null(offset))
+ offset <- rep(0, N)
+ if (glmFit$family$family == "binomial") {
+ if (is.matrix(yy) && ncol(yy) == 2) {
+ w <- apply(yy, 1, sum)
+ yy <- yy[, 1]/w
+ }
+ }
+ family <- glmFit$family
+ nacoef <- as.numeric(which(is.na(glmFit$coef)))
+ xx <- as.data.frame(xx)
+ xx[, nacoef] <- NULL
+ xx <- as.matrix(xx)
+
+ if (is.null(start))
+ start <- glmFit$coef
+
+ ans <- geese.fit(xx, yy, id, offset, soffset, w, waves = waves,
+ zsca, zcor = zcor, corp = NULL, control = control, b = start,
+ alpha = NULL, gm = NULL, family, mean.link = NULL, variance = NULL,
+ cor.link = "identity", sca.link = "identity", link.same = TRUE,
+ scale.fix = scale.fix, scale.value = scale.value, corstr,
+ ...)
+ ans <- c(ans, list(call = call, formula = formula))
+ class(ans) <- "geese"
+ ans$X <- xx
+ ans$id <- id
+ ans$weights <- w
+ value <- glmFit
+ toDelete <- c("R", "deviance", "aic", "null.deviance", "iter",
+ "df.null", "converged", "boundary")
+ value[match(toDelete, names(value))] <- NULL
+ value$method <- "geese.fit"
+ value$geese <- ans
+ value$weights <- ans$weights
+ value$coefficients <- ans$beta
+ value$offset <- offset
+ if (is.null(value$offset))
+ value$linear.predictors <- ans$X %*% ans$beta
+ else value$linear.predictors <- value$offset + ans$X %*%
+ ans$beta
+ value$fitted.values <- family(value)$linkinv(value$linear.predictors)
+ value$modelInfo <- ans$model
+ value$id <- ans$id
+ value$call <- ans$call
+ value$corstr <- ans$model$corstr
+ value$cor.link <- ans$model$cor.link
+ value$control <- ans$control
+ value$std.err <- std.err
+ class(value) <- c("geeglm", "gee", "glm")
+ return(value)
+}
+
+
+
+
+
+
+
+
+
+
+summary.geeglm <- function(object,...){
+ v1 <- summary.geese(object$geese)
+ class(object) <- "glm"
+ value <- summary.glm(object)
+ class(object) <- c("geeglm","glm")
+ class(value) <- "summary.geeglm"
+ toDelete <- c("deviance","aic","null.deviance","iter","df.residual","df.null",
+ "converged","boundary")
+ idx <- match(toDelete,names(value))
+ value[idx] <- NULL
+
+
+
+ covmat <-
+ switch(object$std.err,
+ 'jack'={object$geese$vbeta.ajs},
+ 'j1s'={object$geese$vbeta.j1s},
+ 'fij'={object$geese$vbeta.fij},
+ object$geese$vbeta
+ )
+ value$cov.scaled <- value$cov.unscaled <- covmat
+
+ mean.sum <- data.frame(estimate = object$geese$beta, std.err=sqrt(diag(covmat)))
+ mean.sum$wald <- (mean.sum$estimate / mean.sum$std.err)^2
+ mean.sum$p <- 1 - pchisq(mean.sum$wald, df=1)
+ ## names(mean.sum) <- c("Estimate", "Std.err", "Wald", "p(>W)")
+ names(mean.sum) <- c("Estimate", "Std.err", "Wald", "Pr(>|W|)") ## Thanks, Achim
+
+ value$coefficients <- mean.sum
+
+
+ covmatgam <-
+ switch(object$std.err,
+ 'jack'={object$geese$vgamma.ajs},
+ 'j1s'={object$geese$vgamma.j1s},
+ 'fij'={object$geese$vgamma.fij},
+ object$geese$vgamma
+ )
+ scale.sum <- data.frame(Estimate = object$geese$gamma, Std.err=sqrt(diag(covmatgam)))
+ #scale.sum$wald <- (scale.sum$Estimate / scale.sum$Std.err)^2
+ #scale.sum$p <- 1 - pchisq(scale.sum$wald, df=1)
+
+ if (!is.null(object$geese$zsca.names)) rownames(scale.sum) <- object$geese$zsca.names
+ value$dispersion <- scale.sum
+
+ covmatalpha <-
+ switch(object$std.err,
+ 'jack'={object$geese$valpha.ajs},
+ 'j1s'={object$geese$valpha.j1s},
+ 'fij'={object$geese$valpha.fij},
+ object$geese$valpha
+ )
+
+ corr.sum <- data.frame(Estimate = object$geese$alpha, Std.err=sqrt(diag(covmatalpha)))
+ #corr.sum$wald <- (corr.sum$Estimate / corr.sum$Std.err)^2
+ #corr.sum$p <- 1 - pchisq(corr.sum$wald, df=1)
+ #if (nrow(corr.sum) > 0) rownames(corr.sum) <- object$geese$zcor.names
+ value$corr <- corr.sum
+
+
+ value$corstr <- object$geese$model$corstr
+ value$scale.fix <- object$geese$model$scale.fix
+ value$cor.link <- object$geese$model$cor.link
+
+ value$clusz <- v1$clusz
+ value$error <- object$geese$error
+ value$geese <- v1
+ return(value)
+}
+
+
+# colnames(mean.sum) <- c("Estimate","Std.Error","ajs.SE","j1s.SE","fij.SE",
+# "Wald","Pr(>|z|)")
+
+
+print.summary.geeglm <- function (x,
+ digits = max(3, getOption("digits") - 3),
+ quote = FALSE, prefix = "", ...) # Thanks, Achim...
+
+#print.summary.geeglm <- function (x, digits = NULL, quote = FALSE, prefix = "", ...)
+{
+ if (is.null(digits))
+ digits <- options()$digits
+ else options(digits = digits)
+ cat("\nCall:\n"); print(x$call)
+ cat("\n Coefficients:\n");
+ ##print(as.matrix(x$coef), digits = digits)
+ printCoefmat(as.matrix(x$coef), digits = digits) ## Thanks, Achim
+
+ if (x$scale.fix == FALSE) {
+ cat("\nEstimated Scale Parameters:\n")
+ print(x$dispersion[1:2], digits = digits)
+ }
+ else cat("\nScale is fixed.\n")
+ cat("\nCorrelation: Structure =", x$corstr)
+ if (pmatch(x$corstr, "independence", 0) == 0) {
+ cat(" Link =", x$cor.link, "\n")
+ cat("\nEstimated Correlation Parameters:\n")
+ print(x$corr, digits = digits)
+ }
+
+ cat("Number of clusters: ", length(x$clusz), " Maximum cluster size:",
+ max(x$clusz), "\n")
+ #cat("\nReturned Error Value: ")
+ #cat(x$error, "\n")
+ invisible(x)
+}
+
+
+print.geeglm <- function (x, digits = NULL, quote = FALSE, prefix = "", ...)
+{
+ xg <- x$geese
+ if (is.null(digits))
+ digits <- options()$digits
+ else options(digits = digits)
+ cat("\nCall:\n"); print(x$call)
+ cat("\nCoefficients:\n")
+ print(unclass(x$coefficients), digits = digits)
+
+ cat("\nDegrees of Freedom:", length(x$y), "Total (i.e. Null); ",
+ x$df.residual, "Residual\n")
+
+ if (!xg$model$scale.fix) {
+ cat("\nScale Link: ", xg$model$sca.link)
+ cat("\nEstimated Scale Parameters: ")
+ print(as.numeric(unclass(xg$gamma)), digits = digits)
+ }
+ else cat("\nScale is fixed.\n")
+
+ cat("\nCorrelation: Structure =",xg$model$corstr, " ")
+ if (pmatch(xg$model$corstr, "independence", 0) == 0) {
+ cat(" Link =", xg$model$cor.link, "\n")
+ cat("Estimated Correlation Parameters:\n")
+ print(unclass(xg$alpha), digits = digits)
+ }
+ cat("\nNumber of clusters: ", length(xg$clusz), " Maximum cluster size:",
+ max(xg$clusz), "\n\n")
+ invisible(x)
+}
+
+
+residuals.geeglm <- function (object, type = c("pearson", "working", "response"), ...)
+{
+ type <- match.arg(type)
+ y <- object$y
+ r <- object$residuals
+ mu <- object$fitted.values
+ wts <- object$prior.weights
+ res <- switch(type,
+# deviance = if (object$df.res > 0) {
+# d.res <- sqrt(pmax((object$family$dev.resids)(y, mu,
+# wts), 0))
+# ifelse(y > mu, d.res, -d.res)
+# }
+# else rep.int(0, length(mu)),
+
+ pearson = (y - mu) * sqrt(wts)/sqrt(object$family$variance(mu)),
+ working = r,
+ response = y - mu,
+ partial = r)
+ if (!is.null(object$na.action))
+ res <- naresid(object$na.action, res)
+# if (type == "partial")
+# res <- res + predict(object, type = "terms")
+ res
+}
+
+plot.geeglm <- function(x,...){
+ xx <- fitted(x)
+ rp <- residuals(x,"pearson")
+ plot(xx,rp,ylab="Pearson residuals",xlab="Fitted values")
+ abline(h=0)
+ m <- lowess(rp ~ xx)
+ lines(m)
+
+}
+
+
+
+
+# geeglm <- function (formula, family = gaussian, data=parent.frame(), weights, subset,
+# na.action, start = NULL, etastart, mustart, offset,
+# control = geese.control(...),
+# method = "glm.fit", x = FALSE, y = TRUE,
+# contrasts = NULL,
+# id, waves = NULL,
+# zcor=NULL,
+# corstr = "independence",
+# scale.fix = FALSE,
+# scale.value =1,
+# std.err = 'san.se',
+# ...)
+# {
+
+
+# STDERRS <- c("san.se", "jack", "j1s", "fij")
+# stderrv <- pmatch(std.err, STDERRS, -1)
+# std.err <- STDERRS[stderrv]
+
+# jackB <- j1sB <- fijB <- FALSE
+
+# if (std.err=='jack') jackB <- TRUE
+# if (std.err=='j1s') j1sB <- TRUE
+# if (std.err=='fij') fijB <- TRUE
+
+# control$jack <- as.integer(jackB)
+# control$j1s <- as.integer(j1sB)
+# control$fij <- as.integer(fijB)
+
+# CORSTRS <- c("independence", "exchangeable", "ar1", "unstructured", "userdefined")
+# eprint("SHDgeese.fit - corstr")
+# corstrv <- pmatch(corstr, CORSTRS, -1)
+# corstr<-CORSTRS[corstrv]
+
+# eprint("geeglm is called")
+# call <- match.call(expand.dots=TRUE)
+
+# glmcall <- call
+# glmcall$id <- glmcall$jack <- glmcall$control <- glmcall$corstr <- glmcall$waves <- glmcall$zcor<- glmcall$std.err <- glmcall$scale.fix <- glmcall$scale.value <- NULL
+
+
+# glmcall[[1]] <- as.name("glm")
+# glmFit <- eval(glmcall, parent.frame())
+
+# mf <- call
+# ##call$data <- mf$data <- na.omit(eval(mf$data))
+
+# mf[[1]] <- as.name("model.frame")
+# mftmp <- mf
+# mftmp$family <- mftmp$corstr <- mftmp$control <- mftmp$zcor<- mftmp$std.err <- NULL
+# mf <- eval(mftmp, parent.frame())
+
+
+# ### Copy from "geese" starts here
+# #################################
+# id <- model.extract(mf, id)
+# if (is.null(id))
+# stop("id variable not found.")
+
+# waves <- model.extract(mf, waves)
+# if (!is.null(waves))
+# waves <- as.factor(waves)
+
+# mt <- attr(mf, "terms")
+# Y <- model.response(mf, "numeric")
+# X <- if (!is.empty.model(mt))
+# model.matrix(mt, mf, contrasts)
+# else matrix(, NROW(Y), 0)
+
+# N <- NROW(Y)
+
+# yy <- Y
+# xx <- X
+
+# soffset <- rep(0, N)
+
+# mnames <- c("", "formula", "data", "offset", "weights", "subset", "na.action")
+# cnames <- names(call)
+# cnames <- cnames[match(mnames, cnames, 0)]
+# mcall <- call[cnames]
+# mcall$drop.unused.levels <- TRUE
+# mcall[[1]] <- as.name("model.frame")
+
+# mcall$formula <- formula
+# sformula <- ~1
+# mcall$formula[3] <-
+# switch(match(length(sformula),
+# c(0, 2, 3)), 1, sformula[2], sformula[3])
+# m <- eval(mcall, parent.frame())
+# terms <- attr(m, "terms")
+# zsca <- model.matrix(terms, m, contrasts)
+
+# colnames(zsca) <- c("(Intercept)")
+# #corstr <- "independence"
+# w <- model.weights(mf)
+# if (is.null(w))
+# w <- rep(1, N)
+
+# offset <- model.offset(mf)
+# if (is.null(offset))
+# offset <- rep(0, N)
+
+# if (glmFit$family$family=="binomial"){
+# if (is.matrix(yy) && ncol(yy)==2){
+# w <- apply(yy,1,sum)
+# yy<- yy[,1]/w
+# }
+# }
+
+# family <- glmFit$family
+# nacoef <- as.numeric(which(is.na(glmFit$coef)))
+# xx <- as.data.frame(xx)
+# xx[,nacoef] <- NULL
+# xx <- as.matrix(xx)
+# if (is.null(start))
+# start <- glmFit$coef
+
+# ans <- geese.fit(xx, yy, id, offset, soffset, w, waves=waves, zsca,
+# zcor=zcor, corp=NULL, control=control,
+# b=start,
+# alpha=NULL, gm=NULL, family, mean.link=NULL,
+# variance=NULL,
+# cor.link="identity", sca.link="identity",
+# link.same=TRUE, scale.fix=scale.fix, scale.value=scale.value,
+# corstr, ...)
+# ans <- c(ans, list(call = call, formula = formula))
+# class(ans) <- "geese"
+# ### Copy from geese ends here
+# #############################
+
+# ans$X <- xx
+# ans$id <- id
+# ans$weights <- w
+
+
+# value <- glmFit
+# toDelete <- c("R","deviance","aic","null.deviance","iter","df.null",
+# "converged","boundary")
+# value[match(toDelete,names(value))] <- NULL
+
+# value$method <- "geese.fit"
+# value$geese <- ans
+# value$weights <- ans$weights
+# value$coefficients <- ans$beta
+
+# ## Kludgy..
+# value$offset <- offset
+# if(is.null(value$offset))
+# value$linear.predictors <- ans$X %*% ans$beta
+# else
+# value$linear.predictors <- value$offset + ans$X %*% ans$beta
+
+# value$fitted.values <- family(value)$linkinv(value$linear.predictors)
+# value$modelInfo <- ans$model
+# value$id <- ans$id
+# value$call <- ans$call
+# value$corstr <- ans$model$corstr
+# value$cor.link <- ans$model$cor.link
+# value$control <- ans$control
+# value$std.err <- std.err
+# class(value) <- c("geeglm", "gee", "glm")
+# return(value)
+# }
+
+
+
+
+
+
+
+
+
+
+
diff --git a/R/geese.R b/R/geese.R
new file mode 100755
index 0000000..f0b8fe5
--- /dev/null
+++ b/R/geese.R
@@ -0,0 +1,233 @@
+geese <- function(formula = formula(data),
+ sformula = ~ 1,
+ id, waves = NULL,
+ data = parent.frame(), subset = NULL, na.action = na.omit,
+ contrasts = NULL, weights = NULL,
+ ## zcor is design matrix for alpha,
+ ## corp is known paratemers to correlation coef. rho
+ zcor = NULL, corp = NULL,
+ ## zsca is constructed from sformula
+ ## control parameters
+ control = geese.control(...),
+ ## param
+ b = NULL, alpha = NULL, gm = NULL,
+ ## geestr
+ family = gaussian(),
+ mean.link = NULL,
+ variance = NULL,
+ cor.link = "identity",
+ sca.link = "identity",
+ link.same = TRUE,
+ scale.fix = FALSE, scale.value = 1.0,
+ ## corr
+ corstr = "independence",
+ ...) {
+ scall <- match.call()
+ mnames <- c("", "formula", "data", "offset", "weights", "subset", "na.action", "id", "waves", "corp")
+ cnames <- names(scall)
+ cnames <- cnames[match(mnames,cnames,0)]
+ mcall <- scall[cnames]
+ if (is.null(mcall$id)) mcall$id <- as.name("id")
+ mcall[[1]] <- as.name("model.frame")
+ m <- eval(mcall, parent.frame())
+
+ y <- model.extract(m, "response")
+ if (is.null(dim(y))) N <- length(y) else N <- dim(y)[1]
+ mterms <- attr(m, "terms")
+ x <- model.matrix(mterms, m, contrasts)
+ offset <- model.extract(m, "offset")
+ if (is.null(offset)) offset <- rep(0, N)
+ w <- model.extract(m, "weights")
+ if (is.null(w)) w <- rep(1, N)
+ id <- model.extract(m, id)
+ waves <- model.extract(m, "waves")
+ corp <- model.extract(m, "corp")
+ if (is.null(id)) stop("id variable not found.")
+
+ ##print(control)
+
+ ## setting up the scale model;
+ ## borrowed idea from S+ function dglm by Gordon Smyth
+ mcall$formula <- formula
+ mcall$formula[3] <- switch(match(length(sformula), c(0,2,3)),
+ 1, sformula[2], sformula[3])
+ m <- eval(mcall, parent.frame())
+ terms <- attr(m, "terms")
+ zsca <- model.matrix(terms, m, contrasts)
+ soffset <- model.extract(m, "offset")
+ if (is.null(soffset)) soffset <- rep(0, N)
+
+ if (is.character(family)) family <- get(family)
+ if (is.function(family)) family <- family()
+ ans <- geese.fit(x, y, id, offset, soffset, w,
+ waves, zsca, zcor, corp,
+ control,
+ b, alpha, gm,
+ family, mean.link, variance, cor.link, sca.link,
+ link.same, scale.fix, scale.value,
+ corstr, ...)
+ ans <- c(ans, list(call=scall, formula=formula))
+ class(ans) <- "geese"
+ ans
+}
+
+geese.fit <- function(x, y, id,
+ offset=rep(0,N), soffset=rep(0,N), weights=rep(1,N),
+ waves = NULL, zsca = matrix(1,N,1),
+ zcor = NULL, corp = NULL,
+ control = geese.control(...),
+ ## param
+ b = NULL, alpha = NULL, gm = NULL,
+ ## geestr
+ family = gaussian(),
+ mean.link = NULL,
+ variance = NULL,
+ cor.link = "identity",
+ sca.link = "identity",
+ link.same = TRUE,
+ scale.fix = FALSE, scale.value = 1.0,
+ ## corr
+ corstr = "independence", ...) {
+ N <- length(id)
+ ##clusz <- unlist(lapply(split(id, id), length))
+ clusnew <- c(which(diff(as.numeric(id)) != 0), length(id))
+ clusz <- c(clusnew[1], diff(clusnew))
+ maxclsz <- max(clusz)
+ if (is.null(waves)) waves <- unlist(sapply(clusz, function(x) 1:x))
+ waves <- as.integer(waves)
+
+ LINKS <- c("identity", "logit", "probit", "cloglog", "log", "inverse", "fisherz", "lwybc2", "lwylog")
+ VARIANCES <- c("gaussian", "binomial", "poisson", "Gamma") ## quasi is not supported yet
+
+ if (is.null(mean.link)) mean.link <- family$link
+ if (is.null(variance)) variance <- family$family
+ mean.link.v <- pmatch(mean.link, LINKS, -1, TRUE)
+ cor.link.v <- pmatch(cor.link, LINKS, -1, TRUE)
+ sca.link.v <- pmatch(sca.link, LINKS, -1, TRUE)
+ variance.v <- pmatch(variance, VARIANCES, -1, TRUE)
+ if (any(mean.link.v == -1)) stop("mean.link invalid.")
+ if (any(cor.link.v == -1)) stop("cor.link invalid.")
+ if (any(sca.link.v == -1)) stop("sca.link invalid.")
+ if (any(variance.v == -1)) stop("variance invalid.")
+ if (length(mean.link.v) != length(variance.v))
+ stop("mean.link and variance not same length.")
+ if (length(mean.link.v) != length(sca.link.v))
+ stop("mean.link and sca.link not same lehgnt.")
+
+ if (length(id) != length(y)) stop("id and y not same length.")
+ if (length(offset) != length(y)) stop("offset and y not same length")
+ if (length(soffset) != length(y)) stop("sca.offset and y not same length")
+ if (nrow(zsca) != length(y)) stop("nrow(zsca) and length(y) not match")
+
+ if (link.same) linkwaves <- rep(1, N)
+ else {
+ if (max(waves) != maxclsz) stop("maximum waves and maximum cluster size not equal")
+ if (length(mean.link.v) != maxclsz) stop("length of mean.link not equal to the maximum cluster size.")
+ linkwaves <- waves
+ }
+ linkwaves <- as.integer(linkwaves)
+ geestr <- list(length(mean.link.v), as.integer(mean.link.v),
+ as.integer(variance.v), as.integer(sca.link.v),
+ as.integer(cor.link.v), as.integer(scale.fix))
+
+ CORSTRS <- c("independence", "exchangeable", "ar1", "unstructured", "userdefined", "fixed")
+ corstrv <- pmatch(corstr, CORSTRS, -1)
+ if (corstrv == -1) stop("invalid corstr.")
+ corr <- list(as.integer(corstrv), maxclsz)
+
+ if (is.null(zcor)) {
+ if (corstrv == 5) stop("need zcor matrix for userdefined corstr.")
+ else zcor <- genZcor(clusz, waves, corstrv)
+ }
+ else {
+ if (!is.matrix(zcor)) zcor <- as.matrix(zcor)
+ if (corstrv >= 4 && nrow(zcor) != sum(clusz * (clusz - 1) / 2)) stop("nrow(zcor) need to be equal sum(clusz * (clusz - 1) / 2) for unstructured or userdefined corstr.")
+ if (corstrv %in% c(2,3) && nrow(zcor) != length(clusz)) stop("nrow(zcor) need to be equal to the number of clusters for exchangeable or ar1 corstr.")
+ }
+ if (!is.matrix(zcor)) zcor <- as.matrix(zcor)
+ if (is.null(corp)) corp <- as.double(waves)
+
+ p <- ncol(x)
+ q <- ncol(zcor)
+ r <- ncol(zsca)
+
+ ## Initial values setup
+ ## This may fail for binomial model with log link (relative risk)
+ ## fit0 <- glm.fit(x, y, weights=weights, offset=offset, family=family)
+ if (is.null(b)){
+ ##b <- rep(1,p)
+ fit0 <- glm.fit(x, y, weights=weights, offset=offset, family=family)
+ b <- fit0$coef
+ }
+ if (is.null(alpha)) {
+ if (corstrv == 6) alpha <- 1
+ else alpha <- rep(0,q)
+ }
+ if (is.null(gm)) {
+ ##gm <- rep(scale.value, r)
+ qlf <- quasi(LINKS[sca.link.v])$linkfun
+ ## pr2 <- (residuals.glm(fit0, type="pearson")) ^ 2
+ mu <- quasi(LINKS[mean.link.v])$linkinv(x %*% b)
+ pr2 <- (y - mu) ^ 2 / family$variance(mu)
+ gm <- lm.fit(zsca, qlf(pr2), offset = soffset)$coef
+ }
+ param <- list(b, alpha, gm)
+
+ ans <- .Call("gee_rap", y, x, offset, soffset, weights,
+ linkwaves, zsca, zcor, corp,
+ clusz, geestr, corr, param, control, PACKAGE = "geepack")
+ names(ans) <- c("beta", "alpha", "gamma", "vbeta", "valpha", "vgamma",
+ "vbeta.naiv", "valpha.naiv", "valpha.stab",
+ "vbeta.ajs", "valpha.ajs", "vgamma.ajs",
+ "vbeta.j1s", "valpha.j1s", "vgamma.j1s",
+ "vbeta.fij", "valpha.fij", "vgamma.fij",
+ "error")
+ ans$xnames <- dimnames(x)[[2]]
+ ans$zsca.names <- dimnames(zsca)[[2]]
+ ans$zcor.names <- dimnames(zcor)[[2]]
+ if (is.null(ans$zcor.names)) ans$zcor.names = paste("alpha", 1:ncol(zcor), sep=":")
+ names(ans$beta) <- ans$xnames
+ names(ans$gamma) <- ans$zsca.names
+ if (length(ans$alpha) > 0) names(ans$alpha) <- ans$zcor.names
+
+ param <- list(ans$beta, ans$alpha, ans$gamma)
+ infls <- .Call("infls_rap", y, x, offset, soffset, weights,
+ linkwaves, zsca, zcor, corp,
+ clusz, geestr, corr, param, control, PACKAGE = "geepack")
+ rownames(infls) <- c(paste("beta", names(ans$beta), sep="_"),
+ if (length(ans$gamma) > 0) paste("gamma", names(ans$gamma), sep="_") else NULL,
+ if (length(ans$alpha) > 0) paste("alpha", names(ans$alpha), sep="_") else NULL)
+
+ ans <- c(ans,
+ list(infls=infls,
+ clusz=clusz, control=control,
+ model=list(mean.link=mean.link,
+ variance=variance, sca.link=sca.link,
+ cor.link=cor.link, corstr=corstr, scale.fix=scale.fix)))
+ ans
+}
+
+geese.control <- function (epsilon = 1e-04, maxit = 25, trace = FALSE,
+ scale.fix = FALSE, jack = FALSE,
+ j1s = FALSE, fij = FALSE) {
+ if (!is.numeric(epsilon) || epsilon <= 0)
+ stop("value of epsilon must be > 0")
+ if (!is.numeric(maxit) || maxit <= 0)
+ stop("maximum number of iterations must be > 0")
+ list(trace = as.integer(trace),
+ jack = as.integer(jack), j1s = as.integer(j1s), fij = as.integer(fij),
+ maxit = as.integer(maxit), epsilon = epsilon)
+}
+
+
+## compare coefficients
+compCoef <- function(fit0, fit1) {
+ v0 <- names(fit0$beta)
+ v1 <- names(fit1$beta)
+ v0idx <- (1:length(v0))[v0 %in% v1]
+ v1idx <- (1:length(v1))[v1 %in% v0]
+ delta <- fit0$beta[v0idx] - fit1$beta[v1idx]
+ infls <- fit0$infls[v0idx,] - fit1$infls[v1idx,]
+ robvar <- infls %*% t(infls)
+ list(delta = delta, variance = robvar)
+}
diff --git a/R/internal.R b/R/internal.R
new file mode 100755
index 0000000..b2ef02c
--- /dev/null
+++ b/R/internal.R
@@ -0,0 +1,54 @@
+crossutri <- function(wave) {
+ n <- length(wave)
+ if (n == 1) return(NULL)
+ ans <- rep(0, n*(n-1)/2)
+ k <- 1
+ for (i in 1:(n-1))
+ for (j in (i+1):n) {
+ ans[k] <- paste(wave[i], wave[j], sep=":")
+ k <- k + 1
+ }
+ ans
+}
+
+genZcor <- function(clusz, waves, corstrv) {
+ if (corstrv == 1) return (matrix(0,0,0))
+ crs <- clusz * (clusz - 1) / 2
+ if (corstrv == 2 || corstrv == 3) {
+ ans <- matrix(1, length(clusz), 1)
+ ##ans <- matrix(1, sum(crs), 1)
+ colnames(ans) <- c("alpha")
+ }
+ else {
+ id <- rep(1:length(clusz), clusz)
+ z1 <- unlist(lapply(split(waves, id), crossutri))
+ z2 <- unlist(crossutri(1:max(clusz)))
+ z <- factor(z1,levels=unique.default(z2))
+ ans <- model.matrix(~z - 1)
+ znames <- paste("alpha", z2, sep = ".")
+ colnames(ans) <- znames
+ }
+ ans
+}
+
+
+genZodds <- function(clusz, waves, corstrv, ncat) {
+ if (corstrv == 1) return (matrix(0,0,0))
+ crs <- clusz * (clusz - 1) / 2
+ c2 <- ncat * ncat
+ if (corstrv == 2 | corstrv == 3) {
+ ans <- matrix(1, sum(crs) * c2, 1)
+ colnames(ans) <- c("alpha")
+ }
+ else {
+ id <- rep(1:length(clusz), clusz)
+ z1 <- unlist(lapply(split(waves, id), crossutri))
+ z2 <- unlist(crossutri(1:max(clusz)))
+ z <- factor(z1,levels=unique.default(z2))
+ z <- model.matrix(~z - 1)
+ ind <- gl(sum(crs), c2)
+ ans <- z[ind,]
+ colnames(ans) <- paste("alpha", 1:dim(ans)[2], sep=".")
+ }
+ ans
+}
diff --git a/R/ordgee.R b/R/ordgee.R
new file mode 100755
index 0000000..95695f3
--- /dev/null
+++ b/R/ordgee.R
@@ -0,0 +1,163 @@
+ordgee <- function(formula = formula(data), ooffset = NULL,
+ id, waves = NULL,
+ data=parent.frame, subset=NULL, na.action=na.omit,
+ contrasts=NULL, weights=NULL,
+ z=NULL, ##family=binomial(),
+ mean.link="logit",
+ corstr="independence",
+ control=geese.control(...),
+ b=NA, alpha=NA,
+ scale.fix=TRUE, scale.val=1,
+ int.const=TRUE, rev=FALSE, ##rev TRUE for coding in HZ 1996.
+ ...) {
+### y is sum(n_i) * c x 1
+### x is sum(n_i) * c x (p + c)
+ scall <- match.call()
+ mnames <- c("", "formula", "data", "offset", "weights", "subset", "id", "waves")
+ cnames <- names(scall)
+ cnames <- cnames[match(mnames,cnames,0)]
+ mcall <- scall[cnames]
+ if (is.null(mcall$id)) mcall$id <- as.name("id")
+ mcall[[1]] <- as.name("model.frame")
+ m <- eval(mcall, parent.frame())
+
+ id <- model.extract(m, "id")
+## N <- length(unique(id))
+ clusz <- unlist(lapply(split(id, id), length))
+ maxclsz <- max(clusz)
+ if (is.null(waves)) waves <- unlist(sapply(clusz, function(x) 1:x))
+ else waves <- model.extract(m, "waves")
+# if (is.na(b)){
+# foo <- polr(formula, data, ...)
+# b <- c(foo$zeta, foo$coef)
+# }
+
+ y <- model.extract(m, "response")
+ if (length(y) != length(id)) stop("response and id are not of the same length.")
+
+ if (class(y)[1] != 'ordered') stop("response is not an ordered factor.")
+ lev <- levels(y)
+
+ nlev <- length(lev)
+ ncat <- nlev - 1
+ y <- unclass(y)
+ Y <- rep(y, rep(ncat, sum(clusz)))
+ if (rev) Y <- as.double(Y <= rep(1:ncat, sum(clusz)))
+ else Y <- as.double(Y > rep(1:ncat, sum(clusz)))
+
+ mterms <- attr(m, "terms")
+ x <- model.matrix(mterms, m, contrasts)
+ xvars <- as.character(attr(mterms, "variables"))[-1]
+ if ((yvar <- attr(mterms, "response")) > 0)
+ xvars <- xvars[-yvar]
+ xlev <- if (length(xvars) > 0) {
+ xlev <- lapply(m[xvars], levels)
+ xlev[!sapply(xlev, is.null)]
+ }
+ xint <- match("(Intercept)", colnames(x), nomatch = 0)
+ n <- nrow(x)
+ pc <- ncol(x)
+ if (xint > 0) {
+ x <- x[, -xint, drop = FALSE]
+ pc <- pc - 1
+ }
+ else warning("an intercept is needed and assumed")
+ ind <- gl(sum(clusz), ncat)
+ x <- x[ind,, drop=FALSE]
+
+ if (int.const) {
+ xc <- matrix(diag(ncat), sum(clusz) * ncat, ncat, byrow=TRUE)
+ colnames(xc) <- paste("Inter", lev[1:ncat], sep=":")
+ }
+ else {
+ foo <- sapply(waves,
+ function(x, maxclsz, ncat) {
+ bar <- matrix(0, maxclsz*ncat, ncat)
+ bar[(x-1)*ncat + 1:ncat,] <- diag(ncat)
+ bar
+ }, maxclsz=maxclsz, ncat=ncat)
+ xc <- matrix(unlist(foo), ncol=maxclsz*ncat, byrow=TRUE)
+ colnames(xc) <- paste("Inter", paste(rep(1:maxclsz, rep(ncat, maxclsz)), rep(lev[1:ncat], maxclsz), sep=":"), sep=":")
+ ##b <- c(rep(b[1:ncat], maxclsz), b[-(1:ncat)])
+ }
+
+ xmat <- cbind(xc, x) # note the negate sign!!!
+ p <- ncol(xmat)
+
+ offset <- model.extract(m, "offset")
+ if (is.null(offset)) offset <- rep(0, length(id))
+ offset <- - rep(offset, rep(ncat, sum(clusz)))
+
+ w <- model.extract(m, "weights")
+ if (is.null(w)) w <- rep(1, length(id))
+ w <- rep(w, rep(ncat, sum(clusz)))
+
+ CORSTRS <- c("independence", "exchangeable", "NA_ar1", "unstructured", "userdefined")
+ CORSTRS.ALLOWED <- c("independence", "exchangeable", "unstructured", "userdefined")
+ corstrv <- pmatch(corstr, CORSTRS.ALLOWED, -1)
+ if (corstrv == -1) stop("invalid corstr.")
+ corstrv <- pmatch(corstr, CORSTRS)
+ corr <- list(as.integer(corstrv), maxclsz)
+
+ if (is.null(ooffset)) ooffset <- rep(0, sum(clusz*(clusz-1)/2) * ncat^2)
+ if (is.null(z)) {
+ if (corstrv == 5) stop("need z matrix for userdefined corstr.")
+ else z <- genZodds(clusz, waves, corstrv, ncat)
+ }
+
+ if (length(ooffset) != sum(clusz*(clusz-1)/2) * ncat^2)
+ stop("length(ooffset) != sum(clusz*(clusz-1)) * ncat^2 detected.")
+
+ if (corstrv > 1 && nrow(z) != sum(clusz*(clusz-1)/2) * ncat^2)
+ stop("nrow(z) != sum(clusz*(clusz-1)) * ncat^2 detected.")
+
+ waves <- rep(waves, rep(ncat, sum(clusz)))
+ if (is.null(id)) stop("ID variable not found.")
+
+ LINKS <- c("NA_identity", "logit", "probit", "cloglog", "NA_log", "NA_inverse", "NA_fisherz", "NA_lwybc2", "NA_lwylog")
+ LINKS.ALLOWED <- c("logit", "probit", "cloglog")
+ mean.link.v <- pmatch(mean.link, LINKS.ALLOWED, -1)
+ if (mean.link.v == -1) stop("mean.link invalid.")
+ mean.link.v <- pmatch(mean.link, LINKS, -1)
+
+ geestr <- list(maxwave=maxclsz,
+ mean.link=rep(mean.link.v, maxclsz),
+ variance=rep(2, maxclsz),
+ sca.link=rep(1, maxclsz),
+ cor.link=5,
+ scale.fix=as.integer(scale.fix))
+
+ p <- ncol(xmat)
+ q <- ncol(z)
+ if (!is.matrix(z)) z <- as.matrix(z)
+
+ if (is.na(b)) {
+ link <- mean.link
+ b <- glm.fit(xmat, Y, w, family=binomial(link))$coef
+ }
+ if (is.na(alpha)) alpha <- rep(0,q);
+ param <- list(b, alpha, gm=rep(scale.val, 1))
+
+
+ ans <- .Call("ordgee_rap", Y, xmat, offset, ooffset, w, waves, z,
+ clusz, ncat, rev, geestr, corr, param, control,
+ PACKAGE = "geepack")
+
+ names(ans) <- c("beta", "alpha", "gamma", "vbeta", "valpha", "vgamma",
+ "vbeta.naiv", "valpha.naiv", "valpha.stab",
+ "vbeta.ajs", "valpha.ajs", "vgamma.ajs",
+ "vbeta.j1s", "valpha.j1s", "vgamma.j1s",
+ "vbeta.fij", "valpha.fij", "vgamma.fij",
+ "error")
+ ans$xnames <- dimnames(xmat)[[2]]
+ ans$zcor.names <- dimnames(z)[[2]]
+ names(ans$beta) <- ans$xnames
+ names(ans$alpha) <- ans$zcor.names
+
+ ans <- c(ans, list(call=scall, clusz=clusz, control=control,
+ model=list(mean.link=mean.link,
+ variance="binomial", sca.link=NULL,
+ cor.link="log", corstr=corstr, scale.fix=scale.fix)))
+ class(ans) <- "geese"
+ ans
+}
diff --git a/R/rrr.R b/R/rrr.R
new file mode 100755
index 0000000..65140a0
--- /dev/null
+++ b/R/rrr.R
@@ -0,0 +1,56 @@
+## This is a wrapper function for relative risk regression
+## for binary data with log link using the copy method
+relRisk<- function(formula, id, waves = NULL,
+ data = parent.frame(), subset = NULL,
+ contrasts = NULL, na.action = na.omit,
+ corstr = "indep",
+ ncopy = 1000, control = geese.control(),
+ b = NULL, alpha = NULL) {
+
+ family <- binomial("log") ## fixed
+
+ scall <- match.call()
+ mnames <- c("", "formula", "data", "offset", "subset", "na.action", "id", "waves")
+ cnames <- names(scall)
+ cnames <- cnames[match(mnames,cnames,0)]
+ mcall <- scall[cnames]
+ if (is.null(mcall$id)) mcall$id <- as.name("id")
+ mcall[[1]] <- as.name("model.frame")
+ m <- eval(mcall, parent.frame())
+
+ y <- model.extract(m, "response")
+ if (is.null(dim(y))) N <- length(y) else N <- dim(y)[1]
+ mterms <- attr(m, "terms")
+ x <- model.matrix(mterms, m, contrasts)
+ offset <- model.extract(m, "offset")
+ if (is.null(offset)) offset <- rep(0, N)
+
+ w <- rep(1 - 1 / ncopy, N)
+ w.copy <- rep(1 / ncopy, N)
+
+ y.copy <- 1 - y
+ id <- model.extract(m, id)
+ waves <- model.extract(m, waves)
+
+ ## augmented data
+ Y <- c(y, y.copy)
+ W <- c(w, w.copy)
+ X <- rbind(x, x)
+ ID <- c(id, id + max(id))
+ Waves <- c(waves, waves)
+ Offset <- c(offset, offset)
+ Freq <- rep(c(2, 1), each = N)
+
+ ## get initial values
+ fit0 <- glm.fit(X, Y, offset = Offset, weights = Freq, family = family)
+ fit1 <- glm.fit(X, Y, offset = Offset, family = family, weights = W, start = fit0$coefficients)
+
+ ## feed geese
+ ans <- geese.fit(X, Y, ID, Offset, weights = W, waves = Waves,
+ family = family, control = control, corstr = corstr,
+ b = fit1$coefficients, scale.fix = TRUE)
+ ans <- c(ans, list(call=scall, formula=formula))
+ class(ans) <- "geese"
+ ans
+
+}
diff --git a/R/summary.R b/R/summary.R
new file mode 100755
index 0000000..e0c1793
--- /dev/null
+++ b/R/summary.R
@@ -0,0 +1,114 @@
+summary.geese <- function(object, ...) {
+ mean.sum <- data.frame(estimate = object$beta,
+# nai.se = sqrt(diag(object$vbeta.naiv)),
+ san.se = sqrt(diag(object$vbeta)),
+ ajs.se = sqrt(diag(object$vbeta.ajs)),
+ j1s.se = sqrt(diag(object$vbeta.j1s)),
+ fij.se = sqrt(diag(object$vbeta.fij)))
+ mean.sum$wald <- (mean.sum$estimate / mean.sum$san.se)^2
+ mean.sum$p <- 1 - pchisq(mean.sum$wald, df=1)
+ rownames(mean.sum) <- object$xnames
+
+ corr.sum <- data.frame(estimate = object$alpha,
+# nai.se = sqrt(diag(object$valpha.naiv)),
+ san.se = sqrt(diag(object$valpha)),
+ ajs.se = sqrt(diag(object$valpha.ajs)),
+ j1s.se = sqrt(diag(object$valpha.j1s)),
+ fij.se = sqrt(diag(object$valpha.fij)))
+ corr.sum$wald <- (corr.sum$estimate / corr.sum$san.se)^2
+ corr.sum$p <- 1 - pchisq(corr.sum$wald, df=1)
+ if (nrow(corr.sum) > 0) rownames(corr.sum) <- object$zcor.names
+
+ scale.sum <- data.frame(estimate = object$gamma,
+ san.se = sqrt(diag(object$vgamma)),
+ ajs.se = sqrt(diag(object$vgamma.ajs)),
+ j1s.se = sqrt(diag(object$vgamma.j1s)),
+ fij.se = sqrt(diag(object$vgamma.fij)))
+ scale.sum$wald <- (scale.sum$estimate / scale.sum$san.se)^2
+ scale.sum$p <- 1 - pchisq(scale.sum$wald, df=1)
+ if (!is.null(object$zsca.names)) rownames(scale.sum) <- object$zsca.names
+
+ drop <- ifelse(c(object$control$jack, object$control$j1s, object$control$fij)== 0, TRUE, FALSE)
+ if (any(drop)) {
+ drop <- (3:5)[drop]
+ mean.sum <- mean.sum[,-drop]
+ corr.sum <- corr.sum[,-drop]
+ scale.sum <- scale.sum[,-drop]
+ }
+
+ ans <- list(mean=mean.sum, correlation=corr.sum, scale=scale.sum,
+ call=object$call, model=object$model, control=object$control,
+ error=object$err, clusz=object$clusz)
+ class(ans) <- "summary.geese"
+ ans
+}
+
+print.geese <- function(x, digits = NULL, quote = FALSE, prefix = "", ...) {
+ if(is.null(digits)) digits <- options()$digits
+ else options(digits = digits)
+ cat("\nCall:\n")
+ dput(x$call)
+ cat("\nMean Model:\n")
+ cat(" Mean Link: ", x$model$mean.link, "\n")
+ cat(" Variance to Mean Relation:", x$model$variance, "\n")
+ cat("\n Coefficients:\n")
+ print(unclass(x$beta), digits = digits)
+
+ if (!x$model$scale.fix) {
+ cat("\nScale Model:\n")
+ cat(" Scale Link: ", x$model$sca.link, "\n")
+ cat("\n Estimated Scale Parameters:\n")
+ print(unclass(x$gamma), digits = digits)
+ }
+ else cat("\nScale is fixed.\n")
+ cat("\nCorrelation Model:\n")
+ cat(" Correlation Structure: ", x$model$corstr, "\n")
+ if (pmatch(x$model$corstr, c("independence", "fixed"), 0) == 0) {
+ cat(" Correlation Link: ", x$model$cor.link, "\n")
+ cat("\n Estimated Correlation Parameters:\n")
+ print(unclass(x$alpha), digits = digits)
+ }
+ ##cat("\nNumber of observations : ", x$nobs, "\n")
+ ##cat("\nMaximum cluster size : ", x$max.id, "\n")
+
+ cat("\nReturned Error Value: ")
+ cat(x$error, "\n")
+ cat("Number of clusters: ", length(x$clusz), " Maximum cluster size:", max(x$clusz), "\n\n")
+ invisible(x)
+}
+
+print.summary.geese <- function(x, digits = NULL,
+ quote = FALSE, prefix = "", ... ) {
+ if(is.null(digits)) digits <- options()$digits
+ else options(digits = digits)
+ cat("\nCall:\n")
+ dput(x$call)
+ cat("\nMean Model:\n")
+ cat(" Mean Link: ", x$model$mean.link, "\n")
+ cat(" Variance to Mean Relation:", x$model$variance, "\n")
+ cat("\n Coefficients:\n")
+ print(x$mean, digits = digits)
+
+ if (x$model$scale.fix == FALSE) {
+ cat("\nScale Model:\n")
+ cat(" Scale Link: ", x$model$sca.link, "\n")
+ cat("\n Estimated Scale Parameters:\n")
+ print(x$scale, digits = digits)
+ }
+ else cat("\nScale is fixed.\n")
+ cat("\nCorrelation Model:\n")
+ cat(" Correlation Structure: ", x$model$corstr, "\n")
+ if (pmatch(x$model$corstr, c("independence", "fixed"), 0) == 0) {
+ cat(" Correlation Link: ", x$model$cor.link, "\n")
+ cat("\n Estimated Correlation Parameters:\n")
+ print(x$corr, digits = digits)
+ }
+
+ ##cat("\nNumber of observations : ", x$nobs, "\n")
+ ##cat("\nMaximum cluster size : ", x$max.id, "\n")
+
+ cat("\nReturned Error Value: ")
+ cat(x$error, "\n")
+ cat("Number of clusters: ", length(x$clusz), " Maximum cluster size:", max(x$clusz), "\n\n")
+ invisible(x)
+}
diff --git a/R/zzz.R b/R/zzz.R
new file mode 100755
index 0000000..643b72c
--- /dev/null
+++ b/R/zzz.R
@@ -0,0 +1,3 @@
+## .First.lib <- function(lib, pkg) {
+## library.dynam("geepack", pkg, lib)
+## }
diff --git a/build/vignette.rds b/build/vignette.rds
new file mode 100644
index 0000000..3f24459
Binary files /dev/null and b/build/vignette.rds differ
diff --git a/data/dietox.txt.gz b/data/dietox.txt.gz
new file mode 100755
index 0000000..2aa2a58
Binary files /dev/null and b/data/dietox.txt.gz differ
diff --git a/data/koch.txt.gz b/data/koch.txt.gz
new file mode 100755
index 0000000..d9b9de5
Binary files /dev/null and b/data/koch.txt.gz differ
diff --git a/data/ohio.txt.gz b/data/ohio.txt.gz
new file mode 100755
index 0000000..1f43a71
Binary files /dev/null and b/data/ohio.txt.gz differ
diff --git a/data/respdis.txt.gz b/data/respdis.txt.gz
new file mode 100755
index 0000000..739ee0b
Binary files /dev/null and b/data/respdis.txt.gz differ
diff --git a/data/respiratory.txt.gz b/data/respiratory.txt.gz
new file mode 100755
index 0000000..7ddc8bd
Binary files /dev/null and b/data/respiratory.txt.gz differ
diff --git a/data/seizure.txt.gz b/data/seizure.txt.gz
new file mode 100755
index 0000000..acbf993
Binary files /dev/null and b/data/seizure.txt.gz differ
diff --git a/data/sitka89.txt.gz b/data/sitka89.txt.gz
new file mode 100755
index 0000000..a88582e
Binary files /dev/null and b/data/sitka89.txt.gz differ
diff --git a/data/spruce.txt.gz b/data/spruce.txt.gz
new file mode 100755
index 0000000..edf6850
Binary files /dev/null and b/data/spruce.txt.gz differ
diff --git a/inst/CITATION b/inst/CITATION
new file mode 100755
index 0000000..2d50b45
--- /dev/null
+++ b/inst/CITATION
@@ -0,0 +1,44 @@
+citHeader("To cite geepack in publications use:")
+
+citEntry(entry="Article",
+ title = "The R Package geepack for Generalized Estimating Equations",
+ author = personList(as.person("S�ren H�jsgaard"),
+ as.person("Ulrich Halekoh"),
+ as.person("Jun Yan")),
+ year = 2006,
+ journal = "Journal of Statistical Software",
+ volume = "15/2",
+ pages = "1--11",
+ textVersion =
+ paste("H�jsgaard, S., Halekoh, U. & Yan J. (2006)",
+ "The R Package geepack for Generalized Estimating Equations",
+ "Journal of Statistical Software, 15, 2, pp1--11")
+)
+
+
+citEntry(entry="Article",
+ title = "Estimating Equations for Association Structures",
+ author = personList(as.person("Jun Yan"),
+ as.person("Jason P. Fine")),
+ year = "2004",
+ journal = "Statistics in Medicine",
+ volume = "23",
+ pages = "859--880",
+ textVersion =
+ paste("Yan, J. & Fine, J.P. (2004)",
+ "Estimating Equations for Association Structures",
+ "Statistics in Medicine, 23, pp859--880.")
+)
+
+citEntry(entry="Article",
+ title = "geepack: Yet Another Package for Generalized Estimating Equations",
+ author = personList(as.person("Jun Yan")),
+ year = "2002",
+ journal = "R-News",
+ volume = "2/3",
+ pages = "12--14",
+ textVersion =
+ paste("Yan, J (2002)",
+ "geepack: Yet Another Package for Generalized Estimating Equations",
+ "R-News, 2/3, pp12-14.")
+)
diff --git a/inst/doc/geepack-manual.R b/inst/doc/geepack-manual.R
new file mode 100644
index 0000000..d99f7b6
--- /dev/null
+++ b/inst/doc/geepack-manual.R
@@ -0,0 +1,98 @@
+### R code from vignette source 'geepack-manual.Rnw'
+### Encoding: UTF-8
+
+###################################################
+### code chunk number 1: geepack-manual.Rnw:14-17
+###################################################
+require( geepack )
+prettyVersion <- packageDescription("geepack")$Version
+prettyDate <- format(Sys.Date())
+
+
+###################################################
+### code chunk number 2: geepack-manual.Rnw:55-57
+###################################################
+library(geepack)
+citation("geepack")
+
+
+###################################################
+### code chunk number 3: geepack-manual.Rnw:70-78
+###################################################
+library(geepack)
+timeorder <- rep(1:5, 6)
+tvar <- timeorder + rnorm(length(timeorder))
+idvar <- rep(1:6, each=5)
+uuu <- rep(rnorm(6), each=5)
+yvar <- 1 + 2*tvar + uuu + rnorm(length(tvar))
+simdat <- data.frame(idvar, timeorder, tvar, yvar)
+head(simdat,12)
+
+
+###################################################
+### code chunk number 4: geepack-manual.Rnw:87-89
+###################################################
+mod1 <- geeglm(yvar~tvar, id=idvar, data=simdat, corstr="ar1")
+mod1
+
+
+###################################################
+### code chunk number 5: geepack-manual.Rnw:107-113
+###################################################
+set.seed(123)
+## library(doBy)
+simdatPerm <- simdat[sample(nrow(simdat)),]
+## simdatPerm <- orderBy(~idvar, simdatPerm)
+simdatPerm <- simdatPerm[order(simdatPerm$idvar),]
+head(simdatPerm)
+
+
+###################################################
+### code chunk number 6: geepack-manual.Rnw:123-125
+###################################################
+mod2 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="ar1")
+mod2
+
+
+###################################################
+### code chunk number 7: geepack-manual.Rnw:132-135
+###################################################
+## simdatPerm2 <- orderBy(~timeorder, data=simdat)
+simdatPerm2 <- simdat[order(simdat$timeorder),]
+geeglm(yvar~tvar, id=idvar, data=simdatPerm2, corstr="ar1")
+
+
+###################################################
+### code chunk number 8: geepack-manual.Rnw:148-152
+###################################################
+wav <- simdatPerm$timeorder
+wav
+mod3 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="ar1", waves=wav)
+mod3
+
+
+###################################################
+### code chunk number 9: geepack-manual.Rnw:161-167
+###################################################
+cor.fixed <- matrix(c(1 , 0.5 , 0.25, 0.125, 0.125,
+ 0.5 , 1 , 0.25, 0.125, 0.125,
+ 0.25 , 0.25 , 1 , 0.5 , 0.125,
+ 0.125, 0.125, 0.5 , 1 , 0.125,
+ 0.125, 0.125, 0.125, 0.125, 1 ), 5, 5)
+cor.fixed
+
+
+###################################################
+### code chunk number 10: geepack-manual.Rnw:175-177
+###################################################
+zcor <- fixed2Zcor(cor.fixed, id=simdatPerm$idvar, waves=simdatPerm$timeorder)
+zcor
+
+
+###################################################
+### code chunk number 11: geepack-manual.Rnw:186-188
+###################################################
+mod4 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="fixed", zcor=zcor)
+mod4
+
+
diff --git a/inst/doc/geepack-manual.Rnw b/inst/doc/geepack-manual.Rnw
new file mode 100755
index 0000000..d8d88aa
--- /dev/null
+++ b/inst/doc/geepack-manual.Rnw
@@ -0,0 +1,196 @@
+% \VignetteIndexEntry{Users guide to geepack}
+% \VignetteKeyword{Generalized Estimating Equation}
+% \VignetteKeyword{Working correlation matrix}
+
+\documentclass{article}
+\usepackage{boxedminipage,color,a4,shortvrb,hyperref}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\MakeShortVerb|
+
+\def\pkg#1{{\bf #1}}
+
+
+<<echo=FALSE,print=FALSE>>=
+require( geepack )
+prettyVersion <- packageDescription("geepack")$Version
+prettyDate <- format(Sys.Date())
+@
+
+\SweaveOpts{keep.source=T,prefix.string=figures/LSmeans}
+
+\title{On the usage of the \texttt{geepack} }
+\author{S{\o}ren H{\o}jsgaard and Ulrich Halekoh}
+\date{\pkg{geepack} version \Sexpr{prettyVersion} as of \Sexpr{prettyDate}}
+
+
+\begin{document}
+
+\parindent0pt\parskip4pt
+
+%% Efter preamble
+\definecolor{myGray}{rgb}{0.95,0.95,0.95}
+\makeatletter
+\renewenvironment{Schunk}{
+ \begin{lrbox}{\@tempboxa}
+ \begin{boxedminipage}
+ {\columnwidth}\scriptsize}
+ {\end{boxedminipage}
+ \end{lrbox}%
+ \colorbox{myGray}{\usebox{\@tempboxa}}
+}
+\makeatother
+
+\maketitle
+
+\section{Introduction}
+\label{sec:intro}
+
+
+The primary reference for the |geepack| package is the Halekoh, U.,
+H�jsgaard, S., Yan, J. (2006) -- paper in Journal of Statistical
+Software, see
+
+@
+<<>>=
+library(geepack)
+citation("geepack")
+@ %def
+
+If you use |geepack| in your own work, please do cite the above
+reference.
+
+
+This note contains a few extra examples. We illustrate the usage of a
+the |waves| argument and the |zcor| argument together with a fixed
+working correlation matrix for the |geeglm()| function. To illustrate
+these features we simulate some data suitable for a regression model.
+
+@
+<<>>=
+library(geepack)
+timeorder <- rep(1:5, 6)
+tvar <- timeorder + rnorm(length(timeorder))
+idvar <- rep(1:6, each=5)
+uuu <- rep(rnorm(6), each=5)
+yvar <- 1 + 2*tvar + uuu + rnorm(length(tvar))
+simdat <- data.frame(idvar, timeorder, tvar, yvar)
+head(simdat,12)
+@ %def
+
+Notice that clusters of data appear together in |simdat| and that
+observations are ordered (according to |timeorder|) within clusters.
+
+We can fit a model with an AR(1) error structure as
+
+@
+<<>>=
+mod1 <- geeglm(yvar~tvar, id=idvar, data=simdat, corstr="ar1")
+mod1
+@ %def
+
+This works because observations are ordered according to time within
+each subject in the dataset.
+
+
+
+
+\section{Using the \texttt{waves} argument}
+\label{sec:xxx}
+
+
+If observatios were not ordered according to cluster and time within
+cluster we would get the
+wrong result:
+
+@
+<<>>=
+set.seed(123)
+## library(doBy)
+simdatPerm <- simdat[sample(nrow(simdat)),]
+## simdatPerm <- orderBy(~idvar, simdatPerm)
+simdatPerm <- simdatPerm[order(simdatPerm$idvar),]
+head(simdatPerm)
+@ %def
+
+Notice that in |simdatPerm| data is ordered according to subject but
+the time ordering within subject is random.
+
+Fitting the model as
+before gives
+
+@
+<<>>=
+mod2 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="ar1")
+mod2
+@ %def
+
+Likewise if clusters do not appear contigously in data we also get the
+wrong result (the clusters are not recognized):
+
+@
+<<>>=
+## simdatPerm2 <- orderBy(~timeorder, data=simdat)
+simdatPerm2 <- simdat[order(simdat$timeorder),]
+geeglm(yvar~tvar, id=idvar, data=simdatPerm2, corstr="ar1")
+@ %def
+
+
+
+
+
+
+
+
+To obtain the right result we must give the |waves| argument:
+
+@
+<<>>=
+wav <- simdatPerm$timeorder
+wav
+mod3 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="ar1", waves=wav)
+mod3
+@ %def
+
+\section{Using a fixed correlation matrix and the \texttt{zcor} argument}
+\label{sec:xxx}
+
+Suppose we want to use a fixed working correlation matrix:
+
+@
+<<>>=
+cor.fixed <- matrix(c(1 , 0.5 , 0.25, 0.125, 0.125,
+ 0.5 , 1 , 0.25, 0.125, 0.125,
+ 0.25 , 0.25 , 1 , 0.5 , 0.125,
+ 0.125, 0.125, 0.5 , 1 , 0.125,
+ 0.125, 0.125, 0.125, 0.125, 1 ), 5, 5)
+cor.fixed
+@ %def
+
+Such a working correlation matrix has to be passed to |geeglm()| as a
+vector in the |zcor| argument. This vector can be created using the
+|fixed2Zcor()| function:
+
+@
+<<>>=
+zcor <- fixed2Zcor(cor.fixed, id=simdatPerm$idvar, waves=simdatPerm$timeorder)
+zcor
+@ %def
+
+Notice that |zcor| contains correlations between measurements within
+the same cluster. Hence if a cluster contains only one observation,
+then there will be generated no entry in |zcor| for that cluster. Now
+we can fit the model with:
+
+@
+<<>>=
+mod4 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="fixed", zcor=zcor)
+mod4
+@ %def
+
+
+
+
+
+
+\end{document}
diff --git a/inst/doc/geepack-manual.pdf b/inst/doc/geepack-manual.pdf
new file mode 100644
index 0000000..4463ca7
Binary files /dev/null and b/inst/doc/geepack-manual.pdf differ
diff --git a/inst/include/famstr.h b/inst/include/famstr.h
new file mode 100755
index 0000000..e2a15a4
--- /dev/null
+++ b/inst/include/famstr.h
@@ -0,0 +1,141 @@
+#ifndef FAMSTR_H
+#define FAMSTR_H
+
+#include "tntsupp.h"
+#include "geese.h"
+
+typedef double fun1(double);
+typedef bool fun2(double);
+
+enum links {L_0, IDENT, LOGIT, PROBIT, CLOGLOG, LOG, INVERSE, FISHERZ,
+ LWYBC2, LWYLOG};
+enum variances {V_0, GAUSSIAN, BINOMIAL, POISSON, GAMMA};
+enum correlations {C_0, INDEPENDENCE, EXCHANGEABLE, AR1, UNSTRUCTURED, USERDEFINED, FIXED};
+
+
+DMatrix cor_exch(const DVector &rho, const DVector &wave);
+
+DMatrix cor_rho_exch(const DVector &rho, const DVector &wave);
+
+DMatrix cor_indep(const DVector &, const DVector &wave);
+
+DMatrix cor_rho_indep(const DVector &, const DVector &);
+
+DMatrix cor_ar1(const DVector &rho, const DVector &wave);
+
+DMatrix cor_rho_ar1(const DVector &rho, const DVector &wave);
+
+DMatrix cor_unstr(const DVector &rho, const DVector &wave);
+
+DMatrix cor_rho_unstr(const DVector &rho, const DVector &wave);
+
+DMatrix cor_fixed(const DVector &, const DVector &wave); //get cor matrix
+
+DMatrix cor_rho_fixed(const DVector &, const DVector &); //derivative
+
+class Corr{
+public:
+ typedef DMatrix matfun(const DVector &, const DVector&);
+ typedef DMatrix cor_rho_fun(const DVector &, const DVector&);
+protected:
+ int _corst, _nparam, _maxwave;
+ matfun *_mat;
+ cor_rho_fun *_cor_rho;
+ void init(matfun *mat, cor_rho_fun *cor_rho) {
+ _mat = mat; _cor_rho = cor_rho;
+ }
+public:
+ Corr(int corst, int maxwave);
+ ~Corr() {}
+ DMatrix mat(DVector &rho, DVector &wave) {
+ return _mat(rho, wave);
+ }
+ DMatrix cor_rho(DVector &rho, DVector &wave) {
+ return _cor_rho(rho, wave);
+ }
+ int nparam(){return _nparam;}
+ int corst() {return _corst; }
+};
+
+class Link{
+protected:
+ fun1 *_linkfun, *_linkinv, *_mu_eta;
+ void init(fun1* linkfun, fun1* linkinv, fun1* mu_eta) {
+ _linkfun = linkfun; _linkinv = linkinv; _mu_eta = mu_eta;
+ }
+public:
+ //Link(int link);
+ //Link() {int link = IDENT; Link(link); }
+ Link(int link = IDENT);
+ Link(fun1* linkfun, fun1* linkinv, fun1* mu_eta);
+ ~Link() {}
+ double linkfun(double mu) {return _linkfun(mu);}
+ double linkinv(double eta) {return _linkinv(eta);}
+ double mu_eta(double eta) {return _mu_eta(eta);}
+};
+
+class Variance{
+protected:
+ fun1 *_v, *_v_mu;
+ fun2 *_validmu;
+ void init(fun1* v, fun1* v_mu, fun2 validmu) {
+ _v = v; _v_mu = v_mu; _validmu = validmu;
+ }
+public:
+ Variance(fun1* v, fun1* v_mu, fun2* validmu) {
+ init(v, v_mu, validmu);
+ }
+ //Variance(int var);
+ //Variance() {int var = GAUSSIAN; Variance(var);}
+ Variance(int var = GAUSSIAN);
+ ~Variance() {}
+ double v(double mu) {return _v(mu);}
+ double v_mu(double mu) {return _v_mu(mu);}
+ bool validmu(double mu) {return _validmu(mu);}
+};
+
+/*
+static Link Ident(1), Logit(2), Probit(3), Cloglog(4), Log(5), Inverse(6), Fisherz(7);
+static Variance Gaussian(1), Binomial(2), Poisson(3), Gamma(4);
+
+static Link LINK[] = {Ident, Logit, Probit, Cloglog, Log, Inverse, Fisherz};
+static Variance VARIANCE[] = {Gaussian, Binomial, Poisson, Gamma};
+*/
+
+
+class GeeStr{
+ Vector<Link> MeanLink;
+ Vector<Variance> V;
+ Vector<Link> ScaleLink;
+ Link CorrLink;
+ int ScaleFix_;
+public:
+ GeeStr(int n, Vector<int> meanlink, Vector<int> v,
+ Vector<int> scalelink, int corrlink, int scalefix);
+ ~GeeStr() {}
+ int ScaleFix() {return ScaleFix_;}
+ double MeanLinkfun(double mu, int wave) {
+ return MeanLink(wave).linkfun(mu);
+ }
+ double MeanLinkinv(double eta, int wave) {
+ return MeanLink(wave).linkinv(eta);
+ }
+ double MeanMu_Eta(double eta, int wave) {
+ return MeanLink(wave).mu_eta(eta);
+ }
+ DVector MeanLinkfun(const DVector &Mu, const IVector &Wave);
+ DVector MeanLinkinv(const DVector &Eta, const IVector &Wave);
+ DVector MeanMu_eta(const DVector &Eta, const IVector &Wave);
+ DVector ScaleLinkfun(const DVector &Mu, const IVector &Wave);
+ DVector ScaleLinkinv(const DVector &Eta, const IVector &Wave);
+ DVector ScaleMu_eta(const DVector &Eta, const IVector &Wave);
+ DVector CorrLinkfun(const DVector &Mu);
+ DVector CorrLinkinv(const DVector &Eta);
+ DVector CorrMu_eta(const DVector &Eta);
+ DVector v(const DVector &Mu, const IVector &Wave);
+ DVector v_mu(const DVector &Mu, const IVector &Wave);
+ bool validMu(const DVector &Mu, const IVector &Wave);
+};
+
+
+#endif //FAMSTR_H
diff --git a/inst/include/gee2.h b/inst/include/gee2.h
new file mode 100755
index 0000000..f7f2c83
--- /dev/null
+++ b/inst/include/gee2.h
@@ -0,0 +1,82 @@
+#ifndef GEE2_H
+#define GEE2_H
+
+#include "tntsupp.h"
+#include "geese.h"
+
+extern "C"{
+#include <R.h>
+#include <Rmath.h>
+#include <Rdefines.h>
+}
+
+#include "famstr.h"
+#include "param.h"
+#include "inter.h"
+#include "utils.h"
+#include "geesubs.h"
+
+IVector comp_lev(GeeStr &geestr, Corr &cor);
+
+void gee_var(DVector &Y, DMatrix &X,
+ DVector &Offset, DVector &Doffset, DVector &W,
+ IVector &LinkWave,
+ DMatrix &Zsca, DMatrix &Zcor, DVector &CorP,
+ IVector &Clusz, IVector &ZcorSize,
+ GeeStr &geestr, Corr &cor, GeeParam &par, Control &con);
+
+double update_beta(DVector &Y, DMatrix &X, DVector &Offset, DVector &W,
+ IVector &LinkWave, DVector &CorP,
+ DMatrix &Zcor, IVector &Clusz,
+ IVector &ZcorSize, IVector &Jack,
+ GeeParam &par, GeeStr &geestr, Corr &cor);
+
+double update_gamma(DVector &PR, DVector &W, IVector &LinkWave,
+ IVector &Clusz, IVector &Jack,
+ DVector &Doffset, DMatrix &Zsca,
+ GeeParam &par, GeeStr &geestr);
+
+double update_alpha(DVector &PR, DVector &Phi, DVector &CorP, DVector &W,
+ IVector &Clusz, IVector &ZcorSize, IVector &Jack,
+ DMatrix &Zcor,
+ GeeParam &par, GeeStr &geestr, Corr &cor);
+
+void gee_est(DVector &Y, DMatrix &X,
+ DVector &Offset, DVector &Doffset, DVector &W,
+ IVector &LinkWave,
+ DMatrix &Zsca, DMatrix &Zcor, DVector &CorP,
+ IVector &Clusz, IVector &ZcorSize,
+ GeeStr &geestr, Corr &cor, GeeParam &par,
+ IVector &Jack, Control &con);
+
+void getJackVar(Vector<DVector> &beta_i, Vector<DVector> &alpha_i,
+ Vector<DVector> &gamma_i, GeeParam &par,
+ int jack);
+
+void gee_jack(DVector &Y, DMatrix &Xmat, DVector &Offset, DVector &Doffset,
+ DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor,
+ DVector &CorP, IVector &Clusz, IVector &ZcorSize,
+ GeeStr &geestr, Corr &cor,
+ GeeParam &par, Control &con);
+
+void jack_ajs(DVector &Y, DMatrix &X, DVector &Offset, DVector &Doffset,
+ DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor,
+ DVector &CorP, IVector &Clusz, IVector &ZcorSize,
+ GeeStr &geestr, Corr &cor,
+ GeeParam &par, Control &con);
+
+void gee_top(DVector &Y, DMatrix &Xmat,
+ DVector &Offset, DVector &Doffset, DVector &W,
+ IVector &LinkWave,
+ DMatrix &Zsca, DMatrix &Zcor, DVector &CorP,
+ IVector &Clusz,
+ GeeStr &geestr, Corr &cor, GeeParam &par,
+ Control &con);
+
+extern "C" {
+ SEXP gee_rap(SEXP y, SEXP x, SEXP offset, SEXP doffset, SEXP w,
+ SEXP linkwave, SEXP zsca, SEXP zcor, SEXP corp,
+ SEXP clusz, SEXP geestr, SEXP cor, SEXP par, SEXP con);
+}
+
+#endif //GEE2_H
diff --git a/inst/include/geese.h b/inst/include/geese.h
new file mode 100755
index 0000000..6bf43ad
--- /dev/null
+++ b/inst/include/geese.h
@@ -0,0 +1,8 @@
+#ifndef GEESE_H
+#define GEESE_H
+
+using namespace std;
+using namespace TNT;
+
+
+#endif //GEESE_H
diff --git a/inst/include/geesubs.h b/inst/include/geesubs.h
new file mode 100755
index 0000000..28e80ae
--- /dev/null
+++ b/inst/include/geesubs.h
@@ -0,0 +1,251 @@
+#ifndef GEESUBS_H
+#define GEESUBS_H
+
+#include "tntsupp.h"
+#include "geese.h"
+#include "famstr.h"
+#include "param.h"
+//#include "lgtdl.h"
+
+class Grad{
+protected:
+ DVector U1_, U2_, U3_;
+public:
+ Grad(int p, int r, int q) {
+ DVector U1(p), U2(r), U3(q);
+ U1_ = U1; U2_ = U2; U3_ = U3;
+ }
+ Grad(GeeParam &par) {
+ int p = par.p(), q = par.q(), r = par.r();
+ DVector U1(p), U2(r), U3(q);
+ U1_ = U1; U2_ = U2; U3_ = U3;
+ }
+ Grad() {
+ Grad(0, 0, 0);
+ }
+ ~Grad() {}
+ Grad & operator=(const Grad &G);
+ void set_U1(const DVector &u) {U1_ = u;}
+ void set_U2(const DVector &u) {U2_ = u;}
+ void set_U3(const DVector &u) {U3_ = u;}
+ DVector U1() const {return U1_;}
+ DVector U2() const {return U2_;}
+ DVector U3() const {return U3_;}
+ friend ostream& operator<<(ostream&, const Grad&);
+};
+
+class Hess{
+protected:
+ DMatrix A_, B_, C_, D_, E_, F_;
+public:
+ Hess(DMatrix &A, DMatrix &B, DMatrix &C,
+ DMatrix &D, DMatrix &E, DMatrix &F)
+ : A_(A), B_(B), C_(C), D_(D), E_(E), F_(F) {}
+ Hess(int p, int r, int q) {
+ DMatrix A(p,p), B(r,p), C(r,r), D(q,p), E(q,r), F(q,q);
+ A_ = A; B_ = B; C_ = C; D_ = D; E_ = E; F_ = F;
+ }
+ Hess(GeeParam &par) {
+ int p = par.p(), q = par.q(), r = par.r();
+ DMatrix A(p,p), B(r,p), C(r,r), D(q,p), E(q,r), F(q,q);
+ A_ = A; B_ = B; C_ = C; D_ = D; E_ = E; F_ = F;
+ }
+ Hess(const Hess &H):
+ A_(H.A()), B_(H.B()), C_(H.C()),
+ D_(H.D()), E_(H.E()), F_(H.F()) {
+ //A_ = H.A(); B_ = H.B(); C_ = H.C();
+ //D_ = H.D(); E_ = H.E(); F_ = H.F();
+ }
+ Hess() {
+ Hess(0, 0, 0);
+ }
+ ~Hess() {}
+ DMatrix A() const {return A_;}
+ DMatrix B() const {return B_;}
+ DMatrix C() const {return C_;}
+ DMatrix D() const {return D_;}
+ DMatrix E() const {return E_;}
+ DMatrix F() const {return F_;}
+ void set_A(const DMatrix &a) {A_ = a;}
+ void set_B(const DMatrix &b) {B_ = b;}
+ void set_C(const DMatrix &c) {C_ = c;}
+ void set_D(const DMatrix &d) {D_ = d;}
+ void set_E(const DMatrix &e) {E_ = e;}
+ void set_F(const DMatrix &f) {F_ = f;}
+ void inc_A(const DMatrix &a) {A_ = A_ + a;}
+ void inc_B(const DMatrix &b) {B_ = B_ + b;}
+ void inc_C(const DMatrix &c) {C_ = C_ + c;}
+ void inc_D(const DMatrix &d) {D_ = D_ + d;}
+ void inc_E(const DMatrix &e) {E_ = E_ + e;}
+ void inc_F(const DMatrix &f) {F_ = F_ + f;}
+ void inc(Hess &H) {
+ inc_A(H.A()); inc_B(H.B()); inc_C(H.C());
+ inc_D(H.D()); inc_E(H.E()); inc_F(H.F());
+ }
+ void dec_A(const DMatrix &a) {A_ = A_ - a;}
+ void dec_B(const DMatrix &b) {B_ = B_ - b;}
+ void dec_C(const DMatrix &c) {C_ = C_ - c;}
+ void dec_D(const DMatrix &d) {D_ = D_ - d;}
+ void dec_E(const DMatrix &e) {E_ = E_ - e;}
+ void dec_F(const DMatrix &f) {F_ = F_ - f;}
+ void dec(Hess &H) {
+ dec_A(H.A()); dec_B(H.B()); dec_C(H.C());
+ dec_D(H.D()); dec_E(H.E()); dec_F(H.F());
+ }
+ Hess& operator=(const Hess &H) {
+ A_ = H.A(); B_ = H.B(); C_ = H.C();
+ D_ = H.D(); E_ = H.E(); F_ = H.F();
+ return *this;
+ }
+ friend ostream& operator<<(ostream&, const Hess&);
+};
+
+Hess operator-(Hess &H1, Hess &H2);
+
+Hess inv(Hess &H, IVector &level);
+
+Hess operator*(const double &x, const Hess &H);
+
+ostream& operator<<(ostream& s, const Hess &H);
+
+DVector genzi(const DVector &PR);
+
+DVector utri(const DMatrix &R);
+
+DMatrix getZ_Beta(DMatrix &D, DVector &PR,
+ DVector &V, DVector &V_Mu, DVector &z);
+
+DMatrix getZ_Gamma(DMatrix &D, DVector &PR, DVector &Phi, DVector &z);
+
+DMatrix getS_Beta(DMatrix &D, DVector &PR, DVector &V, DVector &V_Mu);
+
+void HiandGi(DVector &PRi, DVector &Phii, DMatrix &Di, DMatrix &R,
+ DVector &Vi, DVector &V_Mui, DMatrix &D2i, DMatrix &E,
+ DVector &Wi, IVector &level,
+ //output
+ Hess &H, Grad &G);
+
+void PRandD(DVector &Y, DMatrix &X, DVector &Offset,
+ Index1D &I, IVector &LinkWave,
+ GeeParam &par, GeeStr &geestr,
+ DVector &PRi, DMatrix &Di);
+
+void gee_prep(DVector &Y, DMatrix &X, DVector &Offset,
+ Index1D &I, IVector &LinkWave,
+ GeeParam &par, GeeStr &geestr,
+ DVector &PRi, DMatrix &Di, DVector &Vi, DVector &V_Mui);
+
+DMatrix getR(DMatrix &Zmat, Index1D &I, Index1D &J, DVector &CorP,
+ GeeParam &par, GeeStr &geestr, Corr &cor);
+
+int RandE(DMatrix &Zmat, Index1D &I, Index1D &J, DVector &CorP,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ DMatrix &R, DMatrix &E);
+
+void gm_prep(DVector &PR, Index1D &I, IVector &LinkWave,
+ DVector &Doffset, DMatrix &Zsca, GeeParam &par, GeeStr &geestr,
+ DVector &Phii, DVector &Si, DMatrix &D2i);
+
+void PhiandD2(Index1D &I, IVector &LinkWave,
+ DVector &Doffset, DMatrix &Zsca, GeeParam &par, GeeStr &geestr,
+ DVector &Phii, DMatrix &D2i);
+
+DVector getPR(DVector &Y, DMatrix &X, DVector &Offset, IVector &LinkWave,
+ GeeParam &par, GeeStr &geestr);
+
+DVector getPhi(DVector &Doffset, DMatrix &Zsca, IVector &LinkWave,
+ GeeParam &par, GeeStr &geestr);
+
+void HnandGis(DVector &Ycur, DMatrix &X,
+ DVector &Offset, DVector &Doffset, DVector &W,
+ IVector &LinkWave, IVector &Clusz, IVector &ZcorSize,
+ DMatrix &Zsca, DMatrix &Zcor, DVector &CorP,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ IVector &Scur, IVector &level,
+ //output
+ Hess &H, Vector<Grad> &Gis);
+void HisandGis(DVector &Ycur, DMatrix &X,
+ DVector &Offset, DVector &Doffset, DVector &W,
+ IVector &LinkWave, IVector &Clusz, IVector &ZcorSize,
+ DMatrix &Zsca, DMatrix &Zcor, DVector &CorP,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ IVector &Scur, IVector &level,
+ //output
+ Vector<Hess> &His, Vector<Grad> &Gis);
+/*
+DVector interpprev(double t, Vector<DVector> &VV, DVector &tis);
+double interpprev(double t, DVector &v, DVector &tis);
+DVector getY(double t, DVector &Yall);
+IVector getS(double t, DVector &S);
+
+void AandCis(Vector<Lgtdl> &Yall, DMatrix &X,
+ Vector<DVector> &Offset, Vector<DVector> &Doffset,
+ Vector<DVector> &Weight,
+ IVector &LinkWave,
+ IVector &Clusz, IVector &ZcorSize,
+ DMatrix &Zsca, DMatrix &Zcor, DVector &CorP,
+ Vector<DVector> &Beta,
+ Vector<DVector> &Gamma,
+ Vector<DVector> &Alpha,
+ DVector &W, DVector &S, DVector &Tis, DVector &Tlim,
+ int l, DVector &Ita,
+ GeeStr &geestr, Corr &cor,
+ int ndivs, int fgconf,
+ //output:
+ DMatrix &A, Vector<DVector> &Cis);
+*/
+
+
+/*
+This fix was suggested by
+Jeffrey Horner <jeffrey.horner at vanderbilt.edu>
+and Cole Beck <cole.beck at vanderbilt.edu>.
+Cole Beck's email on Jan. 4, 2012 explains why:
+
+I believe the function definition for the template function "Valid" (see geesubs.cc) should actually be in the header file. Taken from http://www.cplusplus.com/doc/tutorial/templates/:
+
+Because templates are compiled when required, this forces a restriction for multi-file projects: the implementation (definition) of a template class or function must be in the same file as its declaration. That means that we cannot separate the interface in a separate header file, and that we must include both interface and implementation in any file that uses the templates.
+*/
+
+//get the valid components in X by valid indicator VI
+template<class T>
+Vector<T> Valid(Vector<T> &X, IVector &VI) {
+ int l = sum(VI), k = 1;
+ Vector<T> ans(l);
+ for (int i = 1; i <= VI.dim(); i++) {
+ if (VI(i) == 1) ans(k++) = X(i);
+ }
+ return ans;
+}
+
+template<class T>
+Fortran_Matrix<T> Valid(Fortran_Matrix<T> &X, IVector &VI) {
+ int l = sum(VI), k = 1, nc = X.num_cols();
+ Fortran_Matrix<T> ans(l, nc);
+ for (int i = 1; i <= VI.dim(); i++) {
+ if (VI(i) == 1) {
+ for (int j = 1; j <= nc; j++) ans(k, j) = X(i, j);
+ k++;
+ }
+ }
+ return ans;
+}
+
+IVector genVI(IVector &Si, int c = 1);
+
+IVector genCrossVI(IVector &Si, int c = 1);
+
+void getDatI(DVector &Y, DVector &Offset, DVector &Doffset,
+ DVector &W, DVector &CorP,
+ DMatrix &X, DMatrix &Zsca, DMatrix &Zcor,
+ IVector &LinkWave,
+ //extract indicator
+ Index1D &I, Index1D &J, IVector Scuri,
+ Corr &cor,
+ //output
+ DVector &VYi, DVector &VOffseti, DVector &VDoffseti,
+ DVector &VWi, DVector &VCorPi,
+ DMatrix &VXi, DMatrix &VZscai, DMatrix &VZcori,
+ IVector &VLinkWavei);
+
+#endif //GEESUBS_H
diff --git a/inst/include/inter.h b/inst/include/inter.h
new file mode 100755
index 0000000..b44d711
--- /dev/null
+++ b/inst/include/inter.h
@@ -0,0 +1,42 @@
+#ifndef INTER_H
+#define INTER_H
+
+extern "C" {
+#include <R.h>
+#include <Rdefines.h>
+}
+
+#include "tntsupp.h"
+#include "geese.h"
+#include "famstr.h"
+#include "param.h"
+#include "geesubs.h"
+
+DMatrix asDMatrix(SEXP a);
+
+DVector asDVector(SEXP a);
+
+IVector asIVector(SEXP a);
+
+Vector<DVector> asVDVector(SEXP a);
+
+SEXP asSEXP(const DMatrix &a);
+
+SEXP asSEXP(const DVector &a);
+
+SEXP asSEXP(const IVector &a);
+
+SEXP asSEXP(const Vector<DVector> &a);
+
+
+Control asControl(SEXP con);
+
+GeeParam asGeeParam(SEXP par);
+
+GeeStr asGeeStr(SEXP geestr);
+
+Corr asCorr(SEXP cor);
+
+SEXP asSEXP(GeeParam &Par);
+
+#endif //INTER_H
diff --git a/inst/include/ordgee.h b/inst/include/ordgee.h
new file mode 100755
index 0000000..5e0cfad
--- /dev/null
+++ b/inst/include/ordgee.h
@@ -0,0 +1,113 @@
+#ifndef ORDGEE_H
+#define ORDGEE_H
+
+//#include "tnt/region1d.h"
+#include "tntsupp.h"
+#include "geese.h"
+
+extern "C"{
+#include <R.h>
+#include <Rmath.h>
+#include <Rdefines.h>
+}
+
+#include "famstr.h"
+#include "param.h"
+#include "inter.h"
+#include "utils.h"
+#include "geesubs.h"
+
+double odds2p11(double psi, double mu1, double mu2);
+
+DMatrix odds2p11(DVector &Psi, DVector &Mu1, DVector &Mu2);
+
+double p11_odds(double psi, double mu1, double mu2);
+
+DVector p11_mu(double psi, double mu1, double mu2);
+
+DVector p11_odds(DVector &Psi, DVector &Mu1, DVector &Mu2);
+
+DMatrix Vijj(DVector &Mu, bool rev);
+
+DMatrix Vijk(DVector &Mu1, DVector &Mu2, DVector &Psi);
+
+DMatrix getU3_Beta(DVector &Mu1, DVector &Mu2, DVector &Psi,
+ DMatrix &D1, DMatrix &D2,
+ DVector &PR1, DVector &PR2);
+
+DMatrix ord2V1(DVector &Mu, DVector &Psi, int clusz, bool rev);
+DMatrix Mu2V1(DVector &Mu, int clusz, bool rev);
+
+void ord_prep_beta(DVector &Y, DMatrix &X, DVector &Offset,
+ DMatrix &Z, DVector &Ooffset,
+ Index1D &I, Index1D &J,
+ int clusz, int c, bool rev,
+ IVector &LinkWave,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ //output
+ DMatrix &Di, DVector &PRi, DMatrix &Vi);
+
+double update_beta(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset,
+ DVector &W, IVector &LinkWave, //DVector &CorP,
+ DMatrix &Z, IVector &Clusz, int c, bool rev,
+ //IVector &ZcorSize, IVector &Jack,
+ GeeParam &par, GeeStr &geestr, Corr &cor);
+
+DVector kronecker(const DVector &v1, const DVector &v2);
+
+DVector vec(const DMatrix &m);
+
+DMatrix ESSTijk(DVector &Mu1, DVector &Mu2, DMatrix &P11,
+ int c1, int c3, bool rev);
+
+DMatrix ESST(DVector &Mu1, DVector &Mu2, DMatrix &P11, bool rev);
+
+void ord_prep_alpha(DVector &PR1, DVector &PR2, //DMatrix &V,
+ DVector &Mu1, DVector &Mu2,
+ //c^2 x 1 c x 1 c x 1
+ DMatrix &Z, DVector &Ooffset,
+ bool rev, GeeParam &par, GeeStr &geestr,
+ //output
+ DVector &U2, DMatrix &V2, DMatrix &D2);
+
+double update_alpha(DVector &PR, DVector &Mu, DVector &W,
+ DMatrix &Z, DVector &Ooffset,
+ IVector &Clusz, int c, bool rev,
+ GeeParam &par, GeeStr &geestr, Corr &cor);
+
+void ordgee_est(DVector &Y, DMatrix &X,
+ DVector &Offset, DVector &Ooffset, DVector &W,
+ IVector &LinkWave,
+ DMatrix &Z, IVector &Clusz, int c, bool rev,
+ GeeStr &geestr, Corr &cor, GeeParam &par,
+ Control &con);
+
+void HiandGi(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset,
+ IVector &LinkWave,
+ DMatrix &Z, int s1, int c, bool rev,
+ Index1D &I, Index1D &J,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ //output
+ Hess &Hi, Grad &Gi);
+
+void HnandGis(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset,
+ IVector &LinkWave, DMatrix &Z,
+ IVector &Clusz, int c, bool rev,
+ GeeParam &par, GeeStr &geestr, Corr &cor, IVector &Scur,
+ Hess &Hn, Vector<Grad> &Gis);
+
+void HnandGis(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset,
+ IVector &LinkWave, DMatrix &Z,
+ IVector &Clusz, int c, bool rev,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ Hess &Hn, Vector<Grad> &Gis);
+
+
+extern "C" {
+ SEXP ordgee_rap(SEXP y, SEXP x, SEXP offset, SEXP doffset, SEXP w,
+ SEXP linkwave, SEXP z, SEXP clusz, SEXP ncat, SEXP rev,
+ SEXP geestr, SEXP cor, SEXP par, SEXP con);
+}
+
+
+#endif //ORDGEE_H
diff --git a/inst/include/param.h b/inst/include/param.h
new file mode 100755
index 0000000..7e516a3
--- /dev/null
+++ b/inst/include/param.h
@@ -0,0 +1,108 @@
+#ifndef PARAM_H
+#define PARAM_H
+
+#include "tntsupp.h"
+#include "geese.h"
+
+class Control{
+protected:
+ int _trace;
+ int _ajs;
+ int _j1s;
+ int _fij;
+ int _maxiter;
+ double _tol;
+
+public:
+ Control(int trace, int ajs, int j1s, int fij, int maxiter, double tol);
+ Control(int *con, double tol);
+ Control(const Control &C);
+ int trace() const {return _trace;}
+ int ajs() const {return _ajs;}
+ int j1s() const {return _j1s;}
+ int fij() const {return _fij;}
+ int maxiter() const {return _maxiter;}
+ double tol() const {return _tol;}
+ void set_maxiter(int mit) {_maxiter = mit;}
+};
+
+class GeeParam{
+protected:
+ DVector _beta;
+ DVector _alpha;
+ DVector _gamma;
+ DMatrix _vbeta;
+ DMatrix _vbeta_naiv;
+ DMatrix _vbeta_ajs;
+ DMatrix _vbeta_j1s;
+ DMatrix _vbeta_fij;
+ DMatrix _valpha;
+ DMatrix _valpha_stab;
+ DMatrix _valpha_naiv;
+ DMatrix _valpha_ajs;
+ DMatrix _valpha_j1s;
+ DMatrix _valpha_fij;
+ DMatrix _vgamma;
+ DMatrix _vgamma_ajs;
+ DMatrix _vgamma_j1s;
+ DMatrix _vgamma_fij;
+ //int _ScaleFix;
+ int _err;
+public:
+ GeeParam(DVector Beta, DVector Alpha, DVector Gamma);
+ GeeParam(DVector Beta, DVector Alpha, DVector Gamma,
+ DMatrix VBeta, DMatrix VBeta_naiv,
+ DMatrix VBeta_ajs, DMatrix VBeta_j1s,
+ DMatrix VBeta_fij,
+ DMatrix VAlpha, DMatrix VAlpha_stab,
+ DMatrix VAlpha_naiv, DMatrix VAlpha_ajs,
+ DMatrix VAlpha_j1s, DMatrix VAlpha_fij,
+ DMatrix VGamma, DMatrix VGamma_ajs,
+ DMatrix VGamma_j1s, DMatrix VGamma_fij);
+ ~GeeParam() {}
+ void set_beta(const DVector &v) {_beta = v;}
+ void set_alpha(const DVector &v) {_alpha = v;}
+ void set_vbeta(const DMatrix &m) {_vbeta = m;}
+ void set_vbeta_naiv(const DMatrix &m) {_vbeta_naiv = m;}
+ void set_vbeta_ajs(const DMatrix &m) {_vbeta_ajs = m;}
+ void set_vbeta_j1s(const DMatrix &m) {_vbeta_j1s = m;}
+ void set_vbeta_fij(const DMatrix &m) {_vbeta_fij = m;}
+ void set_valpha(const DMatrix &m) {_valpha = m;}
+ void set_valpha_stab(const DMatrix &m) {_valpha_stab = m;}
+ void set_valpha_naiv(const DMatrix &m) {_valpha_naiv = m;}
+ void set_valpha_ajs(const DMatrix &m) {_valpha_ajs = m;}
+ void set_valpha_j1s(const DMatrix &m) {_valpha_j1s = m;}
+ void set_valpha_fij(const DMatrix &m) {_valpha_fij = m;}
+ void set_gamma(const DVector &v) {_gamma = v;}
+ void set_vgamma(const DMatrix &m) {_vgamma = m;}
+ void set_vgamma_ajs(const DMatrix &m) {_vgamma_ajs = m;}
+ void set_vgamma_j1s(const DMatrix &m) {_vgamma_j1s = m;}
+ void set_vgamma_fij(const DMatrix &m) {_vgamma_fij = m;}
+ void set_err(int e) {_err = e;}
+
+ DVector beta() {return _beta;}
+ DVector alpha() {return _alpha;}
+ DVector gamma() {return _gamma;}
+ DMatrix vbeta() {return _vbeta;}
+ DMatrix valpha() {return _valpha;}
+ DMatrix vbeta_naiv() {return _vbeta_naiv;}
+ DMatrix vbeta_ajs() {return _vbeta_ajs;}
+ DMatrix vbeta_j1s() {return _vbeta_j1s;}
+ DMatrix vbeta_fij() {return _vbeta_fij;}
+ DMatrix valpha_stab() {return _valpha_stab;}
+ DMatrix valpha_naiv() {return _valpha_naiv;}
+ DMatrix valpha_ajs() {return _valpha_ajs;}
+ DMatrix valpha_j1s() {return _valpha_j1s;}
+ DMatrix valpha_fij() {return _valpha_fij;}
+ DMatrix vgamma() {return _vgamma;}
+ DMatrix vgamma_ajs() {return _vgamma_ajs;}
+ DMatrix vgamma_j1s() {return _vgamma_j1s;}
+ DMatrix vgamma_fij() {return _vgamma_fij;}
+ //int ScaleFix() {return _ScaleFix;}
+ int p() {return _beta.dim();}
+ int r() {return _gamma.dim();}
+ int q() {return _alpha.dim();}
+ int err() {return _err;}
+};
+
+#endif //PARAM_H
diff --git a/inst/include/tnt/cholesky.h b/inst/include/tnt/cholesky.h
new file mode 100755
index 0000000..a5a8dd1
--- /dev/null
+++ b/inst/include/tnt/cholesky.h
@@ -0,0 +1,96 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+#ifndef CHOLESKY_H
+#define CHOLESKY_H
+
+#include <cmath>
+
+// index method
+
+namespace TNT
+{
+
+
+//
+// Only upper part of A is used. Cholesky factor is returned in
+// lower part of L. Returns 0 if successful, 1 otherwise.
+//
+template <class SPDMatrix, class SymmMatrix>
+int Cholesky_upper_factorization(SPDMatrix &A, SymmMatrix &L)
+{
+ Subscript M = A.dim(1);
+ Subscript N = A.dim(2);
+
+ assert(M == N); // make sure A is square
+
+ // readjust size of L, if necessary
+
+ if (M != L.dim(1) || N != L.dim(2))
+ L = SymmMatrix(N,N);
+
+ Subscript i,j,k;
+
+
+ typename SPDMatrix::element_type dot=0;
+
+
+ for (j=1; j<=N; j++) // form column j of L
+ {
+ dot= 0;
+
+ for (i=1; i<j; i++) // for k= 1 TO j-1
+ dot = dot + L(j,i)*L(j,i);
+
+ L(j,j) = A(j,j) - dot;
+
+ for (i=j+1; i<=N; i++)
+ {
+ dot = 0;
+ for (k=1; k<j; k++)
+ dot = dot + L(i,k)*L(j,k);
+ L(i,j) = A(j,i) - dot;
+ }
+
+ if (L(j,j) <= 0.0) return 1;
+
+ L(j,j) = sqrt( L(j,j) );
+
+ for (i=j+1; i<=N; i++)
+ L(i,j) = L(i,j) / L(j,j);
+
+ }
+
+ return 0;
+}
+
+
+
+
+}
+// namespace TNT
+
+#endif
+// CHOLESKY_H
diff --git a/inst/include/tnt/cmat.h b/inst/include/tnt/cmat.h
new file mode 100755
index 0000000..db1216c
--- /dev/null
+++ b/inst/include/tnt/cmat.h
@@ -0,0 +1,605 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+// C compatible matrix: row-oriented, 0-based [i][j] and 1-based (i,j) indexing
+//
+
+#ifndef CMAT_H
+#define CMAT_H
+
+#include "tnt/subscript.h"
+#include "tnt/vec.h"
+#include <cstdlib>
+#include <cassert>
+#include <iostream>
+#include <strstream>
+#ifdef TNT_USE_REGIONS
+#include "tnt/region2d.h"
+#endif
+
+namespace TNT
+{
+
+template <class T>
+class Matrix
+{
+
+
+ public:
+
+ typedef Subscript size_type;
+ typedef T value_type;
+ typedef T element_type;
+ typedef T* pointer;
+ typedef T* iterator;
+ typedef T& reference;
+ typedef const T* const_iterator;
+ typedef const T& const_reference;
+
+ Subscript lbound() const { return 1;}
+
+ protected:
+ Subscript m_;
+ Subscript n_;
+ Subscript mn_; // total size
+ T* v_;
+ T** row_;
+ T* vm1_ ; // these point to the same data, but are 1-based
+ T** rowm1_;
+
+ // internal helper function to create the array
+ // of row pointers
+
+ void initialize(Subscript M, Subscript N)
+ {
+ mn_ = M*N;
+ m_ = M;
+ n_ = N;
+
+ v_ = new T[mn_];
+ row_ = new T*[M];
+ rowm1_ = new T*[M];
+
+ assert(v_ != NULL);
+ assert(row_ != NULL);
+ assert(rowm1_ != NULL);
+
+ T* p = v_;
+ vm1_ = v_ - 1;
+ for (Subscript i=0; i<M; i++)
+ {
+ row_[i] = p;
+ rowm1_[i] = p-1;
+ p += N ;
+
+ }
+
+ rowm1_ -- ; // compensate for 1-based offset
+ }
+
+ void copy(const T* v)
+ {
+ Subscript N = m_ * n_;
+ Subscript i;
+
+#ifdef TNT_UNROLL_LOOPS
+ Subscript Nmod4 = N & 3;
+ Subscript N4 = N - Nmod4;
+
+ for (i=0; i<N4; i+=4)
+ {
+ v_[i] = v[i];
+ v_[i+1] = v[i+1];
+ v_[i+2] = v[i+2];
+ v_[i+3] = v[i+3];
+ }
+
+ for (i=N4; i< N; i++)
+ v_[i] = v[i];
+#else
+
+ for (i=0; i< N; i++)
+ v_[i] = v[i];
+#endif
+ }
+
+ void set(const T& val)
+ {
+ Subscript N = m_ * n_;
+ Subscript i;
+
+#ifdef TNT_UNROLL_LOOPS
+ Subscript Nmod4 = N & 3;
+ Subscript N4 = N - Nmod4;
+
+ for (i=0; i<N4; i+=4)
+ {
+ v_[i] = val;
+ v_[i+1] = val;
+ v_[i+2] = val;
+ v_[i+3] = val;
+ }
+
+ for (i=N4; i< N; i++)
+ v_[i] = val;
+#else
+
+ for (i=0; i< N; i++)
+ v_[i] = val;
+
+#endif
+ }
+
+
+
+ void destroy()
+ {
+ /* do nothing, if no memory has been previously allocated */
+ if (v_ == NULL) return ;
+
+ /* if we are here, then matrix was previously allocated */
+ if (v_ != NULL) delete [] (v_);
+ if (row_ != NULL) delete [] (row_);
+
+ /* return rowm1_ back to original value */
+ rowm1_ ++;
+ if (rowm1_ != NULL ) delete [] (rowm1_);
+ }
+
+
+ public:
+
+ operator T**(){ return row_; }
+ operator T**() const { return row_; }
+
+
+ Subscript size() const { return mn_; }
+
+ // constructors
+
+ Matrix() : m_(0), n_(0), mn_(0), v_(0), row_(0), vm1_(0), rowm1_(0) {};
+
+ Matrix(const Matrix<T> &A)
+ {
+ initialize(A.m_, A.n_);
+ copy(A.v_);
+ }
+
+ Matrix(Subscript M, Subscript N, const T& value = T())
+ {
+ initialize(M,N);
+ set(value);
+ }
+
+ Matrix(Subscript M, Subscript N, const T* v)
+ {
+ initialize(M,N);
+ copy(v);
+ }
+
+ Matrix(Subscript M, Subscript N, const char *s)
+ {
+ initialize(M,N);
+ std::istrstream ins(s);
+
+ Subscript i, j;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<N; j++)
+ ins >> row_[i][j];
+ }
+
+ // destructor
+ //
+ ~Matrix()
+ {
+ destroy();
+ }
+
+
+ // reallocating
+ //
+ Matrix<T>& newsize(Subscript M, Subscript N)
+ {
+ if (num_rows() == M && num_cols() == N)
+ return *this;
+
+ destroy();
+ initialize(M,N);
+
+ return *this;
+ }
+
+
+
+
+ // assignments
+ //
+ Matrix<T>& operator=(const Matrix<T> &A)
+ {
+ if (v_ == A.v_)
+ return *this;
+
+ if (m_ == A.m_ && n_ == A.n_) // no need to re-alloc
+ copy(A.v_);
+
+ else
+ {
+ destroy();
+ initialize(A.m_, A.n_);
+ copy(A.v_);
+ }
+
+ return *this;
+ }
+
+ Matrix<T>& operator=(const T& scalar)
+ {
+ set(scalar);
+ return *this;
+ }
+
+
+ Subscript dim(Subscript d) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( d >= 1);
+ assert( d <= 2);
+#endif
+ return (d==1) ? m_ : ((d==2) ? n_ : 0);
+ }
+
+ Subscript num_rows() const { return m_; }
+ Subscript num_cols() const { return n_; }
+
+
+
+
+ inline T* operator[](Subscript i)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(0<=i);
+ assert(i < m_) ;
+#endif
+ return row_[i];
+ }
+
+ inline const T* operator[](Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(0<=i);
+ assert(i < m_) ;
+#endif
+ return row_[i];
+ }
+
+ inline reference operator()(Subscript i)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i <= mn_) ;
+#endif
+ return vm1_[i];
+ }
+
+ inline const_reference operator()(Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i <= mn_) ;
+#endif
+ return vm1_[i];
+ }
+
+
+
+ inline reference operator()(Subscript i, Subscript j)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i <= m_) ;
+ assert(1<=j);
+ assert(j <= n_);
+#endif
+ return rowm1_[i][j];
+ }
+
+
+
+ inline const_reference operator() (Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i <= m_) ;
+ assert(1<=j);
+ assert(j <= n_);
+#endif
+ return rowm1_[i][j];
+ }
+
+
+
+#ifdef TNT_USE_REGIONS
+
+ typedef Region2D<Matrix<T> > Region;
+
+
+ Region operator()(const Index1D &I, const Index1D &J)
+ {
+ return Region(*this, I,J);
+ }
+
+
+ typedef const_Region2D< Matrix<T> > const_Region;
+ const_Region operator()(const Index1D &I, const Index1D &J) const
+ {
+ return const_Region(*this, I,J);
+ }
+
+#endif
+
+
+};
+
+
+/* *************************** I/O ********************************/
+
+template <class T>
+std::ostream& operator<<(std::ostream &s, const Matrix<T> &A)
+{
+ Subscript M=A.num_rows();
+ Subscript N=A.num_cols();
+
+ s << M << " " << N << "\n";
+
+ for (Subscript i=0; i<M; i++)
+ {
+ for (Subscript j=0; j<N; j++)
+ {
+ s << A[i][j] << " ";
+ }
+ s << "\n";
+ }
+
+
+ return s;
+}
+
+template <class T>
+std::istream& operator>>(std::istream &s, Matrix<T> &A)
+{
+
+ Subscript M, N;
+
+ s >> M >> N;
+
+ if ( !(M == A.num_rows() && N == A.num_cols() ))
+ {
+ A.newsize(M,N);
+ }
+
+
+ for (Subscript i=0; i<M; i++)
+ for (Subscript j=0; j<N; j++)
+ {
+ s >> A[i][j];
+ }
+
+
+ return s;
+}
+
+// *******************[ basic matrix algorithms ]***************************
+
+
+template <class T>
+Matrix<T> operator+(const Matrix<T> &A,
+ const Matrix<T> &B)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(M==B.num_rows());
+ assert(N==B.num_cols());
+
+ Matrix<T> tmp(M,N);
+ Subscript i,j;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<N; j++)
+ tmp[i][j] = A[i][j] + B[i][j];
+
+ return tmp;
+}
+
+template <class T>
+Matrix<T> operator-(const Matrix<T> &A,
+ const Matrix<T> &B)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(M==B.num_rows());
+ assert(N==B.num_cols());
+
+ Matrix<T> tmp(M,N);
+ Subscript i,j;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<N; j++)
+ tmp[i][j] = A[i][j] - B[i][j];
+
+ return tmp;
+}
+
+template <class T>
+Matrix<T> mult_element(const Matrix<T> &A,
+ const Matrix<T> &B)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(M==B.num_rows());
+ assert(N==B.num_cols());
+
+ Matrix<T> tmp(M,N);
+ Subscript i,j;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<N; j++)
+ tmp[i][j] = A[i][j] * B[i][j];
+
+ return tmp;
+}
+
+
+template <class T>
+Matrix<T> transpose(const Matrix<T> &A)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ Matrix<T> S(N,M);
+ Subscript i, j;
+
+ for (i=0; i<M; i++)
+ for (j=0; j<N; j++)
+ S[j][i] = A[i][j];
+
+ return S;
+}
+
+
+
+template <class T>
+inline Matrix<T> matmult(const Matrix<T> &A,
+ const Matrix<T> &B)
+{
+
+#ifdef TNT_BOUNDS_CHECK
+ assert(A.num_cols() == B.num_rows());
+#endif
+
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+ Subscript K = B.num_cols();
+
+ Matrix<T> tmp(M,K);
+ T sum;
+
+ for (Subscript i=0; i<M; i++)
+ for (Subscript k=0; k<K; k++)
+ {
+ sum = 0;
+ for (Subscript j=0; j<N; j++)
+ sum = sum + A[i][j] * B[j][k];
+
+ tmp[i][k] = sum;
+ }
+
+ return tmp;
+}
+
+template <class T>
+inline Matrix<T> operator*(const Matrix<T> &A,
+ const Matrix<T> &B)
+{
+ return matmult(A,B);
+}
+
+template <class T>
+inline int matmult(Matrix<T>& C, const Matrix<T> &A,
+ const Matrix<T> &B)
+{
+
+ assert(A.num_cols() == B.num_rows());
+
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+ Subscript K = B.num_cols();
+
+ C.newsize(M,K);
+
+ T sum;
+
+ const T* row_i;
+ const T* col_k;
+
+ for (Subscript i=0; i<M; i++)
+ for (Subscript k=0; k<K; k++)
+ {
+ row_i = &(A[i][0]);
+ col_k = &(B[0][k]);
+ sum = 0;
+ for (Subscript j=0; j<N; j++)
+ {
+ sum += *row_i * *col_k;
+ row_i++;
+ col_k += K;
+ }
+ C[i][k] = sum;
+ }
+
+ return 0;
+}
+
+
+template <class T>
+Vector<T> matmult(const Matrix<T> &A, const Vector<T> &x)
+{
+
+#ifdef TNT_BOUNDS_CHECK
+ assert(A.num_cols() == x.dim());
+#endif
+
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ Vector<T> tmp(M);
+ T sum;
+
+ for (Subscript i=0; i<M; i++)
+ {
+ sum = 0;
+ const T* rowi = A[i];
+ for (Subscript j=0; j<N; j++)
+ sum = sum + rowi[j] * x[j];
+
+ tmp[i] = sum;
+ }
+
+ return tmp;
+}
+
+template <class T>
+inline Vector<T> operator*(const Matrix<T> &A, const Vector<T> &x)
+{
+ return matmult(A,x);
+}
+
+} // namespace TNT
+
+#endif
+// CMAT_H
diff --git a/inst/include/tnt/fcscmat.h b/inst/include/tnt/fcscmat.h
new file mode 100755
index 0000000..e0f1732
--- /dev/null
+++ b/inst/include/tnt/fcscmat.h
@@ -0,0 +1,165 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+// Templated compressed sparse column matrix (Fortran conventions).
+// uses 1-based offsets in storing row indices.
+// Used primarily to interface with Fortran sparse matrix libaries.
+// (CANNOT BE USED AS AN STL CONTAINER.)
+
+
+#ifndef FCSCMAT_H
+#define FCSCMAT_H
+
+#include <iostream>
+#include <cassert>
+#include "tnt/tnt.h"
+#include "tnt/vec.h"
+
+using namespace std;
+
+namespace TNT
+{
+
+template <class T>
+class Fortran_Sparse_Col_Matrix
+{
+
+ protected:
+
+ Vector<T> val_; // data values (nz_ elements)
+ Vector<Subscript> rowind_; // row_ind (nz_ elements)
+ Vector<Subscript> colptr_; // col_ptr (n_+1 elements)
+
+ int nz_; // number of nonzeros
+ Subscript m_; // global dimensions
+ Subscript n_;
+
+ public:
+
+
+ Fortran_Sparse_Col_Matrix(void);
+ Fortran_Sparse_Col_Matrix(const Fortran_Sparse_Col_Matrix<T> &S)
+ : val_(S.val_), rowind_(S.rowind_), colptr_(S.colptr_), nz_(S.nz_),
+ m_(S.m_), n_(S.n_) {};
+ Fortran_Sparse_Col_Matrix(Subscript M, Subscript N,
+ Subscript nz, const T *val, const Subscript *r,
+ const Subscript *c) : val_(nz, val), rowind_(nz, r),
+ colptr_(N+1, c), nz_(nz), m_(M), n_(N) {};
+
+ Fortran_Sparse_Col_Matrix(Subscript M, Subscript N,
+ Subscript nz, char *val, char *r,
+ char *c) : val_(nz, val), rowind_(nz, r),
+ colptr_(N+1, c), nz_(nz), m_(M), n_(N) {};
+
+ Fortran_Sparse_Col_Matrix(Subscript M, Subscript N,
+ Subscript nz, const T *val, Subscript *r, Subscript *c)
+ : val_(nz, val), rowind_(nz, r), colptr_(N+1, c), nz_(nz),
+ m_(M), n_(N) {};
+
+ ~Fortran_Sparse_Col_Matrix() {};
+
+
+ T & val(Subscript i) { return val_(i); }
+ const T & val(Subscript i) const { return val_(i); }
+
+ Subscript & row_ind(Subscript i) { return rowind_(i); }
+ const Subscript & row_ind(Subscript i) const { return rowind_(i); }
+
+ Subscript col_ptr(Subscript i) { return colptr_(i);}
+ const Subscript col_ptr(Subscript i) const { return colptr_(i);}
+
+
+ Subscript num_cols() const { return m_;}
+ Subscript num_rows() const { return n_; }
+
+ Subscript dim(Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( 1 <= i );
+ assert( i <= 2 );
+#endif
+ if (i==1) return m_;
+ else if (i==2) return m_;
+ else return 0;
+ }
+
+ Subscript num_nonzeros() const {return nz_;};
+ Subscript lbound() const {return 1;}
+
+
+
+ Fortran_Sparse_Col_Matrix& operator=(const
+ Fortran_Sparse_Col_Matrix &C)
+ {
+ val_ = C.val_;
+ rowind_ = C.rowind_;
+ colptr_ = C.colptr_;
+ nz_ = C.nz_;
+ m_ = C.m_;
+ n_ = C.n_;
+
+ return *this;
+ }
+
+ Fortran_Sparse_Col_Matrix& newsize(Subscript M, Subscript N,
+ Subscript nz)
+ {
+ val_.newsize(nz);
+ rowind_.newsize(nz);
+ colptr_.newsize(N+1);
+ return *this;
+ }
+};
+
+template <class T>
+ostream& operator<<(ostream &s, const Fortran_Sparse_Col_Matrix<T> &A)
+{
+ Subscript M=A.num_rows();
+ Subscript N=A.num_cols();
+
+ s << M << " " << N << " " << A.num_nonzeros() << endl;
+
+
+ for (Subscript k=1; k<=N; k++)
+ {
+ Subscript start = A.col_ptr(k);
+ Subscript end = A.col_ptr(k+1);
+
+ for (Subscript i= start; i<end; i++)
+ {
+ s << A.row_ind(i) << " " << k << " " << A.val(i) << endl;
+ }
+ }
+
+ return s;
+}
+
+
+
+} // namespace TNT
+
+#endif
+/* FCSCMAT_H */
+
diff --git a/inst/include/tnt/fmat.h b/inst/include/tnt/fmat.h
new file mode 100755
index 0000000..caea303
--- /dev/null
+++ b/inst/include/tnt/fmat.h
@@ -0,0 +1,577 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+// Fortran-compatible matrix: column oriented, 1-based (i,j) indexing
+
+#ifndef FMAT_H
+#define FMAT_H
+
+#include "tnt/subscript.h"
+#include "tnt/vec.h"
+#include <cstdlib>
+#include <cassert>
+#include <iostream>
+#include <sstream>
+#ifdef TNT_USE_REGIONS
+#include "tnt/region2d.h"
+#endif
+
+// simple 1-based, column oriented Matrix class
+
+namespace TNT
+{
+
+template <class T>
+class Fortran_Matrix
+{
+
+
+ public:
+
+ typedef T value_type;
+ typedef T element_type;
+ typedef T* pointer;
+ typedef T* iterator;
+ typedef T& reference;
+ typedef const T* const_iterator;
+ typedef const T& const_reference;
+
+ Subscript lbound() const { return 1;}
+
+ protected:
+ T* v_; // these are adjusted to simulate 1-offset
+ Subscript m_;
+ Subscript n_;
+ T** col_; // these are adjusted to simulate 1-offset
+
+ // internal helper function to create the array
+ // of row pointers
+
+ void initialize(Subscript M, Subscript N)
+ {
+ // adjust col_[] pointers so that they are 1-offset:
+ // col_[j][i] is really col_[j-1][i-1];
+ //
+ // v_[] is the internal contiguous array, it is still 0-offset
+ //
+ v_ = new T[M*N];
+ col_ = new T*[N];
+
+ assert(v_ != NULL);
+ assert(col_ != NULL);
+
+
+ m_ = M;
+ n_ = N;
+ T* p = v_ - 1;
+ for (Subscript i=0; i<N; i++)
+ {
+ col_[i] = p;
+ p += M ;
+
+ }
+ col_ --;
+ }
+
+ void copy(const T* v)
+ {
+ Subscript N = m_ * n_;
+ Subscript i;
+
+#ifdef TNT_UNROLL_LOOPS
+ Subscript Nmod4 = N & 3;
+ Subscript N4 = N - Nmod4;
+
+ for (i=0; i<N4; i+=4)
+ {
+ v_[i] = v[i];
+ v_[i+1] = v[i+1];
+ v_[i+2] = v[i+2];
+ v_[i+3] = v[i+3];
+ }
+
+ for (i=N4; i< N; i++)
+ v_[i] = v[i];
+#else
+
+ for (i=0; i< N; i++)
+ v_[i] = v[i];
+#endif
+ }
+
+ void set(const T& val)
+ {
+ Subscript N = m_ * n_;
+ Subscript i;
+
+#ifdef TNT_UNROLL_LOOPS
+ Subscript Nmod4 = N & 3;
+ Subscript N4 = N - Nmod4;
+
+ for (i=0; i<N4; i+=4)
+ {
+ v_[i] = val;
+ v_[i+1] = val;
+ v_[i+2] = val;
+ v_[i+3] = val;
+ }
+
+ for (i=N4; i< N; i++)
+ v_[i] = val;
+#else
+
+ for (i=0; i< N; i++)
+ v_[i] = val;
+
+#endif
+ }
+
+
+
+ void destroy()
+ {
+ /* do nothing, if no memory has been previously allocated */
+ if (v_ == NULL) return ;
+
+ /* if we are here, then matrix was previously allocated */
+ delete [] (v_);
+ col_ ++; // changed back to 0-offset
+ delete [] (col_);
+ }
+
+
+ public:
+
+ T* begin() { return v_; }
+ const T* begin() const { return v_;}
+
+ T* end() { return v_ + m_*n_; }
+ const T* end() const { return v_ + m_*n_; }
+
+
+ // constructors
+
+ Fortran_Matrix() : v_(0), m_(0), n_(0), col_(0) {};
+ Fortran_Matrix(const Fortran_Matrix<T> &A)
+ {
+ initialize(A.m_, A.n_);
+ copy(A.v_);
+ }
+
+ Fortran_Matrix(Subscript M, Subscript N, const T& value = T())
+ {
+ initialize(M,N);
+ set(value);
+ }
+
+ Fortran_Matrix(Subscript M, Subscript N, const T* v)
+ {
+ initialize(M,N);
+ copy(v);
+ }
+
+
+ Fortran_Matrix(Subscript M, Subscript N, char *s)
+ {
+ initialize(M,N);
+ std::istringstream ins(s);
+
+ Subscript i, j;
+
+ for (i=1; i<=M; i++)
+ for (j=1; j<=N; j++)
+ ins >> (*this)(i,j);
+ }
+
+ // destructor
+ ~Fortran_Matrix()
+ {
+ destroy();
+ }
+
+
+ // assignments
+ //
+ Fortran_Matrix<T>& operator=(const Fortran_Matrix<T> &A)
+ {
+ if (v_ == A.v_)
+ return *this;
+
+ if (m_ == A.m_ && n_ == A.n_) // no need to re-alloc
+ copy(A.v_);
+
+ else
+ {
+ destroy();
+ initialize(A.m_, A.n_);
+ copy(A.v_);
+ }
+
+ return *this;
+ }
+
+ Fortran_Matrix<T>& operator=(const T& scalar)
+ {
+ set(scalar);
+ return *this;
+ }
+
+
+ Subscript dim(Subscript d) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( d >= 1);
+ assert( d <= 2);
+#endif
+ return (d==1) ? m_ : ((d==2) ? n_ : 0);
+ }
+
+ Subscript num_rows() const { return m_; }
+ Subscript num_cols() const { return n_; }
+
+ Fortran_Matrix<T>& newsize(Subscript M, Subscript N)
+ {
+ if (num_rows() == M && num_cols() == N)
+ return *this;
+
+ destroy();
+ initialize(M,N);
+
+ return *this;
+ }
+
+
+
+ // 1-based element access
+ //
+ inline reference operator()(Subscript i, Subscript j)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i <= m_) ;
+ assert(1<=j);
+ assert(j <= n_);
+#endif
+ return col_[j][i];
+ }
+
+ inline const_reference operator() (Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i <= m_) ;
+ assert(1<=j);
+ assert(j <= n_);
+#endif
+ return col_[j][i];
+ }
+
+
+#ifdef TNT_USE_REGIONS
+
+ typedef Region2D<Fortran_Matrix<T> > Region;
+ typedef const_Region2D< Fortran_Matrix<T> > const_Region;
+
+ Region operator()(const Index1D &I, const Index1D &J)
+ {
+ return Region(*this, I,J);
+ }
+
+ const_Region operator()(const Index1D &I, const Index1D &J) const
+ {
+ return const_Region(*this, I,J);
+ }
+
+#endif
+
+
+};
+
+
+/* *************************** I/O ********************************/
+
+template <class T>
+std::ostream& operator<<(std::ostream &s, const Fortran_Matrix<T> &A)
+{
+ Subscript M=A.num_rows();
+ Subscript N=A.num_cols();
+
+ s << M << " " << N << "\n";
+
+ for (Subscript i=1; i<=M; i++)
+ {
+ for (Subscript j=1; j<=N; j++)
+ {
+ s << A(i,j) << " ";
+ }
+ s << "\n";
+ }
+
+
+ return s;
+}
+
+template <class T>
+std::istream& operator>>(std::istream &s, Fortran_Matrix<T> &A)
+{
+
+ Subscript M, N;
+
+ s >> M >> N;
+
+ if ( !(M == A.num_rows() && N == A.num_cols()))
+ {
+ A.newsize(M,N);
+ }
+
+
+ for (Subscript i=1; i<=M; i++)
+ for (Subscript j=1; j<=N; j++)
+ {
+ s >> A(i,j);
+ }
+
+
+ return s;
+}
+
+// *******************[ basic matrix algorithms ]***************************
+
+
+template <class T>
+Fortran_Matrix<T> operator+(const Fortran_Matrix<T> &A,
+ const Fortran_Matrix<T> &B)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(M==B.num_rows());
+ assert(N==B.num_cols());
+
+ Fortran_Matrix<T> tmp(M,N);
+ Subscript i,j;
+
+ for (i=1; i<=M; i++)
+ for (j=1; j<=N; j++)
+ tmp(i,j) = A(i,j) + B(i,j);
+
+ return tmp;
+}
+
+template <class T>
+Fortran_Matrix<T> operator-(const Fortran_Matrix<T> &A,
+ const Fortran_Matrix<T> &B)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(M==B.num_rows());
+ assert(N==B.num_cols());
+
+ Fortran_Matrix<T> tmp(M,N);
+ Subscript i,j;
+
+ for (i=1; i<=M; i++)
+ for (j=1; j<=N; j++)
+ tmp(i,j) = A(i,j) - B(i,j);
+
+ return tmp;
+}
+
+// element-wise multiplication (use matmult() below for matrix
+// multiplication in the linear algebra sense.)
+//
+//
+template <class T>
+Fortran_Matrix<T> mult_element(const Fortran_Matrix<T> &A,
+ const Fortran_Matrix<T> &B)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(M==B.num_rows());
+ assert(N==B.num_cols());
+
+ Fortran_Matrix<T> tmp(M,N);
+ Subscript i,j;
+
+ for (i=1; i<=M; i++)
+ for (j=1; j<=N; j++)
+ tmp(i,j) = A(i,j) * B(i,j);
+
+ return tmp;
+}
+
+
+template <class T>
+Fortran_Matrix<T> transpose(const Fortran_Matrix<T> &A)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ Fortran_Matrix<T> S(N,M);
+ Subscript i, j;
+
+ for (i=1; i<=M; i++)
+ for (j=1; j<=N; j++)
+ S(j,i) = A(i,j);
+
+ return S;
+}
+
+
+
+template <class T>
+inline Fortran_Matrix<T> matmult(const Fortran_Matrix<T> &A,
+ const Fortran_Matrix<T> &B)
+{
+
+#ifdef TNT_BOUNDS_CHECK
+ assert(A.num_cols() == B.num_rows());
+#endif
+
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+ Subscript K = B.num_cols();
+
+ Fortran_Matrix<T> tmp(M,K);
+ T sum;
+
+ for (Subscript i=1; i<=M; i++)
+ for (Subscript k=1; k<=K; k++)
+ {
+ sum = 0;
+ for (Subscript j=1; j<=N; j++)
+ sum = sum + A(i,j) * B(j,k);
+
+ tmp(i,k) = sum;
+ }
+
+ return tmp;
+}
+
+template <class T>
+inline Fortran_Matrix<T> operator*(const Fortran_Matrix<T> &A,
+ const Fortran_Matrix<T> &B)
+{
+ return matmult(A,B);
+}
+
+template <class T>
+inline int matmult(Fortran_Matrix<T>& C, const Fortran_Matrix<T> &A,
+ const Fortran_Matrix<T> &B)
+{
+
+ assert(A.num_cols() == B.num_rows());
+
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+ Subscript K = B.num_cols();
+
+ C.newsize(M,K); // adjust shape of C, if necessary
+
+
+ T sum;
+
+ const T* row_i;
+ const T* col_k;
+
+ for (Subscript i=1; i<=M; i++)
+ {
+ for (Subscript k=1; k<=K; k++)
+ {
+ row_i = &A(i,1);
+ col_k = &B(1,k);
+ sum = 0;
+ for (Subscript j=1; j<=N; j++)
+ {
+ sum += *row_i * *col_k;
+ row_i += M;
+ col_k ++;
+ }
+
+ C(i,k) = sum;
+ }
+
+ }
+
+ return 0;
+}
+
+
+template <class T>
+Vector<T> matmult(const Fortran_Matrix<T> &A, const Vector<T> &x)
+{
+
+#ifdef TNT_BOUNDS_CHECK
+ assert(A.num_cols() == x.dim());
+#endif
+
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ Vector<T> tmp(M);
+ T sum;
+
+ for (Subscript i=1; i<=M; i++)
+ {
+ sum = 0;
+ for (Subscript j=1; j<=N; j++)
+ sum = sum + A(i,j) * x(j);
+
+ tmp(i) = sum;
+ }
+
+ return tmp;
+}
+
+template <class T>
+inline Vector<T> operator*(const Fortran_Matrix<T> &A, const Vector<T> &x)
+{
+ return matmult(A,x);
+}
+
+template <class T>
+inline Fortran_Matrix<T> operator*(const Fortran_Matrix<T> &A, const T &x)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ //Subscript MN = M*N;
+
+ Fortran_Matrix<T> res(M,N);
+ const T* a = A.begin();
+ T* t = res.begin();
+ T* tend = res.end();
+
+ for (t=res.begin(); t < tend; t++, a++)
+ *t = *a * x;
+
+ return res;
+}
+
+} // namespace TNT
+#endif
+// FMAT_H
diff --git a/inst/include/tnt/fortran.h b/inst/include/tnt/fortran.h
new file mode 100755
index 0000000..c86b1a6
--- /dev/null
+++ b/inst/include/tnt/fortran.h
@@ -0,0 +1,67 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+// Header file to define C/Fortran conventions (Platform specific)
+
+#ifndef FORTRAN_H
+#define FORTRAN_H
+
+// help map between C/C++ data types and Fortran types
+
+typedef int Fortran_integer;
+typedef float Fortran_float;
+typedef double Fortran_double;
+
+
+typedef Fortran_double *fda_; // (in/out) double precision array
+typedef const Fortran_double *cfda_; // (in) double precsion array
+
+typedef Fortran_double *fd_; // (in/out) single double precision
+typedef const Fortran_double *cfd_; // (in) single double precision
+
+typedef Fortran_float *ffa_; // (in/out) float precision array
+typedef const Fortran_float *cffa_; // (in) float precsion array
+
+typedef Fortran_float *ff_; // (in/out) single float precision
+typedef const Fortran_float *cff_; // (in) single float precision
+
+typedef Fortran_integer *fia_; // (in/out) single integer array
+typedef const Fortran_integer *cfia_; // (in) single integer array
+
+typedef Fortran_integer *fi_; // (in/out) single integer
+typedef const Fortran_integer *cfi_; // (in) single integer
+
+typedef char *fch_; // (in/out) single character
+typedef char *cfch_; // (in) single character
+
+
+
+#ifndef TNT_SUBSCRIPT_TYPE
+#define TNT_SUBSCRIPT_TYPE TNT::Fortran_integer
+#endif
+
+
+#endif
+// FORTRAN_H
diff --git a/inst/include/tnt/fspvec.h b/inst/include/tnt/fspvec.h
new file mode 100755
index 0000000..abc2799
--- /dev/null
+++ b/inst/include/tnt/fspvec.h
@@ -0,0 +1,168 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+// Templated sparse vector (Fortran conventions).
+// Used primarily to interface with Fortran sparse matrix libaries.
+// (CANNOT BE USED AS AN STL CONTAINER.)
+
+#ifndef FSPVEC_H
+#define FSPVEC_H
+
+#include "tnt/tnt.h"
+#include "tnt/vec.h"
+#include <cstdlib>
+#include <cassert>
+#include <iostream>
+#include <strstream>
+
+using namespace std;
+
+namespace TNT
+{
+
+template <class T>
+class Fortran_Sparse_Vector
+{
+
+
+ public:
+
+ typedef Subscript size_type;
+ typedef T value_type;
+ typedef T element_type;
+ typedef T* pointer;
+ typedef T* iterator;
+ typedef T& reference;
+ typedef const T* const_iterator;
+ typedef const T& const_reference;
+
+ Subscript lbound() const { return 1;}
+
+ protected:
+ Vector<T> val_;
+ Vector<Subscript> index_;
+ Subscript dim_; // prescribed dimension
+
+
+ public:
+
+ // size and shape information
+
+ Subscript dim() const { return dim_; }
+ Subscript num_nonzeros() const { return val_.dim(); }
+
+ // access
+
+ T& val(Subscript i) { return val_(i); }
+ const T& val(Subscript i) const { return val_(i); }
+
+ Subscript &index(Subscript i) { return index_(i); }
+ const Subscript &index(Subscript i) const { return index_(i); }
+
+ // constructors
+
+ Fortran_Sparse_Vector() : val_(), index_(), dim_(0) {};
+ Fortran_Sparse_Vector(Subscript N, Subscript nz) : val_(nz),
+ index_(nz), dim_(N) {};
+ Fortran_Sparse_Vector(Subscript N, Subscript nz, const T *values,
+ const Subscript *indices): val_(nz, values), index_(nz, indices),
+ dim_(N) {}
+
+ Fortran_Sparse_Vector(const Fortran_Sparse_Vector<T> &S):
+ val_(S.val_), index_(S.index_), dim_(S.dim_) {}
+
+ // initialize from string, e.g.
+ //
+ // Fortran_Sparse_Vector<T> A(N, 2, "1.0 2.1", "1 3");
+ //
+ Fortran_Sparse_Vector(Subscript N, Subscript nz, char *v,
+ char *ind) : val_(nz, v), index_(nz, ind), dim_(N) {}
+
+ // assignments
+
+ Fortran_Sparse_Vector<T> & newsize(Subscript N, Subscript nz)
+ {
+ val_.newsize(nz);
+ index_.newsize(nz);
+ dim_ = N;
+ return *this;
+ }
+
+ Fortran_Sparse_Vector<T> & operator=( const Fortran_Sparse_Vector<T> &A)
+ {
+ val_ = A.val_;
+ index_ = A.index_;
+ dim_ = A.dim_;
+
+ return *this;
+ }
+
+ // methods
+
+
+
+};
+
+
+/* *************************** I/O ********************************/
+
+template <class T>
+ostream& operator<<(ostream &s, const Fortran_Sparse_Vector<T> &A)
+{
+ // output format is : N nz val1 ind1 val2 ind2 ...
+ Subscript nz=A.num_nonzeros();
+
+ s << A.dim() << " " << nz << endl;
+
+ for (Subscript i=1; i<=nz; i++)
+ s << A.val(i) << " " << A.index(i) << endl;
+ s << endl;
+
+ return s;
+}
+
+
+template <class T>
+istream& operator>>(istream &s, Fortran_Sparse_Vector<T> &A)
+{
+ // output format is : N nz val1 ind1 val2 ind2 ...
+
+ Subscript N;
+ Subscript nz;
+
+ s >> N >> nz;
+
+ A.newsize(N, nz);
+
+ for (Subscript i=1; i<=nz; i++)
+ s >> A.val(i) >> A.index(i);
+
+
+ return s;
+}
+
+} // namespace TNT
+
+#endif
+// FSPVEC_H
diff --git a/inst/include/tnt/index.h b/inst/include/tnt/index.h
new file mode 100755
index 0000000..1a52a6a
--- /dev/null
+++ b/inst/include/tnt/index.h
@@ -0,0 +1,83 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+// Vector/Matrix/Array Index Module
+
+#ifndef INDEX_H
+#define INDEX_H
+
+#include "tnt/subscript.h"
+
+namespace TNT
+{
+
+class Index1D
+{
+ Subscript lbound_;
+ Subscript ubound_;
+
+ public:
+
+ Subscript lbound() const { return lbound_; }
+ Subscript ubound() const { return ubound_; }
+
+ Index1D(const Index1D &D) : lbound_(D.lbound_), ubound_(D.ubound_) {}
+ Index1D(Subscript i1, Subscript i2) : lbound_(i1), ubound_(i2) {}
+
+ Index1D & operator=(const Index1D &D)
+ {
+ lbound_ = D.lbound_;
+ ubound_ = D.ubound_;
+ return *this;
+ }
+
+};
+
+inline Index1D operator+(const Index1D &D, Subscript i)
+{
+ return Index1D(i+D.lbound(), i+D.ubound());
+}
+
+inline Index1D operator+(Subscript i, const Index1D &D)
+{
+ return Index1D(i+D.lbound(), i+D.ubound());
+}
+
+
+
+inline Index1D operator-(Index1D &D, Subscript i)
+{
+ return Index1D(D.lbound()-i, D.ubound()-i);
+}
+
+inline Index1D operator-(Subscript i, Index1D &D)
+{
+ return Index1D(i-D.lbound(), i-D.ubound());
+}
+
+} // namespace TNT
+
+#endif
+
diff --git a/inst/include/tnt/lapack.h b/inst/include/tnt/lapack.h
new file mode 100755
index 0000000..035c90e
--- /dev/null
+++ b/inst/include/tnt/lapack.h
@@ -0,0 +1,193 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+// Header file for Fortran Lapack
+
+#ifndef LAPACK_H
+#define LAPACK_H
+
+// This file incomplete and included here to only demonstrate the
+// basic framework for linking with the Fortran Lapack routines.
+
+#include "tnt/fortran.h"
+#include "tnt/vec.h"
+#include "tnt/fmat.h"
+
+
+#define F77_DGESV dgesv_
+#define F77_DGELS dgels_
+#define F77_DSYEV dsyev_
+#define F77_DGEEV dgeev_
+
+extern "C"
+{
+
+ // linear equations (general) using LU factorizaiton
+ //
+ void F77_DGESV(cfi_ N, cfi_ nrhs, fda_ A, cfi_ lda,
+ fia_ ipiv, fda_ b, cfi_ ldb, fi_ info);
+
+ // solve linear least squares using QR or LU factorization
+ //
+ void F77_DGELS(cfch_ trans, cfi_ M,
+ cfi_ N, cfi_ nrhs, fda_ A, cfi_ lda, fda_ B, cfi_ ldb, fda_ work,
+ cfi_ lwork, fi_ info);
+
+ // solve symmetric eigenvalues
+ //
+ void F77_DSYEV( cfch_ jobz, cfch_ uplo, cfi_ N, fda_ A, cfi_ lda,
+ fda_ W, fda_ work, cfi_ lwork, fi_ info);
+
+ // solve unsymmetric eigenvalues
+ //
+ void F77_DGEEV(cfch_ jobvl, cfch_ jobvr, cfi_ N, fda_ A, cfi_ lda,
+ fda_ wr, fda_ wi, fda_ vl, cfi_ ldvl, fda_ vr,
+ cfi_ ldvr, fda_ work, cfi_ lwork, fi_ info);
+
+}
+
+// solve linear equations using LU factorization
+
+using namespace TNT;
+
+Vector<double> Lapack_LU_linear_solve(const Fortran_Matrix<double> &A,
+ const Vector<double> &b)
+{
+ const Fortran_integer one=1;
+ Subscript M=A.num_rows();
+ Subscript N=A.num_cols();
+
+ Fortran_Matrix<double> Tmp(A);
+ Vector<double> x(b);
+ Vector<Fortran_integer> index(M);
+ Fortran_integer info = 0;
+
+ F77_DGESV(&N, &one, &Tmp(1,1), &M, &index(1), &x(1), &M, &info);
+
+ if (info != 0) return Vector<double>(0);
+ else
+ return x;
+}
+
+// solve linear least squares problem using QR factorization
+//
+Vector<double> Lapack_LLS_QR_linear_solve(const Fortran_Matrix<double> &A,
+ const Vector<double> &b)
+{
+ const Fortran_integer one=1;
+ Subscript M=A.num_rows();
+ Subscript N=A.num_cols();
+
+ Fortran_Matrix<double> Tmp(A);
+ Vector<double> x(b);
+ Fortran_integer info = 0;
+
+ char transp = 'N';
+ Fortran_integer lwork = 5 * (M+N); // temporary work space
+ Vector<double> work(lwork);
+
+ F77_DGELS(&transp, &M, &N, &one, &Tmp(1,1), &M, &x(1), &M, &work(1),
+ &lwork, &info);
+
+ if (info != 0) return Vector<double>(0);
+ else
+ return x;
+}
+
+// *********************** Eigenvalue problems *******************
+
+// solve symmetric eigenvalue problem (eigenvalues only)
+//
+Vector<double> Upper_symmetric_eigenvalue_solve(const Fortran_Matrix<double> &A)
+{
+ char jobz = 'N';
+ char uplo = 'U';
+ Subscript N = A.num_rows();
+
+ assert(N == A.num_cols());
+
+ Vector<double> eigvals(N);
+ Fortran_integer worksize = 3*N;
+ Fortran_integer info = 0;
+ Vector<double> work(worksize);
+ Fortran_Matrix<double> Tmp = A;
+
+ F77_DSYEV(&jobz, &uplo, &N, &Tmp(1,1), &N, eigvals.begin(), work.begin(),
+ &worksize, &info);
+
+ if (info != 0) return Vector<double>();
+ else
+ return eigvals;
+}
+
+
+// solve unsymmetric eigenvalue problems
+//
+int eigenvalue_solve(const Fortran_Matrix<double> &A,
+ Vector<double> &wr, Vector<double> &wi)
+{
+ char jobvl = 'N';
+ char jobvr = 'N';
+
+ Fortran_integer N = A.num_rows();
+
+
+ assert(N == A.num_cols());
+
+ if (N<1) return 1;
+
+ Fortran_Matrix<double> vl(1,N); /* should be NxN ? **** */
+ Fortran_Matrix<double> vr(1,N);
+ Fortran_integer one = 1;
+
+ Fortran_integer worksize = 5*N;
+ Fortran_integer info = 0;
+ Vector<double> work(worksize, 0.0);
+ Fortran_Matrix<double> Tmp = A;
+
+ wr.newsize(N);
+ wi.newsize(N);
+
+// void F77_DGEEV(cfch_ jobvl, cfch_ jobvr, cfi_ N, fda_ A, cfi_ lda,
+// fda_ wr, fda_ wi, fda_ vl, cfi_ ldvl, fda_ vr,
+// cfi_ ldvr, fda_ work, cfi_ lwork, fi_ info);
+
+ F77_DGEEV(&jobvl, &jobvr, &N, &Tmp(1,1), &N, &(wr(1)),
+ &(wi(1)), &(vl(1,1)), &one, &(vr(1,1)), &one,
+ &(work(1)), &worksize, &info);
+
+ return (info==0 ? 0: 1);
+}
+
+
+
+
+
+#endif
+// LAPACK_H
+
+
+
+
diff --git a/inst/include/tnt/lu.h b/inst/include/tnt/lu.h
new file mode 100755
index 0000000..0d8522f
--- /dev/null
+++ b/inst/include/tnt/lu.h
@@ -0,0 +1,204 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+#ifndef LU_H
+#define LU_H
+
+// Solve system of linear equations Ax = b.
+//
+// Typical usage:
+//
+// Matrix(double) A;
+// Vector(Subscript) ipiv;
+// Vector(double) b;
+//
+// 1) LU_Factor(A,ipiv);
+// 2) LU_Solve(A,ipiv,b);
+//
+// Now b has the solution x. Note that both A and b
+// are overwritten. If these values need to be preserved,
+// one can make temporary copies, as in
+//
+// O) Matrix(double) T = A;
+// 1) LU_Factor(T,ipiv);
+// 1a) Vector(double) x=b;
+// 2) LU_Solve(T,ipiv,x);
+//
+// See details below.
+//
+
+
+// for fabs()
+//
+#include <cmath>
+
+// right-looking LU factorization algorithm (unblocked)
+//
+// Factors matrix A into lower and upper triangular matrices
+// (L and U respectively) in solving the linear equation Ax=b.
+//
+//
+// Args:
+//
+// A (input/output) Matrix(1:n, 1:n) In input, matrix to be
+// factored. On output, overwritten with lower and
+// upper triangular factors.
+//
+// indx (output) Vector(1:n) Pivot vector. Describes how
+// the rows of A were reordered to increase
+// numerical stability.
+//
+// Return value:
+//
+// int (0 if successful, 1 otherwise)
+//
+//
+
+
+namespace TNT
+{
+
+template <class MaTRiX, class VecToRSubscript>
+int LU_factor( MaTRiX &A, VecToRSubscript &indx)
+{
+ assert(A.lbound() == 1); // currently for 1-offset
+ assert(indx.lbound() == 1); // vectors and matrices
+
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ if (M == 0 || N==0) return 0;
+ if (indx.dim() != M)
+ indx.newsize(M);
+
+ Subscript i=0,j=0,k=0;
+ Subscript jp=0;
+
+ typename MaTRiX::element_type t;
+
+ Subscript minMN = (M < N ? M : N) ; // min(M,N);
+
+ for (j=1; j<= minMN; j++)
+ {
+
+ // find pivot in column j and test for singularity.
+
+ jp = j;
+ t = fabs(A(j,j));
+ for (i=j+1; i<=M; i++)
+ if ( fabs(A(i,j)) > t)
+ {
+ jp = i;
+ t = fabs(A(i,j));
+ }
+
+ indx(j) = jp;
+
+ // jp now has the index of maximum element
+ // of column j, below the diagonal
+
+ if ( A(jp,j) == 0 )
+ return 1; // factorization failed because of zero pivot
+
+
+ if (jp != j) // swap rows j and jp
+ for (k=1; k<=N; k++)
+ {
+ t = A(j,k);
+ A(j,k) = A(jp,k);
+ A(jp,k) =t;
+ }
+
+ if (j<M) // compute elements j+1:M of jth column
+ {
+ // note A(j,j), was A(jp,p) previously which was
+ // guarranteed not to be zero (Label #1)
+ //
+ typename MaTRiX::element_type recp = 1.0 / A(j,j);
+
+ for (k=j+1; k<=M; k++)
+ A(k,j) *= recp;
+ }
+
+
+ if (j < minMN)
+ {
+ // rank-1 update to trailing submatrix: E = E - x*y;
+ //
+ // E is the region A(j+1:M, j+1:N)
+ // x is the column vector A(j+1:M,j)
+ // y is row vector A(j,j+1:N)
+
+ Subscript ii,jj;
+
+ for (ii=j+1; ii<=M; ii++)
+ for (jj=j+1; jj<=N; jj++)
+ A(ii,jj) -= A(ii,j)*A(j,jj);
+ }
+ }
+
+ return 0;
+}
+
+
+
+
+template <class MaTRiX, class VecToR, class VecToRSubscripts>
+int LU_solve(const MaTRiX &A, const VecToRSubscripts &indx, VecToR &b)
+{
+ assert(A.lbound() == 1); // currently for 1-offset
+ assert(indx.lbound() == 1); // vectors and matrices
+ assert(b.lbound() == 1);
+
+ Subscript i,ii=0,ip,j;
+ Subscript n = b.dim();
+ typename MaTRiX::element_type sum = 0.0;
+
+ for (i=1;i<=n;i++)
+ {
+ ip=indx(i);
+ sum=b(ip);
+ b(ip)=b(i);
+ if (ii)
+ for (j=ii;j<=i-1;j++)
+ sum -= A(i,j)*b(j);
+ else if (sum) ii=i;
+ b(i)=sum;
+ }
+ for (i=n;i>=1;i--)
+ {
+ sum=b(i);
+ for (j=i+1;j<=n;j++)
+ sum -= A(i,j)*b(j);
+ b(i)=sum/A(i,i);
+ }
+
+ return 0;
+}
+
+} // namespace TNT
+
+#endif
+// LU_H
diff --git a/inst/include/tnt/qr.h b/inst/include/tnt/qr.h
new file mode 100755
index 0000000..caabfb1
--- /dev/null
+++ b/inst/include/tnt/qr.h
@@ -0,0 +1,229 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+#ifndef QR_H
+#define QR_H
+
+// Classical QR factorization example, based on Stewart[1973].
+//
+//
+// This algorithm computes the factorization of a matrix A
+// into a product of an orthognal matrix (Q) and an upper triangular
+// matrix (R), such that QR = A.
+//
+// Parameters:
+//
+// A (in): Matrix(1:N, 1:N)
+//
+// Q (output): Matrix(1:N, 1:N), collection of Householder
+// column vectors Q1, Q2, ... QN
+//
+// R (output): upper triangular Matrix(1:N, 1:N)
+//
+// Returns:
+//
+// 0 if successful, 1 if A is detected to be singular
+//
+
+
+#include <cmath> //for sqrt() & fabs()
+#include "tnt/tntmath.h" // for sign()
+
+// Classical QR factorization, based on Stewart[1973].
+//
+//
+// This algorithm computes the factorization of a matrix A
+// into a product of an orthognal matrix (Q) and an upper triangular
+// matrix (R), such that QR = A.
+//
+// Parameters:
+//
+// A (in/out): On input, A is square, Matrix(1:N, 1:N), that represents
+// the matrix to be factored.
+//
+// On output, Q and R is encoded in the same Matrix(1:N,1:N)
+// in the following manner:
+//
+// R is contained in the upper triangular section of A,
+// except that R's main diagonal is in D. The lower
+// triangular section of A represents Q, where each
+// column j is the vector Qj = I - uj*uj'/pi_j.
+//
+// C (output): vector of Pi[j]
+// D (output): main diagonal of R, i.e. D(i) is R(i,i)
+//
+// Returns:
+//
+// 0 if successful, 1 if A is detected to be singular
+//
+
+namespace TNT
+{
+
+template <class MaTRiX, class Vector>
+int QR_factor(MaTRiX &A, Vector& C, Vector &D)
+{
+ assert(A.lbound() == 1); // ensure these are all
+ assert(C.lbound() == 1); // 1-based arrays and vectors
+ assert(D.lbound() == 1);
+
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(M == N); // make sure A is square
+
+ Subscript i,j,k;
+ typename MaTRiX::element_type eta, sigma, sum;
+
+ // adjust the shape of C and D, if needed...
+
+ if (N != C.size()) C.newsize(N);
+ if (N != D.size()) D.newsize(N);
+
+ for (k=1; k<N; k++)
+ {
+ // eta = max |M(i,k)|, for k <= i <= n
+ //
+ eta = 0;
+ for (i=k; i<=N; i++)
+ {
+ double absA = fabs(A(i,k));
+ eta = ( absA > eta ? absA : eta );
+ }
+
+ if (eta == 0) // matrix is singular
+ {
+ cerr << "QR: k=" << k << "\n";
+ return 1;
+ }
+
+ // form Qk and premiltiply M by it
+ //
+ for(i=k; i<=N; i++)
+ A(i,k) = A(i,k) / eta;
+
+ sum = 0;
+ for (i=k; i<=N; i++)
+ sum = sum + A(i,k)*A(i,k);
+ sigma = sign(A(k,k)) * sqrt(sum);
+
+
+ A(k,k) = A(k,k) + sigma;
+ C(k) = sigma * A(k,k);
+ D(k) = -eta * sigma;
+
+ for (j=k+1; j<=N; j++)
+ {
+ sum = 0;
+ for (i=k; i<=N; i++)
+ sum = sum + A(i,k)*A(i,j);
+ sum = sum / C(k);
+
+ for (i=k; i<=N; i++)
+ A(i,j) = A(i,j) - sum * A(i,k);
+ }
+
+ D(N) = A(N,N);
+ }
+
+ return 0;
+}
+
+// modified form of upper triangular solve, except that the main diagonal
+// of R (upper portion of A) is in D.
+//
+template <class MaTRiX, class Vector>
+int R_solve(const MaTRiX &A, /*const*/ Vector &D, Vector &b)
+{
+ assert(A.lbound() == 1); // ensure these are all
+ assert(D.lbound() == 1); // 1-based arrays and vectors
+ assert(b.lbound() == 1);
+
+ Subscript i,j;
+ Subscript N = A.num_rows();
+
+ assert(N == A.num_cols());
+ assert(N == D.dim());
+ assert(N == b.dim());
+
+ typename MaTRiX::element_type sum;
+
+ if (D(N) == 0)
+ return 1;
+
+ b(N) = b(N) /
+ D(N);
+
+ for (i=N-1; i>=1; i--)
+ {
+ if (D(i) == 0)
+ return 1;
+ sum = 0;
+ for (j=i+1; j<=N; j++)
+ sum = sum + A(i,j)*b(j);
+ b(i) = ( b(i) - sum ) /
+ D(i);
+ }
+
+ return 0;
+}
+
+
+template <class MaTRiX, class Vector>
+int QR_solve(const MaTRiX &A, const Vector &c, /*const*/ Vector &d,
+ Vector &b)
+{
+ assert(A.lbound() == 1); // ensure these are all
+ assert(c.lbound() == 1); // 1-based arrays and vectors
+ assert(d.lbound() == 1);
+
+ Subscript N=A.num_rows();
+
+ assert(N == A.num_cols());
+ assert(N == c.dim());
+ assert(N == d.dim());
+ assert(N == b.dim());
+
+ Subscript i,j;
+ typename MaTRiX::element_type sum, tau;
+
+ for (j=1; j<N; j++)
+ {
+ // form Q'*b
+ sum = 0;
+ for (i=j; i<=N; i++)
+ sum = sum + A(i,j)*b(i);
+ if (c(j) == 0)
+ return 1;
+ tau = sum / c(j);
+ for (i=j; i<=N; i++)
+ b(i) = b(i) - tau * A(i,j);
+ }
+ return R_solve(A, d, b); // solve Rx = Q'b
+}
+
+} // namespace TNT
+
+#endif
+// QR_H
diff --git a/inst/include/tnt/region1d.h b/inst/include/tnt/region1d.h
new file mode 100755
index 0000000..1b776c3
--- /dev/null
+++ b/inst/include/tnt/region1d.h
@@ -0,0 +1,371 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+
+#ifndef REGION1D_H
+#define REGION1D_H
+
+
+#include "tnt/subscript.h"
+#include "tnt/index.h"
+#include <iostream>
+#include <cassert>
+
+namespace TNT
+{
+
+template <class Array1D>
+class const_Region1D;
+
+template <class Array1D>
+class Region1D
+{
+ protected:
+
+ Array1D & A_;
+ Subscript offset_; // 0-based
+ Subscript dim_;
+
+ typedef typename Array1D::element_type T;
+
+ public:
+ const Array1D & array() const { return A_; }
+
+ Subscript offset() const { return offset_;}
+ Subscript dim() const { return dim_; }
+
+ Subscript offset(Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(i==TNT_BASE_OFFSET);
+#endif
+ return offset_;
+ }
+
+ Subscript dim(Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(i== TNT_BASE_OFFSET);
+#endif
+ return offset_;
+ }
+
+
+ Region1D(Array1D &A, Subscript i1, Subscript i2) : A_(A)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET <= i1 );
+ assert(i2 <= A.dim() + (TNT_BASE_OFFSET-1));
+ assert(i1 <= i2);
+#endif
+ offset_ = i1 - TNT_BASE_OFFSET;
+ dim_ = i2-i1 + 1;
+ }
+
+ Region1D(Array1D &A, const Index1D &I) : A_(A)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET <=I.lbound());
+ assert(I.ubound() <= A.dim() + (TNT_BASE_OFFSET-1));
+ assert(I.lbound() <= I.ubound());
+#endif
+ offset_ = I.lbound() - TNT_BASE_OFFSET;
+ dim_ = I.ubound() - I.lbound() + 1;
+ }
+
+ Region1D(Region1D<Array1D> &A, Subscript i1, Subscript i2) :
+ A_(A.A_)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET <= i1 );
+ assert(i2 <= A.dim() + (TNT_BASE_OFFSET - 1));
+ assert(i1 <= i2);
+#endif
+ // (old-offset) (new-offset)
+ //
+ offset_ = (i1 - TNT_BASE_OFFSET) + A.offset_;
+ dim_ = i2-i1 + 1;
+ }
+
+ Region1D<Array1D> operator()(Subscript i1, Subscript i2)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET <= i1);
+ assert(i2 <= dim() + (TNT_BASE_OFFSET -1));
+ assert(i1 <= i2);
+#endif
+ // offset_ is 0-based, so no need for
+ // ( - TNT_BASE_OFFSET)
+ //
+ return Region1D<Array1D>(A_, i1+offset_,
+ offset_ + i2);
+ }
+
+
+ Region1D<Array1D> operator()(const Index1D &I)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET<=I.lbound());
+ assert(I.ubound() <= dim() + (TNT_BASE_OFFSET-1));
+ assert(I.lbound() <= I.ubound());
+#endif
+ return Region1D<Array1D>(A_, I.lbound()+offset_,
+ offset_ + I.ubound());
+ }
+
+
+
+
+ T & operator()(Subscript i)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET <= i);
+ assert(i <= dim() + (TNT_BASE_OFFSET-1));
+#endif
+ return A_(i+offset_);
+ }
+
+ const T & operator() (Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET <= i);
+ assert(i <= dim() + (TNT_BASE_OFFSET-1));
+#endif
+ return A_(i+offset_);
+ }
+
+
+ Region1D<Array1D> & operator=(const Region1D<Array1D> &R)
+ {
+ // make sure both sides conform
+ assert(dim() == R.dim());
+
+ Subscript N = dim();
+ Subscript i;
+ Subscript istart = TNT_BASE_OFFSET;
+ Subscript iend = istart + N-1;
+
+ for (i=istart; i<=iend; i++)
+ (*this)(i) = R(i);
+
+ return *this;
+ }
+
+
+
+ Region1D<Array1D> & operator=(const const_Region1D<Array1D> &R)
+ {
+ // make sure both sides conform
+ assert(dim() == R.dim());
+
+ Subscript N = dim();
+ Subscript i;
+ Subscript istart = TNT_BASE_OFFSET;
+ Subscript iend = istart + N-1;
+
+ for (i=istart; i<=iend; i++)
+ (*this)(i) = R(i);
+
+ return *this;
+
+ }
+
+
+ Region1D<Array1D> & operator=(const T& t)
+ {
+ Subscript N=dim();
+ Subscript i;
+ Subscript istart = TNT_BASE_OFFSET;
+ Subscript iend = istart + N-1;
+
+ for (i=istart; i<= iend; i++)
+ (*this)(i) = t;
+
+ return *this;
+
+ }
+
+
+ Region1D<Array1D> & operator=(const Array1D &R)
+ {
+ // make sure both sides conform
+ Subscript N = dim();
+ assert(dim() == R.dim());
+
+ Subscript i;
+ Subscript istart = TNT_BASE_OFFSET;
+ Subscript iend = istart + N-1;
+
+ for (i=istart; i<=iend; i++)
+ (*this)(i) = R(i);
+
+ return *this;
+
+ }
+
+};
+
+template <class Array1D>
+std::ostream& operator<<(std::ostream &s, Region1D<Array1D> &A)
+{
+ Subscript N=A.dim();
+ Subscript istart = TNT_BASE_OFFSET;
+ Subscript iend = N - 1 + TNT_BASE_OFFSET;
+
+ for (Subscript i=istart; i<=iend; i++)
+ s << A(i) << endl;
+
+ return s;
+}
+
+
+/* --------- class const_Region1D ------------ */
+
+template <class Array1D>
+class const_Region1D
+{
+ protected:
+
+ const Array1D & A_;
+ Subscript offset_; // 0-based
+ Subscript dim_;
+ typedef typename Array1D::element_type T;
+
+ public:
+ const Array1D & array() const { return A_; }
+
+ Subscript offset() const { return offset_;}
+ Subscript dim() const { return dim_; }
+
+ Subscript offset(Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(i==TNT_BASE_OFFSET);
+#endif
+ return offset_;
+ }
+
+ Subscript dim(Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(i== TNT_BASE_OFFSET);
+#endif
+ return offset_;
+ }
+
+
+ const_Region1D(const Array1D &A, Subscript i1, Subscript i2) : A_(A)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET <= i1 );
+ assert(i2 <= A.dim() + (TNT_BASE_OFFSET-1));
+ assert(i1 <= i2);
+#endif
+ offset_ = i1 - TNT_BASE_OFFSET;
+ dim_ = i2-i1 + 1;
+ }
+
+ const_Region1D(const Array1D &A, const Index1D &I) : A_(A)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET <=I.lbound());
+ assert(I.ubound() <= A.dim() + (TNT_BASE_OFFSET-1));
+ assert(I.lbound() <= I.ubound());
+#endif
+ offset_ = I.lbound() - TNT_BASE_OFFSET;
+ dim_ = I.ubound() - I.lbound() + 1;
+ }
+
+ const_Region1D(const_Region1D<Array1D> &A, Subscript i1, Subscript i2) :
+ A_(A.A_)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET <= i1 );
+ assert(i2 <= A.dim() + (TNT_BASE_OFFSET - 1));
+ assert(i1 <= i2);
+#endif
+ // (old-offset) (new-offset)
+ //
+ offset_ = (i1 - TNT_BASE_OFFSET) + A.offset_;
+ dim_ = i2-i1 + 1;
+ }
+
+ const_Region1D<Array1D> operator()(Subscript i1, Subscript i2)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET <= i1);
+ assert(i2 <= dim() + (TNT_BASE_OFFSET -1));
+ assert(i1 <= i2);
+#endif
+ // offset_ is 0-based, so no need for
+ // ( - TNT_BASE_OFFSET)
+ //
+ return const_Region1D<Array1D>(A_, i1+offset_,
+ offset_ + i2);
+ }
+
+
+ const_Region1D<Array1D> operator()(const Index1D &I)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET<=I.lbound());
+ assert(I.ubound() <= dim() + (TNT_BASE_OFFSET-1));
+ assert(I.lbound() <= I.ubound());
+#endif
+ return const_Region1D<Array1D>(A_, I.lbound()+offset_,
+ offset_ + I.ubound());
+ }
+
+
+ const T & operator() (Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(TNT_BASE_OFFSET <= i);
+ assert(i <= dim() + (TNT_BASE_OFFSET-1));
+#endif
+ return A_(i+offset_);
+ }
+
+
+
+
+};
+
+template <class Array1D>
+std::ostream& operator<<(std::ostream &s, const_Region1D<Array1D> &A)
+{
+ Subscript N=A.dim();
+
+ for (Subscript i=1; i<=N; i++)
+ s << A(i) << endl;
+
+ return s;
+}
+
+
+} // namespace TNT
+
+#endif
+// const_Region1D_H
diff --git a/inst/include/tnt/region2d.h b/inst/include/tnt/region2d.h
new file mode 100755
index 0000000..afe800c
--- /dev/null
+++ b/inst/include/tnt/region2d.h
@@ -0,0 +1,467 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+// 2D Regions for arrays and matrices
+
+#ifndef REGION2D_H
+#define REGION2D_H
+
+#include "tnt/index.h"
+#include <iostream>
+#include <cassert>
+
+namespace TNT
+{
+
+template <class Array2D>
+class const_Region2D;
+
+
+template <class Array2D>
+class Region2D
+{
+ protected:
+
+ Array2D & A_;
+ Subscript offset_[2]; // 0-offset internally
+ Subscript dim_[2];
+
+ public:
+ typedef typename Array2D::value_type T;
+ typedef Subscript size_type;
+ typedef T value_type;
+ typedef T element_type;
+ typedef T* pointer;
+ typedef T* iterator;
+ typedef T& reference;
+ typedef const T* const_iterator;
+ typedef const T& const_reference;
+
+ Array2D & array() { return A_; }
+ const Array2D & array() const { return A_; }
+ Subscript lbound() const { return A_.lbound(); }
+ Subscript num_rows() const { return dim_[0]; }
+ Subscript num_cols() const { return dim_[1]; }
+ Subscript offset(Subscript i) const // 1-offset
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( A_.lbound() <= i);
+ assert( i<= dim_[0] + A_.lbound()-1);
+#endif
+ return offset_[i-A_.lbound()];
+ }
+
+ Subscript dim(Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( A_.lbound() <= i);
+ assert( i<= dim_[0] + A_.lbound()-1);
+#endif
+ return dim_[i-A_.lbound()];
+ }
+
+
+
+ Region2D(Array2D &A, Subscript i1, Subscript i2, Subscript j1,
+ Subscript j2) : A_(A)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( i1 <= i2 );
+ assert( j1 <= j2);
+ assert( A.lbound() <= i1);
+ assert( i2<= A.dim(A.lbound()) + A.lbound()-1);
+ assert( A.lbound() <= j1);
+ assert( j2<= A.dim(A.lbound()+1) + A.lbound()-1 );
+#endif
+
+
+ offset_[0] = i1-A.lbound();
+ offset_[1] = j1-A.lbound();
+ dim_[0] = i2-i1+1;
+ dim_[1] = j2-j1+1;
+ }
+
+ Region2D(Array2D &A, const Index1D &I, const Index1D &J) : A_(A)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( I.lbound() <= I.ubound() );
+ assert( J.lbound() <= J.ubound() );
+ assert( A.lbound() <= I.lbound());
+ assert( I.ubound()<= A.dim(A.lbound()) + A.lbound()-1);
+ assert( A.lbound() <= J.lbound());
+ assert( J.ubound() <= A.dim(A.lbound()+1) + A.lbound()-1 );
+#endif
+
+ offset_[0] = I.lbound()-A.lbound();
+ offset_[1] = J.lbound()-A.lbound();
+ dim_[0] = I.ubound() - I.lbound() + 1;
+ dim_[1] = J.ubound() - J.lbound() + 1;
+ }
+
+ Region2D(Region2D<Array2D> &A, Subscript i1, Subscript i2,
+ Subscript j1, Subscript j2) : A_(A.A_)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( i1 <= i2 );
+ assert( j1 <= j2);
+ assert( A.lbound() <= i1);
+ assert( i2<= A.dim(A.lbound()) + A.lbound()-1);
+ assert( A.lbound() <= j1);
+ assert( j2<= A.dim(A.lbound()+1) + A.lbound()-1 );
+#endif
+ offset_[0] = (i1 - A.lbound()) + A.offset_[0];
+ offset_[1] = (j1 - A.lbound()) + A.offset_[1];
+ dim_[0] = i2-i1 + 1;
+ dim_[1] = j2-j1+1;
+ }
+
+ Region2D<Array2D> operator()(Subscript i1, Subscript i2,
+ Subscript j1, Subscript j2)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( i1 <= i2 );
+ assert( j1 <= j2);
+ assert( A_.lbound() <= i1);
+ assert( i2<= dim_[0] + A_.lbound()-1);
+ assert( A_.lbound() <= j1);
+ assert( j2<= dim_[1] + A_.lbound()-1 );
+#endif
+ return Region2D<Array2D>(A_,
+ i1+offset_[0], offset_[0] + i2,
+ j1+offset_[1], offset_[1] + j2);
+ }
+
+
+ Region2D<Array2D> operator()(const Index1D &I,
+ const Index1D &J)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( I.lbound() <= I.ubound() );
+ assert( J.lbound() <= J.ubound() );
+ assert( A_.lbound() <= I.lbound());
+ assert( I.ubound()<= dim_[0] + A_.lbound()-1);
+ assert( A_.lbound() <= J.lbound());
+ assert( J.ubound() <= dim_[1] + A_.lbound()-1 );
+#endif
+
+ return Region2D<Array2D>(A_, I.lbound()+offset_[0],
+ offset_[0] + I.ubound(), offset_[1]+J.lbound(),
+ offset_[1] + J.ubound());
+ }
+
+ inline T & operator()(Subscript i, Subscript j)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( A_.lbound() <= i);
+ assert( i<= dim_[0] + A_.lbound()-1);
+ assert( A_.lbound() <= j);
+ assert( j<= dim_[1] + A_.lbound()-1 );
+#endif
+ return A_(i+offset_[0], j+offset_[1]);
+ }
+
+ inline const T & operator() (Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( A_.lbound() <= i);
+ assert( i<= dim_[0] + A_.lbound()-1);
+ assert( A_.lbound() <= j);
+ assert( j<= dim_[1] + A_.lbound()-1 );
+#endif
+ return A_(i+offset_[0], j+offset_[1]);
+ }
+
+
+ Region2D<Array2D> & operator=(const Region2D<Array2D> &R)
+ {
+ Subscript M = num_rows();
+ Subscript N = num_cols();
+
+ // make sure both sides conform
+ assert(M == R.num_rows());
+ assert(N == R.num_cols());
+
+
+ Subscript start = R.lbound();
+ Subscript Mend = start + M - 1;
+ Subscript Nend = start + N - 1;
+ for (Subscript i=start; i<=Mend; i++)
+ for (Subscript j=start; j<=Nend; j++)
+ (*this)(i,j) = R(i,j);
+
+ return *this;
+ }
+
+ Region2D<Array2D> & operator=(const const_Region2D<Array2D> &R)
+ {
+ Subscript M = num_rows();
+ Subscript N = num_cols();
+
+ // make sure both sides conform
+ assert(M == R.num_rows());
+ assert(N == R.num_cols());
+
+
+ Subscript start = R.lbound();
+ Subscript Mend = start + M - 1;
+ Subscript Nend = start + N - 1;
+ for (Subscript i=start; i<=Mend; i++)
+ for (Subscript j=start; j<=Nend; j++)
+ (*this)(i,j) = R(i,j);
+
+ return *this;
+ }
+
+ Region2D<Array2D> & operator=(const Array2D &R)
+ {
+ Subscript M = num_rows();
+ Subscript N = num_cols();
+
+ // make sure both sides conform
+ assert(M == R.num_rows());
+ assert(N == R.num_cols());
+
+
+ Subscript start = R.lbound();
+ Subscript Mend = start + M - 1;
+ Subscript Nend = start + N - 1;
+ for (Subscript i=start; i<=Mend; i++)
+ for (Subscript j=start; j<=Nend; j++)
+ (*this)(i,j) = R(i,j);
+
+ return *this;
+ }
+
+ Region2D<Array2D> & operator=(const T &scalar)
+ {
+ Subscript start = lbound();
+ Subscript Mend = lbound() + num_rows() - 1;
+ Subscript Nend = lbound() + num_cols() - 1;
+
+
+ for (Subscript i=start; i<=Mend; i++)
+ for (Subscript j=start; j<=Nend; j++)
+ (*this)(i,j) = scalar;
+
+ return *this;
+ }
+
+};
+
+//************************
+
+template <class Array2D>
+class const_Region2D
+{
+ protected:
+
+ const Array2D & A_;
+ Subscript offset_[2]; // 0-offset internally
+ Subscript dim_[2];
+
+ public:
+ typedef typename Array2D::value_type T;
+ typedef T value_type;
+ typedef T element_type;
+ typedef const T* const_iterator;
+ typedef const T& const_reference;
+
+ const Array2D & array() const { return A_; }
+ Subscript lbound() const { return A_.lbound(); }
+ Subscript num_rows() const { return dim_[0]; }
+ Subscript num_cols() const { return dim_[1]; }
+ Subscript offset(Subscript i) const // 1-offset
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( TNT_BASE_OFFSET <= i);
+ assert( i<= dim_[0] + TNT_BASE_OFFSET-1);
+#endif
+ return offset_[i-TNT_BASE_OFFSET];
+ }
+
+ Subscript dim(Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( TNT_BASE_OFFSET <= i);
+ assert( i<= dim_[0] + TNT_BASE_OFFSET-1);
+#endif
+ return dim_[i-TNT_BASE_OFFSET];
+ }
+
+
+ const_Region2D(const Array2D &A, Subscript i1, Subscript i2,
+ Subscript j1, Subscript j2) : A_(A)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( i1 <= i2 );
+ assert( j1 <= j2);
+ assert( TNT_BASE_OFFSET <= i1);
+ assert( i2<= A.dim(TNT_BASE_OFFSET) + TNT_BASE_OFFSET-1);
+ assert( TNT_BASE_OFFSET <= j1);
+ assert( j2<= A.dim(TNT_BASE_OFFSET+1) + TNT_BASE_OFFSET-1 );
+#endif
+
+ offset_[0] = i1-TNT_BASE_OFFSET;
+ offset_[1] = j1-TNT_BASE_OFFSET;
+ dim_[0] = i2-i1+1;
+ dim_[1] = j2-j1+1;
+ }
+
+ const_Region2D(const Array2D &A, const Index1D &I, const Index1D &J)
+ : A_(A)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( I.lbound() <= I.ubound() );
+ assert( J.lbound() <= J.ubound() );
+ assert( TNT_BASE_OFFSET <= I.lbound());
+ assert( I.ubound()<= A.dim(TNT_BASE_OFFSET) + TNT_BASE_OFFSET-1);
+ assert( TNT_BASE_OFFSET <= J.lbound());
+ assert( J.ubound() <= A.dim(TNT_BASE_OFFSET+1) + TNT_BASE_OFFSET-1 );
+#endif
+
+ offset_[0] = I.lbound()-TNT_BASE_OFFSET;
+ offset_[1] = J.lbound()-TNT_BASE_OFFSET;
+ dim_[0] = I.ubound() - I.lbound() + 1;
+ dim_[1] = J.ubound() - J.lbound() + 1;
+ }
+
+
+ const_Region2D(const_Region2D<Array2D> &A, Subscript i1,
+ Subscript i2,
+ Subscript j1, Subscript j2) : A_(A.A_)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( i1 <= i2 );
+ assert( j1 <= j2);
+ assert( TNT_BASE_OFFSET <= i1);
+ assert( i2<= A.dim(TNT_BASE_OFFSET) + TNT_BASE_OFFSET-1);
+ assert( TNT_BASE_OFFSET <= j1);
+ assert( j2<= A.dim(TNT_BASE_OFFSET+1) + TNT_BASE_OFFSET-1 );
+#endif
+ offset_[0] = (i1 - TNT_BASE_OFFSET) + A.offset_[0];
+ offset_[1] = (j1 - TNT_BASE_OFFSET) + A.offset_[1];
+ dim_[0] = i2-i1 + 1;
+ dim_[1] = j2-j1+1;
+ }
+
+ const_Region2D<Array2D> operator()(Subscript i1, Subscript i2,
+ Subscript j1, Subscript j2)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( i1 <= i2 );
+ assert( j1 <= j2);
+ assert( TNT_BASE_OFFSET <= i1);
+ assert( i2<= dim_[0] + TNT_BASE_OFFSET-1);
+ assert( TNT_BASE_OFFSET <= j1);
+ assert( j2<= dim_[0] + TNT_BASE_OFFSET-1 );
+#endif
+ return const_Region2D<Array2D>(A_,
+ i1+offset_[0], offset_[0] + i2,
+ j1+offset_[1], offset_[1] + j2);
+ }
+
+
+ const_Region2D<Array2D> operator()(const Index1D &I,
+ const Index1D &J)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( I.lbound() <= I.ubound() );
+ assert( J.lbound() <= J.ubound() );
+ assert( TNT_BASE_OFFSET <= I.lbound());
+ assert( I.ubound()<= dim_[0] + TNT_BASE_OFFSET-1);
+ assert( TNT_BASE_OFFSET <= J.lbound());
+ assert( J.ubound() <= dim_[1] + TNT_BASE_OFFSET-1 );
+#endif
+
+ return const_Region2D<Array2D>(A_, I.lbound()+offset_[0],
+ offset_[0] + I.ubound(), offset_[1]+J.lbound(),
+ offset_[1] + J.ubound());
+ }
+
+
+ inline const T & operator() (Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( TNT_BASE_OFFSET <= i);
+ assert( i<= dim_[0] + TNT_BASE_OFFSET-1);
+ assert( TNT_BASE_OFFSET <= j);
+ assert( j<= dim_[1] + TNT_BASE_OFFSET-1 );
+#endif
+ return A_(i+offset_[0], j+offset_[1]);
+ }
+
+};
+
+
+// ************** std::ostream algorithms *******************************
+
+template <class Array2D>
+std::ostream& operator<<(std::ostream &s, const const_Region2D<Array2D> &A)
+{
+ Subscript start = A.lbound();
+ Subscript Mend=A.lbound()+ A.num_rows() - 1;
+ Subscript Nend=A.lbound() + A.num_cols() - 1;
+
+
+ s << A.num_rows() << " " << A.num_cols() << "\n";
+ for (Subscript i=start; i<=Mend; i++)
+ {
+ for (Subscript j=start; j<=Nend; j++)
+ {
+ s << A(i,j) << " ";
+ }
+ s << "\n";
+ }
+
+
+ return s;
+}
+
+template <class Array2D>
+std::ostream& operator<<(std::ostream &s, const Region2D<Array2D> &A)
+{
+ Subscript start = A.lbound();
+ Subscript Mend=A.lbound()+ A.num_rows() - 1;
+ Subscript Nend=A.lbound() + A.num_cols() - 1;
+
+
+ s << A.num_rows() << " " << A.num_cols() << "\n";
+ for (Subscript i=start; i<=Mend; i++)
+ {
+ for (Subscript j=start; j<=Nend; j++)
+ {
+ s << A(i,j) << " ";
+ }
+ s << "\n";
+ }
+
+
+ return s;
+
+}
+
+} // namespace TNT
+
+#endif
+// REGION2D_H
diff --git a/inst/include/tnt/stopwatch.h b/inst/include/tnt/stopwatch.h
new file mode 100755
index 0000000..4da9372
--- /dev/null
+++ b/inst/include/tnt/stopwatch.h
@@ -0,0 +1,83 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+#ifndef STPWATCH_H
+#define STPWATCH_H
+
+// for clock() and CLOCKS_PER_SEC
+#include <ctime>
+
+namespace TNT
+{
+
+/* Simple stopwatch object:
+
+ void start() : start timing
+ double stop() : stop timing
+ void reset() : set elapsed time to 0.0
+ double read() : read elapsed time (in seconds)
+
+*/
+
+inline double seconds(void)
+{
+ static const double secs_per_tick = 1.0 / CLOCKS_PER_SEC;
+ return ( (double) clock() ) * secs_per_tick;
+}
+
+
+class stopwatch {
+ private:
+ int running;
+ double last_time;
+ double total;
+
+ public:
+ stopwatch() : running(0), last_time(0.0), total(0.0) {}
+ void reset() { running = 0; last_time = 0.0; total=0.0; }
+ void start() { if (!running) { last_time = seconds(); running = 1;}}
+ double stop() { if (running)
+ {
+ total += seconds() - last_time;
+ running = 0;
+ }
+ return total;
+ }
+ double read() { if (running)
+ {
+ total+= seconds() - last_time;
+ last_time = seconds();
+ }
+ return total;
+ }
+
+};
+
+} // namespace TNT
+
+#endif
+
+
+
diff --git a/inst/include/tnt/subscript.h b/inst/include/tnt/subscript.h
new file mode 100755
index 0000000..ab022c3
--- /dev/null
+++ b/inst/include/tnt/subscript.h
@@ -0,0 +1,58 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+#ifndef SUBSCRPT_H
+#define SUBSCRPT_H
+
+
+//---------------------------------------------------------------------
+// This definition describes the default TNT data type used for
+// indexing into TNT matrices and vectors. The data type should
+// be wide enough to index into large arrays. It defaults to an
+// "int", but can be overriden at compile time redefining TNT_SUBSCRIPT_TYPE,
+// e.g.
+//
+// g++ -DTNT_SUBSCRIPT_TYPE='unsigned int' ...
+//
+//---------------------------------------------------------------------
+//
+
+#ifndef TNT_SUBSCRIPT_TYPE
+#define TNT_SUBSCRIPT_TYPE int
+#endif
+
+namespace TNT
+{
+ typedef TNT_SUBSCRIPT_TYPE Subscript;
+}
+
+
+// () indexing in TNT means 1-offset, i.e. x(1) and A(1,1) are the
+// first elements. This offset is left as a macro for future
+// purposes, but should not be changed in the current release.
+//
+//
+#define TNT_BASE_OFFSET (1)
+
+#endif
diff --git a/inst/include/tnt/tnt.h b/inst/include/tnt/tnt.h
new file mode 100755
index 0000000..eaefae7
--- /dev/null
+++ b/inst/include/tnt/tnt.h
@@ -0,0 +1,90 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+#ifndef TNT_H
+#define TNT_H
+
+//---------------------------------------------------------------------
+// tnt.h TNT general header file. Defines default types
+// and conventions.
+//---------------------------------------------------------------------
+
+//---------------------------------------------------------------------
+// Include current version
+//---------------------------------------------------------------------
+#include "tnt/version.h"
+
+//---------------------------------------------------------------------
+// Define the data type used for matrix and vector Subscripts.
+// This will default to "int", but it can be overriden at compile time,
+// e.g.
+//
+// g++ -DTNT_SUBSCRIPT_TYPE='unsinged long' ...
+//
+// See subscript.h for details.
+//---------------------------------------------------------------------
+
+#include "tnt/subscript.h"
+
+
+
+//---------------------------------------------------------------------
+// Define this macro if you want TNT to ensure all refernces
+// are within the bounds of the array. This encurs a run-time
+// overhead, of course, but is recommended while developing
+// code. It can be turned off for production runs.
+//
+// #define TNT_BOUNDS_CHECK
+//---------------------------------------------------------------------
+//
+#define TNT_BOUNDS_CHECK
+#ifdef TNT_NO_BOUNDS_CHECK
+#undef TNT_BOUNDS_CHECK
+#endif
+
+//---------------------------------------------------------------------
+// Define this macro if you want to utilize matrix and vector
+// regions. This is typically on, but you can save some
+// compilation time by turning it off. If you do this and
+// attempt to use regions you will get an error message.
+//
+// #define TNT_USE_REGIONS
+//---------------------------------------------------------------------
+//
+#define TNT_USE_REGIONS
+
+//---------------------------------------------------------------------
+//
+//---------------------------------------------------------------------
+// if your system doesn't have abs() min(), and max() uncoment the following
+//---------------------------------------------------------------------
+//
+//
+//#define __NEED_ABS_MIN_MAX_
+
+#include "tnt/tntmath.h"
+
+
+#endif
+// TNT_H
diff --git a/inst/include/tnt/tntmath.h b/inst/include/tnt/tntmath.h
new file mode 100755
index 0000000..a607905
--- /dev/null
+++ b/inst/include/tnt/tntmath.h
@@ -0,0 +1,85 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+// Header file for scalar math functions
+
+#ifndef TNTMATH_H
+#define TNTMATH_H
+
+// conventional functions required by several matrix algorithms
+
+
+
+namespace TNT
+{
+
+inline double abs(double t)
+{
+ return ( t > 0 ? t : -t);
+}
+
+inline double min(double a, double b)
+{
+ return (a < b ? a : b);
+}
+
+inline double max(double a, double b)
+{
+ return (a > b ? a : b);
+}
+
+inline float abs(float t)
+{
+ return ( t > 0 ? t : -t);
+}
+
+inline float min(float a, float b)
+{
+ return (a < b ? a : b);
+}
+
+inline float max(float a, float b)
+{
+ return (a > b ? a : b);
+}
+
+inline double sign(double a)
+{
+ return (a > 0 ? 1.0 : -1.0);
+}
+
+
+
+inline float sign(float a)
+{
+ return (a > 0.0 ? 1.0f : -1.0f);
+}
+
+} /* namespace TNT */
+
+
+#endif
+/* TNTMATH_H */
+
diff --git a/inst/include/tnt/tntreqs.h b/inst/include/tnt/tntreqs.h
new file mode 100755
index 0000000..20b7906
--- /dev/null
+++ b/inst/include/tnt/tntreqs.h
@@ -0,0 +1,70 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+// The requirements for a bare-bones vector class:
+//
+//
+// o) must have 0-based [] indexing for const and
+// non-const objects (i.e. operator[] defined)
+//
+// o) must have size() method to denote the number of
+// elements
+// o) must clean up after itself when destructed
+// (i.e. no memory leaks)
+//
+// -) must have begin() and end() methods (The begin()
+// method is necessary, because relying on
+// &v_[0] may not work on a empty vector (i.e. v_ is NULL.)
+//
+// o) must be templated
+// o) must have X::value_type defined to be the types of elements
+// o) must have X::X(const &x) copy constructor (by *value*)
+// o) must have X::X(int N) constructor to N-length vector
+// (NOTE: this constructor need *NOT* initalize elements)
+//
+// -) must have X::X(int N, T scalar) constructor to initalize
+// elements to value of "scalar".
+//
+// ( removed, because valarray<> class uses (scalar, N) rather
+// than (N, scalar) )
+// -) must have X::X(int N, const T* scalars) constructor to copy from
+// any C linear array
+//
+// ( removed, because of same reverse order of valarray<> )
+//
+// o) must have assignment A=B, by value
+//
+// NOTE: this class is *NOT* meant to be derived from,
+// so its methods (particularly indexing) need not be
+// declared virtual.
+//
+//
+// Some things it *DOES NOT* need to do are
+//
+// o) bounds checking
+// o) array referencing (e.g. reference counting)
+// o) support () indexing
+// o) I/O
+//
diff --git a/inst/include/tnt/transv.h b/inst/include/tnt/transv.h
new file mode 100755
index 0000000..4dee8e7
--- /dev/null
+++ b/inst/include/tnt/transv.h
@@ -0,0 +1,160 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+// Matrix Transpose Views
+
+#ifndef TRANSV_H
+#define TRANSV_H
+
+#include <iostream>
+#include <cassert>
+#include "tnt/vec.h"
+
+namespace TNT
+{
+
+template <class Array2D>
+class Transpose_View
+{
+ protected:
+
+ const Array2D & A_;
+
+ public:
+
+ typedef typename Array2D::element_type T;
+ typedef T value_type;
+ typedef T element_type;
+ typedef T* pointer;
+ typedef T* iterator;
+ typedef T& reference;
+ typedef const T* const_iterator;
+ typedef const T& const_reference;
+
+
+ const Array2D & array() const { return A_; }
+ Subscript num_rows() const { return A_.num_cols();}
+ Subscript num_cols() const { return A_.num_rows();}
+ Subscript lbound() const { return A_.lbound(); }
+ Subscript dim(Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert( A_.lbound() <= i);
+ assert( i<= A_.lbound()+1);
+#endif
+ if (i== A_.lbound())
+ return num_rows();
+ else
+ return num_cols();
+ }
+
+
+ Transpose_View(const Transpose_View<Array2D> &A) : A_(A.A_) {};
+ Transpose_View(const Array2D &A) : A_(A) {};
+
+
+ inline const typename Array2D::element_type & operator()(
+ Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(lbound()<=i);
+ assert(i<=A_.num_cols() + lbound() - 1);
+ assert(lbound()<=j);
+ assert(j<=A_.num_rows() + lbound() - 1);
+#endif
+
+ return A_(j,i);
+ }
+
+
+};
+
+template <class Matrix>
+Transpose_View<Matrix> Transpose_view(const Matrix &A)
+{
+ return Transpose_View<Matrix>(A);
+}
+
+template <class Matrix, class T>
+Vector<T> matmult(
+ const Transpose_View<Matrix> & A,
+ const Vector<T> &B)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(B.dim() == N);
+
+ Vector<T> x(M);
+
+ Subscript i, j;
+ T tmp = 0;
+
+ for (i=1; i<=M; i++)
+ {
+ tmp = 0;
+ for (j=1; j<=N; j++)
+ tmp += A(i,j) * B(j);
+ x(i) = tmp;
+ }
+
+ return x;
+}
+
+template <class Matrix, class T>
+inline Vector<T> operator*(const Transpose_View<Matrix> & A, const Vector<T> &B)
+{
+ return matmult(A,B);
+}
+
+
+template <class Matrix>
+std::ostream& operator<<(std::ostream &s, const Transpose_View<Matrix> &A)
+{
+ Subscript M=A.num_rows();
+ Subscript N=A.num_cols();
+
+ Subscript start = A.lbound();
+ Subscript Mend = M + A.lbound() - 1;
+ Subscript Nend = N + A.lbound() - 1;
+
+ s << M << " " << N << endl;
+ for (Subscript i=start; i<=Mend; i++)
+ {
+ for (Subscript j=start; j<=Nend; j++)
+ {
+ s << A(i,j) << " ";
+ }
+ s << endl;
+ }
+
+
+ return s;
+}
+
+} // namespace TNT
+
+#endif
+// TRANSV_H
diff --git a/inst/include/tnt/triang.h b/inst/include/tnt/triang.h
new file mode 100755
index 0000000..796575b
--- /dev/null
+++ b/inst/include/tnt/triang.h
@@ -0,0 +1,638 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+// Triangular Matrices (Views and Adpators)
+
+#ifndef TRIANG_H
+#define TRIANG_H
+
+// default to use lower-triangular portions of arrays
+// for symmetric matrices.
+
+namespace TNT
+{
+
+template <class MaTRiX>
+class LowerTriangularView
+{
+ protected:
+
+
+ const MaTRiX &A_;
+ const typename MaTRiX::element_type zero_;
+
+ public:
+
+
+ typedef typename MaTRiX::const_reference const_reference;
+ typedef const typename MaTRiX::element_type element_type;
+ typedef const typename MaTRiX::element_type value_type;
+ typedef element_type T;
+
+ Subscript dim(Subscript d) const { return A_.dim(d); }
+ Subscript lbound() const { return A_.lbound(); }
+ Subscript num_rows() const { return A_.num_rows(); }
+ Subscript num_cols() const { return A_.num_cols(); }
+
+
+ // constructors
+
+ LowerTriangularView(/*const*/ MaTRiX &A) : A_(A), zero_(0) {}
+
+
+ inline const_reference get(Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(lbound()<=i);
+ assert(i<=A_.num_rows() + lbound() - 1);
+ assert(lbound()<=j);
+ assert(j<=A_.num_cols() + lbound() - 1);
+#endif
+ if (i<j)
+ return zero_;
+ else
+ return A_(i,j);
+ }
+
+
+ inline const_reference operator() (Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(lbound()<=i);
+ assert(i<=A_.num_rows() + lbound() - 1);
+ assert(lbound()<=j);
+ assert(j<=A_.num_cols() + lbound() - 1);
+#endif
+ if (i<j)
+ return zero_;
+ else
+ return A_(i,j);
+ }
+
+#ifdef TNT_USE_REGIONS
+
+ typedef const_Region2D< LowerTriangularView<MaTRiX> >
+ const_Region;
+
+ const_Region operator()(/*const*/ Index1D &I,
+ /*const*/ Index1D &J) const
+ {
+ return const_Region(*this, I, J);
+ }
+
+ const_Region operator()(Subscript i1, Subscript i2,
+ Subscript j1, Subscript j2) const
+ {
+ return const_Region(*this, i1, i2, j1, j2);
+ }
+
+
+
+#endif
+// TNT_USE_REGIONS
+
+};
+
+
+/* *********** Lower_triangular_view() algorithms ****************** */
+
+template <class MaTRiX, class VecToR>
+VecToR matmult(/*const*/ LowerTriangularView<MaTRiX> &A, VecToR &x)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(N == x.dim());
+
+ Subscript i, j;
+ typename MaTRiX::element_type sum=0.0;
+ VecToR result(M);
+
+ Subscript start = A.lbound();
+ Subscript Mend = M + A.lbound() -1 ;
+
+ for (i=start; i<=Mend; i++)
+ {
+ sum = 0.0;
+ for (j=start; j<=i; j++)
+ sum = sum + A(i,j)*x(j);
+ result(i) = sum;
+ }
+
+ return result;
+}
+
+template <class MaTRiX, class VecToR>
+inline VecToR operator*(/*const*/ LowerTriangularView<MaTRiX> &A, VecToR &x)
+{
+ return matmult(A,x);
+}
+
+template <class MaTRiX>
+class UnitLowerTriangularView
+{
+ protected:
+
+ const MaTRiX &A_;
+ const typename MaTRiX::element_type zero;
+ const typename MaTRiX::element_type one;
+
+ public:
+
+ typedef typename MaTRiX::const_reference const_reference;
+ typedef typename MaTRiX::element_type element_type;
+ typedef typename MaTRiX::element_type value_type;
+ typedef element_type T;
+
+ Subscript lbound() const { return 1; }
+ Subscript dim(Subscript d) const { return A_.dim(d); }
+ Subscript num_rows() const { return A_.num_rows(); }
+ Subscript num_cols() const { return A_.num_cols(); }
+
+
+ // constructors
+
+ UnitLowerTriangularView(/*const*/ MaTRiX &A) : A_(A), zero(0), one(1) {}
+
+
+ inline const_reference get(Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i<=A_.dim(1));
+ assert(1<=j);
+ assert(j<=A_.dim(2));
+ assert(0<=i && i<A_.dim(0) && 0<=j && j<A_.dim(1));
+#endif
+ if (i>j)
+ return A_(i,j);
+ else if (i==j)
+ return one;
+ else
+ return zero;
+ }
+
+
+ inline const_reference operator() (Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i<=A_.dim(1));
+ assert(1<=j);
+ assert(j<=A_.dim(2));
+#endif
+ if (i>j)
+ return A_(i,j);
+ else if (i==j)
+ return one;
+ else
+ return zero;
+ }
+
+
+#ifdef TNT_USE_REGIONS
+ // These are the "index-aware" features
+
+ typedef const_Region2D< UnitLowerTriangularView<MaTRiX> >
+ const_Region;
+
+ const_Region operator()(/*const*/ Index1D &I,
+ /*const*/ Index1D &J) const
+ {
+ return const_Region(*this, I, J);
+ }
+
+ const_Region operator()(Subscript i1, Subscript i2,
+ Subscript j1, Subscript j2) const
+ {
+ return const_Region(*this, i1, i2, j1, j2);
+ }
+#endif
+// TNT_USE_REGIONS
+};
+
+template <class MaTRiX>
+LowerTriangularView<MaTRiX> Lower_triangular_view(
+ /*const*/ MaTRiX &A)
+{
+ return LowerTriangularView<MaTRiX>(A);
+}
+
+
+template <class MaTRiX>
+UnitLowerTriangularView<MaTRiX> Unit_lower_triangular_view(
+ /*const*/ MaTRiX &A)
+{
+ return UnitLowerTriangularView<MaTRiX>(A);
+}
+
+template <class MaTRiX, class VecToR>
+VecToR matmult(const UnitLowerTriangularView<MaTRiX> &A, VecToR &x)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(N == x.dim());
+
+ Subscript i, j;
+ typename MaTRiX::element_type sum=0.0;
+ VecToR result(M);
+
+ Subscript start = A.lbound();
+ Subscript Mend = M + A.lbound() -1 ;
+
+ for (i=start; i<=Mend; i++)
+ {
+ sum = 0.0;
+ for (j=start; j<i; j++)
+ sum = sum + A(i,j)*x(j);
+ result(i) = sum + x(i);
+ }
+
+ return result;
+}
+
+template <class MaTRiX, class VecToR>
+inline VecToR operator*(const UnitLowerTriangularView<MaTRiX> &A, VecToR &x)
+{
+ return matmult(A,x);
+}
+
+
+//********************** Algorithms *************************************
+
+
+
+template <class MaTRiX>
+std::ostream& operator<<(std::ostream &s, const LowerTriangularView<MaTRiX>&A)
+{
+ Subscript M=A.num_rows();
+ Subscript N=A.num_cols();
+
+ s << M << " " << N << endl;
+
+ for (Subscript i=1; i<=M; i++)
+ {
+ for (Subscript j=1; j<=N; j++)
+ {
+ s << A(i,j) << " ";
+ }
+ s << endl;
+ }
+
+
+ return s;
+}
+
+template <class MaTRiX>
+std::ostream& operator<<(std::ostream &s,
+ const UnitLowerTriangularView<MaTRiX>&A)
+{
+ Subscript M=A.num_rows();
+ Subscript N=A.num_cols();
+
+ s << M << " " << N << endl;
+
+ for (Subscript i=1; i<=M; i++)
+ {
+ for (Subscript j=1; j<=N; j++)
+ {
+ s << A(i,j) << " ";
+ }
+ s << endl;
+ }
+
+
+ return s;
+}
+
+
+
+// ******************* Upper Triangular Section **************************
+
+template <class MaTRiX>
+class UpperTriangularView
+{
+ protected:
+
+
+ /*const*/ MaTRiX &A_;
+ /*const*/ typename MaTRiX::element_type zero_;
+
+ public:
+
+
+ typedef typename MaTRiX::const_reference const_reference;
+ typedef /*const*/ typename MaTRiX::element_type element_type;
+ typedef /*const*/ typename MaTRiX::element_type value_type;
+ typedef element_type T;
+
+ Subscript dim(Subscript d) const { return A_.dim(d); }
+ Subscript lbound() const { return A_.lbound(); }
+ Subscript num_rows() const { return A_.num_rows(); }
+ Subscript num_cols() const { return A_.num_cols(); }
+
+
+ // constructors
+
+ UpperTriangularView(/*const*/ MaTRiX &A) : A_(A), zero_(0) {}
+
+
+ inline const_reference get(Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(lbound()<=i);
+ assert(i<=A_.num_rows() + lbound() - 1);
+ assert(lbound()<=j);
+ assert(j<=A_.num_cols() + lbound() - 1);
+#endif
+ if (i>j)
+ return zero_;
+ else
+ return A_(i,j);
+ }
+
+
+ inline const_reference operator() (Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(lbound()<=i);
+ assert(i<=A_.num_rows() + lbound() - 1);
+ assert(lbound()<=j);
+ assert(j<=A_.num_cols() + lbound() - 1);
+#endif
+ if (i>j)
+ return zero_;
+ else
+ return A_(i,j);
+ }
+
+#ifdef TNT_USE_REGIONS
+
+ typedef const_Region2D< UpperTriangularView<MaTRiX> >
+ const_Region;
+
+ const_Region operator()(const Index1D &I,
+ const Index1D &J) const
+ {
+ return const_Region(*this, I, J);
+ }
+
+ const_Region operator()(Subscript i1, Subscript i2,
+ Subscript j1, Subscript j2) const
+ {
+ return const_Region(*this, i1, i2, j1, j2);
+ }
+
+
+
+#endif
+// TNT_USE_REGIONS
+
+};
+
+
+/* *********** Upper_triangular_view() algorithms ****************** */
+
+template <class MaTRiX, class VecToR>
+VecToR matmult(/*const*/ UpperTriangularView<MaTRiX> &A, VecToR &x)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(N == x.dim());
+
+ Subscript i, j;
+ typename VecToR::element_type sum=0.0;
+ VecToR result(M);
+
+ Subscript start = A.lbound();
+ Subscript Mend = M + A.lbound() -1 ;
+
+ for (i=start; i<=Mend; i++)
+ {
+ sum = 0.0;
+ for (j=i; j<=N; j++)
+ sum = sum + A(i,j)*x(j);
+ result(i) = sum;
+ }
+
+ return result;
+}
+
+template <class MaTRiX, class VecToR>
+inline VecToR operator*(/*const*/ UpperTriangularView<MaTRiX> &A, VecToR &x)
+{
+ return matmult(A,x);
+}
+
+template <class MaTRiX>
+class UnitUpperTriangularView
+{
+ protected:
+
+ const MaTRiX &A_;
+ const typename MaTRiX::element_type zero;
+ const typename MaTRiX::element_type one;
+
+ public:
+
+ typedef typename MaTRiX::const_reference const_reference;
+ typedef typename MaTRiX::element_type element_type;
+ typedef typename MaTRiX::element_type value_type;
+ typedef element_type T;
+
+ Subscript lbound() const { return 1; }
+ Subscript dim(Subscript d) const { return A_.dim(d); }
+ Subscript num_rows() const { return A_.num_rows(); }
+ Subscript num_cols() const { return A_.num_cols(); }
+
+
+ // constructors
+
+ UnitUpperTriangularView(/*const*/ MaTRiX &A) : A_(A), zero(0), one(1) {}
+
+
+ inline const_reference get(Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i<=A_.dim(1));
+ assert(1<=j);
+ assert(j<=A_.dim(2));
+ assert(0<=i && i<A_.dim(0) && 0<=j && j<A_.dim(1));
+#endif
+ if (i<j)
+ return A_(i,j);
+ else if (i==j)
+ return one;
+ else
+ return zero;
+ }
+
+
+ inline const_reference operator() (Subscript i, Subscript j) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i<=A_.dim(1));
+ assert(1<=j);
+ assert(j<=A_.dim(2));
+#endif
+ if (i<j)
+ return A_(i,j);
+ else if (i==j)
+ return one;
+ else
+ return zero;
+ }
+
+
+#ifdef TNT_USE_REGIONS
+ // These are the "index-aware" features
+
+ typedef const_Region2D< UnitUpperTriangularView<MaTRiX> >
+ const_Region;
+
+ const_Region operator()(const Index1D &I,
+ const Index1D &J) const
+ {
+ return const_Region(*this, I, J);
+ }
+
+ const_Region operator()(Subscript i1, Subscript i2,
+ Subscript j1, Subscript j2) const
+ {
+ return const_Region(*this, i1, i2, j1, j2);
+ }
+#endif
+// TNT_USE_REGIONS
+};
+
+template <class MaTRiX>
+UpperTriangularView<MaTRiX> Upper_triangular_view(
+ /*const*/ MaTRiX &A)
+{
+ return UpperTriangularView<MaTRiX>(A);
+}
+
+
+template <class MaTRiX>
+UnitUpperTriangularView<MaTRiX> Unit_upper_triangular_view(
+ /*const*/ MaTRiX &A)
+{
+ return UnitUpperTriangularView<MaTRiX>(A);
+}
+
+template <class MaTRiX, class VecToR>
+VecToR matmult(/*const*/ UnitUpperTriangularView<MaTRiX> &A, VecToR &x)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(N == x.dim());
+
+ Subscript i, j;
+ typename VecToR::element_type sum=0.0;
+ VecToR result(M);
+
+ Subscript start = A.lbound();
+ Subscript Mend = M + A.lbound() -1 ;
+
+ for (i=start; i<=Mend; i++)
+ {
+ sum = x(i);
+ for (j=i+1; j<=N; j++)
+ sum = sum + A(i,j)*x(j);
+ result(i) = sum + x(i);
+ }
+
+ return result;
+}
+
+template <class MaTRiX, class VecToR>
+inline VecToR operator*(/*const*/ UnitUpperTriangularView<MaTRiX> &A, VecToR &x)
+{
+ return matmult(A,x);
+}
+
+
+//********************** Algorithms *************************************
+
+
+
+template <class MaTRiX>
+std::ostream& operator<<(std::ostream &s,
+ /*const*/ UpperTriangularView<MaTRiX>&A)
+{
+ Subscript M=A.num_rows();
+ Subscript N=A.num_cols();
+
+ s << M << " " << N << endl;
+
+ for (Subscript i=1; i<=M; i++)
+ {
+ for (Subscript j=1; j<=N; j++)
+ {
+ s << A(i,j) << " ";
+ }
+ s << endl;
+ }
+
+
+ return s;
+}
+
+template <class MaTRiX>
+std::ostream& operator<<(std::ostream &s,
+ /*const*/ UnitUpperTriangularView<MaTRiX>&A)
+{
+ Subscript M=A.num_rows();
+ Subscript N=A.num_cols();
+
+ s << M << " " << N << endl;
+
+ for (Subscript i=1; i<=M; i++)
+ {
+ for (Subscript j=1; j<=N; j++)
+ {
+ s << A(i,j) << " ";
+ }
+ s << endl;
+ }
+
+
+ return s;
+}
+
+} // namespace TNT
+
+
+
+
+
+#endif
+//TRIANG_H
+
diff --git a/inst/include/tnt/trisolve.h b/inst/include/tnt/trisolve.h
new file mode 100755
index 0000000..6822b9a
--- /dev/null
+++ b/inst/include/tnt/trisolve.h
@@ -0,0 +1,184 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+// Triangular Solves
+
+#ifndef TRISLV_H
+#define TRISLV_H
+
+
+#include "triang.h"
+
+namespace TNT
+{
+
+template <class MaTriX, class VecToR>
+VecToR Lower_triangular_solve(const MaTriX &A, const VecToR &b)
+{
+ Subscript N = A.num_rows();
+
+ // make sure matrix sizes agree; A must be square
+
+ assert(A.num_cols() == N);
+ assert(b.dim() == N);
+
+ VecToR x(N);
+
+ Subscript i;
+ for (i=1; i<=N; i++)
+ {
+ typename MaTriX::element_type tmp=0;
+
+ for (Subscript j=1; j<i; j++)
+ tmp = tmp + A(i,j)*x(j);
+
+ x(i) = (b(i) - tmp)/ A(i,i);
+ }
+
+ return x;
+}
+
+
+template <class MaTriX, class VecToR>
+VecToR Unit_lower_triangular_solve(const MaTriX &A, const VecToR &b)
+{
+ Subscript N = A.num_rows();
+
+ // make sure matrix sizes agree; A must be square
+
+ assert(A.num_cols() == N);
+ assert(b.dim() == N);
+
+ VecToR x(N);
+
+ Subscript i;
+ for (i=1; i<=N; i++)
+ {
+
+ typename MaTriX::element_type tmp=0;
+
+ for (Subscript j=1; j<i; j++)
+ tmp = tmp + A(i,j)*x(j);
+
+ x(i) = b(i) - tmp;
+ }
+
+ return x;
+}
+
+
+template <class MaTriX, class VecToR>
+VecToR linear_solve(const LowerTriangularView<MaTriX> &A,
+ const VecToR &b)
+{
+ return Lower_triangular_solve(A, b);
+}
+
+template <class MaTriX, class VecToR>
+VecToR linear_solve(const UnitLowerTriangularView<MaTriX> &A,
+ const VecToR &b)
+{
+ return Unit_lower_triangular_solve(A, b);
+}
+
+
+
+//********************** Upper triangular section ****************
+
+template <class MaTriX, class VecToR>
+VecToR Upper_triangular_solve(const MaTriX &A, const VecToR &b)
+{
+ Subscript N = A.num_rows();
+
+ // make sure matrix sizes agree; A must be square
+
+ assert(A.num_cols() == N);
+ assert(b.dim() == N);
+
+ VecToR x(N);
+
+ Subscript i;
+ for (i=N; i>=1; i--)
+ {
+
+ typename MaTriX::element_type tmp=0;
+
+ for (Subscript j=i+1; j<=N; j++)
+ tmp = tmp + A(i,j)*x(j);
+
+ x(i) = (b(i) - tmp)/ A(i,i);
+ }
+
+ return x;
+}
+
+
+template <class MaTriX, class VecToR>
+VecToR Unit_upper_triangular_solve(const MaTriX &A, const VecToR &b)
+{
+ Subscript N = A.num_rows();
+
+ // make sure matrix sizes agree; A must be square
+
+ assert(A.num_cols() == N);
+ assert(b.dim() == N);
+
+ VecToR x(N);
+
+ Subscript i;
+ for (i=N; i>=1; i--)
+ {
+
+ typename MaTriX::element_type tmp=0;
+
+ for (Subscript j=i+1; j<i; j++)
+ tmp = tmp + A(i,j)*x(j);
+
+ x(i) = b(i) - tmp;
+ }
+
+ return x;
+}
+
+
+template <class MaTriX, class VecToR>
+VecToR linear_solve(const UpperTriangularView<MaTriX> &A,
+ const VecToR &b)
+{
+ return Upper_triangular_solve(A, b);
+}
+
+template <class MaTriX, class VecToR>
+VecToR linear_solve(const UnitUpperTriangularView<MaTriX> &A,
+ const VecToR &b)
+{
+ return Unit_upper_triangular_solve(A, b);
+}
+
+
+} // namespace TNT
+
+#endif
+// TRISLV_H
diff --git a/inst/include/tnt/vec.h b/inst/include/tnt/vec.h
new file mode 100755
index 0000000..91c96ed
--- /dev/null
+++ b/inst/include/tnt/vec.h
@@ -0,0 +1,403 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+// Basic TNT numerical vector (0-based [i] AND 1-based (i) indexing )
+//
+
+#ifndef VEC_H
+#define VEC_H
+
+#include "tnt/subscript.h"
+#include <cstdlib>
+#include <cassert>
+#include <iostream>
+#include <sstream>
+
+namespace TNT
+{
+
+template <class T>
+class Vector
+{
+
+
+ public:
+
+ typedef Subscript size_type;
+ typedef T value_type;
+ typedef T element_type;
+ typedef T* pointer;
+ typedef T* iterator;
+ typedef T& reference;
+ typedef const T* const_iterator;
+ typedef const T& const_reference;
+
+ Subscript lbound() const { return 1;}
+
+ protected:
+ T* v_;
+ T* vm1_; // pointer adjustment for optimzied 1-offset indexing
+ Subscript n_;
+
+ // internal helper function to create the array
+ // of row pointers
+
+ void initialize(Subscript N)
+ {
+ // adjust pointers so that they are 1-offset:
+ // v_[] is the internal contiguous array, it is still 0-offset
+ //
+ assert(v_ == NULL);
+ v_ = new T[N];
+ assert(v_ != NULL);
+ vm1_ = v_-1;
+ n_ = N;
+ }
+
+ void copy(const T* v)
+ {
+ Subscript N = n_;
+ Subscript i;
+
+#ifdef TNT_UNROLL_LOOPS
+ Subscript Nmod4 = N & 3;
+ Subscript N4 = N - Nmod4;
+
+ for (i=0; i<N4; i+=4)
+ {
+ v_[i] = v[i];
+ v_[i+1] = v[i+1];
+ v_[i+2] = v[i+2];
+ v_[i+3] = v[i+3];
+ }
+
+ for (i=N4; i< N; i++)
+ v_[i] = v[i];
+#else
+
+ for (i=0; i< N; i++)
+ v_[i] = v[i];
+#endif
+ }
+
+ void set(const T& val)
+ {
+ Subscript N = n_;
+ Subscript i;
+
+#ifdef TNT_UNROLL_LOOPS
+ Subscript Nmod4 = N & 3;
+ Subscript N4 = N - Nmod4;
+
+ for (i=0; i<N4; i+=4)
+ {
+ v_[i] = val;
+ v_[i+1] = val;
+ v_[i+2] = val;
+ v_[i+3] = val;
+ }
+
+ for (i=N4; i< N; i++)
+ v_[i] = val;
+#else
+
+ for (i=0; i< N; i++)
+ v_[i] = val;
+
+#endif
+ }
+
+
+
+ void destroy()
+ {
+ /* do nothing, if no memory has been previously allocated */
+ if (v_ == NULL) return ;
+
+ /* if we are here, then matrix was previously allocated */
+ delete [] (v_);
+
+ v_ = NULL;
+ vm1_ = NULL;
+ }
+
+
+ public:
+
+ // access
+
+ iterator begin() { return v_;}
+ iterator end() { return v_ + n_; }
+ const iterator begin() const { return v_;}
+ const iterator end() const { return v_ + n_; }
+
+ // destructor
+
+ ~Vector()
+ {
+ destroy();
+ }
+
+ // constructors
+
+ Vector() : v_(0), vm1_(0), n_(0) {};
+
+ Vector(const Vector<T> &A) : v_(0), vm1_(0), n_(0)
+ {
+ initialize(A.n_);
+ copy(A.v_);
+ }
+
+ Vector(Subscript N, const T& value = T()) : v_(0), vm1_(0), n_(0)
+ {
+ initialize(N);
+ set(value);
+ }
+
+ Vector(Subscript N, const T* v) : v_(0), vm1_(0), n_(0)
+ {
+ initialize(N);
+ copy(v);
+ }
+
+ Vector(Subscript N, char *s) : v_(0), vm1_(0), n_(0)
+ {
+ initialize(N);
+ std::istringstream ins(s);
+
+ Subscript i;
+
+ for (i=0; i<N; i++)
+ ins >> v_[i];
+ }
+
+
+ // methods
+ //
+ Vector<T>& newsize(Subscript N)
+ {
+ if (n_ == N) return *this;
+
+ destroy();
+ initialize(N);
+
+ return *this;
+ }
+
+
+ // assignments
+ //
+ Vector<T>& operator=(const Vector<T> &A)
+ {
+ if (v_ == A.v_)
+ return *this;
+
+ if (n_ == A.n_) // no need to re-alloc
+ copy(A.v_);
+
+ else
+ {
+ destroy();
+ initialize(A.n_);
+ copy(A.v_);
+ }
+
+ return *this;
+ }
+
+ Vector<T>& operator=(const T& scalar)
+ {
+ set(scalar);
+ return *this;
+ }
+
+ inline Subscript dim() const
+ {
+ return n_;
+ }
+
+ inline Subscript size() const
+ {
+ return n_;
+ }
+
+
+ inline reference operator()(Subscript i)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i <= n_) ;
+#endif
+ return vm1_[i];
+ }
+
+ inline const_reference operator() (Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i <= n_) ;
+#endif
+ return vm1_[i];
+ }
+
+ inline reference operator[](Subscript i)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(0<=i);
+ assert(i < n_) ;
+#endif
+ return v_[i];
+ }
+
+ inline const_reference operator[](Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(0<=i);
+
+
+
+
+
+
+ assert(i < n_) ;
+#endif
+ return v_[i];
+ }
+
+
+
+};
+
+
+/* *************************** I/O ********************************/
+
+template <class T>
+std::ostream& operator<<(std::ostream &s, const Vector<T> &A)
+{
+ Subscript N=A.dim();
+
+ s << N << endl;
+
+ for (Subscript i=0; i<N; i++)
+ s << A[i] << " " << endl;
+ s << endl;
+
+ return s;
+}
+
+template <class T>
+std::istream & operator>>(std::istream &s, Vector<T> &A)
+{
+
+ Subscript N;
+
+ s >> N;
+
+ if ( !(N == A.size() ))
+ {
+ A.newsize(N);
+ }
+
+
+ for (Subscript i=0; i<N; i++)
+ s >> A[i];
+
+
+ return s;
+}
+
+// *******************[ basic matrix algorithms ]***************************
+
+
+template <class T>
+Vector<T> operator+(const Vector<T> &A,
+ const Vector<T> &B)
+{
+ Subscript N = A.dim();
+
+ assert(N==B.dim());
+
+ Vector<T> tmp(N);
+ Subscript i;
+
+ for (i=0; i<N; i++)
+ tmp[i] = A[i] + B[i];
+
+ return tmp;
+}
+
+template <class T>
+Vector<T> operator-(const Vector<T> &A,
+ const Vector<T> &B)
+{
+ Subscript N = A.dim();
+
+ assert(N==B.dim());
+
+ Vector<T> tmp(N);
+ Subscript i;
+
+ for (i=0; i<N; i++)
+ tmp[i] = A[i] - B[i];
+
+ return tmp;
+}
+
+template <class T>
+Vector<T> operator*(const Vector<T> &A,
+ const Vector<T> &B)
+{
+ Subscript N = A.dim();
+
+ assert(N==B.dim());
+
+ Vector<T> tmp(N);
+ Subscript i;
+
+ for (i=0; i<N; i++)
+ tmp[i] = A[i] * B[i];
+
+ return tmp;
+}
+
+
+template <class T>
+T dot_prod(const Vector<T> &A, const Vector<T> &B)
+{
+ Subscript N = A.dim();
+ assert(N == B.dim());
+
+ Subscript i;
+ T sum = 0;
+
+ for (i=0; i<N; i++)
+ sum += A[i] * B[i];
+
+ return sum;
+}
+
+} /* namespace TNT */
+
+#endif
+// VEC_H
diff --git a/inst/include/tnt/vecadaptor.h b/inst/include/tnt/vecadaptor.h
new file mode 100755
index 0000000..c4d8c72
--- /dev/null
+++ b/inst/include/tnt/vecadaptor.h
@@ -0,0 +1,289 @@
+/*
+*
+* Template Numerical Toolkit (TNT): Linear Algebra Module
+*
+* Mathematical and Computational Sciences Division
+* National Institute of Technology,
+* Gaithersburg, MD USA
+*
+*
+* This software was developed at the National Institute of Standards and
+* Technology (NIST) by employees of the Federal Government in the course
+* of their official duties. Pursuant to title 17 Section 105 of the
+* United States Code, this software is not subject to copyright protection
+* and is in the public domain. The Template Numerical Toolkit (TNT) is
+* an experimental system. NIST assumes no responsibility whatsoever for
+* its use by other parties, and makes no guarantees, expressed or implied,
+* about its quality, reliability, or any other characteristic.
+*
+* BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+* see http://math.nist.gov/tnt for latest updates.
+*
+*/
+
+
+
+#ifndef VECADAPTOR_H
+#define VECADAPTOR_H
+
+#include <cstdlib>
+#include <iostream>
+#include <strstream>
+#include <cassert>
+
+#include "tnt/subscript.h"
+
+#ifdef TNT_USE_REGIONS
+#include "tnt/region1d.h"
+#endif
+
+namespace TNT
+{
+
+// see "tntreq.h" for TNT requirements for underlying vector
+// class. This need NOT be the STL vector<> class, but a subset
+// that provides minimal services.
+//
+// This is a container adaptor that provides the following services.
+//
+// o) adds 1-offset operator() access ([] is always 0 offset)
+// o) adds TNT_BOUNDS_CHECK to () and []
+// o) adds initialization from strings, e.g. "1.0 2.0 3.0";
+// o) adds newsize(N) function (does not preserve previous values)
+// o) adds dim() and dim(1)
+// o) adds free() function to release memory used by vector
+// o) adds regions, e.g. A(Index(1,10)) = ...
+// o) add getVector() method to return adapted container
+// o) adds simple I/O for ostreams
+
+template <class BBVec>
+class Vector_Adaptor
+{
+
+ public:
+ typedef typename BBVec::value_type T;
+ typedef T value_type;
+ typedef T element_type;
+ typedef T* pointer;
+ typedef T* iterator;
+ typedef T& reference;
+ typedef const T* const_iterator;
+ typedef const T& const_reference;
+
+ Subscript lbound() const { return 1; }
+
+ protected:
+ BBVec v_;
+ T* vm1_;
+
+ public:
+
+ Subscript size() const { return v_.size(); }
+
+ // These were removed so that the ANSI C++ valarray class
+ // would work as a possible storage container.
+ //
+ //
+ //iterator begin() { return v_.begin();}
+ //iterator begin() { return &v_[0];}
+ //
+ //iterator end() { return v_.end(); }
+ //iterator end() { return &v_[0] + v_.size(); }
+ //
+ //const_iterator begin() const { return v_.begin();}
+ //const_iterator begin() const { return &v_[0];}
+ //
+ //const_iterator end() const { return v_.end(); }
+ //const_iterator end() const { return &v_[0] + v_.size(); }
+
+ BBVec& getVector() { return v_; }
+ Subscript dim() const { return v_.size(); }
+ Subscript dim(Subscript i)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(i==TNT_BASE_OFFSET);
+#endif
+ return (i==TNT_BASE_OFFSET ? v_.size() : 0 );
+ }
+ Vector_Adaptor() : v_() {};
+ Vector_Adaptor(const Vector_Adaptor<BBVec> &A) : v_(A.v_)
+ {
+ vm1_ = ( v_.size() > 0 ? &(v_[0]) -1 : NULL);
+
+ }
+
+ Vector_Adaptor(Subscript N, /*const*/ char *s) : v_(N)
+ {
+ istrstream ins(s);
+ for (Subscript i=0; i<N; i++)
+ ins >> v_[i] ;
+
+ vm1_ = ( v_.size() > 0 ? &(v_[0]) -1 : NULL);
+ };
+
+ Vector_Adaptor(Subscript N, const T& value = T()) : v_(N)
+ {
+ for (Subscript i=0; i<N; i++)
+ v_[i] = value;
+
+ vm1_ = ( v_.size() > 0 ? &(v_[0]) -1 : NULL);
+ }
+
+ Vector_Adaptor(Subscript N, const T* values) : v_(N)
+ {
+ for (Subscript i=0; i<N; i++)
+ v_[i] = values[i];
+ vm1_ = ( v_.size() > 0 ? &(v_[0]) -1 : NULL);
+ }
+ Vector_Adaptor(const BBVec & A) : v_(A)
+ {
+ vm1_ = ( v_.size() > 0 ? &(v_[0]) -1 : NULL);
+ }
+
+ // NOTE: this assumes that BBVec(0) constructor creates an
+ // null vector that does not take up space... It would be
+ // great to require that BBVec have a corresponding free()
+ // function, but in particular STL vectors do not.
+ //
+ Vector_Adaptor<BBVec>& free()
+ {
+ return *this = Vector_Adaptor<BBVec>(0);
+ }
+
+ Vector_Adaptor<BBVec>& operator=(const Vector_Adaptor<BBVec> &A)
+ {
+ v_ = A.v_ ;
+ vm1_ = ( v_.size() > 0 ? &(v_[0]) -1 : NULL);
+ return *this;
+ }
+
+ Vector_Adaptor<BBVec>& newsize(Subscript N)
+ {
+ // NOTE: this is not as efficient as it could be
+ // but to retain compatiblity with STL interface
+ // we cannot assume underlying implementation
+ // has a newsize() function.
+
+ return *this = Vector_Adaptor<BBVec>(N);
+
+ }
+
+ Vector_Adaptor<BBVec>& operator=(const T &a)
+ {
+ Subscript i;
+ Subscript N = v_.size();
+ for (i=0; i<N; i++)
+ v_[i] = a;
+
+ return *this;
+ }
+
+ Vector_Adaptor<BBVec>& resize(Subscript N)
+ {
+ if (N == size()) return *this;
+
+ Vector_Adaptor<BBVec> tmp(N);
+ Subscript n = (N < size() ? N : size()); // min(N, size());
+ Subscript i;
+
+ for (i=0; i<n; i++)
+ tmp[i] = v_[i];
+
+
+ return (*this = tmp);
+
+ }
+
+
+ reference operator()(Subscript i)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i<=dim());
+#endif
+ return vm1_[i];
+ }
+
+ const_reference operator()(Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(1<=i);
+ assert(i<=dim());
+#endif
+ return vm1_[i];
+ }
+
+ reference operator[](Subscript i)
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(0<=i);
+ assert(i<dim());
+#endif
+ return v_[i];
+ }
+
+ const_reference operator[](Subscript i) const
+ {
+#ifdef TNT_BOUNDS_CHECK
+ assert(0<=i);
+ assert(i<dim());
+#endif
+ return v_[i];
+ }
+
+
+#ifdef TNT_USE_REGIONS
+ // "index-aware" features, all of these are 1-based offsets
+
+ typedef Region1D<Vector_Adaptor<BBVec> > Region;
+
+ typedef const_Region1D< Vector_Adaptor<BBVec> > const_Region;
+
+ Region operator()(const Index1D &I)
+ { return Region(*this, I); }
+
+ Region operator()(const Subscript i1, Subscript i2)
+ { return Region(*this, i1, i2); }
+
+ const_Region operator()(const Index1D &I) const
+ { return const_Region(*this, I); }
+
+ const_Region operator()(const Subscript i1, Subscript i2) const
+ { return const_Region(*this, i1, i2); }
+#endif
+// TNT_USE_REGIONS
+
+
+};
+
+#include <iostream>
+
+template <class BBVec>
+std::ostream& operator<<(std::ostream &s, const Vector_Adaptor<BBVec> &A)
+{
+ Subscript M=A.size();
+
+ s << M << endl;
+ for (Subscript i=1; i<=M; i++)
+ s << A(i) << endl;
+ return s;
+}
+
+template <class BBVec>
+std::istream& operator>>(std::istream &s, Vector_Adaptor<BBVec> &A)
+{
+ Subscript N;
+
+ s >> N;
+
+ A.resize(N);
+
+ for (Subscript i=1; i<=N; i++)
+ s >> A(i);
+
+ return s;
+}
+
+} // namespace TNT
+
+#endif
diff --git a/inst/include/tnt/version.h b/inst/include/tnt/version.h
new file mode 100755
index 0000000..b4c7953
--- /dev/null
+++ b/inst/include/tnt/version.h
@@ -0,0 +1,20 @@
+// Template Numerical Toolkit (TNT) for Linear Algebra
+//
+// BETA VERSION INCOMPLETE AND SUBJECT TO CHANGE
+// Please see http://math.nist.gov/tnt for updates
+//
+// R. Pozo
+// Mathematical and Computational Sciences Division
+// National Institute of Standards and Technology
+
+
+#ifndef TNT_VERSION_H
+#define TNT_VERSION_H
+
+
+#define TNT_MAJOR_VERSION '0'
+#define TNT_MINOR_VERSION '9'
+#define TNT_SUBMINOR_VERSION '4'
+#define TNT_VERSION_STRING "0.9.4"
+
+#endif
diff --git a/inst/include/tntsupp.h b/inst/include/tntsupp.h
new file mode 100755
index 0000000..bbd4545
--- /dev/null
+++ b/inst/include/tntsupp.h
@@ -0,0 +1,556 @@
+#ifndef TNTSUPP_H
+#define TNTSUPP_H
+
+using namespace std;
+
+#include <iostream>
+#include "tnt/subscript.h"
+#include "tnt/tnt.h"
+#include "tnt/vec.h"
+#include "tnt/fmat.h"
+#include "tnt/region1d.h"
+#include "tnt/region2d.h"
+#include "tnt/transv.h"
+#include "tnt/lu.h"
+
+
+
+namespace TNT
+{
+
+typedef Vector<double> DVector;
+typedef Vector<int> IVector;
+typedef Fortran_Matrix<double> DMatrix;
+
+template <class T>
+inline T fmin(T a, T b)
+{
+ return (a < b ? a : b);
+}
+
+template <class T>
+inline T fmax(T a, T b)
+{
+ return (a > b ? a : b);
+}
+
+//typedef Region1D<DVector> subDVector;
+//typedef Region2D<DMatrix> subDMatrix;
+
+//matrix operation on Region2D;
+
+template <class T>
+Fortran_Matrix<T> operator+(const_Region2D<Fortran_Matrix<T> > &A,
+ const_Region2D<Fortran_Matrix<T> > &B) {
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(M==B.num_rows());
+ assert(N==B.num_cols());
+
+ Fortran_Matrix<T> ans(M, N);
+ for (Subscript i = 1; i <= M; i++)
+ for (Subscript j = 1; j <= N; j++)
+ ans(i, j) = A(i, j) + B(i, j);
+ return ans;
+}
+
+template <class T>
+Fortran_Matrix<T> operator+(const Region2D<Fortran_Matrix<T> > &A,
+ const Region2D<Fortran_Matrix<T> > &B) {
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(M==B.num_rows());
+ assert(N==B.num_cols());
+
+ Fortran_Matrix<T> ans(M, N);
+ for (Subscript i = 1; i <= M; i++)
+ for (Subscript j = 1; j <= N; j++)
+ ans(i, j) = A(i, j) + B(i, j);
+ return ans;
+}
+
+template <class T>
+Fortran_Matrix<T> operator-(const_Region2D<Fortran_Matrix<T> > &A,
+ const_Region2D<Fortran_Matrix<T> > &B) {
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(M==B.num_rows());
+ assert(N==B.num_cols());
+
+ Fortran_Matrix<T> ans(M, N);
+ for (Subscript i = 1; i <= M; i++)
+ for (Subscript j = 1; j <= N; j++)
+ ans(i, j) = A(i, j) - B(i, j);
+ return ans;
+}
+template <class T>
+Fortran_Matrix<T> operator-(const Region2D<Fortran_Matrix<T> > &A,
+ const Region2D<Fortran_Matrix<T> > &B) {
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(M==B.num_rows());
+ assert(N==B.num_cols());
+
+ Fortran_Matrix<T> ans(M, N);
+ for (Subscript i = 1; i <= M; i++)
+ for (Subscript j = 1; j <= N; j++)
+ ans(i, j) = A(i, j) - B(i, j);
+ return ans;
+}
+
+template <class T>
+Fortran_Matrix<T> mult_element(const Region2D<Fortran_Matrix<T> > &A,
+ const Region2D<Fortran_Matrix<T> > &B)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(M==B.num_rows());
+ assert(N==B.num_cols());
+
+ Fortran_Matrix<T> tmp(M,N);
+ Subscript i,j;
+
+ for (i=1; i<=M; i++)
+ for (j=1; j<=N; j++)
+ tmp(i,j) = A(i,j) * B(i,j);
+
+ return tmp;
+}
+
+
+template <class T>
+Fortran_Matrix<T> transpose(const Region2D<Fortran_Matrix<T> > &A)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ Fortran_Matrix<T> S(N,M);
+ Subscript i, j;
+
+ for (i=1; i<=M; i++)
+ for (j=1; j<=N; j++)
+ S(j,i) = A(i,j);
+
+ return S;
+}
+
+
+template <class T>
+inline Fortran_Matrix<T> matmult(const Region2D<Fortran_Matrix<T> > &A,
+ const Region2D<Fortran_Matrix<T> > &B)
+{
+
+#ifdef TNT_BOUNDS_CHECK
+ assert(A.num_cols() == B.num_rows());
+#endif
+
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+ Subscript K = B.num_cols();
+
+ Fortran_Matrix<T> tmp(M,K);
+ T sum;
+
+ for (Subscript i=1; i<=M; i++)
+ for (Subscript k=1; k<=K; k++)
+ {
+ sum = 0;
+ for (Subscript j=1; j<=N; j++)
+ sum = sum + A(i,j) * B(j,k);
+
+ tmp(i,k) = sum;
+ }
+
+ return tmp;
+}
+
+template <class T>
+inline Fortran_Matrix<T> operator*(const Region2D<Fortran_Matrix<T> > &A,
+ const Region2D<Fortran_Matrix<T> > &B)
+{
+ return matmult(A,B);
+}
+
+template <class T>
+inline int matmult(Fortran_Matrix<T>& C, const Region2D<Fortran_Matrix<T> >&A,
+ const Region2D<Fortran_Matrix<T> >&B)
+{
+
+ assert(A.num_cols() == B.num_rows());
+
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+ Subscript K = B.num_cols();
+
+ C.newsize(M,K); // adjust shape of C, if necessary
+
+
+ T sum;
+
+ const T* row_i;
+ const T* col_k;
+
+ for (Subscript i=1; i<=M; i++)
+ {
+ for (Subscript k=1; k<=K; k++)
+ {
+ row_i = &A(i,1);
+ col_k = &B(1,k);
+ sum = 0;
+ for (Subscript j=1; j<=N; j++)
+ {
+ sum += *row_i * *col_k;
+ row_i += M;
+ col_k ++;
+ }
+
+ C(i,k) = sum;
+ }
+
+ }
+
+ return 0;
+}
+
+
+template <class T>
+Vector<T> matmult(const Region2D<Fortran_Matrix<T> > &A, const Vector<T> &x)
+{
+
+#ifdef TNT_BOUNDS_CHECK
+ assert(A.num_cols() == x.dim());
+#endif
+
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ Vector<T> tmp(M);
+ T sum;
+
+ for (Subscript i=1; i<=M; i++)
+ {
+ sum = 0;
+ for (Subscript j=1; j<=N; j++)
+ sum = sum + A(i,j) * x(j);
+
+ tmp(i) = sum;
+ }
+
+ return tmp;
+}
+
+template <class T>
+inline Vector<T> operator*(const Region2D<Fortran_Matrix<T> > &A, const Vector<T> &x)
+{
+ return matmult(A,x);
+}
+
+template <class T>
+inline Fortran_Matrix<T> operator*(const Region2D<Fortran_Matrix<T> > &A,
+ const T &x)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ Subscript MN = M*N;
+
+ Fortran_Matrix<T> res(M,N);
+ const T* a = A.begin();
+ T* t = res.begin();
+ T* tend = res.end();
+
+ for (t=res.begin(); t < tend; t++, a++)
+ *t = *a * x;
+
+ return res;
+}
+
+
+//convert Region2D to matrix or vector
+template <class T>
+Fortran_Matrix<T> asMat(const Region2D<Fortran_Matrix<T> > &A) {
+ Subscript m = A.num_rows(), n = A.num_cols();
+ Fortran_Matrix<T> ans(m, n);
+ for (Subscript i = 1; i <= m; i++)
+ for (Subscript j = 1; j <= n; j++)
+ ans(i, j) = A(i, j);
+ return ans;
+}
+
+template <class T>
+Fortran_Matrix<T> asMat(const_Region2D<Fortran_Matrix<T> > &A) {
+ Subscript m = A.num_rows(), n = A.num_cols();
+ Fortran_Matrix<T> ans(m, n);
+ for (Subscript i = 1; i <= m; i++)
+ for (Subscript j = 1; j <= n; j++)
+ ans(i, j) = A(i, j);
+ return ans;
+}
+
+template <class T>
+Vector<T> asVec(const Region2D<Fortran_Matrix<T> > &A) {
+ // A is 1 row or 1 col
+ Subscript m = A.num_rows(), n = A.num_cols();
+ if (m == 1) {
+ Vector<T> ans(n);
+ for (Subscript i = 1; i <= n; i++) ans(i) = A(1,i);
+ return ans;
+ }
+ else {
+ Vector<T> ans(m);
+ for (Subscript i = 1; i <= m; i++) ans(i) = A(i,1);
+ return ans;
+ }
+}
+
+template <class T>
+Vector<T> asVec(const_Region2D<Fortran_Matrix<T> > A) {
+ // A is 1 row or 1 col
+ Subscript m = A.num_rows(), n = A.num_cols();
+ if (m == 1) {
+ Vector<T> ans(n);
+ for (Subscript i = 1; i <= n; i++) ans(i) = A(1,i);
+ return ans;
+ }
+ else {
+ Vector<T> ans(m);
+ for (Subscript i = 1; i <= m; i++) ans(i) = A(i,1);
+ return ans;
+ }
+}
+
+//convert vector to matrix
+template <class T>
+Fortran_Matrix<T> asRowMat(const Vector<T> &v) {
+ Subscript n = v.size();
+ Fortran_Matrix<T> ans(1,n);
+ for (Subscript i = 1; i <= n; i++) ans(1,i) = v(i);
+ return ans;
+}
+
+template <class T>
+Fortran_Matrix<T> asColMat(const Vector<T> &v) {
+ Subscript n = v.size();
+ Fortran_Matrix<T> ans(n,1);
+ for (Subscript i = 1; i <= n; i++) ans(i,1) = v(i);
+ return ans;
+}
+
+
+//scalar multiplication
+template <class T>
+inline Vector<T> operator*(const Vector<T> &v, const T &x) {
+ Subscript m = v.size();
+ Vector<T> ans(m);
+ for (Subscript i = 1; i <= m; i++)
+ ans(i) = v(i) * x;
+ return ans;
+}
+
+template <class T>
+inline Vector<T> operator*(const T &x, const Vector<T> &v) {
+ return v * x;
+}
+
+template <class T>
+inline Fortran_Matrix<T> operator*(const T &x, const Fortran_Matrix<T> &A) {
+ Fortran_Matrix<T> ans = A * x; return ans;
+}
+
+// utilities:
+template <class T>
+Region2D<Fortran_Matrix<T> > MatSubs(Fortran_Matrix<T> &x,
+ const Index1D &I, const Index1D &J) {
+ return x(I, J);
+}
+
+template <class T>
+Region2D<Fortran_Matrix<T> > MatRow(Fortran_Matrix<T> &x, int i) {
+ int n = x.num_cols();
+ Index1D I(i,i), J(1,n);
+ return x(I,J);
+}
+
+template <class T>
+Region2D<Fortran_Matrix<T> > MatCol(Fortran_Matrix<T> &x, int i) {
+ int m = x.num_rows();
+ Index1D I(1,m), J(i,i);
+ return x(I,J);
+}
+
+template <class T>
+Region2D<Fortran_Matrix<T> > MatRows(Fortran_Matrix<T> &x, const Index1D &I) {
+ int n = x.num_cols(); Index1D J(1,n);
+ return x(I,J);
+}
+
+template <class T>
+Region2D<Fortran_Matrix<T> > MatCols(Fortran_Matrix<T> &x, const Index1D &J) {
+ int m = x.num_rows(); Index1D I(1,m);
+ return x(I,J);
+}
+
+template <class T>
+Region1D<Vector<T> > VecSubs(Vector<T> &x, const Index1D &I) {
+ return Region1D<Vector<T> >(x, I);
+}
+
+template <class T>
+Vector<T> asVec(const Region1D<Vector<T> > &x) {
+ Vector<T> ans(x.dim());
+ for (int i = 1; i <= ans.size(); i++) ans(i) = x(i);
+ return ans;
+}
+
+// transp(A) * inv(B) * C
+template <class Matrix, class T>
+Fortran_Matrix<T> matmult(
+ const Transpose_View<Matrix> & A,
+ const Fortran_Matrix<T> &B)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(B.num_rows() == N);
+ Subscript L = B.num_cols();
+
+ Fortran_Matrix<T> x(M,L);
+ Subscript i, j, k;
+ T tmp = 0;
+
+ for (i=1; i<=M; i++) {
+ for (j=1; j<=L; j++) {
+ tmp = 0;
+ for (k = 1; k <= N; k++) tmp += A(i,k) * B(k,j);
+ x(i,j) = tmp;
+ }
+ }
+
+ return x;
+}
+
+template <class Matrix, class T>
+Fortran_Matrix<T> matmult(
+ const Fortran_Matrix<T> & A,
+ const Transpose_View<Matrix> &B)
+{
+ Subscript M = A.num_rows();
+ Subscript N = A.num_cols();
+
+ assert(B.num_rows() == N);
+ Subscript L = B.num_cols();
+
+ Fortran_Matrix<T> x(M,L);
+ Subscript i, j, k;
+ T tmp = 0;
+
+ for (i=1; i<=M; i++) {
+ for (j=1; j<=L; j++) {
+ tmp = 0;
+ for (k = 1; k <= N; k++) tmp += A(i,k) * B(k,j);
+ x(i,j) = tmp;
+ }
+ }
+
+ return x;
+}
+
+template <class Matrix, class T>
+inline Fortran_Matrix<T> operator*(const Transpose_View<Matrix> & A, const Fortran_Matrix<T> &B)
+{
+ return matmult(A,B);
+}
+template <class Matrix, class T>
+inline Fortran_Matrix<T> operator*(const Fortran_Matrix<T> & A, const Transpose_View<Matrix> &B)
+{
+ return matmult(A,B);
+}
+
+//crossprod
+template <class T>
+Fortran_Matrix<T> crossprod(const Fortran_Matrix<T> &B) {
+ return matmult(Transpose_View<Fortran_Matrix<T> >(B), B);
+}
+
+
+
+//outerprod
+template <class T>
+Fortran_Matrix<T> outerprod(const Vector<T> &v) {
+ int n = v.size();
+ Fortran_Matrix<T> ans(n,n);
+ for (int i = 1; i <= n; i++)
+ for (int j = 1; j <= n; j++)
+ ans(i,j) = v(i) * v(j);
+ return ans;
+}
+
+template <class T>
+Fortran_Matrix<T> outerprod(const Vector<T> &v1, const Vector<T> &v2) {
+ int m = v1.size(), n = v2.size();
+ Fortran_Matrix<T> ans(m,n);
+ for (int i = 1; i <= m; i++)
+ for (int j = 1; j <= n; j++)
+ ans(i,j) = v1(i) * v2(j);
+ return ans;
+}
+
+template <class T>
+T fmax(const Vector<T> & v) {
+ T ans = v(1);
+ for (int i = 1; i <= v.dim(); i++)
+ if (ans < v(i)) ans = v(i);
+ return ans;
+}
+
+template <class T>
+T fmin(const Vector<T> & v) {
+ T ans = v(1);
+ for (int i = 1; i <= v.dim(); i++)
+ if (ans > v(i)) ans = v(i);
+ return ans;
+}
+
+template <class T>
+T fmax(const Fortran_Matrix<T> &m) {
+ T ans = m(1, 1);
+ for (int i = 1; i <= m.dim(1); i++)
+ for (int j = 1; j <= m.dim(2); j++)
+ if (ans < m(i, j)) ans = m(i, j);
+ return ans;
+}
+
+template <class T>
+T fmin(const Fortran_Matrix<T> &m) {
+ T ans = m(1, 1);
+ for (int i = 1; i <= m.dim(1); i++)
+ for (int j = 1; j <= m.dim(2); j++)
+ if (ans > m(i, j)) ans = m(i, j);
+ return ans;
+}
+
+template <class T>
+T sum(const Vector<T> &v) {
+ T ans = 0;
+ for (int i = 1; i <= v.dim(); i++)
+ ans += v(i);
+ return ans;
+}
+
+template <class T>
+T sum(const Fortran_Matrix<T> &m) {
+ T ans = 0;
+ for (int i = 1; i <= m.dim(1); i++)
+ for (int j = 1; j <= m.dim(2); j++)
+ ans += m(i, j);
+ return ans;
+}
+
+} //namespace TNT
+
+#endif //TNTSUPP_H
diff --git a/inst/include/utils.h b/inst/include/utils.h
new file mode 100755
index 0000000..0c06ae6
--- /dev/null
+++ b/inst/include/utils.h
@@ -0,0 +1,64 @@
+#ifndef UTILS_H
+#define UTILS_H
+
+#include "tntsupp.h"
+#include "geese.h"
+
+void VecPrint(const DVector &v);
+
+Fortran_Matrix<double> ident (int n);
+
+Fortran_Matrix<double> MatRowCol(const Fortran_Matrix<double> &mat, const Vector<double> &r, const Vector<double> &c);
+
+Fortran_Matrix<double> rho2mat(const Vector<double> &rho);
+
+//solve(a, b = ident(n))
+DMatrix solve(const DMatrix &a, const DMatrix &b);
+
+DVector solve(const DMatrix &A, const DVector &b);
+
+DMatrix solve(const DMatrix &a);
+
+DMatrix AtBiC(const DMatrix &A, const DMatrix &B, const DMatrix &C);
+
+DVector AtBiC(const DMatrix &A, const DMatrix &B, const DVector &C);
+
+DMatrix apply_elwise(const DMatrix &x, double f(double));
+
+DVector apply_elwise(const DVector &x, double f(double));
+
+DVector sqrt(const DVector &x);
+
+double square(double x);
+
+DVector square(const DVector &x);
+
+double reciproot(double x);
+
+DVector reciproot(const DVector &x);
+
+double recip(double x);
+
+DVector recip(const DVector &x);
+
+int cluscount(DVector &ID);
+
+Vector<int> clussize(DVector &ID);
+
+DVector SMult(const DVector &v1, const DVector &v2);
+
+DMatrix SMult(const DVector &v, const DMatrix &m);
+
+DMatrix operator*(const DVector &v, const DMatrix &m);
+
+DMatrix diag(const DVector &v);
+
+DVector diag(const DMatrix &m);
+
+DMatrix inv(const DMatrix &x);
+
+DMatrix fabs(const DMatrix &m);
+
+DVector fabs(const DVector &v);
+
+#endif //UTILS_H
diff --git a/man/DATA-dietox.Rd b/man/DATA-dietox.Rd
new file mode 100755
index 0000000..35365d8
--- /dev/null
+++ b/man/DATA-dietox.Rd
@@ -0,0 +1,44 @@
+\name{dietox}
+\alias{dietox}
+\non_function{}
+\title{Growth curves of pigs in a 3x3 factorial experiment}
+\usage{data(dietox)}
+\description{
+The \code{dietox} data frame has 861 rows and 7 columns.
+}
+\format{
+ This data frame contains the following columns:
+ \describe{
+ \item{Weight}{a numeric vector}
+ \item{Feed}{a numeric vector}
+ \item{Time}{a numeric vector}
+ \item{Pig}{a numeric vector}
+ \item{Evit}{a numeric vector}
+ \item{Cu}{a numeric vector}
+ \item{Litter}{a numeric vector}
+ }
+}
+%\details{
+% ~~ If necessary, more details than the description above ~~
+%}
+\source{
+ Lauridsen, C., H�jsgaard, S.,S�rensen, M.T. C. (1999) Influence of
+Dietary Rapeseed Oli, Vitamin E, and Copper on Performance and
+ Antioxidant and Oxidative Status of Pigs. J. Anim. Sci.77:906-916
+}
+%\references{
+%~~ possibly secondary sources and usages ~~
+%}
+\examples{
+data(dietox)
+dietox$Cu <- as.factor(dietox$Cu)
+gee01 <- geeglm (Weight ~ Time + Cu + Cu * Time, id =Pig, data = dietox,
+ family=gaussian,corstr="ex")
+
+mf <- formula(Weight~Cu*(Time+I(Time^2)+I(Time^3)))
+gee1 <- geeglm(mf, data=dietox, id=Pig, family=poisson("identity"),corstr="ar1")
+summary(gee1)
+anova(gee1)
+
+}
+\keyword{datasets}
diff --git a/man/DATA-koch.Rd b/man/DATA-koch.Rd
new file mode 100755
index 0000000..baf8d87
--- /dev/null
+++ b/man/DATA-koch.Rd
@@ -0,0 +1,33 @@
+\name{koch}
+\alias{koch}
+\non_function{}
+\title{Ordinal Data from Koch}
+\usage{data(koch)}
+\description{
+The \code{koch} data frame has 288 rows and 4 columns.
+}
+\format{
+ This data frame contains the following columns:
+ \describe{
+ \item{trt}{a numeric vector}
+ \item{day}{a numeric vector}
+ \item{y}{an ordered factor with levels:
+ \code{1} < \code{2} < \code{3}}
+ \item{id}{a numeric vector}
+ }
+}
+% \details{
+
+% }
+% \source{
+
+% }
+% \references{
+
+% }
+\examples{
+data(koch)
+fit <- ordgee(ordered(y) ~ trt + as.factor(day), id=id, data=koch, corstr="exch")
+summary(fit)
+}
+\keyword{datasets}
diff --git a/man/DATA-ohio.Rd b/man/DATA-ohio.Rd
new file mode 100755
index 0000000..30024eb
--- /dev/null
+++ b/man/DATA-ohio.Rd
@@ -0,0 +1,34 @@
+\name{ohio}
+\alias{ohio}
+\non_function{}
+\title{Ohio Children Wheeze Status}
+\usage{data(ohio)}
+\description{
+The \code{ohio} data frame has 2148 rows and 4 columns. The dataset is a
+subset of the six-city study, a longitudinal study of the health effects
+of air pollution.
+}
+\format{
+ This data frame contains the following columns:
+ \describe{
+ \item{resp}{an indicator of wheeze status (1=yes, 0=no)}
+ \item{id}{a numeric vector for subject id}
+ \item{age}{a numeric vector of age, 0 is 9 years old}
+ \item{smoke}{an indicator of maternal smoking at the first year of
+ the study}
+ }
+}
+\references{
+ Fitzmaurice, G.M. and Laird, N.M. (1993) A likelihood-based method for
+ analyzing longitudinal binary responses, \emph{Biometrika} \bold{80}: 141--151.
+}
+\examples{
+data(ohio)
+fit <- geese(resp ~ age + smoke + age:smoke, id=id, data=ohio,
+ family=binomial, corstr="exch", scale.fix=TRUE)
+summary(fit)
+fit.ar1 <- geese(resp ~ age + smoke + age:smoke, id=id, data=ohio,
+ family=binomial, corstr="ar1", scale.fix=TRUE)
+summary(fit.ar1)
+}
+\keyword{datasets}
diff --git a/man/DATA-respdis.Rd b/man/DATA-respdis.Rd
new file mode 100755
index 0000000..d5f929e
--- /dev/null
+++ b/man/DATA-respdis.Rd
@@ -0,0 +1,44 @@
+\name{respdis}
+\alias{respdis}
+\non_function{}
+\title{Clustered Ordinal Respiratory Disorder}
+\usage{data(respdis)}
+\description{
+The \code{respdis} data frame has 111 rows and 3 columns. The study
+described in Miller et. al. (1993) is a randomized clinical trial of a
+new treatment of respiratory disorder. The study was conducted in 111
+patients who were randomly assigned to one of two treatments (active,
+placebo). At each of four visits during the follow-up period, the
+response status of each patients was classified on an ordinal scale.
+}
+\format{
+ This data frame contains the following columns:
+ \describe{
+ \item{y1, y2, y3, y4}{ordered factor measured at 4 visits for
+ the response with levels, \code{1} < \code{2} < \code{3},
+ 1 = poor, 2 = good, and 3 = excellent}
+ \item{trt}{a factor for treatment with levels, 1 = active, 0 =
+ placebo.}
+ }
+}
+\references{
+Miller, M.E., David, C.S., and Landis, R.J. (1993) The analysis of
+longitudinal polytomous data: Generalized estimating equation and
+connections with weighted least squares, \emph{Biometrics} \bold{49}: 1033-1048.
+}
+\examples{
+data(respdis)
+resp.l <- reshape(respdis, varying = list(c("y1", "y2", "y3", "y4")),
+ v.names = "resp", direction = "long")
+resp.l <- resp.l[order(resp.l$id, resp.l$time),]
+fit <- ordgee(ordered(resp) ~ trt, id = id, data = resp.l, int.const = FALSE)
+summary(fit)
+
+z <- model.matrix( ~ trt - 1, data = respdis)
+ind <- rep(1:111, 4*3/2 * 2^2)
+zmat <- z[ind,,drop=FALSE]
+fit <- ordgee(ordered(resp) ~ trt, id = id, data = resp.l, int.const = FALSE,
+ z = zmat, corstr = "exchangeable")
+summary(fit)
+}
+\keyword{datasets}
diff --git a/man/DATA-respiratory.Rd b/man/DATA-respiratory.Rd
new file mode 100755
index 0000000..df88e1f
--- /dev/null
+++ b/man/DATA-respiratory.Rd
@@ -0,0 +1,40 @@
+\name{respiratory}
+\alias{respiratory}
+\alias{respiratoryWide}
+\docType{data}
+\title{Data from a clinical trial comparing two treatments for a respiratory illness}
+\description{
+ The data are from a clinical trial of patients with respiratory
+illness, where 111 patients from two different clinics were randomized
+to receive either placebo or an active treatment. Patients were
+examined at baseline and at four visits during treatment. At each
+examination, respiratory status (categorized as 1 = good, 0 = poor)
+was determined.
+}
+\usage{data(respiratory)}
+\format{
+ A data frame with 111 observations on the following 7 variables.
+ \describe{
+ \item{center}{a numeric vector}
+ \item{id}{a numeric vector}
+ \item{age}{a numeric vector}
+ \item{baseline}{a numeric vector}
+ \item{active}{a numeric vector}
+ \item{center2}{a numeric vector}
+ \item{female}{a numeric vector}
+ }
+}
+% \details{
+
+% }
+% \source{
+% ~~ reference to a publication or URL from which the data were obtained ~~
+% }
+% \references{
+% ~~ possibly secondary sources and usages ~~
+% }
+\examples{
+data(respiratory)
+## maybe str(respiratory) ; plot(respiratory) ...
+}
+\keyword{datasets}
diff --git a/man/DATA-seizure.Rd b/man/DATA-seizure.Rd
new file mode 100755
index 0000000..3539ef8
--- /dev/null
+++ b/man/DATA-seizure.Rd
@@ -0,0 +1,77 @@
+\name{seizure}
+\alias{seizure}
+\non_function{}
+\title{Epiliptic Seizures}
+\usage{data(seizure)}
+\description{
+The \code{seizure} data frame has 59 rows and 7 columns. The dataset
+has the number of epiliptic seizures in each of four two-week intervals,
+and in a baseline eight-week inverval, for treatment and control groups
+with a total of 59 individuals.
+}
+\format{
+ This data frame contains the following columns:
+ \describe{
+ \item{y1}{the number of epiliptic seizures in the 1st 2-week
+ interval}
+ \item{y2}{the number of epiliptic seizures in the 2nd 2-week
+ interval}
+ \item{y3}{the number of epiliptic seizures in the 3rd 2-week
+ interval}
+ \item{y4}{the number of epiliptic seizures in the 4th 2-week
+ interval}
+ \item{trt}{an indicator of treatment}
+ \item{base}{the number of epilitic seizures in a baseline 8-week
+ interval}
+ \item{age}{a numeric vector of subject age}
+ }
+}
+\source{
+ Thall, P.F. and Vail S.C. (1990)
+ Some covariance models for longitudinal count data with
+ overdispersion. \emph{Biometrics} \bold{46}: 657--671.
+}
+\references{
+ Diggle, P.J., Liang, K.Y., and Zeger, S.L. (1994)
+ Analysis of Longitudinal Data. Clarendon Press.
+}
+\examples{
+data(seizure)
+## Diggle, Liang, and Zeger (1994) pp166-168, compare Table 8.10
+seiz.l <- reshape(seizure,
+ varying=list(c("base","y1", "y2", "y3", "y4")),
+ v.names="y", times=0:4, direction="long")
+seiz.l <- seiz.l[order(seiz.l$id, seiz.l$time),]
+seiz.l$t <- ifelse(seiz.l$time == 0, 8, 2)
+seiz.l$x <- ifelse(seiz.l$time == 0, 0, 1)
+m1 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id,
+ data=seiz.l, corstr="exch", family=poisson)
+summary(m1)
+m2 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id,
+ data = seiz.l, subset = id!=49,
+ corstr = "exch", family=poisson)
+summary(m2)
+
+## Thall and Vail (1990)
+seiz.l <- reshape(seizure, varying=list(c("y1","y2","y3","y4")),
+ v.names="y", direction="long")
+seiz.l <- seiz.l[order(seiz.l$id, seiz.l$time),]
+seiz.l$lbase <- log(seiz.l$base / 4)
+seiz.l$lage <- log(seiz.l$age)
+seiz.l$v4 <- ifelse(seiz.l$time == 4, 1, 0)
+m3 <- geese(y ~ lbase + trt + lbase:trt + lage + v4,
+ sformula = ~ as.factor(time) - 1, id = id,
+ data = seiz.l, corstr = "exchangeable", family=poisson)
+## compare to Model 13 in Table 4, noticeable difference
+summary(m3)
+
+## set up a design matrix for the correlation
+z <- model.matrix(~ age, data = seizure) # data is not seiz.l
+## just to illustrate the scale link and correlation link
+m4 <- geese(y ~ lbase + trt + lbase:trt + lage + v4,
+ sformula = ~ as.factor(time)-1, id = id,
+ data = seiz.l, corstr = "ar1", family = poisson,
+ zcor = z, cor.link = "fisherz", sca.link = "log")
+summary(m4)
+}
+\keyword{datasets}
diff --git a/man/DATA-sitka89.Rd b/man/DATA-sitka89.Rd
new file mode 100755
index 0000000..66cd5e8
--- /dev/null
+++ b/man/DATA-sitka89.Rd
@@ -0,0 +1,35 @@
+\name{sitka89}
+\alias{sitka89}
+\title{Growth of Sitka Spruce Trees}
+\description{
+Impact of ozone on the growth of sitka spruce trees.
+}
+
+\usage{data(sitka89)}
+\format{
+A dataframe
+\describe{
+\item{size:}{size of the tree measured in \eqn{log(height*diamter^2)}}
+\item{time:}{days after the 1st january, 1988}
+\item{tree:}{id number of a tree}
+\item{treat:}{ozone: grown under ozone environment, control: ozone free}
+}
+}
+
+% \source{
+% }
+
+% \references{
+% }
+
+
+\examples{
+data(sitka89)
+%attach(sitka89)
+}
+
+\keyword{datasets}
+
+
+
+
diff --git a/man/DATA-spruce.Rd b/man/DATA-spruce.Rd
new file mode 100755
index 0000000..2004f1e
--- /dev/null
+++ b/man/DATA-spruce.Rd
@@ -0,0 +1,45 @@
+\name{spruce}
+\alias{spruce}
+\non_function{}
+\title{Log-size of 79 Sitka spruce trees}
+\usage{data(spruce)}
+\description{
+The \code{spruce} data frame has 1027 rows and 6 columns. The data
+consists of measurements on 79 sitka spruce trees over two growing
+seasons. The trees were grown in four controlled environment chambers,
+of which the first two, containing 27 trees each, were treated with
+introduced ozone at 70 ppb whilst the remaining two, containing 12 and
+13 trees, were controls.
+
+}
+\format{
+ This data frame contains the following columns:
+ \describe{
+ \item{chamber}{a numeric vector of chamber numbers}
+ \item{ozone}{a factor with levels \code{enriched} and \code{normal}}
+ \item{id}{a numeric vector of tree id}
+ \item{time}{a numeric vector of the time when the measurements were
+ taken, measured in days since Jan. 1, 1988}
+ \item{wave}{a numeric vector of the measurement number}
+ \item{logsize}{a numeric vector of the log-size}
+ }
+}
+\source{
+ Diggle, P.J., Liang, K.Y., and Zeger, S.L. (1994) Analysis of Longitudinal
+ Data, Clarendon Press.
+}
+\examples{
+data(spruce)
+spruce$contr <- ifelse(spruce$ozone=="enriched", 0, 1)
+sitka88 <- spruce[spruce$wave <= 5,]
+sitka89 <- spruce[spruce$wave > 5,]
+fit.88 <- geese(logsize ~ as.factor(wave) + contr +
+ I(time/100*contr) - 1,
+ id=id, data=sitka88, corstr="ar1")
+summary(fit.88)
+
+fit.89 <- geese(logsize ~ as.factor(wave) + contr - 1,
+ id=id, data=sitka89, corstr="ar1")
+summary(fit.89)
+}
+\keyword{datasets}
diff --git a/man/SHDgeese-internal.Rd b/man/SHDgeese-internal.Rd
new file mode 100755
index 0000000..81f1868
--- /dev/null
+++ b/man/SHDgeese-internal.Rd
@@ -0,0 +1,24 @@
+\name{SHDgeese-internal}
+\alias{anova.geeglm}
+\alias{anovageePrim2}
+\alias{anova.geeglmlist}
+\alias{plot.geeglm}
+\alias{print.geeglm}
+\alias{eprint}
+\alias{print.summary.geeglm}
+\alias{residuals.geeglm}
+\alias{summary.geeglm}
+
+\title{Internal geese functions}
+\description{
+ Internal functions called by other functions.
+}
+% \usage{
+% crossutri(wave)
+% genZcor(clusz, waves, corstrv)
+% genZodds(clusz, waves, corstrv, ncat)
+% }
+% \details{
+% These are not to be called directly by the user.
+% }
+\keyword{internal}
diff --git a/man/compCoef.Rd b/man/compCoef.Rd
new file mode 100755
index 0000000..1724906
--- /dev/null
+++ b/man/compCoef.Rd
@@ -0,0 +1,71 @@
+\name{compCoef}
+\alias{compCoef}
+\title{
+Compare Regression Coefficiente between Nested Models
+}
+\description{
+Comparing regression coefficients between models
+when one model is nested within another for clustered data.
+}
+\usage{
+compCoef(fit0, fit1)
+}
+\arguments{
+ \item{fit0}{
+ a fitted object of class \code{geese}
+ }
+ \item{fit1}{
+ another fitted object of class \code{geese}
+ }
+}
+\value{
+ a list of two components:
+ \item{delta}{estimated difference in the coefficients of common
+ covariates from \code{fit0} and \code{fit1}}
+ \item{variance}{estimated variance matrix of delta}
+}
+\references{
+ Allison, P. D. (1995). The impact of random predictors on comparisons
+ of coefficients between models: Comment on Clogg, Petkova, and
+ Haritou. \emph{American Journal of Sociology}, \bold{100}(5),
+ 1294--1305.
+
+ Clogg, C. C., Petkova, E., and Haritou, A. (1995). Statistical methods
+ for comparing regression coefficients between models.
+ \emph{American Journal of Sociology}, \bold{100}(5), 1261--1293.
+
+ Yan, J., Aseltine, R., and Harel, O. (2011). Comparing Regression
+ Coefficients Between Nested Linear Models for Clustered Data with
+ Generalized Estimating Equations. \emph{Journal of Educational and
+ Behaviorial Statistics}, Forthcoming.
+}
+\author{
+ Jun Yan \email{jyan.stat at gmail.com}
+}
+\examples{
+## generate clustered data
+gendat <- function(ncl, clsz) {
+## ncl: number of clusters
+## clsz: cluster size (all equal)
+ id <- rep(1:ncl, each = clsz)
+ visit <- rep(1:clsz, ncl)
+ n <- ncl * clsz
+ x1 <- rbinom(n, 1, 0.5) ## within cluster varying binary covariate
+ x2 <- runif(n, 0, 1) ## within cluster varying continuous covariate
+ ## the true correlation coefficient rho for an ar(1)
+ ## correlation structure is 2/3
+ rho <- 2/3
+ rhomat <- rho ^ outer(1:4, 1:4, function(x, y) abs(x - y))
+ chol.u <- chol(rhomat)
+ noise <- as.vector(sapply(1:ncl, function(x) chol.u \%*\% rnorm(clsz)))
+ y <- 1 + 3 * x1 - 2 * x2 + noise
+ dat <- data.frame(y, id, visit, x1, x2)
+ dat
+}
+
+simdat <- gendat(100, 4)
+fit0 <- geese(y ~ x1, id = id, data = simdat, corstr = "un")
+fit1 <- geese(y ~ x1 + x2, id = id, data = simdat, corstr = "un")
+compCoef(fit0, fit1)
+}
+\keyword{models}
diff --git a/man/fixed2Zcor.Rd b/man/fixed2Zcor.Rd
new file mode 100755
index 0000000..0befc67
--- /dev/null
+++ b/man/fixed2Zcor.Rd
@@ -0,0 +1,82 @@
+\name{fixed2Zcor}
+\Rdversion{1.1}
+\alias{fixed2Zcor}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+ Construct zcor vector (of fixed correlations) from a fixed working
+ correlation matrix
+}
+\description{
+ Construct zcor vector (of fixed correlations) from a fixed working
+ correlation matrix, a specification of clusters and a specifcation of
+ waves.
+}
+\usage{
+fixed2Zcor(cor.fixed, id, waves)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{cor.fixed}{
+ Matrix
+}
+ \item{id}{
+ Clusters
+}
+ \item{waves}{
+ Vector giving the ordering of observations within clusters.
+}
+}
+%\details{
+%% ~~ If necessary, more details than the description above ~~
+%}
+\value{
+ A vector which can be passed as the zcor argument to geeglm.
+}
+%\references{
+%% ~put references to the literature/web site here ~
+%}
+\author{
+ S�ren H�jsgaard <sorenh at agrsci.dk>
+}
+%\note{
+%% ~~further notes~~
+%}
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+\code{\link{genZcor}}, \code{\link{geeglm}}
+}
+\examples{
+
+timeorder <- rep(1:5, 6)
+tvar <- timeorder + rnorm(length(timeorder))
+idvar <- rep(1:6, each=5)
+uuu <- rep(rnorm(6), each=5)
+yvar <- 1 + 2*tvar + uuu + rnorm(length(tvar))
+simdat <- data.frame(idvar, timeorder, tvar, yvar)
+head(simdat,12)
+
+simdatPerm <- simdat[sample(nrow(simdat)),]
+simdatPerm <- simdatPerm[order(simdatPerm$idvar),]
+head(simdatPerm)
+
+cor.fixed <- matrix(c(1 , 0.5 , 0.25, 0.125, 0.125,
+ 0.5 , 1 , 0.25, 0.125, 0.125,
+ 0.25 , 0.25 , 1 , 0.5 , 0.125,
+ 0.125, 0.125, 0.5 , 1 , 0.125,
+ 0.125, 0.125, 0.125, 0.125, 1 ), nrow=5, ncol=5)
+cor.fixed
+
+zcor <- fixed2Zcor(cor.fixed, id=simdatPerm$idvar, waves=simdatPerm$timeorder)
+zcor
+
+mod4 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="fixed", zcor=zcor)
+mod4
+
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{regression}
+
diff --git a/man/geeglm.Rd b/man/geeglm.Rd
new file mode 100755
index 0000000..2e07486
--- /dev/null
+++ b/man/geeglm.Rd
@@ -0,0 +1,109 @@
+\name{geeglm}
+\alias{geeglm}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Fit Generalized Estimating Equations (GEE)}
+\description{
+ The geeglm function fits generalized estimating equations using the 'geese.fit' function
+ of the 'geepack' package for doing the actual computations. geeglm has a syntax similar to
+ glm and returns an object similar to a glm object.
+ An important feature of geeglm,
+ is that an anova method exists for these models.
+}
+\usage{
+geeglm(formula, family = gaussian, data=parent.frame(), weights, subset,
+ na.action, start = NULL, etastart, mustart, offset,
+ control = geese.control(...),
+ method = "glm.fit", x = FALSE, y = TRUE,
+ contrasts = NULL,
+ id, waves=NULL, zcor=NULL,
+ corstr = "independence",
+ scale.fix = FALSE,
+ scale.value =1, std.err="san.se",
+ ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{formula}{See corresponding documentation to \code{glm}}
+ \item{family}{See corresponding documentation to \code{glm}}
+ \item{data}{See corresponding documentation to \code{glm}}
+ \item{weights}{See corresponding documentation to \code{glm}}
+ \item{subset}{See corresponding documentation to \code{glm}}
+ \item{na.action}{No action is taken. Indeed geeglm only works on
+ complete data.}
+ \item{start}{See corresponding documentation to \code{glm}}
+ \item{etastart}{See corresponding documentation to \code{glm}}
+ \item{mustart}{See corresponding documentation to \code{glm}}
+ \item{offset}{See corresponding documentation to \code{glm}}
+ \item{control}{See corresponding documentation to \code{glm}}
+ %\item{model}{See corresponding documentation to \code{glm}}
+ \item{method}{See corresponding documentation to \code{glm}}
+ \item{x}{See corresponding documentation to \code{glm}}
+ \item{y}{See corresponding documentation to \code{glm}}
+ \item{contrasts}{See corresponding documentation to \code{glm}}
+
+ \item{id}{a vector which identifies the clusters. The length of `id'
+ should be the same as the number of observations. Data are
+ assumed to be sorted so that observations on a cluster are
+ contiguous rows for all entities in the formula. }
+\item{waves}{Wariable specifying the ordering of repeated mesurements on the same unit.
+ Also used in connection with missing values. See examples below.}
+\item{zcor}{Used for entering a user defined working correlation structure.}
+ \item{corstr}{a character string specifying the correlation structure. The
+ following are permitted: '"independence"', '"exchangeable"',
+ '"ar1"', '"unstructured"' and '"userdefined"' }
+ \item{scale.fix}{a logical variable; if true, the scale parameter is fixed at
+ the value of 'scale.value'. }
+ \item{scale.value}{numeric variable giving the value to which the scale
+ parameter should be fixed; used only if 'scale.fix == TRUE'.}
+ \item{std.err}{Type of standard error to be calculated. Defualt
+ 'san.se' is the usual robust estimate. Other options are 'jack':
+ if approximate jackknife variance estimate
+ should be computed.
+ 'j1s': if 1-step jackknife variance estimate
+ should be computed.
+ 'fij': logical indicating if fully iterated jackknife variance
+ estimate should be computed. }
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\details{
+ In the case of corstr="fixed" one must provide the zcor vector
+ if the clusters have unequal sizes.
+
+ Clusters with size one must not be represented in zcor.
+}
+\value{
+ An object of type 'geeglm'
+}
+\references{Liang, K.Y. and Zeger, S.L. (1986) Longitudinal data analysis
+ using generalized linear models. Biometrika, *73* 13-22.
+
+ Prentice, R.L. and Zhao, L.P. (1991). Estimating equations for
+ parameters in means and covariances of multivariate discrete and
+ continuous responses. Biometrics, *47* 825-839.}
+\author{S�ren H�jsgaard, sorenh at agrsci.dk}
+\note{See the documentation for the 'geese' function
+ for additional information. geeglm only works for complete data. Thus
+ if there are NA's in data you can specify data=na.omit(mydata).
+}
+
+\section{Warning }{
+ Use "unstructured" correlation structure only with great care. (It may
+ cause R to crash).
+}
+
+\seealso{\code{\link{geese}}, \code{\link{glm}},\code{\link{anova.geeglm}} }
+\examples{
+data(dietox)
+dietox$Cu <- as.factor(dietox$Cu)
+mf <- formula(Weight~Cu*(Time+I(Time^2)+I(Time^3)))
+gee1 <- geeglm(mf, data=dietox, id=Pig, family=poisson("identity"),corstr="ar1")
+gee1
+summary(gee1)
+
+mf2 <- formula(Weight~Cu*Time+I(Time^2)+I(Time^3))
+gee2 <- geeglm(mf2, data=dietox, id=Pig, family=poisson("identity"),corstr="ar1")
+anova(gee2)
+
+}
+\keyword{models}% at least one, from doc/KEYWORDS
+
diff --git a/man/geese-internal.Rd b/man/geese-internal.Rd
new file mode 100755
index 0000000..2f36d65
--- /dev/null
+++ b/man/geese-internal.Rd
@@ -0,0 +1,17 @@
+\name{geese-internal}
+\alias{crossutri}
+%\alias{genZcor}
+\alias{genZodds}
+\title{Internal geese functions}
+\description{
+ Internal functions called by other functions.
+}
+\usage{
+crossutri(wave)
+genZcor(clusz, waves, corstrv)
+genZodds(clusz, waves, corstrv, ncat)
+}
+\details{
+ These are not to be called directly by the user.
+}
+\keyword{internal}
diff --git a/man/geese.Rd b/man/geese.Rd
new file mode 100755
index 0000000..a518fb8
--- /dev/null
+++ b/man/geese.Rd
@@ -0,0 +1,254 @@
+\name{geese}
+\alias{geese}
+\alias{geese.fit}
+\alias{print.geese}
+\alias{summary.geese}
+\alias{print.summary.geese}
+\title{Function to solve a Generalized Estimating Equation Model}
+\description{
+ Produces an object of class `geese' which is a Generalized Estimating
+ Equation fit of the data.
+}
+\usage{
+geese(formula = formula(data), sformula = ~1, id, waves = NULL,
+ data = parent.frame(), subset = NULL, na.action = na.omit,
+ contrasts = NULL, weights = NULL, zcor = NULL, corp = NULL,
+ control = geese.control(...), b = NULL, alpha = NULL, gm = NULL,
+ family = gaussian(), mean.link = NULL, variance = NULL,
+ cor.link = "identity", sca.link = "identity", link.same = TRUE,
+ scale.fix = FALSE, scale.value = 1, corstr = "independence", ...)
+
+geese.fit(x, y, id, offset = rep(0, N), soffset = rep(0, N),
+ weights = rep(1,N), waves = NULL, zsca = matrix(1, N, 1),
+ zcor = NULL, corp = NULL, control = geese.control(...),
+ b = NULL, alpha = NULL, gm = NULL, family = gaussian(),
+ mean.link = NULL, variance = NULL, cor.link = "identity",
+ sca.link = "identity", link.same = TRUE, scale.fix = FALSE,
+ scale.value = 1, corstr = "independence", ...)
+}
+\arguments{
+ \item{formula}{a formula expression as for \code{glm}, of the form
+ \code{response ~ predictors}. See the documentation of lm and
+ formula for details. As for glm, this specifies the linear predictor
+ for modeling the mean. A term of the form \code{offset(expression)}
+ is allowed.
+ }
+ \item{sformula}{a formula expression of the form \code{ ~ predictor},
+ the response being ignored. This specifies the linear predictor for
+ modeling the dispersion. A term of the form
+ \code{offset(expression)} is allowed.
+ }
+ \item{id}{a vector which identifies the clusters. The length of `id'
+ should be the same as the number of observations. Data are assumed
+ to be sorted so that observations on a cluster are contiguous rows
+ for all entities in the formula.
+ }
+ \item{waves}{an integer vector which identifies components in
+ clusters. The length of \code{waves} should be the same as the
+ number of observation. components with the same \code{waves} value
+ will have the same link functions.
+ }
+ \item{data}{
+ an optional data frame in which to interpret the variables occurring
+ in the \code{formula}, along with the \code{id} and \code{n} variables.
+ }
+ \item{subset}{
+ expression saying which subset of the rows of the data should be used
+ in the fit. This can be a logical vector (which is replicated to have
+ length equal to the number of observations), or a numeric vector
+ indicating which observation numbers are to be included, or a
+ character vector of the row names to be included.
+ All observations are included by default.
+ }
+ \item{na.action}{
+ a function to filter missing data. For \code{gee} only \code{na.omit}
+ should be used here.
+ }
+ \item{contrasts}{
+ a list giving contrasts for some or all of the factors appearing
+ in the model formula. The elements of the list should have the
+ same name as the variable and should be either a contrast matrix
+ (specifically, any full-rank matrix with as many rows as there are
+ levels in the factor), or else a function to compute such a matrix
+ given the number of levels.
+ }
+ \item{weights}{an optional vector of weights to be used
+ in the fitting process. The length of \code{weights} should be the
+ same as the number of observations. This weights is not (yet) the
+ weight as in sas proc genmod, and hence is not recommended to use.
+ }
+ \item{zcor}{a design matrix for correlation parameters.}
+ \item{corp}{known parameters such as coordinates used for correlation
+ coefficients.
+ }
+ \item{control}{a list of iteration and algorithmic constants. See
+ \code{\link{geese.control}} for their names and default
+ values. These can also be set as arguments to \code{geese} itself.
+ }
+ \item{b}{an initial estimate for the mean parameters.}
+ \item{alpha}{an initial estimate for the correlation parameters.}
+ \item{gm}{an initial estimate for the scale parameters.}
+ \item{family}{a description of the error distribution and link
+ function to be used in the model, as for \code{\link{glm}}.
+ }
+ \item{mean.link}{a character string specifying the link function for
+ the means. The following are allowed:
+ \code{"identity"}, \code{"logit"}, \code{"probit"},
+ \code{"cloglog"}, \code{"log"}, and \code{"inverse"}.
+ The default value is determined from family.
+ }
+ \item{variance}{a character string specifying the variance function
+ in terms of the mean. The following are allowed:
+ \code{"gaussian"}, \code{"binomial"}, \code{"poisson"}, and
+ \code{"gamma"}. The default value is determined from family.
+ }
+ \item{cor.link}{a character string specifying the link function for
+ the correlation coefficients. The following are allowed:
+ \code{"identity"}, and \code{"fisherz"}.
+ }
+ \item{sca.link}{a character string specifying the link function for
+ the scales. The following are allowed:
+ \code{"identity"}, and \code{"log"}.
+ }
+ \item{link.same}{a logical indicating if all the components in a
+ cluster should use the same link.
+ }
+ \item{scale.fix}{
+ a logical variable; if true, the scale parameter is fixed at
+ the value of \code{scale.value}.
+ }
+ \item{scale.value}{
+ numeric variable giving the value to which the scale parameter
+ should be fixed; used only if \code{scale.fix == TRUE}.
+ }
+ \item{corstr}{
+ a character string specifying the correlation structure.
+ The following are permitted:
+ \code{"independence"},
+ \code{"exchangeable"},
+ \code{"ar1"},
+ \code{"unstructured"},
+ \code{"userdefined"}, and
+ \code{"fixed"}
+ }
+ \item{x, y}{
+ \code{x} is a design matrix of dimension \code{n * p}, and \code{y}
+ is a vector of observations of length \code{n}.
+ }
+ \item{offset, soffset}{
+ vector of offset for the mean and for the scale, respectively.
+ }
+ \item{zsca}{
+ a design matrix of dimension \code{n * r} for the scales.
+ }
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\value{
+ An object of class \code{"geese"} representing the fit.
+}
+\details{
+ when the correlation structure is \code{fixed}, the specification
+ of \code{Zcor} should be a vector of length
+ \code{sum(clusz * (clusz - 1)) / 2.}
+}
+\references{
+ Yan, J. and J.P. Fine (2004)
+ Estimating Equations for Association Structures.
+ \emph{Statistics in Medicine}, \bold{23}, 859--880.
+
+}
+\author{Jun Yan \email{jyan.stat at gmail.com}}
+\seealso{
+ \code{\link{glm}}, \code{\link{lm}}, \code{\link{ordgee}}.
+}
+\examples{
+data(seizure)
+## Diggle, Liang, and Zeger (1994) pp166-168, compare Table 8.10
+seiz.l <- reshape(seizure,
+ varying=list(c("base","y1", "y2", "y3", "y4")),
+ v.names="y", times=0:4, direction="long")
+seiz.l <- seiz.l[order(seiz.l$id, seiz.l$time),]
+seiz.l$t <- ifelse(seiz.l$time == 0, 8, 2)
+seiz.l$x <- ifelse(seiz.l$time == 0, 0, 1)
+m1 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id,
+ data=seiz.l, corstr="exch", family=poisson)
+summary(m1)
+m2 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id,
+ data = seiz.l, subset = id!=49,
+ corstr = "exch", family=poisson)
+summary(m2)
+## Using fixed correlation matrix
+cor.fixed <- matrix(c(1, 0.5, 0.25, 0.125, 0.125,
+ 0.5, 1, 0.25, 0.125, 0.125,
+ 0.25, 0.25, 1, 0.5, 0.125,
+ 0.125, 0.125, 0.5, 1, 0.125,
+ 0.125, 0.125, 0.125, 0.125, 1), 5, 5)
+cor.fixed
+zcor <- rep(cor.fixed[lower.tri(cor.fixed)], 59)
+m3 <- geese(y ~ offset(log(t)) + x + trt + x:trt, id = id,
+ data = seiz.l, family = poisson,
+ corstr = "fixed", zcor = zcor)
+summary(m3)
+
+data(ohio)
+fit <- geese(resp ~ age + smoke + age:smoke, id=id, data=ohio,
+ family=binomial, corstr="exch", scale.fix=TRUE)
+summary(fit)
+fit.ar1 <- geese(resp ~ age + smoke + age:smoke, id=id, data=ohio,
+ family=binomial, corstr="ar1", scale.fix=TRUE)
+summary(fit.ar1)
+
+###### simulated data
+## a function to generate a dataset
+gendat <- function() {
+ id <- gl(50, 4, 200)
+ visit <- rep(1:4, 50)
+ x1 <- rbinom(200, 1, 0.6) ## within cluster varying binary covariate
+ x2 <- runif(200, 0, 1) ## within cluster varying continuous covariate
+ phi <- 1 + 2 * x1 ## true scale model
+ ## the true correlation coefficient rho for an ar(1)
+ ## correlation structure is 0.667.
+ rhomat <- 0.667 ^ outer(1:4, 1:4, function(x, y) abs(x - y))
+ chol.u <- chol(rhomat)
+ noise <- as.vector(sapply(1:50, function(x) chol.u \%*\% rnorm(4)))
+ e <- sqrt(phi) * noise
+ y <- 1 + 3 * x1 - 2 * x2 + e
+ dat <- data.frame(y, id, visit, x1, x2)
+ dat
+}
+
+dat <- gendat()
+fit <- geese(y ~ x1 + x2, id = id, data = dat, sformula = ~ x1,
+ corstr = "ar1", jack = TRUE, j1s = TRUE, fij = TRUE)
+summary(fit)
+
+
+#### create user-defined design matrix of unstrctured correlation.
+#### in this case, zcor has 4*3/2 = 6 columns, and 50 * 6 = 300 rows
+zcor <- genZcor(clusz = rep(4, 50), waves = dat$visit, "unstr")
+zfit <- geese(y ~ x1 + x2, id = id, data = dat, sformula = ~ x1,
+ corstr = "userdefined", zcor = zcor,
+ jack = TRUE, j1s = TRUE, fij = TRUE)
+summary(zfit)
+
+#### Now, suppose that we want the correlation of 1-2, 2-3, and 3-4
+#### to be the same. Then zcor should have 4 columns.
+z2 <- matrix(NA, 300, 4)
+z2[,1] <- zcor[,1] + zcor[,4] + zcor[,6]
+z2[,2:4] <- zcor[, c(2, 3, 5)]
+summary(geese(y ~ x1 + x2, id = id, data = dat, sformula = ~ x1,
+ corstr = "userdefined", zcor = z2,
+ jack = TRUE, j1s = TRUE, fij = TRUE))
+
+#### Next, we introduce non-constant cluster sizes by
+#### randomly selecting 60 percent of the data
+good <- sort(sample(1:nrow(dat), .6 * nrow(dat)))
+mdat <- dat[good,]
+
+summary(geese(y ~ x1 + x2, id = id, data = mdat, waves = visit,
+ sformula = ~ x1, corstr="ar1",
+ jack = TRUE, j1s = TRUE, fij = TRUE))
+
+}
+\keyword{nonlinear}
+\keyword{models}
diff --git a/man/geese.control.Rd b/man/geese.control.Rd
new file mode 100755
index 0000000..8d05386
--- /dev/null
+++ b/man/geese.control.Rd
@@ -0,0 +1,41 @@
+\name{geese.control}
+\alias{geese.control}
+%- Also NEED an `\alias' for EACH other topic documented here.
+\title{Auxiliary for Controlling GEE Fitting}
+\description{
+ Auxiliary function as user interface for `gee' fitting. Only used when
+ calling `geese' or `geese.fit'.
+}
+\usage{
+geese.control(epsilon = 1e-04, maxit = 25, trace = FALSE,
+ scale.fix = FALSE, jack = FALSE, j1s = FALSE, fij = FALSE)
+}
+%- maybe also `usage' for other objects documented here.
+\arguments{
+ \item{epsilon}{positive convergence tolerance epsilon; the iterations
+ converge when the absolute value of the difference in parameter
+ estimate is below \code{epsilon}.}
+ \item{maxit}{integer giving the maximal number of Fisher Scoring iteration.}
+ \item{trace}{logical indicating if output should be produced for each iteration.}
+ \item{scale.fix}{logical indicating if the scale should be fixed.}
+ \item{jack}{logical indicating if approximate jackknife variance
+ estimate should be computed.}
+ \item{j1s}{logical indicating if 1-step jackknife variance estimate
+ should be computed.}
+ \item{fij}{logical indicating if fully iterated jackknife variance
+ estimate should be computed.}
+}
+\details{
+ When `trace' is true, output for each iteration is printed to the
+ screen by the c++ code. Hence, `options(digits = *)' does not control
+ the precision.
+}
+\value{
+ A list with the arguments as components.
+}
+\author{Jun Yan \email{jyan.stat at gmail.com} }
+\seealso{`geese.fit', the fitting procedure used by `geese'.}
+% \examples{
+% }
+\keyword{optimize}
+\keyword{models}
diff --git a/man/genZcor.Rd b/man/genZcor.Rd
new file mode 100755
index 0000000..51f8929
--- /dev/null
+++ b/man/genZcor.Rd
@@ -0,0 +1,70 @@
+\name{genZcor}
+\alias{genZcor}
+\alias{humbelbee}
+\title{genZcor}
+\description{
+ constructs the design matrix for the correlation structures:
+ independence, echangeable, ar1 and unstructured
+ The user will need this function only as a basis to construct a user defined
+ correlation structure: use genZcor to get the design matrix Z for
+ the unstructured correlation and define the specific correlation structure by
+ linear combinations of the columns of Z.
+
+}
+\usage{
+genZcor(clusz, waves, corstrv)
+}
+
+\arguments{
+ \item{clusz}{integer vector giving the number of observations in each cluster}
+ \item{waves}{integer vector, obervations in the same cluster with
+ values of wave i and j have the correlation \eqn{latex}{sigma_ij}}
+ \item{corstrv}{correlation
+ structures: 1=independence,2=exchangeable,3=ar1,
+ 4=unstructured}
+}
+% \details{
+% }
+\value{
+ \item{}{the design matrix for the correlation structure}
+}
+%\references{ a }
+\author{Jun Yan \email{jyan.stat at gmail.com}}
+% \note{ }
+
+
+
+\seealso{\code{\link{fixed2Zcor}} }
+\examples{
+#example to construct a Toeplitz correlation structure
+# sigma_ij=sigma_|i-j|
+
+#data set with 5 clusters and maximally 4 observations (visits) per cluster
+ gendat <- function() {
+ id <- gl(5, 4, 20)
+ visit <- rep(1:4, 5)
+ y <- rnorm(id)
+ dat <- data.frame(y, id, visit)[c(-2,-9),]
+}
+
+set.seed(88)
+dat<-gendat()
+
+#generating the design matrix for the unstructured correlation
+zcor <- genZcor(clusz = table(dat$id), waves = dat$visit, corstrv=4)
+# defining the Toeplitz structure
+zcor.toep<-matrix(NA, nrow(zcor),3)
+zcor.toep[,1]<-apply(zcor[,c(1,4,6)],1,sum)
+zcor.toep[,2]<-apply(zcor[,c(2,5)],1,sum)
+zcor.toep[,3]<-zcor[,3]
+
+zfit1 <- geese(y ~ 1,id = id, data = dat,
+ corstr = "userdefined", zcor = zcor.toep)
+
+
+zfit2 <- geeglm(y ~ 1,id = id, data = dat,
+ corstr = "userdefined", zcor = zcor.toep)
+
+
+}
+\keyword{ regression }% at least one, from doc/KEYWORDS
diff --git a/man/ordgee.Rd b/man/ordgee.Rd
new file mode 100755
index 0000000..4141065
--- /dev/null
+++ b/man/ordgee.Rd
@@ -0,0 +1,117 @@
+\name{ordgee}
+\alias{ordgee}
+\title{GEE for Clustered Ordinal Responses}
+\description{
+ Produces an object of class `geese' which is a Generalized Estimating
+ Equation fit of the clustered ordinal data.
+}
+\usage{
+ordgee(formula = formula(data), ooffset = NULL, id, waves = NULL,
+ data = parent.frame, subset = NULL, na.action = na.omit,
+ contrasts = NULL, weights = NULL, z = NULL,
+ mean.link = "logit", corstr = "independence",
+ control = geese.control(...), b = NA, alpha = NA,
+ scale.fix = TRUE, scale.val = 1, int.const = TRUE,
+ rev = FALSE,...)
+}
+\arguments{
+ \item{formula}{a formula expression as for \code{glm}, of the form
+ \code{response ~ predictors}. See the documentation of lm and
+ formula for details. As for glm, this specifies the linear predictor
+ for modelling the mean. A term of the form \code{offset(expression)}
+ is allowed.
+ }
+ \item{ooffset}{vector of offset for the odds ratio model.}
+ \item{id}{a vector which identifies the clusters. The length of `id'
+ should be the same as the number of observations. Data are assumed
+ to be sorted so that observations on a cluster are contiguous rows
+ for all entities in the formula.}
+ \item{waves}{an integer vector which identifies components in
+ clusters. The length of \code{waves} should be the same as the
+ number of observation. components with the same \code{waves} value
+ will have the same link functions. }
+ \item{data}{
+ an optional data frame in which to interpret the variables occurring
+ in the \code{formula}, along with the \code{id} and \code{n} variables.
+ }
+ \item{subset}{
+ expression saying which subset of the rows of the data should be used
+ in the fit. This can be a logical vector (which is replicated to have
+ length equal to the number of observations), or a numeric vector
+ indicating which observation numbers are to be included, or a
+ character vector of the row names to be included.
+ All observations are included by default.
+ }
+ \item{na.action}{
+ a function to filter missing data. For \code{gee} only \code{na.omit}
+ should be used here.
+ }
+ \item{contrasts}{
+ a list giving contrasts for some or all of the factors appearing
+ in the model formula. The elements of the list should have the
+ same name as the variable and should be either a contrast matrix
+ (specifically, any full-rank matrix with as many rows as there are
+ levels in the factor), or else a function to compute such a matrix
+ given the number of levels.
+ }
+ \item{weights}{an optional vector of weights to be used
+ in the fitting process. The length of \code{weights} should be the
+ same as the number of observations.
+ }
+ \item{z}{a design matrix for the odds ratio model. The number of rows
+ of z is \deqn{c^2 \sum n_i(n_i - 1)/2,} where \eqn{n_i} is the cluster
+ size, and \eqn{c} is the number of categories minus 1.
+ }
+ \item{mean.link}{a character string specifying the link function for
+ the means. The following are allowed:
+ \code{"logit"}, \code{"probit"}, and \code{"cloglog"}.
+ }
+ \item{corstr}{a character string specifying the log odds. The
+ following are allowed:
+ \code{"independence"}, \code{"exchangeable"}, \code{"unstructured"},
+ and \code{"userdefined"}.
+ }
+ \item{control}{a list of iteration and algorithmic constants. See
+ \code{\link{geese.control}} for their names and default
+ values. These can also be set as arguments to \code{geese} itself.
+ }
+ \item{b}{an initial estimate for the mean parameters.}
+ \item{alpha}{an initial estimate for the odds ratio parameters.}
+ \item{scale.fix}{a logical variable indicating if scale is fixed; it
+ is set at TRUE currently (it can not be FALSE yet!).}
+ \item{scale.val}{this argument is ignored currently.}
+ \item{int.const}{a logical variable; if true, the intercepts are
+ constant, and if false, the intercepts are different for different
+ components in the response.}
+ \item{rev}{a logical variable. For example, for a three level ordered
+ response Y = 2, the accumulated indicator is coded as (1, 0, 0) if
+ true and (0, 1, 1) if false.}
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\value{
+ An object of class \code{"geese"} representing the fit.
+}
+\references{
+ Heagerty, P.J. and Zeger, S.L. (1996)
+ Marginal regression models for clustered ordinal measurements.
+ \emph{JASA}, \bold{91} 1024--1036.
+}
+\author{Jun Yan \email{jyan.stat at gmail.com}}
+\seealso{
+ \code{\link{glm}}, \code{\link{lm}}, \code{\link{geese}}.
+}
+\examples{
+data(respdis)
+resp.l <- reshape(respdis, varying =list(c("y1", "y2", "y3", "y4")),
+ v.names = "resp", direction = "long")
+resp.l <- resp.l[order(resp.l$id, resp.l$time),]
+fit <- ordgee(ordered(resp) ~ trt, id=id, data=resp.l, int.const=FALSE)
+summary(fit)
+
+data(ohio)
+ohio$resp <- ordered(as.factor(ohio$resp))
+fit <- ordgee(resp ~ age + smoke + age:smoke, id = id, data=ohio)
+summary(fit)
+}
+\keyword{nonlinear}
+\keyword{models}
diff --git a/man/relRisk.Rd b/man/relRisk.Rd
new file mode 100755
index 0000000..6610e87
--- /dev/null
+++ b/man/relRisk.Rd
@@ -0,0 +1,83 @@
+\name{relRisk}
+\alias{relRisk}
+\title{
+Fit a Relative Risk Model for Binary data with Log Link
+}
+\description{
+Fit a Relative Risk Model for Binary data with Log Link using the COPY method.
+}
+\usage{
+relRisk(formula, id, waves = NULL, data = parent.frame(),
+ subset = NULL, contrasts = NULL, na.action = na.omit,
+ corstr = "indep", ncopy = 1000,
+ control = geese.control(), b = NULL, alpha = NULL)
+}
+\arguments{
+ \item{formula}{
+ same as in \code{geese}
+ }
+ \item{id}{
+ same as in \code{geese}
+ }
+ \item{waves}{
+ same as in \code{geese}
+ }
+ \item{data}{
+ same as in \code{geese}
+ }
+ \item{subset}{
+ same as in \code{geese}
+ }
+ \item{contrasts}{
+ same as in \code{geese}
+ }
+ \item{na.action}{
+ same as in \code{geese}
+ }
+ \item{corstr}{
+ same as in \code{geese}
+ }
+ \item{ncopy}{
+ the number of copies of the original data in constructing weight.
+ }
+ \item{control}{
+ same as in \code{geese}
+ }
+ \item{b}{
+ initial values for regression coefficients as in \code{geese}
+ but more difficult to obtain due to the log link.
+ }
+ \item{alpha}{
+ same as in \code{geese}
+ }
+}
+\value{
+ An object of class \code{"geese"} representing the fit.
+}
+\references{
+ Lumley, T., Kornmal, R. and Ma, S. (2006). Relative risk regression in
+ medical research: models, contrasts, estimators, and algorithms. UW
+ Biostatistics Working Paper Series 293, University of Washington.
+}
+\author{
+ Jun Yan \email{jyan.stat at gmail.com}
+}
+\examples{
+## this example was used in Yu and Yan (2010, techreport)
+data(respiratory)
+respiratory$treat <- relevel(respiratory$treat, ref = "P")
+respiratory$sex <- relevel(respiratory$sex, ref = "M")
+respiratory$center <- as.factor(respiratory$center)
+## 1 will be the reference level
+
+fit <- relRisk(outcome ~ treat + center + sex + age + baseline + visit,
+ id = id, corstr = "ar1", data = respiratory, ncopy=10000)
+summary(fit)
+## fit <- relRisk(outcome ~ treat + center + sex + age + baseline + visit,
+## id = id, corstr = "ex", data = respiratory)
+## summary(fit)
+## fit <- relRisk(outcome ~ treat + center + sex + age + baseline + visit,
+## id = id, corstr = "indep", data = respiratory)
+## summary(fit)
+}
+\keyword{models}
diff --git a/src/Makevars b/src/Makevars
new file mode 100755
index 0000000..e4d99d3
--- /dev/null
+++ b/src/Makevars
@@ -0,0 +1 @@
+PKG_CPPFLAGS = -I../inst/include -DNDEBUG
diff --git a/src/famstr.cc b/src/famstr.cc
new file mode 100755
index 0000000..5638ed7
--- /dev/null
+++ b/src/famstr.cc
@@ -0,0 +1,390 @@
+using namespace std;
+
+#include "tntsupp.h"
+#include "geese.h"
+#include "utils.h"
+#include "famstr.h"
+#include "float.h"
+
+extern "C" {
+#include <Rmath.h>
+}
+/*
+typedef double fun1(double);
+typedef double fun2(double, int);
+
+DVector Apply_elt(const DVector &V, fun1* f) {
+ DVector ans(V.size());
+ for (int i = 1; i <= V.size(); i++) ans(i) = f(V(i));
+ return ans;
+}
+
+DVector Apply_elt(const DVector &V, const DVector &Wave, fun2* f) {
+ DVector ans(V.size());
+ for (int i = 1; i <= V.size(); i++) ans(i) = f(V(i), (int)Wave(i));
+ return ans;
+}
+*/
+/*
+double dnorm(double x) {return dnorm4(x, 0, 1, 0);}
+
+double pnorm(double x) {return pnorm5(x, 0, 1, 1, 0);}
+
+double qnorm(double x) {return qnorm5(x, 0, 1, 1, 0);}
+*/
+
+//link functions
+
+// logit
+double linkfun_logit(double mu) {return log(mu/(1 - mu));}
+
+double linkinv_logit(double eta) {
+ double thres = - log(DBL_EPSILON);
+ eta = (eta > thres) ? thres : eta;
+ eta = (eta < - thres) ? -thres : eta;
+ return exp(eta)/(1 + exp(eta));
+}
+
+double mu_eta_logit(double eta) {
+ double thres = - log(DBL_EPSILON);
+ if (fabs(eta) >= thres) return DBL_EPSILON;
+ else return exp(eta)/pow(1 + exp(eta), 2);
+}
+
+bool valideta_logit(double eta) {return true;}
+
+//probit
+double linkfun_probit(double mu) {return qnorm(mu,0,1,1,0);}
+double linkinv_probit(double eta) {
+ double thres = -qnorm(DBL_EPSILON,0,1,1,0);
+ eta = min(thres, max(eta, -thres));
+ return pnorm(eta,0,1,1,0);
+}
+double mu_eta_probit(double eta) {
+ return max(dnorm(eta,0,1,0), DBL_EPSILON);
+}
+bool valideta_probit(double eta) {return true;}
+
+//cloglog
+double linkfun_cloglog(double mu) {return log(-log(1 - mu));}
+double linkinv_cloglog(double eta) {
+ double ans = 1 - exp(- exp(eta));
+ ans = min(1 - DBL_EPSILON, ans);
+ return max(DBL_EPSILON, ans);
+}
+double mu_eta_cloglog(double eta) {
+ eta = min(eta, 700.0);
+ return max(DBL_EPSILON, exp(eta) * exp(-exp(eta)));
+}
+bool valideta_cloglog(double eta) {return true;}
+
+//ident
+double linkfun_ident(double mu) {return mu;}
+double linkinv_ident(double eta) {return eta;}
+double mu_eta_ident(double eta) {return 1.0;}
+bool valideta_ident(double eta) {return true;}
+
+//log
+double linkfun_log(double mu) {return log(mu);}
+double linkinv_log(double eta) {return max(DBL_EPSILON, exp(eta));}
+double mu_eta_log(double eta) {return max(DBL_EPSILON, exp(eta));}
+bool valideta_log(double eta) {return true;}
+
+//sqrt
+double linkfun_sqrt(double mu) {return sqrt(mu);}
+double inkinv_sqrt(double eta) {return eta * eta;}
+double mu_eta_sqrt(double eta) {return 2 * eta;}
+bool valideta_sqrt(double eta) {return eta > 0;}
+
+//recipsquare
+double linkfun_recipsquare(double mu) {return 1 / mu / mu;}
+double linkinv_recipsquare(double eta) {return 1 / sqrt(eta);}
+double mu_eta_recipsquare(double eta) {return -1 / (2 * pow(eta, 1.5));}
+bool valideta_recipsquare(double eta) {return eta > 0;}
+
+//inverse
+double linkfun_inverse(double mu) {return 1 / mu;}
+double linkinv_inverse(double eta) {return 1 / eta;}
+double mu_eta_inverse(double eta) {return -1 / eta / eta;}
+bool valideta_inverse(double eta) {return eta != 0;}
+
+//fisherz
+double linkfun_fisherz(double mu) {return log(2/(1 - mu) - 1);}
+double linkinv_fisherz(double eta) {
+ double thres = - log(DBL_EPSILON);
+ eta = (eta > thres) ? thres : eta;
+ eta = (eta < - thres) ? -thres : eta;
+ return 1 - 2 / (exp(eta) + 1);
+}
+double mu_eta_fisherz(double eta) {
+ double thres = - log(DBL_EPSILON);
+ if (fabs(eta) >= thres) return DBL_EPSILON;
+ return 2 * exp(eta) / pow(1 + exp(eta), 2);
+}
+bool valideta_fisherz(double eta) {return true;}
+
+
+//Lin, Wei, Ying
+double linkfun_lwyBC2(double mu) {
+ return log(sqrt(mu + 1) - 1);
+}
+double linkinv_lwyBC2(double eta) {
+ double foo = max(DBL_EPSILON, exp(eta));
+ return pow(1 + foo, 2.0) - 1;
+}
+double mu_eta_lwyBC2(double eta) {
+ double foo = exp(eta);
+ return max(DBL_EPSILON, 2 * (1 + foo) * foo);
+}
+
+double linkfun_lwylog(double mu) {
+ return log(exp(mu) - 1);
+}
+double linkinv_lwylog(double eta) {
+ return log(exp(eta) + 1);
+}
+double mu_eta_lwylog(double eta) {
+ double foo = exp(eta);
+ return foo/(foo + 1);
+}
+
+//variance functions
+double variance_binomial(double mu) {return mu * (1 - mu);}
+double v_mu_binomial(double mu) {return 1 - 2 * mu;}
+bool validmu_binomial(double mu) {return mu > 0 && mu < 1;}
+
+double variance_gaussian(double mu) {return 1.0;}
+double v_mu_gaussian(double mu) {return .0;}
+bool validmu_gaussian(double mu) {return true;}
+
+double variance_poisson(double mu) {return mu;}
+double v_mu_poisson(double mu) {return 1.0;}
+bool validmu_poisson(double mu) {return mu > 0;}
+
+double variance_inverse_gaussian(double mu) {return pow(mu, 3);}
+double v_mu_inverse_gaussian(double mu) {return 3 * mu * mu;}
+bool validmu_inverse_gaussian(double mu) {return true;}
+
+double variance_Gamma(double mu) {return mu * mu;}
+double v_mu_Gamma(double mu) {return 2 * mu;}
+bool validmu_Gamma(double mu) {return mu > 0;}
+
+DMatrix cor_exch(const DVector &rho, const DVector &wave) {
+ int n = wave.size();
+ DMatrix ans(n,n);
+ for (int i = 1; i <= n; i++)
+ for (int j = 1; j <= n; j++)
+ ans(i,j) = (i == j) ? 1.0 : rho(1);
+ return ans;
+}
+
+DMatrix cor_rho_exch(const DVector &rho, const DVector &wave) {
+ int n = wave.size();
+ DMatrix ans(n * (n - 1) / 2, 1);
+ ans = 1.0;
+ return ans;
+}
+
+DMatrix cor_indep(const DVector &, const DVector &wave) {
+ return ident(wave.size());
+}
+
+DMatrix cor_rho_indep(const DVector &, const DVector &) {
+ return ident(0);
+}
+
+DMatrix cor_fixed(const DVector &rho, const DVector &wave) {
+ return cor_unstr(rho, wave);
+}
+
+DMatrix cor_rho_fixed(const DVector &, const DVector &) {
+ return ident(0);
+}
+
+
+DMatrix cor_ar1(const DVector &rho, const DVector &wave) {
+ int n = wave.size();
+ DMatrix ans(n,n);
+ for (int i = 1; i <= n; i++)
+ for (int j = 1; j <= n; j++)
+ ans(i,j) = (i == j) ? 1.0 : pow(rho(1), fabs(wave(j) - wave(i)));
+ return ans;
+}
+
+DMatrix cor_rho_ar1(const DVector &rho, const DVector &wave) {
+ int n = wave.size();
+ DMatrix ans(n * (n - 1) / 2, 1);
+ int k = 1;
+ for (int i = 1; i <= n - 1; i++) {
+ for (int j = i + 1; j <= n; j ++) {
+ double tmp = fabs(wave(j) - wave(i));
+ ans(k, 1) = (tmp == 1.0) ? 1.0 : (tmp * pow(rho(1), tmp - 1.0));
+ k++;
+ }
+ }
+ return ans;
+}
+
+DMatrix cor_unstr(const DVector &rho, const DVector &wave) {
+ DMatrix fullmat = rho2mat(rho);
+ return MatRowCol(fullmat, wave, wave);
+}
+
+DMatrix cor_rho_unstr(const DVector &rho, const DVector &wave) {
+ int n = wave.size();
+ return ident(n * (n - 1) / 2);
+}
+
+//class Corr
+Corr:: Corr(int corst, int maxwave): _corst(corst), _maxwave(maxwave) {
+ switch(corst) {
+ case INDEPENDENCE:
+ _nparam = 0; init(cor_indep, cor_rho_indep); break;
+ case EXCHANGEABLE:
+ _nparam = 1; init(cor_exch, cor_rho_exch); break;
+ case AR1:
+ _nparam = 1; init(cor_ar1, cor_rho_ar1); break;
+ case UNSTRUCTURED:
+ case USERDEFINED:
+ _nparam = maxwave; init(cor_unstr, cor_rho_unstr); break;
+ case FIXED:
+ _nparam = 0; init(cor_fixed, cor_rho_fixed); break;
+ }
+}
+
+//class Link
+//Link::Link() { Link(IDENT); }
+//Link::Link(int link) {
+Link::Link(int link) {
+ switch(link) {
+ case LOGIT:
+ init(linkfun_logit, linkinv_logit, mu_eta_logit);
+ break;
+ case IDENT:
+ init(linkfun_ident, linkinv_ident, mu_eta_ident);
+ break;
+ case PROBIT:
+ init(linkfun_probit, linkinv_probit, mu_eta_probit);
+ break;
+ case CLOGLOG:
+ init(linkfun_cloglog, linkinv_cloglog, mu_eta_cloglog);
+ break;
+ case LOG:
+ init(linkfun_log, linkinv_log, mu_eta_log);
+ break;
+ case INVERSE:
+ init(linkfun_inverse, linkinv_inverse, mu_eta_inverse);
+ break;
+ case FISHERZ:
+ init(linkfun_fisherz, linkinv_fisherz, mu_eta_fisherz);
+ break;
+ case LWYBC2:
+ init(linkfun_lwyBC2, linkinv_lwyBC2, mu_eta_lwyBC2);
+ break;
+ case LWYLOG:
+ init(linkfun_lwylog, linkinv_lwylog, mu_eta_lwylog);
+ break;
+ }
+}
+
+Link::Link(fun1* linkfun, fun1* linkinv, fun1* mu_eta) {
+ init(linkfun, linkinv, mu_eta);
+}
+
+//class Variance
+//Variance::Variance() {Variance(GAUSSIAN); }
+Variance::Variance(int var) {
+//Variance::Variance(int var) {
+ switch(var) {
+ case GAUSSIAN:
+ init(variance_gaussian, v_mu_gaussian, validmu_gaussian); break;
+ case BINOMIAL:
+ init(variance_binomial, v_mu_binomial, validmu_binomial); break;
+ case POISSON:
+ init(variance_poisson, v_mu_poisson, validmu_poisson); break;
+ case GAMMA:
+ init(variance_Gamma, v_mu_Gamma, validmu_Gamma); break;
+ }
+}
+
+//class GeeStr
+GeeStr::GeeStr(int n, Vector<int> meanlink, Vector<int> v,
+ Vector<int> scalelink, int corrlink, int scalefix) :
+ CorrLink(corrlink), ScaleFix_(scalefix) {
+ //int n = meanlink.size();
+ //MeanLink.newsize(n); V.newsize(n); ScaleLink.newsize(n);
+ Vector<Link> ML(n), SL(n); Vector<Variance> VS(n);
+ for (int i = 1; i <= n; i++) {
+ Link ml(meanlink(i)), sl(scalelink(i)); Variance vi(v(i));
+ ML(i) = ml; //MeanLink(i) = LINK[meanlink(i) - 1];
+ VS(i) = vi; //V(i) = VARIANCE[v(i) - 1];
+ SL(i) = sl; //ScaleLink(i) = LINK[scalelink(i) - 1];
+ }
+ MeanLink = ML; V = VS; ScaleLink = SL;
+}
+DVector GeeStr::MeanLinkfun(const DVector &Mu, const IVector &Wave) {
+ int size = Mu.size(); DVector ans(size);
+ for (int i = 1; i <= size; i++) ans(i) = MeanLink(Wave(i)).linkfun(Mu(i));
+ return ans;
+}
+DVector GeeStr::MeanLinkinv(const DVector &Eta, const IVector &Wave) {
+ int size = Eta.size(); DVector ans(size);
+ for (int i = 1; i <= size; i++) ans(i) = MeanLink(Wave(i)).linkinv(Eta(i));
+ return ans;
+}
+DVector GeeStr::MeanMu_eta(const DVector &Eta, const IVector &Wave) {
+ int size = Eta.size(); DVector ans(size);
+ for (int i = 1; i <= size; i++) ans(i) = MeanLink(Wave(i)).mu_eta(Eta(i));
+ return ans;
+}
+DVector GeeStr::ScaleLinkfun(const DVector &Mu, const IVector &Wave) {
+ int size = Mu.size(); DVector ans(size);
+ for (int i = 1; i <= size; i++) ans(i) = ScaleLink(Wave(i)).linkfun(Mu(i));
+ return ans;
+}
+DVector GeeStr::ScaleLinkinv(const DVector &Eta, const IVector &Wave) {
+ int size = Eta.size(); DVector ans(size);
+ for (int i = 1; i <= size; i++) ans(i) = ScaleLink(Wave(i)).linkinv(Eta(i));
+ return ans;
+}
+DVector GeeStr::ScaleMu_eta(const DVector &Eta, const IVector &Wave) {
+ int size = Eta.size(); DVector ans(size);
+ for (int i = 1; i <= size; i++) ans(i) = ScaleLink(Wave(i)).mu_eta(Eta(i));
+ return ans;
+}
+DVector GeeStr::CorrLinkfun(const DVector &Mu) {
+ int size = Mu.size(); DVector ans(size);
+ for (int i = 1; i <= size; i++) ans(i) = CorrLink.linkfun(Mu(i));
+ return ans;
+}
+DVector GeeStr::CorrLinkinv(const DVector &Eta) {
+ int size = Eta.size(); DVector ans(size);
+ for (int i = 1; i <= size; i++) ans(i) = CorrLink.linkinv(Eta(i));
+ return ans;
+}
+DVector GeeStr::CorrMu_eta(const DVector &Eta) {
+ int size = Eta.size(); DVector ans(size);
+ for (int i = 1; i <= size; i++) ans(i) = CorrLink.mu_eta(Eta(i));
+ return ans;
+}
+DVector GeeStr::v(const DVector &Mu, const IVector &Wave) {
+ int size = Mu.size(); DVector ans(size);
+ for (int i = 1; i <= size; i++) ans(i) = V(Wave(i)).v(Mu(i));
+ return ans;
+}
+DVector GeeStr::v_mu(const DVector &Mu, const IVector &Wave) {
+ int size = Mu.size(); DVector ans(size);
+ for (int i = 1; i <= size; i++) ans(i) = V(Wave(i)).v_mu(Mu(i));
+ return ans;
+}
+bool GeeStr::validMu(const DVector &Mu, const IVector &Wave) {
+ int size = Mu.size();
+ bool ans = true;
+ for (int i = 1; i <= size; i++) {
+ if ( !( V(Wave(i)).validmu(Mu(i)) ) ) {
+ ans = false;
+ break;
+ }
+ }
+ return ans;
+}
diff --git a/src/gee2.cc b/src/gee2.cc
new file mode 100755
index 0000000..e67cc23
--- /dev/null
+++ b/src/gee2.cc
@@ -0,0 +1,506 @@
+// using namespace std;
+
+// #include "tntsupp.h"
+// #include "geese.h"
+
+// extern "C"{
+// #include <R.h>
+// #include <Rmath.h>
+// #include <Rdefines.h>
+// }
+
+// #include "famstr.h"
+// #include "param.h"
+// #include "inter.h"
+// #include "utils.h"
+// #include "geesubs.h"
+#include "gee2.h"
+
+IVector comp_lev(GeeStr &geestr, Corr &cor) {
+ IVector level(2);
+ if (geestr.ScaleFix() != 1) level(1) = 1;
+ if (cor.nparam() > 0) level(2) = 1;
+ return level;
+}
+
+DMatrix gee_infls(DVector &Y, DMatrix &X,
+ DVector &Offset, DVector &Doffset, DVector &W,
+ IVector &LinkWave,
+ DMatrix &Zsca, DMatrix &Zcor, DVector &CorP,
+ IVector &Clusz,
+ GeeStr &geestr, Corr &cor, GeeParam &par, Control &con) {
+ Hess Hi(par), H(par); Grad Gi(par);
+
+ int n = Clusz.size();
+ IVector ZcorSize(n);
+ //if (cor.nparam() > 1)
+ if (cor.corst() > AR1) // == UNSTRUCTRUED || USERDEFINED || FIXED
+ for (int i = 1; i <= n; i++)
+ ZcorSize(i) = Clusz(i) * (Clusz(i) - 1) / 2;
+ else ZcorSize = 1;
+
+ IVector level(2); level = 0;
+ if (geestr.ScaleFix() != 1) level(1) = 1;
+ if (cor.nparam() > 0) level(2) = 1;
+
+ int p = par.p(), q = par.q(), r = par.r();
+ DMatrix L11(p,p), L12(p,r), L13(p,q), L22(r,r), L23(r,q), L33(q,q);
+ int l = p + q + r;
+ DMatrix infls(l, n), HH(l, l);
+
+ Index1D I(0,0), J(0,0);
+ Index1D I1(0, 0), JJ(0, 0), I2(0, 0), I3(0, 0);
+ I1 = Index1D(1, p);
+ I2 = Index1D(p + 1, p + r);
+ I3 = Index1D(p + r + 1, p + r + q);
+ for (int i = 1; i <= n; i++) {
+ int s1 = Clusz(i), s2 = ZcorSize(i), crs = s1 * (s1 - 1) / 2;;
+ I = Index1D(1, s1) + I.ubound();
+ if (s2 > 0) J = Index1D(1, s2) + J.ubound();
+ DVector PRi(s1), Vi(s1), V_Mui(s1); DMatrix Di(s1,p);
+ gee_prep(Y, X, Offset, I, LinkWave, par, geestr, PRi, Di, Vi, V_Mui);
+ DVector Phii(s1); DMatrix D2i(s1, r);
+ PhiandD2(I, LinkWave, Doffset, Zsca, par, geestr, Phii, D2i);
+ DMatrix R(s1, s1), E(crs, q);
+ RandE(Zcor, I, J, CorP, par, geestr, cor, R, E);
+ //cout << "i = " << i;
+ DVector Wi = asVec(VecSubs(W, I));
+ HiandGi(PRi, Phii, Di, R, Vi, V_Mui, D2i, E, Wi, level, Hi, Gi);
+ //cout << "Hi = " << Hi; cout << "H = " << H;
+ //cout << "Gi = " << Gi;
+ H.inc(Hi);
+ JJ = Index1D(i, i);
+ infls(I1, JJ) = asColMat(Gi.U1());
+ if (level(1) == 1) infls(I2, JJ) = asColMat(Gi.U2());
+ if (level(2) == 1) infls(I3, JJ) = asColMat(Gi.U3());
+ }
+ Hess Hinv = inv(H, level);
+ I1 = Index1D(1, p);
+ HH(I1, I1) = Hinv.A();
+ if (level(1) == 1) {
+ HH(I2, I1) = Hinv.B();
+ HH(I2, I2) = Hinv.C();
+ }
+ if (level(2) == 1) {
+ HH(I3, I1) = Hinv.D();
+ HH(I3, I3) = Hinv.F();
+ if (level(1) == 1) HH(I3, I2) = Hinv.E();
+ }
+ infls = HH * infls;
+ return infls;
+}
+
+
+void gee_var(DVector &Y, DMatrix &X,
+ DVector &Offset, DVector &Doffset, DVector &W,
+ IVector &LinkWave,
+ DMatrix &Zsca, DMatrix &Zcor, DVector &CorP,
+ IVector &Clusz, IVector &ZcorSize,
+ GeeStr &geestr, Corr &cor, GeeParam &par, Control &con) {
+ Hess Hi(par), H(par); Grad Gi(par);
+
+ IVector level(2); level = 0;
+ if (geestr.ScaleFix() != 1) level(1) = 1;
+ if (cor.nparam() > 0) level(2) = 1;
+
+ int p = par.p(), q = par.q(), r = par.r();
+ DMatrix L11(p,p), L12(p,r), L13(p,q), L22(r,r), L23(r,q), L33(q,q);
+
+ Index1D I(0,0), J(0,0);
+ for (int i = 1; i <= Clusz.size(); i++) {
+ int s1 = Clusz(i), s2 = ZcorSize(i), crs = s1 * (s1 - 1) / 2;;
+ I = Index1D(1, s1) + I.ubound();
+ if (s2 > 0) J = Index1D(1, s2) + J.ubound();
+ DVector PRi(s1), Vi(s1), V_Mui(s1); DMatrix Di(s1,p);
+ gee_prep(Y, X, Offset, I, LinkWave, par, geestr, PRi, Di, Vi, V_Mui);
+ DVector Phii(s1); DMatrix D2i(s1, r);
+ PhiandD2(I, LinkWave, Doffset, Zsca, par, geestr, Phii, D2i);
+ DMatrix R(s1, s1), E(crs, q);
+ RandE(Zcor, I, J, CorP, par, geestr, cor, R, E);
+ //cout << "i = " << i;
+ DVector Wi = asVec(VecSubs(W, I));
+ HiandGi(PRi, Phii, Di, R, Vi, V_Mui, D2i, E, Wi, level, Hi, Gi);
+ //cout << "Hi = " << Hi; cout << "H = " << H;
+ //cout << "Gi = " << Gi;
+ H.inc(Hi);
+ L11 = L11 + outerprod(Gi.U1());
+ if (level(1) == 1) {
+ L12 = L12 + outerprod(Gi.U1(), Gi.U2());
+ L22 = L22 + outerprod(Gi.U2());
+ }
+ if (level(2) == 1) {
+ L13 = L13 + outerprod(Gi.U1(), Gi.U3());
+ L33 = L33 + outerprod(Gi.U3());
+ if (level(1) == 1) L23 = L23 + outerprod(Gi.U2(), Gi.U3());
+ }
+ }
+ //Vbeta:
+ Hess Hinv = inv(H, level);
+ par.set_vbeta_naiv(Hinv.A());
+ par.set_vbeta(Hinv.A() * L11 * Hinv.A());
+
+ //Vgamma:
+ if (level(1) == 1) {
+ par.set_vgamma((Hinv.B() * L11 + Hinv.C() * transpose(L12))
+ * transpose(Hinv.B()) +
+ (Hinv.B() * L12 + Hinv.C() * L22) * Hinv.C());
+ }
+
+ //Valpha:
+ if (level(2) == 1) {
+ par.set_valpha_naiv(Hinv.F());
+ par.set_valpha_stab(Hinv.F() * L33 * Hinv.F());
+ par.set_valpha((Hinv.D() * L11 + Hinv.E() * transpose(L12) +
+ Hinv.F() * transpose(L13)) * transpose(Hinv.D()) +
+ (Hinv.D() * L12 + Hinv.E() * L22 +
+ Hinv.F() * transpose(L23)) * transpose(Hinv.E()) +
+ (Hinv.D() * L13 + Hinv.E() * L23 +
+ Hinv.F() * L33) * Hinv.F());
+ }
+}
+
+
+double update_beta(DVector &Y, DMatrix &X, DVector &Offset,
+ DVector &W, DVector &Phi,
+ IVector &LinkWave, DVector &CorP,
+ DMatrix &Zcor, IVector &Clusz,
+ IVector &ZcorSize, IVector &Jack,
+ GeeParam &par, GeeStr &geestr, Corr &cor) {
+ double del = 0;
+ // DVector alp = par.alpha();
+ int p = par.p();
+ DMatrix H(p,p); DVector G(p);
+ int n = Clusz.size();
+ Index1D I(0,0), J(0,0);
+ for (int i = 1; i <= n; i++) {
+ int s1 = Clusz(i), s2 = ZcorSize(i);
+ I = Index1D(1, s1) + I.ubound();
+ if (s2 > 0) J = Index1D(1, s2) + J.ubound(); //?? what is s2 == 0 ??
+ if (Jack(i) == 1) continue;
+ DVector PRi(s1); DMatrix Di(s1,p);
+ PRandD(Y, X, Offset, I, LinkWave, par, geestr, PRi, Di);
+ DVector rootInvPhii = sqrt(recip(asVec(VecSubs(Phi, I))));
+ DVector rootWi = sqrt(asVec(VecSubs(W, I)));
+ Di = SMult(rootWi, Di); PRi = SMult(rootWi, PRi);
+ Di = SMult(rootInvPhii, Di); PRi = SMult(rootInvPhii, PRi);
+ DMatrix R = getR(Zcor, I, J, CorP, par, geestr, cor);
+ H = H + AtBiC(Di, R, Di);
+ G = G + AtBiC(Di, R, PRi);
+ }
+ DVector Del = solve(H, G);
+ DVector Bnew = par.beta() + Del;
+ while (1) {
+ // cerr << "in updating beta: " << "Del = " << Del << endl;
+ DVector Eta = X * Bnew + Offset;
+ DVector Mu = geestr.MeanLinkinv(Eta, LinkWave);
+ if (geestr.validMu(Mu, LinkWave)) break;
+ Del = 0.5 * Del;
+ Bnew = par.beta() + Del;
+ }
+ par.set_beta(Bnew);
+ del = fmax(fabs(Del));
+ return del;
+}
+
+double update_gamma(DVector &PR, DVector &W, IVector &LinkWave,
+ IVector &Clusz, IVector &Jack,
+ DVector &Doffset, DMatrix &Zsca,
+ GeeParam &par, GeeStr &geestr) {
+ double del = 0;
+ int r = par.r(), n = Clusz.size();
+ // double adj = (double) (PR.size()) / (double)(PR.size() - par.p());
+ if (geestr.ScaleFix() == 1) return del;
+ DMatrix H(r,r); DVector G(r);
+ Index1D I(0,0);
+ for (int i = 1; i <= n; i++) {
+ int s1 = Clusz(i);
+ I = Index1D(1, s1) + I.ubound();
+ if (Jack(i) == 1) continue;
+ DVector Phii(s1), Si(s1); DMatrix D2i(s1, r);
+ gm_prep(PR, I, LinkWave, Doffset, Zsca, par, geestr, Phii, Si, D2i);
+
+ //DMatrix V2 = diag(2.0 * Phii);
+ //independence working structure only now, so no inverting below
+ DVector WiV2inv = SMult(asVec(VecSubs(W, I)), recip(2.0 * Phii));
+ H = H + Transpose_view(D2i) * SMult(WiV2inv, D2i);
+ G = G + Transpose_view(D2i) * SMult(WiV2inv, Si - Phii); //adj * Si
+ //H = H + AtBiC(D2i, WiV2, D2i);
+ //G = G + AtBiC(D2i, WiV2, Si - Phii);
+ }
+ DVector Del = solve(H, G);
+ //cout << "H = " << H << "G = " << G;
+ //par.set_gamma((double) N / (double)(N - p) * (par.gamma() + Del));
+ par.set_gamma(par.gamma() + Del);
+ del = fmax(fabs(Del));
+ return del;
+}
+
+double update_alpha(DVector &PR, DVector &Phi, DVector &CorP, DVector &W,
+ IVector &Clusz, IVector &ZcorSize, IVector &Jack,
+ DMatrix &Zcor,
+ GeeParam &par, GeeStr &geestr, Corr &cor) {
+ double del = 0;
+ int q = par.q(), n = Clusz.size();
+ if (cor.nparam() == 0) return del;
+ DMatrix H(q,q); DVector G(q);
+ Index1D I(0,0), J(0,0);
+ for (int i = 1; i <= n; i++) {
+ int s1 = Clusz(i), s2 = ZcorSize(i), crs = s1 * (s1 - 1) / 2;
+ I = Index1D(1, s1) + I.ubound();
+ if (s2 > 0) J = Index1D(1, s2) + J.ubound();
+ if (Jack(i) == 1) continue;
+ if (s1 == 1) continue;
+
+ DVector PRi = asVec(VecSubs(PR, I));
+ DVector Phii = asVec(VecSubs(Phi, I));
+ DVector sPRi = SMult(reciproot(Phii), PRi);
+ DVector zi = genzi(sPRi);
+
+ DMatrix R(s1, s1), E(crs, q);
+ RandE(Zcor, I, J, CorP, par, geestr, cor, R, E);
+ DVector rhoi = utri(R);
+ DVector Wi = asVec(VecSubs(W, I));
+ //DMatrix V3 = diag(genzi(rootWi));
+ //independence working correlation only now, no need of inverting below
+ DVector WiV3inv = genzi(Wi);
+ H = H + Transpose_view(E) * SMult(WiV3inv, E);
+ G = G + Transpose_view(E) * SMult(WiV3inv, zi - rhoi);
+ //H = H + AtBiC(E, V3, E);
+ //G = G + AtBiC(E, V3, zi - rhoi);
+ }
+ DVector Del = solve(H, G);
+ par.set_alpha(par.alpha() + Del);
+ del = fmax(fabs(Del));
+ return del;
+}
+
+/*********************************************************
+Input:
+ Y: response vector;
+ X: covariate matrix for mean structure;
+ LinkWave: determines which link to apply on each response component;
+ Weight: weight, to be implemented ... ... ???;
+ Offset: offset, to be implemented ... ... ???;
+ Zsca: covariate matrix for scale structure;
+ Zcor: covariate matrix for correlation structure;
+ Corp: correlation parameters to feed cor.mat(rho, .), can be distances for spatial correlation; it is now a vector, which can not really handle >=2 spatial correlations; it really should be a matrix which contains the data to feed cor.mat(rho, .); it actually is the same as LinkWave now, but should be more general to contain high dimensional data, such as coordinates in R x R.
+ Clusz: cluster sizes;
+ ZcorSize: number of rows in Zcor for each cluster;
+ geestr: GEE structure, contains links, variances for each wave;
+ cor: correlation structure;
+ par: parameter values;
+ Jack: Jackknife indicator;
+ con: control parameters: ScaleFix, ajs, j1s, fij, tol, maxiter;
+*********************************************************/
+void gee_est(DVector &Y, DMatrix &X,
+ DVector &Offset, DVector &Doffset, DVector &W,
+ IVector &LinkWave,
+ DMatrix &Zsca, DMatrix &Zcor, DVector &CorP,
+ IVector &Clusz, IVector &ZcorSize,
+ GeeStr &geestr, Corr &cor, GeeParam &par,
+ IVector &Jack, Control &con) {
+ DVector Del(3);
+
+ int N = Y.size();
+ DVector PR(N), Phi(N);
+
+ int iter; double del;
+ for (iter = 0; iter < con.maxiter(); iter++) {
+ if (con.trace() == 1) {
+ //cerr << "iter " << iter << endl;
+ //cerr << "beta = " << par.beta() << "gamma = " << par.gamma() << "alpha = " << par.alpha();
+ Rprintf("iter = %d\n", iter);
+ Rprintf("beta = "); VecPrint(par.beta());
+ Rprintf("gamma = "); VecPrint(par.gamma());
+ Rprintf("alpha = "); VecPrint(par.alpha());
+ }
+ //updating beta;
+ Phi = getPhi(Doffset, Zsca, LinkWave, par, geestr);
+ Del(1) = update_beta(Y, X, Offset, W, Phi, LinkWave, CorP, Zcor, Clusz, ZcorSize, Jack, par, geestr, cor);
+
+ //updating gamma;
+ PR = getPR(Y, X, Offset, LinkWave, par, geestr);
+ //cout << "PR = " << PR;
+ //PR = (double) (N / (N - p)) * PR; //df adjusting
+ Del(2) = update_gamma(PR, W, LinkWave, Clusz, Jack, Doffset, Zsca, par, geestr);
+
+ //updating alpha;
+ Phi = getPhi(Doffset, Zsca, LinkWave, par, geestr);
+ Del(3) = update_alpha(PR, Phi, CorP, W, Clusz, ZcorSize, Jack, Zcor, par, geestr, cor);
+
+ del = fmax(Del);
+ if (del <= con.tol()) break;
+ }
+ if (iter == con.maxiter()) par.set_err(1);
+}
+
+void getJackVar(Vector<DVector> &beta_i, Vector<DVector> &alpha_i,
+ Vector<DVector> &gamma_i, GeeParam &par,
+ int jack) { //jack = 1, 2, 3 for ajs, j1s, fij
+ int I = beta_i.size(), p = par.p(), q = par.q(), r = par.r();
+ DMatrix vb(p,p), va(q,q), vc(r,r);
+ //cout << par.beta();
+ for (int i = 1; i <= I; i++) {
+ //cout << "i = " << i << " " << beta_i(i);
+ vb = vb + outerprod(beta_i(i) - par.beta());
+ //can use level as in gee2_var
+ va = va + outerprod(alpha_i(i) - par.alpha());
+ vc = vc + outerprod(gamma_i(i) - par.gamma());
+ }
+
+ double f = (double) (I - p - q - r) / I;
+ if (jack == 3) {//fij
+ par.set_vbeta_fij(f * vb);
+ par.set_valpha_fij(f * va);
+ par.set_vgamma_fij(f * vc);
+ }
+ else if (jack == 2) { //j1s
+ par.set_vbeta_j1s(f * vb);
+ par.set_valpha_j1s(f * va);
+ par.set_vgamma_j1s(f * vc);
+ }
+ else {//ajs
+ par.set_vbeta_ajs(f * vb);
+ par.set_valpha_ajs(f * va);
+ par.set_vgamma_ajs(f * vc);
+ }
+}
+
+void gee_jack(DVector &Y, DMatrix &Xmat, DVector &Offset, DVector &Doffset,
+ DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor,
+ DVector &CorP, IVector &Clusz, IVector &ZcorSize,
+ GeeStr &geestr, Corr &cor,
+ GeeParam &par, Control &con) {
+ int I = Clusz.size();
+ // int p = par.p(), q = par.q(), r = par.r();
+ IVector Jack(I);
+ Vector<DVector> beta_i(I), alpha_i(I), gamma_i(I);
+ Vector<DVector> beta_fi(I), alpha_fi(I), gamma_fi(I);
+ //DVector b0(p), a0(q), c0(r);
+ //beta_i = b0; alpha_i(I) = a0; gamma_i(I) = c0;
+ //beta_fi = b0; alpha_fi(I) = a0; gamma_fi(I) = c0;
+ Control con1(con); con1.set_maxiter(1); //for j1s
+
+ for (int i = 1; i <= I; i++) {
+ Jack(i) = 1;
+ GeeParam par_i(par.beta(), par.alpha(), par.gamma());
+ if (con.j1s() == 1) {
+ gee_est(Y, Xmat, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, ZcorSize, geestr, cor, par_i, Jack, con1); //1-step
+ beta_i(i) = par_i.beta();
+ alpha_i(i) = par_i.alpha();
+ gamma_i(i) = par_i.gamma();
+ }
+
+ if (con.fij() == 1) {
+ gee_est(Y, Xmat, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, ZcorSize, geestr, cor, par_i, Jack, con); //full iterated
+ beta_fi(i) = par_i.beta();
+ alpha_fi(i) = par_i.alpha();
+ gamma_fi(i) = par_i.gamma();
+ }
+ Jack(i) = 0;
+ }
+ if (con.j1s() == 1) getJackVar(beta_i, alpha_i, gamma_i, par, 2);
+ if (con.fij() == 1) getJackVar(beta_fi, alpha_fi, gamma_fi, par, 3);
+}
+
+void jack_ajs(DVector &Y, DMatrix &X, DVector &Offset, DVector &Doffset,
+ DVector &W, IVector &LinkWave, DMatrix &Zsca, DMatrix &Zcor,
+ DVector &CorP, IVector &Clusz, IVector &ZcorSize,
+ GeeStr &geestr, Corr &cor,
+ GeeParam &par, Control &con) {//con is not used
+ int I = Clusz.size(), p = par.p(), q = par.q(), r = par.r();
+ Vector<Hess> His(I); Vector<Grad> Gis(I);
+ IVector level = comp_lev(geestr, cor), Scur(Y.size()); Scur = 1;
+ HisandGis(Y, X, Offset, Doffset, W, LinkWave, Clusz, ZcorSize,
+ Zsca, Zcor, CorP, par, geestr, cor, Scur, level,
+ His, Gis);
+ Hess Hn(par);
+ for (int i = 1; i <= I; i++) Hn.inc(His(i));
+
+ Vector<DVector> beta_i(I), alpha_i(I), gamma_i(I);
+ DVector b0(p), a0(q), c0(r);
+ beta_i = b0; alpha_i(I) = a0; gamma_i(I) = c0;
+
+ DMatrix vb(p,p), va(q,q), vc(r,r);
+ for (int i = 1; i <= I; i++) {
+ Hess H_i = Hn - His(i);
+ H_i = inv(H_i, level);
+ beta_i(i) = H_i.A() * Gis(i).U1();
+ gamma_i(i) = H_i.B() * Gis(i).U1() + H_i.C() * Gis(i).U2();
+ alpha_i(i) = H_i.D() * Gis(i).U1() + H_i.E() * Gis(i).U2() + H_i.F() * Gis(i).U3();
+ vb = vb + outerprod(beta_i(i));
+ //can use level as in gee2_var
+ va = va + outerprod(alpha_i(i));
+ vc = vc + outerprod(gamma_i(i));
+ }
+ double f = (double) (I - p - q - r) / I;
+ par.set_vbeta_ajs(f * vb);
+ par.set_valpha_ajs(f * va);
+ par.set_vgamma_ajs(f * vc);
+}
+
+void gee_top(DVector &Y, DMatrix &Xmat,
+ DVector &Offset, DVector &Doffset, DVector &W,
+ IVector &LinkWave,
+ DMatrix &Zsca, DMatrix &Zcor, DVector &CorP,
+ IVector &Clusz,
+ GeeStr &geestr, Corr &cor, GeeParam &par,
+ Control &con) {
+ int I = Clusz.size();
+ IVector Jack(I), ZcorSize(I);
+ //initializing ZcorSize
+ //if (cor.nparam() > 1)
+ if (cor.corst() > AR1) // == UNSTRUCTRUED || USERDEFINED || FIXED
+ for (int i = 1; i <= I; i++)
+ ZcorSize(i) = Clusz(i) * (Clusz(i) - 1) / 2;
+ else ZcorSize = 1;
+
+ gee_est(Y, Xmat, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, ZcorSize, geestr, cor, par, Jack, con);
+
+ gee_var(Y, Xmat, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, ZcorSize, geestr, cor, par, con);
+
+ if (con.ajs() == 1)
+ jack_ajs(Y, Xmat, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, ZcorSize, geestr, cor, par, con);
+
+ if (con.j1s() + con.fij() > 0)
+ gee_jack(Y, Xmat, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, ZcorSize, geestr, cor, par, con);
+}
+
+extern "C" {
+ SEXP gee_rap(SEXP y, SEXP x, SEXP offset, SEXP doffset, SEXP w,
+ SEXP linkwave, SEXP zsca, SEXP zcor, SEXP corp,
+ SEXP clusz, SEXP geestr, SEXP cor, SEXP par, SEXP con) {
+ DVector Y = asDVector(y), Offset = asDVector(offset), Doffset = asDVector(doffset), W = asDVector(w);
+ IVector LinkWave = asIVector(linkwave);
+ DVector CorP = asDVector(corp);
+ DMatrix X = asDMatrix(x), Zsca = asDMatrix(zsca), Zcor = asDMatrix(zcor);
+ IVector Clusz = asIVector(clusz); // ZcorSize = asIVector(zcorsize);
+ Control Con = asControl(con);
+ GeeParam Par = asGeeParam(par);
+ GeeStr Geestr = asGeeStr(geestr);
+ Corr Cor = asCorr(cor);
+
+ gee_top(Y, X, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, Geestr, Cor, Par, Con);
+ SEXP ans = asSEXP(Par);
+ return ans;
+ }
+
+ /* return the influence functions for parameters */
+ SEXP infls_rap(SEXP y, SEXP x, SEXP offset, SEXP doffset, SEXP w,
+ SEXP linkwave, SEXP zsca, SEXP zcor, SEXP corp,
+ SEXP clusz, SEXP geestr, SEXP cor, SEXP par, SEXP con) {
+ DVector Y = asDVector(y), Offset = asDVector(offset), Doffset = asDVector(doffset), W = asDVector(w);
+ IVector LinkWave = asIVector(linkwave);
+ DVector CorP = asDVector(corp);
+ DMatrix X = asDMatrix(x), Zsca = asDMatrix(zsca), Zcor = asDMatrix(zcor);
+ IVector Clusz = asIVector(clusz); // ZcorSize = asIVector(zcorsize);
+ Control Con = asControl(con);
+ GeeParam Par = asGeeParam(par);
+ GeeStr Geestr = asGeeStr(geestr);
+ Corr Cor = asCorr(cor);
+
+ DMatrix infls = gee_infls(Y, X, Offset, Doffset, W, LinkWave, Zsca, Zcor, CorP, Clusz, Geestr, Cor, Par, Con);
+ SEXP ans = asSEXP(infls);
+ return ans;
+ }
+}
diff --git a/src/geesubs.cc b/src/geesubs.cc
new file mode 100755
index 0000000..6992225
--- /dev/null
+++ b/src/geesubs.cc
@@ -0,0 +1,550 @@
+// Sep. 17, 2012:
+// workaround since it does not compile otherwise --- Thank B. Ripley
+// I spent hours but could not figure out why it would not work
+// without this undef. Should keep it in mind.
+// Jan. 26, 2012:
+// This line is commented out to remove NOTE of assert
+// from R CMD check, as suggested by K. Hornik and B. Ripley.
+// #undef NDEBUG
+
+using namespace std;
+
+#include "tntsupp.h"
+#include "geese.h"
+#include "famstr.h"
+#include "param.h"
+#include "geesubs.h"
+#include "utils.h"
+
+#include "inter.h"
+
+//#include "lgtdl.h"
+//#include "fgee.h"
+
+/*******************************************************************/
+
+Grad & Grad::operator=(const Grad &G) {
+ U1_ = G.U1_; U2_ = G.U2_; U3_ = G.U3_;
+ return *this;
+}
+
+ostream& operator<<(ostream& s, const Grad &G) {
+ s << "U1 = " << G.U1() << "U2 = " << G.U2() << "U3 = " << G.U3();
+ return s;
+}
+
+Hess operator-(Hess &H1, Hess &H2) {
+ Hess ans(H1);
+ ans.dec(H2);
+ return ans;
+}
+
+
+Hess inv(Hess &H, IVector &level) {
+ Hess ans(H);
+ ans.set_A(inv(H.A()));
+ if (level(1) == 1) {
+ ans.set_C(inv(H.C()));
+ ans.set_B(-1.0 * ans.C() * H.B() * ans.A());
+ }
+ if (level(2) == 1) {
+ ans.set_F(inv(H.F()));
+ ans.set_E(-1.0 * ans.F() * H.E() * ans.C());
+ ans.set_D(-1.0 * ans.F() * (H.D() * ans.A() + H.E() * ans.B()));
+ }
+ return ans;
+}
+
+Hess operator*(const double &x, const Hess &H) {
+ Hess ans(H);
+ ans.set_A(x * H.A()); ans.set_B(x * H.B()); ans.set_C(x * H.C());
+ ans.set_D(x * H.D()); ans.set_E(x * H.E()); ans.set_F(x * H.F());
+ return ans;
+}
+
+ostream& operator<<(ostream& s, const Hess &H) {
+ s << "A = " << H.A() << "B = " << H.B() << "C = " << H.C()
+ << "D = " << H.D()<< "E = " << H.E() << "F = " << H.F();
+ return s;
+}
+
+DVector genzi(const DVector &PR) {
+ int n = PR.size();
+ DVector ans(n * (n - 1)/2);
+ int k = 1;
+ for (int i = 1; i <= n - 1; i++)
+ for (int j = i + 1; j <= n; j++) ans(k++) = PR(i) * PR(j);
+ return ans;
+}
+
+DVector utri(const DMatrix &R) {
+ int n = R.dim(1);
+ //assert (n > 1);
+ DVector ans(n * (n - 1) / 2);
+ int k = 1;
+ for (int i = 1; i <= n - 1; i++)
+ for (int j = i + 1; j <= n; j++) ans(k++) = R(i,j);
+ return ans;
+}
+
+DMatrix getZ_Beta(DMatrix &D, DVector &PR,
+ DVector &V, DVector &V_Mu, DVector &z) {
+ //note: this is the version which excludes phi in the formula
+ DMatrix ans(z.size(), D.dim(2));
+ int k = 1, n = PR.size();
+ for (int i = 1; i <= n - 1; i++) {
+ DMatrix Di = asMat(MatRow(D,i));
+ for (int j = i + 1; j <= n; j++) {
+ DMatrix Dj = asMat(MatRow(D,j));
+ DMatrix foo = V_Mu(i) * reciproot(V(i)) * Di +
+ V_Mu(j) * reciproot(V(j)) * Dj;
+ DMatrix bar = - PR(i) * Di - PR(j) * Dj - 0.5 * PR(i) * PR(j) * foo;
+ //cout << "bar = " << bar << "k = " << k;
+ MatRow(ans, k) = bar;
+ //cout << " ans = " << ans;
+ k++;
+ }
+ }
+ return ans;
+}
+
+DMatrix getZ_Gamma(DMatrix &D, DVector &PR, DVector &Phi, DVector &z) {
+ DMatrix ans(z.size(), D.dim(2));
+ int k = 1, n = PR.size();
+ for (int i = 1; i <= n - 1; i++) {
+ DMatrix Di = asMat(MatRow(D,i));
+ for (int j = i + 1; j <= n; j++) {
+ DMatrix Dj = asMat(MatRow(D,j));
+ //MatRow(ans, k) = -0.5 * z(k) * (sqrt(Phi(j)/Phi(i)) * Di +
+ //sqrt(Phi(i)/Phi(j)) * Dj);
+ //This has caused the scale problem; The first time, scale problem was caused by operator * for Hess, where one component did not get touched, in the old geese (LAPACK);
+ MatRow(ans, k) = -0.5 * z(k) * (1.0 / Phi(i) * Di +
+ 1.0 / Phi(j) * Dj);
+ k++;
+ }
+ }
+ return ans;
+}
+
+DMatrix getS_Beta(DMatrix &D, DVector &PR, DVector &V, DVector &V_Mu) {
+ DMatrix ans(D);
+ for (int i = 1; i <= ans.dim(1); i++) {
+ DMatrix Di = asMat(MatRow(D,i));
+ double f = -2 * PR(i) / sqrt(V(i)) - PR(i) * PR(i)/V(i) * V_Mu(i);
+ MatRow(ans, i) = f * Di;
+ }
+ return ans;
+}
+
+void HiandGi(DVector &PRi, DVector &Phii, DMatrix &Di, DMatrix &R,
+ DVector &Vi, DVector &V_Mui, DMatrix &D2i, DMatrix &E,
+ DVector &Wi, IVector &level,
+ //output
+ Hess &H, Grad &G) {
+ int s = PRi.size();
+ //beta
+ DVector rootPhii = sqrt(Phii);
+ DMatrix V1 = diag(rootPhii) * R * diag(rootPhii);
+ DVector rootWi = sqrt(Wi);
+ DMatrix rootWD = SMult(rootWi, Di);
+ DVector rootWPR = SMult(rootWi, PRi);
+ H.set_A(AtBiC(rootWD, V1, rootWD));
+ G.set_U1(AtBiC(rootWD, V1, rootWPR));
+ //H.set_A(AtBiC(Di, V1, Di));
+ //G.set_U1(AtBiC(Di, V1, PRi));
+ //gamma
+ if (level(1) == 1) {//if (par.ScaleFix() != 1) {
+ DVector Si = square(PRi);
+ DVector WiV2inv = SMult(Wi, recip(2.0 * Phii));
+ H.set_C(Transpose_view(D2i) * SMult(WiV2inv, D2i));
+ DMatrix S_Beta = getS_Beta(Di, PRi, Vi, V_Mui);
+ H.set_B(Transpose_view(D2i) * SMult(-1.0 * WiV2inv, S_Beta));
+ G.set_U2(Transpose_view(D2i) * SMult(WiV2inv, Si - Phii));
+ //DMatrix V2 = diag(2.0 * Phii);
+ //H.set_C(AtBiC(D2i, V2, D2i));
+ //DMatrix S_Beta = getS_Beta(Di, PRi, Vi, V_Mui);
+ //H.set_B(AtBiC(D2i, V2, S_Beta));
+ //G.set_U2(AtBiC(D2i, V2, S - Phii));
+ }
+ //alpha
+ if (level(2) == 1) {//if (cor.nparam() > 0) {
+ if (s == 1) return;
+ DVector sPRi = SMult(reciproot(Phii), PRi);
+ DVector zi = genzi(sPRi);
+ DVector rhoi = utri(R);
+ //DMatrix W = ident(s * (s - 1) / 2);
+ DVector Sca = genzi(reciproot(Phii));
+ DVector WiV3inv = genzi(Wi);
+
+ //H.set_F(AtBiC(E, W, E));
+ H.set_F(Transpose_view(E) * SMult(WiV3inv, E));
+ DMatrix Z_Beta = getZ_Beta(Di, PRi, Vi, V_Mui, zi);
+ Z_Beta = SMult(Sca, Z_Beta);
+ //H.set_D(AtBiC(E, W, Z_Beta));
+ H.set_D(Transpose_view(E) * SMult(-1.0 * WiV3inv, Z_Beta));
+ //G.set_U3(AtBiC(E, W, zi - rhoi));
+ G.set_U3(Transpose_view(E) * SMult(WiV3inv, zi - rhoi));
+ if (level(1) == 1) {//if (par.ScaleFix() != 1) {
+ DMatrix Z_Gamma = getZ_Gamma(D2i, PRi, Phii, zi);
+ //H.set_E(AtBiC(E, W, Z_Gamma));
+ H.set_E(Transpose_view(E) * SMult(-1.0 * WiV3inv, Z_Gamma));
+ }
+ }
+}
+
+void PRandD(DVector &Yi, DMatrix &Xi, DVector &Offseti,
+ IVector &Wavei, GeeParam &par, GeeStr &geestr,
+ DVector &PRi, DMatrix &Di) {
+ DVector Eta = Xi * par.beta() + Offseti;
+ DVector Mu = geestr.MeanLinkinv(Eta, Wavei);
+ DVector V = geestr.v(Mu, Wavei);
+ DVector Mu_Eta = geestr.MeanMu_eta(Eta, Wavei);
+
+ DVector InvRootV = reciproot(V);
+ Di = SMult(InvRootV, SMult(Mu_Eta, Xi));
+ PRi = SMult(InvRootV, Yi - Mu);
+}
+
+void PRandD(DVector &Y, DMatrix &X, DVector &Offset,
+ Index1D &I, IVector &LinkWave,
+ GeeParam &par, GeeStr &geestr,
+ DVector &PRi, DMatrix &Di) {
+ DVector Yi = asVec(VecSubs(Y, I));
+ DMatrix Xi = asMat(MatRows(X, I));
+ DVector Offseti = asVec(VecSubs(Offset, I));
+ IVector Wavei = asVec(VecSubs(LinkWave, I));
+ DVector Eta = Xi * par.beta() + Offseti;
+ DVector Mu = geestr.MeanLinkinv(Eta, Wavei);
+ DVector V = geestr.v(Mu, Wavei);
+ DVector Mu_Eta = geestr.MeanMu_eta(Eta, Wavei);
+
+ DVector InvRootV = reciproot(V);
+ Di = SMult(InvRootV, SMult(Mu_Eta, Xi));
+ PRi = SMult(InvRootV, Yi - Mu);
+}
+
+void gee_prep(DVector &Yi, DMatrix &Xi, DVector &Offseti,
+ IVector &Wavei, GeeParam &par, GeeStr &geestr,
+ DVector &PRi, DMatrix &Di, DVector &Vi, DVector &V_Mui) {
+ DVector Eta = Xi * par.beta() + Offseti;
+ DVector Mu = geestr.MeanLinkinv(Eta, Wavei);
+ DVector V = geestr.v(Mu, Wavei);
+ DVector Mu_Eta = geestr.MeanMu_eta(Eta, Wavei);
+
+ DVector InvRootV = reciproot(V);
+ Di = SMult(InvRootV, SMult(Mu_Eta, Xi));
+ PRi = SMult(InvRootV, Yi - Mu);
+ Vi = geestr.v(Mu, Wavei);
+ V_Mui = geestr.v_mu(Mu, Wavei);
+}
+
+void gee_prep(DVector &Y, DMatrix &X, DVector &Offset,
+ Index1D &I, IVector &LinkWave,
+ GeeParam &par, GeeStr &geestr,
+ DVector &PRi, DMatrix &Di, DVector &Vi, DVector &V_Mui) {
+ DVector Yi = asVec(VecSubs(Y, I));
+ DMatrix Xi = asMat(MatRows(X, I));
+ DVector Offseti = asVec(VecSubs(Offset, I));
+ IVector Wavei = asVec(VecSubs(LinkWave, I));
+ DVector Eta = Xi * par.beta() + Offseti;
+ DVector Mu = geestr.MeanLinkinv(Eta, Wavei);
+ DVector V = geestr.v(Mu, Wavei);
+ DVector Mu_Eta = geestr.MeanMu_eta(Eta, Wavei);
+
+ DVector InvRootV = reciproot(V);
+ Di = SMult(InvRootV, SMult(Mu_Eta, Xi));
+ PRi = SMult(InvRootV, Yi - Mu);
+ Vi = geestr.v(Mu, Wavei);
+ V_Mui = geestr.v_mu(Mu, Wavei);
+}
+
+DMatrix getR(DMatrix &Zmati, DVector &corp,
+ GeeParam &par, GeeStr &geestr, Corr &cor) {
+ DVector alp = par.alpha();
+ int s = corp.dim(); // corp should determine meta par for R
+ if (s == 1) return ident(1);
+ else if (cor.corst() == INDEPENDENCE) //indenpendence
+ return cor.mat(alp, corp);
+ else {
+ DVector Eta = Zmati * alp;
+ DVector Rho = geestr.CorrLinkinv(Eta);
+ return cor.mat(Rho, corp);
+ }
+}
+
+DMatrix getR(DMatrix &Zmat, Index1D &I, Index1D &J, DVector &CorP,
+ GeeParam &par, GeeStr &geestr, Corr &cor) {
+ DVector alp = par.alpha();
+ DVector corp = asVec(VecSubs(CorP, I));
+ int s = corp.dim(); // corp should determine meta par for R
+ if (s == 1) return ident(1);
+ else if (cor.corst() == INDEPENDENCE) //indenpendence
+ return cor.mat(alp, corp);
+ else{
+ DMatrix Zmati = asMat(MatRows(Zmat, J));
+ DVector Eta = Zmati * alp;
+ DVector Rho = geestr.CorrLinkinv(Eta);
+ return cor.mat(Rho, corp);
+ }
+}
+
+int RandE(DMatrix &Zmati, DVector &corp,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ DMatrix &R, DMatrix &E) {
+ DVector alp = par.alpha();
+ //DVector corp = asVec(VecSubs(CorP, I));
+ int s = corp.dim();
+ if (s == 1) {
+ R = ident(1);
+ return 0;
+ }
+ else if (cor.corst() == INDEPENDENCE) { //no need for E
+ R = cor.mat(alp, corp);
+ return 0;
+ }
+ else if (cor.corst() == FIXED) {
+ DVector Eta = Zmati * alp;
+ DVector Rho = geestr.CorrLinkinv(Eta);
+ R = cor.mat(Rho, corp);
+ return 0;
+ }
+ else {
+ //DMatrix Zmati = asMat(MatRows(Zmat, J));
+ DVector Eta = Zmati * alp;
+ DVector Rho = geestr.CorrLinkinv(Eta);
+ R = cor.mat(Rho, corp);
+ DVector Rho_Alp = geestr.CorrMu_eta(Eta);
+ DMatrix Cor_Rho = cor.cor_rho(Rho, corp);
+ E = Cor_Rho * SMult(Rho_Alp, Zmati);
+ return 0;
+ }
+}
+
+int RandE(DMatrix &Zmat, Index1D &I, Index1D &J, DVector &CorP,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ DMatrix &R, DMatrix &E) {
+ DVector alp = par.alpha();
+ DVector corp = asVec(VecSubs(CorP, I));
+ int s = corp.dim();
+ if (s == 1) {
+ R = ident(1);
+ return 0;
+ }
+ else if (cor.corst() == INDEPENDENCE) { //no need for E
+ R = cor.mat(alp, corp);
+ return 0;
+ }
+ else if (cor.corst() == FIXED) {
+ DMatrix Zmati = asMat(MatRows(Zmat, J));
+ DVector Eta = Zmati * alp;
+ DVector Rho = geestr.CorrLinkinv(Eta);
+ R = cor.mat(Rho, corp);
+ return 0;
+ }
+ else {
+ DMatrix Zmati = asMat(MatRows(Zmat, J));
+ DVector Eta = Zmati * alp;
+ DVector Rho = geestr.CorrLinkinv(Eta);
+ R = cor.mat(Rho, corp);
+ DVector Rho_Alp = geestr.CorrMu_eta(Eta);
+ DMatrix Cor_Rho = cor.cor_rho(Rho, corp);
+ E = Cor_Rho * SMult(Rho_Alp, Zmati);
+ return 0;
+ }
+}
+
+void gm_prep(DVector &PRi, IVector &Wavei,
+ DVector &Doffseti, DMatrix &Zi, GeeParam &par, GeeStr &geestr,
+ DVector &Phii, DVector &Si, DMatrix &D2i) {
+ DVector Zeta = Zi * par.gamma() + Doffseti;
+ DVector Phi_Zeta = geestr.ScaleMu_eta(Zeta, Wavei);
+
+ Phii = geestr.ScaleLinkinv(Zeta, Wavei);
+ Si = square(PRi);
+ D2i = Phi_Zeta * Zi;
+}
+
+void gm_prep(DVector &PR, Index1D &I, IVector &LinkWave,
+ DVector &Doffset, DMatrix &Zsca, GeeParam &par, GeeStr &geestr,
+ DVector &Phii, DVector &Si, DMatrix &D2i) {
+ DMatrix Zi = asMat(MatRows(Zsca, I));
+ DVector Doffseti = asVec(VecSubs(Doffset, I));
+ IVector Wavei = asVec(VecSubs(LinkWave, I));
+ DVector Zeta = Zi * par.gamma() + Doffseti;
+ DVector Phi_Zeta = geestr.ScaleMu_eta(Zeta, Wavei);
+ DVector PRi = asVec(VecSubs(PR, I));
+
+ Phii = geestr.ScaleLinkinv(Zeta, Wavei);
+ Si = square(PRi);
+ D2i = Phi_Zeta * Zi;
+}
+
+void PhiandD2(IVector &Wavei,
+ DVector &Doffseti, DMatrix &Zi, GeeParam &par, GeeStr &geestr,
+ DVector &Phii, DMatrix &D2i) {
+ DVector Zeta = Zi * par.gamma() + Doffseti;
+ Phii = geestr.ScaleLinkinv(Zeta, Wavei);
+ if (geestr.ScaleFix() == 1) return;
+ DVector Phi_Zeta = geestr.ScaleMu_eta(Zeta, Wavei);
+ D2i = Phi_Zeta * Zi;
+}
+
+void PhiandD2(Index1D &I, IVector &LinkWave,
+ DVector &Doffset, DMatrix &Zsca, GeeParam &par, GeeStr &geestr,
+ DVector &Phii, DMatrix &D2i) {
+ DMatrix Zi = asMat(MatRows(Zsca, I));
+ DVector Doffseti = asVec(VecSubs(Doffset, I));
+ IVector Wavei = asVec(VecSubs(LinkWave, I));
+ DVector Zeta = Zi * par.gamma() + Doffseti;
+ Phii = geestr.ScaleLinkinv(Zeta, Wavei);
+ if (geestr.ScaleFix() == 1) return;
+ DVector Phi_Zeta = geestr.ScaleMu_eta(Zeta, Wavei);
+ D2i = Phi_Zeta * Zi;
+}
+
+DVector getPR(DVector &Y, DMatrix &X, DVector &Offset, IVector &LinkWave,
+ GeeParam &par, GeeStr &geestr) {
+ DVector Eta = X * par.beta() + Offset;
+ DVector Mu = geestr.MeanLinkinv(Eta, LinkWave);
+ DVector V = geestr.v(Mu, LinkWave);
+ DVector InvRootV = reciproot(V);
+ return SMult(InvRootV, Y - Mu);
+}
+
+DVector getPhi(DVector &Doffset, DMatrix &Zsca, IVector &LinkWave,
+ GeeParam &par, GeeStr &geestr) {
+ DVector Zeta = Zsca * par.gamma() + Doffset;
+ return geestr.ScaleLinkinv(Zeta, LinkWave);
+}
+
+
+void getDatI(DVector &Y, DVector &Offset, DVector &Doffset,
+ DVector &W, DVector &CorP,
+ DMatrix &X, DMatrix &Zsca, DMatrix &Zcor,
+ IVector &LinkWave,
+ //extract indicator
+ Index1D &I, Index1D &J, IVector Scuri,
+ Corr &cor,
+ //output
+ DVector &VYi, DVector &VOffseti, DVector &VDoffseti,
+ DVector &VWi, DVector &VCorPi,
+ DMatrix &VXi, DMatrix &VZscai, DMatrix &VZcori,
+ IVector &VLinkWavei) {
+ int s = Scuri.size();
+ //get dat i
+ DVector Yi = asVec(VecSubs(Y, I));
+ DVector Offseti = asVec(VecSubs(Offset, I));
+ DVector Wi = asVec(VecSubs(W, I));
+ DVector CorPi = asVec(VecSubs(CorP, I));
+ DMatrix Xi = asMat(MatRows(X, I));
+ DMatrix Zscai = asMat(MatRows(Zsca, I));
+ IVector LinkWavei = asVec(VecSubs(LinkWave, I));
+ DMatrix Zcori; DVector Doffseti;
+ if (cor.corst() > INDEPENDENCE && s > 1 ) {
+ Zcori = asMat(MatRows(Zcor, J));
+ }
+ Doffseti = asVec(VecSubs(Doffset, I));
+
+ //valid dat i
+ IVector VI = genVI(Scuri), VJ = genCrossVI(Scuri);
+ VYi = Valid(Yi, VI); VOffseti = Valid(Offseti, VI);
+ VWi = Valid(Wi, VI); VCorPi = Valid(CorPi, VI);
+ VXi = Valid(Xi, VI);
+ VZscai = Valid(Zscai, VI);
+ VLinkWavei = Valid(LinkWavei, VI);
+ if (cor.corst() > INDEPENDENCE && s > 1) {
+ if (cor.nparam() == 1) VZcori = Zcori;
+ else VZcori = Valid(Zcori, VJ);
+ //VDoffseti = Valid(Doffseti, VJ); //this is for log odds for ordinal
+ }
+ VDoffseti = Valid(Doffseti, VI);
+}
+
+void HnandGis(DVector &Y, DMatrix &X,
+ DVector &Offset, DVector &Doffset, DVector &W,
+ IVector &LinkWave, IVector &Clusz, IVector &ZcorSize,
+ DMatrix &Zsca, DMatrix &Zcor, DVector &CorP,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ IVector &Scur, IVector &level, //Scur is the valid data indicator
+ //output
+ Hess &Hn, Vector<Grad> &Gis) {
+ int N = Clusz.size();
+ Hess H(par);
+ Vector<Hess> His(N); His = H;
+ HisandGis(Y, X, Offset, Doffset, W, LinkWave, Clusz, ZcorSize,
+ Zsca, Zcor, CorP, par, geestr, cor, Scur, level,
+ His, Gis);
+ for (int i = 1; i <= N; i++) H.inc(His(i));
+ Hn = (1.0/(double) N) * H;
+}
+
+void HisandGis(DVector &Y, DMatrix &X,
+ DVector &Offset, DVector &Doffset, DVector &W,
+ IVector &LinkWave, IVector &Clusz, IVector &ZcorSize,
+ DMatrix &Zsca, DMatrix &Zcor, DVector &CorP,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ IVector &Scur, IVector &level,
+ //output
+ Vector<Hess> &His, Vector<Grad> &Gis) {
+ Index1D I(0,0), J(0,0);
+ int N = Clusz.size();
+ int pb = par.p(), pg = par.r(), pa = par.q();
+ DVector V0(pb);
+ Hess H(par), Hi(par); Grad Gi(par);
+ //cout << "N = " << N;
+ for (int i = 1; i <= N; i++) {
+ int s1 = Clusz(i), s2 = ZcorSize(i);
+ I = Index1D(1, s1) + I.ubound();
+ if (s2 > 0) J = Index1D(1, s2) + J.ubound();
+
+ IVector Scuri = asVec(VecSubs(Scur, I));
+ if (sum(Scuri) == 0) continue;
+ //get and valid data i
+ DVector Yi, Offseti, Doffseti, Wi, CorPi;
+ DMatrix Xi, Zscai, Zcori;
+ IVector LinkWavei;
+
+ getDatI(Y, Offset, Doffset, W, CorP, X, Zsca, Zcor, LinkWave,
+ I, J, Scuri, cor,
+ Yi, Offseti, Doffseti, Wi, CorPi, Xi, Zscai, Zcori, LinkWavei);
+
+ DVector PRi(s1), Vi(s1), V_Mui(s1); DMatrix Di(s1,pb);
+ gee_prep(Yi, Xi, Offseti, LinkWavei, par, geestr, PRi, Di, Vi, V_Mui);
+ DVector Phii(s1); DMatrix D2i(s1, pg);
+ PhiandD2(LinkWavei, Doffseti, Zscai, par, geestr, Phii, D2i);
+ DMatrix R(s1, s1), E(s2, pa);
+ RandE(Zcori, CorPi, par, geestr, cor, R, E);
+
+ HiandGi(PRi, Phii, Di, R, Vi, V_Mui, D2i, E, Wi, level, Hi, Gi);
+ His(i) = Hi; Gis(i) = Gi;
+ }
+}
+
+IVector genVI(IVector &Si, int c) {
+ int s = Si.size(), k = 1;
+ IVector ans(s * c); ans = 0;
+ for (int i = 1; i <= s; i++) {
+ if (Si(i) == 1) {
+ for (int j = 1; j <= c; j++) {
+ ans(k) = 1;
+ k++;
+ }
+ }
+ }
+ return ans;
+}
+
+IVector genCrossVI(IVector &Si, int c) {
+ int s = Si.size();
+ IVector ans(s * (s - 1) * c * c / 2); ans = 0;
+ IVector vv(c * c); vv = 1;
+ Index1D I(0,0);
+ for (int i = 1; i <= s - 1; i++) {
+ for (int j = i + 1; j <= s; j++) {
+ I = Index1D(1, c * c) + I.ubound();
+ if (Si(i) == 1 && Si(j) == 1)
+ VecSubs(ans, I) = vv;
+ }
+ }
+ return ans;
+}
diff --git a/src/inter.cc b/src/inter.cc
new file mode 100755
index 0000000..2dc7bcf
--- /dev/null
+++ b/src/inter.cc
@@ -0,0 +1,178 @@
+using namespace std;
+
+#include "tntsupp.h"
+#include "geese.h"
+
+extern "C"{
+#include <R.h>
+#include <Rmath.h>
+#include <Rdefines.h>
+}
+
+#include "famstr.h"
+#include "param.h"
+#include "inter.h"
+
+
+DMatrix asDMatrix(SEXP a) {
+ double *x;
+ x = NUMERIC_POINTER(AS_NUMERIC(a));
+ int *dims = INTEGER_POINTER(AS_INTEGER(GET_DIM(a)));
+ DMatrix ans(dims[0], dims[1], x);
+ return ans;
+}
+
+DVector asDVector(SEXP a) {
+ double *x;
+ x = NUMERIC_POINTER(AS_NUMERIC(a));
+ int len = GET_LENGTH(a);
+ DVector ans(len, x);
+ return ans;
+}
+
+IVector asIVector(SEXP a) {
+ int *x;
+ x = INTEGER_POINTER(AS_INTEGER(a));
+ int len = GET_LENGTH(a);
+ IVector ans(len, x);
+ return ans;
+}
+
+Vector<DVector> asVDVector(SEXP a) {//a is a matrix
+ double *x;
+ x = NUMERIC_POINTER(AS_NUMERIC(a));
+ int *dims = INTEGER_POINTER(AS_INTEGER(GET_DIM(a)));
+ Vector<DVector> ans(dims[1]);
+ for (int i = 1; i <= ans.size(); i++) {
+ DVector tmp(dims[0], x);
+ ans(i) = tmp;
+ x += dims[0];
+ }
+ return ans;
+}
+
+SEXP asSEXP(const DMatrix &a) {
+ int size = a.num_cols() * a.num_rows();
+
+ SEXP val;
+ PROTECT(val = NEW_NUMERIC(size));
+ double *p = NUMERIC_POINTER(val);
+ const double *q = a.begin();
+ for (int i = 0; i < size; i++) p[i] = q[i];
+ // SET_CLASS(val, ScalarString(mkChar("matrix")));
+
+ SEXP dim;
+ PROTECT(dim = NEW_INTEGER(2));
+ INTEGER(dim)[0] = a.num_rows(); INTEGER(dim)[1] = a.num_cols();
+ SET_DIM(val, dim);
+
+ UNPROTECT(2);
+ return val;
+}
+
+SEXP asSEXP(const DVector &a) {
+ int size = a.size();
+ SEXP val;
+ PROTECT(val = NEW_NUMERIC(size));
+ double *p = NUMERIC_POINTER(val);
+ const double *q = a.begin();
+ for (int i = 0; i < size; i++) p[i] = q[i];
+ // SET_CLASS(val, ScalarString(mkChar("vector")));
+
+ SEXP len;
+ PROTECT(len = NEW_INTEGER(1));
+ INTEGER(len)[0] = size;
+ SET_LENGTH(val, size);
+ UNPROTECT(2);
+ return val;
+}
+
+SEXP asSEXP(const IVector &a) {
+ int size = a.size();
+ SEXP val;
+ PROTECT(val = NEW_INTEGER(size));
+ int *p = INTEGER_POINTER(val);
+ const int *q = a.begin();
+ for (int i = 0; i < size; i++) p[i] = q[i];
+ // SET_CLASS(val, ScalarString(mkChar("vector")));
+
+ SEXP len;
+ PROTECT(len = NEW_INTEGER(1));
+ INTEGER(len)[0] = size;
+ SET_LENGTH(val, size);
+ UNPROTECT(2);
+ return val;
+}
+
+
+Control asControl(SEXP con) {
+ //con is a list of trace, jack, j1s, fij, maxiter, epsilon
+ int trace, jack, j1s, fij, maxiter;
+ double tol;
+ trace = INTEGER(VECTOR_ELT(con, 0))[0];
+ jack = INTEGER(VECTOR_ELT(con, 1))[0];
+ j1s = INTEGER(VECTOR_ELT(con, 2))[0];
+ fij = INTEGER(VECTOR_ELT(con, 3))[0];
+ maxiter = INTEGER(VECTOR_ELT(con, 4))[0];
+ tol = REAL(VECTOR_ELT(con, 5))[0];
+ Control Con(trace, jack, j1s, fij, maxiter, tol);
+ return Con;
+}
+
+GeeParam asGeeParam(SEXP par) {
+ //par is a list of beta, alpha, gamma;
+ DVector Beta = asDVector(VECTOR_ELT(par, 0));
+ DVector Alpha = asDVector(VECTOR_ELT(par, 1));
+ DVector Gamma = asDVector(VECTOR_ELT(par, 2));
+ GeeParam Par(Beta, Alpha, Gamma);
+ return Par;
+}
+
+GeeStr asGeeStr(SEXP geestr) {
+ //geestr is a list of maxwave, meanlink, v, scalelink, corrlink, scale.fix;
+ int maxwave = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 0)))[0];
+ IVector MeanLink = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 1)));
+ IVector V = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 2)));
+ IVector ScaleLink = asIVector(AS_INTEGER(VECTOR_ELT(geestr, 3)));
+ int corrlink = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 4)))[0];
+ int scalefix = INTEGER(AS_INTEGER(VECTOR_ELT(geestr, 5)))[0];
+ GeeStr G(maxwave, MeanLink, V, ScaleLink, corrlink, scalefix);
+ return G;
+}
+
+Corr asCorr(SEXP cor) {
+ //cor is a list of corst, maxwave
+ int corstr, maxwave;
+ corstr = INTEGER(VECTOR_ELT(cor, 0))[0];
+ maxwave = INTEGER(VECTOR_ELT(cor, 1))[0];
+ Corr Cor(corstr, maxwave);
+ return Cor;
+}
+
+SEXP asSEXP(GeeParam &Par) {
+ SEXP ans;
+ PROTECT(ans = NEW_LIST(19));
+ SET_VECTOR_ELT(ans, 0, asSEXP(Par.beta()));
+ SET_VECTOR_ELT(ans, 1, asSEXP(Par.alpha()));
+ SET_VECTOR_ELT(ans, 2, asSEXP(Par.gamma()));
+ SET_VECTOR_ELT(ans, 3, asSEXP(Par.vbeta()));
+ SET_VECTOR_ELT(ans, 4, asSEXP(Par.valpha()));
+ SET_VECTOR_ELT(ans, 5, asSEXP(Par.vgamma()));
+ SET_VECTOR_ELT(ans, 6, asSEXP(Par.vbeta_naiv()));
+ SET_VECTOR_ELT(ans, 7, asSEXP(Par.valpha_naiv()));
+ SET_VECTOR_ELT(ans, 8, asSEXP(Par.valpha_stab()));
+ SET_VECTOR_ELT(ans, 9, asSEXP(Par.vbeta_ajs()));
+ SET_VECTOR_ELT(ans, 10, asSEXP(Par.valpha_ajs()));
+ SET_VECTOR_ELT(ans, 11, asSEXP(Par.vgamma_ajs()));
+ SET_VECTOR_ELT(ans, 12, asSEXP(Par.vbeta_j1s()));
+ SET_VECTOR_ELT(ans, 13, asSEXP(Par.valpha_j1s()));
+ SET_VECTOR_ELT(ans, 14, asSEXP(Par.vgamma_j1s()));
+ SET_VECTOR_ELT(ans, 15, asSEXP(Par.vbeta_fij()));
+ SET_VECTOR_ELT(ans, 16, asSEXP(Par.valpha_fij()));
+ SET_VECTOR_ELT(ans, 17, asSEXP(Par.vgamma_fij()));
+
+ IVector Err(1); Err(1) = Par.err();
+ SET_VECTOR_ELT(ans, 18, asSEXP(Err));
+ UNPROTECT(1);
+ return ans;
+}
diff --git a/src/ordgee.cc b/src/ordgee.cc
new file mode 100755
index 0000000..24a49e5
--- /dev/null
+++ b/src/ordgee.cc
@@ -0,0 +1,676 @@
+// using namespace std;
+
+// #include "tnt/region1d.h"
+// #include "tntsupp.h"
+// #include "geese.h"
+
+// extern "C"{
+// #include <R.h>
+// #include <Rmath.h>
+// #include <Rdefines.h>
+// }
+
+// #include "famstr.h"
+// #include "param.h"
+// #include "inter.h"
+// #include "utils.h"
+// #include "geesubs.h"
+#include "ordgee.h"
+
+double odds2p11(double psi, double mu1, double mu2) {
+ if (fabs(psi - 1.0) < .001) return mu1 * mu2;
+ else {
+ double exp1 = 1 + (mu1 + mu2) * ( psi - 1);
+ double s = exp1 * exp1 + 4 * psi * (1 - psi) * mu1 * mu2;
+ s = sqrt(s);
+ return .5 / (psi - 1) * (exp1 - s);
+ }
+}
+
+DMatrix odds2p11(DVector &Psi, DVector &Mu1, DVector &Mu2) {
+ //Psi is c^2 by 1, contains odds ratio in the sequence: 1-1, 1-2, 2-1, 2-2
+ //which can be viewed as the result of hvec of PSI matrix
+ int c = Mu1.size(), k = 1;
+ DMatrix ans(c, c);
+ for (int i = 1; i <= c; i++)
+ for (int j = 1; j <= c; j++)
+ ans(i, j) = odds2p11(Psi(k++), Mu1(i), Mu2(j));
+ return ans;
+}
+
+/* get derivative from R function
+f <- deriv( ~ .5 / (psi - 1) * (1 + (mu1 + mu2) * ( psi - 1) - (((1 + (mu1 + mu2) * ( psi - 1))^ 2 + 4 * psi * (1 - psi) * mu1 * mu2))^.5), c("psi", "mu1", "mu2"), function(psi, mu1, mu2){})
+*/
+
+double p11_odds(double psi, double mu1, double mu2) {
+ if (fabs(psi - 1.0) < .001) return mu1*mu2*( - (mu1 + mu2) + mu1*mu2 + 1);
+ else {
+ double expr1 = psi - 1.0;
+ double expr2 = .5 / expr1;
+ double expr3 = mu1 + mu2;
+ double expr5 = 1 + expr3 * expr1;
+ double expr7 = 4 * psi;
+ double expr8 = 1 - psi;
+ double expr9 = expr7 * expr8;
+ double expr10 = expr9 * mu1;
+ double expr12 = pow(expr5, 2.0) + expr10 * mu2;
+ double expr14 = expr5 - pow(expr12, 0.5);
+ double expr23 = pow(expr12, -0.5);
+ //double expr33 = 2 * (expr1 * expr5);
+ //.value <- .expr2 * .expr14
+ double ans = expr2 * (expr3 - 0.5 * ((2 * (expr3 * expr5) + (4 * expr8 - expr7) * mu1 * mu2) * expr23)) - 0.5/pow(expr1, 2.0) * expr14;
+ return ans;
+ }
+}
+
+DVector p11_mu(double psi, double mu1, double mu2) {
+ DVector ans(2);
+ if (fabs(psi - 1.0) < .001) {
+ ans(1) = mu2; ans(2) = mu1;
+ return ans;
+ }
+ double expr1 = psi - 1.0;
+ double expr2 = .5 / expr1;
+ double expr3 = mu1 + mu2;
+ double expr5 = 1 + expr3 * expr1;
+ double expr7 = 4 * psi;
+ double expr8 = 1 - psi;
+ double expr9 = expr7 * expr8;
+ double expr10 = expr9 * mu1;
+ double expr12 = pow(expr5, 2.0) + expr10 * mu2;
+ // double expr14 = expr5 - pow(expr12, 0.5);
+ double expr23 = pow(expr12, -0.5);
+ double expr33 = 2 * (expr1 * expr5);
+ // .grad[, "mu1"] <- .expr2 * (.expr1 - 0.5 * ((.expr33 + .expr9 * mu2) * .expr23))
+ ans(1) = expr2 * (expr1 - 0.5 * ((expr33 + expr9 * mu2) * expr23));
+ // .grad[, "mu2"] <- .expr2 * (.expr1 - 0.5 * ((.expr33 + .expr10) * .expr23))
+ ans(2) = expr2 * (expr1 - 0.5 * ((expr33 + expr10) * expr23));
+ return ans;
+}
+
+DVector p11_odds(DVector &Psi, DVector &Mu1, DVector &Mu2) {
+ //Mu1 and Mu2 are c x 1, Psi is c^2 x 1
+ int c = Mu1.size(), k = 1;
+ DVector ans(c * c);
+ for (int i = 1; i <= c; i++)
+ for (int j = 1; j <= c; j++) {
+ ans(k) = p11_odds(Psi(k), Mu1(i), Mu2(j));
+ //need more attention to the ordering of Mu1 and Mu2, row-major or col-major; this is row major!!!
+ k++;
+ }
+ return ans;
+}
+
+/*
+DMatrix Vijj(DVector &Mu) {
+ int c = Mu.size();
+ DMatrix ans(c,c);
+ for (int i = 1; i <= c; i++)
+ for (int j = 1; j <= c; j++)
+ ans(i,j) = Mu(fmax(i, j)) - Mu(i) * Mu(j);
+ return ans;
+}
+*/
+
+DMatrix Vijj(DVector &Mu, bool rev) {
+ //rev = false: usual cumulated ordering;
+ //rev = true: Heagerty and Zeger (1996)
+ int c = Mu.size(), ij;
+ DMatrix ans(c,c);
+ for (int i = 1; i <= c; i++)
+ for (int j = 1; j <= c; j++) {
+ if (rev) ij = fmax(i, j);
+ else ij = fmin(i, j);
+ ans(i,j) = Mu(ij) - Mu(i) * Mu(j);
+ }
+ return ans;
+}
+
+DMatrix Vijk(DVector &Mu1, DVector &Mu2, DVector &Psi) {
+ //Psi is a c^2 by 1 vector;
+ int c = Mu1.size();
+ DMatrix ans(c,c);
+ int k = 1;
+ for (int i = 1; i <= c; i++) {
+ for (int j = 1; j <= c; j++) {
+ double psi = Psi(k++);
+ double p11 = odds2p11(psi, Mu1(i), Mu2(j));
+ ans(i, j) = p11 - Mu1(i) * Mu2(j);
+ }
+ }
+ return ans;
+}
+
+DMatrix getU3_Beta(DVector &Mu1, DVector &Mu2, DVector &Psi,
+ DMatrix &D1, DMatrix &D2,
+ DVector &PR1, DVector &PR2) {
+ int c = Mu1.size(), p = D1.num_cols();
+ DMatrix ans(c * c, p);
+ int k = 1;
+ for (int i = 1; i <= c; i++) {
+ DMatrix D1i = asMat(MatRow(D1,i));
+ for (int j = 1; j <= c; j++) {
+ DMatrix D2j = asMat(MatRow(D2,j));
+ double psi = Psi(k);
+ DVector P11_Mu = p11_mu(psi, Mu1(i), Mu2(j));
+ P11_Mu(1) = P11_Mu(1) - Mu2(j); P11_Mu(2) = P11_Mu(2) - Mu1(i);
+ //MatRow(ans, k) = P11_Mu(1) * D1i + P11_Mu(2) * D2j;
+ MatRow(ans, k) = (- PR2(j) - P11_Mu(1)) * D1i +
+ (-PR1(i) - P11_Mu(2)) * D2j;
+ k++;
+ }
+ }
+ return ans;
+}
+
+DMatrix ord2V1(DVector &Mu, DVector &Psi, int clusz, bool rev) {
+ //Mu is (ni*c) x 1, Psi is (choose(ni,2)*c^2) * 1
+ //This function should be named as ord2V1 instead of ord_V1, since it is forming V1 rather than taking derivatives
+ int c = Mu.size() / clusz;
+ DMatrix ans(Mu.size(), Mu.size());
+ Index1D I(0,0), K(0,0);
+ for (int i = 1; i <= clusz; i++) {
+ I = Index1D(1, c) + I.ubound();
+ Index1D J = I;
+ DVector Mui = asVec(VecSubs(Mu, I));
+ ans(I, I) = Vijj(Mui, rev);
+ for (int j = i + 1; j <= clusz; j++) {
+ J = Index1D(1, c) + J.ubound();
+ DVector Muj = asVec(VecSubs(Mu, J));
+ K = Index1D(1, c*c) + K.ubound();
+ DVector Psik = asVec(VecSubs(Psi, K));
+ ans(I, J) = Vijk(Mui, Muj, Psik);
+ ans(J, I) = ans(I, J);
+ }
+ }
+ return ans;
+}
+
+DMatrix Mu2V1(DVector &Mu, int clusz, bool rev) {
+ int c = Mu.dim() / clusz;
+ DMatrix ans(Mu.dim(), Mu.dim()); ans = .0;
+ Index1D I(0,0);
+ for (int i = 1; i <= clusz; i++) {
+ I = Index1D(1, c) + I.ubound();
+ DVector Mui = asVec(VecSubs(Mu, I));
+ ans(I, I) = Vijj(Mui, rev);
+ }
+ return ans;
+}
+
+void ord_prep_beta(DVector &Yi, DMatrix &Xi, DVector &Offseti,
+ DMatrix &Zi, DVector &Ooffseti,
+ int clusz, int c, bool rev,
+ IVector &LinkWavei,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ //output
+ DMatrix &Di, DVector &PRi, DMatrix &Vi) {
+ DVector Etai = Xi * par.beta() + Offseti;
+ DVector Mui = geestr.MeanLinkinv(Etai, LinkWavei);
+ DVector Mu_Etai = geestr.MeanMu_eta(Etai, LinkWavei);
+ PRi = Yi - Mui;
+ Di = SMult(Mu_Etai, Xi);
+
+ if (clusz == 1) Vi = Vijj(Mui, rev);
+ else if (cor.nparam() == 0) Vi = Mu2V1(Mui, clusz, rev);
+ else { //cluster size greater than 1;
+ DVector Psii = geestr.CorrLinkinv(Zi * par.alpha() + Ooffseti);
+ Vi = ord2V1(Mui, Psii, clusz, rev);
+ }
+}
+
+void ord_prep_beta(DVector &Y, DMatrix &X, DVector &Offset,
+ DMatrix &Z, DVector &Ooffset,
+ Index1D &I, Index1D &J,
+ int clusz, int c, bool rev,
+ IVector &LinkWave,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ //output
+ DMatrix &Di, DVector &PRi, DMatrix &Vi) {
+ DVector Yi = asVec(VecSubs(Y, I));
+ DMatrix Xi = asMat(MatRows(X, I));
+ DVector Offseti = asVec(VecSubs(Offset, I));
+ IVector LinkWavei = asVec(VecSubs(LinkWave, I));
+ //cout << "Xi = " << Xi << "par.beta() = " << par.beta();
+ DVector Etai = Xi * par.beta() + Offseti;
+ DVector Mui = geestr.MeanLinkinv(Etai, LinkWavei);
+ DVector Mu_Etai = geestr.MeanMu_eta(Etai, LinkWavei);
+ PRi = Yi - Mui;
+ Di = SMult(Mu_Etai, Xi);
+ //if (I.lbound() == 1) cout << "Yi = " << Yi << "Xi = " << Xi << "Etai = " << Etai << "Mui = " << Mui;
+ if (clusz == 1) Vi = Vijj(Mui, rev);
+ else if (cor.nparam() == 0) Vi = Mu2V1(Mui, clusz, rev);
+ else { //cluster size greater than 1;
+ DMatrix Zi = asMat(MatRows(Z, J));
+ DVector Ooffseti = asVec(VecSubs(Ooffset, J));
+ DVector Psii = geestr.CorrLinkinv(Zi * par.alpha() + Ooffseti);
+ Vi = ord2V1(Mui, Psii, clusz, rev);
+ }
+}
+
+double update_beta(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset,
+ DVector &W, IVector &LinkWave, //DVector &CorP,
+ DMatrix &Z, IVector &Clusz, int c, bool rev,
+ //IVector &ZcorSize, IVector &Jack,
+ GeeParam &par, GeeStr &geestr, Corr &cor) {
+ double del = 0;
+ int p = par.p(), n = Clusz.size();
+ DMatrix H(p,p); DVector G(p);
+ Index1D I(0,0), J(0,0);
+
+ for (int i = 1; i <= n; i++) {
+ int s1 = Clusz(i);
+ int s2 = s1 * (s1 - 1) / 2;
+ I = Index1D(1, s1 * c) + I.ubound();
+ if (s2 > 0) J = Index1D(1, s2 * c * c) + J.ubound();
+
+ // cout << "i = " << i << " J.lbound = " << J.lbound() << " J.ubound = " << J.ubound() << endl;
+ DVector PRi(s1 * c); DMatrix Di(s1 * c, p), Vi(s1 * c, s1 * c);
+ DVector Yi = asVec(VecSubs(Y, I));
+ DMatrix Xi = asMat(MatRows(X, I));
+ DVector Offseti = asVec(VecSubs(Offset, I));
+ IVector LinkWavei = asVec(VecSubs(LinkWave, I));
+ DMatrix Zi; DVector Ooffseti;
+ if (cor.nparam() == 0 || s2 == 0) {
+ Zi = DMatrix(1,1); Ooffseti = DVector(1);
+ } else {
+ Zi = asMat(MatRows(Z, J));
+ Ooffseti = asVec(VecSubs(Ooffset, J));
+ }
+
+ ord_prep_beta(Yi, Xi, Offseti, Zi, Ooffseti, s1, c, rev,
+ LinkWavei, par, geestr, cor, Di, PRi, Vi);
+ //if (i == 1) cout << "PRi = " << PRi << "Di = " << Di << "Vi = " << Vi;
+ DVector rootWi = sqrt(asVec(VecSubs(W, I)));
+ Di = SMult(rootWi, Di); PRi = SMult(rootWi, PRi);
+ H = H + AtBiC(Di, Vi, Di);
+ G = G + AtBiC(Di, Vi, PRi);
+ }
+ DVector Del = solve(H, G);
+ par.set_beta(par.beta() + Del);
+ del = fmax(fabs(Del));
+ return del;
+}
+
+DVector kronecker(const DVector &v1, const DVector &v2) {
+ int n1 = v1.size(), n2 = v2.size();
+ DVector ans(n1 * n2);
+ Index1D I(0,0);
+ for (int i = 1; i <= n1; i++) {
+ I = Index1D(1, n2) + I.ubound();
+ VecSubs(ans, I) = v1(i) * v2;
+ }
+ return ans;
+}
+
+DVector vec(const DMatrix &m) {
+ int r = m.num_rows(), c = m.num_cols();
+ DVector ans(r * c, m.begin());
+ return ans;
+}
+
+DVector hvec(const DMatrix &m) {
+ int r = m.num_rows(), c = m.num_cols(), k = 1;
+ DVector ans(r * c);
+ for (int i = 1; i <= r; i++)
+ for (int j = 1; j <= c; j++)
+ ans(k++) = m(i, j);
+ return ans;
+}
+
+DMatrix ESSTijk(DVector &Mu1, DVector &Mu2, DMatrix &P11,
+ int c1, int c3, bool rev) {
+ //P11 is c x c matrix
+ int c = Mu1.size(), c13, c24;
+ if (rev) c13 = fmax(c1, c3);
+ else c13 = fmin(c1, c3);
+ DMatrix ans(c, c);
+ for (int c2 = 1; c2 <= c; c2++) {
+ for (int c4 = c2; c4 <= c; c4++) {
+ if (rev) c24 = fmax(c2, c4);
+ else c24 = fmin(c2, c4);
+ ans(c2, c4) =
+ P11(c13, c24) - P11(c13, c2) * Mu2(c4)
+ - P11(c13, c4) * Mu2(c2) + Mu1(c13) * Mu2(c2) * Mu2(c4)
+ - P11(c1, c24) * Mu1(c3) + P11(c1, c2) * Mu1(c3) * Mu2(c4)
+ + P11(c1, c4) * Mu1(c3) * Mu2(c2) - 3 * Mu1(c1) * Mu1(c3) * Mu2(c2) * Mu2(c4)
+ - P11(c3, c24) * Mu1(c1) + P11(c3, c2) * Mu1(c1) * Mu2(c4)
+ + P11(c3, c4) * Mu1(c1) * Mu2(c2)
+ + Mu1(c1) * Mu1(c3) * Mu2(c24);
+ if (c4 > c2) ans(c4, c2) = ans(c2, c4);
+ }
+ }
+ return ans;
+}
+
+DMatrix ESST(DVector &Mu1, DVector &Mu2, DMatrix &P11, bool rev) {
+ int c = Mu1.size();
+ DMatrix ans(c*c, c*c);
+ Index1D I(0,0), J(0,0);
+ for (int c1 = 1; c1 <= c; c1++) {
+ J = I;
+ I = Index1D(1, c) + I.ubound();
+ for (int c3 = c1; c3 <= c; c3++) {
+ J = Index1D(1, c) + J.ubound();
+ ans(I, J) = ESSTijk(Mu1, Mu2, P11, c1, c3, rev);
+ if (c3 > c1) ans(J, I) = ans(I, J);
+ }
+ }
+ return ans;
+}
+
+void ord_prep_alpha(DVector &PR1, DVector &PR2, //DMatrix &V,
+ DVector &Mu1, DVector &Mu2,
+ //c^2 x 1 c x 1 c x 1
+ DMatrix &Z, DVector &Ooffset,
+ bool rev, GeeParam &par, GeeStr &geestr,
+ //output
+ DVector &U2, DMatrix &V2, DMatrix &D2) {
+ DVector Zeta = Z * par.alpha() + Ooffset; //Z is C^2 x q;
+ DVector Psi = geestr.CorrLinkinv(Zeta);
+
+ //cout << "PR1 = " << PR1 << "PR2 = " << PR2;
+ DVector S = kronecker(PR1, PR2);
+ //cout << "S = " << S;
+ DMatrix V = Vijk(Mu1, Mu2, Psi);
+ // cout << "V = " << V;
+ DVector Sigma = hvec(V);
+ U2 = S - Sigma;
+
+ DVector P11_Odds = p11_odds(Psi, Mu1, Mu2);
+ DVector Odds_Zeta = geestr.CorrMu_eta(Zeta);
+ D2 = SMult(SMult(P11_Odds, Odds_Zeta), Z);
+ //D2 = d V / d alpha = d(P11 - mu1 * mu2) / d alpha = d P11 / d alpha
+
+ DMatrix P11 = odds2p11(Psi, Mu1, Mu2);
+ V2 = ESST(Mu1, Mu2, P11, rev) - outerprod(Sigma);
+}
+
+double update_alpha(DVector &PR, DVector &Mu, DVector &W,
+ DMatrix &Z, DVector &Ooffset,
+ IVector &Clusz, int c, bool rev,
+ GeeParam &par, GeeStr &geestr, Corr &cor) {
+ double del = 0;
+ int q = par.q(), n = Clusz.size();
+ if (cor.nparam() == 0) return del;
+ DMatrix H(q,q); DVector G(q);
+ Index1D I(0,0), J(0,0);
+ for (int i = 1; i <= n; i++) {
+ int s1 = Clusz(i);
+ int s2 = s1 * (s1 - 1) / 2;
+ I = Index1D(1, s1 * c) + I.ubound();
+ if (s2 > 0) J = Index1D(1, s2 * c * c) + J.ubound();
+ if (s1 == 1) continue;
+
+ DVector PRi = asVec(VecSubs(PR, I));
+ DVector Mui = asVec(VecSubs(Mu, I));
+ DMatrix Zi = asMat(MatRows(Z, J));
+ DVector Ooffseti = asVec(VecSubs(Ooffset, J));
+ Index1D K(0,0);
+ for (int j = 1; j <= s1 - 1; j++) {
+ Index1D I1((j - 1) * c + 1, j * c);
+ DVector PR1 = asVec(VecSubs(PRi, I1));
+ DVector Mu1 = asVec(VecSubs(Mui, I1));
+ for (int k = j + 1; k <= s1; k++) {
+ Index1D I2((k - 1) * c + 1, k * c);
+ DVector PR2 = asVec(VecSubs(PRi, I2));
+ DVector Mu2 = asVec(VecSubs(Mui, I2));
+
+ K = Index1D(1,c*c) + K.ubound();
+ DVector Ooffsetijk = asVec(VecSubs(Ooffseti, K));
+ DMatrix Zijk = asMat(MatRows(Zi, K));
+ DVector U2(c*c, 1); DMatrix V2(c*c, c*c), D2(c*c, q);
+ //cout << "i = " << i << " j = " << j << " k = " << k;
+ ord_prep_alpha(PR1, PR2, Mu1, Mu2, Zijk, Ooffsetijk, rev,
+ par, geestr, U2, V2, D2);
+
+ //if (i == 1) cout << "U2 = " << U2 << "D2 = " << D2 << "V2 = "<< V2;
+ H = H + AtBiC(D2, V2, D2);
+ //cout << " AtBiC(D2, V2, D2) = " << AtBiC(D2, V2, D2);
+ //if (i == 37) cout << "V2 = "<< V2;
+ G = G + AtBiC(D2, V2, U2);
+ }
+ }
+ }
+ //cout << "H = " << H;
+ DVector Del = solve(H, G);
+ par.set_alpha(par.alpha() + Del);
+ del = fmax(fabs(Del));
+ return del;
+}
+
+/* the following estimation procedure assumed that each cluster has size
+at least 1. Nov. 6, 2002.
+*/
+
+void ordgee_est(DVector &Y, DMatrix &X,
+ DVector &Offset, DVector &Ooffset, DVector &W,
+ IVector &LinkWave,
+ DMatrix &Z, IVector &Clusz, int c, bool rev,
+ GeeStr &geestr, Corr &cor, GeeParam &par,
+ Control &con) {
+ DVector Del(3); Del = 0.0;
+
+ int N = Y.size(); // N = sum(n_i) * c;
+ DVector PR(N), Mu(N);
+
+ int iter; double del;
+ for (iter = 0; iter < con.maxiter(); iter++) {
+ if (con.trace() == 1) {
+ //cerr << "iter " << iter << endl;
+ //cerr << "beta = " << par.beta() << "gamma = " << par.gamma() << "alpha = " << par.alpha();
+ Rprintf("iter = %d\n", iter);
+ Rprintf("beta = "); VecPrint(par.beta());
+ Rprintf("gamma = "); VecPrint(par.gamma());
+ Rprintf("alpha = "); VecPrint(par.alpha());
+ }
+ //updating beta;
+ Del(1) = update_beta(Y, X, Offset, Ooffset, W, LinkWave,
+ Z, Clusz, c, rev, par, geestr, cor);
+
+ //no updating gamma;
+
+ //updating alpha;
+ Mu = geestr.MeanLinkinv(X * par.beta() + Offset, LinkWave);
+ PR = Y - Mu;
+
+ Del(3) = update_alpha(PR, Mu, W, Z, Ooffset, Clusz, c, rev, par, geestr, cor);
+
+ del = fmax(Del);
+ if (del <= con.tol()) break;
+ }
+ if (iter == con.maxiter()) par.set_err(1);
+}
+
+void HiandGi(DVector &Yi, DMatrix &Xi, DVector &Offseti, DVector &Ooffseti,
+ IVector &LinkWavei,
+ DMatrix &Zi, int s1, int c, bool rev,
+ //Index1D &I, Index1D &J,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ //output
+ Hess &Hi, Grad &Gi) {
+ //need D1, V1, U1, D2, V2, U2, Sig_Beta for H and G
+ int p = par.p(), q = par.q();
+ DVector PRi(s1 * c);
+ DMatrix D1i(s1 * c, p), V1i(s1 * c, s1 * c);
+ ord_prep_beta(Yi, Xi, Offseti, Zi, Ooffseti, s1, c, rev,
+ LinkWavei, par, geestr, cor, D1i, PRi, V1i);
+ Hi.set_A(AtBiC(D1i, V1i, D1i));
+ Gi.set_U1(AtBiC(D1i, V1i, PRi));
+
+ if (s1 == 1) return;
+ if (cor.nparam() == 0) return;
+
+ DVector Mui = Yi - PRi;
+ Index1D K(0,0);
+ for (int j = 1; j <= s1 - 1; j++) {
+ Index1D I1((j - 1) * c + 1, j * c);
+ DVector PR1 = asVec(VecSubs(PRi, I1));
+ DVector Mu1 = asVec(VecSubs(Mui, I1));
+ DMatrix D1j = asMat(MatRows(D1i, I1));
+ for (int k = j + 1; k <= s1; k++) {
+ Index1D I2((k - 1) * c + 1, k * c);
+ DVector PR2 = asVec(VecSubs(PRi, I2));
+ DVector Mu2 = asVec(VecSubs(Mui, I2));
+ DMatrix D1k = asMat(MatRows(D1i, I2));
+
+ K = Index1D(1,c*c) + K.ubound();
+ DVector Ooffsetijk = asVec(VecSubs(Ooffseti, K));
+ DMatrix Zijk = asMat(MatRows(Zi, K));
+ DVector U3i(c*c, 1); DMatrix V3i(c*c, c*c), D3i(c*c, q);
+ ord_prep_alpha(PR1, PR2, Mu1, Mu2, Zijk, Ooffsetijk, rev,
+ par, geestr, U3i, V3i, D3i);
+
+ Hi.inc_F(AtBiC(D3i, V3i, D3i));
+ Gi.set_U3(Gi.U3() + AtBiC(D3i, V3i, U3i));
+
+ DVector Zeta = Zi * par.alpha() + Ooffseti; //Z is C^2 x q;
+ DVector Psi = geestr.CorrLinkinv(Zeta);
+ DMatrix U3_Beta = getU3_Beta(Mu1, Mu2, Psi, D1j, D1k, PR1, PR2);
+ Hi.inc_D(AtBiC(D3i, V3i, -1.0 * U3_Beta));
+ }
+ }
+}
+
+void HnandGis(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset,
+ IVector &LinkWave, DMatrix &Z,
+ IVector &Clusz, int c, bool rev,
+ GeeParam &par, GeeStr &geestr, Corr &cor,
+ Hess &Hn, Vector<Grad> &Gis) {
+// Hess H(par), Hi(par); Grad Gi(par);
+// Index1D I(0,0), J(0,0);
+// int N = Clusz.size();
+// for (int i = 1; i <= N; i++) {
+// int s1 = Clusz(i);
+// int s2 = s1 * (s1 - 1) / 2;
+// I = Index1D(1, s1 * c) + I.ubound();
+// if (s2 > 0) J = Index1D(1, s2 * c * c) + J.ubound();
+// Hess Hi(par); Grad Gi(par);
+// HiandGi(Y, X, Offset, Ooffset, LinkWave, Z, s1, c, I, J,
+// par, geestr, cor, Hi, Gi);
+// H.inc(Hi); Gis(i) = Gi;
+// }
+// Hn = (1.0/(double) N) * H;
+ IVector Scur(Y.size() / c); Scur = 1;
+ HnandGis(Y, X, Offset, Ooffset, LinkWave, Z, Clusz, c, rev,
+ par, geestr, cor, Scur, Hn, Gis);
+}
+
+void HnandGis(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset,
+ IVector &LinkWave, DMatrix &Z,
+ IVector &Clusz, int c, bool rev,
+ GeeParam &par, GeeStr &geestr, Corr &cor, IVector &Scur,
+ Hess &Hn, Vector<Grad> &Gis) {
+ Hess H(par), Hi(par); Grad Gi(par);
+ Index1D I(0,0), J(0,0), K(0,0);
+ int N = Clusz.size();
+ for (int i = 1; i <= N; i++) {
+ int s1 = Clusz(i);
+ int s2 = s1 * (s1 - 1) / 2;
+ K = Index1D(1, s1) + K.ubound();
+ I = Index1D(1, s1 * c) + I.ubound();
+ if (s2 > 0) J = Index1D(1, s2 * c * c) + J.ubound();
+
+ IVector Scuri = asVec(VecSubs(Scur, K));
+ int clsz = sum(Scuri); //this is the new cluster size that should be passed down!!!!!!!
+ if (clsz == 0) continue;
+
+ //get dat i
+ DVector Yi = asVec(VecSubs(Y, I));
+ DMatrix Xi = asMat(MatRows(X, I));
+ DVector Offseti = asVec(VecSubs(Offset, I));
+ IVector LinkWavei = asVec(VecSubs(LinkWave, I));
+ DMatrix Zi; DVector Ooffseti;
+
+ if (cor.nparam() == 0 || s2 == 0) {
+ Zi = DMatrix(1,1); Ooffseti = DVector(1);
+ }
+ else {
+ Zi = asMat(MatRows(Z, J));
+ Ooffseti = asVec(VecSubs(Ooffset, J));
+ }
+
+ //valid data i
+ IVector VI = genVI(Scuri, c), VJ = genCrossVI(Scuri, c);
+ DVector VYi = Valid(Yi, VI), VOffseti = Valid(Offseti, VI);
+ IVector VLinkWavei = Valid(LinkWavei, VI);
+ DMatrix VXi = Valid(Xi, VI);
+ DMatrix VZi; DVector VOoffseti;
+ if (cor.nparam() == 0 || clsz == 1) {//clsz == 1: no need to go association
+ VZi = DMatrix(1,1); VOoffseti = DVector(1);
+ }
+ else {
+ VZi = Valid(Zi, VJ);
+ VOoffseti = Valid(Ooffseti, VJ);
+ }
+ Hess Hi(par); Grad Gi(par);
+ HiandGi(VYi, VXi, VOffseti, VOoffseti, VLinkWavei, VZi, clsz, c, rev,
+ par, geestr, cor, Hi, Gi);
+ H.inc(Hi); Gis(i) = Gi;
+ }
+ Hn = (1.0/(double) N) * H;
+}
+
+void ordgee_var(DVector &Y, DMatrix &X, DVector &Offset, DVector &Ooffset,
+ DVector &W, IVector &LinkWave, DMatrix &Z,
+ IVector &Clusz, int c, bool rev,
+ GeeStr &geestr, Corr &cor, GeeParam &par) {
+ int N = Clusz.size(), p = par.p(), q = par.q();
+ Hess Hn(par); Vector<Grad> Gis(N); Grad G0(par); Gis = G0;
+ HnandGis(Y, X, Offset, Ooffset, LinkWave, Z, Clusz, c, rev,
+ par, geestr, cor, Hn, Gis);
+ IVector level(2); level(2) = 1;
+ Hess Hinv = inv(Hn, level);
+ Vector<DVector> Beta_infs(N), Alpha_infs(N);
+ DMatrix VB(p,p), VA(q,q);
+ for (int i = 1; i <= N; i++) {
+ Beta_infs(i) = Hinv.A() * Gis(i).U1();
+ VB = VB + outerprod(Beta_infs(i));
+ if (cor.nparam() == 0) continue;
+ Alpha_infs(i) = Hinv.D() * Gis(i).U1() + Hinv.F() * Gis(i).U3();
+ VA = VA + outerprod(Alpha_infs(i));
+ }
+ par.set_vbeta_naiv(1.0/N * Hinv.A());
+ par.set_vbeta(1.0/N/N * VB);
+ if (cor.nparam() == 0) return;
+
+ //only those cluster with size 2 or more contributes to the variance of alpha
+ //int Nalp = 0;
+ //for (int i = 1; i <= N; i++) if (Clusz(i) > 1) Nalp++;
+ par.set_valpha_naiv(1.0/N * Hinv.F());
+ //par.set_valpha(1.0/Nalp/Nalp * VA);
+ par.set_valpha(1.0/N/N * VA);
+}
+
+void ordgee_top(DVector &Y, DMatrix &X,
+ DVector &Offset, DVector &Ooffset, DVector &W,
+ IVector &LinkWave,
+ DMatrix &Z, IVector &Clusz, int c, bool rev,
+ GeeStr &geestr, Corr &cor, GeeParam &par,
+ Control &con) {
+ ordgee_est(Y, X, Offset, Ooffset, W, LinkWave, Z, Clusz, c, rev,
+ geestr, cor, par, con);
+ ordgee_var(Y, X, Offset, Ooffset, W, LinkWave, Z, Clusz, c, rev,
+ geestr, cor, par);
+}
+
+extern "C" {
+ SEXP ordgee_rap(SEXP y, SEXP x, SEXP offset, SEXP doffset, SEXP w,
+ SEXP linkwave, SEXP z, SEXP clusz, SEXP ncat, SEXP rev,
+ SEXP geestr, SEXP cor, SEXP par, SEXP con) {
+ DVector Y = asDVector(y), Offset = asDVector(offset), Doffset = asDVector(doffset), W = asDVector(w);
+ IVector LinkWave = asIVector(linkwave);
+
+ DMatrix X = asDMatrix(x), Z = asDMatrix(z);
+ IVector Clusz = asIVector(clusz);
+ int C = INTEGER(AS_INTEGER(ncat))[0];
+ bool Rev = LOGICAL(AS_LOGICAL(rev))[0];
+ Control Con = asControl(con);
+ GeeParam Par = asGeeParam(par);
+ GeeStr Geestr = asGeeStr(geestr);
+ Corr Cor = asCorr(cor);
+ ordgee_top(Y, X, Offset, Doffset, W, LinkWave, Z, Clusz, C, Rev, Geestr, Cor, Par, Con);
+ SEXP ans = asSEXP(Par);
+ return ans;
+ }
+}
diff --git a/src/param.cc b/src/param.cc
new file mode 100755
index 0000000..2e8a32b
--- /dev/null
+++ b/src/param.cc
@@ -0,0 +1,64 @@
+using namespace std;
+
+#include "tntsupp.h"
+#include "geese.h"
+#include "param.h"
+
+//class Control
+Control::Control(int trace, int ajs, int j1s, int fij,
+ int maxiter, double tol) :
+ _trace(trace), _ajs(ajs), _j1s(j1s), _fij(fij),
+ _maxiter(maxiter), _tol(tol){}
+Control::Control(int *con, double tol) {
+ _trace = con[0]; _ajs = con[1]; _j1s = con[2]; _fij = con[3];
+ _maxiter = con[4]; _tol = tol;
+}
+Control::Control(const Control &C) :
+ //{
+ _trace(C.trace()), _ajs(C.ajs()), _j1s(C.j1s()),
+ _fij(C.fij()), _maxiter(C.maxiter()), _tol(C.tol()) {}
+ // _trace = C.trace(); _ajs = C.ajs(); _j1s = C.j1s();
+ //_fij = C.fij(); _maxiter = C.maxiter(); _tol = C.tol();
+ //}
+
+//class GeeParam
+GeeParam::GeeParam(DVector Beta, DVector Alpha, DVector Gamma):
+ _beta(Beta), _alpha(Alpha), _gamma(Gamma), _err(0) {
+ int p = Beta.size(), q = Alpha.size(), r = Gamma.size();
+ DMatrix vb(p,p), va(q,q), vg(r,r);
+ _vbeta = vb; _vbeta_naiv = vb; _vbeta_ajs = vb; _vbeta_j1s = vb; _vbeta_fij = vb;
+ _valpha = va; _valpha_naiv = va; _valpha_ajs = va; _valpha_j1s = va; _valpha_fij = va; _valpha_stab = va;
+ _vgamma = vg; _vgamma_ajs = vg; _vgamma_j1s = vg; _vgamma_fij = vg;
+}
+
+GeeParam::GeeParam(DVector Beta, DVector Alpha, DVector Gamma,
+ DMatrix VBeta, DMatrix VBeta_naiv,
+ DMatrix VBeta_ajs, DMatrix VBeta_j1s,
+ DMatrix VBeta_fij,
+ DMatrix VAlpha, DMatrix VAlpha_stab,
+ DMatrix VAlpha_naiv, DMatrix VAlpha_ajs,
+ DMatrix VAlpha_j1s, DMatrix VAlpha_fij,
+ DMatrix VGamma, DMatrix VGamma_ajs,
+ DMatrix VGamma_j1s, DMatrix VGamma_fij):
+ _beta(Beta),
+ _alpha(Alpha),
+ _gamma(Gamma),
+ _vbeta(VBeta), _vbeta_naiv(VBeta_naiv),
+ _vbeta_ajs(VBeta_ajs), _vbeta_j1s(VBeta_j1s),
+ _vbeta_fij(VBeta_fij),
+ _valpha(VAlpha), _valpha_stab(VAlpha_stab),
+ _valpha_naiv(VAlpha_naiv), _valpha_ajs(VAlpha_ajs),
+ _valpha_j1s(VAlpha_j1s), _valpha_fij(VAlpha_fij),
+ _vgamma(VGamma),
+ _vgamma_ajs(VGamma_ajs), _vgamma_j1s(VGamma_j1s),
+ _vgamma_fij(VGamma_fij) {}
+/*
+ GeeParam(int p, int q, double *beta, double *alpha,
+ double *vbeta, double *vbeta_naiv,
+ double *valpha, double *valpha_stab, double *valpha_naiv) {
+ _beta(beta, p);
+ _alpha(alpha, q);
+ _vbeta(vbeta, p, p);
+
+ }
+*/
diff --git a/src/utils.cc b/src/utils.cc
new file mode 100755
index 0000000..62175e2
--- /dev/null
+++ b/src/utils.cc
@@ -0,0 +1,215 @@
+// using namespace std;
+
+extern "C"{
+#include <R.h>
+}
+
+#include <math.h>
+
+#include "tntsupp.h"
+#include "geese.h"
+
+void VecPrint(const DVector &v) {
+ for (int i = 0; i < v.dim(); i++) Rprintf("%f ", v[i]);
+ Rprintf("\n");
+}
+
+Fortran_Matrix<double> ident (int n) {
+ Fortran_Matrix<double> ans(n,n);
+ for (int i = 1; i <= n; i++) ans(i,i) = 1.0;
+ return ans;
+}
+
+Fortran_Matrix<double> MatRowCol(const Fortran_Matrix<double> &mat, const Vector<double> &r, const Vector<double> &c) {
+ int m = r.size(), n = c.size();
+ Fortran_Matrix<double> ans(m,n);
+ for (int i = 1; i <= m; i++)
+ for (int j = 1; j <= n; j++)
+ ans(i,j) = mat((int) r(i), (int) c(j));
+ return ans;
+}
+Fortran_Matrix<double> rho2mat(const Vector<double> &rho) {
+ int s = rho.size(); // s = n(n-1)/2
+ int n = (int) (0.5 * ( 1 + sqrt(1.0 + 8 * s)));
+ Fortran_Matrix<double> fullmat = ident(n);
+ int k = 1;
+ for (int i = 1; i <= n - 1; i++)
+ for (int j = i + 1; j <= n; j++) {
+ fullmat(i, j) = rho(k++);
+ fullmat(j, i) = fullmat(i, j);
+ }
+ return fullmat;
+}
+
+//solve(a, b = ident(n))
+DMatrix solve(const DMatrix &a, const DMatrix &b) {
+ Subscript m = a.dim(1); // assert(m == a.dim(2));
+ Subscript n = b.dim(1); // assert(m == n);
+ Subscript l = b.dim(2);
+ Vector<Subscript> index(m);
+ DMatrix T(a), B(b);
+ DMatrix ans(n,l);
+ if (LU_factor(T, index) != 0) {
+ // cerr << "LU_factor() failed." << endl;
+ return ans;
+ }
+ DVector v(m);
+ for (int i = 1; i <= l; i++) {
+ v = asVec(MatCol(B,i));
+ LU_solve(T, index, v);
+ MatCol(ans, i) = asColMat(v);
+ }
+ return ans;
+}
+
+DVector solve(const DMatrix &A, const DVector &b) {
+ DMatrix T(A); Vector<Subscript> index(b.size());
+ DVector ans(b);
+ if (LU_factor(T, index) !=0) {
+ //cerr << "LU_factor() failed." << endl;
+ return ans;
+ }
+
+ if (LU_solve(T, index, ans) != 0) {
+ //cerr << "LU_Solve() failed." << endl;
+ return ans;
+ }
+ return ans;
+}
+
+DMatrix solve(const DMatrix &a) {
+ DMatrix b = ident(a.dim(1));
+ return solve(a, b);
+}
+
+DMatrix AtBiC(const DMatrix &A, const DMatrix &B, const DMatrix &C) {
+ DMatrix BiC = solve(B, C);
+ return Transpose_view(A) * BiC;
+}
+
+DVector AtBiC(const DMatrix &A, const DMatrix &B, const DVector &C) {
+ DVector BiC = solve(B, C);
+ return Transpose_view(A) * BiC;
+}
+
+
+DMatrix apply_elwise(const DMatrix &x, double f(double)) {
+ DMatrix ans = x;
+ for (int i = 1; i <= x.dim(1); i++)
+ for (int j = 1; j <= x.dim(2); j++)
+ ans(i, j) = f(x(i, j));
+ return ans;
+}
+/*
+DMatrix apply_elwise(DMatrix &x, double f(double)) {
+ return apply_elwise(x, f);
+}
+*/
+
+DVector apply_elwise(const DVector &x, double f(double)) {
+ DVector ans = x;
+ for (int i = 1; i <= x.dim(); i++)
+ ans(i) = f(x(i));
+ return ans;
+}
+
+/*
+DVector apply_elwise(DVector &x, double f(double)) {
+ return apply_elwise(x, f);
+}
+*/
+
+DVector sqrt(const DVector &x) {
+ return apply_elwise(x, sqrt);
+}
+
+double square(double x) {
+ return x * x;
+}
+
+DVector square(const DVector &x) {
+ return apply_elwise(x, square);
+}
+
+double reciproot(double x) {
+ return 1./sqrt(x);
+}
+
+
+DVector reciproot(const DVector &x) {
+ return apply_elwise(x, reciproot);
+}
+
+double recip(double x) {return 1./x;}
+
+DVector recip(const DVector &x) {
+ return apply_elwise(x, recip);
+}
+
+int cluscount(DVector &ID) {
+ int ans = 1;
+ for (int i = 1; i < ID.dim(); i++)
+ if (ID(i - 1) != ID(i)) ans++;
+ return ans;
+}
+
+Vector<int> clussize(DVector &ID) {
+ int K = ID.size();
+ Vector<int> ans(K);
+ ans = 1;
+ //double id = ID(0);
+ int k = 1;
+ for (int i = 1; i <= (ID.dim() - 1); i++) {
+ if (ID(i + 1) == ID(i)) ans(k) += 1;
+ else k++;
+ }
+ return ans;
+}
+
+DVector SMult(const DVector &v1, const DVector &v2) {
+ // assert (v1.dim() == v2.dim());
+ DVector ans = v1;
+ for (int i = 1; i <= v1.dim(); i++)
+ ans(i) = v1(i) * v2(i);
+ return ans;
+}
+
+DMatrix SMult(const DVector &v, const DMatrix &m) {
+ // assert (v.dim() == m.dim(1));
+ DMatrix tmp = m;
+ for (int i = 1; i <= m.dim(1); i++)
+ for (int j = 1; j <= m.dim(2); j++)
+ tmp(i, j) = v(i) * m(i, j);
+ return tmp;
+}
+
+DMatrix operator*(const DVector &v, const DMatrix &m) {
+ return SMult(v, m);
+}
+
+
+DMatrix diag(const DVector &v) {
+ int n = v.dim();
+ DMatrix ans(n, n); ans = .0;
+ for (int i = 1; i <= n; i++) ans(i, i) = v(i);
+ return ans;
+}
+
+DVector diag(const DMatrix &m) {
+ int n = m.dim(1); //assert m.dim(0) == m.dim(1);
+ DVector ans(n); ans = .0;
+ for (int i = 1; i <= n; i++) ans(i) = m(i,i);
+ return ans;
+}
+
+DMatrix inv(const DMatrix &x) {
+ return solve(x);
+}
+
+DMatrix fabs(const DMatrix &m) {
+ return apply_elwise(m, fabs);
+}
+
+DVector fabs(const DVector &v) {
+ return apply_elwise(v, fabs);
+}
diff --git a/vignettes/geepack-manual.Rnw b/vignettes/geepack-manual.Rnw
new file mode 100755
index 0000000..d8d88aa
--- /dev/null
+++ b/vignettes/geepack-manual.Rnw
@@ -0,0 +1,196 @@
+% \VignetteIndexEntry{Users guide to geepack}
+% \VignetteKeyword{Generalized Estimating Equation}
+% \VignetteKeyword{Working correlation matrix}
+
+\documentclass{article}
+\usepackage{boxedminipage,color,a4,shortvrb,hyperref}
+\usepackage[latin1]{inputenc}
+\usepackage[T1]{fontenc}
+\MakeShortVerb|
+
+\def\pkg#1{{\bf #1}}
+
+
+<<echo=FALSE,print=FALSE>>=
+require( geepack )
+prettyVersion <- packageDescription("geepack")$Version
+prettyDate <- format(Sys.Date())
+@
+
+\SweaveOpts{keep.source=T,prefix.string=figures/LSmeans}
+
+\title{On the usage of the \texttt{geepack} }
+\author{S{\o}ren H{\o}jsgaard and Ulrich Halekoh}
+\date{\pkg{geepack} version \Sexpr{prettyVersion} as of \Sexpr{prettyDate}}
+
+
+\begin{document}
+
+\parindent0pt\parskip4pt
+
+%% Efter preamble
+\definecolor{myGray}{rgb}{0.95,0.95,0.95}
+\makeatletter
+\renewenvironment{Schunk}{
+ \begin{lrbox}{\@tempboxa}
+ \begin{boxedminipage}
+ {\columnwidth}\scriptsize}
+ {\end{boxedminipage}
+ \end{lrbox}%
+ \colorbox{myGray}{\usebox{\@tempboxa}}
+}
+\makeatother
+
+\maketitle
+
+\section{Introduction}
+\label{sec:intro}
+
+
+The primary reference for the |geepack| package is the Halekoh, U.,
+H�jsgaard, S., Yan, J. (2006) -- paper in Journal of Statistical
+Software, see
+
+@
+<<>>=
+library(geepack)
+citation("geepack")
+@ %def
+
+If you use |geepack| in your own work, please do cite the above
+reference.
+
+
+This note contains a few extra examples. We illustrate the usage of a
+the |waves| argument and the |zcor| argument together with a fixed
+working correlation matrix for the |geeglm()| function. To illustrate
+these features we simulate some data suitable for a regression model.
+
+@
+<<>>=
+library(geepack)
+timeorder <- rep(1:5, 6)
+tvar <- timeorder + rnorm(length(timeorder))
+idvar <- rep(1:6, each=5)
+uuu <- rep(rnorm(6), each=5)
+yvar <- 1 + 2*tvar + uuu + rnorm(length(tvar))
+simdat <- data.frame(idvar, timeorder, tvar, yvar)
+head(simdat,12)
+@ %def
+
+Notice that clusters of data appear together in |simdat| and that
+observations are ordered (according to |timeorder|) within clusters.
+
+We can fit a model with an AR(1) error structure as
+
+@
+<<>>=
+mod1 <- geeglm(yvar~tvar, id=idvar, data=simdat, corstr="ar1")
+mod1
+@ %def
+
+This works because observations are ordered according to time within
+each subject in the dataset.
+
+
+
+
+\section{Using the \texttt{waves} argument}
+\label{sec:xxx}
+
+
+If observatios were not ordered according to cluster and time within
+cluster we would get the
+wrong result:
+
+@
+<<>>=
+set.seed(123)
+## library(doBy)
+simdatPerm <- simdat[sample(nrow(simdat)),]
+## simdatPerm <- orderBy(~idvar, simdatPerm)
+simdatPerm <- simdatPerm[order(simdatPerm$idvar),]
+head(simdatPerm)
+@ %def
+
+Notice that in |simdatPerm| data is ordered according to subject but
+the time ordering within subject is random.
+
+Fitting the model as
+before gives
+
+@
+<<>>=
+mod2 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="ar1")
+mod2
+@ %def
+
+Likewise if clusters do not appear contigously in data we also get the
+wrong result (the clusters are not recognized):
+
+@
+<<>>=
+## simdatPerm2 <- orderBy(~timeorder, data=simdat)
+simdatPerm2 <- simdat[order(simdat$timeorder),]
+geeglm(yvar~tvar, id=idvar, data=simdatPerm2, corstr="ar1")
+@ %def
+
+
+
+
+
+
+
+
+To obtain the right result we must give the |waves| argument:
+
+@
+<<>>=
+wav <- simdatPerm$timeorder
+wav
+mod3 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="ar1", waves=wav)
+mod3
+@ %def
+
+\section{Using a fixed correlation matrix and the \texttt{zcor} argument}
+\label{sec:xxx}
+
+Suppose we want to use a fixed working correlation matrix:
+
+@
+<<>>=
+cor.fixed <- matrix(c(1 , 0.5 , 0.25, 0.125, 0.125,
+ 0.5 , 1 , 0.25, 0.125, 0.125,
+ 0.25 , 0.25 , 1 , 0.5 , 0.125,
+ 0.125, 0.125, 0.5 , 1 , 0.125,
+ 0.125, 0.125, 0.125, 0.125, 1 ), 5, 5)
+cor.fixed
+@ %def
+
+Such a working correlation matrix has to be passed to |geeglm()| as a
+vector in the |zcor| argument. This vector can be created using the
+|fixed2Zcor()| function:
+
+@
+<<>>=
+zcor <- fixed2Zcor(cor.fixed, id=simdatPerm$idvar, waves=simdatPerm$timeorder)
+zcor
+@ %def
+
+Notice that |zcor| contains correlations between measurements within
+the same cluster. Hence if a cluster contains only one observation,
+then there will be generated no entry in |zcor| for that cluster. Now
+we can fit the model with:
+
+@
+<<>>=
+mod4 <- geeglm(yvar~tvar, id=idvar, data=simdatPerm, corstr="fixed", zcor=zcor)
+mod4
+@ %def
+
+
+
+
+
+
+\end{document}
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/r-cran-geepack.git
More information about the debian-science-commits
mailing list